From e5f1166e7394893364e4e5f06d78df5c75cf4a96 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Mon, 30 Nov 2020 12:08:03 -0800 Subject: [PATCH] import benchmarks and tests from Envos 1993 history to start refurbishing --- internal/gabriel/00-README.txt | 211 +++++ internal/gabriel/00-README.txt.~1~ | 209 +++++ .../gabriel/Results/KOTO-DANDELION.BENCHMARKS | 1 + .../gabriel/Results/KOTO-DORADO.BENCHMARKS | 1 + internal/gabriel/Results/KOTO-DOVE.BENCHMARKS | 1 + .../gabriel/Results/Lyric/ALL-PAV.BENCHMARKS | 1 + .../Results/Lyric/AREFY-PAV.BENCHMARKS | 1 + .../Results/Lyric/CONSY-BYTE.BENCHMARKS | 1 + .../Results/Lyric/CONSY-PAV.BENCHMARKS | 1 + .../Results/Lyric/EXTRAS-BYTE.BENCHMARKS | 1 + .../Results/Lyric/EXTRAS-PAV.BENCHMARKS | 1 + .../gabriel/Results/Lyric/File-Servers.TEdit | Bin 0 -> 20604 bytes .../gabriel/Results/Lyric/IO-BYTE.BENCHMARKS | 1 + .../gabriel/Results/Lyric/IO-PAV.BENCHMARKS | 1 + internal/gabriel/Results/Lyric/RESULTS.TEDIT | Bin 0 -> 6367 bytes .../gabriel/Results/Lyric/SUMMARY-5-27.TEDIT | Bin 0 -> 9686 bytes .../gabriel/Results/Lyric/TAK-BYTE.BENCHMARKS | 1 + .../gabriel/Results/Lyric/TAK-PAV.BENCHMARKS | 1 + .../gabriel/Results/Lyric/all-byte.benchmarks | 1 + .../Results/Lyric/arefy-byte.benchmarks | 1 + .../Results/Lyric/byte-5-24.benchmarks | 1 + .../Results/Lyric/byte-5-26.benchmarks | 1 + .../gabriel/Results/Lyric/lyric-results.tedit | Bin 0 -> 2480 bytes .../gabriel/Results/Lyric/pav-5-25.benchmarks | 1 + .../gabriel/Results/Lyric/pav-5-26.benchmarks | 1 + internal/gabriel/Results/Lyric/summary.tedit | Bin 0 -> 5005 bytes .../Results/Maiko-Pav-06-14-88.benchmarks | 1 + .../Results/Maiko/1132-BYTE-TAK.Results | 1 + .../Results/Maiko/1132-PAV-TAK.Results | 1 + .../Results/Maiko/1186-BYTE-CONSY.Results | 1 + .../gabriel/Results/Maiko/1186-IO.Results | 1 + .../Results/Maiko/1186-PAV-AREFY.Results | 1 + .../Results/Maiko/1186-PAV-CONSY.Results | 1 + .../Results/Maiko/1186-PAV-TAK.Results | 1 + .../Results/Maiko/SUN-BYTE-AREFY.RESULTS | 1 + .../Results/Maiko/SUN-BYTE-ARITH.RESULTS | 1 + .../Results/Maiko/SUN-BYTE-CONSY.RESULTS | 1 + .../Results/Maiko/SUN-BYTE-TAK.RESULTS | 1 + internal/gabriel/Results/Maiko/SUN-IO.Results | 1 + .../gabriel/Results/Maiko/SUN-IO.Results.~14~ | 1 + .../gabriel/Results/Maiko/SUN-IO.Results.~1~ | 1 + .../Results/Maiko/SUN-PAV-AREFY.Results | 1 + .../Results/Maiko/SUN-PAV-ARITH.Results | 1 + .../Results/Maiko/SUN-PAV-ARITH.Results.~10~ | 1 + .../Results/Maiko/SUN-PAV-ARITH.Results.~1~ | 1 + .../Results/Maiko/SUN-PAV-CONSY.Results | 1 + .../Results/Maiko/SUN-PAV-MISC.Results | 1 + .../Results/Maiko/SUN-PAV-POLY.Results | 1 + .../gabriel/Results/Maiko/SUN-PAV-TAK.Results | 1 + .../Results/Maiko/SUN-PAV-TAK.Results.~16~ | 1 + .../Results/Maiko/SUN-PAV-TAK.Results.~1~ | 1 + .../gabriel/Results/Maiko/win-tak.results | 1 + .../gabriel/Results/Maiko/win-tak.results.~1~ | 1 + .../gabriel/Results/Maiko/win-tak.results.~2~ | 1 + .../gabriel/Results/Maiko/x86-arefy.results | 1 + .../gabriel/Results/Maiko/x86-arith.results | 1 + .../Results/Maiko/x86-byte-tak.results | 1 + .../gabriel/Results/Maiko/x86-consy.results | 1 + .../gabriel/Results/Maiko/x86-poly.results | 1 + .../Results/Medley/BYTE-AREFY-1186.RESULTS | 1 + .../Results/Medley/BYTE-CONSY-1186.RESULTS | 1 + .../Results/Medley/BYTE-IO-1186.RESULTS | 1 + .../Results/Medley/BYTE-TAK-1186.RESULTS | 1 + .../Results/SUMMARY-TIME-SERIES2.tedit | Bin 0 -> 7448 bytes .../Results/SUMMARY-TIME-SERIES3.tedit | Bin 0 -> 7954 bytes .../Results/SUMMARY-TIME-SERIES4.Tedit | Bin 0 -> 7614 bytes .../gabriel/Results/Summary-Time-Series.TEdit | Bin 0 -> 8370 bytes internal/gabriel/Results/koto-1108.benchmarks | 1 + internal/gabriel/admin/Result-Log-Form.TEdit | Bin 0 -> 3551 bytes internal/gabriel/aux/1000-SYMBOLS | 1 + internal/gabriel/aux/2000-FLOATS-TO-READ | 1 + internal/gabriel/benchmarks/ARITH-BENCHMARKS | 1 + .../gabriel/benchmarks/ARITH-BENCHMARKS.DFASL | Bin 0 -> 4416 bytes .../benchmarks/ARITH-BENCHMARKS.DFASL.~1~ | Bin 0 -> 4138 bytes .../benchmarks/ARITH-BENCHMARKS.DFASL.~2~ | Bin 0 -> 2538 bytes .../benchmarks/ARITH-BENCHMARKS.DFASL.~3~ | Bin 0 -> 4242 bytes .../benchmarks/ARITH-BENCHMARKS.DFASL.~4~ | Bin 0 -> 4416 bytes .../benchmarks/ARITH-BENCHMARKS.DFASL.~5~ | Bin 0 -> 4416 bytes .../gabriel/benchmarks/ARITH-BENCHMARKS.LCOM | Bin 0 -> 4889 bytes internal/gabriel/benchmarks/GABRIEL-OTHER | 1 + .../gabriel/benchmarks/GABRIEL-OTHER.LCOM | Bin 0 -> 43889 bytes .../gabriel/benchmarks/GABRIEL-OTHER.dfasl | Bin 0 -> 47097 bytes .../benchmarks/GABRIEL-OTHER.dfasl.~1~ | Bin 0 -> 44664 bytes .../benchmarks/GABRIEL-OTHER.dfasl.~2~ | Bin 0 -> 45996 bytes .../benchmarks/GABRIEL-OTHER.dfasl.~3~ | Bin 0 -> 47090 bytes .../benchmarks/GABRIEL-OTHER.dfasl.~4~ | Bin 0 -> 47097 bytes internal/gabriel/benchmarks/GABRIEL-TAK | 1 + internal/gabriel/benchmarks/GABRIEL-TAK.LCOM | Bin 0 -> 16484 bytes internal/gabriel/benchmarks/GABRIEL-TAK.dfasl | Bin 0 -> 15218 bytes .../gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ | Bin 0 -> 13986 bytes .../gabriel/benchmarks/GABRIEL-TAK.dfasl.~2~ | Bin 0 -> 14666 bytes .../gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ | Bin 0 -> 15218 bytes .../gabriel/benchmarks/GABRIEL-TAK.dfasl.~4~ | Bin 0 -> 15218 bytes internal/gabriel/benchmarks/IO-BENCHMARKS | 1 + .../gabriel/benchmarks/IO-BENCHMARKS.DFASL | Bin 0 -> 14045 bytes .../benchmarks/IO-BENCHMARKS.DFASL.~1~ | Bin 0 -> 14051 bytes .../benchmarks/IO-BENCHMARKS.DFASL.~2~ | Bin 0 -> 14045 bytes .../gabriel/benchmarks/IO-BENCHMARKS.LCOM | 1 + .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~1~ | Bin 0 -> 17977 bytes .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~2~ | Bin 0 -> 17909 bytes .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ | Bin 0 -> 17907 bytes .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~5~ | 140 +++ .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~6~ | Bin 0 -> 18045 bytes .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~7~ | 1 + .../gabriel/benchmarks/IO-BENCHMARKS.LCOM.~8~ | 1 + internal/gabriel/benchmarks/IO-BENCHMARKS.~1~ | 1 + internal/gabriel/benchmarks/IO-BENCHMARKS.~2~ | 1 + internal/gabriel/benchmarks/IO-BENCHMARKS.~3~ | 1 + internal/gabriel/benchmarks/IO-BENCHMARKS.~4~ | 1 + internal/gabriel/benchmarks/MISC-BENCHMARKS | 1 + .../gabriel/benchmarks/MISC-BENCHMARKS.DFASL | Bin 0 -> 4051 bytes .../benchmarks/MISC-BENCHMARKS.DFASL.~1~ | Bin 0 -> 3798 bytes .../benchmarks/MISC-BENCHMARKS.DFASL.~2~ | Bin 0 -> 3895 bytes .../benchmarks/MISC-BENCHMARKS.DFASL.~3~ | Bin 0 -> 4051 bytes .../gabriel/benchmarks/MISC-BENCHMARKS.LCOM | 22 + .../benchmarks/Medley/GABRIEL-OTHER.DFASL | Bin 0 -> 48275 bytes .../benchmarks/Medley/GABRIEL-OTHER.LCOM | Bin 0 -> 47258 bytes .../benchmarks/Medley/GABRIEL-TAK.DFASL | Bin 0 -> 13986 bytes .../benchmarks/Medley/GABRIEL-TAK.LCOM | Bin 0 -> 16484 bytes .../benchmarks/Medley/GABRIEL-TIMERS.LCOM | Bin 0 -> 12280 bytes .../benchmarks/RUNNING-BENCHMARKS.DRIBBLE | 1 + internal/gabriel/interlisp/1186BENCHMARKS | 0 internal/gabriel/interlisp/BENCHMARK | 1 + internal/gabriel/interlisp/BOYER | 5 + internal/gabriel/interlisp/BROWSE | 1 + internal/gabriel/interlisp/CTAK | 1 + internal/gabriel/interlisp/DDERIV | 1 + internal/gabriel/interlisp/DERIV | 1 + internal/gabriel/interlisp/DERIV.LCOM | Bin 0 -> 1533 bytes internal/gabriel/interlisp/DESTRUCTIVE | 1 + internal/gabriel/interlisp/DESTRUCTIVE.LCOM | Bin 0 -> 1091 bytes internal/gabriel/interlisp/DIV2 | 1 + internal/gabriel/interlisp/DIV2.LCOM | Bin 0 -> 1259 bytes internal/gabriel/interlisp/FFT | 1 + internal/gabriel/interlisp/FPRINT | 1 + internal/gabriel/interlisp/FPRINT.TST | 1 + internal/gabriel/interlisp/FREAD | 1 + internal/gabriel/interlisp/POLY | 1 + internal/gabriel/interlisp/PUZZLE | 1 + internal/gabriel/interlisp/STAK | 1 + internal/gabriel/interlisp/TAK | 1 + internal/gabriel/interlisp/TAKL | 1 + internal/gabriel/interlisp/TAKR | 1 + internal/gabriel/interlisp/TESTPATTERN | 1 + internal/gabriel/interlisp/TPRINT | 1 + internal/gabriel/interlisp/TRAVERSE | 1 + internal/gabriel/interlisp/TRAVERSE.LCOM | Bin 0 -> 3120 bytes internal/gabriel/interlisp/TRIANG | 1 + .../gabriel/interlisp/benchmarkmemo.tedit | Bin 0 -> 8737 bytes internal/gabriel/interlisp/dderiv.lcom | Bin 0 -> 2294 bytes internal/gabriel/tools/BENCH-1 | 1 + internal/gabriel/tools/BENCH-1.~1~ | 1 + internal/gabriel/tools/BENCH-1.~2~ | 1 + internal/gabriel/tools/BENCH-1.~3~ | 1 + internal/gabriel/tools/BENCH-2 | 1 + internal/gabriel/tools/BENCH-2.~1~ | 1 + internal/gabriel/tools/BENCH-2.~2~ | 1 + internal/gabriel/tools/BENCH-3 | 1 + internal/gabriel/tools/BENCH-3.~1~ | 1 + internal/gabriel/tools/BENCH-3.~2~ | 1 + internal/gabriel/tools/BENCH-386 | 1 + internal/gabriel/tools/BENCH-4 | 1 + internal/gabriel/tools/BENCH-4.~1~ | 1 + internal/gabriel/tools/BENCH-4.~2~ | 1 + internal/gabriel/tools/BENCH-5 | 1 + internal/gabriel/tools/BENCH-5.~1~ | 1 + internal/gabriel/tools/BENCH-5.~2~ | 1 + internal/gabriel/tools/GABRIEL-TIMERS | 1 + internal/gabriel/tools/GABRIEL-TIMERS.LCOM | 1 + .../gabriel/tools/GABRIEL-TIMERS.LCOM.~1~ | Bin 0 -> 12280 bytes .../gabriel/tools/GABRIEL-TIMERS.LCOM.~2~ | 132 +++ .../gabriel/tools/GABRIEL-TIMERS.LCOM.~3~ | 1 + internal/gabriel/tools/GABRIEL-TIMERS.dfasl | Bin 0 -> 10847 bytes .../gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ | Bin 0 -> 10042 bytes .../gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ | Bin 0 -> 10456 bytes .../gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ | Bin 0 -> 10847 bytes .../gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ | Bin 0 -> 10847 bytes internal/gabriel/tools/TESTVARS | 1 + internal/test/.read-me-first | Bin 0 -> 6426 bytes .../4045/Hand-Aux/Justification-TEst.TEdit | Bin 0 -> 3777 bytes internal/test/ARs/.read-me-first | Bin 0 -> 704 bytes internal/test/ARs/.read-me-first.~1~ | Bin 0 -> 695 bytes internal/test/ARs/.read-me-first.~2~ | Bin 0 -> 704 bytes .../ARs/AR-Test-Case-Summary-Template.TEdit | Bin 0 -> 2211 bytes internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log | 1 + internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT | Bin 0 -> 63780 bytes .../test/GC/HAND-AUX/DANCER10-C0.DISPLAYFONT | Bin 0 -> 7040 bytes .../test/GC/HAND-AUX/Dancer12-C0.DisplayFont | Bin 0 -> 3662 bytes internal/test/GC/HAND-AUX/dancer10-C0.WD | Bin 0 -> 554 bytes internal/test/GC/HAND-AUX/dancer12-c0.wd | Bin 0 -> 298 bytes internal/test/GC/Hand/DANCEROBJ | 1 + internal/test/GC/Hand/DANCEROBJ.LCOM | Bin 0 -> 28972 bytes internal/test/GC/Hand/MAIKO-GC-TESTS | 1 + internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE | 1 + internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM | Bin 0 -> 26755 bytes internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ | 1 + internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ | 1 + internal/test/GC/Hand/Maiko-GC-Tests.script | 1 + internal/test/IO/Auto/IO-REGRESSION.TEST | Bin 0 -> 1251 bytes internal/test/IO/Auto/MSPF.TEST | Bin 0 -> 8655 bytes internal/test/IO/Auto/Peekbin.test | 1 + .../test/IO/Hand-Aux/AR11004-Arith-OFlow.IP | Bin 0 -> 8571 bytes internal/test/LANGUAGE/AUTO/.read-me-first | 1 + .../test/LANGUAGE/AUTO/.read-me-first.~1~ | Bin 0 -> 3878 bytes .../test/LANGUAGE/AUTO/.read-me-first.~2~ | 1 + .../LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL | Bin 0 -> 2281 bytes .../LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST | 1 + internal/test/LANGUAGE/AUTO/10-1-GET.DFASL | Bin 0 -> 3451 bytes internal/test/LANGUAGE/AUTO/10-1-GET.TEST | 1 + internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL | Bin 0 -> 3125 bytes internal/test/LANGUAGE/AUTO/10-1-GETF.TEST | 1 + internal/test/LANGUAGE/AUTO/10-1-REMF.DFASL | Bin 0 -> 2372 bytes internal/test/LANGUAGE/AUTO/10-1-REMF.TEST | 1 + .../test/LANGUAGE/AUTO/10-1-REMPROP.DFASL | Bin 0 -> 2151 bytes internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST | 1 + .../LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL | Bin 0 -> 3305 bytes .../test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.TEST | 1 + .../test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL | Bin 0 -> 1905 bytes .../test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST | 1 + .../test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL | Bin 0 -> 2398 bytes .../test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST | 1 + internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL | Bin 0 -> 4870 bytes internal/test/LANGUAGE/AUTO/10-3-GENSYM.TEST | Bin 0 -> 2645 bytes .../test/LANGUAGE/AUTO/10-3-GENTEMP.DFASL | Bin 0 -> 6087 bytes internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST | 1 + .../test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL | Bin 0 -> 1780 bytes .../test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST | 1 + .../test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL | Bin 0 -> 1755 bytes .../test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST | 1 + .../LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL | Bin 0 -> 1860 bytes .../LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST | 1 + internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL | Bin 0 -> 1851 bytes internal/test/LANGUAGE/AUTO/11-6-IMPORT.TEST | 1 + .../LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL | Bin 0 -> 1431 bytes .../LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST | 1 + .../AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL | Bin 0 -> 1547 bytes .../AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST | 1 + .../test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL | Bin 0 -> 3043 bytes .../test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST | 1 + internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL | Bin 0 -> 1130 bytes internal/test/LANGUAGE/AUTO/11-7-EXPORT.TEST | 1 + .../LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL | Bin 0 -> 848 bytes .../LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.TEST | 1 + .../LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL | Bin 0 -> 1379 bytes .../test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.TEST | 1 + .../test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL | Bin 0 -> 1100 bytes .../test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.TEST | 1 + internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL | Bin 0 -> 2140 bytes internal/test/LANGUAGE/AUTO/11-7-IMPORT.TEST | 1 + .../test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL | Bin 0 -> 989 bytes .../test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST | 1 + internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL | Bin 0 -> 1401 bytes internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST | 1 + .../AUTO/11-7-LIST-ALL-PACKAGES.DFASL | Bin 0 -> 1196 bytes .../LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.TEST | 1 + .../LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL | Bin 0 -> 2044 bytes .../test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST | 1 + .../LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL | Bin 0 -> 1225 bytes .../test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST | 1 + .../AUTO/11-7-PACKAGE-NICKNAMES.DFASL | Bin 0 -> 1342 bytes .../LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST | 1 + .../AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL | Bin 0 -> 1323 bytes .../AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST | 1 + .../LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL | Bin 0 -> 1366 bytes .../LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.TEST | 1 + .../AUTO/11-7-PACKAGE-USED-BY-LIST.DFASL | Bin 0 -> 1179 bytes .../AUTO/11-7-PACKAGE-USED-BY-LIST.TEST | 1 + .../LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL | Bin 0 -> 1525 bytes .../LANGUAGE/AUTO/11-7-RENAME-PACKAGE.TEST | 1 + internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL | Bin 0 -> 1113 bytes internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST | 1 + .../LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL | Bin 0 -> 2411 bytes .../LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.TEST | 1 + .../test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL | Bin 0 -> 1569 bytes .../test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST | 1 + .../test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL | Bin 0 -> 2311 bytes .../test/LANGUAGE/AUTO/11-7-UNINTERN.TEST | 1 + .../LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL | Bin 0 -> 1058 bytes .../LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST | 1 + .../test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL | Bin 0 -> 972 bytes .../test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST | 1 + .../test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL | Bin 0 -> 1342 bytes internal/test/LANGUAGE/AUTO/11-8-PROVIDE.TEST | 1 + .../12-10-IMPLEMENTATION-PARAMETERS.DFASL | Bin 0 -> 2135 bytes .../AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST | 1 + internal/test/LANGUAGE/AUTO/12-2-EVENP.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-2-EVENP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-2-EVENP.TST | Bin 0 -> 674 bytes internal/test/LANGUAGE/AUTO/12-2-MINUSP.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-2-MINUSP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST | Bin 0 -> 716 bytes internal/test/LANGUAGE/AUTO/12-2-ODDP.DFASL | Bin 0 -> 767 bytes internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-2-ODDP.TST | Bin 0 -> 675 bytes internal/test/LANGUAGE/AUTO/12-2-PLUSP.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST | Bin 0 -> 702 bytes internal/test/LANGUAGE/AUTO/12-2-ZEROP.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-2-ZEROP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT | Bin 0 -> 722 bytes internal/test/LANGUAGE/AUTO/12-3-EQP.DFASL | Bin 0 -> 767 bytes internal/test/LANGUAGE/AUTO/12-3-EQP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST | 1 + .../test/LANGUAGE/AUTO/12-3-GREATERP.DFASL | Bin 0 -> 775 bytes .../test/LANGUAGE/AUTO/12-3-GREATERP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/12-3-LEQ.TEST | 1 + internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL | Bin 0 -> 754 bytes internal/test/LANGUAGE/AUTO/12-3-MAX.TEST | 1 + internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/12-3-MIN.TEST | 1 + .../AUTO/12-3-MONOTONIC-NONDECREASE.TEST | Bin 0 -> 1021 bytes .../AUTO/12-3-MONOTONIC-NONINCREASE.TEST | Bin 0 -> 1020 bytes internal/test/LANGUAGE/AUTO/12-3-NEQP.DFASL | Bin 0 -> 767 bytes internal/test/LANGUAGE/AUTO/12-3-NEQP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-+.DFASL | Bin 0 -> 1100 bytes internal/test/LANGUAGE/AUTO/12-4-+.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4--.DFASL | Bin 0 -> 1103 bytes internal/test/LANGUAGE/AUTO/12-4--.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-1+.DFASL | Bin 0 -> 752 bytes internal/test/LANGUAGE/AUTO/12-4-1+.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-1-.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/12-4-1-.TEST | 1 + .../test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL | Bin 0 -> 777 bytes .../test/LANGUAGE/AUTO/12-4-CONJUGATE.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL | Bin 0 -> 895 bytes internal/test/LANGUAGE/AUTO/12-4-DECF.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/12-4-GCD.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL | Bin 0 -> 895 bytes internal/test/LANGUAGE/AUTO/12-4-INCF.TEST | 1 + internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL | Bin 0 -> 1874 bytes internal/test/LANGUAGE/AUTO/12-4-LCM.TEST | 1 + .../test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL | Bin 0 -> 823 bytes .../test/LANGUAGE/AUTO/12-4-QUOTIENT.TEST | Bin 0 -> 2128 bytes internal/test/LANGUAGE/AUTO/12-4-TIMES.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL | Bin 0 -> 1002 bytes internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL | Bin 0 -> 1028 bytes internal/test/LANGUAGE/AUTO/12-5-1-EXPT.TEST | 1 + .../test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL | Bin 0 -> 1066 bytes internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL | Bin 0 -> 767 bytes internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL | Bin 0 -> 1995 bytes internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST | 1 + .../test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL | Bin 0 -> 2078 bytes internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL | Bin 0 -> 1995 bytes internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST | 1 + .../test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL | Bin 0 -> 2052 bytes internal/test/LANGUAGE/AUTO/12-5-2-ASINH.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL | Bin 0 -> 1872 bytes internal/test/LANGUAGE/AUTO/12-5-2-ATAN.TEST | 1 + .../test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL | Bin 0 -> 2648 bytes internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL | Bin 0 -> 2111 bytes internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL | Bin 0 -> 2252 bytes internal/test/LANGUAGE/AUTO/12-5-2-COS.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL | Bin 0 -> 2015 bytes internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST | 1 + .../test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL | Bin 0 -> 2300 bytes internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST | 1 + .../test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL | Bin 0 -> 2520 bytes .../test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL | Bin 0 -> 2252 bytes internal/test/LANGUAGE/AUTO/12-5-2-SIN.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL | Bin 0 -> 2006 bytes internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL | Bin 0 -> 2164 bytes internal/test/LANGUAGE/AUTO/12-5-2-TAN.TEST | 1 + internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL | Bin 0 -> 2021 bytes internal/test/LANGUAGE/AUTO/12-5-2-TANH.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-CEILING.DFASL | Bin 0 -> 1650 bytes internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL | Bin 0 -> 773 bytes internal/test/LANGUAGE/AUTO/12-6-COMPLEX.TEST | 1 + .../LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL | Bin 0 -> 1873 bytes .../test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL | Bin 0 -> 781 bytes .../test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-FCEILING.DFASL | Bin 0 -> 1728 bytes .../test/LANGUAGE/AUTO/12-6-FCEILING.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL | Bin 0 -> 1710 bytes internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST | 1 + .../LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL | Bin 0 -> 1622 bytes .../test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.TEST | 1 + .../LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL | Bin 0 -> 1623 bytes .../LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL | Bin 0 -> 1645 bytes .../test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL | Bin 0 -> 2192 bytes .../test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL | Bin 0 -> 769 bytes internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL | Bin 0 -> 1640 bytes internal/test/LANGUAGE/AUTO/12-6-FLOOR.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL | Bin 0 -> 1686 bytes internal/test/LANGUAGE/AUTO/12-6-FROUND.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL | Bin 0 -> 1737 bytes .../test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL | Bin 0 -> 775 bytes .../test/LANGUAGE/AUTO/12-6-IMAGPART.TEST | 1 + .../AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL | Bin 0 -> 2150 bytes .../AUTO/12-6-INTEGER-DECODE-FLOAT.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL | Bin 0 -> 1594 bytes internal/test/LANGUAGE/AUTO/12-6-MOD.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL | Bin 0 -> 777 bytes .../test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL | Bin 0 -> 824 bytes .../test/LANGUAGE/AUTO/12-6-RATIONAL.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL | Bin 0 -> 809 bytes .../test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-REALPART.DFASL | Bin 0 -> 775 bytes .../test/LANGUAGE/AUTO/12-6-REALPART.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-REM.DFASL | Bin 0 -> 1594 bytes internal/test/LANGUAGE/AUTO/12-6-REM.TEST | 1 + internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL | Bin 0 -> 1612 bytes internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL | Bin 0 -> 2026 bytes .../test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST | 1 + .../test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL | Bin 0 -> 1659 bytes .../test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/12-7-ASH.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL | Bin 0 -> 10420 bytes internal/test/LANGUAGE/AUTO/12-7-BOOLE.TEST | Bin 0 -> 11759 bytes .../LANGUAGE/AUTO/12-7-INTEGER-LENGTH.DFASL | Bin 0 -> 787 bytes .../LANGUAGE/AUTO/12-7-INTEGER-LENGTH.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL | Bin 0 -> 775 bytes .../test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL | Bin 0 -> 775 bytes .../test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL | Bin 0 -> 791 bytes internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL | Bin 0 -> 775 bytes .../test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-7-LOGEQV.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL | Bin 0 -> 773 bytes internal/test/LANGUAGE/AUTO/12-7-LOGNAND.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL | Bin 0 -> 773 bytes internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL | Bin 0 -> 773 bytes internal/test/LANGUAGE/AUTO/12-7-LOGORC2.TEST | 1 + .../test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL | Bin 0 -> 773 bytes internal/test/LANGUAGE/AUTO/12-7-LOGTEST.TEST | 1 + internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL | Bin 0 -> 771 bytes internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST | 1 + .../LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL | Bin 0 -> 1422 bytes .../LANGUAGE/AUTO/12-8-BYTE-POSITION.TEST | 1 + .../test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL | Bin 0 -> 1412 bytes .../test/LANGUAGE/AUTO/12-8-BYTE-SIZE.TEST | 1 + internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL | Bin 0 -> 1874 bytes internal/test/LANGUAGE/AUTO/12-8-BYTE.TEST | 1 + .../LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL | Bin 0 -> 785 bytes .../LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST | 1 + internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL | Bin 0 -> 1541 bytes internal/test/LANGUAGE/AUTO/12-8-DPB.TEST | 1 + .../test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL | Bin 0 -> 1309 bytes .../test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST | 1 + internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL | Bin 0 -> 1291 bytes internal/test/LANGUAGE/AUTO/12-8-LDB.TEST | 1 + .../test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL | Bin 0 -> 1322 bytes .../test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST | 1 + .../AUTO/12-9-MAKE-RANDOM-STATE.DFASL | Bin 0 -> 1552 bytes .../LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.TEST | 1 + .../LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL | Bin 0 -> 1345 bytes .../LANGUAGE/AUTO/12-9-RANDOM-STATE-P.TEST | 1 + internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL | Bin 0 -> 2576 bytes internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST | 1 + .../AUTO/13-1-CHARACTERATTRIBUTES.DFASL | Bin 0 -> 1359 bytes .../AUTO/13-1-CHARACTERATTRIBUTES.TEST | 1 + .../LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL | Bin 0 -> 1486 bytes .../test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST | 1 + .../LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL | Bin 0 -> 1124 bytes .../LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL | Bin 0 -> 1170 bytes .../test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL | Bin 0 -> 3499 bytes .../test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL | Bin 0 -> 2257 bytes internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.TEST | 1 + .../LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL | Bin 0 -> 2347 bytes .../LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL | Bin 0 -> 2081 bytes internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL | Bin 0 -> 2299 bytes internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL | Bin 0 -> 2382 bytes .../test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL | Bin 0 -> 2124 bytes internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.TEST | Bin 0 -> 1865 bytes .../LANGUAGE/AUTO/13-2-CHAR-NOT-EQUAL.TEST | 1 + .../AUTO/13-2-CHAR-NOT-GREATERP.DFASL | Bin 0 -> 2599 bytes .../LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.TEST | 1 + .../LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL | Bin 0 -> 2538 bytes .../LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.TEST | 1 + internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL | Bin 0 -> 2436 bytes internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST | 1 + .../test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL | Bin 0 -> 2218 bytes internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.TEST | 1 + .../LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL | Bin 0 -> 4094 bytes .../test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST | 1 + .../LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL | Bin 0 -> 1099 bytes .../LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST | 1 + .../LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL | Bin 0 -> 1484 bytes .../test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST | 1 + .../LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL | Bin 0 -> 965 bytes .../LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST | 1 + .../LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL | Bin 0 -> 1053 bytes .../LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST | 1 + .../LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL | Bin 0 -> 1484 bytes .../test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST | 1 + .../test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL | Bin 0 -> 859 bytes .../test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST | 1 + .../test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL | Bin 0 -> 777 bytes .../test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST | 1 + .../test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL | Bin 0 -> 857 bytes .../test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST | 1 + .../test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL | Bin 0 -> 860 bytes .../test/LANGUAGE/AUTO/13-3-CODE-CHAR.TEST | 1 + .../test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL | Bin 0 -> 861 bytes .../test/LANGUAGE/AUTO/13-3-MAKE-CHAR.TEST | 1 + .../LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL | Bin 0 -> 1691 bytes .../LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST | 1 + .../test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL | Bin 0 -> 2875 bytes .../test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST | 1 + .../test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL | Bin 0 -> 1503 bytes .../test/LANGUAGE/AUTO/13-4-CHAR-NAME.TEST | Bin 0 -> 1373 bytes .../test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.DFASL | Bin 0 -> 1685 bytes .../test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST | 1 + .../test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL | Bin 0 -> 2526 bytes .../test/LANGUAGE/AUTO/13-4-CHARACTER.TEST | 1 + .../test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL | Bin 0 -> 2897 bytes .../test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST | 1 + .../test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL | Bin 0 -> 1096 bytes .../test/LANGUAGE/AUTO/13-4-INT-CHAR.TEST | 1 + .../test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL | Bin 0 -> 1446 bytes .../test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST | 1 + .../test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL | Bin 0 -> 774 bytes .../test/LANGUAGE/AUTO/13-5-CHAR-BIT.TEST | 1 + .../LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL | Bin 0 -> 782 bytes .../test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.TEST | 1 + .../test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL | Bin 0 -> 1556 bytes .../test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST | 1 + internal/test/LANGUAGE/AUTO/14-1-ELT.DFASL | Bin 0 -> 2381 bytes internal/test/LANGUAGE/AUTO/14-1-ELT.TEST | 1 + internal/test/LANGUAGE/AUTO/14-1-LENGTH.DFASL | Bin 0 -> 2047 bytes internal/test/LANGUAGE/AUTO/14-1-LENGTH.TEST | 1 + .../LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL | Bin 0 -> 2193 bytes .../LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST | 1 + .../test/LANGUAGE/AUTO/14-1-NREVERSE.DFASL | Bin 0 -> 2637 bytes .../test/LANGUAGE/AUTO/14-1-NREVERSE.TEST | 1 + .../test/LANGUAGE/AUTO/14-1-REVERSE.DFASL | Bin 0 -> 2707 bytes internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST | 1 + internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL | Bin 0 -> 2601 bytes internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.TEST | 1 + .../test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL | Bin 0 -> 3758 bytes .../test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST | 1 + internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL | Bin 0 -> 8899 bytes internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST | 1 + internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL | Bin 0 -> 4261 bytes internal/test/LANGUAGE/AUTO/14-2-MAP.TEST | 1 + internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL | Bin 0 -> 9069 bytes internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST | 1 + .../test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL | Bin 0 -> 8827 bytes .../test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST | 1 + internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL | Bin 0 -> 5112 bytes internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST | 1 + internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL | Bin 0 -> 8387 bytes internal/test/LANGUAGE/AUTO/14-2-SOME.TEST | 1 + .../AUTO/14-3-DELETE-DUPLICATES.DFASL | Bin 0 -> 4796 bytes .../LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST | 1 + .../LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL | Bin 0 -> 5839 bytes .../LANGUAGE/AUTO/14-3-DELETE-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL | Bin 0 -> 3836 bytes .../test/LANGUAGE/AUTO/14-3-DELETE-IF.TEST | Bin 0 -> 3506 bytes internal/test/LANGUAGE/AUTO/14-3-DELETE.DFASL | Bin 0 -> 5469 bytes internal/test/LANGUAGE/AUTO/14-3-DELETE.TEST | Bin 0 -> 4703 bytes internal/test/LANGUAGE/AUTO/14-3-FILL.DFASL | Bin 0 -> 3217 bytes internal/test/LANGUAGE/AUTO/14-3-FILL.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.DFASL | Bin 0 -> 4441 bytes .../test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL | Bin 0 -> 4421 bytes internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL | Bin 0 -> 5531 bytes internal/test/LANGUAGE/AUTO/14-3-FIND.TEST | 1 + .../AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL | Bin 0 -> 5706 bytes .../AUTO/14-3-NSUBSTITUTE-IF-NOT.TEST | 1 + .../LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL | Bin 0 -> 6501 bytes .../LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL | Bin 0 -> 6187 bytes .../test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST | 1 + .../LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL | Bin 0 -> 4736 bytes .../LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL | Bin 0 -> 4707 bytes .../test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-POSITION.DFASL | Bin 0 -> 5399 bytes .../test/LANGUAGE/AUTO/14-3-POSITION.TEST | 1 + .../AUTO/14-3-REMOVE-DUPLICATES.DFASL | Bin 0 -> 4732 bytes .../LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST | 1 + .../LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL | Bin 0 -> 5446 bytes .../LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL | Bin 0 -> 3741 bytes .../test/LANGUAGE/AUTO/14-3-REMOVE-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL | Bin 0 -> 5346 bytes internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST | 1 + internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST | 1 + .../AUTO/14-3-SUBSTITUTE-IF-NOT.DFASL | Bin 0 -> 5503 bytes .../LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST | 1 + .../LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL | Bin 0 -> 6545 bytes .../LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.TEST | 1 + .../test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL | Bin 0 -> 6073 bytes .../test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST | 1 + .../LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL | Bin 0 -> 4795 bytes .../test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL | Bin 0 -> 4646 bytes internal/test/LANGUAGE/AUTO/14-4-COUNT.DFASL | Bin 0 -> 5634 bytes internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST | 1 + .../test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL | Bin 0 -> 4390 bytes .../test/LANGUAGE/AUTO/14-4-MISMATCH.TEST | 1 + internal/test/LANGUAGE/AUTO/14-5-MERGE.DFASL | Bin 0 -> 5916 bytes internal/test/LANGUAGE/AUTO/14-5-MERGE.TEST | 1 + internal/test/LANGUAGE/AUTO/14-5-SORT.DFASL | Bin 0 -> 6385 bytes internal/test/LANGUAGE/AUTO/14-5-SORT.TEST | 1 + .../test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL | Bin 0 -> 4950 bytes .../test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL | Bin 0 -> 3216 bytes internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL | Bin 0 -> 3193 bytes internal/test/LANGUAGE/AUTO/15-1-CAAADR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL | Bin 0 -> 3199 bytes internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL | Bin 0 -> 3320 bytes internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL | Bin 0 -> 3326 bytes internal/test/LANGUAGE/AUTO/15-1-CAADDR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL | Bin 0 -> 3215 bytes internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL | Bin 0 -> 3437 bytes internal/test/LANGUAGE/AUTO/15-1-CAAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CADAA.DFASL | Bin 0 -> 3305 bytes internal/test/LANGUAGE/AUTO/15-1-CADAA.TEST | Bin 0 -> 2453 bytes internal/test/LANGUAGE/AUTO/15-1-CADAAR.TEST | Bin 0 -> 2450 bytes internal/test/LANGUAGE/AUTO/15-1-CADADR.DFASL | Bin 0 -> 2673 bytes internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL | Bin 0 -> 2980 bytes internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL | Bin 0 -> 3169 bytes internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST | 1 + .../AUTO/15-1-CADDDR-AND-FOURTH.DFASL | Bin 0 -> 3451 bytes .../LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST | 1 + .../LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL | Bin 0 -> 2477 bytes .../LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST | 1 + .../LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL | Bin 0 -> 2602 bytes .../LANGUAGE/AUTO/15-1-CADR-AND-SECOND.TEST | 1 + .../LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL | Bin 0 -> 3427 bytes .../LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL | Bin 0 -> 3289 bytes internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL | Bin 0 -> 2937 bytes internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL | Bin 0 -> 3167 bytes internal/test/LANGUAGE/AUTO/15-1-CDAAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL | Bin 0 -> 3308 bytes internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL | Bin 0 -> 3392 bytes internal/test/LANGUAGE/AUTO/15-1-CDADDR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL | Bin 0 -> 3201 bytes internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL | Bin 0 -> 3160 bytes internal/test/LANGUAGE/AUTO/15-1-CDAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL | Bin 0 -> 3342 bytes internal/test/LANGUAGE/AUTO/15-1-CDDAAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL | Bin 0 -> 3408 bytes internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL | Bin 0 -> 3240 bytes internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL | Bin 0 -> 3185 bytes internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL | Bin 0 -> 2062 bytes internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL | Bin 0 -> 2031 bytes internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL | Bin 0 -> 2971 bytes internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST | 1 + .../LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL | Bin 0 -> 3335 bytes .../test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL | Bin 0 -> 3827 bytes internal/test/LANGUAGE/AUTO/15-1-CONS.TEST | 1 + .../test/LANGUAGE/AUTO/15-1-TREE-EQUAL.DFASL | Bin 0 -> 4600 bytes .../test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL | Bin 0 -> 5237 bytes internal/test/LANGUAGE/AUTO/15-2-APPEND.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL | Bin 0 -> 3513 bytes internal/test/LANGUAGE/AUTO/15-2-BUTLAST.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL | Bin 0 -> 3734 bytes .../test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL | Bin 0 -> 2096 bytes .../test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL | Bin 0 -> 2291 bytes .../test/LANGUAGE/AUTO/15-2-COPY-TREE.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL | Bin 0 -> 4201 bytes internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL | Bin 0 -> 1267 bytes internal/test/LANGUAGE/AUTO/15-2-ENDP.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL | Bin 0 -> 2105 bytes internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-FIRST.DFASL | Bin 0 -> 744 bytes internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL | Bin 0 -> 746 bytes internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL | Bin 0 -> 2216 bytes internal/test/LANGUAGE/AUTO/15-2-LAST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL | Bin 0 -> 3124 bytes internal/test/LANGUAGE/AUTO/15-2-LDIFF.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL | Bin 0 -> 2775 bytes .../test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL | Bin 0 -> 3434 bytes internal/test/LANGUAGE/AUTO/15-2-LIST.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL | Bin 0 -> 3672 bytes .../test/LANGUAGE/AUTO/15-2-LISTSTAR.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL | Bin 0 -> 2530 bytes .../test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL | Bin 0 -> 4030 bytes .../test/LANGUAGE/AUTO/15-2-NBUTLAST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL | Bin 0 -> 2531 bytes internal/test/LANGUAGE/AUTO/15-2-NCONC.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL | Bin 0 -> 2977 bytes internal/test/LANGUAGE/AUTO/15-2-NINTH.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-NRECONC.DFASL | Bin 0 -> 2532 bytes internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL | Bin 0 -> 2271 bytes internal/test/LANGUAGE/AUTO/15-2-NTH.TEST | Bin 0 -> 3208 bytes internal/test/LANGUAGE/AUTO/15-2-NTHCDR.DFASL | Bin 0 -> 1862 bytes internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-POP.DFASL | Bin 0 -> 2287 bytes internal/test/LANGUAGE/AUTO/15-2-POP.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL | Bin 0 -> 3042 bytes internal/test/LANGUAGE/AUTO/15-2-PUSH.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL | Bin 0 -> 3996 bytes internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-REST.DFASL | Bin 0 -> 742 bytes internal/test/LANGUAGE/AUTO/15-2-REST.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL | Bin 0 -> 2553 bytes .../test/LANGUAGE/AUTO/15-2-REVAPPEND.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL | Bin 0 -> 746 bytes internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST | 1 + .../test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL | Bin 0 -> 2964 bytes internal/test/LANGUAGE/AUTO/15-2-SEVENTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL | Bin 0 -> 2756 bytes internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL | Bin 0 -> 2917 bytes internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST | 1 + internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL | Bin 0 -> 744 bytes internal/test/LANGUAGE/AUTO/15-2-THIRD.TEST | 1 + internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL | Bin 0 -> 3375 bytes internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST | 1 + internal/test/LANGUAGE/AUTO/15-3-RPLACD.DFASL | Bin 0 -> 2650 bytes internal/test/LANGUAGE/AUTO/15-3-RPLACD.TEST | 1 + .../test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL | Bin 0 -> 5089 bytes internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.TEST | 1 + .../LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL | Bin 0 -> 2875 bytes .../LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL | Bin 0 -> 3952 bytes .../test/LANGUAGE/AUTO/15-4-NSUBST-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL | Bin 0 -> 5028 bytes internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL | Bin 0 -> 5759 bytes internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST | 1 + .../LANGUAGE/AUTO/15-4-SUBST-IF-NOT.DFASL | Bin 0 -> 3159 bytes .../test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/15-4-SUBST-IF.DFASL | Bin 0 -> 4531 bytes .../test/LANGUAGE/AUTO/15-4-SUBST-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL | Bin 0 -> 5748 bytes internal/test/LANGUAGE/AUTO/15-4-SUBST.TEST | 1 + internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL | Bin 0 -> 1259 bytes internal/test/LANGUAGE/AUTO/15-5-ADJOIN.TEST | 1 + .../LANGUAGE/AUTO/15-5-INTERSECTION.DFASL | Bin 0 -> 4761 bytes .../test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST | 1 + .../LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL | Bin 0 -> 3820 bytes .../LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL | Bin 0 -> 3684 bytes .../test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL | Bin 0 -> 4830 bytes internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST | 1 + .../LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL | Bin 0 -> 4447 bytes .../LANGUAGE/AUTO/15-5-NINTERSECTION.TEST | 1 + .../LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.DFASL | Bin 0 -> 7976 bytes .../LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.TEST | 1 + .../AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL | Bin 0 -> 12964 bytes .../LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.TEST | 1 + internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL | Bin 0 -> 5218 bytes internal/test/LANGUAGE/AUTO/15-5-NUNION.TEST | 1 + .../LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL | Bin 0 -> 11673 bytes .../LANGUAGE/AUTO/15-5-SET-DIFFERENCE.TEST | 1 + .../LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL | Bin 0 -> 13001 bytes .../LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.TEST | 1 + .../test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL | Bin 0 -> 4441 bytes internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST | 1 + internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL | Bin 0 -> 2014 bytes internal/test/LANGUAGE/AUTO/15-5-TAILP.TEST | 1 + internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL | Bin 0 -> 5542 bytes internal/test/LANGUAGE/AUTO/15-5-UNION.TEST | 1 + internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL | Bin 0 -> 2924 bytes internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST | 1 + .../LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL | Bin 0 -> 1134 bytes .../test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL | Bin 0 -> 1118 bytes .../test/LANGUAGE/AUTO/15-6-ASSOC-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL | Bin 0 -> 1482 bytes internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST | 1 + .../test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL | Bin 0 -> 15021 bytes internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.TEST | 1 + .../LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL | Bin 0 -> 1158 bytes .../LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL | Bin 0 -> 1144 bytes .../test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST | 1 + internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL | Bin 0 -> 1562 bytes internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST | 1 + .../test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL | Bin 0 -> 1731 bytes internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST | 1 + .../test/LANGUAGE/AUTO/16-1-GETHASH.DFASL | Bin 0 -> 1594 bytes internal/test/LANGUAGE/AUTO/16-1-GETHASH.TEST | 1 + .../LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL | Bin 0 -> 1911 bytes .../LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST | 1 + .../LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL | Bin 0 -> 947 bytes .../test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST | 1 + .../LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL | Bin 0 -> 1329 bytes .../LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.TEST | 1 + .../test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL | Bin 0 -> 1750 bytes internal/test/LANGUAGE/AUTO/16-1-MAPHASH.TEST | 1 + .../test/LANGUAGE/AUTO/16-1-REMHASH.DFASL | Bin 0 -> 1636 bytes internal/test/LANGUAGE/AUTO/16-1-REMHASH.TEST | 1 + internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL | Bin 0 -> 916 bytes internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST | 1 + .../test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL | Bin 0 -> 2801 bytes .../test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST | 1 + internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL | Bin 0 -> 982 bytes internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST | 1 + internal/test/LANGUAGE/AUTO/17-2-AREF.DFASL | Bin 0 -> 2925 bytes internal/test/LANGUAGE/AUTO/17-2-AREF.TEST | 1 + internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL | Bin 0 -> 1682 bytes internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST | 1 + .../AUTO/17-3-ADJUSTABLE-ARRAY-P.DFASL | Bin 0 -> 1349 bytes .../AUTO/17-3-ADJUSTABLE-ARRAY-P.TEST | 1 + .../LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL | Bin 0 -> 1527 bytes .../LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST | 1 + .../LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.DFASL | Bin 0 -> 1361 bytes .../LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.TEST | 1 + .../AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL | Bin 0 -> 2586 bytes .../AUTO/17-3-ARRAY-ELEMENT-TYPE.TEST | 1 + .../AUTO/17-3-ARRAY-IN-BOUNDS-P.DFASL | Bin 0 -> 1714 bytes .../LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST | 1 + .../test/LANGUAGE/AUTO/17-3-ARRAY-RANK.DFASL | Bin 0 -> 966 bytes .../test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST | 1 + .../AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL | Bin 0 -> 1755 bytes .../AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.TEST | 1 + .../LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL | Bin 0 -> 1377 bytes .../LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-AND.DFASL | Bin 0 -> 1869 bytes internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL | Bin 0 -> 1881 bytes .../test/LANGUAGE/AUTO/17-4-BIT-ANDC1.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL | Bin 0 -> 1881 bytes .../test/LANGUAGE/AUTO/17-4-BIT-ANDC2.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL | Bin 0 -> 1869 bytes internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL | Bin 0 -> 1869 bytes internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL | Bin 0 -> 1875 bytes .../test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL | Bin 0 -> 1869 bytes internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL | Bin 0 -> 1786 bytes internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL | Bin 0 -> 1875 bytes .../test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL | Bin 0 -> 1875 bytes .../test/LANGUAGE/AUTO/17-4-BIT-ORC2.TEST | 1 + .../test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL | Bin 0 -> 1869 bytes internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST | 1 + internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL | Bin 0 -> 1609 bytes internal/test/LANGUAGE/AUTO/17-4-BIT.TEST | 1 + internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL | Bin 0 -> 1854 bytes internal/test/LANGUAGE/AUTO/17-4-SBIT.TEST | 1 + .../AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL | Bin 0 -> 1417 bytes .../AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.TEST | 1 + .../LANGUAGE/AUTO/17-5-FILL-POINTER.DFASL | Bin 0 -> 977 bytes .../test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST | 1 + .../test/LANGUAGE/AUTO/17-5-VECTOR-POP.DFASL | Bin 0 -> 1965 bytes .../test/LANGUAGE/AUTO/17-5-VECTOR-POP.TEST | 1 + .../AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL | Bin 0 -> 2137 bytes .../AUTO/17-5-VECTOR-PUSH-EXTEND.TEST | 1 + .../test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL | Bin 0 -> 1259 bytes .../test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST | 1 + .../LANGUAGE/AUTO/17-6-ADJUST-ARRAY.DFASL | Bin 0 -> 1792 bytes .../test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST | 1 + internal/test/LANGUAGE/AUTO/18-1-CHAR.DFASL | Bin 0 -> 3863 bytes internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST | 1 + internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL | Bin 0 -> 1670 bytes internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST | 1 + .../test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL | Bin 0 -> 4335 bytes .../test/LANGUAGE/AUTO/18-2-STRING-EQ.TEST | 1 + .../LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL | Bin 0 -> 5889 bytes .../test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST | 1 + .../test/LANGUAGE/AUTO/18-2-STRING-GE.DFASL | Bin 0 -> 4762 bytes .../test/LANGUAGE/AUTO/18-2-STRING-GE.TEST | 1 + .../LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL | Bin 0 -> 4514 bytes .../LANGUAGE/AUTO/18-2-STRING-GREATERP.TEST | 1 + .../test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL | Bin 0 -> 4498 bytes .../test/LANGUAGE/AUTO/18-2-STRING-GT.TEST | 1 + .../test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL | Bin 0 -> 4763 bytes .../test/LANGUAGE/AUTO/18-2-STRING-LE.TEST | 1 + .../LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL | Bin 0 -> 4284 bytes .../test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST | 1 + .../test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL | Bin 0 -> 4304 bytes .../test/LANGUAGE/AUTO/18-2-STRING-LT.TEST | 1 + .../test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL | Bin 0 -> 1578 bytes .../test/LANGUAGE/AUTO/18-2-STRING-NEQ.TEST | 1 + .../LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL | Bin 0 -> 1669 bytes .../LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST | 1 + .../AUTO/18-2-STRING-NOT-GREATERP.DFASL | Bin 0 -> 4965 bytes .../AUTO/18-2-STRING-NOT-GREATERP.TEST | 1 + .../LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL | Bin 0 -> 4860 bytes .../LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST | 1 + .../test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL | Bin 0 -> 1680 bytes .../test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST | 1 + .../AUTO/18-3-NSTRING-CAPITALIZE.DFASL | Bin 0 -> 2597 bytes .../AUTO/18-3-NSTRING-CAPITALIZE.TEST | 1 + .../LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL | Bin 0 -> 2485 bytes .../LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST | 1 + .../LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL | Bin 0 -> 2477 bytes .../LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST | 1 + .../AUTO/18-3-STRING-CAPITALIZE.DFASL | Bin 0 -> 2002 bytes .../LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.TEST | 1 + .../LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL | Bin 0 -> 2301 bytes .../LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST | 1 + .../LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL | Bin 0 -> 3246 bytes .../LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.TEST | 1 + .../AUTO/18-3-STRING-RIGHT-TRIM.DFASL | Bin 0 -> 3240 bytes .../LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST | 1 + .../test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL | Bin 0 -> 3235 bytes .../test/LANGUAGE/AUTO/18-3-STRING-TRIM.TEST | 1 + .../LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL | Bin 0 -> 2293 bytes .../LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST | 1 + internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL | Bin 0 -> 2646 bytes internal/test/LANGUAGE/AUTO/18-3-STRING.TEST | 1 + internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST | Bin 0 -> 7726 bytes .../test/LANGUAGE/AUTO/20-1-APPLYHOOK.DFASL | Bin 0 -> 2082 bytes .../test/LANGUAGE/AUTO/20-1-CONSTANTP.DFASL | Bin 0 -> 1125 bytes .../test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST | 1 + internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL | Bin 0 -> 1910 bytes internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST | 1 + internal/test/LANGUAGE/AUTO/21-STREAMS.TEST | 846 ++++++++++++++++++ .../LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL | Bin 0 -> 3686 bytes .../LANGUAGE/AUTO/22-1-5-COPY-READTABLE.TEST | 1 + .../22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL | Bin 0 -> 3497 bytes .../22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST | 1 + .../AUTO/22-1-5-GET-MACRO-CHARACTER.DFASL | Bin 0 -> 2494 bytes .../AUTO/22-1-5-GET-MACRO-CHARACTER.TEST | 1 + ...22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL | Bin 0 -> 3404 bytes .../22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST | 1 + .../LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL | Bin 0 -> 1902 bytes .../test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST | 1 + .../22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL | Bin 0 -> 3400 bytes .../22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST | 1 + .../AUTO/22-1-5-SET-MACRO-CHARACTER.DFASL | Bin 0 -> 3609 bytes .../AUTO/22-1-5-SET-MACRO-CHARACTER.TEST | 1 + .../AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL | Bin 0 -> 6305 bytes .../AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.TEST | Bin 0 -> 5380 bytes .../test/LANGUAGE/AUTO/22-2-1-LISTEN.DFASL | Bin 0 -> 2717 bytes .../test/LANGUAGE/AUTO/22-2-1-LISTEN.TEST | Bin 0 -> 2469 bytes .../LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.DFASL | Bin 0 -> 4072 bytes .../LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.TEST | Bin 0 -> 4022 bytes .../test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.DFASL | Bin 0 -> 4029 bytes .../test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.TEST | Bin 0 -> 3233 bytes .../AUTO/22-2-1-READ-CHAR-NO-HANG.DFASL | Bin 0 -> 3737 bytes .../AUTO/22-2-1-READ-CHAR-NO-HANG.TEST | Bin 0 -> 2448 bytes .../test/LANGUAGE/AUTO/22-2-1-READ-CHAR.DFASL | Bin 0 -> 3589 bytes .../test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST | 1 + .../AUTO/22-2-1-READ-DELIMITED-LIST.DFASL | Bin 0 -> 2699 bytes .../AUTO/22-2-1-READ-DELIMITED-LIST.TEST | 1 + .../AUTO/22-2-1-READ-FROM-STRING.TEST | Bin 0 -> 3552 bytes .../22-2-1-READ-PRESERVING-WHITESPACE.DFASL | Bin 0 -> 2900 bytes .../22-2-1-READ-PRESERVING-WHITESPACE.TEST | 1 + internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL | Bin 0 -> 2870 bytes internal/test/LANGUAGE/AUTO/22-2-1-READ.TEST | 1 + .../LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL | Bin 0 -> 2370 bytes .../LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST | 1 + .../LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL | Bin 0 -> 2935 bytes .../LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST | 1 + .../LANGUAGE/AUTO/22-3-1-FRESH-LINE.DFASL | Bin 0 -> 4205 bytes .../test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.TEST | 1 + .../test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL | Bin 0 -> 1909 bytes .../test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST | 1 + .../AUTO/22-3-1-PRIN1-TO-STRING.DFASL | Bin 0 -> 4001 bytes .../LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.TEST | 1 + .../test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL | Bin 0 -> 3730 bytes internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST | 1 + .../AUTO/22-3-1-PRINC-TO-STRING.DFASL | Bin 0 -> 4494 bytes .../LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST | 1 + .../test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL | Bin 0 -> 3197 bytes internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST | 1 + .../test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL | Bin 0 -> 4040 bytes internal/test/LANGUAGE/AUTO/22-3-1-PRINT.TEST | 1 + .../test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL | Bin 0 -> 1812 bytes .../test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST | 1 + .../LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL | Bin 0 -> 3099 bytes .../test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST | 1 + .../LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL | Bin 0 -> 6030 bytes .../test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST | 1 + .../LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL | Bin 0 -> 6038 bytes .../LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST | 1 + .../test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL | Bin 0 -> 23983 bytes .../test/LANGUAGE/AUTO/22-3-3-FORMAT.TEST | 1 + .../LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST | 1 + .../test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X | 1 + .../LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X | 1 + .../test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X | 1 + .../LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X | 1 + .../LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X | 1 + .../LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X | 1 + .../test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X | 1 + .../test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X | 1 + .../test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X | 1 + .../LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X | 1 + internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X | 1 + .../test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X | 1 + internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X | 1 + .../AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X | 1 + internal/test/LANGUAGE/AUTO/23-2-OPEN.X | 1 + .../test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X | 1 + .../test/LANGUAGE/AUTO/23-3-DELETE-FILE.X | 1 + .../test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X | 1 + .../test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X | 1 + .../test/LANGUAGE/AUTO/23-3-FILE-POSITION.X | 1 + .../test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X | 1 + internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X | 1 + .../test/LANGUAGE/AUTO/23-3-RENAME-FILE.X | 1 + internal/test/LANGUAGE/AUTO/23-4-LOAD.X | 1 + internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X | 1 + internal/test/LANGUAGE/AUTO/23-FUNCTIONS | 1 + internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF | 1 + .../test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL | Bin 0 -> 25564 bytes internal/test/LANGUAGE/AUTO/24-1-BREAK.DFASL | Bin 0 -> 1632 bytes internal/test/LANGUAGE/AUTO/24-1-BREAK.TEST | 1 + internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL | Bin 0 -> 2962 bytes internal/test/LANGUAGE/AUTO/24-1-CERROR.TEST | 1 + .../test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST | 1 + internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL | Bin 0 -> 1665 bytes internal/test/LANGUAGE/AUTO/24-1-ERROR.TEST | 1 + internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL | Bin 0 -> 2270 bytes internal/test/LANGUAGE/AUTO/24-1-WARN.TEST | 1 + internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL | Bin 0 -> 2019 bytes internal/test/LANGUAGE/AUTO/24-2-ASSERT.TEST | 1 + internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL | Bin 0 -> 1739 bytes internal/test/LANGUAGE/AUTO/24-3-CCASE.TEST | 1 + .../test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL | Bin 0 -> 1241 bytes .../test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST | 1 + internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL | Bin 0 -> 1733 bytes internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST | 1 + .../test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL | Bin 0 -> 1235 bytes .../test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST | 1 + internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X | 735 +++++++++++++++ .../LANGUAGE/AUTO/25-1-COMPILE-FILE.DFASL | Bin 0 -> 777 bytes .../test/LANGUAGE/AUTO/25-1-COMPILE-FILE.TEST | 1 + .../test/LANGUAGE/AUTO/25-1-COMPILE.DFASL | Bin 0 -> 2184 bytes internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST | 1 + .../test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL | Bin 0 -> 1326 bytes .../test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST | 1 + .../LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL | Bin 0 -> 4962 bytes .../LANGUAGE/AUTO/25-2-DOCUMENTATION.TEST | 1 + .../LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL | Bin 0 -> 1941 bytes .../test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST | 1 + .../test/LANGUAGE/AUTO/25-3-APROPOS.DFASL | Bin 0 -> 1742 bytes internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST | 1 + .../test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL | Bin 0 -> 3588 bytes .../test/LANGUAGE/AUTO/25-3-DESCRIBE.TEST | 1 + .../test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL | Bin 0 -> 2038 bytes internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.TEST | 1 + internal/test/LANGUAGE/AUTO/25-3-ED.DFASL | Bin 0 -> 774 bytes internal/test/LANGUAGE/AUTO/25-3-ED.TEST | 1 + .../test/LANGUAGE/AUTO/25-3-INSPECT.DFASL | Bin 0 -> 789 bytes internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST | 1 + internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL | Bin 0 -> 791 bytes internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST | 1 + internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL | Bin 0 -> 1493 bytes internal/test/LANGUAGE/AUTO/25-3-TIME.TEST | 1 + .../AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL | Bin 0 -> 1962 bytes .../AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST | 1 + .../AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL | Bin 0 -> 2204 bytes .../AUTO/25-4-ENCODE-UNIVERSAL-TIME.TEST | 1 + .../LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL | Bin 0 -> 1661 bytes .../LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST | 1 + .../AUTO/25-4-GET-INTERNAL-REAL-TIME.DFASL | Bin 0 -> 2682 bytes .../AUTO/25-4-GET-INTERNAL-REAL-TIME.TEST | 1 + .../AUTO/25-4-GET-INTERNAL-RUN-TIME.DFASL | Bin 0 -> 2678 bytes .../AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST | 1 + .../AUTO/25-4-GET-UNIVERSAL-TIME.DFASL | Bin 0 -> 1378 bytes .../AUTO/25-4-GET-UNIVERSAL-TIME.TEST | 1 + .../25-4-LISP-IMPLEMENTATION-VERSION.DFASL | Bin 0 -> 849 bytes .../25-4-LISP-IMPLEMENTATION-VERSION.TEST | 1 + .../LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL | Bin 0 -> 810 bytes .../LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST | 1 + .../LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL | Bin 0 -> 816 bytes .../LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST | 1 + .../LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL | Bin 0 -> 1052 bytes .../test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST | 1 + .../LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL | Bin 0 -> 813 bytes .../LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST | 1 + .../LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL | Bin 0 -> 813 bytes .../LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST | 1 + internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL | Bin 0 -> 1546 bytes internal/test/LANGUAGE/AUTO/25-4-SLEEP.TEST | 1 + .../LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL | Bin 0 -> 863 bytes .../LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.TEST | 1 + .../LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL | Bin 0 -> 816 bytes .../LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST | 1 + .../test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL | Bin 0 -> 2984 bytes .../test/LANGUAGE/AUTO/25-5-IDENTITY.TEST | 1 + internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST | 1 + internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL | Bin 0 -> 4036 bytes internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST | 1 + internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL | Bin 0 -> 1353 bytes internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.TEST | 1 + .../AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL | Bin 0 -> 2983 bytes .../AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST | 1 + .../AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL | Bin 0 -> 1009 bytes .../AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.TEST | 1 + .../AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL | Bin 0 -> 793 bytes .../AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST | 1 + internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL | Bin 0 -> 8023 bytes internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST | 1 + .../LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL | Bin 0 -> 3601 bytes .../test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST | 1 + .../LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL | Bin 0 -> 3811 bytes .../LANGUAGE/AUTO/5-3-2-DEFPARAMETER.TEST | 1 + .../test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL | Bin 0 -> 4347 bytes internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST | 1 + .../test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL | Bin 0 -> 767 bytes .../test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL | Bin 0 -> 11684 bytes .../test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL | Bin 0 -> 2531 bytes internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL | Bin 0 -> 5898 bytes internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL | Bin 0 -> 3038 bytes internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST | 1 + .../LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.DFASL | Bin 0 -> 4249 bytes .../LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL | Bin 0 -> 3439 bytes .../test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL | Bin 0 -> 3094 bytes .../test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST | 1 + .../AUTO/6-2-2-COMPILED-FUNCTION-P.DFASL | Bin 0 -> 1776 bytes .../AUTO/6-2-2-COMPILED-FUNCTION-P.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL | Bin 0 -> 2916 bytes .../test/LANGUAGE/AUTO/6-2-2-COMPLEXP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL | Bin 0 -> 3288 bytes internal/test/LANGUAGE/AUTO/6-2-2-CONSP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL | Bin 0 -> 2630 bytes internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL | Bin 0 -> 2524 bytes .../test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL | Bin 0 -> 2647 bytes .../test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL | Bin 0 -> 3354 bytes internal/test/LANGUAGE/AUTO/6-2-2-LISTP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL | Bin 0 -> 2027 bytes internal/test/LANGUAGE/AUTO/6-2-2-NULL.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL | Bin 0 -> 2394 bytes .../test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL | Bin 0 -> 2745 bytes .../test/LANGUAGE/AUTO/6-2-2-PACKAGEP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL | Bin 0 -> 2772 bytes .../test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST | 1 + .../AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL | Bin 0 -> 4854 bytes .../AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.TEST | 1 + .../LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.DFASL | Bin 0 -> 3698 bytes .../LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST | 1 + .../LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.DFASL | Bin 0 -> 3693 bytes .../LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL | Bin 0 -> 3473 bytes .../test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL | Bin 0 -> 2274 bytes .../test/LANGUAGE/AUTO/6-2-2-SYMBOLP.TEST | 1 + .../test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL | Bin 0 -> 4452 bytes .../test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL | Bin 0 -> 1447 bytes internal/test/LANGUAGE/AUTO/6-3-EQ.TEST | 1 + internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL | Bin 0 -> 1816 bytes internal/test/LANGUAGE/AUTO/6-3-EQL.TEST | 1 + internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL | Bin 0 -> 2008 bytes internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST | 1 + internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL | Bin 0 -> 3172 bytes internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST | 1 + internal/test/LANGUAGE/AUTO/6-4-AND.DFASL | Bin 0 -> 753 bytes internal/test/LANGUAGE/AUTO/6-4-AND.TEST | 1 + internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL | Bin 0 -> 753 bytes internal/test/LANGUAGE/AUTO/6-4-NOT.TEST | 1 + internal/test/LANGUAGE/AUTO/6-4-OR.DFASL | Bin 0 -> 751 bytes internal/test/LANGUAGE/AUTO/6-4-OR.TEST | 1 + .../test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL | Bin 0 -> 1813 bytes internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST | 1 + .../test/LANGUAGE/AUTO/7-1-1-FBOUNDP.DFASL | Bin 0 -> 3441 bytes .../test/LANGUAGE/AUTO/7-1-1-FBOUNDP.TEST | 1 + .../test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL | Bin 0 -> 2949 bytes .../test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST | 1 + internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.DFASL | Bin 0 -> 1275 bytes internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.TEST | 1 + .../LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.DFASL | Bin 0 -> 2601 bytes .../LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST | 1 + .../LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL | Bin 0 -> 4302 bytes .../LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.TEST | Bin 0 -> 3308 bytes .../LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.DFASL | Bin 0 -> 3302 bytes .../LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.TEST | 1 + .../LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.DFASL | Bin 0 -> 2261 bytes .../test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST | 1 + .../test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.DFASL | Bin 0 -> 2162 bytes .../test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.TEST | Bin 0 -> 2239 bytes internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.DFASL | Bin 0 -> 2154 bytes internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.TEST | Bin 0 -> 2251 bytes internal/test/LANGUAGE/AUTO/7-1-2-SET.DFASL | Bin 0 -> 2222 bytes internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST | 1 + internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST | 1 + internal/test/LANGUAGE/AUTO/7-10-CATCH.DFASL | Bin 0 -> 8052 bytes internal/test/LANGUAGE/AUTO/7-10-CATCH.TEST | 1 + internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL | Bin 0 -> 765 bytes internal/test/LANGUAGE/AUTO/7-10-THROW.TEST | 1 + .../LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL | Bin 0 -> 6621 bytes .../LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST | 1 + .../AUTO/7-2-DEFINE-MODIFY-MACRO.DFASL | Bin 0 -> 4859 bytes .../AUTO/7-2-DEFINE-MODIFY-MACRO.TEST | 1 + .../AUTO/7-2-DEFINE-SETF-METHOD.DFASL | Bin 0 -> 1955 bytes .../LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST | 1 + internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL | Bin 0 -> 2203 bytes internal/test/LANGUAGE/AUTO/7-2-DEFSETF.TEST | Bin 0 -> 2040 bytes .../7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL | Bin 0 -> 1541 bytes .../7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST | 1 + .../LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL | Bin 0 -> 1496 bytes .../LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST | 1 + internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL | Bin 0 -> 23706 bytes internal/test/LANGUAGE/AUTO/7-2-PSETF.TEST | 1 + internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL | Bin 0 -> 46886 bytes internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST | 1 + internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL | Bin 0 -> 302 bytes internal/test/LANGUAGE/AUTO/7-2-SETF.TEST | 1 + internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL | Bin 0 -> 19850 bytes internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST | 1 + internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL | Bin 0 -> 5401 bytes internal/test/LANGUAGE/AUTO/7-3-APPLY.TEST | 1 + .../AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL | Bin 0 -> 1100 bytes .../AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST | 1 + internal/test/LANGUAGE/AUTO/7-3-FUNCALL.DFASL | Bin 0 -> 2962 bytes internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST | 1 + internal/test/LANGUAGE/AUTO/7-4-PROG1.DFASL | Bin 0 -> 1460 bytes internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST | 1 + internal/test/LANGUAGE/AUTO/7-4-PROG2.DFASL | Bin 0 -> 2007 bytes internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST | 1 + internal/test/LANGUAGE/AUTO/7-4-PROGN.DFASL | Bin 0 -> 1465 bytes internal/test/LANGUAGE/AUTO/7-4-PROGN.TEST | 1 + .../test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST | 1 + internal/test/LANGUAGE/AUTO/7-5-FLET.DFASL | Bin 0 -> 5352 bytes internal/test/LANGUAGE/AUTO/7-5-FLET.TEST | 1 + internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST | 1 + internal/test/LANGUAGE/AUTO/7-5-LET.DFASL | Bin 0 -> 4132 bytes internal/test/LANGUAGE/AUTO/7-5-LET.TEST | 1 + internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL | Bin 0 -> 4243 bytes internal/test/LANGUAGE/AUTO/7-5-LETSTAR.TEST | 1 + .../test/LANGUAGE/AUTO/7-5-MACROLET.DFASL | Bin 0 -> 9134 bytes internal/test/LANGUAGE/AUTO/7-5-MACROLET.TEST | 1 + internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL | Bin 0 -> 4401 bytes internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST | 1 + internal/test/LANGUAGE/AUTO/7-6-CASE.DFASL | Bin 0 -> 2199 bytes internal/test/LANGUAGE/AUTO/7-6-CASE.TEST | 1 + internal/test/LANGUAGE/AUTO/7-6-COND.DFASL | Bin 0 -> 3664 bytes internal/test/LANGUAGE/AUTO/7-6-COND.TEST | 1 + internal/test/LANGUAGE/AUTO/7-6-IF.DFASL | Bin 0 -> 3020 bytes internal/test/LANGUAGE/AUTO/7-6-IF.TEST | 1 + .../test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL | Bin 0 -> 5612 bytes internal/test/LANGUAGE/AUTO/7-6-TYPECASE.TEST | 1 + internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL | Bin 0 -> 2889 bytes internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST | 1 + internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL | Bin 0 -> 2929 bytes internal/test/LANGUAGE/AUTO/7-6-WHEN.TEST | 1 + internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST | 1 + .../test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL | Bin 0 -> 8289 bytes .../test/LANGUAGE/AUTO/7-7-RETURN-FROM.TEST | 1 + internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL | Bin 0 -> 4040 bytes internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST | 1 + internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL | Bin 0 -> 4914 bytes internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST | 1 + internal/test/LANGUAGE/AUTO/7-8-2-DO.DFASL | Bin 0 -> 3717 bytes internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL | Bin 0 -> 3727 bytes internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL | Bin 0 -> 4649 bytes internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL | Bin 0 -> 4759 bytes .../test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST | 1 + internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL | Bin 0 -> 3433 bytes internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL | Bin 0 -> 760 bytes internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL | Bin 0 -> 4662 bytes internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL | Bin 0 -> 988 bytes internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST | 1 + internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL | Bin 0 -> 2623 bytes internal/test/LANGUAGE/AUTO/7-8-4-MAPL.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL | Bin 0 -> 3255 bytes .../test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL | Bin 0 -> 6507 bytes internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST | 1 + internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL | Bin 0 -> 751 bytes internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST | 1 + internal/test/LANGUAGE/AUTO/7-8-5-PROG.DFASL | Bin 0 -> 4601 bytes internal/test/LANGUAGE/AUTO/7-8-5-PROG.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL | Bin 0 -> 4685 bytes .../test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST | 1 + .../test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL | Bin 0 -> 4003 bytes .../test/LANGUAGE/AUTO/7-8-5-TAGBODY.TEST | 1 + .../AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL | Bin 0 -> 9048 bytes .../AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST | 1 + .../test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL | Bin 0 -> 2570 bytes .../test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.TEST | 1 + .../7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL | Bin 0 -> 9818 bytes .../7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST | 1 + .../7-9-2-MVR-EVALUATION-APPLICATION.DFASL | Bin 0 -> 3575 bytes .../7-9-2-MVR-EVALUATION-APPLICATION.TEST | 1 + .../AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL | Bin 0 -> 15342 bytes .../AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.TEST | 1 + .../AUTO/7-9-2-MVR-IMPLICIT-PROGN-2.TEST | 1 + .../AUTO/7-9-2-MVR-MISC-SITUATIONS.DFASL | Bin 0 -> 6683 bytes .../LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.DFASL | Bin 0 -> 8283 bytes .../LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST | 1 + .../AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST | 1 + .../test/LANGUAGE/AUTO/8-1-PARSE-BODY.DFASL | Bin 0 -> 1118 bytes .../test/LANGUAGE/AUTO/8-1-PARSE-BODY.TEST | 1 + .../8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST | 1 + .../AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST | 1 + internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST | 1 + internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST | 1 + internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST | 1 + internal/test/LANGUAGE/AUTO/9-3-THE.DFASL | Bin 0 -> 2053 bytes internal/test/LANGUAGE/AUTO/9-3-THE.TEST | 1 + .../test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL | Bin 0 -> 64041 bytes .../test/LANGUAGE/AUTO/AR-TEST-CASES.TEST | Bin 0 -> 36822 bytes internal/test/LANGUAGE/AUTO/AR5741.DFASL | Bin 0 -> 754 bytes internal/test/LANGUAGE/AUTO/AR5741.TEST | 1 + internal/test/LANGUAGE/AUTO/AR6150.DFASL | Bin 0 -> 1685 bytes internal/test/LANGUAGE/AUTO/AR6150.TEST | 1 + internal/test/LANGUAGE/AUTO/AR6247.DFASL | Bin 0 -> 2293 bytes internal/test/LANGUAGE/AUTO/AR6247.TEST | 1 + internal/test/LANGUAGE/AUTO/AR6273.DFASL | Bin 0 -> 774 bytes internal/test/LANGUAGE/AUTO/AR6273.TEST | 1 + internal/test/LANGUAGE/AUTO/AR6781.DFASL | Bin 0 -> 1295 bytes internal/test/LANGUAGE/AUTO/AR6781.TEST | 1 + internal/test/LANGUAGE/AUTO/AR7412.DFASL | Bin 0 -> 823 bytes internal/test/LANGUAGE/AUTO/AR7412.TEST | 1 + internal/test/LANGUAGE/AUTO/AR7475.DFASL | Bin 0 -> 1359 bytes internal/test/LANGUAGE/AUTO/AR7475.TEST | 1 + internal/test/LANGUAGE/AUTO/AR7525.DFASL | Bin 0 -> 1832 bytes internal/test/LANGUAGE/AUTO/AR7525.TEST | 1 + internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL | Bin 0 -> 1888 bytes internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST | 1 + internal/test/LANGUAGE/AUTO/AR7647.DFASL | Bin 0 -> 749 bytes internal/test/LANGUAGE/AUTO/AR7647.TEST | 1 + internal/test/LANGUAGE/AUTO/AR7742.DFASL | Bin 0 -> 1014 bytes internal/test/LANGUAGE/AUTO/AR7742.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8135.DFASL | Bin 0 -> 2075 bytes internal/test/LANGUAGE/AUTO/AR8135.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8136.DFASL | Bin 0 -> 1458 bytes internal/test/LANGUAGE/AUTO/AR8136.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8190.DFASL | Bin 0 -> 1093 bytes internal/test/LANGUAGE/AUTO/AR8190.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8207.DFASL | Bin 0 -> 887 bytes internal/test/LANGUAGE/AUTO/AR8207.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8297.TEST | Bin 0 -> 343 bytes internal/test/LANGUAGE/AUTO/AR8301.DFASL | Bin 0 -> 918 bytes internal/test/LANGUAGE/AUTO/AR8301.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8319.DFASL | Bin 0 -> 790 bytes internal/test/LANGUAGE/AUTO/AR8319.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8458.DFASL | Bin 0 -> 784 bytes internal/test/LANGUAGE/AUTO/AR8458.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8465.DFASL | Bin 0 -> 842 bytes internal/test/LANGUAGE/AUTO/AR8465.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8466.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8470.DFASL | Bin 0 -> 799 bytes internal/test/LANGUAGE/AUTO/AR8470.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8491.TEST | 1 + internal/test/LANGUAGE/AUTO/AR8575.DFASL | Bin 0 -> 883 bytes internal/test/LANGUAGE/AUTO/AR8575.TEST | 1 + .../LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST | Bin 0 -> 2445 bytes internal/test/LANGUAGE/AUTO/ARRAY.DFASL | Bin 0 -> 2769 bytes internal/test/LANGUAGE/AUTO/ARRAY.TEST | 1 + internal/test/LANGUAGE/AUTO/ARRAYP.DFASL | Bin 0 -> 3481 bytes internal/test/LANGUAGE/AUTO/ARRAYP.TEST | 1 + .../test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST | Bin 0 -> 512 bytes .../AUTO/BIGNUM-PATCH-REGRESSION.DFASL | Bin 0 -> 800 bytes .../AUTO/BIGNUM-PATCH-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/BINDING.DFASL | Bin 0 -> 1961 bytes internal/test/LANGUAGE/AUTO/BINDING.TEST | 1 + .../AUTO/BYTECOMPILER-REGRESSION.DFASL | Bin 0 -> 2543 bytes .../AUTO/BYTECOMPILER-REGRESSION.TEST | 1 + .../test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL | Bin 0 -> 2301 bytes .../test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/CHARSET.TEST | 1 + .../AUTO/CL-INTERPRETER-REGRESSION.DFASL | Bin 0 -> 6083 bytes .../AUTO/CL-INTERPRETER-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL | Bin 0 -> 2723 bytes .../LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST | 1 + .../test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL | Bin 0 -> 1031 bytes .../test/LANGUAGE/AUTO/CMLARRAY-PATCH.TEST | 1 + internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL | Bin 0 -> 914 bytes internal/test/LANGUAGE/AUTO/CMLARRAY.TEST | 1 + .../test/LANGUAGE/AUTO/CMLCHARACTER.DFASL | Bin 0 -> 923 bytes internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST | 1 + .../test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST | 350 ++++++++ .../LANGUAGE/AUTO/CMLFILESYS-REGRESSION.DFASL | Bin 0 -> 1241 bytes .../LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST | Bin 0 -> 390 bytes .../AUTO/CMLPATHNAME-REGRESSION.DFASL | Bin 0 -> 862 bytes .../LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/CMLPROGV-REGRESSION.DFASL | Bin 0 -> 1262 bytes .../LANGUAGE/AUTO/CMLPROGV-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/CMLRAND.DFASL | Bin 0 -> 1170 bytes internal/test/LANGUAGE/AUTO/CMLRAND.TEST | 1 + .../AUTO/CMLREADTABLE-REGRESSION.DFASL | Bin 0 -> 3661 bytes .../AUTO/CMLREADTABLE-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL | Bin 0 -> 873 bytes .../LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.TEST | 1 + .../LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL | Bin 0 -> 1348 bytes .../LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST | 1 + .../AUTO/CMLSPECIALFORMS-REGRESSION.DFASL | Bin 0 -> 1089 bytes .../AUTO/CMLSPECIALFORMS-REGRESSION.TEST | 1 + .../test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL | Bin 0 -> 1098 bytes .../test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST | 1 + internal/test/LANGUAGE/AUTO/COMMON.TEST | 1 + .../test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST | 1 + .../test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST | 1 + .../test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST | 1 + .../test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST | 1 + .../test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST | 1 + internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST | 286 ++++++ .../LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST | 1 + .../LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST | Bin 0 -> 1837 bytes .../LANGUAGE/AUTO/DELETE-SIDE-EFFECT.TEST | 1 + internal/test/LANGUAGE/AUTO/DESCRIBE.TEST | 1 + .../AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST | Bin 0 -> 446 bytes .../AUTO/ERROR-RUNTIME-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/EVENP.TEST | 1 + .../LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/FIXP.TEST | 1 + internal/test/LANGUAGE/AUTO/FLOATP.TEST | 1 + .../test/LANGUAGE/AUTO/FORMAT-AR7912.TEST | 1 + .../test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST | Bin 0 -> 603 bytes .../LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/HARRAYP.TEST | 1 + internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST | 1 + internal/test/LANGUAGE/AUTO/HASHARRAY.TEST | 1 + .../AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST | 1 + .../AUTO/INTERLISP-DATATYPES-AR7398.TEST | 1 + .../AUTO/INTERLISP-DATATYPES-ATOM.TEST | 1 + .../LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST | 1 + .../AUTO/INTERLISP-DATATYPESLITATOM.TEST | 1 + .../test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST | 1 + .../test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST | 665 ++++++++++++++ .../LANGUAGE/AUTO/INTERPRETER-AR8538.TEST | 1 + .../LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST | 1 + .../LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/LLREAD.TEST | 1 + .../LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST | 1 + .../LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/NLISTP.TEST | 1 + internal/test/LANGUAGE/AUTO/NUMBERP.TEST | 1 + internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST | 1 + .../LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST | 1 + .../LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA | 1 + .../AUTO/PRETTY-CIRCLE-REGRESSION.TEST | 1 + .../test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST | 1 + .../test/LANGUAGE/AUTO/PROC-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/PROPERTY.TEST | 1 + internal/test/LANGUAGE/AUTO/REGRESSION.TEST | Bin 0 -> 2445 bytes .../LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST | 1 + .../test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST | 1 + internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST | 1 + internal/test/LANGUAGE/AUTO/SMALLP.TEST | 1 + internal/test/LANGUAGE/AUTO/SPECIALS.TEST | 1 + internal/test/LANGUAGE/AUTO/STACK.TEST | Bin 0 -> 1661 bytes internal/test/LANGUAGE/AUTO/STRING.TEST | 1 + internal/test/LANGUAGE/AUTO/STRING.TESTS | 1 + internal/test/LANGUAGE/AUTO/STRINGP.TEST | 1 + .../test/LANGUAGE/AUTO/STRINGS-AR7993.TEST | 1 + .../AUTO/STRUCTURE-PRINT-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST | 1 + internal/test/LANGUAGE/AUTO/TYPENAME.TEST | 1 + internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST | 1 + internal/test/LANGUAGE/AUTO/USERDEF.TEST | 1 + internal/test/LANGUAGE/AUTO/VECTOR.TEST | Bin 0 -> 331 bytes .../test/LANGUAGE/AUTO/WRAPPERS-AR7900.TEST | 1 + .../LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST | 1 + .../AUTO/XCL-COMPILER-REGRESSION.TEST | 1 + .../test/LANGUAGE/AUTO/XCLC-REGRESSION.TEST | 1 + internal/test/LANGUAGE/AUTO/Y | 1 + internal/test/LANGUAGE/AUTO/test-results | 1 + internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U | 1 + .../test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U | 1 + internal/test/LANGUAGE/Hand/25-3-STEP.U | 1 + internal/test/LANGUAGE/Hand/25-3-TRACE.U | 1 + internal/test/LANGUAGE/Hand/25-3-UNTRACE.U | 1 + .../test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG | 1 + internal/test/LANGUAGE/LOGS/31-AUG-88.1109 | 1 + .../test/LANGUAGE/Plans/21-STREAMS.NOTEFILE | Bin 0 -> 114615 bytes internal/test/LANGUAGE/from-sun/README | 1 + .../language/10/10-1-GET-PROPERTIES.TEST | 1 + .../from-sun/language/10/10-1-GET.TEST | 1 + .../from-sun/language/10/10-1-GETF.TEST | 1 + .../from-sun/language/10/10-1-REMF.TEST | 1 + .../from-sun/language/10/10-1-REMPROP.TEST | 1 + .../language/10/10-1-SYMBOL-PLIST.TEST | 1 + .../language/10/10-2-SYMBOL-NAME.TEST | 1 + .../language/10/10-3-COPY-SYMBOL.TEST | 1 + .../from-sun/language/10/10-3-GENSYM.TEST | 1 + .../from-sun/language/10/10-3-GENTEMP.TEST | 1 + .../from-sun/language/10/10-3-KEYWORDP.TEST | 1 + .../language/10/10-3-MAKE-SYMBOL.TEST | 1 + .../language/10/10-3-SYMBOL-PACKAGE.TEST | 1 + .../from-sun/language/11/11-6-IMPORT.TEST | 1 + .../language/11/11-7-DO-ALL-SYMBOLS.TEST | 1 + .../language/11/11-7-DO-EXTERNAL-SYMBOLS.TEST | 1 + .../from-sun/language/11/11-7-DO-SYMBOLS.TEST | 1 + .../from-sun/language/11/11-7-EXPORT.TEST | 1 + .../language/11/11-7-FIND-ALL-SYMBOLS.TEST | 1 + .../language/11/11-7-FIND-PACKAGE.TEST | 1 + .../language/11/11-7-FIND-SYMBOL.TEST | 1 + .../from-sun/language/11/11-7-IMPORT.TEST | 1 + .../from-sun/language/11/11-7-IN-PACKAGE.TEST | 1 + .../from-sun/language/11/11-7-INTERN.TEST | 1 + .../language/11/11-7-LIST-ALL-PACKAGES.TEST | 1 + .../language/11/11-7-MAKE-PACKAGE.TEST | 1 + .../language/11/11-7-PACKAGE-NAME.TEST | 1 + .../language/11/11-7-PACKAGE-NICKNAMES.TEST | 1 + .../11/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST | 1 + .../language/11/11-7-PACKAGE-USE-LIST.TEST | 1 + .../11/11-7-PACKAGE-USED-BY-LIST.TEST | 1 + .../language/11/11-7-RENAME-PACKAGE.TEST | 1 + .../from-sun/language/11/11-7-SHADOW.TEST | 1 + .../language/11/11-7-SHADOWING-IMPORT.TEST | 1 + .../from-sun/language/11/11-7-UNEXPORT.TEST | 1 + .../from-sun/language/11/11-7-UNINTERN.TEST | 1 + .../language/11/11-7-UNUSE-PACKAGE.TEST | 1 + .../language/11/11-7-USE-PACKAGE.TEST | 1 + .../from-sun/language/11/11-8-PROVIDE.TEST | 1 + .../12/12-10-IMPLEMENTATION-PARAMETERS.TEST | 1 + .../from-sun/language/12/12-2-EVENP.TEST | 1 + .../from-sun/language/12/12-2-EVENP.TST | 1 + .../from-sun/language/12/12-2-MINUSP.TEST | 1 + .../from-sun/language/12/12-2-MINUSP.TST | 1 + .../from-sun/language/12/12-2-ODDP.TEST | 1 + .../from-sun/language/12/12-2-ODDP.TST | 1 + .../from-sun/language/12/12-2-PLUSP.TEST | 1 + .../from-sun/language/12/12-2-PLUSP.TST | 1 + .../from-sun/language/12/12-2-ZEROP.TEST | 1 + .../from-sun/language/12/12-2-ZEROP.TXT | 1 + .../from-sun/language/12/12-3-EQP.TEST | 1 + .../from-sun/language/12/12-3-GEQ.TEST | 1 + .../from-sun/language/12/12-3-GREATERP.TEST | 1 + .../from-sun/language/12/12-3-LEQ.TEST | 1 + .../from-sun/language/12/12-3-LESSP.TEST | 1 + .../from-sun/language/12/12-3-MAX.TEST | 1 + .../from-sun/language/12/12-3-MIN.TEST | 1 + .../12/12-3-MONOTONIC-NONDECREASE.TEST | 1 + .../12/12-3-MONOTONIC-NONINCREASE.TEST | 1 + .../from-sun/language/12/12-3-NEQP.TEST | 1 + .../LANGUAGE/from-sun/language/12/12-4-+.TEST | 1 + .../LANGUAGE/from-sun/language/12/12-4--.TEST | 1 + .../from-sun/language/12/12-4-1+.TEST | 1 + .../from-sun/language/12/12-4-1-.TEST | 1 + .../from-sun/language/12/12-4-CONJUGATE.TEST | 1 + .../from-sun/language/12/12-4-DECF.TEST | 1 + .../from-sun/language/12/12-4-GCD.TEST | 1 + .../from-sun/language/12/12-4-INCF.TEST | 1 + .../from-sun/language/12/12-4-LCM.TEST | 1 + .../from-sun/language/12/12-4-QUOTIENT.TEST | 1 + .../from-sun/language/12/12-4-TIMES.TEST | 1 + .../from-sun/language/12/12-5-1-EXP.TEST | 1 + .../from-sun/language/12/12-5-1-EXPT.TEST | 1 + .../from-sun/language/12/12-5-1-ISQRT.TEST | 1 + .../from-sun/language/12/12-5-1-LOG.TEST | 1 + .../from-sun/language/12/12-5-1-SQRT.TEST | 1 + .../from-sun/language/12/12-5-2-ABS.TEST | 1 + .../from-sun/language/12/12-5-2-ACOS.TEST | 1 + .../from-sun/language/12/12-5-2-ACOSH.TEST | 1 + .../from-sun/language/12/12-5-2-ASIN.TEST | 1 + .../from-sun/language/12/12-5-2-ASINH.TEST | 1 + .../from-sun/language/12/12-5-2-ATAN.TEST | 1 + .../from-sun/language/12/12-5-2-ATANH.TEST | 1 + .../from-sun/language/12/12-5-2-CIS.TEST | 1 + .../from-sun/language/12/12-5-2-COS.TEST | 1 + .../from-sun/language/12/12-5-2-COSH.TEST | 1 + .../from-sun/language/12/12-5-2-PHASE.TEST | 1 + .../from-sun/language/12/12-5-2-SIGNUM.TEST | 1 + .../from-sun/language/12/12-5-2-SIN.TEST | 1 + .../from-sun/language/12/12-5-2-SINH.TEST | 1 + .../from-sun/language/12/12-5-2-TAN.TEST | 1 + .../from-sun/language/12/12-5-2-TANH.TEST | 1 + .../from-sun/language/12/12-6-CEILING.TEST | 1 + .../from-sun/language/12/12-6-COMPLEX.TEST | 1 + .../language/12/12-6-DECODE-FLOAT.TEST | 1 + .../language/12/12-6-DENOMINATOR.TEST | 1 + .../from-sun/language/12/12-6-FCEILING.TEST | 1 + .../from-sun/language/12/12-6-FFLOOR.TEST | 1 + .../language/12/12-6-FLOAT-DIGITS.TEST | 1 + .../language/12/12-6-FLOAT-PRECISION.TEST | 1 + .../language/12/12-6-FLOAT-RADIX.TEST | 1 + .../from-sun/language/12/12-6-FLOAT-SIGN.TEST | 1 + .../from-sun/language/12/12-6-FLOAT.TEST | 1 + .../from-sun/language/12/12-6-FLOOR.TEST | 1 + .../from-sun/language/12/12-6-FROUND.TEST | 1 + .../from-sun/language/12/12-6-FTRUNCATE.TEST | 1 + .../from-sun/language/12/12-6-IMAGPART.TEST | 1 + .../12/12-6-INTEGER-DECODE-FLOAT.TEST | 1 + .../from-sun/language/12/12-6-MOD.TEST | 1 + .../from-sun/language/12/12-6-NUMERATOR.TEST | 1 + .../from-sun/language/12/12-6-RATIONAL.TEST | 1 + .../language/12/12-6-RATIONALIZE.TEST | 1 + .../from-sun/language/12/12-6-REALPART.TEST | 1 + .../from-sun/language/12/12-6-REM.TEST | 1 + .../from-sun/language/12/12-6-ROUND.TEST | 1 + .../language/12/12-6-SCALE-FLOAT.TEST | 1 + .../from-sun/language/12/12-6-TRUNCATE.TEST | 1 + .../from-sun/language/12/12-7-ASH.TEST | 1 + .../from-sun/language/12/12-7-BOOLE.TEST | 1 + .../language/12/12-7-INTEGER-LENGTH.TEST | 1 + .../from-sun/language/12/12-7-LOGAND.TEST | 1 + .../from-sun/language/12/12-7-LOGANDC1.TEST | 1 + .../from-sun/language/12/12-7-LOGANDC2.TEST | 1 + .../from-sun/language/12/12-7-LOGBITP.TEST | 1 + .../from-sun/language/12/12-7-LOGCOUNT.TEST | 1 + .../from-sun/language/12/12-7-LOGEQV.TEST | 1 + .../from-sun/language/12/12-7-LOGIOR.TEST | 1 + .../from-sun/language/12/12-7-LOGNAND.TEST | 1 + .../from-sun/language/12/12-7-LOGNOR.TEST | 1 + .../from-sun/language/12/12-7-LOGNOT.TEST | 1 + .../from-sun/language/12/12-7-LOGORC1.TEST | 1 + .../from-sun/language/12/12-7-LOGORC2.TEST | 1 + .../from-sun/language/12/12-7-LOGTEST.TEST | 1 + .../from-sun/language/12/12-7-LOGXOR.TEST | 1 + .../language/12/12-8-BYTE-POSITION.TEST | 1 + .../from-sun/language/12/12-8-BYTE-SIZE.TEST | 1 + .../from-sun/language/12/12-8-BYTE.TEST | 1 + .../language/12/12-8-DEPOSIT-FIELD.TEST | 1 + .../from-sun/language/12/12-8-DPB.TEST | 1 + .../from-sun/language/12/12-8-LDB-TEST.TEST | 1 + .../from-sun/language/12/12-8-LDB.TEST | 1 + .../from-sun/language/12/12-8-MASK-FIELD.TEST | 1 + .../language/12/12-9-MAKE-RANDOM-STATE.TEST | 1 + .../language/12/12-9-RANDOM-STATE-P.TEST | 1 + .../from-sun/language/12/12-9-RANDOM.TEST | 1 + .../language/13/13-1-CHARACTERATTRIBUTES.TEST | 1 + .../language/13/13-2-ALPHA-CHAR-P.TEST | 1 + .../language/13/13-2-ALPHANUMERIC-P.TEST | 1 + .../language/13/13-2-BOTH-CASE-P.TEST | 1 + .../from-sun/language/13/13-2-CHAR-EQUAL.TEST | 1 + .../from-sun/language/13/13-2-CHAR-GE.TEST | 1 + .../language/13/13-2-CHAR-GREATERP.TEST | 1 + .../from-sun/language/13/13-2-CHAR-GT.TEST | 1 + .../from-sun/language/13/13-2-CHAR-LE.TEST | 1 + .../from-sun/language/13/13-2-CHAR-LESSP.TEST | 1 + .../from-sun/language/13/13-2-CHAR-LT.TEST | 1 + .../language/13/13-2-CHAR-NOT-EQUAL.TEST | 1 + .../language/13/13-2-CHAR-NOT-GREATERP.TEST | 1 + .../language/13/13-2-CHAR-NOT-LESSP.TEST | 1 + .../from-sun/language/13/13-2-CHAREQ.TEST | 1 + .../from-sun/language/13/13-2-CHARNEQ.TEST | 1 + .../language/13/13-2-DIGIT-CHAR-P.TEST | 1 + .../language/13/13-2-GRAPHIC-CHAR-P.TEST | 1 + .../language/13/13-2-LOWER-CASE-P.TEST | 1 + .../language/13/13-2-STANDARD-CHAR-P.TEST | 1 + .../language/13/13-2-STRING-CHAR-P.TEST | 1 + .../language/13/13-2-UPPER-CASE-P.TEST | 1 + .../from-sun/language/13/13-3-CHAR-BITS.TEST | 1 + .../from-sun/language/13/13-3-CHAR-CODE.TEST | 1 + .../from-sun/language/13/13-3-CHAR-FONT.TEST | 1 + .../from-sun/language/13/13-3-CODE-CHAR.TEST | 1 + .../from-sun/language/13/13-3-MAKE-CHAR.TEST | 1 + .../language/13/13-4-CHAR-DOWNCASE.TEST | 1 + .../from-sun/language/13/13-4-CHAR-INT.TEST | 1 + .../from-sun/language/13/13-4-CHAR-NAME.TEST | 1 + .../language/13/13-4-CHAR-UPCASE.TEST | 1 + .../from-sun/language/13/13-4-CHARACTER.TEST | 1 + .../from-sun/language/13/13-4-DIGIT-CHAR.TEST | 1 + .../from-sun/language/13/13-4-INT-CHAR.TEST | 1 + .../from-sun/language/13/13-4-NAME-CHAR.TEST | 1 + .../from-sun/language/13/13-5-CHAR-BIT.TEST | 1 + .../language/13/13-5-SET-CHAR-BIT.TEST | 1 + .../from-sun/language/14/14-1-COPY-SEQ.TEST | 1 + .../from-sun/language/14/14-1-ELT.TEST | 1 + .../from-sun/language/14/14-1-LENGTH.TEST | 1 + .../language/14/14-1-MAKE-SEQUENCE.TEST | 1 + .../from-sun/language/14/14-1-NREVERSE.TEST | 1 + .../from-sun/language/14/14-1-REVERSE.TEST | 1 + .../from-sun/language/14/14-1-SUBSEQ.TEST | 1 + .../language/14/14-2-CONCATENATE.TEST | 1 + .../from-sun/language/14/14-2-EVERY.TEST | 1 + .../from-sun/language/14/14-2-MAP.TEST | 1 + .../from-sun/language/14/14-2-NOTANY.TEST | 1 + .../from-sun/language/14/14-2-NOTEVERY.TEST | 1 + .../from-sun/language/14/14-2-REDUCE.TEST | 1 + .../from-sun/language/14/14-2-SOME.TEST | 1 + .../language/14/14-3-DELETE-DUPLICATES.TEST | 1 + .../language/14/14-3-DELETE-IF-NOT.TEST | 1 + .../from-sun/language/14/14-3-DELETE-IF.TEST | 1 + .../from-sun/language/14/14-3-DELETE.TEST | 1 + .../from-sun/language/14/14-3-FILL.TEST | 1 + .../language/14/14-3-FIND-IF-NOT.TEST | 1 + .../from-sun/language/14/14-3-FIND-IF.TEST | 1 + .../from-sun/language/14/14-3-FIND.TEST | 1 + .../language/14/14-3-NSUBSTITUTE-IF-NOT.TEST | 1 + .../language/14/14-3-NSUBSTITUTE-IF.TEST | 1 + .../language/14/14-3-NSUBSTITUTE.TEST | 1 + .../language/14/14-3-POSITION-IF-NOT.TEST | 1 + .../language/14/14-3-POSITION-IF.TEST | 1 + .../from-sun/language/14/14-3-POSITION.TEST | 1 + .../language/14/14-3-REMOVE-DUPLICATES.TEST | 1 + .../language/14/14-3-REMOVE-IF-NOT.TEST | 1 + .../from-sun/language/14/14-3-REMOVE-IF.TEST | 1 + .../from-sun/language/14/14-3-REMOVE.TEST | 1 + .../from-sun/language/14/14-3-REPLACE.TEST | 1 + .../language/14/14-3-SUBSTITUTE-IF-NOT.TEST | 1 + .../language/14/14-3-SUBSTITUTE-IF.TEST | 1 + .../from-sun/language/14/14-3-SUBSTITUTE.TEST | 1 + .../language/14/14-4-COUNT-IF-NOT.TEST | 1 + .../from-sun/language/14/14-4-COUNT-IF.TEST | 1 + .../from-sun/language/14/14-4-COUNT.TEST | 1 + .../from-sun/language/14/14-4-MISMATCH.TEST | Bin 0 -> 4605 bytes .../from-sun/language/14/14-5-MERGE.TEST | 1 + .../from-sun/language/14/14-5-SORT.TEST | 1 + .../language/14/14-5-STABLE-SORT.TEST | 1 + .../from-sun/language/15/15-1-CAAAAR.TEST | 1 + .../from-sun/language/15/15-1-CAAADR.TEST | 1 + .../from-sun/language/15/15-1-CAAAR.TEST | 1 + .../from-sun/language/15/15-1-CAADAR.TEST | 1 + .../from-sun/language/15/15-1-CAADDR.TEST | 1 + .../from-sun/language/15/15-1-CAADR.TEST | 1 + .../from-sun/language/15/15-1-CAAR.TEST% | 1 + .../from-sun/language/15/15-1-CADAA.TEST | 1 + .../from-sun/language/15/15-1-CADADR.TEST | 1 + .../from-sun/language/15/15-1-CADAR.TEST | 1 + .../from-sun/language/15/15-1-CADDAR.TEST | 1 + .../language/15/15-1-CADDDR-AND-FOURTH.TEST | 1 + .../language/15/15-1-CADDR-AND-THIRD.TEST | 1 + .../language/15/15-1-CADR-AND-SECOND.TEST | 1 + .../language/15/15-1-CAR-AND-FIRST.TEST | 1 + .../from-sun/language/15/15-1-CDAAAR.TEST | 1 + .../from-sun/language/15/15-1-CDAADR.TEST | 1 + .../from-sun/language/15/15-1-CDAAR.TEST | 1 + .../from-sun/language/15/15-1-CDADAR.TEST | 1 + .../from-sun/language/15/15-1-CDADDR.TEST | 1 + .../from-sun/language/15/15-1-CDADR.TEST | 1 + .../from-sun/language/15/15-1-CDAR.TEST | 1 + .../from-sun/language/15/15-1-CDDAAR.TEST | 1 + .../from-sun/language/15/15-1-CDDADR.TEST | 1 + .../from-sun/language/15/15-1-CDDAR.TEST | 1 + .../from-sun/language/15/15-1-CDDDAR.TEST | 1 + .../from-sun/language/15/15-1-CDDDDR.TEST | 1 + .../from-sun/language/15/15-1-CDDDR.TEST | 1 + .../from-sun/language/15/15-1-CDDR.TEST | 1 + .../language/15/15-1-CDR-AND-REST.TEST | 1 + .../from-sun/language/15/15-1-CONS.TEST | 1 + .../from-sun/language/15/15-1-TREE-EQUAL.TEST | 1 + .../from-sun/language/15/15-2-APPEND.TEST | 1 + .../from-sun/language/15/15-2-BUTLAST.TEST | 1 + .../from-sun/language/15/15-2-COPY-ALIST.TEST | 1 + .../from-sun/language/15/15-2-COPY-LIST.TEST | 1 + .../from-sun/language/15/15-2-COPY-TREE.TEST | 1 + .../from-sun/language/15/15-2-EIGHTH.TEST | 1 + .../from-sun/language/15/15-2-ENDP.TEST | 1 + .../from-sun/language/15/15-2-FIFTH.TEST | 1 + .../from-sun/language/15/15-2-FIRST.TEST | 1 + .../from-sun/language/15/15-2-FOURTH.TEST | 1 + .../from-sun/language/15/15-2-LAST.TEST | 1 + .../from-sun/language/15/15-2-LDIFF.TEST | 1 + .../language/15/15-2-LIST-LENGTH.TEST | 1 + .../from-sun/language/15/15-2-LIST.TEST | 1 + .../from-sun/language/15/15-2-LISTSTAR.TEST | 1 + .../from-sun/language/15/15-2-LISTSTAR.TEST% | 1 + .../from-sun/language/15/15-2-MAKE-LIST.TEST | 1 + .../from-sun/language/15/15-2-NBUTLAST.TEST | 1 + .../from-sun/language/15/15-2-NCONC.TEST | 1 + .../from-sun/language/15/15-2-NINTH.TEST | 1 + .../from-sun/language/15/15-2-NRECONC.TEST | 1 + .../from-sun/language/15/15-2-NTH.TEST | 1 + .../from-sun/language/15/15-2-NTHCDR.TEST | 1 + .../from-sun/language/15/15-2-POP.TEST | 1 + .../from-sun/language/15/15-2-PUSH.TEST | 1 + .../from-sun/language/15/15-2-PUSHNEW.TEST | 1 + .../from-sun/language/15/15-2-REST.TEST | 1 + .../from-sun/language/15/15-2-REVAPPEND.TEST | 1 + .../from-sun/language/15/15-2-SECOND.TEST | 1 + .../from-sun/language/15/15-2-SEVENTH.TEST | 1 + .../from-sun/language/15/15-2-SIXTH.TEST | 1 + .../from-sun/language/15/15-2-TENTH.TEST | 1 + .../from-sun/language/15/15-2-THIRD.TEST | 1 + .../from-sun/language/15/15-3-RPLACA.TEST | 1 + .../from-sun/language/15/15-3-RPLACD.TEST | 1 + .../from-sun/language/15/15-4-NSUBLIS.TEST | 1 + .../language/15/15-4-NSUBST-IF-NOT.TEST | 1 + .../from-sun/language/15/15-4-NSUBST-IF.TEST | 1 + .../from-sun/language/15/15-4-NSUBST.TEST | 1 + .../from-sun/language/15/15-4-SUBLIS.TEST | 1 + .../language/15/15-4-SUBST-IF-NOT.TEST | 1 + .../from-sun/language/15/15-4-SUBST-IF.TEST | 1 + .../from-sun/language/15/15-4-SUBST.TEST | 1 + .../from-sun/language/15/15-5-ADJOIN.TEST | 1 + .../language/15/15-5-INTERSECTION.TEST | 1 + .../language/15/15-5-MEMBER-IF-NOT.TEST | 1 + .../from-sun/language/15/15-5-MEMBER-IF.TEST | 1 + .../from-sun/language/15/15-5-MEMBER.TEST | 1 + .../language/15/15-5-NINTERSECTION.TEST | 1 + .../language/15/15-5-NSET-DIFFERENCE.TEST | 1 + .../language/15/15-5-NSET-EXCLUSIVE-OR.TEST | 1 + .../from-sun/language/15/15-5-NUNION.TEST | 1 + .../language/15/15-5-SET-DIFFERENCE.TEST | 1 + .../language/15/15-5-SET-EXCLUSIVE-OR.TEST | 1 + .../from-sun/language/15/15-5-SUBSETP.TEST | 1 + .../from-sun/language/15/15-5-TAILP.TEST | 1 + .../from-sun/language/15/15-5-UNION.TEST | 1 + .../from-sun/language/15/15-6-ACONS.TEST | 1 + .../language/15/15-6-ASSOC-IF-NOT.TEST | 1 + .../from-sun/language/15/15-6-ASSOC-IF.TEST | 1 + .../from-sun/language/15/15-6-ASSOC.TEST | 1 + .../from-sun/language/15/15-6-PAIRLIS.TEST | 1 + .../language/15/15-6-RASSOC-IF-NOT.TEST | 1 + .../from-sun/language/15/15-6-RASSOC-IF.TEST | 1 + .../from-sun/language/15/15-6-RASSOC.TEST | 1 + .../from-sun/language/16/16-1-CLRHASH.TEST | 1 + .../from-sun/language/16/16-1-GETHASH.TEST | 1 + .../language/16/16-1-HASH-TABLE-COUNT.TEST | 1 + .../language/16/16-1-HASH-TABLE-P.TEST | 1 + .../language/16/16-1-MAKE-HASH-TABLE.TEST | 1 + .../from-sun/language/16/16-1-MAPHASH.TEST | 1 + .../from-sun/language/16/16-1-REMHASH.TEST | 1 + .../from-sun/language/16/16-2-SXHASH.TEST | 1 + .../from-sun/language/17/17-1-MAKE-ARRAY.TEST | 1 + .../from-sun/language/17/17-1-VECTOR.TEST | 1 + .../from-sun/language/17/17-2-AREF.TEST | 1 + .../from-sun/language/17/17-2-SVREF.TEST | 1 + .../language/17/17-3-ADJUSTABLE-ARRAY-P.TEST | 1 + .../language/17/17-3-ARRAY-DIMENSION.TEST | 1 + .../language/17/17-3-ARRAY-DIMENSIONS.TEST | 1 + .../language/17/17-3-ARRAY-ELEMENT-TYPE.TEST | 1 + .../language/17/17-3-ARRAY-IN-BOUNDS-P.TEST | 1 + .../from-sun/language/17/17-3-ARRAY-RANK.TEST | 1 + .../17/17-3-ARRAY-ROW-MAJOR-INDEX.TEST | 1 + .../language/17/17-3-ARRAY-TOTAL-SIZE.TEST | 1 + .../from-sun/language/17/17-4-BIT-AND.TEST | 1 + .../from-sun/language/17/17-4-BIT-ANDC1.TEST | 1 + .../from-sun/language/17/17-4-BIT-ANDC2.TEST | 1 + .../from-sun/language/17/17-4-BIT-EQV.TEST | 1 + .../from-sun/language/17/17-4-BIT-IOR.TEST | 1 + .../from-sun/language/17/17-4-BIT-NAND.TEST | 1 + .../from-sun/language/17/17-4-BIT-NOR.TEST | 1 + .../from-sun/language/17/17-4-BIT-NOT.TEST | 1 + .../from-sun/language/17/17-4-BIT-ORC1.TEST | 1 + .../from-sun/language/17/17-4-BIT-ORC2.TEST | 1 + .../from-sun/language/17/17-4-BIT-XOR.TEST | 1 + .../from-sun/language/17/17-4-BIT.TEST | 1 + .../from-sun/language/17/17-4-SBIT.TEST | 1 + .../17/17-5-ARRAY-HAS-FILL-POINTER-P.TEST | 1 + .../language/17/17-5-FILL-POINTER.TEST | 1 + .../from-sun/language/17/17-5-VECTOR-POP.TEST | 1 + .../language/17/17-5-VECTOR-PUSH-EXTEND.TEST | 1 + .../language/17/17-5-VECTOR-PUSH.TEST | 1 + .../language/17/17-6-ADJUST-ARRAY.TEST | 1 + .../from-sun/language/18/18-1-CHAR.TEST | 1 + .../from-sun/language/18/18-1-SCHAR.TEST | 1 + .../from-sun/language/18/18-2-STRING-EQ.TEST | 1 + .../language/18/18-2-STRING-EQUAL.TEST | 1 + .../from-sun/language/18/18-2-STRING-GE.TEST | 1 + .../language/18/18-2-STRING-GREATERP.TEST | 1 + .../from-sun/language/18/18-2-STRING-GT.TEST | 1 + .../from-sun/language/18/18-2-STRING-LE.TEST | 1 + .../language/18/18-2-STRING-LESSP.TEST | 1 + .../from-sun/language/18/18-2-STRING-LT.TEST | 1 + .../from-sun/language/18/18-2-STRING-NEQ.TEST | 1 + .../language/18/18-2-STRING-NOT-EQUAL.TEST | 1 + .../language/18/18-2-STRING-NOT-GREATERP.TEST | 1 + .../language/18/18-2-STRING-NOT-LESSP.TEST | 1 + .../language/18/18-3-MAKE-STRING.TEST | 1 + .../language/18/18-3-NSTRING-CAPITALIZE.TEST | 1 + .../language/18/18-3-NSTRING-DOWNCASE.TEST | 1 + .../language/18/18-3-NSTRING-UPCASE.TEST | 1 + .../language/18/18-3-STRING-CAPITALIZE.TEST | 1 + .../language/18/18-3-STRING-DOWNCASE.TEST | 1 + .../language/18/18-3-STRING-LEFT-TRIM.TEST | 1 + .../language/18/18-3-STRING-RIGHT-TRIM.TEST | 1 + .../language/18/18-3-STRING-TRIM.TEST | 1 + .../language/18/18-3-STRING-UPCASE.TEST | 1 + .../from-sun/language/18/18-3-STRING.TEST | 1 + .../from-sun/language/19/19-DEFSTRUCT.TEST | 1 + .../from-sun/language/20/20-1-APPLYHOOK.TEST | 1 + .../from-sun/language/20/20-1-CONSTANTP.TEST | 1 + .../from-sun/language/20/20-1-EVAL.TEST | 1 + .../language/22/22-1-5-COPY-READTABLE.TEST | 1 + .../22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST | 1 + .../22/22-1-5-GET-MACRO-CHARACTER.TEST | 1 + .../22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST | 1 + .../language/22/22-1-5-READTABLEP.TEST | 1 + .../22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST | 1 + .../22/22-1-5-SET-MACRO-CHARACTER.TEST | 1 + .../22/22-1-5-SET-SYNTAX-FROM-CHAR.TEST | 1 + .../from-sun/language/22/22-2-1-LISTEN.TEST | 1 + .../language/22/22-2-1-PARSE-INTEGER.TEST | 1 + .../language/22/22-2-1-PEEK-CHAR.TEST | 1 + .../language/22/22-2-1-READ-CHAR-NO-HANG.TEST | 1 + .../language/22/22-2-1-READ-CHAR.TEST | 1 + .../22/22-2-1-READ-DELIMITED-LIST.TEST | 1 + .../language/22/22-2-1-READ-FROM-STRING.TEST | 1 + .../22/22-2-1-READ-PRESERVING-WHITESPACE.TEST | 1 + .../from-sun/language/22/22-2-1-READ.TEST | 1 + .../language/22/22-2-1-UNREAD-CHAR.TEST | 1 + .../language/22/22-3-1-FINISH-OUTPUT.TEST | 1 + .../language/22/22-3-1-FRESH-LINE.TEST | 1 + .../from-sun/language/22/22-3-1-PPRINT.TEST | 1 + .../language/22/22-3-1-PRIN1-TO-STRING.TEST | 1 + .../from-sun/language/22/22-3-1-PRIN1.TEST | 1 + .../language/22/22-3-1-PRINC-TO-STRING.TEST | 1 + .../from-sun/language/22/22-3-1-PRINC.TEST | 1 + .../from-sun/language/22/22-3-1-PRINT.TEST | 1 + .../from-sun/language/22/22-3-1-TERPRI.TEST | 1 + .../language/22/22-3-1-WRITE-CHAR.TEST | 1 + .../language/22/22-3-1-WRITE-LINE.TEST | 1 + .../language/22/22-3-1-WRITE-STRING.TEST | 1 + .../from-sun/language/22/22-3-3-FORMAT.TEST | 1 + .../test/LANGUAGE/from-sun/language/23/.DFASL | Bin 0 -> 165 bytes .../language/23/23-1-2-MAKE-PATHNAME.X | 1 + .../language/23/23-1-2-MERGE-PATHNAME.X | 1 + .../from-sun/language/23/23-1-2-NAMESTRING.X | 1 + .../language/23/23-1-2-PARSE-NAMESTRING.X | 1 + .../language/23/23-1-2-PATHNAME-DEVICE.X | 1 + .../language/23/23-1-2-PATHNAME-DIRECTORY.X | 1 + .../language/23/23-1-2-PATHNAME-HOST.X | 1 + .../language/23/23-1-2-PATHNAME-NAME.X | 1 + .../language/23/23-1-2-PATHNAME-TYPE.X | 1 + .../language/23/23-1-2-PATHNAME-VERSION.X | 1 + .../from-sun/language/23/23-1-2-PATHNAME.X | 1 + .../from-sun/language/23/23-1-2-PATHNAMEP.X | 1 + .../from-sun/language/23/23-1-2-TRUENAME.X | 1 + .../23/23-1-2-USER-HOMEDIR-PATHNAME.X | 1 + .../LANGUAGE/from-sun/language/23/23-2-OPEN.X | 1 + .../language/23/23-2-WITH-OPEN-FILE.X | 1 + .../from-sun/language/23/23-3-DELETE-FILE.X | 1 + .../from-sun/language/23/23-3-FILE-AUTHOR.X | 1 + .../from-sun/language/23/23-3-FILE-LENGTH.X | 1 + .../from-sun/language/23/23-3-FILE-POSITION.X | 1 + .../language/23/23-3-FILE-WRITE-DATE.X | 1 + .../from-sun/language/23/23-3-PROBE-FILE.X | 1 + .../from-sun/language/23/23-3-RENAME-FILE.X | 1 + .../LANGUAGE/from-sun/language/23/23-4-LOAD.X | 1 + .../from-sun/language/23/23-5-DIRECTORY.X | 1 + .../from-sun/language/23/23-FUNCTIONS | 1 + .../from-sun/language/23/23-FUNCTIONS.DEF | 1 + .../from-sun/language/24/24-1-BREAK.TEST | 1 + .../from-sun/language/24/24-1-CERROR.TEST | 1 + .../from-sun/language/24/24-1-CHECK-TYPE.TEST | 1 + .../from-sun/language/24/24-1-ERROR.TEST | 1 + .../from-sun/language/24/24-1-WARN.TEST | 1 + .../from-sun/language/24/24-2-ASSERT.TEST | 1 + .../from-sun/language/24/24-3-CCASE.TEST | 1 + .../from-sun/language/24/24-3-CTYPECASE.TEST | 1 + .../from-sun/language/24/24-3-ECASE.TEST | 1 + .../from-sun/language/24/24-3-ETYPECASE.TEST | 1 + .../from-sun/language/24/24-ERRORSYSTEM.X | 1 + .../language/25/25-1-COMPILE-FILE.TEST | 1 + .../from-sun/language/25/25-1-COMPILE.TEST | 1 + .../language/25/25-1-DISASSEMBLE.TEST | 1 + .../language/25/25-2-DOCUMENTATION.TEST | 1 + .../language/25/25-3-APROPOS-LIST.TEST | 1 + .../from-sun/language/25/25-3-APROPOS.TEST | 1 + .../from-sun/language/25/25-3-DESCRIBE.TEST | 1 + .../from-sun/language/25/25-3-ED.TEST | 1 + .../from-sun/language/25/25-3-INSPECT.TEST | 1 + .../from-sun/language/25/25-3-ROOM.TEST | 1 + .../from-sun/language/25/25-3-TIME.TEST | 1 + .../25/25-4-DECODE-UNIVERSAL-TIME.TEST | 1 + .../25/25-4-ENCODE-UNIVERSAL-TIME.TEST | 1 + .../language/25/25-4-GET-DECODED-TIME.TEST | 1 + .../25/25-4-GET-INTERNAL-REAL-TIME.TEST | 1 + .../25/25-4-GET-INTERNAL-RUN-TIME.TEST | 1 + .../language/25/25-4-GET-UNIVERSAL-TIME.TEST | 1 + .../25/25-4-LISP-IMPLEMENTATION-VERSION.TEST | 1 + .../language/25/25-4-LONG-SITE-NAME.TEST | 1 + .../language/25/25-4-MACHINE-INSTANCE.TEST | 1 + .../language/25/25-4-MACHINE-TYPE.TEST | 1 + .../language/25/25-4-MACHINE-VERSION.TEST | 1 + .../language/25/25-4-SHORT-SITE-NAME.TEST | 1 + .../from-sun/language/25/25-4-SLEEP.TEST | 1 + .../language/25/25-4-SOFTWARE-TYPE.TEST | 1 + .../language/25/25-4-SOFTWARE-VERSION.TEST | 1 + .../from-sun/language/25/25-5-IDENTITY.TEST | 1 + .../from-sun/language/4/4-7-DEFTYPE.TEST | 1 + .../from-sun/language/4/4-8-COERCE.TEST | 1 + .../from-sun/language/4/4-9-TYPE-OF.TEST | 1 + .../language/5/5-2-2-LAMBDA-EXPRESSIONS.TEST | 1 + .../5/5-2-2-LAMBDA-LIST-KEYWORDS.TEST | 1 + .../5/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST | 1 + .../from-sun/language/5/5-3-1-DEFUN.TEST | 1 + .../language/5/5-3-2-DEFCONSTANT.TEST | 1 + .../language/5/5-3-2-DEFPARAMETER.TEST | 1 + .../from-sun/language/5/5-3-2-DEFVAR.TEST | 1 + .../from-sun/language/5/5-3-3-EVAL-WHEN.TEST | 1 + .../from-sun/language/6/6-2-1-SUBTYPEP.TEST | 1 + .../from-sun/language/6/6-2-1-TYPEP.TEST | 1 + .../from-sun/language/6/6-2-2-ARRAYP.TEST | 1 + .../from-sun/language/6/6-2-2-ATOM.TEST | 1 + .../language/6/6-2-2-BIT-VECTOR-P.TEST | 1 + .../from-sun/language/6/6-2-2-CHARACTERP.TEST | 1 + .../from-sun/language/6/6-2-2-COMMONP.TEST | 1 + .../language/6/6-2-2-COMPILED-FUNCTION-P.TEST | 1 + .../from-sun/language/6/6-2-2-COMPLEXP.TEST | 1 + .../from-sun/language/6/6-2-2-CONSP.TEST | 1 + .../from-sun/language/6/6-2-2-FLOATP.TEST | 1 + .../from-sun/language/6/6-2-2-FUNCTIONP.TEST | 1 + .../from-sun/language/6/6-2-2-INTEGERP.TEST | 1 + .../from-sun/language/6/6-2-2-LISTP.TEST | 1 + .../from-sun/language/6/6-2-2-NULL.TEST | 1 + .../from-sun/language/6/6-2-2-NUMBERP.TEST | 1 + .../from-sun/language/6/6-2-2-PACKAGEP.TEST | 1 + .../from-sun/language/6/6-2-2-RATIONALP.TEST | 1 + .../language/6/6-2-2-SIMPLE-BIT-VECTOR-P.TEST | Bin 0 -> 4557 bytes .../from-sun/language/6/6-2-2-STRINGP.TEST | 1 + .../from-sun/language/6/6-2-2-SYMBOLP.TEST | 1 + .../from-sun/language/6/6-2-2-VECTORP.TEST | 1 + .../LANGUAGE/from-sun/language/6/6-3-EQ.TEST | 1 + .../LANGUAGE/from-sun/language/6/6-3-EQL.TEST | 1 + .../from-sun/language/6/6-3-EQUAL.TEST | 1 + .../from-sun/language/6/6-3-EQUALP.TEST | 1 + .../LANGUAGE/from-sun/language/6/6-4-AND.TEST | 1 + .../LANGUAGE/from-sun/language/6/6-4-NOT.TEST | 1 + .../LANGUAGE/from-sun/language/6/6-4-OR.TEST | 1 + .../from-sun/language/7/7-1-1-BOUNDP.TEST | 1 + .../from-sun/language/7/7-1-1-FBOUNDP.TEST | 1 + .../from-sun/language/7/7-1-1-FUNCTION.TEST | 1 + .../from-sun/language/7/7-1-1-QUOTE.TEST | 1 + .../language/7/7-1-1-SPECIAL-FORM-P.TEST | 1 + .../language/7/7-1-1-SYMBOL-FUNCTION.TEST | 1 + .../language/7/7-1-1-SYMBOL-VALUE.TEST | 1 + .../language/7/7-1-2-FMAKUNBOUND.TEST | 1 + .../from-sun/language/7/7-1-2-MAKUNBOUND.TEST | 1 + .../from-sun/language/7/7-1-2-PSETQ.TEST | 1 + .../from-sun/language/7/7-1-2-SET.TEST | 1 + .../from-sun/language/7/7-1-2-SETQ.TEST | 1 + .../from-sun/language/7/7-10-CATCH.TEST | 1 + .../from-sun/language/7/7-10-THROW.TEST | 1 + .../language/7/7-10-UNWIND-PROTECT.TEST | 1 + .../language/7/7-2-DEFINE-MODIFY-MACRO.TEST | 1 + .../language/7/7-2-DEFINE-SETF-METHOD.TEST | 1 + .../from-sun/language/7/7-2-DEFSETF.TEST | 1 + .../7/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST | 1 + .../language/7/7-2-GET-SETF-METHOD.TEST | 1 + .../from-sun/language/7/7-2-PSETF.TEST | 1 + .../from-sun/language/7/7-2-ROTATEF.TEST | 1 + .../from-sun/language/7/7-2-SETF.TEST | 1 + .../from-sun/language/7/7-2-SHIFTF.TEST | 1 + .../from-sun/language/7/7-3-APPLY.TEST | 1 + .../language/7/7-3-CALL-ARGUMENTS-LIMIT.TEST | 1 + .../from-sun/language/7/7-3-FUNCALL.TEST | 1 + .../from-sun/language/7/7-4-PROG1.TEST | 1 + .../from-sun/language/7/7-4-PROG2.TEST | 1 + .../from-sun/language/7/7-4-PROGN.TEST | 1 + .../from-sun/language/7/7-5-COMPILER-LET.TEST | 1 + .../from-sun/language/7/7-5-FLET.TEST | 1 + .../from-sun/language/7/7-5-LABELS.TEST | 1 + .../LANGUAGE/from-sun/language/7/7-5-LET.TEST | 1 + .../from-sun/language/7/7-5-LETSTAR.TEST | 1 + .../from-sun/language/7/7-5-MACROLET.TEST | 1 + .../from-sun/language/7/7-5-PROGV.TEST | 1 + .../from-sun/language/7/7-6-CASE.TEST | 1 + .../from-sun/language/7/7-6-COND.TEST | 1 + .../LANGUAGE/from-sun/language/7/7-6-IF.TEST | 1 + .../from-sun/language/7/7-6-TYPECASE.TEST | 1 + .../from-sun/language/7/7-6-UNLESS.TEST | 1 + .../from-sun/language/7/7-6-WHEN.TEST | 1 + .../from-sun/language/7/7-7-BLOCK.TEST | 1 + .../from-sun/language/7/7-7-RETURN-FROM.TEST | 1 + .../from-sun/language/7/7-7-RETURN.TEST | 1 + .../from-sun/language/7/7-8-1-LOOP.TEST | 1 + .../from-sun/language/7/7-8-2-DO.TEST | 1 + .../from-sun/language/7/7-8-2-DOSTAR.TEST | 1 + .../from-sun/language/7/7-8-3-DOLIST.TEST | 1 + .../from-sun/language/7/7-8-3-DOTIMES.TEST | 1 + .../from-sun/language/7/7-8-4-MAPC.TEST | 1 + .../from-sun/language/7/7-8-4-MAPCAN.TEST | 1 + .../from-sun/language/7/7-8-4-MAPCAR.TEST | 1 + .../from-sun/language/7/7-8-4-MAPCON.TEST | 1 + .../from-sun/language/7/7-8-4-MAPL.TEST | 1 + .../from-sun/language/7/7-8-4-MAPLIST.TEST | 1 + .../from-sun/language/7/7-8-4-MAPPER.TEST | 1 + .../from-sun/language/7/7-8-5-GO.TEST | 1 + .../from-sun/language/7/7-8-5-PROG.TEST | 1 + .../from-sun/language/7/7-8-5-PROGSTAR.TEST | 1 + .../from-sun/language/7/7-8-5-TAGBODY.TEST | 1 + .../7/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST | 1 + .../from-sun/language/7/7-9-2-MVR-CATCH.TEST | 1 + .../7/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST | 1 + .../7/7-9-2-MVR-IMPLICIT-PROGN-1.TEST | 1 + .../7/7-9-2-MVR-IMPLICIT-PROGN-2.TEST | 1 + .../language/7/7-9-2-MVR-MISC-SITUATIONS.TEST | 1 + .../language/7/7-9-MULTIPLE-VALUES.TEST | 1 + .../8/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST | 1 + .../from-sun/language/8/8-1-PARSE-BODY.TEST | 1 + .../8/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST | 1 + .../language/8/8-MACRO-ARG-EVAL-ORDER.PRETEST | 1 + .../from-sun/language/9/9-1-DECLARE.TEST | 1 + .../from-sun/language/9/9-1-LOCALLY.TEST | 1 + .../from-sun/language/9/9-1-PROCLAIM.TEST | 1 + .../LANGUAGE/from-sun/language/9/9-3-THE.TEST | 1 + .../LANGUAGE/from-sun/language/DO-TEST.DFASL | Bin 0 -> 12169 bytes .../test/LANGUAGE/from-sun/language/README | 1 + .../LANGUAGE/from-sun/language/ar/AR5741.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR6150.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR6247.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR6273.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR6781.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR7412.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR7475.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR7525.TEST | 1 + .../from-sun/language/ar/AR7587-DOC.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR7647.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR7742.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8135.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8136.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8190.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8207.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8297.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8301.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8319.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8458.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8465.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8466.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8470.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8491.TEST | 1 + .../LANGUAGE/from-sun/language/ar/AR8575.TEST | 1 + .../language/other/ARITHMETIC-REGRESSION.TEST | 1 + .../from-sun/language/other/ARRAY.TEST | 1 + .../from-sun/language/other/ARRAYP.TEST | 1 + .../language/other/ARRAYS-AR6466.TEST | 1 + .../other/BIGNUM-PATCH-REGRESSION.TEST | 1 + .../from-sun/language/other/BINDING.TEST | 1 + .../other/BYTECOMPILER-REGRESSION.TEST | 1 + .../language/other/CHAR-REGRESSION.TEST | 1 + .../from-sun/language/other/CHARSET.TEST | 1 + .../other/CL-INTERPRETER-REGRESSION.TEST | 1 + .../language/other/CLSTREAMS-REGRESSION.TEST | 1 + .../language/other/CMLARRAY-PATCH.TEST | 1 + .../from-sun/language/other/CMLARRAY.TEST | 1 + .../from-sun/language/other/CMLCHARACTER.TEST | 1 + .../language/other/CMLFILEMANAGER.TEST | 1 + .../language/other/CMLFILESYS-REGRESSION.TEST | 1 + .../from-sun/language/other/CMLFLOAT.TEST | 1 + .../other/CMLPATHNAME-REGRESSION.TEST | 1 + .../language/other/CMLPROGV-REGRESSION.TEST | 1 + .../from-sun/language/other/CMLRAND.TEST | 1 + .../other/CMLREADTABLE-REGRESSION.TEST | 1 + .../language/other/CMLSEQMODIFY-PATCH.TEST | 1 + .../language/other/CMLSETF-REGRESSION.TEST | 1 + .../other/CMLSPECIALFORMS-REGRESSION.TEST | 1 + .../language/other/CMLTYPES-PATCH.TEST | 1 + .../from-sun/language/other/COMMON.TEST | 1 + .../language/other/COMPILERS-AR8409.TEST | 1 + .../language/other/CONDITIONS-AR7875.TEST | 1 + .../language/other/CONDITIONS-AR7893.TEST | 1 + .../language/other/CONDITIONSAR7383.TEST | 1 + .../language/other/DEBUGGER-AR8512.TEST | 1 + .../from-sun/language/other/DEFDEFINE.TEST | 1 + .../language/other/DEFSTRUCT-ADDITIONAL.TEST | 1 + .../language/other/DEFSTRUCT-REGRESSION.TEST | 1 + .../language/other/DELETE-SIDE-EFFECT.TEST | 1 + .../from-sun/language/other/DESCRIBE.TEST | 1 + .../language/other/DOUBLE-OP-ARITH.TEST | 236 +++++ .../other/DOVEVMEMSIZEPATCH-LLFAULT.TEST | 1 + .../other/ERROR-RUNTIME-REGRESSION.TEST | 1 + .../language/other/EVALUATOR-REGRESSION.TEST | 1 + .../from-sun/language/other/EVENP.TEST | 1 + .../language/other/FASDUMP-REGRESSION.TEST | 1 + .../language/other/FASLOAD-REGRESSION.TEST | 1 + .../language/other/FILEPKG-REGRESSION.TEST | 1 + .../from-sun/language/other/FIXP.TEST | 1 + .../from-sun/language/other/FLOATP.TEST | 1 + .../language/other/FORMAT-AR7912.TEST | 1 + .../language/other/FORMAT-REGRESSION.TEST | 1 + .../language/other/FP-PRINT-REGRESSION.TEST | 1 + .../from-sun/language/other/HARRAYP.TEST | 1 + .../from-sun/language/other/HASH-AR7587.TEST | 1 + .../from-sun/language/other/HASHARRAY.TEST | 1 + .../other/INTERLISP-ARGUMENT-FUNCTIONS.TEST | 1 + .../other/INTERLISP-DATATYPES-AR7398.TEST | 1 + .../other/INTERLISP-DATATYPES-ATOM.TEST | 1 + .../language/other/INTERLISP-DATATYPES.TEST | 1 + .../other/INTERLISP-DATATYPESLITATOM.TEST | 1 + .../language/other/INTERLISP-ISOPRS.TEST | 1 + .../language/other/INTERLISP-RECORDS.TEST | 1 + .../language/other/INTERPRETER-AR8538.TEST | 1 + .../language/other/INTERPRETERS-AR8366.TEST | 1 + .../language/other/LLINTERP-REGRESSION.TEST | 1 + .../from-sun/language/other/LLREAD.TEST | 1 + .../language/other/LLSYMBOL-REGRESSION.TEST | 1 + .../language/other/LOCALFILE-REGRESSION.TEST | 1 + .../from-sun/language/other/LONGFNCALL.TEST | 1 + .../language/other/NAMESTRING-REGRESSION.TEST | 1 + .../from-sun/language/other/NLISTP.TEST | 1 + .../from-sun/language/other/NUMBERP.TEST | 1 + .../from-sun/language/other/PACKAGE-ARS.TEST | 1 + .../language/other/PACKAGE-CONDITIONS.TEST | 1 + .../other/PACKAGE-CONVERTER-TEST.DATA | 1 + .../language/other/PACKAGE-CONVERTER.TEST | 1 + .../other/PRETTY-CIRCLE-REGRESSION.TEST | 1 + .../language/other/PRINTING-MINUS0.TEST | 1 + .../language/other/PROC-REGRESSION.TEST | 1 + .../from-sun/language/other/PROPERTY.TEST | 1 + .../from-sun/language/other/REGRESSION.TEST | 1 + .../language/other/RESETVAR-REGRESSION.TEST | 1 + .../language/other/SIMPLE-SUPPLIED-P.TEST | 1 + .../language/other/SINGLE-OP-ARITH.TEST | Bin 0 -> 1794 bytes .../from-sun/language/other/SINGLE-VALUE.TEST | 1 + .../from-sun/language/other/SMALLP.TEST | 1 + .../from-sun/language/other/SPECIALS.TEST | 1 + .../from-sun/language/other/STACK.TEST | 1 + .../from-sun/language/other/STRING.TEST | 1 + .../from-sun/language/other/STRING.TESTS | 1 + .../from-sun/language/other/STRINGP.TEST | 1 + .../language/other/STRINGS-AR7993.TEST | 1 + .../other/STRUCTURE-PRINT-REGRESSION.TEST | 1 + .../from-sun/language/other/TIME-PATCH.TEST | 1 + .../from-sun/language/other/TYPENAME.TEST | 1 + .../from-sun/language/other/TYPENAMEP.TEST | 1 + .../from-sun/language/other/USERDEF.TEST | 1 + .../from-sun/language/other/VECTOR.TEST | 1 + .../language/other/WRAPPERS-AR7900.TEST | 1 + .../language/other/WRITEFILE-REGRESSION.TEST | 1 + .../other/XCL-COMPILER-REGRESSION.TEST | 1 + .../language/other/XCLC-REGRESSION.TEST | 1 + .../language/other/ZZZ-25-3-DRIBBLE.TEST | 1 + .../xcompiled/10-1-GET-PROPERTIES.DFASL | Bin 0 -> 2281 bytes .../language/xcompiled/10-1-GET.DFASL | Bin 0 -> 3451 bytes .../language/xcompiled/10-1-GETF.DFASL | Bin 0 -> 3125 bytes .../language/xcompiled/10-1-REMF.DFASL | Bin 0 -> 2372 bytes .../language/xcompiled/10-1-REMPROP.DFASL | Bin 0 -> 2151 bytes .../xcompiled/10-1-SYMBOL-PLIST.DFASL | Bin 0 -> 3305 bytes .../language/xcompiled/10-2-SYMBOL-NAME.DFASL | Bin 0 -> 1905 bytes .../language/xcompiled/10-3-COPY-SYMBOL.DFASL | Bin 0 -> 2398 bytes .../language/xcompiled/10-3-GENSYM.DFASL | Bin 0 -> 4870 bytes .../language/xcompiled/10-3-GENTEMP.DFASL | Bin 0 -> 6087 bytes .../language/xcompiled/10-3-KEYWORDP.DFASL | Bin 0 -> 1780 bytes .../language/xcompiled/10-3-MAKE-SYMBOL.DFASL | Bin 0 -> 1755 bytes .../xcompiled/10-3-SYMBOL-PACKAGE.DFASL | Bin 0 -> 1860 bytes .../language/xcompiled/11-6-IMPORT.DFASL | Bin 0 -> 1851 bytes .../xcompiled/11-7-DO-ALL-SYMBOLS.DFASL | Bin 0 -> 1431 bytes .../xcompiled/11-7-DO-EXTERNAL-SYMBOLS.DFASL | Bin 0 -> 1547 bytes .../language/xcompiled/11-7-DO-SYMBOLS.DFASL | Bin 0 -> 3043 bytes .../language/xcompiled/11-7-EXPORT.DFASL | Bin 0 -> 1130 bytes .../xcompiled/11-7-FIND-ALL-SYMBOLS.DFASL | Bin 0 -> 848 bytes .../xcompiled/11-7-FIND-PACKAGE.DFASL | Bin 0 -> 1379 bytes .../language/xcompiled/11-7-FIND-SYMBOL.DFASL | Bin 0 -> 1100 bytes .../language/xcompiled/11-7-IMPORT.DFASL | Bin 0 -> 2140 bytes .../language/xcompiled/11-7-IN-PACKAGE.DFASL | Bin 0 -> 989 bytes .../language/xcompiled/11-7-INTERN.DFASL | Bin 0 -> 1401 bytes .../xcompiled/11-7-LIST-ALL-PACKAGES.DFASL | Bin 0 -> 1196 bytes .../xcompiled/11-7-MAKE-PACKAGE.DFASL | Bin 0 -> 2044 bytes .../xcompiled/11-7-PACKAGE-NAME.DFASL | Bin 0 -> 1225 bytes .../xcompiled/11-7-PACKAGE-NICKNAMES.DFASL | Bin 0 -> 1342 bytes .../11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL | Bin 0 -> 1323 bytes .../xcompiled/11-7-PACKAGE-USE-LIST.DFASL | Bin 0 -> 1366 bytes .../xcompiled/11-7-PACKAGE-USED-BY-LIST.DFASL | Bin 0 -> 1179 bytes .../xcompiled/11-7-RENAME-PACKAGE.DFASL | Bin 0 -> 1525 bytes .../language/xcompiled/11-7-SHADOW.DFASL | Bin 0 -> 1113 bytes .../xcompiled/11-7-SHADOWING-IMPORT.DFASL | Bin 0 -> 2411 bytes .../language/xcompiled/11-7-UNEXPORT.DFASL | Bin 0 -> 1569 bytes .../language/xcompiled/11-7-UNINTERN.DFASL | Bin 0 -> 2311 bytes .../xcompiled/11-7-UNUSE-PACKAGE.DFASL | Bin 0 -> 1058 bytes .../language/xcompiled/11-7-USE-PACKAGE.DFASL | Bin 0 -> 972 bytes .../language/xcompiled/11-8-PROVIDE.DFASL | Bin 0 -> 1342 bytes .../12-10-IMPLEMENTATION-PARAMETERS.DFASL | Bin 0 -> 2135 bytes .../language/xcompiled/12-2-EVENP.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-2-MINUSP.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-2-ODDP.DFASL | Bin 0 -> 767 bytes .../language/xcompiled/12-2-PLUSP.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-2-ZEROP.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-3-EQP.DFASL | Bin 0 -> 767 bytes .../language/xcompiled/12-3-GEQ.DFASL | Bin 0 -> 765 bytes .../language/xcompiled/12-3-GREATERP.DFASL | Bin 0 -> 775 bytes .../language/xcompiled/12-3-LEQ.DFASL | Bin 0 -> 765 bytes .../language/xcompiled/12-3-LESSP.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-3-MAX.DFASL | Bin 0 -> 754 bytes .../language/xcompiled/12-3-MIN.DFASL | Bin 0 -> 765 bytes .../language/xcompiled/12-3-NEQP.DFASL | Bin 0 -> 767 bytes .../from-sun/language/xcompiled/12-4-+.DFASL | Bin 0 -> 1100 bytes .../from-sun/language/xcompiled/12-4--.DFASL | Bin 0 -> 1103 bytes .../from-sun/language/xcompiled/12-4-1+.DFASL | Bin 0 -> 752 bytes .../from-sun/language/xcompiled/12-4-1-.DFASL | Bin 0 -> 765 bytes .../language/xcompiled/12-4-CONJUGATE.DFASL | Bin 0 -> 777 bytes .../language/xcompiled/12-4-DECF.DFASL | Bin 0 -> 895 bytes .../language/xcompiled/12-4-GCD.DFASL | Bin 0 -> 765 bytes .../language/xcompiled/12-4-INCF.DFASL | Bin 0 -> 895 bytes .../language/xcompiled/12-4-LCM.DFASL | Bin 0 -> 1874 bytes .../language/xcompiled/12-4-QUOTIENT.DFASL | Bin 0 -> 823 bytes .../language/xcompiled/12-4-TIMES.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-5-1-EXP.DFASL | Bin 0 -> 1002 bytes .../language/xcompiled/12-5-1-EXPT.DFASL | Bin 0 -> 1028 bytes .../language/xcompiled/12-5-1-ISQRT.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-5-1-LOG.DFASL | Bin 0 -> 1066 bytes .../language/xcompiled/12-5-1-SQRT.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-5-2-ABS.DFASL | Bin 0 -> 767 bytes .../language/xcompiled/12-5-2-ACOS.DFASL | Bin 0 -> 1995 bytes .../language/xcompiled/12-5-2-ACOSH.DFASL | Bin 0 -> 2078 bytes .../language/xcompiled/12-5-2-ASIN.DFASL | Bin 0 -> 1995 bytes .../language/xcompiled/12-5-2-ASINH.DFASL | Bin 0 -> 2052 bytes .../language/xcompiled/12-5-2-ATAN.DFASL | Bin 0 -> 1872 bytes .../language/xcompiled/12-5-2-ATANH.DFASL | Bin 0 -> 2648 bytes .../language/xcompiled/12-5-2-CIS.DFASL | Bin 0 -> 2111 bytes .../language/xcompiled/12-5-2-COS.DFASL | Bin 0 -> 2252 bytes .../language/xcompiled/12-5-2-COSH.DFASL | Bin 0 -> 2015 bytes .../language/xcompiled/12-5-2-PHASE.DFASL | Bin 0 -> 2300 bytes .../language/xcompiled/12-5-2-SIGNUM.DFASL | Bin 0 -> 2520 bytes .../language/xcompiled/12-5-2-SIN.DFASL | Bin 0 -> 2252 bytes .../language/xcompiled/12-5-2-SINH.DFASL | Bin 0 -> 2006 bytes .../language/xcompiled/12-5-2-TAN.DFASL | Bin 0 -> 2164 bytes .../language/xcompiled/12-5-2-TANH.DFASL | Bin 0 -> 2021 bytes .../language/xcompiled/12-6-CEILING.DFASL | Bin 0 -> 1650 bytes .../language/xcompiled/12-6-COMPLEX.DFASL | Bin 0 -> 773 bytes .../xcompiled/12-6-DECODE-FLOAT.DFASL | Bin 0 -> 1873 bytes .../language/xcompiled/12-6-DENOMINATOR.DFASL | Bin 0 -> 781 bytes .../language/xcompiled/12-6-FCEILING.DFASL | Bin 0 -> 1728 bytes .../language/xcompiled/12-6-FFLOOR.DFASL | Bin 0 -> 1710 bytes .../xcompiled/12-6-FLOAT-DIGITS.DFASL | Bin 0 -> 1622 bytes .../xcompiled/12-6-FLOAT-PRECISION.DFASL | Bin 0 -> 1623 bytes .../language/xcompiled/12-6-FLOAT-RADIX.DFASL | Bin 0 -> 1645 bytes .../language/xcompiled/12-6-FLOAT-SIGN.DFASL | Bin 0 -> 2192 bytes .../language/xcompiled/12-6-FLOAT.DFASL | Bin 0 -> 769 bytes .../language/xcompiled/12-6-FLOOR.DFASL | Bin 0 -> 1640 bytes .../language/xcompiled/12-6-FROUND.DFASL | Bin 0 -> 1686 bytes .../language/xcompiled/12-6-FTRUNCATE.DFASL | Bin 0 -> 1737 bytes .../language/xcompiled/12-6-IMAGPART.DFASL | Bin 0 -> 775 bytes .../xcompiled/12-6-INTEGER-DECODE-FLOAT.DFASL | Bin 0 -> 2150 bytes .../language/xcompiled/12-6-MOD.DFASL | Bin 0 -> 1594 bytes .../language/xcompiled/12-6-NUMERATOR.DFASL | Bin 0 -> 777 bytes .../language/xcompiled/12-6-RATIONAL.DFASL | Bin 0 -> 824 bytes .../language/xcompiled/12-6-RATIONALIZE.DFASL | Bin 0 -> 809 bytes .../language/xcompiled/12-6-REALPART.DFASL | Bin 0 -> 775 bytes .../language/xcompiled/12-6-REM.DFASL | Bin 0 -> 1594 bytes .../language/xcompiled/12-6-ROUND.DFASL | Bin 0 -> 1612 bytes .../language/xcompiled/12-6-SCALE-FLOAT.DFASL | Bin 0 -> 2026 bytes .../language/xcompiled/12-6-TRUNCATE.DFASL | Bin 0 -> 1659 bytes .../language/xcompiled/12-7-ASH.DFASL | Bin 0 -> 765 bytes .../language/xcompiled/12-7-BOOLE.DFASL | Bin 0 -> 10420 bytes .../xcompiled/12-7-INTEGER-LENGTH.DFASL | Bin 0 -> 787 bytes .../language/xcompiled/12-7-LOGAND.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-7-LOGANDC1.DFASL | Bin 0 -> 775 bytes .../language/xcompiled/12-7-LOGANDC2.DFASL | Bin 0 -> 775 bytes .../language/xcompiled/12-7-LOGBITP.DFASL | Bin 0 -> 791 bytes .../language/xcompiled/12-7-LOGCOUNT.DFASL | Bin 0 -> 775 bytes .../language/xcompiled/12-7-LOGEQV.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-7-LOGIOR.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-7-LOGNAND.DFASL | Bin 0 -> 773 bytes .../language/xcompiled/12-7-LOGNOR.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-7-LOGNOT.DFASL | Bin 0 -> 771 bytes .../language/xcompiled/12-7-LOGORC1.DFASL | Bin 0 -> 773 bytes .../language/xcompiled/12-7-LOGORC2.DFASL | Bin 0 -> 773 bytes .../language/xcompiled/12-7-LOGTEST.DFASL | Bin 0 -> 773 bytes .../language/xcompiled/12-7-LOGXOR.DFASL | Bin 0 -> 771 bytes .../xcompiled/12-8-BYTE-POSITION.DFASL | Bin 0 -> 1422 bytes .../language/xcompiled/12-8-BYTE-SIZE.DFASL | Bin 0 -> 1412 bytes .../language/xcompiled/12-8-BYTE.DFASL | Bin 0 -> 1874 bytes .../xcompiled/12-8-DEPOSIT-FIELD.DFASL | Bin 0 -> 785 bytes .../language/xcompiled/12-8-DPB.DFASL | Bin 0 -> 1541 bytes .../language/xcompiled/12-8-LDB-TEST.DFASL | Bin 0 -> 1309 bytes .../language/xcompiled/12-8-LDB.DFASL | Bin 0 -> 1291 bytes .../language/xcompiled/12-8-MASK-FIELD.DFASL | Bin 0 -> 1322 bytes .../xcompiled/12-9-MAKE-RANDOM-STATE.DFASL | Bin 0 -> 1552 bytes .../language/xcompiled/12-9-RANDOM.DFASL | Bin 0 -> 2576 bytes .../xcompiled/13-1-CHARACTERATTRIBUTES.DFASL | Bin 0 -> 1359 bytes .../xcompiled/13-2-ALPHA-CHAR-P.DFASL | Bin 0 -> 1486 bytes .../xcompiled/13-2-ALPHANUMERIC-P.DFASL | Bin 0 -> 1124 bytes .../language/xcompiled/13-2-BOTH-CASE-P.DFASL | Bin 0 -> 1170 bytes .../language/xcompiled/13-2-CHAR-EQUAL.DFASL | Bin 0 -> 3499 bytes .../language/xcompiled/13-2-CHAR-GE.DFASL | Bin 0 -> 2257 bytes .../xcompiled/13-2-CHAR-GREATERP.DFASL | Bin 0 -> 2347 bytes .../language/xcompiled/13-2-CHAR-GT.DFASL | Bin 0 -> 2081 bytes .../language/xcompiled/13-2-CHAR-LE.DFASL | Bin 0 -> 2299 bytes .../language/xcompiled/13-2-CHAR-LESSP.DFASL | Bin 0 -> 2382 bytes .../language/xcompiled/13-2-CHAR-LT.DFASL | Bin 0 -> 2124 bytes .../xcompiled/13-2-CHAR-NOT-EQUAL.DFASL | Bin 0 -> 2610 bytes .../xcompiled/13-2-CHAR-NOT-GREATERP.DFASL | Bin 0 -> 2599 bytes .../xcompiled/13-2-CHAR-NOT-LESSP.DFASL | Bin 0 -> 2538 bytes .../language/xcompiled/13-2-CHAREQ.DFASL | Bin 0 -> 2436 bytes .../language/xcompiled/13-2-CHARNEQ.DFASL | Bin 0 -> 2218 bytes .../xcompiled/13-2-DIGIT-CHAR-P.DFASL | Bin 0 -> 4094 bytes .../xcompiled/13-2-GRAPHIC-CHAR-P.DFASL | Bin 0 -> 1099 bytes .../xcompiled/13-2-LOWER-CASE-P.DFASL | Bin 0 -> 1484 bytes .../xcompiled/13-2-STANDARD-CHAR-P.DFASL | Bin 0 -> 965 bytes .../xcompiled/13-2-STRING-CHAR-P.DFASL | Bin 0 -> 1053 bytes .../xcompiled/13-2-UPPER-CASE-P.DFASL | Bin 0 -> 1484 bytes .../language/xcompiled/13-3-CHAR-BITS.DFASL | Bin 0 -> 859 bytes .../language/xcompiled/13-3-CHAR-CODE.DFASL | Bin 0 -> 777 bytes .../language/xcompiled/13-3-CHAR-FONT.DFASL | Bin 0 -> 857 bytes .../language/xcompiled/13-3-CODE-CHAR.DFASL | Bin 0 -> 860 bytes .../language/xcompiled/13-3-MAKE-CHAR.DFASL | Bin 0 -> 861 bytes .../xcompiled/13-4-CHAR-DOWNCASE.DFASL | Bin 0 -> 1691 bytes .../language/xcompiled/13-4-CHAR-INT.DFASL | Bin 0 -> 2875 bytes .../language/xcompiled/13-4-CHAR-NAME.DFASL | Bin 0 -> 1503 bytes .../language/xcompiled/13-4-CHAR-UPCASE.DFASL | Bin 0 -> 1685 bytes .../language/xcompiled/13-4-CHARACTER.DFASL | Bin 0 -> 2526 bytes .../language/xcompiled/13-4-DIGIT-CHAR.DFASL | Bin 0 -> 2897 bytes .../language/xcompiled/13-4-INT-CHAR.DFASL | Bin 0 -> 1096 bytes .../language/xcompiled/13-4-NAME-CHAR.DFASL | Bin 0 -> 1446 bytes .../language/xcompiled/13-5-CHAR-BIT.DFASL | Bin 0 -> 774 bytes .../xcompiled/13-5-SET-CHAR-BIT.DFASL | Bin 0 -> 782 bytes .../language/xcompiled/14-1-COPY-SEQ.DFASL | Bin 0 -> 1556 bytes .../language/xcompiled/14-1-ELT.DFASL | Bin 0 -> 2381 bytes .../language/xcompiled/14-1-LENGTH.DFASL | Bin 0 -> 2047 bytes .../xcompiled/14-1-MAKE-SEQUENCE.DFASL | Bin 0 -> 2193 bytes .../language/xcompiled/14-1-NREVERSE.DFASL | Bin 0 -> 2637 bytes .../language/xcompiled/14-1-REVERSE.DFASL | Bin 0 -> 2707 bytes .../language/xcompiled/14-1-SUBSEQ.DFASL | Bin 0 -> 2601 bytes .../language/xcompiled/14-2-CONCATENATE.DFASL | Bin 0 -> 3758 bytes .../language/xcompiled/14-2-EVERY.DFASL | Bin 0 -> 8899 bytes .../language/xcompiled/14-2-MAP.DFASL | Bin 0 -> 4261 bytes .../language/xcompiled/14-2-NOTANY.DFASL | Bin 0 -> 9069 bytes .../language/xcompiled/14-2-NOTEVERY.DFASL | Bin 0 -> 8827 bytes .../language/xcompiled/14-2-REDUCE.DFASL | Bin 0 -> 5112 bytes .../language/xcompiled/14-2-SOME.DFASL | Bin 0 -> 8387 bytes .../xcompiled/14-3-DELETE-DUPLICATES.DFASL | Bin 0 -> 4796 bytes .../xcompiled/14-3-DELETE-IF-NOT.DFASL | Bin 0 -> 5839 bytes .../language/xcompiled/14-3-DELETE-IF.DFASL | Bin 0 -> 3836 bytes .../language/xcompiled/14-3-DELETE.DFASL | Bin 0 -> 5469 bytes .../language/xcompiled/14-3-FILL.DFASL | Bin 0 -> 3217 bytes .../language/xcompiled/14-3-FIND-IF-NOT.DFASL | Bin 0 -> 4441 bytes .../language/xcompiled/14-3-FIND-IF.DFASL | Bin 0 -> 4421 bytes .../language/xcompiled/14-3-FIND.DFASL | Bin 0 -> 5531 bytes .../xcompiled/14-3-NSUBSTITUTE-IF-NOT.DFASL | Bin 0 -> 5706 bytes .../xcompiled/14-3-NSUBSTITUTE-IF.DFASL | Bin 0 -> 6501 bytes .../language/xcompiled/14-3-NSUBSTITUTE.DFASL | Bin 0 -> 6187 bytes .../xcompiled/14-3-POSITION-IF-NOT.DFASL | Bin 0 -> 4736 bytes .../language/xcompiled/14-3-POSITION-IF.DFASL | Bin 0 -> 4707 bytes .../language/xcompiled/14-3-POSITION.DFASL | Bin 0 -> 5399 bytes .../xcompiled/14-3-REMOVE-DUPLICATES.DFASL | Bin 0 -> 4732 bytes .../xcompiled/14-3-REMOVE-IF-NOT.DFASL | Bin 0 -> 5446 bytes .../language/xcompiled/14-3-REMOVE-IF.DFASL | Bin 0 -> 3741 bytes .../language/xcompiled/14-3-REMOVE.DFASL | Bin 0 -> 5346 bytes .../xcompiled/14-3-SUBSTITUTE-IF-NOT.DFASL | Bin 0 -> 5503 bytes .../xcompiled/14-3-SUBSTITUTE-IF.DFASL | Bin 0 -> 6545 bytes .../language/xcompiled/14-3-SUBSTITUTE.DFASL | Bin 0 -> 6073 bytes .../xcompiled/14-4-COUNT-IF-NOT.DFASL | Bin 0 -> 4795 bytes .../language/xcompiled/14-4-COUNT-IF.DFASL | Bin 0 -> 4646 bytes .../language/xcompiled/14-4-COUNT.DFASL | Bin 0 -> 5634 bytes .../language/xcompiled/14-4-MISMATCH.DFASL | Bin 0 -> 4390 bytes .../language/xcompiled/14-5-MERGE.DFASL | Bin 0 -> 5916 bytes .../language/xcompiled/14-5-SORT.DFASL | Bin 0 -> 6385 bytes .../language/xcompiled/14-5-STABLE-SORT.DFASL | Bin 0 -> 4950 bytes .../language/xcompiled/15-1-CAAAAR.DFASL | Bin 0 -> 3500 bytes .../language/xcompiled/15-1-CAAADR.DFASL | Bin 0 -> 3479 bytes .../language/xcompiled/15-1-CAAAR.DFASL | Bin 0 -> 3485 bytes .../language/xcompiled/15-1-CAADAR.DFASL | Bin 0 -> 3592 bytes .../language/xcompiled/15-1-CAADDR.DFASL | Bin 0 -> 3610 bytes .../language/xcompiled/15-1-CAADR.DFASL | Bin 0 -> 3497 bytes .../language/xcompiled/15-1-CAAR.DFASL | Bin 0 -> 3437 bytes .../language/xcompiled/15-1-CADAA.DFASL | Bin 0 -> 3587 bytes .../language/xcompiled/15-1-CADADR.DFASL | Bin 0 -> 2959 bytes .../language/xcompiled/15-1-CADAR.DFASL | Bin 0 -> 3263 bytes .../language/xcompiled/15-1-CADDAR.DFASL | Bin 0 -> 3453 bytes .../xcompiled/15-1-CADDDR-AND-FOURTH.DFASL | Bin 0 -> 3608 bytes .../xcompiled/15-1-CADDR-AND-THIRD.DFASL | Bin 0 -> 2609 bytes .../xcompiled/15-1-CADR-AND-SECOND.DFASL | Bin 0 -> 2726 bytes .../xcompiled/15-1-CAR-AND-FIRST.DFASL | Bin 0 -> 3433 bytes .../language/xcompiled/15-1-CDAAAR.DFASL | Bin 0 -> 3573 bytes .../language/xcompiled/15-1-CDAADR.DFASL | Bin 0 -> 3222 bytes .../language/xcompiled/15-1-CDAAR.DFASL | Bin 0 -> 3453 bytes .../language/xcompiled/15-1-CDADAR.DFASL | Bin 0 -> 3593 bytes .../language/xcompiled/15-1-CDADDR.DFASL | Bin 0 -> 3681 bytes .../language/xcompiled/15-1-CDADR.DFASL | Bin 0 -> 3492 bytes .../language/xcompiled/15-1-CDAR.DFASL | Bin 0 -> 3444 bytes .../language/xcompiled/15-1-CDDAAR.DFASL | Bin 0 -> 3618 bytes .../language/xcompiled/15-1-CDDADR.DFASL | Bin 0 -> 3688 bytes .../language/xcompiled/15-1-CDDAR.DFASL | Bin 0 -> 3510 bytes .../language/xcompiled/15-1-CDDDAR.DFASL | Bin 0 -> 3453 bytes .../language/xcompiled/15-1-CDDDDR.DFASL | Bin 0 -> 2153 bytes .../language/xcompiled/15-1-CDDDR.DFASL | Bin 0 -> 2122 bytes .../language/xcompiled/15-1-CDDR.DFASL | Bin 0 -> 3239 bytes .../xcompiled/15-1-CDR-AND-REST.DFASL | Bin 0 -> 3341 bytes .../language/xcompiled/15-1-CONS.DFASL | Bin 0 -> 3830 bytes .../language/xcompiled/15-1-TREE-EQUAL.DFASL | Bin 0 -> 4605 bytes .../language/xcompiled/15-2-APPEND.DFASL | Bin 0 -> 5245 bytes .../language/xcompiled/15-2-BUTLAST.DFASL | Bin 0 -> 3517 bytes .../language/xcompiled/15-2-COPY-ALIST.DFASL | Bin 0 -> 3745 bytes .../language/xcompiled/15-2-COPY-LIST.DFASL | Bin 0 -> 2104 bytes .../language/xcompiled/15-2-COPY-TREE.DFASL | Bin 0 -> 2299 bytes .../language/xcompiled/15-2-EIGHTH.DFASL | Bin 0 -> 4209 bytes .../language/xcompiled/15-2-ENDP.DFASL | Bin 0 -> 1279 bytes .../language/xcompiled/15-2-FIFTH.DFASL | Bin 0 -> 2115 bytes .../language/xcompiled/15-2-FIRST.DFASL | Bin 0 -> 757 bytes .../language/xcompiled/15-2-FOURTH.DFASL | Bin 0 -> 759 bytes .../language/xcompiled/15-2-LAST.DFASL | Bin 0 -> 2226 bytes .../language/xcompiled/15-2-LDIFF.DFASL | Bin 0 -> 3132 bytes .../language/xcompiled/15-2-LIST-LENGTH.DFASL | Bin 0 -> 2781 bytes .../language/xcompiled/15-2-LIST.DFASL | Bin 0 -> 3440 bytes .../language/xcompiled/15-2-LISTSTAR.DFASL | Bin 0 -> 3678 bytes .../language/xcompiled/15-2-MAKE-LIST.DFASL | Bin 0 -> 2538 bytes .../language/xcompiled/15-2-NBUTLAST.DFASL | Bin 0 -> 4017 bytes .../language/xcompiled/15-2-NCONC.DFASL | Bin 0 -> 2539 bytes .../language/xcompiled/15-2-NINTH.DFASL | Bin 0 -> 2985 bytes .../language/xcompiled/15-2-NRECONC.DFASL | Bin 0 -> 2542 bytes .../language/xcompiled/15-2-NTH.DFASL | Bin 0 -> 2279 bytes .../language/xcompiled/15-2-NTHCDR.DFASL | Bin 0 -> 1872 bytes .../language/xcompiled/15-2-POP.DFASL | Bin 0 -> 2297 bytes .../language/xcompiled/15-2-PUSH.DFASL | Bin 0 -> 3052 bytes .../language/xcompiled/15-2-PUSHNEW.DFASL | Bin 0 -> 4003 bytes .../language/xcompiled/15-2-REST.DFASL | Bin 0 -> 755 bytes .../language/xcompiled/15-2-REVAPPEND.DFASL | Bin 0 -> 2563 bytes .../language/xcompiled/15-2-SECOND.DFASL | Bin 0 -> 759 bytes .../language/xcompiled/15-2-SEVENTH.DFASL | Bin 0 -> 2972 bytes .../language/xcompiled/15-2-SIXTH.DFASL | Bin 0 -> 2765 bytes .../language/xcompiled/15-2-TENTH.DFASL | Bin 0 -> 2925 bytes .../language/xcompiled/15-2-THIRD.DFASL | Bin 0 -> 757 bytes .../language/xcompiled/15-3-RPLACA.DFASL | Bin 0 -> 3381 bytes .../language/xcompiled/15-3-RPLACD.DFASL | Bin 0 -> 2660 bytes .../language/xcompiled/15-4-NSUBLIS.DFASL | Bin 0 -> 5092 bytes .../xcompiled/15-4-NSUBST-IF-NOT.DFASL | Bin 0 -> 2879 bytes .../language/xcompiled/15-4-NSUBST-IF.DFASL | Bin 0 -> 3945 bytes .../language/xcompiled/15-4-NSUBST.DFASL | Bin 0 -> 5028 bytes .../language/xcompiled/15-4-SUBLIS.DFASL | Bin 0 -> 5762 bytes .../xcompiled/15-4-SUBST-IF-NOT.DFASL | Bin 0 -> 3163 bytes .../language/xcompiled/15-4-SUBST-IF.DFASL | Bin 0 -> 4532 bytes .../language/xcompiled/15-4-SUBST.DFASL | Bin 0 -> 5740 bytes .../language/xcompiled/15-5-ADJOIN.DFASL | Bin 0 -> 1272 bytes .../xcompiled/15-5-INTERSECTION.DFASL | Bin 0 -> 4762 bytes .../xcompiled/15-5-MEMBER-IF-NOT.DFASL | Bin 0 -> 3825 bytes .../language/xcompiled/15-5-MEMBER-IF.DFASL | Bin 0 -> 3666 bytes .../language/xcompiled/15-5-MEMBER.DFASL | Bin 0 -> 4831 bytes .../xcompiled/15-5-NINTERSECTION.DFASL | Bin 0 -> 4448 bytes .../xcompiled/15-5-NSET-DIFFERENCE.DFASL | Bin 0 -> 7972 bytes .../xcompiled/15-5-NSET-EXCLUSIVE-OR.DFASL | Bin 0 -> 12922 bytes .../language/xcompiled/15-5-NUNION.DFASL | Bin 0 -> 5214 bytes .../xcompiled/15-5-SET-DIFFERENCE.DFASL | Bin 0 -> 11630 bytes .../language/xcompiled/15-5-SUBSETP.DFASL | Bin 0 -> 4442 bytes .../language/xcompiled/15-5-TAILP.DFASL | Bin 0 -> 2024 bytes .../language/xcompiled/15-5-UNION.DFASL | Bin 0 -> 5538 bytes .../language/xcompiled/15-6-ACONS.DFASL | Bin 0 -> 2932 bytes .../xcompiled/15-6-ASSOC-IF-NOT.DFASL | Bin 0 -> 1147 bytes .../language/xcompiled/15-6-ASSOC-IF.DFASL | Bin 0 -> 1131 bytes .../language/xcompiled/15-6-ASSOC.DFASL | Bin 0 -> 1495 bytes .../language/xcompiled/15-6-PAIRLIS.DFASL | Bin 0 -> 15026 bytes .../xcompiled/15-6-RASSOC-IF-NOT.DFASL | Bin 0 -> 1171 bytes .../language/xcompiled/15-6-RASSOC-IF.DFASL | Bin 0 -> 1157 bytes .../language/xcompiled/15-6-RASSOC.DFASL | Bin 0 -> 1575 bytes .../language/xcompiled/16-1-CLRHASH.DFASL | Bin 0 -> 1731 bytes .../language/xcompiled/16-1-GETHASH.DFASL | Bin 0 -> 1594 bytes .../xcompiled/16-1-HASH-TABLE-COUNT.DFASL | Bin 0 -> 1911 bytes .../xcompiled/16-1-HASH-TABLE-P.DFASL | Bin 0 -> 947 bytes .../xcompiled/16-1-MAKE-HASH-TABLE.DFASL | Bin 0 -> 1329 bytes .../language/xcompiled/16-1-MAPHASH.DFASL | Bin 0 -> 1750 bytes .../language/xcompiled/16-1-REMHASH.DFASL | Bin 0 -> 1636 bytes .../language/xcompiled/16-2-SXHASH.DFASL | Bin 0 -> 916 bytes .../language/xcompiled/17-1-MAKE-ARRAY.DFASL | Bin 0 -> 2801 bytes .../language/xcompiled/17-1-VECTOR.DFASL | Bin 0 -> 982 bytes .../language/xcompiled/17-2-AREF.DFASL | Bin 0 -> 2925 bytes .../language/xcompiled/17-2-SVREF.DFASL | Bin 0 -> 1682 bytes .../xcompiled/17-3-ADJUSTABLE-ARRAY-P.DFASL | Bin 0 -> 1349 bytes .../xcompiled/17-3-ARRAY-DIMENSION.DFASL | Bin 0 -> 1527 bytes .../xcompiled/17-3-ARRAY-DIMENSIONS.DFASL | Bin 0 -> 1361 bytes .../xcompiled/17-3-ARRAY-ELEMENT-TYPE.DFASL | Bin 0 -> 2586 bytes .../xcompiled/17-3-ARRAY-IN-BOUNDS-P.DFASL | Bin 0 -> 1714 bytes .../language/xcompiled/17-3-ARRAY-RANK.DFASL | Bin 0 -> 966 bytes .../17-3-ARRAY-ROW-MAJOR-INDEX.DFASL | Bin 0 -> 1755 bytes .../xcompiled/17-3-ARRAY-TOTAL-SIZE.DFASL | Bin 0 -> 1377 bytes .../language/xcompiled/17-4-BIT-AND.DFASL | Bin 0 -> 1869 bytes .../language/xcompiled/17-4-BIT-ANDC1.DFASL | Bin 0 -> 1881 bytes .../language/xcompiled/17-4-BIT-ANDC2.DFASL | Bin 0 -> 1881 bytes .../language/xcompiled/17-4-BIT-EQV.DFASL | Bin 0 -> 1869 bytes .../language/xcompiled/17-4-BIT-IOR.DFASL | Bin 0 -> 1869 bytes .../language/xcompiled/17-4-BIT-NAND.DFASL | Bin 0 -> 1875 bytes .../language/xcompiled/17-4-BIT-NOR.DFASL | Bin 0 -> 1869 bytes .../language/xcompiled/17-4-BIT-NOT.DFASL | Bin 0 -> 1786 bytes .../language/xcompiled/17-4-BIT-ORC1.DFASL | Bin 0 -> 1875 bytes .../language/xcompiled/17-4-BIT-ORC2.DFASL | Bin 0 -> 1875 bytes .../language/xcompiled/17-4-BIT-XOR.DFASL | Bin 0 -> 1869 bytes .../language/xcompiled/17-4-BIT.DFASL | Bin 0 -> 1609 bytes .../language/xcompiled/17-4-SBIT.DFASL | Bin 0 -> 1854 bytes .../17-5-ARRAY-HAS-FILL-POINTER-P.DFASL | Bin 0 -> 1417 bytes .../xcompiled/17-5-FILL-POINTER.DFASL | Bin 0 -> 977 bytes .../language/xcompiled/17-5-VECTOR-POP.DFASL | Bin 0 -> 1965 bytes .../xcompiled/17-5-VECTOR-PUSH-EXTEND.DFASL | Bin 0 -> 2137 bytes .../language/xcompiled/17-5-VECTOR-PUSH.DFASL | Bin 0 -> 1259 bytes .../xcompiled/17-6-ADJUST-ARRAY.DFASL | Bin 0 -> 1792 bytes .../language/xcompiled/18-1-CHAR.DFASL | Bin 0 -> 3863 bytes .../language/xcompiled/18-1-SCHAR.DFASL | Bin 0 -> 1670 bytes .../language/xcompiled/18-2-STRING-EQ.DFASL | Bin 0 -> 4335 bytes .../xcompiled/18-2-STRING-EQUAL.DFASL | Bin 0 -> 5889 bytes .../language/xcompiled/18-2-STRING-GE.DFASL | Bin 0 -> 4762 bytes .../xcompiled/18-2-STRING-GREATERP.DFASL | Bin 0 -> 4514 bytes .../language/xcompiled/18-2-STRING-GT.DFASL | Bin 0 -> 4498 bytes .../language/xcompiled/18-2-STRING-LE.DFASL | Bin 0 -> 4763 bytes .../xcompiled/18-2-STRING-LESSP.DFASL | Bin 0 -> 4284 bytes .../language/xcompiled/18-2-STRING-LT.DFASL | Bin 0 -> 4304 bytes .../language/xcompiled/18-2-STRING-NEQ.DFASL | Bin 0 -> 1578 bytes .../xcompiled/18-2-STRING-NOT-EQUAL.DFASL | Bin 0 -> 1669 bytes .../xcompiled/18-2-STRING-NOT-GREATERP.DFASL | Bin 0 -> 4965 bytes .../xcompiled/18-2-STRING-NOT-LESSP.DFASL | Bin 0 -> 4860 bytes .../language/xcompiled/18-3-MAKE-STRING.DFASL | Bin 0 -> 1680 bytes .../xcompiled/18-3-NSTRING-CAPITALIZE.DFASL | Bin 0 -> 2597 bytes .../xcompiled/18-3-NSTRING-DOWNCASE.DFASL | Bin 0 -> 2485 bytes .../xcompiled/18-3-NSTRING-UPCASE.DFASL | Bin 0 -> 2477 bytes .../xcompiled/18-3-STRING-CAPITALIZE.DFASL | Bin 0 -> 2002 bytes .../xcompiled/18-3-STRING-DOWNCASE.DFASL | Bin 0 -> 2301 bytes .../xcompiled/18-3-STRING-LEFT-TRIM.DFASL | Bin 0 -> 3246 bytes .../xcompiled/18-3-STRING-RIGHT-TRIM.DFASL | Bin 0 -> 3240 bytes .../language/xcompiled/18-3-STRING-TRIM.DFASL | Bin 0 -> 3235 bytes .../xcompiled/18-3-STRING-UPCASE.DFASL | Bin 0 -> 2293 bytes .../language/xcompiled/18-3-STRING.DFASL | Bin 0 -> 2646 bytes .../language/xcompiled/20-1-APPLYHOOK.DFASL | Bin 0 -> 2082 bytes .../language/xcompiled/20-1-CONSTANTP.DFASL | Bin 0 -> 1125 bytes .../language/xcompiled/20-1-EVAL.DFASL | Bin 0 -> 1910 bytes .../xcompiled/22-1-5-COPY-READTABLE.DFASL | Bin 0 -> 3686 bytes .../22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL | Bin 0 -> 3497 bytes .../22-1-5-GET-MACRO-CHARACTER.DFASL | Bin 0 -> 2494 bytes ...22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL | Bin 0 -> 3404 bytes .../xcompiled/22-1-5-READTABLEP.DFASL | Bin 0 -> 1902 bytes .../22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL | Bin 0 -> 3400 bytes .../22-1-5-SET-MACRO-CHARACTER.DFASL | Bin 0 -> 3609 bytes .../22-1-5-SET-SYNTAX-FROM-CHAR.DFASL | Bin 0 -> 6305 bytes .../language/xcompiled/22-2-1-LISTEN.DFASL | Bin 0 -> 2717 bytes .../xcompiled/22-2-1-PARSE-INTEGER.DFASL | Bin 0 -> 4072 bytes .../language/xcompiled/22-2-1-PEEK-CHAR.DFASL | Bin 0 -> 4029 bytes .../xcompiled/22-2-1-READ-CHAR-NO-HANG.DFASL | Bin 0 -> 3737 bytes .../language/xcompiled/22-2-1-READ-CHAR.DFASL | Bin 0 -> 3589 bytes .../22-2-1-READ-DELIMITED-LIST.DFASL | Bin 0 -> 2699 bytes .../22-2-1-READ-PRESERVING-WHITESPACE.DFASL | Bin 0 -> 2900 bytes .../language/xcompiled/22-2-1-READ.DFASL | Bin 0 -> 2870 bytes .../xcompiled/22-2-1-UNREAD-CHAR.DFASL | Bin 0 -> 2370 bytes .../xcompiled/22-3-1-FINISH-OUTPUT.DFASL | Bin 0 -> 2935 bytes .../xcompiled/22-3-1-FRESH-LINE.DFASL | Bin 0 -> 4205 bytes .../language/xcompiled/22-3-1-PPRINT.DFASL | Bin 0 -> 1909 bytes .../xcompiled/22-3-1-PRIN1-TO-STRING.DFASL | Bin 0 -> 4001 bytes .../language/xcompiled/22-3-1-PRIN1.DFASL | Bin 0 -> 3730 bytes .../xcompiled/22-3-1-PRINC-TO-STRING.DFASL | Bin 0 -> 4494 bytes .../language/xcompiled/22-3-1-PRINC.DFASL | Bin 0 -> 3197 bytes .../language/xcompiled/22-3-1-PRINT.DFASL | Bin 0 -> 4040 bytes .../language/xcompiled/22-3-1-TERPRI.DFASL | Bin 0 -> 1812 bytes .../xcompiled/22-3-1-WRITE-CHAR.DFASL | Bin 0 -> 3099 bytes .../xcompiled/22-3-1-WRITE-LINE.DFASL | Bin 0 -> 6030 bytes .../xcompiled/22-3-1-WRITE-STRING.DFASL | Bin 0 -> 6038 bytes .../language/xcompiled/22-3-3-FORMAT.DFASL | Bin 0 -> 23983 bytes .../language/xcompiled/23-FUNCTIONS.DFASL | Bin 0 -> 25564 bytes .../language/xcompiled/24-1-BREAK.DFASL | Bin 0 -> 1632 bytes .../language/xcompiled/24-1-CERROR.DFASL | Bin 0 -> 2962 bytes .../language/xcompiled/24-1-ERROR.DFASL | Bin 0 -> 1665 bytes .../language/xcompiled/24-1-WARN.DFASL | Bin 0 -> 2270 bytes .../language/xcompiled/24-2-ASSERT.DFASL | Bin 0 -> 2019 bytes .../language/xcompiled/24-3-CCASE.DFASL | Bin 0 -> 1739 bytes .../language/xcompiled/24-3-CTYPECASE.DFASL | Bin 0 -> 1241 bytes .../language/xcompiled/24-3-ECASE.DFASL | Bin 0 -> 1733 bytes .../language/xcompiled/24-3-ETYPECASE.DFASL | Bin 0 -> 1235 bytes .../xcompiled/25-1-COMPILE-FILE.DFASL | Bin 0 -> 777 bytes .../language/xcompiled/25-1-COMPILE.DFASL | Bin 0 -> 2184 bytes .../language/xcompiled/25-1-DISASSEMBLE.DFASL | Bin 0 -> 1326 bytes .../xcompiled/25-2-DOCUMENTATION.DFASL | Bin 0 -> 4962 bytes .../xcompiled/25-3-APROPOS-LIST.DFASL | Bin 0 -> 1941 bytes .../language/xcompiled/25-3-APROPOS.DFASL | Bin 0 -> 1742 bytes .../language/xcompiled/25-3-DESCRIBE.DFASL | Bin 0 -> 3588 bytes .../from-sun/language/xcompiled/25-3-ED.DFASL | Bin 0 -> 774 bytes .../language/xcompiled/25-3-INSPECT.DFASL | Bin 0 -> 789 bytes .../language/xcompiled/25-3-ROOM.DFASL | Bin 0 -> 791 bytes .../language/xcompiled/25-3-TIME.DFASL | Bin 0 -> 1493 bytes .../25-4-DECODE-UNIVERSAL-TIME.DFASL | Bin 0 -> 1962 bytes .../25-4-ENCODE-UNIVERSAL-TIME.DFASL | Bin 0 -> 2204 bytes .../xcompiled/25-4-GET-DECODED-TIME.DFASL | Bin 0 -> 1661 bytes .../25-4-GET-INTERNAL-REAL-TIME.DFASL | Bin 0 -> 2682 bytes .../25-4-GET-INTERNAL-RUN-TIME.DFASL | Bin 0 -> 2678 bytes .../xcompiled/25-4-GET-UNIVERSAL-TIME.DFASL | Bin 0 -> 1378 bytes .../25-4-LISP-IMPLEMENTATION-VERSION.DFASL | Bin 0 -> 849 bytes .../xcompiled/25-4-LONG-SITE-NAME.DFASL | Bin 0 -> 810 bytes .../xcompiled/25-4-MACHINE-INSTANCE.DFASL | Bin 0 -> 816 bytes .../xcompiled/25-4-MACHINE-TYPE.DFASL | Bin 0 -> 1052 bytes .../xcompiled/25-4-MACHINE-VERSION.DFASL | Bin 0 -> 813 bytes .../xcompiled/25-4-SHORT-SITE-NAME.DFASL | Bin 0 -> 813 bytes .../language/xcompiled/25-4-SLEEP.DFASL | Bin 0 -> 1546 bytes .../xcompiled/25-4-SOFTWARE-TYPE.DFASL | Bin 0 -> 863 bytes .../xcompiled/25-4-SOFTWARE-VERSION.DFASL | Bin 0 -> 816 bytes .../language/xcompiled/25-5-IDENTITY.DFASL | Bin 0 -> 2984 bytes .../language/xcompiled/4-8-COERCE.DFASL | Bin 0 -> 4036 bytes .../language/xcompiled/4-9-TYPE-OF.DFASL | Bin 0 -> 1353 bytes .../xcompiled/5-2-2-LAMBDA-EXPRESSIONS.DFASL | Bin 0 -> 2983 bytes .../5-2-2-LAMBDA-LIST-KEYWORDS.DFASL | Bin 0 -> 1009 bytes .../5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL | Bin 0 -> 793 bytes .../language/xcompiled/5-3-1-DEFUN.DFASL | Bin 0 -> 8023 bytes .../xcompiled/5-3-2-DEFCONSTANT.DFASL | Bin 0 -> 3601 bytes .../xcompiled/5-3-2-DEFPARAMETER.DFASL | Bin 0 -> 3811 bytes .../language/xcompiled/5-3-2-DEFVAR.DFASL | Bin 0 -> 4347 bytes .../language/xcompiled/5-3-3-EVAL-WHEN.DFASL | Bin 0 -> 767 bytes .../language/xcompiled/6-2-1-SUBTYPEP.DFASL | Bin 0 -> 11684 bytes .../language/xcompiled/6-2-1-TYPEP.DFASL | Bin 0 -> 2531 bytes .../language/xcompiled/6-2-2-ARRAYP.DFASL | Bin 0 -> 5898 bytes .../language/xcompiled/6-2-2-ATOM.DFASL | Bin 0 -> 3038 bytes .../xcompiled/6-2-2-BIT-VECTOR-P.DFASL | Bin 0 -> 4249 bytes .../language/xcompiled/6-2-2-CHARACTERP.DFASL | Bin 0 -> 3439 bytes .../language/xcompiled/6-2-2-COMMONP.DFASL | Bin 0 -> 3094 bytes .../xcompiled/6-2-2-COMPILED-FUNCTION-P.DFASL | Bin 0 -> 1776 bytes .../language/xcompiled/6-2-2-COMPLEXP.DFASL | Bin 0 -> 2916 bytes .../language/xcompiled/6-2-2-CONSP.DFASL | Bin 0 -> 3288 bytes .../language/xcompiled/6-2-2-FLOATP.DFASL | Bin 0 -> 2630 bytes .../language/xcompiled/6-2-2-FUNCTIONP.DFASL | Bin 0 -> 2524 bytes .../language/xcompiled/6-2-2-INTEGERP.DFASL | Bin 0 -> 2647 bytes .../language/xcompiled/6-2-2-LISTP.DFASL | Bin 0 -> 3354 bytes .../language/xcompiled/6-2-2-NULL.DFASL | Bin 0 -> 2027 bytes .../language/xcompiled/6-2-2-NUMBERP.DFASL | Bin 0 -> 2394 bytes .../language/xcompiled/6-2-2-PACKAGEP.DFASL | Bin 0 -> 2745 bytes .../language/xcompiled/6-2-2-RATIONALP.DFASL | Bin 0 -> 2772 bytes .../xcompiled/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL | Bin 0 -> 4854 bytes .../xcompiled/6-2-2-SIMPLE-STRING-P.DFASL | Bin 0 -> 3698 bytes .../xcompiled/6-2-2-SIMPLE-VECTOR-P.DFASL | Bin 0 -> 3693 bytes .../language/xcompiled/6-2-2-STRINGP.DFASL | Bin 0 -> 3473 bytes .../language/xcompiled/6-2-2-SYMBOLP.DFASL | Bin 0 -> 2274 bytes .../language/xcompiled/6-2-2-VECTORP.DFASL | Bin 0 -> 4452 bytes .../from-sun/language/xcompiled/6-3-EQ.DFASL | Bin 0 -> 1447 bytes .../from-sun/language/xcompiled/6-3-EQL.DFASL | Bin 0 -> 1816 bytes .../language/xcompiled/6-3-EQUAL.DFASL | Bin 0 -> 2008 bytes .../language/xcompiled/6-3-EQUALP.DFASL | Bin 0 -> 3172 bytes .../from-sun/language/xcompiled/6-4-AND.DFASL | Bin 0 -> 753 bytes .../from-sun/language/xcompiled/6-4-NOT.DFASL | Bin 0 -> 753 bytes .../from-sun/language/xcompiled/6-4-OR.DFASL | Bin 0 -> 751 bytes .../language/xcompiled/7-1-1-BOUNDP.DFASL | Bin 0 -> 1813 bytes .../language/xcompiled/7-1-1-FBOUNDP.DFASL | Bin 0 -> 3441 bytes .../language/xcompiled/7-1-1-FUNCTION.DFASL | Bin 0 -> 2949 bytes .../language/xcompiled/7-1-1-QUOTE.DFASL | Bin 0 -> 1275 bytes .../xcompiled/7-1-1-SPECIAL-FORM-P.DFASL | Bin 0 -> 2601 bytes .../xcompiled/7-1-1-SYMBOL-FUNCTION.DFASL | Bin 0 -> 4302 bytes .../xcompiled/7-1-1-SYMBOL-VALUE.DFASL | Bin 0 -> 3302 bytes .../xcompiled/7-1-2-FMAKUNBOUND.DFASL | Bin 0 -> 2261 bytes .../language/xcompiled/7-1-2-MAKUNBOUND.DFASL | Bin 0 -> 2162 bytes .../language/xcompiled/7-1-2-PSETQ.DFASL | Bin 0 -> 2154 bytes .../language/xcompiled/7-1-2-SET.DFASL | Bin 0 -> 2222 bytes .../language/xcompiled/7-10-CATCH.DFASL | Bin 0 -> 8052 bytes .../language/xcompiled/7-10-THROW.DFASL | Bin 0 -> 765 bytes .../xcompiled/7-10-UNWIND-PROTECT.DFASL | Bin 0 -> 6621 bytes .../xcompiled/7-2-DEFINE-MODIFY-MACRO.DFASL | Bin 0 -> 4859 bytes .../xcompiled/7-2-DEFINE-SETF-METHOD.DFASL | Bin 0 -> 1955 bytes .../language/xcompiled/7-2-DEFSETF.DFASL | Bin 0 -> 2203 bytes .../7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL | Bin 0 -> 1541 bytes .../xcompiled/7-2-GET-SETF-METHOD.DFASL | Bin 0 -> 1496 bytes .../language/xcompiled/7-2-PSETF.DFASL | Bin 0 -> 23706 bytes .../language/xcompiled/7-2-ROTATEF.DFASL | Bin 0 -> 46886 bytes .../language/xcompiled/7-2-SETF.DFASL | Bin 0 -> 302 bytes .../language/xcompiled/7-2-SHIFTF.DFASL | Bin 0 -> 19850 bytes .../language/xcompiled/7-3-APPLY.DFASL | Bin 0 -> 5401 bytes .../xcompiled/7-3-CALL-ARGUMENTS-LIMIT.DFASL | Bin 0 -> 1100 bytes .../language/xcompiled/7-3-FUNCALL.DFASL | Bin 0 -> 2962 bytes .../language/xcompiled/7-4-PROG1.DFASL | Bin 0 -> 1460 bytes .../language/xcompiled/7-4-PROG2.DFASL | Bin 0 -> 2007 bytes .../language/xcompiled/7-4-PROGN.DFASL | Bin 0 -> 1465 bytes .../language/xcompiled/7-5-FLET.DFASL | Bin 0 -> 5352 bytes .../from-sun/language/xcompiled/7-5-LET.DFASL | Bin 0 -> 4132 bytes .../language/xcompiled/7-5-LETSTAR.DFASL | Bin 0 -> 4243 bytes .../language/xcompiled/7-5-MACROLET.DFASL | Bin 0 -> 9134 bytes .../language/xcompiled/7-5-PROGV.DFASL | Bin 0 -> 4401 bytes .../language/xcompiled/7-6-CASE.DFASL | Bin 0 -> 2199 bytes .../language/xcompiled/7-6-COND.DFASL | Bin 0 -> 3664 bytes .../from-sun/language/xcompiled/7-6-IF.DFASL | Bin 0 -> 3020 bytes .../language/xcompiled/7-6-TYPECASE.DFASL | Bin 0 -> 5612 bytes .../language/xcompiled/7-6-UNLESS.DFASL | Bin 0 -> 2889 bytes .../language/xcompiled/7-6-WHEN.DFASL | Bin 0 -> 2929 bytes .../language/xcompiled/7-7-RETURN-FROM.DFASL | Bin 0 -> 8289 bytes .../language/xcompiled/7-7-RETURN.DFASL | Bin 0 -> 4040 bytes .../language/xcompiled/7-8-1-LOOP.DFASL | Bin 0 -> 4914 bytes .../language/xcompiled/7-8-2-DO.DFASL | Bin 0 -> 3717 bytes .../language/xcompiled/7-8-2-DOSTAR.DFASL | Bin 0 -> 3727 bytes .../language/xcompiled/7-8-3-DOLIST.DFASL | Bin 0 -> 4649 bytes .../language/xcompiled/7-8-3-DOTIMES.DFASL | Bin 0 -> 4759 bytes .../language/xcompiled/7-8-4-MAPC.DFASL | Bin 0 -> 3433 bytes .../language/xcompiled/7-8-4-MAPCAN.DFASL | Bin 0 -> 760 bytes .../language/xcompiled/7-8-4-MAPCAR.DFASL | Bin 0 -> 4662 bytes .../language/xcompiled/7-8-4-MAPCON.DFASL | Bin 0 -> 988 bytes .../language/xcompiled/7-8-4-MAPL.DFASL | Bin 0 -> 2623 bytes .../language/xcompiled/7-8-4-MAPLIST.DFASL | Bin 0 -> 3255 bytes .../language/xcompiled/7-8-4-MAPPER.DFASL | Bin 0 -> 6507 bytes .../language/xcompiled/7-8-5-GO.DFASL | Bin 0 -> 751 bytes .../language/xcompiled/7-8-5-PROG.DFASL | Bin 0 -> 4601 bytes .../language/xcompiled/7-8-5-PROGSTAR.DFASL | Bin 0 -> 4685 bytes .../language/xcompiled/7-8-5-TAGBODY.DFASL | Bin 0 -> 4003 bytes .../7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL | Bin 0 -> 9048 bytes .../language/xcompiled/7-9-2-MVR-CATCH.DFASL | Bin 0 -> 2570 bytes .../7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL | Bin 0 -> 9818 bytes .../7-9-2-MVR-EVALUATION-APPLICATION.DFASL | Bin 0 -> 3575 bytes .../7-9-2-MVR-IMPLICIT-PROGN-1.DFASL | Bin 0 -> 15342 bytes .../xcompiled/7-9-2-MVR-MISC-SITUATIONS.DFASL | Bin 0 -> 6683 bytes .../xcompiled/7-9-MULTIPLE-VALUES.DFASL | Bin 0 -> 8283 bytes .../language/xcompiled/8-1-PARSE-BODY.DFASL | Bin 0 -> 1118 bytes .../from-sun/language/xcompiled/9-3-THE.DFASL | Bin 0 -> 2053 bytes .../language/xcompiled/ADDBASE-OP.DFASL | Bin 0 -> 801 bytes .../language/xcompiled/CAR-CDRUFN.DFASL | Bin 0 -> 1465 bytes .../from-sun/language/xcompiled/INIT.LISP | 1 + .../language/xcompiled/LONGFNCALL.DFASL | Bin 0 -> 2732 bytes .../from-sun/language/xcompiled/TEST-RESULTS | 0 .../from-sun/language/xcompiled/take-hard | 1 + internal/test/LANGUAGE/from-sun/sw/do-test | 1 + .../test/LANGUAGE/from-sun/sw/do-test.dfasl | Bin 0 -> 11262 bytes .../test/LANGUAGE/from-sun/sw/do-test.tedit | Bin 0 -> 6091 bytes .../4045xlpstream/Hand/4045XLPSTREAM.PROC | Bin 0 -> 4927 bytes .../4045xlpstream/Hand/4045XLPSTREAM.PROC.~1~ | Bin 0 -> 4822 bytes .../4045xlpstream/Hand/4045XLPSTREAM.PROC.~2~ | Bin 0 -> 4927 bytes .../4045xlpstream/Hand/4045xlpstream.u | Bin 0 -> 4822 bytes .../4045xlpstream/Logs/4045XLPSTREAM.LOG | Bin 0 -> 1120 bytes .../4045xlpstream/Logs/4045XLPSTREAM.LOG.~1~ | Bin 0 -> 2690 bytes .../4045xlpstream/Logs/4045XLPSTREAM.LOG.~2~ | Bin 0 -> 2690 bytes .../4045xlpstream/Logs/4045XLPSTREAM.LOG.~3~ | Bin 0 -> 1120 bytes .../4045xlpstream/Plans/4045XLPSTREAM.PLAN | Bin 0 -> 8091 bytes internal/test/Library/Auto/AR8230.TEST | 1 + .../Library/CASH-FILE/HAND/CASH-FILE.TEST | 1 + .../Library/CASH-FILE/HAND/CASH-FILE.TESTS | 1 + .../CASH-FILE/HAND/CASH-FILE.TESTS.~1~ | 1 + .../CASH-FILE/HAND/CASH-FILE.TESTS.~2~ | 1 + internal/test/Library/GCHAX/Auto/GCHAX.TEST | Bin 0 -> 3188 bytes .../Library/HASH-FILE/HAND/HASH-FILE.TESTS | 1 + .../HASH-FILE/HAND/HASH-FILE.TESTS.~1~ | 1 + .../HASH-FILE/HAND/HASH-FILE.TESTS.~2~ | 1 + .../test/Library/MatMult/Auto/AR8230.TEST | 1 + .../MatMult/Auto/DEGREES-TO-RADIANS.TEST | 1 + .../Library/MatMult/Auto/IDENTITY-3-BY-3.TEST | 1 + .../Library/MatMult/Auto/IDENTITY-4-BY-4.TEST | 1 + .../MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST | 1 + .../Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST | 1 + .../MatMult/Auto/MAKE-HOMOGENEOUS-4-BY-4.TEST | Bin 0 -> 1944 bytes .../Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST | 1 + .../MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST | 1 + .../MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST | 1 + .../MatMult/Auto/PERSPECTIVE-4-BY-4.TEST | 1 + .../Library/MatMult/Auto/ROTATE-3-BY-3.TEST | 1 + .../MatMult/Auto/ROTATE-4-BY-4-ABOUT-X.TEST | 1 + .../MatMult/Auto/ROTATE-4-BY-4-ABOUT-Y.TEST | 1 + .../MatMult/Auto/ROTATE-4-BY-4-ABOUT-Z.TEST | 1 + .../Library/MatMult/Auto/SCALE-3-BY-3.TEST | 1 + .../Library/MatMult/Auto/SCALE-4-BY-4.TEST | 1 + .../MatMult/Auto/TRANSLATE-3-BY-3.TEST | 1 + .../MatMult/Auto/TRANSLATE-4-BY-4.TEST | 1 + .../Library/TEdit/Hand-Aux/.read-me-first | Bin 0 -> 5488 bytes .../Library/TEdit/Hand-Aux/.read-me-first.~1~ | Bin 0 -> 3981 bytes .../Library/TEdit/Hand-Aux/.read-me-first.~2~ | Bin 0 -> 4677 bytes .../Library/TEdit/Hand-Aux/.read-me-first.~3~ | Bin 0 -> 5488 bytes .../test/Library/TEdit/Hand-Aux/AR10063.TEdit | Bin 0 -> 19832 bytes .../TEdit/Hand-Aux/AR8400-TEST-SAMPLE.TEDIT | Bin 0 -> 87 bytes .../Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT | Bin 0 -> 10119 bytes .../TEdit/Hand-Aux/DANCER10-C0.DISPLAYFONT | Bin 0 -> 7040 bytes .../Library/TEdit/Hand-Aux/DANCEROBJ.LCOM | Bin 0 -> 15068 bytes .../TEdit/Hand-Aux/Dancer12-C0.DisplayFont | Bin 0 -> 3662 bytes .../HEADING-KEEP-EXTRA-LINE-GRAB.TEDIT | 54 ++ .../Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL | Bin 0 -> 3653 bytes .../Hand-Aux/KANJI-DEBUG.MAIL-LAFITE-TOC | Bin 0 -> 164 bytes .../Library/TEdit/Hand-Aux/KANJI-DEBUG2.MAIL | Bin 0 -> 934 bytes .../TEdit/Hand-Aux/MASINTER-CAROL-NEWSLETTER | Bin 0 -> 3872 bytes .../TEdit/Hand-Aux/UNDERLINE-TEST.TEDIT | Bin 0 -> 11822 bytes .../TEdit/Hand-Aux/abbrev-sample.tedit | Bin 0 -> 485 bytes .../Library/TEdit/Hand-Aux/dancer10-C0.WD | Bin 0 -> 554 bytes .../Library/TEdit/Hand-Aux/dancer12-c0.wd | Bin 0 -> 298 bytes .../TEdit/Hand-Aux/new-page-after.tedit | Bin 0 -> 320 bytes .../test/Library/WHERE-IS/HAND/WHERE-IS.TESTS | 1 + internal/test/Library/rs232/hand/TESTRECEIVE | 1 + .../test/Library/rs232/hand/TESTRECEIVE.dfasl | Bin 0 -> 1685 bytes .../Library/rs232/hand/TESTRECEIVE.dfasl.~1~ | Bin 0 -> 1500 bytes .../Library/rs232/hand/TESTRECEIVE.dfasl.~2~ | Bin 0 -> 1685 bytes .../test/Library/rs232/hand/TESTRECEIVE.~1~ | 1 + .../test/Library/rs232/hand/TESTRECEIVE.~2~ | 1 + internal/test/Library/rs232/hand/TESTSEND | 1 + .../test/Library/rs232/hand/TESTSEND.dfasl | Bin 0 -> 1577 bytes .../Library/rs232/hand/TESTSEND.dfasl.~1~ | Bin 0 -> 1399 bytes .../Library/rs232/hand/TESTSEND.dfasl.~2~ | Bin 0 -> 1577 bytes internal/test/Library/rs232/hand/TESTSEND.~1~ | 1 + internal/test/Library/rs232/hand/TESTSEND.~2~ | 1 + internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log | 1 + internal/test/Maiko/ARs/ENDLESS-PUSHES | 1 + internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL | Bin 0 -> 805 bytes internal/test/Maiko/ARs/optests.dfasl | Bin 0 -> 1158 bytes internal/test/Maiko/ARs/optests.lisp | 1 + internal/test/Maiko/AUTO/OPCODES.DFASL | Bin 0 -> 54421 bytes internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ | Bin 0 -> 17967 bytes internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ | Bin 0 -> 46530 bytes internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ | Bin 0 -> 49158 bytes internal/test/Maiko/AUTO/OPCODES.DFASL.~4~ | Bin 0 -> 54476 bytes internal/test/Maiko/AUTO/OPCODES.DFASL.~5~ | Bin 0 -> 54446 bytes internal/test/Maiko/AUTO/OPCODES.DFASL.~6~ | Bin 0 -> 54421 bytes internal/test/Maiko/AUTO/OPCODES.TEST | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~1~ | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~2~ | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~3~ | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~4~ | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~5~ | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~6~ | 1 + internal/test/Maiko/AUTO/OPCODES.TEST.~7~ | 1 + internal/test/Maiko/Aux/BBTESTS | 1 + internal/test/Maiko/Aux/BBTESTS.DFASL | Bin 0 -> 4196 bytes internal/test/Maiko/Aux/OPTESTS.DFASL | Bin 0 -> 1158 bytes internal/test/Maiko/Aux/optests.lisp | 1 + internal/test/Maiko/Aux/optests.lisp.~1~ | 1 + internal/test/Maiko/Aux/optests.lisp.~2~ | 1 + internal/test/Maiko/BAD-XREF | 1 + internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS | 1 + .../test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL | Bin 0 -> 10388 bytes .../test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ | 1 + .../test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ | 1 + internal/test/Maiko/OBSOLETE/AREF-TESTER | 1 + .../test/Maiko/OBSOLETE/AREF-TESTER.DFASL | Bin 0 -> 4836 bytes internal/test/Maiko/OBSOLETE/ARRAY-TESTER | 1 + .../test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL | Bin 0 -> 10007 bytes .../test/Maiko/OBSOLETE/ARRAY-TESTER.TEST | 1 + internal/test/Maiko/OBSOLETE/FLOAT-TESTER | 1 + .../test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL | Bin 0 -> 11641 bytes .../test/Maiko/OBSOLETE/FLOAT-TESTER.TEST | 1 + .../test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS | 1 + .../Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL | Bin 0 -> 1281 bytes internal/test/Maiko/OBSOLETE/TESTER | 1 + internal/test/Maiko/OBSOLETE/TESTER.DFASL | Bin 0 -> 8000 bytes internal/test/Maiko/OBSOLETE/unwindtest | 1 + internal/test/Maiko/OBSOLETE/unwindtest.dfasl | Bin 0 -> 1096 bytes internal/test/Maiko/OBSOLETE/unwindtest.lcom | Bin 0 -> 1892 bytes internal/test/Maiko/OBSOLETE/xclopcodetests | 1 + .../test/Maiko/OBSOLETE/xclopcodetests.lcom | Bin 0 -> 13116 bytes internal/test/Maiko/STACKHAX | 1 + internal/test/Maiko/STACKHAX.LCOM | Bin 0 -> 1694 bytes internal/test/Maiko/STACKHAX.LCOM.~1~ | Bin 0 -> 1183 bytes internal/test/Maiko/STACKHAX.LCOM.~2~ | Bin 0 -> 1604 bytes internal/test/Maiko/STACKHAX.LCOM.~3~ | Bin 0 -> 1678 bytes internal/test/Maiko/STACKHAX.LCOM.~4~ | Bin 0 -> 1694 bytes internal/test/Maiko/STACKHAX.~1~ | 1 + internal/test/Maiko/STACKHAX.~2~ | 1 + internal/test/Maiko/STACKHAX.~3~ | 1 + internal/test/Maiko/STACKHAX.~4~ | 1 + internal/test/Maiko/STACKTAKESHI | 1 + internal/test/Maiko/STACKTAKESHI.LCOM | Bin 0 -> 1187 bytes internal/test/Maiko/display.cl | 1 + internal/test/TEST-RESULTS | 1 + internal/test/Tools/AUTOTEST | 1 + internal/test/Tools/AUTOTEST.LCOM | Bin 0 -> 40326 bytes internal/test/Tools/AUTOTEST.TEDIT | 66 ++ internal/test/Tools/DO-TEST | Bin 0 -> 37656 bytes internal/test/Tools/DO-TEST-MENU | 1 + internal/test/Tools/DO-TEST-MENU.dfasl | Bin 0 -> 1947 bytes internal/test/Tools/DO-TEST-MENU.dfasl.~1~ | Bin 0 -> 1664 bytes internal/test/Tools/DO-TEST-MENU.dfasl.~2~ | Bin 0 -> 1947 bytes internal/test/Tools/DO-TEST.LCOM | Bin 0 -> 22958 bytes internal/test/Tools/DO-TEST.dfasl | Bin 0 -> 26197 bytes internal/test/Tools/DO-TEST.dfasl.~1~ | Bin 0 -> 24775 bytes internal/test/Tools/DO-TEST.dfasl.~2~ | Bin 0 -> 26197 bytes internal/test/Tools/FDEVTEST | 1 + internal/test/Tools/FDEVTEST.LCOM | 1 + internal/test/Tools/FILEBANGER | 1 + internal/test/Tools/LOCK-FILE | 1 + internal/test/Tools/NEXTID | 1 + internal/test/Tools/RANDOM-GENERATOR | 1 + internal/test/Tools/RANDOM-GENERATOR.LCOM | Bin 0 -> 5139 bytes internal/test/Tools/TEST-ARITHMETIC-UTILS | 1 + .../test/Tools/TEST-ARITHMETIC-UTILS.LCOM | Bin 0 -> 1378 bytes .../test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ | Bin 0 -> 1378 bytes .../test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ | Bin 0 -> 1378 bytes internal/test/Tools/TEST-DISPLAY-UTILS | 1 + internal/test/Tools/TEST-DISPLAY-UTILS.LCOM | Bin 0 -> 943 bytes internal/test/Tools/TEST-FILING-UTILS | 1 + internal/test/Tools/TEST-FILING-UTILS.LCOM | Bin 0 -> 1072 bytes internal/test/Tools/TEST-REMOTE-EVAL | 1 + internal/test/Tools/TEST-REMOTE-EVAL.LCOM | Bin 0 -> 7859 bytes internal/test/Tools/TESTER | 1 + internal/test/Tools/TESTER.LCOM | 0 internal/test/Tools/TESTER.TEDIT | 85 ++ internal/test/Tools/TESTERLOADER | 1 + internal/test/Tools/TESTERLOADER.LCOM | 1 + internal/test/Tools/TESTERVARS | 1 + internal/test/Tools/TESTERVARS.DFASL | Bin 0 -> 8083 bytes internal/test/Tools/TESTUSERS.TEDIT | 113 +++ internal/test/Tools/TestExec | 1 + internal/test/Tools/TestExec.LCOM | Bin 0 -> 3615 bytes internal/test/Tools/TestExec.TEdit | Bin 0 -> 7726 bytes internal/test/Tools/TestUtils | 1 + internal/test/Tools/TestUtils.LCOM | Bin 0 -> 923 bytes internal/test/Tools/TestUtils.TEdit | Bin 0 -> 1695 bytes internal/test/Tools/VARBROWSER | 1 + internal/test/Tools/VARBROWSER.LCOM | Bin 0 -> 7930 bytes internal/test/Tools/sloop.lisp | 1 + internal/test/admin/ManualManual.tedit | 206 +++++ .../test/admin/Running-AR-Test-Cases.TEdit | Bin 0 -> 1390 bytes internal/test/env/DEdit/high-level.u | 1 + internal/test/env/DEdit/high-level.u.~1~ | 1 + internal/test/env/DEdit/high-level.u.~2~ | 1 + internal/test/env/DEdit/report.TEdit | Bin 0 -> 1073 bytes internal/test/env/Debugger/24-DEBUG.UX | 1 + internal/test/env/Debugger/hand/BreakWindow.u | 469 ++++++++++ .../test/env/Debugger/hand/BreakWindow.u.~1~ | 469 ++++++++++ .../test/env/Debugger/hand/BreakWindow.u.~2~ | 469 ++++++++++ .../test/env/Debugger/hand/BreakWindow.u.~3~ | 469 ++++++++++ internal/test/env/Debugger/hand/debugger.u | 336 +++++++ .../test/env/Debugger/hand/debugger.u.~1~ | 336 +++++++ .../test/env/Debugger/hand/debugger.u.~2~ | 336 +++++++ .../test/env/Debugger/logs/DebuggerOnly.log | 1 + .../env/Debugger/logs/DebuggerOnly.log.~1~ | 1 + .../env/Debugger/logs/DebuggerOnly.log.~2~ | 1 + .../env/Debugger/logs/DebuggerOnly.log.~3~ | 1 + internal/test/env/Debugger/logs/Report.tedit | 313 +++++++ internal/test/env/Debugger/logs/debugger.log | Bin 0 -> 1579 bytes .../test/env/Debugger/logs/debugger.log.~1~ | 1 + .../test/env/Debugger/logs/debugger.log.~2~ | 1 + .../test/env/Debugger/logs/debugger.log.~3~ | 1 + .../test/env/Debugger/logs/debugger.log.~4~ | 1 + .../test/env/Debugger/logs/debugger.log.~5~ | 1 + .../test/env/Debugger/logs/debugger.log.~6~ | 1 + .../test/env/Debugger/logs/debugger.log.~7~ | Bin 0 -> 1579 bytes internal/test/env/Exec/Hand/CONN.U | 1 + internal/test/env/Exec/Hand/DA.U | 1 + internal/test/env/Exec/Hand/DA.U.~1~ | 1 + internal/test/env/Exec/Hand/DA.U.~2~ | 1 + internal/test/env/Exec/Hand/DIR.U | 1 + internal/test/env/Exec/Hand/FIND-EVENT.U | 1 + internal/test/env/Exec/Hand/FIX.U | 1 + internal/test/env/Exec/Hand/HELP.U | 1 + internal/test/env/Exec/Hand/MULTIPLE-USE.U | 1 + internal/test/env/Exec/Hand/NDIR.U | 1 + internal/test/env/Exec/Hand/PL.U | 1 + internal/test/env/Exec/Hand/PP.U | 1 + internal/test/env/Exec/Hand/REDO.U | 1 + .../test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U | 1 + internal/test/env/Exec/Hand/SEE.U | 1 + internal/test/env/Exec/Hand/TEST.REPORT | 1 + internal/test/env/Exec/Hand/TY.U | 1 + internal/test/env/Exec/Hand/TYPE.U | 1 + internal/test/env/Exec/Hand/USE.U | 1 + internal/test/env/Exec/Hand/do-events.u | 1 + internal/test/env/Exec/Hand/exec.log | 1 + internal/test/env/Exec/Hand/forget.u | 1 + internal/test/env/Exec/Hand/log-form | Bin 0 -> 1096 bytes internal/test/env/Exec/Hand/masterscope.u | 1 + internal/test/env/Exec/Hand/name.u | 1 + internal/test/env/Exec/Hand/remember.u | 1 + internal/test/env/Exec/Hand/retry.u | 1 + internal/test/env/Exec/Hand/shh.u | 1 + internal/test/env/Exec/Hand/test.proc | Bin 0 -> 2498 bytes internal/test/env/Exec/Hand/time.u | 1 + internal/test/env/Exec/Hand/undo.u | 1 + internal/test/env/Exec/Logs/Debugger.log | 1 + internal/test/env/Exec/Logs/Exec.log | 1 + internal/test/env/Exec/Logs/Exec.log.~1~ | 1 + internal/test/env/Exec/Logs/Exec.log.~2~ | 1 + internal/test/env/Exec/Logs/Exec.log.~3~ | 1 + .../test/env/FilePkg/Hand-Aux/FORMATTINGFNS | 1 + internal/test/env/FilePkg/Hand/AR10062.u | 1 + internal/test/env/FreeMenu/Auto/FREEMENU.TEST | Bin 0 -> 15472 bytes .../test/env/Program-Support/Auto/CLISP.TEST | Bin 0 -> 7660 bytes .../env/Program-Support/Auto/CLISP.TEST.~2~ | Bin 0 -> 7660 bytes .../test/env/Program-Support/hand/DWIM.REPORT | 1 + internal/test/env/Program-Support/hand/DWIM.U | 1 + .../test/env/Program-Support/hand/dwim.log | 1 + .../test/env/code-editor/hand/Command-abort.u | 1 + .../env/code-editor/hand/Command-arglist.u | 1 + .../code-editor/hand/Command-arglist.u.~1~ | 1 + .../code-editor/hand/Command-arglist.u.~2~ | 1 + .../test/env/code-editor/hand/Command-base.u | 1 + .../env/code-editor/hand/Command-comment.u | 1 + .../test/env/code-editor/hand/Command-eval.u | 1 + .../env/code-editor/hand/Command-expand.u | 1 + .../env/code-editor/hand/Command-extract.u | 1 + .../code-editor/hand/Command-extract.u.~1~ | 1 + .../code-editor/hand/Command-extract.u.~2~ | 1 + .../test/env/code-editor/hand/Command-find.u | 1 + .../env/code-editor/hand/Command-find.u.~1~ | 1 + .../env/code-editor/hand/Command-find.u.~2~ | 1 + .../test/env/code-editor/hand/Command-high.u | 1 + .../env/code-editor/hand/Command-high.u.~1~ | 1 + .../env/code-editor/hand/Command-high.u.~2~ | 1 + .../test/env/code-editor/hand/Command-join.u | 1 + .../env/code-editor/hand/Command-join.u.~1~ | 1 + .../env/code-editor/hand/Command-join.u.~2~ | 1 + .../test/env/code-editor/hand/Command-menu.u | 1 + .../env/code-editor/hand/Command-menu.u.~1~ | 1 + .../env/code-editor/hand/Command-menu.u.~2~ | 1 + .../env/code-editor/hand/Command-meta-o.u | 1 + .../env/code-editor/hand/Command-meta-o.u.~1~ | 1 + .../env/code-editor/hand/Command-meta-o.u.~2~ | 1 + .../env/code-editor/hand/Command-mutate.u | 1 + .../env/code-editor/hand/Command-mutate.u.~1~ | 1 + .../env/code-editor/hand/Command-mutate.u.~2~ | 1 + .../test/env/code-editor/hand/Command-paren.u | 1 + .../env/code-editor/hand/Command-paren.u.~1~ | 1 + .../env/code-editor/hand/Command-paren.u.~2~ | 1 + .../env/code-editor/hand/Command-substitute.u | 1 + .../code-editor/hand/Command-substitute.u.~1~ | 1 + .../code-editor/hand/Command-substitute.u.~2~ | 1 + .../env/code-editor/hand/Command-undo-redo.u | 1 + .../code-editor/hand/Command-undo-redo.u.~1~ | 1 + .../code-editor/hand/Command-undo-redo.u.~2~ | 1 + internal/test/env/code-editor/hand/Control.u | 364 ++++++++ .../test/env/code-editor/hand/Control.u.~1~ | 1 + .../test/env/code-editor/hand/Control.u.~2~ | 364 ++++++++ .../test/env/code-editor/hand/Interrupt.u | 1 + .../test/env/code-editor/hand/Interrupt.u.~1~ | 1 + .../test/env/code-editor/hand/Interrupt.u.~2~ | 1 + .../env/code-editor/hand/SEdit-3-mar-88.log | 1 + .../code-editor/hand/SEdit-3-mar-88.log.~1~ | 1 + .../code-editor/hand/SEdit-3-mar-88.log.~2~ | 1 + .../env/code-editor/hand/command-package.u | 1 + .../code-editor/hand/command-package.u.~1~ | 1 + .../code-editor/hand/command-package.u.~2~ | 1 + .../env/code-editor/hand/command-skip-next.u | 1 + .../code-editor/hand/command-skip-next.u.~1~ | 1 + .../code-editor/hand/command-skip-next.u.~2~ | 1 + .../test/env/code-editor/hand/report.tedit | Bin 0 -> 4865 bytes internal/test/env/inspector/hand/allrec.test | 665 ++++++++++++++ .../env/inspector/hand/inspect-allrec.tedit | Bin 0 -> 71237 bytes .../env/inspector/hand/inspect-code.tedit | Bin 0 -> 1719 bytes .../inspector/hand/inspect-defstruct.tedit | Bin 0 -> 9251 bytes .../hand/inspect-defstruct.tedit.~1~ | Bin 0 -> 9188 bytes .../hand/inspect-defstruct.tedit.~2~ | Bin 0 -> 9251 bytes .../env/inspector/hand/inspect-macro.tedit | Bin 0 -> 6003 bytes .../inspector/hand/inspect-macro.tedit.~1~ | Bin 0 -> 5950 bytes .../inspector/hand/inspect-macro.tedit.~2~ | Bin 0 -> 6003 bytes .../env/inspector/hand/inspectfieldflg.tedit | Bin 0 -> 3097 bytes .../inspector/hand/inspectfieldflg.tedit.~1~ | Bin 0 -> 3044 bytes .../inspector/hand/inspectfieldflg.tedit.~2~ | Bin 0 -> 3097 bytes .../test/env/inspector/hand/inspectw.tedit | Bin 0 -> 9947 bytes .../env/inspector/hand/inspectw.tedit.~1~ | Bin 0 -> 9894 bytes .../env/inspector/hand/inspectw.tedit.~2~ | Bin 0 -> 9947 bytes internal/test/env/inspector/hand/report.tedit | Bin 0 -> 3594 bytes internal/test/env/inspector/hand/userdef.test | 1 + .../test/env/inspector/hand/userdef.test.~1~ | 1 + .../test/env/inspector/hand/userdef.test.~2~ | 1 + .../env/inspector/logs/inspect-defstruct.log | Bin 0 -> 607 bytes .../inspector/logs/inspect-defstruct.log.~1~ | 1 + .../inspector/logs/inspect-defstruct.log.~2~ | Bin 0 -> 607 bytes .../test/env/process-controls/LOGS/PSW.LOG | 1 + .../test/env/process-controls/hand/PSW.REPORT | 1 + internal/test/env/process-controls/hand/PSW.U | 1 + .../test/env/process-controls/hand/PSW.U.~1~ | 1 + .../test/env/process-controls/hand/PSW.U.~2~ | 1 + .../test/env/process-controls/hand/PSW.U.~3~ | 1 + .../env/program-analysis/hand/BROWSER-PART2.U | 1 + .../program-analysis/hand/BROWSER-PART2.U.~1~ | 1 + .../program-analysis/hand/BROWSER-PART2.U.~2~ | 1 + .../program-analysis/hand/BROWSER-PART2.U.~3~ | 1 + .../program-analysis/hand/BROWSER-PART2.U.~4~ | 1 + .../env/program-analysis/hand/BROWSER.GRAPH | Bin 0 -> 3076 bytes .../env/program-analysis/hand/BROWSER.REPORT | 1 + .../program-analysis/hand/DATABASEFNS.REPORT | 1 + .../env/program-analysis/hand/DATABASEFNS.U | 1 + .../program-analysis/hand/DATABASEFNS.U.~1~ | 1 + .../program-analysis/hand/DATABASEFNS.U.~2~ | 1 + .../program-analysis/hand/DATABASEFNS.U.~3~ | 1 + .../program-analysis/hand/DATABASEFNS.U.~4~ | 1 + .../test/env/program-analysis/hand/INSPECT.U | 1 + .../env/program-analysis/hand/INSPECT.U.~1~ | 1 + .../env/program-analysis/hand/INSPECT.U.~2~ | 1 + .../env/program-analysis/hand/INSPECT.U.~3~ | 1 + .../env/program-analysis/hand/INSPECT.U.~4~ | 1 + .../env/program-analysis/hand/INSPECT.U.~5~ | 1 + .../program-analysis/hand/MASTERSCOPE.REPORT | 1 + .../test/env/program-analysis/hand/SPY.REPORT | 1 + internal/test/env/program-analysis/hand/SPY.U | 1 + .../test/env/program-analysis/hand/SPY.U.~1~ | 1 + .../test/env/program-analysis/hand/SPY.U.~2~ | 1 + .../test/env/program-analysis/hand/SPY.U.~3~ | 1 + .../env/program-analysis/hand/browser-part1.u | Bin 0 -> 5488 bytes .../program-analysis/hand/browser-part1.u.~1~ | 1 + .../program-analysis/hand/browser-part1.u.~2~ | 1 + .../program-analysis/hand/browser-part1.u.~3~ | Bin 0 -> 5488 bytes .../program-analysis/hand/databasefns.data | 1 + .../hand/databasefns.data.~1~ | 1 + .../hand/databasefns.data.~2~ | 1 + .../env/program-analysis/hand/inspect.report | 1 + .../env/program-analysis/hand/masterscope.u | 1 + .../program-analysis/hand/masterscope.u.~1~ | 1 + .../program-analysis/hand/masterscope.u.~2~ | 1 + .../program-analysis/hand/masterscope.u.~3~ | 1 + .../program-analysis/hand/masterscope.u.~4~ | 1 + .../program-analysis/hand/masterscope.u.~5~ | 1 + .../program-analysis/hand/masterscope.u.~6~ | 1 + .../program-analysis/hand/masterscope.u.~7~ | 1 + .../test/i/o/Display/Auto/CURSORTEST.SOURCE | 1 + .../test/i/o/Display/Auto/CURSORTEST.TEST | 1 + internal/test/i/o/Display/Hand/CURSOR.PROC | Bin 0 -> 2174 bytes internal/test/i/o/Display/Logs/CURSOR.LOG | Bin 0 -> 1473 bytes .../test/i/o/Hardcopy/Hand/FX80DRIVER.PROC | Bin 0 -> 4892 bytes .../i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG | Bin 0 -> 2263 bytes .../i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC | Bin 0 -> 3248 bytes .../test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL | Bin 0 -> 3994 bytes .../Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT | Bin 0 -> 198815 bytes .../test/i/o/Hardcopy/Hand/fx80driver.log | Bin 0 -> 967 bytes internal/test/i/o/Hardcopy/Hand/streamtests.u | 1 + .../Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT | 1 + .../i/o/Hardcopy/Hand/testfiles/01UR.TEDIT | Bin 0 -> 7339 bytes .../i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT | Bin 0 -> 7789 bytes .../i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT | Bin 0 -> 8396 bytes .../i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT | 27 + .../i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT | Bin 0 -> 9942 bytes .../i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT | Bin 0 -> 10358 bytes .../i/o/Hardcopy/Hand/testfiles/07NS.TEDIT | Bin 0 -> 11263 bytes .../i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT | Bin 0 -> 29457 bytes .../o/Hardcopy/Hand/testfiles/10MIXED.SKETCH | Bin 0 -> 1440 bytes .../Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH | Bin 0 -> 1056 bytes .../o/Hardcopy/Hand/testfiles/12CURVE.SKETCH | Bin 0 -> 1562 bytes .../o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH | Bin 0 -> 1916 bytes .../i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH | Bin 0 -> 2170 bytes .../Hardcopy/Hand/testfiles/15REVERSE.SKETCH | Bin 0 -> 2434 bytes internal/test/i/o/Keyboard/Hand/ASKUSER.u | 1 + .../test/i/o/Keyboard/Hand/PromptForWord.u | 1 + internal/test/i/o/Keyboard/Hand/ReadNumber.u | 1 + internal/test/i/o/Keyboard/Hand/TTYIN.u | 1 + internal/test/i/o/Keyboard/logs/askuser.log | 1 + internal/test/i/o/Keyboard/logs/keyboard.log | 1 + .../test/i/o/Keyboard/logs/keyboard.log.~1~ | 1 + .../test/i/o/Keyboard/logs/keyboard.log.~2~ | 1 + .../test/i/o/Keyboard/logs/keyboard.log.~3~ | 1 + internal/test/loops/LOOPS-SETUP.TEDIT | Bin 0 -> 2035 bytes internal/test/loops/LOOPS-TESTER-2-1 | 1 + internal/test/loops/LOOPS-TESTER-2-1.dfasl | Bin 0 -> 10026 bytes internal/test/loops/LOOPS-TESTER-2-2 | 1 + internal/test/loops/LOOPS-TESTER-2-2.dfasl | Bin 0 -> 2005 bytes internal/test/loops/LOOPS-TESTER-2-4 | 1 + internal/test/loops/LOOPS-TESTER-2-4.dfasl | Bin 0 -> 8488 bytes internal/test/loops/LOOPS-TESTER-BASICS | 1 + internal/test/loops/LOOPS-TESTER-BASICS.dfasl | Bin 0 -> 1048 bytes internal/test/lyric/DO-TEST | 1 + internal/test/lyric/DO-TEST.dfasl | Bin 0 -> 10386 bytes internal/test/lyric/do-test.tedit | Bin 0 -> 6091 bytes 3250 files changed, 10780 insertions(+) create mode 100644 internal/gabriel/00-README.txt create mode 100644 internal/gabriel/00-README.txt.~1~ create mode 100644 internal/gabriel/Results/KOTO-DANDELION.BENCHMARKS create mode 100644 internal/gabriel/Results/KOTO-DORADO.BENCHMARKS create mode 100644 internal/gabriel/Results/KOTO-DOVE.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/ALL-PAV.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/AREFY-PAV.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/CONSY-BYTE.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/CONSY-PAV.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/EXTRAS-BYTE.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/EXTRAS-PAV.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/File-Servers.TEdit create mode 100644 internal/gabriel/Results/Lyric/IO-BYTE.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/IO-PAV.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/RESULTS.TEDIT create mode 100644 internal/gabriel/Results/Lyric/SUMMARY-5-27.TEDIT create mode 100644 internal/gabriel/Results/Lyric/TAK-BYTE.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/TAK-PAV.BENCHMARKS create mode 100644 internal/gabriel/Results/Lyric/all-byte.benchmarks create mode 100644 internal/gabriel/Results/Lyric/arefy-byte.benchmarks create mode 100644 internal/gabriel/Results/Lyric/byte-5-24.benchmarks create mode 100644 internal/gabriel/Results/Lyric/byte-5-26.benchmarks create mode 100644 internal/gabriel/Results/Lyric/lyric-results.tedit create mode 100644 internal/gabriel/Results/Lyric/pav-5-25.benchmarks create mode 100644 internal/gabriel/Results/Lyric/pav-5-26.benchmarks create mode 100644 internal/gabriel/Results/Lyric/summary.tedit create mode 100644 internal/gabriel/Results/Maiko-Pav-06-14-88.benchmarks create mode 100644 internal/gabriel/Results/Maiko/1132-BYTE-TAK.Results create mode 100644 internal/gabriel/Results/Maiko/1132-PAV-TAK.Results create mode 100644 internal/gabriel/Results/Maiko/1186-BYTE-CONSY.Results create mode 100644 internal/gabriel/Results/Maiko/1186-IO.Results create mode 100644 internal/gabriel/Results/Maiko/1186-PAV-AREFY.Results create mode 100644 internal/gabriel/Results/Maiko/1186-PAV-CONSY.Results create mode 100644 internal/gabriel/Results/Maiko/1186-PAV-TAK.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-BYTE-AREFY.RESULTS create mode 100644 internal/gabriel/Results/Maiko/SUN-BYTE-ARITH.RESULTS create mode 100644 internal/gabriel/Results/Maiko/SUN-BYTE-CONSY.RESULTS create mode 100644 internal/gabriel/Results/Maiko/SUN-BYTE-TAK.RESULTS create mode 100644 internal/gabriel/Results/Maiko/SUN-IO.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-IO.Results.~14~ create mode 100644 internal/gabriel/Results/Maiko/SUN-IO.Results.~1~ create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-AREFY.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~10~ create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~1~ create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-CONSY.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-MISC.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-POLY.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~16~ create mode 100644 internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~1~ create mode 100644 internal/gabriel/Results/Maiko/win-tak.results create mode 100644 internal/gabriel/Results/Maiko/win-tak.results.~1~ create mode 100644 internal/gabriel/Results/Maiko/win-tak.results.~2~ create mode 100644 internal/gabriel/Results/Maiko/x86-arefy.results create mode 100644 internal/gabriel/Results/Maiko/x86-arith.results create mode 100644 internal/gabriel/Results/Maiko/x86-byte-tak.results create mode 100644 internal/gabriel/Results/Maiko/x86-consy.results create mode 100644 internal/gabriel/Results/Maiko/x86-poly.results create mode 100644 internal/gabriel/Results/Medley/BYTE-AREFY-1186.RESULTS create mode 100644 internal/gabriel/Results/Medley/BYTE-CONSY-1186.RESULTS create mode 100644 internal/gabriel/Results/Medley/BYTE-IO-1186.RESULTS create mode 100644 internal/gabriel/Results/Medley/BYTE-TAK-1186.RESULTS create mode 100644 internal/gabriel/Results/SUMMARY-TIME-SERIES2.tedit create mode 100644 internal/gabriel/Results/SUMMARY-TIME-SERIES3.tedit create mode 100644 internal/gabriel/Results/SUMMARY-TIME-SERIES4.Tedit create mode 100644 internal/gabriel/Results/Summary-Time-Series.TEdit create mode 100644 internal/gabriel/Results/koto-1108.benchmarks create mode 100644 internal/gabriel/admin/Result-Log-Form.TEdit create mode 100644 internal/gabriel/aux/1000-SYMBOLS create mode 100644 internal/gabriel/aux/2000-FLOATS-TO-READ create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~1~ create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~2~ create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~3~ create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~4~ create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~5~ create mode 100644 internal/gabriel/benchmarks/ARITH-BENCHMARKS.LCOM create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER.LCOM create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~1~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~2~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~3~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~4~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK.LCOM create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK.dfasl create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~2~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ create mode 100644 internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~4~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~1~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~2~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~1~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~2~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~5~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~6~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~7~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~8~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.~1~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.~2~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.~3~ create mode 100644 internal/gabriel/benchmarks/IO-BENCHMARKS.~4~ create mode 100644 internal/gabriel/benchmarks/MISC-BENCHMARKS create mode 100644 internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL create mode 100644 internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~1~ create mode 100644 internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~2~ create mode 100644 internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~3~ create mode 100644 internal/gabriel/benchmarks/MISC-BENCHMARKS.LCOM create mode 100644 internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.DFASL create mode 100644 internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.LCOM create mode 100644 internal/gabriel/benchmarks/Medley/GABRIEL-TAK.DFASL create mode 100644 internal/gabriel/benchmarks/Medley/GABRIEL-TAK.LCOM create mode 100644 internal/gabriel/benchmarks/Medley/GABRIEL-TIMERS.LCOM create mode 100644 internal/gabriel/benchmarks/RUNNING-BENCHMARKS.DRIBBLE create mode 100644 internal/gabriel/interlisp/1186BENCHMARKS create mode 100644 internal/gabriel/interlisp/BENCHMARK create mode 100644 internal/gabriel/interlisp/BOYER create mode 100644 internal/gabriel/interlisp/BROWSE create mode 100644 internal/gabriel/interlisp/CTAK create mode 100644 internal/gabriel/interlisp/DDERIV create mode 100644 internal/gabriel/interlisp/DERIV create mode 100644 internal/gabriel/interlisp/DERIV.LCOM create mode 100644 internal/gabriel/interlisp/DESTRUCTIVE create mode 100644 internal/gabriel/interlisp/DESTRUCTIVE.LCOM create mode 100644 internal/gabriel/interlisp/DIV2 create mode 100644 internal/gabriel/interlisp/DIV2.LCOM create mode 100644 internal/gabriel/interlisp/FFT create mode 100644 internal/gabriel/interlisp/FPRINT create mode 100644 internal/gabriel/interlisp/FPRINT.TST create mode 100644 internal/gabriel/interlisp/FREAD create mode 100644 internal/gabriel/interlisp/POLY create mode 100644 internal/gabriel/interlisp/PUZZLE create mode 100644 internal/gabriel/interlisp/STAK create mode 100644 internal/gabriel/interlisp/TAK create mode 100644 internal/gabriel/interlisp/TAKL create mode 100644 internal/gabriel/interlisp/TAKR create mode 100644 internal/gabriel/interlisp/TESTPATTERN create mode 100644 internal/gabriel/interlisp/TPRINT create mode 100644 internal/gabriel/interlisp/TRAVERSE create mode 100644 internal/gabriel/interlisp/TRAVERSE.LCOM create mode 100644 internal/gabriel/interlisp/TRIANG create mode 100644 internal/gabriel/interlisp/benchmarkmemo.tedit create mode 100644 internal/gabriel/interlisp/dderiv.lcom create mode 100644 internal/gabriel/tools/BENCH-1 create mode 100644 internal/gabriel/tools/BENCH-1.~1~ create mode 100644 internal/gabriel/tools/BENCH-1.~2~ create mode 100644 internal/gabriel/tools/BENCH-1.~3~ create mode 100644 internal/gabriel/tools/BENCH-2 create mode 100644 internal/gabriel/tools/BENCH-2.~1~ create mode 100644 internal/gabriel/tools/BENCH-2.~2~ create mode 100644 internal/gabriel/tools/BENCH-3 create mode 100644 internal/gabriel/tools/BENCH-3.~1~ create mode 100644 internal/gabriel/tools/BENCH-3.~2~ create mode 100644 internal/gabriel/tools/BENCH-386 create mode 100644 internal/gabriel/tools/BENCH-4 create mode 100644 internal/gabriel/tools/BENCH-4.~1~ create mode 100644 internal/gabriel/tools/BENCH-4.~2~ create mode 100644 internal/gabriel/tools/BENCH-5 create mode 100644 internal/gabriel/tools/BENCH-5.~1~ create mode 100644 internal/gabriel/tools/BENCH-5.~2~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.LCOM create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~1~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~2~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~3~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.dfasl create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ create mode 100644 internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ create mode 100644 internal/gabriel/tools/TESTVARS create mode 100644 internal/test/.read-me-first create mode 100644 internal/test/4045/Hand-Aux/Justification-TEst.TEdit create mode 100644 internal/test/ARs/.read-me-first create mode 100644 internal/test/ARs/.read-me-first.~1~ create mode 100644 internal/test/ARs/.read-me-first.~2~ create mode 100644 internal/test/ARs/AR-Test-Case-Summary-Template.TEdit create mode 100644 internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log create mode 100644 internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT create mode 100644 internal/test/GC/HAND-AUX/DANCER10-C0.DISPLAYFONT create mode 100644 internal/test/GC/HAND-AUX/Dancer12-C0.DisplayFont create mode 100644 internal/test/GC/HAND-AUX/dancer10-C0.WD create mode 100644 internal/test/GC/HAND-AUX/dancer12-c0.wd create mode 100644 internal/test/GC/Hand/DANCEROBJ create mode 100644 internal/test/GC/Hand/DANCEROBJ.LCOM create mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS create mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE create mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM create mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ create mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ create mode 100644 internal/test/GC/Hand/Maiko-GC-Tests.script create mode 100644 internal/test/IO/Auto/IO-REGRESSION.TEST create mode 100644 internal/test/IO/Auto/MSPF.TEST create mode 100644 internal/test/IO/Auto/Peekbin.test create mode 100644 internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP create mode 100644 internal/test/LANGUAGE/AUTO/.read-me-first create mode 100644 internal/test/LANGUAGE/AUTO/.read-me-first.~1~ create mode 100644 internal/test/LANGUAGE/AUTO/.read-me-first.~2~ create mode 100644 internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-1-GET.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-1-GET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-1-GETF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-1-REMF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-1-REMF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-3-GENSYM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-3-GENTEMP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-6-IMPORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-EXPORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-IMPORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-UNINTERN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/11-8-PROVIDE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-EVENP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-2-EVENP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-EVENP.TST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-MINUSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-2-MINUSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-ODDP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-ODDP.TST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-PLUSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-ZEROP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-2-ZEROP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT create mode 100644 internal/test/LANGUAGE/AUTO/12-3-EQP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-EQP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-LEQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-MAX.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-MIN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONINCREASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-3-NEQP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-3-NEQP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-+.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-+.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4--.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4--.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-1+.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-1+.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-1-.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-1-.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-DECF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-GCD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-INCF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-LCM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-4-TIMES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-EXPT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ASINH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ATAN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-COS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-SIN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-TAN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-5-2-TANH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-COMPLEX.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FCEILING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FLOOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FROUND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-IMAGPART.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-MOD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-RATIONAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-REALPART.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-REM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-REM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-ASH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-BOOLE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGEQV.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGNAND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGORC2.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGTEST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-BYTE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-DPB.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-LDB.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-ELT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-ELT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-LENGTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-LENGTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-NREVERSE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-NREVERSE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-MAP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-2-SOME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-DELETE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FILL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FILL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-FIND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-POSITION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-4-COUNT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-4-MISMATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-5-MERGE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-5-MERGE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-5-SORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-5-SORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAADR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAADDR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADAA.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADAA.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADADR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDADDR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDAAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-CONS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-APPEND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-BUTLAST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-ENDP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-FIRST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LAST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LDIFF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NCONC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NINTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NTHCDR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-POP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-POP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-PUSH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-REST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-REST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-SEVENTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-2-THIRD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-3-RPLACD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-3-RPLACD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-4-SUBST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-ADJOIN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-NUNION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-TAILP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-5-UNION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-GETHASH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-GETHASH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-MAPHASH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-1-REMHASH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-2-AREF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-2-AREF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-AND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-BIT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-4-SBIT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-1-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-GE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-GE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-GT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-LE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-LT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/18-3-STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/20-1-APPLYHOOK.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/21-STREAMS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-FROM-STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-READ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-PRINT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X create mode 100644 internal/test/LANGUAGE/AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X create mode 100644 internal/test/LANGUAGE/AUTO/23-2-OPEN.X create mode 100644 internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X create mode 100644 internal/test/LANGUAGE/AUTO/23-4-LOAD.X create mode 100644 internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X create mode 100644 internal/test/LANGUAGE/AUTO/23-FUNCTIONS create mode 100644 internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF create mode 100644 internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-1-BREAK.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-1-BREAK.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-1-CERROR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-1-ERROR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-1-WARN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-2-ASSERT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-3-CCASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X create mode 100644 internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-ED.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-ED.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-3-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SLEEP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/25-5-IDENTITY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-CONSP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-LISTP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-NULL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-4-AND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-4-AND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-4-NOT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/6-4-OR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/6-4-OR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-SET.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-10-CATCH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-10-CATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-10-THROW.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-DEFSETF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-PSETF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-SETF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-3-APPLY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-3-FUNCALL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-4-PROG1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-4-PROG2.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-4-PROGN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-4-PROGN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-FLET.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-5-FLET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-LET.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-5-LET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-5-LETSTAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-MACROLET.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-5-MACROLET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-6-CASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-6-CASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-6-COND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-6-COND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-6-IF.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-6-IF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-6-TYPECASE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-6-WHEN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-2-DO.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-PROG.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-PROG.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-2.TEST create mode 100644 internal/test/LANGUAGE/AUTO/7-9-2-MVR-MISC-SITUATIONS.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST create mode 100644 internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST create mode 100644 internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST create mode 100644 internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/9-3-THE.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/9-3-THE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR-TEST-CASES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR5741.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR5741.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR6150.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR6150.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR6247.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR6247.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR6273.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR6273.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR6781.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR6781.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR7412.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR7412.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR7475.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR7475.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR7525.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR7525.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR7647.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR7647.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR7742.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR7742.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8135.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8135.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8136.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8136.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8190.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8190.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8207.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8207.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8297.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8301.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8301.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8319.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8319.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8458.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8458.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8465.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8465.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8466.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8470.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8470.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8491.TEST create mode 100644 internal/test/LANGUAGE/AUTO/AR8575.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/AR8575.TEST create mode 100644 internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/ARRAY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/ARRAY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/ARRAYP.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/ARRAYP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST create mode 100644 internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/BINDING.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/BINDING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CHARSET.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLARRAY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLCHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLRAND.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLRAND.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL create mode 100644 internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/COMMON.TEST create mode 100644 internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST create mode 100644 internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DELETE-SIDE-EFFECT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DESCRIBE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST create mode 100644 internal/test/LANGUAGE/AUTO/ERROR-RUNTIME-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/EVENP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FIXP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FLOATP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/HARRAYP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST create mode 100644 internal/test/LANGUAGE/AUTO/HASHARRAY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERPRETER-AR8538.TEST create mode 100644 internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST create mode 100644 internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/LLREAD.TEST create mode 100644 internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/NLISTP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/NUMBERP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA create mode 100644 internal/test/LANGUAGE/AUTO/PRETTY-CIRCLE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST create mode 100644 internal/test/LANGUAGE/AUTO/PROC-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/PROPERTY.TEST create mode 100644 internal/test/LANGUAGE/AUTO/REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST create mode 100644 internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST create mode 100644 internal/test/LANGUAGE/AUTO/SMALLP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/SPECIALS.TEST create mode 100644 internal/test/LANGUAGE/AUTO/STACK.TEST create mode 100644 internal/test/LANGUAGE/AUTO/STRING.TEST create mode 100644 internal/test/LANGUAGE/AUTO/STRING.TESTS create mode 100644 internal/test/LANGUAGE/AUTO/STRINGP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST create mode 100644 internal/test/LANGUAGE/AUTO/STRUCTURE-PRINT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST create mode 100644 internal/test/LANGUAGE/AUTO/TYPENAME.TEST create mode 100644 internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST create mode 100644 internal/test/LANGUAGE/AUTO/USERDEF.TEST create mode 100644 internal/test/LANGUAGE/AUTO/VECTOR.TEST create mode 100644 internal/test/LANGUAGE/AUTO/WRAPPERS-AR7900.TEST create mode 100644 internal/test/LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/XCL-COMPILER-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/XCLC-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/AUTO/Y create mode 100644 internal/test/LANGUAGE/AUTO/test-results create mode 100644 internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U create mode 100644 internal/test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U create mode 100644 internal/test/LANGUAGE/Hand/25-3-STEP.U create mode 100644 internal/test/LANGUAGE/Hand/25-3-TRACE.U create mode 100644 internal/test/LANGUAGE/Hand/25-3-UNTRACE.U create mode 100644 internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG create mode 100644 internal/test/LANGUAGE/LOGS/31-AUG-88.1109 create mode 100644 internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE create mode 100644 internal/test/LANGUAGE/from-sun/README create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-1-GET-PROPERTIES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-1-GET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-1-GETF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-1-REMF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-1-REMPROP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-1-SYMBOL-PLIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-2-SYMBOL-NAME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-3-COPY-SYMBOL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-3-GENSYM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-3-GENTEMP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-3-KEYWORDP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-3-MAKE-SYMBOL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/10/10-3-SYMBOL-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-6-IMPORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-DO-ALL-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-DO-EXTERNAL-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-DO-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-EXPORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-ALL-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-SYMBOL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-IMPORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-IN-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-INTERN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-LIST-ALL-PACKAGES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-MAKE-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NAME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NICKNAMES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USE-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USED-BY-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-RENAME-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOW.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOWING-IMPORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-UNEXPORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-UNINTERN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-UNUSE-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-7-USE-PACKAGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/11/11-8-PROVIDE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-10-IMPLEMENTATION-PARAMETERS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TXT create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-EQP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-GEQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-LEQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-LESSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-MAX.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-MIN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONDECREASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONINCREASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-3-NEQP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-1+.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-1-.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-CONJUGATE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-DECF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-GCD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-INCF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-LCM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-QUOTIENT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-4-TIMES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXPT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-1-ISQRT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-1-LOG.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-1-SQRT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ABS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOSH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASIN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASINH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATAN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATANH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-CIS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-COS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-COSH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-PHASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIGNUM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-SINH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-TAN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-5-2-TANH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-CEILING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-COMPLEX.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-DECODE-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-DENOMINATOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FCEILING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FFLOOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-DIGITS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-PRECISION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-RADIX.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-SIGN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FLOOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FROUND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-FTRUNCATE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-IMAGPART.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-INTEGER-DECODE-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-MOD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-NUMERATOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONALIZE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-REALPART.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-REM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-ROUND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-SCALE-FLOAT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-6-TRUNCATE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-ASH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-BOOLE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-INTEGER-LENGTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGAND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC2.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGBITP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGCOUNT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGEQV.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGIOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNAND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC2.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGTEST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-7-LOGXOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-POSITION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-SIZE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-DEPOSIT-FIELD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-DPB.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-LDB-TEST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-LDB.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-8-MASK-FIELD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-9-MAKE-RANDOM-STATE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM-STATE-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-1-CHARACTERATTRIBUTES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHA-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHANUMERIC-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-BOTH-CASE-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LESSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-LESSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHAREQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-CHARNEQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-DIGIT-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-GRAPHIC-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-LOWER-CASE-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-STANDARD-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-STRING-CHAR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-2-UPPER-CASE-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-BITS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-CODE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-FONT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-3-CODE-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-3-MAKE-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-DOWNCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-INT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-NAME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-UPCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-DIGIT-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-INT-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-4-NAME-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-5-CHAR-BIT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/13/13-5-SET-CHAR-BIT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-COPY-SEQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-ELT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-LENGTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-MAKE-SEQUENCE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-NREVERSE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-REVERSE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-1-SUBSEQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-CONCATENATE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-EVERY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-MAP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-NOTANY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-NOTEVERY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-REDUCE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-2-SOME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-DUPLICATES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-FILL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-FIND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-DUPLICATES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-REPLACE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-4-MISMATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-5-MERGE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-5-SORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/14/14-5-STABLE-SORT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAAADR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAADAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAADDR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAADR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAAR.TEST% create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADAA.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADADR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADDAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADDDR-AND-FOURTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADDR-AND-THIRD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CADR-AND-SECOND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CAR-AND-FIRST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDAADR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDADAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDADDR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDADR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDADR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDDR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDDR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CDR-AND-REST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-CONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-1-TREE-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-APPEND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-BUTLAST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-ALIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-TREE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-EIGHTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-ENDP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-FIFTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-FIRST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-FOURTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-LAST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-LDIFF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-LIST-LENGTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST% create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-MAKE-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-NBUTLAST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-NCONC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-NINTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-NRECONC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-NTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-NTHCDR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-POP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-PUSH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-PUSHNEW.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-REST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-REVAPPEND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-SECOND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-SEVENTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-SIXTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-TENTH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-2-THIRD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACA.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBLIS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-SUBLIS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-ADJOIN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-INTERSECTION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-NINTERSECTION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-DIFFERENCE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-EXCLUSIVE-OR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-NUNION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-SET-DIFFERENCE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-SET-EXCLUSIVE-OR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-SUBSETP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-TAILP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-5-UNION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-ACONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-PAIRLIS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-CLRHASH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-GETHASH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-COUNT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-MAKE-HASH-TABLE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-MAPHASH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-1-REMHASH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/16/16-2-SXHASH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-1-MAKE-ARRAY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-1-VECTOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-2-AREF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-2-SVREF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ADJUSTABLE-ARRAY-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSIONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ELEMENT-TYPE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-IN-BOUNDS-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-RANK.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ROW-MAJOR-INDEX.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-TOTAL-SIZE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-AND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC2.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-EQV.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-IOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NAND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC2.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-XOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-BIT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-4-SBIT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-5-ARRAY-HAS-FILL-POINTER-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-5-FILL-POINTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-POP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH-EXTEND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/17/17-6-ADJUST-ARRAY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-1-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-1-SCHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LESSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NEQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-GREATERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-LESSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-MAKE-STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-CAPITALIZE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-DOWNCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-UPCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-CAPITALIZE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-DOWNCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-LEFT-TRIM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-RIGHT-TRIM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-TRIM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-UPCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/18/18-3-STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/20/20-1-APPLYHOOK.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/20/20-1-CONSTANTP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/20/20-1-EVAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-COPY-READTABLE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-READTABLEP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-MACRO-CHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-SYNTAX-FROM-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-LISTEN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-PARSE-INTEGER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-PEEK-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR-NO-HANG.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-DELIMITED-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-FROM-STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-PRESERVING-WHITESPACE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-2-1-UNREAD-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-FINISH-OUTPUT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-FRESH-LINE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-PPRINT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1-TO-STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC-TO-STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-TERPRI.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-CHAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-LINE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/22/22-3-3-FORMAT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/23/.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-MAKE-PATHNAME.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-MERGE-PATHNAME.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-NAMESTRING.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PARSE-NAMESTRING.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DEVICE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DIRECTORY.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-HOST.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-NAME.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-TYPE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-VERSION.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAMEP.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-TRUENAME.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-1-2-USER-HOMEDIR-PATHNAME.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-2-OPEN.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-2-WITH-OPEN-FILE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-DELETE-FILE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-AUTHOR.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-LENGTH.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-POSITION.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-WRITE-DATE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-PROBE-FILE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-3-RENAME-FILE.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-4-LOAD.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-5-DIRECTORY.X create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS create mode 100644 internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-1-BREAK.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-1-CERROR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-1-CHECK-TYPE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-1-ERROR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-1-WARN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-2-ASSERT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-3-CCASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-3-CTYPECASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-3-ECASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-3-ETYPECASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE-FILE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-1-DISASSEMBLE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-2-DOCUMENTATION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS-LIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-DESCRIBE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-ED.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-INSPECT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-ROOM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-3-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-DECODE-UNIVERSAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-ENCODE-UNIVERSAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-GET-DECODED-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-REAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-RUN-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-GET-UNIVERSAL-TIME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-LISP-IMPLEMENTATION-VERSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-LONG-SITE-NAME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-INSTANCE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-TYPE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-VERSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-SHORT-SITE-NAME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-SLEEP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-TYPE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-VERSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/25/25-5-IDENTITY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/4/4-7-DEFTYPE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/4/4-8-COERCE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/4/4-9-TYPE-OF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-EXPRESSIONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-LIST-KEYWORDS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-3-1-DEFUN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFCONSTANT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFPARAMETER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFVAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/5/5-3-3-EVAL-WHEN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-1-SUBTYPEP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-1-TYPEP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-ARRAYP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-ATOM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-BIT-VECTOR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-CHARACTERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMMONP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPILED-FUNCTION-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPLEXP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-CONSP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-FLOATP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-FUNCTIONP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-INTEGERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-LISTP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-NULL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-NUMBERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-PACKAGEP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-RATIONALP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-SIMPLE-BIT-VECTOR-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-STRINGP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-SYMBOLP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-2-2-VECTORP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-3-EQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-3-EQL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-3-EQUAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-3-EQUALP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-4-AND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-4-NOT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/6/6-4-OR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-BOUNDP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-FBOUNDP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-FUNCTION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-QUOTE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-SPECIAL-FORM-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-FUNCTION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-VALUE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-2-FMAKUNBOUND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-2-MAKUNBOUND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-2-PSETQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-2-SET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-1-2-SETQ.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-10-CATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-10-THROW.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-10-UNWIND-PROTECT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-MODIFY-MACRO.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-SETF-METHOD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-DEFSETF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-PSETF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-ROTATEF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-SETF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-2-SHIFTF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-3-APPLY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-3-CALL-ARGUMENTS-LIMIT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-3-FUNCALL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-4-PROG1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-4-PROG2.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-4-PROGN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-COMPILER-LET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-FLET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-LABELS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-LET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-LETSTAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-MACROLET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-5-PROGV.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-6-CASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-6-COND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-6-IF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-6-TYPECASE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-6-UNLESS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-6-WHEN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-7-BLOCK.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN-FROM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-1-LOOP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-2-DO.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-2-DOSTAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOLIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOTIMES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAN.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCON.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPLIST.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPPER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-5-GO.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROG.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROGSTAR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-8-5-TAGBODY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-2.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-MISC-SITUATIONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/7/7-9-MULTIPLE-VALUES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/8/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/8/8-1-PARSE-BODY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/8/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/8/8-MACRO-ARG-EVAL-ORDER.PRETEST create mode 100644 internal/test/LANGUAGE/from-sun/language/9/9-1-DECLARE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/9/9-1-LOCALLY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/9/9-1-PROCLAIM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/9/9-3-THE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/DO-TEST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/README create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR6247.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR6273.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR7475.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR7525.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR7587-DOC.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR7647.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8190.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8207.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8297.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8301.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8319.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/BIGNUM-PATCH-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/BINDING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CL-INTERPRETER-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLFILESYS-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLPROGV-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLRAND.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-ADDITIONAL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DELETE-SIDE-EFFECT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DESCRIBE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DOUBLE-OP-ARITH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/ERROR-RUNTIME-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/EVENP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/FP-PRINT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/HARRAYP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/HASHARRAY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ARGUMENT-FUNCTIONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-AR7398.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-ATOM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERLISP-RECORDS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER-TEST.DATA create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PRETTY-CIRCLE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PRINTING-MINUS0.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PROC-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/SIMPLE-SUPPLIED-P.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/SINGLE-OP-ARITH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/SINGLE-VALUE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/STACK.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/STRING.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS create mode 100644 internal/test/LANGUAGE/from-sun/language/other/STRINGP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/STRUCTURE-PRINT-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/TYPENAME.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/VECTOR.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/WRAPPERS-AR7900.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/XCL-COMPILER-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/XCLC-REGRESSION.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/other/ZZZ-25-3-DRIBBLE.TEST create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET-PROPERTIES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GETF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMPROP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-SYMBOL-PLIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-2-SYMBOL-NAME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-COPY-SYMBOL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENSYM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENTEMP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-KEYWORDP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-MAKE-SYMBOL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-SYMBOL-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-6-IMPORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-ALL-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-EXTERNAL-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-EXPORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-ALL-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-SYMBOL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IMPORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IN-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-INTERN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-LIST-ALL-PACKAGES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-MAKE-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NAME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NICKNAMES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USE-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USED-BY-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-RENAME-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOW.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOWING-IMPORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNEXPORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNINTERN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNUSE-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-USE-PACKAGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/11-8-PROVIDE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-10-IMPLEMENTATION-PARAMETERS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-EVENP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-MINUSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ODDP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-PLUSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ZEROP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-EQP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GEQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LEQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MAX.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MIN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-NEQP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-+.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4--.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1+.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1-.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-CONJUGATE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-DECF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-GCD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-INCF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-LCM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-QUOTIENT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-TIMES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXPT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-ISQRT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-LOG.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-SQRT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ABS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOSH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASIN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASINH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATAN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATANH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-CIS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COSH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-PHASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIGNUM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SINH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TAN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TANH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-CEILING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-COMPLEX.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DECODE-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DENOMINATOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FCEILING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FFLOOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-DIGITS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-PRECISION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-RADIX.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-SIGN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FROUND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FTRUNCATE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-IMAGPART.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-INTEGER-DECODE-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-MOD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-NUMERATOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONALIZE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REALPART.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-ROUND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-SCALE-FLOAT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-TRUNCATE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-ASH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-BOOLE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-INTEGER-LENGTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGAND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC2.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGBITP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGCOUNT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGEQV.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGIOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNAND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC2.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGTEST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGXOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-POSITION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-SIZE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DEPOSIT-FIELD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DPB.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB-TEST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-MASK-FIELD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-MAKE-RANDOM-STATE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-RANDOM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-1-CHARACTERATTRIBUTES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHA-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHANUMERIC-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-BOTH-CASE-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAREQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHARNEQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-DIGIT-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-GRAPHIC-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-LOWER-CASE-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STANDARD-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STRING-CHAR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-UPPER-CASE-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-BITS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-CODE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-FONT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CODE-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-MAKE-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-DOWNCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-INT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-NAME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-UPCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-DIGIT-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-INT-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-NAME-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-CHAR-BIT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-SET-CHAR-BIT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-COPY-SEQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-ELT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-LENGTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-MAKE-SEQUENCE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-NREVERSE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-REVERSE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-SUBSEQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-CONCATENATE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-EVERY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-MAP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTANY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTEVERY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-REDUCE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-SOME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-DUPLICATES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FILL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-DUPLICATES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-MISMATCH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-MERGE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-SORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-STABLE-SORT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAADR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADDR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAA.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADADR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDDR-AND-FOURTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDR-AND-THIRD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADR-AND-SECOND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAR-AND-FIRST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAADR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADDR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDADR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDDR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDR-AND-REST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CONS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-TREE-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-APPEND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-BUTLAST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-ALIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-TREE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-EIGHTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-ENDP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIFTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIRST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FOURTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LAST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LDIFF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST-LENGTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LISTSTAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-MAKE-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NBUTLAST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NCONC.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NINTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NRECONC.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTHCDR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-POP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSHNEW.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REVAPPEND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SECOND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SEVENTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SIXTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-TENTH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-THIRD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACA.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBLIS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBLIS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-ADJOIN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-INTERSECTION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NINTERSECTION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-DIFFERENCE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-EXCLUSIVE-OR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NUNION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SET-DIFFERENCE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SUBSETP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-TAILP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-UNION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ACONS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-PAIRLIS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-CLRHASH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-GETHASH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-COUNT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAKE-HASH-TABLE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAPHASH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-REMHASH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/16-2-SXHASH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-MAKE-ARRAY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-VECTOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-AREF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-SVREF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ADJUSTABLE-ARRAY-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSIONS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ELEMENT-TYPE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-IN-BOUNDS-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-RANK.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-TOTAL-SIZE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-AND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC2.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-EQV.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-IOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NAND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC2.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-XOR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-SBIT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-FILL-POINTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-POP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH-EXTEND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/17-6-ADJUST-ARRAY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-SCHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NEQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-GREATERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-LESSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-MAKE-STRING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-CAPITALIZE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-DOWNCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-UPCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-CAPITALIZE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-DOWNCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-LEFT-TRIM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-RIGHT-TRIM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-TRIM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-UPCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-APPLYHOOK.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-CONSTANTP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-EVAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-COPY-READTABLE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-READTABLEP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-MACRO-CHARACTER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-LISTEN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PARSE-INTEGER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PEEK-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR-NO-HANG.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-DELIMITED-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-PRESERVING-WHITESPACE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-UNREAD-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FINISH-OUTPUT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FRESH-LINE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PPRINT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1-TO-STRING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC-TO-STRING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-TERPRI.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-CHAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-LINE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-STRING.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-3-FORMAT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/23-FUNCTIONS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-BREAK.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-CERROR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-ERROR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-WARN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-2-ASSERT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CCASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CTYPECASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ECASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ETYPECASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE-FILE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-DISASSEMBLE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-2-DOCUMENTATION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS-LIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-DESCRIBE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ED.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-INSPECT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ROOM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-DECODE-UNIVERSAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-ENCODE-UNIVERSAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-DECODED-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-REAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-RUN-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-UNIVERSAL-TIME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LISP-IMPLEMENTATION-VERSION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LONG-SITE-NAME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-INSTANCE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-TYPE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-VERSION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SHORT-SITE-NAME.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SLEEP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-TYPE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-VERSION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/25-5-IDENTITY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/4-8-COERCE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/4-9-TYPE-OF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-EXPRESSIONS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-1-DEFUN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFCONSTANT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFPARAMETER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFVAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-3-EVAL-WHEN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-SUBTYPEP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-TYPEP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ARRAYP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ATOM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-BIT-VECTOR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CHARACTERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMMONP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPILED-FUNCTION-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPLEXP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CONSP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FLOATP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FUNCTIONP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-INTEGERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-LISTP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NULL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NUMBERP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-PACKAGEP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-RATIONALP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-STRING-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-VECTOR-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-STRINGP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SYMBOLP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-VECTORP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUAL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUALP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-AND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-NOT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-OR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-BOUNDP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FBOUNDP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FUNCTION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-QUOTE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SPECIAL-FORM-P.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-FUNCTION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-VALUE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-FMAKUNBOUND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-MAKUNBOUND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-PSETQ.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-SET.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-CATCH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-THROW.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-UNWIND-PROTECT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-MODIFY-MACRO.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-SETF-METHOD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFSETF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-PSETF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-ROTATEF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SETF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SHIFTF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-APPLY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-CALL-ARGUMENTS-LIMIT.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-FUNCALL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG2.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROGN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-FLET.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LET.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LETSTAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-MACROLET.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-PROGV.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-CASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-COND.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-IF.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-TYPECASE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-UNLESS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-WHEN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN-FROM.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-1-LOOP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DO.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DOSTAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOLIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOTIMES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPC.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCON.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPLIST.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPPER.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-GO.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROG.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROGSTAR.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-TAGBODY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CATCH.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-EVALUATION-APPLICATION.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-MISC-SITUATIONS.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-MULTIPLE-VALUES.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/8-1-PARSE-BODY.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/9-3-THE.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/ADDBASE-OP.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/CAR-CDRUFN.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/INIT.LISP create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/TEST-RESULTS create mode 100644 internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard create mode 100644 internal/test/LANGUAGE/from-sun/sw/do-test create mode 100644 internal/test/LANGUAGE/from-sun/sw/do-test.dfasl create mode 100644 internal/test/LANGUAGE/from-sun/sw/do-test.tedit create mode 100644 internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC create mode 100644 internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~1~ create mode 100644 internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~2~ create mode 100644 internal/test/Library/4045xlpstream/Hand/4045xlpstream.u create mode 100644 internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG create mode 100644 internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~1~ create mode 100644 internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~2~ create mode 100644 internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~3~ create mode 100644 internal/test/Library/4045xlpstream/Plans/4045XLPSTREAM.PLAN create mode 100644 internal/test/Library/Auto/AR8230.TEST create mode 100644 internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST create mode 100644 internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS create mode 100644 internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~1~ create mode 100644 internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ create mode 100644 internal/test/Library/GCHAX/Auto/GCHAX.TEST create mode 100644 internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS create mode 100644 internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ create mode 100644 internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ create mode 100644 internal/test/Library/MatMult/Auto/AR8230.TEST create mode 100644 internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST create mode 100644 internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST create mode 100644 internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST create mode 100644 internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST create mode 100644 internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST create mode 100644 internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-BY-4.TEST create mode 100644 internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST create mode 100644 internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST create mode 100644 internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST create mode 100644 internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST create mode 100644 internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST create mode 100644 internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-X.TEST create mode 100644 internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Y.TEST create mode 100644 internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Z.TEST create mode 100644 internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST create mode 100644 internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST create mode 100644 internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST create mode 100644 internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST create mode 100644 internal/test/Library/TEdit/Hand-Aux/.read-me-first create mode 100644 internal/test/Library/TEdit/Hand-Aux/.read-me-first.~1~ create mode 100644 internal/test/Library/TEdit/Hand-Aux/.read-me-first.~2~ create mode 100644 internal/test/Library/TEdit/Hand-Aux/.read-me-first.~3~ create mode 100644 internal/test/Library/TEdit/Hand-Aux/AR10063.TEdit create mode 100644 internal/test/Library/TEdit/Hand-Aux/AR8400-TEST-SAMPLE.TEDIT create mode 100644 internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT create mode 100644 internal/test/Library/TEdit/Hand-Aux/DANCER10-C0.DISPLAYFONT create mode 100644 internal/test/Library/TEdit/Hand-Aux/DANCEROBJ.LCOM create mode 100644 internal/test/Library/TEdit/Hand-Aux/Dancer12-C0.DisplayFont create mode 100644 internal/test/Library/TEdit/Hand-Aux/HEADING-KEEP-EXTRA-LINE-GRAB.TEDIT create mode 100644 internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL create mode 100644 internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL-LAFITE-TOC create mode 100644 internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG2.MAIL create mode 100644 internal/test/Library/TEdit/Hand-Aux/MASINTER-CAROL-NEWSLETTER create mode 100644 internal/test/Library/TEdit/Hand-Aux/UNDERLINE-TEST.TEDIT create mode 100644 internal/test/Library/TEdit/Hand-Aux/abbrev-sample.tedit create mode 100644 internal/test/Library/TEdit/Hand-Aux/dancer10-C0.WD create mode 100644 internal/test/Library/TEdit/Hand-Aux/dancer12-c0.wd create mode 100644 internal/test/Library/TEdit/Hand-Aux/new-page-after.tedit create mode 100644 internal/test/Library/WHERE-IS/HAND/WHERE-IS.TESTS create mode 100644 internal/test/Library/rs232/hand/TESTRECEIVE create mode 100644 internal/test/Library/rs232/hand/TESTRECEIVE.dfasl create mode 100644 internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~1~ create mode 100644 internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~2~ create mode 100644 internal/test/Library/rs232/hand/TESTRECEIVE.~1~ create mode 100644 internal/test/Library/rs232/hand/TESTRECEIVE.~2~ create mode 100644 internal/test/Library/rs232/hand/TESTSEND create mode 100644 internal/test/Library/rs232/hand/TESTSEND.dfasl create mode 100644 internal/test/Library/rs232/hand/TESTSEND.dfasl.~1~ create mode 100644 internal/test/Library/rs232/hand/TESTSEND.dfasl.~2~ create mode 100644 internal/test/Library/rs232/hand/TESTSEND.~1~ create mode 100644 internal/test/Library/rs232/hand/TESTSEND.~2~ create mode 100644 internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log create mode 100644 internal/test/Maiko/ARs/ENDLESS-PUSHES create mode 100644 internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL create mode 100644 internal/test/Maiko/ARs/optests.dfasl create mode 100644 internal/test/Maiko/ARs/optests.lisp create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL.~4~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL.~5~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.DFASL.~6~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~1~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~2~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~3~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~4~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~5~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~6~ create mode 100644 internal/test/Maiko/AUTO/OPCODES.TEST.~7~ create mode 100644 internal/test/Maiko/Aux/BBTESTS create mode 100644 internal/test/Maiko/Aux/BBTESTS.DFASL create mode 100644 internal/test/Maiko/Aux/OPTESTS.DFASL create mode 100644 internal/test/Maiko/Aux/optests.lisp create mode 100644 internal/test/Maiko/Aux/optests.lisp.~1~ create mode 100644 internal/test/Maiko/Aux/optests.lisp.~2~ create mode 100644 internal/test/Maiko/BAD-XREF create mode 100644 internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS create mode 100644 internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL create mode 100644 internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ create mode 100644 internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ create mode 100644 internal/test/Maiko/OBSOLETE/AREF-TESTER create mode 100644 internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL create mode 100644 internal/test/Maiko/OBSOLETE/ARRAY-TESTER create mode 100644 internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL create mode 100644 internal/test/Maiko/OBSOLETE/ARRAY-TESTER.TEST create mode 100644 internal/test/Maiko/OBSOLETE/FLOAT-TESTER create mode 100644 internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL create mode 100644 internal/test/Maiko/OBSOLETE/FLOAT-TESTER.TEST create mode 100644 internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS create mode 100644 internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL create mode 100644 internal/test/Maiko/OBSOLETE/TESTER create mode 100644 internal/test/Maiko/OBSOLETE/TESTER.DFASL create mode 100644 internal/test/Maiko/OBSOLETE/unwindtest create mode 100644 internal/test/Maiko/OBSOLETE/unwindtest.dfasl create mode 100644 internal/test/Maiko/OBSOLETE/unwindtest.lcom create mode 100644 internal/test/Maiko/OBSOLETE/xclopcodetests create mode 100644 internal/test/Maiko/OBSOLETE/xclopcodetests.lcom create mode 100644 internal/test/Maiko/STACKHAX create mode 100644 internal/test/Maiko/STACKHAX.LCOM create mode 100644 internal/test/Maiko/STACKHAX.LCOM.~1~ create mode 100644 internal/test/Maiko/STACKHAX.LCOM.~2~ create mode 100644 internal/test/Maiko/STACKHAX.LCOM.~3~ create mode 100644 internal/test/Maiko/STACKHAX.LCOM.~4~ create mode 100644 internal/test/Maiko/STACKHAX.~1~ create mode 100644 internal/test/Maiko/STACKHAX.~2~ create mode 100644 internal/test/Maiko/STACKHAX.~3~ create mode 100644 internal/test/Maiko/STACKHAX.~4~ create mode 100644 internal/test/Maiko/STACKTAKESHI create mode 100644 internal/test/Maiko/STACKTAKESHI.LCOM create mode 100644 internal/test/Maiko/display.cl create mode 100644 internal/test/TEST-RESULTS create mode 100644 internal/test/Tools/AUTOTEST create mode 100644 internal/test/Tools/AUTOTEST.LCOM create mode 100644 internal/test/Tools/AUTOTEST.TEDIT create mode 100644 internal/test/Tools/DO-TEST create mode 100644 internal/test/Tools/DO-TEST-MENU create mode 100644 internal/test/Tools/DO-TEST-MENU.dfasl create mode 100644 internal/test/Tools/DO-TEST-MENU.dfasl.~1~ create mode 100644 internal/test/Tools/DO-TEST-MENU.dfasl.~2~ create mode 100644 internal/test/Tools/DO-TEST.LCOM create mode 100644 internal/test/Tools/DO-TEST.dfasl create mode 100644 internal/test/Tools/DO-TEST.dfasl.~1~ create mode 100644 internal/test/Tools/DO-TEST.dfasl.~2~ create mode 100644 internal/test/Tools/FDEVTEST create mode 100644 internal/test/Tools/FDEVTEST.LCOM create mode 100644 internal/test/Tools/FILEBANGER create mode 100644 internal/test/Tools/LOCK-FILE create mode 100644 internal/test/Tools/NEXTID create mode 100644 internal/test/Tools/RANDOM-GENERATOR create mode 100644 internal/test/Tools/RANDOM-GENERATOR.LCOM create mode 100644 internal/test/Tools/TEST-ARITHMETIC-UTILS create mode 100644 internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM create mode 100644 internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ create mode 100644 internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ create mode 100644 internal/test/Tools/TEST-DISPLAY-UTILS create mode 100644 internal/test/Tools/TEST-DISPLAY-UTILS.LCOM create mode 100644 internal/test/Tools/TEST-FILING-UTILS create mode 100644 internal/test/Tools/TEST-FILING-UTILS.LCOM create mode 100644 internal/test/Tools/TEST-REMOTE-EVAL create mode 100644 internal/test/Tools/TEST-REMOTE-EVAL.LCOM create mode 100644 internal/test/Tools/TESTER create mode 100644 internal/test/Tools/TESTER.LCOM create mode 100644 internal/test/Tools/TESTER.TEDIT create mode 100644 internal/test/Tools/TESTERLOADER create mode 100644 internal/test/Tools/TESTERLOADER.LCOM create mode 100644 internal/test/Tools/TESTERVARS create mode 100644 internal/test/Tools/TESTERVARS.DFASL create mode 100644 internal/test/Tools/TESTUSERS.TEDIT create mode 100644 internal/test/Tools/TestExec create mode 100644 internal/test/Tools/TestExec.LCOM create mode 100644 internal/test/Tools/TestExec.TEdit create mode 100644 internal/test/Tools/TestUtils create mode 100644 internal/test/Tools/TestUtils.LCOM create mode 100644 internal/test/Tools/TestUtils.TEdit create mode 100644 internal/test/Tools/VARBROWSER create mode 100644 internal/test/Tools/VARBROWSER.LCOM create mode 100644 internal/test/Tools/sloop.lisp create mode 100644 internal/test/admin/ManualManual.tedit create mode 100644 internal/test/admin/Running-AR-Test-Cases.TEdit create mode 100644 internal/test/env/DEdit/high-level.u create mode 100644 internal/test/env/DEdit/high-level.u.~1~ create mode 100644 internal/test/env/DEdit/high-level.u.~2~ create mode 100644 internal/test/env/DEdit/report.TEdit create mode 100644 internal/test/env/Debugger/24-DEBUG.UX create mode 100644 internal/test/env/Debugger/hand/BreakWindow.u create mode 100644 internal/test/env/Debugger/hand/BreakWindow.u.~1~ create mode 100644 internal/test/env/Debugger/hand/BreakWindow.u.~2~ create mode 100644 internal/test/env/Debugger/hand/BreakWindow.u.~3~ create mode 100644 internal/test/env/Debugger/hand/debugger.u create mode 100644 internal/test/env/Debugger/hand/debugger.u.~1~ create mode 100644 internal/test/env/Debugger/hand/debugger.u.~2~ create mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log create mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ create mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ create mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ create mode 100644 internal/test/env/Debugger/logs/Report.tedit create mode 100644 internal/test/env/Debugger/logs/debugger.log create mode 100644 internal/test/env/Debugger/logs/debugger.log.~1~ create mode 100644 internal/test/env/Debugger/logs/debugger.log.~2~ create mode 100644 internal/test/env/Debugger/logs/debugger.log.~3~ create mode 100644 internal/test/env/Debugger/logs/debugger.log.~4~ create mode 100644 internal/test/env/Debugger/logs/debugger.log.~5~ create mode 100644 internal/test/env/Debugger/logs/debugger.log.~6~ create mode 100644 internal/test/env/Debugger/logs/debugger.log.~7~ create mode 100644 internal/test/env/Exec/Hand/CONN.U create mode 100644 internal/test/env/Exec/Hand/DA.U create mode 100644 internal/test/env/Exec/Hand/DA.U.~1~ create mode 100644 internal/test/env/Exec/Hand/DA.U.~2~ create mode 100644 internal/test/env/Exec/Hand/DIR.U create mode 100644 internal/test/env/Exec/Hand/FIND-EVENT.U create mode 100644 internal/test/env/Exec/Hand/FIX.U create mode 100644 internal/test/env/Exec/Hand/HELP.U create mode 100644 internal/test/env/Exec/Hand/MULTIPLE-USE.U create mode 100644 internal/test/env/Exec/Hand/NDIR.U create mode 100644 internal/test/env/Exec/Hand/PL.U create mode 100644 internal/test/env/Exec/Hand/PP.U create mode 100644 internal/test/env/Exec/Hand/REDO.U create mode 100644 internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U create mode 100644 internal/test/env/Exec/Hand/SEE.U create mode 100644 internal/test/env/Exec/Hand/TEST.REPORT create mode 100644 internal/test/env/Exec/Hand/TY.U create mode 100644 internal/test/env/Exec/Hand/TYPE.U create mode 100644 internal/test/env/Exec/Hand/USE.U create mode 100644 internal/test/env/Exec/Hand/do-events.u create mode 100644 internal/test/env/Exec/Hand/exec.log create mode 100644 internal/test/env/Exec/Hand/forget.u create mode 100644 internal/test/env/Exec/Hand/log-form create mode 100644 internal/test/env/Exec/Hand/masterscope.u create mode 100644 internal/test/env/Exec/Hand/name.u create mode 100644 internal/test/env/Exec/Hand/remember.u create mode 100644 internal/test/env/Exec/Hand/retry.u create mode 100644 internal/test/env/Exec/Hand/shh.u create mode 100644 internal/test/env/Exec/Hand/test.proc create mode 100644 internal/test/env/Exec/Hand/time.u create mode 100644 internal/test/env/Exec/Hand/undo.u create mode 100644 internal/test/env/Exec/Logs/Debugger.log create mode 100644 internal/test/env/Exec/Logs/Exec.log create mode 100644 internal/test/env/Exec/Logs/Exec.log.~1~ create mode 100644 internal/test/env/Exec/Logs/Exec.log.~2~ create mode 100644 internal/test/env/Exec/Logs/Exec.log.~3~ create mode 100644 internal/test/env/FilePkg/Hand-Aux/FORMATTINGFNS create mode 100644 internal/test/env/FilePkg/Hand/AR10062.u create mode 100644 internal/test/env/FreeMenu/Auto/FREEMENU.TEST create mode 100644 internal/test/env/Program-Support/Auto/CLISP.TEST create mode 100644 internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ create mode 100644 internal/test/env/Program-Support/hand/DWIM.REPORT create mode 100644 internal/test/env/Program-Support/hand/DWIM.U create mode 100644 internal/test/env/Program-Support/hand/dwim.log create mode 100644 internal/test/env/code-editor/hand/Command-abort.u create mode 100644 internal/test/env/code-editor/hand/Command-arglist.u create mode 100644 internal/test/env/code-editor/hand/Command-arglist.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-arglist.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-base.u create mode 100644 internal/test/env/code-editor/hand/Command-comment.u create mode 100644 internal/test/env/code-editor/hand/Command-eval.u create mode 100644 internal/test/env/code-editor/hand/Command-expand.u create mode 100644 internal/test/env/code-editor/hand/Command-extract.u create mode 100644 internal/test/env/code-editor/hand/Command-extract.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-extract.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-find.u create mode 100644 internal/test/env/code-editor/hand/Command-find.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-find.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-high.u create mode 100644 internal/test/env/code-editor/hand/Command-high.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-high.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-join.u create mode 100644 internal/test/env/code-editor/hand/Command-join.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-join.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-menu.u create mode 100644 internal/test/env/code-editor/hand/Command-menu.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-menu.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-meta-o.u create mode 100644 internal/test/env/code-editor/hand/Command-meta-o.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-meta-o.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-mutate.u create mode 100644 internal/test/env/code-editor/hand/Command-mutate.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-mutate.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-paren.u create mode 100644 internal/test/env/code-editor/hand/Command-paren.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-paren.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-substitute.u create mode 100644 internal/test/env/code-editor/hand/Command-substitute.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-substitute.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Command-undo-redo.u create mode 100644 internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Control.u create mode 100644 internal/test/env/code-editor/hand/Control.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Control.u.~2~ create mode 100644 internal/test/env/code-editor/hand/Interrupt.u create mode 100644 internal/test/env/code-editor/hand/Interrupt.u.~1~ create mode 100644 internal/test/env/code-editor/hand/Interrupt.u.~2~ create mode 100644 internal/test/env/code-editor/hand/SEdit-3-mar-88.log create mode 100644 internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ create mode 100644 internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ create mode 100644 internal/test/env/code-editor/hand/command-package.u create mode 100644 internal/test/env/code-editor/hand/command-package.u.~1~ create mode 100644 internal/test/env/code-editor/hand/command-package.u.~2~ create mode 100644 internal/test/env/code-editor/hand/command-skip-next.u create mode 100644 internal/test/env/code-editor/hand/command-skip-next.u.~1~ create mode 100644 internal/test/env/code-editor/hand/command-skip-next.u.~2~ create mode 100644 internal/test/env/code-editor/hand/report.tedit create mode 100644 internal/test/env/inspector/hand/allrec.test create mode 100644 internal/test/env/inspector/hand/inspect-allrec.tedit create mode 100644 internal/test/env/inspector/hand/inspect-code.tedit create mode 100644 internal/test/env/inspector/hand/inspect-defstruct.tedit create mode 100644 internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ create mode 100644 internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ create mode 100644 internal/test/env/inspector/hand/inspect-macro.tedit create mode 100644 internal/test/env/inspector/hand/inspect-macro.tedit.~1~ create mode 100644 internal/test/env/inspector/hand/inspect-macro.tedit.~2~ create mode 100644 internal/test/env/inspector/hand/inspectfieldflg.tedit create mode 100644 internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ create mode 100644 internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ create mode 100644 internal/test/env/inspector/hand/inspectw.tedit create mode 100644 internal/test/env/inspector/hand/inspectw.tedit.~1~ create mode 100644 internal/test/env/inspector/hand/inspectw.tedit.~2~ create mode 100644 internal/test/env/inspector/hand/report.tedit create mode 100644 internal/test/env/inspector/hand/userdef.test create mode 100644 internal/test/env/inspector/hand/userdef.test.~1~ create mode 100644 internal/test/env/inspector/hand/userdef.test.~2~ create mode 100644 internal/test/env/inspector/logs/inspect-defstruct.log create mode 100644 internal/test/env/inspector/logs/inspect-defstruct.log.~1~ create mode 100644 internal/test/env/inspector/logs/inspect-defstruct.log.~2~ create mode 100644 internal/test/env/process-controls/LOGS/PSW.LOG create mode 100644 internal/test/env/process-controls/hand/PSW.REPORT create mode 100644 internal/test/env/process-controls/hand/PSW.U create mode 100644 internal/test/env/process-controls/hand/PSW.U.~1~ create mode 100644 internal/test/env/process-controls/hand/PSW.U.~2~ create mode 100644 internal/test/env/process-controls/hand/PSW.U.~3~ create mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U create mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ create mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ create mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ create mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ create mode 100644 internal/test/env/program-analysis/hand/BROWSER.GRAPH create mode 100644 internal/test/env/program-analysis/hand/BROWSER.REPORT create mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.REPORT create mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U create mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ create mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ create mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ create mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ create mode 100644 internal/test/env/program-analysis/hand/INSPECT.U create mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~1~ create mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~2~ create mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~3~ create mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~4~ create mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~5~ create mode 100644 internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT create mode 100644 internal/test/env/program-analysis/hand/SPY.REPORT create mode 100644 internal/test/env/program-analysis/hand/SPY.U create mode 100644 internal/test/env/program-analysis/hand/SPY.U.~1~ create mode 100644 internal/test/env/program-analysis/hand/SPY.U.~2~ create mode 100644 internal/test/env/program-analysis/hand/SPY.U.~3~ create mode 100644 internal/test/env/program-analysis/hand/browser-part1.u create mode 100644 internal/test/env/program-analysis/hand/browser-part1.u.~1~ create mode 100644 internal/test/env/program-analysis/hand/browser-part1.u.~2~ create mode 100644 internal/test/env/program-analysis/hand/browser-part1.u.~3~ create mode 100644 internal/test/env/program-analysis/hand/databasefns.data create mode 100644 internal/test/env/program-analysis/hand/databasefns.data.~1~ create mode 100644 internal/test/env/program-analysis/hand/databasefns.data.~2~ create mode 100644 internal/test/env/program-analysis/hand/inspect.report create mode 100644 internal/test/env/program-analysis/hand/masterscope.u create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~1~ create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~2~ create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~3~ create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~4~ create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~5~ create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~6~ create mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~7~ create mode 100644 internal/test/i/o/Display/Auto/CURSORTEST.SOURCE create mode 100644 internal/test/i/o/Display/Auto/CURSORTEST.TEST create mode 100644 internal/test/i/o/Display/Hand/CURSOR.PROC create mode 100644 internal/test/i/o/Display/Logs/CURSOR.LOG create mode 100644 internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC create mode 100644 internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG create mode 100644 internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC create mode 100644 internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL create mode 100644 internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/fx80driver.log create mode 100644 internal/test/i/o/Hardcopy/Hand/streamtests.u create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH create mode 100644 internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH create mode 100644 internal/test/i/o/Keyboard/Hand/ASKUSER.u create mode 100644 internal/test/i/o/Keyboard/Hand/PromptForWord.u create mode 100644 internal/test/i/o/Keyboard/Hand/ReadNumber.u create mode 100644 internal/test/i/o/Keyboard/Hand/TTYIN.u create mode 100644 internal/test/i/o/Keyboard/logs/askuser.log create mode 100644 internal/test/i/o/Keyboard/logs/keyboard.log create mode 100644 internal/test/i/o/Keyboard/logs/keyboard.log.~1~ create mode 100644 internal/test/i/o/Keyboard/logs/keyboard.log.~2~ create mode 100644 internal/test/i/o/Keyboard/logs/keyboard.log.~3~ create mode 100644 internal/test/loops/LOOPS-SETUP.TEDIT create mode 100644 internal/test/loops/LOOPS-TESTER-2-1 create mode 100644 internal/test/loops/LOOPS-TESTER-2-1.dfasl create mode 100644 internal/test/loops/LOOPS-TESTER-2-2 create mode 100644 internal/test/loops/LOOPS-TESTER-2-2.dfasl create mode 100644 internal/test/loops/LOOPS-TESTER-2-4 create mode 100644 internal/test/loops/LOOPS-TESTER-2-4.dfasl create mode 100644 internal/test/loops/LOOPS-TESTER-BASICS create mode 100644 internal/test/loops/LOOPS-TESTER-BASICS.dfasl create mode 100644 internal/test/lyric/DO-TEST create mode 100644 internal/test/lyric/DO-TEST.dfasl create mode 100644 internal/test/lyric/do-test.tedit diff --git a/internal/gabriel/00-README.txt b/internal/gabriel/00-README.txt new file mode 100644 index 00000000..4e9e80d8 --- /dev/null +++ b/internal/gabriel/00-README.txt @@ -0,0 +1,211 @@ +Running the Benchmarks +All the files for doing benchmarks were in this folder. +This file would have told you where to find the files you need, and how to run the various benchmarks.dir + +Overall directory layout: + Information Gabriel>, this file. + Procedures Gabriel>Admin> for overall procedure files, rather than specific test plans or scripts + Benchmarks Gabriel>Benchmarks> for lisp source & compiled files containing specific benchmarks + Results Gabriel>Results> for the results of benchmark runs. + Tools Gabriel>Tools> for general-purpose files like gabriel-timers. + Auxiliary Files Gabriel>Aux> for auxiliary files, e.g., the file of FLOATs that gets read in by the floating-point-read benchmark. + Interlisp Gabriel>Interlisp> for the old, Interlisp-only versions of the Gabriel benchmarks that were run before Common Lisp existed. +The directory in detail: +. +The Benchmarks you might want to run +. +Creating a Benchmark +1. Load Tools>GABRIEL-TIMERS.LCOM, which defines all the functions you'll need. +2. Use the function GABRIEL::DEFINE-TIMER (documented below) to create each benchmark. You'll be assigning the benchmark a name, and you may want to define auxiliary functions for the benchmark (e.g. for cleanup) as well. +3. To try out your benchmarks, first compile all the TIMERS definitions and auxiliary functions (I use ^C in SEdit quite nicely), then say to an Exec: + GABRIEL::RUN-BENCHMARKS((>>your b/m names here<<)) + to try them out. +4. Save all the timers and functions on a file, MAKEFILE it, and compile it. After you load the compiled file, you'll be able to run the new benchmarks wherever you loaded it. + +(GABRIEL::DEFINE-TIMER + (name + [(:SETUP single-setup-form)] + [(:AFTER-EVERY single-cleanup-form)] + [(:AFTER single-cleanup-form)] ) + "optional documentation string" + forms-to-run-for-the-benchmark ) + +Defines a benchmark named name, which will run forms-to-run-for-the-benchmark for every iteration of the benchmark. If you specify the :SETUP clause, the single form single-setup-form you supply will be run once before the first iteration of the benchmark. If you specify :AFTER, that single cleanup form will be run after the last iteration of the benchmark has been run; the :AFTER-EVERY cleanup form will be run after each iteration (including the last one). +Running Benchmarks +1. Load Tools>GABRIEL-TIMERS.LCOM, which defines all the functions you'll need. +2. Load the files that contain the benchmarks you want to run. Loading a file of benchmarks adds the names of those benchmarks to the list GABRIEL::*ALL-TIMERS*. +3. Use the function GABRIEL:RUN-BENCHMARKS, described below. + +(GABRIEL::RUN-BENCHMARKS + &OPTIONAL (BENCHMARKS GABRIEL::*ALL-TIMERS*) + (DRIBBLE-FILE (QUOTE {DSK}GABRIEL.BENCHMARKS)) + (NUMBER-OF-ITERATIONS GABRIEL::*MINIMUM-TESTS*)) + +Runs the benchmarks named in BENCHMARKS, defaulting to the list of all the benchmarks that you've loaded. The timing results are printed in the Exec window, and on the file DRIBBLE-FILE. Each test will be run NUMBER-OF-ITERATIONS times, defaulting to 2. +Running the Standard Benchmark Set +1. Load the files : + Tools>GABRIEL-TIMERS.LCOM + {ERIS}Benchmarks>GABRIEL-OTHER.dfasl + {ERIS}Benchmarks>GABRIEL-TAK.dfasl + {ERIS}Benchmarks>ARITH-BENCHMARKS.dfasl + {ERIS}Benchmarks>IO-BENCHMARKS.LCOM +2a. If you are running on an 1186, run the following functions: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>1186-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*IO-BENCHMARKS* + 'Results>Maiko>1186-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>1186-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>1186-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>1186-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>1186-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + 'Results>Maiko>1186-PAV-MISC.Results) + +2b. If you are running on a Sun, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>SUN-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MAIKO-IO-BENCHMARKS* + 'Results>Maiko>SUN-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>SUN-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>SUN-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>SUN-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>SUN-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + 'Results>Maiko>SUN-PAV-MISC.Results) +2c. If you are running on an 1108, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>1108-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MAIKO-IO-BENCHMARKS* + 'Results>Maiko>1108-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>1108-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>1108-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>1108-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>1108-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + 'Results>Maiko>1108-PAV-MISC.Results) +2d. If you are running on a Dorado, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>1132-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MAIKO-IO-BENCHMARKS* + 'Results>Maiko>1132-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>1132-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>1132-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>1132-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>1132-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + 'Results>Maiko>1132-PAV-MISC.Results) +3. Load the files: + {ERIS}Benchmarks>GABRIEL-OTHER.LCOM + {ERIS}Benchmarks>GABRIEL-TAK.LCOM + {ERIS}Benchmarks>ARITH-BENCHMARKS.LCOM +4a. If you are running on an 1186, run the following functions: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>1186-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>1186-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>1186-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>1186-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>1186-BYTE-POLY.Results) + +4b. If you are running on a Sun, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>SUN-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>SUN-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>SUN-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>SUN-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>SUN-BYTE-POLY.Results) +4c. If you are running on an 1108, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>1108-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>1108-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>1108-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>1108-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + 'Results>Maiko>1108-BYTE-POLY.Results) +4d. If you are running on a Dorado, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + 'Results>Maiko>1132-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + 'Results>Maiko>1132-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + 'Results>Maiko>1132-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + 'Results>Maiko>1132-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + +'Results>Maiko>1132-BYTE-POLY.Results) +5. SEE each of the .Results files listed above, average the run times (mentally is probably fine), and enter the results in the benchmark log. diff --git a/internal/gabriel/00-README.txt.~1~ b/internal/gabriel/00-README.txt.~1~ new file mode 100644 index 00000000..861fbc1f --- /dev/null +++ b/internal/gabriel/00-README.txt.~1~ @@ -0,0 +1,209 @@ +Running the Benchmarks +All the files for doing benchmarks are contained on {Eris}Gabriel>. This file will tell you where to find the files you need, and how to run the various benchmarks. + +Overall directory layout: + Information {Eris}Gabriel>, files named .name, e.g. Ş.read-me-firstş , this file. + Procedures {Eris}Gabriel>Admin> for overall procedure files, rather than specific test plans or scripts + Benchmarks {Eris}Gabriel>Benchmarks> for lisp source & compiled files containing specific benchmarks + Results {Eris}Gabriel>Results> for the results of benchmark runs. + Tools {Eris}Gabriel>Tools> for general-purpose files like gabriel-timers. + Auxiliary Files {Eris}Gabriel>Aux> for auxiliary files, e.g., the file of FLOATs that gets read in by the floating-point-read benchmark. + Interlisp B/Ms {Eris}Gabriel>Interlisp> for the old, Interlisp-only versions of the Gabriel benchmarks that were run before Common Lisp existed. +The directory in detail: +. +The Benchmarks you might want to run +. +Creating a Benchmark +1. Load {Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM, which defines all the functions you'll need. +2. Use the function GABRIEL::DEFINE-TIMER (documented below) to create each benchmark. You'll be assigning the benchmark a name, and you may want to define auxiliary functions for the benchmark (e.g. for cleanup) as well. +3. To try out your benchmarks, first compile all the TIMERS definitions and auxiliary functions (I use ^C in SEdit quite nicely), then say to an Exec: + GABRIEL::RUN-BENCHMARKS((>>your b/m names here<<)) + to try them out. +4. Save all the timers and functions on a file, MAKEFILE it, and compile it. After you load the compiled file, you'll be able to run the new benchmarks wherever you loaded it. + +(GABRIEL::DEFINE-TIMER + (name + [(:SETUP single-setup-form)] + [(:AFTER-EVERY single-cleanup-form)] + [(:AFTER single-cleanup-form)] ) + "optional documentation string" + forms-to-run-for-the-benchmark ) + +Defines a benchmark named name, which will run forms-to-run-for-the-benchmark for every iteration of the benchmark. If you specify the :SETUP clause, the single form single-setup-form you supply will be run once before the first iteration of the benchmark. If you specify :AFTER, that single cleanup form will be run after the last iteration of the benchmark has been run; the :AFTER-EVERY cleanup form will be run after each iteration (including the last one). +Running Benchmarks +1. Load {Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM, which defines all the functions you'll need. +2. Load the files that contain the benchmarks you want to run. Loading a file of benchmarks adds the names of those benchmarks to the list GABRIEL::*ALL-TIMERS*. +3. Use the function GABRIEL:RUN-BENCHMARKS, described below. + +(GABRIEL::RUN-BENCHMARKS + &OPTIONAL (BENCHMARKS GABRIEL::*ALL-TIMERS*) + (DRIBBLE-FILE (QUOTE {DSK}GABRIEL.BENCHMARKS)) + (NUMBER-OF-ITERATIONS GABRIEL::*MINIMUM-TESTS*)) + +Runs the benchmarks named in BENCHMARKS, defaulting to the list of all the benchmarks that you've loaded. The timing results are printed in the Exec window, and on the file DRIBBLE-FILE. Each test will be run NUMBER-OF-ITERATIONS times, defaulting to 2. +Running the Standard Benchmark Set +1. Load the files : + {Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM + {ERIS}Gabriel>Benchmarks>GABRIEL-OTHER.dfasl + {ERIS}Gabriel>Benchmarks>GABRIEL-TAK.dfasl + {ERIS}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl + {ERIS}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM +2a. If you are running on an 1186, run the following functions: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>1186-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*IO-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-PAV-MISC.Results) + +2b. If you are running on a Sun, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MAIKO-IO-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-PAV-MISC.Results) +2c. If you are running on an 1108, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>1108-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MAIKO-IO-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-PAV-MISC.Results) +2d. If you are running on a Dorado, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>1132-PAV-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MAIKO-IO-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-IO.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-PAV-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-PAV-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-PAV-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-PAV-POLY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*MISC-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-PAV-MISC.Results) +3. Load the files: + {ERIS}Gabriel>Benchmarks>GABRIEL-OTHER.LCOM + {ERIS}Gabriel>Benchmarks>GABRIEL-TAK.LCOM + {ERIS}Gabriel>Benchmarks>ARITH-BENCHMARKS.LCOM +4a. If you are running on an 1186, run the following functions: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>1186-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1186-BYTE-POLY.Results) + +4b. If you are running on a Sun, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>SUN-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>SUN-BYTE-POLY.Results) +4c. If you are running on an 1108, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>1108-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1108-BYTE-POLY.Results) +4d. If you are running on a Dorado, run the following: + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*TAK-TIMERS* + '{Eris}Gabriel>Results>Maiko>1132-BYTE-TAK.Results) + (GABRIEL::RUN-BENCHMARKS + IL:*ARITH-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-BYTE-ARITH.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*AREFY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-BYTE-AREFY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*CONSY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-BYTE-CONSY.Results) + (GABRIEL::RUN-BENCHMARKS + GABRIEL::*POLY-BENCHMARKS* + '{Eris}Gabriel>Results>Maiko>1132-BYTE-POLY.Results) +5. SEE each of the .Results files listed above, average the run times (mentally is probably fine), and enter the results in the benchmark log. 222;T $T; $T>  $0<, , ,,MODERN MODERN MODERN MODERN MODERNMODERN MODERN  ° 3%spMU”œ % hß—7ą  !  ZhŁ=      "   #497<8@rptzzxx4qusyyww6rvtzzxx7rvtzzxxJ6;@su{{y4rtzzx6su{{y7su{{yŽ'qůzş \ No newline at end of file diff --git a/internal/gabriel/Results/KOTO-DANDELION.BENCHMARKS b/internal/gabriel/Results/KOTO-DANDELION.BENCHMARKS new file mode 100644 index 00000000..d822d692 --- /dev/null +++ b/internal/gabriel/Results/KOTO-DANDELION.BENCHMARKS @@ -0,0 +1 @@ + MACHINETYPE = DANDELION MAKESYSNAME = KOTO MAKESYSDATE = 19-Nov-85 10:39:55 DATE = 20-Nov-85 23:12:11 USERNAME = PEDERSEN ************ TAK BENCHMARK ************** Starting the TAK run: (TIMEALL (TAK 18 12 6)) Elapsed Time = 1.73 seconds SWAP time = .031 seconds CPU Time = 1.7 seconds PAGEFAULTS = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 1.71 seconds CPU Time = 1.71 seconds Value = 7 TAK finished ************ STAK BENCHMARK ************** Starting the STAK run: (TIMEALL (STAK)) Elapsed Time = 4.75 seconds SWAP time = .046 seconds CPU Time = 4.71 seconds PAGEFAULTS = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 4.72 seconds CPU Time = 4.72 seconds STAK finished ************ CTAK BENCHMARK ************** Starting the CTAK run: (TIMEALL (CTAK 18 12 6)) Elapsed Time = 59.8 seconds SWAP time = .047 seconds CPU Time = 59.7 seconds PAGEFAULTS = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 59.8 seconds SWAP time = .031 seconds CPU Time = 59.7 seconds Value = 7 CTAK finished ************ TAKL BENCHMARK ************** Starting the TAKL run: (TIMEALL (TAKL 18L 12L 6L)) Elapsed Time = 14.2 seconds SWAP time = .035 seconds CPU Time = 14.2 seconds PAGEFAULTS = 3 Value = (7 6 5 4 3 2 1) Repeating the TIMEALL Elapsed Time = 14.2 seconds CPU Time = 14.2 seconds Value = (7 6 5 4 3 2 1) TAKL finished ************ TAKR BENCHMARK ************** Starting the TAKR run: (TIMEALL (TAK0 18 12 6)) Elapsed Time = 2.03 seconds SWAP time = .228 seconds CPU Time = 1.8 seconds PAGEFAULTS = 17 Value = 7 Repeating the TIMEALL Elapsed Time = 1.8 seconds CPU Time = 1.8 seconds Value = 7 TAKR finished ********* BOYER BENCHMARK *********** Initializing BOYER run: (TIMEALL (SETUP)) Elapsed Time = .735 seconds SWAP time = .69 seconds CPU Time = .045 seconds PAGEFAULTS = 23 starting BOYER run: (TIMEALL (TEST-BOYER)) Elapsed Time = 128.0 seconds SWAP time = 9.03 seconds GC time = 48.2 seconds CPU Time = 70.8 seconds PAGEFAULTS = 507 FIXP LISTP 7 226469 Repeating the TIMEALL Elapsed Time = 117.0 seconds GC time = 46.9 seconds CPU Time = 69.8 seconds PAGEFAULTS = 2 FIXP LISTP 7 226469 BOYER finished ********* BROWSE BENCHMARK *********** starting BROWSE run: (TIMEALL (BROWSE)) Elapsed Time = 421.0 seconds SWAP time = 5.15 seconds GC time = 179.0 seconds CPU Time = 237.0 seconds PAGEFAULTS = 168 LISTP 489970 Repeating the TIMEALL Elapsed Time = 430.0 seconds SWAP time = 2.27 seconds GC time = 183.0 seconds CPU Time = 245.0 seconds PAGEFAULTS = 90 LISTP 488945 BROWSE finished *********** THE DESTRUCTIVE BENCHMARK ************ Starting the DESTRUCTIVE run: (TIMEALL (DESTRUCTIVE 600 50)) Elapsed Time = 23.3 seconds GC time = 8.1 seconds CPU Time = 15.2 seconds LISTP 43105 Value = ((1 1 2) (1 1 1) (1 1 1 2) (1 1 1 1) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) Repeating the TIMEALL Elapsed Time = 22.9 seconds GC time = 7.9 seconds CPU Time = 15.0 seconds LISTP 43105 Value = ((1 1 2) (1 1 1) (1 1 1 2) (1 1 1 1) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) DESTRUCTIVE finished ************* THE TRAVERSE BENCHMAK ************ Starting the TRAVERSE initialization: (TIMEALL (INIT-TRAVERSE)) Elapsed Time = 99.9 seconds SWAP time = .089 seconds GC time = 1.78 seconds CPU Time = 98.0 seconds PAGEFAULTS = 8 LISTP NODE 36796 100 Starting the TRAVERSE run: (TIMEALL (RUN-TRAVERSE)) Elapsed Time = 162.0 seconds SWAP time = .085 seconds CPU Time = 161.0 seconds PAGEFAULTS = 2 Repeating the TIMEALL Elapsed Time = 161.0 seconds CPU Time = 161.0 seconds TRAVERSE finished ******* Derivative Benchmark ********** Starting the DERIV run: (TIMEALL (RUN-DERIV)) Elapsed Time = 85.6 seconds SWAP time = .075 seconds GC time = 53.7 seconds CPU Time = 31.9 seconds PAGEFAULTS = 2 LISTP 245000 Value = NIL Repeating the TIMEALL Elapsed Time = 87.4 seconds GC time = 54.7 seconds CPU Time = 32.8 seconds LISTP 245000 Value = NIL DERIV finished ******* Data-Driven Derivative Benchmark ********** Starting the DDERIV run: (TIMEALL (RUN-DDERIV)) Elapsed Time = 105.0 seconds SWAP time = .009 seconds GC time = 62.5 seconds CPU Time = 42.5 seconds PAGEFAULTS = 1 LISTP 260000 Value = NIL Repeating the TIMEALL Elapsed Time = 106.0 seconds GC time = 63.0 seconds CPU Time = 42.7 seconds LISTP 260000 Value = NIL DDERIV finished ******* DIVIDE BY TWO BENCHMARK ********** Starting the iterative DIV2 run: (TIMEALL (TEST1 L)) Elapsed Time = 41.1 seconds GC time = 26.6 seconds CPU Time = 14.4 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 42.4 seconds GC time = 27.7 seconds CPU Time = 14.7 seconds LISTP 120000 Starting the recursive DIV2 run: (TIMEALL (TEST2 L)) Elapsed Time = 42.7 seconds GC time = 27.5 seconds CPU Time = 15.3 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 43.5 seconds GC time = 27.7 seconds CPU Time = 15.7 seconds LISTP 120000 DIV2 finished *************** THE FFT BENCHMARK *********** Starting FFT run: (TIMEALL (FFT-BENCH)) Elapsed Time = 324.0 seconds SWAP time = 3.3 seconds GC time = 202.0 seconds CPU Time = 118.0 seconds PAGEFAULTS = 260 FLOATP 1004420 Repeating the TIMEALL Elapsed Time = 312.0 seconds SWAP time = .48 seconds GC time = 194.0 seconds CPU Time = 117.0 seconds PAGEFAULTS = 95 FLOATP 1004420 FFT finished *************** THE PUZZLE BENCHMARK *********** Starting PUZZLE run: (TIMEALL (START)) Success in 2005 trials. Elapsed Time = 62.2 seconds SWAP time = .123 seconds CPU Time = 62.1 seconds PAGEFAULTS = 6 Value = NIL Repeating the TIMEALL Success in 2005 trials. Elapsed Time = 62.1 seconds CPU Time = 62.1 seconds Value = NIL PUZZLE finished *************** THE TRIANGLE BENCHMARK *********** Starting TRIANG run: (TIMEALL (GOGOGO 22)) Elapsed Time = 1060.0 seconds SWAP time = .123 seconds GC time = .578 seconds CPU Time = 1060.0 seconds PAGEFAULTS = 13 LISTP 11626 Value = NIL Repeating the TIMEALL Elapsed Time = 1060.0 seconds GC time = .6 seconds CPU Time = 1060.0 seconds LISTP 11626 Value = NIL TRIANG finished ******************************************************************* DSK file I/O benchmarks: FPRINT and FREAD Terminal printing (to window): TPRINT ******************************************************************* Starting FPRINT: (TIMEALL (FPRINT)) Elapsed Time = 12.2 seconds SWAP time = .435 seconds GC time = .494 seconds CPU Time = 11.3 seconds PAGEFAULTS = 8 FIXP LISTP STRINGP VMEMPAGEP STREAM ETHERPACKET PageGroup FileDescriptor 127 698 45 2 1 3 49 1 \BTREEBUF 1 Repeating the TIMEALL Elapsed Time = 11.4 seconds SWAP time = .263 seconds GC time = .498 seconds CPU Time = 10.6 seconds PAGEFAULTS = 6 SWAPWRITES = 1 FIXP LISTP STRINGP VMEMPAGEP STREAM ETHERPACKET PageGroup FileDescriptor 118 657 45 1 1 3 48 1 FPRINT finished Starting the FREAD run: (TIMEALL (FREAD)) Elapsed Time = 6.18 seconds SWAP time = .19 seconds GC time = .293 seconds CPU Time = 5.69 seconds PAGEFAULTS = 2 FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 33 2514 23 1 1 37 1 Repeating the TIMEALL Elapsed Time = 5.62 seconds CPU Time = 5.62 seconds FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 33 2514 23 1 1 37 1 FREAD finished Starting the TPRINT run: (TPRINT) Elapsed Time = 28.8 seconds CPU Time = 28.8 seconds Repeating the TIMEALL Elapsed Time = 28.8 seconds CPU Time = 28.8 seconds TPRINT finished *************** THE POLYNOMIAL BENCHMARK *********** Starting POLY 2 run: (TIMEALL (BENCH 2)) Elapsed Time = .768 seconds SWAP time = .384 seconds CPU Time = .384 seconds PAGEFAULTS = 14 FIXP FLOATP LISTP BIGNUM 86 32 726 73 Value = (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0 (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 2.0 0 1.0))) Repeating the TIMEALL Elapsed Time = .382 seconds CPU Time = .382 seconds FIXP FLOATP LISTP BIGNUM 86 32 726 73 Value = (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0 (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 2.0 0 1.0))) Starting POLY 5 run: (TIMEALL (BENCH 5)) Elapsed Time = 14.1 seconds SWAP time = .15 seconds GC time = 4.2 seconds CPU Time = 9.8 seconds PAGEFAULTS = 4 FIXP FLOATP LISTP BIGNUM 1842 411 12782 1153 Value = (Z 5 1.0 4 (Y 1 5.0 0 (X 1 5.0 0 5.0)) 3 (Y 2 10.0 1 (X 1 20.0 0 20.0) 0 (X 2 10.0 1 20.0 0 10.0)) 2 (Y 3 10.0 2 (X 1 30.0 0 30.0) 1 (X 2 30.0 1 60.0 0 30.0) 0 (X 3 10.0 2 30.0 1 30.0 0 10.0)) 1 (Y 4 5.0 3 (X 1 20.0 0 20.0) 2 (X 2 30.0 1 60.0 0 30.0) 1 (X 3 20.0 2 60.0 1 60.0 0 20.0) 0 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0)) 0 (Y 5 1.0 4 (X 1 5.0 0 5.0) 3 (X 2 10.0 1 20.0 0 10.0) 2 (X 3 10.0 2 30.0 1 30.0 0 10.0) 1 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0) 0 (X 5 1.0 4 5.0 3 10.0 2 10.0 1 5.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 14.3 seconds SWAP time = .121 seconds GC time = 4.44 seconds CPU Time = 9.75 seconds PAGEFAULTS = 3 FIXP FLOATP LISTP BIGNUM 1842 411 12782 1153 Value = (Z 5 1.0 4 (Y 1 5.0 0 (X 1 5.0 0 5.0)) 3 (Y 2 10.0 1 (X 1 20.0 0 20.0) 0 (X 2 10.0 1 20.0 0 10.0)) 2 (Y 3 10.0 2 (X 1 30.0 0 30.0) 1 (X 2 30.0 1 60.0 0 30.0) 0 (X 3 10.0 2 30.0 1 30.0 0 10.0)) 1 (Y 4 5.0 3 (X 1 20.0 0 20.0) 2 (X 2 30.0 1 60.0 0 30.0) 1 (X 3 20.0 2 60.0 1 60.0 0 20.0) 0 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0)) 0 (Y 5 1.0 4 (X 1 5.0 0 5.0) 3 (X 2 10.0 1 20.0 0 10.0) 2 (X 3 10.0 2 30.0 1 30.0 0 10.0) 1 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0) 0 (X 5 1.0 4 5.0 3 10.0 2 10.0 1 5.0 0 1.0))) Starting POLY 10 run: (TIMEALL (BENCH 10)) Elapsed Time = 419.0 seconds SWAP time = .1 seconds GC time = 132.0 seconds CPU Time = 287.0 seconds PAGEFAULTS = 52 FIXP FLOATP LISTP BIGNUM 54142 5496 334320 16330 Value = (Z 10 1.0 9 (Y 1 10.0 0 (X 1 10.0 0 10.0)) 8 (Y 2 45.0 1 (X 1 90.0 0 90.0) 0 (X 2 45.0 1 90.0 0 45.0)) 7 (Y 3 120.0 2 (X 1 360.0 0 360.0) 1 (X 2 360.0 1 720.0 0 360.0) 0 (X 3 120.0 2 360.0 1 360.0 0 120.0)) 6 (Y 4 210.0 3 ( X 1 840.0 0 840.0) 2 (X 2 1260.0 1 2520.0 0 1260.0) 1 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 0 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0)) 5 (Y 5 252.0 4 (X 1 1260.0 0 1260.0) 3 (X 2 2520.0 1 5040.0 0 2520.0) 2 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 1 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 0 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0)) 4 (Y 6 210.0 5 (X 1 1260.0 0 1260.0) 4 (X 2 3150.0 1 6300.0 0 3150.0) 3 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 2 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 1 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 0 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0)) 3 (Y 7 120.0 6 (X 1 840.0 0 840.0) 5 (X 2 2520.0 1 5040.0 0 2520.0) 4 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 3 (X 4 4200.0 3 16800.0 2 25200.0 1 16800.0 0 4200.0) 2 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 1 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 0 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0)) 2 (Y 8 45.0 7 (X 1 360.0 0 360.0) 6 (X 2 1260.0 1 2520.0 0 1260.0) 5 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 4 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 3 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 2 (X 6 1260.0 5 7560.0 4 18900.0 3 25200.0 2 18900.0 1 7560.0 0 1260.0) 1 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 0 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0)) 1 (Y 9 10.0 8 (X 1 90.0 0 90.0) 7 (X 2 360.0 1 720.0 0 360.0) 6 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 5 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 4 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 3 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 2 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 1 (X 8 90.0 7 720.0 6 2520.0 5 5040.0 4 6300.0 3 5040.0 2 2520.0 1 720.0 0 90.0) 0 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0)) 0 (Y 10 1.0 9 (X 1 10.0 0 10.0) 8 (X 2 45.0 1 90.0 0 45.0) 7 (X 3 120.0 2 360.0 1 360.0 0 120.0) 6 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0) 5 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0) 4 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0) 3 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0) 2 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0) 1 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0 ) 0 (X 10 1.0 9 10.0 8 45.0 7 120.0 6 210.0 5 252.0 4 210.0 3 120.0 2 45.0 1 10.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 421.0 seconds GC time = 133.0 seconds CPU Time = 288.0 seconds PAGEFAULTS = 8 FIXP FLOATP LISTP BIGNUM 54142 5496 334320 16330 Value = (Z 10 1.0 9 (Y 1 10.0 0 (X 1 10.0 0 10.0)) 8 (Y 2 45.0 1 (X 1 90.0 0 90.0) 0 (X 2 45.0 1 90.0 0 45.0)) 7 (Y 3 120.0 2 (X 1 360.0 0 360.0) 1 (X 2 360.0 1 720.0 0 360.0) 0 (X 3 120.0 2 360.0 1 360.0 0 120.0)) 6 (Y 4 210.0 3 ( X 1 840.0 0 840.0) 2 (X 2 1260.0 1 2520.0 0 1260.0) 1 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 0 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0)) 5 (Y 5 252.0 4 (X 1 1260.0 0 1260.0) 3 (X 2 2520.0 1 5040.0 0 2520.0) 2 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 1 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 0 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0)) 4 (Y 6 210.0 5 (X 1 1260.0 0 1260.0) 4 (X 2 3150.0 1 6300.0 0 3150.0) 3 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 2 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 1 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 0 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0)) 3 (Y 7 120.0 6 (X 1 840.0 0 840.0) 5 (X 2 2520.0 1 5040.0 0 2520.0) 4 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 3 (X 4 4200.0 3 16800.0 2 25200.0 1 16800.0 0 4200.0) 2 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 1 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 0 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0)) 2 (Y 8 45.0 7 (X 1 360.0 0 360.0) 6 (X 2 1260.0 1 2520.0 0 1260.0) 5 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 4 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 3 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 2 (X 6 1260.0 5 7560.0 4 18900.0 3 25200.0 2 18900.0 1 7560.0 0 1260.0) 1 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 0 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0)) 1 (Y 9 10.0 8 (X 1 90.0 0 90.0) 7 (X 2 360.0 1 720.0 0 360.0) 6 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 5 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 4 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 3 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 2 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 1 (X 8 90.0 7 720.0 6 2520.0 5 5040.0 4 6300.0 3 5040.0 2 2520.0 1 720.0 0 90.0) 0 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0)) 0 (Y 10 1.0 9 (X 1 10.0 0 10.0) 8 (X 2 45.0 1 90.0 0 45.0) 7 (X 3 120.0 2 360.0 1 360.0 0 120.0) 6 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0) 5 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0) 4 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0) 3 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0) 2 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0) 1 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0 ) 0 (X 10 1.0 9 10.0 8 45.0 7 120.0 6 210.0 5 252.0 4 210.0 3 120.0 2 45.0 1 10.0 0 1.0))) Starting POLY 15 run: (TIMEALL (BENCH 15)) Elapsed Time = 7600.0 seconds SWAP time = .127 seconds GC time = 2420.0 seconds CPU Time = 5190.0 seconds PAGEFAULTS = 174 FIXP FLOATP LISTP BIGNUM 1041160 42596 5707723 118947 Value = (Z 15 1.0 14 (Y 1 15.0 0 (X 1 15.0 0 15.0)) 13 (Y 2 105.0 1 (X 1 210.0 0 210.0) 0 (X 2 105.0 1 210.0 0 105.0)) 12 (Y 3 455.0 2 (X 1 1365.0 0 1365.0) 1 (X 2 1365.0 1 2730.0 0 1365.0) 0 (X 3 455.0 2 1365.0 1 1365.0 0 455.0)) 11 (Y 4 1365.0 3 (X 1 5460.0 0 5460.0) 2 (X 2 8190.0 1 16380.0 0 8190.0) 1 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 0 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0)) 10 (Y 5 3003.0 4 (X 1 15015.0 0 15015.0) 3 (X 2 30030.0 1 60060.0 0 30030.0) 2 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 1 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 0 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0)) 9 (Y 6 5005.0 5 (X 1 30030.0 0 30030.0) 4 (X 2 75075.0 1 150150.0 0 75075.0) 3 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0 ) 2 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 1 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 0 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0)) 8 (Y 7 6435.0 6 (X 1 45045.0 0 45045.0) 5 (X 2 135135.0 1 270270.0 0 135135.0) 4 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 3 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 2 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 1 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 0 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0)) 7 (Y 8 6435.0 7 (X 1 51480.0 0 51480.0) 6 (X 2 180180.0 1 360360.0 0 180180.0) 5 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 4 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 3 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 2 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 1 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 0 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0)) 6 (Y 9 5005.0 8 (X 1 45045.0 0 45045.0) 7 (X 2 180180.0 1 360360.0 0 180180.0) 6 (X 3 420420.0 2 1261260.0 1 1261260.0 0 420420.0) 5 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 4 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 3 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 2 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 1 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 0 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0)) 5 (Y 10 3003.0 9 (X 1 30030.0 0 30030.0) 8 (X 2 135135.0 1 270270.0 0 135135.0) 7 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 6 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 5 (X 5 756756.0 4 3783780.0 3 7567560.0 2 7567560.0 1 3783780.0 0 756756.0) 4 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 3 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 2 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 1 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0 ) 0 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0)) 4 (Y 11 1365.0 10 (X 1 15015.0 0 15015.0) 9 (X 2 75075.0 1 150150.0 0 75075.0) 8 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 7 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 6 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 5 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 4 (X 7 450450.0 6 3153150.0 5 9459450.0 4 15765750.0 3 15765750.0 2 9459450.0 1 3153150.0 0 450450.0) 3 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 2 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 1 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 0 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0)) 3 (Y 12 455.0 11 (X 1 5460.0 0 5460.0) 10 (X 2 30030.0 1 60060.0 0 30030.0) 9 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0) 8 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 7 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 6 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 5 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 4 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 3 (X 9 100100.0 8 900900.0 7 3603600.0 6 8408400.0 5 12612600.0 4 12612600.0 3 8408400.0 2 3603600.0 1 900900.0 0 100100.0) 2 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 1 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 0 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0)) 2 (Y 13 105.0 12 (X 1 1365.0 0 1365.0) 11 (X 2 8190.0 1 16380.0 0 8190.0) 10 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 9 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 8 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 7 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 6 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 5 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 4 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 3 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 2 (X 11 8190.0 10 90090.0 9 450450.0 8 1351350.0 7 2702700.0 6 3783780.0 5 3783780.0 4 2702700.0 3 1351350.0 2 450450.0 1 90090.0 0 8190.0) 1 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 0 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0)) 1 (Y 14 15.0 13 (X 1 210.0 0 210.0) 12 (X 2 1365.0 1 2730.0 0 1365.0) 11 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 10 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 9 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 8 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 7 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 6 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 5 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0) 4 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 3 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 2 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 1 (X 13 210.0 12 2730.0 11 16380.0 10 60060.0 9 150150.0 8 270270.0 7 360360.0 6 360360.0 5 270270.0 4 150150.0 3 60060.0 2 16380.0 1 2730.0 0 210.0) 0 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0)) 0 (Y 15 1.0 14 (X 1 15.0 0 15.0) 13 (X 2 105.0 1 210.0 0 105.0) 12 (X 3 455.0 2 1365.0 1 1365.0 0 455.0) 11 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0) 10 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0) 9 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0) 8 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0) 7 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0) 6 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0) 5 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0) 4 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0) 3 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0) 2 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0) 1 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0) 0 (X 15 1.0 14 15.0 13 105.0 12 455.0 11 1365.0 10 3003.0 9 5005.0 8 6435.0 7 6435.0 6 5005.0 5 3003.0 4 1365.0 3 455.0 2 105.0 1 15.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 7650.0 seconds GC time = 2440.0 seconds CPU Time = 5210.0 seconds PAGEFAULTS = 33 FIXP FLOATP LISTP BIGNUM 1041160 42596 5707723 118947 Value = (Z 15 1.0 14 (Y 1 15.0 0 (X 1 15.0 0 15.0)) 13 (Y 2 105.0 1 (X 1 210.0 0 210.0) 0 (X 2 105.0 1 210.0 0 105.0)) 12 (Y 3 455.0 2 (X 1 1365.0 0 1365.0) 1 (X 2 1365.0 1 2730.0 0 1365.0) 0 (X 3 455.0 2 1365.0 1 1365.0 0 455.0)) 11 (Y 4 1365.0 3 (X 1 5460.0 0 5460.0) 2 (X 2 8190.0 1 16380.0 0 8190.0) 1 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 0 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0)) 10 (Y 5 3003.0 4 (X 1 15015.0 0 15015.0) 3 (X 2 30030.0 1 60060.0 0 30030.0) 2 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 1 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 0 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0)) 9 (Y 6 5005.0 5 (X 1 30030.0 0 30030.0) 4 (X 2 75075.0 1 150150.0 0 75075.0) 3 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0 ) 2 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 1 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 0 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0)) 8 (Y 7 6435.0 6 (X 1 45045.0 0 45045.0) 5 (X 2 135135.0 1 270270.0 0 135135.0) 4 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 3 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 2 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 1 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 0 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0)) 7 (Y 8 6435.0 7 (X 1 51480.0 0 51480.0) 6 (X 2 180180.0 1 360360.0 0 180180.0) 5 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 4 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 3 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 2 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 1 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 0 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0)) 6 (Y 9 5005.0 8 (X 1 45045.0 0 45045.0) 7 (X 2 180180.0 1 360360.0 0 180180.0) 6 (X 3 420420.0 2 1261260.0 1 1261260.0 0 420420.0) 5 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 4 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 3 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 2 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 1 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 0 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0)) 5 (Y 10 3003.0 9 (X 1 30030.0 0 30030.0) 8 (X 2 135135.0 1 270270.0 0 135135.0) 7 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 6 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 5 (X 5 756756.0 4 3783780.0 3 7567560.0 2 7567560.0 1 3783780.0 0 756756.0) 4 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 3 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 2 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 1 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0 ) 0 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0)) 4 (Y 11 1365.0 10 (X 1 15015.0 0 15015.0) 9 (X 2 75075.0 1 150150.0 0 75075.0) 8 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 7 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 6 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 5 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 4 (X 7 450450.0 6 3153150.0 5 9459450.0 4 15765750.0 3 15765750.0 2 9459450.0 1 3153150.0 0 450450.0) 3 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 2 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 1 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 0 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0)) 3 (Y 12 455.0 11 (X 1 5460.0 0 5460.0) 10 (X 2 30030.0 1 60060.0 0 30030.0) 9 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0) 8 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 7 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 6 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 5 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 4 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 3 (X 9 100100.0 8 900900.0 7 3603600.0 6 8408400.0 5 12612600.0 4 12612600.0 3 8408400.0 2 3603600.0 1 900900.0 0 100100.0) 2 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 1 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 0 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0)) 2 (Y 13 105.0 12 (X 1 1365.0 0 1365.0) 11 (X 2 8190.0 1 16380.0 0 8190.0) 10 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 9 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 8 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 7 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 6 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 5 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 4 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 3 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 2 (X 11 8190.0 10 90090.0 9 450450.0 8 1351350.0 7 2702700.0 6 3783780.0 5 3783780.0 4 2702700.0 3 1351350.0 2 450450.0 1 90090.0 0 8190.0) 1 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 0 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0)) 1 (Y 14 15.0 13 (X 1 210.0 0 210.0) 12 (X 2 1365.0 1 2730.0 0 1365.0) 11 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 10 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 9 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 8 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 7 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 6 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 5 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0) 4 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 3 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 2 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 1 (X 13 210.0 12 2730.0 11 16380.0 10 60060.0 9 150150.0 8 270270.0 7 360360.0 6 360360.0 5 270270.0 4 150150.0 3 60060.0 2 16380.0 1 2730.0 0 210.0) 0 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0)) 0 (Y 15 1.0 14 (X 1 15.0 0 15.0) 13 (X 2 105.0 1 210.0 0 105.0) 12 (X 3 455.0 2 1365.0 1 1365.0 0 455.0) 11 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0) 10 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0) 9 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0) 8 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0) 7 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0) 6 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0) 5 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0) 4 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0) 3 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0) 2 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0) 1 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0) 0 (X 15 1.0 14 15.0 13 105.0 12 455.0 11 1365.0 10 3003.0 9 5005.0 8 6435.0 7 6435.0 6 5005.0 5 3003.0 4 1365.0 3 455.0 2 105.0 1 15.0 0 1.0))) POLYNOMIAL finished Finished benchmarking \ No newline at end of file diff --git a/internal/gabriel/Results/KOTO-DORADO.BENCHMARKS b/internal/gabriel/Results/KOTO-DORADO.BENCHMARKS new file mode 100644 index 00000000..7cd03ce3 --- /dev/null +++ b/internal/gabriel/Results/KOTO-DORADO.BENCHMARKS @@ -0,0 +1 @@ + MACHINETYPE = DORADO MAKESYSNAME = KOTO MAKESYSDATE = 19-Nov-85 10:39:55 DATE = 20-Nov-85 23:10:46 USERNAME = PEDERSEN ************ TAK BENCHMARK ************** Starting the TAK run: (TIMEALL (TAK 18 12 6)) Elapsed Time = .525 seconds CPU Time = .525 seconds Value = 7 Repeating the TIMEALL Elapsed Time = .525 seconds CPU Time = .525 seconds Value = 7 TAK finished ************ STAK BENCHMARK ************** Starting the STAK run: (TIMEALL (STAK)) Elapsed Time = 1.9 seconds CPU Time = 1.9 seconds Value = 7 Repeating the TIMEALL Elapsed Time = 1.9 seconds CPU Time = 1.9 seconds STAK finished ************ CTAK BENCHMARK ************** Starting the CTAK run: (TIMEALL (CTAK 18 12 6)) Elapsed Time = 18.2 seconds CPU Time = 18.2 seconds Value = 7 Repeating the TIMEALL Elapsed Time = 18.2 seconds CPU Time = 18.2 seconds Value = 7 CTAK finished ************ TAKL BENCHMARK ************** Starting the TAKL run: (TIMEALL (TAKL 18L 12L 6L)) Elapsed Time = 3.84 seconds CPU Time = 3.84 seconds Value = (7 6 5 4 3 2 1) Repeating the TIMEALL Elapsed Time = 3.84 seconds CPU Time = 3.84 seconds Value = (7 6 5 4 3 2 1) TAKL finished ************ TAKR BENCHMARK ************** Starting the TAKR run: (TIMEALL (TAK0 18 12 6)) Elapsed Time = .692 seconds CPU Time = .692 seconds Value = 7 Repeating the TIMEALL Elapsed Time = .691 seconds CPU Time = .691 seconds Value = 7 TAKR finished ********* BOYER BENCHMARK *********** Initializing BOYER run: (TIMEALL (SETUP)) Elapsed Time = .029 seconds CPU Time = .029 seconds PAGEFAULTS = 2 LISTP 224 starting BOYER run: (TIMEALL (TEST-BOYER)) Elapsed Time = 46.1 seconds GC time = 15.5 seconds CPU Time = 30.6 seconds PAGEFAULTS = 518 FIXP LISTP 4 226469 Repeating the TIMEALL Elapsed Time = 42.2 seconds GC time = 20.1 seconds CPU Time = 22.1 seconds PAGEFAULTS = 6 FIXP LISTP 4 226469 BOYER finished ********* BROWSE BENCHMARK *********** starting BROWSE run: (TIMEALL (BROWSE)) Elapsed Time = 129.0 seconds GC time = 50.1 seconds CPU Time = 78.6 seconds PAGEFAULTS = 50 LISTP 488945 Repeating the TIMEALL Elapsed Time = 130.0 seconds GC time = 51.1 seconds CPU Time = 79.3 seconds PAGEFAULTS = 49 LISTP 488945 BROWSE finished *********** THE DESTRUCTIVE BENCHMARK ************ Starting the DESTRUCTIVE run: (TIMEALL (DESTRUCTIVE 600 50)) Elapsed Time = 7.17 seconds GC time = 3.28 seconds CPU Time = 3.89 seconds LISTP 43105 Value = ((1 1 2) (1 1 1) (1 1 1 2) (1 1 1 1) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) Repeating the TIMEALL Elapsed Time = 7.12 seconds GC time = 3.24 seconds CPU Time = 3.87 seconds LISTP 43105 Value = ((1 1 2) (1 1 1) (1 1 1 2) (1 1 1 1) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) DESTRUCTIVE finished ************* THE TRAVERSE BENCHMAK ************ Starting the TRAVERSE initialization: (TIMEALL (INIT-TRAVERSE)) Elapsed Time = 23.8 seconds GC time = .684 seconds CPU Time = 23.2 seconds PAGEFAULTS = 3 LISTP NODE 36796 100 Starting the TRAVERSE run: (TIMEALL (RUN-TRAVERSE)) Elapsed Time = 59.0 seconds CPU Time = 59.0 seconds Repeating the TIMEALL Elapsed Time = 59.0 seconds CPU Time = 59.0 seconds TRAVERSE finished ******* Derivative Benchmark ********** Starting the DERIV run: (TIMEALL (RUN-DERIV)) Elapsed Time = 28.5 seconds GC time = 18.9 seconds CPU Time = 9.57 seconds LISTP 245000 Value = NIL Repeating the TIMEALL Elapsed Time = 28.9 seconds GC time = 19.2 seconds CPU Time = 9.75 seconds LISTP 245000 Value = NIL DERIV finished ******* Data-Driven Derivative Benchmark ********** Starting the DDERIV run: (TIMEALL (RUN-DDERIV)) Elapsed Time = 33.2 seconds GC time = 21.0 seconds CPU Time = 12.2 seconds LISTP 260000 Value = NIL Repeating the TIMEALL Elapsed Time = 33.3 seconds GC time = 21.1 seconds CPU Time = 12.2 seconds LISTP 260000 Value = NIL DDERIV finished ******* DIVIDE BY TWO BENCHMARK ********** Starting the iterative DIV2 run: (TIMEALL (TEST1 L)) Elapsed Time = 12.4 seconds GC time = 8.83 seconds CPU Time = 3.54 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 12.5 seconds GC time = 8.92 seconds CPU Time = 3.54 seconds LISTP 120000 Starting the recursive DIV2 run: (TIMEALL (TEST2 L)) Elapsed Time = 14.4 seconds GC time = 9.06 seconds CPU Time = 5.3 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 13.8 seconds GC time = 8.79 seconds CPU Time = 5.04 seconds LISTP 120000 DIV2 finished *************** THE FFT BENCHMARK *********** Starting FFT run: (TIMEALL (FFT-BENCH)) Elapsed Time = 258.0 seconds GC time = 65.0 seconds CPU Time = 193.0 seconds PAGEFAULTS = 28 FLOATP 1010220 Repeating the TIMEALL Elapsed Time = 257.0 seconds GC time = 65.2 seconds CPU Time = 192.0 seconds FLOATP 1010220 FFT finished *************** THE PUZZLE BENCHMARK *********** Starting PUZZLE run: (TIMEALL (START)) Success in 2005 trials. Elapsed Time = 19.8 seconds CPU Time = 19.8 seconds Value = NIL Repeating the TIMEALL Success in 2005 trials. Elapsed Time = 19.6 seconds CPU Time = 19.6 seconds Value = NIL PUZZLE finished *************** THE TRIANGLE BENCHMARK *********** Starting TRIANG run: (TIMEALL (GOGOGO 22)) Elapsed Time = 344.0 seconds GC time = .233 seconds CPU Time = 344.0 seconds PAGEFAULTS = 24 LISTP 11626 Value = NIL Repeating the TIMEALL Elapsed Time = 344.0 seconds GC time = .231 seconds CPU Time = 343.0 seconds LISTP 11626 Value = NIL TRIANG finished ******************************************************************* DSK file I/O benchmarks: FPRINT and FREAD Terminal printing (to window): TPRINT ******************************************************************* Starting FPRINT: (TIMEALL (FPRINT)) Elapsed Time = 4.93 seconds Disk i/o time = 2.62 seconds CPU Time = 2.32 seconds DISKOPS = 228 FIXP LISTP ARRAYP STRINGP VMEMPAGEP STREAM 1 193 2 6 1 1 Repeating the TIMEALL Elapsed Time = 2.75 seconds Disk i/o time = .431 seconds CPU Time = 2.32 seconds DISKOPS = 83 FIXP LISTP ARRAYP STRINGP VMEMPAGEP STREAM 1 195 2 6 1 1 FPRINT finished Starting the FREAD run: (TIMEALL (FREAD)) Elapsed Time = 1.96 seconds Disk i/o time = .423 seconds CPU Time = 1.53 seconds DISKOPS = 37 FIXP LISTP ARRAYP STRINGP VMEMPAGEP STREAM 2 2228 4 3 1 1 Repeating the TIMEALL Elapsed Time = 1.96 seconds Disk i/o time = .42 seconds CPU Time = 1.54 seconds DISKOPS = 37 FIXP LISTP ARRAYP STRINGP VMEMPAGEP STREAM 2 2228 4 3 1 1 FREAD finished Starting the TPRINT run: (TPRINT) Elapsed Time = 6.61 seconds CPU Time = 6.61 seconds Repeating the TIMEALL Elapsed Time = 6.5 seconds CPU Time = 6.5 seconds TPRINT finished *************** THE POLYNOMIAL BENCHMARK *********** Starting POLY 2 run: (TIMEALL (BENCH 2)) Elapsed Time = .121 seconds CPU Time = .121 seconds FIXP FLOATP LISTP BIGNUM 86 32 726 73 Value = (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0 (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 2.0 0 1.0))) Repeating the TIMEALL Elapsed Time = .124 seconds CPU Time = .124 seconds FIXP FLOATP LISTP BIGNUM 86 32 726 73 Value = (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0 (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 2.0 0 1.0))) Starting POLY 5 run: (TIMEALL (BENCH 5)) Elapsed Time = 4.48 seconds GC time = 1.47 seconds CPU Time = 3.01 seconds PAGEFAULTS = 2 FIXP FLOATP LISTP BIGNUM 1842 411 12782 1153 Value = (Z 5 1.0 4 (Y 1 5.0 0 (X 1 5.0 0 5.0)) 3 (Y 2 10.0 1 (X 1 20.0 0 20.0) 0 (X 2 10.0 1 20.0 0 10.0)) 2 (Y 3 10.0 2 (X 1 30.0 0 30.0) 1 (X 2 30.0 1 60.0 0 30.0) 0 (X 3 10.0 2 30.0 1 30.0 0 10.0)) 1 (Y 4 5.0 3 (X 1 20.0 0 20.0) 2 (X 2 30.0 1 60.0 0 30.0) 1 (X 3 20.0 2 60.0 1 60.0 0 20.0) 0 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0)) 0 (Y 5 1.0 4 (X 1 5.0 0 5.0) 3 (X 2 10.0 1 20.0 0 10.0) 2 (X 3 10.0 2 30.0 1 30.0 0 10.0) 1 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0) 0 (X 5 1.0 4 5.0 3 10.0 2 10.0 1 5.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 4.09 seconds GC time = 1.11 seconds CPU Time = 2.98 seconds FIXP FLOATP LISTP BIGNUM 1842 411 12782 1153 Value = (Z 5 1.0 4 (Y 1 5.0 0 (X 1 5.0 0 5.0)) 3 (Y 2 10.0 1 (X 1 20.0 0 20.0) 0 (X 2 10.0 1 20.0 0 10.0)) 2 (Y 3 10.0 2 (X 1 30.0 0 30.0) 1 (X 2 30.0 1 60.0 0 30.0) 0 (X 3 10.0 2 30.0 1 30.0 0 10.0)) 1 (Y 4 5.0 3 (X 1 20.0 0 20.0) 2 (X 2 30.0 1 60.0 0 30.0) 1 (X 3 20.0 2 60.0 1 60.0 0 20.0) 0 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0)) 0 (Y 5 1.0 4 (X 1 5.0 0 5.0) 3 (X 2 10.0 1 20.0 0 10.0) 2 (X 3 10.0 2 30.0 1 30.0 0 10.0) 1 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0) 0 (X 5 1.0 4 5.0 3 10.0 2 10.0 1 5.0 0 1.0))) Starting POLY 10 run: (TIMEALL (BENCH 10)) Elapsed Time = 126.0 seconds GC time = 40.5 seconds CPU Time = 85.9 seconds PAGEFAULTS = 48 FIXP FLOATP LISTP BIGNUM 54143 5496 334320 16330 Value = (Z 10 1.0 9 (Y 1 10.0 0 (X 1 10.0 0 10.0)) 8 (Y 2 45.0 1 (X 1 90.0 0 90.0) 0 (X 2 45.0 1 90.0 0 45.0)) 7 (Y 3 120.0 2 (X 1 360.0 0 360.0) 1 (X 2 360.0 1 720.0 0 360.0) 0 (X 3 120.0 2 360.0 1 360.0 0 120.0)) 6 (Y 4 210.0 3 ( X 1 840.0 0 840.0) 2 (X 2 1260.0 1 2520.0 0 1260.0) 1 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 0 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0)) 5 (Y 5 252.0 4 (X 1 1260.0 0 1260.0) 3 (X 2 2520.0 1 5040.0 0 2520.0) 2 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 1 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 0 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0)) 4 (Y 6 210.0 5 (X 1 1260.0 0 1260.0) 4 (X 2 3150.0 1 6300.0 0 3150.0) 3 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 2 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 1 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 0 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0)) 3 (Y 7 120.0 6 (X 1 840.0 0 840.0) 5 (X 2 2520.0 1 5040.0 0 2520.0) 4 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 3 (X 4 4200.0 3 16800.0 2 25200.0 1 16800.0 0 4200.0) 2 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 1 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 0 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0)) 2 (Y 8 45.0 7 (X 1 360.0 0 360.0) 6 (X 2 1260.0 1 2520.0 0 1260.0) 5 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 4 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 3 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 2 (X 6 1260.0 5 7560.0 4 18900.0 3 25200.0 2 18900.0 1 7560.0 0 1260.0) 1 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 0 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0)) 1 (Y 9 10.0 8 (X 1 90.0 0 90.0) 7 (X 2 360.0 1 720.0 0 360.0) 6 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 5 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 4 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 3 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 2 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 1 (X 8 90.0 7 720.0 6 2520.0 5 5040.0 4 6300.0 3 5040.0 2 2520.0 1 720.0 0 90.0) 0 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0)) 0 (Y 10 1.0 9 (X 1 10.0 0 10.0) 8 (X 2 45.0 1 90.0 0 45.0) 7 (X 3 120.0 2 360.0 1 360.0 0 120.0) 6 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0) 5 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0) 4 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0) 3 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0) 2 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0) 1 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0 ) 0 (X 10 1.0 9 10.0 8 45.0 7 120.0 6 210.0 5 252.0 4 210.0 3 120.0 2 45.0 1 10.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 127.0 seconds GC time = 40.4 seconds CPU Time = 86.3 seconds PAGEFAULTS = 6 FIXP FLOATP LISTP BIGNUM 54142 5496 334320 16330 Value = (Z 10 1.0 9 (Y 1 10.0 0 (X 1 10.0 0 10.0)) 8 (Y 2 45.0 1 (X 1 90.0 0 90.0) 0 (X 2 45.0 1 90.0 0 45.0)) 7 (Y 3 120.0 2 (X 1 360.0 0 360.0) 1 (X 2 360.0 1 720.0 0 360.0) 0 (X 3 120.0 2 360.0 1 360.0 0 120.0)) 6 (Y 4 210.0 3 ( X 1 840.0 0 840.0) 2 (X 2 1260.0 1 2520.0 0 1260.0) 1 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 0 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0)) 5 (Y 5 252.0 4 (X 1 1260.0 0 1260.0) 3 (X 2 2520.0 1 5040.0 0 2520.0) 2 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 1 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 0 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0)) 4 (Y 6 210.0 5 (X 1 1260.0 0 1260.0) 4 (X 2 3150.0 1 6300.0 0 3150.0) 3 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 2 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 1 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 0 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0)) 3 (Y 7 120.0 6 (X 1 840.0 0 840.0) 5 (X 2 2520.0 1 5040.0 0 2520.0) 4 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 3 (X 4 4200.0 3 16800.0 2 25200.0 1 16800.0 0 4200.0) 2 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 1 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 0 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0)) 2 (Y 8 45.0 7 (X 1 360.0 0 360.0) 6 (X 2 1260.0 1 2520.0 0 1260.0) 5 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 4 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 3 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 2 (X 6 1260.0 5 7560.0 4 18900.0 3 25200.0 2 18900.0 1 7560.0 0 1260.0) 1 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 0 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0)) 1 (Y 9 10.0 8 (X 1 90.0 0 90.0) 7 (X 2 360.0 1 720.0 0 360.0) 6 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 5 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 4 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 3 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 2 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 1 (X 8 90.0 7 720.0 6 2520.0 5 5040.0 4 6300.0 3 5040.0 2 2520.0 1 720.0 0 90.0) 0 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0)) 0 (Y 10 1.0 9 (X 1 10.0 0 10.0) 8 (X 2 45.0 1 90.0 0 45.0) 7 (X 3 120.0 2 360.0 1 360.0 0 120.0) 6 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0) 5 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0) 4 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0) 3 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0) 2 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0) 1 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0 ) 0 (X 10 1.0 9 10.0 8 45.0 7 120.0 6 210.0 5 252.0 4 210.0 3 120.0 2 45.0 1 10.0 0 1.0))) Starting POLY 15 run: (TIMEALL (BENCH 15)) Elapsed Time = 2240.0 seconds GC time = 713.0 seconds CPU Time = 1530.0 seconds PAGEFAULTS = 184 FIXP FLOATP LISTP BIGNUM 1041160 42596 5707723 118947 Value = (Z 15 1.0 14 (Y 1 15.0 0 (X 1 15.0 0 15.0)) 13 (Y 2 105.0 1 (X 1 210.0 0 210.0) 0 (X 2 105.0 1 210.0 0 105.0)) 12 (Y 3 455.0 2 (X 1 1365.0 0 1365.0) 1 (X 2 1365.0 1 2730.0 0 1365.0) 0 (X 3 455.0 2 1365.0 1 1365.0 0 455.0)) 11 (Y 4 1365.0 3 (X 1 5460.0 0 5460.0) 2 (X 2 8190.0 1 16380.0 0 8190.0) 1 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 0 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0)) 10 (Y 5 3003.0 4 (X 1 15015.0 0 15015.0) 3 (X 2 30030.0 1 60060.0 0 30030.0) 2 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 1 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 0 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0)) 9 (Y 6 5005.0 5 (X 1 30030.0 0 30030.0) 4 (X 2 75075.0 1 150150.0 0 75075.0) 3 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0 ) 2 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 1 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 0 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0)) 8 (Y 7 6435.0 6 (X 1 45045.0 0 45045.0) 5 (X 2 135135.0 1 270270.0 0 135135.0) 4 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 3 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 2 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 1 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 0 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0)) 7 (Y 8 6435.0 7 (X 1 51480.0 0 51480.0) 6 (X 2 180180.0 1 360360.0 0 180180.0) 5 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 4 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 3 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 2 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 1 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 0 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0)) 6 (Y 9 5005.0 8 (X 1 45045.0 0 45045.0) 7 (X 2 180180.0 1 360360.0 0 180180.0) 6 (X 3 420420.0 2 1261260.0 1 1261260.0 0 420420.0) 5 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 4 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 3 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 2 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 1 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 0 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0)) 5 (Y 10 3003.0 9 (X 1 30030.0 0 30030.0) 8 (X 2 135135.0 1 270270.0 0 135135.0) 7 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 6 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 5 (X 5 756756.0 4 3783780.0 3 7567560.0 2 7567560.0 1 3783780.0 0 756756.0) 4 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 3 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 2 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 1 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0 ) 0 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0)) 4 (Y 11 1365.0 10 (X 1 15015.0 0 15015.0) 9 (X 2 75075.0 1 150150.0 0 75075.0) 8 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 7 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 6 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 5 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 4 (X 7 450450.0 6 3153150.0 5 9459450.0 4 15765750.0 3 15765750.0 2 9459450.0 1 3153150.0 0 450450.0) 3 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 2 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 1 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 0 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0)) 3 (Y 12 455.0 11 (X 1 5460.0 0 5460.0) 10 (X 2 30030.0 1 60060.0 0 30030.0) 9 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0) 8 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 7 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 6 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 5 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 4 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 3 (X 9 100100.0 8 900900.0 7 3603600.0 6 8408400.0 5 12612600.0 4 12612600.0 3 8408400.0 2 3603600.0 1 900900.0 0 100100.0) 2 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 1 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 0 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0)) 2 (Y 13 105.0 12 (X 1 1365.0 0 1365.0) 11 (X 2 8190.0 1 16380.0 0 8190.0) 10 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 9 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 8 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 7 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 6 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 5 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 4 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 3 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 2 (X 11 8190.0 10 90090.0 9 450450.0 8 1351350.0 7 2702700.0 6 3783780.0 5 3783780.0 4 2702700.0 3 1351350.0 2 450450.0 1 90090.0 0 8190.0) 1 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 0 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0)) 1 (Y 14 15.0 13 (X 1 210.0 0 210.0) 12 (X 2 1365.0 1 2730.0 0 1365.0) 11 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 10 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 9 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 8 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 7 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 6 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 5 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0) 4 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 3 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 2 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 1 (X 13 210.0 12 2730.0 11 16380.0 10 60060.0 9 150150.0 8 270270.0 7 360360.0 6 360360.0 5 270270.0 4 150150.0 3 60060.0 2 16380.0 1 2730.0 0 210.0) 0 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0)) 0 (Y 15 1.0 14 (X 1 15.0 0 15.0) 13 (X 2 105.0 1 210.0 0 105.0) 12 (X 3 455.0 2 1365.0 1 1365.0 0 455.0) 11 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0) 10 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0) 9 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0) 8 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0) 7 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0) 6 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0) 5 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0) 4 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0) 3 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0) 2 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0) 1 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0) 0 (X 15 1.0 14 15.0 13 105.0 12 455.0 11 1365.0 10 3003.0 9 5005.0 8 6435.0 7 6435.0 6 5005.0 5 3003.0 4 1365.0 3 455.0 2 105.0 1 15.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 2240.0 seconds GC time = 713.0 seconds CPU Time = 1530.0 seconds PAGEFAULTS = 34 FIXP FLOATP LISTP BIGNUM 1041160 42596 5707723 118947 Value = (Z 15 1.0 14 (Y 1 15.0 0 (X 1 15.0 0 15.0)) 13 (Y 2 105.0 1 (X 1 210.0 0 210.0) 0 (X 2 105.0 1 210.0 0 105.0)) 12 (Y 3 455.0 2 (X 1 1365.0 0 1365.0) 1 (X 2 1365.0 1 2730.0 0 1365.0) 0 (X 3 455.0 2 1365.0 1 1365.0 0 455.0)) 11 (Y 4 1365.0 3 (X 1 5460.0 0 5460.0) 2 (X 2 8190.0 1 16380.0 0 8190.0) 1 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 0 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0)) 10 (Y 5 3003.0 4 (X 1 15015.0 0 15015.0) 3 (X 2 30030.0 1 60060.0 0 30030.0) 2 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 1 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 0 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0)) 9 (Y 6 5005.0 5 (X 1 30030.0 0 30030.0) 4 (X 2 75075.0 1 150150.0 0 75075.0) 3 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0 ) 2 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 1 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 0 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0)) 8 (Y 7 6435.0 6 (X 1 45045.0 0 45045.0) 5 (X 2 135135.0 1 270270.0 0 135135.0) 4 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 3 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 2 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 1 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 0 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0)) 7 (Y 8 6435.0 7 (X 1 51480.0 0 51480.0) 6 (X 2 180180.0 1 360360.0 0 180180.0) 5 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 4 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 3 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 2 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 1 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 0 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0)) 6 (Y 9 5005.0 8 (X 1 45045.0 0 45045.0) 7 (X 2 180180.0 1 360360.0 0 180180.0) 6 (X 3 420420.0 2 1261260.0 1 1261260.0 0 420420.0) 5 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 4 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 3 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 2 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 1 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 0 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0)) 5 (Y 10 3003.0 9 (X 1 30030.0 0 30030.0) 8 (X 2 135135.0 1 270270.0 0 135135.0) 7 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 6 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 5 (X 5 756756.0 4 3783780.0 3 7567560.0 2 7567560.0 1 3783780.0 0 756756.0) 4 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 3 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 2 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 1 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0 ) 0 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0)) 4 (Y 11 1365.0 10 (X 1 15015.0 0 15015.0) 9 (X 2 75075.0 1 150150.0 0 75075.0) 8 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 7 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 6 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 5 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 4 (X 7 450450.0 6 3153150.0 5 9459450.0 4 15765750.0 3 15765750.0 2 9459450.0 1 3153150.0 0 450450.0) 3 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 2 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 1 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 0 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0)) 3 (Y 12 455.0 11 (X 1 5460.0 0 5460.0) 10 (X 2 30030.0 1 60060.0 0 30030.0) 9 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0) 8 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 7 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 6 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 5 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 4 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 3 (X 9 100100.0 8 900900.0 7 3603600.0 6 8408400.0 5 12612600.0 4 12612600.0 3 8408400.0 2 3603600.0 1 900900.0 0 100100.0) 2 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 1 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 0 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0)) 2 (Y 13 105.0 12 (X 1 1365.0 0 1365.0) 11 (X 2 8190.0 1 16380.0 0 8190.0) 10 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 9 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 8 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 7 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 6 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 5 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 4 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 3 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 2 (X 11 8190.0 10 90090.0 9 450450.0 8 1351350.0 7 2702700.0 6 3783780.0 5 3783780.0 4 2702700.0 3 1351350.0 2 450450.0 1 90090.0 0 8190.0) 1 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 0 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0)) 1 (Y 14 15.0 13 (X 1 210.0 0 210.0) 12 (X 2 1365.0 1 2730.0 0 1365.0) 11 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 10 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 9 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 8 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 7 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 6 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 5 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0) 4 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 3 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 2 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 1 (X 13 210.0 12 2730.0 11 16380.0 10 60060.0 9 150150.0 8 270270.0 7 360360.0 6 360360.0 5 270270.0 4 150150.0 3 60060.0 2 16380.0 1 2730.0 0 210.0) 0 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0)) 0 (Y 15 1.0 14 (X 1 15.0 0 15.0) 13 (X 2 105.0 1 210.0 0 105.0) 12 (X 3 455.0 2 1365.0 1 1365.0 0 455.0) 11 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0) 10 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0) 9 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0) 8 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0) 7 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0) 6 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0) 5 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0) 4 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0) 3 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0) 2 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0) 1 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0) 0 (X 15 1.0 14 15.0 13 105.0 12 455.0 11 1365.0 10 3003.0 9 5005.0 8 6435.0 7 6435.0 6 5005.0 5 3003.0 4 1365.0 3 455.0 2 105.0 1 15.0 0 1.0))) POLYNOMIAL finished Finished benchmarking \ No newline at end of file diff --git a/internal/gabriel/Results/KOTO-DOVE.BENCHMARKS b/internal/gabriel/Results/KOTO-DOVE.BENCHMARKS new file mode 100644 index 00000000..8accc941 --- /dev/null +++ b/internal/gabriel/Results/KOTO-DOVE.BENCHMARKS @@ -0,0 +1 @@ + MACHINETYPE = DOVE MAKESYSNAME = KOTO MAKESYSDATE = 12-Nov-85 15:14:37 DATE = 17-Nov-85 15:13:52 USERNAME = PEDERSEN ************ TAK BENCHMARK ************** Starting the TAK run: (TIMEALL (TAK 18 12 6)) Elapsed Time = 1.69 seconds CPU Time = 1.69 seconds Value = 7 Repeating the TIMEALL Elapsed Time = 1.68 seconds CPU Time = 1.68 seconds Value = 7 TAK finished ************ STAK BENCHMARK ************** Starting the STAK run: (TIMEALL (STAK)) Elapsed Time = 4.36 seconds CPU Time = 4.36 seconds Value = 7 Repeating the TIMEALL Elapsed Time = 4.36 seconds CPU Time = 4.36 seconds STAK finished ************ CTAK BENCHMARK ************** Starting the CTAK run: (TIMEALL (CTAK 18 12 6)) Elapsed Time = 55.1 seconds CPU Time = 55.1 seconds Value = 7 Repeating the TIMEALL Elapsed Time = 55.1 seconds CPU Time = 55.1 seconds Value = 7 CTAK finished ************ TAKL BENCHMARK ************** Starting the TAKL run: (TIMEALL (TAKL 18L 12L 6L)) Elapsed Time = 12.6 seconds CPU Time = 12.6 seconds Value = (7 6 5 4 3 2 1) Repeating the TIMEALL Elapsed Time = 12.6 seconds CPU Time = 12.6 seconds Value = (7 6 5 4 3 2 1) TAKL finished ************ TAKR BENCHMARK ************** Starting the TAKR run: (TIMEALL (TAK0 18 12 6)) Elapsed Time = 1.77 seconds CPU Time = 1.77 seconds Value = 7 Repeating the TIMEALL Elapsed Time = 1.77 seconds CPU Time = 1.77 seconds Value = 7 TAKR finished ********* BOYER BENCHMARK *********** Initializing BOYER run: (TIMEALL (SETUP)) Elapsed Time = .203 seconds SWAP time = .111 seconds CPU Time = .092 seconds PAGEFAULTS = 5 LISTP 224 starting BOYER run: (TIMEALL (TEST-BOYER)) Elapsed Time = 106.0 seconds SWAP time = .043 seconds GC time = 37.3 seconds CPU Time = 68.7 seconds PAGEFAULTS = 557 FIXP LISTP 7 226469 Repeating the TIMEALL Elapsed Time = 100.0 seconds GC time = 36.7 seconds CPU Time = 63.4 seconds FIXP LISTP 7 226469 BOYER finished ********* BROWSE BENCHMARK *********** starting BROWSE run: (TIMEALL (BROWSE)) Elapsed Time = 343.0 seconds SWAP time = .864 seconds GC time = 132.0 seconds CPU Time = 210.0 seconds PAGEFAULTS = 80 LISTP 488945 Repeating the TIMEALL Elapsed Time = 358.0 seconds SWAP time = .5 seconds GC time = 138.0 seconds CPU Time = 219.0 seconds PAGEFAULTS = 69 LISTP 488945 BROWSE finished *********** THE DESTRUCTIVE BENCHMARK ************ Starting the DESTRUCTIVE run: (TIMEALL (DESTRUCTIVE 600 50)) Elapsed Time = 18.9 seconds GC time = 6.02 seconds CPU Time = 12.8 seconds LISTP 43105 Value = ((1 1 2) (1 1 1) (1 1 1 2) (1 1 1 1) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) Repeating the TIMEALL Elapsed Time = 19.0 seconds GC time = 6.18 seconds CPU Time = 12.9 seconds LISTP 43105 Value = ((1 1 2) (1 1 1) (1 1 1 2) (1 1 1 1) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 2) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) DESTRUCTIVE finished ************* THE TRAVERSE BENCHMAK ************ Starting the TRAVERSE initialization: (TIMEALL (INIT-TRAVERSE)) Elapsed Time = 74.5 seconds SWAP time = .052 seconds GC time = 1.2 seconds CPU Time = 73.2 seconds PAGEFAULTS = 4 LISTP NODE 36796 100 Starting the TRAVERSE run: (TIMEALL (RUN-TRAVERSE)) Elapsed Time = 144.0 seconds CPU Time = 144.0 seconds Repeating the TIMEALL Elapsed Time = 144.0 seconds CPU Time = 144.0 seconds TRAVERSE finished ******* Derivative Benchmark ********** Starting the DERIV run: (TIMEALL (RUN-DERIV)) Elapsed Time = 61.5 seconds GC time = 39.6 seconds CPU Time = 21.9 seconds LISTP 245000 Value = NIL Repeating the TIMEALL Elapsed Time = 64.1 seconds GC time = 40.9 seconds CPU Time = 23.2 seconds LISTP 245000 Value = NIL DERIV finished ******* Data-Driven Derivative Benchmark ********** Starting the DDERIV run: (TIMEALL (RUN-DDERIV)) Elapsed Time = 81.0 seconds GC time = 48.9 seconds CPU Time = 32.1 seconds LISTP 260000 Value = NIL Repeating the TIMEALL Elapsed Time = 80.0 seconds GC time = 48.3 seconds CPU Time = 31.8 seconds LISTP 260000 Value = NIL DDERIV finished ******* DIVIDE BY TWO BENCHMARK ********** Starting the iterative DIV2 run: (TIMEALL (TEST1 L)) Elapsed Time = 30.2 seconds GC time = 20.7 seconds CPU Time = 9.51 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 30.1 seconds GC time = 20.6 seconds CPU Time = 9.54 seconds LISTP 120000 Starting the recursive DIV2 run: (TIMEALL (TEST2 L)) Elapsed Time = 33.6 seconds GC time = 20.9 seconds CPU Time = 12.7 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 33.7 seconds GC time = 21.1 seconds CPU Time = 12.6 seconds LISTP 120000 DIV2 finished *************** THE FFT BENCHMARK *********** Starting FFT run: (TIMEALL (FFT-BENCH)) Elapsed Time = 835.0 seconds SWAP time = .964 seconds GC time = 172.0 seconds CPU Time = 662.0 seconds PAGEFAULTS = 220 FLOATP 1010220 Repeating the TIMEALL Elapsed Time = 825.0 seconds SWAP time = .307 seconds GC time = 165.0 seconds CPU Time = 660.0 seconds PAGEFAULTS = 87 FLOATP 1010220 FFT finished *************** THE PUZZLE BENCHMARK *********** Starting PUZZLE run: (TIMEALL (START)) Success in 2005 trials. Elapsed Time = 114.0 seconds CPU Time = 114.0 seconds Value = NIL Repeating the TIMEALL Success in 2005 trials. Elapsed Time = 114.0 seconds CPU Time = 114.0 seconds Value = NIL PUZZLE finished *************** THE TRIANGLE BENCHMARK *********** Starting TRIANG run: (TIMEALL (GOGOGO 22)) Elapsed Time = 2160.0 seconds GC time = .417 seconds CPU Time = 2160.0 seconds PAGEFAULTS = 8 LISTP 11626 Value = NIL Repeating the TIMEALL Elapsed Time = 2170.0 seconds GC time = .435 seconds CPU Time = 2170.0 seconds LISTP 11626 Value = NIL TRIANG finished ******************************************************************* DSK file I/O benchmarks: FPRINT and FREAD Terminal printing (to window): TPRINT ******************************************************************* Starting FPRINT: (TIMEALL (FPRINT)) Elapsed Time = 9.88 seconds SWAP time = .263 seconds GC time = .342 seconds CPU Time = 9.27 seconds PAGEFAULTS = 8 FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 158 576 53 1 1 48 1 Repeating the TIMEALL Elapsed Time = 9.46 seconds GC time = .337 seconds CPU Time = 9.12 seconds FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 158 575 53 1 1 48 1 FPRINT finished Starting the FREAD run: (TIMEALL (FREAD)) Elapsed Time = 5.85 seconds GC time = .253 seconds CPU Time = 5.6 seconds FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 108 2511 27 1 1 37 1 Repeating the TIMEALL Elapsed Time = 5.85 seconds GC time = .26 seconds CPU Time = 5.59 seconds PAGEFAULTS = 2 FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 108 2511 27 1 1 37 1 FREAD finished Starting the TPRINT run: (TPRINT) Elapsed Time = 22.8 seconds CPU Time = 22.8 seconds Repeating the TIMEALL Elapsed Time = 22.8 seconds CPU Time = 22.8 seconds TPRINT finished *************** THE POLYNOMIAL BENCHMARK *********** Starting POLY 2 run: (TIMEALL (BENCH 2)) Elapsed Time = .697 seconds SWAP time = .219 seconds CPU Time = .478 seconds PAGEFAULTS = 11 FIXP FLOATP LISTP BIGNUM 86 32 726 73 Value = (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0 (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 2.0 0 1.0))) Repeating the TIMEALL Elapsed Time = .463 seconds CPU Time = .463 seconds FIXP FLOATP LISTP BIGNUM 86 32 726 73 Value = (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0 (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 2.0 0 1.0))) Starting POLY 5 run: (TIMEALL (BENCH 5)) Elapsed Time = 15.4 seconds SWAP time = .051 seconds GC time = 3.92 seconds CPU Time = 11.5 seconds PAGEFAULTS = 3 FIXP FLOATP LISTP BIGNUM 1842 411 12782 1153 Value = (Z 5 1.0 4 (Y 1 5.0 0 (X 1 5.0 0 5.0)) 3 (Y 2 10.0 1 (X 1 20.0 0 20.0) 0 (X 2 10.0 1 20.0 0 10.0)) 2 (Y 3 10.0 2 (X 1 30.0 0 30.0) 1 (X 2 30.0 1 60.0 0 30.0) 0 (X 3 10.0 2 30.0 1 30.0 0 10.0)) 1 (Y 4 5.0 3 (X 1 20.0 0 20.0) 2 (X 2 30.0 1 60.0 0 30.0) 1 (X 3 20.0 2 60.0 1 60.0 0 20.0) 0 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0)) 0 (Y 5 1.0 4 (X 1 5.0 0 5.0) 3 (X 2 10.0 1 20.0 0 10.0) 2 (X 3 10.0 2 30.0 1 30.0 0 10.0) 1 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0) 0 (X 5 1.0 4 5.0 3 10.0 2 10.0 1 5.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 15.4 seconds SWAP time = .068 seconds GC time = 3.83 seconds CPU Time = 11.5 seconds PAGEFAULTS = 2 FIXP FLOATP LISTP BIGNUM 1842 411 12782 1153 Value = (Z 5 1.0 4 (Y 1 5.0 0 (X 1 5.0 0 5.0)) 3 (Y 2 10.0 1 (X 1 20.0 0 20.0) 0 (X 2 10.0 1 20.0 0 10.0)) 2 (Y 3 10.0 2 (X 1 30.0 0 30.0) 1 (X 2 30.0 1 60.0 0 30.0) 0 (X 3 10.0 2 30.0 1 30.0 0 10.0)) 1 (Y 4 5.0 3 (X 1 20.0 0 20.0) 2 (X 2 30.0 1 60.0 0 30.0) 1 (X 3 20.0 2 60.0 1 60.0 0 20.0) 0 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0)) 0 (Y 5 1.0 4 (X 1 5.0 0 5.0) 3 (X 2 10.0 1 20.0 0 10.0) 2 (X 3 10.0 2 30.0 1 30.0 0 10.0) 1 (X 4 5.0 3 20.0 2 30.0 1 20.0 0 5.0) 0 (X 5 1.0 4 5.0 3 10.0 2 10.0 1 5.0 0 1.0))) Starting POLY 10 run: (TIMEALL (BENCH 10)) Elapsed Time = 465.0 seconds SWAP time = .056 seconds GC time = 116.0 seconds CPU Time = 349.0 seconds PAGEFAULTS = 33 FIXP FLOATP LISTP BIGNUM 54143 5496 334320 16330 Value = (Z 10 1.0 9 (Y 1 10.0 0 (X 1 10.0 0 10.0)) 8 (Y 2 45.0 1 (X 1 90.0 0 90.0) 0 (X 2 45.0 1 90.0 0 45.0)) 7 (Y 3 120.0 2 (X 1 360.0 0 360.0) 1 (X 2 360.0 1 720.0 0 360.0) 0 (X 3 120.0 2 360.0 1 360.0 0 120.0)) 6 (Y 4 210.0 3 ( X 1 840.0 0 840.0) 2 (X 2 1260.0 1 2520.0 0 1260.0) 1 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 0 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0)) 5 (Y 5 252.0 4 (X 1 1260.0 0 1260.0) 3 (X 2 2520.0 1 5040.0 0 2520.0) 2 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 1 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 0 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0)) 4 (Y 6 210.0 5 (X 1 1260.0 0 1260.0) 4 (X 2 3150.0 1 6300.0 0 3150.0) 3 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 2 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 1 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 0 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0)) 3 (Y 7 120.0 6 (X 1 840.0 0 840.0) 5 (X 2 2520.0 1 5040.0 0 2520.0) 4 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 3 (X 4 4200.0 3 16800.0 2 25200.0 1 16800.0 0 4200.0) 2 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 1 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 0 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0)) 2 (Y 8 45.0 7 (X 1 360.0 0 360.0) 6 (X 2 1260.0 1 2520.0 0 1260.0) 5 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 4 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 3 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 2 (X 6 1260.0 5 7560.0 4 18900.0 3 25200.0 2 18900.0 1 7560.0 0 1260.0) 1 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 0 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0)) 1 (Y 9 10.0 8 (X 1 90.0 0 90.0) 7 (X 2 360.0 1 720.0 0 360.0) 6 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 5 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 4 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 3 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 2 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 1 (X 8 90.0 7 720.0 6 2520.0 5 5040.0 4 6300.0 3 5040.0 2 2520.0 1 720.0 0 90.0) 0 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0)) 0 (Y 10 1.0 9 (X 1 10.0 0 10.0) 8 (X 2 45.0 1 90.0 0 45.0) 7 (X 3 120.0 2 360.0 1 360.0 0 120.0) 6 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0) 5 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0) 4 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0) 3 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0) 2 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0) 1 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0 ) 0 (X 10 1.0 9 10.0 8 45.0 7 120.0 6 210.0 5 252.0 4 210.0 3 120.0 2 45.0 1 10.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 468.0 seconds GC time = 118.0 seconds CPU Time = 350.0 seconds PAGEFAULTS = 10 FIXP FLOATP LISTP BIGNUM 54142 5496 334320 16330 Value = (Z 10 1.0 9 (Y 1 10.0 0 (X 1 10.0 0 10.0)) 8 (Y 2 45.0 1 (X 1 90.0 0 90.0) 0 (X 2 45.0 1 90.0 0 45.0)) 7 (Y 3 120.0 2 (X 1 360.0 0 360.0) 1 (X 2 360.0 1 720.0 0 360.0) 0 (X 3 120.0 2 360.0 1 360.0 0 120.0)) 6 (Y 4 210.0 3 ( X 1 840.0 0 840.0) 2 (X 2 1260.0 1 2520.0 0 1260.0) 1 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 0 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0)) 5 (Y 5 252.0 4 (X 1 1260.0 0 1260.0) 3 (X 2 2520.0 1 5040.0 0 2520.0) 2 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 1 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 0 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0)) 4 (Y 6 210.0 5 (X 1 1260.0 0 1260.0) 4 (X 2 3150.0 1 6300.0 0 3150.0) 3 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 2 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 1 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 0 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0)) 3 (Y 7 120.0 6 (X 1 840.0 0 840.0) 5 (X 2 2520.0 1 5040.0 0 2520.0) 4 (X 3 4200.0 2 12600.0 1 12600.0 0 4200.0) 3 (X 4 4200.0 3 16800.0 2 25200.0 1 16800.0 0 4200.0) 2 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 1 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 0 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0)) 2 (Y 8 45.0 7 (X 1 360.0 0 360.0) 6 (X 2 1260.0 1 2520.0 0 1260.0) 5 (X 3 2520.0 2 7560.0 1 7560.0 0 2520.0) 4 (X 4 3150.0 3 12600.0 2 18900.0 1 12600.0 0 3150.0) 3 (X 5 2520.0 4 12600.0 3 25200.0 2 25200.0 1 12600.0 0 2520.0) 2 (X 6 1260.0 5 7560.0 4 18900.0 3 25200.0 2 18900.0 1 7560.0 0 1260.0) 1 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 0 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0)) 1 (Y 9 10.0 8 (X 1 90.0 0 90.0) 7 (X 2 360.0 1 720.0 0 360.0) 6 (X 3 840.0 2 2520.0 1 2520.0 0 840.0) 5 (X 4 1260.0 3 5040.0 2 7560.0 1 5040.0 0 1260.0) 4 (X 5 1260.0 4 6300.0 3 12600.0 2 12600.0 1 6300.0 0 1260.0) 3 (X 6 840.0 5 5040.0 4 12600.0 3 16800.0 2 12600.0 1 5040.0 0 840.0) 2 (X 7 360.0 6 2520.0 5 7560.0 4 12600.0 3 12600.0 2 7560.0 1 2520.0 0 360.0) 1 (X 8 90.0 7 720.0 6 2520.0 5 5040.0 4 6300.0 3 5040.0 2 2520.0 1 720.0 0 90.0) 0 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0)) 0 (Y 10 1.0 9 (X 1 10.0 0 10.0) 8 (X 2 45.0 1 90.0 0 45.0) 7 (X 3 120.0 2 360.0 1 360.0 0 120.0) 6 (X 4 210.0 3 840.0 2 1260.0 1 840.0 0 210.0) 5 (X 5 252.0 4 1260.0 3 2520.0 2 2520.0 1 1260.0 0 252.0) 4 (X 6 210.0 5 1260.0 4 3150.0 3 4200.0 2 3150.0 1 1260.0 0 210.0) 3 (X 7 120.0 6 840.0 5 2520.0 4 4200.0 3 4200.0 2 2520.0 1 840.0 0 120.0) 2 (X 8 45.0 7 360.0 6 1260.0 5 2520.0 4 3150.0 3 2520.0 2 1260.0 1 360.0 0 45.0) 1 (X 9 10.0 8 90.0 7 360.0 6 840.0 5 1260.0 4 1260.0 3 840.0 2 360.0 1 90.0 0 10.0 ) 0 (X 10 1.0 9 10.0 8 45.0 7 120.0 6 210.0 5 252.0 4 210.0 3 120.0 2 45.0 1 10.0 0 1.0))) Starting POLY 15 run: (TIMEALL (BENCH 15)) Elapsed Time = 8480.0 seconds SWAP time = .056 seconds GC time = 2110.0 seconds CPU Time = 6380.0 seconds PAGEFAULTS = 178 FIXP FLOATP LISTP BIGNUM 1041160 42596 5707723 118947 Value = (Z 15 1.0 14 (Y 1 15.0 0 (X 1 15.0 0 15.0)) 13 (Y 2 105.0 1 (X 1 210.0 0 210.0) 0 (X 2 105.0 1 210.0 0 105.0)) 12 (Y 3 455.0 2 (X 1 1365.0 0 1365.0) 1 (X 2 1365.0 1 2730.0 0 1365.0) 0 (X 3 455.0 2 1365.0 1 1365.0 0 455.0)) 11 (Y 4 1365.0 3 (X 1 5460.0 0 5460.0) 2 (X 2 8190.0 1 16380.0 0 8190.0) 1 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 0 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0)) 10 (Y 5 3003.0 4 (X 1 15015.0 0 15015.0) 3 (X 2 30030.0 1 60060.0 0 30030.0) 2 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 1 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 0 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0)) 9 (Y 6 5005.0 5 (X 1 30030.0 0 30030.0) 4 (X 2 75075.0 1 150150.0 0 75075.0) 3 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0 ) 2 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 1 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 0 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0)) 8 (Y 7 6435.0 6 (X 1 45045.0 0 45045.0) 5 (X 2 135135.0 1 270270.0 0 135135.0) 4 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 3 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 2 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 1 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 0 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0)) 7 (Y 8 6435.0 7 (X 1 51480.0 0 51480.0) 6 (X 2 180180.0 1 360360.0 0 180180.0) 5 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 4 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 3 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 2 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 1 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 0 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0)) 6 (Y 9 5005.0 8 (X 1 45045.0 0 45045.0) 7 (X 2 180180.0 1 360360.0 0 180180.0) 6 (X 3 420420.0 2 1261260.0 1 1261260.0 0 420420.0) 5 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 4 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 3 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 2 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 1 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 0 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0)) 5 (Y 10 3003.0 9 (X 1 30030.0 0 30030.0) 8 (X 2 135135.0 1 270270.0 0 135135.0) 7 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 6 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 5 (X 5 756756.0 4 3783780.0 3 7567560.0 2 7567560.0 1 3783780.0 0 756756.0) 4 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 3 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 2 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 1 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0 ) 0 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0)) 4 (Y 11 1365.0 10 (X 1 15015.0 0 15015.0) 9 (X 2 75075.0 1 150150.0 0 75075.0) 8 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 7 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 6 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 5 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 4 (X 7 450450.0 6 3153150.0 5 9459450.0 4 15765750.0 3 15765750.0 2 9459450.0 1 3153150.0 0 450450.0) 3 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 2 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 1 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 0 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0)) 3 (Y 12 455.0 11 (X 1 5460.0 0 5460.0) 10 (X 2 30030.0 1 60060.0 0 30030.0) 9 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0) 8 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 7 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 6 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 5 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 4 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 3 (X 9 100100.0 8 900900.0 7 3603600.0 6 8408400.0 5 12612600.0 4 12612600.0 3 8408400.0 2 3603600.0 1 900900.0 0 100100.0) 2 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 1 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 0 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0)) 2 (Y 13 105.0 12 (X 1 1365.0 0 1365.0) 11 (X 2 8190.0 1 16380.0 0 8190.0) 10 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 9 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 8 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 7 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 6 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 5 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 4 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 3 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 2 (X 11 8190.0 10 90090.0 9 450450.0 8 1351350.0 7 2702700.0 6 3783780.0 5 3783780.0 4 2702700.0 3 1351350.0 2 450450.0 1 90090.0 0 8190.0) 1 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 0 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0)) 1 (Y 14 15.0 13 (X 1 210.0 0 210.0) 12 (X 2 1365.0 1 2730.0 0 1365.0) 11 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 10 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 9 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 8 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 7 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 6 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 5 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0) 4 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 3 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 2 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 1 (X 13 210.0 12 2730.0 11 16380.0 10 60060.0 9 150150.0 8 270270.0 7 360360.0 6 360360.0 5 270270.0 4 150150.0 3 60060.0 2 16380.0 1 2730.0 0 210.0) 0 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0)) 0 (Y 15 1.0 14 (X 1 15.0 0 15.0) 13 (X 2 105.0 1 210.0 0 105.0) 12 (X 3 455.0 2 1365.0 1 1365.0 0 455.0) 11 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0) 10 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0) 9 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0) 8 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0) 7 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0) 6 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0) 5 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0) 4 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0) 3 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0) 2 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0) 1 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0) 0 (X 15 1.0 14 15.0 13 105.0 12 455.0 11 1365.0 10 3003.0 9 5005.0 8 6435.0 7 6435.0 6 5005.0 5 3003.0 4 1365.0 3 455.0 2 105.0 1 15.0 0 1.0))) Repeating the TIMEALL Elapsed Time = 8490.0 seconds GC time = 2110.0 seconds CPU Time = 6380.0 seconds PAGEFAULTS = 18 FIXP FLOATP LISTP BIGNUM 1041160 42596 5707723 118947 Value = (Z 15 1.0 14 (Y 1 15.0 0 (X 1 15.0 0 15.0)) 13 (Y 2 105.0 1 (X 1 210.0 0 210.0) 0 (X 2 105.0 1 210.0 0 105.0)) 12 (Y 3 455.0 2 (X 1 1365.0 0 1365.0) 1 (X 2 1365.0 1 2730.0 0 1365.0) 0 (X 3 455.0 2 1365.0 1 1365.0 0 455.0)) 11 (Y 4 1365.0 3 (X 1 5460.0 0 5460.0) 2 (X 2 8190.0 1 16380.0 0 8190.0) 1 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 0 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0)) 10 (Y 5 3003.0 4 (X 1 15015.0 0 15015.0) 3 (X 2 30030.0 1 60060.0 0 30030.0) 2 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 1 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 0 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0)) 9 (Y 6 5005.0 5 (X 1 30030.0 0 30030.0) 4 (X 2 75075.0 1 150150.0 0 75075.0) 3 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0 ) 2 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 1 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 0 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0)) 8 (Y 7 6435.0 6 (X 1 45045.0 0 45045.0) 5 (X 2 135135.0 1 270270.0 0 135135.0) 4 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 3 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 2 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 1 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 0 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0)) 7 (Y 8 6435.0 7 (X 1 51480.0 0 51480.0) 6 (X 2 180180.0 1 360360.0 0 180180.0) 5 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 4 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 3 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 2 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 1 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 0 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0)) 6 (Y 9 5005.0 8 (X 1 45045.0 0 45045.0) 7 (X 2 180180.0 1 360360.0 0 180180.0) 6 (X 3 420420.0 2 1261260.0 1 1261260.0 0 420420.0) 5 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 4 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 3 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 2 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 1 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 0 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0)) 5 (Y 10 3003.0 9 (X 1 30030.0 0 30030.0) 8 (X 2 135135.0 1 270270.0 0 135135.0) 7 (X 3 360360.0 2 1081080.0 1 1081080.0 0 360360.0) 6 (X 4 630630.0 3 2522520.0 2 3783780.0 1 2522520.0 0 630630.0) 5 (X 5 756756.0 4 3783780.0 3 7567560.0 2 7567560.0 1 3783780.0 0 756756.0) 4 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 3 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 2 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 1 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0 ) 0 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0)) 4 (Y 11 1365.0 10 (X 1 15015.0 0 15015.0) 9 (X 2 75075.0 1 150150.0 0 75075.0) 8 (X 3 225225.0 2 675675.0 1 675675.0 0 225225.0) 7 (X 4 450450.0 3 1801800.0 2 2702700.0 1 1801800.0 0 450450.0) 6 (X 5 630630.0 4 3153150.0 3 6306300.0 2 6306300.0 1 3153150.0 0 630630.0) 5 (X 6 630630.0 5 3783780.0 4 9459450.0 3 12612600.0 2 9459450.0 1 3783780.0 0 630630.0) 4 (X 7 450450.0 6 3153150.0 5 9459450.0 4 15765750.0 3 15765750.0 2 9459450.0 1 3153150.0 0 450450.0) 3 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 2 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 1 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 0 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0)) 3 (Y 12 455.0 11 (X 1 5460.0 0 5460.0) 10 (X 2 30030.0 1 60060.0 0 30030.0) 9 (X 3 100100.0 2 300300.0 1 300300.0 0 100100.0) 8 (X 4 225225.0 3 900900.0 2 1351350.0 1 900900.0 0 225225.0) 7 (X 5 360360.0 4 1801800.0 3 3603600.0 2 3603600.0 1 1801800.0 0 360360.0) 6 (X 6 420420.0 5 2522520.0 4 6306300.0 3 8408400.0 2 6306300.0 1 2522520.0 0 420420.0) 5 (X 7 360360.0 6 2522520.0 5 7567560.0 4 12612600.0 3 12612600.0 2 7567560.0 1 2522520.0 0 360360.0) 4 (X 8 225225.0 7 1801800.0 6 6306300.0 5 12612600.0 4 15765750.0 3 12612600.0 2 6306300.0 1 1801800.0 0 225225.0) 3 (X 9 100100.0 8 900900.0 7 3603600.0 6 8408400.0 5 12612600.0 4 12612600.0 3 8408400.0 2 3603600.0 1 900900.0 0 100100.0) 2 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 1 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 0 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0)) 2 (Y 13 105.0 12 (X 1 1365.0 0 1365.0) 11 (X 2 8190.0 1 16380.0 0 8190.0) 10 (X 3 30030.0 2 90090.0 1 90090.0 0 30030.0) 9 (X 4 75075.0 3 300300.0 2 450450.0 1 300300.0 0 75075.0) 8 (X 5 135135.0 4 675675.0 3 1351350.0 2 1351350.0 1 675675.0 0 135135.0) 7 (X 6 180180.0 5 1081080.0 4 2702700.0 3 3603600.0 2 2702700.0 1 1081080.0 0 180180.0) 6 (X 7 180180.0 6 1261260.0 5 3783780.0 4 6306300.0 3 6306300.0 2 3783780.0 1 1261260.0 0 180180.0) 5 (X 8 135135.0 7 1081080.0 6 3783780.0 5 7567560.0 4 9459450.0 3 7567560.0 2 3783780.0 1 1081080.0 0 135135.0) 4 (X 9 75075.0 8 675675.0 7 2702700.0 6 6306300.0 5 9459450.0 4 9459450.0 3 6306300.0 2 2702700.0 1 675675.0 0 75075.0) 3 (X 10 30030.0 9 300300.0 8 1351350.0 7 3603600.0 6 6306300.0 5 7567560.0 4 6306300.0 3 3603600.0 2 1351350.0 1 300300.0 0 30030.0) 2 (X 11 8190.0 10 90090.0 9 450450.0 8 1351350.0 7 2702700.0 6 3783780.0 5 3783780.0 4 2702700.0 3 1351350.0 2 450450.0 1 90090.0 0 8190.0) 1 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 0 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0)) 1 (Y 14 15.0 13 (X 1 210.0 0 210.0) 12 (X 2 1365.0 1 2730.0 0 1365.0) 11 (X 3 5460.0 2 16380.0 1 16380.0 0 5460.0) 10 (X 4 15015.0 3 60060.0 2 90090.0 1 60060.0 0 15015.0) 9 (X 5 30030.0 4 150150.0 3 300300.0 2 300300.0 1 150150.0 0 30030.0) 8 (X 6 45045.0 5 270270.0 4 675675.0 3 900900.0 2 675675.0 1 270270.0 0 45045.0) 7 (X 7 51480.0 6 360360.0 5 1081080.0 4 1801800.0 3 1801800.0 2 1081080.0 1 360360.0 0 51480.0) 6 (X 8 45045.0 7 360360.0 6 1261260.0 5 2522520.0 4 3153150.0 3 2522520.0 2 1261260.0 1 360360.0 0 45045.0) 5 (X 9 30030.0 8 270270.0 7 1081080.0 6 2522520.0 5 3783780.0 4 3783780.0 3 2522520.0 2 1081080.0 1 270270.0 0 30030.0) 4 (X 10 15015.0 9 150150.0 8 675675.0 7 1801800.0 6 3153150.0 5 3783780.0 4 3153150.0 3 1801800.0 2 675675.0 1 150150.0 0 15015.0) 3 (X 11 5460.0 10 60060.0 9 300300.0 8 900900.0 7 1801800.0 6 2522520.0 5 2522520.0 4 1801800.0 3 900900.0 2 300300.0 1 60060.0 0 5460.0) 2 (X 12 1365.0 11 16380.0 10 90090.0 9 300300.0 8 675675.0 7 1081080.0 6 1261260.0 5 1081080.0 4 675675.0 3 300300.0 2 90090.0 1 16380.0 0 1365.0) 1 (X 13 210.0 12 2730.0 11 16380.0 10 60060.0 9 150150.0 8 270270.0 7 360360.0 6 360360.0 5 270270.0 4 150150.0 3 60060.0 2 16380.0 1 2730.0 0 210.0) 0 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0)) 0 (Y 15 1.0 14 (X 1 15.0 0 15.0) 13 (X 2 105.0 1 210.0 0 105.0) 12 (X 3 455.0 2 1365.0 1 1365.0 0 455.0) 11 (X 4 1365.0 3 5460.0 2 8190.0 1 5460.0 0 1365.0) 10 (X 5 3003.0 4 15015.0 3 30030.0 2 30030.0 1 15015.0 0 3003.0) 9 (X 6 5005.0 5 30030.0 4 75075.0 3 100100.0 2 75075.0 1 30030.0 0 5005.0) 8 (X 7 6435.0 6 45045.0 5 135135.0 4 225225.0 3 225225.0 2 135135.0 1 45045.0 0 6435.0) 7 (X 8 6435.0 7 51480.0 6 180180.0 5 360360.0 4 450450.0 3 360360.0 2 180180.0 1 51480.0 0 6435.0) 6 (X 9 5005.0 8 45045.0 7 180180.0 6 420420.0 5 630630.0 4 630630.0 3 420420.0 2 180180.0 1 45045.0 0 5005.0) 5 (X 10 3003.0 9 30030.0 8 135135.0 7 360360.0 6 630630.0 5 756756.0 4 630630.0 3 360360.0 2 135135.0 1 30030.0 0 3003.0) 4 (X 11 1365.0 10 15015.0 9 75075.0 8 225225.0 7 450450.0 6 630630.0 5 630630.0 4 450450.0 3 225225.0 2 75075.0 1 15015.0 0 1365.0) 3 (X 12 455.0 11 5460.0 10 30030.0 9 100100.0 8 225225.0 7 360360.0 6 420420.0 5 360360.0 4 225225.0 3 100100.0 2 30030.0 1 5460.0 0 455.0) 2 (X 13 105.0 12 1365.0 11 8190.0 10 30030.0 9 75075.0 8 135135.0 7 180180.0 6 180180.0 5 135135.0 4 75075.0 3 30030.0 2 8190.0 1 1365.0 0 105.0) 1 (X 14 15.0 13 210.0 12 1365.0 11 5460.0 10 15015.0 9 30030.0 8 45045.0 7 51480.0 6 45045.0 5 30030.0 4 15015.0 3 5460.0 2 1365.0 1 210.0 0 15.0) 0 (X 15 1.0 14 15.0 13 105.0 12 455.0 11 1365.0 10 3003.0 9 5005.0 8 6435.0 7 6435.0 6 5005.0 5 3003.0 4 1365.0 3 455.0 2 105.0 1 15.0 0 1.0))) POLYNOMIAL finished Finished benchmarking \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/ALL-PAV.BENCHMARKS b/internal/gabriel/Results/Lyric/ALL-PAV.BENCHMARKS new file mode 100644 index 00000000..a598813d --- /dev/null +++ b/internal/gabriel/Results/Lyric/ALL-PAV.BENCHMARKS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 12-Mar-87 12:04:37 Software Type: Xerox Lisp Software Version: 11-Mar-87 23:53:52 Machine Type: Xerox 1186 Machine Version: microcode 87, 7424 pages Machine Instance: 2856394810 Site: unknown Features: (:interlisp :xerox :common) ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 48.169 seconds net compute time = 48.180 seconds Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 48.180 seconds net compute time = 48.180 seconds Storage allocated: 10 listp, 4 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 784.695 seconds reclaim time = 0.468 seconds net compute time = 784.227 seconds Page faults = 83 Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 783.741 seconds reclaim time = 0.469 seconds net compute time = 783.272 seconds Storage allocated: 11626 listp ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 187.429 seconds SWAP time = 0.145 seconds reclaim time = 105.844 seconds net compute time = 81.440 seconds Page faults = 30 Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 186.689 seconds reclaim time = 105.489 seconds net compute time = 81.200 seconds Storage allocated: 942640 floatp ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 38.857 seconds reclaim time = 24.215 seconds net compute time = 14.642 seconds Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 39.140 seconds reclaim time = 24.214 seconds net compute time = 14.926 seconds Storage allocated: 120000 listp ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 35.460 seconds reclaim time = 22.848 seconds net compute time = 12.612 seconds Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 35.448 seconds reclaim time = 22.830 seconds net compute time = 12.618 seconds Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 21.386 seconds reclaim time = 6.384 seconds net compute time = 15.002 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 21.816 seconds reclaim time = 6.718 seconds net compute time = 15.098 seconds Storage allocated: 43105 listp ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 70.923 seconds reclaim time = 45.575 seconds net compute time = 25.348 seconds Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 70.354 seconds reclaim time = 45.120 seconds net compute time = 25.234 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 84.107 seconds reclaim time = 51.881 seconds net compute time = 32.226 seconds Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 83.869 seconds reclaim time = 51.985 seconds net compute time = 31.884 seconds Storage allocated: 260000 listp ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 145.430 seconds reclaim time = 39.506 seconds net compute time = 105.924 seconds Page faults = 470 Storage allocated: 226464 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 141.222 seconds reclaim time = 39.463 seconds net compute time = 101.759 seconds Storage allocated: 226464 listp, 272 compiled-closure ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 310.640 seconds SWAP time = 0.043 seconds reclaim time = 117.671 seconds net compute time = 192.926 seconds Page faults = 76 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 312.875 seconds reclaim time = 117.812 seconds net compute time = 195.063 seconds Page faults = 50 Storage allocated: 488945 listp, 2202 oned-array ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 589.837 seconds reclaim time = 265.880 seconds net compute time = 323.957 seconds Page faults = 58 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 606.759 seconds reclaim time = 274.007 seconds net compute time = 332.752 seconds Page faults = 48 Storage allocated: 488945 listp, 229002 oned-array \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/AREFY-PAV.BENCHMARKS b/internal/gabriel/Results/Lyric/AREFY-PAV.BENCHMARKS new file mode 100644 index 00000000..92d3c4fb --- /dev/null +++ b/internal/gabriel/Results/Lyric/AREFY-PAV.BENCHMARKS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 12-Mar-87 12:04:37 Software Type: Xerox Lisp Software Version: 11-Mar-87 23:53:52 Machine Type: Xerox 1186 Machine Version: microcode 87, 7424 pages Machine Instance: 2856394810 Site: unknown Features: (:interlisp :xerox :common) ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 48.911 seconds net compute time = 48.911 seconds Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 48.912 seconds net compute time = 48.912 seconds Storage allocated: 10 listp, 4 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 787.551 seconds reclaim time = 0.907 seconds net compute time = 786.644 seconds Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 787.524 seconds reclaim time = 0.892 seconds net compute time = 786.632 seconds Storage allocated: 11626 listp ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 209.847 seconds reclaim time = 123.799 seconds net compute time = 86.048 seconds Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 209.832 seconds reclaim time = 123.799 seconds net compute time = 86.033 seconds Storage allocated: 942640 floatp \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/CONSY-BYTE.BENCHMARKS b/internal/gabriel/Results/Lyric/CONSY-BYTE.BENCHMARKS new file mode 100644 index 00000000..36753426 --- /dev/null +++ b/internal/gabriel/Results/Lyric/CONSY-BYTE.BENCHMARKS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 12-Mar-87 12:04:37 Software Type: Xerox Lisp Software Version: 11-Mar-87 23:53:52 Machine Type: Xerox 1186 Machine Version: microcode 87, 7424 pages Machine Instance: 2856394810 Site: unknown Features: (:interlisp :xerox :common) ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 83.669 seconds reclaim time = 54.342 seconds net compute time = 29.327 seconds Page faults = 24 Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 79.776 seconds reclaim time = 52.129 seconds net compute time = 27.647 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 92.738 seconds reclaim time = 58.220 seconds net compute time = 34.518 seconds Page faults = 4 Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 93.343 seconds reclaim time = 58.629 seconds net compute time = 34.714 seconds Storage allocated: 260000 listp ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 37.476 seconds reclaim time = 25.225 seconds net compute time = 12.251 seconds Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 38.242 seconds reclaim time = 25.526 seconds net compute time = 12.716 seconds Storage allocated: 120000 listp ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 46.541 seconds reclaim time = 26.068 seconds net compute time = 20.473 seconds Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 46.185 seconds reclaim time = 25.843 seconds net compute time = 20.342 seconds Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 23.955 seconds reclaim time = 7.237 seconds net compute time = 16.718 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 23.789 seconds reclaim time = 7.238 seconds net compute time = 16.551 seconds Storage allocated: 43105 listp ***** traverse-init Benchmark *** Traverse, Initialize Iteration 0 of traverse-init Timing for : traverse-init Elapsed time = 80.309 seconds reclaim time = 1.909 seconds net compute time = 78.400 seconds Page faults = 394 Storage allocated: 36796 listp, 100 tnode Iteration 1 of traverse-init Timing for : traverse-init Elapsed time = 122.999 seconds reclaim time = 1.936 seconds net compute time = 121.063 seconds Page faults = 433 Storage allocated: 36853 listp, 100 tnode ***** traverse Benchmark *** Traverse, Traverse Iteration 0 of traverse Timing for : traverse Elapsed time = 154.940 seconds net compute time = 154.940 seconds Iteration 1 of traverse Timing for : traverse Elapsed time = 154.939 seconds net compute time = 154.939 seconds ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 161.438 seconds SWAP time = 0.105 seconds reclaim time = 46.146 seconds net compute time = 115.187 seconds Page faults = 555 Storage allocated: 226465 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 156.507 seconds reclaim time = 46.724 seconds net compute time = 109.783 seconds Page faults = 4 Storage allocated: 226464 listp, 272 compiled-closure ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 1677.630 seconds SWAP time = 0.094 seconds reclaim time = 819.829 seconds net compute time = 857.707 seconds Page faults = 75 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 1717.348 seconds SWAP time = 0.012 seconds reclaim time = 839.550 seconds net compute time = 877.786 seconds Page faults = 69 Storage allocated: 488945 listp, 229002 oned-array \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/CONSY-PAV.BENCHMARKS b/internal/gabriel/Results/Lyric/CONSY-PAV.BENCHMARKS new file mode 100644 index 00000000..876ccf81 --- /dev/null +++ b/internal/gabriel/Results/Lyric/CONSY-PAV.BENCHMARKS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 12-Mar-87 12:04:37 Software Type: Xerox Lisp Software Version: 11-Mar-87 23:53:52 Machine Type: Xerox 1186 Machine Version: microcode 87, 7424 pages Machine Instance: 2856394810 Site: unknown Features: (:interlisp :xerox :common) ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 87.944 seconds reclaim time = 58.328 seconds net compute time = 29.616 seconds Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 86.923 seconds reclaim time = 57.705 seconds net compute time = 29.218 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 99.232 seconds reclaim time = 62.584 seconds net compute time = 36.648 seconds Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 98.432 seconds reclaim time = 62.347 seconds net compute time = 36.085 seconds Storage allocated: 260000 listp ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 40.517 seconds reclaim time = 26.548 seconds net compute time = 13.969 seconds Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 41.565 seconds reclaim time = 27.281 seconds net compute time = 14.284 seconds Storage allocated: 120000 listp ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 48.682 seconds reclaim time = 27.368 seconds net compute time = 21.314 seconds Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 49.145 seconds reclaim time = 27.146 seconds net compute time = 21.999 seconds Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 24.180 seconds reclaim time = 8.483 seconds net compute time = 15.697 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 24.216 seconds reclaim time = 8.448 seconds net compute time = 15.768 seconds Storage allocated: 43105 listp ***** traverse-init Benchmark *** Traverse, Initialize Iteration 0 of traverse-init Timing for : traverse-init Elapsed time = 173.013 seconds reclaim time = 2.247 seconds net compute time = 170.766 seconds Page faults = 9 Storage allocated: 36646 listp, 100 tnode Iteration 1 of traverse-init Timing for : traverse-init Elapsed time = 222.035 seconds reclaim time = 2.290 seconds net compute time = 219.745 seconds Page faults = 368 Storage allocated: 36853 listp, 100 tnode ***** traverse Benchmark *** Traverse, Traverse Iteration 0 of traverse Timing for : traverse Elapsed time = 155.139 seconds net compute time = 155.139 seconds Iteration 1 of traverse Timing for : traverse Elapsed time = 155.139 seconds net compute time = 155.139 seconds ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 170.367 seconds reclaim time = 54.939 seconds net compute time = 115.428 seconds Page faults = 538 Storage allocated: 226464 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 165.693 seconds reclaim time = 55.075 seconds net compute time = 110.618 seconds Page faults = 2 Storage allocated: 226464 listp, 272 compiled-closure ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 2801.953 seconds reclaim time = 1391.371 seconds net compute time = 1410.582 seconds Page faults = 56 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 2831.552 seconds reclaim time = 1403.618 seconds net compute time = 1427.934 seconds Page faults = 48 Storage allocated: 488945 listp, 229002 oned-array \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/EXTRAS-BYTE.BENCHMARKS b/internal/gabriel/Results/Lyric/EXTRAS-BYTE.BENCHMARKS new file mode 100644 index 00000000..8f9ff09e --- /dev/null +++ b/internal/gabriel/Results/Lyric/EXTRAS-BYTE.BENCHMARKS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 12-Mar-87 12:04:37 Software Type: Xerox Lisp Software Version: 11-Mar-87 23:53:52 Machine Type: Xerox 1186 Machine Version: microcode 87, 7424 pages Machine Instance: 2856394810 Site: unknown Features: (:interlisp :xerox :common) ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 1016.108 seconds reclaim time = 491.414 seconds net compute time = 524.694 seconds Page faults = 100 Swap writes = 77 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 1015.613 seconds reclaim time = 490.510 seconds net compute time = 525.103 seconds Page faults = 77 Swap writes = 70 Storage allocated: 488945 listp, 2202 oned-array ***** traverse-init Benchmark *** Traverse, Initialize Iteration 0 of traverse-init Timing for : traverse-init Elapsed time = 355.094 seconds reclaim time = 3.185 seconds net compute time = 351.909 seconds Page faults = 388 Swap writes = 214 Storage allocated: 36796 listp, 100 tnode Iteration 1 of traverse-init Timing for : traverse-init Elapsed time = 397.276 seconds reclaim time = 3.401 seconds net compute time = 393.875 seconds Page faults = 429 Swap writes = 204 Storage allocated: 36796 listp, 100 tnode ***** traverse Benchmark *** Traverse, Traverse Iteration 0 of traverse Timing for : traverse Elapsed time = 154.792 seconds net compute time = 154.792 seconds Iteration 1 of traverse Timing for : traverse Elapsed time = 154.817 seconds net compute time = 154.817 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/EXTRAS-PAV.BENCHMARKS b/internal/gabriel/Results/Lyric/EXTRAS-PAV.BENCHMARKS new file mode 100644 index 00000000..b280f4dc --- /dev/null +++ b/internal/gabriel/Results/Lyric/EXTRAS-PAV.BENCHMARKS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 12-Mar-87 12:04:37 Software Type: Xerox Lisp Software Version: 11-Mar-87 23:53:52 Machine Type: Xerox 1186 Machine Version: microcode 87, 7424 pages Machine Instance: 2856394810 Site: unknown Features: (:interlisp :xerox :common) ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 807.146 seconds reclaim time = 383.271 seconds net compute time = 423.875 seconds Page faults = 56 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 818.779 seconds reclaim time = 387.191 seconds net compute time = 431.588 seconds Page faults = 48 Storage allocated: 488945 listp, 2202 oned-array ***** traverse-init Benchmark *** Traverse, Initialize Iteration 0 of traverse-init Timing for : traverse-init Elapsed time = 261.049 seconds reclaim time = 2.479 seconds net compute time = 258.570 seconds Page faults = 10 Storage allocated: 36796 listp, 100 tnode Iteration 1 of traverse-init Timing for : traverse-init Elapsed time = 309.028 seconds reclaim time = 2.655 seconds net compute time = 306.373 seconds Page faults = 411 Storage allocated: 36796 listp, 100 tnode ***** traverse Benchmark *** Traverse, Traverse Iteration 0 of traverse Timing for : traverse Elapsed time = 154.839 seconds net compute time = 154.839 seconds Iteration 1 of traverse Timing for : traverse Elapsed time = 154.837 seconds net compute time = 154.837 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/File-Servers.TEdit b/internal/gabriel/Results/Lyric/File-Servers.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..fe5a05cece296172c272b48f39ab5ca5c904b076 GIT binary patch literal 20604 zcmd5@TXP#nc7|kUtAKcuRBbMsds|-HpiRzla3KMdtqny&64$($fMhG1P1O(>5VHhk zkePufZYp_9Zy;EQM^M#01vi66i8<3xy`Orr4orxiy#raO6*U9X%Kqx71mGY6KFOPNi@wfNc|+GS;HuVuA$iTt{%m{cOkrRDE1Bl zki2s*2$NLo9-nsC#a{1=b>WGVXD6mzh;-B|P-unjKEz}-NlK+CL_CY53qJ(g%TNSi z8bN`1EM{JuCXNuSQ4oVEQM5{D-r(Xqj^`E*JqRSaQd2=Fp*(|JM`C3BHQ zJ;SEbHAxEby?6+tK|*#3WF1T}FA5XkokjChT#mhzbsBo9C#K$&nEGC*Z3AOL2UEE; znu&@3(w~SyG$cI4JbT1e9Fd4*oFoIyzVK$V*dGLl1ITfOY1646rpY?yMf3A9eM{!& z=L8TE3#v$&B3?-g4?2W8nfP8pK>~%~h^c@_KO3kJd$=wjjr`g1f+R$kjUSREl@oIB zKI7w2-n(oT!^JvSCKJ|+l@VU-i_17jQ$Q&Q#V%BUm7j6>>tW z5Ynu2Sr%XfxP5>LXakqrL~VO%?F|AFZv zF9`-f9)v)|4HA)fSClW{4Wyl^2jJVnLg!&XaVAHu>)bXD&au3I9{WC*Fyxm}FeJGs zyx}!(Izv&@W`(YUNkmAH=AK0y43t^b5D3^?h~`a_NL)tq$xuv!3#=n1UJNkGWsx^f zW?*>4Nw#cbb6uPvuOT1v48w7gaKIUWnU`~0M%%HQ~x_IKJ8_zuQlD?)4m`shR8Zul~YqmYV_>9OQ0p?b)|lGLQz6{l5R#m~}jH)7?Gou`h z=_sPPECrLGpVMuTs3KfQxUUYjDK+ymWMO(El zPPzx(jB?bI!XNJJJ>U5{Bhz=+{o!_VlTtQ|k6sG}3o9IScOGjCipQ!EfKX@L*l|in z767a?4J{GneljsiVU(nRAW919B6EJW2+OZlKw~4-fobu*ADsK~Vj(e{$7IySB7HKA z9K|chvFCn>LYBgJXNdL`{eYeY=OIOr2hfKEKolSd!A5Zap&({VTEjTpE;T!wo5Gvo z=O~33#Fg4b;9=}xX-dRYQzkw*!Jl7^WoCxfgsBNy2;vnXZbcebxd=~lyM;WXc zULViXIpz)nbWq$WG4hh6|JmGDT+ zqaX~DF{G9v98;ez%TVaQqJTtVAOdxF+G~n4l`!r|$R1gp=YBqG5TV{>6r+(bH#wJM z`gMj5i6lhgxDsREdr5*Rs~E%Kk!T7zs3Do4D#RCXqwKR(M4>D|U*sJ!tYh=GDUMINM?DSZ$K1@4J%L=gO<^QeCLT z%?f@rYD9J$3%Uxsa?NSA%VOKv-lk_w`lwYX{P1L}PER)ZNsXSk6&Zu&rnA{DyLD%) zP2`rGRXI}SM+ODU)zN~rSpq4PT#6)fo$V$`)^>?T|5dbLO{Wg_O{c}2x8xiatnSqC zr0z89L}Z;Z!CFqUQ5J2d&a+r@x3UmS#vXhU667-B8t!tdu`yj{Bl&CLYRqO!S(FF3 znbn}_mQ!bqSh$*w9r7-AYZNv{a_uOu18&rWa8r&X1Ru*llAXA&LX0}ytRRdl$1^pK zo~(<(*dJVAvcerzJnCUE1EomjQPq$z)FwWsc3SXiASFQMrF{Wqv@}YAXUIx8WPcJz z2~s(D=&O7J9VL8KH!Sgs+)VOed%@ivngailf(b3qQbcop&fHQ5GM9lF9tN0~xTWE2 zm))AnfNO zEHq}eoEBiV?eKVJq#)CDwxQ^jg0e!o3N#vyIj{tvt|k?vyAIQAB|8(aO<9IKq#Ljp z0*81Yyoj5&9W3p-&KAvadE(mxG!>>Cz9OIpP*mp?8G52{9X&HakLz57E?gmf5dmm@ z75KAaamhJe#g+_%K%SN$0Pt@HeQF5}_yfig{W;k*_6hm#@e{ezlF;9M+THy^^iiO0 zfpp|&1#~uWU8ik8lQJ#5p$xCVR3pr6IosqZ=@bR^np0~dJvZe#JX0raPW4+(o3f&w zQ^3-qxygdCfzVOKgjTC5(U5$v6%Dx_XqF(7b2x7!&2N<(&L$&V1&4w;LZ(?p5i%bY zM7tj5%fzF^D~n3OZ~$_n40bFReYg_luG82CUDgd2?rtboT{r`_w$(&F_F`{ND00!eR)?v82+ce!7b zsNNY4(P8gWk+}t|TS&(eJDiO*c3SKmb^(1urqQr=k*I5`cGHdkl~wwRdZ=$VH|@p1l3U4 zT`)IvB1p{gOdb1EI*C@h0pR=0r*>N@7a+^eLkK|3(KI1oaGRmq{i3q6MyPOLJ>+7n z3bix5zu-RPjCR1ZoMfbIn`^hS;LM_y4Y|nqyb;<9hT+G&GiUq6-gJnK01g0r98>Tq zG})QBnxJOYrBs(t6?F-B< z3Q%=5UKxQhJV55C;UH7NsR7$`wy1(oE_OLc>M}(lYjW!3jLMlBDU!`_eRR4`J&R72 zRb}5VD;|fx#U90p3j+94%+xe{G*{S^FlWVHl@GLU4OEsb)`mY2VtL7K3~6kEmgXsH z729lrf{Zl>H4gg_ekPTWLe{8^pg7Ad5l8&%1pC=Mz%3OcnNBAdr@Xh#gFOQ*Um5A6 zdOkao{gR4qhODkSxzI*Dq+?tp;f$0cLatFPQMidg*y$q0n^hUe=%}bbQLLIGsB%SQ zN*Ba&QIj-Pi;D=mt}-FY7yZ`jg(a-rrxJ@ZHyty(V{b+$BDMN0N){R?z2{KilRIdH z18q9UqtdH7T6n96O-F-pS7R(Rir}-_Dxj^E@uBs&t7n6 z3F8@fuEZRgb_myUS~SCzosI7KTC^B85KUf^r@mfjGr%jnxLcf=0ez|I|9|d>(kr>oj*>5fM7I3Xs?uSY1otb70&2= zYz#h5%&Rb*fC0(?1t0ly>ZMx9RdDLz^gf|IIezoe&5{Ei1RRUPQvqD6xVWUILtZTw zj{N<}2uVLoaal}(wh_n$PCvlsI;j+3DAFnAdZ=eP>F z!l*KBuK8o*=y|!1a4VxhE2Bu1d$?Mt=+jMk2*bGM4@!3WKO!*t$e(&=4H_W~p2Rms zz{0^m6Ap{yHk)@K+^})M;4qM&pb$xSzJM<}Huwlpy1;Su%;;8Ctr_73)sk8Ud_ z8hg3PW-;+WQbKf!oD7HZ=m=uCax(%c+p?^15Gg776iM#Au`_9wWr5*f(vr&4BrJqY zIB!ut*AzwzI zYf^cuLBsg)oJOexp1rC-I~uAEfOK{@AQx6wJ^Zo`HTvF!E_DRT0Legq^UEoG&ZC0@ zN&eW7>xQ{BEt{`9oy8jzBo>ER*6`!LjxV?JF9?xf5q2e^Wti+L%)FG)bxCJ+Y{ZR| zc1X_~3wlom+qEf*5M8490}q#4WR&doL*Mw({gin@g}XwCqWTSz4fS>C!`SLI9ooVW zd4wx<6rcC>yDQI$Gg#zbzac#E8!W>h8Sr~O01l12=6<7k(CvRBs?~n?@MPm;r~mY5 z=ddfPhdW<%7e6~sk9&RbxWB=FclNr^_jkMWTYi&OlS`-Q?Cqa+cl*buFZg-(qa)Yt z^>Od`L{y*Pa^=P0+M4L}Uz~KsgI+L2QGKwsrq_}JVR(1vP*mwMM&w0Qj8MNs=lEIw zJ z)X?hg!ErDDgqNu99ryPSaf4dj2PmH%_4UftUbp|Hxzcj+_m3cQCXSq>CE7XK6Y9H` zR)}i%OW{IVdltE0yIy zI@&+b5p+;7e*rEX zw`MqXR)vtkL}TdY%#q_)NFrJSD|48W7(3T_PIOd|i|VI%wa;AygIEQ6IzU0IOX+mazU@O$yfWh+Nd2Hy#+$A zN}b_dfD1apqB8*$@McXUGY>CCEl$h1oT2o~ckAd41-u}FeU+^DuW)z!;Qc@O;0GUm z_|YfTwNL-@uYU5=&mMYb128%t2S2-*OgG(Hz0us-Znck&Prf|u^`AZe>gyMO`asD@ zg-E>&N%i5;v;Bj;jehs*zRbT#IvOqL z>1E*C@!F{4WHRNwBllZ){b`mvzR`!mB!s>s!%j0H0~O@XMo zQp=kG*)(zT&G!Y_5?T*4JuJb8!O2K}$ZodmOY)I9n^jvh11s*NzD*z-*Y1q6{o}0o zb54B?gy~-H+P;unc^jB9<0`eI8z;xT{XU_>aE$2m`a7ptxA{u|WKkxwt{W0w&$oND zx3VWL_Li!bE`UkyNA&dyYL0!s@+|=r1iLesDTQ* zUK0~2P>ioE@79ny7!tW=#lWDHD@zXF>(U{_2yd1q3I5N3@0IA!uaw>`Rr#CxxPQ<5 zmHYm=`Rg5w`%bA}D*d8V`mfTx_0qkxbnoBH5&7@i=1-dZF8s|cw{nB@Nzju0kxN}tcu3QYeCkO$G$XteJLrzuhUnPzy>r4{GC32U(b1` zIHyu1u+z;&*xQ;w^O?X4L6D_{AJL*WjaGWbn`<$Vi<)}j_$%cd5=g2Th2Uw%;}aJ-m+u@+rTU`5R}*n}p* zTEnusWgv@S`NdkpG9j}y-C)_&;$jir1lu!+bj~SMVrMD>qUY!Wi`Qy{Rb-- zwUBI?&>~pQw$@-tO~2eB)K_z{Mp$fD!=Oy62ox14RQVR5k*wbrowVzIr0vn{rkV3tiSg5~UgFZ$M+ViByk zwE$yHu?VdGwaz9Ef&|l^qrb~Vf+!MlHl-z>SdH~bk*%eEP#j@R`J3X1 z)q+{-Th2Z#E^2w7E076(D_%Y~gLmenmITe{rAKvqOq_V{s8xrar9r9L+krnZ*omVv$~E_$6z;4>gwwH|0)g!>Z85=mq*V}!u{u`2Oq!K zdwKk+QlLLAdO5Dcqv>K?UytwZX5nah86M9Tv!~(B)p8!* zEMHws=5NQBVLhHNuNL!gFg)7r^`C~vyN&w6?!j`gz~4AjNVQoXrwhQayh3uSawsYnL<%nKC_K3y=8>MBOG8uFYk zr3MEwnN=D^l}C12o@i9X+?6t^HezWtM9nfL>$T0A-HNQ4+@F0pu2og)Ql&=cDl2rR zl1LRPA8D#nHQ29b@8)B5dUUe!-xR4bajpi>#`8tJyjV-l&%nNAkls!UNfI?3cM<}J=tT51W2$$RB`Io(zUlT0+vQqIY~_2gD1 z2}W=T;haB7GrbpY`0NMtti7dx`j$gCRvJ$6$c(Xo7~333HhSgDk2zh%)`V) zlt&>JOI5Bk>+!{sbD*1Hhe-(qdzu85IPG)~56@Luim_-FI=1Jikv5#*Y}-rWah0VS3aA(u45 zi|(o(0<}=Z|3M9~nfl~@>T`tHpG|=yxK?ZzwY=D0~AIJ$oq#Qny zv}=boTG)ncN-+nM2zPWRZpRfp*j&aP&MYjC2lr|UO~fTZOwh8CUcc9s(T*@OQwd?f z8hJ*t007sjTchDUAq)n$EVtZ{x3#e^#EHPZ+q$X0#0*)MlR#AE7Vwf&l$U#fcd2@zvDRLYe`psE`o_pduOjzh1ei zr>VGasPy>Ol*m{N131tjs7u+PtDcE46%bFlSa9(5l1U8(rcLdq-Wdr_qtI7MIVxKi z$`qWGV{jn#F(<)I-Y0I45o5%~?o#o;tA~anq0_#Y^mUN@(n)G#M4?M?rLBRP&MK*a z(ve6pj0wzIu1j!9rUsO4(IdN4%T?X=+gd2qjz*7aSFVE5ERgg~G7bZzR!h2M&65)Q z6sy&gSJlXR=^Ys)Ng1StOky`xH~LANw-jf=rZ;q1EZ2%#_Sr>~`$X8(Gq}uFtCFPQ z-9BuyCA84?mK;|uqaP$*RDBjU*{&^iD5xeB!XolA0Dv~}ZEVR9`YG8CeA_mSH(`26 zmi5JdEjf**QjIc_FF19}qJ22sGmM$@)taIv(S)LqV-OAVpm z0_jq))OM+swE+p&WxGy_Y?m++BdfjvJWeZhj9jEc$fOgbUP-TA$R|fmn9WiLi`0Kv zMZZ8VEY1-gA>2ar>HMVC&2tM+!%q?T)uU|kiL)g-O4a}?+_B2=-f`PY_V`WMM8`>2 z(^h(M#$CjwLvyUb0H6`hlL5R-lF?>MoLgMug-un~ArxTB5v*^PoV)Hem#ZY$7AYK4 z{Dc#@siwmP?1tnaXCvF0blKL9t5U}9(3>{&*_7LY4&`1=;et}Cl5I^$32Bcjze1gL z{9rQq%|%1rK;)i)4+c9s;rZFiqto;7Rrk{~yq;Z7UQhTTJLgC4JY3Ae`C?Qr!qFmJ zydCp>6V6_Tqww8idO3R+PNwq(KM6!8)30WW#q2tKJ*&fG`y2VFH$B&Z{Cz8UKPcp7 z>nnK%!FyW)qQ3{he}b(t*!o8!z3+J-!u4g}mSz8xmBD}Q;?HIM*1zvt+{nJ+&ck(! zPjL8a{@xF^g1-c2`0V-N-rr8n4?iKkCLDgWckuCE$USziC2!}?U%ogx-8%`(?d{+@ z8%CcH6izF$X1@mnA3Un@xQ#!%HX>K>^)}u^{SWI)p78NwSMU>8@JmRyGkeKT>Zji>2s^`q|#WOnJh1@(rFgWqXfI&PYRR8H0+di)VzVBUX23S z*brHcmFiafz^dc|JGCx#LqRB#Mjk^xj z!}}-dF-*p{a6IZC94am$8f0an&ZAe&5HFF(b8CEv*M>|@F+#ViiIvzlB#@VCK2LUAYY$V;VN_NjdU@|LUP(kmG`Y+ z1Q&C+xz0}YoZ*j|yYM12ErkI53;Xb+%u5|R`dRyA3&~2XLc>+#hROrG(F$6vV{#Um zPVz|>t&rGNxix8&Hz}{-QGKSPSf9oy%jCUQ>({7|{L>HWoo>!;o!zXeD@r8;Kc)D0*240MHo}2tVaqWqI zre=B>fyFIpaXdnYf@c88)o3e8Folt4@cx+r>-hpTqVj@8fef6L$wX>tf~|$S4*!|X zB5_olrq9Zijqa_?%&uQlTI?*w?RAzRKVgDNa_m?~K256pxP!N=SICht%pNF{PHaIk zji+W!SSQZ?8y{b#NtCS0;s|AfKaL7P%eR3zg-wSWDE%sES;8um_yp<$KT!6AIYBNY4#`L;=2{I4q z2#e+#vKdw`b5`rLJdIKS{VLN)lZnX#bqp?IJJKTuys;=%N+C3bWQw(IrmXEI0F^N@ zkqAUc6k9F#b*`OG%SoZi1c?f4Mjpb;MMeOb^40nn>q1HHBjQLzlVyUKEEc027X|1= z@S&dav(>Fpr$K{NjMiru1>61B8`YXfrJzB8tLd8TUA2$icY-UXAzDEDGQrkB6!;5m zuCS;Fu`-$I$n~8xV5(lPP9c~q&BHp{Jl9JoYF+yDlSdo#gWDOONXDpr+a-Ql0wcmu zn%>|*Y$P}^!?4}2O4vMYc9m{e+aw)}-B9$XhYhT207bS%RxJU!4<11(^q92FkcN|V zYS8s0C%DsYGcdCmx&nX!3IgxgE7RF5XnnPsU+TWPcCGY}JdWmz0y5I6A;jXr-ZpoP z;7ztP(}-z2iLyxvZP`EyWb6rDEMS5DZk-P#-)0i@m;O$y5O#z)$ zq3Uw$Edi{^WlU5^*F06wg1vAg=g8-5~-UC?{&x ztcP~Xqv|(8N?v3gPiFhm(w1GK9-cA02kPhuYoHh~nb>)H-B$IvW@1Ymt3%os4yC_; zXH_0ZD63ZqrG0NbE?>Nejo(ACM)k8BjJtkMo`@#H-0rnba9&L2{t$5*4CPNa@`vp~ zFdWFAPG3SVkJj<=i64%72(CXA{t$n<;O|nnUbNrBV93<0TE_p$q`T2s=jguQwJ9nI z)y2NB1KBoWa*0WumM}i?yMv$)<#Bh@^Si@f*k*lXW!m zJ6Ioe&=10%a0x$HaT@mrgJ2Z;oi4u(M!~Sl_u;r%a@e|S8At7)JMg<$w(G-Rz0mJ= zf>0Qx40^5G>4iakf!y!-<6baAiQxwd1V3!OL8GAEZrS@Rlu(a~cSeJtJ@WhQaWLxp zo#8m>NO7_n+ntK}UB5H#FoGcz!Jp1}jPk{=4&x5n#a&}tySOHkD>8pL3PPj++%`t& zgF&A*jvy90i|ldAi+1?S%*W z8IfEyWp9z765_34sFr$?@hpi$0c$w9&iOvcSyqySyl?nFW#GvQy$;!eK(y;8{D3gX z6MmHlk6Xu<5m?xU=a8y!V#wIy*`Y&8X1I=d-u1(F&>Q&(C_c4={(!HNCS!87Sx)Rt z?%DlkDSG?56E#SW8)jDCGk&fQsB%1pyny|6fjqpGPPrKP74 zJlNjk*=DHtusyC1u<+$!yIs%5nlOnL8MbOP4j~N{<>?|bFaY_4M~%jv5cSvV0gLdr zy#>wy3389y0>>lf9)O8_8_*2Y8Tliw%nofq5$M@w;~ocnAd&;5NL?`qm`Icbcmmg~ z-7buRtwZ<##@5go0wR#todC$`peUFGXvitZiOmSD;|&b0*XujDDT+aJ2SHf`@FWJ1 z3N_oZ)1Vsw@m&NJumf@pWy+|4vkPvB59#|&5Jjyq)(Go<_n?7JmwyvRS+X>L;P3Y^ z^sIri8+803ihTn@YZtJ`Hn1rP(6dh$Lcv^NN2^8|aj85Uys13~=&%?wCb*1)P-4)a z4IIJcM#vFCm_7jo`HiAkV~s!!9{67X;0>g&3u)T-{tY-@Jy zPun8f99~g#)Z6TRx2DwF?8t;Q$CvrSkTf2Ugdyd({N&mrtGKb)A;`v8a&Rrtu}%RJ z-r_E`2npZVCVYFF@Xc+)ceV)|igD4|Hpd^f2|FS?gm+#lLiRQ}YU4;aAfYyngrjZ3 zzDr;>kgE|PVIxKO^=X`TX(eHbFRcM6M*zV;l8A`JFW`_n5n=nC}vPNX1;j&Y~NUxA}I6)g_>o)1;LFhdb1`pEX__0MF7y< kNm%4_RadVj{G9u|R78sPr5rC_xyH?knQlzgDIi0u3x?WN*?}#Yh_VLYJE90vZz{ zj+%gSs>}$sDp$p11K(d5m9_)0CoDSFl_{sVRfd_QRN8XnEt?XFkt{LkRLz0Vis9Jk z97wUVqLe06cE(gb%VaK#5)%|C(i$P#@IEwhytlaJX<20pzMto}8OAMPEF{S48{G@)8wtXgaItBwb&eLGqdk9`&dT zOBmFPz`g6dD!~_UKLTUGz1rmlwd)vNVaNp-LyvdcKFF9+;c*OGExgGHE(7u11|Kyk zm(`B+LK+(RJfMCA8GAj*5V}}`N6;7V`cCsM=*3yT{`#Uzy;!XNJ15eXrbIf7hjx7+C-B<^ASl5D=#0D3Eznd&hl-$<2c0N_ zsFgU8M$M@wc#rznF>n)}3*jCX^L^*!X#?>EG!(?#r^4+~f#kV|#eCN}QFCu!!NKMo z+T)?19?%60CJi7Ax&}3Qv_!)7te}192vvsK&`K9}eh4~4B&G)J>FIz*5%d}XEf?yB zE+`UU-@>`9uCFtYNg$^XqmfiEu1O7yN{R`%J<)Y34}3@v`_N1+l)#2W00-`@U=vwL zlVr^_fcM+JX?T(GPFff@4d7T8cKtTyRXSx?8t5FJQ(WxHcaDo{C zP2dHBI*vnco^yW52|l}IhjekX^$-3Mva?0V6Y_?TKgm{1wti`>_x&EDu^sjfhW(0> zMbL*=(TPslcTpX@$AJpT5OyxRb`eyv$89qc5;vL*PE(US;miha^ z9DhBC=)V=Q1Ku@ucMRzLw4DPveXwcx=t0BB{~z(?X2@rohWe1KM8>tViTGmE@cE|U yPL;1W5eJ)wPaZUU)kfUW^o{{VzHW!00l#Y}Xwo*^$?-VDd&?ZVe~=%qfBO$*!OBkn literal 0 HcmV?d00001 diff --git a/internal/gabriel/Results/Lyric/pav-5-25.benchmarks b/internal/gabriel/Results/Lyric/pav-5-25.benchmarks new file mode 100644 index 00000000..c1c1d4db --- /dev/null +++ b/internal/gabriel/Results/Lyric/pav-5-25.benchmarks @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 19-May-87 16:31:40 Software Type: Xerox Lisp Software Version: 19-May-87 15:27:21 Machine Type: Xerox 1186 Machine Version: microcode 89, 7424 pages Machine Instance: 2856398998 Site: unknown Features: (:interlisp :xerox :common) ***** tak Benchmark *** Tak Iteration 0 of tak Timing for : tak Elapsed time = 1.652 seconds net compute time = 1.675 seconds Iteration 1 of tak Timing for : tak Elapsed time = 1.676 seconds net compute time = 1.676 seconds ***** takr Benchmark *** TakR Iteration 0 of takr Timing for : takr Elapsed time = 1.703 seconds net compute time = 1.703 seconds Iteration 1 of takr Timing for : takr Elapsed time = 1.710 seconds net compute time = 1.710 seconds ***** takl Benchmark *** TakL Iteration 0 of takl Timing for : takl Elapsed time = 14.585 seconds net compute time = 14.585 seconds Iteration 1 of takl Timing for : takl Elapsed time = 14.577 seconds net compute time = 14.577 seconds ***** stak Benchmark *** STak Iteration 0 of stak Timing for : stak Elapsed time = 5.562 seconds net compute time = 5.562 seconds Iteration 1 of stak Timing for : stak Elapsed time = 5.570 seconds net compute time = 5.570 seconds ***** ctak Benchmark *** CTak Iteration 0 of ctak Timing for : ctak Elapsed time = 48.557 seconds SWAP time = 0.107 seconds reclaim time = 5.766 seconds net compute time = 42.684 seconds Page faults = 16 Storage allocated: 47707 listp Iteration 1 of ctak Timing for : ctak Elapsed time = 48.433 seconds reclaim time = 5.805 seconds net compute time = 42.628 seconds Storage allocated: 47707 listp ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 40.165 seconds reclaim time = 22.908 seconds net compute time = 17.257 seconds Page faults = 8 Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 40.716 seconds reclaim time = 24.563 seconds net compute time = 16.153 seconds Page faults = 2 Storage allocated: 120000 listp ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 37.703 seconds reclaim time = 24.057 seconds net compute time = 13.646 seconds Page faults = 2 Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 35.975 seconds reclaim time = 22.902 seconds net compute time = 13.073 seconds Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 20.940 seconds reclaim time = 6.424 seconds net compute time = 14.516 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 20.968 seconds reclaim time = 6.454 seconds net compute time = 14.514 seconds Storage allocated: 43105 listp ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 69.733 seconds reclaim time = 45.068 seconds net compute time = 24.665 seconds Page faults = 4 Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 68.561 seconds reclaim time = 44.381 seconds net compute time = 24.180 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 84.666 seconds reclaim time = 52.102 seconds net compute time = 32.564 seconds Page faults = 2 Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 83.163 seconds reclaim time = 51.210 seconds net compute time = 31.953 seconds Storage allocated: 260000 listp ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 140.934 seconds SWAP time = 0.050 seconds reclaim time = 41.294 seconds net compute time = 99.590 seconds Page faults = 522 Storage allocated: 226464 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 131.996 seconds reclaim time = 37.017 seconds net compute time = 94.979 seconds Page faults = 2 Storage allocated: 226464 listp, 272 compiled-closure ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 517.850 seconds SWAP time = 0.090 seconds reclaim time = 230.605 seconds net compute time = 287.155 seconds Page faults = 98 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 514.126 seconds reclaim time = 230.334 seconds net compute time = 283.792 seconds Page faults = 48 Storage allocated: 488945 listp, 229002 oned-array ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 286.296 seconds reclaim time = 109.003 seconds net compute time = 177.293 seconds Page faults = 53 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 294.959 seconds reclaim time = 112.913 seconds net compute time = 182.046 seconds Page faults = 48 Storage allocated: 488945 listp, 2202 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 747.275 seconds SWAP time = 0.058 seconds reclaim time = 0.621 seconds net compute time = 746.596 seconds Page faults = 1 Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 747.075 seconds reclaim time = 0.474 seconds net compute time = 746.601 seconds Storage allocated: 11626 listp ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 45.588 seconds net compute time = 45.588 seconds Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 45.580 seconds net compute time = 45.580 seconds Storage allocated: 10 listp, 4 oned-array ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 178.205 seconds SWAP time = 0.371 seconds reclaim time = 101.683 seconds net compute time = 76.151 seconds Page faults = 36 Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 177.319 seconds reclaim time = 101.552 seconds net compute time = 75.767 seconds Storage allocated: 942640 floatp ***** fprint Benchmark *** FPrint Iteration 0 of fprint Timing for : fprint Elapsed time = 12.116 seconds SWAP time = 0.236 seconds reclaim time = 0.360 seconds net compute time = 11.520 seconds Page faults = 5 Storage allocated: 64 fixp, 537 listp, 1 vmempagep, 1 stream, 94 oned-array, 1 process, 2 pathname, 53 pagegroup, 1 filedescriptor Iteration 1 of fprint Timing for : fprint Elapsed time = 11.847 seconds reclaim time = 0.368 seconds net compute time = 11.479 seconds Storage allocated: 50 fixp, 521 listp, 1 vmempagep, 1 stream, 89 oned-array, 2 pathname, 52 pagegroup, 1 filedescriptor ***** fread Benchmark *** FRead Iteration 0 of fread Timing for : fread Elapsed time = 10.562 seconds reclaim time = 0.661 seconds net compute time = 9.901 seconds Storage allocated: 28 fixp, 6238 listp, 1 vmempagep, 1 stream, 79 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor Iteration 1 of fread Timing for : fread Elapsed time = 10.407 seconds reclaim time = 0.544 seconds net compute time = 9.863 seconds Storage allocated: 28 fixp, 6238 listp, 1 vmempagep, 1 stream, 79 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor ***** tprint Benchmark *** TPrint Iteration 0 of tprint Timing for : tprint Elapsed time = 28.868 seconds reclaim time = 0.285 seconds net compute time = 28.583 seconds Storage allocated: 11 fixp, 77 listp, 4 etherpacket, 24 pagegroup Iteration 1 of tprint Timing for : tprint Elapsed time = 28.697 seconds reclaim time = 0.175 seconds net compute time = 28.522 seconds Storage allocated: 170 fixp, 93 listp, 2 etherpacket, 24 pagegroup ***** traverse* Benchmark *** Traverse, Traverse Evaluating setup for traverse* Iteration 0 of traverse* Timing for : traverse* Elapsed time = 145.082 seconds net compute time = 145.082 seconds Iteration 1 of traverse* Timing for : traverse* Elapsed time = 145.083 seconds net compute time = 145.083 seconds Evaluating after function for traverse* ***** traverse-init* Benchmark *** Traverse, Initialize Iteration 0 of traverse-init* Timing for : traverse-init* Elapsed time = 102.325 seconds reclaim time = 24.622 seconds net compute time = 77.703 seconds Page faults = 8 Storage allocated: 36796 listp, 100 tnode Evaluating after every function for traverse-init* Iteration 1 of traverse-init* Timing for : traverse-init* Elapsed time = 78.082 seconds reclaim time = 1.561 seconds net compute time = 76.521 seconds Storage allocated: 36796 listp, 100 tnode Evaluating after every function for traverse-init* ***** frpoly5r3 Benchmark *** FRPoly, Power = 5, r3 = r in flonums Evaluating setup for frpoly5r3 Iteration 0 of frpoly5r3 Timing for : frpoly5r3 Elapsed time = 0.230 seconds net compute time = 0.230 seconds Storage allocated: 448 floatp, 966 listp Iteration 1 of frpoly5r3 Timing for : frpoly5r3 Elapsed time = 0.231 seconds net compute time = 0.231 seconds Storage allocated: 448 floatp, 966 listp ***** frpoly5r2 Benchmark *** FRPoly, Power = 5, r2 = 1000r Evaluating setup for frpoly5r2 Iteration 0 of frpoly5r2 Timing for : frpoly5r2 Elapsed time = 12.475 seconds SWAP time = 0.110 seconds reclaim time = 3.832 seconds net compute time = 8.533 seconds Page faults = 4 Storage allocated: 1684 fixp, 15346 listp, 1190 bignum Iteration 1 of frpoly5r2 Timing for : frpoly5r2 Elapsed time = 12.177 seconds SWAP time = 0.067 seconds reclaim time = 3.533 seconds net compute time = 8.577 seconds Page faults = 1 Storage allocated: 1684 fixp, 15346 listp, 1190 bignum ***** frpoly5r Benchmark *** FRPoly, Power = 5, r = x + y + z + 1 Evaluating setup for frpoly5r Iteration 0 of frpoly5r Timing for : frpoly5r Elapsed time = 0.216 seconds net compute time = 0.216 seconds Storage allocated: 966 listp Iteration 1 of frpoly5r Timing for : frpoly5r Elapsed time = 0.225 seconds net compute time = 0.225 seconds Storage allocated: 966 listp ***** frpoly2r3 Benchmark *** FRPoly, Power = 2, r3 = r in flonums Evaluating setup for frpoly2r3 Iteration 0 of frpoly2r3 Timing for : frpoly2r3 Elapsed time = 0.022 seconds net compute time = 0.022 seconds Storage allocated: 33 floatp, 102 listp Iteration 1 of frpoly2r3 Timing for : frpoly2r3 Elapsed time = 0.023 seconds net compute time = 0.023 seconds Storage allocated: 33 floatp, 102 listp ***** frpoly2r2 Benchmark *** FRPoly, Power = 2, r2 = 1000r Evaluating setup for frpoly2r2 Iteration 0 of frpoly2r2 Timing for : frpoly2r2 Elapsed time = 0.290 seconds net compute time = 0.290 seconds Storage allocated: 48 fixp, 654 listp, 74 bignum Iteration 1 of frpoly2r2 Timing for : frpoly2r2 Elapsed time = 0.301 seconds net compute time = 0.301 seconds Storage allocated: 48 fixp, 654 listp, 74 bignum ***** frpoly2r Benchmark *** FRPoly, Power = 2, r = x + y + z + 1 Evaluating setup for frpoly2r Iteration 0 of frpoly2r Timing for : frpoly2r Elapsed time = 0.020 seconds net compute time = 0.020 seconds Storage allocated: 102 listp Iteration 1 of frpoly2r Timing for : frpoly2r Elapsed time = 0.021 seconds net compute time = 0.021 seconds Storage allocated: 102 listp ***** frpoly15r3 Benchmark *** FRPoly, Power = 15, r3 = r in flonums Evaluating setup for frpoly15r3 Iteration 0 of frpoly15r3 Timing for : frpoly15r3 Elapsed time = 32.937 seconds reclaim time = 14.305 seconds net compute time = 18.632 seconds Storage allocated: 53297 floatp, 48892 listp Iteration 1 of frpoly15r3 Timing for : frpoly15r3 Elapsed time = 33.284 seconds reclaim time = 14.450 seconds net compute time = 18.834 seconds Storage allocated: 53297 floatp, 48892 listp ***** frpoly15r2 Benchmark *** FRPoly, Power = 15, r2 = 1000r Evaluating setup for frpoly15r2 Iteration 0 of frpoly15r2 Timing for : frpoly15r2 Elapsed time = 7447.767 seconds SWAP time = 0.102 seconds reclaim time = 2459.026 seconds net compute time = 4988.639 seconds Page faults = 9 Storage allocated: 1049024 fixp, 7404396 listp, 129648 bignum Iteration 1 of frpoly15r2 Timing for : frpoly15r2 Elapsed time = 7479.973 seconds reclaim time = 2474.735 seconds net compute time = 5005.238 seconds Storage allocated: 1049024 fixp, 7404396 listp, 129648 bignum ***** frpoly15r Benchmark *** FRPoly, Power = 15, r = x + y + z + 1 Evaluating setup for frpoly15r Iteration 0 of frpoly15r Timing for : frpoly15r Elapsed time = 26.251 seconds reclaim time = 11.681 seconds net compute time = 14.570 seconds Page faults = 12 Storage allocated: 31789 fixp, 48892 listp Iteration 1 of frpoly15r Timing for : frpoly15r Elapsed time = 25.422 seconds reclaim time = 11.143 seconds net compute time = 14.279 seconds Storage allocated: 31789 fixp, 48892 listp ***** frpoly10r3 Benchmark *** FRPoly, Power = 10, r3 = r in flonums Evaluating setup for frpoly10r3 Iteration 0 of frpoly10r3 Timing for : frpoly10r3 Elapsed time = 4.629 seconds reclaim time = 1.880 seconds net compute time = 2.749 seconds Storage allocated: 6393 floatp, 9236 listp Iteration 1 of frpoly10r3 Timing for : frpoly10r3 Elapsed time = 4.566 seconds reclaim time = 1.766 seconds net compute time = 2.800 seconds Storage allocated: 6393 floatp, 9236 listp ***** frpoly10r2 Benchmark *** FRPoly, Power = 10, r2 = 1000r Evaluating setup for frpoly10r2 Iteration 0 of frpoly10r2 Timing for : frpoly10r2 Elapsed time = 408.080 seconds reclaim time = 136.282 seconds net compute time = 271.798 seconds Storage allocated: 55634 fixp, 443694 listp, 17227 bignum Iteration 1 of frpoly10r2 Timing for : frpoly10r2 Elapsed time = 407.992 seconds reclaim time = 136.387 seconds net compute time = 271.605 seconds Storage allocated: 55634 fixp, 443694 listp, 17227 bignum ***** frpoly10r Benchmark *** FRPoly, Power = 10, r = x + y + z + 1 Evaluating setup for frpoly10r Iteration 0 of frpoly10r Timing for : frpoly10r Elapsed time = 3.060 seconds reclaim time = 1.189 seconds net compute time = 1.871 seconds Storage allocated: 69 fixp, 9236 listp Iteration 1 of frpoly10r Timing for : frpoly10r Elapsed time = 2.985 seconds reclaim time = 1.163 seconds net compute time = 1.822 seconds Storage allocated: 69 fixp, 9236 listp \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/pav-5-26.benchmarks b/internal/gabriel/Results/Lyric/pav-5-26.benchmarks new file mode 100644 index 00000000..3826fe87 --- /dev/null +++ b/internal/gabriel/Results/Lyric/pav-5-26.benchmarks @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Version: LISPCORE of 19-May-87 16:31:40 Software Type: Xerox Lisp Software Version: 19-May-87 15:27:21 Machine Type: Xerox 1186 Machine Version: microcode 89, 7424 pages Machine Instance: 2856398998 Site: unknown Features: (:interlisp :xerox :common) ***** tak Benchmark *** Tak Iteration 0 of tak Timing for : tak Elapsed time = 1.660 seconds net compute time = 1.684 seconds Iteration 1 of tak Timing for : tak Elapsed time = 1.684 seconds net compute time = 1.684 seconds ***** takr Benchmark *** TakR Iteration 0 of takr Timing for : takr Elapsed time = 1.711 seconds net compute time = 1.711 seconds Iteration 1 of takr Timing for : takr Elapsed time = 1.709 seconds net compute time = 1.709 seconds ***** takl Benchmark *** TakL Iteration 0 of takl Timing for : takl Elapsed time = 14.622 seconds net compute time = 14.622 seconds Iteration 1 of takl Timing for : takl Elapsed time = 14.613 seconds net compute time = 14.613 seconds ***** stak Benchmark *** STak Iteration 0 of stak Timing for : stak Elapsed time = 5.562 seconds net compute time = 5.562 seconds Iteration 1 of stak Timing for : stak Elapsed time = 5.569 seconds net compute time = 5.569 seconds ***** ctak Benchmark *** CTak Iteration 0 of ctak Timing for : ctak Elapsed time = 48.008 seconds SWAP time = 0.055 seconds reclaim time = 5.480 seconds net compute time = 42.473 seconds Page faults = 20 Storage allocated: 47707 listp Iteration 1 of ctak Timing for : ctak Elapsed time = 47.472 seconds reclaim time = 5.552 seconds net compute time = 41.920 seconds Storage allocated: 47707 listp ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 31.535 seconds reclaim time = 20.084 seconds net compute time = 11.451 seconds Page faults = 4 Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 32.813 seconds reclaim time = 21.314 seconds net compute time = 11.499 seconds Page faults = 6 Storage allocated: 120000 listp ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 36.547 seconds reclaim time = 22.812 seconds net compute time = 13.735 seconds Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 36.461 seconds reclaim time = 22.655 seconds net compute time = 13.806 seconds Page faults = 2 Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 20.272 seconds reclaim time = 6.296 seconds net compute time = 13.976 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 20.096 seconds reclaim time = 6.211 seconds net compute time = 13.885 seconds Storage allocated: 43105 listp ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 66.807 seconds reclaim time = 43.665 seconds net compute time = 23.142 seconds Page faults = 2 Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 66.887 seconds reclaim time = 43.858 seconds net compute time = 23.029 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 80.780 seconds reclaim time = 50.822 seconds net compute time = 29.958 seconds Page faults = 6 Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 80.362 seconds reclaim time = 50.231 seconds net compute time = 30.131 seconds Storage allocated: 260000 listp ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 136.938 seconds SWAP time = 0.053 seconds reclaim time = 37.645 seconds net compute time = 99.240 seconds Page faults = 516 Storage allocated: 226464 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 132.520 seconds reclaim time = 37.700 seconds net compute time = 94.820 seconds Storage allocated: 226464 listp, 272 compiled-closure ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 514.966 seconds SWAP time = 0.132 seconds reclaim time = 228.758 seconds net compute time = 286.076 seconds Page faults = 97 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 528.138 seconds reclaim time = 237.366 seconds net compute time = 290.772 seconds Page faults = 50 Storage allocated: 488945 listp, 229002 oned-array ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 292.764 seconds reclaim time = 112.000 seconds net compute time = 180.764 seconds Page faults = 51 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 293.884 seconds reclaim time = 112.679 seconds net compute time = 181.205 seconds Page faults = 50 Storage allocated: 488945 listp, 2202 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 747.135 seconds SWAP time = 0.064 seconds reclaim time = 0.513 seconds net compute time = 746.558 seconds Page faults = 1 Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 747.668 seconds reclaim time = 0.486 seconds net compute time = 747.182 seconds Storage allocated: 11626 listp ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 45.583 seconds net compute time = 45.583 seconds Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 45.584 seconds net compute time = 45.584 seconds Storage allocated: 10 listp, 4 oned-array ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 185.331 seconds SWAP time = 0.365 seconds reclaim time = 106.612 seconds net compute time = 78.354 seconds Page faults = 35 Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 184.159 seconds reclaim time = 106.493 seconds net compute time = 77.666 seconds Storage allocated: 942640 floatp ***** fprint Benchmark *** FPrint Iteration 0 of fprint Timing for : fprint Elapsed time = 12.013 seconds SWAP time = 0.200 seconds reclaim time = 0.352 seconds net compute time = 11.461 seconds Page faults = 4 Storage allocated: 73 fixp, 487 listp, 1 vmempagep, 1 stream, 70 oned-array, 1 process, 1 pathname, 49 pagegroup, 1 filedescriptor Iteration 1 of fprint Timing for : fprint Elapsed time = 12.444 seconds reclaim time = 0.536 seconds net compute time = 11.908 seconds Storage allocated: 262 fixp, 533 listp, 1 vmempagep, 1 stream, 89 oned-array, 2 etherpacket, 2 pathname, 52 pagegroup, 1 filedescriptor ***** fread Benchmark *** FRead Iteration 0 of fread Timing for : fread Elapsed time = 10.548 seconds reclaim time = 0.673 seconds net compute time = 9.875 seconds Storage allocated: 23 fixp, 6236 listp, 1 vmempagep, 1 stream, 79 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor Iteration 1 of fread Timing for : fread Elapsed time = 10.479 seconds reclaim time = 0.619 seconds net compute time = 9.860 seconds Storage allocated: 23 fixp, 6236 listp, 1 vmempagep, 1 stream, 79 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor ***** tprint Benchmark *** TPrint Evaluating setup for tprint Iteration 0 of tprint Timing for : tprint Elapsed time = 24.901 seconds net compute time = 24.901 seconds Storage allocated: 4 listp Evaluating after every function for tprint Iteration 1 of tprint Timing for : tprint Elapsed time = 24.912 seconds net compute time = 24.912 seconds Storage allocated: 4 listp Evaluating after every function for tprint Evaluating after function for tprint ***** traverse-init* Benchmark *** Traverse, Initialize Iteration 0 of traverse-init* Timing for : traverse-init* Elapsed time = 78.289 seconds reclaim time = 1.678 seconds net compute time = 76.611 seconds Page faults = 9 Storage allocated: 36796 listp, 100 tnode Evaluating after every function for traverse-init* Iteration 1 of traverse-init* Timing for : traverse-init* Elapsed time = 78.170 seconds reclaim time = 1.581 seconds net compute time = 76.589 seconds Page faults = 2 Storage allocated: 36796 listp, 100 tnode Evaluating after every function for traverse-init* ***** traverse* Benchmark *** Traverse, Traverse Evaluating setup for traverse* Iteration 0 of traverse* Timing for : traverse* Elapsed time = 145.081 seconds net compute time = 145.081 seconds Iteration 1 of traverse* Timing for : traverse* Elapsed time = 145.081 seconds net compute time = 145.081 seconds Evaluating after function for traverse* \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/summary.tedit b/internal/gabriel/Results/Lyric/summary.tedit new file mode 100644 index 0000000000000000000000000000000000000000..1c552d3d17ad0c6271a4f52dc9e6daa0dbb27ae6 GIT binary patch literal 5005 zcmb_eO^@SB6?JCjA(izIi-(Xv2-V|jlA%-MZ#(EQQg@?%jF=I_O#c8XPIY39V+Vhv zNuww6Ls%kUgT#UrOIG|07W@E~EIGGqrxUwpdY(iU75n<_WX;cgYDZ6_5bw0G2BwNX{{^4#v3z{7DUz%@;TMIHixYmSUneJAW(&P? z=YNx@yDVQPGCiDrtqR4nyy8g~r}YByjIWcFAbg=@TJh_oS|QktEM%q9-9+%qLT*)2 zs%erXm0qT^aP4hT@3C9ru)*-DVNl`L1hlJiuRdhJ4G3q-@KWSwM~hO@znvbxs zQcm>N3$-coMIDn2O8JU!L)z&N8g2H<;qo;~d~} zSLSs^m0>&6m#43%QAj>7YBC+Utda$Dlq?f!*n`b^JX zj7t@l6Gl{NA74wHxd|uC7U2v-;9{^XG8K4=Jo-R`6_{_3A7(oum@!ZIGvi zbT<@Z)^KRON!1!9hO$mFT^H|>1}w!-(`uF1OH}loG7`5k!WTKpeXgoX6(k-MJ5_nJ zh7PlXo-}GSZQmCSHqNsW9>$9re9S5Mms`|XHR01K93>?vR;R?-ZdcfXyp}uEu0F`q zLR~%HefU|j@%g51&a!>fXW2ZPuj-qdR533ScGQl3AOeduqa`9A#}WDFWs%5i$-)Sf z^Yot+ve3gRI{3p0+jRE69?Xl2O9qZo0YtWNEN0Je=n(@0y%7Fp7{(n3A zX|i>u&zb8B57D3q9p=o0?XgJAs6HLkp73l_<6bjYf3rP=!(2}U0ad0)7+Y63fU1#7 z=GeMqePLPp89VlcOJsln`w0Opk}V4@;rh(+h2yfo6QM?^6qb(bUycY?gS!QKgcv^F?x%pgO4s z5%Jm{JlAm?sQ&dTiB}vAi24LiI%+m-Z70PmS=f9n<02m)L0ZTt z>Imd&2QA1LPz!X(Gp|$Skcv(ZTAwlCYoLclq&?vV&}a;eTsI@?myoXZ1HlG~+M$td zJ+|c$*?axANyPO4CHH2+rG<1MJ7y;|HkbxE(Bq-#I7BTPI-zlF(8%*ZH2hmV-GST? zIt;baM4+0*f`D*Gs)L$$Sb#3oRB)#ZmT+t~0}YNuqLsSP-zx)X)@=JwBLJfWM&7M1 z*by}?WGOn52!M#0(9VYKfi0j4wwN6W1OTLnxLbCjU?GR33G7fF^tqAHbdq2JhD}4O zdh!6q5^W)S)InQOZ~;ehLQ4LzK#&{&?t5(Pc5vvz0sdGcx&lH@Jv3-73y^zWZWKzp z-f%EtiR&qE8{9eprQ>{o`&hl%_ncDUQFRh7ix19fAqdz$+Y zjgGie+(%1XSW9Z@njQeVla`ywQh%ZwG~MR(WsdHPn%(HFuj)C3Vuc`W+lu&BrZqf4 zmFR|0R=BbY{${tH=jk+)Yr5&`Mh)$!I9K>im)mY-iqpfb;VwOE1yIYF+~&zbFGKQp z;NPI%N5&)LC-gA-FO7!raAX)?F@9wjzc-A38zXLvR>tTL`0$S3-IM=p82>Rwkumz6 zG5Y5_X2KlOr^A&W8NbmpvF2ajJ?)}DjTxUAH1ltI@<|)>=wHTzZ@=3MeR*U&G(Ist z`uz0#XQ#$j_t+0GJ!rrW;KDFg^zu+!8UvDeZ1`H=pb?D|J!O;<;=o|^5yqQ)5#PTT z;r0<;-*7)-5ZHJ6K8_HSmnVei5=8%>kfGZx8NS{(e6w%(M&IzQzG1NJRUh%EzF{zB zVEFXCQwVMmqT3u9CS>R~M}}$NFg`R8l2H38cN#u@FM{R|;y7A`5QD&ebm){2_fI+L zPZ=1TK7t(YH%BjD^bG@q&fZ}Pk1B}ZgDHQx*QpNd@SwiipYpxF;Rp8`jyQK`V1ulS zzSF@m3^q47m&bh{IzfjS`(Yn3m@fprint.tst") 15: REVERT T69Breakpoint at T69. 17: return NIL Timing for : FREAD Elapsed time = 617.560 seconds SWAP time = 148.260 seconds reclaim time = 50.380 seconds net compute time = 418.920 seconds Disk operations = 3 Storage allocated: 395 FIXP, 397 FLOATP, 15144 LISTP, 7 ARRAYP, 38 STACKP, 128 STREAM, 47 BITMAP, 23 COMPILED-CLOSURE, 1272 ONED-ARRAY, 1 FDEV, 14 COREFILEINFOBLK, 1 ENVIRONMENT, 4 RESTART, 1 PROCEED-CASE, 12 PROCESS, 15 EVENT, 4 MONITORLOCK, 12 SYSQUEUE, 18 ETHERPACKET, 11 NSADDRESS, 1 PUPSOCKET, 28 PILOTBBT, 28 \DISPLAYDATA, 1 BSPSOC, 1 REVERT, 2 FILE-NOT-FOUND, 1 PATHNAME, 2 CURSOR, 10 MENU, 20 WINDOW, 6 NSOCKET, 3 SPPCON, 8 NSNAME, 5 SELECTION, 1 THISLINE, 103 LINEDESCRIPTOR, 1 LINECACHE, 9 PIECE, 1 TEXTOBJ, 1 TEXTIMAGEDATA, 1 CHARLOOKS, 2 FMTSPEC, 1 TEDITCARET, 89 TABLEITEM, 89 FBFILEDATA Iteration 1 of FREAD In OPEN: File not found: #.(PATHNAME "{dsk}fprint.tst") 18: bt OPEN FREAD T69 CL::%GET-TIMING-INFO CL::TIME-CALL SI::*UNWIND-PROTECT* RUN-BENCHMARKS APPLY 19: revert T69 T69Breakpoint at T69. 20: return NIL Timing for : FREAD Elapsed time = 24.620 seconds SWAP time = 3.240 seconds reclaim time = 2.220 seconds net compute time = 19.160 seconds Storage allocated: 32 FIXP, 688 LISTP, 18 STACKP, 6 STREAM, 4 BITMAP, 8 COMPILED-CLOSURE, 37 ONED-ARRAY, 2 COREFILEINFOBLK, 1 ENVIRONMENT, 2 RESTART, 1 PROCEED-CASE, 2 PILOTBBT, 2 \DISPLAYDATA, 1 REVERT, 1 CONTROL-E-INTERRUPT, 1 FILE-NOT-FOUND, 1 PATHNAME, 2 WINDOW ***** FPRINT Benchmark *** FPrint Iteration 0 of FPRINT In IL:\\OPENFILE: File not found: {dsk}fprint.tst 21: bt IL:OPENSTREAM OPEN FPRINT T68 CL::%GET-TIMING-INFO CL::TIME-CALL SI::*UNWIND-PROTECT* RUN-BENCHMARKS 22: revert t68 T68Breakpoint at T68. 23: return NIL Timing for : FPRINT Elapsed time = 26.480 seconds SWAP time = 3.420 seconds reclaim time = 2.360 seconds net compute time = 20.700 seconds Disk operations = 1 Storage allocated: 43 FIXP, 777 LISTP, 19 STACKP, 7 STREAM, 4 BITMAP, 8 COMPILED-CLOSURE, 70 ONED-ARRAY, 2 COREFILEINFOBLK, 1 ENVIRONMENT, 2 RESTART, 2 PILOTBBT, 2 \DISPLAYDATA, 1 REVERT, 1 CONTROL-E-INTERRUPT, 1 FILE-NOT-FOUND, 1 PATHNAME, 2 WINDOW Iteration 1 of FPRINT In IL:\\OPENFILE: File not found: {dsk}fprint.tst 24: !revert !REVERT is an unbound variable. 25: redo revert T68Breakpoint at T68. 26: return NIL Timing for : FPRINT Elapsed time = 17.180 seconds SWAP time = 2.100 seconds reclaim time = 1.520 seconds net compute time = 13.560 seconds Storage allocated: 33 FIXP, 694 LISTP, 20 STACKP, 6 STREAM, 4 BITMAP, 7 COMPILED-CLOSURE, 61 ONED-ARRAY, 2 COREFILEINFOBLK, 1 ENVIRONMENT, 2 RESTART, 2 PILOTBBT, 2 \DISPLAYDATA, 1 UNBOUND-VARIABLE, 1 REVERT, 1 FILE-NOT-FOUND, 1 PATHNAME, 2 WINDOW ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 474.440 seconds SWAP time = 1.680 seconds reclaim time = 361.800 seconds net compute time = 110.960 seconds Storage allocated: 942640 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 474.400 seconds SWAP time = 1.580 seconds reclaim time = 361.720 seconds net compute time = 111.100 seconds Storage allocated: 942640 FLOATP ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 75.960 seconds SWAP time = 0.260 seconds reclaim time = 56.260 seconds net compute time = 19.440 seconds Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 75.080 seconds SWAP time = 0.220 seconds reclaim time = 55.340 seconds net compute time = 19.520 seconds ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 72.580 seconds SWAP time = 0.300 seconds reclaim time = 55.240 seconds net compute time = 17.040 seconds Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 72.660 seconds SWAP time = 0.300 seconds reclaim time = 55.200 seconds net compute time = 17.160 seconds ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 62.780 seconds SWAP time = 0.100 seconds reclaim time = 20.780 seconds net compute time = 41.900 seconds Storage allocated: 43105 LISTP Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 62.660 seconds SWAP time = 0.080 seconds reclaim time = 20.780 seconds net compute time = 41.800 seconds ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 149.060 seconds SWAP time = 0.420 seconds reclaim time = 119.300 seconds net compute time = 29.340 seconds Iteration 1 of DERIV Timing for : DERIV Elapsed time = 149.040 seconds SWAP time = 0.300 seconds reclaim time = 119.000 seconds net compute time = 29.740 seconds Storage allocated: 48392 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 195.460 seconds SWAP time = 0.340 seconds reclaim time = 130.520 seconds net compute time = 64.600 seconds Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 195.480 seconds SWAP time = 0.500 seconds reclaim time = 130.520 seconds net compute time = 64.460 seconds ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 848.620 seconds SWAP time = 1.420 seconds reclaim time = 455.440 seconds net compute time = 391.760 seconds Storage allocated: 97931 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 856.460 seconds SWAP time = 1.540 seconds reclaim time = 460.580 seconds net compute time = 394.340 seconds Storage allocated: 97931 LISTP, 229002 ONED-ARRAY ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 240.840 seconds SWAP time = 0.700 seconds reclaim time = 98.400 seconds net compute time = 141.740 seconds Storage allocated: 29856 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 240.860 seconds SWAP time = 0.520 seconds reclaim time = 98.500 seconds net compute time = 141.840 seconds Storage allocated: 29856 LISTP ***** TRAVERSE-INIT* Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 230.860 seconds SWAP time = 0.220 seconds reclaim time = 3.680 seconds net compute time = 226.960 seconds Storage allocated: 100 TNODE Evaluating after every function for TRAVERSE-INIT* Iteration 1 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 231.700 seconds SWAP time = 0.360 seconds reclaim time = 3.660 seconds net compute time = 227.680 seconds Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* ***** TRAVERSE* Benchmark *** Traverse, Traverse Evaluating setup for TRAVERSE* Iteration 0 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 322.020 seconds SWAP time = 0.180 seconds net compute time = 321.840 seconds Iteration 1 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 322.000 seconds SWAP time = 0.300 seconds net compute time = 321.700 seconds Evaluating after function for TRAVERSE* ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 538.920 seconds SWAP time = 0.820 seconds reclaim time = 304.620 seconds net compute time = 233.480 seconds Storage allocated: 97931 LISTP, 2202 ONED-ARRAY Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 519.960 seconds SWAP time = 0.940 seconds reclaim time = 285.440 seconds net compute time = 233.580 seconds Storage allocated: 32395 LISTP, 2202 ONED-ARRAY \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1132-BYTE-TAK.Results b/internal/gabriel/Results/Maiko/1132-BYTE-TAK.Results new file mode 100644 index 00000000..e45d2981 --- /dev/null +++ b/internal/gabriel/Results/Maiko/1132-BYTE-TAK.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 30-May-88 14:50:05 Software Type: Xerox AIE Software Version: Lispcore sysout of 30-May-88 14:50:05, Make-init dates: 30-May-88 13:52:01, 30-May-88 14:02:15 Machine Type: Xerox 1132 Machine Version: Microcode version: 5682, memory size: 16384 Machine Instance: Amontillado = 12542500312# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 21.905 seconds net compute time = 21.905 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 21.904 seconds net compute time = 21.904 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 1.872 seconds net compute time = 1.872 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 1.872 seconds net compute time = 1.872 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 0.514 seconds net compute time = 0.514 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 0.515 seconds net compute time = 0.515 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 3.898 seconds net compute time = 3.898 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 3.898 seconds net compute time = 3.898 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 0.703 seconds net compute time = 0.703 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 0.703 seconds net compute time = 0.703 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1132-PAV-TAK.Results b/internal/gabriel/Results/Maiko/1132-PAV-TAK.Results new file mode 100644 index 00000000..01917d49 --- /dev/null +++ b/internal/gabriel/Results/Maiko/1132-PAV-TAK.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 28-Jun-88 09:39:24 Software Type: Xerox AIE Software Version: Lispcore sysout of 28-Jun-88 09:39:24, Make-init dates: 27-Jun-88 17:23:26, 27-Jun-88 17:33:19 Machine Type: Xerox 1132 Machine Version: Microcode version: 5682, memory size: 16384 Machine Instance: Amontillado = 12542500312# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 21.918 seconds SWAP time = 0.089 seconds net compute time = 21.829 seconds Page faults = 4 Disk operations = 4 Iteration 1 of CTAK Timing for : CTAK Elapsed time = 21.826 seconds net compute time = 21.826 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 1.873 seconds net compute time = 1.873 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 1.872 seconds net compute time = 1.872 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 0.514 seconds net compute time = 0.514 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 0.513 seconds net compute time = 0.513 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 3.815 seconds net compute time = 3.815 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 3.815 seconds net compute time = 3.815 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 0.917 seconds SWAP time = 0.229 seconds net compute time = 0.688 seconds Page faults = 17 Disk operations = 17 Iteration 1 of TAKR Timing for : TAKR Elapsed time = 0.679 seconds net compute time = 0.679 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1186-BYTE-CONSY.Results b/internal/gabriel/Results/Maiko/1186-BYTE-CONSY.Results new file mode 100644 index 00000000..34928194 --- /dev/null +++ b/internal/gabriel/Results/Maiko/1186-BYTE-CONSY.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 19-Jul-88 19:48:02 Software Type: Xerox AIE Software Version: Medley sysout of 19-Jul-88 19:48:02, Make-init dates: 19-Jul-88 18:28:31, 19-Jul-88 18:39:48 Machine Type: Xerox 1186 Machine Version: Microcode version: 113, memory size: 7424 Machine Instance: Shih1186 = 25220200562# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 70.069 seconds reclaim time = 46.591 seconds net compute time = 23.516 seconds Page faults = 20 Storage allocated: 245000 LISTP Iteration 1 of DERIV Timing for : DERIV Elapsed time = 66.234 seconds reclaim time = 44.768 seconds net compute time = 21.466 seconds Page faults = 2 Storage allocated: 245000 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 83.047 seconds reclaim time = 52.683 seconds net compute time = 30.364 seconds Page faults = 2 Storage allocated: 260000 LISTP Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 81.864 seconds reclaim time = 52.292 seconds net compute time = 29.572 seconds Storage allocated: 260000 LISTP ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 31.475 seconds reclaim time = 21.810 seconds net compute time = 9.665 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 31.266 seconds reclaim time = 21.388 seconds net compute time = 9.878 seconds Storage allocated: 120000 LISTP ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 33.603 seconds reclaim time = 22.857 seconds net compute time = 10.746 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 33.087 seconds reclaim time = 22.412 seconds net compute time = 10.675 seconds Storage allocated: 120000 LISTP ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 22.533 seconds reclaim time = 6.364 seconds net compute time = 16.169 seconds Storage allocated: 43105 LISTP Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 22.308 seconds reclaim time = 6.277 seconds net compute time = 16.031 seconds Storage allocated: 43105 LISTP ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 123.725 seconds reclaim time = 41.036 seconds net compute time = 82.689 seconds Page faults = 522 Storage allocated: 226464 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 121.814 seconds reclaim time = 41.857 seconds net compute time = 79.957 seconds Storage allocated: 226464 LISTP ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 558.774 seconds SWAP time = 0.055 seconds reclaim time = 258.202 seconds net compute time = 300.517 seconds Page faults = 92 Storage allocated: 491147 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 573.668 seconds reclaim time = 266.281 seconds net compute time = 307.387 seconds Page faults = 50 Storage allocated: 491147 LISTP, 229002 ONED-ARRAY ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 292.462 seconds reclaim time = 125.844 seconds net compute time = 166.618 seconds Page faults = 51 Storage allocated: 491147 LISTP, 2202 ONED-ARRAY Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 303.437 seconds reclaim time = 131.858 seconds net compute time = 171.579 seconds Page faults = 50 Storage allocated: 491147 LISTP, 2202 ONED-ARRAY ***** TRAVERSE-INIT* Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 88.822 seconds reclaim time = 1.591 seconds net compute time = 87.231 seconds Page faults = 9 Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* Iteration 1 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 81.917 seconds reclaim time = 1.606 seconds net compute time = 80.311 seconds Page faults = 2 Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* ***** TRAVERSE* Benchmark *** Traverse, Traverse Evaluating setup for TRAVERSE* Iteration 0 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 139.586 seconds net compute time = 139.586 seconds Iteration 1 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 139.588 seconds net compute time = 139.588 seconds Evaluating after function for TRAVERSE* \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1186-IO.Results b/internal/gabriel/Results/Maiko/1186-IO.Results new file mode 100644 index 00000000..f9c9f62b --- /dev/null +++ b/internal/gabriel/Results/Maiko/1186-IO.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 28-Jun-88 09:39:24 Software Type: Xerox AIE Software Version: Lispcore sysout of 28-Jun-88 09:39:24, Make-init dates: 27-Jun-88 17:23:26, 27-Jun-88 17:33:19 Machine Type: Xerox 1186 Machine Version: Microcode version: 113, memory size: 7424 Machine Instance: Wills1186 = 25220220072# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FPRINT Benchmark *** FPrint Iteration 0 of FPRINT Timing for : FPRINT Elapsed time = 11.202 seconds SWAP time = 0.126 seconds reclaim time = 0.458 seconds net compute time = 10.618 seconds Page faults = 5 Storage allocated: 201 FIXP, 527 LISTP, 10 VMEMPAGEP, 1 STREAM, 48 ONED-ARRAY, 2 PATHNAME, 52 PageGroup, 1 FileDescriptor Iteration 1 of FPRINT Timing for : FPRINT Elapsed time = 10.880 seconds reclaim time = 0.435 seconds net compute time = 10.445 seconds Storage allocated: 184 FIXP, 522 LISTP, 10 VMEMPAGEP, 1 STREAM, 48 ONED-ARRAY, 4 ETHERPACKET, 2 PATHNAME, 48 PageGroup, 1 FileDescriptor ***** FREAD Benchmark *** FRead Iteration 0 of FREAD Timing for : FREAD Elapsed time = 10.199 seconds SWAP time = 0.061 seconds reclaim time = 0.704 seconds net compute time = 9.434 seconds Page faults = 5 Storage allocated: 119 FIXP, 6247 LISTP, 4 VMEMPAGEP, 1 STREAM, 64 ONED-ARRAY, 2 PATHNAME, 37 PageGroup, 1 FileDescriptor Iteration 1 of FREAD Timing for : FREAD Elapsed time = 10.133 seconds SWAP time = 0.062 seconds reclaim time = 0.664 seconds net compute time = 9.407 seconds Page faults = 1 Storage allocated: 119 FIXP, 6247 LISTP, 4 VMEMPAGEP, 1 STREAM, 64 ONED-ARRAY, 2 PATHNAME, 37 PageGroup, 1 FileDescriptor ***** TPRINT Benchmark *** TPrint Evaluating setup for TPRINT Iteration 0 of TPRINT Timing for : TPRINT Elapsed time = 23.227 seconds net compute time = 23.227 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Iteration 1 of TPRINT Timing for : TPRINT Elapsed time = 23.238 seconds net compute time = 23.238 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Evaluating after function for TPRINT ***** READ-FLOAT Benchmark *** Read 2000 Floats from {CORE} Iteration 0 of READ-FLOAT Timing for : IL:READ-FLOAT Elapsed time = 16.040 seconds reclaim time = 1.706 seconds net compute time = 14.334 seconds Page faults = 15 Storage allocated: 8519 FIXP, 2000 FLOATP, 2006 LISTP, 1 STREAM, 1 ONED-ARRAY, 4 ETHERPACKET Iteration 1 of READ-FLOAT Timing for : IL:READ-FLOAT Elapsed time = 14.792 seconds reclaim time = 1.430 seconds net compute time = 13.362 seconds Storage allocated: 8520 FIXP, 2000 FLOATP, 2006 LISTP, 1 STREAM, 1 ONED-ARRAY ***** PRINT-FLOAT Benchmark *** Print 2000 Floats to {NULL} Iteration 0 of PRINT-FLOAT Timing for : IL:PRINT-FLOAT Elapsed time = 69.916 seconds SWAP time = 0.178 seconds reclaim time = 3.429 seconds net compute time = 66.309 seconds Page faults = 64 Storage allocated: 8065 FIXP, 4004 LISTP, 1 STREAM, 4000 ONED-ARRAY Iteration 1 of PRINT-FLOAT Timing for : IL:PRINT-FLOAT Elapsed time = 69.161 seconds SWAP time = 0.022 seconds reclaim time = 3.115 seconds net compute time = 66.024 seconds Page faults = 1 Storage allocated: 8065 FIXP, 4004 LISTP, 1 STREAM, 4000 ONED-ARRAY ***** TERMINAL-PRINTING Benchmark *** Printing chars to terminal Evaluating setup for TERMINAL-PRINTING Iteration 0 of TERMINAL-PRINTING Timing for : IL:TERMINAL-PRINTING Elapsed time = 111.776 seconds net compute time = 111.776 seconds Storage allocated: 4 FIXP, 12 LISTP, 1 STREAM, 1 COREFILEINFOBLK Iteration 1 of TERMINAL-PRINTING Timing for : IL:TERMINAL-PRINTING Elapsed time = 111.749 seconds net compute time = 111.749 seconds Storage allocated: 4 LISTP Evaluating after function for TERMINAL-PRINTING ***** READ-EXISTING-SYMBOLS Benchmark *** Read 1000 symbols that exist in the sysout already Iteration 0 of READ-EXISTING-SYMBOLS Timing for : IL:READ-EXISTING-SYMBOLS Elapsed time = 9.377 seconds SWAP time = 0.062 seconds reclaim time = 0.707 seconds net compute time = 8.608 seconds Page faults = 51 Storage allocated: 13 FIXP, 2 FLOATP, 3056 LISTP, 1 STREAM, 13 ONED-ARRAY Iteration 1 of READ-EXISTING-SYMBOLS Timing for : IL:READ-EXISTING-SYMBOLS Elapsed time = 5.575 seconds reclaim time = 0.601 seconds net compute time = 4.974 seconds Storage allocated: 2 FIXP, 3005 LISTP, 1 STREAM, 11 ONED-ARRAY, 2 NSADDRESS ***** READ-DSK Benchmark *** Read 50,000 bytes from a file on {DSK} Evaluating setup for READ-DSK Iteration 0 of READ-DSK Timing for : IL:READ-DSK Elapsed time = 3.758 seconds net compute time = 3.758 seconds Page faults = 4 Storage allocated: 259 FIXP, 410 LISTP, 7 VMEMPAGEP, 1 STREAM, 14 ONED-ARRAY, 101 PageGroup, 1 FileDescriptor Iteration 1 of READ-DSK Timing for : IL:READ-DSK Elapsed time = 3.668 seconds net compute time = 3.668 seconds Storage allocated: 259 FIXP, 410 LISTP, 7 VMEMPAGEP, 1 STREAM, 14 ONED-ARRAY, 101 PageGroup, 1 FileDescriptor Evaluating after function for READ-DSK ***** READ-CORE Benchmark *** Read 50,000 bytes from CORE. Evaluating setup for READ-CORE Iteration 0 of READ-CORE Timing for : IL:READ-CORE Elapsed time = 1.934 seconds reclaim time = 0.135 seconds net compute time = 1.799 seconds Storage allocated: 2 FIXP, 5 LISTP, 1 STREAM, 1 ONED-ARRAY Iteration 1 of READ-CORE Timing for : IL:READ-CORE Elapsed time = 1.898 seconds reclaim time = 0.132 seconds net compute time = 1.766 seconds Storage allocated: 2 FIXP, 5 LISTP, 1 STREAM, 1 ONED-ARRAY Evaluating after function for READ-CORE ***** WRITE-DSK Benchmark *** Write 50,000 bytes on on {DSK} Iteration 0 of WRITE-DSK Timing for : IL:WRITE-DSK Elapsed time = 19.100 seconds SWAP time = 1.951 seconds reclaim time = 1.271 seconds net compute time = 15.878 seconds Page faults = 309 Swap writes = 3 Storage allocated: 412 FIXP, 1927 LISTP, 7 VMEMPAGEP, 7 STREAM, 5 BITMAP, 2 COMPILED-CLOSURE, 19 ONED-ARRAY, 2 COREFILEINFOBLK, 2 PROCESS, 4 PILOTBBT, 4 \DISPLAYDATA, 1 CURSOR, 3 WINDOW, 125 PageGroup, 1 FileDescriptor Iteration 1 of WRITE-DSK Timing for : IL:WRITE-DSK Elapsed time = 12.973 seconds reclaim time = 0.438 seconds net compute time = 12.535 seconds Swap writes = 2 Storage allocated: 377 FIXP, 597 LISTP, 7 VMEMPAGEP, 1 STREAM, 17 ONED-ARRAY, 125 PageGroup, 1 FileDescriptor Evaluating after function for WRITE-DSK ***** WRITE-CORE Benchmark *** Write 50,000 bytes to a file on {CORE} Iteration 0 of WRITE-CORE Timing for : IL:WRITE-CORE Elapsed time = 11.399 seconds SWAP time = 0.237 seconds reclaim time = 0.935 seconds net compute time = 10.227 seconds Page faults = 49 Swap writes = 21 Storage allocated: 6 FIXP, 231 LISTP, 1 STREAM, 4 ONED-ARRAY, 1 COREFILEINFOBLK Iteration 1 of WRITE-CORE Timing for : IL:WRITE-CORE Elapsed time = 11.165 seconds reclaim time = 0.720 seconds net compute time = 10.445 seconds Page faults = 98 Swap writes = 31 Storage allocated: 6 FIXP, 227 LISTP, 1 STREAM, 4 ONED-ARRAY, 1 COREFILEINFOBLK Evaluating after function for WRITE-CORE \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1186-PAV-AREFY.Results b/internal/gabriel/Results/Maiko/1186-PAV-AREFY.Results new file mode 100644 index 00000000..94329d01 --- /dev/null +++ b/internal/gabriel/Results/Maiko/1186-PAV-AREFY.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 6-Jun-88 15:12:28 Software Type: Xerox AIE Software Version: Medley sysout of 6-Jun-88 15:12:28, Make-init dates: 6-Jun-88 13:44:45, 6-Jun-88 13:55:29 Machine Type: Xerox 1186 Machine Version: Microcode version: 111, memory size: 7424 Machine Instance: Shih1186 = 25220200562# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 46.210 seconds net compute time = 46.210 seconds Storage allocated: 10 LISTP, 1 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 46.207 seconds net compute time = 46.207 seconds Storage allocated: 10 LISTP, 1 ONED-ARRAY ***** TRIANG Benchmark *** Triang Iteration 0 of TRIANG Timing for : TRIANG Elapsed time = 822.291 seconds SWAP time = 0.023 seconds reclaim time = 0.601 seconds net compute time = 821.667 seconds Page faults = 71 Storage allocated: 11626 LISTP Iteration 1 of TRIANG Timing for : TRIANG Elapsed time = 821.879 seconds reclaim time = 0.592 seconds net compute time = 821.287 seconds Storage allocated: 11626 LISTP ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 248.317 seconds SWAP time = 0.614 seconds reclaim time = 137.099 seconds net compute time = 110.604 seconds Page faults = 43 Storage allocated: 942640 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 247.126 seconds reclaim time = 136.751 seconds net compute time = 110.375 seconds Storage allocated: 942640 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1186-PAV-CONSY.Results b/internal/gabriel/Results/Maiko/1186-PAV-CONSY.Results new file mode 100644 index 00000000..57e2cb10 --- /dev/null +++ b/internal/gabriel/Results/Maiko/1186-PAV-CONSY.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 28-Jun-88 09:39:24 Software Type: Xerox AIE Software Version: Lispcore sysout of 28-Jun-88 09:39:24, Make-init dates: 27-Jun-88 17:23:26, 27-Jun-88 17:33:19 Machine Type: Xerox 1186 Machine Version: Microcode version: 113, memory size: 7424 Machine Instance: Wills1186 = 25220220072# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 82.750 seconds reclaim time = 55.484 seconds net compute time = 27.266 seconds Page faults = 5 Swap writes = 5 Storage allocated: 245000 LISTP Iteration 1 of DERIV Timing for : DERIV Elapsed time = 81.878 seconds reclaim time = 55.356 seconds net compute time = 26.522 seconds Page faults = 2 Swap writes = 2 Storage allocated: 245000 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 97.316 seconds reclaim time = 62.950 seconds net compute time = 34.366 seconds Page faults = 2 Swap writes = 2 Storage allocated: 260000 LISTP Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 97.426 seconds reclaim time = 62.702 seconds net compute time = 34.724 seconds Storage allocated: 260000 LISTP ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 38.395 seconds reclaim time = 25.727 seconds net compute time = 12.668 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 38.710 seconds reclaim time = 25.939 seconds net compute time = 12.771 seconds Storage allocated: 120000 LISTP ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 43.355 seconds reclaim time = 27.620 seconds net compute time = 15.735 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 42.932 seconds reclaim time = 27.414 seconds net compute time = 15.518 seconds Storage allocated: 120000 LISTP ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 23.053 seconds reclaim time = 7.639 seconds net compute time = 15.414 seconds Storage allocated: 43105 LISTP Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 23.305 seconds reclaim time = 7.990 seconds net compute time = 15.315 seconds Storage allocated: 43105 LISTP ***** TRAVERSE-INIT* Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 85.646 seconds reclaim time = 1.826 seconds net compute time = 83.820 seconds Page faults = 394 Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* Iteration 1 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 81.617 seconds reclaim time = 1.701 seconds net compute time = 79.916 seconds Page faults = 2 Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* ***** TRAVERSE* Benchmark *** Traverse, Traverse Evaluating setup for TRAVERSE* Iteration 0 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 150.143 seconds net compute time = 150.143 seconds Iteration 1 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 150.145 seconds net compute time = 150.145 seconds Evaluating after function for TRAVERSE* ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 151.560 seconds reclaim time = 51.161 seconds net compute time = 100.399 seconds Page faults = 113 Storage allocated: 226464 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 149.775 seconds reclaim time = 50.858 seconds net compute time = 98.917 seconds Storage allocated: 226464 LISTP ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 617.725 seconds SWAP time = 0.041 seconds reclaim time = 298.729 seconds net compute time = 318.955 seconds Page faults = 64 Storage allocated: 491147 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 640.112 seconds reclaim time = 310.729 seconds net compute time = 329.383 seconds Page faults = 50 Storage allocated: 491147 LISTP, 229002 ONED-ARRAY ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 330.884 seconds reclaim time = 161.267 seconds net compute time = 169.617 seconds Page faults = 66 Storage allocated: 491147 LISTP, 2202 ONED-ARRAY Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 341.451 seconds reclaim time = 166.544 seconds net compute time = 174.907 seconds Page faults = 48 Storage allocated: 491147 LISTP, 2202 ONED-ARRAY \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/1186-PAV-TAK.Results b/internal/gabriel/Results/Maiko/1186-PAV-TAK.Results new file mode 100644 index 00000000..7d2b19db --- /dev/null +++ b/internal/gabriel/Results/Maiko/1186-PAV-TAK.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 6-Jun-88 15:12:28 Software Type: Xerox AIE Software Version: Medley sysout of 6-Jun-88 15:12:28, Make-init dates: 6-Jun-88 13:44:45, 6-Jun-88 13:55:29 Machine Type: Xerox 1186 Machine Version: Microcode version: 111, memory size: 7424 Machine Instance: Shih1186 = 25220200562# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 56.758 seconds net compute time = 56.758 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 56.757 seconds net compute time = 56.757 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 4.481 seconds net compute time = 4.481 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 4.482 seconds net compute time = 4.482 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 1.632 seconds net compute time = 1.632 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 1.632 seconds net compute time = 1.632 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 13.413 seconds net compute time = 13.413 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 13.413 seconds net compute time = 13.413 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 1.713 seconds net compute time = 1.713 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 1.711 seconds net compute time = 1.711 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-BYTE-AREFY.RESULTS b/internal/gabriel/Results/Maiko/SUN-BYTE-AREFY.RESULTS new file mode 100644 index 00000000..7b876370 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-BYTE-AREFY.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 20-Jun-88 19:23:27 Software Type: Xerox AIE Software Version: Lispcore sysout of 20-Jun-88 19:23:27, Make-init dates: 20-Jun-88 18:24:36, 20-Jun-88 18:34:47 Machine Type: MAIKO Machine Version: Microcode version: 266, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 71.640 seconds SWAP time = 0.040 seconds net compute time = 71.600 seconds Storage allocated: 10 LISTP, 1 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 71.640 seconds SWAP time = 0.080 seconds net compute time = 71.560 seconds Storage allocated: 10 LISTP, 1 ONED-ARRAY ***** TRIANG Benchmark *** Triang Iteration 0 of TRIANG Timing for : TRIANG Elapsed time = 1486.440 seconds SWAP time = 0.960 seconds reclaim time = 1.440 seconds net compute time = 1484.040 seconds Iteration 1 of TRIANG Timing for : TRIANG Elapsed time = 1486.540 seconds SWAP time = 1.080 seconds reclaim time = 1.440 seconds net compute time = 1484.020 seconds Storage allocated: 11626 LISTP ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 343.640 seconds SWAP time = 1.680 seconds reclaim time = 234.820 seconds net compute time = 107.140 seconds Storage allocated: 942640 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 343.620 seconds SWAP time = 1.800 seconds reclaim time = 234.860 seconds net compute time = 106.960 seconds Storage allocated: 942640 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-BYTE-ARITH.RESULTS b/internal/gabriel/Results/Maiko/SUN-BYTE-ARITH.RESULTS new file mode 100644 index 00000000..ecdc15fe --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-BYTE-ARITH.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 20-Jun-88 19:23:27 Software Type: Xerox AIE Software Version: Lispcore sysout of 20-Jun-88 19:23:27, Make-init dates: 20-Jun-88 18:24:36, 20-Jun-88 18:34:47 Machine Type: MAIKO Machine Version: Microcode version: 266, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** NULL-LOOP Benchmark *** Null loop, 1000 times thru Iteration 0 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 101.680 seconds SWAP time = 0.140 seconds reclaim time = 5.600 seconds net compute time = 95.940 seconds Storage allocated: 3 FIXP, 20322 LISTP, 5 ENVIRONMENT Iteration 1 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 101.320 seconds SWAP time = 0.100 seconds reclaim time = 5.620 seconds net compute time = 95.600 seconds Storage allocated: 2 FIXP, 20218 LISTP, 5 ENVIRONMENT ***** FLOAT-ADD Benchmark *** 1000 Floating-point additions Iteration 0 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 120.920 seconds SWAP time = 0.160 seconds reclaim time = 8.000 seconds net compute time = 112.760 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 5 ENVIRONMENT Iteration 1 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 120.640 seconds SWAP time = 0.060 seconds reclaim time = 8.040 seconds net compute time = 112.540 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** FLOAT-SUB Benchmark *** 1000 Floating-point subtractions Iteration 0 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 119.160 seconds SWAP time = 0.160 seconds reclaim time = 7.960 seconds net compute time = 111.040 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20343 LISTP, 5 ENVIRONMENT Iteration 1 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 119.180 seconds SWAP time = 0.180 seconds reclaim time = 7.900 seconds net compute time = 111.100 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** FLOAT-TIMES Benchmark *** 1000 Floating-point multiplications Iteration 0 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 120.200 seconds SWAP time = 0.180 seconds reclaim time = 7.960 seconds net compute time = 112.060 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20343 LISTP, 5 ENVIRONMENT Iteration 1 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 119.860 seconds SWAP time = 0.180 seconds reclaim time = 7.900 seconds net compute time = 111.780 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** FLOAT-DIV Benchmark *** 1000 Floating-point divisions Iteration 0 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 119.240 seconds SWAP time = 0.160 seconds reclaim time = 7.960 seconds net compute time = 111.120 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 5 ENVIRONMENT Iteration 1 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 119.220 seconds SWAP time = 0.100 seconds reclaim time = 7.960 seconds net compute time = 111.160 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** GENERIC-ADD-FLOAT Benchmark *** 10000 Generic + with float args Iteration 0 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 120.640 seconds SWAP time = 0.140 seconds reclaim time = 7.940 seconds net compute time = 112.560 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20343 LISTP, 5 ENVIRONMENT Iteration 1 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 121.000 seconds SWAP time = 0.140 seconds reclaim time = 7.940 seconds net compute time = 112.920 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** GENERIC-SUB-FLOAT Benchmark *** 10000 Generic - with float args Iteration 0 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 120.760 seconds SWAP time = 0.140 seconds reclaim time = 7.940 seconds net compute time = 112.680 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20343 LISTP, 5 ENVIRONMENT Iteration 1 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 120.780 seconds SWAP time = 0.140 seconds reclaim time = 7.960 seconds net compute time = 112.680 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** GENERIC-TIMES-FLOAT Benchmark *** 10000 Generic * with float args Iteration 0 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 121.000 seconds SWAP time = 0.160 seconds reclaim time = 7.940 seconds net compute time = 112.900 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20343 LISTP, 5 ENVIRONMENT Iteration 1 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 120.080 seconds SWAP time = 0.140 seconds reclaim time = 8.000 seconds net compute time = 111.940 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 5 ENVIRONMENT ***** GENERIC-DIV-FLOAT Benchmark *** 10000 Generic / with float args Iteration 0 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 122.020 seconds SWAP time = 0.160 seconds reclaim time = 8.000 seconds net compute time = 113.860 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20343 LISTP, 5 ENVIRONMENT Iteration 1 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 121.100 seconds SWAP time = 0.160 seconds reclaim time = 7.980 seconds net compute time = 112.960 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20230 LISTP, 5 ENVIRONMENT ***** FLOAT-SINE Benchmark *** 10000 calls to CL:SIN(pi/6) Iteration 0 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 132.060 seconds SWAP time = 0.220 seconds reclaim time = 7.940 seconds net compute time = 123.900 seconds Storage allocated: 3 FIXP, 10000 FLOATP, 20340 LISTP, 5 ENVIRONMENT Iteration 1 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 130.980 seconds SWAP time = 0.160 seconds reclaim time = 7.960 seconds net compute time = 122.860 seconds Storage allocated: 2 FIXP, 10000 FLOATP, 20228 LISTP, 5 ENVIRONMENT \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-BYTE-CONSY.RESULTS b/internal/gabriel/Results/Maiko/SUN-BYTE-CONSY.RESULTS new file mode 100644 index 00000000..b57c2350 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-BYTE-CONSY.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 20-Jun-88 19:23:27 Software Type: Xerox AIE Software Version: Lispcore sysout of 20-Jun-88 19:23:27, Make-init dates: 20-Jun-88 18:24:36, 20-Jun-88 18:34:47 Machine Type: MAIKO Machine Version: Microcode version: 266, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 75.040 seconds SWAP time = 0.360 seconds reclaim time = 48.040 seconds net compute time = 26.640 seconds Storage allocated: 48392 LISTP Iteration 1 of DERIV Timing for : DERIV Elapsed time = 75.040 seconds SWAP time = 0.360 seconds reclaim time = 48.060 seconds net compute time = 26.620 seconds ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 88.460 seconds SWAP time = 0.320 seconds reclaim time = 52.000 seconds net compute time = 36.140 seconds Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 88.480 seconds SWAP time = 0.240 seconds reclaim time = 51.960 seconds net compute time = 36.280 seconds Storage allocated: 63392 LISTP ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 38.520 seconds SWAP time = 0.180 seconds reclaim time = 24.200 seconds net compute time = 14.140 seconds Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 38.460 seconds SWAP time = 0.140 seconds reclaim time = 24.200 seconds net compute time = 14.120 seconds ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 41.660 seconds SWAP time = 0.180 seconds reclaim time = 25.060 seconds net compute time = 16.420 seconds Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 40.840 seconds SWAP time = 0.160 seconds reclaim time = 24.420 seconds net compute time = 16.260 seconds Storage allocated: 54464 LISTP ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 32.620 seconds SWAP time = 0.060 seconds reclaim time = 8.820 seconds net compute time = 23.740 seconds Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 32.640 seconds SWAP time = 0.120 seconds reclaim time = 8.880 seconds net compute time = 23.640 seconds ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 163.940 seconds SWAP time = 0.440 seconds reclaim time = 45.500 seconds net compute time = 118.000 seconds Storage allocated: 29856 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 164.040 seconds SWAP time = 0.340 seconds reclaim time = 45.600 seconds net compute time = 118.100 seconds Storage allocated: 29856 LISTP ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 494.880 seconds SWAP time = 1.160 seconds reclaim time = 188.980 seconds net compute time = 304.740 seconds Storage allocated: 97931 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 494.640 seconds SWAP time = 1.440 seconds reclaim time = 187.900 seconds net compute time = 305.300 seconds Storage allocated: 97931 LISTP, 229002 ONED-ARRAY ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 297.840 seconds SWAP time = 0.480 seconds reclaim time = 103.340 seconds net compute time = 194.020 seconds Storage allocated: 32395 LISTP, 2202 ONED-ARRAY Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 297.620 seconds SWAP time = 0.500 seconds reclaim time = 103.280 seconds net compute time = 193.840 seconds Storage allocated: 97931 LISTP, 2202 ONED-ARRAY ***** TRAVERSE-INIT* Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 67.460 seconds SWAP time = 0.160 seconds reclaim time = 3.700 seconds net compute time = 63.600 seconds Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* Iteration 1 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 67.980 seconds SWAP time = 0.180 seconds reclaim time = 3.620 seconds net compute time = 64.180 seconds Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* ***** TRAVERSE* Benchmark *** Traverse, Traverse Evaluating setup for TRAVERSE* Iteration 0 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 262.320 seconds SWAP time = 0.200 seconds net compute time = 262.120 seconds Iteration 1 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 262.360 seconds SWAP time = 0.220 seconds net compute time = 262.140 seconds Evaluating after function for TRAVERSE* \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-BYTE-TAK.RESULTS b/internal/gabriel/Results/Maiko/SUN-BYTE-TAK.RESULTS new file mode 100644 index 00000000..45a0a280 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-BYTE-TAK.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 20-Jun-88 19:23:27 Software Type: Xerox AIE Software Version: Lispcore sysout of 20-Jun-88 19:23:27, Make-init dates: 20-Jun-88 18:24:36, 20-Jun-88 18:34:47 Machine Type: MAIKO Machine Version: Microcode version: 266, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 96.440 seconds SWAP time = 0.260 seconds net compute time = 96.180 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 95.540 seconds SWAP time = 0.060 seconds net compute time = 95.480 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 11.280 seconds SWAP time = 0.020 seconds net compute time = 11.260 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 11.180 seconds SWAP time = 0.040 seconds net compute time = 11.140 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 3.020 seconds net compute time = 3.020 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 3.100 seconds SWAP time = 0.020 seconds net compute time = 3.080 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 18.980 seconds SWAP time = 0.040 seconds net compute time = 18.940 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 18.960 seconds SWAP time = 0.020 seconds net compute time = 18.940 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 3.340 seconds net compute time = 3.340 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 3.340 seconds net compute time = 3.340 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-IO.Results b/internal/gabriel/Results/Maiko/SUN-IO.Results new file mode 100644 index 00000000..94bbd861 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-IO.Results @@ -0,0 +1 @@ +Lisp Type: Envos Medley Lisp Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55 Software Type: Envos Medley Software Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55, Make-init dates: 17-Apr-90 20:12:20, 17-Apr-90 20:30:18 Machine Type: mc68020fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Machine Version: Emulator created: 9-May-90, memory size: 0 Machine Instance: 31000c9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 pigmyc9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Site: ENVOS Corporation Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FPRINT Benchmark *** FPrint Iteration 0 of FPRINT Timing for : FPRINT Elapsed time = 19.740 seconds SWAP time = 2.080 seconds net compute time = 17.660 seconds Page faults = 2 Swap writes = 2 Disk operations = 2 Storage allocated: 76 FIXP, 113 LISTP, 1 STREAM, 52 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT Iteration 1 of FPRINT Timing for : FPRINT Elapsed time = 19.040 seconds SWAP time = 1.980 seconds net compute time = 17.060 seconds Page faults = 2 Swap writes = 2 Disk operations = 2 Storage allocated: 76 FIXP, 113 LISTP, 1 STREAM, 52 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT ***** FREAD Benchmark *** FRead Iteration 0 of FREAD Timing for : FREAD Elapsed time = 15.232 seconds SWAP time = 0.560 seconds reclaim time = 0.260 seconds net compute time = 14.412 seconds Storage allocated: 41 FIXP, 5928 LISTP, 1 STREAM, 55 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT Iteration 1 of FREAD Timing for : FREAD Elapsed time = 15.100 seconds SWAP time = 0.660 seconds reclaim time = 0.280 seconds net compute time = 14.160 seconds Storage allocated: 41 FIXP, 5928 LISTP, 1 STREAM, 55 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT ***** TPRINT Benchmark *** TPrint Evaluating setup for TPRINT Iteration 0 of TPRINT Timing for : TPRINT Elapsed time = 189.396 seconds SWAP time = 0.200 seconds net compute time = 189.196 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Iteration 1 of TPRINT Timing for : TPRINT Elapsed time = 189.540 seconds SWAP time = 0.160 seconds net compute time = 189.380 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Evaluating after function for TPRINT ***** READ-FLOAT Benchmark *** Read 2000 Floats from {CORE} Iteration 0 of READ-FLOAT Timing for : IL:READ-FLOAT Elapsed time = 21.260 seconds SWAP time = 0.100 seconds reclaim time = 0.960 seconds net compute time = 20.200 seconds Page faults = 1 Swap writes = 1 Storage allocated: 7811 FIXP, 2000 FLOATP, 2004 LISTP, 1 STREAM, 2 ONED-ARRAY Iteration 1 of READ-FLOAT Timing for : IL:READ-FLOAT Elapsed time = 21.240 seconds SWAP time = 0.020 seconds reclaim time = 0.980 seconds net compute time = 20.240 seconds Storage allocated: 7811 FIXP, 2000 FLOATP, 2004 LISTP, 1 STREAM, 2 ONED-ARRAY ***** PRINT-FLOAT Benchmark *** Print 2000 Floats to {NULL} Iteration 0 of PRINT-FLOAT Timing for : IL:PRINT-FLOAT Elapsed time = 0.040 seconds net compute time = 0.040 seconds Storage allocated: 4 LISTP, 1 STREAM, 3 ONED-ARRAY Iteration 1 of PRINT-FLOAT Timing for : IL:PRINT-FLOAT Elapsed time = 0.020 seconds net compute time = 0.020 seconds Storage allocated: 4 LISTP, 1 STREAM, 3 ONED-ARRAY ***** TERMINAL-PRINTING Benchmark *** Printing chars to terminal Evaluating setup for TERMINAL-PRINTING Iteration 0 of TERMINAL-PRINTING Timing for : IL:TERMINAL-PRINTING Elapsed time = 1976.020 seconds SWAP time = 2.760 seconds reclaim time = 0.140 seconds net compute time = 1973.120 seconds Storage allocated: 2 FIXP, 10 LISTP, 1 STREAM, 1 ONED-ARRAY, 1 COREFILEINFOBLK Iteration 1 of TERMINAL-PRINTING Timing for : IL:TERMINAL-PRINTING Elapsed time = 2053.020 seconds SWAP time = 2.600 seconds net compute time = 2050.420 seconds Storage allocated: 4 LISTP Evaluating after function for TERMINAL-PRINTING ***** READ-EXISTING-SYMBOLS Benchmark *** Read 1000 symbols that exist in the sysout already Iteration 0 of READ-EXISTING-SYMBOLS Timing for : IL:READ-EXISTING-SYMBOLS Elapsed time = 13.860 seconds reclaim time = 0.740 seconds net compute time = 13.120 seconds Storage allocated: 5 FIXP, 4 FLOATP, 3008 LISTP, 1 STREAM, 16 ONED-ARRAY Iteration 1 of READ-EXISTING-SYMBOLS Timing for : IL:READ-EXISTING-SYMBOLS Elapsed time = 8.200 seconds reclaim time = 0.400 seconds net compute time = 7.800 seconds Storage allocated: 1 FIXP, 3004 LISTP, 1 STREAM, 12 ONED-ARRAY ***** READ-DSK Benchmark *** Read 50,000 bytes from a file on {DSK} Evaluating setup for READ-DSK Iteration 0 of READ-DSK Timing for : IL:READ-DSK Elapsed time = 3.560 seconds SWAP time = 0.860 seconds net compute time = 2.700 seconds Storage allocated: 104 FIXP, 34 LISTP, 1 STREAM, 20 ONED-ARRAY Iteration 1 of READ-DSK Timing for : IL:READ-DSK Elapsed time = 3.960 seconds SWAP time = 0.820 seconds net compute time = 3.140 seconds Storage allocated: 104 FIXP, 34 LISTP, 1 STREAM, 20 ONED-ARRAY Evaluating after function for READ-DSK ***** READ-UFS Benchmark *** Read 50,000 bytes from a file on the {UNIX} device Evaluating setup for READ-UFS Please enter my pup host number (in octal): 65 Iteration 0 of READ-UFS Timing for : IL:READ-UFS Elapsed time = 2.540 seconds SWAP time = 0.340 seconds net compute time = 2.200 seconds Page faults = 3 Storage allocated: 103 FIXP, 19 LISTP, 1 STREAM, 12 ONED-ARRAY Iteration 1 of READ-UFS Timing for : IL:READ-UFS Elapsed time = 2.620 seconds SWAP time = 0.380 seconds net compute time = 2.240 seconds Page faults = 3 Storage allocated: 103 FIXP, 19 LISTP, 1 STREAM, 12 ONED-ARRAY Evaluating after function for READ-UFS ***** READ-CORE Benchmark *** Read 50,000 bytes from CORE. Evaluating setup for READ-CORE Iteration 0 of READ-CORE Timing for : IL:READ-CORE Elapsed time = 2.360 seconds SWAP time = 0.020 seconds net compute time = 2.340 seconds Storage allocated: 1 FIXP, 3 LISTP, 1 STREAM, 2 ONED-ARRAY Iteration 1 of READ-CORE Timing for : IL:READ-CORE Elapsed time = 2.560 seconds SWAP time = 0.020 seconds reclaim time = 0.160 seconds net compute time = 2.380 seconds Storage allocated: 1 FIXP, 3 LISTP, 1 STREAM, 2 ONED-ARRAY Evaluating after function for READ-CORE ***** WRITE-DSK Benchmark *** Write 50,000 bytes on on {DSK} Iteration 0 of WRITE-DSK Timing for : IL:WRITE-DSK Elapsed time = 19.440 seconds SWAP time = 2.020 seconds net compute time = 17.420 seconds Page faults = 9 Swap writes = 7 Disk operations = 7 Storage allocated: 203 FIXP, 42 LISTP, 1 STREAM, 20 ONED-ARRAY Iteration 1 of WRITE-DSK Timing for : IL:WRITE-DSK Elapsed time = 20.428 seconds SWAP time = 1.580 seconds net compute time = 18.848 seconds Page faults = 6 Swap writes = 6 Disk operations = 6 Storage allocated: 205 FIXP, 42 LISTP, 1 STREAM, 20 ONED-ARRAY Evaluating after function for WRITE-DSK ***** WRITE-UFS Benchmark *** Write 50,000 bytes to a file on {UNIX} Iteration 0 of WRITE-UFS Timing for : IL:WRITE-UFS Elapsed time = 16.680 seconds SWAP time = 0.440 seconds net compute time = 16.240 seconds Page faults = 11 Swap writes = 6 Disk operations = 6 Storage allocated: 202 FIXP, 27 LISTP, 1 STREAM, 12 ONED-ARRAY Iteration 1 of WRITE-UFS Timing for : IL:WRITE-UFS Elapsed time = 16.480 seconds SWAP time = 0.440 seconds net compute time = 16.040 seconds Page faults = 9 Swap writes = 6 Disk operations = 6 Storage allocated: 202 FIXP, 27 LISTP, 1 STREAM, 12 ONED-ARRAY Evaluating after function for WRITE-UFS ***** WRITE-CORE Benchmark *** Write 50,000 bytes to a file on {CORE} Iteration 0 of WRITE-CORE Timing for : IL:WRITE-CORE Elapsed time = 15.660 seconds reclaim time = 1.060 seconds net compute time = 14.600 seconds Storage allocated: 2 FIXP, 209 LISTP, 1 STREAM, 5 ONED-ARRAY, 1 COREFILEINFOBLK Iteration 1 of WRITE-CORE Timing for : IL:WRITE-CORE Elapsed time = 15.540 seconds SWAP time = 0.040 seconds reclaim time = 1.080 seconds net compute time = 14.420 seconds Storage allocated: 2 FIXP, 205 LISTP, 1 STREAM, 5 ONED-ARRAY, 1 COREFILEINFOBLK Evaluating after function for WRITE-CORE \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-IO.Results.~14~ b/internal/gabriel/Results/Maiko/SUN-IO.Results.~14~ new file mode 100644 index 00000000..94bbd861 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-IO.Results.~14~ @@ -0,0 +1 @@ +Lisp Type: Envos Medley Lisp Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55 Software Type: Envos Medley Software Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55, Make-init dates: 17-Apr-90 20:12:20, 17-Apr-90 20:30:18 Machine Type: mc68020fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Machine Version: Emulator created: 9-May-90, memory size: 0 Machine Instance: 31000c9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 pigmyc9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Site: ENVOS Corporation Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FPRINT Benchmark *** FPrint Iteration 0 of FPRINT Timing for : FPRINT Elapsed time = 19.740 seconds SWAP time = 2.080 seconds net compute time = 17.660 seconds Page faults = 2 Swap writes = 2 Disk operations = 2 Storage allocated: 76 FIXP, 113 LISTP, 1 STREAM, 52 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT Iteration 1 of FPRINT Timing for : FPRINT Elapsed time = 19.040 seconds SWAP time = 1.980 seconds net compute time = 17.060 seconds Page faults = 2 Swap writes = 2 Disk operations = 2 Storage allocated: 76 FIXP, 113 LISTP, 1 STREAM, 52 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT ***** FREAD Benchmark *** FRead Iteration 0 of FREAD Timing for : FREAD Elapsed time = 15.232 seconds SWAP time = 0.560 seconds reclaim time = 0.260 seconds net compute time = 14.412 seconds Storage allocated: 41 FIXP, 5928 LISTP, 1 STREAM, 55 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT Iteration 1 of FREAD Timing for : FREAD Elapsed time = 15.100 seconds SWAP time = 0.660 seconds reclaim time = 0.280 seconds net compute time = 14.160 seconds Storage allocated: 41 FIXP, 5928 LISTP, 1 STREAM, 55 ONED-ARRAY, 2 PATHNAME, 2 DIRECTORY-COMPONENT ***** TPRINT Benchmark *** TPrint Evaluating setup for TPRINT Iteration 0 of TPRINT Timing for : TPRINT Elapsed time = 189.396 seconds SWAP time = 0.200 seconds net compute time = 189.196 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Iteration 1 of TPRINT Timing for : TPRINT Elapsed time = 189.540 seconds SWAP time = 0.160 seconds net compute time = 189.380 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Evaluating after function for TPRINT ***** READ-FLOAT Benchmark *** Read 2000 Floats from {CORE} Iteration 0 of READ-FLOAT Timing for : IL:READ-FLOAT Elapsed time = 21.260 seconds SWAP time = 0.100 seconds reclaim time = 0.960 seconds net compute time = 20.200 seconds Page faults = 1 Swap writes = 1 Storage allocated: 7811 FIXP, 2000 FLOATP, 2004 LISTP, 1 STREAM, 2 ONED-ARRAY Iteration 1 of READ-FLOAT Timing for : IL:READ-FLOAT Elapsed time = 21.240 seconds SWAP time = 0.020 seconds reclaim time = 0.980 seconds net compute time = 20.240 seconds Storage allocated: 7811 FIXP, 2000 FLOATP, 2004 LISTP, 1 STREAM, 2 ONED-ARRAY ***** PRINT-FLOAT Benchmark *** Print 2000 Floats to {NULL} Iteration 0 of PRINT-FLOAT Timing for : IL:PRINT-FLOAT Elapsed time = 0.040 seconds net compute time = 0.040 seconds Storage allocated: 4 LISTP, 1 STREAM, 3 ONED-ARRAY Iteration 1 of PRINT-FLOAT Timing for : IL:PRINT-FLOAT Elapsed time = 0.020 seconds net compute time = 0.020 seconds Storage allocated: 4 LISTP, 1 STREAM, 3 ONED-ARRAY ***** TERMINAL-PRINTING Benchmark *** Printing chars to terminal Evaluating setup for TERMINAL-PRINTING Iteration 0 of TERMINAL-PRINTING Timing for : IL:TERMINAL-PRINTING Elapsed time = 1976.020 seconds SWAP time = 2.760 seconds reclaim time = 0.140 seconds net compute time = 1973.120 seconds Storage allocated: 2 FIXP, 10 LISTP, 1 STREAM, 1 ONED-ARRAY, 1 COREFILEINFOBLK Iteration 1 of TERMINAL-PRINTING Timing for : IL:TERMINAL-PRINTING Elapsed time = 2053.020 seconds SWAP time = 2.600 seconds net compute time = 2050.420 seconds Storage allocated: 4 LISTP Evaluating after function for TERMINAL-PRINTING ***** READ-EXISTING-SYMBOLS Benchmark *** Read 1000 symbols that exist in the sysout already Iteration 0 of READ-EXISTING-SYMBOLS Timing for : IL:READ-EXISTING-SYMBOLS Elapsed time = 13.860 seconds reclaim time = 0.740 seconds net compute time = 13.120 seconds Storage allocated: 5 FIXP, 4 FLOATP, 3008 LISTP, 1 STREAM, 16 ONED-ARRAY Iteration 1 of READ-EXISTING-SYMBOLS Timing for : IL:READ-EXISTING-SYMBOLS Elapsed time = 8.200 seconds reclaim time = 0.400 seconds net compute time = 7.800 seconds Storage allocated: 1 FIXP, 3004 LISTP, 1 STREAM, 12 ONED-ARRAY ***** READ-DSK Benchmark *** Read 50,000 bytes from a file on {DSK} Evaluating setup for READ-DSK Iteration 0 of READ-DSK Timing for : IL:READ-DSK Elapsed time = 3.560 seconds SWAP time = 0.860 seconds net compute time = 2.700 seconds Storage allocated: 104 FIXP, 34 LISTP, 1 STREAM, 20 ONED-ARRAY Iteration 1 of READ-DSK Timing for : IL:READ-DSK Elapsed time = 3.960 seconds SWAP time = 0.820 seconds net compute time = 3.140 seconds Storage allocated: 104 FIXP, 34 LISTP, 1 STREAM, 20 ONED-ARRAY Evaluating after function for READ-DSK ***** READ-UFS Benchmark *** Read 50,000 bytes from a file on the {UNIX} device Evaluating setup for READ-UFS Please enter my pup host number (in octal): 65 Iteration 0 of READ-UFS Timing for : IL:READ-UFS Elapsed time = 2.540 seconds SWAP time = 0.340 seconds net compute time = 2.200 seconds Page faults = 3 Storage allocated: 103 FIXP, 19 LISTP, 1 STREAM, 12 ONED-ARRAY Iteration 1 of READ-UFS Timing for : IL:READ-UFS Elapsed time = 2.620 seconds SWAP time = 0.380 seconds net compute time = 2.240 seconds Page faults = 3 Storage allocated: 103 FIXP, 19 LISTP, 1 STREAM, 12 ONED-ARRAY Evaluating after function for READ-UFS ***** READ-CORE Benchmark *** Read 50,000 bytes from CORE. Evaluating setup for READ-CORE Iteration 0 of READ-CORE Timing for : IL:READ-CORE Elapsed time = 2.360 seconds SWAP time = 0.020 seconds net compute time = 2.340 seconds Storage allocated: 1 FIXP, 3 LISTP, 1 STREAM, 2 ONED-ARRAY Iteration 1 of READ-CORE Timing for : IL:READ-CORE Elapsed time = 2.560 seconds SWAP time = 0.020 seconds reclaim time = 0.160 seconds net compute time = 2.380 seconds Storage allocated: 1 FIXP, 3 LISTP, 1 STREAM, 2 ONED-ARRAY Evaluating after function for READ-CORE ***** WRITE-DSK Benchmark *** Write 50,000 bytes on on {DSK} Iteration 0 of WRITE-DSK Timing for : IL:WRITE-DSK Elapsed time = 19.440 seconds SWAP time = 2.020 seconds net compute time = 17.420 seconds Page faults = 9 Swap writes = 7 Disk operations = 7 Storage allocated: 203 FIXP, 42 LISTP, 1 STREAM, 20 ONED-ARRAY Iteration 1 of WRITE-DSK Timing for : IL:WRITE-DSK Elapsed time = 20.428 seconds SWAP time = 1.580 seconds net compute time = 18.848 seconds Page faults = 6 Swap writes = 6 Disk operations = 6 Storage allocated: 205 FIXP, 42 LISTP, 1 STREAM, 20 ONED-ARRAY Evaluating after function for WRITE-DSK ***** WRITE-UFS Benchmark *** Write 50,000 bytes to a file on {UNIX} Iteration 0 of WRITE-UFS Timing for : IL:WRITE-UFS Elapsed time = 16.680 seconds SWAP time = 0.440 seconds net compute time = 16.240 seconds Page faults = 11 Swap writes = 6 Disk operations = 6 Storage allocated: 202 FIXP, 27 LISTP, 1 STREAM, 12 ONED-ARRAY Iteration 1 of WRITE-UFS Timing for : IL:WRITE-UFS Elapsed time = 16.480 seconds SWAP time = 0.440 seconds net compute time = 16.040 seconds Page faults = 9 Swap writes = 6 Disk operations = 6 Storage allocated: 202 FIXP, 27 LISTP, 1 STREAM, 12 ONED-ARRAY Evaluating after function for WRITE-UFS ***** WRITE-CORE Benchmark *** Write 50,000 bytes to a file on {CORE} Iteration 0 of WRITE-CORE Timing for : IL:WRITE-CORE Elapsed time = 15.660 seconds reclaim time = 1.060 seconds net compute time = 14.600 seconds Storage allocated: 2 FIXP, 209 LISTP, 1 STREAM, 5 ONED-ARRAY, 1 COREFILEINFOBLK Iteration 1 of WRITE-CORE Timing for : IL:WRITE-CORE Elapsed time = 15.540 seconds SWAP time = 0.040 seconds reclaim time = 1.080 seconds net compute time = 14.420 seconds Storage allocated: 2 FIXP, 205 LISTP, 1 STREAM, 5 ONED-ARRAY, 1 COREFILEINFOBLK Evaluating after function for WRITE-CORE \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-IO.Results.~1~ b/internal/gabriel/Results/Maiko/SUN-IO.Results.~1~ new file mode 100644 index 00000000..183e2130 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-IO.Results.~1~ @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 3-Aug-88 00:55:00 Software Type: Xerox AIE Software Version: Lispcore sysout of 3-Aug-88 00:55:00, Make-init dates: 31-Jul-88 18:16:30, 31-Jul-88 18:26:32 Machine Type: mc68020 Machine Version: Microcode version: 349, memory size: 16384 Machine Instance: 1300283a trouser Site: trouser Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FPRINT Benchmark *** FPrint Iteration 0 of FPRINT Timing for : FPRINT Elapsed time = 15.840 seconds SWAP time = 0.560 seconds net compute time = 15.280 seconds Page faults = 22 Swap writes = 8 Disk operations = 6 Storage allocated: 22 FIXP, 105 LISTP, 1 STREAM, 31 ONED-ARRAY, 1 PATHNAME Iteration 1 of FPRINT Timing for : FPRINT Elapsed time = 15.020 seconds SWAP time = 0.420 seconds net compute time = 14.600 seconds Page faults = 1 Swap writes = 1 Disk operations = 4 Storage allocated: 19 FIXP, 128 LISTP, 1 STREAM, 44 ONED-ARRAY, 2 PATHNAME ***** FREAD Benchmark *** FRead Iteration 0 of FREAD In IL:\\EOSERROR: End of file IL:|{DSK}/users/hayata/fprint.tst;2| 12: ^ \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-AREFY.Results b/internal/gabriel/Results/Maiko/SUN-PAV-AREFY.Results new file mode 100644 index 00000000..17529685 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-AREFY.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 3-Aug-88 00:55:00 Software Type: Xerox AIE Software Version: Lispcore sysout of 3-Aug-88 00:55:00, Make-init dates: 31-Jul-88 18:16:30, 31-Jul-88 18:26:32 Machine Type: mc68020 Machine Version: Microcode version: 349, memory size: 16384 Machine Instance: 1300283a trouser Site: trouser Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 63.360 seconds SWAP time = 0.140 seconds net compute time = 63.220 seconds Page faults = 6 Swap writes = 4 Storage allocated: 1 FIXP, 10 LISTP, 1 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 63.180 seconds SWAP time = 0.040 seconds net compute time = 63.140 seconds Storage allocated: 1 FIXP, 10 LISTP, 1 ONED-ARRAY ***** TRIANG Benchmark *** Triang Iteration 0 of TRIANG Timing for : TRIANG Elapsed time = 1143.400 seconds SWAP time = 1.980 seconds reclaim time = 1.500 seconds net compute time = 1139.920 seconds Page faults = 1 Storage allocated: 11626 LISTP Iteration 1 of TRIANG Timing for : TRIANG Elapsed time = 1142.600 seconds SWAP time = 1.300 seconds reclaim time = 1.520 seconds net compute time = 1139.780 seconds Storage allocated: 11626 LISTP ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 309.880 seconds SWAP time = 1.400 seconds reclaim time = 220.720 seconds net compute time = 87.760 seconds Page faults = 2 Swap writes = 2 Storage allocated: 942640 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 310.180 seconds SWAP time = 1.560 seconds reclaim time = 220.940 seconds net compute time = 87.680 seconds Storage allocated: 942640 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results b/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results new file mode 100644 index 00000000..0dc0db5a --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results @@ -0,0 +1 @@ +Lisp Type: Envos Medley Lisp Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55 Software Type: Envos Medley Software Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55, Make-init dates: 17-Apr-90 20:12:20, 17-Apr-90 20:30:18 Machine Type: mc68020fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Machine Version: Emulator created: 9-May-90, memory size: 0 Machine Instance: 31000c9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 pigmyc9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Site: ENVOS Corporation Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** NULL-LOOP Benchmark *** Null loop, 1000 times thru Iteration 0 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.240 seconds net compute time = 0.240 seconds Iteration 1 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.260 seconds net compute time = 0.260 seconds ***** FLOAT-ADD Benchmark *** 1000 Floating-point additions Iteration 0 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 1.780 seconds reclaim time = 0.680 seconds net compute time = 1.100 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 1.880 seconds reclaim time = 0.660 seconds net compute time = 1.220 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SUB Benchmark *** 1000 Floating-point subtractions Iteration 0 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 2.100 seconds reclaim time = 0.700 seconds net compute time = 1.400 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 2.100 seconds reclaim time = 0.640 seconds net compute time = 1.460 seconds Storage allocated: 10000 FLOATP ***** FLOAT-TIMES Benchmark *** 1000 Floating-point multiplications Iteration 0 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 1.640 seconds reclaim time = 0.640 seconds net compute time = 1.000 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 1.640 seconds reclaim time = 0.680 seconds net compute time = 0.960 seconds Storage allocated: 10000 FLOATP ***** FLOAT-DIV Benchmark *** 1000 Floating-point divisions Iteration 0 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 1.680 seconds reclaim time = 0.640 seconds net compute time = 1.040 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 1.680 seconds reclaim time = 0.640 seconds net compute time = 1.040 seconds Storage allocated: 10000 FLOATP ***** GENERIC-ADD-FLOAT Benchmark *** 10000 Generic + with float args Iteration 0 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 1.860 seconds reclaim time = 0.660 seconds net compute time = 1.200 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 1.860 seconds SWAP time = 0.020 seconds reclaim time = 0.680 seconds net compute time = 1.160 seconds Storage allocated: 10000 FLOATP ***** GENERIC-SUB-FLOAT Benchmark *** 10000 Generic - with float args Iteration 0 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 1.900 seconds SWAP time = 0.040 seconds reclaim time = 0.680 seconds net compute time = 1.180 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 1.800 seconds SWAP time = 0.020 seconds reclaim time = 0.680 seconds net compute time = 1.100 seconds Storage allocated: 10000 FLOATP ***** GENERIC-TIMES-FLOAT Benchmark *** 10000 Generic * with float args Iteration 0 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 1.740 seconds reclaim time = 0.680 seconds net compute time = 1.060 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 1.740 seconds reclaim time = 0.660 seconds net compute time = 1.080 seconds Storage allocated: 10000 FLOATP ***** GENERIC-DIV-FLOAT Benchmark *** 10000 Generic / with float args Iteration 0 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 2.760 seconds reclaim time = 0.640 seconds net compute time = 2.120 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 2.760 seconds SWAP time = 0.020 seconds reclaim time = 0.640 seconds net compute time = 2.100 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SINE Benchmark *** 10000 calls to CL:SIN(pi/6) Iteration 0 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 19.320 seconds SWAP time = 0.080 seconds reclaim time = 8.200 seconds net compute time = 11.040 seconds Storage allocated: 110000 FLOATP Iteration 1 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 19.300 seconds SWAP time = 0.060 seconds reclaim time = 8.160 seconds net compute time = 11.080 seconds Storage allocated: 110000 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~10~ b/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~10~ new file mode 100644 index 00000000..0dc0db5a --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~10~ @@ -0,0 +1 @@ +Lisp Type: Envos Medley Lisp Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55 Software Type: Envos Medley Software Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55, Make-init dates: 17-Apr-90 20:12:20, 17-Apr-90 20:30:18 Machine Type: mc68020fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Machine Version: Emulator created: 9-May-90, memory size: 0 Machine Instance: 31000c9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 pigmyc9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Site: ENVOS Corporation Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** NULL-LOOP Benchmark *** Null loop, 1000 times thru Iteration 0 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.240 seconds net compute time = 0.240 seconds Iteration 1 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.260 seconds net compute time = 0.260 seconds ***** FLOAT-ADD Benchmark *** 1000 Floating-point additions Iteration 0 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 1.780 seconds reclaim time = 0.680 seconds net compute time = 1.100 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 1.880 seconds reclaim time = 0.660 seconds net compute time = 1.220 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SUB Benchmark *** 1000 Floating-point subtractions Iteration 0 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 2.100 seconds reclaim time = 0.700 seconds net compute time = 1.400 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 2.100 seconds reclaim time = 0.640 seconds net compute time = 1.460 seconds Storage allocated: 10000 FLOATP ***** FLOAT-TIMES Benchmark *** 1000 Floating-point multiplications Iteration 0 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 1.640 seconds reclaim time = 0.640 seconds net compute time = 1.000 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 1.640 seconds reclaim time = 0.680 seconds net compute time = 0.960 seconds Storage allocated: 10000 FLOATP ***** FLOAT-DIV Benchmark *** 1000 Floating-point divisions Iteration 0 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 1.680 seconds reclaim time = 0.640 seconds net compute time = 1.040 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 1.680 seconds reclaim time = 0.640 seconds net compute time = 1.040 seconds Storage allocated: 10000 FLOATP ***** GENERIC-ADD-FLOAT Benchmark *** 10000 Generic + with float args Iteration 0 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 1.860 seconds reclaim time = 0.660 seconds net compute time = 1.200 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 1.860 seconds SWAP time = 0.020 seconds reclaim time = 0.680 seconds net compute time = 1.160 seconds Storage allocated: 10000 FLOATP ***** GENERIC-SUB-FLOAT Benchmark *** 10000 Generic - with float args Iteration 0 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 1.900 seconds SWAP time = 0.040 seconds reclaim time = 0.680 seconds net compute time = 1.180 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 1.800 seconds SWAP time = 0.020 seconds reclaim time = 0.680 seconds net compute time = 1.100 seconds Storage allocated: 10000 FLOATP ***** GENERIC-TIMES-FLOAT Benchmark *** 10000 Generic * with float args Iteration 0 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 1.740 seconds reclaim time = 0.680 seconds net compute time = 1.060 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 1.740 seconds reclaim time = 0.660 seconds net compute time = 1.080 seconds Storage allocated: 10000 FLOATP ***** GENERIC-DIV-FLOAT Benchmark *** 10000 Generic / with float args Iteration 0 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 2.760 seconds reclaim time = 0.640 seconds net compute time = 2.120 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 2.760 seconds SWAP time = 0.020 seconds reclaim time = 0.640 seconds net compute time = 2.100 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SINE Benchmark *** 10000 calls to CL:SIN(pi/6) Iteration 0 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 19.320 seconds SWAP time = 0.080 seconds reclaim time = 8.200 seconds net compute time = 11.040 seconds Storage allocated: 110000 FLOATP Iteration 1 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 19.300 seconds SWAP time = 0.060 seconds reclaim time = 8.160 seconds net compute time = 11.080 seconds Storage allocated: 110000 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~1~ b/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~1~ new file mode 100644 index 00000000..5a507e9c --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-ARITH.Results.~1~ @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 20-Jun-88 19:23:27 Software Type: Xerox AIE Software Version: Lispcore sysout of 20-Jun-88 19:23:27, Make-init dates: 20-Jun-88 18:24:36, 20-Jun-88 18:34:47 Machine Type: MAIKO Machine Version: Microcode version: 266, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** NULL-LOOP Benchmark *** Null loop, 1000 times thru Iteration 0 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.280 seconds net compute time = 0.280 seconds Iteration 1 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.260 seconds net compute time = 0.260 seconds ***** FLOAT-ADD Benchmark *** 1000 Floating-point additions Iteration 0 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 3.520 seconds SWAP time = 0.020 seconds reclaim time = 2.040 seconds net compute time = 1.460 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 3.520 seconds reclaim time = 2.040 seconds net compute time = 1.480 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SUB Benchmark *** 1000 Floating-point subtractions Iteration 0 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 3.860 seconds reclaim time = 2.040 seconds net compute time = 1.820 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 3.860 seconds reclaim time = 2.060 seconds net compute time = 1.800 seconds Storage allocated: 10000 FLOATP ***** FLOAT-TIMES Benchmark *** 1000 Floating-point multiplications Iteration 0 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 3.560 seconds SWAP time = 0.020 seconds reclaim time = 2.040 seconds net compute time = 1.500 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 3.560 seconds SWAP time = 0.020 seconds reclaim time = 2.060 seconds net compute time = 1.480 seconds Storage allocated: 10000 FLOATP ***** FLOAT-DIV Benchmark *** 1000 Floating-point divisions Iteration 0 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 3.520 seconds reclaim time = 2.060 seconds net compute time = 1.460 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 3.520 seconds SWAP time = 0.020 seconds reclaim time = 2.040 seconds net compute time = 1.460 seconds Storage allocated: 10000 FLOATP ***** GENERIC-ADD-FLOAT Benchmark *** 10000 Generic + with float args Iteration 0 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 3.580 seconds SWAP time = 0.040 seconds reclaim time = 2.020 seconds net compute time = 1.520 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 3.580 seconds SWAP time = 0.040 seconds reclaim time = 2.000 seconds net compute time = 1.540 seconds Storage allocated: 10000 FLOATP ***** GENERIC-SUB-FLOAT Benchmark *** 10000 Generic - with float args Iteration 0 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 3.640 seconds reclaim time = 2.040 seconds net compute time = 1.600 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 3.760 seconds SWAP time = 0.040 seconds reclaim time = 2.120 seconds net compute time = 1.600 seconds Storage allocated: 10000 FLOATP ***** GENERIC-TIMES-FLOAT Benchmark *** 10000 Generic * with float args Iteration 0 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 3.780 seconds reclaim time = 2.160 seconds net compute time = 1.620 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 3.620 seconds SWAP time = 0.020 seconds reclaim time = 2.040 seconds net compute time = 1.560 seconds Storage allocated: 10000 FLOATP ***** GENERIC-DIV-FLOAT Benchmark *** 10000 Generic / with float args Iteration 0 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 4.600 seconds SWAP time = 0.020 seconds reclaim time = 2.040 seconds net compute time = 2.540 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 4.580 seconds SWAP time = 0.020 seconds reclaim time = 2.020 seconds net compute time = 2.540 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SINE Benchmark *** 10000 calls to CL:SIN(pi/6) Iteration 0 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 11.580 seconds reclaim time = 2.040 seconds net compute time = 9.540 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 11.620 seconds SWAP time = 0.020 seconds reclaim time = 2.040 seconds net compute time = 9.560 seconds Storage allocated: 10000 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-CONSY.Results b/internal/gabriel/Results/Maiko/SUN-PAV-CONSY.Results new file mode 100644 index 00000000..e7011a74 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-CONSY.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 3-Aug-88 00:55:00 Software Type: Xerox AIE Software Version: Lispcore sysout of 3-Aug-88 00:55:00, Make-init dates: 31-Jul-88 18:16:30, 31-Jul-88 18:26:32 Machine Type: mc68020 Machine Version: Microcode version: 349, memory size: 16384 Machine Instance: 1300283a trouser Site: trouser Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 65.300 seconds SWAP time = 0.300 seconds reclaim time = 43.060 seconds net compute time = 21.940 seconds Iteration 1 of DERIV Timing for : DERIV Elapsed time = 65.280 seconds SWAP time = 0.320 seconds reclaim time = 43.020 seconds net compute time = 21.940 seconds Storage allocated: 48392 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 76.960 seconds SWAP time = 0.340 seconds reclaim time = 46.260 seconds net compute time = 30.360 seconds Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 76.980 seconds SWAP time = 0.440 seconds reclaim time = 46.200 seconds net compute time = 30.340 seconds ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 33.140 seconds SWAP time = 0.200 seconds reclaim time = 22.020 seconds net compute time = 10.920 seconds Storage allocated: 54464 LISTP Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 33.100 seconds SWAP time = 0.140 seconds reclaim time = 21.980 seconds net compute time = 10.980 seconds ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 35.960 seconds SWAP time = 0.220 seconds reclaim time = 22.960 seconds net compute time = 12.780 seconds Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 35.740 seconds SWAP time = 0.040 seconds reclaim time = 22.580 seconds net compute time = 13.120 seconds ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 26.940 seconds SWAP time = 0.040 seconds reclaim time = 8.260 seconds net compute time = 18.640 seconds Storage allocated: 43105 LISTP Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 27.000 seconds SWAP time = 0.060 seconds reclaim time = 8.220 seconds net compute time = 18.720 seconds Storage allocated: 43105 LISTP ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 143.960 seconds SWAP time = 0.380 seconds reclaim time = 44.400 seconds net compute time = 99.180 seconds Storage allocated: 29856 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 143.940 seconds SWAP time = 0.260 seconds reclaim time = 44.460 seconds net compute time = 99.220 seconds Storage allocated: 29856 LISTP ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 404.020 seconds SWAP time = 0.400 seconds reclaim time = 160.760 seconds net compute time = 242.860 seconds Page faults = 2 Swap writes = 1 Storage allocated: 32395 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 406.800 seconds SWAP time = 0.540 seconds reclaim time = 161.480 seconds net compute time = 244.780 seconds Storage allocated: 97931 LISTP, 229002 ONED-ARRAY ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 256.240 seconds SWAP time = 0.380 seconds reclaim time = 90.020 seconds net compute time = 165.840 seconds Page faults = 1 Storage allocated: 97931 LISTP, 2202 ONED-ARRAY Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 256.140 seconds SWAP time = 0.220 seconds reclaim time = 90.280 seconds net compute time = 165.640 seconds Storage allocated: 97931 LISTP, 2202 ONED-ARRAY ***** TRAVERSE-INIT* Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 62.600 seconds SWAP time = 0.120 seconds reclaim time = 4.060 seconds net compute time = 58.420 seconds Page faults = 1 Swap writes = 1 Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* Iteration 1 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 61.720 seconds SWAP time = 0.080 seconds reclaim time = 4.060 seconds net compute time = 57.580 seconds Storage allocated: 100 TNODE Evaluating after every function for TRAVERSE-INIT* ***** TRAVERSE* Benchmark *** Traverse, Traverse Evaluating setup for TRAVERSE* Iteration 0 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 240.560 seconds SWAP time = 0.280 seconds net compute time = 240.280 seconds Iteration 1 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 244.200 seconds SWAP time = 0.940 seconds net compute time = 243.260 seconds Evaluating after function for TRAVERSE* \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-MISC.Results b/internal/gabriel/Results/Maiko/SUN-PAV-MISC.Results new file mode 100644 index 00000000..ab97a4c9 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-MISC.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 29-Jun-88 20:57:46 Software Type: Xerox AIE Software Version: Lispcore sysout of 29-Jun-88 20:57:46, Make-init dates: 29-Jun-88 19:12:47, 29-Jun-88 19:22:47 Machine Type: MAIKO Machine Version: Microcode version: 260, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FLEGALS-SORT-TEST Benchmark *** Bob Flegal's SORT benchmark; runs on a 3/160 in 10.21s Lucid, 11.04s Franz. Iteration 0 of FLEGALS-SORT-TEST Timing for : IL:FLEGALS-SORT-TEST Elapsed time = 181.100 seconds SWAP time = 0.220 seconds reclaim time = 19.360 seconds net compute time = 161.520 seconds Storage allocated: 1 COMPILED-CLOSURE Iteration 1 of FLEGALS-SORT-TEST Timing for : IL:FLEGALS-SORT-TEST Elapsed time = 173.200 seconds SWAP time = 0.080 seconds reclaim time = 12.080 seconds net compute time = 161.040 seconds Storage allocated: 40000 LISTP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-POLY.Results b/internal/gabriel/Results/Maiko/SUN-PAV-POLY.Results new file mode 100644 index 00000000..5ebd5f0e --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-POLY.Results @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 3-Aug-88 00:55:00 Software Type: Xerox AIE Software Version: Lispcore sysout of 3-Aug-88 00:55:00, Make-init dates: 31-Jul-88 18:16:30, 31-Jul-88 18:26:32 Machine Type: mc68020 Machine Version: Microcode version: 349, memory size: 16384 Machine Instance: 1300283a trouser Site: trouser Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FRPOLY10R Benchmark *** FRPoly, Power = 10, r = x + y + z + 1 Evaluating setup for FRPOLY10R Iteration 0 of FRPOLY10R Timing for : FRPOLY10R Elapsed time = 4.220 seconds reclaim time = 1.620 seconds net compute time = 2.600 seconds Storage allocated: 69 FIXP, 9236 LISTP Iteration 1 of FRPOLY10R Timing for : FRPOLY10R Elapsed time = 4.240 seconds SWAP time = 0.020 seconds reclaim time = 1.620 seconds net compute time = 2.600 seconds Storage allocated: 69 FIXP, 9236 LISTP ***** FRPOLY10R2 Benchmark *** FRPoly, Power = 10, r2 = 1000r Evaluating setup for FRPOLY10R2 Iteration 0 of FRPOLY10R2 Timing for : FRPOLY10R2 Elapsed time = 230.920 seconds SWAP time = 0.540 seconds reclaim time = 127.400 seconds net compute time = 102.980 seconds Storage allocated: 55634 FIXP, 181550 LISTP, 17227 BIGNUM Iteration 1 of FRPOLY10R2 Timing for : FRPOLY10R2 Elapsed time = 231.220 seconds SWAP time = 0.360 seconds reclaim time = 127.700 seconds net compute time = 103.160 seconds Storage allocated: 55634 FIXP, 247086 LISTP, 17227 BIGNUM ***** FRPOLY10R3 Benchmark *** FRPoly, Power = 10, r3 = r in flonums Evaluating setup for FRPOLY10R3 Iteration 0 of FRPOLY10R3 Timing for : FRPOLY10R3 Elapsed time = 6.700 seconds reclaim time = 2.800 seconds net compute time = 3.900 seconds Storage allocated: 6393 FLOATP, 9236 LISTP Iteration 1 of FRPOLY10R3 Timing for : FRPOLY10R3 Elapsed time = 6.680 seconds SWAP time = 0.020 seconds reclaim time = 2.760 seconds net compute time = 3.900 seconds Storage allocated: 6393 FLOATP, 9236 LISTP ***** FRPOLY15R Benchmark *** FRPoly, Power = 15, r = x + y + z + 1 Evaluating setup for FRPOLY15R Iteration 0 of FRPOLY15R Timing for : FRPOLY15R Elapsed time = 36.440 seconds SWAP time = 0.180 seconds reclaim time = 16.440 seconds net compute time = 19.820 seconds Storage allocated: 31789 FIXP Iteration 1 of FRPOLY15R Timing for : FRPOLY15R Elapsed time = 36.540 seconds SWAP time = 0.060 seconds reclaim time = 16.620 seconds net compute time = 19.860 seconds Storage allocated: 31789 FIXP ***** FRPOLY15R2 Benchmark *** FRPoly, Power = 15, r2 = 1000r Evaluating setup for FRPOLY15R2 Iteration 0 of FRPOLY15R2 Timing for : FRPOLY15R2 Elapsed time = 3825.320 seconds SWAP time = 6.140 seconds reclaim time = 2228.760 seconds net compute time = 1590.420 seconds Storage allocated: 1049024 FIXP, 4717420 LISTP, 129648 BIGNUM Iteration 1 of FRPOLY15R2 Timing for : FRPOLY15R2 Elapsed time = 3834.320 seconds SWAP time = 5.040 seconds reclaim time = 2237.680 seconds net compute time = 1591.600 seconds Storage allocated: 1049024 FIXP, 4782956 LISTP, 129648 BIGNUM ***** FRPOLY15R3 Benchmark *** FRPoly, Power = 15, r3 = r in flonums Evaluating setup for FRPOLY15R3 Iteration 0 of FRPOLY15R3 Timing for : FRPOLY15R3 Elapsed time = 48.640 seconds SWAP time = 0.080 seconds reclaim time = 20.560 seconds net compute time = 28.000 seconds Storage allocated: 53297 FLOATP Iteration 1 of FRPOLY15R3 Timing for : FRPOLY15R3 Elapsed time = 48.600 seconds SWAP time = 0.060 seconds reclaim time = 20.700 seconds net compute time = 27.840 seconds Storage allocated: 53297 FLOATP ***** FRPOLY2R Benchmark *** FRPoly, Power = 2, r = x + y + z + 1 Evaluating setup for FRPOLY2R Iteration 0 of FRPOLY2R Timing for : FRPOLY2R Elapsed time = 0.040 seconds net compute time = 0.040 seconds Storage allocated: 102 LISTP Iteration 1 of FRPOLY2R Timing for : FRPOLY2R Elapsed time = 0.040 seconds net compute time = 0.040 seconds Storage allocated: 102 LISTP ***** FRPOLY2R2 Benchmark *** FRPoly, Power = 2, r2 = 1000r Evaluating setup for FRPOLY2R2 Iteration 0 of FRPOLY2R2 Timing for : FRPOLY2R2 Elapsed time = 0.220 seconds net compute time = 0.220 seconds Storage allocated: 48 FIXP, 654 LISTP, 74 BIGNUM Iteration 1 of FRPOLY2R2 Timing for : FRPOLY2R2 Elapsed time = 0.220 seconds net compute time = 0.220 seconds Storage allocated: 48 FIXP, 654 LISTP, 74 BIGNUM ***** FRPOLY2R3 Benchmark *** FRPoly, Power = 2, r3 = r in flonums Evaluating setup for FRPOLY2R3 Iteration 0 of FRPOLY2R3 Timing for : FRPOLY2R3 Elapsed time = 0.040 seconds net compute time = 0.040 seconds Storage allocated: 33 FLOATP, 102 LISTP Iteration 1 of FRPOLY2R3 Timing for : FRPOLY2R3 Elapsed time = 0.020 seconds net compute time = 0.020 seconds Storage allocated: 33 FLOATP, 102 LISTP ***** FRPOLY5R Benchmark *** FRPoly, Power = 5, r = x + y + z + 1 Evaluating setup for FRPOLY5R Iteration 0 of FRPOLY5R Timing for : FRPOLY5R Elapsed time = 0.240 seconds net compute time = 0.240 seconds Storage allocated: 966 LISTP Iteration 1 of FRPOLY5R Timing for : FRPOLY5R Elapsed time = 0.240 seconds net compute time = 0.240 seconds Storage allocated: 966 LISTP ***** FRPOLY5R2 Benchmark *** FRPoly, Power = 5, r2 = 1000r Evaluating setup for FRPOLY5R2 Iteration 0 of FRPOLY5R2 Timing for : FRPOLY5R2 Elapsed time = 8.520 seconds reclaim time = 4.200 seconds net compute time = 4.320 seconds Storage allocated: 1684 FIXP, 15346 LISTP, 1190 BIGNUM Iteration 1 of FRPOLY5R2 Timing for : FRPOLY5R2 Elapsed time = 8.520 seconds SWAP time = 0.020 seconds reclaim time = 4.200 seconds net compute time = 4.300 seconds Storage allocated: 1684 FIXP, 15346 LISTP, 1190 BIGNUM ***** FRPOLY5R3 Benchmark *** FRPoly, Power = 5, r3 = r in flonums Evaluating setup for FRPOLY5R3 Iteration 0 of FRPOLY5R3 Timing for : FRPOLY5R3 Elapsed time = 0.340 seconds net compute time = 0.340 seconds Storage allocated: 448 FLOATP, 966 LISTP Iteration 1 of FRPOLY5R3 Timing for : FRPOLY5R3 Elapsed time = 0.340 seconds net compute time = 0.340 seconds Storage allocated: 448 FLOATP, 966 LISTP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results b/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results new file mode 100644 index 00000000..079c2424 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results @@ -0,0 +1 @@ +Lisp Type: Envos Medley Lisp Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55 Software Type: Envos Medley Software Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55, Make-init dates: 17-Apr-90 20:12:20, 17-Apr-90 20:30:18 Machine Type: mc68020cal/lde/lispcore/gabriel/TOOLS/BENCH-1 Machine Version: Emulator created: 9-May-90, memory size: 0 Machine Instance: 31000c9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 pigmyc9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Site: ENVOS Corporation Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 82.806 seconds SWAP time = 0.080 seconds reclaim time = 5.420 seconds net compute time = 77.306 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 82.000 seconds SWAP time = 0.060 seconds reclaim time = 5.360 seconds net compute time = 76.580 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 15.420 seconds net compute time = 15.420 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 15.420 seconds net compute time = 15.420 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 2.760 seconds net compute time = 2.760 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 2.740 seconds net compute time = 2.740 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 21.400 seconds SWAP time = 0.020 seconds net compute time = 21.380 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 21.400 seconds net compute time = 21.400 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 3.220 seconds net compute time = 3.220 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 3.200 seconds net compute time = 3.200 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~16~ b/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~16~ new file mode 100644 index 00000000..079c2424 --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~16~ @@ -0,0 +1 @@ +Lisp Type: Envos Medley Lisp Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55 Software Type: Envos Medley Software Version: Lispcore 1.0 sysout of 18-Apr-90 10:37:55, Make-init dates: 17-Apr-90 20:12:20, 17-Apr-90 20:30:18 Machine Type: mc68020cal/lde/lispcore/gabriel/TOOLS/BENCH-1 Machine Version: Emulator created: 9-May-90, memory size: 0 Machine Instance: 31000c9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 pigmyc9fal/lde/lispcore/gabriel/TOOLS/BENCH-1 Site: ENVOS Corporation Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 82.806 seconds SWAP time = 0.080 seconds reclaim time = 5.420 seconds net compute time = 77.306 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 82.000 seconds SWAP time = 0.060 seconds reclaim time = 5.360 seconds net compute time = 76.580 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 15.420 seconds net compute time = 15.420 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 15.420 seconds net compute time = 15.420 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 2.760 seconds net compute time = 2.760 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 2.740 seconds net compute time = 2.740 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 21.400 seconds SWAP time = 0.020 seconds net compute time = 21.380 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 21.400 seconds net compute time = 21.400 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 3.220 seconds net compute time = 3.220 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 3.200 seconds net compute time = 3.200 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~1~ b/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~1~ new file mode 100644 index 00000000..5a58341b --- /dev/null +++ b/internal/gabriel/Results/Maiko/SUN-PAV-TAK.Results.~1~ @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 3-Aug-88 00:55:00 Software Type: Xerox AIE Software Version: Lispcore sysout of 3-Aug-88 00:55:00, Make-init dates: 31-Jul-88 18:16:30, 31-Jul-88 18:26:32 Machine Type: mc68020 Machine Version: Microcode version: 349, memory size: 16384 Machine Instance: 1300283a trouser Site: trouser Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 79.160 seconds SWAP time = 0.080 seconds reclaim time = 12.960 seconds net compute time = 66.120 seconds Page faults = 1 Iteration 1 of CTAK Timing for : CTAK Elapsed time = 79.220 seconds SWAP time = 0.120 seconds reclaim time = 13.040 seconds net compute time = 66.060 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 10.040 seconds SWAP time = 0.020 seconds net compute time = 10.020 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 10.040 seconds net compute time = 10.040 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 2.640 seconds net compute time = 2.640 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 2.640 seconds net compute time = 2.640 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 20.320 seconds net compute time = 20.320 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 20.320 seconds net compute time = 20.320 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 2.860 seconds net compute time = 2.860 seconds Page faults = 1 Iteration 1 of TAKR Timing for : TAKR Elapsed time = 2.840 seconds net compute time = 2.840 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/win-tak.results b/internal/gabriel/Results/Maiko/win-tak.results new file mode 100644 index 00000000..f8b201cb --- /dev/null +++ b/internal/gabriel/Results/Maiko/win-tak.results @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Breakpoint at CL::TIME-FORMAT. 2/357: ?= Arg 0 = # Arg 1 = "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" Arg 2 = 1 Arg 3 = CTAK 2/358: eval Timing for : CTAK NIL 2/359: ok Breakpoint at CL::TIME-FORMAT. 2/360: eval Elapsed time = 0.079 seconds NIL 2/361: ?= Arg 0 = # Arg 1 = "~&~A ~20,5T= ~9,3F seconds~&" Arg 2 = "Elapsed time" Arg 3 = 0.079 2/362: editf(cl:run-benchmarks) External symbol RUN-BENCHMARKS not found in package LISP EDITF -> IL:EDITF ? ...yes Could not find fns definition for NIL. Could not find fns definition for NIL 2/363: eval Elapsed time = 0.079 seconds NIL 2/364: evl EVL is an unbound variable. 2/365: ?= Arg 0 = # Arg 1 = "~&~A ~20,5T= ~9,3F seconds~&" Arg 2 = "Elapsed time" Arg 3 = 0.079 2/366: ub (CL::TIME-FORMAT) 2/367: undo No undo info saved for UB. 2/368: redo il:break (CL::TIME-FORMAT) 2/369: ok Breakpoint at CL::TIME-FORMAT. 2/370: ?= Arg 0 = # Arg 1 = "~&~A ~20,5T= ~9,3F seconds~&" Arg 2 = "reclaim time" Arg 3 = 0.017 2/371: ib IB is an unbound variable. 2/372: ub (CL::TIME-FORMAT) 2/373: ok reclaim time = 0.017 seconds net compute time = 0.062 seconds Storage allocated: 238535 FIXP Iteration 1 of CTAK Timing for : CTAK Elapsed time = 0.091 seconds reclaim time = 0.007 seconds net compute time = 0.084 seconds Storage allocated: 238535 FIXP ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 0.009 seconds net compute time = 0.009 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 0.008 seconds SWAP time = 0.006 seconds net compute time = 0.002 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 0.001 seconds net compute time = 0.001 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 0.002 seconds SWAP time = 0.002 seconds net compute time = 0.0 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 0.013 seconds net compute time = 0.013 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 0.014 seconds net compute time = 0.014 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 0.002 seconds net compute time = 0.002 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 0.002 seconds net compute time = 0.002 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/win-tak.results.~1~ b/internal/gabriel/Results/Maiko/win-tak.results.~1~ new file mode 100644 index 00000000..606af608 --- /dev/null +++ b/internal/gabriel/Results/Maiko/win-tak.results.~1~ @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 0.075 seconds reclaim time = 0.011 seconds net compute time = 0.064 seconds Storage allocated: 238535 FIXP Iteration 1 of CTAK Timing for : CTAK Elapsed time = 0.099 seconds reclaim time = 0.014 seconds net compute time = 0.085 seconds Storage allocated: 238535 FIXP ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 0.009 seconds net compute time = 0.009 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 0.008 seconds net compute time = 0.008 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 0.002 seconds net compute time = 0.002 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 0.002 seconds net compute time = 0.002 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 0.012 seconds net compute time = 0.012 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 0.012 seconds net compute time = 0.012 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 0.002 seconds net compute time = 0.002 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 0.003 seconds net compute time = 0.003 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/win-tak.results.~2~ b/internal/gabriel/Results/Maiko/win-tak.results.~2~ new file mode 100644 index 00000000..f8b201cb --- /dev/null +++ b/internal/gabriel/Results/Maiko/win-tak.results.~2~ @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Breakpoint at CL::TIME-FORMAT. 2/357: ?= Arg 0 = # Arg 1 = "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" Arg 2 = 1 Arg 3 = CTAK 2/358: eval Timing for : CTAK NIL 2/359: ok Breakpoint at CL::TIME-FORMAT. 2/360: eval Elapsed time = 0.079 seconds NIL 2/361: ?= Arg 0 = # Arg 1 = "~&~A ~20,5T= ~9,3F seconds~&" Arg 2 = "Elapsed time" Arg 3 = 0.079 2/362: editf(cl:run-benchmarks) External symbol RUN-BENCHMARKS not found in package LISP EDITF -> IL:EDITF ? ...yes Could not find fns definition for NIL. Could not find fns definition for NIL 2/363: eval Elapsed time = 0.079 seconds NIL 2/364: evl EVL is an unbound variable. 2/365: ?= Arg 0 = # Arg 1 = "~&~A ~20,5T= ~9,3F seconds~&" Arg 2 = "Elapsed time" Arg 3 = 0.079 2/366: ub (CL::TIME-FORMAT) 2/367: undo No undo info saved for UB. 2/368: redo il:break (CL::TIME-FORMAT) 2/369: ok Breakpoint at CL::TIME-FORMAT. 2/370: ?= Arg 0 = # Arg 1 = "~&~A ~20,5T= ~9,3F seconds~&" Arg 2 = "reclaim time" Arg 3 = 0.017 2/371: ib IB is an unbound variable. 2/372: ub (CL::TIME-FORMAT) 2/373: ok reclaim time = 0.017 seconds net compute time = 0.062 seconds Storage allocated: 238535 FIXP Iteration 1 of CTAK Timing for : CTAK Elapsed time = 0.091 seconds reclaim time = 0.007 seconds net compute time = 0.084 seconds Storage allocated: 238535 FIXP ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 0.009 seconds net compute time = 0.009 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 0.008 seconds SWAP time = 0.006 seconds net compute time = 0.002 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 0.001 seconds net compute time = 0.001 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 0.002 seconds SWAP time = 0.002 seconds net compute time = 0.0 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 0.013 seconds net compute time = 0.013 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 0.014 seconds net compute time = 0.014 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 0.002 seconds net compute time = 0.002 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 0.002 seconds net compute time = 0.002 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/x86-arefy.results b/internal/gabriel/Results/Maiko/x86-arefy.results new file mode 100644 index 00000000..5799a114 --- /dev/null +++ b/internal/gabriel/Results/Maiko/x86-arefy.results @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 0.039 seconds net compute time = 0.039 seconds Storage allocated: 1 FIXP, 10 LISTP, 1 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 0.041 seconds net compute time = 0.041 seconds Storage allocated: 1 FIXP, 10 LISTP, 1 ONED-ARRAY ***** TRIANG Benchmark *** Triang Iteration 0 of TRIANG Timing for : TRIANG Elapsed time = 0.571 seconds net compute time = 0.571 seconds Storage allocated: 11626 LISTP Iteration 1 of TRIANG Timing for : TRIANG Elapsed time = 0.572 seconds net compute time = 0.572 seconds ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 0.074 seconds SWAP time = 0.010 seconds reclaim time = 0.038 seconds net compute time = 0.026 seconds Storage allocated: 944500 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 0.097 seconds reclaim time = 0.059 seconds net compute time = 0.038 seconds Storage allocated: 944500 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/x86-arith.results b/internal/gabriel/Results/Maiko/x86-arith.results new file mode 100644 index 00000000..747a6ae2 --- /dev/null +++ b/internal/gabriel/Results/Maiko/x86-arith.results @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** NULL-LOOP Benchmark *** Null loop, 1000 times thru Iteration 0 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.0 seconds net compute time = 0.0 seconds Iteration 1 of NULL-LOOP Timing for : IL:NULL-LOOP Elapsed time = 0.0 seconds net compute time = 0.0 seconds ***** FLOAT-ADD Benchmark *** 1000 Floating-point additions Iteration 0 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 0.001 seconds reclaim time = 0.001 seconds net compute time = 0.0 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-ADD Timing for : IL:FLOAT-ADD Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SUB Benchmark *** 1000 Floating-point subtractions Iteration 0 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-SUB Timing for : IL:FLOAT-SUB Elapsed time = 0.001 seconds reclaim time = 0.001 seconds net compute time = 0.0 seconds Storage allocated: 10000 FLOATP ***** FLOAT-TIMES Benchmark *** 1000 Floating-point multiplications Iteration 0 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-TIMES Timing for : IL:FLOAT-TIMES Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP ***** FLOAT-DIV Benchmark *** 1000 Floating-point divisions Iteration 0 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP Iteration 1 of FLOAT-DIV Timing for : IL:FLOAT-DIV Elapsed time = 0.001 seconds reclaim time = 0.001 seconds net compute time = 0.0 seconds Storage allocated: 10000 FLOATP ***** GENERIC-ADD-FLOAT Benchmark *** 10000 Generic + with float args Iteration 0 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-ADD-FLOAT Timing for : IL:GENERIC-ADD-FLOAT Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP ***** GENERIC-SUB-FLOAT Benchmark *** 10000 Generic - with float args Iteration 0 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 0.002 seconds reclaim time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-SUB-FLOAT Timing for : IL:GENERIC-SUB-FLOAT Elapsed time = 0.002 seconds net compute time = 0.002 seconds Storage allocated: 10000 FLOATP ***** GENERIC-TIMES-FLOAT Benchmark *** 10000 Generic * with float args Iteration 0 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 0.001 seconds reclaim time = 0.001 seconds net compute time = 0.0 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-TIMES-FLOAT Timing for : IL:GENERIC-TIMES-FLOAT Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 10000 FLOATP ***** GENERIC-DIV-FLOAT Benchmark *** 10000 Generic / with float args Iteration 0 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 0.002 seconds net compute time = 0.002 seconds Storage allocated: 10000 FLOATP Iteration 1 of GENERIC-DIV-FLOAT Timing for : IL:GENERIC-DIV-FLOAT Elapsed time = 0.002 seconds reclaim time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 10000 FLOATP ***** FLOAT-SINE Benchmark *** 10000 calls to CL:SIN(pi/6) Iteration 0 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 0.012 seconds reclaim time = 0.007 seconds net compute time = 0.005 seconds Storage allocated: 110000 FLOATP Iteration 1 of FLOAT-SINE Timing for : IL:FLOAT-SINE Elapsed time = 0.012 seconds reclaim time = 0.006 seconds net compute time = 0.006 seconds Storage allocated: 110000 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/x86-byte-tak.results b/internal/gabriel/Results/Maiko/x86-byte-tak.results new file mode 100644 index 00000000..6d09682b --- /dev/null +++ b/internal/gabriel/Results/Maiko/x86-byte-tak.results @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 0.076 seconds reclaim time = 0.012 seconds net compute time = 0.064 seconds Storage allocated: 238535 FIXP Iteration 1 of CTAK Timing for : CTAK Elapsed time = 0.086 seconds reclaim time = 0.017 seconds net compute time = 0.069 seconds Storage allocated: 238535 FIXP ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 0.008 seconds net compute time = 0.008 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 0.008 seconds net compute time = 0.008 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 0.002 seconds net compute time = 0.002 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 0.002 seconds net compute time = 0.002 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 0.013 seconds net compute time = 0.013 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 0.012 seconds SWAP time = 0.006 seconds net compute time = 0.006 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 0.001 seconds net compute time = 0.001 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 0.002 seconds net compute time = 0.002 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/x86-consy.results b/internal/gabriel/Results/Maiko/x86-consy.results new file mode 100644 index 00000000..9324dda3 --- /dev/null +++ b/internal/gabriel/Results/Maiko/x86-consy.results @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 0.033 seconds reclaim time = 0.014 seconds net compute time = 0.019 seconds Iteration 1 of DERIV Timing for : DERIV Elapsed time = 0.038 seconds reclaim time = 0.018 seconds net compute time = 0.020 seconds Storage allocated: 48392 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 0.046 seconds reclaim time = 0.020 seconds net compute time = 0.026 seconds Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 0.047 seconds reclaim time = 0.021 seconds net compute time = 0.026 seconds Storage allocated: 63392 LISTP ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 0.008 seconds net compute time = 0.008 seconds Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 0.008 seconds net compute time = 0.008 seconds ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 0.009 seconds net compute time = 0.009 seconds Storage allocated: 54464 LISTP Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 0.010 seconds net compute time = 0.010 seconds ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 0.016 seconds reclaim time = 0.003 seconds net compute time = 0.013 seconds Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 0.016 seconds reclaim time = 0.004 seconds net compute time = 0.012 seconds Storage allocated: 43105 LISTP ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 0.071 seconds reclaim time = 0.020 seconds net compute time = 0.051 seconds Storage allocated: 29856 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 0.072 seconds reclaim time = 0.018 seconds net compute time = 0.054 seconds Storage allocated: 29856 LISTP ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 0.340 seconds reclaim time = 0.124 seconds net compute time = 0.216 seconds Storage allocated: 97931 LISTP, 229002 ONED-ARRAY, 1101 NEW-ATOM Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 0.377 seconds reclaim time = 0.129 seconds net compute time = 0.248 seconds Storage allocated: 163467 LISTP, 229002 ONED-ARRAY, 1101 NEW-ATOM ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 0.271 seconds reclaim time = 0.113 seconds net compute time = 0.158 seconds Storage allocated: 97931 LISTP, 2202 ONED-ARRAY, 1101 NEW-ATOM Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 0.248 seconds reclaim time = 0.101 seconds net compute time = 0.147 seconds Storage allocated: 163467 LISTP, 2202 ONED-ARRAY, 1101 NEW-ATOM ***** TRAVERSE-INIT* Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 0.063 seconds net compute time = 0.063 seconds Storage allocated: 36796 LISTP, 100 TNODE Evaluating after every function for TRAVERSE-INIT* Iteration 1 of TRAVERSE-INIT* Timing for : TRAVERSE-INIT* Elapsed time = 0.053 seconds net compute time = 0.053 seconds Storage allocated: 100 TNODE Evaluating after every function for TRAVERSE-INIT* ***** TRAVERSE* Benchmark *** Traverse, Traverse Evaluating setup for TRAVERSE* Iteration 0 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 0.114 seconds net compute time = 0.114 seconds Iteration 1 of TRAVERSE* Timing for : TRAVERSE* Elapsed time = 0.113 seconds net compute time = 0.113 seconds Evaluating after function for TRAVERSE* \ No newline at end of file diff --git a/internal/gabriel/Results/Maiko/x86-poly.results b/internal/gabriel/Results/Maiko/x86-poly.results new file mode 100644 index 00000000..a10d8ac8 --- /dev/null +++ b/internal/gabriel/Results/Maiko/x86-poly.results @@ -0,0 +1 @@ +Lisp Type: Venue Medley Lisp Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12 Software Type: Envos Medley Software Version: Medley3.5 2.0 sysout of 13-Aug-2020 12:39:12, Make-init dates: 10-Apr-2000 01:42:43, 10-Apr-2000 01:46:59 Machine Type: mc68020 Machine Version: Emulator created: 10-Oct-20, memory size: 0 Machine Instance: 7f0101 TV-PC Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY) ***** FRPOLY10R Benchmark *** FRPoly, Power = 10, r = x + y + z + 1 Evaluating setup for FRPOLY10R Iteration 0 of FRPOLY10R Timing for : FRPOLY10R Elapsed time = 0.001 seconds net compute time = 0.001 seconds Storage allocated: 69 FIXP, 9236 LISTP Iteration 1 of FRPOLY10R Timing for : FRPOLY10R Elapsed time = 0.002 seconds net compute time = 0.002 seconds Storage allocated: 69 FIXP, 9236 LISTP ***** FRPOLY10R2 Benchmark *** FRPoly, Power = 10, r2 = 1000r Evaluating setup for FRPOLY10R2 Iteration 0 of FRPOLY10R2 Timing for : FRPOLY10R2 Elapsed time = 0.124 seconds reclaim time = 0.052 seconds net compute time = 0.072 seconds Storage allocated: 44753 FIXP, 257817 LISTP, 15719 BIGNUM Iteration 1 of FRPOLY10R2 Timing for : FRPOLY10R2 Elapsed time = 0.141 seconds reclaim time = 0.058 seconds net compute time = 0.083 seconds Storage allocated: 44753 FIXP, 192281 LISTP, 15719 BIGNUM ***** FRPOLY10R3 Benchmark *** FRPoly, Power = 10, r3 = r in flonums Evaluating setup for FRPOLY10R3 Iteration 0 of FRPOLY10R3 Timing for : FRPOLY10R3 Elapsed time = 0.004 seconds reclaim time = 0.001 seconds net compute time = 0.003 seconds Storage allocated: 6393 FLOATP, 9236 LISTP Iteration 1 of FRPOLY10R3 Timing for : FRPOLY10R3 Elapsed time = 0.004 seconds reclaim time = 0.001 seconds net compute time = 0.003 seconds Storage allocated: 6393 FLOATP, 9236 LISTP ***** FRPOLY15R Benchmark *** FRPoly, Power = 15, r = x + y + z + 1 Evaluating setup for FRPOLY15R Iteration 0 of FRPOLY15R Timing for : FRPOLY15R Elapsed time = 0.024 seconds reclaim time = 0.006 seconds net compute time = 0.018 seconds Storage allocated: 31789 FIXP Iteration 1 of FRPOLY15R Timing for : FRPOLY15R Elapsed time = 0.025 seconds reclaim time = 0.007 seconds net compute time = 0.018 seconds Storage allocated: 31789 FIXP ***** FRPOLY15R2 Benchmark *** FRPoly, Power = 15, r2 = 1000r Evaluating setup for FRPOLY15R2 Iteration 0 of FRPOLY15R2 Timing for : FRPOLY15R2 Elapsed time = 2.313 seconds reclaim time = 0.937 seconds net compute time = 1.376 seconds Storage allocated: 774749 FIXP, 4105318 LISTP, 122293 BIGNUM Iteration 1 of FRPOLY15R2 Timing for : FRPOLY15R2 Elapsed time = 2.441 seconds reclaim time = 0.976 seconds net compute time = 1.465 seconds Storage allocated: 774749 FIXP, 4039782 LISTP, 122293 BIGNUM ***** FRPOLY15R3 Benchmark *** FRPoly, Power = 15, r3 = r in flonums Evaluating setup for FRPOLY15R3 Iteration 0 of FRPOLY15R3 Timing for : FRPOLY15R3 Elapsed time = 0.026 seconds reclaim time = 0.008 seconds net compute time = 0.018 seconds Storage allocated: 53297 FLOATP Iteration 1 of FRPOLY15R3 Timing for : FRPOLY15R3 Elapsed time = 0.026 seconds reclaim time = 0.008 seconds net compute time = 0.018 seconds Storage allocated: 53297 FLOATP, 48892 LISTP ***** FRPOLY2R Benchmark *** FRPoly, Power = 2, r = x + y + z + 1 Evaluating setup for FRPOLY2R Iteration 0 of FRPOLY2R Timing for : FRPOLY2R Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 102 LISTP Iteration 1 of FRPOLY2R Timing for : FRPOLY2R Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 102 LISTP ***** FRPOLY2R2 Benchmark *** FRPoly, Power = 2, r2 = 1000r Evaluating setup for FRPOLY2R2 Iteration 0 of FRPOLY2R2 Timing for : FRPOLY2R2 Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 59 FIXP, 31 BIGNUM Iteration 1 of FRPOLY2R2 Timing for : FRPOLY2R2 Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 59 FIXP, 324 LISTP, 31 BIGNUM ***** FRPOLY2R3 Benchmark *** FRPoly, Power = 2, r3 = r in flonums Evaluating setup for FRPOLY2R3 Iteration 0 of FRPOLY2R3 Timing for : FRPOLY2R3 Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 33 FLOATP, 102 LISTP Iteration 1 of FRPOLY2R3 Timing for : FRPOLY2R3 Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 33 FLOATP, 102 LISTP ***** FRPOLY5R Benchmark *** FRPoly, Power = 5, r = x + y + z + 1 Evaluating setup for FRPOLY5R Iteration 0 of FRPOLY5R Timing for : FRPOLY5R Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 966 LISTP Iteration 1 of FRPOLY5R Timing for : FRPOLY5R Elapsed time = 0.0 seconds net compute time = 0.0 seconds Storage allocated: 966 LISTP ***** FRPOLY5R2 Benchmark *** FRPoly, Power = 5, r2 = 1000r Evaluating setup for FRPOLY5R2 Iteration 0 of FRPOLY5R2 Timing for : FRPOLY5R2 Elapsed time = 0.006 seconds reclaim time = 0.002 seconds net compute time = 0.004 seconds Storage allocated: 1481 FIXP, 12984 LISTP, 982 BIGNUM Iteration 1 of FRPOLY5R2 Timing for : FRPOLY5R2 Elapsed time = 0.005 seconds reclaim time = 0.001 seconds net compute time = 0.004 seconds Storage allocated: 1481 FIXP, 12984 LISTP, 982 BIGNUM ***** FRPOLY5R3 Benchmark *** FRPoly, Power = 5, r3 = r in flonums Evaluating setup for FRPOLY5R3 Iteration 0 of FRPOLY5R3 Timing for : FRPOLY5R3 Elapsed time = 0.0 seconds SWAP time = 0.001 seconds net compute time = 0.0 seconds Storage allocated: 448 FLOATP, 966 LISTP Iteration 1 of FRPOLY5R3 Timing for : FRPOLY5R3 Elapsed time = 0.001 seconds SWAP time = 0.001 seconds net compute time = 0.0 seconds Storage allocated: 448 FLOATP, 966 LISTP \ No newline at end of file diff --git a/internal/gabriel/Results/Medley/BYTE-AREFY-1186.RESULTS b/internal/gabriel/Results/Medley/BYTE-AREFY-1186.RESULTS new file mode 100644 index 00000000..9197eb47 --- /dev/null +++ b/internal/gabriel/Results/Medley/BYTE-AREFY-1186.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 15-Mar-88 18:32:37 Software Type: Xerox AIE Software Version: Medley sysout of 15-Mar-88 18:32:37, Make-init dates: 15-Mar-88 16:19:01, 15-Mar-88 16:38:25 Machine Type: Xerox 1186 Machine Version: Microcode version: 107, memory size: 7424 Machine Instance: Wills1186 = 25220220072# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 46.241 seconds net compute time = 46.270 seconds Storage allocated: 10 LISTP, 1 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 46.279 seconds net compute time = 46.279 seconds Storage allocated: 10 LISTP, 1 ONED-ARRAY ***** TRIANG Benchmark *** Triang Iteration 0 of TRIANG Timing for : TRIANG Elapsed time = 829.979 seconds reclaim time = 0.565 seconds net compute time = 829.414 seconds Page faults = 79 Storage allocated: 11626 LISTP Iteration 1 of TRIANG Timing for : TRIANG Elapsed time = 828.981 seconds reclaim time = 0.550 seconds net compute time = 828.431 seconds Storage allocated: 11626 LISTP ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 206.390 seconds SWAP time = 0.213 seconds reclaim time = 115.504 seconds net compute time = 90.673 seconds Page faults = 31 Storage allocated: 942640 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 205.926 seconds reclaim time = 115.455 seconds net compute time = 90.471 seconds Storage allocated: 942640 FLOATP \ No newline at end of file diff --git a/internal/gabriel/Results/Medley/BYTE-CONSY-1186.RESULTS b/internal/gabriel/Results/Medley/BYTE-CONSY-1186.RESULTS new file mode 100644 index 00000000..bdb7da60 --- /dev/null +++ b/internal/gabriel/Results/Medley/BYTE-CONSY-1186.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 15-Mar-88 18:32:37 Software Type: Xerox AIE Software Version: Medley sysout of 15-Mar-88 18:32:37, Make-init dates: 15-Mar-88 16:19:01, 15-Mar-88 16:38:25 Machine Type: Xerox 1186 Machine Version: Microcode version: 107, memory size: 7424 Machine Instance: Wills1186 = 25220220072# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 69.577 seconds reclaim time = 46.420 seconds net compute time = 23.157 seconds Storage allocated: 245000 LISTP Iteration 1 of DERIV Timing for : DERIV Elapsed time = 69.236 seconds reclaim time = 46.056 seconds net compute time = 23.180 seconds Storage allocated: 245000 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 82.165 seconds reclaim time = 51.815 seconds net compute time = 30.350 seconds Storage allocated: 260000 LISTP Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 80.605 seconds reclaim time = 50.652 seconds net compute time = 29.953 seconds Storage allocated: 260000 LISTP ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 30.382 seconds reclaim time = 20.370 seconds net compute time = 10.012 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 30.130 seconds reclaim time = 20.251 seconds net compute time = 9.879 seconds Storage allocated: 120000 LISTP ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 34.071 seconds reclaim time = 20.934 seconds net compute time = 13.137 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 34.371 seconds reclaim time = 21.338 seconds net compute time = 13.033 seconds Storage allocated: 120000 LISTP ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 21.845 seconds reclaim time = 5.860 seconds net compute time = 15.985 seconds Storage allocated: 43105 LISTP Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 22.247 seconds reclaim time = 6.057 seconds net compute time = 16.190 seconds Storage allocated: 43105 LISTP ***** TRAVERSE-INIT Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT Timing for : TRAVERSE-INIT Elapsed time = 77.801 seconds reclaim time = 1.174 seconds net compute time = 76.627 seconds Page faults = 342 Storage allocated: 36796 LISTP, 100 TNODE Iteration 1 of TRAVERSE-INIT Timing for : TRAVERSE-INIT Elapsed time = 120.992 seconds reclaim time = 1.321 seconds net compute time = 119.671 seconds Page faults = 433 Storage allocated: 36796 LISTP, 100 TNODE ***** TRAVERSE Benchmark *** Traverse, Traverse Iteration 0 of TRAVERSE Timing for : TRAVERSE Elapsed time = 142.926 seconds net compute time = 142.926 seconds Iteration 1 of TRAVERSE Timing for : TRAVERSE Elapsed time = 142.926 seconds net compute time = 142.926 seconds ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 139.292 seconds reclaim time = 40.000 seconds net compute time = 99.292 seconds Page faults = 557 Storage allocated: 226464 LISTP Iteration 1 of BOYER Timing for : BOYER Elapsed time = 133.852 seconds reclaim time = 40.084 seconds net compute time = 93.768 seconds Storage allocated: 226464 LISTP ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 1649.867 seconds SWAP time = 0.120 seconds reclaim time = 795.324 seconds net compute time = 854.423 seconds Page faults = 99 Storage allocated: 491147 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 1677.013 seconds reclaim time = 809.323 seconds net compute time = 867.690 seconds Page faults = 50 Storage allocated: 491147 LISTP, 229002 ONED-ARRAY \ No newline at end of file diff --git a/internal/gabriel/Results/Medley/BYTE-IO-1186.RESULTS b/internal/gabriel/Results/Medley/BYTE-IO-1186.RESULTS new file mode 100644 index 00000000..203b492e --- /dev/null +++ b/internal/gabriel/Results/Medley/BYTE-IO-1186.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 15-Mar-88 18:32:37 Software Type: Xerox AIE Software Version: Medley sysout of 15-Mar-88 18:32:37, Make-init dates: 15-Mar-88 16:19:01, 15-Mar-88 16:38:25 Machine Type: Xerox 1186 Machine Version: Microcode version: 107, memory size: 7424 Machine Instance: Wills1186 = 25220220072# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** FPRINT Benchmark *** FPrint Iteration 0 of FPRINT Timing for : FPRINT Elapsed time = 12.856 seconds SWAP time = 0.078 seconds reclaim time = 0.336 seconds net compute time = 12.442 seconds Page faults = 3 Storage allocated: 182 FIXP, 456 LISTP, 2 VMEMPAGEP, 1 STREAM, 72 ONED-ARRAY, 1 PATHNAME, 49 PageGroup, 1 FileDescriptor, 1 \BTREEBUF Iteration 1 of FPRINT Timing for : FPRINT Elapsed time = 12.819 seconds reclaim time = 0.334 seconds net compute time = 12.485 seconds Storage allocated: 170 FIXP, 502 LISTP, 1 VMEMPAGEP, 1 STREAM, 96 ONED-ARRAY, 2 PATHNAME, 50 PageGroup, 1 FileDescriptor ***** FREAD Benchmark *** FRead Iteration 0 of FREAD Timing for : FREAD Elapsed time = 11.733 seconds reclaim time = 0.600 seconds net compute time = 11.133 seconds Storage allocated: 107 FIXP, 6241 LISTP, 1 VMEMPAGEP, 1 STREAM, 87 ONED-ARRAY, 2 PATHNAME, 37 PageGroup, 1 FileDescriptor Iteration 1 of FREAD Timing for : FREAD Elapsed time = 11.773 seconds reclaim time = 0.643 seconds net compute time = 11.130 seconds Storage allocated: 107 FIXP, 6241 LISTP, 1 VMEMPAGEP, 1 STREAM, 87 ONED-ARRAY, 2 PATHNAME, 37 PageGroup, 1 FileDescriptor ***** TPRINT Benchmark *** TPrint Evaluating setup for TPRINT Iteration 0 of TPRINT Timing for : TPRINT Elapsed time = 27.110 seconds net compute time = 27.110 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Iteration 1 of TPRINT Timing for : TPRINT Elapsed time = 27.120 seconds net compute time = 27.120 seconds Storage allocated: 4 LISTP Evaluating after every function for TPRINT Evaluating after function for TPRINT \ No newline at end of file diff --git a/internal/gabriel/Results/Medley/BYTE-TAK-1186.RESULTS b/internal/gabriel/Results/Medley/BYTE-TAK-1186.RESULTS new file mode 100644 index 00000000..6e4395f7 --- /dev/null +++ b/internal/gabriel/Results/Medley/BYTE-TAK-1186.RESULTS @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Medley sysout of 15-Mar-88 18:32:37 Software Type: Xerox AIE Software Version: Medley sysout of 15-Mar-88 18:32:37, Make-init dates: 15-Mar-88 16:19:01, 15-Mar-88 16:38:25 Machine Type: Xerox 1186 Machine Version: Microcode version: 107, memory size: 7424 Machine Instance: Wills1186 = 25220220072# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 1.631 seconds net compute time = 1.631 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 1.641 seconds net compute time = 1.641 seconds ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 1.721 seconds net compute time = 1.721 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 1.719 seconds net compute time = 1.719 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 4.591 seconds net compute time = 4.591 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 4.599 seconds net compute time = 4.599 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 13.350 seconds net compute time = 13.350 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 13.358 seconds net compute time = 13.358 seconds ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 82.491 seconds net compute time = 82.491 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 82.498 seconds net compute time = 82.498 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/SUMMARY-TIME-SERIES2.tedit b/internal/gabriel/Results/SUMMARY-TIME-SERIES2.tedit new file mode 100644 index 0000000000000000000000000000000000000000..7eb773cc77e2aef12354935d2ebeda85f124f3ce GIT binary patch literal 7448 zcmeHKJ!~V_5q`USch0V3r$_>%aPe#-hU1!CNM}KKKlA3z z&o?uVvj<^(KjrNxJ4v%qIPOQhH_T?d7mp%M>kT7*nuZBaPk26zr+gY^aWtjvaWw7^ zM`3oKXVG+)izyUhXP;!EMQ~qJS)9C){O%mQuv*_*p z@EE2hZ+B-SSb2U^@6`u!&f%rF^r!Ot@ru}RJP@bhWRj(mEDrMsH`08Z=1?)eo5Hnh z=^k9@5jcaiKO05koD)zvj2Li0@?kxTr&k-cMM!UT1+ImSnx=MVV{YHFT;q9Gn(E#% zom;+7vtP`XSxot?S&Plt9$Osc1bi2FN8t1Y3m4G=`>lKs8+Dd zV%d7&%^6h7()|lNv4a_l(J>Z$YDt|7-Vs)thHe?qX_&g{s-C4Az8W|*`i5>Aud0Es z2af7Hx^K{dB@XC{8sLhfdY&G*n%15@dXz+};~Bc+Y^#nN=z+1VdcN+NG`gnhyM#MN z2V+2L%h4czq0R^0C{-h#olnIQrG;J9t5D;Zh6BIF0uK4x zs%5ygZWuH}q@kKs12J=HHej%7ItUTa!EEV)5750pcO9BN-Sf4*y&jx_Zm<9&+;D92 zbX#>zy&Al#+O|n9m?YLw?W&>M#m>Rbv2@GASylH8GMA!f8XhUI5gV|W23Q&lAzzk8c6`-0R!~FF0lrL(1{cgsjTfr(>$B? zbJewU7uZ0eLDCJ1J#0oyst}JrK!T6J*fu$DRdoaw$RWRg12D1;n5tSP#Rgdp*DOP? zI#7_sXK;!{iu8wvZdI5klF$>dTRuRf6!F32>kg7exBy9@AfkYT=#~n8(n$boyQS~| z8Q`jj4o0)c<|+lBa+Gj|AIM0LB7-%|4=A@N4uM74kE8&davE8P$Rcj8b~`=C6Ker1 zSb*#z6fIcp2ZaMboNNTBfP@m!#{&f-BtfbvFjP&HxP>#1L}G_LLUfSHK-okD0!zD{ zr4ObN3KO*j7-0@@3;-vbbv&WgMaBVE8wrK5x|A)HjR6_!T6mIRGqA&TC!lB}N+=@} zIbIC}fHvj2QL4IWBc!Nm#0i!I6VgKVpt>C@2v`Zh77~$ST!esjWFF-uLP3utOejjv zqVn)j+Tqz&V;twmh$2YPLbU{&9Au6eAa#&W77~VP-9p9&pa;MPPm(Ac_ynAQGF(zc z9wHmDvo56H#KHUzj}&mBIul8P#6Xd_1#^@ERVq@{fQ`IF;aNWAu$WMQ7P5mL76cuc zZ^3(Fp@)tp*i32WQEubKgkO(s2JA)2IVv}}rnmz6G-69Vo*6Q-)G_0X`4bF~T% zUyLX;IO>%n(cO{`X90RKf{q-ZkzQ$sV4%@;wY@?hqJWae&rH=7h?IE41E@wl!W@*k zk29RmTZJOTczn9l09MvCP;&(hJIy!V5?yhaJP6OH zd@>v7ba9eJXK^~4Cg+=coIc$%CB{=YsQOC5Hd?x2mB<9B7PR)7xg%ac#@{~XOnHA>|UvC`;xW_TH-~Y zH{}`P2td;b8h)}M8=!yQ7)Hrt%8Q3-yP|2DsnYkx?Q=BU^X8L4j!t5HU7Td;h=-++ z_)+nJfWDjzO(JT$fgzO8XGilqi~A&Fgai?v8*_P@rPh*sn9fdzS8(>rwin$za_TtB zbJz+o)c@cLEFcZS$T{m~p>V6*4+>sN6G+$?%JP)rFguNsb6)x}igAsqk56ZlNtzX( zRC`GZ6_nd4-XM-_$%msTkNdh-RmE?d5Du&6AZ_)Nl)e+E6f_Yq%~kKDKANL(?b$J~9Ku4hTRze=nL!fVrW}~&czSf+Js%yX$<{a=QDKWWU*~3pZy4O*USM(8w6NO{GUm!UwdUdB zoi5*a@2IxRcj~QPy;I+<@SS&Ro${o6L>BFI8tongHClHY-Nx-^ogeP)@ov3Y-|4ks zQcvvLox>go_1)r>+%OHkS377l-{%L1yY)_sAKtBZnvGT|px0^KsUIE{*NiBep;VtkrlnLU)*$1?j&W?#q>m!-BW<+AjVEPX0VpUd(q zvfPyAiF}2~g1k%9vc)g36PZ1hrI%&tSeE`G%P-0D2hWyqurA{z^7=Old#td3D$>h} zCAWp6U}kg-2A_8%r~GHJ-9kC^liCci?gSO2xyH{EZZHAs)A+#sZFYUX zhE{-;S4-tGyN;Cza1j(4c>uKN_yro6Ou>}SXo&^>1fk%V6X@zbogrBGlZ7P#Etd&D zTP9GZQ=k_d#3?k=Lg=4Mrwthexs1$}#X`XMWhiuA+@giJwL%eitWf4K3XOCkSiX#^ z%RDQBzmoD7VZf^Am(96M5qPaAzf2L5S9mUYep&hDKwPGLmrPy}e1$6FA?Ij5D3%ul zaY%^HIeuO&F9^R}C!DSmF3I@GI>%4f3E?{75{Jm+Wy6N+SMIM9L}JqwVGxzv-F21^ z)(Klg5d0-Vm;5)@Io?~B@zy%w&1C}RqfjufG%{0|x=d)$m1V;5Iw4*s^wtT#T_>!l zeX1P`r20?2OBnuoej>`7OyqM4fpTkupG11uhI+es3u1>uxVW4mMJF3(lK2 zZ{El6y*HZK13$bU^KOuw#>v>93zR#X%hNbfE{r*i8Gie_QnV; zS=omWJOXDJ4`$!; zJd`$1rRMqfRa-a9>f^`kAK!b-HYbL&x?-(N)>f{Vkop8FZFgm3dDWP0tgNh0R*l(f zlZ67UpTU3A){(Fx0L)gxF)h8a+-sV8Z5a?|*2T z-Hf&J(jm-N;K9sX8pUiGw6;sp)J*cfS|v|w@ZM0Xt`5vxSFc)XwW3!X)h*L%6=n>g z4aguCK_ep2WlPAQj4j>LwC?QT!zfUzW%7%@FyQEw{EH0^DVl$)!c6`x>s29-NS&H) zIpPc2(Q9S;qUt?#{NxNdsMd6+Oe40s7|jYP!f5Lb&8?bl)4Ek9)G-Pr7-7UwO{)yI z#3*9Myh5;H6!|nQ0}*1sS%V{n)@*vJO*n&PAjYz4+ZEk}A;>|WZMu35W(*XcrP_w8 zyCjLM8dx*PRVcDa5ECF>BkQ(-!4PteqiK8LxwX?$ZFmY#Y@rvqfB-5E(ufpvSy-rw zD9gI#5+At$A9(>yQGzV@{I+XCwL|J41J`cTh+4rq zf?cCgdoV#pwY?zClGz|rfi|khGAPNQ=?mIXE%*vF0 zRUpZe@+3T0tF~@Hrm7n#ALIyng!@#Dkax&Ql7TJoA!89Tpb;EsAO;%fp$uK@1%{5c zm#cPB+(@KDn7E=$kW;8biKCQk6g}DiGJv(ByWkh{Km;@;5PL!Ad#S>;JMkq>W79!* zBaR$h)4@hW3(N?N3W|ef&`&dDj3jMQKQu#9DB)NuizYCQib!?^wFODk4B1KIi!@Lx zC?vpUJ0`j5z@7uosZ|`Tfr+(>h`a)i0kd5u1k{R)HbGqIf|`L@nc}d~0|>kV*no&A zaA$7lrmd>rhy@GYK`-V80-`J;36MuXC?5;$fs&eP?5_4+Gz$yNCe^1fDDL%Bt@fG$Un-82777hCXArAsd@n;6*}6O zH014r+>>PtH5YX@fM+5B97iks+PT#WD%oU=Q>C8kTNFh3a>N-E9M7}}8Gy0;C zs)QtJ7|`KM2Os(lG)l?Qnn~afiBE^1=m_X5q{xQoMXVs@#HZd8wnguvIO){F!HBO7 z-I~^+8{_L*zqrV8=axx#F22L-y+)JAxTOy1COzR>;TX5gb4>D|w$e7=t@rTR>*4y# zqi_=FYl2|TBmpQ0`e@M@sf$i@YHL#Iu5S$IFkb;wVXAmHade%()^ zfJbqBe>S}>j2+L7-G0Ja3Ag&iMK$FK5(z}(Dc&sPK{CV>U~3da)0F4OJv(?#K+iT5pwW6D+@i@TSBMrtU(IqD@ zxA{ekgN4r(Xqu_gIKo1|0Op zYhNbefOL#e%i?WU=+i8<9%Z9=b~d^~axi~k;OT_&pMwN7ba})Uct93}lZEJZZg6Kl zALg=D(a^9poZ;aalj{fPQJ7|>`Au3pUI+0k8p2AR#qc4$&rsI7W~+G$Z_>-n=i_)7 zo`zUOwWafSDEVU(@^t6Sf1 z@J_4EL3JCwe(U`PZ|B|8u6OqOyWrmD9&aADTZgSq^N?@Vd-Xf5UHOHU3*(a5+akIp?3~umh&Ek$}VYVf76vle>_Tk~(KHqxhsJ_Q{8y&CFYwVTy?pyWV ze5HRx9_{v8T@Q*{op)RP)}3~PA2yr3-)J{>y)Inx#Jt-(^uTEB<*O8iY4B$Kpw+&| z4-WSly$(Nox6y02I&%eHuXVR^c$9BH>Of+#);R9gJN?#ShxZ!$N9}r#_uGfv#$xtf zqqYB*#}68Nt)l~StkEkhANBE%5Q2#??R)p&E~pal>mAgA&NBc6L{`P(R+(EkKW(R! z@7(el$DU9p(qucl?DDE*@QUT;A|>qn(()+0|2mUjXEN{BuX~cZ`M>GOQc0Y&FEEwe zW7pYr`Ojj`6p68ynWwM^3j0`LpDFAMMdFIoRisRjK2oGl73p(DenpYniab^FO;>!M zrdVbVWcIPlK9kuOvczSnD@&OyeI!et%F^eu{E95MWqB%Jp)zOh(Xi_A4R$KCN3!&? zES<>GA7%L^S^nVJIu15{tnkdq573oik^!H~+`u3VK$g1oO z#vU;C2gd%%q-`dRnDh~o{>tQ6Nc8HzF8k(6XxA8f5!qosRoHJtGX5o!@wOuUT9H0c zq`xTgwP$;E) zp6nY7qtE7jHVDqhW<1%{zlt^%%6d82@v}pMT zeV9zil+K9+fj_~>B?<;@-KRAq3xBfkM8Lkv_%W>&461ZW^nyVP!XgpEexaQvYu4=S8@*j*h@<4V^EK^8`A=ov+CFlVJ&W$a+yJ$2qxV zh(*d?A@QS}Trw^;8N*G+f7bEd<`z-^t7hNdlz76A(WXSW$q+3=N`*tz%y&0MKGWvdQ?_Cd1og{A!c2v&q1( z+PancCS%Rhr@AgA2;9L__tMHQiWN-qBa#;!Vo>l4Ef23;>0G%|x^m^UVr5}jBnQBL KD`CHX_~_rWHBO-b literal 0 HcmV?d00001 diff --git a/internal/gabriel/Results/SUMMARY-TIME-SERIES4.Tedit b/internal/gabriel/Results/SUMMARY-TIME-SERIES4.Tedit new file mode 100644 index 0000000000000000000000000000000000000000..7e030b234db27b092566e1e43702514b34401aac GIT binary patch literal 7614 zcmeHLJ&fbV73R;`4(Zq_>>`DWfsMecgO)3j5=A+VFIug%mQSmdC9ZQ0kRPtZT`@)TvUW43JcT3j>$$4M{Cmw|jPCr1Ro1oO$!! z_kL&e<_=u{e#Ayzd=kYAH=KIRna3;U_zO=}ow>(OBR62t2}|dG!V)j`y@Zy>UO1gE z-1t6=y<`=n2|ITamPTyhxydT_!0)kT2^KQPI1|@xz&a=Fe8JVXZN#vS}2OQm*6#atZsOJMK?@`X+%-qu6_E-#vz@ z!CRBn0#;t!)|~FlPZ_-ALch!RA6#=e_+kciSSN}-~Vjo?~bl7kBl z1!opbR|_vp83ihZ5i^F6e9(>k!F zr)K0|lfL_%!QtWEqtR_;=%$(zyP?+FG3tt5+rdBER+XW5&N|UziO|NhxN~Lor55UL zQ8|herEZ{fMn~7qhE$N*c4>NzjGE_Cb=>=ksnsmy@nhki-+C<2!oGf?wX8deVrUJU z##XK1B8(VvX1$=$qKsJD(ONA<(Mbm|>@|}*Nnway)0%4%txAF$E3H-|9Me>kmew>1 z&16fU7=~u9&Eu;}muS!CG>hy2ilG@a)--8r2if==+EVb8j6tmXS>OiU0 zKv9eq9IGjIOS5Z=sY48fZ)*($Fj<;(1O_3{!DJ(8s=DW&8QXouw7C&=!Z&rTj#xt4 zP)vhr33I)OE@BK@3|q5cEFx%S5M!mTQ$X}4d1clq@w!P7Hyb>(rdGcUa1BmD4fzRU z40X>-(s(sZ3AX`vT2zjPr6H=AqiT$%R?Frbq)st`6N=H`{5EPCAhCa@H0zXA@WTMh z(CU!o*|torfjKYqtWGGGN&_JUS*H~3We7H0fal16ozM)6OoeMrI6`41%o2iSQ*aE# z+*Ws^3tSd@1LuX3(jo}GjwsPer-ITECR7Y1i~_6GkP(a)Mj#_}tp@B@cjM?h@n9Xo z1O130J`ErtmnIxScp7zH&?ZWJU3NrQ8i*;1*{s=@NViR_xkow_v=AU0-oOAj3#$y2 z4303ZD6RQn_H``QWi%{J&pt4PRyb4i0Sm0- zh9SFv!P$WnJ~eoVAI>mUOxT43fU!;^tjb0d3t?icWhXP-ad9BvKjj*AsrE7e9mRko z!6A%DA5sJg{K&jP0ptLPE}7EcW+5rI+KWARhH~Q(go`j2Cj+7;KUJt}KBqb*A&e+= z&JR^4@}a6j`pJJoUH=j@Ye%>7+sL+Ad))1@2yMoUTA`3_`3tlQXINxcWu?kG?JOm?S8t8W)rgjEze1|t?ZgB2iBy70~QxaUp-kBe*lHj7s!swix_z%#nTso3n*i}~C zO;xt8+f7ZaOHEbQd(VwSSWZ4)1DANHGioO{I;agylbR4%pT~8^PGZkvXD)t4jsuSc zQFMQ`yu+2<%az@ELR$rG*}Bz8Sd5km5sj8;I>~}~h8}Kf?gh()Wf#t!N-0Uro!Y(3 zh$Qs`YCh8x0_0z={|d9-d^&Tr0C?N!^@n>`WO2#64UUviN|tCVf6 z5>)i=!0Ei*9KOOKaKxQvu)4As^X`J4Nqv(@S$8LZkIA!zn1U-C78Cp*2 zI1@-_b|uUOf5^K%{~?v(+&`rb8*TK7n;`5JdI@-eyG*c4kA^Cv`)Y;v1|Au^oo)%f z=wS&S&Wt+D4gAxP_vKseDvh@Na2k8G#yLF+$<8W5m#%o>u7h61Y_Tr9Jm+l7vhOl~ z=0^(%=QWXgsH(c+kU1B4G!(rvctY>Q$Lr`Mjuy<#3($X^SB>^%SN2F?l}sr*pz z59(G+7P#@LheMS6vG8#S=;}sEFPBlAJqde31Qm2KM)>VQLHg-@;idjmQyU6zY&baL zQ3Ppw8btKYO(p-C6W@)OFj+gEv|oBbIYmsOvQwS6i?G z65OU5K*_r^jZH2V$5F5yy0{ARWS~*xXA1j><65&O(4V|D=uaHBwKZz*ciFH%V3>`% z<4OPfT{g(>uR(jbH|cJQ)RPx`xqE<5b?*rYq?cAODRa`<{QK6F6n?q$2=hF)X6_CbH}K07$v>yC%)@V)MM z&>!Xi&bWWKdw7(I9}U5=-s|2QwTF}b;gF5H`$q#@X_LX>sJmW$uiM{$+hGUYz5dYw z8P**anvW*Io*2>hvR87 zEmpT#)2OkAVP`BANdDjQ$gTe>lV4>rJFQ=xNjlA6B;g}T z__HK@CW%ZEN0OLI;)jy>i6nk1Nv}xKK$4cy4Uidmk3MCKpA$|b;gKZ1D2d0C_ybc};dj2Fo3U&z8ES@^pwz9@^fEQYf98(I9LEdJx^p1yMh47`f)rXV~Jgx?Fo zzXY)=h;u>wP!RtnNUsp<&3_}|>m}E23BvQpj__ky_%%<)zj-p=k;Pxh;>WW1S6RCC zbjwCib(!2RkN0gdUHmk2fQsc7xd|WP;Kv#DrjZA!Ec!nOi8S02o)cacp3Qzdg|DrZ zKArZ>j1Q%8$@juFv}Xk#*6aAd{gUv^ejBZTkc;NZCE*#&c!IN}NT>rui?*MmL69h! z;u%db!5=4N90h?y_h}Ew!k@$~d4r~9!Vk&>s`PQ0K%877O}PF7ofc#ia0N0~;@doY zwDlCq%OrJ$hdas9a~K|u{~GwE&j)^P@HdD)Pq+#o9GC)D&Z?rbDB zUap)!2gxp1V#o0*(CgO zld!!>z|DRYl>1WF!ZTGSn42Q}JeN6sw8`=FO~MuTuZ;)ipo~qgm8G4Z6+2jDcMmHl lM4*VSQ6Ap7!?Rhoel1hEQRcN`XRZ0&obru73BP^#=szfnK-2&L literal 0 HcmV?d00001 diff --git a/internal/gabriel/Results/Summary-Time-Series.TEdit b/internal/gabriel/Results/Summary-Time-Series.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..d7b98d6cefc98937b547d0e2aae3412c35e66958 GIT binary patch literal 8370 zcmeHLNsJ@a8LnlR@G60f#6(FX4lf`=_lT~peMu0bo^E$z#_euwHw+O{aNE`6%GfTe zT<)13Ktd79G0G{*kpl;m6Ne~59652|kXxi2A`Ur53a5xeq{;Wca+Q}}*u)L1=hdsf z{`LEpsyDZyG`YuX@p#1dqx2|A2kl`e;;mjf;jMTOXGm)hc6x($dWWacc+$_t{BC>9vxE<#_IQ#;;E(udPAz0^%?u{TQOYwI(K+8vQr?ZS zcHED;Ji0gPw}a(mtKjHR8kZkmS1n7eNI>w#Zh?RC>#4+7?`8y;PQb;HJ$-({w; zjz6&lF~Ck^H%<`wW-=H7+jQx!9^L&?j~4jOz0p`J$=ZFkxqt9AcDLqa7WUdSzgnw( zhncz;7K`h!2M?tGJoP{#N-%$8pM7KN#*EF-U7J~YXq3FV>w#cdCBe{ro6M##;QPhm z%@{y7OK#kp^TgKenXj;G!c5>XrX%N;?#`qP#Gy4a1nTIvS1gt}Gvey5Us`l@H=Mh1 zX2F@pqDjYQA-TtN$76wR%@o2NmtyQQ)6%`!G6$ifdoz9$!MLSS+&QynmZjS>9}o<} zGjxu{q;8L;)WO$ya@b#uCyx-*A{1A$qvfu%bk%U9Ra{h1SiO*VXlY%xNR z`5vW`>Au4}OuAEEgi-I%V9t%o+7uE028PQH4&0$*)j$!I1kTk=P{1U+;44+_!ZHooIa631?z1@POiy%GEpiq6m=-Xt@3>@7= zRzSm@Ww-=D2rqF1g{B27K-6cpDQpJ;6)Lh8GRwDglY$LV$W}-WqBo2{)3)McYpu#` zgDNbfLbqXz9M%z>Za_OsYvF&JJ`NO^xdFm~H6>iV*BrbrZG%9sPzqI>-!k zA8~@k$t^WVJwlK7|DJ-h=8 zSqcyp^*i=KsBJ~#ES+>RG9Q2!t&2QTi9it~P~iXriVzBA3xJewk$&2vQbdJV2-%`)2g2|k zQw>3d%tgjUP^cxKlEY`&+E#8UfbSGIv^eA^;0NZQV)*14!XC|!B!?~wp$t4?G@;IH zgG5o)!V+9X&aj6i2lLpaMA?pZBRRo)$20^=@DJ>;5?U<8SfK>a0EBKwfQx(roe%*d zXAVXdE)b>qfKs?mcT^!_fq4rkio~IGQFGXPo^~Tm?v5iwkn{S~=dOWb1FSxvvzUuQ z2~p_*+7?PZm@CtutJm<-JzQR8H!j8NfTKmtOM}EOn}Cu(xeijIuLn(LhAGYPcgGBOcbh41dJ(#3-W@h zcf~6L4S@NERb&&h9@u~adw4gM_O8M2{D=C3*MJq%0KsDB`^XMeg#nxJQq&)!a0|#> zPw0tKO+bR%m{=Ej8+Sw zBhzpP?M4-ZNsS1xQa1_|sJ=-(rXdLVs|mG(T%k~*-qyC$sNH2QH3fzd8VtdbA>5Oq zfVNZJVp2N>M>6QOgINbWa^1)txsGNbAFvg=tLuBbIf=7K6JNV~qiDFciO=ZS$3gKK z0Ptp?KU3mNh;KD-mR}5|hzI9aeh!-c`M>3uinrSls!taK+hC?@3k?r}dJXRFh6iNj_mne@A` zQiMh4sk`kHU9(v}tFO^XtIY>VH$IB-lzMb}ZX`br#Xz57%kTE$PLEH>GAx$Zl!r|c z>h#*F$p`IDnovZU2zB^$CXSrC<}iF8@$o2vxygw4+v)A7f5NA63}T3Nl5WJulhG(i z^Yi9*KY-XO~2j;^^(yy=8;cvXP3*6Am7h#phY1b&()4u$+EzAfmK z-1c!hZXfpPh?;V0nJIYtlS5$HgNOJS3;1!nKY=EMO*Jsi(7-xxo(v9?{@SoTK*)JA z@WDb(_V64ymX>vie(FlC+HCQamHmyK3a?jd9J~EWqgnk`h1c>zsBP4@nwy|r=Pkay zSF7$->)U&LWuviiqq@nTctEGFCyMJTZ?-lXt!jOTR6fbgRlZ_ygZrVyJ=4P7iqKIQ zYi!i^_HH)$%8LgZTYR%pZ&ezVtyRAH{6=H?q{e^9@ZG(wN~6yAUaB-|)%sLHt5LmK**nO^ z59;73pH*({Z`7OBy*h7Hb`EMA4c@Hn?N`dXmn+qs=UaTYvQ<6UCC4g_!ty~A|8YSu z5vI-7D{vRPRp8gy-2gfl00@XI*W#ALEu7wMZ#9=(X;p5uggTKX+v85aeaqmk733_d zko?y2D7^nJliy`B@7C{nlDhfJ^yKQQn6wW`k4Qb~vUFMbo4A)$S&|-;o>ipR6zOe6 zdQXu)QKZil`KlrZiu|e~zop3UD)PsQ{HdZ`Q4~i}YKroPqP(LhA1JwwbJnx$sM2ey z^tLL!r%Iow(r2oCRh0u(epQvWti`{)`85T`ysnWf|*Z-+9SLJ`U3Tsf(h3AVRHc8Z@}naBp(_7Ll|NGDe_yQZg#~5cWzw^fbWf80B1xY~@-vd$ zljL_L`BO=G{6ep!edz~tm|c>j?<0E3%^yT!{wsogL6v`}%I~Z4KUC$?#h&fM+^nX) zxxQbL`|{^`5LBa=C``nN0N>B4=dA*ydC{*85?Qz;eNVb7UC!Ux(!-_Ei)lZ}`A~2( zzDLfWU6ur_XYqmiG3lY54Sa#1XXk$krAqo4k@BP{f&m~&aF%`wUFBoi66=&8366q5 zqBrOnl7*ilbX}+IJfS~NAo-W)2@l~$SR|1J?bK?I5i4!LrijM^KH?J;dL$?%&jplH ziZ&Yl35BI*RPz$0v_-~A@l|3eO_7?C6F&r6fyX-0!y;YBHD9- z~Qj#l%x6zLIaJLiFSukH4zoAATE(DHj6c;_X09D@tdc5R&PF zaHfdR0hpxDJS!pbyYT=-IVpw33VjWRN}DJ>U7xcYb!&qW zw6N7yoI|mL$nn5-F}giCoNt2Bi2Bi3DMwRn=S2AxpV^C&|QIMht4UU2i-7yHY;R;mGwJZ-WzD;aC)vi|H@iafF@?YdZQZ@Wz>Rpji(E@aNFQ>zziK7_|GQp2N++ zoP5}^plabK6Zqb=mJ{|KLT}=E_{jy&gfKoBXlhyxY8|$6P}?}rtsGo49tr3^_3>^E znf5*Cbo)&kn&FW+teAtD3OPJ)Aq%Tm%9-_Q89i~}ggqQ8!8L;p;7ZrD!-IvnE_K*BCE8+-7>&L(U(YK(@Utv|MT1g{1u+YPAK_n@(}mrvQo zglSF>-P!gkVI@)cWGBtjJOyG-85u=NnSsJE4IRJYZGC zkGwM9m1<-b`tQ35Rmh9AcN2<5m#q~X@)fdn(ARXcN4}WRz2x3N$Q8Gabriel>Benchmarks>ARITH-BENCHMARKS.;1" 3828 |changes| |to:| (GABRIEL::TIMERS GENERIC-DIV-FLOAT GENERIC-TIMES-FLOAT GENERIC-SUB-FLOAT GENERIC-ADD-FLOAT FLOAT-SINE FLOAT-DIV FLOAT-TIMES FLOAT-SUB NULL-LOOP FLOAT-ADD) (VARS ARITH-BENCHMARKSCOMS) (VARIABLES PI/6 *ARITH-BENCHMARKS*)) (PRETTYCOMPRINT ARITH-BENCHMARKSCOMS) (RPAQQ ARITH-BENCHMARKSCOMS ( (* |;;| "Pure arithmetic benchmarks.") (COMS (* |;;|  "The null loop of 10K times thru, to factor out loop overhead.") (GABRIEL::TIMERS NULL-LOOP)) (COMS (* |;;| "Pure floating point benchmarks") (GABRIEL::TIMERS FLOAT-ADD FLOAT-DIV FLOAT-SUB FLOAT-TIMES) (* |;;| "Transcendental function benchmarks ") (GABRIEL::TIMERS FLOAT-SINE)) (GABRIEL::TIMERS GENERIC-ADD-FLOAT GENERIC-DIV-FLOAT GENERIC-SUB-FLOAT GENERIC-TIMES-FLOAT) (VARIABLES PI/6 *ARITH-BENCHMARKS*))) (* |;;| "Pure arithmetic benchmarks.") (* |;;| "The null loop of 10K times thru, to factor out loop overhead.") (GABRIEL::DEFINE-TIMER (NULL-LOOP) "Null loop, 1000 times thru" (LET (X) (FOR I FROM 1 |to| 10000 |do| (SETQ X 1)))) (* |;;| "Pure floating point benchmarks") (GABRIEL::DEFINE-TIMER (FLOAT-ADD) "1000 Floating-point additions" (LET ((X 0.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (FPLUS X 1.0))))) (GABRIEL::DEFINE-TIMER (FLOAT-DIV) "1000 Floating-point divisions" (LET ((X 5400.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (FQUOTIENT X 1.0013562))))) (GABRIEL::DEFINE-TIMER (FLOAT-SUB) "1000 Floating-point subtractions" (LET ((X 0.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (FMINUS X 1.0))))) (GABRIEL::DEFINE-TIMER (FLOAT-TIMES) "1000 Floating-point multiplications" (LET ((X 1.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (FTIMES X 1.0013562))))) (* |;;| "Transcendental function benchmarks ") (GABRIEL::DEFINE-TIMER (FLOAT-SINE) "10000 calls to CL:SIN(pi/6)" (LET (X) (FOR I FROM 1 TO 10000 DO (SETQ X (CL:SIN PI/6))))) (GABRIEL::DEFINE-TIMER (GENERIC-ADD-FLOAT) "10000 Generic + with float args" (LET ((X 0.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (+ X 1.0))))) (GABRIEL::DEFINE-TIMER (GENERIC-DIV-FLOAT) "10000 Generic / with float args" (LET ((X 5400.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (/ X 1.0013562))))) (GABRIEL::DEFINE-TIMER (GENERIC-SUB-FLOAT) "10000 Generic - with float args" (LET ((X 0.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (- X 1.0))))) (GABRIEL::DEFINE-TIMER (GENERIC-TIMES-FLOAT) "10000 Generic * with float args" (LET ((X 1.0)) (FOR I FROM 1 TO 10000 DO (SETQ X (CL:* X 1.0013562))))) (CL:DEFVAR PI/6 (FQUOTIENT 3.1415927 6)) (CL:DEFVAR *ARITH-BENCHMARKS* '(NULL-LOOP FLOAT-ADD FLOAT-SUB FLOAT-TIMES FLOAT-DIV GENERIC-ADD-FLOAT GENERIC-SUB-FLOAT GENERIC-TIMES-FLOAT GENERIC-DIV-FLOAT FLOAT-SINE)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0c9c6c1dd15bbb414d4b5236fcbed7345f35190b GIT binary patch literal 4416 zcmb`K&utBv%xO5H(lGQ z5Q>BaNFh5iw=e*@}|OWQkrGwbZyV22RM!I^!#GxO#%@B8M> zCew8#8b?vBv{oppI?`&@wOSReYC5WDH9e=IRj{L5F=b)nLS8GWkz!WYZ$=8mLS-!? zB`znGNL*G@(PUbR%!xB;S&Bzyq(pRnQA{r=5iu=i<^{*#KR?#1G!2~7)ofK=L799_ zudHNmj-qf7U8TucC^(A7r^8{V^OV2$`M2iR+>pk=-*x-POj_T>4Ii=OioL*GxwfZ-$N|mM=T@G z#3j?+!tFQfd(Aoz?^z%GaOcmP#<5gQS5a0kRP!aZTF9Ym zYB`rLW%U~szxC}N(ifVzAHQoFA7%0?DudIgsA+3RTSa5R1yn7R)C#KR_1Y-7idM6* zw=_T-U#+WpUd^t+h@APQ;mXL1Qd%)LO=Djp4#A!7#Bw|?#FNPsxQPK}W5z-1;c8LK zRtx3pXiY1Wt4&^#kI9C0&&HEtMi65$=OHFvb{>@F8F+A8pAiq7MGa;2Y`KzC%PVTR znuW-ym2=gCR&JUGf$Mah9%}#vf@5pyzBwr&rR6A@T%fOEBHIW~ylez#Y~!J=?$oJ< znQl|}W!Og&M+ywMCnX0a;QvA2i<|3X&3cz<91KkfAV*Ooid>s365C^b;eRvp; zU@soTLu6yYMetX_hsf52a2Su1xMq(mJ)#0$I=(r7m$v4Q<~R?-vk(gVeIjhS6%Rf< zU>YYH0Wm$@5FmYr?AT!0t;lD%UOdR-L56uqrp|=M&k_~oALW0!@%U2tl;__~*>mI3 zr5jHl|NIYwCEnHyQ4dkv87HyO7R@eC93xdBHF_94LwZ@7GL54o2T-Amf|!EACN;eR zAQn3Uv(?ZFY>3B04zLM;aFVXF1=>6{J+sjL#o(o8bX@+{cJoede&IaK`7--GW3N7R;E`KvT4=2YuZ>M>d6ka?GyBjV|g%am&$~HbX zUZ-4qgv&9)C5Up_ViAfM4MpSAFyDu3g}}t=9psu*?RjjS>UL4kibdeD;9wcsE@qzE zF$2dkbNi*Z*?l(N=nyx88`G&MBY`kFVKJIh%c>4l;u-WgRE&sLWl%j{-$_n>1t+^s zYUSkTvESho+Ibct3%KX7f=qPZ;Jg7xYP(C-WZ1hMu=y=)_b4`h8*G8MkIk+mTd@Ur z9B{COw+pY|TEeUDAZw(h-G>)p^`HZ*fW@j#Sq0j#5_ZAr^!8FDwWMMd*sZjJJPtav z#5B4fQ)B*9?aa*9Wq3%_Nr-v6Ks%T~PBz@wfJ?|X1nf`GpZ^cPji?m> literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~1~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..1cf1692b926133b7893d5a3a742789ba258a6c9b GIT binary patch literal 4138 zcmb`KT~FIq7{~nrgqOlXp=#Fxb;V294Ce(X1G;rGi30}Xgg9xZUM)=w@yOc}hiR%R zRTG+2$x=(BO+Hh1w@tg6cG>l&`w-ne!?bFewC%oojved-k`mTQD7KG}&w0-8{Gb1M z*e6^c1VtuT$Q9MBQep}ftys~RtwM<@7b>Nc!fZi1bBB)!^4)huwOkAqO3L+>OOMw}0@5`@^FR3>R1VL<@e|-coI7s5> z9)fTa6lr{+4}=Ag55{;d&WFTEkRpr+y4xeiIVr@&LaZP~6LF8By910?D6&~)SIJ@& zISNKG9_roUgcOVm5y_~M_oy>4pgY8e1&L?zxbS&6(g!1UM54Szb;Ac;kwhGZ?1bB% zkPzd|kEubU+JRdjj!>Li7I{ObVH2Rq73G5K+zK@G2vVGniGmy@4ZZ7*RLN%V60kyI zu(qOS_<9zv%+LpC4#iuBcLbtwm}Dn}*;lu2vKJbL5ARkmvLRDFMzzzZ((s=2zz=op znxS8aR!Rz!EU8*1r)X-5xovN`*XrAWzlB>gjLsPPd-06I5%0kCYHa zR*XcV5GFcj&p2jAxRos=H8sD@6bouztBVqM9>t%B#RwN?xlqV?2njcw2RX3}4}DfQ z9D%c_@pvhjFQ=4zTFGlk&_pGl($qq}ZW;zcH|OcM29QA(2U8EO@De0Y5KqpUuVEs) z5rR0{2*KEmLkFLmLDibgZR)uJ`-l}J!+;%8!8Z@r)1Jed>miM5x1pb&S!5yK*oB3I zTw5^o`Tv&MpAp2sKQNgql}YBel``DYT4Bkk_MuVaMSkQ%Eb^cUG=(P77#hbL3n4gPPJhL8f%E6PHK+CwBm0;94i~+Jd8jD2xk((0~Seq8|ID2)InX*6jAxatQ0mzpb}A7o)>$_oOe90cT95Pnw} zbe@ojlgi=47BnVZC}q-^#5Al7I3$O1<+fIW1EdWgmzog=ivrdJPK`Efkyc2t%T>c65vQA?j2FX2`ut% z3pKDVWR7j(U@?x17LFAquaux9dz<+L$}`3+fuK~|KF%nQL1GsqjYzyS@;XT7+Vcw> z_ zotlB1Kr$H1!xmV47M7}s#n%K2dqON%UY$v}7?Z8)v=NM-Mt%p(d}}bjHh_721k4GX z6@x)7!1ygNk4-TCCSW{G!Cb(nBlsRJ2C@CE?ytIWlU1*xSwkNHTY}0Iid+WQ;tmDs z6v)17Ig*e<(N4JShFUQwa>54LgJ!AWz4yENA3=>y!7G;><%0qzqFK||j+u1M&_|p} zn-u=GD^sUT6ZxjoynG82&r!ohwI3JfP@+#ksm?;t?uX(X|GPk$-M)ho{VR;}hnFw^ E1x5s&i2wiq literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~2~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..34ce95aa0a55046345c762bbba863fcf363ec344 GIT binary patch literal 2538 zcmbVO-EZ4e6t|szcdfFm-AC85yN%D%v`ve;HXE6o#A)5SP8KI)5v0Litx{PxG#gn}r(AW=s%4{!RkiaPS_L`UNGMA;FIOve)UfiZ5j6^0)X*#C zyk%?AHFd?-H6t3+%zUw=+Uu1lpAoYQp_m}Y7nb?Vk}`fN+@mz{4Fm z>8Z%{#qpkJpW{!t5sP7%wdYSS{2o2ZQc*WNL55@TL$^OENTd1b5r7g0^f7Hk~uk^6;m?aW^Zw)fH0U4lA5?MYb3D^xlRY264=HpBJ zJP5i)IV)r&QAxAd?bwj3hH;aDDA`XKhW(}%))Tro3D1)*_@aM`JH_4gy+!l2;9pzf z?e(3-_5Hoaf6{E!Ar!V#+*{ujJ=CJRKqbHIi0k{ikAH6gZ4mm<-+b0q&<5*WkF}55 z@`#@vg7|4GVu+~0dPkwv^cnv+1mk`y#)Ap?Kd%087-BzNKQ?7H$OHm#Y}(S|#0++i zg{KZ2v`TlCf@*Z97BeF3 zfGnVhGO#f}1Gvv~Cj=6KihlA@d$7~%?|4qrt*`v8N3hkATo&b=LZvSJ?S9UYi&4pK zGN?9$;N*K`aHb&ur^00LI2Fh_NeW4+RJtAh^)}sowjTro2fJ20wX6(-1@_VAm0M#U z&=rOi!_d_O?4Auz!UxT3re^DTG>Sgdog!K_EY(4(y;h;HkLwDhP4LxI)n8BzwNkxW zw|Zq$`0_hX_0kKf6RlKVty>+aTMfRT`eqAN=2z^V@#BI-)_>KG6HhOwsNhZi7cHhnx zHDuOIAZrzjEH&8}qj_G1Kwov-L*I^+QYRh^2CJ0vgF( zw=11V#U)-`X8TBxJF$7CqwhXM&%suwk{043FOlHk%*L=g+%VfBsZCChtL-EMCSx4b cq>lzn>kHuz(K10ohN%-ofsj9Y_t~?50sK1=lK=n! literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~3~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..06d099abe4968b173c676d4053b54699859f9f05 GIT binary patch literal 4242 zcmb`KTTdHD6vy|10YjkXl8X{>wl$E(WqkpHz)6V~dkqW5HeNf4@>F9l*v0m`zED*W zQdFgtBCV7VtJO}GzO_}Ksy?Q9Nk2r|&rqdmAKJdBXLjwi4L0DW53u9enK@^EbN*+} z9uU2EyaC25XY=WdRAA(CDPJxz+j4;^%H={rVz!~5x#ttt_ivPog{6#~h-a2ENogsQ zF6I+*L0a00Zxzx~W@%ZK zQZgqMlkrccnVCgqt(=n>_u|6BG~-_IxZIvOm!r?mi2>b-+N2FRr_XRRp+rgE0=M0Z zi*8tA)-yZrx#o8Cz5ZJLk{Xu@g4n74^}};$h{RoH__GicseYjh`h@`RjqqHQ_XR>; ziclXZ7P}bbf<7+dV})Qi7PYI2#m$uDJe!gBqzq=0rCNRMQG9`*`rqa(KvD-7jhyN+0g`=LX*gfZ1`ZoMetWdBlzfM&@7t6 zF-@M`e1>(qIexJE8E&jzOi&hrCLs{c*f}_IJsRw2OjRyd!@=XJN>6*o7?DAewYVp! zGssFKD?vO3!&Gzu)N?-dEcMgw^R?U+%ijlrW%t?I?#t&t{zV|3HuM4wO=-4TF2PTn zPhQkIu<~$+g+R;jsOpTeVj3X#a3mD&LxSlX_&*Bn3BeWC7xKn7_+XU7=>v@oBdZzl zCK&KmbwDk(pfM6z$&0FT5o=x(2c$=r%hjNuW1%6gEhHoUn<3d~WUE111W1?h{+c+g z;-24hSbq>`vk?|G^5Euuf*>EjkPg5F@n}6kQC1{qywKV(vYFAQ39XaJh9Qh=JNH+W z&FadICzENcz2cj30M#{fn4r;w&Vi1)UF|{qZh*LZ1jO`5WS3 zuuPg!Lc=nNvFOS;6d%R%R;d8@%c;n`-8!E%+yTvOrf4)}u$gHeB(IDh$=1OTIt?5o zSTmc(7)qnb5GX z7|UfH%Zikf3Q)?u$9xQB9ix>_P~z>JoKjCfW0W$@XdEt43t%*>Dua-@pwxxBnZf0Kodz`sdgxvb z#e%-D37Wl7cX|Vyut5%>S?b(_o81FXpzNpMRgW0vy#g0Nvs&sq(d?Y6jMdGy_?j>> zI5ntcm~Twl<6AI2N1anE1GwUcx_=7le-^$3T<}GJzdi)1L}`U+dF+T>+ITKhY-lYnSHx6^X4<}`{vCC zv-fH&fnr*DtyofZq}6L{^%`2ybX3*qdR|2)t9#Y|j~lj+5*&on$CRMXaklDe*z2)Hr_LzoYYy)%o+SXNFY%?5j$ zI}QVS;?j(qlms#^be~CiV8mUiw3OuB(7}~j%)*c^X!gYAj6^$g@0pEV!~%ZAv*L6@ zG7TQK3`~2{Vr*WV1w)UV%t{%u53FgpZYJxc(k%wo${cYP^@KK$SnD&5zVHiPSIHa9 z6K7c$IO}d%J=+I{{ulQ$mReA_eP&~~+2G+l>w_Qe{CU$jmagk6%IU>gp{&-5d9%Yrc%H>W1j%vAVWz2h!P0zgdAUebS$$I~pvZPA!#o~#sGQx3%AYosYcEk5 z{fxaM{rKw+sC?Xo%CH+>qf~~wQdusp7prfB3Z$fVDqbFY9V+8M#oH}bdWruQnP&{n zJ7n1RK`O2pP{yLdykY2k(gl*&jq?q|8q4yA2!I@vi1wHzJoq(*o= z;*dJGRs8&6$4}Xz#8_xZ{19!uzN$X$f@Z{x%M{HBK{M1zRpolAR$MC;^KiUwPg`g! zI^lFx3Jx#*!&%^1>Qb3yOM0j7T|Hf z!4}#oynbs7uZDxHnU;1QUWC7c}=m%^ORI@&daLN4TSRF1mWZgzER literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~5~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~5~ new file mode 100644 index 0000000000000000000000000000000000000000..0c9c6c1dd15bbb414d4b5236fcbed7345f35190b GIT binary patch literal 4416 zcmb`K&utBv%xO5H(lGQ z5Q>BaNFh5iw=e*@}|OWQkrGwbZyV22RM!I^!#GxO#%@B8M> zCew8#8b?vBv{oppI?`&@wOSReYC5WDH9e=IRj{L5F=b)nLS8GWkz!WYZ$=8mLS-!? zB`znGNL*G@(PUbR%!xB;S&Bzyq(pRnQA{r=5iu=i<^{*#KR?#1G!2~7)ofK=L799_ zudHNmj-qf7U8TucC^(A7r^8{V^OV2$`M2iR+>pk=-*x-POj_T>4Ii=OioL*GxwfZ-$N|mM=T@G z#3j?+!tFQfd(Aoz?^z%GaOcmP#<5gQS5a0kRP!aZTF9Ym zYB`rLW%U~szxC}N(ifVzAHQoFA7%0?DudIgsA+3RTSa5R1yn7R)C#KR_1Y-7idM6* zw=_T-U#+WpUd^t+h@APQ;mXL1Qd%)LO=Djp4#A!7#Bw|?#FNPsxQPK}W5z-1;c8LK zRtx3pXiY1Wt4&^#kI9C0&&HEtMi65$=OHFvb{>@F8F+A8pAiq7MGa;2Y`KzC%PVTR znuW-ym2=gCR&JUGf$Mah9%}#vf@5pyzBwr&rR6A@T%fOEBHIW~ylez#Y~!J=?$oJ< znQl|}W!Og&M+ywMCnX0a;QvA2i<|3X&3cz<91KkfAV*Ooid>s365C^b;eRvp; zU@soTLu6yYMetX_hsf52a2Su1xMq(mJ)#0$I=(r7m$v4Q<~R?-vk(gVeIjhS6%Rf< zU>YYH0Wm$@5FmYr?AT!0t;lD%UOdR-L56uqrp|=M&k_~oALW0!@%U2tl;__~*>mI3 zr5jHl|NIYwCEnHyQ4dkv87HyO7R@eC93xdBHF_94LwZ@7GL54o2T-Amf|!EACN;eR zAQn3Uv(?ZFY>3B04zLM;aFVXF1=>6{J+sjL#o(o8bX@+{cJoede&IaK`7--GW3N7R;E`KvT4=2YuZ>M>d6ka?GyBjV|g%am&$~HbX zUZ-4qgv&9)C5Up_ViAfM4MpSAFyDu3g}}t=9psu*?RjjS>UL4kibdeD;9wcsE@qzE zF$2dkbNi*Z*?l(N=nyx88`G&MBY`kFVKJIh%c>4l;u-WgRE&sLWl%j{-$_n>1t+^s zYUSkTvESho+Ibct3%KX7f=qPZ;Jg7xYP(C-WZ1hMu=y=)_b4`h8*G8MkIk+mTd@Ur z9B{COw+pY|TEeUDAZw(h-G>)p^`HZ*fW@j#Sq0j#5_ZAr^!8FDwWMMd*sZjJJPtav z#5B4fQ)B*9?aa*9Wq3%_Nr-v6Ks%T~PBz@wfJ?|X1nf`GpZ^cPji?m> literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.LCOM b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..dadbb4b66688639b460c0c8d5de516dad83c65e6 GIT binary patch literal 4889 zcmb`L-)`bY6vo-@RV}sJz3k2EtgEVqF2pu}0!|glfFVvCLu|9!t$O2t6D)|0z-%j( zK1AOnmu+wQ5^0~IYNe`brC#@pZ43+8IN6O93C80y-~8sAIdfo|QcG5)d`niOysWl5 z@Jy4$rXki93Fuc1g@$Kcv2iB0@vE#FlBURdm(EfQd82`S4XFtN`o3_3ytV0U8}mI&O<~O_r47x}-Kv&PDA^KNdCFILWUX z3SS>_S)h3q!#gBAR})xPC>Cj;8=dnmQB8ylXjs_J0x0^GHFduQ#hy(7B2k4x0Xqy# z&l)UHNz~4>0$&tLhg7$}jURr6U?q3+bS5wCTNi z*g`E|6r0Vk$$vesP=VZLw_FzOp>@TJ3)p-_A^^kWU~zPWE76@#Eik9HH@vYtyAPKU$pVc71---0 z6m1MGaOUGNj9qsE?iFzC8F==MH3M%roxcFjg)6h~xl?fGUfAo6H62>!z>l{{JeqrU zH5j!n?P~0rp6y)2#I+r7O&(FV87&}<{I-}A&cRckKE9h<4r5GBXV$lzf#rDS7_R0{ z-?MSMtVlroSY&~T^i3r@9I^Dswz*bDTJ~A98wN)!tgkk;Yq@c~b;-DZNJvgZSCKfH zp2Kxi1hIMAkyT(WdL2VrnJ&Bg6*Q2+RY7Q$DOFY=^Kl0MMg!;bC;$F1d@{Pb{V#*< z@%CeRccy3LEf6 z;0i1hfi1AxQ(qfBJ;T}#hWi6;GW5Z2`PhUoAo;(}NGbvCSo&)=hJ$nb9cxWW?W zr)PtGoywrTj`TpeSfELP(g2;!FTE+|o_Amx=7#93T0cWkx54u(s)?KZkG(F%jUTt= zLlxlLv2u{=w18%WxUX6np44j^2F_vXwqz#llNf!F%c#JnA zH%#=rX+rLyo!dnl_bgU54MmjCmt_j6r1Y-TkVPfPR76%s1E${Tsm-VW zB4xQ>(qeB?mic8m(;}sgjKvBR3tWjS*Z4!gZWv+DNHG=P_PDz``qiJWV*6<{t*8)R u{Rjb6P&uHJ*K6ms+IqR9QD%yMFNxeAwXCfXMAdP04241c97}+Zy7GT%%nOJB literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER b/internal/gabriel/benchmarks/GABRIEL-OTHER new file mode 100644 index 00000000..c4962aaa --- /dev/null +++ b/internal/gabriel/benchmarks/GABRIEL-OTHER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "GABRIEL")) (IL:FILECREATED "28-Jun-88 17:26:33" IL:{ERIS}GABRIEL>BENCHMARKS>GABRIEL-OTHER.\;6 64944 IL:|changes| IL:|to:| (IL:VARIABLES *CONSY-BENCHMARKS*) (IL:VARS IL:GABRIEL-OTHERCOMS) IL:|previous| IL:|date:| "27-Jun-88 10:02:52" IL:{ERIS}GABRIEL>BENCHMARKS>GABRIEL-OTHER.\;5) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:GABRIEL-OTHERCOMS) (IL:RPAQQ IL:GABRIEL-OTHERCOMS ((IL:FILES IL:GABRIEL-TIMERS) (IL:STRUCTURES TNODE) (IL:VARIABLES TYPEMAX SIZE) (IL:VARIABLES *A* *ALPHA* *B* *C* *D* *L *P *P* *R* *R2* *R3* *SERIES* *V* *X* *VAR ANSWER BOARD CLASS CLASSMAX COUNT FALSE FINAL III IM KOUNT MARKER PIECECOUNT PIECEMAX PUZZLE Q* RAND RE ROOT SEQUENCE SN TEMP-TEMP TRUE U* UNIFY-SUBST) (IL:FUNCTIONS *DDERIV +DDERIV -DDERIV /DDERIV ADD ADD-LEMMA ADD-LEMMA-LST APPLY-SUBST APPLY-SUBST-LST BROWSE BROWSE-RANDOM CHAR1 CPLUS CREATE-N CREATE-STRUCTURE CTIMES DDERIV DDERIV-AUX DEFINEPIECE DERIV DERIV-AUX DESTRUCTIVE FALSEP FFT FIND-ROOT FIT GOGOGO INIT INVESTIGATE ITERATIVE-DIV2 ITERATIVE-DIV2-TEST LAST-POSITION MATCH ONE-WAY-UNIFY ONE-WAY-UNIFY1 ONE-WAY-UNIFY1-LST PCOEFADD PCOEFP PCPLUS PCPLUS1 PCTIMES PCTIMES1 PDIFFER1 PEXPTSQ PLACE POINTERGP PPLUS PPLUS1 PSIMP PTIMES PTIMES1 PTIMES2 PTIMES3 PUZZLE-REMOVE PZERO PZEROP RANDOMIZE RECURSIVE-DIV2 RECURSIVE-DIV2-TEST REWRITE REWRITE-ARGS REWRITE-WITH-LEMMAS RUN-DDERIV RUN-DERIV RUN-ONE RUN-SERIES RUN-SERIES-TO-FILE SEED SETUP SETUP-DDERIV SETUP-FRPOLY SNB START TAUTOLOGYP TAUTP TEST TRANS-OF-IMPLIES TRANS-OF-IMPLIES1 TRAVERS TRAVERSE TRAVERSE-RANDOM TRAVERSE-REMOVE TRAVERSE-SELECT TRIAL TRIANG-TEST TRUEP TRY) (IL:COMS (IL:* IL:|;;| "Modified version of browse which doesn't cons so much") (IL:FUNCTIONS CHAR1* BROWSE* INVESTIGATE* MATCH*) (TIMERS BROWSE*)) (IL:COMS (IL:* IL:|;;| "Modified version of traverse-init to break circularities") (IL:FUNCTIONS CREATE-STRUCTURE* TRAVERSE-REMOVE* RELEASE-TREE RELEASE-TREE-AUX) (TIMERS TRAVERSE* TRAVERSE-INIT*)) (IL:VARIABLES DIV2-L) (IL:VARIABLES *CONSY-BENCHMARKS* *AREFY-BENCHMARKS* *POLY-BENCHMARKS*) (TIMERS BOYER BROWSE DDERIV DERIV DESTRU DIV2-1 DIV2-2 FFT FRPOLY10R FRPOLY10R2 FRPOLY10R3 FRPOLY15R FRPOLY15R2 FRPOLY15R3 FRPOLY2R FRPOLY2R2 FRPOLY2R3 FRPOLY5R FRPOLY5R2 FRPOLY5R3 PUZZLE TRAVERSE TRAVERSE-INIT TRIANG) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:GABRIEL-OTHER))) (IL:FILESLOAD IL:GABRIEL-TIMERS) (DEFSTRUCT TNODE (PARENTS NIL) (SONS NIL) (SN (SNB)) (ENTRY1 NIL) (ENTRY2 NIL) (ENTRY3 NIL) (ENTRY4 NIL) (ENTRY5 NIL) (ENTRY6 NIL) (MARK NIL)) (DEFCONSTANT TYPEMAX 12) (DEFCONSTANT SIZE 511) (DEFVAR *A* ' #37(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6)) (DEFVAR *ALPHA*) (DEFVAR *B* '#37(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5)) (DEFVAR *C* ' #37(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4)) (DEFVAR *D* 8) (DEFVAR *L) (DEFVAR *P) (DEFVAR *P* (MAKE-ARRAY (LIST (1+ TYPEMAX) (1+ SIZE)))) (DEFVAR *R*) (DEFVAR *R2*) (DEFVAR *R3*) (DEFPARAMETER *SERIES* '(PUZZLE TRIANG FRPOLY2R FRPOLY2R2 FRPOLY2R3 FRPOLY5R FRPOLY5R2 FRPOLY5R3 FRPOLY10R FRPOLY10R2 FRPOLY10R3 FRPOLY15R FRPOLY15R2 FRPOLY15R3 BOYER BROWSE DESTRU TRAVERSE-INIT TRAVERSE TAK STAK CTAK TAKL TAKR DERIV DDERIV DIV2-1 DIV2-2 FFT)) (DEFVAR *V*) (DEFVAR *X*) (DEFVAR *VAR) (DEFVAR ANSWER) (DEFVAR BOARD '#16(1 1 1 1 1 0 1)) (DEFVAR CLASS (MAKE-ARRAY (1+ TYPEMAX) ':INITIAL-ELEMENT 0)) (DEFCONSTANT CLASSMAX 3) (DEFVAR COUNT 0) (DEFCONSTANT FALSE NIL) (DEFVAR FINAL) (DEFVAR III 0) (DEFVAR IM (MAKE-ARRAY 1025 :ELEMENT-TYPE 'SINGLE-FLOAT ':INITIAL-ELEMENT 0.0)) (DEFVAR KOUNT 0) (DEFVAR MARKER NIL) (DEFVAR PIECECOUNT (MAKE-ARRAY (1+ CLASSMAX) ':INITIAL-ELEMENT 0)) (DEFVAR PIECEMAX (MAKE-ARRAY (1+ TYPEMAX) ':INITIAL-ELEMENT 0)) (DEFVAR PUZZLE (MAKE-ARRAY (1+ SIZE))) (DEFVAR Q*) (DEFVAR RAND 21) (DEFVAR RE (MAKE-ARRAY 1025 :ELEMENT-TYPE 'SINGLE-FLOAT ':INITIAL-ELEMENT 0.0)) (DEFVAR ROOT) (DEFVAR SEQUENCE (MAKE-ARRAY 14 ':INITIAL-ELEMENT 0)) (DEFVAR SN 0) (DEFVAR TEMP-TEMP) (DEFCONSTANT TRUE T) (DEFVAR U*) (DEFVAR UNIFY-SUBST) (DEFUN *DDERIV (A) (LIST '* (CONS '* A) (CONS '+ (MAPCAR #'DDERIV-AUX A)))) (DEFUN +DDERIV (A) (CONS '+ (MAPCAR #'DDERIV A))) (DEFUN -DDERIV (A) (CONS '- (MAPCAR #'DDERIV A))) (DEFUN /DDERIV (A) (LIST '- (LIST '/ (DDERIV (CAR A)) (CADR A)) (LIST '/ (CAR A) (LIST '* (CADR A) (CADR A) (DDERIV (CADR A)))))) (DEFUN ADD (A Q) (COND ((NULL Q) `(,(LET ((X `(,A))) (RPLACD X X) X))) ((NULL (CAR Q)) (LET ((X `(,A))) (RPLACD X X) (RPLACA Q X))) (T (RPLACA Q (RPLACD (CAR Q) `(,A . ,(CDR (CAR Q)))))))) (DEFUN ADD-LEMMA (TERM) (COND ((AND (NOT (ATOM TERM)) (EQ (CAR TERM) 'EQUAL) (NOT (ATOM (CADR TERM)))) (PUSHNEW TERM (GET (CAR (CADR TERM)) 'LEMMAS) :TEST #'EQUAL)) (T (ERROR "Add lemma did not like term")))) (DEFUN ADD-LEMMA-LST (LST) (COND ((NULL LST) T) (T (ADD-LEMMA (CAR LST)) (ADD-LEMMA-LST (CDR LST))))) (DEFUN APPLY-SUBST (ALIST TERM) (COND ((ATOM TERM) (COND ((SETQ TEMP-TEMP (ASSOC TERM ALIST)) (CDR TEMP-TEMP)) (T TERM))) (T (CONS (CAR TERM) (APPLY-SUBST-LST ALIST (CDR TERM)))))) (DEFUN APPLY-SUBST-LST (ALIST LST) (COND ((NULL LST) NIL) (T (CONS (APPLY-SUBST ALIST (CAR LST)) (APPLY-SUBST-LST ALIST (CDR LST)))))) (DEFUN BROWSE () (SETF RAND 21) (INVESTIGATE (RANDOMIZE (INIT 100 10 4 '((A A A B B B B A A A A A B B A A A) (A A B B B B A A (A A) (B B)) (A A A B (B A) B A B A)))) '((*A ?B *B ?B A *A A *B *A) (*A *B *B *A (*A) (*B)) (? ? * (B A) * ? ?)))) (DEFUN BROWSE-RANDOM () (SETQ RAND (MOD (* RAND 17) 251))) (DEFMACRO CHAR1 (X) `(AREF (SYMBOL-NAME ,X) 0)) (DEFMACRO CPLUS (X Y) `(+ ,X ,Y)) (DEFUN CREATE-N (N) (DO ((N N (1- N)) (A NIL (PUSH NIL A))) ((= N 0) A))) (DEFUN CREATE-STRUCTURE (N) (LET ((A `(,(MAKE-TNODE)))) (DO ((M (1- N) (1- M)) (P A)) ((= M 0) (SETQ A `(,(RPLACD P A))) (DO ((UNUSED A) (USED (ADD (TRAVERSE-REMOVE 0 A) NIL)) (X) (Y)) ((NULL (CAR UNUSED)) (FIND-ROOT (TRAVERSE-SELECT 0 USED) N)) (SETQ X (TRAVERSE-REMOVE (REM (TRAVERSE-RANDOM) N) UNUSED)) (SETQ Y (TRAVERSE-SELECT (REM (TRAVERSE-RANDOM) N) USED)) (ADD X USED) (SETF (TNODE-SONS Y) `(,X . ,(TNODE-SONS Y))) (SETF (TNODE-PARENTS X) `(,Y . ,(TNODE-PARENTS X))))) (PUSH (MAKE-TNODE) A)))) (DEFMACRO CTIMES (X Y) `(* ,X ,Y)) (DEFUN DDERIV (A) (COND ((ATOM A) (COND ((EQ A 'X) 1) (T 0))) (T (LET ((DDERIV (GET (CAR A) 'DDERIV))) (COND (DDERIV (FUNCALL DDERIV (CDR A))) (T 'ERROR)))))) (DEFUN DDERIV-AUX (A) (LIST '/ (DDERIV A) A)) (DEFUN DEFINEPIECE (ICLASS II JJ KK) (LET ((INDEX 0)) (DO ((I 0 (1+ I))) ((> I II)) (DO ((J 0 (1+ J))) ((> J JJ)) (DO ((K 0 (1+ K))) ((> K KK)) (SETQ INDEX (+ I (* *D* (+ J (* *D* K))))) (SETF (AREF *P* III INDEX) TRUE)))) (SETF (AREF CLASS III) ICLASS) (SETF (AREF PIECEMAX III) INDEX) (COND ((NOT (= III TYPEMAX)) (SETQ III (+ III 1)))))) (DEFUN DERIV (A) (COND ((ATOM A) (COND ((EQ A 'X) 1) (T 0))) ((EQ (CAR A) '+) (CONS '+ (MAPCAR #'DERIV (CDR A)))) ((EQ (CAR A) '-) (CONS '- (MAPCAR #'DERIV (CDR A)))) ((EQ (CAR A) '*) (LIST '* A (CONS '+ (MAPCAR 'DERIV-AUX (CDR A))))) ((EQ (CAR A) '/) (LIST '- (LIST '/ (DERIV (CADR A)) (CADDR A)) (LIST '/ (CADR A) (LIST '* (CADDR A) (CADDR A) (DERIV (CADDR A)))))) (T 'ERROR))) (DEFUN DERIV-AUX (A) (LIST '/ (DERIV A) A)) (DEFUN DESTRUCTIVE (N M) (LET ((L (DO ((I 10 (1- I)) (A NIL (PUSH NIL A))) ((= I 0) A)))) (DO ((I N (1- I))) ((= I 0)) (COND ((NULL (CAR L)) (DO ((L L (CDR L))) ((NULL L)) (OR (CAR L) (RPLACA L (CONS NIL NIL))) (NCONC (CAR L) (DO ((J M (1- J)) (A NIL (PUSH NIL A))) ((= J 0) A))))) (T (DO ((L1 L (CDR L1)) (L2 (CDR L) (CDR L2))) ((NULL L2)) (RPLACD (DO ((J (FLOOR (LENGTH (CAR L2)) 2) (1- J)) (A (CAR L2) (CDR A))) ((= J 0) A) (RPLACA A I)) (LET ((N (FLOOR (LENGTH (CAR L1)) 2))) (COND ((= N 0) (RPLACA L1 NIL) (CAR L1)) (T (DO ((J N (1- J)) (A (CAR L1) (CDR A))) ((= J 1) (PROG1 (CDR A) (RPLACD A NIL))) (RPLACA A I)))))))))))) (DEFUN FALSEP (X LST) (OR (EQUAL X '(F)) (MEMBER X LST :TEST #'EQUAL))) (DEFUN FFT (AREAL AIMAG) (PROG (AR AI I J K M N LE LE1 IP NV2 NM1 UR UI WR WI TR TI) (SETQ AR AREAL AI AIMAG N (ARRAY-DIMENSION AR 0) N (1- N) NV2 (FLOOR N 2) NM1 (1- N) M 0 I 1) L1 (COND ((< I N) (SETQ M (1+ M) I (+ I I)) (GO L1))) (COND ((NOT (EQUAL N (EXPT 2 M))) (PRINC "Error ... array size not a power of two.") (READ) (RETURN (TERPRI)))) (SETQ J 1 I 1) L3 (COND ((< I J) (SETQ TR (AREF AR J) TI (AREF AI J)) (SETF (AREF AR J) (AREF AR I)) (SETF (AREF AI J) (AREF AI I)) (SETF (AREF AR I) TR) (SETF (AREF AI I) TI))) (SETQ K NV2) L6 (COND ((< K J) (SETQ J (- J K) K (FLOOR K 2)) (GO L6))) (SETQ J (+ J K) I (1+ I)) (COND ((< I N) (GO L3))) (DO ((L 1 (1+ L))) ((> L M)) (SETQ LE (EXPT 2 L) LE1 (FLOOR LE 2) UR 1.0 UI 0 WR (COS (/ PI (FLOAT LE1))) WI (SIN (/ PI (FLOAT LE1)))) (DO ((J 1 (1+ J))) ((> J LE1)) (DO ((I J (+ I LE))) ((> I N)) (SETQ IP (+ I LE1) TR (- (* (AREF AR IP) UR) (* (AREF AI IP) UI)) TI (+ (* (AREF AR IP) UI) (* (AREF AI IP) UR))) (SETF (AREF AR IP) (- (AREF AR I) TR)) (SETF (AREF AI IP) (- (AREF AI I) TI)) (SETF (AREF AR I) (+ (AREF AR I) TR)) (SETF (AREF AI I) (+ (AREF AI I) TI)))) (SETQ TR (- (* UR WR) (* UI WI)) TI (+ (* UR WI) (* UI WR)) UR TR UI TI)) (RETURN T))) (DEFUN FIND-ROOT (TNODE N) (DO ((N N (1- N))) ((= N 0) TNODE) (COND ((NULL (TNODE-PARENTS TNODE)) (RETURN TNODE)) (T (SETQ TNODE (CAR (TNODE-PARENTS TNODE))))))) (DEFUN FIT (I J) (LET ((END (AREF PIECEMAX I))) (DO ((K 0 (1+ K))) ((> K END) TRUE) (COND ((AREF *P* I K) (COND ((AREF PUZZLE (+ J K)) (RETURN FALSE)))))))) (DEFUN GOGOGO (I) (DOTIMES (J 16) (SETF (AREF BOARD J) 1)) (SETF (AREF BOARD 5) 0) (LET ((ANSWER NIL) (FINAL NIL)) (TRY I 1))) (DEFUN INIT (N M NPATS IPATS) (LET ((IPATS (COPY-TREE IPATS))) (DO ((P IPATS (CDR P))) ((NULL (CDR P)) (RPLACD P IPATS))) (DO ((N N (1- N)) (I M (COND ((= I 0) M) (T (1- I)))) (NAME (GENSYM) (GENSYM)) (A NIL)) ((= N 0) A) (PUSH NAME A) (DO ((I I (1- I))) ((= I 0)) (SETF (GET NAME (GENSYM)) NIL)) (SETF (GET NAME 'PATTERN) (DO ((I NPATS (1- I)) (IPATS IPATS (CDR IPATS)) (A NIL)) ((= I 0) A) (PUSH (CAR IPATS) A))) (DO ((J (- M I) (1- J))) ((= J 0)) (SETF (GET NAME (GENSYM)) NIL))))) (DEFUN INVESTIGATE (UNITS PATS) (DO ((UNITS UNITS (CDR UNITS))) ((NULL UNITS)) (DO ((PATS PATS (CDR PATS))) ((NULL PATS)) (DO ((P (GET (CAR UNITS) 'PATTERN) (CDR P))) ((NULL P)) (MATCH (CAR PATS) (CAR P) NIL))))) (DEFUN ITERATIVE-DIV2 (L) (DO ((L L (CDDR L)) (A NIL (PUSH (CAR L) A))) ((NULL L) A))) (DEFUN ITERATIVE-DIV2-TEST (L) (DO ((I 300 (1- I))) ((= I 0)) (ITERATIVE-DIV2 L) (ITERATIVE-DIV2 L) (ITERATIVE-DIV2 L) (ITERATIVE-DIV2 L))) (DEFUN LAST-POSITION () (DO ((I 1 (1+ I))) ((= I 16) 0) (IF (= 1 (AREF BOARD I)) (RETURN I)))) (DEFUN MATCH (PAT DAT ALIST) (COND ((NULL PAT) (NULL DAT)) ((NULL DAT) NIL) ((OR (EQ (CAR PAT) '?) (EQ (CAR PAT) (CAR DAT))) (MATCH (CDR PAT) (CDR DAT) ALIST)) ((EQ (CAR PAT) '*) (OR (MATCH (CDR PAT) DAT ALIST) (MATCH (CDR PAT) (CDR DAT) ALIST) (MATCH PAT (CDR DAT) ALIST))) (T (COND ((ATOM (CAR PAT)) (COND ((EQL (CHAR1 (CAR PAT)) #\?) (LET ((VAL (ASSOC (CAR PAT) ALIST))) (COND (VAL (MATCH (CONS (CDR VAL) (CDR PAT)) DAT ALIST)) (T (MATCH (CDR PAT) (CDR DAT) (CONS (CONS (CAR PAT) (CAR DAT)) ALIST)))))) ((EQL (CHAR1 (CAR PAT)) #\*) (LET ((VAL (ASSOC (CAR PAT) ALIST))) (COND (VAL (MATCH (APPEND (CDR VAL) (CDR PAT)) DAT ALIST)) (T (DO ((L NIL (NCONC L (CONS (CAR D) NIL))) (E (CONS NIL DAT) (CDR E)) (D DAT (CDR D))) ((NULL E) NIL) (COND ((MATCH (CDR PAT) D (CONS (CONS (CAR PAT) L) ALIST)) (RETURN T)))))))))) (T (AND (NOT (ATOM (CAR DAT))) (MATCH (CAR PAT) (CAR DAT) ALIST) (MATCH (CDR PAT) (CDR DAT) ALIST))))))) (DEFUN ONE-WAY-UNIFY (TERM1 TERM2) (PROGN (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2))) (DEFUN ONE-WAY-UNIFY1 (TERM1 TERM2) (COND ((ATOM TERM2) (COND ((SETQ TEMP-TEMP (ASSOC TERM2 UNIFY-SUBST)) (EQUAL TERM1 (CDR TEMP-TEMP))) (T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1) UNIFY-SUBST)) T))) ((ATOM TERM1) NIL) ((EQ (CAR TERM1) (CAR TERM2)) (ONE-WAY-UNIFY1-LST (CDR TERM1) (CDR TERM2))) (T NIL))) (DEFUN ONE-WAY-UNIFY1-LST (LST1 LST2) (COND ((NULL LST1) T) ((ONE-WAY-UNIFY1 (CAR LST1) (CAR LST2)) (ONE-WAY-UNIFY1-LST (CDR LST1) (CDR LST2))) (T NIL))) (DEFUN PCOEFADD (E C X) (IF (PZEROP C) X (CONS E (CONS C X)))) (DEFMACRO PCOEFP (E) `(ATOM ,E)) (DEFUN PCPLUS (C P) (IF (PCOEFP P) (CPLUS P C) (PSIMP (CAR P) (PCPLUS1 C (CDR P))))) (DEFUN PCPLUS1 (C X) (COND ((NULL X) (COND ((PZEROP C) NIL) (T (CONS 0 (CONS C NIL))))) ((PZEROP (CAR X)) (PCOEFADD 0 (PPLUS C (CADR X)) NIL)) (T (CONS (CAR X) (CONS (CADR X) (PCPLUS1 C (CDDR X))))))) (DEFUN PCTIMES (C P) (COND ((PCOEFP P) (CTIMES C P)) (T (PSIMP (CAR P) (PCTIMES1 C (CDR P)))))) (DEFUN PCTIMES1 (C X) (COND ((NULL X) NIL) (T (PCOEFADD (CAR X) (PTIMES C (CADR X)) (PCTIMES1 C (CDDR X)))))) (DEFUN PDIFFER1 (X Y) X Y (ERROR "pdiffer2 called")) (DEFUN PEXPTSQ (P N) (DO ((N (FLOOR N 2) (FLOOR N 2)) (S (COND ((ODDP N) P) (T 1)))) ((ZEROP N) S) (SETQ P (PTIMES P P)) (AND (ODDP N) (SETQ S (PTIMES S P))))) (DEFUN PLACE (I J) (LET ((END (AREF PIECEMAX I))) (DO ((K 0 (1+ K))) ((> K END)) (COND ((AREF *P* I K) (SETF (AREF PUZZLE (+ J K)) TRUE)))) (SETF (AREF PIECECOUNT (AREF CLASS I)) (- (AREF PIECECOUNT (AREF CLASS I)) 1)) (DO ((K J (1+ K))) ((> K SIZE) 0) (COND ((NOT (AREF PUZZLE K)) (RETURN K)))))) (DEFMACRO POINTERGP (X Y) `(> (GET ,X 'ORDER) (GET ,Y 'ORDER))) (DEFUN PPLUS (X Y) (COND ((PCOEFP X) (PCPLUS X Y)) ((PCOEFP Y) (PCPLUS Y X)) ((EQ (CAR X) (CAR Y)) (PSIMP (CAR X) (PPLUS1 (CDR Y) (CDR X)))) ((POINTERGP (CAR X) (CAR Y)) (PSIMP (CAR X) (PCPLUS1 Y (CDR X)))) (T (PSIMP (CAR Y) (PCPLUS1 X (CDR Y)))))) (DEFUN PPLUS1 (X Y) (COND ((NULL X) Y) ((NULL Y) X) ((= (CAR X) (CAR Y)) (PCOEFADD (CAR X) (PPLUS (CADR X) (CADR Y)) (PPLUS1 (CDDR X) (CDDR Y)))) ((> (CAR X) (CAR Y)) (CONS (CAR X) (CONS (CADR X) (PPLUS1 (CDDR X) Y)))) (T (CONS (CAR Y) (CONS (CADR Y) (PPLUS1 X (CDDR Y))))))) (DEFUN PSIMP (VAR X) (COND ((NULL X) 0) ((ATOM X) X) ((ZEROP (CAR X)) (CADR X)) (T (CONS VAR X)))) (DEFUN PTIMES (X Y) (COND ((OR (PZEROP X) (PZEROP Y)) (PZERO)) ((PCOEFP X) (PCTIMES X Y)) ((PCOEFP Y) (PCTIMES Y X)) ((EQ (CAR X) (CAR Y)) (PSIMP (CAR X) (PTIMES1 (CDR X) (CDR Y)))) ((POINTERGP (CAR X) (CAR Y)) (PSIMP (CAR X) (PCTIMES1 Y (CDR X)))) (T (PSIMP (CAR Y) (PCTIMES1 X (CDR Y)))))) (DEFUN PTIMES1 (*X* Y) (PROG (U* *V*) (SETQ *V* (SETQ U* (PTIMES2 Y))) A (SETQ *X* (CDDR *X*)) (COND ((NULL *X*) (RETURN U*))) (PTIMES3 Y) (GO A))) (DEFUN PTIMES2 (Y) (COND ((NULL Y) NIL) (T (PCOEFADD (+ (CAR *X*) (CAR Y)) (PTIMES (CADR *X*) (CADR Y)) (PTIMES2 (CDDR Y)))))) (DEFUN PTIMES3 (Y) (PROG (E U C) A1 (COND ((NULL Y) (RETURN NIL))) (SETQ E (+ (CAR *X*) (CAR Y))) (SETQ C (PTIMES (CADR Y) (CADR *X*))) (COND ((PZEROP C) (SETQ Y (CDDR Y)) (GO A1)) ((OR (NULL *V*) (> E (CAR *V*))) (SETQ U* (SETQ *V* (PPLUS1 U* (LIST E C)))) (SETQ Y (CDDR Y)) (GO A1)) ((= E (CAR *V*)) (SETQ C (PPLUS C (CADR *V*))) (COND ((PZEROP C) (SETQ U* (SETQ *V* (PDIFFER1 U* (LIST (CAR *V*) (CADR *V*)))))) (T (RPLACA (CDR *V*) C))) (SETQ Y (CDDR Y)) (GO A1))) A (COND ((AND (CDDR *V*) (> (CADDR *V*) E)) (SETQ *V* (CDDR *V*)) (GO A))) (SETQ U (CDR *V*)) B (COND ((OR (NULL (CDR U)) (< (CADR U) E)) (RPLACD U (CONS E (CONS C (CDR U)))) (GO E))) (COND ((PZEROP (SETQ C (PPLUS (CADDR U) C))) (RPLACD U (CDDDR U)) (GO D)) (T (RPLACA (CDDR U) C))) E (SETQ U (CDDR U)) D (SETQ Y (CDDR Y)) (COND ((NULL Y) (RETURN NIL))) (SETQ E (+ (CAR *X*) (CAR Y))) (SETQ C (PTIMES (CADR Y) (CADR *X*))) C (COND ((AND (CDR U) (> (CADR U) E)) (SETQ U (CDDR U)) (GO C))) (GO B))) (DEFUN PUZZLE-REMOVE (I J) (LET ((END (AREF PIECEMAX I))) (DO ((K 0 (1+ K))) ((> K END)) (COND ((AREF *P* I K) (SETF (AREF PUZZLE (+ J K)) FALSE)))) (SETF (AREF PIECECOUNT (AREF CLASS I)) (+ (AREF PIECECOUNT (AREF CLASS I)) 1)))) (DEFMACRO PZERO () 0) (DEFMACRO PZEROP (X) `(AND (NUMBERP ,X) (ZEROP ,X))) (DEFUN RANDOMIZE (L) (DO ((A NIL)) ((NULL L) A) (LET ((N (MOD (BROWSE-RANDOM) (LENGTH L)))) (COND ((= N 0) (PUSH (CAR L) A) (SETQ L (CDR L))) (T (DO ((N N (1- N)) (X L (CDR X))) ((= N 1) (PUSH (CADR X) A) (RPLACD X (CDDR X))))))))) (DEFUN RECURSIVE-DIV2 (L) (COND ((NULL L) NIL) (T (CONS (CAR L) (RECURSIVE-DIV2 (CDDR L)))))) (DEFUN RECURSIVE-DIV2-TEST (L) (DO ((I 300 (1- I))) ((= I 0)) (RECURSIVE-DIV2 L) (RECURSIVE-DIV2 L) (RECURSIVE-DIV2 L) (RECURSIVE-DIV2 L))) (DEFUN REWRITE (TERM) (COND ((ATOM TERM) TERM) (T (REWRITE-WITH-LEMMAS (CONS (CAR TERM) (REWRITE-ARGS (CDR TERM))) (GET (CAR TERM) 'LEMMAS))))) (DEFUN REWRITE-ARGS (LST) (COND ((NULL LST) NIL) (T (CONS (REWRITE (CAR LST)) (REWRITE-ARGS (CDR LST)))))) (DEFUN REWRITE-WITH-LEMMAS (TERM LST) (COND ((NULL LST) TERM) ((ONE-WAY-UNIFY TERM (CADR (CAR LST))) (REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST))))) (T (REWRITE-WITH-LEMMAS TERM (CDR LST))))) (DEFUN RUN-DDERIV () (DO ((I 0 (1+ I))) ((= I 1000)) (DECLARE (TYPE FIXNUM I)) (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5)))) (DEFUN RUN-DERIV () (DO ((I 0 (1+ I))) ((= I 1000)) (DECLARE (TYPE FIXNUM I)) (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5)) (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5)))) (DEFUN RUN-ONE (NAME &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (FORMAT STREAM "~&~A: " (GET NAME 'TIMING-DOCUMENTATION)) (MULTIPLE-VALUE-BIND (N-RUNS REAL-TIME CPU-TIME) (MULTIPLE-TIMED-DURATION (GET NAME 'TIMING-FUNCTION)) (FORMAT STREAM "CPU: ~7,3F Page: ~7,3F Real: ~7,3F (based on ~D calls)" CPU-TIME (- REAL-TIME CPU-TIME) REAL-TIME N-RUNS))) (DEFUN RUN-SERIES (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (DESCRIBE-IMPLEMENTATION STREAM) (TERPRI STREAM) (TERPRI STREAM) (DOLIST (NAME *SERIES*) (RUN-ONE NAME STREAM))) (DEFUN RUN-SERIES-TO-FILE (&OPTIONAL (PATHNAME "RPG-CL.TEXT")) (WITH-OPEN-FILE (STREAM PATHNAME :DIRECTION :OUTPUT) (RUN-SERIES STREAM))) (DEFUN SEED () (SETQ RAND 21)) (DEFUN SETUP () (ADD-LEMMA-LST '((EQUAL (COMPILE FORM) (REVERSE (CODEGEN (OPTIMIZE FORM) (NIL)))) (EQUAL (EQP X Y) (EQUAL (FIX X) (FIX Y))) (EQUAL (GREATERP X Y) (LESSP Y X)) (EQUAL (LESSEQP X Y) (NOT (LESSP Y X))) (EQUAL (GREATEREQP X Y) (NOT (LESSP X Y))) (EQUAL (BOOLEAN X) (OR (EQUAL X (T)) (EQUAL X (F)))) (EQUAL (IFF X Y) (AND (IMPLIES X Y) (IMPLIES Y X))) (EQUAL (EVEN1 X) (IF (ZEROP X) (T) (ODD (1- X)))) (EQUAL (COUNTPS- L PRED) (COUNTPS-LOOP L PRED (ZERO))) (EQUAL (FACT- I) (FACT-LOOP I 1)) (EQUAL (REVERSE- X) (REVERSE-LOOP X (NIL))) (EQUAL (DIVIDES X Y) (ZEROP (REMAINDER Y X))) (EQUAL (ASSUME-TRUE VAR ALIST) (CONS (CONS VAR (T)) ALIST)) (EQUAL (ASSUME-FALSE VAR ALIST) (CONS (CONS VAR (F)) ALIST)) (EQUAL (TAUTOLOGY-CHECKER X) (TAUTOLOGYP (NORMALIZE X) (NIL))) (EQUAL (FALSIFY X) (FALSIFY1 (NORMALIZE X) (NIL))) (EQUAL (PRIME X) (AND (NOT (ZEROP X)) (NOT (EQUAL X (ADD1 (ZERO)))) (PRIME1 X (1- X)))) (EQUAL (AND P Q) (IF P (IF Q (T) (F)) (F))) (EQUAL (OR P Q) (IF P (T) (IF Q (T) (F)) (F))) (EQUAL (NOT P) (IF P (F) (T))) (EQUAL (IMPLIES P Q) (IF P (IF Q (T) (F)) (T))) (EQUAL (FIX X) (IF (NUMBERP X) X (ZERO))) (EQUAL (IF (IF A B C) D E) (IF A (IF B D E) (IF C D E))) (EQUAL (ZEROP X) (OR (EQUAL X (ZERO)) (NOT (NUMBERP X)))) (EQUAL (PLUS (PLUS X Y) Z) (PLUS X (PLUS Y Z))) (EQUAL (EQUAL (PLUS A B) (ZERO)) (AND (ZEROP A) (ZEROP B))) (EQUAL (DIFFERENCE X X) (ZERO)) (EQUAL (EQUAL (PLUS A B) (PLUS A C)) (EQUAL (FIX B) (FIX C))) (EQUAL (EQUAL (ZERO) (DIFFERENCE X Y)) (NOT (LESSP Y X))) (EQUAL (EQUAL X (DIFFERENCE X Y)) (AND (NUMBERP X) (OR (EQUAL X (ZERO)) (ZEROP Y)))) (EQUAL (MEANING (PLUS-TREE (APPEND X Y)) A) (PLUS (MEANING (PLUS-TREE X) A) (MEANING (PLUS-TREE Y) A))) (EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X)) A) (FIX (MEANING X A))) (EQUAL (APPEND (APPEND X Y) Z) (APPEND X (APPEND Y Z))) (EQUAL (REVERSE (APPEND A B)) (APPEND (REVERSE B) (REVERSE A))) (EQUAL (TIMES X (PLUS Y Z)) (PLUS (TIMES X Y) (TIMES X Z))) (EQUAL (TIMES (TIMES X Y) Z) (TIMES X (TIMES Y Z))) (EQUAL (EQUAL (TIMES X Y) (ZERO)) (OR (ZEROP X) (ZEROP Y))) (EQUAL (EXEC (APPEND X Y) PDS ENVRN) (EXEC Y (EXEC X PDS ENVRN) ENVRN)) (EQUAL (MC-FLATTEN X Y) (APPEND (FLATTEN X) Y)) (EQUAL (MEMBER X (APPEND A B)) (OR (MEMBER X A) (MEMBER X B))) (EQUAL (MEMBER X (REVERSE Y)) (MEMBER X Y)) (EQUAL (LENGTH (REVERSE X)) (LENGTH X)) (EQUAL (MEMBER A (INTERSECT B C)) (AND (MEMBER A B) (MEMBER A C))) (EQUAL (NTH (ZERO) I) (ZERO)) (EQUAL (EXP I (PLUS J K)) (TIMES (EXP I J) (EXP I K))) (EQUAL (EXP I (TIMES J K)) (EXP (EXP I J) K)) (EQUAL (REVERSE-LOOP X Y) (APPEND (REVERSE X) Y)) (EQUAL (REVERSE-LOOP X (NIL)) (REVERSE X)) (EQUAL (COUNT-LIST Z (SORT-LP X Y)) (PLUS (COUNT-LIST Z X) (COUNT-LIST Z Y))) (EQUAL (EQUAL (APPEND A B) (APPEND A C)) (EQUAL B C)) (EQUAL (PLUS (REMAINDER X Y) (TIMES Y (QUOTIENT X Y))) (FIX X)) (EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE) BASE) (PLUS (POWER-EVAL L BASE) I)) (EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE) BASE) (PLUS I (PLUS (POWER-EVAL X BASE) (POWER-EVAL Y BASE)))) (EQUAL (REMAINDER Y 1) (ZERO)) (EQUAL (LESSP (REMAINDER X Y) Y) (NOT (ZEROP Y))) (EQUAL (REMAINDER X X) (ZERO)) (EQUAL (LESSP (QUOTIENT I J) I) (AND (NOT (ZEROP I)) (OR (ZEROP J) (NOT (EQUAL J 1))))) (EQUAL (LESSP (REMAINDER X Y) X) (AND (NOT (ZEROP Y)) (NOT (ZEROP X)) (NOT (LESSP X Y)))) (EQUAL (POWER-EVAL (POWER-REP I BASE) BASE) (FIX I)) (EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE) (POWER-REP J BASE) (ZERO) BASE) BASE) (PLUS I J)) (EQUAL (GCD X Y) (GCD Y X)) (EQUAL (NTH (APPEND A B) I) (APPEND (NTH A I) (NTH B (DIFFERENCE I (LENGTH A))))) (EQUAL (DIFFERENCE (PLUS X Y) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS Y X) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS X Y) (PLUS X Z)) (DIFFERENCE Y Z)) (EQUAL (TIMES X (DIFFERENCE C W)) (DIFFERENCE (TIMES C X) (TIMES W X))) (EQUAL (REMAINDER (TIMES X Z) Z) (ZERO)) (EQUAL (DIFFERENCE (PLUS B (PLUS A C)) A) (PLUS B C)) (EQUAL (DIFFERENCE (ADD1 (PLUS Y Z)) Z) (ADD1 Y)) (EQUAL (LESSP (PLUS X Y) (PLUS X Z)) (LESSP Y Z)) (EQUAL (LESSP (TIMES X Z) (TIMES Y Z)) (AND (NOT (ZEROP Z)) (LESSP X Y))) (EQUAL (LESSP Y (PLUS X Y)) (NOT (ZEROP X))) (EQUAL (GCD (TIMES X Z) (TIMES Y Z)) (TIMES Z (GCD X Y))) (EQUAL (VALUE (NORMALIZE X) A) (VALUE X A)) (EQUAL (EQUAL (FLATTEN X) (CONS Y (NIL))) (AND (NLISTP X) (EQUAL X Y))) (EQUAL (LISTP (GOPHER X)) (LISTP X)) (EQUAL (SAMEFRINGE X Y) (EQUAL (FLATTEN X) (FLATTEN Y))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) (ZERO)) (AND (OR (ZEROP Y) (EQUAL Y 1)) (EQUAL X (ZERO)))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) 1) (EQUAL X 1)) (EQUAL (NUMBERP (GREATEST-FACTOR X Y)) (NOT (AND (OR (ZEROP Y) (EQUAL Y 1)) (NOT (NUMBERP X))))) (EQUAL (TIMES-LIST (APPEND X Y)) (TIMES (TIMES-LIST X) (TIMES-LIST Y))) (EQUAL (PRIME-LIST (APPEND X Y)) (AND (PRIME-LIST X) (PRIME-LIST Y))) (EQUAL (EQUAL Z (TIMES W Z)) (AND (NUMBERP Z) (OR (EQUAL Z (ZERO)) (EQUAL W 1)))) (EQUAL (GREATEREQPR X Y) (NOT (LESSP X Y))) (EQUAL (EQUAL X (TIMES X Y)) (OR (EQUAL X (ZERO)) (AND (NUMBERP X) (EQUAL Y 1)))) (EQUAL (REMAINDER (TIMES Y X) Y) (ZERO)) (EQUAL (EQUAL (TIMES A B) 1) (AND (NOT (EQUAL A (ZERO))) (NOT (EQUAL B (ZERO))) (NUMBERP A) (NUMBERP B) (EQUAL (1- A) (ZERO)) (EQUAL (1- B) (ZERO)))) (EQUAL (LESSP (LENGTH (DELETE X L)) (LENGTH L)) (MEMBER X L)) (EQUAL (SORT2 (DELETE X L)) (DELETE X (SORT2 L))) (EQUAL (DSORT X) (SORT2 X)) (EQUAL (LENGTH (CONS X1 (CONS X2 (CONS X3 (CONS X4 (CONS X5 (CONS X6 X7))))))) (PLUS 6 (LENGTH X7))) (EQUAL (DIFFERENCE (ADD1 (ADD1 X)) 2) (FIX X)) (EQUAL (QUOTIENT (PLUS X (PLUS X Y)) 2) (PLUS X (QUOTIENT Y 2))) (EQUAL (SIGMA (ZERO) I) (QUOTIENT (TIMES I (ADD1 I)) 2)) (EQUAL (PLUS X (ADD1 Y)) (IF (NUMBERP Y) (ADD1 (PLUS X Y)) (ADD1 X))) (EQUAL (EQUAL (DIFFERENCE X Y) (DIFFERENCE Z Y)) (IF (LESSP X Y) (NOT (LESSP Y Z)) (IF (LESSP Z Y) (NOT (LESSP Y X)) (EQUAL (FIX X) (FIX Z))))) (EQUAL (MEANING (PLUS-TREE (DELETE X Y)) A) (IF (MEMBER X Y) (DIFFERENCE (MEANING (PLUS-TREE Y) A) (MEANING X A)) (MEANING (PLUS-TREE Y) A))) (EQUAL (TIMES X (ADD1 Y)) (IF (NUMBERP Y) (PLUS X (TIMES X Y)) (FIX X))) (EQUAL (NTH (NIL) I) (IF (ZEROP I) (NIL) (ZERO))) (EQUAL (LAST (APPEND A B)) (IF (LISTP B) (LAST B) (IF (LISTP A) (CONS (CAR (LAST A)) B) B))) (EQUAL (EQUAL (LESSP X Y) Z) (IF (LESSP X Y) (EQUAL T Z) (EQUAL F Z))) (EQUAL (ASSIGNMENT X (APPEND A B)) (IF (ASSIGNEDP X A) (ASSIGNMENT X A) (ASSIGNMENT X B))) (EQUAL (CAR (GOPHER X)) (IF (LISTP X) (CAR (FLATTEN X)) (ZERO))) (EQUAL (FLATTEN (CDR (GOPHER X))) (IF (LISTP X) (CDR (FLATTEN X)) (CONS (ZERO) (NIL)))) (EQUAL (QUOTIENT (TIMES Y X) Y) (IF (ZEROP Y) (ZERO) (FIX X))) (EQUAL (GET J (SET I VAL MEM)) (IF (EQP J I) VAL (GET J MEM)))))) (DEFUN SETUP-DDERIV () (MAPC #'(LAMBDA (OP FUN) (SETF (GET OP 'DDERIV) (SYMBOL-FUNCTION FUN))) '(+ - * /) '(+DDERIV -DDERIV *DDERIV /DDERIV))) (DEFUN SETUP-FRPOLY () (SETF (GET 'X 'ORDER) 1) (SETF (GET 'Y 'ORDER) 2) (SETF (GET 'Z 'ORDER) 3) (SETQ *R* (PPLUS '(X 1 1 0 1) (PPLUS '(Y 1 1) '(Z 1 1)))) (SETQ *R2* (PTIMES *R* 100000)) (SETQ *R3* (PTIMES *R* 1.0))) (DEFUN SNB () (SETQ SN (1+ SN))) (DEFUN START () (DO ((M 0 (1+ M))) ((> M SIZE)) (SETF (AREF PUZZLE M) TRUE)) (DO ((I 1 (1+ I))) ((> I 5)) (DO ((J 1 (1+ J))) ((> J 5)) (DO ((K 1 (1+ K))) ((> K 5)) (SETF (AREF PUZZLE (+ I (* *D* (+ J (* *D* K))))) FALSE)))) (DO ((I 0 (1+ I))) ((> I TYPEMAX)) (DO ((M 0 (1+ M))) ((> M SIZE)) (SETF (AREF *P* I M) FALSE))) (SETQ III 0) (DEFINEPIECE 0 3 1 0) (DEFINEPIECE 0 1 0 3) (DEFINEPIECE 0 0 3 1) (DEFINEPIECE 0 1 3 0) (DEFINEPIECE 0 3 0 1) (DEFINEPIECE 0 0 1 3) (DEFINEPIECE 1 2 0 0) (DEFINEPIECE 1 0 2 0) (DEFINEPIECE 1 0 0 2) (DEFINEPIECE 2 1 1 0) (DEFINEPIECE 2 1 0 1) (DEFINEPIECE 2 0 1 1) (DEFINEPIECE 3 1 1 1) (SETF (AREF PIECECOUNT 0) 13) (SETF (AREF PIECECOUNT 1) 3) (SETF (AREF PIECECOUNT 2) 1) (SETF (AREF PIECECOUNT 3) 1) (LET ((M (+ 1 (* *D* (+ 1 *D*)))) (N 0) (KOUNT 0)) (COND ((FIT 0 M) (SETQ N (PLACE 0 M))) (T (FORMAT T "~%Error."))) (COND ((TRIAL N) (FORMAT T "~%Success in ~4D trials." KOUNT)) (T (FORMAT T "~%Failure."))))) (DEFUN TAUTOLOGYP (X TRUE-LST FALSE-LST) (COND ((TRUEP X TRUE-LST) T) ((FALSEP X FALSE-LST) NIL) ((ATOM X) NIL) ((EQ (CAR X) 'IF) (COND ((TRUEP (CADR X) TRUE-LST) (TAUTOLOGYP (CADDR X) TRUE-LST FALSE-LST)) ((FALSEP (CADR X) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST FALSE-LST)) (T (AND (TAUTOLOGYP (CADDR X) (CONS (CADR X) TRUE-LST) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST (CONS (CADR X) FALSE-LST)))))) (T NIL))) (DEFUN TAUTP (X) (TAUTOLOGYP (REWRITE X) NIL NIL)) (DEFUN TEST () (PROG (ANS TERM) (SETQ TERM (APPLY-SUBST '((X F (PLUS (PLUS A B) (PLUS C (ZERO)))) (Y F (TIMES (TIMES A B) (PLUS C D))) (Z F (REVERSE (APPEND (APPEND A B) (NIL)))) (U EQUAL (PLUS A B) (DIFFERENCE X Y)) (W LESSP (REMAINDER A B) (MEMBER A (LENGTH B)))) '(IMPLIES (AND (IMPLIES X Y) (AND (IMPLIES Y Z) (AND (IMPLIES Z U) (IMPLIES U W)))) (IMPLIES X W)))) (SETQ ANS (TAUTP TERM)))) (DEFUN TRANS-OF-IMPLIES (N) (LIST 'IMPLIES (TRANS-OF-IMPLIES1 N) (LIST 'IMPLIES 0 N))) (DEFUN TRANS-OF-IMPLIES1 (N) (COND ((EQUAL N 1) (LIST 'IMPLIES 0 1)) (T (LIST 'AND (LIST 'IMPLIES (1- N) N) (TRANS-OF-IMPLIES1 (1- N)))))) (DEFUN TRAVERS (TNODE MARK) (COND ((EQ (TNODE-MARK TNODE) MARK) NIL) (T (SETF (TNODE-MARK TNODE) MARK) (SETQ COUNT (1+ COUNT)) (SETF (TNODE-ENTRY1 TNODE) (NOT (TNODE-ENTRY1 TNODE))) (SETF (TNODE-ENTRY2 TNODE) (NOT (TNODE-ENTRY2 TNODE))) (SETF (TNODE-ENTRY3 TNODE) (NOT (TNODE-ENTRY3 TNODE))) (SETF (TNODE-ENTRY4 TNODE) (NOT (TNODE-ENTRY4 TNODE))) (SETF (TNODE-ENTRY5 TNODE) (NOT (TNODE-ENTRY5 TNODE))) (SETF (TNODE-ENTRY6 TNODE) (NOT (TNODE-ENTRY6 TNODE))) (DO ((SONS (TNODE-SONS TNODE) (CDR SONS))) ((NULL SONS) NIL) (TRAVERS (CAR SONS) MARK))))) (DEFUN TRAVERSE (ROOT) (LET ((COUNT 0)) (TRAVERS ROOT (SETQ MARKER (NOT MARKER))) COUNT)) (DEFUN TRAVERSE-RANDOM () (SETQ RAND (MOD (* RAND 17) 251))) (DEFUN TRAVERSE-REMOVE (N Q) (COND ((EQ (CDR (CAR Q)) (CAR Q)) (PROG2 NIL (CAAR Q) (RPLACA Q NIL))) ((= N 0) (PROG2 NIL (CAAR Q) (DO ((P (CAR Q) (CDR P))) ((EQ (CDR P) (CAR Q)) (RPLACA Q (RPLACD P (CDR (CAR Q)))))))) (T (DO ((N N (1- N)) (Q (CAR Q) (CDR Q)) (P (CDR (CAR Q)) (CDR P))) ((= N 0) (PROG2 NIL (CAR Q) (RPLACD Q P))))))) (DEFUN TRAVERSE-SELECT (N Q) (DO ((N N (1- N)) (Q (CAR Q) (CDR Q))) ((= N 0) (CAR Q)))) (DEFUN TRIAL (J) (LET ((K 0)) (DO ((I 0 (1+ I))) ((> I TYPEMAX) (SETQ KOUNT (1+ KOUNT)) FALSE) (COND ((NOT (= (AREF PIECECOUNT (AREF CLASS I)) 0)) (COND ((FIT I J) (SETQ K (PLACE I J)) (COND ((OR (TRIAL K) (= K 0)) (SETQ KOUNT (+ KOUNT 1)) (RETURN TRUE)) (T (PUZZLE-REMOVE I J)))))))))) (DEFUN TRIANG-TEST () (DOTIMES (J 16) (SETF (AREF BOARD J) 1)) (SETF (AREF BOARD 5) 0) (LET ((ANSWER NIL) (FINAL NIL)) (TRY 22 1) (= (LENGTH ANSWER) 775))) (DEFUN TRUEP (X LST) (OR (EQUAL X '(T)) (MEMBER X LST :TEST #'EQUAL))) (DEFUN TRY (I DEPTH) (COND ((= DEPTH 14) (LET ((LP (LAST-POSITION))) (UNLESS (MEMBER LP FINAL) (PUSH LP FINAL))) (PUSH (CDR (COERCE SEQUENCE 'LIST)) ANSWER) T) ((AND (= 1 (AREF BOARD (AREF *A* I))) (= 1 (AREF BOARD (AREF *B* I))) (= 0 (AREF BOARD (AREF *C* I)))) (SETF (AREF BOARD (AREF *A* I)) 0) (SETF (AREF BOARD (AREF *B* I)) 0) (SETF (AREF BOARD (AREF *C* I)) 1) (SETF (AREF SEQUENCE DEPTH) I) (DO ((J 0 (1+ J)) (DEPTH (1+ DEPTH))) ((OR (= J 36) (TRY J DEPTH)) NIL)) (SETF (AREF BOARD (AREF *A* I)) 1) (SETF (AREF BOARD (AREF *B* I)) 1) (SETF (AREF BOARD (AREF *C* I)) 0) NIL))) (IL:* IL:|;;| "Modified version of browse which doesn't cons so much") (DEFMACRO CHAR1* (X) `(CODE-CHAR (IL:NTHCHARCODE ,X 1))) (DEFUN BROWSE* () (SETF RAND 21) (INVESTIGATE* (RANDOMIZE (INIT 100 10 4 '((A A A B B B B A A A A A B B A A A) (A A B B B B A A (A A) (B B)) (A A A B (B A) B A B A)))) '((*A ?B *B ?B A *A A *B *A) (*A *B *B *A (*A) (*B)) (? ? * (B A) * ? ?)))) (DEFUN INVESTIGATE* (UNITS PATS) (DO ((UNITS UNITS (CDR UNITS))) ((NULL UNITS)) (DO ((PATS PATS (CDR PATS))) ((NULL PATS)) (DO ((P (GET (CAR UNITS) 'PATTERN) (CDR P))) ((NULL P)) (MATCH* (CAR PATS) (CAR P) NIL))))) (DEFUN MATCH* (PAT DAT ALIST) (COND ((NULL PAT) (NULL DAT)) ((NULL DAT) NIL) ((OR (EQ (CAR PAT) '?) (EQ (CAR PAT) (CAR DAT))) (MATCH* (CDR PAT) (CDR DAT) ALIST)) ((EQ (CAR PAT) '*) (OR (MATCH* (CDR PAT) DAT ALIST) (MATCH* (CDR PAT) (CDR DAT) ALIST) (MATCH* PAT (CDR DAT) ALIST))) (T (COND ((ATOM (CAR PAT)) (COND ((EQL (CHAR1* (CAR PAT)) #\?) (LET ((VAL (ASSOC (CAR PAT) ALIST))) (COND (VAL (MATCH* (CONS (CDR VAL) (CDR PAT)) DAT ALIST)) (T (MATCH* (CDR PAT) (CDR DAT) (CONS (CONS (CAR PAT) (CAR DAT)) ALIST)))))) ((EQL (CHAR1* (CAR PAT)) #\*) (LET ((VAL (ASSOC (CAR PAT) ALIST))) (COND (VAL (MATCH* (APPEND (CDR VAL) (CDR PAT)) DAT ALIST)) (T (DO ((L NIL (NCONC L (CONS (CAR D) NIL))) (E (CONS NIL DAT) (CDR E)) (D DAT (CDR D))) ((NULL E) NIL) (COND ((MATCH* (CDR PAT) D (CONS (CONS (CAR PAT) L) ALIST)) (RETURN T)))))))))) (T (AND (NOT (ATOM (CAR DAT))) (MATCH* (CAR PAT) (CAR DAT) ALIST) (MATCH* (CDR PAT) (CDR DAT) ALIST))))))) (DEFINE-TIMER BROWSE* "Browse" (BROWSE*)) (IL:* IL:|;;| "Modified version of traverse-init to break circularities") (DEFUN CREATE-STRUCTURE* (N) (LET ((A `(,(MAKE-TNODE)))) (DO ((M (1- N) (1- M)) (P A)) ((= M 0) (SETQ A `(,(RPLACD P A))) (DO ((UNUSED A) (USED (ADD (TRAVERSE-REMOVE* 0 A) NIL)) (X) (Y)) ((NULL (CAR UNUSED)) (PROG1 (FIND-ROOT (TRAVERSE-SELECT 0 USED) N) (IL:* IL:|;;| "Break the circularities") (RPLACD (CAR USED) NIL))) (SETQ X (TRAVERSE-REMOVE* (REM (TRAVERSE-RANDOM) N) UNUSED)) (SETQ Y (TRAVERSE-SELECT (REM (TRAVERSE-RANDOM) N) USED)) (ADD X USED) (SETF (TNODE-SONS Y) `(,X . ,(TNODE-SONS Y))) (SETF (TNODE-PARENTS X) `(,Y . ,(TNODE-PARENTS X))))) (PUSH (MAKE-TNODE) A)))) (DEFUN TRAVERSE-REMOVE* (N Q) (COND ((EQ (CDR (CAR Q)) (CAR Q)) (PROG2 NIL (CAAR Q) (IL:* IL:|;;| "Break the circularity ") (RPLACD (CAR Q) NIL) (RPLACA Q NIL))) ((= N 0) (PROG2 NIL (CAAR Q) (DO ((P (CAR Q) (CDR P))) ((EQ (CDR P) (CAR Q)) (RPLACA Q (RPLACD P (CDR (CAR Q)))))))) (T (DO ((N N (1- N)) (Q (CAR Q) (CDR Q)) (P (CDR (CAR Q)) (CDR P))) ((= N 0) (PROG2 NIL (CAR Q) (RPLACD Q P))))))) (DEFUN RELEASE-TREE (ROOT) (LET ((*TREE-SNS* NIL)) (DECLARE (SPECIAL *TREE-SNS*)) (RELEASE-TREE-AUX ROOT))) (DEFUN RELEASE-TREE-AUX (NODE) (LET ((SONS (TNODE-SONS NODE))) (DECLARE (SPECIAL *TREE-SNS*)) (PUSHNEW (TNODE-SN NODE) *TREE-SNS*) (SETF (TNODE-PARENTS NODE) NIL) (DOLIST (N SONS) (IF (NOT (MEMBER (TNODE-SN N) *TREE-SNS* :TEST #'EQ)) (RELEASE-TREE-AUX N))) (SETF (TNODE-SONS NODE) NIL))) (DEFINE-TIMER (TRAVERSE* (:SETUP (PROGN (SETQ SN 0) (SETQ RAND 21) (SETQ COUNT 0) (SETQ MARKER NIL) (SETQ ROOT (CREATE-STRUCTURE* 100)) NIL)) (:AFTER (RELEASE-TREE ROOT))) "Traverse, Traverse" (DO ((I 50 (1- I))) ((= I 0)) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT))) (DEFINE-TIMER (TRAVERSE-INIT* (:AFTER-EVERY (RELEASE-TREE ROOT))) "Traverse, Initialize" (PROGN (SETQ SN 0) (SETQ RAND 21) (SETQ COUNT 0) (SETQ MARKER NIL) (SETQ ROOT (CREATE-STRUCTURE* 100)) NIL)) (DEFVAR DIV2-L (CREATE-N 200)) (DEFPARAMETER *CONSY-BENCHMARKS* '(DERIV DDERIV DIV2-1 DIV2-2 DESTRU BOYER BROWSE BROWSE* TRAVERSE-INIT* TRAVERSE*)) (DEFPARAMETER *AREFY-BENCHMARKS* '(PUZZLE TRIANG FFT)) (DEFPARAMETER *POLY-BENCHMARKS* '(FRPOLY10R FRPOLY10R2 FRPOLY10R3 FRPOLY15R FRPOLY15R2 FRPOLY15R3 FRPOLY2R FRPOLY2R2 FRPOLY2R3 FRPOLY5R FRPOLY5R2 FRPOLY5R3)) (DEFINE-TIMER (BOYER (:SETUP (SETUP))) "Boyer" (TEST)) (DEFINE-TIMER BROWSE "Browse" (BROWSE)) (DEFINE-TIMER (DDERIV (:SETUP (SETUP-DDERIV))) "DDeriv" (RUN-DDERIV)) (DEFINE-TIMER DERIV "Deriv" (RUN-DERIV)) (DEFINE-TIMER DESTRU "Destruct" (DESTRUCTIVE 600 50)) (DEFINE-TIMER DIV2-1 "Div2, Iterative" (ITERATIVE-DIV2-TEST DIV2-L)) (DEFINE-TIMER DIV2-2 "Div2, Recursive" (RECURSIVE-DIV2-TEST DIV2-L)) (DEFINE-TIMER FFT "FFT" (DO ((NTIMES 0 (1+ NTIMES))) ((= NTIMES 10)) (FFT RE IM))) (DEFINE-TIMER (FRPOLY10R (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 10, r = x + y + z + 1" (PEXPTSQ *R* 10)) (DEFINE-TIMER (FRPOLY10R2 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 10, r2 = 1000r" (PEXPTSQ *R2* 10)) (DEFINE-TIMER (FRPOLY10R3 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 10, r3 = r in flonums" (PEXPTSQ *R3* 10)) (DEFINE-TIMER (FRPOLY15R (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 15, r = x + y + z + 1" (PEXPTSQ *R* 15)) (DEFINE-TIMER (FRPOLY15R2 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 15, r2 = 1000r" (PEXPTSQ *R2* 15)) (DEFINE-TIMER (FRPOLY15R3 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 15, r3 = r in flonums" (PEXPTSQ *R3* 15)) (DEFINE-TIMER (FRPOLY2R (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 2, r = x + y + z + 1" (PEXPTSQ *R* 2)) (DEFINE-TIMER (FRPOLY2R2 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 2, r2 = 1000r" (PEXPTSQ *R2* 2)) (DEFINE-TIMER (FRPOLY2R3 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 2, r3 = r in flonums" (PEXPTSQ *R3* 2)) (DEFINE-TIMER (FRPOLY5R (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 5, r = x + y + z + 1" (PEXPTSQ *R* 5)) (DEFINE-TIMER (FRPOLY5R2 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 5, r2 = 1000r" (PEXPTSQ *R2* 5)) (DEFINE-TIMER (FRPOLY5R3 (:SETUP (SETUP-FRPOLY))) "FRPoly, Power = 5, r3 = r in flonums" (PEXPTSQ *R3* 5)) (DEFINE-TIMER PUZZLE "Puzzle" (START)) (DEFINE-TIMER TRAVERSE "Traverse, Traverse" (DO ((I 50 (1- I))) ((= I 0)) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT))) (DEFINE-TIMER TRAVERSE-INIT "Traverse, Initialize" (PROGN (SETQ SN 0) (SETQ RAND 21) (SETQ COUNT 0) (SETQ MARKER NIL) (SETQ ROOT (CREATE-STRUCTURE 100)) NIL)) (DEFINE-TIMER TRIANG "Triang" (GOGOGO 22)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:GABRIEL-OTHER IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:GABRIEL-OTHER IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "GABRIEL"))) (IL:PUTPROPS IL:GABRIEL-OTHER IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.LCOM b/internal/gabriel/benchmarks/GABRIEL-OTHER.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..d5201f3e5358a5fe625c37a344f8fc6cf78d239f GIT binary patch literal 43889 zcmdsgeQ;dYb>Hp-MahVWEI@>&AX&bFWqAp4DeNx3ttk7jSa2V(*tgtW5CEl^p|G$4 zEJUgx<*%q}^U+SzY1+tkY|B1 z{z*F(`a9>|``&%~1@I%8Ooqh1`|jtt=bU@)x#ymHUvw%n?c_7DX(yM7Ir(W0G~fv|y)a?V}kHMP425KWa}FolLI((4o$#lbfLOX_PEyrbK^YEH?Av z>Dbtqh>uPr#wHS@{UX}GeCGKV);3lu;>>B$FFH}^M>0jH^!K02Ii*6{EoPopbv`|r z$)~e(c5$|(qhfA3n<*Z7_M;<*Q2nS^{n*6d;6!|+U-YNlxdQcp0IBo~)c(@i>6b)j z|KiH#nNN${+SwO`57&_+M`WJLsdFopmrRfc$0w5G6N#bz9XmEMkxX(echV0rGBiFk z#AtYFdG*xkPpq7MiJ?AsX5uA5C_Qc$9U?| zD$-wqev~DnYZv1pUC7M?8$7aOdC{pt9@PY3 zn*;3>2=WoL=NE+(EQ}3=32y#XX|e+6IFL%HEr{u9VA;t}#Rx~82$scBm;MPSkFb+J zo+*``qYyB{DQAjy8D(Qr&hbRuE3k>)f`;W-!7Vw2IWcFK(^=s{%q`eUF~+dy47|pJ zsc}XNgi>ajkjjAq9*hk6h~rguT|E&oFfS@{{Wi$_b|%YswRO0GfNd|opa2bpx86a>aNRSqH}7%RIhcfr~a|D{ZMz94^f zMI05IE*9L}64-uHl*)FoEXwwL+0D5}m%#oA7DOi#uM7?>#oXx_@RP%E#n=c|-D zM2LQ7ynyCjl_8@s*Xc!+GMK5*HiT=AfAdErhG+!RI9!tBj^rpyr~wwHAN?pzCUa*h zYad_39QMhT&9iHm$j*FRJhyq~Q)gGir&iaNS4HK_%GuK&IVYCSoIWego)OQ#xV+k5 zKahE74XE*k>V4iG5S`4dB;bh?&_y{a2M*mPROdEN5sWLbwbN_o#JMv7bLCW3EU#@Y zzqoN~bM4&P%GpN1v97=X=otpe)yAH zCk^6QPIk|aZk+QV>5Cc2Mq?U;hzCcRF+Kp3?h?s#DcU-wRfLeBBa=Ef?4=L;>BGgO=#+UAIz8bfCy*)=y~2K3Dyn7+jkX}x6rZAVG?Pzd zFh>;#Ds~L;!<36@-rb{lkzbnAH(u7f@+Gh zhcJ;(OibBjoBNq}a)SQ)x%L>eQopT35~>)a5SM}IpU;(j*kgqvi*aZKg(U?Z)iua9 zMm{K;FF#l34KY z#H~))>2#)4a*JZ3P|Qp@X=qL!P&|rD&cwury`dRXQYGdMmf%=bZ=|yCx-$k;ci3H$ zSW;v}qY~voPKqkx1&52u8sq~N8Kkm`43ber2AH-JfGCb87aOrL!FXa3u0nwn3wQi z)j<}Qx>XU{8w!QOsecy=MM7Yz&S+9e?#`$Z^3b)hM0HA8NJqtFx+`40-;9#ufyPu8 z5qf~zL2GX}Ye@pia&o8QRue!~@qDnOP1@emvak}NJGH*IeFcdfA$XvD1<4&N*w?;- zp&cuDuzdx?J66!uzJie*D~PnLfMxJbH0WtkoYf1TRiT+omtq(wF_)HGSV2KO3P`&{ z(84_(B+w$n-%GJmo1ZuvdkF*Adj3$z3axa9Lu=jdM!Ii)u=}T@+3K6uW-Bwde*S!T zwYIwS?X|bE)stPd@3>u+yo&sxlaU%Cduu0qYHn}E?UC^q1t$;G)=nOz#7Al;`)ckZ z6}OKPmussh51xD!iGmUztDWqxxsO%ceoFip62-~Kkr<`K!?lwGHTQ7E9iYS|Bt}mj zLE<1K4%JR3YVJ_QO;BPPiGwFckT^z(Pt{IN)ZC{k?gS;eNE|!)G!j#kI8{42S#zf< z?j$A7ATf1v8i`p-%+*fL)ZARf<$h<7m_3=V{ctGs!IOoW^D}NC*Bh$MebFtrkzT8Y z$AR8G?m>Egw0CdK6%=~B_ko%lrO=VyeKmKGLLA^lG6KTz?#GPm1H z@xABYds)Rl!tt-Vk5K$0=imEr75^B=f6aZ2;vYNz-ak?ChdKW1?qP~QeEz+kQt?9^ z|4ny@;)l+^_c;~+6vzLv`xM1Lb^g6CsrV_5zu-<${M7mPUQ_Woj=$pOC_Z=oz1Kt0 z(IHwvL;enrkBbQ&6T_nzmn@@3#PD!jg@?s(VpN5P#PA@b2j@wOp;45SN}CuO)@9>j zD2cLAFNX$Ej^%A~3ejsF!}NUJJi_diUUWZ|`3GKG6FBe)sk6!|#K=58}70w+p|K-UxnsdV8{w zHBdc^ztztBLZRnE`?r2B6dmWOIi1aDz{0VOi@rxQ0 z?Ex;z23rpsnErQw8T$e|4;>e^i-z?!*qHOh|Wbg9_Na zrl9q}(xt6R*x`dM-LvVz>N-oN*jZTd@q<5@F6`N&w%04OJ=y0>GuaO4I=&M=7kA14 zdsX{3c+v?)&IL93O$))c+s{QAIm($J<3Mno()08GZ|Let_qt zIG-RALE^_?S(PTZL9Sgh9@j#1QnD#j=9Hwf?$80+$7;V z`z0rTly;tB4y8RiNypA6gghci*%B(=QfvX3N>i}O&BykAB-Ie603ui82+)bDKKV*E ztG3MUZ*#V&*36))_M-ymBzf;Ks76{7oE_@i86pgacJOer2@MS&leEFPr~No=Njy0L zw1R{8f<4w!lSMrYddh2~2Oir&cGBi;3m9aQ!UMgC1cY0gwu+fnH6cOQ0~`I{>>#22 zVTP+ECG-Y+3+Vl1)dw9B?8#6&rfiEhSlubTanMnMZZp4wgz`KCxGpXI*-N0@lxU{p zr)=$UG`|BMnQjQ^jCMT;EbwgfCiLVUEbg!ltEBqyo9d2tWH0TT?de+6ez-xms9 zo&Ca$^Z2!&a8~X^$PTBH@&6 z?F)tafG&{VaONRTm1a${2TPz?@&eMWqAUB+70Z5oH3G_`X1{)*tge2ns*M=0HMO^{ z8=+qC93w&>KnFq_-?tpvsBG-p*hB0AnuGEbLSxhmY{d9}4b%KADo1f7ya5WbkGmpZ3tAnP>|l}g<>X2(EgzKL5!9t@*lzzZ-|5~BO0Z`wwP4^ z2jb0?X;%)Z3+j-k!_Ae1ct?X&NdZN7PXCr(?2BZyYKmmth1tq{X(y7K-G z?n?LfTiNi{tQEdS(ql%7N*-=7{zxgWY$D3j_ZHIa-8u}1u z*~ZQGi zi(rVStZG(ozCpP1G)bz0s&qswGGcta%M>l(0OIj32nU+OQxMhA5J*l$M-1&lJSpp7 zpK)o&KTmP7S>*DD84^7^>czFHU^sS5EpIY$e`}%d z&4mNkvRBt;XPiH;<*L`Werpatzn;g>e_D7HJ8ugIupO6jBW~A~+QK8)g+oM7E$jBW zJ%~84@!<9^EF7p_Up^374Jbp>8fNrYA?1>!(Kz8`dj6ijbkBsy0h=?If3T+%Z`xE#DJ3!4F#V@kN zNYKPY0y;ct1y8{0uh`gYvymVzxR^>1JRTEEKMV3fHtL8A(#=@ne+Poq>W+jq_Ceym z2Fh^{GZkOeDtv*zH2$?LmXX|I(F67HsZy;goe?rtl0>Cgu*oR)1 z%jA!ivjQ83GH!fGM~z@~<|dwfHjfRhG!azZ>VWSe^ zUw@2)qV- zH)pEXujOZMUHs|l$?3UUpF1CZ--hK*BlRRUs_7A_5qR(hScf+N1>FcHbEE)b_yyF* zJW|8{e8r7mXFl}HHTQtq_l|qeedL`R=n38)p|`$wuA@ipH00nvb0gPT&354_{J zcpT)sSsCP*1Drn#j{&y_J_A{I^0NEr4R^>*P%p| z>+VzT1m#Up?9(dmbvNZc4ZKXcUDr=evP;DFS@;!Hub_?9oHZI#QKZRaityJItiZrY6&eh=Z>GgC){2xF z3u!ehM!{3qhQe6_nA=M@E-UExLNDe=OYPpxc{_xQO_ojHP~r>`Fc z*dA6QspimVdyMpXo7VAAKvR)ah4s7FQ^Xo?hr(EkW~(6a5m?9*sj*wMMU4|;WzLdT7%37q9a{lZ~W!t%a z`IXg(0|xtJQz=%*IE+?xiv?IQ*yvB_Enw`cgE&0(kI3^l==YJm;ZS%Zvfka_k#%l; z?f9F{wd(8)IIDX7>eip{KMstnXE*M9} z3;=Uu>*gFJ;AFPD=Y4J$iF3E7hm!2vjT3l%e71TcM^b&DW^Y9y!`+@fascXru#Q+5 z@+Z5te$}gQrn>d3)f=e&t#3cG^-m$l!GuS_pi6U*m(qby8BF4sU{wmHWx}LN7z$*= z7}Dj(bttKvnc>P0zJ>x1WMJgb5IEFnF3%0r;fxAlZjeqY!GRg{d6E}rgf3VU>=PG0 znDw;NrPpS{PFNzy+PXD^*^o?tzXAIeP)^5kXtWIm+XV#1@gAdTSaqm9eyhfQ?B(rOvXN}{`r_7~nPW_zaME>P(VCFvB~%7~ zUJwg3Bh>vNNY#=0y1jZc!loaoe14-6w!=4HwQTD-tM*)I>$j!C_(;mKC&9p%eggrE zL%+sZwrZ(x$LG$6eiX_p5Vn4q=A(%Vk0W~W;Y;tQ+$q%9H`({xo|>%kpIa%b4^{tT zqre+SD1YTENWz$VE_8l-&F-_id#vmm9Y1z{yOOe;RCorp00u~z88A{GGG;Buy85ka zTmQojcdXuAz4^xfqQ(fkH-3|v<_6Die}EJaTIbT)uQ*nT7#Ui>!CWz}Q-;{MmBDrh zjVsd}f;{FcrVd#d?2Vdrq5VQz9foO%j3&t;@u6qoWHF2fVge`3f>IZJG?yURj%VDn z0h&g4f!Q8bz}00~=A=j)tvjRUF;bu%cyRgtywcX#wjn|b@tkRYjD@U_Wp`XWU>6=< zw!V-$W_>qer}_$g%b~Rh?7e$dBg8OoypPZ=fg4KHK^L$~1|e)}nj|2hSz<>@gdPGr zS<=eNw#hgC%A@Pn|Ar_WtZU1|gm+@kz(GR5e@moMJ?&bBx>0wBos9gKf14TiR|JI7LX2b+O}qQPdMfP<#24ka2LhJZ$A z)6`jMdN!(i29-sg(1ib;qOFbyjuEeKyqvKsKgTsHqc{Oh9pUAS2QC&gUR^M3 z$WxnsGx{KC0Qe=KkXKC*nIVfrCIYBe*=kg2c((PwfJ25KU)fBE4|Ib=n=n&sTz+WO5< z6w0hrg`pv+)2I-HDx}n8ziWJ=H2{XGL5@mujT9=VL>_@=5i@Qcl9oaT;0N?gU=nAx z(INN#`$E=2FLcaPd)J@I-n#hE!hzK6pM7;9a?PH-esyiexl)^jp7{q0J#Q^^r7nMa zp@$xqu{_RQso5Vp9p1i$`EntWzx;YWLZ+X{{zxXUHz7^wZV`4AkQPdOT@*3`d2qgIW#Lw*bB-1og@)H% zk{dMIg5$tr&=N6ds^c4S=CM1zVH3}QlSt}+6(gD_Y>M&}J=+W2`YNVlFM~~kA2}&A zb~-?DKJ`3`QOc*O<6;DC!f_+RUK|X!QE}Y|V@*+WC_xBgIvf z2r#MFw>j?H>o)WsT0)^m+ZP^&;sP-(#TJZUQe4rfNAj(&aUw;d6OdsIB5l+I5-Ngf zJPCH!$H%p7gR`ef_lFbrJOC+4BX)ojq4yK4_N6`Rkq!V%!u9ij5p$NBN3>L919A&m zu5f>okqApFfieMg1cSqfEP04YhBm)JnVm;Hq_u7l3Nq~EfodGFm zu%PzjH7(9nR?ryOl{AK3z@V|JK7cx$+{V}_V7jOK9XN<(3WvxXjSC+jTOJ}|*)760 zr0?QV4Rn1j^m;ZzuUogIl;^t1!&t)Ro5R$*iRwWiTczDk*#K>RhErGy6~d|T^#Ykx zc`mUmG@+&vVrF%@0CqQZwU7rg=<|mH#ptHrAeQH{o6}f2(`^6CmFL7-fd!L^AS~^_lH2a@V(hyY!`Or4+seW8-|5w$woU<-N=MBxbh$Z3zQp zaHgb7UO0%N7xvGW!ie&7|9HuoIjD;Ki;`viY^efca`x62Eo*u2*1IL^s#CGPT*FT| z`~PlzIXmN6eSHsYJ&sIdCk03szHi;pZ`)r)M$3BWClP~c@v8{M3xh;mf37*!g|BnX zw=TSftXqEpGA1wp8F?^1s__XK0uE)l7azo=t!HWI`7#zqA=L1N>9U>@JeBF|1Ppq_ zg*gF&u>MsbOpp30F)-te8+#uZ3fjanwwLC=2hv&aup8r<8`S19*Y2JJ5 zxSaj2=jN^iwk*7fj_!@Pt4R)XT*z7vRKC+ZL~Sp^%kOSa(n1a5Fi3j@#DTtu0-%nkwRJXqdW~V6P|A%T@zgE5BSX+OHH4j#@E|#cC zZLl8?Uf1GDjNsiLO@QIukrXSrERkrB4=bu*xfa#kD?3WCF_QQ7G4%k^B0HGJ08!p- zVvI?-uqM^`Vel<&&XG<}^0zPLO==(kY4t;>S6+!?-h#py@o!22f51v5{f(GibQ!)z zCD1bY1xS|nqtA;UonyTSL9-GH?lxOCCX z^I8D`4gr)18A!HZ&hk4BW4h_zL*pZ`VE1A3uZAIzpnizZM=|(9>tv%k-SLOC98?P% z-lIT!EuU<}`p;N?cw5x4A*ju2=mIK)oop4t@RcD24!M0rpMb9qR!oanSW(FKLX#AO z^ZwAoc9AK*bEZyqL)x)Du<4HNL0AwXc_;PW;*qN)G;)Bj$N@qk2MC80_&b6^aA{D$ zVZ!xJ=jt`+0G-d9!p&YW7k2S^+(08j^ACjOvEAya?o;<~SlM?!w-EWU4eQhi;$BDl zRzO+v!eC|meyQe?vmU7u+fYOGVJQ)MqQg>1&c6Ff=|_R;Zp#4<^oY9-`%L0?H_4-P`r z)BRyDH*%F5n9ncJWn=ImFXM&$w6>BkpySC7G)jlx ztJ!zIKm!Lf1_byI7}mNi3n7UX2ca26D%@Zwn79GUGq5xc(1wpC6HOXkNl+}B+(L%- zsbEBu{S(-qX-@wHxj{|H(N8v)i75xF1dTizLYVFPi-n`HbnZwwvslJJ;9JZz%NSm* zdoi)HS8G5GhA9Tuoq2K`9hPpck_|?D$6&)Ejwve|l|IW+eOnWIZHj0yLl>LjR7D!s z1YyHYMD-;FEF&<@f!E<_ih!yhbF6@Ak8Ukf5z~&G59zsN<~#}xrop7L<7&xLK`gOR zQkSJTzrsAOD~uZ1{5DioO|#auI_bJJpm>U=GZ7L>oWLPH$$x{}hyNbMO?nDSI;axW zH^Iq%>Nf`6t0M}`<>TCpGcBT0*XJ9_ki~_6VKg42z8bCYjg5s;OyuAmkeNb09Rrt{ zf{K+@nZ>5h5SNQhOdrW1J8DmIUmp$$(q7~M92aECUy5erN)K}%Dpgh<+G|%Bv``iMg}uxA;F*jA z_JE9W>tEp)&C|S>qa_ff)b)}Y#m$zSq{7g;+7^NMhf^}u#XP{wsHsW~5OaFW1P4;o zN6C`HTo~NYgz8jVK^#LB;1isq$L}#h7`q#7Un*CQEuqI$^+e4taRqaK`;1An%d#LkbH!d{npr`Sn9BF#YqB#lrE5p!(H z`W2G>rp?Z%=X`e2b@Q3-VJTp{W>@B|(qILXu~doq?FR zDSl;NNlN?R%t2a00hHL3_bf(n{(`osS+v4eS7AEZBrBSt^d>2oBIt~QhmR&%m~gnL z6V21elT{JEy!sY{btt$@_&{}xSPicZ)iHxN&8dvU5PmT&Kbc%QYXEj>+5=onXRci1 zL?_XVsKWt9l#yN<@)5*3s|wV?t5`&5qPjH;5?v)3iON1fJv?U?Gid`OC|j5+;g-VV zaI`@tO2sV*{9H7XWDd&0r<=Sv_dh-3m-Ic5?y zjhDcf^Rjr<;L5#dvnl0R>g6QXf#Sg4rX1E?kRahW4d10$f*QsW3%Pl`sLG{y@LmFg zH4g_?iF=-bH5F6?aPAY1;)EG7OJFE+%aj>J$Pm&fEK#e9$*igz#i_g~#Z{@?iX-)e zPRyW5p_vt|VB)8)gq$2b&45Rm28A^cxo9|n!=ljKV>zj@p&90Osif#E#B_l&XxHeN z?4Q8^9;`MAL5%^LHoORDPFrP!G+T4g4uw7I9&69ZiW990MG)kY)uCiHT|!H=<@V!FX(| z7fnOjwI)=dKZ-I(({f%EQ3?f@Gb}7j=4S-UxhYDCHlv(EILv2E;*KZ2XxcGaGxA9O zWj-MEQqLKs3a*Bnto-gOC)cT~$J`YFO-**H6+I)Fz^BDRT^S_=)2vO)A`2vSd@TCh z>dl0h6=`Culduil0^$s1%hOGQ62&YfRdr+HW`%+DcN2Yzk2zZ-K4fYT6{>{Bh(D>T zZ1w!lh&5T=V<}y`CP9;t;$x1u&cvAtt41X>kmQ<84V<$PghsQmZX*22c-FK$kQBL% zsa`JjAddA)OZJb;jxwrn2$enuI+c!^4r zMGz>IVS%?3NSsO6MB~P2fGI3zW32`-&NWj=evlc6EJpqS?s&!8v>t}eNTynh*FY^2 z1>iTycnh=!)1qH3MrdFV`n{~0Ffw96&L}!v;jIW$k0xZp9O32F1W>IjJot@yM6CnK zXIJI{1G^1!iKQs&H{LKM41qFR~-MR*-3r*jLE;O|?bZUjo8EP|AB_H)x8U`lCgyev-(g0!se-I_DCijSiQbqjQ?5JeT`5N>*^d1T?oeTp?;yxYZSN zBDF@A5|7}-V8%S97+H74uSHd6^jgX~BjSXd)~I%WvQgZpCmJ54ehw;9m%}8aRJSEE zQPM<5vo*cPFw{%pU24c!#s#zsZ=uham(~XWL&bF6YGTr_^%)J~ND9yb)SKPwk*vv} zvoa;rdcsFD>v1&CF^Q=T8h=ne2~8C34_`$QI$eQwrK+c_3yff%9%-y{4hs0u)Jtag zXqs%OoP!QVBUfN)tlMA%Iuo2^D%ayjDMl-^5+zGalQc$7RUYPZ4MYSWWcbZV-tQ#IT29t8IJ1@~{uFFFF`AwNCj6RoKRqpj({*mHN@9>J zl+-c%Tt7TLaZUhAqI$yJ6BjJpZ5-OT!jThfQvMz`Ddk1) z>WCFiF*P1+^=>!f?Inm;eWj6ZUf-sqE)Ig10yz!DaFpap4^sKD5N~&m-3#$8E9{Ta zX$}6Q6^C)8nr^TZp_veTv;Z;wR{^mMZCHM=13~Jc{=>#A{x63r6hR@YphLI`J&M!U z%7G3CF;xg>Wu&JZE^&|nAb_?76*{obX1t9XFF*zMbfqIFHt$Z5KaYHaOUx3^0jeZS zUD%VuaZNfyiBp(y?BC+52OQ^%q6{<>_UM3;z(LGUbhsmqol&TKowye{fH3;}Md*Io zwJYE}KXzq7bA1#58`zjA^)4TsM3i^xF;bg(@p%^(z=ts4)=r-p<5KV$qFV?>_!!*x z;1h!bapZ{pEAU#!eFWsQ$38EAy1&|O@4V@0BX2S2wKn3eu6?qVy^XSa@z&)e61i$@!65rF^KZLQgt` zxzU+jzrx2cH#)La8LHx-ffwqyvVWngQoa68_4<0HyW_rfy3FKf`1dE*6z|n?7;&%i z+Z-4+qT|7lNsK+^Tal#myVA`f2~Lt9b4r2$I+FZ5`KUqy&d7A=HNh7Z;IwH*-djNq zqUI;c5^#bFyki4D@Q$lT%=h>>U3}oz7at4O7at4O7atAQ7l*rhpgerX1Me7X!S_IY z+Jh&F0oecYho?`iZM?X-f{z*|(GNtFUR+*YIeS*Dofa<-O^I`xYo|8OQZjB!s_9WVZr6QlO(bxC4U2Rx89@boY|c4EznGE1>6-!MBNd zd;4_zmnl9gR1qq{NHQ&!Wk@2kBr{eFbzAJ7y(?Ik>jSkYt&<#(b|KzqKf{PxZU6 zQd3p-Ek=l%uil_jaD8|ZPsp2da4$eJ0C2aKh5%l@L~6Lb1Oef1+Zmmuv(otfkiH8* zO*c5aO;`7d&`;o;uqCep=&^5Jd>)=?c5lxy%z0J{VfuS}@9NFoz24gcczeKm+lRM( z-rIwCd(eC9!dsX37QtJD-rlyzj>cEJ;t{);%CgHq@4A8NDzV!)yoiYG1t^&Gd2yT^GJ~efvUya5pA0^}q zjWKuA=@9-lr<}(b+w>J3900;u4)ShI9b3J*Y@w%F8t>laSH7T-oyPYDK~UU}rJFI_ zhjzUAO(D+vW}&VF{3ow;WR9Pw<7RN^#Zjy;*w6H`0#Kv6ezH3#MW z@Hw+^eIU*nQk|biom}5lu!5m#$=TVcVvx5wNRv&NS{Dw&)SaCm$1tpMK!_;|$640- z%888!Z+)={-o`0pd=d2W<@N20k2{qVXmjC%@^s@O#^Bd+Nrud}7U3h0bX~;OzlT)N z=PdMD4!$aazOg`OwpeGtoC=k}pe^0$9`t?R<<%9VxVj>=%d0Ck4$$2dr2d@lxPKdL z1~)lnvLUBX<2DO90~!d`Ug5O-`s=xr2W}}4$4eexGfz%s3fMS-)~h_x6Y3MXJc{tW zL;1N}qB9&r(@IOm4W_mVj^NTp6&&?Hi_4|Q)LkIx&s*00VEB!$?F%1z0Jm^}y-OeX zMz++qytf8*62cc)!(o}e<;Ys3TAar*&}}*<6#7Ti;&FcYk@aGk1Di!K5Heg{&pKE3 z(+e{AFUWMYN+}CnNV2b{D7Z7JhuJKY=yj4FC4CMS*nP$>x#S=s)(AvJyE!* z;XguP;PMW_9$XZ0?5l`x!h*EsCu$+1uxcbjJWDHmI3`Ws;2pTD!!eDQK$4=(cYDe8 z5N-pc`2-dgYK^=O0USN}21CD`1 zT^Nd67ygdi7;0RzGT@4sRkl$#WgaKfXBsI zG^?;_3?__F2m%)q5#&05Mi)Fp)4Dn>r;R@Km8y5FFU(U6o?Jj9N|x-dg5a44(Lc$b zTgKA0{<75oC#x&`e*FGWsPVSdPqesg^(hGQ!j$vlUhMmirc?(^#V%MK|b6I z^;4uWk`C{EQx0TmqZtHS~0-QYe< zph_!(?&GzF7N+*l@o>3>ig$2ePx)%a`M~FD&W}2M%e*XG#fQ;OT>2hLUG24S-Oe*q zU{Cpxe@O;uIxmA0e7Li*9te0*f!*wfZ`b-QwyWz#1g+^5r_&K7FN`VQ5Bu@$q>|1L zz;~2O!z=>*FI19#g0JC0Ds#tZrOsiT;lwv6WSDMH!y;V13}N8#H&^KD1~LKT0`%`& zw$_*Tt}Z{YLDnK#v_Kf(bPl^P_}^n~D_R>nA$K$Mb=-d6M)7qvh;cgOB0uWNIu?B~ zgFfa8lF&INKtN){=j+=;pgoN(TqnzVHgNcz$-q@`w59&bg#ujqW1+onE8v; zT%rhr0*8im;&4$X4i}R_f*E>kgYrxCXq?7yHBocbm$m@f2}q`|F9lm^y<_w_g))qt z&0ArCzWZic$^S9EPOp=}O@XYJzmsP^v$DBckt-Rx2_EHv)mBT0wq4{!#x76^2cTvX zjRq+wNgH~p*AKgzS=5yS4O$OwGipvqKH6^{vTq8it~Lm2<9t2_z6RH{T9!#R2waP> zo90?_Pm7gVb7<=kJ2kbkx%SE3@{dGOBVMI8*~mVOSL5!2=KbUhS{k)nfsT=;N93;? zB?_h>Q5w2=d%dJNpvfqaS|)cBt4o-Ct;LN5LeR} zTI$O;$3$^u`Nhq%w}A=LHyVe!smjt)R5O{}2c z)PXwN3=VE`M`W~6W}6hQ#{{zMc0_neQ6mmuJ~7q#0esI`!01K`wT*pJ9N^ zjIv956vkN*8E>nI-~=e?T({R^t662dg-&9iB}k_RR2K_pHa>G$6!^~k zAAqs*u-FtoAU=)nfqVvkpQVq3+%_>VR_aX|_&!OH8u)nh-H~G#19F_SneuomeL`V% z_w?|aY)KGODw>D@k05>(EtYS{*+`KDNJ8#7^ja3n#BP4fNv_{N#jFFt?vHV4OWu?azf zcCmn@`rg}@RMbSUV@=4x#w_^R-4k*cEw-da3oSuW!>D1m<6`*kB^6e=O{fu6A;=xr zmsEE|j)pPcgdS{x!pDQ|5k34STN0$z{4A$CMoo~5b{rl=kvo-CWM*iXG$8WoW({`7 zR-)>TXyMC^mTDYYC0RxHnBF65_>H!r1{!NSaWH!BfE;%xtrCzV^%FV1)m}#vV|b7k z7nWJKp;u88!G1Lk4m2qVa&IPbqsi9fXgiM^HSAJaVU2T_YE`0{tcnlT&*i4Dx)W;n zf}_p&;JKW3Ebqnm;EpL4Xibl{let;NZ4l%RWfjb&&4xw&ByNhTJE4RxG}=&tr*ZnE z-@T!P-)3t{w4KNqH^K3|)3iZD~j*^OOWWwkp(lj#vwMW65f*1EFn zLKls<&_w*c2T4+oQSEwt9k!KWWx`qv%}{YZEEO{Fu$n6%9HWSU;j(!-aa*{?w9*FFVp!A!e_rJ{2*i`xeJ7gsjVd|IT> ZY`$=Ywu;W2?uVQD*eLyw+C^J={~rOy%OL;& literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..c12d5629701728ac77ef3d2c801cd2c919155917 GIT binary patch literal 47097 zcmeHwd3apam1n(Ii%PO2mu+DiVN9VILkr8;G6swZR7onSN-9;At4g+H5*#6mlon+0 z!j=x$gru`55MwZUU=l;<?({PKC4tY~nd!_h zn%_C+zO7W=>2LmNgX-OP-@WIa?Vfw?^3L1q3HG)o!>!xyy>DoAaC>;$uATSo+8MrQ z+xGB|ZM(J)42JJPe)wZ;xvr1jR@ip$;O(RR+qXY_`_Smnj{9zpr8cH>wtx3|Pnt?}+?wkv05HKp_MSa#+5)ipT>)Pe1T{W}M@hBpmv9UI)Swg2H2 z;pTPW&Rt`J;nnMIxn)Io^{ve}-Fjp5x*ONsbn}|#H7je{qq(GDWY*2^GHb31rw4X! zyBkC_uWDWeP`9pawkof>Wo6CGixd0x4{Y<`-$$*VIh2|=Pvh)Lx(Ru7ZQ|MS+V(^; z)|!n)^Rc#Mx>ff~JT)F_%;lr0wrIAkDUr(bD0tNZMS|U0EXIP?TJ*ZiQuAodpZP&zH}y*(&wN;Al;J($N-X+ZHa7* zE9;9V_W39Wc(moCEy>u#xEBILRz)V-+7<1HP3+Sro*u6Pa5H1?#Q414ST^0;)SB+@ zPN$kkKojE?N<7-cc;I8HU8AEP_kbau6*e!J2h5NnCl?VrB&j$9$ZJaI-9d#6FO#_( zWL6S=xnw%p7Q$TxNXlf>8SfRinWr!iZ2)q)fLWmpY|ateYg}c#R|76`Yt7tzqC1w& zEu7d_O>{py?&sEwE99;!m(TXJ=6kZS9C+f-r_yb)39!Q?ePW-N8r&GoCWx0*s3PB& ziFHSNjjM6v%Oy6)klJ^hu?)A~#%LqwS2RYGnYg;~HnvEvx3Sesv`Ip5Omca>F~e7H zW5z6zm4vS`+ia!QNGjNvi=p4-%%U63M6X#A2s6AuG?m*FleE7j4L#&+e`_+D%W*Qu zNulSdaer&NCzU5wv`3RUqKuM>R8-LPCK3tG(-YnDtc%KXGC=)THC2^K#9Ctvi=PGg z-eg)J)3bSVQh@6l6v|n269Ju-C%$YtO^}}&59VSUdSD@9Kt|7{xKw36)}3jhAHMZL zj0#|n0G!j4O0@Si<$79j1Z7_@$K#d&78Nuod>Ba9@jvN^G%s_E4ZT0r5(<~r*0jXVlw+7j*UF(u53OsqGP&utKtGs$SHP+yrz zCsJTQhcx7e3MrWfI4Q9FnOs8YeIR2uSRrW>6@DNLR8Q6jTcr0jWno*D zwkPH6ewBQ0_fxusz!)r-6-&tX^XZ}7H|5hjY;wLY7mF#omy6|lgt%%>I-62C?b%E^ z*~b;Vxl{`${20ZvqQ_PFXiq+!On3At8PUBYeU@T|@?c%ADc#-#K_y|S8OprUTqP=G zZ^RhIWrFHPD4c8FIgNrN(-xtfnTx>-5nTOw3|nHk=TI`$VG9V)dSZgNH=iYX;Ws=x z?xR6gMm?<&_xk$v6XR>Uw{0D|X9$kh1B2Ul3~d_=Z@VXa_x5cM?idU|SQr{8gtu-R z+%b0T&hWstu^sRO!}snQC`|108yT4F02?u}$`xYcjI|H8k2Ffo2hIRtlZ?&KzYh6^?%b4pf?8q<*b=3#TrT7i!sk z2$0EZB7uQY@+amuwx(0Lz9!p076|hjquCfnx6=H1jikFJ+50YMHW4Cl0s3f&HZ~jm z##WL|8*FK|hgDBn7oC(etcOt`{H0HDmSab)~&0of~+2zfUR4UHQJcygFv^&#cm;0dIQp|^ue|myr69CRw#V1EuG4@ zrZas=*S4i&8>7hx`a}jk>clhTKvu%Hk0#+@<@QKF@sYbK?qrahOY#pud4ifv8s#iL9$Jm)~JF9)}*8h%?HOl(sIjEc3{-br8`o?J$yn=l5#)v+Jlh)GI~ z<4G)ggVFE-6c5==rdv8;-R2t&n$h50GO@3UY(awu{H{=ACuis^{nMNlqao>lBR}X! zS2@zvj&!Xf9de}SOL`FykkrNfR!r<$4Epp;&S;>HMJm(8j3?EsLKY@%S?EoU)z+7T zHGpn+;z0np**?`LWr&%oOu#Jj z?jE|<>IdO#){YfH4k&ECCxx90#0buK3J!N@nLkB2;xgQUj&ovajA7`V52 zG#y=x%}fKE3!dAH4Jl0uAkY6GpvrJ8fx0ZkFoOwnA{U2)mT%8BQO8e{!wT;*o12Fs z3+y5$-k9yX@+}&?i;RY9wgDbRiw0UqQM(wyrP`lX6s8K(pXi?&nznO}6pntP|H#l$ zGp900Xuh$h{|z&zqHwJ6<|q1(4ZUgR%qeWCEf%(fioe&7#1ImWC-d>7j-JfNlRD>< zg?O@fEGvG5(7tNR@?zrI z^zwL}r`UySXPsV5FHhF_iYeT6*9D5{(EjxDbZuR*n69JL{JN@QdNHLI)>RkNODI)e zS6fVnDYdjNR7@|UR72f-KvF89)p_*CXYfy{#T`{EmxWq z!n7{tXksp-o78;9at%W^56@b+v77*E4eX$lT9V$q@en^4&_f=tW?VPHYnE`l!dPX~ zz$!ssC*u)l!8%l1Muv~1R&89T*H3)<8cp|k{Q=Dz(EYwS)io7CpRZz0u(~EtHMg?1 zrlxjoWmO=c5wTB=SL8CWR+=td$5d9^NReYy3*w|{Ue|MwrrM-2Qqk3G{LTf?g(YEH zi)G*~F1na!8*Q2znI_#=;SW}N16BS?P*NML^v}-mJ8)^d09>wj;L>_lT&`zaW^=O) z#~rv_&$wJ=vsR28i=N~?8dSnw;XtJAtca{|@_j`)(P0@&xSKqO)SAv(J9CcOE19;& zGt*Wxrh5wY^-QcH^9Bc*83&o(1}LO>gVAg@+BdIM6>e}+eM33CEuG3Xo&)h!<*L)V zAgd%+pU+W$_1WvMIamE=W?Y?vahx20Q{wd)YbM4o11@lbquntqjfKs%Z;xdGG_wop zSmVD^&HR4KHtR?H`!@gnn14_3?@9hW#lJj`c;4dl_xShw{QCp`{UQH;3o~Z2f#2re zpYSiuExq|DInT5aV5M5E6cV!f;zJ74TVpGx-2~=1|9;0PIQqt#a%{Auxba+Eyz#8n zd(TyUZMo`}5;v5ieW;Hm!vEY`8@oEK|H#MB20kKwdSj}6= zQiU}72ODkuvyJsF-0;~tE)V|0JV{m^cb$y@@1NKRcpDgj2i;v(Ujol&E-m+9glWR^ z5iJH(8|$3icpZzNZq!?DaIFKm*5GPx**G}L6ICsV(fd{&y%~va<5s3^siSW(EtbI@ zR`g(z&txd?+Sv5yZbC4$u6H86o{?TqD2MYrC(gWA;6S*BF-&4=ahn!2h0$%?#_&q? z$V81dq8u>He(yx+gXc-{?Y8N~rq4tF|0Q3&{sS`>~UC?JI<3G z5nBOxOV37YwgN<)42hhhfr27BIx%jV19I?V*|W6}b+!=Y7S7T?eY5*#3-+BAi|wsQ zyTvngQekzq(c)~s#f}SHD^{h-Q)Bq+H5w zE6eE@I&_<}y*6skQ_=xVb=`2TVI;=bp2fktOsPZr#JD-S&@PjW#+M@HfFbcj{e8Y`!nI;*QBU{DtWSuj*?uyM^k zX>ZE`%N}cz&aoz04kuI9d(Nfm-Q{Y}R}?u8A2{$RH(sT%fVBZV?sj{`h}3gBf(5Js zmaO70Cnm3mYuw9^CZ6f+T7Kk-u0s9h>9{^M`SuDKHYvhFv9mNh9Sv0uvLK;B>*;x%-X7pHMOX|(&(=-`h8*Q3cBxdYVZaYk3L^Ws-fn4(EN4L z!&gML=c7?A64mtj%NK_th5Fw3<;7^+O2!K$f*uUzx>_c~29JgzPuoD^KVWPGpt~a8 zy+gYThZjZ!<##54F|wX0JYGQdTHI+UTAOYrs+vGe%Su#2c5LiX0nKmJ zT|{CxI@|5*1!ewNHk;0N8;c^i2}IjEamZjjl5=x?-7V>4lX)t}-+_rtfKRnxm*FO^ zxuGYTTurNTw6}ddbL*-(dB7x`jD#8!;xv~>3F5RlyjS{xGb;@FJlH#Rb}da)*SMb!HOaa^w=s_R41$Q1*g zr!#se%Co{QqZji(2ebWAEH39K2+wS{R%!Gxq&~F2IC{7al4CeFyaI5bGG#yzF8W-f zuL5n5>^1|P<)fDkc#5N2N2^AC%ybq8i-m6)I%C#uY_?~n-mr1+LgJR^GxLm5kB(Dk zIQLcwHtUUYa!9{JP8jHoxH4aF#8V9q`DP9O-o(FaB}Z)o=<-N1tw*A}Yt#;jzII|? z1%bOmfm_cYd@%ZyYqluhd7Dg^66-OM2BPfx>+;z7dmDq9{p&0BVB-R)<+GKpX&}|)BSiNjnceFK& z<16U06XOfaTgN7{2gg638lR(jZwl)oWZ->tBtWZ!=w+*Bxotiee_3kdOh&-k^QEOt zZZgbhgA{XRHEb-JgT?0sv}Mzzuu_LqeGBm*i1R$ud~TlcAu*m^n(-kGT8_;lt=G*G zb(CqpXCbpBu4_kxBb~}f6Ep6_NOFP9(0B({M@4d6FNSKutb}S-mW{rJeBCt9_^^<7 zr)GSZ$Rq3Ci@!eT$z5b)XsnJ8&+JWv;v*-I6cY7))16b3zxEh+0WXK0(^AyX0b>g) zky&_!cc2ROQ<0IA)A1vT;hC2Yc^>bKUyiK!(cw5tuE4)<(AHF!_D91>zK!s2i0ezb zi*t@Sa-`&&-Eu9a0@Qf7T#oDY*s5G5I1xh}TagfYYIwF^{pOqJ)SV z!u?rdj;4Lo=-EOk&zJkCGvHWRj&EP;=F7_+bkWD6lDXa(Vq@j`@^YhxM_Q^;pzcNp|on4FWyJ#(fJ90riRHR^{(Tp#fsUJ}u451{wih&~dp4RJ>aMfmd0-jUESMz4PKbEjrSJ>D=` zb)4(u13&tbIYvL}+TDOWpQ}cAz=He2#^-L}>H?ruSPtEMsyHyQ-@kEqYIr&kJ-v7G z#^EEKEx0ZpKHAla>*7RDXHVCu6Q@p04Q@9@yBPRxe7$|+l?OwmJ!W%Gd@KzY>yg{SY81VT$KIK38u=||g zb*_nVJ%L${-ie8a-ql4MK7g}JvfX<{#QX9gZI0gVS=hc3C^tj;kWdJ1_vbEH?_EXpTjj@$3Ka|S>WAH9x>vCgjEiyGe z;-WuBNf|+xP|;to8guvj8&1xrTwV&-Ir$CFWutJ^F7SJt^itV9ob){`7v7E4YuF;_ zHR5D=r9E_9U~~qB9R#FOh25%VAgr+Wh*o(1cC^a0$Kx)0JRO-LD_saBG_tdaBMJRz z7gB%NC7d4>ck_)d?N}1!x}WThFD@oWPQKZ#A4|P4`O8jMu@4W=Jl9!RTv%p6GRI3|!PTwYAqPS&NQI_2nZrfc7r{MqHjPW@Pyezg0@!gOqJJD#NyZ*z+Qb#6#&4#^*T9ZEnIa7ybKIk#-ft7ZQlv)bI zQ8x?thjbX~Ln*8lw>IAmix9|Ry)d0MYVL%6hI^mt$j8OaGj3#oJP*DeFg^_%9#F^(U3OH0jrz;9LLP2LK3OF!9CnpLx9zo|M3OEcAnTlfAW%k@P za`G-EK2%DLoJ6(ZV+FPKI-MHTySe;Ze{wm~%A^%}$dljD$Whel zdhhh%NWAMcG?c(^LotqX7hO1V5$}9$%XR5x>E*8%6DliVXQjjO&ex0Sh6MfAy^#c% zFLotQ9!;8>HTkQq@~G@Z<~+mKH~VF-~-Z0N-;cy?o1c#q@P4x_Lf*T{?6EERLt=zm{HnDnXa} zQzt<$=hREi;!`J>_Qqm*{+1PZblq#|@X0MJ(~apB!~m6_p!^0aKTi4AS>;c-%2U3S zxAK8Y?Fry^Xl84A`N#?2d}t<_UYuTXDqWvm%1GgEDcvn$gwkPfB;5d(q?e)mvf`ot zdyHn4g~hH;;fG5cO-_vaajqfSLH0?@laGRBbV{d@)~~sNk~AImwx)BGmWjaEC@KCQ zDX~T?DLy*2j~mZFvR>1V=d;KUVA6@xZ*=B zyx@Rcpd8*@(5Zn=blU*0>}Tk9H5Z>GtE;s>5lPJbYf3d*sijZcvD@Q$cw+pz*!Jys z`EKRPm0`SS*Z**M$Iv5#JQME^-?!~SdPVP^@XiOftwfg_LYKQX$~G_(im)CX_Z%=2 z8fNEvBILnNP5w8JG34&&>gA|$xUlHg4OQ%$8N(C%z2R)+HS!YTr}qwpa*@QZp36rQ zCtf2nOK!kFd%U{Q>h)rz_hEB(7_Pe0aA9oMI>9-hHv(YGho|DBq4!Q7{Om|B4(DOy z#MI&1CtJuI%dz;IWU5eXA58t?l$Nfor+ZkQ5S#nZvB|%edeP34c#^Iqh>Kki)3qpGTb%p_ zd~ICG_D3Hl+bX>(msBI(3X!#Mi&1)yeOBjCvI1)W9w-Zn5lz75lF|#x^Ln zQ(cn2tBtXGV{CyjR&9*2&fJH||KbtS#F@Rrp^**o*JdyzvNHaX4kO)S+-EO+qXv+_ zU(`&yBLa`~rYL@HFr7RMr%yz%BKyvlB6?JBx!YH~TQAa5*eSEb;T3q&!rH=PFBRjv zK1?aGYUQZ&azyhUUJ<30L#!HJO>m{?;RSB!hh`osgbMI+S?z~k<3Zxq!)qd1%N4zc zFN^CDy*_FKJ~We{`UJ1OrQX8v&`fhFguFnwoFH&_bV2cAFpt(Bi5~5QzC`q{2xQn& z&&0qyB)YJ4%az_R9iim(;^Gb05PGND+csuA{+F#u&i01sYg4Yn_7TobpeX*G>{D4Ze@Y7lUvydbz2%iBajz^ zet{ZMdiBr3Nh;|uwLUCt0uWuAwV=Xw7xlU5nhI{=z8{4 z8V?bFjE4ZCJ9>C+R1^L_GaS{x;KK`s(WOOdVm3ojY)Q~+w_5J54@FFgL`Wiq&@j!~ z(JlclZMWBZgYi(<*i~;l#?3x_2FxSTQ-JVr83+!{A7K!W07N)?cnK44t(^;Y+?CN^ zJqDGXjm%;LUu={hvT&H7LipjnAPDpo_sYS_tSB+!sK6ijNf&u zp@z5IwUkem&y5wN8J@?N$VJw}4JP2@SPALcRBO38lZ!Tm;O9)h%{elZhp*3$&Oi1{ zZ;ZTlqz6B*jhwub<^UKkaa#5?#*lpCH4JK8?pL(@(T3%Z7A$|P!}3QfmOpMVK91!N zCpT@!2puh?R=}Juh++@Vy_Cv}013A9YIm$t-KZrW(C1z59+1zcC*nmLxW^r_JRjrr zUSEYb9wg?J> zIaqK%bc&MIJ2+@O_+jJ09#*eC8RMatq$0*c?1_2y@N~noTefz*E3Z|IgX)uF?gkZo zk;6UF!x^Gs=5RPdd!D8x!QzlYtZ;a}K9E`|pTSJ>_(gd2Bg|}Z8a(DAK ziD&n6W7pMEc%ia4gxnq=M>}m%?*TG$`+yZj5j4hYm0ZFN+l!5VYb0TKj{^i19Cz71 zxI^Ra;b}NDOO)35`u>ZOFnSyg<1DtYv;8UK;YW>!A7K3V+;2Q`kEHsIM}%8@_>}|C zC-gi$@UD!@g^VHr{sbmGSI!G-QFhV#rXa(+Junk;kF8P<<~ZHD$G8!yFYD%?&>grK zYr(=k{W1pjNk3nn09=9o1iYAKk;CDP7ST>*Xz5T{a$V>4EJF_0Lx4X42gm6d_j#8X zyA}yp?)xktf&NM04jQzTvV0SPx7R}rfe5WfwY1qB#X2#HJ;&4)Cx4RPTi88x=iaVQ z#Pd+l`i*hg0b?V;;Q&WUhiD2svnxUKdh;vh95N>pInSFEAcCXhN;4)kU38MLw>pk z<5V6$uZ^6baf%n@TY%O&pw)^I=?08QZ7lasoo!Sy_dCt_0sB2(+L{1D-Yr1N(Pz$Q zm_ZHNe35s|cr0T{I5sYox1`?3P~!u|E=o{SG$c(=*(dtjNdT|Ku;@w;Z>EJ;*HKHRg@}et!3cNGhQyHwRxxJ|bV0xC zr@FeRPka^&7jIydI(cOBA12?B5#=*@-`HtUl3spwR!_*>>-h?7r<>aQSu{T{f@aX8 zxaE5GG70g|;?D&J^A|H;aQ_@CU*I|b0r(tDy9+SZ0vK?;TzGZD^I3T(n6Qx6#?jgb zFbpjvWCd5J|G+E@MbxM|?na)EsOU1}Kgru3p3h5v*RL|+e;)8Ji@@_>*k%(JJ3jA* z$jk47;^$=$pe6;=Cou@Dj2>>J!%JfR4=>0dt!@}TtuUyW<4=Gz&vl6jPrB#3jJPcJ zdjL5W1Rb#mCLuX>SaBWl2Yw9DeqtLegnMv{RW6Y zR_`y#h)3}L0#thUh4)<*zTi@Yt*d$4@(N>X$k_Uys=x|-iQ4}kr3!mtf<^|1Pd_s_ zs-K=1QS9zPc)wnQLbW&{)kE+4 zH1QcsM&XzGZFn-5-hD?v9`o>}arO1cty8&e=~k|$AnJV+8J-3D*y?Mo&_Ha1U z|ItC~COgOqX2N85PmWXJDZ4SF73{%G{puVeS;&X zpBt7vmEz#=J6|4wFmh9IG1Tr$9(%Njy@@@AkhWRQCBgfhp2T7XTT<^)c(!Ypz^A>s zi^u%7ulJbE)!RiBa-8%Jm(iX6hgT9$5ss!cn`l9}L&Qzum!uR2cy#lA(;8{^!Mtq3 zTK!d1XP{&HldMtG3HIIihgB;69?m!o;a4wGbuLuriPz~PoQyZAL32TSNr0 z9vvr@(N`G(KD^-lrhdIqvD^rH)4*zJ{J6)~)dIIP9H}jG9$qEJT25n6YEuFM5b(}* z9??uhGk-~*2u|8ov?kLz1SI4Y6fA`KI+|Cl@lu$OIfzBm6U$L_#ytBC-v7$Om*;7) zr43EbN7GDc{J1WYJMxrUM+f`Ins(jC!6tXG5e37&KSl$)HHy=MXn^TlOrx-o{%A`& zi__9q;q{DcrlYAfxiTN?&Fc{;e@KPFX+th!NO2Y`Ka|O5<2|XaW^p&3L0=EhVOe$~ z+F8)g*as$osM5h_fvrl4Q4(Kn$ac*l=mNqcn4gn;f-y;41imD47VD`#B#LE!R&Cl zN|lh8y}hRy-n%8Rf*l;9FKYp`N&&JTfh2S4iT7O-oYfLzPemN~nAM3+Zz`Qv&3S(- z56Z%*QaF?Y!_{V7P{e8SIw_%3!WAv)G@@OBk5(hVK}S##Qz~Y@wr6%0KYPi_M}ioQ zNO&eVM#OB>yG;sISW(jiwyThjUGg$~BW(RpffRz`NIi<~1Y8sCP!NW3ubEG{Qh9Hh z13I$)=&PH|$1YhQ3IbwWW^zsZqOYdj=%rXBq+32fsWwaCoQ;yJ1ZePGL%kS!N)t3H zZ2@Lv+oP>{1(m{TGIJ_9(*dYSE2$P#dXAbFzJ!FCZP(S|0nbwN3IrKTz|NYrnK6)n z;*i1u$2g-fQ5-CcI!t*ror5T%7^e^jO-0|NRXt{t?9>TSI1xdwt|~HoE!3j#4xqM& zQxOM!q#o4@sER-;rClX`Ewf=!0sSRcF)4@p+!yp0S1r`s$2@lB&_tM&j^Cfg>)lwoLPXaI4Qr#V8%>X>T2aH z{V^*NK0bt~FmBlS?g*2Y4Lyr{0&4eP*DldxWQ|J1H=e`#N3jJaz z0acrc4rxj~bKQzz@xADT${@fnXDyk$-{!!MpW2;9$O4m`RH8f=BTGQNv`T`oQY>M! z_X)nGaJj-+@tB32?{kjEoT>sO9Jj7w7IGHP1?<-ZEBd7Y*%AalJ@cS12uod)eI=j- zf@NylGCj94Fqd6E0)V^RQzM)9Jm<%)J{!fgRrA2b|t*acdz@V96iDIn5YZQ<%UD)h73M0IPB=4NCXkC+@Rb(2adp(S2>@h?8JCI6CgnOB-9nj$o-SfHdX|C)vU zc#VwPHw%|3WAV`^2lXGLGPYDmtvE*s!~N7m#;gne>@KO`#GCY(r!l;|Aclku03K8z zhGf1eIeRioEn4=(&+A^k7b(+HUuUL`xrv)aU|B79W;#U9@ZG9o!Lg9>-709%uhp&? zH@*c`K{~XOz}lQ?HO;cZRLjq^RhoE|N#lD8O%xWG?FOjg-zqGK zh>5l`ZI&`8z3*yP2P;L=`&+Xa7t;v?;5rL8H!nVLTnFQ}rsdGYYdEXXi2 zq!VmTMHRCY#ofUROA!PntFcA7#Ya{wCbC=6=-=rC;>z?he@QizRJfwm5Mw2te~Fpo z=Ey#Gw6;;55|aG8DN_{BvKTgs3r+63hCsp6dSoKHkm2(%X;JH!OmhhIu`f(dnKkqJeh>+*7w(l=f z$1@pykiZi4ZE=Az`NDJoA615Kts%i;mff?}G}TqCEccxgvDw_W0lJuDV#t{$hAQ(+ zmcs&mcEe!eV>VGjh}Z+SNwfrQ@xc!#K|1t#qb*8eAt}AOM12`PG|$g_7^Hn74Yf!n zl2#XN zf-v*TYbmmO4TIH#j)tLhx z7hJh@!F6!Z>P1e=Yh_w6y-c)~U$SsR`EGp>UH2PK@sJNO$KE5FrBN1}ML@q5D(Lr2 z$XnJ#khhhSA(S9Vh22P&P-j6Czht!Czu`|xJFh`7wGkxKaQFhQt6x#X70c;5vSX~$hiraJax zR$vxSqJuv`XQ~}Rv7KM5NjBJ)+bbyhn#{)R?qId*AdUKw+OIH4WG$wARjdSQA;o%1 zw=NMgg?6Lm)~A)D&MOHn1h{Ug6C{i`JFDpgF)v^TE#w__#YMG9prOR^)HEY1)9R+O z)lalIL~WU1nmu3J0S!OK*!u~nnF zOI|LX3$d2arA13sPOk$3QCw&?u}VJ3G|QBp~Z3sQ&YwBiL7S54Inp>9oDEJj)hw|X+2 zXHdhE@lg-&F-t3gxuus%GJz)geib&!6CLtRsjImh^irywi6^{fAk|`RmNU$CP1*y0 zETGPuIcx9=98^s5pES`Z%U-kFSmka1w~U+#l*k40O6-jz2F}q=9HQg{ zV@W=pCTA{js*m2{|B;8FdiLW0zxis#O~xW#wo7v67{)Kjz=U@i;a-?$JJVFk+gL7d1o{QKEWR)6mW2to36E9-t|H zOyI;^MFwH9YP()9a*Qs7oIr4nQ+(L|TNHGo8kLtKj0b}r$NNI@#INPW z)?aa&0)+NDoCO8=fAXr}3EJ%BR(U7SEDFaSqol`YNMBR5w1!Ou^N8#4>_>7fMio(jrlqy zKV&C)mBaH2<;LyY^~T33XN@sT7r!xpi|4m;`L$gBUM_zrm+#Bv8*-VF%OA<*Ww|^j zmvOo5F$O&RlHLHK-9LIwd;ieruI+;>skx04yQB!`5NTm1;$08C40E3q&0;Iw0hBTnlmclx z%*5n3@l0wVIs)FMb3Objm8Qz|DyGF^DMEGZm=u${DU1TWfzD_FC1;QVyljiFsP@F@ zOTLIz&Bw?n?Y~Egw;CV4mQ!D;F+R%X%JUWN3d-@-o2OG>0I72&h)BVF>5S{VfX1Bf z3-#)i0+o%wXB>}(SqA{&N_sW2#9;NYx=oqLAJ9=l1t*Yq{$7}ixU;&s!RuRK+7D|* zX8|=>;yc*OC;YU`x*`)QXD8vaVhNZ&`l&n~t`p!1zTa?VN;7`LPuoz+zu@H)I`}0Z z&Fw6;L~8kB>M8RTTfEjN$@yw*wSfHGgvKLp$x#S_Y#wVeOUgbYAjq(5AEq$zEb)VA zyypQ)2(?E2@_3g_OSqyegWK!6x3VDI1S>xtmY&g4dknWJrJ&avm+(+0y2VKj?O=xS zCWU^nM8{GHEkgNU)cF*=Z-MY~fvIX=1k_cLk+)tDa3lPZqCKD@v?zys#Fcf=euvTX z#aS&amzKN>S#AsF(Z#z>&hA+aehEVsA@sV695p}s4p{(x{UVC*nQg#mrWfU26$y~j zfsdlOGJ~8MbZ1s^W|cd$nltfkFt?##)^cX8J2S+YA(eSt=deX_WsQmyl;|A~yn*#h z=a(=JJ6=*XLtM!x=!n8Ulwxx!{i1{>eNrw6RQj;du)}EBYBbzsG^CA&gwb%T(Qu>D zaE;M$mC-QQXyDH#ia9t4ujew1MV`n8LU2HWSkRZ>@OJlln1DEtigIfQ$vI$?K)oie zu`lKM5-<=@FM<1I0}~UHFWHWRXpNq*D!vRo*^F2J5dXly7dED%h+P;DMTTb%U&Xf? zUX8{xM72Pn%NI+0tY4wTR8*Tr))B-`oPgJu=)AnxMPb5@CUivcIg*_2nwtED7~_{Q z96C74ajH}dbVBdTKmoyW0S~aAPG|%LFY{2a+;;@Pm)+qhN&&nAKBhS)Dg2e^a!|BD z5m7~Z60f~BJo6{3RM3yZ*Q!J>Yy9TDosXkERUAQxBs7RPH&gTiO9U^k@cYj!fmgil zSF$^Ot(^a<74mqw@$oB-VT-T751g9M8n$e7p?b%rlkpkzR?L)yFeB#tKEjxpW5IRQ zlK%YF+~8NOroICHomY@Xg7+1GbIQUB)X1<8o+U`*9;Iquo!C!rqkH}|I$Aq(csU0p z>&;*J`|*4|-lpFqacS8D&^OJmhkG~_8p+XXd6`uNQ}>qHs^+qswL>yidgw+{hO`$&Tp1j&YyT?gl_5zgE7aNZJd-Xtu;SG^T31|i~#zb%%@$2n-} zALc8eL#eliG5pp)Q?@aHH|1nQ`D&jlqyH8EKemZPuE;%sCA zPm%ID^EUn!;Oq1L(WivoPkDh)p{u6UXmj2 z#mpJV|L2H%V(ok19<6=nnbC^)k9HT>2AnPU-t7^D@1c-A?%;dZMzk{mJ8K-i|NF~J zjl;(*KCf7O>sS{!7N3lehe#~aPku&V*sHJLc$E97Y(@7@x_AyHlEg-j%p~ zuOKcTyk~9EhAH-JH(a?l{wYqy>*bSDFviu5(PWZe$Ia#%F})e5ujVCE@`i3U+>%Xi z%EcU?+4Sh*TfNG25||=3>3aSa)ZOo?;Nec0Y>I@ZtfNGnrqXP0ueUvIPL-}_vE*f0 zfjyiG3YTCS+G~tOA!Cso0rmcc7`|8MFpGA{0@I(1t$kGsWPTnfU*(ZdfC z<(jtL=ox0k`0`e|=wo;B-AlcEna)aPQZjEdhS)AUz9=xwJX2p3*eCw_xLkI#+itqj z(_rBi@rb`DE-={eAK?~HpWQ7!f)}#q%nNyBR!DOKXmeE~-a(Hwd4JR$ch{GKJA$vuP|rTNyB9X+poSoB>c~gVuvgvw@E8 zm9G7it7|I?y!q9uhy?%AVfxe%K9pA+9`F?l5ZCBdrUfoHNx)-t0^@cpXRn7eqVRA9 z`)54XQlwVL_)c9khR+0`fVJ49=*c)D6o@IZ@uiLV{aP@?*fC~;$@8{PhwpomIvi1$ zT(GfpFi-Or2vqA-qW;uPCdKP4q3- zGFthjXyu!tm5?c&Rk(PWzH(7AeF@y2t#z-sw9dwm4o{Sm;@93kDLN1;E5$cOieDos z)`=A9UH-mVvV4 zrA)jL-Q1M4J3pe{-Nh?k&hH3w9p@(vIfI)$)3>Xs#5X3!uYv|SzF$r6LiaVb;3dR3 zeF-(!=-@MpNK1O?OV(AhJ{L{!zRmr~{2ukIeD@~*9@Erp1)qT7md}aXH)r8S-;g>V z+`QITww<4_rdGds&Q||?VtlEaBbjvad>XB0vcAi|Z}IQ<`1kw#`vd-!&vpNZ({Jo zI`uaeDg732%gl-X)=^m`yk9kW!TRLDV-|n=g};Am=~6%Qx2Jht=?)l%p%%b%R7fb6u*`Q|8x>acX7fS$JxzAh(sU@m}&vs^e+^R%o`rBfr zzHQRn%)Y0mdQ9&fZRW*R<-z`|jV&Vb+;g!+ziWe;MKt3hg#W8WIA;>^!M4F2JGbu| z*m<6!E}@@>_SLiLKQ8nix9Fek%Mu1(XWRdtV}#ZX@-Z&TX#VybJUA{qc+bUy3e$^KM=gyhg#|0XxO|V%pWIqEMC_ zvfL@;do=tBkPb}1?jZFD&ee325PVG?FfK|xf_(Z#9R(J)?*b1hyJh!0-SaGt%w zJ*{rflFPMvRo2Y`66beC8{jL@_J%j#%>Ij3l^Ly4W&sn>RZRC{hc5Vx-&J&%ZWOJ=!CGIqpX)<*39lK-xHC1&k_lHNhKm_=FW2C1&d_0gQK=cZgh#nZh5xP5?tp1aET&u z;8Ip3-xHCnbBW}8XYMR(Ad>BL>g=A;ZDYIc-Ep3srK}ZOTgHlgUj*}gQ!s1Ty&=KO zEwy4T7c7`N9DKC})8Z10-7-5CE@v{>;Q(-nf^pzdRxsZe!F0F;^ZoLIS^GX)v9;MU zR_q5NnIBk^5pTmS8L?uS3zkf`gR!<`GA_y3E%O-fmQ0TWz$Hq?flFD*{6Hkr!%F+~Cq&&V;=!a(Ua5 zi#6&y()ioLnx{ zf|VCY83XoX5y+2Cf!t_~_6~uF0sHg?3*?gye%c*HeMv*@&f6`Q8SOvs0C0%{ao|!` zAU_s?eBLFHAD^+KypQ&)oD+6J#DXPQv0pb@L%qM$3EO|cV%g{5sx6lNu6|;-TxO_$ z!2#eB#p1xFtXNKnSYB|6TMKB?38R3B(%c9Rd;i zb@+k>@~VTMwm=TMI*Q$LnSuUw2Y^fLC=Oi83gnas~C7an7#86{Igjsq3=Xq%%X4*rzyj1SZ+~L)cI_n{^a;N0Iux=6!n-KV!$kOunnxV^iLmW$7u$Y9Y&-J- zj0@e9$Y&GLRL5+N{Zu&iQ;TEbS5=NKtR$>uZz}lLl$I59&1;O{=AsyZR!lHu_2;L; zh`)9*;-}md^LSx$?4#Ul!!`oL=#~H46~6s3K5tEU=eGNrMh71l9F^~J*lpu0tIv)H zGd+2H79^9K$E${a$884x&f{G~ueH_F7dPlr?b$>}oPr<#V(;MgZ4ZT8w{5>~8*L74 z8-wgBzCl0V#32&YAwZtLrI+6-v1QQPnl$FnL6O>t@rsUUOEwWp;yi>|?!V);0({P( UJCneNZQAkUc^=h+@662nKe38Q@Bjb+ literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~1~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..d573d51789b6139cfe76489e0a9bce245cdd33ef GIT binary patch literal 44664 zcmeHwd3apamFHWkq>^mOWn124V+vs#M_AaFF_^tdQpr_Psj6I6@|JXnkVHxgHu1*R zfK8kQB7&D-^n#m^{p-#*9ob16$;MRDNhX012#IaT^f%oh`I1S}Lqf(qGd<~HJil|! zTdT^p4C%jSznh*7t-ohSe_trKvwwSE&wa~6&1*s(JGbu+qn?#AZpuc>a2 zWD`=QRb)ed-xjOT4emnCD{ox2;>J}gucdpbA zAHk}&cqYn)wdtb=eUt(`+H#SWM09jS2mg^&nU1t}M%G404{DByL9@ z#n73u`Jk+dNXjNsk+vy_Rf39iCY9D_A~M~qR9YGMWPMhFHgGmeoUZod(dPgzQfsZ$ zT)Zoq$xa(RIF(3!a>UQI8S^Dplg(wiTXWr+Xclbn=aQ+m=qNZ~Q9F82rwZ3cGI3%b zWva|=N=LgQ8;vUv@nz$iqX->bYAixjZ;Ui@dSzoIk&c-Wy|G17^~P2!&?W(`F~Rw@ z#x%e6#!3ye^W>q!mc(gUj zu=rbm;}+8@(%qXkCj_{*&O|wbo*|$!^2L`)r3ms9BY|vmT{n7u6v$}VBT#G-#X)yg zsUyB#SY5#~VhV11yNCgLbF!_;Y&-Ob_P8k?Yg6<;*WrsN&D1IJ48OM|qCOr$D+b-rgQH8?!PU-I&g0*9pq$ zM5I-yuS%!lNibloROE*UnQdOdL4oB@XXB>aSEQW^DB2@OxD{p-ZZCaDl^dy8MGS%ooYs!BAK-!k~6K8 z4e?w|I+A>-$#f^(-LHz{PCun68jQhmUeSacpFtlb-jqx6NXhBGY&2@>y=*ksEyPXb zpt~wFr9G2QB{p$EJ)3OdfFA>QM&!6A7wOKW5~;PD%r>I91bwz(26JFtwkg%#goa8$ zQ!|w5#i?dfA$dK8NLn-Iq=uOj{|?h&##S+tSN`!j%_`JZhzCjmVq6xL4a|8&rqm$ zU|a9b;ht>+I|llrJaPsmZZ>1;UKRNG6KWtvG#pBgt-2^1*q` zCPD-zz$O}^jm<`n(MN6523?xzX3>+{MJ6Q-?P25zf9Vq|SD+}OHFi|gixXeP->vMc zz1df1yxCW0Bzr)>HA`-@aI=}&j(YN%kj;-4U^|MuMjI3TEYPj?uvk0>5;TaMR0s#rVyQhEj;2hAWrL#r@^&yguCT2WIVGWWnCCflWvMiy#EIK~K zxC0+5keb+U`BOnOFaUeAOmIo5X{XNw+fn zcLFAvg!ED5=rEB|Mom!v1GxfbE;9H`C_W3y|HSvH^4(^dna6MC`PZU6#7r|!g_Y-j z73Co&n|Ug&Jbx<6L(Dhx1gt#&R+NVt#mrM><@w)5d8o0>JT+FHcaX>Ajx^$KVeL6E zTti<9L|R*;*=#C9v;A}?+7@qxMZJ5sa+uq68fNMh;qOq#mpJ;m%2ROCMp!)HuBNCO z`WLH{+0YZ1zmw8%UQ$^3ol8^9fP5^(5Q52ZJR5`Ym21y7QBO~iF$&8ulcjZvnNAi9 zQOx8$={C~(G@~KFonA4qSAjiA<|<&bQ2o2g{CIxiqdnsT6IT3q{=`Rnjt`tL;{io^ zeoxQy*4LBy7e3l^a^MAtPs!h2TgcxYEPSE|fdK^U^chI6qx2a_uXEC8BYiHV&qn%O zC%qo&3n;xF=?k3ng-8!k`a-0Kob(2yFQW7Yq%SIbNKr1oeMuqyWNJyQPAPQa-BG6% zQcDtbzCseQuDXgsDtIWhBvo4%D5UBrG^4JjkeW-O*>zJ3sRb0Oud6MjLKIq97c8U} zQK+GA1|XTut=1{pBj@m++2p)*w4^h-Nfv@w>mbNF2XD-=@ieuL9cs2itL)IVc4)O7 zx(*>938}i2d;jPZGTvS#A@}LrHA(MZXo8bN zYmG%)JDYg0YmdYez6FePE5v+?(crUs+_d4TMGI#$p?Asr!5v`UQ_ zfaw9tCElg##$pww1uf9C29b0 z8Rsrz3Bgk5lV#!Ph4I+_Sdfx>wVL@cAmI1g2J3)J&_Yt*)+}R#j6`p%Q^lj8taR z(N>z+EM>~7Ol-)gsRc<=FE78j2r?_A@y(=Wqw&7UP=i%kS{`MnEgou^g!K+3jZBH= ztMmt|^okmP74WYORQXF&{4OLKCxgV*E+kqnh{V;5L@D#iFxZ8})r5D9^ctq8p^TgkS8vgje0@F0GznYoA}sA9 zOkV(56FV)E$wW3umvFWBayOmJOOUmtCewHkY*&<&rDZvmI4u5Nr0~iM6kc_)!p+Pl z?!46Q+=*c%=!&swbYvEgfK3|diegDBWUV=QV!*gr7g< z=P7=k=I0rH{*a$9^Ycgie1)H{^7F_1{61!?q{V)~&)4}$b2>d2AxoAP;O$VW9YR1> zJ$wjZT50rQx=UbQ{L@7nX1-FUIGt4qq-jgFSTNTXj@Qn=cb z7+LVYNb&2b_{G%tn$eM|CQ#lva4T}+qw4AkYe?$^Rr(Ja*8a~?wQIP>P}vTNv3U@a zQnNeW;8e?76Hc{yJy&~=w#KD&saSw3j&HQV6$Ql=86Cy1f78AXM7AVK?pJ^McNsghob3te#9Z zbTo4z*bz7E2*WPh!+hQz)`Cr0lbOywom0>Gx|uMw%4l)d+H(F{tG%_h%90a}YSwPx z{wJN4xzc3ZmVOR69ey#O|}!={}jLiwzgWdn7(KFQ%fCo``>@qjSmey`A~`%@Z+g zeC${Cu*&N(onGhjOr_O`y1=+Yr&VV4YFac>8+p2~A=_aigPN|MbPa%>DS=*R^r!++ zCy3cgg_tc5kuYr{fH?qMZ8C!>4{It>N=Vaqhp7C+CrW2Fn5>{Kx%@7)@smg9t*%¯kRY5>dkuRjZ#jHyF;>kH=#33Xzx-j^&Bv z-560db8!e;6Dmd_bse?yVPic&b%yo*1H1D_>lop;M}aRV?9Ln?HHa4?lM>RPXPXu_sxrpvb$g!rSGOe%AmG3Po&Dk5zi*b85U;I!p0tiInR3L%SIT` z^CG%I?A2-%r9K!5&+k-f1^Qp^==O+HDY z{YfNqmARO&tsXsCN#JfX!QI3le9+RAYSk#CRIc zcIWqeHTQcw6}dCJ!)8HqoUw{nQ8Oo4%ouuV5uCj_C4-dmgwfpZM{`%Fho_$z{x`I3 zuhqKmcUl({l_y5@u2dU|2N*iF|K7WMw)8bwM~Mz8v?Yjt=(kWaBqgkNNuhKi;*z8t_@8nAyhZT?4n7m6{v{&XnR_%MuW?C!W5~IrBN2?7;cDh zLY>x{W+m23XVNA@lUc8M3Q`j>=v0jl6cJ?}kU6AG4{PJ7C8owiy`l#ZMH{`EZ88*L z&67%EFd*~qyr@&nZq&KZdK1%)s__@pJ3j~rvuX5;4W8Q{59Z_bn|F612m{?I?o!mEG9JfWi(Bot}stj}M+Z+Sd`AM;iRZU<{1RDvok^eiMR6s3zEFKYEz^zK3^NskwmdMt&H9Ycv&{dgQzjy<6m zw^tS+SiOUYRMoW6-9aJci|r(9I7!sP(a+z?uP@w4FD=iqt9-uM7`R4qhm7t8l7lsZ zs`>_uhCZWVv(eB^>)<4=)t0zg2b<2@w1e-uX)$1zHZARkn^MVDQ)|e&wOYyaSZzC~ z8XuyD>On&-3F}Aag;i_p8;?C1)`nuWK}cdSjK|yihk}C;#U9}58ORm=GE#OpgeOD! zf+jYX^^awBWsD z@I+@T-gD#K9o?O0PMtY5KCnI)`$M5~=+ud^Uv~_hIzIMBeCX7~*h}FJwYldCu?;~y zbHh{5?av2uL#KKJ7(0B%t-9Y>rdJrt^-ALgJz%sNy*|Ih*qcHgHi;&SpjWEfYnA>J;H=`Jr6obvN z*fcTO$Yzs2v=bF{tTq($G<{#OdFZE}^E0E5UK8?q+~{9#^j&H6)l%XgSlo6|@OKJI!W(dAP<>c8|G~-9&ht6kt9WSC4LsACGG%I`{1vyR(zHJ51Ko z^PTF+1afqZbj9Wty0nvtq0`Tg{h`CoaI$Og+*2L-xrGjOY*E+q9qJ2-p>t0sHSFOg z^YaR++L0s*CN(6Z;IHNtI<*rW+VL@CY*m~qTLwM(vCe$Her};tjU3OP?4ar%%XiiP z#mSDL)5pjDND30A#(qi)`pCI;ig73Op=&r)lQ4_BxcQ!^Qz#!uV(qZCc|AIEMHUN8 zsfx5YCg#t+70luN;NW57!(h|=Fb%mc^QKuiB60>cz-EJ<_^?-}sT*-% zpA0@aI#SUEJsZu`F}#JEm_Z>vwxV63YP6FNjnZyhfr|3d9@-VOS57mpJdYLD-gh2b z+_cx7$CftjZRfFtO?%mSY+2LZbsk&P;qeGYEgCzLL#JOzaxXJO=1-JR1rzY=L)T|2x)k zEVU@Lgy8&VcK`fz|3S#6#9-s=+i&GXBhJYM)(u07f{B>%{ z?Mn-(rAdk$NG(kTPl1K8)Qn@Pxo6_^sy}lYq;X2Uq|7~Yipgv&q-NZ{44;-BONCCS z8dJ-NRx>qDsSRdoj8d1{c~80WQmW)NQ-MS6Dd2SE+;D2i&?(@0?bb_JRBRc}mz5x_j$AbSdf1(2jey zUW0BlfNpeUgmqUq7-mE1v+`0gN!$|-vMu)u#TfARTk|5x2y8m^(}o&0Zj8avLwYC^ zK1Ks|?Ck!5U^X28{ZqL}{M0d0jWiPfR?#)1Ro5}t`mmuk2rJapHY$c!wFA5aYC{0F zcyK&69DL{OzTJ-vWn&n?hfa-;{b4XW?0>E>J*0()Al zAjQ1z)164qW1e5=8ajP)?Dw5eYb_^ZFOa^$_k*e0v6)FVRa;N$T6=*r{g$#vI!<#J z1-!938%U}aN~X3j_FJlr^mODAQqgReeq1qzk?b-*L@h&Nlj%q>p@Z>s7_L3*)M*75!LCBRqYCrh29E z5p@>h@-3=o3+j;x!@fQ7U`*u+g9bR5Fks`_({{Xne%RQGB8#`E%giB`EXP98!xGc2 z5L0*SCw%jbEwha+(~T`tjV&w!cVmJ%cZlTb-2TDf(7M>Mb2#0>lJyoH?pR~o?W~HT z1aSU{NR4`R_zOqWh6o<>#f+jcZf_V1cyE6$tVOhzJ0iZq9a@3bS6(*_twwxkfh5Rq zNSP3sh-0pVwUCxO?EGI1tNPKU5m|RSdKm$woF-g5+wOcY4~r2j7(7NA{l=r$hSiq& z?Mk2oNqE(s}uRNqo>*L39EEuQj8v-}(?kN)I=Fav{Yr2cs1LKNuB4S3>UCh1;UDIy70d7Vak zf`S3#BP7#rl1$?+Q8d{`QQp$lNChg7vKXbe8Xt)oA6a93MB{0f=BwuPn@DRauY9_Z zUZ4K-ZD_b{XzM9?EFFa-tSPYVpER}=tyHIbr>C z+`>;0GYJaQn4aIOeI~q4dl{=@_33(40g?$kB&ZW0G*5@{Rx!ia!By;lSS<)2olD>W z_-U%Zl%9VU7E(S}$MV5a0;cq82Db#!oq#eYvMNXmmD$~_ykZ~w@GfGnM$5y4CCEiV?6T4Inzl3c3m!ZT5+7Vyi@MBh@4UDO!& zfX2Fr{IG ziSwk@f)Ok}(^4m|b=C*N7DvOx(R^@_Cab8BAiA1FxT!Z9_g-e~oM$}D_1#wn-Eia# zO5azev^Zni7iNP2x z_JnC62D)xAhV*?Oi&JzWCV9vHQ8E5f^Wuq1wrbKR(}jKSBhgYG;o(VnL{_BsG1?De zvL9P-TM=WkHq^q5I5d!j9Rb6Vt%%%2clg-x93IDpPLuhJAq(gK&O)PSQ`D4~1qXnmNro1|l74MRFKbshSA_8I<4>A(yfy13WV-iE*h z>=I=CZSsw0zRK(M}DK8$#^{9v%Soy-yHy|xpf_=s1GX`Zfb3hXfM+hW|8XB_wR8~1-eLYs{H z?N+10AJvldLBEpOrC&*c#py8V7fcVS5tuKV#?c5+9%1UNlu#IZTY(kdr76a>5K>|B zM>SU~7^?{hZ8pRD7;nugdr_SL-%I;M;iL6wHLRXW)7llQPE7-BQ*&Z`7O;C^0=Uh@ zP5NA8r^wk}UNGVXYJvMPAPwZzrLxiheDlF>ssjY5-CW7>4r{RJz+eGGfp^$m&+X6e z9yrmtzw@K9oO<@?-1V^zj3H>9-azkEY{PM`Blvdi=nWmYGLVketD&gnb+_ZC>F~yigOK6Lv$D5+2u{B>1QuZ_Eh(IQ9uzQN0%Gb~V&(mo$}6_j0?E z_{qyV$|EEfKQ|tx*Q>_E4;c^KVLTk;V!NgP(-&!pk7Hn136*b7FUMxBr|D&WL#=CI z$WG)iFl6yKHgpOD1B@~q+TRE5?}zr6MPBK}AHUEjU~MW{7l#iiIxTYp8J+fxU7BGs z8XhG|*W>9Zx2c}#b~5smSIz5qFG2YP*nlCx+CH$aG1G#Zrqb3B4Nedh^Mw%ED}?c8 zZ)cti#`-jjNq)jB9YClu*-cAxX+MorILuRy9%p|+a62zSn}wiHTJ8EMv|Vd{96c+> z+dJs6kj@Fr!7;F4yC%#XB@{m%#$wpH!<`Vg`ti3*?qPHI{T8&QN zx(#@s#rf2cwm)FJABc%SJ%);>g$)`KNK4eSbw%>_82;S)ApvXKN|&OaLeWXiNvYtc z&;lNSn3pm@QD%=xXLyWp#dLd%jR1!L zmL|C7bmkw!GC5+JKkc1=F}AV_tP3|rW*Qr-Fio>+c>=iJfR&&v`fq57olGu(=LO9R zy?ILivPi`f;J?|s{L77=tBjt@jh;D1&opdG`LCu+(r670d+%b1`uO^_wu@7D*{K}8 zP7Lq&j#QA(y-PuzNdRUM!Fzu%}8M7 z73>H!1OCAfI^LmTqfC9C^Cqyp(ivB)vC<8VM5Ebs$7hvzm}(@JDEs}Y=SCqGuzYm* z10|}K(B01zTn5n%akxl`bon$ks)gf_ZaUZB#An19g|~2y=)lM{x@HQ$7S`b~3o#WMDc7wUNMj@8#oV(Vy5$f-?~pqX}{odk4ou2JqAhREoaVDX}_j zh(fU@bDTYhRXz7LQycRD);41#9@_hi3LeY#Z)!`7$}5e49tA3MV=t04;$NQY7!21I z5W$5$tT!}vCpW}#qZn5mbMOZs^7j@Q3^?ys*_udY;k}C|{8*y#tzFr?8qNZ6Bngfi zx}#b0US=*F9OY3+IRKPzLZ!8+lx)ElHJbj=-NDx3{+=yOJMU&kY};8aQqz0~z;~-P zfC;x*sccjwmumh^7u}fCu7`LBO@9$>NM-EEAz9T2(z#5m zJK5PRP4F4?-U>Rm$3wr&??2<5;sTOpTRjO}UCUI|`<|q)=GhcKPASq! zMUhI&X$9^`QO~1G<$QTE6J?Jkbd(O89IbG8h7A(yYrwj;1+;u z+J&gfo?~1!v&$zOYcX@kT}%C!4DZb%Sb??d$SPw4v~vNnAMVz&<`?}<3!GgOV^3LJ z_*lh>PCc2*nbqmPlMiKK)R;Jw1H;As;DI7WkM5>~PAyipq*Cw+13uc700#~C@vT;| z($zhsN&IcpPDg+k4S!JCha%y^^vREdS!xLR=&V)+N=a@NFoah2{nd)L6;T$mK93^dh2?;CNDXYPP zEfModxZ;UJpIW5}2DQ5AwA)QAaPlnz-NY_+ID=gk2hbI%C8xmG9)=;f3o?Dw(TWzc zNj7?fDC~pNRWy?fAMa24mIJjt1k1O=MIQm3Y63O=^l_f$o}9ksQdo@Es3)5!i~}Rn zZO2wPDvBHH7E#0=ZfWJS(jZky8pspu7L4H)^N%|O;ROeL7XJW)8pTW{UnaszA7AS) zX#$o~oCfHEe~vEw?R3=agCjStRi#uP7LN&^3a-M{6BvX~ z&eT|R6N4Bc>W0FD=+bK)k-#YVc=qSpzOWG1`EoO_m_=OG1E})dXWT)`ukB`s%a> zr-0LTepmhGf$E!y@2$dq@#m(J`z@;oL%7ZxJ^!FDjI$^z3rZl^T=TZ+#f5>{>ah`st(9Fc5HMGv zrY8MXMKWRekTYB0jGH75qpbwRPg#L)n4I!`)5)ya*}Pv(1Hk&~w3CxfkeR~BwB!8M zT5qGw+0Bj!ip)NrE72j#?u?GPlG z?tZIb0}{#R=^xDs0;(nuyeOoM`DYr=yyg`Kv7x z?nJAI!*UzGDTQ8KU1dFd<;>cCi}50bRy%0>y*L-qLWqG+RqR?V%RW4X9D3Rck*$AD z7aY7Kn{44ky9g7-Q=(kVmKg?mnH}{s7G_U4wQ1$B)DMQK4i*TNTyL0K$r5!x-?o#R z_kOykMWsE7xD6!jY>{n!wLx(aUaIh0nf+KiD+T4vW4D=a5kV;Gsw`HNuA7a)VMwnR z8LKQ9vb&`9oUA0rJdNRX1yLld0Pvv_?$>fniPFg|)oAMz{}mj4oSwG$x)VL}gwB+_*Pqq0VwO+pX zaih>rxLS31ag{>!6acPDJn(F`NS(qKJF_H;inbFS*<()XZ>nW`6jh`D&LYjjbpB+s z(>tjt6$N*L@uZ0fpxF!sY;5ehu$#jiqo<#{jm^FD&7_r@Y*aOnP7D)qL?9H$1Yy5BvCWE#Mq|X1B7Q} z{##5M{e5mAo-kyLlvPj_}Mft8Gl;&!_YOkXyxqRnXcM9faK$#ejEm}6nciA61UKFwhRzp!Gk@Uf~8e(tj96~QglJ>E9; z-)$A2G}h-i^Nwn0ZeY*ydde57Q2nxnQ^pddj4Z&5^cUxK+3))*(`i{U6ESM zUh-sqLfk8ov{z!AFJ=Kz@@4R(MRq@zKuuJ9Z7PkQ;<1KavwHt`J=I$T)?~38R65(V zC8-ShE^0j4oQ44s(_}RtzY0MM#JG^hI^V(G+u4Y6E?zWqa=|C;c~m#6v8eF^^01wA z`dxBSTHZZkiokuy#Kc?9WTI}3xR-*kz_kV0yN1F11;1)|LTnndR*RnzB87A_(Fa4H zA^Lx7vA`8|F-(M^h8I>R0oU%#{`Yqi%w8mmsI#F-M|I1Z)pXwR z$35B-f4$I4C0ST(t-F9VatyntST;>Xfx*az=;e)>0Rvf41`$mZl>8F4#ydw7$f~>> zzRg`OXfE5k;oBL^#xbj)3AzsTgY=EBkhwN1U?-7OETqFv z^S)-=RH$&xLhZa(q6xm@YO6LILx$8wpe&u`$?Ixn8%3*qn}LM3k#{#395#L^!9mGP zU?=A89PF{&oxtwN-3j72UfX!RO`h*lmWx5*QN>LbkKC4_Gzbh0GaxL+9c7NocCd#e zuGGKWBFP+-i=qTYe-lsyMQNuZSlDT=}Yx!rIEU{zOTXRUKN>P1rsarsarOJk+2Lb+CYy=78?SX{# zlw(-g$h*q=Y{=&?>%qCGZCz1Y1v?bE7ofRPtBVL{m?7xvUc{_bKZ|=NA1r}zV0wW_ zHgT2UHKKeMEaG5mj^>{B^6*@UwHsY(^a`k{NErcJFwWZ*(96`_L}83_ZKLg zY&ct)a-D=SS!O=^X)Kd3?iC^p>d_0$w9t^wz$+eO)}JpMnnY;B<}x3%XvO6WPs!_~ zyamO^${X;CC)0`H*v5=Ad-GVtg!WjuO^966Xi*|^qwm*XlRUmwetG2z&bP|~bB3cP zvhJEutV)VS+iYW4GMi;9o)J*zPXzaDa)qn=OeXoiCuLnVat6mv_U8B5=6jiTCQ!b& ztcGZ_8e+0_eBH#!se_TGa|3o|_AJ5f3q=~U*qpGNkm-=KBqZ%NL`nap#Ri*C9MD6Q zPD@R6CPjxUD5jBC32|sb4wdNegF(ZQU6Yjjxs;Ur^sKJW}qt)b&< z<9ybQ9yp(8-bmToL81LI_$$E?G4?`2rzde@k1lurCxsv>hj5hMJcWhJS9AErp0-eh zhdv#v);=R+WQ}!34jq{>)r8V&Dr<^+9wwrmCN+^&RM0iO9OPbs*KE@#Io<4ngR;A&!gY)-N&Et`S+K|gThplTnL{G z40Z$;W@7O_$VJNEbEbb9>Ka-Gk2+hV|~D=L$pJ!x}$zJaa=i^5---F*se-*&o;; zeolOHz?6eR949CZj&(w4f>t{GLFh&pr%jjXe%$=2!2M6$`Gi|1kpcs*olNnVN$kFb zT0}oW!E2phBe&C+D0Q)uI^TGZQf3*0cqzX%dg=9ZdA%;LSLF3Qc|9+$Z^-L!j!c;~kMYp6ze@Spq8;_S}e-u~^|LjyRodu>~2 z$F_l<;qCnWiqVn4LyOt(2YK}%v_6aO|6rJIIpU^%xP{)hz^@<8n|=vCh)YBC_2^7o zeoNU%7s?NBn79e%`E-QxQo(xiO@M1DoPqK?{sqQH=z=`mQ)V=Piu(dO?h)b_ z0K22~E0l0V%ZIxt?EipdzsdOU6&(7?6yw9JP?WEzb120Jl!UaWLE4ls9j4`r+fvcf zsK|Z8W~0W_IOVgfj+GI7mePk&dM@4Nb7`0flBIDA=ffH@iw4nVFfvb9!x<(02moW` z)2&|LW2aEI;)$;Jt7D6b&h~zV0g3fk`kgwf4uV+mJ9_#b^(0C){zvhHTlgnRmu)T$ zr?3P;Yj4T4FfpH85W%nZtiy<- z6)46ZD`>RG&;Hm60Zs@w2{oKh<0MSw1YA?KVAOI#t&trcrp0(Xhj4xZ7yxH5zU=8Zt&h(rAbn4YwE# zD~yI^M#JSs!+fIwKbyxt<|Uo_Sy&b`F;pnwb%a$fU00`{F2ZHvo6whIKqbO;JWFG< z>6An@VrsS2jCuvo=fTu6?neo+&pV^G=>sZm7yAMleLe2J!4nJ|=BncnIC6^x!*FVO zIY(7oM8UVwNF15w%@uz`zekSoh&q9!Dl;!!!Gww7Yg=}nA1OQ4zr7m z2NxQHHZ#8rbe3P(^V9HbzKqg=j9yb$a96k@d!L+#D*80qsH1Bi=z(INe;CBYnHrcj1R?OUS=oA(}o!& z7~_MK%mX;uaSht>7T8fsVMjH>j=CClR9vqzc+*$;s$S{g4g6^M+oI`QOn+EdJ)hPf z@hj7r)@UW%D$V72JN97E+c4Z&SDEdf&vkq5rO}xkYltCHxdw4pJ51&dGd%Y`IWi@g zi%|u14}_f3zzJ4clzj!`#>+uygVKxH&P8Uy3^kjQ(UP8e69t9~LpgGK|Vs3Cq`2m+GsUYhhKb$&*}FbK=eX z6yP$+GqceNsQ<@3Rdb()3VF9))42SFJ*QEYBW~|$oPav9I5KN+rl`P4Ym z$Z^^K`Sp8nT*geEl=Cv#wr1yL+&vYZN3u6D%iwSh?^wP3$O^RR)W%36!FNkDS^Dwp5&F%icv7yL zW&U4?J+wiZUcFS$}Ua_dgk!0JEz{QcrOdTIGCj(uL1q9(ZAwY(UkpI>DRESJo-=kN*U1w4nt2;OQm^cxKy66cyE zHWOgS`^C(BM(j#Z_vf}XCoXJj9>=BNs_8+VFOh)_5v*yXABu0vCP@I%?&81YI7H57 z5ln5Kz9=U^hM3wXAk`_Jo@nFz@=auq$FrBgw2XJu!vv+oJpF>{@%#jAm_1{2VMZhE zMPGIS+;+nDE6{4?uO*)bqs6>zT)B;zdcx}p)R!a^fJZdtgumTrXf_%a8VyzEMB@CN zjDS_%J~}en)3K}{U3dMUqSdudO4mARbuHStJOr1$&87#-b%c7k2b=u=nI=xm!paAo zZtK6CX?j*1rae1LVnKOHkA4=cC2NMHS))jd!PA_ufTG*htc5FK!s8ffA!5)qm14tMGGi)Mt*H)n8m`xp<_NQ(7m5X`f{5 zBJFVMSc)B~uo<~+J-hn1ZSP+evO*V7;oK0AuK8u9tBHR1uZ)PjAR_jHC1SMG{cfA= zz$G==6X0j5BpvWbl8qMax0g23Q}3aXT-BFtq!*--o}xyolSZQZ;G0UC>IG`5I;(+} zh2mQVc3?pjzLL4I7SMo3{S-Y3FLvKL`~#AI`3+zat#3O&z=qqj%}oiXyXv!z5As%m z`$r_XjQdx$IDxD4c(pM%3+U^2Mn^7(V7PvzlL@6Z}9zAt_G`&M73GbtWRjQmY8wsmb%Cp1J!kL1?sA~Y~TF8^vwxIrSjtf{`=Gq{ViMX>)$pBhSG0_ zyBL~DZGgWDk8QhI$4^0-Htm{X>i*tC9r8_*vVv2tgtE;-)!*9;-t4wxFK$+NNovDo z`}leR@<_|=5fW5S!2J+Z+Q);$o8;6@Q zEjO*dUpRQG6~>*DrthDeawYU}^+Mw>Y#KR{=nS;=Z{M+PXYY$xlazx3}lKWao7wZ+WZ{|nkTKr1cX;%D&J8xdyt$; z5GL8^f4Ttac_I59o9sN1tOMmqh_!dR*q$MCW#x*Dmso11A4(fTk(-^E4FENe9d<}oyB~imC&796 z33CgW#rZPb>t$j6%Qh?6V(_qjC9}S6(yX8E;+@0#IuGle`ih71z&uy+OJ%*Q>awhV zSy(^M!}^zr^$W|gz8Sny?; zuMW=}JUn;mD>eZFSGkH`D$iY2m*x47gy&azc>bgFi~B0@d>b9{xpR2ymYsKPpMC@oL~KCR5YtIWfaY;!unTj*2_5VX1yqyTPMwW9Be2f^tXCg@6^Wwshjn! zuHu)6=P*9+VZ2jc$pPpCL|4b^ToGEik_cisZ zg;mTR7vmgB-|OMKQ(wt=`lze;rSjcXby>cj623p`;rpqwe1DggOgVusYsj1y#-Fws zZx5Yc0<4*1JQYwOjYPu)lPm{k!^y z#YetVr9KOXi392G9NhG$vwXxa@EY&82VPV3>2%ekp1k1GZ|r8`Yh!db84x%2Z`*or zsCDbMySLKLz}77g)ynVC^Z(euf&FgMjQ{5KM#HDegO55n5)L0v68@OY1U*G6`sI_U` z>cHCTZ{D!!=Jo5>R8K!Uenefm%jI%?O8=XK`~3L|WmVzN?^2cVr^agAV(~~zIug!C zTI0zU)iwV3n7=8L4JTT|>DFK@k?PJijgR@)2KMgS9n25hGms~y+@%7<_*ce!ZQY5M zY%G}=Kdc;3>jBW;8fl9qB0++S>TSttK=dS2k%U@>3KhxjEI@jZtZI#=BV1Xn8$ax! z9N^KK4L8Rl<6~}!16h@+a7$;nJu-e+9e-l12EdJsL*rxfdm`y%Pp~D~)s;*H!eLsst&ibTZ{$gopVKc>}48*Qn46_GXCP)s8amD*+d|wMK3>))h%-7K|UBOY}Z9 z=H=Ej6r-n_Og7!!lI>1MGT?2D^DCRe@l;fQa5pteuDhwlNVG~qZHjYwwJF7ScT>tJk(Pv~ zDZS22t(TOqDHB0A$QVVp8HpaFBoJnJ72!l?dqmRS<|Oowv%M|xa3;e^A18&L$H%-a z$?im!SkV@aXNWRN#u8yc(;bV&I8Tjr$-7P}&&i6eaJo}(swNeSv_u#dzw`04!L*80 z_l_NL0j_SsMZDe+b$iuCqP3!>xj36%xUCq^m2; z)vL|NV4RzKVr))0m5N*KKQT7XmSL8vXig`$>wK=3bdWfa)Y;n-4X4*~6W*3oyxR~N z8<(JP!Y`&KXlgPSuYeWkib(ki8wE9z4u-o$f#-;AVfjcq7E`J?X)h{m#I^~mD_BQ# z#cgX7H9&7pv<7wAp+~gEboFRY(tq5BCzjB2=fo1*BAINg9le=f)yA@sbU2G9f~~P_ z>o{+rGY?YNd0Y)G&IVJ-OpNTMpx+hFwnRBuorKNY9_|gYCJ1y#mN0gKGtU%_FV&Ka zv>5`g;3uIKX;T)Jk`_>Su(*!;{2;G%4W6-%Bgs`MX0YzC1VLN zpj{gBLWOjhS8!5bc~hB~uJ;uwtHDZ18>sLLVW9qIy|6`kUoai%O6r32rgp&U^V#M1zV;iLMt;9f%hS}db1d|#B$G}WTM>?5Z-l11aEgXP4vQFcxuc; zgRG2tN)w*d&6~%^HgxUUIe6zFT&sHqM)wTv8VT&WGjPY~u6y?k1n$iZ_U8gScMa?r z`S9LA|E`fe@a_V4?d#8tANFb~nCuERVq%pm#m33QTwCXt9E>68y_9C(q=Iyq7^6J| zm*LyMkP|NfKTiBxzW(L-*v4`Q?j7wTbO(ZiBZGV4g8<`!zTrUs;AsE8eBbEc-ob%A z29EQKji}&5awO42^xmT5od%1;$jqiAA}7B+M>m){j^6@z(6Va6APMJl8H=juon4M2Nrz=%pcA z+oAPoJ4rUJu%+p4Ry}E5bW+l=9$Jp@mp-xfdQ`<@jrl0%#d==P?~URcoW(b!oy9k# zrMOSPt&`Gv<#l>t^U+aOhpfLe0Gp2}tFLiojE9s3QLqfW{WA+Ze>`B)D;7VC_vbGg-g>sj>B+fvL+pa0@x! zEy;AmnDE?cN!rLV=0G>HGrp0W@j=rQrzd)#zkD4%ReNzM7%n^A$z}Ju#>eKt1(1O~ z!2U0?b@$x8UR&G<4qmy!bS{EAtAg;q!%Qi><%&#i2Ci5Qe6>25)nE$DiL_cCNyT+| za|M+SV%&p!W4*c-6OwA%n@IY@TH{g__ghUSn>%39=4p+J*63b5ez=DEf1?XLuGGg% z&QMw6=Q%BgLedqse4i~{V@uDqrE6_zzb(B$(hGrrq%QATF@Crn^r@+gM!c;dH3>4~ zNgZpDg$Y_3x{_g4^<-cHpwAt6QGwiauiisBEj>!|rH4rR22pb^v%!|WQDBlOK?<(5 zA;tp-AV$U_2n8j|6opWcEE*>sA6o)N33tb{mh^(DH2W(=2lW|)jsva(EGA~Xq8>PS zfO++gC|9jRG)X)xh1^D=eWbc^_qT?uZZ%2y3Uoa20*Y7j9{ZWHQM#&HYp9NNcPGuJwTf2VBQksPiy!uMB;U zyS`)~sqk!^3=D+6d>pMO8nw~KycYAFice}sv7kx+! zB4NE)fERW2VgX*%*f2WqVoxPkM(bRKPTV`{)IxG)yv|cd;Hj&wqLB0-Nv=%R*7*v_I!Z05 zt0^SwDYd9>ZXtOUr5fsL3&{Ybmeu(S$>o%4tXlv`B0WW^bEywa|2QS#q#atkFN=j5&T@a>}?=i4nj+AEva^V7{A;@c)R*vdw+W;YqiGat%x zS7?&^z@dr7gCyrDU2;4`-r*`t{N|H*yt*fJ#s$_#LuXWQ9ybqIk6Q&ekDCu{$E^lD z$89bcj$19bjhi2=#%%%k9M#!8Uvcy^S!z-iV-TCy5{3P)>bG!ajbntC2Gm_ zdu;{x^aUfzbV(Dm_-K?4&}x?rel;T+S3KHE1%3?=z)F|4lAtNPQtB`lJ%^%xa!C4B zzss#?tHycp5uQ{4%VrArqb~}Qfv9N4!cuF>tG7_2tx^|_e_@59dfeU$#a*F#J#*$( zSNc4j$~nHd)fF}Ks%opNYv)zfR8%NLDCF-tWnpTvjsd_|p?;IFe2 zdtE8Qrv9XxE`jm&rIl$dkChKA#+RtQ_F}cyU#j*x=GJ_ZTa@U>T*B?r){l=}0W{#j zhPxtI$qE=t)h@GtD@GSn;m9x5Cu(oAC3=IeZ}RmQd_Bw8b9{Y^uRrGN>wNtQUw_Ki zpYiqQeEk6?xMbOW$k$);m8OF3Y?%CBTDLb-EoKS{SuF7&h1saK6SHIjbB3=!(sH(5 zu)dUortr31ih(y=q;k)tDsL#QY)T&Dzl7vvy67;5)wgruo~3)wFvl zH+`?OTjCqrSH|YiQVa%*AeMG$qF$qIvUk-@%=7tqcggrz2P)0+(fF2P;~~#1l{iM< zn|btQ47#+NnWToYBn|0=VCBu=A%9A-2vMCBC^gz(^xCpK9Pucm z7selzVfRjF?Ur$TD-~-A&&V`Q?xu1I;<<)%zeURub2G6-JJxjC@Vzp-1d20PR~Yu+ zYP2otiie3KHcPQ(1{?@kqUJAZ7D}a}4%vASx(M)`PHcF5%;@6edPmY1gC4d+4>R-& zbUaUS$7{yNUY)7d_dlzx3-vx>ZjIJ#Z@KwmEthop7Forj!O!^8IP-Q}?CrL2yMgjL zrLxu0x!P)RRlca$TI3a1rO3{pm$urQYNe)Jj*eyM3A%t9*A}aB%u*)f!?TT&3k)HK62p2Krn5(jal02c@*Nh(G6}1lQW167A$OGW zgC=U!0n88MmtaaKgYXZQ3=)nRAAKdV0kX!3xP6R>m!e~+a`&ZFxvRA90-Y4wCwvLRc5dVJRs3wb(>MR3V??RP4!)&Xp%0?#wmpn2M^C6TfYM zZ{L7f`c{u)hOUH_W!fEXS`JaJrL`%giB}R-6g#G+(b(#lHv#bJ67Y3epCTaL1Tr&g zkeTuz3D+P&%mU(OlOs%iNL7ej#+*k;WXS)-9D2p<&{;wq%eFYEgw>B|eRH%v&sC)F zs%H^3bsY;tT_B`XQ^Vb8cvbksm0{&*IIM)iirTQG-XF>}^hB2w!cj9B%@O0fG5)Ih z>JvVUC>XDlt!Np5wgFH!88!rB2;uE}4~?<(YX=4Ikoawocx@^_|E>Ig zCE@C80BzcBmUuBtJU-^`O19$tF>rM5z^8ZjjqD5>JDZNUmW0$Eg;(yW>&9SuNLkn< zlac8}N3|*6+~v!=!YyfR??|S*#>W;KkG7AjE-WlOJ~l`1uL&$fRN&b|pUf3(1cbFA z$LngtP!Q(4h(#IHwDDn-774kn03(Yx#tLPFwzvu_w+rd>Mo>pb-?iykfEPY&bfI=L zwc5wTI(91B$CO3goz2aVT70^6X0%AO;nsUwS-X- zwG3;UhnLjV?X}v+g{<2Y?c+oine86@^+G8=0p`}z$QvD+J{0puhtHkN#Tt62IwmLn z=+Zs`glx7E6*0w-c-8bTWd^!~so zfoyw+U{Y-=@<~yV-HP_fVioCwv{!}PCmKSEId1nn6;g+zwSLlle~7N{9vb!!Vfg7o zkF~2z*oAdg*k8{}UJIyN|M(H_wxP+P zsaW{@p@|!YPIffozH;bPXAAE2vF?uU&bQ9Kb#`)aTQ>T~Lg(<=Qxm`I7(RP);_cY* z*{O*ig|^pbUnxYl`*F?Y=T0BW`Ln}k`+XSfJld^pueRDN%m~!ZP9P1`c1pKUd?EMOj=TOv_kd2UA@+pS8F{zascB(EH+3n=+2=W=qAlib;lOYVNYx$ozjXOG+>e5<}y zZoFSab<5C-9(ha~D65kLXscK!cj}V?*2z0X@UCCwYYa>JsKb&@g(k_q=KL|`!~?OD zG4)g@G~`>I%;!9Ng0FTer{gHo^;lQ5z7QWi_ga^FI`Qhn?>lUTK0Y-4bVshf(4kB; zb-mi5ycQpxK9*4N5j>GwQb^WL)Fq@c<*2VEYhRuC^^!t|db(3R)pc^>(b%cZ7bdRj zRCau$GnZ?qFLWy5leyC!)a;`jXfoH;@bS}$lM{a=t6V^(i8nyU7JcOQyBz?J%=&x)bf$=tgF_wvKN{0sWZvDR6CB zh{o{O>1$LdZ0Mgc8GtqURMBh$!xlTTO9*mTq^miSzJft6Q^mIn@Mli-8bzhy8+NBn zy9RCLL_+F~wE2K0nK>SnjC}+->=vMH137FCpj`qv>;<4r0Xcm7r#%2UeCZEOhA~JI zV?Hr_?h_(3R7nhev=zz63pUA6SRQmPrTtPGvQ3V>U_~IWv zg$kYTpFa_bcD{@jVz@RIqS#H)iJb(|j+bv=m0X@&`AQ+CXT_|nWFXq{N+H=8qifx( zae#TYGk)$=T-T(DKX%5?o`TKW0gMh!932LT-jOtZ#46xl)uU>f7Vf+ z@}<0)4_s=`0=MJSJCiGi&jRP;)A3||@~XFz4asGU6rPsR(^ZU6G5}5_8^Ma?a+F_Q zIR39cq)A<_-l6cj11c9dpvDX`v5>06OjS6oNQAZ52CGnD=aYwAms z6fLD^g;py(w8I<^u6MWyU0e?%zXFp!?AqE-Md)nM{YZFe8&}INF8G(7Qa+6QdHfL* z8}ac)B!eCHDgmcWk`=uCoubDTTzrBIsdB@^q1e1%QR-?lRrm0g11{G+<72BLqoX+b zwPwwlK;P(S-+h5SgZB^c9JnvAd)K{mK(rBu*x4r;bmLy0kn{w)rz+#-YiHR5+W#Jw|sQ)WY=*Qowd7Q*ReN z{)M)fZV#~v{a}~2c$2pH266H&_?EJBVf}pZ8xUd^~0oj(}#xq!&{>-Ph*s0<@-JDsM)CPwpNf) z16A%8y;9bPzII$`3ghx2-8sVm`EUq}obNstQp0NV9iGA+YJrxVerb4bO?c5v8p2~K z6{3e;%;~T?WUKJakm5dZZI~A2upk#8pj`6ALMPn}R(S32n4!L5~*l)&eQIuTv^DI%0WD+k^9}Ys2mnOEA+~ z$fCy5sVowLNRXMjvR{2Nv{ii_ONI@p2DAdIsR8IxCxEDS6Ue}=Miy#&xskn4u%#ii z0YMRl&rlP(CjDn&BNepSQV*650f%nu6rYakKI&lM^?p*J!$aZe1Gz)ZP_t&9!R-S8 zn;c*U#uR+=!$J!F*{90pA*~~>dFHATttdg5;Hmo0ssodmtR*S3c9cza&3>9J=n#^u zLWnQGP5=&}x zuuA(hZpXAw13)Z%Vr^Ivu0A;wR>0P;4x#h1q}VL_!&ua(rDIt;Zt#Z;8H7j%IsXt% zqtPY-EpD^Ny;}S9GHu@yZ9g}8Us;?(;kQu#zB2V~IN#3z?gxOS;S)=kXk#6kF{3^U zm33)UuoRC)+P($a{k-DE%Sgwx&j6I|+p6}NqI$eqC0`5Gt7y01*u331!B;hFPxj-87|a~&ljLN?$cD?;qz*~yYc9}4_e$sZI+M=krb(E)J(A`9E$(Y+ z9ap(kT}Bfx-qY#b+MUdj7vN2%aXMAI2B$HM53cSYvC_?3`DU=XOCK3!HOr(D#9XYW zKFB@Qy;9L0EMCys4@LPT%DnkYjCI&|n|5zjySGbve@y!{uQ|F7Zq`062fq&Tbk=o1y-xVETxS#Xn+(PQpq>ex zNQO^z5aQD(mWJqypl&3vG^5)F?txU|{BvA@-Vl1Q4kb2(zB~zV6ez*i8~_`o9Fju2W0fmVI^L|xc@j11Rd;Dhl1ZSj&ImvF*%Z-fy(IHcYGNlAT7yI&TK5Art`*XPs} zy>PGL^(H8}F1^oTGIHhofD$I3s&^7Xxxik?Z ztDHZvWLuQJl8~7Cef@Ls&6Gcyp1{lL6E}Bc%RoAD#kQ=17xrooXVs2+z4GzteOXmK zf4{Dh^Y+?O9~U$$56h5@X*mdHe}@x{xLkN zOA24a4Nc)XC88>&8%udl5qva`JLW6zO?-h&_zf`O8(_kvqd($tJDFWc?9|yze11pc z70;h)`ybFg)2HokV+kBsTqKCkW31VLAw-`UPt;@FiTy#Np(eN8Z;Um+%T9G;tjXf? z^6*(2Yj|n987OT6N-Y>wuEVGzA3Z*Qv6032{AZjvKjL!J5XIy^)t;LXIe2+0t$m1KL z>16U~2%R$SwsA10&YCXw0t|d!I+UNHA+R#hP0Nxgaz)+P$#of?D8sT*Ud|IG%D*6# z=Y;Yv7#=A;S+e4M5!`OeO@>~G%J()h1jO{-q3LHr3ci|!xC1uEPKK~rIDM=Wirg^S z*-5(pB`h7hiUr{K$%)@h6l8q(B2J~+ZARQJE9f!aHme@3#HVD#W_$^4`$I=*@L>bg z!2Td1{U!W4pkP{ILj)duh}05^At=-^E*j5*=)qBd_n zagB*(rv?Sd$6(o;!Y5YJ&K$PsUriw;Ny3>X`1%~~S3sBNoJ9L$&Uq)JEX(I^;mV_R zT2B?Gr$$4M1L0e-RyN}Pd-_&EJ|e;A1>j31cwOTMq9>0-7<#AmuGjjSw7zS!zIv^1 z9zOheucK4^Ku^VX4Dq8q93McH4>tSFTrMPg7|d5vQmWm;1@?Pae$W7ye$W6B-RXlR zdCmt7P}j7td_W5D6^8=sY|?h(ct*XpbDp;Ie<=W~?VqXh|DzP(5KPS-14HMZ9LTHZ zpB|RkabaNie;<1H#k|@#d2rigl*~fN+z3F9Wx;wRGeLj73Ou9R6pSFsX|B-~?>ZOn zsHU$2Fi|u%&bOkhNlY}EV;`ze94B0{l;@${IjB*!lFlV35#NfU7$BZUxXb%-`?4r&adp?oj34Wr?7(uA2UFa`xIPK-d^W=!mT>k z%f~?7r!9ucMCQ;cR?~miD7UMKorpftl8!YasvW}Q@VOhEcpg>V-v{Spz&Z>wlENbR z)sy8(n0lCWXevhT7yXeAMc>DEowm?q^s(~exrtZXc3WbI9w^@X* z5LNs=IThF-TG!?ra99O;f^DD+;Iy%_iZ#)FgV2|(V0 zcKv9VNQ|CQc?w1jZcBckZzQ;HH^&j&!={pC^b3GLpwJFx1bjqHh$qDNQIHcxg8WM1(k z90PrP25P#{o&vV^B{=E`Ptj{x4aMTyc3OBlJVYTo@KO!PB2T3eZw2S{s2@@o1U}H4 zj&Lv@+INZXKrM*Xhi^&7Tb~hOfYtMNM7j+w)o@3)B9H~Qv>%TO2R*X2%+boQsYov& z$A8`D8QyzEuzc+tgDq_WG)n=p7m)%p`WyFq1~{`N#-57U@G+_ro$f?3t2gKVle{Pk zqejP}92l-P?SLZgklRiPZE>w^P9_n~2z)df0S+o6NElKv@|A<7S^Vw=Gam_JG(w#j z;2063P4_M-P-%w664;JH9{%oDhHr$e7b=iI1Qe-9;d_8gfKvPk(k&05%r#126N)ZZ&vI(Yvx0gs^i&U^ zW&vho+rlkb9V*35Wadv4`~$MA~zN9?a8ybwFm;GZzer{_}i9bu&>c|j1gp`r_+!HfcI!Abc=2Gd5uR97=! zS4^WK;p0IJLT*)|T+b@Or-GZX^#lfiZ^pzXkY#B&<)CdCJg6?+wh{@9l7~ODdj_44 zu*cMWxHLSjKA5cWnc4OM4?Ky_9Ih88*iT!aZ*43CM4z1d6A zW(Ot+u)!x5>R=3E@fxi)r?jL&2$L$BiXi4B zW6X`m9IrfI=1lXI$qd2YR4UH*aI`GOkXs>*=jzZSo#948C(zDaQa^ovy71idj6k6) zh7wSEikZlnJQuJp308Ea0ofD;zrFCFF9=IrgMCGy z1cGU5oHD(%GBB4NJ_50|vI`CZW-cUZGD%gW6Gr$$T>`(hlf-GrN~nFtNPJHx)$@I; zuxb`_zST!0NnZwAmVGCQkQ|P9yoHyGq)2s?0&~0*A%J8mT8e?cE)!M z$hKm|@by=Yl0{`Krdp7l$P{%5SSjI|X}xTZCh`Q9{4s29jF2@oIOzZlr!UnC?}wO% zQ$e&-%rKv(FE18axAauo^G|&JXSo`H33-62>1x4&f7*6tddXDILJOKBp2Nio8Jtj` zr^?nCEh=T&Kj|{2)z%Ah6;mhdnGO@k#Z36R7CLdY)wKu!Zd_O;M~Tae7Gku}^BFQ8 z89ht90*w#@pQ<<*V1~oba(NlU47KU6mg%&iJSECTO%qPlJVEo(sL#T} z>dX~b6PQOj0ULk z(Poht7UB%6Nr364FxB+)EZGu|Qb`2N4^rG$wj0Q*YL2xBX^_#qZGGwArT;s6VH zZ@ZxlhW+(Mm|x53>TTyVwAN~k^RWcvC0va*oVZFQ3xKT=2RxH4(x$M*EG(H~qRmW; zrOZk9drH|JMa{VXWRT`yI=?d6Ic@N@j0?fI+Uk<_I0pa|8?!C%7NL-?-m4_7qhUFP z&PK^7Fnh_*5g{`&)T`wY<#qlGSkUa0huOSSzo@i1CAd)YmTEcCqKeMu#ltI7UXul0 z=meWnQN=Wc=@$AKY1SkXqfL!X${j#>M&|9(Y4q;3194;ue+i~86=y@jQ}#8A%p^BQ z_PM>KmFg6cm!Zefp~&jl(w1|qEz5oTM68ti7C;Ac3=BEbz);V;kmWFe zU)(Sl_!vzT5hC`W)b==K>V=aa9eT!Si;|c~O0O!546bc>D5LlDJH=)wmrn3R6=`qo_QR66P2?j{alhu6upb0Gy#Ua(i7qbc<*csiThBRVF|dd6F*BiEk|!ptwX zsmRVX3|0^DtA;1Ux-)A?Tn3V&uKkW7(0?&lzzul$(Z(?7XRdHL;L4)| zu8o6cFS1)+Gt-3WW}?mfqJB&o0y$s+1ZXwp&bx@IW1bNsQ7wuGV+dZ{K0i;Z;`u%?oUGZ)7U-P8>Q%##Vx z$s4@@2C||8qME2E<>k>B?^si*MSWG?4qw*@y`o;g4&N-G3r8UrmIk4n}vD|07j+`zGAZzJQ-_()JmWXo8>5L z6SIk;A>U?HReSjB1|xQAcF=N$F$`~v)eRB(@69~iie2-!Bux7c;7p-Dp ztB>Xmc{zA4#F|2v7M%*J8&Y#zwehD^^xj18^1qVhPHT7n=NkB2NaweSW z$#h;o4U5J{HE_@ zoa^D;X4m6n@>&FH;4_r2r?E3#C!jLJBt687W3Gojs_oyT?O&xWUZO3o(H2)U(p&c$ z-W}n2cA-4+X&Lu>yh`R?!%|lFdy^cnqU9l%^7-cx8&LG>Sw&fEh~zy5AvpBy*ZXna zUeT!^$G*7A6yiR~#<&hfXuRCUIBon$1@KXNXlFbQY<}g-gWGG3FcN>H1O8qFS-Ej| zD#nQqBd!Z4>Z9EVMn$2hPUW`OcD_>JAXLBQW1erxc6o|RF&CAWA<_kdeiX-eqOm{9 znbALRpjp{b$yibtZpJuSDXFY-^E zkwO$=q}50HInEm)%~uG#;n6}kn?zx^nsGL%l}@}OC=&;1a%o=Zy=*~TNK#JE--$_-I@bLD3&v(bhMZ-#0q2hFV3$>G}s(WcKy<5A4|!7{qSh8(ITZJtLup%~0e4b(r(9vy12#wf}^5Y0Ae)6(ALO;8T zNXWb;jMCmdDZWMf)N)RJbFTI&?u)K(Dtt)B(_ri~eFj8Uhj<^Ze&&m7JcFie=WCQ6 z)h967jJqDiYhltc)L%je5$&d^m*7nrXdhGYq#xp!gFnwyBkC!Be_J;Y3k~aFuFJ5I zDe?fUMG!GTyy?#LFpJ(I9}Btk+l)pVgnk82)4iG_Q=0K=Uiz3Mr6r5DZ;1snK1%76 z0Mnz=-x6s01ZR$QoUf0NCXjawXyR0s2g0DnjFRl*6B;sjT3aFvJd3;;8ntKEGUN2Z9KO(XqM~#{Fz6NdBffIL#6QJP-7be39z!&w05bgA8epGPQ81E4A z0fm;-OBAR-pu}WYnL^e{g#H_chZpNuQs|^mSf^qtqS%~_Pjw=oxmen-VU)A+lA|)| zQMC!ZuLA`{X$3sMdLpI}6dbUjD6Q`bfUi5_HxvVS5nSx#sF`p$p3Xq2Dhh~u*&TcN z<)P{Ctd?*XCzi{-hZK9qp^k^pm|hkEctSFeQ~0e{>0C(&XG-`?F*E-~xATZ|hbP4O zpO>Q)FRsuYSgH+~JpBgnx&ESIx$=wT)Jq2;GvcnCE{f1aZ21PFbQy;J!z{I<*Kn)f zG8_6PICrTag9PfEfMged8EBBfK7R$@$_5!csH@kv#*fgkZrAZ}zIOV=hbZh;Pj=}y zqS*!32TBAb}gK+7@V-1gq`k62Xhd9#M>H4WutChWN>}!N?PQ^ zFR-UuB9#bhMZYWQp-(pGdKeasv)JZOOP7R^rm>u3*^A>*8C4z9n91pKgpqz~Y)&E@ zrB>*)37s)RG_uwRN3T}q!6+!RkDUu(YnyS6z)wojuH}?O0%8)kl`}Z-Lbwz zQs-3w_FXC|0)b&)muZWuwZ*bk$o;o6d;4}3GiINx{rruX*l#NhIJDY4y6fIO1NsO& zDa!9UM(805y%m=JfeVMF|4zLvE(^uZP&- zMzH!}j#ST;rogA$#i9MGc(5S(e}q>%b#bruBu+Wk%=gR0jU0MtYE2W)bw`4k1nDWX zBFY$_gm-503$8tDg6kCM6W9I})ITe88g)|co~g{qSY|1_*jPscyj{-C(N6@Q%uRJ1 z>Nq%2uk_MX=!_?G)i-#33W2f_?Su>V=5P=h>j`pxy7FPh;*>KetS15ILXoAXQ{I@? zc!Sm$;3&4n&v9R{OA@%syT`{CIl5ss9p*EGWjf+%>4>Mzj<}IJqOvBxP7heRmE7dQ zg{~a7^lh5DF+VFGhbyG_IIm1npI^!(J})7Mo}VvIbL0llG|OI4+@W<7K#Mbm2|(wS zfa;ZxJG!fd`6j~LyL5nry8td*iZ9MuiZ6h_r7HHKL&a>^(Ut^S-!GEeOMkxHY>1SV+iN1X zmq>1PA~!k++*=~O*GPJGhRjw6Vk3ilu{ew{+blnhfWUp4Ivph_u5bQ_l+u4Oko4}m z*6$kPAo03j-0Ii}^7DyW61V-=Te*(?x9K>8TP*tv!Swoj<6~DtTWr4)Oy`GtgUvX& z7p32*%rx2f$|6zXF8aOTnvx&oC3rvN9%KCK@3;BsHNKu!^r;1YEreUXIAY%~L5zMi zXeNlc%^xzh|4J}5`TdJG`8VTZ%bdJOCF3(`QT(YNGg+_m^(TD&DPMoa*PrwC4Zgm~ z*I)4UEMNJ9uIsHL7X1z5dm-14DpGH!@R>GuFWGDVSy98;`+;=wA6T87Hu5;Vy}t#E zjD9HA@)$BMHaL9GR>K+`{?^fRZB5cvA!n06wgHePDJ%swIb&mM!=Y@a{eg7aA2U*w z6xsDpZ&cilHIIwKx0bn=*8YO6OAlXtlBQ)=uP&j{cpgGkwg_*4Ba1!Fy(;FwRa{ zhM_y%h?iyR3wwNysnsZG2TVnmx~o@;_aI@-ssD`wq&_ z5ash)2k%)2-vqyT*|&G_9&t@BHQ1D4z`9Zf{74w^BZ~p-Qrew1lL5X82LmYo%d=#H z4~uEW$W>PSKVl~MDjZDsk&OxIf&P7?duGZ6`dwaY#BFQKIysPYYdMQ@c30KK^gX18 zA}?-D^S2gW#79JMMQg`IXbY)=Z=RwWWZ(x30Ap6F;G;bs`uJVKg`99;p2>k6QSS!s zGtztKT(&Juj?vod(@wfcbUzl!V_c_?0~jmTvY(+;rSdh>-7)>Uo~f<3$=#!UR;Ts? z!-ek(i#UAz)90bSdXpY*+-kMN)$lE~0gxf%X}!sr4jFbFN*K)T3zL^JQiiMXV`B6Q zuxwZUzSV&g|Gv&g18c8e9T*LKH1O%bwSoKacR&8t&PWsp)n->dLlk9t;p-xc*DbEF zTjG=jFEII5&Po;^va!;V#Y%@PY^|1f3%+Y@04`G&HXO>z;&qY5wGLUlPO?~5Ru=0Z z46F%UKQn*u0zz0{+97@-LimX#1omc}Lf}nwz8hvGgtayvT0*$NAp~2iB_4)vlMTRS z3c-d$St0yHgs{mWgr8ivL#&4oMrl9Qo%vlO`|jE^qYhElHf<;y_^Bldc1B1P z^NMU!^Q=U%#l}fX6wMA%Sgo#OXTa|4`Pyv&E>jdX9LkE~ry`1WhbVqpUKATXP}{U2 zUB)*3Ol0vhQx@yQLvYAKY*T7hvgoq0(vn5WAq!ipJUTmM(QN~8nX<6qP*xT{6IpaS zWbw1|wuxl%0obMu=`yzI=OTokTS71gYpX+uZTiHlgm9aUhn5gN;ShqY)zZPb-v;0^ zgtPp-KLg;r0;pZ3b5SL|}t|&8DuPbAk-VjM(man@_>&&5=_e9B-Yj&IRvy#N1 zjggil@(xMZS}h%_@3sNBOi9>qC@YCKL=ty9B=H7GVtMgUjrq#uc}?X8iFM@+)0-lR zH!Vq+2m%3G2Zw}JlB8Tb7tORk`#z#vKM;v{@ z)@tb>{frI3WeUQELs>zb6+t}X=nH4d3gWW;rE*=Oth;nhByrA?ggH`Mk`Sx(;;bZL z`{ZStRy)7F*;*|fsbBi@C1Jy%tR&8fBwlhz;#^s)G<$EUya>uzrME-`Z&@NRhiFR# zVwFzJN(A4wanR}vCmfx@)@tbx{fZ61Wp)M|4rN8~mWbdLhX~%fU}v~2tK?i-Om*+r z5sx_M)2;ZlXR*KJtAOvXOBg{v<2Re-R3G*S7^8FvBU*(Ce{D*pl^9Tw+IRo``I)Vr zI^98IONf(5T1a|cbnSVI*gtDai0_Qm#4NUi%y?bQ_TjLEX-tkV?u^Me&Lrkt?hc0r zhhJ?ll6N>*q#EBoe<|GjrNzxZXPb)eO~(d@+aa!5X&5G-7t}D~%P)mlZ#tOuOJdfA zHx$fn)jpe!g%j^tQ>T8^ii;?{=oG%NA}{i5W*E#&{o zLH^s^(Xu#TH}WZN?y6mYLP(YVei452VQl{Tz}{WEgZY7b2J-St3|6b|#n?;kOLb@Q za}cQvZ=&%1hFkOf#^vVIV-56M3-nvp=~#P|4!{Fq&%o%ePX}6djqct>pG$U)KvtFC zqs#ZP8N#hK(B#bZcXVW`3JdE!EpZJ;cU7%+e5|rP+?5K1e;uLhyHYXy Rf=L@LuA`{#dv|*JzXKu2NLBy< literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~3~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..abeddcd63385bc4d2339ce26d3b93f4c47e13786 GIT binary patch literal 47090 zcmeHwd3apam1n(Ii%PO2mu+DiVN9VILkr8;G6swZR7onSN-9;At4g+H5*#6mlon+0 z!j=x$gru`55MwZUU=l;<?({PKC4tY~nd!_h zn%_C+zO7W=>2LmNgX-OPmvhfO=iGD8-Ok(V3HG)o!>!xyy>DoAaC>;$uATSo+8MrQ z+xGB|ZM(J)42JJPeE4H+xvr1jR@ip$;O(RR+qXY_`_Smnj{9zpr8cH>wtx8FTDHc+^?fBVP|GpZ?_kH@kr*RQV0IiL<~AMD>bxHY_KaO>FMj;;L< zuLw7<3wQ1s8w{^rcgrm+!mDp>zUkH*o7dgA?xvg9G_P4%(;m$w1tYU;_qH)ExO!bU zJ+O1z-DpGes^(QFi;}CX!fRKrteJUnV!!@@Z65slsP!|4Li6Tn99>B-A&;(2JUd?7 zo=C=8v$1GC)|O1S>YjP+P1$k%~1DToi9lhXB!+&csss925wod-4DoK(Mkc zk&SU-eeuLTAH@KVwtTcD8JigQf?rUlc02~y6X3QK}3HTbb%~oiQgo2H^82U}l%(~GG^qM(=FvAN(Q@Kqs3Hw{pkVB64wx z90!9Ol=eI|?r%-^r1C_H_GmIkEu&x}6%{nSi9~|q^hCF$by0o}2D+o!E>%@kCJ}3m zF)U6C^1Dg2K&EH&=A;1EHz<^|=q3U>D=EHgI!%zD8V}}T8+u}?))a_ku90vPQ6jC#+ZvB% zS92Bq)=aX;WEm@&CZR+~R8Es6$(%g^ZO|Q)`~gP`swCVL?GXWx#xTkm7t(CY?)=-W2q^qxsf22W!&MotvV4O)Lol-4!K- zo$rpbSQEq$6>B#c9^f}=E5a5pDkLnR@M2RP<@rUDf|<5NdwWbVvmz7g&E#_%1m#RJ z+A6KD%%l@35THXU@B;8YtZ~QLtf|PxHf6y#23oCNnxfeb5y=H+%%(&> zE*(h{s14X2Pw|M}CFrvRGn5DEa!u*>CNL@qP0di| zmBuPoA$lXmD9#g9FVe!f=9^O~I3jHp+L5^!tPsJ~pU1EzntKifQyn&gkk%6uyuJA> zwHJ27v*SJ*WM$OT8u6~LUq3OvwtL&wp?ij4cs($hoM178Dv9QZH%`v()_x0FM0=k|U=cd%(_Y-lHJ5MVsmKN21o+CH!g zHtEpLp}`#{j`K>DsNh3LEJHw3O_L`HijVRIab71*2b_##c4u&u@%oV;J2^3&yWFG3EMuJgn^aYBmKlj=Bk*JK{77M zK19B{?r0b6cbM*&^dz$BRCf%PQvDpVPXTCre)BC&n7K6Fa!Yvi%`|OUv*y|HH6Mej z%YFQ|Su-S?)1@<{o7gCCW21b?VUTkKzw^&%9Y@so$@(tZCOn7Ogb#Tp#^=HukU>7o zwlHNDQ{8*JvFLX|%`2|442>p5wkFu(QEoLX=RmG62eYgic3T}(Y*Pk=inZC+NnjmP zE~DH{7z1JI*hx2Hl2YSHiDhpv8a{yRA-l?SODDA3e4{}#8oWy;_EnKCXz+mE6>99{ z2%Wiqn!}W**vMEkL0G9}nntKd6pa~Ajb9EyiS{J(Hust`S+-rM9n^o!cI@`-W;QYDHGTJ< z-At>0MZOvZ(Q4v8$>cRN{Tl(3Ow#lT@E=l_)CA!eyO zRc4;|kVjERn7CU=I|G92=u5$9Yilf*OJ`|4Ad`)?C0b!-@7}%JbAXvT7nAv5{+D%|n(2b`}$F%=TUJRvWyFjD~8~0Up&B4Q(Mo?P3I%YJXZ$m?}(v zqJL^=+KxF=IQohHBSS~cn93lb`Np39H_Vud!m+}epXfg}^rjgzr?92ASlALO{$4)< zLkKuh<|Cz!QsyJ2&Y7|hDT^s(AyO7QQ|ghjgi`8}vc#FP6e(d!S&EdfGo=A3%P6G* zDa(omhHoZJv=P7pK*;%I-)60`}zG4b*-F1OtI}`%^b!iy*VPu&VG1p+3l-DLDAZ6lACQztXmuX_@frM6Vlf9S@h$I)^~s77 zD<=e5HQ|Z*IewLLvO>*PXpI#jZ7=!OTA`Z|@{ufSD_KcQ%pt??7t|MgUhcs(Jbb{o znxenUA{(LLAr9U_!RI)5`^Wk5!2y2Umf*+woB46;HT+n&fFHMrg1gxiqJpdAFxH`LmCpF3(lHk>eiFKOQ-*gZy~-Kz}>}AU_^K&>oK}5FU?e zP#uq2kQ|Q?=#9sG5Ie4DJx_CWKUt2_>M^*@ZH>oTyP9}#Y>y_AzGaMj>jI;p#%S=F z-Lr1Ay4(`n0w`-TB(W5k4-*Wm#1Q(@LA6@2GzcRGHc+Bl^BUJ^m12Jf%|cX}=arJAI7Z#={a1A55g z)r{*Vc+C=qR~V~o8b~GR>!dsaEm((Y%gFGN)T)i^^!kZUU!&h> zW29nn$1T0=9P-V4bE2I zP!4ZPrm~IaKzvoX;bPg{{24x z{(ygf$iLshjG1)cxB2%c{7Z97Z$3)KGi?M|p;jw|fULgw5W@7<*otX4fjQ2<-!Te~ zzOkkp87(euJQo#jJZtgZa}{4(uDB%xkc4vxfy_cnlxB?*BH4sE2ZWnh49;&XxMgCz zTEXT`4d-Y;q}3c+^A^%nA&ve)M_d1FWqk`*e726uga0s3l2ylDXCuJ-CpH4!21ejP zcbC(E?la5cAV92Dh=s+Pp)eJhXN zj6}C_E4OW_qi=CrEQLF)+Ji+tlc2n7W4A|lHv~iLdMDEB8R-RuayZX(;>>#m4uoqM z!z88_w`oC>8QsQh46j6vOw@QI$^pad_fCX9c%Ci3-B!KW)H+*xZ+C*fox$IFMuLv{ zG^Viq!&${}RK&hx0vooXUSV%pYRubQPI7$La_m=WM5xXsQXN=OYR6`2{z^zxwUQ(@ z46BVh^c7DKc^q2hj`Ji(#1;VF(zDT;EdUWGK_cg z4QJ_}zS;e=1^dp5#P(LCUE`TLsgSzbXmQrxa<2MoX4l^;OKCKMnp>aeUwf;w_ExU_ znllTW?r~ZaZ8n)@pT|+{mF46M9lFg~UmMluDd~WwxNbPtFcM>I&tl+Rro^FrV%!{E zXqU;xa<;g&JJD(xfb?7r4fj&xQlv73Dk)fMNq zokh@VXA4@w7Bq90+|i;lj76rHL+zQGx7SE;?dKjUI&JFZQg&Ul`PS)#-dT<|G-ISL zV(sOhgFsyjWWi9m!NxWFq`fT%EPJd;I>(x1Ih;&U?>U#Kcb6+YU$w|__`rcjx$!E6 z1*{F|aktweMx>s@5iDR8uw)f~IWc)fT;pDTH1SMl*YYDzbQS71PsjDC$-l41l%gK% z2OE5@wF51xU2WX$t-+|FT~EtsS|cxX=*V`!$fClP7g7l-$j++ZGNWG;pk4x+y9l7U z@<0jSCW4s<%&3DhLWPK~QLCi^GTtIe{%0~#DicN#hkBl4T~mwdD~%uAuua zrwVUi_UQAaNi|e`530W|diaW{_Ixy|MWUKsfBE82q)^`*zq}ZYTfumNSkQx^Tvy9v z*x=DH>aIp&H#*zx>qX1_v1~S-?KT!g@Dhl&b>fi0dIaa@`np@v z$tLqujK2dDnE;<^!7js1TyjHCG`X5qY8p^?Gx&cW^XqS>3!?7GMoBf_>~M5m>*cZY!NCbY%D5igF-XntcO6RQ_% zLRUn+FA&A`Dr$9oC>pt9!1HuQ4@G%a*k$x${^uaJKZ?cW`~=~d?ba%dK8DnX`WHtJ z*MV~k$A(t`4wR=12*O35YxGs14&vQrptF4RvH?$Vbn9r)x%wV?gD??|@+KtWj z%+wn;?p;XK@_c5VG3wEA>I~=JDnVwwQBDr&cgP6?y%A5Q>y1d&kjO7<`1dCMT`Mta z8$g#NiL{bLcGsvK5`FE&z6t_&hXS{rLHMBbDb}n}!1FelE;-g?A`L{@^w%ZX`Fk6K znf>d`Gdt|e?@CphXs(K!nVn%(Pz_sV5%X2$1c@0#S1p3GJEvrjQm!!Aeka&IH#0i# z)ad_a?yB{OcH>T)zgh)4iMKo5MuGy8Ru4XOU;o(FCiB?Ve$SGK-mA$L1b62IG!jb; zD{WFfUFfzBDXd<$tUKD8#qkw%*@^K5=Br~9*@NSsPmRw}y*Gt*5mN9zIufAOf%URg zv)oo6jK3_kaU>&P?fKHuCRZ6|w9yoEWi@OpnuEpX1+-<;q_9$lRDBDP5X5;Nsy;W* z_>d^iF3tFm1}Vqpk=E-bi8{)(-?NZO64$jOLXl3Tq=^`JVkEghVraYrtD_(pt{2m4 z!mOm#EG!#+3;DTep7CL6-kqB9VQL;}_g?(9YbSve0XMWA`~Avd8Cl2@0;$N zn*6oLxC?kW^qiKWiVhfCP>9sRE4%|$sGo|AoScpyNes`te8}^7XZ&(R#g7ihnR5mH zeS@~9y0kwUPV#Gne?wee!d)D5%n>6w-|UuWF%_W7yXA3Qug8u>H%F!9aokgny^P5h z8A7~%Dgm4h&5U`BEfpn=s3F{+CE{q>M~$8>6!Ltzk2(X6mF4*LrEY$_+(8e0EGm)f zjUiT6o-Z#qdU*8pyv#~V(|iQv(?$b5_81MjjD|7V*Pwn?WA-cawA*yLiHU+4X8Ui4>#Q*MjsI|x=%AcQYuFMkcjIe-or~Gnr#8}J{!?T;Y2TTP=4gZKoA3^&$!*|H&%E9#tq&I zW1Tl>v>F3GzsINSCm(j76THqfF|H>t%h5YA@zA@vh{6YOc1gB-uZVbGKBUbtEvmz- zq@DWtna-h0E_bWccR{r>`K_A8o>Kr!^VVtK>ZXB97Owo2v2htdiG*w|HLm^CwSHr4 zrN!gUUQgJW4K9JMq2 z9tXXYcMk`B56gphWAz%=2zree8D6Om9Tym#L0|^~sZ?OMsu>6i>^&kCp1&QfGWGGe zOCL{1rbtT{LJ5uZY~n~lKiY-RA9e}lN5$NHqf0xMM857PyW@+C$&r(9cI(GdZ%qEO z)0OSR!!yry78VyfwaLcrH#)U9lOr<+QaX+aqzac8)3uXzDJf1d`kU$6Hzt2}d9hPJ z)};!4E3QDR*PGk?}kPQwe^A-ghs-V*q1stKEvlIm!n4psr z1sso{a}os{hKNi>G3+vV?ix9Hmtr3ZrAAJo*zmEDBb}-DP8;1LCysS?LNT3Ajq2T; z|E)i{oZHGxEAo&hzoC(%DAo1e>BEtD*K4RKf!~H=9Oo{&aO5K1`P!E2(#z7zUoR$9 zRKku*hvS{E7t;+1`mK8-2{2#mN}fELG$m{DS6#^yN1-G)1FyZ4#t2}fmvx_h`j8eK z)zixuw=K11OG0v)2F)Kv^BLiEh{tTs$jE~xXGmCD90A5S(GdcC&!P14E!P#(*QMy? z`Sf+^&BvkET-pgS%IYMUQ35hZdsXbOs^mU zsQ3iMH(2p;ioedvf5MfY;w8To4_s9DsooujZ!1inT=vHwVjHCjpW(W!mBc>a;)ntnW=MSK90PMm(D*C!|&-MxAg z0Y4pyYrUT{|3Om9L=iuiH+6Br0lPps++5J9f=+bX0I%$4=yf$`pCqlTwLTF^%>8Q$ zHCmyiPu#KF<9T>u{JPlo?YMlma^=b}F52}!9NsbX$RN+e`@{EbdyuZ^-4ovV;I@_M zazp5H*G5?fMnVymqvM_fW zwtRRhJ{o%O^uf=LGScbBR7bV7e6fd!l=68iMyzeT2_N4Wb#|G@s)+@+ z){XGwWnG+9;K@?4d*tM?$$yq3W-Z6!Z<4A)wtZ0bi&I*yySJdVHG2>03LEMYkD?M8dyyg~ZX}mr6OYiSz7Q0vZ~p zPVi})nMv_!jswOvlxZ5% zR;YnpOx$AG2MhLJd5mokY^S&+eODV}^~Tr&W31X3W0|=RlmEpdB#AS7heIP9;;+qM zNMvFBB^^e(#kkL2`bG&Lf4_*Cc1Hvj=}l4m++Z4c7*3yvU`6(wFGcjI-g39Ec(-1p zrLa?Gj>9XE(!$chV=ranw?0fMv1;Wg^KwM<9$pcpl|!r=UQKW%>){1%=!a$=DufEK zaart#U*kdI*28NeTFVu^hcAok5xqWY13om9pz;K-zNOy6@z6|jDTKU0xSSwxcXUDV zVla=^ABi6AguF!bt_XP8QqPTndPsC(>6QzB&=sXcP*Al=%J7OJ3ERy|67H zDfq?VWK!g`%12_ZeSn2`f`SW;`$@!qMS_n@cCl0&z4Ad1oph<^Y0jJ3Y22SM?q6@* zuiwBCKHeA5*OU77{PmNK^e~>h1H9Z0_SY1!;unc3eS?!IDPw!dnj@_>t_D{0Y{u+~ zZnhpUcHq)*bJTmd9<#YRX1hUz6+qn3%oPLrGm#DYTUget&(xzHw3}*xWOV_G?o^Nr z-L7SUv6E}r32|E*K_%c9gMNW3QF8UqLP^T$P_;fRYyuEHnzf+9b{F-z=$a5o)4t*8 z%^mRcHEWGUp)rposG<5W7h)X5xEyZUFv}GF+g+eC>tLuDangza*j)1 zLPsgb=iY}aXZH+lZw?RikB$y*1(@Fjm=D5AW}M@N2vwUFJB>ESpnyhUUc3~F^a zj+Cz^5Y-sj`ZN?wULu|(i{NeB~Htp#u$=MyoN!I^ZkmJKiaVT z(SqfVby)sr#q!4u#>cVz;iRT*7@?zu)C!pMf++Uz+)Jsv2#{bsuXe{e)r(s4LHoSR z-2?LZ^h8{=fqC2!%kwc_@AXx9)o#}tXgbGdXZ;&`(s{a`?N4WMY1p{>GD#vzdYkx{ zk4K*W@+@tn%EFq}VsPSY-S|=N#@^+c@o4GV+G7x$5oqI&Kr3VL!a$6%5uynpfphvx$m+^DTO%k4=3v47(8)>`@8F>E;D?O|dsw{oWQ>Pm5{eiPu_fl&!_y7V zZrR%LuDn(e4x&$jxf`wMiyZEW9?no3W)6oVwC8DR5-bjx`a^msWjaj_<&9BYkb@GL zt!rpgO{zdOv+(xILhf$fCh_cEZtS{RGA~s6hLGC>ODY8ZXdA1D1yp(t&(%N zVSBOhZ;d1j?{R>jjN>ld2XkoLJv6bCEPx|@s1mFtvCt$@aiyRJTw1{>hLraHBlj}Oy zXDM=+9s>Lc7&uPLxX-)9*tJN&a^GhL3G`0_ceFuUDa$tzSbIHG5gMWOsG2sLqgW?K zvFEsT#mS%K_ZD^!-MP2x6Y)F*w0>ipc7T|31Hpl6>=N@f@g!1b4&T<9F9+-J!i{+i zDXxM~H0nlRAXuFIWnRbZPu2g)1QOpn{d^+cnb7O&FE36u zCy>9BQBkPBIP8d`MkMgAUtatS9;ghz)55eet;g!(vs4A@#}jj+cPBqds{cl){8mD+cz6EHl16r*Zk#4|<)W&@O)Y(QQbHCH{ zAF$u!rL74d%}3si#Kx_q=N?K%v_?ur-cRup~0t3a~C_c%34OyeFGMtK z3P!kdHYAQju!=czpbPR{Kh@Pmed4oNxOfAr)X5{0|1kN6j3}SMePgFaNqYI}te%j$ z*Yg$FPB*3Zv#5Sv1l6ENan1E?WfJ0_#h(id<}YTv;Ql!jzQA<=0`NJgb{Al*1u)=x zdGP9l=d*Grn6QxA#!=e`FbpjvWCd5J{lFv(MbxM|?na)EsOU1}Kgru3p3h5v*RL|+ ze;)8Ji@@?=*k%@($jk47;^$=$pehB^Cou@Dj2>>J!%L$64=>0dtX>#CtuUyW z<4=Gz&vl6iPrB#3jJPcJdj1sn0HQk1s))JnW5*EsV;uXK70a)(>SZNK zPAPVqX$k_UyqQC-t ziPHZcB?^0?f<^|1Pd_s_s-K=1QS4oPQ|vRTe+BmsP|2b zuWQZp+!}uL<`rw&!{JQ-M+dE!>|p<>^>W?a{X5{O2R?cpZR4er9lvum+Vkl0N29lf zRo{FXE0l@BduLAX8yq?P+_3Da6bFaj`SJ*uk(-K(qIN&>*rQGCP3$Rzw9RrZ3D)oQ zBo;GRlX{QBvR%UseA=tKXw0{Ly~k{--Y%?=3JaK>o}zj~31bEY~^yiOnC zV7y5U+WW8w>%8}FH6n=h=s1atzRC#j;RWwE_3Mp_J7PzM2NNthh zaFrNqIgLH3O$j(az@6(nyqSn({*o*aoV2ZIO{Q~jNXRQFSP1iXG_P5;#!G%e=D-gPpU!JEymp0TrA9Zt6Iy%@t*0k$B_BOeLwJ0d={V{6T zt&yV^xC2b*VjB64^haCLSsa(X3imUznU1E`#S_<4ZOm19A zM#8e%RAKt#!L>{3o8%gUZ*XU0?5v5-u3`_X6}}v?4`!wYO?MLn%KH!0cn4f6;f-y; z6o6}b46hnH#d6fl-t2I^O68E--rmy;@7)qu!4CG(m$d*|xd7P@Pm(#6;(gZyXVt{m zQx*q4W^rn#Hb$>|gt9QI6b|LUaIqN|6tSAT&X&+I;fj`Y8t$$@N2?Oxpu?+( z$rUqR+cP_g(_XUT5g5i#rZZj%fZmfJLe?aJh1o4gF&2wOiyAO){DQjXj^ z0oO!31cYJSYsM3c)^$nxRo{3os+w9&ODlsN`3ZiBrju4nR#>NwJ`kbCk63B_zyfyQ~fq zc$Sz~z{^+yiqg%lPz#~Fo=VsBy8Vaki?9Jmq1Km|`|%KauS>oJ*Rt4^{{=XsHa$`lRtN%nZi@Ji{&9fI(JZ&8zefB~d~DwaGl2`PQ)GlHOlA>D8t zXJ%k6PQoudm@xyExLWZ_e$0Y|j}Ja7xmJy0eb)&-0j|Q)6BvYVsaetzL=K>CC_IQR zJvLAi7$qOif_+2oSLkEvK3tvtk|W@T>EkUR-wb5Vo7}HFXZ3xal6+6Pl6;@zNGr)AhTv}r703IkENXErB=KAva-;}u22=yB z{32*Rb+BJ(?t4L?&@YA(v}!Z8L#k3~u2)ekz89TP83YLCEG4t|+Z@<&s@-X%Ss;?L zmB`Q8NE1*mtr9P+Fo4$Ez!wg`7om0sA$$CcFY zv&j8(ySWxieU3=GSypHKxe3{ktrWgWa^)<^V-wYe>_(=fLqJOj%`ENZc(srxuw;+n zpk|D;sYyu}Xc&E&HdsGIG~BA9Q*NgEv}}3N&`Q%&Y2Ux`?{DPS1Wd>SOjUO)d@|6H zIm=3>d^TE;9I+hEmdT`qevk@VwuvqxW$8cZGM3g>nYoB16V6DN3gm1Sd?kf$TpeZY z1^_qCtdpU{`9%sbTBvx2j8{g_X0Jda#6YJ?b`Y6k_r#oE#xPTFvh~mLs+8n0VLBq+ zI+UkG`M9ORshH1nUCH(k17c=j_Jl*cW)4&RV3_J;fzZgCkJ3s%R{=k-b^DsAkbgYebw=8lo48pGEGy;CNC(Rq zzFTxGI2JO#TLlgJwdxh+#;<5qkWQ^6usCOGO*5|$)w1(!ktP~t()gf46Zr*Zy@9C8 zmPAJr4Km8wR#U$wB>7t4CtASccC`{LQ~&y7RH5Yd^Nub_tz8?X`mqk=CtS@s+_*9T zkxT~Qs6>*=*C|tdE3+UXD%y&)Ny?P;zN=XstQ1M_Z_R34L?;Z0)8aU|bz# zNqXD^fQ5}!m;Vk&2d= zQ}t(}1r>BxFBV>z1sO($WP;VHh+>x9xI1WJ34*|6F}7N6(UAp<8`-Ve=-=rC;)?V$ zeMvMFSGb^65o0Bme~Fsp>PSC#w6;;1k|z0gQ=|x(27n;;}4S|BCm1H8ikm2(% zX|>ibk>(KSV_TR~nKb(IQp5yhDkb07RE&Ev!wY0zN7ay;?(pMJ&5#t7)n$TUqKm zCt|ayZv%7@$Hb5$O$=4!nKXw5{OpRs#K)|nq#>dY+$zyxv_%I$j0EY>=Z&@qiG`%} z>Jsr~_>eq5?_rSi2{+UtnQ&g!?EedXWoyS00SiG2NZI!!n~86W$uVomlj(^{11Z`v zvCJ1$Ko8s1xa5Hr+5KDsHBs@7bOv7|GlyPPyZ1nY?2P6L&c?72?R{F9czxm)8VoT_pw)|zoD87^Ny_X-vZQquG(p}eYo>6!#~T=(mA172G&$am2F1<_3#l>q};Nd^&36qNk(YL0g-QBQX7FXb(SlygUuF-CVyK{RPW{84Mq$bKNMl3q$2oJ49*<< z-34a^e`LWKA)mj{dvCUy=X)VwAwZ1?beS|lBc!O)&|sGOwg~xfwOv?TX4XhK{CAij z)Sz7QN_o8R0*ch*&LmSEJDCNT*^}ttFVLA{M^J3z*Q$~gwq^DT%DyJEGP^riwK|$c z{YdRsm`!9Urg)XD1ZioCl}fKJ7IO>jO3STJD?^=E5?lyy*-|4&2yb>)(+FZ(Ko45T zJIacQYBhm|5=W}3MpUHLO=YW}+TvifrGo7iITxTAtl33`GE5NkbvI(>s-NUBNov{V zHcU4VhF^Bw+OZB^rihKL8qHn&a?xBGYcXAFv_wT-6%Z472YqI<-oFrPayMlqk+i5F zWq3YL@npkU%9JZ%K0vkk=&OGwZ)8AM8oU&mve2M58F)bEdw6wMsft?RZq;C}>7|lLpozX;g-!BAhkR7(YR(6_ zlwxP139lJQu~?gB40Bnt?SVfQP-l*uHFyOMDkAw$nrM_Iui0&^{I>mDhR+1b_nyg! zHj@$OTSrmhWY=M_)~d{!C0LxZl{CwMr+=uC8B99aZptiA70PFaJI^_2k5Zb^~?N*Mwt)XA#-I9b)kr`e|D3>^RB z@Sa?|d7_g7d*g6|bF>quDEYuxl8>j!p-UX=qig&>@(@(dew^Sp?^fJoEaEj@eW`Z6 z(GTyUz%*;*j15K}pR!`Cb&_r}9RmQafT)j;=YbeT;e~ z54Xeq;ZyefGvMJ^3G2m-Dn-=WxVbHK}4NH}dg~^5`@kiy4ot zG8Qd07F8RI0>4Ai-j&Pf;d_y<+jv*<4F>PKa+hKyb6P@g6wqB3E5U3!7@YUN5qfF8G{)caBqh+WuSQ zb)y=Em%@(+gC56)p?KogaI$WQnVR6>NPVUWX2AU zn0avkcvxis0Nn~AED%QZ5wi*eO$f+2qJW_;D_FB}`1RtbcjL(G#gUDpI{$j{+cVNb zuE~a{hv#WNAIf8SDJEF-4@gu}j!in!;cLWaL~u8XoRziUZd4oH)`h<+ zImK%D(LdzC;sWALfhFea6#S4K+9pNFI7rwDAymR|d|L6`*$36exqt~!=8FC#%s67wGLeI}cM<;exUZZm;X!%8YO~SlRK=^o*9;W4KKT z1>J94!b6?N76;k4gXzbc1p37i8B4*p2*rO<=VS1`1wzXOrl@@pP*+7p-g-g6jqoi+ zdq9P6QTF+WC(E9FiP7`LSv4(}n!F2{Zwuzp!@Et+?pYOn2}2ek^ty5#H9z_eX#l=| z5yc11HefWW%Bda*F${ktFk+>Ypbtss%99ip*3~^*gMIP7L zZ&6%nqat}FddCB6U_H0pAxY201#%Q?8Xqam>@OKkM9UO$!a~Z}WPh z##9u}3*({4@XX<>_*KK*Xr#fd1u|W}SR7>i3OS~t+BBk$zdS3<#@RkdBfc11jBPh7dL*8=V5ddFy`==-c z@CxXdW~ZdESDwp3&;muc741p9_S*2wpR7_|KMr530=+EpoA-7;j`~z~cp(zsAY$B1 z(G8XeZm;kKXy(8xUiY2sPG2j>e`7Zr7>*L_4k2O^I83tjV@G|Y&sdAF>l38 zi4QX(&hNvInK>3*M>XlsU(FSM)vD?%px=3UX(V`G0XQcwEKiLL``}r;H11KN_SK2~ zbRFIEr_s^cnZwK3D_L*;%HNOY>v5falQ^bj3qapAzaHk{P-rAa_sVAuUpA5>M<_EB z!#VPt^4bi0xgW_*AsH@P60a9?Q^;TjDbMr>MMpM;qOTW+r=l=VkSlgh`bBD&f_m)zjCtu4mh#eP_Br z{>MD&sfhCc~XuyXNg_Izp@Cu))AHwSW+b{ zscSCOS3bk!kwH1aCs+9#c^m%kJi5P%xFdYN4pEG1J34s@Ae4%_mIyXxA(nk zBib2(oz)TF|NZ5qI^tszpO-Vfbu0_)j88_$L&O&8CqE-FY}Hq=L&|-Wx1xI|Jv@gJ z@(^q6P&vnZ?}}r-SKycr*0Z)~!xUS#8?M|N{}hMf_3}+ADC6qJXfnz7akIHbOmD{N zvw4Y>T+z*jTe9g*xtQZSn;u8wO1CGs|7i1o7LlLFIBGxbS< zePXYV%VRg2?WQR`4H9kBg%qJ`Y{u6TlJf7I=G*O!7h zg3roO&pzr;84WiZ4Gl)a95oR-d-tVM757h!FLZU;d^XB=ddqa$W727lnVpt)iT7)3 zMw^u@*bQuI7ti)!kFY>Do`Zy0+B<+ScChUph>m8p4P2io*lGVgcM5-O5dY#Z3(G7@a`4 z9jn>v!Hg&jTtWUBkF^r1)iJtL7meUE0mxr1_9%KX4i5#Qi7a$!(|x}d%rJ6{m>}}J zZPDTLo+J!M6e1U_Djnq0%c;s^LeJ+J-Do=;vCc-96zBZ>_WlP3x9=ES5jI2T7)=Oo z62~jbienRf%C(G4z9};KrYVzj4B_HA`pQLd^d%5`w#dEW5;+S&Iu=omhhKaDc<8{V zEDzrl9)68@SSLKBd;EQ~IQb@Vvd-k+ig03VXeXAd;qIJyxr_%|>Ga$qIY{o5N53uo zM?NG^0{M0OGnu#z-Q1M4J3d_A-Nmb3&W{Ll8Rz#5IfAP_(}$}m$2TU%uY&wIK3+}t zp!=FyZ~-w+pFzzvI_S(C(vlwfjCIwlZ$%TlZ*y-lKSup3zrD%7$22ul!S`Rd=5ylq z%~`n72c*siH?Q@HZRhu^sn&0vv(`VK7+>n9NG6>;pGvE_S>NT~xA^ya{QG_W{Q>{V zx4M7C;kWts$NYPOe|dY_bE?_c^~{Yub_DlJ5U4v-{H- zqY^vvFF+=&>q&GZ*?>M`7XbepTfKOOpeSS>){(^8T$QN&QUTwzk3TLl2y% z7`eM`8R~BJ!hIM^5!%WoqzvAx$ljBz&(k z+vAobQqkWQ74>ba&1`gfs>k%+(Pmy`RhH|&+StMq&pj90=yz=}vl`9#NW=ftYB)zy zfiKa%2Ywc5UBr{^X!KYqZZ-s;Q3s5R5|1FCdQnFJN+&r5p~YN_ z76qb%7i~DtUg4fjw`a-RTD>akrU0??yCMy+6lhxm%8-p0ttvBGrPKmuo~yXsiygAy zGk#aK`z*sv@G|5vtsZN*2`;u;#Ryn6&o*F!S2_U5kn^0X_CkjoCoW~h@4G_sD;YV{ zfcY+w{Th&O+vvk9!WsUq(g(wKiJWoZQkFAs31_Z%apo=J z%+j))X$EUnuUfV0d~MD%uw>2b&hkBB$@ff_G_#dd!jfk0EH_>-OIAB5YO~}<7fbA# zXWJ~nbq)ZR$Px!GWm)n)VaYldOTKsJ&awt9*-od;?it-Sw(H&<=h<1xYO%FtwAlBB zG2gcs!{!Y!W^Sn#Yq?;?+~J_B&6pM!W9*vQuy7fZ!43z2OJs}#m$HoczA&c4#hCAx zXUy97S&OaBmeFEA5YGI-;*3}uZqA4n%Um#Lx*deIIg@d5#;%#icsFNy8~`qnGY(wJ za^?rZnI0Eseo$VE5og{PEw(mWMvMJWSn@-QCDxGd=q#ee?z&)>-07gG&62xZEU{}Y zGvp6A09+zV9JrKa$q$7k11^^Q@XVd%BDL6MWrqCbGD_@6!WS$(h$+@=4ft|ujMv)5 z6dS!@z6?3YYV&2(#TUEgG6Vko4gigs=rGu%f@#SVO(P)Ck*u!ED**psLN5 z{jPpu*IZ_(f58FZ64~Owr7T-c2wProvE@Wrwp@Y@R<660HNj2_Urt(lvBrA`UqpYs za>0CYZ1dqe@@l6$=-zg;Yc4b1f9?I_ivyRkd^st6`I?I_C(G)ui?P7UGo+0EIwcG_ zWiiAW=p76Z{dM?)8S<)wo;E`cyE=+pbD4qubq9b;>?jUg$};4XFywU?Lr$Hsqg)i!J+FpOUL&s^c7ALH}Zgm-ScuW5Affx%Jv z4u@SgKCk-hcreqG$M--oxp};5_;*}q@b5g{MRc95p1!m}-)PS!I^yK~01$fzw{LqW z+`4W1ecNbrXxkWgSMd${`6dpKpbP=>{4HI2tHhQ;Z)?(+Lx)6aC&nu}qAl4(EQzxa dX1@Q9>je0WL3bvBFWR)@$MZaj2j7{Q`G3XcNpAoE literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~4~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~4~ new file mode 100644 index 0000000000000000000000000000000000000000..c12d5629701728ac77ef3d2c801cd2c919155917 GIT binary patch literal 47097 zcmeHwd3apam1n(Ii%PO2mu+DiVN9VILkr8;G6swZR7onSN-9;At4g+H5*#6mlon+0 z!j=x$gru`55MwZUU=l;<?({PKC4tY~nd!_h zn%_C+zO7W=>2LmNgX-OP-@WIa?Vfw?^3L1q3HG)o!>!xyy>DoAaC>;$uATSo+8MrQ z+xGB|ZM(J)42JJPe)wZ;xvr1jR@ip$;O(RR+qXY_`_Smnj{9zpr8cH>wtx3|Pnt?}+?wkv05HKp_MSa#+5)ipT>)Pe1T{W}M@hBpmv9UI)Swg2H2 z;pTPW&Rt`J;nnMIxn)Io^{ve}-Fjp5x*ONsbn}|#H7je{qq(GDWY*2^GHb31rw4X! zyBkC_uWDWeP`9pawkof>Wo6CGixd0x4{Y<`-$$*VIh2|=Pvh)Lx(Ru7ZQ|MS+V(^; z)|!n)^Rc#Mx>ff~JT)F_%;lr0wrIAkDUr(bD0tNZMS|U0EXIP?TJ*ZiQuAodpZP&zH}y*(&wN;Al;J($N-X+ZHa7* zE9;9V_W39Wc(moCEy>u#xEBILRz)V-+7<1HP3+Sro*u6Pa5H1?#Q414ST^0;)SB+@ zPN$kkKojE?N<7-cc;I8HU8AEP_kbau6*e!J2h5NnCl?VrB&j$9$ZJaI-9d#6FO#_( zWL6S=xnw%p7Q$TxNXlf>8SfRinWr!iZ2)q)fLWmpY|ateYg}c#R|76`Yt7tzqC1w& zEu7d_O>{py?&sEwE99;!m(TXJ=6kZS9C+f-r_yb)39!Q?ePW-N8r&GoCWx0*s3PB& ziFHSNjjM6v%Oy6)klJ^hu?)A~#%LqwS2RYGnYg;~HnvEvx3Sesv`Ip5Omca>F~e7H zW5z6zm4vS`+ia!QNGjNvi=p4-%%U63M6X#A2s6AuG?m*FleE7j4L#&+e`_+D%W*Qu zNulSdaer&NCzU5wv`3RUqKuM>R8-LPCK3tG(-YnDtc%KXGC=)THC2^K#9Ctvi=PGg z-eg)J)3bSVQh@6l6v|n269Ju-C%$YtO^}}&59VSUdSD@9Kt|7{xKw36)}3jhAHMZL zj0#|n0G!j4O0@Si<$79j1Z7_@$K#d&78Nuod>Ba9@jvN^G%s_E4ZT0r5(<~r*0jXVlw+7j*UF(u53OsqGP&utKtGs$SHP+yrz zCsJTQhcx7e3MrWfI4Q9FnOs8YeIR2uSRrW>6@DNLR8Q6jTcr0jWno*D zwkPH6ewBQ0_fxusz!)r-6-&tX^XZ}7H|5hjY;wLY7mF#omy6|lgt%%>I-62C?b%E^ z*~b;Vxl{`${20ZvqQ_PFXiq+!On3At8PUBYeU@T|@?c%ADc#-#K_y|S8OprUTqP=G zZ^RhIWrFHPD4c8FIgNrN(-xtfnTx>-5nTOw3|nHk=TI`$VG9V)dSZgNH=iYX;Ws=x z?xR6gMm?<&_xk$v6XR>Uw{0D|X9$kh1B2Ul3~d_=Z@VXa_x5cM?idU|SQr{8gtu-R z+%b0T&hWstu^sRO!}snQC`|108yT4F02?u}$`xYcjI|H8k2Ffo2hIRtlZ?&KzYh6^?%b4pf?8q<*b=3#TrT7i!sk z2$0EZB7uQY@+amuwx(0Lz9!p076|hjquCfnx6=H1jikFJ+50YMHW4Cl0s3f&HZ~jm z##WL|8*FK|hgDBn7oC(etcOt`{H0HDmSab)~&0of~+2zfUR4UHQJcygFv^&#cm;0dIQp|^ue|myr69CRw#V1EuG4@ zrZas=*S4i&8>7hx`a}jk>clhTKvu%Hk0#+@<@QKF@sYbK?qrahOY#pud4ifv8s#iL9$Jm)~JF9)}*8h%?HOl(sIjEc3{-br8`o?J$yn=l5#)v+Jlh)GI~ z<4G)ggVFE-6c5==rdv8;-R2t&n$h50GO@3UY(awu{H{=ACuis^{nMNlqao>lBR}X! zS2@zvj&!Xf9de}SOL`FykkrNfR!r<$4Epp;&S;>HMJm(8j3?EsLKY@%S?EoU)z+7T zHGpn+;z0np**?`LWr&%oOu#Jj z?jE|<>IdO#){YfH4k&ECCxx90#0buK3J!N@nLkB2;xgQUj&ovajA7`V52 zG#y=x%}fKE3!dAH4Jl0uAkY6GpvrJ8fx0ZkFoOwnA{U2)mT%8BQO8e{!wT;*o12Fs z3+y5$-k9yX@+}&?i;RY9wgDbRiw0UqQM(wyrP`lX6s8K(pXi?&nznO}6pntP|H#l$ zGp900Xuh$h{|z&zqHwJ6<|q1(4ZUgR%qeWCEf%(fioe&7#1ImWC-d>7j-JfNlRD>< zg?O@fEGvG5(7tNR@?zrI z^zwL}r`UySXPsV5FHhF_iYeT6*9D5{(EjxDbZuR*n69JL{JN@QdNHLI)>RkNODI)e zS6fVnDYdjNR7@|UR72f-KvF89)p_*CXYfy{#T`{EmxWq z!n7{tXksp-o78;9at%W^56@b+v77*E4eX$lT9V$q@en^4&_f=tW?VPHYnE`l!dPX~ zz$!ssC*u)l!8%l1Muv~1R&89T*H3)<8cp|k{Q=Dz(EYwS)io7CpRZz0u(~EtHMg?1 zrlxjoWmO=c5wTB=SL8CWR+=td$5d9^NReYy3*w|{Ue|MwrrM-2Qqk3G{LTf?g(YEH zi)G*~F1na!8*Q2znI_#=;SW}N16BS?P*NML^v}-mJ8)^d09>wj;L>_lT&`zaW^=O) z#~rv_&$wJ=vsR28i=N~?8dSnw;XtJAtca{|@_j`)(P0@&xSKqO)SAv(J9CcOE19;& zGt*Wxrh5wY^-QcH^9Bc*83&o(1}LO>gVAg@+BdIM6>e}+eM33CEuG3Xo&)h!<*L)V zAgd%+pU+W$_1WvMIamE=W?Y?vahx20Q{wd)YbM4o11@lbquntqjfKs%Z;xdGG_wop zSmVD^&HR4KHtR?H`!@gnn14_3?@9hW#lJj`c;4dl_xShw{QCp`{UQH;3o~Z2f#2re zpYSiuExq|DInT5aV5M5E6cV!f;zJ74TVpGx-2~=1|9;0PIQqt#a%{Auxba+Eyz#8n zd(TyUZMo`}5;v5ieW;Hm!vEY`8@oEK|H#MB20kKwdSj}6= zQiU}72ODkuvyJsF-0;~tE)V|0JV{m^cb$y@@1NKRcpDgj2i;v(Ujol&E-m+9glWR^ z5iJH(8|$3icpZzNZq!?DaIFKm*5GPx**G}L6ICsV(fd{&y%~va<5s3^siSW(EtbI@ zR`g(z&txd?+Sv5yZbC4$u6H86o{?TqD2MYrC(gWA;6S*BF-&4=ahn!2h0$%?#_&q? z$V81dq8u>He(yx+gXc-{?Y8N~rq4tF|0Q3&{sS`>~UC?JI<3G z5nBOxOV37YwgN<)42hhhfr27BIx%jV19I?V*|W6}b+!=Y7S7T?eY5*#3-+BAi|wsQ zyTvngQekzq(c)~s#f}SHD^{h-Q)Bq+H5w zE6eE@I&_<}y*6skQ_=xVb=`2TVI;=bp2fktOsPZr#JD-S&@PjW#+M@HfFbcj{e8Y`!nI;*QBU{DtWSuj*?uyM^k zX>ZE`%N}cz&aoz04kuI9d(Nfm-Q{Y}R}?u8A2{$RH(sT%fVBZV?sj{`h}3gBf(5Js zmaO70Cnm3mYuw9^CZ6f+T7Kk-u0s9h>9{^M`SuDKHYvhFv9mNh9Sv0uvLK;B>*;x%-X7pHMOX|(&(=-`h8*Q3cBxdYVZaYk3L^Ws-fn4(EN4L z!&gML=c7?A64mtj%NK_th5Fw3<;7^+O2!K$f*uUzx>_c~29JgzPuoD^KVWPGpt~a8 zy+gYThZjZ!<##54F|wX0JYGQdTHI+UTAOYrs+vGe%Su#2c5LiX0nKmJ zT|{CxI@|5*1!ewNHk;0N8;c^i2}IjEamZjjl5=x?-7V>4lX)t}-+_rtfKRnxm*FO^ zxuGYTTurNTw6}ddbL*-(dB7x`jD#8!;xv~>3F5RlyjS{xGb;@FJlH#Rb}da)*SMb!HOaa^w=s_R41$Q1*g zr!#se%Co{QqZji(2ebWAEH39K2+wS{R%!Gxq&~F2IC{7al4CeFyaI5bGG#yzF8W-f zuL5n5>^1|P<)fDkc#5N2N2^AC%ybq8i-m6)I%C#uY_?~n-mr1+LgJR^GxLm5kB(Dk zIQLcwHtUUYa!9{JP8jHoxH4aF#8V9q`DP9O-o(FaB}Z)o=<-N1tw*A}Yt#;jzII|? z1%bOmfm_cYd@%ZyYqluhd7Dg^66-OM2BPfx>+;z7dmDq9{p&0BVB-R)<+GKpX&}|)BSiNjnceFK& z<16U06XOfaTgN7{2gg638lR(jZwl)oWZ->tBtWZ!=w+*Bxotiee_3kdOh&-k^QEOt zZZgbhgA{XRHEb-JgT?0sv}Mzzuu_LqeGBm*i1R$ud~TlcAu*m^n(-kGT8_;lt=G*G zb(CqpXCbpBu4_kxBb~}f6Ep6_NOFP9(0B({M@4d6FNSKutb}S-mW{rJeBCt9_^^<7 zr)GSZ$Rq3Ci@!eT$z5b)XsnJ8&+JWv;v*-I6cY7))16b3zxEh+0WXK0(^AyX0b>g) zky&_!cc2ROQ<0IA)A1vT;hC2Yc^>bKUyiK!(cw5tuE4)<(AHF!_D91>zK!s2i0ezb zi*t@Sa-`&&-Eu9a0@Qf7T#oDY*s5G5I1xh}TagfYYIwF^{pOqJ)SV z!u?rdj;4Lo=-EOk&zJkCGvHWRj&EP;=F7_+bkWD6lDXa(Vq@j`@^YhxM_Q^;pzcNp|on4FWyJ#(fJ90riRHR^{(Tp#fsUJ}u451{wih&~dp4RJ>aMfmd0-jUESMz4PKbEjrSJ>D=` zb)4(u13&tbIYvL}+TDOWpQ}cAz=He2#^-L}>H?ruSPtEMsyHyQ-@kEqYIr&kJ-v7G z#^EEKEx0ZpKHAla>*7RDXHVCu6Q@p04Q@9@yBPRxe7$|+l?OwmJ!W%Gd@KzY>yg{SY81VT$KIK38u=||g zb*_nVJ%L${-ie8a-ql4MK7g}JvfX<{#QX9gZI0gVS=hc3C^tj;kWdJ1_vbEH?_EXpTjj@$3Ka|S>WAH9x>vCgjEiyGe z;-WuBNf|+xP|;to8guvj8&1xrTwV&-Ir$CFWutJ^F7SJt^itV9ob){`7v7E4YuF;_ zHR5D=r9E_9U~~qB9R#FOh25%VAgr+Wh*o(1cC^a0$Kx)0JRO-LD_saBG_tdaBMJRz z7gB%NC7d4>ck_)d?N}1!x}WThFD@oWPQKZ#A4|P4`O8jMu@4W=Jl9!RTv%p6GRI3|!PTwYAqPS&NQI_2nZrfc7r{MqHjPW@Pyezg0@!gOqJJD#NyZ*z+Qb#6#&4#^*T9ZEnIa7ybKIk#-ft7ZQlv)bI zQ8x?thjbX~Ln*8lw>IAmix9|Ry)d0MYVL%6hI^mt$j8OaGj3#oJP*DeFg^_%9#F^(U3OH0jrz;9LLP2LK3OF!9CnpLx9zo|M3OEcAnTlfAW%k@P za`G-EK2%DLoJ6(ZV+FPKI-MHTySe;Ze{wm~%A^%}$dljD$Whel zdhhh%NWAMcG?c(^LotqX7hO1V5$}9$%XR5x>E*8%6DliVXQjjO&ex0Sh6MfAy^#c% zFLotQ9!;8>HTkQq@~G@Z<~+mKH~VF-~-Z0N-;cy?o1c#q@P4x_Lf*T{?6EERLt=zm{HnDnXa} zQzt<$=hREi;!`J>_Qqm*{+1PZblq#|@X0MJ(~apB!~m6_p!^0aKTi4AS>;c-%2U3S zxAK8Y?Fry^Xl84A`N#?2d}t<_UYuTXDqWvm%1GgEDcvn$gwkPfB;5d(q?e)mvf`ot zdyHn4g~hH;;fG5cO-_vaajqfSLH0?@laGRBbV{d@)~~sNk~AImwx)BGmWjaEC@KCQ zDX~T?DLy*2j~mZFvR>1V=d;KUVA6@xZ*=B zyx@Rcpd8*@(5Zn=blU*0>}Tk9H5Z>GtE;s>5lPJbYf3d*sijZcvD@Q$cw+pz*!Jys z`EKRPm0`SS*Z**M$Iv5#JQME^-?!~SdPVP^@XiOftwfg_LYKQX$~G_(im)CX_Z%=2 z8fNEvBILnNP5w8JG34&&>gA|$xUlHg4OQ%$8N(C%z2R)+HS!YTr}qwpa*@QZp36rQ zCtf2nOK!kFd%U{Q>h)rz_hEB(7_Pe0aA9oMI>9-hHv(YGho|DBq4!Q7{Om|B4(DOy z#MI&1CtJuI%dz;IWU5eXA58t?l$Nfor+ZkQ5S#nZvB|%edeP34c#^Iqh>Kki)3qpGTb%p_ zd~ICG_D3Hl+bX>(msBI(3X!#Mi&1)yeOBjCvI1)W9w-Zn5lz75lF|#x^Ln zQ(cn2tBtXGV{CyjR&9*2&fJH||KbtS#F@Rrp^**o*JdyzvNHaX4kO)S+-EO+qXv+_ zU(`&yBLa`~rYL@HFr7RMr%yz%BKyvlB6?JBx!YH~TQAa5*eSEb;T3q&!rH=PFBRjv zK1?aGYUQZ&azyhUUJ<30L#!HJO>m{?;RSB!hh`osgbMI+S?z~k<3Zxq!)qd1%N4zc zFN^CDy*_FKJ~We{`UJ1OrQX8v&`fhFguFnwoFH&_bV2cAFpt(Bi5~5QzC`q{2xQn& z&&0qyB)YJ4%az_R9iim(;^Gb05PGND+csuA{+F#u&i01sYg4Yn_7TobpeX*G>{D4Ze@Y7lUvydbz2%iBajz^ zet{ZMdiBr3Nh;|uwLUCt0uWuAwV=Xw7xlU5nhI{=z8{4 z8V?bFjE4ZCJ9>C+R1^L_GaS{x;KK`s(WOOdVm3ojY)Q~+w_5J54@FFgL`Wiq&@j!~ z(JlclZMWBZgYi(<*i~;l#?3x_2FxSTQ-JVr83+!{A7K!W07N)?cnK44t(^;Y+?CN^ zJqDGXjm%;LUu={hvT&H7LipjnAPDpo_sYS_tSB+!sK6ijNf&u zp@z5IwUkem&y5wN8J@?N$VJw}4JP2@SPALcRBO38lZ!Tm;O9)h%{elZhp*3$&Oi1{ zZ;ZTlqz6B*jhwub<^UKkaa#5?#*lpCH4JK8?pL(@(T3%Z7A$|P!}3QfmOpMVK91!N zCpT@!2puh?R=}Juh++@Vy_Cv}013A9YIm$t-KZrW(C1z59+1zcC*nmLxW^r_JRjrr zUSEYb9wg?J> zIaqK%bc&MIJ2+@O_+jJ09#*eC8RMatq$0*c?1_2y@N~noTefz*E3Z|IgX)uF?gkZo zk;6UF!x^Gs=5RPdd!D8x!QzlYtZ;a}K9E`|pTSJ>_(gd2Bg|}Z8a(DAK ziD&n6W7pMEc%ia4gxnq=M>}m%?*TG$`+yZj5j4hYm0ZFN+l!5VYb0TKj{^i19Cz71 zxI^Ra;b}NDOO)35`u>ZOFnSyg<1DtYv;8UK;YW>!A7K3V+;2Q`kEHsIM}%8@_>}|C zC-gi$@UD!@g^VHr{sbmGSI!G-QFhV#rXa(+Junk;kF8P<<~ZHD$G8!yFYD%?&>grK zYr(=k{W1pjNk3nn09=9o1iYAKk;CDP7ST>*Xz5T{a$V>4EJF_0Lx4X42gm6d_j#8X zyA}yp?)xktf&NM04jQzTvV0SPx7R}rfe5WfwY1qB#X2#HJ;&4)Cx4RPTi88x=iaVQ z#Pd+l`i*hg0b?V;;Q&WUhiD2svnxUKdh;vh95N>pInSFEAcCXhN;4)kU38MLw>pk z<5V6$uZ^6baf%n@TY%O&pw)^I=?08QZ7lasoo!Sy_dCt_0sB2(+L{1D-Yr1N(Pz$Q zm_ZHNe35s|cr0T{I5sYox1`?3P~!u|E=o{SG$c(=*(dtjNdT|Ku;@w;Z>EJ;*HKHRg@}et!3cNGhQyHwRxxJ|bV0xC zr@FeRPka^&7jIydI(cOBA12?B5#=*@-`HtUl3spwR!_*>>-h?7r<>aQSu{T{f@aX8 zxaE5GG70g|;?D&J^A|H;aQ_@CU*I|b0r(tDy9+SZ0vK?;TzGZD^I3T(n6Qx6#?jgb zFbpjvWCd5J|G+E@MbxM|?na)EsOU1}Kgru3p3h5v*RL|+e;)8Ji@@_>*k%(JJ3jA* z$jk47;^$=$pe6;=Cou@Dj2>>J!%JfR4=>0dt!@}TtuUyW<4=Gz&vl6jPrB#3jJPcJ zdjL5W1Rb#mCLuX>SaBWl2Yw9DeqtLegnMv{RW6Y zR_`y#h)3}L0#thUh4)<*zTi@Yt*d$4@(N>X$k_Uys=x|-iQ4}kr3!mtf<^|1Pd_s_ zs-K=1QS9zPc)wnQLbW&{)kE+4 zH1QcsM&XzGZFn-5-hD?v9`o>}arO1cty8&e=~k|$AnJV+8J-3D*y?Mo&_Ha1U z|ItC~COgOqX2N85PmWXJDZ4SF73{%G{puVeS;&X zpBt7vmEz#=J6|4wFmh9IG1Tr$9(%Njy@@@AkhWRQCBgfhp2T7XTT<^)c(!Ypz^A>s zi^u%7ulJbE)!RiBa-8%Jm(iX6hgT9$5ss!cn`l9}L&Qzum!uR2cy#lA(;8{^!Mtq3 zTK!d1XP{&HldMtG3HIIihgB;69?m!o;a4wGbuLuriPz~PoQyZAL32TSNr0 z9vvr@(N`G(KD^-lrhdIqvD^rH)4*zJ{J6)~)dIIP9H}jG9$qEJT25n6YEuFM5b(}* z9??uhGk-~*2u|8ov?kLz1SI4Y6fA`KI+|Cl@lu$OIfzBm6U$L_#ytBC-v7$Om*;7) zr43EbN7GDc{J1WYJMxrUM+f`Ins(jC!6tXG5e37&KSl$)HHy=MXn^TlOrx-o{%A`& zi__9q;q{DcrlYAfxiTN?&Fc{;e@KPFX+th!NO2Y`Ka|O5<2|XaW^p&3L0=EhVOe$~ z+F8)g*as$osM5h_fvrl4Q4(Kn$ac*l=mNqcn4gn;f-y;41imD47VD`#B#LE!R&Cl zN|lh8y}hRy-n%8Rf*l;9FKYp`N&&JTfh2S4iT7O-oYfLzPemN~nAM3+Zz`Qv&3S(- z56Z%*QaF?Y!_{V7P{e8SIw_%3!WAv)G@@OBk5(hVK}S##Qz~Y@wr6%0KYPi_M}ioQ zNO&eVM#OB>yG;sISW(jiwyThjUGg$~BW(RpffRz`NIi<~1Y8sCP!NW3ubEG{Qh9Hh z13I$)=&PH|$1YhQ3IbwWW^zsZqOYdj=%rXBq+32fsWwaCoQ;yJ1ZePGL%kS!N)t3H zZ2@Lv+oP>{1(m{TGIJ_9(*dYSE2$P#dXAbFzJ!FCZP(S|0nbwN3IrKTz|NYrnK6)n z;*i1u$2g-fQ5-CcI!t*ror5T%7^e^jO-0|NRXt{t?9>TSI1xdwt|~HoE!3j#4xqM& zQxOM!q#o4@sER-;rClX`Ewf=!0sSRcF)4@p+!yp0S1r`s$2@lB&_tM&j^Cfg>)lwoLPXaI4Qr#V8%>X>T2aH z{V^*NK0bt~FmBlS?g*2Y4Lyr{0&4eP*DldxWQ|J1H=e`#N3jJaz z0acrc4rxj~bKQzz@xADT${@fnXDyk$-{!!MpW2;9$O4m`RH8f=BTGQNv`T`oQY>M! z_X)nGaJj-+@tB32?{kjEoT>sO9Jj7w7IGHP1?<-ZEBd7Y*%AalJ@cS12uod)eI=j- zf@NylGCj94Fqd6E0)V^RQzM)9Jm<%)J{!fgRrA2b|t*acdz@V96iDIn5YZQ<%UD)h73M0IPB=4NCXkC+@Rb(2adp(S2>@h?8JCI6CgnOB-9nj$o-SfHdX|C)vU zc#VwPHw%|3WAV`^2lXGLGPYDmtvE*s!~N7m#;gne>@KO`#GCY(r!l;|Aclku03K8z zhGf1eIeRioEn4=(&+A^k7b(+HUuUL`xrv)aU|B79W;#U9@ZG9o!Lg9>-709%uhp&? zH@*c`K{~XOz}lQ?HO;cZRLjq^RhoE|N#lD8O%xWG?FOjg-zqGK zh>5l`ZI&`8z3*yP2P;L=`&+Xa7t;v?;5rL8H!nVLTnFQ}rsdGYYdEXXi2 zq!VmTMHRCY#ofUROA!PntFcA7#Ya{wCbC=6=-=rC;>z?he@QizRJfwm5Mw2te~Fpo z=Ey#Gw6;;55|aG8DN_{BvKTgs3r+63hCsp6dSoKHkm2(%X;JH!OmhhIu`f(dnKkqJeh>+*7w(l=f z$1@pykiZi4ZE=Az`NDJoA615Kts%i;mff?}G}TqCEccxgvDw_W0lJuDV#t{$hAQ(+ zmcs&mcEe!eV>VGjh}Z+SNwfrQ@xc!#K|1t#qb*8eAt}AOM12`PG|$g_7^Hn74Yf!n zl2#XN zf-v*TYbmmO4TIH#j)tLhx z7hJh@!F6!Z>P1e=Yh_w6y-c)~U$SsR`EGp>UH2PK@sJNO$KE5FrBN1}ML@q5D(Lr2 z$XnJ#khhhSA(S9Vh22P&P-j6Czht!Czu`|xJFh`7wGkxKaQFhQt6x#X70c;5vSX~$hiraJax zR$vxSqJuv`XQ~}Rv7KM5NjBJ)+bbyhn#{)R?qId*AdUKw+OIH4WG$wARjdSQA;o%1 zw=NMgg?6Lm)~A)D&MOHn1h{Ug6C{i`JFDpgF)v^TE#w__#YMG9prOR^)HEY1)9R+O z)lalIL~WU1nmu3J0S!OK*!u~nnF zOI|LX3$d2arA13sPOk$3QCw&?u}VJ3G|QBp~Z3sQ&YwBiL7S54Inp>9oDEJj)hw|X+2 zXHdhE@lg-&F-t3gxuus%GJz)geib&!6CLtRsjImh^irywi6^{fAk|`RmNU$CP1*y0 zETGPuIcx9=98^s5pES`Z%U-kFSmka1w~U+#l*k40O6-jz2F}q=9HQg{ zV@W=pCTA{js*m2{|B;8FdiLW0zxis#O~xW#wo7v67{)Kjz=U@i;a-?$JJVFk+gL7d1o{QKEWR)6mW2to36E9-t|H zOyI;^MFwH9YP()9a*Qs7oIr4nQ+(L|TNHGo8kLtKj0b}r$NNI@#INPW z)?aa&0)+NDoCO8=fAXr}3EJ%BR(U7SEDFaSqol`YNMBR5w1!Ou^N8#4>_>7fMio(jrlqy zKV&C)mBaH2<;LyY^~T33XN@sT7r!xpi|4m;`L$gBUM_zrm+#Bv8*-VF%OA<*Ww|^j zmvOo5F$O&RlHLHK-9LIwd;ieruI+;>skx04yQB!`5NTm1;$08C40E3q&0;Iw0hBTnlmclx z%*5n3@l0wVIs)FMb3Objm8Qz|DyGF^DMEGZm=u${DU1TWfzD_FC1;QVyljiFsP@F@ zOTLIz&Bw?n?Y~Egw;CV4mQ!D;F+R%X%JUWN3d-@-o2OG>0I72&h)BVF>5S{VfX1Bf z3-#)i0+o%wXB>}(SqA{&N_sW2#9;NYx=oqLAJ9=l1t*Yq{$7}ixU;&s!RuRK+7D|* zX8|=>;yc*OC;YU`x*`)QXD8vaVhNZ&`l&n~t`p!1zTa?VN;7`LPuoz+zu@H)I`}0Z z&Fw6;L~8kB>M8RTTfEjN$@yw*wSfHGgvKLp$x#S_Y#wVeOUgbYAjq(5AEq$zEb)VA zyypQ)2(?E2@_3g_OSqyegWK!6x3VDI1S>xtmY&g4dknWJrJ&avm+(+0y2VKj?O=xS zCWU^nM8{GHEkgNU)cF*=Z-MY~fvIX=1k_cLk+)tDa3lPZqCKD@v?zys#Fcf=euvTX z#aS&amzKN>S#AsF(Z#z>&hA+aehEVsA@sV695p}s4p{(x{UVC*nQg#mrWfU26$y~j zfsdlOGJ~8MbZ1s^W|cd$nltfkFt?##)^cX8J2S+YA(eSt=deX_WsQmyl;|A~yn*#h z=a(=JJ6=*XLtM!x=!n8Ulwxx!{i1{>eNrw6RQj;du)}EBYBbzsG^CA&gwb%T(Qu>D zaE;M$mC-QQXyDH#ia9t4ujew1MV`n8LU2HWSkRZ>@OJlln1DEtigIfQ$vI$?K)oie zu`lKM5-<=@FM<1I0}~UHFWHWRXpNq*D!vRo*^F2J5dXly7dED%h+P;DMTTb%U&Xf? zUX8{xM72Pn%NI+0tY4wTR8*Tr))B-`oPgJu=)AnxMPb5@CUivcIg*_2nwtED7~_{Q z96C74ajH}dbVBdTKmoyW0S~aAPG|%LFY{2a+;;@Pm)+qhN&&nAKBhS)Dg2e^a!|BD z5m7~Z60f~BJo6{3RM3yZ*Q!J>Yy9TDosXkERUAQxBs7RPH&gTiO9U^k@cYj!fmgil zSF$^Ot(^a<74mqw@$oB-VT-T751g9M8n$e7p?b%rlkpkzR?L)yFeB#tKEjxpW5IRQ zlK%YF+~8NOroICHomY@Xg7+1GbIQUB)X1<8o+U`*9;Iquo!C!rqkH}|I$Aq(csU0p z>&;*J`|*4|-lpFqacS8D&^OJmhkG~_8p+XXd6`uNQ}>qHs^+qswL>yidgw+{hO`$&Tp1j&YyT?gl_5zgE7aNZJd-Xtu;SG^T31|i~#zb%%@$2n-} zALc8eL#eliG5pp)Q?@aHH|1nQ`D&jlqyH8EKemZPuE;%sCA zPm%ID^EUn!;Oq1L(WivoPkDh)p{u6UXmj2 z#mpJV|L2H%V(ok19<6=nnbC^)k9HT>2AnPU-t7^D@1c-A?%;dZMzk{mJ8K-i|NF~J zjl;(*KCf7O>sS{!7N3lehe#~aPku&V*sHJLc$E97Y(@7@x_AyHlEg-j%p~ zuOKcTyk~9EhAH-JH(a?l{wYqy>*bSDFviu5(PWZe$Ia#%F})e5ujVCE@`i3U+>%Xi z%EcU?+4Sh*TfNG25||=3>3aSa)ZOo?;Nec0Y>I@ZtfNGnrqXP0ueUvIPL-}_vE*f0 zfjyiG3YTCS+G~tOA!Cso0rmcc7`|8MFpGA{0@I(1t$kGsWPTnfU*(ZdfC z<(jtL=ox0k`0`e|=wo;B-AlcEna)aPQZjEdhS)AUz9=xwJX2p3*eCw_xLkI#+itqj z(_rBi@rb`DE-={eAK?~HpWQ7!f)}#q%nNyBR!DOKXmeE~-a(Hwd4JR$ch{GKJA$vuP|rTNyB9X+poSoB>c~gVuvgvw@E8 zm9G7it7|I?y!q9uhy?%AVfxe%K9pA+9`F?l5ZCBdrUfoHNx)-t0^@cpXRn7eqVRA9 z`)54XQlwVL_)c9khR+0`fVJ49=*c)D6o@IZ@uiLV{aP@?*fC~;$@8{PhwpomIvi1$ zT(GfpFi-Or2vqA-qW;uPCdKP4q3- zGFthjXyu!tm5?c&Rk(PWzH(7AeF@y2t#z-sw9dwm4o{Sm;@93kDLN1;E5$cOieDos z)`=A9UH-mVvV4 zrA)jL-Q1M4J3pe{-Nh?k&hH3w9p@(vIfI)$)3>Xs#5X3!uYv|SzF$r6LiaVb;3dR3 zeF-(!=-@MpNK1O?OV(AhJ{L{!zRmr~{2ukIeD@~*9@Erp1)qT7md}aXH)r8S-;g>V z+`QITww<4_rdGds&Q||?VtlEaBbjvad>XB0vcAi|Z}IQ<`1kw#`vd-!&vpNZ({Jo zI`uaeDg732%gl-X)=^m`yk9kW!TRLDV-|n=g};Am=~6%Qx2Jht=?)l%p%%b%R7fb6u*`Q|8x>acX7fS$JxzAh(sU@m}&vs^e+^R%o`rBfr zzHQRn%)Y0mdQ9&fZRW*R<-z`|jV&Vb+;g!+ziWe;MKt3hg#W8WIA;>^!M4F2JGbu| z*m<6!E}@@>_SLiLKQ8nix9Fek%Mu1(XWRdtV}#ZX@-Z&TX#VybJUA{qc+bUy3e$^KM=gyhg#|0XxO|V%pWIqEMC_ zvfL@;do=tBkPb}1?jZFD&ee325PVG?FfK|xf_(Z#9R(J)?*b1hyJh!0-SaGt%w zJ*{rflFPMvRo2Y`66beC8{jL@_J%j#%>Ij3l^Ly4W&sn>RZRC{hc5Vx-&J&%ZWOJ=!CGIqpX)<*39lK-xHC1&k_lHNhKm_=FW2C1&d_0gQK=cZgh#nZh5xP5?tp1aET&u z;8Ip3-xHCnbBW}8XYMR(Ad>BL>g=A;ZDYIc-Ep3srK}ZOTgHlgUj*}gQ!s1Ty&=KO zEwy4T7c7`N9DKC})8Z10-7-5CE@v{>;Q(-nf^pzdRxsZe!F0F;^ZoLIS^GX)v9;MU zR_q5NnIBk^5pTmS8L?uS3zkf`gR!<`GA_y3E%O-fmQ0TWz$Hq?flFD*{6Hkr!%F+~Cq&&V;=!a(Ua5 zi#6&y()ioLnx{ zf|VCY83XoX5y+2Cf!t_~_6~uF0sHg?3*?gye%c*HeMv*@&f6`Q8SOvs0C0%{ao|!` zAU_s?eBLFHAD^+KypQ&)oD+6J#DXPQv0pb@L%qM$3EO|cV%g{5sx6lNu6|;-TxO_$ z!2#eB#p1xFtXNKnSYB|6TMKB?38R3B(%c9Rd;i zb@+k>@~VTMwm=TMI*Q$LnSuUw2Y^fLC=Oi83gnas~C7an7#86{Igjsq3=Xq%%X4*rzyj1SZ+~L)cI_n{^a;N0Iux=6!n-KV!$kOunnxV^iLmW$7u$Y9Y&-J- zj0@e9$Y&GLRL5+N{Zu&iQ;TEbS5=NKtR$>uZz}lLl$I59&1;O{=AsyZR!lHu_2;L; zh`)9*;-}md^LSx$?4#Ul!!`oL=#~H46~6s3K5tEU=eGNrMh71l9F^~J*lpu0tIv)H zGd+2H79^9K$E${a$884x&f{G~ueH_F7dPlr?b$>}oPr<#V(;MgZ4ZT8w{5>~8*L74 z8-wgBzCl0V#32&YAwZtLrI+6-v1QQPnl$FnL6O>t@rsUUOEwWp;yi>|?!V);0({P( UJCneNZQAkUc^=h+@662nKe38Q@Bjb+ literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK b/internal/gabriel/benchmarks/GABRIEL-TAK new file mode 100644 index 00000000..a94861a0 --- /dev/null +++ b/internal/gabriel/benchmarks/GABRIEL-TAK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "GABRIEL")) (il:filecreated "13-Apr-88 13:15:44" il:{eris}gabriel>medley>gabriel-tak.\;1 52748 il:|previous| il:|date:| "26-May-87 09:18:24" il:{eris}gabriel>gabriel-tak.\;7) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:gabriel-takcoms) (il:rpaqq il:gabriel-takcoms ((il:files il:gabriel-timers) (il:functions listn) (il:variables |12L| |18L| |6L|) (il:variables *x* *y* *z*) (il:functions ctak ctak-aux mas shorterp stak stak-aux tak tak0 tak1 tak10 tak11 tak12 tak13 tak14 tak15 tak16 tak17 tak18 tak19 tak2 tak20 tak21 tak22 tak23 tak24 tak25 tak26 tak27 tak28 tak29 tak3 tak30 tak31 tak32 tak33 tak34 tak35 tak36 tak37 tak38 tak39 tak4 tak40 tak41 tak42 tak43 tak44 tak45 tak46 tak47 tak48 tak49 tak5 tak50 tak51 tak52 tak53 tak54 tak55 tak56 tak57 tak58 tak59 tak6 tak60 tak61 tak62 tak63 tak64 tak65 tak66 tak67 tak68 tak69 tak7 tak70 tak71 tak72 tak73 tak74 tak75 tak76 tak77 tak78 tak79 tak8 tak80 tak81 tak82 tak83 tak84 tak85 tak86 tak87 tak88 tak89 tak9 tak90 tak91 tak92 tak93 tak94 tak95 tak96 tak97 tak98 tak99) (timers ctak stak tak takl takr) (il:variables *tak-timers*) (il:declare\: il:dontcopy il:doeval@compile (il:localvars . t)) (il:prop (il:filetype il:makefile-environment) il:gabriel-tak))) (il:filesload il:gabriel-timers) (defun listn (n) (if (not (zerop n)) (list* n (listn (1- n))))) (defvar |12L| (listn 12) ) (defvar |18L| (listn 18) ) (defvar |6L| (listn 6) ) (defvar *x* ) (defvar *y* ) (defvar *z* ) (defun ctak (x y z) (declare (type fixnum x y z)) (catch 'ctak (ctak-aux x y z))) (defun ctak-aux (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) (throw 'ctak z)) (t (ctak-aux (catch 'ctak (ctak-aux (1- x) y z)) (catch 'ctak (ctak-aux (1- y) z x)) (catch 'ctak (ctak-aux (1- z) x y)))))) (defun mas (x y z) (declare (type list x y z)) (if (not (shorterp y x)) z (mas (mas (cdr x) y z) (mas (cdr y) z x) (mas (cdr z) x y)))) (defun shorterp (x y) (declare (type list x y)) (and y (or (null x) (shorterp (cdr x) (cdr y))))) (defun stak (*x* *y* *z*) (stak-aux)) (defun stak-aux nil (if (not (< *y* *x*)) *z* (let ((*x* (let ((*x* (1- *x*)) (*y* *y*) (*z* *z*)) (stak-aux))) (*y* (let ((*x* (1- *y*)) (*y* *z*) (*z* *x*)) (stak-aux))) (*z* (let ((*x* (1- *z*)) (*y* *x*) (*z* *y*)) (stak-aux)))) (stak-aux)))) (defun tak (x y z) (declare (type fixnum x y z)) (if (not (< y x)) z (tak (tak (1- x) y z) (tak (1- y) z x) (tak (1- z) x y)))) (defun tak0 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak1 (tak37 (1- x) y z) (tak11 (1- y) z x) (tak17 (1- z) x y))))) (defun tak1 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak2 (tak74 (1- x) y z) (tak22 (1- y) z x) (tak34 (1- z) x y))))) (defun tak10 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak11 (tak7 (1- x) y z) (tak21 (1- y) z x) (tak87 (1- z) x y))))) (defun tak11 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak12 (tak44 (1- x) y z) (tak32 (1- y) z x) (tak4 (1- z) x y))))) (defun tak12 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak13 (tak81 (1- x) y z) (tak43 (1- y) z x) (tak21 (1- z) x y))))) (defun tak13 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak14 (tak18 (1- x) y z) (tak54 (1- y) z x) (tak38 (1- z) x y))))) (defun tak14 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak15 (tak55 (1- x) y z) (tak65 (1- y) z x) (tak55 (1- z) x y))))) (defun tak15 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak16 (tak92 (1- x) y z) (tak76 (1- y) z x) (tak72 (1- z) x y))))) (defun tak16 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak17 (tak29 (1- x) y z) (tak87 (1- y) z x) (tak89 (1- z) x y))))) (defun tak17 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak18 (tak66 (1- x) y z) (tak98 (1- y) z x) (tak6 (1- z) x y))))) (defun tak18 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak19 (tak3 (1- x) y z) (tak9 (1- y) z x) (tak23 (1- z) x y))))) (defun tak19 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak20 (tak40 (1- x) y z) (tak20 (1- y) z x) (tak40 (1- z) x y))))) (defun tak2 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak3 (tak11 (1- x) y z) (tak33 (1- y) z x) (tak51 (1- z) x y))))) (defun tak20 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak21 (tak77 (1- x) y z) (tak31 (1- y) z x) (tak57 (1- z) x y))))) (defun tak21 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak22 (tak14 (1- x) y z) (tak42 (1- y) z x) (tak74 (1- z) x y))))) (defun tak22 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak23 (tak51 (1- x) y z) (tak53 (1- y) z x) (tak91 (1- z) x y))))) (defun tak23 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak24 (tak88 (1- x) y z) (tak64 (1- y) z x) (tak8 (1- z) x y))))) (defun tak24 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak25 (tak25 (1- x) y z) (tak75 (1- y) z x) (tak25 (1- z) x y))))) (defun tak25 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak26 (tak62 (1- x) y z) (tak86 (1- y) z x) (tak42 (1- z) x y))))) (defun tak26 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak27 (tak99 (1- x) y z) (tak97 (1- y) z x) (tak59 (1- z) x y))))) (defun tak27 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak28 (tak36 (1- x) y z) (tak8 (1- y) z x) (tak76 (1- z) x y))))) (defun tak28 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak29 (tak73 (1- x) y z) (tak19 (1- y) z x) (tak93 (1- z) x y))))) (defun tak29 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak30 (tak10 (1- x) y z) (tak30 (1- y) z x) (tak10 (1- z) x y))))) (defun tak3 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak4 (tak48 (1- x) y z) (tak44 (1- y) z x) (tak68 (1- z) x y))))) (defun tak30 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak31 (tak47 (1- x) y z) (tak41 (1- y) z x) (tak27 (1- z) x y))))) (defun tak31 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak32 (tak84 (1- x) y z) (tak52 (1- y) z x) (tak44 (1- z) x y))))) (defun tak32 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak33 (tak21 (1- x) y z) (tak63 (1- y) z x) (tak61 (1- z) x y))))) (defun tak33 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak34 (tak58 (1- x) y z) (tak74 (1- y) z x) (tak78 (1- z) x y))))) (defun tak34 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak35 (tak95 (1- x) y z) (tak85 (1- y) z x) (tak95 (1- z) x y))))) (defun tak35 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak36 (tak32 (1- x) y z) (tak96 (1- y) z x) (tak12 (1- z) x y))))) (defun tak36 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak37 (tak69 (1- x) y z) (tak7 (1- y) z x) (tak29 (1- z) x y))))) (defun tak37 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak38 (tak6 (1- x) y z) (tak18 (1- y) z x) (tak46 (1- z) x y))))) (defun tak38 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak39 (tak43 (1- x) y z) (tak29 (1- y) z x) (tak63 (1- z) x y))))) (defun tak39 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak40 (tak80 (1- x) y z) (tak40 (1- y) z x) (tak80 (1- z) x y))))) (defun tak4 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak5 (tak85 (1- x) y z) (tak55 (1- y) z x) (tak85 (1- z) x y))))) (defun tak40 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak41 (tak17 (1- x) y z) (tak51 (1- y) z x) (tak97 (1- z) x y))))) (defun tak41 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak42 (tak54 (1- x) y z) (tak62 (1- y) z x) (tak14 (1- z) x y))))) (defun tak42 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak43 (tak91 (1- x) y z) (tak73 (1- y) z x) (tak31 (1- z) x y))))) (defun tak43 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak44 (tak28 (1- x) y z) (tak84 (1- y) z x) (tak48 (1- z) x y))))) (defun tak44 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak45 (tak65 (1- x) y z) (tak95 (1- y) z x) (tak65 (1- z) x y))))) (defun tak45 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak46 (tak2 (1- x) y z) (tak6 (1- y) z x) (tak82 (1- z) x y))))) (defun tak46 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak47 (tak39 (1- x) y z) (tak17 (1- y) z x) (tak99 (1- z) x y))))) (defun tak47 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak48 (tak76 (1- x) y z) (tak28 (1- y) z x) (tak16 (1- z) x y))))) (defun tak48 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak49 (tak13 (1- x) y z) (tak39 (1- y) z x) (tak33 (1- z) x y))))) (defun tak49 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak50 (tak50 (1- x) y z) (tak50 (1- y) z x) (tak50 (1- z) x y))))) (defun tak5 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak6 (tak22 (1- x) y z) (tak66 (1- y) z x) (tak2 (1- z) x y))))) (defun tak50 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak51 (tak87 (1- x) y z) (tak61 (1- y) z x) (tak67 (1- z) x y))))) (defun tak51 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak52 (tak24 (1- x) y z) (tak72 (1- y) z x) (tak84 (1- z) x y))))) (defun tak52 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak53 (tak61 (1- x) y z) (tak83 (1- y) z x) (tak1 (1- z) x y))))) (defun tak53 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak54 (tak98 (1- x) y z) (tak94 (1- y) z x) (tak18 (1- z) x y))))) (defun tak54 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak55 (tak35 (1- x) y z) (tak5 (1- y) z x) (tak35 (1- z) x y))))) (defun tak55 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak56 (tak72 (1- x) y z) (tak16 (1- y) z x) (tak52 (1- z) x y))))) (defun tak56 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak57 (tak9 (1- x) y z) (tak27 (1- y) z x) (tak69 (1- z) x y))))) (defun tak57 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak58 (tak46 (1- x) y z) (tak38 (1- y) z x) (tak86 (1- z) x y))))) (defun tak58 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak59 (tak83 (1- x) y z) (tak49 (1- y) z x) (tak3 (1- z) x y))))) (defun tak59 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak60 (tak20 (1- x) y z) (tak60 (1- y) z x) (tak20 (1- z) x y))))) (defun tak6 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak7 (tak59 (1- x) y z) (tak77 (1- y) z x) (tak19 (1- z) x y))))) (defun tak60 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak61 (tak57 (1- x) y z) (tak71 (1- y) z x) (tak37 (1- z) x y))))) (defun tak61 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak62 (tak94 (1- x) y z) (tak82 (1- y) z x) (tak54 (1- z) x y))))) (defun tak62 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak63 (tak31 (1- x) y z) (tak93 (1- y) z x) (tak71 (1- z) x y))))) (defun tak63 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak64 (tak68 (1- x) y z) (tak4 (1- y) z x) (tak88 (1- z) x y))))) (defun tak64 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak65 (tak5 (1- x) y z) (tak15 (1- y) z x) (tak5 (1- z) x y))))) (defun tak65 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak66 (tak42 (1- x) y z) (tak26 (1- y) z x) (tak22 (1- z) x y))))) (defun tak66 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak67 (tak79 (1- x) y z) (tak37 (1- y) z x) (tak39 (1- z) x y))))) (defun tak67 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak68 (tak16 (1- x) y z) (tak48 (1- y) z x) (tak56 (1- z) x y))))) (defun tak68 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak69 (tak53 (1- x) y z) (tak59 (1- y) z x) (tak73 (1- z) x y))))) (defun tak69 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak70 (tak90 (1- x) y z) (tak70 (1- y) z x) (tak90 (1- z) x y))))) (defun tak7 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak8 (tak96 (1- x) y z) (tak88 (1- y) z x) (tak36 (1- z) x y))))) (defun tak70 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak71 (tak27 (1- x) y z) (tak81 (1- y) z x) (tak7 (1- z) x y))))) (defun tak71 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak72 (tak64 (1- x) y z) (tak92 (1- y) z x) (tak24 (1- z) x y))))) (defun tak72 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak73 (tak1 (1- x) y z) (tak3 (1- y) z x) (tak41 (1- z) x y))))) (defun tak73 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak74 (tak38 (1- x) y z) (tak14 (1- y) z x) (tak58 (1- z) x y))))) (defun tak74 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak75 (tak75 (1- x) y z) (tak25 (1- y) z x) (tak75 (1- z) x y))))) (defun tak75 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak76 (tak12 (1- x) y z) (tak36 (1- y) z x) (tak92 (1- z) x y))))) (defun tak76 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak77 (tak49 (1- x) y z) (tak47 (1- y) z x) (tak9 (1- z) x y))))) (defun tak77 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak78 (tak86 (1- x) y z) (tak58 (1- y) z x) (tak26 (1- z) x y))))) (defun tak78 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak79 (tak23 (1- x) y z) (tak69 (1- y) z x) (tak43 (1- z) x y))))) (defun tak79 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak80 (tak60 (1- x) y z) (tak80 (1- y) z x) (tak60 (1- z) x y))))) (defun tak8 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak9 (tak33 (1- x) y z) (tak99 (1- y) z x) (tak53 (1- z) x y))))) (defun tak80 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak81 (tak97 (1- x) y z) (tak91 (1- y) z x) (tak77 (1- z) x y))))) (defun tak81 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak82 (tak34 (1- x) y z) (tak2 (1- y) z x) (tak94 (1- z) x y))))) (defun tak82 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak83 (tak71 (1- x) y z) (tak13 (1- y) z x) (tak11 (1- z) x y))))) (defun tak83 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak84 (tak8 (1- x) y z) (tak24 (1- y) z x) (tak28 (1- z) x y))))) (defun tak84 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak85 (tak45 (1- x) y z) (tak35 (1- y) z x) (tak45 (1- z) x y))))) (defun tak85 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak86 (tak82 (1- x) y z) (tak46 (1- y) z x) (tak62 (1- z) x y))))) (defun tak86 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak87 (tak19 (1- x) y z) (tak57 (1- y) z x) (tak79 (1- z) x y))))) (defun tak87 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak88 (tak56 (1- x) y z) (tak68 (1- y) z x) (tak96 (1- z) x y))))) (defun tak88 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak89 (tak93 (1- x) y z) (tak79 (1- y) z x) (tak13 (1- z) x y))))) (defun tak89 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak90 (tak30 (1- x) y z) (tak90 (1- y) z x) (tak30 (1- z) x y))))) (defun tak9 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak10 (tak70 (1- x) y z) (tak10 (1- y) z x) (tak70 (1- z) x y))))) (defun tak90 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak91 (tak67 (1- x) y z) (tak1 (1- y) z x) (tak47 (1- z) x y))))) (defun tak91 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak92 (tak4 (1- x) y z) (tak12 (1- y) z x) (tak64 (1- z) x y))))) (defun tak92 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak93 (tak41 (1- x) y z) (tak23 (1- y) z x) (tak81 (1- z) x y))))) (defun tak93 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak94 (tak78 (1- x) y z) (tak34 (1- y) z x) (tak98 (1- z) x y))))) (defun tak94 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak95 (tak15 (1- x) y z) (tak45 (1- y) z x) (tak15 (1- z) x y))))) (defun tak95 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak96 (tak52 (1- x) y z) (tak56 (1- y) z x) (tak32 (1- z) x y))))) (defun tak96 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak97 (tak89 (1- x) y z) (tak67 (1- y) z x) (tak49 (1- z) x y))))) (defun tak97 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak98 (tak26 (1- x) y z) (tak78 (1- y) z x) (tak66 (1- z) x y))))) (defun tak98 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak99 (tak63 (1- x) y z) (tak89 (1- y) z x) (tak83 (1- z) x y))))) (defun tak99 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak0 (tak0 (1- x) y z) (tak0 (1- y) z x) (tak0 (1- z) x y))))) (define-timer ctak "CTak" (ctak 18 12 6)) (define-timer stak "STak" (stak 18 12 6)) (define-timer tak "Tak" (tak 18 12 6)) (define-timer takl "TakL" (mas |18L| |12L| |6L|)) (define-timer takr "TakR" (tak0 18 12 6)) (defparameter *tak-timers* '(ctak stak tak takl takr) ) (il:declare\: il:dontcopy il:doeval@compile (il:declare\: il:doeval@compile il:dontcopy (il:localvars . t) ) ) (il:putprops il:gabriel-tak il:filetype compile-file) (il:putprops il:gabriel-tak il:makefile-environment (:readtable "XCL" :package (xcl:defpackage "GABRIEL"))) (il:putprops il:gabriel-tak il:copyright ("Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.LCOM b/internal/gabriel/benchmarks/GABRIEL-TAK.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..cdb406b796741114c1498e0fe4524ae6e9f09096 GIT binary patch literal 16484 zcmche&2AgX5y!c55^R_+?FPsphedO1*h6Y&SpTl>>fcoNbhkg-x&PqH zozDFSyE~l+U*7-9eDY|g|Jh!Ddw0jQ{&;VzxVt8=R2m2d*yrU^Zxdu2Rpm1 zjg4k|H0~XY#?_#%%0)Fatsv_3XLTpfO%U~h9RFIT-5N}fXSi!PoI|i^{5(udRz_1)tUU+S(Hb2zy58|+<@Vv^F_&qvtAhYg0N*;_rCh# zp)I|2VMvD0N0W0DzN)9EW*64YBaFoxL}en zi*wV2@8`3+dOn(-%+GC2oZHg$Q06d&gJ+#QGu^`0TzIpLt1(wa8JD}BmCv48t1DMg z_jA*hhMKFZqvNWcZy36GG8rsJ)5+YRQ5F+E`Mj)0<^H&uoAV&tMU|ZgIX=$Q-SanZ z*gV}dn`ij{V)IRd12m(thfaBNYL3gfnIBH;MODwt++MN=x@7;r|8CPB13Gl+$lpWy z9?>zTV?xK2ju{D-n)V*D5R!$EEQDksBnxzBL>3~l5Rrw5 z&r=a1G7yo0hzvwzAR+@S5|f3PEW~6XCJQlHh{-}s7Gko1I6={3vOpITGLVpggbXBP zARz-uLaroaAt4J1SxCqNoleO@N)}SGkdlRzETp88@||QLB?BoLpc7e_L^86Fk%f#b zWMm;D3mI9+_y=SmBMbC3ry}HJASVMk8OX^%P6qOnRL}=d0bqzdk_A4Hg@P;;WT7An z1z9M_LP13+$Us2`iURStph%}6zV6xnGn`Hq zgX!#yzgN%8@s=YTb*1riP>#`c=1p_gEH>Eqte(!eqXC4Avsq<-d|Vz?7N4DJ@_bZJ zC&$%fv7vfsd9<;D+4*={4%Kz;!Ay1X^gKxI}`?sy((Z!D& zjbE=Ht~c62*LCvdWHfHJ!48xT{*8`J``O8KQJMC9Rt-kwnEO2yVOpE^{`6!rgd2Pl zF~PbwuNKc7A=+G$Af(^iU=|#?)+}9Hnzh6cv-vG%EtqV5T~S!NBu4Rv*i3IW39j98 z!`W>&fQTrQ1z_3jc7tUz;o)TFqh4=wP%Z|Cow{0_)RWFZJw4vEZ9FqwzC1iRK0fOl zOzRHaNEZ)GXin{22PQHUhzBM%FVN)8wL5E#(bh+6A3S=z_mc)fz_z#GcSD+-pezA1 zg0&ac+6YA=Ya@uC!rF%jpgT_+4a5!%C1i)ZKqZIt7rwA_7UBO72Y+$t;L*j>MJ|jj zgK|*{6?&_6SJ@F)n5}hNPw!Ny$XlVP@oXr#n262UyA*0!p6df*!v@4w|Mg!H6x%;T zRB&*t9`}FnYJct3e&gl88f`pCCG>1;L?(>XiO>X@IuRH|tL+t|2{MF9IqobD>*=3t zxTSQX!6Ti5H;DO@Pg5A$+(Kd+5VS#Uu;lX^w+kx@UgwN z)yIdF{ME~UqUbs0D##tIS*Y2Mc$vE_!)%$%tSGOj{t6Yg*8lr2w+{dFkDo(zjq2vr z%YUyoEPWk;DG?F_w)T-nNr$v)74^-ou{1J`AKEtfka}de%$_dGV;^2N(-L#DOLG=E z&YZ=IP1+no+*upXPWr$kPA|N3r_p#aeEj;`y>;8=KDx68^^YGPUFIZ&A7XF%M+#2>@qZN-XxD}5sxEYTwR6Du|wDvd! z#HhqR@K=?(H%R@4g8fD*CM+k0f#JLnA?g)CPEtiKO5)E?K_H%=PE-&WCARY$(L?w_g{AE$FkVR7+NFEVrfxsO` z5GVvx0K{$n{1gBd0zgbzv7eD5AZGCVi3$NR<;RtabdN9&0G->gL8kP zLO|ev>lV{TEE*~TA~*CWDg+b&;?*^4rV4-<9sAQ103uIdNAaGUMGFN$%n$k#6#&{~ zkR#V=Mv8xUzWURY&_#=}CIG>XW;%8~63|ZF@RXbo5F;5^yQ}FK?(^rU01(4`b`;4T zYsLzISia#;bO}JG3DB`-uK0)P0B@RDZNimnX9OvVaE3)g#XpY?D(#6uK1*U53QH#H ziH4H+^HTtbfr1ki04556;G#cK0U-K4i()kmds-*}A~W_|stoVloTK+_(zaSlA zQN%EdX1c$41fZRvBIshRnrl!2V4whq8~u4I0K}k$MS(i@G*JY^YBz79ST4t&7D7Or zVbMYn&|~dN>_AOJPDi}IF{2yFP%6ad;61w3UW08AAC zkr?_D6#!y1&!WOVg+IiYKS{wK(gBvlpr0!@QvAc*pg&RJAKrhkDBgImXr>5=>;6QA zfLPV(Dpv@Ig@h~bB=GvcpQsQ}0En?JI~pqhB9HK=DSZ@#XGhVtESl>+>JflggUc+! z^bCuFbSxSw0OCe(o?^8xi`ra}Iw{VuXsQ6{(NXaeqcE1l>;_9l%1@NUpPx$r3IXw| zltl|gK!DMos1Oh%LiSVu7%2cEG4!V?0K}Rm)`XYrXr>T|p|L+vK_F&|oTGw3ML^62 z_|p^uVqrdOVl2###)^QLZ1yKA1Vqx#qL}Vu(OeM_Lq~t2LO@Fh9_$MO1BE~=k?|)g z2*gT#7Dckho+b)`$X@)33K}59qHvi-3ylVk2(+mmWxMvJFy|?Pz(^s`qo#fBOqwDPIk%4w`2#Mke>O`Gpst}0#ytSy!6i5?;Kc^`SR0za<{xk)FU^#1IZ53B; ztPqH?u|H8kAa=8`D3*G<7F7(yv%sIIFc70(76lAhG*Ar0>k)sV!a%&fXHg6jSu{}$ z1UdYP3Ij1M#-f$K#)lf5a=YbJ`rR96VT=*~x-;Ve$4QHtO~=L3lKI+BtB$AhD^5Z-R*1fAt-H zJ)90s>=v%lZluJX)q8v8k=s#vtBZC){1q-TGOu%yek9|gD_mrw;>xuy23Nay)vw=l z@$vU?@oEnl(ARlre{+L_Wb#)3uo;c^#l6vlSN!-*_x8Sf1H#()iUz!V6dYi~1@E7w zEf;~?F-L!dZci=tTVbok!#_OYAWrO_lUw|U=&cnHU0VTf{rZX;z)o+fzFT7$Re-IO zZ*^0CFx}9?ng(yTlHH%_y5qGm9AE3=Tfe@-#Yfh~Yj-Pd!ZAS;Z3bL2YvqCzu}zzk zY~Qg{Z}z|2W2y_NH)7*P8wavA)a@qi*b^#rulm(hn@CN&haLIDh26aE_VV{;<>07% zioKnu18iZf4&?9V%7*@1#q74%di3;gfnEK)%l_W9o=s~)Udsf9T~1$Mp)N=5{{T{Q BaBBbn literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..03a84f7a620a5754a63b821f043010ac0d1eaa3c GIT binary patch literal 15218 zcmbW8>sOOWp2u@Rz^1gp<0*S>=WN+C+S}MsNdhEZkPw1ILK2f8;2jVJiGT>+?|0jH zK@{_CGq3iXnYVlToZZ>!H@=v8KeJ~~{}cOmU+?LyUsXb-wevVnJV#QgRDD17`_=WS zr)tqrKNOCM@XWc{$?W)?m|2*gU6>cAXXeC(nT5HradBG4i)-EKz8iZcX3mXwWJl)a zu5?UhCojx)MB;}M>5f=5oeU>Zk&gYLu2eJ<>*$Ka!@d2XRA0Ij<;jHlw(o9PlP=R7 zn;RdQA3r4q$4^a6QS9;$*gDz1_Iv-Z_BQh)?I#Y&>w7T_xXI=*Yt$a zF_=p`8T<>J<(VsoQi}pk?vR`>~iE^UJU;Y5f&>G-)q9s43(gsLY~mT zkWStoO6%x!Zz7e6q>}1ejchu_or_&SpviL8m`xHy@u;GT(9AJ4cBP-4A*D4KEw5ur8Qii z;ra~MXShDY^%<@a@Efk*aQ%ksH(Y;NHpBHBuHSI|hU+(6ldIKmTMf6>a9a(x)o@$O z6b!f3a9a(x)o@MHHp6W*+&05)Gu$@AZ8O}qGBLw#Gu$@AHNUqTZoA>O8*aPdwi|A{ z;kFxYdzr4`wi~XA3>a>}a07-LFx-IQ1`Ib~xB%@k}_89G2m=-HFJdP^?o9+etaT=U>wRyjsqSp_m*}(|7VqZW&QSL%kl3 z>uGS#3@0NpdVPPWPtJXE+LH^0Xetr!kHj<# zwMZ(OzOm<{)kVLYk0Zk$tSlS_d?hEdb!R(&UYuy`?40^Z%~%^79r#MlPfj&K5ijSA zI~!D-ocx@>Gt>TiH4my>LyNtQS*C(xu11I3i7ojYlQXO|Ra}>|#&xH&H0QZD;j1P& zk=J%52IAexS{baDUXV_V_B$E2IGyB=7rDB0G7^r4V%S2nt`&G)Ie2S1IPeh|ccpRv zUaLO-L*lk7ocj7FZ2c6eww&~JKG#q(vF($fuggJStAzwJzHD^l)ry4tC1+8yLU0y~ z>L}0tjb--XPi1em%zpS&*|*82KcfF2iayMw?;3nz*25fVEhGy4leB-K@ z;W`fC37=0yVuCiwb%wPlXaz++coIrm3o_f^)?IjcA@&gcN|>|mlUDhKB3)$5D+-T5ob7})C2a_ z0~YE*fi8~2Oj&VX5rXy!K?}kzfegoKh7P5^%f9+93-#RsXE^2p-&O^*(dC?AcO=4IYJDBO1;y*dZ&eYpTHPLf`PhX0U`V9Aq({`fk}>j zhFeO#%f5P-g?d=vI>#^rb(8|a_SM4{>fO49zTg;V7*m99`-E-_LPQhpa-7#a?Wv+f z>{B8ZlpcW|jvEX;O1;OvI%TZX{`U(E>-PVIfmXl;?6*(YZ$ao4n9_td+DmU0rPn^C z*MbrixTz_38B&T6wNHpz5Dw_tUgX%va7_^o*eB31S*b2!0&N^I2Aa4F=(Dd*16U>X zLjnsNM;J~h^_YG2n1y=3KrhD-!*QkFZ(qINLOm{UgyWQMKaUh4Zl4ghAS48)Ic6DX zz$zeNUp--=p44sUHpg{_vx<=USqR%)qffdd?u7%nRHw0(72kXKUA2pr?+V8|-L&#f90LsWFj~M#`|2kx)JFwIIYt>qmHLQ%^$`p8tUxEn1qND( z7cgpHor+b-Gh+ht9MigoeWwUx_6fA~uS7Vd+s-47s|>UVFW{7Y!YK>FxInA!VGkLm z6=B>yVcddnTA)J{UTIG)E6Qp66dEQgdFqV7L5>jyS{f8^#=bgjbW~EG5IDuLhvBMH zpRlh!VWB=LaFL@|d*_)VOxh<*S`g0acJzcJ!$5;o0cY(KXkl2%LsJ5M94EC64;5j` zK4Hp&a84k^agKpD1PaL7SEmJ4rSe}A*vD~;fr?PTIs5A8EYzn3(i~S9sFDhpwy#cI zvr^e-1WxN7_CWjpm7>hpr_cj-CCaS86-`-WpogIXX6+MZEePjzD}Bmwh+#ny&f6!P zw;;?3jBxB`ph=^EIs59g2&v?u3j$$|{S34$E8v2Cb=pF#q&_b&z>(H9d`A)H?GxrL z2nzxe948oPW3_+<`|4C_mCAon;2Osi15FkMT(qxFk6V@0FYC7Roa3_g&~rt(WS?@$ zf^t{>c2^*!`@vI9daX#8?UOEBkgf<^(vK%J(5tM&;r zAy%rBYXU|P-)RY#(iL{_BN0&$KB2HNJ* zUVL30i5Bu!q&EU5Ip(zosUvFIo9bvZ?OM^61up2Ge4Bw@U~AfPbu`*^v!cD#E##pl z<{0QfT@&9{N2J&2m56=;KZl>G<7;$Ycf-N|r2RL?!QU+QK2)LJjrwe`JRr%MLostNtTX zeQr8RSu|DM?DZp-fsrizrK5gpwim5&_)%}lK`pZTxEsg!MR%vGZ z-c2~i_r_$p0kQ1+KO)bDi}I@^4rhtIa@ya;@=L4q zjTGG;)Zce>HA02{q*ax%Uwz0eD}oBryN$M;l@#h-uvf27stWB>pF literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..a09c5be364221e0b6bff233ba755b5dcba9a2822 GIT binary patch literal 13986 zcmb80+jCP%e#dq36*r8{_Rcb-v*XDQQ-caISn@?SH_Nh&1+pY08Qa_q7;J2?G3I_5 zV7Lv4i!r$Lr8JMpYf_Va$j%E7NhSFQ=3#TGN-DJvTl_2nG(nfFu=$CAyl=`%AEQ)9Eu(--DuF3dHboStnyKYd~L_*nBvncsXZ zo=xO#Y)d9`nOHg--?1y&lTE~vI|kyt$@ob5GMJC<*}S!7Rc=Mi<)oN?$Y6)##^}{!dzK^Co z9?vQD*WmFqHF@c}-s5TX_`Jneg*APNWIUFQNAt41>6p(`d{$@-VJrkT7yEryQE;!?pl;ZP3UEg3TmQSQp#Rcyz-_Iqmu{YkANX3K1mDT&w z4U$-u&csu`I$5D6J(!osYMHF>O=RP$vahMQP(?Yi9liNzPcmLC_@(n@R&6F4+Y{Xt zFE03sFAA$Ayqqy#EHn+rv+3brEIlxgP6eq8iiO&x4)7KWHP=!XrlxLqzFG8qtUW-s zOE0{k&tEKkDql!e_$L;gmt{QgE5rUw8dgsh<&x=WZ-cz5l}2Q;>5Ttp^5TOfP3mRY zm|Ru4c&~J8j@;a^qJ;k!k}31nEaxQ#;@R8>#f5sZ@>QW)DPg_7sxP}ZCmm2Njm)Qt z()O~Q) z6bPGSt4X$*WV=arm}JBxJ5`ceV6Y*h8#20~6$OlL$moWQZpi3{jBd#2hK#OZg^h05 z=!T7Mctu&G8#cOOqZ>B5VWS&1x(3i{bX$#XtI=&Wx~(g!8QoT++iG-Mjc%*aHMQD| zZky3#J!{~Mx-43JMVRSo;ZimtBSiv>A9Y)t=MvQL6=thig#OOwhZp7$DjBdo}Mpj4| zU7eyq+i7$=jc%vW?KHZbMz_=Gb{gGIquXh8J4tP!MovmKc{NF*8Jn;LA)2OS6ZGsx zsVo)rsriisO?Jy^J0s`!;!B!< z>*Y!qP0A@Xce}XYml;(w)$8fFjwa{)NG2|``9O4!TvE;I?)8?} zIsb?FgvsT)rYAj^>djQkWSz8JIxaEbt;eTcFZtkEp*EL^#}d&bK9y_hyYt0{k{CpR`Nfi%|ZS0mZ(@*y#xwe z4w&`dyVN?*%Br6`R=x7Rsv8}vUVUHHfDDLDi@rwLx4${-34PZc?U5TAxtXKwQBxom z&BywK*?4|1n+j%P0op0l6nB-^qYf4Y*TV;~oEv&fWW6bn^S2ZrQ9mwYAH+r@rf% z{JuM?a_eO7v8p%6d~c3<-u%s9%W6I2>sM7k$;$%FBnHmMuI0D>IBsysG@vFXpTsaBh@dC?Pyc1yi)|DxNcnjiJ4_V)Nx z15MNZwMP!M%`y<)>6)tb*!(kWX4ve<7qUH?&@M zNc+(G$?s)aH2HlJvUX^lyc9$0n-p{HkdT+_ht@Uu>*(7ie*-BE2^lvH2>4cGqpu#H z`|4!6R;FuYx>}~IWZEy&vO%&#Hu_|P{0tlYtK{bz1kl1{@8~UZRVP|PX!#Xd_)_aa zi=Is?ST>Y{q#PFIKrnv(E%`aL($unVCs|$3eK$@e6;hKWBSwq`gpzT5h^w%6whKmZ^ZVhgC0e1)tattu+ zSI`b?Xom|lA`s;mVXDnvDR9IZ9B~163gkG(7`7{Dr!}3e7nG;2ESsMRp9N`VCs{1&ygQv zhd@k&3k`>}!#)MwX${@!0^Kcej3dQBBd3IJYiPF%G%7I8kz}~3 zpiygR)CJljaE)V_fdagQ9&2ci3pA!f>?y|yhGPmGvj)dpz`YuLn`1@~j7JLIYYp#p zfyV{n9M>7*3L3YDQhBGi?GqT*ar=a@JsEAMFrnw4d3Mg?-#hC z;kOy~DsaCwxZeew&>i@kV+X@k1x{FlX`*uS^B#dVjy(*t2$rzh8cK7C6Le5uj$=Q= zVFle|4c+4cO$zMd7-Bf2ph;_J(givou%F|&j)eOPJYWqTZ~>CV=a(z5!frxq2UV*#{9^*= zInL+-@wEaUvj)?))(L!EN5OrLD-5*dEaA8{__z!Bgg~nv5ce3)DDVku@Cg_2n80=o zp4aYprQl=MaGI!`+;LJM!*P^>R@V|vT0`l6+6j6};5f%thARqs${H#k6goo31uk&x z(k>_{@VGU2+yy+LBjO=Pj)5kS5+K ztTmkO^_<|-0+%)XIRkC$OPIC>)9(yU;29lek2nSy<`j6w8a(3yJ|}RLql@9Ff}XR6 z(yHy$+F5}fjy?w3wUjVx4W$Q5PSEoLd5)~^v|9>%-Wp8DHJre60;f0*Gtk4e66UO- z)DKS33j$X;PBYNtT*3uwDBUVJK`-ejc*1c>yWxp~U$ll_bb-_6{IDs*#&$>pjU&RF;K9VaK#!-tBjMsuL=xt>}F_H(5u!^ zdH~`Cy(Tch(aAvfVK?gqzl2dPwR7{!*ZiV?xL7Lk0fQ8vLaTmd0__|T2AYJlz`cqDX#3`7#eIQ( zj$Z95>Od`WzakNOIOrzwK;QsJhJo&%wZMal1n2>ao4`YXvm6Jt735Pb@~|Qi8nkXA zUkg3(IK~-vEQ@?ykqF%qx`{l}A`2XI40KzeEqPRt2>pWLCh}MyqQ}TB?Xu^~LXRsF zdi)-tCjxu4&=UrFfUT`5R3t+8OitFc30&f6W1!Vv!=F?Hr)`WAoTihf0*5$S8E6}) z1)f$UKo7;-1fB`ZaC9)x6GtuZtReyW9oJ3ZxzN9ObHo_v0ihOoUXcg|h?~f~7J0>y zW}wwfi_BLfLbpS1A}<8GI1Vs$EepJ;NPwQ)y9q1^3~-!cpywspf`y6%XwT{<@KWFi z$9X;IXz*x}mlcW7g61ajN??}bO9uL>PYb-NNPwQxxCtx@6;b!}$bQT~w~tzAu_7V* zdC^HIED+`hGj&!*9_DM1lVN7HJS!*Vgxtj0vEbaq z8TnSk@ww4SkGFgZ$V*2CYofio(}~p5p)rZ5%D2$r+C@*p)Y>UFRntJHoX9rczsr^_ z9U$_m!&!7NPRJ(cKUt6tG0HzO-BkM*Q_Z&yAFjrS)lE`|%T^{*yMn#x*dU$6jM9q< zXkJ4Hzm!^)EcC%rq4KGEG|R(nUS6bQ@6wdFT%c|Cgz@Y_bylk2Tn$&HG)I%J@&&2xU*s)t<&5b)%CxA!Cj_p!*JU z{$ScA&5_0J%=x{k_LeyzZO$K-%?Xh?ephRL9F)?Usg*&w+&i??z?dWt8ZY|mGJCTs zwEP}ypyRQAA3jqx{wPO4IXbJUA8Stwl&gNu3vijMo%;3Z8>ZT zAIX@U8J!(HGd3rumVmTS&obxbdC29SD4)gk$+u;y^=WWbAL{?tbVOODeyyowmwE@P zEV<&d(c}K!kDp#>s#|)~C%1}#etj0$@AdfQOG|!yM90PHEO|Dut3OYt#pPQ`W3$tj z<%?spGt;x9a}(2NWxd+Jr~m#zwprFuE&D5aAE#cw=!6Dp^&0b5kF=s(?l0w(%9f6& QtGB8=uc;lYe)!@40pk~rC@*k<+wHWs$A%{_zHavX;@tVgx>K|BbqllS=f@`MPRaPXtKrmv>$}e{%y(vH$3`-p znemCv%+$i%*zEj7=joBr`KgIaXZOU+*yP!f`RRqueZlTzG!pZrg9jRRHLgn)NsY}< zj4V!!*9}gL&rB?gk6iv^U8BD)I5$6)scUQx1n9A&v8BV`*08Q8n2PBF6ms>=&ZsO+ zjdh8!#o19=vFkHuYT6c@7h{7MODjBjmzWC zz0PjziN+$KWF(l5gky=2$CZ1Yt*K9?gYj@M8TLiv{R8RxT(+jMZgFZTKs=O=CgQne_btyBDOeMZ^hDzkAL+{MJ&AQvu`JOaiF>MLhKj^MT1uA7 zV0Ac}jHt|>k8{gq6eG(KP6xYVkzCd*YeYs>_6I`;g8L%5Wl!#9c7qfzL@ed9wL_6) zV#pUt^z|j;zF0KXpUYORdflDNR$Psr&t$HhfDU+C>3g{hpHpo8P`&>ECc|wiN?^E6hTCMgO@`ZKxJ`!JWVlAlZ@7NL^&76gD6Qf84cBkDe#7+} zuHSHtK(paC8*a1VHXCkpQ8vSEHr!^zZ8qFy!!@~D47bH_TMW0wa9a$wrAWbWTMW0w za9a%5ByBa^R>N&I+*ZSFHQZLiZ7mWr+*ZSFHC*%mHp6W*+&05)Gu$@AZ8O|9!)+_l zHQYACHIV_s4H#~~a07-LFx-IQ1`Ib~xPc;s;pz}|+IGWjH{5o^Z8zL@!)-U*cEfEq z+;+olC)#p_9F!{3YLLWd@SzcY8m43s^yo&RBqj8y@r~8XXP-{5hBX=>tHO~`ESQXR zsBj{l4kh}BWq4ya5jhl$b;)77Uykp&S8B+W^I6Ef>abizRG3S7Yu9tAmgiI##d^=u%Y0*8dpxOJIF_J&Xk2) zT@Scd%jhc3{Ix^o;SXi5cgTGBLz#ETM&gr;zD-owf0=QGf9MK!(@ICK^l0r=TOSIh zL%qIaBt4Lf`}#xmw1B8c4X4tPKDieBMT&HyUU~iB;Pbj%-ql9tm5ppjeum}euzMXE z+-~?>lHDNL?JUnS#5%ifK8-i^B6{lni=*6t0f)~I6ryT`4*{{s!BidS|*TD376m#dU`P_Dy! zlZioXQUnb?G;lPO9fq$BzE9z+)Mo6I{j4F_MX2w;=}1S`HrC z*D|Zj+n8JNR#eGg4JFwj`@L)v_!^BeY7H-+>#;*tN|Vadlw0{IJh)|WtE`uf!L8Fj z%J8;YuZLtd4Q`Ro+XlDRddv0mHu=1Da7(SXNOIx?+EXRN zl`>o*!{stuCc|DCmZg%lQty$a@-ozW*U9gV*nuV{t4Ob+%XUL9rF83GPTyPULNw0vP!_QQTJesBW*Ghc5gShG@B->m{wro3E z1om*WF{G4dTkMou9F)5R`Z+=j*OYRropP&#a+^@?{acQ1hKowQ%}%||K|LUFh$GH$ zL@5XClmiaR?E>8#hnXtY%<~*X$C0o)0*%|5eDrDv?M9z_aRMq%`wJ6i?ck2 z?9_)G)Q1H+IA$46Ddk~1eL)cdF6<}3EhhxGSIY=#}PYq zdfh3depFyyt1mOmEA^vx>PH>akLen{&yiv1QtHR-)Q>r+AJ^({IQB45=g8x@ojOf7 zr95*&U^hpU;f7K^VW&(}WGUs70tt=*272ksi{U)R?bOE|)F%X5 zbnkh8&pIg22&6bJGf<`E zF=MApU9MD_X9Z5_-g963`=uhx+7amGwG?4a;IbwxG0;m$9&>i;a}Mg~bW41~afso( zQa@*>e$GLCUSNb{7XuCYdCc1>(?X$?R~7_99Qzn($&|-}oic5;l~P_57~n|h+PtmQ z7wyy+9n{YYOmduHppC~o&f6(d1(hoI1%ay^(+o7&=W)SKnO<*7DPPiUH9KYcai)~=b%E;~Jq*{C z@^w39%2Z1EhHjBBIFbzXlSv*o?9^$wT}u6?R)5NIoZ+NWziFpV+smcYsjc4<*vD~3 zxAVt}prY+4D$55*w*?M!TwtJ0;Jo@F?yRYbh786K$Ih*Jx7(QNe}Hww4LfidL(d^;~)cV5opRIdkSqc zIZ+-9%yJyl_K=G;>9IYDy1NtUTip_Fb4)SpT_b&KPomdcC(;v5dc|>`fnJ8RO;7Ae z^rMjzDJ#&f`_gUg!KF1?)}EIA0PUGTOw*n*&<_IIuBY}Sdhsh|SF6A!j#dU*a%jRc zdjc(`N)f2rJQq05(ZWEBN=JkaFSzDdyP7pCcU;N(RArVS`k>#z4R6X{Sd23EA}MXuyP{3(XHWu zrezuEg;>+x*wg4|;8L_^fo6_orjAU}$xnXppK1T<;3rGH_bJf3Ri81HNAOsEFeZ=R zsk6Iu7B^eFdPzh@)zSR|bMVyVVe-JCI*cc?deiFQ`ihHXHf30*V!c$B=d|Q_;XNpW zg`=42@SZw7`3GVbK9pJ=ex(T7c__*rmyd;;9Ri!zVRQNKB=BQdrf7VhFPsPs&_UiH z-EP5Wo8YU~)N+~Vqt!%(OBwh~9)fgl&C#uik!dPNNp~obzMs2*?o7Pzf<`Z$>&t5w z(820oa{;Xbj0X57VkQSpM5;Y&J$?e*X*RjwJAcg@~1b*fahB-d|l(bEq0s*-4%XVz?1 zk*Zpy-Ld~ivz3M?e`)wzZTQXYI`rfXYbpB zy-8(nEsYA*@}us9jmfb^)(U0*Q!e}0>b6-j*cXupi0g{)6S&+3@Y*48&xYJ`xxSX5 zt6lwlOQ+;j=+9bJS-9;z=o*~@blTkM5}J22U0qncc9z;mqTYMjzpLpP(oaAAA4I0xtN;K2 literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..bc0d34a2ed3af3157cffeb05fedc6cd8af5a2383 GIT binary patch literal 15218 zcmbW8>r>Oon#XfNz_E3}vf5e4Q`eWrQE$U(>iNdq(7SR@op*Gc@m6EkGxUwsrj;YL^FY=2u6eG*gm5p>JV)>j`R+x;c>x)G9NA||@i=Of)!Um&`ly2Pxw>NYxbwN%Ysm{!Q#V}FA+GO?FO(0IL*A?4 zdUA&j7Cj@C10UFXo)W>U%-k%^TuJt25~)a6gZxw{P3lXh`n+Gt51$uHK&?R*EmK=c z-X)!!A*Zh@OX2-WYRb4Z%W?7ESUSV=iz~_IH@OvxgfI1{l_iH~q&rqfle5XZ^hC*O z@}n%=!ALqzZlpxsW`6=-sX#~vJgxM1u?Byj*rvfI{dLn&DR77ai&OY}`F%}PnxPWZ zQ^*(TAJoZvBN-i?=}D!tv2>sMR3n>CF*$`y@=|n-3~bj)WvE$&R!~Sss$f~H-y{f_ zV9*3xOt94i+e|QIf?*Y;5*S&(;rb2NUzWgd{f6r|T)*M^4cBkDe#13d0mBU#ZoqH@ zWoZpJV7LLp4H#~~a07;G1cHVeG~A%!1`Rh@md$X3h8r~8py37$*W_w3+!n)aG29lz zZ86-IG6lnJG29lzZ82PvwAFB14Y$>BTMf6>a9a(xwM@)#TMf6>aLxB^hTCSiZHC)s zxNU~pX1HyJ+g7G)xNU}OB1487GTe~ih731kxFN$08E(jMLuClV)gkJ%VZ#j@ZrE_c zh8s5Au;GRcH*C0J!wnN{u~rUBwOKVt;w$*ji~tQ&vIu%~qfnX>der#Fn&fAnPOpYF z8X)VtV$nn-9owP8sbn^q>Kl^bHC?IL!APP*4%>Zle9yn80eGdH7b6Kdq-O5q7rio~ zhK71Q9M{v}oE_?m$>?>xk^OS+lhdADFvQcTWN$2)#fDWhzDuFp+U9^y&ilSlNUi|X zlplPP^IeOj6?6RRmsHGPlCQF2YsU!63qCr!If7l67rXv zMa>GqT`a1rJo~qf*@r%ry~#2Ap-*MsBAbp+E)3VH`v2>+tNW*pNT*r_$(10jts0x6 zk!-ZbmyTuo(@9@nw22lLwV9zzHr6ZGiXWxOrkYe0{0Dqqm&;phdtTZ02IbF?{5j-a zgRO2id@f1fD(O>^j{p1L9}kzxkorls;9@E6*44Vl|62NH;-|>u&z&8re0S^W%D%bx zQ|IK*9g*TU_41pMn)f4~_amhFJHYo%h=oRZe9i6`YM zCK*ZivOVe4fHrL(wr&JiS@D$C6c#5U&^b`we ziud20vY&2~W&2HE)d*}`k8NwP&5P|aQ32Z};>*a7>pK?4Z%;lnN{X(&M$fE>M7hnX|~9*K{gS5i)Iws<~6 zlV>Hq_0-F7oebB?@Cq5Okzub4%aY0JY4XUDc^R6#tL5J{*aAP3b)}cvHG3deSpH4$ zuPYWapj|Huxy7^}(_T#b_`vmna??xhqGsw92yg@#C`AE5sqa%Qb+fa+?mkqj!AjCK zo6sV#o1={(qtsjM)mt3YI|TYTq72uSdaJ#9tAl!*Q2pS0j!uS4iqK|HXmcQh1P*c} z84fG;kiB}yK|L(c$#IA&EAA^o*q#t}AnXvxa-3plSL!?L)pt0k?-V%AF~>k7TLC-m z)pt6m?-IDmaZ`Ker6TOIC+u<{?AGlk$8|Ge*rzDF?J2t*DD47Mny|z`PwEA<+Y_h) zmq*6(;X(G{Jpx^t@Qh)~SDO1O_-F38Pcm3qQnJ>j67_Ub7I^*-HpZgX5`IHL%C_JlqM!U0WK)P3Nw_SB*x9k3@Ia3G}xLYnfL zfm~WZ+MYmNv{FmW2<+py#BfomXYAE!L0(BcD{z#foncC;XYJLq4(j~^vmE;v4k`71 zd-Z+?^#NVW_c#W04c}9ggZ7kz4wPX{dCYNIQyweIfIWqlJeBHUP*dJ;j55$7uz*2( z!k`0TNMHxY48tjU#RhXs!7p7w}=rltZ8+Y{*V zs}kXez?>#5GR!H$5qrWB2f|TZ%MUoF7&;W;s6FAR1L2q^yye)b=v5tq&_Zil4BRc zRi!>|uRiXeJ|S?Cqepw^nIcTs6DAx8XLLJy!jWa5!K#2W_5@lOR`SrKzX&ufdCqZJd+52MT(YNJ za-iIm-`y2R>wfT5lU^&*WqZ7Km_3Hv>ICe15<8A@h?bYeURVDQs0yj9i8Ez=`8}{my zv6A{t-CAFAq#5WnQUN#Z3AEg=M7X61&p3`ToKS>Y_5|8iuSB4}a9dz6#~IxZo+yfn zwkN4c!5T>PR$vI@xtk;H>T&_ZVnm*R;FU(a1I@+B1PMO?%5g z+jN?CuR0oSxj5183*6GQ7rNfwEEDfnN2J%APQ(YgExzLDV4zJxZQq0HXb(O?dnnMx z5oVylPm>;2N1|n{lU?dsH2bwvC-=j|Gl!9AKdB3{84m9f`KfoJdau zW;l*&yU5*|_M|!*4GT`R?{(|A!!g0IXPNeWbu@YmccMMjwAUOL80eu)+xE0N8of|+ zqU8j_y06{Q-dtEF=Bgv+K0$mgkkG{E4D>=o+xM(G8a<3wvaeO(GDj-|En_t0d36+8 zs#T&;w|XIPjH88t7O$H0qB;_7gF2C33Y_BzG0^t2CcUhVM28xjNDI0h-sk9IpiN>; zTd0mk&B}@PO4F7&`gA+Iy-a*n9g!X}orsG9J2{Rp>|7=-R!5?jL{6mF0!fZ>2HNJ* zUVL30i5Busq&EU5IOeqnsUvFIo9bvZ?K;tx1kUT8e4Bw@U~Ae^bu`*^bE3V~E##pl z<{0QfT@&9{N2J&2m54!sAV-j?<7;$Ycm08XrTsV8f!{6kJXE2c4f<@bJRr%MA_;jo zQk}e}lhnD!;#D6NCFpjDIWX+K1vr{W3gB<#BM0lIi`>9d!HU*Y0Tc(&5WO z(H(R~{x{u0>k8uznWH*)(B?*K19(1Ew*_!#=Z7tpM(pCSF zsR1t?r7W3BcL09VRN8_trpg@EnL1)*mTSIbYCxMhwrpyEO!fZlmj1etOG^{Ku2q^D zfAA8{^@A~)?m8@aKkGY?E;doG3!CYLz1M?pRN1Co-eucs)TvsQ6Q{%`=QqordN9C|2D~s~~F`xT8b>T1_>5a*=;iCL1iOXGLFQ4}Ju>9f* zeIrG;2le|MU5!wozi3ru?AIT1%Zi|abh*Ik7NU2fymC@symy#sBx&z`ZRvfNcfGu+ zf(>+eg>JT_<9mCubazGGm>ip%xhyZj&dtuu4bM-^Ov`+A|3<(5U6x+vQDyuy-40x- lFJVGnVDVs$xnn5pDW&_9yz;?{mu1wAPuCArj)h--`G4sOOWp2u@Rz^1gp<0*S>=WN+C+S}MsNdhEZkPw1ILK2f8;2jVJiGT>+?|0jH zK@{_CGq3iXnYVlToZZ>!H@=v8KeJ~~{}cOmU+?LyUsXb-wevVnJV#QgRDD17`_=WS zr)tqrKNOCM@XWc{$?W)?m|2*gU6>cAXXeC(nT5HradBG4i)-EKz8iZcX3mXwWJl)a zu5?UhCojx)MB;}M>5f=5oeU>Zk&gYLu2eJ<>*$Ka!@d2XRA0Ij<;jHlw(o9PlP=R7 zn;RdQA3r4q$4^a6QS9;$*gDz1_Iv-Z_BQh)?I#Y&>w7T_xXI=*Yt$a zF_=p`8T<>J<(VsoQi}pk?vR`>~iE^UJU;Y5f&>G-)q9s43(gsLY~mT zkWStoO6%x!Zz7e6q>}1ejchu_or_&SpviL8m`xHy@u;GT(9AJ4cBP-4A*D4KEw5ur8Qii z;ra~MXShDY^%<@a@Efk*aQ%ksH(Y;NHpBHBuHSI|hU+(6ldIKmTMf6>a9a(x)o@$O z6b!f3a9a(x)o@MHHp6W*+&05)Gu$@AZ8O}qGBLw#Gu$@AHNUqTZoA>O8*aPdwi|A{ z;kFxYdzr4`wi~XA3>a>}a07-LFx-IQ1`Ib~xB%@k}_89G2m=-HFJdP^?o9+etaT=U>wRyjsqSp_m*}(|7VqZW&QSL%kl3 z>uGS#3@0NpdVPPWPtJXE+LH^0Xetr!kHj<# zwMZ(OzOm<{)kVLYk0Zk$tSlS_d?hEdb!R(&UYuy`?40^Z%~%^79r#MlPfj&K5ijSA zI~!D-ocx@>Gt>TiH4my>LyNtQS*C(xu11I3i7ojYlQXO|Ra}>|#&xH&H0QZD;j1P& zk=J%52IAexS{baDUXV_V_B$E2IGyB=7rDB0G7^r4V%S2nt`&G)Ie2S1IPeh|ccpRv zUaLO-L*lk7ocj7FZ2c6eww&~JKG#q(vF($fuggJStAzwJzHD^l)ry4tC1+8yLU0y~ z>L}0tjb--XPi1em%zpS&*|*82KcfF2iayMw?;3nz*25fVEhGy4leB-K@ z;W`fC37=0yVuCiwb%wPlXaz++coIrm3o_f^)?IjcA@&gcN|>|mlUDhKB3)$5D+-T5ob7})C2a_ z0~YE*fi8~2Oj&VX5rXy!K?}kzfegoKh7P5^%f9+93-#RsXE^2p-&O^*(dC?AcO=4IYJDBO1;y*dZ&eYpTHPLf`PhX0U`V9Aq({`fk}>j zhFeO#%f5P-g?d=vI>#^rb(8|a_SM4{>fO49zTg;V7*m99`-E-_LPQhpa-7#a?Wv+f z>{B8ZlpcW|jvEX;O1;OvI%TZX{`U(E>-PVIfmXl;?6*(YZ$ao4n9_td+DmU0rPn^C z*MbrixTz_38B&T6wNHpz5Dw_tUgX%va7_^o*eB31S*b2!0&N^I2Aa4F=(Dd*16U>X zLjnsNM;J~h^_YG2n1y=3KrhD-!*QkFZ(qINLOm{UgyWQMKaUh4Zl4ghAS48)Ic6DX zz$zeNUp--=p44sUHpg{_vx<=USqR%)qffdd?u7%nRHw0(72kXKUA2pr?+V8|-L&#f90LsWFj~M#`|2kx)JFwIIYt>qmHLQ%^$`p8tUxEn1qND( z7cgpHor+b-Gh+ht9MigoeWwUx_6fA~uS7Vd+s-47s|>UVFW{7Y!YK>FxInA!VGkLm z6=B>yVcddnTA)J{UTIG)E6Qp66dEQgdFqV7L5>jyS{f8^#=bgjbW~EG5IDuLhvBMH zpRlh!VWB=LaFL@|d*_)VOxh<*S`g0acJzcJ!$5;o0cY(KXkl2%LsJ5M94EC64;5j` zK4Hp&a84k^agKpD1PaL7SEmJ4rSe}A*vD~;fr?PTIs5A8EYzn3(i~S9sFDhpwy#cI zvr^e-1WxN7_CWjpm7>hpr_cj-CCaS86-`-WpogIXX6+MZEePjzD}Bmwh+#ny&f6!P zw;;?3jBxB`ph=^EIs59g2&v?u3j$$|{S34$E8v2Cb=pF#q&_b&z>(H9d`A)H?GxrL z2nzxe948oPW3_+<`|4C_mCAon;2Osi15FkMT(qxFk6V@0FYC7Roa3_g&~rt(WS?@$ zf^t{>c2^*!`@vI9daX#8?UOEBkgf<^(vK%J(5tM&;r zAy%rBYXU|P-)RY#(iL{_BN0&$KB2HNJ* zUVL30i5Bu!q&EU5Ip(zosUvFIo9bvZ?OM^61up2Ge4Bw@U~AfPbu`*^v!cD#E##pl z<{0QfT@&9{N2J&2m56=;KZl>G<7;$Ycf-N|r2RL?!QU+QK2)LJjrwe`JRr%MLostNtTX zeQr8RSu|DM?DZp-fsrizrK5gpwim5&_)%}lK`pZTxEsg!MR%vGZ z-c2~i_r_$p0kQ1+KO)bDi}I@^4rhtIa@ya;@=L4q zjTGG;)Zce>HA02{q*ax%Uwz0eD}oBryN$M;l@#h-uvf27stWB>pF literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS b/internal/gabriel/benchmarks/IO-BENCHMARKS new file mode 100644 index 00000000..dd8d870e --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "20-Feb-92 18:40:05"  IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;4| 17729 IL:|changes| IL:|to:| (IL:FUNCTIONS READ-FLOATS) IL:|previous| IL:|date:| "19-Apr-90 18:48:13" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;3|) ; Copyright (c) 1987, 1988, 1990, 1992 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ( (IL:* IL:|;;|  "Benchmarks for various I/O functions in the system.") (IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\;  "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) (IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;|  "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* '(IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) (IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) (GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;|  "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:* IL:\; "FPRINT") (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS '(GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI)) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) (CLOSE GABRIEL::F))) (IL:* IL:\; "TPRINT") (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (  GABRIEL::SETUP-TPRINT ))) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*))) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT () (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM)) 'IL:REGION)) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR ) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) ) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR))) )) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT '(GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::123A GABRIEL::234B GABRIEL::345C GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::890G)) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE)) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:* IL:|;;| "Floating-point I/O") (DEFUN READ-FLOATS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" 'IL:INPUT)) (SETQ *FLOATS-TO-PRINT* (IL:READ IL:STR))) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* (IL:OPENSTREAM 'IL:{NULL} 'IL:OUTPUT))) (IL:* IL:|;;| "Printing to the terminal") (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time.") (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS (IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN (IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW '(0 0 876 30))) (IL:DSPFONT '(IL:GACHA 10) IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* 'IL:PAGEFULLFN 'IL:NILL))) (:AFTER (PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)))) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (IL:* IL:|;;| "Symbol reading") (DEFUN IL:READ-EXISTING-SYMBOLS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" 'IL:INPUT)) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)))) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:INPUT 'IL:OLD)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER (IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER (IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:* IL:|;;| "Set up for this series of tests") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "BENCHMARKS"))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ae0a6d967581c2abdea6e524821ec342e274a6ca GIT binary patch literal 14045 zcmb_jYit`=cIFHzN|t4tO8iKiY&=eCdrg~)o|a`hiun{rrbvpUY$;H%(1VV+dQc## z*s^S(2)g@Ymqj*FlI1O&V$t?Tf$a|i1p?cPLO{1@oBi7a=mXoI#cqFWfo9tRy9ms?rR&N^tF3e7V^v4;iZ{EVSPBalq;?dhvU~1>EW23P6iXH@bHK~kkZ4k;XpVZ zjE?zJ*V4m!!e_O*F83cu+oaAFvNNUZycQ|s=4aN=YrQ>MBs*JJn<=boJwrpixO1uJ z;-&uHq5h!@gMIzoT?ZombWEyLeK@n0Ey}06wZvR0KZ{xPcK3Fl*ZMAX510@4;o+}7 zu6(4vl6T<0x6F_Ibk*6Z@a=un@HkYZ@?rU4M304osjxp24#g5d)lqr3?D3{E{&>ir z3iT{J%7u|s#p^QHe3s=fcSPZvXlm6f} z|46v9saD=Ew?laK#(R}==VUmQnDhk`V`GW9k1SLvw_BD_DrNUZd~Ipzo&%UTPFip< z42;PZUmlZ)Kw|H0Y zl@_vEalKf|E_YQnX($(s331}Mc%f20HZn6?$iYDLpe6HCWwS-R#Jy-(4Csy|Q+hlj zF?DD3v2ZF~0iLafZv$zgi#SD=p*b0LPKz`6b-xq<`|25VdB5CYyU}AlblsoQ$(m{O z@EAP+ONO0;pKIr)KZ9vVIowYAGnsHI&TBd$Cgc<+W|Lwi|M` z!iOh2t;yIQKjbyK-_YZs#0@XYeAYfutGA^o?0F%UE0&5{{w5}CIEc0~vz#rSXE#|Z zX0=fwTl1PogVtRZ8H#>}*H&QzKeF#^Poyc@HLtuK(M3(Y1 zrQFI}zSVqgr9@uK1_P4&skaYL`ZI7$afqgL8p7JG`y`qTDZAB*elA&nM2N;}=2ZhH zS}uo4Gmr*xGEqR9eceWak#4*UVch`C_g}GS1S3*cLuamI#cZ6K)i)l;3T^L~@E1E%!^Bo=B&LL0JCSa4ZzAXJ`M!L(hL`4% zm>?sW%NMf4Z^>9cY=(wnT^d5HryLu9$h3iV|= zKF7*fACiu(w#CsN2aEa05~H3HM?K=a46hCEj{An#h-2!t*QWE_k|bGX#tl1F#1SW z|3Z&Gzx7AD`sl&`T=hp8A%Nku739`5l|im)LGY7)Z>4+@F=?YkWGEA9T%^}ltIz(5ce43NDlz%LY0K46#5QmMtz+pO<;>JAM zu$+Q1zdq(rJ1XTv8}r4*dpB3fW?iLXNuh=IZn-s`34Wt$RgMn-hLB~YHFjK$!VkE@*+!5v6U#6w9pyVNI2hj>*zUfDbX*J|?zf)LZw%e>x3 z*CWy1KG~vceYCG%w&?m=tbahZ=z1(Za6z`{I+46EC|h(ro*KL;TXdbyTpW@ux}LZ` z)Gb?dePgnl(h%rE*Hdp)b)jp2psEWuf>m95di(kZF8BlTIc^LFg0e-w3|i^h;0gNL04C(HGUR)`-+7-aZtsl7ZASO%1fIkqnKm@rBO&pk zEL?bdGwgw~gE<43# z3%vnCPu-Us=a|bOBm{2=@(90nm;qOjME>UnmPf6q%~#csNzV5l7HkU0!zq#awTYB% z^b0h)vX4p32w-yL-`Jv)B3^syQGY|EbWrXz?3`rNVUTrbOR||50I9-nZ7NWb(H2T4 zQ(=gDYGr;)${hAb5SD%6>){kKdSkaoG-*@mViT2qzfC1K6W|R)p*{Pz%}{mzeOX%V z_l%!Zxkg#$^bDu}aQD|>#ZZb729HPu`w?knt*|2sfEV2gAxl|WL3R;#S5-1s)GJLGjLJc8_` z6*mq{>+$qNDl9jJB);`V1j%kUo!=G{Rt_+>llSn zfZefgpi(~BFs5@BW9*2n2%*+R^+1(?T_9jde=d-(q+u6`S5mMGq$}yy1;Ulo>jK$I z+I4|wCFP<-H7@Da1%j1S>jJq-nstF#jWIx~#uy+}V+@d~pGnUJB9)Zt0*OjGb%8)7 zmAXKl#ubQD5~>TNDaq6Y!UU1pxGKPSzSNW~7mQ3MSSg>_j^(zZ!%j#B?fe*|G512y z0T6VkQhsH-0u2frH9S3BXHn3pl_-RG?#yM^n-&Tg#!>BAE=uxOT$@vL1JcVgKgYkKK(N9%_{VU~z!KLiXicgjsmWw@`wNhI#P)}kU56Z1cD(?CWRj9zbZ#tPtMJM9ddMWrlIk9}Dabl^*E^(!W z(Xm!5Wk%CZF>Pf=Lqx(g8*Jq}mhlxuynz;Z%wBm{!5~#D*YWN&^RDt8Gh3P_rhSpp zN*qLVcWYeCL;bptU)E%4gcs10@o1800}olFYXHcbPVuG*$c1jsN{%J1)Q>&eN*u}3 zqhw=c!CHve)xmFh2(~{`0itE&e1iBGX9p9p*uAF&GrI$rZ%Qy1OfcUhFkj%Tr3Ot@ zFAXK`i&=zaFR$UNSh6WzTAd!H@v1dWcRb!uN)Mm{?~}(aUc_p`!6{~GQ5iJ^Iwz57 zh{K`249}UYuHmhPM~ja~SDe54;sbr*_=7fRqbH8mbzr=NvzI=cN3i)$hq< zrb0OTiTM#NC?q-5o=Ul>`O~3D^N+NDr(c^syW?ZeW2Y6vUQu%#1B&g4K=yfOwuK!R zPhkUoqCU%)QxcUob{9vyP2&h({m6WZo&}t<}@BJ*NkvC%nAb^+~6o`o0uJ zdtj8>ysYi_thJ=5Viwb&ptHjUOo8WBlnA(<;F9nQAc zjUbO26M6Rc`SXXCZq8Gf&;gv<$;nW0_Au_WB2$kf;u#)XajP2cx#D^(M(29%Nt`%F zu=pc!^`I=}wv70LQGYw!)rGP#YGF$+J>`6VDChg%iroraHB~y~W^Zf3*mGJF`mr@3 zfK5PtX#l?GC{GU?TwWLD=Vf5}u|x%{be;m!aq~1~ZegZS@81+`vQ>pvVB*;eifCuw4&2i zz;OcS3&v((3+aR04b)`=YQt=xPko*x-j<;#g~>O`?z!7`ZZ%VS{`ETN^9@eyRGCKX zjd;775-%t4+YfYWU2EAXmMz!f8eeTL{|n2^$mP-Z>AdA1EHQQ7vMjyj7pAu?lehG8 zE>Gu~c*lg!s}blIW=dN2Hr_(8y?uh0r?iGuE>tUvuB(;u5gDp*8iYL> z7a-_?i_ozPo=CZ@{>A$X51vJ4wscZv5}c#{=VNkC*VgD`a?jD76V-m@S&ZB=jT0fN zx%wa-n@-i(bh_-c^hCF8Z>F<)mOXc>W{25-Uz9M~6~^0-UBK17VvU)V0I+Ig{y2Ab z$y0TSvvPz-jjA60{!BW`qS}v9`v}2>$BRF^rhoClD0TyO6t69Q_Ol1Sk|5TtaAZsk z^8EqT$AjEH#$W#eD9?T!DB zlzn22^Rt8et^>XM;iI=PIqdDUoA^JQ4D&cg`JEZmY?{cDNh3`_KKM_b-9wYoH>Zi} zkeVRRw=@~#T7^-|t42I{tx890RWGhEyFF++w#?-EvT@(_6#^r_jc_^>H(V&(~ne-=|?tIcvsq3m7_K(RX_TMR5@xol1&x)nvE<9+a2jen;v#Y zYN*RzJ;{z$ohRLvp7f&WNw=-6Vkb|cms+LGwE67YxjA0>yQrhSymN4(y+W;9tvkiK znSYmL@+7O(vB`#0pvG#vo;bKeDiE{5Rkd2fu(?B4qUtswmf2#a z*(_BqHp>NQuiGdWXsFAc?PgQ3&TbphZYk4l8=MR@up3GUwp@T2cbE2Se*9&Wx#3EfHqZRI#9pvW^E!Qlrot!3Td?*vS$O@ z6s$AgU1`8s(|~t(XF$e?GwuMV>--`2#|_(@ama%F_DhcgC9i?ze?`-B1^cBoth7M>WVVpMjlbtAtmX^&6N3B- zo@@O%ef%AL{5^gA<9U9XMgB2PmO6~XTYkI!r1e{wUX$M^|KLdAb!=4}tobXVqj)#F h{$20Rr+srARo0qU(NQ6MsyEsle}YM>cfb1T{{b`%Fnj<2 literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~1~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..e05099387ee931889feffac88c0b71fc25bbb1f3 GIT binary patch literal 14051 zcmb_jU2GdycIFHzN|t4tO8k>J*?64P_L?>ok&@IQ3&W3ZL_aUfc{|nSnT#;3pCpn*hP?j z=iK4UP$Xr^N#Kxkhj-3B_dDmF@7!}o@7cO0gE1voTwcj9#uWv<@8yii=ujV#TSN^2werF?m1B%HXG%#6g;Oe&a6het;JfwUTqjm+i> za|_EerN#1yn)C$1iC{GDPhZXST^ih%u}GaO^ z@9?k>cP@G_TpaWb4-TI@KQP$ew=d$)#Dq%qhvUTpKkOY=l5>^fEGFUW_w}Duyyq?s zo;MyI!oy#ET>D6Vt!Tr4Zy6tZ>8iI^;@f+u;j+n6?ZfK+h#CtA(_w!$9Ev4_vaR-R z)#c7){fUr29rCD&)I`=@tGc{OrMTi*%DtUiBHWf`h^YOj+7+2d1hZ-~QQMIIQ2rJK zxZB$ZYZ zS%IlDtH#6WObvK;>b?!6^)A{8vJA~hw{u22gmL&)KF%Ad`K(+QTNYpxxyRh0<&hw|S)Bv!2GeZyD=_jl&_!BG!f1*p5+v~k>j`|7z zaMSH~s~zJL$t+eQd2nwemQ1ClJdtEN4vVRYQQYj&Z(dKU==UL9MRX$5Sqy>cJr`Lj z&Q$V+w>&Gwe4#>K%LW6Id#SevPx`ZPOzi+o=_G`8oA*gH8&Y&@6#YV~1c?xh)y%5~ zPO_XY%q-Oh=oOD$S{Pm|AYNwBdu3%!na`IOm6cqH z!r@F|E=MYy)RJ0C8*kKRe`alYwz#B#2d=nGc}ZN|O4a9tyoQ^+DjY-)up(eN824XgygkSv z)O0ct4!X%*gy1P^$nri%35WiSQuHF zM`D7EWUg4sjl3md{dQ>xv7U5f{1Nls__yARexI+RN9Sah%`Q=_bNgel`T|E>s-Dmp z;NnG{#(D88#$6F;C8^GdHhG_R%C4QV*&aZgBkT1JVIh5F>+BMY$|!3V4wa}c)A1Qr z#{3X;Y_?5~cG+0WN2VD0gm&1a9qxDugC2y6w0=U#-~{38r*uR+aacRGSB&mNrvrMY zI*n;3popX}6;i0MJpiwLB%d8O$2YI`bsK?6TGmLCA(gj$l7Y zF)|oSX2QqliX+Go&FSc+^d>Wr0@H>=;T~$K5f3l^OsCc{gdT9M^Bc`YPp$L<{ZRYG)=D4yp*^eXPW*7A4q>jOgThQ5XLp z++TaWRy_)pKzXJzCWD(kF85*tXCOI|2&J6tQlCgY+UxSs+QuQcR+m2zgcz@ndA*CS zN29(0(V}a0Y+z8d==y4Ga7eW1I-VFhCt7r!Or1L~T68_0K7T>9=sJ_VFf3YhJ#lTg zU$p4@`eZ+)A<%`cr*71Bp=*Djt_wGUbzQu^fx)43{(yLn8|MQ-(V}0@UkHXoiyOnC zuxQaQ!~NliXmP_E85J%1#p@f5iWWBpqAJ!Jks8I@N80OTAo)~V11&k1oa5|$a}Ekp z+UvB$YSoupT1rn8E$i=?=I-U8{>C&_zhqIMpFN~~ROE+0tX2QOh?Ip%T*3BenJJi@PSM!=N>k^i}lUC9sJ|gn+Anq*R!*|$Fw8o1rPxdifKcJL78NMT=n7?0 z=`ch+vogOWWe)ly2+N-EwQw34y}sKcnlx4N^|w*!_ghqQG67!K7236bTMX6Y-jumc1v=+6Q26*TMs@d^rdfOG}@IzYIBdL1BJ zLAwqRt)N_#sKy1|IzX_3Y8@a~L9-4Jt3C!uRUZR{s*eFO^)u-?K%|0F9UxIbrw$OP zpi&3OQ@;Xn3PN>&GzFPDK$sv>3s(gg&sW-#<$|8c1Z&k}Td~|ybl48bpp_qkH0Evy zIsk$W)vB*;RiH(Iqk*SKnk))BH4}vp&%IqbsbZ^w0aN~_baG44!xEYFgn;tMjlJ3_ zZAiPMO=~x`d2Ly{t*vQywR@KF)osTgt5wgm8NXG1rHvNYJ8jY84(qYrpvf3%V(Vcq zFbb7T1z9XUJ+-h&PAyJQ+C?z}(c}g#{esPQY*HlU%#9r5qF)}gZRYVQZ_@8P$U$55 zpuEVJQP1WAb{sbl?dpk3FG5u})pIl0T=?Ts5854EC${%v^&gFXDx&C|hFqDbZzTW~5z@b1VBQbBppJ&~YLhKzD}BdEm!^qo zU#7egM-lz~3Rm;W%B@mySrN4nUO`XCqfMp_JVcSM1t2%=+D#J>AEzZpQfBVQu5D(H zWa%-ov9w^WL~QHexI6^gAGrYWvVK58gp9+3iCFCZGlH4h2F#lR%mo9?n*`=doVGNe ziSnhc!~<;>aoNp__zKo+n%7pZOKQDr_2V6vJCs%fD8YNgxr-aYnsBgdv$U%8A_5(h zh&;q*lV64BOx73i=ECE}Cu0TsufF&|T{!yiya)=P+C+XdhHm1j@xJl&*y3kT9{w#Y zf6k;tAxDZMk&svoT7KqQ_BqqoZ0x<}k4=O#bexk7kQI=0!Aiq*YkAM`qj!&sFIxVt zY<4Py)1R0h@q&VqP4?ERWyPNfMcRL4{M-H7_StP8dl6wNhTWoKI|3NH5rV7}&u)o3 z4xYj~97TSfFQ)`7H+B|C+-(C1<*8KEHY(VS@nqhv&6~?-U~5(nM31?7yXz5NK^1-> zigv*$wz*l`@0p89lC@b(gQCthTQCW(R}V1e7EJn{u?#F)4YF2e*s&PHIh)|Fl<+vq zYS*JYs!ZhC-{;RCn!4FfU_$$FZYL%~<=KO{(}`R?l1yZIaLFkvxaUZyu^64~b*FIV z7{Tg~B;@^~nABj;UEYo?4Oh=9Ll(~hOQkhRx^b?gG2Kn~Bityfe zh}7t-Nn|mmuZp6|e)fud-m<%weqv5a>LP;+xqaer%7%Oh|;}U6J$vN z*-wO3QF2KVWG_VMSg68>P&3Lc^T=q2fVC;1fE9JX_+X_GtCU?!nOJcN#n#JM@rO=` zygq(vPDoe&O}YsU21 z0Q_rnq$U8z1%RIz0FD!YuLO%YsI=gx`ymjd)CN0)Wkl=?&$crFn=f1U1?*Q*kxWY} zZ3b+|aKfN(2R4yEi2XoQIv}@B2L|L9S>zoNi_(~VoBW=;Z6#MDspns>aYoGTU_RA%;tY#+8NnA`aYYx{DUc`$z7I(yZpj%mt}Gn zA7}G)q>0x|=*Sw8eqpAfeBc zbhO)K@>BIxiMD5!)U+cog}^P-p><~{9HX;S;TTbwc-)={U*}r2wCK1}s~!@u3I{^i zrEv{{9=HG<`{0U{&8lC#zwq#Rq-IOUMJmBr>VG~V?{sXAJt6-bdrGQ0C_Rs%JEn0e zM0HmW#ADwn>-$cJm6)FDm)-4@mQS&ZXP zo*m+3T>vc|;!&fri@!e;p0X$pV$=bGaN)_~&#tOpd@zO$ffdH9i=X}M;jaXWO=}!E zQ>&DJNcQk3caHGazW~eAUk6J#I;BkdYX0{J+UnQFYIR3gks~H!Apw@kV4byqwE?hx z00&Vv8KwW)9ZKh!H)eO3g+0ZM@VZc=8{M&McT6|pO=?Rw!n-UcYIQd{ zus)GcC-3jrkK}z8A%-8xF2j#3s_@RVwJL`#QtE#64XJY2a3qT=;$<6A8n!yp%N9MX zj?_|@-FlK0t0qsnBRuJ4!;|iqiN$uFM6b3AnXqJ=;_tx_6}sc)7a=hckS9; z(}6_#-qLE9EojxPwo7`Ghb=Np|G8}VkEzL^Alhc51uP=0Mr)~F3?h!UE9r~V3Xa}h27GI-PSo7Xkj;$5iGd?Gwu%U*ZvI5d|$Y6 z+1;~i_e=wBlMYNm*~s(4o?DA$xcOU^UY6e@{_IG@OWCrvzu|9*4&x2& h<~P23pY{E5R9YKeNJo|Mnci!+{Rt*1-}~yT{|8ccGEV>i literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~2~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..ae0a6d967581c2abdea6e524821ec342e274a6ca GIT binary patch literal 14045 zcmb_jYit`=cIFHzN|t4tO8iKiY&=eCdrg~)o|a`hiun{rrbvpUY$;H%(1VV+dQc## z*s^S(2)g@Ymqj*FlI1O&V$t?Tf$a|i1p?cPLO{1@oBi7a=mXoI#cqFWfo9tRy9ms?rR&N^tF3e7V^v4;iZ{EVSPBalq;?dhvU~1>EW23P6iXH@bHK~kkZ4k;XpVZ zjE?zJ*V4m!!e_O*F83cu+oaAFvNNUZycQ|s=4aN=YrQ>MBs*JJn<=boJwrpixO1uJ z;-&uHq5h!@gMIzoT?ZombWEyLeK@n0Ey}06wZvR0KZ{xPcK3Fl*ZMAX510@4;o+}7 zu6(4vl6T<0x6F_Ibk*6Z@a=un@HkYZ@?rU4M304osjxp24#g5d)lqr3?D3{E{&>ir z3iT{J%7u|s#p^QHe3s=fcSPZvXlm6f} z|46v9saD=Ew?laK#(R}==VUmQnDhk`V`GW9k1SLvw_BD_DrNUZd~Ipzo&%UTPFip< z42;PZUmlZ)Kw|H0Y zl@_vEalKf|E_YQnX($(s331}Mc%f20HZn6?$iYDLpe6HCWwS-R#Jy-(4Csy|Q+hlj zF?DD3v2ZF~0iLafZv$zgi#SD=p*b0LPKz`6b-xq<`|25VdB5CYyU}AlblsoQ$(m{O z@EAP+ONO0;pKIr)KZ9vVIowYAGnsHI&TBd$Cgc<+W|Lwi|M` z!iOh2t;yIQKjbyK-_YZs#0@XYeAYfutGA^o?0F%UE0&5{{w5}CIEc0~vz#rSXE#|Z zX0=fwTl1PogVtRZ8H#>}*H&QzKeF#^Poyc@HLtuK(M3(Y1 zrQFI}zSVqgr9@uK1_P4&skaYL`ZI7$afqgL8p7JG`y`qTDZAB*elA&nM2N;}=2ZhH zS}uo4Gmr*xGEqR9eceWak#4*UVch`C_g}GS1S3*cLuamI#cZ6K)i)l;3T^L~@E1E%!^Bo=B&LL0JCSa4ZzAXJ`M!L(hL`4% zm>?sW%NMf4Z^>9cY=(wnT^d5HryLu9$h3iV|= zKF7*fACiu(w#CsN2aEa05~H3HM?K=a46hCEj{An#h-2!t*QWE_k|bGX#tl1F#1SW z|3Z&Gzx7AD`sl&`T=hp8A%Nku739`5l|im)LGY7)Z>4+@F=?YkWGEA9T%^}ltIz(5ce43NDlz%LY0K46#5QmMtz+pO<;>JAM zu$+Q1zdq(rJ1XTv8}r4*dpB3fW?iLXNuh=IZn-s`34Wt$RgMn-hLB~YHFjK$!VkE@*+!5v6U#6w9pyVNI2hj>*zUfDbX*J|?zf)LZw%e>x3 z*CWy1KG~vceYCG%w&?m=tbahZ=z1(Za6z`{I+46EC|h(ro*KL;TXdbyTpW@ux}LZ` z)Gb?dePgnl(h%rE*Hdp)b)jp2psEWuf>m95di(kZF8BlTIc^LFg0e-w3|i^h;0gNL04C(HGUR)`-+7-aZtsl7ZASO%1fIkqnKm@rBO&pk zEL?bdGwgw~gE<43# z3%vnCPu-Us=a|bOBm{2=@(90nm;qOjME>UnmPf6q%~#csNzV5l7HkU0!zq#awTYB% z^b0h)vX4p32w-yL-`Jv)B3^syQGY|EbWrXz?3`rNVUTrbOR||50I9-nZ7NWb(H2T4 zQ(=gDYGr;)${hAb5SD%6>){kKdSkaoG-*@mViT2qzfC1K6W|R)p*{Pz%}{mzeOX%V z_l%!Zxkg#$^bDu}aQD|>#ZZb729HPu`w?knt*|2sfEV2gAxl|WL3R;#S5-1s)GJLGjLJc8_` z6*mq{>+$qNDl9jJB);`V1j%kUo!=G{Rt_+>llSn zfZefgpi(~BFs5@BW9*2n2%*+R^+1(?T_9jde=d-(q+u6`S5mMGq$}yy1;Ulo>jK$I z+I4|wCFP<-H7@Da1%j1S>jJq-nstF#jWIx~#uy+}V+@d~pGnUJB9)Zt0*OjGb%8)7 zmAXKl#ubQD5~>TNDaq6Y!UU1pxGKPSzSNW~7mQ3MSSg>_j^(zZ!%j#B?fe*|G512y z0T6VkQhsH-0u2frH9S3BXHn3pl_-RG?#yM^n-&Tg#!>BAE=uxOT$@vL1JcVgKgYkKK(N9%_{VU~z!KLiXicgjsmWw@`wNhI#P)}kU56Z1cD(?CWRj9zbZ#tPtMJM9ddMWrlIk9}Dabl^*E^(!W z(Xm!5Wk%CZF>Pf=Lqx(g8*Jq}mhlxuynz;Z%wBm{!5~#D*YWN&^RDt8Gh3P_rhSpp zN*qLVcWYeCL;bptU)E%4gcs10@o1800}olFYXHcbPVuG*$c1jsN{%J1)Q>&eN*u}3 zqhw=c!CHve)xmFh2(~{`0itE&e1iBGX9p9p*uAF&GrI$rZ%Qy1OfcUhFkj%Tr3Ot@ zFAXK`i&=zaFR$UNSh6WzTAd!H@v1dWcRb!uN)Mm{?~}(aUc_p`!6{~GQ5iJ^Iwz57 zh{K`249}UYuHmhPM~ja~SDe54;sbr*_=7fRqbH8mbzr=NvzI=cN3i)$hq< zrb0OTiTM#NC?q-5o=Ul>`O~3D^N+NDr(c^syW?ZeW2Y6vUQu%#1B&g4K=yfOwuK!R zPhkUoqCU%)QxcUob{9vyP2&h({m6WZo&}t<}@BJ*NkvC%nAb^+~6o`o0uJ zdtj8>ysYi_thJ=5Viwb&ptHjUOo8WBlnA(<;F9nQAc zjUbO26M6Rc`SXXCZq8Gf&;gv<$;nW0_Au_WB2$kf;u#)XajP2cx#D^(M(29%Nt`%F zu=pc!^`I=}wv70LQGYw!)rGP#YGF$+J>`6VDChg%iroraHB~y~W^Zf3*mGJF`mr@3 zfK5PtX#l?GC{GU?TwWLD=Vf5}u|x%{be;m!aq~1~ZegZS@81+`vQ>pvVB*;eifCuw4&2i zz;OcS3&v((3+aR04b)`=YQt=xPko*x-j<;#g~>O`?z!7`ZZ%VS{`ETN^9@eyRGCKX zjd;775-%t4+YfYWU2EAXmMz!f8eeTL{|n2^$mP-Z>AdA1EHQQ7vMjyj7pAu?lehG8 zE>Gu~c*lg!s}blIW=dN2Hr_(8y?uh0r?iGuE>tUvuB(;u5gDp*8iYL> z7a-_?i_ozPo=CZ@{>A$X51vJ4wscZv5}c#{=VNkC*VgD`a?jD76V-m@S&ZB=jT0fN zx%wa-n@-i(bh_-c^hCF8Z>F<)mOXc>W{25-Uz9M~6~^0-UBK17VvU)V0I+Ig{y2Ab z$y0TSvvPz-jjA60{!BW`qS}v9`v}2>$BRF^rhoClD0TyO6t69Q_Ol1Sk|5TtaAZsk z^8EqT$AjEH#$W#eD9?T!DB zlzn22^Rt8et^>XM;iI=PIqdDUoA^JQ4D&cg`JEZmY?{cDNh3`_KKM_b-9wYoH>Zi} zkeVRRw=@~#T7^-|t42I{tx890RWGhEyFF++w#?-EvT@(_6#^r_jc_^>H(V&(~ne-=|?tIcvsq3m7_K(RX_TMR5@xol1&x)nvE<9+a2jen;v#Y zYN*RzJ;{z$ohRLvp7f&WNw=-6Vkb|cms+LGwE67YxjA0>yQrhSymN4(y+W;9tvkiK znSYmL@+7O(vB`#0pvG#vo;bKeDiE{5Rkd2fu(?B4qUtswmf2#a z*(_BqHp>NQuiGdWXsFAc?PgQ3&TbphZYk4l8=MR@up3GUwp@T2cbE2Se*9&Wx#3EfHqZRI#9pvW^E!Qlrot!3Td?*vS$O@ z6s$AgU1`8s(|~t(XF$e?GwuMV>--`2#|_(@ama%F_DhcgC9i?ze?`-B1^cBoth7M>WVVpMjlbtAtmX^&6N3B- zo@@O%ef%AL{5^gA<9U9XMgB2PmO6~XTYkI!r1e{wUX$M^|KLdAb!=4}tobXVqj)#F h{$20Rr+srARo0qU(NQ6MsyEsle}YM>cfb1T{{b`%Fnj<2 literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM new file mode 100644 index 00000000..1b03d7c7 --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "20-Oct-2020 03:27:34" ("compiled on " IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.;4|) " 9-Apr-2000 18:01:32" IL:|bcompl'd| IL:|in| "Medley 3.5 Full Sysout 13-Aug-2020 ..." IL:|dated| "13-Aug-2020 12:39:12") (IL:FILECREATED "20-Feb-92 18:40:05" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;4| 17729 IL:|changes| IL:|to:| (IL:FUNCTIONS READ-FLOATS) IL:|previous| IL:|date:| "19-Apr-90 18:48:13" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;3|) (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ((IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") ( IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) ( IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* (QUOTE (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ))))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) ( IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) ( GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P ( IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP ( IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS (QUOTE (GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI))) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) ( CLOSE GABRIEL::F))) (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT) )) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*)) ) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT NIL (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM )) (QUOTE IL:REGION))) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| ( IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR)) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR)) ))) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT (QUOTE (GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::123A GABRIEL::234B GABRIEL::345C GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::890G))) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE))) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE))) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (DEFUN READ-FLOATS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" (QUOTE IL:INPUT))) ( SETQ *FLOATS-TO-PRINT* (IL:READ IL:STR))) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* ( IL:OPENSTREAM (QUOTE IL:{NULL}) (QUOTE IL:OUTPUT)))) (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time." ) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS ( IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN ( IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW (QUOTE (0 0 876 30)))) (IL:DSPFONT (QUOTE (IL:GACHA 10)) IL:*TIMER-WINDOW-FOR-PRINT-TIMING* ) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)))) (:AFTER ( PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)) )) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (DEFUN IL:READ-EXISTING-SYMBOLS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" ( QUOTE IL:INPUT))) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)) )) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE IL:INPUT) (QUOTE IL:OLD))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER ( IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER ( IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER ( IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "BENCHMARKS"))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990 1992)) NIL \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~1~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..ea517892b62c98c6160163709787e7984dc3e288 GIT binary patch literal 17977 zcmc&+OLH4p6_!22zz8T3WA3>OtpvTI}{S@J`nQfWyot0#K7)rw=v8^@MoVOw%Z z$}p)oKLXbL0d})wR#~uO&s0&Y*iZ#q_yO>pbNg{y-7U533^SEU)ZMr5J@50KbFY-H z>NTUKXKF@6&ls&*TYO~dTGi6Z4PB(3RvIbsQAevh*7kIf##rZbs;svv^`>S%?xxn( zl4+w+qA4nP+0v^bmCt5Ad2yN9*%7(jQf{l1FQ!B~buzlT9$fZM#b_u}B8it?>88CMcXg`HA1pNhd*7M$Id5s}+26!R>I zo0Ie7;q(6FhRL3eN;iUp`b0CkbjK$I@Y!ACao6Mir-RW8`z>Mw@1-_L_(KvtBvZ_n zirL!>J10e8cC`KdP(nnS=v-%V9z4M6<^J&G{OWjoF%f5@vH0|OOcV;^7j1F&Vt6tg zjD{027>en6Urb(3rv0mp)S5_>H4tOWwldw`@w4%uf64EAQssPjUyNT2#qrs+KNdDyVZ6Ib@XOJh)6}$b zP#Yv$D^j-Z{BlU-0$ttebux00q7ZpwM#9R?oGlGk#4|EuIR>X)x2HHTTGjT!`piqV zpzYT}<$XgIolGHeOebP=265ZAEr!Qe{mI8{;V&kA@teW)T$sI<5~>^%4WW76=g#Yj zAl93j@wlDwKbO+vP{6*H%k6B@5NX%zBE8>hTZqr_hgzfE=^SQiZLnVXwFl$%hB<4Fnpf59u0<5@Uen44|6O}nu^T5n=JBVK;|K_ORn5~dG%~`DaQTdQ!pQ3){&qwOu#?N7yvYj)@9`CuX@eIy-r`Dq`%Z?o8OOr~?l9HgS)i`IMkFrUq4 zZNDHv5V^o8uZWP>(p~IXD{XtavD&WmNPrrl1whamhbTbA8IqVsj>RH3%Nc@{0|cO+nowBx<$jU)@yco=+>WR;+Ff1b3xeaC$Zd&sM{hxNxx6TKdmR8Dy{d~{Q8H>7 z4jWyuB}#2bwP%S<5Nnt^10cK;;6-L+QW`PT5UQ>uc2QVtiLA$O6V8_Sa3zs=rwm#_ zcl~tr5A_e261_7+NFno@)o;{$@+V9fi1YI=Og#c1>AvV>+2qWwLlNexLQk%d}0A zF1LHFYS5e1ks|GPe(#yfma7b{TtQU`Tl2htZtT_bn;y?}ZG56ikFFm#3Po=WT{m0B zE$w+g-W|H$H@9~bd`&mH){bIGblrQhtC%8PA3V(}mP*%$zXH`RA9SsiRigPu zWwW3xmdkGzid$OQdyQ{wmn+^K8nL}osd{(##x8u&U5rNTX7!qPhi~L+d&*)oB$wZ- zdxQAKX5D};<7?loCh*E4{kvmBEx>-NKs?1~5mUAl8}LkqX+`Yto0OUvL^>*;P|95M z_*Y-zbdp<`PIv|R&d2*&?19RU@AXInu zk@bKT>^$d1+&MaR=!~z_Jew6IMVat?)Q3?9u>-@L%%B*^)Gc!FM5&x81j=kOp@q1F zzLx-@9f=t>N#xaT$J8l`C?t zFyA#Wn65qt0IR9jfM0tzak1BIvY>b~2Yv;H&uVgJfItSPDPxuZ{+!E@Yz{FYX*$BR z{PQZvP;r7JLqk_B0h5dgW@lQa5wOzN%J3Sa?&=b;dR8M_>F#4mHibWeOR{;x4JD;% zNlydKME8~1#+>^=ZD0kOR!VbB_Nij2HoRACXEuKz2pt-%=HiKmx~86dh{Lxl9_rh< zYXoJ5^&|66d1B(o9z<+HpdPnf4P7`{chE{Lt*MKyQ7WzX zT9iG}T}CIqV)6c!0qo1qDh*w00TEJ%xXX_SSmO1rW%6PGz_`NH#R4F~JpkSnLTmVQ zezN)o{~*)nHpLUI(bKybY?fM1;%+|SD^A%=tW)gFknBg~kxPGTG1aDR0LpCpTQd@`^c@p+Cl z(I-$DMbpskaoOO>W*N;Rg$$_{MnBa5f?##630m{$bur!48JiiOmqIjJsNpaaxM!w2 zyJRC2OnWQLD~~`^XdBdf+rwQUMeEEu@ynYnJ2uSJtnucX#k^Fp3hHqS-Xy|i?|5`2 zWP3Z6ggi0rOc0vWM8;qxh|Ck-wrg?ZMC-DXP7QW`e;vm5J+5|ORnpjG;fQ9Bvj&=> z_~k>iIo#brXVrWANYZB@KLIT>Rzm^S_~%FOVLPOF^gD zWTgNJ!Pi1nB@%&>Jc6%~DP0G!L+*OjG|D)4kdX$=35KFC79xRB8nP=p zT+yBb{_)kIKVTiA_Vi*h=?VWM9D_SG93zZ|C_zZ~Iy$n0^RC>EAh&d|65AdeYAgIv z-u1Pmf`&7@x2@}eyFkBi$CaF&f7f}dG$W-$=~+%gJ6+gAqFCZrQ$V|3fd`=k!)ge1 z@k7N9LWKpla4Ol@H2;X=AGsV9c)}k#aK(-ch%&DuElPqV>p(5ACBBEwP_2z!LcXvY z2T%<<<9Gp{)*y4IcX1-Dh8S6+y(UsWg~>gwQrAQ-y9QTHXJL0c+gtGF$e0&HKClKt zPQmulE{O*njitr&zS9gl=e`{?wz$^>?qX0YTVg?K3wM%%y`?!5{gpEkI6F3;@JR{x zl*ID+H-L-hWZ{C+dWS_xa~qsW63{8G~fL|mhzA5%VvaxBigV<9#ROT{W%z+7X@ldVh_@HLT0IPwcYozr5HPDN0!fG_XK6lBD>;rndiFVb7f~AnVEqhny5q z+x87%6HgE|e1~h2*{;Uh!jTb0a1n|3`&0yh*sr9dun21S09i(-+V#VnAQs*j^cid8JndpWXl_8&)DJ_m(b z+dQY0TVU+8z7s`J)Gq*R5$nhIP}=kg_t5304)`jU+az9`nWiIxNcZQ*Q_=qnM^ly4 z)T0+uaePU~2VYA6#Cu!5%Vk9Q5c!3JYf8=_{1ZT|6Gy4g0_b@o;(^mBAcUy}{=WH@AI~*~ED% zc?^t4IU*8y)=_|NX#uig^L0V;C^qb78CT<>Z{}tDq@^Fo8bKDFuzFF*I}J3PdeW=j zSvLiU%s$~9TPlW7hWQH6UTr>1gi+is4D>o@w@u(qB%n5ly zcEJ7>?5#vbI8Giueqxx=&Qd1iU&4)T^K6LO{#tCvPps7MVj~K^WdoUZqbjY)*$a?K ze5vY=C&w<|JhUPY!!TOGVGda}5C25n88{Ks?UpMQ;5Z$IPD!s)B?K69BI#fNM=8kKcl8y)g1$($fYA{;(y6&xQ^X|k&8E27CuHrDD zOIu9iygNye)*0QbV)f0H{)~C1xcUvoN}2;-9$wxKWh$GWt&2);A;J#tm=P5!;#(mf zt1T)>BBrL};fFaSMJhVtFs+N)S&QcorH8@OrSRZ)Lq1>5QNZ>-=a zSJ38je`h7>|Dlx_E0UekS9`H>=KUHXdsyNpuCk3(w6y78;Db+N92GJwD*l38NOB;v;MOYNT z0wBjKQ9mMC=MQ8z%Xp=QSKfQ7TwZyTs$`q|faE*p_T%;oXg`rmi(Dt=`c^=6R!&5kDJfji=g?F0$zBe9qMMUZdUB%%{W5 z&Q3aObZRt31A{HSDKdq_oOZp)9p**hpjIx|O8Jb)X3pksuBTU%b1|QZj7Ve9&HLu? z>4(Q}my5?&^Rw~Q zvxAvRxv$1Ed$Igstx&<_nMS`mpj{DN=NUnZO=mYE)3Ik4-mtyBJ=x)WyqcV&kN1km zuht6H%*IWYYL((cZAuiX`GZ5I`RsB$do@|!@WX0eyAfGp+%wG_Qj?D#*z$0PJ6&Mb6>r^${iet0=QJI<%v-bAcew>Mej*la$5?NA_U8e1eFF=YX zQgJa~h+mHvM6NI%_r=BA+1YA3pDo37CRUddv3$2&P2TKfcI4J+mm)CTk<=6(?@e8! zAz0Tx;>8yt(;ApY&!X2yTHQ4CPOWAcT^&44yA86BoS`-9H7ujw8;Zc|;4_TKup%1^ zawZ7QAnO{YL%l40XtBC_Z@5XbXvglt+&0iGOE-HvF&j*0T4cu}+Z_!p@p2*-Z)akB zv6?J|y{)LdyG!uk_?^?#v@+>Vn739eZ{7K2m)He{x-}Z)WG6)+vLV1>rLkah!)0-R zXUxa&w7d2cCq}Q?KiLfovKeg;i{$qWX>^(#%W5g+7ht#TuEcEoX0rU8HT>;zBK~>0 zx)kQ9r?@ajMI&h5_1X5W!ie3jW<2fZ{O=_<*)Onh6bc7b>LT@eS7eVzeG6V3GHZ4E zgTZO8)i=9PBcpf3UchcWF%5L{dP!mL#P2-Qx|)wy)7h)s^?W*8kqz2*=UGjfX31d% z&4Pyt868&hI?&pzLb8AS!s*Olfd#R$Sk2i}K)>HiXXC5T`f@%C+|bRg(bGE7L^yAA z+#igg#lu?80;g?XU%wOQ)8%V%Jz2nwy&2EWCQ*jvaZ};B*T^hShj@t$|H-Cb;7bjCZsb=!*GLJZGIr<_|}PtK+n z(=(L=;^lm`x|+-;XRpDX@vGTU5e!d@Pti%HG%Eh zTO2qlGdSfPWZpB#`KQs)eA4MRw9b=GQ-9Jih67seiR~1hXrt#(iururwi03s5uXv6 z_tfu$G#-16Mqf^z##=&ANhUAQq?&QvD!FCu1*^J}6pl)&?R=2ly#~GXb z#)$Z*5s(0EZL#+PundsIdt^5)3c;Phe>oTd`rH!A)_t%*r2c+uJC!WqyrCbSnBtVw9Jp^i{xC1H)S#h%D}`|ZLGQ$O8Gr9P>HR?yu(-~RXZ zPd|RCwf`ElZ-4zischlU>o3L0>lHv28A#4Db$!Rtg#efBo_8i~5A6Nq%U}K9zt*=t z(;hwAdfoote=$C*Z`HS7e&?g{x4-@J^*34_l;UIiYWti2`1;SOEc7>$3YW$#G_}#u zjIN_}+2KHM7+NPZ&eelxd$YOW_JW%@U%viuaZLepZ?#-eKC^i-9?x>(W%{Pb*88Jg zGi*(2Pm%Q-zxU4FmdggM-auLjUGuDf8jjkW z{-C<=wb1jixqqNQZ)zA?$hBOG=y~)EnXB7E&nM6Gil)-@=`TUG+lQXDx=J)RG)iS< zu|ly_u2i+UH;fzh>kY4kdh8!GnqCVx9Kr_O#i++&UT=9V+)!v8DT`5;Lh-2Wb>fCn z+kh;SOW#d2Fl3Yb-M*0;V82z+pJKD{DOE)WJe6Tu;XC{)rA7vkjf*D~KX<(StAjY4 zR5peap26`TjZ-UV~32E8WUJ6{0SL@5j9Q*vN>$-yD7Np!7-v9u!0@u zJde9ZrVgFSg<55`+K;9_iZZYr80IX1V!%^3|GgKba-s+*v(JPcBqj9I6bKzi%uphh zH-`gL$L#l_PHQ3G%IVK^6S=5eU{T=K0n-TJ5v2-YW`<~FWOMQW6h_c?xWRfis7}y) ztq>GcRY2iDk(mGD1?8!G{T7^C>TnyPF(DfK`TeH=BJHjA_V(5v+uK{S@1*R9Z_u>8 z^#kto+o=IlFwotAJyd++6lE?tLb}6-+3$2jnP1DY?ujVpX?gi%>PLXFaN10e(Ho9T zT~<(lzR-3;30rgMvfm9}k~M!hV5qFO0T}vvI$C#Y%z9s7s8Zo_?^amNtyLum*=kLU zGGFMOlD2ta*eRRYzR;`S0KgR#)B*6OpdtV_1;zoiDF7INO@VI!YYKD&P*Y$VFxr8F z4FJ#-xCU^hKs5j}1*QR%DZ~JfDa70WjA=I>IJf~6tD}tP>gf%TSVQdq9M)8yfx>*x zz+k%i9ssPRJ_CLo-6X|cLH|bnW)1ubbq`81&_N)A)07EQ0DsJ7NVbNUh%gc4YHAg2=AnY%UplsL1E>hj#d|?4gpLyGEE- zSTDBp2fh(;&N`t^zFx1=aP(u~2;70VG*44$(sMU5yJ&K+v zJfle8u=u3R0QTi~jgGGMfC#C0Jmgmdi?PbkGI=ooU_5End>N-q0F&FPEkbMfb9uJ? z@fV+NA=2BCy88^3M=IQ408{5=Hvt+^{ZVjN>{>r$aE%(%F;!(!*?pNYfR88*Y4yGd zh={U~GPyhNK%ttb8Mu4G9{v%SJvGPwm>O_p`e=I#pX8p}_+(%?+Sn!5EajalmJN^W zJ)%6MtScGM_=YN6V4bdYL0l2Z1`|rPuR#Bz#5YC{X&<_RYk^|yElZs?&+UT^&y55# zQvfaEez?%7(C1+T;+?<98CWNA0#nZ0)_{l!pvk|FOwV)EkUO! zu~3L&;COa_@-u4JHn$1iQ-ABUiPM#icIp^8*DFM+f}0)Mu-S_LYpAVz8#{LGuuK~K z$GsEWvk@rKM6%rPZ7t+YA{9z#WA+s>Wzfg&Hcg|BO9wfrz#Kxz-C`kP7zG+Tcf%8% zD&QYqmiZHwA+k%)36q>;WP#s|;JT3Z^x}o>jSuAs1KFVie^}X|?bYa4Mc24)!9oL=d344dsAVALoAjVAld58Wg)R0H)O; z{idB%oGSxgw~IIZjMAt9?otaQDiM2;3W6Ecsr9dne-d z0XGD7*A#7W7~^6VXp~g9>A6&{1JVyU+n&4vVVem-DoW|-JPKXHK`(-YZIcES*^8*^M~Qdn*4 zH<(R(0;^#=oP-1m6%Pd*WAfS}0`HF~uf3$i_9OoHGFx^oF3w;y$eVUD+jS&|;(s`$ zrlk|6xp6DG0b9v=WwwEUh(TBsi~K{voOgZ78%IN;{CC~p*kss$hv@cECQ_f)nWa3p zVzcyJ1B#=510;)CKe-LkNmaBB-frrUHF5?`?8O~uy7GsBemP!=$!~DgRJk2Jf4dUn zE4mK&PFg5CSoLDvLs=&)ZT%Dxn*+Mcx2W#Kkf|lu_@p-fV*3-MeRjh4Z$G|dll_!a z2J7nQocU3f_n)}GwNI11c!8@WmMHK{jy1cILx;#sC9vPpt?W0nN|fy~jb6Qq$fq0% z|1fW`U>>%-MG@MC*s&$7AKSPbW(^F5IhuNhFAkP)jY;0l;%0{@qR3JR5h`UYvo2rh zqKGq8yTZjObmYjQtarU<CD6X|-L#Jtz)ACP2Fc1rjeO%$2_v%j;f4{Zid+tMRFT5U_LrOWaAR1BkY~6~ z<}0VFR_pPM^GH%OHX~QjJZ$0K_5IeBh7HT7G-8e060$J$-?(`g>!sM^`!z*&U1Ty6>tcnAkGL=7R(Wo#i}$82RvEeQ zS5dwlkWd-#O;M~i#uxWI4Txd=?X{7A5ABF^!>Px=nh9kVdLJrG|muP8OX80qu& z-1w(jKFys}H6V>2L^peqW-7|HAH^xHOmJd>QAHK#M}O96#P;O%69J0qon=6kKz+f^opdy z^o3fSZFxUil3*Nh$TW`H7Jgpk`D8KwjcCjl*YgFwkUyVg@H-y|`}7z6;>RI*EMyhw F{|8Skei{G( literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..f7a6c16d745a338a7ccd082a57d1765aab3ed006 GIT binary patch literal 17907 zcmcg!OLHSv6_%Y4h=3wP7F4JrTvR~GuE?W@Ez1rym6p`9I-{3ct?`(ejmDP8Vmy*d z(gddB`4O<@53tJ;RWn+*iZ#q_yO>pbNg}oCAA+(YBHm~eIMtZ=XcJ%Qns!) zjE@%kjnNR7@u#Bhnaj^?AMj@b&$d z^V$82>B;co{>AC&{>6BHc`}`i?mrtoosCBq_p77H$@z=n?D_n@(am{FZ+%?4+Q3Yu z+^55dy;y#4zp#VJGqrBJN4p}rPBVfQ8&9r8re)7AykT2gTe8FHa4|YXAMX{BU*0d2 zGYK|XDBabjM4_CoRG8+I^Wo&#Xnw^Hi|PKA$P(ioX=b0AeEh(c`y1TxayI&GJbh^o zqitberkKxt`tl-&nG4`jc|T8#x&tW`t|WKNo_2T`NtMWwifl4%AAbx|JdujC=}de! zoDsRgxZf3LFDEC9@pLj5$BT1e4myep zb5t~f=1re%Zz_z~Y-`5DZqEN+a+Cc68%Lo~DN`4z*P9}HIOtmN;*eRR)$R3;bB(Uq zh8h{21NH)T>yc@oo7YPUdn115na0I*xEN2KT3lwvCR~iYCH&o8$gq3@skk zauzsk`||RYI33TQi_6grZtTTyax#iCERUNC&%H)wc{;@N2;U`F?!S8Rbb29Xqv0tw zAKI+LP5rUaC+X(;$L(sjMU3~no9*sm`=T@6`K{Yl^af&hPCDh>{Bm?MJ{zB?91u^Z zi^augGCFwFmu$|9^YL8FM}Q}6@{18{-`--+QJLN` z?;yh%=NE&%`JmOUX{`sXy8fVL^n0}01KTG)&<2km6!ZDKZ6w4MqCF!rpHsir(st}6 zYF#;Z8gB_eC7HZHliQl$&gyG)Y`kZ7?LD-$hb)(z-g#u0-A-HYSgfXym37?H8Ep96 z5awVs2p4|ndD2a-)$$yXR{ykXbR37|1_dYHx((_mOly_5#eTheJhoE zFO@BN>)2CJmvmMV(i_0N(|)A;b0>FJ3%0{9$YdPX1#Oc9vAVsr8_rno)&|5sjc^1| zYlEE^aAklb-XnWyQ3&n~?#qD)Q0InFw(dg(BK707^;GKcSt{lJNrPqg)>3BkyQx(3 zUCFtMsI|I%T@<$kdpzJy(e3FSu&z)P`~5)=kVvoVVo&TFjT}3az9@_RF1R|dLG~gzF;vcDOX*-%;m&PnKwbs&%wxe{}eowC% zS}Qcp)q`kzv$^5+f}1#&f==vk|(L~}!}w5=>wD3-Q&%39SM z#tpmGn%6=-b}O~I*TM~Zut9e*>amyC8(s@H6dDK0V$`KjJZO5IxS`ZEAj{;^ck>Jk zStWnBZ=?p;Zx!&T*erZXS5@L6!L=SE7`$8 z39mPhi%hqc2?hbi4jBzKCa_lc^Dzb^YMcxtbJ*NBQ*hP2Lqt7b1v}1p9(RdM9XgW> zwajX@8%=!_Wneon%t-*nfTwQydn-!iL=jMCmkF&TCG?#X2<=JCP$HJs`#n>~?6;y$ zYardq>5p_1si<9FQQ%gEX$0_yQiU)xLo_n7Il2Q1BWT-OVZAF0At~_nINOnADFrh)6MZpFDXbM~dI8&e+ zfSCf*0Lm0%0LT<#t^mfgD-Rr80g6>o#dG!a3P`M`b^s2mtIt4TzGq-CU40J#)=-}T zzYeaFVy~coBY(35eucURB^l@-5W#86geibO<}xH(LQF)Mj!`ZDyb3Z@j3CX>&=pHa zB@=?#KruB2R{BaAUdhy5T_RRbYh;n#eJ#l*_eXF^R&u!1q?9x1ZK%xX4hfd*+!tzT zD^$)>%4V{Hl}NPFRb)G|`5i%I*KjtMj6GE2^Y}wMyj%8AMbBL$%qy%HTloXuh&bmM zYco_s$J=o6+-u~CX-9S^+9nw4?Y6I>3RiF=dPi&PqHpZ)Zw@*XJyCZ?jlO2_L74&U z%kOF}UF!f5Qti0UuLu@nmA+;2VgSH+(#rWA95Mk+uBX-rt>Mr4$@-h0zO#l%Z%69( zBUB!#aDxF%os-=JXhii#!CkRyeV4&CYD|Yzl}TlHWySzLqBNvcyCxta%0kNI?z}yP zYNDp+?g@MNIWT)_ivKY+;L7;k`WimTJvH&kz;d*)bF5j)J5?+j9@%?Dc}Q7TGM@1b zRk*-9U2B85B9aXzlxkmr{zZvzj1JO1bOqM}#n@|>I&GfY=Ng_H31+6ddFE2M(5cYp zVFTiwzsMO_CvgI^o42k1M)L(xE#;(wO4@=Ci00yKHhm#vH9M0AKS5@|%`7Ps(=O@E zb~W=n^CC0Zl!bGur}OwtXxH~RpMe@l?UJb>$~n#&D0kwcPfgf-+^Q$ue%=|hTCZ8V zBMJk~Ob)flMSw$0=1f=wzU{|M7?c4g7Cs^1q)d`dB9K!m$6|Noo{B;y17P+JGL$vS zP$qBv>pAS$K&ABjJ+f^RjDKVB-|i!Id}BQS>+u(VN4CCAazL~Moub4-A&PZdQS6bS!W8_?~5TzYl?9lr4M*LrWZQ0w{u}g<#(%?U?o#2{{K#3-j z<$iB#A#W0?P(mBCuZSswK6bNi8dcmm$Vmm}5JK)23lYO8(Ac>fp6FBo|M;@ZAFvFO zU3yNKDyJeVftdmQ?A7}%Cp-{zWx5Vs`hlI3tV)nf2 z)VI#L6vrD|T|UAJ38^vOwB1lMXFEK@SQjOpZ7`O1~C3Es1 zIK<)x-Sb%Rt&^cR^X`DyTez05vdQ4IVHs~_L7eem+TkskvyEJ2UCzD};Ba;qU{%il z8Xzo3*4f9!MhC)rZ7W!B6PKLpR0Uru%;htN7=APxFGhr6#N`k-AwR<5F0OL`$4KVi zg6{;Um$6+|@~_W!hK7>YAqlMDjU*{Kv#FB5l-Wxs4Dq@)#f>I~)wX_v*|aCH8n(kp zNU%_GSHLkQuPq|*exLH%b4qOA;D0Z(W#{7J3`T>zX(zK?Msg_rhf``=I$@d{w~`yM zm7G^*8wiLPghjE)&l2Xm%TwMs8WQEd%Ld0L!~Q!&*N-xh`n1d}<+&A`rSBS09Q7+8 zS=|lg&1DYZNOL3LfOHp z_v-G-I$3F}$B5XZwhftYQQe6lQ$w)vNp1e=`ddi*?1b<4@1L{DzQZYlb@3C<{3y%& zC+=_U(qvDb;A)8_3Otiz&93CoA#zg*?6-6+`wguUWxGtHSFa-SDTl&8%o{A2hb^yB zgmxizYzgaq8<)eZaiIls)b$qM8!X`(lf0e9%??jQk);qKRLWRpUB1#q5of4&g^N?@ z$dN@^^XTYD66ecI5qd4Qiw_)JC(XkdBr6v+@{LO+jL71L8%Crmayi&hMG7nHpRCrym0=}9p5Z!~ubiq{t;aLY zBT3QNj9f+Yu!Vco_bXQ#HY}ggh$U`I$imdWaq}?NOR>lIZ6JY?>|9Gp{7bn0X_=Pr zK7$VHtI-laby9+>)g(O1h8x{hUFwNbgqNZAT3HrPjsvu1m_pt&VN8L05;A+8{F$mG zunVT&Pok4$Q9eaCu;~JL?hF^>?Q|rZ$$C^IM;3I?#HuK#0Wq}sO!F>Di>tL%sDfiv zWT~CGhWPH5n7}ewIg*j=E(wY&r&QwW<|`Q=jk|X89})6;`U;|zM;A!|?cB9oC=7b{$RtjOZyGU8%&@z%7(DkB&ED$2J55-Q`Z zDT>v`_~M?Y0Wqwp1yq*(2YFB-ASTay$k=$Lz|E-q&_ z$80bl=yXQbVSS=TD7;NHlw4jO4)IM4m!H?Q>V*DXAtQztVVASV0BG;}0OyZ zU~XS6+NoRl8hxDVbG=0UNfBy@{MKuh&pp&1M!|u%{lh5uofK5<+#g3t`+prJ!HT58 z^nF?!ZFxUhl3*Nh$TSX`7Jgji@n|;vji^m$m(v-(jz67b@GBp{9r%lW?}Hr{B4+yk D)B1h& literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~5~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~5~ new file mode 100644 index 00000000..ce4c95e3 --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~5~ @@ -0,0 +1,140 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) +(IL:FILECREATED "21-Oct-91 23:41:38" ("compiled on " +IL:|{DSK}local>lde>lispcore>gabriel>Benchmarks>IO-BENCHMARKS.;3|) "27-Aug-91 19:40:51" +IL:|bcompl'd| IL:|in| "Medley 28-Aug-91 ..." IL:|dated| "28-Aug-91 09:16:07") +(IL:FILECREATED "19-Apr-90 18:48:13" +IL:|{DSK}/usr/local/lde/lispcore/gabriel/Benchmarks/IO-BENCHMARKS.;3| 16088 IL:|changes| IL:|to:| ( +IL:VARS IL:IO-BENCHMARKSCOMS) IL:|previous| IL:|date:| "20-Jul-88 19:16:05" +IL:|{DSK}/usr/local/lde/lispcore/gabriel/Benchmarks/IO-BENCHMARKS.;1|) +(IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) +(IL:RPAQQ IL:IO-BENCHMARKSCOMS ((IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") ( +IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS +GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES + GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\; +"FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) ( +IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT +GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT +GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;| +"Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* +GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* (QUOTE (IL:FLOPPY-FORMATTING +IL:FLOPPY-WRITE IL:FLOPPY-READ))))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS +READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| +"Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) ( +IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE + IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) ( +GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;| +"File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE +IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK + IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P ( +IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE + "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP ( +IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) +(GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) +(DEFUN GABRIEL::FPRINT NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT +:IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) +(DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE +GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD +GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) +(DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP +GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) +GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N + GABRIEL::ATOMS) GABRIEL::A))))) +(DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| +"JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") + "{dsk}fprint.tst") +(DEFVAR GABRIEL::TEST-ATOMS (QUOTE (GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 + GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 + GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD + GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI))) +(DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) +(GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) +(DEFUN GABRIEL::FREAD NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) ( +CLOSE GABRIEL::F))) +(GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT) +)) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*)) +) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) +(DEFUN GABRIEL::SETUP-TPRINT NIL (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM +)) (QUOTE IL:REGION))) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) +IL:|of| GABRIEL::TTYR) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| ( +IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR)) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR)) +))) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) +(DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE +GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD +GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) +(DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP +GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) +GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N + GABRIEL::ATOMS) GABRIEL::A))))) +(DEFVAR GABRIEL::TEST-ATOMS-TPRINT (QUOTE (GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 +GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 +GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::123A GABRIEL::234B GABRIEL::345C GABRIEL::|456D| GABRIEL::|567D| +GABRIEL::|678E| GABRIEL::|789F| GABRIEL::890G))) +(DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) +(DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) +(DEFPARAMETER GABRIEL::*IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT +IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE +IL:WRITE-DSK IL:WRITE-CORE))) +(DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT +IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS +IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE))) +(IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) +(DEFUN READ-FLOATS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" (QUOTE IL:INPUT))) ( +IL:READ IL:STR)) NIL) +(GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) +(GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* ( +IL:OPENSTREAM (QUOTE IL:{NULL}) (QUOTE IL:OUTPUT)))) +(DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| +"Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| +"bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time." +) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS ( +IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN ( +IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW +"LINE " IL:I +" ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" + T))) (IL:TTYDISPLAYSTREAM TDS)))) +(GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* + (IL:CREATEW (QUOTE (0 0 876 30)))) (IL:DSPFONT (QUOTE (IL:GACHA 10)) IL:*TIMER-WINDOW-FOR-PRINT-TIMING* +) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)))) (:AFTER ( +PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)) +)) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) +(GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) +(GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) +"Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) +(GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") +:AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE +"{FLOPPY}200-PAGES" "{NULL}")) +(DEFUN IL:READ-EXISTING-SYMBOLS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" ( +QUOTE IL:INPUT))) (PROG1 NIL (IL:READ IL:STR)))) +(GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE +"{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) +"Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) +(DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM +"{CORE}SPEED-TEST-FILE" (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES + IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) +(DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE +IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)) +)) +(DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE +IL:INPUT) (QUOTE IL:OLD))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) +(GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER ( +IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE +"{DSK}test-file" 50000)) +(GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER ( +IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE + "{UNIX}test-file" 50000)) +(GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER ( +IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" +50000)) +(GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) +"Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) +(GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) +"Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) +(GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) +"Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) +(IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") +(IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") +(IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE +"BENCHMARKS"))) +(IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) +(IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990)) +NIL diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~6~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~6~ new file mode 100644 index 0000000000000000000000000000000000000000..6fecd5dd6ca7df5742f05ecf2972bc59d2e3e294 GIT binary patch literal 18045 zcmcg!OLH67l?G_XHoYauBMlhGcliuyvSkD_3O6v z@Xa?@uT~fH+5Y9(WdCxyygHpPCi~A$o-U@7%l)U5+3CfLlg0DpzA-HN>pu8;=Xw(> zRg2ooXT^F+lokQ+xGaY(W=|Ka+dqClM|(CwOnU%PcKep&nC-jept;L*MfyS z9<*#@IIsk5Q?b(eXbUh@22yY&In=$WAdeXQM+0c>)WCPLTimu(DCFPdM!fFFdD;-Z7j)|9%-gQ)@0=(y=>jGSwsCd+@#qgL2n^$8)>$!n}f{+ z26OoiDTFBW$CfRgPQ>EnOq`srCJW)P700``1P@N;oTjFgqq{+}wG(CQ%`dwoE@0{Q zcvO^~lns#$AqgvuB}W>bh(j`CIYy`5a;7*k2JPX|R%nnTXlGcgyst^4bNSwMxmt?( zImGRFC^0*EFn%|@91m@HZM=h<7>$mLouS!>8X1EF_PtK)k!hft-%D=xW-{mb&gJ}M zHJv>xUd^Yo71^L;cfQr+0`4hdbXd*rKx?xKNq3gKa4tVuU_q=bR&(|g(C-)1*~w*O zeL0^EY3OF(7-&66%hyI}`B>I{Tjc%_3@skja^7%a`|9eIIGZk?i>t{3ZtTU$>~s=m zSiUqBnfr|_@?1pbF}_Q#Y`uE%bbcuolan(rA7K^~vo!U`hDEzuw2u4DVGnVk;Cna6 z-6i&w>J;N^;aU*0i_$3G||jm4J9UU#%`Dv&rdmNay6)Y`&Z>8o#|#5IkP!LvxMO*rX?l8)Gou&FT0S}bFY>SH{Tt`e-418YT>42%G^wKj-mHN}*S1II(4oDrJ>>l;>Vrpy zIUMx$fz9fPJ+hBSIwOpL`@tNH`rx_`eGj^&^?JSo(%Qco8Uxo6dFJQFS+7AIg=y`* zs%W&Uxq;CWnGZ7f??e3gI8&(j3psO8pIkvwG8)6L6GPJPd9%CAh1+2eWGk-Eg23fK zEbs7k#~Ith)|dpS5l{m{?XcGZiVTs&OtO0xr7&mkTP`+$9(P39?+}0kBJ*W-Ba=CN z1_`Nuaz8=CC)teI{Rkhr|L6#CSG0OVOBa=G!5&YPOJX?E2asTCPc*FY2#`o`>!MT^ z4WmU2 z?Z5x^zna;PwNF0DKJWhJKaG!@+2+R6_um@-@|$m;|DZLARDAAUZv61S-~T^!b~m12 zkH`X)w$;;&zN>!)Yoxaftrr>RsYJZ(Nj+B-C;$3v`TWiK6~)X4tL2LFn41^lRd}m- znV~5P&Ea^^jvAKQQxt-Zz<=kl_{Hn6!OM#vr_I4C` z(sO^XyXW_z=ivzc!&{7=56x;#LEqG1*|oagiJr%gkRy4+==tdJwxVtHeEe^q+UrBl zT2m#O8(NheWwBDZva`FVHT_}SP;IvS7V1&0wc36QH`HN=-eT0FzO8rs7H%kY4wS{H zOR0R&^*eDxrE6d>)9=2QYhcJt`|tIQ)d1(Mg1sCq<*aE>>?u0ns|?c$_YqVnHA;v= zQfwhCu<7%!4&u-PS9Viq;VE1nLT)TE4#>sQ2bS7Rfo1K4k+@<44+g>t4Nn(U;A=n2 z!r30WzLx%V!$hg-gb8RnPr2g+2_@RzVQ*yGwQh6j3h|0DvStMHG6pAV*bF6g;P1l> z{PpON;vcZXt_*m-+g-D-E}`i+wobZL-Hsm#K+S0g) zC6ZCj(K{e9hPd(#MtpjpN*q|Ko}zxx1~ zq?_$-Y-InhyOEu}pK%_3K+{I{r%t!uObs##gN7Jn7+h|2cUA1Vn{2hrVXr54smG@nivMKl2f(+$hD??*u*Rk?ODX_kXgi_|u5Edn;Ds_NpdS+{Dl6WA6azh7^}98U zy*E-+$?ybtEAZykuTsQtwN6IaFck36521csc1vlFU-SzqKy)Pqh5*eeFbPOb!F51! z3Z?^sQ}7(nn}X$l+!P!K&{k8x0uY;m-+&I;5MK%g%}_-g&2S{&1V$Atf?#k zRHk6GYe2I0wcq&~fGqF~IHs%bfyFw?Gk_S1OXNCkhTvfjN2Au@ut@jt4u(1igzUp^Q8qsnIU40dh759)^ zBhN>eNtSiE?xfT<>20Lu=nVR^IUjlr zw7xDZqtVzJ4=8Y=2#tb$%jQ!v1CWQ`wR*ZX04StFvc<0m4Ph0_HhD3i;4N7+q{=Ew z)9J>D0c-ByC@S+==Dkdok=*G9#r})a_uu~FgDen0iKlz=r2hy-N-FVSa;DwQfkGSv zaaoWOJh==0l<_wer4G4%lPT0?S^+tujHES(CO{-gNXqmc+!=u@cP{!c@^}U-MF9KE z9DitX0yEQ3HnQ~Dg+g6=Flbd`@q$W+Zc0;TJmWEo>|I%2?oWxArm`4BtZRJ`Spm;X zFbH@f(qe+kCm3qB>rkN-p99Lmh}f%_;_d6fxYv8bx*op`0g}`2!%pHpq?s_h5uAqv zb^?cNl62Y!Ii+%<_O6^+S;(vb5^o@($#Oz7d+$%rVblgntQQ}XshcGGw}$-3Z{W^v zjpx5V{{9b{!Vc#$2(Td5$yJE#lBjUrB0rbC-J@Ip+hg0uZJf^Zv}4!axy~UfHQWZ# ztac~)FH2kZHgW9QVfh?YvG6$V7g`%`8r*dKuTyZS_ zB^XmR{#Dttvs-zM2r66WJ9a&JIk9+)PgjdlCKRe=9Hyf%oH1=hcPGM?pXEW6QO6oX zUV1;V3qN63alWHCJgjmv(RuQKWNfr?r~GL|b~tjKq7&FF95F$)6aa7x^oZRc>I$79 z&Jxus0yaoSVVGG@AOaJ|xM0?Sm+a6{lqgmBDEvTcbv0Zd+eAz)Y(wX2V4^}5tavw? zLP*dF!cx(a(;mx69z4?QsW1#ggw>c=s!AABQ7Qd7VWmWqB%8v8qkaJlsed!gp96$omwIwGh^#oRCho&?Ra% zF*Kw%n}lk;M~iZw#;aZW*`PdKj>xz}w?!ssUy1w9wwh9<47kC47RwM(p@;ortVaoH86o&HB&693PJ!Rb40t0x z17-}ue7hO&I;w+M3_X>^TvWdGfl^iAi(t zqSEc7PONgRGg4WPVIvLRHA*7?2BeliKzfU$!>@S%ce|-0w#k_`$rl%_={_MM{Kd&i zOn!}ftjg8v`OB3!xum;>ucW=Qzg2JTy(?Q~?QI?-f)fPnAh_TkvR3}kk=Yrn3AX#? z2C7%4lM?>-rx((GKVbW{FMlqRL&^gGh&w`@1wMI#Yb&-WF&=a4J>K47p;)$37;^>W z+{TzA>%bFzhTvZ54a3FMNIKLU%gmV>z_-9$!)1DY+NH zIQF~Z5fYb2D0b|f{bHchQ9)86>tYhd$Bx8zKzNmbekAh%nN&i{#qPFSEW@QIz3pFK zQjkXY4aX2~A!6t6u8%CcA59-!mQv{A&RunpwZP2>alXl_MvZ*aQ;9Ilx*uUkBMn)b zbrqAUu^Zo}*GdXGHAnr*&grp}?w5JBn7xguvZ18osvZ*`8C8}?)1-Agt*3Q92=VS1 z|J^l+O(&p1KVRq3ge+b)* zDq5Hgt4ws5qcg)^Tk4Ek)Rz(YR>>Jpj)S{(*h6j@V~?Dhn9Y96B^FqTJeLU)>1Jni z$biY;&^`3xIqv5>X-qT)_UT9uLFkH$T~p2%5~&MV-Mb_%sZdj+!w0)2tM@E9iv3=Z z3S#3@lN0FPB}GZKm|Aif{zloyW3=7vuLz|*eTChX#~~;cV2|l*lf3J9$yu2eoQ|&3 zM_Jdrt3Hkg#^baK$%Ld=NUmVkWCe3Qd5H>nZ|V{?l1qm*eSPqBFPqRM{o`;%f|j;$;~KTj$iBaVz!=PQC)#WX-%CL zN)ZazQI)v&1c&15m+PiWI+KjC_Tc6-E6(P-XIM^h^vylLg3D~&Va`Ae+bwVf8UqsI z>Sy4FDpgrxzmi+v!xQz_S#Wah{5lJMtfis+LQ5|A6D=uLB-N!a`{IDi|M8R*<48iL uanQB#3onl+i}|lbYreReFYp@y^I0A@=75dyR}FvB&ydvX6b=BAa(@GTWqr{A literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~7~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~7~ new file mode 100644 index 00000000..ae8332ae --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~7~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "19-Oct-2020 16:48:53" ("compiled on " IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>benchmarks>IO-BENCHMARKS.;4|) " 9-Apr-2000 18:01:32" IL:|tcompl'd| IL:|in| "Medley 3.5 Full Sysout 13-Aug-2020 ..." IL:|dated| "13-Aug-2020 12:39:12") (IL:FILECREATED "20-Feb-92 18:40:05" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;4| 17729 IL:|changes| IL:|to:| (IL:FUNCTIONS READ-FLOATS) IL:|previous| IL:|date:| "19-Apr-90 18:48:13" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;3|) (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ((IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") ( IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) ( IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* (QUOTE (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ))))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) ( IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) ( GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P ( IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP ( IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS (QUOTE (GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI))) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) ( CLOSE GABRIEL::F))) (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT) )) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*)) ) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT NIL (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM )) (QUOTE IL:REGION))) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| ( IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR)) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR)) ))) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT (QUOTE (GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::123A GABRIEL::234B GABRIEL::345C GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::890G))) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE))) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE))) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (DEFUN READ-FLOATS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" (QUOTE IL:INPUT))) ( SETQ *FLOATS-TO-PRINT* (IL:READ IL:STR))) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* ( IL:OPENSTREAM (QUOTE IL:{NULL}) (QUOTE IL:OUTPUT)))) (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time." ) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS ( IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN ( IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW (QUOTE (0 0 876 30)))) (IL:DSPFONT (QUOTE (IL:GACHA 10)) IL:*TIMER-WINDOW-FOR-PRINT-TIMING* ) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)))) (:AFTER ( PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)) )) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (DEFUN IL:READ-EXISTING-SYMBOLS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" ( QUOTE IL:INPUT))) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)) )) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE IL:INPUT) (QUOTE IL:OLD))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER ( IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER ( IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER ( IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "BENCHMARKS"))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990 1992)) NIL \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~8~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~8~ new file mode 100644 index 00000000..1b03d7c7 --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~8~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "20-Oct-2020 03:27:34" ("compiled on " IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.;4|) " 9-Apr-2000 18:01:32" IL:|bcompl'd| IL:|in| "Medley 3.5 Full Sysout 13-Aug-2020 ..." IL:|dated| "13-Aug-2020 12:39:12") (IL:FILECREATED "20-Feb-92 18:40:05" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;4| 17729 IL:|changes| IL:|to:| (IL:FUNCTIONS READ-FLOATS) IL:|previous| IL:|date:| "19-Apr-90 18:48:13" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;3|) (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ((IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") ( IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) ( IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* (QUOTE (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ))))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) ( IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) ( GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P ( IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP ( IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS (QUOTE (GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI))) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD NIL (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) ( CLOSE GABRIEL::F))) (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT) )) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*)) ) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT NIL (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM )) (QUOTE IL:REGION))) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| ( IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR)) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR)) ))) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT (QUOTE (GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::123A GABRIEL::234B GABRIEL::345C GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::890G))) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE))) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* (QUOTE (GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE))) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (DEFUN READ-FLOATS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" (QUOTE IL:INPUT))) ( SETQ *FLOATS-TO-PRINT* (IL:READ IL:STR))) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* ( IL:OPENSTREAM (QUOTE IL:{NULL}) (QUOTE IL:OUTPUT)))) (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time." ) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS ( IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN ( IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW (QUOTE (0 0 876 30)))) (IL:DSPFONT (QUOTE (IL:GACHA 10)) IL:*TIMER-WINDOW-FOR-PRINT-TIMING* ) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)))) (:AFTER ( PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)) )) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (DEFUN IL:READ-EXISTING-SYMBOLS NIL (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" ( QUOTE IL:INPUT))) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE IL:OUTPUT) (QUOTE IL:NEW))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)) )) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE (QUOTE IL:INPUT) (QUOTE IL:OLD))) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER ( IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER ( IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER ( IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "BENCHMARKS"))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990 1992)) NIL \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.~1~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~1~ new file mode 100644 index 00000000..6f74bc6b --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "20-Jul-88 19:16:05" IL:{ERIS}GABRIEL>BENCHMARKS>IO-BENCHMARKS.\;12 17452 IL:|changes| IL:|to:| (IL:VARS IL:IO-BENCHMARKSCOMS) IL:|previous| IL:|date:| "30-Jun-88 09:52:50" IL:{ERIS}GABRIEL>BENCHMARKS>IO-BENCHMARKS.\;11) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ( (IL:* IL:|;;|  "Benchmarks for various I/O functions in the system.") (IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\;  "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) (IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;|  "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* '(IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) (IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) (GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;|  "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P (IL:COPYFILE "{ERIS}GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:* IL:\; "FPRINT") (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS '(GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI)) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) (CLOSE GABRIEL::F))) (IL:* IL:\; "TPRINT") (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT ))) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*))) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT () (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM)) 'IL:REGION)) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR ) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) ) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR))) )) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT '(GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::|123A| GABRIEL::|234B| GABRIEL::|345C| GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::|890G|)) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE)) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:* IL:|;;| "Floating-point I/O") (DEFUN READ-FLOATS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" 'IL:INPUT)) (IL:READ IL:STR)) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* (IL:OPENSTREAM 'IL:{NULL} 'IL:OUTPUT))) (IL:* IL:|;;| "Printing to the terminal") (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time.") (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS (IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN (IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW '(0 0 876 30))) (IL:DSPFONT '(IL:GACHA 10) IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* 'IL:PAGEFULLFN 'IL:NILL))) (:AFTER (PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)))) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (IL:* IL:|;;| "Symbol reading") (DEFUN IL:READ-EXISTING-SYMBOLS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" 'IL:INPUT)) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)))) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:INPUT 'IL:OLD)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER (IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER (IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:* IL:|;;| "Set up for this series of tests") (IL:COPYFILE "{ERIS}GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "BENCHMARKS"))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.~2~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~2~ new file mode 100644 index 00000000..9e8b5a95 --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "19-Apr-90 18:43:52"  IL:|{DSK}/usr/local/lde/lispcore/gabriel/Benchmarks/IO-BENCHMARKS.;2| 16089 IL:|changes| IL:|to:| (IL:VARS IL:IO-BENCHMARKSCOMS) IL:|previous| IL:|date:| "20-Jul-88 19:16:05" IL:|{DSK}/usr/local/lde/lispcore/gabriel/Benchmarks/IO-BENCHMARKS.;1|) ; Copyright (c) 1987, 1988, 1990 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ( (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\;  "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) (IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* '(IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ )))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) (IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) (GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P (IL:COPYFILE "{{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:* IL:\; "FPRINT") (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS '(GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI)) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) (CLOSE GABRIEL::F))) (IL:* IL:\; "TPRINT") (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT ))) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*))) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT () (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM)) 'IL:REGION)) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR ) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) ) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR))) )) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT '(GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::|123A| GABRIEL::|234B| GABRIEL::|345C| GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::|890G|)) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE)) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:* IL:|;;| "Floating-point I/O") (DEFUN READ-FLOATS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" 'IL:INPUT)) (IL:READ IL:STR)) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* (IL:OPENSTREAM 'IL:{NULL} 'IL:OUTPUT))) (IL:* IL:|;;| "Printing to the terminal") (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time.") (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS (IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN (IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW '(0 0 876 30))) (IL:DSPFONT '(IL:GACHA 10) IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* 'IL:PAGEFULLFN 'IL:NILL))) (:AFTER (PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)))) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (IL:* IL:|;;| "Symbol reading") (DEFUN IL:READ-EXISTING-SYMBOLS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" 'IL:INPUT)) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)))) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:INPUT 'IL:OLD)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER (IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER (IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:* IL:|;;| "Set up for this series of tests") (IL:COPYFILE "{{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE ( XCL:DEFPACKAGE "BENCHMARKS" ))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.~3~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~3~ new file mode 100644 index 00000000..98fb77a7 --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~3~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "19-Apr-90 18:48:13"  IL:|{DSK}/usr/local/lde/lispcore/gabriel/Benchmarks/IO-BENCHMARKS.;3| 16088 IL:|changes| IL:|to:| (IL:VARS IL:IO-BENCHMARKSCOMS) IL:|previous| IL:|date:| "20-Jul-88 19:16:05" IL:|{DSK}/usr/local/lde/lispcore/gabriel/Benchmarks/IO-BENCHMARKS.;1|) ; Copyright (c) 1987, 1988, 1990 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ( (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\;  "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) (IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* '(IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ )))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) (IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) (GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:* IL:\; "FPRINT") (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS '(GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI)) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) (CLOSE GABRIEL::F))) (IL:* IL:\; "TPRINT") (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (GABRIEL::SETUP-TPRINT ))) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*))) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT () (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM)) 'IL:REGION)) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR ) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) ) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR))) )) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT '(GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::|123A| GABRIEL::|234B| GABRIEL::|345C| GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::|890G|)) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE)) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:* IL:|;;| "Floating-point I/O") (DEFUN READ-FLOATS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" 'IL:INPUT)) (IL:READ IL:STR)) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* (IL:OPENSTREAM 'IL:{NULL} 'IL:OUTPUT))) (IL:* IL:|;;| "Printing to the terminal") (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time.") (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS (IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN (IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW '(0 0 876 30))) (IL:DSPFONT '(IL:GACHA 10) IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* 'IL:PAGEFULLFN 'IL:NILL))) (:AFTER (PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)))) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (IL:* IL:|;;| "Symbol reading") (DEFUN IL:READ-EXISTING-SYMBOLS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" 'IL:INPUT)) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)))) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:INPUT 'IL:OLD)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER (IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER (IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:* IL:|;;| "Set up for this series of tests") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS-TO-READ" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE ( XCL:DEFPACKAGE "BENCHMARKS" ))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.~4~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~4~ new file mode 100644 index 00000000..dd8d870e --- /dev/null +++ b/internal/gabriel/benchmarks/IO-BENCHMARKS.~4~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "BENCHMARKS")) (IL:FILECREATED "20-Feb-92 18:40:05"  IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;4| 17729 IL:|changes| IL:|to:| (IL:FUNCTIONS READ-FLOATS) IL:|previous| IL:|date:| "19-Apr-90 18:48:13" IL:|{DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;3|) ; Copyright (c) 1987, 1988, 1990, 1992 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:IO-BENCHMARKSCOMS) (IL:RPAQQ IL:IO-BENCHMARKSCOMS ( (IL:* IL:|;;|  "Benchmarks for various I/O functions in the system.") (IL:COMS (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:COMS (IL:* IL:\; "FPRINT") (GABRIEL::TIMERS GABRIEL::FPRINT) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS (IL:* IL:\;  "FREAD (MUST be run after FPRINT)") (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) (IL:COMS (IL:* IL:\; "TPRINT") (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS (IL:* IL:|;;|  "Lists of benchmark names, for use with RUN-BENCHMARKS:") (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* '(IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)))) (IL:COMS (IL:* IL:|;;| "Floating-point I/O") (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS (IL:* IL:|;;| "Printing to the terminal") (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) (IL:COMS (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS (IL:* IL:|;;| "Symbol reading") (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) (GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS (IL:* IL:|;;|  "File-system-specific performance bottleneck diagnosis") (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS (IL:* IL:|;;| "Set up for this series of tests") (IL:P (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) (IL:* IL:|;;| "Benchmarks for various I/O functions in the system.") (IL:* IL:|;;| "Gabriel I/O Benchmarks:") (IL:* IL:\; "FPRINT") (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE (IL:* IL:|;;| "JRB - making this {dsk}fprint.tst rather than {dsk}fprint.tst so that Maiko will like it") "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS '(GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI)) (DEFVAR GABRIEL::TEST-PATTERN (GABRIEL::FPRINT-INIT 6 6 GABRIEL::TEST-ATOMS)) (IL:* IL:\; "FREAD (MUST be run after FPRINT)") (GABRIEL::DEFINE-TIMER GABRIEL::FREAD "FRead" (GABRIEL::FREAD)) (DEFUN GABRIEL::FREAD () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE))) (READ GABRIEL::F) (CLOSE GABRIEL::F))) (IL:* IL:\; "TPRINT") (GABRIEL::DEFINE-TIMER (GABRIEL::TPRINT (:SETUP (SETQ GABRIEL::*TPRINT-WINDOW* (  GABRIEL::SETUP-TPRINT ))) (:AFTER-EVERY (IL:DSPRESET GABRIEL::*TPRINT-WINDOW*)) (:AFTER (IL:CLOSEW GABRIEL::*TPRINT-WINDOW*))) "TPrint" (PRINT GABRIEL::TEST-PATTERN-TPRINT GABRIEL::*TPRINT-WINDOW*)) (DEFUN GABRIEL::SETUP-TPRINT () (LET* ((GABRIEL::TTYR (IL:WINDOWPROP (IL:WFROMDS (IL:TTYDISPLAYSTREAM)) 'IL:REGION)) (GABRIEL::W (IL:CREATEW (IL:CREATEREGION (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR ) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| GABRIEL::TTYR) (- 1024 (IL:|fetch| (IL:REGION IL:PRIGHT) IL:|of| GABRIEL::TTYR) ) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| GABRIEL::TTYR))) )) (IL:DSPSCROLL T GABRIEL::W) (IL:DSPRESET GABRIEL::W) GABRIEL::W)) (DEFUN GABRIEL::TPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::TPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::TPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::TPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFVAR GABRIEL::TEST-ATOMS-TPRINT '(GABRIEL::ABC1 GABRIEL::CDE2 GABRIEL::EFG3 GABRIEL::GHI4 GABRIEL::IJK5 GABRIEL::KLM6 GABRIEL::MNO7 GABRIEL::OPQ8 GABRIEL::QRS9 GABRIEL::STU0 GABRIEL::UVW1 GABRIEL::WXY2 GABRIEL::XYZ3 GABRIEL::123A GABRIEL::234B GABRIEL::345C GABRIEL::|456D| GABRIEL::|567D| GABRIEL::|678E| GABRIEL::|789F| GABRIEL::890G)) (DEFVAR GABRIEL::*TPRINT-WINDOW* NIL) (DEFVAR GABRIEL::TEST-PATTERN-TPRINT (GABRIEL::TPRINT-INIT 6 6 GABRIEL::TEST-ATOMS-TPRINT)) (IL:* IL:|;;| "Lists of benchmark names, for use with RUN-BENCHMARKS:") (DEFPARAMETER GABRIEL::*IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-CORE IL:WRITE-DSK IL:WRITE-CORE)) (DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* '(GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT IL:READ-FLOAT IL:PRINT-FLOAT IL:TERMINAL-PRINTING IL:READ-EXISTING-SYMBOLS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:RPAQQ IL:*1186-IO-TIMERS* (IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:* IL:|;;| "Floating-point I/O") (DEFUN READ-FLOATS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}FLOATS" 'IL:INPUT)) (SETQ *FLOATS-TO-PRINT* (IL:READ IL:STR))) NIL) (GABRIEL::DEFINE-TIMER (IL:READ-FLOAT) "Read 2000 Floats from {CORE}" (READ-FLOATS)) (GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT "Print 2000 Floats to {NULL}" (IL:PRINT *FLOATS-TO-PRINT* (IL:OPENSTREAM 'IL:{NULL} 'IL:OUTPUT))) (IL:* IL:|;;| "Printing to the terminal") (DEFUN PRINT-TO-TERMINAL (WINDOW) (IL:* IL:|;;| "Print 1000 lines of characters to the terminal, with dribbling disabled.") (IL:* IL:|;;| "bind *DRIBBLE-OUTPUT* here, to prevent dribbling during the long printing that we really want to time.") (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (LET ((IL:*DRIBBLE-OUTPUT*) (TDS (IL:TTYDISPLAYSTREAM))) (DECLARE (SPECIAL IL:*DRIBBLE-OUTPUT* IL:\\TERM.OFD)) (UNWIND-PROTECT (PROGN (IL:TTYDISPLAYSTREAM WINDOW) (IL:|for| IL:I IL:|from| 1 IL:|to| 1000 IL:|do| (IL:PRINTOUT WINDOW "LINE " IL:I " ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF ASDF SADF ASDF ASDF ASDF ASDF ASDF" T))) (IL:TTYDISPLAYSTREAM TDS)))) (GABRIEL::DEFINE-TIMER (IL:TERMINAL-PRINTING (:SETUP (PROGN (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* (IL:CREATEW '(0 0 876 30))) (IL:DSPFONT '(IL:GACHA 10) IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:WINDOWPROP IL:*TIMER-WINDOW-FOR-PRINT-TIMING* 'IL:PAGEFULLFN 'IL:NILL))) (:AFTER (PROGN (IL:CLOSEW IL:*TIMER-WINDOW-FOR-PRINT-TIMING*) (IL:SETQ IL:*TIMER-WINDOW-FOR-PRINT-TIMING* NIL)))) "Printing chars to terminal" (PRINT-TO-TERMINAL IL:*TIMER-WINDOW-FOR-PRINT-TIMING*)) (IL:* IL:|;;| "Floppy disk performance") (GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING "Formatting a floppy disk" (IL:FLOPPY.FORMAT "TEST" T T)) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-WRITE :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Write 200 pages, CORE to floppy" (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES")) (GABRIEL::DEFINE-TIMER (IL:FLOPPY-READ :SETUP (IL:COPYFILE "{CORE}200-PAGES" "{FLOPPY}200-PAGES") :AFTER (IL:DELFILE "{FLOPPY}200-PAGES")) "Copy 200 pages, floppy to NULL" (IL:COPYFILE "{FLOPPY}200-PAGES" "{NULL}")) (IL:* IL:|;;| "Symbol reading") (DEFUN IL:READ-EXISTING-SYMBOLS () (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}1000-SYMBOLS" 'IL:INPUT)) (PROG1 NIL (IL:READ IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-EXISTING-SYMBOLS :SETUP (IL:COPYFILE "{ERIS}GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:READ-EXISTING-SYMBOLS)) "Read 1000 symbols that exist in the sysout already" (IL:READ-EXISTING-SYMBOLS)) (IL:* IL:|;;| "File-system-specific performance bottleneck diagnosis") (DEFUN IL:WRITE-TO-COREFILE (IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM "{CORE}SPEED-TEST-FILE" 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33))) (IL:DELFILE "{CORE}SPEED-TEST-FILE")) (DEFUN IL:WRITE-TO-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:OUTPUT 'IL:NEW)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BOUT IL:STR 33)))) (DEFUN IL:READ-FROM-FILE (IL:FILE IL:BYTES) (WITH-OPEN-STREAM (IL:STR (IL:OPENSTREAM IL:FILE 'IL:INPUT 'IL:OLD)) (IL:|for| IL:I IL:|from| 1 IL:|to| IL:BYTES IL:|do| (IL:\\BIN IL:STR)))) (GABRIEL::DEFINE-TIMER (IL:READ-DSK (:SETUP (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (:AFTER (IL:DELFILE "{DSK}test-file"))) "Read 50,000 bytes from a file on {DSK}" (IL:READ-FROM-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-UFS (:SETUP (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Read 50,000 bytes from a file on the {UNIX} device" (IL:READ-FROM-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:READ-CORE (:SETUP (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (:AFTER (IL:DELFILE "{CORE}test-file"))) "Read 50,000 bytes from CORE." (IL:READ-FROM-FILE "{CORE}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-DSK (:AFTER (IL:DELFILE "{DSK}test-file"))) "Write 50,000 bytes on on {DSK}" (IL:WRITE-TO-FILE "{DSK}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-UFS (:AFTER (IL:DELFILE "{UNIX}test-file"))) "Write 50,000 bytes to a file on {UNIX}" (IL:WRITE-TO-FILE "{UNIX}test-file" 50000)) (GABRIEL::DEFINE-TIMER (IL:WRITE-CORE (:AFTER (IL:DELFILE "{CORE}test-file"))) "Write 50,000 bytes to a file on {CORE}" (IL:WRITE-TO-FILE "{CORE}test-file" 50000)) (IL:* IL:|;;| "Set up for this series of tests") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS") (IL:PUTPROPS IL:IO-BENCHMARKS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "BENCHMARKS"))) (IL:PUTPROPS IL:IO-BENCHMARKS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:IO-BENCHMARKS IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1990 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS b/internal/gabriel/benchmarks/MISC-BENCHMARKS new file mode 100644 index 00000000..df613a8b --- /dev/null +++ b/internal/gabriel/benchmarks/MISC-BENCHMARKS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "22-Jul-88 17:59:22" {ERIS}GABRIEL>BENCHMARKS>MISC-BENCHMARKS.\;4 5113 |changes| |to:| (GABRIEL::TIMERS SHORT-STRING-SORT LONG-STRING-SORT) (VARS MISC-BENCHMARKSCOMS) |previous| |date:| "30-Jun-88 13:30:01" {ERIS}GABRIEL>BENCHMARKS>MISC-BENCHMARKS.\;3 ) (PRETTYCOMPRINT MISC-BENCHMARKSCOMS) (RPAQQ MISC-BENCHMARKSCOMS ((COMS (* |;;| "Bob Flegal ran this test on a Sun 3/160; in Lucid lisp it took 10.21sec; in Franz 11.04sec; on Maiko 2:34.43") (GABRIEL::TIMERS FLEGALS-SORT-TEST) (FUNCTIONS USER::BL USER::FLEGALS-TEST)) (COMS (* |;;| "Sorting benchmarks") (VARS (*LIST-TO-SORT-LONG-COMMON-PREFIXES* (|for| I |from| 1 |to| 1000 |collect| (CONCAT "A MANY-CHARACTER PREFIX--" (CHARACTER (+ 65 (IMOD I 26))) (CHARACTER (+ 69 (IMOD I 17))) (CHARACTER (+ 97 (IMOD I 26))) (CHARACTER (+ 99 (IMOD I 23))) (CHARACTER (+ 32 (IMOD I 31) (IMOD I 13)))))) (*LIST-TO-SORT-SHORT-STRINGS* (|for| I |from| 1 |to| 1000 |collect| (CONCAT (CHARACTER (+ 65 (IMOD I 26))) (CHARACTER (+ 69 (IMOD I 17))) (CHARACTER (+ 97 (IMOD I 26))) (CHARACTER (+ 99 (IMOD I 23))) (CHARACTER (+ 32 (IMOD I 31) (IMOD I 13))))))) (GABRIEL::TIMERS SHORT-STRING-SORT LONG-STRING-SORT)) (VARS (GABRIEL::*MISC-BENCHMARKS* '(FLEGALS-SORT-TEST SHORT-STRING-SORT LONG-STRING-SORT))) (PROP (FILETYPE) MISC-BENCHMARKS))) (* |;;| "Bob Flegal ran this test on a Sun 3/160; in Lucid lisp it took 10.21sec; in Franz 11.04sec; on Maiko 2:34.43" ) (GABRIEL::DEFINE-TIMER (FLEGALS-SORT-TEST) "Bob Flegal's SORT benchmark; runs on a 3/160 in 10.21s Lucid, 11.04s Franz." (USER::FLEGALS-TEST)) (CL:DEFUN USER::BL (USER::N) (CL:IF (= USER::N 0) NIL (CONS USER::N (USER::BL (- USER::N 1))))) (CL:DEFUN USER::FLEGALS-TEST () (CL:DOTIMES (USER::I 40) (CL:SORT (USER::BL 1000) #'<)) NIL) (* |;;| "Sorting benchmarks") (RPAQ *LIST-TO-SORT-LONG-COMMON-PREFIXES* (|for| I |from| 1 |to| 1000 |collect| (CONCAT "A MANY-CHARACTER PREFIX--" (CHARACTER (+ 65 (IMOD I 26))) (CHARACTER (+ 69 (IMOD I 17))) (CHARACTER (+ 97 (IMOD I 26))) (CHARACTER (+ 99 (IMOD I 23))) (CHARACTER (+ 32 (IMOD I 31) (IMOD I 13)))))) (RPAQ *LIST-TO-SORT-SHORT-STRINGS* (|for| I |from| 1 |to| 1000 |collect| (CONCAT (CHARACTER (+ 65 (IMOD I 26))) (CHARACTER (+ 69 (IMOD I 17))) (CHARACTER (+ 97 (IMOD I 26))) (CHARACTER (+ 99 (IMOD I 23))) (CHARACTER (+ 32 (IMOD I 31) (IMOD I 13)))))) (GABRIEL::DEFINE-TIMER (SHORT-STRING-SORT (:SETUP (SETQ *LIST-TO-SORT* (COPY *LIST-TO-SORT-SHORT-STRINGS*))) (:AFTER-EVERY (SETQ *LIST-TO-SORT* (COPY *LIST-TO-SORT-SHORT-STRINGS*))) (:AFTER (SETQ *LIST-TO-SORT* NIL))) "SORT 1000 strings of 5 assorted characters" (SORT *LIST-TO-SORT*)) (GABRIEL::DEFINE-TIMER (LONG-STRING-SORT (:SETUP (SETQ *LIST-TO-SORT* (COPY *LIST-TO-SORT-LONG-COMMON-PREFIXES*))) (:AFTER-EVERY (SETQ *LIST-TO-SORT* (COPY *LIST-TO-SORT-LONG-COMMON-PREFIXES*))) (:AFTER (SETQ *LIST-TO-SORT* NIL))) "SORT 1000 strings of 25-character common prefix and 5 mixed chars." (SORT *LIST-TO-SORT*)) (RPAQQ GABRIEL::*MISC-BENCHMARKS* (FLEGALS-SORT-TEST SHORT-STRING-SORT LONG-STRING-SORT)) (PUTPROPS MISC-BENCHMARKS FILETYPE :COMPILE-FILE) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ec8e03ce8fa1bce0a5df7d890c9a54b28ebc6047 GIT binary patch literal 4051 zcmb_fOKcm*8Qxvelw?^pX$6uZSJec5q@cVEmk(PHL-2}RiYq>r=B|vW1#Hk1Wzt%a zDj!7@!$8pnMO$p^sFH)7#zkQu0gC3LLj%b2!IuIBdUh{Gk3HnllTSSq?mshp$B7do zhRmJ$=k@*neE&ByyWHTrktB*#wzf-Vp^7Sv`gWs^HY!zAt2Cu#WUxy-{7y?Oa5GAX;gdJ4l+FoxO;p`S9F)C@>eAyL34y1$-khSx+)Z zt)WJvP-7$gNXyqNx4?^lKj6QJLi6Epd$2$38+q{u`y=6Og@b>$+dspkmiwK;3-*S6(LrzEKY*bX!nN`DUTW$%}E8C)3_({PeaoZAL z3j0HAFt(bG7^;@G_xPU*Q!t@Bs>IZ^B9eJwcuaG{j7}}1q=jJ^;L=tNn9>Esp{SZw z=wM;O-XoTQj2ubG%ZhCcscA#Wl9-c@0559DOG#*Oz(#_}xg_h#ao)CEche2iyvKpl z+*=)gsh`y8r?fcET(&JwpwE#SX~7PHpLYZP0YI0@Y8l5FsEqdQY(z`xF0c;~@1hVh zoy71|UoT4{Xt$`+i0gWe?RF>tWF6vs=5WyRRK^_xQWMM6rR9u+SX~kQmvQDx6!RaIbYn$RX1yFM(1@IRtG2#tg~L& zR#;7At0uMdvItR1X=yQ&1@647=w5qo5PCX*Xz<}x_;GGjD_bPkLcQ`cj&png#esaq zGzo_({%GY!j}GCukU)C#9cSCYI>PEjW1#m z`*{2gbrJg^EwI#Co8TmHy4LaR8EpzkZw>MBxz)zopUewx&cPEhd*x(OWVu05TW>d$V}8CV zW3&ymIN#0_o^Oc;Cyd}}2cG7*hr~G}a5)T8G%&~n2RFLpg~#WiMwDu%qg1rSl&WLw z$d{YL)y@>cc|7XIqsPtw_BQ|;@J5Vkk=2xvHe@2hcxnt!595XlI-F{DXeBeA;_)<( zY%9^xpSNp>_|(bQ1ypU6YfOl!2oVipg2SW;jw`A)hzgI7dx+10L#MCad9hn`U%k5d z4|=*x0`7Bwo2SZ3_SWLl{4ljW#OFx}?i|L=AN=q6qXSfSd_f0M|7qzsartR{^V#9S zzlt!`c?fq?q#aY_JRzVbpm0iGOD$|Cc7mqfdBw(TE zy9YZox~7~kC+RxR=#r+AFg@M%Twi-WVUBmVql7ul>IrkCt6{`Nz#pmm>dJ-3AFLE7 z*A5e#&z>CoJWdaxr^P45qvGSu!#G1zH|2OAka!=EzV>{)4@kTPB;E_;7yEPC)Fq|6+-Jp5q|-{0E20=ilt}PiB0^YJX?7zp~m9 ztNn%5{>*Bh;P5tsH*Jni~h`n%5w?P=)p z5iPU!+RN_~4LPYR#%iXWUPMB=qB8pmKp%Glq7XlNZ8#qjIB&=?IL}4px{_V{Do}H< zRmX~XxZpZibXjm7b@qlt`&+AU-#)dK81IbX8*IZK(TFjKEkU9YBcki2IxG48epIVh z;f@3%yMe+eSF6FD30?>JVy>FY*9+C!H{kSzm!DJpr*to+Z#wYJHl=6%y_D|a(Py1d z@dCAf_zkx0Pb93Zi*%dBpHUKbEh~MAGc!FTK6ow8ynOKk7e$ZxZodPs0Py*D2;g%D z;Ez23f-fiNQ77solCMS3t}yfv^d=+d5rgw7z#)`edMPCXVX;j`l&@@U!HZ(MTG%MP zhjQh0VC+`uy(V32J_>WZ^TcAWt)@=C;*2&jgXxs$JK0YLkhb z^~Z{WkYLr9T@BlYBxo)aK_8Hi5K?$RO40{-KwAEQ^1Khc@Xqt9d(PZ(Jju2xT_M>s zbI;s+&+nZ3JHLBpo%6jB&yaY1b**ZY8>HTDt+iWZx!xendb?37lVz}zcjSViz57~5 z(eiP%AYYu9Vg*IcT#U)Ncq%Iu(%QwWqQ%8-J2*Erpt)u!HOj?S`8r89s@ID*&y#SN zEVPZABy?eB<~#|#Ivc$(8=4LdBqc4weEyaZkw|dh;iuL|!pSs2P|_WL|XMV(J245Y+w#n z1(?OUWA-H%b8%f!bJhm`p70z@IFgW)N=_DWUKpNK2Vq99nwN7z9}MVK7j>Aj2Oj$q zN

<3w~>(7c9QK6i-X@vSs!wIbAMbR2%&z5_Y)YXW%|R1;5XqNM?Hv|9|Y7sz?3hjdCw>`Mh~r6T+M1;u=it3 z3CNU&nHxUTOBl8`y!hKPy*R?!@W3M@)TD{S#)^3n%W!#hiNd+kmOs-xf#{_w>dwJ;;aZD4=eSo=s;b81q3iGb%1tm9c z2TjjYkp_ACiX9@Igkqqfu5ZMNa9qBBPlO)&BIMEUMrE%N7)R`7Vn~?{LWN~QZutX; z_#dFB@Xc+r=klVe+XyG<6?zrW!&F|ZE+{v6?87qBm+~@w-iMY=0Vos>i=cYq%#5RW z;qaCj{lCN&rGOv3yaQrz`P6#q7Ti6=>?`ta7AHa4M(P6OrtwS z7^9=d=xC20pdJS#KoK#a#uu}4PM1(;>8T+);iGLYbQpFzbn2F#;^_o`+%nT$sd>3c zFobSt&XGpD)?}Jv>kY~c(-x*Wu;{NCudn@Ezo!sdcvV_j5LeY50+b@b&|Z;O%=F#oI2seZ!1jv(^`^b&s_uYi+UC2dwpX8eO8H zMH;zGqYE?|qmhd=I!z;C8V%6MSsHzjM#gDWKp+36${Ib#`;XGzBZ`s!<*~*0KU#FK z_^x>9m2UBcq1=1(u-s7L92Dfx0ksWKg!%!uU%fo;MmEpDjQP7&fqvo*Kj_2;#Vugl$!nUzZC@kAo70#ptP&?6q*E;$AoZnAs;w;-N*@ zmqmJWh+bi_qgZN{ z8_g$B^z5Vehr>JLL55!S(5qdBPP-ZE%F0*Wtnh+uzjMUOe2JNJj;viyer0pg4hDW>H_S#q}?~ZZiNVnhq4sO3?Za+KV_QIq2w%5%pX6?7}%@yqdzFlQ} z+hhK}0RPCa*drMhj*9!tBBlE3Djdw$8s+8cTclXK4g_4SzU8p58MJZvozE2ebH!G% yCw#69;1SCCT+#R*dQIrZ1LE_v3g1P~z?nLaUtV~|;?ZuO!MKmHp#Jsn;eP==raGDc literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~2~ b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..cf1659a8cbedc3f32556531f17a6989db5ac41f2 GIT binary patch literal 3895 zcmb_fO>7&-72aKvlE~OHDZ8@6M$rKN3urIHAJMTTL-2}RiYxw_y9%NlEKn3>GFp-9 zk}Tr528trR6xiCTWMijxQ5a}|6uAfmg39v2y%fFmcoXd*r^g z%37t=s;rWvR$DFIx=11svd~sE@`NB zC32C3!_(2|ba*Q0dGQD10XNZL80Kc@c>`LXk42Fi9xubO#(jM>DP_cXQ4|z0k;%t7 z#<;6{1F|CI5<)S-OS!_L5-@acn6w(3yjuBrMa8IWaIl1NPajDx=HiN!&l%h7FS%2& zpf@2VrJTs)x}cuSdtgOpz98l}Hz*9{7Zq621+VUeR1{5R?u4;D1d`!`5Kjy9qM^H` zoFW!8l3c)v0572ka~T+Lz&3%%IVZ^CQP$9hZs*#ndWQjbnV;IOqL1kAGkiG-kC!oY zU*v!bO&DOP1Cg^HKt2q(3dMZEF%F&M2X-%>&&n>4yV0)%L`%l#9Xl|K8#A_@_`9z= zQN!4Fz$+VoKW=8m(ABxd3Q4M!nm>Sa_)=(w)aoSD zF4tBGW*Dip0DEJdghRndxLGNi<4IWI6WH=#Xv!4964_F1y+I<=(W&56)Y#^X-|0h& zlogAzv1RDP^TJ$F5;K6tm&}OsLPqB0d{N=S8^wa^w)ay8RcgOC1TA`szG>)Vazks?>NiQR0IU_A?+aiZpxoC_2Vg_NTHdmn$>-*Ih*CD6;|oQ| znh!)dU~G@TOb4VGG^_-F&NZ#Efx+fljbAa0<7;>wE;m%QQf?XB!_XUw=W}sEG4wYD zk`;1Gd^{x-g*YS-vDW2z3xK;jfY|Qp>;<6%Qp)BNl=s6l3UPDLDG~o;l=t;SrH-g? zR=FdBIGBn~Iz>97$xiFBOusegyPU$f%Suto&6`fsi#o0~{ z&-RG*Wul!zI$(cteGduY`ovc1*Z7k1mpL!vU@?^gLMFpom4TS`^POd-lc;F=)wh@JsQeAhmDu~qe6ySDx>JW2cj z`wXyPJup^I4cJa~Y^VBdyTHbig`EZI-2SIh)&JpB zGj2QS?>^w1pkW13IAsG{%ZC9V)g!P_5Nh_9$LKz zG`32^%QX5SjTLE3qR|A6&Cuv28slm79U7aYQ9q4wXyd#92JF%oGGUR`8fzuyzGQ%A(G1 z;IZo+D%Rn)R&vo#*q-$%xRAL`>n05`RC2K9yx*GtI}F!d!?YXE7nXjI-5unEQCUR`q$JLs~VvF{CJY+rP~=tYO+O!>Xn?9t~KMftE|;NCZ+l+r=B|vW1#Hk1Wzt%a zDj!7@!$8pnMO$p^sFH)7#zkQu0gC3LLj%b2!IuIBdUh{Gk3HnllTSSq?mshp$B7do zhRmJ$=k@*neE&ByyWHTrktB*#wzf-Vp^7Sv`gWs^HY!zAt2Cu#WUxy-{7y?Oa5GAX;gdJ4l+FoxO;p`S9F)C@>eAyL34y1$-khSx+)Z zt)WJvP-7$gNXyqNx4?^lKj6QJLi6Epd$2$38+q{u`y=6Og@b>$+dspkmiwK;3-*S6(LrzEKY*bX!nN`DUTW$%}E8C)3_({PeaoZAL z3j0HAFt(bG7^;@G_xPU*Q!t@Bs>IZ^B9eJwcuaG{j7}}1q=jJ^;L=tNn9>Esp{SZw z=wM;O-XoTQj2ubG%ZhCcscA#Wl9-c@0559DOG#*Oz(#_}xg_h#ao)CEche2iyvKpl z+*=)gsh`y8r?fcET(&JwpwE#SX~7PHpLYZP0YI0@Y8l5FsEqdQY(z`xF0c;~@1hVh zoy71|UoT4{Xt$`+i0gWe?RF>tWF6vs=5WyRRK^_xQWMM6rR9u+SX~kQmvQDx6!RaIbYn$RX1yFM(1@IRtG2#tg~L& zR#;7At0uMdvItR1X=yQ&1@647=w5qo5PCX*Xz<}x_;GGjD_bPkLcQ`cj&png#esaq zGzo_({%GY!j}GCukU)C#9cSCYI>PEjW1#m z`*{2gbrJg^EwI#Co8TmHy4LaR8EpzkZw>MBxz)zopUewx&cPEhd*x(OWVu05TW>d$V}8CV zW3&ymIN#0_o^Oc;Cyd}}2cG7*hr~G}a5)T8G%&~n2RFLpg~#WiMwDu%qg1rSl&WLw z$d{YL)y@>cc|7XIqsPtw_BQ|;@J5Vkk=2xvHe@2hcxnt!595XlI-F{DXeBeA;_)<( zY%9^xpSNp>_|(bQ1ypU6YfOl!2oVipg2SW;jw`A)hzgI7dx+10L#MCad9hn`U%k5d z4|=*x0`7Bwo2SZ3_SWLl{4ljW#OFx}?i|L=AN=q6qXSfSd_f0M|7qzsartR{^V#9S zzlt!`c?fq?q#aY_JRzVbpm0iGOD$|Cc7mqfdBw(TE zy9YZox~7~kC+RxR=#r+AFg@M%Twi-WVUBmVql7ul>IrkCt6{`Nz#pmm>dJ-3AFLE7 z*A5e#&z>CoJWdaxr^P45qvGSu!#G1zH|2OAka!=EzV>{)4@kTPB;E_;7yEPC)Fq|6+-Jp5q|-{0E20=ilt}PiB0^YJX?7zp~m9 ztNn%5{>*Bh;P5tsH*Jni~h`n%5w?P=)p z5iPU!+RN_~4LPYR#%iXWUPMB=qB8pmKp%Glq7XlNZ8#qjIB&=?IL}4px{_V{Do}H< zRmX~XxZpZibXjm7b@qlt`&+AU-#)dK81IbX8*IZK(TFjKEkU9YBcki2IxG48epIVh z;f@3%yMe+eSF6FD30?>JVy>FY*9+C!H{kSzm!DJpr*to+Z#wYJHl=6%y_D|a(Py1d z@dCAf_zkx0Pb93Zi*%dBpHUKbEh~MAGc!FTK6ow8ynOKk7e$ZxZodPs0Py*D2;g%D z;Ez23f-fiNQ77solCMS3t}yfv^d=+d5rgw7z#)`edMPCXVX;j`l&@@U!HZ(MTG%MP zhjQh0VC+`uy(V32J_>WZ^TcAWt)@=C;Gabriel>Benchmarks>MISC-BENCHMARKS.;2") "27-Jun-88 18:00:16" |brecompiled| |changes:| + |nothing| |in| "Xerox Lisp 28-Jun-88 ..." |dated| "28-Jun-88 09:39:24") +(FILECREATED "30-Jun-88 13:27:36" "{ERIS}Gabriel>Benchmarks>MISC-BENCHMARKS.;2" 1676 +|changes| |to:| (VARS MISC-BENCHMARKSCOMS) (GABRIEL::TIMERS FLEGALS-SORT-TEST) (FUNCTIONS +USER::FLEGALS-TEST USER::FLEGAL USER::BL) |previous| |date:| "30-Jun-88 13:23:50" +"{ERIS}Gabriel>Benchmarks>MISC-BENCHMARKS.;1") +(PRETTYCOMPRINT MISC-BENCHMARKSCOMS) +(RPAQQ MISC-BENCHMARKSCOMS ((COMS (* |;;| +"Bob Flegal ran this test on a Sun 3/160; in Lucid lisp it took 10.21sec; in Franz 11.04sec; on Maiko 2:34.43" +) (GABRIEL::TIMERS FLEGALS-SORT-TEST) (FUNCTIONS USER::BL USER::FLEGAL USER::FLEGALS-TEST)) (VARS ( +GABRIEL::*MISC-BENCHMARKS* (QUOTE (FLEGALS-SORT-TEST)))))) +(GABRIEL::DEFINE-TIMER (FLEGALS-SORT-TEST) +"Bob Flegal's SORT benchmark; runs on a 3/160 in 10.21s Lucid, 11.04s Franz." (USER::FLEGALS-TEST)) +(CL:DEFUN USER::BL (USER::N) (CL:IF (= USER::N 0) NIL (CONS USER::N (USER::BL (- USER::N 1))))) +(CL:DEFUN USER::FLEGAL (QUOTE USER::S-TEST) NIL (CL:DOTIMES (USER::I 40) (CL:SORT (USER::BL 1000))) +NIL) +(CL:DEFUN USER::FLEGALS-TEST NIL (CL:DOTIMES (USER::I 40) (CL:SORT (USER::BL 1000) (CL:FUNCTION <))) +NIL) +(RPAQQ GABRIEL::*MISC-BENCHMARKS* (FLEGALS-SORT-TEST)) +NIL diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.DFASL b/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ef08934b73279a5d25cc1ad53b88141d8b78e86a GIT binary patch literal 48275 zcmeIbd3;>el_&n*t3@SSlFPP?Z2_hb#yG+$Nl2%KXJRB{&}RlhhyKv%>5dH~Bm}aN^rVT?p5^!JU()`4 z&pG#PrLrxN%xC@?u%b@?=AKWMh156+`emPWb43S zWXHg+!OcC9tw@i2I-X7D?!Klonaeb%v+?WNVolj(yz{!QcuQw|qZMsT=M(Yl(yLca z%el&K9_-n)vu8^rzpH1*mQ8mpiL6*2Y2UT2C$fCa>eWjk%P+rb)taj=U%hl%Yb@6( z=+0JT)m6(@UA1E6(rKqYKYYNLKcH#aZTxS#rp=tGQ@m2s!kVEEKRr~_n(T}>XXCLv zh)p*e+VJB;;f7p3mTHM*TN;z8On1IvcqqI)vU6a2W3lIso+9yoy8$S}PYi`xyHm~i zWI8pxU*B!a0l;ueyfvAMHxgVFZ%t1JM1MLHPZ=Q;2&TL902x5AvL%^~b75oV@P0p~ zfR2`Ytf@0TJmiDqkyMe1HFw0?;=}um;U|Zx0o+R1H#{_RLp+<_(Ab>r>Pn{?N&dq_ z6-xU0@KEs6sa?h5-5SK8T_7SL<{^f0dd^i(76yQ=EMaj6@@S@yIXf4eRT4|N&UCD0 zI${;zB9l#Le6tamsgOz?gPxq2o4DYWZR-YaU zFgEjCiB;$F+3x0icQ&4b7y|iJx+Ojg30T|?@AnbHb+K%c#7CJb@*6YpuGj|iLPY$z zv z*rAmY3N_@=G~zic>pCm2!O97O8D21!%B_z}IM9@a>Tzrcq5byoN%%qI-u}&3*PD7sbuTM#$0z(PO{8sko=A7lc|>U zddju`7Sar>ow8;$w6vgJ)-lkEOWl!1cjPix#20H31}hP0?2LDH#klx1JKET(XqX<$ zWI8=Wxf1ML!KQ3_y{frs5^f|Zrd8E6Ct}&Flo_xKe|POngHopIa*=XF6le!hK~X zjRq3Wwh5vDluv0(kb?p%kjW)gYYS!^gcTCDNZ}VEK=o#&h(+3bV>aHERw@w4+(gfv2 zb+$X@Zn%{kcUm|_QDF?0^NLmG_$+!U@y2}Gv6cQ@Jg#hTE}rie=Bha8Mx|0(vzc_~ zMxk5sxXhL>muliy0k{=eX%p4?Sa&|%nQq&tYK`I&^po-9{L_^!vo*iUl^|6X&O_e0 z#&l~VYPS+f^^$@1LDTjR}T-Z>KfS6yR{eo;2k}KJ9-DUMFzG; zZXF!Bb4O3)&O-0zLS)N8&yH=E?2K$4*tP>sXyo=?n+wDH119x_LAIIFGgOF4l}MG# zVn_}i>lH!wK%zNSU907$K_)nmZ1K;M~!^1rorBwy*)cD8fTW;Y@vthk*X%HnwX+H3lYbVn9s(gp2F@FWuFy| zFN2Rt3yhSnv7&H9lX>RW&;C!4>|~=gcZ$;iL(1ek&1z^)r*az` zo6x5x$ZJsU&8&u4Hjd7?G<`-xGCd)2W&<^tlH~p8v6zVw_&^)U8!U73;tl z2E&(lYF#p$PIblMfYnuy!wx`0vsNr`#1O4<^=clTU3t~AHBS#+HpM|84@xe>prqFt zk|0b$`YYBVGA)4diHutCi$P0R8y=bgr$tk!Ccq;7J3kk%aMS7V42>?eynh8KBM`co9Tu zcB5*f9F_(p>C!+Xe7R^g=UL?nUm-Bb#2|!$gjJ2ZccU7aibm)pa~392B#FA3$A{)a zQDWVld8hUoc_0zb5+Bq|EIxK?ySbV~^fPzw+077r$Tv+vv{~FQnPyp;`~*xg3G2hi z(V>Xa{#=0yAXiA`A`7da%(kEe@xDsl+d@-$YOOpKC3#4gD$g7%PpBjh30dVi$I4S# zl81z^^31jJP`$e8p-NGC=2>~Bm*kLb2xNcrKUD z($q&L8*fQA!=>N7TRX@#umIB*!RRa0@FkA6uJe2ZSt87&a8pAoLi=KKat`bSCNs!r zI1eeT{l6|tF$?;!0Nn{@3X-`5yuW;Fu8~@Ln!I7SuGt(-+RS#cScGC)!;@|k?VDlN zhq%#eiuy39r#8M4)GW}yT~Qb*pDZBa*jqs)r2)j^PL4xX4=z^}48c4&niT4{$aw?nJ!&=m;zNlEp^ zq-)xrPp991ASL(vxM`BzzsS6hl3!qTOjGcS986L0K@N5e@S}4*KRT}GNBd>`NV0pW zCuVZ2O)OWdr7#gFOmB3Q6n@`GZ7(V~fxiNEgSTqqBOm-3BtM#nzOF&+co>j69)5@& zk07LuM+hRvqZ;zYqYA>tqXv@3BMdR)F$*$IC=o|=Pm7XiHN6&{)r{suyt$*1JG<6c zveVD5nVyB3PdDrRR*RcatSXsBoDI86{vjq%^AReJX(I?nb<#RjVhC;ryq08_?lUje z;Z~3b9+*9SrKk;NwFTxlFv721$#Vvr0t` zIW;w4N$~Pqq>CYiP}2zrBfri3*kriDlr_y2Gt?#zHw>l6;iQ2%G5i&QP^B+e9jFBT zHKEGD#FT)Gh=$1!ajA=l<}(s;DHAbKcx43aBH~gef+zS(>a`eBwYtPbLdzLRSmKuP zk_mN$88MM&=UJ+!@$^MAXDPar`Kd3Xr^RX846RUC2R0RBm$?|rxES-D2VE0CEtbv3 zHcFFl)%Rs?J};Xlg7H@7|%wm33$zJ&$`v7jLPBt=bLeA584O(`xE|skAL6i-=FgD&-nM} z{QCp`{UQIp!@ob`-yieuyZn0`qgI0YCjb7De`!4D%g4x*rPT;K)NF?kkO8?LAq+3g z0*1Z><}Lnx+bp_Nf8_-E*%i0$Y~s88^kp}kt?a4^W$j8w&7Y;xub5DHn$j3q{WweU zE2;R|%=qfzp(+KGmr>k?oaCsxn!;+bI$@pugN3#Kb4=}O#uzEvAkjDXVNj}?;~EDo zuhTeaeRYiX0dGSz&Vj=*gJxyWB{X7|hsM~I<{Ee7T*Km;QS_DcfVJSy?g6b;A(!l? zGr}9uyI#e;D@SiKuVQBAm0_k&F@Xsu z(+OZ{?@ZNoy<1AxGvG_hXu>wX4!xFt^qQPcr5w>=ELe+uhv#OSQ{Tnq)Z2ePryi!s zk*XX72FbNz4NJx`w%_CCB*~nV)z})Z?zB6)W3A`Am^e)zXX$IZ8)rM? zJX1f^;fN}iahk0D4ff$UL!FIcduKsOkxyXzhRlo$c8Aq@dk?)3dfo(S~${d(XxES%F9<>5tAj% z5J#?TY8IIE=E~L0vQQf0$eI>esS44XHOu0yl9MCLTiYZ?Z@>`KP6K5rpWD^_Q!lay5_e$2dNQ1>OgA45BXa& z)2X!70=9Rpl^XCv<|2Lg_}wCTKV+?NK+XyWWUO#NzOt3X57~;8{gA6j*bkYCbp4R0 z3PF}4V?X35^7TW8kgZF8DQ*rmy(K=GXZnOzW?gNM$y=!*p7=-!qk_$Mo~e ztv+%S^-F2eSa0CzJ_8o{pt%m1E}b+6Kwmcjdac=`3&b2jTt8Ka>&rtVN*f8_1^`^8 zgh8A~4V^e8qRB->RQ}-=rL!26C}_UVHBYa{jD==TrP<@3NBx13pG`D8+G&Ng`0q zTsIgVp0GzF+vRTqBY}7}o6cTu&btXze=-T#X(e$os}} z=7r0+mdi~TK+li)OcJkwVNqQ;7Cm>f z_GHEg$9Mvz)4T}-AD2`EF|3i~hl$2)7u++{6mZ`R+_Ph!M;!r(1*!n#^tw!GA_Cp_ z%|U>t@*f8s3yO0#YvaW&#p?GgV;~wda<5H1D-6+y?CqRB}eY#-v{{jeo0X)R))NiMEjL!=6z~0&$xehKdr&( z*DG+3GKf4(2&GyW1$>_0NsdRcpB04ioWCKj-M>Seb>go(&&04hzvr!5@AV*ZXLg5G zL1hH3B34x8gov3!4;G=>n^Q7KDNh*HeG964TBbPj&Eo%ux>Y0aHuDyzb}>=$_>iwF z-9qXCfmZc=a{H!jTNzt1YuP5l5!O7YBsv2cF`brl!t5rU z3;m^{^lQ4giCX8afN&1=eu=(Q`;y^8vToy8qW}2l$nP}sR>NZm^%OxnXl_Ok;MaCz z$^`~H+JAg3aU|Jy>d=<<#C)>gFZLxM$O8V37O=M2p+E6(UngQw5-$qTvjcxGsW82J zxr=_sQ$bDZqMz4|IxKp1A(Wz@*R?tJ*cQfQQx8Y zQQhkMMiWm*js8SU7@8Q4;^)M^{%{{uu?MtzI&#f-J{ddgAC|7XINj_apj!cy#*0xH zaP-&QGPi;fPhoUImdkQ06}oNsKww?pXx~^ec5>gy<$XumoA6xJ_hLsgp7WC3?cE)3 z9((iHXz#jw;D8?nlVRJk-LtHlU+2jxP zL4{xCXdgWz3a@vMP{Lf5`W9;_8JBMnS(_N{v8MN6nvF~ zw^HywI>8YR-b|_Akkq^Qk=w>1hGLDDUf_jI&Ff2k8Wx`w(E z^TxZ3mpc28A07E^yPe^suD(;BYcI?jZ`Vf_b{%ckU+(Nb^=!((9*$ID{&>1(D20M4 z1IZ}(i}~Xn#*6L7kr8ubWs;FCft|d+qfn@uH{PMgjuc*MCv=Y#y6SFzslEUBk&)k# zfkdg1?~{Rk{?uB{?1MdYb%#2}$a)u7-%;9yc2f##2hA(ip&ng+YE7ow)3_%;}f*$O(%;Tt z6^-;lPy_Wy*9hrhUfl$!m3R#`{4WcG83aPy2d$(JhO|(~DCS zc{05?9X)Je*`H;*x!4ddxqw=BV{#fQ_8^* zCMmUEr6wqKv7PsrD=(!=UX=Y?yr=8Ie0m}BFC2gV-;dKEr-*3{my!qIy2Uz&hXUAD5^I|VYogP5%!j213e$kh zxcD*(E~MnR&r0e+=m}c>NtGQn0j_!%-81@GL_U4Dw1yhN25N`~UJ&xM6QJIpZA)&9g(( z_FlhR({>FHEshTk;?(8RrAs551_w9Y71`1IsU98@Zi;LlxRcIiZjJ1`b6_c&(d}qP z7sc3iMZ-~cl%A1?jzQv{XqbJupK9jq-gc`_)eXU?Lp!anX6MG-HhjPr$wm)TN1Zsi zuQ!~FCO`aKK9)Rom`o$}#J|>jhS}otp|ka4L4BLybJvZI?p1Gx072RS4rDG^E9OIf zX@zMtOTOWF0y>SpTQ{!*ILJZ!dvicHEPuvFYe_f{m(IoKSW?f=FoXW-7(rL&x-+zU zz9mj)EGv_(*t?5iYc60`7$#ctL32BVa()vqj3&mC#uIy!m{QoAG{#2$do-5d&Bf++ z;PNR4!AC|De=wc_o>VmEo1dUS*67vq>LqGH%6QtZKBL8>8M7@LU9jLvF`$iMR@E=Y-vHOw!Tml|b|FO}L-}dE-ffvSSMvQ1bgpbp( zhIyr-o7bWmSDQP0SP@sEz*b8=DQ!hN#6Wk7oz@OEmzC#O>3RUuU?Zv+ig+ z^@LA6)`9c_WH8>NVJg zR=Tn4)8^beS&$d?U`ofFyFwzozTvxw)zUWuGflklS)G_5Iq!lr>whU9FM4+GO(=Rgb(&sP{3klC1 zz#~JmC-x-637v;#2H;?5b_ev=U1_{i>7aQhid?)+U!t5D^3lgjek_AnDXewXZMSzcz9B6!y`vO8pD9-PPtN9i>DG(0rGui+*YJ z%g^ieG5nk>4l8*Rd!v{tJ@Lh;5i^?5d~P+yX(H<_<sEauu(Jv8A z1gWm6&Zg}7Q`dURr&Rg5R37cf17Q}tm{{GB*o*C?7Ez-kiu!7*17R?u$qr0ppu|z} z`8uHwL|qI9A+$OmPBSA`w$WRPe|jx<;22{Gd*6bzYnkuJYax{ULt@l*>% zUnkWuzC^)?B{*Q-6*uo%ZQf<@_}0K#1~%_}!Hvc3kvb-sD`d=5QmQq%@?x3xhz;{Tz;re$Fo^p~ zKww;?ZfSYLu> zLzK>8E+Cn-uE1sk!i#CY&P!4 ztW08^?e2}tSziNx??7)34j)DU?C#~qx}%4WhGP85E*eSDfHZP#Id~5v-&n{{YSUUP3bYLAO>bhV?o7sk9sRtbrRW$yg z8?)x`Vs_}{v&drS@V0j@BZi!-fEt!tzgam$S@ScU=4VjkATI3y1U1$&0n|EIz3Fq*`u^yzqQ~GWZ5&0#z~DrwVN=5R$O#Q2 zg^Zz@mqVFF?2o!lj=746GDQBL4KU&%h*qrc5d4Y-(L;3^J*pqe(1awLV8Z}xWr5)f z2-qRG8*ZO=qi>#hx9Hvw&jPwE@Ml3Zn9&!@^bzPSgu4j`7|^>J$&q%eLuyBd1gC@; z8+j|guduuK#g2U)_a*ZB$wTwjCEC$Xp|&=MHdkS7m2*9hcc%`mY0sB|bf|V+UdIbp zsl9oleV!`&{Ha}e!#IFHJ#i9v5!f6WANiNOfw8EC`~D=}{^8^^$wYh7sH>YlKC(24 z0_`B<2BG@dK0AS^Pa#){{?8`D}R@KmH{SW`JrGYkA z&;$RJkK}vV+t?>Vv2OZbYEOn`bgY;r8ekF$s*w4IirmxZAxtd_hF z*08xSik6n(H9Rz6XzLip{pg6WCKu&~6G3-DpP#Y3)Na?4cR#Uyb}1 zvF-c(&^6bbLnqEuqSg$PXEu!YLs&1i5I+gTGomJS8)P-=Y_IJ}Wbpujr%&2S>0*8M zqv#}u!&HzKgFOH-BxZnO+@6%i@g&pe!txZboR3}r!;>ge=yccI38?<;DKELa$->~> zp4tKNzn@lPJh(YR|I>gxGYa{FZvkyH|Fjnx&%ukE`n1?!LMKoTzy@CuJ9H84vLWkx zFoOVx0G0;VYAE$?R0d|u^8xSJkExZZexFF=soCaDl^7ygSUv|@*I@Q(o9|b&jzX>) z!1Jv2nVvkG@P=r`=OBO8x&oJ(J(rk07nnVB&7K)pc??`iw`!1%;35%mWb;0bzb3zS zDo15kg8fQz%2tgb$sf4rPYn>)m;Greoc*T;IQ>rzP-)okA7A&wp1LnwViqni3vz+0Ck5u>nU3G85y4={)ck-#8qH*#-KMzjFd-{LScjBu>W7FuK?$HFQan929k z4j+`LTto-_)3_v$t^vWFI#4fw@Kz&l1f*Kges8S8n;CSM04_qZb^w|eE=FptN^MCu zb1?g4{O{*zDl(G351Pv42J^h5Z$QCeu>Wd!-jW33fas_>Te zBkjBrL$lMrCI1WD_-DWeTgiMq<1;*><>_$$Oh=e9L^LmE-8>nQ$GId*+}_iiO*Y|1 zOgcqH@=}a*$LXI3sY%E5EX+pdHahBFmi)23q&QIz`ATAcc&08>5ww&g2U<3xE;hn=<)qqC3^G zLgarCO*cq8Gr8YyW0np&`}9Deswi@cOXj;iPjA_S+l^VS8~N0FA6;<+T8-^8lTu+_ zNrY3d)a-B`K#s>}<9z=WZI;C1N;B^F#EOjdHe}t*L7@C=h;0{KD&dQ-#lh>=~7o)g>=1l5A=TO|_z-92hQ^^*}M$t?_U|`%){K(rMfv207YDK!brB zSFBpG()B$Plla}Q>~sVG(uXSvEpSYTB|YDFBtwOL6P>{JWb$v7sJwE4CTasvffP!#jDME1(j}9W#LqEq6^S&y@bb*(sPuw=_Mkp zWTz~t)dV%Kz{PDz7*ne>!Jt}agXVihQGvaUF&HMkK#eols5pS8NHsYfSIeRg!sT-6 zR#lqrVll}IlQ4yy4s_U9vEhH3F+K^>_Hbywi$4NdrGTnyX(hKOr~m1RuqcD^D^E5t z7*7t(v~NnpW?8I#opcL#g)&y1QvIJ6dV-9?)e;26C#;f= zhEob~!{9-6>9LkrV3Pc|GsvUf=u1>{_+wCL+jhVU(|@xR=3kWIL5u^DK)8{d9jX#S zIg&u3O@+%0Sz00%2g9#r{h^x5r*)9H_GEp|9gz(ea|cZyPRmhvI$`N9UI8${+n$I84GDV z7YF4^;3W*&`4J%XQ#;XxPydGkg+a6sS2qwJf=a#fM5X`ppKwEE5M*H(ij;bQ6Ng;X z@mssmD7GLZH!L^`ExW7lNg%CB70+4BwHOQd%qX*_1(~?C}vutQB2w5HL`oswNXz zNjhQOI4U*Z<3$6@$6yjsS4xN~5Ws;PmQ;Y}uT)#IvX#75j+6D4YnZ^gvI#NMnV43( zbHQ8bD5~nk#xJ7tP-g@7U8S;3WW`or>y;;G85I}2S9`MAroa-IMc&m+kF7-#_3#am z2YBzkrPKpLITWm;kgXW0maE45_B#aM)Trc&u{gWnRH&m6G zi`Y8hPV|^S&St|`TIiwG!tPCk`Q*$7dKygQBCLq?RzE9HdDlg39j8tH0eQWdf`l}*XEM(Sjgx9yjq-)_9}H{t4S0UvlqL2~TxFeBvLfoC}E znUbKCz%U$VqSeCTrBw=XMh4(Q;(=F!Q`t0&qJR*>X55D0h?FJiZ_&%PC`Qv|vE~sv zzk=vRoZdmrL{)HCSb6_hTC0UC@T71^ztXh)mh^1*hFm7buKX4&13A5}bZXT$kxDNG zEO_?nsoz5HCRe#4XinU3oEH6QWMNy;5)ZGWx!V;&I>F{tR5438b8CoapQAe$J*?8Al#GI_6utuHRS; zl(dG=D$o`t%I4<|fT$_c0ds~D`P$XP8YFJ8jA0FO9Jq+QI-Su6KvDKXp8S^6DOA~c zI6ATB?3OLKUh`xtFMZcQY@+mSQ{fekM`9L*D)F?I!>(_}SfUwreOm)Vj}V;9wu$3_ z<4Jq#H1K^7g{rtkfKn2#!l^_%54UOuuLB>N7vPl((mo;Q%OqyWYu9#=_wAM>+FVkA z%LdqwvsG2iE23iUDNmLskOotWhz_ugOr~+(x z?L-@R&aa|Ye`gyqzs$?<9e)T=OLG2PoVym5w?!dxE%BRNKqkt=L0WEpTDi62 zNV*9SL?up;AVPQGdh0k=Hu3JaHssTn_0TNY?7DSDZ4+#B~^#lKDY*Y@_7N-aLvKWBVQ}w}Qx+WKA0&95iVA z)mS7?w#j$3F64Z#olPb@XCTGmEw(evWi8$-SmY&|+c?C~eLRxH*Ve=|txBX;^ zTKOISw@f_~s6fW5h!(pdCWoV9mZHhQA!0|>+Q{rtg3}hBR3cOsvqc!9-!f+K6)W9_ z$o$EMAdmH6+`hfc6J|zePl^wheQ|l3CB&u)*;L}gO()bH*#Z=*o28`Wr{9W2R$VKg zoOp@aR`msJt6EKa*G74x8~tE&o;segx1B=!61b5D`@{I28QMCD?Rs>m{D&Gr(!PLw z^lBFtPG`;K<9^0A9d|JLu;0^ft~1x0-R6d%qSO!vm)H9Z*$pk1GFGfmBz+O*YSOad zuAk6Jut=NJtgw&5M630O4Tt!LgS{C_p`hUe{k*qq84mj{$4w7>#9sTNhEwpecdUXJ zYP3hLV|E^4^Q1kvjAIW*%(=DZ+>kjp$ouep5AsrK*5%OnbnC&46tb?+uRzq~Zv+QJNc$-wSC;WM}r`|m<6Ic!FP zLM^4uc!*%1WV*9+F=7?+smS#gBU~lnY`hH{Pyk-`>sNg8^9Q_x|L^GDi7J#_fU83o>=2IpB$B_CW27H) zrl0g}4v+U0ef@n9;doy^f*hbENh$i|6`qpP*Dranuegt2p^%{h2vMn`(JufIkW$Fe z&&2^(1*UcPy)a(%b@#t8-rrp`_}7Que1D#<9qSwGo2mQw+PVY$JN8hoQf97UlVcsw z{IHddTQqRDCicrN!I`CIoLP#~iC5e{#-D-GzKk2lRNc=eabL^II){RnJ3-k-`Ztuy z8)^NVfwf(`pHkYBN1y2Jq1iaXqr0w67^*rUJf^~Ge0}j`42FmZ;&@eJYR}5IExW58Y+(-CvS`r_=?T*tIn{mrH z?^2_1;3lE^YP0`B4n05J>}Lb6J+JeI2LJ6=yZS0vn;xYt!F=RhtnOEV$bC*|gTdob z?JL}`XwJ!-zd-4EbVAW(D#yrTj9N7Rg#lP%B8*u~%vY!3-caX4V(Hrx=*skNXE?%MOKl<%N3=+MvyZw03;)Wv5W8?c8@X<#Ysd3=Jw>`LyGiqN$PIn_o$z=%I z*NqTYohLB_c4!}%)V@9eLxgGkx{q6u zf2;Tj-;w={HllB!t0Y#2`JSvwal%* zMA$bSFGO9vX4=L68kN2drx9^25bmkgM`O4@F%iZcTZb;-sE(sScsCqNBGdeNa*Nl8 z$T1qz$B=Xcmo^S3^%s-vxKA+*#~AK0UvTtmvDAMJ|JWr#o$g0e*M<{m-y$7mSb+0n zQV(0j|5b{A%Q$24zk&4H`Bqc7KA+1$cY@=%m$W;1_%PjG)xh_49J+`fd=TeI`@Z&j zflB4Y#XwOKIQvmA(HR`_C-?>p7VqEqyhpU#{ZUSTOt}s0GHCZNFmW12)x!u#y6nt% zfECZ-BSP(HOxt`Fr%G-EBe9I&Mlh>Wk}=`?^^91q1fwj^Lvm-lCz3M(j9dEXkmasO z0%m+r%a5}6MD9`S92!1A$I`WtSh42Rq52Sd&P4wFC+<(=>u{)kJ>6mp0UGOP)osQn zQN#T?x~JsSp*j6ITx)Xp)No%8SDGNe_rUk%M)4X~t0Z3-&y6C36{I|4{gfPCACA2+ z-ZvV<-6x6S!c$aXdlTg711DXj_M05thceoqgv*>8qq|d7kYJ4VQ8GIusLR!;%WL5q zE{1Q|0N?OZ_=fGiO7lt)rLV#x8{CQ#Xo+X?3EyYr{kb$b+?_mX&O_YbJH z{UUVsqh6y&TJR#=6_-{AO0LqQEJxkf>2U&Z;;FBv>*-Q-Jzd-X+3V@Z6ptqUsaSL3 z3yI>XUldQl8@aDok@&~m1!~1-ytMARDDKvwJ9WI5)?E_S&kFTSSK0mhFaL{!T? zy3US=$#R_?4~Vs+R59#V_%M5;?jNc6HU%G{237HG-gBuPjZ;iJx>_E_Qf_UYtL^?x zuD1IsuC~L`MSb>Kx_D#l`M7})&qSSk5)4+fsv*|d$tQlZIWnR{^tr_(edQ0QezK9K zYJ=o}z9by7)HLq$^ze=5 z#%^ZuTWh&aM|u57`=-nhzRLA(jK(<2H&>dsUnZIDOZ#7CS>V!sIKl&FeUDlHXL7GC z>C3AS$Bp7@enEUoaQCP7H(x!ozxf>;)vlZw<}njF*-*ji2AoaDrzTURfaG#BPv3#( zWQz#yc7Rh~0~_LQzXq*N^AN=t<%fSPcO;oRAMRzcy$)_DB^K!8;YSK%@L~3h%!4b9 zwAcN)^Kc<9e7|v;M*gMbGvKtSBj6SPEU3Jf!unI>0$d}nu-(3Xg;~GAtglpqiPJYS zDpB#4e6z`ESov&>4*-{GTHlqX^^pZnQfR4zZ!mG6Z}LW`QJ2q&QNFPSbJs4 zWc?d$bgsc1b9csd8-W-Jn@C!P$IiE$wQgPwtjcvDZb#Ubj?? zwjg}ODhpLlrOHATnPZ*DJ(`|nF}|NUffrxfn*;bXyNa9dw6bdx}&{$*J*zE?`d_gLbd>z33S z5CQqG!$TJUr}O3G20Gupv9SpUD--m^+gyW7pSYLNZ{*qM>It7DCwOnN6kq4x@A9wp z{qrNb8u#e8ar%EfBVGSEfiC(U(`4wvEu#$o1J5VYiMD?{BgTIk9y-q}iDY^bV(^&* z<{%^dMG1rdbVhXFA0ArZMVCo;PKH0Ob$on8A8X_xF%3-}ks!&*PT$r0rP;G{^T1tpVj; z-}f(&aGK6FbcHLo-MNO=cub;=i?)Dya9!srEqxr_OG3EL+GV*hm$in+#Ts76q*VO7 zfIm)_FVHk_SI^)i1WLBXB~TttIChRC`f(q=d#6Sb^i@$0cWoZ-kZ+QlwK(M_aQ1QG zs?8Sg$K4|bNbWSFB}+%VEVba?iR3yjOFcgRP!#$QBTt`4^{|w2NRzMgXrEJTmGQhn zU9Q}Ya%61Udqi};{PNNfSg6}oRI2U^3enj$!-aN&{CY%w-L_Wru>4wDdIo#%n1o7r z+gKU#6@0kyj5PvmvG?n4T%-iv#x*=?wr+IFPGGAbY<=7oZGjbivRsvD1wL_^?e=N~ z_a0(8-n7|cXIZP>W^5>~z(j})fJ5*aY#xJV-=z85;*^`fAEOr@Z?k#iMB+2l(z9dd z;I7R(CsBbVtdj4td?KrF39E0}td_dmg!>I@RH5yz9@sGNoHV<)pM~AGgx&2PcHbg) zXSDR*u>xKjJ}$axXYU>2w4J$YD8u!NiCn)eTw?}<=BS~+>{`198V=WYdAO$Z{gdXL zzD}VULD`CaTR6YV!};4T&a*w6cMa~C9Ov{AWyglMw&uNT7ky^YW|v)d;~ZLlsisRX z*Jh#B>KiQNh9=+&@)AzyUdQFss|dm*O*`G&ES!uGv3+eKp82a+eD)?T~RN*_G( zGCJrp2W>_tbo!4vbiuA8<0Scc$SF6WDhGw1M{RxviJw3#Zphm*368uf+e%+}& zZ%t8S`hm2>AK2`%bD@Va#cDRRn1kR=cA?L^+96Y=?NywX>yYWzI!h)_hx~b)9Y$^A zoY4D!*;QORxvO_OZ7;iuPgU+N)Me%Vj>!FGkKErm zz1pvY+y`k}-`3*5wq3XHn1tGwH9D)x7@Z%9^nYYaU%G!7of%%E^S4uy{;MwWInw`I zkMtd!+y}d*|AwphRHg4iT~_)(66wF;k^Ya$OMlg$(CDnnmN7a%7V-bs7C-mWr2Mw{ z#poQLlKB70B|k^}$35bAa8Bq(VUIqt(Q%l<8|%l(9KK5#j&D68=iNr=`7Yyt*Nd&hMrq{108ybA>mg}SWp-(%rd`aQybkA#1IIpI&m;FOno8GG}-Nd0|V z>UKA4OP%da<+Q0ty%NpEHq^G%E2nv+?%*u#W-Dj8iceAMZq#L^{=P_kmPhLEpH}7n zMCPWPi}O>F{ZDP#+kI@nV{R(Xos#V7PISvNcVvIANA?cR(mu8_;wnB>*}G7emHkge z_7RWle_B@dAJM}pr}$+ZoS%vCe`X8c?r3e{v$?7K*p!67$R#~T_#g8K-@#eh(N->X z6`!i`U8u_n|7Rlnr5@q`tgN}2s(({n>SfH$&qeA#x1@f#-NV{a7jtvvl%#&SOKgtR zuk=XW!CBhFR$k*OK2@o^P?weZ&qeCjc%=UG)2jSOFgM=0sZ93`H+06mquDqXI&F!| zJh`*RR*6@(y%6qcYGqRMQ9vya=g5GSsKnO&dyRB`Il#Q8FFZUC?S zLNw|ZHhImqox|nlj3qM}Hh{OE-21#tklvyjh{*>M3K~z!*cbg<=PzbW+ZK zAHjID8zZ)R2l<2R>lN0s&d9k1JwcIJ$f8U)3sHVW6f0DIvJ;-(VSu%>$J!a<7qP-^0RIw#F-V^0; zXf5jhQpER5TYTKJeza|DmD@dgqBc)jpKd>kgnlU!@-Arok|cEctw>W@)yij+u~gec z;d~&%`M?&AxBwN!bFk@1)+{UUa%k6m=8j48e72>m4}@p$Qq~93hHxf#+ih$H=UW@D zN}lvRnVBmiI|sHm7JKgKDat2h98!IA(CkB*ZW!uxCdYfPEBEj&pvpa(Zzi3jtV0f* z`^ap}CfgEpn+G6n=ouXNWTbguaQgr)AP&$G<%(D6=T$zpD*G&dN9Qdou>iH9xzogL v1cq5NJXFyZYsx0$o!FfM*ks+c6F6Cd?{aiylKA>kD}J literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.LCOM b/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..80f1dfb9c7d1d0867ffea05d68bfa9ff1ae9dfb5 GIT binary patch literal 47258 zcmdsgdvILWdEf2@MbU_eEI@>&U|BwaWqAp4DeNxZmX*C&EU*_?>|O3I2!K+|P*~Ui z79v%U@++*`JlbhGO&iIMAF<O^O>n! zW?8?++;TQkJpS}Y5}ij;^`NdgK01*YpNNn5i~h7bU!eX|Cn{X^#r3ln(f!q}bDtKu z_4CgOzufWT$7PnvnG36xi=s1F=Wu*tXrzDFK_w=J5_dERF)}tZI3zkT{);PXXU=|N z_54Kw#>ETgCN2sBWwx3&7o^>fdwQZxvZBaqwAZ4t=h$%%M; zB01F0ZQLe|<8t7|f_>sd(>{o(p6x&%%g%hJhz?R>sa#x0mlukek|^ihsf>)ps2oD7 zlISci7c%qqk|;T+8WIQW0Wo0b3R!wi;xCQADg5QcKmq>|D$-wqev*blUmSVx}l2UAs6X(mA_SlE2h!+Fi((#k8F(Wdv~F&WY(l(aD!%X6BT9Ku z&de83^?U&#)NhwDlSVLB=EenpmJtgBVj=HLFULv?lclog9FU2zMJGSyE)GaYPA}xs zWyj5z0GKI^{-k(JJ!9(mxO&=CQv!dnTxNdW_Cv88>b47ooNA}jeBs2&qPqy_$VZHZ z=FW?B)-J|Hx{zA{FnOuR@;cznxj@(EG0Cb2@)5HamPDtdGz>c-`^~?cI0euU);K3I zCp0q!F+Gh*!nk7$(P;;75>jfmoV*tW!sV3XVwxydrP)6*G%wvbsWluIW>XCY?;cM2|$GEwa_<=}% zCe$;j@G@4+%)5YS;Z&yR%HIMbsymOR*9mk@FBD52M1rppBE`&N5r9Khe#Y$LOv!s$ zbjn$YT!>r9YxLtFBW5QB0WnUME7b_b%C1~)r3|=6DN|l3$X{I%N5!U#1vj^>Qq*cG z42=zZ+=F?k(M{QR$P{An8-O3%K@h8ANdIJq4{%_^^dQE zL4I;|>-;*ninws)Y|&Wny8#xJ%9GY7sSfBv**S6bK=?OSJwLLi2^Uv z0kw8fy}tqmL?@#((GkKI3{kG|fupzCs|#CasE@0$^|R|2#D#O{=IWWMSXtj%d4BWE z*7}9@)$@%VlQhF473hu!H;JgAqJW=W%EZdW4B?#rLR7-@wC9QDpx`kzYA}zuZ6?^mREl2_l{)`cDkTE@nWP&8W@+#|=ab5T=?jewQcR zWnxH@uxjeai$u~s!99)3M?z9RN$)zDu7SEyDbb~@-?>0Ri8Nphb3js(ZbTF{ zpd%$wB9;t>kC)W%gwdmfC@t2-PnQ7lO^qEQL*ASOlC#zx)3)MG8>_=9T|=Nb3^6gNN6DnepA&a-77~vlxdq5yOt}LzRDoxL z=vxdjF18byq6amiWJZcl%}}Sr)`FOr8fGm6P<4>WrEXP(_J=~DaO&TMLXi+qxigwn zl)E#kh&-4*_MJ{C3+kwlOb>;t_nT34JkXfRB0>ka9klj#vzBB>nNIFj+-lNMRXiUY zXp^@0wJfYi=x(j=Z(l)T*B%^bUqN!$3J$ifU})D09%x^|@U9hfwXa}g*9synD_|PD z+Z^;XDbC`BkE)PNrb{s_l$c9fJM7jV9tEh~QONS13=(J&{zJCW|2AL#yxXtw(1wYkddt)IOVUaPGwe{=nA4Rwe{0SDDk1%>Asr#P{r+|#Fg6G=_98fMxvm^M{1}0YwjZz zx1SO}hD34tQ6xqw@mTHjK+Qc?aR(@I8Hv%;$B{Tli9@y1iJCi9aTAnSM&jV<5hRXL z;uE#g6E*jViaSAxE)vI1KZ(Q?B~H~&PuAS2iaSY(vq(&xoWkpL>MfAMV{>a|MMS?LAO)qZB&c zd$8sXQfQ?2ftou;p(lI0YHo@`)4h?Jn?;>&zPHCMM9zF76uS9^x$3W8?xf{sR@?D|5TO6yJO4-4|5+LmdBQ_aTaZ=+e7CqT(On z_^-K-Q2Zm8-u)*k{usx9-91L}$1c75<0^iL&qWGap@4lqspWygka-X31CoaAF zMHN5A@t55xil4gl?pIZOj^kfB@F>g4Hs3Vk{{x z?(1O6NlfK~7txEOorXLdSSlWcT?rEx!6M0mlU&XoBDA2l)Z3w6`n7s3{O;@Bhu{6Z z`|*3A_W*tm_8!FV1HBL6x2v}czmeVuetUX*vXOPndKQ0co%e-8&x8(b|4b-4&a63| z&7|jI%=M;iCxppxx%k5zz_J zCq6931*96}qW=hR#Gn{KKic<{70kP2nrt~7O3}lCj@lRw4Q3Pr7(>r!Fz6-qN%tFl zq?BPEw3&~F(=6j|14*~+BcqECL5W$>Gt}8`igxSiRLh=HitZ^i{bTK? zF1O396?RK+*^h$J51cc|eYagK+RGve`4O6c_+#E0;up0h+IP4p8*II7aF(%4pK;K! zOAd7k!nyR)_Krr>+()$Xb>IW)M2vInwmb z;a~wj_=D=go-67T1a*)=T0T>EwhOpU?gr1L-7-L5)xHgR0@XebA5U?XMw+S8)WVPl zS$Yx2M?g3AKhQx`(T?2l`B#f(RGMmr--4JQzHB?pHDY9 zw+2naNn_NRM%Qstke~S|0Y06j(|F?4IP8|^*YS8V0cCps4_3}s|Nh6H+gd++;rNB~ z7jV8Sqn_Br0r$sovVQ(aBeg9?;Cz$2)rfYSqJT-KpbW~Ew9A=qRSgn!Es#cdt0GBh zd@w=MoWvX+sOC*2z<>_%p|XWqSK)eR6J$Fs(XC~#_}I2Z$5fi?n>^rcKSmN?p{^i! zHiAnhs`}(B>DAhT-#klWJy`d#; zPHm7swx<=Xd%`E`t@@!7buZ-Udwm}?TW%w(p4f%H(~)4*_reWoPJqkT$vI!jf;Ni?BhXg(5azn#{9`pHOY+>l>7Dh$| zJx&xy#{@k}<*{)=kA;)tgAjcdPA)DD#sxi=PoZjh*psN5pJ`MbPb7ziN9;+#&(X=W zp!d3e^OiQLRI4+x>NfNN2te%}47Jv~T1pti_aK;EQ;{=pJ0!W;Iksv@|uM8;I7sW-u zU=j~NAdLrxKZOSdPY(<|g9ipajR%H30}UAsLbGQ!!YMZef+@97w)U`E*oD3rRzB@3 zs?_@=wLa2KRUWKm zd)5H9f8|Bk*&`9V60W4|u+{fq?TAz~^SQ{;PTvyDsD2RE5JeK!LbgRJu#PJS&taSx zLxje9^YSeWs^jvX;y2vg9ZqHcjrBG`;KTUCf8=`rSV3AY=ey_(CORU|p436ma1v%` zvoK_Wa!-_&=O^7*=Ns)%6dhdJ$FHDu2)yZh1IQRVZiAPmyNOlLx%kujkt#ZGR^O1op}v?bN{Y&EBTVDX=Q<*EBoxN1RXTn#^}dzRm3?-^ ziiA_Pbubj_1Gq5#h9w?#wONz(Lx>A9;nS^RD2Ff<%YJz+f|*Cne*FMhUH#BM88KdK z$}&a6iAKSajtIRU0|;$?&q`>svUzZGAE5{495YWLG)AMqk)>~EB;w<~l^GveW51{x z0*`_T>3}W1ZxZ&M^lL*UNI!VD!PfCYL3*PXikT#K|9#^7uv((Xe-ux=Are}@Xp{=u zVp9E+Z#stGP*}fHE(%iwqVY;qb1tOF$|(o60!kaSe{2GpP6AC~v-_RR{|i8@5GcmP zygTJV_2TNMpF4B55@VyRi$TmG-RvWeV9Qr@O^X%)-b|Txln znb}JA!P;8iQe`6xv{=JmcmMvm@GoxU5KQ4Of->}+!{1vfOljYmr{7v0$ISEe^S0H8 zv#5E5^7Qj|s1IjU+pnWUw(kw6dSm+~a7Ucr8%Kd-pbFq1ID*l3S}|pmIEodWnHM7? zehRH{SoVTudzqEVC2d)${svOZtpVxBL>)XFIkDp)5-E~= zLpZNSL{Ba2_PRZYIK275&d)6#u3ld`99atpLsD!PfC6Ry$Bgt%FDwuXymyJMljgO4;?}&&YOag5jGW%or z1v)^?8^tfO#E8(ua3_e8M)2dIvDaqfgtWk7Dnb46kXVvwx<6pl5f>zzF{%C*2&>f{ z32hz(#s4ZK=k6EZlLEE=@){9;kkjoy%2vX!9DVA_zU{&AH|EwVeMf3@VSDWw@_)HD zOLTe8+WsA6p6%QIlZpj21OB-^SMDc5{5s9UCP{T}Px!5;!37?kcUi9FNYrupNX?C` z(NB0=%sWSb&Nt?*?HhOp3V*D+bNP_lWw~8z57r(;Cd=*F{%N-h`SR5pNZ9@#AoZXC zP>&MyA=l+H`I&N7;D}wujSuOl5vS9FzK2nZ^-j4)TV#_2_ zeESOINQqz=6@)#)7r-(zKMCVfSQOSt@|XxMniDl(u^n+Z3yn^L64FhMK%+RJwr4Og z5KwGrN=5kB9-+y(+0}jX{oOzC!PFb})$9g9S-tTwh8~tRfKc0bt9mUDvz0H`Km^{J ztz6&!i%n}D`M&+j)N6FL2F^%-k?K>|=4NkQE@bCkgGq{mUl^spCS?vrDcRZA+(+F0 z*J}=pQRZNj;vgdGKKeRx9IMTeWy-_uF?WD64C4Jbj6d8#_xS5Dg!$%NC3owmayQFN1fFI@`1XVY@0k$M^?9rTFQsC%%R*?`>)1>Fdk zIa1JLSkTnRJXC`vOT~@Ah9&e%HTSUF_l|qSedwJV7zy4UqPM*H0al`C zj3o`D5}6qrX|*gyfm1lJ#SI@EOqFnnhiC+JZNz`*T%myd2b(s^H$u_`tWlE3<3sV` zacD9U$)x!PS`|MIgMy^!&und-+Y-1vD9&tco%xJ7zy8@(-gKT3&z<|!>K5JBxbUfS z$FcSF<)Z-FLsu!K8(M9TkUVeGJ{|&SDw3+OeD`vSP~+`T7<qtC)HXqVUFY_STE*ky6U} zvoDry=lW|eu00dyFfcYWsq1O7l5GWQ8dRpc+3#Q*?B z5|Xo63xqFYzzG*uZop^w9E})-TgcEn5@jhZ6zE0{^qDXZa;9NTifwlZjAX)v#$llh zql<|t2N#*>0vE~vM)Ek0F9PXaV;_(Z@*-Yb(5$cmy8An_&aJPVeABsBotp(I zsb0Uj{pW{H0@@qd&HG+I)Gh8yRe=gXgCQ6};i{BoT=kQe6b|n4fP{!VKMgkjA}ZLI zrcq*dS+QO@#Itw+?}zr!ZR~tLkIDSw`F!8Ea^U^HG>?Qe02!URv3+wMXgQhf?s<>f zMf}_C>7gV$cjFXZADye-$PpVKsM*_5Fm1P|k8C5mz?~x&X#DA}?O*Zgo2_pDO7#Y6 zf9so1ZU0js52(%zDAMvg7^JkVRvNN6FkPiU4kJjagrPt-5KUcvT!#V}NGddS!HMzS z)W;Z;hpU1FIjGN}lPM7)dYpIT1TLtL>{FLNkoC4B%U_)hJ7EbRYx~wL#2?c6{su4+ zAg9}rXbLh(pj{AafWorNlkNu zmv-Jy5+^A(=n8HeY5}YaEzm+Z7}qI7tj)~e6qeSNssBPA^A)m!tPBcfjk?(GV0$tQ zT_S18KwUrhH0;lY@jy)AqOV6>F*#6dKV);}h@I*y^sR)}BT(?~TZ<6F zy!svjx9r?dqONxVMRc%-O?A-(4QwTF5H3Ow0-Y?WR%d1OtAFLq>-PT!DIBb8%Y%e> zaXPRPVA?9usGbhXL*1ym!%jwia>L$vaT2?fNv-}=(9~K=dH4FRR7Ky7H)*Y%NsoGvU3c?%r- zYjv&M0HVAm9;k9jS2;m*V_)e>5eQQ|knlE0H53UaBbR$O?C{Q4H*j`9M+ijqBX$@s zh#)j!{SnS{^gVVQ%Xkx(M2A=xtC3n?au4*v8(1&*qT|Z`l>JWK$VTk$sm~_i%2E{ zs8=cHRB1?s{mk2kh|GZe+{MecndAt500 zD43t5trq$zcTKK!;|S4|iu}NGed7%3zx~lc6oDd<=;viGL&$ zIE<2KCvFjnGfXXZZFNz|2;kA}o)(8N>f+)|p^<2K!zH>wt1Y+=JOnKff~GpYAvurT z@eP}B2AD)t|0`J0%&;lS6ZC8^bn7c%$6f}T7C&-QW*lu{#@YGAC{`&uwTQ!;jfxu? z_Tq2?AoBqv+)A+v<-IfD&1dB42?if zi5jtOun4`E`f6XlEVWbvwRq!Q%YbjnNF##Sqj)G+Gu^aa2H54j3E9Mx`m2(V5 zkTJ)q`rx2hk}81RlP@1E6XF-}h=UNFKft*UXv>2{EW1V62K8N9u3=uE3B8<+(ChXs zN#(h2x_lw~=IcMzySZ!z1srlPInxc$X?HkuNy{WYEVC)fHoyeuL1*$YD-n>r9@DxEsS5F^2h99UY-?_n<``DN{$@KsUTVKk~I#yrbgWHcH z6Dh{grOV&5;pn%WFCe33J@{jYLACf*6U7^YMBR9!jp<*K_l)2hONGMn~>@ z?uyBQ$AzqoK;^sfA!@Uc2XRlpe*#@A+*RM+9}u&_dP&k&4}^FC`e8iBqs$ra{xzmpaZ~psDi!%#)E^S z6iCqa@29R-sykl;vQre{|AV#dU#;G7tnELW5IT^h{+sqhg5o4y%A4&{9bQGe#F(hP_z@S|$T5G#rr)qg}Kr znJHiYMIVE47j{fb*jQ1>_Ck{s16L@J!}gFVzI&!l zwmaLkJ)r5X?SWVjAo=M0-olZqBrtM-pvVCNA_oYD6!<#=LSSi-z=7d=*XQnc5YYR?YfcAb>i3!D;&ZG8QekXihVWu^Yqj6Cs`8B7Qma(Q><4wf3%;@$ogM+^aXoDK*vBxsXXi%1c&ve zbwGvSSr1eRZHS@z9;paD)?q0iXTS4e>4yO7Zp#4-^};cym4J75)J66&S)T4l6}CylO1T3S5fvmpQnX`IYtlgAAMNw zwk(7sSR90A5vgE(O5|0tkN?O5;ujf94k?2zdQ4wmJk3XG^HckC@$R45jB%mzInpq zi#ExMrU-~lQothUQi=zUCRupm;4c}?)5?=o5xl(mmV$MtewqEltYgLM{_0R2GI(rG zWh8{~i)s4F)1|Wp`p(KZS_ljWu3UxLF|nqmI$Hn{Wu%#pdaSdmKwW(@KA(nb1M)x&UdsGl z1K*21O8nl>FRg6>q#%%~!^#quX47~HtT``>Hyd2J7i~7BEQ!6GggOu$*u0p-dI+*h zxIe|7$xD#EnPMR~uNPIhBoE$8V6o<5u`FTF99YkSY5=C6!cmwoE9R&hYPx00EFxqG zX%yz0f+|X7Rpls~NP!zoK5!4VMw&A^~W_%e$qMHOHP?gRo9c)7- zIYKeXr;PG0zMT*wKh3xj=gh>Y+t6HLW+vgA`>6U=%@q91IhEp=eesjMx~So%l{p$j zMx`M7+-TH@Tb6Mqr2Nq?LzMHEx0-WF{tdZ|VM0@H$Rz>L`xQ22S*k)0mW}|HIjB!E z4iau8En#5zM20Zf5PfjF2BR?G)x4vGCG{0Ef*QT&h05=;4jQ3ZvjIN^%OX6|*Uc%R zf@5^YETmBZlf;v17B`}1^@Q=-Rxf%E>C~D)h4HAFnSqxAiJ%k;ZfBTSn8?onmb@uS zi8h0rLb$zYFmcBtU&MBd){Hz7f4OM_FO8f*s`}NClZD?s<&?wW#lA#BRG@2$*{N1E zM>0E~7K?Rd6lF`ZG%brP64mjc=wqwOOARwCucNRH!vf&Ar;?r!KjGIPMKMcBQJpi% zv9Q2E^1BH>g~tjAw9r(L;UQClpim_=M0}>Mveo0iQ4!Ca4-8$qZnDWr@iPLE!hY>WPsNi;|=0 zbOpB}R6Tkk8+e45S5JUyUBSU`%$rorjg0+~EXz1xK(~P|F%>183HDm!h8#8vkc1I( z;J&5+lBdF|02c)f^P^RtXeH_?r){I`A1RS2rLJ|v`a4>q`-&!M`FIL$%kXK4B{pQ& z0y3Qu`vN(?skTV^OMv(XN_lTA944qLzjsqqgjc^TYYN}G6Rav)g0@5k(0~j;DJcWE zbteNj%#s1zvm9ltr>2+=k9Z7{Q#|lA5_%^0)Q<$p)=P?>_@ha!eiF&00*dJSGUqa) zjRBXOnRz{_%**{6B`P>T0^%(WSBM%FY<0z)NUf2k#G7zJFoRDiMAk#`Yf+UMqn5PJ zh&UzL8r3ebLFODT&z~ z@uL)?m05_AC8miQBd014eXKLXAE5z7Xwp}io`D-=xla$|r@jUv0zKsZn@rvxBykT; z)*PHs%OiiPZ#prWo&qHNn)En5DTC8>Zmvo~kSmn4V~)9gd3xlWIw&XABkmr#@Igjq zv$O1*3cCQ>UjmN_qEwm=BW4LDc;6{=ax&V-p$?8|OrK9c8xcB&%lhnvhVJEGr8BH+ z&Wp1!({aMH;Wu$=HHTvyI=I4>6C6_h9^as&b1-$q3b&XVZ!&xCtmuRm79UaV!%8== z-DfFJQLs`Vqk$N%l05G9RQk{LPUq+tioRQjw&}J8f4-2zxI<6QeMM+C1RE{%82_v2 zu?%fmey{^U8lnEf!7Ki+genw4A*-N6_((()*X@-79d6#L5bnxIOF4M$kO2U|00++5 zjJI*)1)#v0t~BJt;oT{+=aFv!&@%1;swA*301fwZ>C!B&-Ntc#3*R2N&KE@)NG5F2 z0U?2d;7@e9BM#s|esbax&cZ_G z*Rxjm?7onCxq&DvEFBeHU8i$uKDh>HV7`iBPL*(G1hf)>ihRZ4w3~z9DNdHoUlz&v z6jJ3|F*8Hw{py(0$(QhrOZjC+pa60$P8Z$zsgidj3?KLb44_XPh3=`=9kD9JlO5dcY7B2gmm?e5HH((SQu+yh+WO6AOL6J9C5k3KXL>T$th96nh z|1!+*;ZcK(5ZQ?5PY+eQ?R~g`dFz#->eKZ2aP=vAypJ+2cI6hk=ExbxRnKnmcgYdQ zf8)Zxa%h7KKXB`n{*9-p`d4}vd)~}m%Uxabe0Ka1XZ_7X8!Nq)&5r5@CS{|#vDraS zis1Ln4vxoz-z!y4uWni!6{I7(Md?)(u<+cpsug<2lk+3BO8HP*g`RY)bh9(N@jBlx z-R#I#WvGgq6JDs}^+StYmFo3(s@FFv-5vLBkUO5A< zl!S$jG8ReF4RmQYlEl)GpZ`l@0(2x9tn%H91gxv++IE6nZQ%NBMtWW$i&yglnF&~R z1>Rwi5O|049P>RsPOdxr`r>dR8GH}c7atAQ7l-|RAU}-Z1MgTS!S_IY+9W9niqikW zho;Z0Z$7`ZiVy83F%CqOo?ls6J%3)TpA|0*O^FLz>t{C4Q!;#mAeryh)6IGBm@@Fq z9~kA(H$nO48Mzf&kikLT0Ea#X0@#tNkbOVy8BXHyb#==PRP^Sn|0e~jWlH=K893u& z{q{Rnm~wpyul)WWD4uQ*^i5)lUwxb7@h&ewhPHnWU$nr5WdE#`Tp-DhlmZ2)J20$J zeWaDkF+?&!703aX99CdNs_SSD_Km=>wF)5@c@Hz1fdPfIZS*J#`@{2$707>`$qy=2 z5h}rzZmI>Hf{P6hdi9xCJx4IS(BxzJlYlFh)NjPHnglo~4XJ8~sp)YaUT zKp=zW3(Z@*LstT33qFRy5<2jCRHJF-N#`&jEtVGHEgpP5fv z&>2iT*b)BXt1(!*;EwOsXpbF=rNZX}xuO@LAI0TvOFHf7v2VWeEX)V(-kuZS>sAV3 z`g?o-+Rfhm-rE7Z9q`@`;_aaK_5j`<@ZP%c*5$oL@D`!Bw=J^MmDhJczG`$8{}xs| z%m9_AH2^g}IIcW}z%P*UsixhmX`gCh3`CUOt&QpcoDjM3~^FQAVw8~d_E-|vlx;k zZZFkccp+;(Y)ml`Qx@(ZZLnjQ%?ECMp$Oc@)p2}H`?c3Lc3yeZsiZJBmp>q{q%L6% zejToCWVZDP-%}+YAKU*PR6$>k(O_o(9`wy1x@gC85#$DlMaJCvpH9}J*rUIZQTQ7P z?a|-J=3#O;LL%PTj{A3jX0UBkdN#7;HC&KLF0Z=+I;>6kY0v!E<2nnrMEDHKvWM5) z=v1bF(=JH%>iR%JedC^25kB(E-?QfzSo5aUP5^#}Z514WYgH8-^*>Y31;&&E7mVjE z>wX~oX4lT;4<3N)6rgwM{olxz`d0SWATopa0&2M7)VC5@k5r2bxVyVUce_IWs9HS9 zFF&|ZEOTJ12n0fgs~cJ8^+WW64E_r;U9D2eVi%I^t0@X^*wyQV-}4-j-WmxXSoD;@8*kjWghZhL_hpb&f-RM4?kLz2mUwkwBY} z9@)e^=;|f>KCqm7=j!FvRG0`IE#&{Y*>&^P?(F8y?{Dsq`<4Bh_hm+EOlomOT`=ND<4p&F(Vzif-0lJ?g>%b%i{lu_?7;obeDIoz=%3s=_o?%%*qqlpL=NDw5|w`B{!pmVBl0I&ctrl!o=4UQ}k@J(+=^VzLTYRcWhRNd{_TTbl2&;xa%|)&@NW+aU6nxK$wXw2)ZRNlwDZ^;L0!o0} zRBUqMe_FgPS#2DGJblvs^8JzFD7&*v9w+73$yvCf&nnSZ$uS*ts|@WE#qd|f?E%l8 z#<_=gm(XuHiI#5%`t>xuymjW2t6S$+j|m+DeZMWljFD5uCfJFub{OFJTQ#A&%ex`w z5KSvSQfG`qt+KnD*1GoP+|q@yQbz~^)x$Y*DpZl4xhC&(JjCEh1*Pt z7->@)gJH&+q{in7S)m&iBn}5Pvy%D0I2ckswu3( z*qiI#Ti?SMtd!X9zzoo#`*Lg&*H*Gb)Jg+96pv9fBx~Xd z<04!L*O%;hMzE2fNu+D!@# zFNM1?@Ce?1t_B>pH8g^0UK7eS@ifqJO2`@6rICV*vyqlSuTS+GDpJy&fBsf|KQ~eI zzQK#bBd#-1gbIg4!#Z)es1t{ap!$2H(mc0~q67RSH{EQ|5^BeoRCT)%PJDN}vrIR1 zm3N82hK8Bw-WzGfb79EVjPo_^VLdsVJolN^t-UfjxdCg0;aH3Dsrel)v_li5xO-BP%q4sM&R0gZz+M_vCIfJG`EjRmdtv9Tb%vGO) zbJ8%(+Z!b@n8p=?U5__R?Btdzmu~>U`X>{| zgoCf07Nfr-1xx>&^)ho25kkJGZ!3{tQNCcfh?F|xSPb~G^t#O}3_h!hz5>b8m z=8!0^t~|eW{x%>%!c5~*H}?;uHqe_{d@>v7MQ~sv-7ak&!?$(B>mLclOV6YTY#7Dp0Ou|+1K zAKyH8_W5Ve-{#^NE;gBvp!5--RNsC3l!}@N4y=(vCsD%)&;+q)*X2Po za;KDv^hAwJqn?HHtrJD5?r17}ve8l;PcRe5>C!!#3ctygQ_-G_GidH$D(;R_B|t^$ znK(=o2q^y2FnBoGJYuVS8zL385FA$Hx=1ny$I;}ym<*%AR#TB|p@)!6!>C}7R0^Ba zyA-Dq&1e+da|S2El&0=vCVYC)a$O|l!Qs8(;5;fd`7P(7Edw`exQ)rUL;3_Aca!B% z&$mtTbSJamlZw`}z>FIotGG7{!f&zVEVO0Z442>{-i=MrlDIq4)J%qgAJ5>5Fi6vV zw@sQF#gQhYiCH$RtnS537!9_Zh_(#ds9=w);qK+9rs5MUSc4N`lBPSEiM@~}X4x>y zzBg0hx7czn+H&kWke%*AbZRO&k&D^@r#4B`oy>wyC|Z)HA?DREYrHqJ;J4Un7KYj~ z>pKveXcq32H0cj%)XPk;uWA7gx;)!X4Ww%flGjE;G}PiSp?Udw@?3cSv!C7EvjSb6 zP&Y`1xEo>On`!%??G0EDhil}@>_FZ@CMpf9eV84ckVG0^K`O>~>qm90|t`{wFl==0LsaPkwLTL@+!yss*15oLk-nRjW z_NF;Q#K+6HMBg474IN=O*^9T`jV5T?Lh)S($QInId|QfdZ4K8bv%x~z2f*K2L&V)T zMnf&60e|Gd+R`-vaFGB1P1(}5MNn-IP1b*V0Bs9X1`S%aNvf}=HGG3c zY*^YL73~i-q`grS&>8{`EY@K4?|S|lmGw# literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.DFASL b/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a09c5be364221e0b6bff233ba755b5dcba9a2822 GIT binary patch literal 13986 zcmb80+jCP%e#dq36*r8{_Rcb-v*XDQQ-caISn@?SH_Nh&1+pY08Qa_q7;J2?G3I_5 zV7Lv4i!r$Lr8JMpYf_Va$j%E7NhSFQ=3#TGN-DJvTl_2nG(nfFu=$CAyl=`%AEQ)9Eu(--DuF3dHboStnyKYd~L_*nBvncsXZ zo=xO#Y)d9`nOHg--?1y&lTE~vI|kyt$@ob5GMJC<*}S!7Rc=Mi<)oN?$Y6)##^}{!dzK^Co z9?vQD*WmFqHF@c}-s5TX_`Jneg*APNWIUFQNAt41>6p(`d{$@-VJrkT7yEryQE;!?pl;ZP3UEg3TmQSQp#Rcyz-_Iqmu{YkANX3K1mDT&w z4U$-u&csu`I$5D6J(!osYMHF>O=RP$vahMQP(?Yi9liNzPcmLC_@(n@R&6F4+Y{Xt zFE03sFAA$Ayqqy#EHn+rv+3brEIlxgP6eq8iiO&x4)7KWHP=!XrlxLqzFG8qtUW-s zOE0{k&tEKkDql!e_$L;gmt{QgE5rUw8dgsh<&x=WZ-cz5l}2Q;>5Ttp^5TOfP3mRY zm|Ru4c&~J8j@;a^qJ;k!k}31nEaxQ#;@R8>#f5sZ@>QW)DPg_7sxP}ZCmm2Njm)Qt z()O~Q) z6bPGSt4X$*WV=arm}JBxJ5`ceV6Y*h8#20~6$OlL$moWQZpi3{jBd#2hK#OZg^h05 z=!T7Mctu&G8#cOOqZ>B5VWS&1x(3i{bX$#XtI=&Wx~(g!8QoT++iG-Mjc%*aHMQD| zZky3#J!{~Mx-43JMVRSo;ZimtBSiv>A9Y)t=MvQL6=thig#OOwhZp7$DjBdo}Mpj4| zU7eyq+i7$=jc%vW?KHZbMz_=Gb{gGIquXh8J4tP!MovmKc{NF*8Jn;LA)2OS6ZGsx zsVo)rsriisO?Jy^J0s`!;!B!< z>*Y!qP0A@Xce}XYml;(w)$8fFjwa{)NG2|``9O4!TvE;I?)8?} zIsb?FgvsT)rYAj^>djQkWSz8JIxaEbt;eTcFZtkEp*EL^#}d&bK9y_hyYt0{k{CpR`Nfi%|ZS0mZ(@*y#xwe z4w&`dyVN?*%Br6`R=x7Rsv8}vUVUHHfDDLDi@rwLx4${-34PZc?U5TAxtXKwQBxom z&BywK*?4|1n+j%P0op0l6nB-^qYf4Y*TV;~oEv&fWW6bn^S2ZrQ9mwYAH+r@rf% z{JuM?a_eO7v8p%6d~c3<-u%s9%W6I2>sM7k$;$%FBnHmMuI0D>IBsysG@vFXpTsaBh@dC?Pyc1yi)|DxNcnjiJ4_V)Nx z15MNZwMP!M%`y<)>6)tb*!(kWX4ve<7qUH?&@M zNc+(G$?s)aH2HlJvUX^lyc9$0n-p{HkdT+_ht@Uu>*(7ie*-BE2^lvH2>4cGqpu#H z`|4!6R;FuYx>}~IWZEy&vO%&#Hu_|P{0tlYtK{bz1kl1{@8~UZRVP|PX!#Xd_)_aa zi=Is?ST>Y{q#PFIKrnv(E%`aL($unVCs|$3eK$@e6;hKWBSwq`gpzT5h^w%6whKmZ^ZVhgC0e1)tattu+ zSI`b?Xom|lA`s;mVXDnvDR9IZ9B~163gkG(7`7{Dr!}3e7nG;2ESsMRp9N`VCs{1&ygQv zhd@k&3k`>}!#)MwX${@!0^Kcej3dQBBd3IJYiPF%G%7I8kz}~3 zpiygR)CJljaE)V_fdagQ9&2ci3pA!f>?y|yhGPmGvj)dpz`YuLn`1@~j7JLIYYp#p zfyV{n9M>7*3L3YDQhBGi?GqT*ar=a@JsEAMFrnw4d3Mg?-#hC z;kOy~DsaCwxZeew&>i@kV+X@k1x{FlX`*uS^B#dVjy(*t2$rzh8cK7C6Le5uj$=Q= zVFle|4c+4cO$zMd7-Bf2ph;_J(givou%F|&j)eOPJYWqTZ~>CV=a(z5!frxq2UV*#{9^*= zInL+-@wEaUvj)?))(L!EN5OrLD-5*dEaA8{__z!Bgg~nv5ce3)DDVku@Cg_2n80=o zp4aYprQl=MaGI!`+;LJM!*P^>R@V|vT0`l6+6j6};5f%thARqs${H#k6goo31uk&x z(k>_{@VGU2+yy+LBjO=Pj)5kS5+K ztTmkO^_<|-0+%)XIRkC$OPIC>)9(yU;29lek2nSy<`j6w8a(3yJ|}RLql@9Ff}XR6 z(yHy$+F5}fjy?w3wUjVx4W$Q5PSEoLd5)~^v|9>%-Wp8DHJre60;f0*Gtk4e66UO- z)DKS33j$X;PBYNtT*3uwDBUVJK`-ejc*1c>yWxp~U$ll_bb-_6{IDs*#&$>pjU&RF;K9VaK#!-tBjMsuL=xt>}F_H(5u!^ zdH~`Cy(Tch(aAvfVK?gqzl2dPwR7{!*ZiV?xL7Lk0fQ8vLaTmd0__|T2AYJlz`cqDX#3`7#eIQ( zj$Z95>Od`WzakNOIOrzwK;QsJhJo&%wZMal1n2>ao4`YXvm6Jt735Pb@~|Qi8nkXA zUkg3(IK~-vEQ@?ykqF%qx`{l}A`2XI40KzeEqPRt2>pWLCh}MyqQ}TB?Xu^~LXRsF zdi)-tCjxu4&=UrFfUT`5R3t+8OitFc30&f6W1!Vv!=F?Hr)`WAoTihf0*5$S8E6}) z1)f$UKo7;-1fB`ZaC9)x6GtuZtReyW9oJ3ZxzN9ObHo_v0ihOoUXcg|h?~f~7J0>y zW}wwfi_BLfLbpS1A}<8GI1Vs$EepJ;NPwQ)y9q1^3~-!cpywspf`y6%XwT{<@KWFi z$9X;IXz*x}mlcW7g61ajN??}bO9uL>PYb-NNPwQxxCtx@6;b!}$bQT~w~tzAu_7V* zdC^HIED+`hGj&!*9_DM1lVN7HJS!*Vgxtj0vEbaq z8TnSk@ww4SkGFgZ$V*2CYofio(}~p5p)rZ5%D2$r+C@*p)Y>UFRntJHoX9rczsr^_ z9U$_m!&!7NPRJ(cKUt6tG0HzO-BkM*Q_Z&yAFjrS)lE`|%T^{*yMn#x*dU$6jM9q< zXkJ4Hzm!^)EcC%rq4KGEG|R(nUS6bQ@6wdFT%c|Cgz@Y_bylk2Tn$&HG)I%J@&&2xU*s)t<&5b)%CxA!Cj_p!*JU z{$ScA&5_0J%=x{k_LeyzZO$K-%?Xh?ephRL9F)?Usg*&w+&i??z?dWt8ZY|mGJCTs zwEP}ypyRQAA3jqx{wPO4IXbJUA8Stwl&gNu3vijMo%;3Z8>ZT zAIX@U8J!(HGd3rumVmTS&obxbdC29SD4)gk$+u;y^=WWbAL{?tbVOODeyyowmwE@P zEV<&d(c}K!kDp#>s#|)~C%1}#etj0$@AdfQOG|!yM90PHEO|Dut3OYt#pPQ`W3$tj z<%?spGt;x9a}(2NWxd+Jr~m#zwprFuE&D5aAE#cw=!6Dp^&0b5kF=s(?l0w(%9f6& QtGB8=uc;lYe)!@40pk~rO1*h6Y&SpTl>>fcoNbhkg-x&PqH zozDFSyE~l+U*7-9eDY|g|Jh!Ddw0jQ{&;VzxVt8=R2m2d*yrU^Zxdu2Rpm1 zjg4k|H0~XY#?_#%%0)Fatsv_3XLTpfO%U~h9RFIT-5N}fXSi!PoI|i^{5(udRz_1)tUU+S(Hb2zy58|+<@Vv^F_&qvtAhYg0N*;_rCh# zp)I|2VMvD0N0W0DzN)9EW*64YBaFoxL}en zi*wV2@8`3+dOn(-%+GC2oZHg$Q06d&gJ+#QGu^`0TzIpLt1(wa8JD}BmCv48t1DMg z_jA*hhMKFZqvNWcZy36GG8rsJ)5+YRQ5F+E`Mj)0<^H&uoAV&tMU|ZgIX=$Q-SanZ z*gV}dn`ij{V)IRd12m(thfaBNYL3gfnIBH;MODwt++MN=x@7;r|8CPB13Gl+$lpWy z9?>zTV?xK2ju{D-n)V*D5R!$EEQDksBnxzBL>3~l5Rrw5 z&r=a1G7yo0hzvwzAR+@S5|f3PEW~6XCJQlHh{-}s7Gko1I6={3vOpITGLVpggbXBP zARz-uLaroaAt4J1SxCqNoleO@N)}SGkdlRzETp88@||QLB?BoLpc7e_L^86Fk%f#b zWMm;D3mI9+_y=SmBMbC3ry}HJASVMk8OX^%P6qOnRL}=d0bqzdk_A4Hg@P;;WT7An z1z9M_LP13+$Us2`iURStph%}6zV6xnGn`Hq zgX!#yzgN%8@s=YTb*1riP>#`c=1p_gEH>Eqte(!eqXC4Avsq<-d|Vz?7N4DJ@_bZJ zC&$%fv7vfsd9<;D+4*={4%Kz;!Ay1X^gKxI}`?sy((Z!D& zjbE=Ht~c62*LCvdWHfHJ!48xT{*8`J``O8KQJMC9Rt-kwnEO2yVOpE^{`6!rgd2Pl zF~PbwuNKc7A=+G$Af(^iU=|#?)+}9Hnzh6cv-vG%EtqV5T~S!NBu4Rv*i3IW39j98 z!`W>&fQTrQ1z_3jc7tUz;o)TFqh4=wP%Z|Cow{0_)RWFZJw4vEZ9FqwzC1iRK0fOl zOzRHaNEZ)GXin{22PQHUhzBM%FVN)8wL5E#(bh+6A3S=z_mc)fz_z#GcSD+-pezA1 zg0&ac+6YA=Ya@uC!rF%jpgT_+4a5!%C1i)ZKqZIt7rwA_7UBO72Y+$t;L*j>MJ|jj zgK|*{6?&_6SJ@F)n5}hNPw!Ny$XlVP@oXr#n262UyA*0!p6df*!v@4w|Mg!H6x%;T zRB&*t9`}FnYJct3e&gl88f`pCCG>1;L?(>XiO>X@IuRH|tL+t|2{MF9IqobD>*=3t zxTSQX!6Ti5H;DO@Pg5A$+(Kd+5VS#Uu;lX^w+kx@UgwN z)yIdF{ME~UqUbs0D##tIS*Y2Mc$vE_!)%$%tSGOj{t6Yg*8lr2w+{dFkDo(zjq2vr z%YUyoEPWk;DG?F_w)T-nNr$v)74^-ou{1J`AKEtfka}de%$_dGV;^2N(-L#DOLG=E z&YZ=IP1+no+*upXPWr$kPA|N3r_p#aeEj;`y>;8=KDx68^^YGPUFIZ&A7XF%M+#2>@qZN-XxD}5sxEYTwR6Du|wDvd! z#HhqR@K=?(H%R@4g8fD*CM+k0f#JLnA?g)CPEtiKO5)E?K_H%=PE-&WCARY$(L?w_g{AE$FkVR7+NFEVrfxsO` z5GVvx0K{$n{1gBd0zgbzv7eD5AZGCVi3$NR<;RtabdN9&0G->gL8kP zLO|ev>lV{TEE*~TA~*CWDg+b&;?*^4rV4-<9sAQ103uIdNAaGUMGFN$%n$k#6#&{~ zkR#V=Mv8xUzWURY&_#=}CIG>XW;%8~63|ZF@RXbo5F;5^yQ}FK?(^rU01(4`b`;4T zYsLzISia#;bO}JG3DB`-uK0)P0B@RDZNimnX9OvVaE3)g#XpY?D(#6uK1*U53QH#H ziH4H+^HTtbfr1ki04556;G#cK0U-K4i()kmds-*}A~W_|stoVloTK+_(zaSlA zQN%EdX1c$41fZRvBIshRnrl!2V4whq8~u4I0K}k$MS(i@G*JY^YBz79ST4t&7D7Or zVbMYn&|~dN>_AOJPDi}IF{2yFP%6ad;61w3UW08AAC zkr?_D6#!y1&!WOVg+IiYKS{wK(gBvlpr0!@QvAc*pg&RJAKrhkDBgImXr>5=>;6QA zfLPV(Dpv@Ig@h~bB=GvcpQsQ}0En?JI~pqhB9HK=DSZ@#XGhVtESl>+>JflggUc+! z^bCuFbSxSw0OCe(o?^8xi`ra}Iw{VuXsQ6{(NXaeqcE1l>;_9l%1@NUpPx$r3IXw| zltl|gK!DMos1Oh%LiSVu7%2cEG4!V?0K}Rm)`XYrXr>T|p|L+vK_F&|oTGw3ML^62 z_|p^uVqrdOVl2###)^QLZ1yKA1Vqx#qL}Vu(OeM_Lq~t2LO@Fh9_$MO1BE~=k?|)g z2*gT#7Dckho+b)`$X@)33K}59qHvi-3ylVk2(+mmWxMvJFy|?Pz(^s`qo#fBOqwDPIk%4w`2#Mke>O`Gpst}0#ytSy!6i5?;Kc^`SR0za<{xk)FU^#1IZ53B; ztPqH?u|H8kAa=8`D3*G<7F7(yv%sIIFc70(76lAhG*Ar0>k)sV!a%&fXHg6jSu{}$ z1UdYP3Ij1M#-f$K#)lf5a=YbJ`rR96VT=*~x-;Ve$4QHtO~=L3lKI+BtB$AhD^5Z-R*1fAt-H zJ)90s>=v%lZluJX)q8v8k=s#vtBZC){1q-TGOu%yek9|gD_mrw;>xuy23Nay)vw=l z@$vU?@oEnl(ARlre{+L_Wb#)3uo;c^#l6vlSN!-*_x8Sf1H#()iUz!V6dYi~1@E7w zEf;~?F-L!dZci=tTVbok!#_OYAWrO_lUw|U=&cnHU0VTf{rZX;z)o+fzFT7$Re-IO zZ*^0CFx}9?ng(yTlHH%_y5qGm9AE3=Tfe@-#Yfh~Yj-Pd!ZAS;Z3bL2YvqCzu}zzk zY~Qg{Z}z|2W2y_NH)7*P8wavA)a@qi*b^#rulm(hn@CN&haLIDh26aE_VV{;<>07% zioKnu18iZf4&?9V%7*@1#q74%di3;gfnEK)%l_W9o=s~)Udsf9T~1$Mp)N=5{{T{Q BaBBbn literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-TIMERS.LCOM b/internal/gabriel/benchmarks/Medley/GABRIEL-TIMERS.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..dcb5d18f9682dff1f2e87da4f9a04ae4f53885d7 GIT binary patch literal 12280 zcmdT~-)|dNb|xujlVxH-5(L3Z7{&z~JCu-dIQ%7wUMw;qhtf#o3_UXx?ZmFYNVFxJ zmRyN)W2{y{@(;Az1zNOSY>R#AW9`Kn*w{{pKK7~IT|ex9u^YJW?sx8;8O~5cS#jHk z8ZtS&Kh8b(-gCbDopUEuQLCD+N>#0s%Q(5v_xt3%X8cKOpSyEXF zZQbYOlCo%OYArcC8&7Gq67?^mr>$04QqD-q!ELEnWOBNc&6ec(BugbXcJJNa?shiW z?hZ>b^!c%BYSvGFSktUV*)Y`~IU;{#8%E7?e@V7hS552kjVtrrNtwe9`;8@qcQHt2Qv@@3Irv)$`#9<>4#+B>&9`-ij?hrQj>A>#|#)XTPJ=oT}Zy0ob3<>k6! zu3EFa+5NrFgYDe|rxVQq-IAH2yC~^wDI=FMg(M&1J1%fR%-d`zSFh4&&VD#MfJL@g zid3BAs$983t5}>DcW}hy#Kik{xbZ@f7&d$cxz4qQ+wtukQ z>+CZ$zt-8?{hZO}l#;W2(n9u-=t}3-_Re;1dv|A_3-4`pm@o#`dw9R|A#3k!GAi7p zhMhgP(LGnHW7_uhhH5!I#c)+`jpJ?`GP2o`%D}>O+cauyO))ic4a-s7zZ7gvsnwjt znqv}8u*Y_9v39r1)%?s`3a+p-vxmC}A3W%=?rwXtvw1mGY+ci}db2Lss%2XwxsFBr zGZNj~zK134?b5=tPJ3gEVTpSm(u%YXx;aANaQL~879eGvjo0Zw6bCwrsb?jMJ?A9Q@v3lkFLPR%SPimhmMM&t|_&T9c1O} zUNayKMr5(e%ytAcOrs$-1<*^5MuO_fDh?Ikv8u0WrlHfOa`*}YN_^HiJ1o_fDn_|E z*!#p@J)LgaX)77=>1MRpTqLR5KQp8XF#y zYiyV-wP-Z;3M@fv$nj<@#dl)3g6SG&9ZvyXD>z$p1Jhhm?PbMUc4fJXN~<|HSapfo zNSvn3kuB23HJYJ4<0o`wDKb`{Fcz{ZtYm4Qs4SmmB~#_&I=^XaIs0+VjI6$~y2QUn({uOEQ zI=TlvduTwcgR7@&LPG60^GhL9JRA@Usq^`L@T1P2cq9`0I5zpkJIm3pmSdkppRL56Ynx+#9lafiXfv^)ugNp-y%ULi zjXLpXOl>6+yOBsFkw8IxtCrvo;gyL58YhhDU*{m>8?@24jA<&OzF}Q-R8l?u8#BKy zqSyL(9}SK1Eo0`Sj%YCGc~114;5{d{jB_XUoEY>B(`uDEZzbNN87C4GkyJKaWJ;r< z0_!rFdA0-_RO<~U7ZwK3a^8E+c}-wZnc_SX(2yzS(8Ok$A~sO9t1MF}xK;U#`;;S@ zXp}2Bjj~zrBM@JfffhoNypZ#rWZqmx$i`*L^LeMaoR{53Syu%)D^!rPjta88;5JXE zo#sVXt74YRF2brv-Few*ns>$JbF9&{mUXqoFc@HPNoN?Vq*QIyWLdy2f0EQS)x6F! zS>Um1Hyckt`-V@5yTj77(O7K=tFV$q2RATdt=Q=x$NTCH`Zu6i1W>+*){(J(a~0SbJl zhJ1rJMheOjp`ry*EyelgHacoP8llTVQGtBPM$$^o)! z)n*lKEhA;b7Xi0rn@xO~+8V2fuSL^nA+TLEt^=%tqs)23%rVgnTph*|%xo#?bXum5 zjK@x@pdiC=$|7$?qLIj*#&`glLS%Vj2!c43nQQ7T1iunC!&b{S&)PJOk3rt8IqYYy zTvHXj*&v2jN7e;ZRr01etgK#9%!*`yCpLvF)L@N}#z1O_$A?byEcPmxyb)q@4iAt* z`sA5E=@)tRE~ZVi>HCpLYX%>}^WVjETl=+t(o{+C|C(}Um5Rr&)!*|=!29Q&_=${zjEn8w3&|Ixp! z270ZI_v^98uVy2uOfJi49~3YetTYzUq|60^RJpj|*2wb(MqwZUpGbVj`9Wo-;I)%I zVW1n1Sg?#ynJ7>-XPZD5Xl(2{S(DL%If1^(RMx7RM!jOO0@HNKNs_~*<$16dVJP5v z1soJmuEK2!zq3R6F`p;M;8BhT1XCjmX%=KL48+REk39atFm#Zvu!1Mk!+Lq1w8zm= zV>mi!a>(>oo3&b1hx#B}3oLnbQGL+v9<+Ou1#92xQL5ER%JH1*QTym(5<8I(ZQ6Oz z*?Sn;A)loV8stGVE(MPEDU-&f#ov)nt$D#4u=jx+0L{LJy_(-tB$qP*4=uVF>axSblh34K@;s8Uvj? zOoO@m;EA*Zp+CMbqM{f$`$gG8m|j@iG@El)dk(95_w6&WNM|w{xx4)B-?S#axZ9qT z&vawU-~J2;^JO>Ie%c+QnyD|lW9?_%Gt1xpbnDCRnfCM6H1=S1GWI>R!xR1pXzKXx zx5n{_V%nZQ9$Vvtlq=3=rE@M4ASgoSv#DAVE~ab-e*KB3{IYNy>hz@0_uD3i92tRzFYjA9EnaiT~`G7j69>bN|@ zB^uLq_IvG}jY0K%j(WJ&Yn{D)K(*UBPNwOrws9}#)-fa_Xsq2^y}xYZ4tA(3%gKT2 zKv$f`=t?()!`*N&5bBFMf1hE1^xuUH&Q*E};`|%Y%y8izCZEVV-<)6)cd!T=fS1`} z79fgYU6dLbkN{Df4`&FXvcQzJB_1xi!a;Zf*D<0U;5?MfE*v`%K$C`+RcM{zR7pwa z1i}GQG7O;6tl1Lc3RS5i%XszO_af2OrOCf|dwKJhkE1_~ekF*eMzF29ly)QKdp_@b zzTkUK_@0yhD8#gqB&T)$pL|m9w9bRxzJKTI=e7FFUo}KcT^sOP&EvJLbBT>}{nmwG z_Y0ifK6|>d`ttATyji{b;@PABs^5L_^`n1nC4y}e80s93pDj?~KYwyTL;DsJC6p#? zeF#e5UyfaS{Aw(^KHfTaXL9PSF){Y!2gcM?>wQ!r+;1^_Z?L`|d-P2d#F-emG5*1m zu{$q_pHIZrCm#LB6b-U5M@Jpy9+9&1A8T2#T5PL#IAwr}Zf+9C8}aCiAF&Lj=6HOV z0dSd=8$+m?SB~m`h`eh$}c$S}yWmqp9?%z&7XMA@S*ep9?q` zpaEFJSt8O6INDWln$N=q4GRZa3V5w78m5iM*N*EAc_IWiC`_xBJRl-od`v%L#zB)n zmj;4}q40~BX2MN_*YO{t=FPH_^2HtG+8x5Vwd6p}R!1lEfE>961T|5@ydZdCge{P9%F%%g?6dKtIZBPDoe7PHY_H=b~<>fCQM_zzXKHvTtMc{eg7~`8d zmHxiJbrTs+Dix{J=}lvbDt^}o_^!|JnnZv7T;E7+8t16yKl^vr&r_}Vn;e^j2^bd) z;;|aOnQ5m@nqMYlHz$!lmngN`JE(S5zaV$tpdy1CD1 ze9vd`EH0Pm{<@7OfBM_iyMJguewAA7#$J5-_|*(A{5xY@lp5nGULSw_YT7BE=H+w7 zG?h;e$`ej`g31$+gA}jGt=_nSYioK_uBu&w4}%AC3-lMtF!1Ar^F={gIbEe_hVEkd z3(b^+<$N|+h5JJ$gVT8_W0#a7Fy+mG3$`U0iz~o%siIY@s)@I8Rm5IAQR=w`-GcKD zP%=0$;+^mcOp7Y`yGQECYheDQcQ9hNGOpQ^ zYPWrVA8&Zmd#T6>!;h2p_B~1))7!yEpB`N~D&Y_5*$Vso=q67Uup{f}60%Y**kaS% zw-kde$vu@aX>?!x(f4p)J(-SueErFp<%#Ii<;nD0D}S{aeO7z&HeS5A`Nis`=dsw> zlRws{V8y@DVvqh1N#)Y4sUwf$WJ#bl77oZrd3=8E1Yc03Wu=#lc%H`pj`?XihP?#I zQrMN?%k@a}IWO1KeKW3H-QV#+t~z*4K0;A?bJNt8mhrMsQoLYY-rc*uD^ly&iv?^X LK8g@V7sdY#(7{XJ literal 0 HcmV?d00001 diff --git a/internal/gabriel/benchmarks/RUNNING-BENCHMARKS.DRIBBLE b/internal/gabriel/benchmarks/RUNNING-BENCHMARKS.DRIBBLE new file mode 100644 index 00000000..7490cc6a --- /dev/null +++ b/internal/gabriel/benchmarks/RUNNING-BENCHMARKS.DRIBBLE @@ -0,0 +1 @@ +NIL 2/296> ?? 2/296> 2/295> DRIBBLE(RUNNING-BENCHMARKS.DRIBBLE) NIL 2/294> DRIBBLEFILE) NIL 2/293> LOAD("arith-benchmarks.dfasl") IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>ARITH-BENCHMARKS.DFASL;4| 2/292> COMPILE-FILE("arith-benchmarks") #.(PATHNAME "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>ARITH-BENCHMARKS.DFASL;") 2/291> LOAD("gabriel-tak.dfasl") IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>GABRIEL-TAK.dfasl;4| 2/290> COMPILE-FILE("gabriel-tak") #.(PATHNAME "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>GABRIEL-TAK.DFASL;") 2/289> COMPILE-FILE(GABRIEL-TAK.DFASL) 2/288> LOAD("gabriel-other.dfasl") IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>GABRIEL-OTHER.dfasl;4| 2/287> PWD "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>" 2/286> (LOAD (VALUEOF -1)) 2/285> COMPILE-FILE(GABRIEL-OTHER) #.(PATHNAME "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>GABRIEL-OTHER.DFASL;") 2/284> CD BENCHMARKS IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>| 2/283> COMPILE-FILE(GABRIEL-OTHER) 2/282> RUN-BENCHMARKS) NIL 2/281> IN-PACKAGE(|gabriel|::GABRIEL) # 2/280> |gabriel|::RUN-BENCHMARKS) NIL 2/279> |gabriel|::CD |gabriel|::ILISP/ENVOS/LISPCORE/GABRIEL IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>| 2/278> |gabriel|::CD IL:{DSK} 2/277> |gabriel|::PWD "{DSK}larry>ilisp>envos>lispcore>gabriel>tools>" 2/276> 2/275> COMPILE-FILE("gabriel-timers") #.(PATHNAME "{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.DFASL;") 2/274> IL:BCOMPL(IL:GABRIEL-TIMERS) IL:ST IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.LCOM;3| |gabriel|::FIX IL:EDITV 2/273> IL:EDITV(IL:GABRIEL-TIMERSCOMS) IL:GABRIEL-TIMERSCOMS 2/272> |gabriel|::FIX |gabriel|::EDITV 2/271> IL:IN-PACKAGE("gabriel") # 2/270> IL:EDITV(IL:GABRIEL-TIMERSCOMS) IL:GABRIEL-TIMERSCOMS 2/269> IL:FILES?) 2/268> IL:LOAD(IL:GABRIEL-TIMERS.DFASL) IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.dfasl;3| 2/267: 2/266: LOAD(EXPORTS.ALL) IL:|{DSK}larry>ilisp>medley>library>EXPORTS.ALL;2| 2/265> COMPILE-FILE(IL:GABRIEL-TIMERS) #.(PATHNAME "{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.DFASL;") 2/264> 2/263> 2/262> IL:DIR 2/261> IL:SEE IL:BENCH-5 IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>BENCH-5.;2| 2/260> IL:DIR 2/259> IL:PWD "{DSK}larry>ilisp>envos>lispcore>gabriel>tools>" 2/258> IL:CD IL:TOOLS 2/257> IL:FILES?) 2/256: RETURN 2/255: RETURN IL:RETRY 2/254> (IL:INSTALL-WHO-LINE-OPTIONS) NIL IL:FIX 2/253> (IL:INSTALL-WHO-LINE-OPTIONS) 2/252> (IL:INSALL-WHO-LINE-OPTIONS) 2/251> IL:WHO-LINECOMS ((IL:* IL:|;;;| "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (IL:* IL:|;;| "") (IL:* IL:|;;| "Public fn for manipulating the who-line") (IL:FNS IL:INSTALL-WHO-LINE-OPTIONS) (IL:* IL:|;;;| "----------------------------------------------------------------------") (IL:* IL:|;;;| "Some fns that compute useful values for the who-line, and act as nice button event fns") (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the current logged in user") (IL:FNS IL:WHO-LINE-USERNAME IL:WHO-LINE-CHANGE-USER IL:WHO-LINE-USER-AFTER-LOGIN) (IL:VARIABLES IL:*WHO-LINE-CURRENT-USER* IL:*WHO-LINE-USER-ENTRY*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:ADDVARS (IL:\\SYSTEMCACHEVARS IL:*WHO-LINE-CURRENT-USER*) (IL:\\AFTERLOGINFNS IL:WHO-LINE-USER-AFTER-LOGIN))) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing the current machine name") (IL:FNS IL:WHO-LINE-HOST-NAME) (IL:VARIABLES IL:*WHO-LINE-HOST-NAME* IL:*WHO-LINE-HOST-NAME-ENTRY*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:ADDVARS (IL:\\SYSTEMCACHEVARS IL:*WHO-LINE-HOST-NAME*))) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the current tty process package") (IL:FNS IL:CURRENT-TTY-PACKAGE IL:SET-PACKAGE-INTERACTIVELY IL:SET-TTY-PACKAGE-INTERACTIVELY) (IL:VARIABLES IL:*WHO-LINE-PACKAGE-NAME-CACHE* IL:*WHO-LINE-PACKAGE-ENTRY*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the current tty process readtable") (IL:FNS IL:CURRENT-TTY-READTABLE-NAME IL:SET-READTABLE-INTERACTIVELY IL:SET-TTY-READTABLE-INTERACTIVELY) (IL:VARIABLES IL:*WHO-LINE-READTABLE-ENTRY*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the current tty process") (IL:FNS IL:WHO-LINE-TTY-PROCESS IL:CHANGE-TTY-PROCESS-INTERACTIVELY) (IL:VARIABLES IL:*WHO-LINE-TTY-PROC-ENTRY*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the currently connected directory") (IL:FNS IL:WHO-LINE-CURRENT-DIRECTORY IL:SET-CONNECTED-DIRECTORY-INTERACTIVELY) (IL:VARIABLES IL:*WHO-LINE-DIRECTORIES* IL:*WHO-LINE-LAST-DIRECTORY* IL:*WHO-LINE-DIRECTORY-ENTRY*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the current VMem utilization") (IL:FNS IL:WHO-LINE-VMEM IL:WHO-LINE-SAVE-VMEM) (IL:VARIABLES IL:*WHO-LINE-LAST-VMEM* IL:*WHO-LINE-VMEM-ENTRY*) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY IL:DONTEVAL@LOAD (IL:FILES (IL:LOADCOMP) IL:LLFAULT IL:MODARITH) (IL:P (IL:CHECKIMPORTS (QUOTE (IL:LLPARAMS)) T))) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing the percent of symbol-space currently used") (IL:FUNCTIONS IL:WHO-LINE-SYMBOL-SPACE) (IL:VARIABLES IL:*WHO-LINE-SYMBOL-SPACE* IL:*WHO-LINE-SYMBOL-SPACE-ENTRY*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing the current time") (IL:FNS IL:WHO-LINE-TIME IL:WHO-LINE-SET-TIME) (IL:VARIABLES IL:*WHO-LINE-TIMER* IL:*WHO-LINE-OLD-TIME* IL:*WHO-LINE-TIME-ENTRY*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:APPENDVARS (IL:\\SYSTEMTIMERVARS (IL:*WHO-LINE-TIMER* IL:SECONDS)))) (IL:* IL:|;;;| "----------------------------------------------------------------------") (IL:* IL:|;;;| "Some as yet un-debugged entries. Try at your own risk.") (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing the machine-active entry") (IL:FNS IL:WHO-LINE-SHOW-ACTIVE IL:\\UPDATE-WHO-LINE-ACTIVE-FLAG IL:\\PERIODICALLY-WHO-LINE-SHOW-ACTIVE) (IL:VARIABLES IL:*WHO-LINE-ACTIVE-PERIOD* IL:*WHO-LINE-ACTIVE-TIMER* IL:*WHO-LINE-SHOW-ACTIVE-ENTRY*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:APPENDVARS (IL:\\SYSTEMTIMERVARS (IL:*WHO-LINE-ACTIVE-TIMER* IL:MILLISECONDS)))) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing / changing the current reader profile") (IL:FNS IL:CURRENT-PROFILE IL:SET-PROFILE-INTERACTIVELY IL:SET-TTY-PROFILE-INTERACTIVELY) (IL:VARIABLES IL:*WHO-LINE-PROFILE-ENTRY*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Showing the state of the current TTY process") (IL:FNS IL:WHO-LINE-TTY-STATE IL:WHO-LINE-WHAT-IS-RUNNING) (IL:VARIABLES IL:*WHO-LINE-STATE* IL:*WHO-LINE-STATE-UNINTERESTING-FNS* IL:*WHO-LINE-TTY-STATE-ENTRY*) (IL:PROP IL:WHO-LINE-STATE IL:AWAIT.EVENT IL:BLOCK IL:EXCHANGEPUPS IL:GETPUP IL:SENDPUP IL:WAIT.FOR.TTY IL:\\TTYBACKGROUND IL:\\WAITFORSYSBUFP IL:|\\\\getkey| IL:\\SENDLEAF IL:PUTSEQUIN IL:\\LEAF.READPAGES) (IL:* IL:|;;;| "----------------------------------------------------------------------") (IL:* IL:|;;;| "Default options for the who-line") (IL:VARIABLES IL:*WHO-LINE-ENTRIES* IL:*WHO-LINE-ENTRY-REGISTRY* IL:*WHO-LINE-ANCHOR* IL:*WHO-LINE-NAME-FONT* IL:*WHO-LINE-VALUE-FONT* IL:*WHO-LINE-DISPLAY-NAMES?* IL:*WHO-LINE-COLOR* IL:*WHO-LINE-TITLE* IL:*WHO-LINE-BORDER* IL:*WHO-LINE-UPDATE-INTERVAL*) (IL:* IL:|;;;| "----------------------------------------------------------------------") (IL:* IL:|;;;| "Internal fns") (IL:FNS IL:REDISPLAY-WHO-LINE IL:PERIODICALLY-UPDATE-WHO-LINE IL:SETUP-WHOLINE-TIMER IL:UPDATE-WHO-LINE IL:WHEN-WHO-LINE-SELECTED-FN IL:WHO-LINE-CONTROL-SELECT IL:WHO-LINE-COPY-INSERT) (IL:FNS IL:WHO-LINE-REDISPLAY-INTERRUPT) (IL:VARIABLES IL:*WHO-LINE* IL:*WHO-LINE-UPDATE-TIMER*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:APPENDVARS (IL:\\SYSTEMTIMERVARS (IL:*WHO-LINE-UPDATE-TIMER* IL:TICKS)))) (IL:FUNCTIONS IL:INVERT-WHO-LINE-ENTRY) (IL:DECLARE\: IL:DONTCOPY (IL:RECORDS IL:WHO-LINE-ENTRY)) (IL:* IL:\; "Macros that lets us lock down the Who-Line while we evaluate some forms") (IL:FUNCTIONS IL:WITH-WHO-LINE IL:WITH-AVAILABLE-WHO-LINE) (IL:* IL:|;;;| "----------------------------------------------------------------------") (IL:* IL:|;;;| "Initialize the who-line") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:P (IL:INSTALL-WHO-LINE-OPTIONS)) (IL:ADDVARS (IL:BACKGROUNDFNS IL:PERIODICALLY-UPDATE-WHO-LINE))) (IL:* IL:|;;;| "----------------------------------------------------------------------") (IL:* IL:|;;;| "Filemanager stuff") (IL:DECLARE\: IL:DONTCOPY (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:WHO-LINE) (IL:PROP IL:FILETYPE IL:WHO-LINE))) 2/250> IN-PACKAGE(XCL-USER::IL) # 2/249> XCL-USER::WHO-LINECOMS 2/248> XCL-USER::WHO-LINE) 247> 246> |gabriel|::|pwd| "{DSK}larry>ilisp>envos>lispcore>gabriel>tools>" 245> (|gabriel|::|cl:in-package| "gabriel") 244> |gabriel|::|pwd| "{DSK}larry>ilisp>envos>lispcore>gabriel>tools>" 243> IL:|in-package|(IL:|gabriel|) # 242> IL:|load|(IL:|gabriel-timers.lcom|) IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.LCOM;2| 241> IL:|dir| 240> IL:|cd| IL:|tools| IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>| 239> IL:|pwd| "{DSK}larry>ilisp>envos>lispcore>gabriel>" 238> IL:|dir| 237> IL:|cd| IL:|gabriel| IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>| 236> IL:|cd| IL:|gabfiel| 235> IL:|cd| IL:|lispcore| IL:|{DSK}larry>ilisp>envos>lispcore>| 234> IL:|cd| IL:|lispcoe| 233> 232> IL:|dir| 231> IL:|cd| IL:|gabriel| 230> IL:|cd| IL:|ilisp/envos| IL:|{DSK}larry>ilisp>envos>| 229> IL:|cd| IL:|envos| 228> IL:|dir| FB-TEdit/227(debug) FB-Edit/226(debug) 225> IL:|dir| IL:|tools| 224> IL:|dir| IL:|gab*| 223> IL:|pwd| "{DSK}" 222> IL:|cd| IL:{DSK} 221> IL:|fb| NIL 220> IL:FILEFNSLST(IL:WHO-LINE) (IL:INSTALL-WHO-LINE-OPTIONS IL:WHO-LINE-USERNAME IL:WHO-LINE-CHANGE-USER IL:WHO-LINE-USER-AFTER-LOGIN IL:WHO-LINE-HOST-NAME IL:CURRENT-TTY-PACKAGE IL:SET-PACKAGE-INTERACTIVELY IL:SET-TTY-PACKAGE-INTERACTIVELY IL:CURRENT-TTY-READTABLE-NAME IL:SET-READTABLE-INTERACTIVELY IL:SET-TTY-READTABLE-INTERACTIVELY IL:WHO-LINE-TTY-PROCESS IL:CHANGE-TTY-PROCESS-INTERACTIVELY IL:WHO-LINE-CURRENT-DIRECTORY IL:SET-CONNECTED-DIRECTORY-INTERACTIVELY IL:WHO-LINE-VMEM IL:WHO-LINE-SAVE-VMEM IL:WHO-LINE-SYMBOL-SPACE IL:WHO-LINE-TIME IL:WHO-LINE-SET-TIME IL:WHO-LINE-SHOW-ACTIVE IL:\\UPDATE-WHO-LINE-ACTIVE-FLAG IL:\\PERIODICALLY-WHO-LINE-SHOW-ACTIVE IL:CURRENT-PROFILE IL:SET-PROFILE-INTERACTIVELY IL:SET-TTY-PROFILE-INTERACTIVELY IL:WHO-LINE-TTY-STATE IL:WHO-LINE-WHAT-IS-RUNNING IL:REDISPLAY-WHO-LINE IL:PERIODICALLY-UPDATE-WHO-LINE IL:SETUP-WHOLINE-TIMER IL:UPDATE-WHO-LINE IL:WHEN-WHO-LINE-SELECTED-FN IL:WHO-LINE-CONTROL-SELECT IL:WHO-LINE-COPY-INSERT IL:WHO-LINE-REDISPLAY-INTERRUPT IL:INVERT-WHO-LINE-ENTRY IL:WITH-WHO-LINE IL:WITH-AVAILABLE-WHO-LINE) MOUSE/219(debug)RETURN) 218> IL:PERIODICALLY-UPDATE-WHO-LINE) NIL 217> IL:PRINTCODE(IL:UPDATE-WHO-LINEA0001) 216> IL:PRINTCODE(IL:UPDATE-WHO-LINE) NIL 215: 214> 213> IL:EDITV(IL:WHO-LINECOMS) 212> IL:\. IL:SHOW IL:PATHS IL:TO IL:INSTALL-WHO-LINE-OPTIONS 211> IL:\. IL:SHOW IL:WHERE IL:ANY IL:CALLS IL:INSTALL-WHO-LINE-OPTIONS 210> IL:\. IL:WHO IL:IS IL:ON IL:WHO-LINE (IL:INSTALL-WHO-LINE-OPTIONS IL:WHO-LINE-USERNAME IL:WHO-LINE-CHANGE-USER IL:WHO-LINE-USER-AFTER-LOGIN IL:WHO-LINE-HOST-NAME IL:CURRENT-TTY-PACKAGE IL:SET-PACKAGE-INTERACTIVELY IL:SET-TTY-PACKAGE-INTERACTIVELY IL:CURRENT-TTY-READTABLE-NAME IL:SET-READTABLE-INTERACTIVELY IL:SET-TTY-READTABLE-INTERACTIVELY IL:WHO-LINE-TTY-PROCESS IL:CHANGE-TTY-PROCESS-INTERACTIVELY IL:WHO-LINE-CURRENT-DIRECTORY IL:SET-CONNECTED-DIRECTORY-INTERACTIVELY IL:WHO-LINE-VMEM IL:WHO-LINE-SAVE-VMEM IL:WHO-LINE-TIME IL:WHO-LINE-SET-TIME IL:WHO-LINE-SHOW-ACTIVE IL:\\UPDATE-WHO-LINE-ACTIVE-FLAG IL:\\PERIODICALLY-WHO-LINE-SHOW-ACTIVE IL:CURRENT-PROFILE IL:SET-PROFILE-INTERACTIVELY IL:SET-TTY-PROFILE-INTERACTIVELY IL:WHO-LINE-TTY-STATE IL:WHO-LINE-WHAT-IS-RUNNING IL:REDISPLAY-WHO-LINE IL:PERIODICALLY-UPDATE-WHO-LINE IL:SETUP-WHOLINE-TIMER IL:UPDATE-WHO-LINE IL:WHEN-WHO-LINE-SELECTED-FN IL:WHO-LINE-CONTROL-SELECT IL:WHO-LINE-COPY-INSERT IL:WHO-LINE-REDISPLAY-INTERRUPT IL:*WHO-LINE-CURRENT-USER* IL:*WHO-LINE-USER-ENTRY* IL:*WHO-LINE-HOST-NAME* IL:*WHO-LINE-HOST-NAME-ENTRY* IL:*WHO-LINE-PACKAGE-NAME-CACHE* IL:*WHO-LINE-PACKAGE-ENTRY* IL:*WHO-LINE-READTABLE-ENTRY* IL:*WHO-LINE-TTY-PROC-ENTRY* IL:*WHO-LINE-DIRECTORIES* IL:*WHO-LINE-LAST-DIRECTORY* IL:*WHO-LINE-DIRECTORY-ENTRY* IL:*WHO-LINE-LAST-VMEM* IL:*WHO-LINE-VMEM-ENTRY* IL:*WHO-LINE-SYMBOL-SPACE* IL:*WHO-LINE-SYMBOL-SPACE-ENTRY* IL:*WHO-LINE-TIMER* IL:*WHO-LINE-OLD-TIME* IL:*WHO-LINE-TIME-ENTRY* IL:*WHO-LINE-ACTIVE-PERIOD* IL:*WHO-LINE-ACTIVE-TIMER* IL:*WHO-LINE-SHOW-ACTIVE-ENTRY* IL:*WHO-LINE-PROFILE-ENTRY* IL:*WHO-LINE-STATE* IL:*WHO-LINE-STATE-UNINTERESTING-FNS* IL:*WHO-LINE-TTY-STATE-ENTRY* IL:*WHO-LINE-ENTRIES* IL:*WHO-LINE-ENTRY-REGISTRY* IL:*WHO-LINE-ANCHOR* IL:*WHO-LINE-NAME-FONT* IL:*WHO-LINE-VALUE-FONT* IL:*WHO-LINE-DISPLAY-NAMES?* IL:*WHO-LINE-COLOR* IL:*WHO-LINE-TITLE* IL:*WHO-LINE-BORDER* IL:*WHO-LINE-UPDATE-INTERVAL* IL:*WHO-LINE* IL:*WHO-LINE-UPDATE-TIMER* IL:WHO-LINE-SYMBOL-SPACE IL:INVERT-WHO-LINE-ENTRY IL:WITH-WHO-LINE IL:WITH-AVAILABLE-WHO-LINE) 209> IL:WHO-LINE) 208> IL:PP IL:UPDATE-WHO-LINE 207> IL:UPDATE-WHO-LINE) 206> IL:IN-PACKAGE(IL:IL) # 205: 204: IL:|retfrom|(IL:|update-who-line|) 203: IL:OLDFAULT1 IL:FIX 202> IL:LOAD(IL:WHO-LINE.LCOM) 201> IL:LOAD(IL:WHO-LLINE.LCOM) 200> IL:FILES?) 199> 198> 197> IL:PWD "{DSK}larry>ilisp>MEDLEY>INITFILES>" 2/297> pwd "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>" 2/298> (car loadedfilelst) LOADEDFILELST is an unbound variable. 2/299> (car il:loadedfilelst) IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>ARITH-BENCHMARKS.DFASL;4| 2/300> compile-file("io-benchmarks") Compiling 1 top-level form ... Done Compiling 2 top-level forms ... Done Compiling GABRIEL::DEFINE-TIMER GABRIEL::FPRINT ......... Done Compiling DEFUN GABRIEL::FPRINT ... Done Compiling DEFUN GABRIEL::FPRINT-INIT ... Done Compiling DEFUN GABRIEL::FPRINT-INIT1 ... Done Compiling DEFPARAMETER GABRIEL::FPRINT-TEST-FILE ... Done Compiling DEFVAR GABRIEL::TEST-ATOMS ... Done Compiling DEFVAR GABRIEL::TEST-PATTERN ... Done Compiling GABRIEL::DEFINE-TIMER GABRIEL::FREAD ......... Done Compiling DEFUN GABRIEL::FREAD ... Done Compiling GABRIEL::DEFINE-TIMER GABRIEL::TPRINT ........................... Done Compiling DEFUN GABRIEL::SETUP-TPRINT Warning: The variable IL:\\TERM.OFD was unknown and has been declared SPECIAL. ... Done Compiling DEFUN GABRIEL::TPRINT-INIT ... Done Compiling DEFUN GABRIEL::TPRINT-INIT1 ... Done Compiling DEFVAR GABRIEL::TEST-ATOMS-TPRINT ... Done Compiling DEFVAR GABRIEL::*TPRINT-WINDOW* ... Done Compiling DEFVAR GABRIEL::TEST-PATTERN-TPRINT ... Done Compiling DEFPARAMETER GABRIEL::*IO-BENCHMARKS* ... Done Compiling DEFPARAMETER GABRIEL::*MAIKO-IO-BENCHMARKS* ... Done Compiling 1 top-level form ... Done Compiling DEFUN READ-FLOATS Warning: The variable *FLOATS-TO-PRINT* was unknown and has been declared SPECIAL. ... Done Compiling GABRIEL::DEFINE-TIMER IL:READ-FLOAT ......... Done Compiling GABRIEL::DEFINE-TIMER IL:PRINT-FLOAT ... Warning: The variable *FLOATS-TO-PRINT* was unknown and has been declared SPECIAL. ...... Done Compiling DEFUN PRINT-TO-TERMINAL ... Done Compiling GABRIEL::DEFINE-TIMER IL:TERMINAL-PRINTING ... Warning: The variable IL:*TIMER-WINDOW-FOR-PRINT-TIMING* was unknown and has been declared SPECIAL. ......Warning: The variable IL:*TIMER-WINDOW-FOR-PRINT-TIMING* was unknown and has been declared SPECIAL. ......Warning: The variable IL:*TIMER-WINDOW-FOR-PRINT-TIMING* was unknown and has been declared SPECIAL. ...... Done Compiling GABRIEL::DEFINE-TIMER IL:FLOPPY-FORMATTING ......... Done Compiling GABRIEL::DEFINE-TIMER IL:FLOPPY-WRITE ......... Done Compiling GABRIEL::DEFINE-TIMER IL:FLOPPY-READ ......... Done Compiling DEFUN IL:READ-EXISTING-SYMBOLS ... Done Compiling GABRIEL::DEFINE-TIMER IL:READ-EXISTING-SYMBOLS ......... Done Compiling DEFUN IL:WRITE-TO-COREFILE ... Done Compiling DEFUN IL:WRITE-TO-FILE ... Done Compiling DEFUN IL:READ-FROM-FILE ... Done Compiling GABRIEL::DEFINE-TIMER IL:READ-DSK ..................... Done Compiling GABRIEL::DEFINE-TIMER IL:READ-UFS ..................... Done Compiling GABRIEL::DEFINE-TIMER IL:READ-CORE ..................... Done Compiling GABRIEL::DEFINE-TIMER IL:WRITE-DSK ............... Done Compiling GABRIEL::DEFINE-TIMER IL:WRITE-UFS ............... Done Compiling GABRIEL::DEFINE-TIMER IL:WRITE-CORE ............... Done Compiling 5 top-level forms ... Done Warning: The following functions were called in the code just compiled, but are not known to exist: IL:FLOPPY.FORMAT -- called from T164. #.(PATHNAME "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.DFASL;") 2/301> load(io-benchmarks.dfasl) ; Loading {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.DFASL;2 XCL Compiler output for source file {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.;4 Source file created Friday, 21 February 1992, 2:18:4294967340. FASL file created Tuesday, 20 October 2020, 3:05:4294967330. File not found: {DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS 2/302> retry ; Loading {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.DFASL;2 XCL Compiler output for source file {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.;4 Source file created Friday, 21 February 1992, 2:18:4294967340. FASL file created Tuesday, 20 October 2020, 3:05:4294967330. In IL:\\OPENFILE: File not found: {DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS 2/303: il:copyfile("{dsk}larry>ilisp>envos>lispcore>gabriel >2000-floats" {core}floats>2000=floats) File not found: {dsk}larry>ilisp>envos>lispcore>gabriel>2000-floats 2/304: pwd "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>" 2/305: REVERT IL:COPYFILEBreakpoint at IL:COPYFILE. 2/306: 2/307: ?= FROMFILE = "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" TOFILE = IL:{CORE}FLOATS>2000-FLOATS DESTPARAMETERS = NIL 2/308: fromfile FROMFILE is an unbound variable. 2/309: dir {core} 2/311: ?= FROMFILE = "{DSK}larry>ilisp>envos>lispcore>gabriel>aux>2000-floats-to-read" TOFILE = IL:{CORE}FLOATS>2000-FLOATS DESTPARAMETERS = NIL 2/312: eval IL:{CORE}FLOATS>2000-FLOATS>2000-FLOATS-TO-READ.\;1 2/313: ok In IL:\\OPENFILE: File not found: {DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS 2/314: revert il:copyfile IL:COPYFILEBreakpoint at IL:COPYFILE. 2/315: ?= FROMFILE = "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" TOFILE = IL:{CORE}1000-SYMBOLS>1000-SYMBOLS DESTPARAMETERS = NIL 2/316: (editv 'fromfile) Undefined car of form EDITV 2/317: ?= FROMFILE = "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" TOFILE = IL:{CORE}1000-SYMBOLS>1000-SYMBOLS DESTPARAMETERS = NIL 2/318: ?= FROMFILE = "{dsk}larry>ilisp>envos>lispcore>gabriel>aux>1000-symbols" TOFILE = IL:{CORE}1000-SYMBOLS>1000-SYMBOLS DESTPARAMETERS = NIL 2/320: eval IL:{CORE}1000-SYMBOLS>1000-SYMBOLS>1000-SYMBOLS.\;1 2/321: ok IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.DFASL;2| 2/322> editv(iio-benchmarkcoms) EDITV -> IL:EDITV ? yes NIL not editable 2/323> editv(io-benchmarkcoms) EDITV -> IL:EDITV ? yes NIL not editable 2/324> iobenchmarkcoms IOBENCHMARKCOMS is an unbound variable. 2/325> dir io-bench* {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS> IO-BENCHMARKS.;4 IO-BENCHMARKS.;3 IO-BENCHMARKS.;2 IO-BENCHMARKS.;1 IO-BENCHMARKS.DFASL;2 IO-BENCHMARKS.DFASL;1 IO-BENCHMARKS.LCOM;7 IO-BENCHMARKS.LCOM;6 IO-BENCHMARKS.LCOM;5 IO-BENCHMARKS.LCOM;3 IO-BENCHMARKS.LCOM;2 IO-BENCHMARKS.LCOM;1 2/326> see io-benchmarks File created:20-Feb-92 18:40:05 {DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;4 changes to:(IL:FUNCTIONS READ-FLOATS) previous date:19-Apr-90 18:48:13 {DSK}lde>lispcore>gabriel>benchmarks>IO-BENCHMARKS.;3 Read Table:XCL Package:(DEFPACKAGE "BENCHMARKS") ; Copyright (c) 1987, 1988, 1990, 1992 by Xerox Corporation. All rights reserved. (IL:RPAQQ IL:IO-BENCHMARKSCOMS ( **COMMENT** (IL:COMS **COMMENT** (IL:COMS **COMMENT** ( GABRIEL::TIMERS GABRIEL::FPRINT ) (IL:FUNCTIONS GABRIEL::FPRINT GABRIEL::FPRINT-INIT GABRIEL::FPRINT-INIT1) (IL:VARIABLES GABRIEL::FPRINT-TEST-FILE GABRIEL::TEST-ATOMS GABRIEL::TEST-PATTERN)) (IL:COMS **COMMENT** (GABRIEL::TIMERS GABRIEL::FREAD) (IL:FUNCTIONS GABRIEL::FREAD)) (IL:COMS **COMMENT** (GABRIEL::TIMERS GABRIEL::TPRINT) (IL:FUNCTIONS GABRIEL::SETUP-TPRINT GABRIEL::TPRINT-INIT GABRIEL::TPRINT-INIT1)) (IL:VARIABLES GABRIEL::TEST-ATOMS-TPRINT GABRIEL::*TPRINT-WINDOW* GABRIEL::TEST-PATTERN-TPRINT)) (IL:COMS **COMMENT** (IL:VARIABLES GABRIEL::*IO-BENCHMARKS* GABRIEL::*MAIKO-IO-BENCHMARKS*) (IL:VARS (IL:*1186-IO-TIMERS* '(IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)))) (IL:COMS **COMMENT** (IL:FUNCTIONS READ-FLOATS) (GABRIEL::TIMERS IL:READ-FLOAT IL:PRINT-FLOAT)) (IL:COMS **COMMENT** (IL:FUNCTIONS PRINT-TO-TERMINAL) (GABRIEL::TIMERS IL:TERMINAL-PRINTING)) (IL:COMS **COMMENT** (GABRIEL::TIMERS IL:FLOPPY-FORMATTING IL:FLOPPY-WRITE IL:FLOPPY-READ)) (IL:COMS **COMMENT** (IL:FUNCTIONS IL:READ-EXISTING-SYMBOLS) (GABRIEL::TIMERS IL:READ-EXISTING-SYMBOLS)) (IL:COMS **COMMENT** (IL:FUNCTIONS IL:WRITE-TO-COREFILE IL:WRITE-TO-FILE IL:READ-FROM-FILE) (GABRIEL::TIMERS IL:READ-DSK IL:READ-UFS IL:READ-CORE IL:WRITE-DSK IL:WRITE-UFS IL:WRITE-CORE)) (IL:COMS **COMMENT** (IL:P (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS" "{CORE}FLOATS") (IL:COPYFILE "{DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>1000-SYMBOLS" "{CORE}1000-SYMBOLS"))) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IO-BENCHMARKS))) **COMMENT** **COMMENT** **COMMENT** (GABRIEL::DEFINE-TIMER GABRIEL::FPRINT "FPrint" (GABRIEL::FPRINT)) (DEFUN GABRIEL::FPRINT () (LET ((GABRIEL::F (OPEN GABRIEL::FPRINT-TEST-FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE))) (PRINT GABRIEL::TEST-PATTERN GABRIEL::F) (CLOSE GABRIEL::F))) (DEFUN GABRIEL::FPRINT-INIT (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (LET ((GABRIEL::ATOMS (COPY-TREE GABRIEL::ATOMS))) (DO ((GABRIEL::A GABRIEL::ATOMS (CDR GABRIEL::A))) ((NULL (CDR GABRIEL::A)) (RPLACD GABRIEL::A GABRIEL::ATOMS))) (GABRIEL::FPRINT-INIT1 GABRIEL::M GABRIEL::N GABRIEL::ATOMS))) (DEFUN GABRIEL::FPRINT-INIT1 (GABRIEL::M GABRIEL::N GABRIEL::ATOMS) (COND ((= GABRIEL::M 0) (POP GABRIEL::ATOMS)) (T (DO ((GABRIEL::I GABRIEL::N (- GABRIEL::I 2)) (GABRIEL::A NIL)) ((< GABRIEL::I 1) GABRIEL::A) (PUSH (POP GABRIEL::ATOMS) GABRIEL::A) (PUSH (GABRIEL::FPRINT-INIT1 (1- GABRIEL::M) GABRIEL::N GABRIEL::ATOMS) GABRIEL::A))))) (DEFPARAMETER GABRIEL::FPRINT-TEST-FILE **COMMENT** "{dsk}fprint.tst") (DEFVAR GABRIEL::TEST-ATOMS '(GABRIEL::ABCDEF12 GABRIEL::CDEFGH23 GABRIEL::EFGHIJ34 GABRIEL::GHIJKL45 GABRIEL::IJKLMN56 GABRIEL::KLMNOP67 GABRIEL::MNOPQR78 GABRIEL::OPQRST89 GABRIEL::QRSTUV90 GABRIEL::STUVWX01 GABRIEL::UVWXYZ12 GABRIEL::WXYZAB23 GABRIEL::XYZABC34 GABRIEL::123456AB GABRIEL::234567BC GABRIEL::345678CD GABRIEL::456789DE GABRIEL::567890EF GABRIEL::678901FG GABRIEL::789012GH GABRIEL::890123HI)) 2/327> files?) FILES? -> IL:FILES? ? yes To be dumped: IL:WHO-LINE ...changes to IL:VARIABLES: IL:*WHO-LINE-TIME-ENTRY* IL:LOCAL-INIT ...changes to IL:FNS: IL:LOCAL-INIT 2/328> 2/329> (car il:loadedfilelst) IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.DFASL;2| 2/330> dir io-bench* {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS> IO-BENCHMARKS.;4 IO-BENCHMARKS.;3 IO-BENCHMARKS.;2 IO-BENCHMARKS.;1 IO-BENCHMARKS.DFASL;2 IO-BENCHMARKS.DFASL;1 IO-BENCHMARKS.LCOM;7 IO-BENCHMARKS.LCOM;6 IO-BENCHMARKS.LCOM;5 IO-BENCHMARKS.LCOM;3 IO-BENCHMARKS.LCOM;2 IO-BENCHMARKS.LCOM;1 2/331> bcompl(io-benchamrks) BCOMPL -> IL:BCOMPL ? yes File not found: IO-BENCHAMRKS 2/332> fix 2/332> BCOMPL (IO-BENCHmarks) BCOMPL -> IL:BCOMPL ? yes listing? store and redefine IL:|{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.LCOM;8| 2/333> (load (il:valueof -1)) ; Loading {DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>IO-BENCHMARKS.LCOM;8 ; compiled on 20-Oct-2020 03:27:34 ; File created 20-Feb-92 18:40:05 ; IL:IO-BENCHMARKSCOMS File not found: {DSK}LOCAL>LDE>LISPCORE>GABRIEL>AUX>2000-FLOATS 2/334> editv(io-benchmarkscoms) EDITV -> IL:EDITV ? yes =IL:IO-BENCHMARKSCOMS 2/335> apropos(readfile) READFILE IL:READFILE (defined) IL:|\\LFReadFileID| (defined) IL:\\LEAF.READFILENAME (defined) IL:READFILEA0001 (defined) IL:\\LEAF.READFILEPROP (defined) 2/336> apropos(core) USER::{DSK}LARRY>ILISP>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>GABRIEL-TAK. BENCHMARKS::{CORE}FLOATS>2000=FLOATS BENCHMARKS::{CORE} CORE IL:|{DSK}sybalsky>lispcore>sources>CLSTREAMS.LCOM;2| IL:|{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLPACKAGE.;1| IL:|{PELE:MV:ENVOS}SOURCES>DSKDISPLAY.;2| IL:|{DSK}export>lispcore>sources>LLMVS.;1| IL:|{DSK}export>lispcore>sources>LLMVS.;2| IL:|{DSK}lde>lispcore>sources>CLEARINGHOUSE.;1| IL:|{DSK}sources>CLISP.;1| IL:|{DSK}sybalsky>lispcore>sources>CMLPATHNAME.LCOM;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>library>GRAPHER.;3| IL:|{DSK}kaplan>Local>medley3.5>lispcore>library>GRAPHER.;5| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>D-ASSEM-PACKAGE.LCOM;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-PEEPHOLE.LCOM;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.;3| IL:|{DSK}lde>lispcore>sources>CLEARINGHOUSE.;2| IL:|{DSK}sources>CMLSEQBASICS.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>LLREAD.LCOM;2| IL:|{PELE:MV:ENVOS}SOURCES>SEDIT-TOPLEVEL.;4| IL:|{PELE:MV:ENVOS}SOURCES>SEDIT-TOPLEVEL.;5| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLMVS.;1| IL:|{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>DEFSTRUCT.;1| IL:|{DSK}local>lde>lispcore>sources>CMLUNDO.;1| IL:|{DSK}sources>LOCALFILE.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLSMARTARGS.;3| IL:|{DSK}sybalsky>lispcore>sources>DSKDISPLAY.LCOM;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>LOGOW.;3| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLSETF.;1| IL:|{DSK}sources>XCLC-TOP-LEVEL.;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CONDITION-HIERARCHY.;1| IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>| IL:|{DSK}kaplan>Local>medley3.5>lispcore>fonts>displayfonts>c0>modern10-mir-c0.displayfont;1| IL:|{DSK}disk3>lispcore3.0>sources>LLBIGNUM.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XXGEOM.LCOM;1| IL:{DSK}KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>FONTS>POSTSCRIPTFONTS>C0>HELVETICA01-MRR-C0.PSCFONT\;1 IL:|{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-IL.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>library>TEDIT.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>library>DMCHAT.LCOM;1| IL:|{DSK}sources>EXEC-COMMANDS.;1| IL:|CoreFiles| IL:|{DSK}sources>CMLREAD.;1| IL:{DSK}KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>FONTS>POSTSCRIPTFONTS>C0>HELVETICA-NARROW01-MIR-C0.PSCFONT\;1 IL:|{DSK}sybalsky>lispcore>sources>XCLC-TREES.DFASL;2| IL:COREVAL IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>DWIM.LCOM;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>LLNS.;1| IL:|{DSK}sources>DWIMIFY.;1| IL:|{DSK}sources>CONDITION-HIERARCHY-IL.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLDESTRUCT.LCOM;1| IL:|{DSK}sources>LLARRAYELT.;6| IL:|{DSK}sources>LLARRAYELT.;8| IL:|{PELE:MV:ENVOS}SOURCES>HIST.;2| IL:|{PELE:MV:ENVOS}SOURCES>HIST.;3| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>PASSWORDS.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLSPECIALFORMS.;1| IL:{NODIRCORE}SCRATCH IL:|{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>UNDO.;1| IL:|{PELE:MV:ENVOS}LIBRARY>BYTECOMPILER.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>xlisp.sysout| IL:|{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>MISC.;1| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>APUTDQ.;1| IL:|{PELE:MV:ENVOS}SOURCES>FONTPROFILE.;2| IL:|{PELE:MV:ENVOS}SOURCES>FONTPROFILE.;3| IL:|{DSK}disk3>lispcore3.0>sources>LLBIGNUM.;2| IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.;2| 2/337> dribblefile) DRIBBLEFILE -> IL:DRIBBLEFILE ? yes #larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>RUNNING-BENCHMARKS.DRIBBLE;1/173,75340> 2/338> pwd "{DSK}larry>ilisp>ENVOS>LISPCORE>GABRIEL>BENCHMARKS>" 2/339> (run-benchmarks *tak-timers* "results>maiko>win-tak.results") \ No newline at end of file diff --git a/internal/gabriel/interlisp/1186BENCHMARKS b/internal/gabriel/interlisp/1186BENCHMARKS new file mode 100644 index 00000000..e69de29b diff --git a/internal/gabriel/interlisp/BENCHMARK b/internal/gabriel/interlisp/BENCHMARK new file mode 100644 index 00000000..b1ad8803 --- /dev/null +++ b/internal/gabriel/interlisp/BENCHMARK @@ -0,0 +1 @@ +(FILECREATED "19-Nov-85 23:24:15" {QV}BENCHMARKS>BENCHMARK.;11 15509 changes to: (FNS BROWSE.BM TRAVERSE.BM) previous date: "17-Nov-85 13:47:33" {QV}BENCHMARKS>BENCHMARK.;10) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT BENCHMARKCOMS) (RPAQQ BENCHMARKCOMS ((FNS CTAK.BM FFT.BM RUN.BENCHMARKS STAK.BM TAK.BM TAKL.BM TAKR.BM BOYER.BM BROWSE.BM DERIVATIVE.BM DDERIVATIVE.BM DESTRUCTIVE.BM DIV2.BM POLYNOMIAL.BM PUZZLE.BM TRAVERSE.BM TRIANGLE.BM IO.BM) (* * Call (RUN.BENCHMARKS)) (DECLARE: DONTEVAL@LOAD (FILES (SYSLOAD FROM {ERIS}LIBRARY>) CMLARRAY)) (DECLARE: DONTEVAL@LOAD (FILES BOYER BROWSE CTAK DDERIV DERIV DESTRUCTIVE DIV2 FFT FPRINT FREAD POLY PUZZLE STAK TAK TAKL TAKR TESTPATTERN TPRINT TRAVERSE TRIANG)) (* Gabriel benchmarks) (VARS AREFY BENCHMARKSUITE CONSY TAKS))) (DEFINEQ (CTAK.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:30") (printout T T "************ CTAK BENCHMARK **************" T T) (printout T T T "Starting the CTAK run: (TIMEALL (CTAK 18 12 6))" T T) (SETQ VALUE (TIMEALL (CTAK 18 12 6))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (SETQ VALUE (TIMEALL (CTAK 18 12 6))) (printout T "Value = " VALUE T) (printout T T "CTAK finished" T T]) (FFT.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:57") (printout T T "*************** THE FFT BENCHMARK ***********" T T) (printout T T T "Starting FFT run: (TIMEALL (FFT-BENCH))" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (FFT-BENCH)) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (FFT-BENCH)) (printout T T "FFT finished" T T]) (RUN.BENCHMARKS [LAMBDA (BENCHMARKS) (* jop: " 8-Nov-85 17:28") (* * BENCHMARKS should be a list of the desired Benchmarks) (DECLARE (SPECVARS BENCHMARKSUITE)) (SETQ BENCHMARKS (MKLIST BENCHMARKS)) (if (NULL BENCHMARKS) then (SETQ BENCHMARKS BENCHMARKSUITE) elseif (for BM in BENCHMARKS thereis (NOT (MEMB BM BENCHMARKSUITE))) then (HELP "Unknown Benchmark" BENCHMARKS)) (RESETLST (LET ((DRIBBLE.FILE (PACKFILENAME (QUOTE HOST) (QUOTE DSK) (QUOTE NAME) (PACK* MAKESYSNAME "-" (MACHINETYPE)) (QUOTE EXTENSION) (QUOTE BENCHMARKS))) VALUE) (RESETSAVE NIL (QUOTE (TERPRI))) (RESETSAVE NIL (LIST (QUOTE PRIN1) (CONCAT "Benchmark Results in " DRIBBLE.FILE))) [RESETSAVE (DRIBBLE (PACKFILENAME (QUOTE HOST) (QUOTE DSK) (QUOTE NAME) (PACK* MAKESYSNAME "-" (MACHINETYPE)) (QUOTE EXTENSION) (QUOTE BENCHMARKS] (MOVD (QUOTE PAGEFULLFN) (QUOTE PAGEFULLFN.SAVE)) (RESETSAVE NIL (QUOTE (MOVD PAGEFULLFN.SAVE PAGEFULLFN))) (MOVD (QUOTE NILL) (QUOTE PAGEFULLFN)) (printout T T "MACHINETYPE = " (MACHINETYPE) T) (printout T T "MAKESYSNAME = " MAKESYSNAME T) (printout T T "MAKESYSDATE = " MAKESYSDATE T) (printout T T "DATE = " (DATE) T) (printout T T "USERNAME = " (USERNAME) T T) (DECLARE (SPECVARS VALUE)) [for BM in BENCHMARKS do (APPLY (PACK* BM (QUOTE .BM] (* (BROWSE.BM)) (* (PUZZLE.BM)) (* (JONL.BM) (BITBLT.BM)) (PRINTOUT T "Finished benchmarking" T T]) (STAK.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:31") (printout T T "************ STAK BENCHMARK **************" T T) (INIT-STAK) (* Bind X, Y , and Z) (printout T T T "Starting the STAK run: (TIMEALL (STAK))" T T) (SETQ VALUE (TIMEALL (STAK))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (SETQ VALUE (TIMEALL (STAK))) (printout T T "STAK finished" T T]) (TAK.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:29") (printout T T "************ TAK BENCHMARK **************" T T) (printout T T T "Starting the TAK run: (TIMEALL (TAK 18 12 6))" T T) (SETQ VALUE (TIMEALL (TAK 18 12 6))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (SETQ VALUE (TIMEALL (TAK 18 12 6))) (printout T "Value = " VALUE T) (printout T T "TAK finished" T T]) (TAKL.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:31") (printout T T "************ TAKL BENCHMARK **************" T T) (printout T T T "Starting the TAKL run: (TIMEALL (TAKL 18L 12L 6L))" T T) (SETQ VALUE (TIMEALL (TAKL 18L 12L 6L))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (SETQ VALUE (TIMEALL (TAKL 18L 12L 6L))) (printout T "Value = " VALUE T) (printout T T "TAKL finished" T T]) (TAKR.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:30") (printout T T "************ TAKR BENCHMARK **************" T T) (printout T T T "Starting the TAKR run: (TIMEALL (TAK0 18 12 6))" T T) (SETQ VALUE (TIMEALL (TAK0 18 12 6))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (SETQ VALUE (TIMEALL (TAK0 18 12 6))) (printout T "Value = " VALUE T) (printout T T "TAKR finished" T T]) (BOYER.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:46") (printout T T "********* BOYER BENCHMARK ***********" T T) (printout T T T "Initializing BOYER run: (TIMEALL (SETUP)) " T T) (TIMEALL (SETUP)) (printout T T T "starting BOYER run: (TIMEALL (TEST-BOYER)) " T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (TEST-BOYER)) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (TEST-BOYER)) (printout T T "BOYER finished" T T]) (BROWSE.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:46") (printout T T "********* BROWSE BENCHMARK ***********" T T) (printout T T T "starting BROWSE run: (TIMEALL (BROWSE)) " T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (BROWSE)) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (BROWSE)) (printout T T "BROWSE finished" T T]) (DERIVATIVE.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:50") (printout T T "******* Derivative Benchmark **********" T T) (printout T T T "Starting the DERIV run: (TIMEALL (RUN-DERIV))" T T) (FRPTQ 40 (RECLAIM)) (SETQ VALUE (TIMEALL (RUN-DERIV))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (SETQ VALUE (TIMEALL (RUN-DERIV))) (printout T "Value = " VALUE T) (printout T T "DERIV finished" T T]) (DDERIVATIVE.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:50") (printout T T "******* Data-Driven Derivative Benchmark **********" T T) (printout T T T "Starting the DDERIV run: (TIMEALL (RUN-DDERIV))" T T) (INIT-DDERIV) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (RUN-DDERIV))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (SETQ VALUE (TIMEALL (RUN-DDERIV))) (printout T "Value = " VALUE T) (printout T T "DDERIV finished" T T]) (DESTRUCTIVE.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:54") (printout T T "*********** THE DESTRUCTIVE BENCHMARK ************" T T) (printout T T T "Starting the DESTRUCTIVE run: (TIMEALL (DESTRUCTIVE 600 50))" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (DESTRUCTIVE 600 50))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (SETQ VALUE (TIMEALL (DESTRUCTIVE 600 50))) (printout T "Value = " VALUE T) (printout T T "DESTRUCTIVE finished" T T]) (DIV2.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:53") (printout T T "******* DIVIDE BY TWO BENCHMARK **********" T T) (printout T T T "Starting the iterative DIV2 run: (TIMEALL (TEST1 L))" T T) (FRPTQ 20 (RECLAIM)) (TIMEALL (TEST1 L)) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (TEST1 L)) (printout T T T "Starting the recursive DIV2 run: (TIMEALL (TEST2 L))" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (TEST2 L)) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (TEST2 L)) (printout T T "DIV2 finished" T T]) (POLYNOMIAL.BM [LAMBDA NIL (* jop: " 8-Nov-85 17:26") (printout T T "*************** THE POLYNOMIAL BENCHMARK ***********" T T) (printout T T T "Starting POLY 2 run: (TIMEALL (BENCH 2))" T T) (SETUP-POLY) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 2))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 2))) (printout T "Value = " VALUE T) (printout T T T "Starting POLY 5 run: (TIMEALL (BENCH 5))" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 5))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 5))) (printout T "Value = " VALUE T) (printout T T T "Starting POLY 10 run: (TIMEALL (BENCH 10))" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 10))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 10))) (printout T "Value = " VALUE T) (printout T T T "Starting POLY 15 run: (TIMEALL (BENCH 15))" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 15))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (BENCH 15))) (printout T "Value = " VALUE T) (printout T T "POLYNOMIAL finished" T T]) (PUZZLE.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:57") (printout T T "*************** THE PUZZLE BENCHMARK ***********" T T) (printout T T T "Starting PUZZLE run: (TIMEALL (START))" T T) (FRESHPUZZLES) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (START))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (FRESHPUZZLES) (FRPTQ 40 (RECLAIM)) (SETQ VALUE (TIMEALL (START))) (printout T "Value = " VALUE T) (printout T T "PUZZLE finished" T T]) (TRAVERSE.BM [LAMBDA NIL (* jop: "19-Nov-85 23:23") (printout T T "************* THE TRAVERSE BENCHMAK ************" T T) (printout T T T "Starting the TRAVERSE initialization: (TIMEALL (INIT-TRAVERSE))" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (INIT-TRAVERSE)) (printout T T T "Starting the TRAVERSE run: (TIMEALL (RUN-TRAVERSE))" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (RUN-TRAVERSE)) (printout T T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (RUN-TRAVERSE)) (printout T T "TRAVERSE finished" T T]) (TRIANGLE.BM [LAMBDA NIL (* jop: " 7-Nov-85 22:57") (printout T T "*************** THE TRIANGLE BENCHMARK ***********" T T) (printout T T T "Starting TRIANG run: (TIMEALL (GOGOGO 22))" T T) (TRIANG-INIT) (FRPTQ 20 (RECLAIM)) (SETQ VALUE (TIMEALL (GOGOGO 22))) (printout T "Value = " VALUE T) (printout T T "Repeating the TIMEALL" T T) (TRIANG-INIT) (FRPTQ 40 (RECLAIM)) (SETQ VALUE (TIMEALL (GOGOGO 22))) (printout T "Value = " VALUE T) (printout T T "TRIANG finished" T T]) (IO.BM [LAMBDA NIL (* jop: " 7-Nov-85 12:37") (printout T T "*******************************************************************" "DSK file I/O benchmarks: FPRINT and FREAD" T "Terminal printing (to window): TPRINT" T "*******************************************************************" T T) (CNDIR (QUOTE {DSK})) (DELFILE (QUOTE FPRINT.TST)) (CREATE-TESTPATTERN) (printout T T T "Starting FPRINT: (TIMEALL (FPRINT))" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (FPRINT)) (printout T T "Repeating the TIMEALL" T T) (DELFILE (QUOTE FPRINT.TST)) (FRPTQ 20 (RECLAIM)) (TIMEALL (FPRINT)) (printout T T "FPRINT finished" T T) (printout T T T "Starting the FREAD run: (TIMEALL (FREAD))" T T) (FRPTQ 20 (RECLAIM)) (TIMEALL (FREAD)) (printout T T "Repeating the TIMEALL" T T) (FRPTQ 40 (RECLAIM)) (TIMEALL (FREAD)) (printout T T "FREAD finished" T T) (printout T T T "Starting the TPRINT run: (TPRINT)" T T) (INIT-TPRINT) (FRPTQ 20 (RECLAIM)) (TIMEALL (TPRINT)) (CLOSEW BIGWINDOW) (printout T T "Repeating the TIMEALL" T T) (INIT-TPRINT) (FRPTQ 10 (RECLAIM)) (TIMEALL (TPRINT)) (CLOSEW BIGWINDOW) (printout T T "TPRINT finished" T T]) ) (* * Call (RUN.BENCHMARKS)) (DECLARE: DONTEVAL@LOAD (FILESLOAD (SYSLOAD FROM {ERIS}LIBRARY>) CMLARRAY) ) (DECLARE: DONTEVAL@LOAD (FILESLOAD BOYER BROWSE CTAK DDERIV DERIV DESTRUCTIVE DIV2 FFT FPRINT FREAD POLY PUZZLE STAK TAK TAKL TAKR TESTPATTERN TPRINT TRAVERSE TRIANG) ) (* Gabriel benchmarks) (RPAQQ AREFY (PUZZLE TRIANGLE)) (RPAQQ BENCHMARKSUITE (TAK STAK CTAK TAKL TAKR BOYER BROWSE DESTRUCTIVE TRAVERSE DERIVATIVE DDERIVATIVE DIV2 FFT PUZZLE TRIANGLE IO POLYNOMIAL)) (RPAQQ CONSY (BOYER BROWSE DERIVATIVE DDERIVATIVE DIV2)) (RPAQQ TAKS (TAK STAK CTAK TAKL TAKR)) (PUTPROPS BENCHMARK COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (918 14795 (CTAK.BM 928 . 1443) (FFT.BM 1445 . 1907) (RUN.BENCHMARKS 1909 . 4059) ( STAK.BM 4061 . 4605) (TAK.BM 4607 . 5115) (TAKL.BM 5117 . 5641) (TAKR.BM 5643 . 6158) (BOYER.BM 6160 . 6725) (BROWSE.BM 6727 . 7183) (DERIVATIVE.BM 7185 . 7762) (DDERIVATIVE.BM 7764 . 8381) ( DESTRUCTIVE.BM 8383 . 9011) (DIV2.BM 9013 . 9741) (POLYNOMIAL.BM 9743 . 11414) (PUZZLE.BM 11416 . 12030) (TRAVERSE.BM 12032 . 12690) (TRIANGLE.BM 12692 . 13320) (IO.BM 13322 . 14793))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/BOYER b/internal/gabriel/interlisp/BOYER new file mode 100644 index 00000000..b515f822 --- /dev/null +++ b/internal/gabriel/interlisp/BOYER @@ -0,0 +1,5 @@ +(FILECREATED "20-Nov-85 21:25:36" {QV}BENCHMARKS>BOYER.;4 17677 changes to: (FNS ADD-LEMMA) previous date: " 7-Nov-85 01:23:28" {QV}BENCHMARKS>BOYER.;3) (PRETTYCOMPRINT BOYERCOMS) (RPAQQ BOYERCOMS ((FNS ADD-LEMMA ADD-LEMMA-LST APPLY-SUBST APPLY-SUBST-LST FALSEP ONE-WAY-UNIFY ONE-WAY-UNIFY1 ONE-WAY-UNIFY1-LST PTIME REWRITE REWRITE-ARGS REWRITE-WITH-LEMMAS SETUP TAUTOLOGYP TAUTP TEST-BOYER TRANS-OF-IMPLIES TRANS-OF-IMPLIES1 TRUEP) (* * Call (SETUP) then (TEST-BOYER)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (ADD-LEMMA [LAMBDA (TERM) (* jop: "20-Nov-85 21:13") (COND [[AND (NOT (ATOM TERM)) (EQ (CAR TERM) (QUOTE EQUAL)) (NOT (ATOM (CADR TERM] (LET* [(ATM (CAR (CADR TERM))) (PROPLST (GETPROP ATM (QUOTE LEMMAS] (* Modified so multiple evocations will not generate  repeats in the prop list) (if PROPLST then [if (NOT (MEMB TERM PROPLST)) then (PUTPROP ATM (QUOTE LEMMAS) (CONS TERM (GETPROP ATM (QUOTE LEMMAS] else (SETPROPLIST ATM (CONS (QUOTE LEMMAS) (CONS (LIST TERM) (GETPROPLIST ATM] (T (ERROR (QUOTE ADD-LEMMA-DID-NOT-LIKE-TERM) TERM]) (ADD-LEMMA-LST (LAMBDA (LST) (COND ((NULL LST) T) (T (ADD-LEMMA (CAR LST)) (ADD-LEMMA-LST (CDR LST)))))) (APPLY-SUBST [LAMBDA (ALIST TERM) (DECLARE (GLOBALVARS TEMP-TEMP)) (* jop: " 7-Nov-85 01:17") (COND ((NLISTP TERM) (COND ((SETQ TEMP-TEMP (FASSOC TERM ALIST)) (CDR TEMP-TEMP)) (T TERM))) (T (CONS (CAR TERM) (APPLY-SUBST-LST ALIST (CDR TERM]) (APPLY-SUBST-LST (LAMBDA (ALIST LST) (COND ((NULL LST) NIL) (T (CONS (APPLY-SUBST ALIST (CAR LST)) (APPLY-SUBST-LST ALIST (CDR LST))))))) (FALSEP (LAMBDA (X LST) (OR (EQUAL X (QUOTE (F))) (MEMBER X LST)))) (ONE-WAY-UNIFY [LAMBDA (TERM1 TERM2) (DECLARE (GLOBALVARS UNIFY-SUBST)) (* jop: " 7-Nov-85 01:17") (PROGN (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2]) (ONE-WAY-UNIFY1 [LAMBDA (TERM1 TERM2) (DECLARE (GLOBALVARS UNIFY-SUBST TEMP-TEMP)) (* jop: " 7-Nov-85 01:16") (COND ((NLISTP TERM2) (COND ((SETQ TEMP-TEMP (FASSOC TERM2 UNIFY-SUBST)) (EQUAL TERM1 (CDR TEMP-TEMP))) (T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1) UNIFY-SUBST)) T))) ((ATOM TERM1) NIL) ((EQ (CAR TERM1) (CAR TERM2)) (ONE-WAY-UNIFY1-LST (CDR TERM1) (CDR TERM2))) (T NIL]) (ONE-WAY-UNIFY1-LST (LAMBDA (LST1 LST2) (COND ((NULL LST1) T) ((ONE-WAY-UNIFY1 (CAR LST1) (CAR LST2)) (ONE-WAY-UNIFY1-LST (CDR LST1) (CDR LST2))) (T NIL)))) (PTIME (LAMBDA NIL (PROG (GCTM) (SETQ GCTM (CLOCK 3)) (RETURN (CONS (IPLUS (CLOCK 2) GCTM) GCTM))))) (REWRITE (LAMBDA (TERM) (COND ((NLISTP TERM) TERM) (T (REWRITE-WITH-LEMMAS (CONS (CAR TERM) (REWRITE-ARGS (CDR TERM))) (GETPROP (CAR TERM) (QUOTE LEMMAS))))))) (REWRITE-ARGS (LAMBDA (LST) (COND ((NULL LST) NIL) (T (CONS (REWRITE (CAR LST)) (REWRITE-ARGS (CDR LST))))))) (REWRITE-WITH-LEMMAS [LAMBDA (TERM LST) (DECLARE (GLOBALVARS UNIFY-SUBST)) (* jop: " 7-Nov-85 01:18") (COND ((NULL LST) TERM) [(ONE-WAY-UNIFY TERM (CADR (CAR LST))) (REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST] (T (REWRITE-WITH-LEMMAS TERM (CDR LST]) (SETUP [LAMBDA NIL (DECLARE (GLOBALVARS TEMP-TEMP UNIFY-SUBST)) (* jop: " 7-Nov-85 01:21") (SETQ TEMP-TEMP NIL) (SETQ UNIFY-SUBST NIL) (ADD-LEMMA-LST (QUOTE ([EQUAL (COMPILE FORM) (REVERSE (CODEGEN (OPTIMIZE FORM) (NIL] (EQUAL (EQP X Y) (EQUAL (FIX X) (FIX Y))) (EQUAL (GREATERP X Y) (LESSP Y X)) (EQUAL (LESSEQP X Y) (NOT (LESSP Y X))) (EQUAL (GREATEREQP X Y) (NOT (LESSP X Y))) [EQUAL (BOOLEAN X) (OR (EQUAL X (T)) (EQUAL X (F] (EQUAL (IFF X Y) (AND (IMPLIES X Y) (IMPLIES Y X))) [EQUAL (EVEN1 X) (IF (ZEROP X) (T) (ODD (SUB1 X] (EQUAL (COUNTPS- L PRED) (COUNTPS-LOOP L PRED (ZERO))) (EQUAL (FACT- I) (FACT-LOOP I 1)) (EQUAL (REVERSE- X) (REVERSE-LOOP X (NIL))) (EQUAL (DIVIDES X Y) (ZEROP (REMAINDER Y X))) (EQUAL (ASSUME-TRUE VAR ALIST) (CONS (CONS VAR (T)) ALIST)) (EQUAL (ASSUME-FALSE VAR ALIST) (CONS (CONS VAR (F)) ALIST)) (EQUAL (TAUTOLOGY-CHECKER X) (TAUTOLOGYP (NORMALIZE X) (NIL))) (EQUAL (FALSIFY X) (FALSIFY1 (NORMALIZE X) (NIL))) [EQUAL (PRIME X) (AND (NOT (ZEROP X)) [NOT (EQUAL X (ADD1 (ZERO] (PRIME1 X (SUB1 X] (EQUAL (AND P Q) (IF P (IF Q (T) (F)) (F))) (EQUAL (OR P Q) (IF P (T) (IF Q (T) (F)) (F))) (EQUAL (NOT P) (IF P (F) (T))) (EQUAL (IMPLIES P Q) (IF P (IF Q (T) (F)) (T))) (EQUAL (FIX X) (IF (NUMBERP X) X (ZERO))) (EQUAL (IF (IF A B C) D E) (IF A (IF B D E) (IF C D E))) [EQUAL (ZEROP X) (OR (EQUAL X (ZERO)) (NOT (NUMBERP X] (EQUAL (PLUS (PLUS X Y) Z) (PLUS X (PLUS Y Z))) (EQUAL (EQUAL (PLUS A B) (ZERO)) (AND (ZEROP A) (ZEROP B))) (EQUAL (DIFFERENCE X X) (ZERO)) (EQUAL (EQUAL (PLUS A B) (PLUS A C)) (EQUAL (FIX B) (FIX C))) (EQUAL (EQUAL (ZERO) (DIFFERENCE X Y)) (NOT (LESSP Y X))) [EQUAL (EQUAL X (DIFFERENCE X Y)) (AND (NUMBERP X) (OR (EQUAL X (ZERO)) (ZEROP Y] (EQUAL (MEANING (PLUS-TREE (APPEND X Y)) A) (PLUS (MEANING (PLUS-TREE X) A) (MEANING (PLUS-TREE Y) A))) (EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X)) A) (FIX (MEANING X A))) (EQUAL (APPEND (APPEND X Y) Z) (APPEND X (APPEND Y Z))) (EQUAL (REVERSE (APPEND A B)) (APPEND (REVERSE B) (REVERSE A))) (EQUAL (TIMES X (PLUS Y Z)) (PLUS (TIMES X Y) (TIMES X Z))) (EQUAL (TIMES (TIMES X Y) Z) (TIMES X (TIMES Y Z))) (EQUAL (EQUAL (TIMES X Y) (ZERO)) (OR (ZEROP X) (ZEROP Y))) (EQUAL (EXEC (APPEND X Y) PDS ENVRN) (EXEC Y (EXEC X PDS ENVRN) ENVRN)) (EQUAL (MC-FLATTEN X Y) (APPEND (FLATTEN X) Y)) (EQUAL (MEMBER X (APPEND A B)) (OR (MEMBER X A) (MEMBER X B))) (EQUAL (MEMBER X (REVERSE Y)) (MEMBER X Y)) (EQUAL (LENGTH (REVERSE X)) (LENGTH X)) (EQUAL (MEMBER A (INTERSECT B C)) (AND (MEMBER A B) (MEMBER A C))) (EQUAL (NTH (ZERO) I) (ZERO)) (EQUAL (EXP I (PLUSF0J K)) (TIMES (EXP y J) (EXP I K))) (EQUAL (EXP I (TIMES J K)) (EXP (EXP I J) K)) (EQUAL (REVERSE-LOOP X Y) (APPEND (REVERSE X) Y)) (EQUAL (REVERSE-LOOP X (NIL)) (REVERSE X)) (EQUAL (COUNT-LIST Z (SORT-LP X Y)) (PLUS (COUNT-LIST Z X) (COUNT-LIST Z Y))) (EQUAL (EQUAL (APPEND A B) (APPEND A C)) (EQUAL B C)) (EQUAL (PLUS (REMAINDER X Y) (TIMES Y (QUOTIENT X Y))) (FIX X)) (EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE) BASE) (PLUS (POWER-EVAL L BASE) I)) [EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE) BASE) (PLUS I (PLUS (POWER-EVAL X BASE) (POWER-EVAL Y BASE] (EQUAL (REMAINDER Y 1) (ZERO)) (EQUAL (LESSP (REMAINDER X Y) Y) (NOT (ZEROP Y))) (EQUAL (REMAINDER X X) (ZERO)) [EQUAL (LESSP (QUOTIENT I J) I) (AND (NOT (ZEROP I)) (OR (ZEROP J) (NOT (EQUAL J 1] [EQUAL (LESSP (REMAINDER X Y) X) (AND (NOT (ZEROP Y)) (NOT (ZEROP X)) (NOT (LESSP X Y] (EQUAL (POWER-EVAL (POWER-REP I BASE) BASE) (FIX I)) (EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE) (POWER-REP J BASE) (ZERO) BASE) BASE) (PLUS I J)) (EQUAL (GCD X Y) (GCD Y X)) [EQUAL (NTH (APPEND A B) I) (APPEND (NTH A I) (NTH B (DIFFERENCE I (LENGTH A] (EQUAL (DIFFERENCE (PLUS X Y) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS Y X) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS X Y) (PLUS X Z)) (DIFFERENCE Y Z)) ‰ (EQUAL (TIMES X (DIFFERENCE C W)) ‰ š ‰şŚŃU7ý?t/tŻ¨tßUőŚŃU˝ 4hßUőďő.ľŠżżżżżżşşşşşşşŚŃU˝ 4hßUőCő.ľˇˇŠżżżżŚŃŐ4 +uăßUőŚŃU/4 5ýď7toßUőŚŃU˝ 4hßUőiő)ľŠżżżżżżşşşşşş)ľŠżżżżżşŚŃU-t/ěßŐľˇŠżżżżŚŃŐ4 +uăßUőŚŃU7ý?t/tŻ¨tßUőŚŃUMŁhßUőëőŚŃUMŁhßUőwőŻľˇŠżżżżżżşşşşşşş7ľŠżżżżżşŚŃUMŁhßUőëőŻľˇŠżżżżŚŃŐ4 +uăßUőŚŃU7ý?t/tŻ¨tßUőŚŃŐuw7ŃUőŚŃUMŁhßUőő)ľˇŠżżżżżżşş (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE))))) (_ ($! TEMP-INSTANCE-NAME) |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-UnSetName-BASIC| NIL (XCL-USER::DO-TEST "UnSetName Basic test, make sure UnSetName works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (TOSS-AWAY (_ TEMP-INSTANCE |UnSetName|)) (RESULTS (AND (EQ 1 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE))) (NOT (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE)))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-UnSetName-MORE-1| NIL (XCL-USER::DO-TEST "UnSetName More test, make sure UnSetName works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (TOSS-AWAY-1 (CL:DOTIMES (I 10) (_ TEMP-INSTANCE |SetName| ( CL:GENSYM )))) (TOSS-AWAY-2 (_ TEMP-INSTANCE |UnSetName| TEMP-INSTANCE-NAME)) (RESULTS (AND (EQ 11 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE))) (NOT (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE)))))) (_ TEMP-INSTANCE |UnSetName|) (SETQ RESULTS (AND RESULTS (EQ 1 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP ),Qăő$¨XęlO?%źâ'*), +Fp"73(mž˜ŁČŚÜˇ (TIMES A B) (PLUS C D))) [Z F (REVERSE (APPEND (APPEND A B) (NIL] (U EQUAL (PLUS A B) (DIFFERENCE X Y)) (W LESSP (REMAINDER A B) (MEMBER A (LENGTH B] (QUOTE (IMPLIES [AND (IMPLIES X Y) (AND (IMPLIES Y Z) (AND (IMPLIES Z U) (IMPLIES U W] (IMPLIES X W] (SETQ ANS (TAUTP TERM)) (SETQ TM2 (PTIME)) (RETURN (LIST ANS (DIFFERENCE (CAR TM2) (CAR TM1)) (DIFFERENCE (CDR TM2) (CDR TM1]) (TRANS-OF-IMPLIES (LAMBDA (N) (LIST (QUOTE IMPLIES) (TRANS-OF-IMPLIES1 N) (LIST (QUOTE IMPLIES) 0 N)))) (TRANS-OF-IMPLIES1 (LAMBDA (N) (COND ((EQUAL N 1) (LIST (QUOTE IMPLIES) 0 1)) (T (LIST (QUOTE AND) (LIST (QUOTE IMPLIES) (SUB1 N) N) (TRANS-OF-IMPLIES1 (SUB1 N))))))) (TRUEP (LAMBDA (X LST) (OR (EQUAL X (QUOTE (T))) (MEMBER X LST)))) ) (* * Call (SETUP) then (TEST-BOYER)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS BOYER COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (612 17474 (ADD-LEMMA 622 . 1474) (ADD-LEMMA-LST 1476 . 1613) (APPLY-SUBST 1615 . 1969) (APPLY-SUBST-LST 1971 . 2147) (FALSEP 2149 . 2227) (ONE-WAY-UNIFY 2229 . 2449) (ONE-WAY-UNIFY1 2451 . 3000) (ONE-WAY-UNIFY1-LST 3002 . 3212) (PTIME 3214 . 3357) (REWRITE 3359 . 3577) (REWRITE-ARGS 3579 . 3727) (REWRITE-WITH-LEMMAS 3729 . 4092) (SETUP 4094 . 15470) (TAUTOLOGYP 15472 . 16071) (TAUTP 16073 . 16146) (TEST-BOYER 16148 . 17034) (TRANS-OF-IMPLIES 17036 . 17161) (TRANS-OF-IMPLIES1 17163 . 17393 ) (TRUEP 17395 . 17472))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/BROWSE b/internal/gabriel/interlisp/BROWSE new file mode 100644 index 00000000..b1b35811 --- /dev/null +++ b/internal/gabriel/interlisp/BROWSE @@ -0,0 +1 @@ +(FILECREATED "18-Nov-85 14:31:42" {QV}BENCHMARKS>BROWSE.;4 5551 changes to: (FNS MATCH! BROWSE SEED-BROWSE RANDOMIZE RANDOM-BROWSE INIT-BROWSE INVESTIGATE) (VARS BROWSECOMS) previous date: "28-Nov-84 19:18:36" {PHYLUM}BROWSE.;17) (* Copyright (c) 1983, 1984, 1985 by RPG. All rights reserved.) (PRETTYCOMPRINT BROWSECOMS) (RPAQQ BROWSECOMS ((MACROS CHAR1) (FNS INIT-BROWSE RANDOM-BROWSE SEED-BROWSE RANDOMIZE MATCH! BROWSE INVESTIGATE) (* * Call (BROWSE)) (DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T)))) (DECLARE: EVAL@COMPILE (PUTPROPS CHAR1 MACRO ((X) (NTHCHAR X 1))) ) (DEFINEQ (INIT-BROWSE [LAMBDA (N M NPATS IPATS) (* JonL "28-Nov-84 19:17") (PROG ((IPATS (SUBST NIL NIL IPATS)) LOSER) (RPLACD (SETQ LOSER (LAST IPATS)) IPATS) (RETURN (PROG1 (bind (A _ NIL) for old N from N to 1 by -1 as (I _ M) by (if (ZEROP I) then M else (SUB1 I)) as (NAME _(GENSYM)) by (GENSYM) do (push A NAME) (RPTQ I (PUTPROP NAME (GENSYM) NIL)) (PUTPROP NAME (QUOTE PATTERN) (bind (A _ NIL) for I from NPATS to 1 by -1 as IPATS on IPATS do (push A (CAR IPATS)) finally (RETURN A))) (RPTQ (DIFFERENCE M I) (PUTPROP NAME (GENSYM) NIL)) finally (RETURN A)) (RPLACD LOSER NIL) (* To break the circularities) ]) (RANDOM-BROWSE [LAMBDA NIL (* jop: "18-Nov-85 14:28") (DECLARE (GLOBALVARS RAND-BROWSE)) (SETQ RAND-BROWSE (IMOD (ITIMES RAND-BROWSE 17) 251]) (SEED-BROWSE [LAMBDA NIL (* jop: "18-Nov-85 14:28") (DECLARE (GLOBALVARS RAND-BROWSE)) (SETQ RAND-BROWSE 21]) (RANDOMIZE [LAMBDA (L) (* jop: "18-Nov-85 14:25") (bind (A _ NIL) while L do [PROG [(N (IMOD (RANDOM-BROWSE) (LENGTH L] (COND ((ZEROP N) (push A (CAR L)) (SETQ L (CDR L))) (T (for N from N to 2 by -1 as X on L do NIL finally (PROGN (push A (CADR X)) (RPLACD X (CDDR X] finally (RETURN A]) (MATCH! [LAMBDA (PAT DAT ALIST) (* jop: "18-Nov-85 14:13") (COND ((NULL PAT) (NULL DAT)) ((NULL DAT) NIL) ((OR (EQ (CAR PAT) (QUOTE ?)) (EQ (CAR PAT) (CAR DAT))) (MATCH! (CDR PAT) (CDR DAT) ALIST)) ((EQ (CAR PAT) (QUOTE *)) (OR (MATCH! (CDR PAT) DAT ALIST) (MATCH! (CDR PAT) (CDR DAT) ALIST) (MATCH! PAT (CDR DAT) ALIST))) (T (COND [(NLISTP (CAR PAT)) (COND [(EQ (CHAR1 (CAR PAT)) (QUOTE ?)) (PROG ((VAL (FASSOC (CAR PAT) ALIST))) (RETURN (COND (VAL (MATCH! (CONS (CDR VAL) (CDR PAT)) DAT ALIST)) (T (MATCH! (CDR PAT) (CDR DAT) (CONS (CONS (CAR PAT) (CAR DAT)) ALIST] ((EQ (CHAR1 (CAR PAT)) (QUOTE *)) (PROG ((VAL (FASSOC (CAR PAT) ALIST))) (RETURN (COND (VAL (MATCH! (APPEND (CDR VAL) (CDR PAT)) DAT ALIST)) (T (for (L _ NIL) by (NCONC L (LIST (CAR DTEMP))) as E on (CONS NIL DAT) as (DTEMP _ DAT) by (CDR DTEMP) do (COND ((MATCH! (CDR PAT) DTEMP (CONS (CONS (CAR PAT) L) ALIST)) (RETURN T] (T (AND (NOT (NLISTP (CAR DAT))) (MATCH! (CAR PAT) (CAR DAT) ALIST) (MATCH! (CDR PAT) (CDR DAT) ALIST]) (BROWSE [LAMBDA NIL (* jop: "18-Nov-85 14:26") (SEED-BROWSE) (INVESTIGATE [RANDOMIZE (INIT-BROWSE 100 10 4 (QUOTE ((A A A B B B B A A A A A B B A A A) (A A B B B B A A (A A) (B B)) (A A A B (B A) B A B A] (QUOTE ((*A ?B *B ?B A *A A *B *A) (*A *B *B *A (*A) (*B)) (? ? *(B A)* ? ?]) (INVESTIGATE [LAMBDA (UNITS PATS) (* edited: "25-FEB-83 13:07") (for UNITS on UNITS do (for PATS on PATS do (for P on (GETP (CAR UNITS) (QUOTE PATTERN)) do (MATCH! (CAR PATS) (CAR P) NIL]) ) (* * Call (BROWSE)) (DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS BROWSE COPYRIGHT ("RPG" 1983 1984 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (673 5348 (INIT-BROWSE 683 . 1743) (RANDOM-BROWSE 1745 . 1976) (SEED-BROWSE 1978 . 2164) (RANDOMIZE 2166 . 2692) (MATCH! 2694 . 4532) (BROWSE 4534 . 4988) (INVESTIGATE 4990 . 5346))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/CTAK b/internal/gabriel/interlisp/CTAK new file mode 100644 index 00000000..59d7b278 --- /dev/null +++ b/internal/gabriel/interlisp/CTAK @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 01:05:24" {QV}BENCHMARKS>CTAK.;3 1232 changes to: (VARS CTAKCOMS) (FNS TAK TAK1 TAKCALLER CTAK1 CTAK) previous date: " 5-JUL-83 13:07:00" {QV}BENCHMARKS>CTAK.;1) (PRETTYCOMPRINT CTAKCOMS) (RPAQQ CTAKCOMS ((FNS CTAK CTAK1 TAKCALLER) (* * Call (CTAK 18 12 6)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (CTAK [LAMBDA (X Y Z) (* JonL " 5-JUL-83 12:51") (TAKCALLER X Y Z]) (CTAK1 [LAMBDA (X Y Z) (* JonL " 5-JUL-83 12:47") (COND ((NOT (ILESSP Y X)) (RETFROM (QUOTE TAKCALLER) Z)) (T (CTAK1 (TAKCALLER (SUB1 X) Y Z) (TAKCALLER (SUB1 Y) Z X) (TAKCALLER (SUB1 Z) X Y]) (TAKCALLER [LAMBDA (X Y Z) (* jop: " 4-Nov-85 21:54") (CTAK1 X Y Z]) ) (* * Call (CTAK 18 12 6)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CTAK COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (415 1041 (CTAK 425 . 553) (CTAK1 555 . 908) (TAKCALLER 910 . 1039))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/DDERIV b/internal/gabriel/interlisp/DDERIV new file mode 100644 index 00000000..0954cc72 --- /dev/null +++ b/internal/gabriel/interlisp/DDERIV @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 01:03:40" {QV}BENCHMARKS>DDERIV.;5 4118 changes to: (FNS RUN-DDERIV INIT-DDERIV DDERIV PLUS.DERIV DIFFERENCE.DERIV TIMES.DERIV QUOTIENT.DERIV DER1-DDERIV DER1 DERIV RUN DDERIV-DER1 DDERIV-DERIV) (VARS DDERIVCOMS) previous date: "11-FEB-83 14:21:49" {QV}BENCHMARKS>DDERIV.;1) (* Copyright (c) 1983, 1985 by RPG. All rights reserved.) (PRETTYCOMPRINT DDERIVCOMS) (RPAQQ DDERIVCOMS ((FNS INIT-DDERIV RUN-DDERIV DDERIV QUOTIENT.DERIV TIMES.DERIV DIFFERENCE.DERIV PLUS.DERIV DER1-DDERIV) (PROP DERIV QUOTIENT TIMES DIFFERENCE PLUS) (FNS HEADIFY) (* * Call (INIT-DDERIV) then (RUN-DDERIV)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (INIT-DDERIV [LAMBDA NIL (* jop: " 7-Nov-85 00:59") (for X in (QUOTE (PLUS DIFFERENCE TIMES QUOTIENT)) do (HEADIFY X (QUOTE DERIV]) (RUN-DDERIV [LAMBDA NIL (* jop: " 7-Nov-85 01:02") (DECLARE (GLOBALVARS RUNTIMES)) (to 1000 do (DDERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DDERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DDERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DDERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DDERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5]) (DDERIV [LAMBDA (EXP) (* jop: " 4-Nov-85 22:53") (COND ((ATOM EXP) (COND ((EQ EXP (QUOTE X)) 1) (T 0))) (T (PROG [(DDERIV (GETP (CAR EXP) (QUOTE DERIV] (RETURN (COND (DDERIV (APPLY* DDERIV (CDR EXP))) (T (QUOTE ERROR]) (QUOTIENT.DERIV [LAMBDA (EXP) (* jop: " 4-Nov-85 22:55") (LIST (QUOTE DIFFERENCE) (LIST (QUOTE QUOTIENT) (DDERIV (CAR EXP)) (CADR EXP)) (LIST (QUOTE QUOTIENT) (CAR EXP) (LIST (QUOTE TIMES) (CADR EXP) (CADR EXP) (DDERIV (CADR EXP]) (TIMES.DERIV [LAMBDA (EXP) (* jop: " 4-Nov-85 22:55") (LIST (QUOTE TIMES) (CONS (QUOTE TIMES) EXP) (CONS (QUOTE PLUS) (MAPCAR EXP (QUOTE DER1-DDERIV]) (DIFFERENCE.DERIV [LAMBDA (EXP) (* jop: " 4-Nov-85 22:54") (CONS (QUOTE DIFFERENCE) (MAPCAR EXP (QUOTE DDERIV]) (PLUS.DERIV [LAMBDA (EXP) (* jop: " 4-Nov-85 22:54") (CONS (QUOTE PLUS) (MAPCAR EXP (QUOTE DDERIV]) (DER1-DDERIV [LAMBDA (EXP) (* jop: " 4-Nov-85 22:55") (LIST (QUOTE QUOTIENT) (DDERIV EXP) EXP]) ) (PUTPROPS QUOTIENT DERIV QUOTIENT.DERIV) (PUTPROPS TIMES DERIV TIMES.DERIV) (PUTPROPS DIFFERENCE DERIV DIFFERENCE.DERIV) (PUTPROPS PLUS DERIV PLUS.DERIV) (DEFINEQ (HEADIFY (LAMBDA (X PROP) (* JonL "11-FEB-83 14:08") (PROG ((L (GETPROPLIST X))) (if (FMEMB PROP (CDDR L)) then (SETPROPLIST X (CONS PROP (CONS (GETP X PROP) L))))))) ) (* * Call (INIT-DDERIV) then (RUN-DDERIV)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS DDERIV COPYRIGHT ("RPG" 1983 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (776 3454 (INIT-DDERIV 786 . 1006) (RUN-DDERIV 1008 . 1824) (DDERIV 1826 . 2225) ( QUOTIENT.DERIV 2227 . 2635) (TIMES.DERIV 2637 . 2900) (DIFFERENCE.DERIV 2902 . 3093) (PLUS.DERIV 3095 . 3274) (DER1-DDERIV 3276 . 3452)) (3629 3897 (HEADIFY 3639 . 3895))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/DERIV b/internal/gabriel/interlisp/DERIV new file mode 100644 index 00000000..3a46cd12 --- /dev/null +++ b/internal/gabriel/interlisp/DERIV @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 00:57:05" {QV}BENCHMARKS>DERIV.;3 2605 changes to: (VARS DERIVCOMS) (FNS DER1 DERIV RUN-DERIV RUN DDERIV-DER1 RUN-DDERIV) previous date: "10-FEB-83 13:56:46" {QV}BENCHMARKS>DERIV.;1) (* Copyright (c) 1983, 1985 by RPG. All rights reserved.) (PRETTYCOMPRINT DERIVCOMS) (RPAQQ DERIVCOMS ((FNS DER1 DERIV RUN-DERIV) (* * Call (RUN-DERIV)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (DER1 [LAMBDA (A) (* JonL "10-FEB-83 13:56") (LIST (QUOTE QUOTIENT) (DERIV A) A]) (DERIV [LAMBDA (A) (* JonL "10-FEB-83 13:56") (COND ((ATOM A) (COND ((EQ A (QUOTE X)) 1) (T 0))) [(EQ (QUOTE PLUS) (CAR A)) (CONS (QUOTE PLUS) (MAPCAR (CDR A) (QUOTE DERIV] [(EQ (QUOTE DIFFERENCE) (CAR A)) (CONS (QUOTE DIFFERENCE) (MAPCAR (CDR A) (QUOTE DERIV] [(EQ (QUOTE TIMES) (CAR A)) (LIST (QUOTE TIMES) A (CONS (QUOTE PLUS) (MAPCAR (CDR A) (QUOTE DER1] [(EQ (QUOTE QUOTIENT) (CAR A)) (LIST (QUOTE DIFFERENCE) (LIST (QUOTE QUOTIENT) (DERIV (CADR A)) (CADDR A)) (LIST (QUOTE QUOTIENT) (CADR A) (LIST (QUOTE TIMES) (CADDR A) (CADDR A) (DERIV (CADDR A] (T (QUOTE ERROR]) (RUN-DERIV [LAMBDA NIL (* JonL "10-FEB-83 13:56") (for I to 1000 do (DERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))) (DERIV (QUOTE (PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5]) ) (* * Call (RUN-DERIV)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS DERIV COPYRIGHT ("RPG" 1983 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (496 2405 (DER1 506 . 670) (DERIV 672 . 1640) (RUN-DERIV 1642 . 2403))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/DERIV.LCOM b/internal/gabriel/interlisp/DERIV.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..ae57ee8f5300b44cfef48e37f90ce8b22a1c490b GIT binary patch literal 1533 zcmb7E%Wl&^6m`-C-~~!ym(`WUV_cEQW5*IWX zCv?GvA7EP{Rf1K&fE|0bY>+DP1Kb&>2}Ob`k?hQUojE>t=8{$rvS!M>jQOBYT3O!M zuh?~MHV&ND_;7nvw)tUSAA-z zAS=)q0~rpr9m7`OnB(j{?!y3K*0v6ZuOS>99l#{FTCFP3-#Estt|Qdyj%g{XOs=to zdLyCS@YRv{0tdy^DlN8Hu??UG(syc>0`g7#s45HKkA6)iArK8b zRR!s;BuRyBNpkPtvr{gYOA@hicBqODtKB#YSd^h50D>O;h46g_5#0X!zH$4*g^N&^ zr@N&WB@TM|=>fiHwW51=zhA%|J_qNw+B@av@7j;P6lczVF5fGc+1kYcX2Tu{yY=OrTZ=A_$UP9s|~pAdD>UnzhIyrV2)5>KYjg zI&~4~#?&=3_HF7SY)F!_EL+D3k)%PCA(J%mR#zt;Apaa7sM{ROL33ko56HN| zc*BX$nxU662mCn7SkDXHF!p?5HREI*WIq;OP5?(XkT7m~p%`6N$W;6x#cr0QaWWca a!0Xarsh!~rPm?7DXoC-BENCHMARKS>DESTRUCTIVE.;3 2065 changes to: (FNS DESTRUCTIVE) (VARS DESTRUCTIVECOMS) previous date: " 9-FEB-83 15:37:32" {QV}BENCHMARKS>DESTRUCTIVE.;1) (* Copyright (c) 1983, 1985 by HornBlower. All rights reserved.) (PRETTYCOMPRINT DESTRUCTIVECOMS) (RPAQQ DESTRUCTIVECOMS ((FNS DESTRUCTIVE) (MACROS COLLECTN) (* * Call (DESTRUCTIVE 600 50)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (DESTRUCTIVE [LAMBDA (N M) (* jop: " 7-Nov-85 00:50") (PROG ((LST (COLLECTN 10))) [for I from N by -1 to 1 do (if (NULL (CAR LST)) then (for L on LST do (OR (CAR L) (RPLACA L (LIST NIL))) (NCONC (CAR L) (COLLECTN M))) else (for LST1 on LST as LST2 on (CDR LST) do (RPLACD (for J from (IQUOTIENT (FLENGTH (CAR LST2)) 2) by -1 to 1 as A on (CAR LST2) do (RPLACA A I) finally (RETURN A)) (PROG ((N (IQUOTIENT (FLENGTH (CAR LST1)) 2))) (RETURN (if (ZEROP N) then (RPLACA LST1 NIL) (CAR LST1) else (for J from N by -1 to 2 as A on (CAR LST1) do (RPLACA A I) finally (RETURN (PROG1 (CDR A) (RPLACD A NIL] (RETURN LST]) ) (DECLARE: EVAL@COMPILE [PUTPROPS COLLECTN MACRO ((N) (PROG (VAL) (FRPTQ N (push VAL NIL)) (RETURN VAL] ) (* * Call (DESTRUCTIVE 600 50)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS DESTRUCTIVE COPYRIGHT ("HornBlower" 1983 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (518 1727 (DESTRUCTIVE 528 . 1725))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/DESTRUCTIVE.LCOM b/internal/gabriel/interlisp/DESTRUCTIVE.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..b409b8d05fd1cf407cd81d8595d94f3a257cde99 GIT binary patch literal 1091 zcma)6-%Hz26i!ooFrcJWMlC}QVX#EjlC;LQafmTZO*PGJ(1~v;hy^?=X~Ei_q*W>MN`*oU3K(4 za49LVu+~asGazLYX;P8X9Pr$FduzMt)m><}fP-h1<>&XydS17yx-~PWTbfZ)?ZxU$ zUava#lI9eb_2hI~0H&{;C@Eq}N#{7&3#xf{U1(yl2lbuyQ!tym+i*#pOeQ&S*Y=R` zYK8QqBFUV<@K-cLCSkP?5?L8UQIYYMZ>$kg;*<>QjkVU}`Y!CX72pe26_~!22*59^ zb`|;{jg+baZ12<$n(h7Fo>B$-l1miyxkNS%lB}dNN;<^>bF*GaLO&zC%TF@A3A_X) z5Wx}z2n|OmijJ_9H{@>odet!E?>9epe)~o=QW@BsJ^Nsm&R=$^ABGz`zSp_quDGGM zjYd4?FN7MWYA>Z2KkcOyhbYRY!zW+6)Cp}wxIr>pV|}X@4Ig%?L&65b8xjp|;xkB5 z9{nXU!jREg+zlU%`{Wjhoga^qcq!(S*w)3T8jf+g^Nqx#g#DZFXyfPc^x{DHL_)}; z7b7DPa=XU4;nzMHCvbkm6OJZaW6Y0^`GlpBpG4{I#S7#+`bgLY)?`DS?}Q6jAYcI> zQ#xlOC7hgfFGdWO;!~*%tQJ;uo0LJCnuLO>Tl0Jmj98AoteUeXQS%VYG*W(uK@SY%;lTvnB${gW9GC=0zzY|!rgV8 literal 0 HcmV?d00001 diff --git a/internal/gabriel/interlisp/DIV2 b/internal/gabriel/interlisp/DIV2 new file mode 100644 index 00000000..a56d5fa5 --- /dev/null +++ b/internal/gabriel/interlisp/DIV2 @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 00:41:53" {QV}BENCHMARKS>DIV2.;5 2082 changes to: (FNS LDIV2 DV2 TEST1 ITERATIVE-DIV2 TEST2 RECURSIVE-DIV2 FTEST1) (VARS DIV2COMS) previous date: "10-FEB-83 13:34:00" {QV}BENCHMARKS>DIV2.;1) (* Copyright (c) 1983, 1985 by RPG. All rights reserved.) (PRETTYCOMPRINT DIV2COMS) (RPAQQ DIV2COMS ((FNS CREATEN ITERATIVE-DIV2 RECURSIVE-DIV2 TEST1 TEST2) (VARS (L (CREATEN 200))) (* * Call (TEST1 L) for iterative test and (TEST2 L) for recursive test) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (CREATEN (LAMBDA (n) (* JonL "10-FEB-83 13:29") (to n collect NIL))) (ITERATIVE-DIV2 [LAMBDA (LST) (* jop: " 7-Nov-85 00:37") (for L A on LST by (CDDR L) do (push A (CAR L)) finally (RETURN A]) (RECURSIVE-DIV2 [LAMBDA (LST) (* jop: " 7-Nov-85 00:38") (if (NULL LST) then NIL else (CONS (CAR LST) (RECURSIVE-DIV2 (CDDR LST]) (TEST1 [LAMBDA (L) (* jop: " 7-Nov-85 00:38") (for I from 300 by -1 until (EQ I 0) do (ITERATIVE-DIV2 L) (ITERATIVE-DIV2 L) (ITERATIVE-DIV2 L) (ITERATIVE-DIV2 L]) (TEST2 [LAMBDA (L) (* jop: " 7-Nov-85 00:39") (for I from 300 by -1 until (EQ I 0) do (RECURSIVE-DIV2 L) (RECURSIVE-DIV2 L) (RECURSIVE-DIV2 L) (RECURSIVE-DIV2 L]) ) (RPAQ L (CREATEN 200)) (* * Call (TEST1 L) for iterative test and (TEST2 L) for recursive test) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS DIV2 COPYRIGHT ("RPG" 1983 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (625 1805 (CREATEN 635 . 772) (ITERATIVE-DIV2 774 . 993) (RECURSIVE-DIV2 995 . 1229) ( TEST1 1231 . 1516) (TEST2 1518 . 1803))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/DIV2.LCOM b/internal/gabriel/interlisp/DIV2.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..da793caab8177d162d18fd702a09bf604be7d8a4 GIT binary patch literal 1259 zcmbW1F>ljA6vv&k3|I)I152le2RK(avYkdr4XWbWm&WPUcF%6qB9^EzG&GH?#Ep;; zAA)bd#+rc+lz}hNPr#0Z)P)W19FivPP>I2o{QT~B|M%|y4%HokEsD($+aT$h(rovY zY6Y~4q3TAdA_0<);?uKkFX}+t2MONqwLZM?v5jef-OVlRT8&+k?gX2*)6$F2%QA>_ z992s>8xkZO(|g*1E~6YogZLeg?(ht5_AC~Q5_H-L+i8(dS~s+^B#UT4EL0RX9x2r_ zsH(B98RgR5;y_ocIvgFh`){HlB(VXg?gl`(cCgtahByc{a6(MY&}m^M{lkMgP;Bkf zU>2;WsWPCJNdw?{mbV+oa5jiW-S~W%mSTXUsY)GhDb*5aC4-fssuGBIbWxMV$)ULL z*;cBENCHMARKS>FFT.;3 4803 changes to: (FNS FFT) (VARS FFTCOMS) previous date: " 8-Nov-85 17:37:57" {QV}BENCHMARKS>FFT.;1) (* Copyright (c) 1983, 1985 by JonL. All rights reserved.) (PRETTYCOMPRINT FFTCOMS) (RPAQQ FFTCOMS ((FNS FFT FFT-BENCH) [VARS (RE (MAKE-ARRAY 1025 (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (IM (MAKE-ARRAY 1025 (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT] (MACROS IEXPT) (* * CALL (FFT-BENCH)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (FFT [LAMBDA (AREAL AIMAG) (* JonL "21-OCT-83 20:47") (* Fast Fourier Transform AREAL = real part AIMAG =  imaginary part) (* *) (PROG (AR AI PI I J K M N LE LE1 IP NV2 NM1 UR UI WR WI TR TI) (SETQ AR AREAL) (* Initialize) (SETQ AI AIMAG) (SETQ PI 3.141593) (SETQ N (ARRAY-DIMENSION AR 0)) (add N -1) (SETQ NV2 (LRSH N 1)) (SETQ NM1 (SUB1 N)) (SETQ M 0) (SETQ I 1) L1 (until (NOT (ILESSP I N)) do (* Compute M = log (N)) (add M 1) (add I I)) (* Note that Interlisp could do this by merely setting M = (SUB1 (INTEGERLENGTH N)) and testing  (POWEROFTWOP N)) (if (NOT (IEQP N (IEXPT 2 M))) then (ERROR "Array size not a power of two" N)) (SETQ J 1) (* ;Interchange elements) (SETQ I 1) (* ;in bit-reversed order) L3 (repeatuntil (NOT (ILESSP I N)) do (if (ILESSP I J) then (SETQ TR (LAREF AR J)) (SETQ TI (LAREF AI J)) (LASET (LAREF AR I) AR J) (LASET (LAREF AI I) AI J) (LASET TR AR I) (LASET TI AI I)) (SETQ K NV2) L6 (until (NOT (ILESSP K J)) do (SETQ J (IDIFFERENCE J K)) (SETQ K (LRSH K 1))) (SETQ J (IPLUS J K)) (add I 1)) (for L to M do (* ;Loop thru stages) (SETQ LE (IEXPT 2 L)) (SETQ LE1 (LRSH LE 1)) (SETQ UR 1.0) (SETQ UI 0.0) [SETQ WR (COS (FQUOTIENT PI (FLOAT LE1] [SETQ WI (SIN (FQUOTIENT PI (FLOAT LE1] (for J to LE1 do (* ;Loop thru butterflies) (for I from J by LE until (IGREATERP I N) do (* ;Do a butterfly) (SETQ IP (IPLUS I LE1)) (SETQ TR (FDIFFERENCE (FTIMES (LAREF AR IP) UR) (FTIMES (LAREF AI IP) UI))) (SETQ TI (FPLUS (FTIMES (LAREF AR IP) UI) (FTIMES (LAREF AI IP) UR))) (LASET (FDIFFERENCE (LAREF AR I) TR) AR IP) (LASET (FDIFFERENCE (LAREF AI I) TI) AI IP) (LASET (FPLUS (LAREF AR I) TR) AR I) (LASET (FPLUS (LAREF AI I) TI) AI I)) (SETQ TR (FDIFFERENCE (FTIMES UR WR) (FTIMES UI WI))) (SETQ TI (FPLUS (FTIMES UR WI) (FTIMES UI WR))) (SETQ UR TR) (SETQ UI TI))) (RETURN T]) (FFT-BENCH [LAMBDA NIL (* jop: " 8-Nov-85 17:36") (DECLARE (SPECVARS RE IM)) (for I from 1 to 10 do (FFT RE IM]) ) (RPAQ RE (MAKE-ARRAY 1025 (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (RPAQ IM (MAKE-ARRAY 1025 (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (DECLARE: EVAL@COMPILE [PUTPROPS IEXPT MACRO (X (PROG ([N (CAR (CONSTANTEXPRESSIONP (CAR X] (E (CADR X))) (RETURN (if (AND (FIXP N) (POWEROFTWOP N)) then [if (NEQ 2 N) then (SETQ E (BQUOTE (ITIMES , (SUB1 (INTEGERLENGTH N)) ,E] (BQUOTE (MASK.1'S , E 1)) else (BQUOTE (EXPT (IPLUS 0 , (CAR X)) (IPLUS 0 , (CADR X] ) (* * CALL (FFT-BENCH)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS FFT COPYRIGHT ("JonL" 1983 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (590 4025 (FFT 600 . 3816) (FFT-BENCH 3818 . 4023))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/FPRINT b/internal/gabriel/interlisp/FPRINT new file mode 100644 index 00000000..8c377a92 --- /dev/null +++ b/internal/gabriel/interlisp/FPRINT @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 00:34:26" {QV}BENCHMARKS>FPRINT.;4 1198 changes to: (FNS INIT-FPRINT FPRINT INIT1-FPRINT INIT INIT1) (VARS FPRINTCOMS) previous date: " 5-JUL-83 14:29:33" {QV}BENCHMARKS>FPRINT.;1) (PRETTYCOMPRINT FPRINTCOMS) (RPAQQ FPRINTCOMS ((FNS FPRINT) (* * Should be connected to {dsk}. The file FPRINT.TST should not exist. TESTPATTERN must already be defined) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (FPRINT [LAMBDA NIL (* jop: " 7-Nov-85 00:32") (DECLARE (GLOBALVARS TESTPATTERN)) (PROG [(F (INFILEP (QUOTE FPRINT.TST] (COND (F (DELFILE F))) (SETQ F (OPENFILE (QUOTE FPRINT.TST) (QUOTE OUTPUT))) (PRINT TESTPATTERN F) (RETURN (CLOSEF F]) ) (* * Should be connected to {dsk}. The file FPRINT.TST should not exist. TESTPATTERN must already be defined) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS FPRINT COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (516 920 (FPRINT 526 . 918))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/FPRINT.TST b/internal/gabriel/interlisp/FPRINT.TST new file mode 100644 index 00000000..47432311 --- /dev/null +++ b/internal/gabriel/interlisp/FPRINT.TST @@ -0,0 +1 @@ +NIL \ No newline at end of file diff --git a/internal/gabriel/interlisp/FREAD b/internal/gabriel/interlisp/FREAD new file mode 100644 index 00000000..78b6ec2d --- /dev/null +++ b/internal/gabriel/interlisp/FREAD @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 00:28:51" {QV}BENCHMARKS>FREAD.;3 829 changes to: (VARS FREADCOMS) previous date: " 5-JUL-83 14:36:33" {QV}BENCHMARKS>FREAD.;1) (PRETTYCOMPRINT FREADCOMS) (RPAQQ FREADCOMS ((FNS FREAD) (* * Should be run after FPRINT. Call (FREAD)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (FREAD (LAMBDA NIL (* JonL " 5-JUL-83 14:32") (PROG ((F (OPENFILE (QUOTE FPRINT.TST) (QUOTE INPUT)))) (READ F) (RETURN (CLOSEF F))))) ) (* * Should be run after FPRINT. Call (FREAD)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS FREAD COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (387 616 (FREAD 397 . 614))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/POLY b/internal/gabriel/interlisp/POLY new file mode 100644 index 00000000..586d0632 --- /dev/null +++ b/internal/gabriel/interlisp/POLY @@ -0,0 +1 @@ +(FILECREATED " 8-Nov-85 17:18:08" {QV}BENCHMARKS>POLY.;1 6694 changes to: (VARS IPOLYCOMS POLYMACROS) (FNS SETUP-POLY BENCH PTIMES3 PTIMES1 PTIMES2) previous date: "20-Feb-82 19:42:04" {PHYLUM}FRPOLY.IL;1) (PRETTYCOMPRINT POLYCOMS) (RPAQQ POLYCOMS ((FNS PCOEFADD PCPLUS PCPLUS1 PPLUS PTIMES PTIMES1 PTIMES2 PTIMES3 PSIMP PCTIMES PCTIMES1 PEXPTSQ PPLUS1 BENCH SETUP-POLY) (MACROS * POLYMACROS) (* * Call (SETUP-POLY) then (BENCH 2) (BENCH 5) (BENCH 10) and (BENCH 15)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))) (DEFINEQ (PCOEFADD [LAMBDA (E C X) (COND ((PZEROP C) X) (T (CONS E (CONS C X]) (PCPLUS [LAMBDA (C P) (COND ((PCOEFP P) (CPLUS P C)) (T (PSIMP (CAR P) (PCPLUS1 C (CDR P]) (PCPLUS1 [LAMBDA (C X) (COND [(NULL X) (COND ((PZEROP C) NIL) (T (CONS 0 (CONS C NIL] ((PZEROP (CAR X)) (PCOEFADD 0 (PPLUS C (CADR X)) NIL)) (T (CONS (CAR X) (CONS (CADR X) (PCPLUS1 C (CDDR X]) (PPLUS [LAMBDA (X Y) (COND ((PCOEFP X) (PCPLUS X Y)) ((PCOEFP Y) (PCPLUS Y X)) [(EQ (CAR X) (CAR Y)) (PSIMP (CAR X) (PPLUS1 (CDR Y) (CDR X] [(POINTERGP (CAR X) (CAR Y)) (PSIMP (CAR X) (PCPLUS1 Y (CDR X] (T (PSIMP (CAR Y) (PCPLUS1 X (CDR Y]) (PTIMES [LAMBDA (X Y) (COND ((OR (PZEROP X) (PZEROP Y)) (PZERO)) ((PCOEFP X) (PCTIMES X Y)) ((PCOEFP Y) (PCTIMES Y X)) [(EQ (CAR X) (CAR Y)) (PSIMP (CAR X) (PTIMES1 (CDR X) (CDR Y] [(POINTERGP (CAR X) (CAR Y)) (PSIMP (CAR X) (PCTIMES1 Y (CDR X] (T (PSIMP (CAR Y) (PCTIMES1 X (CDR Y]) (PTIMES1 [LAMBDA (*X* Y) (DECLARE (SPECVARS V *X* U*)) (* jop: " 8-Nov-85 17:13") (PROG (U* V) (SETQ V (SETQ U*(PTIMES2 Y))) A (SETQ *X*(CDDR *X*)) (COND ((NULL *X*) (RETURN U*))) (PTIMES3 Y) (GO A]) (PTIMES2 [LAMBDA (Y) (DECLARE (SPECVARS V *X* U*)) (* jop: " 8-Nov-85 17:14") (COND ((NULL Y) NIL) (T (PCOEFADD (PLUS (CAR *X*) (CAR Y)) (PTIMES (CADR *X*) (CADR Y)) (PTIMES2 (CDDR Y]) (PTIMES3 [LAMBDA (Y) (DECLARE (SPECVARS V *X* U*)) (* jop: " 8-Nov-85 17:14") (PROG (E U C) A1 (COND ((NULL Y) (RETURN NIL))) (SETQ E (IPLUS (CAR *X*) (CAR Y))) (SETQ C (PTIMES (CADR Y) (CADR *X*))) (COND ((PZEROP C) (SETQ Y (CDDR Y)) (GO A1)) ((OR (NULL V) (IGREATERP E (CAR V))) [SETQ U*(SETQ V (PPLUS1 U*(LIST E C] (SETQ Y (CDDR Y)) (GO A1)) ((IEQP E (CAR V)) (SETQ C (PPLUS C (CADR V))) (COND [(PZEROP C) (SETQ U*(SETQ V (PDIFFER1 U*(LIST (CAR V) (CADR V] (T (RPLACA (CDR V) C))) (SETQ Y (CDDR Y)) (GO A1))) A (COND ((AND (CDDR V) (IGREATERP (CADDR V) E)) (SETQ V (CDDR V)) (GO A))) (SETQ U (CDR V)) B (COND ((OR (NULL (CDR U)) (ILESSP (CADR U) E)) [RPLACD U (CONS E (CONS C (CDR U] (GO E))) (COND ((PZEROP (SETQ C (PPLUS (CADDR U) C))) (RPLACD U (CDDDR U)) (GO D)) (T (RPLACA (CDDR U) C))) E (SETQ U (CDDR U)) D (SETQ Y (CDDR Y)) (COND ((NULL Y) (RETURN NIL))) (SETQ E (IPLUS (CAR *X*) (CAR Y))) (SETQ C (PTIMES (CADR Y) (CADR *X*))) C (COND ((AND (CDR U) (IGREATERP (CADR U) E)) (SETQ U (CDDR U)) (GO C))) (GO B]) (PSIMP [LAMBDA (VAR X) (COND ((NULL X) 0) ((ATOM X) X) ((ZEROP (CAR X)) (CADR X)) (T (CONS VAR X]) (PCTIMES [LAMBDA (C P) (COND ((PCOEFP P) (CTIMES C P)) (T (PSIMP (CAR P) (PCTIMES1 C (CDR P]) (PCTIMES1 [LAMBDA (C X) (COND ((NULL X) NIL) (T (PCOEFADD (CAR X) (PTIMES C (CADR X)) (PCTIMES1 C (CDDR X]) (PEXPTSQ [LAMBDA (P N) (PROG (S) (SETQ S (COND ((ODDP N) P) (T 1))) (SETQ N (QUOTIENT N 2)) LOOP(COND ((ZEROP N) (RETURN S))) (SETQ P (PTIMES P P)) (AND (ODDP N) (SETQ S (PTIMES S P))) (SETQ N (QUOTIENT N 2)) (GO LOOP]) (PPLUS1 [LAMBDA (X Y) (COND ((NULL X) Y) ((NULL Y) X) [(IEQP (CAR X) (CAR Y)) (PCOEFADD (CAR X) (PPLUS (CADR X) (CADR Y)) (PPLUS1 (CDDR X) (CDDR Y] [(IGREATERP (CAR X) (CAR Y)) (CONS (CAR X) (CONS (CADR X) (PPLUS1 (CDDR X) Y] (T (CONS (CAR Y) (CONS (CADR Y) (PPLUS1 X (CDDR Y]) (BENCH [LAMBDA (N) (* jop: " 8-Nov-85 16:58") (DECLARE (SPECVARS R R2 R3)) (PEXPTSQ R N) (PEXPTSQ R2 N) (PEXPTSQ R3 N]) (SETUP-POLY [LAMBDA NIL (DECLARE (SPECVARS R R2 R3)) (* jop: " 8-Nov-85 16:59") (PUTPROP (QUOTE X) (QUOTE ORDER) 1) (PUTPROP (QUOTE Y) (QUOTE ORDER) 2) (PUTPROP (QUOTE Z) (QUOTE ORDER) 3) [SETQ R (PPLUS (QUOTE (X 1 1 0 1)) (PPLUS (QUOTE (Y 1 1)) (QUOTE (Z 1 1] (SETQ R2 (PTIMES R 100000)) (SETQ R3 (PTIMES R 1.0]) ) (RPAQQ POLYMACROS (CPLUS CTIMES PCOEFP POINTERGP PZERO PZEROP)) (DECLARE: EVAL@COMPILE (PUTPROPS CPLUS MACRO [LAMBDA (X Y) (PLUS X Y]) (PUTPROPS CTIMES MACRO [LAMBDA (X Y) (TIMES X Y]) (PUTPROPS PCOEFP MACRO [LAMBDA (E) (ATOM E]) [PUTPROPS POINTERGP MACRO (LAMBDA (X Y) (IGREATERP (GETPROP X (QUOTE ORDER)) (GETPROP Y (QUOTE ORDER] (PUTPROPS PZERO MACRO [LAMBDA NIL 0]) (PUTPROPS PZEROP MACRO [LAMBDA (X) (EQP X 0]) ) (* * Call (SETUP-POLY) then (BENCH 2) (BENCH 5) (BENCH 10) and (BENCH 15)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (621 6008 (PCOEFADD 631 . 719) (PCPLUS 721 . 832) (PCPLUS1 834 . 1083) (PPLUS 1085 . 1400) (PTIMES 1402 . 1765) (PTIMES1 1767 . 2091) (PTIMES2 2093 . 2415) (PTIMES3 2417 . 4173) (PSIMP 4175 . 4306) (PCTIMES 4308 . 4422) (PCTIMES1 4424 . 4560) (PEXPTSQ 4562 . 4889) (PPLUS1 4891 . 5270) ( BENCH 5272 . 5484) (SETUP-POLY 5486 . 6006))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/PUZZLE b/internal/gabriel/interlisp/PUZZLE new file mode 100644 index 00000000..f83998de --- /dev/null +++ b/internal/gabriel/interlisp/PUZZLE @@ -0,0 +1 @@ +(FILECREATED "12-Nov-85 17:21:33" {QV}BENCHMARKS>PUZZLE.;5 6119 changes to: (FNS FRESHPUZZLES START DEFINEPIECE TRIAL REMOVE! PLACE FIT) (VARS PUZZLECOMS) previous date: " 2-OCT-83 15:53:02" {PHYLUM}PUZZLE.;7) (* Copyright (c) 1982, 1983, 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PUZZLECOMS) (RPAQQ PUZZLECOMS ((CONSTANTS SIZE TYPEMAX D CLASSMAX) (FNS FIT PLACE REMOVE! TRIAL DEFINEPIECE START FRESHPUZZLES) (* * First Call (FRESHPUZZLES) then (START)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DECLARE: EVAL@COMPILE (RPAQQ SIZE 511) (RPAQQ TYPEMAX 12) (RPAQQ D 8) (RPAQQ CLASSMAX 3) (CONSTANTS SIZE TYPEMAX D CLASSMAX) ) (DEFINEQ (FIT [LAMBDA (I J) (* jop: "11-Nov-85 17:11") (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG)) (NOT (find K from 0 to (16AREF PIECEMAX I) suchthat (AND (PAREF P-PUZZLE I K) (PAREF PUZZLE (IPLUS J K]) (PLACE [LAMBDA (I J) (* jop: "11-Nov-85 17:11") (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG)) [for K from 0 to (16AREF PIECEMAX I) do (if (PAREF P-PUZZLE I K) then (PASET T PUZZLE (IPLUS J K] (16ASET (SUB1 (16AREF PIECECOUNT (16AREF CLASS I))) PIECECOUNT (16AREF CLASS I)) (OR (find K from J to SIZE suchthat (NOT (PAREF PUZZLE K))) 0]) (REMOVE! [LAMBDA (I J) (* jop: "11-Nov-85 17:11") (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG)) [for K from 0 to (16AREF PIECEMAX I) do (if (PAREF P-PUZZLE I K) then (PASET NIL PUZZLE (IPLUS J K] (16ASET (ADD1 (16AREF PIECECOUNT (16AREF CLASS I))) PIECECOUNT (16AREF CLASS I]) (TRIAL [LAMBDA (J) (* jop: "11-Nov-85 17:10") (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG) (SPECVARS KOUNT)) (bind (K _ 0) for I from 0 to TYPEMAX do (if (AND (NEQ 0 (16AREF PIECECOUNT (16AREF CLASS I))) (FIT I J)) then (SETQ K (PLACE I J)) (if (OR (TRIAL K) (ZEROP K)) then (AND PUZZLETRACEFLG (printout NIL T "Piece at " (ADD1 K))) (add KOUNT 1) (RETURN T) else (REMOVE! I J))) finally (PROGN (add KOUNT 1) NIL]) (DEFINEPIECE [LAMBDA (ICLASS II JJ KK) (* jop: "11-Nov-85 17:10") (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG)) (PROG ((INDEX 0)) [for I from 0 to II do (for J from 0 to JJ do (for K from 0 to KK do [SETQ INDEX (IPLUS I (ITIMES D (IPLUS J (ITIMES D K] (PASET T P-PUZZLE III INDEX] (16ASET ICLASS CLASS III) (16ASET INDEX PIECEMAX III) (if (NEQ III TYPEMAX) then (add III 1]) (START [LAMBDA NIL (* jop: "11-Nov-85 17:23") (* *) (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG) (SPECVARS KOUNT)) (for M from 0 to SIZE do (PASET T PUZZLE M)) [for I from 1 to 5 do (for J from 1 to 5 do (for K from 1 to 5 do (PASET NIL PUZZLE (IPLUS I (ITIMES D (IPLUS J (ITIMES D K] (for I from 0 to TYPEMAX do (for M from 0 to SIZE do (PASET NIL P-PUZZLE I M))) (SETQ III 0) (DEFINEPIECE 0 3 1 0) (DEFINEPIECE 0 1 0 3) (DEFINEPIECE 0 0 3 1) (DEFINEPIECE 0 1 3 0) (DEFINEPIECE 0 3 0 1) (DEFINEPIECE 0 0 1 3) (DEFINEPIECE 1 2 0 0) (DEFINEPIECE 1 0 2 0) (DEFINEPIECE 1 0 0 2) (DEFINEPIECE 2 1 1 0) (DEFINEPIECE 2 1 0 1) (DEFINEPIECE 2 0 1 1) (DEFINEPIECE 3 1 1 1) (16ASET 13 PIECECOUNT 0) (16ASET 3 PIECECOUNT 1) (16ASET 1 PIECECOUNT 2) (16ASET 1 PIECECOUNT 3) (PROG ([M (IPLUS 1 (ITIMES D (IPLUS 1 D] (N 0) (KOUNT 0)) (if (FIT 0 M) then (SETQ N (PLACE 0 M)) else (printout NIL T "Error")) (if (TRIAL N) then (printout NIL T "Success in " KOUNT " trials.") else (printout NIL T "Failure.")) (TERPRI]) (FRESHPUZZLES [LAMBDA NIL (* jop: "11-Nov-85 17:29") (DECLARE (GLOBALVARS CLASS PIECEMAX PUZZLE P-PUZZLE PIECECOUNT III PUZZLETRACEFLG)) (SETQ III 0) (SETQ PUZZLETRACEFLG NIL) [SETQ CLASS (MAKE-ARRAY (ADD1 TYPEMAX) (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 16] [SETQ PIECEMAX (MAKE-ARRAY (ADD1 TYPEMAX) (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 16] (SETQ PUZZLE (MAKE-ARRAY (IPLUS SIZE 2))) [SETQ P-PUZZLE (MAKE-ARRAY (LIST (ADD1 TYPEMAX) (ADD1 SIZE] [SETQ PIECECOUNT (MAKE-ARRAY (ADD1 CLASSMAX) (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 16] NIL]) ) (* * First Call (FRESHPUZZLES) then (START)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS PUZZLE COPYRIGHT ("Xerox Corporation" 1982 1983 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (777 5877 (FIT 787 . 1140) (PLACE 1142 . 1671) (REMOVE! 1673 . 2111) (TRIAL 2113 . 2817) (DEFINEPIECE 2819 . 3493) (START 3495 . 5071) (FRESHPUZZLES 5073 . 5875))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/STAK b/internal/gabriel/interlisp/STAK new file mode 100644 index 00000000..bf0a14e3 --- /dev/null +++ b/internal/gabriel/interlisp/STAK @@ -0,0 +1 @@ +(FILECREATED " 6-Nov-85 22:32:57" {QV}BENCHMARKS>STAK.;3 1354 changes to: (FNS STAK INIT-STAK TAK) (VARS STAKCOMS) previous date: " 5-JUL-83 12:48:46" {QV}BENCHMARKS>STAK.;1) (PRETTYCOMPRINT STAKCOMS) (RPAQQ STAKCOMS ((FNS INIT-STAK STAK) (* * Call (INIT-STAK) then (STAK)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (INIT-STAK [LAMBDA NIL (DECLARE (SPECVARS X Y Z)) (* jop: " 6-Nov-85 22:29") (SETQ X 18) (SETQ Y 12) (SETQ Z 6]) (STAK [LAMBDA NIL (* jop: " 6-Nov-85 22:27") (DECLARE (SPECVARS X Y Z)) (COND ((NOT (ILESSP Y X)) Z) (T (PROG [[X (PROG ((X (SUB1 X)) (Y Y) (Z Z)) (RETURN (STAK] [Y (PROG ((X (SUB1 Y)) (Y Z) (Z X)) (RETURN (STAK] (Z (PROG ((X (SUB1 Z)) (Y X) (Z Y)) (RETURN (STAK] (RETURN (STAK]) ) (* * Call (INIT-STAK) then (STAK)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS STAK COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (423 1154 (INIT-STAK 433 . 617) (STAK 619 . 1152))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TAK b/internal/gabriel/interlisp/TAK new file mode 100644 index 00000000..605c725b --- /dev/null +++ b/internal/gabriel/interlisp/TAK @@ -0,0 +1 @@ +(FILECREATED " 6-Nov-85 22:32:40" {QV}BENCHMARKS>TAK.;3 742 changes to: (VARS TAKCOMS) (FNS TAK) previous date: "14-FEB-83 10:11:44" {QV}BENCHMARKS>TAK.;1) (PRETTYCOMPRINT TAKCOMS) (RPAQQ TAKCOMS ((FNS TAK) (* * Call (TAK 18 12 6)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (TAK [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK (TAK (SUB1 X) Y Z) (TAK (SUB1 Y) Z X) (TAK (SUB1 Z) X Y]) ) (* * Call (TAK 18 12 6)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (364 585 (TAK 374 . 583))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TAKL b/internal/gabriel/interlisp/TAKL new file mode 100644 index 00000000..648dd7a1 --- /dev/null +++ b/internal/gabriel/interlisp/TAKL @@ -0,0 +1 @@ +(FILECREATED " 6-Nov-85 22:32:09" {QV}BENCHMARKS>TAKL.;3 1331 changes to: (VARS TAKLCOMS) previous date: "14-FEB-83 11:45:11" {QV}BENCHMARKS>TAKL.;1) (PRETTYCOMPRINT TAKLCOMS) (RPAQQ TAKLCOMS ((FNS LISTN TAKL SHORTERP) (* * Call (TAKL 18L 12L 6L)) (VARS 18L 12L 6L) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (LISTN [LAMBDA (N) (* lmm "28-APR-82 21:41") (COND ((ZEROP N) NIL) (T (CONS N (LISTN (SUB1 N]) (TAKL [LAMBDA (X Y Z) (* lmm "28-APR-82 21:39") (COND ((NOT (SHORTERP Y X)) Z) (T (TAKL (TAKL (CDR X) Y Z) (TAKL (CDR Y) Z X) (TAKL (CDR Z) X Y]) (SHORTERP [LAMBDA (X Y) (* lmm "28-APR-82 21:38") (AND Y (OR (NULL X) (SHORTERP (CDR X) (CDR Y]) ) (* * Call (TAKL 18L 12L 6L)) (RPAQQ 18L (18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)) (RPAQQ 12L (12 11 10 9 8 7 6 5 4 3 2 1)) (RPAQQ 6L (6 5 4 3 2 1)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (399 1030 (LISTN 409 . 581) (TAKL 583 . 855) (SHORTERP 857 . 1028))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TAKR b/internal/gabriel/interlisp/TAKR new file mode 100644 index 00000000..26094082 --- /dev/null +++ b/internal/gabriel/interlisp/TAKR @@ -0,0 +1 @@ +(FILECREATED " 6-Nov-85 22:30:49" {QV}BENCHMARKS>TAKR.;3 20916 changes to: (VARS TAKRCOMS) (FNS TAK1) previous date: "14-FEB-83 10:52:35" {QV}BENCHMARKS>TAKR.;1) (PRETTYCOMPRINT TAKRCOMS) (RPAQQ TAKRCOMS ((FNS TAKR TAK0 TAK1 TAK2 TAK3 TAK4 TAK5 TAK6 TAK7 TAK8 TAK9 TAK10 TAK11 TAK12 TAK13 TAK14 TAK15 TAK16 TAK17 TAK18 TAK19 TAK20 TAK21 TAK22 TAK23 TAK24 TAK25 TAK26 TAK27 TAK28 TAK29 TAK30 TAK31 TAK32 TAK33 TAK34 TAK35 TAK36 TAK37 TAK38 TAK39 TAK40 TAK41 TAK42 TAK43 TAK44 TAK45 TAK46 TAK47 TAK48 TAK49 TAK50 TAK51 TAK52 TAK53 TAK54 TAK55 TAK56 TAK57 TAK58 TAK59 TAK60 TAK61 TAK62 TAK63 TAK64 TAK65 TAK66 TAK67 TAK68 TAK69 TAK70 TAK71 TAK72 TAK73 TAK74 TAK75 TAK76 TAK77 TAK78 TAK79 TAK80 TAK81 TAK82 TAK83 TAK84 TAK85 TAK86 TAK87 TAK88 TAK89 TAK90 TAK91 TAK92 TAK93 TAK94 TAK95 TAK96 TAK97 TAK98 TAK99) (* * Call (TAKR 18 12 6)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (TAKR [LAMBDA NIL (TAK0 18 12 6]) (TAK0 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK1 (TAK37 (SUB1 X) Y Z) (TAK11 (SUB1 Y) Z X) (TAK17 (SUB1 Z) X Y]) (TAK1 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK2 (TAK74 (SUB1 X) Y Z) (TAK22 (SUB1 Y) Z X) (TAK34 (SUB1 Z) X Y]) (TAK2 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK3 (TAK11 (SUB1 X) Y Z) (TAK33 (SUB1 Y) Z X) (TAK51 (SUB1 Z) X Y]) (TAK3 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK4 (TAK48 (SUB1 X) Y Z) (TAK44 (SUB1 Y) Z X) (TAK68 (SUB1 Z) X Y]) (TAK4 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK5 (TAK85 (SUB1 X) Y Z) (TAK55 (SUB1 Y) Z X) (TAK85 (SUB1 Z) X Y]) (TAK5 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK6 (TAK22 (SUB1 X) Y Z) (TAK66 (SUB1 Y) Z X) (TAK2 (SUB1 Z) X Y]) (TAK6 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK7 (TAK59 (SUB1 X) Y Z) (TAK77 (SUB1 Y) Z X) (TAK19 (SUB1 Z) X Y]) (TAK7 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK8 (TAK96 (SUB1 X) Y Z) (TAK88 (SUB1 Y) Z X) (TAK36 (SUB1 Z) X Y]) (TAK8 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK9 (TAK33 (SUB1 X) Y Z) (TAK99 (SUB1 Y) Z X) (TAK53 (SUB1 Z) X Y]) (TAK9 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK10 (TAK70 (SUB1 X) Y Z) (TAK10 (SUB1 Y) Z X) (TAK70 (SUB1 Z) X Y]) (TAK10 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK11 (TAK7 (SUB1 X) Y Z) (TAK21 (SUB1 Y) Z X) (TAK87 (SUB1 Z) X Y]) (TAK11 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK12 (TAK44 (SUB1 X) Y Z) (TAK32 (SUB1 Y) Z X) (TAK4 (SUB1 Z) X Y]) (TAK12 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK13 (TAK81 (SUB1 X) Y Z) (TAK43 (SUB1 Y) Z X) (TAK21 (SUB1 Z) X Y]) (TAK13 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK14 (TAK18 (SUB1 X) Y Z) (TAK54 (SUB1 Y) Z X) (TAK38 (SUB1 Z) X Y]) (TAK14 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK15 (TAK55 (SUB1 X) Y Z) (TAK65 (SUB1 Y) Z X) (TAK55 (SUB1 Z) X Y]) (TAK15 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK16 (TAK92 (SUB1 X) Y Z) (TAK76 (SUB1 Y) Z X) (TAK72 (SUB1 Z) X Y]) (TAK16 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK17 (TAK29 (SUB1 X) Y Z) (TAK87 (SUB1 Y) Z X) (TAK89 (SUB1 Z) X Y]) (TAK17 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK18 (TAK66 (SUB1 X) Y Z) (TAK98 (SUB1 Y) Z X) (TAK6 (SUB1 Z) X Y]) (TAK18 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK19 (TAK3 (SUB1 X) Y Z) (TAK9 (SUB1 Y) Z X) (TAK23 (SUB1 Z) X Y]) (TAK19 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK20 (TAK40 (SUB1 X) Y Z) (TAK20 (SUB1 Y) Z X) (TAK40 (SUB1 Z) X Y]) (TAK20 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK21 (TAK77 (SUB1 X) Y Z) (TAK31 (SUB1 Y) Z X) (TAK57 (SUB1 Z) X Y]) (TAK21 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK22 (TAK14 (SUB1 X) Y Z) (TAK42 (SUB1 Y) Z X) (TAK74 (SUB1 Z) X Y]) (TAK22 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK23 (TAK51 (SUB1 X) Y Z) (TAK53 (SUB1 Y) Z X) (TAK91 (SUB1 Z) X Y]) (TAK23 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK24 (TAK88 (SUB1 X) Y Z) (TAK64 (SUB1 Y) Z X) (TAK8 (SUB1 Z) X Y]) (TAK24 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK25 (TAK25 (SUB1 X) Y Z) (TAK75 (SUB1 Y) Z X) (TAK25 (SUB1 Z) X Y]) (TAK25 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK26 (TAK62 (SUB1 X) Y Z) (TAK86 (SUB1 Y) Z X) (TAK42 (SUB1 Z) X Y]) (TAK26 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK27 (TAK99 (SUB1 X) Y Z) (TAK97 (SUB1 Y) Z X) (TAK59 (SUB1 Z) X Y]) (TAK27 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK28 (TAK36 (SUB1 X) Y Z) (TAK8 (SUB1 Y) Z X) (TAK76 (SUB1 Z) X Y]) (TAK28 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK29 (TAK73 (SUB1 X) Y Z) (TAK19 (SUB1 Y) Z X) (TAK93 (SUB1 Z) X Y]) (TAK29 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK30 (TAK10 (SUB1 X) Y Z) (TAK30 (SUB1 Y) Z X) (TAK10 (SUB1 Z) X Y]) (TAK30 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK31 (TAK47 (SUB1 X) Y Z) (TAK41 (SUB1 Y) Z X) (TAK27 (SUB1 Z) X Y]) (TAK31 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK32 (TAK84 (SUB1 X) Y Z) (TAK52 (SUB1 Y) Z X) (TAK44 (SUB1 Z) X Y]) (TAK32 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK33 (TAK21 (SUB1 X) Y Z) (TAK63 (SUB1 Y) Z X) (TAK61 (SUB1 Z) X Y]) (TAK33 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK34 (TAK58 (SUB1 X) Y Z) (TAK74 (SUB1 Y) Z X) (TAK78 (SUB1 Z) X Y]) (TAK34 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK35 (TAK95 (SUB1 X) Y Z) (TAK85 (SUB1 Y) Z X) (TAK95 (SUB1 Z) X Y]) (TAK35 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK36 (TAK32 (SUB1 X) Y Z) (TAK96 (SUB1 Y) Z X) (TAK12 (SUB1 Z) X Y]) (TAK36 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK37 (TAK69 (SUB1 X) Y Z) (TAK7 (SUB1 Y) Z X) (TAK29 (SUB1 Z) X Y]) (TAK37 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK38 (TAK6 (SUB1 X) Y Z) (TAK18 (SUB1 Y) Z X) (TAK46 (SUB1 Z) X Y]) (TAK38 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK39 (TAK43 (SUB1 X) Y Z) (TAK29 (SUB1 Y) Z X) (TAK63 (SUB1 Z) X Y]) (TAK39 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK40 (TAK80 (SUB1 X) Y Z) (TAK40 (SUB1 Y) Z X) (TAK80 (SUB1 Z) X Y]) (TAK40 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK41 (TAK17 (SUB1 X) Y Z) (TAK51 (SUB1 Y) Z X) (TAK97 (SUB1 Z) X Y]) (TAK41 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK42 (TAK54 (SUB1 X) Y Z) (TAK62 (SUB1 Y) Z X) (TAK14 (SUB1 Z) X Y]) (TAK42 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK43 (TAK91 (SUB1 X) Y Z) (TAK73 (SUB1 Y) Z X) (TAK31 (SUB1 Z) X Y]) (TAK43 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK44 (TAK28 (SUB1 X) Y Z) (TAK84 (SUB1 Y) Z X) (TAK48 (SUB1 Z) X Y]) (TAK44 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK45 (TAK65 (SUB1 X) Y Z) (TAK95 (SUB1 Y) Z X) (TAK65 (SUB1 Z) X Y]) (TAK45 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK46 (TAK2 (SUB1 X) Y Z) (TAK6 (SUB1 Y) Z X) (TAK82 (SUB1 Z) X Y]) (TAK46 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK47 (TAK39 (SUB1 X) Y Z) (TAK17 (SUB1 Y) Z X) (TAK99 (SUB1 Z) X Y]) (TAK47 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK48 (TAK76 (SUB1 X) Y Z) (TAK28 (SUB1 Y) Z X) (TAK16 (SUB1 Z) X Y]) (TAK48 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK49 (TAK13 (SUB1 X) Y Z) (TAK39 (SUB1 Y) Z X) (TAK33 (SUB1 Z) X Y]) (TAK49 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK50 (TAK50 (SUB1 X) Y Z) (TAK50 (SUB1 Y) Z X) (TAK50 (SUB1 Z) X Y]) (TAK50 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK51 (TAK87 (SUB1 X) Y Z) (TAK61 (SUB1 Y) Z X) (TAK67 (SUB1 Z) X Y]) (TAK51 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK52 (TAK24 (SUB1 X) Y Z) (TAK72 (SUB1 Y) Z X) (TAK84 (SUB1 Z) X Y]) (TAK52 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK53 (TAK61 (SUB1 X) Y Z) (TAK83 (SUB1 Y) Z X) (TAK1 (SUB1 Z) X Y]) (TAK53 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK54 (TAK98 (SUB1 X) Y Z) (TAK94 (SUB1 Y) Z X) (TAK18 (SUB1 Z) X Y]) (TAK54 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK55 (TAK35 (SUB1 X) Y Z) (TAK5 (SUB1 Y) Z X) (TAK35 (SUB1 Z) X Y]) (TAK55 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK56 (TAK72 (SUB1 X) Y Z) (TAK16 (SUB1 Y) Z X) (TAK52 (SUB1 Z) X Y]) (TAK56 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK57 (TAK9 (SUB1 X) Y Z) (TAK27 (SUB1 Y) Z X) (TAK69 (SUB1 Z) X Y]) (TAK57 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK58 (TAK46 (SUB1 X) Y Z) (TAK38 (SUB1 Y) Z X) (TAK86 (SUB1 Z) X Y]) (TAK58 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK59 (TAK83 (SUB1 X) Y Z) (TAK49 (SUB1 Y) Z X) (TAK3 (SUB1 Z) X Y]) (TAK59 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK60 (TAK20 (SUB1 X) Y Z) (TAK60 (SUB1 Y) Z X) (TAK20 (SUB1 Z) X Y]) (TAK60 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK61 (TAK57 (SUB1 X) Y Z) (TAK71 (SUB1 Y) Z X) (TAK37 (SUB1 Z) X Y]) (TAK61 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK62 (TAK94 (SUB1 X) Y Z) (TAK82 (SUB1 Y) Z X) (TAK54 (SUB1 Z) X Y]) (TAK62 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK63 (TAK31 (SUB1 X) Y Z) (TAK93 (SUB1 Y) Z X) (TAK71 (SUB1 Z) X Y]) (TAK63 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK64 (TAK68 (SUB1 X) Y Z) (TAK4 (SUB1 Y) Z X) (TAK88 (SUB1 Z) X Y]) (TAK64 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK65 (TAK5 (SUB1 X) Y Z) (TAK15 (SUB1 Y) Z X) (TAK5 (SUB1 Z) X Y]) (TAK65 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK66 (TAK42 (SUB1 X) Y Z) (TAK26 (SUB1 Y) Z X) (TAK22 (SUB1 Z) X Y]) (TAK66 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK67 (TAK79 (SUB1 X) Y Z) (TAK37 (SUB1 Y) Z X) (TAK39 (SUB1 Z) X Y]) (TAK67 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK68 (TAK16 (SUB1 X) Y Z) (TAK48 (SUB1 Y) Z X) (TAK56 (SUB1 Z) X Y]) (TAK68 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK69 (TAK53 (SUB1 X) Y Z) (TAK59 (SUB1 Y) Z X) (TAK73 (SUB1 Z) X Y]) (TAK69 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK70 (TAK90 (SUB1 X) Y Z) (TAK70 (SUB1 Y) Z X) (TAK90 (SUB1 Z) X Y]) (TAK70 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK71 (TAK27 (SUB1 X) Y Z) (TAK81 (SUB1 Y) Z X) (TAK7 (SUB1 Z) X Y]) (TAK71 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK72 (TAK64 (SUB1 X) Y Z) (TAK92 (SUB1 Y) Z X) (TAK24 (SUB1 Z) X Y]) (TAK72 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK73 (TAK1 (SUB1 X) Y Z) (TAK3 (SUB1 Y) Z X) (TAK41 (SUB1 Z) X Y]) (TAK73 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK74 (TAK38 (SUB1 X) Y Z) (TAK14 (SUB1 Y) Z X) (TAK58 (SUB1 Z) X Y]) (TAK74 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK75 (TAK75 (SUB1 X) Y Z) (TAK25 (SUB1 Y) Z X) (TAK75 (SUB1 Z) X Y]) (TAK75 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK76 (TAK12 (SUB1 X) Y Z) (TAK36 (SUB1 Y) Z X) (TAK92 (SUB1 Z) X Y]) (TAK76 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK77 (TAK49 (SUB1 X) Y Z) (TAK47 (SUB1 Y) Z X) (TAK9 (SUB1 Z) X Y]) (TAK77 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK78 (TAK86 (SUB1 X) Y Z) (TAK58 (SUB1 Y) Z X) (TAK26 (SUB1 Z) X Y]) (TAK78 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK79 (TAK23 (SUB1 X) Y Z) (TAK69 (SUB1 Y) Z X) (TAK43 (SUB1 Z) X Y]) (TAK79 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK80 (TAK60 (SUB1 X) Y Z) (TAK80 (SUB1 Y) Z X) (TAK60 (SUB1 Z) X Y]) (TAK80 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK81 (TAK97 (SUB1 X) Y Z) (TAK91 (SUB1 Y) Z X) (TAK77 (SUB1 Z) X Y]) (TAK81 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK82 (TAK34 (SUB1 X) Y Z) (TAK2 (SUB1 Y) Z X) (TAK94 (SUB1 Z) X Y]) (TAK82 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK83 (TAK71 (SUB1 X) Y Z) (TAK13 (SUB1 Y) Z X) (TAK11 (SUB1 Z) X Y]) (TAK83 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK84 (TAK8 (SUB1 X) Y Z) (TAK24 (SUB1 Y) Z X) (TAK28 (SUB1 Z) X Y]) (TAK84 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK85 (TAK45 (SUB1 X) Y Z) (TAK35 (SUB1 Y) Z X) (TAK45 (SUB1 Z) X Y]) (TAK85 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK86 (TAK82 (SUB1 X) Y Z) (TAK46 (SUB1 Y) Z X) (TAK62 (SUB1 Z) X Y]) (TAK86 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK87 (TAK19 (SUB1 X) Y Z) (TAK57 (SUB1 Y) Z X) (TAK79 (SUB1 Z) X Y]) (TAK87 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK88 (TAK56 (SUB1 X) Y Z) (TAK68 (SUB1 Y) Z X) (TAK96 (SUB1 Z) X Y]) (TAK88 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK89 (TAK93 (SUB1 X) Y Z) (TAK79 (SUB1 Y) Z X) (TAK13 (SUB1 Z) X Y]) (TAK89 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK90 (TAK30 (SUB1 X) Y Z) (TAK90 (SUB1 Y) Z X) (TAK30 (SUB1 Z) X Y]) (TAK90 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK91 (TAK67 (SUB1 X) Y Z) (TAK1 (SUB1 Y) Z X) (TAK47 (SUB1 Z) X Y]) (TAK91 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK92 (TAK4 (SUB1 X) Y Z) (TAK12 (SUB1 Y) Z X) (TAK64 (SUB1 Z) X Y]) (TAK92 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK93 (TAK41 (SUB1 X) Y Z) (TAK23 (SUB1 Y) Z X) (TAK81 (SUB1 Z) X Y]) (TAK93 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK94 (TAK78 (SUB1 X) Y Z) (TAK34 (SUB1 Y) Z X) (TAK98 (SUB1 Z) X Y]) (TAK94 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK95 (TAK15 (SUB1 X) Y Z) (TAK45 (SUB1 Y) Z X) (TAK15 (SUB1 Z) X Y]) (TAK95 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK96 (TAK52 (SUB1 X) Y Z) (TAK56 (SUB1 Y) Z X) (TAK32 (SUB1 Z) X Y]) (TAK96 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK97 (TAK89 (SUB1 X) Y Z) (TAK67 (SUB1 Y) Z X) (TAK49 (SUB1 Z) X Y]) (TAK97 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK98 (TAK26 (SUB1 X) Y Z) (TAK78 (SUB1 Y) Z X) (TAK66 (SUB1 Z) X Y]) (TAK98 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK99 (TAK63 (SUB1 X) Y Z) (TAK89 (SUB1 Y) Z X) (TAK83 (SUB1 Z) X Y]) (TAK99 [LAMBDA (X Y Z) (COND ((NOT (ILESSP Y X)) Z) (T (TAK0 (TAK0 (SUB1 X) Y Z) (TAK0 (SUB1 Y) Z X) (TAK0 (SUB1 Z) X Y]) ) (* * Call (TAKR 18 12 6)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (984 20758 (TAKR 994 . 1041) (TAK0 1043 . 1245) (TAK1 1247 . 1454) (TAK2 1456 . 1658) ( TAK3 1660 . 1862) (TAK4 1864 . 2066) (TAK5 2068 . 2268) (TAK6 2270 . 2472) (TAK7 2474 . 2676) (TAK8 2678 . 2880) (TAK9 2882 . 3076) (TAK10 3078 . 3271) (TAK11 3273 . 3466) (TAK12 3468 . 3663) (TAK13 3665 . 3860) (TAK14 3862 . 4057) (TAK15 4059 . 4254) (TAK16 4256 . 4451) (TAK17 4453 . 4646) (TAK18 4648 . 4839) (TAK19 4841 . 5036) (TAK20 5038 . 5233) (TAK21 5235 . 5430) (TAK22 5432 . 5627) (TAK23 5629 . 5822) (TAK24 5824 . 6019) (TAK25 6021 . 6216) (TAK26 6218 . 6413) (TAK27 6415 . 6608) (TAK28 6610 . 6805) (TAK29 6807 . 7002) (TAK30 7004 . 7199) (TAK31 7201 . 7396) (TAK32 7398 . 7593) (TAK33 7595 . 7790) (TAK34 7792 . 7987) (TAK35 7989 . 8184) (TAK36 8186 . 8379) (TAK37 8381 . 8574) (TAK38 8576 . 8771) (TAK39 8773 . 8968) (TAK40 8970 . 9165) (TAK41 9167 . 9362) (TAK42 9364 . 9559) (TAK43 9561 . 9756) (TAK44 9758 . 9953) (TAK45 9955 . 10146) (TAK46 10148 . 10343) (TAK47 10345 . 10540) ( TAK48 10542 . 10737) (TAK49 10739 . 10934) (TAK50 10936 . 11131) (TAK51 11133 . 11328) (TAK52 11330 . 11523) (TAK53 11525 . 11720) (TAK54 11722 . 11915) (TAK55 11917 . 12112) (TAK56 12114 . 12307) (TAK57 12309 . 12504) (TAK58 12506 . 12699) (TAK59 12701 . 12896) (TAK60 12898 . 13093) (TAK61 13095 . 13290) (TAK62 13292 . 13487) (TAK63 13489 . 13682) (TAK64 13684 . 13875) (TAK65 13877 . 14072) (TAK66 14074 . 14269) (TAK67 14271 . 14466) (TAK68 14468 . 14663) (TAK69 14665 . 14860) (TAK70 14862 . 15055) ( TAK71 15057 . 15252) (TAK72 15254 . 15445) (TAK73 15447 . 15642) (TAK74 15644 . 15839) (TAK75 15841 . 16036) (TAK76 16038 . 16231) (TAK77 16233 . 16428) (TAK78 16430 . 16625) (TAK79 16627 . 16822) (TAK80 16824 . 17019) (TAK81 17021 . 17214) (TAK82 17216 . 17411) (TAK83 17413 . 17606) (TAK84 17608 . 17803) (TAK85 17805 . 18000) (TAK86 18002 . 18197) (TAK87 18199 . 18394) (TAK88 18396 . 18591) (TAK89 18593 . 18788) (TAK90 18790 . 18983) (TAK91 18985 . 19178) (TAK92 19180 . 19375) (TAK93 19377 . 19572) ( TAK94 19574 . 19769) (TAK95 19771 . 19966) (TAK96 19968 . 20163) (TAK97 20165 . 20360) (TAK98 20362 . 20557) (TAK99 20559 . 20756))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TESTPATTERN b/internal/gabriel/interlisp/TESTPATTERN new file mode 100644 index 00000000..79b3239e --- /dev/null +++ b/internal/gabriel/interlisp/TESTPATTERN @@ -0,0 +1 @@ +(FILECREATED " 6-Nov-85 22:14:20" {QV}BENCHMARKS>TESTPATTERN.;1 1946 changes to: (VARS TESTPATTERNCOMS) (FNS AUX-MAKE-TESTPATTERN MAKE-TESTPATTERN CREATE-TESTPATTERN)) (PRETTYCOMPRINT TESTPATTERNCOMS) (RPAQQ TESTPATTERNCOMS ((FNS AUX-MAKE-TESTPATTERN CREATE-TESTPATTERN MAKE-TESTPATTERN) (VARS TESTATOMS) (* * MAKE-TESTPATTERN will setup the testpattern necessary for TPRINT and FPRINT) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (AUX-MAKE-TESTPATTERN [LAMBDA (M N ATOMS) (* jop: " 6-Nov-85 21:57") (COND ((ZEROP M) (pop ATOMS)) (T (bind A for I from N by -2 until (ILESSP I 1) do (push A (pop ATOMS)) (push A (AUX-MAKE-TESTPATTERN (SUB1 M) N ATOMS)) finally (RETURN A]) (CREATE-TESTPATTERN [LAMBDA NIL (DECLARE (GLOBALVARS TESTPATTERN) (SPECVARS TESTATOMS)) (* jop: " 6-Nov-85 22:11") (SETQ TESTPATTERN (MAKE-TESTPATTERN 6 6 TESTATOMS]) (MAKE-TESTPATTERN [LAMBDA (M N ATOMS) (* jop: " 6-Nov-85 21:57") (PROG ((ATOMS (SUBST NIL NIL ATOMS))) (bind (A _ ATOMS) until (NULL (CDR A)) do (pop A) finally (RPLACD A ATOMS) ) (RETURN (AUX-MAKE-TESTPATTERN M N ATOMS]) ) (RPAQQ TESTATOMS (ABCDEF12 CDEFGH23 EFGHIJ34 GHIJKL45 IJKLMN56 KLMNOP67 MNOPQR78 OPRST89 QRSTUV90 STUVWX01 UVWXYZ12 WXYZAB23 XYZABC34 123456AB 234567BC 345678CD 456789DE 567890EF 678901FG 789012GH 890123HI)) (* * MAKE-TESTPATTERN will setup the testpattern necessary for TPRINT and FPRINT) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (517 1501 (AUX-MAKE-TESTPATTERN 527 . 923) (CREATE-TESTPATTERN 925 . 1159) ( MAKE-TESTPATTERN 1161 . 1499))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TPRINT b/internal/gabriel/interlisp/TPRINT new file mode 100644 index 00000000..96e99b48 --- /dev/null +++ b/internal/gabriel/interlisp/TPRINT @@ -0,0 +1 @@ +(FILECREATED " 6-Nov-85 22:23:53" {QV}BENCHMARKS>TPRINT.;5 1278 changes to: (FNS INIT-TPRINT TPRINT INIT1-TPRINT TIMIT INIT) (VARS TPRINTCOMS) previous date: "26-Jan-84 00:51:25" {QV}BENCHMARKS>TPRINT.;1) (PRETTYCOMPRINT TPRINTCOMS) (RPAQQ TPRINTCOMS ((FNS INIT-TPRINT TPRINT) (* * Testpattern must exist first. Then call (INIT-TPRINT) and then (TPRINT)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (INIT-TPRINT [LAMBDA NIL (* jop: " 6-Nov-85 22:21") (DECLARE (GLOBALVARS BIGWINDOW)) (SETQ BIGWINDOW (CREATEW (create REGION LEFT _ 150 BOTTOM _ 50 WIDTH _ 800 HEIGHT _ 700))) (DSPSCROLL T BIGWINDOW]) (TPRINT [LAMBDA NIL (* jop: " 6-Nov-85 22:17") (DECLARE (GLOBALVARS TESTPATTERN BIGWINDOW)) (PRINT TESTPATTERN BIGWINDOW]) ) (* * Testpattern must exist first. Then call (INIT-TPRINT) and then (TPRINT)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TPRINT COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (495 1033 (INIT-TPRINT 505 . 830) (TPRINT 832 . 1031))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TRAVERSE b/internal/gabriel/interlisp/TRAVERSE new file mode 100644 index 00000000..faba31ee --- /dev/null +++ b/internal/gabriel/interlisp/TRAVERSE @@ -0,0 +1 @@ +(FILECREATED "19-Nov-85 22:24:40" {QV}BENCHMARKS>TRAVERSE.;7 6905 changes to: (VARS TRAVERSECOMS) (FNS RUN-TRAVERSE INIT-TRAVERSE CREATE-STRUCTURE SNB SEED RANDOM TREMOVE TRAVERSE RANDOM-TRAVERSE SEED-TRAVERSE FIND-ROOT TADD TRAVERS TSELECT) previous date: " 9-Jan-84 17:55:36" {PHYLUM}TRAVERSE.;10) (PRETTYCOMPRINT TRAVERSECOMS) (RPAQQ TRAVERSECOMS ((RECORDS NODE) (FNS INIT-TRAVERSE SNB SEED-TRAVERSE RANDOM-TRAVERSE RUN-TRAVERSE TREMOVE TSELECT TADD CREATE-STRUCTURE FIND-ROOT TRAVERS TRAVERSE) (* * Call (INIT-TRAVERSE) then (RUN-TRAVERSE)) (DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T)))) [DECLARE: EVAL@COMPILE (DATATYPE NODE ((PARENTS POINTER) (SONS POINTER) (SN WORD) (ENTRY1 FLAG) (ENTRY2 FLAG) (ENTRY3 FLAG) (ENTRY4 FLAG) (ENTRY5 FLAG) (ENTRY6 FLAG) (MARK FLAG)) SN _(SNB)) ] (/DECLAREDATATYPE (QUOTE NODE) (QUOTE (POINTER POINTER WORD FLAG FLAG FLAG FLAG FLAG FLAG FLAG)) [QUOTE ((NODE 0 POINTER) (NODE 2 POINTER) (NODE 4 (BITS . 15)) (NODE 2 (FLAGBITS . 0)) (NODE 2 (FLAGBITS . 16)) (NODE 2 (FLAGBITS . 32)) (NODE 2 (FLAGBITS . 48)) (NODE 2 (FLAGBITS . 64)) (NODE 2 (FLAGBITS . 80)) (NODE 2 (FLAGBITS . 96] (QUOTE 6)) (DEFINEQ (INIT-TRAVERSE [LAMBDA NIL (* jop: "19-Nov-85 22:14") (DECLARE (GLOBALVARS ROOT SN MARKER)) (SETQ SN 0) (SETQ MARKER NIL) (SEED-TRAVERSE) (SETQ ROOT (CREATE-STRUCTURE 100]) (SNB [LAMBDA NIL (* jop: "19-Nov-85 22:01") (DECLARE (GLOBALVARS SN)) (SETQ SN (ADD1 SN]) (SEED-TRAVERSE [LAMBDA NIL (* jop: "19-Nov-85 22:11") (DECLARE (GLOBALVARS RAND-TRAVERSE)) (SETQ RAND-TRAVERSE 21]) (RANDOM-TRAVERSE [LAMBDA NIL (* jop: "19-Nov-85 22:10") (DECLARE (GLOBALVARS RAND-TRAVERSE)) (SETQ RAND-TRAVERSE (IREMAINDER (ITIMES RAND-TRAVERSE 17) 251]) (RUN-TRAVERSE [LAMBDA NIL (* jop: "19-Nov-85 21:59") (DECLARE (GLOBALVARS ROOT)) (for I from 1 to 50 do (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT) (TRAVERSE ROOT]) (TREMOVE [LAMBDA (N Q) (* jop: "19-Nov-85 22:04") (COND ((EQ (CDR (CAR Q)) (CAR Q)) (PROG2 NIL (CAAR Q) (RPLACA Q NIL))) [(ZEROP N) (PROG2 NIL (CAAR Q) (bind (P _(CAR Q)) until (EQ (CDR P) (CAR Q)) do (pop P) finally (RETURN (RPLACA Q (RPLACD P (CDR (CAR Q] (T (for N (Q _(CAR Q)) (P _(CDR (CAR Q))) from N by -1 until (ZEROP N) do (pop Q) (pop P) finally (RETURN (PROG2 NIL (CAR Q) (RPLACD Q P]) (TSELECT [LAMBDA (N Q) (* JonL " 5-JUL-83 13:37") (for N (Q _(CAR Q)) from N by -1 until (ZEROP N) do (pop Q) finally (RETURN (CAR Q]) (TADD [LAMBDA (A Q) (* JonL " 5-JUL-83 15:50") (COND [(NULL Q) (PROG ((X (LIST A))) (RPLACD X X) (RETURN (LIST X] [(NULL (CAR Q)) (PROG ((X (LIST A))) (RPLACD X X) (RETURN (RPLACA Q X] (T (RPLACA Q (RPLACD (CAR Q) (CONS A (CDR (CAR Q]) (CREATE-STRUCTURE [LAMBDA (N) (* jop: "19-Nov-85 22:09") (PROG [(A (LIST (create NODE] (RETURN (for M (P _ A) from (SUB1 N) by -1 until (ZEROP M) do (push A (create NODE)) finally (PROGN (SETQ A (LIST (RPLACD P A))) (RETURN (bind (UNUSED _ A) (USED _(TADD (TREMOVE 0 A) NIL)) X Y until (NULL (CAR UNUSED)) do (SETQ X (TREMOVE (IMOD ( RANDOM-TRAVERSE) N) UNUSED)) (SETQ Y (TSELECT (IMOD ( RANDOM-TRAVERSE) N) USED)) (TADD X USED) (push (fetch SONS of Y) X) (push (fetch PARENTS of X) Y) finally (RETURN (FIND-ROOT (TSELECT 0 USED) N]) (FIND-ROOT [LAMBDA (NODE N) (* JonL " 9-Jan-84 17:52") (for old N from N by -1 until (ZEROP N) do [if (NULL (ffetch PARENTS of NODE)) then (RETURN NODE) else (SETQ NODE (CAR (ffetch PARENTS of NODE] finally (RETURN NODE]) (TRAVERS [LAMBDA (NODE MARK) (* JonL " 9-Jan-84 17:53") (DECLARE (SPECVARS COUNT)) (if (EQ (ffetch MARK of NODE) MARK) then NIL else (freplace MARK of NODE with MARK) (add COUNT 1) (freplace ENTRY1 of NODE with (NOT (ffetch ENTRY1 of NODE))) (freplace ENTRY2 of NODE with (NOT (ffetch ENTRY2 of NODE))) (freplace ENTRY3 of NODE with (NOT (ffetch ENTRY3 of NODE))) (freplace ENTRY4 of NODE with (NOT (ffetch ENTRY4 of NODE))) (freplace ENTRY5 of NODE with (NOT (ffetch ENTRY5 of NODE))) (freplace ENTRY6 of NODE with (NOT (ffetch ENTRY6 of NODE))) (for SONS on (ffetch SONS of NODE) do (TRAVERS (CAR SONS) MARK]) (TRAVERSE [LAMBDA (ROOT1) (* jop: "19-Nov-85 22:06") (DECLARE (GLOBALVARS MARKER) (SPECVARS COUNT)) (PROG ((COUNT 0)) (TRAVERS ROOT1 (SETQ MARKER (NOT MARKER))) (RETURN COUNT]) ) (* * Call (INIT-TRAVERSE) then (RUN-TRAVERSE)) (DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TRAVERSE COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (1358 6689 (INIT-TRAVERSE 1368 . 1645) (SNB 1647 . 1817) (SEED-TRAVERSE 1819 . 2011) ( RANDOM-TRAVERSE 2013 . 2259) (RUN-TRAVERSE 2261 . 2581) (TREMOVE 2583 . 3273) (TSELECT 3275 . 3519) ( TADD 3521 . 3961) (CREATE-STRUCTURE 3963 . 5013) (FIND-ROOT 5015 . 5438) (TRAVERS 5440 . 6394) ( TRAVERSE 6396 . 6687))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/TRAVERSE.LCOM b/internal/gabriel/interlisp/TRAVERSE.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..05568c972bcb7f47225dee1072283d1fc28c8488 GIT binary patch literal 3120 zcma)8Pi)&{6#wjQY*^5x`vYw+JY_N8 z6Vfz^8|QK1z@1$tQHCbLCXpj565>)JKuAbjxF8W}haEV;d;XKyEt{ws`+MK}zW4X{ z-ZP&!np)k_R99<2IxlB0tZZgy%OIDlO0ilfrGclfZe6>+wz2BL)+VIk_QKMgv$odI zoVI43o72p?-cp^5?Q^c9F45-9TXHS~QcPG*uIBR9LM08`Bx~ah57toBrPUi-A3$^M z=5-h;o|&0RgSWDc>XH%)N>whVGZIf&ELXDT)~)Pp5%T$JUa2a%|7BqrN|js@u69>8 z-&?&2+gnxOORCcbDe|Ijwb~ir^JW{IMKc?1gJBx(hzcT?ZM)85-CcAvXq$7;)-aZi zYBsDExQ^DcmNa|^!2u~?j6~4s5jAg^jjUr?F1Tu=5nThftznwn3|zmldTVX#{hNM> zs+f*SkTHcaRtz#G-L~~kbFp>j?0I$0F|=kfHB!=rdksZ0jV7>D4F7tsGS5lNL2ygUDn=2$kM$>B0X03?`%F!!Od&(hNvYO#iPhyp2kg%rJn ziUKWvk(MWhfExZwER|BydzHM;3grF6W3}$I@7|Q&olXh&hoq`crc_VxP^~zP{-zk& z8QOZFAR+}}Xg|Xe5)cTl;hT*1jPDQikE14ethWBM{-}dqqz&|9GCcIyyND8}h7 z+|KXh(H|E)eX8G`zSPsPXu9~DNFQkm4>XinL#m0tZ^Cs8*O$lpCcXRC_zR4g{&QEH zJ}LH1q^)s!?y~8VtiSWPM+Zp=)pw}?qs}82D^bG%8Ee|_L^9TUlpZ-(0;6R$K+XlV zVzq|V0u{n?(DW)waIBIG+u`WcEJ~xSluN_YB{{+aDAYLSphQpVD@qAWtDzyPF}VJs z5G}Ao{GCDt4vo>u?bzCBtl=2tSHZ}?C{Z$)R0nv6!06AnxWf7>rsayb^Bab%99cR-ZqVOjD5Dk_iHCVKsBSHq*umM4qJT*Dz7v;wgYG~b zeEbFbR=vCaVUJK^{2(s(jpM{|*7vR+qI0Y_h_PA7CQd5BNyRvj;6RL%OK@^A4i zLwA7f8RhDP&6q?k=cCaQ%@{wo+;%kA?cmI|9mB-g8BSY&h)dkD)rEz`CUEX(b<1hA zgZu}BJ~7gVE-`{(Xyni?{MtAJXP~~au>m|`N(Q#O ztDC^3xI)A%Z)o+V>S$GHSf*RI?2f*{P$plrzxsCEnw+*(1fz%vS(zfs$C`Ov_HU#?4Sh3oc4#nPShU>0Zd4x-JhU^i*EiJ{{rm?7Qwl|J zzn|nH5yY6j#Y-49Q3GCpMF;`>sJA(!Hu7^9GX21A*B2BW0J8F3}E p3H32071U0b0*8^1xV`AwIF#E%G-6@e9mhDYyX2XPEz%!+{{qVV7rOue literal 0 HcmV?d00001 diff --git a/internal/gabriel/interlisp/TRIANG b/internal/gabriel/interlisp/TRIANG new file mode 100644 index 00000000..6d60acee --- /dev/null +++ b/internal/gabriel/interlisp/TRIANG @@ -0,0 +1 @@ +(FILECREATED "12-Nov-85 17:25:04" {QV}BENCHMARKS>TRIANG.;6 3921 changes to: (FNS TRIANG-INIT GOGOGO TEST LAST-POSITION TRY TRIANG-TEST) (VARS TRIANGCOMS) previous date: "22-May-84 20:52:42" {PHYLUM}TRIANG.;6) (* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT TRIANGCOMS) (RPAQQ TRIANGCOMS ((FNS GOGOGO LAST-POSITION TRY TRIANG-INIT TRIANG-TEST) (* * First call (TRIANG-INIT) then (GOGOGO 22)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DEFINEQ (GOGOGO [LAMBDA (I) (* jop: "11-Nov-85 16:01") (DECLARE (SPECVARS ANSWER FINAL)) (PROG ((ANSWER NIL) (FINAL NIL)) (RETURN (TRY I 1]) (LAST-POSITION [LAMBDA NIL (* jop: "11-Nov-85 16:02") (DECLARE (GLOBALVARS BOARD)) (OR (find I to 16 suchthat (EQ 1 (8AREF BOARD I))) 0]) (TRY [LAMBDA (I DEPTH) (* jop: "11-Nov-85 16:08") (DECLARE (SPECVARS ANSWER FINAL) (GLOBALVARS BOARD SEQUENCE A-TRIANGLE B-TRIANGLE C-TRIANGLE)) (COND ((EQ DEPTH 14) [PROG ((LP (LAST-POSITION))) (COND ((MEMBER LP FINAL)) (T (push FINAL LP] [push ANSWER (CDR (for I from 0 to (SUB1 (ARRAY-TOTAL-SIZE SEQUENCE)) collect (8AREF SEQUENCE I] T) ([AND (EQ 1 (8AREF BOARD (8AREF A-TRIANGLE I))) (EQ 1 (8AREF BOARD (8AREF B-TRIANGLE I))) (EQ 0 (8AREF BOARD (8AREF C-TRIANGLE I] (8ASET 0 BOARD (8AREF A-TRIANGLE I)) (8ASET 0 BOARD (8AREF B-TRIANGLE I)) (8ASET 1 BOARD (8AREF C-TRIANGLE I)) (8ASET I SEQUENCE DEPTH) (bind (DEPTH _(ADD1 DEPTH)) for J from 0 to 36 until (TRY J DEPTH) do NIL) (8ASET 1 BOARD (8AREF A-TRIANGLE I)) (8ASET 1 BOARD (8AREF B-TRIANGLE I)) (8ASET 0 BOARD (8AREF C-TRIANGLE I)) NIL]) (TRIANG-INIT [LAMBDA NIL (* jop: "11-Nov-85 16:07") (DECLARE (GLOBALVARS BOARD SEQUENCE A-TRIANGLE B-TRIANGLE C-TRIANGLE)) (SETQ BOARD (MAKE-ARRAY 16 (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 8)) (QUOTE :INITIAL-ELEMENT) 1)) (ASET 0 BOARD 5) (SETQ SEQUENCE (MAKE-ARRAY 14 (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 8)) (QUOTE :INITIAL-ELEMENT) 255)) [SETQ A-TRIANGLE (MAKE-ARRAY 37 (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 8)) (QUOTE :INITIAL-CONTENTS) (QUOTE (1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 0] [SETQ B-TRIANGLE (MAKE-ARRAY 37 (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 8)) (QUOTE :INITIAL-CONTENTS) (QUOTE (2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 0] (SETQ C-TRIANGLE (MAKE-ARRAY 37 (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 8)) (QUOTE :INITIAL-CONTENTS) (QUOTE (4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 0]) (TRIANG-TEST [LAMBDA NIL (* jop: "11-Nov-85 16:01") (DECLARE (SPECVARS ANSWER FINAL)) (TRIANG-INIT) (PROG ((ANSWER NIL) (FINAL NIL)) (TRY 22 1) (RETURN (EQ 775 (LENGTH ANSWER]) ) (* * First call (TRIANG-INIT) then (GOGOGO 22)) (DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TRIANG COPYRIGHT ("Xerox Corporation" 1984 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (574 3681 (GOGOGO 584 . 812) (LAST-POSITION 814 . 1047) (TRY 1049 . 2097) (TRIANG-INIT 2099 . 3384) (TRIANG-TEST 3386 . 3679))))) STOP \ No newline at end of file diff --git a/internal/gabriel/interlisp/benchmarkmemo.tedit b/internal/gabriel/interlisp/benchmarkmemo.tedit new file mode 100644 index 0000000000000000000000000000000000000000..3552ce68680d41f65c264ae5451b2324994cb75e GIT binary patch literal 8737 zcmcIoOK;=W6{aUspj6RK7wNmblQtdOm04cC)dmyTp7BH-+c9hhMS!9JB~dmp6saL8 zc|1Y>M;84hMgK#$+4V1U*Dku~cMcztcs=7FKn+-wF3&yZ-0!?^uctrXKR6#gI~E7e zP7gmh**|}Aq3f0@PP3&U9tUm@f0ywrPOrowokY19re&1RqBn0c5vCLIA}h1Lm?w)u z%on31F0P}A$fIJBl!YOB+rz!phQ4^QSJ9vCt%&1Pd~g=!(=4Bb={RDp&z51b2+KH2 zMK%@3!;3RaFoYU(ibPgOK}F7MPJB4;O;=>gD4$e&%*qr z{$fu`GuW1fd$OYs*MFSx551?4=L`L6+4{G%Ct`F)rg}1mi+G&+u&eX6r8g zr4LR6!}9gsWgaf0yok2rG%k1azyYx|Y?r=S_-47f6Bq=E^j5_ABHhs?SmH(X8PGW) zH;%vmw6nfS9onXrl}iF&{71hhu?tyXr9Mu33Tz>9^g5U_(E#< zAi(=P3Maa63>@9CJPVeA-3=LdI15-x8&a6X?yhcu3}UT-y$E2E`}EGTN;6(1`twK<5V$iQ*km=xA6oZHfdTa(FoE2-X%a1A^fodI)#G?sF z3lQ-y2DXk$GQ5Pp(5GK1!=c%$0@EAdo#VkW0eK~?0wa>U*)ZiDL2B8ED1Xoe8Ebb0 zE1VaBPHyYKZN19Z1AH;zpl^*@Rrn%bHGfJZGxAj=I}V+E zBc6$=OAd^Tfe1x3(~3<#epg&mbb^;n`Z^}gVH2E4BUpP&d{b7lkfbPP@j-AR3CJpW zy(7|*)F?Yj27rW+E`Ct`k14CL!3l2=QnHXFHIbkK)HQWK^i8eVv$5ncu5`p+6 z1n{8rXp%o}W(hkWhDa=1U!WkKmZ@bcm4ogRd&F6$0cCWu72O%EhDrT!vji`VN zdC(X-poG8=QQ(1w;S8EMCvRyAJlAZLR`L$C6yz&NTLes1juCH+2G=Zv6cu5lBkCOj z@M)?x0t|j4DdBJxMzWy;GucMX#t|I2Ej$Pj=2AgK_#-%|W;+#STeFe%h!$BAod79- zGsBOmzI$GeYqmrK1}Cx_zk!=VU)wP4RoFsj%I6KpFb12pDcUxK8u9ZSA2nUGh|@_t4$G(z(iBnKjTh981O7g5oW#XE%;WM_jH2=;ic&GV71Q`?fnJ>3 zcnB%h`4@|;D|Dg-c86t0cC#;!rb#p|MJNgk9Z9q%-4K^h7vjaDfP`sSlw$w<+0kP( z{-Z@H(hM`oD0__wB+EsHv*lu%WSAo`z05PTVWQ0A@yo&h2D{?&?0k573Ek^aLCmsA zJdLrtz-$90Gf|Xb4pk~$%WO`^55*18$!>rVCXx`crhJr9R+iaJV2%+l`1HdSYm)dp zN~1hX#5kMHqO>f2kHHGZS<)#~Bxz2nxUA-_Srit)mUpupvL3lrn$2QxUY(={k$?vN zFbB>U5h&rP{yG&0!{?`;om^C)zJ<%HMNGD=NePirBqmuJ;S@QdwM=fs-X2R?jd{)Z zC&D~}O-i5$)QJ>+6i)yJotq6uo>QY=i0!J__Qho#pnV1a_TFJuFbS}~&fpV8lHI_# zaHDk1eW5Ciono?xNL4y}9>ueH!jQG&&Op@Xnd_@sX!H)*onl(FD zI38oFB-rRhRATsG-%Z6Ivov{Jh)w2(7?vW2mI)jP-WEY2_B|*A9H105LS6I#AyB=^ zFrQRsh+fYDCi!hjL|9(oVu+KtpjZ&Ic${bBY!ZE3LD-y^aGu5F_T+pdV~Y>_fk2+5;)o=p~Dx4KnmWHpFXdsna$murl=VtgHqUjjOUjj)BCF#sc) zNUwstdnm%0K($QC228Sy^Kua;@aTAgP)4Q%IXN8QnP#{rf%U}~^XuDWG5hkPtLmQO z$*v(TGB|Kp!gEMmQD*tAAT(-&vTqoQbx*MBNOrx7RSI)vQ3?ETuvOUujd$@F&jj|*j7lIc0A_-@sNr)H6 zC&T(jUz}YW?_GR$iq*3$FWD%#BS|N8N5fY)P$d+gFnS2_=8ow9aqV-^Boj1>q%a

51ju~@S{YR89$)yNrJ@cAwGZ*`Ke8>K>9fapMI^)MMZxhwpmObaT6bISCUadK`SgDC0K$ zqs@aR-3?f{wITMl?oo#ey@E~$iGGNhENXpd3i9bv0@^iQV13O)Exutx2DiW@u|7pZ zS9OafcZ=2NAgQ;hdqqsvPy?MG4vdC`<^h}wGTSy04G8)|8sX3k6IR@ma96j{B?1q$ znbiIf2fDKGxoP9upSC~5XhUNy&W8C2R5ThBf>mpXo)P`8$r3OvnWPS8RP?xmcA|rV zWGq~z1T=?X)GH#T*9tG*DO8JP2UN)t6s&#(C=hc4v+HC+Kx z!%Lko_*R!dGz`!m0-%1J^hPU%P&8gM-#fEOrNZ(C4uC=u^|)+tRe}YOgiz zubTF?ru|pj3bd_1Yg=DwTYs-8?)vm;ah=6OV(~R^{_3s`)!O#@s|S$$mcMUGN82B2 zTiVB(+tBcDq5k-p%6y$ouPCi2R4$g&%bne%@X9Nq0e^P!@jG-6FaR zyWNGo?!u$)!iU|3$K3^msd9XU>9~|LwQz~asq&Qt3UU%WQ-GyIw7ZfRq2kmsX z{HD90xTWHBiXIzczlE`tEo6Pg>E7>Zs)V|-phSZb`^pvt(+y81FHkU545e&QFjW>5 zrV8qcCo6}0)CEYPP!@jH-J*n;B34mdL5xF%KM*eu5z}PfHnOo$eP5%{UfoOagL^6d zeILcv!F?3kKkudZ*S!??OX&in4ew?8r!K``x(gdjAKtP*Sks$;w$2=U2|6K&T+5NKtqw6be8arlcR=>mFaB Ycycer=Uoa#b%kkn;r)MX*>C>#KP#C9FaQ7m literal 0 HcmV?d00001 diff --git a/internal/gabriel/interlisp/dderiv.lcom b/internal/gabriel/interlisp/dderiv.lcom new file mode 100644 index 0000000000000000000000000000000000000000..96a4dc4b44e97a38ab3cd514d70d839bf2fe2e17 GIT binary patch literal 2294 zcmbVO&yU+w5O%x=z!D{k$|dSyXF7kpehT5q`5A1yHk(ZqX2%!kt7^e= z?2cnnRa3|%xX{+4^%K2ggFzj`a$4x*YIxA1v;z+p$E!#4bGTSLKnBqWl5wQxA%GG@ zL0U}2S{#l?%`8Ib2ZI4iFmNUo(%^snhZNH^N zK?u@&628{>`Epi!BuQ^e(rbC=)t`&HM5qZq^DyKiWWSrk#}QaSI3*P_Afo{a0yIsj zP+GcjYUpOSE}c$SJHP(%Vo~RA-$I91{racBy!=@rwjp?dmRXFfRxvW~79&h?&Z)*j zM8K`KKumI+7EED^ROd7A(rl0KppLEXwVzSIqSt;1%!1DU4o(4TU)zx;Lc4ZNj(aE#vkm(!jiCdd zq(?D3@J0`s<3WV#z|^oL875$2X1JtLrAVnlG^LP-sE;iiHp+o}#J5{RUAS^>(P%WX zDgTmd`5U+RdV_!Q58|=fW%3J=pi9#h!ZeLin_zE-sG_o-GlbP@-h!v^b! z=*B?qz#ZrvFPA{7U0s8V#e4;1gBLj?ebx)TggMY3Mk$+kp&Jgpem3h3<0Bkoi<}+& zLjWWk_Pj8=g_@9R_(J~1DaSf0Qzc5fK%FbMdN6OTd2AJSsz)j@=I1sG+xD`u$&YR5 gyksrkGABRIEL>TOOLS>BENCH-1.;1" 9194 changes to%: (VARS BENCH-1COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-1COMS) (RPAQQ BENCH-1COMS [ (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Benchmarks>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Benchmarks>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3822 7377 (MM 3832 . 4056) (PPR 4058 . 4517) (JDSINIT 4519 . 7375))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-1.~1~ b/internal/gabriel/tools/BENCH-1.~1~ new file mode 100644 index 00000000..cf73c991 --- /dev/null +++ b/internal/gabriel/tools/BENCH-1.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:05:47" "{ERIS}GABRIEL>TOOLS>BENCH-1.;1" 9194 changes to%: (VARS BENCH-1COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-1COMS) (RPAQQ BENCH-1COMS [ (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>GABRIEL-TAK.dfasl") (LOAD "{Eris}Gabriel>Tools>ARITH-BENCHMARKS.dfasl") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>GABRIEL-TAK.dfasl") (LOAD "{Eris}Gabriel>Tools>ARITH-BENCHMARKS.dfasl") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3822 7377 (MM 3832 . 4056) (PPR 4058 . 4517) (JDSINIT 4519 . 7375))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-1.~2~ b/internal/gabriel/tools/BENCH-1.~2~ new file mode 100644 index 00000000..20efd13c --- /dev/null +++ b/internal/gabriel/tools/BENCH-1.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:05:47" "{ERIS}GABRIEL>TOOLS>BENCH-1.;1" 9194 changes to%: (VARS BENCH-1COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-1COMS) (RPAQQ BENCH-1COMS [ (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Tools>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Tools>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3822 7377 (MM 3832 . 4056) (PPR 4058 . 4517) (JDSINIT 4519 . 7375))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-1.~3~ b/internal/gabriel/tools/BENCH-1.~3~ new file mode 100644 index 00000000..6a1073d2 --- /dev/null +++ b/internal/gabriel/tools/BENCH-1.~3~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:05:47" "{ERIS}GABRIEL>TOOLS>BENCH-1.;1" 9194 changes to%: (VARS BENCH-1COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-1COMS) (RPAQQ BENCH-1COMS [ (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Benchmarks>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Benchmarks>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3822 7377 (MM 3832 . 4056) (PPR 4058 . 4517) (JDSINIT 4519 . 7375))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-2 b/internal/gabriel/tools/BENCH-2 new file mode 100644 index 00000000..84b1b660 --- /dev/null +++ b/internal/gabriel/tools/BENCH-2 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:12" "{ERIS}GABRIEL>TOOLS>BENCH-2.;1" 8476 changes to%: (VARS BENCH-1COMS BENCH-2COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-2COMS) (RPAQQ BENCH-2COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"AREFy%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*AREFY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"AREFy%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*AREFY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3386 6941 (MM 3396 . 3620) (PPR 3622 . 4081) (JDSINIT 4083 . 6939))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-2.~1~ b/internal/gabriel/tools/BENCH-2.~1~ new file mode 100644 index 00000000..e65cab99 --- /dev/null +++ b/internal/gabriel/tools/BENCH-2.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:12" "{ERIS}GABRIEL>TOOLS>BENCH-2.;1" 8476 changes to%: (VARS BENCH-1COMS BENCH-2COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-2COMS) (RPAQQ BENCH-2COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"AREFy%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*AREFY-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"AREFy%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*AREFY-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3386 6941 (MM 3396 . 3620) (PPR 3622 . 4081) (JDSINIT 4083 . 6939))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-2.~2~ b/internal/gabriel/tools/BENCH-2.~2~ new file mode 100644 index 00000000..84b1b660 --- /dev/null +++ b/internal/gabriel/tools/BENCH-2.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:12" "{ERIS}GABRIEL>TOOLS>BENCH-2.;1" 8476 changes to%: (VARS BENCH-1COMS BENCH-2COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-2COMS) (RPAQQ BENCH-2COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"AREFy%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*AREFY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"AREFy%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*AREFY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-AREFY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3386 6941 (MM 3396 . 3620) (PPR 3622 . 4081) (JDSINIT 4083 . 6939))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-3 b/internal/gabriel/tools/BENCH-3 new file mode 100644 index 00000000..1c1b5ed7 --- /dev/null +++ b/internal/gabriel/tools/BENCH-3 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:35" "{ERIS}GABRIEL>TOOLS>BENCH-3.;1" 8476 changes to%: (VARS BENCH-1COMS BENCH-3COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-3COMS) (RPAQQ BENCH-3COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"CONSy%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*CONSY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"CONSy%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*CONSY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3386 6941 (MM 3396 . 3620) (PPR 3622 . 4081) (JDSINIT 4083 . 6939))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-3.~1~ b/internal/gabriel/tools/BENCH-3.~1~ new file mode 100644 index 00000000..f920a82a --- /dev/null +++ b/internal/gabriel/tools/BENCH-3.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:35" "{ERIS}GABRIEL>TOOLS>BENCH-3.;1" 8476 changes to%: (VARS BENCH-1COMS BENCH-3COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-3COMS) (RPAQQ BENCH-3COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"CONSy%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*CONSY-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"CONSy%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*CONSY-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3386 6941 (MM 3396 . 3620) (PPR 3622 . 4081) (JDSINIT 4083 . 6939))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-3.~2~ b/internal/gabriel/tools/BENCH-3.~2~ new file mode 100644 index 00000000..1c1b5ed7 --- /dev/null +++ b/internal/gabriel/tools/BENCH-3.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:35" "{ERIS}GABRIEL>TOOLS>BENCH-3.;1" 8476 changes to%: (VARS BENCH-1COMS BENCH-3COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-3COMS) (RPAQQ BENCH-3COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"CONSy%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*CONSY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"CONSy%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*CONSY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-CONSY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3386 6941 (MM 3396 . 3620) (PPR 3622 . 4081) (JDSINIT 4083 . 6939))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-386 b/internal/gabriel/tools/BENCH-386 new file mode 100644 index 00000000..ce13aa90 --- /dev/null +++ b/internal/gabriel/tools/BENCH-386 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:05:47" "{ERIS}GABRIEL>TOOLS>BENCH-1.;1" 9194 changes to%: (VARS BENCH-1COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-1COMS) (RPAQQ BENCH-1COMS [ (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Benchmarks>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>486-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>486-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>486-PAV-ARITH.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 1 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the TAK, IO, and Arithmetic benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Benchmarks>GABRIEL-TAK.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>ARITH-BENCHMARKS.dfasl") (LOAD "{dsk}Gabriel>Benchmarks>IO-BENCHMARKS.LCOM") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*TAK-TIMERS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-TAK.Results) (GABRIEL::RUN-BENCHMARKS GABRIEL::*MAIKO-IO-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-IO.Results) (GABRIEL::RUN-BENCHMARKS *ARITH-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-ARITH.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3822 7377 (MM 3832 . 4056) (PPR 4058 . 4517) (JDSINIT 4519 . 7375))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-4 b/internal/gabriel/tools/BENCH-4 new file mode 100644 index 00000000..a7730383 --- /dev/null +++ b/internal/gabriel/tools/BENCH-4 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:56" "{ERIS}GABRIEL>TOOLS>BENCH-4.;1" 8470 changes to%: (VARS BENCH-1COMS BENCH-4COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-4COMS) (RPAQQ BENCH-4COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"POLY%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*POLY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-POLY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"POLY%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*POLY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-POLY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3382 6937 (MM 3392 . 3616) (PPR 3618 . 4077) (JDSINIT 4079 . 6935))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-4.~1~ b/internal/gabriel/tools/BENCH-4.~1~ new file mode 100644 index 00000000..a894982e --- /dev/null +++ b/internal/gabriel/tools/BENCH-4.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:56" "{ERIS}GABRIEL>TOOLS>BENCH-4.;1" 8470 changes to%: (VARS BENCH-1COMS BENCH-4COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-4COMS) (RPAQQ BENCH-4COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"POLY%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*POLY-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-POLY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"POLY%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*POLY-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-POLY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3382 6937 (MM 3392 . 3616) (PPR 3618 . 4077) (JDSINIT 4079 . 6935))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-4.~2~ b/internal/gabriel/tools/BENCH-4.~2~ new file mode 100644 index 00000000..a7730383 --- /dev/null +++ b/internal/gabriel/tools/BENCH-4.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 11:06:56" "{ERIS}GABRIEL>TOOLS>BENCH-4.;1" 8470 changes to%: (VARS BENCH-1COMS BENCH-4COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-4COMS) (RPAQQ BENCH-4COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"POLY%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*POLY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-POLY.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"POLY%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>GABRIEL-OTHER.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*POLY-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-POLY.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3382 6937 (MM 3392 . 3616) (PPR 3618 . 4077) (JDSINIT 4079 . 6935))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-5 b/internal/gabriel/tools/BENCH-5 new file mode 100644 index 00000000..c0c0b0ac --- /dev/null +++ b/internal/gabriel/tools/BENCH-5 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 13:30:52" "{ERIS}GABRIEL>TOOLS>BENCH-5.;1" 8462 changes to%: (VARS BENCH-5COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-5COMS) (RPAQQ BENCH-5COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"MISC%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>MISC-BENCHMARKS.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*MISC-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-MISC.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"MISC%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>MISC-BENCHMARKS.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*MISC-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-MISC.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3372 6927 (MM 3382 . 3606) (PPR 3608 . 4067) (JDSINIT 4069 . 6925))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-5.~1~ b/internal/gabriel/tools/BENCH-5.~1~ new file mode 100644 index 00000000..faf96d85 --- /dev/null +++ b/internal/gabriel/tools/BENCH-5.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 13:30:52" "{ERIS}GABRIEL>TOOLS>BENCH-5.;1" 8462 changes to%: (VARS BENCH-5COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-5COMS) (RPAQQ BENCH-5COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"MISC%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>MISC-BENCHMARKS.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*MISC-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-MISC.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"MISC%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {ERIS}Gabriel>Tools> {ERIS}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{Eris}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{Eris}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{Eris}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{Eris}Gabriel>Tools>MISC-BENCHMARKS.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*MISC-BENCHMARKS* '{Eris}Gabriel>Results>Maiko>SUN-PAV-MISC.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3372 6927 (MM 3382 . 3606) (PPR 3608 . 4067) (JDSINIT 4069 . 6925))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/BENCH-5.~2~ b/internal/gabriel/tools/BENCH-5.~2~ new file mode 100644 index 00000000..c0c0b0ac --- /dev/null +++ b/internal/gabriel/tools/BENCH-5.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jun-88 13:30:52" "{ERIS}GABRIEL>TOOLS>BENCH-5.;1" 8462 changes to%: (VARS BENCH-5COMS) previous date%: "22-Apr-88 20:08:12" {ERIS}INIT.;23) (PRETTYCOMPRINT BENCH-5COMS) (RPAQQ BENCH-5COMS [ (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started.") (* ;; "This INIT file runs the %"MISC%" benchmark sets.") (FNS MM PPR JDSINIT) [VARS (SYSOUTGAG T) (PROMPT#FLG T) (CLEANUPOPTIONS '(RC ST)) (**COMMENT**FLG " (* --) ") (BREAKDELIMITER ", ") (GRAYSHADE 21930) (WINDOWBACKGROUNDSHADE 14316) (RECOMPILDEFAULT 'EXPRS) (DEFAULTPRINTINGHOST '(TSUNAMI%: TREMOR%: YODA] [COMS (* ; "To defeat the IDLE program") (VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (IDLE.TIMEOUT NIL) (IDLE.DEFAULTMODE 'UNLOCKED] (ADDVARS (DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (DISPLAYFONTEXTENSIONS AC) (PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>")) (COMS (* ; "Load the benchmark files") (P (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>MISC-BENCHMARKS.dfasl"))) (P (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL")) (P (GABRIEL::RUN-BENCHMARKS GABRIEL::*MISC-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-MISC.Results)) (P (LOGOUT T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR) (NLAML) (LAMA]) (* ;; "This is the INIT file that runs part 2 of the benchmarks on a SUN. It is put in place as INIT.LISP by a shell script, then Lisp is started." ) (* ;; "This INIT file runs the %"MISC%" benchmark sets.") (DEFINEQ (MM [LAMBDA (X) (* ; "Edited 21-Jul-87 18:04 by jds") (COND ((LISTP X) (for V in X collect (FTIMES 60.0 V))) (T (FTIMES 60.0 X]) (PPR [NLAMBDA X (* rrb " 9-JUL-81 15:12") (RESETFORM (OUTPUT T) (MAPC (OR (LISTP X) (LIST X)) (FUNCTION (LAMBDA (R) [PRINTDEF (OR (APPEND (RECLOOK R) (FIELDLOOK R)) (CONS R '(not found] (TERPRI T]) (JDSINIT [LAMBDA NIL (* ; "Edited 17-Jan-88 16:30 by jds") (* ;;; "Machine dependent initialization stuff") (PROG ((MACHINE (MACHINETYPE))) (SETQ LAFITEDISPLAYREGION (create REGION LEFT _ 605 BOTTOM _ 8 HEIGHT _ 300 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITEEDITORREGION (create REGION LEFT _ 605 BOTTOM _ 313 HEIGHT _ 200 WIDTH _ (IDIFFERENCE SCREENWIDTH 608))) (SETQ LAFITESTATUSWINDOWPOSITION (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH 200) YCOORD _ (IDIFFERENCE SCREENHEIGHT 30))) (CROCK (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 835) BOTTOM _ (IDIFFERENCE SCREENHEIGHT 80) WIDTH _ 85 HEIGHT _ 72)) (MOVEW PROMPTWINDOW (create REGION LEFT _ (IDIFFERENCE SCREENWIDTH 750) WIDTH _ 550 HEIGHT _ 89 BOTTOM _ (IDIFFERENCE SCREENHEIGHT 89))) (AND LOGOW (CLOSEW LOGOW)) (SELECTQ MACHINE (DOVE (* ;; "Daybreak. Set up special key actions for typing convenience.") [KEYACTION 'KEYPAD9 '((57 188 NOLOCKSHIFT) . IGNORE] (* ; "1/4") [KEYACTION 'KEYPAD6 '((174 189 NOLOCKSHIFT) . IGNORE] (* ; "1/2") [KEYACTION 'KEYPAD3 '((51 190 NOLOCKSHIFT) . IGNORE] (* ; "3/4") ) (DORADO (* ;; "Dorado. Set up a meta key and some TEdit commands.") (TTYINMETA T) (TEDIT.SETFUNCTION (CHARCODE %##F) '\TEDIT.FIND) (TEDIT.SETFUNCTION (CHARCODE %##f) '\TEDIT.FIND) (TEDIT.SETSYNTAX 27 'REDO) (TEDIT.SETSYNTAX (CHARCODE %##U) 'UNDO) (TEDIT.SETSYNTAX (CHARCODE %##u) 'UNDO) (FILESLOAD TEDITDORADOKEYS)) (DANDELION) (DOLPHIN) (SHOULDNT]) ) (RPAQQ SYSOUTGAG T) (RPAQQ PROMPT#FLG T) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQ **COMMENT**FLG " (* --) ") (RPAQ BREAKDELIMITER ", ") (RPAQQ GRAYSHADE 21930) (RPAQQ WINDOWBACKGROUNDSHADE 14316) (RPAQQ RECOMPILDEFAULT EXPRS) (RPAQQ DEFAULTPRINTINGHOST (TSUNAMI%: TREMOR%: YODA)) (* ; "To defeat the IDLE program") (RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL)) (RPAQQ IDLE.TIMEOUT NIL) (RPAQQ IDLE.DEFAULTMODE UNLOCKED) (ADDTOVAR DIRECTORIES {dsk}Gabriel>Tools> {dsk}Gabriel>Benchmarks> {DSK}) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (ADDTOVAR DISPLAYFONTEXTENSIONS AC) (ADDTOVAR PRESSFONTWIDTHSFILES {ERIS}SD>FONTS.WIDTHS) (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}FONTS>" "{dsk}XeroxPrivate>Fonts>") (* ; "Load the benchmark files") (LOAD "{dsk}Gabriel>Tools>GABRIEL-TIMERS.LCOM") (LOAD "{dsk}Gabriel>Tools>IO-BENCHMARKS.LCOM") (LOAD "{dsk}Gabriel>Tools>MISC-BENCHMARKS.dfasl") (RAISE NIL) (GCGAG 500) (CHANGESLICE 100) (XCL:SET-DEFAULT-EXEC-TYPE "IL") (XCL:SET-EXEC-TYPE "IL") (GABRIEL::RUN-BENCHMARKS GABRIEL::*MISC-BENCHMARKS* '{dsk}Gabriel>Results>Maiko>SUN-PAV-MISC.Results) (LOGOUT T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3372 6927 (MM 3382 . 3606) (PPR 3608 . 4067) (JDSINIT 4069 . 6925))))) STOP \ No newline at end of file diff --git a/internal/gabriel/tools/GABRIEL-TIMERS b/internal/gabriel/tools/GABRIEL-TIMERS new file mode 100644 index 00000000..a56beeae --- /dev/null +++ b/internal/gabriel/tools/GABRIEL-TIMERS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "GABRIEL")) (IL:FILECREATED "12-Aug-88 10:32:50" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;7 17901 IL:|changes| IL:|to:| (IL:FUNCTIONS RUN-BENCHMARKS) IL:|previous| IL:|date:| "28-Jul-88 03:21:26" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;6 ) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:GABRIEL-TIMERSCOMS) (IL:RPAQQ IL:GABRIEL-TIMERSCOMS ( (IL:* IL:|;;| "Main file for running [Gabriel] Benchmark suites in Xerox Lisp:") (IL:COMS (IL:* IL:|;;| "Definitions for the TIMERS type, and the definer for them:") (IL:DEFINE-TYPES TIMERS) (IL:FUNCTIONS DEFINE-TIMER)) (IL:COMS (IL:* IL:|;;| "CONTROL VARIABLES") (IL:* IL:|;;|  " *ALL-TIMERS* - List of all the benchmark definitions you've loaded.") (IL:* IL:|;;|  " *MINIMUM-TESTS* - Min # of times to run each test, defaults to 2.") (IL:VARIABLES *ALL-TIMERS* *MINIMUM-TESTS* *MOST-TIMERS*)) (IL:COMS (IL:* IL:|;;| "Functions for running benchmarks. RUN-BENCHMARKS is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function.") (IL:FUNCTIONS RUN-BENCHMARKS DESCRIBE-IMPLEMENTATION)) (IL:COMS (IL:* IL:|;;| "Functions for running benchmarks and saving the results in a database of benchmarks. RUN-BENCHMARKS-TO-DATABASE is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function.") (IL:FUNCTIONS RUN-BENCHMARKS-TO-DATABASE TIME-CALL ALL-TIME-INDICATORS)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:GABRIEL-TIMERS))) (IL:* IL:|;;| "Main file for running [Gabriel] Benchmark suites in Xerox Lisp:") (IL:* IL:|;;| "Definitions for the TIMERS type, and the definer for them:") (XCL:DEF-DEFINE-TYPE TIMERS "Gabriel Benchmarks") (XCL:DEFDEFINER (DEFINE-TIMER (:NAME (LAMBDA (WHOLE) (IF (CONSP (SECOND WHOLE)) (CAR (SECOND WHOLE)) (SECOND WHOLE))))) TIMERS (NAME-AND-OPTIONS DOCUMENTATION &BODY BODY) (LET ((NAME (IF (CONSP NAME-AND-OPTIONS) (CAR NAME-AND-OPTIONS) NAME-AND-OPTIONS)) (SETUPFORM (CADR (ASSOC ':SETUP NAME-AND-OPTIONS))) (AFTER-EVERY-FORM (CADR (ASSOC ':AFTER-EVERY NAME-AND-OPTIONS))) (AFTERFORM (CADR (ASSOC ':AFTER NAME-AND-OPTIONS)))) (LET ((TIMER (GENTEMP))) `(PROGN (PUSHNEW ',NAME *ALL-TIMERS*) (DEFUN ,TIMER () ,@BODY) (SETF (GET ',NAME 'TIMING-FUNCTION) ',TIMER) ,@(IF SETUPFORM (LET ((SETUP (GENTEMP))) `((DEFUN ,SETUP () ,SETUPFORM) (SETF (GET ',NAME 'SETUP-FUNCTION) ',SETUP)))) ,@(IF AFTER-EVERY-FORM (LET ((AFTER-EVERY (GENTEMP))) `((DEFUN ,AFTER-EVERY () ,AFTER-EVERY-FORM) (SETF (GET ',NAME 'AFTER-EVERY-FUNCTION) ',AFTER-EVERY)))) ,@(IF AFTERFORM (LET ((AFTER (GENTEMP))) `((DEFUN ,AFTER () ,AFTERFORM) (SETF (GET ',NAME 'AFTER-FUNCTION) ',AFTER)))) (SETF (GET ',NAME 'TIMING-DOCUMENTATION) ,DOCUMENTATION))))) (IL:* IL:|;;| "CONTROL VARIABLES") (IL:* IL:|;;| " *ALL-TIMERS* - List of all the benchmark definitions you've loaded.") (IL:* IL:|;;| " *MINIMUM-TESTS* - Min # of times to run each test, defaults to 2.") (DEFVAR *ALL-TIMERS* NIL) (DEFPARAMETER *MINIMUM-TESTS* 2 "Run each test at least this many times") (DEFVAR *MOST-TIMERS* '(TAKR TAKL TAK STAK CTAK TRIANG TRAVERSE-INIT TRAVERSE TPRINT PUZZLE FPRINT FREAD FFT DIV2-2 DIV2-1 DESTRU DERIV DDERIV BROWSE BOYER TRAVERSE-INIT* TRAVERSE* BROWSE*)) (IL:* IL:|;;| "Functions for running benchmarks. RUN-BENCHMARKS is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." ) (DEFUN RUN-BENCHMARKS (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE '{DSK}GABRIEL.BENCHMARKS) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (APPEND-DRIBBLE-FILE NIL)) (IL:* IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| "Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS)) (UNWIND-PROTECT (PROGN (IL:* IL:|;;|  "Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE "GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) 'IL:PAGEFULLFN 'IL:NILL) (IL:* IL:|;;|  "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE APPEND-DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK 'TIMING-FUNCTION)) (SETQ SETUP-FUNCTION (GET BENCHMARK 'SETUP-FUNCTION)) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK 'AFTER-EVERY-FUNCTION)) (SETQ AFTER-FUNCTION (GET BENCHMARK 'AFTER-FUNCTION)) (SETQ DOCUMENTATION (GET BENCHMARK 'TIMING-DOCUMENTATION)) (IF DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) (IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (CL::TIME-CALL #'(LAMBDA NIL (FUNCALL TIMING-FUNCTION)) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") (IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) (FUNCALL AFTER-FUNCTION)))))) (IL:* IL:|;;| "Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:") (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) 'IL:PAGEFULLFN 'NIL)) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) (DEFUN DESCRIBE-IMPLEMENTATION (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (FORMAT STREAM "~&Lisp Type:~20T~A" (LISP-IMPLEMENTATION-TYPE)) (FORMAT STREAM "~&Lisp Version:~20T~A" (LISP-IMPLEMENTATION-VERSION)) (FORMAT STREAM "~&Software Type:~20T~A" (SOFTWARE-TYPE)) (FORMAT STREAM "~&Software Version:~20T~A" (SOFTWARE-VERSION)) (FORMAT STREAM "~&Machine Type:~20T~A" (MACHINE-TYPE)) (FORMAT STREAM "~&Machine Version:~20T~A" (MACHINE-VERSION)) (FORMAT STREAM "~&Machine Instance:~20T~A" (MACHINE-INSTANCE)) (FORMAT STREAM "~&Site:~20T~A" (LONG-SITE-NAME)) (FORMAT STREAM "~&Features:~20T~S" *FEATURES*)) (IL:* IL:|;;| "Functions for running benchmarks and saving the results in a database of benchmarks. RUN-BENCHMARKS-TO-DATABASE is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." ) (DEFUN RUN-BENCHMARKS-TO-DATABASE (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE '{DSK}GABRIEL.BENCHMARKS) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (TOTAL-TIMES-FILE '{DSK} GABRIEL.TOTALTIMES)) (IL:* IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| "Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS) TOTALTIMES TIMES AVG-TIMES) (UNWIND-PROTECT (PROGN (IL:* IL:|;;|  "Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE "GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) 'IL:PAGEFULLFN 'IL:NILL) (IL:* IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (WITH-OPEN-FILE (RESULT-STREAM TOTAL-TIMES-FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK 'TIMING-FUNCTION)) (SETQ SETUP-FUNCTION (GET BENCHMARK 'SETUP-FUNCTION)) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK 'AFTER-EVERY-FUNCTION)) (SETQ AFTER-FUNCTION (GET BENCHMARK 'AFTER-FUNCTION)) (SETQ DOCUMENTATION (GET BENCHMARK 'TIMING-DOCUMENTATION)) (IF DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) (IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (SETQ TIMES (CONS (TIME-CALL #'(LAMBDA NIL (FUNCALL TIMING-FUNCTION)) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) TIMES)) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") (IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) (FUNCALL AFTER-FUNCTION))) (IL:* IL:|;;| "Now compute the average times for this group of runs:") (DOLIST (INDICATOR (ALL-TIME-INDICATORS TIMES)) (IL:* IL:|;;| "TOTAL THE TIMES") (IL:* IL:|;;| "COMPUTE THE AVERAGE") (IL:* IL:|;;| "ADD TO TOTALTIMES FOR THIS TIMING.") (SETQ AVG-TIMES (APPEND (LIST INDICATOR (/ (IL:FOR TIME-LIST IL:IN TIMES IL:SUM (OR (IL:LISTGET TIME-LIST INDICATOR) 0)) *MINIMUM-TESTS*)) AVG-TIMES))) (PRINT (LIST BENCHMARK (IL:DATE) AVG-TIMES (REVERSE TIMES)) RESULT-STREAM))))) (IL:* IL:|;;| "Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:") (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) 'IL:PAGEFULLFN 'NIL)) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) (DEFUN TIME-CALL (CL::TIMED-FUNCTION &KEY (CL::OUTPUT *TRACE-OUTPUT*) (CL::TIMED-FORM NIL CL::TIMED-FORM-P) (CL::DATA-TYPES (IL:DATATYPES)) (CL::REPEAT 1)) (LET ((VALUES NIL) (CL::TIME-BEFORE (CL::MAKE-STATS-OBJECT)) (CL::TIME-AFTER (CL::MAKE-STATS-OBJECT)) (CL::TIME-DO-NOTHING (CL::MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (CL::%GET-TIMING-INFO #'(LAMBDA NIL NIL) CL::TIME-BEFORE CL::TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (CL::%GET-TIMING-INFO CL::TIMED-FUNCTION CL::TIME-BEFORE CL::TIME-AFTER CL::REPEAT))) (CL::%STATS-OBJECT-DIFFERENCE CL::TIME-DO-NOTHING CL::TIME-AFTER) (IF CL::TIMED-FORM-P (CL::TIME-FORMAT CL::OUTPUT "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" CL::REPEAT CL::TIMED-FORM)) (CL::%PRINT-TIMING-ITEM CL::OUTPUT "Elapsed time" (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) T T) (CL::%PRINT-TIMING-INFO CL::OUTPUT CL::TIME-AFTER CL::DATA-TYPES) (LIST ':TOTAL (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) :GC (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :SWAP (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :I/O (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER))))) (DEFUN ALL-TIME-INDICATORS (TIME-LIST) (LET (ALL-INDICATORS) (DOLIST (TIMES TIME-LIST) (SETQ ALL-INDICATORS (UNION ALL-INDICATORS (IL:FOR IND IL:IN TIMES IL:BY CDDR IL:COLLECT IND)))) ALL-INDICATORS)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "GABRIEL"))) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.LCOM b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM new file mode 100644 index 00000000..29adca17 --- /dev/null +++ b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "GABRIEL")) (IL:FILECREATED "20-Oct-2020 02:46:56" ("compiled on " IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.;1|) " 9-Apr-2000 18:01:32" IL:|bcompl'd| IL:|in| "Medley 3.5 Full Sysout 13-Aug-2020 ..." IL:|dated| "13-Aug-2020 12:39:12") (IL:FILECREATED "12-Aug-88 10:32:50" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;7 17901 IL:|changes| IL:|to:| (IL:FUNCTIONS RUN-BENCHMARKS) IL:|previous| IL:|date:| "28-Jul-88 03:21:26" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;6) (IL:PRETTYCOMPRINT IL:GABRIEL-TIMERSCOMS) (IL:RPAQQ IL:GABRIEL-TIMERSCOMS ((IL:* IL:|;;| "Main file for running [Gabriel] Benchmark suites in Xerox Lisp:") (IL:COMS (IL:* IL:|;;| "Definitions for the TIMERS type, and the definer for them:") (IL:DEFINE-TYPES TIMERS) (IL:FUNCTIONS DEFINE-TIMER)) (IL:COMS (IL:* IL:|;;| "CONTROL VARIABLES") (IL:* IL:|;;| " *ALL-TIMERS* - List of all the benchmark definitions you've loaded.") (IL:* IL:|;;| " *MINIMUM-TESTS* - Min # of times to run each test, defaults to 2.") (IL:VARIABLES *ALL-TIMERS* *MINIMUM-TESTS* *MOST-TIMERS*)) (IL:COMS (IL:* IL:|;;| "Functions for running benchmarks. RUN-BENCHMARKS is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." ) (IL:FUNCTIONS RUN-BENCHMARKS DESCRIBE-IMPLEMENTATION)) (IL:COMS (IL:* IL:|;;| "Functions for running benchmarks and saving the results in a database of benchmarks. RUN-BENCHMARKS-TO-DATABASE is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." ) (IL:FUNCTIONS RUN-BENCHMARKS-TO-DATABASE TIME-CALL ALL-TIME-INDICATORS)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:GABRIEL-TIMERS ))) (XCL:DEF-DEFINE-TYPE TIMERS "Gabriel Benchmarks") (XCL:DEFDEFINER (DEFINE-TIMER (:NAME (LAMBDA (WHOLE) (IF (CONSP (SECOND WHOLE)) (CAR (SECOND WHOLE)) ( SECOND WHOLE))))) TIMERS (NAME-AND-OPTIONS DOCUMENTATION &BODY BODY) (LET ((NAME (IF (CONSP NAME-AND-OPTIONS) (CAR NAME-AND-OPTIONS) NAME-AND-OPTIONS)) (SETUPFORM (CADR (ASSOC (QUOTE :SETUP) NAME-AND-OPTIONS))) (AFTER-EVERY-FORM (CADR (ASSOC (QUOTE :AFTER-EVERY) NAME-AND-OPTIONS))) (AFTERFORM (CADR (ASSOC (QUOTE :AFTER) NAME-AND-OPTIONS)))) (LET ((TIMER (GENTEMP))) (IL:BQUOTE (PROGN (PUSHNEW (QUOTE (IL:\\\, NAME)) *ALL-TIMERS*) (DEFUN (IL:\\\, TIMER) NIL (IL:\\\,@ BODY)) (SETF (GET (QUOTE ( IL:\\\, NAME)) (QUOTE TIMING-FUNCTION)) (QUOTE (IL:\\\, TIMER))) (IL:\\\,@ (IF SETUPFORM (LET ((SETUP (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, SETUP) NIL (IL:\\\, SETUPFORM)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE SETUP-FUNCTION)) (QUOTE (IL:\\\, SETUP)))))))) (IL:\\\,@ (IF AFTER-EVERY-FORM (LET (( AFTER-EVERY (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, AFTER-EVERY) NIL (IL:\\\, AFTER-EVERY-FORM)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE AFTER-EVERY-FUNCTION)) (QUOTE (IL:\\\, AFTER-EVERY)))))))) (IL:\\\,@ (IF AFTERFORM (LET ((AFTER (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, AFTER) NIL (IL:\\\, AFTERFORM)) ( SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE AFTER-FUNCTION)) (QUOTE (IL:\\\, AFTER)))))))) (SETF (GET ( QUOTE (IL:\\\, NAME)) (QUOTE TIMING-DOCUMENTATION)) (IL:\\\, DOCUMENTATION))))))) (DEFVAR *ALL-TIMERS* NIL) (DEFPARAMETER *MINIMUM-TESTS* 2 "Run each test at least this many times") (DEFVAR *MOST-TIMERS* (QUOTE (TAKR TAKL TAK STAK CTAK TRIANG TRAVERSE-INIT TRAVERSE TPRINT PUZZLE FPRINT FREAD FFT DIV2-2 DIV2-1 DESTRU DERIV DDERIV BROWSE BOYER TRAVERSE-INIT* TRAVERSE* BROWSE*))) (DEFUN RUN-BENCHMARKS (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE (QUOTE {DSK}GABRIEL.BENCHMARKS)) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (APPEND-DRIBBLE-FILE NIL)) (IL:* IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| "Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS)) (UNWIND-PROTECT ( PROGN (IL:* IL:|;;| "Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE "GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)) (IL:* IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE APPEND-DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK ( QUOTE TIMING-FUNCTION))) (SETQ SETUP-FUNCTION (GET BENCHMARK (QUOTE SETUP-FUNCTION))) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK (QUOTE AFTER-EVERY-FUNCTION))) (SETQ AFTER-FUNCTION (GET BENCHMARK (QUOTE AFTER-FUNCTION))) (SETQ DOCUMENTATION (GET BENCHMARK (QUOTE TIMING-DOCUMENTATION))) (IF DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) (IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (CL::TIME-CALL (FUNCTION ( LAMBDA NIL (FUNCALL TIMING-FUNCTION))) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") ( IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) ( FUNCALL AFTER-FUNCTION)))))) (IL:* IL:|;;| "Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:" ) (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN ) (QUOTE NIL))) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) (DEFUN DESCRIBE-IMPLEMENTATION (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (FORMAT STREAM "~&Lisp Type:~20T~A" (LISP-IMPLEMENTATION-TYPE)) (FORMAT STREAM "~&Lisp Version:~20T~A" ( LISP-IMPLEMENTATION-VERSION)) (FORMAT STREAM "~&Software Type:~20T~A" (SOFTWARE-TYPE)) (FORMAT STREAM "~&Software Version:~20T~A" (SOFTWARE-VERSION)) (FORMAT STREAM "~&Machine Type:~20T~A" (MACHINE-TYPE)) (FORMAT STREAM "~&Machine Version:~20T~A" (MACHINE-VERSION)) (FORMAT STREAM "~&Machine Instance:~20T~A" (MACHINE-INSTANCE)) (FORMAT STREAM "~&Site:~20T~A" (LONG-SITE-NAME)) ( FORMAT STREAM "~&Features:~20T~S" *FEATURES*)) (DEFUN RUN-BENCHMARKS-TO-DATABASE (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE (QUOTE {DSK}GABRIEL.BENCHMARKS)) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (TOTAL-TIMES-FILE (QUOTE {DSK}) GABRIEL.TOTALTIMES)) (IL:* IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| "Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS) TOTALTIMES TIMES AVG-TIMES) (UNWIND-PROTECT (PROGN (IL:* IL:|;;| "Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE "GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)) (IL:* IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (WITH-OPEN-FILE (RESULT-STREAM TOTAL-TIMES-FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK (QUOTE TIMING-FUNCTION))) (SETQ SETUP-FUNCTION (GET BENCHMARK (QUOTE SETUP-FUNCTION))) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK (QUOTE AFTER-EVERY-FUNCTION))) (SETQ AFTER-FUNCTION (GET BENCHMARK (QUOTE AFTER-FUNCTION))) (SETQ DOCUMENTATION (GET BENCHMARK (QUOTE TIMING-DOCUMENTATION))) (IF DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) ( IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (SETQ TIMES ( CONS (TIME-CALL (FUNCTION (LAMBDA NIL (FUNCALL TIMING-FUNCTION))) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) TIMES)) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") (IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) (FUNCALL AFTER-FUNCTION))) (IL:* IL:|;;| "Now compute the average times for this group of runs:") (DOLIST (INDICATOR (ALL-TIME-INDICATORS TIMES )) (IL:* IL:|;;| "TOTAL THE TIMES") (IL:* IL:|;;| "COMPUTE THE AVERAGE") (IL:* IL:|;;| "ADD TO TOTALTIMES FOR THIS TIMING.") (SETQ AVG-TIMES (APPEND (LIST INDICATOR (/ (IL:FOR TIME-LIST IL:IN TIMES IL:SUM (OR (IL:LISTGET TIME-LIST INDICATOR) 0)) *MINIMUM-TESTS*)) AVG-TIMES))) (PRINT (LIST BENCHMARK (IL:DATE) AVG-TIMES (REVERSE TIMES)) RESULT-STREAM))))) (IL:* IL:|;;| "Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:" ) (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN ) (QUOTE NIL))) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) (DEFUN TIME-CALL (CL::TIMED-FUNCTION &KEY (CL::OUTPUT *TRACE-OUTPUT*) (CL::TIMED-FORM NIL CL::TIMED-FORM-P) (CL::DATA-TYPES (IL:DATATYPES)) (CL::REPEAT 1)) (LET ((VALUES NIL) (CL::TIME-BEFORE (CL::MAKE-STATS-OBJECT)) (CL::TIME-AFTER (CL::MAKE-STATS-OBJECT)) (CL::TIME-DO-NOTHING ( CL::MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (CL::%GET-TIMING-INFO (FUNCTION (LAMBDA NIL NIL)) CL::TIME-BEFORE CL::TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (CL::%GET-TIMING-INFO CL::TIMED-FUNCTION CL::TIME-BEFORE CL::TIME-AFTER CL::REPEAT))) (CL::%STATS-OBJECT-DIFFERENCE CL::TIME-DO-NOTHING CL::TIME-AFTER) (IF CL::TIMED-FORM-P (CL::TIME-FORMAT CL::OUTPUT "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" CL::REPEAT CL::TIMED-FORM)) (CL::%PRINT-TIMING-ITEM CL::OUTPUT "Elapsed time" (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) T T) (CL::%PRINT-TIMING-INFO CL::OUTPUT CL::TIME-AFTER CL::DATA-TYPES) (LIST (QUOTE :TOTAL) (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) :GC (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :SWAP ( IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :I/O ( IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER))))) (DEFUN ALL-TIME-INDICATORS (TIME-LIST) (LET (ALL-INDICATORS) (DOLIST (TIMES TIME-LIST) (SETQ ALL-INDICATORS (UNION ALL-INDICATORS (IL:FOR IND IL:IN TIMES IL:BY CDDR IL:COLLECT IND)))) ALL-INDICATORS)) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "GABRIEL"))) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) NIL \ No newline at end of file diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~1~ b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..dcb5d18f9682dff1f2e87da4f9a04ae4f53885d7 GIT binary patch literal 12280 zcmdT~-)|dNb|xujlVxH-5(L3Z7{&z~JCu-dIQ%7wUMw;qhtf#o3_UXx?ZmFYNVFxJ zmRyN)W2{y{@(;Az1zNOSY>R#AW9`Kn*w{{pKK7~IT|ex9u^YJW?sx8;8O~5cS#jHk z8ZtS&Kh8b(-gCbDopUEuQLCD+N>#0s%Q(5v_xt3%X8cKOpSyEXF zZQbYOlCo%OYArcC8&7Gq67?^mr>$04QqD-q!ELEnWOBNc&6ec(BugbXcJJNa?shiW z?hZ>b^!c%BYSvGFSktUV*)Y`~IU;{#8%E7?e@V7hS552kjVtrrNtwe9`;8@qcQHt2Qv@@3Irv)$`#9<>4#+B>&9`-ij?hrQj>A>#|#)XTPJ=oT}Zy0ob3<>k6! zu3EFa+5NrFgYDe|rxVQq-IAH2yC~^wDI=FMg(M&1J1%fR%-d`zSFh4&&VD#MfJL@g zid3BAs$983t5}>DcW}hy#Kik{xbZ@f7&d$cxz4qQ+wtukQ z>+CZ$zt-8?{hZO}l#;W2(n9u-=t}3-_Re;1dv|A_3-4`pm@o#`dw9R|A#3k!GAi7p zhMhgP(LGnHW7_uhhH5!I#c)+`jpJ?`GP2o`%D}>O+cauyO))ic4a-s7zZ7gvsnwjt znqv}8u*Y_9v39r1)%?s`3a+p-vxmC}A3W%=?rwXtvw1mGY+ci}db2Lss%2XwxsFBr zGZNj~zK134?b5=tPJ3gEVTpSm(u%YXx;aANaQL~879eGvjo0Zw6bCwrsb?jMJ?A9Q@v3lkFLPR%SPimhmMM&t|_&T9c1O} zUNayKMr5(e%ytAcOrs$-1<*^5MuO_fDh?Ikv8u0WrlHfOa`*}YN_^HiJ1o_fDn_|E z*!#p@J)LgaX)77=>1MRpTqLR5KQp8XF#y zYiyV-wP-Z;3M@fv$nj<@#dl)3g6SG&9ZvyXD>z$p1Jhhm?PbMUc4fJXN~<|HSapfo zNSvn3kuB23HJYJ4<0o`wDKb`{Fcz{ZtYm4Qs4SmmB~#_&I=^XaIs0+VjI6$~y2QUn({uOEQ zI=TlvduTwcgR7@&LPG60^GhL9JRA@Usq^`L@T1P2cq9`0I5zpkJIm3pmSdkppRL56Ynx+#9lafiXfv^)ugNp-y%ULi zjXLpXOl>6+yOBsFkw8IxtCrvo;gyL58YhhDU*{m>8?@24jA<&OzF}Q-R8l?u8#BKy zqSyL(9}SK1Eo0`Sj%YCGc~114;5{d{jB_XUoEY>B(`uDEZzbNN87C4GkyJKaWJ;r< z0_!rFdA0-_RO<~U7ZwK3a^8E+c}-wZnc_SX(2yzS(8Ok$A~sO9t1MF}xK;U#`;;S@ zXp}2Bjj~zrBM@JfffhoNypZ#rWZqmx$i`*L^LeMaoR{53Syu%)D^!rPjta88;5JXE zo#sVXt74YRF2brv-Few*ns>$JbF9&{mUXqoFc@HPNoN?Vq*QIyWLdy2f0EQS)x6F! zS>Um1Hyckt`-V@5yTj77(O7K=tFV$q2RATdt=Q=x$NTCH`Zu6i1W>+*){(J(a~0SbJl zhJ1rJMheOjp`ry*EyelgHacoP8llTVQGtBPM$$^o)! z)n*lKEhA;b7Xi0rn@xO~+8V2fuSL^nA+TLEt^=%tqs)23%rVgnTph*|%xo#?bXum5 zjK@x@pdiC=$|7$?qLIj*#&`glLS%Vj2!c43nQQ7T1iunC!&b{S&)PJOk3rt8IqYYy zTvHXj*&v2jN7e;ZRr01etgK#9%!*`yCpLvF)L@N}#z1O_$A?byEcPmxyb)q@4iAt* z`sA5E=@)tRE~ZVi>HCpLYX%>}^WVjETl=+t(o{+C|C(}Um5Rr&)!*|=!29Q&_=${zjEn8w3&|Ixp! z270ZI_v^98uVy2uOfJi49~3YetTYzUq|60^RJpj|*2wb(MqwZUpGbVj`9Wo-;I)%I zVW1n1Sg?#ynJ7>-XPZD5Xl(2{S(DL%If1^(RMx7RM!jOO0@HNKNs_~*<$16dVJP5v z1soJmuEK2!zq3R6F`p;M;8BhT1XCjmX%=KL48+REk39atFm#Zvu!1Mk!+Lq1w8zm= zV>mi!a>(>oo3&b1hx#B}3oLnbQGL+v9<+Ou1#92xQL5ER%JH1*QTym(5<8I(ZQ6Oz z*?Sn;A)loV8stGVE(MPEDU-&f#ov)nt$D#4u=jx+0L{LJy_(-tB$qP*4=uVF>axSblh34K@;s8Uvj? zOoO@m;EA*Zp+CMbqM{f$`$gG8m|j@iG@El)dk(95_w6&WNM|w{xx4)B-?S#axZ9qT z&vawU-~J2;^JO>Ie%c+QnyD|lW9?_%Gt1xpbnDCRnfCM6H1=S1GWI>R!xR1pXzKXx zx5n{_V%nZQ9$Vvtlq=3=rE@M4ASgoSv#DAVE~ab-e*KB3{IYNy>hz@0_uD3i92tRzFYjA9EnaiT~`G7j69>bN|@ zB^uLq_IvG}jY0K%j(WJ&Yn{D)K(*UBPNwOrws9}#)-fa_Xsq2^y}xYZ4tA(3%gKT2 zKv$f`=t?()!`*N&5bBFMf1hE1^xuUH&Q*E};`|%Y%y8izCZEVV-<)6)cd!T=fS1`} z79fgYU6dLbkN{Df4`&FXvcQzJB_1xi!a;Zf*D<0U;5?MfE*v`%K$C`+RcM{zR7pwa z1i}GQG7O;6tl1Lc3RS5i%XszO_af2OrOCf|dwKJhkE1_~ekF*eMzF29ly)QKdp_@b zzTkUK_@0yhD8#gqB&T)$pL|m9w9bRxzJKTI=e7FFUo}KcT^sOP&EvJLbBT>}{nmwG z_Y0ifK6|>d`ttATyji{b;@PABs^5L_^`n1nC4y}e80s93pDj?~KYwyTL;DsJC6p#? zeF#e5UyfaS{Aw(^KHfTaXL9PSF){Y!2gcM?>wQ!r+;1^_Z?L`|d-P2d#F-emG5*1m zu{$q_pHIZrCm#LB6b-U5M@Jpy9+9&1A8T2#T5PL#IAwr}Zf+9C8}aCiAF&Lj=6HOV z0dSd=8$+m?SB~m`h`eh$}c$S}yWmqp9?%z&7XMA@S*ep9?q` zpaEFJSt8O6INDWln$N=q4GRZa3V5w78m5iM*N*EAc_IWiC`_xBJRl-od`v%L#zB)n zmj;4}q40~BX2MN_*YO{t=FPH_^2HtG+8x5Vwd6p}R!1lEfE>961T|5@ydZdCge{P9%F%%g?6dKtIZBPDoe7PHY_H=b~<>fCQM_zzXKHvTtMc{eg7~`8d zmHxiJbrTs+Dix{J=}lvbDt^}o_^!|JnnZv7T;E7+8t16yKl^vr&r_}Vn;e^j2^bd) z;;|aOnQ5m@nqMYlHz$!lmngN`JE(S5zaV$tpdy1CD1 ze9vd`EH0Pm{<@7OfBM_iyMJguewAA7#$J5-_|*(A{5xY@lp5nGULSw_YT7BE=H+w7 zG?h;e$`ej`g31$+gA}jGt=_nSYioK_uBu&w4}%AC3-lMtF!1Ar^F={gIbEe_hVEkd z3(b^+<$N|+h5JJ$gVT8_W0#a7Fy+mG3$`U0iz~o%siIY@s)@I8Rm5IAQR=w`-GcKD zP%=0$;+^mcOp7Y`yGQECYheDQcQ9hNGOpQ^ zYPWrVA8&Zmd#T6>!;h2p_B~1))7!yEpB`N~D&Y_5*$Vso=q67Uup{f}60%Y**kaS% zw-kde$vu@aX>?!x(f4p)J(-SueErFp<%#Ii<;nD0D}S{aeO7z&HeS5A`Nis`=dsw> zlRws{V8y@DVvqh1N#)Y4sUwf$WJ#bl77oZrd3=8E1Yc03Wu=#lc%H`pj`?XihP?#I zQrMN?%k@a}IWO1KeKW3H-QV#+t~z*4K0;A?bJNt8mhrMsQoLYY-rc*uD^ly&iv?^X LK8g@V7sdY#(7{XJ literal 0 HcmV?d00001 diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~2~ b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~2~ new file mode 100644 index 00000000..35802167 --- /dev/null +++ b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~2~ @@ -0,0 +1,132 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "GABRIEL")) +(IL:FILECREATED "21-Oct-91 23:28:45" ("compiled on " +IL:|{DSK}local>lde>lispcore>gabriel>TOOLS>GABRIEL-TIMERS.;1|) "27-Aug-91 19:40:51" IL:|bcompl'd| +IL:|in| "Medley 28-Aug-91 ..." IL:|dated| "28-Aug-91 09:16:07") +(IL:FILECREATED "12-Aug-88 10:32:50" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;7 17901 +IL:|changes| IL:|to:| (IL:FUNCTIONS RUN-BENCHMARKS) IL:|previous| IL:|date:| "28-Jul-88 03:21:26" +IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;6) +(IL:PRETTYCOMPRINT IL:GABRIEL-TIMERSCOMS) +(IL:RPAQQ IL:GABRIEL-TIMERSCOMS ((IL:* IL:|;;| +"Main file for running [Gabriel] Benchmark suites in Xerox Lisp:") (IL:COMS (IL:* IL:|;;| +"Definitions for the TIMERS type, and the definer for them:") (IL:DEFINE-TYPES TIMERS) (IL:FUNCTIONS +DEFINE-TIMER)) (IL:COMS (IL:* IL:|;;| "CONTROL VARIABLES") (IL:* IL:|;;| +" *ALL-TIMERS* - List of all the benchmark definitions you've loaded.") (IL:* IL:|;;| +" *MINIMUM-TESTS* - Min # of times to run each test, defaults to 2.") (IL:VARIABLES *ALL-TIMERS* +*MINIMUM-TESTS* *MOST-TIMERS*)) (IL:COMS (IL:* IL:|;;| +"Functions for running benchmarks. RUN-BENCHMARKS is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." +) (IL:FUNCTIONS RUN-BENCHMARKS DESCRIBE-IMPLEMENTATION)) (IL:COMS (IL:* IL:|;;| +"Functions for running benchmarks and saving the results in a database of benchmarks. RUN-BENCHMARKS-TO-DATABASE is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." +) (IL:FUNCTIONS RUN-BENCHMARKS-TO-DATABASE TIME-CALL ALL-TIME-INDICATORS)) (IL:DECLARE\: IL:DONTCOPY +IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:GABRIEL-TIMERS +))) +(XCL:DEF-DEFINE-TYPE TIMERS "Gabriel Benchmarks") +(XCL:DEFDEFINER (DEFINE-TIMER (:NAME (LAMBDA (WHOLE) (IF (CONSP (SECOND WHOLE)) (CAR (SECOND WHOLE)) ( +SECOND WHOLE))))) TIMERS (NAME-AND-OPTIONS DOCUMENTATION &BODY BODY) (LET ((NAME (IF (CONSP +NAME-AND-OPTIONS) (CAR NAME-AND-OPTIONS) NAME-AND-OPTIONS)) (SETUPFORM (CADR (ASSOC (QUOTE :SETUP) +NAME-AND-OPTIONS))) (AFTER-EVERY-FORM (CADR (ASSOC (QUOTE :AFTER-EVERY) NAME-AND-OPTIONS))) (AFTERFORM + (CADR (ASSOC (QUOTE :AFTER) NAME-AND-OPTIONS)))) (LET ((TIMER (GENTEMP))) (IL:BQUOTE (PROGN (PUSHNEW +(QUOTE (IL:\\\, NAME)) *ALL-TIMERS*) (DEFUN (IL:\\\, TIMER) NIL (IL:\\\,@ BODY)) (SETF (GET (QUOTE ( +IL:\\\, NAME)) (QUOTE TIMING-FUNCTION)) (QUOTE (IL:\\\, TIMER))) (IL:\\\,@ (IF SETUPFORM (LET ((SETUP +(GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, SETUP) NIL (IL:\\\, SETUPFORM)) (SETF (GET (QUOTE (IL:\\\, +NAME)) (QUOTE SETUP-FUNCTION)) (QUOTE (IL:\\\, SETUP)))))))) (IL:\\\,@ (IF AFTER-EVERY-FORM (LET (( +AFTER-EVERY (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, AFTER-EVERY) NIL (IL:\\\, AFTER-EVERY-FORM)) (SETF + (GET (QUOTE (IL:\\\, NAME)) (QUOTE AFTER-EVERY-FUNCTION)) (QUOTE (IL:\\\, AFTER-EVERY)))))))) (IL:\\\,@ + (IF AFTERFORM (LET ((AFTER (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, AFTER) NIL (IL:\\\, AFTERFORM)) ( +SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE AFTER-FUNCTION)) (QUOTE (IL:\\\, AFTER)))))))) (SETF (GET ( +QUOTE (IL:\\\, NAME)) (QUOTE TIMING-DOCUMENTATION)) (IL:\\\, DOCUMENTATION))))))) +(DEFVAR *ALL-TIMERS* NIL) +(DEFPARAMETER *MINIMUM-TESTS* 2 "Run each test at least this many times") +(DEFVAR *MOST-TIMERS* (QUOTE (TAKR TAKL TAK STAK CTAK TRIANG TRAVERSE-INIT TRAVERSE TPRINT PUZZLE +FPRINT FREAD FFT DIV2-2 DIV2-1 DESTRU DERIV DDERIV BROWSE BOYER TRAVERSE-INIT* TRAVERSE* BROWSE*))) +(DEFUN RUN-BENCHMARKS (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE (QUOTE +{DSK}GABRIEL.BENCHMARKS)) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (APPEND-DRIBBLE-FILE NIL)) (IL:* +IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| +"Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET + ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS)) (UNWIND-PROTECT ( +PROGN (IL:* IL:|;;| +"Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE +"GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)) (IL:* +IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE +APPEND-DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION +AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT +*STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK ( +QUOTE TIMING-FUNCTION))) (SETQ SETUP-FUNCTION (GET BENCHMARK (QUOTE SETUP-FUNCTION))) (SETQ +AFTER-EVERY-FUNCTION (GET BENCHMARK (QUOTE AFTER-EVERY-FUNCTION))) (SETQ AFTER-FUNCTION (GET BENCHMARK + (QUOTE AFTER-FUNCTION))) (SETQ DOCUMENTATION (GET BENCHMARK (QUOTE TIMING-DOCUMENTATION))) (IF +DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| +"Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* +"~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) (IL:* IL:|;;| +"Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* +"~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (CL::TIME-CALL (FUNCTION ( +LAMBDA NIL (FUNCALL TIMING-FUNCTION))) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) (IL:* IL:|;;| +"Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT +*STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL +AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") ( +IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) ( +FUNCALL AFTER-FUNCTION)))))) (IL:* IL:|;;| +"Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:" +) (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN +) (QUOTE NIL))) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) +(DEFUN DESCRIBE-IMPLEMENTATION (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (FORMAT STREAM +"~&Lisp Type:~20T~A" (LISP-IMPLEMENTATION-TYPE)) (FORMAT STREAM "~&Lisp Version:~20T~A" ( +LISP-IMPLEMENTATION-VERSION)) (FORMAT STREAM "~&Software Type:~20T~A" (SOFTWARE-TYPE)) (FORMAT STREAM +"~&Software Version:~20T~A" (SOFTWARE-VERSION)) (FORMAT STREAM "~&Machine Type:~20T~A" (MACHINE-TYPE)) + (FORMAT STREAM "~&Machine Version:~20T~A" (MACHINE-VERSION)) (FORMAT STREAM +"~&Machine Instance:~20T~A" (MACHINE-INSTANCE)) (FORMAT STREAM "~&Site:~20T~A" (LONG-SITE-NAME)) ( +FORMAT STREAM "~&Features:~20T~S" *FEATURES*)) +(DEFUN RUN-BENCHMARKS-TO-DATABASE (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE (QUOTE +{DSK}GABRIEL.BENCHMARKS)) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (TOTAL-TIMES-FILE (QUOTE {DSK}) +GABRIEL.TOTALTIMES)) (IL:* IL:|;;| +"Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| +"Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET + ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS) TOTALTIMES TIMES +AVG-TIMES) (UNWIND-PROTECT (PROGN (IL:* IL:|;;| +"Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE +"GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)) (IL:* +IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE) +(DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION +DOCUMENTATION) (WITH-OPEN-FILE (RESULT-STREAM TOTAL-TIMES-FILE :DIRECTION :OUTPUT :IF-EXISTS +:NEW-VERSION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" +BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK (QUOTE TIMING-FUNCTION))) (SETQ SETUP-FUNCTION (GET +BENCHMARK (QUOTE SETUP-FUNCTION))) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK (QUOTE +AFTER-EVERY-FUNCTION))) (SETQ AFTER-FUNCTION (GET BENCHMARK (QUOTE AFTER-FUNCTION))) (SETQ +DOCUMENTATION (GET BENCHMARK (QUOTE TIMING-DOCUMENTATION))) (IF DOCUMENTATION (FORMAT +*STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION +(PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) ( +IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT +*STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (SETQ TIMES ( +CONS (TIME-CALL (FUNCTION (LAMBDA NIL (FUNCALL TIMING-FUNCTION))) :TIMED-FORM BENCHMARK :OUTPUT +*STANDARD-OUTPUT*) TIMES)) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF +AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" +BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| +"Now clean up after the test:") (IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* +"~%Evaluating after function for ~a~%" BENCHMARK) (FUNCALL AFTER-FUNCTION))) (IL:* IL:|;;| +"Now compute the average times for this group of runs:") (DOLIST (INDICATOR (ALL-TIME-INDICATORS TIMES +)) (IL:* IL:|;;| "TOTAL THE TIMES") (IL:* IL:|;;| "COMPUTE THE AVERAGE") (IL:* IL:|;;| +"ADD TO TOTALTIMES FOR THIS TIMING.") (SETQ AVG-TIMES (APPEND (LIST INDICATOR (/ (IL:FOR TIME-LIST IL:IN + TIMES IL:SUM (OR (IL:LISTGET TIME-LIST INDICATOR) 0)) *MINIMUM-TESTS*)) AVG-TIMES))) (PRINT (LIST +BENCHMARK (IL:DATE) AVG-TIMES (REVERSE TIMES)) RESULT-STREAM))))) (IL:* IL:|;;| +"Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:" +) (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN +) (QUOTE NIL))) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) +(DEFUN TIME-CALL (CL::TIMED-FUNCTION &KEY (CL::OUTPUT *TRACE-OUTPUT*) (CL::TIMED-FORM NIL +CL::TIMED-FORM-P) (CL::DATA-TYPES (IL:DATATYPES)) (CL::REPEAT 1)) (LET ((VALUES NIL) (CL::TIME-BEFORE +(CL::MAKE-STATS-OBJECT)) (CL::TIME-AFTER (CL::MAKE-STATS-OBJECT)) (CL::TIME-DO-NOTHING ( +CL::MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (CL::%GET-TIMING-INFO (FUNCTION (LAMBDA NIL NIL)) +CL::TIME-BEFORE CL::TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (CL::%GET-TIMING-INFO +CL::TIMED-FUNCTION CL::TIME-BEFORE CL::TIME-AFTER CL::REPEAT))) (CL::%STATS-OBJECT-DIFFERENCE +CL::TIME-DO-NOTHING CL::TIME-AFTER) (IF CL::TIMED-FORM-P (CL::TIME-FORMAT CL::OUTPUT +"Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" CL::REPEAT CL::TIMED-FORM)) (CL::%PRINT-TIMING-ITEM CL::OUTPUT + "Elapsed time" (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) T T) (CL::%PRINT-TIMING-INFO CL::OUTPUT + CL::TIME-AFTER CL::DATA-TYPES) (LIST (QUOTE :TOTAL) (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) +:GC (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :SWAP ( +IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :I/O ( +IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER))))) +(DEFUN ALL-TIME-INDICATORS (TIME-LIST) (LET (ALL-INDICATORS) (DOLIST (TIMES TIME-LIST) (SETQ +ALL-INDICATORS (UNION ALL-INDICATORS (IL:FOR IND IL:IN TIMES IL:BY CDDR IL:COLLECT IND)))) +ALL-INDICATORS)) +(IL:PUTPROPS IL:GABRIEL-TIMERS IL:FILETYPE COMPILE-FILE) +(IL:PUTPROPS IL:GABRIEL-TIMERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE +"GABRIEL"))) +(IL:PUTPROPS IL:GABRIEL-TIMERS IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) +NIL diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~3~ b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~3~ new file mode 100644 index 00000000..29adca17 --- /dev/null +++ b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~3~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "GABRIEL")) (IL:FILECREATED "20-Oct-2020 02:46:56" ("compiled on " IL:|{DSK}larry>ilisp>envos>lispcore>gabriel>tools>GABRIEL-TIMERS.;1|) " 9-Apr-2000 18:01:32" IL:|bcompl'd| IL:|in| "Medley 3.5 Full Sysout 13-Aug-2020 ..." IL:|dated| "13-Aug-2020 12:39:12") (IL:FILECREATED "12-Aug-88 10:32:50" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;7 17901 IL:|changes| IL:|to:| (IL:FUNCTIONS RUN-BENCHMARKS) IL:|previous| IL:|date:| "28-Jul-88 03:21:26" IL:{ERIS}GABRIEL>TOOLS>GABRIEL-TIMERS.\;6) (IL:PRETTYCOMPRINT IL:GABRIEL-TIMERSCOMS) (IL:RPAQQ IL:GABRIEL-TIMERSCOMS ((IL:* IL:|;;| "Main file for running [Gabriel] Benchmark suites in Xerox Lisp:") (IL:COMS (IL:* IL:|;;| "Definitions for the TIMERS type, and the definer for them:") (IL:DEFINE-TYPES TIMERS) (IL:FUNCTIONS DEFINE-TIMER)) (IL:COMS (IL:* IL:|;;| "CONTROL VARIABLES") (IL:* IL:|;;| " *ALL-TIMERS* - List of all the benchmark definitions you've loaded.") (IL:* IL:|;;| " *MINIMUM-TESTS* - Min # of times to run each test, defaults to 2.") (IL:VARIABLES *ALL-TIMERS* *MINIMUM-TESTS* *MOST-TIMERS*)) (IL:COMS (IL:* IL:|;;| "Functions for running benchmarks. RUN-BENCHMARKS is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." ) (IL:FUNCTIONS RUN-BENCHMARKS DESCRIBE-IMPLEMENTATION)) (IL:COMS (IL:* IL:|;;| "Functions for running benchmarks and saving the results in a database of benchmarks. RUN-BENCHMARKS-TO-DATABASE is the main entry; DESCRIBE-IMPLEMENTATION is a sub-function." ) (IL:FUNCTIONS RUN-BENCHMARKS-TO-DATABASE TIME-CALL ALL-TIME-INDICATORS)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:GABRIEL-TIMERS ))) (XCL:DEF-DEFINE-TYPE TIMERS "Gabriel Benchmarks") (XCL:DEFDEFINER (DEFINE-TIMER (:NAME (LAMBDA (WHOLE) (IF (CONSP (SECOND WHOLE)) (CAR (SECOND WHOLE)) ( SECOND WHOLE))))) TIMERS (NAME-AND-OPTIONS DOCUMENTATION &BODY BODY) (LET ((NAME (IF (CONSP NAME-AND-OPTIONS) (CAR NAME-AND-OPTIONS) NAME-AND-OPTIONS)) (SETUPFORM (CADR (ASSOC (QUOTE :SETUP) NAME-AND-OPTIONS))) (AFTER-EVERY-FORM (CADR (ASSOC (QUOTE :AFTER-EVERY) NAME-AND-OPTIONS))) (AFTERFORM (CADR (ASSOC (QUOTE :AFTER) NAME-AND-OPTIONS)))) (LET ((TIMER (GENTEMP))) (IL:BQUOTE (PROGN (PUSHNEW (QUOTE (IL:\\\, NAME)) *ALL-TIMERS*) (DEFUN (IL:\\\, TIMER) NIL (IL:\\\,@ BODY)) (SETF (GET (QUOTE ( IL:\\\, NAME)) (QUOTE TIMING-FUNCTION)) (QUOTE (IL:\\\, TIMER))) (IL:\\\,@ (IF SETUPFORM (LET ((SETUP (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, SETUP) NIL (IL:\\\, SETUPFORM)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE SETUP-FUNCTION)) (QUOTE (IL:\\\, SETUP)))))))) (IL:\\\,@ (IF AFTER-EVERY-FORM (LET (( AFTER-EVERY (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, AFTER-EVERY) NIL (IL:\\\, AFTER-EVERY-FORM)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE AFTER-EVERY-FUNCTION)) (QUOTE (IL:\\\, AFTER-EVERY)))))))) (IL:\\\,@ (IF AFTERFORM (LET ((AFTER (GENTEMP))) (IL:BQUOTE ((DEFUN (IL:\\\, AFTER) NIL (IL:\\\, AFTERFORM)) ( SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE AFTER-FUNCTION)) (QUOTE (IL:\\\, AFTER)))))))) (SETF (GET ( QUOTE (IL:\\\, NAME)) (QUOTE TIMING-DOCUMENTATION)) (IL:\\\, DOCUMENTATION))))))) (DEFVAR *ALL-TIMERS* NIL) (DEFPARAMETER *MINIMUM-TESTS* 2 "Run each test at least this many times") (DEFVAR *MOST-TIMERS* (QUOTE (TAKR TAKL TAK STAK CTAK TRIANG TRAVERSE-INIT TRAVERSE TPRINT PUZZLE FPRINT FREAD FFT DIV2-2 DIV2-1 DESTRU DERIV DDERIV BROWSE BOYER TRAVERSE-INIT* TRAVERSE* BROWSE*))) (DEFUN RUN-BENCHMARKS (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE (QUOTE {DSK}GABRIEL.BENCHMARKS)) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (APPEND-DRIBBLE-FILE NIL)) (IL:* IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| "Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS)) (UNWIND-PROTECT ( PROGN (IL:* IL:|;;| "Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE "GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)) (IL:* IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE APPEND-DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK ( QUOTE TIMING-FUNCTION))) (SETQ SETUP-FUNCTION (GET BENCHMARK (QUOTE SETUP-FUNCTION))) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK (QUOTE AFTER-EVERY-FUNCTION))) (SETQ AFTER-FUNCTION (GET BENCHMARK (QUOTE AFTER-FUNCTION))) (SETQ DOCUMENTATION (GET BENCHMARK (QUOTE TIMING-DOCUMENTATION))) (IF DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) (IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (CL::TIME-CALL (FUNCTION ( LAMBDA NIL (FUNCALL TIMING-FUNCTION))) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") ( IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) ( FUNCALL AFTER-FUNCTION)))))) (IL:* IL:|;;| "Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:" ) (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN ) (QUOTE NIL))) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) (DEFUN DESCRIBE-IMPLEMENTATION (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (FORMAT STREAM "~&Lisp Type:~20T~A" (LISP-IMPLEMENTATION-TYPE)) (FORMAT STREAM "~&Lisp Version:~20T~A" ( LISP-IMPLEMENTATION-VERSION)) (FORMAT STREAM "~&Software Type:~20T~A" (SOFTWARE-TYPE)) (FORMAT STREAM "~&Software Version:~20T~A" (SOFTWARE-VERSION)) (FORMAT STREAM "~&Machine Type:~20T~A" (MACHINE-TYPE)) (FORMAT STREAM "~&Machine Version:~20T~A" (MACHINE-VERSION)) (FORMAT STREAM "~&Machine Instance:~20T~A" (MACHINE-INSTANCE)) (FORMAT STREAM "~&Site:~20T~A" (LONG-SITE-NAME)) ( FORMAT STREAM "~&Features:~20T~S" *FEATURES*)) (DEFUN RUN-BENCHMARKS-TO-DATABASE (&OPTIONAL (BENCHMARKS *ALL-TIMERS*) (DRIBBLE-FILE (QUOTE {DSK}GABRIEL.BENCHMARKS)) (NUMBER-OF-ITERATIONS *MINIMUM-TESTS*) (TOTAL-TIMES-FILE (QUOTE {DSK}) GABRIEL.TOTALTIMES)) (IL:* IL:|;;| "Run the benchmarks named in BENCHMARKS (defaulting to all known timers)") (IL:* IL:|;;| "Dribble the timings to DRIBBLE-FILE") (IL:* IL:|;;| "Run each test NUMBER-OF-ITERATIONS times.") (LET ((OLD-PACKAGE (PACKAGE-NAME *PACKAGE*)) (*MINIMUM-TESTS* NUMBER-OF-ITERATIONS) TOTALTIMES TIMES AVG-TIMES) (UNWIND-PROTECT (PROGN (IL:* IL:|;;| "Set up so we're in the GABRIEL package, and the type-out won't pause on screen-full:") (IN-PACKAGE "GABRIEL") (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN) (QUOTE IL:NILL)) (IL:* IL:|;;| "Set up the dribble file, and describe the machine we're running on:") (DRIBBLE DRIBBLE-FILE) (DESCRIBE-IMPLEMENTATION) (LET (TIMING-FUNCTION SETUP-FUNCTION AFTER-EVERY-FUNCTION AFTER-FUNCTION DOCUMENTATION) (WITH-OPEN-FILE (RESULT-STREAM TOTAL-TIMES-FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (DOLIST (BENCHMARK BENCHMARKS) (FORMAT *STANDARD-OUTPUT* "~%~%***** ~A Benchmark ***~%" BENCHMARK) (SETQ TIMING-FUNCTION (GET BENCHMARK (QUOTE TIMING-FUNCTION))) (SETQ SETUP-FUNCTION (GET BENCHMARK (QUOTE SETUP-FUNCTION))) (SETQ AFTER-EVERY-FUNCTION (GET BENCHMARK (QUOTE AFTER-EVERY-FUNCTION))) (SETQ AFTER-FUNCTION (GET BENCHMARK (QUOTE AFTER-FUNCTION))) (SETQ DOCUMENTATION (GET BENCHMARK (QUOTE TIMING-DOCUMENTATION))) (IF DOCUMENTATION (FORMAT *STANDARD-OUTPUT* "~%~A~%~%" DOCUMENTATION)) (IL:* IL:|;;| "Set up for the test:") (IF SETUP-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating setup for ~a~%" BENCHMARK) (FUNCALL SETUP-FUNCTION))) ( IL:* IL:|;;| "Run the test the right number of times:") (DOTIMES (I *MINIMUM-TESTS*) (FORMAT *STANDARD-OUTPUT* "~%Iteration ~s of ~a~%" I BENCHMARK) (IL:* IL:|;;| "Run the timing:") (SETQ TIMES ( CONS (TIME-CALL (FUNCTION (LAMBDA NIL (FUNCALL TIMING-FUNCTION))) :TIMED-FORM BENCHMARK :OUTPUT *STANDARD-OUTPUT*) TIMES)) (IL:* IL:|;;| "Run the cleanup-after-each-iteration function:") (IF AFTER-EVERY-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after every function for ~a~%" BENCHMARK) (FUNCALL AFTER-EVERY-FUNCTION))) (DOTIMES (J 10) (IL:RECLAIM))) (IL:* IL:|;;| "Now clean up after the test:") (IF AFTER-FUNCTION (PROGN (FORMAT *STANDARD-OUTPUT* "~%Evaluating after function for ~a~%" BENCHMARK) (FUNCALL AFTER-FUNCTION))) (IL:* IL:|;;| "Now compute the average times for this group of runs:") (DOLIST (INDICATOR (ALL-TIME-INDICATORS TIMES )) (IL:* IL:|;;| "TOTAL THE TIMES") (IL:* IL:|;;| "COMPUTE THE AVERAGE") (IL:* IL:|;;| "ADD TO TOTALTIMES FOR THIS TIMING.") (SETQ AVG-TIMES (APPEND (LIST INDICATOR (/ (IL:FOR TIME-LIST IL:IN TIMES IL:SUM (OR (IL:LISTGET TIME-LIST INDICATOR) 0)) *MINIMUM-TESTS*)) AVG-TIMES))) (PRINT (LIST BENCHMARK (IL:DATE) AVG-TIMES (REVERSE TIMES)) RESULT-STREAM))))) (IL:* IL:|;;| "Now clean up: Set the package back as it was, close the dribble file, and restore the page-full function on the main window:" ) (DRIBBLE) (IN-PACKAGE OLD-PACKAGE) (IL:WINDOWPROP (IL:WFROMDS *STANDARD-OUTPUT*) (QUOTE IL:PAGEFULLFN ) (QUOTE NIL))) (FORMAT *STANDARD-OUTPUT* "~%~%Output on ~s~%" DRIBBLE-FILE))) (DEFUN TIME-CALL (CL::TIMED-FUNCTION &KEY (CL::OUTPUT *TRACE-OUTPUT*) (CL::TIMED-FORM NIL CL::TIMED-FORM-P) (CL::DATA-TYPES (IL:DATATYPES)) (CL::REPEAT 1)) (LET ((VALUES NIL) (CL::TIME-BEFORE (CL::MAKE-STATS-OBJECT)) (CL::TIME-AFTER (CL::MAKE-STATS-OBJECT)) (CL::TIME-DO-NOTHING ( CL::MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (CL::%GET-TIMING-INFO (FUNCTION (LAMBDA NIL NIL)) CL::TIME-BEFORE CL::TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (CL::%GET-TIMING-INFO CL::TIMED-FUNCTION CL::TIME-BEFORE CL::TIME-AFTER CL::REPEAT))) (CL::%STATS-OBJECT-DIFFERENCE CL::TIME-DO-NOTHING CL::TIME-AFTER) (IF CL::TIMED-FORM-P (CL::TIME-FORMAT CL::OUTPUT "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" CL::REPEAT CL::TIMED-FORM)) (CL::%PRINT-TIMING-ITEM CL::OUTPUT "Elapsed time" (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) T T) (CL::%PRINT-TIMING-INFO CL::OUTPUT CL::TIME-AFTER CL::DATA-TYPES) (LIST (QUOTE :TOTAL) (CL::STATS-OBJECT-ELAPSED-TIME CL::TIME-AFTER) :GC (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :SWAP ( IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER)) :I/O ( IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| (CL::STATS-OBJECT-TIME-BLOCK CL::TIME-AFTER))))) (DEFUN ALL-TIME-INDICATORS (TIME-LIST) (LET (ALL-INDICATORS) (DOLIST (TIMES TIME-LIST) (SETQ ALL-INDICATORS (UNION ALL-INDICATORS (IL:FOR IND IL:IN TIMES IL:BY CDDR IL:COLLECT IND)))) ALL-INDICATORS)) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "GABRIEL"))) (IL:PUTPROPS IL:GABRIEL-TIMERS IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) NIL \ No newline at end of file diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..a1f70e99a3bd44e22595f703f04eea54d060cf27 GIT binary patch literal 10847 zcmc&)Yj7Lab>3Zo;2Q!TrYuT!))q;%v>}U>tOwOLrWGSQpuB%Lv*GwBceM>5m?XpcAV7+CVy83ZNVukxUBbn5cIysX)Hj`D4PEM)Q zlQUC8DfKAo)u#hy-^oYPljEsfndH>eiCrU^k?CW*QWM7~r*~0yXmTpG>xtx%sgYD> zS9WqTGrgcJ9z{P=-kw~=|Q!# zYs>sB zS8|?qGvSK{eDQ!+kH-2F?fIOiL(NVe^JY@VQyCK3xB?dWS92A?{-{5p8`1nZ`IK@G z7*U};*0JPlL8 z0OB-Ryi19cru@0`{5c2c}^c!i)kh#?-HH!ka|JFg0Qln0YtUf ziw=UdK7X#vx_5C-b$%n7h#O&bz!%qPlZ(?0sO`RR;rz6#URqdIojj^0GZ~)ckwp>k zeC>sun4H;gJf&tPlf$Xujf(?ytL+gzsz>@GUTj0cB!&^lY&~(zj*LTs*-4VKno16( zRY)}ZAju&)lgV;ZCwP%eD~mJ5+DfO0wVlnaS~d(<*0x6sGhv&8c9MakL%Afe<GCZQuoyhrU(SSD?ls(UF@p6Tk(V6%MA&*BjL)vud3>(g}dIB70TcPcf_(!`{b z>ToifJd&JFk^DbrsosR)#mVt?`%LY(UAEJrWj8NfcIf~tf=beAuOGU{#fE|s!f*w2 zzb|3LO_B!bLPbFHhkbFai}TQAzY*JqygOiM1HSNX9KRS&e*Qe2o=TWfUl`hBp2q&8 z!bxUB9GD6+5Ol0i-5Bxp!Cb;pYS95bZbWG>tu@uKIK(Jd-_hyCUE$rnUG3P^wYjtF z;Z3jQ9(r1f>*mQv$lm#lxK_A+b|nlWY!*t3m(ez|e-3P-eE(2^A$4Bjhx;4oiv+KQS~^nsG^^DHZjfPlrOU4T&B}bYF*SS4Dy~UT)F3-Gocqa z7iu0-1XC{Zk033U|IaEtl7ozP4edy*uZL})gZ6V(EUqOI`(P6zK7ZUW9ki#lqLQe> zW+I6(Lk&Z*$U_z)K!n{qIzGT*U+PF)P#)+4H*9Z zMZ0kyO=dNkoKZa-rb0amt86Kd)rMA@R9|bgP(oMn>eiBF@@n&<#_~4x{TeZU5p~W&;d#imOxx4%3qM2Ebl3bINv548qmxN4 z*{yb~cE)NMvBrn3mO~)(_(Q&Ej}{OYD>TSjzsH)`VU2CEGWS_y>#U5+x=*%RoI!zo zTs>i<+ZVQKtqC^k6IKfhgbfmk7-1R^!-1x=IeD*DE3A(kvzjS)Hh0ew$+P7tPSzxP zg%-7^-$-a+a!#?1ThrCnR~bX~{3b{4Z~s94a}=d~iKdKDX9BDm=Cp$A!k2 zkwqax%mQ;MKC8)NHC1+58#Y-Reit$({0DFu@OJN0t(LXcGfh@YwbepsvfAe54H|LT z+8{}9Vz~m{Fk0}Yo;n81lbTvQo;F5#UBbr7=XNW5<*OlOzkIz{xuHAGjGRiJ)#X$A zO5(itanC|&6xIjQ&0I}O3!7lt=14x*P$-t%pJlY4FS6Z>!R-i8u?0n#N?5W;jJWEWDL8_?qWnyCd#?T@)=>Q56GAwz)k z)QA(RM|+lDAJ%#ziI-?70-X52DrT zU{lq!OwVk~W1WO>7d<+w$x+QxdX@}G0~-)wwY9x5IKW!bkTgyt$5Y;;6L%VqhTV$H z*5W)evIjr5;=YBEWLt6JjFt_CjIc(-1CGi5mF8DsK$iQcu_C>|XYk)05-zbi0YYMN zJ(>{M1Z#u|6&BR7(>mD7MznmZHP&He)?%S+N*2of;3dJ2fXmusZ4d%^iv+T&gf8lf zXt1iv1AwL02KW;((UVEw>eZ^aUrwDuFK4$A*vH1VL0H^7MYg867|!kXu^lO#_{)&d z7d!D1_Hl#DYLTI$<%?5dNlR_T!5ERQC}eC|iDoFO)l?1HHqd$Z+UCZNb2yvOP~nUB zkVMQn8kP?1We7)JOP&JYRvT}1KDUZ)IYNYRMma|EO0K4@#8BmP6p`xcLKQ2;y}avp zKMRWtmv*0t=S)B?Z5pD5OKU+;^)l4c0 z=RTW;w>qAjI3YZ8HZdg0A6T6%jQdOG$y+G=3M=)s92K0eWZ>ON;e21L}u8j9{9v4bnAF!)S^4)P`&=kXz zbsPIQ_JTuNm={l#Vi9L^m4!M{EEhddDA|C`(wo-y{Ofd&N*5<2=_^-KpUOCI z=SMS6ag0*KqrZ4(^H?(UaicUp_G2nNkWr|p*u}PtBYAb~$7r}W@X{9Loi^t_== znz)+gmVVw|WL@)movhHPyw8nNs8Jc?Y{)x5ATkSzZO;|O>U21)4u=zI8MLpm-3|}7 zJ6tH%6(gAh-5u*d@3+HoH#n21TMgUCKh$kEV3-;Lkmi1!QNX2jPq%o_A-4feLa06eKWKm-AV)aM$bf_OJ9=L$;b~j z@qQR?!NPDC!9Vvct+-ZNxL#VgQCc{7(PkPEJbN$SwQQ8pUJQIUVD~5>w^46+KEC}& zbH@rq^@f`-$oUct(i;_Ct>NZmu&K5TLXzhD?&RI)2HVDYqcKzU@$GMaQwYLn9D5&? zb3Zrgk*S}bdpUe(&oD%z+`9D1zuX+%?VgXoT#Kvp14j)kDcrsG{^%gWN?xF^1j63! zd~f_`wIa#5HOu{B!|abE%#CvhwBYF3vXw&xDJJ`ncGHKOryLP;a_g!5K(T2JsXlp6 z9LpjV_-L_F`iElnrpS(nWV^Ma6CKNKy=?>kTKL{HOJk4%RumH`9}LEgNWfeL$|^nT zwRO0XW>9C9Q&NQmRMF@GM&&g8U-AfNDEn>Bo~P_N&R(GG3!HsphLel;S%=qQtg09y z{lWflI2f$}k$fnhYng4;jwdrS$t*<{lSi`@s9J8KHvd#nH=h|1G#e>DviIsau zcorxhh2Fc#C2h_m$BzsrDYm|Rr`RK*6ADy83_r-{+qA~8P2KMZtakjB^QZ8E0=ywCOm=LJyK7_ zx4Dvzuk@{A)&eVc*nlHt;vV7afGGZ;NbwC&cz`@Zh<4!iruR6%_BGM|B-#)P6m0}W zaC41`rlV-8DKt@Fa=)nWCw8V0ObjA|?X~;pqK#a_+Ql~Nv|Ti8M#EYPGB0~(DD>YT z$nFQ(-7Aq1s~V>HNFs9~y@e;X*|s2FLuc?j&^6n+DKSf7Md^G#S3BEg;%!S*`l#}` zd~VHbTLdpOc%M@BiRo-|VyHkcmCxN>Y#c~UP2&jKos;?8UB$KpUc2lDybgk+Ie9eu zWO6E{F75Rw9p_?WNwv!&8dlH@TvbQUug`X($@w`Kor5Mih262ny-@`CD&mopc-^9M^p|VDJKwB8B*cf z{Hvp!cku&jmvb3*;(Dn3mjF$kgpu%xCqI+n6=Rye5IXf$PHs1F@{ux(`?HL}khOj< z*Zmh$|LJEUpf_OrNQoG}E=NFS(F(HkY-_Wi2qU=!{Q$=}840=g7ZOEH70{BCyDs|? zzycIC^CS3mFGC>$$Lii|1QB`x5gfdj5BT?24j59-(KTbEfQPraj#;iP){c$TB1^5D z*!EUg#U+Pp6c=zcqC16?nL@cz4|=t|I-Wltx5^J#6{>Z3Et8ko;88%t9|G4cNLSO> z^fNl)x=Zr4!Ftw-ULls=BBp~bDf3Iq&ShoSvT{Xfd6<>)4{iRTg{p$!otK-I4vJgZ z36$4(ee_1SkMP~J-5&0}1KmNLc^7*5cd%aU0WGVd8NYN2aR03^f(uyhW`u#>%VN(X zWAERb`;YM0`#0uZ3N2Ku(5J!;X5h@4awB~`d?tK)&Xf;u<<0c1QJ~_80YEy2`{j=d7Y~;%iVGrt9#RZ;g)qGgFG52;a&xhNXGY`i>lF&kp zxHom>>ZMO2*XV#lmlidulJ;2oz)@v&a_(1^0GOOB(WGP4|ObJT7>(`(}HhJG8>Bt_E<@1<#Jv4?-Mrc8}X(Bu+H!MZ9at$d1 z0ZC1!PjSk8-9|itSKMX5^OWGe1mA6^v0nLNaFf|Id^wCs!@a!1Jhr}RJu2+JtfWS7 z|Jhht92H*vy~=l8gY{QVC&jZAisfmTz2}lwN3InJD*4!5Kb^c@s3{w}aXJa_mm6;J zFHW&YJ*Cz?YIuY-+Z{FBVK!2HXm1)G!!4%Kdr=_Vur6$vC>d^fWW;tzLx#IgaN+UM zWT%Rp@i3EOS-9%OvM?edkjk$oj!NvPyB+Z!zveAOKOU`=mw;9mV889T6+Yy`J4aie zw$I|D%(_rTA7yw6&Y92*S6qt$1h1l9xD6Xo^BA5;=#!10zL(!te!^RGh}z#PX0Ks3 z^{pamY)9^Od>uwqb1O6<20~5WLQ^$6wjzu|b>BqY-K~Jc3DawI_rjO<2J~Q1i{qOa zGFDJ~xUG*x1^`ME&w$v|iW$=P5cG6GgJyYJ!-vpT$8YMT%-Gh*sTk9wwvkUo>*wVQ z^Y#%rr_#?L3y1y?ui!_>JIz5Kum4>Xlpa6P{0*{Y40QOBNIoF0@%_S?a@Jbqd>I26 z*JzpKv1xoINZ%(>*9!=pCPv1|>!nY#W)IBnobAFtc!vS?so8^!Y1LVCwrv!r+>s_9 zwxQ_5vdrki7O;|NDMja1W}_;5-n4e3r$2pVx48aK&ux{jg?c&KlfKpW$KkoPeTecL zcHau0k3`#UK9A?egE#sV<@(%DSsAb34w`#61cS00C!*x7Lxdto{PI@FxU4@47X?$G z5AjOlx{Naf=qhGuA$6NS`%63rMG7hqr=SQ0BJfz7{FF;1l4CW!ey^cTqwjO#dQT`p zFW>l7kUyC7Pfi`16b?K3m4Bapeo(`GtUiSAtxECbp@mOy6w6&SegI_PYxQC|HMZZ) Os8xD{#{c@KpZ+gOjoWbm literal 0 HcmV?d00001 diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..de3f95f87479d7e596e2d241b2928905bd01e417 GIT binary patch literal 10042 zcmcIqdu&_RdB69PBK4%HM`TBFQl{1;Q*xb1&cjxU*c5pwUg?sTzL(S^FPD+&P!c7% z66MCtqS#KlBnz=bwv+G}4!W%ikOJMJr0C$cu(kWc!1l+A09&#Bw{!zG5A)yw3!28> z?>pyGBo!x3Qp}Kfp5Hm&`Ofz~cSZ7!hm1gIe)iy0F0&ArU&FK4#e4uaF&YfuAH_*RpV8?yi>mxzi5c_=zm>u^I?C9HGf8*`q zo64>8k|aIN{~9Ezxml)moh11sMJ~Qk@I`b(3t3t)sf7(Qq)5fr3jSU@8H|U6R#?^J ziBz(;Sn&4+^79APT;@-8DVvHXyu}kP z%#(ZZqdfd@v9LRqo|+RkN*uMYG&eUj_jKT~q4ZM=Q<>Zofx*n&WOg>aFcVl@n#yMu z1DHOZS(tw&U`#C@93YClQE(FiSekXP+lqyOaOS|&+*E#Qer}QTX+E0?2+j-S4HUNs|?;$#* zmvVVN)Q`3JU6wJ$*(y=Q*^U=BZPJV!r_MlVa*O%`XHn#mN2xK7EcCA@@Q%rJo1!! zz}bbBS7u z{|k<)CQTKR6C4cM+V6U7H=|>BR3E!?15ScE;%YSn-s8>I5)(pQh4oM{X<9Z>gLt7f ztc8rAr48^pI5}h{CQ$cH!2?1A_tAo<0UBt3Odpg{xNV;{x+qr**VLkLVQDF_lP zbhpKVBT$mik6L_Gx6C-*CA$?WLZ*cZEq(ne%z(OcCmDbp{R0o&_eSB~uV`mT>$&I> zfA(3;XNj&xNt$$XRcMzxJiG%2Vhw#LUVkwQMM;fsOHz|0t*iz_U4Y;>*Ux|IJwmna zJ%i@n+gGA5qKtM-Dg-P3Nb`P;hF@}#R&6AbB}Rt0a&i&DHzh1BnVf*qiUmWKX}gH% z^`etz8FsQ*=zt*^z!bGYw>e5tc9j%;JyB|nwNvqdDBcl8Q53JT_8bfu*@9@$j!vPz ziLOzlmdb6Gfz7=`8Xx}_#yx{(DjrTefNCum0eqy#?xy}=c-YkA9qb9RF3q-J;o^Q~zJGPAc95&u{LkI372?zyw{4pX|q2pota` zodonF0sE(bZLNaE3D@C%06356Aehqv=8ez5gf(Lw<~YHK4uW}2z`Xn!m`ePj1OsHVcozbY}+n2cNd%KV!6$1rj6y?>`s|=y8DFN;TbZ_!JxtF z*<64$`yA_plscBWY^WDu=Uo^&UXaIGy-)#if^|^sc;WUcDs%BKBWu%qg$}hhWhON& zazbH;*rJzxhr2I*Hy4|~QZAEd^^nL#*F_FuMvl#G4&(D(Gz<2FJ7)aQGHyn=IEu>J zn^=3@U92a-dTs+X$;pBT7gh%++E`~Zd)~)7y&wkNg|n6#F)f+(fFp1);Y@JjtY)4$ z2p1!>ur6$lOYo)yUXXY1QO-o=vr*-o?pm2Tl0B}=NA&Z+U2j+93r=~_DKFJZ(mr2V zUyNisI>>G7=)eTimmO9*coi-DZ5-|B!1NB|gNJApKdoZ=vj+7M_|0Ja7^HFhKa!1A z1IE5IV7wYI{-ptLg4M7r@PVEty!{d*fjS1Itnj-djwv*Dc5>xMR}w20T1(9e(^5mU ze~4?I1pM$Yt@5vELRmqV#1hp0bH4V=c~NW^#q9+6O?HTiZvemr5vBT8)ZNfq5o$E> zap}4!KH-qBU_knqSO1WzR{&50-bux&^$RieZ$$CeWr(#h#7}tjRhrJkyn-lRDNp|c zG5vdDYK9#eXNOW^*b+lSVrYOJqT@q(+tIi-c0XYQjXV_Z22a-nBT3D=gSea5RBcqV zCfaEPM@%I=z(M{!vdtut;P*C2kRBhZR@!VEO{=Mx<`b)x9A!R1`rC>LZ57+8)zeN? zO!ILpDkki!7~JIGQU(uVl=X3?;ale^t`XRCAZ97BfyleOoI1xyuv@uc3%#k0ClLK< zWdU!SOV4K119P7h>efAq%q96GDzYCx4wJrvon(he5sB4|MNLDa?ctTkY9(HdfL8`) z2{BIY2^5)2f^ldTMm=Ha@uaZzI1QAT&|$6~_QV#h#=Mf4~pj~oG%d(aF|aP`+Jbly#f zvwqAyL9PZ$68r(^@YN((!d>;aS*Hy4^R6SqsVOyxZQz=L_LW!c1>IUnN>xWeIH9`Y z=J);qSKxFXTZs5&kMB%$CF;*kD&%&tKByFI2&c9xSd-UjuQam9YS`m)9qW@xL`cr; zgcj0aFF6~^TT9F5l*y9+=Ug}4F6%EAwqlD!&;s=#iW}p&@;xhC*pt``=>oV^r6|qE z`jxg~q1&pA>;mb0AeTuaoXlqtAI+xc4vQF&OEGDcORS$W<83AEKt|AjAD+6L^Y17Y z+DhlI4DoJ8fE~c&#AaNPI~g3IKv>j7l;J|3=t6SEsf9{4PZF_le29vOqL)_~XQdYz&f`$sW`Z2ipiwL|l|y@&>@dQ3 zWJ0)`4*rU#VuPBcnh{k8`}3gQhS&wUu~sW5^MLM;fP#mteK46pwb8*%CFRu$Zt(@J zAs$Vrnq`?5C2u_TgbnQ{Co#PF*|0tGoRgv2UdD@UZ-6 z)B9T1%ofxC>9yC7uBM$SEv654X06N=dYgjNm}EQ0+UsjDHd4LZhz~2Zt(k4PCaiR% zK<6~uWJ_sEm6o+tW>f*O7L+7+r&a?*=@Dn*$jSJ&5v zq^rcjhNM6ZSwETOU18nfF{~K%w1IKI>C2Xq3X-Ldh$75ytTlKQE$k3{^Mey_a<|Z#$Gsl zbBKRNve-KfHug~r)saijKD9qhxz~+1#6u|B<9~1`M^I9T0|&3rzTBk)A>hV^htgjq zbbf@WtO}jQOn&KL6~?EFg<8m8kYo^AU@Miq^e?a+EQgu_bS!r@mD92$ozg#oT7D-b z6;>Ulq0~v;*HxL@-#;L@WP^qt6?kYc_pMhDaI(3fmD(hBf}4qA;Om{ zCWabILzK{p2#^phXPc4a7*dm}12Z7TDA1{2A0r?U%w3_>({1!dvLSz5g8!y~r#NrR z&8E>(jeO2ksqR_4n=E%n@Org`obSML|9#12d%jqxU+%W?SRp!slf}ZV%iS@g+ws^C z(B~HO>AA_$;8?M+r93#ASy+U;IDjL?!Y$>oB%Usuf!%yXd;UQFyXl2Ypc)FkT08bH z4OW2l@b&23WCI8uOi%y1Vadv0{yNg=1Dc8z|U)|zEk*)~-;EMvYZkHrN~#SM?82Bn8z(!V(2-AC*Z z_XgjDkAsuHhEw8Cn#rJevaz}Q!hHtEaLn+9|FcyviSljOwHoehux+Ef@4xx%Q#bW6 zNSs!noTxnZ885@$=wy)Ys_-!2Fu1w5;o-la9(tOfn$G7IfGJ)&ykI^L*E<~3ODt!!UApMJvy_00XOci}5tmd<9+=_@*XCHYnP+*k|U z_%L^HN`4YpL|GfIXt}Feo~l-DRf~wzbXqKm8dtTK-5<18Yy&IkhVRsNe)@tj!o8-9 z7&V5geJ1cFXgrMnV=Y8uLcX>Gzr@EdG#gj-z=gUP6aLdHbc?Z>4==7>HD*4%u=-Z? za_z?XwLYwZC2{E&vgeHz{7tfJc zfkU*N3JH;&uiD};Ir{s1+P4GpAXz4zXsik#1n!yYQ2aSJT@NdQTw|v)NXo1 zrpD8JiI=GQIOZu`_foZ;?V&-uB7Sc&oCfc@FYSc=;ww90@BVI17&Of1IAOp4 z#SYkXh4XdGZ*ji3rus9YjNCK>e0|^(NI>*5#WErdCf8RxiE`mg7%(Izj5^HjNP51wYb9mV|jndxiq%w$O%aMU}L zpL)hx&KynC^8*^*EELuY>9bSkoHoSi{LwTe_%T{DbKz(jQ6M^<)IMqu(Xx4qn|@M5 zd*Y_gfP#ViT{Qisk9HeA#eG6UC&k07rca)l;_+G3^oV5K_6qoq2@ zyvWA!l)9@9SK{kM(jug(rD%S4om}PndEgK`5lrcG7bL*DN3;nhMDaSsIP{3El9yzo z<*~E`e928j)SpAJ8y`pRoSwKN`Z!OxpW&1qr|}<`s|?t*bcv*+liHnuYHRv{_)|eLOY_A1^tLiT*BNMqe&a zPMbDMb9A1JW2~7!aaJxA<%9deqPUl03pzJHwxGpT3eu$Wpn*%jmt+1O>TY{1$j|*l zG?bwb&3PNu8tza$$d^mq#f#(?Dx~WT%v;JxG-|o@!9{#1Mc;8ihP#tfvlRK!=PS#P zEkC?GfImb?;lMM?PjFW;uxu}Pk3%e7S&HLY%W)j16FvT85AmY19>B>-jzH6Cwg-@p zWY6po7Wn9DpL{Ml%##?|OCzrzGgdc`$d`IluaE;H@*T6RUq0 zg#y^)g=#40z(oX3RF`*vv^A+X9DPoOHzod&7P&NJ;wwu2ebSE4|31k@UtHB9DyMkd z=JA-kP{R+gAi3~Wm5bdIzI6q;W+I4{Cf(A)bn`uTYshhZc5 n{DIYpudrAHy?pq}Itm^T)@8#uMWYjKa$it7g(c+YZ`}Alm@lt) literal 0 HcmV?d00001 diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..1b850727a213ccab6cb449846f7bcd0a86d1ec3b GIT binary patch literal 10456 zcmcgydu&_hb-(wLq8^rLT2f?NjuU2<{Vb}+CPH0%hm!( z_B-dhd`V8)G{6jt-}9XNedjxm-*@g^lxp_*LT=y8^zn&wa@IXFpFKXGbswFXbB zAJf#3C$5Fnn6dM*t~#TP(b#MkUYVqfi6ght}=L~2e)fZE}an&EveTtNSG3V+u;@*hg8}oa#NOU;fna{bp z+}WAqo^R=^_v`?;FHaKsna^ho}^d|KHAhAzJv&?2gb_<}s3*MXy5kE#)+ z76cA`I1ZLosMh+mn99UTbN;-Ydaw?E+}j^g^En$%16|couW!gZpytmj`E$7jFfVj0 z=5rhNsWE+@$ESzGdc+gbjA%YrZHZmZ=N!*Q=F{otB#1)VQV;{}pG2`tm5umwNnq5y zYI}1SkW3rxO0L7Msvwm0Lj@b@bbDxHS@+CQcOsqURURpdfY)nn?9|Ns_7h2WdL}WR9N$@d zP`|q~tVOi&aM*)mh#SN(44G{sj@gN6NH9A?a&{*ZV<|Tzn%zNiNX)0RJk$+dB-7f` zO0l={C1P*qa_d(;hCAyz!@3c-%)OIjU@McsOkh4URyvi!Sr@lAx6|#84M#lvYQz@| zdt*a}djdrNZd=-M^h8fkt3d?)>Bv}9ayTf zk}0ortpf^Yw_b+bOrB~Fm$(sE~$b1Y3PI^iBqWD`dcb4il_XKd9I*FCTt zZ@<@2zv#B@CT+X5a@*w(U=h@kR(pKVJ#ID?ln^e zCj0d0e$<_QT^;d;`e1%hSbqKjSx+sTs5b=dG0x!p(P1aIAq=L590Zvax|_q^Avj9- zNHsE|#q59?wo%i7Qms86G9r^+QmW-3Ek-*Uw z%O3cFY78-m0UqyP#vB2Ylt;~$I_qiLFI;K zTbwwZI;Y8}wVSk4twoV<6)K0F>|vvk+DcHcwUtQp##E?PRH;dS zYbLa|f}}Na`8SzcGjr3MQxWQACZ9stj0rRcf2UKr^YWfbdfoZ?7`WCjaD6TYg;iGW zaY(F?A_8s4C7EQ8XQ2xUpED_1uD-2}{U;q?IG<}OG|NI+6`j)&c3e?le?K*A(1fpp zD+))6>t8eP-=*r;M0K|)w$kjdd4dWJL^fDC)m7B(aD4%4^oa3xQQXIr&(pwGuD(Fk z^&qH%t_?@fl0M+6(vL;)FGULJpNbUla5VGl^z*iu_l785FHL`?H2oW5`ZMN<3G+l! zOi7605it}rPxxuy(P1MPQAhh|MR4o`k)5!EDsLdJ#U0 zwU!b&aE@$tvCnBNS1;j7%;zA~;-$)LvDLDK&XPlDVuv7HuevXa+oxJ`49%IubkcJ) zv(_0j^(iu2{{>WJ7k(^-eG^ZTErrERuxd1@hg5nz5Rv@o>a`UeLdE4UTA0T02(Hj3 zA>wQhXdxQYB5?sCurIhl;RS6EnTPISM_9eXoVwpkw_tOd%QnY!xSRmK}z z69v=0jIPgT+7b?KdzINHLm#V)>tWGK_ZFT+uyBo7aX4iq2U;iTu0NnVCX)i$|_fA0)pYn%yh{P7JLP0WI5-LQg)|T#!Qft@ci0=uvPY z8=(yLxOa%|{-P!>RyOpBF65M~ny*lE#E}k&4DfheJm!V-Gbm}K0aJlXO`(fh4kTb; zbD|y{K5!tUih7{bUlpJX5_j7I0c);b8|n6Ri@99yvg*Knv0<(wM#QuctGle;AJaz- z@tCT9eLrV5V2g!y@lxrge=b*B=o8IqL5W70?0ckF&0YCR6dI*V8A-bLN^<&>+ZU2) z`|Xz|({?tQTWo?73&?D)Lo26j0GDWqZXL*Fn6-D@HMKQZ=HnYoSM_C1ptL?P% zZJjm;nj1=~L6OMoGPN^ z8uRD@j|L;)T!sMy^fG4fluzb+>>`%nAkg8BA49d?TAPQwL=#TI36H^dB99u2=`qS# zIgI@V+%2Lg5I$#bt;F2U(z?uT%>4!6@`d(=c3q@?XEN@ExrKH*t+Pm`qLiN^5eA#3 z{iS>HXbZ`>;Pyz0%fS^TxFU{|Al`CHqti=WOI=UhNZkysNVigerIE$RS5j}w4jJ{) z7CHsp$>h4T2+5hStbMJle!Z-IqpW`D6~Qgc%myzvRWP3%#M3qb3QqzD>y5hWquYP9 zbj+I4s5>dvEteEUYgTA$x|4oKTk5K4cxW}xAt%^1FYC?ehL3Ll;qURL_2#K}(6{tc zy%Ckh<)sUu)np+ELAmwz$NzhCvd_63hWlN|Uj98>J^UkXTAjm@QRHJhz)NvtiaUAq zzt<^}jJQ|r3+cvi44Gk=7-GC_pyy$_x5`1D_5oEp5JjqyWTsm*wKtT8WKwRr!*CJ^ zgVMhh2XSYm4q_p_C8}Q*MVGmI2MDVz&Abo%>u}YjRqCUZ>A8!ZI2wrQVZY(T%myvu zv9z?7*!{w+rs8MVKm$G9&lsAz1i)OR>Unc1)uv5Y}0vr&p_wqTX4`DXr5euB2<93IXXfD0gQ7FOFb?MyI)3Rw}}PLfeDVzyZe*l*5hGT;xu+ ztKTVA&w`aRq~ls+APTTEKPg7D7;ym^29ZZVu%*{hK6O%z9mN>3X=03!1LDn-VrUI*}Z*Nce$L1JgltjPtF}!Z?pqU>r{+#@SxPIQJGX&cwB)d*YQSXZR{b zB?daFYa=D7L)fQgnSL9VH^{b9G%JHWqs~g)V*}o?1NT&+bnt2Ym#v!1_sl)^RS1Xs zq1wL&v~k7txL3UIG8hCg@_3UuevskfHv0(aL*)o!U=>3abK58n{SVLngHOdN7vaRn z&c3l0rx*oqMlutQV?|*fhtvpWEODxkmB93f&Js;utp_9&`8oG$KoGF63q|aO0v*o8vH|<~k%% z3Z{1u?OHA1QTJ(h**9ud8)nVj=3(K0t5{ZNEaY|>uxmxSn!2VfY6QD3%GX94Nd*R3 z7K25|1+7t*E1LGorlYc1Q`Q`3m3vJv4z4sW{OcrED&7-)p?B#%OT~)(p!VH5*}f;^eE0j1Xt=gv}wxKw?Ce^MivWwDQb;K zjl5@TFoi4rc`cA1sRAR5g68aUl5*tXevwzh1(8}gw1E5gK1uBbgnB!@ny1Dzv-lcS z6PTy8KSp}1oc=JOI0h9&GYmRT1CMq?}h+--=i+s zE+FLMUY>BFpNp4zxOiCvk=KYyuK(3xob->M8^(S6i@~_pKNH5C`D_@MDT8o#{SpYr ze(YN;IoC5-vkS^Xh7ergTaw80$xW4D6R;L)K=@9T>4TCgZ@(Uk<0WMo9-I?AD{$8? zI>)d7$_S7-H2r$8kDkP!Uao|GUwYMi!t&n#nVh`+CsQdl4chWO%3nA}8?T&6@EaPm zs#9=eUrAh@xMmI4kbzx4leliRtEO(8N#L$Y-M8ommdb^z%uh#j7dxoFi0%xL>mj?m zsk?M1KY8#K#+f0Fy%N`Tr#vws?tnqvImFcTMD&Y7k<%_BF1GjcTNNK8=Q8T4&x2V9LC9=(4McUO;J3k1{{KJHLYVnx+YhDQJv;|y@yu{!!}gcAGo zKnA$-_z0M6;Mc|FjC5Xaa!?dKbcdn6^VS7m`H(Jy(%(T2Htj)P{a>PPH%7g@_wS;i z4ESiyTc}nsAbE`09ejX`1MI_Od%aoBG4vwxHflO?d=8(h(ML2y`aF`4@rh}=WzzRU z3kMe-Tj<4q+{XOwlM9C!bGm_RI}$KnTZ-MUX4{Cfs6jG- z(f~+VV^i`;PFu?-C0i4{-K9%=Eqy%_(*}ZZdb5j9*!XiU-^}ds8F4cPUG)#>=Z6hU qV-6wTZPtn};>>mQCdgTGX8=&(Ytqf8-n!s2tdw4+=YRE+PyP?M8_E9w literal 0 HcmV?d00001 diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..f78a8ae507011e868deeb68dd82715c0020eb795 GIT binary patch literal 10847 zcmc&)Yj7Lab>3Zo;2Q!TrYuT!))q;%v>}U-ElZR~76>eeB>^mi1xYf}uB=uA#MGC8GA zPtHsoPOC>yuRa|#`%gTQnH*2=$fl;Ij_(-Bj!Yljk)AjWgHJrrBk`|uo{{g8BQI)U+wa#{+TCcrgLi7 zwyj%H-rDWk*8QMw+k@M-JiOVrWn+EFZ$`vyihYwa>1pol+oT$YbCZX#0N*Cxru$W2 z_vVKeJ3r*xSpVsT!t2WVNeO>XEdJC|uAxEZ>S`)@Bt@4IxU21Ofs5hHFmd=vM#uczAyqd2H4a5RT-G~*=$|se( zz|a%aLV8T|5?^!=86I$S8gVVA)S`pS7)XMp3)$+Rp3u0na%bVJlWH)JVA9_c(F%D7 zHVajiaetuS->VhQDupxo8Za+boG#=Wc54Y^w>Mx!qejdd(am@vUukcKT*$kgj?HAV zCnN|&x~C)ymH`W7p0lfkIKa-gY?0H{VmWASvIlFc#LVLfBkov>LgUh1$0SS_s;g8LOLfzLZbZo!clb$%7 z8Ba}(snatfx%9LO^4;mF$*0r^^s$>{_gdab698+g)mmG~cL&o)MkYpbBa;);tm3&$ zS{3T4=8hjt->;@7hE=K@CPHWv4UO_R*ePIFXK!P2Ph2x0d6(#1fYgf;7KGJB4Irw; zUUU$w^@Xz)*4>M9Y6uvyWWtE3gZ_k0n_QZ1Q0??bisz?O_0qy}>f{kMmCf=j4=sv- z=W8$Q_~gunV`()znHo+HZ(JOxN9~O2F+DmE^6CNYdcX6uP#Ze$!1%uSM<)pY7` zMukLk_mdn_Gua$B`M`^0T3wnc)>b}6tnEyG)v{r@vc5BFm`U3dbdn4lWipry%}g9F z?MiX47ne7^QB@NIF>j9+3xuQoM8BzyU`p7haZ-}>L~iQ%b~UJ(frQ?J^A(Lpw5S$K z`soZ3X$m@W$a};dg=Nx#sk)ak<(aPj3^vQ>{45T^U;Vmyvp!9yj*;flbf?nOEKN*0 zr4FZZsY9vhG|B&Smg-F!UYs0%kKfdO+hsc~T6XKwWtR`YBB&;<_6DGPTx=>TAq-bg z5BQTt!X#;sE>s1zK*XQWx;YO`4jA!0$h(7vHt3J+#PN&c8XY(^+%vR<|*ty zDx73C#DS?I13||M)y+|VKg=a8r4}316Gn{o(ppmsi$jd^ja@!3?h5bLt!me%?#;gL zhc>;If8c2?p_?ZjA$u1v5?b;4*^xAih*>NxUPcd-{c~Uw<$FKd1|~{Pb!7AoJB4jD zm)E;QJzpX7+{oG8-^s8U6;+QDiyHcQXA{#rPWcim&SiaeQtzTxVUTxS=E_}noesai zxp3=YMKI+e{|M4j`TwlaBRR-u*U^r|`+M2;IcPsu#S>aGxd%2e>JKCg(?NS$FDi*D zVkQguR@_+KAn}%&PTS_nj^aI1PaCn$YN4c(6X`>d{F6xD70CtMnsnWS{braBU;*V- zq%B^m@$w}(fk{;MYD_bTc2|!v5DUipk*$KhL0$Fe4yyMD`wTtSVeO|&tijZh-k=c} zShO4W&}3Gl$r;ll5h^sIu*#MKS#4;gN%i$s8zpoVuWm0}Cg1j$392kwq4Y5r)DQzv zNmak(zS6&=Z_|>#Smk2BpP`>iR8XIvh(15Mtxr&kEcSVi`iKhZ^Fz_+`?vKepWjXD zQ<~cq(dVy4@|H+m1^lQ@Xe@72->VVx7g6Ud7M_P}E3{n${>U>_O?S=jkz_hqGCG;$ zvfb*m>SwIB5o>(dYC8ZjPay1%^=d(Ju|k8a^}DQzZPwU>R`woiY@L;LS@+0Rn=>S^ zkE=Ig^!OuIy*0sReZp#kfv`bB2_sAcVmQ!rCNJ-{>V@@@<5nx>&gAb}B6+qvrOBE^ zuh61)4H!ucOwKCSF>AWk`YL0n-rwZN{jIVfPWlFMl*465nGdc^ixNHdD2sh$J53ruS?ii`Rq<*w|ph6?3J(eDc5z!>5-F}GrD|I zzrl;vTNL@`V(y?@m?Ww_=$Ws=jHQE(%gt0Y)7r`av$d6b8jYDqtDWZx{#k*lwG};E zW0!)0akF4-G-qN|FPMD}gJw_>A^xAt8175jayEwhOYrfmz{m5&`IP3peD(ce&V2pQ zGCh(-C+=A&jl%jsx|y$QYhx2k+Z-+An~KG<`?G@f^F_9Makw2pDz>2rQwd8JjT6^@ zWZvJP>}w+Xh)C`t>M83OCFAJifRUhl26-neXNU>|qFocoPVV_4HEieXOO(AI9V(!c z12HPqGpY2kNPfB4L%OxtL;5LaUk17KcY^M_BAF|Zzg;4~P$GZcI+nAJO$xG6L2^Je z$E;&Itvx%&@4WU(?bx8PRv31G+3n`co*aH6bnl|7eI_aU@e zU2Ljamg$*od8`u;M z*;<@KM)u&xR@}ERl58t3oY9J*uo2N{c)&3^u+sd>49IdHHD00@_zeELL&7E2AV5ew zp~sQ}n_!JFp~8YXwp;t#*@#wdvBtWr>{={zP1!=ZAG{>^5pY>stPMgSZ;?P&mC?og zQ4LmAxeu_^+5mqdE_yNvT)lb~_shwX=;iD&f_vEbHVKP+yU5m*7Q?xnezqgU6MqRZ z`eG+u!ai zUXqB}K*Q33y#(RNYspgp-0I-1F639yEk}qD&M3!7Udh*Wlo_f*o+47+-Kb)vxSMzV zHfVi1?8zKf2%B16uz27H$6|@YEH7@j(qQd#S&zweR+mhtmX5v|*8)0#1D_1Jqim3@ za#;Edc{n7?SIDo!U~zu}ONE_S?p2r63<5iVQ4!q$@+|ty4VF(qB%&ix?q{p1oSIFi z;N0gj@K(oD6UT)|&L)N=`2)+x!nn6=p1g&^&wwzv!4}BoLcX~ukaE9!C5dcS0D@LS zMVv{0KSd`*PPl#!)QKv@zU*9}m~$l&u!!|?dwnwDhm|xbxTOQLflF1fic2nph;SH1 zK0dH_Z$uOMP^rEmM3FA8c7#GUZBQTdd3}PG^IdixxH2)od0Z$7ebBBh%l9OVAyW)f z(PQl4*b5G6ab7%Cibb5sR~PFjTLyT0k#)`M4YER`@;*09;bvuwvtjT2pvWvJwmnxA%ja-dT@EMG3TR(-ryU;b zbhuD#C`B?w+_BTz>ToL0eu_WaG;^;GBTfg@A1UN(N}(5^jUd7-h*YtE167L+M0>P^ z*9dua90(4&m^hMt#u?snVsf~p^O%B*fQmmkf^3~VH!sUU9X&aIL&>y}Yphg3UB4c=lboW7#O9eHi#o!0u5%Zllrge0=MV z=8hJL8VxsJkn?34q&F+PTEorBP)mIUge1-P-_E<=4YtkmMsv32<6GbUrVxbDJoY{+ z=YDQ9BGWiO_j2U+o)L&fxq0!Ef4MQb(>))BxfWOH2aY;eQn-7a1F<25mApV-Nrb&S z`QG@?T1Ap^YgPs#hB=Txm>cI1Xu;9j)y1KLG?RTuyXnWxQ;CQ8Z=jdvPO@2 zZ5^(r88ldxl+<7WH8gsVQ8^9&mpsC0%6^-(=O}xYv*#)M0%zZt;pDfct0s;} ze`p{Q3B{^FBp)c`+h*IfW2x*+Do2sU)R7#8s_p0|$E;^ltn)zl`OXz+@nA7^eB~Yz zo&_pLq4#cbNn5k2@k7HYimfl-DfUQd(*KRUIf;}!Mg%hQEwk-9CWN{1;iK@TJss&? zIJrxvGo8-O94()*^gZ1FIKO^6!-sI!Qrby>>a4%y&#S1IZLcYX-RWdY{{v}x?2u#7 zYby`MuBso4Clld;SikRSz|4Dv0*4n|0#)oP9sP`LLV+rX;Rl7hJAj*c!YgJuKFwF? z;;NnNh)l+oQ=-&xBKpdb+`>hiD&eND7Ki8h1+MH@j8 z++1U#=?I$YicJ)l+$-t_h@EMKl0%4Kd+k2DXd{=fezA=@Z50ih(Xf_+%*&n`iv2eT zvU@>x=SpP6s*Y(slE_?0Z{dk;wj+es&>1`rbkF)WC1)wDD4i?h>t{Pmylsg}KUF?g z$gi30h~k9??^CKiF`Y|I94-<}74mnM8VA!;(>Q{5=TsqoN2x7|*DkvOuY=%dP9DiU znVL$gOM5*^$GOy4)@>v6qo=lIUGAa_xPu$Y$N`>q*x>2X=Ypq)mVhVkQtXjIR~kd8%+;<{M;3*>zYBsD|9j5tRc-$_YeOfmHZ5 z|LUmZUHrh>;arBDxE?D1B|wuWX(avP$a9cs@!K)sn)@@OkQDwM*$Ik2wb-yUCCV4 zPwRy1F3MMj8d)d$gjo7Ym=3z6%r7lFmz7=1%2nm%VOGXJwE2e@YKnq)UTRr7C~jpZ zP+s%3(d&_Z!gteld!+9+bO&|jUFhTAp+>O>w5+OD{L(4F{kOshE?~VIQ3iT1i#?By zy?By-$Q{KmwH!?Rzfr_J!gPt>n=hWO9 z`KIBH^>5(f$rqNBmTF!V z*%KmR#gslIFe&{#V@gCoQIMTSnBepvC+9+(oZrI98)DcC3_;c394Siw_C=ARbnUl8 zihusONb#l5M~X9LDDjS8gA&=~eUGFgdq|egW8RI>7(N-{1>vTN@TAlL-*pW&UOtr)&r&E>W?=T7OI;bcS|q6EV|VRT>RPd;V(j{<6ue(bh=@Qczn(a%v7_!z#Crmow;26+v|3&QT3vwsw&zy-kPGh|9sSxK zi;ptvLJfVC;Uzd{LNiR?3x!3V^7*Wlw(1aKWHGK}quhG*7U)megLm@4JZ)V6? zLG9tTJ{BDWC`~>CVoy6}NZ&)y(*+Hh<7o{aKwAU9sh2ZjTO+6AOp|_?d@5Q$FJG9q zkH|Tdeg;`M^apqaKSJJV4*7Zg@1mge28iZwkgZ^#!;eJrK5>oj70#5i-m2uw7{Itr z%chP_<10b>K8d=XN9Z&;GEQDEeVR49Z+81^H~zsp460Af?q^J^&YH6wqd4V`4EeB4 zB_Eb$Mjy6-l|)M^Ij=GsRoU~VwG%x9naexH^?zz^i+nZQ$I+h5&Hg`*%&qN5l;@!P zX5?Hn)^X!`JU{Ng-mfUv=6=e`co}!l+`C~Il$|&cWp5oK6hY#bw?M`f12MQLm;!x> zS02}8oFPD0DN74!*!gc3!*wL@@`}FgJI__ijBYbaFi!To?e1fA`?vn8XAOl~k56h{u{cc9B N(i=4X*FXLAe*ql!+hza& literal 0 HcmV?d00001 diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ new file mode 100644 index 0000000000000000000000000000000000000000..a1f70e99a3bd44e22595f703f04eea54d060cf27 GIT binary patch literal 10847 zcmc&)Yj7Lab>3Zo;2Q!TrYuT!))q;%v>}U>tOwOLrWGSQpuB%Lv*GwBceM>5m?XpcAV7+CVy83ZNVukxUBbn5cIysX)Hj`D4PEM)Q zlQUC8DfKAo)u#hy-^oYPljEsfndH>eiCrU^k?CW*QWM7~r*~0yXmTpG>xtx%sgYD> zS9WqTGrgcJ9z{P=-kw~=|Q!# zYs>sB zS8|?qGvSK{eDQ!+kH-2F?fIOiL(NVe^JY@VQyCK3xB?dWS92A?{-{5p8`1nZ`IK@G z7*U};*0JPlL8 z0OB-Ryi19cru@0`{5c2c}^c!i)kh#?-HH!ka|JFg0Qln0YtUf ziw=UdK7X#vx_5C-b$%n7h#O&bz!%qPlZ(?0sO`RR;rz6#URqdIojj^0GZ~)ckwp>k zeC>sun4H;gJf&tPlf$Xujf(?ytL+gzsz>@GUTj0cB!&^lY&~(zj*LTs*-4VKno16( zRY)}ZAju&)lgV;ZCwP%eD~mJ5+DfO0wVlnaS~d(<*0x6sGhv&8c9MakL%Afe<GCZQuoyhrU(SSD?ls(UF@p6Tk(V6%MA&*BjL)vud3>(g}dIB70TcPcf_(!`{b z>ToifJd&JFk^DbrsosR)#mVt?`%LY(UAEJrWj8NfcIf~tf=beAuOGU{#fE|s!f*w2 zzb|3LO_B!bLPbFHhkbFai}TQAzY*JqygOiM1HSNX9KRS&e*Qe2o=TWfUl`hBp2q&8 z!bxUB9GD6+5Ol0i-5Bxp!Cb;pYS95bZbWG>tu@uKIK(Jd-_hyCUE$rnUG3P^wYjtF z;Z3jQ9(r1f>*mQv$lm#lxK_A+b|nlWY!*t3m(ez|e-3P-eE(2^A$4Bjhx;4oiv+KQS~^nsG^^DHZjfPlrOU4T&B}bYF*SS4Dy~UT)F3-Gocqa z7iu0-1XC{Zk033U|IaEtl7ozP4edy*uZL})gZ6V(EUqOI`(P6zK7ZUW9ki#lqLQe> zW+I6(Lk&Z*$U_z)K!n{qIzGT*U+PF)P#)+4H*9Z zMZ0kyO=dNkoKZa-rb0amt86Kd)rMA@R9|bgP(oMn>eiBF@@n&<#_~4x{TeZU5p~W&;d#imOxx4%3qM2Ebl3bINv548qmxN4 z*{yb~cE)NMvBrn3mO~)(_(Q&Ej}{OYD>TSjzsH)`VU2CEGWS_y>#U5+x=*%RoI!zo zTs>i<+ZVQKtqC^k6IKfhgbfmk7-1R^!-1x=IeD*DE3A(kvzjS)Hh0ew$+P7tPSzxP zg%-7^-$-a+a!#?1ThrCnR~bX~{3b{4Z~s94a}=d~iKdKDX9BDm=Cp$A!k2 zkwqax%mQ;MKC8)NHC1+58#Y-Reit$({0DFu@OJN0t(LXcGfh@YwbepsvfAe54H|LT z+8{}9Vz~m{Fk0}Yo;n81lbTvQo;F5#UBbr7=XNW5<*OlOzkIz{xuHAGjGRiJ)#X$A zO5(itanC|&6xIjQ&0I}O3!7lt=14x*P$-t%pJlY4FS6Z>!R-i8u?0n#N?5W;jJWEWDL8_?qWnyCd#?T@)=>Q56GAwz)k z)QA(RM|+lDAJ%#ziI-?70-X52DrT zU{lq!OwVk~W1WO>7d<+w$x+QxdX@}G0~-)wwY9x5IKW!bkTgyt$5Y;;6L%VqhTV$H z*5W)evIjr5;=YBEWLt6JjFt_CjIc(-1CGi5mF8DsK$iQcu_C>|XYk)05-zbi0YYMN zJ(>{M1Z#u|6&BR7(>mD7MznmZHP&He)?%S+N*2of;3dJ2fXmusZ4d%^iv+T&gf8lf zXt1iv1AwL02KW;((UVEw>eZ^aUrwDuFK4$A*vH1VL0H^7MYg867|!kXu^lO#_{)&d z7d!D1_Hl#DYLTI$<%?5dNlR_T!5ERQC}eC|iDoFO)l?1HHqd$Z+UCZNb2yvOP~nUB zkVMQn8kP?1We7)JOP&JYRvT}1KDUZ)IYNYRMma|EO0K4@#8BmP6p`xcLKQ2;y}avp zKMRWtmv*0t=S)B?Z5pD5OKU+;^)l4c0 z=RTW;w>qAjI3YZ8HZdg0A6T6%jQdOG$y+G=3M=)s92K0eWZ>ON;e21L}u8j9{9v4bnAF!)S^4)P`&=kXz zbsPIQ_JTuNm={l#Vi9L^m4!M{EEhddDA|C`(wo-y{Ofd&N*5<2=_^-KpUOCI z=SMS6ag0*KqrZ4(^H?(UaicUp_G2nNkWr|p*u}PtBYAb~$7r}W@X{9Loi^t_== znz)+gmVVw|WL@)movhHPyw8nNs8Jc?Y{)x5ATkSzZO;|O>U21)4u=zI8MLpm-3|}7 zJ6tH%6(gAh-5u*d@3+HoH#n21TMgUCKh$kEV3-;Lkmi1!QNX2jPq%o_A-4feLa06eKWKm-AV)aM$bf_OJ9=L$;b~j z@qQR?!NPDC!9Vvct+-ZNxL#VgQCc{7(PkPEJbN$SwQQ8pUJQIUVD~5>w^46+KEC}& zbH@rq^@f`-$oUct(i;_Ct>NZmu&K5TLXzhD?&RI)2HVDYqcKzU@$GMaQwYLn9D5&? zb3Zrgk*S}bdpUe(&oD%z+`9D1zuX+%?VgXoT#Kvp14j)kDcrsG{^%gWN?xF^1j63! zd~f_`wIa#5HOu{B!|abE%#CvhwBYF3vXw&xDJJ`ncGHKOryLP;a_g!5K(T2JsXlp6 z9LpjV_-L_F`iElnrpS(nWV^Ma6CKNKy=?>kTKL{HOJk4%RumH`9}LEgNWfeL$|^nT zwRO0XW>9C9Q&NQmRMF@GM&&g8U-AfNDEn>Bo~P_N&R(GG3!HsphLel;S%=qQtg09y z{lWflI2f$}k$fnhYng4;jwdrS$t*<{lSi`@s9J8KHvd#nH=h|1G#e>DviIsau zcorxhh2Fc#C2h_m$BzsrDYm|Rr`RK*6ADy83_r-{+qA~8P2KMZtakjB^QZ8E0=ywCOm=LJyK7_ zx4Dvzuk@{A)&eVc*nlHt;vV7afGGZ;NbwC&cz`@Zh<4!iruR6%_BGM|B-#)P6m0}W zaC41`rlV-8DKt@Fa=)nWCw8V0ObjA|?X~;pqK#a_+Ql~Nv|Ti8M#EYPGB0~(DD>YT z$nFQ(-7Aq1s~V>HNFs9~y@e;X*|s2FLuc?j&^6n+DKSf7Md^G#S3BEg;%!S*`l#}` zd~VHbTLdpOc%M@BiRo-|VyHkcmCxN>Y#c~UP2&jKos;?8UB$KpUc2lDybgk+Ie9eu zWO6E{F75Rw9p_?WNwv!&8dlH@TvbQUug`X($@w`Kor5Mih262ny-@`CD&mopc-^9M^p|VDJKwB8B*cf z{Hvp!cku&jmvb3*;(Dn3mjF$kgpu%xCqI+n6=Rye5IXf$PHs1F@{ux(`?HL}khOj< z*Zmh$|LJEUpf_OrNQoG}E=NFS(F(HkY-_Wi2qU=!{Q$=}840=g7ZOEH70{BCyDs|? zzycIC^CS3mFGC>$$Lii|1QB`x5gfdj5BT?24j59-(KTbEfQPraj#;iP){c$TB1^5D z*!EUg#U+Pp6c=zcqC16?nL@cz4|=t|I-Wltx5^J#6{>Z3Et8ko;88%t9|G4cNLSO> z^fNl)x=Zr4!Ftw-ULls=BBp~bDf3Iq&ShoSvT{Xfd6<>)4{iRTg{p$!otK-I4vJgZ z36$4(ee_1SkMP~J-5&0}1KmNLc^7*5cd%aU0WGVd8NYN2aR03^f(uyhW`u#>%VN(X zWAERb`;YM0`#0uZ3N2Ku(5J!;X5h@4awB~`d?tK)&Xf;u<<0c1QJ~_80YEy2`{j=d7Y~;%iVGrt9#RZ;g)qGgFG52;a&xhNXGY`i>lF&kp zxHom>>ZMO2*XV#lmlidulJ;2oz)@v&a_(1^0GOOB(WGP4|ObJT7>(`(}HhJG8>Bt_E<@1<#Jv4?-Mrc8}X(Bu+H!MZ9at$d1 z0ZC1!PjSk8-9|itSKMX5^OWGe1mA6^v0nLNaFf|Id^wCs!@a!1Jhr}RJu2+JtfWS7 z|Jhht92H*vy~=l8gY{QVC&jZAisfmTz2}lwN3InJD*4!5Kb^c@s3{w}aXJa_mm6;J zFHW&YJ*Cz?YIuY-+Z{FBVK!2HXm1)G!!4%Kdr=_Vur6$vC>d^fWW;tzLx#IgaN+UM zWT%Rp@i3EOS-9%OvM?edkjk$oj!NvPyB+Z!zveAOKOU`=mw;9mV889T6+Yy`J4aie zw$I|D%(_rTA7yw6&Y92*S6qt$1h1l9xD6Xo^BA5;=#!10zL(!te!^RGh}z#PX0Ks3 z^{pamY)9^Od>uwqb1O6<20~5WLQ^$6wjzu|b>BqY-K~Jc3DawI_rjO<2J~Q1i{qOa zGFDJ~xUG*x1^`ME&w$v|iW$=P5cG6GgJyYJ!-vpT$8YMT%-Gh*sTk9wwvkUo>*wVQ z^Y#%rr_#?L3y1y?ui!_>JIz5Kum4>Xlpa6P{0*{Y40QOBNIoF0@%_S?a@Jbqd>I26 z*JzpKv1xoINZ%(>*9!=pCPv1|>!nY#W)IBnobAFtc!vS?so8^!Y1LVCwrv!r+>s_9 zwxQ_5vdrki7O;|NDMja1W}_;5-n4e3r$2pVx48aK&ux{jg?c&KlfKpW$KkoPeTecL zcHau0k3`#UK9A?egE#sV<@(%DSsAb34w`#61cS00C!*x7Lxdto{PI@FxU4@47X?$G z5AjOlx{Naf=qhGuA$6NS`%63rMG7hqr=SQ0BJfz7{FF;1l4CW!ey^cTqwjO#dQT`p zFW>l7kUyC7Pfi`16b?K3m4Bapeo(`GtUiSAtxECbp@mOy6w6&SegI_PYxQC|HMZZ) Os8xD{#{c@KpZ+gOjoWbm literal 0 HcmV?d00001 diff --git a/internal/gabriel/tools/TESTVARS b/internal/gabriel/tools/TESTVARS new file mode 100644 index 00000000..84f0fcd4 --- /dev/null +++ b/internal/gabriel/tools/TESTVARS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-May-87 10:00:50" {ERIS}GABRIEL>TESTVARS.;3 1687 changes to%: (VARS TESTVARSCOMS GABRIEL::SUBSET) previous date%: "22-May-87 15:36:25" {ERIS}GABRIEL>TESTVARS.;2) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TESTVARSCOMS) (RPAQQ TESTVARSCOMS ((VARS GABRIEL::BENCHMARKS GABRIEL::SUBSET))) (RPAQQ GABRIEL::BENCHMARKS (GABRIEL::TAK GABRIEL::TAKR GABRIEL::TAKL GABRIEL::STAK GABRIEL::CTAK GABRIEL::DIV2-2 GABRIEL::DIV2-1 GABRIEL::DESTRU GABRIEL::DERIV GABRIEL::DDERIV GABRIEL::BOYER GABRIEL::BROWSE GABRIEL::BROWSE* GABRIEL::TRIANG GABRIEL::PUZZLE GABRIEL::FFT GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT GABRIEL::TRAVERSE* GABRIEL::TRAVERSE-INIT* GABRIEL::FRPOLY5R3 GABRIEL::FRPOLY5R2 GABRIEL::FRPOLY5R GABRIEL::FRPOLY2R3 GABRIEL::FRPOLY2R2 GABRIEL::FRPOLY2R GABRIEL::FRPOLY15R3 GABRIEL::FRPOLY15R2 GABRIEL::FRPOLY15R GABRIEL::FRPOLY10R3 GABRIEL::FRPOLY10R2 GABRIEL::FRPOLY10R)) (RPAQQ GABRIEL::SUBSET (GABRIEL::TAK GABRIEL::TAKR GABRIEL::TAKL GABRIEL::STAK GABRIEL::CTAK GABRIEL::DIV2-1 GABRIEL::DIV2-2 GABRIEL::DESTRU GABRIEL::DERIV GABRIEL::DDERIV GABRIEL::BOYER GABRIEL::BROWSE GABRIEL::BROWSE* GABRIEL::TRIANG GABRIEL::PUZZLE GABRIEL::FFT GABRIEL::FPRINT GABRIEL::FREAD GABRIEL::TPRINT GABRIEL::TRAVERSE-INIT* GABRIEL::TRAVERSE*)) (PUTPROPS TESTVARS COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/.read-me-first b/internal/test/.read-me-first new file mode 100644 index 0000000000000000000000000000000000000000..ec17ca3a012010569a0cc37f143f85c805572d53 GIT binary patch literal 6426 zcmcgv>yFz*6rOG`kWd7Oa=#6|&;oIa#1EvUiWKc;OK7^gN`gSD`okN~CRS}vZhyqbLPc&c<=bv3CXozJ z`6vqGNfd{oIhu=!YkPdh^@Q5wd`E^{*+&GIM}SiZ0h-B3j@d5cFgS805^+1L-|L^yCs zE$Qnzz8iEnEE|9L+#nNEEgss@OoY&82VBv54&4bSuld}w1I1}clhB<rWz6%5w^4%8LFoUQ#qSpyt5F_$gJF61#HT!$*uE}s~}}~J}1X2&?)IA z)hctXAZ9|ao{>f34cvp!4o^3+WgYj(bz&6M$I^*W2tjf((iO3q%v8MNYmwDt7O-oQ zS&*tBvjV*inFX;LGAq!D5vp;&C{(dcJ`|{(u0FB!0dSzChg#=wFCko)XT^_aBH#&m zirXP7tnejZ>v5l2Ta*0)dTss-arj9jZx2Cq5h+aU; zI&of8T}|{ape1qY$;d=BZR+;7dQUg`ULZJ511IY*=g1SsrLJ>=CM-ltoD-m}KN(U`Uyv8Q4;vJW6jWfARY zK>hl$8_f*R+UXB^v;`s99SpSasLjz6q2~^`jp(Fz0n@Nk-K4GM@DuCQdTt#fIBja8 zTZv*{0+4pKD6mOGjmAOoNTT%?+!KeuVreMFfM$(2l#+KTDs-o_2#)N)H*sS7a}W0e zYTpI-=@mbKsL(f$w7O&UI1(bdoDBM-v9&eqb;td^-L@u#?CI&pd)xh;{?_6ZjPxUp z3&vc+77<52AS1mPO%i#0EJH`}VejFvHyS}>i<8P$Qn@BGoHFRv!4_euf7krLjp5=d zKm;kSW-|61a{W+x4k$!lo{-|(Bu`fnQjpMtI~9c#TC;lrk*`%Dv?ORpcNK0NP8>LP z5Vf=1h?A^H$fxBbCOvr!qqsZ~(KDiil;Ppx5s&|$aO-X}jrhzyT8?>gSxPDl`cQPX z*8ZRk&-8G+KcumUCJSEX%wskSh@D1P-}>~5 z>~DDp?>GI0S$`z$HId@$)4O zuhAFg$>|?x2;TA8U@*<@(vYC^puhB6(sGAp=#{}vX_%jQRGb**C&=E;uw~ckHvG($9+%B`Y_Jh?3co$QLU`$gzinFpkl0 z79kS`9cUs*XB9>2b^I>{=3_IFL0&U6MoVcTTkrWY8Alo9jas#z7(^yhvRtE`C4-b)DNW!6 zOPD-g=6(rM&x%!&DOs*jORVUV*|0)|_g$m5L4!&X-YY>$mUaFTPlnr%>SeM5mRT;5 zP*VH;e^yIQ>ho3WPR~P3CI=(lY-C9TGB%c6A_6lgkAbZcZdSb{ETCGrPm8OH8A aW`KQ}Xe9-iCnWQIUIr6y{mK4*{_y^%wwK-p2~bFYZCHvdyGL4DO50FeW=T4BPh~9HAu5puNx^lC z{z8ACf6{LV(BH|iGfPsE14)+C-de$?xiji)@ts<&RjctROXAV=A`9b) zs?$vqgaPh=fvrouFLit10JqS>9q5U!H)PnHGZ3EHgA)eddydNu&U#>&o-^2!ygzXF zYwo)MhSPBtUXKGX;wV#kKpJ0WH+~YpMI5DJnxzn50%RCWat&TPSrYgY7-C6?3nz%4 z1W^`7S1Kr+_*Vg>c~BT-L2~I|1aKKA%6%3j@y~f8(@%p0>_i2rYVKG-TvNvYb<-9N zIEnpaMD3ph$Q8geEi+E?N^avRL_siuEQT;jGk-i*8JCjgoNtK}g8{J#G@HjAxQUaW z5KEc&0nU;0CPbpkFrq-ks+?+(h`f&^Nk<^VG&HTfdAKMhAgJ^^fwl+Ju)2R}lp z(G=CY-NRhbi0bR2x=9>`7b#rFNrq+FNqm*~lL=OGfox$;wU!2I|G{(GHAn`yEA!Fr zK8Lr#IKJ7hY4q8uo7{1sUbpo=1B;u0Z#I(-{~=#Gt}b0}^~wJNnhmHQzyWlcEjaqF zg{!(DOfE{K)J-8?IZ%J?={-<8w*lROE(^2c5qDQ|+eH>`opOht;Q1DY0S=z%u4@a9 zr-9bC6fPR@94Idp)I0z~A9C{?hN8!$1>%%RlUoIWEBPxXyd3UX7%}s)Gh4SDE-btO z`ktvva7*xTQ zhtN7chL@d29#kJNy@&GU0u>AQ95Wk2kggJehizyb!QtT|&Sht=0;!o`1pOSe;i&a8 zr*0r{#n8~R`H)Ozxc{9Qp^6V4(dmj2tsE_G9!HQj2Of1=8xFT~-2Qim`~L}qPdVoAJ(KPCnQK^; zh5YlHP+Nj*(W3yqpx4sySeZY8iGX*QX#aeJzcXqwR5AU7i=^7_Fp*(XCe(ah0xiBG z0|`bPWKh(lfs|cGJ)cmaWC~jy3u4so|1OSO1|<%EzLw(BBrK^|2hfj;;zNF9%soD#_K@YFbyL9Q$7Mdvai$ zqNd$g7K(?68Rz(tNTFU2k*ZGgEVcT;WFv8~A+ZYcq!JqIL1M)K<33=NjdJX~nf+S)th?E8;3It9Y4}d6MmojC;Acxn5LT zp^=u^a_q>5Pg}0IyG9SS))Cf2i_xkUeT0qN?dYme@kXlFsT9}y-q5%X)qWVnuptL# z1sa--O|5x?SaOapxf1&I5UJgXffZgK+iWC`mn7CnmAArRCl$8b&{&-;7)#S%Y+x~m zDKH2joP1D4n9eL20-OO{09*m2mi`&+@I)4JPyXn>95)VJf-&>0o>9sZIJ&#P&5N~- zX%WDPJN6vyUpo303)1<+&N;WG9~ih7C!+j>0POkZOTSz1+?Hd7BYaoi<6ji?M_hKA IeER(U3Do#p<^TWy literal 0 HcmV?d00001 diff --git a/internal/test/ARs/.read-me-first.~2~ b/internal/test/ARs/.read-me-first.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..367d0e4a993c92d368f4e60209c5bf16a88421ea GIT binary patch literal 704 zcmcIf%SyyR5bR`kJuLAi=)pr1Jer_q!$4TGH&;pW10k7g2J(=Z34-G1_!EAIA7oEv z!GH*Qun0XpHC5e}?2(tEXmKlAu5jov%DK`kP8D0nX^~jy3u4so|1OSO1|<%EzLw(BBrK^|2hfj;;zNF9%soD#_K@YFbyL9Q$7Mdvai$ zqNd$g7K(?68Rz(tNTFU2k*ZGgEVcT;WFv8~A+ZYcq!JqIL1M)_~LLU}G1@Nt_f5f~hu>2vsaklDlTN0P}7|fyO;-kGAL7 z1C6qr?57w4?6gA+LlVi4BK?V`xCUEoYe+ZS3QWDJAGTl~Zf`gDU(Waz?mok8mTl^4 zIz5}scnf~rB1y^I(+i|97J{JQ3xr%qpjCm|h>r-es_W_==1K}B^0|V5YknzGI6tR1 z1Y^0jB40S)SI`e3h#-QbAH(<}CMjq-oc1=kvtIa2J8WXLf1V+Q?7blB1w()3= z?jiz0C3FVE$!^=<5iarpNIV!Gf()YMAY?o_1R0JVr5nMu<8bZ`EtYvXslsY`gq-Z;T)x|AYgFPy?HoZ8Lr*y-1AKLA+1?{NSC literal 0 HcmV?d00001 diff --git a/internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log b/internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log new file mode 100644 index 00000000..92808d8f --- /dev/null +++ b/internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log @@ -0,0 +1 @@ +(1 :PASS "SYBALSKY" "16-Feb-88 10:33:19") (2 :PASS "SYBALSKY" "16-Feb-88 10:33:21") (3 :PASS "SYBALSKY" "16-Feb-88 10:33:22") (3 :FAIL "SYBALSKY" "16-Feb-88 10:34:01") (4 :FAIL "SYBALSKY" "16-Feb-88 10:34:05") (5 :FAIL "SYBALSKY" "16-Feb-88 10:34:08") (?= PASS "SHIH" "16-Feb-88 15:57:40") (8654 PASS "SHIH" "16-Feb-88 16:01:20") (8632 PASS "SHIH" "16-Feb-88 16:01:29") (8603 PASS "SHIH" "16-Feb-88 16:01:35") (8672 PASS "SHIH" "16-Feb-88 16:01:40") (8449 PASS "SHIH" "16-Feb-88 16:01:44") (8406 PASS "SHIH" "16-Feb-88 16:01:48") (8670 PASS "SHIH" "16-Feb-88 16:01:53") (8667 PASS "SHIH" "16-Feb-88 16:01:59") (8664 PASS "SHIH" "16-Feb-88 16:02:09") (8600 FAIL "SHIH" "16-Feb-88 16:29:14") (8641 PASS "SHIH" "16-Feb-88 17:19:00") (8627 PASS "SHIH" "16-Feb-88 17:19:03") (8611 PASS "SHIH" "16-Feb-88 17:19:06") (8609 PASS "SHIH" "16-Feb-88 17:19:09") (8584 PASS "SHIH" "16-Feb-88 17:19:11") (8565 PASS "SHIH" "16-Feb-88 17:19:15") (8524 PASS "SHIH" "16-Feb-88 17:19:18") (8414 PASS "SHIH" "16-Feb-88 17:19:21") (8410 PASS "SHIH" "16-Feb-88 17:19:24") (8697 PASS "SHIH" "16-Feb-88 17:19:27") (8687 PASS "SHIH" "16-Feb-88 17:19:30") (8691 PASS "SHIH" "16-Feb-88 17:22:33") (8646 PASS "SHIH" "16-Feb-88 17:28:34") (8495 PASS "SHIH" "16-Feb-88 17:47:43") (8688 PASS "SHIH" "16-Feb-88 17:47:50") (8650 FAIL "SHIH" "16-Feb-88 18:02:32") (8636 PASS "SHIH" "16-Feb-88 18:13:17") (8477 PASS "SHIH" "16-Feb-88 18:17:49") (8660 PASS "SHIH.PA" "18-Feb-88 12:04:35") (8655 FAIL "SHIH.PA" "18-Feb-88 12:05:46") (8590 FAIL "SHIH.PA" "18-Feb-88 12:25:11") (8605 PASS "SHIH.PA" "18-Feb-88 12:41:23") (7809 PASS "VANMELLE" "18-Feb-88 15:15:22") (7810 PASS "VANMELLE" "18-Feb-88 15:16:15") (7812 PASS "VANMELLE" "18-Feb-88 15:18:03") (7880 FAIL "VANMELLE" "18-Feb-88 15:39:41") (9073 PASS "VANMELLE" "18-Feb-88 15:43:37") (9079 PASS "VANMELLE" "18-Feb-88 15:56:35") (9297 PASS "VANMELLE" "18-Feb-88 16:01:21") (8682 FAIL "SHIH.PA" "18-Feb-88 16:19:12") (9301 PASS "VANMELLE" "18-Feb-88 16:22:02") (9310 PASS "VANMELLE" "18-Feb-88 17:03:11") (9350 PASS "VANMELLE" "18-Feb-88 17:38:51") (9360 PASS "VANMELLE" "18-Feb-88 17:40:01") (9381 PASS "VANMELLE" "18-Feb-88 17:40:37") (9407 PASS "VANMELLE" "18-Feb-88 17:41:58") (9329 PASS "VANMELLE" "18-Feb-88 17:46:18") (9291 PASS "VANMELLE" "19-Feb-88 10:57:56") (9311 PASS "VANMELLE" "19-Feb-88 10:59:09") (9379 PASS "VANMELLE" "19-Feb-88 11:03:38") (7788 FAIL "WOZENCRAFT" "19-Feb-88 11:02:33") (7966 FAIL "WOZENCRAFT" "19-Feb-88 11:02:43") (8120 FAIL "WOZENCRAFT" "19-Feb-88 11:02:46") (8229 FAIL "WOZENCRAFT" "19-Feb-88 11:02:51") (9386 PASS "VANMELLE" "19-Feb-88 11:05:41") (9289 PASS "WOZENCRAFT" "19-Feb-88 11:05:17") (8706 PASS "WOZENCRAFT" "19-Feb-88 11:05:20") (9054 PASS "WOZENCRAFT" "19-Feb-88 11:05:24") (7886 PASS "WOZENCRAFT" "19-Feb-88 11:05:28") (7908 PASS "WOZENCRAFT" "19-Feb-88 11:05:30") (7928 PASS "WOZENCRAFT" "19-Feb-88 11:05:39") (7947 PASS "WOZENCRAFT" "19-Feb-88 11:05:42") (7948 PASS "WOZENCRAFT" "19-Feb-88 11:05:46") (7985 PASS "WOZENCRAFT" "19-Feb-88 11:05:48") (8018 PASS "WOZENCRAFT" "19-Feb-88 11:05:51") (8111 PASS "WOZENCRAFT" "19-Feb-88 11:05:56") (8138 PASS "WOZENCRAFT" "19-Feb-88 11:06:02") (8161 PASS "WOZENCRAFT" "19-Feb-88 11:06:04") (8162 PASS "WOZENCRAFT" "19-Feb-88 11:06:07") (8165 PASS "WOZENCRAFT" "19-Feb-88 11:06:10") (8176 PASS "WOZENCRAFT" "19-Feb-88 11:06:13") (8187 PASS "WOZENCRAFT" "19-Feb-88 11:06:16") (8237 PASS "WOZENCRAFT" "19-Feb-88 11:06:31") (8245 PASS "WOZENCRAFT" "19-Feb-88 11:06:34") (8250 PASS "WOZENCRAFT" "19-Feb-88 11:06:37") (8257 PASS "WOZENCRAFT" "19-Feb-88 11:06:41") (8279 PASS "WOZENCRAFT" "19-Feb-88 11:06:45") (8354 PASS "WOZENCRAFT" "19-Feb-88 11:06:47") (8378 PASS "WOZENCRAFT" "19-Feb-88 11:06:51") (8385 PASS "WOZENCRAFT" "19-Feb-88 11:06:55") (9411 PASS "VANMELLE" "19-Feb-88 11:09:37") (9422 PASS "VANMELLE" "19-Feb-88 11:10:56") (9426 PASS "VANMELLE" "19-Feb-88 11:12:41") (9450 PASS "VANMELLE" "19-Feb-88 11:34:26") (9466 FAIL "VANMELLE" "19-Feb-88 11:48:53") (9435 PASS "VANMELLE" "19-Feb-88 12:22:26") (9466 PASS "SYBALSKY" "19-Feb-88 13:53:21") (9466 PASS "SYBALSKY" "19-Feb-88 13:56:57") (9349 PASS "VANMELLE" "19-Feb-88 14:07:57") (9055 FAIL "VANMELLE" "19-Feb-88 14:34:17") (4067 FAIL "MULLINS" "19-Feb-88 16:12:12") (2047 PASS "MULLINS" "19-Feb-88 16:12:43") (2316 PASS "MULLINS" "19-Feb-88 16:12:45") (2532 PASS "MULLINS" "19-Feb-88 16:12:47") (2800 PASS "MULLINS" "19-Feb-88 16:12:49") (2857 PASS "MULLINS" "19-Feb-88 16:12:52") (4146 PASS "MULLINS" "19-Feb-88 16:12:55") (3787 PASS "MULLINS" "19-Feb-88 16:13:17") (3889 PASS "MULLINS" "19-Feb-88 16:13:19") (4051 PASS "MULLINS" "19-Feb-88 16:13:21") (4220 PASS "MULLINS" "19-Feb-88 16:13:24") (4349 PASS "MULLINS" "19-Feb-88 16:13:26") (4725 PASS "MULLINS" "19-Feb-88 16:13:29") (4464 PASS "MULLINS" "19-Feb-88 16:13:48") (4566 PASS "MULLINS" "19-Feb-88 16:13:50") (4723 PASS "MULLINS" "19-Feb-88 16:13:52") (773 PASS "MULLINS" "19-Feb-88 16:13:54") (4092 PASS "MULLINS" "19-Feb-88 16:13:56") (4778 PASS "MULLINS" "19-Feb-88 16:14:18") (4878 PASS "MULLINS" "19-Feb-88 16:14:20") (3544 PASS "MULLINS" "19-Feb-88 16:14:23") (3811 PASS "MULLINS" "19-Feb-88 16:14:25") (4336 PASS "MULLINS" "19-Feb-88 16:14:27") (4746 PASS "MULLINS" "19-Feb-88 16:14:30") (8867 FAIL "SNOW.PA" "22-Feb-88 12:10:04") (8754 PASS "SNOW.PA" "22-Feb-88 12:14:07") (9290 PASS "SNOW.PA" "22-Feb-88 12:14:10") (8712 PASS "SNOW.PA" "22-Feb-88 12:14:15") (8713 PASS "SNOW.PA" "22-Feb-88 12:14:18") (8714 PASS "SNOW.PA" "22-Feb-88 12:14:21") (8745 PASS "SNOW.PA" "22-Feb-88 12:14:25") (8715 PASS "SNOW.PA" "22-Feb-88 12:14:28") (8757 PASS "SNOW.PA" "22-Feb-88 12:14:32") (8854 PASS "SNOW.PA" "22-Feb-88 12:14:34") (8880 PASS "SNOW.PA" "22-Feb-88 12:14:37") (8897 PASS "SNOW.PA" "22-Feb-88 12:14:39") (8898 PASS "SNOW.PA" "22-Feb-88 12:14:41") (8906 PASS "SNOW.PA" "22-Feb-88 12:14:44") (8911 PASS "SNOW.PA" "22-Feb-88 12:14:47") (8916 PASS "SNOW.PA" "22-Feb-88 12:14:49") (8932 PASS "SNOW.PA" "22-Feb-88 12:14:52") (8962 PASS "SNOW.PA" "22-Feb-88 12:14:55") (8963 PASS "SNOW.PA" "22-Feb-88 12:14:57") (8964 PASS "SNOW.PA" "22-Feb-88 12:15:04") (8969 PASS "SNOW.PA" "22-Feb-88 12:15:06") (8973 PASS "SNOW.PA" "22-Feb-88 12:15:09") (8991 PASS "SNOW.PA" "22-Feb-88 12:15:12") (8998 PASS "SNOW.PA" "22-Feb-88 12:15:16") (8999 PASS "SNOW.PA" "22-Feb-88 12:15:18") (9003 PASS "SNOW.PA" "22-Feb-88 12:15:22") (9009 PASS "SNOW.PA" "22-Feb-88 12:15:26") (9016 PASS "SNOW.PA" "22-Feb-88 12:15:29") (9034 PASS "SNOW.PA" "22-Feb-88 12:15:32") (9036 PASS "SNOW.PA" "22-Feb-88 12:15:35") (9037 PASS "SNOW.PA" "22-Feb-88 12:15:38") (9049 PASS "SNOW.PA" "22-Feb-88 12:15:40") (9052 PASS "SNOW.PA" "22-Feb-88 12:15:42") (9155 PASS "SNOW.PA" "22-Feb-88 12:15:45") (6809 FAIL "SYE.PA" "26-Feb-88 10:28:26") (6815 FAIL "SYE.PA" "26-Feb-88 10:28:29") (7408 FAIL "SYE.PA" "26-Feb-88 10:28:32") (7326 FAIL "SYE.PA" "26-Feb-88 10:28:34") (6521 PASS "SYE.PA" "26-Feb-88 10:34:44") (6555 PASS "SYE.PA" "26-Feb-88 10:34:48") (6563 PASS "SYE.PA" "26-Feb-88 10:34:50") (6599 PASS "SYE.PA" "26-Feb-88 10:34:52") (6705 PASS "SYE.PA" "26-Feb-88 10:34:55") (6798 PASS "SYE.PA" "26-Feb-88 10:34:57") (6899 PASS "SYE.PA" "26-Feb-88 10:35:00") (6955 PASS "SYE.PA" "26-Feb-88 10:35:02") (6962 PASS "SYE.PA" "26-Feb-88 10:35:05") (6992 PASS "SYE.PA" "26-Feb-88 10:35:07") (7033 PASS "SYE.PA" "26-Feb-88 10:36:20") (7153 PASS "SYE.PA" "26-Feb-88 10:36:23") (7273 PASS "SYE.PA" "26-Feb-88 10:36:27") (7292 PASS "SYE.PA" "26-Feb-88 10:36:30") (7372 PASS "SYE.PA" "26-Feb-88 10:36:35") (7376 PASS "SYE.PA" "26-Feb-88 10:36:38") (7401 PASS "SYE.PA" "26-Feb-88 10:36:40") (7445 PASS "SYE.PA" "26-Feb-88 10:36:43") (7471 PASS "SYE.PA" "26-Feb-88 10:36:45") (7514 PASS "SYE.PA" "26-Feb-88 10:36:47") (7521 PASS "SYE.PA" "26-Feb-88 10:38:09") (7561 PASS "SYE.PA" "26-Feb-88 10:38:12") (7570 PASS "SYE.PA" "26-Feb-88 10:38:15") (7639 PASS "SYE.PA" "26-Feb-88 10:38:17") (7669 PASS "SYE.PA" "26-Feb-88 10:38:20") (7674 PASS "SYE.PA" "26-Feb-88 10:38:23") (7699 PASS "SYE.PA" "26-Feb-88 10:38:26") (7709 PASS "SYE.PA" "26-Feb-88 10:38:29") (7724 PASS "SYE.PA" "26-Feb-88 10:38:32") (7745 PASS "SYE.PA" "26-Feb-88 10:38:34") (7761 PASS "SYE.PA" "26-Feb-88 10:38:37") (8986 PASS "SNOW.PA" "27-Feb-88 13:15:21") (8884 PASS "SNOW.PA" "27-Feb-88 14:37:09") (8867 FAIL "SNOW" " 7-Mar-88 15:49:28") (5932 FAIL "CUTTING" "14-Mar-88 16:08:48") (5930 FAIL "CUTTING" "14-Mar-88 16:08:52") (4879 PASS "CUTTING" "14-Mar-88 16:27:28") (4981 PASS "CUTTING" "14-Mar-88 16:27:35") (4933 PASS "CUTTING" "14-Mar-88 16:27:45") (4957 PASS "CUTTING" "14-Mar-88 16:27:55") (4992 PASS "CUTTING" "14-Mar-88 16:28:03") (4997 PASS "CUTTING" "14-Mar-88 16:28:06") (5008 PASS "CUTTING" "14-Mar-88 16:28:10") (5212 PASS "CUTTING" "14-Mar-88 16:28:14") (5225 PASS "CUTTING" "14-Mar-88 16:28:18") (5259 PASS "CUTTING" "14-Mar-88 16:28:24") (5260 PASS "CUTTING" "14-Mar-88 16:28:28") (5376 PASS "CUTTING" "14-Mar-88 16:28:32") (5383 PASS "CUTTING" "14-Mar-88 16:28:35") (5412 PASS "CUTTING" "14-Mar-88 16:28:39") (5490 PASS "CUTTING" "14-Mar-88 16:28:43") (5606 PASS "CUTTING" "14-Mar-88 16:28:51") (5619 PASS "CUTTING" "14-Mar-88 16:28:58") (5647 PASS "CUTTING" "14-Mar-88 16:29:03") (5695 PASS "CUTTING" "14-Mar-88 16:29:06") (5707 PASS "CUTTING" "14-Mar-88 16:29:08") (5715 PASS "CUTTING" "14-Mar-88 16:29:12") (5716 PASS "CUTTING" "14-Mar-88 16:29:14") (5758 PASS "CUTTING" "14-Mar-88 16:30:29") (5771 PASS "CUTTING" "14-Mar-88 16:30:33") (5839 PASS "CUTTING" "14-Mar-88 16:30:37") (5843 PASS "CUTTING" "14-Mar-88 16:30:43") (5895 PASS "CUTTING" "14-Mar-88 16:30:52") (5844 PASS "CUTTING" "14-Mar-88 16:30:58") (5993 PASS "CUTTING" "14-Mar-88 16:31:01") (6000 PASS "CUTTING" "14-Mar-88 16:31:04") (6020 PASS "CUTTING" "14-Mar-88 16:31:08") (6034 PASS "CUTTING" "14-Mar-88 16:31:11") (6067 PASS "CUTTING" "14-Mar-88 16:31:15") (6161 PASS "CUTTING" "14-Mar-88 16:31:19") (6362 PASS "CUTTING" "14-Mar-88 16:31:24") (6416 PASS "CUTTING" "14-Mar-88 16:31:32") (6434 PASS "CUTTING" "14-Mar-88 16:31:36") (6473 PASS "CUTTING" "14-Mar-88 16:31:40") (6520 PASS "CUTTING" "14-Mar-88 16:31:46") (8590 PASS "JAMES.PA" " 5-Apr-88 14:29:54") (8682 PASS "SNOW" " 5-Apr-88 14:50:22") (8867 PASS "DANIELS" " 5-Apr-88 17:23:29") (8650 PASS "DANIELS" " 5-Apr-88 17:24:39") (9055 PASS "DANIELS" " 5-Apr-88 17:31:31") (5930 PASS "SYBALSKY" " 8-Apr-88 14:35:04") (5932 PASS "SYBALSKY" " 8-Apr-88 14:35:08") (6809 PASS "SYBALSKY" " 8-Apr-88 14:35:12") (6815 PASS "SYBALSKY" " 8-Apr-88 14:35:14") (7788 PASS "SYBALSKY" " 8-Apr-88 14:35:17") (8655 PASS "DANIELS" "13-Apr-88 17:00:51") (7966 PASS "VANMELLE" "14-Apr-88 11:13:45") (7408 PASS "WOZENCRAFT.PA" "19-Apr-88 17:44:48") (8600 PASS "WOZENCRAFT.PA" "19-Apr-88 17:48:06") (7880 PASS "WOZENCRAFT.PA" "19-Apr-88 17:58:46") (8120 PASS "WOZENCRAFT.PA" "20-Apr-88 14:28:06") \ No newline at end of file diff --git a/internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT b/internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..4e139f2e83a12523248ad314d5ef1062ba13b5ff GIT binary patch literal 63780 zcmeHwZEqY|c3x{{$7^xz*lTAUuU~6sb~Q~e$_x%nb4ijKJUh7h(j+#{`q-dConz zZdF%zb7nPOBiPYMELPpR_uO;O`#Ja4#_?!ztKaQr*E)mU<8D4Gma^=|pnsSh6un}Q zce8G%R}2@jN1f6AY;?cKir(HZ+wTt!JH3M}&qjG~uQ+@&%T{|?k?-DD`vq^A?dQ8} z*FPSWBMg_a+eO}cbidOr7VM?|zTW6#fI+sG_jZc`#_aSkz!2}V-SDuF$Jt?j)amyY z*l{t`OAqs1fW4OukNP7FoIk*Qyf!M12mgb3ViTu*mj0 zgJPE*XSlQ984O2iUhDxIE1dAXeD?w0ILd*OZqdyiRqpTxvG>ZuRAlFPs_j6A1(xMt3_8$`aJNNO%E=IvWz3d*~8RUX3?{>b2d3JiE zes(|aVth<&m<{juAF*Ax|7dCMZ0q@pU%TA;bi0=gv*hnQZe7SOW|y+d*=yPB*%z}n z=3A|^txsN9yo5g&@c2=N#l@dT`cv?Y%bC5S_StKCV{-rFt>?~OEwBc~*;{#cA1FIH zySzUt1|^gg7_;6fpp5VttdrgdP&V{$IJl6#VR*otWe%#r|j!EVvi?$p=L?z&}^A4Y4PsTu!L~#Ng4xVsN78OWDffQPCUn z$(z}e_p*&KDZ22K5Iz}ykX?8WXl$#mz0UrA2U2%5zchEPKadE*3~qOZ#}KLzLI4e5 zV+;s|Nvj570g;wr+2*#3(ecqRJD1%oMvD-+d~xl<5&qrGhbAmHb|HBe8UW5lk2<>$ zvs-I7m*zI}&LG>^-*;U=aSBB2X2b6u0~3O$KZMvUhMj|+N#8`?a%m}_qp&rJ9;9sd zMCzfJ-Cz@7XlYK1T67NXkFwqSxdijzSVCLc=gn*x(lDrn^0hz=_4lAsD6!FtUN+GU zh$zCZK$t?e1)b*YcKe4%-GVw~uYY{6TR?6LU4vtQ23p2^Z}$6pB3oPw+5lMg#BsHd zZ5GfAz}iA~6+Mf4)}TC>o<_P~-rX&ZI1U-$P3y=pTa1A18e=SzBL~G%7nnLMdLyyY zSFr>TqK3JqCEpHfRg3`ats)09N+5|z{|%Hv-5(bnlO{9pp0B)V->i;fbZi~rm7V*8 z<13o&E&7h^SBJ^ z)0Ch+4eEtYFG5vb&Mu`-gZiEDGDF5e&-L}Z(8bq#wq zV(P4|awgoAx94Uk4pDgyvHUo5n+D=x6pa(eo#HVJlkQ2jy$jPU;{t;8(LUOeAAHdI z%g?utTfmgtBD>-+gey@IJW= zg7gL?0#>3jr>u>;d&bC+Ad(}L9x}X#T{0p_11glJ#C*bVdDgAy-GtlLv+WFj>)iIq z>#NJRH`cF%FZ4WHueW&K_;Dq>o8fQuX*8U6203)LtbB+Bn^R<$lXSgK#T!kWL8gF; z>{8}9SAZ#+@K;(xO?TV7#Msf@wAYIiQl~sWeSx_ zMI7W;Wrc8a`)B~&mMX8+o-)X_U%*K5*;vQyA^>9(wc zO8IBo{!DTRf)lbrniOT~CtC*>EVx(WvVCs7KcXngs}fR{5gbCdOXd5S>qjG>c3=QD z%jsxIm_>n1R&Y_!#!_J`sQhVsU+s%(K65xZ^c?7o$ zgvN0oZy71UvaHj{+w1HO(c-(u2#_1`}B)tO9on>>m-Si>de{+P90mMx$66c3zik3z_>7t1zC(aP)>VSp6bquYv7}2Gb(4OFGn`mmHUAa!gN{&i z;T#<0$2NbsxfjXRLQg=$LbkjHPnJFzXQ%aW)a1RBM_g5ye(tm}On1~D4m}d{>&6$PXv@d!&JtAg-eIg=rBeD zRp8Zt4Ki}Mi|8qg%iy%ahDKz8Attg+Mba@&wm3XSqyeTA92#;yA_4Zp_RVs2y@1UG&yw-45MjA-5g{;>w3Wb2Ff2phCW>rC zz+Rjyh2xmactYkzZsaK^xL3eYDqw{Mwo%;PZLko(-|P1jGGkOkX$Qq~VvtOBZRit& zt?p;IW5!gkFG+&IvUV;{ET>jJ?DzKOg_ICPTdjm_EmlH%N?jxVx$jQ&5K*Sm$_VCb zFlN_{cE@uB(TtUInbgmL*137Oxu!nvrLo_^{AvH!cgn7mT8T0Nce+I$&0a} zemuB|+h|Uci0_+4J8``96#=FJ1?(vYg(iFhSFaPuo8 z$V<%a7#T(jK#9@%2x`g$56qnSU@}rags*LbmZ}|@z8`$}F{`Q+a>0!B8??@YrxQ&j zr=C>ojY~be>4<9Vnxs*z_k01=G8hnlrjHev*`R$dRAbdTH5d6_b zVQ8&SrG;v!48ri5`)=l(I{89GHhFLpvX9F&Qw}sVI1_21|8(jvdfDWt14OEoe&5WWJ;8!te9*IiA@!xP%sUG zQxaWs$gyiVgerZ4cj>H>FG9Etm((X|TQlWCGdhKUc}L#TAw@G%$R1Xc;UF72l5pG@OTg2V({z$Cu};TIB36C z%Tx$eWi3*$_WI0iQ>AM9NaP;Df<}a)i?nns&v4r${A}hgw7v{S#jKemipbW%eLyJ( z3mLv>?#R^EYzc=Ww5~E#_U>8a!w8;raa!=+K$48$mE4YN15fENfcF}P4d6{_Eng^^ zOe1)+Y!FcdtcHt=7WBwq?hcKmmC+d%kLifhwV@B*rhSq=a4(zL3K=x2Pq5Vlt0FRR zNP+_?4N!E`4+&djkEjP@H3G@TN{E~>=*S~Mvw zOh%J3gkA0x`7uHVY3;#rZ`A1$M<se3JoydU zMH3<~jXCNn^C=gBD1w{#ePkATOt*qapWHC}*B9(*U>uRy z?%9oGL*#Je`knO#QZA~~1$5lvLGap*Dd?0`ii zBT^Q7KkD{Rj7W5!xo+^^c$nFuLJY*{d;7;U$SZ7K3)xo3 z^DIl?bCzxis_jim&iY!wlNyWlI-3VaK)1x5&BFAbg0oZ&%*L*r(QMu;(L$n=V2Y$v3;j#JtEGn8A z-+Ud0@EiE~Mb$LVo&6{?&e{sNl?-hKMf1dj=hGSI3pp~&qBX_&W;A~da9#wYuVa;1 zvt5IB`e?6(goYJxTPk7-a5fg*1dXTBn%DoVTLmFp{U}FuqRS8%tV0!7MH7f7sLY}T z#n9-i!4=G&NN5@FEG;cPg;cuLe^kJ}M!w17;3k8i3`$9EeVAW291S|ELF*L|${g72 zP=vYN-LIL%scbRPy9<*u_zQ zkw0a+Cp$WJpxZ33X+#bisi@k_l(IB+Le{v^KSK`#BruqUGFoBX21c<=Xq420;uXeW zI9@hDzMp8-u$&@7cW~$xcm;Zp-O)-XR)1RX9SX&<4$N61MjIlhBsv+O)Y-uYbTieBZ9@$;ScEB?6Xx)7@!XRIdRq@)Ik}fpP$3z?)`gF9BO}46I z@odF_HIyP_h=3CppiC5&nT3c#t23}-Kk~!%{@y|KTr2jfav`$yz_(rq;8lWTzp_|5 zkf(L#xxc%4_kj!>4S_O=;46&Prn5XSiV?=KSiNa=DoL$f*6wy56puOxQn2^_uywRj1i%6Fg^A5wgOjgxG?X-y3Q1OYIerY>D8z1?+Su zSBZ$lHi=}2E%K@B!fjX_S9;4LvD1! zBxR|22th!GDTa)IIghpItXvQHC@c(nm}4`L1V>2|aK#ZtvIvwDR?g5GDBQ|ks&5+7 z>@BMYpBa9Db6t-ULilS4!@4xnlOb0Q%JM0g@W~?*Iegi;O(K3AT1 zRSYWP7qQcKL(^(c;-+)P5~;L@fQ0l&vpPbO%bbdsp{T&j@?;SjMG87}mQ-{Uz^Ftp z{6Ym|&l4G=QIp)lnA_9rb^O?cS1<1@-$eYL#aHD^y)wN}^{V`ZIaE9FPY`65i*T39 zauL-CVgNa~keUkQ#ffhMV55LWphNZilkfy#cZ2bE~JsuMZ-0h&9Fds5zb=vx@Cn78x5@) zRJaJNU6#9N&SluJYhIttFGUN$ojkfFdD&mN!FY0ODmXfva%@A2s6+*6(m@7Vj3!w& zZ=O3qKK0@?x+Mz3$}ORr6C&(k$9AavKs4%@TM`klMpz45W6OL6c5#NNuA#_8pA3n~ zjo>g^G7#bg<^;mTL9z}}VvOo(@IJ*f*%{n@y-(dEDM%^oZRt_;cXxAcK81;Wf|g~t zJ5dY4FPEOaQ!fyF7w$zCPI%w&(THpdR?Ir ziVyiQTb``VdL5#j?qJwfOMD-8_7<_%6}GfT3z|0L#MH1^o25Pk6x4B# z#Zdj;l@OfQ;{;oD^ljU5scvhJ>HFK(<5@8TQnL`VNQt&+)X2oV!U;eURFKN2skcPK ztsU&p8=w>`!_|FU9k<@Zwf)9otpY__EZEBNcMreqw>oIuLE#p6_1SNEtBdQE)??l6 zq21C4t;WLlx^opuD@gevQ{Y?d%w8$AY;azKc2;RT7C?3iaxW@#XDTP|<8(!QH`X{? z)PrY4kQO+kFhd5%=@m#E!e+9L7;d0v%xy^Ka}_za87K*+oDhTrX%41VB~4Y`c2Kfr zDQ|+QgW)^92WHBG03=~#yJ$G>J;87ma6%TQKt450@lk*90NF+4Akm;4V2t+}X90;j zYM2=qU=ttsaG+!**q4-OXIpTS9?Uy15+w$zB^*H_dB`LRnr1H50?>nuh(|{rUn=)> zbif7L;?A8FU}$h+8hlD4I9T#YTlO{BFdyE}PXNDR1POJqdDxG?jExjwLq$p|p0TMe z>5KDo+nvXYJE-Vb-bKpzdU1>&n5&VM?-P(WnA-^ep;Qt@AR*Av^G(Rv>%qGhyL#3( zxK{2zA^~bUp^=hKw#o+Sk21~Zh!YA$h$uYD+gv74Zrqd$8Xnyb$3EbG+B-{VlH)-b znl9_YKHFZon-z~ToNf^R$FD1Q=UXqT7M|7X6aLP(igx?X+T!xoHE8fJs$4#6-`Ua) znqzoxK5MU83)&gshP7bU!EW4ITU}p)POtus(@FGv{%q^at=4DT>!^Nf`2SRZK4`ah zHZ~WxS8lHYQ0q5qU)|WTTjkKJ?+6x}PzGDLQ34xoAWu?l;S-*pJA2)#vxjGI0oQYz zn_iN<^`-Ne2M})az(sO>s(F+MXCBBPj0pD?uql)f+wUd7aX}p4YqlUhX(0TQx3+Gs zEpKn9;HJp`(DX3{+*#mc?dcN&xNb52U_{bCHIZE3s#8h0<3y0PSMOLGIvatK!X0N7 z5Q=0eBkxDtQ+f6lr1Al*n&DZxpg2H6+a(ivI(s`FPY`yMC1!22VBQFFMk6#xd{@rLRmS8sSN9>);`ZoHuiCnvsk9Zy`c@UbMtx4I&Poi&ZSNl89~)`fK=@9_0HoC zENm9Akx+uOmW0TynS<=b?sPvMcJ^>I0L&j1vt-}s9Aw`>gi$LRBFc14io+oZa|2w) znxL?Y;07#I()CWC=pxn-BE%2UF| z-0t!QEqHR`01wXL?>21sPV4A{R_P7Zyc;u$oZhZv>sJ92Siy6(OzC#>y$)z^2neyu zo774W5mh7fiR3^N_}6fIkqW_vuzIQ$W*XRx?>H*OcERMUmMtoAsiB;>v-WWhC3@z> zDmOhgIu=is8F9TVnexPmh}ea*PTzpXGvxz!ear421@Kh0(}(S>TyXZ}9Xe_bvHD+n zI-h1ov>7b~^>kPX&)d>UVk59+I+%9?PyyNLIeg?)D|c3TBF$(<1Ua{S?>k7(!m+o( zWiF&~g6ZMiUqDa%)uAJH1tG7|><3iJ&cuu#|L&YZY zyzsj?Bw0Egw2?XO2n{yX>QG0qM$Bfr=xjz_1?m!ZOx~m0TatE7#|YaOmCM|->@51( z0b+-U{TGz~Pi$cPyT=%DbfQ@n$1Oqo$Gsj(yp{j2AHsFH=@2gV$Jwwu>{SkFu_TiV zO@bv*W+|Q_BKOVDl`+EM`%XC^g;>#!T@A?@jwVi>G(kuWQk3)c7DExk5d$q{Eo^0- zBhxWZ}y+~m6?HV?tY%sya!wvvV`_AG>rtyhJQ8YB;C4r&_Zp$pm9SjevHQk57b zfrBpNWDfV?1f|7H}cV&bF{+uKWLp@Md$`Pm<93-OdSsadaS{6@USXX zz$8mi5tANfc}|@Q;(Ka&aVtp3E_GyR4I*Zslw7y zNeqpQC$uO7@?m2I&BbC5N8ai{8sghbyk-|GM5rH;x`R7KBh?fL7KyvqA%VyT`3Rbm z7I`9VN-5S9b`II$8cl=Vnyj+xn>%AR)GcLqMKmEQ1PWrwFtj>IplV))6~l}XgNoi0 zb`nhRY^q0Tigjb0-0dW65Evt4hybW1HuSqBVzLb4) zhsHhBv0{p3eF*Mv0Zo{Gb&680s|eR&+eROL57@=Hu??#T#};a*F9cEQw8c&$)TeXU z08|hNG?*sD-yxm=gK8y{{UUCn)lE9zwjxrl6fCXrgag~G$guuG>2q2B17dGX7?W9p z-I4lp2)d~<_9d2(4|WQQAsM2j$A*LBa9U+FcN?}rN`9dj z-y_OFc9AppyZOOUAC8#GgRHg-pfmy?IVB4v7^S{z1rwC-ICFZWguciiiMK9sM?e|) zr-YR&iIUWCGIQ|JIzT8+-q5LeIEk=6Nfekr^{oZ*O@PKSLFhu58muS97J`OX-$flF zgTXSz;@Q>S%bRA~hx7*bIwGZro_z}nB{mR7(WLWiIXRv1o8z>u;6MZ%hTS=3(=VO> zK0*axFjSw>BJx+!CH4Z?q1^dkmof$Cv0?J^2zeMcSWqrU0L$_gVAFC#q!;p7A^oMe z#^{^iM;hmB!Zh3Y7fY z4s^VScR4G^l*Q38G28@U*??gys6gPvh|Y;q%Z{EuA|2qDeZ+$9;)Wgv+ zEco&!XoX#qKNXuGYUn4-q|H`N)zfxUPt}5qvGZ`!QSMF~Wt%h7|MRWq+YM7;gNd`{ z1gdXOgKNe1-YUfSL92l&-jBFG+YUQc$BN3Vt}dLA#;4`EJ1S-1Ay>(}mD7F3-es5^ zI|x*HP$`rc+a?jqO7wtt5E}L03&nKA}0!Qx*v2yYP0+ zs*lXcQ-Z*VyLoaZxXFdoiZZ^O5a3P4gl|Yn%G)K%s6vBqGRF>~FU~tKa4_F&J1=>Z z_<^|v?<$}Z;^;%zG7s}X2bHiSG!|bIUuNzh|@Htcv(v4b!`NRUoRfdxIgo;KQi-36I z6$p@-MuQef#0E8^9e%V??GTnoQHX9SBitO_*p&5gE%;f%Uj!fx9E+VP)AXYU3P#!of`F$9HyT<4@yk7E55MOqMR*nS^2 z-CHe{)m2%6R4S%iC^=;u;?oQWs4Be-9_}>&kH8F17eay~NjH^62W3^mjs7mU#q=e< ze36e3@DmZkbU=Ur+cLQr5>oJS%_~)L0AoJzmk?u2>QiCq)CxE!RKJEYCz;T6EZnut zQBs8nBa9Xt1<{Oo?g62pL{1JyCG|ccpnMC=68cW~n=*I-W{#vXBrhu}P$Cwmg_rKC zPxuJ1hXUDv6&~VjeFndWJe`pRwv8vWQMATD6W*s?gIl7;=qlFYmSxb|3SKKbmF!S* z_8e!*Q*LlE?`Zg9^P#@VPg!KFb{qocK?65?`8@rum*4XlQW~jlx0*qMADg%@%`4~O zPR)4R*pGe>yJW%v%b0$yKmkSrA1&I=O`uE=Yn|{x1Bi5Z%yjITMXVf1640__2SKur zKuZeSW}C+#_NzGb`|2*u{FY0p|AwMSSYBRB7BIsYv5EJ zs0yhE6_ger@!JZ(GC&0q8<_7KlP*j5`_v!k~E&<_SjcC48%g%&qlk%0F#h=;N4WN>)FRHdI|2jFH|O zX4fQZ6J-8>Bypp(jhQ_YNEX#**wl55;`NY`QrC7SO|_IUv6Y&XeV}EkVv3=g_<~Li z^CgC#HYOBRL>n_RMj0_?>ql&?JjM|tFlTU3GD|Q-b!(QL7aL9DkR(b6((es%h`MXm zdjNSi=0T_tEuIuCYx6^7V#G$a6_%2{RDo&IW#k@>hbm(U2lNPEv-?YRyGBLp%P14Gv)A`{We|CY1!<9+V4Otcgh8QA}CC^zoUfmwO*GwO@`{cP=OyRHsRV=tj>L#p=N&BO*cNfL) zX54q<`c%D=F|u%f!(@}s^ppfb!pGz%a-``!1T@G zu;U;I(2DP*y~|R$4!p_5X18S-+JlTYV4+)e&aOcXv{JJBst4{0nQTm(eNFTpEPI|L zJe!o1WK8fLJwvWaKM*m0Mq#S_6Ih`tOew|#1R%z{+5;ioH!BF>a*(@36$HzX%}7kV zXt4}&4iH2;g;G5|8zv~q$TlSec^UR5K=*P1$7E*HUVmvj8j%VQ8JD?W0Y8lp zXo818F*#8_E_ZD=m`$tPf?-`UW>sBAmn2F%(GkH2Kn85pK8}Ngr7ciON0sMtpFYu= zn7(kUeT6Y4ZX?o;t)=3kY(O`dPHMt z{Xs~nRunppavUBk6@KLeM^A%mhcnLz_!Re1DD;V~Dz)$OF=g{9e#(|#u`M21!iW1$ z!e6;(R-W9UJywZ-j3-DKx8Z@t`AGs}=?-^m$QTvpf)HklT|rvrvHgykwS! z$#rlr(dh-9$!d~Wd5VsVLJB$%-L{JLXleP5uL@b(gm)VE8`O`WXPkzimJCQa!oNJI zz6a#k4oKe55zooh3VRi@C+VoLmzDWOv744AeMX2REmh}Pf?EAF&CJ80DoZc6feO^e zF=(ygI;5;sF4S!M$ZK?tTty%fB;&ts9FJZ^+)>gGKPo_5ap|M{2<7##k@!(;K~q(E z;PxG8WSvJ!cnTH+m~LW39eO3!`+%lYen2;aL3x{7Zac*Y8 zY+OLGY-vyN5|8Di=p+RBaUB4Z9pk{?BW$oCuiPt;b%6N+At@(~_mJ#i2y7m222)=E z+|x&e!#Bn;q+%t2!If^KSycuItri1~S?sd7+eO)tPTXPGR{b*=91R&OH1IhzpYXGz z^dt2=ieg}1ggP}$MRH%BTRc$oN`{Yv(<7yohyq(qw5*7=r6NZ2F2ALB;u}AGebDK> zf=3XC@8>bN9=4GnnuG;^65FL1h!u*jx21%#Y zidw{A>p3`RZ@58dQFbhesF~E0Ge~JxEW|Hq(Ul4NRJK9UAsHgnCyh5z_L@OaGp#N%#56DBkaM(J@z1IU;*tu(1)I} zi&~p2!cnpC+(eHDSlsFmp!+!^%z9L-wt%nXv)c zP;uu}ZUF!Z2m_jPETbteHb&-*@XUP+2Wc4r)_u-!XbmaPO{%IEDd~|~5G3X71z9#` zLR}l++hyElB`e83HWl;8H5Vtjr3tkodL{}g^x=qwa?ty|s!J2LHS56!J zNr@@Wf}pV-K;q6IaG6nqF%V9EG;ytcG5{eFzQ%O0MU2qE=G+0m!O+eEK4DW@Y1d7T z69(H1ib#nzt0O>1HOGXmk45y#7tDHVsxIaWhrurjR8nhz(=Ce8!y0UBaaG$1HS0|aFab;6SI(4;C$ z{$$uD&RybX;eD_f{EoBXxY{XSRh+RrvzMdIwcruekNWB6r>w1NM?D;?E5C~P1NF6A zV&X&@VLT_|bmo0|2&VLbG1`Oj-is3;uxLRh7m=oKHuz0XcW zff$U2hNmYYPz2byK(z}5IGF9DP*Vh^Mo$xuxC-JLM=Oyw}B;l$^t%0wA$f8*MYN&l7TAin;(9#0chRXkN=D##%%n6mrud?EX@d(z0 zOEI9tg9tJU%t}!hD)vg7dOKn!dk;`8haDIxun>##w!9`agrIFBhStS}K8GY}#K`(~ zpheInSikyxD&Zj|^QK6V!{Z-Dp`l*=unpWIP1R3+RxuuCvVDAT0IvwAo|sM858O*%wediq0xkYBERc{4RXR@5B!A0uNx{42Y85^1S>h4C?t! z1ds4BaC`)X#)>MQ^|GA)g|sBsvp!bB70Xp9Jj-Ll5p_a%aNidB2{E~d{9QaF^K{Bb zra_G-@JZ!{&)H;c*G%#Q7$O0plJDD8HVfIwRXWe1NoSdDQ>N|XF|7-kpLwNFi@2?n zSk5w~7J*4(srJB^<=H}5pblikfm^Oo?1hRhI%!b&pbpBPhQ*B?vEAfe zf`L5NQBv0Gx+eTARX|l~Og<>kiduQ7p$c2a^^=yfZoq_+gdNPqaJ5;jajM~rwMwuF z4tT0wS-+Eb|3Xq_TAUEIn|{umR&2>P*qVnCak~LOkp-naJ}o*;B@>$%v@;Xn$apAg zaEw@p>ZKuO6ib4ZsYoJp!|GEqoqsJ8)$zM3&fO=k8C^ZZ>s1@j>8`RXzC7A1RCYnx z;xs{3_wpZlU0M(IN&yOZ_`moTfDuS}tBZ6#N^w5H=j)co$4l1WbqgJO75*#GWYD;F zpqRx4ENtZ92S5&WjKPTlBqL0}bm>C@0JI21tb%d~Eb#O+J136E=|a?6$^VRSLp9SF zZQPlWhb?>_Z?LBmD*`K7y+*o&g7cv8sjdvaB8t9mW8nED@SCMgH>mNoPK$Lo3@AZVtPO;sdT+#;6^wfXibH}K-#*?&EfSez=3X~Tr889pMVw3ZvT>F3xO!;KjnH6PF=*mh1^js<+t@hb4iB!s&G#Q3t>G%=7Q>DEP%%iAGhJOS+R0Y+BG!@<*LImr&n6pQeo zPuV__h%%8*Du5%NjKLI4X6%pxKre@Yn(SIF5zz%oP!I!_fmL;wX)8<;J{iQ0<_$^95Brt*q#q zgT-znUH{7b#DIYc|H7e;F>h*Q8ATI|Do7@gw-AD+#X>U%%u?{waehL zG>nS^BbhUO`C@d1!B}EWYgbxsFf^#zkOX7#3WXI83_-;U>QX2v=}EwYIv(PLDoG9P z*&t?((@8(SU5E5*d*Wr5V$Vils@>h6c zs4%cyJ^& zZZC(VFJe4qm51p;G!g!p;vi{bQ3L`IDE(1%~NR0eA_WSCd zc8*jJQp-^eSiuoLbgVy<%FUeoqm7*S7il(19UjDLUM~*6Zx99P+NE)*S+Sy( z!y_CO*7=@!c~7wPIKdq=gR+Fr0J)COSRWMlawq10q?9irLslePW=?B-bItaJ+D2M@ zwpeK9SG-cdxK*fr%*8jebEe9Mte(Z5ly6Nqyo^;bIy(y4c>-#kImt~l3#tdtM8g1d z1|Gj0csyz#hjx|cEa7v?)nMm)I5{P25Ai`$)qr}C%Iby&sP#EO?GTF;Sqrp>VksP+ z$N&l&;O6~SA2n3P2Q4`$&Y?a5fKx*b?iglvdGMzyM{;CLY_t<}cHDZU#Zt-Gb&IE> z?hHEk1UYJQkO`j>LM_i8p+rucDlibk+4jLwSLfiXP|4v=8VM#aFf840#P)cQ^}6*O zp^<@9kFdt4%>oZG=B&L9NdaEO_Bk9cz;U*KpEb>p0g zqNkrU@ZAvU4pK`|`naJ(JB|4+xDe`5o{fZ?cMr%)ZwXouYK7u-VC}JS5xneWUJN{6 zVe%OPZRS28;ruk1ybDQS!pj_=#2=_6^Gl~GxHhG?0Kw-@lS~>qO^xp=y~C&FyH&Sn zVtHiK?iOqh=EuvbAr9EA5@fbj+o+ZbtvU7#yG59#S_%FL?e#JRT}H6VBFAucmtsVb zA1rtdRfjz^ITk+H$g#=?Hb=uDhe^7kHVuHBB;z^H5Sl9CtG$6zZad~J*Va^rtPGmX z$28JJgGOW2w`V9jQlexy+t>j);(tA*KE(@6tJYi-!2cpQB)yf{2z$r81 zwgH2|(7u*zEOBJ=iAgQfEO6V*o+5cwf@lEtdMNI-$gMoQxLmtk)a;qn=7;uC0%3_K z1ZEWifcuLN!+SA~eYc*XP5WjTAHsHrBb}|pxGT3x28aCw*+)QBCcePo{+ZD0wGVxE zkwHSP5`j^;5msk`LQTBw?3Zwr;fMJu3Iz%dtsMR z^st*Xt!d3<3r==16!`{4tF56dD7$fqXUNs|2GC9kpOE(wN^+)EO)`O&z=Z|TOislSDb)~c}6y+ z@|{pp+vX|sm6t-r+QrrjZN=AKpzUYD@(b8t^8)l4;%I)iO7oo5B6?&VfjL;&)PP0^ z@ojPSUA2(@m`!p5NPv}g1&t0Cu4CC&d)X5mP$_&-RxWTj;7=n--}vF8_Nmfx#gw|W zFVvqhepov5Fpsk`ve%gr(Bx}h2>#u zzEyvt`bDP+MnIyq*Qs00HPX3KiYLGOB3v3C40%}S6dD*92xEa7bg__qj{}1~&E`_s z6Ju%Et7I!|MY|m=eKd3#u%r8=vhp_(ys?A2pM;q|Mc3r!l=RBu#F~|4$bwb^^r1VG z9?)zG=cmjI$}`NFGMsDizvtU)tJ^zSyS=%5bA=y&$#Au~vbDYXjTMw3s08`O#@gz} z>iUfhgy*)FudZIpUi#oKKmS4NCI2~(FDISP&S$S*K+VIKF5-Ln8zMkD!zP-Bk^=xBvXZ7}Sw(-u2ebPqn?`*BUy|Qt~-oCSb zJ$bhBwaw-A?bVI-Y-{D_owenyYGHdi}Z9ziJw&?0_%*SSuOlIsDo@ zRQb|xgpmxmGp#Sb(E54Js{35)pFh|7@6(6O!`u4t{PV3ZKW_-}QRiXIoo7)11R~W8 zt|9sC>eBfyg{#-zU=X75zc+L@nbY&F&pp=yY=1HxFn>?4HvrZ+7;aY4fwg*}^()V{ z)}L$rJr3#9n)SAgDrEl5bFEvae7j-MCs9`kfKN0MS8WB#menhNFOu>p5qnYHBnvWu zn9I>_hBtnUKP%+_8JQmEvr|z5-~L4Fr(27yA2Uk<p-Xgy(R2u)hHO2;*n_J7bD{ax$e5LJYtnE7Nm5%C2l{7-=;MN#3jDicoM#_2&Zd^K2FyVLzi&QqJhe!W;L!X z*^FhVv?T(jEE(GJzvrMqTCKNu`8V(vX}wmfI7u)_EFG;Sy#EbL^=}k}O z>rdi4!V=#RC9;<*-c~*F&P~7LBmOdP@X4?G6R8nOqZj;+xBVI3VB0UIPY7AY8=Sx< zFH%l;kvI6{d%Q@We401d+hty)bB!|+qWFXzsO`(VNZUr3zLY*8Ot10=U;GPR_{f}; z5XIH_<*BUp*Pz8ZK{uH*lbB?P5;ecbS9tNqd^<%}B*mA~Cq&k-^9GUie|h1^;!h!q zq(2>5Z1Lh$bWZI4YY|kn)S z!I&SyiU^RfyU7dlH~EnB`Ym1%*-&swca5=Ym zgB17sycnZ6LOWf2O>H5H^QDMnJoS}GBNK<6-08)s>&sy$wy1PU+h{f%vs+X;C6ePh zpWv4n>l_tfWX^e)w~|;yXOuq6_5LDjM``V{IX)5m>_w|iy7{{IqDQrq5!2v-|iAhjmf%LmHMCib#wCIWp>hAcz&Vl=;!PIG4PwqctvDWI3@AnQ*b* zHp1|Q^a+{J4Tv)m8tS1=h0|3WF+8!wWO?=_2Sjwk8Q=3eKEVj|IO6`Uw~cSN{f@t_ zl_xUB`i+P?Uw%qNP}^v4iA)KprY)@)K>jt(!I4WkiY=BVb@m}zaLLP1 zlaKq%hY?ARO^>7^+V^n@jjl=8{}O+j<@l065%g@k?01|yqUHD1^a&~bE4;xMFYv+< z%Nvn91QT%(1=(-2E$?{$VtkIg#(U|L$bDJ`KG7I#d$ry+j<}mXVc);W8w5%jl~Y3b zxA{^Ei%6d%Ya;2BII{ZpCmeZ!op9t;UZf+(z|}i^!gpdXa(%p)3NF9qZHYPdFZIbL zzso1yKYt2gY%)>YK8qG|cR30HV#rpuBLRAw_r?Gs4u60Ek3eQ06DRc&ht)~}Ai@zj zK%v7%td3LY4fevek!H1i>D!t#siDFX95Hgs7w}7kf})=^OrNkPMI`z1fKSHIMhK@% zf3`S3RfMs{!lV{2;UN%a|3>ne`ij=#bS)-=el8uB(-&9p;w?TI!vk+jpCwyN98Mrl zZSf+9<)mU${>oS4jUS-**vG^iTn+gsko`-^kaqVR2vMvj&Y;~oChYz3Bn!;}c;2A>elf6WVrlP%O81<;>P z;LT!sYpteJ&4d~2gNiLd*OO1W5xB-O8R>7h9nM0{&oD-jN+`L z-+;c2lC>rr2|d^y8TPybrCqzj8yq3x0SsXy@UH0U&-{+Jjblr(vR^*o3=}-!i<`Wc z&LF-MB|}`LD{Sk%@Z~t$SN%zRd(5hdaKGhk9m_RsKFW2-&y$e&E#jtsQtZO4%L zAJZpXM#)bC^bVg;au7QL@ppNVV&?zUZ-}(g7Qd6WAR?nEdTEj=&K^U=#bO07iM|_y}!ioMNZ*Y(UUN~-XIpnC!e?3mIKDgD)7cT^PC$m zl#k{G0-!b39l`sDcx=$um3fr2;K){sMu+Cl{vwKE!o$%y1x5de-SBPx6@me1b?gY$ z_4Emm_AhvY!|EbIS_6(^FX#D^MhkO`Poi;0xY@txoc+s$N&AlkGG=N_A;mxPk>iM0 z{mvMszTi(HR^y$qw&R2s&B=(>xNiP-6bWzpNd6?wU`!-vX$VlANR3TN^1oK^Ev|hf zNW@OW-+X5b3lTpR>=L-KKMn5Zq3m z5Q0~DgX^Ft4gtl1kifxyb*828ELyxWX_SgBK}h3d#>pTeIGVCw!3#nKTq;|h$!Lqr z=0p?`I!+K#dtl|P-yI*x-;N}r8E`qI0f<}iMY=$dQGPS+g$wjK-oUia2nJsu;vtHz zx7Z}@?bEzLGW;*R;FE~6cl?e+8Aq;&Q;xjNrW{E9H;()}Y?6)~#~ELnuXx+2(k}WP zhb7{h!&mx^xEy;Y!vE{(JM19i4Z<%PclaY|6T<0++l;*}*!V;MlcyHhDs3B) zu$ev~K*B8tk@~10;VRpXA%W{Z(To--Y%#GwTk|0jVpGnCK*t-;ymyWniAl6f+(c5m zj$bO+illhnpTxJn%GMOH_|6upKtR9Cm@5)SA#bqBgX#K zEx9b-aVTT|arRNd{W02W_7NXTe#hSy;c|(-QhzdKj<>z7aKg9ww}R(LmA{rg;b<@M z1}FJ%dEv8;R6_chP9;-YXg+M=6O;kN;kJ11V;wG{(MPE)^>^YDjD>Um37Zl)Nz??|GwXbk+^EL*_{whDB5E^Ye75-fSX&4YzVZ<;a?)Sh z!qO=e@NJ?wrIttmQ2<2dyH#%+X<|&IMVc5h^gho{xWNC57fu2kLjz7_y4fu%Z27Tt zO3U-LjW+yyQ#&gBRXQMb1nYZ-o70ZJ`C?D8dpMR>Wjq zc$}>w;$CGdqA6M!eZS*xM~f?}q1fMQy=`PBy~KVwzL-fv`hxIoWTxwEl0J$3XXz6z z;>*0jm;XI4d=dF>WR>YlL>x|R!4aAR%@6sc5kxH-pG3LzWp5krEchKqDWMQjj_Xe% z0yQ7@t4Y!_i6|8uyfcRWxU9dO_RDFh;**H`KA-&6Auft!pL(RGShW#X`?m;MisUKC zI9G2Qd+DT4ICVKsocjOflg6ok2ISLNNg1hXVhd>vt!H4iKTJpAXt9skR`EnJAN!cN z!$L8;6b=apQprCiKq*=ys>W$IE{X=EaFiV3+wo5H;^Q64`pO7#;V#slL<+r8f1=(J OF#q(e7yjq>p8h{FX08JO literal 0 HcmV?d00001 diff --git a/internal/test/GC/HAND-AUX/DANCER10-C0.DISPLAYFONT b/internal/test/GC/HAND-AUX/DANCER10-C0.DISPLAYFONT new file mode 100644 index 0000000000000000000000000000000000000000..f7a00dde5ff63eb06866450e3c1bb61c9c6ae422 GIT binary patch literal 7040 zcmeI0Ux-}Q9mjt&_sls<O(8WjGx~*b7t>7Gi4Ja z;zRD`JNN$noZs(z&iS2lW@cteO4aKZZrb_nA4>jeH%n6bsC2v2&5E4&OnI%mCMB7A z`6;I>^I4ZhL7qmFw-@BWpy(gTCE_)5?PEFQbIHR8F$&i?xiB1ZZahBoc=&p&kJ=k4 zi{TDe1vxnbS=*nfe?FhjUkT~ST#V-opW}RM|Fp-2D;GZ=kF%9E-*|sF^2hOGe(`)v z^3RXI+AF#K#r~VyOSCV}$7cLD%a?DTz^{51{Nj3u>p8ZcuAJZB>$&|}Ct&Gc|R}OoB4RI{nV&^%zraE%x7|W*YOD-fq#&zxBWT1x@WK_NVPm4cb*Pq&7YUGzwUf2_;2h_nB|Mu@5A_n@h{37-v^X`{yb0EJ7T$p zCbZZ3$bX-R>m|g~ZjP?pe&lrLpT{=x^LU&L7)-{^I!;pNE^t)v@#Q^y9_j7xPtqRqk+kS$7eCO|n-a|CqnY z@lE(GRLjX4FZPe+eEUiMdAmRVi~M7LdH*<`>t(JU!hRk4AKOn?4*RvnYjTgt;r!x! zQ6HehYpNo&tXa&w=N` zpTJ*023`Sw18d+-@HXg!_rMA8AMoE{u9Gnrk%T=f*#a&Emw?N_RbT;p58MoX0)7U5 z4(L;I54acH4=i{DJPMu!PlF@iMQ{|n7U#^%*x{V~6Z{*%HK7&^)oP}|1$o~u(>vT+ zfEqPdfF0l(a2>b-d>{M({0Q7Si8uP&RnKz|xC{IO><143YQazo=GTC6HIDd;+yd?Z z`@ntR05}NXSa}c}2GnciH{f@Gxv#*jLTy%F0k4C%Onp`!l2uueCA(^O+C?$bBMthU zShwhAH>T}LOH6%A=4H1{ZD!x)rZt*HdDr&Q?6zOC^I{rpIS_ITBbtVhxmX92MOn2g z7A7vQsSl)h8 zGv#%s&v@@ihQ~T>j%XC}tr2J0>GY{OZ}qx1EoX*SWuVp;H*aOW9 zM~QZ7@qMuLRr_Y@9p)yC{6o?~Gmxd+J)j<9O-E+&o6lO^wA<%SyRGhgW*QwLMQwdF zyOeR;CG4g-?v;y|_Iv$an!0%7OvbCEZW+szUd{3)p(^|}W3(pp_Lr$?%`2-_xsJY? z=^0mzUZXYdve&lRcBZ}QWixi0HI0kWM=k4huc0rinTypddX1vhtK#C(m)^RIS8vK9 zwVvZq--x~w8_XM?*!>{vw6GC z?SN9d{Z7NaMKo4Dt*1z?gPS=;SCK`tkaq-m8zpY_6 zNm$JXko+oA@8hf@@>X#M%(nOOZsntobDUO=|Gy4PgT5Kt8#X?N z!yciljZ;a_Gj_-Ch_1)O@>fPNLvu?0B@1?evunZbVI7!8Le<}C!y0v~!Fg$1jl9R5 wj76{aiKgdlhkIkCy0&nDlU>SItmD);MDD}xK1wzDy^?h+DXX^6>eY4nDca&a&Hw-a literal 0 HcmV?d00001 diff --git a/internal/test/GC/HAND-AUX/Dancer12-C0.DisplayFont b/internal/test/GC/HAND-AUX/Dancer12-C0.DisplayFont new file mode 100644 index 0000000000000000000000000000000000000000..9ae49c751fe37a72c7d2c35827c1842269966cfd GIT binary patch literal 3662 zcmeH}J7{E87{|Z4bLMd~Gno-m1X(6&geVrXDA>egeBo9Wi-m>7U<4N*Fm5#qOFYFC zB4QOG#TFt#aV-SVZi^G&Sgj(qP9dVj%0y7M$a?*K=gz%z?@hA!*urAZ$N$d#Ugvw9 z$DK}7r26PXPdxJ2S;>xGL!@+}^p2M;i`3e|)!?d>Wbxo#FDvs5rIF(sNV57IA4OXZ2P%>t(5BXQy_~TiTBj)y?~1u+Q@9pY2CcuY6YjckHwCSMk?~ zNj~bI@AuJsvidUi^^E^<`PFW!=Tg-E+`@ij>kG&)ylMQS_4$5gSB&*4&G`8KWIt!e zzt}I?`@O}D-OkLvkmaKra0}^uuVy(tyy_Ew)pw5gcT#`NU*paDoj;#NeU;s7pz@XH zb?S5^`6q(f=)2_A|0epRUrBz-H(8OCkN$+4fB)23^?CnhYOnfs&i{tzlKJBAUFQ3U zeXhT(RU^}%0N(dQe#7#RuXP%wR4B$^k=_&9ucm_NNUIORA2yBD# zaU~#sP38Q)0p0|cz}w(G@B#Q3Tmheg&%xK=8}L2&0sI7h1;2wEA^|skz}+9*0rufVr}T!LS~AHtRe z9dIYO3lO`!Zo&=Ol6~uk+n;PrHk@f>WOmGYw)_$Kwv41FCR~xzcHsJcOx%He z#mio{6Bi2y?zCMI)9T6gJer?*18JH0x8UNT@sMg>`*gUlln%v| zfaz10m5W}tihNDZP_;2yuac=B$}*Mp$!3)|e8{PerOM!HNd(P?Owh*Bm#{Lmb$J*% zE9d2tSrpaYFHg#=*!Fp97x#R1+9hUGs$QJMk8?9bo{&LLI~X>7Z}eSz6GLi_DSSyKTnY}3&%;j($x%FE7v>qPJLLPLPOp< z^_A;pp^3ID$N8l(hIRxEH5xHGCwmkkEl%6h_Hc0)sddd~ETZ$o&uh+vku8#GSyoBc zRXd@dXWH5~W*}2&Ao0kZ)#OYxi)VF%({oDa3EOtr^#+qwrQu-NwXJE!l^pd+=bqT9 zopKN88El_qJ*zsbx#nQGH#{}%PP?P^=Ah@>Fu5#6RMS<}eg8w2i* T$X9DxLy6>o+oSJCe0%%_RuB3y literal 0 HcmV?d00001 diff --git a/internal/test/GC/HAND-AUX/dancer10-C0.WD b/internal/test/GC/HAND-AUX/dancer10-C0.WD new file mode 100644 index 0000000000000000000000000000000000000000..89a315838dc1eab3721783c49243ff19f1460c62 GIT binary patch literal 554 zcmWgOVPIr)arAR`4PrnB4xEe(j6WIU!D3=S@;?J3gXI6SjHQe@4h)QCsIY;7dJx$a z2sXle2B2N!0FW-2DPY%EAp8I|FOIQ{VK<6g1tS!~bV6u^P6!KCmNFi8zah+I7!dz6 GFaQAa>R4$2 literal 0 HcmV?d00001 diff --git a/internal/test/GC/HAND-AUX/dancer12-c0.wd b/internal/test/GC/HAND-AUX/dancer12-c0.wd new file mode 100644 index 0000000000000000000000000000000000000000..87a92132c0ae40cc201dffcbfe2ca6190c077df7 GIT binary patch literal 298 zcmWgOVPIr)arAR`4PrnB4xEe(jFpVbz+z%RvYvsFLFxZd##Y8w2L{H2sIY;7dJx$a m2sXle2B2N!0FW-2DPY$hM)(10UIF7lhKDF}hZ&)efdK%(a5ftN literal 0 HcmV?d00001 diff --git a/internal/test/GC/Hand/DANCEROBJ b/internal/test/GC/Hand/DANCEROBJ new file mode 100644 index 00000000..064266c6 --- /dev/null +++ b/internal/test/GC/Hand/DANCEROBJ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Apr-88 05:11:42" {DSK}DANCEROBJ.;15 84031 changes to%: (VARS DANCEROBJCOMS) (FNS DANCEROBJ.GETFN2 DANCEROBJ.PUTFN DANCEROBJ.INIT DANCEROBJ.DISPLAY-AUX-LINES DANCEROBJ.DISPLAYFN DANCEROBJ.EDIT DANCEROBJ.CREATEBUTTONFN DANCEROBJ.MAKEFMDESC DANCER-Y DANCER-X DANCEROBJ.CREATE DANCEROBJ.MAKEMENU DANCEROBJ.Y-SCALED-CURVE DANCEROBJ.X-SCALED-POLY DANCEROBJ.BOTH-SCALED-POLY DANCEROBJ.COMPUTE-AUXLINE-EXTENSIONS DANCEROBJ.X-SCALED-CURVE DANCEROBJ.BOTH-SCALED-CURVE) previous date%: "14-Apr-88 02:46:03" {DSK}DANCEROBJ.;10) (* " Copyright (c) 1985, 1986, 1987, 1988, 1900 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DANCEROBJCOMS) (RPAQQ DANCEROBJCOMS ((FILES FREEMENU) (FNS DANCERMENU.CLOSEFN DANCEROBJ.CREATE DANCEROBJ.DISPLAYFN DANCEROBJ.IMAGEBOXFN DANCEROBJ.GETFN DANCEROBJ.GETFN2 DANCEROBJ.PUTFN DANCEROBJ.BUTTONEVENTINFN DANCEROBJ.COPYFN DANCEROBJ.INIT DANCEROBJ.INITFORMATIONINFO) (FNS DANCEROBJ.MAKEMENU DANCEROBJ.EDIT DANCEROBJ.MAKETERMTABLE DANCEROBJ.CREATEBUTTONFN DANCEROBJ.FACEBUTTONFN DANCEROBJ.MAKEFMDESC DANCEROBJ.SORTLOCS DANCEROBJ.ROT90 DANCEROBJ.COMPOUND) (COMS (* ; "Auxiliary Line functions") (FNS DANCER-Y DANCER-X DANCEROBJ.COMPUTE-AUXLINE-EXTENSIONS IAVG) (FNS DANCEROBJ.X-SCALED-CURVE DANCEROBJ.Y-SCALED-CURVE DANCEROBJ.BOTH-SCALED-CURVE DANCEROBJ.DISPLAY-AUX-LINES) (FNS DANCEROBJ.X-SCALED-POLY DANCEROBJ.BOTH-SCALED-POLY) (* ;; "Knots for semi-circles (actually 30%% ellipses)") (VARS DANCEROBJ.TOP-KNOTS DANCEROBJ.BOT-KNOTS DANCEROBJ.L-KNOTS DANCEROBJ.R-KNOTS) (* ;; "1/4 circle & ellipse quadrant knots") (VARS DANCEROBJ.LU-KNOTS DANCEROBJ.LB-KNOTS DANCEROBJ.RU-KNOTS DANCEROBJ.RB-KNOTS) (RECORDS DANCER-AUX-LINE)) (VARS (*DANCER-FONT-SIZE* 12) (DANCEROBJ.MENU) (DANCEROBJ.FORMATIONINFO) (DANCEROBJ.FMDESC) (DANCEROBJ.TERMTABLE (DANCEROBJ.MAKETERMTABLE)) DANCEROBJ.INITIAL.FORMATION.INFO) (ADDVARS (IMAGEOBJGETFNS (DANCEROBJ.GETFN)) (IMAGEOBJGETFNS (DANCEROBJ.GETFN2))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DANCEROBJ.INIT))) (RECORDS FORMATION))) (FILESLOAD FREEMENU) (DEFINEQ (DANCERMENU.CLOSEFN [LAMBDA (W) (* jds "22-Apr-86 16:30") (* CLOSE a TEdit menu window%: Detach the menu, then reshape the remaining  windows to take up the remaining space) (PROG ((MAINW (WINDOWPROP W 'MAINWINDOW)) TEXTOBJ HEIGHT OHEIGHT OBOTTOM WBOTTOM WINDOWS) (DETACHWINDOW W) (* So detach this window.) (COND ((IGREATERP (FLENGTH (ATTACHEDWINDOWS MAINW)) 1) [SETQ OHEIGHT (fetch HEIGHT of (WINDOWPROP W 'REGION] [SETQ OBOTTOM (fetch BOTTOM of (WINDOWPROP W 'REGION] (CLOSEW W) [SETQ WINDOWS (SORT (ATTACHEDWINDOWS MAINW) (FUNCTION (LAMBDA (WW) (fetch BOTTOM of (WINDOWPROP WW 'REGION] (for WW in WINDOWS when (IGEQ [SETQ WBOTTOM (fetch BOTTOM of (WINDOWPROP WW 'REGION] OBOTTOM) do (MOVEW WW (fetch LEFT of (WINDOWPROP WW 'REGION)) (IDIFFERENCE WBOTTOM OHEIGHT]) (DANCEROBJ.CREATE [LAMBDA (FORMATION FACINGDIRS IDS LINES) (* ; "Edited 16-Apr-88 18:18 by ") (* ;; "RETURNS an image object representing the square dance formation FORMATION, with the dancers facing in FACINGDIRS, and labelled with IDS.") (* ;; "ALSO with auxiliary lines described in LINES.") (PROG ((OBJ (IMAGEOBJCREATE NIL DANCERIMAGEFNS))) (IMAGEOBJPROP OBJ 'FORMATION FORMATION) (IMAGEOBJPROP OBJ 'FACING FACINGDIRS) (IMAGEOBJPROP OBJ 'IDS IDS) (IMAGEOBJPROP OBJ 'LINES LINES) (RETURN OBJ]) (DANCEROBJ.DISPLAYFN [LAMBDA (IMAGEOBJ IMAGE.STREAM) (* ; "Edited 20-Apr-88 00:10 by ") (* ;; "Display a dancer diagram on some image stream") (LET* ((AUX-LINE-OFFSETS (DANCEROBJ.COMPUTE-AUXLINE-EXTENSIONS IMAGEOBJ IMAGE.STREAM)) (CURX (+ (CAR AUX-LINE-OFFSETS) (DSPXPOSITION NIL IMAGE.STREAM))) (CURY (+ (CADR AUX-LINE-OFFSETS) (DSPYPOSITION NIL IMAGE.STREAM))) (FONT (FONTCREATE 'DANCER *DANCER-FONT-SIZE* NIL NIL IMAGE.STREAM)) (FONTDESCENT (FONTPROP FONT 'DESCENT)) [SIZE (IMAX (CHARWIDTH (CHARCODE a) FONT) (FONTPROP FONT 'HEIGHT] (FORMATION (IMAGEOBJPROP IMAGEOBJ 'FORMATION)) (FINFO (LISTGET DANCEROBJ.FORMATIONINFO FORMATION)) (WIDTH (FIXR (FTIMES (fetch (FORMATION FWIDTH) of FINFO) SIZE))) (HEIGHT (FIXR (FTIMES (fetch (FORMATION FHEIGHT) of FINFO) SIZE))) (DANCER-LOCATIONS (fetch (FORMATION FLOCS) of FINFO)) (DANCER-FACING-DIRECTIONS (IMAGEOBJPROP IMAGEOBJ 'FACING)) (AUXILIARY-LINES (IMAGEOBJPROP IMAGEOBJ 'LINES)) (DANCER-IDS (IMAGEOBJPROP IMAGEOBJ 'IDS)) (IMAGEBOX (OR (IMAGEOBJPROP IMAGEOBJ 'BOUNDBOX) (DANCEROBJ.IMAGEBOXFN IMAGEOBJ IMAGE.STREAM))) (YDESC (IMINUS (fetch (IMAGEBOX YDESC) of IMAGEBOX))) (OFONT (DSPFONT NIL IMAGE.STREAM)) ID FACING) (RESETLST (RESETSAVE (SETTERMTABLE DANCEROBJ.TERMTABLE)) [RESETSAVE (DSPFONT FONT IMAGE.STREAM) '(AND (DSPFONT OLDVALUE IMAGE.STREAM] [for SPOT in DANCER-LOCATIONS do (* ;; "Run thru the spots in the formation, drawing each one in turn. Run thru every spot even if facing or ID info hasn't been provided for it.") (* ;; "(These can't be AS's, since one may run out before the other):") (SETQ FACING (pop DANCER-FACING-DIRECTIONS)) (SETQ ID (pop DANCER-IDS)) (* ;; "Print the dancer ID:") (MOVETO (IPLUS CURX (FIXR (FTIMES (fetch XCOORD of SPOT) SIZE))) (IPLUS CURY YDESC FONTDESCENT (FIXR (FTIMES (fetch YCOORD of SPOT) SIZE))) IMAGE.STREAM) (AND ID (PRIN1 ID IMAGE.STREAM)) (* ;; "Now print the dancer image (box or circle). The MOVETO is there because INTERPRESS streams do the wrong thing with 0-wide chars sometimes:") (MOVETO (IPLUS CURX (FIXR (FTIMES (fetch XCOORD of SPOT) SIZE))) (IPLUS CURY YDESC FONTDESCENT (FIXR (FTIMES (fetch YCOORD of SPOT) SIZE))) IMAGE.STREAM) (\OUTCHAR IMAGE.STREAM (SELECTQ (U-CASE FACING) (N (CHARCODE e)) (S (CHARCODE c)) (E (CHARCODE b)) (W (CHARCODE d)) (NS (CHARCODE g)) (EW (CHARCODE f)) ((P PH) (CHARCODE h)) ((-- NONE) (CHARCODE a)) ((R R-- RNONE) (CHARCODE o)) (RE (CHARCODE p)) (RW (CHARCODE r)) (RN (CHARCODE s)) (RS (CHARCODE q)) (REW (CHARCODE t)) (RNS (CHARCODE u)) (RNW (CHARCODE v)) (RNE (CHARCODE w)) (RSE (CHARCODE x)) (RSW (CHARCODE y)) (RNNE (CHARCODE ^A)) (RENE (CHARCODE ^B)) (RESE (CHARCODE ^C)) (RSSE (CHARCODE ^D)) (RSSW (CHARCODE ^E)) (RWSW (CHARCODE ^F)) (RWNW (CHARCODE ^G)) (RNNW (CHARCODE ^H)) ((X BLANK XX SP) (CHARCODE m)) (CHARCODE a] (DANCEROBJ.DISPLAY-AUX-LINES AUXILIARY-LINES IMAGE.STREAM DANCER-LOCATIONS SIZE CURX CURY FONTDESCENT YDESC]) (DANCEROBJ.IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* ; "Edited 14-Apr-88 02:19 by ") (* ;; "returns an imagebox describing the size of the dancer diagram") (PROG* ((AUX-LINE-OFFSETS (DANCEROBJ.COMPUTE-AUXLINE-EXTENSIONS IMAGEOBJ IMAGE.STREAM)) (FONT (FONTCREATE 'DANCER *DANCER-FONT-SIZE* NIL NIL IMAGE.STREAM)) [SIZE (IMAX (CHARWIDTH 97 FONT) (FONTPROP FONT 'HEIGHT] (FORMATION (IMAGEOBJPROP IMAGEOBJ 'FORMATION)) (FINFO (LISTGET DANCEROBJ.FORMATIONINFO FORMATION)) (WIDTH (+ (FIXR (FTIMES (fetch (FORMATION FWIDTH) of FINFO) SIZE)) (CAR AUX-LINE-OFFSETS) (CADDR AUX-LINE-OFFSETS))) (HEIGHT (+ (FIXR (FTIMES (fetch (FORMATION FHEIGHT) of FINFO) SIZE)) (CADR AUX-LINE-OFFSETS) (CADDDR AUX-LINE-OFFSETS))) (LINES (IMAGEOBJPROP IMAGEOBJ 'LINES)) VJUST HJUST) (RETURN (create IMAGEBOX XSIZE _ WIDTH YSIZE _ HEIGHT YDESC _ (SELECTQ VJUST (TOP 0) (BOT HEIGHT) (LRSH (IDIFFERENCE HEIGHT SIZE) 1)) XKERN _ (SELECTQ HJUST (RIGHT WIDTH) (CENTER (LRSH WIDTH 1)) 0]) (DANCEROBJ.GETFN [LAMBDA (STREAM) (* jds " 8-Dec-85 16:50") (* * Reads an imageobject that describes a formation of dancers) (PROG* ((FORMATION (\ATMIN STREAM)) (FACINGDIRECTIONS (\ARBIN STREAM)) (IDENTITIES (\ARBIN STREAM))) (RETURN (DANCEROBJ.CREATE FORMATION FACINGDIRECTIONS IDENTITIES]) (DANCEROBJ.GETFN2 [LAMBDA (STREAM) (* ; "Edited 20-Apr-88 02:52 by ") (* ;;; "Reads an imageobject that describes a formation of dancers") (PROG* ((FORMATION (\ATMIN STREAM)) (FACINGDIRECTIONS (\ARBIN STREAM)) (IDENTITIES (\ARBIN STREAM)) (LINES (\ARBIN STREAM))) (RETURN (DANCEROBJ.CREATE FORMATION FACINGDIRECTIONS IDENTITIES LINES]) (DANCEROBJ.PUTFN [LAMBDA (BMOBJ STREAM) (* ; "Edited 20-Apr-88 02:51 by ") (* ;;; "Put a description of a group of dancers into a file") (PROG* [(FORMATION (IMAGEOBJPROP BMOBJ 'FORMATION)) (FACINGDIRECTIONS (IMAGEOBJPROP BMOBJ 'FACING)) (IDENTITIES (IMAGEOBJPROP BMOBJ 'IDS)) (LINES (IMAGEOBJPROP BMOBJ 'LINES] (\ATMOUT STREAM FORMATION) (\ARBOUT STREAM FACINGDIRECTIONS) (\ARBOUT STREAM IDENTITIES) (\ARBOUT STREAM LINES]) (DANCEROBJ.BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOW) (* jds "18-Dec-85 18:17") (* * the user has pressed a button inside the DANCER object IMAGEOBJ.  Bring up a menu of DANCER edit operations.) (PROG* NIL (COND ([MENU (OR DANCEROBJ.MENU (SETQ DANCEROBJ.MENU (create MENU ITEMS _ '(Edit% Dancers] (DANCEROBJ.EDIT IMAGEOBJ) (RETURN 'CHANGED]) (DANCEROBJ.COPYFN [LAMBDA (IMAGEOBJ) (* jds "18-Dec-85 15:04") (* RETURNS an image object representing the square dance formation FORMATION,  with the dancers facing in FACINGDIRS, and labelled with IDS.) (PROG ((OBJ (IMAGEOBJCREATE NIL DANCERIMAGEFNS))) (IMAGEOBJPROP OBJ 'FORMATION (IMAGEOBJPROP IMAGEOBJ 'FORMATION)) (IMAGEOBJPROP OBJ 'FACING (IMAGEOBJPROP IMAGEOBJ 'FACING)) (IMAGEOBJPROP OBJ 'IDS (IMAGEOBJPROP IMAGEOBJ 'IDS)) (RETURN OBJ]) (DANCEROBJ.INIT [LAMBDA NIL (* ; "Edited 20-Apr-88 02:52 by ") (* ;; "Initialization for the DANCEROBJ imagefns vector.") (SETQ DANCERIMAGEFNS (IMAGEFNSCREATE (FUNCTION DANCEROBJ.DISPLAYFN) (FUNCTION DANCEROBJ.IMAGEBOXFN) (FUNCTION DANCEROBJ.PUTFN) (FUNCTION DANCEROBJ.GETFN2) (FUNCTION DANCEROBJ.COPYFN) (FUNCTION DANCEROBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) 'DANCEROBJ)) (SETQ DANCEROBJ.FORMATIONINFO NIL) (DANCEROBJ.INITFORMATIONINFO DANCEROBJ.INITIAL.FORMATION.INFO) (* ;  "Set up the intial formation info from the intial specs") (SETQ DANCEROBJ.FMDESC (DANCEROBJ.MAKEFMDESC]) (DANCEROBJ.INITFORMATIONINFO [LAMBDA (FORMATIONSPECS) (* jds "30-Dec-85 16:23") (* * Given a list of formation specs (as a PLIST)%, expand the definitions, and  add them to DANCEROBJ.FORMATIONINFO) (for NAME in FORMATIONSPECS by (CDDR NAME) as DESC in (CDR FORMATIONSPECS) by (CDDR DESC) do (SETQ DANCEROBJ.FORMATIONINFO (NCONC DANCEROBJ.FORMATIONINFO (LIST NAME (DANCEROBJ.COMPOUND DESC]) ) (DEFINEQ (DANCEROBJ.MAKEMENU [LAMBDA (MAINWINDOW) (* ; "Edited 16-Apr-88 18:11 by ") (* ;;; "Create a free menu to be used in creating and editing dancer objects") (PROG [(MAINW (OR MAINWINDOW (WHICHW] (DANCEROBJ.MAKEFMDESC) (SETQ DANCEROBJ.FREEMENU (FREEMENU DANCEROBJ.FMDESC "Dancer Diagram Menu")) (WINDOWPROP DANCEROBJ.FREEMENU 'MAINWINDOW MAINW) (WINDOWADDPROP DANCEROBJ.FREEMENU 'CLOSEFN (FUNCTION DANCERMENU.CLOSEFN)) (ATTACHWINDOW DANCEROBJ.FREEMENU (OR MAINW (WHICHW)) 'TOP 'JUSTIFY 'LOCALCLOSE]) (DANCEROBJ.EDIT [LAMBDA (OBJ) (* ; "Edited 20-Apr-88 00:31 by ") (* ;;; "Create a free menu to be used in creating and editing dancer objects") (PROG* ((FORMATION (IMAGEOBJPROP OBJ 'FORMATION)) (IDS (IMAGEOBJPROP OBJ 'IDS)) (FACING (IMAGEOBJPROP OBJ 'FACING)) (LINES (IMAGEOBJPROP OBJ 'LINES)) (DONEITEM (FM.GETITEM 'FINISHER NIL DANCEROBJ.FREEMENU)) (FORMATIONITEM (FM.GETITEM 'FORMATION NIL DANCEROBJ.FREEMENU)) (IDITEM (FM.GETITEM 'IDENT NIL DANCEROBJ.FREEMENU)) (FACINGITEM (FM.GETITEM 'FACE NIL DANCEROBJ.FREEMENU)) [IDSTRING (CONCATLIST (for ID in IDS join (LIST ID " "] [FACESTRING (CONCATLIST (for FACE in FACING join (LIST FACE " "] MENUSTATE) (while (LISTGET (FM.GETSTATE DANCEROBJ.FREEMENU) 'FINISHER) do (* ;  "Make sure the DONT toggle in the menu is turned off.") (FM.CHANGESTATE DONEITEM NIL DANCEROBJ.FREEMENU)) (FM.CHANGESTATE FORMATIONITEM FORMATION DANCEROBJ.FREEMENU) (* ;  "Fill in the formation, ID's, and facing directions in the menu from this object") (FM.CHANGESTATE IDITEM IDSTRING DANCEROBJ.FREEMENU) (FM.CHANGESTATE FACINGITEM FACESTRING DANCEROBJ.FREEMENU) (for LINE in (APPEND LINES '("" "" "" "" "" "")) as ID in '(Aux1 Aux2 Aux3 Aux4 Aux5 Aux6 Aux7 Aux8) do (FM.CHANGESTATE (FM.GETITEM ID NIL DANCEROBJ.FREEMENU) (MKSTRING LINE) DANCEROBJ.FREEMENU)) (SPAWN.MOUSE) (* ;  "Since we're the mouse process, need another one to fiddle the menu while we're waiting.") (until (LISTGET (FM.GETSTATE DANCEROBJ.FREEMENU) 'FINISHER) do (* ;  "Wait until the user claims to be finished in the menu") (DISMISS 250)) (SETQ MENUSTATE (FM.GETSTATE DANCEROBJ.FREEMENU)) (* ; "Find out what he did") (FM.CHANGESTATE DONEITEM NIL DANCEROBJ.FREEMENU) (IMAGEOBJPROP OBJ 'FORMATION (LISTGET MENUSTATE 'FORMATION)) (* ;  "Fill in the object's declarations from the menu's changes") [IMAGEOBJPROP OBJ 'IDS (READFILE (OPENSTRINGSTREAM (LISTGET MENUSTATE 'IDENT] [IMAGEOBJPROP OBJ 'FACING (READFILE (OPENSTRINGSTREAM (LISTGET MENUSTATE 'FACE] [IMAGEOBJPROP OBJ 'LINES (READFILE (OPENSTRINGSTREAM (CONCAT (LISTGET MENUSTATE 'Aux1) " " (LISTGET MENUSTATE 'Aux2) " " (LISTGET MENUSTATE 'Aux3) " " (LISTGET MENUSTATE 'Aux4) " " (LISTGET MENUSTATE 'Aux5) " " (LISTGET MENUSTATE 'Aux6) " " (LISTGET MENUSTATE 'Aux7) " " (LISTGET MENUSTATE 'Aux8] (IMAGEOBJPROP OBJ 'BITMAP NIL) (* ;  "And invalidate the image cache so it gets redisplayed") ]) (DANCEROBJ.MAKETERMTABLE [LAMBDA NIL (LET ((TTBL (COPYTERMTABLE \ORIGTERMTABLE))) (for I from 1 to 255 do (ECHOCHAR I 'REAL TTBL)) TTBL]) (DANCEROBJ.CREATEBUTTONFN [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 20-Apr-88 00:27 by ") (* ;;; "He hit the CREATE button. Create him an object.") (PROG* [(MENUSTATE (FM.GETSTATE MENU)) (FORMATION (LISTGET MENUSTATE 'FORMATION)) (IDSTREAM (OPENSTRINGSTREAM (LISTGET MENUSTATE 'IDENT) 'INPUT)) (IDS (READFILE IDSTREAM)) (FACESTREAM (OPENSTRINGSTREAM (LISTGET MENUSTATE 'FACE) 'INPUT)) (LINESTREAM (OPENSTRINGSTREAM (CONCAT (LISTGET MENUSTATE 'Aux1) " " (LISTGET MENUSTATE 'Aux2) " " (LISTGET MENUSTATE 'Aux3) " " (LISTGET MENUSTATE 'Aux4) " " (LISTGET MENUSTATE 'Aux5) " " (LISTGET MENUSTATE 'Aux6) " " (LISTGET MENUSTATE 'Aux7) " " (LISTGET MENUSTATE 'Aux8)) 'INPUT)) (LINES (READFILE LINESTREAM)) (FACE (READFILE FACESTREAM)) (MAINW (WINDOWPROP MENU 'MAINWINDOW] (CLOSEF? IDSTREAM) (CLOSEF? FACESTREAM) (CLOSEF? LINESTREAM) (TEDIT.INSERT.OBJECT (DANCEROBJ.CREATE FORMATION FACE IDS LINES) (TEXTSTREAM MAINW)) (TTY.PROCESS (WINDOWPROP MAINW 'PROCESS]) (DANCEROBJ.FACEBUTTONFN [LAMBDA (ITEM MENU BUTTON) (* jds "30-Dec-85 12:05") (* * He hit the CREATE button. Create him an object.) (PROG* [(MENUSTATE (FM.READSTATE MENU)) (FACEITEM (FM.ITEMFROMID MENU 'FACE)) (FACE (LISTGET MENUSTATE 'FACE] (PRINT (CONCAT FACE " " (FM.ITEMPROP ITEM 'ID)) PROMPTWINDOW) (FM.CHANGESTATE FACEITEM MENU (CONCAT FACE " " (FM.ITEMPROP ITEM 'ID]) (DANCEROBJ.MAKEFMDESC [LAMBDA NIL (* ; "Edited 20-Apr-88 00:27 by ") (* ;;; "Create the Free-menu description for future dancerobj menus") (SETQ DANCEROBJ.FMDESC `(((TYPE MOMENTARY LABEL CREATE FONT (MODERN 10 BOLD) ID CREATOR SELECTEDFN DANCEROBJ.CREATEBUTTONFN) (TYPE TOGGLE LABEL DONE FONT (MODERN 10 BOLD) ID FINISHER SELECTEDFN NILL) (TYPE STATE LABEL "Formation: " ID FORMATION MENUITEMS %, (for FORMATION in DANCEROBJ.FORMATIONINFO by (CDDR DANCEROBJ.FORMATIONINFO) collect FORMATION) LINKS (DISPLAY FRMN)) (TYPE DISPLAY ID FRMN LABEL "" BOX 1 MAXWIDTH 150)) ((TYPE EDITSTART LABEL ID's%: LINKS (EDIT IDENT)) (TYPE EDIT ID IDENT LABEL "")) ((TYPE EDITSTART LABEL "Facing: " LINKS (EDIT FACE)) (TYPE EDIT ID FACE LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux1)) (TYPE EDIT ID Aux1 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux2)) (TYPE EDIT ID Aux2 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux3)) (TYPE EDIT ID Aux3 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux4)) (TYPE EDIT ID Aux4 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux5)) (TYPE EDIT ID Aux5 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux6)) (TYPE EDIT ID Aux6 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux7)) (TYPE EDIT ID Aux7 LABEL "")) ((TYPE EDITSTART LABEL |Aux Line:| LINKS (EDIT Aux8)) (TYPE EDIT ID Aux8 LABEL ""]) (DANCEROBJ.SORTLOCS [LAMBDA (LOCLIST) (* jds "30-Dec-85 15:51") (* * Sort the locations of the dancers so they're numbered from bottom to top,  left to right) (SORT LOCLIST (FUNCTION (LAMBDA (LOC1 LOC2) (LET ((X1 (CAR LOC1)) (Y1 (CDR LOC1)) (X2 (CAR LOC2)) (Y2 (CDR LOC2))) (COND ((LESSP Y1 Y2) (* Sort first so that lower dancers  come first) T) ((EQP Y1 Y2) (* Then dancers on the same level are sorted left to right) (LESSP X1 X2]) (DANCEROBJ.ROT90 [LAMBDA (FORMATION) (* jds "31-Dec-85 10:09") (* * Rotate a formation by 90 degrees (doesn't preserve identifications!)) (LIST (CADR FORMATION) (CAR FORMATION) (DANCEROBJ.SORTLOCS (for LOC in (CADDR FORMATION) collect (CONS (CDR LOC) (CAR LOC]) (DANCEROBJ.COMPOUND [LAMBDA (FORMLIST) (* jds "31-Dec-85 10:09") (* * Given a formation info spec that is a compound of existing specs, create  the fully expanded form of the formation info.) (COND ((ATOM FORMLIST) (LISTGET DANCEROBJ.FORMATIONINFO FORMLIST)) ((NUMBERP (CAR FORMLIST)) (* This is a fully-qualified formation  info. Just use it) FORMLIST) (T (PROG* ((WIDTH 0) (HEIGHT 0) SIZE LOCS) (SELECTQ (CAR FORMLIST) (BESIDE [bind SUBFORM for FORM in (CDR FORMLIST) do (SETQ SUBFORM (DANCEROBJ.COMPOUND (LISTGET DANCEROBJ.FORMATIONINFO FORM))) [SETQ LOCS (APPEND LOCS (for LOC in (CADDR SUBFORM) collect (CONS (PLUS WIDTH (CAR LOC)) (CDR LOC] (add WIDTH (CAR SUBFORM)) (SETQ HEIGHT (MAX HEIGHT (CADR SUBFORM]) (ONTOP [bind SUBFORM for FORM in (CDR FORMLIST) do (SETQ SUBFORM (DANCEROBJ.COMPOUND (LISTGET DANCEROBJ.FORMATIONINFO FORM))) [SETQ LOCS (APPEND LOCS (for LOC in (CADDR SUBFORM) collect (CONS (CAR LOC) (PLUS HEIGHT (CDR LOC] (add HEIGHT (CADR SUBFORM)) (SETQ WIDTH (MAX WIDTH (CAR SUBFORM]) (ROTATE [RETURN (DANCEROBJ.ROT90 (DANCEROBJ.COMPOUND (CADR FORMLIST]) (SHOULDNT)) (RETURN (LIST WIDTH HEIGHT (DANCEROBJ.SORTLOCS LOCS]) ) (* ; "Auxiliary Line functions") (DEFINEQ (DANCER-Y [LAMBDA (DANCER# SPOTS TOP-BOT SIZE CURY YDESC) (* ; "Edited 20-Apr-88 00:36 by ") (LET [(BASE-Y (COND ((LISTP DANCER#) (IQUOTIENT [for D# in DANCER# sum (+ CURY YDESC (FIXR (FTIMES SIZE (fetch YCOORD of (CL:NTH (CL:1- D#) SPOTS] (FLENGTH DANCER#))) (T (+ CURY YDESC (FIXR (FTIMES SIZE (fetch YCOORD of (CL:NTH (CL:1- DANCER#) SPOTS] (SELECTQ TOP-BOT (BOTTOM BASE-Y) (TOP (+ BASE-Y SIZE)) (CENTER (+ BASE-Y (IQUOTIENT SIZE 2))) (HELP]) (DANCER-X [LAMBDA (DANCER# SPOTS LEFT-RT SIZE CURX) (* ; "Edited 20-Apr-88 00:35 by ") (* ;; " Given a dancer number, compute the X location of its LEFT_RT edge. If DANCER# is a list, compute the average such X coordinate.") (LET [(BASE-X (COND ((LISTP DANCER#) (IQUOTIENT [for D# in DANCER# sum (+ CURX (FIXR (FTIMES SIZE (fetch XCOORD of (CL:NTH (CL:1- D#) SPOTS] (FLENGTH DANCER#))) (T (+ CURX (FIXR (FTIMES SIZE (fetch XCOORD of (CL:NTH (CL:1- DANCER#) SPOTS] (SELECTQ LEFT-RT (LEFT BASE-X) (RIGHT (+ BASE-X SIZE)) (CENTER (+ BASE-X (IQUOTIENT SIZE 2))) (HELP]) (DANCEROBJ.COMPUTE-AUXLINE-EXTENSIONS [LAMBDA (IMAGEOBJ IMAGE.STREAM) (* ; "Edited 16-Apr-88 02:06 by ") (* ;; "Computes how much the aux lines add to the 4 sides of the image object, if any. Used to compute offsets for display, and imagebox correctiosn.") (* ;; "Returns a list of 4 values, representing the increments at the left bottom right and top edges, resp.") (LET* ((FONT (FONTCREATE 'DANCER *DANCER-FONT-SIZE* NIL NIL IMAGE.STREAM)) [SIZE (IMAX (CHARWIDTH 97 FONT) (FONTPROP FONT 'HEIGHT] (FORMATION (IMAGEOBJPROP IMAGEOBJ 'FORMATION)) (FINFO (LISTGET DANCEROBJ.FORMATIONINFO FORMATION)) (WIDTH (FIXR (FTIMES (fetch (FORMATION FWIDTH) of FINFO) SIZE))) (HEIGHT (FIXR (FTIMES (fetch (FORMATION FHEIGHT) of FINFO) SIZE))) (DANCER-LOCATIONS (fetch (FORMATION FLOCS) of FINFO)) (AUXILIARY-LINES (IMAGEOBJPROP IMAGEOBJ 'LINES)) (MAX-X WIDTH) (MIN-X 0) (MAX-Y HEIGHT) (MIN-Y 0)) (bind DANCER1 DANCER2 for AUX-LINE in AUXILIARY-LINES do (* ;; "Run thru the auxiliary lines we're to draw, and paint them.") (SETQ DANCER1 (fetch (DANCER-AUX-LINE DANCER1) of AUX-LINE)) (SETQ DANCER2 (fetch (DANCER-AUX-LINE DANCER2) of AUX-LINE)) (SETQ DASHING (fetch (DANCER-AUX-LINE DASHING) of AUX-LINE)) (SELECTQ (fetch (DANCER-AUX-LINE LINETYPE) of AUX-LINE) (TOP-SEMI [SETQ MAX-Y (IMAX MAX-Y (+ (IAVG (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE 0 0 ) (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE 0 0)) (IQUOTIENT (IABS (- (DANCER-X DANCER1 DANCER-LOCATIONS 'CENTER SIZE 0) (DANCER-X DANCER2 DANCER-LOCATIONS 'CENTER SIZE 0))) 3]) (BOT-SEMI [SETQ MIN-Y (IMIN MIN-Y (- (IAVG (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE 0 0) (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE 0 0)) (IQUOTIENT (IABS (- (DANCER-X DANCER1 DANCER-LOCATIONS 'CENTER SIZE 0) (DANCER-X DANCER2 DANCER-LOCATIONS 'CENTER SIZE 0))) 3]) (L-SEMI [SETQ MIN-X (IMIN MIN-X (- (IAVG (DANCER-X DANCER1 DANCER-LOCATIONS 'LEFT SIZE 0) (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE 0)) (IQUOTIENT (IABS (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'CENTER SIZE 0 0) (DANCER-Y DANCER2 DANCER-LOCATIONS 'CENTER SIZE 0 0))) 3]) (R-SEMI [SETQ MAX-X (IMAX MAX-X (+ (IAVG (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE 0) (DANCER-X DANCER2 DANCER-LOCATIONS 'RIGHT SIZE 0)) (IQUOTIENT (IABS (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'CENTER SIZE 0 0) (DANCER-Y DANCER2 DANCER-LOCATIONS 'CENTER SIZE 0 0))) 3]) (UL-ARC) (UR-ARC) (LL-ARC) (LR-ARC) (VLINE) (HLINE) (DRLINE) (URLINE) NIL)) (LIST (IABS MIN-X) (IABS MIN-Y) (- MAX-X WIDTH) (- MAX-Y HEIGHT]) (IAVG [LAMBDA (VAL1 VAL2) (IQUOTIENT (IPLUS VAL1 VAL2) 2]) ) (DEFINEQ (DANCEROBJ.X-SCALED-CURVE [LAMBDA (STREAM KNOTS X1 X2 Y) (* ; "Edited 16-Apr-88 02:14 by ") (* ;; "Draw a curve from KNOTS that runs from X1 to X2, and is based at Y.") (LET ((DX (IABS (- X1 X2))) (X0 (IMIN X1 X2))) (DRAWCURVE [for K in KNOTS collect (CONS [+ X0 (FIXR (FTIMES DX (CAR K] (+ Y (FIXR (FTIMES DX (CDR K] NIL (FIXR (DSPSCALE NIL STREAM)) NIL STREAM]) (DANCEROBJ.Y-SCALED-CURVE [LAMBDA (STREAM KNOTS Y1 Y2 X) (* ; "Edited 16-Apr-88 02:42 by ") (LET ((DY (IABS (- Y1 Y2))) (Y0 (IMIN Y1 Y2))) (DRAWCURVE [for K in KNOTS collect (CONS [+ X (FIXR (FTIMES DY (CAR K] (+ Y0 (FIXR (FTIMES DY (CDR K] NIL (FIXR (DSPSCALE NIL STREAM)) NIL STREAM]) (DANCEROBJ.BOTH-SCALED-CURVE [LAMBDA (STREAM KNOTS X1 Y1 X2 Y2) (* ; "Edited 16-Apr-88 02:16 by ") (LET ((DX (IABS (- X2 X1))) (DY (IABS (- Y2 Y1))) (X0 (IMIN X1 X2)) (Y0 (IMIN Y1 Y2))) (DRAWCURVE [for K in KNOTS collect (CONS [+ X0 (FIXR (FTIMES DX (CAR K] (+ Y0 (FIXR (FTIMES DY (CDR K] NIL (FIXR (DSPSCALE NIL STREAM)) NIL STREAM]) (DANCEROBJ.DISPLAY-AUX-LINES [LAMBDA (AUXILIARY-LINES IMAGE.STREAM DANCER-LOCATIONS SIZE CURX CURY FONTDESCENT YDESC) (* ; "Edited 20-Apr-88 02:35 by ") (* ;; "Display a dancer diagram on some image stream") (LET* [(SCALE (DSPSCALE NIL IMAGE.STREAM)) (LINE-BRUSH (IMAX 1 (FIXR SCALE] (bind DANCER1 DANCER2 DASHING for AUX-LINE in AUXILIARY-LINES do (* ;; "Run thru the auxiliary lines we're to draw, and paint them.") (SETQ DANCER1 (fetch (DANCER-AUX-LINE DANCER1) of AUX-LINE)) (SETQ DANCER2 (fetch (DANCER-AUX-LINE DANCER2) of AUX-LINE)) [SETQ DASHING (FOR SEGMENT IN (fetch (DANCER-AUX-LINE DASHING) of AUX-LINE) COLLECT (FIXR (FTIMES SEGMENT SCALE] (SELECTQ (fetch (DANCER-AUX-LINE LINETYPE) of AUX-LINE) (TOP-SEMI (DANCEROBJ.X-SCALED-CURVE IMAGE.STREAM DANCEROBJ.TOP-KNOTS (DANCER-X DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURX) (DANCER-X DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURX) (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC))) (ITOP-SEMI (DANCEROBJ.X-SCALED-CURVE IMAGE.STREAM DANCEROBJ.TOP-KNOTS (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (+ FONTDESCENT (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX)) (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) )) ((BOTTOM-SEMI BOT-SEMI) (DANCEROBJ.X-SCALED-CURVE IMAGE.STREAM DANCEROBJ.BOT-KNOTS (DANCER-X DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURX) (DANCER-X DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURX) (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC))) ((IBOTTOM-SEMI IBOT-SEMI) (DANCEROBJ.X-SCALED-CURVE IMAGE.STREAM DANCEROBJ.BOT-KNOTS (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (+ FONTDESCENT (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX)) (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC))) ((LEFT-SEMI L-SEMI) (DANCEROBJ.Y-SCALED-CURVE IMAGE.STREAM DANCEROBJ.L-KNOTS (DANCER-Y DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) (DANCER-Y DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) (DANCER-X DANCER1 DANCER-LOCATIONS 'LEFT SIZE CURX))) (IL-SEMI (DANCEROBJ.Y-SCALED-CURVE IMAGE.STREAM DANCEROBJ.L-KNOTS (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC ) FONTDESCENT) (+ FONTDESCENT (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC)) (+ FONTDESCENT (DANCER-X DANCER1 DANCER-LOCATIONS 'LEFT SIZE CURX)))) ((RIGHT-SEMI R-SEMI) (DANCEROBJ.Y-SCALED-CURVE IMAGE.STREAM DANCEROBJ.R-KNOTS (DANCER-Y DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) (DANCER-Y DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX))) (IR-SEMI (DANCEROBJ.Y-SCALED-CURVE IMAGE.STREAM DANCEROBJ.R-KNOTS (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC ) FONTDESCENT) (+ FONTDESCENT (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC)) (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT))) (UL-ARC (* ;; "ARCS ARE ALWAYS SPECIFIED CLOCKWISE!") (DANCEROBJ.BOTH-SCALED-POLY IMAGE.STREAM DANCEROBJ.LU-KNOTS (+ FONTDESCENT (DANCER-X DANCER1 DANCER-LOCATIONS 'LEFT SIZE CURX)) (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) FONTDESCENT) (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX) (- (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) FONTDESCENT))) (UR-ARC (DANCEROBJ.BOTH-SCALED-CURVE IMAGE.STREAM DANCEROBJ.RU-KNOTS (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) FONTDESCENT) (- (DANCER-X DANCER2 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (- (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) FONTDESCENT))) (LR-ARC (DANCEROBJ.BOTH-SCALED-CURVE IMAGE.STREAM DANCEROBJ.RB-KNOTS (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (+ (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) FONTDESCENT) (- (DANCER-X DANCER2 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (+ (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) FONTDESCENT))) (LL-ARC (DANCEROBJ.BOTH-SCALED-CURVE IMAGE.STREAM DANCEROBJ.LB-KNOTS (+ (DANCER-X DANCER1 DANCER-LOCATIONS 'LEFT SIZE CURX) FONTDESCENT) (+ (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) FONTDESCENT) (+ (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX) FONTDESCENT) (+ (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) FONTDESCENT))) (VLINE (* ;; "Draw a line DOWN from dancer 1 to 2.") (DRAWLINE (DANCER-X DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURX) (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) (DANCER-X DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURX) (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (IVLINE (* ;; "Draw a line DOWN from dancer 1 to 2--including the area inside the nose border.") (DRAWLINE (DANCER-X DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURX) (+ FONTDESCENT (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC)) (DANCER-X DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURX) (- (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) FONTDESCENT) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (HLINE (* ;; "Draw a line RIGHT from dancer 1 to 2") (DRAWLINE (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) (DANCER-Y DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX) (DANCER-Y DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (IHLINE (* ;; "Draw a line RIGHT from dancer 1 to 2") (DRAWLINE (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (DANCER-Y DANCER1 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) (+ FONTDESCENT (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX)) (DANCER-Y DANCER2 DANCER-LOCATIONS 'CENTER SIZE CURY YDESC) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (DRLINE (* ;; "Draw a line DOWN & RIGHT from dancer 1 to 2.") (DRAWLINE (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX) (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (IDRLINE (* ;; "Draw a line DOWN & RIGHT from dancer 1 to 2. to the edge of the pix.") (DRAWLINE (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (+ FONTDESCENT (DANCER-Y DANCER1 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC)) (+ FONTDESCENT (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX)) (- (DANCER-Y DANCER2 DANCER-LOCATIONS 'TOP SIZE CURY YDESC ) FONTDESCENT) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (URLINE (* ;; "Draw a line UP & RIGHT from dancer 1 to 2.") (DRAWLINE (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC) (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX) (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (IURLINE (* ;; "Draw a line UP & RIGHT from dancer 1 to 2.") (DRAWLINE (- (DANCER-X DANCER1 DANCER-LOCATIONS 'RIGHT SIZE CURX) FONTDESCENT) (- (DANCER-Y DANCER1 DANCER-LOCATIONS 'TOP SIZE CURY YDESC ) FONTDESCENT) (+ FONTDESCENT (DANCER-X DANCER2 DANCER-LOCATIONS 'LEFT SIZE CURX)) (+ FONTDESCENT (DANCER-Y DANCER2 DANCER-LOCATIONS 'BOTTOM SIZE CURY YDESC)) LINE-BRUSH 'PAINT IMAGE.STREAM NIL DASHING)) (HELP]) ) (DEFINEQ (DANCEROBJ.X-SCALED-POLY [LAMBDA (STREAM KNOTS X1 X2 Y0 DASHING) (* ; "Edited 16-Apr-88 12:32 by ") (* ;; "Draw a curve from KNOTS that runs from X1 to X2, and is based at Y.") (LET [(DX (IABS (- X1 X2))) (X0 (IMIN X1 X2)) (SCALED-DASHING (FOR LEN IN DASHING COLLECT (FIXR (FTIMES LEN (DSPSCALE NIL STREAM] (bind [X _ (+ X0 (FIXR (FTIMES DX (CAAR KNOTS] [Y _ (+ Y0 (FIXR (FTIMES DY (CDAR KNOTS] for K in (CDR KNOTS) do (DRAWLINE X Y [SETQ X (+ X0 (FIXR (FTIMES DX (CAR K] [SETQ Y (+ Y0 (FIXR (FTIMES DY (CDR K] (FIXR (DSPSCALE NIL STREAM)) 'PAINT STREAM NIL SCALED-DASHING)) (DRAWCURVE [for K in KNOTS collect (CONS [+ X0 (FIXR (FTIMES DX (CAR K] (+ Y (FIXR (FTIMES DX (CDR K] NIL (FIXR (DSPSCALE NIL STREAM)) NIL STREAM]) (DANCEROBJ.BOTH-SCALED-POLY [LAMBDA (STREAM KNOTS X1 Y1 X2 Y2 DASHING) (* ; "Edited 16-Apr-88 12:27 by ") (LET [(DX (IABS (- X1 X2))) (DY (IABS (- Y1 Y2))) (X0 (IMIN X1 X2)) (Y0 (IMIN Y1 Y2)) (SCALED-DASHING (for LEN in DASHING collect (FIXR (FTIMES LEN (DSPSCALE NIL STREAM] (bind [X _ (+ X0 (FIXR (FTIMES DX (CAAR KNOTS] [Y _ (+ Y0 (FIXR (FTIMES DY (CDAR KNOTS] for K in (CDR KNOTS) do (DRAWLINE X Y [SETQ X (+ X0 (FIXR (FTIMES DX (CAR K] [SETQ Y (+ Y0 (FIXR (FTIMES DY (CDR K] (FIXR (DSPSCALE NIL STREAM)) 'PAINT STREAM NIL SCALED-DASHING]) ) (* ;; "Knots for semi-circles (actually 30%% ellipses)") (RPAQQ DANCEROBJ.TOP-KNOTS ((8.940697E-8 . 2.1457673E-7) (0.030153751 . 0.10260624) (0.11697778 . 0.1928364) (0.24999994 . 0.25980768) (0.41317588 . 0.29544234) (0.586824 . 0.2954423) (0.74999994 . 0.2598076) (0.8830222 . 0.19283625) (0.9698462 . 0.10260604) (0.99999994 . 0.0))) (RPAQQ DANCEROBJ.BOT-KNOTS ((8.940697E-8 . -2.1457673E-7) (0.030153751 . -0.10260624) (0.11697778 . -0.1928364) (0.24999994 . -0.25980768) (0.41317588 . -0.29544234) (0.586824 . -0.2954423) (0.74999994 . -0.2598076) (0.8830222 . -0.19283625) (0.9698462 . -0.10260604) (0.99999994 . 0.0))) (RPAQQ DANCEROBJ.L-KNOTS ((-2.1457673E-7 . 8.940697E-8) (-0.10260624 . 0.030153751) (-0.1928364 . 0.11697778) (-0.25980768 . 0.24999994) (-0.29544234 . 0.41317588) (-0.2954423 . 0.586824) (-0.2598076 . 0.74999994) (-0.19283625 . 0.8830222) (-0.10260604 . 0.9698462) (0.0 . 0.99999994))) (RPAQQ DANCEROBJ.R-KNOTS ((2.1457673E-7 . 8.940697E-8) (0.10260624 . 0.030153751) (0.1928364 . 0.11697778) (0.25980768 . 0.24999994) (0.29544234 . 0.41317588) (0.2954423 . 0.586824) (0.2598076 . 0.74999994) (0.19283625 . 0.8830222) (0.10260604 . 0.9698462) (0.0 . 0.99999994))) (* ;; "1/4 circle & ellipse quadrant knots") (RPAQQ DANCEROBJ.LU-KNOTS ((1.7881393E-7 . -1.1920929E-7) (0.01519233 . 0.17364804) (0.060307562 . 0.34201998) (0.13397467 . 0.49999985) (0.23395562 . 0.6427874) (0.35721248 . 0.7660443) (0.5 . 0.86602527) (0.65797985 . 0.9396924) (0.8263518 . 0.98480755) (1.0 . 0.9999999))) (RPAQQ DANCEROBJ.LB-KNOTS ((1.7881393E-7 . 1.0000001) (0.01519233 . 0.82635194) (0.060307562 . 0.65798) (0.13397467 . 0.5000001) (0.23395562 . 0.3572126) (0.35721248 . 0.23395568) (0.5 . 0.13397473) (0.65797985 . 0.060307622) (0.8263518 . 0.015192449) (1.0 . 1.1920929E-7))) (RPAQQ DANCEROBJ.RU-KNOTS ((0.0 . 0.9999999) (0.17364818 . 0.98480755) (0.34202012 . 0.9396924) (0.49999997 . 0.86602527) (0.6427875 . 0.7660443) (0.7660444 . 0.6427874) (0.8660253 . 0.49999985) (0.93969244 . 0.34201998) (0.98480767 . 0.17364804) (0.9999998 . -1.1920929E-7))) (RPAQQ DANCEROBJ.RB-KNOTS ((0.0 . 1.1920929E-7) (0.17364818 . 0.015192449) (0.34202012 . 0.060307622) (0.49999997 . 0.13397473) (0.6427875 . 0.23395568) (0.7660444 . 0.3572126) (0.8660253 . 0.5000001) (0.93969244 . 0.65798) (0.98480767 . 0.82635194) (0.9999998 . 1.0000001))) (DECLARE%: EVAL@COMPILE (RECORD DANCER-AUX-LINE (LINETYPE DANCER1 DANCER2 DASHING)) ) (RPAQQ *DANCER-FONT-SIZE* 12) (RPAQQ DANCEROBJ.MENU NIL) (RPAQQ DANCEROBJ.FORMATIONINFO NIL) (RPAQQ DANCEROBJ.FMDESC NIL) (RPAQ DANCEROBJ.TERMTABLE (DANCEROBJ.MAKETERMTABLE)) (RPAQQ DANCEROBJ.INITIAL.FORMATION.INFO (DIAMOND (2 4 ((0.5 . 0) (0 . 1.5) (1 . 1.5) (0.5 . 3))) DIAMONDR90 (ROTATE DIAMOND) DIAMONDS (BESIDE DIAMOND DIAMOND) DIAMONDSR90 (ROTATE DIAMONDS) PPDIAMONDS (BESIDE DIAMONDR90 DIAMONDR90) PPDIAMONDSR90 (ROTATE PPDIAMONDS) O/R% Diamonds (6 2 ((0 . 0.5) (1 . 0.5) (2 . 0) (3 . 0) (2 . 1) (3 . 1) (4 . 0.5) (5 . 0.5))) |O/R Diamonds R90| (ROTATE O/R% Diamonds) T/Diamonds (BESIDE DIAMOND DIAMOND DIAMOND) |T/Diamonds R 90| (ROTATE T/Diamonds) DTHAR (4 4 ((0.5 . 0.5) (2.5 . 0.5) (1.1 . 1.1) (1.9 . 1.1) (1.1 . 1.9) (1.9 . 1.9) (0.5 . 2.5) (2.5 . 2.5))) RTHAR (4 4 ((1.5 . 0) (1.5 . 1) (0 . 1.5) (1 . 1.5) (2 . 1.5) (3 . 1.5) (1.5 . 2) (1.5 . 3))) THAR (5 5 ((2 . 0) (2 . 1) (0 . 2) (1 . 2) (3 . 2) (4 . 2) (2 . 3) (2 . 4))) HRGLASS (4 4 ((1.5 . 0) (0 . 0.75) (3 . 0.75) (1 . 1.5) (2 . 1.5) (0 . 2.25) (3 . 2.25) (1.5 . 3))) GALAXY (4 4 ((1.5 . 0) (1 . 1) (2 . 1) (0 . 1.5) (3 . 1.5) (1 . 2) (2 . 2) (1.5 . 3))) |1X4| (4 1 ((0 . 0) (1 . 0) (2 . 0) (3 . 0))) |4X1| (ROTATE |1X4|) |2X2| (2 2 ((0 . 0) (1 . 0) (0 . 1) (1 . 1))) |2X4| (4 2 ((0 . 0) (1 . 0) (2 . 0) (3 . 0) (0 . 1) (1 . 1) (2 . 1) (3 . 1))) |4X2| (ROTATE |2X4|) |1X8| (BESIDE |1X4| |1X4|) |8X1| (ROTATE |1X8|) |1X3| (3 1 ((0 . 0) (1 . 0) (2 . 0))) |3X1| (ROTATE |1X3|) |3X2| (BESIDE |3X1| |3X1|) |2X3| (ROTATE |3X2|) |3X4| (BESIDE |3X2| |3X2|) |4X3| (ROTATE |3X4|) |1X2| (2 1 ((0 . 0) (1 . 0))) |2X1| (ROTATE |1X2|) |2X6| (BESIDE |2X2| |2X2| |2X2|) |6X2| (ROTATE |2X6|) |2X5| (BESIDE |2X2| |2X2| |2X1|) |5X2| (ROTATE |2X5|) 1/4TAG (4 3 ((1 . 0) (2 . 0) (0 . 1) (1 . 1) (2 . 1) (3 . 1) (1 . 2) (2 . 2))) |1/4TAG R 90| (ROTATE 1/4TAG) O (4 4 ((1 . 0) (2 . 0) (0 . 1) (3 . 1) (0 . 2) (3 . 2) (1 . 3) (2 . 3))) BFLY (4 4 ((0 . 0) (3 . 0) (1 . 1) (2 . 1) (1 . 2) (2 . 2) (0 . 3) (3 . 3))) H (4 3 ((0 . 0) (3 . 0) (0 . 1) (1 . 1) (2 . 1) (3 . 1) (0 . 2) (3 . 2))) H% R90 (ROTATE H) LBLOX (4 4 ((1 . 0) (3 . 0) (0 . 1) (2 . 1) (1 . 2) (3 . 2) (0 . 3) (2 . 3))) RBLOX (4 4 ((0 . 0) (2 . 0) (1 . 1) (3 . 1) (0 . 2) (2 . 2) (1 . 3) (3 . 3))) SET (4 4 ((1 . 0) (2 . 0) (0 . 1) (3 . 1) (0 . 2) (3 . 2) (1 . 3) (2 . 3))) PHANT (4 4 ((0 . 0.5) (1 . 0.5) (2.5 . 0) (2.5 . 1) (0.5 . 2) (0.5 . 3) (2 . 2.5) (3 . 2.5))) VHPHANT (ROTATE PHANT) |Wv bet Vmw| (4 6 ((1.5 . 0) (1.5 . 1) (0 . 2.5) (1 . 2.5) (2 . 2.5) (3 . 2.5) (1.5 . 4) (1.5 . 5))) |Wv bet Vmw R 90| (ROTATE |Wv bet Vmw|) |Vdi bet Vmw| (2 7 ((0.5 . 0) (0.5 . 1) (0.5 . 2) (0 . 3) (1 . 3) (0.5 . 4) (0.5 . 5) (0.5 . 6))) |1-3-3-1| (3 4 ((1 . 0) (0 . 1) (1 . 1) (2 . 1) (0 . 2) (1 . 2) (2 . 2) (1 . 3))) 1-3-3-1% R90 (ROTATE |1-3-3-1|) |Ac Duc 1 1/2| (4 6 ((1.5 . 0) (1.5 . 1) (1.5 . 2) (0 . 2.5) (3 . 2.5) (1.5 . 3) (1.5 . 4) (1.5 . 5))) |1-2-2-2-1| (2 5 ((0.5 . 0) (0 . 1) (1 . 1) (0 . 2) (1 . 2) (0 . 3) (1 . 3) (0.5 . 4))) 1-2-2-2-1% horiz (ROTATE |1-2-2-2-1|) Star (2 2 ((0.5 . 0) (0 . 0.5) (1 . 0.5) (0.5 . 1))) |Single 1/4 Tag| (2 3 ((0.5 . 0) (0 . 1) (1 . 1) (0.5 . 2))) |Single 1/4 Tag R 90| (ROTATE |Single 1/4 Tag|) Triangle (2 2 ((0 . 0) (1 . 0) (0.5 . 1))) |Triangle R 90| (ROTATE Triangle) Wide% Tri (3 2 ((0 . 0) (2 . 0) (1 . 1))) |Wide Tri R 90| (ROTATE Wide% Tri) |L Exch 1/2| (5 4 ((2 . 0) (0 . 0.5) (1 . 0.5) (2 . 1) (2 . 2) (3 . 2.5) (4 . 2.5) (2 . 3))) |L Exch 1/2 R 90| (ROTATE |L Exch 1/2|) |R Exch 1/2| (5 4 ((2 . 0) (3 . 0.5) (4 . 0.5) (2 . 1) (2 . 2) (0 . 2.5) (1 . 2.5) (2 . 3))) |R Exch 1/2 R 90| (ROTATE |R Exch 1/2|))) (ADDTOVAR IMAGEOBJGETFNS (DANCEROBJ.GETFN)) (ADDTOVAR IMAGEOBJGETFNS (DANCEROBJ.GETFN2)) (DECLARE%: DONTEVAL@LOAD DOCOPY (DANCEROBJ.INIT) ) (DECLARE%: EVAL@COMPILE (RECORD FORMATION (FWIDTH FHEIGHT FLOCS)) ) (PUTPROPS DANCEROBJ COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1900)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3271 17590 (DANCERMENU.CLOSEFN 3281 . 4720) (DANCEROBJ.CREATE 4722 . 5329) ( DANCEROBJ.DISPLAYFN 5331 . 11414) (DANCEROBJ.IMAGEBOXFN 11416 . 13123) (DANCEROBJ.GETFN 13125 . 13541) (DANCEROBJ.GETFN2 13543 . 13990) (DANCEROBJ.PUTFN 13992 . 14550) (DANCEROBJ.BUTTONEVENTINFN 14552 . 15118) (DANCEROBJ.COPYFN 15120 . 15703) (DANCEROBJ.INIT 15705 . 17004) (DANCEROBJ.INITFORMATIONINFO 17006 . 17588)) (17591 32091 (DANCEROBJ.MAKEMENU 17601 . 18259) (DANCEROBJ.EDIT 18261 . 23323) ( DANCEROBJ.MAKETERMTABLE 23325 . 23506) (DANCEROBJ.CREATEBUTTONFN 23508 . 25460) ( DANCEROBJ.FACEBUTTONFN 25462 . 25975) (DANCEROBJ.MAKEFMDESC 25977 . 28359) (DANCEROBJ.SORTLOCS 28361 . 29324) (DANCEROBJ.ROT90 29326 . 29780) (DANCEROBJ.COMPOUND 29782 . 32089)) (32133 41125 (DANCER-Y 32143 . 33320) (DANCER-X 33322 . 34487) (DANCEROBJ.COMPUTE-AUXLINE-EXTENSIONS 34489 . 41042) (IAVG 41044 . 41123)) (41126 56907 (DANCEROBJ.X-SCALED-CURVE 41136 . 41697) (DANCEROBJ.Y-SCALED-CURVE 41699 . 42168) (DANCEROBJ.BOTH-SCALED-CURVE 42170 . 42703) (DANCEROBJ.DISPLAY-AUX-LINES 42705 . 56905)) ( 56908 58926 (DANCEROBJ.X-SCALED-POLY 56918 . 58074) (DANCEROBJ.BOTH-SCALED-POLY 58076 . 58924))))) STOP \ No newline at end of file diff --git a/internal/test/GC/Hand/DANCEROBJ.LCOM b/internal/test/GC/Hand/DANCEROBJ.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..6f1a3a31c9f1112470387d8972c9c2a43b00c498 GIT binary patch literal 28972 zcmchAeQab`mRG&9`y-Xa<8n;XbnP6mt9p|Wmna6s>)sVOtQvf zdt$qt?reX|B+$T2*aiMTLYY|xEog-@2qZva?IevRlbMuO`w#mE|DbMmLKYCKWs&#; zrip~mO3d&(=YG8Vs>+>A8qw+0yYGISd+xdC>z;e>>qMzssWr>9m0G<#TWeN)aek$^ zxLmwa7Spw6r`)R7+AGuIe5+h6b&3o1zU+l!yDZ$~Oe{eF7E!BHE{SO`Ia_@7=4?JM zl9|hH>T=qf7K!Pt8?U^&cd)Z9Zd@1B;;)q2%YXIH6L@Oc{)?qzbFtj=7nbI}o4!zx^P(pO(h0aMhWoi#q~*ZgMNslbJJpb^EM_t7M{(tcR8J$el*j# z%ruW=5|K|QQ?5{aAa36PDV|u)%xatkWfKY!(cIMqCNw6 zNQlQU2g{W`J3~0~SQhxyGieFHXJN;HCN_^StImj5Z|;13@5Y^5B1Rm6iJErPTE3HD zhwSBK>d`s@N=EiTk~p_m_uJ)4vzSaKU2(aTi6v?xDZ1Sm5qUZii8%95L?XX`GU|*+ z5-IUwt=V2}mAkcO$?wj@nzec?F$|gnv?B5VBvwRL$QEs+Gop)8b^Hd>Y2ll6O8C`s z?Mk(Sd{3C9D>{&1$P2QQqEW0hyMhq}e%FDTGyigg5RGr1BuuOLAAheseD`^Ucr@y~ zugCC1O7y6XZ1k(~_-TJ^p5r0I~(3nqM5qzZklynKH~QdH{Y z=9NxWxVZsHZc3EO1YCj!ts#^$z1l9fR$BfF^g|}AglcfkQiR=ak19CQmR2^(Ck$FR-@Q~(iIgHN^Yw)U<;u>FmZp*aU!F; zFVM6(kt*h59yF$BQ9T#bbCI6Jc?H4EfdCCiKv{*}y;S(!&4l06=2Z>}6iH>&FuWX( z!Y!yl2p7ZA_@kocZz71%Q6w%Y$>q&rqb%CB%a<>$Hi_=Dz_3$Z>|A1wZLjzpCJEPA zte1<;)s|;Csd`4h5Z3CoVryNR!x<4h=X@^WV1~O>kgMIPsokme)Yi!x&@kO| z#0bcujP98u=Ra*bV2h5^iEf?lZJq6P$DHn1bZe})HQwt^RGrp;1Bf4YC$FwnqcZ*D zAHM)b>2=4y+Z`uhkFNGY_bdQx1DT)vz23pjk+Y}MTSv}II{non=LMbKK61)B{qm7h z(CM!oIkTMpCpu^M$oU0MfBVS!oKBqN#J}KQQ}f1A03vU zf1}gCb`<$toxXh(xu?^2jw1g|r@wv_`E8y4#!=)=oqp{o@*AA~&ECQ5hp%(;JH2a% zH*{w7a9bxw4%c;Z^suRuCk_{N^5kJ&Cr=&9;REdH!)eZaXObWGV87Elc;$`W!6qi= zndr#9kvEQhD!S)i=$>hHC%TiXS7WCm5y*HZrPtS38T@=r5*2ol~%3kiURZ;^fqecv$8A)j-|>TbR&Fc$PNSr(q_1t z^d{7O8-}Wo7HexF4L^LLUTiKSnnVm`r%Jp2aQWYMsg24ru0M~_0LpN@&An=mS z2`ou68G)R1N}!{D>Y$xS6q_ZH&;<1BrK`pIYFX-ArPgLBS=Y|OwJIiX|lh1 zeKG4-DqvJ;dP4?;jIXwgP{rVvOHy6KO!{aY`ZeyHIM}SCF1@_BU3>UeuNHSs zYIn^!)lK?i&&8e7{lBW6oTXX{&}?f za6|MM(fAjh>3Z=moB@L90)L@vdU!zJc*z`mu*=M@ZP+QW6^Q}aX*RmjnjW|1uleXRC>hCW-K$w69V?bde+T=SIH65o{S5H5za{UXTTv0*8r=r;wlh# zL4iSBLlv^H*O+bPL!(DhnUW*Z@Nz6C0Xl(Rm7gaS;rfc-uCeb%vI0IZ?>5sMzpjDS zbfMV#=}3xX!C!5bNDkdJgc9=S8ZV4hH#?E!M;n%e>QjX5^Tc?-lBUW%%?0vD>kTP? zWDlhLkzi@36b_`8KS=;c{r2f-WK_!<3Dvj}s_4Py5~OJf%xk1+#0bJ@ccKnqI?-^JNtUWk6;f~? zVtTR>RasHWlbNSfyI#{D+a*8f-O>HOL(gyfW54c?Er0k&D!2K!Ik)*o-`t0THZ=vY zag%+%bza%rtTL-$u@E=HJX_odW)8TKlz6~?pPs#7jmXC>lOF)1$E!vcW&?{!HvJte z5!|Gw9Q?G+Pmmp{5c~LvBN@gbfjI#mQh-nnKn2Si?QIjkn8}m=J$vw&!(SXxt7bT{ zwBC$6yoM%?SzCgeN~%Y%#z_4t;e+vdvDjJwmjOkU!h*ZlY1Ep1D{X3}A}@;f^^%ON z#bcm;Ve~lEO-g5{@p2&vF)$*>BniXOtxHy9Z<{C_YOcn)$QMWVRS0HH7;3m8?@ zNJ_+{Oz6M~N=J%S2wAUK<6jcEUU3<}yO=eoRT>^#P=V#NNy^!x+%%29)1YK38x{i0 zct|MVpM>7Sui#DSJ-N!Jr7depy#|A4s})%v56h@&`6{t41y7lvv^rOzfj<4Dog88( z3JVaaqD~~*x|jM(k;pG?)8cG$v`7B@q>ztuz5VU$fBk3MtPJANDBHEkr+X7yqu}#* zpCBedWg?Z9GJ?%9yi8hfAF%}dQ)qzZ6@<6pX&`D|T&;JgtXi&@$V5_TgyI&B6%bn7 z9UY;<&iYFEi+3?#a=#Mg?Y-L6-}fpK8kRTx6C%-|b_+OO`QZ9+2(1r>gWgxU@O)K=)7oLRekNazCUk640&B6xTv za6zjdX+q)i8YUrvnU_9};qWZesse!t$7yIKf1Ifz7t$&tFtuVm@FeGyE2)h)v4ITU zgUP%I1QPTe{JYJ6kRKb1M7AQkThSI+>NL_PiPE-DWo-w*i3vgygo+t0V*yEGf?}pk z@CP(AO=x9-KxUnm4<>W2UzW_efrg@(%q#>bPbuWQ1w*Pe8*4^HdM!56Cag4MdcuP- zI+7zhr0zNVM3QYPwpYrF6t=N7v?(N#U=E%i1;fur=i}2OH7v=0!}&o~hC$!&EG>iP z5OA#!Au(%R&ZU%=bh38A*v^qz8MaC0LtL;v$ zvW~EVAXf#(LNXpHIvtQF&sW9fNlymEVjY+j(^C71(%$CFH#c7qjh*XvuoDz;Fsoff zcCa`?e(+=pY*i?gWqqvI+@vsyi)C0(gmI}DTB&5-uy$p=QtOl{Y!3~GO*>9ndPe1d z>kxcUFWQI^qbk)z?i8u5K@SR2M0zEpbQF~lKy>~LaV(}0^Gu$VP6c_E6-VK2_Y!6w zi%~0m!b+dC(x>9dr)!75uPcPyERVh(+9aGM*e; zI=q1N#)Loq`NKaB8l6R>se3K|?8do`DcR^8H;RvUFQEZCeD0mU(5NzEaJ|pSgg@q= zmnrIfS+R0_deVP(!=?Q}6I?XX9eepXOLvkp?W1i>C|=_?ERo3SN(CodWEE z)+w^wwsB9T?Is8r4mRoE+DIj#e8PjKI3ThxPDuohBAlUj3St(!%{lm{2rqg-v>yc2 zU%f~n5U8COiz^s+30fX{qrV~rANsn-#$jKUi$E!|3`TAqTMSG#8ApMN<=$LuzF7Hr zEYi6Z&sPpQBY2ZIo4M5Rx#nYg+iCdr3$;$8hyWbssCehKJR-Q9$RUEui7X=fO3ElWSx z*aXpMVu+A=3=TXEK(;|6<7#5_+QWx8&8DQ&S*XK$fO&ny157ozI@2RgB+`cdh<_n^ z@Uv?_cyDRD_VJt5ai~M`6nab7?tl64zhhCJ5#`0IPtgg0Ar~)z5=+1=LAL9C4w`f* z&1n^7ZS!iMnuESH@nkY3@hRZTDXC64-Ye}cX%~u1N!!RftGbTmzw=nhO^}jK0V&x# zN292KgApVZ82Z1)s7H!4bh*un2$4hEtk2wEGY zKb;V;N&v$kmLUCiNX4&0A!w;EyeQ=YLAoVk{Q2LDMBbeLTbu+Vp2W$JQRs>`F=egz zs4DEyL=uGoD+ymk%{s#MxCK2U8SXnw12qDQb=w=u{8f^vG!+Ga-;tZC2 zOgwm6FG83o;NQ?Y_6|euFaV)Eg|o#VdDi-47^#sE9#m(aOjDFk_vOXe2_DLH|R0$iJbN zcrx1lyW7t9Yxho7cc;Gmt?I@1qVU`Q$I=8Zt0q(sOjC66$`rjgS?cb7Y~J z!7)1109i_uWFOPhR2-Ds0H-UPTYJ}E#*wcOP@cVhm^`(g4Dv1n9>)!@?_9ncf{AQ* z08h$PV|x^ukAUe7gNZmjllL>iObvqxXXkNXriZ~yKOW4?FqrTL9tY3tFqoQMKO;SJ z!(iqf56}ECnDCFy*x~rW3Msx<;V=@7N~_T{)v&*VtwUJ5HMza#W|Dx5Ku$u*m~Kd| zPy!7%UAb}dmCf6GH?EV^(@M#jzl{9O~bK80f>WM;Quj(^*2qk=oW#&ALcH zB7Fqpa5}`T(@TwQDz%=oQi{0WD^hyR|0gJ_no57yc3@v zna3vO;ncSCmFTiF1$};+^!fU)<9Ge@6jk}JOB7V09SC3%iV5r9hYU=IDD|=dZc2M~ zfs7A%7Sh3H_nQceggS;tUWYk~ic_(?tE{o-r7VKvI(kP044JbT;dtW|wfgS-!D*2H zH@jl~x$$`?HU8%O_2${P@krH=FPIlhKXI!{3tqz8>^@;+ez0c5Js7x1EhK2M&7l{-gT+NcGD- z-hYp}NBnGK+@JXP+y3~s{E6?&-oFD2{*&LDk2)A0{*Ir9UsbKCz%$J&g){=8&=ZTj z4opndU#*uQt{xVkK^@6n9z4w;&&;|9r^Q4yT%6q+Qpbh5Fm>Px52=D(O)}h#VtaXR zwSsNggomXBdZvR*v~YzMp?EG9W#u+(y(IxSkFHjSke4rl!=PhudJWk%ED7a7%^E`X zd=Qh)*zz$@THgWUENyJlMjo9eZSx9GV)sP|&mM&5|DYCKKm3Sh=R4KK`{N6g`fhdcAo|gL znk38&?W<#_4oh12n{@hw*GiXh+yuwrf`iJc5H1tW*q{)kfb^?fdn`PNP6#l_1A&aRS=R9YY&U8d+ab=07}&GFVP%<(aL!vd<-1ouJ1!Tl|+$t0GN$mMf#InL!I){%opFvP}_Lm;Mwe-gR z(uW5lAKia{dl`rEmNzaQIWJ4~fF2S7fX~vy5BKX2->Sc{U#A`({Aj!J@XcOhBXQ)M zkUebn{AYt622l)+U>E`qKG<(Qe5?7!ev^CH80&5OV-LTLiy0fw9!36<>}3Z#29MXv z#&~bvAAk5gfBbLY$>f3o+x90Oey`_GY)l`fxu8LQAMX1JKu-XA;zJ-i^#F5w?g5{tfO5^4V>OV+3?x&kd3wR2;ac(P z6(qFvf}GM0h^m4Y*d0?pZFaNKI1Qc6jZ?;~qH)UDN_q);#tYPg0h>x9woE;z5YsX6 z1LF($p4q_!BoCU#H1-fQ=Efe5jhV(SOo4fUNe}Ib=wsPg3UfnKBDxkThl;b$lR?Rv z(~YcL^l?V$&MZRLtGIXx2R{pSR8mRA!>Te9w8Y6y6lV~qs<&o~twn^Tu-K`qWD@OV z5^?=il?&yp^mPV3sw5o|m%2L*^QKaWbhT#NVR_)!71S%!&8u9m4UT|xjhFL z2X`)&H`Ed^CyesFn_RAYf39#sx_r=H1&S{-l^r?sh7UBeDQ}^RQzFM zVt0EUS_s;Gcb@bUq!D(x)GBr*zMwU;BgKx}D|~$v5~^5~?Auyv$hxENE@9uG*VUkD zxVT`zgIL4y(duF9%$=XtWzg2#>drQw6e*b9+U4_BDR4`R?G zC72A4Vu7z?!cLYJ!Yoi8V2Kh~qO`bO#-kh`9gWYQE*@UOnr6JWT*Co$b_wfCICIXa zsUJ1(oo--RHTJE>#Sg$9f8dV|;SU$W6)=cP8?)@%L17vep$$69RNnFs7EwV9>!ypM z7IaIye1&2QAd~T6kk+ma`FL8Zl8cuPd3Y?)vkR@&HeE!3pG7yGLDZaCZBVE)xG+ZR z5ViUk=4dN@jrFm*7dF&W>vt5fJl0Bt99UY*NI6D=nCb8?@qDERh0g21%J)zA{F>AC(=QIL}_j+v&bWl?N58-TlFaqw=EJKb6g?z_ z=jcD@Mye_GY&ZSnp0C->Jv2WTLQmqY25I5M;~kxo2bzUPs5gPz09270zSt~`)Ee?vB2M4!_k#6k#E9$1qWq66Sy%8y2#mvG8}^K7V_ zW6fnaf<%K04HHX3Ugg01WCPUoD?K^(emwuo&_c} zFbkOwd6pn8#a(|a1}Qs=J}nWd*kBaVHFF#XsPZ5L%HiYAKY3h?oY#h7^dK~}kh~s0 zICatVaWRVgiNt6rM570NR5~7~J~~DIz64ja!G(r*9KmgJAFj|c>Fq1l>{t4T6jo~r zKRu~7tT*6@_LiexIr`Im#H!Lbdc!dpH;uEFWUJZR$8|<+HL!Yd(};&F^F~*buskq} z6WlY^_6tiJmrnNtP*PZ;ST(T`A3#Z&+pN?>%EVeL2c~k`> ziNmxt8Rl}62=%C8Byld;)TTqfOvxk;2bo+jsfK|yngmgRL6Hy&fJ>t&z!a(`1)!@& zQNSLM&ZUdYGP+iPsZy;m)!Z5!sOsfmomA^Q_CItkl)P-52bQ{=4zUu#c}$nigMQ$= z9LBEVb~zj!R>e8sCP$M4A$2B%L1jXbskmPjLnPF)2#d8|UNvpf0c|MmOE{*WKx#Uw2&@=AIBPWZ|M!o2$5NP*o(UD=U_%lz_*RP&<28ZX0hhK9xCUN4{ zpJ>$mNm+Meywp959eWOnZA@?{=mXyR{BD!hTTIHth~ z4MhXd&1gkn8y}^y`Zxt_X+oPJX7QLypxro_nPfi65Aq3uZxr;*N_GK%Q1w2pA@i%b z=I4%wz7vZ?PA!ze@zBL`_I2JE2?;Ba zFvw%RBuaZ>17tE*L~1b$|GpJR(1oo|WUHWTU|%4NbIAK=RTMO}!BP=gf*fDM*F%@D z-?)8CeC@_fack$5z1gk3n_CAvw?txd>-L?^gM-(x$$Q~~*f}`Zd-c}Ntr?>I%pq2HgW$T zt2J1wWup2Cd^XQ-;ntO`Z}whh=o65#hxm^^3Y2R_eY0jWG64Svu_UIqClqJS7y-m*A13D{c%sBv;_=GArpG_kwFV>5# zGJOvigD+!?cfRfyOL!w)5)+9P8#W=v%`{C78R)xTQg3o|efwZg#ac|2NaW`VX)IWB z<=MQL6W$zxc)4sYRi4cOwd7nfm2~l`I5@v^A~}cCXb3-eX)eNzmqIRw1>l^Bp{U^H zQ(0N!r3>^Y&26xP&L?x(Jh#D}J~x+vgGtb^x1PprKiLL;d>$UUmCp@w0Vs5$U~x%4 zpGwl<2gZv#_we~;pj^Pxf^HZF2q$G1jFd(TXPJjk2BNG)tDiEnk0j0PBWOcq!-<2E z`51MdA>qPQWmXhee!#U%14gjVa**LmC50c4ARR zcaQZV(JUa0Mj6pED)>3+Qr9LTk#Og7`8)zjq-FqW)+PQ-7QBK{JGlFYFh+{|adS{C zdBvg0EEp-5VfhAa5L`;S2$%5WxT#bjmqsXqu#<`-FLeSy6*96>axR%pefJ`FY@)%TT{= zm|cc)i?O8xR6%S0<4VS}DI)tT$RXGi!Qg;np6n_n%O(dtt%*MpR)`vs0$FYmqK2v^ zNh`-JA?AoepiPJz5{s-yMjK?a2m%9wxx|hTN+d->(>+v#0#@l0IfgD7VvydF9l#J$ z`4`L#0a?io2ujc#g=dx7K@QO70GXDoZnKPRELqcHGW4N3lubgM35!HVQ1%|;XQ@eu zb;43Glq~wZMM7z!5FvTWSyU8dY{K`E#+t1dV1?Ij|Jv&veoCBhxT& z@r>8S7b%aaBmez`pwRL!KaD#&h|qAa6z*ZI*zoDYupXit#2h?fL|^cgJIA`nq+}`X z@y%diEE~2Eu}r9o6)FqPuq=aTE3a4R4E+ph3~7$Ydacz0*@lC)Jc(jf;Xa;x6C^ z;DN+lLyu6;AX(@60FCgd^pNxuV6Dn6VM7fHK*kPz1ObQzbEn55CsIz}9Qojocwp|% z6|A((m+DpKQ(8{5CuzcPD2=hUg6?8ubTqHX6k7-euIVcIhsY{ZOh|H=2Txm7RY?owE5&+oZGEs028LEVc037COv1E?K+shs9vTyrNpaU* zOM{WpI8LjW74--x4M5RG@hS0Odd)R#7ZcnVx!#(GTznm72n-f)1rz6jxwh>h&{Em;nM#l`|-r zEnrTJ2$LZJhSibGgqk%%(8r~^BMq3|2{64g*W;-L7rYNqT&UpR-%(;qwTb7cHa+_V zi{1k?rJxZss?U;C)dUDbf??5!^@ALaC@4_9AZ#O3oe}kgI&L~^4bz7z!HXB0gYvjvG)Vhs8MGj)K>5%&<=>EObv>q z&7_LTdKz;8Yk^!=+MFWfq)pKvrETHPq-D8UkhGbi09=;KPF5KA^{v+LyVyn&sraFqG^lmd1<(uiZB|&xwkP2d$c}+j) zvbZHmcebEo-RDW89ZO{#^$6w@-3})%4_1*mOl5c0;zXqIEnL)Puw#@YHQASWK9&462fa6&fMv{a9H2LQZ28&F}b# z=bJlk#|HC1eO)k3%-Rg#fIXISa@A_qjrh0Sg5 rqsbE(3H5K*E#A2K>W!QHsf}seDMm~RKUw<8(N7*fNrbrhn-l*RGC>HAND>MAIKO-GC-TESTS.\;7 46959 |changes| |to:| (FNS MAIN-GC-TEST LIST-MANIPULATION-TEST CODE-RECLAIM-TEST) |previous| |date:| "23-Jun-88 16:06:34" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;6) ; Copyright (c) 1988 by John Sybalsky & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT MAIKO-GC-TESTSCOMS) (RPAQQ MAIKO-GC-TESTSCOMS ((FILES DANCEROBJ GCHAX) (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>")) (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))) (FNS MAIN-GC-TEST) (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS ARRAY-STRING-TEST VARIOUS-TYPES-TEST) (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST) (FNS ATOM-FULL-TEST STORAGE-FULL-TEST) (COMS (FNS DATATYPE-TEST) (RECORDS GC-TEST-TYPE) (* |;;| "DATATYPE TESTS") ) (COMS (* |;;| "CODE RECLAIMATION TESTS") (FNS CODE-RECLAIM-TEST) (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.") (VARS (CODE-RECLAIM-TEST-TEMP-FN '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) (LET (I) (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (CL:FLET ((TEMP (ARG) (SETQ ARG (FLOAT ARG)) (EXPT (SQRT I) (SQRT (COS (/ I 180)))))) (CL:UNWIND-PROTECT (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) (SETQ I NIL))))))))))) (FILESLOAD DANCEROBJ GCHAX) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)) (DEFINEQ (MAIN-GC-TEST (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT CODE-COUNT TYPE-COUNT LIST-LEN-LIMIT) (* \; "Edited 23-Jun-88 13:30 by jds") (DRIBBLE (OR DRIBBLE-FILE "{LPT}")) (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE) T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}") T T) (|for| I |from| 1 |to| (OR LIMIT 10) |do| (PRINTOUT T "Starting Maiko GC tests, pass " I T) (ITEMS-ON-STACK-TEST (OR STACK-COUNT 100)) (MANY-BIGNUM-MAKER (OR BIGNUM-COUNT 1000)) (MANY-FIXP-MAKER (OR FIXP-COUNT 1000)) (MANY-FLOAT-MAKER (OR FLOAT-COUNT 1000 )) (TEDIT-CRUNCH-TEST (OR TEDIT-COUNT 5)) (ARRAY-STRING-TEST 3) (LIST-MANIPULATION-TEST (OR LIST-COUNT 5) LIST-LEN-LIMIT) (BOUNDARY-TESTS) (CODE-RECLAIM-TEST (OR CODE-COUNT 20)) (VARIOUS-TYPES-TEST (OR TYPE-COUNT 10) ) (FRPTQ 100 (RECLAIM)) (STORAGE)) (ATOM-FULL-TEST) (STORAGE-FULL-TEST) (DRIBBLE NIL))) ) (DEFINEQ (ITEMS-ON-STACK-TEST (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:56 by jds") (PRINTOUT T " Starting ITEMS-ON-STACK test for " LIMIT " iterations." T) (FOR I FROM 1 TO LIMIT DO (LET ((X (CREATE CHARLOOKS)) (Y (EXPT 1234.5 (RAND 3 7)))) (ERSETQ (FRPTQ 5 (RECLAIM)) (COND ((\\ISONFREELIST X) (HELP "X is free, but pointer is on stack." )) ((\\ISONFREELIST Y) (HELP "Y is free, but pointer is on stack." )))))))) (MANY-BIGNUM-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") (PRINTOUT T " Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 12345678901234567890 (RAND 1 I))) (SETQ Y (IQUOTIENT X 3)) (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) (IREMAINDER Y 3) (CL:FLOOR Y 2) (CL:CEILING X 8))) (SETQ W (/ Z Y)))))) (MANY-FIXP-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") (PRINTOUT T " Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 543 (RAND 1 I))) (SETQ Y (IQUOTIENT X 3)) (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) (IREMAINDER Y 3) (CL:FLOOR Y 2) (CL:CEILING X 8))) (SETQ W (/ Z Y)))))) (MANY-FLOAT-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:55 by jds") (PRINTOUT T " Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (FTIMES 1.0 (RAND 0 1))) (SETQ Y (+ (SQRT I) (EXPT (SQRT (SQRT I)) 3.4))) (SETQ Z (LOG Y)))))) (BOUNDARY-TESTS (LAMBDA NIL (* \; "Edited 26-May-88 11:54 by jds") (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.") (PRINTOUT T " Starting Refcnt-63 crossing test" T) (LET* ((ITEM (|create| FMTSPEC)) (LIST (|for| I |from| 1 |to| 62 |collect| ITEM))) (|for| I |from| 1 |to| 1000 |do| (|for| J |from| (LENGTH LIST) |to| (+ 63 (RAND 1 10)) |do| (SETQ LIST (CONS ITEM LIST))) (|for| J |from| (LENGTH LIST) |to| (- 63 (RAND 3 12)) |do| (|pop| LIST)) (COND ((ZEROP (IMOD I 31)) (RECLAIM)))) (PRINTOUT T " Starting Refcount-500K <-> NIL test." T) (|for| LOOP |from| 1 |to| 10 |do| (|for| I |from| 1 |to| 500000 |do| (SETQ LIST (CONS ITEM LIST))) (SETQ LIST NIL)) (PRINTOUT T " Starting Refcount 1-2 boundary test." T) (LET ((ITEM (LIST (|create| FMTSPEC)))) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (CAR ITEM)) (SETQ ITEM2 NIL))) (PRINTOUT T " Starting Refcount 1 + stack boundary test." T) (LET ((ITEM (|create| FMTSPEC)) ITEM2) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (LIST ITEM)) (RPLACA ITEM2 NIL))) (PRINTOUT T " Starting Refcount 0-1 boundary test." T) (LET (ITEM) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM (LIST (|create| FMTSPEC))) (RPLACA ITEM NIL)))))) (ARRAY-STRING-TEST (LAMBDA (LIMIT REAL-STRESS) (* \; "Edited 23-Jun-88 12:23 by jds") (* |;;| "Try out array & string creation, and substringing on the GC.") (PRINTOUT T " Starting Array & String test." T) (FOR I FROM 1 TO (OR LIMIT 10) DO (LET (STRINGS ARRAYS) (FOR ARRAY-COUNT FROM 1 TO 5000 COLLECT (CL:MAKE-ARRAY (RAND 10 (COND (REAL-STRESS 65000) (T (IMAX 100 (IQUOTIENT 65000 ARRAY-COUNT))))))) (FOR I FROM 1 TO 5000 COLLECT (BITMAPCREATE (RAND 1 512) (RAND 1 512))) (SETQ STRINGS (FOR STRING-COUNT FROM 1 TO 5000 COLLECT (ALLOCSTRING (RAND 10 (COND (REAL-STRESS 65000) (T (IMAX 100 (IQUOTIENT 65000 STRING-COUNT )))))))) (FOR STRING IN STRINGS COLLECT (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING) 1)) (RAND (ADD1 (LRSH (NCHARS STRING) 1)) (NCHARS STRING)))))))) (VARIOUS-TYPES-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 12:04 by jds") (* |;;|  "Run thru creation and collection of various types that have caused trouble in the past. ") (PRINTOUT T " Starting various type cases." T) (FOR REPEAT-COUNT FROM 1 TO (OR LIMIT 10) DO (|for| TYPE IN '(VMEMPAGEP) AS CREATION-LIMIT IN '(100) |do| (FOR I FROM 1 TO CREATION-LIMIT COLLECT (NCREATE TYPE)) (DORECLAIM))))) ) (DEFINEQ (TEDIT-CRUNCH-TEST (LAMBDA (LIMIT) (* \; "Edited 27-May-88 13:06 by jds") (* |;;| "GC Testing -- stressing the world.") (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.") (PRINTOUT T " Starting TEDIT-CRUNCH test for " LIMIT " iterations." T) (FOR PASS FROM 1 TO LIMIT DO (PRINTOUT T " Round " PASS " started " (DATE) "." T) (LET ((TS (OPENTEXTSTREAM ' |{ERIS}GC>Hand-Aux>ADVDICT-N-Z.TEDIT| )) TLIST) (TEDIT.HARDCOPY TS '{CORE}FOO.IP T) (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP) (DELFILE '{DSK}FOO.IP) (DELFILE '{CORE}FOO.IP) (CLOSEF (FETCH (TEXTOBJ TXTFILE) OF (TEXTOBJ TS))))))) (LIST-MANIPULATION-TEST (LAMBDA (LIMIT LENGTH-LIMIT) (* \; "Edited 23-Jun-88 14:03 by jds") (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.") (PRINTOUT T " Starting LIST-MANIPULATION test for " LIMIT " iterations." T) (|for| PASS |from| 1 |to| LIMIT |do| (PRINTOUT T " Round " PASS " started " (DATE) "." T) (LET ((TS (OPENTEXTSTREAM '|{ERIS}Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|)) (LEN (RAND 0 (OR LENGTH-LIMIT 100000))) TLIST) (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| TS)) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH LEN 1))) |do| (|pop| TLIST)) (|for| I |from| 1 |to| (RAND 1 100) |do| (SETQ TLIST (CONS TS TLIST))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (|for| I |from| 1 |to| (RAND 1 2000) |do| (SETQ TLIST (CONS TS TLIST))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (|for| \i |from| 1 |to| (RAND 1 1500) |do| (SETQ TLIST (NCONC TLIST (|for| J |from| 1 |to| (RAND 1 10) |join| (|for| K |from| 1 |to| 3 |collect| (CONS TS K)))))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (CLOSEF (|fetch| (TEXTOBJ TXTFILE) |of| (TEXTOBJ TS)))) (LET ((GC-ITEM (NCREATE 'VMEMPAGEP)) (LEN (RAND 10 500)) TLIST ELT) (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| NIL)) (|for| I |from| 1 |to| LEN |do| (SETQ ELT (CL:RANDOM LEN)) (RPLACA (CL:NTHCDR ELT TLIST) GC-ITEM) (RPLACA (CL:NTHCDR (SUB1 I) TLIST) GC-ITEM)) (|for| I |from| (SUB1 LEN) |to| 0 |by| -1 |do| (RPLACD (CL:NTHCDR I TLIST) GC-ITEM)))))) ) (DEFINEQ (ATOM-FULL-TEST (LAMBDA NIL (* \; "Edited 26-May-88 11:39 by jds") (PRINTOUT T " Starting ATOM-space full test.") (LET ((CUR-ATOM-COUNT |\\AtomFrLst|)) (CL:UNWIND-PROTECT (PROGN (SETQ |\\AtomFrLst| 64000) (FOR I FROM 64000 TO 70000 DO (GENSYM 'GC-TEST))) (SETQ |\\AtomFrLst| CUR-ATOM-COUNT))))) (STORAGE-FULL-TEST (LAMBDA NIL (* \; "Edited 26-May-88 11:47 by jds") (PRINTOUT T " Starting Storage-full test." T) (ERSETQ (FOR I FROM 1 COLLECT (ARRAY 100))))) ) (DEFINEQ (DATATYPE-TEST (LAMBDA (LIMIT) (* \; "Edited 26-May-88 11:26 by jds") (FOR I FROM 1 TO (OR LIMIT 10) DO (FOR L FROM 1 TO 100 DO (FOR Y FROM 1 TO 20 COLLECT (CREATE GC-TEST-TYPE FIELD-1 _ T)) (RECLAIM))))) ) (DECLARE\: EVAL@COMPILE (DATATYPE GC-TEST-TYPE (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE) (FIELD-5 FIXP) FIELD-6 (FIELD-7 WORD) FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14 FIXP) FIELD-15 (FIELD-16 XPOINTER) FIELD-17 (FIELD-18 BYTE) (FIELD-19 FIXP) FIELD-20 (FIELD-21 BYTE) FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE) FIELD-26 (FIELD-27 BYTE) FIELD-28 (FIELD-29 BYTE) FIELD-30 (FIELD-31 WORD) FIELD-32 (FIELD-33 XPOINTER) FIELD-34 (FIELD-35 FIXP) FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG) FIELD-40 (FIELD-41 FLAG) FIELD-42 (FIELD-43 FIXP) (FIELD-44 FIXP) FIELD-45 (FIELD-46 XPOINTER) FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG) (FIELD-51 BYTE) FIELD-52 FIELD-53 (FIELD-54 BYTE) FIELD-55 FIELD-56 (FIELD-57 BYTE) (FIELD-58 WORD) FIELD-59 FIELD-60 (FIELD-61 XPOINTER) FIELD-62 FIELD-63 (FIELD-64 XPOINTER) (FIELD-65 XPOINTER) FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG) FIELD-71 FIELD-72 (FIELD-73 WORD) FIELD-74 (FIELD-75 FLAG) FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP) (FIELD-81 FIXP) FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER) (FIELD-87 BYTE) (FIELD-88 XPOINTER) FIELD-89 (FIELD-90 BYTE) (FIELD-91 FLAG) (FIELD-92 FIXP) (FIELD-93 FIXP) (FIELD-94 FLAG) FIELD-95 (FIELD-96 FLAG) FIELD-97 (FIELD-98 FLAG) FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 XPOINTER) FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE) FIELD-110 (FIELD-111 WORD) FIELD-112 (FIELD-113 XPOINTER) (FIELD-114 FLAG) (FIELD-115 FIXP) FIELD-116 FIELD-117 (FIELD-118 BYTE) FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 XPOINTER) (FIELD-125 BYTE) (FIELD-126 XPOINTER) FIELD-127 FIELD-128 (FIELD-129 FIXP) (FIELD-130 FLAG) FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD) (FIELD-136 FLAG) FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD) (FIELD-141 FLAG) FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP) FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG) FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP) FIELD-156 (FIELD-157 BYTE) FIELD-158 (FIELD-159 FIXP) (FIELD-160 WORD) FIELD-161 (FIELD-162 WORD) (FIELD-163 FIXP) FIELD-164 (FIELD-165 FIXP) FIELD-166 (FIELD-167 FLAG) (FIELD-168 BYTE) FIELD-169 FIELD-170 (FIELD-171 XPOINTER) (FIELD-172 BYTE) FIELD-173 FIELD-174 (FIELD-175 FLAG) (FIELD-176 BYTE) (FIELD-177 WORD) FIELD-178 (FIELD-179 FIXP) FIELD-180 FIELD-181 (FIELD-182 BYTE) FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE) (FIELD-189 FIXP) FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE) FIELD-194 (FIELD-195 WORD) FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD) FIELD-201 (FIELD-202 FLAG) FIELD-203 (FIELD-204 XPOINTER) FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG) FIELD-209 (FIELD-210 WORD) (FIELD-211 BYTE) FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP) FIELD-216 FIELD-217 (FIELD-218 XPOINTER) FIELD-219 (FIELD-220 FLAG) FIELD-221 (FIELD-222 FLAG) (FIELD-223 WORD) (FIELD-224 FLAG) (FIELD-225 WORD) FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 XPOINTER) FIELD-232 (FIELD-233 WORD) (FIELD-234 WORD) FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 FIELD-241 (FIELD-242 XPOINTER) FIELD-243 (FIELD-244 WORD) FIELD-245 FIELD-246 (FIELD-247 XPOINTER) FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER) FIELD-259 (FIELD-260 FIXP) FIELD-261 FIELD-262 (FIELD-263 XPOINTER) FIELD-264 (FIELD-265 WORD) (FIELD-266 FLAG) FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE) FIELD-273 FIELD-274 (FIELD-275 FLAG) (FIELD-276 BYTE) FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER) (FIELD-281 WORD) (FIELD-282 WORD) FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD) FIELD-287 (FIELD-288 XPOINTER) (FIELD-289 BYTE) FIELD-290 (FIELD-291 XPOINTER) (FIELD-292 FLAG) FIELD-293 FIELD-294 (FIELD-295 FLAG) FIELD-296 FIELD-297 (FIELD-298 XPOINTER) (FIELD-299 FIXP) (FIELD-300 FIXP) (FIELD-301 BYTE) FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP) FIELD-307 (FIELD-308 FLAG) (FIELD-309 FIXP) FIELD-310 (FIELD-311 XPOINTER) FIELD-312 FIELD-313 (FIELD-314 BYTE) FIELD-315 (FIELD-316 WORD) (FIELD-317 FIXP) FIELD-318 (FIELD-319 FLAG) FIELD-320 (FIELD-321 WORD))) ) (/DECLAREDATATYPE 'GC-TEST-TYPE '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER FLAG POINTER WORD) '((GC-TEST-TYPE 0 POINTER) (GC-TEST-TYPE 2 POINTER) (GC-TEST-TYPE 4 POINTER) (GC-TEST-TYPE 4 (BITS . 7)) (GC-TEST-TYPE 6 FIXP) (GC-TEST-TYPE 8 POINTER) (GC-TEST-TYPE 10 (BITS . 15)) (GC-TEST-TYPE 12 POINTER) (GC-TEST-TYPE 14 POINTER) (GC-TEST-TYPE 16 POINTER) (GC-TEST-TYPE 18 POINTER) (GC-TEST-TYPE 20 POINTER) (GC-TEST-TYPE 22 POINTER) (GC-TEST-TYPE 24 FIXP) (GC-TEST-TYPE 26 POINTER) (GC-TEST-TYPE 28 XPOINTER) (GC-TEST-TYPE 30 POINTER) (GC-TEST-TYPE 30 (BITS . 7)) (GC-TEST-TYPE 32 FIXP) (GC-TEST-TYPE 34 POINTER) (GC-TEST-TYPE 34 (BITS . 7)) (GC-TEST-TYPE 36 POINTER) (GC-TEST-TYPE 38 POINTER) (GC-TEST-TYPE 40 POINTER) (GC-TEST-TYPE 40 (BITS . 7)) (GC-TEST-TYPE 42 POINTER) (GC-TEST-TYPE 42 (BITS . 7)) (GC-TEST-TYPE 44 POINTER) (GC-TEST-TYPE 44 (BITS . 7)) (GC-TEST-TYPE 46 POINTER) (GC-TEST-TYPE 11 (BITS . 15)) (GC-TEST-TYPE 48 POINTER) (GC-TEST-TYPE 50 XPOINTER) (GC-TEST-TYPE 52 POINTER) (GC-TEST-TYPE 54 FIXP) (GC-TEST-TYPE 56 POINTER) (GC-TEST-TYPE 58 POINTER) (GC-TEST-TYPE 60 POINTER) (GC-TEST-TYPE 60 (FLAGBITS . 0)) (GC-TEST-TYPE 62 POINTER) (GC-TEST-TYPE 62 (FLAGBITS . 0)) (GC-TEST-TYPE 64 POINTER) (GC-TEST-TYPE 66 FIXP) (GC-TEST-TYPE 68 FIXP) (GC-TEST-TYPE 70 POINTER) (GC-TEST-TYPE 72 XPOINTER) (GC-TEST-TYPE 74 POINTER) (GC-TEST-TYPE 76 POINTER) (GC-TEST-TYPE 78 POINTER) (GC-TEST-TYPE 78 (FLAGBITS . 0)) (GC-TEST-TYPE 76 (BITS . 7)) (GC-TEST-TYPE 80 POINTER) (GC-TEST-TYPE 82 POINTER) (GC-TEST-TYPE 82 (BITS . 7)) (GC-TEST-TYPE 84 POINTER) (GC-TEST-TYPE 86 POINTER) (GC-TEST-TYPE 86 (BITS . 7)) (GC-TEST-TYPE 88 (BITS . 15)) (GC-TEST-TYPE 90 POINTER) (GC-TEST-TYPE 92 POINTER) (GC-TEST-TYPE 94 XPOINTER) (GC-TEST-TYPE 96 POINTER) (GC-TEST-TYPE 98 POINTER) (GC-TEST-TYPE 100 XPOINTER) (GC-TEST-TYPE 102 XPOINTER) (GC-TEST-TYPE 104 POINTER) (GC-TEST-TYPE 106 POINTER) (GC-TEST-TYPE 108 POINTER) (GC-TEST-TYPE 110 POINTER) (GC-TEST-TYPE 110 (FLAGBITS . 0)) (GC-TEST-TYPE 112 POINTER) (GC-TEST-TYPE 114 POINTER) (GC-TEST-TYPE 89 (BITS . 15)) (GC-TEST-TYPE 116 POINTER) (GC-TEST-TYPE 116 (FLAGBITS . 0)) (GC-TEST-TYPE 118 POINTER) (GC-TEST-TYPE 120 POINTER) (GC-TEST-TYPE 122 POINTER) (GC-TEST-TYPE 124 POINTER) (GC-TEST-TYPE 126 FIXP) (GC-TEST-TYPE 128 FIXP) (GC-TEST-TYPE 130 POINTER) (GC-TEST-TYPE 132 POINTER) (GC-TEST-TYPE 134 POINTER) (GC-TEST-TYPE 136 POINTER) (GC-TEST-TYPE 138 XPOINTER) (GC-TEST-TYPE 138 (BITS . 7)) (GC-TEST-TYPE 140 XPOINTER) (GC-TEST-TYPE 142 POINTER) (GC-TEST-TYPE 142 (BITS . 7)) (GC-TEST-TYPE 140 (FLAGBITS . 0)) (GC-TEST-TYPE 144 FIXP) (GC-TEST-TYPE 146 FIXP) (GC-TEST-TYPE 140 (FLAGBITS . 16)) (GC-TEST-TYPE 148 POINTER) (GC-TEST-TYPE 148 (FLAGBITS . 0)) (GC-TEST-TYPE 150 POINTER) (GC-TEST-TYPE 150 (FLAGBITS . 0)) (GC-TEST-TYPE 152 POINTER) (GC-TEST-TYPE 154 POINTER) (GC-TEST-TYPE 156 POINTER) (GC-TEST-TYPE 158 POINTER) (GC-TEST-TYPE 160 POINTER) (GC-TEST-TYPE 162 XPOINTER) (GC-TEST-TYPE 164 POINTER) (GC-TEST-TYPE 166 POINTER) (GC-TEST-TYPE 168 POINTER) (GC-TEST-TYPE 170 POINTER) (GC-TEST-TYPE 170 (BITS . 7)) (GC-TEST-TYPE 172 POINTER) (GC-TEST-TYPE 174 (BITS . 15)) (GC-TEST-TYPE 176 POINTER) (GC-TEST-TYPE 178 XPOINTER) (GC-TEST-TYPE 178 (FLAGBITS . 0)) (GC-TEST-TYPE 180 FIXP) (GC-TEST-TYPE 182 POINTER) (GC-TEST-TYPE 184 POINTER) (GC-TEST-TYPE 184 (BITS . 7)) (GC-TEST-TYPE 186 POINTER) (GC-TEST-TYPE 188 POINTER) (GC-TEST-TYPE 190 POINTER) (GC-TEST-TYPE 192 POINTER) (GC-TEST-TYPE 194 POINTER) (GC-TEST-TYPE 196 XPOINTER) (GC-TEST-TYPE 196 (BITS . 7)) (GC-TEST-TYPE 198 XPOINTER) (GC-TEST-TYPE 200 POINTER) (GC-TEST-TYPE 202 POINTER) (GC-TEST-TYPE 204 FIXP) (GC-TEST-TYPE 202 (FLAGBITS . 0)) (GC-TEST-TYPE 206 POINTER) (GC-TEST-TYPE 208 POINTER) (GC-TEST-TYPE 210 POINTER) (GC-TEST-TYPE 212 POINTER) (GC-TEST-TYPE 175 (BITS . 15)) (GC-TEST-TYPE 212 (FLAGBITS . 0)) (GC-TEST-TYPE 214 POINTER) (GC-TEST-TYPE 216 POINTER) (GC-TEST-TYPE 218 POINTER) (GC-TEST-TYPE 220 (BITS . 15)) (GC-TEST-TYPE 218 (FLAGBITS . 0)) (GC-TEST-TYPE 222 POINTER) (GC-TEST-TYPE 224 POINTER) (GC-TEST-TYPE 226 POINTER) (GC-TEST-TYPE 228 FIXP) (GC-TEST-TYPE 230 POINTER) (GC-TEST-TYPE 232 POINTER) (GC-TEST-TYPE 234 POINTER) (GC-TEST-TYPE 236 POINTER) (GC-TEST-TYPE 236 (FLAGBITS . 0)) (GC-TEST-TYPE 238 POINTER) (GC-TEST-TYPE 240 POINTER) (GC-TEST-TYPE 242 POINTER) (GC-TEST-TYPE 244 POINTER) (GC-TEST-TYPE 246 FIXP) (GC-TEST-TYPE 248 POINTER) (GC-TEST-TYPE 248 (BITS . 7)) (GC-TEST-TYPE 250 POINTER) (GC-TEST-TYPE 252 FIXP) (GC-TEST-TYPE 221 (BITS . 15)) (GC-TEST-TYPE 254 POINTER) (GC-TEST-TYPE 256 (BITS . 15)) (GC-TEST-TYPE 257 FIXP) (GC-TEST-TYPE 260 POINTER) (GC-TEST-TYPE 262 FIXP) (GC-TEST-TYPE 264 POINTER) (GC-TEST-TYPE 264 (FLAGBITS . 0)) (GC-TEST-TYPE 260 (BITS . 7)) (GC-TEST-TYPE 266 POINTER) (GC-TEST-TYPE 268 POINTER) (GC-TEST-TYPE 270 XPOINTER) (GC-TEST-TYPE 270 (BITS . 7)) (GC-TEST-TYPE 272 POINTER) (GC-TEST-TYPE 274 POINTER) (GC-TEST-TYPE 274 (FLAGBITS . 0)) (GC-TEST-TYPE 272 (BITS . 7)) (GC-TEST-TYPE 259 (BITS . 15)) (GC-TEST-TYPE 276 POINTER) (GC-TEST-TYPE 278 FIXP) (GC-TEST-TYPE 280 POINTER) (GC-TEST-TYPE 282 POINTER) (GC-TEST-TYPE 282 (BITS . 7)) (GC-TEST-TYPE 284 POINTER) (GC-TEST-TYPE 286 POINTER) (GC-TEST-TYPE 288 POINTER) (GC-TEST-TYPE 290 POINTER) (GC-TEST-TYPE 292 POINTER) (GC-TEST-TYPE 292 (BITS . 7)) (GC-TEST-TYPE 294 FIXP) (GC-TEST-TYPE 296 POINTER) (GC-TEST-TYPE 298 POINTER) (GC-TEST-TYPE 300 POINTER) (GC-TEST-TYPE 300 (BITS . 7)) (GC-TEST-TYPE 302 POINTER) (GC-TEST-TYPE 304 (BITS . 15)) (GC-TEST-TYPE 306 POINTER) (GC-TEST-TYPE 308 POINTER) (GC-TEST-TYPE 310 POINTER) (GC-TEST-TYPE 312 POINTER) (GC-TEST-TYPE 305 (BITS . 15)) (GC-TEST-TYPE 314 POINTER) (GC-TEST-TYPE 314 (FLAGBITS . 0)) (GC-TEST-TYPE 316 POINTER) (GC-TEST-TYPE 318 XPOINTER) (GC-TEST-TYPE 320 POINTER) (GC-TEST-TYPE 322 POINTER) (GC-TEST-TYPE 324 POINTER) (GC-TEST-TYPE 324 (FLAGBITS . 0)) (GC-TEST-TYPE 326 POINTER) (GC-TEST-TYPE 328 (BITS . 15)) (GC-TEST-TYPE 326 (BITS . 7)) (GC-TEST-TYPE 330 POINTER) (GC-TEST-TYPE 332 POINTER) (GC-TEST-TYPE 334 POINTER) (GC-TEST-TYPE 336 FIXP) (GC-TEST-TYPE 338 POINTER) (GC-TEST-TYPE 340 POINTER) (GC-TEST-TYPE 342 XPOINTER) (GC-TEST-TYPE 344 POINTER) (GC-TEST-TYPE 344 (FLAGBITS . 0)) (GC-TEST-TYPE 346 POINTER) (GC-TEST-TYPE 346 (FLAGBITS . 0)) (GC-TEST-TYPE 329 (BITS . 15)) (GC-TEST-TYPE 346 (FLAGBITS . 16)) (GC-TEST-TYPE 348 (BITS . 15)) (GC-TEST-TYPE 350 POINTER) (GC-TEST-TYPE 352 POINTER) (GC-TEST-TYPE 354 POINTER) (GC-TEST-TYPE 356 POINTER) (GC-TEST-TYPE 358 POINTER) (GC-TEST-TYPE 360 XPOINTER) (GC-TEST-TYPE 362 POINTER) (GC-TEST-TYPE 349 (BITS . 15)) (GC-TEST-TYPE 364 (BITS . 15)) (GC-TEST-TYPE 366 POINTER) (GC-TEST-TYPE 368 POINTER) (GC-TEST-TYPE 370 POINTER) (GC-TEST-TYPE 372 POINTER) (GC-TEST-TYPE 374 POINTER) (GC-TEST-TYPE 376 POINTER) (GC-TEST-TYPE 378 POINTER) (GC-TEST-TYPE 380 XPOINTER) (GC-TEST-TYPE 382 POINTER) (GC-TEST-TYPE 365 (BITS . 15)) (GC-TEST-TYPE 384 POINTER) (GC-TEST-TYPE 386 POINTER) (GC-TEST-TYPE 388 XPOINTER) (GC-TEST-TYPE 390 POINTER) (GC-TEST-TYPE 392 POINTER) (GC-TEST-TYPE 394 POINTER) (GC-TEST-TYPE 396 POINTER) (GC-TEST-TYPE 398 POINTER) (GC-TEST-TYPE 400 POINTER) (GC-TEST-TYPE 402 POINTER) (GC-TEST-TYPE 404 POINTER) (GC-TEST-TYPE 406 POINTER) (GC-TEST-TYPE 408 POINTER) (GC-TEST-TYPE 410 XPOINTER) (GC-TEST-TYPE 412 POINTER) (GC-TEST-TYPE 414 FIXP) (GC-TEST-TYPE 416 POINTER) (GC-TEST-TYPE 418 POINTER) (GC-TEST-TYPE 420 XPOINTER) (GC-TEST-TYPE 422 POINTER) (GC-TEST-TYPE 424 (BITS . 15)) (GC-TEST-TYPE 422 (FLAGBITS . 0)) (GC-TEST-TYPE 426 POINTER) (GC-TEST-TYPE 428 POINTER) (GC-TEST-TYPE 430 POINTER) (GC-TEST-TYPE 432 POINTER) (GC-TEST-TYPE 434 POINTER) (GC-TEST-TYPE 434 (BITS . 7)) (GC-TEST-TYPE 436 POINTER) (GC-TEST-TYPE 438 POINTER) (GC-TEST-TYPE 438 (FLAGBITS . 0)) (GC-TEST-TYPE 436 (BITS . 7)) (GC-TEST-TYPE 440 POINTER) (GC-TEST-TYPE 442 POINTER) (GC-TEST-TYPE 444 POINTER) (GC-TEST-TYPE 446 XPOINTER) (GC-TEST-TYPE 425 (BITS . 15)) (GC-TEST-TYPE 448 (BITS . 15)) (GC-TEST-TYPE 450 POINTER) (GC-TEST-TYPE 452 POINTER) (GC-TEST-TYPE 454 POINTER) (GC-TEST-TYPE 449 (BITS . 15)) (GC-TEST-TYPE 456 POINTER) (GC-TEST-TYPE 458 XPOINTER) (GC-TEST-TYPE 458 (BITS . 7)) (GC-TEST-TYPE 460 POINTER) (GC-TEST-TYPE 462 XPOINTER) (GC-TEST-TYPE 462 (FLAGBITS . 0)) (GC-TEST-TYPE 464 POINTER) (GC-TEST-TYPE 466 POINTER) (GC-TEST-TYPE 466 (FLAGBITS . 0)) (GC-TEST-TYPE 468 POINTER) (GC-TEST-TYPE 470 POINTER) (GC-TEST-TYPE 472 XPOINTER) (GC-TEST-TYPE 474 FIXP) (GC-TEST-TYPE 476 FIXP) (GC-TEST-TYPE 472 (BITS . 7)) (GC-TEST-TYPE 478 POINTER) (GC-TEST-TYPE 480 POINTER) (GC-TEST-TYPE 482 POINTER) (GC-TEST-TYPE 484 POINTER) (GC-TEST-TYPE 486 FIXP) (GC-TEST-TYPE 488 POINTER) (GC-TEST-TYPE 488 (FLAGBITS . 0)) (GC-TEST-TYPE 490 FIXP) (GC-TEST-TYPE 492 POINTER) (GC-TEST-TYPE 494 XPOINTER) (GC-TEST-TYPE 496 POINTER) (GC-TEST-TYPE 498 POINTER) (GC-TEST-TYPE 498 (BITS . 7)) (GC-TEST-TYPE 500 POINTER) (GC-TEST-TYPE 502 (BITS . 15)) (GC-TEST-TYPE 503 FIXP) (GC-TEST-TYPE 506 POINTER) (GC-TEST-TYPE 506 (FLAGBITS . 0)) (GC-TEST-TYPE 508 POINTER) (GC-TEST-TYPE 505 (BITS . 15))) '510) (* |;;| "DATATYPE TESTS") (* |;;| "CODE RECLAIMATION TESTS") (DEFINEQ (CODE-RECLAIM-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 11:54 by jds") (LET NIL (* |;;| "Make sure there's a definition to compile.") (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN) (EVAL CODE-RECLAIM-TEST-TEMP-FN)) (PRINTOUT T " Starting code-block reclaim test" T) (|for| I |from| 1 |to| LIMIT |do| (BKSYSBUF "ST N ") (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN)) (PRINTOUT T " Starting MAPATOMS(GETD)" T) (|for| I |from| 1 |to| LIMIT |do| (MAPATOMS (FUNCTION GETD))) (PRINTOUT T " Starting MAPATOMS(MOVD to DUMMYFN)" T) (FOR I FROM 1 TO LIMIT DO (MAPATOMS #'(LAMBDA (FN-NAME) (AND (GETD FN-NAME) (MOVD FN-NAME 'MAIKO-GC-TEST-DUMMY-FN)) )))))) ) (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed." ) (RPAQQ CODE-RECLAIM-TEST-TEMP-FN (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) (LET (I) (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (CL:FLET ((TEMP (ARG) (SETQ ARG (FLOAT ARG)) (EXPT (SQRT I) (SQRT (COS (/ I 180)))))) (CL:UNWIND-PROTECT (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) (SETQ I NIL))))))) (PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2794 5208 (MAIN-GC-TEST 2804 . 5206)) (5209 13651 (ITEMS-ON-STACK-TEST 5219 . 6382) ( MANY-BIGNUM-MAKER 6384 . 7256) (MANY-FIXP-MAKER 7258 . 8044) (MANY-FLOAT-MAKER 8046 . 8653) ( BOUNDARY-TESTS 8655 . 11122) (ARRAY-STRING-TEST 11124 . 13070) (VARIOUS-TYPES-TEST 13072 . 13649)) ( 13652 18513 (TEDIT-CRUNCH-TEST 13662 . 15074) (LIST-MANIPULATION-TEST 15076 . 18511)) (18514 19198 ( ATOM-FULL-TEST 18524 . 18955) (STORAGE-FULL-TEST 18957 . 19196)) (19199 19717 (DATATYPE-TEST 19209 . 19715)) (44700 45875 (CODE-RECLAIM-TEST 44710 . 45873))))) STOP \ No newline at end of file diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE b/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE new file mode 100644 index 00000000..84f8813b --- /dev/null +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE @@ -0,0 +1 @@ +(PROGN (PRIN1 "Use LOADDB to load database files! " T) (ERROR!)) ("23-Jun-88 16:06:34" . {ERIS}GC>HAND>MAIKO-GC-TESTS.;6) FNS (MAIN-GC-TEST ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS ARRAY-STRING-TEST VARIOUS-TYPES-TEST TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST ATOM-FULL-TEST STORAGE-FULL-TEST DATATYPE-TEST CODE-RECLAIM-TEST) (READATABASE) ( CALL MAIN-GC-TEST (DATE TERPRI RECLAIM PLUS DRIBBLE) ITEMS-ON-STACK-TEST (TERPRI FREPLACEFIELDVAL NCREATE EXPT RAND FRPTQ RECLAIM PLUS) MANY-BIGNUM-MAKER (TERPRI CL:* RAND IQUOTIENT IPLUS IMOD IREMAINDER CL:FLOOR CL:CEILING / PLUS) MANY-FIXP-MAKER (TERPRI CL:* RAND IQUOTIENT IPLUS IMOD IREMAINDER CL:FLOOR CL:CEILING / PLUS) MANY-FLOAT-MAKER (TERPRI FTIMES RAND + SQRT EXPT LOG PLUS) BOUNDARY-TESTS (TERPRI FREPLACEFIELDVAL NCREATE CONS LIST PLUS + RAND LENGTH - IMOD) ARRAY-STRING-TEST (TERPRI CL:MAKE-ARRAY RAND IMAX IQUOTIENT LIST PLUS BITMAPCREATE ALLOCSTRING SUBSTRING LRSH NCHARS ADD1) VARIOUS-TYPES-TEST (TERPRI NCREATE LIST PLUS) TEDIT-CRUNCH-TEST (TERPRI DATE OPENTEXTSTREAM TEXTOBJ FETCHFIELD PLUS) LIST-MANIPULATION-TEST (TERPRI DATE OPENTEXTSTREAM RAND LIST PLUS IMAX LRSH CONS FLENGTH NCONC TEXTOBJ FETCHFIELD NCREATE CL:RANDOM CL:NTHCDR SUB1) ATOM-FULL-TEST (PRIN1 CL:MULTIPLE-VALUE-PROG1 .UNWIND.PROTECT. FUNCTION PLUS) STORAGE-FULL-TEST (TERPRI ERSETQ ARRAY LIST PLUS) DATATYPE-TEST (FREPLACEFIELDVAL NCREATE LIST PLUS) CODE-RECLAIM-TEST (GETD TERPRI PLUS) NIL BIND MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST (X Y) MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER (W) BOUNDARY-TESTS NIL ARRAY-STRING-TEST (ARRAYS) VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST (TLIST) LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL NLAMBDA MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST (CL:UNWIND-PROTECT) STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL NOBIND MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL RECORD MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST (TEXTOBJ) LIST-MANIPULATION-TEST (TEXTOBJ) ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL CREATE MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST (CHARLOOKS) MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS (FMTSPEC) ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST (GC-TEST-TYPE) CODE-RECLAIM-TEST NIL NIL FETCH MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST (TXTFILE) LIST-MANIPULATION-TEST (TXTFILE) ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL REPLACE MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST (FIELD-1) CODE-RECLAIM-TEST NIL NIL REFFREE MAIN-GC-TEST (TYPE-COUNT) ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST (CODE-RECLAIM-TEST-TEMP-FN) NIL REF MAIN-GC-TEST (DRIBBLE-FILE LIMIT STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT CODE-COUNT) ITEMS-ON-STACK-TEST (LIMIT) MANY-BIGNUM-MAKER (LIMIT) MANY-FIXP-MAKER (LIMIT) MANY-FLOAT-MAKER (LIMIT) BOUNDARY-TESTS NIL ARRAY-STRING-TEST (LIMIT STRING) VARIOUS-TYPES-TEST (LIMIT ) TEDIT-CRUNCH-TEST (LIMIT TS) LIST-MANIPULATION-TEST (LIMIT LEN TS GC-ITEM) ATOM-FULL-TEST ( CUR-ATOM-COUNT) STORAGE-FULL-TEST NIL DATATYPE-TEST (LIMIT) CODE-RECLAIM-TEST (LIMIT) NIL SETFREE MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS (ITEM2) ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST (\AtomFrLst) STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL SET MAIN-GC-TEST (I) ITEMS-ON-STACK-TEST (I) MANY-BIGNUM-MAKER (X Y Z W I) MANY-FIXP-MAKER (X Y Z W I) MANY-FLOAT-MAKER (X Y Z I) BOUNDARY-TESTS (I LIST J LOOP ITEM2 ITEM) ARRAY-STRING-TEST (ARRAY-COUNT I STRINGS STRING-COUNT) VARIOUS-TYPES-TEST (TYPE CREATION-LIMIT I REPEAT-COUNT) TEDIT-CRUNCH-TEST (PASS ) LIST-MANIPULATION-TEST (TLIST I K J i ELT PASS) ATOM-FULL-TEST (I) STORAGE-FULL-TEST (I) DATATYPE-TEST (Y L I) CODE-RECLAIM-TEST (I) NIL SMASHFREE MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL SMASH MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS (ITEM2 ITEM) ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL PROP MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL TEST MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST (REAL-STRESS) VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL TESTFREE MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL PREDICATE MAIN-GC-TEST (GREATERP) ITEMS-ON-STACK-TEST (GREATERP) MANY-BIGNUM-MAKER (GREATERP) MANY-FIXP-MAKER (GREATERP) MANY-FLOAT-MAKER (GREATERP) BOUNDARY-TESTS (GREATERP ZEROP) ARRAY-STRING-TEST (GREATERP) VARIOUS-TYPES-TEST (GREATERP) TEDIT-CRUNCH-TEST (GREATERP) LIST-MANIPULATION-TEST (GREATERP LESSP) ATOM-FULL-TEST (GREATERP) STORAGE-FULL-TEST NIL DATATYPE-TEST (GREATERP) CODE-RECLAIM-TEST (GREATERP) NIL EFFECT MAIN-GC-TEST (PRINTOUT PRIN1 ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER TEDIT-CRUNCH-TEST ARRAY-STRING-TEST LIST-MANIPULATION-TEST BOUNDARY-TESTS CODE-RECLAIM-TEST VARIOUS-TYPES-TEST FRPTQ STORAGE ATOM-FULL-TEST STORAGE-FULL-TEST) ITEMS-ON-STACK-TEST (PRINTOUT PRIN1 ERSETQ) MANY-BIGNUM-MAKER (PRINTOUT PRIN1) MANY-FIXP-MAKER ( PRINTOUT PRIN1) MANY-FLOAT-MAKER (PRINTOUT PRIN1) BOUNDARY-TESTS (PRINTOUT PRIN1 FRPLACD RECLAIM RPLACA) ARRAY-STRING-TEST (PRINTOUT PRIN1 FRPLACD MAPCAR) VARIOUS-TYPES-TEST (PRINTOUT PRIN1 FRPLACD DORECLAIM) TEDIT-CRUNCH-TEST (PRINTOUT PRIN1 TEDIT.HARDCOPY COPYFILE DELFILE CLOSEF) LIST-MANIPULATION-TEST (PRINTOUT PRIN1 FRPLACD CLOSEF RPLACA RPLACD) ATOM-FULL-TEST (PRINTOUT GENSYM) STORAGE-FULL-TEST (PRINTOUT PRIN1 FRPLACD) DATATYPE-TEST (FRPLACD RECLAIM) CODE-RECLAIM-TEST (EVAL PRINTOUT PRIN1 BKSYSBUF COMPILE MAPATOMS) NIL CLISP MAIN-GC-TEST (for from to do) ITEMS-ON-STACK-TEST (for from to do) MANY-BIGNUM-MAKER (for from to do) MANY-FIXP-MAKER (for from to do) MANY-FLOAT-MAKER (for from to do) BOUNDARY-TESTS (for from to collect do) ARRAY-STRING-TEST (for from to do collect in) VARIOUS-TYPES-TEST (for from to do in as collect) TEDIT-CRUNCH-TEST (for from to do) LIST-MANIPULATION-TEST (for from to do collect join by) ATOM-FULL-TEST (for from to do) STORAGE-FULL-TEST (for from collect) DATATYPE-TEST (for from to do collect) CODE-RECLAIM-TEST (for from to do) NIL SPECVARS MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL LOCALVARS MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL APPLY MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST (GETD) NIL ERROR MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL LOCALFREEVARS MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST (CUR-ATOM-COUNT) STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL ARGS MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL USERTEMPLATES WINDOWPROP (CALL EVAL PROP EVAL . PPE) UNINTERRUPTABLY (CALL |..| EVAL) OP# (CALL) CL:PUSH (NIL @ EXPR (COND ((ATOM (CADDR EXPR)) (QUOTE (EVAL SET))) (T (QUOTE (EVAL SMASH))))) SPREADAPPLY* ( CALL FUNCTIONAL |..| EVAL) WINDOWADDPROP (CALL EVAL PROP EVAL EVAL . PPE) CAPABILITY? (CALL) DOVEIO.LOCKMEM (CALL |..| EVAL) TTBOUT (CALL |..| (IF (OR (LISTP EXPR) (AND (NTHCHAR EXPR 2) (NOT ( ASSOC EXPR DMCHARCODES)))) EVAL NIL)) \DoveIO.LockMem (CALL |..| EVAL) \\\\DoveIO.LockMem (CALL |..| EVAL) TOP10-APPLY-CHAR-STYLE MACRO WINDOWDELPROP (CALL EVAL PROP EVAL . PPE) TTBOUTN (MACRO (X . Y) ( FRPTQ X (TTBOUT . Y))) \\DoveIO.LockMem (CALL |..| EVAL) CAL-Y MACRO SCRATCHASH MACRO RUN-SUPER (CALL |..| EVAL) SPREADAPPLY (CALL FUNCTIONAL EVAL . PPE) SHAZAM (CALL |..| NIL) perform (MACRO ARGS ( PERFORMTRAN ARGS T)) SETQ.NOREF (CALL SET EVAL . PPE) CL::%%ABS MACRO GETRELQ MACRO PERFORM (MACRO ARGS (PERFORMTRAN ARGS T)) TESTRELQ MACRO CAL-X MACRO CATCH (CALL CALL CALL |..| EVAL) \MICASTOPTS MACRO REF (CALL EVAL (IF (AND (CONSP EXPR) (EQ (CAR EXPR) (QUOTE QUOTE))) (NIL FETCH) EVAL)) NIL 0 MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL KEYACCEPT MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL KEYSPECIFY MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL KEYCALL MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL FLET MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL LABEL MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL MACROLET MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL COMPILER-LET MAIN-GC-TEST NIL ITEMS-ON-STACK-TEST NIL MANY-BIGNUM-MAKER NIL MANY-FIXP-MAKER NIL MANY-FLOAT-MAKER NIL BOUNDARY-TESTS NIL ARRAY-STRING-TEST NIL VARIOUS-TYPES-TEST NIL TEDIT-CRUNCH-TEST NIL LIST-MANIPULATION-TEST NIL ATOM-FULL-TEST NIL STORAGE-FULL-TEST NIL DATATYPE-TEST NIL CODE-RECLAIM-TEST NIL NIL ) \ No newline at end of file diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM b/internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..ad86f35d4e35d6a57bf503bee54c3abcf8f6a6da GIT binary patch literal 26755 zcmdU2U2I#|eV3&;A8g}EvX{D==bW&aOSz`1`$3741J$%h$+Spbnxq^%bEhhn5-DUP zLz0UIae;kcz=k~xYYS|{9)=EkS-TIlj)yKuOSCUT_fYJ?3tF@TimneG2CPZcb-;kG z`~A2a2dKy#*Mef*hDvs=&atSfl8*sbdut6MLw@6O(008vvA7|?EItA$#*zFaA^%0Z0- zX7fR@lx>veD}{1Zw4`orZrx((>iSw|{S_9XKQS?ZwboYm*4NM-wmZ|a-pp(+m+rrF zcXl#&zdL3A)J$$hZv~s$+s1w}3$-Roy{BD`vs*WI)<3zqeRCJkXcK^!cD?Myn_F}? zpyuS%tcSBn-Pd7EjhlGP7IUdgojI(Gf1OD|?MkVZt(2?f7TRW5>uSA}oe!34^qLoh zSFh7zf_j}|V4ZSHkIu1$N>B*jeYQ}(QrF!cJ6~R`Emw7e%bG3ltbTV`u~9w`Ugcbk zZpJ~%M&zQUb{w+99W9vc{-kIlyi2D+Pg=~~_%?KwsQ31<_Cb9WxY&i+sNuyXtE)i3@0=20}_&jv;f4`ke&t0=@=KM(2! z4G4U8VYyNfLgD&3R%iv)Xp`rufy{M%CWQ!M?z78Go5FJMx$^w+iW$;wM7BhnRXSwG?r`g7i8;{2L({OniZ^5 zEi9E9%*m-n;vd=O%QneGvK6~4w@TG!7MenE6W@k|ok9uL8(?#1hT*g3;K`FudGNXD z&FgW~YS`4Y9F@zfQNTxl@Ml;N3X_4(qQN5};OlsfY;tLzVrc~lvjk_4r)uR&Dg)V@ zVd>`H>dxNg){CsVy4l`li}P%6eRps747;(qy9?blonz@&EA`f=(+pHfpFMk)6?ZnD zf4;NM_O{XQJEF01b4w^_cUm-XrOXx!jq_v==7S0pJ$MCZK}V-k40PboPKWQBAqn2H01l7~54w>bB#pP-hhZ;1peAH>Sz+83( ze|zjI{`UE(TBTWPUCLfARF+HQY``BJ8XVX>2Qlm%HYB0}{{I}wyN(3CBt{wg;J%?zzx@~m776rp;0Q4DPeA+1)G;L084=LoUH|oYN3J`=HXDTvdvxg z!p{2o8TS0mJ$7Szb8ByXhZoxt#b)eLLf3z|D ziGhJ9*IqjIFxRY|q0S@FUidRI`Ve}aJu)^j@^BUOA3aKHYX4gUnd#|XQYd(4%3-A| z^%jFPHQ+HYFsT#|2#OR;C0l+QIZhb-+E|h{z9Qq34*02DX$ORqT|a! z#9hyy$T0`!!!~hlt9zTtvTDPm9EFHvKS2{!Ay?SA7jg!0F8Twwi zGl;$mok#I^C;M&j&vRwGy-{u7{rLXZ2Qo7ro3G5y{@O){{s+e3gST&%}q_`XC}j^d($^bL{e=AiMekewDTc%yfygbgVXmL zps%ax3tuQgU*0b1>%M3D-jh#-X$-Akl8W5pdQW7$^gv{MsSUovjIWU7(|`CwY>U>r zSMmHhXUVsq3tUzS78wMXi~SS~!leep9|Fxk;f~Pf194*p-VS#V>Llk=KJzC0`((nX zUlFBV%$<=e2qR8H?#^(1Mo)Pu_1v0}!X?!~c1%3EjIFpUligsVeRpMI|A&EpYQ^pD zzZ*=Bz5z!QYWYNv52g-oueCdmlPdVw-6as5E0DjsxHKk|!GCo=22K5b^#2R>t{mxp zEjUs;_`=fQ8^I9(KC=IlAm4cs{VT&Sz5Rt?`0&u52E!QnSvZ*8AdeyW{XaWum<0I5 zE62MlPjrLh!4n6!$EmZua;&>D+6|5cqX%E4)q`W0dTjsQjW>ehcsjoSmH|VOVr8tm z7L0)u*evUA9sRxb%E|7^iEeN*IB{_MSilZlKiA#Bf5AxrIl2EIJ%OYFBn==d83E!{ zcjf7Ba4LBE;BSM>#@NPjykPpN{U00CM}~iuRva08GMEdVA+4*hIt_rQ1y-{(dk(Yb z_WyMt<2#NrQ~u8_scAc9lww*$xX+O>t}N{s+^ zWD5L7D%yb~gK%uIbpbxwv{2WM6ShrC6^F~yyp zv`opm@xdv0a}LYF6P=typwb($Ec%z&Gub%?6Q&VMtg*G1gf4OS>rC_*YVn^FJa z(Am*}fkA_RWq5l2Fv8Q<9@-eb_EpZ#>BmUIZ=dZvUij?R&wliW_%Ar}-Pb#77vK5( z#oy|zLDoqVKv;+Gj0B^Qyy33Y1^*O`p4xx+r~vbRF3h(l+FOI9&gBPb3P{8gn0g#j zp#+4WzZD$UQ{CZUEI58}`&<--vG2aoSzCJN^GhKL3}OvU#{lOf3H=zvY;6A@19l2p z0GjT^=$j+wMk@RHwL>fEc8~_zKfwCpq5W93w4n=gLgC|d*IA+?@D-HWRSD`^cfhOcl3~1;bd{wR0~*PXJ_>lb_x==qZo4n zoY^B(m#hib8%&jB93x7YiChlx94P_LaE($Oc|M(J3G*sDplTQu#8V+ql*EVh-$?rK z($Jlu-#zr^#i2Wo3CI8Yhd$mOkxckh#l~ts6s$&82Da$p;OqNe8OS)39xDb)8Ny|# zX@Vv+o1{{XWiD4s)jC4j`Z$9k0FX&M7^3~j)g4NnvAtJrth4K@yX)}%$5S#*6-hfN zbI)4ZuD672)(fUM4t(~ZD2e(9PFiY3-blY<^T~j#i`W%J8yOk8h^I|3H?`mo&P4X9 zkBb-w-|L%a@F{5j8PL!pmo#XW7NC+QLAEQc;QU3fWR4X}70T`+Op{bA_UQ$Xh3dCJow65-d~{S zAZ8CyciF4+V2e*L1i?fZsuEV|)nao=zfb04@92+Cn3*=;^V95>%9KLI^R)Hq)*5o% zpPDNaFBi-6t!yp(+ytiu4mb!G$X|2vE~dbRa$t*Nh?N$TL2G%+NO{(%5ra%JFFMc29jUfq))JeWNc)= z#CV`=vbZB%4W0beYGLr}XQC#kH_yL2JTg22gCvy%=kEt#`VGI#=Gp4k6S1@t(8 z9tY6l66lF8{NLb2Fs6Z?z=RV7^ziox=*Zx&1XF>3a2pVWm){;4JsHdf`Gebw!84s9 zkmp0exnS<#_J^_Pxv`anZcqe;7C@om%K2_^4gk;Xe?M3_wNfMsogW3o2kdXNs7MmCKZ>HW8Zr=x19^Z1jU$F~ms z1j~%1KO9`t2l(0q9Z#i8O@reB9NdF1pFR2#UcWOk_>rI$Tt4`6{irb4Kl_H|sQ*D9 zHR-;UT2R3{!38)ZjrMnmQ5e*2A5y{`Q4Sv-Tglq$V?&6i=e&Mx-efv z9t4&+@&*ZyzVSXX)IpWykniO-I|o6ODmE9%2#4KA#Cz>pZ9b^YyNGTl z!xt|v-3M<QMC&@BD9kxI_MieOVB`%91&mzy11aEyo;9?vStOxEr6ba^ zwL-Nd^0LddXUnx>7OBS;!YRtb3ddb0xaTXSLT$NDDeh|XG!m>&qeOLR>wgA5ARHz< ziFy+BqcHSco-KWw{8P4Asx_}x5n!QCA&aMQ;ci{KR@mEqd10rryT^^u47^ADgTTZn z>O_+93rM)nFE_G$01rHX%EJRlNYsJI@Bnw7yaePpM3s~70qiNj(giof%_E1%M}bh{ z&jqZ}#V3kW@IW9=JeA*sMWNKY3lXSZ=FhM~$t^fYRC9(SI!u{3A|~!J!=+FwK_$}# zF-SiQc^Ubxxm$PjQmm8h0QP8}AL8(c>m{eu)XK<=jw56HSjd*mrmBz$w}&igAH zV{cq+-+g`m$CXq2|4sgyhzDg2s0T*s6i^tY`ifZ@aNi9SYjmvpm=I1 zo}wBV9>8HXk;@+};{-=>rfLt=4-<#XCw#i71e&ZVBu_-YOJV4fy=dAgV$_od1%l zY-TO}94JX8@!KDuNQSz_P@&2G-Aop$!G9ec^KS1kNuB6GTOh0^;YDp3c`ljXf>Dr0 z2?;Yj0AYyi*H#Rvx%r@4r>F-;`}|V#YV-Uuwy*2EVHtRmm7u4fZw+!&oj5@%agZ>g zi=`H?pd>~pV)i98*nbA~)ktbgZ6(7`9_3tqx;PVQ`NE8w9!V&m8?ivT*-F)L%LdU= z6z28qwe{@to$c#whO0K6)yd}S_;O0u{r1l?b!@NDi1 zU|)f*zYNb~jvzJX(pZDvRH{=3>=zFm;Oi_y1!fl60is)&UZhE|vDBqy*mh%stT4|r zbxWmj{3EXNKnnH!B-vz^4~4o)mb^qMF;eFe)tpGhCRT(nH*5 zt#0k@vdyjC%{3&3ASjFr$}U^oSy$4szBZ9gVP(Pg37oW~XB6M?D|nY^v$5N0;m|^} zxB!rqQVZOU2e^yyG*Wb10{&zxAcsa?&;YaY!q`NP2v}-x*3FQwPVd6VgIVSKz4}w} z0r1WcO8|`wsej0KV-aBaB6tL5#Fy|;7WwK_u^0Fd)*LZx6GHP*pzq`-Njzv^3Sdo7 zS?w{pMJRE-NxpiS=JK`6l&9yw8Kf$k}0TnL!pcaCIt56VE{}gQ4Db+E>uG9lgSiOQX zt$Xt(hOo#{6p_`EU|d*uz7>H1datacXa&06F1d-Ic zNqf}URY#QeVqsrlK=pNw3UUA$dGbhM2wdcRloF%#Lc&)}L9#@RP#h*ZXy3$v%IFvm%YG>ROhmxdo0j#4vo$y1q9#7DM9!cbd>Qz<7RQ4~D| z1Oj3xawuv9t^q}*1X*L%Lm8p)1W|mFbJcpd94TA$dU=v55=99E{$`Z#QLa_OsQ4Ss zumFMtl$sPhUe%__El1}gRFX{^3*>N8hJu)pJf~K`Wf%iZNs6w_o5#nIZM0j-9GU5`cpwSa|RfKE)4ej-tOasSdzF5kb#3McsjR zQ(e$+QDLVtykc6qNE$AxC#db~22<`Gq%&^ zbwdS77y1*viK`VP-A)o~x=@fBoT-*w+*Vgz(2xe_xzLkhtMX7>Drs=qx=@qqN$=l< zGZ^JmS8GK#)QT>&V#r|%29Qu|kZO$B4HpVhAxO?(l%-uLN)uzK%h(8YBpSRX3YEuddg@$t5I z+Kry2=%pKytMC>DEU}8wYkx6NO)P4llvsjDtno8nXe-9#1Zai0`sDKo&y)tKx(w`% zMgx1*V_iyjXe*IeO2JT{#;#POv1-o|Nm3;UqJYIeHIjVS`b`bvt$aRDIrigt4*2 z3JOl&Mf9Mk*c*i9i*Q`@3Iem}3Rmjm7hggq~=C*R2Ly80e@M^%+jlT3yJa8esc0NXgeTS~T4Fe3Mjy)P`P(>Qd^a zvX%6NGEoN!mpmkF3@|!y?M~D?D4AgN;QpPegv2{C_>w`BO|WTN&zM9mG52eYR$R|k zpi<^|@<1gphu0O2dGJ5=#MnG5cJM*f$;XjH)NTO>-_zD(MIl9TdXLQ_k7AIIGdu4HV0poXb-U$rD4iA)F9fCW?VU z3uGI@N%0<3%nOT>jHrjl1r-6NZ7yXh`p&f;0WV+i&6!)^X^P~gk*ToYfOLh8wDcuL zOp2w1}<8sOT80rH~e}&9WW>)zfU}?I0Ht=`)E%^)<_C4t=pzGm3#D zmDp@uut+w+5aqXil0j8CE8r-m<}Q%0QpeZhfT%EM1xiWL7)B;+`i_-tw%zQ}eMjpo z=vixDZwJ8P+3BPLpf85mK*6+Gm$BP72ia*WM8p2Z$OHqY&LC;4sLmJRL6e#6hK#;1 z-Nz&m)WqqEIFj@B+a5-^TdoD+egTHv$#I;*4`sKo&@&@g%C{$cT~+{xqA(hFk=Ybe7>@%rqkN;e|siZC~89mU1 zCG9Ct_TZ2z=eZJWYKWqIptyDLZqdD}FYKJ;O@Iwm~;Q?HZM) zs_rC1dUjKq^6a+Mvj>_UzXp{Qd(W_vu`L*8(%d<$q)lUbb~8y`_fYU2{o;vs`C^OS z%jSFd0UgX(aRn$dUn(68M#z*!w46xj0;0(Jpq_r zD-A;miS5PqKqj~k+u9ARXBb#>AF!d;eb_CiXXH*}5TjfY+k!oN>X|pbOpx{rsE0dl z+I;k43cH!}3^Ny7(9mYFP1x<6XSZ{nJtXvC%dBT$HD>t5I;&cxAF~U&%tYU}Cp!5L z0QMGe-yYKWl<2hayKfKbd>EWwrroz&nUrsj$9z~BD;D-h%O_J}NL7qnm>Shf$pVOP zm>PqRd{~CK8`t@E z)8*UaGvBaWF@o7mlMmC>14riDqc7^ZhyUioaP@?0w^}}|R)oN@4cKEazmM5Mmz{U< zqo!8g%~4X)5GF%a<@o*Pq#vC#;xBUx)YqRgb9Td*i^W>x(~3JYsT}^tGq`drevP8f zx8}vKpj>(n->eV6b)JI#)n7XQMSip1{9-+_`Tq~TS&#qg%W?}pWmRv+egp(0s$XrC y7caE%zx%nky|Klb^7p&&8>Cm(ceX#p=C^ll;KzFCC%o{JBQyCtj*xy<>i+<)jBRBA literal 0 HcmV?d00001 diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ new file mode 100644 index 00000000..54b3a46f --- /dev/null +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "23-Jun-88 16:06:34" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;6 46489 |changes| |to:| (VARS MAIKO-GC-TESTSCOMS) (FNS MAIN-GC-TEST ARRAY-STRING-TEST VARIOUS-TYPES-TEST LIST-MANIPULATION-TEST CODE-RECLAIM-TEST) |previous| |date:| "27-May-88 14:59:01" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;5) ; Copyright (c) 1988 by John Sybalsky & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT MAIKO-GC-TESTSCOMS) (RPAQQ MAIKO-GC-TESTSCOMS ((FILES DANCEROBJ GCHAX) (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>")) (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))) (FNS MAIN-GC-TEST) (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS ARRAY-STRING-TEST VARIOUS-TYPES-TEST) (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST) (FNS ATOM-FULL-TEST STORAGE-FULL-TEST) (COMS (FNS DATATYPE-TEST) (RECORDS GC-TEST-TYPE) (* |;;| "DATATYPE TESTS") ) (COMS (* |;;| "CODE RECLAIMATION TESTS") (FNS CODE-RECLAIM-TEST) (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.") (VARS (CODE-RECLAIM-TEST-TEMP-FN '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) (LET (I) (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (CL:FLET ((TEMP (ARG) (SETQ ARG (FLOAT ARG)) (EXPT (SQRT I) (SQRT (COS (/ I 180)))))) (CL:UNWIND-PROTECT (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) (SETQ I NIL))))))))))) (FILESLOAD DANCEROBJ GCHAX) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)) (DEFINEQ (MAIN-GC-TEST (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT CODE-COUNT) (* \; "Edited 23-Jun-88 13:30 by jds") (DRIBBLE (OR DRIBBLE-FILE "{LPT}")) (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE) T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}") T T) (|for| I |from| 1 |to| (OR LIMIT 10) |do| (PRINTOUT T "Starting Maiko GC tests, pass " I T) (ITEMS-ON-STACK-TEST (OR STACK-COUNT 100)) (MANY-BIGNUM-MAKER (OR BIGNUM-COUNT 1000)) (MANY-FIXP-MAKER (OR FIXP-COUNT 1000)) (MANY-FLOAT-MAKER (OR FLOAT-COUNT 1000 )) (TEDIT-CRUNCH-TEST (OR TEDIT-COUNT 5)) (ARRAY-STRING-TEST 3) (LIST-MANIPULATION-TEST (OR LIST-COUNT 5)) (BOUNDARY-TESTS) (CODE-RECLAIM-TEST (OR CODE-COUNT 20)) (VARIOUS-TYPES-TEST (OR TYPE-COUNT 10) ) (FRPTQ 100 (RECLAIM)) (STORAGE)) (ATOM-FULL-TEST) (STORAGE-FULL-TEST) (DRIBBLE NIL))) ) (DEFINEQ (ITEMS-ON-STACK-TEST (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:56 by jds") (PRINTOUT T " Starting ITEMS-ON-STACK test for " LIMIT " iterations." T) (FOR I FROM 1 TO LIMIT DO (LET ((X (CREATE CHARLOOKS)) (Y (EXPT 1234.5 (RAND 3 7)))) (ERSETQ (FRPTQ 5 (RECLAIM)) (COND ((\\ISONFREELIST X) (HELP "X is free, but pointer is on stack." )) ((\\ISONFREELIST Y) (HELP "Y is free, but pointer is on stack." )))))))) (MANY-BIGNUM-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") (PRINTOUT T " Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 12345678901234567890 (RAND 1 I))) (SETQ Y (IQUOTIENT X 3)) (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) (IREMAINDER Y 3) (CL:FLOOR Y 2) (CL:CEILING X 8))) (SETQ W (/ Z Y)))))) (MANY-FIXP-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") (PRINTOUT T " Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 543 (RAND 1 I))) (SETQ Y (IQUOTIENT X 3)) (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) (IREMAINDER Y 3) (CL:FLOOR Y 2) (CL:CEILING X 8))) (SETQ W (/ Z Y)))))) (MANY-FLOAT-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:55 by jds") (PRINTOUT T " Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (FTIMES 1.0 (RAND 0 1))) (SETQ Y (+ (SQRT I) (EXPT (SQRT (SQRT I)) 3.4))) (SETQ Z (LOG Y)))))) (BOUNDARY-TESTS (LAMBDA NIL (* \; "Edited 26-May-88 11:54 by jds") (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.") (PRINTOUT T " Starting Refcnt-63 crossing test" T) (LET* ((ITEM (|create| FMTSPEC)) (LIST (|for| I |from| 1 |to| 62 |collect| ITEM))) (|for| I |from| 1 |to| 1000 |do| (|for| J |from| (LENGTH LIST) |to| (+ 63 (RAND 1 10)) |do| (SETQ LIST (CONS ITEM LIST))) (|for| J |from| (LENGTH LIST) |to| (- 63 (RAND 3 12)) |do| (|pop| LIST)) (COND ((ZEROP (IMOD I 31)) (RECLAIM)))) (PRINTOUT T " Starting Refcount-500K <-> NIL test." T) (|for| LOOP |from| 1 |to| 10 |do| (|for| I |from| 1 |to| 500000 |do| (SETQ LIST (CONS ITEM LIST))) (SETQ LIST NIL)) (PRINTOUT T " Starting Refcount 1-2 boundary test." T) (LET ((ITEM (LIST (|create| FMTSPEC)))) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (CAR ITEM)) (SETQ ITEM2 NIL))) (PRINTOUT T " Starting Refcount 1 + stack boundary test." T) (LET ((ITEM (|create| FMTSPEC)) ITEM2) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (LIST ITEM)) (RPLACA ITEM2 NIL))) (PRINTOUT T " Starting Refcount 0-1 boundary test." T) (LET (ITEM) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM (LIST (|create| FMTSPEC))) (RPLACA ITEM NIL)))))) (ARRAY-STRING-TEST (LAMBDA (LIMIT REAL-STRESS) (* \; "Edited 23-Jun-88 12:23 by jds") (* |;;| "Try out array & string creation, and substringing on the GC.") (PRINTOUT T " Starting Array & String test." T) (FOR I FROM 1 TO (OR LIMIT 10) DO (LET (STRINGS ARRAYS) (FOR ARRAY-COUNT FROM 1 TO 5000 COLLECT (CL:MAKE-ARRAY (RAND 10 (COND (REAL-STRESS 65000) (T (IMAX 100 (IQUOTIENT 65000 ARRAY-COUNT))))))) (FOR I FROM 1 TO 5000 COLLECT (BITMAPCREATE (RAND 1 512) (RAND 1 512))) (SETQ STRINGS (FOR STRING-COUNT FROM 1 TO 5000 COLLECT (ALLOCSTRING (RAND 10 (COND (REAL-STRESS 65000) (T (IMAX 100 (IQUOTIENT 65000 STRING-COUNT )))))))) (FOR STRING IN STRINGS COLLECT (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING) 1)) (RAND (ADD1 (LRSH (NCHARS STRING) 1)) (NCHARS STRING)))))))) (VARIOUS-TYPES-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 12:04 by jds") (* |;;|  "Run thru creation and collection of various types that have caused trouble in the past. ") (PRINTOUT T " Starting various type cases." T) (FOR REPEAT-COUNT FROM 1 TO (OR LIMIT 10) DO (|for| TYPE IN '(VMEMPAGEP) AS CREATION-LIMIT IN '(100) |do| (FOR I FROM 1 TO CREATION-LIMIT COLLECT (NCREATE TYPE)) (DORECLAIM))))) ) (DEFINEQ (TEDIT-CRUNCH-TEST (LAMBDA (LIMIT) (* \; "Edited 27-May-88 13:06 by jds") (* |;;| "GC Testing -- stressing the world.") (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.") (PRINTOUT T " Starting TEDIT-CRUNCH test for " LIMIT " iterations." T) (FOR PASS FROM 1 TO LIMIT DO (PRINTOUT T " Round " PASS " started " (DATE) "." T) (LET ((TS (OPENTEXTSTREAM ' |{ERIS}GC>Hand-Aux>ADVDICT-N-Z.TEDIT| )) TLIST) (TEDIT.HARDCOPY TS '{CORE}FOO.IP T) (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP) (DELFILE '{DSK}FOO.IP) (DELFILE '{CORE}FOO.IP) (CLOSEF (FETCH (TEXTOBJ TXTFILE) OF (TEXTOBJ TS))))))) (LIST-MANIPULATION-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 14:03 by jds") (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.") (PRINTOUT T " Starting LIST-MANIPULATION test for " LIMIT " iterations." T) (|for| PASS |from| 1 |to| LIMIT |do| (PRINTOUT T " Round " PASS " started " (DATE) "." T) (LET ((TS (OPENTEXTSTREAM '|{ERIS}Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|)) (LEN (RAND 0 100000)) TLIST) (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| TS)) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH LEN 1))) |do| (|pop| TLIST)) (|for| I |from| 1 |to| (RAND 1 100) |do| (SETQ TLIST (CONS TS TLIST))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (|for| I |from| 1 |to| (RAND 1 2000) |do| (SETQ TLIST (CONS TS TLIST))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (|for| \i |from| 1 |to| (RAND 1 1500) |do| (SETQ TLIST (NCONC TLIST (|for| J |from| 1 |to| (RAND 1 10) |join| (|for| K |from| 1 |to| 3 |collect| (CONS TS K)))))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (CLOSEF (|fetch| (TEXTOBJ TXTFILE) |of| (TEXTOBJ TS)))) (LET ((GC-ITEM (NCREATE 'VMEMPAGEP)) (LEN (RAND 10 500)) TLIST ELT) (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| NIL)) (|for| I |from| 1 |to| LEN |do| (SETQ ELT (CL:RANDOM LEN)) (RPLACA (CL:NTHCDR ELT TLIST) GC-ITEM) (RPLACA (CL:NTHCDR (SUB1 I) TLIST) GC-ITEM)) (|for| I |from| (SUB1 LEN) |to| 0 |by| -1 |do| (RPLACD (CL:NTHCDR I TLIST) GC-ITEM)))))) ) (DEFINEQ (ATOM-FULL-TEST (LAMBDA NIL (* \; "Edited 26-May-88 11:39 by jds") (PRINTOUT T " Starting ATOM-space full test.") (LET ((CUR-ATOM-COUNT |\\AtomFrLst|)) (CL:UNWIND-PROTECT (PROGN (SETQ |\\AtomFrLst| 64000) (FOR I FROM 64000 TO 70000 DO (GENSYM 'GC-TEST))) (SETQ |\\AtomFrLst| CUR-ATOM-COUNT))))) (STORAGE-FULL-TEST (LAMBDA NIL (* \; "Edited 26-May-88 11:47 by jds") (PRINTOUT T " Starting Storage-full test." T) (ERSETQ (FOR I FROM 1 COLLECT (ARRAY 100))))) ) (DEFINEQ (DATATYPE-TEST (LAMBDA (LIMIT) (* \; "Edited 26-May-88 11:26 by jds") (FOR I FROM 1 TO (OR LIMIT 10) DO (FOR L FROM 1 TO 100 DO (FOR Y FROM 1 TO 20 COLLECT (CREATE GC-TEST-TYPE FIELD-1 _ T)) (RECLAIM))))) ) (DECLARE\: EVAL@COMPILE (DATATYPE GC-TEST-TYPE (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE) (FIELD-5 FIXP) FIELD-6 (FIELD-7 WORD) FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14 FIXP) FIELD-15 (FIELD-16 XPOINTER) FIELD-17 (FIELD-18 BYTE) (FIELD-19 FIXP) FIELD-20 (FIELD-21 BYTE) FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE) FIELD-26 (FIELD-27 BYTE) FIELD-28 (FIELD-29 BYTE) FIELD-30 (FIELD-31 WORD) FIELD-32 (FIELD-33 XPOINTER) FIELD-34 (FIELD-35 FIXP) FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG) FIELD-40 (FIELD-41 FLAG) FIELD-42 (FIELD-43 FIXP) (FIELD-44 FIXP) FIELD-45 (FIELD-46 XPOINTER) FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG) (FIELD-51 BYTE) FIELD-52 FIELD-53 (FIELD-54 BYTE) FIELD-55 FIELD-56 (FIELD-57 BYTE) (FIELD-58 WORD) FIELD-59 FIELD-60 (FIELD-61 XPOINTER) FIELD-62 FIELD-63 (FIELD-64 XPOINTER) (FIELD-65 XPOINTER) FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG) FIELD-71 FIELD-72 (FIELD-73 WORD) FIELD-74 (FIELD-75 FLAG) FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP) (FIELD-81 FIXP) FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER) (FIELD-87 BYTE) (FIELD-88 XPOINTER) FIELD-89 (FIELD-90 BYTE) (FIELD-91 FLAG) (FIELD-92 FIXP) (FIELD-93 FIXP) (FIELD-94 FLAG) FIELD-95 (FIELD-96 FLAG) FIELD-97 (FIELD-98 FLAG) FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 XPOINTER) FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE) FIELD-110 (FIELD-111 WORD) FIELD-112 (FIELD-113 XPOINTER) (FIELD-114 FLAG) (FIELD-115 FIXP) FIELD-116 FIELD-117 (FIELD-118 BYTE) FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 XPOINTER) (FIELD-125 BYTE) (FIELD-126 XPOINTER) FIELD-127 FIELD-128 (FIELD-129 FIXP) (FIELD-130 FLAG) FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD) (FIELD-136 FLAG) FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD) (FIELD-141 FLAG) FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP) FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG) FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP) FIELD-156 (FIELD-157 BYTE) FIELD-158 (FIELD-159 FIXP) (FIELD-160 WORD) FIELD-161 (FIELD-162 WORD) (FIELD-163 FIXP) FIELD-164 (FIELD-165 FIXP) FIELD-166 (FIELD-167 FLAG) (FIELD-168 BYTE) FIELD-169 FIELD-170 (FIELD-171 XPOINTER) (FIELD-172 BYTE) FIELD-173 FIELD-174 (FIELD-175 FLAG) (FIELD-176 BYTE) (FIELD-177 WORD) FIELD-178 (FIELD-179 FIXP) FIELD-180 FIELD-181 (FIELD-182 BYTE) FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE) (FIELD-189 FIXP) FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE) FIELD-194 (FIELD-195 WORD) FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD) FIELD-201 (FIELD-202 FLAG) FIELD-203 (FIELD-204 XPOINTER) FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG) FIELD-209 (FIELD-210 WORD) (FIELD-211 BYTE) FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP) FIELD-216 FIELD-217 (FIELD-218 XPOINTER) FIELD-219 (FIELD-220 FLAG) FIELD-221 (FIELD-222 FLAG) (FIELD-223 WORD) (FIELD-224 FLAG) (FIELD-225 WORD) FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 XPOINTER) FIELD-232 (FIELD-233 WORD) (FIELD-234 WORD) FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 FIELD-241 (FIELD-242 XPOINTER) FIELD-243 (FIELD-244 WORD) FIELD-245 FIELD-246 (FIELD-247 XPOINTER) FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER) FIELD-259 (FIELD-260 FIXP) FIELD-261 FIELD-262 (FIELD-263 XPOINTER) FIELD-264 (FIELD-265 WORD) (FIELD-266 FLAG) FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE) FIELD-273 FIELD-274 (FIELD-275 FLAG) (FIELD-276 BYTE) FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER) (FIELD-281 WORD) (FIELD-282 WORD) FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD) FIELD-287 (FIELD-288 XPOINTER) (FIELD-289 BYTE) FIELD-290 (FIELD-291 XPOINTER) (FIELD-292 FLAG) FIELD-293 FIELD-294 (FIELD-295 FLAG) FIELD-296 FIELD-297 (FIELD-298 XPOINTER) (FIELD-299 FIXP) (FIELD-300 FIXP) (FIELD-301 BYTE) FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP) FIELD-307 (FIELD-308 FLAG) (FIELD-309 FIXP) FIELD-310 (FIELD-311 XPOINTER) FIELD-312 FIELD-313 (FIELD-314 BYTE) FIELD-315 (FIELD-316 WORD) (FIELD-317 FIXP) FIELD-318 (FIELD-319 FLAG) FIELD-320 (FIELD-321 WORD))) ) (/DECLAREDATATYPE 'GC-TEST-TYPE '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER FLAG POINTER WORD) '((GC-TEST-TYPE 0 POINTER) (GC-TEST-TYPE 2 POINTER) (GC-TEST-TYPE 4 POINTER) (GC-TEST-TYPE 4 (BITS . 7)) (GC-TEST-TYPE 6 FIXP) (GC-TEST-TYPE 8 POINTER) (GC-TEST-TYPE 10 (BITS . 15)) (GC-TEST-TYPE 12 POINTER) (GC-TEST-TYPE 14 POINTER) (GC-TEST-TYPE 16 POINTER) (GC-TEST-TYPE 18 POINTER) (GC-TEST-TYPE 20 POINTER) (GC-TEST-TYPE 22 POINTER) (GC-TEST-TYPE 24 FIXP) (GC-TEST-TYPE 26 POINTER) (GC-TEST-TYPE 28 XPOINTER) (GC-TEST-TYPE 30 POINTER) (GC-TEST-TYPE 30 (BITS . 7)) (GC-TEST-TYPE 32 FIXP) (GC-TEST-TYPE 34 POINTER) (GC-TEST-TYPE 34 (BITS . 7)) (GC-TEST-TYPE 36 POINTER) (GC-TEST-TYPE 38 POINTER) (GC-TEST-TYPE 40 POINTER) (GC-TEST-TYPE 40 (BITS . 7)) (GC-TEST-TYPE 42 POINTER) (GC-TEST-TYPE 42 (BITS . 7)) (GC-TEST-TYPE 44 POINTER) (GC-TEST-TYPE 44 (BITS . 7)) (GC-TEST-TYPE 46 POINTER) (GC-TEST-TYPE 11 (BITS . 15)) (GC-TEST-TYPE 48 POINTER) (GC-TEST-TYPE 50 XPOINTER) (GC-TEST-TYPE 52 POINTER) (GC-TEST-TYPE 54 FIXP) (GC-TEST-TYPE 56 POINTER) (GC-TEST-TYPE 58 POINTER) (GC-TEST-TYPE 60 POINTER) (GC-TEST-TYPE 60 (FLAGBITS . 0)) (GC-TEST-TYPE 62 POINTER) (GC-TEST-TYPE 62 (FLAGBITS . 0)) (GC-TEST-TYPE 64 POINTER) (GC-TEST-TYPE 66 FIXP) (GC-TEST-TYPE 68 FIXP) (GC-TEST-TYPE 70 POINTER) (GC-TEST-TYPE 72 XPOINTER) (GC-TEST-TYPE 74 POINTER) (GC-TEST-TYPE 76 POINTER) (GC-TEST-TYPE 78 POINTER) (GC-TEST-TYPE 78 (FLAGBITS . 0)) (GC-TEST-TYPE 76 (BITS . 7)) (GC-TEST-TYPE 80 POINTER) (GC-TEST-TYPE 82 POINTER) (GC-TEST-TYPE 82 (BITS . 7)) (GC-TEST-TYPE 84 POINTER) (GC-TEST-TYPE 86 POINTER) (GC-TEST-TYPE 86 (BITS . 7)) (GC-TEST-TYPE 88 (BITS . 15)) (GC-TEST-TYPE 90 POINTER) (GC-TEST-TYPE 92 POINTER) (GC-TEST-TYPE 94 XPOINTER) (GC-TEST-TYPE 96 POINTER) (GC-TEST-TYPE 98 POINTER) (GC-TEST-TYPE 100 XPOINTER) (GC-TEST-TYPE 102 XPOINTER) (GC-TEST-TYPE 104 POINTER) (GC-TEST-TYPE 106 POINTER) (GC-TEST-TYPE 108 POINTER) (GC-TEST-TYPE 110 POINTER) (GC-TEST-TYPE 110 (FLAGBITS . 0)) (GC-TEST-TYPE 112 POINTER) (GC-TEST-TYPE 114 POINTER) (GC-TEST-TYPE 89 (BITS . 15)) (GC-TEST-TYPE 116 POINTER) (GC-TEST-TYPE 116 (FLAGBITS . 0)) (GC-TEST-TYPE 118 POINTER) (GC-TEST-TYPE 120 POINTER) (GC-TEST-TYPE 122 POINTER) (GC-TEST-TYPE 124 POINTER) (GC-TEST-TYPE 126 FIXP) (GC-TEST-TYPE 128 FIXP) (GC-TEST-TYPE 130 POINTER) (GC-TEST-TYPE 132 POINTER) (GC-TEST-TYPE 134 POINTER) (GC-TEST-TYPE 136 POINTER) (GC-TEST-TYPE 138 XPOINTER) (GC-TEST-TYPE 138 (BITS . 7)) (GC-TEST-TYPE 140 XPOINTER) (GC-TEST-TYPE 142 POINTER) (GC-TEST-TYPE 142 (BITS . 7)) (GC-TEST-TYPE 140 (FLAGBITS . 0)) (GC-TEST-TYPE 144 FIXP) (GC-TEST-TYPE 146 FIXP) (GC-TEST-TYPE 140 (FLAGBITS . 16)) (GC-TEST-TYPE 148 POINTER) (GC-TEST-TYPE 148 (FLAGBITS . 0)) (GC-TEST-TYPE 150 POINTER) (GC-TEST-TYPE 150 (FLAGBITS . 0)) (GC-TEST-TYPE 152 POINTER) (GC-TEST-TYPE 154 POINTER) (GC-TEST-TYPE 156 POINTER) (GC-TEST-TYPE 158 POINTER) (GC-TEST-TYPE 160 POINTER) (GC-TEST-TYPE 162 XPOINTER) (GC-TEST-TYPE 164 POINTER) (GC-TEST-TYPE 166 POINTER) (GC-TEST-TYPE 168 POINTER) (GC-TEST-TYPE 170 POINTER) (GC-TEST-TYPE 170 (BITS . 7)) (GC-TEST-TYPE 172 POINTER) (GC-TEST-TYPE 174 (BITS . 15)) (GC-TEST-TYPE 176 POINTER) (GC-TEST-TYPE 178 XPOINTER) (GC-TEST-TYPE 178 (FLAGBITS . 0)) (GC-TEST-TYPE 180 FIXP) (GC-TEST-TYPE 182 POINTER) (GC-TEST-TYPE 184 POINTER) (GC-TEST-TYPE 184 (BITS . 7)) (GC-TEST-TYPE 186 POINTER) (GC-TEST-TYPE 188 POINTER) (GC-TEST-TYPE 190 POINTER) (GC-TEST-TYPE 192 POINTER) (GC-TEST-TYPE 194 POINTER) (GC-TEST-TYPE 196 XPOINTER) (GC-TEST-TYPE 196 (BITS . 7)) (GC-TEST-TYPE 198 XPOINTER) (GC-TEST-TYPE 200 POINTER) (GC-TEST-TYPE 202 POINTER) (GC-TEST-TYPE 204 FIXP) (GC-TEST-TYPE 202 (FLAGBITS . 0)) (GC-TEST-TYPE 206 POINTER) (GC-TEST-TYPE 208 POINTER) (GC-TEST-TYPE 210 POINTER) (GC-TEST-TYPE 212 POINTER) (GC-TEST-TYPE 175 (BITS . 15)) (GC-TEST-TYPE 212 (FLAGBITS . 0)) (GC-TEST-TYPE 214 POINTER) (GC-TEST-TYPE 216 POINTER) (GC-TEST-TYPE 218 POINTER) (GC-TEST-TYPE 220 (BITS . 15)) (GC-TEST-TYPE 218 (FLAGBITS . 0)) (GC-TEST-TYPE 222 POINTER) (GC-TEST-TYPE 224 POINTER) (GC-TEST-TYPE 226 POINTER) (GC-TEST-TYPE 228 FIXP) (GC-TEST-TYPE 230 POINTER) (GC-TEST-TYPE 232 POINTER) (GC-TEST-TYPE 234 POINTER) (GC-TEST-TYPE 236 POINTER) (GC-TEST-TYPE 236 (FLAGBITS . 0)) (GC-TEST-TYPE 238 POINTER) (GC-TEST-TYPE 240 POINTER) (GC-TEST-TYPE 242 POINTER) (GC-TEST-TYPE 244 POINTER) (GC-TEST-TYPE 246 FIXP) (GC-TEST-TYPE 248 POINTER) (GC-TEST-TYPE 248 (BITS . 7)) (GC-TEST-TYPE 250 POINTER) (GC-TEST-TYPE 252 FIXP) (GC-TEST-TYPE 221 (BITS . 15)) (GC-TEST-TYPE 254 POINTER) (GC-TEST-TYPE 256 (BITS . 15)) (GC-TEST-TYPE 257 FIXP) (GC-TEST-TYPE 260 POINTER) (GC-TEST-TYPE 262 FIXP) (GC-TEST-TYPE 264 POINTER) (GC-TEST-TYPE 264 (FLAGBITS . 0)) (GC-TEST-TYPE 260 (BITS . 7)) (GC-TEST-TYPE 266 POINTER) (GC-TEST-TYPE 268 POINTER) (GC-TEST-TYPE 270 XPOINTER) (GC-TEST-TYPE 270 (BITS . 7)) (GC-TEST-TYPE 272 POINTER) (GC-TEST-TYPE 274 POINTER) (GC-TEST-TYPE 274 (FLAGBITS . 0)) (GC-TEST-TYPE 272 (BITS . 7)) (GC-TEST-TYPE 259 (BITS . 15)) (GC-TEST-TYPE 276 POINTER) (GC-TEST-TYPE 278 FIXP) (GC-TEST-TYPE 280 POINTER) (GC-TEST-TYPE 282 POINTER) (GC-TEST-TYPE 282 (BITS . 7)) (GC-TEST-TYPE 284 POINTER) (GC-TEST-TYPE 286 POINTER) (GC-TEST-TYPE 288 POINTER) (GC-TEST-TYPE 290 POINTER) (GC-TEST-TYPE 292 POINTER) (GC-TEST-TYPE 292 (BITS . 7)) (GC-TEST-TYPE 294 FIXP) (GC-TEST-TYPE 296 POINTER) (GC-TEST-TYPE 298 POINTER) (GC-TEST-TYPE 300 POINTER) (GC-TEST-TYPE 300 (BITS . 7)) (GC-TEST-TYPE 302 POINTER) (GC-TEST-TYPE 304 (BITS . 15)) (GC-TEST-TYPE 306 POINTER) (GC-TEST-TYPE 308 POINTER) (GC-TEST-TYPE 310 POINTER) (GC-TEST-TYPE 312 POINTER) (GC-TEST-TYPE 305 (BITS . 15)) (GC-TEST-TYPE 314 POINTER) (GC-TEST-TYPE 314 (FLAGBITS . 0)) (GC-TEST-TYPE 316 POINTER) (GC-TEST-TYPE 318 XPOINTER) (GC-TEST-TYPE 320 POINTER) (GC-TEST-TYPE 322 POINTER) (GC-TEST-TYPE 324 POINTER) (GC-TEST-TYPE 324 (FLAGBITS . 0)) (GC-TEST-TYPE 326 POINTER) (GC-TEST-TYPE 328 (BITS . 15)) (GC-TEST-TYPE 326 (BITS . 7)) (GC-TEST-TYPE 330 POINTER) (GC-TEST-TYPE 332 POINTER) (GC-TEST-TYPE 334 POINTER) (GC-TEST-TYPE 336 FIXP) (GC-TEST-TYPE 338 POINTER) (GC-TEST-TYPE 340 POINTER) (GC-TEST-TYPE 342 XPOINTER) (GC-TEST-TYPE 344 POINTER) (GC-TEST-TYPE 344 (FLAGBITS . 0)) (GC-TEST-TYPE 346 POINTER) (GC-TEST-TYPE 346 (FLAGBITS . 0)) (GC-TEST-TYPE 329 (BITS . 15)) (GC-TEST-TYPE 346 (FLAGBITS . 16)) (GC-TEST-TYPE 348 (BITS . 15)) (GC-TEST-TYPE 350 POINTER) (GC-TEST-TYPE 352 POINTER) (GC-TEST-TYPE 354 POINTER) (GC-TEST-TYPE 356 POINTER) (GC-TEST-TYPE 358 POINTER) (GC-TEST-TYPE 360 XPOINTER) (GC-TEST-TYPE 362 POINTER) (GC-TEST-TYPE 349 (BITS . 15)) (GC-TEST-TYPE 364 (BITS . 15)) (GC-TEST-TYPE 366 POINTER) (GC-TEST-TYPE 368 POINTER) (GC-TEST-TYPE 370 POINTER) (GC-TEST-TYPE 372 POINTER) (GC-TEST-TYPE 374 POINTER) (GC-TEST-TYPE 376 POINTER) (GC-TEST-TYPE 378 POINTER) (GC-TEST-TYPE 380 XPOINTER) (GC-TEST-TYPE 382 POINTER) (GC-TEST-TYPE 365 (BITS . 15)) (GC-TEST-TYPE 384 POINTER) (GC-TEST-TYPE 386 POINTER) (GC-TEST-TYPE 388 XPOINTER) (GC-TEST-TYPE 390 POINTER) (GC-TEST-TYPE 392 POINTER) (GC-TEST-TYPE 394 POINTER) (GC-TEST-TYPE 396 POINTER) (GC-TEST-TYPE 398 POINTER) (GC-TEST-TYPE 400 POINTER) (GC-TEST-TYPE 402 POINTER) (GC-TEST-TYPE 404 POINTER) (GC-TEST-TYPE 406 POINTER) (GC-TEST-TYPE 408 POINTER) (GC-TEST-TYPE 410 XPOINTER) (GC-TEST-TYPE 412 POINTER) (GC-TEST-TYPE 414 FIXP) (GC-TEST-TYPE 416 POINTER) (GC-TEST-TYPE 418 POINTER) (GC-TEST-TYPE 420 XPOINTER) (GC-TEST-TYPE 422 POINTER) (GC-TEST-TYPE 424 (BITS . 15)) (GC-TEST-TYPE 422 (FLAGBITS . 0)) (GC-TEST-TYPE 426 POINTER) (GC-TEST-TYPE 428 POINTER) (GC-TEST-TYPE 430 POINTER) (GC-TEST-TYPE 432 POINTER) (GC-TEST-TYPE 434 POINTER) (GC-TEST-TYPE 434 (BITS . 7)) (GC-TEST-TYPE 436 POINTER) (GC-TEST-TYPE 438 POINTER) (GC-TEST-TYPE 438 (FLAGBITS . 0)) (GC-TEST-TYPE 436 (BITS . 7)) (GC-TEST-TYPE 440 POINTER) (GC-TEST-TYPE 442 POINTER) (GC-TEST-TYPE 444 POINTER) (GC-TEST-TYPE 446 XPOINTER) (GC-TEST-TYPE 425 (BITS . 15)) (GC-TEST-TYPE 448 (BITS . 15)) (GC-TEST-TYPE 450 POINTER) (GC-TEST-TYPE 452 POINTER) (GC-TEST-TYPE 454 POINTER) (GC-TEST-TYPE 449 (BITS . 15)) (GC-TEST-TYPE 456 POINTER) (GC-TEST-TYPE 458 XPOINTER) (GC-TEST-TYPE 458 (BITS . 7)) (GC-TEST-TYPE 460 POINTER) (GC-TEST-TYPE 462 XPOINTER) (GC-TEST-TYPE 462 (FLAGBITS . 0)) (GC-TEST-TYPE 464 POINTER) (GC-TEST-TYPE 466 POINTER) (GC-TEST-TYPE 466 (FLAGBITS . 0)) (GC-TEST-TYPE 468 POINTER) (GC-TEST-TYPE 470 POINTER) (GC-TEST-TYPE 472 XPOINTER) (GC-TEST-TYPE 474 FIXP) (GC-TEST-TYPE 476 FIXP) (GC-TEST-TYPE 472 (BITS . 7)) (GC-TEST-TYPE 478 POINTER) (GC-TEST-TYPE 480 POINTER) (GC-TEST-TYPE 482 POINTER) (GC-TEST-TYPE 484 POINTER) (GC-TEST-TYPE 486 FIXP) (GC-TEST-TYPE 488 POINTER) (GC-TEST-TYPE 488 (FLAGBITS . 0)) (GC-TEST-TYPE 490 FIXP) (GC-TEST-TYPE 492 POINTER) (GC-TEST-TYPE 494 XPOINTER) (GC-TEST-TYPE 496 POINTER) (GC-TEST-TYPE 498 POINTER) (GC-TEST-TYPE 498 (BITS . 7)) (GC-TEST-TYPE 500 POINTER) (GC-TEST-TYPE 502 (BITS . 15)) (GC-TEST-TYPE 503 FIXP) (GC-TEST-TYPE 506 POINTER) (GC-TEST-TYPE 506 (FLAGBITS . 0)) (GC-TEST-TYPE 508 POINTER) (GC-TEST-TYPE 505 (BITS . 15))) '510) (* |;;| "DATATYPE TESTS") (* |;;| "CODE RECLAIMATION TESTS") (DEFINEQ (CODE-RECLAIM-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 11:54 by jds") (LET NIL (* |;;| "Make sure there's a definition to compile.") (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN) (EVAL CODE-RECLAIM-TEST-TEMP-FN)) (PRINTOUT T " Starting code-block reclaim test" T) (|for| I |from| 1 |to| LIMIT |do| (BKSYSBUF "ST N ") (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN)) (PRINTOUT T " Starting MAPATOMS(GETD)" T) (|for| I |from| 1 |to| LIMIT |do| (MAPATOMS (FUNCTION GETD)))))) ) (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed." ) (RPAQQ CODE-RECLAIM-TEST-TEMP-FN (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) (LET (I) (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (CL:FLET ((TEMP (ARG) (SETQ ARG (FLOAT ARG)) (EXPT (SQRT I) (SQRT (COS (/ I 180)))))) (CL:UNWIND-PROTECT (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) (SETQ I NIL))))))) (PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2908 5241 (MAIN-GC-TEST 2918 . 5239)) (5242 13684 (ITEMS-ON-STACK-TEST 5252 . 6415) ( MANY-BIGNUM-MAKER 6417 . 7289) (MANY-FIXP-MAKER 7291 . 8077) (MANY-FLOAT-MAKER 8079 . 8686) ( BOUNDARY-TESTS 8688 . 11155) (ARRAY-STRING-TEST 11157 . 13103) (VARIOUS-TYPES-TEST 13105 . 13682)) ( 13685 18528 (TEDIT-CRUNCH-TEST 13695 . 15107) (LIST-MANIPULATION-TEST 15109 . 18526)) (18529 19213 ( ATOM-FULL-TEST 18539 . 18970) (STORAGE-FULL-TEST 18972 . 19211)) (19214 19732 (DATATYPE-TEST 19224 . 19730)) (44715 45405 (CODE-RECLAIM-TEST 44725 . 45403))))) STOP \ No newline at end of file diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ new file mode 100644 index 00000000..d8df862f --- /dev/null +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 2-Aug-88 21:52:05" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;7 46959 |changes| |to:| (FNS MAIN-GC-TEST LIST-MANIPULATION-TEST CODE-RECLAIM-TEST) |previous| |date:| "23-Jun-88 16:06:34" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;6) ; Copyright (c) 1988 by John Sybalsky & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT MAIKO-GC-TESTSCOMS) (RPAQQ MAIKO-GC-TESTSCOMS ((FILES DANCEROBJ GCHAX) (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>")) (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))) (FNS MAIN-GC-TEST) (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS ARRAY-STRING-TEST VARIOUS-TYPES-TEST) (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST) (FNS ATOM-FULL-TEST STORAGE-FULL-TEST) (COMS (FNS DATATYPE-TEST) (RECORDS GC-TEST-TYPE) (* |;;| "DATATYPE TESTS") ) (COMS (* |;;| "CODE RECLAIMATION TESTS") (FNS CODE-RECLAIM-TEST) (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.") (VARS (CODE-RECLAIM-TEST-TEMP-FN '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) (LET (I) (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (CL:FLET ((TEMP (ARG) (SETQ ARG (FLOAT ARG)) (EXPT (SQRT I) (SQRT (COS (/ I 180)))))) (CL:UNWIND-PROTECT (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) (SETQ I NIL))))))))))) (FILESLOAD DANCEROBJ GCHAX) (ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)) (DEFINEQ (MAIN-GC-TEST (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT CODE-COUNT TYPE-COUNT LIST-LEN-LIMIT) (* \; "Edited 23-Jun-88 13:30 by jds") (DRIBBLE (OR DRIBBLE-FILE "{LPT}")) (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE) T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}") T T) (|for| I |from| 1 |to| (OR LIMIT 10) |do| (PRINTOUT T "Starting Maiko GC tests, pass " I T) (ITEMS-ON-STACK-TEST (OR STACK-COUNT 100)) (MANY-BIGNUM-MAKER (OR BIGNUM-COUNT 1000)) (MANY-FIXP-MAKER (OR FIXP-COUNT 1000)) (MANY-FLOAT-MAKER (OR FLOAT-COUNT 1000 )) (TEDIT-CRUNCH-TEST (OR TEDIT-COUNT 5)) (ARRAY-STRING-TEST 3) (LIST-MANIPULATION-TEST (OR LIST-COUNT 5) LIST-LEN-LIMIT) (BOUNDARY-TESTS) (CODE-RECLAIM-TEST (OR CODE-COUNT 20)) (VARIOUS-TYPES-TEST (OR TYPE-COUNT 10) ) (FRPTQ 100 (RECLAIM)) (STORAGE)) (ATOM-FULL-TEST) (STORAGE-FULL-TEST) (DRIBBLE NIL))) ) (DEFINEQ (ITEMS-ON-STACK-TEST (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:56 by jds") (PRINTOUT T " Starting ITEMS-ON-STACK test for " LIMIT " iterations." T) (FOR I FROM 1 TO LIMIT DO (LET ((X (CREATE CHARLOOKS)) (Y (EXPT 1234.5 (RAND 3 7)))) (ERSETQ (FRPTQ 5 (RECLAIM)) (COND ((\\ISONFREELIST X) (HELP "X is free, but pointer is on stack." )) ((\\ISONFREELIST Y) (HELP "Y is free, but pointer is on stack." )))))))) (MANY-BIGNUM-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") (PRINTOUT T " Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 12345678901234567890 (RAND 1 I))) (SETQ Y (IQUOTIENT X 3)) (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) (IREMAINDER Y 3) (CL:FLOOR Y 2) (CL:CEILING X 8))) (SETQ W (/ Z Y)))))) (MANY-FIXP-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") (PRINTOUT T " Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 543 (RAND 1 I))) (SETQ Y (IQUOTIENT X 3)) (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) (IREMAINDER Y 3) (CL:FLOOR Y 2) (CL:CEILING X 8))) (SETQ W (/ Z Y)))))) (MANY-FLOAT-MAKER (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:55 by jds") (PRINTOUT T " Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T) (LET (X Y Z W) (FOR I FROM 1 TO LIMIT DO (SETQ X (FTIMES 1.0 (RAND 0 1))) (SETQ Y (+ (SQRT I) (EXPT (SQRT (SQRT I)) 3.4))) (SETQ Z (LOG Y)))))) (BOUNDARY-TESTS (LAMBDA NIL (* \; "Edited 26-May-88 11:54 by jds") (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.") (PRINTOUT T " Starting Refcnt-63 crossing test" T) (LET* ((ITEM (|create| FMTSPEC)) (LIST (|for| I |from| 1 |to| 62 |collect| ITEM))) (|for| I |from| 1 |to| 1000 |do| (|for| J |from| (LENGTH LIST) |to| (+ 63 (RAND 1 10)) |do| (SETQ LIST (CONS ITEM LIST))) (|for| J |from| (LENGTH LIST) |to| (- 63 (RAND 3 12)) |do| (|pop| LIST)) (COND ((ZEROP (IMOD I 31)) (RECLAIM)))) (PRINTOUT T " Starting Refcount-500K <-> NIL test." T) (|for| LOOP |from| 1 |to| 10 |do| (|for| I |from| 1 |to| 500000 |do| (SETQ LIST (CONS ITEM LIST))) (SETQ LIST NIL)) (PRINTOUT T " Starting Refcount 1-2 boundary test." T) (LET ((ITEM (LIST (|create| FMTSPEC)))) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (CAR ITEM)) (SETQ ITEM2 NIL))) (PRINTOUT T " Starting Refcount 1 + stack boundary test." T) (LET ((ITEM (|create| FMTSPEC)) ITEM2) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (LIST ITEM)) (RPLACA ITEM2 NIL))) (PRINTOUT T " Starting Refcount 0-1 boundary test." T) (LET (ITEM) (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM (LIST (|create| FMTSPEC))) (RPLACA ITEM NIL)))))) (ARRAY-STRING-TEST (LAMBDA (LIMIT REAL-STRESS) (* \; "Edited 23-Jun-88 12:23 by jds") (* |;;| "Try out array & string creation, and substringing on the GC.") (PRINTOUT T " Starting Array & String test." T) (FOR I FROM 1 TO (OR LIMIT 10) DO (LET (STRINGS ARRAYS) (FOR ARRAY-COUNT FROM 1 TO 5000 COLLECT (CL:MAKE-ARRAY (RAND 10 (COND (REAL-STRESS 65000) (T (IMAX 100 (IQUOTIENT 65000 ARRAY-COUNT))))))) (FOR I FROM 1 TO 5000 COLLECT (BITMAPCREATE (RAND 1 512) (RAND 1 512))) (SETQ STRINGS (FOR STRING-COUNT FROM 1 TO 5000 COLLECT (ALLOCSTRING (RAND 10 (COND (REAL-STRESS 65000) (T (IMAX 100 (IQUOTIENT 65000 STRING-COUNT )))))))) (FOR STRING IN STRINGS COLLECT (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING) 1)) (RAND (ADD1 (LRSH (NCHARS STRING) 1)) (NCHARS STRING)))))))) (VARIOUS-TYPES-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 12:04 by jds") (* |;;|  "Run thru creation and collection of various types that have caused trouble in the past. ") (PRINTOUT T " Starting various type cases." T) (FOR REPEAT-COUNT FROM 1 TO (OR LIMIT 10) DO (|for| TYPE IN '(VMEMPAGEP) AS CREATION-LIMIT IN '(100) |do| (FOR I FROM 1 TO CREATION-LIMIT COLLECT (NCREATE TYPE)) (DORECLAIM))))) ) (DEFINEQ (TEDIT-CRUNCH-TEST (LAMBDA (LIMIT) (* \; "Edited 27-May-88 13:06 by jds") (* |;;| "GC Testing -- stressing the world.") (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.") (PRINTOUT T " Starting TEDIT-CRUNCH test for " LIMIT " iterations." T) (FOR PASS FROM 1 TO LIMIT DO (PRINTOUT T " Round " PASS " started " (DATE) "." T) (LET ((TS (OPENTEXTSTREAM ' |{ERIS}GC>Hand-Aux>ADVDICT-N-Z.TEDIT| )) TLIST) (TEDIT.HARDCOPY TS '{CORE}FOO.IP T) (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP) (DELFILE '{DSK}FOO.IP) (DELFILE '{CORE}FOO.IP) (CLOSEF (FETCH (TEXTOBJ TXTFILE) OF (TEXTOBJ TS))))))) (LIST-MANIPULATION-TEST (LAMBDA (LIMIT LENGTH-LIMIT) (* \; "Edited 23-Jun-88 14:03 by jds") (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.") (PRINTOUT T " Starting LIST-MANIPULATION test for " LIMIT " iterations." T) (|for| PASS |from| 1 |to| LIMIT |do| (PRINTOUT T " Round " PASS " started " (DATE) "." T) (LET ((TS (OPENTEXTSTREAM '|{ERIS}Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|)) (LEN (RAND 0 (OR LENGTH-LIMIT 100000))) TLIST) (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| TS)) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH LEN 1))) |do| (|pop| TLIST)) (|for| I |from| 1 |to| (RAND 1 100) |do| (SETQ TLIST (CONS TS TLIST))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (|for| I |from| 1 |to| (RAND 1 2000) |do| (SETQ TLIST (CONS TS TLIST))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (|for| \i |from| 1 |to| (RAND 1 1500) |do| (SETQ TLIST (NCONC TLIST (|for| J |from| 1 |to| (RAND 1 10) |join| (|for| K |from| 1 |to| 3 |collect| (CONS TS K)))))) (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) 1))) |do| (|pop| TLIST)) (CLOSEF (|fetch| (TEXTOBJ TXTFILE) |of| (TEXTOBJ TS)))) (LET ((GC-ITEM (NCREATE 'VMEMPAGEP)) (LEN (RAND 10 500)) TLIST ELT) (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| NIL)) (|for| I |from| 1 |to| LEN |do| (SETQ ELT (CL:RANDOM LEN)) (RPLACA (CL:NTHCDR ELT TLIST) GC-ITEM) (RPLACA (CL:NTHCDR (SUB1 I) TLIST) GC-ITEM)) (|for| I |from| (SUB1 LEN) |to| 0 |by| -1 |do| (RPLACD (CL:NTHCDR I TLIST) GC-ITEM)))))) ) (DEFINEQ (ATOM-FULL-TEST (LAMBDA NIL (* \; "Edited 26-May-88 11:39 by jds") (PRINTOUT T " Starting ATOM-space full test.") (LET ((CUR-ATOM-COUNT |\\AtomFrLst|)) (CL:UNWIND-PROTECT (PROGN (SETQ |\\AtomFrLst| 64000) (FOR I FROM 64000 TO 70000 DO (GENSYM 'GC-TEST))) (SETQ |\\AtomFrLst| CUR-ATOM-COUNT))))) (STORAGE-FULL-TEST (LAMBDA NIL (* \; "Edited 26-May-88 11:47 by jds") (PRINTOUT T " Starting Storage-full test." T) (ERSETQ (FOR I FROM 1 COLLECT (ARRAY 100))))) ) (DEFINEQ (DATATYPE-TEST (LAMBDA (LIMIT) (* \; "Edited 26-May-88 11:26 by jds") (FOR I FROM 1 TO (OR LIMIT 10) DO (FOR L FROM 1 TO 100 DO (FOR Y FROM 1 TO 20 COLLECT (CREATE GC-TEST-TYPE FIELD-1 _ T)) (RECLAIM))))) ) (DECLARE\: EVAL@COMPILE (DATATYPE GC-TEST-TYPE (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE) (FIELD-5 FIXP) FIELD-6 (FIELD-7 WORD) FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14 FIXP) FIELD-15 (FIELD-16 XPOINTER) FIELD-17 (FIELD-18 BYTE) (FIELD-19 FIXP) FIELD-20 (FIELD-21 BYTE) FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE) FIELD-26 (FIELD-27 BYTE) FIELD-28 (FIELD-29 BYTE) FIELD-30 (FIELD-31 WORD) FIELD-32 (FIELD-33 XPOINTER) FIELD-34 (FIELD-35 FIXP) FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG) FIELD-40 (FIELD-41 FLAG) FIELD-42 (FIELD-43 FIXP) (FIELD-44 FIXP) FIELD-45 (FIELD-46 XPOINTER) FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG) (FIELD-51 BYTE) FIELD-52 FIELD-53 (FIELD-54 BYTE) FIELD-55 FIELD-56 (FIELD-57 BYTE) (FIELD-58 WORD) FIELD-59 FIELD-60 (FIELD-61 XPOINTER) FIELD-62 FIELD-63 (FIELD-64 XPOINTER) (FIELD-65 XPOINTER) FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG) FIELD-71 FIELD-72 (FIELD-73 WORD) FIELD-74 (FIELD-75 FLAG) FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP) (FIELD-81 FIXP) FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER) (FIELD-87 BYTE) (FIELD-88 XPOINTER) FIELD-89 (FIELD-90 BYTE) (FIELD-91 FLAG) (FIELD-92 FIXP) (FIELD-93 FIXP) (FIELD-94 FLAG) FIELD-95 (FIELD-96 FLAG) FIELD-97 (FIELD-98 FLAG) FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 XPOINTER) FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE) FIELD-110 (FIELD-111 WORD) FIELD-112 (FIELD-113 XPOINTER) (FIELD-114 FLAG) (FIELD-115 FIXP) FIELD-116 FIELD-117 (FIELD-118 BYTE) FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 XPOINTER) (FIELD-125 BYTE) (FIELD-126 XPOINTER) FIELD-127 FIELD-128 (FIELD-129 FIXP) (FIELD-130 FLAG) FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD) (FIELD-136 FLAG) FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD) (FIELD-141 FLAG) FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP) FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG) FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP) FIELD-156 (FIELD-157 BYTE) FIELD-158 (FIELD-159 FIXP) (FIELD-160 WORD) FIELD-161 (FIELD-162 WORD) (FIELD-163 FIXP) FIELD-164 (FIELD-165 FIXP) FIELD-166 (FIELD-167 FLAG) (FIELD-168 BYTE) FIELD-169 FIELD-170 (FIELD-171 XPOINTER) (FIELD-172 BYTE) FIELD-173 FIELD-174 (FIELD-175 FLAG) (FIELD-176 BYTE) (FIELD-177 WORD) FIELD-178 (FIELD-179 FIXP) FIELD-180 FIELD-181 (FIELD-182 BYTE) FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE) (FIELD-189 FIXP) FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE) FIELD-194 (FIELD-195 WORD) FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD) FIELD-201 (FIELD-202 FLAG) FIELD-203 (FIELD-204 XPOINTER) FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG) FIELD-209 (FIELD-210 WORD) (FIELD-211 BYTE) FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP) FIELD-216 FIELD-217 (FIELD-218 XPOINTER) FIELD-219 (FIELD-220 FLAG) FIELD-221 (FIELD-222 FLAG) (FIELD-223 WORD) (FIELD-224 FLAG) (FIELD-225 WORD) FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 XPOINTER) FIELD-232 (FIELD-233 WORD) (FIELD-234 WORD) FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 FIELD-241 (FIELD-242 XPOINTER) FIELD-243 (FIELD-244 WORD) FIELD-245 FIELD-246 (FIELD-247 XPOINTER) FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER) FIELD-259 (FIELD-260 FIXP) FIELD-261 FIELD-262 (FIELD-263 XPOINTER) FIELD-264 (FIELD-265 WORD) (FIELD-266 FLAG) FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE) FIELD-273 FIELD-274 (FIELD-275 FLAG) (FIELD-276 BYTE) FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER) (FIELD-281 WORD) (FIELD-282 WORD) FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD) FIELD-287 (FIELD-288 XPOINTER) (FIELD-289 BYTE) FIELD-290 (FIELD-291 XPOINTER) (FIELD-292 FLAG) FIELD-293 FIELD-294 (FIELD-295 FLAG) FIELD-296 FIELD-297 (FIELD-298 XPOINTER) (FIELD-299 FIXP) (FIELD-300 FIXP) (FIELD-301 BYTE) FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP) FIELD-307 (FIELD-308 FLAG) (FIELD-309 FIXP) FIELD-310 (FIELD-311 XPOINTER) FIELD-312 FIELD-313 (FIELD-314 BYTE) FIELD-315 (FIELD-316 WORD) (FIELD-317 FIXP) FIELD-318 (FIELD-319 FLAG) FIELD-320 (FIELD-321 WORD))) ) (/DECLAREDATATYPE 'GC-TEST-TYPE '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER FLAG POINTER WORD) '((GC-TEST-TYPE 0 POINTER) (GC-TEST-TYPE 2 POINTER) (GC-TEST-TYPE 4 POINTER) (GC-TEST-TYPE 4 (BITS . 7)) (GC-TEST-TYPE 6 FIXP) (GC-TEST-TYPE 8 POINTER) (GC-TEST-TYPE 10 (BITS . 15)) (GC-TEST-TYPE 12 POINTER) (GC-TEST-TYPE 14 POINTER) (GC-TEST-TYPE 16 POINTER) (GC-TEST-TYPE 18 POINTER) (GC-TEST-TYPE 20 POINTER) (GC-TEST-TYPE 22 POINTER) (GC-TEST-TYPE 24 FIXP) (GC-TEST-TYPE 26 POINTER) (GC-TEST-TYPE 28 XPOINTER) (GC-TEST-TYPE 30 POINTER) (GC-TEST-TYPE 30 (BITS . 7)) (GC-TEST-TYPE 32 FIXP) (GC-TEST-TYPE 34 POINTER) (GC-TEST-TYPE 34 (BITS . 7)) (GC-TEST-TYPE 36 POINTER) (GC-TEST-TYPE 38 POINTER) (GC-TEST-TYPE 40 POINTER) (GC-TEST-TYPE 40 (BITS . 7)) (GC-TEST-TYPE 42 POINTER) (GC-TEST-TYPE 42 (BITS . 7)) (GC-TEST-TYPE 44 POINTER) (GC-TEST-TYPE 44 (BITS . 7)) (GC-TEST-TYPE 46 POINTER) (GC-TEST-TYPE 11 (BITS . 15)) (GC-TEST-TYPE 48 POINTER) (GC-TEST-TYPE 50 XPOINTER) (GC-TEST-TYPE 52 POINTER) (GC-TEST-TYPE 54 FIXP) (GC-TEST-TYPE 56 POINTER) (GC-TEST-TYPE 58 POINTER) (GC-TEST-TYPE 60 POINTER) (GC-TEST-TYPE 60 (FLAGBITS . 0)) (GC-TEST-TYPE 62 POINTER) (GC-TEST-TYPE 62 (FLAGBITS . 0)) (GC-TEST-TYPE 64 POINTER) (GC-TEST-TYPE 66 FIXP) (GC-TEST-TYPE 68 FIXP) (GC-TEST-TYPE 70 POINTER) (GC-TEST-TYPE 72 XPOINTER) (GC-TEST-TYPE 74 POINTER) (GC-TEST-TYPE 76 POINTER) (GC-TEST-TYPE 78 POINTER) (GC-TEST-TYPE 78 (FLAGBITS . 0)) (GC-TEST-TYPE 76 (BITS . 7)) (GC-TEST-TYPE 80 POINTER) (GC-TEST-TYPE 82 POINTER) (GC-TEST-TYPE 82 (BITS . 7)) (GC-TEST-TYPE 84 POINTER) (GC-TEST-TYPE 86 POINTER) (GC-TEST-TYPE 86 (BITS . 7)) (GC-TEST-TYPE 88 (BITS . 15)) (GC-TEST-TYPE 90 POINTER) (GC-TEST-TYPE 92 POINTER) (GC-TEST-TYPE 94 XPOINTER) (GC-TEST-TYPE 96 POINTER) (GC-TEST-TYPE 98 POINTER) (GC-TEST-TYPE 100 XPOINTER) (GC-TEST-TYPE 102 XPOINTER) (GC-TEST-TYPE 104 POINTER) (GC-TEST-TYPE 106 POINTER) (GC-TEST-TYPE 108 POINTER) (GC-TEST-TYPE 110 POINTER) (GC-TEST-TYPE 110 (FLAGBITS . 0)) (GC-TEST-TYPE 112 POINTER) (GC-TEST-TYPE 114 POINTER) (GC-TEST-TYPE 89 (BITS . 15)) (GC-TEST-TYPE 116 POINTER) (GC-TEST-TYPE 116 (FLAGBITS . 0)) (GC-TEST-TYPE 118 POINTER) (GC-TEST-TYPE 120 POINTER) (GC-TEST-TYPE 122 POINTER) (GC-TEST-TYPE 124 POINTER) (GC-TEST-TYPE 126 FIXP) (GC-TEST-TYPE 128 FIXP) (GC-TEST-TYPE 130 POINTER) (GC-TEST-TYPE 132 POINTER) (GC-TEST-TYPE 134 POINTER) (GC-TEST-TYPE 136 POINTER) (GC-TEST-TYPE 138 XPOINTER) (GC-TEST-TYPE 138 (BITS . 7)) (GC-TEST-TYPE 140 XPOINTER) (GC-TEST-TYPE 142 POINTER) (GC-TEST-TYPE 142 (BITS . 7)) (GC-TEST-TYPE 140 (FLAGBITS . 0)) (GC-TEST-TYPE 144 FIXP) (GC-TEST-TYPE 146 FIXP) (GC-TEST-TYPE 140 (FLAGBITS . 16)) (GC-TEST-TYPE 148 POINTER) (GC-TEST-TYPE 148 (FLAGBITS . 0)) (GC-TEST-TYPE 150 POINTER) (GC-TEST-TYPE 150 (FLAGBITS . 0)) (GC-TEST-TYPE 152 POINTER) (GC-TEST-TYPE 154 POINTER) (GC-TEST-TYPE 156 POINTER) (GC-TEST-TYPE 158 POINTER) (GC-TEST-TYPE 160 POINTER) (GC-TEST-TYPE 162 XPOINTER) (GC-TEST-TYPE 164 POINTER) (GC-TEST-TYPE 166 POINTER) (GC-TEST-TYPE 168 POINTER) (GC-TEST-TYPE 170 POINTER) (GC-TEST-TYPE 170 (BITS . 7)) (GC-TEST-TYPE 172 POINTER) (GC-TEST-TYPE 174 (BITS . 15)) (GC-TEST-TYPE 176 POINTER) (GC-TEST-TYPE 178 XPOINTER) (GC-TEST-TYPE 178 (FLAGBITS . 0)) (GC-TEST-TYPE 180 FIXP) (GC-TEST-TYPE 182 POINTER) (GC-TEST-TYPE 184 POINTER) (GC-TEST-TYPE 184 (BITS . 7)) (GC-TEST-TYPE 186 POINTER) (GC-TEST-TYPE 188 POINTER) (GC-TEST-TYPE 190 POINTER) (GC-TEST-TYPE 192 POINTER) (GC-TEST-TYPE 194 POINTER) (GC-TEST-TYPE 196 XPOINTER) (GC-TEST-TYPE 196 (BITS . 7)) (GC-TEST-TYPE 198 XPOINTER) (GC-TEST-TYPE 200 POINTER) (GC-TEST-TYPE 202 POINTER) (GC-TEST-TYPE 204 FIXP) (GC-TEST-TYPE 202 (FLAGBITS . 0)) (GC-TEST-TYPE 206 POINTER) (GC-TEST-TYPE 208 POINTER) (GC-TEST-TYPE 210 POINTER) (GC-TEST-TYPE 212 POINTER) (GC-TEST-TYPE 175 (BITS . 15)) (GC-TEST-TYPE 212 (FLAGBITS . 0)) (GC-TEST-TYPE 214 POINTER) (GC-TEST-TYPE 216 POINTER) (GC-TEST-TYPE 218 POINTER) (GC-TEST-TYPE 220 (BITS . 15)) (GC-TEST-TYPE 218 (FLAGBITS . 0)) (GC-TEST-TYPE 222 POINTER) (GC-TEST-TYPE 224 POINTER) (GC-TEST-TYPE 226 POINTER) (GC-TEST-TYPE 228 FIXP) (GC-TEST-TYPE 230 POINTER) (GC-TEST-TYPE 232 POINTER) (GC-TEST-TYPE 234 POINTER) (GC-TEST-TYPE 236 POINTER) (GC-TEST-TYPE 236 (FLAGBITS . 0)) (GC-TEST-TYPE 238 POINTER) (GC-TEST-TYPE 240 POINTER) (GC-TEST-TYPE 242 POINTER) (GC-TEST-TYPE 244 POINTER) (GC-TEST-TYPE 246 FIXP) (GC-TEST-TYPE 248 POINTER) (GC-TEST-TYPE 248 (BITS . 7)) (GC-TEST-TYPE 250 POINTER) (GC-TEST-TYPE 252 FIXP) (GC-TEST-TYPE 221 (BITS . 15)) (GC-TEST-TYPE 254 POINTER) (GC-TEST-TYPE 256 (BITS . 15)) (GC-TEST-TYPE 257 FIXP) (GC-TEST-TYPE 260 POINTER) (GC-TEST-TYPE 262 FIXP) (GC-TEST-TYPE 264 POINTER) (GC-TEST-TYPE 264 (FLAGBITS . 0)) (GC-TEST-TYPE 260 (BITS . 7)) (GC-TEST-TYPE 266 POINTER) (GC-TEST-TYPE 268 POINTER) (GC-TEST-TYPE 270 XPOINTER) (GC-TEST-TYPE 270 (BITS . 7)) (GC-TEST-TYPE 272 POINTER) (GC-TEST-TYPE 274 POINTER) (GC-TEST-TYPE 274 (FLAGBITS . 0)) (GC-TEST-TYPE 272 (BITS . 7)) (GC-TEST-TYPE 259 (BITS . 15)) (GC-TEST-TYPE 276 POINTER) (GC-TEST-TYPE 278 FIXP) (GC-TEST-TYPE 280 POINTER) (GC-TEST-TYPE 282 POINTER) (GC-TEST-TYPE 282 (BITS . 7)) (GC-TEST-TYPE 284 POINTER) (GC-TEST-TYPE 286 POINTER) (GC-TEST-TYPE 288 POINTER) (GC-TEST-TYPE 290 POINTER) (GC-TEST-TYPE 292 POINTER) (GC-TEST-TYPE 292 (BITS . 7)) (GC-TEST-TYPE 294 FIXP) (GC-TEST-TYPE 296 POINTER) (GC-TEST-TYPE 298 POINTER) (GC-TEST-TYPE 300 POINTER) (GC-TEST-TYPE 300 (BITS . 7)) (GC-TEST-TYPE 302 POINTER) (GC-TEST-TYPE 304 (BITS . 15)) (GC-TEST-TYPE 306 POINTER) (GC-TEST-TYPE 308 POINTER) (GC-TEST-TYPE 310 POINTER) (GC-TEST-TYPE 312 POINTER) (GC-TEST-TYPE 305 (BITS . 15)) (GC-TEST-TYPE 314 POINTER) (GC-TEST-TYPE 314 (FLAGBITS . 0)) (GC-TEST-TYPE 316 POINTER) (GC-TEST-TYPE 318 XPOINTER) (GC-TEST-TYPE 320 POINTER) (GC-TEST-TYPE 322 POINTER) (GC-TEST-TYPE 324 POINTER) (GC-TEST-TYPE 324 (FLAGBITS . 0)) (GC-TEST-TYPE 326 POINTER) (GC-TEST-TYPE 328 (BITS . 15)) (GC-TEST-TYPE 326 (BITS . 7)) (GC-TEST-TYPE 330 POINTER) (GC-TEST-TYPE 332 POINTER) (GC-TEST-TYPE 334 POINTER) (GC-TEST-TYPE 336 FIXP) (GC-TEST-TYPE 338 POINTER) (GC-TEST-TYPE 340 POINTER) (GC-TEST-TYPE 342 XPOINTER) (GC-TEST-TYPE 344 POINTER) (GC-TEST-TYPE 344 (FLAGBITS . 0)) (GC-TEST-TYPE 346 POINTER) (GC-TEST-TYPE 346 (FLAGBITS . 0)) (GC-TEST-TYPE 329 (BITS . 15)) (GC-TEST-TYPE 346 (FLAGBITS . 16)) (GC-TEST-TYPE 348 (BITS . 15)) (GC-TEST-TYPE 350 POINTER) (GC-TEST-TYPE 352 POINTER) (GC-TEST-TYPE 354 POINTER) (GC-TEST-TYPE 356 POINTER) (GC-TEST-TYPE 358 POINTER) (GC-TEST-TYPE 360 XPOINTER) (GC-TEST-TYPE 362 POINTER) (GC-TEST-TYPE 349 (BITS . 15)) (GC-TEST-TYPE 364 (BITS . 15)) (GC-TEST-TYPE 366 POINTER) (GC-TEST-TYPE 368 POINTER) (GC-TEST-TYPE 370 POINTER) (GC-TEST-TYPE 372 POINTER) (GC-TEST-TYPE 374 POINTER) (GC-TEST-TYPE 376 POINTER) (GC-TEST-TYPE 378 POINTER) (GC-TEST-TYPE 380 XPOINTER) (GC-TEST-TYPE 382 POINTER) (GC-TEST-TYPE 365 (BITS . 15)) (GC-TEST-TYPE 384 POINTER) (GC-TEST-TYPE 386 POINTER) (GC-TEST-TYPE 388 XPOINTER) (GC-TEST-TYPE 390 POINTER) (GC-TEST-TYPE 392 POINTER) (GC-TEST-TYPE 394 POINTER) (GC-TEST-TYPE 396 POINTER) (GC-TEST-TYPE 398 POINTER) (GC-TEST-TYPE 400 POINTER) (GC-TEST-TYPE 402 POINTER) (GC-TEST-TYPE 404 POINTER) (GC-TEST-TYPE 406 POINTER) (GC-TEST-TYPE 408 POINTER) (GC-TEST-TYPE 410 XPOINTER) (GC-TEST-TYPE 412 POINTER) (GC-TEST-TYPE 414 FIXP) (GC-TEST-TYPE 416 POINTER) (GC-TEST-TYPE 418 POINTER) (GC-TEST-TYPE 420 XPOINTER) (GC-TEST-TYPE 422 POINTER) (GC-TEST-TYPE 424 (BITS . 15)) (GC-TEST-TYPE 422 (FLAGBITS . 0)) (GC-TEST-TYPE 426 POINTER) (GC-TEST-TYPE 428 POINTER) (GC-TEST-TYPE 430 POINTER) (GC-TEST-TYPE 432 POINTER) (GC-TEST-TYPE 434 POINTER) (GC-TEST-TYPE 434 (BITS . 7)) (GC-TEST-TYPE 436 POINTER) (GC-TEST-TYPE 438 POINTER) (GC-TEST-TYPE 438 (FLAGBITS . 0)) (GC-TEST-TYPE 436 (BITS . 7)) (GC-TEST-TYPE 440 POINTER) (GC-TEST-TYPE 442 POINTER) (GC-TEST-TYPE 444 POINTER) (GC-TEST-TYPE 446 XPOINTER) (GC-TEST-TYPE 425 (BITS . 15)) (GC-TEST-TYPE 448 (BITS . 15)) (GC-TEST-TYPE 450 POINTER) (GC-TEST-TYPE 452 POINTER) (GC-TEST-TYPE 454 POINTER) (GC-TEST-TYPE 449 (BITS . 15)) (GC-TEST-TYPE 456 POINTER) (GC-TEST-TYPE 458 XPOINTER) (GC-TEST-TYPE 458 (BITS . 7)) (GC-TEST-TYPE 460 POINTER) (GC-TEST-TYPE 462 XPOINTER) (GC-TEST-TYPE 462 (FLAGBITS . 0)) (GC-TEST-TYPE 464 POINTER) (GC-TEST-TYPE 466 POINTER) (GC-TEST-TYPE 466 (FLAGBITS . 0)) (GC-TEST-TYPE 468 POINTER) (GC-TEST-TYPE 470 POINTER) (GC-TEST-TYPE 472 XPOINTER) (GC-TEST-TYPE 474 FIXP) (GC-TEST-TYPE 476 FIXP) (GC-TEST-TYPE 472 (BITS . 7)) (GC-TEST-TYPE 478 POINTER) (GC-TEST-TYPE 480 POINTER) (GC-TEST-TYPE 482 POINTER) (GC-TEST-TYPE 484 POINTER) (GC-TEST-TYPE 486 FIXP) (GC-TEST-TYPE 488 POINTER) (GC-TEST-TYPE 488 (FLAGBITS . 0)) (GC-TEST-TYPE 490 FIXP) (GC-TEST-TYPE 492 POINTER) (GC-TEST-TYPE 494 XPOINTER) (GC-TEST-TYPE 496 POINTER) (GC-TEST-TYPE 498 POINTER) (GC-TEST-TYPE 498 (BITS . 7)) (GC-TEST-TYPE 500 POINTER) (GC-TEST-TYPE 502 (BITS . 15)) (GC-TEST-TYPE 503 FIXP) (GC-TEST-TYPE 506 POINTER) (GC-TEST-TYPE 506 (FLAGBITS . 0)) (GC-TEST-TYPE 508 POINTER) (GC-TEST-TYPE 505 (BITS . 15))) '510) (* |;;| "DATATYPE TESTS") (* |;;| "CODE RECLAIMATION TESTS") (DEFINEQ (CODE-RECLAIM-TEST (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 11:54 by jds") (LET NIL (* |;;| "Make sure there's a definition to compile.") (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN) (EVAL CODE-RECLAIM-TEST-TEMP-FN)) (PRINTOUT T " Starting code-block reclaim test" T) (|for| I |from| 1 |to| LIMIT |do| (BKSYSBUF "ST N ") (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN)) (PRINTOUT T " Starting MAPATOMS(GETD)" T) (|for| I |from| 1 |to| LIMIT |do| (MAPATOMS (FUNCTION GETD))) (PRINTOUT T " Starting MAPATOMS(MOVD to DUMMYFN)" T) (FOR I FROM 1 TO LIMIT DO (MAPATOMS #'(LAMBDA (FN-NAME) (AND (GETD FN-NAME) (MOVD FN-NAME 'MAIKO-GC-TEST-DUMMY-FN)) )))))) ) (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed." ) (RPAQQ CODE-RECLAIM-TEST-TEMP-FN (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) (LET (I) (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (NLSETQ (DATE)) (ERSETQ (DATE)) (CL:FLET ((TEMP (ARG) (SETQ ARG (FLOAT ARG)) (EXPT (SQRT I) (SQRT (COS (/ I 180)))))) (CL:UNWIND-PROTECT (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) (SETQ I NIL))))))) (PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2794 5208 (MAIN-GC-TEST 2804 . 5206)) (5209 13651 (ITEMS-ON-STACK-TEST 5219 . 6382) ( MANY-BIGNUM-MAKER 6384 . 7256) (MANY-FIXP-MAKER 7258 . 8044) (MANY-FLOAT-MAKER 8046 . 8653) ( BOUNDARY-TESTS 8655 . 11122) (ARRAY-STRING-TEST 11124 . 13070) (VARIOUS-TYPES-TEST 13072 . 13649)) ( 13652 18513 (TEDIT-CRUNCH-TEST 13662 . 15074) (LIST-MANIPULATION-TEST 15076 . 18511)) (18514 19198 ( ATOM-FULL-TEST 18524 . 18955) (STORAGE-FULL-TEST 18957 . 19196)) (19199 19717 (DATATYPE-TEST 19209 . 19715)) (44700 45875 (CODE-RECLAIM-TEST 44710 . 45873))))) STOP \ No newline at end of file diff --git a/internal/test/GC/Hand/Maiko-GC-Tests.script b/internal/test/GC/Hand/Maiko-GC-Tests.script new file mode 100644 index 00000000..1a26243b --- /dev/null +++ b/internal/test/GC/Hand/Maiko-GC-Tests.script @@ -0,0 +1 @@ +;;; Maiko Garbage Collector Tests ;; Start a clean Maiko Full.Sysout. ;; Open an Interlisp EXEC. LOAD(GCHAX.LCOM) LOAD({ERIS}GC>HAND>MAIKO-GC-TESTS.LCOM) (STORAGE) ;; note the counts for types starting with SEDIT::. DV DIRECTORIES DV DISPLAYFONTDIRECTORIES DV INTERPRESSFONTDIRECTORIES ;; close the SEdit windows (FRPTQ 100 (RECLAIM)) (STORAGE) ;; make sure that all the SEDIT:: types got reclaimed. SHH(MAIN-GC-TEST 5) ; or any number ;; look at the dribble to make sure that things get ;; reclaimed. Specifically, look at: ;; FLOATPs ;; FIXPs ;; BIGNUMs ;; STREAMs ;; PIECEs ;; TEXTOBJs ;; VMEMPAGEPs ;; COMPILED-CLOSUREs ;; The final 2 things MAIN-GC-TEST does are to exhaust atom ;; space artificially (and restore it to its pre-existing state), ;; and exhaust storage for real. Both of these should cause errors ;; from which you can ^ to continue the test. \ No newline at end of file diff --git a/internal/test/IO/Auto/IO-REGRESSION.TEST b/internal/test/IO/Auto/IO-REGRESSION.TEST new file mode 100644 index 0000000000000000000000000000000000000000..490f0d8c8b8579753cf07ecde2b234a02d7cba10 GIT binary patch literal 1251 zcmbtUO;6iE5OoVZ5Q%$x8@Y$9Be`n&p;8x7S;T-v;vmO}wnCLQ&XBCS*v7jK1;nL4 ztG}+ZaSEoiQY9>{H6HKGd-L|$tT%L%V3dGe@KT{0`2%{2!)O=6s26;KqcGVU9wy+! zDDmS2_Jhwy!?HqEzqTEQXE27h zj^ngi?0=9S2z!#}H8NyEE|#Y>FEzYgQrW1fOmbHfSFjtL6=q6kF&Fv*bPk<@CeiMg zE9}^0&>O#FWMCAe+N&P$=Ov8zpLfQKsO1=c5$lBD3#v(Q|MOC+6k@|*@} zN_0@>b1^|sIxkVdX+EhW)f4EQPw>ltL9Lskx={s!UOB8J`;S zyfdO$=32E@tdCZg^@1J$u%GMvO( sT2Dgyr^Lg7A2sq1Y-_DNG2K^a{V>5}T5n8XGG9&bi0D7FRxf}40!of&9{>OV literal 0 HcmV?d00001 diff --git a/internal/test/IO/Auto/MSPF.TEST b/internal/test/IO/Auto/MSPF.TEST new file mode 100644 index 0000000000000000000000000000000000000000..12ecfaeaff4cb33d68ef4d8970f929b409b82c86 GIT binary patch literal 8655 zcmd5>ZExeo5f*|5g;XG4`*kWHjTFe&+6J1|7X+ZBmCc4GbtHAhedJkmOhgi0QM!Y3 zIRBmehyJ28^V$?TriS+e+v z-bBkJU1!2+8ox=dUEJw%)(Q~EPap-Tc& z6~?$pmlQ|Ww=|1?iXblUc^zeOFJH-_!Gi1u}~J@MayUv zvuoI@uqccqvd*DhvVcPDlH+0pbJ-xCCO0?nGG45J23Y|Xum(G12SODG^q7&caxN&= zK^XX&U0p1$sFsPsuT#L&4MZ?|6fh&URaRK;dX@^nDz2ZVP;HT}i05J~y(e%1qAT2) zQAI*wTJRKrM>+uD5oQICOygP1Acs9+0=RrCXqEtqpa#PtcPra*&3gm8yuXG#@hadR z@s(y-@*43499I?s;|RxREj*BKWCAv$Fr|J>A;23?&qyY{v2u01_e|W6d&GnI!;1%w z7pPH>Y?m_urY50&Ial(6aZgiTT_{(mdo)yzCSnf0a;;0HzxQpoM}6?}XL>vSG8?S$VMnwNi=G339=a?xb845$toY6@2>G-%u$N%{IcbbBU zoCw)!a)%fLiKh8mm4-&Z#gwd!H^B2w`F8OBd&dsO1J74KaKilIG8m8K;~9T7+qXJH z?})!2o%`NoOl^Lz&#LVfxS#bEQm<+?J7eEFcZpifW=D9yDlcHjm-av%Ve^o_>9pSs zgCF1XEL*cp%_casSwQ!df{Z*P^6BaJI~KS?-+nh%jyik){dm%M>_JJ|?b36}y&Oa) zt^S4MLjw)q;)J&;nl%`xAUL}8hAMz;wsU5?<4H((fq%_g-wQ8z#2N!p!)|wzg|7mX z911bqg)z>o5lT^RiWZcEK}GcrD^xWGR{J~BJdQ!K#c%T@DRH%q7 zki1lWV0&(W?Z81cF5E`#mpX&fb_tQt%4YtA@IL+sH8H4AL5_)gWxK;8AS+aZFgGk9#!O0(=@=91mDxZHNZ%CRWZzZyX1~Lv zRSg9%aUlZZDgN49-w<2dQ~6yYW&i*3px1!Xq2| z2zQ;zOqLTYvbao(5WKWP`c{NG((wJ3+Jd?VOVXhl0>_Rz2Z&xF8Ip+hU_E^O@O4|; zibo0|!Bhg+cmyEL#RecnSZyp~fZ8LmtzcCEk9a7^SinL-M);;0K%2n(NQC7NXodw~ zpxw{AiTh&YQt2&;OBARs}d^{9<@dsD2XYS({qsWFW5* zzYX}R<$(T=N4zjVrU1NbH$+0eumi&XmbA_797=3&es;Z6%pAP87@ff>VdQ!tbu4#S zM8~+;Q({fVi!!-Ar(L(Pq^qM}qDVx}14k6t9|;m2jQuL?A*oqfs<;7qo@FAFl=$n8 zCr%3eOfC{IbKn=|VCy2U)EeYO$Ct3jx^0_Or#H=_XLy}t7B)~`jO+5kK=*P|6^fQq zw`|-Da^a+hs7wu7w2Ian25O24<)cEPg*^Rq!<_CnOm%wGFnUH?MNCu8vY*v76}5LQ z1Mxq6Xf)_UgTt%r6%E+wuWY$Tr%v|Fo#t~nrqqjxg$@D--(em`j08N}QO~1-5;km| z=mPl?vAf()ghdT|q-yZ)Ha}&9(*rg*h(B%y#J;Y2A%Dvby)e}AcWeu!Ea$A23JPm7 zq*FupI6DZg3B|s7twea%VUCjp&I{zZIVO;zIZ>ef_0jl9ATl%NQIn-42tfmpfC#9} zGV&26*D=?xGNv=f7NJBCU2y>2%Mq3iHkm14J&dVAa=E_+QhL| zt9Jf`s}1z6B{($%d8p*|sA39MSSz||wleKLW+pBQfI0q|{;kf#RRghOA2U*YEQ)U{ zjh480OI?Uvo>NWl%TQr#iGdj2d9B>%QO!knV^T0b#)}$#yP|C#Y8X-n$s$!0{j2T} zhjewp$0#e0k}E5a)|Lau)=?swvqSbp3NS5Iq3BWN_HgU40nqc4J9by6%{G?10|AgM zdV*RzMEGNeCx`{ToSVwHmg|jbVDmJNt$gcYh7E9c#!b1@c+ZuqIX)CDeHBi8Tt2y; zd&I|8*xS+H(l`;nPQlx|Ij?)*J00tXt_0IYCsvBQeNEJZyTFr*jiq@M$Vt zpbtxQ;Kt>-#VvEQLHa+m&bk3T6i7`L3#|02j|N3$?LnZZZgx0qbq&g`jy=1r?#^XK zaVbrsi92BAKAwx@f(9C!TZ|_YMv32n+)$eJ;INZb*^qhXP>IhcaIY_+%7|f9{kQKR z*pGO2g#ImKu7&tP$}0V4?8Lc1-<3n4+?UjGtjqq;!ev{SA9uKd>I30;5?r9n^4)nJ zseB{M5&FmuCvw?ow)jnUIQ^VEh-XaB*|=)V^N)0C+wB4L-tN0Te*!XDBmdE2`_gRt zJiT+RR)Bu9Ws#PIFIDRs7}K@z&LF~a^Mee2>Oy2oGh=?0(LZP5S6ajw*P6Xq0f;*^ zFYJqcaT$2Q31(N*Zkq{#WlfY9`Gw=L^r8$mwf`###c0Qh3Ebr>TF)OCyEVv?+QNu2 z7aEX6Y9hqjYWa$~pErIre4p(H3-vCU?7o9xL#$YPk1>YRoCME4^G@p@9*`ZFR+ zH_esb{qSRD5PD-IvL;@s!O!m+Uo`&MXkIAir3&qV)%Z$=`J-mI@zt+9`vv}e$$#+j WhiCan%Z&W~y&3t_wDILH|Naj&Kt<^Q literal 0 HcmV?d00001 diff --git a/internal/test/IO/Auto/Peekbin.test b/internal/test/IO/Auto/Peekbin.test new file mode 100644 index 00000000..f35339e3 --- /dev/null +++ b/internal/test/IO/Auto/Peekbin.test @@ -0,0 +1 @@ +(FILECREATED "17-Jun-86 15:55:40" {ERIS}LISP>FDEVTEST.;3 3034 changes to: (FNS TEST.PEEKBIN) (VARS FDEVTESTCOMS) previous date: "17-Jun-86 14:29:21" {ERIS}LISP>FDEVTEST.;1) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT FDEVTESTCOMS) (RPAQQ FDEVTESTCOMS ((FNS TEST.PEEKBIN))) (DEFINEQ (TEST.PEEKBIN [LAMBDA (FILE DONT.TRY.HARD.FLG) (* mjs "17-Jun-86 15:54") (PROG ((STRM (OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD))) STRMLEN) (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) STRM)) (SETQ STRMLEN (GETEOFPTR STRM)) (for PTR in (APPEND (LIST 0 STRMLEN (IMAX (SUB1 STRMLEN) 0) (ADD1 STRMLEN) (IPLUS (RAND 1 10) (ITIMES (RAND 2 5) STRMLEN))) (for X from -1 to STRMLEN by 512 when (IGREATERP X 0) collect X) (for X from 0 to STRMLEN by 512 collect X) (for X from 1 to STRMLEN by 512 collect X) (for X from 1 to 5 collect (RAND 0 STRMLEN))) bind C.PEEK.NIL C.PEEK.T C.BIN PTR2 PTR3 do (SETFILEPTR STRM PTR) (SETQ C.PEEK.NIL (NLSETQ (\PEEKBIN STRM))) (SETQ PTR2 (GETFILEPTR STRM)) (if (NOT DONT.TRY.HARD.FLG) then (if (NOT (EQUAL PTR PTR2)) then (ERROR "\PEEKBIN moving file ptr!"))) (SETQ C.PEEK.T (NLSETQ (\PEEKBIN STRM T))) (SETQ PTR3 (GETFILEPTR STRM)) (if (NOT DONT.TRY.HARD.FLG) then (if (NOT (EQUAL PTR PTR3)) then (ERROR "\PEEKBIN moving file ptr!"))) (SETQ C.BIN (NLSETQ (BIN STRM))) (if (IGEQ PTR STRMLEN) then (* at EOS) (if (NOT DONT.TRY.HARD.FLG) then (if (NOT (AND (EQUAL C.PEEK.NIL NIL) (EQUAL C.PEEK.T (QUOTE (NIL))) (EQUAL C.BIN NIL))) then (ERROR "\PEEKBIN or BIN not working correctly at EOS"))) (if (NOT DONT.TRY.HARD.FLG) then (if (NOT (EQUAL (GETFILEPTR STRM) PTR)) then (ERROR "BIN moving fileptr at eos") )) else (* before EOS) (if (NOT (AND (EQUAL C.PEEK.NIL C.PEEK.T) (EQUAL C.PEEK.T C.BIN))) then (ERROR "\PEEKBIN and BIN not returning same value!")) (if (NOT (EQUAL (GETFILEPTR STRM) (ADD1 PTR))) then (ERROR "BIN not moving ptr correctly!"]) ) (PUTPROPS FDEVTEST COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (368 2955 (TEST.PEEKBIN 378 . 2953))))) STOP \ No newline at end of file diff --git a/internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP b/internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP new file mode 100644 index 0000000000000000000000000000000000000000..9255877f24c3c6c71493d9d7b89883f27f8b1eac GIT binary patch literal 8571 zcmd5>4Qv$06<(X`<}3xymI4(Cpap}e3K*MUjQKM@f{laCkIm0rlR7%^+3`>AoV#-f zq^VG&l-68mRRZ=wOV>bJM3jPP(l#h<2w6hfM5wJu6h$pU{Ye1Tln^xpBK7*syqUQ@ zd)GpgR>}HA@@nYgbg&`405oXYRB-dH>Mz%!B6hzW!ZihuLoFnwFFEZ4*<6?(KQv zlOErzKGWRm>oRR0d9|}|y{O@eYcLP{j`>c&#q4JX=&;{cZ5}XRfY`Q8n;@lu zEie4GPRr4Zboz5m{%+O08vixuFPp#Fx&D*=mf68A!!mD=J*`0*%*;2Rvpj|ES`N(E zV@AyOHzrqyLy2y1f4b4w-P#(CC)%PB42leYcWc~e2zNzeiQV8fxC2$zJL8!uT)j84 zg8hrBy1obg>f{?s-+bk?mTME`-oW%3Io-IHG;FJ>bI~A0&;5)qMjGr^oNE_Wbl1#x z(Q&wftPr9-Y)1u>>s}L>O-|Kl+E)BSJ5Irz+}nhi#O@~lGHeMmZW*je%;gh(9A%DcmwJFX` zPb9re*B8lruBc!BmCtn)8loz1sH62y8iE35ima@YElWQDQCAYw6$ExfWca zW&hi_ev`35#(Z0hV0M8cy;nI$FyJv_#5&tn_RKCTHn5plgiurghPWnpi8EEnVFLhm zHa_$Wg%@xDLtJAX=+lsNVV>`Pb{8`k;sY@y!xt8a_f7yJ{B*c3LU_|a{TD9aT>NN| zu*BV~U9{+yZiH~5keBLpBUpoJgq~H6Zpuv&A4rst@2dT>M1DI{0B?Wv*=;=2ZykGP z8La919mgI6hx1|fod3i5p!PNKfzZdU2i!Of5F!+LP9!DhpAlGI?c;fHI@iNH_!ffh&9D0?SXkEO7aK0^X|$VLBQnsB~`fUj+2GHJ!U< z=!48Mb~F@m=w&*WTWs6*xwFgJ3C=g<|1voM__VD7I~D`f*!tM_I0`@kHT;xw0U-#& zGBz-?Xn2}M2zdfDNJwR3*)-smSQ_T{+?*jm%r*RH zB?U-105l#0vb5cCK?JZL1+?!mkGpmOh4Sv-OO#K3DEH^$^)CDK{MkXm5@)Y={+PV= z?l-v}82~a1ysILN|A^ZHJMb(&gM=^zfHCvq66td_g!IvtI|1n+vy26RF&t?ODE4Os zfU=TI08l{~kN`Z|s{m{`*ePFt5T$YZIFgDmPy~?e`J$Z~#03Ih(S*VS4WZMCHO#oz z-C2|JOSF%on4@E3{yUDK>Ju*qDFg^n$r*j(rLlD5_zJE=GA5(^xTt8G1{M`MDo4S- zTgC<%#eo6hD2>EYT3ZE<-V2ff`?g35lvlc-bVUUYAuLIN zlU@amLld%SkXhiTDl%2{x-FmrhY%(jT%7eaNrTgZ2Fctzf(Fbo&>%%Lz<_8_Y0Df& zl&g9{Awy9BLyG)_$*uDtJ5&_VSp@AAornXRQY^qg7?DQh3J_Cd=u>1!R!cI>I_84a zjSnSrgm8uoH-05=?YfjjhRg!Hej*nr8|k*d^AO>uh!Eyvc;w$(te%3ss?T;;X?o(K zv{s7XJh)NpGoQL(YZT{AN7LsPyTz6_y^Mvo#iDV<_7*-IILkBbDI4A;_0jG~q9qz@ zo@eX)8Qe<4AB%2^hhs*#xh>HaX*C`TN4lBitO>~4#%NlquFit-E?pfxfHWPB5$zue zxO(6Nnyh*DJ=EK&1$PIZc66)~v^Rd#+M?|<|AtH3M-RNr+kW<@&&W}#>9h4r1$;!! z74nhgng1`FcOEDhXl1^wPPd8drr#Td9HrnFx?r^-gm{qD- zyz*+YBT#m~OGiLoUc_CZL-ItGi#E~Q*(@AU4>V7cx_?SZp2rSQIBZFzv4rkCaX*TD{j?g%U6YWgs5;@ zi&svI*B1VRZm%trXjU1Tahfbb{XcLiLiO<9gwyOLsP}1Ef_l^Ac5tUrv8SBIPR!9s z9P~HxbJ%Mdb^1(+#nfhG;cH1K)*Ls)s~^1Nc^q3Y;ovP~m=et@ae2RxWt=zNP86epNqNiilt*k7 zt27#-t>IW)IjVlM(Gq$h8f#004e2yv1A8mh)!7}F;mnA+dQVm>HP_v$l`f>C+;V%h zV(DGqm(!n;_i8RIn(gd8C7M;%WV|Pfnws}riW&Ez&`Iv${L7k-cCHb+#oo58a$Hx1W31CAZfbB;D+py``^~ zbldkPIc#pK;*hh$lxS7~ka3ty|L1OVN&ofLl5Y0oKkvIT`S+$DA%{_#%^b$_FMdu= zFS0qTbeIf`?NDQ7tQo0ATf|tg#4Vo540z#7E*Y@?@V$ae_Wak.read-me-first \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/.read-me-first.~1~ b/internal/test/LANGUAGE/AUTO/.read-me-first.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..c3012707e656e4f37a99fa2b00dae738b0f3cdac GIT binary patch literal 3878 zcmdT_-EJF26rQAMsZIEkkl=!g1LCKsy9SB7sETC8n__U2$TkA0>c!eSwnyFFS?$cm zNfEa^2iH6T&%t}}2;n<3>ttgqpjK+tu4M1*ne+3_cYfxVZhu5$X{^fU)KjILT3w#g z$d=XAR;6qY;(T7kbGb(}UP$WaR+gzU1${{eI?HrU1O7^DH4~6xm7M-LC7V_LsPr82)gV9EX}@II^UL$6z%{hwM09jJaE=Lrl( z(^3^2=*qO+|K=Dc!SQ6A0o~6kPxSJ?v5~{(y{y)C1O`gi!qf^UrJhripQ=*lnanL> zMrU#wfU`tWlqlvqpq`vm^SN7giy~Fi*eWnO);fKv82MvUO$>4Z=@THR8N8x!#i1i{ z1uo2PF|0}z{N1G zytw`oIt$OkXWN(_zq!n1iOxx+adQVPYshM{n3}1aK^IdA6$@2U$f=sC zDK{0PtF=lsUswP+1U7jVXGJOlHit#VTQq^GJatig6X5iiz7_>YgZ^k79t@-IxPN@q zafEO@Cw_F?>mT+HuC@@QZ%G*{G-5Gvi~-qBD~u;bywqi4Xc#>lMxzlt2E;A{U$)Z) zn(?WGfzx$~V158&DCb=5JjFajv(QzVF!Y&D6Htij!IP53Y|j&v9e8@;H06{6fq?0`9Ia8s<{6e%_W7H3dfG>G=y6VB$CmRKaL9dWm zPBe01I&HzvZLuTv#je=h`di#$!L1z@?h5g-5T6V2tq>1beDkwkZ@~oCTQ6wsoIJO6 zP{($!ZHK=p*;w!3v>%E)Xw7JN#D}b(4cWG6=)JR2YskP3KhX0puqHm`B`;XcJ3siP z|7Ub>@zTTGcJJ1@;Lf_>-n!uax?sb^;cZ6osbRYs*hhZp|6dT8tDhUA@WuwP_c-8< zCd}AF*6^fyg5G68)8y{DVB@qKByafGfWBe!{(6*aCJgWs)@UN#INa-k^v5>_>Cqd5 zbi9uAbx1ak9@py48FZVg6jPaZ{8Xw1+i&w3R;|UAe5s1Yy{5XgQT>;y*SxZ`!MfKE ZRscYe_v&IcTj#r`4R-JTF8+A-*S}F=-c0}i literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/.read-me-first.~2~ b/internal/test/LANGUAGE/AUTO/.read-me-first.~2~ new file mode 100644 index 00000000..d5281f83 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/.read-me-first.~2~ @@ -0,0 +1 @@ +This file obsolete, see: {ERIS}.read-me-first \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bc20495e3de51adf1145e183d62b64d257080754 GIT binary patch literal 2281 zcma)8U5pb|6uvVp?RNicD-o!GlZD-o;xsHGfdw?Pvv=EJXJ^X%P&OeU%kC^~QfSk5 ziG)B1F=|W`TsGod5RJqK6MX>U3yRq&55{PGFeWCN_+X-M5~7JlU)FQxmZiI5B%S2m z?>j&DyXT%e(>b#0kg7{+<#@GJ_G(gPwo#pJNHdk1RIkj|raWl|cGwao-Cr>>s4epkdYOPd;$*x@h2Zx^BKD1*;rgK!Wb)M}JV|Hdb z7q4Ct;uS*36j{I_Mo655h<~vePdn6hwg< zC%rOm=Xjk6g!r#DJ4RhYbu`oP=Y?}Zw|}A8qZx7@wx(n$5j$F0FuUM4A0ON%56W5U z$a%}mQ_In)O|D*wohL->PQ*nN^>Oj`m~iU^`S6o5v9LOo5F*C{r8n2Zxb%SZVk!ks zYJcjZCeRoP5KyqeqRWJ{;mbzf%(xD}FUf>_We+`D#z{0byeE9h@m z_=RRs1`D^WIMNuduVFgJ3%ES1Zl@%$(LQ)iqsjqH2OYRqo*GJpIZrC0?P`{Q= zaOejypNe0!DHnwYyATC1-#b@q|2=Y9*YL7pwzj%L!u=_z+d?spjq`eQeOfh*5e>Ub z&MC%-PAz#@1IEbOX)(fL;wos}L|RoGH78rtaV=;)HR#=lJz+a^Tol1$HE(WJr;6d` ziO)N|Z3*%+kj7=YbL}7YR(E$j50f?YF#Xa)ln6j@?}{Un%{@&MGuc3MD>W@L%qwd9nx>J6b^5)CvkX{59d%tmKyfN zII?HhdK^x2V~Gzg541R<5V6WpG(C@=`?zh0+hn!@$$n1uaWcu#V*w(62Z;R1(a#+H z#L?FreaX=~Yz-tMZ?UyFTwv>FaGy|pe489%8#5rJ8*~qwx(qdS=?2`(u<05jc?^LQ z2c_VgHBi(Kh=RjH^bNetA_i7JIE*`N6SCK#&|&JR85T!4#}YV%ffa@Wiri)WK#}i| zQaJS)8$jv`9@6rv%UR2G^W5u2)_0n1Dzi;Tz%QmNM%IOQrp@AqS;9u)IyJIRF3%Es z0riY4W3CbGWh+Z;LForv)1mz=(FY)GQ|Ca6C9pukZ}6r)<~8JMty1-BjgnWF8eYAD zrn`RgDF^0K-&v(knwf;p(X>=L!M`NPoyFY<@A~t2b0Rr9Y|#RX!#rx|6+^RgybwOL zFx!HzFM%uDg3bl1WpfU<*N}Y%SSYuqQcijh6vY_$T3~uX4KfQO+`QkP?_dM0pY3A1 z(F##GjPfDNht~Q#F+ccWwv9L+V0&=h<6*D2UN88q5 zd)QvKk39!G`8|jWJv0#QKL%@nd8~G--hgj7B%Ur+tJPB(G=KjeX+Qs;v>*6acqulj z7F8T7uej5?=1@z~Z3g=i*;dwvi@o7DGeg4^-V~I7i-SKHc*6Wt?;qz`yLG^sqy9X$ qY!n&_UI|b_0C2~l*9{hD+t_C9A^M-^OD4jBMy9tEkjoQ`i~j(W1Bn&@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST b/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST new file mode 100644 index 00000000..e8c94d85 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-properties ;; ;; Source: CLtL p. 167 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 24 June 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>10-1-get-properties.test ;; ;; ;; Syntax: get-properties place indicator-list ;; ;; Function Description: Search the property list stored in place for any of the indicators in indicator-list until the it finds the first property in the property list whose indicator is one of the elements of indicator-list . ;; ;; Argument(s): place: a property list; ;; indicator-list: a list of property indicators ;; ;; Returns multiple values: ;; If one of the elements of indicator-list is one of the properties in the list stored at place: the first indicator found, its value, and the tail of the property list. ;; If not: nil ;; (do-test-group get-properties-group :before (progn (test-setq alpha-list '(a b c d e f g H)) (setf (get 'alpha-list 'length) 7 (get 'alpha-list 'languages) '(english german spanish etc.)) ) ; progn ;; (do-test "get-properties test" (AND ;; The simplest cases: ;; First value is a property. (EQ 'a (car (multiple-value-list (get-properties alpha-list '(a 3 "Alexis is a bitch."))))) (EQ 'a (car (multiple-value-list (get-properties '(a b c d e f g H) '(a "Krystle is dipppy."))))) ;; Second value is the property's value. (eq 'b (cadr (multiple-value-list (get-properties alpha-list '(a 3 "Alexis is a bitch."))))) (eq 'b (cadr (multiple-value-list (get-properties '(a b c d e f g H) '(a "Alexis is a bitch." 3 ))))) ;; Third value is the list's tail, starting at the indicator found. (tailp (caddr (multiple-value-list (get-properties alpha-list '(a e)))) alpha-list) ;; (tailp (caddr (multiple-value-list (get-properties alpha-list '(C D)))) alpha-list) (equal (nthcdr 2 (multiple-value-list (get-properties '(a b c d e f g H) '(C D)))) (list (nthcdr 2 alpha-list))) ;; Should return NIL if it doesn't find any property from indicator-list. (null (get-properties alpha-list '(7))) (null (get-properties alpha-list '(weight price))) (null (get-properties (list (gensym) (gensym)) '(languages weight))) ;; See if it can work on itself: (equal 'etc. (cadr (multiple-value-list (get-properties (cadr (multiple-value-list (get-properties (symbol-plist 'alpha-list) '(languages)))) '(hebrew spanish))))) ) ; AND ) ; do-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-1-GET.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GET.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8190a18ddd2ec93b1977daf674496fa39514b5e7 GIT binary patch literal 3451 zcmd5Ec{eI8!x%N5M_JEO6jpbv<%a!7ay1Z69zE)Egmsix)<+YVUQC$RH zeax_I^W-7jm>a(*vCRo+3M<9=T5&;j*NUqP^WVQqO?*SukFS&~usCo4U}Ey_y_5U* zk8hjNofJj;GCunzC-#kRySo0O6j^4B71#!f4#px(VgC7gB<`AytIZ@+rk2suX52sL z*V~~N&2voKuSfT)wdLblrFf!P!FG3c*?M;}qh+Br zeb!`h`(_l3F2Oo6p(V6g(`D-~MjmG@^s{J0#!4=g-kFo$s!AWdJ16I3v8WVY66H09 zKwf)6y`@+TUa`Zmx9dQoD?mX1SLPMDpl(z`g^`U)TVZqqYAX!j|M%olFZ=Hc&{iUy zOlWaE*jndDpzjtewU+tO>ohoxma>V;??AlmkKb^!RC?>-o(-!9;FWW!XRV$O7&}+` zk<~LNOWm-%IG7(oC(ySu)&;ec3p+Pnm;Z_6<_5{nG&iUn%-)kfMC;oc-wA-q;FU%y zfYE!habOEG8ekfI0e}ur&*@V0?@KpuGc|w#0v!a(SB9JAcLWliFJ07Hu+j}PZ0sl( z#u~ll7M&jh`U;lx6_)eIW;xxE2wr7OU8FS*cc^hB2xbESivBvl<`w|F{dzbUfPtlG z;j3&S^nSC6&ip{LoIpa@N+|9TVBm#&fj!O>q#kVm(pN9zp&lSa+M*WZKLmr%i`P{CXtug$FA26pa1`XeMi0 zS;WJ9CkW*;5+7q8Gw10kR4Nzw4ivBQAr$L;7)3;w%AX3I{1>5oGq1ZN4kT zN5}cDVLn;{I^=^@8_a7qgJ=bj*nUK1cw&b$xG`d%9^|(ndoS-rF+!rBL|6#ra~=hq z@-ISvCGiQ7zZaD&mkIrj(0M+F4rfGYLSr0OyrM5o${|l zf$|$9UV-E=J2?0vqx@45Kt9Xwgy8ZSLO&q%D53i(&fOGXj0Aql+MTSKO2JW~P@8EL zeiww2J{Qi?-)QeYAw=_(E{g)C-$INq4M0SYeog%QT*C;L$me;m>VPAx&DxenbCOPq zlBAlbMJkebfD(HYY{`%LKA zr$qjl(1&mgyVLrdml5X|8engVv&7!O1Df+JR~+#Mk*@(6a!faehOZEJf$u>?o4}sp z6Nr9DSx)oB_juoT`JM-Pf1Xdcyg$biN#6fWzUNLJy`4|&=Ft(Ji1Fwkc!kdR_1?AB zqIRrUt(BLn>Qb?$){3h&)II6fZ*gI*j-1j*)Wv!DzP_NAtMpYHxl_B*Y|yWFpD0(C zYFeROeFPZg$`GOcJaG_4jH{2IIC$fZcX9RdmWa|>zdk-WWx{=L(oX~Ndk5pv44cC{cml>test>10-1-get.test ;; ;; ;; Syntax: get symbol indicator &optional default ;; ;; Function Description: Get the value of indicator from the property list of symbol. Return default if specified and the value of indicator isn't found. default defaults to nil. Note that the function returns the same value (nil) if nil is the value of the indicated property or if symbol does not have the indicated property. ;; ;; Argument(s): symbol - a valid CML symbol; ;; indicator - any valid CML expression ;; Returns: value of a property - if symbol has a ;; property eq to indicator's; ;; default - if specified and the property's ;; value is not found; ;; nil - if not found and no default ;; specified. ;; (do-test-group get-group ;; First, create some property lists. :before (progn (test-setq carre 2 four 4 five 5 cinq 'five) ;; The symbol FIVE, not the number which is FIVE's value ;; Start with clean property lists. (setf (symbol-plist 'four) nil) (setf (symbol-plist 'five) nil) (setf (symbol-plist 'cinq) nil) (setf (get 'four 'square) (* 4 4)) (setf (get 'five 'square) (* 5 5)) (setf (get 'four 'sqrt) (sqrt four)) (setf (get 'four 'odd) nil) (setf (get 'five'sqrt) (sqrt five)) (setf (get 'four 'spelling) "four") (setf (get 'five 'spelling) "five") ) ;; Try some ordinary gets. (do-test "regular-get-test" (AND (get 'four 'square) (eq (get 'five 'square) 25.) (eql (get 'five 'sqrt) (sqrt 5)) (eql (get 'four 'sqrt) (cadr '(1.0 2.0 3.0))) (get 'four 'spelling) (string= (get 'five 'spelling) "five") ) ) ;; Try the default feature (do-test "default get test" (AND (null (get 'four 'prime)) (get 'four 'prime (car '(10 20 30))) (setq epimenides t) (eq t (get 'four 'prime epimenides)) ) ) ;; Test the equivalence between get of a nonexistent property and get of a property defined to be nil. (do-test "nil get test" (AND (setf (get 'five 'odd) t) (member 'odd (symbol-plist 'four)) (member 'odd (symbol-plist 'five)) (not (member 'perfect-square-p (symbol-plist 'five))) (null (get 'four 'odd)) (null (get 'five 'perfect-square-p)) (eq (get 'four 'odd) (get 'five 'cube)) ) ) ;; Test the function's ability to distinguish between names and values. With acknowledgements to Ron Fischer. (do-test "use-mention get test" (AND ;; cinq is bound to the symbol 'five, not to the symbol's value. ;; A property of 'cinq... (not (equalp (get cinq 'sqrt) (get 'cinq 'sqrt))) (setf (get 'cinq 'carre) "vingt-cinq") (member 'carre (symbol-plist 'cinq)) ;; ...not of the symbol which is its value (not(member 'carre (symbol-plist cinq))) ;; A property of the value of 'cinq - i.e. of the symbol 'five (setf (get cinq 'carre) "vingt-cinq") (member 'carre (symbol-plist cinq)) ;; The symbol 'carre is on the plist, not carre's value. (not(member carre (symbol-plist cinq))) (setf (get cinq 'carre) 2) ;; The value of the symbol 'carre - i.e. 2 - should be part of the property list now. (member carre (symbol-plist cinq)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a64b46f2ce12cb73ea70a5b14993c7ac398c286f GIT binary patch literal 3125 zcmb_eYiJx*6uvY2$a~#9#JWlAnA)bUog}-aG^QxbPG_^*Oy+Lq(exqIm~6VyZBsX! zg0ET&K7Oq9Max`Ee+UIZ5Muoy)!JBmK>Z;o{!kG_MNkwhBBD@<=iHk#No&QT><;Ii z$M>Cc&%Jwgj*!q+-Bk36-FwH2`I0g*Ro**QR>meu%H+gUX(X?Vfn9lAr?&BAM$-p6 zHzaDEMV^sTez=?;RotokN$q(R~nN_ zd19|x%XP=3r}Dzd_{cITmD>{7Oxt zTTQ6_hMOj*PShPFB-qp#m9dn!3g-r-vwNh$w+G~*wpgPS-bKg-xzIvp7B663lFKpJB8j@VDeBWE+OirVo~JE^*v=-1rx6*D)1O>PxKI|Du2II%fwk#i)y-1j zEZ}Ga)JsRqLp1U(Ax8?&(a3--HNbNE)}a-+FYs3rQV(4iA5msrliy$5z;EXpScleP zu;a{nz6f<3Ell6VmtkBgL+!xRQ4GwUX@Ldqn(J~$F?8ub;XvVES9Oc13aJ;Bh3ed) z%Dd-ls^8NQT}TEBG-LLRQcNxwi%GCuf^8!KR`h>X5^S8Wq!y^fckVo}0lfRC_yK?q z9n;H15Zn$pSXf_>X>|ThijG|exQYjh5CH`P(lpJ`D6lkL%K`x%*I`o^vCSXV4YK|N z`?|kjzkw`(zVsh&3s7u|!S8aW5G8W0f4tHb*QvEJi<3poXx2v4u+>x+ELOi0m+M)L zTnA4Wo)C<$#<;GzdPcPk*Rx^#=zM;Koo$Y549YS@w1@$xn}%k2IWcG-H7{vO$q% zSsRLvd7$(W50uXHK&ej{*9+qsZX~m;6#(QHA--d+WuU8fwhgAJslu*3V+8k{qMo%e zcRy>jSZj*4_ORCN01H-uF9g-~Tc8ELMvZqJwa?(+Cv0J_cU7#VK%B({$R&Q0j_+<7^drUJ&A0WOHrL8W7$m z1^h7qe@Fy9D8zOl9JU$>G(@IM_+J#r`vhdY23iPTB+zQ*+$g7b4z)a3&PqRfP=@-@o+|uhjh4c#NmQD&$ zL3mozU1~c5{tQ^E-3;{{7$?H?1nWeC9`H2a4OjbZ>g9xQxnOM(bRjOtWxgr$2k#vD zjdzaxEW}U3_ya!{@{JH*3FDXi5|BeI3HiuDxW^5H+JI;AYySvq-h(%LvqxRyVb)v# zCFmIL<_B1_#}YP6W?5&NB{#4{FYD@JooiXwN|ubVu4Z5h{O(tpOZkzh(&YHQys|4_ z9#hKs$uhcr^((izuvXglYwgO|FuZ$?D&u>^Ya`nBn|{FDAM9Fi+^+t6G?y=ttO zS=X>N(_wWG#@2}wh0)eHnjagUDwdZdm2<2YNn`%8Fi?gJ%gVwDVDo_%61Z@BOa(pc zxSp<4?h6lUwws0PhLDtp% z8PezyZO0PLxR$)zuXOgM3>d+Nc+KVS?$}S!!};dzcjnrO7l<(bSdgt|Ygk;|k7q== X&08Uz9Kz3i5P>qdG$na)%k1o5x3Xp0 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-1-GETF.TEST b/internal/test/LANGUAGE/AUTO/10-1-GETF.TEST new file mode 100644 index 00000000..50fd0686 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-1-GETF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: getf ;; ;; Source: CLtL p. 166 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 20 June 86 ;; ;; Last Update: 16 December 86 ;; ;; Filed As: {eris}cml>test>10-1-getf.test ;; ;; ;; Syntax: getf place indicator &optional default ;; ;; Function Description: Get the value of indicator from the property list stored in place. Return default if specified and the value of indicator isn't found. default defaults to nil. Note that the function returns the same value (nil) if nil is the value of the indicated property or if symbol does not have the indicated property. ;; getf differs from get in that place may be any form whose value is a symbol, whereas get requires a symbol. ;; ;; Argument(s): place - a form whose value is a symbol; ;; indicator - a list (anything for which listp returns t) ;; Returns: value of a property - if symbol has a property eq to indicator's; ;; default - if specified and the property's value is not found; ;; nil - if not found and no default specified. ;; (do-test-group getf-group ;; First, create some property lists. Whether or not the symbol is bound shouldn't matter. :before (progn (setf (symbol-plist 'hundred) nil (symbol-plist 'thousand) nil) (setf (get 'hundred 'power) 2 (get 'hundred 'factors) '(2 5 2 5) (get 'thousand 'power) 3 (get 'thousand 'factors) '(2 5 2 5 2 5) ) (test-setq list1000 (symbol-plist 'thousand)) (mapcar #'(lambda (symbol) (setf (symbol-plist symbol) nil)) '(trunk branch twig leaf)) (setf (get 'trunk 'offshoot) 'branch (get 'branch 'offshoot) 'twig (get 'twig 'offshoot) 'leaf ) ) ; progn ;; ;; Try some ordinary getfs. (do-test "regular getf test" (AND (getf '(0 1 2 3 4 5) 4) ;; NIL because 5 isn't in a property-name position (null (getf '(0 1 2 3 4 5) 5)) ;; NIL becase 6 isn't there at all (null (getf '(0 1 2 3 4 5) 6)) (= (getf list1000 'power) 3) ;; Nested getfs - the property is itself a list. (eq (getf (getf (symbol-plist 'thousand) 'factors) 2) 5) ) ) ;; ;; Try the default feature (do-test "default getf test" (AND (= 10000 (getf (symbol-plist 'hundred) 'square 10000)) ;; Default should not override specified properties. (not (eql 50 (getf (symbol-plist 'hundred) 'power 50))) (getf '(Ennis concrete Hollyhock stucco Martin brick) 'Hollyhock nil) ) ) ;; ;; Show that getf works several layers deep. (do-test "recursive getf test" (setf (get 'leaf 'color) 'orange (getf (symbol-plist 'leaf) 'color) 'vermillion (getf (symbol-plist (getf (symbol-plist 'twig) 'offshoot)) 'color) 'blue (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist 'branch) 'offshoot)) 'offshoot)) 'color) 'black (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist 'trunk) 'offshoot)) 'offshoot)) 'offshoot)) 'color) 'green ) ; setf (equal (getf (symbol-plist 'leaf) 'color) 'green) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-1-REMF.DFASL b/internal/test/LANGUAGE/AUTO/10-1-REMF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d48beabb7a87971e65e417866442fd40f9a95ae5 GIT binary patch literal 2372 zcmcImQEwDg6uvXlmTkLTw!2H9n~FoRQCDWMP!cQ>GM!G_Wq0Q;GqXY?NrUZ_S#5VW z+g*jAq@oFlP6D-o%$4wf(ZmN$+LEX!x)L7@zrbJMlP|oRfal!VLO~yh#&nx=&$;J* z-#O>rd+scg_7hr8)+!6t(!5iXD~)=!QJ3c`HF>epsLeR?9N6V^8a4IzCRHt)J~Y&2 zZJL>>Ij8E*tZX-&#o1G5_sB!9$ZEA#nuo!`gP;zL9N0H9Je=+tSFK!t_B3nuj~v*a z?s{ zdFO3s9@AM^BmyD+WiK>dG&DOy4Sz*g62kr^uP0+D1xQVu(1{pop&+{8d!0isD?^H@ z=f}zQt34M8k;=VM5kvXGy`2?qmC4;7v*Pg`$zGx3G>>n+ALPRy1nef0@Jk*|e(!-9 zmx2l!PitorYFnvOJS1k`)Wxl1(i3n9zy zMHi9GO>kav^5sVX ztBTn!yC1bUm))h(l8b*&y_egAy~MI^+RRNmDJ^X5WH+$5Wnm85ph zJ1zAe3Z8-5O6v+u2rh2(zb*I8|C|?ucr=N}$Bh!P+rQ%Vr!;DeW$@N2ld3V6(@kYG z0~TY#N{J!XDR#hrJG6z~l&0F+B-~iLXu`GDcwgwSrYu{}iz0X=g2ticbk!&plyPe2 ztrQbP;qR+$nqu8jm~~2B&?X`&-88AG(4t)^+9@dl3&JVYm{PbML8Pr<>#!$HT^)Pa zkFb;YUUcY*eiUvagtcK4+J!5UCWU7to2@Fjunx<}S>Ud1Rxk;Ey zJgSbST6z!<>&EFQAhq-OKoh@1TuWC?Z4%Wlp|o2dmx4(PsDHq=qgY})P*hnTiawSE zA>0VWi(HUzxF@;EJ;~>+?;Ptdv;H?&e;O#l)>M9!<`l@Ls6T_8qqJy@7197C&0s{p zIANf6nBz&q(3m?6Oql0C$Yi9x&#S4LRyM<8X!x1!La`Qz8-Z{*gm^MolMlop7Dvxv zKxiK|;m8C4N?_i?h42R(04L$sK>G=NLr`(u%&0l;E_@rzTnfY@W|Gs52^*^?(7-y* zcB6JA(6)0y{^UmTTcE81au2>C%7jUa1&&QvP|3?YUh+PZ&tSF%-7uys7HhD98jF|M zb8{>{jT0KRZECRCNw#~6#S1L{Dn!$hSF=Tf7xyI=e*r6dtVnHrki`c;X|r_uSdzuJ zLVyySL8ay_%*i#U-l&xq<#MI0l;NE&&B-Nv@f+n?x$Zi0wN|M*wfb3HRPeoLZD+AA z51dyA^w)2DN7WTbebaobA+w$qU`w&5%FTql9$J}xA#jo+aJSp5oMC%VY-0)t;d&qjxgd8q z1Kay(J^9M_(j%ifTr55KB;emU2o~hGk=S{wm1;WUd+qgiN@eFr026O}9F=@}_`!p} E02o53RsaA1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-1-REMF.TEST b/internal/test/LANGUAGE/AUTO/10-1-REMF.TEST new file mode 100644 index 00000000..11972e1e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-1-REMF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remf ;; ;; Source: CLtL p. 167 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 June 86 ;; ;; Last Update: 1/28/87 Jim Blum - removed tests which evaluated to (REMF NIL) ;; ;; Filed As: {eris}cml>test>10-1-remf.test ;; ;; ;; Syntax: remf place indicator ;; ;; Function Description: remove the property whose indicator is eq to indicator from the property list at place. ;; ;; Argument(s): place is any generalized variable acceptable to setf. ;; indicator is any valid cml expression. ;; ;; Returns: T if indicator was found on the property list at place, else nil. ;; (do-test-group remf-group :before (progn ;; Create a property list (test-setq thread "twine") (setf (symbol-plist 'thread) nil (get 'thread 'material) 'cotton (get 'thread 'length) 30 (get 'thread 'brand) 'Pennys ) ) ;; (do-test "remf test" ;; Some ordinary examples (AND (remf (symbol-plist 'thread) 'material) (null (get 'thread 'material)) (remf (symbol-plist 'thread) 'length) (null (getf (symbol-plist 'thread) 'material)) (remf (symbol-plist 'thread) 'brand) (null (get 'thread 'brand)) ;; By now the plist should be empty (null (symbol-plist 'thread)) ) ) ;; (do-test "remf returns non-nil if it found the property" (setf (get 'tarski 'nil) 300) (and (evenp (search '(nil) (symbol-plist 'tarski))) ; Show that it's there and in property position. (remf (symbol-plist 'tarski) 'nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL b/internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..99dfb0ce94aa146da3079dda7894e38630127e32 GIT binary patch literal 2151 zcmbtWT}&KR6uvXd&+@Zm=~7#^h$9WOSv#~#Y0{#p8HUTUWp`$oA8=z*+boN-cDswq zqQRzwRAYk~Qz@~|)%3wW>PyRm30fufC(*Z!6zU3#*2yZ1<#qgw9vjZF$_8P zJ3rq&=iGa^tdRPb)Rd%_FU}T<`HEDYug=a_rI~U?nk&y&a(QV6^wK3&H|XUtMIG;d zKHhBZu;eQF^VR&cWXaN$Wwuf%!s6sffbpRd14Dy@{mr9_nc{3u5;Hgy zhnTIKH-vDR5RxMsD4GZflK}CqyWyBcO-mk4rl_nbX&UoZJU0ln$hJuh&ut%&s^wX^ zn13T*#Bwgq5rGiz12;HoYpRvhHE&f|5?Z}$ZYZhA87NIjP$C9vEXXc+ZfpFQ9G4B6 z&KP=z+`JLGLWnrs9u_g1ubjK%!g`7P@%6Yk)e&tM8ea8NTJ){Z1O&IyJD)YjU@59%43Q)lA?w@oCJ-QFk@nnHHi)ITMzTl9#a)d z9fPZC*#_Ka)gOokGizEjEsEgL!6!ydQAM*e@~Cd4%@`9z;qhookFl0Oh&2UTU_RPn z)G%~I)@>_eTd_bZ1hmE!Ei3zaBndQwuEm<7nw5o_oTLw?5$DKr!|_L^F;qtgtHTlO z#ECi!+tkrXC52!DKm(?ySO_)DPqhsL$REx-6VP@VY#k3vC9EKk&5z*|46Hp>CT#jT;Q>wl+D%Xw|!^fQ!d_x zm>|tkRZr=LA0;fX2>QJamd2zuNez>7Lx~%5Xh2=dds%74Tu5FHK8TCoiE>zEWL)6vR=_ea6bqRi&OqrAL}M4^Qs2R4DP+5_OAy zN4IcZut$G-pLnY{)7`2;6^qJ`j6f=BQA0_YtOeZI5q|K$z-zXhTopD$qMzAOY{9QS uAB#WqCf|5&|IjdnF{J$Y^#3QoIG*Hoc8g{$-~JbQbfj)K8Tt71*4BTIWn(`8 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST b/internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST new file mode 100644 index 00000000..1b5b28c9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remprop ;; ;; Source: CLtL p. 166 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 20 June 86 ;; ;; Last Update: 16 December 86 ;; ;; Filed As: {eris}cml>test>10-1-remprop.test ;; ;; Syntax: remprop symbol indicator ;; ;; Function Description: remove from symbol's property list the property eq to indicator. ;; ;; Argument(s): symbol - a valid CML symbol; ;; indicator - any valid CML expression ;; Returns: property indicator if found (i.e. if symbol has a property with an indicator eq to indicator; ;; nil - if not found ;; (do-test-group remprop-group ;; First, create a property list. :before (progn (test-setq twenty-five 25) (setf (symbol-plist 'twenty-five) nil) (setf (symbol-plist 'minus25) nil) (setf (get 'twenty-five 'sqrt) 5) (setf (get 'twenty-five 30) 35) (setf (get 'twenty-five 'inverse) 'minus25) (setf (get 'minus25 'sign) 'negative) ) (do-test "remprop test" (AND ;; First, show that the properties are there. (get 'twenty-five 'inverse) (get 'twenty-five 'sqrt) (get 'twenty-five 30) ;; Now get rid of one. (remprop 'twenty-five 'sqrt) (null (get 'twenty-five 'sqrt)) ;; Show that something eq to indicator will do. (remprop 'twenty-five (+ 15 15)) (null (getf (symbol-plist 'twenty-five) 30)) ;; What evaluates to a symbol ought to be acceptable as symbol. (symbol-plist 'minus25) (remprop (get 'twenty-five 'inverse) 'sign) (null (symbol-plist 'minus25)) ;; One property should be left; get rid of it and the list should be empty. (remprop 'twenty-five 'inverse) (null (symbol-plist 'twenty-five)) ;; Remprop should work on arbitrary symbols and properties. (null (remprop (gensym) 'eyecolor)) ) ) ;; ;; Remprop must return non-nil if it found the property (do-test "remprop returns non-nil if it found the property" ;; NOTE: not working in 6 December sysout; see AR 5973. (setf (get 'tarski 'nil) t) (and (evenp (search '(nil) (symbol-plist 'tarski))) ; show that it's in property position (remprop 'tarski nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL b/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2a4f746c571d9c477848e57387a1ffabc9a8f79a GIT binary patch literal 3305 zcmds3Z){uD6~FgAJBjnhwS#L~lhT(!OKbWv(mAE1leU+am)Onod+vMBO)?3hlDM!hJfT0c&+{B-U)=l;&Wd+)h-l?11CQ_(9Ys-<#aQK>A~s>?Oycx6#psw^+g6_n#3 zS5E1+WBf9$>63$phC1C%nz_Zov07nX@s;j2#FAx_~+`8q-VIEI-W5N)zY#?(qHxK z9gvHfcMZp{NB1kWN>wcveqJbJIwzJ0CB*-2y<0ZXR{585lyZtBYJsC^QL2BBB zL8OkB6|_#l%+Ouxkm}B4M{QHhnHkq3=bzqkhLAu{G$LV0my2&q($^N~l{Y7)sewe4 zw*8F9d8rTR#vcMNCKB*Z98SDm2Qfl{1@3=pdT}n<=zwzX=H8m00)hWekrspR$2 za{ETYsOk(70>;FjmY@bxgA2V()B;Lz-EVGB1K?MrVvJlHl->YY@0s>nXz{h#aKjD* z`}wN*q#b^nkk#U&c6d^vJutkmed=~}3VLwZO-Q3Ox4Ussnn7V}k)*rV7pa4Lx=PL! zFT`OwgtS_G0tQ#4t1w!*aj!QEujpix+f6>@J?lP0544UKk!Oduhl3*f_Fz zYt+tLW5C`F79&a5gG@DNOwCwm)2~N{u4}syI29~_y>>5l%>cjx26zBQ{sx#fOic5T z{SrJx^}OR4)~3eJDC#~2UF=$cb>9ZV3>jF7~Qyr+K&5`?o?Z|0f8gDiPsUV2*{4^8pA#qu` zs7Zn*tlPO6*h<=%r;VB%a0iIDWVJ~H_M)3sH{`d2yobv*$I)iM0{IX`?GQC=JdBfE z2EMy>qk;&drz_cd)Z!-^$)VWJ6Qh#5X((~;MSY4koy2RzNe6T7w+6P z3m2KM`4zSgr59No$)X^4!|DddVcQwFb)(aUV^6EPoz22of~@(vrNq=-oJgOrI{`2K zm0OeE733|p6@?EAGR}U0oG!Q&C-fVRqn~jA6>!=RIv=9w-F(%n6ONtFu?U!<4-4Q! z0$38{J{}Cs3w$4B8p&AD0yGn%hk{xjU!(0%5P39%o1DgBQnz6mS={8_OpaIgDonst zX&o<^M_%PN$;(*FBYE57^DYVDOCSumhIa%fz93}JuoQBS^N7eJY#6y;32ucQc!?yr>9YPqyjQ!$c6t|13;WOdYuM3l)nSWz z29~DPC;2fpGoImK%jtq?Y*;L8^ZFR7i`|sJIPxKMlp)@c{Bevm5P7dBeA;c5U=RYL zJN>nGcyGd+6WbS!`1N4z7o~*)GTr`TaNycow91daY!&{*KRt4N+HHkcml>test>10-1-symbol-plist.test ;; ;; ;; Syntax: symbol-plist symbol ;; ;; Function Description: Return symbol's property list; return nil if no property list is found, whether because symbol is undefined or because it has no properties. ;; ;; Argument(s): symbol - a valid CML symbol ;; Returns: symbol's property list or nil. ;; ;; (do-test-group symbol-plist-group :before (progn ;; create some symbols (test-setq nothing nil unbound (gentemp) props '(true fixed ratio float complex character semistd linediv symbol list dot vector string bitvector hashtable readtable package pathname stream random) vals (list t 100 -3/5 3.14 #c(3 -5) #\Q #\return #\newline nothing '(a b c) '(33 . 50) '#(5 10 15) "twine" (make-array 7 :element-type 'bit :initial-contents '(1 0 0 0 1 0 1)) (make-hash-table) (copy-readtable) (car (list-all-packages)) (pathname T) *standard-input* (random 4761)) ) ; test-setq (setf (symbol-plist 'nothing) nil) (setf (symbol-plist 'unbound) nil) ) ; progn ;; (do-test "symbol-plist empty property lists test" (AND (null (symbol-plist 'nothing)) ;; Get an unbound symbol. (not(boundp (gensym))) (null (symbol-plist (gensym))) ) ) ;; (do-test "symbol-plist property types test" (AND (= 0 (list-length (symbol-plist 'nothing))) ;; Give nothing a property of each type. (not(setf (get 'nothing 'false) nil)) ;; acknowldegments to Karin Sye (mapcar #'(lambda (property value) (setf (get 'nothing property) value)) props vals) (= (+ 2 (* 2 (list-length props)))(list-length (symbol-plist 'nothing))) ) ) ;; (do-test "symbol-plist unbound symbol test" ;; Show that unbound symbols have property lists (AND (= 0 (list-length (symbol-plist 'unbound))) ;; Give unbound a property of each type. (not(setf (get 'unbound 'false) nil)) ;; acknowldegments to Karin Sye (mapcar #'(lambda (property value) (setf (get 'unbound property) value)) props vals) (= (+ 2 (* 2 (list-length props)))(list-length (symbol-plist 'unbound))) ) ) ; do-test "symbol-plist unbound symbol test" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..df5817be6c830091a67e0a70a2c06b91dca8edad GIT binary patch literal 1905 zcmb7F-EZ4e6u(Z|ENz-785VS*W2R$*dULc^EgEHLxbAJ5)v;55w3H8_E=@^9+Ei^i zX+kU0keHAxMmw?jg7&~3_b_dd_Apo#4Uh(}Jn|PHAx(%kB&2eVZ@Z?0hoM+G_jkVT z@0@$Cy-wQS(sW6yEi6^4rDdtMT3=eNOY^m5X{ENhTr5fRpqD<;0W} zi>0_+nyr`SBxkj>GBIpJgKb~5k+kH%aX z7L9iyHA-t*+>LIGK2;yp`g`hPpX0?M$Cheghtp|b&@3nM z#J}`?AO4d|I8&@pqxE9Qe77Sg)p0OR8 z4~4)()H&7^7pkDT;Iac#LrX!!a1ogiI~V zv=q~I3a%rEyTH9mR*e}Y&}05^C+ONR1xw=0J~8?o?S!y4ocDt`y5B?6Haey12<`%i zAWzjn*g&G1YgyE2xm-*@+YPXZyM5ABn{o;)hUNw2YUlC=xRJJFLF?W?^*pF!Ef)xN zQ|x&ZChI|w<>*b0j&szW-p=k4Cdj95x&Dj6gnQ_eC2G3B@v!vM^FrLV_|4a_zVIf_N3(u3~{edgH6aMOgzuT4}n%Z zuTHo|P~+Q7oW^1%UDKfs6DI+*+0>cLG4UkpJIYe8F!=~e^|GUBmP#PmTQGeq=N8V? zs?y@@LP@HZR_ds~>3fG9SWCTYYOgdu3*VGEsj|pF2dG;MYOVM?>@W!4;z2ubt?jWK z0}D<&TH?E2WUFQUXxE4Q;(zU5!Tb4wW>M9l$`ezp=NxLOy3JzX#$?{PP2bB5k5IT9 nlz%{iuOe2&tJtBxW^WgiS>(~;DK1lO!M1E@J1P0<)YjHN|H%(r literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST new file mode 100644 index 00000000..d10c33d1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: symbol-name ;; ;; Source: CLtL p. 168 ;; Chapter 10: Symbols Section 2: The Print Name ;; ;; Created By: Peter Reidy ;; ;; Creation Date: June 28 86 ;; ;; Last Update: 16 December 1986 ;; ;; Filed As: {eris}cml>test>10-2-symbol-name.test ;; ;; Syntax: symbol-name symbol ;; ;; Function Description: returns the print name of symbol. ;; ;; Argument(s): symbol - any expression whose value is a symbol. ;; ;; Returns: symbol's print name. ;; (do-test-group symbol-name-group :before (progn ;; Create a some symbols and a property. (test-setq five 5 fivename 'five) (setf (get 'five 'symbol) 'sqrt25) ) ;; (do-test "symbol name test" (AND ;; For a defined symbol (string= (symbol-name 'five) "FIVE") (not (string= (symbol-name 'five) "five")) (string-equal "five" (symbol-name 'five)) ;; NIL has a non-nil print name. (symbol-name nil) ;; For an undefined symbol (symbol-name (gensym)) ;; Indirectly (string= (symbol-name fivename) "FIVE") ;; For a property (string= (symbol-name (get 'five 'symbol)) "SQRT25") ;; With escape characters (string= (symbol-name '\f\i\v\e) "five") (string= (symbol-name (get '\F\I\V\E '\S\Y\M\B\O\L)) "SQRT25") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..72776bb33e88c55eccba76f0a2ed983fe3fd6328 GIT binary patch literal 2398 zcmb_eUu;uV7(e%JE!(=4u2vaku3SLpwYxcer;ya|KB(=OynJ>Cksk~UPEY_vDa#gC87pr+!nghFZTs2JX&3%eG9e-x5 z$7=KBt8T9D&Pw*8Tbs=-Jt2)fEh&}id=VCV_JBGzv3uvl_;|c0p;#%7c0W10C&qTh zdv0AiFNDg3kUVLk=q4mYI*50s5sKNGWy^_VN|SXZt;M_*uh9j2ksV7jy+;2|sa~$g zMfWwgh}&7H5rGizbfYWb=&GGGbnmQiLg@8QHTsgeoPn(=QyLMwS}2Gvc#Y85lkzTE zH8L}@HItq+QsmP4z)3>HH~K>&GWxu5by~Pm682x47PAjU`vw0oMssx#330Wz;V+5x~ z0Sc^K-kgoLsCE(33nl0CgUyeHI2zZx_v?E1x_E(X1V};l>Nx030eM~ghOe=Y=zK6c zaH(ZK3)m+L{O`V*ZQ{(3NE@{_UgGQPyt<)IaXS>vM^<++LfL_})zMaU5Tn@$^262I z1web11qIjs7fOJ-KMEab7D7bq_Rcj1W2&L=P2y`T?^E=>Db188lVH)OteDtEyG1|z z`(RG`W2$1S`(#tI9TVPjl?{sDnz3vxEs78k;gh7MG(~qZa>6jvR*VXw@b7Hfh|xet zA2_-p%$~u)yFGU}F&zQg-O&qvAM?{tM-L2GFs7NNVakSMXB<1$5rlx=n4-_f%#PJ? z((W19J|7{p6Q}fH9Jnd~b!rEd6e=z#eq^fHs2)YCs$-g(-gYHW0evR;B6qr_Dwf8} zQZ~nr0MbT2+Vc9%fN5K47=-XQ-Gt%~hzhjb0%-f54xsp!Zbs3hQ52_n+6g$Lo)PV! zX2QJzhmz9JxdbR15|f6b@6DjTfV;S(=0Ocw$#e#;G|M(2?KzA(g0))=vEgWYiDFNL zr#OXiPGN*mAb-(8@R462t+$m1U2`yx+@wP&z5;p?OS2QLORat9?mtQ(93?<96yXy6p(SZh#Zcm_{Z}hquxp8IVNWrVngWI%-q&Q54U^ zRqWUC1lfV^ppT(-6C9S`I^Za#Mnh=mp)nMG-qtlPK4lQXM=VFU$i=(dSE2ooAQYfx zr|zT>TsXvCW9%)tbCt_err~5*9U;mg`#F}#1o@NYk>3ETFRe^FIy);sBtNk#syhL6*5k%nh! z_%MxSX;`P>XQ})+4R5FM5gHz*JEAlkgjn%qudyXxt}My5rG=yAqQusfYPnLA>Ta!$ zA&0%jkPT~Tcv%^i=5p|TpOxlI{L_rKty}*9+7O)V literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST b/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST new file mode 100644 index 00000000..f1a8d488 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: copy-symbol ;; ;; Source: CLtL p. 169 ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 30 June 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>10-3-copy-symbol.test ;; ;; Syntax: copy-symbol sym &optional copy-props ;; ;; Function Description: returns a new uninterned symbol with the same print name as sym. If copy-props is non-nil, the initial value and function definition will be the same as those of sym, and the property list of the new symbol will be a copy of sym's. If copy-props is nil (the default), then the new symbol will be unbound and undefined, and its property list will be empty. ;; ;; Argument(s): sym: an object whose value is a symbol ;; copy-props: an object whose value is nil or non-nil ;; ;; Returns: sym ;; (do-test-group copy-symbol-group :before (progn (test-setq forty 40) (setf (symbol-plist 'forty) nil (get 'forty 'square) 1600) (test-defun forty nil 4040) (test-setq fortyname (copy-symbol 'forty)) ) ;; (do-test "copy-symbol nil test" (AND ;; The print names should be the same. (string= (symbol-name 'forty) (symbol-name fortyname)) ;; Since we didn't copy props, the new symbol should be unbound and without property list or function definition. (every 'null (list (boundp fortyname) (symbol-plist 'fortyname) (fboundp fortyname) ) ) ;; but 'forty is forty (symbol-plist 'forty) (forty) ) ) ;; Now try it with copy-props; it should bring everything with it. (do-test "copy-symbol copy-props test" (and ;; Returns nil 9 October; AR 6540 (setq fortyname (copy-symbol 'forty 40)) (eq (eval fortyname) forty) (eq (get 'forty 'square) (getf (symbol-plist fortyname) 'square)) (eq (forty) (funcall (symbol-function fortyname))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL b/internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f58e197d9dfc1715872f823c6950f9dea65dc6b8 GIT binary patch literal 4870 zcmb_fPiWg#7}uJthd?20jIzVnJC-pCJ^iue*VLQw9LAC~W3JYMmxCv(sb%#TQfPpc^|hyKTF8m$G)p9x}?H8*G{JK1r4m%c3}z;DK%F`S<&M z?|tw4eeW~s`Afw`RMgiDt)ZGocWlG4(PiC4mhPB}iY~)*v{_t!ue9}cp}4@D#WUq2 zZxmCl+G-75a8#>S-FO}094Z*5)_^aP1V1qmIU)$m%zUA|=%bDEACYi5W~Tqum(R_< zI!#du^}S9}U)*c8u61`>^9TKFw@wLHraHK{Ep+aRU)#6#9{t$gWgc&LPMopz-i;6X z-+nUvY3IAAH=myV>(A*oI_q6omU{>NUHoSI@zlNjC%uD<-HY3M|6Jecw>z(iJKu=>F9)u{_N@OS&S+uOD|PTI)`D;hya6MK_6QT+MIVBOKp;c z^1B5x?|h`8ORA}_Z_T~0HXSuzT5}rttGZd&nydK_wPt>;T36k4p)IGWTLOcbH6`d08K={&oZ%o%cz=)r#(l*p?5QggTpQn7N@0sKv6+449RrUir&yoS3Q@Z-*Fmr zjzw4^JSIXmRrLW;EKkB14o^V1J{UGtA_A9g3!bfF2{u04;^Z# z$AS8iQo@J+6oa2cb6^@#cM=GjQf2h(;=lwWmBwdDq(5{f4*Tv3-6ap{o?2!1^#{Hb z$C60Dm+jCQ1g<0ys9vjfEmW7~!g|>#5;PRQ!4@XI2IgXK{T2r$d zHPzc6#Cvk39Ae?JlO;Go+i{3niGw|cLQ`A4V*C2U@XSNg!V@t;{sgEM6a#t;byrQj zx$0-PL@z5gElG%DVW(jMC*SM9td*%pfP3Bpi35lWuR!(R+7jG2A=28Oo$9Xoy6UU1XF7$$UKU2Q63$zAj&P2; z$1;ZsrCv7c(<%MntnF2SIfU`z*c?MQhRM#;;P7J3JA(=)TREI9o6EM=X?lhpc#^~U z9O1QUJ5*)~$3mMJr;r;g;rY^mzeWpkilSWJb+FkTkY5guVZX0>ZD4mNI2?1bzV1r5 z4KR5E2UuWpNjSSZ@OQvNQPX+*Iu!FgDxrV)susE{T7`Q>Q|}qnW^b~UJOu+UmxGXRP#O&!Iwhn5$r}VNODG&6c0=Md zPzNsmY~Wg$IhZ*&cf6;d(DX`b+Cb~P3B4pJRFdkmfo(kwIqa*dZ|FRxM>$aPuV#d= z4V_$V#&9Tc#{1eHfitlH7VI33M!=XWD(rqZPRDR4bTLO|qkY1J->*3AxH7{+t zI5*gI)0HZSjx2N=Tvp^tRCz8~!ChHYSVIyLU5(irUiY3FN0)6ER~jS8`i(uGR(%l} zmC{55RuzR%@8~3*xtrqC^?gfk((n@hz3HCraVw8lPLwH|JOCETvQ>EoDJbVN>TgQT zJS8QP-kfN|mC!)nBU}hGru>`=x1&m7cr>I=h0lWb{}kr#QrPZ{U>f=m^&Hg>Lm#B? zTw}{FlYL#s-e(;zu6Tv<1eY(t-hzY_<1MyKg6opg)3dnlEJ95_jQ=|WgVE;6uYrWM zK{PXK8*hu1AhUzP~&9) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.DFASL b/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..91fcafb48f5bed142cb62b662366bf9112611ac9 GIT binary patch literal 6087 zcmd@YZERcB^}Xkhe7i}Lrmkt>^@|o0yKxdio3<-2?n~m<@pJ5F+@hh*bzWj8jvZ`g zEvu*sj6sJN7TR_10^LAEAZ-&Zk%rm<$`7=mO>7!cnbsd{u(3~}tx_lL15MdE_tbMHO(&Iq;x{-Es7O-!aUMqbWM6(^^P@<=W(7jjeiq#=(0 zT|Va5BI*MJihsX%r>{1;s3(~>5=CQJ)~AfZaN_ESx>#d`J+g)-*LrXw9ps*Y=ASv(nqI@0a3R zT}`5Wl$$ua7U04UY)-jc@N?~ReYXT;6a^Hp|08xD#C9IUq?bU)T&4k>liWU6&E1yl zsx-Ri%AV;Xc*rrQIiA!Uj}ZC{DuZT&Ak3ZL01fz+ol3~RcR8}6=rzGQ!a!{He>h_L zHLzgiLsjd=)I~l+K(EXMpU@m{2*OP2QO&Vm62Z`!^K0Vn@|3|-^ZV>Aul|ky_+rj6lLr%!7Q<~%aI%pnp&1tSDHP`gSJPZ%NcdpK)PNW|fIhO?d z=Pxa`1!SF-m^sTab5>&ZvF^0KSFy!Glf7}OZJ(;BUJ>shD0-X8CO0pUmaF}s%Iv(48h&WY3wwc*XmyjOxx z$1g!vWQM^AXuw zs2J2t200cC!nD?$*9>xkL5}MTa{LQ}{(~ri{rg+O<1RO0?2Ka-j5{iXAeOhEN>Sm%OE|=CdH>uo}xMIP@KEH4@Px z9xbMaW4hbY3Ig?RC3Mik>8QlA8ff-#MC}V4Sg0nyP1HC ztw&-#+kimgMB4{k&h|c+v%SsbY%jnNj%Z*o4E0@9k3jD11`*pgfLuqo2dFr_?O9Gc zIM}NNc`1lAw6LmNwjq9+-HPB#Y$Jj%vP}pcWt$Ovp87sRX533=43Zfexf!Ip948c! zNu-%=L9CHu)(^P?>+iV&>t(LM`Z8y+zCdEzDRt&J{|>xI!tz6-s_s`%O_*_w3dDu|Y^f1-AfXzXN(&pr_9h zC0ABzaO}jSUa_1m{vGHxz8HZ^{1XpESoH^#AYbO5Fp}Rx@}T06Xr4tn#h(GWs;^gz zh4yl`x7lsT{RVR*c#hqU;4#*Q-~r}AkY!#3BWxRjdqF`xW_{&mfW&)%XosW%V-eL^ zJAxtRL$Dt@`8x3g15sR&;u_RZo*1mzn2N+|)UjZg@CVijRN*q~LhveK-z2QWI*+lg zds%0Yb$MCmI@Wavn5rD0!4{5a{pecz@AxF_zkr*KJ%pP9?hW>zuxI@OKhXdR9 zInnkyVJ{KrCE^ak+#Fbc%!$_T5%vm!Ng|FCc7VVtBGz-v@(%(hIni>0u=@yXBH~Si zk$^-dNo0~lCP_zOX3oU(AUgQ-h9_)a5v39N_i zx;}_!EW~|}9F5dfi|!nXX*z~SvhdW91Rz>5VSy(8g)@pD5_p%uI|P2nwj;}%d|`^O z5je+oAn|L2J5V4Ogbz!n(1VTr9`D{DciW>VEi7+Q`-4q=y# z(}cgWU4RL{Wz7ga;QYe-g#Dc17ApLdupbcT1-1%_-yzOf!p;%ri-bKzoF^GxeuXa( z=fi}ZV7rep=Q!JS4{MFH9-XxgvE2dIx{K|)ovq%=dN#Aw8`y3aTa5{BpEpZek8I24 zvYugMBr%mK%9D9xBz?3^E{vxq<*5R^BowAbfMOJo|0A<>i*6K(@`mHe26-d_ZxO?C zI!n(8NIQ-@xcve1Y4a4812_94s-ml&>(06$p0`Rc%IbiP_3#9;XU)>4BilZi9b;?{ zjAQ$dkHhY|rp5NIS@O{wG}LvO zRHl}zJZP5IR-Q;;u7yb>nI1{Q#3w;ZV$?wC7)iU#k`1XHK(qdNnJVkA&C;rLwrJ$D zqja?v)3FmjF>`N9%mxnSHk zWq?<9%D#5Fm{0QvTeosemUGKAS)MgZu57NDN@qvq#0ZSdEdagXhkOyNuslPu`F6LUQ3R!v%Z8VVX35*rt3q+6(%Tb% zP%ADZawUV0N6R^lM~}3}ECCSy*l%QwJUpt&30Mosq){lOb6GhzA{XwTIGoEAu!%2P z<+Zb|>~3#uO^w`}C_tnNn0T;A^00Esy=`(PJ&^{K`m$3Khw-^@L{5We6Ga%Iz!m5q zSQg=amXD+}89ATGj)KB`ZURynMu1dCczZH8g<0Y8aaq+n>Xo-nB*u-RF)>+yIJaZ0 zHxAuKT1G1q8^Rus3}6SJx$lg)aqPl?GCz}QgzH4_T?3ckLIIa4_>VV>f$>Wh&i@iz z#F`;0nZ(55;RIMIUtcc63!jCT%jPMIS+e#*oeK*j7#Ixbtl5g^u^lQ(EuyzVvyLC{ zbUtGZQU{v`TsPDZe2svw2t(EB^XOW+{uFC~Si7Vo6$FgiCfW|LvX$)D+TvBSv?ZJ| z&|ky3?3NWE{QOt#74ahvj?-LP)uZp6ZzqaU^&ZpaWr>E zRE&xFtEY{OboId6t5{}32uT|^;hqL`m*ZNgLh-)wF9FB-EhSz zUunA8rcSnb8_?}^b8xd;w=i(I@Sp?E42Kfw=jCeUN(3Dkk68*OUV_Bai`oyeBS`9n z$Kk$2CIj2k5m>Bwq`|f$;?^K`nWq}2+oyfg9n+oDUDJ0=cTe9ry?vUO1#Z&S0(`

Sm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST b/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST new file mode 100644 index 00000000..917a078b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: gentemp ;; ;; Source: CLtL p. 169 ;; ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 10 July 86 ;; ;; Last Update: 17 December 86 ;; ;; Filed As: {eris}cml>test>10-3-gentemp.test ;; ;; Syntax: gentemp &optional prefix package ;; ;; Function Description: invents a print name consisting of prefix (default: T) and a number, creates a new symbol with that print name and interns in package (default: the current package); returns the new symbol. prefix is in effect for only one call, unlike gensym's, which becomes the new default. ;; ;; Argument(s): prefix: a string ;; package: a package ;; ;; Returns: the new symbol ;; (do-test-group gentemp-group :before (progn (test-setq digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) prefix "T" nondefprefix "Fallingwater" iter (make-list 10) pack1 (make-package (gensym)) pack2 (make-package (gensym)) ) ;; Acknowledgements to R. Fischer (test-defun integerpart (&optional (charpart prefix) (symbol (gentemp (string charpart)))) "Extract the integers from a symbol in gentemp form. Default symbol is a new gentemp; default non-integer part is #\T, the standard gentemp prefix." (car (multiple-value-list (parse-integer (string-trim (string charpart) (symbol-name symbol) ) ) ) ) ) (test-defun maketemps (base limit prefix) "Generate a succession of symbols of form prefix/integer. Base is the first integer, limit is the number of iterations. The integer part will range from base to base+counter-1. E.g. (maketemps 100 10 #\Q) will generate Q100 - Q109." (do ((cnt 0 (1+ cnt))) ((= cnt limit)) ;; Since gentemp creates symbols new IN THE PACKAGE, phony symbols have to be in the package as well; thus the import. (import (make-symbol (concatenate 'simple-string prefix (prin1-to-string (+ base cnt)) ) ) ) ) ) ; test-defun ) ; progn ;; (do-test "default prefix should be T" (char= (character prefix) (char (symbol-name (gentemp)) 0)) ) (do-test "after prefix should be an integer" (integerp (integerpart)) ) (do-test "nothing after integer part" (string= prefix (string-trim digits (symbol-name (gentemp))) ) ) (do-test "integers should be in sequence; 10 tries" ;; Acknowledgements to Karin Sye. ;; Might skip over a previously-used symbol; hence the <=. (dolist (dummy iter (<= -1 (- (integerpart) (integerpart)) ) ) ) ) (do-test "result should be interned" (symbol-package (gentemp)) ) (do-test "interned in *package*" (equal *package* (symbol-package (gentemp))) ) (do-test "created in specified package" (AND (equal pack1 (symbol-package (gentemp prefix pack1))) (equal pack2 (symbol-package (gentemp "pack2" pack2))) ) ; and ) (do-test "prefix should reset once, then go back to default" (AND (string= nondefprefix (string-trim digits (symbol-name (gentemp nondefprefix))) ) (gentemp nondefprefix) (string= prefix (string-trim digits (symbol-name (gentemp))) ) ) ) (do-test "w/default prefix, skip used suffixes" (let ((base (1+ (integerpart))) (limit (1+ (random 100)))) (maketemps base limit prefix) (or ;; maketemps will have used up limit consecutive symbols; gentemp will skip at least that many (> (integerpart) (+ (1- limit) base)) ;; In case of wraparound (<= (integerpart) (1+ base)) ) ) ) (do-test "w/non-default prefix, skip used suffixes" (let ((base (1+ (integerpart))) (limit (1+ (random 100)))) (maketemps base limit prefix) (or ;; maketemps will have used up limit consecutive symbols; gentemp will skip at least that many. (> (integerpart) (+ (1- limit) base)) ;; In case of wraparound (<= (integerpart) (1+ base)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL b/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..10a0b2428607a41ab818395ff09bc2d73e2034dc GIT binary patch literal 1780 zcmb_d&2Jl35P!S*vXj`dDI~3xq)(9|%9gcAo1!*=V6%BiTsyn&eh_k@TAWR6)v+Uc z($K&Vh;B#v<7zyXOP=l%gmVP-c@-EtrYq}`pJc{9KH z&Fs9l`=sX$wLsPS`bMSdHfVj*+t~EzYP~_5_02}frK@14JF0H5w-*#OpM7bv-|Sc^ zHC)GYSE#k=HdmbO=jr4ns%$hWRd~605!A`)3+JY%rn3EWidl%zjuZ3Z^wjxm|H0kc zLaI&(DUlY6I3X$0MS>6glw>i}lIL;-CTq$flY;%gk3lW6Z89V9)90vH-;k^Bb+?M; ztT%~3NO04S&Dol2<#a8$CA=#P1~>dfPLqpJnljIb7&}BkbRqEjCtr}y%XzlEq#LtE za`*PY9wEZF>6D0cekec43-@az_%Sao4Q0|o?^?+5>k*Jg7mzMzGH_)sXTJBrjG>@{ zwlq>2X;mJ8?Ww)K6GHj^)nrRgg8Fd3a6?c2Ovrxu13j4+g#^5Qd1~n-#=?4xkU>IP zl~Shll`z`LXW zNnQOAFeoY7vK-nGq$>%2ap`b2rNB>3J~7k--GuONoa7TYmtTN?H+x+vpzEGrFzK7Q>vM zgWgj#^mz@Fy@y)ZHPm)sllN*^ci4t1A4BU3So<{HT7VCY`kVYTig7-Q;#B06h=d4u zeTRD|L?FZn6-CEtZkyd#m19p_L}BcuiX0s?qCCb<;(U zj|2a-@Gy|UZ3(G90`%~=bnT;ON0Nq>c@_;Zhd$nSxFwxbBAwoRMc z>u=SowCOnwuTop1TNSTN9a^ea>or9AEdsmwIM`0$XQyWv3^R+)^6&@c9o641eAhf| SMfTN*M!NfPAo9ud!NEUb8UR}W literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST b/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST new file mode 100644 index 00000000..be1d4ec0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: keywordp ;; ;; Source: CLtL p. 170 ;; ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 12 July 86 ;; ;; Last Update: 26 August 86 ;; ;; Filed As: {eris}cml>test>10-3-keywordp.test ;; ;; Syntax: keywordp object ;; ;; Function Description: returns T iff the argument is a symbol and the symbol belongs to the keyword package. ;; ;; Argument(s): object - any lisp object. ;; ;; Returns: T or nil ;; (do-test-group (keywordp-group :before (test-setq *package* *package*) ) ; keywordp-group (do-test "keyword is any symbol starting with a colon" (keywordp :nothing) ) (do-test "all keywords are in the keyword package" (equal (symbol-package :nothing) (find-package 'keyword)) ) (do-test "A keyword is its own value" (and (keywordp ':nothing) (eq :nothing ':nothing) (equal (symbol-package ':nothing) (symbol-package :nothing)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..425dc7d41a4a683df4250f9b5e8d84333b77bf4f GIT binary patch literal 1755 zcmbtVU2ofD6n>qiY0@NBGDWP7%CPz&RaqTqS)r67qZv`ld)Zzl=B<^bx6`A?NB6myMF=UA zK8g?_F)~D)ukBb$r_)v@D?eAj9Tb@M~Bj_ou$gd@cH z$_{1>S<PQo)B_ay{(Mpd|VVBA53hGV;IM)Fo~puH77%$uOZkE<F^@_clmOBbbyO|nCmE_r<$*)NIJ8{@TjFd)lBiLyEDNJ~8To11LJ>}q zrmHZu_YhtJIPCT09x%if5gRxRh(*|W6d^Vag8aiKQ2Y+BWptKarRuhzLB>2q^jEi% zdyGyG9Kufk9?7gJhP+-x{RhwkXX=-30dkv-f6OKdY%&ez$O$nRhCyFt{5go@J^{mU zQB^i%)O6I`>7tf{lOK?AT<-K%*$h_tn@ywm)6@R&#P<;BmyJ9+l3O^}fsTa@RWXVz z)?m{WHe;}vRq&32gCV<&FS7U?7QSLAI-OBS_?iW6yQ=8aq~9XqFo0 z>y6S4Q}6)3ZI)}TwpFfm_xP^a>7xI2$9_$RXMSp5oZ@#&@HMXRwWjwWMQnc--O`Rd z(y6tZmRUzN^}L#JzIE>6dS8%KD(X~tVH@&UovLD9V_|S(bM92QVaLvNs#dRF;de~F z*W9ss&B{FgQLPJLmoM=^wPm(}YrO{i;E%D}YnHn;t2xh?niYtsHM?fJX;zRC$1Z{( z_gp3{eO8AYICgqvjlwQd??dhWeXxJ8=hJ5QwUhSKS;r2Tjh(vLc;Cwt_dlPOe6xCd F{4b#H`c?n{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST b/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST new file mode 100644 index 00000000..d3323036 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-symbol ;; ;; Source: CLtL p. 168 ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Creation Date: 28 June 86 Peter Reidy ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>10-3-make-symbol.test ;; ;; Syntax: make-symbol print-name ;; ;; Function Description: creates a new uninterned symbol, whose print name is the string print-name. The value and function bindings will be unbound, and the property list will be empty. ;; ;; Argument(s): print-name - any object whose value is a print name. ;; ;; Returns: the symbol whose print name was the input. ;; (do-test-group make-symbol-group :before (test-setq test-symbol (make-symbol "emblem")) (do-test "should be unbound, without a property list or function, and uninterned" (AND (symbolp test-symbol) (every 'null (list (boundp test-symbol) (symbol-plist test-symbol) (fboundp test-symbol) (symbol-package test-symbol) ) ) ) ) (do-test "symbol-name/make-symbol reciprocity test" (string= "sirnoel" (symbol-name (make-symbol "sirnoel"))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1ac880d518ff3612b2721321b2fdf1bed7d642ac GIT binary patch literal 1860 zcmb_dO>7%g5PrLHj2$PIO^TbCv}}!vU}3GgEusyT&}Q?TxVCql{lU!%jI*f?P951! zM1%-Yg%k;`R6^BgA63L12?;8J)Y8fa;DUtU$dLmFBrcUWqcF2;r%8%L4oJJ2H#2X( z`DS+B+buG9MJWhMb7{HWuv z-Pz`1O+rYObWwx}iID-~e&WPLlNzR!%@wGm%0()=Tdos=S|rP$y6eQx3Z3S%)Ua3W z29~qbCLAH|$4)3~sfwA?RQD#g!411NoROR=m7p|vh7vy1LqT-Tbw)F1q;rxnU!2kk zdz*H)Bi9Mxeu>9;B=v3WexAE~jqE(g^X0K*oC{v{nBJKHx%U9|S~3Yw@^bQ?17-{b z6|`Pu)kL>`9~@6!e`1uY-F+k4)uNz2+$!AAqTdm+Rom2}d7c}A<(K2-B!+=MM9459 z-FkJR`xSR?KcT<-ghJ&6q~EG-93B6-kB@Ns66{0g-tMD^%L$+X34mDFUwQc+9=VwR zPWE#@*+@B2!#w|2MZouR61aD3F~X0yx10%4(bVZ2PKY!stJ4LlOH(SC>uv{f+bOm0o-sFK0*HgqA|{%MiFHbAjqFy zIQhd1C%<~(hQH4HO^aL1!Q<|ktmlBxZ2hayg zx;CSt_8DqkgHhXt>m;aR$Giq^vJ_e;*(nqmUrYJoDd?DYJK;xUG29Sg&w?O7dE3eN z-ahiRFFwQuAMBtsqia@)#g^Eq1(vc{>Jo4nfl@5hqx&L@KacF@EX|~+Sv&y|lag55G_p*8l(j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST new file mode 100644 index 00000000..5fc0e707 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: symbol-package ;; ;; Source: CLtL p. 170 ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Creation Date: 30 Oct 86 Ron Fischer (rewritten from Peter Reidy's version) ;; ;; Last Update: 17 December 86 ;; ;; Filed As: {eris}cml>test>10-3-symbol-package.test ;; ;; ;; Syntax: symbol-package sym ;; ;; Function Description: returns the contents of sym's package cell, either a package object or nil. ;; ;; Argument(s): sym - a symbol. ;; ;; Returns: a package if sym is interned, nil otherwise. ;; (do-test-group (symbol-package-group :before (test-setq test-symbol (make-symbol "Frivolity")) ) (do-test "fresh symbols have package NIL" (null (symbol-package test-symbol)) ) (do-test "set symbol-package to a package" (progn (setf (symbol-package test-symbol) (find-package 'xcl-test)) (eq (find-package 'xcl-test) (symbol-package test-symbol)) ) ) (do-test "set symbol-package to NIL" (progn (setf (symbol-package test-symbol) nil) (null (symbol-package test-symbol)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28d8969a0cb0b61c0ba4dfced354ef49175b9775 GIT binary patch literal 1851 zcmb_d&u`mw6n}QwEN$8-En{uNw0dPo$kY`ng>B^kuIIL(iA5J zO^B+RkajUDWn%Id7#GBe0|O+)L?KAMfH?C9AaOwAQi%f+m-3#Sbm`zQ2@cWo_xZig z=ktB}e81j>&MS&8DAmeFsa)`c>Sldovo5SvJ)u_J^i~SO8s>#J6w^}QoRyWivFEeh zcH5g3udrM%tP0L%p|-kweN@O^6yy!BRK|x37jT)Ke0F?tVq&a&TDJ8F?O}S(PmVt` z)_r*AHkYmfzzQ@dbOEFx2En_2T69#~k)}0Wl?*wjiotH+CvY#4YpYh^_l*nn>V{M< zyjCdFb}BXC0D^b?#I$QDj%FIcEpD6Z33mKm&5-iAHF-t_KG8%WbT06d*{t-Oq~-Fa z<-ncW$r}LNk9}#L#C%iSo8#`SgZJ$mKYuFI$Hgi83P3T5f=@R}d-&Xc8d47X_zr)Y?1F`U3>z6ar||n@A^bVc9dDkQXSVq-zcH+ z;`V~=s5zd;ij$Eu6O{I%2FF z8+t_9SdhXzfy7dni)%SVHIEEWRt@}g_5s5uI{;V*x%^Rb?LIPesF!7(7GL2aPReA5 zmS2)I#kDNeXggAjqjw+UyOZ}Pq{y}!>0#kvcpWErVlj7F*X$6gj>ySr9G_$_d%LJ_v4+ ztIsHwDm$w5fD?2LMCML>TEST>11-6-import.test ;; ;; ;; Syntax: (import symbols &optional package) ;; ;; Function Description: The argument should be a list of symbols, or possibly ;; a single symbol. These symbols become internal symbols in package and can ;; therefore be referred to without having to use qualified-name (colon) syntax. ;; import signals a correctable error if any of the imported symbols has the same ;; name as some distinct symbol already accessible in the package. Import returns T. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group (import-group :before (setq im-foo (make-package "IM-BAR" :use nil)) ) (do-test "import returns T" (eq (import '(lisp:rational lisp:plusp) 'im-bar) T) ) (do-test "symbols imported from LISP" (and (eq 'lisp:rational (find-symbol "RATIONAL" 'im-bar)) (eq 'lisp:plusp (find-symbol "PLUSP" 'im-bar)) ) ) (do-test "imported symbols :internal" (and (eq :internal (second (multiple-value-list (find-symbol "RATIONAL" 'im-bar)))) (eq :internal (second (multiple-value-list (find-symbol "PLUSP" 'im-bar)))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..662895b8a8baca21fe61d3935f3f91e38b8729fe GIT binary patch literal 1431 zcmb7ET~8ZF6ur9`WAovz2}xDdHmej0vN8x$qNGHXIxK6v_Ij7@j!Q_RwyrT*7lV;M zDn(Hd%1af=YT`seJB{*^UqJd0iLdaGmqhAQ)rY?K56~Y_(K`lOlDxE%t(iG<=XlON zXWWGLE1Icl<)xKksZdeN_1a3krY@8#YPDRiBp0@Mv99 z$^ejuJu!p<6leqgUPFm7-DMwekun6}~H!gq)=+ zNC5ubMktZBG-lYAe_vXYy8Szi9>XFtD2-0*Acu}v1iR!nPQ~NoBAK!YHBI8qWhQOY zg-7eb)n$OQS6g@5_IA?J<}y@w)AFp+AC-b309lq&fAzuMb$~@tDlXp#sXjTfgHZ3S zj)>%KeihlXBe>jens@BTbAYDzgB?lBQV+mAZ{y5tuQ(>Y$k+|ASIqY{J*B9C9P}SF z-i>LtHDw4bBuT9)Q+LRufrvHj#^iQvQZ%MfrX`7^v#f(6wN{sc?wrf?j4Zub!R#3C zY76mjTNoP?iRq4GJH*binJkO7_27Z-7`5g|3wL82JEX*4Yjmg$fCof(0~I6*CTu4| zSy}v;mUSH6I^i0ZzC^t5UmY5C^+R^v^&Xy%ng+Tont$Yw8*mYBZ(SgTb_Oj$Z(ina z4YDe3|4*B~rby^i8=`CAC7ecHM8BWjLzmR_Qr) zA&0S_SBuMsi51xD;OM$^3(ffB(@k&7L)*Pw@0o`tqB~ouySKgVbkkcaK7r>cDG2Z~ z(%kss+nvL?A^_Muv5=o-FwJ<{v?CMEjksk#UHtRsfsFYS;q7#w6xjFEI8DBU{WXtc zOp0DV2179yf7{vk<(RnlBynr;3h{%Ky!GUu@c+nPV8BE;PQ4nRgkxtg9)9DUe6E)F zM04Ko9za43lY1+ zcXsTafOj$OZ(YM|>sKhVGc)4F3;Z#bE7Wo59AP#?M%TEi-{c=G@`11UpusK&G5^Nf%keVn;lwn>!%i2umXXNuJMA1+I{%=i@qc%whhOf;qCz-X< KV?T`^9Q+N9x3Rha literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST new file mode 100644 index 00000000..35563012 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do-all-symbols ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 188 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 28, 1986 ;; ;; Last Update: Mar 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-do-all-symbols.test ;; ;; ;; Syntax: (do-all-symbols (var [result-form]) {declaration}* ;; {tag| statement}* ;; ;; Function Description: This is similar to do-symbols but executes the body once ;; for every symbol contained in every package. (This will not process every ;; symbol whatsoever, because a symbol not accessible in any package.) It is not ;; in general the case that each symbol is processed only once, because a symbol ;; may appear in many packages. ;; ;; ;; Argument(s): var (bound to the symbol) ;; package ;; result-form (a single form) ;; ;; Returns: value of the do-all-symbols form ;; ;; Constraints/Limitations: Since do-all-symbols will executes the body for every ;; symbol contained in every package, this test may take unreasonably a long time. ;; In order to execute this test within a reasonable amount of time (i.e. 5 min) ;; do-all-symbols-test package will stop at the third package of package list. (do-test "do-all-symbols-test" (let ((p3 (third (list-all-packages)))) (catch 'stop-at-third-package (do-all-symbols (s (null s)) (when (and (symbolp s) (eq (symbol-package s) p3)) (throw 'stop-at-third-package t) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d46292b061deab74f0ae9be2e7519bfa77f99175 GIT binary patch literal 1547 zcma)6TW=dh6rQ!6OB2W0I3|R&O1A-uWY{2AshR`<8gC|zlieM6c1)e9QWTO6YwE<2 z?G!4YN-BYPFajr{-KFXe;00NEpz1~S0}>MNh`+#V;SYp!oV1Ao4@h3mxqNdjGvApy zY0Dd?W|Y=83Prc9l{Tvzn^kSKRMsk`&GNFVt%6)tiXe=SgPNMWcwusEY_w~dI_5#N|Fh@PeCsM={B`k(y#lqPUuC?IZXJqz6)Blw4oQ>8*UNXS*s9* z5dXVc=XB0CWQN=RuCk>>{cmeM8C%anYxFWBq0Yl77+vvegQ=8$NuT06%S$F~YU<9s zmFA{H?%!#@O^EV2mi5ScJgYohS8hC+4P8Am)Tgwe^&>*OZbF`Vi?LSmXzL+lQEhsQ z@g`SyxVqhVNkKVog9A( z@YrE!4=~>10DOb+4K+Uo-EJr3w>bV0@EmC&!0-V$SHSTEADZ0jZ&eqsdtY+3?rjws zSNI@L{Cxedz4!S52#Cd!BgM$Gy?!3&Dl`f|uty2m^7aN!+Muj$?`xj8{yP-XxOW%( z1N4^n7`DZ4cO(?=;ZqyrXZ5*n>|Y3}dtceJAqBeK@frhHhj9abovjqj!m?KP)PhPv zZT|PQGf9KnQyIKceTLdoCKGx(0~Y(TlMF?GD}70WN@GSBOy&gKwb3F=yEE@dW`&f0 zBP34--QiepD%=bFh$Wd2TYC8{OmJj!iL>N%ow!$o;-N6FjdQ z+_K;x%#4#o@HtE?n8iO}s1AeLd%$4*`5d6V3t<+s(oCS*6TAWo`5R8R_Zl1}%Tvj% zEY2C)e+9Hkg`o4gHwdmZ7!lRf? zfVHi4l&HE90$P<9}9nLcl z!kLjYZMN!ufI$vDi2Nyd9hV=2^QR$P7#@yJj8pJy{VOHi{j}uOlrD6qL zu3tMV-AYv(xkX2`)g^cvSG2Uhn)Bmon!>wv zl^mBW LI7fb%*x&yLNi)M; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST b/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST new file mode 100644 index 00000000..14b3c236 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do-external-symbols ;; ;; Source: Guy L Steele's CLtL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: Mar 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-do-external-symbols.test ;; ;; ;; Syntax: (do-external-symbols (var [package [result-form]]) {declaration}* ;; {tag| statement}* ;; ;; Function Description: do-external-symbols is just like do-symbols, except that ;; only the external symbols of the specified package are scanned. ;; ;; ;; Argument(s): var (bound to the symbol) ;; package ;; result-form (a single form) ;; ;; Returns: value of the do-external-symbols form ;; ;; Constraints/Limitations: none (do-test "do-external-symbols" (let* ((package (make-package "DO-EXTERNAL-PACKAGE" :use NIL)) (external-names '("EXTERNAL-FOO" "EXTERNAL-BAR" "EXTERNAL-BAZ")) (internal-names '("FOO" "BAR" "BAZ")) (external-symbols) ) (dolist (name (append external-names internal-names)) (intern name package) ) (dolist (name external-names) (let ((symbol (intern name package))) (export symbol package) (push symbol external-symbols) ) ) (and (let ((checking external-symbols)) (do-external-symbols (s package (and (null s) (null checking))) (if (and (symbolp s) (member s checking :test #'string=)) (setq checking (remove s checking :test #'string=)) (return nil) ) ) ) (delete-package "DO-EXTERNAL-PACKAGE") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..24700b43b38cbe75b56c6dd3c93ded64c90356de GIT binary patch literal 3043 zcmds3U2IfE6rOu`TS{BnZK=yrYPpmOxbZd?N?J=W-fpMumfbt$-dky_*wl96Rtnqn zhe(K|ARrG*aN9`lKuC;Yj2g|hF)E@o24iCMfd`DyL|-&U;|s=^_*T!E>6V7_Ac?$~ zcJ|D7&Ua?coO|XcO>(*-F)fljI6OF%7}1jBW5eTP+P>t7HkuqC=}&0;K(8H*FpIv> zW<++??5NGRmst8o5`ANd0nHgtj1Kf2c|@yyOf!Z@28W>2&;YQuar@TBy1JVD7Q>Fo z(f*B3Lu2i>n*8}o=aoQ`5YkWPP^=^*KzziTOa;OYwH>`B8l$>t#A(<|d#OBFi{5Ed z%S)AP)y9&;`cUF71!44^?EbY?e2IJi`nGT`P>tP_?8!1^cC}XcZx#Q^A_~1sy=`0$`<+tn_$ht%Ci4 z2`p@&R)LTaF@VJcVCE9?Wm#_-*s!Ony+Ifu1g#ue1++?N8ni0OEt;GmC!YhW@C=|6 z0p4w-f(NUBgo76=XIf)AW3x(D{=tDiW(`&W9khk!Sja!*zcss>g;)TV4*#GpBxJ&! z4c@7PU|)1+6w1mE+=Qt!Z!HEOqFxL@uHn7~Kt5j#fCbZ;GE5W;rQK63kai~qXUJs+ zU#4mfqhnRs)X3hlv`n)gCOh+CHaUBjCZ`Ms?5&<-)sw6`#X^u9Rtn#cg>KE(-DB#G zyJxa-zx3LST7`vz4Ti(|D8gDQx`#TDWGsZ!Vx_`&u@a*j(m@UIHfYO>?kP|NcU4^|^dSXRLaj#r6p?@pA>#TX5khFW+Y*!U1n@Kkl z+_NQHM|oo3&JFg5({5leK-3)Xl~hGI!p!C<9+-NYVK&F8r8h-EW4791)ek3eNjPFS zkv83;PNxMYX+#{wxpueh(738BXE-d(3w*2jN?#eAzC~ebSb~2Haw2Mg@JNgm=!l1gg0^0NT+2{bIBFK6|`LkTiNY3 zMGTwDnRo%3FM_$KnZ~F?vzG$iEG1pkVqJQK#p95OSk&%7@)Tc#;wa8;(KvgOB77cT zvAi$z>}7-c{YZ<`coVe{4)C=o+Cf{;0vTPnVo*m>w=e=;Zm6q)k5T+I@MxFeuy{vS zk2hGruq>lncbH?ubUWIE4!+NL2*ouqjqhDvj_7TPCi#Pi4)aPBk4xqbX$wo{W{HXg zQ~gsg)f6tl=;)wkGdQY;grj;uP}LscsP2(yCtrt@23~<;gBV7c7sDv;3qNH>FqKz@ zpK?i}Q<6C-ncF1uQE6K*nH3WG1(W>BE017Uw5x+z&Nz0Xrb8{0@eMVA3ggDE#c#Qu zSJgv2{wrX}5e0^52Hpj^CYDbO;Tyaf1rD{sb}T6Morp((<;Qmcf_l z7TyrBP3$(uXo`ui@HgKK1m9Ib_kASjzBeVhEYXmpV0o-q7z17QN_7|Cf~Y~dY?m(8 z5^WGj{Y@~{p9NF>UZQU#`a+7=rQlMy!d*>BcSoY#0x5q9cjb2}-V-+E9cjBD(X>Rp zlF}o_RCY@glSr4$uw<^4C@2v5Q83AOf=O;j^p!-PN^wz&G~corlJ0{i-8%koK4$uc zms&ND)JKmTd^R~Wikh#z)Osf|I;K?}Gpe+Geehl#&;}35rzYx-i7z$n!M=`KG~#6U zH9DVztsOPns1m$SGd`6tA!2Tf=voY2&h>*4&Mzco)4X6;7tgh(!%JneI5hVi3J$#B5%GG^p&| Ooy?(pBf0Rz{QN%yK2=Wu literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST b/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST new file mode 100644 index 00000000..ccb0531a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do-symbols ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 185 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: March 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-do-symbols.test ;; ;; ;; Syntax: (do-symbols (var [package [result-form]]) {declaration}* ;; {tag| statement}* ;; ;; Function Description: do-symbols provides straightforward iteration over the ;; symbols of a package. The body is performed once for each symbol accessible ;; in the package, in no particular order, with the variable var bound to the ;; symbol. Then result-form (a single form, not an implicit progn) is evaluated, ;; and the result is the value of the do-symbols form. (When the result-form is ;; evaluated, the control variable var is still bound and has the value of nil.) ;; If the result-form is omitted, the result is nil. return may be used to terminate ;; the iteration prematurely. If execution of the body affects which symbols are ;; contained in the package, other than possibly to remove the symbol currently ;; the value of var by using unintern, the effects are unpredictable. ;; ;; ;; Argument(s): var (bound to the symbol) ;; package ;; result-form (a single form) ;; ;; Returns: value of the do-symbols form ;; ;; Constraints/Limitations: none ;; ;; Test description: creates two packages, one inherited by the other. Interns a ;; small number of known symbols in both packages. For each package we remember the ;; list of symbols expected to be found there and then do-symbols over the package. ;; At each iteration we remove the name we found there. NIL is returned if either ;; an unknown symbol is found in the package or not all the symbols are found. (do-test "do-symbols" (let* ((inherited-package (make-package "INHERITED-PACKAGE" :use NIL)) (direct-package (make-package "DIRECT-PACKAGE" :use "INHERITED-PACKAGE")) (direct-symbols '("FOO" "BAR" "BAZ" "GLORP")) (inherited-symbols '("IFOO" "IBAR" "IBAZ" "IGLORP")) ) (dolist (name direct-symbols) (intern name direct-package)) (dolist (name inherited-symbols) (export (intern name inherited-package) inherited-package) ) (and (let ((checking inherited-symbols)) (do-symbols (s inherited-package (and (null s) (null checking))) (if (and (symbolp s) (member s checking :test #'string=)) (setq checking (remove s checking :test #'string=)) (return nil) ) ) ) (let ((checking (append inherited-symbols direct-symbols))) (do-symbols (s direct-package (and (null s) (null checking))) (if (and (symbolp s) (member s checking :test #'string=)) (setq checking (remove s checking :test #'string=)) (return nil) ) ) ) (delete-package "INHERITED-PACKAGE") (delete-package "DIRECT-PACKAGE") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fb742032c891776d29486c0d6d3c4f6349f2cceb GIT binary patch literal 1130 zcma)5;Y(9d6u)m%H@6v6N5T?)GXu2`CC?XMw zJ}q)e@^0amzV@Lo2uw++f5`v9&fSXHf`|w2o%6fro^yV`b6y2CPiuy(<(Bf9tW%J4 zrDDERloxXac_mjW%scWT;PNxgw8--@Rh#I$9S_+jPUZ{FT+vyOS;<*hn0tCzj^C2i zd?AwsV{j1M_|WzKp@D(EP(rnhTDJeWGdMJGwJ&tMvn@q)2%&j&C_b$SMUfwQo8_p& zh|O?9HwdO`k|jlVrj8Qi3;xO?vP)h$9FOChm`tZki=mzEmUU?2yXfSryFV`NEu({jao^Ob z?slnJpbrshLuhxdZUb_(+X?SF1SEXY(VDwESjRF)yO-+TKQ67g;@O9Yj`cu9a`(Pb z5nY*hMSmbvabMDLp9DQ@x}Q3ys?v$HL4+a*9cJb`DsD6rMZRY5P5G>%nRG-KTHrC2 zju^zk!#W^z)K+{=Aac8+sZ1Ng7GY@%MAE7%x7af_BT1k1cLXyP9`*-#t3L?Bo>GWq znHDzFER|-8zZEV-6qU~4DsC$r6pqFl1{Lrl#GAx)!b0sYkfOfr7erl z6VvCCIC~Fgr|XCML>TEST>11-7-export.test ;; ;; ;; Syntax: (export symbols &optional package) ;; ;; Function Description: The function export takes a symbol that is accessible in some ;; specified package (directly or by inheritance) and makes it an external symbol of ;; that package. If the symbol is already accessible as an external symbol in the ;; package, export has no effect. If the symbol is directly present in the package as ;; an internal symbol via use-package, the symbol is first imported into the package, ;; then exported. (The symbol is then present in the specified package whether or not ;; the package continues to use the package through which the symbol was originally ;; inherited.) If the symbol is not accessible at all in the specified package, ;; a correctable error is signalled that, upon continuing, asks the user whether the ;; symbol should be imported. By convention, a call to export listing all exported ;; symbols is placed near the start of a file to advertise which of the symbols ;; mentioned ;; in the file are intended to be used by other programs. ;; ;; ;; Argument(s): symbols (list or a single symbol) ;; package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none ;; (do-test "export-test" (and (import '(lisp:machine-type) 'USER) (let ((SYM1 (intern "MACHINE-TYPE" 'USER))) (and (eq SYM1 'USER::MACHINE-TYPE) (eq :internal (second (multiple-value-list (find-symbol "MACHINE-TYPE" 'USER)))) ) ) (eq (export '(USER::MACHINE-TYPE) 'USER) T) (let ((SYM2 (intern "MACHINE-TYPE" 'USER))) (and (eq SYM2 'USER::MACHINE-TYPE) (eq :external (second (multiple-value-list (find-symbol "MACHINE-TYPE" 'USER)))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1c29266fbf8bc53466a43e777987b5f4e2c64f29 GIT binary patch literal 848 zcma)4T}#|R6urrQxaulVsumF&EG;y2q$?J!?aP>*)z$1olL=P(P}bdSvk*7SeiWos zqz`>cX;-Nv7XL$Et))Kn5A`3|$*!Q-mqH+C?#w;+oHNsb#7k9^Rd2Umb?t`iwOjRe zORjhgx#_hVC0nlWy8KSn4f1{!tLwARGXv(0ol?Utw(PRZ+IF*C+FM0k{QT@d4x3t!?SFa}m*y8{2QE*K1<3<|5?n;TegFw#5FGlF!idRGF0T

&;# za3yr=gk%13%~J=?IY*-(`qF}P_KR}-r?dWv{s!ncAL*JX3;`TE-^aJQW+Q?WKpNnp zS{m&*QdI&m5q$Nh6ji6$e54+&Vw%;6ftIxCbc=0ROo{dLhO~m|HtN<*CFGe%nOo8J#Q?&1 zlxJdxlO%JxQNZkVG)%P&gU}oI6bh8r?_B#(u}OOD;ou|QE!_@#Ivh)8`9`8E;RV0K zB#j1WPr`|ZydEpyjr-x<2@c~XVVm(+TwCML>TEST>11-7-find-all-symbols.test ;; ;; ;; Syntax: (find-all-symbols string-or-symbol) ;; ;; Function Description: This function searches every package in the LISP system ;; for symbols whose print-name is the specified string, and returns a list of ;; such symbols. If a symbol is specified, its print name is used. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: list of symbols ;; ;; Constraints/Limitations: none (do-test "find-all-symbols" (and (member 'SETQ (find-all-symbols "SETQ")) (member 'MAP (find-all-symbols 'MAP)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fe0896f3b9a5fe4d3435732fe20e8a71c2acc6b0 GIT binary patch literal 1379 zcma)6J8#=o6uzWvRc}a!k%tn}&v%~RJ?HR_$ovJi&V9!>A9JLFz9rpmUGu>;dR=5!V%*A;6{p7 zUA0Sw?mgxna0%~`n=I*41+J#7Q^H3kSui^XX=GWt0#)?2cP@KRk`D>tl9@D*l>TVE zEORgJko&L7{MKSN!-XeA>&JY`w+KN+9PY3%ZoUM#@bH5S*LZOwH8xTJ_ea_zBlU)m zQR7=9Rpz-Qh|f-Loxm`#M+iv}GH%whU-JC_gj48h0?rBjq^tBRpR@zYXHI16mHRxMOU$;a)%%c1} zj4dOoimh%)Cbg?3v|aV*7PhWiHr?cT@K_86t7=rys}-qen46Z!IG+1|v~7qi9*Tk? z<}br!h=q5nfZ9-!MMLqUJ~B&(aP}#YnxY?&ib_$QZ;25z}Eq0>GPJYR<=h1yrDbwku=Gf^d`W}E`zG52dI-+~Q?9|{f*%q32f_DIQyJykundgSvo$X=E5BddA|6YIK zw9&=@4IqV7K=l0-$zORtdyjEra;ixcn@UGIsg-PMDw@UO=mwYmtZLYlCML>TEST>11-7-find-package.test ;; ;; ;; Syntax: (find-package name) ;; ;; Function Description: This function returns the package with specified name or ;; nickname. ;; ;; Argument(s): The name must be a string that is the name or nickname for a package. ;; This argument may also be a symbol, in which case the symbol's print name is used. ;; ;; Returns: package-name ;; ;; Constraints/limitations: None (do-test-group (find-package-test-setup :before (progn (setq test-package1 (make-package "test-1")) (setq test-package2 (make-package "test-2" :nicknames '("system" "module"))))) (do-test "make-package" (and (eq (find-package "test-1") test-package1) (eq (find-package "test-2") test-package2) (eq (find-package "system") test-package2) (eq (find-package "module") test-package2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e185e8c8118885745943ba23ec74d7d922aafcd2 GIT binary patch literal 1100 zcma)5TTc@~6rOGAjTTY}mxu<}Mqf5AQi2g`VzO+fbldGL?oP!TV}iZdCM|7xF(F1$ zdGM)33judE#8)4DAozqBeDDwP5Ae*EDB^==lbt!2`ObH~Inzb1hqB7c)k>{Y&e!>B zt66I``9ihMH>$0AHqRHp&%cm09lwlAa&qc!xZgMz$=35L&3ulht$ZW5vUZaX&+}5P zUMj<8ZVt?FiCK+lE?SIb9N2X_{`cL zD#jEQi$qFc!R(qHFZ3d&4Xm4;p&7net%>FQ^L&}LQ)wU$A@gm=8%qe1=gdwp92W0D6%rMVOlm<>(cZ3m1DM!!z7~%X+~F!Z{FZPm z4^9kmE=Ka1&2zy19}^DDlXvhV4(_B~JXkzSf%w7vztczlNa+^arFM~hM}RoI;R$fX z!(+lqbd#Ip2SVNAYm#tqfWB4SA6vG?V-Q}10>HYI9qtx`r66*+%$?2^LDooAVQPqR zi9}Vbiwn@JLKY3d(FZaQ39>}xxTs^A)<<~}Pbr*$2Z zbN6p?EcOv%Bfoo+B?I>=S^fr~_|IKr4eWqzpWVFyf_NUM9;k{zm#op0H72pb3ZYmh z*RAnu*65@)=4WMgAmFk)VAdu~m76erDl=bM6BUSik~p)h>Cq=_=6WEKngM>!hnYug zSo_$ZCct5DevL01yn9yY798^_B#w23;-~!s4Nit^IOd`Ey92UUm%n#CML>TEST>11-7-find-symbol.test ;; ;; ;; Syntax: (find-symbol string &optional package) ;; ;; Function Description: This is identical to intern, but it never creates a new ;; symbol. If a symbol with the specified name is found in the specified package, ;; directly or by inheritance, the symbol found is returned as the first value and ;; the second value is as specified for intern. If the symbol is not accessible ;; in the specified package, both values are nil. ;; ;; ;; ;; Argument(s): string ;; package (&optional) ;; ;; ;; Returns: Two values (symbol and symbol status) if symbol if found. ;; or NIL if symbol is not found. ;; ;; Constraints/Limitations: None ;; (do-test "find-symbol-test" (and (let ((find-sym-list (multiple-value-list (find-symbol "COS" (FIND-PACKAGE 'USER))))) (and (eq (first find-sym-list) 'COS) (eq :INHERITED (second find-sym-list)) ) ) (intern "XYZ" 'USER) (let ((find-sym-list-1 (multiple-value-list (find-symbol "XYZ" (FIND-PACKAGE 'USER))))) (and (eq (first find-sym-list-1) 'USER::XYZ) (eq :INTERNAL (second find-sym-list-1)) ) ) (eq (find-symbol "JUNK" (find-package 'KEYWORD)) NIL) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cab7952b29e9e6d5bee6cea43721ce2ed022b8df GIT binary patch literal 2140 zcmb_dU1%It6uvW?q`TS8x@kl6V~j(ZR#`H^4be91gG?rOlQpw5>-@9{1VWl@+%3D= zxVuq`7(x*GG7@94%vIYL@yQ444`MMIp^v`$&?iAq5JU(F3ckd1=4R8~whs~dFr2yP zp7VX*z4x4ZcS!53s!3|Ov{oqQDpGm9wzgiAR>~ErT3)X#<)jtxOK+-%N#B}Q)R~bN z6YW;R%u*${Sj#O-_Ij?mym)n3N{ma&TBT5gp9>dYm`FZ9nj9M&X-_GZ#?g+GGoDP0 zjQj`gox)lV`uHco+(q zh5chwbaM*KZQy7i5a#LxA<%iBWB*q3a5MiHIq%guJDNz~m_=d#i_?#AK2Cb^g*ts0 z*9)xwdZj!%YBHGj}bBKz3=wNRYRXlW4+1Kiax1PQ=UkJN1w9dVh0O}A^3vu zwZYd4h20rf6$P6sGD|cAGV4*)$`H5Yfd;U)89hJ6Snpm>Db11W|Z6+cx4X z9Eh+`pdAW58mFddn6ly6S;vkCqL2`YEBc)5`w=AY1o+z089+6TItqKib7P4IIx5ma z2y4MM>czH@fT4w6R5To%ftSJ-7Vg1x zbdqY+ru8mGVV$$oG-hSh$Yfw^wX~JR;ICOXnlD)onvWR@6W)MxI5D5O2tg=DsDZX{ z3JyWG<}woo>J=`tr_e000W{}1%ov9m@?pro{v7#(o4bAp`N0n%w|U4lTs6Ne7FhQ@ z>&dX*LGVQ~%FL1aeqa!v1aE8BG^TVMwZj@CJWrl74JXS^qKv;W$Uhn!{Rx*>n~q!R zEB=`cq1R()&}{S3CO5AEUdJKcgko~ED|q>(b(@+xN0?`4G1Xz`(DZVk7)KC%L;mqY z$iA;ubNo#vzjNm=;0&4ymbQ;aKJgLAM?Cc%Zr)~R=h)x`J2TFP;%sODLCML>TEST>11-7-import.test ;; ;; ;; Syntax: (import symbols &optional package) ;; ;; Function Description: The argument should be a list of symbols, or possibly ;; a single symbol. These symbols become internal symbols in package and can ;; therefore be referred to without having to use qualified-name (colon) syntax. ;; import signals a correctable error if any of the imported symbols has the same ;; name as some distinct symbol already accessible in the package. Import returns T. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group (import-group :before (setq im-foo (make-package "IMPORT-BAR" :use nil)) :after (delete-package "IMPORT-BAR") ) (do-test "import returns T" (eq (import '(lisp:rational lisp:plusp) 'IMPORT-bar) T) ) (do-test "symbols imported from LISP" (and (eq 'lisp:rational (find-symbol "RATIONAL" 'IMPORT-bar)) (eq 'lisp:plusp (find-symbol "PLUSP" 'IMPORT-bar)) ) ) (do-test "imported symbols :internal" (and (eq :internal (second (multiple-value-list (find-symbol "RATIONAL" 'IMPORT-bar)))) (eq :internal (second (multiple-value-list (find-symbol "PLUSP" 'IMPORT-bar)))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6127e649ee7a202cd22d668b142f66efe4a54d87 GIT binary patch literal 989 zcma)5%}*0S6rb&P>4$|NDj;l{5Y2`~+h8nkT9zp+Y-j84Y%0g5ENo+;O+QSGN(cu| zYp@V;2Seh?v*CsqIrtCpAK*+2LhxdCHZ${kZ+`QB@4aaQ|4Uira(fyJz% zLJ>(hD7bCc2~jPgX+Yg|deeNfS`#bQYpcTKtTzA$fcw!2WlbbwMMLgBx5Y)>T_>g> zF;AsQ^ALDKmn@8(bDcY>l=xh{;c#>i+@^tiW6}JuPZzn94e<5nqNk7;?B)Dxoe+-| zI(J6|fa9q`yo;Y7k6$_@uc5nLi2Oyi?CbB88vC|`an3&Zh3NXcz4QV72B2;4phXWC z17OeoK2Ydm(Xc-RKoo$pa;d*1sCt#;!Y&DvEa#Kq3t3~?KR`~Kp_mMDcbBuGpxceSTJtFH+!ce@W aQ&lk3CDkAi=0*j)Ff|OxeQ@~b;^GfCZX*Ez literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST new file mode 100644 index 00000000..a93f66b9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: in-package ;; ;; Source: Guy L Steele's CLTL Package System ;; Section: 11.7 Package System and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 7, 1986 ;; ;; Last Update: Oct 16, 86 ;; ;; Filed As: {ERIS}CML>TEST>11-7-in-package.test ;; ;; ;; Syntax: (in-package package-name &key :nicknames :use) ;; ;; Function Description: This function is intended to be placed at the start of a ;; file containing a subsystem that is to be loaded into some package other than ;; USER. If there is not already a package with the specified name, one is created ;; as with make-package. If there is an existing package, it is augumented to ;; reflect any new nicknames or used packages. ;; ;; ;; Argument(s): package-name: string or symbol ;; nicknames (key): list of string(s) ;; use: list of string(s) or symbol(s) ;; ;; ;; Returns: package-name or nil ;; ;; Constraints/Limitations: This file may be similar to other files that test ;; package functions as a file may use the following or combinations of the ;; following forms: ;; (provide ...) ;; (in-package...) ;; (shadow...) ;; (export...) ;; (require...) ;; (use-package...) ;; (import...) ;; (do-test "in-package" (and (boundp '*package*) (in-package 'foo0 :use 'user) (eq *package* (find-package 'foo0)) (in-package 'lisp) (eq *package* (find-package 'lisp)) (in-package 'user) (eq *package* (find-package 'user)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL b/internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c10ba974930f83eeb146b9fa3ced2fe1960e09af GIT binary patch literal 1401 zcma)6-)kF35Z*i4mSovRc8mqF8(mEU$&ocxemZWUoX@N1?9-jQw-?)x7sozV0!1>i z98yYy$wTSGl}0fQw+Z+9c3Ip>KskAM*#~C6MRh&YTh)6h8!=*u8INzWHWn z_S&R(*|asYac#3&3z}MEyS2I9(l#1RZL6`}Tnn@fz_qVTm$R=+hPg2HNul3+%d*xC zR$IZkCbomE_0=y=X@!fLvDvKFU^6`puZ5X&r)SQdo$4B}UZLYZhczqA*h^&IPv=szI8 zC%zqTt_lu0TKG`NBL)f(FRqA)K2 z)Fy8lliJ2Ae0SEhYQ6KxKXyJzK z$qc%|p?&VVg2{1=4ZGBJl*a1FxAOQxcjoDC;8ZN*Xg93Hn&b({C{N09a_`*!{{KFW Bl^*~A literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST b/internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST new file mode 100644 index 00000000..70673c12 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: intern ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 17, 1986 ;; ;; Last Update: JAN 14, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-intern.test ;; ;; ;; Syntax: (intern string &optional package) ;; ;; Function Description: The package, which defaults to the current package, is ;; searched for a symbol with the name specified by the string argument. This search ;; will include inherited symbols, as described in section 11.4. If a symbol with ;; the specified name is found, it is returned. If no such symbol is found, one is ;; created and is installed in the specified package as an internal symbol ;; (as an external symbol if the package is the keyword package)- the specified ;; package becomes the home package of the created symbol. ;; ;; Argument(s): package ;; ;; Returns: Two values: The first is the symbol that was found or created. ;; The second value is nil if no pre-existing symbol was found, and takes on one of ;; three values if a symbol was found: ;; ;; :internal - The symbol was directly present in the package as an internal symbol. ;; :external - The symbol was directly present as an external symbol. ;; :inherited - The symbol was inherited via use-package (which implies that the ;; symbol is internal. ;; ;; Constraints/Limitations: none (do-test "intern-test-internal" ;; Also test import function. (and (eq :inherited (second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER)))) (import '(lisp:software-type) 'USER) (let ((SYM (intern "SOFTWARE-TYPE" 'USER))) (and (eq SYM 'USER::SOFTWARE-TYPE) (eq :internal (second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER)))) ) ) ) ) (do-test "intern-test-external" ;; Also test export function. (and (export '(USER::SOFTWARE-TYPE) 'USER) (eq :external (second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER)))) (unintern 'SOFTWARE-TYPE 'USER) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL b/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5e1555066395da348c14c262b7a32382b8cd84ff GIT binary patch literal 1196 zcma)6&1(};5PzGbZETacDH22d=pt5R^%WwO){5Y|eX(gb@74XF?Zpz(ts9I@NK!#X z5d~3*XcT3i(u;SYdaIQd@#xiqg5b%M7ypAgFKukli!95|{AS+F{NBuL19i;khN73Q zlnX_-qLh|u<)xakP^u`^(o!YwDhq%sH*{u_o8y{3Ie0qNZM9kQ6*pIN=M{U&tNos)7`R}^BBo!DpHOP0GA_DT-J+m#rHUkk{Kxfh+M&9g zVbp&r-IgN$qk1$$@f1+g&Jz>}Z$}Z)CBL3XrSLE|GLT9$jFy{)mY;XtfqH(5qTYFH z6VmD;`tg1uFukWQE_GaLRvJd=z^gat!H)L!dYfEqlP_+Qduz3U(}{(no|qWig-0toI05@3UU7Z%zhZ8dzWX8b#=~xAUw)xZXQmvgECf( zCLdCW(eUokiGT#&PrQ}HbV8IOUMN3;&_*GjY0b|6%5hGVvZ^UIxyw0m^JqfdwoLG7rJy|4c*<(B0N-_8c>CYrO^D|~?7 z6z>m-EMH&=iiK(o=ZZyK&gC!XF1b})bE`FB{p{EKZIG2ix3ojbLJocw^GacHYtIFC wYajy~)v8AFU;0l2kl~CML>TEST>11-7-list-all-packages.test ;; ;; ;; Syntax: (list-all-packages) ;; ;; Function Description: A list of other packages that currently exist in ;; the lisp system. ;; ;; Argument(s): none ;; ;; ;; Returns: List of packages ;; ;; Constraints/Limitations: none (do-test "list-all-packages-test" (and (member (find-package 'LISP) (list-all-packages)) (member (find-package 'SYSTEM) (list-all-packages)) (member (find-package 'KEYWORD) (list-all-packages)) (member (find-package 'USER) (list-all-packages)) (make-package "FOO-PACK") (member (find-package 'FOO-PACK) (list-all-packages)) (notany #'null (mapcar #'packagep (list-all-packages))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..88070d3043acfc36ccf1e43f5b577f791f6365a2 GIT binary patch literal 2044 zcmb_d-D@0G6u+~ZkKKIK%}1LW+hn?GpkrrYW2;TXkLm2)W|P^Ob!N7kC@5>P$u3Q@ zOLkK&Vu(R3lr1%BQ|B70DEQp4;6sfxU>^jr4}vHt6#54UzKDw$VrQuPPt=HEaeOG zZ015{7R#9{5`hrsqp~lW)KxoX=*~4^S!i>vmfK^xoPg4lvy^yzRWImW05{>V{Jb1j z#%SH-<_-S}A;RyN&)3*ra#=#*YwS-qnC=4;u_L;KytYBrDy;9RVik4UPaM`AcU z@`$2GG-}FcVj$7aT9T)k`8|#BG{AIrNUCD1BeF^DqzTidy5reoO;|RKdxU>l*oMSf zy?*BRw!=gokf>=IrfekbMADYLt#F`CQuGPgm0J=Myg0djsXDh3OzN|H2j1U62y4JG zAHacq00)|)h8b6Eg!eHCHEEhu-?c_eK;1pibw8|CRV>OQvsP4p4(bCDs!_YX6}WvJ zAN}%zl5VkD}U8*e*3O@#6bM%an)FZCZWyB^uM@@^O{u1DhYHhL} zQ^#<{E!2F#9!FASN01aangR1b%^db0gS$meas3;doCCAA-Mfq~23Qx8Cs{X=E_M(I zdB6@Mx$mAMzi{*uNB21To}+JBFIs+u31d`Q(X?8nm@uhuyDwQkqAxgF=V*r1gNn{`Ln!Cr9L#9QRndKYk`d;ef8Y{9FnNyppN5Z+=zBpYxuKAooA4C-%0 ze3zm2x|_N1K6@I`94Bc`UWbzncxUV>RGQ4483Uqtp`j=m0p9<}UHI8CR0wWt@+T+1 zVG4K`@@tg3&d84-YIa4b2`>4rE}`RGvdz1Ciya4-~UYElI@WX~RH zF`Jr-X0cW@gDZVCY1ou^vVXrq+-#m;p(Ur@#Kjs*$KQ0ru_18Aph*c>L#f&ZNzS~J TE0&5cYb+!@YDPX8+1dFUHQYRb literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST new file mode 100644 index 00000000..e6f11fbd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 183 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 13,1986 ;; ;; Last Update: Oct 17, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-make-package.test ;; ;; ;; Syntax: (make-package package-name &key :nicknames :use) ;; ;; Function Description: This function creates and returns a new package with the ;; specified package name. ;; ;; Argument(s): package-name: string or symbol ;; nicknames: list of strings to be used as alternative names ;; for the package ;; use: list of packages or the names (strings or symbols) of ;; packages whose external symbols are to be inherited by ;; the new package. ;; ;; Returns: package-name ;; (do-test "*package*-exists?" (and (boundp '*package*) (packagep *package*) ) ) (do-test "make-package-test1" (and (make-package "PACK-EX") (make-package "PACK-WY") (make-package 'PACK-ZEE) (not(eq (member (find-package 'PACK-EX)(list-all-packages)) NIL)) (not (eq (member (find-package 'PACK-WY)(list-all-packages)) NIL)) (not (eq (member (find-package 'PACK-ZEE)(list-all-packages)) NIL)) (if (fboundp 'delete-package) (progn (delete-package (find-package 'PACK-EX)) (delete-package (find-package 'PACK-WY)) (delete-package (find-package 'PACK-ZEE)) (identity T) ; T is returned when a package is deleted ) T) ) ) (do-test "make-package-test2" (and (make-package "NEW-PACK" :nicknames '("NP1" "NP2") :use 'LISP) (member (find-package 'lisp) (package-use-list (find-package 'new-pack))) (or (equal (package-nicknames (find-package 'new-pack)) '("NP2" "NP1")) (equal (reverse (package-nicknames (find-package 'new-pack))) '("NP2" "NP1")) ) (if (fboundp 'delete-package) ; delete the package (progn (delete-package (find-package 'new-pack)) (identity T) ) T) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a64c827e63c6e6a00213ec6afb3b61e078704cb8 GIT binary patch literal 1225 zcmah}OHUI~6u#3!X=#Ch5PT6kVsJ5WkRk?z#AFz5VPHB_=aE88Oqw##D$u46qcIY~ z!qpfpD4DAvap}@@hZwscaplUjKf-^2=T0dCF3fZ?=bZ1}bHDSQb6Z8N3zEV~`L#lB z)h=@RO1V%ebIbW6SISq48Jk;%IQLxAbo^pgl;(#fW9`N%BvZ80WqXM;D|Trq{p=yP>Wz0Sa+T75w4ss2&?uJdzF^6RzeIy?i(iM{Z2^Qx3+*>cJNF$D1>%~X5KZbHQo@p@>sUQCPlTaZ z4Y1z7dPt&y8z+(Q20)$DSivT4&Ihfjdjad(f*@&$1PG|eM)E1?FT#m!@hQzxr<0GU zZJ0XfnOp%o(v*Zw@dFZFps_dz-po2rqO*jXB+*+WdV_)qasK4UE96>$68!`~tEU0= zKEj*_R9c}z-M8d=p7dKlxP=lTU6`8mo{%nYmg~T~kj^|#uh_zRdd(KfcBxEv9=J}_ z1e+V!5C^#BH2fDVak=%zHKwtR!G~@ms|sJ5@}BF24NNuj3K(&nj<~GDRi$+foCPnO q0U7s$yW<0DS0x>bAnQ5d71_kPs2C(nmqESvEzQJa0KLC`bo2-LU}!D? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST new file mode 100644 index 00000000..45e5228e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST @@ -0,0 +1 @@ + ;; Function To Be Tested: package-name ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 13,1986 ;; ;; Last Update: Dec 15, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-name.test ;; ;; ;; Syntax: (package-name package) ;; ;; Function Description: This function returns the string that names that ;; package. ;; ;; Argument(s): package-name ;; ;; Returns: string that names that package ;; ;; Constraints/Limitations: none (do-test "package-name-test" (and (setq PACKAGE-A (make-package "FIRST-PACK")) (setq PACKAGE-B (make-package "SECOND-PACK")) (equal (package-name PACKAGE-A) "FIRST-PACK") (equal (package-name PACKAGE-B) "SECOND-PACK") (equal (package-name (find-package 'USER)) "USER") (equal (package-name (find-package 'LISP)) "LISP") (stringp (package-name *package*)) (if (fboundp 'delete-package) (progn (delete-package package-a) (delete-package package-b) (identity T) ) T) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..33ad1be1a44287c8c205c12d9ea9e987772905a5 GIT binary patch literal 1342 zcmb7ETW=dh6rNqj*Ep$NP*F>1mrCJb#YA-oB25Kiy&1=w?8VHCY5ZuMO>NbVE!$~@ zP^+jys8Y8oPK22S^*wk$%Z9nVe7lfgXDp4rUmyCr8b9y{yY;U>)C#vW zqt|b>;jy*`VqyK`mG#xth{k9yZGe8PL;`<;~s=6k(JXahm zhe}pF4;CyJS70<_lOQ!U%_6faBDhp2;7?Ai*tN`US&X3<7f4K1eYqb5$ z{S%>4^E-D-RUqq8^Os9^B4}im6hc{qUbh+-N6lO-ht#{WTC z%Jo$&w z-M`uHEzo8iV|$kFeF)4hG0!2>xNG6%R0q7`(V#xiD&fiz>{|Gq4ecZi+bk2OHY25^ zQ!&&E;F+GWNC#=YLP^Qmi8%Z&L{7mEucss$-vR@B^~SyWT_5ka8u#|=9e;p_{$MDr zha$Mn;jP_xWZcm9>Ts#MT5ErDWK#EN>9a9<>+>nkCIkbXDe1X zhI7Ma@R)#uR>iS;Mjg4~nfU`TL-Cz4T8M@K-v9sJl?3#*$SkJ{ABqUv!HUPV6@Pfq>@`+0_z literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST new file mode 100644 index 00000000..d10337fe --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: package-nicknames ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Creation Date: Aug 13,1986 John Park ;; ;; Last Update: March 24, 1987 Ron Fischer ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-nicknames.test ;; ;; ;; Syntax: (package-nicknames package) ;; ;; Function Description: This function returns the list of nickname strings for ;; that package. ;; ;; Argument(s): package ;; ;; Returns: nicknames for the package ;; ;; Constraints/Limitations: Checks to be sure that the SYSTEM package has nickname SYS. ;; Does generic check that nicknames are on the nickname list and also makes sure that ;; any prefix-name becomes a nickname. (do-test "package-nicknames-test" (and (some #'(lambda (name) (string= name "SYS")) (package-nicknames 'system) ) (make-package "ALCHEMY" :prefix-name "ALCHEM" :nicknames '("METALS" "GOLD")) (every #'(lambda (name) (member name '("GOLD" "METALS" "ALCHEM") :test #'string=)) (package-nicknames 'alchemy) ) (delete-package 'alchemy) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cd484fc1e56875ae2bc2fc558e74700c64d80c65 GIT binary patch literal 1323 zcmah}-EZ4e6u)+wENwpOMpc0B1G5c~EL<(oD5FS7j_WjTo$GRat*r1+Lh9Dh(k3M7 zPz6k5Ou&N?%O-~J&?LkgZ)Fk>W2i;ql|KO9dECRE_FB$$S~hhL$g=!9=lt&P-t%!i zK=F&ZCF|{tPP658<@Q#;v(=Z^+FiNV-s(0yc@6yX$GT07Pb-?fIQ>>(%y}x(=z8_O zw<^;uueVy?eoZdCDQlf>vjyP71uzSmS+i!;+>`*&{( zQX3)EKzsZ%ijah2D7+a+3N;+6mQBl0u~s#da1aJb$VGJ>gM`6EQSP@pYRkLqwRk!k zJtQC$-UyOq7wgotad=C(Dx|}2f{cmPB}h%1H;|Y-P~qxA7@R5;)He>Js#DSC?3#(^ zRcEM!&2_#|QM&5Y;9j zo0DLF$7$g6Q;=sK9M^}0d)u{qZ8C$Hm(B!OQ5MmS6cIlE!l~@)?X+^`!YUFnm2HlnlM}{U7M~IE^Ns)M) zGa!^G+oY;dZXV+&(_KOg{L~~e0b=Me#3r94u4|4l+=-=l_y?}!Py$8Z=9gf;a4>_< zP8nxh2S&OKWjh?kPa=hAAV1{L#MB^ojh%cCtQ1^=Ln2{`GE2;WS32B*M=jH#1$O*Z zmN?E5e2CFQpv0qUaO)qqD+$bVwYd2gdx?KOgS19U+PhF%n?q1pV&f&?#z1tMojJ?S zi~>=J!QJW98<*!uzdQ8c3NJm!@p)# zZf*{L6Wn*@WlsA&yd{Q#XfKArNW~@9%iMCML>TEST>11-7-package-shadowing-symbols.test ;; ;; ;; Syntax: (package-shadowing-symbols package) ;; ;; Function Description: A list is returned of symbols that have been declared as ;; shadowing symbols in this package by shadow or shadowing-import. All symbols ;; on this list are present in the specified package. ;; ;; Argument(s): package ;; ;; Returns: A list of symbols declared as shadowing symbols ;; ;; Constraints/Limitations: none (do-test "package-shadowing-symbols-test" (and (setq barr2 (in-package "BAZ2")) (lisp:in-package 'lisp) (member (find-package 'LISP) (package-use-list barr2)) (setq blap2 (in-package "FRUMBLE2" :use NIL)) (lisp:in-package 'lisp) (use-package blap2 barr2) (intern "HURM" blap2) (intern "OK" blap2) (shadow '(HURM OK) barr2) (equal (mapcar #'string (package-shadowing-symbols (find-package 'baz2))) '("OK" "HURM")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ed56cc99f537dc19acba6950cd5a0ceb107f3d7c GIT binary patch literal 1366 zcmah}OK1~O6n&HQljhS-YyDti9II6re8q_sYZYM}Cnjw&Q)ebbaTU_3304#G5mXc@ zs2~xIMVY4-L~yU!`9T+MT)KAa!i6BN-PC*2q>XVQneg5{=f3mqZ>COq&nO8&DO@b( z7wwWzs8)*Aim*^93FShyl(mHgz=dmyZm8E|vNAhyRPve~OtxfaD)zi!RqgV8=E{CS zIwHu$QhpIOQ&V6{(}yC{lamwPsB9+I)c$)WGJW8{^uehK@9N59jxP{Gvg9K!1BCFz zO`L}{UbIxxqS1IlrJ9^nMW^o6Jdg`bnX2K`h9g3yP^63YWqT3RxmYF~AVz`y{CO5 zq@KI2&A2!ahg-L#x8Y^@_YmSIVY;5i;8S1F>0t*%78K}%|7*+XH82@y10KmEL~(icRvu`sIIS9KC<3kY>eB3 zJa(hiH!86q_dquo0Wi?5gq}V&;Kt4mimGAg2Gvv6T*?yNUU2q{vUZj>aZ_Y40=(2U zN&WqVupS(rO*jNUL8vdP8%fzh^9N`QD=EWJwT|&*9CBZQ8{H_GB0~nvo0t#jm!QPA zGiuKo63>C~N1?Fod=Ye55SL{Z!sYIob&G|rgR`%rHU&JKlxNqAHP3?QSUAaoF%~+` z!uwfp9}5Lp*pE72z`M5@6I!3)h3V5Uw*;E+nSjd*q|pQK!5kYx^8uKF_JtIRj^NT? zAQb&70_~QfR~oe4a7+cFH4tp*DBC;5#`myY9u)Zw)h}kU7c%Ey4Ap@VNc_Dvk?dyWrjq%IQvWx9zV;7vxTg^^OngnYj?ya4c#5qqv0YVEa hhALYs?P^;hZmEWxFqseCpk}92x}~z6CML>TEST>11-7-package-use-list.test ;; ;; ;; Syntax: (package-use-list package) ;; ;; Function Description: A list of other packages used by thae argument package ;; is returned. ;; ;; Argument(s): package ;; ;; Returns: package(s) ;; ;; Constraints/Limitations: none (do-test "package-use-test" (and (setq use-package-1 (make-package "USE-PACK-1")) (member (find-package 'lisp) (package-use-list use-package-1)) (setq use-package-2 (make-package "USE-PACK-2" :use 'SYSTEM)) (member (find-package 'system) (package-use-list use-package-2)) (setq foo-package-1 (make-package "FOO-PACK-1" :use NIL)) (eq (package-use-list foo-package-1) nil) (setq foo-package-2 (make-package "FOO-PACK-2")) (use-package '(use-pack-1 use-pack-2) 'FOO-PACK-2) (member (find-package 'use-pack-1) (package-use-list foo-package-2)) (member (find-package 'use-pack-2) (package-use-list foo-package-2)) (member (find-package 'lisp) (package-use-list foo-package-2)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d44cbb36db0a4129e7b087fa8fe258e16fba0ebe GIT binary patch literal 1179 zcmah}-A~g{6u;g07%<5oMCKxLgYm)2MMh8&O|*1(FxIuuc7c(QI7eZPlP&u&F-Ago z;HgFj(ey%i^VLL2O#BKw=pW>Nfah*75gtsN_MG22_k8@$X{)GtURJQ2e_F6}RuShb zgGTEb?~(&j}XeBL;h+*D1f}k-Esn= zNez=kV+tjzl%S$pbsZn{LXrm6U8idVm-7XZvz}Qw-pa_7X#Lr2I&iYPI|M0@XAHlUJpk)YQ@%{P<7w_Vng1_e$+sLn;-2!X#YXo*6`@tzi|%fts}b)r$c+) zUeDIA?|^o1wEBhY*8>&g-_`gl^(R8r?4~;H5iTGENiWXTsN_j~2>B5@v@_k+Y`_j6 zPqX{hxh%?>8i{dk$dsf;6snVn7$EATA$ppC^e$1BOnHjv)J*C?np|VO#Yh<@O?ZU! z9;PO;4sR=K^ZJ13PLb-mrV}k`&LmCI+Xe^xqNJus4L3vvj0eJJ2G{CEh&AzPb#uPI zK%kbWrY9tmtDkvNIjQSZJ+%!?;I{W*>-pQ0EE%+(iFG^!Q)h%K)TAfVW#%J5x?;|1+D!`FG`ahjUb^hh6f;{CDyUN+FgQ+#rroCML>TEST>11-7-package-used-by-list.test ;; ;; ;; Syntax: (package-used-by-list package ) ;; ;; Function Description: A list of other packages that use the argument package ;; is returned. ;; ;; Argument(s): package ;; ;; ;; Returns: List of packages ;; ;; Constraints/Limitations: none (do-test "package-used-by-list" (and (member (find-package 'USER) (package-used-by-list (find-package 'LISP))) (eq (package-used-by-list (find-package 'KEYWORD)) NIL) (make-package 'XYZ :use '("USER" "SYSTEM")) (member (find-package 'XYZ) (package-used-by-list (find-package 'USER))) (member (find-package 'XYZ) (package-used-by-list (find-package 'SYSTEM))) (if (fboundp 'delete-package) (progn (delete-package (find-package 'XYZ)) (identity T) ) T) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a0450ce7628ac33d029a961a0eb1627480e253c5 GIT binary patch literal 1525 zcmah}Pi)&{6#ty8f6}CuGsad`Tj!3yvT(PAO>70Bxz3k0t>drQ&f1=)EOnQNwu#aN zfu>DWB?JdcTUt^10}W{$kdQcxA|Z_-df>u=J6G;pIB?*ARNk{2XA43ok=}d1_y5o5 z4jEX|4Oy?RH)?BcQ?9pLjdn|3tvBV(db?S1YDqWyN2zo zZxVqJ|GqbzFPXYiV5Yw-YzZmj6`NyrWHz(jVGkT1R=_n3&nk#7Hv z32mY9%YK825r4DC-;fTNw8JDXfFg^x!&JkBoY|>9I{%C`8A|(OAqAg<9#`9{ZB@I! zCx9Q{9ukG>VV^y_7f*EShMXw~S*x7vRHd3kVgvps z-f2Z=X0Cw4RcAFbXHZL>DF9+#vz6E}*jifAHAkO?fjT7%rmhET8?={ghZbYPzbzc5 z@MJu}6Y){ll&Db4VwTEE&O*si;z@8wDVn*g2Dq(oSecaR+k7HU2tS7Feje6F4k6HB zo>@iBLGf=)s+TO-@l)r-1=Rfxx)Z&gbj_w=CZ0s~cc2z?)Symu8+e83C2FxHRcFN_ z48kbb3uyc;q)p{v8r?HO@N0ew$ya;~$wM$1%FnQpnG0O@Ku&|dqiTlHb+gfOH+1-z zkE8Sc~28uuPNhFV8EF&ge>{hI1qqm8#3QfN3H_7l95dS=! z$9+^YBN~;O4b|KIIJiwh4T-4B3I6ga{z_2lU%n?c-Hr0Pt2WA&cgwe2%LFnhia$h;VO;w(Z>CML>TEST>11-7-rename-package.test ;; ;; ;; Syntax: (rename-package package new-name &optional new-nicknames) ;; ;; Function Description: The old name and all of the old nicknames of package ;; are eliminated and are replaced by new-name and new-nicknames. ;; ;; Argument(s): package ;; new-name: string or symbol ;; new-nicknames: list of strings or symbols ;; ;; Returns: nicknames for the package ;; ;; Constraints/Limitations: none (do-test "rename-package" (let ((test-package-1 (make-package 'old-package-1)) (test-package-2 (make-package 'old-package-2 :nicknames '("OLD-FOO" "OLD-BAR")))) (and (rename-package test-package-1 "NEW-PACKAGE-1") (rename-package test-package-2 "NEW-PACKAGE-2" '("NEW-FOO" "NEW-BAR")) (equal (package-name test-package-1) "NEW-PACKAGE-1") (equal (package-name test-package-2) "NEW-PACKAGE-2") (or (equal (package-nicknames test-package-2) '("NEW-BAR" "NEW-FOO")) (equal (reverse (package-nicknames test-package-2)) '("NEW-BAR" "NEW-FOO")) ) (not (member (find-package 'old-package-1) (list-all-packages))) (not (member (find-package 'old-package-2) (list-all-packages))) (if (fboundp 'delete-package) (progn (delete-package (find-package 'new-package-1)) (delete-package (find-package 'new-package-2)) (identity T) ) T) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f75aa46cc957a3980dc3cddb28263f057db976de GIT binary patch literal 1113 zcmah|&rcIU6rOD<6bfZQf(a_FBwjWyVF^Y=FVkg83)|T`JDY+D2P}(iEG;Rmi7_JK z;Kemsh-6p8)q@A4-0b13cO0S1jNWSVW)!b!;*WLByrAOBk{icG~ zs>Ko*lat`;Q`g6*CMHI^lGrv|Z2vtoJ~gIK>H28b;ohz!R}eyZ^h10)5t30D`P-hX za$<8WnKp?=afYaV!}p@li{{vb`Ci|+Qmd?KCHJ9Q678(6BMBk@l^0Dq)Zl50`a9C5 z)a}3YdeT(OLTh-2piuOPMX*c07t?j^hGwVmw3S19yU{Hu;+v@CbK%RZbWldWzRren z{X>0HGQ?P$G=3daBBJUZU4M}ilyYO)^Hy}8~8%3xap&!Nk zV51-xWfY3|uf2<^VbSTdkU>jfI&BiBCDMS<8CwmtfxdmJfw_^=7~u{BeT=5S?e>Dr zNhT!yo53wLh=n^K5J_Oh^pklACBxAsZsM#S^oBcw&TtP1A6E%u7Sk+;XC1DFW02IX zV!EI;aa#>w0Q23Cp3=*@7_BloLi5h1nXu4QALToCZS%m@(M01E`DmlW zI%;Ox=2t~l5;Q(Ob|DyU7gg;*Aku7Dc+X))+o@>Bd>V|*3)xZ*%YbYX5D5d@2w-i% zm<@V6#EJK?vGsDXTyv{s;lJ~}%iLYBDI*(rL|Iva`@5_Z%dM*?u#Kzt{3F)Xu`vcD zN#SoE1-;P^5B~s4 CDn=~; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST new file mode 100644 index 00000000..87441938 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: shadow ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 185 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 22, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-shadow.test ;; ;; ;; Syntax: (shadow symbols &optional package) ;; ;; Function Description: This function extracts the print name of each symbol and ;; searches the package (defaulting to the current package) for a symbol with that ;; name. If such a symbol is directly present in the package, then nothing is done. ;; Otherwise, a new symbol is created with the print name, and it is inserted in the ;; package as an internal symbol. The symbol is also placed on the shadowing symbols ;; list of the package. ;; ;; ;; Argument(s): symbol(s) package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test "unintern" (and (setq barr1 (make-package "BAZ1")) (member (find-package 'LISP) (package-use-list barr1)) (setq blap1 (make-package "FRUMBLE1" :use NIL)) (use-package blap1 barr1) (set (intern "HURM1" blap1) 52) (shadow 'HURM1 barr1) (not (boundp (intern "HURM1" barr1))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b020270da1878e08dfe7921ac5c994906033e781 GIT binary patch literal 2411 zcmb_e-)|IE6uvVHZMVOe!cr+B9s7go!Zd7y3Kb*M*}L6oXJ^)#St*3XtlMpO!*;jX z-9o@X2rtGs2~@C|E5XG051@$;jo?0*7m)u@zyGn>?l?mxR-RP1+NbYXoo*^uk$&GIe@#NmUT|)CL zA@CI12x;&x{Nez;q1&J5s}vVEFrD>Y62eOUPp3eM>S#0o)hw z^qkzcI=h9CcEBp;_BXx|?rtC;C~E}5Xq|W%A&mn3ij9f;L^z9_(HzQj8lWUbgh0-1iGfE zZA~efl}f=18oHAPEa5MPRD@qx1e>4PZfw3|-Pn8zlzLVbU_-4tr&42<;h@JwKJ7f8 zHp{1-fN9cJX+ZDix%VFK-4b|{2fVq$BA3|iGV7+e4s;6Tg0Mx zLu|hcm|`40Y){+PxQU}zA@$yWWvq|yaFO-pSpR7@Fv$kS*x+$C7-NIO zkVOa-{~$Zi&t8_A6cBfh7MstH(7F8#rMR?pY!a^GdOPcD}EJ#^WTXR>g;O%Eg6 z2mUSph6oJyYc^HkOl>)N2CRs!8V+kiH(1KIGL}nuia+{ZU#*axuADEHXXV<3xpyli zxl)$rv$?a`+5AvVE){EajPir;^}6d!c=&Zf$nNqWx?K&(u!9ha9pW)+zIS*%hEklH zuT<;ubR}Oa57p&dcA=J+^VKR`+z>ZcDbJLOxgcVN#Srlrlp`C$UjO6R5n#277$DW2 z3?&6nWO*sncVamS7lZ@1ocKu08-*lZGazX@LCi#uC#=z3o8>8CTPc*75DWWWPcB=} z6>tHzYDh?c!*tzi)(p$Z*c8~~<82#s)p21LtbY?fDB=rjKw<~rCdd2;BuGBnl;BHf z`f!t}|D5j)kB(80A^MajyFJhB4U39qAh{kq~X6vTv_ESfH8a~?b^wVIXUu4 HdS&GwtCML>TEST>11-7-shadowing-import.test ;; ;; ;; Syntax: (shadowing-import symbols &optional package) ;; ;; Function Description: This is like import, but it does not signal an error even ;; if the importation of a symbol would shadow some symbol already accessible in ;; the package. In additionto being imported, the symbol is placed on the ;; shadowing-symbols list of package. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group (package-shadowing-symbols-group :before (progn (make-package 'inherited :use nil) (make-package 'direct :use 'inherited) (export (intern "CAR" 'inherited) 'inherited) ) :after (progn (delete-package 'direct) (delete-package 'inherited) ) ) (do-test "import causes error on conflict" (expect-errors import-conflict (import '(lisp:car) 'direct) ) ) (do-test "shadowing-import doesn't cause error on conflict" (shadowing-import '(lisp::car) 'direct) ) (do-test "shadowing symbol on package's list" (member 'lisp::car (package-shadowing-symbols 'direct)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b249238aeedb12cf9d23bfbd3cbe83424833c7fd GIT binary patch literal 1569 zcmah}O>7%g5PoYXu@fh$^XIfp(k_V#(w2>I8k95@h|Tu7*~ESucGpQ`*isrB z$3`I3Dyjr0qvBSS9jXe68$DIIm7*4@2M%1gAaUWufeVKsap4qZ)^?M|kt)lYH{bVW z-Z!)JUX``3=t)`6Un%4^-J+Z?mkQ;Qypb=;+xc>F&6PJ0mp|1_i(j47^o8*Y@eca{ zvsQFhOYXYtl-=$1)lXiP3-yHQaM+)nZ%g)WhIY*ka%RI3HM!p6roYKkx2ylWqJSVtnuQP`8wQ@JLX`>cSV|31ijl=VCq}b>Zs%;Bqe|pnsULPR1VR z*82UX)rCs$HH3z0avq@(7`wYnLA2UeJlo)=nz_*igrfT!>t~@2%{$o_tG=1NA3I8R zH5<)ESs>(nRT)-vQ(QFYgQ;_xxR~UYI%^;zF4;<;71{$WI1N3Dt~vUgYH=rR;n&pt zacHwMw!>2asdfjI?551FGN*cDG zDvFsS39MSRGpSiKNqbrl3pWN60roEpkogBMT|h%P+!8*{{v&{|>;r#dXSxMnu2-tAWG+9u*>opK%pWj9=4W_` z%ug86f}L6fncUA{=qe0<2*dBg2!~T~WV`nBfqWK524Solw@Ua-94l|R9~bh)l3H@N zOX>u{!mFHi(33~6X`}MSDn5Yga&D{kb`f^%3~h^ehlSGddpHg?U4I|R|9T{P&%5K@ z3ZT?ey2UkztA}PIX<&!6qzw_;hJAiJZ8{u==)^lsRm2JY8qO?v2TNZdWn<@`!%jcv TNxlkD@C-N$L+qQWy}kbdGjqNG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST new file mode 100644 index 00000000..65653fb4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unexport ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 186 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 21, 1986 ;; ;; Last Update: Dec 22, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-unexport.test ;; ;; ;; Syntax: (unexport symbols &optional package) ;; ;; Function Description: The function unexport is provided mainly as a way to undo ;; erroneous calls to export. It works only on symbols directly present in the current ;; package, switching them back to internal status. If unexport is given a symbol ;; already accessible as an internal symbol in the current package, it does nothing. ;; If it is given a symbol not accessible in the package at all, it signals an error. ;; It is also an error to unexport a symbol from the keyword package. ;; ;; ;; Argument(s): symbols (list or a single symbol) ;; package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test "unexport-test-1" (and (import 'new-symbol) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL")))) (export 'new-symbol) (equal :EXTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL")))) (eq (unexport '(NEW-SYMBOL)) T) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL")))) ) ) (do-test "unexport-test-2" (let ((*test-package* (find-package 'lisp))) (and (import 'new-symbol-xyz *test-package*) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL-XYZ" *test-package*)))) (export 'new-symbol-xyz *test-package*) (equal :EXTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL-XYZ" *test-package*)))) (eq (unexport '(NEW-SYMBOL-XYZ) *test-package*) T) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL-XYZ" *test-package*)))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8f9c0e121a36410600f9819476e0127d9e530bf2 GIT binary patch literal 2311 zcmb_dOKcle6n!(!$MG*tnx@E9kSnWe#gbJODvkPDqb@90szR;Os4iNqa%9^gcJ}b$o@n>T` zqs_BeweodqNiZ8$Z7IJ#CdAGO(pt4xg2vgi(2d2Po`_FQj{6dlk!EZUoHG$WgVV-+ zyEm?J;R+#Sk!+*sAtX#Z#CgvSM@_{r#Y8f#h^mxPqE6GXy^xETGZfvi`zC~XWlbzu zFIy!{XSGH+LY#MPZz8A4W>Qm~tK23RaIVp&f)~@isL2x4MsU zgSaO*!(7P@gx%C?Ye3YYT#(Y(sX(U-1CUJYmM{W2r|XK^cK9iWzDpSSK|y56P?#+Bqx&gv zho+UZVk)iUj(0}iyrOIKqO4^yP{nl8$RfC(4xs6!$H8#BbP&z25Q{$n^%aeU%#?=l zabLSY?kfho&VVlg(A&B+5S3x5IfjZe)G_)f`g}A3hWzb9$X_mm{N_T)m$1m)mogV1 zEKHw#&afW>f5=E?vT*qsrVh*f9D3iUkpdmC=f>{OJ0~O=do2zUz3kvwYp4 zNt2Gw(P4>>Owf_jbo4Rsd*Eq^(9uUgjxWGH-zXQ$b*oy&{*q&haVY_}JbNwNC$MhS z>cYr|G$Its?CIJtgylTEh)d%*DdK$WT*U)3BMVv3vJqS<&5O$sg`y@=4p|ciP%-?X_!n6XxmZ=OMrNlma({a>NB2-Q()G Ln~Qvu+THyRn68XN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.TEST b/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.TEST new file mode 100644 index 00000000..b8c2c190 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unintern ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 185 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: Oct 22, 1986 ;; ;; Last Update: Mar 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-unintern.test ;; ;; ;; Syntax: (unintern string &optional package) ;; ;; Function Description: If the specified symbol is present in the specified package, ;; it is removed from that package and also from the package's shadowing-symbols list ;; if it is present there. Moreover, if the package is the home package for the symbol, ;; the symbol is made to have no home package. Note that in some circumstances the ;; symbol may continue to be accessible in the specified package by inheritance. ;; ;; ;; Argument(s): package ;; ;; Returns: unintern returns t if it actually removed a symbol, and nil otherwise. ;; ;; Constraints/Limitations: none (do-test-group ("unintern" :before (progn (make-package 'hurm :use nil) (intern "HURM" 'hurm) ) :after (delete-package 'hurm) ) (do-test "symbol interned" (and (string= "HURM" (find-symbol "HURM" 'hurm)) (eq :internal (second (multiple-value-list (find-symbol "HURM" 'hurm))) ) ) ) (do-test "uninterning symbol" (unintern (find-symbol "HURM" 'hurm) 'hurm) ) (do-test "unintern returns NIL for symbol not in package" (null (unintern 'lisp:car 'hurm)) ) (do-test "symbol uninterned" (null (find-symbol "HURM" 'hurm)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f796c55c05a73f9a62b535d78732efeeaf960fed GIT binary patch literal 1058 zcmah|+fUPA6#u#l8@oV3qIiKdBqpZuL$^Q#G|^Hz*y!5XOD4XUWfZzN*s_a>Q3)Z& zr+OJg>?biMKKWz}Z-|ix{~`VZJl}>m@xioBPk-n1ch32p^EHwGo+xu-d8JY;Syisw zs8~!>TRjA7AC-lbleg z7E54EOu%P+YCJJDHZ~ec3cB28`|m%Asq1i0j)smtY%^>bAyhyI^wo_Ji@eC)bXeYy zbOR?-vV;{OBk^w2b%M|fHg!pJoxTKDFIRBMdSsPoJ1aHBAmqMrf=N>mjg+dmTg*BW zabG*pl!CL+nlLLNPw<$9vNNvJACKc3*i?Y@B<90*U;}FTLJRt4@28o)RrL9L+LL21 z^f7*lE+b@zq3E97bgl<#-n75o0SxXaLdC<~1XuvKd_%hv$=knpFTl^A_yH63jq^=Lu-d#!rnb;6sS`=$yh- z@J~S0l~lEiV9?Kxv=-6SG)d{$1Hw?>EAS2cX;lUrln zF#~LFWK9_1mhx~+7rEkU`-D+!?eaOd&Cj?y?v@9#4U3v27!p3EjGQtgO^|gGreRR` PT~jqAGKAjqM@PQ^>)AJ$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST new file mode 100644 index 00000000..73cec8a4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unuse-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 15, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-unuse-package.test ;; ;; ;; Syntax: (unuse-package packages-to-unuse &optional package) ;; ;; Function Description: This function removes the packages-to-unuse from the ;; use-list of the specified package, which defaults to the current package. ;; The pacakges-to-unuse can be a package or package name, or a list of such. ;; ;; Argument(s): packages-to-unuse: list of packages or package names. ;; package (&optional) ;; ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test "unuse-package-test" (and (setq foo2 (make-package "BAR2" :use nil)) (eq (package-use-list foo2) nil) (eq (use-package 'lisp 'bar2) T) (member (find-package 'lisp) (package-use-list foo2)) (eq (unuse-package 'lisp 'bar2) T) (not (member (find-package 'lisp) (package-use-list foo2))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3af07b5ce6ca7392a1cb389128187aa07a924e29 GIT binary patch literal 972 zcmah|?@!Y}7{0C>8*Ge%M2+&Jl9*_<=oW}DP0UelQ0Q7{Z$UozVHt%j4!Z1z(Wr!A zVq#K*gGgEp|AXP1V&sGW5dQ(bR}cw)Fl}>hpL_4Q_kEtb7K%JkG*NL@tL2Ja6P;$G z+H8o+PED*k&05hGmjM@FDTYbjOk-ts_+hHUIyY0S*@cF^B+{l`Un;!3E2hRpT&pb zIjd?!)^UzVUdwZ1(2Jb6i0QfAX|dr{<%<2>uCR7i>xe_h`{>59d0nBZp?f>r2AA-* z+)h=O=b$w_MNlYq%EH(=&lOTB`2nLm%h=nEZbBtnteo$qgBkAI8hZa@CbS@2>*gX1 zT|uZ6hmw=~cNUUR@pkF!4Zz^-M5uhUe+eRhgSq}zd85Rh0|0wAqe-sx?WYd$QET>t z{tKa2>770k;$S7vTwds58?Y~iPy(UDaifnBUH~ zgMvwkn5JRMMxM^)sl<0edP2hbq8#9s8vbm-tT|JgaFz(zbg$PKY>lZ>z+Sw9kO^J4Znsn)2!QawNQLk zSh3}XU2nYb+(8PXIJAz3#N`6qs3ozyc5)dQwtn-97jSXj7jGv7!~=>+FeUPZMm3cZ X6Kj?qXK7I4eBPkM??az&A0Ph)0_-4v literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST new file mode 100644 index 00000000..473ced46 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: use-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 15, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-use-package.test ;; ;; ;; Syntax: (use-package packages-to-use &optional package) ;; ;; Function Description: The packages-to-use argument should be a list of packages ;; or package names, or possibly a single package or package name. These packages ;; are added to the use-list of package if they are not there already. All external ;; symbols in the packages to use become accessible in package as internal symbols. ;; ;; Argument(s): packages-to-use: list of packages or package names. ;; package (&optional) ;; ;; ;; Returns: t ;; ;; Constraints/Limitations: none (do-test "use-package-test" (and (setq foo1 (make-package "BAR" :use nil)) (eq (package-use-list foo1) nil) (eq (use-package 'lisp 'bar) T) (not (eq (member (find-package 'lisp) (package-use-list foo1)) NIL)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL b/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c4b403ed16548dfc5cb3703f6ac0ccdb7d38b99 GIT binary patch literal 1342 zcmbtU-HRJl6u&dcW;bcFPD($6yS-McFm@IbD{NN;XJ>DA<4)$r`PjN3XxPkd0@G$Y%5YleY54U`}4SM>X!EN^bnr^HwyjsjSkKJsAe!b^6 zsN46ujrz5Vw0N27ov_u0!{Q>q;?gUnrAwCKGAuQDRfOjwXzilc0?s4Z$Wn{QNB7&*L^yGe+Y z%PTTw^F#Cgx^#DsT>EidzH+LNmr{9UdS{g7a4h(2j*#Q`0UWY^p!Kni{A_(Swe=bt-`4ANhm4(FjP9PB8i)! z;GmO0lw=#a34r_wAcYC&F2X-B1H-dzW<9osLc+V>F!M)EFm#8F!-_0k-$SMCML>TEST>11-8-provide.test ;; ;; ;; Syntax: (provide module-name) ;; ;; Function Description: This function is called to indicate that the specified ;; module is being loaded. Its name, which can be a string or symbol, is added ;; to the list of modules maintained in the special variable *modules* ;; ;; ;; Argument(s): module-name ;; ;; Returns: T ;; ;; Constraints/Limitations: Checks that members of *modules* are strings and that the ;; insertion of elements is case sensitive. (do-test-group (do-test "*modules*-exist?" (boundp '*modules*) ) (do-test "elements of *modules* are strings" (let ((*modules* nil)) (provide 'foo) (every #'stringp *modules*) ) ) (do-test "provide-test" (let ((*modules* nil)) (provide 'foo) (provide "Bar") (and (member "FOO" *modules* :test #'string=) (member "Bar" *modules* :test #'string=) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e6ebcf6cb260e3a60559d318cf57dbdd3cfda4af GIT binary patch literal 2135 zcma)6&u<$=6rNqjZelym+L+=vrdd@=g;uOpM@1?@2(330XUTfU?2r67MUmrROKBZB z4iZ9*s&b$QOHBxromRbZMas3%%2JV#xNz!!z?B0xj^T|rS+9))99FaMeeZqWym@ct z7=_nWT~wQQ_8Pmjme@RK?;W(oon}kiZyvO&HE{?0;uk70@x5h5UCDn?h*|-p+Ny1} zYuloIP}|?$`utt7@V=<*wHmwdbNe=!g@yO#7jE6kN0$^!_t^e3XMW)(LoKpnVbkp-=f!q&Pu{J4R@-Ie z+}TGQLhey#e919XTO)>h!rkZM?xW76X2=yNO(|i-kDs$JcFyh07Ut!`O<5~fbX>-U zt*}gpHbK(HriGq8o_v51mrDvf+u%?27c1QJyXc3PEBsnEo8%(B-DkRMnaxDEzA3<$ zf-l`AiK8!xaQY5Oa8MO<2rfyH^bNotl5{=0nSyAN;34nybv4&*y!aHM)PpN;a`orn zBMC77Jk}qP#LoyF*S{i(6`q@f-_y+6HKq#qI6`rRx{a#XJ#7Z|$K@{e7lSC!U&}z| z)ARov{NJztZ@H_ZliyC;0k|psGI>Cpb ztw~8$Y;{>SvF(^}&}y%*5o^P;ahc~KBJDL^)v;nY6?uu6WlN$Q&;2voCK8Q>;s8uv z+CYD7Si?h6IuS}hyx@0OUR87lTT}>5!Kfr8Y?{QBiDOqBTM7vf8;4>#oiLw^C5?jNG6SlE-L zF$Vtzha8>5tJvI-EjU#jGw-j!KV@x{i$s?%CZG9V(HXY9q&c=cp&7P(N2l5HkY+!m zZ!uCX3F+aANlFH@La+nz(xa5|x@OrQQGs#%!4i9i!mQun;zbNrB`X@erXpK@ftV|X zQ!Zk&!t5WxjueSwEcVQAKy9jI66i8iZP|)pLm%$Z*)|nxR1C9}Gq|F5ZNDvEKUA)Z zJ6rHrZHtY&-aEs5hjT3Kd-th(!lvh%YGTF4jPQIGd&j72aG4d|qA?Z*JO9KXHm0*I z_sH$!7m65qguREP_d2$H(F?Uh>s&vdbx*QDk}eZ?p(@0JpuBtaKu2U;u{6kJqu^asPdw-k wZaCmi^#udoT#($?@2k8$pfW08KyF09Oh9)S9_!sLItMq0-k`JSiFS7OHx2oD+yDRo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST new file mode 100644 index 00000000..a9161124 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: implementation-parameters ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 17, 86 ;; ;; Last Update: Aug 21, 86 ;; ;; Filed as: {eris}cml>test>12-6-implementation-parameters.test ;; ;; Syntax: ;; ;; Function Description: This file tests to determine if the following constants ;; are defined. They may be useful for parameterizing code in some situations. ;; Constants defined: ;; most-positive-fixnum, most-negative-fixnum, most-positive-short-float, ;; least-positive-short-float, least-negative-short-float, ;; most-negative-short-float, most-positive-single-float, ;; least-positive-single-float, least-negative-single-float, ;; most-negative-single-float, most-positive-double-float, ;; least-positive-double-float, least-negative-double-float, ;; most-negative-double-float, most-positive-long-float, ;; least-positive-long-float, least-negative-long-float, ;; most-negative-long-float, short-float-epsilon, ;; single-float-epsilon, double-float-epsilon, long-float-epsilon, ;; short-float-negative-epsilon, single-float-negative-epsilon, ;; double-float-negative-epsilon, and long-float-negative-epsilon ;; ;; ;; Argument(s): ;; ;; Returns: constant value ;; ;; Constraints/limitations: None (do-test-group group-constants :before (progn (setf implementation-parameters '(most-positive-fixnum most-negative-fixnum most-positive-short-float least-positive-short-float least-negative-short-float most-negative-short-float most-positive-single-float least-positive-single-float least-negative-single-float most-negative-single-float most-positive-double-float least-positive-double-float least-negative-double-float most-negative-double-float most-positive-long-float least-positive-long-float least-negative-long-float most-negative-long-float short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon)) (setf parameter-values (mapcar #'eval implementation-parameters))) (do-test implementation-parameters-exist? (and (every #'boundp implementation-parameters) (every #'numberp parameter-values)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-2-EVENP.DFASL b/internal/test/LANGUAGE/AUTO/12-2-EVENP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6c263796692b52754406f1489473bb469a6ec041 GIT binary patch literal 769 zcmaiy&rcIU6vy9gf6$he6rzb3qZ1M?8>g`ijaV;^+bM0?&cf_0$dQz-ZBp2#KTM2~ z7!RJ-Xd#ka4gZ5z#K^&a$o~Lmi%|jxPc!p7gIZEYuXK~s*Hxmg<{sx$)}=_Z?`#j99VAB1U}yW~eUyKMNUz`N%FXh! zJmyQqLTPC!m#PrUxN!ULn?mV9p;Rp9Qs>7XSSj4yXXE8uLGScQoB(CML>TEST>12-2-EVENP.TEST ;; ;; ;; Syntax: (EVENP NUMBER &OPTIONAL MODULUS) ;; ;; Function Description: ;; This predicate is true if the argument INTEGER is even (divisible ;; by two), and otherwise is false. It is an error if the argument is not ;; an integer. ;; ;; Argument(s): NUMBER - a number ;; MODULUS - an integer ;; ;; Returns: T or NIL ;; (do-test evenp-test (and (evenp 2) (evenp -4) (not (evenp 3)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST b/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST new file mode 100644 index 0000000000000000000000000000000000000000..968e3cb9cc26b16506dc5d8d907d0d3997bbae43 GIT binary patch literal 674 zcmZvW-EPxB5QVq=Rko;r8_MOm!3R8i#Tyjrn96hS5qL8LAD??B$9u2qGTcW}d_r1Z{D2+Ek@7zW*V9fVvM+(ml4c z;Q?%*;PXs874O7BKADZOi^VLRiCQ34M>&7E`So_o%{GlJ+d-9&n4x7%vFJ=7Tvy2Al# zbb6@Y8TM)}YDgTt(k)J3uM>S^=}~UlzL2T)-0HxsBQbRQ_3F#JDEAPNZm-pr!Ro5K z<_h=og_V`1=@PNc3EO{b@`dGlg=JZDete{4Isj0Ev+zg)WFP|mftS$)wFNF2CdG_Y zsOFD+FCo2P$EMu(vUxPKA3sRAIkc=dx(OHdh zZgFfmV$%^?BqCML>TEST>12-2-MINUSP.TEST ;; ;; ;; Syntax: (MINUSP NUMBER) ;; ;; Function Description: ;; This predicate is true if NUMBER is strictly less than zero, ;; and is false otherwise. ;; Regardless of whether an implementation provides distinct representations ;; for positive and negative floating-point zeros, ;; (MINUSP -0.0) is always false. ;; (The function function FLOAT-SIGN may be used to distinguish a negative zero.) ;; It is an error if the argument NUMBER is not a non-complex number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: T or NIL ;; (do-test minusp-test (and (minusp -1) (minusp -4.0) (minusp -79) (not (minusp -0.0)) (not (minusp 1000)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST new file mode 100644 index 0000000000000000000000000000000000000000..0fbea9abf65d199b073b55250136a5e08781c043 GIT binary patch literal 716 zcmZvY;ZEBy6omuZn34@`5)$z9{9BP))J$kV`U^TLby@+@zJO_ONknQ}jx%TUy;_cKp=1VK)|E~=9Sl`%#+1bvTB7ntg;S+& zo9O03TQW$0HZde0f|FX@5Yppcoa`DBmL|BKXZWLXiA!N_flzT{@Y@+O48$C16GuLE zX=qZ6Js;(SSt08RIzSW^tf>jb6tbROyAwE4Qsr}^{UYxTl!MhuC!|1kaQz#@s9#dzzx@iJb$Gl4QrVYO+u7dYwB2@iS%~4< zM*Mw@)}!5MbJQQ44X-W+C+E>u&mDfB`|1b&J4dw5V$H2h7EC^~U~<5Mi7zqv9!SE1 n$+tlKVVGP6^6c>=xX&jpz3RLX$PNqkd~y`h+e4kI;S+HYM9{4jwH0X43+kN4-Bb=Q+C;-7nKUHygM##871zWJO`M4o6IV$ z;~z}!e~nh(v!4K?);m^Hl_`Mz*4OKsV-guo0b~JAz548^mGg3-#)D7(Elsyr*@!B` zD}V!m|(R3p870jt{xGY&8GbijVThKLCxq3rbT9}C?!*nbqF{d@k zxy7;Nh;>J3v9x@U)d<_dW8Kz5$(t)&YFjb}5KctBiq)h^qGItiBC1g`-Qk?F3o{6n z2U5TGk3%OmJ$DZ?6J;4oN1en`Z~u;KJVxmpA6Ky;CzN1O4s$M?Qy&NZ9pUx|Xnv2( zqvp2!iw)%Mo`0iA+gnhAFTsH-y>IKB5<&5$^rj&wC#D@{qH8kGhGPjD-hj{O?Cdw0 CLFEqs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST b/internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST new file mode 100644 index 00000000..5248b9d0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ODDP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-ODDP.TEST ;; ;; ;; Syntax: (ODDP NUMBER &OPTIONAL MODULUS) ;; ;; Function Description: ;; This predicate is true if the argument INTEGER is odd (not divisible ;; by two), and otherwise is false. It is an error if the argument is not ;; an integer. ;; ;; Argument(s): NUMBER - a number ;; MODULUS - an integer ;; ;; Returns: T or NIL ;; (do-test oddp-test (and (oddp 3) (oddp -7) (not (oddp 0)) (not (oddp 4)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-2-ODDP.TST b/internal/test/LANGUAGE/AUTO/12-2-ODDP.TST new file mode 100644 index 0000000000000000000000000000000000000000..06fc9b89b7aa05e65ae2809372b8edb8ae015f26 GIT binary patch literal 675 zcmZvYT~ER=6o!YNVUegY8n4WICrf~c5I@G1q8N;P#PJ6zE3km;(sfb%WyW7;PoZ3h zO}e~$&U@aTw&7#IQ-xME;}{8vRu&IcBw`;T3=_A}Kp-+XK?mT+Ub`jUsy z(D1>8n=z1BhA4%S8Amii6e~W~6KJGo1&c!nHR19jO7&gXEaeq5|2$Ug6D=X%neu@m zUCcIno9rYjV(%p}^&l)(e&XX&T9G{S$CBU^gQTrht`&};hZ{!LA&!9y!JYGU1!g5jsNGSx=CN{a85|% z^fqZkb}gxsAX2d8z!KMzeM?L`TO@cg!mh4z^X2~iiS(4nhbM*D|3*RD& Awg3PC literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.DFASL b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fd3987042bf097da47e3e77ea39a385239894977 GIT binary patch literal 769 zcmaiy%We}f6o$`CF3q({E08EcU{&g7gd-A)C}D${I=4y>N~J4MRdUn@dm|{AgIcMmF@r7|2f||oDieJp`!JWVE<~CGr!jI`NQ|9ftMTGC$~{1&Kj?JjW^GL# zbA@~P!s==^Q6!czbNla`eBsXBLOz#GoF5-4nH~T%;Vf9<02v5@ci?6;K`nuc6@y|% zYE<(ko*R=a*tRJ5+=VH$Ja@VQ&h8Kt0PlkvE80vK6_a^~%4;R%y?4_UhU*fI zlqjgN-!6f>;<@Qu9_Ml0u&p{AA4Q)8MSN|aR+W=I*!)&ix8|=eD3Q+TGl0c6b19{L z@}0^3&&kF+_5)zje#@$=k_I?vf4RCfMUmkcKnmcj(_EaiGo1{m5$~gWL(@&RUI|LW zWy01C%JJihR9MN<)Uae;&~zg7GUim+T-K~lp`+HeC1_1m{=Feg%}<8r{CFrPIp;OX zxyi9`|g{smdS~Pi$h*FSDw>hWm!VrAr zzSOV$<4Y5ufZpDe*O!z C0Ojxi literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST new file mode 100644 index 00000000..53916c0b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PLUSP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-PLUSP.TEST ;; ;; ;; Syntax: (PLUSP NUMBER) ;; ;; Function Description: ;; This predicate is true if NUMBER is strictly greater than zero, ;; and is false otherwise. ;; It is an error if the argument NUMBER is not a non-complex number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: T or NIL ;; (do-test plusp-test (and (plusp 1) (plusp 4.0) (plusp +79) (not (plusp 0)) (not (plusp -9)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST new file mode 100644 index 0000000000000000000000000000000000000000..3a8decc7fa0f16a84a8b31f18af08a773e696b2b GIT binary patch literal 702 zcmZvY-A>~$5QPKFj}n1ELc7|_b4M#$L=gg-Ua>%>A_|D+1>AN@B2qhY9H2bfzQ(@L zdaSqtfhAkV-^`gAyB8y&(x9K^gqhOlS8`%9C1VtMRTfdNhmorEgyIk*LzM5A_@mTw z3zw-V3~6+ZTNsfu!OB8B5jx#dc3x@{hNc)VV%(@y;z8(Vz(;HwT-k&eL$N@og>&b6 z&@{~^jwdO(IZ$|ptc1}OA)7%~^RXSkk|)d6CoGN8^2EoHK#Vxf|R@ zQDdswhQHS}aWV?Su))LCjXO;yVSPI}JonuK1-tc6Zv+OmlT`T{Bz4yQW0c=E?%K!iX literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.DFASL b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..96004e1efa336bb4abf8aaebb374febdecf8c934 GIT binary patch literal 769 zcmaiy&rcIU6vy9gX=!Oo3eiN2(FqBcjnmkQvDS;@cKVBDw#?3ocq3)8O$u%L!^9Yg z@!)BV79!cz@IQD(j2!%j{158vVuawq)69I|%=f*|dozaUQ{6y%cc<6xIDOO|4SS;@ z+V1wzpgZa}9keZV^h!55eO)E`O7>xH#<~z`_MOe4vxUUS8EkF7yp3`X5b5>X9l0qK zg zX}C&Q$)FrRu1SSeEKQw~%yXJfgkHs*3Y*KC^$;7NgsJ(-$h4n`#3kpf zMmaY*Hf_CML>TEST>12-2-ZEROP.TEST ;; ;; ;; Syntax: (ZEROP NUMBER) ;; ;; Function Description: ;; This predicate is true if NUMBER is zero (either the integer zero, ;; a floating-point zero, or a complex zero), and is false otherwise. ;; Regardless of whether an implementation provides distinct representations ;; for positive and negative floating-point zeros, ;; (ZEROP -0.0) is always true. ;; It is an error if the argument NUMBER is not a number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: T or NIL ;; (do-test zerop-test (and (zerop 0) (zerop 0.0) (zerop -0.0) (zerop -0) (not (zerop 1)) (not (zerop -2.8)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT new file mode 100644 index 0000000000000000000000000000000000000000..d2c3623442299e7b7fd527fbb7a6d63dbc2cab95 GIT binary patch literal 722 zcmZvY+e*Vg6h-5mL`A_1KJGUgXr&buO`p6KDptkz2gdfa4W=_;GC}L7`9uDObB2rv zIxu0Mwa+cnPB5Utpp#~VvC`<2a%fT|6MT?XdDL#BuSz|nBt+j3Wrqc>lzOe>dMa{5 z8m;3x`s9jWWiBR!*2O7TUTYGDMtGSgxKmS!C!t>f@7OW8u?Y!!VvbfF=Vx5?q-m56 z9Un{yxet*RFuEk9W5{y$VrN^zYeL8o>#@iRf-+OmZ)rhp`MEUW9UY}-!X!Y={Z>^U zb4FL@rFE)~wNx6K*w&m^hrl>f!lZK2$d$D!Y#&NssAhRa?+&?6kEL;~2C)7^_dbeh zBh@hczHX|MQ5c4(@xs+A%^1u=A09R1-*Kb)2UNaP#`kE&e_7-B=sdQEdk1`$gT>$= z*c^0wxBchG-sMBE;kd>BbLTGc*JcF!EEeqDWWi*O1(OpNOq|7J+mna|lPyo&GE8nf e`N`SyWQ7Ii+YqXZs&+S%XC{APYLGlb|f!$d}VuhVR~UDO`*JA*!| zx4Wp<9(1cNs!JTbGAvGC=ZUek`Y1JHU+`4B?rz_$Au(`!wcVF@QR*Qgoo=%wjg1ZY zO=a$o7wUEao36Z^Z>V+jvrGoc>_a z{x#fs&wc_78}C?ARptN=8(*()kA+Bg0w4)+-mEST8(LEXHR^xzZs~@_HVa{6I8WH7 zNjZK}kO<4!x;iBlFX#plMjmr294`;4yCNft0JIE=?^S0SKnTQALW9B$l;!iHKZS%y2lT?7|8H<$=Vn z{nKF(n@-q+*{MzGo1+znm^hs6-*t`GD5<04Hdf?@Vk|6TE(J^KW8b?Y++H6oACP5K z-<7vmL(Tok8HL!visFCqk5oy1+u)Q4iZ9hS3xaZD+QDoXChJrjOVHp3d`6?uZ?>G} ACIA2c literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-3-EQP.TEST b/internal/test/LANGUAGE/AUTO/12-3-EQP.TEST new file mode 100644 index 00000000..83835fd7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-3-EQP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: = ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-EQP.TEST ;; ;; ;; Syntax: (= NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test equal-test (and (= 3 3) (= 3 3.0) (= 7 7 7 7) (not (= 1 2)) (not (= 1 3 4 5 4)) (not (= -3 4 -9 0 100)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL b/internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..af8b81891f8f19edd8108fe7de138a0728994ab4 GIT binary patch literal 765 zcmaiyT~8B16o$`kKcR(ei6&xaD8UP__UwCR-gBOFW(={XhKY>sZm->O`=~n__C`b0 z?Do;1JL)%F)Ra1UX;_@Tst{u>`!F|cU&=K4?)K2#L1N?%cD7&KMY#uv^!n|N3|3d= zZ?3SCFDx%-r%S{(FWmlnCttX?R9IfgPM;qiDOwi*8gLeVrT{dEfPdg=x}dherK(9W zBXz3#W8X_k7VOxR`(7rGhTR_SxX;~Ah_gEY1;GE{B})!7MAc&cq4HWu`|rJ(D#Pm% zjg%><$=@!ayCUOU9xvfC-GJkx_>-`OudUOXaRNlMCDopNq* zY&l}x5qe}wUP$YNZQ+S->w(18a#yC7hyVo9a8!|+G>MliUMHd)7Bd{qDZ8|SK)EmV zYkxTmV$%!vAQdgjTv84ahm-xYtjQ9kact7WqTElMg(b}SU|xOXdv}C87@~!JvVfY~ z@+Iz|_TI%K3bp-3#sBOds?z$l!6^|GU#V_Z1?9xFgH(7-*4c0@L4zCc37wz+0_I%g Ae*gdg literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST b/internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST new file mode 100644 index 00000000..a51c6d65 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: >= ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-GEQ.TEST ;; ;; ;; Syntax: (>= NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test geq-test (and (>= 3) (>= 3 2) (>= 3 2 1) (>= 3 2 1 0) (>= 3 3 3 3) (>= 3 3 2 2) (>= 3 3) (NOT (>= 3 4)) (NOT (>= 3 4 5)) (NOT (>= 3 3 3 4)) (NOT (>= 3 2 1 2)) (>= 3.0) (>= 3.0 2.0) (>= 3.0 2.0 1.0) (>= 3.0 2.0 1.0 0.0) (>= 3.0 3.0 3.0 3.0) (>= 3.0 3.0 2.0 2.0) (>= 3.0 3.0) (NOT (>= 3.0 4.0)) (NOT (>= 3.0 4.0 5.0)) (NOT (>= 3.0 3.0 3.0 4.0)) (NOT (>= 3.0 2.0 1.0 2.0)) (>= 4 4) (>= 6 5 3 0 ) (>= 100 7 7.0 3 0 -8.0 -8 -9) (not (>= 1 2 3)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d315d2f4a8f2588a5b5d0625aae9109c2dc6c582 GIT binary patch literal 775 zcmah{T~8B16urBprL=_wy2<0&?Z0m_xqB~u5qc4GDr_!g>to*$Yu6HVQ&s-GAxzDWho=3RP*hr- z( ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-GTHAN.TEST ;; ;; ;; Syntax: (> NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test greaterp-test (and (> 3) (> 3 2) (> 3 2 1) (> 3 2 1 0) (NOT (> 3 3)) (NOT (> 3 2 2)) (NOT (> 3 2 1 1)) (> 3.0) (> 3.0 2.0) (> 3.0 2.0 1.0) (> 3.0 2.0 1.0 0.0) (NOT (> 3.0 3.0)) (NOT (> 3.0 2.0 2.0)) (NOT (> 3.0 2.0 1.0 1.0)) (> 299 10 3 0) (> 4 3 2 0 -1 -10) (> 19828 1872 107 100 4 1 -1 -1000) (not (> -7 -6 -5 -4 0 1 2 3 4)) (not (> 4 3 3 2 0)) (not (> 4 3 1 2 0 -1)) (not (> 1 0 0.8)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL b/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..04fddfc1dbb4d33c26f84ab79f61f446fc6f0cbd GIT binary patch literal 765 zcmaiyO>fgc5QfLjN7E#&(h4Ms5UeWoVzE^dQc=Q%#o2t-T{r7BrN=69NTjrh@_~d9 z72?3j2-1qm2K7I1Ek*ReAL1W`b%LNO2TmTpv-{3GGdqIFQ{6y%XTRHOJ3Z7H4!Xku zYIJ(2-x>C54r)jpz0^%kUzLcyx%x02w=QLBJ!fy=)R7oE{rcXEyD0qtk#4Wmmchn` z{7vW9Gr4SbHC`Z=F?IXzolI^mn_F97jgL=HlvD=*YH$&JW&u(V0`JI8X@Xh;7s>|3 zjBHWO8+mR_vS8by+;bN)Xwd26w)5O+2RQqEPyoCSZmeK4U6f7c9V@Sur1##PD>J+; z(MXYk8vE@MxGOSFXYf62&?=msM4tpLd~Kdrl(PeEsmP0RtnUJ_tCwj=_bpUgT`=) zu)IMzeq5FcD_WWwmc$F1PJ~{Kth|ua2;0RI-O_xCn@V4q+Dr(*4+o@ia{~m=A5!iEAW;3 zQor_>LnjuUy8DT6UglzQkT{s^pJh#!D2*eNCRXHrqAVz3Ecr|7BhS4foc;hUAChI% z*pn}@j#>xPM-*s>D~k8oJ65IjZJkphD85qNC=1GoVfl&Rn5CML>TEST>12-3-LEQ.TEST ;; ;; ;; Syntax: (<= NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test leq-test (and (<= 3) (<= 3 4) (<= 3 4 5) (<= 3 4 5 6) (<= 3 3 3 3) (<= 3 3 4 4) (NOT (<= 3 2)) (NOT (<= 3 4 3)) (NOT (<= 3 3 2)) (NOT (<= 3 4 5 4)) (NOT (<= 3 3 3 2)) (<= 3.0) (<= 3.0 4.0) (<= 3.0 4.0 5.0) (<= 3.0 4.0 5.0 6.0) (<= 3.0 3.0 3.0 3.0) (<= 3.0 3.0 4.0 4.0) (NOT (<= 3.0 2)) (NOT (<= 3.0 4.0 3.0)) (NOT (<= 3.0 3.0 2)) (NOT (<= 3.0 4.0 5.0 4.0)) (NOT (<= 3.0 3.0 3.0 2)) (<= 4 4) (<= 0 3 5 6) (<= -9 -8 -8.0 0 3 7.0 7 100) (not (<= 3 -5 -7)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7d2727543bb65fe9a81bb53ec38d663bd6fb50ee GIT binary patch literal 769 zcmaiyO>fgc5QfLjXPcx-Dv&5bu&UIH#a1K~QNo4A*?iSmr|UJP$0&74q_m0hfrJnh z;=suW(u&Fk^*?YeMfAWQ;va-{f}kn~PF}yW^UgdoJBG+p-9UPGuh;H4ebgNdd!r%R z?e@{2JL)$bv@3P=Qa3q$RVMnz>ci~3bs^I1JB^{UgT%-g>@;57M%f35^!n|NJgl$F z-)#O~F2A<6I$tD~F?0KGPA-3EEuWP+lapg5-35RqoClvdfHZ`_J9N{Upq9YJia{|W zHL7`I&y7nKY+ICjZYGC@-5%~Z&z(+yvo`<*!296Fi#F3m#bn-*@>)rH@7+{|;kra4 zB?@Z%w@cuzcy212!*{VkEvpVE$I&N26JJ|rRpoRaHosNXt%d6uCDJ~72C(=hmQ-4& z-{*{eN3Cs3(3-0JdqbF-p9sbLxlmkkE@+f< zlVj5sbz5kmIhl~u2;0U}-O_vsoX%dFTPy_Nhl62-s?sD{GwdNP<*MrQ4y3A!}1fsHCboVHU;&s!6!7C`~sb| B<=OxM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST b/internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST new file mode 100644 index 00000000..f9247118 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: < ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-LTHAN.TEST ;; ;; ;; Syntax: (< NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test lessp-test (and (< 3) (< 3 4) (< 3 4 5) (< 3 4 5 6) (NOT (< 3 3)) (NOT (< 3 4 4)) (NOT (< 3 4 5 5)) (< 3.0) (< 3.0 4.0) (< 3.0 4.0 5.0) (< 3.0 4.0 5.0 6.0) (NOT (< 3.0 3.0)) (NOT (< 3.0 4.0 4.0)) (NOT (< 3.0 4.0 5.0 5.0)) (< -299 0 3 5 6) (< 1 3 4 100 107 1872 19828) (< 0 3 4 6 7 8 10) (< -7 -6 -5 -4 0 1 2 3 4) (not (< 0 3 4 4 6)) (not (< 10 5 -3 0)) (not (< 0 0 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL b/internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b0c4dc134051c2520330f36e59ed2e06040506d2 GIT binary patch literal 754 zcmah{T~8B16urAkKY*4Lq9huF6B1rF4zU#@))&WRN?W$GFgu&VBWbsGlfpLrFfm4A zeDG<{0BH&OeFZ=)7&|8?>YC}xg$ty8zwURy{^}Bd&nOSy2Al# z`90M4hrNc2S`tUE42#p(WnyeBKgmzoS6&)DcX!}6kr=xD=I+aTDE}CdZqMt;V0Beq z^TmgS;>ybMREgN;CEI^%3dQ>?#e%H4I5}2wJ^(b}JU%7?a-czY802(8ZGlS_lVV0{ zR1ZgCkd|JsV^bamvjsHpySU@Na67S`y*?-a;m06da+o1177LG*H%cb_5M(P1Z%S)q zor0SF!xFPAGR_z916(89aB`fi$1QwopH-F9ec1Y5RqHdiXO)C^_8egDZ7QR*Pk%5O z{~B$)XFmZ(?RTuIDp`QT_SgCP*hox~2FL)MdyTnKJLlyE)%w9 zQjVWhB*NBhU7e7YXLW-Jql`Hf4wo$(W6w!@#}>4vD*t8(OOK|tR5YojrOg?ga&B>K zIbzchx;7~bGCE;9c#PY6B>m>{*T$C80HTR_R@#OnNtP^LBcdFO84l-^UHOAZc_i^0 ze|;FlrkCup4=l?QW2q(i4M`RgnYW^OZ7mG4@wky3Gs-^=gS*1*576QPSwyW}xqeOL v?O$$Aj2$c~;g|48l~M}^r$kVEP0_3f%86-5({Y+q-Eu5Jqnq$~;o{;qV6fkz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-3-MAX.TEST b/internal/test/LANGUAGE/AUTO/12-3-MAX.TEST new file mode 100644 index 00000000..277574d9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-3-MAX.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAX ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 198 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-MAX.TEST ;; ;; ;; Syntax: (MAX &REST NUMBERS) ;; ;; Function Description: ;; The arguments may be any non-complex numbers. ;; MAX returns the argument that is greatest (closest ;; to positive infinity). ;; MIN returns the argument that is least (closest to ;; negative infinity). ;; ;; For MAX, ;; if the arguments are a mixture of rationals and floating-point ;; numbers, and the largest argument ;; is a rational, then the implementation is free to ;; produce either that rational or its floating-point approximation; ;; if the largest argument is a floating-point number of a smaller format ;; than the largest format of any floating-point argument, ;; then the implementation is free to ;; return the argument in its given format or expanded to the larger format. ;; More concisely, the implementation has the choice of returning the largest ;; argument as is or applying the rules of floating-point contagion, ;; taking all the arguments into consideration for contagion purposes. ;; Also, if one or more of the arguments are equal, then any one ;; of them may be chosen as the value to return. ;; Similar remarks apply to MIN (replacing ``largest argument'' by ;; ``smallest argument''). ;; ;; ;; ;; (MAX 6 12) => 12 (MIN 6 12) => 6 ;; (MAX -6 -12) => -6 (MIN -6 -12) => -12 ;; (MAX 1 3 2 -7) => 3 (MIN 1 3 2 -7) => -7 ;; (MAX -2 3 0 7) => 7 (MIN -2 3 0 7) => -2 ;; (MAX 3) => 3 (MIN 3) => 3 ;; (MAX 5.0 2) => 5.0 ;; (MIN 5.0 2) => 2 OR 2.0 ;; (MAX 3.0 7 1) => 7 OR 7.0 (MIN 3.0 7 1) => 1 OR 1.0 ;; (MAX 1.0S0 7.0D0) => 7.0D0 ;; (MIN 1.0S0 7.0D0) => 1.0S0 OR 1.0D0 ;; (MAX 3 1 1.0S0 1.0D0) => 3 OR 3.0D0 ;; (MIN 3 1 1.0S0 1.0D0) => 1 OR 1.0S0 OR 1.0D0 ;; ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (DO-TEST "TEST MAX 1" T) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL b/internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d6ea5edf58bcd29ea7696c13c056b0a91ff5f156 GIT binary patch literal 765 zcmaiy&rcIU6vy9ge^Lrrh$do;PDr?H96}35tQW`a6t-+Qq|l~6OpK8j z51!U&A(CAU|ASY=$iaWe{{Ux;QGy3g`}X^0zVChBn-L_Q8Wu7-yWLjX>!HqY&>ap? zqtiqE&ahYWP($kIrD1dWYMmGxiw|=d=TfHD^Qr@{j>ORG*Q+n?qTB;Sy1iCg2CJ*` zH&?iqFRZLAW=h1dF5LcmCtp}vDJ(B7X3md~6s-dQH8_ht695{-AUNz2{y#!rASE0uX%g(MD|sLH=5gsq2@u~aw_OH0aWopNq- zY`bF96?$w!UdZZ%?clNQ=%K{ba#yC7iUEZ2XjHMXG)b0hULj&FDrUHxQ+8kj9 z*Zy)C#Gx1N;bgohb7?t998LDmvc^l4#))wg3vxe67L~B(!a4O(;NKBme}Lxq$vkRQ zCML>TEST>12-3-MIN.TEST ;; ;; ;; Syntax: (MIN &REST NUMBERS) ;; ;; Function Description: ;; The arguments may be any non-complex numbers. ;; MAX returns the argument that is greatest (closest ;; to positive infinity). ;; MIN returns the argument that is least (closest to ;; negative infinity). ;; ;; For MAX, ;; if the arguments are a mixture of rationals and floating-point ;; numbers, and the largest argument ;; is a rational, then the implementation is free to ;; produce either that rational or its floating-point approximation; ;; if the largest argument is a floating-point number of a smaller format ;; than the largest format of any floating-point argument, ;; then the implementation is free to ;; return the argument in its given format or expanded to the larger format. ;; More concisely, the implementation has the choice of returning the largest ;; argument as is or applying the rules of floating-point contagion, ;; taking all the arguments into consideration for contagion purposes. ;; Also, if one or more of the arguments are equal, then any one ;; of them may be chosen as the value to return. ;; Similar remarks apply to MIN (replacing ``largest argument'' by ;; ``smallest argument''). ;; ;; ;; ;; (MAX 6 12) => 12 (MIN 6 12) => 6 ;; (MAX -6 -12) => -6 (MIN -6 -12) => -12 ;; (MAX 1 3 2 -7) => 3 (MIN 1 3 2 -7) => -7 ;; (MAX -2 3 0 7) => 7 (MIN -2 3 0 7) => -2 ;; (MAX 3) => 3 (MIN 3) => 3 ;; (MAX 5.0 2) => 5.0 ;; (MIN 5.0 2) => 2 OR 2.0 ;; (MAX 3.0 7 1) => 7 OR 7.0 (MIN 3.0 7 1) => 1 OR 1.0 ;; (MAX 1.0S0 7.0D0) => 7.0D0 ;; (MIN 1.0S0 7.0D0) => 1.0S0 OR 1.0D0 ;; (MAX 3 1 1.0S0 1.0D0) => 3 OR 3.0D0 ;; (MIN 3 1 1.0S0 1.0D0) => 1 OR 1.0S0 OR 1.0D0 ;; ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (do-test min-test (and (EQL (min 4 18) 4) (EQL (min -4 -8 -2 0) -8) (= (min 3 9.0 10 9 (/ 5 6) -30 1.0 1.5E2 150 0) -30) (= (min 3 3.00001 (/ 10 3)) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST b/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST new file mode 100644 index 0000000000000000000000000000000000000000..cc70f1206629a84114cf826dff86f0b03b216817 GIT binary patch literal 1021 zcmbtS-;dHj5U!q@K;n~6zRiQVw24Iucfi4k>A|6A3U@hrPd@FH0XCLh+}%d2@gMWA zbG9u9F~%1+TRNQ|-#7COg8@u3kr*xo#1bwLV$=o~eK>y$1K3C*jTAg#X_|wOVu6W5 zrny+v2Lrk=mzhei59Jxj4V6S(Z{a?Nxj{_PM&?*j1g%E950tfKifbt}5brG8+@sPJ z#0^^!TyWN@2u8$54Z%fTkbIPD0XIy2J`CIL$CTBFDa)brn#y~-`iN-*ciTk~{!4tq zQ$i1QHNp?1#(tisG(sX34wFqfG$hF|X!$MwK@Weg1vYHFY^P8p7lwVS;7CPLj0eY{ zD2)_V=$9^CjqtF5G3rF|tzAYR;x+zDepv3-rqE=Hlr$py}J-Jn^gw=(@Q+?Pr>hcbP8Z<$+72&bL6~p z0(X2l3GbqKay^S70QY@3`VbO~w=;WW#h16!t63O9&-0w;MY;WX;XEzU4_yC==r}Je i@MF5KtZ_t7%^Ku!rq-~Yo;9rJlQkZZ^VoUz{nu|v@eI8H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONINCREASE.TEST b/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONINCREASE.TEST new file mode 100644 index 0000000000000000000000000000000000000000..11e6c5cb2240475324d9b94020eccd98e1ed04e7 GIT binary patch literal 1020 zcmbtSO>fgc5H%E#5{VNhZgT+SNI1kvNnHnm+@ygbC#@Ry!foqJk`?xD*j)<@;*as` zn01^cLWm2iwe>t7Z)V*Y)o7@b+3@+xoZdREm_sux~XTsVJ)P-~}iO zBSjT@Ta&IwxLd#&b*lKrE+d3wjsKD#mbs}+ZDsmLY)vd6uLa<&P)IrzVOp+i0 zDmA-^Z9wfD(bkP(Tp0Z-<~cXa&P(!>qEx2YbQjXIiteXB6uWXY8;yp`!~$H>x7V_t z4GWLqc>mFd*U*Cw>@9w$11E6O?o@U!Am9byoz@Zbt5<|RbcvKs#Y-JI_B?QooOh1z zj?X92O`J?FX9@V=zK=#9BJew{9SjI1=hxGVSrkLiYB`Uqbo+YZJgmYGO#jK~I8QC{ heY(#qIHIRv0a=`>1=bQ+U@f04xJSn4&ZF>J_@*mXMVwAvzS2OdTnfILMoEbypnQkDxyW4AboIdJ~hP}}c zHM@N@=#Khz2Q{URUg;*MuS-PVSbdaESQjGozOyrQ8c2+sL1X9TU6g)^NUz`S$j$n? zJf?GNnOruznkW#Tnh;aex$rz&mhLnxK}zg|b00 zBUP$-W6zCA7HnITd+tI84ZA(uab7r`0B3gq3V`>~jTLOBi?YeQL*yW+X=bOztYjBeK8_$c}`sNq}dw4$8s!RGghx;1}uL5Z|ap93tuok=RK zlOIg(e~mZZv!4Lt);m^Fl{tWe*4OJ>QxX}D0VDy=+V#b8E7eYc8u324w=~^k`EpPh zE)kYDD92CAQej0)Q^OK@LDPxQOPEt(b6K)JWsX|gmY`Ktxq3sGnm-$w@#CSG#GKbC z=O)LdEo!#VLUH*ZsS&n~r@E#2k~fvU)V7%rfFBNe6{<*+Xu;%FB8ovW-R7LK3p4PQ z2U5TGk3%OGJ$LtK!+9Bt2c5)0Z~u;KI!5UnnO3nPClqBt4r9q*QXhNn9pMayXnCJ3 zqvnqMiw)G?JO4(3w!flyU%W$Adf(PLC4%Bh>5a0WoEVlr8(folHf>W-{|0CML>TEST>12-3-NEQP.TEST ;; ;; ;; Syntax: (/= &REST NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test NEQP-test (and (/= 1 2 3 4 9 10 119.0) (/= 0 2 3.0 100 -1.1) (/= 7 77 100 192886) (/= 4) (not (/= 10.0 10 20 30 40 100 1000 203909)) (not (/= 1 1.0 1 1.000)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-+.DFASL b/internal/test/LANGUAGE/AUTO/12-4-+.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7bb0606616e2017823ddca01c72e62bcb6f38f95 GIT binary patch literal 1100 zcmb_b&rcIU6rOEqX=zK^Qk&KwZb(SX>JnQ@#CkC6GKIpj3%j#Hj!ju?lR}&RFfj&V zIOt^!79!cF;oyION5sg%c=YVmgNcbJPhN4Rhyt4E!NcUud*8fo-ka}D8+mTa3NKfe zYvqbn=c}z|t<~h0s&&3mZPkkwzeMBweOc4->ZBx358p`j7$=Zo-6}M#MV_>*#$w^# z6+U&HmumHLg>J^isGG`;rn8yMa8FJ$lq0sk=A^S%GuhG6;hw{tZ7y6z2o=!*Gk%1^ z$c>y$J1h`v5HXimu&7EiSa8~o?W4Vjrh#?Gj->f!wI)`qyHHceb`my>Jp?2w^I_2U*bhjIykFjiu`Va~tbWkqF zJ53$)y*%dY{x5tScg*Me2foeH?zuk{*e-?3VfHFd?S4Vl)bTufI&o4`#}%xLxAHWi zP8fo#8~iR0U0qb0h#*Tuo)mRVOr5^1+!4oXEEojOxVYa>5KVx9+Yf$si0aWRU|rXA zQ8US`Nd$L*CIkgZT@X8QLjWpFWaO;Aem6qU#Z>h(slHGqZ%)%^B*NU!>{i*-b*!G4 z8sHfAfnu>=&B>C1kFJ6Mg8`z%BPSN#6?I9K{5$RFH8LB*cXY_ zX!3(=(jdQ7pr3V-FRvW^GZtGLV#i)M&z&t7r5ccREDu7P9WGE11|V@0`nl5)^z72%;de)WM1ueT literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-+.TEST b/internal/test/LANGUAGE/AUTO/12-4-+.TEST new file mode 100644 index 00000000..6b08ead2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-4-+.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: + ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 199 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-PLUS.TEST ;; ;; ;; Syntax: (+ &REST NUMBERS) ;; ;; Function Description: ;; This returns the sum of the arguments. If there are no arguments, the result ;; is 0, which is an identity for this operation. ;; ;; Compatibility note: While + is compatible with its use in Zetalisp, ;; it is incompatible with Maclisp, which uses + for fixnum-only ;; addition. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (DO-TEST PLUS-TEST1 (AND (= (+) 0) (= (+ 0) 0) (= (+ 1) 1) (= (+ -1) -1) (= (+ 10 20) 30) (= (+ 10 -20) -10) (= (+ -100 -200) -300) (= (+ -100 200) 100) (= (+ 1000 2000 3000) 6000) (= (+ 10000 20000 30000 40000) 100000) (= (+ -10000 20000 -30000 40000) 20000))) (DO-TEST PLUS-TEST2 (AND (= (+ 1000000 2000000) 3000000) (= (+ 1000000 -2000000) -1000000) (= (+ -10000000 -20000000) -30000000) (= (+ -10000000 20000000) 10000000) (= (+ 100000000 200000000 300000000) 600000000) (= (+ 1000000000 2000000000 3000000000 4000000000) 10000000000) (= (+ -1000000000 2000000000 -3000000000 4000000000) 2000000000))) (DO-TEST PLUS-TEST3 (AND (= (+ (/ 1 2) (/ 1 2)) 1) (= (+ (/ 2 3) (/ 1 3)) 1) (= (+ (/ 5 6) (/ 1 6)) 1) (= (+ (/ 1 2) (/ 1 3)) (/ 5 6)) (= (+ (/ 1 2) (/ -1 2)) 0) (= (+ (/ 2 3) (/ -1 3)) (/ 1 3)) (= (+ (/ 5 6) (/ -1 6)) (/ 2 3)) (= (+ (/ 1 2) (/ -1 3)) (/ 1 6)) (= (+ (/ -1 2) (/ 1 2)) 0) (= (+ (/ -2 3) (/ 1 3)) (/ -1 3)) (= (+ (/ -5 6) (/ 1 6)) (/ -2 3)) (= (+ (/ -1 2) (/ 1 3)) (/ -1 6)) (= (+ (/ -1 2) (/ -1 2)) -1) (= (+ (/ -2 3) (/ -1 3)) -1) (= (+ (/ -5 6) (/ -1 6)) -1) (= (+ (/ -1 2) (/ -1 3)) (/ -5 6)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4--.DFASL b/internal/test/LANGUAGE/AUTO/12-4--.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9a86d40c44c73e69003ec021c44e9473d933aa00 GIT binary patch literal 1103 zcmb_b&rcIk5PsXz($ZquQk&KwZb(SX#z))&5$nOM%PTCjyRbik9GkM(CWSWrVPXu# zaL~&dEJU)S;oyION5sg%c=YVmgNcbJPhRo8A_{1t2M?QhGv9pQn|U+aM!wr}j+d*; zwQ|L-^VL?f)@t%g)jHp(w(3QjU!rmTzO3nFbxM+FhHr>H#tEcYw+l^skvCg*W3h1W z3NK#grCPmQp@;Et>WZ1MbY^sPxF;(axg)i|a?+WrV;NB#?m67q<|0*uP!Sz46GSM2 zyvW^jB7#W_6K9ni!K#!eg4=eT0PO`^2GLz7n&z9;8m`!P?FwsWxq&!@+$T;TYpJrS zXsWx#J>bIbhSRI4c$T&%O%mh@{7_-)oa^|-G#HXhW5wA-7)7;()D!iWd z%*QT7IbV7I4nnc@?sHse?~O{&U)wW})wc+>OApm)57$diyNUTYV^cJMP#B?uaxu|q z>R9jPv0nFo(c`#dy}&={ZI*V=|DnKkDN>HGS9$963$mt8DD3I*l%!7Nh>mY5G@?!# zf~OmT9v}U>=xm~bESd5Y)`@B9^ljzNaQw!CVUoOu`#r)Ec9K2c$ft~QFbV=sFs1*(v19EMCP%C z_p}mUr*!7MqdVwVSzS5i?m>!~t^nYFC%PU8}8jGzBv9uTNb9c)_wFYFJNG8E&8qO&u(WRULA(lofp0hNQ dK$3AcpntAIhl>=10Z872e(rPxJ-d8(_#NK*MNj|$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4--.TEST b/internal/test/LANGUAGE/AUTO/12-4--.TEST new file mode 100644 index 00000000..86fb0249 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-4--.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: - ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 199 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-MINUS.TEST ;; ;; ;; Syntax: (- &REST NUMBERS) ;; ;; Function Description: ;; The function -, when given one argument, returns the negative ;; of that argument. ;; ;; The function -, when given more than one argument, successively subtracts ;; from the first argument all the others, and returns the result. ;; For example, (- 3 4 5) => -6. ;; ;; Compatibility note: While - is compatible with its use in Zetalisp, ;; it is incompatible with Maclisp, which uses - for fixnum-only ;; subtraction. ;; Also, - differs from DIFFERENCE as used in most Lisp ;; systems in the case of one argument. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (DO-TEST MINUS-TEST1 (AND (= (- 0) 0) (= (- 1) -1) (= (- -1) 1) (= (- 10 20) -10) (= (- 10 -20) 30) (= (- -100 -200) 100) (= (- -100 200) -300) (= (- 1000 2000 3000) -4000) (= (- 10000 20000 30000 40000) -80000) (= (- -10000 20000 -30000 40000) -40000))) (DO-TEST MINUS-TEST2 (AND (= (- 1000000 2000000) -1000000) (= (- 1000000 -2000000) 3000000) (= (- -10000000 -20000000) 10000000) (= (- -10000000 20000000) -30000000) (= (- 100000000 200000000 300000000) -400000000) (= (- 1000000000 2000000000 3000000000 4000000000) -8000000000) (= (- -1000000000 2000000000 -3000000000 4000000000) -4000000000))) (DO-TEST MINUS-TEST3 (AND (= (- (/ 1 2) (/ 1 2)) 0) (= (- (/ 2 3) (/ 1 3)) (/ 1 3)) (= (- (/ 5 6) (/ 1 6)) (/ 2 3)) (= (- (/ 1 2) (/ 1 3)) (/ 1 6)) (= (- (/ 1 2) (/ -1 2)) 1) (= (- (/ 2 3) (/ -1 3)) 1) (= (- (/ 5 6) (/ -1 6)) 1) (= (- (/ 1 2) (/ -1 3)) (/ 5 6)) (= (- (/ -1 2) (/ 1 2)) -1) (= (- (/ -2 3) (/ 1 3)) -1) (= (- (/ -5 6) (/ 1 6)) -1) (= (- (/ -1 2) (/ 1 3)) (/ -5 6)) (= (- (/ -1 2) (/ -1 2)) 0) (= (- (/ -2 3) (/ -1 3)) (/ -1 3)) (= (- (/ -5 6) (/ -1 6)) (/ -2 3)) (= (- (/ -1 2) (/ -1 3)) (/ -1 6)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-1+.DFASL b/internal/test/LANGUAGE/AUTO/12-4-1+.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..26a3b123e436a15741229cbdc871a5866d38c0c2 GIT binary patch literal 752 zcmaiyPfrs;7{=e-rT?IimMDqF;Dm(B;t;oii1p&QOle`6h1uC4N762~Nuf>um>455 z9z3nlLL{>qzJpi9$iXk_D+bWp3`YxjF- zx79)2R=-mX(5}+aYun}YO_|th^G~c%@5)ZK6YTVY8WR1WTibc{09lU_X?Ge;wOCqG zzgBUvP+VA;A1x8jxpez)O`-U3u~=A|AH6s^)^aTXsKR;t$pGZQ0C^bZOhG+?OBIJ= zM%Jk*2Qo}67VLYJ%P?O+y;d7HgO@=w#@XwF1|UC$>5|WEQE{0((%x!W`7s=?FubAA z$O;8L{nsUS*JPNo3U~oqb8vE;+=@H+UO!vaPWNH+$Ev1}(0uIt*(6T&s4F(VaajI^ShFe&FQ z$F46nd|?_HRgg6a+r~rPGb4qYv#w1oWdKAY@u-Y7Ws)qpe4U7L9A^8RQ+DMFBJGjV zZ~f!2iAOKpRUcTDCx%h8>K2kLHgfJnQ^v9kGx4;MHHWOHGQ2N>ZV$~IkQubQqaI%k wHTEyxO{^WvYVxZ*(pA#5%_$KSUkh|9f^y<`(O7&;g>L$;pwVskGJSFJ2Pn7RjsO4v literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-1+.TEST b/internal/test/LANGUAGE/AUTO/12-4-1+.TEST new file mode 100644 index 00000000..c4b82a90 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-4-1+.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: 1+ ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 200 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: Sep 24, 1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-1+.TEST ;; ;; ;; Syntax: (1+ NUMBER) ;; ;; Function Description: ;; (1+ X) is the same as (+ X 1). ;; ;; (1- X) is the same as (- X 1). ;; Note that the short name may be confusing: (1- X) does NOT mean ;; 1-X; rather, it means X-1. ;; Rationale: These are included primarily for compatibility with Maclisp ;; and Zetalisp. Some programmers prefer always to write (+ X 1) and ;; (- X 1) instead of (1+ X) and (1- X). ;; Implementation note: Compiler writers are very strongly encouraged to ensure ;; that (1+ X) and (+ X 1) compile into identical code, and ;; similarly for (1- X) and (- X 1), to avoid pressure on a Lisp ;; programmer to write possibly less clear code for the sake of efficiency. ;; This can easily be done as a source-language transformation. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (DO-TEST "TEST 1+ 1" (AND (= (1+ 1) 2) (= (1+ 0) 1) (= (1+ -1) 0) (= (1+ 10239999) 10240000))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-1-.DFASL b/internal/test/LANGUAGE/AUTO/12-4-1-.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d291e91ad3a401975727b77bdd07eb2b7bbe4490 GIT binary patch literal 765 zcmaiy&rcIU6vy9ge?uXKXd=ewgoMk+Y1~=@){Db3r7g=W%+87&N!i*ag*N?RVvNLi z@U%t?k?d;tAG{()4*o;_2X(eJO5osWX1;Ic``+ih89?lrVIrfo-)=PB4r=v#?S2o{ zS{>AF^*dD;)ufJI85XCnOT<{uKGrAfOOa~F-R-%1Nc7$A-tNo$NPmP#yVGdO&GNE5 z>V?HzA)n7q6p3w)-TwO~S9q{kc(|0E7@nRenHB(4;UZj802zpYf8=E}L2ZGHWs_n? zHmK$gd@m_kuwzs1dowxIYqfFHec?7koc%5+0RBfWS#+2o$`gN^Z>;SgDSJdt4+cQe6asC`&_H81q)X#n} zx&Jj-f6smb4C?P#MOCH%j_O};ZjU%*I0=vjxM);o2lY%N18U6wi>;Q!x^RiG zRg-eOQkDu^vo$p;foC*>2&05K6%LmL8zbVly<-cyp(@vJ2ulklBZ(jtNlM6RjdE^r zY&l}n5n3cAAEY(HcJN5IwLsEl^eatEL;!+l*r`ZGn#7A1-ymWwOlCNoQ+8AV$-pEFd1Eyv6Sts=s4``-(ii0D4k=YDi-8?;w;Qz&INPo6W_Zh+-?ueACh@g z+m%0Y4>bOHy9TF3P<$o5Sr(KN(+(!XYckK4V+k7Eg3o9;{0)WE BCML>TEST>12-4-SUB1.TEST ;; ;; ;; Syntax: (1- NUMBER) ;; ;; Function Description: ;; (1+ X) is the same as (+ X 1). ;; ;; (1- X) is the same as (- X 1). ;; Note that the short name may be confusing: (1- X) does NOT mean ;; 1-X; rather, it means X-1. ;; Rationale: These are included primarily for compatibility with Maclisp ;; and Zetalisp. Some programmers prefer always to write (+ X 1) and ;; (- X 1) instead of (1+ X) and (1- X). ;; Implementation note: Compiler writers are very strongly encouraged to ensure ;; that (1+ X) and (+ X 1) compile into identical code, and ;; similarly for (1- X) and (- X 1), to avoid pressure on a Lisp ;; programmer to write possibly less clear code for the sake of efficiency. ;; This can easily be done as a source-language transformation. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test sub1-test (and (equalp (1- 3) 2) (equalp (1- 7.0) 6.0) (zerop (1- 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL b/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b1af9267afdc60812ffbe83956c565bbd5500d02 GIT binary patch literal 777 zcmah{T~8B16urCsptPkaL=!PaCnUUVoW|A?vA#Gi(=V1;n4J}QBxSKp3fuI<#2AV3 z!KXD^h-6p8fAAGC^57rxAJo~FAkhb(X6D?PbI-YFh7fzE8%THeI<2&a+kf8_O81sZ#rwJB=;T<*x&Y9C^Kh94$U+4CLocfdY6)Df85A?J zMm2xvdkN_U+ZN@%H(Nk`w}acx3#T30+3SG<;D7WIWt-`uW-|Xsd84HL58h0T;dN<^ zR4Ay43zm>w@x4sGfQwi+S>3J>LE+>${xlTwt$9{gPWNHsdtKek+?-Wnt+VF4w}D+cBGNlhZGVrgnr`kvKvBJ?WeRM=eV*2l)<)|MscnyUPJLzr5SicAI5k%aV` z(J1F8$EGdTZJ|Y`<%6_F*cKk+mKI3U+5BI#n~DGg(Qsgqx+IC0O}<7%C2XeKoKtos zh(LKD@oRs4=)|HE_8=8qk+sa_IB_`T%izX=O8VGX%A(9F&ca5GjdV z0a-x1+wxcLpw|B6LxtGEqT+w?k5t*CML>TEST>12-4-CONJUGATE.TEST ;; ;; ;; Syntax: (CONJUGATE NUMBER) ;; ;; Function Description: ;; This returns the complex conjugate of NUMBER. The conjugate ;; of a non-complex number is itself. For a complex number Z, ;; ;; (CONJUGATE Z) = (COMPLEX (REALPART Z) (- (IMAGPART Z))) ;; ;; For example: ;; ;; (CONJUGATE #C(3/5 4/5)) => #C(3/5 -4/5) ;; (CONJUGATE #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) ;; (CONJUGATE 3.7) => 3.7 ;; ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test conjugate-test (and (equal (conjugate #C(1 4)) #C(1 -4)) (equal (conjugate #C(1 -4)) #C(1 4)) (equal (conjugate 3) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL b/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..639240c28accb81f9b0b02e8c5808f4af16e0380 GIT binary patch literal 895 zcmah|O-~a+7=Cx#(w2|45KIUf-4MNOTw$2mgWLh8Q{c7xaI4^_q&+`3$C zHEXS=yj-ozjcTjzxbiad%g;5##4mD4n;XBA?6uBCoVvTzbc-@=xsBq|vs-d zhsd;!P4!-$dB}{Vh+(GSprRqF+hhu8T?u=vMT_EjQTR858cNU?in4$}{;17$ z3dMqWD9)6W6l|J?sTww2u&ELnV7dJYB8zI*Zz%zjG?BcpnP?aw2=jGx1>R*qJz2w? zN0jTm&53BXX<~A2-GRVkn=Cf`cTNpi__R~d_kg3|`!>=S?gk^tVB|(H66Q5qtR~JE zs&eYVrKc=0(xq2px1)#f#(FWhBJ$){zIUCvjix-dj>hEWCH5AIa(V6a8gt+JO~K#y lcSHtyO*1i~SiQhU&r@t7-3t168tZl6HYg58;q6$b^9u=O4=n%y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-DECF.TEST b/internal/test/LANGUAGE/AUTO/12-4-DECF.TEST new file mode 100644 index 00000000..61cc7588 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-4-DECF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: DECF ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 201 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-DECF.TEST ;; ;; ;; Syntax: (DECF PLACE &OPTIONAL DELTA) ;; ;; Function Description: ;; This returns the complex conjugate of NUMBER. The conjugate ;; of a non-complex number is itself. For a complex number Z, ;; ;; (CONJUGATE Z) = (COMPLEX (REALPART Z) (- (IMAGPART Z))) ;; ;; For example: ;; ;; (CONJUGATE #C(3/5 4/5)) => #C(3/5 -4/5) ;; (CONJUGATE #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) ;; (CONJUGATE 3.7) => 3.7 ;; ;; ;; Argument(s): PLACE - a generalized variable ;; DELTA - a number ;; ;; Returns: a number ;; (do-test decf-test (and (setq n 0) (equalp (decf n) -1) (equalp (decf n) -2) (equalp (decf n 5) -7) (zerop (incf n 7)) (equalp (decf n 1) -1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL b/internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1a7d2aaca9532f24902978a114bd6ccd55b300a9 GIT binary patch literal 765 zcmaiyT~8B16o$`k=?AosmS`fz=!Arujnmi$BGwzn>GX?b7G`HfE=gHzlR}$*m>455 zUU;=e3z6(<_z&J9MlSqA{)0N(8YOt))t-IN%zMsr&I}>?l$waP_dCs&+ePg`zcc8g zy>=J%+JkQ0MSDs|FR3Nis|ulO*@w9q`%gqFt#Z7f z&`6nqp7`w&x@#)V@50gf79u5XP&R5}5W0=Q__=ZB4SGYxvw|LEN^sKtxburXXA zyl66kA6J#a%eJ9UDdLPliKG=Qm~@2dn2wQS_O>nAx~~0uLRvO#sOd>fB-+XxhHI(KDi@d!XL6^<%WQzo&JCDw^7hsCHP1ml-h5NP+6 ze(f&@B{rM52g#|T$|ckwaX8sO%Nj3H8Ar!WEUEp(cv!+*2p055zIR8uy*^qzB#UTo zN4>;d)I69xqEI_r()`cCML>TEST>12-4-GCD.TEST ;; ;; ;; Syntax: (GCD &REST INTEGERS) ;; ;; Function Description: ;; This returns the greatest common divisor of all the arguments, ;; which must be integers. The result of GCD is always a non-negative ;; integer. ;; If one argument is given, its absolute value is returned. ;; If no arguments are given, GCD returns 0, ;; which is an identity for this operation. ;; For three or more arguments, ;; ;; (GCD A B C ... Z) = (GCD (GCD A B) C ... Z) ;; ;; ;; Here are some examples of the use of GCD: ;; ;; (GCD 91 -49) => 7 ;; (GCD 63 -42 35) => 7 ;; (GCD 5) => 5 ;; (GCD -4) => 4 ;; (GCD) => 0 ;; ;; ;; Argument(s): INTEGERS - an integer ;; ;; Returns: an integer ;; (do-test gcd-test (and (eq (gcd 14 49) 7) (eq (gcd 18 9 1) 1) (eq (gcd -3 -9 -81) 3) (eq (gcd 10) 10) (zerop (gcd)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL b/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..645e96c58963fa55345eae84aa297dcca872ceaa GIT binary patch literal 895 zcmah|T~E_c7=GJrY~!OAf(Zem4aS>l30uJ6OiXGyV}o)E?WvPX(iJz@*s>3!F%rUs zH`d@FkXGTse_*&nj9mB^^ndsd<~f@m1TRc4dfu<+ectCirv;J6nl5RTaYVuXQ2f)ZEpEo0mw_t>;&t-;omcB(+*A zmgr$-hMI}gbTTzHHPM?^Exn8O-|e8`Cv0C3=({o(*3guvhPM42Fq zDCw+@6s#^H*>Cw?jLxFi7BYQrFex=ERi)%UbxUlVaveAT|E(8G+gKx61N-~jHrMa( zdIMRkEYZ=_IRt#{7Yak?d@r6zDpN`pYiT$>jP6hh9~h5Mg|m6?bQ6v~&+|EPbdZaz zJHkmOCv1FkgpC1!lT`Oy;+b(fCzK*IQi?KbY@M3X?~c$u$_eE*^_Sb!zg_tKojm~< z+KCEW;q(ip=O3+wH~1?+tMCfX^Bm3HD}20~8)8goI0n!Ua9(tVTLrNw0w3`Yylb*% z;Mpu2RLQ7#R!64tFiSmn&XV~sRd7(&RH9`R6A{~_3TPb(d#n|UphcehH-i{*&=-o* z0Ehpm&2$RIf_NxSl@w%Tnue(uHd(TX92%gx{j!Qzl#bt$11hPQxU`vQ7$69UFpZ20e-nrfkLr=afCML>TEST>12-4-INCF.TEST ;; ;; ;; Syntax: (INCF PLACE &OPTIONAL DELTA) ;; ;; Function Description: ;; This returns the complex conjugate of NUMBER. The conjugate ;; of a non-complex number is itself. For a complex number Z, ;; ;; (CONJUGATE Z) = (COMPLEX (REALPART Z) (- (IMAGPART Z))) ;; ;; For example: ;; ;; (CONJUGATE #C(3/5 4/5)) => #C(3/5 -4/5) ;; (CONJUGATE #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) ;; (CONJUGATE 3.7) => 3.7 ;; ;; ;; Argument(s): PLACE - a generalized variable ;; DELTA - a number ;; ;; Returns: a number ;; (do-test incf-test (and (setq n 0) (equalp (incf n) 1) (equalp (incf n) 2) (equalp (incf n 5) 7) (zerop (decf n 7)) (equalp (incf n -1) -1) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL b/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8406d795c0d39975ed2b1cda1d9aafd29eef9860 GIT binary patch literal 1874 zcmb_dO>7%Q6n?v|6aOXH&JS@F(j{tDX~h(5LXw69S~lavsk58xjupZ!N;cS1QU}Kd zA=HA3RD@(y+=yrg)B{Iu<-j2ns1QP&svatVI3a|D#0`#|!kZnO#tjl2d>Fmi?|a|3 z^Jd@7wjlhHS=7wx_D*HXt7+9neWy{^Hmfylx7w(!d)g-A+MA~B&@1zXdFjIQ*_eBb zS+99(b#Fss4R3d2?Tx3j>_yGksa3XcGChrt*_r2ZGZPaRVtKeB|s4J&Wr<8Ez&MN@vYrScueDJk}^FLab-nYI5XqB&93#!tG zv)jWfqe6{r1Rw!$x3WGKl-2h8rtR0;6+b1__KS4KZ>{YY?T+7PZNI**_^C?UFWw!$ z<+fkqfB4-j-yZsx58NszD@jlj{)f#`-L$RQf@nT6Z&W~);h*)#3uEu#(?ZXkp z5y8=mBaGt|c6&-U4Q9?0hq97`-D(Ey-s7&ij4rCm$qZ)eJRXYiXs91MykDn|V>`qy zv858zLyw^#p&QmJ32;~E*y^dNM^8*F1i(*;b221aUq`2&yzML+Ogx?!Z#7GfL#<=y zkSl_F9J#@V#hQjo<*RrcY2_!L7U2gzAj0>2P=xm+cwK_8OYouuCnb130O9ulgx>-X zev}}W;JyUk<%0#D&hvpOJ~)c*>RDXT89c`%xHeV_Y@XzZMdw^HTUsJ{!(_H|bcKi< zA&Oze;b4ozQy6cL9!u0;6zlzqXGC~_#$%nvSz&z4mk*1?ulR@vpG(=NGQ1-;s#7hO zB{kbp%7l3VbKaK_>-8x o$0hTYWQ>!{(*Xm2o?zf-$$WB>xxuyNPV@z?DV+#>G<|sZH}-TBXaE2J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-LCM.TEST b/internal/test/LANGUAGE/AUTO/12-4-LCM.TEST new file mode 100644 index 00000000..f2369259 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-4-LCM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LCM ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 202 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 25,1986 by John Sybalsky ;; ;; Filed As: {ERIS}CML>TEST>12-4-LCM.TEST ;; ;; ;; Syntax: (LCM INTEGER &REST MORE-INTEGERS) ;; ;; Function Description: ;; This returns the least common multiple of its arguments, ;; which must be integers. ;; The result of LCM is always a non-negative integer. ;; For two arguments that are not both zero, ;; ;; (LCM A B) = (/ (ABS (* A B)) (GCD A B)) ;; ;; If one or both arguments are zero, ;; ;; (LCM A 0) = (LCM 0 A) = 0 ;; ;; ;; For one argument, LCM returns the absolute value of that argument. ;; For three or more arguments, ;; ;; (LCM A B C ... Z) = (LCM (LCM A B) C ... Z) ;; ;; ;; Some examples: ;; ;; (LCM 14 35) => 70 ;; (LCM 0 5) => 0 ;; (LCM 1 2 3 4 5 6) => 60 ;; ;; ;; Mathematically, (LCM) should return infinity. Because Common Lisp ;; does not have a representation for infinity, LCM, unlike GCD, ;; always requires at least one argument. ;; ;; Argument(s): INTEGER - an integer ;; MORE-INTEGERS - an integer ;; ;; Returns: an integer ;; (do-test lcm-test-dup-factor (eq (lcm 14 35) 70)) (do-test lcm-test-with-zero (eq (lcm 0 5) 0)) (do-test lcm-test-1to7 (eq (lcm 1 2 3 4 5 6 7) 420)) (do-test lcm-test-with-1-neg (eq (lcm -4 5 7) 140)) (do-test lcm-test-with-2-negs (eq (lcm -4 5 -7) 140)) (do-test lcm-test-with-1-neg-dup-factor (eq (lcm -14 35) 70)) (do-test lcm-test-with-2-negs-dup-factor (eq (lcm -14 -35) 70)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL b/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1330a09deca872db8f22125a05323c7e2b7263b6 GIT binary patch literal 823 zcmah{&rcIU6n?vDh3ap=FR*0ecyXMh(D$lqK&O)t?su_quXhAJ7}}f zLhVMkRq@fL^rIKl;q2uCp-a>Eb1C<)NTubkcl-?`x_*0O{rPQ_n?`4FIUXsd|P0vJiuCFUT5#xdN9=i(#8A zGb8MUK~i$Tp38U`jOJ0N(ZqHCnO|3Qw%VWpgztl7$+M|29Xs6DcC}3SE*Lg#T$a?x zJOe%XtBdNcg+VHp#|6CNIl^SNfWw1?uW)>+9xrM~+wkP;qP{vZKB~pHen@O8Gz`$I z?N*PU0*t*H%xKl46I)Z<+0bg`C5D@p&A3m%lX?7VxFMyi^vc*H7SlV*B~GisK(Lmg|tm1U{lx?{DC zKMPi$2Qok22U(CiP1p*8bt}3abHd=J@Y@|UxkDz==DNJz4OH7cKRo5znVNWgBKM?) lpTd1zPPsujBZA>e7%fvUPAoS{t28-Hfnm`&e4IQx`w8`E^{@Z{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.TEST b/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.TEST new file mode 100644 index 0000000000000000000000000000000000000000..bbcf662e5a63825c57034181789ade1df0f1a3ec GIT binary patch literal 2128 zcmeHHO^+Kz5S@)g_QVm+1ro3;jXkz^gBEXCY1iwGCOCFtkCiL!aj&P9p6Ow_XEzq& zz&V%v2`-#+MdAnKZxAks8~=dUJs+5aD+eS--uAkxy6V-dS95wwS7jC(p)!gTU2uxH zHhev#;QiB6d}yJ{BIZMSP;O~L3&XkOpJ^IRqKR{JcX>$tLHC%>3t^I!8xhki=LNHQ zwGDgBHpnsP_3Esnf-{t%i|vr`e8r{Q(p<4P*$uF$E)h4Rhb8>|f#3h)D3*(Sc953D0OF zZg8fm;A9e(k;*u+VpFC(Gd}4uj=9!|LF;RABi7teX>2M{p!p`2R$F3HA_*sjqtL{% zH5J^HMW&s(;JTEiYoXY`rx?>)@7LaR$n{`Oixw*qw#v@T;{B{yLb*RDp& zP#cGcnWS$@Wd!;l1?R0Ikr}=LGFx3}$`s&d#GkX+G`=p;l`5<)%_VoV*=YNK_Wpp5 z59!M@I@&cJ)yDo&aJ*yhoVd_VKRDU3BAD(~If8*zqRVZ+A^nPBM@o&=(F&j-v~F2s z8;iQ}SETwjL8(DK#%H_T8MUUX$!s?FX*3Qe;q-w|(R?`_okwGL3*EM&n9r8e%a-Zz z8ig>`S`C&mM%Pk--E7mz6(CSnrYl~!M5vinb1o%@2NZ9`#tJgt*nMJoF1Kx+kxFyq zTnQ=6)=mYx_B3IJ0$M9%LS3T_#I>a|lj0eNa^bZ-mbzrp_8tU;Mw*@n-OU^O`%klC=hy%M literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-TIMES.DFASL b/internal/test/LANGUAGE/AUTO/12-4-TIMES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d0f26f6a075463c771ee2e83b59a35a71067a7d GIT binary patch literal 769 zcmaiy&rcIU6vy9g>F<^lqKO!z6A~^Pr?C|j>&0=ImMz;^n4J|lHtk}Y6x#HMi7^u6 z!P6QoM6#>lfAESJIrtCxAK+{;O7P%mX1;Ic``+ih8AJ4`ZX&(A(`$F!KI)E!z0nYD zcl&729rYV7+Lk(csau@BS|$2g{$U|yUx+mNZhh!Bkr=syX8px&RCs_$uix&-&GNE5 z7D`LS(&A!1RVKE1?)Kj|#nPR7rMpY{)Y;LYlIsFM15U#w36O&b`1@W?6Vw*CY?u@? zQlpwb_PvB;!H!M2@68m^u-n5O_qp2%adrlv0QeugMA>1wFf8UDD6f@_|K7_Q46jQx zQlX$Ge!GP3itl9$MZAcGQKL2-9mbx7MSN|YRF&gh*!WgeH>a=9DAD%GGl1DQ@r=?s z{?6q7=XmWM`vEX+y=7HZ$pY-RzFgg$pvZ6nAOmpPZp@BbxpofJsQ=Nsq3IS|F~ZXD zDq$-o<@m876;`n|bxJbNXgU%4D&|x;T-K~lpkwxyEoeE#VG^Xnv2( zqwTun%~qpC4%Bh`AtJmPE0#Uhu37D4aX8RxCWol+1W3j C$mP}m literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST b/internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST new file mode 100644 index 00000000..1d1ceeee --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: * ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 199 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-TIMES.TEST ;; ;; ;; Syntax: (* &REST NUMBERS) ;; ;; Function Description: ;; This returns the product of the arguments. ;; If there are no arguments, the result ;; is 1, which is an identity for this operation. ;; ;; Compatibility note: While * is compatible with its use in Zetalisp, ;; it is incompatible with Maclisp, which uses * for fixnum-only ;; multiplication. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (do-test times-test (and (equalp (* 4 18) 72) (equalp (* 2.1 3.4 0.5 0.1) 0.357) (equalp (* -1 -4 -5) -20) (equalp (* 1.5E2 2E3 1E-1) 30000.0) (equalp (*) 1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..134ccfa58b0d41fc6f2ff579a725d2cd4e6e5f9e GIT binary patch literal 1002 zcmah|-%ry}6u#{?w!t;7 zTt1UE3S6#S%9l%ADp%l&xpEznB{QUD9+9- zoZ*CvoR}|UvLqN7AV(qG9}4&N^)^REO|Gl`_nlDq?D=q?(A&JbvCaf@0DvUep_>}2q0E90uU3~XMbJ6)3jV)i>(KQ|){tPThbfJXj3Vn+kdy7$nfbp6@B2|(Mj zJHVv3J}V^tQ5{`Tz5q~7-&aOhhR|2jZx2tlQ4Nyz0N?{)CzEWirh}OvU|rT@vx}D! zN+eFphcQu!$Vi1lae^qr8qYdOUt4)e#8M2Z20Eo9GI8e34raSL-NzE zzac_R(S$lCVtRZfsCWnk(pv086j~t!SIsj$-6NN&NuiG91^bwfLeDL;8ym$E z*Rv@0aH$#c>&$YQ`TDJ=*y5=hmB@qk$n{G2Zd*>N3^t`wv5LsPei5k*eEraIp)v@6 z;d8b4MCHmiuiRaWJ1DL*)-!93CBBYJDiSe*2a1&A7^$MH*)5btyiVu|jO;G(^yKdD EZwUe^6#xJL literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST b/internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST new file mode 100644 index 00000000..f4bafdf2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EXP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 203 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-EXP.TEST ;; ;; ;; Syntax: (EXP NUMBER) ;; ;; Function Description: ;; Returns E raised to the power NUMBER, ;; where E is the base of the natural logarithms. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test exp-test (LET ((TOL .0001)) (and (setq e 2.718282) (> TOL (ABS (- (exp 0) 1.0))) (> TOL (ABS (- (exp 0.5) (sqrt e)))) (> TOL (ABS (- (exp 1) e))) (> TOL (ABS (- (exp 2.1) (expt e 2.1)))) (> .001 (ABS (- (exp 7) (expt e 7))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..97023147c8b50c1fad89f3b90cc9ff2c8864ae7b GIT binary patch literal 1028 zcmah|TTc@~6h6DX(?S;FJqQa4Az9sO8&IeZFf3DOX?M%+Hh>Q%q%5|vP%Op77ziPi zr!`oJWLF_3zL^+fd_xR882^F#J4}3*I#aw( z9xW7ed2;CMBVs7h8;a|Euf3TstyUlO~0LZ{0-FyHXIKbL8 zIYGyoE=FSsEXpW}1*>A2UXqKL*05@s&0)S&SP=8ZJtI%knOg(~zvV~T8T zF{@0#+AteqvX~;Np%DzM_oo$Vov}=RC@l7hArVieblBZ?uaO{L(@5TB_v6goJiL4# zXD6C2G&3%$J)p~-JS#W7jngBYH7SxGCxhyPf9c!mrJZ_VHT!Gq-v($|^8}de-hoWc zUn^sedQHJ%9U1qc8f<}xjnESKYeby-i$RzXta;TX+Z97XbQ z0;}RsjA-N$O<r~c$5Aq^jUvi(kq?-1Nat0vM){%#H`Q1~J7 zEz4}zjl~k*xq>?R*=h0vX87Fvar08$O4qIO00(e$-N%iW5f6|oqxR~NR30GD2i6(( z(pt581l_f@wLGv2aCRFm4x-PbgK3oq$&SeUlxIo(zI^}2fn~a-greaTf!P`<))s4- z%p{pp&NC!nw(ANCML>TEST>12-5-1-EXPT.TEST ;; ;; ;; Syntax: (EXPT BASE-NUMBER POWER-NUMBER) ;; ;; Function Description: ;; Returns BASE-NUMBER raised to the power POWER-NUMBER. ;; If the BASE-NUMBER is of type RATIONAL and the POWER-NUMBER is ;; an integer, ;; the calculation will be exact and the result will be of type RATIONAL; ;; otherwise a floating-point approximation may result. ;; ;; When POWER-NUMBER is 0 (a zero of type integer), ;; then the result is always the value one in the type of BASE-NUMBER, ;; even if the BASE-NUMBER is zero (of any type). That is: ;; ;; (EXPT X 0) = (COERCE 1 (TYPE-OF X)) ;; ;; If the POWER-NUMBER is a zero of any other data type, ;; then the result is also the value one, in the type of the arguments ;; after the application of the contagion rules, with one exception: ;; it is an error if BASE-NUMBER is zero when the POWER-NUMBER ;; is a zero not of type integer. ;; ;; Implementations of EXPT are permitted to use different algorithms ;; for the cases of a rational POWER-NUMBER and a floating-point ;; POWER-NUMBER; the motivation is that in many cases greater accuracy ;; can be achieved for the case of a rational POWER-NUMBER. ;; For example, (EXPT PI 16) and (EXPT PI 16.0) may yield ;; slightly different results if the first case is computed by repeated squaring ;; and the second by the use of logarithms. Similarly, an implementation ;; might choose to compute (EXPT X 3/2) as if it had ;; been written (SQRT (EXPT X 3)), perhaps producing a more accurate ;; result than would (EXPT X 1.5). It is left to the implementor ;; to determine the best strategies. ;; ;; The result of EXPT can be a complex number, even when neither argument ;; is complex, if BASE-NUMBER is negative and POWER-NUMBER ;; is not an integer. The result is always the principal complex value. ;; Note that (EXPT -8 1/3) is not permitted to return -2; ;; while -2 is indeed one of the cube roots of -8, it is ;; not the principal cube root, which is a complex number ;; approximately equal to #C(0.5 1.73205). ;; ;; Argument(s): BASE-NUMBER - a number ;; POWER-NUMBER - a number ;; ;; Returns: a number ;; (do-test expt-test (flet ((closep (x y) (< (abs (- x y)) (* .00001 (/ (+ (abs x) (abs y)) 2))))) (and (= (expt 1233 0) 1) (= (expt 0 5) 0) (closep (expt 28.8 0) 1) (closep (expt -2 9) -512) (closep (expt 3 4) 81) (closep (expt 2 -1) 0.5) (closep (expt 10000 0.25) 10.0) (closep (expt (/ 3 4) 2) 0.5625)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..31064a098c81d399dc59b1c70de0dd335274dc9c GIT binary patch literal 771 zcmaiy&rcIU6vy9ge^5$GTB3;>%9@;|`Y)+oV)r^jH~Hedm11FKDS2^ntYkU>P=oVunFh!}1pGrUqX}vYTsBOK z8QG+oKk~hVWWkP2x$kB3Xwd26w)@;|hd6tEPyqZ7UZU(UT^JVgkCfL+%75>r4TiTQ z8d;;DCVsnw?uzfFa(P_9Ic(V5T)@e3{7G2G*XCJ8Io*ftZxwZC_GVUzwa%Ua%)OaP zDb3UGOzwYF-99xdqa)cI{mJd=IVY_&&+gc!zGr23Bn~DGg(Xd^SiZqFrExt*_T9{0CIH&B= z7y{+K)UW;J(1}ea?!ip7BxC7uD{4Gz8_uw1b)On#{B9Sb_#O;1jyI F_ysI8=2-v$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST new file mode 100644 index 00000000..7abd3f8a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ISQRT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 205 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-ISQRT.TEST ;; ;; ;; Syntax: (ISQRT INTEGER) ;; ;; Function Description: ;; Integer square root: the argument must be a non-negative integer, and the ;; result is the greatest integer less than or equal to the exact positive ;; square root of the argument. ;; For example: ;; ;; (ISQRT 9) => 3 ;; (ISQRT 12) => 3 ;; (ISQRT 300) => 17 ;; (ISQRT 325) => 18 ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test isqrt-test (and (equal (isqrt 9) 3) (equal (isqrt 0) 0) (equal (isqrt 99) 9) (equal (isqrt 1000) 31))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..52cb5ad4e4b0260040e77de15d80da06e4810557 GIT binary patch literal 1066 zcmah|-Afcv6hC+N)30e1qcE{S=xb=iT@+2Bb{wy|HqPjLu=>!0tYf>dy0Wf8L?W`( z%UG>TGL!k(TSN#!X6QrpC*8QS_jk_ko;l}t?vx=kDJ#63pIgZ0 z>;j)(DlRM)`PqDdU(7ER(l$R!{QM(X)A8dGNxs|BAFDO0BI$xXU9@L-bID$unSOYa zkKN*>g+ew*Hod(B#`?PBeO+B0wL_Aj9A*3OnRs7kPhV%eqxNuX195o(NW(r|Y5+J0 zfV=K+f{6`N97-x!RHZR2xMkOgl3qm1z`E-+#`$7?LCo0?>>O=pZV?cG`@)G1S*mO% zHPx-46;$s&cN&taI8IuVhA}YF<192ga-D`)T!I0{e?u%Asgmor?J1199YbXo;j zQwNh&3~@wK2NkS~14-ghhYf)V5|tYTSu*7jQOBmG6P09N=CCnkn0Smq|1wNX@ah5) z5#j)T;^95VctW>$;|knq`h#rVwZ#+BvHK z1|LbH@Q|jDNhXCKXd$wt>sYP25+0(lHzd}4+NUfT_~=VsT`$QJAd|i7T?|s{Hlaod z7HPrWIqKRZl#pK-MHO;?!Yci&Lg7>I5=+;2u5;P67mIxRveeGcPLn@ohR@C)U3ThQ zzEUV9RsiOGYnKuUfN9^Rd~5hNSxQvytzl}P^_K_*Zj|njQ>~?h_{+Mm0bD}*ete4( z2fu%E;5uPEVM)q3;WEBFZiR6jG)dkm6r}A*0|uZ-sps0aw}9MD8eezXWF1Q;7SG6{ aBu%VKis98!8fkpO(oF2Nz^m(rhkpR>!!j8F literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST b/internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST new file mode 100644 index 00000000..cd499f6b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOG ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 204 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-LOG.TEST ;; ;; ;; Syntax: (LOG NUMBER &OPTIONAL BASE) ;; ;; Function Description: ;; Returns the logarithm of NUMBER in the base BASE, ;; which defaults to E, the base of the natural logarithms. ;; For example: ;; ;; (LOG 8.0 2) => 3.0 ;; (LOG 100.0 10) => 2.0 ;; ;; The result of (LOG 8 2) may be either 3 or 3.0, depending on the ;; implementation. ;; ;; Note that LOG may return a complex result when given a non-complex ;; argument if the argument is negative. For example: ;; ;; (LOG -1.0) = (COMPLEX 0.0 (FLOAT PI 0.0)) ;; ;; ;; Argument(s): NUMBER - a number ;; BASE - a number ;; ;; Returns: a number ;; (do-test log-test (flet ((equalp (x y) (< (abs (- x y)) (* .00001 x)))) (and (setq e 2.718282) (equalp (log e) 1.0) (equalp (log (* e e)) 2.0) (equalp (log 100) 4.60517) (equalp (log 8.0 2) 3.0) (equalp (log 1000 10) 3.0) (equalp (log 81 3) 4.0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d9bef8514e11e5c0b9c68dc33da0496d59c56b0 GIT binary patch literal 769 zcmaiyT~8B16o$`kY3UbaA)1IWIw9d^;}Euifc3_4nSQa%!tAWbC26;|Nuf!S9c-x>5# zz1>B<_Mlt!P+jWirD=2eszl6<#fL`Pxe}>%y}iCyLt^0dYI`s4BjW)goo=%wH*0J1 zXyjLN`Q_!sbb&b5*zLb>a`~mzys@;HzC1lqv^D@#;UZd602;&~IPx`JP)FcG*`k<{ zO{xdOz)wmR>^hVO{!9+_+a28Uo_nnbXTJvuK=8p&7F=eEvdw~H<+YLx-uqK!hPNad zDN<0Azg;4CCGayw4zFMXJKJ2q=}F>ARK?fEc||!pfbDM;b!Ynaj1q62KLeP3GnrKy zXWyCJ{~T_-V?O|fjkm0#DpLSQjW0KMMl3R%1jqthG^?}2hStS1j zE)lkFQH~#%rNWAiu1-kk8QmnpEMZQC%Vp8#h&tiyI)ZMh%D*>+t%sS|WSEL2CFrzH zIk!2sU9sf~J(iLWvN~bAc%(aeD2X-WTH_{T0O3T`tyo2xBnmd)B%&B4GhNOpyE27P zS(W;YzZ@oU=-55XOsvaTD(WPTy8CBfqd`jN_^65nIim!Na#(ZWocbv6?+LHhNArhd z9@Y2cZ>*u_!T2LZ+Tnr{d=8FP>3!Galn9EirMJq0a$-4QCb}l`Y`eCg;Vt-tE-!xp DRGQ_v literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST b/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST new file mode 100644 index 00000000..8e273768 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SQRT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 205 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 17,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-SQRT.TEST ;; ;; ;; Syntax: (SQRT NUMBER) ;; ;; Function Description: ;; Returns the principal square root of NUMBER. ;; If the NUMBER is not complex but is negative, then the result ;; will be a complex number. ;; For example: ;; ;; (SQRT 9.0) => 3.0 ;; (SQRT -9.0) => #C(0.0 3.0) ;; ;; The result of (SQRT 9) may be either 3 or 3.0, depending on the ;; implementation. The result of (SQRT -9) may be either #C(0 3) ;; or #C(0.0 3.0). ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test sqrt-test (and (equalp (sqrt 9.0) 3.0) (equalp (sqrt 0) 0.0) (equalp (round (sqrt 399)) 20) (equalp (sqrt -9.0) #C(0.0 3.0)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a85443eb78b8bda8371571695c83553041b9a2bc GIT binary patch literal 767 zcmaiyTTc@~6vxkQFZ4=UqKO!z6B1rFPGcJyu)a7f(;Ley%+88DlCrf;3T=8ZF-Bs1 z@M(<}BH7jO9ehQMJottD26eU=CHUae%>2*H|D4}BGls}h-9UPGzt`?KebgNdd!r$0 zcKc}19rYUyYDyiw)J;xbRf)cydz4RDS0atRvpaP5kQh0Gz1l}P*i8Nl3|nUvBx z`_AP4=Xm`c`vEX+y=8S(Ndp|UzTDiNqR4OzAO&#IZp@8anRW)$i1*RGqv@Te{Tp=^OK<&KOTxn&RLCe zZgOneV$&8{C@vqQG{Sc9RJSx=0%!8q`Zf~+@WVl~LUm~pEt`CUh)R%5w>hWm$`E{I zS?V|ba_GdOm+pQtye4BY*+?Ap_RqMcW0b~`X%UNZLQxi^Fy{Sv^|9yP6V70W77ob* zYVOLvxQE&Ym)|JR4i^>gvv;gY>$^IqL{NM!yHOLA6T|Y8!8Ms@%Qgk|Z^0)tnfwAl C{N&gG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST new file mode 100644 index 00000000..ee89561e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ABS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 205 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 25,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ABS.TEST ;; ;; ;; Syntax: (ABS NUMBER) ;; ;; Function Description: ;; Returns the absolute value of the argument. ;; ;; For a non-complex number, ;; ;; (ABS X) = (IF (MINUSP X) (- X) X) ;; ;; and the result is always of the same type as the argument. ;; ;; For a complex number Z, the absolute value may be computed as ;; ;; (SQRT (+ (EXPT (REALPART Z) 2) (EXPT (IMAGPART Z) 2))) ;; ;; Implementation note: The careful implementor will not use this formula directly ;; for all complex numbers ;; but will instead handle very large or very small components specially ;; to avoid intermediate overflow or underflow. ;; For example: ;; ;; (ABS #C(3.0 -4.0)) => 5.0 ;; ;; The result of (ABS #C(3 4)) may be either 5 or 5.0, ;; depending on the implementation. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test abs-test (and (equal (abs -9) 9) (equal (abs 0) 0) (equal (abs 99) 99) (equal (abs -3.9E4) 39000.0) (equal (abs #C(3.0 -4.0)) 5.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..af7bfde0d3741de267fa6403307bd8848293eef9 GIT binary patch literal 1995 zcmbtVUrZZy9RJ-F7===})utTF6DRO=>u$KvXQ`7Nz;j)yzDm zv#>-sLY!Nr+96w0tc0#Px4AXW=iDqcBs3`rsma5X@U^>E&^qUo>U*QoSt%;Xif)p- zn~m2Ahy(;4gZV1^V3gawLOy*s%BMo109WHi+U-V~ZmB%N<+lkzyn&E|ud@#TZ@PZ0 zmCJ5V`pdc>$lo^9o4Ws7LN>DNx_^}CKxbpCHFXm8fnQ6A53J0l+sgO2l>;I0Eqfu< zrdq&ScCrb+LHIU<&q4JNXma$R-rNQJ_x0v%Xfg=Wx}OKVt;cEcvwP&H zBN{nc1ReL^Oo^!u$UWV8Ur%)&&03cOg-dmTwY6;J^Pdaf{7;1kYj1?0kmam^!}4+I zWLVL)!30i}G$Lz*DmA2m1R&b58Rl!4m#>C#4TKfhQbr_$TDAe>rnvK3V@{YB9pibB z2v!DKQK_uiNohzo#>_C|c<%4omL6vH9v?6oaV{ly6BOB`=Kc~OMuDz++HbkH4mCU^oU3d?U$#oEJ~06Ts_l#VBX zO9w&xIIx80F&WgfRSWPS;Qk7(LxE&Xp@5#K7#~ZjbR0I&07<7L^d4GVAM}n@;kLTl z$3sF@^s=nNDsq1SQG=zDEhK*jg8{{cXte{UfpN(D8F<0xt-^9u(r5L^{t{a0KdtE& zmc@kTsTAQ4K+C(I5EBra0jI~3a>7s(Cejyxt~IEvVhR9|KS8Mu8jygn=x)^z-^S3< z*n8~771lP#PRZakXi{rPGAG6cbXD3rPOq{qAKHEfD%D9tAJ&lim9^vJM+Dv0A@w~R zwHgg;;FjbY)`RF5=u5Lz^(q9@;AQ}R>?9K=S@&huGt7Eoto>!y=|$;ZoYE;Pvs4f} zR^<+HW(scpv^aaEa;_0uJq==H-TB11jln3-Uot?h` D@RV4S literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST new file mode 100644 index 00000000..66d70198 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ACOS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ACOS.TEST ;; ;; ;; Syntax: (ACOS NUMBER) ;; ;; Function Description: ;; ASIN returns the arc sine of the argument, and ACOS the arc cosine. ;; The result is in radians. The argument may be complex. ;; ;; The arc sine and arc cosine functions may be defined mathematically for ;; an argument X as follows: ;; ;; ;; Arc sine -I log (I X+SQRT(1-X2)) ;; Arc cosine -I log (X+I SQRT(1-X2)) ;; ;; Note that the result of either ASIN or ACOS may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group acos-setup :before (progn (setq acos-tolerance 0.001) (setq acos-test-cases '(0.0 0.1 0.3 0.7 0.99 -0.1 -0.3 -0.7 -0.99)) (setq complex-part #C(0.0 1.0)) (defun estimate-acos (x) (if (<= (abs x) 1.0) (- (* complex-part (log (+ x (* complex-part (sqrt (- 1 (expt x 2)))))))))) (defun acos-test (pairs) ; pairs: paired result (calulated vs correct) (cond ((zerop (car pairs))(zerop (cdr pairs))) (t (< (abs (- (car pairs) (cdr pairs))) acos-tolerance))))) (do-test acos-test (and (setq calculated-acos (mapcar #'acos acos-test-cases)) (setq correct-acos (mapcar #'realpart (mapcar #'estimate-acos acos-test-cases))) (setq calculated-expected (pairlis calculated-acos correct-acos)) (setq acos-test-result (mapcar #'acos-test calculated-expected)) (notany 'null acos-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0babd0979a2718e3d1b1d11a7d125ea983cbeab9 GIT binary patch literal 2078 zcmbtU-A^1<6u&bIbXi~-){Sjfgb@YF)}aEsg<`Zj3>R1#=5A+ZT}Vs_F1s!bbO|4R zL`8y|(1(pJqBysvFDAYiHIy_ljnwrc#+Uj=HSx(m!9-shJZBatsm7X^?9RRC^Zw4c zzkAk6<(Q_+T7GtJdL}b3=a&}emKNn~eqLV4FU_Yjau)RR8yYj|Tf?e0((z2E&pKjB z&u1nVGgGp?lv$XXeEli8^Q^4S%}>w3rneWw&c0|@UnJ7u8&oa5ob7=zU42jY^mU)@ z@a#fC0^XmQld(i zqH4?4b}u2dfMYuSMCm%Ydj!4k%K`eD z{|mBddn(nGYJ`*1ZQCi_-ge<_F#pyNU`VwcX+Un`1k?;o2tX4gw+WyKI4sCcv_U^E zu@lgQAhd%?BE)U&Lf)0!O71@w|L{K*4=|n&LB~ruiHJ4M2gSy)#*BeDGC~)MwQ18Eh3j-OQ>vyQ;%UCdfWn;{0VZU>x9ym{1IGk z@J3ud;g7xvse=}^2Ni34w4dq9!9-w?9NIk!ZKDTmJBCi*n1d+9GEsVH!`#(-+Hw6m`pP?03#b&IZ!3Ni!+XLboz4tG~#62k{!r0lS zF?_@Di;3m+j=OAM?)%vYQ(bV` z2!wRthLFwD1XSoz`>hvY6>-O!R*2+E@vQ{X$?%=t<{e}<{D)c=0!)FyPgLoMD!B6p4a#h>g F`wL||VXOcE literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST new file mode 100644 index 00000000..9d4d69a2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ACOSH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 29,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ACOSH.TEST ;; ;; ;; Syntax: (ACOSH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (acosh-setup :before (progn (setq acosh-tolerance 0.00001) (setq acosh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-acosh (x) (log (+ x (* (+ x 1.0) (sqrt (/ (- x 1.0) (+ x 1.0))))))) (setq correct-acosh (mapcar #'compute-acosh acosh-test-cases)) (defun acosh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (abs(realpart (car pairs))) (abs(realpart (cdr pairs)))) (realpart (cdr pairs)))) acosh-tolerance) (< (abs (/ (- (abs(imagpart (car pairs))) (abs(imagpart (cdr pairs)))) (imagpart (cdr pairs)))) acosh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) acosh-tolerance)))))) (do-test acosh-test (and (setq calculated-acosh (mapcar #'acosh acosh-test-cases)) (setq acosh-pairs (pairlis calculated-acosh correct-acosh)) (or (equal calculated-acosh correct-acosh) (notany 'null (mapcar #'acosh-test acosh-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c127ce2a01eee25a07fb949c278f9a02b0d46953 GIT binary patch literal 1995 zcmbtVUrZZy9RJ-FSbw_(I&QiLW!hY>RI`_~?Vi#m9-??-dw96E%b!ci+$V|KFBK z^|+#nN`8J}HkVlx^DD~>E6d_ceo6XeXRDOpL#2W}X{5g9caNqS4 ztz33z(p%QOK>k)zZ|dIf2q|SZbnht7flg_=HFXO0f$t{716F3!ZRNY%>Y)($mi-Xi zsTQ!7o%F%uho>1V-@2juwu8EtgX$sRvvt4T+y(p(^yX|}(ht(Qmj}J=M``i%yX2>1 z8aZAB9rxZ!iK!0AJ>7XvPjw#8T9*xlOLc*@^=#$uKNr6Fp9&Aw-V8t?%UJ=3<&)y6 zkfLjYahxb=MAimXYDfcdK(t{q#MiJ|z8c20DWu4jG9nq&N*XY3iZib@=7ed{F`fqr ze`TN*mC9N&Ar0xqm>FUm&;4E7(nGA?MuDoItg=%6$3OmH=!C@jB06>A^!0e13`C>>7# zmkxsXNni=jV=}0jR4u^$fO{*r4h51mg#!9Q#rRl4rQ@)H21wdPA$(+UJc+CKgk3WCRy+@>mFv^QP%zn>#RlTU+m&(E3>pL zcC5)A;>;A>{AqFaO66Q5wsr=@$cFu?y@|uxra-=s+mU*zaSNKOnyenhAjnHe-J&eG zXcv2;0~8uXE4SGBfmuFqxbJDr-1FUYaf^F#F2?PCJQw44g%}s(AH&imo;}6$&sywa zAU8Gt_Vg46d30dl&~whfz|7cCJ?NCl2@sA;9xx$`$QIWb18aCdpO&)1Tq2fu@@_20 z!=Ry;NANs(>^N%uAC9>3sy1|@>casnzIn;8n(+hn!{XU%gsU#}uY=FvMgjg4hiJDq zYb(^nhY!CmyusM*LVs^>Z=wI%!WV@Hh<$@t8L={8fkO0#FJI*}f=N(j*29A2wz9kX E7mhDj!~g&Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST new file mode 100644 index 00000000..21168b9b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASIN ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ASIN.TEST ;; ;; ;; Syntax: (ASIN NUMBER) ;; ;; Function Description: ;; ASIN returns the arc sine of the argument, and ACOS the arc cosine. ;; The result is in radians. The argument may be complex. ;; ;; The arc sine and arc cosine functions may be defined mathematically for ;; an argument X as follows: ;; ;; ;; Arc sine -I log (I X+SQRT(1-X2)) ;; Arc cosine -I log (X+I SQRT(1-X2)) ;; ;; Note that the result of either ASIN or ACOS may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group asin-setup :before (progn (setq asin-tolerance 0.001) (setq asin-test-cases '(0.0 0.1 0.3 0.7 0.99 -0.1 -0.3 -0.7 -0.99)) (setq complex-part #C(0.0 1.0)) (defun estimate-asin (x) (if (<= (abs x) 1.0) (- (* complex-part (log (+ (* x complex-part) (sqrt (- 1 (expt x 2))))))))) (defun asin-test (pairs) ; pairs: paired result (calulated vs correct) (cond ((zerop (car pairs))(zerop (cdr pairs))) (t (< (abs (- (car pairs) (cdr pairs))) asin-tolerance))))) (do-test asin-test (and (setq calculated-asin (mapcar #'asin asin-test-cases)) (setq correct-asin (mapcar #'realpart (mapcar #'estimate-asin asin-test-cases))) (setq calculated-expected (pairlis calculated-asin correct-asin)) (setq asin-test-result (mapcar #'asin-test calculated-expected)) (notany 'null asin-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..56d9b955686e934a33b6fcf50d74f8f121ace6ba GIT binary patch literal 2052 zcmbtU+fO4^7(X-RTA(}B#$_wQh=QaztUy^1quXIPl*%xtJ2SOxVnVRAmK7Gl#Y zYov5k(`9XDdUkRuJtxmBF3c`2$eEcrd46VbE|r!upqJm!m`UFnQnlgsr#rmX2}^1& zJ-(2hknP3v{KWX{Pskll$?ELf

ardqM2z>+b9ehugh_s-+jR-8ZJQ@5$c2j^1|f z{>=?RnjwUwNCB5hLL}lL&U<+&WK+vl24gx^40VKtoHZw30ktRzi<(Zpwo_i1nN_CJ zucW82oauQY5aQg(R}3Z$&5kj{Sr?XtYUg^sCT1vcC{2x0B32w^!R&&QukPqnx|L2v zwPMB)xw+w8Aw>AGRuU1-SJ|Cm;m%d^>)l~7DFHM-}i*9WmlPRSQOyYwXJi>CPV=C3PP#@$7JfU!Yy*|1bX3@L-bYu z7i7csM6w}S4=1Nuwv)Ksb>Xcu-&PbbBwJ22AUjqEHA55p&;-eC0x0|r3$VHt=*Kly z2Tce-JD4Ow+}0lCUCu6N|8wyV{!{S)uMcU=7>FSwlp)m^(5b2P z$3SC5t&mv8E5%ZvTWv^FZEZ*~shu!^E}F}?GV8Ks(-Bbwk3f--nodr`(#k1pT%(NhF090oV;4o-{YG{;8 zPG0IbHAr5d5--8&@!>Fh3rCjF=T#kr+aQ!->8g$5Ey!7`B>=y1VpO?+wvWLUIBq>w zUj)dj(EKV~jj!2YHUfv?i|Q2BHbm7NH;qfEY=l$Gu?{_EflU4cxzu$+=}Z0)F1L9- zE}!s+--Ofwi`s*Vb$O(p>B`}Yz#uuadj#4>58Ha4H&sKNu!A|{CW{&~H~5qo2_1C=8*BMloglL9T2Q=QdgHe9K0@hWr! z)Rz*>rp0qVck=Ch{S>Z^7GFyD`Cm9X^zgJL>)`zM*EWRAm58wa{*{QhFGWOncD88* zXBd7FvAF*1ZeVCZjNkiXyXig-QdWux5fQ?UV(_i!XPta-YJB>|iE*s^G#lYn7hE<1 zAsx6OWV18|6?)Wu>jhZF=JPra$9VT32o+|4hv@o+2eZbmco zPDgVi57+aavpgK&J%Sf3&#N`PO0SkB=Zzh`q`}=CML>TEST>12-5-2-ASINH.TEST ;; ;; ;; Syntax: (ASINH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group asinh-setup :before (progn (setq asinh-tolerance 0.00001) (setq asinh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-asinh (x) (log (+ x (sqrt (+ 1 (expt x 2)))))) (setq correct-asinh (mapcar #'compute-asinh asinh-test-cases)) (defun asinh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (abs(realpart (car pairs))) (abs(realpart (cdr pairs)))) (realpart (cdr pairs)))) asinh-tolerance) (< (abs (/ (- (abs(imagpart (car pairs))) (abs(imagpart (cdr pairs)))) (imagpart (cdr pairs)))) asinh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) asinh-tolerance))))) (do-test asinh-test (and (setq calculated-asinh (mapcar #'asinh asinh-test-cases)) (setq asinh-pairs (pairlis calculated-asinh correct-asinh)) (or (equal calculated-asinh correct-asinh) (notany 'null (mapcar #'asinh-test asinh-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7d003a92bfb93de5e1fb642dd8057631901642f0 GIT binary patch literal 1872 zcma)6PfXiZ7=KP61PH-lDQnZNGm-j7*-S$y6Jwgd7(-l)o!QPPCq^M@$bcXSlcuQ% zwb8bNrIyjPest9ilU8Xb)*UvqPC@Ev(t6mmL#3W3P1W;W-@m7j(^qemkl#^+=jbuyidlrIy4KocS5=?B2H zT&+98Ev&Vk2KlF2Yc4V#25l|q0lSUgCpjAe zjdBoqCHKEmY<*FR;O9aFLY8wZHt}=oL`>Aw0U0~ZCk1stk#xRa21Fe)Vjdr@_te4| zLorb>#U!swW?F|ah|U~+#+YGBBOVWEgxx`liX^D%6hElxBSwre9_FyMsl{lcH$dyX z4IpgBneon+h=L&*)dfMw8-&3JW0J0GI>NtcYY zVp7%{0zByA8k8oeqC{ESVml73UBE{Ot-)Pu!rh5L*c$0wK|!Vg7#|iSn8-GP%aEAX zbxGZ~*pvYo`3Gd-XAQ-I+$1TkB>4>*9z3OLQ1KXVK#LU#;d@}!Bqk+s*jZr8=IOD^ zG;)z1KL-Y3Lox?>V{D{fQ~14G;cWO3NUS!cYeOpLRR><`t1X}`dVY!;PM47T3+|Oq z#X_(y@|Z^Pc!ag8X+@dBG#m#IF`c692yGjn(JmT2OJAu2RmN*uubP>~A{Sj2qFiAIQSucwncsGi`$t`9 z`;K$s9o^YxbGr(amE3bUnBA1~JK*X5@qPO1RoXSJ>?$3w-FboW;kY}P+2OzrjDdF( z-r0UWDqLFIip)&RUYeS~z8~CT56sBfVpwF`s!0j59>5;`fg{GrBJ-HW@z`>Yd+zat zdt9UO_i22b#)oM99F3o$@i2{(der~3RQ|d72~rP%3fx5Mn=1BYX-jscAD8;%(DGcV z7ql+{-TdSN&@V+3&Y!f|Ykrt~39Lz}cMINnV0ypKW=p-_b#^)oN>J=D0G7(xY_@8% u$COt<4Sy&pTfaQ2+LSxNrkB$7NU8hR?_aKQHjCML>TEST>12-5-2-ATAN.TEST ;; ;; ;; Syntax: (ATAN X &OPTIONAL Y) ;; ;; Function Description: ;; An arc tangent is calculated and the result is returned in radians. ;; ;; With two arguments Y and X, neither argument may be complex. ;; The result is the arc tangent of the quantity Y/X. ;; The signs of Y and X are used to derive quadrant ;; information; moreover, X may be zero provided ;; Y is not zero. The value of ATAN is always between ;; - (exclusive) and  (inclusive). ;; The following table details various special cases. ;; ;; ;; ;; ;; Condition Cartesian locus Range of result ;; Y = 0 X > 0 Positive X-axis 0 ;; Y > 0 ;; X > 0 Quadrant I 0 < result < /2 ;; Y > 0 X = 0 Positive Y-axis /2 ;; Y > 0 X < 0 ;; Quadrant II /2 < result <  ;; Y = 0 X < 0 Negative X-axis  ;; Y < 0 X < 0 Quadrant III ;; - < result < -/2 ;; Y < 0 X = 0 Negative Y-axis -/2 ;; Y < 0 X > 0 Quadrant IV ;; -/2 < result < 0 ;; Y = 0 X = 0 Origin error ;; ;; ;; ;; With only one argument Y, the argument may be complex. ;; The result is the arc tangent of Y, which may be defined by ;; the following formula: ;; ;; ;; Arc tangent -I log ((1+I Y) SQRT(1/(1+Y2))) ;; ;; Implementation note: This formula is mathematically correct, assuming ;; completely accurate computation. It may be a terrible method for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formula given above is not necessarily ;; the simplest one for real-valued computations, either; it is chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; For a non-complex argument Y, the result is non-complex and lies between ;; -/2 and /2 (both exclusive). ;; ;; ;; Compatibility note: Maclisp has a function called ATAN whose ;; range is from 0 to 2. Almost every other programming language ;; (ANSI Fortran, IBM PL1, Interlisp) has a two-argument arc tangent ;; function with range - to . ;; Zetalisp provides two two-argument ;; arc tangent functions, ATAN (compatible with Maclisp) ;; and ATAN2 (compatible with all others). ;; ;; Common Lisp makes two-argument ATAN the standard one ;; with range - to . Observe that this makes ;; the one-argument and two-argument versions of ATAN compatible ;; in the sense that the branch cuts do not fall in different places. ;; The Interlisp one-argument function ARCTAN has a range ;; from 0 to , while nearly every other programming language ;; provides the range -/2 to /2 for ;; one-argument arc tangent! ;; Nevertheless, since Interlisp uses the standard two-argument ;; version of arc tangent, its branch cuts are inconsistent anyway. ;; ;; Argument(s): X - a number ;; Y - a number ;; ;; Returns: a number ;; (do-test-group (atan-setup :before (progn (setq atan-tolerance 0.0001) (setq atan-test-cases '((0.0 1.5) ; y=0 x>0 (1.3 1.4) ; y>0 x>0 (0.5 0.0) ; y>0 x=0 (1.4 -0.9) ; y>0 x<0 (0.0 -0.9) ; y=0 x<0 (-1.0 -1.0) ; y<0 x<0 (-1.1 0.0) ; y<0 x=0 (-0.7 1.2) ; y<0 x>0 )) (defun check-atan (pair) (let ( (y (car pair)) (x (cadr pair) )) (cond (( and (= y 0) (> x 0)) (= (atan y x) 0)) (( and (> y 0) (> x 0)) (and (> (atan y x) 0)(< (atan y x) (+ (/ pi 2) 0.0001)))) (( and (> y 0) (= x 0)) (< (atan y x) (+ (/ pi 2) 0.0001))) (( and (> y 0) (< x 0)) (and (< (atan y x) pi)(> (atan y x) (/ pi 2) ))) (( and (= y 0) (< x 0)) (< (atan y x) (+ pi 0.0001))) (( and (< y 0) (< x 0)) (and (> (atan y x)(- pi ))(< (atan y x) (- (/ pi 2) )))) (( and (< y 0) (= x 0)) (< (atan y x)(+ (/ (- pi) 2) 0.0001))) (( and (< y 0) (> x 0)) (and (< (atan y x) 0)(> (atan y x) (-(/ pi 2)) ))) (t nil)))) )) (do-test atan-test (and (setq atan-test-result (mapcar #'check-atan atan-test-cases)) (notany 'null atan-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7a4bd970bb4daab086907e067f912b0a260360aa GIT binary patch literal 2648 zcmbtVPiz!b7=JTc`e(N+({+W?6c}n-o29dM7n;;9wL6_ow`*tTEidojM%^?aM%QDwa&wEQ4_BP6B8o1B${}^cn~mn(u*e#8ZTb3e&0-iT8Nl5?aueU zKkxUxzwa%R9ixgSD#eqt(=)j_vADP}ySO0ci*w?9adB=kC+0yezO7J0eP>u!M#8-j zuenJxIhUJQ$W4jXVs3tF;;l|G@}elu&P~t2qNfMgNUS>=J8~rK9gf*zc8vkfoZIG?dg-NtaV<$X>R~wGfMxF;&AZH$=sS z;;b~2dm}f4;hdZ&93l3_a_vw?SF9w}?GimGHG2D2UG4<@!ie z>XxFCY{~jCxx5-ULkRy{gTSLVUly*9aMw<8i#JC2?Ea<(uG(=m>bN@Dc4oF3TqwI&p|*a5NsNt!FJG}r@=zgcmS-apND;Gw| zo3;nmQpq-N521ClJJZ*}x4@a2eO%!hz*0Z3zb|VSsQ+t1mJ8>oe}w12@8z|<*>;Qp z^tFW4LnPCa9hEEGhno`Vseh12-*&?ceSC%7-)^Lx0P;mPlx=|kCd0sdmhH^8BGUzo z4WVSi+sY+CIZ0cg{rt=^}!^LjWjIlgPLkc14)qR2{Xi3 zvpRkU%w$7Iku7CdGE^&Lz)UI5P*$5`rlqEM9xQ_H)GC@P>zTAPM2(agVjRyszT2W9 z=JR+#5paf2a^_u;P1Tel4~HFv9{&@KqD=7YVs#z?v2lDiBcQSY6uaPJGgQTL2V9DP zIPka_t)GFL!XHu%gBlXeSm}%v@&v)OJ|yd7k|W1ZJkNqGpvan%(PT><+yuP)i5kS- z0~)UzWm--e5FiK}w+hj6F9>&SsRo;N_8gnmO$le9a1|bGpbI{#J*MA{mHAL@LvQ%obPDMmlT7FaO-1n{ z?ArOLYD_?3l0Ao{owWkt{stdvFjy^VBL4?#L-GxXcQ`wddzZB%8DJukes&N^7i&RM z14jo<)f$q_vD5(7qzCspD9KOYfLEa@sFLbd!100Dtm94g{0JrkJHiXL{4aQ9+Mo#? zxgQ+&`0FTiii*O|;oYd#F=0;rK4qOKJ&rJXMss8}Oad8q6b|;ek%MoUv~w)i#txyf z+1bZ=T|!vv>#U;=k-oRf2dv!ug4l9eZV~en@Z?U3)2H0m5@n~I=hiN{fePN zb4gnYqa`iq2+d?ZG=l(+WvHdPXZP6UaBM(@s;lmE=)Ca@4-b8C+G%s+{4jd#S>^I4 z;@tZCC*u6N5a;1izpBRZE`t9!@6tQY0xln5)A#?p+VT_wp&-P$I1k$%?!iZ$HQVK; znTeCHPEBC!TN@glZ_a6G=xG}YhI1l}LzEtQz;+n79y6@ntT%vbbu?`ekFV6fL`aSE<(x0+ zuvdH~IG&VVV(e0>A6IBpipSwo$>;N>%HhL@OJAY(#;sf5opaS_eXdkNOVl5=3y$ HvcCQg!9fl7 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST new file mode 100644 index 00000000..fb1a2e6c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ATANH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 29,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ATANH.TEST ;; ;; ;; Syntax: (ATANH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group atanh-setup :before (progn (setq atanh-tolerance 0.001) (setq atanh-test-cases-1 '(0.1 0.3 0.5 1.0001 3.0 7.0 -1.0001 -1.7 -3.0 -7.77 #C(1.0 0.3) #C(-1.0 0.9) #C(-1.0 -2.0))) (setq tanh-test-cases-2 '(0.0 0.3 0.5 1.0 3.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 -0.7) )) (setq atanh-test-cases-2 (mapcar #'tanh tanh-test-cases-2)) ;; ROACH 20-AUG-86 Don't use the ATANH formula on page 209 ;; of the silver book. IT'S WRONG! Below is the correct formula. (defun compute-atanh (x) (log (* (+ 1.0 x) (sqrt (/ 1.0 (- 1.0 (expt x 2))))))) (setq correct-atanh-1 (mapcar #'compute-atanh atanh-test-cases-1)) (setq correct-atanh-2 (mapcar #'compute-atanh atanh-test-cases-2)) (defun atanh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (abs(realpart (car pairs))) (abs(realpart (cdr pairs)))) (realpart (cdr pairs)))) atanh-tolerance) (< (abs (/ (- (abs(imagpart (car pairs))) (abs(imagpart (cdr pairs)))) (imagpart (cdr pairs)))) atanh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) atanh-tolerance))))) (do-test atanh-test (and (setq calculated-atanh-1 (mapcar #'atanh atanh-test-cases-1)) (setq calculated-atanh-2 (mapcar #'atanh atanh-test-cases-2)) (setq atanh-pairs-1 (pairlis calculated-atanh-1 correct-atanh-1)) (setq atanh-pairs-2 (pairlis calculated-atanh-2 correct-atanh-2)) (or (notany 'null (mapcar #'atanh-test atanh-pairs-1)) (notany 'null (mapcar #'atanh-test atanh-pairs-2))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2e4e2164fa9a901d92903d7684b8d41389dea913 GIT binary patch literal 2111 zcmcH)%}*Rv{LKt3%L3ckWkuN{j3^(ObZD0r3QG(O!vj`^dF#xq3nzlh;*vlie3%#` zA+^yaZfud*%(Ll#;DHho)3jz|jPc^3hkEet(L)mwFUH{SH_Mk;(_TEx{NC^T`@L;a zIc1oNvAndhu$W&}mN(W{HrAE-Ed1Ez~SLT7Pd}uJ6el)Hd6I}y|kaLQYTg}g| z=jRl6BfmB``@sbz(XZ$$s|$;8=<5SCk?iSCUb)g08r2=MZ0)%^-N{S+$wY5g=-}QR zL0%?=k zbe7hLK!|s{7#z)5hMQuRw~lI{!ED%ZR>mu=2ALD;$Wy(}Jo_H)}|;oUJvAlrVb4+Sis484d#FJ!+L zK!|!Q#v0n8EjL*M^dbgbVX_E%yHCLGR$;5~!j)@yR^=d!x8l&YQb8tSt@mZINi~=? zlEPWk#&v7Nq_#Gk0*W=}sA7OuiF`t&K8!(owk}3jfx2naXRV5HP|p(VD+PhVD@3czci}g+ZVOR^FzDi=)qF>71{l zn?}aeT{?0|m3g%kffWj?)V7(ev5cF}xT+Kd=~`8{rZu0A;YjsBt2a(8(5W<-rz2oI z2CR@D5Q8Gn@@iSd17M$iO;v zNpJyq&A^MDlpgahhskSzE$l;U!fh6FF?hE;5Ys%f`{NC=1_N3bEYSUnW-IJNyz*hjT&q+ZPF>kKSQGs z2A)6h9WZBv$1zl~5Ae#g&Bl-`s=Nh3Jre!0BUT4jUckb-V3~wJc_)JVAX8ywOr(*g zkXbcm1|enAern`b-hr&gzBu{548GwlRX`Qny<&@-Ut3pNH}zI!eimMcIc4Em`Ep0v zW*a&Yyu02G4rsGsQy3cUOwG-d3(YniUV~x~^xGNc(z4^_Q;Ey6qqX#{JA#mz?Aqhzzb}j=H+b-fr22+#zSX#GTmG`yrzVp2I z6@K+4WI#zwWSryub-Z7Y`0Iqc=Iw-TKpw=~kw8Ych=$Us0H8d{2c$zN`tVRj6^|H5 z9jxR70X}dfzz3@UKfx;gAuI8LV^h9n*@17T=1^}C%*StB?fCKQ3csEF0yK+jyn}q@ H931=&=f!Tj literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST new file mode 100644 index 00000000..a55eb7ca --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CIS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 29,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-CIS.TEST ;; ;; ;; Syntax: (CIS RADIANS) ;; ;; Function Description: ;; This computes E^i*^radians. ;; The name CIS means ``cos + I sin,'' because ;; E^iq = cos q + I sin q. ;; The argument is in ;; radians and may be any non-complex number. The result is a complex ;; number whose real part is the cosine of the argument and whose imaginary ;; part is the sine. Put another way, the result is a complex number whose ;; phase is the equal to the argument (mod 2Sail) ;; and whose magnitude is unity. ;; Implementation note: Often it is cheaper to calculate the sine and cosine ;; of a single angle together than to perform two disjoint calculations. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; (do-test-group cis-setup :before (progn (setq cis-tolerance 0.00001) (setq cis-test-cases '(0.0 (/ PI 6) (/ PI 3) (/ PI 2) (/(* 2 PI) 3) (/(* 5 PI) 6) PI (/(* 7 PI) 6) (/(* 4 PI) 3)(/(* 3 PI) 2) (/(* 5 PI) 3) (/(* 11 PI) 6) (* 2 PI))) (setq correct-cis (mapcar #'(lambda (x) (complex (cos x) (sin x))) (mapcar #'eval cis-test-cases))) (defun cis-test (pairs) ; pairs: paired result (calulated vs correct) (cond ((and (complexp (car pairs)) (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs)))(realpart (cdr pairs)))) cis-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs)))(imagpart (cdr pairs)))) cis-tolerance))t)))) (do-test cis-test (and (setq calculated-cis (mapcar #'cis (mapcar #'eval cis-test-cases))) (setq calculated-expected (pairlis calculated-cis correct-cis)) (or (equal calculated-cis correct-cis) (notany 'null (mapcar #'cis-test calculated-expected)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1500e6ca8e9b081cd8d6f5e6f2bb0a6f725a75f0 GIT binary patch literal 2252 zcmbtV+e;i*7(Zvm%ev~i>Q;;~W|SD0F{9PyYMaDyJZ86!Gn=_|4K0XSH(66}^-?Hl zgCs)xur%42$efnEgg)lM1PYa=Y@rnTP$-m^Lg^n-=yS2(H@j=sw9tYqXV0A9_xrBr zJLlv`<)o%d+T#4u>|A855{?1Px9jrYAe5VXrA zspa(aYI;U;*3v68)9;;-2F^+9((>#ae4ITC%YmU&gF`1z_65gOTQ6AqPo2S`m(LBo za;7i1`)G@X7YQLLlEl;-=wk(sf$r-Obj=4J84osh1cL0!1rmoqE~&fkEYz zGN@>#O&)E9ZxbTC*%%fumM=5U$LY=j`RuE4A=%c}NUQunPxyhRq{7sdzfK6^^@QYS zpTnZ*cJ*PJ*_jIE%@8bq&*^u~&^LtSG9Q|uae)Fcw|ywtj!Ga85K@P#sgC?p`b(K# zT3PZN02&k~H@lws-ws;-%|V%U;bzHtO;UnbGgA>5EihUk?t6F4$ad5WQE-bu#4}sW z*5e@m$ZXBDO|<~q3<;pO{nLSzQ^y`ZC6AL`2QzZ~*;~nD$>UJjRP>pdj2_II>_NSg zGFV&B6n+P*I#_$X4GNjhgo#k&J0se(*g%~DOn(EdK&fyX1E4$LvpS*1Ej@1I`eWXXQygFs znD|}iL*z$(1Xkn+-htEC{3uQjG2{``HAWNf@FNSnV~QU=4bCGrbH)_=%EXANE2W#y zzs3@vQJJvJO9to*BfJx*UIhIO##I+wmsJMV!7ocQk0L4nr^0Y`#K`xMNkbwI_oD%~ zF`JCr&P6{V@;UE8!V_PKJSt50L03q`-v+H3%pan26THdcJ>xw38jtq#&U*B5!OI?X z(krV{*DbY6x;71O(2O*@PbtmVHm}O)p;KXc|Y&D?q&OiMi^{7E4&!~Gq}1JM#=vzyBJa5;1=z^F-&*A zh~;8;ZVU^%5AZKMOoxS^hXv>`IM$c{`~#jW$`5(jwz=u~t25J>$cybrDWQHlLPvVA zFVG0K&;cQf>WF<9tJd8Q2}ixn;Ks#uc*r(I0BL_AuL}FJ<%q(@MWAfJARBr3E6At< zTz(#Nya1H^x-a1BeiU_J5Z}Z;5qj$cx9F0e=eCML>TEST>12-5-2-COS.TEST ;; ;; ;; Syntax: (COS RADIANS) ;; ;; Function Description: ;; SIN returns the sine of the argument, COS the cosine, ;; and TAN the tangent. The argument is in radians. ;; The argument may be complex. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; (do-test-group (cos-setup :before (progn (setq cos-tolerance 0.00001) (setq cos-test-cases '(0 (/ PI 6) (/ PI 3) (/ PI 2) (/(* 2 PI) 3) (/(* 5 PI) 6) PI (/(* 7 PI) 6) (/(* 4 PI) 3)(/(* 3 PI) 2) (/(* 5 PI) 3) (/(* 11 PI) 6) (* 2 PI))) (setq expected-value '(1.0 (/(sqrt 3) 2) 0.5 0.0 -0.5 (-(/(sqrt 3) 2)) -1.0 (-(/(sqrt 3) 2)) -0.5 0.0 0.5 (/(sqrt 3) 2) 1.0)) (defun cos-test (pairs) ; pairs: paired result (calulated vs result) (cond ((or (zerop (car pairs)) (zerop (cdr pairs))) (zerop (cdr pairs))) (t (< (abs (/ (- (car pairs) (cdr pairs)) (cdr pairs))) cos-tolerance)))) )) (do-test pi-const-exist? (and (boundp 'pi) (numberp pi))) (do-test cos-test (and (setq calculated-result (mapcar #'cos (mapcar #'eval cos-test-cases))) (setq expected-result (mapcar #'eval expected-value)) (setq calculated-expected (pairlis calculated-result expected-result)) (setq test-result (mapcar #'cos-test calculated-expected)) (notany 'null test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d7190ef6d86e3ba16da73a364830b42c8ea433e GIT binary patch literal 2015 zcmbtU+i%-c7(aHlE=^j`4H4TySWTg!%5X=sX5EU$;(DiTsN)lCXXzeLRnnAn>ei}F zxd<3liL^aLY@wp_8QKdHF9=XqO+phJ;UdJ#cEf%!X-wzbJP`&GMVm@IN@ycEG?G)bMlY=Rq_Dig$PurEwtCVa+^cP)i+1 z1IHY)<6;wU7I(w6wZ(PK(T7!wIynobMfb+7$v$H{G$V?j5pK+*Zcxq4Wz|7uW$ZW? zMB&fY4vX`kF93qQI994R$hu}zdwYhF<&!|81syB6FN7}Qnt4X`_=w2&2=H3Hz*#MA+2Aw`9H{|?LH?SlQ!cwz zx#yuL6o4t>yYSse_zu2-fV=2v%|PNN5KWl1<{)_kT(;>sz;5n%q+CGRM<5G7s5)le zfX9Os(HI!Tt;3y1l@yK7-<`5@;f3z9VEWskKu8XNAdWW zKmHat4%^fjRP8gF0cNOMn}C69D0Bu&MmH;Zn0K^*nQ$9C?#^0l$VBRM-j2srWO@Zf z>OEL0O(tgU72+KpLv9kGm^lM^1gp^~IfTz;J@Dij??hS6(+FL{=}`e zJH`33(s4oSP$tJ=2Tv$d=Ns!2c^5p}Z`}{wWt_f)x&_>+P+-i6K0EL#(#(wmcetA3SR_&ri6{FDR2F4$SDyP&f4)5 zzTT7wzkA*v9xB|k_kUZ9{;fzZ$tfWvg2A>nE_S}ptwyHD&%Hb`j_E!;fUv>^ZvbHi zUFZwWZ_8;&%%=_5Hk@MTVV(D;c=7}g{&Yqg%4(L=$B!oX(JtQG$&(!@fMOXai1NOD zyibsUw+H)g&{4r(Ik^aJIkZATDM;gN>K^>prxB-2{uv!K?g2Vs)F<(zA6)zBXjbGW z!08k2a-aeysXWj5waQ7nVYEsrg}-0mSD&1mtkjPjIa2uwRqouq`{Tui4w_u7)ID|3 f+`N8G2#Hksp8o#RUEVP8IJBA{;+^E$z{bWOS1?jz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST new file mode 100644 index 00000000..4aefbaac --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST @@ -0,0 +1 @@ + ;; Function To Be Tested: COSH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 29,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-COSH.TEST ;; ;; ;; Syntax: (COSH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (cosh-setup :before (progn (setq cosh-tolerance 0.00001) (setq cosh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-cosh (x) (/ (+ (exp x) (exp (- x))) 2)) (setq correct-cosh (mapcar #'compute-cosh cosh-test-cases)) (defun cosh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (= (cdr pairs) 1.0)) ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) cosh-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) cosh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) cosh-tolerance)))))) (do-test cosh-test (and (setq calculated-cosh (mapcar #'cosh cosh-test-cases)) (setq cosh-pairs (pairlis calculated-cosh correct-cosh)) (or (equal calculated-cosh correct-cosh) (notany 'null (mapcar #'cosh-test cosh-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4695723c336a7279a114c6ab1a5576fd239d87ac GIT binary patch literal 2300 zcmbtVO>7%g5PrK(QpZl5wQEXi(qwVlG?;FRLklGw>dj`IxLNNryKCHDh=Su{M@bXq zhaUk|)LLpKj9L?j_E9PU5*Nh5?TLyOS0HZ5t*8gia0MwhBxGjRj%yXfk7{f8y_q*} z=9_unye*UV(~2f43-gPGx!jVtu)4Cix+0!kSQ3{PR+q9l@hs@Yw-sur?@q|d}(~{x|O_g*xsYdLwU2;P%Qrc7vyW}4h zR~8nfx!miyIZS7MnQ(;IS4-}AT34(D)$Mg|jq9?nl)4kTl!Dacah34yh8OhC*`==N zuykA+mQoY4sgmm(o(qKV{eFQ*G~eWJPja`;k)Q8O@)L6CDg>JbXm9}5FVkQ?G!+1A>f>QwWwH=A4?$9qzPFc(^NwmO@KxpHzRxp>*U*k#{P&RTgrrFs8-ql8Y&KtJIphtr6zeE zEP{2SE1D|n>68?wM$(Khj_3Zm+oBQXb$PHm9KK3UizvWcv)LV}a{0i-11)W+idCmJ z6I?yGPmwhxt;v=;*3=8E)8&UY@kLa_poT=#Rw`{pTmi7}ipcsI$#x#+*yCg&(YETdGlC@!1`mxFOLC7}sWm!W3+q45ymn{@K!KYtI z1Ae{b3Sb%+lvVos>aWW6#HWHR0`IRfx@VZvI%1Y1%Ax!uVbrSI4iI8<3L4i&Z^hf9DXXsT9R zGS4JOsV41QOYg7)6hguAB%#de&M_Qi2Yj%P4?3<5I7?D zKgbSt!Wz)D)NkdMSH$pnIV_%?hA+m9SU6X|>`{0A5W3j1ui5KJ=|06!fnw4_r=%q; zpoeBMFPcFPFQuua*28~omxe}0RiJ=czs;Rb)JikxPPFr8BmNLZytqN;V{j4PjKrWd z@uu6pxxYCr=LMWUE0zmuc@PQ$C}y`eP&r!@W@Fo|X$w+qXQ8RQ-kddd6T1|eo1TAl zW*XCfnBWkea|jL`w@ch<_bV)Hv2c=wPqOea7Vc-^-7M^8VGgt3g#^&l)9us6Sfb~r zOz|$fM{$0CkE8KA8uI1_*E<{IYah+T1XLEDw hQt?|2rd3!96`w!+!&hw%_t+6&7L(Xv^6^Bi_9qd6r^EmN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST new file mode 100644 index 00000000..4131fdaa --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PHASE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 206 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 31,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-PHASE.TEST ;; ;; ;; Syntax: (PHASE NUMBER) ;; ;; Function Description: ;; The phase of a number is the angle part of its polar representation ;; as a complex number. That is, ;; ;; (PHASE X) = (ATAN (IMAGPART X) (REALPART X)) ;; ;; The result is in radians, in the range -Sail (exclusive) ;; to Sail (inclusive). The phase of a positive non-complex number ;; is zero; that of a negative non-complex number is Sail. ;; The phase of zero is arbitrarily defined to be zero. ;; ;; If the argument is a complex floating-point number, the result ;; is a floating-point number of the same type as the components of ;; the argument. ;; If the argument is a floating-point number, the result is a ;; floating-point number of the same type. ;; If the argument is a rational number or complex rational number, the result ;; is a single-format floating-point number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (phase-setup :before (progn (setq phase-tolerance 0.00001) (setq phase-test-cases '(0 1 2 -1 0.0 3.0 -5.0 #C(1.0 0.5) #C(1.1 -0.1) #C(-0.2 -1.0))) (defun compute-phase (x) (cond ((zerop x) x) ((complexp x) (atan (imagpart x) (realpart x))) (t (atan 0 x)))) (setq correct-phase (mapcar #'compute-phase phase-test-cases)) (defun phase-difference (pairs) ; calculated vs correct (cond ((zerop (cdr pairs)) (zerop (car pairs))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) phase-tolerance)))) (defun check-phase-range (x) ; x : value of (phase x) (cond ((complexp x) (and (> (phase x) (- pi)) (<= (phase x) pi) (not(integerp (phase x))))) ((plusp x) (= (phase x) 0)) ((minusp x) (> (phase x) (- pi 0.000001))) ((zerop x) (= (phase x) 0)) (t (and (> (phase x) (- pi)) (<= (phase x) pi))))))) (do-test phase-test (and (setq calculated-phase (mapcar #'phase phase-test-cases)) (setq phase-pairs (pairlis calculated-phase correct-phase)) (notany 'null (mapcar #'check-phase-range phase-test-cases)) (or (equal calculated-phase correct-phase) (notany 'null (mapcar #'phase-difference phase-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..866665fb6e8a17b2cb8084ce2b9d5d3b155a37e5 GIT binary patch literal 2520 zcmbtV-A@!(6u&bI$mcrX+Tu!a6rps}K>e*Zu`<(!`{1W_!-;E^e@&5wdgUo^$T+ zp7T5B+)0zt)2c42iRqb%so1QTSeTz#m>0(rv*KK0VRkeoj)Pu&N2R9r-hiSGwjFD) zw2CaFv$2u+*qCT9#OB6E-hNqZKPoCSvlCPBa^wgs+q({SbR9U*RvA<*J%{$Mdpf$> z_jh%6v{hzrta3tv5HdtQNvl`mbhx?QmQ6oND)X)>DLHfo<~7+&Pi3a zcSr}N4#^7j8__VivFbfX2;WjG@EFcF@q2^Z-LvG^ZwL7y(O=7zxv{pov5xw4B9M85 z5Y*QYk{R+3do%H20e*Gx^JS>_@_8z(wNft!$)Q4UXdU&nfc*mX#r?x|;7z?e>|0wO zZ72pS!kxGWi@I}Lc5v~#;7Pr({5`E-qTUCDq~pufJIHeoKzeP*&>jp1?B#@1Lr4>& zdo#DWlSTRPhYI;rJ!`y;pWP;FLybcXaQ0{mEIx&UpAi(G?hGO3LpReE>Rszc)RrPz z4!>Y z;sW8ToNK9ufJ%+N5O$n2pcs9+W=g#w&=~zzfG=Yed?~bZZ9r9QbwDyTJ8D8Zs%}4* zS!XO;3-dg9_;L-e>Y8FiBT|r>VJpBmo_l(?O#`gTQ;CLL-%9SRsEVao8)Jehj~9Hr zFx#f4+W8)5f@dr4R25x~>WZ!PJuwKZ!cz+q;|*x0Nll4H?MT!Pc}XqLyHLF59y*|@gL%eWk#p&U__iPoddNcGGK@C|2TSrJ zYe4Y>djZAQtP#aUh{R`Uc2Kg;gnOwj6>csxo@aYc!Ff=;FqA;ssL>&|*S(^4!U3fb zllB|n&0{ZA6^Mtz=YskJecXzH5BD2fj%5Z?h>UW-u$NF=0iO~hs=K;w762W20BD8M zLVVGP3rB9TRF;`j)BTgJqRv$@X# z>K2<3V%_<~S;3}nR80+9P})>3J!C`g=oYI&H%Q`@D7CfR@fj!8*43*)FKD@Y-~E`) zZyZ`UZPCh~--aiCxQe|&zLGn|^u$tpMV@@L6knC0f&({*wrsS(Ct;c(i^Av~J0dB(ATq z!(}KhCNoQf;M)gDc#v85Iqp7(l09G>bl=JQt6W6pA7|`n2?TDB23EJv@FP200>JU{~QdAPciv?H9KCx zx`DLTWtSuOvD;axAsl}$3x7GSEEAHvf0K|RujOP<>fukx?*!D|2Z-c-@bV`Qzxe&F T5_ejd1hc@}SS$H>Ae;RYiw)Z% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST new file mode 100644 index 00000000..b0525335 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SIGNUM ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 206 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 18,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-SIGNUM.TEST ;; ;; ;; Syntax: (SIGNUM NUMBER) ;; ;; Function Description: ;; By definition, ;; ;; (SIGNUM X) = (IF (ZEROP X) X (/ X (ABS X))) ;; ;; For a rational number, SIGNUM will return one of -1, 0, or 1 ;; according to whether the number is negative, zero, or positive. ;; For a floating-point number, the result will be a floating-point number ;; of the same format whose value is minus one, zero, or one. ;; For a complex number Z, (SIGNUM Z) is a complex number of ;; the same phase but with unit magnitude, unless Z is a complex zero, ;; in which case the result is Z. ;; For example: ;; ;; (SIGNUM 0) => 0 ;; (SIGNUM -3.7L5) => -1.0L0 ;; (SIGNUM 4/5) => 1 ;; (SIGNUM #C(7.5 10.0)) => #C(0.6 0.8) ;; (SIGNUM #C(0.0 -14.7)) => #C(0.0 -1.0) ;; ;; For non-complex rational numbers, SIGNUM is a rational function, ;; but it may be irrational for complex arguments. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (signum-setup :before (progn (setq signum-tolerance 0.00001) (setq signum-test-cases '(0 1 2 -1 0.0 3.0 -5.0 #C(0.0 0.0) #C(1.1 -9.0) #C(-2.0 -3.0))) (setq complex-zero #C(0.0 0.0)) (defun compute-signum (x) (if (zerop x) x (/ x (abs x)))) (setq correct-signum (mapcar #'compute-signum signum-test-cases)) (defun signum-difference (pairs) ; calculate vs correct (cond ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) signum-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) signum-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) signum-tolerance)))) (defun check-signum-sign (x) (cond ((and (integerp x)(> x 0)) (= (signum x) 1)) ((and (integerp x)(= x 0)) (= (signum x) 0)) ((and (integerp x)(< x 0)) (= (signum x) -1)) ((and (floatp x)(> x 0.0)) (= (signum x) 1.0)) ((and (floatp x)(= x 0.0)) (= (signum x) 0.0)) ((and (floatp x)(< x 0.0)) (= (signum x) -1.0)) ((and (complexp x) (= x complex-zero)) (= (signum x) x)) (t (complexp (signum x))))) ) ) (do-test signum-test (and (setq calculated-signum (mapcar #'signum signum-test-cases)) (setq signum-pairs (pairlis calculated-signum correct-signum)) (notany 'null (mapcar #'check-signum-sign signum-test-cases)) (or (equal calculated-signum correct-signum) (notany 'null (mapcar #'signum-difference signum-pairs))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2bf84756f5acbf78e46f8783e8f0562d78cd612d GIT binary patch literal 2252 zcmeHG-Ahwp7=PX)Tbmzai#6twI;hAz?1)*t-$Y%?AdMuNpCo+XxQlZCCPET@Tgr6D=a6?_^y!Fx^O){q>^2#VJ z7nF(7#61t~Jxd3&xl|f|`ugzd_4oSxJw09Z!GIL5qW#gw=l6E|d(U*$|6H6W)(ik7 zp{yTf04vmi_M~WKWL}clU?|M9LSUF@w31ddVJ&P_;v-to=A-kOESpyDC~3W%@d+RR z+Fa2Tj0&6_5(VuknI?_eY_TaMup?MnV1Nh8w1c9f6Rp_f^|8IIkCj3KEY4eJ0H|v= zE2Zc1THPEX8@J)bn;|OZa@mNnlBlPWXp*iTt>qg4y1WUXoZ7_8@tI>MiMkQDltl|( zf0V+rqU9|>Nqs0J;lg}Ch>oy9F)}PM3xpy&-Z*4br|0rlJoQDukVpV*e**ZP z?%$ZQ+}{L3zQBo!78>q$dK@dz&{jIVop`Cs+;ihapuTm3@h1Azw2W=%Y#tnCML>TEST>12-5-2-SIN.TEST ;; ;; ;; Syntax: (SIN RADIANS) ;; ;; Function Description: ;; SIN returns the sine of the argument, COS the cosine, ;; and TAN the tangent. The argument is in radians. ;; The argument may be complex. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; ;; Constraints/Limitations (do-test-group (sin-setup :before (progn (setq sin-tolerance 0.00001) (setq sin-test-cases '(0 (/ PI 6) (/ PI 3) (/ PI 2) (/(* 2 PI) 3) (/(* 5 PI) 6) PI (/(* 7 PI) 6) (/(* 4 PI) 3)(/(* 3 PI) 2) (/(* 5 PI) 3) (/(* 11 PI) 6) (* 2 PI))) (setq expected-value '(0.0 0.5 (/(sqrt 3) 2) 1.0 (/(sqrt 3) 2) 0.5 0.0 -0.5 (-(/(sqrt 3) 2)) -1.0 (-(/(sqrt 3) 2)) -0.5 0.0)) (defun sin-test (pairs) ; pairs: paired result (calulated vs result) (cond ((or (zerop (car pairs)) (zerop (cdr pairs))) (zerop (cdr pairs))) (t (< (abs (/ (- (car pairs) (cdr pairs)) (cdr pairs))) sin-tolerance)))) ) ) (do-test pi-const-exist? (and (boundp 'pi) (numberp pi))) (do-test sin-test (and (setq calculated-result (mapcar #'sin (mapcar #'eval sin-test-cases))) (setq expected-result (mapcar #'eval expected-value)) (setq calculated-expected (pairlis calculated-result expected-result)) (setq test-result (mapcar #'sin-test calculated-expected)) (notany 'null test-result)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..70a98602ec5a4032fde8129b1fc779e5252bde05 GIT binary patch literal 2006 zcmbtU+fN)-7(X-1Wm#Z4tQ&cjVIKav^!qlA@Gu=&LRj6>U<|<>R8i&@j0ZK&wVHV6TxViGScC|}wSM8WN zNN#Ke)(8=PsFFnl^JQjlNVt8O{CsCfOe*0jp~OSl>>*8s^Dh&Eib_KA$?%wz&y30N z1>ppcj5RLSO!WLDua~ zBqw6nXzi<8HNyqA;{hkKoN9Vh*dYiJg%^67(xif z!DJEQcJ4yn)y!(LtBUBFqYtVUbrKe^Mfd1dVvpJm9Tr9K2o?CK8&oqBakZaW!*+xVqVVTv zhedd~F93!!NGsJNvaZ?GKISm0d=hw6z{Rtu?sx>`vhNH=>6)P@49%f^M{1du`Ko}* zQiNI-vs9LF;t40>3u20hW{#?!9ufH-0$rt7IIhJk8ezV!9xq4p zt8gk(qsbhE4X6eTifRX<%8uv7Wz^L}(NgTfh}j^M-w_e|pzsBM6qj4P7MG9tV{by@ zkWHO_)gB%0Wrlk65->;&gC2&F(Zh+h@`efs6ZRluaol19CQ6_4dR#t0r8iKN-i1e{ z#Kg|MLA=eIP}_x2%!GkDg3~CB9Lgu+9(c0N8_~Am`I9x?w9M<9`4fJO{>07IJL$zG zrC~*DP$tLW4W3Y@E*G9p)U9~2-?|^Vo5;R8-J-w;_0&|2m;=XY*t{Iw0QB<-=Fmdj z&)i%~PcMZdqlNd;d-Ru%iyl>5u@CFFytXC0I2{!Z-kXk!2Xa(|*Jk%Z6t8Yngx@{y z54RNd@%z8+*8Z(Y&d59T8wnlm9Mc&l|fE!2H`ME~k*}%JyFMgPmfrc919pc?W0Cc5z z_y!#zX4p;Fq7AoXqAsIy$mnq0629{U6s0J{Yo|&3o?PdAR+W5E9OIKlS~m TMIHxu1WuTr<&9*!_u$|UmZnh# literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST new file mode 100644 index 00000000..128813a6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SINH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 16, 1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-SINH.TEST ;; ;; ;; Syntax: (SINH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (sinh-setup :before (progn (setq sinh-tolerance 0.00001) (setq sinh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-sinh (x) (/ (- (exp x) (exp (- x))) 2)) (setq correct-sinh (mapcar #'compute-sinh sinh-test-cases)) (defun sinh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) sinh-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) sinh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) sinh-tolerance)))) ) ) (do-test sinh-test (and (setq calculated-sinh (mapcar #'sinh sinh-test-cases)) (setq sinh-pairs (pairlis calculated-sinh correct-sinh)) (or (equal calculated-sinh correct-sinh) (notany 'null (mapcar #'sinh-test sinh-pairs))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5f9aab29c000db7187071d93fd7dfc4fab4d70c3 GIT binary patch literal 2164 zcmbtVT}&KR6uvVHbopBr*ly^GFpxrV)7c7^*wTmHVYtA`Ftg5&3rQ2C%i>a@OZZES zN(hcx<0ggvkhyIdlfL+%F;JhHV)nuKs1L?Q6Vo>zeK0XT_+apy85XfNu?f4G+{F5^q1KL1H&&)^g7rApEodhrII-OWrHf0&vYugy0Lq*95#b-qS+c zU0Q&Hun2@4Evz+lg8Zu1l#5J+L0b#(V7L9lk&H7Z@9mI#>Gq>J>AZh2eKOq%nayd=-{~lLTg!R>qh%euy%K>$7IQ(uS30)}%~4rX2a;Ih;;^I+C{!2wlYpp0 zMwIunO1=WVa%iIZs4SWCu&7hh(xC}tw~H!_al@peJP#TnugzqIN~)C-2Q_`vh%%1n z{%dV&QC97%VwJuCG*uuI$!fsUo9Y|;VoHA%53Yw$H-Y*|udOOX)QsbMK52pU09cc6X%hX8Ioq+ikii{l`w zcB3C?hXJZ`NokNcNtGd_QwVlHah+7b`LQy*LmKc>xCL7-qreasS7A|ssgg`wz7HPj zWlPtodg#Jp9LiQe7W(J7Fb7_OST%}=;5Y*vss?<;p}lD<0Iqp2t-kYr%oARv5@5q};Dr>OcyYJFX7-!qp+4u+|kI z5;CYcC>rCV{hA_{Zc+D2+yLwHl&%e79Dbd(;qWGc?qTEV5?s9%D(1vZk-@qU?FXGQ z)lv|HyBLlyl@uWzaI@2~q+!P0&5=LYDNrE4x<=%&H+&Dad@6~8&%m-0^8pO4lxK6( zv-y~Hy~DcltSyZ3R-HntnO$5G+E=A^VR{nYwkcueiuWubw%UPABF-J>29|$|tW&5l zq_p2q?g=SL6G}rdST(A_Hea=F16g@8;zMzZXn!3I0)nhr)wyPyO{fzJ%CML>TEST>12-5-2-TAN.TEST ;; ;; ;; Syntax: (TAN RADIANS) ;; ;; Function Description: ;; SIN returns the sine of the argument, COS the tanine, ;; and TAN the tangent. The argument is in radians. ;; The argument may be complex. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; ;; Constraints/limitations: The test case for tan must not be equal to ;; (+ (/ pi 2) (* k pi)) where k is an integer; otherwise, the result approaches ;; infinity. (do-test-group tan-setup :before (progn (setq tan-tolerance 0.00001) (setq tan-test-cases (list (-(/ PI 3)) (-(/ PI 4)) (-(/ PI 6)) 0.0 (/ PI 6) (/ PI 4) (/ PI 3))) (setq expected-value (list (-(sqrt 3)) -1.0 (-(/ (sqrt 3) 3)) 0.0 (/(sqrt 3) 3) 1.0 (sqrt 3))) (defun tan-test (pairs) (cond ((zerop (car pairs))(zerop (cdr pairs))) (t (< (abs (/ (- (car pairs) (cdr pairs)) (cdr pairs)))tan-tolerance))))) (do-test pi-const-exist? (and (boundp 'pi) (numberp pi))) (do-test tan-test (and (setq calculated-result (mapcar #'tan (mapcar #'eval tan-test-cases))) (setq expected-result (mapcar #'eval expected-value)) (setq calculated-expected (pairlis calculated-result expected-result)) (setq test-result (mapcar #'tan-test calculated-expected)) (notany 'null test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1cfaf94f6346868dc1f89621e24024c9349545f1 GIT binary patch literal 2021 zcmbtU+fN)-7(X*x=(5o1u-(|Q#WJE`vvsIkwigU`hT#A!!<=mJ8xx=W6HN5A!S9;|O6oQ7Vdk9g{`)TH zTOl=LhN&2Zx%uhY?1EBQD$Xwzm0V##Su89qWU@*Q_{tjwv*}yIx-ru6OlQd1CCMyg zCyUuB#a+rSPEEf4l+t-x(dQSYXW??{6p)?0@vh#Uo{rFIjiZfOuERa?GWUs}3eis#^Lejd?3xIS9F^DTmr#xv@(r7UtF2>?_$> zOlNM92!wc-%fZ2vWw;4ud8@**(BNGv?@L%}5>nHLC=r8OUeLSXmFqjZ)VSKEy1F$? zuC0a66C(W3D2oW@%lxeo;pSQL^X(BatwbAzS|90AA8969d6^Jo>?5R-j!sCG{Dcf& z7`{k_NtfSY^7>IG36K*qWRHbeq#fiJStK8w2!l40M6g@Gn`z$dZ2A^>4xiuKB;;>` zm`OnXx?)~p(szWcf;_S@ zl|GVghRB)rjWk~G`0!Slv_1qF((Stnke@gNIYSY`Pz2d80x-fJi?BoOP>+l35ELN- zbk`VGZR)0Mm=?nyw_0c1ap|Zif<~k|kA_KgE0t6SnLX;nxF8CD zwsu*J*9Sr%*pFkS`h#rf4s~{B7+C=cG#cRH+0=0T0pxOEKUx{OX{1cur32e+nb!px zVU(p9wQXjrEafIsZY&T+7ct!$SA9Mr3LF65K0k0$PuLDPjQ~fgLSc}O*4)npK$acZ1Zl_*cMqUd9-HTb62?uEMJ0e0IB);H>@wma8@%WfO z`X)GzIMf|fo$=9rW~$qpfPrf$^eB{!ZdLR+Z*2fG;TCwTN!o14Lh5tgg2xBQ^b3mA zyRcMhEzI06#M`_bxp9PIrA*`ztVXru5I&Xk!IP`J4P`67J~_|Zmw3xj{&*0rKk>>f zZg#P#w4T#jmE0uk;3;MLY;}Di@0@S@t@oj~iqm(*uqn)g`cPHPgbVF79bS)W0Q&h9 zb7?j1XI{CZx1U1GXmvmOOTV}ibUWHPXDfckYiq)bGn%mZ-i#)0%9;q`j@m?T;iBWwhsoQQ3KXII&XyZMtJdX1cgi4txXyPX${G<>9 z-d=3JNyi8|wnh$Xkid*~&rfORit9%v{|pcs_W+7fKah9W=MD dUlT&2rISy7|LGooBzO!O&X4gnaCML>TEST>12-5-2-TANH.TEST ;; ;; ;; Syntax: (TANH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (tanh-setup :before (progn (setq tanh-tolerance 0.00001) (setq tanh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-tanh (x) (/ (- (exp x) (exp (- x))) (+ (exp x) (exp (- x))))) (setq correct-tanh (mapcar #'compute-tanh tanh-test-cases)) (defun tanh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs) )) ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) tanh-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) tanh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) tanh-tolerance)))) ) ) (do-test tanh-test (and (setq calculated-tanh (mapcar #'tanh tanh-test-cases)) (setq tanh-pairs (pairlis calculated-tanh correct-tanh)) (or (equal calculated-tanh correct-tanh) (notany 'null (mapcar #'tanh-test tanh-pairs))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL b/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..27798b6504b69e5b98c72136a5a31abb16a0c410 GIT binary patch literal 1650 zcma)6&2Jk;6rc4vuI^eawnB9L$)c<*#jhm1#u-VWUR-Sy z*FBmd^Sn z;t;a-TJD9MrkH7>SqI!5&S&km{Ao?fLTYjfBZs?(!q7RZ4a;bJ?Lr>`)6M-EFkHiS5ecn+Sz=E(~+!M=OCg z2>|)$zPd{Szaq3>{)_~c9GoAHN5lCs1_W|9LOz7rmBQur18(|^PwuzAPj@~7Xyug< zd|~*80D13I5;~e70S@ZL7$J*<$xsyJpOc|-WF-vRB;WwMqdyAKZy%t;d^A7u1P;6T z(eu$JnR7sd0H1;Qdtu@s&QF{V^PEBD#V2>l?DyO?8#=FMP{HdFs6o3du$%p|H4;;Z zHlJqKFD=U2yoz<{S{gW7%7{5!)Z-X{-U`MP*;E!K9h*5FdPA|B%Vpd!Oq_8zKqK7k zK1Ic{mdi>DM9&y8$~m~FtxXc6gS?M=crOS&vYyIiux1)3{mMFx4}k1qug$=(kyFhC z75Iz57EVkgl4X$tUwB$Q3G5(rb0CIwo#+zDnc18f<3ph8i^y^#`4@l}?t8P} z(W%Su|HuH}Y6*$|yec15mpa)~^0Sxm0|em2@5w47z5&9;N+X+${2G9RN>0}y`_p$z zIVRh+ot|8cA{)3HE*)gztMnz<(BBMD&StST&&cn=$Zhn}VC4)hW1TEZ3dv;Pe$}** zU8f@-(3jt*qaFtH9oP?Kb&}E;bq~yaXNy1u#%?ktyHt$24HLtqu^jA_sx*2N%)EUw z13Dy2g)ALU(dZ0~+HStGTCbSJ&4xI(Esu$%RT!XaV&ztM_A%b}I6$MnplaajLJ#XB z>z;MMdTUhCv20>Uqu;4^In=a?by+p&AX9@F-^~#d)A54UiqBrdP-onobN29VocQlM z-Zpxn#9y}#c&F1j0UJPF^272fTQ2)ASqFZe=Q)^^JDpDFpVK7*lIC2rRBFzN2sP)1 q>0$Hg)YMe-9SWyk*wSX?F%uj!m19tL+BwnJ0Gv+Jaddd4)A<)TpZSyk literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST b/internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST new file mode 100644 index 00000000..f3688a1e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CEILING ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-CEILING.TEST ;; ;; ;; Syntax: (CEILING NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a real ;; DIVISOR - a real ;; ;; Returns: an integer ;; (do-test-group ceiling-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq ceiling-result1 '(3 3 3 1 1 0 0 -2 -2 -2)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq ceiling-result2 '(4 4 4))) (do-test ceiling-test (and (setq ceiling-test-result1 (mapcar #'ceiling arguments)) (equal ceiling-test-result1 ceiling-result1) (setq ceiling-test-result2 (mapcar #'(lambda (x) (append '(ceiling) x)) arguments-option)) (equal (mapcar #'eval ceiling-test-result2) ceiling-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL b/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..861ea10f3230110c008213fca84ad40386689db9 GIT binary patch literal 773 zcmah{O-~a+7=CyA2^7*2O~e?TkZ{>JByCW!UL1#MY1z)g?5x1CX}7jXp-n$bjFA`* zp4Mm~l3fk|!7F0q;2-iI;A}x9cTwZ%u-N&C`Gt>;z;ZXL;?+pkw&+(p@kh;)0cw%RN&t7A5Q zFPC3hTAVBp+dN16Z%;0t&E<2d=j`ZEOLqXE2B+aN0g#3W`1@Ykkj$32P%;_jq{0k; zPOa5Yxn#!g|)o}&HwBl=nDQe6^uxxBKz&+n1NZ6Oc2u!rov}x&W2-27TkbO=cml>test>12-6-complex.test ;; ;; Syntax: complex realpart &optional imagpart ;; ;; Function Description: This function returns a non-complex number if only real ;; part is specified as a rational number. Otherwise, a complex number is ;; returned if real part is given in floating-point number or if both real and ;; imaginary parts are given. ;; ;; Argument(s): non-complex number(s) ;; ;; Returns: non-complex or complex number ;; ;; Constraints/limitations: None (do-test complex-test (and (eql (complex 198) 198) (eql (complex 2.0) #C(2.0 0.0)) (eql (complex 3 8) #C(3 8)) (eql (complex 2.0 8.0) #C(2.0 8.0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3fcbb3d538a96f6a7b9ead97c6dcfa5d7f362dd5 GIT binary patch literal 1873 zcmbtV|7#m%7=Q25?@hBy7rQp=+G}aX47;+lRn{mh*Xx@m_IlUd7rTN`Ym%C1+mtjF zhFH28R3xxvW%b^TB8uP-f_CB$Zcc*ulRx;|z(2r$KoI;*>hoOME_R~A2zU3s&zH~V zd7k%qpHxWW6-5=5{K{HxIa3hx8^yJaqPUbVi0k={LMkIJfn0oB(GB`eLRO}SUx>7s zb(&NmvslceMQbCoo?g6qUW|;3@>(Ic42z2wVH=4)HxeBi8*YosrdmV$PoI%!WF$Iz zVYqF7cZU=5gpd@e;-{4mfp~~>t1N^qYFbh}sZvRkXK2`|IOP_|MY2t5IA#BcSj?|U z%bB+_%b3o}I^hU$ZkAi(wx(D~U30d%EzaxQD0d_^X%y~a7-PPPf zkab>feum55U+`6RA8dcCs5f-qkAzgR@9Vy4o&(p)Ue8=F`hdQL5HEn`Qhn8X+;|-+ z_u!DUWv(00vJ0K?1mNicg*Ta9dgY{qMqc{Zrup?xi3kSIr7|$hXVAVMW&_ zlh_GTLe?f#YDg1FkZ4n8m~UdOd?U1(Kdi`>l8_8)*#@+U;`UjSId58YhUdW|P-{d* zrLtzvN^#woF~f}GxhK6XJz8 z5q6z&zm-`pii4Z-pt!UMGdL~gR%_!EWt*X^&Ru648?a9?sBBT`*a4_XiyE?OvUW6s zpfB6HMcGi=DGx^{D4Z;<%|&vg^5V*C=|#-zcw>SO z=Qbwvrc>sw@ZFF>hdY1Wrf6nkgg;%vP&!Igc#|_bM2aET{0UWcml>test>12-6-decode-float.test ;; ;; Syntax: decode-float float ;; ;; Function Description: The function decode-float takes a floating-point number ;; and returns three vlaues. First value is a new floating-point number ;; representing the significand; the second vlue is an integer representing the ;; exponent; and the third value is a floating-point number of the same format ;; indicating the sign. ;; ;; Argument(s): floating-point number ;; ;; Returns: First value: Significand (floating-point number) ;; Second Value: Exponent (integer) ;; Third Value: Float-sign (1.0 or -1.0) ;; ;; Constraints/limitations: None (do-test-group decode-float-test-setup :before (progn (defun check-value(x) (if (and (or (= x 0.0) (and(>= x 0.5) (< x 1.0))) (floatp x)) t)) (defun check-sign (x) (cond ((< x 0) (eql (float-sign x) -1.0)) ((>= x 0) (eql (float-sign x) 1.0)) (t nil))) (setq test-decode-numbers '(0.0 -0.0 1.0 3.0 7.1 -10.0 299.2 1024.99 -239898989.9))) (do-test decode-float-test (and (setq value-result (mapcar #'decode-float test-decode-numbers)) (notany #'null (mapcar #'check-value value-result)) (setq sign-result (mapcar #'check-sign test-decode-numbers)) (notany #'null sign-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c709c252638bc8e2f1d8b4fa9e1dc71dc5f41b33 GIT binary patch literal 781 zcmah{O-~a+7=CyA4TWrpCSr_ENVseqk~XMVFOJ)3*|MF5*;$ceQx@B#(54?I#z>3@ zPiwRg$*zX~;1w})@DKS9aJDr{;NWRzpLgEp<9%lYiD!m|jLvSi)%JR*GaPh>1GLlW zp?+uBYj|i!;^>uObNYIf7;8(9@>9-*N~7o12i`UkL$AMGe|Z<>A0pE2wc7HqvLb); z#e0R~^77JDnK;&j?Y}*RVt&$dete{89RO&+S@g*OXb^+oz}Iv^9f8ZHMKL2ast2RM zPs=RWbtn(~TmcO_UEKCwc@|yUY-#&4NSajgk#M_%kNM>oOXtP*Br< zSR!^M@U?sa-^V4&?3&4lusIwbC7(uCzBNy)%E=yVe6OmTvo~`}qILQlVD4=yt29r3 zFnRtpT6@oa0*spPSXEVK01ld8uWyb6$#NPX3vkwI%#E5_O9M3#eDZJUhRsT5WDu_s zRnLMW(L>Q}>Q{i&y+!#ksI$MsQHC4HKL)dya9ZQ9oSX!o?)hXvT z$F?ihU7^P^vLUMzwuQ&Iqle?zm!_AB0fg~rWU;CwNtSJ1Bcc+C87}9PU06k^JdpUc ze>n`|&D0P_!1ndQsTD3DG?N3a$%W*a$-5*baYMXY`C_d;SKnV&d+}XJ$va_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST new file mode 100644 index 00000000..e22f1143 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: DENOMINATOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-DENOMINATOR.TEST ;; ;; ;; Syntax: (DENOMINATOR RATIONAL) ;; ;; Function Description: ;; These functions take a rational number (an integer or ratio) ;; and return as an integer the numerator or denominator of the canonical ;; reduced form of the rational. The numerator of an integer is that integer, ;; and the denominator of an integer is 1. Note that ;; ;; (GCD (NUMERATOR X) (DENOMINATOR X)) => 1 ;; ;; The denominator will always be a strictly positive integer; ;; the numerator may be any integer. ;; For example: ;; ;; (NUMERATOR (/ 8 -6)) => -4 ;; (DENOMINATOR (/ 8 -6)) => 3 ;; ;; ;; Argument(s): RATIONAL - a rational ;; ;; Returns: a positive integer ;; (do-test denominator-test (and (eq (denominator 10) 1) (eq (denominator (/ 3 4)) 4) (eq (denominator (/ 10 -4)) 2))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0bd7688237778fe2c4fabf13ec78d1da52ae9feb GIT binary patch literal 1728 zcma)6-%le|6u#3!ZA)9HScz1`kw`--gSPA{R^u`Zx1} zshXtLR@atSD(g~hv%a=jmzHYl(nf7_y^A+`qORI`raSw>wh(f5n&G@I8?ZGcM~TOOih}5Z(+sB4^2>5orFku{=g7Ug zkz0fa-$z9cw(~>v!K`rqCfWUQ)>C>a9u<6UuW`56@<97F*nUZ^Am$>zfiqD zA8D}&sDJEfJ1p`uA$!%^EHdj6!XO^@mxd4s{C+}0gtV5+&$o_*S01S;{Bl;)Uy1`- zb-ov#7(9J|y!$chJ$!*h1R%^u2-FEdRpaw9NMI2Uq#piOPJDSp4oZpA zz(WvrN`n^zj$(ZPg&r?K{Ixvt9W9Mq3^UU1>k^3HOVY#bD*pdBZG9Kf1|+^22O3&c z5x?%I&4HxK^yxf~fIOq<(;7A9sXSQpoR#$Wc)-&Q^A%01imlGbCbf$u%!ld@n9sUy z*|gyCKt!xPfvQFoy=cf;W)`d@7d*nhvu&2-J>C!xc!S^!C}yr$pt@~!W)`Q-8v&nq zHfm7VDr$C$i{8i4-pP@ffvtmGydXXe_9)DBBuPz^nKCQdM$t}sdm%QIRP^hzYsW^t zPk`;oPCfTHofnP$mlG;DO)>S4(-i`Sc^4k3FdmR2XrYU~t!Sux1&R;pQEXJd0OY7z zG)-XO{QPnOeRseYJO4bYV$pWPya(M={AqZR69iNYgX+_$eho=}>-2~srO`QRvN>60 zg#vtIEpHjCeBfRF%sYJ0?d}`M?>0=9(-HJ@NDuyv1}>ugHb%K@p|%BAhfl{%xO=Mc z1eX35=E;}Um|`0@04CCbv0!WrE*g9|#}gAg5kQOsr}?a1*{DlHTgs5Mv;a5jqO^Ro zeJP@CYZyWQ1R9~X{|xMX=QC#?CvH$RsbW*u*xCHL1ZjDjnu=!e9t?w~-zqYj^5L@6 z9Lr2mV4k*bK=)d&cN#dWyk(vCGWMdg?`=$O6LP+cfC*q5Q(c6FT>CML>TEST>12-6-FCEILING.TEST ;; ;; ;; Syntax: (FCEILING NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group fceiling-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq fceiling-result1 '(3.0 3.0 3.0 1.0 1.0 0.0 0.0 -2.0 -2.0 -2.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq fceiling-result2 '(4.0 4.0 4.0))) (do-test fceiling-test (and (setq fceiling-test-result1 (mapcar #'fceiling arguments)) (equal fceiling-test-result1 fceiling-result1) (setq fceiling-test-result2 (mapcar #'(lambda (x) (append '(fceiling) x)) arguments-option)) (equal (mapcar #'eval fceiling-test-result2) fceiling-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..82b5029b5691afd5e9378120c197f69a5b380c8b GIT binary patch literal 1710 zcma)6-A^M`6u&ct+R{>|-G)d-9EmifGS!w{#cGscxGk0G+;KiE8y^TM?Y0KCq!gnu z60$Z~ADRG5+|0$SiN+_R3HV|*u9n0HU-m&0{}3O2!*i!lh)aTLdhhxCopXP4?%hNE zi;5~L^|kfdYPliSH=FC5O|epMh#U3IMyV`Tz%G8G5CeZYFDnblH&O%U1y89_UT&6G zL~FCWv9kQ}q?meLl-C=zRS>49K}}_Dq%+sACkL{!sdmw>%t>cbQ<+z8BnM6&+~1 zLflVbfoIM9Tz#~_J-m%}e_7y*&&0x<*X=asc3K+gZlm2z?9?9JLMU?QsbQ}Aa4FOw zAyEI`Q+G({H-z@8cS&f0=LSJM94?MAAn^MT3L@00m0s)|aj#vd$^Cv-(^rfET6HM` z|0w*20D1Q_5;=T{ggBtfix9I#91VXL@gpuyTn;nQ?duANzl!4H?JE2IZ`y_~qYX%WCk8Zhssj7A zU$jRO3eo2BYyhNrS({U_AB6Up8`f0c)1on^-n$o)Gv#-9dx0 zrmb2jDtMj-tI*4kh|U@ZyYNJG8mwWM=1>9~1~DXJTe@u}JQ0WtCS>iVpIrvnED+gc}@3XG9tr^*dU9NLJ9@= zvTEMc*XYOx^tt!xsN383kln8vB&RXRuOK;afdDEn>s=P(vc$A4cr3gcJAiwhI*qfk zKfnxmp{i`@w*Vw~3Sz>b=v2_@c#g)WY242c4xIM$R(Yc-j%~?fVr3a#(iO3GyZZ<- z+txUP{09hh$#M_#k@Kaq&n9eCF|cf5IMUg?y2Pk?3mdX((f|vChTpY`h3R<7X(uzY z7#PRh_s)I9o4xX9b+^pZPLeM>`<~X!3_|D21egG}HQR^Kpew-p(-i~|UU2pYTaW-5 zy#)l+a+l6FNbYhx15$5^xmoc_r8Oh6)M0widV6YWs`VBH=~uRNn0m|{$1LO+g8N(^ Q=p=MOB|44{-aI+^7k@ebU;qFB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST new file mode 100644 index 00000000..9e390a45 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FFLOOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FFLOOR.TEST ;; ;; ;; Syntax: (FFLOOR NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group ffloor-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq ffloor-result1 '(2.0 2.0 2.0 0.0 0.0 -1.0 -1.0 -3.0 -3.0 -3.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq ffloor-result2 '(3.0 3.0 3.0))) (do-test ffloor-test (and (setq ffloor-test-result1 (mapcar #'ffloor arguments)) (equal ffloor-test-result1 ffloor-result1) (setq ffloor-test-result2 (mapcar #'(lambda (x) (append '(ffloor) x)) arguments-option)) (equal (mapcar #'eval ffloor-test-result2) ffloor-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c74fc801d601e8f9096de3b65109210411634ab7 GIT binary patch literal 1622 zcmbtU&2Jk;6rWuuCUG2h9U0PERoS>|0gJKZG*oFoYSx?a2U+i!o!taqh>T-ngHuO| zg9M1kY9hg5MQb9WomP>0;=(0}3ssAZ#J|9m{{e|J3UAg;uu>$DIIL#h?|r}d&Fi7j zcXdP6+Z&tBR&7gd?{qeII%>VWrEa%(wyHI?4!HW6PA&3zUelLTZ>B?RNK@UaRXVkG z)!wOXuU9^KT}|Iowau+&3x4M3K};{aF}pA~mkMPyW(=bJtIzC0`o==~Rw{IIbSNop zgisar#W9YMf&$3<+EtP^VK&Yd41!IqNRnR9bH|_;>@Z?^Zgf`dv^R09_HnHx+S%Af z5<=d6cP#6ex?P~AcOZ48uy@a$ESR_it!X)eoHeLs5vV1&u7r5*YT5FRfk{PM{w{C@fs7SNh+hZ->g1%BN*ctj7Oek?KQ81l_Evki6UY z&sDzkPgO#wx8o43-%yY|;eF#?PU_TLDu|21dCgohh=nr+K+GIV%0WIZj{*y#NnNw` zJhq7KSa6HFPlF&UGn*7;87yK0p6CYAOs9mi)GD$hmt^UAZ<{9hL?Fz^10mr!eCgP9 ziWy?DGm;5<1R_A5NRn6$;l4B2o9vk0QiJ1T({eV+<0EkQL1kLKcLes9&>%sEY=4$Fhhy^bEKpbaSHqzvriGj10=* z6GAQK8@fhTh*ic625Jz21|j|hRxW0!fluEE;OIBN!^6W6;3Ixf97p_;IKJZX8pMn- zVrTKW5c7Q6PijJ#(UL`TCU{7TqWa;W{%E)&bgv0Ze|kbv;mrn3(Y8N@C{GA90REvN z|I%&W7d-%cdI)EOkwallX<)I(XFlbLk9gueel;jUz2&(t+qLbEn%LD6YP|ycZe4BO z8LTRS?Op>j^qu$6I}nVzqFY3>2|hPpqhJ$DGZ>!`X3)Vq4z&rN5x$3>n_9>axI8l0 zMgD^AoFzTYw#%O7PgM@l%;F8T*X%aD#Sj1dqu1!d?~nOjes8fgebQ?x@K8KA-l}Z8 zzg`jLo~IIQJISXKu*q|!ER=!b-a&Bxb{C=jMUeJ?&erSu@PnY-c#*<7El~zfZiV0_ h>SSQE`jb4cml>test>12-6-float-digits.test ;; ;; Syntax: float-digits float ;; ;; Function Description: The function float-digits returns, as a non-negative ;; integer, the number of radix-b digits used in the representation of its argument ;; (including any implicit digits, such as a "hidden bit"). ;; ;; Argument(s): floating-point number ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group float-digits-test-setup :before (progn (setq float-digits-numbers (mapcar #'eval '(1.0 2.0 -3.10 -0.0 most-positive-double-float most-negative-double-float))) (defun float-digitp? (f) (if (or (and (integerp f) (>= f 0)) (= f 23)) t))) (do-test float-digits-test (and (setq sign-test-result (mapcar #'float-digits float-digits-numbers)) (every #'float-digitp? sign-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..052268f2299f4573c192d7ea4e0da3ba294cd747 GIT binary patch literal 1623 zcmbtUO>Y}T7@l1xCb1oN9l5k!Rb^w;0xQOn(@+J2)T}q-#ALl=_9MX;BIB&F!Kow1 zK>|b+wUOYkqBRlGPOC_qxNr&LR8eFk{sLG20}^Kx-dQ&xa*;sdu$q0pp7&#(dHZPm z9oc~w6)pR5Rv@1P%kS`pVS%PAqswd=`2b6tXO8ou;^CLi3R((%hQDL@xo zAq8}rrf-1#3z}}q>(k&(lOn_&|5}#^?<2%vrVtvmo`5iY_qmHg^D&rd62#y8#(kRn z1)+ZPbDCTc1#s*iUs=1#gTOw4P=bfnuMNIO-<~T|sGgP?Uz7h|k;)@T1l_DDkbJNC zpR0WSpQ;3?w`2etG$ka)gRlLos!q+t62B|FteJ}jv2dXT8gt23#VDH;$AJhbRo5JS z8C%40Ex1TMWJ1)g+72m;B6y^SRM8EhnQjFasa3XBCWykb(GFEvJd$9Okr)^+jodpn z-Ex6g_8HYUNg_$0P*Nq9MJ-HSr{X$l>A&ZwYc?6y z#Nyn{=N!9ER*6-`HVoDvTpI=a3wE_!pawpDE}%!has9|pxc(ba;0f-=u8g?UXt8n0M%$%F`DffqS~8xDv`-24i64hP941s-wK> z6)xW1S<=&NyY|!k+1eqRTKM44Kl)9nC85BV+qKR2Hfp@CQ33(J5E2MD6!=0BWF!X% z(f!+d2< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST new file mode 100644 index 00000000..8fdbdc95 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: float-precision ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: Aug 8, 86 ;; ;; Filed as: {eris}cml>test>12-6-float-precision.test ;; ;; Syntax: float-precision float ;; ;; Function Description: The function float-precision returns, ;; as a non-negative ;; integer, the number of radix-b digits present in the argument; ;; if the argument is ;; (a floating-point) zero, then the result is (an integer) zero. ;; ;; ;; Argument(s): floating-point number ;; ;; Returns: non-negative integer or zero if argument is zero (a floating-point). ;; ;; Constraints/limitations: None (do-test-group float-precision-test-setup :before (progn (setq float-precision-numbers (mapcar #'eval '(1.0 2.0 -3.10 -0.0 most-positive-double-float most-negative-double-float))) (defun float-precisionp? (f) (>= f 0))) (do-test float-precision-test (and (setq precision-test-result (mapcar #'float-precision float-precision-numbers)) (every #'float-precisionp? precision-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fbb1a041dbf8e4e35724f880386e95d9a3143b2a GIT binary patch literal 1645 zcmbtUTW=dh6rNott`j@kO)w>Oqq4DRsVpW^Oba1Mw42S?F=owC(!NR;jG50j_;zaGQNSryKJV?@taoU7pfbx!5SL zYVJ;Xd$st*TiWD%n!dSJt-;UK6qu9KH`3GBuTKnSbjR$l{p+6e^yJ&Yo|B_PNv#t? zN~Dd;03j*~5&uC`O}Wf*X(nefYUz2F@>_m00=-brVYc5KPHT<&Cask}FW0c0^=%>% z;@@vZGM;6)Id1s}(w-Fa?=^>V7A-()dX^D6@`44~CBLaors+F0V{+Z4wmzF%B1eZq zcLAi37Mds#Zkx}RQ7-? z-*sVomH%A&g?}m?s6I?Uf_6nEa@7B!IhHcGHJii3qjS17YciY8>lG z_<_~&O!rJ|D3j2j7zim4@=BLZsO9BnnC%EPbRIOOq?m1Un{v-Bcy21BB4bLomT7=v zdK6oaW@G(?h&~jmf|{!UQ6F2-O*B3NBaEf%E}BbNyW!b3v$}4DkkFR{U;OXU8M?zd zX+;#>8jN=E3R__IGId~4+$XK|i-W?lLisdk_8Q#Pkecml>test>12-6-float-radix.test ;; ;; Syntax: float-radix float ;; ;; Function Description: The function float-radix turns (as an integer) the ;; radix b of the floating-point argument. ;; ;; Argument(s): floating-point number ;; ;; Returns: integer ;; ;; Constraints/limitations: None (do-test-group float-radix-test-setup :before (progn (setq float-radix-numbers (mapcar #'eval '(1.0 2.0 -3.10 0.0 most-positive-double-float most-negative-double-float))) (defun is-radix-2? (number) (if (= number 2)t))) (do-test float-radix-test (and (setq radix-result (mapcar #'float-radix float-radix-numbers)) (or (every #'is-radix-2? radix-result) (every #'integerp radix-result))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a282844dc0aab4db5f8f93c23748b9fa934946ca GIT binary patch literal 2192 zcma)7+fN)-7(X)$l%0vol7rD^DD~>E6dXC{Gzlpzp|K0OS8b2-dCAHKRmCf<9%;LYRvGyi2$m^1_u$Y~L%iti8k)eV9p|fZEYDX1QE2F*8rhh1MW@uob zuXg*+CMV7lLQ9Pg9Hw(+iExBCYlZ4jTUV_Z)13`2$JIMG3k@+{PC#nP7$to54ho`kPN6Za*>*J0FaS*jODuSK>+i3; z|DU7RT;{sx{Q3BgQc@||el+lfU0@E7@3pWXp6+E9pUaGs4efSO` z{%faNxy*g=#snaru4^}$@C_mBnU9$;&T|cLExwfO!MH(QO-MZ;Xujf6@5gbh8&FnM;|l8e3e_n zSHiS5g;m8;&&vk2Yy+lE^~SZzoHQ*O=XuZwl;>I1sG{2md6XG(GwgCa_pG(W!fu^U z073KqV9L53k5a>o?Ck-ZU|-|WTK%r*6G7BMFD0mI(GhRBAw1L8tOy93&@B$U?5&x7 zf#0q1H6Le*umRX8LYNu`Gh}943EK+$TEL(_tmu=n$H&Bc!J|9?fKw17hgO#W1$QfO zUp2w*;kUp;1)WedB%T6Mh1F6lB>zNI)iw;OA6SkqhqB*57TE8Ws+hDKk6VZ0Pux~K zGz3%<3964E*#$iox^!k?^d@vwqrm3=LoIsIRsRSmBClc(+|$72z6YHO-PVxDnE=&t2ue2LV@-H~+?#F> zs+}pDcDko)5cqee@QRgQT9!Iil@4ik8eYm7DSNg2$RTgF3)Lue&h13|8Rtu91Hblm z)u4(+GmDmeGpEou6s6E=T7J*GM|yeB{jT3tb0?BM@JMdw zhjWDBZ7pAd+uP0td`P^<%|AW|FCq{q$e%k%>`KtslZ2d&s6r42w8E=~+Xo@Iuev?ti{b6<{{iM+l2`x$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST new file mode 100644 index 00000000..3df45ea2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: float-sign ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - fixed (COND .. NIL) to (COND ... (T NIL)) ;; ;; Filed as: {eris}cml>test>12-6-float-sign.test ;; ;; Syntax: float-sign float1 &optional float2 ;; ;; Function Description: The function float-sign returns a floating-point-number ;; x such that x and float1 have the same sign and also such that x and float2 ;; have the same absolute value. ;; ;; ;; Argument(s): floating-point number and optional floating-point number ;; ;; Returns: 1.0, -1.0, or other floating-point number ;; ;; Constraints/limitations: None (do-test-group (float-sign-test-setup :before (progn (setq float-sign-numbers1 (mapcar #'eval '(1.0 2.0 -3.10 -0.0 most-positive-double-float most-negative-double-float))) (setq float-sign-numbers2 '((1.0 -3.0) (-1.0 3.0) (-1.0 -3.0) (1.0 3.0))) (setq expected-sign-result1 (mapcar #'(lambda (x) (cond ((>= x 0) 1.0) ((< x 0) -1.0) (t nil))) float-sign-numbers1)) (setq expected-sign-result2 (mapcar #'(lambda (pairs) (cond ((>= (first pairs) 0) (abs (second pairs))) ((< (first pairs) 0) (- (abs(second pairs)))) (t nil))) float-sign-numbers2)))) (do-test float-sign-test (and (setq sign-test-result1 (mapcar #'float-sign float-sign-numbers1)) (or (equal sign-test-result1 expected-sign-result1) (notany #'null (mapcar #'(lambda (pairs) (cond ((equalp (car pairs) (cdr pairs)) t) (t nil))) (pairlis sign-test-result1 expected-sign-result1)))) (setq sign-test-result2 (mapcar #'eval (mapcar #'(lambda (x) (append '(float-sign) x)) float-sign-numbers2))) (equal sign-test-result2 expected-sign-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d79f7f565441eac8247b5a4e67ec8639b9263601 GIT binary patch literal 769 zcmaiy&rcIU6vy9g=?`d2wnP&#Mkgd(HcpdmK(SsNmnm&oW?^<#>%9@;|7vtx-mSqjB_bc?|QYqw~NHU>+RNF+(pI%L^|DOOKw(H z&x}q_6s-*ab-0L@X#fpk5FGiME~q1LsbW#g z$OhGeVc@4E3w9mK13yh|o-oDy%IKLeP1lgucM zv+qpqe-78*u^#}###>fZl`OzftQ;U45wo$$vLZ2 z&TWouS8TdMk4?)58J(~lJk}jOl)##CrEkd?KsXgOD^`^ziIUAXh**n~nJ(v)T^d5D z+?V>bzZ@oU=)^rtPp!&WcHBxFb@$J}#)FjB@o^c8az+UjC9&qidG%4?-w|G~j}{Ke z0@|y|-?)pK2a}H!X@`qS@HseErTJ}>Qz9t7lHaNb%8BKK>FAowv*p@?hBx378jXGd De@*4R literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST b/internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST new file mode 100644 index 00000000..b8ed6448 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FLOAT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 214 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FLOAT.TEST ;; ;; ;; Syntax: (FLOAT NUMBER &OPTIONAL OTHER) ;; ;; Function Description: ;; This converts any non-complex number to a floating-point number. ;; With no second argument, if NUMBER is already a floating-point ;; number, then NUMBER is returned; ;; otherwise a SINGLE-FLOAT is produced. ;; If the argument OTHER is provided, then it must be a floating-point ;; number, and NUMBER is converted to the same format as OTHER. ;; See also function COERCE. ;; ;; Argument(s): NUMBER - a real ;; OTHER - a floating point number ;; ;; Returns: a floating point number ;; (do-test float-test (and (eql (float 10) 10.0) (eql (float (/ 5 2)) 2.5) (eql (float 7.01) 7.01) (eql (float -3E3) -3000.0) (eql (float 3 4.0) 3.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5580668675957ab45e0ceb16999380123bb911d3 GIT binary patch literal 1640 zcma)6&2Jk;6rWuu#&&FXZLElx5VoPQB9k?;6Hss^n(b!nxLNO*-8D|dA&MNkHgf97 zaS*5?s)8jrtdxX^vXiPvaDxL%5toXBBf+r;4*VfpxPii(-6p9@q;^(2Gw#oSd$UumiFM$Mw-ln|PZnflF?Bf|FrJW9JGGT= zZB;ZkYa6R8A5V$tw?%oq(`>X7nYDTv0+NNf{G0%+ zfjEThUCWm%Yl>MQn!V56=7RQ)6)I>_2~v~u81cTxC=8vmtx!56y(Q&TLUeTRPIwz3 z?x%>rvsiv^JY3`++(f&-Eb^6?;t|g41R8e&t&Y0On7fGm=EEBZMYmrV;TjK?!+jD4 z@~=I0hlGDaXs_`Z2`}Ms1{>HZ4x8H36OtIh8ywa7-*9)4|a!tRukXeM+cQeW%Lnjb}D1% zqfIgAfCvFT1M!dQy^iov9;U6&j_3(@l;@S?6K=l-0z zi=8V0Y}*pjPu-;;RFw{}3lw5E;s1;*?#6{kdux&?29S7Y%z>9lC#1{e*wMh5gm zi3%k;k*A4Sns8ivWm~VBwT-Sgz9o-~^%Zz9SHx`>wsu zdTC72v20>U;G{F1GN=U;>#}OlA*Kda@0N*)=|t7GQrW8*>Wkf1&3UT3r`}K8ZW)gQ zNxfn3dtgk$0#Fx2Fulg6OQDPQeu(FJgtm`ioKF9;ojb)rqc@kR*L!m!LcO^WdeFNv mJw4rfhr;exHuV{K!~{o7CML>TEST>12-6-FLOOR.TEST ;; ;; ;; Syntax: (FLOOR NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group floor-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq floor-result1 '(2 2 2 0 0 -1 -1 -3 -3 -3)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq floor-result2 '(3 3 3))) (do-test floor-test (and (setq floor-test-result1 (mapcar #'floor arguments)) (equal floor-test-result1 floor-result1) (setq floor-test-result2 (mapcar #'(lambda (x) (append '(floor) x)) arguments-option)) (equal (mapcar #'eval floor-test-result2) floor-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..92698194e92973302c16b356052f3e13364482f4 GIT binary patch literal 1686 zcma)6-A^M`6u&ct+Cr(*ZbPIZj(~*B?$i{}#hSPshTBpZ=8p4WcjE&grQKp+OQ0By zk&v~?`p^Ve;$|*pH_`aCSrhQZY+Nmg55DY!CjKEl`iAGubb;)WV4B{0K7Z$T&zyUA zQRj746V=+v>e6y~O{{IyS2yZnrM4!n*EZHlWw8Qw@e7rh_{$kZolU)$?y}B!N^9kX zdU;W_H_Gda3!h&R)9;GP>e|vW2$PebrZaDkWhN$4T{*?le6$O5#xm)N%=pz**YW*( zoKQmul~9XqVT1$}K|*Oa1;f;BR7U>B&um;=vw|16FEgo~r+!;Jd8E`a#EC_de)vfux1Tkm;ogC>5Egf_IQ z0{gb#H2Wo$=+gx@0P>8YPixqerwU-v^OnR1X_)VX>556JVyiQLybwJG))-84RKli7Oqn>g;n-3j4v`T_(Qn9}oskS& z0^6l_E$B)}U5rC0-+@0;G^YFjN|3chv6=cE;Ko$P zG~wi@x0Z6ucNct#)6b$R7WT=~Zswk%ufm3o8K7bqSf6Iy15yduc0!X9{ zV!=QdR50jJo(@ma;V?tkcbl)<<@LHaxTy?^l?8Y)7saJp{$s~%n{P76f1y!cQ@q#Y zGxu9}k4@5mYGTF4@^cN)3N|(s&7$2b3lG{vWrZ99C`|q0fSl3U=KdZZG zwV9;ea`ys_Y!;zLcB{RNf(c+7QymEPcmljLz94|`hP&6(&H&yGNJWinEEk0K(qifn zQ~f22P}0j9sZ<(S5$xGMy5G1qK0e-fpMvxoTUty#VvZvgasCML>TEST>12-6-FROUND.TEST ;; ;; ;; Syntax: (FROUND NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group fround-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq fround-result1 '(3.0 2.0 2.0 1.0 0.0 0.0 -1.0 -2.0 -2.0 -3.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq fround-result2 '(3.0 4.0 4.0))) (do-test fround-test (and (setq fround-test-result1 (mapcar #'fround arguments)) (equal fround-test-result1 fround-result1) (setq fround-test-result2 (mapcar #'(lambda (x) (append '(fround) x)) arguments-option)) (equal (mapcar #'eval fround-test-result2) fround-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..48cbc0cac7d0763a9ce172fe61dc9d686e2f13ad GIT binary patch literal 1737 zcma)6-A^M`6u;9#ZTXm;)`mz$9EmifGMECZh(;NPTc}Lujx$rs#s@-5+19|8lwveS zvRRv~4^4n2ZsuZk6OB)sH347D#?_Me;LAQ};veFpZ+OmhY1b8lnasWC)*$Ir)aHZdOX`AWThxnw-8oK0P@()|FCiy@_^V%=mP2a{6*|tn2j7 zZ9ys%Lh_`6Q-~0W_=$U~E+rglJ4!08Q^im-G~w>M^&sp;$=cL%>)~;^THaLF3m+BM zaXTAZL?Fc7s|QnALvzy1a1Vs*LXW#!?@b$u30qU=De(m#qaeEA*2Uzw@|u!zEC^B^ zO77eiZxAB<5SDyc&yU52i^79zWbda%U+%eBSO|E<#=K(l1I=l$ImwOE!>fcuZamX3 z6dx>$4JLy6=f1wn#9s*6FWzM0qEF}r@u)vHgh1dA64FCRqm+NSaV)(4L{8z?vz)

zcy8bk2)nt#^8rUOKY&7w7a;zYANiix2diC*Z)f1;wIH)`AAnybcT4 zS8Ru7d_GtaZMLAMQ`N|tN{U$-JHZ8?@b74cC3v^Lhll)K;0&qOd^ST3$8I$(wwqtX zz*et8W;?4pNiO*>fkSEqDa^#$!7iN_Fb<9|w6&O^mc=ZEWgRo?B>WLr+>=m^D~e~w zQvJ_@t*@QYyHf46(f{;94!15PpSof_z%uW^d)14VuKBE-~%7>7e3&FUU~NcpwqP2yn(29Azu6^6I?>aOgFtoZi6xgTDr_g)ftE~#oQt#N0iy3>>J@D6NW(a8yBVYp9+H40Qy`BK?Qd5vXc*#BJ ztw8`pv<47J?Wy4eZLJ~ZMa9?FYBMs1_VdHqI};NVwYND)KjY9q^#mO!xa0&DcX&MT PQK*6|e3%@*b$a?YEkXoR literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST new file mode 100644 index 00000000..e0569c90 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FTRUNCATE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FTRUNCATE.TEST ;; ;; ;; Syntax: (FTRUNCATE NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group ftruncate-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq ftruncate-result1 '(2.0 2.0 2.0 0.0 0.0 0.0 0.0 -2.0 -2.0 -2.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq ftruncate-result2 '(3.0 3.0 3.0))) (do-test ftruncate-test (and (setq ftruncate-test-result1 (mapcar #'ftruncate arguments)) (equal ftruncate-test-result1 ftruncate-result1) (setq ftruncate-test-result2 (mapcar #'(lambda (x) (append '(ftruncate) x)) arguments-option)) (equal (mapcar #'eval ftruncate-test-result2) ftruncate-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL b/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e5b3fe5060fa6b8d612d56e63663bd159eed72f9 GIT binary patch literal 775 zcmah{T~8B16urBpACy8`qKO!z6B1rFPGcKTtS^qsv~1bVmf2a6$EICulR}$*m>455 zKKQgo3z6(<_z%7!Mjre_{)0MO{2=(?)7&}t&bjB@J0plb(M_axcDt>%+e4k5ymjdJ%9>GoP}8LY0# zYp$@8FDx%-lSN{i=WPFdlP}~}3U^kr$?@@#lI{RN9nQjI8Xyf3@DIGSCa5iN(J(1y zq(U`+HJMBPo+b`w{AX>GbxQW=M9GreRE&jv%!Obcml>test>12-6-imagpart.test ;; ;; Syntax: imagpart number ;; ;; Function Description: This function returns the imaginary part of a complex ;; number. If the number is a non-complex, then imagpart returns the floating ;; point zero of the same format. ;; ;; Argument(s): number ;; ;; Returns: real part of a complex number or zero ;; ;; Constraints/limitations: None (do-test imagpart-test (and (eql (imagpart 198) 0) (eql (imagpart 2.0) 0.0) (eql (imagpart #C(3 8)) 8) (eql (imagpart #C(2.0 8.0)) 8.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..eb99080e7a9076ede7950254a0339d1386433012 GIT binary patch literal 2150 zcmbtVOK%%h6uvXg!-*4jVoch&k4#OIwpJ$Kw1qSj@MLlwn~Z1Nc{GUxibCvSw`mgP zfv8ZUs91o6rPf4^=C9 zdbHWBu}sZpCl|9B(OSwbWF{~6h|!axJU5@8hCzQnOrrxQ`UZ|4?`@9Drdnb9&zQb} z=!t=7UvKl~%{5M#C4@|oGQOG!5r~I4UlfIiMNLbJCsitGa*9Trl2i0TFOqFi!zs4) ziHoyy(scHN>@>D>VS#XjI9H3_xUDHxQrDbSZiQ=ct`u97nv{mtFyfCVl$?&fm$Cj4dH57R$O>J{Dp6CtJCr@DWH=ODCnyJK`8#(>>R zNDGkVrw)|wa7Im1?r}A#cXSW1h0ZN|4eVs zg(iaFt^0Y1yZvZN{PGUD3%S5|RD}F6{rY)1!|Rhwv>cq zP|G$zM~W-N26NoBXo}~-BUn+YqEcD2(^6bFQf7p4Jooo#OOG(0rv(fzxa!{0n`Wm5 zsbM}hK^1@F+Zla_T71;p7LHG+?u` zh0_OEf?^v6)oM;H92xXF#d-beF<)C4WHH<}P}M8Z}AD@0G}J zAa`)5TVaNU&a=Jmuzfuc9yF;Hm$sF7kiF!`8h!?f`m~`BYdHH3O6k~%P{Pfw6#o@Q zxSNU**WoT}&~Sa-<^G%NHz*v2Jz*F!Bg6?-qAD2Z=iWF_8on+i518X59&P z_#`{r#X3VwY((mBonohzU04*u%W_yeI|<)~jF_LPTH52Lzm!a>6r!IK|NP zyY|aIKz;Z9;52Ivf*` zeeE2MH^BuiuYYXuJKwobudSEZ-4L6xKlw_iVCz6xf@L&>q@ oEZoCR9c6EHu{RI0FyY(XP4Kx-Qs-)b^}r4@iFK3fgPWUw0hpI}(EtDd literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.TEST b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.TEST new file mode 100644 index 00000000..f4c0407c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: integer-decode-float ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 21, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - fixed (COND ... NIL) to (COND (T NIL)) ;; ;; Filed as: {eris}cml>test>12-6-integer-decode-float.test ;; ;; Syntax: integer-decode-float float ;; ;; Function Description: The function integer-decode-float is similar to ;; decode-float but for its first value returns, as an integer, the significand ;; scaled so as to be an integer. Integer-decode-float takes a floating-point ;; number and returns three vlaues. First value is an integer ;; representing the significand; the second vlue is an integer representing the ;; exponent; and the third value is a floating-point number of the same format ;; indicating the sign. ;; ;; Argument(s): floating-point number ;; ;; Returns: First value: Significand (integer: f) ;; (f < (expt b (float-precision f)) ;; or (f >= (expt b (- (float-precision f) 1) ;; b: radix for the floating-point representation. ;; Second Value: Exponent (integer) ;; Third Value: Float-sign (1.0 or -1.0) ;; ;; Constraints/limitations: None (do-test-group integer-decode-float-test-setup :before (progn (defun check-decode-value(f) (cond ((and (floatp f) (or (> f 0.0) (< f 0.0))) (and (< (integer-decode-float f) (expt (float-radix f) (float-precision f))) (>= (integer-decode-float f) (expt (float-radix f) (- (float-precision f) 1))) )) ((and (floatp f) (zerop f)) (and (integerp (integer-decode-float f)) (zerop (integer-decode-float f)))) (t nil))) (defun check-decode-sign (x) (cond ((< x 0) (eql (float-sign x) -1.0)) ((>= x 0) (eql (float-sign x) 1.0)) (t nil))) (setq test-decode-numbers '(0.0 -0.0 1.0 3.0 7.1 -10.0 299.2 1024.99 -239898989.9))) (do-test integer-decode-float-test (and (setq type-value-result (mapcar #'integer-decode-float test-decode-numbers)) (every #'integerp type-value-result) (setq value-limit-result (mapcar #'check-decode-value test-decode-numbers)) (notany #'null value-limit-result) (setq sign-result (mapcar #'check-decode-sign test-decode-numbers)) (notany #'null sign-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL b/internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ebd1d96204b29627656b882600bcaad0f260a8db GIT binary patch literal 1594 zcma)6-)kdP6uvWQvuWC7lWZt$taWU&rHng~lwIA;qB5P{w6T-9aei#JAe54(CX(Hh zHdRC{wHEau(5+>cxs?Uk2SE_*E`k(Sg7{j|2k}4fUGPWZ{lU0W#>r6s_n_cdnH4`x(tHgP@ax1R76 zR*DO?;-X})6;~G*-n%3vuSx3iO1T1yt5?BHrmjq+E?-Xg)2gMn+0M+FNF}eNCSFeX zoA>Vtp(-JyKpOb!AtXdR#Qm%ul5J|)N;;!c#Za?Uc6Z#m5B8!s7B$^^ctWaGmz7HK zoni&Ib8D3dgt&L=zO-X#c7_@5uCO8Wx!d(X#!zywHFcU2(Rajx>;kNl6Us|UmQ9iS z_xziL2#s(^L?z#s9?uE~x5?%Yvtm9L3k%+s%%PUd!f>Pf_$@*ro970F(!qSN!Gd7^ zxub8h;7^3?ls;j>Sy2eUa(^%{VJi52g!B>8C>KT=4~6U#RfJzURebp&U@Of>;EBT1 z56pKyVv+qz7|w!7iD1NKQPw{OF`u&jQfxj787wG5?*6ZZ_=AV!n|%CqqH!RBHlIQA zTVd=`IX`wf1qF)vfd(7s_Ux25N{=p70&L)SAoUVb34p>6*}xh6-xbF1=Ew8HhZ`mQ z{qJV>pVmxh?dvfp-zbIf1K+I=$r>}JGB^dwjA~5j)Kn%jfEd%3EP8p5*bO5VmNnJZ zW)zd!jtL{8wPws~%~>|hiXucr+e4`7R5hHOl4fSslDQxX|IN0U%zHh4-s1^^(+?A+ zsOGejrG{-Ck1h_K=REiW=r^h5=r#{|LNKI3nVKdu73SDE$Cf=|i0YG7V@_$|Sk@B( zEQpz{qoJu5wIKTfpy!X#W6~(VVUsz=QFzDU)BS>(0CKwM4OK_u zYcRaHan(liD`eFi(}aDU98NBvZx4LYlg6XIws_v6odhQF;)@uWf^XE7&fGM?Ab;=} zzP`XhYA#2Osd@g)n|vtCpABH}x8Uf`nQYoX>q{u&>+F_?5ZcCoR+rHF814YCfr4B5 z-{o;cUxA9=w9ZsJHwO$SU9{li=Xhw6k6z<(na9sz^aHp4oLyY4Nh9m(h_ti-SLC8p zzTLjv5L>?pVT41=ptc9(yzPGO?&8P{YbI4~syx*PJ!4Z-)h*tOVW9U7huM^mI&M9Y znxxQR+P=kFS99&ScBkmNbtEJ4yu0faJe$pC^B??cZoPVV`196lgM2Rr9$@#wmlVCML>TEST>12-6-MOD.TEST ;; ;; ;; Syntax: (MOD NUMBER DIVISOR) ;; ;; Function Description: ;; MOD performs the operation function FLOOR on its two arguments ;; and returns the SECOND result of FLOOR as its only result. ;; Similarly, ;; REM performs the operation function TRUNCATE on its arguments ;; and returns the SECOND result of TRUNCATE as its only result. ;; ;; MOD and REM are therefore the usual modulus ;; and remainder functions when applied to two integer arguments. ;; In general, however, the arguments may be integers or floating-point ;; numbers. ;; ;; ;; ;; (MOD 13 4) => 1 (REM 13 4) => 1 ;; (MOD -13 4) => 3 (REM -13 4) => -1 ;; (MOD 13 -4) => -3 (REM 13 -4) => 1 ;; (MOD -13 -4) => -1 (REM -13 -4) => -1 ;; (MOD 13.4 1) => 0.4 ;; (REM 13.4 1) => 0.4 ;; (MOD -13.4 1) => 0.6 (REM -13.4 1) => -0.4 ;; ;; Compatibility note: The Interlisp function REMAINDER is essentially ;; equivalent to the Common Lisp function REM. The Maclisp function REMAINDER ;; is like REM but accepts only integer arguments. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group mod-test-setup :before (progn (setq mod-arguments '((13 4) (-13 4) (13 -4) (-13 -4) (13.4 1) (-13.4 1))) (setq mod-result '(1 3 -3 -1 0.4 0.6))) (do-test mod-test (and (setq mod-test-cases (mapcar #'(lambda (x) (append '(mod) x)) mod-arguments)) (setq mod-test-result (mapcar #'eval mod-test-cases)) (setq round-test-result (mapcar #'(lambda (x) (if (floatp x) (/ (fround (* 10 x)) 10) x)) mod-test-result)) (equal round-test-result mod-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fa5a2d8adb6c37f44a0199c90d42ff2fd9e726ad GIT binary patch literal 777 zcmah{T~8B16urCspp??IL=!PaCnUUVoF;9GVtsMkPD{&n7G`Hf9!a~{CWSWrFfm4A zeDG<{0DWmHAvvWrju(0d)-#s>7mYW&>arY zZl{O(onf!;pk0Zh*Sg8+n>C`ZXC7zc)}>0l=j;re1`cR6%0V;T=A5!i zLHNo;iQo9=LnjuUvio!4qO2t^#)*R|Uj#P^RMJN#QkG>_Q5G~Z7X3x_iRa!EPJe)w z4#*PP-I2etfm-|14;5es%Zm5aJ5ptXyE>;tP<%y$Q4uml!}8~XYqHO#Z3^n&f-h)1 F{sY+_=uQ9t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST new file mode 100644 index 00000000..b7c60994 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NUMERATOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-NUMERATOR.TEST ;; ;; ;; Syntax: (NUMERATOR RATIONAL) ;; ;; Function Description: ;; These functions take a rational number (an integer or ratio) ;; and return as an integer the numerator or denominator of the canonical ;; reduced form of the rational. The numerator of an integer is that integer, ;; and the denominator of an integer is 1. Note that ;; ;; (GCD (NUMERATOR X) (DENOMINATOR X)) => 1 ;; ;; The denominator will always be a strictly positive integer; ;; the numerator may be any integer. ;; For example: ;; ;; (NUMERATOR (/ 8 -6)) => -4 ;; (DENOMINATOR (/ 8 -6)) => 3 ;; ;; ;; Argument(s): RATIONAL - a rational ;; ;; Returns: a number ;; (do-test numerator-test (and (eq (numerator 10) 10) (eq (numerator (/ 3 4)) 3) (eq (numerator (/ -10 4)) -5) (eq (numerator (/ 8 -6)) -4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL b/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..62b206bf95fdf426a1faa45d54f56eaef4b2b9ac GIT binary patch literal 824 zcmah{T~8B16urAkODTmEqEXSvi1B6PkhFk-`ZO+6C@i}$I~yP-CZyfEHH9|)Ffm3# zc;IP`79!b|@E?3dj6C><{0BHwPzgTxG&ASkd+t5wP6uLZhKY>YX1!AN8mQK8)!Qvp zt~F4z)@~F%R2DdTYuJpwn14x4g;eL?TIdwSB7fgyR zvPAW;69x&P1-lMqVK9_Mty&#dz1Ln<%Gqp!0uX)-5_#7$c)_;917$}^g&%@}f`ylb zG%`m)O=tk|8zk)*#hs|g1S05GNi;L`UBwT^6XT0 z{2l-FCBX1*Z%Xk`zFXq{v$Oc#5?LL8&stEG0f2q~%gxoULJ>{?qyWw;#o>;huB1VY zg`a|Zx?x+h1vvnoC)TV<8Gcp}h&AWvYLBpDNH+*K<}st(WkQP4^&;-9JDe`5%D)-h z)}wx{H|o<8LjIsm8M7I-UB2vcUF#DCDV;eK%!lUp& k70vG(j1o@qwfW2fr;M0R)GyOSvlZ9oG`bC+ADo~60&LCo8UO$Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.TEST b/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.TEST new file mode 100644 index 00000000..7ac2c6a0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RATIONAL ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 214 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Jan 28, 1987 - Jim Blum - Substitued (= ...) for (eq.. ...) ;; ;; Filed As: {ERIS}CML>TEST>12-6-RATIONAL.TEST ;; ;; ;; Syntax: (RATIONAL NUMBER) ;; ;; Function Description: ;; Each of these functions converts any non-complex number to be a rational ;; number. If the argument is already rational, it is returned. ;; The two functions differ in their treatment of floating-point numbers. ;; ;; RATIONAL assumes that the floating-point number is completely accurate ;; and returns a rational number mathematically equal to the precise ;; value of the floating-point number. ;; ;; RATIONALIZE assumes that the ;; floating-point number is accurate only to the precision of the ;; floating-point representation, and may return any rational number for ;; which the floating-point number is the best available approximation of ;; its format; in doing this it attempts to keep both numerator and ;; denominator small. ;; ;; It is always the case that ;; ;; (FLOAT (RATIONAL X) X) = X ;; ;; and ;; ;; (FLOAT (RATIONALIZE X) X) = X ;; ;; That is, rationalizing a floating-point number by either method ;; and then converting it back ;; to a floating-point number of the same format produces the original number. ;; What distinguishes the two functions is that RATIONAL typically ;; has a simple, inexpensive implementation, whereas RATIONALIZE goes ;; to more trouble to produce a result that is more pleasant to view and ;; simpler for some purposes to compute with. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test rational-test (and (= (rational 10) 10) (= (float (rational 3.1)) (/ 31 10)) (rationalp (rational 3.1)) (= (float (rational 3.1)) 3.1) (= (float (rational (/ 3 10))) (/ 3 10)) (rationalp (rational (/ 3 10))) (= (rational 3E3) 3000))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..863ee24d81d2942a9c2e0401ba5972cdc1abbcd6 GIT binary patch literal 809 zcmah{T~8B16urAkOMyZbqVY4bk{FYXL()nOmZx!<{0BHwj1qkCY3`gm_uPBVoi3!-EZeZ^TaB>hH;sCy-RQK9 z&3e;l)jQ3KZ)^(Ocw;$?yq(9^;^a(j(7lwYH2saXUp08gZ&f#5KQeMp4cuskH4#it zi)*e}$QP%kCI?H{wJ+HITaz#53dKTUa`624NYU#6P=Paf3;^h$LA)R7CMPaOrLs*B z#Y@DDyK$5eT9D@w7DuCbqg`*Hn*YkLNjY0BPyphOQKsZkinPyv4ba!%??@f=Q)oABxW`S~wCY4V!@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST b/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST new file mode 100644 index 00000000..d58a88f6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RATIONALIZE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 214 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-RATIONALIZE.TEST ;; ;; ;; Syntax: (RATIONALIZE NUMBER) ;; ;; Function Description: ;; Each of these functions converts any non-complex number to be a rational ;; number. If the argument is already rational, it is returned. ;; The two functions differ in their treatment of floating-point numbers. ;; ;; RATIONAL assumes that the floating-point number is completely accurate ;; and returns a rational number mathematically equal to the precise ;; value of the floating-point number. ;; ;; RATIONALIZE assumes that the ;; floating-point number is accurate only to the precision of the ;; floating-point representation, and may return any rational number for ;; which the floating-point number is the best available approximation of ;; its format; in doing this it attempts to keep both numerator and ;; denominator small. ;; ;; It is always the case that ;; ;; (FLOAT (RATIONAL X) X) = X ;; ;; and ;; ;; (FLOAT (RATIONALIZE X) X) = X ;; ;; That is, rationalizing a floating-point number by either method ;; and then converting it back ;; to a floating-point number of the same format produces the original number. ;; What distinguishes the two functions is that RATIONAL typically ;; has a simple, inexpensive implementation, whereas RATIONALIZE goes ;; to more trouble to produce a result that is more pleasant to view and ;; simpler for some purposes to compute with. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test rationalize-test (and (eql (rationalize 10) 10) (eql (rationalize 3.1) (/ 31 10)) (rationalp (rationalize 3.1)) (eql (float (rationalize 3.1)) 3.1) (eql (rationalize (/ 10 5)) 2) (rationalp (rationalize (/ 10 5))) (eql (rationalize 3E3) 3000))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL b/internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..859b2eb7d959929d509452cc87282abb1f8bb6d9 GIT binary patch literal 775 zcmah{T~8B16urCsE`=1Li5R035?(e=<5onhFOJLfi|s7T&Wb#evb9YLZTewijKuih z(;6*Ava8`g_=*^L@DKS9aJDECeDG=RoO|cobMBoH#GV=^GCJGcR@?2N&T!Bj4p5`h zL;cRMS9eiE;^?Jear&xEjFsF&J#Ame)O+scz}-S(==QfZU))Ce14O#LR$B&3OY*80 z?&S*$3%PWW*yb7Af8XQ_`eNbE-CX+g@Ic9S0H6*h;gJH!LInIhFRKY^3tX(26f;tz znm_Wrr1XLvn{wZq&Z9x6i`(vVw;kHq?t=p0fAEq;hZ&+`F@Ilqtz`W7-eiU0RcVcs zD5%NbEFrt%duct77cr;ATqRt<;X(XKsN-w%xT+lOz}mN}x;}M%T8Xuep8?FgNo17f z(RU`}pQDv`><7T8`Ic2xWfEYo`Q_^R*o{ml0Wtt5t@_NUnQdi3jrkwF8=7IU^GQKoAY*6{$*+c+uiDB1&O1!{MB=3wsEZ z`x3wM*M~uDdd411M3-eQ{b!muobmbE#_N>qv9XeQxv4k{`cml>test>12-6-realpart.test ;; ;; Syntax: realpart number ;; ;; Function Description: This function returns the real part of a complex ;; number. If the number is a non-complex, then realpart returns its argument. ;; ;; Argument(s): number ;; ;; Returns: real part of a complex number ;; ;; Constraints/limitations: None (do-test realpart-test (and (eql (realpart 198) 198) (eql (realpart 2.0) 2.0) (eql (realpart #C(3 8)) 3) (eql (realpart #C(2.0 8.0)) 2.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL b/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..48f2c106143ce045a3381a926d128f4172f681f2 GIT binary patch literal 1594 zcma)6|7%-S6uE@`zJE0t=oF4fi=D{Bp@RI5v?wY7SoD3t)0KG2v+Kb%*!g~_W4zx9-* zP%kbuip!F{R$N_PdjF!7n3mL)dZh}&l`EholCMrBFI}4Sr&LStu$>w+l}ubtzA`=O zKfHHG2-OH71=7M#A0Z*)A@1kRkZe=SR#Iu5Du$Y&vb*CpeXthAv8d@b!&6eDwxU#v z?-r}LoExh|AjG}Z^raj_v(wCQcZCgMz};>J(uR_SrKxk2h`uK*$S#1Km{Kk)Ce4t0 zcl?`#2(55P#7e#|KVA^_Z<5U)7Q|dE78bniGKbq`7Dif?$8Qr7**tSzDDUTkEfxgz zuN{4x1%D=Fr~D}kE{H+^#J%%52}8l|BV>S(R;4i7dMIR`$|C&Q&Em@q16w&CfhP*j zATZzhm__z3qB{#BC4v!`McLpu_MjnylTwq)Kq5DfEaU@EP8pL*b5^TmNnJZ z=3)13$Al5l+B4?07A>1*L=ilqogvh8sv1sKNij2H$y^YH|3=$P=KUT&@ACw~=!c0? zRCCVBP{X#4Mi+<9a~A9Yw42m&beo4fAsEu2Oih!S3UlnNW6Pc}cn!#^v8c3hOzVjN z7R1Q*(a=(6dMA5or|Qu*n=_w&UJ4xXn=FnWN)}!Q?%7Ui$F}>_a&{^qQ)p z@---4T)1kZ`W3Qjj%mWWjt?gn&~_JW(c{KreVyWYn|216#0xK@XA<_PCzZZ#f}}H^kO2fE(e^GRWnYVO^4Z(k2!90 zGC4z`!L)OWwXf#JQSNTib?ZqPlP|ivUSabPex3K$>jwwFZ2btY7+8Sa4?8KM!`~?Q jQTnHgbd@djTB#%ey7dzZJ?-kb3;=(LkCD4q4-fwZQ3mpS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-REM.TEST b/internal/test/LANGUAGE/AUTO/12-6-REM.TEST new file mode 100644 index 00000000..81271e5d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-REM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: REM ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-REM.TEST ;; ;; ;; Syntax: (REM NUMBER DIVISOR) ;; ;; Function Description: ;; MOD performs the operation function FLOOR on its two arguments ;; and returns the SECOND result of FLOOR as its only result. ;; Similarly, ;; REM performs the operation function TRUNCATE on its arguments ;; and returns the SECOND result of TRUNCATE as its only result. ;; ;; MOD and REM are therefore the usual modulus ;; and remainder functions when applied to two integer arguments. ;; In general, however, the arguments may be integers or floating-point ;; numbers. ;; ;; ;; ;; (MOD 13 4) => 1 (REM 13 4) => 1 ;; (MOD -13 4) => 3 (REM -13 4) => -1 ;; (MOD 13 -4) => -3 (REM 13 -4) => 1 ;; (MOD -13 -4) => -1 (REM -13 -4) => -1 ;; (MOD 13.4 1) => 0.4 ;; (REM 13.4 1) => 0.4 ;; (MOD -13.4 1) => 0.6 (REM -13.4 1) => -0.4 ;; ;; Compatibility note: The Interlisp function REMAINDER is essentially ;; equivalent to the Common Lisp function REM. The Maclisp function REMAINDER ;; is like REM but accepts only integer arguments. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group rem-test-setup :before (progn (setq rem-arguments '((13 4) (-13 4) (13 -4) (-13 -4) (13.4 1) (-13.4 1))) (setq rem-result '(1 -1 1 -1 0.4 -0.4))) (do-test rem-test (and (setq rem-test-cases (mapcar #'(lambda (x) (append '(rem) x)) rem-arguments)) (setq rem-test-result (mapcar #'eval rem-test-cases)) (setq round-test-result (mapcar #'(lambda (x) (if (floatp x) (/ (fround (* 10 x)) 10) x)) rem-test-result)) (equal round-test-result rem-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL b/internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28ebef26420618853eb1c7df87af799322f9b91f GIT binary patch literal 1612 zcma)6&2Jk;6rbI7jP2O&+E@`WA#4*9g;m$cPN-5N(QG$k$IWKf><4beA&MNkHgf97 zaS*5?s)8jrtdxX^vXiPvaDxL%5toXBBf+r;4*VfpxB=nKx=pGOskOB;^S*xXW8S=7 zG;mE(1*NsR)@WASLTjV5w$Tx4t+ue<+Gtm*LJj!BEk!r*$MdqXkbWx@GM|!E+STPw zbw#i?s_QGuA6*bKmjrpO-DtvLW(LSi?#*m&dO97-%cj~#d!|h`m${hBPNhRf_wF!! z3n5fNJ-P)E;t_}3&mCU0uxUy8qKYL=Uc{oi>pB6*MY2t7xK1o9bXsdtv-&}`Nz++f zM+`#ljuXh+nqn1o&D~>eGhuhzi4--d1gXgdjM%_q6pGHcP9&3+E=q=OYjfz{o#+-q z%#SgirLp`}f4IOrxQTXtUSP{FC1Z@=3pD8kS{dnYqy0_jH6GqTD8BW=FjIf96z%Cz zAphJ|xAo|+2<_HC)uRh66M^HwaCwXZfjodv7@=OHlIq=Orl0c3{Px6WpqvD>`cfRe z1bjn)yz_}3KbX{`3{;CU;;x?1hbBP&nLbocE+s%)kFsEQ@JD6hoBL?LJW(Eb1c&YN z=-Fr&sB=Js0H1;Qdu8$mT%J4|<~f5Z3y*Hs>HoQFHgs0apn_MEP=j8br}z4WGa@Rw zHdmyVFU`x^oQe(UN)b3(!4z3P39mG&7I1zE^zGVp5Js+A!; zcMh2Rv4NzQXxzZ(Pb+7E8G}BKir6r8L(*-lWLqK^2gR@`Yu6=@PebHh1YW%F$$LL1 z?h5CR>Dx( zHpmhuSE9%!?uSYSsrWK^88-Ac1(ZuAtj$sKJGe++zIe@8B_r>XSKcF|L8|;MXbqGM zy`WL*E+9uv(j+`(cBzV23QFCAS>V@boL<;XlDYv#gMA|t?!H9$5*aU$)C@^^F1~b~ zSFP%LM;P0b$AsE448|3qakD?uC~xyM07id7U8pAy=|lIfyGMIwR57q@Vd+%5YSF@m zteRwys)5xzwr*iEUU8jt?h1xF;{NpVMsnxa`xCdD=Ho!pZ@7CL=kra%22kfCu#D3s z6*=$jML3p)@wasZKf3&Ty!?{{X?J#_R_o3R2z6(N$$t0p)YMe>Z33rX=+dL)Ar%}_ Wl|xYWd3ll7!2uD;INHB-bo3wPNAdXp literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST b/internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST new file mode 100644 index 00000000..f360a1cc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ROUND ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-ROUND.TEST ;; ;; ;; Syntax: (ROUND NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group round-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq round-result1 '(3 2 2 1 0 0 -1 -2 -2 -3)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq round-result2 '(3 4 4))) (do-test round-test (and (setq round-test-result1 (mapcar #'round arguments)) (equal round-test-result1 round-result1) (setq round-test-result2 (mapcar #'(lambda (x) (append '(round) x)) arguments-option)) (equal (mapcar #'eval round-test-result2) round-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3cea44d2479e42f7e514a8acc2d0bf763a3c4267 GIT binary patch literal 2026 zcmbtVUrbw77(e$GxalP+RAKRoCm&mS#9tcfG+QLI zEBTpneonO3@~d+*@0=BfUKHi!mEr;r7cRhcX!QBv(R1hGohjK=8{QsiGdwzUestu8 zc<0`YElwyALS{)Fj}Afv;vvq*RUu|k(~?qYl}ehNp)sfCRDBSOWSi7*s-a=ATw0bE z@^9xCFr39z!V%(JtNK#5rdVlRb2hmO7jUjtyV9DJh0x@Sl<>ZNFX)|fs>0B)bY3zQ z8Jfu6Ux*N3hAP;uiKhE~GIxF4=&)rv! z9OVi-Al8F${k^7M)q~#?QY(C*2Pb$AUaf8S=1w94koyP;0FL6USpSwAY=O=F*@W%? zH;`vh9e{$%M*zM1cv1G>RCE20=OTJN7tQtEsT3-O|D2_sf65Z%?9~XArd|*T?{}_O z`(lc&CDYh9(zvW8Rcc6MY2auV%^2@x9eg`9Whkb|mNG6G)Upj|D#h(euQ_E}G{f_t z5pJ}tqEcD2vrf%Ja^dI(qqi;34q|qmj078J2OTN^I^MVqk1}7hbIV{PtnON zRVMQbVJf@D{EUZj{pXNn5<1nE+27tLcr^3ea@XSMK)b8 z-5@=BNNP~iRxKvrv>X_^z!5@N8%|m$4$aSiqKyJ5yzIioiwTe|yxs%fA;mTfs~C& ze8KwGpw?lNS}Dn#%8co%)Z7;12;o3>-G#t}GwhTL<0tUlo;CD~8aU(bf`M=_S4=?B z4l24i$J;h6C9j5gaMSW7iz1eb7FC+v3ZfVej4q5gQ5Toe+xon-*P^4HnCApDh8D;DjmqWnzpDR zt0wcK8iethty{DKkKmA+;s@axG zPa50_puBFqvb?YX`lMrHqynFW=oXO@T)U@MtQ1&+=SD=NDutUp2`+)#If0uG1n|Er zz&iLJK-#l%+AuwX0HzIE#}YANE{Nkm`CUpf@C1 nCIM5$Z^-fad6)AFD7!@J^Own7n_ETpEU2&;8z7&i_xAn*mw;11 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST b/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST new file mode 100644 index 00000000..0960caca --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: scale-float ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-scale-float.test ;; ;; Syntax: scale-float float integer ;; ;; Function Description: The function scale-float takes a floating-point number,f ;; and an integer k, and returns (* f (expt (float b f) k)). ;; ;; Argument(s): floating-point number and integer ;; ;; Returns: floating-point number (* f (expt (float b f) k)) ;; ;; Constraints/limitations: None (do-test-group scale-float-test-setup :before (progn (setq scale-float-numbers '((0.0 10)(2.0 1)(2.0 2)(3.0 3) (3.0 4) (10.9 3) (0.5 3)(19999.0 100))) (defun expected-scale-float (pairs) (if (and (floatp (first pairs)) (integerp (second pairs))) (* (first pairs) (expt (float (float-radix (first pairs)) (first pairs)) (second pairs))))) (setq expected-scale-values (mapcar #'expected-scale-float scale-float-numbers)) (defun modify-scale-float-values (x) (cond ((and (>= x 0) (< x short-float-epsilon)) 0.0) (t (/ (fround (* x 1000)) 1000))))) (do-test scale-float-test (and (setq scale-float-test-cases (mapcar #'eval (mapcar #'(lambda (x) (append '(scale-float) x)) scale-float-numbers))) (setq scale-float-test-result (mapcar #'modify-scale-float-values scale-float-test-cases)) (equal scale-float-test-result expected-scale-values)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28b199e4197d3b5210169098e263f7642f104990 GIT binary patch literal 1659 zcma)6&2Jk;6rWuu#&&FXZA?T=2;0zDk;w+xNvq&WG~3O@F0x!n}Y^@g}r-)xHwR=QbupQmot^eA%7)rSd!|h?mAI6;2sWL&w>hDX z5GtZJ+q?(~$c5}LEFo@U!;}^?DwZ@ki{tizZFwLUDQ{riwn9mKdur4LIrmd?f& z;t;a;Eze?JQ_Kv}>_hGr=ePH)Kt_{tkeZyvi1$1}Vd$J~`4UO#l4R;&BbylAy&c>| zi2ETV@GP7kE031Bhd0pvPs@DaKoTiIfE*Qk8f4j|G8^6d{)h%g6~A32JMQ#uJ%i7G_DYB zA;a!pT9UN|73QH4{{D zon!pIjYM)Rbl?kT=qG_6f`$&pv91$cB6%~HH{-4_==$Tbc1?2lEKt{rzwfZ{7_*!z}{1Uy^i}3!T^3xRvGa%5N=i;*<|EBKn^K+U55&sK3>W( z*&fIur`My%2JQw-hnV;ZeFZl37Xy@YIjk)(@;fl{8ofkVO+zbKCo7UdvRSxfHDly9 z=;#OZ)%WR`m*IR10E0Q5q%}s}0efH1Tw-;g0^_%smQyZ9-Gss6)>sx!QZ*X84tBx5 zodJ!Kqe6~Oq-ku9#vDgq+16`jX{#xY@5tj~c?|~Xx>&u@oq>$EGXdD>PbeHX^Yp+z zvhUc3tjER_9mCLpOnM#bltj&#SeI3U4ly-|^4&Z!F`X#d)^zGBhFat9z;mW}vmZdu z^N#T(mgzU`Ll^ueVFRf10a#vV%Z0#s`!K-sJVb|fJDtwor%Mzht@&8F+?p2=YR!+( pqt=y~nVHtx6iz?0rOn6_COBa#C!jpw9a5_aN(9z{i=N~ZS{b2wA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST b/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST new file mode 100644 index 00000000..cdd5f735 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TRUNCATE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-TRUNCATE.TEST ;; ;; ;; Syntax: (TRUNCATE NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group truncate-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq truncate-result1 '(2 2 2 0 0 0 0 -2 -2 -2)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq truncate-result2 '(3 3 3))) (do-test truncate-test (and (setq truncate-test-result1 (mapcar #'truncate arguments)) (equal truncate-test-result1 truncate-result1) (setq truncate-test-result2 (mapcar #'(lambda (x) (append '(truncate) x)) arguments-option)) (equal (mapcar #'eval truncate-test-result2) truncate-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL b/internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..96059e25d609ff9a9353ff98ad625c6807085bf2 GIT binary patch literal 765 zcmaiyT~8B16o$`kKUmsA3eiN2(FqAR8>g`irciGjm+2SFEX>Y|T#~Z2O$yue!^9Yg z@xrS$T8Ly>J_@*m)AF-qXVt3CUknfILMoEbslnPDQs+wHbHZV!3GL3cPn zO|OUg-muqjQB&&Zm0@xEx=M`I+@pNTzLaV7-0gw8gT&D7?`*%kkMhfibbIZN43?JU zZ@%=fP+DBfrOL!MFWmlnr%=ilOAnTFsq^C_CF=n|1J0t)BtRBo5FGefT~J%#a?PZe zku|CZqrlfB3wCVE1AnG~23{9;+!t;q!rASE0uX%kwX(wuQL|WZsJu}!!3Te;#_+mC zBNYm&_Qxf1S7e+o;36h=6^@URPooyTwNC5G$sTNcudAEWw`Y_@`}8@$?AwWq(mMIU zWc+Ki`kws+7`5K9x~fb89JIdP+#G|*v<8p?IBPd%N3Co-3u+?x=h6#&DIe z6_axOq$U+sv2`^riDz_!2&0NQ6%Lmj8)M|8y=4o!rYhG@2ulysv59aprb)_aopNq* zY&l}x5qfM=UdZT#ZQ-$Q>!HNW=C4d`A_fq~qfy1`(j-~7_!<$FsF>k!PT8dugi2BB zH~w)L#HJVSVLHAdbDA6^jwbteS>q*2cml>test>12-7-ash.test ;; ;; Syntax: ash integer count ;; ;; Function Description: ;; This function shifts INTEGER arithmetically left by COUNT bit ;; positions if COUNT is positive, ;; or right -COUNT bit positions if COUNT is negative. ;; The sign of the result is always the same as the sign of INTEGER. ;; ;; Mathematically speaking, this operation performs the computation ;; FLOOR(INTEGER*2^count). ;; ;; Logically, this moves all of the bits in INTEGER to the left, ;; adding zero-bits at the bottom, or moves them to the right, ;; discarding bits. (In this context the question of what gets shifted ;; in on the left is irrelevant; integers, viewed as strings of bits, ;; are ``half-infinite,'' that is, conceptually extend infinitely far to the left.) ;; For example: ;; ;; (LOGBITP J (ASH N K)) ;; = (AND (>= J K) (LOGBITP (- J K) N)) ;; ;; ;; Argument(s): INTEGER - an integer ;; COUNT - an integer ;; ;; Returns: a number ;; (do-test ash-test (and (eq (ash 1 1) 2) (eq (ash 1 2) 4) (eq (ash 1 3) 8) (eq (ash 1 4) 16) (eq (ash 1 10) 1024) (eq (ash 1 0) 1) (eq (ash 1 -1) 0) (eq (ash 15 -1) 7) (eq (ash 15 -2) 3) (eq (ash 15 -3) 1) (eq (ash -1 1) -2) (eq (ash -1 3) -8) (eq (ash -1 -1) -1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL b/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ce2efedae4f48db51ea96c66cb2961faa3478930 GIT binary patch literal 10420 zcmeI2ZERE58OP7H9lyU^I}U^Z#bt$tEH{t<1yWw(I5#94J)=p?=kDSOUyeD8JQ zD`8jn+lX{t{G9*)Ip_SYbA5c1Nm8~u5)DNL4h{D8_Y8#wjt&nV9S-#l426yi93ATF z3H3re^lU_mi(hREN4D2JTJKEcjdTt5>>uvw4#`J*j&$$;N^PiqLnu5r)YlK4_3Pnf zedF4O#x-l|oUP$Rlx4f8r=hWaU1R+tb|7@8sc#V03C)re70JsNx1S&+DEoO6UCW!Po7=e? zhfNQ?wcXUYzRJ&8aiL99olX0^Q>lGClmL|Al;oXwUgED+OI{8(Km&Y63P{1_Fn(GJ zrmFS@KrMMq;Jfzwu4de7*JjqVu%?wYZLHbGnkZ{xtm$A)oHa6QcCltRYaV0GUe-Lp znkQNF)KuTi1B3)l*pgi81}sJL!pqMlqh}@WJA_Q8PD$SFCe8!hYYRFX>1JWvPKcY3 zslKj_Q`gH^<#V~9aB+bQ_TAY8)|YbqX6TQlik@$t-h6qJnWvS>+?|{C>DN*@TmhK) z9#`OYSNGNHWU{kcKT%ySQL5_Rseaql`%|&AS3gma?}yHoTVp8$Sy?_+SUHVgl|oi2 z{VkTp>L9Q>sGq1V&mpVl^tV_Vt5IMzs-LJ>RvpH&a@|o_ zl^elo3|WooZ?QC1CxF!n{Y1sGiW|$y8B$mUjbJs7tj6`XSQ@L7!0M!aqGDOe#5SusV&bPU~;6G*)MT)fxRn#j@IEEGyrL!fKuotkTFTt-r<6SiJzOUeHfeEUVqd zvf^J=Sj{(r)daGd(BEQdtj+lYiXwsCxy0ftR*VOh30mM#I`1COjTKjX#tcw7hbNyAd~|9}>`BPt4wDHKLH2Al5*5R-WQWiy z#djoXvYd%4bjwmr)@5Flb(j~!lT>ew7>`SFK}yOUNx8=S02tgg;n*Gl<1~qR3B;W3 zF}bExtQH{zWY=?%bv6Ya!0Szyt662?Wg$%TH7X@c>&s=p%VMSUGznZxgGuNu+qb zrGC~xo}&Q<$|-t$99tu6L%uF$NZt4v2rppkqL-%7w-y8ya|EjU5g44$2J3aa z>tMKi*0AbauQ?lZoEtP}Zdi3T!cZkk3QP(Y{3whEXOFAijd@R()lf`{9{e@yT7xfM6}p!9 z_Kr7&sC7a1()gCut5=V2&O+~PT20ZH({x~(N~S?<$-D#$$kx(I$Sxz7HqOjI+WSAB zi-2iG?aq&KPL7oA|A3HB;2Qs{f7>sAL%w#CaNOTW1sk_-T2VXiN5p*M=_QLN7SdSt z#Gy2C@8ya0z!=kf?%F!D^M6f1=RI*hWDtSCU$SxdqqhGe_^i+lFA?@Z zlnv0KTiKnod4~yK$A*7nww`?`qMpBkdj8u?cp4kuH$l%1Zvs7|&`&Z{`-V~N`x2Aw z#m2i2)VYHf9(7c?w+-dqEljrx8z((y8oZJL^%yHvI7GgQ0& zi89v**m(Y^so95UZsDF^q1y8%ll>4I$4@l1@_CHgbYxKNILl;X*w~*3wKI2Y$Rlp= zN3p$&sbp+yoq6Is+_okZ+tx8vH8xgyhIF&cd5Nt-)LLCAD!Yq~Wk%EH<+Xf_TFZw_ zbQ>G<`=HH{R*r7CKl4pgn_pwHSFtgDS5qqoL{yt5P;ENJWFy#c&w`pAvhol9g1Eaq zA#Xt+*Nr~zab}3JW;1;8u;;!|big~6Yk+{YSxUxQ@TCj#vI8UJl{&kfw? zFpxW#mi!y@kw0bQyC51|mq{;?dyWi;@QlO`M(RL^MeR@~M8XMCh_=hH$Y>(#%H`Ralw=XtSnkU9 zLW)2iJ^CD=lLbPw+c#^LdWie~!wyOPbodaO{U4&)zezRocNDXWEfIErYvkW8aPzOB zoA;}3-+MZ4I=3%d;P#zDxAz~a+k07YJJ{TCUjVQ7P=VL`IC`BoRIhVT@#fIdy9Ah> z;R3UBC7RveQqArb#hjZM?it{9R}^^NX7sxDt6o>-9538K!0Y*>!0Y(~dOd4ZujA7> zUbvrt*YQ??*YN}NIvlFkK0U|F_G_Ok@Y;`~*Y;=CYrCL$?F=+tVOvju)s{f3^}1@c zrsi7d<+W}ouv#BRYuVRTYuQG{YGbp~w|<$kz-jp}IxTxtr-h&6q;s18THrMQ4xMH} zb(;RJICEDP?or@1{j9)i`VM;GiH7of#Ql7Z7w%Z#<-Sqi<-UwwZc*WgEt9TmY!=~x ziOBxv4F8dCSiOl9e$j#{$orY|77mWtw112C;RWr#3w>Atq5ZdMAO3-j_TNA~>t91X z(|n)B(R&s3EDm3mz{~Q(djWE?{O~J5=f#{SX&>?*M=jw-P{(mkW1Qm-;%oRnJZJ$F z{3jh$lpaTW90yvA&G;MXV>VK7;jmb~HPZ9m*ce Rea%zuVB`|b|MASs{{W`n%j*CD literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-BOOLE.TEST b/internal/test/LANGUAGE/AUTO/12-7-BOOLE.TEST new file mode 100644 index 0000000000000000000000000000000000000000..18eed64a7e9d52a6d64690747d3a911cfa898f2b GIT binary patch literal 11759 zcmeHNU2Gf25k6A3EZLSqD~ggRKixU;iyIoUV^-|g@dAKkQmLMnnWq`(mv#=Df-ffq5%rDFD>8*ere#& z?ETRat*9~uCxuVu@oskJo7tJ2-Pxswhsi`apDw9do=6%QQ;4J#OUg``j0pnIwG9u$ zKa$kSdRhsS$?^i>NwTCUS*5Q?qP)b@W`zQTNiZ~ci16B+nwGOfC@8v&z(oS!@pA5j zq8E`pA|GVsVL^QSZ$=BYcu6E^zp<30gPEq&#C!2 zQUYCBD7|54v-V&63Q(g8#SSX@*hEWml4E2|N7kiTNKS7}B*SBb8(3X6L#)7P!_anqYLXo z)T7mfU1f13?u6U+qv^()0aQ;*jhty;Ob{)>`eV;E(0z)qk-++s`b#0jkAQPQs>e}^R&B=2GSua7dV!qlX0FIidmdn9%!K=jrt~OW| zm^Fc&*vOPLivp|(9t{&|p`d_V{uHcYv?Rb)3~&ls9;bM2zNE{vh`5aY=jcQ3Z+vvpoZD31`Bk44&e$KR1xHRimst1 zY%R(;x-949(xBCah_xR3ivg&DuIZg_L%wfbi?7F|r7F3{Ju)>c1^pH{!}Y?k<)-a$PWAO`}_y1FGacmP`9 zR;O)W)PIl+1p@G?-wMKH2xNf+@05# z{9^~h{4+aztZ(G|A21%z-NboTdDd=hz9)^bCH5h&*6n^;O!JQM4 zB)>tKP&oKV7z&4-S6{o}@oCW4G_#CftqkL1nwaWOE53f*p0g7%o@3*YX|BJzSgo`` zU)WTV6RVXyA=oz-*sO9&$zpeMMaIK0)t4$Q6RCI<_iokmo->}^)pM1$Se#8j*CLY~ z<884}5ZzO)+)dYeYvaO>b5UWOV<&haA~COB*!=>-c>cJ@=S9cn`j6!956YXEOHRhCSL<&!YhOL^t$$Ipf1o@N(te{-_WikKs^Zr(o;Gb0Rwy z14?`{+3#&OTD{w09Pa6lMx^KzD{@jwgmDz51F<=IJSlP0UN3NTnjUq2Jimv>O_3r=!~%Z}HUh7$+v35sqz5JB`++b{M_w{hTNYA}ge%L`v#! zx(%dv_ebK#SxQG$O+Hj59ZzuVQxQJJfw9RHFB!h3JIW?CQ=8c!lz))HV)wM%wIt3&i&j|oLHlj`LikcE709pZ&t_~-6xHEzHQt) z0OFl+a5KTKGVuXpUpw0Hdw|%U5QWJ&zAb?%ch>`CG1#W@KSv1~RFrrH=CbBE`j@)< z$3`Dg%fPcOp5iI3*YE?4`3z_+7Iq>7iuPVt5epWl5{Bad(7zDZ|vl zr&`&Ihr^`j`A83$mFa=1nm4C(q&>fXq55j|JdXMMqaqiPICfP~`IrO;XMEDwg>2B9 zCsTsN8ND;r%3yemgVDm7b2VLnXys3p*;<}YT6zZ$RL{4bg}yQ7?eR14G&+j6&kr6v z`#Sc4DGUHF~~d^h9vjaK{qTVR*RB>{CMIqOl~*enUXpWzxjR zc9nY_LWz^UB!OtI+dX*DVj+^1#>5 z19%J<3=lsYbd|_FoNkcTHaxw%{&hmrvI+}w^e6^Sn({L$J-C6Bk=0UgKvRYTA%9LT zq-CA#>r>!2BvOlTdx_PRVmVt1kTud4n#*o+f+FB`&W6l(RnyU+>3(Rj&A>w<;x8(t zXDyu;Q>n)4>#22Z_FGGWe;)iK7x33C(&wjIUDyCR?|MD3?6H2SV+%6;z7+_pb#xt5 zn|?F=#n8u{|62LwQr+v~J1akVZ)JXE`O3wQRyy}ySy{Q*`}We(#Ven__{EMZD@#EB z#eY`d>D;?Z7e9J?{*#s7x8HqtY1xL`!fkuQpucuW^M7Q}yqPw&8Bu2(ub0OT!p8C# z+1JZs<=Io_8Lyqh@VzFFZKek2F~BxFj~!FZPH%R)fuHaFv*mRs-h>ZoB@~<0dYj#;b&}*ll&1OmMqMXTdZ|=(ZH~Q+;+GcAL+(twrlLojP#9W V_3B=H)o}^scOnf3Cg%TB`7hI~J^=s# literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.DFASL b/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d75fa05aaa613c2358fe291c1cd085f82aac248f GIT binary patch literal 787 zcmah{O-~a+7=Cw4KY&77&_s;U2?>{t)7SQq|l}xCdNpN z2TyCX5Xr8F|KJrda_|rN4{){^MLc+#ndhB(KHhgm5PhPXNbl@+TWz<8I>SMCI6#d~ z5A{34Ud=@fiK7>~#p%m3(bqE%vQze@O0DNs2W}mSq1&%lpWj8<`-pUVt+w2(t;u6H zzmm%@FK4ET#5OP3{`)4E&)v)CRx(rP$45%40{}HR3ztcN6hy#3@KTzfw!lThq?nNn zs`(?|OUNwPu_^bxbPf$VUEFq`x$Q8{ZXXl?|Gk$eI!qUa#r#9%m6G(|c{2vXn=%?H zQBV`VSVDHi_vW)XyowDbXo+%cQdSaWI6jI!4&8ido>r8TJ=pqMQMYGrrj=;x^eMpH z>v&RWo_u3+|6{cNmVE~pHQ%s`s>}c!G(TV89%qu}1V9qttW}#EHB+q=s8RoecT3YP zRxm=3xJ+2Vl**3`iLjEbsS`4MTGNTp%a~K)aA{s2r;ph?wxAoT^6w2{X~A?P9!y3O zGVrWMIkz~r9I@#LEix$|BsIcz@EEtXKqgORuQV_o0SG3-u0<-6Bv!Qe1`(xDOm{e^ z?9wy>WmV$W{^Zb!O)uDk>4}1@&Hvp~9QOP72*;z98qu+zB{{Vi3)RepU_pK8dv}D} zAE3p3vWOa0`9JHZwRiEgLTrCY@jv;8s#LkHb4mooSB#j3pq!X?Fdbf#I$MqCML>TEST>12-7-INTEGER-LENGTH.TEST ;; ;; ;; Syntax: (INTEGER-LENGTH INTEGER) ;; ;; Function Description: ;; This function performs the computation ;; ;; ;; CEILING(log2(if INTEGER < 0 then -INTEGER else INTEGER+1)) ;; ;; This is useful in two different ways. ;; First, if INTEGER is non-negative, then its value can be represented ;; in unsigned binary form in a field whose width in bits is ;; no smaller than (INTEGER-LENGTH INTEGER). ;; Second, regardless of the sign of INTEGER, its value can be ;; represented in signed binary two's-complement form in a field ;; whose width in bits is no smaller than (+ (INTEGER-LENGTH INTEGER) 1). ;; For example: ;; ;; (INTEGER-LENGTH 0) => 0 ;; (INTEGER-LENGTH 1) => 1 ;; (INTEGER-LENGTH 3) => 2 ;; (INTEGER-LENGTH 4) => 3 ;; (INTEGER-LENGTH 7) => 3 ;; (INTEGER-LENGTH -1) => 0 ;; (INTEGER-LENGTH -4) => 2 ;; (INTEGER-LENGTH -7) => 3 ;; (INTEGER-LENGTH -8) => 3 ;; ;; Compatibility note: This function is similar to the Maclisp ;; function HAULONG. One may define HAULONG as ;; ;; (HAULONG X) = (INTEGER-LENGTH (ABS X)) ;; ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test integer-length-test (and (eq (integer-length 0) 0) (eq (integer-length 1) 1) (eq (integer-length 3) 2) (eq (integer-length 4) 3) (eq (integer-length 7) 3) (eq (integer-length -1) 0) (eq (integer-length -4) 2) (eq (integer-length -7) 3) (eq (integer-length -8) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..46f2f8e2b6e981e2d2d01953df82bc4d1804fd90 GIT binary patch literal 771 zcmah{&rcIU6n?u)OG^uBi6&xCQ33}~^X7YRzW06a%@AVG3=(=}3HWCB3w_SgE7v&xz(&>6F8LX_x zYp(DhUszgNoGKC99JBrRO}>!7SGb>FoH{=~QZj7-Xuw%?Bmpv@L2%$_bU|%_OBIu1 zMru?KhJl}uUa(_R9{AZj>bE<%<-TxRk)7QhC;-7nKT&d+Au1LN4wW}bI{4sER~TNG z)<~Ixn)t&Ku`7X}%H{DgHmx#YML0f+KaEs;Yo1n>lRen@UR5_|Zf2F3clsP)_U&X^ zX`cLGGX6DOd(VCX44dy*RaK?|4w_%DZ;rgkbOIm^aOO2;hs}(a0W}tU@^9&e#fp_k z8(x+DOv>?-ibPo1*3}7VI;$H*7^|35;czM17`cwyTehGzRk>OrEImwVlVMUzNTV}4 z<=o=fa>TkLbS)_#q;A!k_!1ndlKr;9DG?N35@1#Y<;1kZR8%JWY&e#n;SKnV&d+}X D84u<( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST new file mode 100644 index 00000000..de0f4e44 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: logand ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.7: Logical Operations on Numbers Page: 221 ;; ;; Created By: John Park ;; ;; Creation Date: July 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-7-logand.test ;; ;; Syntax: logand &rest integers ;; ;; Function Description: This returns the bit-wise logical and or of its ;; arguments. If no argument is given, then the result is -1, which is ;; an identity for this operation. ;; ;; Argument(s): integer(s) ;; ;; Returns: -1 or integer ;; ;; Constraints/limitations: None (do-test logand-test (and (eq (logand 0 0) 0) (eq (logand 0 1) 0) (eq (logand 1 0) 0) (eq (logand 1 1) 1) (eq (logand) -1) (eq (logand 11 5) 1) (eq (logand 7 5 6) 4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c2eebf574de8b04e888cdad6f9c50dfc47c9b5e GIT binary patch literal 775 zcmah{T~8B16urCsptOY)qKO!z6B1rFPGc(us4tGg^owN{W@kknNm*=@LYsb=7$Y%0 z__Rg~k?d;t556Ks9{fZ81DtJD2tN2Uch0?Y?m73)0Af$6iD+xL-DtWU)av)z{T|wB zbx^m}@6=qhqj2<+T7tbQ6S|Upm`mE1GPRDo)pNIz?7Q9VtrvGuZV8cgr_ofw;-b3d z3J>yy`T1<27ZC zlo;rV-z*`!=6lIp9xq_iDiOX+b8vhVe-i5WT0gC7Cws8|t*UQK-kj26jniiU({IMo zTK(iZSMkrm$~*o8U{HU{tGYG;a8UnpePifGr4s;YfU`zzdQi_aGN8x&kKQeVT70<@ zs>5Z~(PRQYt|)|;Y(tMK+fxQ5l9sVx(h*8F9r}*jo3>=Dy7q5{w2UAX84JcE31xNC zU_w{|TaH|Fq!Afc57GwVn|O%ZMxZ=ra#uz-76AyN;k+VMMG`MsVwK2J*o-F0Qh#zAHTFi|Da7{YH2<@Is4M>4R4^hLz9PY_NG6DB2dS`3^;vf;$$}g337wz+ E0$&K{ApigX literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST new file mode 100644 index 00000000..1f06b788 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGANDC1 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGANDC1.TEST ;; ;; ;; Syntax: (LOGANDC1 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logandc1-test (and (eq (logand 1 (logandc1 0 0)) 0) (eq (logand 1 (logandc1 0 1)) 1) (eq (logand 1 (logandc1 1 0)) 0) (eq (logand 1 (logandc1 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1a2bae27dc86fa54814d8c86cbb92bc32d4ea34d GIT binary patch literal 775 zcmah{TTc@~6h6D97urG!(L{{V2?;M7hu8)K))&WNdSjV|*;$dtrrp{mg*LsI7$Y%0 z__Rg~k?d;t556Ks9{fZ81Dq{h2t4>SXTEdhJKuNCj3D}ynuvCGx~;a`L!IHEI~<@! zr-%BTVXx+*hQiTHY6cFidIduE=>WjN5`v8${uhmw;%8I&X z^Y?T4rKQDWf!O9b+kfBW^0|BYrIp3x+0mhv=>R|tPQzmoAOjKb_q~iEnJsalY%%a?X{Nn-+NPKjyIGw zQe>bfezSz^n(rmEIlPQbt4R1N&B4)O>`AEOYxAU{9q+>Cw~D?seRD>OwoaY_%)W`I zwdV16uHv7gwRijnz^M6_S9EO(V88k0`qtQuN+$r)0H>|m?5LS(Wk8SmAH7=!wfJf| zREJBdqsat*TviA#+J-)%Y|j{!NLs>zNk=HzbnH83Z`+cs>)O={X&FH(5)URL31xNK zU_w{|TaMgtq!F1^57GwV+jxxIMxZ=rvX@2|j{pP{;k+UhMG`AmVx7oh*o-+l_#Nmwpu5G+d#U33iSx}pb@vx6M7tHC8eD98Q`vWw; zN9IwZs{UjhwRX?HQ;6*?X#QvaKv(>?sbEAhd`W^?mP`=S4pL#6>a*!sk_9*56FNKl E1z~UJBLDyZ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST new file mode 100644 index 00000000..a7510021 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGANDC2 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGANDC2.TEST ;; ;; ;; Syntax: (LOGANDC2 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logandc2-test (and (eq (logand 1 (logandc2 0 0)) 0) (eq (logand 1 (logandc2 0 1)) 0) (eq (logand 1 (logandc2 1 0)) 1) (eq (logand 1 (logandc2 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a6e264ac137bb4313adfa9b1945d9f4a1423e138 GIT binary patch literal 791 zcmah{&rcIU6n?vg@x@b&d!P?UPxKoO$u%L!^9W~ z@nAfx(LyA<8vX~bh>?T;5dQ(r6e0u<9wu+*do$mA-}j~q>F1`6%=%^{tocn;@3b48 zHrl8+QLEl*R(-S~arDM?IDNZ7%%zFPg+cdHrrPw^+WtBc9ly1{_WA)TJVK<=3~O>T zGb4|M(p0fDIXN*{Ca!(P_TM+fQt@GFYHDKe^k84h*8!jk$0`f}@ibV4vY7+9W57siiRzQ zm!&i^PeIR~vnX~gj&g+}p2oH_KWm9)IM~kws*NAP(V}*^1=XL6`pU?yQ7s*YCkH_{ z_#oq+Tsy%|aP$&j>|K9O3l4uVxj*SHePq7@y1{$4sB6OjyTSMCD?NEKodw7N9Ea7h zZjcZ2pr_+6(QU(Y*qo)>#S4VZ*_7j1OCoIEHS|8|!>C~rVJ=`!g~z21vu8xcU3CSm z=-R(GgkvN_ss3ajm6h5@49dB~vEzwlPZ+5I`5 UCPV6)tn<`!1Wj(hS9E&%2gaiDZ2$lO literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST new file mode 100644 index 00000000..2fb1872a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGBITP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 224 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGBITP.TEST ;; ;; ;; Syntax: (LOGBITP INDEX INTEGER) ;; ;; Function Description: ;; LOGBITP is true if the bit in INTEGER whose index ;; is INDEX (that is, its weight is 2^index) is a one-bit; ;; otherwise it is false. ;; For example: ;; ;; (LOGBITP 2 6) IS TRUE ;; (LOGBITP 0 6) IS FALSE ;; (LOGBITP K N) = (LDB-TEST (BYTE 1 K) N) ;; ;; ;; Argument(s): INDEX - an integer ;; INTEGER - an integer ;; ;; Returns: a number ;; (do-test logbitp-test (and (eq (logbitp 2 6) t) (eq (logbitp 0 6) nil) (eq (logbitp 0 1) t) (eq (logbitp 3 15) t))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8d0954bb8cbc2c7ccd5fc8a615eaea0ee35f9546 GIT binary patch literal 775 zcmah{TTc@~6h6DXP})KY(L{{V2?;M7hu8)K))&X=^u{s^v$GSXTCG%JKuNCj3D-unuvCGx~;a`L!IHEI~<_x zP7n1v!(QD*+X_c7sU_H}GNG%B53@=8LZ;qxYXi4|;pu)y;fTVD=X@n z&EL=EmzEZjMPi%hZ2zsv<#XBmJymmdbf{%I08oe1@R$V1Km`1KFJnk%OI)m&40E!^ z41eT%3FQSlHWR)#lS6|}7q{K#ZacKI(+3T}|KKHx4yUqWasNPjt)>0<-c*I-b!Cl| z80d-LEFrt*d&z7LFJsdxQOn^Hjt=8bLLFb5Csplu7dF0C_08#5@(f`1%|u#j z9)IU5{yAEG$A18fns0ek*QNmWn_sSPj@_tq0w4`=+N#fvnweGx^qBwAyJb*|7b>AT zTqe9=GJzjg6v9ikp+}YN8G{l@%UCe!2ql}2eaG!BTe3A>yZS;}Mv#h31e1}3vN~-r zAuNF{N3J{4h)k-2v_be59^ZuSivq#EX_#BeE1WqmB@aU)V#S zEi3%mKOdCX?3_JFMGGpI{4-4)&iL=z#_Lq literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST new file mode 100644 index 00000000..7839abe7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGCOUNT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 224 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGCOUNT.TEST ;; ;; ;; Syntax: (LOGCOUNT INTEGER) ;; ;; Function Description: ;; The number of bits in INTEGER is determined and returned. ;; If INTEGER is positive, then 1 bits in its binary ;; representation are counted. If INTEGER is negative, then ;; the 0 bits in its two's-complement binary representation are counted. ;; The result is always a non-negative integer. ;; For example: ;; ;; ;; (LOGCOUNT 13) => 3 ;Binary representation is ...0001101 ;; (LOGCOUNT -13) => 2 ;Binary representation is ...1110011 ;; (LOGCOUNT 30) => 4 ;Binary representation is ...0011110 ;; (LOGCOUNT -30) => 4 ;Binary representation is ...1100010 ;; ;; The following identity always holds: ;; ;; (LOGCOUNT X) = (LOGCOUNT (- (+ X 1))) ;; = (LOGCOUNT (LOGNOT X)) ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test logcount-test (and (eq (logcount 1) 1) (eq (logcount 10) 2) (eq (logcount 15) 4) (eq (logcount -1) 0) (eq (logcount -30) 4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4337e12f8cdad9e0a0d206a0d06f98f2fa389b7b GIT binary patch literal 771 zcmah{&rcIU6n?v{t)3^-=tQW`aw6ttzVRjbe*tA>Qq|l~6OpK8j z51!U&A(CAU|ASY=$iaWe|DevcMhP4|&71GN`QG=vH$#X%GfZT(_dCs&+ePg`zcc8g zdb^8y?LoKdqPoP!AyzHnQio&6pt0RBfWo_ClbiWc*al{ZS#|KQCP8QzlC zNP&VH|HBfpE54V|Gk6V~R)KEs!0AbBCsgsRab8l+4q*FxN!^{ly`V&!=g$Ea-%cl$ z#@P=h<6pzg_v|OYuCML>TEST>12-7-LOGEQV.TEST ;; ;; ;; Syntax: (LOGEQV &REST INTEGERS) ;; ;; Function Description: ;; This returns the bit-wise logical EQUIVALENCE (also known as EXCLUSIVE NOR) ;; of its arguments. ;; If no argument is given, then the result is -1, ;; which is an identity for this operation. ;; ;; Argument(s): INTEGERS - an integer ;; ;; Returns: a number ;; (do-test logeqv-test (and (eq (logand 1 (logeqv 0 0)) 1) (eq (logand 1 (logeqv 0 1)) 0) (eq (logand 1 (logeqv 1 0)) 0) (eq (logand 1 (logeqv 1 1)) 1) (eq (logeqv) -1) (eq (logeqv 7 5 6) 4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..619ef08fa49742451c51d4190a924d76379b722a GIT binary patch literal 771 zcmah{T~8B16urCsptOY)qKO!z6B1rF4#_qcu)a8Mr|p(y7G`Hf9!a~kO$u%LVPcHL z_~6qTEkv@b;Xn9_7*Yr@3?PopaB*cSewSW?0DR>~&jhuZKFrL3cPn zjZP2sJHuYhLk)?eSBA~$>k2W}mmleA=TfHD^L7Vb9f_gWukXIRkMxI#bbGC~4A$1< zRWCfq7gko5(BF&#KDlK5Tujs@t=-=afY2>^Z>v+o`P5 zJpI9B{A;xSp8W(EHQ%wSs>}c!HoxB79($4L6hIc>yj7bYHFK>TsEOc{e@8QHRx~4R zxI$Rbq8vXlCBn*%rpBe|In5x#s9;Wo%cW>z>^kY}ID&4d%Jm9iYhflf6;8)e(&(&4 zIk!2sU9ss3EjBG5WHrKe@ECWrP&&@(R|Yo~0|?{Mv|?3Bk}TPLgNSm}%y2oU?9vuO zWmV!g{`oM7LnrKECSH`e%w(20n(yD0jaMnT6Js4qa!W}Tb+H!01@&>@-xFScfEEwP zB5Lf)|5!(@{mEB~u!AKf_!1nclKrm1DG?N35n!2ua$-4QCMuJCwp?4#@D_YV7Z<+) DS<2>S literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST new file mode 100644 index 00000000..6ce9b96a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGIOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGIOR.TEST ;; ;; ;; Syntax: (LOGIOR &REST NUMBERS) ;; ;; Function Description: ;; This returns the bit-wise logical INCLUSIVE OR of its arguments. ;; If no argument is given, then the result is zero, ;; which is an identity for this operation. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (do-test logior-test (and (eq (logior 0 0) 0) (eq (logior 0 1) 1) (eq (logior 1 0) 1) (eq (logior 1 1) 1) (eq (logior 1 3 9) 11))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..25334118f118434cb3b467af25f44073a9b79934 GIT binary patch literal 773 zcmah{O-~a+7=CxREd>f`i6&xwC+5b|V(9hj)mINu_7Ni8UaKuPYishD z&8--@<>jTR0&%Phw*S5{az-|1tSn8PA0H{{4gl2PELtW3(x5?b;HPy#9f1oai(*D9 zR1ZdhpOjg!>rfu}83PSEUEKCwdhICAZXXnY;FF&$xXctKn+1o;TO}2I^k+&8Z^~$- zNI^|rvPA4k;HR<%Ud5JOWQ676_$cu#vhlrnT2@Z>VCzR&-JZRhQR1!B7XWkbCQ?fC z=(eO`JRU25htt|bIH@IN(pjBy zZgXtAV$&76HYp#Zbi#J<7b&BRfM{|;?DOi3Oe8(EZdO0Y=Anh)pICxQP!c>Mud*e469 zQI$Wkj#_&cpDDuj7nR^^aHvZ9`zEJEP<+jSRT7jF%L%8WYf@*+wFM3Dz!!9W{s-cml>test>12-7-lognand.test ;; ;; Syntax: lognand integer1 integer2 ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test lognand-test (and (eq (logand 1 (lognand 0 0)) 1) (eq (logand 1 (lognand 0 1)) 1) (eq (logand 1 (lognand 1 0)) 1) (eq (logand 1 (lognand 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8adb216089403b18ce9ed5037c82d7e5c8e477da GIT binary patch literal 771 zcmah{T~8B16urCsq%EW+nuswvA>n1?G}(#)>x<)d`o(q@W@kknNm*=@LYsb=7$Y%0 z__Rg~k?d;t556Ks9{fZ81DtJ*5`6G!X3m{C_ndQQ46&z%iHz=EuibI`s5=_=MnkmQ z?V~|=)Ni_ISK{cUVR8DZN{qGqLp^0*sx(y)Hon!>&AFR7CDuNB1~C67kx^Qw z-U@!(hQ50YN0k< zC9Gspjvv<~!Ya0=My2VTW)NXiF{i@eQnWE~9k;h^K^v;_?+syTK{}EMW+F*xbWWq3 zTO3=CSa*aLnUN1N8ev;_g4he2#QWe?KPlB}htS>iC?KO>urQgX*8I+o;=;xg|BF&Bab^^x!05$<4!77xfG z+TE7_aR;^cr(Y?=4we-Evwx&Y_S*)hL{NN1fLRli6VndT;WgQ3!?6SnZonsWaq$aW CIOc2s literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST new file mode 100644 index 00000000..a29595c1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGNOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGNOR.TEST ;; ;; ;; Syntax: (LOGNOR INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test lognor-test (and (eq (logand 1 (lognor 0 0)) 1) (eq (logand 1 (lognor 0 1)) 0) (eq (logand 1 (lognor 1 0)) 0) (eq (logand 1 (lognor 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e04679d58574c4ff792094a091efdef5f1c1543d GIT binary patch literal 771 zcmah{T~8B16urCsprwTrqKO!z6B1rF4oNEptS^q+Y1y)!h1pq=N762KlR}$*m>455 zKKQgo3z6(<_z%7!Mjre_{)0N(8YTGP)7&}t&bjB@J3~l3)lH7L zUb~BW?LoKhqCJVDm%7F2t97DpEI-Uo+m|x+uDjcJ8%PY?USs#gU6g--NT=(yWU#g- zuleHrLUCnfdAdw&bHeuDH-%y$U%a=rJUu!+QF3hnsKZ5cqycgegW$-|X@c4UmkpC* zMru?GhJl}wUa(_R9{6(w)Ngli%YE*)B0Kv%Pym7teyZ#+T^JS%j+NI+HhAyP7z}Sp zYotO!P5owx*p;SgDRn_g;n{!ISJAVc+|7I$y zG|#>>8UGw^ykkEAhRwIEswy)8N6jzSx5r*&It7pgxbW)p!)DIQftm+{>tE{VgO-0npUhTNs?uY*NCV@&2)!z$}Vjo zR8}Q^?XM4=*mS}kX5uB8%S>j8qxt?>*?5(bJ2BR=B)61gQ5SO|Tu>hc{vF}=`e^Zx zETX+#`5zm|JD7Z>2s>O-g3rORD%o%AoDxCt6#=FpC?}>JW}-6LXUnk!4R63FG#dQ^ Dana^? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST new file mode 100644 index 00000000..5ef676ff --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGNOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 223 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGNOT.TEST ;; ;; ;; Syntax: (LOGNOT INTEGER) ;; ;; Function Description: ;; This returns the bit-wise logical NOT of its argument. ;; Every bit of the result is the complement of the corresponding bit ;; in the argument. ;; ;; (LOGBITP J (LOGNOT X)) = (NOT (LOGBITP J X)) ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test lognot-test (and (eq (lognot 1) -2) (eq (lognot 0) -1) (eq (lognot -1) 0) (eq (lognot 19) -20))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..49ebbbd37fe7603b194ab1c0cd642bb725e9a888 GIT binary patch literal 773 zcmah{T~8B16urBpA3z}s(L{{V2?;M7hh!TJSYI56X=&Nc!tAWbBWbs`NufR6)JC+u+iAA^E@}_@ok1Vf z+g;Ra54u$!)fJ9jQAe=XYlN;ZKC&j_1hiX@?ZF^*v@VbG=T79kSTba%96vwL+y>04L<}^C5|_gHBw}t zXD(S{b}bCDRt_&?+bKGNT5x=ndK%04);KL|Cws8@y{vCd-=5Ku&C}-qvv1Q`t#R^$ ztNX9v`g{HpVAy!a%epoNaM1XAb8BQqeP;l&0B6nW?66@p4bYR}r{IoB9llzM#o;x= zS8XQnlafMs(KYok<$A`XMA9`ZnDm5FO-HsVEoD$B5hgW zH~#vd#AO%k(d5`_T<@}(IPUPDp^b*A$de->3u;a&9+$D_qB;F>7~GS7uaD;U$vmp> zsEw?l=HA6J#n}FW7Jdm2bwz)d3PvQu*A&<#$po?8Xfh5{bv8Xmvgj6kM(5|h0n_;A Az5oCK literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST new file mode 100644 index 00000000..c45a5f9d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGORC1 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGORC1.TEST ;; ;; ;; Syntax: (LOGORC1 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logorc1-test (and (eq (logand 1 (logorc1 0 0)) 1) (eq (logand 1 (logorc1 0 1)) 1) (eq (logand 1 (logorc1 1 0)) 0) (eq (logand 1 (logorc1 1 1)) 1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4c730c3f647d02a967e0cbaef40babf254cf0a63 GIT binary patch literal 773 zcmah{T~8B16urCsriHXb6EQ|7B)n`Kk~SEyzBmrkFP2%DofUZ`?P8l0+VsQ37>V)0 zr!`uLWLLv~@D(xg;2-iI)Y(Fm;Db*ybLQT2&$;)GAoh%!h<5h6t+v}ko#CK69H8A! z5A{34Ufo5z3P-P~CD`iBMepL);T8MqB3hi<>I^YT8*KSZS4Yqiy7Wko&n z#RrAr($eBoiP+`^+kbNk#ez!9FHVh5j)SGvRx=0vdF>xb41h+o7GkK4<{`M=x1&IF(h4`$yUvE#rUirmGxpC~Kt5 zKu=z>gzTE{W%32Qj7_U-30i=YSL9k1!yG{9l=>&>l+8TFk6$N-$T>a(L}wv`1v=6~|;7}Vmc)leL+ z5WZ?MfuB?r!ppXyN0sZGL5ZXlESPkJQcWkesZX1EJoXubBTp|JxM8kGPYKkOYvcx)(<**oagkb#27y@ls z;Wz&Jpu}bu>_IxZ8rHjPCJsCNXK0gQD)QJw$byCML>TEST>12-7-LOGORC2.TEST ;; ;; ;; Syntax: (LOGORC2 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logorc2-test (and (eq (logand 1 (logorc2 0 0)) 1) (eq (logand 1 (logorc2 0 1)) 0) (eq (logand 1 (logorc2 1 0)) 1) (eq (logand 1 (logorc2 1 1)) 1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fd316cb1067d9679aadfca7060fe7beeaf5850fd GIT binary patch literal 773 zcmah{T~8B16urBpUrORG*LPpuN7;vnbbGC~ysWOu zXSVPlS6EqDo-Pu{x?uZnPOgxXY5C>p@yW54?f^gy&ef3wNJ9jILqBZ@>IhscTNE== zrA9Cc{Dky^U5E0(&*adc)5UG?h1XVg_WGa!1RwoG(PgG6+blTJ-e{@dgFjnlcvD&< zB?@}tl0~s=fuG9ea2{KBNxk9ZIQCS@_|`nDXs7$I^}V8R&)v>w(bm~>fcdxal-4}` z!Q}ndXyZNm2{3BDV-;PS1vqSey}3OxBfk>>DS-1CML>TEST>12-7-LOGTEST.TEST ;; ;; ;; Syntax: (LOGTEST INTEGER1 INTEGER2) ;; ;; Function Description: ;; LOGTEST is a predicate that is true if any of ;; the bits designated by the 1's in INTEGER1 are 1's in INTEGER2. ;; ;; (LOGTEST X Y) = (NOT (ZEROP (LOGAND X Y))) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logtest-test (and (eq (logtest 1 0) nil) (eq (logtest 0 1) nil) (eq (logtest 1 1) t) (eq (logtest 0 0) nil) (eq (logtest 4 5) t))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e0ac9086672bd7f50a3794ecffea48806faaf8d8 GIT binary patch literal 771 zcmah{T~8B16urBpU$l^gXd=ewgoKxkLu|!>^~G^JEiKzwn4J}PY|3Jr6t?Myi7^u6 zgHLO;5Xr8F|KKZPBnED8r~cwD$~{D+(`~h7u(Ber zxx#~dVQFb`vP5ii%=X_m`9eNlxOabX^5W!J(L4ZXz^q?s%}o-oKfPfvu6OaZ<1N1 zdHS8n_~&r#9s2<=Y`$exRha@fY<{`EIr1XYDS#}%d8;uyY-%kH)OhgGzoi=%D^?x;i0E&*%mb#wzAiI9!T0My?a~wk>E)RsO9ImL6te$uJ#DNu$#` z<=o=fa>TkL^jKOx$m)b`;}LG_p>(X}t_&_20|+OgX~n9NBvG<>jfis8%y2lT?9vuO zWm)3a{`xS8O~>qEW}+x_nei-fG~Yif8?91u$45FASE4?bL!*3za!jUAI%?- zd9+)X|8WPk_Qzi-!VVUc;B#=KO7`0Zr$kVEMSximloQhqGf|oBv*B2RhBx37y14iS DbV%la literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST new file mode 100644 index 00000000..ebf980c0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: logxor ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.7: Logical Operations on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-7-logxor.test ;; ;; Syntax: logxor &rest integers ;; ;; Function Description: This returns the bit-wise logical exclusive or of its ;; arguments. If no argument is given, then the result is zero, which is ;; and identity for this operation. ;; Argument(s): integer(s) ;; ;; Returns: zero or integer ;; ;; Constraints/limitations: None (do-test logxor-test (and (eq (logxor 0 0) 0) (eq (logxor 0 1) 1) (eq (logxor 1 0) 1) (eq (logxor 1 1) 0) (zerop (logxor)) (eq (logxor 11 5) 14) (eq (logxor 1 3 9) 11))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5ccd58800ea1f4bd592feb9e097d7d9022151182 GIT binary patch literal 1422 zcma)+-EZ4e6u_^YHciqrb3znK6f!I2Ls&R8*?=}kNUnF&hPrm}2c{BYs@!x5cu7eU z1R7LRAK=B(DAOii(DpY#-X=ErVgCwy&wtRJ>ug;cCJjZp@%f#5zV12q9;4YWWrde} z*Y`VatIzj_gZ<%v-|O}HgWj<3wD>*X{0&*t@y{EQyjlLFk}%F_oPKL((AwqAVe4Rb z=g0T?$|^7I_d70ptgL`oseM?jUA|mS)FnficzdNywN|axmRHM(lY4g=u7?nEP(c6U z2yrNa{NFuJFtK5Z^@f5)RocRWf9!iPs7164tovTN$`5+`qTBku<v9UI=P_BvCbl_b51_!@)4&1YtbnN zorl*D${fwT&a@v~O$AyC#PP9mOG`aQ=(zo>mfB>Q1^E2y4ZB2xfj)*%5}}~uycPV7 z{ymccbM!oen4Otr?${akxRHaNt~U9`A7@0WXc<&j!jF4{>tHiM2&63 z#9J&2JF=4rk`*keR#U8N`j#OOhGqV1ZE6CUkHkTd3`fCeVtGYeJ{>taERlsNb%k(| z`6*TfmIRhKbyN9Bq%biJKL(gO2QO8{O8_qbOr4rjxD1pd@kknGIVE6S*K|>{%%)`u zkqqok3X-}lhMX4Ydt7DeZp2~4$PB#@b9Ay@a5RIzkQ6Fh1tCfgM>47S6*x@Gmab#< z%N z4Rfc`DqP^GN|On56UfpKj9)u%Y(UGKg!`J5EV5K5OEc8c^1X{@>tMi_4y6*mw*#-* zF5l@+9wf>R--d1I7ynQHHl2>5tYZmo{Zu(h!^FCz7-XJqgVa8^G!v83cfMDytzkGP jJb7)xCvcml>test>12-8-byte-position.test ;; ;; Syntax: byte-position bytespec ;; ;; Function Description: Given a byte specifier, this function returns the ;; position specified as integer. ;; ;; ;; Argument(s): byte-spec (list) ;; ;; Returns: byte-position (integer) ;; ;; Constraints/limitations: None (do-test-group byte-position-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec16-2 (byte 16 2)) (setq byte-spec16-7 (byte 16 7)) (setq byte-spec32-3 (byte 32 3)) (setq byte-spec32-30 (byte 32 30))) (do-test byte-position-test (and (eq (byte-position byte-spec8-0) 0) (eq (byte-position byte-spec8-1) 1) (eq (byte-position byte-spec8-2) 2) (eq (byte-position byte-spec16-2) 2) (eq (byte-position byte-spec16-7) 7) (eq (byte-position byte-spec32-3) 3) (eq (byte-position byte-spec32-30)30)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fe485a642c87a4d71cb93d70c288f6596342a0bb GIT binary patch literal 1412 zcma)+UvC>l5WsiOiDNsCbG9rKEaRRW{-~#}sofSrDj{7i>%_#lGk0f>fK(J+9Bj$4 zgJUC5)u@UPyqr`*)#?^hK10b{MbSO*UEnp3yoK3w>!b#$m94v*-^|X=?9A*jn*LO+ zNosFzzujr}rQUF`KO9KAy}oqN8}^;1vv}^xeWgs#n{=Shgj?(gdF7a zR}>);g^>4?E6Nr%EmEo0DAANnDtpJC8-ZL%!=#4iCd<;Gw@*6FubUm7&fWpS2zfuc zkxD~Tt*Wkh_wijE_wKoKRgKgkHD!$=A@a-%_l`X`Q7V%qva)4SVpcz+=+VRZBZTlE zDGEHE-&;>N@RKh3^^Xm~ma<74?naQ4^1Bi2q~R$z8NVwE&H_AVoUGrKLQW2zc_;6; zpMHr@>S*RQ+4`rPI&S@-CpH8;2cM5$w+nnT&_@u8BjmT8H~rtx zUl$_4-#w2YVyC9@13R_%&)-LO3U?x>CwJ^LN9h2i1JtrJ9AyHO36N6x& zPd>D>9AyKP4bWvf$5AdoIoy#>PttatqkMq!9Nlf5|6V!E%>QKxIe(Oes{1XG*XDtn zlT}??t?~krbwyjPQG={hfoN-{EQDE9n1=31%Bo_i>%^c|!+`3lL3@PFEz_c#f&doj zQU9nls%VWmsp!V0DKjkK|E{)lnazfxpootep-$B$a&_Eryj4PT6Y3HZL$edC3@i>T zHg;2bk8l{9gzp1Pya2D2$u)rU02AZo99{(~vS=s?ot%)VVdw_Y8&cml>test>12-8-byte-size.test ;; ;; Syntax: byte-size bytespec ;; ;; Function Description: This function returns the size specified as ;; integer. ;; ;; ;; Argument(s): byte-spec (list) ;; ;; Returns: byte-size (integer) ;; ;; Constraints/limitations: None (do-test-group byte-size-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec16-2 (byte 16 2)) (setq byte-spec16-7 (byte 16 7)) (setq byte-spec32-3 (byte 32 3)) (setq byte-spec32-30 (byte 32 30))) (do-test byte-size-test (and (eq (byte-size byte-spec8-0) 8) (eq (byte-size byte-spec8-1) 8) (eq (byte-size byte-spec8-2) 8) (eq (byte-size byte-spec16-2) 16) (eq (byte-size byte-spec16-7) 16) (eq (byte-size byte-spec32-3) 32) (eq (byte-size byte-spec32-30)32)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..da67d003cca69f582eba82d40e80d6d2bca2b4e4 GIT binary patch literal 1874 zcmbtVPfr_16rWw&U>oeLU5gNxrVDCOwaQwxl~#mYx-0`2%#ORej$^5+MU1H(8BC3- zgsP&5R%#C`CBy~ow2c&{UjU9#Q~6LS=NzhjgQ(XYd!z5I6G|x(ks@o~%=`D7_ujlW z-X(#XdQR4xtLybfwIw$<+v}Tcd8OHsH=3KRN>yF~x%{QhO#0QFrZ1$fr^D6>O{G;` zYFC$Kd$YQ+ytH*iPG6I?^;W$Bn~4cv(~}=$Ca+#ig=aJ?*F!tkCo`D=pZ8PYqX+wf z)FgydNEeq7ArkQs_r4=3HnnVZCYz(Gp)FFy-F2NH)a9Cr%MNFHZ>;Wk9Qy01p-w!S~=~3guy79S(_->$uyFu8&-sr5LLMEGJ*>p51=Tou z4nc{p6V!Rm7}T8_{$9BuF7_G%(>T!)&>!3gbxt#;bJSF) zvLG>LEk*3(Au#}h5>s@|*5_1{+65CDUH2xX&nj6qT@*#INc2WY&r!`Nge5=zmR2Y87%emwXp^$R~j=bnFho7z|-l zp{B`9l@;uK!B%{6Fd9@eqojIr49NEe$Sxc^s=8)Ti%YH}rBBUzxStU2#{nO}k=+J- zKfR&lkog>#KFm?GkzE7Km|ieVYMgjYxPZD(L6`Wq#&}*Y8t%cS0VzOlP_qQa!cY7y zSjcmJ373a>ik8n)W4g?fpYS&q`A85kx6mnXvRMN;%Y(qgk(-C-sn5XByhyL}(Go-u z>17Ppm*>(Hm#^_rg^xzi;Wj)_x3=06Mo(&fseFFiMUR(v9x+?c?pe9R}s<>y(+pL(RGBI@RdMD5Fz@y2!zA+K=yvj z?za0Qo^ju~teaGWzB*O(T-K(hmb3T(nn3|SE-;&Nx!^jf$teoANqcX+_s50B=oR2) z=G)ebTBJtZPQUxT7$ispAbuYb5s2hRf(kj3M6(W>0TFcml>test>12-8-byte.test ;; ;; Syntax: byte size position ;; ;; Function Description: This function takes two integers representing the ;; size and position of a byte and returns a byte specifier suitable for use ;; as an argument to byte-manipulation functions. ;; ;; Argument(s): size: integer position: integer ;; ;; Returns: byte specification (list) ;; ;; Constraints/limitations: Other implementations such as VAX Lisp 2.0 may return ;; a dotted pair for a byte spec (i.e. (byte 8 1) => '(8 . 1)) instead of ;; '(bytespec 8 1) as returned by XCL implementation). (do-test-group (byte-setup :before (progn (setq byte-spec '((8 0) (8 1) (4 3) (4 2) (16 4) (16 0) (32 10))) (setq byte-spec-others '((8 . 0) (8 . 1) (4 . 3) (4 . 2) (16 . 4) (16 . 0) (32 . 10))) ) ) (do-test "byte-test" (and (setq byte-spec-cases (mapcar #'(lambda (x) (append '(byte) x)) byte-spec)) (setq byte-spec-result (mapcar #'eval byte-spec-cases)) (every #'(lambda (x y) (eql x y)) (mapcar #'byte-size byte-spec-result) (mapcar #'car byte-spec-others)) (every #'(lambda (x y) (eql x y)) (mapcar #'byte-position byte-spec-result) (mapcar #'cdr byte-spec-others)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..31f50c26cdfc2de1fadf65e40ba2ea4fb1075f8f GIT binary patch literal 785 zcmah{O-~a+7=Cw4KcI!QjV5A@PDr?HoF;8Rv0favQ@UlDh1pq=W7BSJlR}$*m>455 z9z3nlLL|Ey{)1P<$iYA4Kfu{y6!73_W}bKE`FP(ML-eU`BE7rQYj@l}>W+rJ(GWGe zeKhEf`gIpIC5~R|7N@T&L|@B2%+J^tD)qiw8@df7M(&_ddvO=#A0X1}w>xsPvLcW9 z;&P$5w3M4E6Wcsz`|q1Vu}~;3-^@Zyz7V{63*GkHN@68$vZ^&q5 zm4cf1%@VRJzL(7x@Cq)`4a+t{HENdN=rHyqH1oA}QdN$3Ve?y6-I}|ZQKIdWX8_qZ z@s!d!{?6q7=XmWM`vEX+y=7HZnFZKyeYw6hi6qMjfE2)KyPh4l((N>;QU9ZNOVce@ zGD3^ELRiV996vTB!d7ifos!uznofjX!JG<*OYiz5e9Ydq1zlH_e{Tp&3zCs|Fda$A zymK1m+~U}B#D*iZ$h3Tr(g@qe6WrDU89bf8(!Y2FAeai97O6^-SlQz1M68Bly2CkT z7lsii_a%PqZw{T<^qf6NPL*UWd#R;3?Dn4lP6jI_q7yrda%M3Wikb7ly!y!Z?g)1< zL<@Ul0X1v#cQ#Oa_xxjp*xsVzfA$YlDRNuqln9Ei_%IDYIWg@Z8D5h*n~o)Da05P} Gv$J1#GU_t` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST new file mode 100644 index 00000000..896b530f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: deposit-field ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 227 ;; ;; Created By: John Park ;; ;; Creation Date: July 24, 86 ;; ;; Last Update: Dec 22, 1986 ;; ;; Filed as: {eris}cml>test>12-8-deposit-field.test ;; ;; Syntax: deposit-field newbyte bytespec integer ;; ;; Function Description: This function returns an integer that contains the ;; bits of newbyte within the byte specified by bytespec, and elsewhere ;; contains the bits of integer. This function is to mask-field as dpb is to ;; ldp. (logbitp j (dpb m (byte s p) n)) => ;; (if (and (>= j p) (< j (+ p s))) (logbitp j m) (logbitp j n)) ;; ;; Argument(s): newbyte bytespec: list integer ;; ;; Returns: integer ;; ;; Constraints/limitations: None (do-test deposit-field-test (let ((bs-8-0 (byte 8 0)) (bs-8-1 (byte 8 1)) (bs-4-0 (byte 4 0)) (bs-4-1 (byte 4 1)) (bs-4-2 (byte 4 2)) (bs-2-0 (byte 2 0)) (bs-2-1 (byte 2 1)) (bs-2-2 (byte 2 2))) (and (= (deposit-field 1 bs-8-0 #b1111) 1) (= (deposit-field 1 bs-8-1 #b1111) 1) (= (deposit-field 1 bs-4-0 #b1101) 1) (= (deposit-field 1 bs-2-1 #b1101) #b1001) (= (deposit-field 1 bs-2-2 #b1101) 1) (= (deposit-field #b101010 bs-8-0 #b11111111) #b101010) (= (deposit-field #b101010 bs-8-1 #b11111111) #b101011) (= (deposit-field #b101010 bs-4-0 #b11111111) #b11111010) (= (deposit-field #b101010 bs-4-1 #b11111111) #b11101011) (= (deposit-field #b101010 bs-4-2 #b11111111) #b11101011) (= (deposit-field #b101010 bs-2-0 #b11111111) #b11111110) (= (deposit-field #b10110110 bs-4-1 #b100000001) #b100010111) (= (deposit-field #b10110110 bs-8-1 #b100000001) #b10110111) (= (deposit-field #b100011011 bs-4-2 #b111101111) #b111011011) (= (deposit-field #b100011011 bs-2-2 #b111101111) #b111101011) (= (deposit-field #b11000111 bs-4-2 #b10110001) #b10000101) (= (deposit-field #b11000111 bs-4-0 #b10110001) #b10110111) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL b/internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fed7ff8d878f345d13b8b9f90b62aaadfa0fdf53 GIT binary patch literal 1541 zcma)6&u<$=6rSC+9si26jzTCVBpXXbXvLb^4agV?wAoA&6KB`#t}!`46gdvI?Anpz zAORw(a^YerxK*p2LJxp?L?RXvs%T|Z<-~~tCr(_r?_WT8jhU!x@PAM-MPtK=c3L@Z!)hdML3$eh7lk1RH!-!<8(&JDl5fhboX}n z7$NSbxX9C;{7`$a!QF468xJ@5@?0X$1zJH=nI5)+TxABnd}S8CLgf;CeU-$p{@{It zrjI9{;%fJ|V?!eb)a@5ejM!s@`n6Au*apu{!tmQ?%JZ}UQ~d0JEMpasm6T5t#N0rQmJa0hzRf3D+q2d@M3R3h#m1M+%AGHEj^-@t;HOx&*CLGWGeYI`K zBqD?$5nbN0v0@dmmQ}7iF)+2BFgcb^6H$na#WE0!j>WD*EIbxlf>?}%gefq4Ova{Z zn2J%dizQnYL^@Yi^(|!-r+apKVtVZIgusf#M{mq5y#zmkkPpAD7AW~1NPwPKwJH4$ z1mjxCG_ii+dJ>N2?m=$muYPN)g;`k=q3LZ<65y`Uu}S7BtT1?m!3zu$45A}Ie=u+v z{KnvC29FpF7<|p(7MX98XPad1UGiLr78ycaf6+A7bjnU)lR?;pLjMOM($F0`VbmYW z`tXVbbb8>?`HxAm4ogCGi3R>B644}!d6LYLq>s-3#_28C)q}2-JW`X=-VQvdyHdTy z-a;BXy8MyzxpR}+XkIh13Z58iQXy|+Q!Q8|LZ`uI-YOY3CW}?4m&z?;=ssqT-00=* cJ}Guy<;e2trhKDHcml>test>12-8-dpb.test ;; ;; Syntax: dpb newbyte bytespec integer ;; ;; Function Description: This returns a number that is the same as integer ;; except in the bits specified by bytespec. Let s be the size specified by ;; bytespec; then the low s bits of newbyte appear in the result in the byte ;; specified by bytespec. The integer newbyte is therefore interpreted as ;; being right-justified, as if it were the result of ldb. ;; (logbitp j (dpb m (byte s p) n)) ;; => (if (and (>= j p) (< j (+ p s))) (logbitp (- j p) m) (logbitp j n)) ;; ;; Argument(s): newbyte bytespec: list integer ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group dpb-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test dpb-test (and (eq (dpb 1 byte-spec8-0 15) 1) (eq (dpb 1 byte-spec8-1 15) 3) (eq (dpb 1 byte-spec8-2 15) 7) (eq (dpb 1 byte-spec8-3 15) 15) (eq (dpb 1 byte-spec8-4 15) 31) (eq (dpb 3 byte-spec8-0 15) 3) (eq (dpb 3 byte-spec8-1 15) 7) (eq (dpb 3 byte-spec8-2 15) 15) (eq (dpb 3 byte-spec8-3 15) 31) (eq (dpb 3 byte-spec8-4 15) 63) (eq (dpb 5 byte-spec8-0 15) 5) (eq (dpb 5 byte-spec8-1 15) 11) (eq (dpb 5 byte-spec8-2 15) 23) (eq (dpb 5 byte-spec8-3 15) 47) (eq (dpb 5 byte-spec8-4 15) 95)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b4ef2a98481fcafb59778ef118a4067de3fa30be GIT binary patch literal 1309 zcma)6&rcIU6rSBJwJoJ=wGu_drHMv2Zet53SWn9`KxNsjyIU&Ow>pW z7cZM&G2o7di~oRlG-7)2;?@7at2YiFP4G<%l~fbG%*^+_-}Bx~9d+GRR6(gME*HyA zRj91imRD=SLZvFKR936DBP;+fJW+H5Kb?}5>BP-s$UG*otIk}_nHQ{8XJvlw(N!UN zLy(uN#WEa5M*$|&*Hh_{kwj=hHr1B5f7+zdso``gl?WZ|Y%_cXA!MTl-GT`5h(q3{ z%ZnB^Eoma7Vo8%{u;|r2HvqLrITIV68%+td%Cb~;9y(=O&f*GU5b|EQfr*@^SQ%aO zUNX;^u(#p%WHc!YrOA^Rv4KM`)H~z3p=3%LmDKSui4tgMJG71vb2iGeG@Xxyy=msd z659MU&E`+`M;ZT80NJs|Qh>4hU}fzyuyS@ktUi07QQUig(8=`^rQwHa|!MfINUu7@u-t7B1_D@RcSrF^X13wHaPh286= zd|w+}F6Ga(!MRetzXj?Ax0D|^JQtr8{yVL{zoi99-s*?WGzvVuzb$t_RCH}TLoZpH zlC^Oa8`4+?7;VxNSw9J~UC_a(sK}NwB^lVt8PEZx*+RcLYg%}QWkDm>>an6?S<7Xm z3Eh}6MZ&PmpVpQxl5Q?Yf?N*>!(+1+mdq?xMx|@*!Jr-Fx;w;4!gJvcE(KhugBu1e z(!q@Y*9!v_5wT(DhNS1LY|aunp6ZFRHY+uGnzQHf$&P^xLT8DOPGOkN)G2V}!*^tr z0zUvhtyi`v0-~7>P?O;by*384W312f3 Qxd?v9B{GCwCk_sN0lH{^&Hw-a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST new file mode 100644 index 00000000..d4585aaf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ldb-test ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 23, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-ldb-test.test ;; ;; Syntax: ldb-test bytespec integer ;; ;; Function Description: This function returns true if any of the bits ;; designated by the byte specifier bytespec are 1's in integer; that is true ;; if the designated field is non-zero. ;; ;; Argument(s): bytespec: list integer ;; ;; Returns: t or nil ;; ;; Constraints/limitations: None (do-test-group ldb-test-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test ldb-test-test (and (ldb-test byte-spec8-0 15) (ldb-test byte-spec8-1 15) (ldb-test byte-spec8-2 15) (ldb-test byte-spec8-3 15) (eq (ldb-test byte-spec8-4 15) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL b/internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..957524c65fc1f57d5c9bb5588bcf1c3f89a940da GIT binary patch literal 1291 zcma)6T~E_c7(Q*s+!v!GNDvXr5{PN+;sz!-uSz+Uz22 z)P!oIzTT({E7h8?QEk+0M_2(|xTEL>zB?x?^QrUcht+(bsGSJ$PAbJMBNa#lAGgOK;g4b2oZ#mecL z_k_8}#Jq=YcTSV?P?|i85gXd`LcKFUr!&%|q)tzvm)nv12r&Z*o~4<5D1Dq~-mjs@ zpXS+O?_h!nu7!}@*IWxRc0Zh~JpdWgOap*Cgis8jX4w{+Z_)OlsLZMTsG(wCr3cI^J*}OIV!uxx zY3+;^2Yi}q?F#chw|NHN(`u~;{htbD-|IiBi?vbHF-ahkK|^68FM48veafbL(6u2e5L3gAn! zN|`QTg0x=QqAYDjLMa#q)($N@VL*m{fUNI#zZKcUepnKv;?LlTgUzM%J2FhK*Z%d& zzn+reDmh*uLs!U&Fo>B5SajtLeO9B&yTFCOUZUNjz;`Nc*G0K+@Gk{5nkda1eI>~< zcml>test>12-8-ldb.test ;; ;; Syntax: ldb bytespec integer ;; ;; Function Description: This function returns a byte of integer to be ;; extracted according to bytespec. For example, if the byte spec is ;; '(8 0) and integer 15, it extracts 8 bits from 15 starting at position 0. ;; ;; ;; Argument(s): bytespec: list integer ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group ldb-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test ldb-test (and (eq (ldb byte-spec8-0 15) 15) (eq (ldb byte-spec8-1 15) 7) (eq (ldb byte-spec8-2 15) 3) (eq (ldb byte-spec8-3 15) 1) (eq (ldb byte-spec8-4 15) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fab175e12d4268ad2ce88e41f94c6fbe8727390e GIT binary patch literal 1322 zcma)6&rj1(9DnV`+{V~CL?Vb-mZ-6@iyN5WJeBf*xzf(Ib8;|-l;UOvBV(ATkq|Fl znkb;yry=nV@SvO|Vs`K^@IUbCZ3mAg_!{ja?|v0z}`b>eBhUR@F^_C32o%UM`P3_|WRCpb}1WizX( z?k2OwMBJxNS5_7CP?|J}5gR=4LcKGt6HBGVQE^%_au5nD<7j&;{1_poFV3+vp^v4# z9J9NKHa_LpVt0R>2`mPY)zerEGFC5~taTDjpVbei-x_F?_wFFn{rK1krnGxI+R&oF zHrJJ>TJ$qQ>!l}JG{-VsK)&lM4$=T14i&K(1u3%jp%L1ZK8Uh<2A+`f%7#C#8l&3@;n*|+aAh(7XFlG!BPqQp&^mtR2 z6)dTRyf~rh(}qA8mig1#)CAJ$3z3ko3xtue854^}9?PTRrQfSThwAHW6Q>C0i?m^B zz`||VFksO(Yy_|vtWZ?Ix~}P>RxtAgQ}A(APmt6Zv4zu|U587xtz-x$OZ;>XBXp;Z zgCjq_At{sz0283~N+xA};4m&1bRDZlmYy&mL*GHxbJ%ZLGO!nxbW-tWy5ff$OrZ~C zkX~=S>y39kCxcaTszL^Ck<%d%Gf^q!^@=szFZI3z~_^knK9j%ov7dV(%qrJ#Y2j!G1+q XH4fq?{jEskEchYk$Pjv!+~5BR9khX6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST new file mode 100644 index 00000000..0861ca6f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: mask-field ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 24, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-mask-field.test ;; ;; Syntax: mask-field bytespec integer ;; ;; Function Description: This is similar to ldb; however, the result contains ;; the specified byte of integer in the position specified by bytespec, rather ;; than in position 0 as with ldb. The result therefore agrees with integer ;; in the byte specified but has zero-bits everywhere else. ;; ;; ;; Argument(s): bytespec: list integer ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group mask-field-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test mask-field-test (and (eq (mask-field byte-spec8-0 15) 15) (eq (mask-field byte-spec8-1 15) 14) (eq (mask-field byte-spec8-2 15) 12) (eq (mask-field byte-spec8-3 15) 8) (eq (mask-field byte-spec8-4 15) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL b/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9ee211fa56029dc9d2ca7a123288ff23aca34424 GIT binary patch literal 1552 zcmbtU-D@LN6u&cRvq_r9BzA*l({&ngR|an+$*yc8BGc(j8#9^7&WG88q9sjDpxcx* z6+|p$5%*_5cRuDf zcb`mNQ8h{JU)}0$bOus?XSlU9l-BzLX}iBOXm_M_uuJc%hRNPrR@8do#bV4F^Rx$@ z)nR8%vUfV$Ypd@(Cl%)33bCqUX#v{5=9DU>a^+&V5Iekm zOGx$!A#E~35hWx^Ld5&nP0BX2Y+9{pjOt2*$=<%_Mqn1|Sj_a?R7o24x9CRa?al^{ zb9I{tgm@phk*cGscFoYe17S~ydpF$anogTAnzF=*7cZVk^1(NCu{D!T3E>FzoE_o&tpAoqy?bvFlD>B8 zw9vi#Mq*?nK)t`O-7pg06SCjEZY1iWFb&7gpKN6i6#S4MCuG!XKQa1({5)Rix1&lC z2!plUY~=uEult{iWFA#ytb*{`QH3aU0oY$=S~(~LC$E(a4tw4ITM(Lm1;Iw$BoU+D zO*bd2hQ3(C4@8$?;~F#RLJchXk|m1~9u>pzOacQ^vZ~nXGBug)nD7Nvp8{cP#j;sL z6d__J;E1X*MR%ICYM2d6=7K1k%(e}gPlcv=G&BW_NXX1I4U-y<-E?d@6o-VktmrG$ zw2DaEZCyEalh};P!e4OzBIrP}^oDxrmlE;l@p7z{i@fd%nPZ7c=khCdeUKQXc z*sF?$$~-7x98a-PeE|?ts$-f=ANxbNfWGtKoB4ais$#KVC_V*l@&_QLPS71a_xUV} zUjp$X&!YANKZD{coqhtZz}fCqv2FvxwM&%6%lxktB2Eg)Z$r>lJKC7v(vd>DX)=RNl+yR$u% z^1Di2T3>}5bWQ4Q2A3b&cAvp|KY5>e2guX2s>$F|p~pUpR$m*erk~EwgOfkY=Tcml>test>12-9-make-random-state.test ;; ;; Syntax: make-random-state &optional state ;; ;; Function Description: This function returns a new object of type random-state, ;; suitable for use as the value of the variable *random-state*. If state is nil ;; or omitted, random-state returns a copy of the current random-number state ;; object. If state is a state object, a copy of that state object is returned. ;; If state is t, then a new state object is returned that has been "randomly" ;; initialized by some means (i.e. time-of-day clock). ;; ;; Argument(s): t, nil, or optional state ;; ;; Returns: object of type random-state ;; ;; Constraints/limitations: None (do-test-group make-random-state-test-setup :before (progn (setq random-state1 (make-random-state)) (setq random-state2 (make-random-state)) (setq random-state3 (make-random-state))) (do-test *random-state*-exist? (and (boundp '*random-state*) (random-state-p *random-state*))) (do-test make-random-state-test (and (random-state-p (make-random-state)) (random-state-p (make-random-state *random-state*)) (random-state-p (make-random-state random-state1))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL b/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..11ca6a9d8f800c9e380e32664df5899bf1c4aae6 GIT binary patch literal 1345 zcma)6PiWg#7=Mx-$95b~PE2UMw0#LQ46$csH-Xk=2UUGeT+5Ox$@Ov=TX3A&ki@}p z3S%^c96AcxIeJNP^@UD- z5!)N}^~Hs6KgF2~SXpZ~m*H^!Jg}MEOg1+?osQ-eOY_nG(1 zAyh*>P9g|ND1h9b9Z9ySWs`hCqeNFqRCc?r6NXwy#iFL`B(k{ES|iK#>-A+`&dNFx z5ORNV!ug7>+66;*?+9B$%)RXl7j#mF(v(?>#P9(MM;BaYG?OJ4h^gq8jS{hJ#ipc; zcJIZu5fXw4N#sfW+Sn@!&sNdR--=>&B$W_CVMsXH3Qn;D~|EHPi z7$=`pPjGUkdYY3lfB@QU+*%F(?j5$8TMhsF-`R})TQ&fEB?Y7CH6-4!yUw_*8v5k| z?<$#tUTM@MmkJ=!XDwL_v4}VTBTLAtVykn+q;|!GmaE>(Le{)x(~>BHMbaOts!>I+ zlu6z&OP0(8QTV5~ZOCjW5MhzPFesz_6UrQ|0v}>v=(s-1q(JPr@Ei!EuncjTnxqwbn3l|wghz0qU4a2se_uv$y*A$I2Z-EK% z@)Vo1uOUc6t(Yd&`&OC>T=xoe$q(&S6^r_*u%Q}Dea$|;%EqSvE>Tj7^lzJr*{Kve zC2^2d3M#^aqsZ$Ijx$MU(jRC(h4>;70qHp+ze{FS}|cml>test>12-9-random-state-p.test ;; ;; Syntax: random-state-p &optional state ;; ;; Function Description: This function returns true if its argument ;; a random-state object, and otherwise is false. ;; ;; Argument(s): object ;; ;; Returns: object of type random-state ;; ;; Constraints/limitations: None (do-test-group random-state-p-test-setup :before (progn (setq random-state1 (make-random-state)) (setq random-state2 (make-random-state)) (setq random-state3 (make-random-state))) (do-test random-state-p-test (and (random-state-p random-state1) (random-state-p random-state2) (random-state-p random-state3) (random-state-p *random-state*) (eq(random-state-p 'random-state) nil) (eq (random-state-p 1234) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f0da6bfd7ada659c9960dbd84dcef70e052db153 GIT binary patch literal 2576 zcmbtWO>7fa5PrKGLWmu+4u%Gkrb_@fSXqNjpdm;oo6U3LX1&kdA6%qLQR|Ai zl~C0PL8|s(skl+mJ`fkKy#T!wmC6UMt%TI7Ql(ycX)irgTL0Y;w*-9ZjlItcvs48Y1h=93^Tno;i3@qJ}Y-*Of?6gX=9X#ZFLkx7rb&H znNp9dmS&E!EV*%Y*Cj%v6Jc3IXTB-jn-K1v7goQW5c56Ju+Z8DjvlV!H|2i^e5VUa zHLpyDs-;O8{yX76Qe~klmzjL4kA(z?2?espI$0zJ`cGM;6rJpZ)hr}}-K`%B(Hc-! zHQ)7gpcnuN&w=@=(ECjLgCzjyc&;Zu6pmHjBLt&|#nqX6z;s^Px>qRO1;1Db*gq@A zXDoD|kV@$j7Mc(dwQ_5Bem@$49xkJ9^%JO=X7r$_ms>FT?ATgc|4 z`99dY&<)JVeD}*C#&6yxe}ngMSot`h0{h#u&Y~ZKdZBbacsZx~?@Z=<^Zgj);2rB_ zLrh$+$Cm)Wi>2nj7e3})PdjFSeKQJ)tCnOU2D~rI-Ep0nqZw>MbsSpDpq4t40f{+g z$Hi8@P22(<9**mpqmQc=bzBQNRQFrF)jn-IG%Jd*B2t?HxI6sMNOES0%V&UNC_4loGDHS@IU%P|}&g0ebD zy6((QkagB&{vfP*1Y7QE($r#X*t`Oo$D`jc>H<~6dEY1rNV_)+Qy`3P79IiN9uPLX zY3ym)4rscc(A0D0mF4872^|a*!dq}Gcj1^l3h8N~kV<6wfN8}8)*NIH0Bl%yEsL5> zcK{bqhY5)MUtqds(^@il0Mz2IP=KKWCUY>!Hk6z}QTz*Ru-!hL9btyrxFJyf6$YS> zQ+)#N8YqN%#c&ywSHNg124rMxDZ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST new file mode 100644 index 00000000..8f0cf36b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: random ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.9: Random Numbers ;; Page: 228 ;; ;; Created By: John Park ;; ;; Creation Date: July 22, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - fixed (COND ... NIL) to (COND ... (T NIL)) ;; ;; Filed as: {eris}cml>test>12-9-random.test ;; ;; Syntax: random number &optional state ;; ;; Function Description: This function accepts a positive integer n and returns ;; a number of the same kind between 0 (inclusive) and n (exclusive). ;; The argument state must be an object of type random-state; it defaults to the ;; value of the variable *random-state*. ;; ;; Argument(s): number: positive integer or positive floating-point number ;; state (optional): object of type random-state. ;; ;; Returns: random number between 0 (inclusive) and specified number (exclusive). ;; ;; Constraints/limitations: None (do-test-group random-test-setup :before (progn (setq random-state1 (make-random-state)) (setq random-state2 (make-random-state)) (setq random-state3 (make-random-state)) (setq random-values '(1 3 7.4 10 38 100 860 99999.888 most-positive-double-float least-positive-double-float)) (setq random-original (mapcar #'eval random-values)) (setq random-state-values '((19 random-state1) (100 random-state2) (999.9 random-state3))) (setq random-state-original (mapcar #'(lambda (x) (car x)) random-state-values)) (setq random-state-first (mapcar #'(lambda (x)(union '() x)) random-state-values)) (defun check-final-values (random-pairs) (cond ((and(or(= (cdr random-pairs) (car random-pairs)) (< (cdr random-pairs) (car random-pairs))) (or (zerop (cdr random-pairs)) (plusp (cdr random-pairs)))) t) (t nil)))) (do-test random-test (and (setq random-final (mapcar #'random random-original)) (setq random-result-pairs (pairlis random-original random-final)) (setq random-test-result (mapcar #'check-final-values random-result-pairs)) (notany #'null random-test-result) (setq random-state-final (mapcar #'eval (mapcar #'(lambda (x) (append '(random) x)) random-state-values))) (setq random-state-pairs (pairlis random-state-original random-state-final)) (setq random-state-result (mapcar #'check-final-values random-result-pairs)) (notany #'null random-state-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL b/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6c3868e52a990ccd8d63af353244fefd342e812d GIT binary patch literal 1359 zcmcJP%}*0i5WwGVp|*U~R%SSzN9tbEUGfR9Y_20yN~mW%VS7#adKJ#u8dL*60<~zK%bdVZ3@DY-qBftunV-jU7M6%aNbtaq zWIRjfhHV9pq*bXcSohlvOUprNbes`6@{@veDew=cPibjQ&r*l#oH>+p#~Ag%NuEE6 zt`Q;~PsC-+?0sQlLV9 zu}_3l3-|5VgeOywi7fC(2x%i^vp93OR`(A5^A0`oAL!EY9eVU%(SdWm3!1iB zh!Z&)JodX)-L}RIyniiAtud21+Nc2*Yur`kh=|Hz_?n@?300?D&uR|io&yciYaI@| zmtD>#Wf^vK)JH%!8MVBema&~lR~3>h{Ta<|RkViMMKsh34UehJacoDkJ)ZNp8ft@p zHkDeJwVE9vfgexr8KCwMA)*PVrUe_{3!o-;k(#I^K?!35l%skOGtfQ9Vb(7rDkStZ zVdlG+pi`ICj}@)pCSQ>>YJ1jL4%N4!1H~J02*nGLydyfVh>j_7C@YdF(HRG`bOd6W zbB;Z3p%#Y&I&os*V!5lC#-zbDcFAzLd#>?FaJ-TD9YbqXqqYU_BWz(ASQYsuQYgN_ zp8b1(Xn)-}C}TsNza1pHaK|&zjpAXQb5EphHBh@Dyn)f}F}4?TR&)=FRG&z7H9~i{ zg@F!F*gwkiOBJPOh4v_O)9}BVRf;$2zZ$fy^kEVogJ;1b9GfG$!zgFko*tM6zHieN mt+)+t<$`B(RxjYC=)G187stRU`b2k5^fvu&Ax}?kZ~p*jsD@eq literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.TEST b/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.TEST new file mode 100644 index 00000000..6ba9f51f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.TEST @@ -0,0 +1 @@ +;; To Be Tested: Character-attributes constants ;; ;; Source: CLtL pp. 233-234 ;; ;; Chapter 13: Characters Section : Character Attributes ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 8 October 86 - change plusp to not minusp and remove an implementation-dependent test. ;; ;; Filed As: {eris}cml>test>13-1-character-attributes.test ;; ;; Test Description: See that the constants are defined and that they are non-negative; see that char-bits-limit is a power of 2. ;; (do-test-group character-attributes-group (do-test char-code-limit-exists? ;; ensure that char-code-limit is bound (and (boundp 'char-code-limit) (not (minusp char-code-limit)) ) ) ;; ;; This will probably come out, since we don't support the font attribute. (do-test char-font-limit-exists? ;; ensure that char-font-limit is bound (and (boundp 'char-font-limit) (not (minusp char-font-limit)) ) ) ;; ;; Only zero for first delivery (do-test char-bits-limit-exists? ;; ensure that char-bits-limit is bound (and (boundp 'char-bits-limit) (not (minusp char-bits-limit)) ;; See if it's a power of 2 (i.e. if its base-2 log is a an integer). (or (= 0 char-bits-limit) (= 0 (- (log char-bits-limit 2) (truncate (log char-bits-limit 2)))) ) ; or ) ; and ) ; do-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1c17bc96c8d0c17341307d6e2b102729870222bd GIT binary patch literal 1486 zcmb_c&2Jk;6rWuu#&&FDqkMo9!Zsw3E*%HEE=^nz-EKFr@n+ZTt_e}0Wo2(-OHORr z8zj^=Mdi@T>J<|a?SLxoJyjf#3axTLocRNgIB?+1g)3pkCL#nRE|oQUeqX0PDSaUmF^_qw9mjT^ znqciX-J1Q;86mSINbOFeN&hS^QZBzEVssptD&B^AoxqNOZ9XY(W&m~$2 zp(;9HB8*T11(5%lmk=$*wD59KRj?+lDx%->y%6PsE2d)jUNS4Vtu}5tA39A&XRC`i zg#1sv&~inSt)i~^d)&ud)W7S+iW)9cYSM~=_|RV{44tDenX@>HCAD0Tuw0M~Tt@fy z!?zLQ7Lo~`mGoWxQHguFjoOb({Mu+L$ptt2buwQJp+{7E=Jr!buKw^^{6LRW^|zjS zSC4;>P_KSRkC%9khV>pytc|l2c0ve65jtp8pY4-Ay5Yy88$uN1iNka0Blz$WgQq}m zrRdBK>IuY${m;EAQP#D~Mb>^?khIIHV&F?fYSC6qkq?nDAEalP&NnH_k|h_gp;#4z z&PVPKIB2e$ma@w8G-7nH0kWz{TBVGabz{{O3CDB)&bD-sj09pN92lYVj*E(6=myp+ zR=Hw{fhbLgijuaD`*sH6dx^}6{fPw-B13Fx;%xkJVN8RS?U-r8~TdIvi@LNpD5FQr(Z-+W0f-^ z=vOky#7{IPdVJ}b@hg&IVt){FhfLleQx{39Y8w@4a9-U00adm1cwun?5!*p|L%9Czx$_j$Qh* zzc&k~UVFB`R0bYkU=y?+^!WDQA-iNDj4L*SDa070_ zE(r7&0oD@qga4(!$ChYXHWbNH@QI12MN2Ux)g&V0AC@3|@r{WZ^92;2gXL=V1|+Hu{$mfkKi~B(?S*t?D{k4cv9@?V8=G9cz_I ZrfFIbLJ)=+L@AA1L;plWUo0FR{t44VwzdEO literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST new file mode 100644 index 00000000..0fb11db3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: alpha-char-p ;; ;; Source: CLtL p. 235375 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-alpha-char-p.test ;; ;; Syntax: alpha-char-p char ;; ;; Function Description: true if char is an alphabetic character, nil otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test-group (do-test "alpha-char-p on alpha characters" (every 'alpha-char-p '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) ) ; do-test "alpha-char-p on alpha characters" ;; (do-test "alpha-char-p on semi-standard characters" (notany #'alpha-char-p '(#\backspace #\tab #\linefeed #\page #\return #\rubout)) ) ; do-test "alpha-char-p on semi-standard characters" ;; (do-test "alpha-char-p on digits" (notany 'alpha-char-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ; do-test "alpha-char-p on digits" ;; (do-test "alpha-char-p on other graphic characters" (notany 'alpha-char-p '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) ) ; do-test "alpha-char-p on other graphic characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..03f20fe74109619176d66e8c50dadf7201d0f6f8 GIT binary patch literal 1124 zcmah|YjYD-7(SbjHcc<4RbU3FE|mx@oI=tR+aROc?Ma(6S#(Cgy@x zq~rL(Pw~-^k=cdeKll}KcF7 z)mF3CYRVhcy4P1)H5PtctW?JmtqN*)VUQEX9eUW0_U2D4QGH3eC&`?)=wGiX6jQx_NsMW3St=#tldJ2^#DRMiWMs^R3BmD6Z}Jbuu(6Lj-?>FJX6 zWQ%P7u@qVvIWj6mZueRYV#9h>iWwKO~i&{Aq~u-<{>3jK2u!lzudpLXxPy zU;6FfN{_n;M+q4cfaT&?rxY*8Nhsp|+CHXerZJxjxKPpFyv{5-mlGai!B#>Cgh-=` zrgCkOT8ulEAgT3K>a$mE&hjDY-x=Ig{K0U)KM;-zVMY{YS*ArzhZh{Kga<^ykfIu^ zwCA@KUnmq$z9Dpfm=OO!pzc6jfb?ZeE3fiuaGB;<7Bluu&6jQn|2waEXsXTj(EY(n zg5yZSFnMsJEm-O7f&hHWUd_*$I(;$6b0RI4U{{#+BI}fY=(vCQh<~WRBGAY7Pp?3O z!M@y;z;Fa+q(>+()}zk|+SOJ6*p%?cUaL*`-g#xySAL(E`y-0P;HVh$SS!H~rQ7LmgemZ2jL111W% z3=1|m99+Q)u3{CRVhy)Y#5!DT;5JGq;|qL=3O2EYDr)!&bu`dK3wQ7}zQH!WmApq@ nHzdS-SF@PP8GU17dX6(o)op(;NE3Qqc1+IvqvYYq-Q9lx2YF;H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST new file mode 100644 index 00000000..5b30e9bc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST @@ -0,0 +1 @@ +;;; Section 13.2: Predicates on Characters ;;; Peter Reidy after Greg Nuyens, 30 April 86 ;;; See if alphanumeric-p is true for just the alphabetic and numeric characters - not semi-standard characters or other graphic characters. ;;; Filed as {eris}cml>test>13-2-alphanumeric-p.tst (do-test alphanumericp-test (every #'alphanumericp '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (every #'alphanumericp '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (notany #'alphanumericp '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7460aa146936397bdba0cdadf70bf0e3dd353167 GIT binary patch literal 1170 zcmah|?^7E^7~V@t2uZ-u5uB;TUa{2nWRavqDOKxnY)Ig8NAEVJ_!~oLVgrf!QLVMu zVWy5B;#1Sq&YcebgX6ba$A0i1@;|`c)GE{u&V9IjpWXL)-{*OEJEZT5VX8)Tt5&WQ z>uR;tthJizX0@(1s;zpVsBQ{ey=mAEyOq(6<*5sahAR)gb4u|TYaPLrbyClCy0z10fA5%&Xf49W?&(899 z)*pm)O5a#Z0Yz}$EB!pO+OtG#hY5)h^0-_$+9}1$aT4hBerO-p4BJ}BN{KY1TMH(0 z=zLZn)}pHgjtK9DHACk{hB}Pr9iiRmnHO@`T+VU<<-aGmt@+VlzdsNR3%`am<~X)P z?L1$}b1gU^5@MQetJk2=fkA`LaT~Q}~V9Zp`|DP)*gKL7juUEPtZc)gRt(&X}b6q^74Yj=ecml>test>13-2-both-case-p.test ;; ;; Syntax: both-case-p char ;; ;; Function Description: Returns non-nil iff char is a character with both uppper- and lower-case representations (i.e. the 25 letters of the alphabet) and NIL for any other character; does not accept arguments other than characters. ;; ;; Argument(s): char - any cml character ;; ;; Returns: non-nil or NIL ;; (do-test both-case-p-test (let ((both-case-egs '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (semi-standard-egs '(#\backspace #\tab #\linefeed #\page #\return #\rubout)) (digit-egs '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)) (other-graphic-egs '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\ )) ) (and (every #'both-case-p both-case-egs) (notany #'both-case-p semi-standard-egs) (notany #'both-case-p digit-egs) (notany #'both-case-p other-graphic-egs) ) ; and ) ; let ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ee9d86671c19c2fe939eb21c6181efc6f5e23084 GIT binary patch literal 3499 zcmd^CUu;`f8Nc`1PVM}won~q3wdsvX)8OQKOV&b{c62w+P2%Rp*SWr~o3asH$EnTS zB(t4$U0KOCiEWzoZCSK&Pf>-0kT&3fE(nRSK^_nfOh^okfp`F^5)uOOfZ$~k59RyL zNt&=d5RLIflB3`Gedjyh-*fM|S(SX};-(s3ytGs*7b@!Fa&2k3rp_-`)av4LC0|hI zQLbK%Tek7!gdU%aog8dT?^wxK3b|TgPIZLMmPy8)gq3vH zNNOoeO&>QT#lLBVtjlhF@8EsfkQSfNZOxd@=%#ez)!@^T|yVBjJ$TaFIv3eh~4_ABJ5Fhw(3bCj6s1ifJoSWdBF%ypKJ+kNI8!0~?rswkO-0 z9cacTcL}K~AhuC@8<*Rj-gCEHd~>#S!)itPw^j2+tM#Xnv|4=DYMoT%7M$KZknJP$ zxbBxEG__I6M>pQ^tncWNa(=5vesbEC?P`*w^*)-bq_#D(v8@?341Z8kZk`qI^i~`J^4**5#ng(k?KnDcbYhw>J!7@sOqBOnt#X4Ty*C@)DCey3KURy+ zS>f^%h%2R6aHhWhlokFJ?Pzzc4y&^l4LoOc7Q?e0XwGU?(D2RgWBA{ELq0*ida^yc z@ulDKb$;8|uXpWBdWY9{H=aIzR@tuI*#ECGSt)*!ZTCI3)pk0?bo_Rg!pAQWJ_hSc zS5M(vC5uD5%jcu8p{9=*dh<8?)@Gbd<@8 z{L$Tx6=hAHy|~~{JEL?3r0?7@bUS#0xU?s2OeJuc1wA1a@U)?*A(M*hX#*wuNWrwS zo3tJ8n%1ac+m@|a87Gx-qMo}@r8%l6XEZLSSUepl3nVdN-AqmBXlFkP{3*PiC%qYfU2c1^X3R@BS~uNJ51}WoaaK2pSV$TuQQaYGqOnjsW7|e@$Mwl%T04bn?b`*X zxJ6v7iI(@FC7*HDuxF5Yzr_v{9A*az4zfc8&8!Q-bBnKe_H$6aE1-{SDo41cau?T> z|H{|op9#3ZRpjejMSel3*yy$iqr%=ANgU`vK7g|3^vu+VWonpbh70|a>4=p{j;2sY z`U|6CNWWtdg0}?wj$n1xeU(KXX5A)>#8~$s7I_erd|ApcWn1G(VuQqZUx@YL$3sJs z>d4D_fE_`p_gy@s0qTn$cMO{(-^N`n+g}VMy1;q~9$-faWY&Y=`G6bn{8_*^xQger zfG)17yw91kE?7yhF~M566-DOT<-ZGfhp)*$5%4u^XK*_bZQQmpDMsHf@(SNAUl!Yn z0umUx*TmyY8b>LODSa}Ne`4(f ze`Ngxw*>nG8zA-@!G10@f5`Te@CQP3U9j&7&DR9GE;OHKA=3P+(0oR)6*llV3q8W3 z=UH2p^*gL>nhhja+bI_9XPtel{|M`huz@h^yc;+BCfxd=d@)zi3Xd-5%If7(t*Cx( zNF`A&Un^9qq%`W*4?BfwO^saBBkFt(zlP`3(t`MqCD}E8434^Ach~3z(-pT3Jfqr& zo+2}Wr$aZ>tO?avKd-*G)2;XJ2%vOvVX;!Es&l3J`9h_zkjFWC%IB&DjKtf{VhGB; z+!MQJ+m6!h)_d?fw{m4WcC}RHWHYx?ty(D0)AmE$ihK*cf=vEBG!pz4S_s~Q0KqT8 zPw@Ij9LZ~LJvKaI;LF4i-_-mch1#9+Y}Msjdb3g#u{;aS1n1nf2Jk}wTA&#kh5r$E zEe7|(APm8Ma14&aXW+AN0`7-yh`^_y2aZ559ECpkG(@2v20()t+yldK5>CMbI8MWZ z@OgL$9)>T#EPN5J!k6JmxCSczHj3mkfwPc> tb1(zvX>U|?h#nc~pJL9RgI|a_Kj}BbJhULN?Xcml>test>13-2-char-equal.test ;; ;; Syntax: char-equal char &rest more-characters ;; ;; Function Description: true if all characters are the same apart from difference in case, bits or fonts attributes, nil otherwise ;; ;; Argument(s): character ;; ;; Returns: non-nil or nil ;; ;; NOTE: This file does not test bit or font attributes. (do-test-group (char-equal-group :before (test-setq upcase '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) lowcase '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) non-alpha '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ ) stdchars (concatenate 'list upcase lowcase non-alpha) semistd '(#\Backspace #\Tab #\Linefeed #\Page #\Return #\Rubout) pagechar #\page ) ; test-setq ) ; char-equal-group ;; (do-test "every character is char-equal itself" (and (every 'char-equal stdchars stdchars) (every 'char-equal semistd (list #\backspace #\TAB #\lINEfEEd pagechar #\rEtUrN #\Rubout)) ) ; and ) ; do-test "every character is char-equal itself" ;; (do-test "char-equal ignores differences in case" (and (every 'char-equal lowcase (mapcar 'char-upcase lowcase)) (every 'char-equal upcase (mapcar 'char-downcase upcase)) (every 'char-equal (mapcar 'char-upcase stdchars) (mapcar 'char-downcase stdchars)) ) ; and ) ; do-test "char-equal ignores differences in case" ;; (do-test "char-equal with >2 characters" (and (every 'char-equal stdchars stdchars (mapcar 'char-upcase stdchars)) (every 'char-equal semistd semistd semistd (mapcar 'char-downcase semistd)) ) ) ; do-test "char-equal with >2 characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0af83b5268a2370a4f21fa0d93a6c6fa0462919f GIT binary patch literal 2257 zcmb`JU1%It6vywKBx(l1# zWp*}N#iA7vWU$84I#&rIQvAS&BEAGGdGJMw_$t1MuObK{BBJqrI5f=)eQ+NRXU_l5 z`Q3Bw?3vjuF!ZESLP~3+U2ixpYIVJK*F)8cow&zrl)pa^m``iO4cNEEOx85KZ3kxL7<&Vte=jUhROR`zwwA<#)<>!v%=X101 zz3nS7-2wnqz%F$$0McLp1aJ9i(NaxIS}K%ONt0JqG1v zL{_)2q%Hs;>}Jvet>%l`^&;G90`JSBaB6Bi10(h8X92kL!X2Zqw)0GCS5J}fm#xx8 zJ@pj;Tea8pR8fG#Lwc`ak3DSzJ9WSYd z^mu_N+OjDMaU2tp#1h1YiN%OTiA9JFk@3rjifkz>lA&5D<}YHNHZ65k5Xc=P zd_a|wDr@C6X-PL$O%X!@_GVkUh!X>caBLt=#xW(ThM^mhUbfcCmN<|h2}x1bPD@Ou zkibvp4vhDq0RZqIo#`wc(H#OBR8Pt!8hlEE2rWRiX!tR$Kq(uBs_lD$U`W?6t^DS} zD6*;YZE=DwpTr~7nRt{s1&>h&m?F>z z&94Ujc%^2$#}@O5yqDc`sO~u%XrtTl(6L2Y-ur=nkL8eX`n)`i)@}0bsiJz5e>SLg z{$6_9)4{vJCHfY{8@JV}uFZpMOt1pa*oST|FVSF=52yAH$A z_TX=f1V8H~eGvE)oRmj1HaQJ6a}<$}@XSN>`gxlC9#4L%H+gk`vV1W43{5WZ= ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-ge.test ;; ;; Syntax: char>= char &rest more-characters ;; ;; Function Description: true if each character >= the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char>=group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char>=: upper-case characters in order are >=" (char>= #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char>=: lower-case characters in order are >=" (char>= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char>=: digits in order are >=" (char>= #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char>=: #\A >= #\9 or #\0 >= Z" (or (char>= #\A #\9 ) (char>= #\0 #\Z)) ) ;; (do-test "char>=: #\a >= #\9 or #\0 >= z" (or (char>= #\a #\9 ) (char>= #\0 #\z )) ) ;; (do-test "char>= accepts characters that are char=" (and (char>= #\3 #\3 #\3 #\3) (char>= #\Q #\Q #\Q #\Q #\P) ) ) ;; (do-test "char>= accepts non-alphanumeric characters" (and (char>= #\; #\; #\;) (char>= #\space #\space #\space) ) ) ;; (do-test "char>=: every item must >=" (not (or (char>= #\3 #\3 #\3 #\3 #\4) (char>= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a #\b) )) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..004d2407299a2c4147bc0f3341e9b9c780a4f2ff GIT binary patch literal 2347 zcmb_eU1%It6ux&hSvR}Mc2kmQmnOXiYH@XzTIX7Vi1>pKQu-hSD?tR2(svPG#8(jn5fRaNf4U^w75d;l+&y!? zd(L;hduPtQyAHa~$XO)UR_b=ea!{?|)f*mKsyWE5H5}7IO9V$R%bKpdGAGINV^57o z^Lu7Y$0~YO2^kH`EfrTEMdQ;*sylXtJRChr-0}3(M0#>^EIK3Qvz+aoITPuLsr1zJ zSafIeDooS>04CU`rU!ro2!Y_TpGX->-VkRpSw&Q(1tk@%2Y!UCMJ(hMJ@ES{kXNgV z73;iJq03ou0R$j;+mFl?RN2UAYOn!cg}uQgzb~VTIkGfqRsllf4hv<6fxmzJ32{P{ z=OkU6)fLH5^c>i{8ovmDaJxStP)%QyZ_dN5D)7FX7fz2P`(fC=xeUPmi}ww}^47EQ zZ7ojRU)QsjwD{Kmte4-^;`0LRBahebKaD5_9T5O}0ob<9QMS@1>#Zhhq=T#wHCcN) z$$GxY+Sf_e+fCM32U&&DCTnjeS>I@~M#(F0zS$T6o%j->sZd^hN3c z76SifA@CO#0zc*8#~gfzg9Zmra!_I*_=kbuF9w32Irs?&Kjh#QJf!0R4G%tzhuC7j zq5^WdHmgzr*O(l-h19!DPQkEB*Uq-$b<8ppe1J|KPD7XM-LGpX4BCgCh(CKQa(}$Gva4d5eRu;iQ9;llZ_RIC&5!nX(&!pEk=y=U5t% z)7)7_)G3-Cxvo|ku7{qtkn1_N=~Y%y#d2Nbm5WvKW1*_`l1CTyS>PWsED}0;K^jF% zMRKK;kX_}s5ydVXreQAx*MbfDp^nJxtQYTk>)8xB|D|jm$7mSY;FAT-xU+BP0{=0p zOI&6bqEk=r%5;ekt5iM0q?)y=XD>Hu4VRWYgNLa(9BhQvifhN$9;e=e)H}OotxZ!e z!c^fAQWGEI`}t?!Kh#nT*~`_MW4XvIx)v(gOG}nxRZWZ5fWNaE@J2h&2Z4X2g-0ye z%eLo=5%>fDrHGUVzp*TE ly*=ywz<;1Mt3^22#KUJ>v*z0}b`{Rz;jY$b@UFD8^DhHwtBL>s literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST new file mode 100644 index 00000000..dd4ebb16 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-greaterp ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-greaterp.test ;; ;; Syntax: char-greaterp char &rest more-characters ;; ;; Function Description: true if each character is greater than the next (ignoring differences in font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file doesn't test font or bit attributes. (do-test-group char-greaterp-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char-greaterp-upper-case" (char-greaterp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char-greaterp-lower-case" (char-greaterp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char-greaterp-digits" (char-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char-greaterp-digits-outside-upper-case" (or (char-greaterp #\A #\9 ) (char-greaterp #\0 #\Z)) ) ;; (do-test "char-greaterp-digits-outside-lower-case" (or (char-greaterp #\a #\9 ) (char-greaterp #\0 #\z)) ) ;; (do-test "char-greaterp ignores case differences" (char-greaterp #\z #\Y #\x #\W #\V #\u #\T #\S #\r #\q #\P #\o #\N #\m #\L #\k #\J #\i #\H #\g #\F #\e #\D #\c #\B #\a) ) ;; (do-test "char-greaterp: characters needn't be contiguous" (every 'char-greaterp '(#\Z #\e #\9) '(#\a #\B #\0)) ) ; do-test "char-greaterp: characters needn't be contiguous" ;; (do-test "char<: every character must be strictly less than the next" (not (or (char-greaterp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A #\a) (char-greaterp #\Z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) (char-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0 #\0) )) ) ; do-test "char<: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..61e24482c38ceaecefbe7b555ff8e21d460eb485 GIT binary patch literal 2081 zcmb_dL2MgE6#ctSjAJ{-K}o7wNjj>8Dj7BqH$ZDj(XyQ+CeCiUUbjtE30!*n#q!Hpk4zsiW z&7b$*pP4_i4!sw&JkgrVty6|}0Lrk1T^~RaLg2sSCDRrySjto`PZeFAqiKKL_aZzOrC6Y*?+s*#+iWRy zd&RC}I?E170RG!vWU8oZR?g7<4e3=W?qBozbGkCmQ&XoY$dS7&$S(O_eB!v0QM4J= zRHiN1yb-+$Ag>H0WmNM;_4cfEs{!tpv-0_o)PNMO-ChEC;Oc!tQuWqzi7g|+&0p8^ z*Nnth0PEE^jl`@h_4D7Ght7{71-1x49AK+fCP9u})~~y)kppCvNSC$mAX!(sto;Yc z`fZmrc7Uw%BVE=w-<<9q!~hO%>*P1OA)^0RIG6Zril6$eY7*qAf885NYleO%hX+`h zQS~!j$uZvgdF$gX!dsZPUS2T+X-&1X8O5Yl(c~vy3rZ$jSSVO@ zPL{dHpr|P=PgT7*uS^-{Tp`UQS=v9_GSVy-O0d4r{k(z_X=<8=sTf6TzG$UGNj@Q- zR`mrXz>&oFk`wn-WFiE>daw)+VO6y_Q4c+*=Fuo~Ba8x63(eUbb8cQ}R(9*Fq;5M7ajT^U|JbBq zzvN<47kuxCWpme~SJb0qvBV#c3aK^3-H+In2hnZFf8XE0V>hOmRJEvb&mQJ;7B$s; zfyK~`Cx5nRSTqnWhkfrD>N=g>k>_v$cBOGFkXUXu+}cv7*>NzG%tmq1zVkOiYwFtN zwMWtV2Ca*0_S#9bJ`dEeF&>K@5$pI7&m#z;RBB5#*HQT6=+r8 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST new file mode 100644 index 00000000..bb4015fe --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char> ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-gt.test ;; ;; Syntax: char> char &rest more-characters ;; ;; Function Description: true if each character is greater than the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char>-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char>-upper-case" (char> #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char>-lower-case" (char> #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char>-digits" (char> #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char>-digits-outside-upper-case" (or (char> #\A #\9 ) (char> #\0 #\Z)) ) ;; (do-test "char>-digits-outside-lower-case" (or (char> #\a #\9 ) (char> #\0 #\z)) ) ;; (do-test "char>: characters needn't be contiguous" (every 'char> '(#\Z #\e #\9) '(#\A #\b #\0)) ) ; do-test "char>: characters needn't be contiguous" ;; (do-test "char<: every character must be strictly less than the next" (not (or (char> #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A #\A) (char> #\z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) (char> #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0 #\0) )) ) ; do-test "char<: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fffa1b0557ec9a48b4f3cede55dc198408f92126 GIT binary patch literal 2299 zcmb_dUuYaf7@yfB=jHBly+{)2(Ok!bKDfG}iK(_RLDuaiIdj=f_x9SR6m;2adWVv>z5%;t2(P-k^HTnU3H&jr+Co-Lnyj6zWIfwt z?P?|KohEC%g{;y*lQq#w*4LV>F*x$($;J_C-47vs*W4oce}#j@r_<0&>%|n3lHt{0 zpRAe2(JX5VWm+|k=5$MWDhr4)m6xR$?UWKQ;xM{kbi#VHI%d`}; zV9yn7xvd)l60&N{D;#GeVUQZWr`PwiAw=6*gQr=)eg#DB`f)YKoHcMFOn_=L_fw`o zD_E9pY`aY;W^*4frM=9|(LQD#0{Ra9xNgle5Ah}VPrd~I z#FyZY1^A%=-x8oLz+(bbIf(w^Ao_!Y=tlv5B*6Ctc$M~9w8x~qPtrb~>=#VHoMlcK zOu%(6hn0|dm*M`47%X>QidQL*(CJ<_IW9a!m<%fuyZ6Q?U=shp*WhpYB)%<7AV5Kb z>jHdCfPw~RIEcRIAo@mlUkmew0AHbLpQcCY-iK*=A5C*fH^X4RTXg*Ki7^5s;w*c zoM|p=>z10!(>PlOM)q0IASC$p0TrE1wjU~@7xm((5Y`2rN zpP2)|buo5vfPFu>?K{fF&cml>test>13-2-char-le.test ;; ;; Syntax: char<= char &rest more-characters ;; ;; Function Description: true if each character is <= the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char<=-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper-case characters in order are all char<=" (char<= #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ; do-test "upper-case characters in order are all char<=" ;; (do-test "lower-case characters in order are all char<=" (char<= #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ; do-test "lower-case characters in order are all char<=" ;; (do-test "digits in order are all char<=" (char<= #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ; do-test "digits in order are all char<=" ;; (do-test "#\9 <= #\A or #\Z #\0" (or (char<= #\9 #\A ) (char<= #\Z #\0)) ) ; do-test "#\9 <= #\A or #\Z #\0" ;; (do-test "#\9 <= #\a or #\z #\0" (or (char<= #\9 #\a ) (char<= #\z #\0)) ) ; do-test "#\9 <= #\a or #\z #\0" ;; (do-test "char<= accepts char= characters" (and (char<= #\c #\c #\c #\c #\c #\c #\c #\c) (char<= #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\8) (char<= #\0 #\0 #\0 #\2 #\2 #\2 #\4 #\4 #\4) ) ; and ) ; do-test "char<= accepts char= characters" ;; (do-test "char<= accepts non-alphanumeric characters" (every 'char<= '(#\newline #\") '(#\newline #\")) ) ; do-test "char<= accepts non-alphanumeric characters" ;; (do-test "char<=: every character must <=" (not (or (char<= #\X #\X #\X #\W #\X #\X #\X #\X) (char<= #\5 #\5 #\5 #\5 #\5 #\5 #\4) )) ) ; do-test "char<=: every character must <=" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4ff95024808fb7441cdf7f5faf74edb164302d6f GIT binary patch literal 2382 zcmb_dZ)hAv6rb57=Ove1E|NrgG}keqh-)`AF-j7JvTirYHJ9D%?q1u3f?n@7xy8%f zvAb7I#iA7vWJyg+>y9Oeh=1^dlztF`l^}vh>30#oh+jnzL_|d6{OOsr2P$|Rb8p{o z-uumO-t3#*03D~43{tAAHK%O5s9N`HbssHPUF22kZox*&1V=9@x}m-}CoA)#PmFb$ zdu9r*o%ih`vg)>1%nV^c`3xlWlpOimJaZ2GbB>4}Nat{K_PaJGNV8J`}XoIX4` z+O@NJ6(*_xfCAX2rW1e!XanJ;AR$_+X-PBbj4EmJf+~g^VGt#Ik#eSLghAgp@~bte zY@fBubUUjafB=MV1kstCrdVlR3opZ$V0U;i=t*l*mTXO)Re=z_!$R3%81#-kDve9Z zoNP!L)ikqU^J@G80K)CQgg^y-TDmz8w<^H@Y+g8-O7_8sb8`iN`!C!#083j>$G7!3 zaevy#T-4)V0I*SdO^?qDu!lTef8Zpd6m&!Z=muchDGal1Hdt>pSfedug{Z;W*-F;4 z4c4Akvfgg6##+cK3^!Q2Tgm!rgSCqsdE;bb0JQFf5Wa0J5&yr!iNs?`(oWl@1Q6ok zm0-W9=-SaV?F?y7){bUWLwYJr5N*~Jg)ZDFbdwPyqlb)6GNNQe$mk&L*e5EorOZi& zYUK>lP73SCh`DH5>VhDUh<@I%N=B8nTvnRVjRjN0P=L+ZmM-F0TQBZxOOW=Ai>hJh zhNS1LY|awf`ba{zC~J!n!zoD^B*yM(_ue)Da69esB<ghHA8_zZ4q6;M&Ow=h;7E9YXqQWj#9%4ER)r#+|)T?!mu6GI#QFAc7+`hiFes0}fpQ8SQ)R)Qc%=%&KN0}^~ zB8%b!ysE#2!N|xID+DhM8p$K_$sRek7o*wm7q$qz(M9vjx5dc%C=8lj(-vaHu2EX-8}Pzqh721M~+!M)P8q9cuU^d`3tM` Bvw;8r literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST new file mode 100644 index 00000000..84faa429 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-lessp ;; ;; Source: CLtL p. 239 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-lessp.test ;; ;; Syntax: char-lessp char &rest more-characters ;; ;; Function Description: true if each character is less than the next (ignoring differences of font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file doesn't test font or bit attributes. (do-test-group char-lessp-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper case letters in order are char-lessp" (char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ;; (do-test "lower case letters in order are char-lessp" (char-lessp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ;; (do-test "char-lessp ignores case differences" (char-lessp #\a #\B #\c #\D #\e #\F #\g #\H #\i #\J #\k #\L #\m #\N #\o #\P #\q #\R #\s #\T #\u #\V #\w #\X #\y #\Z) ) ;; (do-test "digits in order are char-lessp" (char-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ;; (do-test "#\9 char-lessp #\A or #\Z char-lessp 0" (or (char-lessp #\9 #\A) (char-lessp #\Z #\0)) ) ;; (do-test "#\9 char-lessp #\a or #\z char-lessp 0" (or (char-lessp #\9 #\a) (char-lessp #\z #\0)) ) ;; (do-test "char-lessp: characters needn't be contiguous" (every 'char-lessp '(#\A #\A #\b #\0) '(#\Z #\z #\e #\9)) ) ; do-test "char-lessp: characters needn't be contiguous" ;; (do-test "char-lessp: every character must be strictly less than the next" (not (or (char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\Z) (char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\z) (char-lessp #\a #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) (char-lessp #\a #\A #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) (char-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9) )) ) ; do-test "char-lessp: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..518f8fb7718cb54a0ad82e31dbc985e0190af899 GIT binary patch literal 2124 zcmb_dL2MgE6rEis#<3mapd?kSBpo%XDjBvUX+Vt$Ld$lOm^i!XdfhfrC2;LcY~k3} z?m7?<6%-*Pv`Pt4%MK_)2q6%sid#id4qPfg;=q9`CoUX7;(!Da;s2c&l18Wpau|>Q zn|W{EpP4_qNjfhnIjS^Po7I|S(?-i}wp_a0u&L8%*(HlE15RI7bVGe*R#xUtKQR`~ z?;9!ER?)S})NEN!xw!ra9h;1X;aOc(sVYbN}4>cru|Ldi$E??A+H*~*E3GtMpLR; zYgP@@S#^j&i2t@1nJ#FGnbkFaOL$d?``5khtR^i$YVwRq#K@isstdjsA3GzBOUkTl zNI8>i-;7=(L|p4hisLwJ>)6F%l)x4tBu>aqwM2s)+p1r;RU=2JD$urS*HNmjwN<;1 zQuW)mYU~JA#Yfw!aX6gz8N>)Vx}y`{XfF}{zsAAhGbyfLMK{)`) zUjaz|3_$WT2S4TD#~i%D`VH2rv%aTTe~{PnxYmN9&uHjF4OYh8!e|N}q_Bo*23boi zg?@fv1K9npv(y9| zc$lRISt_u5+4nM~O3|LmP^S})ohPBvnzKhQ$O^*leNYRKqwU*3r@#{ gQ~NKOZ8o%YP+|_~t!DH7^cgnPaga*hdvbU8Z*kpVdH?_b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.TEST new file mode 100644 index 0000000000000000000000000000000000000000..af7829084009dc98ddda01687aafbfefa84cfd54 GIT binary patch literal 1865 zcmchXTTdE66vz9z4}6CcOe!Qo5Lz!_Oi*iWiY(BcFzA?W_vx_PgUroRy5YM!!%~=IO)}fyotlulRD5;^Za_(s z+MV@c!|qfhjt#ALx`h8mgc#W%7;$d8-KC-7NQT0(CHT7Ew6I_pYZ2|tGdDx_=8joL z^YR8SbI(D^DjkYBZLAfG17RJVBoRz>X_NLik4+-=yGF^uHb^1H`2 zG&1qI?vgVple{1n;WV?CohNB2W^2h!g~AV$;v2U@O2(uyG}qE{A*pXB>5P@D*?O+) zPJ#D&%q}$w@hYtv*>U5o1VP|MRceuL`0yGNqthfWcK#o$JsQKaRD79=Sh_jQQbc;r zx#$aRNW?Ko$1}S^LPeR-i$xnD1f^|)dPYs616CoT(8O14<`iq4G%LZvJyp{rL7hTj z8G$?BHE>MYM3@zZb7fVk1VPQ0Ws7L(tPgg;F4zNaz&>~j4!}F`9((`;a0otvBQOM? zz%dwsF*pIA!58oqd;_QTN>KNiDrt@N^%Jz-OIuyhVW5CH}kU;?H8+5=c@EWXvb+7?83+rf{ASfpT zOL=jysgHu;aav5Ys@@Bxijw)Q*i^qCpJLpqKOnqpRpeH0|7lf}tlmCmHS3)6CBe1g zNG)eg9cty|B-N?SWaoXloHyHYE$=p8!&aUA&`bAa+|1+?^{BW?RDH6WKijG}mOJ)? z{8g~Hbk-Rex)^uouNOlmSZPN{Hd4O0BF}U~kOY5AN^X6-KUd3_+&-y~vywsWqhcml>test>13-2-char-not-equal.test ;; ;; Syntax: char-not-equal char &rest more-characters ;; ;; Function Description: true if all characters are different (apart from differences in font, bit or case attributes, which the function ignores), nil otherwise. ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file doesn't test font or bit attributes (do-test-group (char-not-equal-group :before (test-setq allchars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\newline #\backspace #\linefeed #\tab #\page #\return #\rubout) allcharsb (concatenate 'list (cdr allchars) (list (car allchars))) ) ; test-setq ) ; char-not-equal-group ;; (do-test "No character is char-not-equal itself" (notany 'char-not-equal allchars allchars allchars) ) ;; (do-test "distinct characters are always char-not-equal" (every 'char-not-equal allchars allcharsb) ) ;; (do-test "char-not-equal ignores case differences" (and (notany 'char-not-equal allchars (mapcar 'char-upcase allchars)) (notany 'char-not-equal allchars (mapcar 'char-downcase allchars)) ) ) ;; (do-test "char-not-equal: all characters must be distinct" (not (char-not-equal #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\newline #\backspace #\linefeed #\tab #\page #\return #\A)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4d8353bc194eab7e95de4831dcb10e8afb09c898 GIT binary patch literal 2599 zcmb_eO>7%Q6rNot#<88muF^!cl62(20mG(snxZs-(6Zem#?EfKUbmz|pq0IeEjhMX z+byM{Ksg|xRZCj6>`+ArA%4UGRXrd@6h(*&s<

1#v<`NFam|;wQYBsmYH)An@Vo z?fYilH{U$Z%=0ShepJa|rMglpm2C%Cn~hqtftRWdu2-8*-o{IS2#AqYdhM5Q-ol@-DfNgsEmtX(p9XB~6}J6W*%l24F8zE~^@z8=b(7 zYE3HJr|dG_&Pp8#2zf8Nftj49m?>TJE(^~IVeg{bo6@8O*qS`6A~A5Ag|Z8tJD5Bq zO-Ra|Y)G1JO0$M4o2s#Z)~@!SN5~hCMntOXgW}D!uwFrp57Xia9E%G6(#>Ur_ME?C zNGPs9(YK-ZLHONj=Az#BF+!`w7xlihDD=YT^`R4SNfGKqq@2B7>{~LsZp*q0eem)%Q#ztt*YbhKJX$(Sp$Wh@X=fb=Sx~ z>Mrr<1@0P<7;SrS>AWdE{Q#ebnG?QZpuic0TO4#b$QgwO2k+yc#G_H>(3cEEpYiAu z?q1^H^Caew*d*C^4~Y$v7~3SYheW<;IZ~zCkd|5Rb86EVx{PxM(*Y~rfHu0)tT*rj z4}xl6m*?&`Z3yG%??Nbm8|1-I#b5XfFgW z#Oe3xZQqYGU1Ss>vY#)fd+ve1UyhB~Pd2Ucu7%Qkp+Fm<@H4dQu_I6~JZ53|=P~v) z9y5iY2 zuAbsl{x&M~(_fteTw1PF9lMV6R^7&h($bRc*p<9ZtBihNTcml>test>13-2-char-not-greaterp.test ;; ;; Syntax: char-not-greaterp char &rest more-characters ;; ;; Function Description: true if each character is <= the next (ignoring differences in font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char-not-greaterp-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper-case characters in order are all char-not-greaterp" (char-not-greaterp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ; do-test "upper-case characters in order are all char-not-greaterp" ;; (do-test "lower-case characters in order are all char-not-greaterp" (char-not-greaterp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ; do-test "lower-case characters in order are all char-not-greaterp" ;; (do-test "char-not-greaterp ignores case differences" (char-not-greaterp #\A #\b #\C #\d #\E #\f #\G #\h #\I #\j #\K #\l #\M #\n #\O #\p #\Q #\r #\S #\t #\U #\v #\W #\x #\Y #\z) ) ; do-test "char-not-greaterp ignores case differences" ;; (do-test "digits in order are all char-not-greaterp" (char-not-greaterp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ; do-test "digits in order are all char-not-greaterp" ;; (do-test "#\9 <= #\A or #\Z #\0" (or (char-not-greaterp #\9 #\A ) (char-not-greaterp #\Z #\0)) ) ; do-test "#\9 <= #\A or #\Z #\0" ;; (do-test "#\9 <= #\a or #\z #\0" (or (char-not-greaterp #\9 #\a ) (char-not-greaterp #\z #\0)) ) ; do-test "#\9 <= #\a or #\z #\0" ;; (do-test "char-not-greaterp accepts char-equal characters" (and (char-not-greaterp #\c #\C #\c #\c #\C #\C #\c #\C) (char-not-greaterp #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\8) (char-not-greaterp #\0 #\0 #\0 #\2 #\2 #\2 #\4 #\4 #\4) ) ; and ) ; do-test "char-not-greaterp accepts char= characters" ;; (do-test "char-not-greaterp accepts non-alphanumeric characters" (every 'char-not-greaterp '(#\newline #\") '(#\newline #\")) ) ; do-test "char-not-greaterp accepts non-alphanumeric characters" ;; (do-test "char-not-greaterp: every character must <=" (not (or (char-not-greaterp #\X #\X #\x #\W #\X #\X #\X #\X) (char-not-greaterp #\5 #\5 #\5 #\5 #\5 #\5 #\4) )) ) ; do-test "char-not-greaterp: every character must <=" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c54248ef8c34d8ca2f38aa8c738b616f30b52013 GIT binary patch literal 2538 zcmb`JU1%It6vywKP1fCfY&JDXn|{FrAs6p6HsDj6A2^_L+2MDxEnn zHPN-XejX-W0DuiPsEY%T1Q8Iv9VAnxVwmD=Hm``Pw4kKIwJ?a0TEv2(=wZ;GM!s7U zE6%D@q2;X90R$j?D~Qb&RN2gGYIqjD412;eL2p(S7fET-oC1W{zZ6P`VQ}Zr3r3(Bna>6mRw;x8!SC;|Ub^4Couyo~_ z#DqQIi^P zCv~++?QJLZdXw7SMyfE@r1rFv`h1hx)lTZyO=_Zz)X4rOweSB@$>;sVUa~efN=YE} zh3A6Nl&q^OAZvuju0AS)!O^po|T zNGZCm>7rIJ7Yk-8vWq;>lakcqBGV}(43d*O_K#!)0Ng=0jZwPz`v|B*IV$C8AdnzR z6Oc?23Y#|E5fIhAJhBaK+cX!IS~TB9m$0quxz9S>9YCf-BcYdl)zZib5w@(3{pe_$f~mPgmP z3%K|yk9_VP;-bi-eawOHnFzk&(O2BP!Nphbu!o1I@t*tf@F*T0p&8u>gE6~gd1BS| z$stj%*D{D472Ziy_MH{9(y06B(MRaWKf>T{(;?y5DQOHXS>!k@qH>j=WK=tK4;}Vd z_-=TXewO=WU6D*h+%d=btf}Zy-oV{-80p-Rf@Uf#LE%yuq_-!7EZcT!ejQcas%TYe zC9B$4alEpP=s3&v9j{K`dJ(f~o@Ot{qXdob;!G_J4*m!8CIa~-%SV>yFs$f2+psDW zo8#D63l{zv2IJeY88mK@R-y4ji2O8+AE4JS5D5I8LExvYkoRu|k#<5(P{?~6@>DBi zAq?)_nMtv{TqaE;v*UV2@;5^(W3vdeoD*%~05ZS#ZReo!a@F;mI;xN9JyUYt(AD$Iao9j_oM$jcml>test>13-2-char-not-lessp.test ;; ;; Syntax: char-not-lessp char &rest more-characters ;; ;; Function Description: true if each character >= the next (ignoring differences in font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file does not test font or bit attributes (do-test-group char-not-lesspgroup ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char-not-lessp: upper-case characters in order are >=" (char-not-lessp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char-not-lessp: lower-case characters in order are >=" (char-not-lessp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char-not-lessp ignores case differences" (char-not-lessp #\z #\Y #\x #\W #\v #\U #\t #\S #\r #\Q #\p #\O #\n #\M #\l #\K #\j #\I #\h #\G #\f #\E #\d #\C #\b #\A) ) ;; (do-test "char-not-lessp: digits in order are >=" (char-not-lessp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char-not-lessp: #\A >= #\9 or #\0 >= Z" (or (char-not-lessp #\A #\9 ) (char-not-lessp #\0 #\Z)) ) ;; (do-test "char-not-lessp: #\a >= #\9 or #\0 >= z" (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z)) ) ;; (do-test "char-not-lessp accepts characters that are char-equal" (and (char-not-lessp #\3 #\3 #\3 #\3) (char-not-lessp #\Q #\q #\Q #\q #\P #\p) ) ) ;; (do-test "char-not-lessp accepts non-alphanumeric characters" (and (char-not-lessp #\; #\; #\;) (char-not-lessp #\space #\space #\space) ) ) ;; (do-test "char-not-lessp: every item must >=" (not (or (char-not-lessp #\3 #\3 #\3 #\3 #\4) (char-not-lessp #\z #\y #\x #\w #\v #\U #\T #\S #\r #\q #\p #\o #\n #\m #\l #\k #\j #\I #\h #\G #\F #\e #\d #\c #\b #\a #\b) )) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9afb4d4bfaf170b90f12392ce30cfe644d8a8b40 GIT binary patch literal 2436 zcmcImTWl0n7(TPTu-hBErLAQt%TVcsg{gK60)-0G>9k$Co!QRJvJ}Nqwp(^(Y3uHm zi-lStL5!OpYK6=}3BDL&OcXIZaM67*zL@x6AU>M-Vxox#!;>%Ke`Z>!@Sus>-IMS9 z_y2r5|D4W}qTN!6m&OlGBvbJ;KR%hAn9TB{<7qxKKADci`BBvKQoyZ`jaM(k<#CJKNvJ1lrr$ z+5?+fN*-Lgz`4f>Au*C?;3C9L3W)i3&h0m3-4MEiAz4twe%Wu%nmH$)MTqFKX68Hr zK07`kq~eF;DR!Jg8Nv}_p36DABZ_1MRmGg+X1Fr*Y_2@02w^;$*dr5%b3O~p&Y8K= z);1v^NWG#a50Fb2N=_2u_{!sUux4&0ZufCF#<-f#`yA1FuZJr>V0Cz{4)Ng^TTXbr z`1S7e-prwzg`$Yk|Lbni=Cf#v@isK)lee*G<;f+>xx|g3io9BZ;=S3>S+(LzLS_?h zs1NCBkIGBFI$a7dG;wO`j1QAT_{;TUlQ3& z4AtPO#pOk2&z(|ht_D*})C#VckUK+l`IM;E-JeaIQR`BB5NDF-amU|%U9J0;MbwyT zt?F&W1ZPxyV1{Zjom%0*#8*E<#%7cMnlo&5rxzc{e8No}<>vWZonKOwt{@u+p;uJ8 zLb4`w22rE*=zfQbx*Sei#kh)a<~)8$G^AcZlZ}XmGb33;SF8`}hTQLPphuNGl~PC+ zl}K3VR<(ZJPdNwoWVE6BX=%YyG&psmi%ppRaD>_L6}Zu~M3?)6Xr}H04|Nq(;^MzHgoRQ$KD1@@h72$>=jVUMmmp) z3*}v6hzZwFC}ypT1`|KQWF9G^X|l5DeM32ByNtG~M-)n;F57L;QfAI#Ca0nr@-A5$ zLSgdfUBTcwdKEo%`GBru%4yqk%Jw{Hdv@Bk6&8^DmJ7LOxsV?$7m~wd zW%^)$ry3IQJP~<{ou*TbC|%*b)EA@KEwyqAJ(?N`Q#Zzw@2o)bjTJ$@u;C(>FYg!oB8qiJ=JzJ`FgVQ`8;BtL zOgd#NXHZ$F%f`S_>N!Xo_t45HZ8B)(0BsJ^%5Ai99j$JrO%1fVo;G`Fbq&TkJ~DGv zvBYq?gCC0@7|tdS$N6kLlg%*O6*ITWK!LBH7VG)ZVZ1Fz_~e*<(J|e01G;g)o9~)) zY(jjJCX0qFJoeCpf=H(r(rGEW(I%UspUqsYUH3>bo8X@h@Jt$xW#eg9oBNUa8JxCq z({+m?k6>4L^QDhHir|wOOX%Q}*-Sh&$|5s%f=%!mliGk?Z=3+-4Az2+K?67u$RAJC zAU~P8miA5=2Sv6oSnIzAMvTqH0twUlJS{CO(RC34IWPeo#P#FbseOIv5avT@Z!cFbI2K81_R9Mj#HOZ~zjJgqPtU zq~H*Y!8lC7E0Bf^WML8x!x17g9ETGy4Lp8IEE35j`^WH%*;u*V P#_Gbq@<=Z3c<|s){*lbe literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST new file mode 100644 index 00000000..046f6742 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char= ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 5 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-chareq.test ;; ;; Syntax: char= char &rest more-characters ;; ;; Function Description: true if all characters are the same, nil otherwise ;; ;; Argument(s): character ;; ;; Returns: non-nil or nil ;; (do-test-group (char=-group :before (test-setq stdchars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ ) semistd '(#\Backspace #\Tab #\Linefeed #\Page #\Return #\Rubout) pagechar #\page) ) ; char=-group ;; (do-test "every character is char= itself" (and (every 'char= stdchars stdchars) (every 'char= semistd (list #\backspace #\TAB #\lINEfEEd pagechar #\rEtUrN #\Rubout)) ) ; and ) ; do-test "every character is char= itself" ;; (do-test "char= with >2 characters" (and (every 'char= stdchars stdchars stdchars) (every 'char= semistd semistd semistd semistd) ) ) ; do-test "char= with >2 characters" ;; (do-test "char= negative tests" (and (notevery 'char= stdchars (mapcar 'char-downcase stdchars)) (not (char= #\Z #\Z #\Z #\Z #\z)) ) ) ; do-test "char= negative tests" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b5f19e2bad0cc48ed3e5b4a075093de74032f5c9 GIT binary patch literal 2218 zcmb_d-E$LF6u-OuAZ^l`XstBzv6L2S$_CRGfdb-oyKO@^yXo$RP!utyDT$;>O;SEY zN(Ua8VRjA{MrJP#5575$4~pXh3e#cKaeVLrXZ#O*aC~s^!AA$r-K9{$8Fh3fx4(PN zJ?D2m_MYBF(r`dl1-U#kTPWr#LV2z>J698?%N3zoo~vYY!ZhlIQ?hO-r^h6DJi05^ zY_2%TR&tqIZc4D`a@DEK$t^-`ry$K%3Ps%P*nwhfa9iKtz(BNlL^4&6?Qebh2K)O5 z2ew6hNeuAYgYni3E{Vgf;`LSi~P-T?na6Hd~2LfuMUT}#v^Wu*ViCE_+ifZa2S8# zec{h-R5Mo;QTmtWZX?>4&@0`}r`x%F*pHoAw^X=^swdB`dWy^6INZ9Vx1xA=QN5_Q zeo4q;{=D8g&T}oe{kS6?W+Zs-BP2k`QX#u$=@ahIifXvTay33TP`W+cj+Xy8#4}z9 z#<(KJ$^aiN2WavFtivk)KYD&-nZAVuEv_nN?%cilaJ!JdE;8w_mTT<(X~x_a^9zNA z{C~_0OWYU6E3lLg628TG*IpBmb!|A#ZlE|OX~U{wh(mGIXrpF?Z=y}S4_70u2E68> zh%8z1m}n?g%D`(XyZ5}&oHQ*Z!SiU*<_&_ZDw38;iX*y_Fe8-XxyQXNJwp9;emw9= zs>&|4`Cw|;eXk49rn+XFh}MW=7`h?qDJz+>B6Y3k5{O9Jr0D7yf87(PYg(omqCv+F z#vU0te*+=3p3T|QY;0o4T(9hxR3>zx(8!XNEGBMX*~%%yP_z|8O*wWJ!n3xAO_L>4 z@$#U4Jm!96Ostr#dzg5Eu4Ztab}%?j!wiyW)1d5Ej7cW-dL})d$!gbx{K{xF-NGu- zhJ54Nkgr@D@|kCI0d4%434Rkr!*vMdfH|2M(p3@bN+~KM8PZeQa575Qucg9TN^+Fsq^i+}t(S>~Ix{&uh+e>ug8O)(xjhog{+_WU5@s#FfeUOIIEWL@8ZYdTG zO)xuCu_od)w3}|~rENWQb2n}4q&;EU){fl#TF36n<};P8dxTo%Xs#;Elq)%*md})g z+VQfGsT`S`$(3qVX4~P|>#bb1CUnkAox*empOz`1Q1V^{rkn3(75)Gj26sI8&Vz3~ z_}YWp9(?M-2OeB<-g7RqnOG+q3Vt5(kxQe-Eya*jllsw&Zua_k&apf0=g(ffOtC01 zF_W$3DlBR442>}8cgbn*3fC^j?)F>cNa-ZMYgFY=cXx_Zvvgirt@-#>=1TqYR0wXXAV-SaZFb*mtKm#3;FaZXb zU_lD@LmCdiBpiecybf8If*ef45y(RU-hiV}gc&G78D`;4s6Z8JFbBurIGli!@D@A| zG3bMS7=Uf?0&IsJuoE^wCv1c+=!Q+O8G7J3h(IrF0TH6G6$W7!?1nwK_QFf>GQ0wZ s;8i#bufZvJ8&1PK2+#~ZXn`gO;Ocml>test>13-2-charneq.test ;; ;; Syntax: char/= char &rest more-characters ;; ;; Function Description: true if all characters are different, nil otherwise. ;; ;; Argument(s): character ;; ;; Returns: non-nil or nil ;; (do-test-group (char/=-group :before (test-setq allchars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\newline #\backspace #\linefeed #\tab #\page #\return #\rubout) allcharsb (concatenate 'list (cdr allchars) (list (car allchars))) ) ) ; char/=-group ;; (do-test "char/=: no character is char/= itself" (notany 'char/= allchars allchars allchars) ) ;; (do-test "char/= for all characters" (every 'char/= allchars allcharsb) ) ; do-test "char/= for all characters" ;; (do-test "char/= takes more than two arguments" (and (char= #\a #\a #\a #\a #\a #\a (char-downcase #\A) (char-downcase #\a)) (not (char/= #\a #\a #\a #\a #\a #\a (char-downcase #\A) (char-downcase #\a))) ) ; and ) ; do-test "char/= takes more than two arguments; all characters must be different" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fd9cb5979266b180e8acca8ad7e760c542c1ccb0 GIT binary patch literal 4094 zcmdT{du&_P8NUxFIM3RlYgI2z-Nb2w%T41XUE9Ebo0}WQjqU5+dmT3n2wmblAZ@Zd zSfL{euni`89}N-c9;yz(v@tP_u}&3*G6juEd!b2_(6pDPO+uQsKc)$364Hda@0`!B z-KNqe)_~iowb9ylO(nOSkv9t)7#e->#V(e?m0OyCrQ${w85c9k^+({dCwFAQP*@_Z7`8E zwX~ixqu!cV@Z(sttYg|cGvbvG8lMh@@Dn-`db5CGUWydi|8u%nnuu7M@jV0`1kD63 z8#8a=0Gl4aX@@-h##rNq)rj;TYssgr#&;xXZTd;8aafTX@bR@BxiHtmcE2RmOVY;7 zca5075k1TN-1=t7}`?`94rPpN`Xi*&|D0>P~!m?7P-kKgei}sCaWPPKTnv;QQ=sgac**e%^XnTa`K_z)8z8@jH;2jw zDW`0ZI2pWg_Wo3|S6|_!jqH`ZP@wFEIQR0uIl(@UgmC+BOa~;T-g~yt95t-;K!Tr# z+K`?eNSe0RpTI~u?nIS3R--iFw+6p{{8r<)3J>34)X-gHNV82hYvbW*h|{;)8FgGU zr6`!Om5yg4Y3k{0MjN#3loMsLB5$sCtthKgYgvuj$QvCqmCzg)z3BFUX2zW>2RlEK z)h#^7a);1o+}1Ng34`abfEvJ)yfJFpwqgd=xs^wgR_>~(R|v$exm#-Sz+ygrp``fL@FrUEnIn3VlkXy_=Hu60 zPG3REppmt0GhK0eF`2iW#kQ^G^&lgBK&*~8&vT`;g;O)i=@il}&S~777BvGDY-69~ZDH2TA;@+jsPBt9_4gu0eUI2Lh`mGXBC*$4m=}DL z*q4Nu`j`+?7f8&Yf<8*=Ar>XpN^A$QATd8NNk}XI6ij(fNGrb*(#ns7w6Z1&l&2`= zF=D5P%@dm^ADCi`W+Gs9tm=eV6Hw~YmO;u*1p_&((9N&FuQcOmX)vAs{R4j!H09xKIo&}Fx9 z&8f31}%)ZdVKOdl|f1nO1vS2{+mngq;vpgP^x;T1#f5j z_pzo9*456MT3IZ_n#AGu4X?1v%`Yy6TUYef@Z@p)H8T;OIY~c6cxvT*+`~TathdfD&lbZr zb=TCcxeAgA*R=Jd!|E`Nb%|B-?O@$lt6sto`it}DZ+q+8t~(YTN7IkvF>pi!I3^QE zH3*ZurXc!ey=7(f5uvPn=&k#&Rl^G951T5KpHoE-_kwfDv$k)}suEf9vv^%LV2b>} zrW85r6*~L+O}sTt`t2rukS<+W#?tz&IK>t1^Xh&<=ZGFLb~y5QTkk zD`?OO`{8!@G~5Aq!d>tgxCicq`(O<2htu!{cobHE-)eHmTdxK`)IbB&LoIxf$8Pr4 zLmy`+@Y;G_`|);!T;;7d6z9GNdds^Kb)|pNQi)gaU3wPp)j4|Jev&YFCt;KC>S>mq I&t1O!Zvg;o9{>OV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST new file mode 100644 index 00000000..4e55389a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: digit-char-p ;; ;; Source: CLtL p. 236 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-digit-char-p.test ;; ;; Syntax: digit-char-p char &optional radix ;; ;; Function Description: Returns non-nil iff char is a digit of the current radix, not for digits of another radix or for semi-standard or other graphic characters. char must be a character. ;; ;; Argument(s): char - any cml character ;; radix - an integer ;; ;; Returns: non-nil or NIL ;; (do-test-group (digit-char-p-group :before (test-setq digit-char-egs '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) upper-case-egs '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) lower-case-egs '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) semi-standard-egs '(#\backspace #\tab #\linefeed #\page #\return #\rubout) other-graphic-egs '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\ ) ) ; test-setq ) ; digit-char-p-group ;; for the default case: radix 10 (do-test digit-char-p-with-decimal-test (and (every #'digit-char-p digit-char-egs) (every #'digit-char-p digit-char-egs '(#3r101)) (notany #'digit-char-p upper-case-egs) (notany #'digit-char-p lower-case-egs) (notany #'digit-char-p semi-standard-egs) (notany #'digit-char-p other-graphic-egs) ) ; and ) ; do-test digit-char-p-with-decimal-test ;; for binary (do-test digit-char-p-with-binary-test (and (every #'digit-char-p '(#\0 #\1) (list 2)) ;; #\2 - #\9 will fail. (notany #'digit-char-p (cddr digit-char-egs) (list 2)) (notany #'digit-char-p upper-case-egs (list 2)) (notany #'digit-char-p lower-case-egs (list 2)) (notany #'digit-char-p semi-standard-egs (list 2)) (notany #'digit-char-p other-graphic-egs (list 2)) ) ; and ) ; do-test digit-char-p-with-binary-test ;; for octal (do-test digit-char-p-with-octal-test (and (every #'digit-char-p '(#\0 #\1 #\2 #\2 #\3 #\5 #\6 #\7) (list 8)) (null (digit-char-p #\8 #7r11)) (notany #'digit-char-p upper-case-egs (list 8)) (notany #'digit-char-p lower-case-egs (list 8)) (notany #'digit-char-p semi-standard-egs (list 8)) (notany #'digit-char-p other-graphic-egs (list 8)) ) ; and ) ; do-test digit-char-p-with-octal-test ;; for hexadecimal (do-test digit-char-p-with-hexadecimal-test (and (every #'digit-char-p '(#\0 #\1 #\2 #\2 #\3 #\5 #\6 #\7 #\8 #\9 #\A #\a #\B #\b #\C #\c #\D #\d #\E #\e #\F #\f) (list 16)) (notany #'digit-char-p '(#\g #\G) (list 16)) (notany #'digit-char-p semi-standard-egs (list 16)) (notany #'digit-char-p other-graphic-egs (list 16)) ) ; and ) ; do-test digit-char-p-with-hexadecimal-test ;; for base 35 (do-test digit-char-p-with-base-35-test (and (every #'digit-char-p '(#\0 #\1 #\2 #\2 #\3 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) (list 35)) (notany #'digit-char-p semi-standard-egs (list 35)) (notany #'digit-char-p other-graphic-egs (list 35)) ) ; and ) ; do-test digit-char-p-with-base-35-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..096727067d73e992eecef15ff0e4100e0b946e36 GIT binary patch literal 1099 zcmah|U3U{z6upzQX_}@b1zE0zh+{E`V{b8O!BQ2SPH&pDlbLYmh7zDiO{XN7HZdP4 zB9-L>PjO4=f;FS7|G`(pB@g}~|3SUe^34NJb3XSyd!I8s(tqACRinP%sMg%3TJN+Q zowmAGZ>p_&r&)H@H5pfL8a8LQvbwQ2@mVV7ypSn3-Icbxs)~-=T3xv@uBJ|_dZSsb zNn?6ix~Z9y>6xjiiC9K=%ssR>_M~Sfr)JWpCSp6=50pfm5K<3Di z%n>w`Ga0q?Jkz|M*NsXpwCFJIbw|@`yWXHR_qtmP=&ZMhLWp;_8_g6gL*#7B+fr^T zaqqY8aL%FyNll+;Bouvu5}+$y_dsfrrs+J_3)!4OjjYaTfowmB)PrgMsytdy9&V6p ze=mfVMh=ZC{Z|PI62pXSOH)q!#JgR2B>nxr48)bn!+$Jk|JPgm)%ur^UgeIp5K?5v zy~>{lmv+g@bd-=dA&;x&{k=+}njoQm?|%2NX4uwTE*PF>b!*OKoX+NC#F}@sP@hy~ zR5Ns8WGQE&$R#UdSC)uVas(Yl}e0gjB}e)yC@1pp@j!!LtN9X z65WkEnlB|uq+U^WAWVqg7sweYOOQy$=6PLQ2_7?woHOf%HTgsYU&-sfC)`$B9oy8$)U_4)AFQg?jlB~NVw=h1-qrx3 z7{oB*h~a0%4tZP4Siv_aV-+sea1|9)aSh+1hIMS9jt0I%6D_pS!F7C(A8-RdLdPr& z%z+_;d1R5p0v2H+4+}O5I13I30!5s|63(N93rHc2Nlf7+PT^Bb<1{|O`xwJfe1Ig5 z;X@q9N6_#w#z8TG6Zjlo;0(URSGb5vSjJ_1jVri`pKuGCP!;bFZ!09VJYsOB3r1hr clbI8Y>!#xm1!Yprvqf7l{~hxCv7Md&0b6WdqyPW_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST new file mode 100644 index 00000000..c0c7c8e0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: graphic-char-p ;; ;; Source: CLtL p. 234 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 8 October 86 ;; ;; Filed As: {eris}cml>test>13-2-graphic-char-p.test ;; ;; Syntax: graphic-char-p char ;; ;; Function Description: Returns non-nil iff char is a graphic character (any standard character except #\newline; space; none of the semi-standard characters) and NIL for any other character; does not accept arguments other than characters. ;; ;; Argument(s): char - any cml character ;; ;; Returns: non-nil or NIL ;; (do-test graphic-char-p-test (and (every 'graphic-char-p '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\ ) ) (notany #'graphic-char-p '(#\backspace #\tab #\linefeed #\page #\return #\rubout #\newline)) ) ; and ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d44f218cd8c419bf601622dbcb53301f6d605b9e GIT binary patch literal 1484 zcmb_c-EZ4e6u(Z|Ea^vI##hU9h z+-1>Tck9c}2SZ}|qNr4BWe*n<6KJL<$44f|#)jKw6ieGj`_G(_$t zszL}Ul3o5u5RxKM5`5;TB%4~cJd@R^tSdPx1SqGsTCjfjm(RrcKXT#vW2 zS|G?Jgc#rDZzmy--X-MJ?Gq=3(t{hxT_cI+ zpH1zKk^GsEX6X|nITsNytoiNJi`|E5aY8x>*)11Ohb{+P97 z*)$i4U_|%+d{m7pdLb{*7-r6rm=F>EooyQuYmX*aBHD@5NJ`W+4O2D>cD`Us(RNJe zkQ9AM4)-}o;HT2ZrkjWo!dm!9JNa;aMW7bCplICq35^&pK(V>`kXN7?jwf>^6>N{e1xUjPjKUa0_$t`uiaDd2RI#ai zjD9U^Q&Z6_*3QF_s`-LpQ`TDu{6Vks{y+PELd22A=h@ja!FCTQFa;`11BDrwg$!ij z3e159Incp?Jj{a$7T8dL1z3cuumsn7c1Z4WjF8`d@SMzFcw;l(P5f+?o28U@;=rRE zc&>$>&oiF*$5!U?k*w5yR;rvLf#2gftM4p3ob}@(#vhariWqeq_$_KiF-dd+HI(2> dMMWa|*ieKG5z-Q}#?B!pte^FgFE8xv{S6fF&kq0q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST new file mode 100644 index 00000000..3f6309a2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: lower-case-p ;; ;; Source: CLtL p. 234 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-lower-case-p.test ;; ;; Syntax: lower-case-p char ;; ;; Function Description: Returns non-nil iff char is a lower case character and NIL for any other character - upper case, digit and semi-standard; does not accept arguments other than characters. ;; ;; Argument(s): char - any cml character ;; ;; Returns: non-nil or NIL ;; (do-test-group (do-test "lower-case-p for lower-case characters" ;; Each lower-case character satisfies the predicate and and its upper-case counterpart does not. (every #'(lambda (char) (and (lower-case-p char) (not (lower-case-p (char-upcase char)))) ) '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ) ; do-test "upper-case-p for upper-case characters" ;; (do-test "lower-case-p for upper-case characters" ;; No upper-case character satisfies the predicate, but each one's lower-case counterpart does. (every #'(lambda (char) (and (not (lower-case-p char))(lower-case-p (char-downcase char)))) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ) ; do-test "upper-case-p for lower-case characters" ;; (do-test "upper-case-p for non-alpha characters" (notany #'lower-case-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ #\backspace #\tab #\linefeed #\page #\return #\rubout)) ) ; do-test "upper-case-p for non-alpha characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2fe40eb43a01c29dc139a7f3a58c578c5442672f GIT binary patch literal 965 zcmah|T~8B16rJ7DQYe&`keF1#^@A8U4oM3}#HV4I($ZzO?uS@kOl`Ncq_j=DB~c?G zy!f&SRw9|z@E?37V*218@*m)x)+oUTH@lgcJNKS@&b@bgDEM4aC8fFBs@0vg)a<&g zt}9iVZK>1jwo8sw0lV~8(GB`8LzLXYljOL0>88|nimp?Ztgh237hgY+l8+_QYS-$p zSzd-?a^+!aWoc<)JWWh>i1y!@)XL)0Am-xqM2IyJLM7Da%NRm26hQ2w7n3b&S~#6m zDb~m)m06E@VbFqYlN!v6rzE%8!gXiQsdG8I9V8&cK6v4@ttnPk*VwUeAWX0$Z!)Xl zJV+z!6p7*AC>&j2-b`{4r?6=eZH*XfSji9r=h5lO=pnERa_ZC!94<^LtL* ziY4MgXd5AZ0Sml9njfkOcqS1#2h;T7=#)@Bdl~KPQ8@nWsYiPB2SUB-dp(*H1#s(q zy|y*Yrtu)gI_l*QV_Ny@@hS(?XhOFq?T9!+~8Q`f>1FvSmqOF^<7=&8I zWrbKu1{>6}4bZ9#iWM>orbRbJ5jz90(!Mq9eKLNW;<@NQ7*R2xKu5+aZ74A z+eNpw=SZ&8abGd-rUk2Xd!O8vDn%2KT{`~$dce_m#ucxPvpdBV;J`@)WSC*~A` f5{u$1GS#d_4WgQUgu4Ozr?zfUKY>2qzqt4XZpR$K literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST new file mode 100644 index 00000000..a2fbb065 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: standard-char-p ;; ;; Source: CLtL p. 234 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 P.R. ;; ;; Filed As: {eris}cml>test>13-2-standard-char-p.test ;; ;; Syntax: standard-char-p char ;; ;; Function Description: true iff char is a standard character (CLtL p. 21), NIL otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test-group ;; NOTE: fails in 6 December sysout on #\$ and $\&. See AR 7038. (do-test "standard-char-p standard characters test" (every 'standard-char-p ;; 94 standard characters (CLtL p. 21) plus space and newline (2 notations each) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) ) ; do-test "standard-char-p standard characters test" ;; (do-test "standard-char-p negative test" (notany 'standard-char-p (list "j" 'j (symbol-name 'j) "#\j")) ) ; do-test "standard-char-p negative test" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4883752b894684db5f2a703b4d91b8ca82c970da GIT binary patch literal 1053 zcmah{TXWM!7+u*oahw27rc7s2Xhk5s2sYGCQW8_9D9So^B1>kqPB6DNaTM&Hc=#zU|lYx<7_z%2N7OV+VPFrpdj7FpVZb#oaXS*bF!7x>$wpp)K-G*9g zx9aVdx>0MW&04!ra@7r)S8p3OXLmEYu{3ce5p!Ovlp5}8%UxGR+ik9|-a4r!W>vl3 zs8r=)W=4jI)O0d6H8l}S>yEjH_THIfYH}(yotTL2K7OFYYlM&zc^P~L2#J$0@$Plv znqZEg>8#19rRSLDb-hkha-ju>aj!F+R9m$=t-3edYCvbRNfbi7KRVHL!7@bFw!9tX zXJyFyy|X`S(Y&OlFEA2{{)-ZzD_&w zSDr71Rt}5~E0Jrx4TIW#LY~QJACgrk!C0gZ8Pb7~hvz96*lfE*aobgM{vc}Mf5 z2=T;QTK0zt@%IG+MwTT=U)tt5T{ywdi~{G(dd(PLF=YOOS3C^eVSDKQ;8DpjHqMqA zFH%R6GTEraJLnX1bGAwUb1IUT2qSNpKm&jNw>$`D!jkEIo2Ip`ImvIGG@h!f? zZQQ|KY(te#3^B!f4MR>d@!?uaou$M!Jthlc)nl@=8uwx$9H%C0ZZFa A@&Et; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST new file mode 100644 index 00000000..98491d60 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-char-p ;; ;; Source: CLtL p. 235 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-string-char-p.test ;; ;; Syntax: write-char string-char-p char ;; ;; Function Description: true if char is of type string-char, nil otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test string-char-p-test (every #'string-char-p ;; 94 standard characters (CLtL p. 21) plus space and newline (2 notations each) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ ) ) ; every ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c7e6f071f56a4d55f496119767034ef67cb788ae GIT binary patch literal 1484 zcmb_c-EZ4e6u(Z|Ea^vteOlthJiraCE&fRmk|I$OeCDSln_9L!m({4OD~nVL+JPU(UgW$*&A{)Q5S!JS?77!mkGHeZ zAOa!5r+$1cud8;}(1Q(OUFZq!_`O+O&S7iHJSCC%E(%8%5GFk-PssUPj+(NnSX9oD zyPNUbSjxk`RD_pwzw}^1xK|;SpB5q)j|}t)F}};+UP2yRCFIEMLx+XZz01ihBZ=l; zZS9Vc{DqKq>0=|g5D_q}{oUgi`}fk~g!B-yRW2M2Ti(O}eGfm5Ajrf2a{^+$I)G?f zr4;Y|3x7yb4gFk}6C`I8{hWr4pUvWqK5t2p7)wMtk^MeNRctjQo7B#m$etR~AG4M$ zn=VEo7}38oA627@p3lj1hPh}-Oo#}NX4{6ux}yn}i1y+%k`gsd!<3D@oy*%&v>Ow8 zBt>76!+j1C_^I@P=_aCtuns=bUOt@P5U7J*P&97*j7E$XpxE5J&nr;#rb+dE`e6e1 zeakEVmw<5M;jyfnyFWsLk|Vld^KvYtM5Aj6e%M-CJZot3p0X~n{w4NUmK`0&_^uIp zftq{ap>%%5oX(tS%d=5DwBQTGJoTZ&3LclXT97mrMyGC z9%t9H8hSp@c;cVynTPwbQaf3xa*720fak1SDLS0>gCfQsln{y-bsYE|YDO_hbOtq) f;7dhCB8J#lgpCo>5wgZkASY~?4U(@;Zg2ksw7}9G literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST new file mode 100644 index 00000000..9e3cee26 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: upper-case-p ;; ;; Source: CLtL p. 235 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-upper-case-p.test ;; ;; Syntax: upper-case-p char ;; ;; Function Description: true if char is an upper-case character, nil otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test-group (do-test "upper-case-p for upper-case characters" ;; Each upper-case character satisfies the predicate and and its lower-case counterpart does not. (every #'(lambda (char) (and (upper-case-p char) (not (upper-case-p (char-downcase char)))) ) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ) ; do-test "upper-case-p for upper-case characters" ;; (do-test "upper-case-p for lower-case characters" ;; No lower-case character satisfies the predicate, but each one's upper-case counterpart does. (every #'(lambda (char) (and (not (upper-case-p char)) (upper-case-p (char-upcase char))) ) '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ) ; do-test "upper-case-p for lower-case characters" ;; (do-test "upper-case-p for non-alpha characters" (notany #'upper-case-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ #\backspace #\tab #\linefeed #\page #\return #\rubout)) ) ; do-test "upper-case-p for non-alpha characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..08ec313d9b2692ef79f5c45d6578f2f1c09c8397 GIT binary patch literal 859 zcmah{O-~a+7@pnIPf9IBV}f5Rk<023TOfgY8ipw?YH7VN=8DT{4VXwwf9V+}^}5`{nwgj%d#1 zW^%LH+|0~WB9EAH#`fQtY;Jls_i%11ae8>5q?-VMDmam!H~?u70{)(x);VDu=8Fb_ zCMpr#@B3~{c!4$})OSa-TDRGP4d=Pjkao5^Kmox2;KuT{iFwg7{e9)NlJwuZBSjOg z3TtSI05$fTMY1cto61bXX^0Dm!i6Gd;P4=_A%%Rc9WN_KJK*WJWpzC@KB|PD4b;in z2mr_8Huff(RBA`xO>zF&UwLQ#0H9xcYc8vb=-8`$xwbyACdx4Yk^r34t7H9Ix}FAV z*#GF>)UjnQ7Nt~JK<1)Bqy~YQOH5aX#12Mvj5sbpO1Mph2Rv9pgq0a5B~|&igIjtq z9Et|4Z{?Ld)i>HrGROF_6@eS%w3g>48{4I&*1{(GUQ^kX&APO^`(L7A+yp zUSO5CJh>H`WWccnK?sU4^#4ei9wkqOPZ))|Ovj-`$ z-N{@2e$=aY$lLH1Jl(tRWflLkzpn}bw=pG%6L`sqQRIXog9XE~P3U-RTbu;r;M2X+ F(_d@m|Lp(( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST b/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST new file mode 100644 index 00000000..68b2f87b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 240 ;; Author: John Park ;; Creation date: April 30, 86 ;; Functions to be tested: char-bits ;; Filed in {eris}cml>test>13-3-char-bits.tst (do-test char-bits-test ; returns the bits attribute of the character object (every #'char-bits '(#\a #\A #\b #\B #\* #\+ #\2))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cd743c45fb160a15818f05b0459557455fdcc549 GIT binary patch literal 777 zcmah{T~8B16urCshSIb|6EQ|7B)n{#CgmeyeQ}&lY0GvNW@kknNm*=@LYsb=7$Y%0 z__Rg~k?d;t556Ks9{fZ81Dq|2L?3*bnR92(J?GpRLF@@N5$)`DTWz<8I>SMCI6ym{ z9_n|7y@rc+6pmg{OR$#}LRa$-3KRB~N~7m)4cu)chi-p+>-k+&xQ|G;*J`WH^0GP> zic9mw#l`$Ynb_t9+kfB87Z;X_g{Az&`SFpK?EpXn&cY=Hkc9~N2VT~Y%$B%ZH5ull z&J2I#dr9R5J2n%(mzzg}P8YY`XKp*Rv)cy^z<=*0%MPcqYH|Nid!?oQcivQ$<27ZC ztT51%zgR+c&G#~e1-yW1g$PWo5`*KT_~TH>m*#0rJK2NvuQh!mb2F#KTBlC|re7!0 zTJz)^SNk8M)wldRz^M6#*K}DYMO-n1pF>)O9Jq-6w?kwlP+B$d~U z!Gy2`wj88y*twF576vB znMFHW>Q`=~*51X33bFk;&Hv;d>Z-wQDj1PWP3(7;V-03iGC@o`m<+F}KI@JpS#SeB HqVw~g272e9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST b/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST new file mode 100644 index 00000000..b9695335 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 239 ;; Author: John Park ;; Creation date: April 30, 86 ;; Function to be tested: char-code ;; Filed in {eris}cml>test>13-3-Char-Code.tst (do-test char-code-test ; returns the code attribute of the character object (and (< (char-code #\A ) 65536) (< (char-code #\a ) 65536) (< (char-code #\1 ) 65536) (and (< (char-code #\$ ) 65536)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c5db677192b8b6558ef5b77db78e056e32db629 GIT binary patch literal 857 zcmah{&rcIU6n?v{{x&YiUbdyX5RPS`{w)Jn?3}e5JMx4?PjfRx3osL)9iM% ztwu|0H@dBgt!+tMdr3@AUu7{_oqm{%S{E{vmR;`Ho0{m_?alIw`&x2A!_8K$E-&-* zGEAoDQt8>*>1YO9#u?jxds69{xpeBmboBJ_KuI(JpaLiU5dla*0Ngz%p$lpWl*t(s zF`TEm+jpI?^n!{O<*qZ9(mIVMs@u=)x^HK@4GMt!!3k%IjEJ1c+5_8`>qdA5O z(i&c-poV|5`0R@7#FH~<29Yf0C}T1KhXY z0vyX|{LOGosUCf2^8T~G`i}ho=vUve6;+WHd(|)3)(6&PIt&m4IH^^}`_)7(0cz0w z=-kwa$(C}yRFuVR$)Fr9<|M+FEnOXwGZ@ne79@)}6-6#Rkiif_R>=}HuPXmm2vhe) z0>fS;5SG54TYmCyjUbWaW-k-Rj=;Q)X)opG-c2U$#=ynvw8>pOscn_zuin&ZJ7*u# z$9AV~x%;7Bxrcijy~W<6-lXDwcK22J{B6Q178G6bVdMnm*s#12zf7ulTr>ssCg9V( G)6-vT$NxeA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST b/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST new file mode 100644 index 00000000..1fecd176 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 240 ;; Author: John Park ;; Creation date: April 30, 86 ;; Functions to be tested: char-font ;; Filed in {eris}cml>test>13-3-char-font.tst (do-test char-font-test ; returns the font attribute of the character object (every #'char-font '(#\a #\A #\b #\B #\@ #\"))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e2b1f7f301089dbb4f642b962c2d2e669f33f0c5 GIT binary patch literal 860 zcmah{T~8B16rJ7D?@|lFn4scHBrzMONed)UeHn%+Eo^sjb{4FO549||NufZ6Cf-RGA*BQ$y-DV3n?B{mFm$TDB5<>2KCz7{xDvE~g9!jsJg!|4JE$Vn3 zq>&Yd8fK@qR5;Pa!$z zesFH6)Xf{QX*&pb0#bf8t7mNA+u}>R+6QEJA|Qn z@j%#%1|pz4sWQ$Djtxt!TS5&)VIZLry^IHWQ}tj0smxz{3cml>test>13-3-code-char.tst (do-test code-char-test ; returns a character object whose code attribute is code, whose bits attribute is bits, and whose font attribute is font (every #'code-char '(1 2 4 7 10 20 30 40 60 90 150))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..53298896a8d2a73e25f60c466d1dee26b143d376 GIT binary patch literal 861 zcmah{OHUI~7`-#4Pf9IBV}h@d$Y$atDTM^;>TAiEtiaK5g zX=H^VIra-BK$koxmC52PE|E2cX@PKbava$Thet@rtFi_ebx8#>6z+V7!b?5T&t6z`JIaOG}1^f4dZ32ZYqn z037%-v^oeDVJJKxoB?+udO$~;_HW&Ue0(?;(mdy$usdC4>VQlsI~BOcml>test>13-3-make-char.tst (do-test make-char-test ; construct a character object whose code attribute is the same as the code attribute of char, whose bits attribute is bits, and whose font attribute is font (every #'make-char '(#\a #\A #\b #\B #\c #\* #\9 #\}))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..17376176b8ffcd1441c862fd9904a30c8043aaa9 GIT binary patch literal 1691 zcmcIk&u<$=6rNotZtNtkW1=XS2sTBPDvOQeBo!e@RVJHB>}Ip;?vFUBkid1E+Tg^- zaSACSih6*{>Xi_Pc0f6Cw8)3vkr0Rj5)wx)NR{#jgg5Inq%Bf=;jo%{Z|42@ zzVFTMlFlVfSG3w%y;3bTl-g#qzS&e(YYkxyib+uZ$ zQK||!Ya2u&#Q)6ensp7$$(n}0C+$c*{%x-}Yp6MdM&}rjyNaqc$T4``x#&m&3leEPA?EzCSPBT_;;V&dd4!WS;WOW6Sx|zp%LWn>X`$Tu4Sg4mrLfzt;o69|RjmJYh=s#;<(^Su8 zXgeC+Q5=C-idmLvsiy1XTqhNZ;nkiLHI~)DFWU0Gc>0NviiDBr4lzf)Vj%v;L>+9A z>caRFjj(`39bx`~3HvnHvY2sdXt^ZLe!{c9?x=RiVvsxaKOQDzW0h#+Gr~0w&^)#wSYg56{WJ?e)qz+ zeO^>K*e9=6&rBhIzkFY%nM0iaO!X=*JC!doRpr;6%+FH~VWB zrGR}D!1tsjB6T2B5rL3u4zmammG=IhO8i1Q{U^^(PoD#bd<;YuK=4~eFrq}=|JvUZ zZ{=mpV${KrKY4k^T*mhzu=GFJQ3!RBHQ+{ zMk5#ey-rY|2PWVWM2G#oBv6{s6idxhX!mw6E@)nd;lN97ToLzaPm<^!N<5l JzPfaD^beVx4-NnT literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST new file mode 100644 index 00000000..3b12e93b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-downcase ;; ;; Source: Steel's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986 BY MASINTER TO PUT STOP AT END ;; ;; Filed As: {eris}cml>test>13-4-char-downcase.test ;; ;; ;; Syntax: CHAR-DOWNCASE char ;; ;; Function Description: CHAR-DOWNCASE attempts to convert its argument to an lowercase equivalent. ;; ;; Argument(s): char - a character object ;; ;; Returns: char - a character object with the same font and bits attributes ;; as the input char, but with possibly a different code attribute ;; ;; an error signal - if the argument is not a character ;; (do-test-group (test-char-downcase-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf non-alpha-chars '(#\Space #\Page #\8 #\> #\Newline )))) (do-test test-char-downcase ; be sure upper case letters are converted to lower case letters correctly (and (every #'(lambda (x y) (char= (char-downcase x) y)) upper-case-chars lower-case-chars) ; be sure lower case letters stay the same (every #'(lambda (x) (char= (char-downcase x) x)) lower-case-chars) ; be sure non-alpha characters stay the same (every #'(lambda (x) (char= (char-downcase x) x)) non-alpha-chars)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..30fed284bf844e1a44c730ea0f31e83468a50740 GIT binary patch literal 2875 zcmcImU2GIp6uvVH%kH*awx#}1N|~q#4$lQ0dpBwP@x-OI(AgrTHJX=<;IMBjZD z$}YIYKs2VbDOy~$l!W1+8}oG+5fX3KhD4gq7unl=!mUa4!IypFU}HnA;AOdnS*|0S z`LvZ!Eqsy}a<`8mRCjUBdLeu3mEeLIB+EbNl9$ckHwevT-!g-JqEJH~Z>}F~qI|^f zL#P^|h1`g=@QJv6NoZkBIkb;j2g79JBlAD`F#e_Fqh)eGBj3ED~l_VFN z%H&myTwYP~GiCB>M&7cb3KN&tUykx8wZs-mnu8=?O|^9di3Q4C@%OJSUvyRx;80r3Q-LlEDp2Db_ZSn>N zc;}$@Cy3o^I&p?_i=pTP%_B$zh*!~$v4QIULz4I^eLzjp#SOCX(t=foF0T=)S}ko^ zy0N4^VS)NC5nug(hro(qW#TI8j$_8I<3_sbz#HkbmYiH*i$0)RLyAp~Dyb8z@CSnm zzcZ-tGlL4B;wI_??z_Z&Z*X6l`=ZiEf~*sldt?V@E%E||vDzr?6luI(gT5p7%Cb02t=$!y+xg}l zxS9IH9JY>4!fzGmHij1NFtqS3hkeGUw=2*wjy}QBJOyEhqjyxGTRFO(qpKJU{llj_ z73e5Kqt6){eavC+;qW9uu3PqclwQkBr*PdMZZ>du9}YiFD=oRjO-^Q}AcfDVVQFlb zd~-*o+$8^8Qro#L6qa(YyCo{OCe6}ShbUoD(CjWH6OL}FNgG#D7&(ALY17eJQsQ2` zol^Mc(Np`q2>lq7=5iOZSK0INyCKpf++xG{@Wj#4VH){C1(1)6z!X44;1-3$NDPvT z>8GczY9y+NV+fG|!d;dlmPrPfpQG?A3oU%Ka-nf-G2VP-yf=9~^RdM1tcFU-=Z`1iN6#FkMEZ)=d1wCiqzp{}Ix6}yD5Qb-9 zGi-saunk&ZJIJsDc7g&C*acm%2cCx)U@z>0{qPbTftTS7oP}+>+>#G`;D_^20}=$F z8UihDsRo{fD6~Qh+Mpde;5pb0oy~5k0aWM)4Gw?~J#=3>07%PQod84Nk-B OtCqhQbnVE!d;bDZUq+q) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST b/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST new file mode 100644 index 00000000..c02df2ee --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CHAR-INT ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 242 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986/ MASINTER, add RETURN after STOP ;; ;; Filed As: {eris}cml>test>13-4-char-int.test ;; ;; ;; Syntax: CHAR-INT char ;; ;; Function Description: CHAR-INT returns a non-negative integer encoding the character object. ;; ;; Argument(s): char - a character object ;; ;; Returns: a non-negative integer, which is the encoding code of the input char ;; ;; an error signal - if the input argument is not a character ;; (do-test-group (test-char-int-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf numbers '( #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (setf chars-have-names '(#\Backspace #\Tab #\Rubout #\Linefeed #\Space #\Return #\Page #\Newline)) (setf others '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@ #\[ #\\ #\] #\{ #\} #\')))) (do-test test-char-int1 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) lower-case-chars)) (do-test test-char-int2 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) upper-case-chars)) (do-test test-char-int3 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) numbers)) (do-test test-char-int4 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) others)) (do-test test-char-int5 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) chars-have-names)) (do-test test-char-int6 (= (- 26 1) (- (char-int #\Z) (char-int #\A)) (- (char-int #\z) (char-int #\a))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..673ff4325dffad6e9d236ea6f151e336040016c5 GIT binary patch literal 1503 zcma)6OK%%h6uvW#UB5eSq9~XOCPtOeh_U1}pw?`9J-JRy#xw3b;#weqaU5*PsV&Dr zDu_^Z0h`g3Bx-bTt4jO>x}>7Wi!NCpA$7@yRhRsOaPBy9LqGz_*39|N`+R54J__H` zbXn_f54yefQ10)J2D>A9t3Q-?`n$tcTiya({!%k7^3@vF*7NTd;`SL$YuIj%+MBYo z+uqr1-g!qZT$k}+*zLi~wQC?2itjEJmzVSLGPd9Lsx@y~tz zzL|cG(0=DzGrcYfDR_OdP|xxRppPPyL}=V?T^>K_pUw61G*^_P^||^&0-;CX0mG@! zLzKIn|DA6B-_k*-53&$!+>!V^9(b1(%`{djd}!(#Hdb_Esig`a#;UD|5f&4}z(_{X zu%oT17I9n)CaMLLMC^v`kg6zx#oUB5O()oJYiilFsP2#s-*2$Q0f$m1LtXlSe9w2rt8#PM+v35oq~;q z8sNMv>PdxjI~0o`#Af*7r1%#60fA=72G+Uo0)z-}2|HZ;4FYB~*RqIlW=omCbz7wty1Wa{ea4s+ZGJWMu-)!1UMwOH0+ zuLsrr&heUMt{U9xSIC(TKAGtjArXUj5j6EZ%W?DoY+_TtPk8x% z52dbJrdwlDg)QD-xdO{Yx!W()d(&y}jO5%N&dFO%xFnl$_x9unaBS}iH~Z!Y#c#mA z!4JdwN{D*dUUU1?%_cWK&jC1y0SEL@q@HjK{*6!!3Y@ho)f!xb6Sm1s7wcibBNISm zZ-MK8KH`1{-W!@lutU^yH0TwFSXj4Nf}6nrZ@Q*K*y2aj%NI)o_$8BT5}e4atDD|wh8nSgi6zh@;Rmp}1FO%UWf(OoV`xPuX&j(V zuT;0EV;TE?fIW1ndK3ZPGvUh*F9Kgi9v5ua>jt|QNPTx>i)@o2`SlomgC3~}S7A)w z4n??OWE|=?vGlqLschLyLt!gSdcu#C$XGf`7A)=w)P;i58T?a-&lphA>2+Bc!x_O}C5=ADRgAeBL!>AXJ z>J|NeJRxp_z|H)(>fnSk8Llci7f3E`@gFQ20uzD@kbWnm0gM3;h4CeXJO=t?L=GoY z%;t+HoT!zNj^Moris^Z{&4G7*NTbwdr?`A5MuK<3k$;$gpNeGhX{v%Gia~lMB&-%! zj`yf{E+gtOSUGlS8~^QIo1rwqThJ2A)L|2(c7I~kt3BZyj``3{Q<{s_8WHH(UQsB ziQ$rmtm-!bb|3@3&BVltb5)c<__P%~}2VUtG7 zZMIx3zl3QIG~GHPsb96rFDulheqbutq|m=EY(UH-60i#v0Is~dFg-DmO!dD_eti6C zVj}kofv3!udQH9j#FuF`y6&pi9|*Q+v~1h7T(V!SndwbWCROY^#+FAC8oFZ+#z^Kc F{2K~Zg0BDo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b602c632310d2b4dc15319edd51cbde4adf18f57 GIT binary patch literal 1685 zcmcIk-A^M`6u&ctE-g?8Bm^tbVa+C+#v$Qj4Pvt4GF)hvVWvAD6pV>>OW9Tnt);Aj zk&u1Rm&sWXC37`A?V~RnpIlwjhkZ9OMjuQ}eDuX+6aD}^cgiB7$?l5}lY7rO_k8?* z=bYIi?Mu3$>eaPcxl*jF)y+n2v!Sk5>*_{zvtB5wtEg8$&@G#Nn5O#t@M|M+=ZvLL zFXkJ?71iA=Zmi_DURFn5RcWnWuHa>20>zQZE2ER+KLtPPxKj`9D8MQ^vZDj z`0zkds)UdNX^JC8h(aPH_|#WYE^}OMHe)c&qzfz+>;--YV$nQ@*@53Psy3=Mtx~*I ztOz)38$==`_{8s+^-SH(SZ1&U)Z zS)DqJ93FJu#!8NQ6j@aCUFpHRbbp;}eLpYf`jS0TG%UA2EVt0xItH5M2R8}ny?x=Q+&`XiCDMiZXG|=b8rd{$ zd80ax1CU5D+qP`Y^4zTFrXmS^+LfZ_vKHz^Sz;2-4OA?OOt*J|g>CkAR`i_{Rp z?35vSKvvPKOYnNKZHJOTXUw6e#Hz*xGiVqm@C5cFbp8T3+Y>2kEkiC4ncgy zhu%Wh{`0QdoNakou4K46#fL`tP>BDRz<<##ZZy=3JM^Nun#bS9idtT8ZM@L!ToO4B z56DZE3scD5Pv2DX=_8!|bY&Zl-STJYiu&_z`p2n93JLsVCBJrKB`-ppXC4<>3Ykap z17BJqQX8@q6X>Y!GMf;QY5)Jp#4oqPfAr+=^eKSICqQHY1ixhjBU03YFN1xtCokwW zqb`p7>DGlKVq_2~H5}e4o?*MMdzQ<%`bOXnPfjzOJ=Xf|h5z!#X=5IDWXCz_(eUM9 zza3QQf(f_^@u6Tp2^6M5hZ$fn3v-Z$3|xbGFkk^pupkT9!3GCh@L&;gumsESdQ$l1 z;RY071&Xi=H=zV&cpKh<3ar68RG|j%LLD}s0h@3O-h=mH3%1)roO~2f@G-8EFRmUR F{{?EI4iEqU literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST b/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST new file mode 100644 index 00000000..d7e69c5b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-upcase ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986// MASINTER ;; ;; Filed As: {eris}cml>test>13-4-char-upcase.test ;; ;; ;; Syntax: CHAR-UPCASE char ;; ;; Function Description: CHAR-UPCASE attempts to convert its argument to an uppercase equivalent. ;; ;; Argument(s): char - a character object ;; ;; Returns: char - a character object with the same font and bits attributes ;; as the input char, but with possibly a different code attribute ;; ;; an error signal - if the argument is not a character ;; (do-test-group (test-char-upcase-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf non-alpha-chars '(#\Space #\Page #\8 #\> #\Newline )))) (do-test test-char-upcase ; be sure lower case letters are converted to upper case letters correctly (and (every #'(lambda (x y) (char= (char-upcase x) y)) lower-case-chars upper-case-chars) ; be sure upper case letters stay the same (every #'(lambda (x) (char= (char-upcase x) x)) upper-case-chars) ; be sure non-alpha characters stay the same (every #'(lambda (x) (char= (char-upcase x) x)) non-alpha-chars)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bfa3a3f385aec611c8d01587bdf85649acd735f0 GIT binary patch literal 2526 zcmb`I&u<$=6vt=RNowbZ>x8H+RvWfeB7xNnq%Bn&gw*wB9Xnp{I{PDzDiHcS^ATAs^aN-Z(*c-?4W?!170jV4+>#NVcc{6X` z{CML{(z~eYl3HJFRBPp?RPVGKowl@GZ%VCtr&%mZ%g`=;q?(rYNm5bMlkZLS+xtAl zX1UNVmn5fCZj}lfr=_WjlG12aYw&U50+>_N@1B`HcW$yjq1ZY`d+C@n(`V05pS?KQ z|MdR05UCSFie!f)L`Z}Li1$@D5_2@$krOFhlMN-K#k@_g8-%sUuB};KcleCdt~cab zdA(fY%UNv^fe`P@ZZP2*s*^GeZ%eo>40?CFLn%Yf!qSvkjflbBC_K90b;DC<<#V!{ zR4hexG>hEdK75A|;ho`#$n*KR@+d7lTqEB-PK&uC(P5#_PjUYiXFNADXJ~zW@Q5b^H2e0Q&@#x?W5;920PPI6` z^8>lJFA?F=vqXZtHFqpGGC;_W7knd{8|B7Zz9FFz^^GyV8}q-9!(6v3`1{|f9r>@+ zAkn!foY+n!!uR#-?(vvv8Z#-r`EpV*W^~Px<0)t{X6=~R$3kK+oa}H+RU9=bTbkoq za5AcYw0(BocC?HrLXS~AdsWvI!_CSG)5_Q}CWyknM>}SW4Fp2`!suoW=2I10^Uu@X zyD!Q0P0`$j$Ygu!#ja5Hhu;vEkk43W>o zO`Urp2Se<6hT(38W13}|mTbCC)^%cm5$HV_Q;fXqxASFt-N@8|yB>lwWIgmM%M^#3Q3yD!x|XFG`>Kfv+&2Ke(dS3zZ=F9a8vr-?6OOchLR-+R zyllgU=o)YR9pd-;jokW`o#gll@jc=WJMk$SYp^#$;1eeJfUITC8r(VxbB6uW-YYs5 z;SS=*<(t6+{tcDfXYf_%QTXTW#so zE#;K7T!8njBvse&Y2t0SCV0p{wn^v`++L`{2=ThnT48mmRNx&C?lyE5{N08P_qxKO zAVR94z4V1%*r(?vAw2qT+a$=ND^Fe?T-*&V^5CGnAhOdCgU5ONisC$YMRC4;MRC6H z?s;3h*2h#!QyeJSy_dtkhI$HKV+9ImfOmrnH1C>@#>Q`W-O1^=2KQUTSKt3DYwsQR zvva;>@1FeRjJL&WKu{R3L?Mn)5iWBv78ls74 zA=-!zVjXcEaRae|xXB{ty{#c4h=HEozC*##+k73c^`JON1s6yjZr888c2|7!YG)3oVn(8z|4QkRX zou?MHsY6}5Ky!4F=IP}qA6KADv`9;|Oqb~jt)xzRX3ruC>cml>test>13-4-character.test ;; ;; ;; Syntax: CHARACTER object ;; ;; Function Description: CHARACTER function converts its argument to be a character if possible. ;; ;; Argument(s): object - a lisp object ;; ;; Returns: a character ;; an error signal - if it is not possible to convert the object ;; (do-test-group (test-character-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf lower-case-strings '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")) (setf upper-case-strings '("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z")) (setf numbers '( 0 1 2 3 4 5 6 7 8 9)) (setf lower-case-symbols '(\a \b \c \d \e \f \g \h \i \j \k \l \m \n \o \p \q \r \s \t \u \v \w \x \y \z)) (setf upper-case-symbols '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)))) (do-test test-character (and (every #'(lambda (x y) (char= (character x) y)) lower-case-strings lower-case-chars) (every #'(lambda (x y) (char= (character x) y)) upper-case-strings upper-case-chars) (every #'(lambda (x y) (char= (character x) y)) upper-case-symbols upper-case-chars) (every #'(lambda (x y) (char= (character x) y)) lower-case-symbols lower-case-chars) (every #'(lambda (x) (characterp (character x))) numbers)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c52b48f7f7ffbc71ef20bcc0082c4e1a9ba4c446 GIT binary patch literal 2897 zcmb_eK};J*6rEjzSz~N$LTKU=vLOzo3+rN=P(oBC%d!|3<0b2L4861zoPb1PWS~-1 zC5@1(=3s3?ouHjYQL0uw^^*3MHWi0RJ?2uWhgOwx%%xH;y;N%G|2vovJ5sBbwRYdW zKmWh^GxKNG>!f~4O^IsZ!qUQGz9<$}SC&>+#B+tBxLjB*&gR8)U>84Bbwj&6rl{kQ zlhMY^u9n$ier6>nk^PfG#G)H0?#noMbOTA9!!d)+PxFcvwR(G0s3 zjEO6SC3!LbL4Fa3b77fqgxEJq!e}KUmi&&lBTSVDF(T-(Y8hiKNSq{n9%q055~Fs7s-We{P|#~`-3@ZdZlEo%*jxcU3<`Zsky(5LIE>$?9TA?x#>=>Bn@ z^TF%AgSi8k0JIB)G!e47FdN$ZhWmV1uH4N^t^!(f?YRywA>Sq)BIY`g3^^p6>q64w zknWs>q}?ICxd@Qk&U;@j2JctrE5Co8Yun3mMak_+<&Rbp^}u*w>9GxO%;WW1Q)`V0 zQ`)<9u2s_U)pYd#Isv)2LomM0`2gX4_N`L8r0VIBBvz?BrldzwnjsG-!IDm7B;G?k zya2Zw?t0h?K}l6ibxbxiGiyL8tIl3nHV!=Lm5d<$7NS0GRhxtD>>B#y5uM{Z+n>v8~28 zj=rx{`8vh}V0+Wp9W|sods*}gtObD&R!@|=n{1glKLtpjUSlFx zgu$;29x?dJQ6XPADx^%q`yqm#K$%HHPo$BZg5d_7GyeJM8>cPU)a~?#g^BDi9O^J| zm_lbp1GERM+%xd;JwFE3Gq6~m^7R6_WU#eU7;7VSmj8iN9Z@t251nMgkq>0#0B z4v@RxzrSi2a>CHFlTHx1Mx~Ev&l2syW#LcSrNd@^c}48JqI8PqX5ia9CoWuMpG~w~ z!G(g4RN3Wg?Z8*4E7#f4pw0Dh)@C~?;=H-zEhc^)a~HH43Kb@Q$|q$Rs71mFt6h5Q=wV9UM`);JeBgwIQM z+3oZB1VKQyip<+2cv_K7I|9L~}*aM}X93^27lz!YG!fE*a z{I~h$cjo(E&6<+ib}2G6ticJVv43ICU(1!960g+umCSavN6y1qT76dZJwPmzvdfyX zrmc4jcstU0bR3&?YjOnez`?idasZvJm=(ABt>e~!^`jqoJ?}%OYRkx#V2<#Of!Bh9*c*$qQt*yTStEV9O literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST new file mode 100644 index 00000000..0c2d5284 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: digit-char ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986 ;; ;; Filed As: {eris}cml>test>13-4-digit-char.test ;; ;; ;; Syntax: DIGIT-CHAR weight &optional (radix 10) (font 0) ;; ;; Function Description: DIGIT-CHAR attempts to construct a character object with the argument font. ;; The returned character has a code which is equivalent to the argument weight ;; when bases on the argument radix. ;; ;; Argument(s): weight - a non-negative integer and less then radix ;; radix - between 2 and 36 inclusive, the default is set to 10 ;; font - the font attribute, the default is set to 0 ;; ;; Returns: char - a character object whose font attribute is font, and whose code is ;; equivalent to the argument weight when bases on the argument radix. ;; ;; nil - it's not possible to construct such a character ;; ;; (do-test-group (test-digit-char-group :before (progn (setf weight-radix-10 '(0 1 2 3 4 5 6 7 8 9)) (setf char-radix-10 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (setf weight-radix-8 '(0 1 2 3 4 5 6 7)) (setf char-radix-8 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) (setf weight-radix-16 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) (setf char-radix-16 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)) (setf weight-radix-26 '(24 25)) (setf char-radix-26 '(#\O #\P)) (setq weight-radix-36 '(33 34 35)) (setq char-radix-36 '(#\X #\Y #\Z)) (setq weight-radix-2 '(0 1)) (setq char-radix-2 '(#\0 #\1)))) (do-test test-digit-char1 (and (every #'(lambda (x y) (char= (digit-char x) y)) weight-radix-10 char-radix-10) (every #'(lambda (x y) (char= (digit-char x 8) y)) weight-radix-8 char-radix-8) (every #'(lambda (x y) (char= (digit-char x 16) y)) weight-radix-16 char-radix-16) (every #'(lambda (x y) (char= (digit-char x 26) y)) weight-radix-26 char-radix-26) (every #'(lambda (x y) (char= (digit-char x 36) y)) weight-radix-36 char-radix-36) (every #'(lambda (x y) (char= (digit-char x 2) y)) weight-radix-2 char-radix-2))) (do-test test-digit-char2 ; if "weight" is not less than "radix" be sure it returns nil (and (notany #'digit-char '(10 11 12 8 9 20 ) '(10 10 10 8 8 8)) (notany #'digit-char '(16 17 18 19 26 27 282 29) '(16 16 16 16 26 26 26 26)) (notany #'digit-char '(36 37 38 40 2 3 4) '(36 36 36 36 2 2 2)))) (do-test test-digit-char3 ; what happens if "weight" is negative ? I assume it returns nil (notany #'digit-char '(-1 -2 -3 ) '(10 20 30)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2c13d0e52214a776525444927787d607cbf1256a GIT binary patch literal 1096 zcmah|OHUI~7`@X{`heCJtEA;MfsmNd!L&fY>Vk2&rG<7{XQl$Os%^1N2HNytG)5$t z=w^%-BAJVU#KfH&mLf(L{sR3E?)eAxyG77g6Bd)1`5xzeEP&ZVolEUVUXm2CR)H8yaA z6-woT1|O4?@EZt?2Sa0HBaX13#7@x8?FoiPCqjYo5l3Tpn{gKrLK$>KUv`At$c&6l z-OZ_3QTcE*hIvVdW6r1>x(&4ODFw@h?g_HhVu{ys4|5uovr<6}LdF~27EVc`8cj&X z7PHQD8n1O{RN|8$O_;&RWc!Um(HTQ`1V;HWJ}Rla7!hQ&yKUV78vB&X=ltO;bFhk* zzRa5D-F^>ap;7uc5juQ;P}hdl#pDmZO7MMLpL->JL#UpAAp6{a7khLMy ziO^9Y<87)uMgDk-Y%QFRx0&C+^dG=_-d%7blht^u_i|!FnvPQKd_<6@V_4>IMhHbQU4_aN#H98&e=-C$0Fs*qB zOe{_6&tQ4lCCVvQA^vzvZ;*6P5Z`s;A0qyC+PY)t18S~PWe3-UL3TL}7b(jYR!{B# zjjatY8SjiO6F~KgG8Rcml>test>13-4-int-char.test ;; ;; ;; Syntax: INT-CHAR integer ;; ;; Function Description: INT-CHAR attemps to return a character object such that the integer encoding the ;; returned character is equal to the argument integer ;; ;; Argument(s): integer - a non-negative integer ;; ;; Returns: a returned character ;; ;; nil - if the attemp fails ;; (do-test test-int-char2 (every #'(lambda (x) (characterp (int-char x))) '(5 10 15 20 25 30 35 40 50 60 75 80 90 100 115 120 128))) (do-test test-int-char3 (and (char= (int-char 65) #\A) (char= (int-char 32) #\Space) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b270db6fcf5159e2abbfcb1d872b65da38537336 GIT binary patch literal 1446 zcma)6&2Jk;6rWvxV8&+xKUhkTn*|?UFz&H-J!zie{k=iA*B+|VE%V*lMf0fU94aj*Gu68D?eW{rnucaMK#Lo1^xQ zN)OumJI$L{)ckv@F&K7xaJY62#C+kM)xz4^%G{d(I_TV-z-~Lw~Z>+*b(z%kc;jS>@q*Is*d^tz1RM{-4p5T?IQ^x z_N^b=^lX!s9h;pPP!sXDL6h{s%M1cui3_7>6PD38k#=txF0 z4QiHj7gNuLikd-7qNG76uF5iKEKGZ5TG+6?n!f3{Ribf8mi}o?9gQbKaUKt)M6*Th z3B=x>Hk-_vE!q@HfJ%~37x)CNB3ub20h=dI73-c|v7Nd-yP1QQr#0-lj;lK!t$9=n zrG*F0up4@S3s%fm@-K`~Jc>E|OX@G;;Kyp7$) zE`PPfvy{IUu=`!$HP_j)h1M?+GabAb@mPXc=8CxZAut!k5YqSXK%%zDB1q~xo)hRX z=)`Asp9uPYccpK+j#uMKnJ=&NT%PA*!t7_}zd_skBQWdM}nAbmgG@>_le1bRB*TN#<_?K4A9+c*qzUBeJjhvYf`mABYQ7#xIY zxr!lPxLz_SSKt(?mm0w#Wji+33APF5$}&5NFkdbb=7*?Jg#Qg}F+W0J;b7*6Yp`^( epfiq*Npt=QsHj{QGSIlqkHRTXMX~)?5o-U literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST new file mode 100644 index 00000000..f68dacbf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: name-char ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 243 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 5 '86 ;; ;; Filed As: {eris}cml>test>13-4-name-char.test ;; ;; ;; Syntax: NAME-CHAR name ;; ;; Function Description: NAME-CHAR returns a character object whose name is the same as the argument. ;; ;; Argument(s): name - an object coerceable to a string ;; ;; Returns: char - a character object whose name is the same as the argument ;; nil - no such character object is found ;; an error signal - if the argument is not a character ;; (do-test-group (test-name-char-group :before (progn (setf chars-have-names '(#\Backspace #\Tab #\Rubout #\Space #\Page )) (setf string-names '("BS" "TAB" "DEL" "SPACE" "PAGE")) (setf some-unknown-names '(time what why none-sense)))) (do-test test-name-char (and (every #'(lambda (x y) (char= (name-char x) y)) string-names chars-have-names) (notany #'name-char some-unknown-names)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL b/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5281db2d8ae26d06b4d50858b9e2698b4a655ec1 GIT binary patch literal 774 zcmah{O-~a+7=Cw4KY&6C(L{{V2?>{tL(&2P>&0<8r7hc8n4J|lHtk}Y6x#H|#2AV3 z;AxE(BH7jOAG{()4*ntk0nWAt2^>7l%ro;oAMZN@h(4z#qOHAlqv>`~tKVz)duX@S zLETorQ+3gbb zUCCsZmlr4U#5PB4|EVG7gY}2>6Fy%8<;KIA1gw=A_IF zf8cuwl?6LC6TUZ-LA_QRH{F+RGmNv>1r5Oe$IPda98EJ?ek)1(S|Yw&^f;%-*pjE9=_L7t%6<$w)jHk0eyoX@d!2 z32ZrX(~(AGTooh@!gufxw~at$PNlE4E*=30#=?F@N{S?ww?vu9^-zpDLNI=14uQ6+ z@LT_KP-3$YdoVec3-zSfx$NlW)P~bk`B?VPyy8V}JCULhN8c^S}B>x}v{N1tXH-YYxn!WP+G>Fd05mI$Mqcml>test>13-5-char-bit.test ;; ;; ;; Syntax: CHAR-BIT char name ;; ;; Function Description: char-bit takes a character object and the name of a bit, ;; and returns non-nil or nil depending on whether the bit ;; is set or not set. ;; ;; Argument(s): char - a character object ;; name - the name of a bit of the bits attribute ;; (valid values for name are implementation-dependent) ;; ;; Returns: non-nil - if the bit is set in char ;; nil - if the bit is not set in char ;; an error - if the input argument, name, is not supported by ;; the implementation ;; ;; JRB - Our CL does not support char-bits; commenting this test out #| (do-test try-char-bit (and (eq nil (char-bit #\a :control)) (char-bit #\Control-A :control))) |# (do-test try-char-bit t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL b/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1fe2e8655ae61b54a26bc5467fa4ad212dd186b1 GIT binary patch literal 782 zcmah{O-~a+7=Cw4KY&8EL=!PaCnQ`pPGbuMtQW^&N?Vp$n4J|ll6J983T^sfVvNLi z@U%t?k?d;t4_*-?2mg@&0B4I)#Dk}qdES}l<9%lU@h8+mw6)uAG`$XL^?U7p5AC!% zsN3pysvg==IC?>C!CsaKUClnojX9Sp)sDB_^J+-;y>4y$`CXK|k4U@IXsXT9k~-!J z3;DwQe0Hoz9P5JZzi;w|xy8c#z3kZe@sVb<0H6wI(J~5PKn#Kd-!LU}BrcXMhB;Yd zW-ti+l*)o#hl#+?B_2m!zSK`E+Q}Yle68r4lQ%P3ym9&zVCr=; zt<_Jyakc+3SbfXC0}SeKctzJH01oP(uWt?$sd5S+4RF?|P7Uft!vH-VeDH6X)aJ|O z$RREfzHG5bRv~=FG4&A@J!4WLX$cD^U7@VgVfKWxcml>test>13-5-set-char-bit.test ;; ;; ;; Syntax: SET-CHAR-BIT char name newvalue ;; ;; Function Description: set-char-bit takes a character object, the name of a bit, ;; and a newvalue. It returns a character just like the input ;; character except the named bit is set or reset according to ;; whether newvalue is non-nil or nil. ;; ;; ;; Argument(s): char - a character object ;; name - the name of a bit of the bits attribute ;; (valid values for name are implementation-dependent) ;; newvalue - non-nil or nil ;; ;; Returns: char - same as the input char, excep with the named bit set or reset ;; an error - if the input argument, name, is not supported by the ;; implementation ;; ;; JRB Our implementation does not support char-bits; commenting test out #| (do-test try-set-char-bit ; char-equal ignores the differences of bits attributes; char= doesn't ignore them (and (char-equal #\A (set-char-bit #\A :control t)) (char= #\Z (set-char-bit #\Control-Z :control nil)))) |# (do-test try-set-char-bit t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ae17143b7f5cd0dfe461a1a77681c015b45d3006 GIT binary patch literal 1556 zcmah}O>Y}T7@l3npK*c{RShISM?n>m#acKd(1uE6vKhyltaqK=aT50ca_miQb>lU* z14M`j^-wr0(8MCz1?7OmiBpf1B6{G$&*?u1@9eatDo9wipP6Ugcjo;*LGfKx$EtVG z>$pxIdxyi`;Sle8eLV0E`%MS$1CKvfO^bd}ChBJ4{bI&`?xfjw8bhar*`YINHIClG z#p{^#`W+V**RH{~xV*Hmytr7%l!&d1+x}N)Vfmf+mKT=_nTzu?Dd!=Cn&=USG(tHP zL&2$^%QI>-rKIUpF-V2xgOk8dfiFtUrdHrjE#RToQ(Wg0$K~!E43LCSaL-SbYKF=* z(+Eb=mr^$P&Y#c>r3$W*b&BNFlUw-hQs8Hbi%L;Z&1zk-=@vRaOWXl7?sHpyYd_qO z9(2(!zi-Gple1G&oUG<_$T zmD&&fFkt=oWb+&2PlQg|ca05M0*TZ1{mVO1sJLnhA$ampr#XGn&UJD~jtAfSujW-P2Nb=bJ3>PIzrd1(~ zZ-3&Csx`}^#&g*YC4P1f&My7qlS*tVUJA#%;BV$C-KG{K4jk0!M?BLNvPl(US)^VL zFBgHyL=2?1Mh%r_`K@<>jzR87rb)UttiNi!gzL|3Rz zD_~+3l#{Aisp@pM!WEwI3aeMC8qVGb=dOcDS}hZcsBp=<;cH4bH_jhEhjJS_gCTBu zy(4Ade9Xx(@UJjV&L5L`yx)LsY~fBmVeX zR=5OGDHF0*(#@SnGDevi7On)o>2>k&>5y>_daifmI0O7?$8~Yn8{$0&H}+su4L#gz z^lxJ>-gdClfY=Q>EeCu1?%rX?ZFRc0aPjTpT=4ZJcugYFGt#O6c#D(5If+{jyOIEI zE$qqyGyxj|HU;PcDgq1vrhuw|EdiDQ5iF@57G}=S^a{+kU&||xp=npj(9}5;_%WDQ zFuA0tMR+Ft1OyLCO`hcGgUTg(m1i>bY)XN2@FP#}ssFlaQNk!pu&13Lb&0M)=@H!y U$3+#yw`wM%;mhcU4=*nM2DvuhU;qFB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST new file mode 100644 index 00000000..e140b9fa --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: XXXX ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 29 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-copy-seq.test ;; ;; ;; Syntax: copy-seq SEQUENCE ;; ;; Function Description: copy-seq returns a copy of SEQUENCE ;; ;; Argument(s): SEQUENCE ;; ;; Returns: a sequence ;; ;; Assumes that CL:EVERY works. (do-test "test copy-seq" (flet ((fun (parent) (let ((child (copy-seq parent))) (and (not (eq child parent)) (equalp parent child)))) ) (every #'fun (list '#(a b c d e f g h i j k l m n o p q r s y) "on tuesday, employees will not be able to park on the east side oflbuilding 101" '(it is suggested that employees utilize the west parking log or the overflow etc) (make-sequence '(vector bit) 200 :initial-element 1) (make-array 100 :element-type 'character :initial-element #\< :fill-pointer t) (make-array 120 :element-type 'complex :initial-element #c(1 2) :fill-pointer t) '( (1 (2)) 3 (23 (34)) 5 6 7 (8 9 10) (((11)) 23 45 ) 66 77 88 99 100) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-ELT.DFASL b/internal/test/LANGUAGE/AUTO/14-1-ELT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e965aa7ceb445a1f30281f762d1cfbd15eed4955 GIT binary patch literal 2381 zcmb_dT}%{L6uvXd!tS!*0^3EA!k}Hj)j@Z`s92kh%K!_*49v_TG)?RZLl--+6c(+i zwP^Zd(rp!qX0EM$ZPEur?2|v0G=1%(X?$w>)}(!?X_G#*G4!0dyNacWFFwqC=bU@a zch9-!%$+6T9Zf1iGB-UtWm|JXZXrLrkQXL%bHaRXVQ$9(0(W$ zFxIV%&smwgH6fS_*8D`~^ll-3P>^Qlrfd)n8~`=mwJ*`t+1VcGkqm{gJu@cJ)v>>8 z-@f+1+V!hkC`SkxC#wj4LPEqtoXdq!%#;mN>`5uIs7ix!%vo{@KBz@Z8?x>cY7#;| zH!IrKNz2A^rsoMqh;ymn>q)CgGo`7{GPlSDor{I4lqwEEX;QCDcwdnP**TEoonl;+ z6_Z@Q>OW5iFJcNrTQekgx1T?{xuJ&hqP6r?5_0EFLTb-f)NrEh#g)IHVq03T8T+}!n+ z&D$Qk%=X$|^#oX|?M-Vp>r|V6;$*+GwwPVaKA$ANEG6l~6d=oc?zUL;%{JBE0^7QB zgKF0o+_A{27Sh}a-n5$#5u4}rerOlzV8S_*_Krkk$W1?#}Vicyjrt`laN6p(k>k$q!h%<;XXa&skslabfV9iB?rv->IS&dKJA-fW zB))eYqCy94X{9aLCBDHar1RE%Ua;)E&>@Jzyp^96rZcC7;((SBTk{&MDlHCrES7w27Xx+!qg1= z+o0{NTiq|tg#^!g%Dlk}pT8;+3{-CtYHI7ku}J;qEuC8%Uu=3sXxX;CFS?_(O^@x` zExx{IZ#;qL^0l*^;4rcrBP%g7gpn^`WCKPvW8_O1xf3JXOOY3y&z)r+j7}?=%u6>v=ZH5EQZsXDYN!1I)$poXXfT{hVH?1wmQoV)a}m^8l|n+sBRiX zkQwwa=w;ByAjP1c!2kn=!5{;bfyQ8n!7u}zfkC6^=nmX#gc*)97-cX93GKujy>8(& z0cFt+Ha>r?uO|*pEy_@@wK&o0nXv30{{R3 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-1-ELT.TEST b/internal/test/LANGUAGE/AUTO/14-1-ELT.TEST new file mode 100644 index 00000000..51ae7a5c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-1-ELT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ELT ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 28 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-elt.test ;; ;; ;; Syntax: elt SEQUENCE INDEX ;; ;; Function Description: elt returns the element of the SEQUENCE specified by INDEX. ;; ;; Argument(s): SEQUENCE - ;; INDEX - a non-negative integer less than the length of the SEQUENCE. ;; The first element of a sequence has index 0. ;; ;; Returns: the element of the SEQUENCE specified by INDEX ;; (do-test "test elt 0" (let ((a '#(a b c d e f g h))) (every #'(lambda (x y) (eq (elt a y) x)) '(a b c d e f g h) '(0 1 2 3 4 5 6 7)) ) ) (do-test "test elt 1" (let ((a (vector #'+ #'- #'* #'oddp))) (and (every (elt a 3) '(1 3 5 7 9)) (= (funcall (elt a 0) 1 2 3 4 5) 15) (= (apply (elt a 2) '(1 2 3 4 5)) 120) ) ) ) (do-test "test elt 2" (let ((a (reverse '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))) (and (eq (elt a 0 ) 'z) (eq (elt a 25) 'a) (eq (elt a 23) 'c) (eq (elt a 5) 'u) ) ) ) (do-test "test elt 3 - setf may be used with elt to replace a sequence element with a new value" (let ((a (make-array 50 :initial-contents '( 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50) :fill-pointer t))) (do ((n 0 (+ 5 n)) (m (length a))) ((>= n m)) (setf (elt a n) (* 2 (elt a n)))) (equalp a '#(2 2 3 4 5 12 7 8 9 10 22 12 13 14 15 32 17 18 19 20 42 22 23 24 25 52 27 28 29 30 62 32 33 34 35 72 37 38 39 40 82 42 43 44 45 92 47 48 49 50)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-LENGTH.DFASL b/internal/test/LANGUAGE/AUTO/14-1-LENGTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bdc81e2fb6140628cf7a78c07bb091f2cd43a0d6 GIT binary patch literal 2047 zcmb7EU2GIp6uvXF{o5_LEw%i}&xjC`l|fnxlwzXO;kI46ohdW3Lh%8X-D!8)VRzk~ z7STWm55$lWZL2U>Lt>1HiBCwv17g}3U*y^Nq$WO?@MJXM!Niw(&YfMTfrPlTyXW5T zJ3sfFd*;lOrW0C5*2-rquIE(c@~mH(_2tQORj!q1t9eJB1YCYsGfaA6MAb(39PWu* ztC)P%$@xw}wr8DMA$NYa+;d1)D^=HnMSnkRdj|IR4)pcyi4Un(Ci3=7o8Eza{R4Xs z?TN44ye=fmgpfR0M$tw{l1L<62$CtATDCHj&QL{H$7m{?4}(_7Maf#!41w2QSo^9rVgPA(Ix!zc6g$`_VcgFXI^275QGwd z7V7AGGt<*E(QgJm)9{&r2Qhr&TS0d#>fV0SJGsjKB*!Sad)hDF40g?2XB&?TrtmF^ zSK;4{w=_<0sn~e#0nvH6B`Fl|F6prTYku^7{d+>@i&ylcqOb;5x7Huu&%|ba@hAtuwl&fx7_$_l+DI^4YmA6mNAuE!p{E z(oGVvCHy$poYD;aNE(|*8Bz5k8EPtnX+ZR0D^Y?=zbMO!EW4AkUv%U-C-1}DE#_)+ z4hN+tSITb5cdENNy(^dZ-8lzF8XE4BL9JGC@@~O}@q6Yx*I8{PyEVD$__NiLQ^3f- zguyl&BX7T`ZkH!>FxLyRTZ%?9Vi$L!+F-Z{Z6rZc2pBT7>1oHSS`CG9aA12!^^0Ua5~fCqCt#D?pn^>rBb>PnJ?LAy3Wwb8~DCPd_o z9xjSuAX)TS7znx`Vhh#hG$H6i3_nGcgT_jo1^jjU!YmOwRVu47rl zrqOLb41@UUTiOc_$)D^+6bq2LAjWWc4c@otdl0u*p>((xBTV8tSJ3;Sz;RT%9DXE9 zv5SBTVmS<&Ykt)&O}%pM+~zRY(bK!HZ~uXV{fGAE&g2Wu%9XdOHGg*Q f+}r2hS^xiQ!v-L*!0W*dLuB?U+ekh+v9j_n;hcml>test>14-1-length.test ;; ;; ;; Syntax: length SEQUENCE ;; ;; Function Description: ;; ;; Argument(s): SEQUENCE ;; ;; Returns: a non-negative integer ;; (do-test "test length 0" (flet ((check-length (seq n) (= (length seq) n))) (and (check-length "1234567890abcdefghijklmnopqrstuvwxyz" 36) (check-length (make-list 100 :initial-element #\w) 100) (check-length (vector 1 0 0 1 1 0 0 1 1 0 1 1 1 1 0 0 0 0 1 0 1 0 0 1 1 0 1 0 1 0) 30) (check-length (make-array 90 :initial-element "string") 90) (check-length (vector '(1 2) '(3 . 4) '((1) (2)) '(1 (2) ((3)) 4) '(((55))) '(1 2 4)) 6) (check-length (make-array 100 :element-type 'integer :initial-element 650 :fill-pointer t) 100) ) ) ) (do-test "test length - if the vector has a fill pointer, the 'active-length' as specidied by the fill pointer is returned" (flet ((check-length (seq n) (= (length seq) n))) (let ((a (make-array 100 :initial-element 987 :fill-pointer t)) (b (make-array 200 :fill-pointer 100)) (c (make-array 4 :initial-contents '((a b c) (aa bb cc) (aaa bbb ccc) (aaaa bbbb cccc)) :fill-pointer 3))) (and (check-length a 100) (setf (fill-pointer a) 96) (check-length a 96) (check-length b 100) (setf (fill-pointer b) 190) (check-length b 190) (check-length c 3) (setf (fill-pointer c) 0) (check-length c 0) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3b90b608cfb928d3c8cbf5657d6c25ce22077e7 GIT binary patch literal 2193 zcmb7FU2GIp6uvY2*X_@;#VsvV+JS)J${<}ZmJ&m!)7$QJXJ?j~S!mUStnK1%*#6KT z(GW<%7-Jj@+l4w;#Rpz|FeY_1F(9T7CMG1rHy`!U#5Z~HL8H`jW?;7piE+2xbIOfSsOEX)h1re}q@>4n+xyl@I|;hd}+^n6m1Q~Qtf zG@2Wj@!5QCK0hH?3;DT;+#CCZp2LDPGg~adqPG{+p1$W2eTNS1Zyb_L)${hBdlG#I zd;1ax_BXCyU*V$DgphHvh9XQzl=z6VY)9i3H7#*SQK_g&X&QIRj@l6}w?5tI3w4Yfgn*J;03*Nj=j0( zkk})pr4$uSdMrydnUd=(p-Y7Dty6?_zvzbbb>Vi3yE#Sff0N=*#J06^!B+_>wct;< znGlTp?v2mMRRjX?gTO<)dJeUczYdT56(egScQDzLku^P1(IcxJpqC4a#goxBJ-Vz% z-va$xLaMtwyOMvs+K%y{uNWDL@wjLqWU;VVsJ1`uTx1ptw}IMxDHP=jH{G*9{k5!K z)+6A&TzFfLq<9Y8lvmqNY(ba!-{1znRvhoxm^>eRn0y$Gz#E=A0Y9ihwxtPNlze(5 z0=2k;Y-R(Ssj<~F?lK1CY1|h(?QW`$y6|4y=tq2S$?p*_Ae7kPD^d5=4e%7VuTFwe zW4#*uk2)+DR<}H^5amL&7$tnzxn@5ZmvwDW!44CXk~XMPLmW^5(T2@9A7o)Z0PWiv zmnBP1iUzf^2DG2-_HWP}GcB6txkoK5J2Yd| zi6)d!rAWSmL90|7wvstmhK^I&(v8e<)^?P&?O|;lV8s0lOu#J#YCpoY4{DgFit6`l z8;Z{W-K1#nq$E|ODosP$h<}2)m`XYWlf|?QI2h3@tP{n%K>Ah1bS+=^u$(6bJ#mz6 zN5iK)Z3ox~YhK7tY%7rD2R8!pohMdZQ}U_1kz9nV19(D4XPv#Q^C0Wm$vU^Q?QYQb z9XmFkpPLsZbEos-T>i{LehP+k4<7l4V|QD~?YtoE6i($}a8C%uDR1T?c40S~-CAq0_Wug2$VYX!#Yj0v5 zTo>!+o?RiK{^T8U7rnQYa+9x2D664=*a~ z=?uJ<2E_+99Dw1MGnSFeYN-U4!S8&CBJ#!3Sri{T6+iJF4!O2MB9JQ96X&6ua%Vl|M_!+p zI6GL&SL1Mc_@IV_YjCde98U~aC=fE+b8*1213CO0S<1zoN=vx*3AxF$!)VvXw(=NQ OnLW?3-Ve0(^}hiFC0)V* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST new file mode 100644 index 00000000..abd1b5b3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-SEQUENCE ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 249 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 28 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-make-sequence.test ;; ;; ;; Syntax: make-sequence TYPE SIZE &KEY :INITIAL-ELEMENT ;; ;; Function Description: make-sequence returns a sequence of type TYPE and of length SIZE, ;; each of whose elements has been initialized to the :INITIAL-ELEMENT argument. ;; If specified, the :INITIAL-ELEMENT argument must be an object that can be an element of ;; a sequence of type TYPE. ;; ;; Argument(s): TYPE - a lisp type specfier ;; SIZE - an integer ;; INITIAL-ELEMENT - an object of type TYPE ;; ;; Returns: a sequence ;; (do-test "test make-sequence 0" (and (equal (make-sequence 'list 10 :initial-element 9) '(9 9 9 9 9 9 9 9 9 9)) (equal (make-sequence 'string 5 :initial-element #\a) "aaaaa") (let ((a (make-sequence '(vector t) 4 :initial-element '(1 . 2)))) (and (typep a 'sequence) (= (length a) 4) (every #'(lambda (n) (equal (elt a n) '(1 . 2))) '(0 1 2 3)) ) ) (equal (make-sequence 'list 5 :initial-element #\w) '(#\w #\w #\w #\w #\w)) ) ) (do-test "test make-sequence 1" (flet ((test-result (result expected-length expected-elt) (and (typep result 'sequence) (= (length result) expected-length) (every #'(lambda (x) (equal x expected-elt)) result) ))) (and (test-result (make-sequence 'string 100 :initial-element #\p) 100 #\p) (test-result (make-sequence 'list 80 :initial-element '(1 2 3)) 80 '(1 2 3)) (test-result (make-sequence '(vector bit) 20 :initial-element 1) 20 1) (test-result (make-sequence '(simple-array integer 1) 40 :initial-element #4r10) 40 4) (test-result (make-sequence 'list 50 :initial-element "hi") 50 "hi") (test-result (make-sequence 'simple-string 300 :initial-element #\%) 300 #\%) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3ffc5f5e1b84120cad887d94d69a7f666c343b70 GIT binary patch literal 2637 zcmb7GU2GIp6uvXtZMWU-GAspQ5xO8mvSE<6i2XtBFum<=JDpi(W`PtIvE7;P zoO92dzkAM|nI`^&suol8hsTF=*+MKoIWayt5gW=EV#WMqVK5sT0(tBe)iCMtgrfHB zXltmkmaPmHvi%d;Ow69l7Bl_Fw#OP;V#;`7I0r;?Gq4SobxrwI|;#t5l@!HejIbF)XdJ|=AVyhl8+Cc09nT#OUp*85k< zbq9hjJ6Fk-fEPc?LxjM}`^o%jmGD?KsA?H zrvC^ULiY4mFRG%qMH@@S_+KTt;LNW1x0*~l(y&Ctko#uo@wjT}9Z76MIicts8a3s; zNs#DWR$Q!P)uJDId}Ul!Y&9X9)J~hwqpH{Bl~$i+(_T?{Si?5rEa(feY9ID>I8IH| zFl8fcr_y%ZR|5~!#udF!_T*NaL4!X$CqW+}tOBQFJ@)!jV5zdxFnbjn+3o06O`9gw zmrWlNaBV%T)jdc|RV>O~u^=o9cfnE+mLVys!-cYM*=mGuaH&`6p|WM0Pz03Cvo#2x za(D;BP*N$XccAnVu+`oJTGGP6gmY{y!WjPYY!yO))d7(2;UOQ@P@Q}SbYN+& zQScE6{5a-)$dy<$&(>KingVgibEKH2($@}bCEb@+v{Va=?nZ7uRc*uE!J?a3bOk&s zN}eSwJ#tlW=2YrfKMh#nPZmS?fo(+i5*Ak^b!Y@dlc`2~p{gjq#x@~*%;7_H^Pn&@ zTspGjw|Y$i>4FW%dDsJqd*0PMDN> zWJRZuHW#VnelGJ_$%93y5QBst1U@6e&&xIhnFMQV+%jZS5nds!jI6>Y7BshHW}K0s(acEE866pN zGDW-(92pxNIQ;UliR{s1N5}KS`SG^?+*oGd$Yf#HGtEuA8=IP2CWrIcqs~ad$>!T~ z{l#2n)EUBSDC1SL-JO!4I)dV*D(vN;a_Hc|izIY%u8Tv0Ly|)`haL{Rz(OzQ_+AUV z!a|B~a?3^1-VSe|Yk0ekx6cyYa9^0)mbfu;Q|r0+`&=}s!ONyQF?vV41H`TKryNNe zy?yi4ur&L#BN2FOd*1`lm3}CacYa|}OFoP4tCZQgEo@x`#|ZYW%TCm?Xcce))kyWp zpdqpW*cUAC6YeG4j|-)Zs!8FHlK*j@X-S)!ie|AOs=<-5FKyV=8$O}#p~2dTCMAZ0 zLq33ggjT?llDvm>bpJTbrwEKc*#K9SR{)lQ^jMbF lcml>test>14-1-nreverse.test ;; ;; ;; Syntax: nreverse SEQUENCE ;; ;; Function Description: This function returns a new sequene of the same kind as SEQUENCE, containing the same elements ;; but in reverse order. The argument may be destroyed and re-used to produce the result. The ;; result may or may not be eq to the argument. ;; ;; Argument(s): SEQUENCE - ;; ;; Returns: a sequence ;; (do-test "test nreverse 0" (and (equal (nreverse "") "") (equal (nreverse ()) ()) (equalp (nreverse (vector)) '#()) (let ((a (nreverse (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9))))) (equal (do ((n 0 (1+ n)) (contents ())) ((= n 10) contents) (push (elt a n) contents)) '(0 1 2 3 4 5 6 7 8 9))) (let ((a (nreverse '#(1 1 1 1 1 0 0 0 0 0)))) (every #'(lambda (x y) (= (elt a x) y)) '(0 9 4 5) '(0 1 0 1))) (let ((a (nreverse (do ((n 0 (1+ n)) (m nil (cons n m))) ((= n 40) m))))) (= (elt a 5) 5) ) ) ) (do-test "test nreverse 1" (flet ((test-one (seq) (let* ((expected-length (length seq)) (save-seq (copy-seq seq)) (rev (nreverse seq))) (and (= expected-length (length rev)) (dotimes (n expected-length t) (unless (equal (elt save-seq n) (elt rev (- (1- expected-length) n))) (return nil)) ) ) ) )) (and (test-one '#(a b c d e f g h i j k l m n o p)) (test-one "dhjfkdjshkjfhdskjfhbvncbmxytewywpoiop;alndbvur478362389uioewhjrheo;lasldkhfdkhffds") (test-one '((1 . 2) (((3)) 4) ((5 . 6) . 7) 8 9 10 (11 12 13) ((14 15 16 17) 18 19 20))) (test-one '#(1 0 1 0 0 1 1 1 1 0 0 1 0 0 0 1 1 1 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 1)) (test-one '(to all those who strive for excellence to all those who strive for excellence)) (test-one (append (make-list 50 :initial-element '((1) (2))) (make-list 50 :initial-element '(3 4 (5))) (make-list 50 :initial-element '(8 7 . 9)) )) (test-one (concatenate 'string (make-string 100 :initial-element #\u) (make-string 100 :initial-element #\s) (make-string 100 :initial-element #\a) )) (test-one (concatenate 'vector '#(1 2 3 4 5 6 7 8 9) '#(one two three four five six seven eight nine))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7df65acfc1cb9be55db92c3794c0b9606270809f GIT binary patch literal 2707 zcmb7Ge`p(Z6#w3(X`80W(yW_n)GdyU&FEFrb+hXbdS1V6(p>J+yUVtUFuEr7(q>If z+RZ7-HidN%=elg;zUmMrhzLSg{KNf_3L+>B1W^?HLs4-54#Yoaeeb@htD8e?^UdeI z_kG{@>)!ib=81Q|qDGa{q3J>~Uyhb$XQpRoqT{7EO9tIb4U>|K7n)8GBKA!YvguhjplkN^lyGHA*!XEm+_yf`CN$Q=M7VM3GP!C) z%r*NmSy;6ZAOyB976Z={f?~g$*@58F#DUO~eIUG~hl+vanjT)*pa=C3sO#Z~E1vuo zG!}kwtuKz$O%B~|CrcO;^6g}(T|@#G7+#D|fMM5Yu(;hdx)zLbdqJ=lTw1sZF&4ex zrs!QhX7m5+5L@^}Q%JC{pyx2Kx8~J1_3-C}%-bjRa7q;5#Qeeo`!=k&YbK@dj^1sS*)?QfuZ*`fsLxm6#1J3#CLor3y`jgm-QbN}HRcc7jBtfDL znlZ7F`9v@Dd0R}8EhPahXk`uPQ^jrcMsvipXj&BR)v)v!^LzZv=fU0%#;9TFhNNe$ zOxB8dTHruyOx8vuS8m1_H2J-=;`b238gN1)*znz8sc}Fz(z1nY9K9-8!=T!#31kB9 zMPaY~PGX8|QtpcRVOzKfmi({{Nl^_J%D!gn5N_aBT24{Pvf}d;@e-eYTPR5O^<+ z`UrAwu*fv)uvlam!~xfjY#8#03~VDE&dO@0mqj{R&utyL+;_v|;x>J<%TzZPbD=v^f z*+w`){&3xp-`J)hFdbSk4HbuaTPDUJN=`L6ldsG~%WyfCEBR;~rH?w*O%_TwzbbEz zj*r5%pNkfz_>GOSSGQtFzdCd4;Sme+-}f!vlqh+IZ9`Bv^mCvb1~?3INN`AU7~+uP zpmIoa&^YKEG8~3E7#vKt?Kt|)a&|AeM_QoGCAE9CK4+MTrgpZqT05b8nwm3D&rXjc{)D~Wgvn8aRs*$rN#wT+V6?<}G+|E_-`{3cJ zv4e+RJUWv_BfMRCwqcD$>OYw?O@$(C)>rI!U%dV5V;RtW}o2KmA=F+ zxNnmQpqCf7C$COiOAX!reKFFPf)`gJIr&}cJ0NbHIc|qiliyxDUI;DxY=;Q^0&ss@ zK<_kwP4^zeDpWlt9rkvzj;*X?Esi72-U>;my8z9M~) zh`fxkKUf?+bTBuHqkGR!Ab89oTnkN#s+(DZx{p?Ls=|I)BZ8N8@GQtFXD)z!!rKDf zoN#IZ@^`zZ|G_=&%#mHNwm4PtFsvrG2CM)XvI({k+nbz+7hXuw(;4`^)-Tol3n278 Sm$8gQR!eogg?g_oFaHI0)(@)y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST new file mode 100644 index 00000000..9498370a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: reverse ;; ;; Source: CLtL Section 14.1: Simple Sequences Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sep. 2,1986 ;; ;; Last Update: Nov. 5,1986 ;; ;; Filed As: {eris}cml>test>14-1-reverse.test ;; ;; ;; Syntax: reverse SEQUENCE ;; ;; Function Description: This function returns a new sequene of the same kind as SEQUENCE, containing the same elements ;; but in reverse order. ;; ;; Argument(s): SEQUENCE - ;; ;; Returns: a sequence ;; (do-test "test reverse 0" (and (equal (reverse "") "") (equal (reverse ()) ()) (equalp (reverse '#()) '#()) (let ((a (reverse (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9))))) (equal (do ((n 0 (1+ n)) (contents () (cons (elt a n) contents))) ((= n 10) contents)) '(0 1 2 3 4 5 6 7 8 9))) (let ((a (reverse '#(1 1 1 1 1 0 0 0 0 0)))) (every #'(lambda (x y) (= (elt a x) y)) '(0 9 4 5) '(0 1 0 1))) (let ((a (reverse (do ((n 0 (1+ n)) (m () (cons n m))) ((= n 40) m))))) (= (elt a 5) 5)) ) ) (do-test "test reverse 1" (flet ((test-one (seq) (let ((rev (reverse seq)) (size (length seq))) (and (not (eq seq rev)) (= size (length rev)) (dotimes (n size t) (unless (equal (elt seq n) (elt rev (- (1- size) n))) (return nil)) ) ) ) )) (and (test-one '#(a b c d e f g h i j k l m n o p)) (test-one "dhjfkdjshkjfhdskjfhbvncbmxytewywpoiop;alndbvur478362389uioewhjrheo;lasldkhfdkhffds") (test-one '((1 . 2) (((3)) 4) ((5 . 6) . 7) 8 9 10 (11 12 13) ((14 15 16 17) 18 19 20))) (test-one '#(1 0 1 0 0 1 1 1 1 0 0 1 0 0 0 1 1 1 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 1)) (test-one '(to all those who strive for excellence to all those who strive for excellence)) (test-one (append (make-list 50 :initial-element '((1) (2))) (make-list 50 :initial-element '(3 4 (5))) (make-list 50 :initial-element '(8 7 . 9)) )) (test-one (concatenate 'string (make-string 100 :initial-element #\u) (make-string 100 :initial-element #\s) (make-string 100 :initial-element #\a) )) (test-one (concatenate 'vector '#(1 2 3 4 5 6 7 8 9) '#(one two three four five six seven eight nine) '#(a b c d e f g h i j k l m n o p q r s t u v) )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL b/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3673a2249075998dec6491321b2876e1bb05d35 GIT binary patch literal 2601 zcmb_dO>7%Q6rNrGhAd zDyUUdDC)rl+=ONaR8>NpIG~UdZBc{Z+9OCHA#vn{RH+gdgu;8Xaa#%!7yL8dyl>vT znR)ZxnCqr4yB^RI4mjr(Nj;@Y36=VbZf%Ma>_0G1F;1 zFfv_rOLccfvKQUjOzF(CQs$7PEL6)rbVf!%%p4vbI6O3TpmSWYw9wjr&KWp7c2eW{rc6*Gwr^QM>q5}z$_&XF z*>a9p^eDM{rTsi1;wjw84e#cpaDAR!|9Vnp>v;q}<|n#Z%nO_m z{pdYrKWCz?IoD8}+mZm5yzqPTBq2TL+meEJ{gw{>JI(wh{X0UM-h29_D1c^j?a`NZ z;cWc36S9qvjq-FqciGlPh2L8nZ9}D7v&WMg-tnFdBk9j|PZ(l!a^cX#UFUWo`CuWhD z^QT}Yv^a6yfwhzOr;KsYFM!6ZU*HbBhWKRQo*v*o-5 zIK#&Ve&FR>x*vlLflrL2i2K>Kp(EU0HF((GUh@9?_AYyCJOAzanqIP;Bw`}?sF6ym zhCY_Vu$8llKBiGqK9U1QpRm$m8|x5b@Q*@X>`1GMt!8DD+Kvfvt@6Z(TT_-z3!?B( z4ckbwu1FW_h+r;kPgB!0OxbYkqGP8coiJfrTG6Lu&Rb~)NwH(_;oRzq5W=FEQT>=9 zC9o79H_U=!qxc%Gsye1g^#?MR2{=}OvEKWKQx%JbOR+8-?nX;t`k~kkVrN0gQyKEn zp}IY*dREDnbYw$_1 zEP^BVs3uixDnArQS`J*GXcp^2HMoT{(pT?}!dv>)==ISXqfKwAd^6w7zcUJt z%6hNTk}oKcW_ih5>z@SG6$P409+bTt7B~-|g7rQmvqyf|TvbNF{*le32VVkDD1V#{ zokodxeiJ^tIKW*8jVNSpCTO&UNe#WYWrKS%7`IOvMJ#cO25M9v%d}O1ja%S8HOq5O zqxyuMJq{JITg_56&*NDhS8`erG~13*)i%sxo>7UZ-Ee2y6?4MD9BS1R(E*lkfu#n) zObm0XC`>_6fdSDl*)4)9m_d| z@a`>0dyS>0f{PItifOPRxNTNsM=dCq!HT%=tx5FDiYSQCM555d;?Q*Mgl6AcY8c_s zal;r0;|6+zEHx4=$H8C(qcml>test>14-1-subseq.test ;; ;; ;; Syntax: subseq SEQUENCE START &OPTIONAL END ;; ;; Function Description: returns the subsequence of SEQUENCE specified by START and END ;; ;; Argument(s): SEQUENCE - ;; START - an integer index into the SEQUENCE ;; END - an integer index into the SEQUENCE ;; ;; Returns: a sequence ;; (do-test "test subseq 0" (and (equal (subseq "abcdefg" 0) "abcdefg") (equal (subseq "1234567890" 5 10) "67890") (equal (subseq '(foo foo1 foo2 foo3 foo4 foo5) 2 4) '(foo2 foo3)) (equal (subseq '( ( 1 . 2) (3 . 4) (5 . 6) (11 . 22) (33 . 122)) 4) '((33 . 122))) (equalp (subseq '#(large medium small) 1) '#(medium small)) ) ) (do-test "test subseq 1" (flet ((test-one (seq1 subseq1 start1 &optional (end1 (length seq1)) ) (and ; check the type of subsequence ; this is the best you can do!! (etypecase seq1 (list (listp subseq1)) (vector (typep subseq1 'vector))) ; ; check the length of subsequence ; (= (length subseq1) (- end1 start1)) (= (search subseq1 seq1) start1) ))) (let (( a "abcdefghijklmnopqr" ) ; ; b is a list of 100 elements ; (b (do ((a 0 (1+ a)) (b nil (cons a b))) ( (= a 100) b) ) ) ; ; c & d are vector ; (c (make-array 80 :element-type 'character :initial-element #\k) ) (d '#(tremulous quiver happy mould gulp delight heart flash upon me) )) (and (test-one a (subseq a 5 15) 5 15) (test-one a (subseq a 0) 0) (test-one b (subseq b 20) 20) (test-one b (subseq b 1 89) 1 89) (test-one c (subseq c 0) 0) (test-one c (subseq c 0 77) 0 77) (test-one d (subseq d 1) 1) (test-one d (subseq d 3 8) 3 8) ) )) ) (do-test "test subseq - the returned subsequence never shares storage with its parent" (let* ((a (make-sequence 'list 10 :initial-element 'z)) (b (subseq a 5) )) (setf (cadr b) '(7 8 9)) (and (equal a '(z z z z z z z z z z)) (equal b '(z (7 8 9) z z z)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..08352fa3c9722157ad4985fc19052a69120a1b13 GIT binary patch literal 3758 zcmb_fYit}>6`sfLdi{1>$4Okr9uhUEn`|2Iu46kDBAeaW=Xlng*-da$WVY*B&w9r@ z&g^bdlQv32i&`|KI4;rLLVf`1pGpWf2t*#W1*j60+8;;}NC*W9{vZ&dQjqw8N;v0^ z9o#e!RbYGWd41>HbMKrx=X#m(ejz3aF>_(DVrZ6NHXDo0hEO&wp>8&rG?qR1RD$dS>|kx1lVTOz7T zZnTH`gpPzKj)cMo+wNYu%=VZJ!<3kHB&`h7!|;rA$?gf{MKvExq$M#ZM<>OAv+US@ zSWB>=ii%@z3keN#F=%L~H3OHkP-j?%alT>u69qYzPv>N3g+0%9IIr2AX*oCrON%B& zhVySk!RV}G_l!h>p-vohd#%QN?`DQO(Lb<__0BO2 z8vfJM=67xHUmds)*|A|buipSm?}e5gR=>6;1OMT2_UrP`8D?4ks+{52PT*E|oY=WJ z1w;hj^-5`g?$Aa`?8;_JEeKrOGMmB6UEh71`Pvp0LJW`Gb=3l;@rw;h`+wmP97Avj zhAJYFnMV!Z=Kc5v7(M{^fl0@C=wNu|uJgM4`+r$4_uA%q{V);E1N*c_*X7?yH%8V6 z22g(g0c(d1q*!^=34!>4kLz?bZ+MMPqub~+b{Ru$K5#I2!)LS_9iSXEwzst~%uMe( zOfKhoVLxX2)&bv|>w}Q+2jV>w1_l+b{^4uCq_6fr=w&bKJ(V6T*KgW`0jSS-8f!Y3 zipp_GRD#FSpplbmfNLSGoEIJs9GYzbDC1ZvsEGN30!1IAr^csFt9fyfV?T+==K`di zZzruh9+a+ts3OjxvOVC(z$;$l%%bf+TiX#PA#5}ztWr70B0L2Tc0R8e;T zA#qU>^CF6mlO0HQlYS)I(0E*o<#P&%>_5p)B)_5<_5+GxzvGhUNiW)#$RkK9qz}m; z_;*f5vtlr+DA8$DwUJ#wn18tBuK;MJ04c5FYMDQPrk!fkyaF!>bvBL7yhkj4(ti) z$7WqJLWWV<53xJoQz`|ga%nj)((UL4Wp`SJx{69c*uhD7K?rUopF!fGuFT)4#Qf1E zzjev4X*$f$T*wc|kVyvT$nKM5ca#k8AVY^B0B1S&7aLl=A(YHo33^Bk9w8_+bWO0d zdedkKv!+%TYGy;I>qScwinS%7-msdbMiZnnm4;4LW|{gFt-0ocRs*nhs;SjVS{)~; zIreZKC)sl@x<@D%p_$DJm73d!PzQCEa&(7C5PH@)7dfvsTwDH4Uo;Yw`?~rzIGsS*^p>2pG6nKs|1vipGKoWmYuK z6qoAoZmSx+KtZp}=@@vgv(gQ@`_+Q1rqZ%_@3Ml|3@~sxnS2iE!jH2+?WqggyTiX1cH>*1I z*mYgo%l%~jntnZXL%*55lwFu?Y_t=~)b~4CH?ex^3ziy z*780D%fxO~q1lOYOjNP`F_*!_ixTZCuLAFrL^+vHq3J8+3Bp6G$TT=rJ!p=;-0+pLvn&Rh^X}7G*LMr&a5VtEo&fL3xjqjk_i9 z7b8k8RS-|Om`ps8%4S_Yn@Po07th6A%1YG4Cz5VVF5_bPO(36&kCqK7YhPm?!drBq{C=C-mxFn;Z4Mo;}dT7Fn!R? zQH{nE6XTTkCKIV}$Yrw`sW3`ee=3p8W-_S}Dz(F!z&VwPgk7^In;DI4`XrKWeBUuS zHhCPPO3q3rX_C|A40(<$kuQ_8 zStO^3Me3vh-^x8@(>w(KRGA|h7$CD}pE)x;upciZ<_+BNi+At-3vJV7I{*Lx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST new file mode 100644 index 00000000..46c369b2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: concatenate ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 249 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 8 ,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - removed ARRAY test since ARRAY is not a legal sequence ;; ;; Filed As: {eris}cml>test>14-2-concatenate.test ;; ;; ;; Syntax: concatenate RESULT-TYPE &REST SEQUENCES ;; ;; Function Description: concatenate returns a new sequence that contains all the elements of all the sequences in ;; order. The result does not share any structure with any of the argument sequences. ;; ;; Argument(s): RESULT-TYPE - a subtype of SEQUENCE ;; SEQUENCE - ;; ;; Returns: a sequence ;; (do-test "test concatenate 0" (and (equal (concatenate 'string "foo0 " "foo1 " "foo2 " "foo3 " "foo4 " "foo5 " "foo6") "foo0 foo1 foo2 foo3 foo4 foo5 foo6") (equal (concatenate 'list '(gjd dshjgf lkds e4rohuew jdfhkk kjhdsf df l fgd jk dsf jlk dfs ewr fkldj) '(7983 873 478 32 90 435 7 43 98 32 894 67 45 243 564 76 54 342 12 43) '(fdg89 fgd- sadf98 gfh32 kjlu5 hfgkjjh1 kjhfgdhj435 kj54 kjfg9 bncmv8)) '(gjd dshjgf lkds e4rohuew jdfhkk kjhdsf df l fgd jk dsf jlk dfs ewr fkldj 7983 873 478 32 90 435 7 43 98 32 894 67 45 243 564 76 54 342 12 43 fdg89 fgd- sadf98 gfh32 kjlu5 hfgkjjh1 kjhfgdhj435 kj54 kjfg9 bncmv8)))) (do-test "test concatenate 1" (flet ((test-one (type &rest sequences &aux (expected-length 0) (contents ())) (dolist (seq sequences (let ((expected-result (if (eq type 'list) (reverse contents) (make-sequence type expected-length)))) (unless (eq type 'list) (setq contents (reverse contents)) (dotimes (i expected-length) (setf (elt expected-result i) (pop contents)) ) ) (equalp (apply #'concatenate type sequences) expected-result) ) ) (incf expected-length (length seq)) (dotimes (i (length seq)) (push (elt seq i) contents)) ) )) (and (test-one 'string "12345" "6789012") (test-one 'list "8547935743897598437598" "hjfgkjfdhkgjfhdkgjhdfkjghdkfhg" "rkjkthrek49837598473eukrhke") (test-one 'vector (make-string 200 :initial-element #\u) (make-list 200 :initial-element '(1 2 (3))) (make-array 200 :initial-element "concatenate")) (test-one 'list (make-array 50 :initial-element 1) (make-array 50 :initial-element 0 :fill-pointer 3) '#(3 4 5 6 7 6 5 4 3 2 1 9 0 9 4 5 6 4 3 6 8 6 4 2 1 2 3 547 90 8) '(sunshine on my shoulder makes me happy sun shine in my eyes makes me cry) "sunshine in the water looks so lovely sunshine almost always make me high") (test-one 'list () "" () "") ) ) ) (do-test "test concatenate - the result does not share any structure with any of the argument sequences" (and (let* ((a (LIST 1 2 '(3 4) 5 6)) (b (concatenate 'list a))) (setf (third a) 8) (equal (list a b) '((1 2 8 5 6) (1 2 (3 4) 5 6)) ) ) (let* ((a "trees lists cons numbers floats") (b "t nil identity lisp cml function macro sequence") (c "gcd max min replace find setseq elt member if let prog") (d (concatenate 'string a b c ))) (setq d (delete #\r d)) (equal (list a b c) '("trees lists cons numbers floats" "t nil identity lisp cml function macro sequence" "gcd max min replace find setseq elt member if let prog"))) (let* ((a (vector 5 10 15 20 25 30)) (b (vector 3 6 9 12 15 28 21)) (c (concatenate 'vector a b))) (setq c (delete 10 (delete 9 c))) (equalp (concatenate 'vector a b) '#(5 10 15 20 25 30 3 6 9 12 15 28 21))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2bb6ef004ad88c8894bf742493a12f1ed75a831a GIT binary patch literal 8899 zcmeI2dvIGa z9L@zssXg%KNGcuOzbzc;x#l{%I-~RqPv(ZEb0dN5-rUs4(7sIpyE72pGg&ASbaYVF z-rO46+|qJQ_117EA*206o6zRwPPRFF=%8LVp=sK%b{s{OrqyYtR=%%P*O-lFvcawK zL^PNT_eLAbGv!hx%_Z2MiKfe?`cPncVo$J`dt5NTjx~7%iTdLgJpNwSVsbqOp zzf-R%zo)b?o(%TU)WWf-W>mVPV067)T4=WfL&4}x(e$8p=wS6-npW}daZOvZlfyZh zf3inEGOqiM^%y$>E9!OsZ5$&)#V22*X@xUS?3>@}^9z$P9c=*yC zYrSY_P#WQQVR-$#DW3MGSed`^wI~P=p)L z>&{bue#P8B9LoHig^L-Tb*~p)&D@1fe(uX39-h}g0dALu-9@u#6)TGM#dY+#syI~a zE#5r#muk8{h~b96r}wg}S2%Mqr{Q1aO#|D_rxhjLHEAM^uV|vFEPX}O#a>qbF)tq6 zUETYK=TmO~%@^#TaF<`OAcz#e|d9}@BMYZUo$mxex-F+gp zdRl7vw=Mo(yFdXgz0mV%CSO;m(~L#s1ErOXkyNrfj>md%TR7RBh^B*GacW7%GL1&9 zQ)N`sr-nWY=u<_XO8WTeV^J8uTDjiJqXZ!lIjpkx9sA&u*2ZP+6X>=%&sPA}XK2m3Dn&U$jvK48? zT{Mz^YbxCv&Z7EOc#ZU@)6t}oig!8TB{UD#C@sm z?mn{i{n`nj_#w5`BvL!*F!MFeeP44fN8j6d5Z`{b_KiysA%n_zHw7Ng;!5|ech*v2 zzR1ev3#?^6%Z2_tDO*W8MiElc53!1Vzx3VBh4yuB)Q(E+aVg$M>r_MU9f@FHDxQ?Z z(`I>fwEv_r_24K;Um~8#Hly0O3UVVk(SAXq;?3n!&2(;RIzX=`llua#XuG3aT9ZZF z+P8$)21bYIoogge7?;;2w7umDsM+O`FP9s-4IC`b`h2Etfv+r={8RMOHO@V2No#bd zSVYfi>bavZKAoFHZ3Xo9j*Ure=|OGDmM}fZyG|YGicooHex|D~U#FEzmlcP`ZXFpy z2mJ1N0fB&rV|j&DF{d_C@4y7LOpcClvcI>BUMFcPUGc1QC1&T{M*YuG zuv3N6aZK-7(l^~Hot!tN6UvmHnm46m^QLs<)t=HLkNl$eUSz(&zibH4_*`3A=PxhpPB~hhq39ic;4&bb6+RmivTpv>dvGy zDNd;H8U6|fhsye_TKV)r&Ds)P`A?i7!#zWWcYf%~!%49o{o4`Jot+~@9DgUGht!DP z|F1_h<3@zVp*1sQ&9G#>6cDx0(s%(~V1e#c!@1{Q4`=H94Ii1m;UTQ!8+gNg&zDQf zrs)>AyO?u}Vqto^NH^OdY@hF2<9EaA z7H{4oyc>MC@PB~cCR_mT7tVwC3FA>=?iC&d-!7a3j|q=}3&O+TobavSA>kqLEy8aA z(+vT!?E=&N0Q`C|-3-9DfO~~s2aXHh42}x#1c!z395-(e9sqX=?*O+7-vqXW`@unB zKtMS{MnHStZ;9wuEm4W3u!UCpKOd z-Uj}&a18uMVY~nszZXU-Yy3_axufx0VPq-BZ-l$R|0Ns-pBCN%eqQ*s;2#OU2K;?t zWNF4T!qP%s zCHQt>BwEIp@Op4TcpW$=jHJ>S62|?(xJ5Vs9u!6zZ1f8wb2hdMBbhdOg^`IHabcv@ zMpSqOI4q2}7~=+Eyh$0I!gxzFT7~iAX4t}bmotLG4dAPVF9Ba6ycm4Ba6NdHa24*9Ds=u{7+d~g|e>Bk>YPFr) zJ#JCBS>cevw!%$wYVsxZ3-)XZN;yx__YlWyG1-edwu1}!r z66ksax(cevw!%$wYVsxZ3-)X z?G~k7@oOu7ZN;zc`o&aSw?Nk`&~*xQeF9yVK-VMCbqI9*0pSkkZi+HMoK}5?<;Ph* z?H#+;7SWpUwC>~nPq6&Dr`6(W?WSauduCZa&hmt()l6FFxK+lz&9k_lbwA1S8=h83 zu?V>ql+{+S)&Z8EV);$a!d5J7vN+e?rf|FX-sSl|$YXq(<+nVGCS{~1*Z0ldD!h+% z53@Y!TG*XrfrZ@Rja%ma&#?Tqr`0hxuHE5|oAJhVSoaB*-|;Nk-EmXixDRmuXIY-| zwAz$$+uU(`Jc|ce_j4?t@hq^n=h(G~d6B%IbwAJYyPlS}&k;}S5chw9<@Y=->@(Kk zwVu`oxc`eRpY^n`x6r!Ii}8cp|0R~+_q3G#w6UMCX!k50V%;Mwf8bdt`(}Il*6c;{ zFzbGq$J!?B|Y0Ssr8gV^_)D z9Js^Yc&&6%V*GX9gg(qhUt#$ZSIONan6|nLKrh*HWIw{1$65Z=)%W)3GEeEF-2GLS z&$~+A7G3HoJ;vQnvHY2<9%FF}5Lg zWo&(HZ7dL59a|Y&5nC2p8f%Cxj@89#w??}oUEwY2@6_ggy9T1KyGFL*7uo;lRh|B7 zU^#u`R}o31GW}^u(3Y1=#sGa8XAFcOnju;sS|QpX+95h1I?E+%rTtLjch_9tNnztCGFmFNqZATlN+6!Cfq|fJd!I? zF?8!NCA&tIMrp25Sw#u1QBg^$EqygYNv&b|X|)WWMTx9o`Y44p47|JUDkD^tS$FPv`-P(MX>?`&Xw!zwiJ6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST b/internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST new file mode 100644 index 00000000..e6aada0e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: every ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Sept. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-every.test ;; ;; ;; Syntax: every PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: every returns nil as soon as any invocation of PRIDICATE returns a nil. ;; If the end of a sequence is reached, every returns a non-nil value. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test every - If the end of a sequence is reached, "t" is returned" (and (eq (every #'+ '(2 4 6) '(1 3 5) '()) t) (eq (every #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) t) (eq (every #'list "abc" "cde" "" "efr") t) (eq (every #'- (vector) "" (make-array 3 :initial-element nil :fill-pointer 2)) t) ) ) (do-test "test every 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (every #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test every - with 110 sequences" (let ((a '(1)) ) (and (eq (every #'nconc (list a) '((2)) '((3)) '((4)) '((5)) '((6)) '((7)) '((8)) '((9)) '((10)) '((11)) '((12)) '((13)) '((14)) '((15)) '((16)) '((17)) '((18)) '((19)) '((20)) '((21)) '((22)) '((23)) '((24)) '((25)) '((26)) '((27)) '((28)) '((29)) '((30)) '((31)) '((32)) '((33)) '((34)) '((35)) '((36)) '((37)) '((38)) '((39)) '((40)) '((41)) '((42)) '((43)) '((44)) '((45)) '((46)) '((47)) '((48)) '((49)) '((50)) '((51)) '((52)) '((53)) '((54)) '((55)) '((56)) '((57)) '((58)) '((59)) '((60)) '((61)) '((62)) '((63)) '((64)) '((65)) '((66)) '((67)) '((68)) '((69)) '((70)) '((71)) '((72)) '((73)) '((74)) '((75)) '((76)) '((77)) '((78)) '((79)) '((80)) '((81)) '((82)) '((83)) '((84)) '((85)) '((86)) '((87)) '((88)) '((89)) '((90)) '((91)) '((92)) '((93)) '((94)) '((95)) '((96)) '((97)) '((98)) '((99)) '((100)) '((101)) '((102)) '((103)) '((104)) '((105)) '((106)) '((107)) '((108)) '((109)) '((110))) t) (equal a (do ((n 1 (1+ n)) (buf nil (append buf (list n)))) ((= n 111) buf) )) ) ) ) (do-test "test every 1" (and (eq (every #'identity (vector t t 3 t 2 t t 5 t 9)) t) (eq (every #'identity (list t t 3 t 2 t t 5 nil t 9)) nil) ) ) (do-test "test every 2" (and (eq (every #'lower-case-p "twinkle twinkle little star !") nil) (eq (every #'lower-case-p "twinkletwinklelittlestar") t) (eq (every #'oddp (vector 1 3 5 7 17 35 17 39 97 77 91 -2)) nil) (eq (every #'oddp (vector 1 3 5 7 17 35 17 39 97 77 91 -3)) t) ) ) (do-test "test every 3" (and ( eq (every #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) nil) ( eq (every #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 7 99) ((a) ((a)) a 'a) (2 6 7 a) )) t) ( eq (every #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 17 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ) ) (do-test "test every 4" (and (eq (every #'>= '(100 90 60 50 40 1 2) '(95 87 43 30 35 8 11) '(5 9 40 25 3)) t) (equal (every #'>= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) nil) (equal (every #'>= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 20 3)) t) ) ) (do-test "test every 5" (and (eq (every #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) nil) (eq (every #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(4 4 1 5) "eeag" (make-array 4 :initial-element 'character)) t) (eq (every #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(4 3 1 5) "eeag" (make-array 4 :initial-element 'character)) nil) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL b/internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..61fe26029fd9a5444b3aaf1b28d9668c2177fd0a GIT binary patch literal 4261 zcmd59ZERat_1@>$ah%w7GB>DS>7#6bOkapU5+|+L`s}LX3GV_$VnW*we$Y<*V5LxLXh@(=Xo5=oLhu8SK!OP*B*waO&V5en z(n@qtBrM;1?mg$8k9*EN=iawLtg{hSjFcBD#Zs;+mY3?4rMj3eSH)U+shY`&dBBU$ zM&b$O`AIo4J$TUPNVZWj)m*xs%Zl1ku9i)&>=%7wqFkvKOE4H6g{kkru>U|XIOv#= zld380-|_&%&;h@1&~fYHCUutyAsKQFK^GxzVj;$P-R;$sq$W*FsfrYnql(wqFmyZY zMM@==grWEP#d^6Sm2%JIO1Pbc8li+3=XCo-Di+bE;xVI18??tbt2?J+(hO`(eo`TV zy(I;uQyBY#l3$9-GvwlC&ly52Z!Z$E_ZT}0mxPI!@Q-~VI`yhx=uXRcP-vma^C#wYyC)yyFd@x z(0B3|Kspn5tzP=g^@nKRyIb}-TgI3+{%3t*=k4E?TM#;IEq6aWyM@nh+1*_{eA7d& zfx#GkROcawJ;Gi3!MQkph<+3PyrsVfG@IVKpGt_{!`rkayQS0t8r#)vjsFLpw)}2O zsjG1ReV#8|^0bj4w>Aom;sb6QnEUUSL>mQn(M<%G@nwCtHxiGHPhnkS)ma1dLyzHnUoTWmP$Y&iSSBfOU@-VB`VN+S7>oB z>$YrTT^2VKAD352B;pAvp3-Jgn%B|`3_V^sHYag>(#xO<^@jenm~FEV!aA^o4PjM! z6C~Lt;)$rN;q(pE8c8J*O02C!GK#dzK=a($Y(!2frYhEr7a zu1Z@~6Y+Jn9YL1$BM7rT1W&L>5PXt(5LoyU;Vn)Re#&XW6;2bHXsmK1C99}K(9NaK zacRP=$&oTS6q92IUqXM$Y4irC(Kk7bGLv?iv(r;1sG6W;g1iZyHo-9yXeNl6VA2Gl zsbP<)!NE0<8)&aQGo!@D!CrEeDs~?p@9REOsSfbgd?RYUbgcitbaec>J<=V<-x|;MYy7DF^r^&({;8R!E>;NN;pcx zs6(Af@;E=rb|G$;xu}N&;g4(pkivI3O?bsbe#HbUz-{}qtfrJCu6c$}m53Hk;PimW z;xpIoe{VYsu$y7M09Kq>Pm8*Jb>+cn2_A7;CQC^o4j zAWkCNvxg0gz(UIp4Sk}XtJTGYbVZcJVqUBla$+l{xJz+4T@!1ST&9>W!h5J*7LVt| z#bRkc=cwlDOV!01B2d~DL*J{Rw0)=LePTWhZ>+3XTr{6Yh&%llE<0m1JE&mkz;PKK zBlFpOEt}8QaDLLzt=U|DejX?DFi9WJWOFz8|Ze=~IV$zpEdMCN#HW%+ZXfw9~&;{O7xGx-z6 z<)xMC$2W;AVO7?58(CFCEoe|P3o8-~SpYWSFJBbe@xKQEx zJ_PSi8Cn?H14Ij+c1+`+`{Or*VR zKMxxH^*wH*Z@0V65BAcxxZCL0jb;}dWAlgj3xH^V-i|eA=c=I#iz~(jp?h|{)>y}c zqUV5)sREXr*9AFz`%?oy5&%WVS=ne>ogO#{YhCsi<-Py-y#-F3rM9%l2COJThd`T2 zNo80JJYmj51qa^Z)-`(O7W`h6Mfgb3t@)+J#g*>$8m4unQpy>+tz1nn&ga&;oG4D- zBrZ8z5)Qc{*Efpp!he$ya9;7`(U0Hj!X51{^x>lI+=b+4uw97Ky3fXz5&ApXDTDz# zZY_dav#bZZSQX*06OjtzsqtN->1WIA6a#7GORUP_x&MC*n)_|A-3E#3{6HOYzG~=x zo;x3?L(Z4(j>-xMx?P_okq?%-wyBvKQ6VBpJHMD%#4cml>test>14-2-map.test ;; ;; ;; Syntax: map RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: map returns a sequence such that element j is the result of applying FUNCTION to element j of ;; each of the argument sequences. The result sequence is as long as the shofrtest of the ;; input sequences. ;; ;; Argument(s): RESULT-TYPE - a subtype of the type SEQUENCE ;; FUNCTION - a Lisp function which must take as many arguments as there are sequences provided ;; SEQUENCE(S) - ;; ;; Result: a sequence ;; (do-test "test map - test cases copied from page 250 of CLtL" (and (equal (map 'list #'- '(1 2 3 4)) '(-1 -2 -3 -4)) (equal (map 'string #'(lambda (x) (if (oddp x) #\1 #\0)) '(1 2 3 4)) "1010") ) ) (do-test "test map 1" (equal (map 'list #'list "12345123451234512345123451234512345123451234512345" '(6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 ) (make-array 50 :initial-contents '(a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e))) (let ((x ())) (dotimes (ignore 10 x) (setq x (append '((#\1 6 a) (#\2 7 b) (#\3 8 c) (#\4 9 d) (#\5 10 e)) x)))) ) ) (do-test "test map 2" (equal (map 'list #'(lambda (w x y z) (not (null (equal (funcall w x y) z)))) (list #'member #'intersection #'+ #'>= #'subseq #'cons #'find #'typep #'elt #'complexp) '((a b) (1 2 13 4 (5)) #c(1 -1) 10.0 "funny" 11 #\s "apple" "orange" #c(9 10)) '(((ab) d) (10 20 3 4 5) #c(9 8) 9.999 3 88 "sun" list 5) '( nil (4) #c(10 7) t "ny" (11 . 88) #\s nil #\e) ) '(t t t t t t t t t))) (do-test "test map 3" (let ((a "12345678901234567890") (b "024680246802468") (c "9753197531357") (even t)) (equal (map 'list #'(lambda (x y z) ;; skip every other element slice. (unless (setf even (not even)) (concatenate 'string (vector x) (vector y) (vector z)))) a b c) '("109" nil "345" nil "581" nil "727" nil "963" nil "103" nil "347") ) ) ) (do-test "test map 4" (equalp (map 'vector #'values '(1 2 3 4 5 6 7 8 9 0) '(11 22 33 44 55 66 77 88) '(111 222 333 444 555 666)) '#(1 2 3 4 5 6))) (do-test "test map 5" (equal (map 'list #'(lambda (w x y z) (>= (char-code w) (char-code x) (char-code y) (char-code z))) "cfjiwuyrklmops" "kiemjcbsywq839ew" "KLFDDSLFKLDKLD" "736y47326479738") '(nil nil t nil t t t nil nil nil nil nil nil nil) )) (do-test "test map - if the RESULT-TYPE was specified to be nil, map returns nil" (and (null (map nil #'list "abcde" "defgg" "gdfsdfds")) (null (map (= 1 2) #'- '(1 2 3 4))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..91a6e80c3694b043e4c187747aaf64a950ab848f GIT binary patch literal 9069 zcmeI2dvIJ;9mnru@8(IGl%({{(o$*DZq41i3urgn?RJ~ZZo0dn4<0ono9@z0(&hnl zvw(iBLBRVQ5V0mgSSQSvJRY7?Qh=Ns7(K?PgjDz*}J->U}le8iZF#coO z{hiM_=l46m-+A17e|M7!&Ds=-`9i~kJ97EVh;Mj&Y{&SRZ(w-DH#$5%(wFfKP`mH_ zp+qvgdtETpx$=CwJf-yXjbwVqGX1{vcxJS}ch?G^-R=wS7|G=c+S;gUuWAmgYHC_p zzBZVO@o4|ih71~3H8rj*KfZ6TUOlX7TAy|ZMVY2mYo=DbsZd>?4yV%owb5AE9}jkg z>x&b`LMhF~-;)X_i-nqiZ)|vnKcBfWlgD%hM>Sp3iZ>QY*Y?Ci>1ZNeoYb$;D~q2f zoDq%tyJ>2{NLVvU-BB>QUMy7DP5yvCo=6Ado3(v=%Rj7XCASP|+Syw~JO{H6bm|9& zbkBpG#zx=V8r{211c_Mj$yRDw?%3VCrnbu7)0Nrs3SqM5^d{w&=slNvOW8}_q-vHv zc?12z=QUaUdw?2eez;_oo;|R&>QJJJs>dc`pGZ_aq-hh`>l0O-hJFU&{w!_=22bX?FeVwb~&p0!(VP^|gkyeJ9KExfIp+_l*{!v7ZRB?ypG?&5KPyq2sLIZzt3tGH ze}WYDzdYr@k#?=Tl4{*6srF4@NuDR=fveyHm(AvlTrO|r@@3_8@sVc=Zno^p($8G{ zPVe|h=(1@|w6b;6nmD4jZ(+TU$#`(Pb#Exr zCqECGPuoGU%{y(!+Z|!a{W8KCGA^~G7}cu#$l0d0Nmf+z9*Uj*)4IcgCetLf)bih3 z{8zK2;b)!hku{O6&Q)v1jN+cc{Q6KLz9x!Cy?JrspWtrlvU_WF~8oY3!kqylWH5 zu3#F~o8UFnlT3!=O6KF}=)0EsYEMo$6ikKLl~aN4G)Cey2Gwq)Jzc@hus@hg1~;SW zLTFqR4y6-GR2MmQC>A=iP*gZ)QQUS`?$C|5X&#RX3 z9Q`TU@R(iPxPtALvE3YDXCB2G2fMq&@ii2M`5iGE{dr-b9~2h)*M)_CtFX|o z7Ao3HqECBK^l3j9ecETaZ=cvA?PJ2dcD*xuw^K)vZFTBeoY^a!Iv+{$R&pgdx5Vi~ zZIDu7IuLZUVyIr`%tz5hI%T1C!DKL$4vTZJp7dr!<8&DXWBza~+(l;(n)93mC}ukg zsqo(D%tLX#7{z-v7njgr#swFmBjlWoqFxl%ABDDcRH#``ad8wz*S??@H zQN_xZ&@%rf3jJ9G5U1-ZL@N3|p`w41`>qp(_ONKw4sz{wEF@JX=8t1jt zCdFcDAE7aIKf>_DqN#Kvs`U#Xmy;9i*Ca|lUM!T4Wk$z*L&IaeL%V#bWX6G?p1b%@4it!9lJq+pE>B4$_mmU83j-*=o{&?i9Va@v&E>O$y({n-QjMN$PCBQqz>0JMd$+}z$&t|bPl~_ zO6cav(7ngi(7pdqL-+puoe14&H=R`+uJ`wt9B!;VT^;n&NmJ>Frk(RJJ9%IA{)U1b z%?%9E^t>;VzUdKD@;9HwOI`U3W>HgxUi<1UDOcsWc;b1!KpY}|N zMd>gHV=1QsYBbReJ&AN!Tms%NO*^zrnDgfyoNDhC#YxNBvb5GjWuQ1&vUSVy+Qp@K zIC(FpYX6oC0!wuR)eTTB+cHO}c0qMxN~%Vus7BG z6g%$uZLzRmjP8Ql>H98O=5u3XR2?1b9r2w*x}K-sjMBkV9D8n`=Gewyx3c4=Q`MIg z3qJMs@AqAm8_W9aK!a~IvvWK%)R)1T@|+_^Fb~tJA`3Jh)>(l9n53k+n6z~`2}V?4$NDacY^mZ?*Kc@!{9y4xXGCl%!A+?nDLM?Kgzrvd>!)@ z;A@$4;N8qw@GfRN3(Rrm0q{=d40w>aADm?;8*O(*VzcS;c z#P~Bal568tW@NL*E6hlgjHApQ;9oKa!7nhc20zREUhtF5?*Tu~jJ(nKA@c>`!_4P{ zA7Nev{x)+v_(A42@B!vl@O{iJ;JcWSQ5knI<3VNI#@q=00yAz8#x2aaVvT*w4Pb}) z-QYdUE5Q@Ye((*;rFRMq+OCFe8^YHZUW-H@cYdZeT>2k?0#?=DFY?Gv2F=3z_k9 zXS6fp#nEVH#=E3pGuMIr%(dWU%x8j^FwX>^!(0Piz+4TU!#o3A$6N)jVa8YWhI{@i z!DZZzjDz0r#hE_?tTUGp>#sAHf?s1U0socR3;r`RQfmEGW)JukW@Ih;QD&qw`il-p z?H=Gmr`+lFdy9oC^-k}@+0yrm`?~(2;$$af8QyTLE6{8^Ba)jGZd5p+u&r>zNw(V+ zZd15b;TDAzzqaDnR{YwEUt95OyM8T--*pRgy#igQK-VYGbqRDm0$qnd*B?-E7ibPB zOQdk4!U2VCg&R(?-L7z(!mSFoD6IIko0N9NudVpC6~DIY7gKTF0$r~_*D28T33Oco zU5`N5A<*>)RNMuc8{Mt=QyW-bY{Mw3N+x3g7 zxNd>2SD@<@==ub@E`hE`pz9Fm`UAopt~(^`xLoxw3VBG#XXItq+{9YLQtL~i|64*n zE47+jt?iTzi=JDB{I-xklUj|Wb%L9D+-=h0Hlh0+A)k|40mUNVT2NYDBDB6NL} zFD-1v!X}Fo?JWwovhS_Z_gBOi4-5H%v}jO9YH)pDELY)nq5FuCKX)zccCx@iZj|HR zA^N{7%hwj(exj{hpA&kQS}(xCuG#S4ID$LjF=}wJ77ZxZ`$8i~U0P zu#hiF3+(L)b}b?@lDmZN_l0~}YRP>LNv*p@{||)xmDIvMV;$(tkx$k=qW_4HN2M0_ z7Fy@a81EJRKNRxUQcKxS8~X{1R%vmc(EX8+zmXQozS(l$8f7H+3*8?J`CGEUg&?=> z-SoaDI=&|4V?w?Hhs&k;*G1doLjKM*m%DRbandU~4hZ=ZA%E{Gxtjxb*c;hOhZ5s2 zmJ|AhF#4&Ge{hxDU4m(|y8vg)cn%89Cxm>})t7rTPbxhix}OyCkFJv3qO+vZgQEK> zA^+qm$sIaVDt%LQKP}`jR|y-0Ih?UqORYPsMH(V2BP$~Hk)@G$Mb3>ZiufW6Bl9D3 zBeNs3BDIm3k?Kg*+VGlCM{qU&ickEWZx`H~RC2IrOb#Nhp>`^&~k% zn^P?fUpe++d#7(b?A5a`0_&g-6@%n_FS>hsAfWbUv$7Xmd*GwL;b$t z0blQlS6^Rl)JK1I(wEKjuRtoRJuT8D?S^7OyPCqu42+Bs?jY>z&*Z7-y}XaoU878+ zMAs-SqZHRDDW&9=zMP@7*08*^T!zP@RMs#(l*AeaUf&Gepo47crbUO+G(6stsZopc o&P%^`s17B%y6G=b*7)7U*Qv4WlJ0bJT~E9-a5KedY&(AZUr@I6dH?_b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST new file mode 100644 index 00000000..1912c143 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: notany ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Sept. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-notany.test ;; ;; ;; Syntax: notany PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: notany returns nil as soon as any invocation of PRIDICATE returns a non-nil value. ;; If the end of a sequence is reached, notany returns a non-nil value. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test notany - If the end of a sequence is reached, "t" is returned" (and (eq (notany #'+ '(2 4 6) '(1 3 5) '()) t) (eq (notany #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) t) (eq (notany #'list "abc" "cde" "" "efr") t) (eq (notany #'- (vector) "" (make-array 3 :initial-element nil :fill-pointer 2)) t) ) ) (do-test "test notany 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (notany #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) nil ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test notany - with 120 sequences" (let ((a '(1)) ) (and (eq (notany #'nconc (list a) '((2)) '((3)) '((4)) '((5)) '((6)) '((7)) '((8)) '((9)) '((10)) '((11)) '((12)) '((13)) '((14)) '((15)) '((16)) '((17)) '((18)) '((19)) '((20)) '((21)) '((22)) '((23)) '((24)) '((25)) '((26)) '((27)) '((28)) '((29)) '((30)) '((31)) '((32)) '((33)) '((34)) '((35)) '((36)) '((37)) '((38)) '((39)) '((40)) '((41)) '((42)) '((43)) '((44)) '((45)) '((46)) '((47)) '((48)) '((49)) '((50)) '((51)) '((52)) '((53)) '((54)) '((55)) '((56)) '((57)) '((58)) '((59)) '((60)) '((61)) '((62)) '((63)) '((64)) '((65)) '((66)) '((67)) '((68)) '((69)) '((70)) '((71)) '((72)) '((73)) '((74)) '((75)) '((76)) '((77)) '((78)) '((79)) '((80)) '((81)) '((82)) '((83)) '((84)) '((85)) '((86)) '((87)) '((88)) '((89)) '((90)) '((91)) '((92)) '((93)) '((94)) '((95)) '((96)) '((97)) '((98)) '((99)) '((100)) '((101)) '((102)) '((103)) '((104)) '((105)) '((106)) '((107)) '((108)) '((109)) '((110)) '((111)) '((112)) '((113)) '((114)) '((115)) '((116)) '((117)) '((118)) '((119)) '((120))) nil) (equal a (do ((n 1 (1+ n)) (buf nil (append buf (list n)))) ((= n 121) buf) )) ) ) ) (do-test "test notany 1" (and (eq (notany #'identity (vector nil nil 2 t t 5 t 9)) nil) (eq (notany #'identity (list nil nil nil nil nil)) t) ) ) (do-test "test notany 2" (and (eq (notany #'lower-case-p "twinkle twinkle little star !") nil) (eq (notany #'upper-case-p "twinkle twinkle little star !") t) (eq (notany #'evenp (vector 1 3 5 7 17 35 17 39 97 77 91 )) t) (eq (notany #'evenp (vector 1 3 5 7 17 35 17 39 97 77 91 -2)) nil) ) ) (do-test "test notany 3" (and ( eq (notany #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) t) ( eq (notany #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 7 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ( eq (notany #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 22 (3)) (4 5 (6) 63) (88 17 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ) ) (do-test "test notany 4" (and (eq (notany #'<= '(100 90 60 50 40 1 2) '(95 87 43 30 35 8 11) '(5 9 40 25 3)) t) (equal (notany #'<= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) nil) (equal (notany #'<= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 20 3)) nil) ) ) (do-test "test notany 5" (and (eq (notany #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) t) (eq (notany #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(5 1 1 5) "eefg" (make-array 4 :initial-element 'character)) nil) (eq (notany #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(4 3 1 5) "eeag" (make-array 4 :initial-element 'character)) nil) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2345bddc9b669ff25014d3b6d27acf17a2786eb2 GIT binary patch literal 8827 zcmeI2dvH|s702&mck?797>FQ`%S$n`n7et9pjI}UWwT_n8+SKCP)cL6VYlRg$wo^Z zEOF}i=vs}b>AhH5ZMACE7T;1IXsx#RXlvCXT5YwXqklM~(_uPHrSyD%=U%uWSeX(2 zE5kj%&+qp;=XcKUaqm5MVN`Oj4MeoSK;Py}Z)#8*7|w1U&T2gagWAx*@L*R;>!Eh- zia;zL+}i99v@APEFHAUkx&~97*;Kcd98L{&cWzm#=?$8H^I)czpuV1}`iffLikg~b zg{%CD2#@xqHe{f$@afA65A7J2O9v!L>XLS&D3GL5NtKM7bETEZU?S;V6^;bGQGaW& z(ik;z`7{@Adm&S zaMasIQ}c&{l9F$Yg3)CoSE$!`ecos+8N4tU?~rzk7hWYvdHMa4G;f`V=!x``E%L5@ zS$e8PS)%BKPVc;IVyoSItTJ6#BuoOwHYs$A-o@OT&t7^}s;24c zRnSj9N7LIfPg29QtMX>Z>0KL2cE?Jn`srxo##qU7=)Wdb(xS*y2zOSjSzt#(1CsUb zOxL0b)7xiHFF(EdV7as#3jmXHX?3|`+n&s_a27?idXHGsmrvZpTnp@p70~L?@xmO^ zvrgtr{y#Ra@`+xDLK=|nv}G7~6P@?;hH^Udy#t5FV&yw4V&$=t^ej5ANL*N`hk6rijEv4++6A0gu3(Sel?G7-S${K!9(WL2kR#^(4w3^ zp@B3oQ|q*gAh%_x( zZF}SgblovKDA?J@?7-voL`Il5$BuBS9hbAjL!DxYINQLzE{cx-Zi0^Wa#;99dbIvL z)N#j7do$x$Z->!zX{J*Gc(WWrosorLPv?&sddmF>l5)CCPl@hZ+DWt2I zt|Gb$=*p+dLzkOgCwq_nH-` zy~4Gpxwb=$=iV;Hb6?NnZD5rM7Y$rYWzAxt>H1t~x?Z7;EnRF+#G9baj0DMx>jg2q z>q+xe)E?p5yx`}tXOJJ*USnp^?2SPMYlLtsJ%|vq$i3)6G8QPb2f@cNv9yt z?2r2c$soq_JVbg^!%@0H{1I<35^SYYh4xWuFQx=G;%$qCqn7gb%{l1%o;erAeDgFE zr}EGRqHupg9+a=0M;-3hO%25pTzp4pyDww4jiPXUCK_EIacv(L&(RRBSW{CQS-T!I z=cBlt+KMBwHFWoiLoNDlG8dpP$%C}8^|@RuBZK^K6U`=^#JP6OH5XE$zAuzjcBQ^3 zl;t-_*&U_(CO|5(DOBW}xNk%h(leq_dW>s#bMZrS9vMhuVm+kq(kQaGhombKP9&>Q zt(*gS7PR(~@a#8oQ?sd|tkyq}rR;xji&l%~&y3u>B$^jo>0hArbkb){x0dPWFA}s} zxfp8q8#z}h)wvOTk1^(Qsj?eCky4n%$2*P!7xLc1q+$|>~T(dznS6CtTVM26+McZ2&>C245 zZwx2R(=nsNPs9vOV<^+pk13@{U$v&udEC=jf3l|$GHx}-6ngm24a9@~WYBxmJ0KFK zJJ=sdm_<;d$z9M+Uyb5Od+H}0$r{YG#;l~m{cmH;?OwN}Tt($y##r8lb!U|?%*X4* z{ZFcPuRGVbL{?CJAF2iGW(w7Jp}HnvtG+c+b&pV8!m7^;)wAYWqdq%P^-eK0^CAk| zyjVo+9-kC(HT>Vq5tF9d7*l11UZ5&Y9o1xyhnm)wbz!^5@ZOgFhrh}3HI2qG*&H^9 z*$)*i#gk_aW8gK;N@84cuk_D8jyp!N?ij_sTjrL&&Tzb6J)DZkdrm)n9QEMzVJTf=&s}?rYl~&o zomaN7?2OLVi>^9!=+Hsxc0E41{Xb~G%gCLYrKjYk-jr4JX0q8{dIEP2qMuIK9IHdK zOV-e!qKS9XwU=zZyPB<&m!a6DRvXL6r46Mn9ZvOkrG{uYb-!?=?x4LwKB$iJrs2`0-oV@kzK*#Ud^PhX zFg>Ml>b?oy%A5gjVNQdsgMinGdMUT}fay^R+Y~s%+zn1KcY!;ZF9EM-?gV!*e*@gk zya9Xx^Vh+x%8vBpHDEfp;0wWC=63Lz%*ce) z#moutd}d@$>Kx_^z%!YVm8jF1W8gC8D7cWh6S5~fLUJAaN89ACV!i+bcvX%Kv@D}DJ;9=%7z?U+g4(?+{ zqNZe+7lBjE3&EYtNL!Wl%y^V29n2cIof(;>ase~aZKaiY4miw=oL&hsBNtcv%(KAf zG0y}yFypI8sb$7jnW8h}Q%~_SPY0jLTn=8$d0G0_cP~#KV$ZQKVe2fEPu@G0)N1atVDi~ z8R?4rwn8O9nJe!!a-|cWxf)KFe4lv2%2ya;EtExgf{|8Vt!`#*u5oa+gMALx z9b9#U^#%vmJ9xQ+>m2Oxt2_Ma4!^p?ukP@xTYlXXzvUKac?DWdftF98P( zmOr4wov+sCSRw~kJJ{!7-N98ySZ{D}y@QuKxX!^2zj}?M-Qibv_|+YLb;~cNVz~uc zUV)ZVpyd;2xdd7sftEv{NfY-?4M)?u#YaVZIAi(7^6!$Q7dYxx`& zKFeYQeZ>f^9|`%0kbkf(bccmb7KhvG9K4);<9kL}?-24)A^&JwR5?bfvV7xvMQHt4 z$j5~IlVzbdkOdYpVUPP0(f_!Rui9GmN5<9bt#M=axVH)2T|)lZwpebB+hUJ$FblfB4Z-jgs4$rX7e<9kQ6Y{T?xxG6JjWLhtxL3&E z3i*zuWNi-IVQ=hKI+PfHo;{)agwgXtzH2F2y9Co(YXMHPADr}`+ zitgVD`FBgn-l9`%rC*8e-wXMkrDX5WR9k7M=-wmb`<4RP=@NU|X&Ba&oA zlFUew9Z51INtPtZl%%lr30t4A^$A;_u=NRBU#%QAXY!8|(ub3BA!)CXYnqq~d9`ql zmQAO$RDZWN(4%!8{tVSJLmK_Bi>`F4d#Tn>|ID!pA7=B);9Wo8BJbmH)LuoxVSADZ*Gsa__kAw JO2?r?{{=YL#!LVJ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST b/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST new file mode 100644 index 00000000..06096cd3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: notevery ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-notevery.test ;; ;; ;; Syntax: notevery PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: notevery returns a non-nil as soon as any invocation of PRIDICATE returns a nil. ;; If the end of a sequence is reached, notevery returns a nil. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test notevery - If the end of a sequence is reached, nil is returned" (and (eq (notevery #'+ '(2 4 6) '(1 3 5) '()) nil) (eq (notevery #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) nil) (eq (notevery #'list "abc" "cde" "" "efr") nil) (eq (notevery #'- (vector) "" (make-array 3 :initial-element nil :fill-pointer 2)) nil) ) ) (do-test "test notevery 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (notevery #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test notevery - with 110 sequences" (let ((a '(1)) ) (and (eq (notevery #'nconc (list a) '((2)) '((3)) '((4)) '((5)) '((6)) '((7)) '((8)) '((9)) '((10)) '((11)) '((12)) '((13)) '((14)) '((15)) '((16)) '((17)) '((18)) '((19)) '((20)) '((21)) '((22)) '((23)) '((24)) '((25)) '((26)) '((27)) '((28)) '((29)) '((30)) '((31)) '((32)) '((33)) '((34)) '((35)) '((36)) '((37)) '((38)) '((39)) '((40)) '((41)) '((42)) '((43)) '((44)) '((45)) '((46)) '((47)) '((48)) '((49)) '((50)) '((51)) '((52)) '((53)) '((54)) '((55)) '((56)) '((57)) '((58)) '((59)) '((60)) '((61)) '((62)) '((63)) '((64)) '((65)) '((66)) '((67)) '((68)) '((69)) '((70)) '((71)) '((72)) '((73)) '((74)) '((75)) '((76)) '((77)) '((78)) '((79)) '((80)) '((81)) '((82)) '((83)) '((84)) '((85)) '((86)) '((87)) '((88)) '((89)) '((90)) '((91)) '((92)) '((93)) '((94)) '((95)) '((96)) '((97)) '((98)) '((99)) '((100)) '((101)) '((102)) '((103)) '((104)) '((105)) '((106)) '((107)) '((108)) '((109)) '((110))) nil) (equal a (do ((n 1 (1+ n)) (buf nil (append buf (list n)))) ((= n 111) buf) )) ) ) ) (do-test "test notevery 1" (and (not (notevery #'identity '#(t t 3 t 2 t t 5 t 9))) (notevery #'identity '(t t 3 t 2 t t 5 nil t 9)) ) ) (do-test "test notevery 2" (and (eq (notevery #'lower-case-p "twinkle twinkle little star !") t) (eq (notevery #'lower-case-p "twinkletwinklelittlestar") nil) (eq (notevery #'oddp '#(1 3 5 7 17 35 17 39 97 77 91 -2)) t) (eq (notevery #'oddp '#(1 3 5 7 17 35 17 39 97 77 91 -3)) nil) ) ) (do-test "test notevery 3" (and ( eq (notevery #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) t) ( eq (notevery #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 7 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ( eq (notevery #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 17 99) ((a) ((a)) a 'a) (2 6 7 a) )) t) ) ) (do-test "test notevery 4" (and (eq (notevery #'>= '(100 90 60 50 40 1 2) '(95 87 43 30 35 8 11) '(5 9 40 25 3)) nil) (equal (notevery #'>= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) t) (equal (notevery #'>= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 20 3)) nil) ) ) (do-test "test notevery 5" (and (eq (notevery #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) t) (eq (notevery #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(4 4 1 5) "eeag" (make-array 4 :initial-element 'character :fill-pointer 1)) nil) (eq (notevery #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(4 3 1 5) "eeag" (make-array 4 :initial-element 'character)) t) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL b/internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..296f84e8eb4ebd943809543aff85d51155a301bf GIT binary patch literal 5112 zcmb_feQaA-6@OoL94Bd#tshC&b+26m!NpmVrXOopQP+7%oH~A~pPe*iWw?nOyM3|K z#3|j%wo-NTn7ouUS^I8Tnb=?&gFi}&5bH*}iHc2#p@BM>I<%p|#88J;fdmLx%{lkj zv6ECQe^l}Fxxe4}zW2U+oe9CV!|PYQ$)Vx6868oRW2xb>l)5K5qK+oVM*5@b9^lnO zUOlKi*x~VRYuwc2G>SC+Bhg4II-rKeqN4+m`#-NX-K~0tN8%<7Hf#Xcv~g|o#+H^w zXPd|HQ?wiUfCIR#YjkE$pAf5(f*|w@7f_T6LX{v3*6~c0E2J4Acbm_zxdWaq&1Fqk z83**@4jWp~%2YS2spPQRj2?)Z*v`Uj zJnfnwIdV}jx@cv}np)h=?x5Bh_G-fE6V4-oVEYeNaxV5#r}$z*y!Yi!sdrgjwP+jU z<)N-Z5X_3~Gd~nA&*Fyuh1|sg2cvkoAPikY{srP=;Jg>HRj|W&GIB>|aR9DPo3kj) z{>$l}0tX{ZLHs?lcmOjRb(SU$2tH1G&hc<;?%zwGzU4^CLNWH@`2dWsPHcN3@H0V} zh&>wUltd_a;>?m>71QG5;HfUe`&aN)%*~xto}arC2mworrr=7&b`fVPpuh=GveO$1 zW-!_Zk11i1Ft|EhJ4Qkp`OT^K<$S#k$`u1)%8&?FXF69ea@fGk)UGMm&f;_R z&auzl#CqlR`FcxpHNZUX%}y^Xpnch=3ScjvteY}bN<}_(1vcHk^a7>nT{^SAxO}j* zy-PvP-EhbC`xZZ<%aek}# z;*LX6`DU@7c>dkWP7fEUOc?-1E~xdnYSWJXdAnSr+3EW0+VNPqIm>OW!?ByP!uG2C zbd>KsAG@#aLckozPU>}MZq@4ou{x*=xqX+;pZTz8N}x!y3BNWKI>a|1KR0F@D!0Se z(7D1|w-#G00+5i8!gsu2p<<(aE1AupFfj_mfh$xLRyz3&bJ8ZE>Or?24t0k^F1Z?P%Uzy8pPTcBi@`Nky?*X(xIhsErr;g;MZD8KhDi1{ zJ=o<5A^Zp{@rHvzEl_mFG7)v}fNo)70=ynWqg1R6)h}Qqx-bzw&T3GM0b6PGb#2xC z?)(Lee2mlvt3}jCXdR)I7|GM!tp!>^sr-#CLh&(MjN(1E1jQNdp)l^DWC-miG(adw zNF%hKPy?Ym3Dsey9?culgAi2yBhMuNfoGE6*3mggOarCbWT2 z6$NwhVA3Z%nDiDmk$%lhq}K^uBy^6@j|n}=-KFE?euUh^WJ38Q$|p6GLp|y02vriY zb0mJigNg6+VB&9hF!4EVBAz0XaY7Fg8X=Tqx52!Kdx_jdWDlXW6tkIPuHZ3+zi<=b zcicqy1)-l3q9qf)OUNSK1ffS*%|onqKdXUMUt%>oS#1}q*~)6yvYJL#yPVZPTX87G z_9m>Djc;&7ufgv+djNN@AK_2f?I^wjtkV~O_tfKe_jvqa4cVuGm1#@aPQln_ggimM z=^p{)Xbb9H?wtBzwhTQUV0WMxfs_jDdjr94Qtcwu4yGd6jTU~N!J};<)h1G{0hQ8supbPs8hN>-E7Y#VXP0DIQxs$z#jMc_?|D2bLdY zE70U1y1O zdnA6v>LIc8D(^!&3ysO`UOXkFgJeETb^{~=JigQpb|pqA2Qg8FKI_!uz}^;axs!!X=(bc#W-w5`~MTJ4fUX z$mAJ9<0Kwqs}HgILFiN5+{@~HZ21@1%2jOT5?1ep5VjAkj58G-O{pW%fid_;uo=le zS(!URNUnIuvqIeyfqxDM)OdpauS4!3To~Kb3Bj?&9Qdv0Qk7t3ZZji8y9Xj@H}4*T zS|xrDS(B2L5qH4T2b_RWp0K7C3!)?|HhYPqw4$usxuCMD`j%T4f>J(;7W>faQ$I(t z+3dNt_6}d?Hh)(@$JMm?fV{R1M#{gfZ=(D0%rb9K^Mo|_oO{g=TQunL8>|e?U`K2Z z>#%A08+>KX{4`;}KeII`&ZbLCP<}t{aG*Sv#yUR1uYV#==lH?21G#@7cVD`6M&FTc z!13G2uSy?mK)EO_A$JYO)f5l!W5t;kB$TC`%c4ydv8{l)kC+zGPQJo>W*T(F+ITDS z@8`6FTS$JJw<14hP1#|BO4@^Z*xS*^Dsd0C>Rvu5+3GPm+QNPgY^{2?Mh12xplLf{ z%sz{u9=4{WnGb7#)1oun)s1SMb+hegvdfxsKxDh&*EH0?c(xG>GJ|~%O}EU1ni;S@ zwv%F^85%WOlO^-nn)$t#TA5JsHg~IEiA57?Di&2ohok-RJ#pCKqhq^Aqx;9A33w0U zqiS?$ICZ}oNerloq`EPlh^OKa(|sUfj&b#1{6I8;McDWhN~h;#mBy{i_8VutZpujF zQ&LKgQ_3BM4fkKDMA|+FZ?Pt25nmlyLG|6UVS|;ioAFf2jG}URF%theuNm=OE3@nW zZ>B$)NJZj_Q8k%}s!=mK6iuXVJeT5S-k5kADuum)Cv6k#pSxHilqensmW}1nm&YSW z_Q6@g2b<@Y+-PN5W|hoAe`GW|s`e*`an1LPB!|@D$RM12Yn#;M9@Xnl;m-@v#VZj$ zg4q+{;j;)*p_BKrHL2j41(w1aK+k;G>OB2Qk;z%m&qU!)&lhR=>BM8?eW!}FUxT0T dZ1oU)%kVbytW7z2drpe8TNh4YStqmE{{ceZlZF5Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST b/internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST new file mode 100644 index 00000000..3402dd19 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: reduce ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 251 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Sept. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-reduce.test ;; ;; ;; Syntax: reduce FUNCTION SEQUENCE &KEY :FROM-END :START :END :INITIAL-VALUE ;; ;; Function Description: The reduce function combines all the elements of a sequence using a binary function. ;; ;; Argument(s): FUNCTION - a lisp function which takes two argument ;; SEQUENCE - ;; :FROM-END - t: the reduction is left-associative ;; nil: the reduction is right-associative ;; :START - an integer, used to specify a subsequence ;; :END - an integer, used to specify a subsequence ;; :INITIAL-VALUE - an object whilch is logically placed before or after the subsequence (depends on ;; the value of :FROM-END)and included in the reduction operation ;; ;; Returns: anything ;; (do-test "test reduce -test cases copied from page 251 of CLtL" (and (= (reduce #'+ '(1 2 3 4)) 10) (= (reduce #'- '(1 2 3 4)) -8) (= (reduce #'- '(1 2 3 4) :from-end t) -2) (= (reduce #'+ '()) 0) (= (reduce #'= '(3)) 3) (eq (reduce #'+ '(foo)) 'foo) (equal (reduce #'list '(1 2 3 4)) '(((1 2) 3) 4)) (equal (reduce #'list '(1 2 3 4) :from-end t) '(1 (2 (3 4)))) (equal (reduce #'list '(1 2 3 4) :initial-value 'foo) '((((foo 1) 2) 3) 4)) (equal (reduce #'list '(1 2 3 4) :from-end t :initial-value 'foo) '(1 (2 (3 (4 foo))))) ) ) (do-test "test reduce - when the specified sequence contains one element and no :initial-value is given" ;; ;; then that element is returned and the function is not called ;; (and (equal (reduce #'* "a") #\a) (= (reduce #'- (vector 4)) 4) (eq (reduce #'+ '(foo1 foo2 foo3) :start 1 :end 2) 'foo2) (eq (reduce #'list '(foo1 foo2 foo3) :start 2) 'foo3) ) ) (do-test "test reduce - when the specified sequence is empty and an :initial-value is given" ;; ;; then the :initial-value is retuned and the function is not called ;; (and (= (reduce #'list () :initial-value 3) 3) (equal (reduce #'evenp () :initial-value "little") "little") (equal (reduce #'listp () :initial-value '(1 2 (3 4))) '(1 2 (3 4))) (= (reduce #'stringp () :initial-value #c(-3 -4)) #c(-3 -4)) ) ) (do-test "test reduce - when the specified subsequence is empty and no :initial-value is given" ;; ;; then the function is called with zero arguments, and reduce returns whatever the function does. ;; (and (= (reduce #'gcd ()) 0) (= (reduce #'* ()) 1) (eq (reduce #'+ ()) 0) ) ) (do-test "test reduce 0" (prog2 (setq a '(sleepy jumpy grouchy doc bashful dopey sneezy)) (and (equal (reduce #'cons a) '(((((( sleepy . jumpy) . grouchy) . doc) . bashful) . dopey) . sneezy)) (equal (reduce #'cons a :from-end t :initial-value 'snow-white) '(sleepy jumpy grouchy doc bashful dopey sneezy . snow-white)) (equal (reduce #'cons a :start 1 :end 5 :initial-value 'apple) '((((apple . jumpy) . grouchy) . doc) . bashful) ) (equal (reduce #'cons a :from-end t :start 2 :end 7 :initial-value 'witch) '(grouchy doc bashful dopey sneezy . witch)) ) ) ) (do-test "test reduce 1" (prog2 (setq a (vector #c(1 2) #c(-1 -2) #c(-1 -1) #c(0 2) #c(-3 1) #c(2 -2))) (and (= (reduce #'* a) #c(120 40)) (= (reduce #'* a :start 1 :from-end t) #c(40 -40)) (= (reduce #'+ a :end 3 :initial-value #c(9 -9)) #c(8 -10)) (= (reduce #'- a :start 3 :end 6 :from-end t :initial-value #c(8 8)) #c(-3 -9)) (= (reduce #'- a :start 3 :end 6 :initial-value #c(8 8)) #c(9 7)) ) ) ) (do-test "test reduce 2" (prog2 (setq a (do ((n 0 (1+ n)) (m nil (append m (list n)))) ((= n 100) m) )) (and (= (reduce #'- a :start 49 :end 59) -437) (equal (reduce #'list a :start 70 :end 81 :initial-value -70) '(((((((((((-70 70) 71) 72 ) 73 ) 74) 75) 76) 77) 78) 79) 80) ) (equal (reduce #'cons a :end 21 :initial-value 900 :from-end t) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 . 900)) (= (reduce #'(lambda (x y) (+ (* x 100) y)) a :start 50 :end 52 :initial-value 2) 25051) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL b/internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..77aa73b1992aa76d54047f9011457eaa48c59ee1 GIT binary patch literal 8387 zcmeI1Yiu0V702hb>$hVkPD~7#sq6Z^cQ>D$ty6wcU`APRzhe=fhXHx@{R<1u|!oDqxl`*J1W zn70R^`9ncL%C}mf)chFmnjy6BbldfonLC#o-fT57O}~u^P3d9xK^ECJ1Qfefg#)-&dg+A zKz8wgyb3Y%?5@(|@ls?@9gf@=FMW~f?}?XoOJWJ|>B{Y@-HCj*KAs(_aYiQo$&M^P zv*n8l;W))kCKbY#3dy#;oM~Z|AROQFG7sm8OBa~@dpod#`D1xGWBGsE=C-()aVSg+ z!uXQs&Rn`FS2oyFUNSf3v<))%&C8FH*Kdy^PJ$R&^oUmd+OMla|C(49Jl2y=bqY&WI-?#I;%I)>H8#Fa(BiPQGbfEPmtF@Zz2(lIqm|6NOcdQu3|3W zfIk^DT^U7Gy%#Mhbg)xqh^_%qe|OO9PbB>PROC07QnJxlMoBg2Tz@wfBj@_iSVGBP zj0#GgGV2~i8;g?t(e`-6Yu_=b`T?{0+eRhj?l5zsX0F?8ugh$&#cZ#HRg{04$-8Fq zE7nwg!J5hsSyS1MNiAMQL3opx#0bTrjC0ex7eB zC%nXU!oy~r&ciL-V^n_ASei8|cNt5YjLLP!Qq`!u4)M6}#VEUY#Zc}pTNEHW+t0~EviPzL#X{s&dL@~Hfx!=s)WhS?viTpr3+7k)(^`Hf1fP>f; zjBzfETybwt4|XFjQZ8&URA|co;r8TDxgq&|GkJsB3wI!faEjKd{G#y{O71b0?=-b0 zI1&E)XL+rz^AHM;q2!Xm%{XM}R z86*cIDX5dPjzfc#XpUZcsn?3x>uWE%*Q+i^uZsz0pHN_dc02NFSlD(F4uc^(O4gZm>%qlnZH z+}7TBD#%OP_5QrY*?@_2{nc1Q$&>o5%QdiexlEbI_1U~#1J_lo$fsk$^?hWA2R8WD ziV|h-C)I)hQ#D7b+mp8H!TGAUv#QnV6sw+Xbz;71lEX6k&}pOJ>}|)q-qw@v&1P>4 z%@Gj&XWww?-PAN4BRw}9>$9>*r=$!}kP}fT_eFx@`q9ZQ@Y$aF>po@fD3WyVw0Ad7qG>B0G?0b>!P10#VH^JwC zEd-wd!UUfHx(Gf7ga|$YbP{|3pc|+39-xEZ9YBEKEkHZLNr0c=b--qV*8n#VyaJ#* zz4Q`*?pM-p0UHQ@16WV+9H5Qhmw;A+V}KTdp8=W)ehg?LcmhCo5a}@hJ@2JQ0rV)9 z9s;w*jstm;|gP7zfbl zBHavFO)vtW%Z{`Mu##XWUV0SX8{0pt^W49Fw+2;e6806@1r@jZY- z@D4yGcnd)1uXqw55~pZ@;JP{1S{>Zt;ARImIoRP>bNJO9el>?*&EZ$G{JPM8%PpbhmC$lZX!#_xToPIy z2`z_&mOny=J71&EF+>iocd*aFnuF`+SZj4~i-VgT+~i<~U#-DW?(nNQ{Av!rn&p>5 zvD^|`UI{IygqBZ2%O#=Zk_xbrpEJBG-?^$zwqSaWdQ9BZu(ZgFt4gPR=e z@T)aA${l_+hhNR%SF`+5D3)77%PXPfl+f}?Xt^Y`JQ7+C2`ztw>uU&31R%7He2{Gs}Kk z%jdB0Sr!Ahkh9iWmVTB4wuR=f&|q=4yvf1MrtfXG?`ye@c9u8V7Ilu6>MY-Q)SF}F zVch`Bn=A{h6&5s*I0wv8xQ^>PSnja3TISl-TC8?)V3_T$W8EOjowh}@)o!QVu9xdO zS?;p6njGymS?#vl7PYJ!V!7M4pt(KEmc=H!C)cxX7t29g%bw>pTdR)i!z}mMS~Slz z4o$X}#`RlR4%u2Xx1@z*&m1iu*LSlVwzVAdsnL9r1O!@lbs=wt$I%G)9P5l1`H!eSV6)J5_XUIa3dqOa+Z z$!Qer0}c(R@fA)U+%wdVH}L|Y7c#$KE4|9+Mcml>test>14-2-some.test ;; ;; ;; Syntax: some PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: some returns as soon as any invocation of PREDICATE returns a non-nil value; some returns ;; that value. If the end of a sequence is reached, some returns nil. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test some - If the end of a sequence is reached, nil is returned" (and (eq (some #'+ '(2 4 6) '(1 3 5) '()) nil) (eq (some #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) ()) (eq (some #'list "abc" "cde" "" "efr") nil) (eq (some #'- '#() "" (make-array 3 :initial-element nil)) nil) ) ) (do-test "test some 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (some #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) nil ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test some - with 100 sequences" (= (some #'+ '(1) '(2) '(3) '(4) '(5) '(6) '(7) '(8) '(9) '(10) '(11) '(12) '(13) '(14) '(15) '(16) '(17) '(18) '(19) '(20) '(21) '(22) '(23) '(24) '(25) '(26) '(27) '(28) '(29) '(30) '(31) '(32) '(33) '(34) '(35) '(36) '(37) '(38) '(39) '(40) '(41) '(42) '(43) '(44) '(45) '(46) '(47) '(48) '(49) '(50) '(51) '(52) '(53) '(54) '(55) '(56) '(57) '(58) '(59) '(60) '(61) '(62) '(63) '(64) '(65) '(66) '(67) '(68) '(69) '(70) '(71) '(72) '(73) '(74) '(75) '(76) '(77) '(78) '(79) '(80) '(81) '(82) '(83) '(84) '(85) '(86) '(87) '(88) '(89) '(90) '(91) '(92) '(93) '(94) '(95) '(96) '(97) '(98) '(99) '(100) ) (/ (* (+ 1 100) 100) 2) )) (do-test "test some 1" (and (eq (some #'identity '#(nil nil nil nil nil nil nil nil nil nil)) nil) (eq (some #'identity '(nil nil nil nil nil 3 nil nil)) 3) ) ) (do-test "test some 2" (and (eq (some #'upper-case-p "twinkle twinkle little star !") nil) (equal (some #'upper-case-p "twinkle twinkle lIttle star !") t) (eq (some #'evenp '#(1 3 5 7 17 35 17 39 97 77 91 -2)) t) (eq (some #'complexp '#(1 3 5 7 17 35 17 39 97 77 91 -2)) nil) ) ) (do-test "test some 3" (and ( eq (some #'(lambda (x y) (member x y :test #'equal)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) nil) ( equal (some #'(lambda (x y) (member x y :test #'equal)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 7 99) ((a) ((a)) 'a) (2 6 7 a) )) '(7 99)) ( equal (some #'(lambda (x y) (member x y :test #'equal)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) a 'a) (2 6 7 a) )) '(a 'a)) ) ) (do-test "test some 4" (and (eq (some #'<= '(100 90 60 50 40 1 2) '(95 87 43 20 35 8 11) '(5 9 40 25 3)) nil) (equal (some #'<= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) t) (equal (some #'<= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 25 3)) t) ) ) (do-test "test some 5" (and (eq (some #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) nil) (equal (some #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 4 1 5) "sian" (make-array 4 :initial-element 'character)) #\a) (equal (some #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 1 1 5) "sian" (make-array 4 :initial-element 'character)) #\i) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8cc60703573065c083e4ca664880388e03228918 GIT binary patch literal 4796 zcmb_geM}qY8GrB2=EFcR%!^52^nw9VziyWjhKywCG{-h1BnE-Vt~5r0VbXUB8tj5#T1XQp#A)ACq$Ql84rOpcoJ z80h6k{kox@8BqO$d%HVakrK=3q?wpDlX7&%oJuBUKPPv5K~{5<=?o0+y%)re16`d5 z_U+s2>Qf^j9__!*feD=ly7upNtzBFZ+*v}%D7lVMO^BOF#9GR`eNinERr-PNia5{qbtm2c>jr?WXFV?JVLu$=KJA`oIdnXl@Lh5gZ>9=4W+b3(0kAzv2^ zE5lHl+OH9@%8r831uMV3W1n)563{|gR8s=6;ZV@8f{9#QsXI@I;|7xYS?cN`;iU=k z>dS}3!>v0T1gA|E;pUYG5l#@2t|5eLg0=>fP!Qbtz~wABv~TTzL0px#)43G>y9&C- z^OYVU_0qL4jNe@xd?Ne{LKahB4<8bRIv8E{9+oj4UR8wD5^_B~+QydCW-k1sz`Qbb zEp^O&J$0-RE>B^}ui;c+3YNmCu{bJvq3Pz82arWZD%LunyHQbBRCMW$s1Wg1yIyjO z?pasEsJze(r2;kP4%J@JJ*?b$-E-UZiW7x;Yp_bJwoq5G8e0cU;1_By^6zAs%aqNm zD6WKix>#4)GlHnhlM!#Ui8tOp@qZPF*A@tK>W~u^MUp#M7F3n7De0Gw$;I)j0v8wN z`KZeUZ3o%-T0?h1kF~%$U`N4&Wa#F2jZ0_+;_$oG{Pu*e1z0 z{>J?P3x;u7TeaA2)xz6qDRp`KRtLah%AIx-(PcfAZ}Iu{a3F|>qB5X{10l^&dV`<| z_eXqUEv*)7;Hren36}#--v%EXgZ=@<(4sK|PES8Oek&sJNK_jVh0PvO-A8MrdRi^H z;l$nM(+op56g?IljzxV^15Bv(so}W7^bsG0qqm`}`~2j0b;|Z zR{&a6u+&H5L%n)PDZExtuh35;_~>>7FZCkS(fW; z+b(h2Du+exvcO#?xXVdyOK^w)t17=f99JUR2&NpOI}kJu_i?zBMG*f=8^I?2g?0(OEGD_kVv<$rnWEl@Xwz}p6sF!ov`M8+ z3iUQq@BL7t<0)7rCu=v9^6+I)5yoB$p?HQiBZNRJY2g5l2Vm@sL{)<|TY!B@82XT6 zn-Aim2Zz-DVcVk{=MHLdoVyRk4*a4(p^>&C)Y3Z;s;P`1(p>=38%!zvo++i*xbnMP z`5aeXghax9==?M{pTNw92EEHOOG)ndW!i>bUt(V3t8^zw;?G%O;uQ|hGAiOTSPc7| z3hPKw{099j!a+W#i#xY-@bEd?*z)0)LC+eNMEHR221)oQm;MYcb^Za>P}tT&%bVQt z7z-?Xl|>ZBIUHtz1%tMr=Meo2LN}K_&!yd5@-T_4uqb4KO(*AR^8{^8K~9HX4Hzbs zkJ0v{bXPyUGeG5ow7r||+Cy6-5Y_R#m2a9hr>5nknK7qLB{`GJq(|X9c1pen?U$_l z9Z|HmomJc9u>^bqC*|}6|9VB;S*+8Mp07W@20u79=jU$p5Hi>E2SQLz%u7{>56;i^ ztb+djb6g(>nfcjrY+fwJ*uO$*df<(x!nNimR=zot7(bp&VCqeWA%SIQhoQABT6y6J zTye1i%9qsMh)C}OJLYdMAI9;AiJ=Wg)wrFS;c zlm5o(Nx%DKDg3g8!i_QtFPBmH>3jvgGo%-7Dwj8|l=RJ#SdW#(`dV46Gj^<5JJt;N zuda84^zizsOKl}_@#&N<)6TNE+wHiGcHC`caqB?t!EUsdxnez!_^$N~w#-t#)eolz z{I{m;y%-8cHA4+WXbrl-AvqG$qZ&U7-n{k3>4Y^CU#EKzeqb#-tz}6NB?#ewp&(kz zj_N7|rzlE-1HHbpLh6g{&Ob-~&z7$UY2p6pfJg@k>w0mC5wJ4~z=CJB*+>H0auSkw z{F5O;2iKF&SiAQ;p(P>$d9aiJA1Q?CZ7GY$ld62T?vtgwpwd$ay&U`;0vt4Y3KCVaDc@rE$Jsq!GJb-M`F)`kf-;$VZ}wa8 S{!j6Qjmu1)#>!UK*8T&VECv_= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST b/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST new file mode 100644 index 00000000..8adae10f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: delete-duplicates ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Oct. 1 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-delete-duplicates.test ;; ;; ;; Syntax: delete-duplicates SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: The elements of SEQUENCE are compared pairwise, and if any two match, then the one occurring ;; earlier in the sequence is discarded (if :FROM-ENT is true, then the one later in the sequence ;; is discarded). The result is a sequence of the same kind as the argument SEQUENCE with enough ;; elements deleted so that no two of the remaining elements match. ;; ;; Argument(s): SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test case copied from page 255 of CLtL" (and (equal (delete-duplicates '(a b c b d d e)) '(a c b d e)) (equal (delete-duplicates '(a b c b d d e) :from-end t) '(a b c d e)) (equal (delete-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr) '((bar #\%) (baz #\A))) (equal (delete-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr :from-end t) '((foo #\a) (bar #\%)) ) ) ) (do-test "test delete-duplicates 0" (let ( (a '(1 3 5 3 6 8 9 4 2 0 3 4 2 3 1)) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (delete-duplicates a) '( 5 6 8 9 0 4 2 3 1) ) (equal (delete-duplicates b :start 3) '( 1 3 5 6 8 9 0 4 2 3 1) ) (equal (delete-duplicates c :end 10) '(1 5 3 6 8 9 4 2 0 3 4 2 3 1)) (equal (delete-duplicates d :start 2 :end 12) '(1 3 5 6 8 9 2 0 3 4 2 3 1)) (equal (delete-duplicates e :start 2 :end 12 :from-end t) '(1 3 5 3 6 8 9 4 2 0 2 3 1)) ) ) ) (do-test "test delete-duplicates 1" (let ( (a "sneezy SleePY grouchy dopey jumpy bashful") b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (delete-duplicates a :test #'char-equal) "nzgrcdoejmpy bashful") (equal (delete-duplicates b :test #'equal) "nzSPYgrcdoejmpy bashful") (equal (delete-duplicates c :test #'equal :from-end t) "snezy SlPYgrouchdpjmbaf") ) ) ) (do-test "test delete-duplicates 2" (let* ( (a '( (1 2 3) (4 5) (2) (3 4) (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) (b (copy-seq a)) ) (and (equal (delete-duplicates a :test-not #'(lambda (x y) (/= (length x) (length y)))) '( (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) (equal (delete-duplicates b :test-not #'(lambda (x y) (/= (length x) (length y))) :from-end t) '((1 2 3) (4 5) (2) (9 8 1 2) (2 2 3 1 4)) ) ) ) ) (do-test "test delete-duplicates 3" (let ( (a (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equalp (delete-duplicates a :test #'= :key #'realpart) (vector #c(2 -1) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (delete-duplicates b :test #'= :key #'imagpart) (vector #c(3.0 4) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (delete-duplicates c :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart) (vector #c(3 8) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (delete-duplicates d :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t) (vector #c(2 -1) #c(3.0 4) #c(3 8) #c(-3.0 7) ) ) (equalp (delete-duplicates e :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t :start 1 :end 7) (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(-3.0 7) #c(15 -1)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3cbc8a1e3cad4c804ec28ced1dbb69027104bad1 GIT binary patch literal 5839 zcmcgweQXrR72ln`JKvo-V-tT-Y*;=*(1`_XJ{pLk`Z%xc!{QM1kaJxD*@*XD5g>N~$6yY8srXf{>buG)kpfRjN>>RimcqmlTCmX%T-^l)CTD ztiNp_&{p!^n|brzZ+`F1o7q|S3D#z>U-qVw>9`*4l2bjIbWcX^NOj5Gsh+O3sN4a1 z`3Y|zsD87-<855^K$SBzVWh1q+M0>B%i*4AcYAB^O1WyI>`8aUb!gmwKXj`$t*_p+ zZrv(pohRhyXt(qMhqark*Q|1moE{JhQ-UD02^Uc~1ffun1moFUp*yUG!b+XbuPU0S zNp%~2M$QhgD3OpFG;&4Nawe5l^yuEGj^QM`1yK-;6FGZbMDvDy0nO+a4~lb)<2jd4 zQ?^2Ao_bXvb`u5BMI$$_YMruHsa5@ISXF#=iWUe9rw3ez1i@N~gx-o>*dm_q6yAAz z3)x=rl_Jp^8;b2L7$rNT0b}UyX4KKaB?zV%+{m>W2;DkoT)&9x0|jgVe&SBs*yzF7 z!Po`R%{!D=EXK|QHnaPpukm=G;2lBei)8}^TZjnr^u1BGeIZVUk6jR8ii`0!nQ=3D zi+e|T+mUr_2u(TVKmkbBM;%frHaQLtR-=mZTQR0wfJz<=T33&f9-cyZ2yKAxGa94& zly=)}$%aw3j>%abXN@gb{KT*!!4Ld_i_?r3W0>v1n4vgc zJ}X>76SiPucpT}D5e-fwPzo{ukM6*q3H;3JpN$*pO@4zu6RUg@mIZozzq| z8OSg!$uX{H1ZT2^;rQqx4-Y{eaKB*)Il8Z*x|9lV}WD6$nEun zy$woG4M&1-EPL6xZVR=9!fF!{r(1*rZkjI@P=_=Zj`9Mx8Vm-4N+1&68VS3lLU5Sl z_Gm2%(}&y?&h(=7Q(p}Qk|0nEz7TwPvKIl8tu7F3@`SNlfU|ld!Jw*5c;QeH#w<5r ztav;~uP3DPsc1e9zYj>xNpBC-{v5P(LoH341Ab-nZG`$C(NYv=XbFl_y!R9rykqc~$ zoa1B9@v#$pEWwzPHZFE>(FmMeO`b+o@dSgO7MPSQW1*16EEH12LJ>b z8HSkUVkh$xA7y@`pZhK5mU&DF|KQ>i<{?KkR)5cMzL~#pTED$Fu^)FFgGrTZ?62>EK?i+-nE-ihzNw&L8lE*~DJ% z_8?t`9-FwwdhSuhJ?^9T!kF|fU4Y_k7QgfZE_wmY9#o+Wc~sI~h9Eu0U?rUaNihZ_ zeI2K6@@bI}D_VsvM?g3CxR-m#+@pef6tfV?$2g0x7Phl5%nIov=0iSYKIAg&={yaN zEY0U1yH(;=Q*RuJ|Tbp5|gRci+VQR&lX_O)ZwPsYSwi z!so0f^fL$HXh`j0nZY-qZK|D+U0mBzvrXw04}!W1Eb$=JV&G>HS_5U(6AmF z85y|_4U{8CehP0#=s1pe3R$Cg4)n^7Y__gli^g-|hX9Q5d&GKmHZ0eXntPbT%%HR3 z?Kk@KV1nt~ZWnKyntuw^?IKKxP%-))cf#nVXPyfBudAW2}D#PbDeK+SlFKKAa`^ttEv_oPdebXyVjQ!SPP;{aRLZpzi}& z3FoZh$MMLg9FJTY5DIGG-iOa+ec{zY z!N@JpTa&xmTX8o`yKq1)i|oPycMc;bHWM2=lA1jAc<>Rr91L*YH#tx8LzCxgCeJfd zc)nut{O$yvrzY@x-sJh%UGtn*+P-caHryHBmNTL@LFF3 z_xCRe*UaE7b#N6HMDaTbTx;ZOP7bI+1`l9glybw`Xs%GqroBD1SU4 z%)v6;qf2)XCtSvRaiix2;YAP(sb;LN-&L&i07jW+QJyjSrP-pKzGN@meJ~VqD}39G zgW>@_OZm*2$|Qikd#BwZ9UOWuZkE& z1Huwk>0g{{=xZpff&WH*a9(fqU4>6QpZ+)s_~N_yiAMlu;)y4S_<`u~Hh6*_FT7-+ zKx9@RaNF2`hvw`=!^pI0MykTU{x?)v`d=I6C|pC1Je&2=pu9ci^ENcml>test>14-3-delete-if-not.test ;; ;; ;; Syntax: delete-if-not TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: delete-if-not returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and not satisfying ;; TEST have been deleted. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements deleted from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test delete-if-not 0" (let ((a '#(1 3 4 2 5 6 3 20 6 8 5 6 7 4 3 2 4 6 7 5) ) b c) (setf b (copy-seq a) c (copy-seq b) ) (and (equalp (delete-if-not #'evenp a) '#(4 2 6 20 6 8 6 4 2 4 6 ) ) (equalp (delete-if-not #'evenp b :count 5) '#(4 2 6 20 6 8 6 7 4 3 2 4 6 7 5) ) (equalp (delete-if-not #'evenp c :count 5 :from-end t) '#(1 3 4 2 5 6 3 20 6 8 6 4 2 4 6 ) ) ) ) ) (do-test "test delete-if-not 1" (let ((a "aN inteGeR WhICH liMitS thE NumbEr oF eLemenTs reMoved FrOm SeQuenCE") b c) (setq b (copy-seq a) c (copy-seq b)) (and (equal (delete-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :start 20) "aN inteGeR WhICH liMit th umbr o eemens reoved rm euen") (equal (delete-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) b :end 40) "a intee h liit th umbr o eemenTs reMoved FrOm SeQuenCE") (equal (delete-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) c :start 5 :end 50) "aN intee h liit th umbr o eemens reoved FrOm SeQuenCE") ) ) ) (do-test "test delete-if-not 2" (let ((a '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "tyhfgwsjkkh" "olkdewskddc" "ppmmnnllkkplm")) b c ) (setf b (copy-seq a) c (copy-seq a)) (and (equal (delete-if-not #'(lambda (x) (find #\p x)) a :key #'(lambda (y) (subseq (reverse y) 0 3))) '("ikjlkmop" "jnmdkpmn" "ppmmnnllkkplm")) (equal (delete-if-not #'(lambda (x) (find #\p x)) b :key #'(lambda (y) (subseq (reverse y) 0 3)) :from-end t :count 2) '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "ppmmnnllkkplm")) (equal (delete-if-not #'(lambda (x) (find #\k x)) c :key #'(lambda (y) (subseq y 2 5)) :count 3) '("ikjlkmop" "jnmdkpmn" "olkdewskddc" "ppmmnnllkkplm")) ) ) ) (do-test "test delete-if-not 3" (let ((a (make-array 11 :initial-contents '( #c(2 10) #c(3 -5) #c(1 9) #c(10 20) #c(-5 42) #c(40 2) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) ) b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equalp (delete-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) a :start 2 :end 7 :from-end nil :count 3 :key #'identity) (vector #c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (delete-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) b :start 2 :end 7 :from-end 'non-nil :count 3 :key #'identity) (vector #c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (delete-if-not #'oddp c :start 1 :end 9 :count 3 :key #'realpart) (vector #c(2 10) #c(3 -5) #c(1 9) #c(-5 42) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (delete-if-not #'minusp d :start 1 :end 9 :count 4 :key #'realpart) (vector #c(2 10) #c(-5 42) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) ) ) ) (do-test "test delete-if-not 4" (let ((a '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) ) b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equal (delete-if-not #'floatp a :start 1 :end 8 :key #'cdr :count 2) '((3 . 2.4) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (delete-if-not #'floatp b :start 1 :end 8 :key #'cdr :count 2 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (2 . 222)) ) (equal (delete-if-not #'oddp c :start 2 :end 8 :key #'first :count 1 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (delete-if-not #'oddp d :start 2 :end 8 :key #'first :count 1 ) '((3 . 2.4) (5 . -5) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..94bb6452679b5301847730169c3c91d3da1bd586 GIT binary patch literal 3836 zcmb_fZ){sv6~FgA+p!%xq*>}TY16)i4YlrGwfrfRZV10Tzcgu`=k)nyZPcRT#4oj1 zC$?N?Q$d?X2q2_KyVP5Fx6`Nq3BHXoi4SG0(*$S;x=FAv69R;W$_Ef)q8}=dAe?ir zouqYOL^RfW=iPJ9`JLZ6_ulhfmWltQo>KJET)9wmDoSagT3)Csv!#l1zO+!8agY{WUEe2u@{{4x$K2Ul>SdDTDejv!o#6MFzi2kaNzLJ z(1GxXmPrY;5A^|u!NWrzKM-Dhd4;x@2q81%4HO|l+KEiO%WiwzHZrz4GL|w_QyVwp z-m>QgAs2NrV_2TMZ9u7(%4*Sh$|+(xbLR;q#CzTij!c@mJ(f1T8hwsNyi0C$%v2{J zHSLH&q+lHd(W&RQ^$)3oYSKs!h!nqt26l<`7>>e+-}r!1kJir1M1a-LT7>~Mk5V` zUZG95aW&l5(VxqU-)o@lSZwK_`RjnpEk9U3b}8NVV?vhmUrDzel_*46zSec32N~cM zBm_ddQJC4q$<=eEuQYNEBJKPJ!gcCggU?83_ZrI~R0)ocuPN))c|xsdpI9pl65l}k z2HF7UubG_km(Bl~u{7LZ9NL5-pu(0~Bh-f`7)t2jE|v?5fipMn7pK=7oT3Pe7lbNG zcx!=Mp)talaD&}_DTh4R2#p1Y-0un=X#|(Uja~QQQ7`AO#WveF%lY;~JCRzw7u{WP zJ#8k(@YJcJnwd-)mO4BJ8uLgdE=5^L3c(eG%MX_ij`y~>uG#viY8m#V1;q$IGs`(9SQZ{VI3&G%^pBeW1T39Y&(kmVs5XP+rj7PU-=yU1B-zPeMgLb zAx76BNKj8tOsN^;I8J|^BhVK(0$maaQ^Mz{@cEP&?G>Vnb)jFF3v!FQllQqh`4x93 z-{6+y5_czyZ2JWk1HulAon~D&>q@ZgkFwZw$kIOVJ1=WE-2*s^E+sou{DdE{sh3I`lx1Ux@}k!X#7>S z1H~5v@`4aKL^x(l;mjGIsZZA^%CRxmAqOD z1dVp?2G_;a)zyD>)gSK6fL?|cRP$4jq3^**Vi3WHW`FmGA_#MKg|sA~z0!8#xjT#5 zx#?UM%h=R%puyXKAYD0q=y^Nm5i>D4-@?34TfITUP(?&&@u`{iyl_!6J-%b^yb zjD0LO&>e#=8>V2=(01p&+O7=%ooMXy17cJ-oaF4TP6(lUwE&fTfB%}cXjpOcC1O2 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.TEST b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.TEST new file mode 100644 index 0000000000000000000000000000000000000000..970cc9cd3733707e4bcaf1ff353615c0739e0816 GIT binary patch literal 3506 zcma)8U2GIp6kb#?jaeW{)PRu_FtAm&?#%vni^bAzhlCc8EiuMKGM&BcPT0;YJF}F= z_@K``7#mE12Yo{E9~J+#ihtn01*rlS|9`duKKNv`@t!mH&fW)2+%(^QbMJS~ch5O@ zHtpzu-nwJ?w(G!v3+ovSFwbYDJd{|4`7CY^MLRn99~9ks&0={FpYA@t4{4DF!CI;< znTLM2WDkwm&M;r!S!a&LJQ=XX9Olt_IwkUT*O9$YPNUJ+KTN}Ew{!xt&vKn z&x`KVQt@OwEV~WY0vC?_SdMS*4$GHSg>o1u6bGPKxNTcuQ+EMYZ7kdY`QELY`{RX8 zJ&-RBbZs4gJn`<$+ct5|6{3i60zJ&LYIYT;!JV49Ys|0L91l$JL|eff0>8|_Ge;Qg zu$>Z^9xa%);ra-3{N_>ovgt!vY?Gebw%~_P7^NPt-4<^gkLOCi?0O9NEGT__Fm&X{ zu}5qi+2EKg$mGUU6cW$$Z7-NUj}<1=DC$kw+{FL}8FNHsr8ZH2mpF6GYgHReQKHdt zUi*-|sJwR9VIWJD<%G@WF>$%roB>}1$F6`|1IKmZoQ4`@I&ogQ&xTozf0t~$zx>&y zX2|?&VAS@@vIT2zp$>$(g6Yz+`JtUK-Dugi%0Mj)Cgs#e2DuF{CY(bs@e&Nx+>vmA zVP?Ei|Dzqj7)R|&h0oQmnU){q<7W{@R87^a;q|7A(9(i=d6|O@@Y*vUF1k>ym==>4 zZM5uGm`orCw>7wz>d-Kea!vUYH;G1LB{z%9-( zzxVK7ZR*5be@#C$b7tMt^3?RX>Bhl1{4^Rf2Ra*bv(W~JxyC~NwXSjDipKs$v^Y15 z4>L0)-hVoK$*Jup5Bz!J+|(jWx34zwz@7z#zJ4vMHF-wiX@#d0o>aK5a82QffY0ao z+nY4kq{0*h!V{^mL@FGS3PYsA52<3Or}eM|J*DuZ!gYmf3Qsh-)~@iJ!m|p`C|vQ? z6kkp8)f8V%@zsPcmLhDC3Rk4U6shn;DlCx-N2J0KsqjOp*y-t{(jtW?6|O5>Q+T4u zwRVN)6rNRhM&XLDmQvOgUrq7V6kkpFVkyEFsc=OqOpyvtq{0%Za6~E$kqSSgXm?*E zGS8bBzic0pgM^cWUy4_R|L+p0T&a45_TMD@N~%&qwPRv@KJ7e8_!i-5sY-HH$kRdI zVHt6Vv_}cgNR_Tc=pw?J7{8oUj}g92cvePeN`%HE!u5>8vw`<^>HRq6c!%(78Ie#j zC4~2#vI|d;_Fcjm5uvs72yEo-GVhbL{~qBvsme9;YB`a&DDyr=+V=^+kr7#uceBj< zH0>WF{8p+mO5TjfyHQ3wL)znn-^mD^ZOBE0Ay0Ccv>yN(o~i10_L!r7v#L!R+@+W(mFC#h2Aso^{^A}b?~koFV8pJjwHH%-nhDNphO zX+I_Wg-76vAjfv|#Q3GO@gm`8gukNUO)~r?TKk-^A;RT!R!@vCppBOarwC_-NDK$< za5i$4UrNlsQWo?I1)U)LO^C#lFf=V1uw0(!RZ^ZLJTLTeM$4q=HQN4y@PZJ@5nUri zuhaG^!iz#ACv=q*y+Pa4gue?B4hU@we7Du3vgZuiTs) z>Fwp+X}+Vj_w&h4_u=bGXKH=CHz;tErg+qsBXcp0GwWGtMgJsy#dh=%IjiZAX zjhc?ets;LXFUXwTiC6Qyqn{rvUwLzLWBcmX=Fu-}@7B&9y?4;Ky4m^;Ok4kE$6Hty z3ejsv2cOenD`?6-x`YmblhyF*`Y99{0zyI;t!dq)EzgSx;PEmiu z^Qigw_&PuT(DUw|b$!vS5B-Cc({AA9Vv%N{6Mrz$&3Ly@zaOFV+@muWYW)u%Z{q%+ zhu43$`6tgi?Ehr*+CmLW9{%oE+g~CAUCW;LHP3r8=zZDxOf;?i&1rgugs{kCX>YAM z-`+Y`-kmS+E<9o7O3TK@B58p?r{?kZi^Z)~bQB9^*A;Y~L)XA|&rE$C{pZp5b}9K1 zdM=3M+od3z{=DXY;jJ&unGf_y^A~>Y%s=}q^JyIF;BPJx$KR!HvRj6WQ>CiM0rgo2 zoS5{I9UwQ*jkEaqqxwv<7XRYRTIoOTBa(f@uz#zJ-gCrQ?70giS^Lti-~8TtM5APN zar!^UkGs}94m`=6naLmtY4GFYuNDh74=}{;9N6x);z9m;12FPC@#= zw{_m;|4+Bhy8?Kot4?h>SG`ayiP4;#SiM*-RiLL+<hHU{is%|6!bWL@>LW;bj0vt~!@s;4!(TC=Y; zJ6l)1t=Zk0{jJ&Inmw+oF4ydH%}&?sbLLt!`+hC^XE6ox}#s-Z9(3d5l=916psFsOb+#GnXmlgy`sak+29 zZ6y1#36LoEf%z)o_!y3l;rN(9z5Q-s zw;C=|kr%WmBkGI!lDpztiG~CYp>}&3<)p;bMw z$3e5vY&86xQEQsxfLgPk!_l-me5hLL{$Scy8VA$_`IQfQ`DCq8_ltb0e7}nWLpO1z zH0n6&aLyqIl`m6Yy*TWRhCMmRXzUEzkp4TT#DHxzCt+^FQTA0pvK!i|KB9mnd6 zlYv{|M#7DR8wocSF1eTVjfEQvHx_OzTpS~oivyfn;l{#^g`1qchAydGFyDqNgX{4Cs5xT$bc;bx_O*$Qi<+P1_sxGE!o0FB|OS!|7o9Q2FoVy(zvL zqUGtrcP#jgaFM&n1UBHQbM1csZsuHznNz3MC+x)L>3S8T`}tn0*PZ08F}CjegW+9# zSLNDbFrDIYGVSiESJpm3y?y+T^85(W^Mr5k{nBt;I!3Di?no5=cM2l=nW-#MNuuy( zAcp?;fEML6d-+p>7>Kh}-B*<``bBs5_6`#3fqIBM+Rb-w;~PIbD0SJMd#_&1@42&v zGUlRhR19mnWHt(y`;dt$RQ4S6Ls;um75Qmut;}%icliTFMt6=u8E8ut;Z_ZDz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE.TEST b/internal/test/LANGUAGE/AUTO/14-3-DELETE.TEST new file mode 100644 index 0000000000000000000000000000000000000000..e121b4fe5d2ff9a29b035336d5180e601b0897c3 GIT binary patch literal 4703 zcmeGgeQXog{mwqSG5I7I!UB{>Sli%n*#ZGUpbW>k6cc}>_N7^-RqW!Nb0-{Mc6UyQ zrci@MJ7wM=gis%9CyJ;Epr zWPd^tGlI8CnQAt-G;M4}QLSH1kE+=LpnoGLXH&A_D0E2!puJ&Ji)}BY%My4&ZKK3y zr=+V{6m3GuQO6^Zz)`h>U@KT0GMmtb4QPGy)-9WDD-p>sQTI?kkw7S>4L6}p^CUXd z40s6|cI4lbb=4T#o>7gVl%~r&QiGWtCgi)LxrN`z(~O%ifjS_Wk7iA2Unz4ZAu5Z) zq7X$%;puK67820ookA~a?MTF6MSgVV4wx2>^r_ig(9g4;pqdr8cz7 zMoL$Qa7)0g?MRo+oSrq1gbcg3NJ}GAk&z({%4n~e?MIS92$DXK8!;`|wBJmx2m|K1iC1X2=K{Ld@s-N**B=bx_59>l<~lk-#y@2yYC@R1G=; zSQl3k{0`%u5-)wSoV7FRZ$hG?8VJ4;kPK7L!7L5SNE?!MFr#Ig?7{@?d>V~)bK5{l zZ?}UlG+4+Rz9}+G&&z8)MC~8VUq)l`h zvbn)Na06MCdQL~GAEk9|urwqk%Xo(E&%J4BS-DgPIw~V-CWGXCrY@ySY7b(u9g%E? zBpn|n(tV!~+l4gy=xD$k!H^AQq!e_W4)chjWn{;IGXM!X`*WL*4b3?UfPs_B#(s?_ zGuJ?__R-<#9Ht}#%1m+|g1ZsE8DX#ZR@PAIYsBO0YlO2UWl*E7*@B*EY(^VU3u;Ci z;ks$vI-7!Vz$$&8t#aqgKQD}5IC$=Y^!@ig{7dnJ)mrYO=xqKs`O7yyxfx(z3rC|f zGv7@t>#0jW{n4QxesX;O*FJaY)bn3Iw(q?e)N=B0eR?OGJ9H+0WA^ANBlV-_T&I@I zrp8}?^$#EH|I)ML{}?;A{My*F!rJDOv*0A@udVI6wSv9*#Sc?UrhYv2_SAtZ`Ik;! z26xx;m-AQPdi`|%#2>CjA1GmW?D^sej1~1 zDi=H1^I7)YOP#JBRKJ)lQ+ChzndvOUtj2slv)k`-bRQ;MR1Z<@{w;~|%EbYOsXh3} zGFCair)oN01?cUG$l-X^TabDD@9BlmFYMResQQSOf-- zDrcLp-Mugt${s(AMn;>RjQh{l#r^Rrr5>i8Q1@O3fwO;`H%K7ucLvFC50Zc3gLKRp zr1HCigb$Zen1|0D-T%#_r`hpXG0%f~`;9I02vC&A=Mg{xXKGJ72{NzdmAvu*gPV4O z!)+m_7Q=Fe0q0NLLxKR8+(S}tKgejjk`oQSRoHnu9^rNe0c^f61A<+7U&e%jEB4^( z^~fqG!fGe3xp0w(6fQEChW8l`qNCrvSOzahX6 zF|>2#G{I!NI@U$;HBP4n;;XDv3 zqrpyr4<-^pLONkB#hl~TG7NNzec7tT*mi3P2J0<90M9Jpd2WM^>SS-UEgs=Jx?>?+ zYRvvSWxr$9VeBf!enGL9i9OE=V$U;9?d_o=5el|aP)#K(h$Qzhk>svIV{0CB65*53 z%!mM9xL*_V+(m0S#(qYzA5iQx#ZFLcl43eB&uP^B9%_CI6=|j-jTBo$F@`9(XNZFP z7Ey5HGJ1nuUGVY*e%;4O=}jIGnnZ+opYWJJ6CU$>!edTS-pix| z%s96Fj1Usz39!w)VAYLTOI525s8zRvix%}7lZwwDj1f##Q zR$}mTknx3f1rx!LC}4ZupMYF-I0gqK7~zG85QVA2^a-F>z;s3Uu6Q_R3xCgAg?Znx z9>rjdwE~0X)U=NP&n@ua+VLbXJl8FR!J8C3N2EQ&RBV6%?hYYxHz@Wl1#f`~F5ceW z1=`#j)*1|60a`^Q-UFwX3^m~$u^KQ>q((Za_I3)IK%p$$4%vi7JlEW#)>;7WzY<|L zb>;pY5oZ4g!k!qMn-GYw77<~OP~HIom|qeibB3#&!^LfWuD*nrX!`DXy$Khm%v zwEd4^vDb?QPL`zsynn4Y$#HJhgZHl%zsMDm6Jz{T{(B+1mTZo7tj>9@MC)@)#T#kl2w%~9_A4a&=R=3p(A^sP`)z7%g5T3V=jqTXmWHBi+rM1d|WSfnYHkC>^pv`8}I9cyYcGoT85><(d6K~=u zKS&6u(q7amK~Pi4(~7_8&jm-`Cd@9a3$h z=IuXi$e{n&@t)|`)hn#62mn*CNhAW$1_7vCDz(XuZad0Q+RznK&FFHaTq%Vy7bR=! zR;AQ_G__n@P~6-bIhWFzTLK19Su2HyvZm&wxmmf)R#~iau@q06${41mp434I*S(N; zRw+e#`;=o8#el09&Jijr@ZqCCeUyKT;pG~&25Mg}X9|a_CAR2-i zaN3~R3UK}Tx>o$3d#m{kw39A8C9(X?NpX{l$lfg*7rFQqKso;|7e@t#hUM!1)5(U@ zFhC4_%}gC=hQ*u)tS~8J>Cjy~4em@8jU|lbAB$8!7U_QR<3*%2zvfyI19W+e{k>t(6Z;2V{+#gK6p@Wmq)_4c$@((kL-c+OiP$ zB0?Bv2xk!6v|ZLzM;q?4bSGwK+KB-qS%_EtXmeh z6rOd)vW^@O(I6(P=7i$QZP~*fZSQ-q)nfqwuZ0@Cn_Bia^b{K6Rz`J*{h6X_S*&826@uQv#K#hY?WS*j5?|-s%5DYBw9yNP#qgHeC|`^ zBEEu=w*BBAlLtFHVC&kFNqkSNHhs zx_bt}>GuGB`V!!d`^(qAC(dsGV?V+(wS8%_tGnYfd}^wPsJM90r9}-eH{Nj;0_#5RTu|og= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-FILL.TEST b/internal/test/LANGUAGE/AUTO/14-3-FILL.TEST new file mode 100644 index 00000000..52b9ae32 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-FILL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fill ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 252 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 9 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-fill.test ;; ;; ;; Syntax: fill SEQUENCE ITEM &KEY :START :END ;; ;; Function Description: fill destructively modifies SEQUENCE by replacing each element of the subsequence specified ;; by :START and :END parameters with ITEM. ;; ;; Argument(s): SEQUENCE - ;; ITEM - any Lisp object which must be a suitable element for the SEQUENCE ;; :START - an integer index into the SEQUENCE ; :START < :END ;; :END - an integer index into the SEQUENCE ; :END < (length SEQUENCE) ;; ;; Returns: a sequence ;; (do-test "test fill - test cases from page 252 of CLtL" (let ( (x '#(a b c d e)) ) (and (prog2 (fill x 'z :start 1 :end 3) (every #'(lambda (m n) (eq (elt x m) n)) '(0 1 2 3 4) '(a z z d e))) (prog2 (fill x 'p) (every #'(lambda (m n) (eq (elt x m) n)) '(0 1 2 3 4) '(p p p p p))) ) ) ) (do-test "test fill 0" (let* ((a "a b c d e f g h i j k l m n o p q r s t u v w x y z a b c d e f g h i j k l m n o p q r s t u v w x y z") (b (copy-seq a)) (c (copy-seq a))) (fill a #\0) (fill b #\1 :start 0) (fill c #\2 :end (length c)) (every #'(lambda (m n) (equal m (make-string 103 :initial-element n))) (list a b c) '(#\0 #\1 #\2)) ) ) (do-test "test fill 1" (let ((a (make-array 40))) (fill (fill (fill (fill a #'+ :end 10) #'- :start 10 :end 20) #'* :start 20 :end 30) #'max :start 30) (every #'(lambda (w x y z) (= (funcall (elt a w) x y) z)) (do ((n 0 (1+ n)) (lst nil (append lst (list n)))) ((= n 40) lst)) '(1 3 5 7 9 11 13 15 10 20 30 40 2 3 4 1 6 5 7 8 9 3 2 -1 -5 -3 -7 -8 0 2 -4 3 4 2 1 2 9 7 5 3) '(2 4 6 1 0 2 4 6 -3 -2 -1 -6 4 -1 1 2 0 1 2 3 4 5 6 7 -6 4 3 10 5 2 3 -1 2 1 0 3 4 6 2 3) '(3 7 11 8 9 13 17 21 7 18 31 46 -2 4 3 -1 6 4 5 5 36 15 12 -7 30 -12 -21 -80 0 4 3 3 4 2 1 3 9 7 5 3)) ) ) (do-test "test fill 2" (let ((a (make-array 400)) (b '(dopey sleepy sneezy grouchy))) (dotimes (n 400 nil) (fill a (elt b (mod n 4)) :start n :end (1+ n))) (equalp a (make-array 400 :initial-contents (apply #'append (make-list 100 :initial-element (subseq b 0 4))))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0d298644ecb9a399f57e57a1e73f43eccc76fcbc GIT binary patch literal 4441 zcmeHK&2Jk;6rT+-WYbtmi6~VM=&_O5*(w`({SkjuAX%;hNrMw&N9Dj}V^88$)?R15 zCb+0ls1PTk)mInK{Tfm6~NU7o3JyYk08YxKMW*Zjr$X%Hhk*{9^X{N9oL!$xFs?zHg=I zGSg!vC^T5TWHu+jNJ6^iS~gA+?@fYXq+;PzG&(svozBm7tsSV7KoeXc6^l#`Z{NKm zjXH#oB6-XQnUGQP8tL3_jb1Ed^96l+W-hDe(jR9pcG{iR5c;Ao<+F>O*4Z$4PE@zq z=gj8rRO&<`Wb0OIXnHA^Da_30I^Ri~(n#lKD>#$W7tpozhgmW({I0;)<3^uumN&}}QSj!CH%6uMgI{tu|EqoF+uRdE+U0L@ zvjY+uY~OqP>UqB3A%kRy5Ips|B*ZVi$N8` z=s{A`g0dFWf8nsaY+_l&u5Z5s$03v%y@wXx5otL!}L? zx`x@*8*R(;@MGOGU3gc~z{7J6XTrD8HNf>z8^QMU0rsG9N~Id8MI1_168#yuQ) zFisF)crQSh@*zTUFGBNq7@832Fk*zmO z`-KiqL?C>?;poD?!+Fuagrm_g`u*Ia`7$1j$ol*i>BC9*kKn|1>lMot3Ga{2PQ`AB zGQEaLY^?yl453FSvpv97O_a3Ptg#x_^ECmaDKP8=QpQV4sW&PW<|+URUY8!9DJ!OJ z<50)%)#|F!x1B}+3mvl|))UG~-CC(4;@%aZ(rQE8BFmNswuP6s>AGeUkKbXQb8s>~ z@$5W`Phvk_S^JzqD||&^%v|lc#s#!ut}$KsgBmHTYI&Av>&#{q{7wV4STIdLj_Ner}4wEyS5{4x7~RGWI? s{=c@r|L+{N|38EMe^_74US7&%vGpIu)<5ufU+XV@#@pz3{@wcj13i%59RL6T literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST new file mode 100644 index 00000000..8b70b167 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-if-not ;; ;; Source: CLtL Section 14.3: Modif-notying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 26 ,1986 ;; ;; Last Update: Sept. 26 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-find-if-not.test ;; ;; ;; Syntax: find-if-not SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the left most ;; (or rightmost) such element is returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test find-if-not 0" (and (= (find-if-not #'evenp '(2 5 3 7 8 9 0)) 5) (= (find-if-not #'evenp '(2 5 3 7 8 9 0) :from-end t) 9) (eq (find-if-not #'integerp '(3 4 5 6 7 2 1)) nil) (eq (find-if-not #'numberp '(3 4 5 6 7 2 1)) nil) (equal (find-if-not #'atom '( 3 4 (5) 9 8 (9) 7) :from-end t) '(9)) ) ) (do-test "test find-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) (and (equal (find-if-not #'(lambda (x) (<= (realpart x) 8)) a ) #c(10 -2)) (equal (find-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) #c(10 -4) ) (equal (find-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) #c(8 9)) (equal (find-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a :from-end t) #c(7 65) ) (eq (find-if-not #'complexp a) nil) ) ) ) (do-test "test find-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) (and (char= (find-if-not #'lower-case-p a) #\W) (char= (find-if-not #'lower-case-p a :start 42) #\space) (char= (find-if-not #'lower-case-p a :start 49 :end 57) #\,) (char= (find-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) #\.) (char= (find-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\space))) a :end 60 :from-end t) #\,) ) ) ) (do-test "test find-if-not 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) (and (equal (find-if-not #'oddp a :key #'cdr :from-end t) '(6 . 12) ) (equal (find-if-not #'evenp a :key #'cdr ) '(5 . -5)) (equal (find-if-not #'minusp a :key #'car) '(3 . 4)) (equal (find-if-not #'plusp a :key #'car) '(-23 . 9)) ) ) ) (do-test "test fine-if-not 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) (and (equal (find-if-not #'listp a :start 1 :end 14 :from-end t) "str1") (equal (find-if-not #'vectorp a :start 6 ) '(8 9)) (equalp (find-if-not #'bit-vector-p a :start 5) (vector 3 4 5)) (equal (find-if-not #'null a :start 10 :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3)) )) "str1") (equal (find-if-not #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3) #\2) )) "str3") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a2f7c4b9b015540ef9b58448a5375cb0f4465318 GIT binary patch literal 4421 zcmb_fe{36f760Cye0#NLOiv7_9&eS~@0Zo1xvUM$?%g1^@9EsRr=z2- zsz)`WJlg;C0f){#?f11+m0nm7YR3s7L*xUjmtSQK?FjaX9~Waq#m*&aow30riB{kn}t9`R}!!^ zwO1peuN(!V3r?Y?y+hdrS@f_H=^-yH1dbEp>cmohlDV)?I6p>y@zZ@`|AwYI!9B|A zLtTIn+g&P}O9*h;8bJM};@%|`>`rCQZC?%Cy#$o~FzA)(%yi}g0PBx?YlY1Di#qUE z=k|X?f1QxI%-8gNq5uKs&NcSmjrREX2!X7ZvO`U5`^q&7$0{{@D~906auf$D$nwm^ zt_r$n*IGeV*wupsXM{Q|B{QAHqSvf&(Wn&eTagI!T`lI8FyQPUteh+QS1Q_3dw-Ru zqP}n0QtVGHdTm|~KL9@2MVB>QlypyJQT`Qma$$MiE5(OzVNovlO7X$lDVuMjT*DJ` zJycmtz;3K;V1?R}?Xum~eBUczg&wk7kUf-XTKVrHFB~uXVR-Cy@XA)f#kN~YMSDqU zdlomsx&;c?vA72lU?4jHFBI@Zp#$X=ifly*Nl?KW@8h%{MA~qx-kZzRW^0KUaGon{ z3Wnl(ID+#>=~MM^R5O%rm@W~$*9?k&>KA?Rc;Ruw3b9G& zF$Yaci;2R`7FIk+tEFn{mvFeP3u=ZDHqf(b(`m|*f?_i~43Zc@i2@*yYhaq9t+Ve zQ|cCZBn7_|hvn=T|B;8-6z-1nzEf~b!!PWv_qtwp0Pp}PeT9R006jGb zJi>txTNO2-W@_=d(6PE$><@7VD^|EZ+X|8Zoul?=viWo#dP^Qo!yjmqW5f7oTI#Tz z&!y9HDlg~1n6_cVi&O*O=sr~m^{IxEAVT%5j2$ApGs`mlksdHNh(qkf>DhK~Zd5xIhFFe893&fABv3+;E z7&yjC;5W;=ih+O217BW~z^~qP>g0Q?PkjewJwufod^Y@}&b$|zeqM003k>+_S%ORTUm8##@UPnSyn1%CR;Qvd(} literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST new file mode 100644 index 00000000..304d86da --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 26 ,1986 ;; ;; Last Update: Sept. 26 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-find-if.test ;; ;; ;; Syntax: find-if SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the liftmost ;; (or rightmost) such element is returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test find-if 0" (and (= (find-if #'oddp '(2 5 3 7 8 9 0)) 5) (= (find-if #'oddp '(2 5 3 7 8 9 0) :from-end t) 9) (eq (find-if #'complexp '(3 4 5 6 7 2 1)) nil) (eq (find-if #'floatp '(3 4 5 6 7 2 1)) nil) (equal (find-if #'consp '( 3 4 (5) 9 8 (9) 7) :from-end t) '(9)) ) ) (do-test "test find-if 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) (and (equal (find-if #'(lambda (x) (> (realpart x) 8)) a ) #c(10 -2)) (equal (find-if #'(lambda (x) (> (realpart x) 8)) a :from-end t) #c(10 -4) ) (equal (find-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a ) #c(8 9)) (equal (find-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a :from-end t) #c(7 65) ) (eq (find-if #'integerp a) nil) ) ) ) (do-test "test find-if 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) (and (char= (find-if #'upper-case-p a) #\W) (char= (find-if #'upper-case-p a :start 42) #\N) (char= (find-if #'upper-case-p a :start 49 :end 57) #\M) (char= (find-if #'(lambda (x) (not (alpha-char-p x))) a :start 35) #\.) (char= (find-if #'(lambda (x) (not (or (alpha-char-p x) (char= x #\space)))) a :end 60 :from-end t) #\,) ) ) ) (do-test "test find-if 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) (and (equal (find-if #'evenp a :key #'cdr :from-end t) '(6 . 12) ) (equal (find-if #'oddp a :key #'cdr ) '(5 . -5)) (equal (find-if #'plusp a :key #'car) '(3 . 4)) (equal (find-if #'minusp a :key #'car) '(-23 . 9)) ) ) ) (do-test "test fine-if 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) (and (= (find-if #'integerp a :start 1 :end 14 :from-end t) 33) (equal (find-if #'vectorp a :start 6 ) "gcd") (equalp (find-if #'bit-vector-p a :start 6) #*101010) (eq (find-if #'(lambda (x) (equal x #\2)) a :start 10 :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) nil) (equal (find-if #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) "str2") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL b/internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8f806d47fe445d9938bddd92cbda96117d7b1fd7 GIT binary patch literal 5531 zcmb_geQZ5BV-Z}T$ zd5IlX)J5QT?)jb1d(M6L-j`A0+!+Y_0zF*^lV(S+uVuiwyOhSJy^)|80a zqWP^+E9Hi{DDjx4Td8@qzW$zrirI0f!^G)y^%02>>#3BxF&+sR&C!UJmIkGA>r|?u zIihTXsi{pGq3)a)^e$N`Pt7`IEkua~$=R`rV}v+^n8z!f7q&<*cavMMZlOCW7tfQN zCPlo05R*sD=|WX-WXdp!bmuv8-i9bZrYj5cf3|Bfujk6? zowOl0KwXpB%s|)eyp|JP-ct%whk|{}#vN05*X?YkL6jLWE-1|ztSP{`Ba>#&nq?RO zX9+bF6`8A={5@Y2H-^Z~12VJQJCW(Rvq-Q7b z!_G*)5EbY?m!4R76%ZKyL$C9R!Wu&jAW)vG(+m!PhUuBEpUm6j8Y^smJg|At#KP!{Vm`BEq{vN-k>rq{a#*J-p!!MVDLAhUzv??5r`5El^ z^VSz09Az>g%z?*6BOU-7z*9+MRBurYWY=TVKwQ_g$h6~#Nhn(hvW4~}18PhYp;#G+ z9sfa3+V;2_-iGYIfpy?fgUp}U=aF1tl}KI^+&RH9!JQV|_XYP|!Nmj@7TjiV`MFqY zOG7lQlvV};}Ttz-ERC)y0F1V=RngmxPxN5;w z3T^@C=*OI+w*>bt4@BSLf#?Muh^B-}pCG#g*&z%b65J-itrXn-oRe;HXVP`CT{Du}V zqWX7O<-@EB+%~W(g;jz_zCIR%hLf)^D5rBi+(1eqxOl?ImaxS@93SGngx_Z(Q8aQ~ zg@xk`##>rir>-?9M$u({htZ=giY8XdI{-LihN^S%MYaUBUSms<{Dv(<@^b+`E5KpF z9T!}mP%#C#51h$4$9tF$je`hn)mm{}FO=)V^7$%A9QnLz+5MMyOdwkX{$yIi4VWk!MEF3i1P9Cu;I6 zsDa)BAyxnSW;EO`gd5Qtq8$8+P+iK_pvn@?N$+#t(q-;cx+utVygt%1ygt&9;EoIK zpx_P&Zl~a4f~yytBFG{EIyoU1c_8vCk3hx+5gP~@V=LNVANF9XYQWI+U6?rEkan;Y z53vU}u@&Ehq@6WZs;s}G555bM-R-`02q{)-nSs#qqv~?s-UNIlwEL3X;)0LZQLMV- zx;5;uhG6q_z*;HS!deS%lSb<{%}P^Hb~IL zzs88`fC@*GmsqJKW}<6PdjcaB?bC4jQoc{4>y)$;eyx(sDgj47f3wnM*09qWazZw& znmx#B25(KJmjj43?6!v7w#Kgtfw(m+TSKy~@j;zw*^cvtK|VnAmk?zC9CYD15#&tagl}PxkvR%-LIgQnRCf&0 zGe%a`?}zoI;vWernnh}sK*cQsnHUNFt3G2*G;Z&LWU`?ORbh?HCSaDkC_N=`_lBo=RoY1?xN z_(cM%3ln$~LoJ!LP75%B1E&0$5@6t$oDjj~k9ctTW?}F_P?G;*J&o_{>D1DIuBnEm z6x^4>&9E`4;TS6uJBD+6JZfm-?6^E*Us{XqE-?kkn3a}~WwY7a`1k}LS%goH5of)6 z<1PwX)LWPfK^Ko&Y1kfQNrr7irj8PLu6Dw^Ej!=>DuPa8ypQqmQ4X1w1|Suc%iy^> zgnv(vdy9<_-v9q+x{EjAMf9fI@iyD&Iz*i=R9I=F_vR9smNRO2rZnj7DLZ=2M&IL& z_9KJv>o5w~tIW(dn z2m8fB6+ZNy=DG1KZ+JUD%Mz0C#4Cr}en?gD%vHA0a^{D8MY5f|WUpb&_7VKlpbwAq zBWbY(%_9j!8b<1n)Y^h-fqZeK8wFLiU;#&@$vbvOx;CRbHDE9OlXpiNx6)qO;d0|r zzU|>;(orHgoRm0F&EjExi^D;CxX&I&?cpYSxW*nXw1?8vko@D0$&x?LNcKSpP2S_l zlIIJz(Qy=>niU-`L?=-9L?MbVJb9uJ9gkTlSE9Q=`N%*=bmWl`EOv=*u+k;a-!$w2 qz{zmq0Rk@=JlDXEAyJ33#O3zD%jJ?`NF|3f`y|OvFzAQb?0*6GUkcy= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND.TEST b/internal/test/LANGUAGE/AUTO/14-3-FIND.TEST new file mode 100644 index 00000000..a0cc9b79 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-FIND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 25 ,1986 ;; ;; Last Update: Sept. 25 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-find.test ;; ;; ;; Syntax: find ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the liftmost ;; (or rightmost) such element is returned. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test find 0" (and (eq (find 2 '(3 4 5 6 2 1 4)) 2) (eq (find 3 '(1 2 4 5 6 7 8 9)) nil) (equal (find '(1 2) '( 1 2 ((1 2)) 3 4 (1 2)) :test #'equal ) '(1 2)) (char-equal (find #\q "antique" :test #'equal) #\Q) (equalp (find #*1011 (vector #*0000 #*1111 #*1011) :test #'equalp) #*1011) ) ) (do-test "test find 1" (let ((a '(3 4 7 8 -2 9 8 -3 4 6 1 4 5 2 0 4) )) (and (eq (find 7 a :start 3) nil) (= (find 7 a :start 2 ) 7) (eq (find -3 a :end 7 ) nil) (= (find -3 a :end 8) -3) (eq (find -2 a :start 5 :end 14) nil) (= (find -2 a :start 4 :end 14) -2) (eq (find 2 a :start 4 :end 13) nil) (= (find 2 a :start 4 :end 14) 2) (eq (find 11 a ) nil) ) ) ) (do-test "test find 2" (let (( a "Fatal error in function SYSTEM: TASK-SCHEDULER")) (and (char= (find #\n a :test #'char=) #\n) (char= (find #\: a :test #'char=) #\:) (char= (find #\a a :test-not #'char>= ) #\t) (char= (find #\F a :test #'(lambda (x y) (and (alpha-char-p y) (char> x y)))) #\E) (char= (find #\R a :test-not #'(lambda (x y) (/= (- (char-code y) (char-code x)) (- (char-code #\a) (char-code #\A)) ))) #\r) ) ) ) (do-test "test find 3" (let ((a '( (1 3 5) (2 4 6)(38 5 7) (4 2 1) (-3 -5 -7) (-2 -4 -1) (10 22 31) (38 72 10)) )) (and (equal (find 7 a :key #'third) '(38 5 7)) (equal (find -4 a :key #'second) '(-2 -4 -1)) (equal (find 38 a :key #'first) '(38 5 7)) (equal (find 38 a :key #'first :from-end t) '(38 72 10)) (equal (find 0 a :key #'cadr :test #'(lambda (x y) (> x y))) '(-3 -5 -7)) (equal (find 0 a :key #'cadr :test #'(lambda (x y) (> x y)) :from-end t) '(-2 -4 -1)) ) ) ) (do-test "test find 4" (let ((a '(#*11111 #*0000 #*10101010 #*01010101 #*111 #*00000 #*1110 #*0101111 #*000 #*11100 #*01000) )) (and (equalp (find #*10 a :start 4 :end 10 :test #'equalp :key #'(lambda (x) (subseq x 1 3))) #*0101111) (equalp (find #*11 a :start 1 :end 9 :test #'equalp :from-end t :key #'(lambda (x) (subseq x 0 2)) ) #*1110) (equalp (find #*01 a :start 4 :end 10 :test-not #'(lambda (x y) (or (/= (elt x 0) (elt y 0)) (/= (elt x 1) (elt y 1)) )) :from-end t) #*0101111) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 0 y))) #*11111) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 0 y)) :from-end t) #*111) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 1 y)) :start 2 :from-end t) #*000) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 1 y)) ) #*0000 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6e5737c135c3995dfb4b0f0b9f6ef384297ae0d5 GIT binary patch literal 5706 zcmcIn3v5%@89w)3KNA8W1QH%27uH~~YT7)YG-K3`b3+1-9qemL&=50@jh#5YA-2m> zHX4yvn9!td3R^o(>a>TpO4FuIn!2u=x<|Y0|IhIw zFS4ZD2=@Ox-}%4)oO|x^2r(XTdt|rP*B?(r24pRh?$4yKaPO`+nes+v9)CK;+Rmb5kkV`CJHMdN;q|HH;#le9gcwa&)wS65J;K!_dFJ&! z;=}9LEEkLk>rqxLMoS4nF)=Pr^+LQCKJgNBE<6;w4tB-k=1L)U^@bPpKaK1?7j2*7b?|>UP zH}C>)UgNRZ^^6}X)`=}ml$99s%i%1Bd=(h0FUB@biB)238Gdb^vRE^iLUle&gf%YFT+HKsb(nCb;L#;_&dm=bJ9Yzpbz+A|MS zkz-$|uUPX=%)}2X1eIcJeLjXnIZ7cogUQE#CXJT z9I=V<{rLp8C;WPsd(eHP_iQ5-X3F z6LG2jOm>~!?en&@-P4j%9BfL$!1RPOFc-~`XmR^GyBq;!ANrfv`A0)#Y4 zD^dJ}jgj7jG0Os79nC(EBmWx1@M}E$92d{hDs+C4i^mwOl;NU-p-X!>dJ{)Cv2o%D zY=HPXZvB#5cer(fTd#2IE8H68R+d{sYzFajTqL>Z=Aw~JE7q}T#SLs);axUd_!S#2 z{E%C>xi!wM%iMaFTj#lTieU!+1 zn)?;E>hq(?TTI@ftI>Lm54p?$$P2XUB&|3>SM<`#X1cPTR(+DLTt};#A=U76z%jDT zhSrbaied8NPV%66o32Ii3V5ZxN*C%cqpo;cP=670V?cHJ*|vLQIAF!#U zZ*cKtq@cF7`>`l#ggc)Ar={JiD!UawHcYyYqi*7GRa^*cV(~*(hKMaT_*z;pUwjXq z6yaduUWPX+bicz>e@5>?>uqX7@dk&v&12Vj>^nSmnLD57&Wqgn6t_-uYZWUE&KT^r z@GmZY&zd3phBZp~1(db~mcGs9aJRYq4lGf4gQwi0o6-6@&wPnnXSmqRpaq#@Rx&|8 z0x+{T*wM^eL%s>N@u1@Ov7L1Ztxiuc&>5m@y6D;ty7tqw=0PgohXG~3;_X~b@7W7e z8s68ltJ9HGT27`iM^fo{I+Kn#;!#IZOUsRz@UEV%Q88iTN!La>8iLz+w;WIMi!}O9 z)?(UKeblOFO{rug^5`HciAba$6k|`O52g9&fR+izKr01;B9RUNuy{7bKrZB}M!?Yp^Od@_FdwJ^wR!1&X^dE%JqZbJ?29b3OE3aq z6aGw4_T@Mq8zW`-5_T@We+L8;z!_TM}gjOzsnP#rI-c};J%+D6!eCw-SqgSgj_LT=7N@i}{;C6Agc zKz0aucqZ-)yOvDc5$B*Vj>iU25EedbFL8vv4dy+51U|t9X(axaDqZ9YJ7@J&bj;J!It1OqdMf-`&+bY^BHgh_s9V;ea#-u@(~`BROfs6#jzB-4X(IF#UTd~F~Z56Q`Rua*Qb;iqTu)h@g>1*}$!!l-$`Y8hB9TpwnDz0SeD zH3bYRTNGGrp|Te^7`%`RG#6W05o~k{O0ijTp;cml>test>14-3-nsubstitute-if-not.test ;; ;; ;; Syntax: nsubstitute-if-not NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and not satisfying the test have been replaced by ;; newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (nsubstitute-if-not 9 #'oddp '(1 2 4 1 3 4 5)) '(1 9 9 1 3 9 5)) (equal (nsubstitute-if-not 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 4 9)) ) ) (do-test "test nsubstitute-if-not 0" (and (equal (nsubstitute-if-not 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 3 9 3 4 100 3 4 7 2 9 3 3 3)) (equalp (nsubstitute-if-not 7 #'zerop (vector 0 0 0 1 1 1 0 0 0 0 0 0 0 0 8 8 0 0 0 0)) (vector 0 0 0 7 7 7 0 0 0 0 0 0 0 0 7 7 0 0 0 0 )) (equal (nsubstitute-if-not "*" #'numberp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test nsubstitute-if-not 1" (let ((a "seedhead of common sunflower marin county calif-notornia nikon") b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) ) (and (equal (nsubstitute-if-not #\% #'alpha-char-p a) "seedhead%of%common%sunflower%marin%county%calif%notornia%nikon") (equal (nsubstitute-if-not #\% #'alpha-char-p b :start 10) "seedhead of%common%sunflower%marin%county%calif%notornia%nikon") (equal (nsubstitute-if-not #\% #'alpha-char-p c :end 50) "seedhead%of%common%sunflower%marin%county%calif%notornia nikon") (equal (nsubstitute-if-not #\% #'alpha-char-p d :start 15 :end 40) "seedhead of common%sunflower%marin%county calif-notornia nikon") ) ) ) (do-test "test nsubstitute-if-not 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (nsubstitute-if-not 'z #'oddp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (nsubstitute-if-not 'z #'oddp b :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if-not 'z #'oddp c :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (nsubstitute-if-not 'z #'oddp d :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if-not 'z #'oddp e :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) ) ) ) (do-test "test nsubstitute-if-not 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if-not "**" #'integerp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (nsubstitute-if-not "**" #'(lambda (x) (<= x 6)) b :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (nsubstitute-if-not "**" #'(lambda (x) (= (length x) 2)) c :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) ) ) ) (do-test "test nsubstitute-if-not 4" (let ((a '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "bashful" "dopey" "snowwhite" "witch") ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if-not "no-y" #'(lambda (x) (find #\y x)) a :end 8 :from-end t :count 2) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-y" "dopey" "no-y" "witch")) (equal (nsubstitute-if-not "no-o" #'(lambda (x) (find #\o x)) b :start 4 :end 7 :count 1 :from-end t :key #'(lambda (y) (subseq y 0 3))) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-o" "dopey" "snowwhite" "witch")) (equal (nsubstitute-if-not "no-s" #'(lambda (x) (equal x #\s)) c :start 4 :end 6 :key #'(lambda (y) (elt y 0))) '("sneezy" "sleepy" "jumpy" "grouchy" "no-s" "no-s" "dopey" "snowwhite" "witch")) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6c69f9ae4c7ebceaf87b2a47cc9a0d7017c96dee GIT binary patch literal 6501 zcmcIo4Qx}_6@Gtq{vin=P58@$HJxi=N`6Rzf$A6Mg%}(=*v}t`nq zhb4#woO91P_n!Nm@0@q(;NSU*Fic zs<2fFcv!Umxds+At#5!elPAad(m2O)-P{C<0*))?L{2}RDz$5BKy$RZJ*va2w5xXg zn4ZdqTpYoG>eo|c_406h&=Cti9*$u;{RxieIQ?iUzcuJ}X>OlaALB>)V*UA4iQDVw zfYg*tDktQpqhNGiPc5ixbTl};fnak$b8A6Ob+}u(ljBAEInHtp5nYJ9wV8i&fIIQC z&BC^2i^_OQtl&`!6um_phvLe4d8!rseej7E=B3@Ek+(oE-=9~(N8Y^Xh4DX*Z8_|{ z%yGve2fUjFz63_+?%5_|F#P0mTrtN@M7vi|TGAkR%>a=X6Cnt&H4Vge+!c(E<@hPA zplJJY{GbZ}oUg`Uw}u^!+$H!zlL0?Jaxt>Ad?K>5!l?R1+#8^S)fh1!YWT@8z0I&7 zjj@tKOPb^J8w`i996j|}Pli@s1$yS=FWZ#jm@))ZbRyK~d0z!B(zCvbSyxH)8EF<_ zf;3S`x5|{*v}7~sS4{vo_-`)l6B#qhAupTVj;xC&o(Foi_0Dg|xG7_R!?@m0Yv zW|_7SNih>sH9==mVye=_RLz5b20aNg7KBDN_reNN1nHm&KedGD5~>S>H0F z0WeV(CF3+@a_7&W37=RW>0MxO3_!Y$gYUnB~ zWb$_Vpf9`Em6u=Req>B%#l`c2hNdS6D1f3c{ZJV*XOdF_pAQ<7*i(i*LxCb=#P0HWTikd9INB6%i%0c4n%!XW zZVK3iLQ)_U!6zR+dGN8oM}q67%GzWTW4rKJ1G+9 zlLE06u9$gt)$jND9loH}5!CEr87wHaE8Z>#wFm43?wYbD^OZGUKH z?ae-q!?-Qcevr9$f;->k>*#U>)U9amB=?{YNI3{`k}N>+cT$1k=X8yDiBzKYJ*FLE z;#p>Vf{8edB8HjR$bzkB!R$1c@GrVf_%mG~{EBH;nf5l*e#o?!m^Q|=reis*=>TH5k5PSCb!k37s@K`vYor>rpRgronejBK+(*jykOh6DqM0nLCzW3! z3zv{e1*Te_fjAc0Q>g8Q_Z_Pj8^(ibKUs`o6#L7Btj?!Q%1- zy|l$-oXR}XZ?Wv|7HBrNhHItw$r2R5Aj?o(BQ+@A#q|MA@#A{wDK=#&*8G^POcrof(fZ<6&mp&9ujvW~JEpn-moPHzs~fDdB%fDd8_L?G)2wwxEj5ET)3{ z4B(fz+7!Ry(o{cfq1Q2^?W*5LwUgf9zBB&p-=m#wjf;>R#Nc|}0VcD7qoVK1tYrEOH8m(?U#bZxdRCA~*v?^xn=V;w% zELvxFpF?-uI9K9?yRZ-5fJ-?&wKx{)f21db6x?!L!=uX6;~GwEh}tDsA#+jnXvjdG zAG*ySP+=0rT{O;FoR3Y;F=QvKrpqf0)D|-nluO(mnUHRp-AJGGh1rVqNuL>uJ~ak^ zHB*9&Ngtc7h)DX#Y(@H{%i~-j(igK%vO9QA40iI!oYkXxH)(Awb7{f=_o_Jw%v?Ha zhS7o6GsdD*#^BrLdC%cI-E6Hw>o?6-O2bjJmC}$hTPY36aW3B(6XxDSoxDW6>CB_p zGJSX2GE&$`-IDW&(Ct&~#PY^9Wz z=r7{Yay+%nVs3id@wnk&R6GGv#7-c~)}T*Q*~M@}Pc6)K~^q2NC=d4zDr)P;8t%K4~cMx4+$CI=&>NaMz_G2KS22D{W8GQ z`fTBjS@R*$QOv<}ffi^Z58?ewkDh^^*+V#BSc#5*wKJQmfA@*6q!pB6Ai+4&1% z?a2Z$dKaJVND4)w_KUb#Eo-ya{SO^gim#^Sre zL$&>(q3A$ucYI`Ec(>dgibdg%k^|9@JP_@R4?rOP8r~8375U2C+n*PX$aq%r?;XL{ zG5+!tG_~n0U}~aD>gH0dCUYH^j6evcZ(#XJ#GzK<+1b zm!A4Ez4W_7iEsj{GZ=-hGQC6bet9tTXjraa(}cxzd4@d+vI@Spcml>test>14-3-nsubstitute-if.test ;; ;; ;; Syntax: nsubstitute-if NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (nsubstitute-if 9 #'oddp '(1 2 4 1 3 4 5)) '(9 2 4 9 9 4 9)) (equal (nsubstitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) ) ) (do-test "test nsubstitute-if 0" (and (equal (nsubstitute-if 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(3 -3 3 -5 3 3 -3 3 3 3 3 -4 3 -8)) (equalp (nsubstitute-if 1 #'zerop (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 )) (equal (nsubstitute-if "*" #'characterp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test nsubstitute-if 1" (let ((a "seedhead of common sunflower marin county california nikon") b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) ) (and (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) a) "seedhead%of%common%sunflower%marin%county%california%nikon") (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) b :start 10) "seedhead of%common%sunflower%marin%county%california%nikon") (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) c :end 50) "seedhead%of%common%sunflower%marin%county%california nikon") (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) d :start 15 :end 40) "seedhead of common%sunflower%marin%county california nikon") ) ) ) (do-test "test nsubstitute-if 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (nsubstitute-if 'z #'evenp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (nsubstitute-if 'z #'evenp b :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if 'z #'evenp c :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (nsubstitute-if 'z #'evenp d :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if 'z #'evenp e :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) ) ) ) (do-test "test nsubstitute-if 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if "**" #'floatp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (nsubstitute-if "**" #'(lambda (x) (> x 6)) b :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (nsubstitute-if "**" #'(lambda (x) (/= (length x) 2)) c :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) ) ) ) (do-test "test nsubstitute-if 4" (let ((a (list #*10110 #*00000 #*11111 #*00011 #*10001 #*001100 #*101010 #*01010 #*110110) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if "!" #'(lambda (x) (= x 1)) a :start 2 :end 8 :from-end t :count 2 :key #'(lambda (x) (elt x 2))) (list #*10110 #*00000 #*11111 #*00011 #*10001 "!" "!" #*01010 #*110110) ) (equal (nsubstitute-if "!" #'(lambda (x) (/= (length x) 6)) b :start 3 :end 8 :count 3 :key #'identity) (list #*10110 #*00000 #*11111 "!" "!" #*001100 #*101010 "!" #*110110) ) (equal (nsubstitute-if "!" #'(lambda (x) (= x 0)) c :end 5 :count 2 :from-end t :key #'(lambda (y) (elt (reverse y) 1))) (list #*10110 "!" #*11111 #*00011 "!" #*001100 #*101010 #*01010 #*110110) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..83ed1a499e2fefe0c441fd317e9107dd167d5247 GIT binary patch literal 6187 zcmb_g4QyN06~6D!v7MxKLK2|AZXv94>q0`>&>%`*oR=o8HPb3CXi6L)vDls`UaMucN(;BZnJ~3hebIUC-Y-(H8+}6^v z(%q>?f&%T5KH$*Wb`$u_9-WaqV~nvlJB7r>n1?AWdpPa!MU6<*-`O2B{2{%^@MWj7 zX(#03k421dHeJ)~O^uEFt;Ftxh3Sk=GKsP5p|rCz779eW%}_QY?USmq2h-KvA%8EV zrmr`c?98Dcx|B_Onp*rf`$LgfdnDQ&jYSQ1bf)qi#vBh|INwY@w?TS#7yI7x8{|!k z=G91=<+4=NR5FI-^ofWq+0NKbw`Pmmip8KBaaY)?g`iT<8N~2`l=E);lKA%=NNew@ zsFRYmMU448x1t22v9x@+Cpu7QdQj>rNLN@xR<&6R z(w(TO&ZqvU^&_j!tg|siwio0J@tJkt1Suah>nP{XnRS<)wETpfbS0)LQZ6KzPaaBP zCoQx%!UyA(3z=-SNp|0GFG}&Rtm8Bb*RSgRU%Ypxrhg)5bbpuX|IXV)8OL_n7#e}h|!1YC-~J!?&h^f_VTNc?BaDu)(Y1);o2m~ zJRxilBR3KC9TKYN#por%RDUYS;{>f9BWU$7L908kGDcra5B9=L>UJD{+z3R?Fb-D; zI5)orN7ejVAj(T5R9>Vxl;=sOJS%ilLiY(F+#-Yvh0sM|C=wC*T|xdxCh|iRoBSZf zChw=%lM^cbN?2MI;mDjb4>Gz+pokP0G9#KPVt z6!y9xzZK*u!embpCVQCIjq>^t-q6SESM&PCynZ*7#1V(GY1EK7+6vb|M+mzuh(nXl zN74pT6|a3bXhDa7-qC?&b~J%X*=Y15zXEtIV8%jZ_c7EMp$^o{;R}#B`9dTbUxbA5 z#Xz+8xEIMgVD9V;n>~KvqrHOjM7z4fh@hP%AMK3r`8nZfF9_Ek;JlHj9>#gK@9-r^ zo`aV`>xlLA^yja?xeT;8pNAG(C^>DTAgvUe)*|Lv36o2=q1AFR)%5_Ubebk_MB!DS zc0>$(*Kp_&PSxnN76lc;3AYFZUMq4^&tXE;uVA9SMJDPS<(s4n5xVNCOI4d};1 z$i!Nz4G^*#?52fR6}}Q=%6q&S$-fY#olumw_>Cxfli!5o_q++otHSOqzZpj_^A;pO z6K~f~D0$_$K>UKR{5)?(lfwe+pa8p9fPGe&>=9s}6kwwQCCP6wn~6C z3$Wz^Y?&~*PJnp@SUrKsuM&#R<&}ce3!#Tb(mw^+Pwvtl@{=q^?sK z(|rCg_r>{wAYTGAHSxu9Fn4?^o32eICR5&BlT(9}sgcxFD&fVYaO}>e7e`UEbg#bD zJ3IhCW{12ZyTtEMlE1QETq75Ju!6bz&g?(Hxt4mT~`4!$TY8)D7>D@5&WoCZSF{!|DN>sbgc zqd2Havn3&-)&H)g_RATj={wGQ*cBI1J6Q;H5(rPW8vZ6SCDs1H-6)lJ#7w#yosOrb1NJTPHq zJSRGMBa%(LQOv!u*l2z6VBrj_(AU8ayUVCm$*v$N*d)>ZUZXcxuG%7Ol5+D0W@nrFo&7DML9iYq>t(|FdSSh=1bZ;v;UjAwqE#OtC&vLCNwZ+>yC9OhHJV9( zD~C3apIiDXp-FEFv{$JGPov|R0(-i^K3P&M>5+29!Yh~b5EVa#U)Eh zwR@3*N_YuTI&`6Q6-b?6>vR^|F18U+>I4KQB2*XK=B04bmd?ihK`ER8H};nT`&xnh zb%A}RBuDneY`U%FzT)?iC_XTmnDoZS#z)|$GCVOh>Kz~0p71uWTJ0Sh_6C9}{LR9S z@ipVHNxEFBOHs9Lz{1up0UNbhm)2pksZQCxjr7mrLK`LDsFMAm0dt-L? EzqiVpy#N3J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST new file mode 100644 index 00000000..d513af5c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nsubstitute ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 256 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 25 ,1986 ;; ;; Last Update: Sept. 25 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-nsubstitute.test ;; ;; ;; Syntax: nsubstitute NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; OLDITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test nsubstitute - test cases copied from page 256 of CLtL" (and (equal (nsubstitute 9 4 '(1 2 4 1 3 4 5)) '(1 2 9 1 3 9 5)) (equal (nsubstitute 9 4 '(1 2 4 1 3 4 5) :count 1 ) '(1 2 9 1 3 4 5)) (equal (nsubstitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) (equal (nsubstitute 9 3 '(1 2 4 1 3 4 5) :test #'>) '(9 9 4 9 3 4 5)) ) ) (do-test "test nsubstitute 0" (let ((a '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (nsubstitute 8 3 a) '(8 2 1 10 8 8 9 2 1 8 10 13 30 8)) (equal (nsubstitute 8 3 b :start 5) '(3 2 1 10 3 8 9 2 1 8 10 13 30 8)) (equal (nsubstitute 8 3 c :end 9) '(8 2 1 10 8 8 9 2 1 3 10 13 30 3) ) (equal (nsubstitute 100 10 d :start 1 :end 10) '(3 2 1 100 3 3 9 2 1 3 10 13 30 3) ) (equal (nsubstitute 200 20 e ) '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) ) ) ) (do-test "test nsubstitute 1" (let ((a "abdefgbcdefegAbcDabGecba") b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equal (nsubstitute #\* #\a a :count 2) "*bdefgbcdefegAbcD*bGecba") (equal (nsubstitute #\* #\a b :count 2 :from-end t) "abdefgbcdefegAbcD*bGecb*") (equal (nsubstitute #\% #\b c :count 3) "a%defg%cdefegA%cDabGecba") (equal (nsubstitute #\% #\b d :count 3 :from-end t) "abdefgbcdefegA%cDa%Gec%a") ) ) ) (do-test "test nsubstitute 2" (let ((a (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 9 '(d w 2 4) 'b 'a 7 7 't 'u 9 0) ) b c d ) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equalp (nsubstitute "!" 6 a :test #'(lambda (x y) (and (numberp y) (< x y))) ) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 "!" '(d w 2 4) 'b 'a "!" "!" 't 'u "!" 0) ) (equalp (nsubstitute '(11 22) 'dummy b :test #'(lambda (x y) (and (numberp y) (oddp y))) ) (vector 'x 'y '(11 22) 0 'a 'z '(11 22) 6 'm 'n '(11 22) '(11 22) '(d w 2 4) 'b 'a '(11 22) '(11 22) 't 'u '(11 22) 0) ) (equalp (nsubstitute 99 9.0 c :test #'equalp) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 99 '(d w 2 4) 'b 'a 7 7 't 'u 99 0) ) (equalp (nsubstitute "nlist" 'list d :test-not #'(lambda (x y) (typep y x)) :start 10 :end 15) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n "nlist" "nlist" '(d w 2 4) "nlist" "nlist" 7 7 't 'u 9 0) ) ) ) ) (do-test "test nsubstitute 3" (let ((a '( (1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) (-7 0 1) (2 2 4 4 6) (3 1 4 2)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute 'same '(2 4) a :key #'(lambda (x) (subseq x 1 3)) :test #'equal) '(same ( 5 3 1 2) same (0 8 9 1) (-7 0 1) same (3 1 4 2)) ) (equal (nsubstitute 'fun 2 b :test #'> :key #'second) '((1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) fun (2 2 4 4 6) fun) ) (equal (nsubstitute 'foo 4 c :test #'= :key #'caddr) '(foo ( 5 3 1 2) foo (0 8 9 1) (-7 0 1) foo foo) ) ) ) ) (do-test "test nsubstitute 4" (let ((a '( (1 2 3) (-4 3 1) (3 5 -4) (6 2 -1) (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute "@" 'dummy a :from-end t :start 1 :end 8 :test #'(lambda (x y) (plusp y)) :count 4 :key #'third) '((1 2 3) "@" (3 5 -4) (6 2 -1) (4 -5 -3) "@" (0 0 -2) (2 2 -4) (3 1 -4)) ) (equal (nsubstitute "?" 2 b :from-end t :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '((1 2 3) (-4 3 1) (3 5 -4) "?" (4 -5 -3) "?" "?" (2 2 -4) (3 1 -4)) ) (equal (nsubstitute "@" 2 c :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '("@" "@" (3 5 -4) "@" (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..13ed8013c283203d7c10517925b88af740b28b9a GIT binary patch literal 4736 zcmb^!3v3)$@$K$??X$6+_(GjH+19ivm#h^hcI%`qczs^m7vJq3dwX$=0`zL1bLVVq z=X?gLs!a(w3CY|+k_yWp&bmQ0 zljPQ}s{;!6?%L7QS?8Xp3QaSFka2PfL70#xA`$0!r731<8A};VBsE1>Q(DYfbSfdp zMagC~)2TFXm&-G=ik<&*-o|te&JlqS=NpyKU{;S?2}5_5gd;-4d9u=w(3Lc#rVeRD z3@uwh>w;5R+tsb?P|`*wfhtO3P|*#GoTxS&CB*j}hV*jbmEFQi)8vC!cZ;K+Y-<+$ z`&pdGYaqmy-0%OC99yBmt{4G&(5)RxC~hp3?1) z+$E#&nH#2$&b573i$sD5L%7~TZF<(AY(KFdUkQ-Nu%)%LKX`P zM&oW#0R6?2>qgtqK0YBrAkWN5htq1mSv&aDKxmD%gfRCyq8D4z0Ny5589ILv;A)hJGRa`rOHxzbjdsY+uNc6k4&#oroF{3|r z<6uTcgt@ShRrJ{CMY?$9|6|`m*F>+@xQm6RViOVToo`h(#NviNzz5l|st+VJQ|V6t zMIXw<#0DA`!|;UQ@x$YTA=?~_t5$qiF*Pe|!jO!!DI3U)Wh^Zv3Rg;4MvT@=5gL~2 zV6ZmEG}AOp#mHLetQC_QK_L=T^)ZFfGcgJiwz=o>K^>6@p*|eXah$Rzz*1n)FjK09 z=+o#mo;6KPUp4-zfV{_mw{|7TxSG+pD_W22QLyxh%Vs&!duc0zyO5n3OZ6K`#d}F0 zeLZJ4(fub_CN&)%h(R3WtgRfZ z`_$SBy%(1sQ_A>J${G9m_e#ra?^IT*ab63-8O&q%Xb)D z`&mgLHV-fPfR6Q&M0Ap_M_>R|8qvmZKf*o(Oe3Z6V10wgT;6Y^8&GBoko*}-HCfSh zfCrzRO)`s7x(Ov3ffngcSPH*zC5=RZ@uUxd7vyv#OJ`_1g1^y?2>!x_-o~(#iHyZW zva}6(Nfxg300%J;k>V<=rp+ucsU5Y_$!vycHPKI@RvqU_zzd`jI%kR>Fzo@<7SAyW z@jcYm_Gmh4i+^NciEq-)i2aU>{0c;T#=roR_&SS9JjTKi=Q((g#V?xZEn}H5KTuue z#_nf1ikrDiGshwv6G0=AG)7_Yu--%$!oL|$_y^sB*dI9fHuEbiF^2+oFC1bXgalX# z#f?-tsqJMJ9^mvg2FNd&DtV2mlIJ-%LE8_~_Hj&2wTu*o9@Mj`e$7m)XfB~!+7KW; zw0#S`dmX*|GZ2ig>Qq|F`8oI=E>7o_;-oS?Q_7wc(p!-i!GfyQmFRX5`5&akJ={URMy+MgAYyQQ1^;K2(Jf$4MLcO zPDR)&t$|P_EolV-29laSWDVny2KgnViLma8?F9YyRY|B1UoWR`)Caf}myPVGlH0Bx zeBnl|N^9snL3*!9dm$zWPn15<|K+p!APfngBu#>cH+SG;e=WJMt`=__0%w_K#2C z_B+luMNz`tGu+1x+&^`!@BHas<8Eoechq&=3%Gy8c?Mk^uWXE)8q7}RvUf`|VQHqC z%+PusiT`t1!_s&o+fF6QYG-z4u2?S4Onddi{1qrmy~9}wK|GQV7C*ZE4{jP@2}EF# zC0LOBUKlp5h}C0VNnyGVfcP&Ce#5~FELsXbY(#4CzWu?qg200nzsrIU$DE2fS}2zD zWhi5LA`d?U=cgy|$6)S&TrTDFa;_|wzf!b|`wQhxSQ z6YXVb4uM`J5mtO>`NzkN6*()wQ7jU%m)q;El4h*K7l#*zo4DcY)gS!SyQFgjHhI)! zdRSHB!>Xx3uhc&wGcO(7%cd#`pqJ~JzPu>~kxucVhEFHVUwEH`cR2XP6}KY1aIIUx znh<`%Zbg`KmKqk=<$t^o3NJKZ8GO7DRK49sPGBo87dYem0wS)oAYmT~lXMQjLmYgO zgU?q<9UDlYb2oEC>@Y*n5Xm&W9(nG9!A7-xQn}Pi3|GZis2|X-17gP&c#Rr+@N@?43aZf)DrpAwQ6Y_+&g)Tc0F7r^?mll zg`2tqFhPniqa=6(h4GWz9}eL*xYt<+b(A*EOu}8OTkc>w68{lOCu*w JV{|86_rL2L9i9LH literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST new file mode 100644 index 00000000..3d02b322 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: position-if-not ;; ;; Source: CLtL Section 14.3: Modif-notying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 27 ,1986 ;; ;; Last Update: Sept. 27 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-position-if-not.test ;; ;; ;; Syntax: position-if-not SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the ;; indext within the sequence of the leftmost (or rightmost) such element is returned, otherwise nil is ;; returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive integer or nil ;; (do-test "test position-if-not 0" (and (= (position-if-not #'evenp '(2 52 44 5 3 7 8 9 0)) 3) (= (position-if-not #'evenp '(2 52 44 5 3 7 8 9 0) :from-end t) 7) (eq (position-if-not #'integerp '(3 4 5 6 7 2 1)) nil) (eq (position-if-not #'numberp '(3 4 5 6 7 2 1)) nil) (= (position-if-not #'atom '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 6) (= (position-if-not #'(lambda (x) (>= x 100)) ;; ;; create a list of integers from 0 to 249 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 250) b)) :from-end t) 99) ) ) (do-test "test position-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) a ) 2) (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) 7 ) (= (position-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) 1) (= (position-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a :from-end t) 3 ) (eq (position-if-not #'complexp a) nil) (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) (append a a a a) :from-end t) 37) ) ) ) (do-test "test position-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (position-if-not #'lower-case-p a) 0) (= (position-if-not #'lower-case-p a :start 42) 42) (= (position-if-not #'lower-case-p a :start 49 :end 57) 54) (= (position-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) 41) (= (position-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\space))) a :end 60 :from-end t) 54) (= (position-if-not #'(lambda (x) (char/= x #\W)) (concatenate 'string a a) :start 1 ) 65) ) ) ) (do-test "test position-if-not 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (position-if-not #'oddp a :key #'cdr :from-end t) 3 ) (= (position-if-not #'evenp a :key #'cdr ) 1) (= (position-if-not #'minusp a :key #'car) 0) (= (position-if-not #'plusp a :key #'car) 5) ) ) ) (do-test "test fine-if-not 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (position-if-not #'listp a :start 1 :end 14 :from-end t) 13) (= (position-if-not #'vectorp a :start 6 ) 9) (= (position-if-not #'bit-vector-p a :start 5) 5) (= (position-if-not #'null a :start 10 :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3)) )) 13) (= (position-if-not #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3) #\2) )) 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c87410c153d4904228129df5c62f9e3e11b4b3b GIT binary patch literal 4707 zcmb^!e{37o`Q4rE*s-0ZKaxWF>)HYZ(@UE+Z9}_>T%1ed*1mJk=eFq(n@OD5$u-Fw zXK0(&Ruw3kYUt7o>mCRYpiOKNQ?aHo2BVXZn5Ka=jlq!ECQZ{S5SkXL6Mu}B+xNYf zBWW9L%SfVo-|t`Veeb*T4Dlb2C*}C~$%&$!FUjLm<%y}XJTzXCC&#Bs19^D}`0}^n zhN*qKPmLdLJ=j*CStJ=K<#XlyplnU$CkJ!i*de#wBdZgoq76t#2as(C_U=B=-ric@ zqh^xa+kdqIgN_5ccD2^KPgaG-aYD!dxr87@NF$MmbD`20v$Tw*^dyp+qN^z_=FB*i zAk?B{Gn(mCR_&I{;}eRV|9alWa!yVXfe`1rm0(X+k6Q^tcV>k%Lc}>=i6(R<4W+5Q z8WDr@UeLSXR2tjbl|4$@$RyB2N%W8>tI@NB_@2UaeqMOxknr*tnS1q+c82Th+8WxlG*`0A-Ir7Zel|7A3*=ii;bI%6rMM< zI6LkINzs#Hh~V<}2)s2fb!TS^jm1VHhMmVM8)9)o@8*-MPu07VnyGXpfTQM7AV5+W)#Z@cbrpI!2%$cl$6YvDFMy{&k71@%3(4~sHJ&w1 zO?_!-irango&k( zX){pLN1S?(Q_o?3N42m-!O@$*B)G z^+!&OOJIKqo8j_?eNBaCyE0@kjk)0*B5A%qm?_He_4oVt^PTR8ABK>o~}lJ}WY z@*C!qJi%q>>8;>?kT##7O&QvppiN!0c|UF1L7TVGCfK}tA(n3vLi<@CAvFT8@_>#_ zl0@>$bUlI|;7W(Je#E=j%ic6n3QyMeB^1u%chU{0vkh4OjHQ~a(;De!WCkHnq$^=5 z{EU?}Fr`nJOu7QHI?iY8%XA}3|3Wt*_!C!p2b6*d-O_qBlW7^W1;srqNohX^w}F-v zS6L5jVd+TgfE7q3^lXNiMd>y)t7Ag(8VLRAB$tVE%(@$`#lLffzXHo=ba$hz_%2IK z{4Ko$skgYs>*zu|s_9H+nq?)PV(EzE9GqY!h)K{4WGoX#1==6v-uAIF#VuSX%&7pQ zgsWf?$wFtC3cH3FLih)l{f)+u`W**V7FT$L1r&IAVU$G>;&dx&?&s862FNd&0eOiT zkmu=oP|jf~(D0db8dL2_8mg7P7tmnbNTrk7@$??L@h-Z39o^2l=bTe%DCZ~P)3!L4 zSBgV&JH+u#JC)5Aa<`sRx5`5~_|_eii(~vV6?vy_N3}$iv~Q0_iEoZKmm2`$iI47PPVQdOylH!o?iK02`3yI%K!(yUoQiLw{Yx(UMvU-w0NJS_5_1!TPM8N%ZPkx6;*bX#yxk z)$T)CxZYh!?acG&;s;Je8Xg!#lsexNMG3LTc#J)W&pgz5_06{sdt};o)^*)$h)+3B zV2BHqO>t9$>8jlD%1I_H%~X>a8s?e!k7Nx?rO9g+65Q<`4t7>a1A52j zU3=5ALx=%5t6(Cf_F@Q;esey`ZQQ;5x!u##3r-uk)5z!9kO=tstcUJ& cW}l8iH!o`vzyJUM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST new file mode 100644 index 00000000..c83cabb7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: position-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 27 ,1986 ;; ;; Last Update: Sept. 27 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-position-if.test ;; ;; ;; Syntax: position-if SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the ;; index within the sequence of the leftmost (or rightmost) such element is returned, otherwise nil ;; is returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive number or nil ;; (do-test "test position-if 0" (and (= (position-if #'oddp '(2 52 44 5 3 7 8 9 0)) 3) (= (position-if #'oddp '(2 52 44 5 3 7 8 9 0) :from-end t) 7) (eq (position-if #'complexp '(3 4 5 6 7 2 1)) nil) (eq (position-if #'floatp '(3 4 5 6 7 2 1)) nil) (= (position-if #'consp '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 6) (= (position-if #'(lambda (x) (= x 199)) ;; ;; create a list of integers from 0 to 249 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 250) b))) 199) ) ) (do-test "test position-if 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (position-if #'(lambda (x) (> (realpart x) 8)) a ) 2) (= (position-if #'(lambda (x) (> (realpart x) 8)) a :from-end t) 7 ) (= (position-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a ) 1) (= (position-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a :from-end t) 3 ) (eq (position-if #'integerp a) nil) (= (position-if #'(lambda (x) (> (realpart x) 8)) (append a a a a) :from-end t) 37) ) ) ) (do-test "test position-if 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (position-if #'upper-case-p a) 0) (= (position-if #'upper-case-p a :start 42) 43) (= (position-if #'upper-case-p a :start 49 :end 57) 56) (= (position-if #'(lambda (x) (not (alpha-char-p x))) a :start 35) 41) (= (position-if #'(lambda (x) (not (or (alpha-char-p x) (char= x #\space)))) a :end 60 :from-end t) 54) (= (position-if #'(lambda (x) (char= x #\W)) (concatenate 'string a a) :start 1 ) 65) ) ) ) (do-test "test position-if 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (position-if #'evenp a :key #'cdr :from-end t) 3 ) (= (position-if #'oddp a :key #'cdr ) 1) (= (position-if #'plusp a :key #'car) 0) (= (position-if #'minusp a :key #'car) 5) ) ) ) (do-test "test fine-if 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (position-if #'integerp a :start 1 :end 14 :from-end t) 12) (= (position-if #'vectorp a :start 6 ) 6) (= (position-if #'bit-vector-p a :start 6) 7) (eq (position-if #'(lambda (x) (equal x #\2)) a :start 10 :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) nil) (= (position-if #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) 8) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL b/internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..adaca5a2ec628bfb0a53b5ab406ca515e06eb9fc GIT binary patch literal 5399 zcmcIoeQZV`JTiHck7`+D%%e{(;mNa1{;~VH7Os0BMKp|=nToup`OG@&n}NS+B3W>@#vR5P3t}S;7~FJgLUhGZECrD zbxU*eDtEgc4GM3cX#)o9T2`-J<<1|Umg)uwAv?)ABrZbgh)k?wnL4j&L`|)|BWP$L zz02@gQ&z?abJ1c^BVuLhS9?YV2DMbrzMd3Lr+=78gjh#2&h}WyXLf``R#qC5YOEuf z+K!Oc4O7!M8H73uUeLQ_W!z28+8V7p9PL08a(ue>AR+2j%;ojoH#SSJr6u>9o9WiZ zh4qq}qKMZLl2Y?8zDiyY{6mB!YXGZ7Y&<0wbdL3&*^fi~feQS=5rxUqJByQdq#URUj#4ttq6%kw&IT!h6v0#dmy4S92s#m* zvOyR6sN-{*o6n8*Uny#ExjSq@Jz6xNV5&Eh zT8aU1zP)3~Vs((-m+BA3Uh(@g>Jj^xrb&IEY9bGvkGWF*EBe6G|i za9@NSrIz22=_vDx({Yu0Yfpyv_jLay3=XI*;P1mXQ!6S2Fq!>jFj$Ed?a1f0@43nX zM9A}wLaVW;E{?!^#r~gZn)kLu>wU}QaXR-cjAs_gIb{Dh94Z?wo{_Ppc zeIQNY(l6;Ii~87I{yLqQp>I1cL`%Ab-`v9mJDa3vv0`x>oS9_O4fWcS&#kKzQ-HV_ z-qT#;)pAIzue7|b?Tvvqw{f;jWvaI>Sx0EC^-N}w*B1`?`F^Vf^pHPjM6|XJKth|M zUg}~l>V%&Iek%MFI1B2%KHc;Mw1{EGBCwbH_+d~LjYmzRi%OLmX4uQBVvVuWU#QcObGJs_KBPtvDH4H1e}qu2qSoW&yt0Og;o0m<8fZcYkzK$RAmKL> zev=7>aos2%!`e{&v97Lo=|Y2I6#awWULxTx%?SAsxB!3}HT4J=pJxjZe3#vZ%u9gAXYiRr;^ zMB|{L6tgvjaknsD%f5gbcd?~NG`0-M7lq0)t|Fgj^8u9q!V4q+R*)Rl(5L(TSata{ z_aYzX(dB9GMLr5D3aD_6!$RW`AsS-K(QH6~_Y1SF=(4>d!iy@KLe|Pwpymd_-GTFp z8u*GLdb>d9prIM)h;Xo)gY-8%Yx*;uF8z@pCwTqnIM0F(qc>kbk8Iok-sqqZ-iO{0 z<=|GKsxvRDY~-Bu3HL2sZv+|z=4Sa3svdq8k;!TAMu zr{ETHLf+-^$RBwi@=HNp;VmOC^OVR0uOT^v$@9iTy5t~RmSQWDY+018>}Ja}wzv~u z)o*3yj`R$Vcm@ZClOxH2w5J*2Rx7i_M0n`|eW_=60=_SHd6H@IX@J-PY?>-h6Gxv8 zXIdSxGPkA@{X2FgP_1Ggh6E_zhpjBNGSW8q#U&XMRNCRx!1Q3LU9z&()`V(}t5#Nl zWm;ndjV|1p&3LzghDS2)SSZ@DDP;Jywzz3Xpj4~-H^<=pY6}`;|F$L+YaF(Fg*CIa z?4B`VO*pM_rwx3s9Ee#HvNbN-8s|$H*gmdy3K|Y;++mwMQ0@c57G_cKQQ@=|=llNW zs~%fZsM~vtzwf^QcYChC86|f=7Vb{nAa~yu?ha3r<*j>Qsp$B~;}!30U@B18+J_iE z0K@ym|6WM&eOR%Oltr*IWFu(a!qQHbmRY(`n6Hb_k607b8mD%{c=eOh#MQbdMdADF zvx0&ZjP~^%$xzC0|!4wyzLki3o9Pd5AF# zp<2)48*(hO*cUN$)6mMUF2N4di0Hv6s}?Vkx+NAi4Y8YlRIvxF0hjW>n1 zEXnXz%2cU>=L)#~WMu_zZCUwXKA*pgk5BONaRIr4%q4u}0jX_V0?!oz{4ST-G;A;W z#cQZ}MWdk*1YL|Xc#$AOe+r#zt&|?oBr6K)*SDf=tKu!7Jpg3sGR}^$L zFk;0BL5T9ce)Fh}?tdY0$Nv%Of?dp$jq zaNDkd%SS-hFj1|W*6>=L6tyg5dx&E%VG2)7wj)W|Nbh6=l=wmz65Xp{NL5rbOW)2L&VPEDwAdhcDQ}r|e(lpt36z44;xEEa^+LgCm&R#e;0%&f9L6wm&%X6GblV!j(&*fbLA+$RKzMr&m4e= ziS$Tv?`V%!`0bzE+f#`qCie!dY!$RR3tIw}s0?Q?kN|&fu(B?RDr%Jj_7O>TeaXt! f$cp-8D+H~glFO-3Wx*_%Gcml>test>14-3-position.test ;; ;; ;; Syntax: position ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the index ;; within SEQUENCE of the leftmost (or rightmost) such element is returned as a non-negative integer; otherwise ;; nil is returned. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive number or nil ;; (do-test "test position 0" (and (= (position 2 '(3 4 5 2.0 6 2 1 9 8 4 2 4)) 5) (= (position 2 '(3 4 5 2.0 6 2 1 9 8 4 2 4) :from-end t) 10) (eql (position 3 '(1 2 4 5 6 7 8 (3) 9)) nil) (= (position '(1 2) '( 1 2 ((1 2)) 3 4 (1 2)) :test #'equal ) 5) (= (position #\q "antique-que-que" :test #'equal) 4) (= (position #\q "antique-que-que" :test #'equal :from-end t ) 12) (= (position #*1011 (vector #*0000 #*1111 #*1011) :test #'equalp) 2) ) ) (do-test "test position 1" (let ((a '(3 4 7 8 -2 9 7 8 -3 4 6 1 7 4 5 -3 2 0 4 -2 7 2) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 20 21 ;; (and (= (position 7 a :start 3) 6) (= (position 7 a :start 2 ) 2) (= (position -3 a :end 17 ) 8) (= (position -3 a :start 9 :end 16) 15) (eq (position -2 a :start 5 :end 14) nil) (= (position -2 a :start 4 :end 14) 4) (= (position 2 a :start 4 :end 19) 16) (eq (position 2 a :start 17 :end 21) nil) (eq (position 34 a ) nil) ) ) ) (do-test "test position 2" (let (( a "Fatal error in function SYSTEM: TASK-SCHEDULER")) ;; ;; 0123456789012345678901234567890123456789012345 ;; (and (= (position #\n a :test #'char=) 13) (= (position #\: a :test #'char=) 30) (= (position #\a a :test-not #'char>= ) 2) (= (position #\F a :test #'(lambda (x y) (and (alpha-char-p y) (char> x y)))) 28) (= (position #\R a :test-not #'(lambda (x y) (/= (- (char-code y) (char-code x)) (- (char-code #\a) (char-code #\A)) ))) 7) ) ) ) (do-test "test position 3" (let ((a '( (1 3 5) (2 4 6)(38 5 7) (4 2 1) (-3 -5 -7) (-2 -4 -1) (10 22 31) (38 72 10)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (position 7 a :key #'third) 2) (= (position -4 a :key #'second) 5) (= (position 38 a :key #'first) 2) (= (position 38 a :key #'first :from-end t) 7) (= (position 0 a :key #'cadr :test #'(lambda (x y) (> x y))) 4) (= (position 0 a :key #'cadr :test #'(lambda (x y) (> x y)) :from-end t) 5) (eq (position 0 a :key #'caddr) nil) ) ) ) (do-test "test position 4" (let ((a '(#*11111 #*0000 #*10101010 #*01010101 #*111 #*00000 #*1110 #*0101111 #*000 #*11100 #*01000) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 ;; (and (= (position #*10 a :start 4 :end 10 :test #'equalp :key #'(lambda (x) (subseq x 1 3))) 7) (= (position #*11 a :start 1 :end 9 :test #'equalp :from-end t :key #'(lambda (x) (subseq x 0 2)) ) 6) (= (position #*01 a :start 4 :end 10 :test-not #'(lambda (x y) (or (/= (elt x 0) (elt y 0)) (/= (elt x 1) (elt y 1)) )) :from-end t) 7) (= (position 'dummy a :test-not #'(lambda (x y) (find 0 y)) :start 2 ) 4) (= (position 'dummy a :test-not #'(lambda (x y) (find 0 y)) :end 4 :from-end t) 0) (= (position 'dummy a :test-not #'(lambda (x y) (find 1 y)) :start 2 :from-end t) 8) (= (position 'dummy a :test-not #'(lambda (x y) (find 1 y)) ) 1 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..893d50d6e2813c8db0dbaaf5029933de770e5d80 GIT binary patch literal 4732 zcmb_g4QyLi6~6C2JF%UlO-9y)^e1nDl+K;Qk~OT&*qRsTC2{IJr_XlR6e@5XCvoS* zR-Ck?s9RMP!jGFSv6{VGs3;YaKpIlkNfV`oRVo5h6*Qzx3?VVl5JOBzV<5zTIOpEy zpE${2kXFy`MTN=;8GBgsi6ot&PG#*`6= zE1&iT4DEEE>OIi%NUJMYghVG}k*V0Q5}J;sha)o&D6RVxH8mMez+mrQa9cat+dB5_ zX>s+aLBC-8k2O%Rx1+ti#kG8SQL0W7LZaj)G)_XQiA>CeOtm|t1w)=5pI`In>VW1p z=go`**5U~VHN(u*v?)``lqV585li55#?wS1#C$sA=n3oIkT0N{S?P>aX8 z+`Tr621pZfUb>MBRpmpE=0X%xD+{Y=S_uGJP(L3R`ZsJ1v?aF&hczwC2P?_T>{vT| z--As;2I(}M1n1ylTd}Tz1!u2M&bP=HW7ZsAa`@u ztHthwp1bYZt9F%HmE={dw6;SKtW^hX%qJpWTa^w)`9>=iDoU=U)+~Uc zC*VqyyR3UsT$vkNBCqY%bCLBdZXoD;FHOEMwzOrfCv|?TI$lj^m3c9<&Fu~7-99|M zJbkL(?bi%Xmk%O(Z_rJh%t;+^mBVF+%Ld0}jT_D@Zy%gsp|AnRoR^=IWx=6fNE@Ki z>Womp%_`&y=9KYh+~n2_BVc#};m}|>;cz*N=~Fb32Rx<_zUZ`d$2z32dE5@J5UY72|>szFUm#VQcqj!fFYu<9Q~w*lQl znl}_Mz?J{V?nU!9+k)m50BcsA+=$!;WOHz6pex|_ko%3ad@Cx+hruF;=g$x_(x#vU(4z+sf+pgJj!&*kn8J67(L1H*cAaE#OCY zH){YR{}`gOrg!7`4vg)=kZNF$$lvF0Y9lbbH z+aWVkKNU+)DU-4Bkq0J=b}LkaM@-2YuJ0aKP}?BzDO!M;oC!nYq^@3nXQS)__5&# zE^*aaNuVG2S!rgenUM~|HAKr`n`N~tNLdTuupapvCAyxqbbYl%$K@g&pZouHu$F>^ z6GhuJ3Dd$(=5B{PQ6lfSC2weBCG-?Y=qi!$Sc!xV(Gl`TEGcazJ5^c4xp9;H9Un%g?msj%AyDNF=4=vvBS-iJOcyEH=iCqqR4P8LLRW#34 z^Gnz=3z;2WIGsY8r{uNi_k}b=^#@r6romx+FdPVJ;+V>=|A4mPJQvt5G)K*>-OS1o zm4U(rLy4MMo6~{DPN^)}FzetV*_>~8@wM_lwtSgi(|bdGl=Ty_-hMOdTqS_Y@M&SG zkU*JGVkwj*{#eT>%**BfH<=&Zm?g0Og7kLAkNQS_m)Jg#$2!F3SFgYMtth*aZ@%=J znW;-p#7@m9!NlOu=wxy_IyRg-K7K4R0$I{+Gjl({0*}Q8hZK=AqYNigu^Hv~^muAU zITlHejZ7!7;3n`*oC+dUbT}D1UIIVIVwm-;nW>#PwRXxyk@D24B}u9Em-HaACd88V zm|2%3+vPHc(?$vO4`Msa?B+sHwprmikqfDm&W-EXX z3W>!A?!+u>6jV5jDq^Y{_K)r05) zE&%q_oci!u6$m_t9lnr}RCW?gmoQ#ox`ol$NtmFVq0rCs-!JgrFBXk6d@O#?!ws=> ZUu3V&I}i8fJ@82@x0hT(B^Q^M{|!S<`~Uy| literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST new file mode 100644 index 00000000..c07cd640 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove-duplicates ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Sept. 22 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove-duplicates.test ;; ;; ;; Syntax: remove-duplicates SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: The elements of SEQUENCE are compared pairwise, and if any two match, then the one occurring ;; earlier in the sequence is discarded (if :FROM-ENT is true, then the one later in the sequence ;; is discarded). The result is a sequence of the same kind as the argument SEQUENCE with enough ;; elements removed so that no two of the remaining elements match. ;; ;; Argument(s): SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test case copied from page 255 of CLtL" (and (equal (remove-duplicates '(a b c b d d e)) '(a c b d e)) (equal (remove-duplicates '(a b c b d d e) :from-end t) '(a b c d e)) (equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr) '((bar #\%) (baz #\A))) (equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr :from-end t) '((foo #\a) (bar #\%)) ) ) ) (do-test "test remove-duplicates 0" (let ( (a '(1 3 5 3 6 8 9 4 2 0 3 4 2 3 1))) (and (equal (remove-duplicates a) '( 5 6 8 9 0 4 2 3 1) ) (equal (remove-duplicates a :start 3) '( 1 3 5 6 8 9 0 4 2 3 1) ) (equal (remove-duplicates a :end 10) '(1 5 3 6 8 9 4 2 0 3 4 2 3 1)) (equal (remove-duplicates a :start 2 :end 12) '(1 3 5 6 8 9 2 0 3 4 2 3 1)) (equal (remove-duplicates a :start 2 :end 12 :from-end t) '(1 3 5 3 6 8 9 4 2 0 2 3 1)) (equal a '(1 3 5 3 6 8 9 4 2 0 3 4 2 3 1)) ) ) ) (do-test "test remove-duplicates 1" (let ( (a "sneezy SleePY grouchy dopey jumpy bashful")) (and (equal (remove-duplicates a :test #'char-equal) "nzgrcdoejmpy bashful") (equal (remove-duplicates a :test #'equal) "nzSPYgrcdoejmpy bashful") (equal (remove-duplicates a :test #'equal :from-end t) "snezy SlPYgrouchdpjmbaf") (equal a "sneezy SleePY grouchy dopey jumpy bashful") ) ) ) (do-test "test remove-duplicates 2" (let ( (a '( (1 2 3) (4 5) (2) (3 4) (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) )) (and (equal (remove-duplicates a :test-not #'(lambda (x y) (/= (length x) (length y)))) '( (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) (equal (remove-duplicates a :test-not #'(lambda (x y) (/= (length x) (length y))) :from-end t) '((1 2 3) (4 5) (2) (9 8 1 2) (2 2 3 1 4)) ) (equal a '( (1 2 3) (4 5) (2) (3 4) (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) ) ) ) (do-test "test remove-duplicates 3" (let ( (a (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) )) (and (equalp (remove-duplicates a :test #'= :key #'realpart) (vector #c(2 -1) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (remove-duplicates a :test #'= :key #'imagpart) (vector #c(3.0 4) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (remove-duplicates a :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart) (vector #c(3 8) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (remove-duplicates a :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t) (vector #c(2 -1) #c(3.0 4) #c(3 8) #c(-3.0 7) ) ) (equalp (remove-duplicates a :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t :start 1 :end 7) (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(-3.0 7) #c(15 -1)) ) (equalp a (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..35a1777e6f54c1a2e8fee3817c1ae205e53c9c8e GIT binary patch literal 5446 zcmcgweQaA-6~FI2+p(Q`b-Scl)34X8gUa12ZQ5@Am{?w%=fl+r9AoJk9Ub} zOX?R1?n4YE$^wK`$Y}Ev7e=;w!IbEpYeX>3_&t;Iq0I3#{=EwP#V4wQLi*BW9mZFO zcAwN=CuAu7w7yFeAlA^uy0*J8AU<9~AjXwUM?G7&3QS?&1k9=lMQ~-;RN#z_?wHPA zJIQXC&c+Pw#tDdHw-uo1n*ivY77~Y(SfbYm08IuFiGIi#Wn-gjW~{<&0Lz~p@Yl&Yg63YhbXyG=Fc+BUI50Ui;9z=+}YPU3(8Y+(h=7%a)D>uQ5S zW?~t~Mi0!;=j%ShJqDbnuUuDu63zem2A)b^Tr$@yIFt@%fvRc{AJAGP7x-+LlczcJD4%t3VshqgKHI`c4PA`pi|Cz51X=?`{0*k0 z?M@q5f(e4fj`!DS9-9_Qo;mp#H|InIo5=7XHMgEN;xz(8Ex zttqNusQV$B@K***_=o`${=k3<7nzkX#7UkLm1};UYp!RSWSq&!`<(oelW#Ija*k<| zleDIT);&yXVMW5U?g3i6fi77~>sHg+db%VDAY5+1>ZFvyERNm`ZbOc_qD|6N4W{)P*tilcEx6dyOCa(_ zj6__i=zgCrL;iQ^awOlTE0CP0E0LU~tB^cPWh7swtC1Yz28Y3`6mBt))yu8&+^U;f zeF+pikyt`CSzw);wbBN((6~htw|IbCG}604CjOl+Me-5LU;HB{n1t8Rpk#Pf;!l_d z@fGG)e3>~CUu2HN7cg`@s;82yz|PP$=c!H%Uc4L%i3%pxV6IWF{ z#BC08n*;EIRq4<_^k{7I(u3C(RDGB&kJ!fj8r<(z`WcjM;chl?H}`VQ&vMNMuDKXC zCK%PBKdCVVUSbnKV37##vgHtd#nwUiDJK`0C*gVKSNIB_4KTmLan9t>g*DuKIkyWk zLjJ)*lfSXh$uLGEgYdu*qi$@42H@}9g0)T9rbVXt#q zl=_>N(z7sdpBNt>{}&99j`zO?rxi?m{c4a6Y8Jq(uD{v6X%i|hgbxwikl&-PH=JP~ zFlPG-^f%qf3~s{drTG9}$LV|^M`#mbea0ECx*4pKZl}`j;vUuvTQF4_7fVj@4bf>Q|I2nC8%rkB~c>;7Wv)gkAJKM3|XPxa(tpYpS;dpn- z!amW%8ctl@iET}!Yd`^$Y`#GpD{dJFO;1Iyb%t+xe}sRs;-O!F(x6}Dz30z!w~9u{ zRQMAs3E^dD*actzGTClBn=2Gy*qzUHW{bJJQ?4%9*-q=x-fU-Qhg0?!i@97rZ`;{y z(axcZ?~IT@lP%hAxc%SY2J9Db13bx8b5h&O*Iqb}@6tR_0__Joa`|F0n+06H$BrEB zJDkfG4gto}(RA0LM|-=o+4S`hKL?2MF5U!}?i)nBk0EwN;NnUI;j39J7vZ!s?7m^h zvlsHI5wZX)x!aa*VkzPJdw)Pk<=>7d5i)=(vL8Y+)~=i&oh{GktO|zGc3)Q z^z7WaZ#_2#;B+Oej;XW`+}5k0F6CWS`t6 zMaXMMg8^8W?y3$rSb(77vd1L8YFl>^S;LP2tgZjV&s@p@dM z%cDDkHB&6Nr^+P(x61t>sJcWCs!gyqu>`NIf!jevf(}-2t}qh}Ig25GK0f|mMI|^4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST new file mode 100644 index 00000000..2f3d448f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove-if-not ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 253 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 13 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove-if-not.test ;; ;; ;; Syntax: remove-if-not TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: remove-if-not returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and not satisfying ;; TEST have been removed. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements removed from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test remove-if-not 0" (let ((a '#(1 3 4 2 5 6 3 20 6 8 5 6 7 4 3 2 4 6 7 5) )) (and (equalp (remove-if-not #'evenp a) '#(4 2 6 20 6 8 6 4 2 4 6 ) ) (equalp (remove-if-not #'evenp a :count 5) '#(4 2 6 20 6 8 6 7 4 3 2 4 6 7 5) ) (equalp (remove-if-not #'evenp a :count 5 :from-end t) '#(1 3 4 2 5 6 3 20 6 8 6 4 2 4 6 ) ) (equalp a '#(1 3 4 2 5 6 3 20 6 8 5 6 7 4 3 2 4 6 7 5) ) ) ) ) (do-test "test remove-if-not 1" (let ((a "aN inteGeR WhICH liMitS thE NumbEr oF eLemenTs reMoved FrOm SeQuenCE") ) (and (equal (remove-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :start 20) "aN inteGeR WhICH liMit th umbr o eemens reoved rm euen") (equal (remove-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :end 40) "a intee h liit th umbr o eemenTs reMoved FrOm SeQuenCE") (equal (remove-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :start 5 :end 50) "aN intee h liit th umbr o eemens reoved FrOm SeQuenCE") (equal a "aN inteGeR WhICH liMitS thE NumbEr oF eLemenTs reMoved FrOm SeQuenCE") ) ) ) (do-test "test remove-if-not 2" (let ((a '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "tyhfgwsjkkh" "olkdewskddc" "ppmmnnllkkplm") )) (and (equal (remove-if-not #'(lambda (x) (find #\p x)) a :key #'(lambda (y) (subseq (reverse y) 0 3))) '("ikjlkmop" "jnmdkpmn" "ppmmnnllkkplm")) (equal (remove-if-not #'(lambda (x) (find #\p x)) a :key #'(lambda (y) (subseq (reverse y) 0 3)) :from-end t :count 2) '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "ppmmnnllkkplm")) (equal (remove-if-not #'(lambda (x) (find #\k x)) a :key #'(lambda (y) (subseq y 2 5)) :count 3) '("ikjlkmop" "jnmdkpmn" "olkdewskddc" "ppmmnnllkkplm")) (equal a '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "tyhfgwsjkkh" "olkdewskddc" "ppmmnnllkkplm")) ) ) ) (do-test "test remove-if-not 3" (let ((a (make-array 11 :initial-contents '( #c(2 10) #c(3 -5) #c(1 9) #c(10 20) #c(-5 42) #c(40 2) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) )) (and (equalp (remove-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) a :start 2 :end 7 :from-end nil :count 3 :key #'identity) '#(#c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (remove-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) a :start 2 :end 7 :from-end 'non-nil :count 3 :key #'identity) '#(#c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (remove-if-not #'oddp a :start 1 :end 9 :count 3 :key #'realpart) '#(#c(2 10) #c(3 -5) #c(1 9) #c(-5 42) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (remove-if-not #'minusp a :start 1 :end 9 :count 4 :key #'realpart) '#(#c(2 10) #c(-5 42) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp a '#(#c(2 10) #c(3 -5) #c(1 9) #c(10 20) #c(-5 42) #c(40 2) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) ) ) ) (do-test "test remove-if-not 4" (let ((a '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) )) (and (equal (remove-if-not #'floatp a :start 1 :end 8 :key #'cdr :count 2) '((3 . 2.4) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (remove-if-not #'floatp a :start 1 :end 8 :key #'cdr :count 2 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (2 . 222)) ) (equal (remove-if-not #'oddp a :start 2 :end 8 :key #'first :count 1 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (remove-if-not #'oddp a :start 2 :end 8 :key #'first :count 1 ) '((3 . 2.4) (5 . -5) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..84483dd34ee183ca0382108ecf52fe919bdf2ddd GIT binary patch literal 3741 zcmb_fYit}>6~1?7-}VMO*qho(opG8#*>tS<5z&Mab}}BvPS&$#cDAWYMYOiZ-fh;q z%i3-URYQraN)v#m8ZX)A#MAwVJ&sZ!dA78Rr-x#9;Pej)LP#~-9XKtNGz&bimK zcD;crYP^~~_nzl>&b{Z%dW8fZ($k7wnXeX0PEDySEmoHnmDx&7S*R@4rX6J#_{tM{ z#xkB9)$~(+pX!fgw@9XIPJYpuQS2pWVJ3g>KBfPNqE&0f5-je&AGZBR4-Xt28tRLU zXxX&z_JKBFaOCLFC;MXSFRs$I3L#{gypAMFNE?xfcgbx_+D6t^N5;~IYHH&~(p&M| z2;`#XvWDfk?E}hUrK*;k$D9(TGrvG6A>OlYWF%+m_E^UB>hvkv>V4gfkD2NOq^6xP zh!olIg5Ig;?&u#<2UW`$&pc?TVGHweZ?WdaX?Uc>SbwI?>%ugL51q z%Ho6|S$lb5lLxD_@DyVqUubU%8wSTVd9W(QTYcqwwh3Un>1w6;RKfqe29li@!fmv0 z?I$LzZ>*g9n)xOnD}|@clM;nUD_3`&z6GQ z!1=UqkL(8;?ESEXQ}Xp&P?~CF?8Cex5T!jn#K;ybB7OtUCz?c{AdUeNN8y?Pb!Q-5 z@gYUG#4Sl!g)n>-ae+IO#(aRB zv=!Tk6!)HY_aya!Z+D zcFuz4(|PxXvXfcc7?)_XhMh^W7P*B*Wo+0TNyD--mYT`g6FEC6$H1U9shN{1=Vy}) zI=B7s_5si$6T$-6_WPlSrT>7Z&`8D_*KFMW3!~~e%QDO@V}((a{Rw0pn@Q?g))1js z3yR+WPtnGVK+d;;^O5Z2`0-3y_2&)pm)TAvUtu3b@&(p`WQ27h2@09SW%O@cMt{y_ z^cqWm3jK!Iy(D%uZa^!-;EXUhBvg8YN;}_?cLez*Hy~@=fL!MW#yzzyn|oXLy%3Lmsq zW?VJQVHE!e81lyY2dJ90HH)i$6P(BOQO(kH+ps23d5-Nuaz=R03UUlRoH8a+a)fmu zIn26|9AdkX9AtZd&_8oy`g?9ge=W!xT$5hscJvhp8PK(13-y1@dXQXUdy#lzmlICL zg|#L~lEjIeAHtW!C*=*0sb-`k-M> z%(AXWSnnw7J;J&Vv#x`zcNfCT3=dDJ;8Oa#=e8|63yVt4nXf$NsKr@j2>CZWcdw27 zedo1(%4{B9(=$r3EZ(rlJAVMx-t_7%k&Ah+E>Y>?)N*Q)U0(j_-R!dGhVoN0@Xq$? z0Z9%7y}Arx=|M>bWj8dHFT)2NeAlb*xRry8&UP0UD;P&+_cr-(y(<6!ny5#&49zyw zZM~EpgQM5dS=NGTaM?ba%h-mv1y45TKZv-_G2X>vUOfy!;~hOfqi+@f7 zUxsN?4^oj~p!dE6LN*zS#cQfE5ZSLEUh3$)#H3_Z9v!!WsbcIC~h04g?s2 zH;kJ=92|7?+&l1qFqbq9*?0w{S zJ@>%l@YB3D@02QK#s8bmmlyM;O4U&cm9leg#(5lVdOg?LqAa=}-kZl#tl&pFDiJ$HC+<_>t?ggoOQ;0S|n@>N_0@HpWo^{+~` z+dfVL=lQ%FZM=T?1tITxu9^1>w^0iy#fPf|`D+6*`OAlc%pI)=tiNr#804+yi*X36 z^)r4ki0jpNQaK<6Lvl0{j_>U{EeGYUC%pQeE!+-d2ZEp$Pkd}cml>test>14-3-remove-if.test ;; ;; ;; Syntax: remove-if TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: remove-if returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and satisfying the ;; TEST have been removed. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements removed from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test remove-if 0" (and (equal (remove-if #'oddp '(1 2 4 1 3 4 5)) '(2 4 4)) (equal (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) (let ((a '(1 3 4 2 5 6 3 9 8 7 10 20 31 25 87 3 4 5 3 4 2 10 22 38 100 50 25 22))) (and (equal (remove-if #'evenp a) '(1 3 5 3 9 7 31 25 87 3 5 3 25 )) (equal (remove-if #'evenp a :count 10) '(1 3 5 3 9 7 31 25 87 3 5 3 22 38 100 50 25 22)) (equal (remove-if #'evenp a :count 10 :from-end t) '(1 3 4 2 5 6 3 9 8 7 10 31 25 87 3 5 3 25 )) (equal a '(1 3 4 2 5 6 3 9 8 7 10 20 31 25 87 3 4 5 3 4 2 10 22 38 100 50 25 22)) ) ) ) ) (do-test "test remove-if 1" (let ((a "watermelon banana tomato pineapple pear peach plum apple orange cantalope honeydew")) (and (equal (remove-if #'(lambda (x) (> (char-code x) (char-code #\r))) a :end 30) "aermelon banana omao pineapple pear peach plum apple orange cantalope honeydew") (equal (remove-if #'(lambda (x) (> (char-code x) (char-code #\r))) a :start 60 ) "watermelon banana tomato pineapple pear peach plum apple orange canalope honede") (equal (remove-if #'alpha-char-p a :start 11 :end 64) "watermelon cantalope honeydew") (equal a "watermelon banana tomato pineapple pear peach plum apple orange cantalope honeydew") ) ) ) (do-test "test remove-if 2" (let ((a '( ( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) (1.1 (2.2) 3.3 4.4 5.5)) )) (and (equal (remove-if #'(lambda (x ) (<= (length x) 2)) a :key #'cadr) '( (10 (20 30 40) 50 60) )) (equal (remove-if #'(lambda (x ) (< (length x) 2)) a :key #'cadr :count 1 :from-end t) '(( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) )) (equal a '( ( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) (1.1 (2.2) 3.3 4.4 5.5))) ) ) ) (do-test "test remove-if 3" (let ((a '( (10 20 30) (-2 23) (-9 99) (34 49) (3 2 1) (20 34 13) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) )) (and (equal (remove-if #'(lambda (x) (and (> x 5) (oddp x))) a :start 2 :end 7 :from-end t :count 2 :key #'(lambda (x) (first (last x))) ) '((10 20 30) (-2 23) (-9 99) (3 2 1) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) ) (equal a '( (10 20 30) (-2 23) (-9 99) (34 49) (3 2 1) (20 34 13) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) ) ) ) ) (do-test "test remove-if 4" (let ((a '(8 #\a (1 2) #\b 3.4 -9.85 #\e "abdesd" (2 3 4 5) #\o #\a (+ 2 3) #\a "banana") )) (equal (remove-if #'characterp a :start 2 :end 12 :from-end t :count 3) '(8 #\a (1 2) #\b 3.4 -9.85 "abdesd" (2 3 4 5) (+ 2 3) #\a "banana") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b311a9a274bc363b38b1421721cfbb8f3385f80d GIT binary patch literal 5346 zcmb_g4Qv$06`q~l`|%%`pODyqvp|2yg#-LUYW^CQV~vf^cjj&lxJuL>_8A-2nAnD- zMR5~~plPlL=2~YbO`5c*Dr%dGxQg147NXFK1|hWyiPA=*N~Km+BGJ+`O@D%L-UQk4PAj9bB`marL& z7;R?28Ff;As3q7DH)Bp}Mx8!9uqS9I_a$vCr+57`_WZcnbV@x``xQiqFhN#u*aMN3rud#?Nn+mlUB>kQfZT?VLW zu2woNTgxq(0`2h}hcdenIo#+fg<%99I6-o7Ck_5lNNOPF~c$}uaqe@)ewF?PE5 z^VMe}*~E5TcKVP|9p1Wgvn3V0jTKtP0Ds0_gqw=pDtqCE!LTw29Idt=Ml;4jGbFUD z3fcvB=z`zmVr2w?!-jPvS}k|1!_jKmvX1qhoO8WBYqYnruafa{=bNc{flxHEp#?YV zV6zd~5H@4M^(|nDY>WqZnJD2EaFxL2hsy_-2QCdxhZ%v8VTGDuLMBv0${rYVWWDY9%<72aHH(P}<`G0Y}4(&rCgG zrm2hx4bPPgcus7ENZzJstj(}cwJ>X_BNj6w1?QGfurCCCv-8DYF^!${`l z4kO%-Y84(@ZAPmZG-5HM6HRjvVYIiK5t(`xs3j5+Zi&n6K5+-&v=2%A8R2xQq4ff& z8XTozR9+Ue))SIRB)=*l{2wGPk?}3k zeo5NPqC5W6ynwJEZMs`_h>@C>Vd=c2aBQ0U~{XDzG z*qa1BB<7EZnn6)>zqtEzVu2}^7$Oi9fo%}n)9$27hm%9Y`e3quU|&+d2aRDTb*F{K zg(Jp7y(a-5DBXJBZu+)B+sG#oHvQoGX2!6k9yG4VmiDiM#@~2@F`Y!NV5>mm9p3;Z91~23IGXikL(@n@guXe{j7{wrAYL z88@-*d<(sgrD{Sk)3D6olx;uUVwo``92aE>gE`sU5w%P?58C}xhGPXL?i4sG+TG4q z;pkD7be#$!z0&VNjZ5W$^n>Xnf~v<@**bV7HsHE&vudHRqH4JpDEaX54Mv-|2xp7; zVoEm)2Te=YryC)qdJPmcU5Ce<`d^}i%@5F{HeHvlN9{e-fHJoK3U#Lw>FwBl7agD? zY`-Q4POO1$v6ddevs1>S0dZ&Kc&HgCgRDyA2>9Wx07nDw9u-E0R{%+VU}9q8nubn2 zPNw3zXoOrCJVsH)~c>NI&| zp|-z-fgO5*GJnU(z!I5+B0tURbM0Oq#`gJvW;XV9BE3xv3UgD8V(&=|ek*_n`wEgd zN8?vWxsXh8pzF~1Q9j%WDgYyYr!aD1Op5TaB0rvwe3%9TBab*49F~vIc~bFx`IyN( z+i20;^L10^z7BJ*k#i4EQ_7RTe_&H4#+YZF@qay*Fb%i~DgSm-ixS(rx|2OSZX^); zep)8I?4)WWlpL;eNAM+C>?v&iKHY=jHQ0pFj}jH%fdRsPHO4B}!GCjHH1KBgH*UJe zLM27J4&y%f94Nul$q2#r$R(XusOHmoZl}^+nDi%56Ai*g-4S&>@Ar({ZIs7~CQtd& zl*y|_&wX<86xfMo!{UK83C~xBM^m{XZwOg(gT6&K=(|IbdKE)VcQP{z!(()g+bFx{ zg4jPL$fb~Hz~0G&;Q5{bdtZ)cKG4NH=KM!t&gL;cEE*s7l#^Ooct8hrsdXiWl0$mW z;6T5=C$S@`*R8162YU2Sco<(;nIrCj4Oi1(?6x==A8=Ek*#-FM}U Zx|8uJTv6dm$n{nxlVeX}qCZSb{0~gsT#^6) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST b/internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST new file mode 100644 index 00000000..f3819eb8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 253 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 12 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove.test ;; ;; ;; Syntax: remove ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: remove returns a sequence of the same kind as the argument SEQUENCE that has the same elements ;; except that those in the subsequence delimited by :START and :END and satisfying the test have ;; been removed. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements removed from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test remove - test cases from page 253 of CLtL" (and (equal (remove 4 '(1 2 4 1 3 4 5)) '(1 2 1 3 5)) (equal (remove 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5)) (equal (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) (equal (remove 3 '(1 2 4 1 3 4 5) :test #'>) '(4 3 4 5)) ) ) (do-test "test remove 1" (let ((a '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1))) (and (equal (remove 3 a) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (remove 3 a :from-end 'non-nil) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (remove 3 a :count 2) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 3 2 1)) (equal (remove 3 a :from-end t :count 2) '(1 2 3 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (remove 3 a :count 0) '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) (equal (remove 3 a :from-end t :count 0) '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) (equal a '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) ) ) ) (do-test "test remove 2" (let ((b "abcdefgabcdefgabcdefgabcdefgabcdefg")) (and (equal (remove #\b b :test #'char>) "bcdefgbcdefgbcdefgbcdefgbcdefg") (equal (remove #\c b :test #'(lambda (x y) (= (char-code x) (- (char-code y) 2))) :count 4) "abcdfgabcdfgabcdfgabcdfgabcdefg") (equal (remove #\f b :test-not #'char/=) "abcdegabcdegabcdegabcdegabcdeg") (equal (remove #\a b :test-not #'(lambda (x y) (equal x y) )) "aaaaa") (equal b "abcdefgabcdefgabcdefgabcdefgabcdefg") ) ) ) (do-test "test remove 3" (let ((c '( (1 2 3) (2 3 4) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) )) (and (equal (remove '(1 2 3) c :start 1 :test #'equal) '((1 2 3) (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (8 9 0) (4 5 6) )) (equal (remove '(2 3 4) c :end 6 :test #'equal) '((1 2 3) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) (equal (remove '(1 2 3 ) c :start 2 :end 7 :test #'equal) '((1 2 3) (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) )) (equal (remove 2 c :key #'second ) '( (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (8 9 0) (4 5 6) ) ) (equal (remove 6 c :test #'< :key #'third) '((1 2 3) (2 3 4) (4 5 6) (1 2 3) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) (equal c '( (1 2 3) (2 3 4) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) ) ) ) (do-test "test remove 4" (let ((a '((9 2 3) (8 2 4) (1 2 4) (-4 3 2) (5 3 5) (-5 2 1) (3 4) (2 9) (10 2) (-2 4)) )) (equal (remove 5 a :from-end t :start 2 :end 8 :test #'> :count 4 :key #'car) '((9 2 3) (8 2 4) (1 2 4) (5 3 5) (10 2) (-2 4)) ) ) ) (do-test "test remove 5" (let* ((a (vector '(1 #\2 3) '(#\a #\b) '(#\9 8 5) '(#\1 #\2 #\3) '(1 2 3) '(3 #\2 1) '(4 #\3 #\8) '(#\q #\w #\e)) ) (b (remove 56 a :start 1 :end 7 :test-not #'(lambda (x y) (equal (type-of x) (type-of y))) :key #'second) )) (equalp b '#( (1 #\2 3) (#\9 8 5) (1 2 3) (#\q #\w #\e))) ) ) (do-test "test remove 6" (let ( (a (make-array 200 :element-type 'float)) b) (fill (fill (fill (fill a 20.0 :end 50) 30.0 :start 50 :end 100) 40.0 :start 100 :end 150) 50.0 :start 150 ) (setq b (remove 35 a :start 75 :end 150 :test #'(lambda (x y) (or (= (+ x 5) y) (= (- x 5) y))) )) (equalp b (make-array (+ 50 25 50) :initial-contents (append (make-list 50 :initial-element 20.0) (make-list 25 :initial-element 30.0) (make-list 50 :initial-element 50.0)))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST b/internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST new file mode 100644 index 00000000..7f6844c2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: replace ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 252 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 9 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-replace.test ;; ;; ;; Syntax: replace SEQUENCE1 SEQUENCE2 &KEY :START1 :END1 :START2 :END2 ;; ;; Function Description: replace destructively modified SEQUENCE1 by copying the subsequence of SEQUENCE2 ;; into the subsequence of SUBSEQUENCE1. ;; ;; Argument(s): SEQUENCE1 SEQUENCE2 - ;; :START1 :START2 - ;; :END1 :END2 - ;; ;; Returns: a sequence ;; (do-test "test replace 0" (and (equal (replace "12345678" "abcde") "abcde678") (equal (replace "12345" "abcdefghijklmno") "abcde") (equal (replace '(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :start1 5 :start2 2) '(1 2 3 4 5 c d e f 10)) (equal (replace '(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :end1 3 :end2 5) '(a b c 4 5 6 7 8 9 10)) (equal (replace '(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :start1 3 :end2 4) '(1 2 3 a b c d 8 9 10)) (equalp (replace '#(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :end1 4 :start2 4) '#(e f 3 4 5 6 7 8 9 10)) (equal (replace "654368793789327932" '(#\a #\c #\e #\h #\i #\d #\p #\m #\k #\s #\b #\o) :start1 3 :end1 13 :start2 2 :end2 8) "654ehidpm789327932" ) (equal (replace "654368793789327932" '(#\a #\c #\e #\h #\i #\d #\p #\m #\k #\s #\b #\o) :start1 3 :end1 nil :start2 2 :end2 nil) "654ehidpmksbo27932") ) ) (do-test "test replace 2" (flet ((test-one (seq1 seq2 &key (s1 0) (s2 0) (e1 (length seq1)) (e2 (length seq2))) (let* ((seq11 (copy-seq seq1)) (copied-elts (min (- e1 s1) (- e2 s2))) (expected (concatenate 'list (and (> s1 0) (subseq seq11 0 s1)) (subseq seq2 s2 (+ s2 copied-elts)) (and (> (length seq11) (+ s1 copied-elts)) (subseq seq11 (+ s1 copied-elts))) )) (result (replace seq1 seq2 :start1 s1 :start2 s2 :end1 e1 :end2 e2))) (and (eql (length expected) (length result)) (dotimes (i (length expected) t) (unless (equal (elt expected i) (elt result i)) (return nil)) ) ) ) )) (test-one "kdjsfjkldsjoieurhhfkldsfjlkdsjhfg" "123456789" :s1 5 :e1 10 ) (test-one (make-string 200 :initial-element #\*) (make-string 50 :initial-element #\%) :s1 99) (test-one (make-list 100 :initial-element '(1 2 3)) (make-list 100 :initial-element '((1 2) . 3)) ) (test-one (make-array 150) (make-array 200 :initial-element "replace") :s1 70 :e1 120) (test-one '#(1 2 3 4 11 22 33 44 55 111 222 333 444 555 666) '("11" "22" "33" "44") :s1 4) ) ) (do-test "test replace 3" ;; ;; If seq1 and seq2 are the same (eq) object and the region being modified overlaps the region being copied from ;; (and (let ((a (list 1 2 3 4 5 6 7 8 9 0))) (replace a a :start1 2 :end1 5 :start2 3 :end2 6) (equal a '(1 2 4 5 6 6 7 8 9 0))) (let ((b (vector 1 2 3 4 5 6 7 8 9 0)) (replace b b :start1 2 :end1 5 :start2 3 :end2 6) (equal b '#(1 2 4 5 6 6 7 8 9 0))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3fe3649e5b6073560652edd25d399f2eb150ca78 GIT binary patch literal 5503 zcmcIneQaA-6~FI2JN`)0C2bnotZQCd+3UQ%uFc2RW^A?NyfkhcJGGzJq%bDeacU=y zUmDv)X+>9stlB28B@K(-9V-lm28aPApp8=4IwAf5rD%Le{DA~WlMsI(F}}nQo5DHw z+Hn#mT>>T1%em*{{_gLbd*69C)5P58^~+v;WHgzIkI8y2JDSVNgZh}9(Q{+5xI74U z`J6WxQa{z@@pkWj_@F(!#1k8fN3-z(SCUkg#8@tL+3QLwH|0|KD6JyaCKIw(Fq|j@+Jx!AvHuI#+7`HOH;#|(&_W7O2E^j zx{PTfZ-rcxNLURS`PwEqtB)$F_$T8jOlKrR1VW6@0d|E_P6^&CW@rKpSW>MxSl4@ z|KON-Vp~J4U{2XiGp^{ZBm~9$oV?Tu{$Y5Mc1yv1A#nrr&6AeRLgM-x0T{nK-ThqP zM}$l#E(VT?LN$!8edI&~g5hH&q>7L?ld&DFG6fRC$BQH^DG5NJV9Q9HN?EvdXlQ77 zco_b&pOiIa#euz!5r$F9g1^jJ&~S`?ATqZdLCfJUB<@fe;{C-mtgEjymsoBGE~#p} zxmfG2a&J?~ySLnX7Xs{E+>PlZrgF#9ks6BW;K3-b+n2sgo?hlaHkK0MM7a|zrNc9) zmIatgvz_J6WwT4k-l5%--Y%wFT~=vW8O~&hoQe^}2b?%8c^yR$%EdGm{YBjh6rv=?5e`MD=n2AMDb-!ArIgTw&4y?7**RpTp)aYfwqr*tK8t$ww3 zFrBDL))2AMcs{?wEDtuZEO%A6NoM!!EI!+C&>XR(LG%nBg%&Ypr#8 zJ({;m38`8n1g+7_dTT|vKdh-eqEH^81zogKs-iZ@4()W4OAUpBAte~mdLx=k+5{7- zT%JI`!t7xeg}z$*;L7$~B@seR*p%C_vpxq%6`jFQk4HoGSzOf{35C?alBQ1u^i6=T zu9T?P6IS_Bl=bLifK*%7!Exelx)p@)AE z{$5Cs`~}s=RIe5cq53NpOMXtbq4qkT@>Op9BCS79H=mP zXDHaC6rwg`ls6a&uqZp-fl*d^4+!Z`v=PN0=}r{yFrV}y-HzI4+2YdET#N!wleeP- zvz12JQc{qMCQL!=@`aF;^Z++Hz-aXaH1((&!h(r^V5s768JzeFF22VW7Qe%2h+o4s zf*l*;KpulY~@-L(}aIA zYQmoxC*d6~e#(j={FoI=xB=9vVC%a)inq%XQjntX6&`Yx-iz8ZJn~7do#tXMhn6{J z9TVgO0J8)lJ?*?S9UR>7tR}mW^k!awc~wlTBuG*|?G%RML7@ZbAQ~k#E${zx%vrw>%hyYwUoWO!FHk z+Ri&LtjCzK8TpD#IvzhefrC^$J_-Z#P;LaJ<@A`IizQ%WO6y8yQJ4qx(KuLbnY2DW zo=9fnFlRiOjU^COoh26c5Zsh%h>^cL6&*P>5XHsIx*ohR0_%Fv_>8>JFG!H6r1~{* zAW+M?=}7~64CtPUW)g$B6p*c%h9{015J0b%h{hLPJ>s0I>sY>+5cQ~xlQ z_skNTdnhHr9eRT_`vo%;vI5(_dc06e6YWH%WR|dNiF@PQ(Buvb_VREy_G`W>Sz{pNq7OrJoq6O8PyIoSy$`P;2KTInz4Bo%vk)WpX206F(+t-ZP-=qqPv&M|Ym@$dcl>7H^@q?i- z<-RyLXf?yoHs#*Z+&ty}baOL$rjA@7WXcVjHRWcboACb{m~Xy>7B{rIsU!LMTSi`V zxxfyP05s+P34OtgOC|pgOU+bRfg~g2pT9NbshYnfuCjC-k11T>QsTk}k7=KPg{|4q91v>9Fv?_xDRx@I+sC0X^PpcBd5U*ffE5wnuL0(2A(I6cEZ((pR3 z^<8NK9PvGNvc;Rm%=XIqUHcwt@9B$G*EQbP;?ufLQs?8;>7h>i#o%wP8Wno{n5Vj) z1$+SmsB;%}K17{8)ET4BBG!_qD~$WAh&Z_lB42O$%4bSbqUCE)XXAa;iHw)5qLrq! zuQ`RUwKC6#OH+50m(;#?Ne^O9Hda#Mmqz~4Ogui2h(`xxeNc|+BO`j+k;$b8Q~G#( z%rO!jOQsz$J(tc-$gyaOfA00MbTTTZlf!x%z=XF}MS)vF0Yzpg0DfDP*DvAiK)AL9 z%%Km$+P9(PV3Zti16e`oWmcWn5Rh`*D@$-8)eYe~7E^tygnN$TW|!b@ly3=lq=Xye zxIJZ?Dm=ROrXIjd+xVtd8#9~4$%Tc54{Z4N-=+bkm@FdG-~TZLhF~;4RmpNTH{9kUUsF7MKkdX9Ffr^+!+VQ^bvV9dO9vQwLXaF r((BLqGgMKb9|@vKkW9AL#i7}WLz_*IZ05$2Ram|dc>#I;Y+>O)Yb-j| literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST new file mode 100644 index 00000000..78f01f1c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: substitute-if-not ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 255 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 24 ,1986 ;; ;; Last Update: Sept. 24 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-substitute-if-not.test ;; ;; ;; Syntax: substitute-if-not NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and not satisfying the test have been replaced by ;; newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (substitute-if-not 9 #'oddp '(1 2 4 1 3 4 5)) '(1 9 9 1 3 9 5)) (equal (substitute-if-not 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 4 9)) ) ) (do-test "test substitute-if-not 0" (and (equal (substitute-if-not 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 3 9 3 4 100 3 4 7 2 9 3 3 3)) (equalp (substitute-if-not 7 #'zerop (vector 0 0 0 1 1 1 0 0 0 0 0 0 0 0 8 8 0 0 0 0)) (vector 0 0 0 7 7 7 0 0 0 0 0 0 0 0 7 7 0 0 0 0 )) (equal (substitute-if-not "*" #'numberp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test substitute-if-not 1" (let ((a "seedhead of common sunflower marin county calif-notornia nikon")) (and (equal (substitute-if-not #\% #'alpha-char-p a) "seedhead%of%common%sunflower%marin%county%calif%notornia%nikon") (equal (substitute-if-not #\% #'alpha-char-p a :start 10) "seedhead of%common%sunflower%marin%county%calif%notornia%nikon") (equal (substitute-if-not #\% #'alpha-char-p a :end 50) "seedhead%of%common%sunflower%marin%county%calif%notornia nikon") (equal (substitute-if-not #\% #'alpha-char-p a :start 15 :end 40) "seedhead of common%sunflower%marin%county calif-notornia nikon") (equal a "seedhead of common sunflower marin county calif-notornia nikon") ) ) ) (do-test "test substitute-if-not 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) )) (and (equal (substitute-if-not 'z #'oddp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (substitute-if-not 'z #'oddp a :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if-not 'z #'oddp a :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (substitute-if-not 'z #'oddp a :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if-not 'z #'oddp a :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) (equal a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) ) ) ) (do-test "test substitute-if-not 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) )) (and (equal (substitute-if-not "**" #'integerp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (substitute-if-not "**" #'(lambda (x) (<= x 6)) a :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (substitute-if-not "**" #'(lambda (x) (= (length x) 2)) a :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) (equal a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) ) ) ) (do-test "test substitute-if-not 4" (let ((a '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "bashful" "dopey" "snowwhite" "witch") )) (and (equal (substitute-if-not "no-y" #'(lambda (x) (find #\y x)) a :end 8 :from-end t :count 2) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-y" "dopey" "no-y" "witch")) (equal (substitute-if-not "no-o" #'(lambda (x) (find #\o x)) a :start 4 :end 7 :count 1 :from-end t :key #'(lambda (y) (subseq y 0 3))) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-o" "dopey" "snowwhite" "witch")) (equal (substitute-if-not "no-s" #'(lambda (x) (equal x #\s)) a :start 4 :end 6 :key #'(lambda (y) (elt y 0))) '("sneezy" "sleepy" "jumpy" "grouchy" "no-s" "no-s" "dopey" "snowwhite" "witch")) (equal a '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "bashful" "dopey" "snowwhite" "witch") ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0e383f7ff0782e2f5b9f2c7a20c209d7b82f74a7 GIT binary patch literal 6545 zcmcIoeN0=|6~FJpU>j%&0Y(UEUa}GzFHQsGqajMe!#skCv5EcM;#BG87!x}f%=l=R zb;;6{MTzRPBPi(IZf&=2no@0*l1!`AW@@5VTeXd3+A4KZC#}^gt=rT;T2-66r4c*l zUOx;E(?P_Hp6@+hzxzAqopH_|{li2c#Q1i`-WK+IbZ@|KOb920V&myd ziP!J$g4EQ#8WHVT6hs${Oj-R_ccVKLZVBmLJ*;bPZyR}bvgjlswm~HHYT`INxts!UIV71+e!S~Em ze>{mPEL$2P|R6tEmjUSV>g*E%cElZy2-j|_Noib6V>MDHPZ#3(v*l_ zcKAw~5}KV(-j=58LSqhf3Yy}5(~TkH^UILglMDh>)tTK+Ovi=BxwvOcH->97i6UdP z+y?07M!$*qdE+b^i+#M#B`#Lx+vUa+rO8qv78&O=H7-xU-|EE;+}*DFTYXy4-Qop} ze{aYomQaW2fXfb7AzU`NWH>EWxIC)vX?F)TJsgDH-ouWIf>0!+Yn`Gn-$M_$XpvM* z9g-7Hh&xInyfnt#?gMg_EWfvr53s7DQHd?|`YkNhSeIp-Wos2!peI1GUC&QPSY zCE#8s5~aOd+Q^4muB>8%_z4RaKVsqHdn{ah ziFu0Og$5c$lprR{0e*V2nIUc zn!gnlFN4D7355OF3i2g%&06{Z+U{+Irts=4HbGaTPmHd?;bD3g4iStG>1vS0mvI*- zcX7}fbdi~-G))zdqzqk!!x-ZxeT@%afwg2$YbzE*I>`4FC6NM(p3>!-ASu=)0&-h&As&Q zRbZ0?t*u>;Kt8sEMy6sUK0Klfj~*HxNsf$;#NEkWMcInRh>=;VqjCLlb-mIXg?H{A zB{{%fmr-}T7Ts!$Cku=-1;&I7x4&5PX`Q%t=#ehXm=Iw#XV@R|?)7V}?v{wI3E)(s zwswS}Pg;E1i9aGlmGPv_IAa3{x|wdF^(Qb5TloxdR(k=prB>}0)D~M2PNUXt)#4*% zldalMQA?~^0$TYqtM(#l|6%2TS;&92`eGLHU#z~Eh5To$7PFAwF*3qBoV;y?LgMo8 zty&~5-!OxIZ8bBluTPSaW;m$(;B~o_7@5_nX#b&}DBj32$n+8+yCIr|Uocspw^oAH5`H)FN}RQtS^3UbwXA&K zGJ_sBC&#QMVHG=S)iOq-RxK-^K1rNdzEr_9Kk%1S!EOO7SK!n9d-e8g=3OSa-PR;n z<~yx4y0F^Y%%FO6;$IBb7+A7r6TD7bU>#SN1~TOyBLcjP$Q;>e2`K3Maj9C60xY-nIH-|44tbYPX>F4^{*$sq~grizStQYt>>& zrQcY!SW@Xts}@TtT{6Cd8|1mnU7nz(!moJCtCi0SySwTO(IUQ&+V+P7y2ek;7mQ4K zo_)I!ai61Z9F7bjU`>9F~DinsZAQb>TDh6@wf&oabW2d0!wccyMxd9l@6WC|^lq!4!)VToI5 zgzYV|PYvl=`ny;%?;!sjlcbodzQpt;%Pm;Al$!~C7y09fMRSZ9kDjfqu7mFqU`XzA>Zm6WgDxYet-AE0#yX`M>z z@DH7z&+8RD*rAqGZa{~p(Sg>jqjfuIT_>%J(K-`rme)xnCt!DoLwOMSdUIEf=0f(* zUxU`I-AL<@@vK!^b0G~2hVZqld44GuTD)Lcgy zWfnnU2mrhw!b^C};P3aTr8ll1KBeG&5?*`?-%AD9BWLodP4@!v&&j7YUq0tqX-g1n zd^w1n<-|_SA_j$CG_l&5LLbc$8(j`!U**J(%p$gwisgvKa>Ty89K;^t#I%JQdwc%I z#`9cg;EfIE#vS6x>FMcP4*b3;_b@>&6q)>)gd!f_cml>test>14-3-substitute-if.test ;; ;; ;; Syntax: substitute-if NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) '(9 2 4 9 9 4 9)) (equal (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) ) ) (do-test "test substitute-if 0" (and (equal (substitute-if 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(3 -3 3 -5 3 3 -3 3 3 3 3 -4 3 -8)) (equalp (substitute-if 1 #'zerop (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 )) (equal (substitute-if "*" #'characterp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test substitute-if 1" (let ((a "seedhead of common sunflower marin county california nikon")) (and (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a) "seedhead%of%common%sunflower%marin%county%california%nikon") (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a :start 10) "seedhead of%common%sunflower%marin%county%california%nikon") (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a :end 50) "seedhead%of%common%sunflower%marin%county%california nikon") (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a :start 15 :end 40) "seedhead of common%sunflower%marin%county california nikon") (equal a "seedhead of common sunflower marin county california nikon") ) ) ) (do-test "test substitute-if 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) )) (and (equal (substitute-if 'z #'evenp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (substitute-if 'z #'evenp a :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if 'z #'evenp a :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (substitute-if 'z #'evenp a :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if 'z #'evenp a :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) (equal a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) ) ) ) (do-test "test substitute-if 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) )) (and (equal (substitute-if "**" #'floatp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (substitute-if "**" #'(lambda (x) (> x 6)) a :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (substitute-if "**" #'(lambda (x) (/= (length x) 2)) a :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) (equal a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) ) ) ) (do-test "test substitute-if 4" (let ((a (list #*10110 #*00000 #*11111 #*00011 #*10001 #*001100 #*101010 #*01010 #*110110) )) (and (equal (substitute-if "!" #'(lambda (x) (= x 1)) a :start 2 :end 8 :from-end t :count 2 :key #'(lambda (x) (elt x 2))) (list #*10110 #*00000 #*11111 #*00011 #*10001 "!" "!" #*01010 #*110110) ) (equal (substitute-if "!" #'(lambda (x) (/= (length x) 6)) a :start 3 :end 8 :count 3 :key #'identity) (list #*10110 #*00000 #*11111 "!" "!" #*001100 #*101010 "!" #*110110) ) (equal (substitute-if "!" #'(lambda (x) (= x 0)) a :end 5 :count 2 :from-end t :key #'(lambda (y) (elt (reverse y) 1))) (list #*10110 "!" #*11111 #*00011 "!" #*001100 #*101010 #*01010 #*110110) ) (equal a (list #*10110 #*00000 #*11111 #*00011 #*10001 #*001100 #*101010 #*01010 #*110110) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b472e39f0802362f5ed84f15d0ac85fc1c52d84e GIT binary patch literal 6073 zcmb_g4Qx}_6~6D!vGYg52tNUWL1e5hri1_rp~x!0 zOBYpBJ9(5~8hoL2qTA?(R<)oamC@0yRAVb!*RG{nt9Dw|mT8+nAXaT`rP(?6_}NZk z24aZ3cg{UO-#O>r^X|Q7glX+AkKNV3Z6Ibu2kresiGiVny}N(V9`7F-3`gzVAh+*u z`TXt&*XgbeOIFtv2l6!G!Dwe98nFk5qVY)QHy7LMR@wD|!I%L|Ljw%!8dof9T)uos zaf=@C5ZVoWmNl-ZYpkzdQapBWRI2D_jD^|DNNkK%FomV}Br6<2cOd9&Y4y0BUcJrj zNROnGR;a}p3b_60WaTn@qJO|?L?4J6SkAUMlNd|yPFh<+URSWy=S`=iho#c=P|(c|j+P8FW?78c{H*8Xdg;V=_UcRP z<;^pzD<#da87gW@7(?>gV*yjLm9f5J%@jB0i$N7DE;3bfL8YKGh~W<^&bmF^ga1x~ zbn0-?RH^60DKGGsMmBuUdz!J4p6__q%TgI|&(GLgjS%=)87pP%2T>m*E*-)9Sr&5m~x48&JySd1l?`2G}$8PbMO+Sl-rbI zINHh`Zol8>cltuXjiI1JDF=sAhwklg3VFc6;f$+XIq|40RT$$c9*|$b!_E#!mKLAC zO%LL5E=F~Q{C>AL?*Qf!>PkU3Emx>Z54b55$756b5Rcp3X^NtEKr|)L(YD6tahgXn z%8&6XB+u~aNOsa_2aW3aR1_}dUqE8#(}1X#g^7AWn5Z8UIZMJbG&)7(My^L*(niK}rY*DIy%CI?~M} zLhkJEV#MAe@~rScJScv zBCkgBE=X0pHR0ebba3g-%{X1!8=z7)xI2(P3%us?g}lP%&jecUz;=I^9_s>T-WLs2t(vEKt3_Ti;(O67&j2q{UYwY+>Ur5 z=vJ*c)YjIKy*-*0Oy{%EqMVA81yTPda#Q~z;;7in(wD(X{gVi#o&z|g#pmM-QTQsT zEde)v3^@EHIh{l&{HoL!$>}-a6!MbOQ&^DbJ2W{!CVR>CF|bqvaMvYMugFksq0}0Q zECd@VLK{>(~;OGaqj^h6A_2GIb--ohQPpfDi<+}tv zOgKCFU1*V@P+y}^y%cIInRHR8`zTb1zBRv?JEeiZ7L(;21XfL8GYG7lz)HwOAuuMu z0&I*VOTv2+WFQ791goXgpz$4|T;8 zvBXd!YR5&lRHc*if~Z*VkiNj)-3h-WBlg&K`Vok-hj3Q4kJBkzIw>`YC#5Lb@YvYc zXPJ?Tga6>`S~{f&4IFzZIG~XK95`7PQs5LxaEST-C@XE!-|oG3g^u8Ka<ka6gd6d6!Pf5Vswk4v;ZKdIhsfDUz(fTi`1g-^?iGW- zm6Yz85CkP8EjS6!-nL12oNvMeAH!(K4CgY%g}d=|kkt(q%@}2x-g~8j-TG>^Q=*&9 zDP5gDfNQ!ZS>y7%^`P51;cnt-4Z8ihC%{Y44EEklAz#ofI$m2`ps#UH)4s$TfT;gS zr;7NZbV}8rI|Re5HtY@TlB-POi})h6dk^fuN|IG;#yDg1Pq^Zx)bUQ~lqSonY5|2J zsWSS%eq(>`F#Wg#U0&euW{)8IW6W}KCa_?}2NWVR)V@(>Yw9x;xc%P5DoB}c2JVnj zyQIPNS@3S>-b9~{x;vLe5~f#HF`u|t5grEtPl$LX9uJ>pE{?a& ze4&6+{+v!~+l^Q}0k+Ef`GY@#hX}r3ybqB5+xaGMma8r3JwL0To8>CA95fFh%KsW= zReF5|{%GU9dfz9P#BSJgD^)^ixF54+Ig@$QWX=@IT0U*64~?>lOj>)J z^lMit{;!PonXnHQjJjb`!^w9SXgIvW$PJ?5WJ@|Zv$HD_?cUlIhIe$UUK?)itX&%o z*LH%L^ywsh7wEe{-zD^ycXgrJg^$p z0{`u(C^lJA%8F|gR5}Yv7mzeE-nLR?^9OW;&MmhBnAMsG#;#@!*hLc;4XhB&3U2Jf zoWVQ!2w8*Q=M0WdDv=#dCs$3pz&Pzf67GygKn$)f-Glwx>;s)!qxNMhR@(c! z?JiFOe*&?mdBXr~vo@P*Q&jCfU}3YDfDM|gO=~t;Ra+%k8ydhonYJ)Fz=G7K&CW@s O@#(Vt81MYp*na^MdWIkX literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST new file mode 100644 index 00000000..e287df81 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: substitute ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 255 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 24 ,1986 ;; ;; Last Update: Sept. 24 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-substitute.test ;; ;; ;; Syntax: substitute NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; OLDITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test substitute - test cases copied from page 256 of CLtL" (and (equal (substitute 9 4 '(1 2 4 1 3 4 5)) '(1 2 9 1 3 9 5)) (equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 ) '(1 2 9 1 3 4 5)) (equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) (equal (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) '(9 9 4 9 3 4 5)) ) ) (do-test "test substitute 0" (let ((a '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) )) (and (equal (substitute 8 3 a) '(8 2 1 10 8 8 9 2 1 8 10 13 30 8)) (equal (substitute 8 3 a :start 5) '(3 2 1 10 3 8 9 2 1 8 10 13 30 8)) (equal (substitute 8 3 a :end 9) '(8 2 1 10 8 8 9 2 1 3 10 13 30 3) ) (equal (substitute 100 10 a :start 1 :end 10) '(3 2 1 100 3 3 9 2 1 3 10 13 30 3) ) (equal (substitute 200 20 a ) '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) (equal a '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) ) ) ) (do-test "test substitute 1" (let ((a "abdefgbcdefegAbcDabGecba")) (and (equal (substitute #\* #\a a :count 2) "*bdefgbcdefegAbcD*bGecba") (equal (substitute #\* #\a a :count 2 :from-end t) "abdefgbcdefegAbcD*bGecb*") (equal (substitute #\% #\b a :count 3) "a%defg%cdefegA%cDabGecba") (equal (substitute #\% #\b a :count 3 :from-end t) "abdefgbcdefegA%cDa%Gec%a") ) ) ) (do-test "test substitute 2" (let ((a (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 9 '(d w 2 4) 'b 'a 7 7 't 'u 9 0) ) ) (and (equalp (substitute "!" 6 a :test #'(lambda (x y) (and (numberp y) (< x y))) ) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 "!" '(d w 2 4) 'b 'a "!" "!" 't 'u "!" 0) ) (equalp (substitute '(11 22) 'dummy a :test #'(lambda (x y) (and (numberp y) (oddp y))) ) (vector 'x 'y '(11 22) 0 'a 'z '(11 22) 6 'm 'n '(11 22) '(11 22) '(d w 2 4) 'b 'a '(11 22) '(11 22) 't 'u '(11 22) 0) ) (equalp (substitute 99 9.0 a :test #'equalp) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 99 '(d w 2 4) 'b 'a 7 7 't 'u 99 0) ) (equalp (substitute "nlist" 'list a :test-not #'(lambda (x y) (typep y x)) :start 10 :end 15) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n "nlist" "nlist" '(d w 2 4) "nlist" "nlist" 7 7 't 'u 9 0) ) (equalp a (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 9 '(d w 2 4) 'b 'a 7 7 't 'u 9 0) ) ) ) ) (do-test "test substitute 3" (let ((a '( (1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) (-7 0 1) (2 2 4 4 6) (3 1 4 2)) )) (and (equal (substitute 'same '(2 4) a :key #'(lambda (x) (subseq x 1 3)) :test #'equal) '(same ( 5 3 1 2) same (0 8 9 1) (-7 0 1) same (3 1 4 2)) ) (equal (substitute 'fun 2 a :test #'> :key #'second) '((1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) fun (2 2 4 4 6) fun) ) (equal (substitute 'foo 4 a :test #'= :key #'caddr) '(foo ( 5 3 1 2) foo (0 8 9 1) (-7 0 1) foo foo) ) (equal a '( (1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) (-7 0 1) (2 2 4 4 6) (3 1 4 2)) ) ) ) ) (do-test "test substitute 4" (let ((a '( (1 2 3) (-4 3 1) (3 5 -4) (6 2 -1) (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) )) (and (equal (substitute "@" 'dummy a :from-end t :start 1 :end 8 :test #'(lambda (x y) (plusp y)) :count 4 :key #'third) '((1 2 3) "@" (3 5 -4) (6 2 -1) (4 -5 -3) "@" (0 0 -2) (2 2 -4) (3 1 -4)) ) (equal (substitute "?" 2 a :from-end t :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '((1 2 3) (-4 3 1) (3 5 -4) "?" (4 -5 -3) "?" "?" (2 2 -4) (3 1 -4)) ) (equal (substitute "@" 2 a :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '("@" "@" (3 5 -4) "@" (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fb21e499ccb8b3721552454b93bc1354cfa4a5e7 GIT binary patch literal 4795 zcmcH+TWlOx_0G&by=!L^*G}WSCT*Z)<8iaWp-Cvz5AcJC;3Ja7qsn7A=Uz{2 zCq^M5*qS--*FERnJ3B+X2jfXOK6YfhWECdlv8nR-R9PMxn~*2RrX~gp@(}RlXW~Xi zJKn3t_qKg9R+n8O8Js8#lnZ&;oGMJ_2adJMvE8ydK2fp&*|iJE*q)s`_O!RR)pe`c zB=>e(n;mGgJ=Rv|yjm3^V}y`FauGq0kO+~8JzI%HO)YCG-HD{8=xR!f+B0?~0JSK& ztd_AWt9Qudv2n#Je70a=IY%amK#2WvCD5JI<7UFp?K$D35Vl{c)F*T$4W+3)8W95v zUeLP$Zes09yAn5Yx~U|(72Pn&tJV5bgm`{|`Mg$qy-&C>Dnx$VCmy)JWwqcv%#uV| zJt3CI`Q|zDwM8CarLfCCy~syhuTvXa#u;{MPu|Q(EHVINz9gp>!+67Q77sOC)UB#B zXEdB`G#d0`3;0Fe$h&Wz{fn!gcTN@;|6d38np6HYLh%A<8Vx{Rp4t17(eP73W{T5B zL!T&smzlF`542zud;)|(5f@8?8(34^MY!ZHLcmqzOHi9~X*UIrQ#<7HP)BrXDVKJ2 zpsYs$hmNBJv|u^5x=KqSq~h8{mXvny3KKtY3kxnw$ckWhUtHt?W<{~R0jD;;oE<~i z?m8d5p|E{!{>Xh0EqqRG&r;@NASp3*Ses2K0fws(V$=xOjr?B@Qa~MB|3umB3R`=~eZvq?S=S6Ts1X zvQe>~2E`ye0eHOdc;NV59gVAIyjRI+W-bHAXPlkCzHEQi)Ka2wtA=SrX-Epwpi~D( zZbMYdWQ>erl+sX6;SpaklnXfWL(W^JQNL~xD1}cOHX-Z?x#%%xnPSbI{J2 zF-~peU>#>Rb1KMyc%3oDe{kv&2XC=J;?G$i@jMG8p5mI%Ku#f85NM;O!vi^pc`oYX zU?&F;a$omzD$FRsVU+MMPQB0K2=B5u!p~S7;bpG!0@kjk)0*A|A%s!RJq$^^Gt<&o2~Isd+Gz6@ z+63L`1Vzs)kc5{_7E-hD72wlxY?4TRo~}n=0ax0q^&?(n-w7EbrSP;pgD70Ub-Dp{ z62S6iO*O-2PlX5`J(px2+v#T1Xa!!lGhr&c^-3C zA7a|cMAk$VX_B@e7-s28PjHX`6)CQ=x$0(#NspmbI+@Edt2Vk7t+sL57LfT;34KA> z$gI1Vb%bm9&|2HC>1Zu}$kGz$=|f0eW-8*JLB(Tqbuo?av8=>zuyn*(4o@%!JQR6y~a4O0v87#s{;{cpLY>ToGja(L_+rW$PcMdMFxWZW$P~hQ( z3X34*!Al@+q|!<4AbJoEa(+7lb{CY0csb$hR zbeYgitp|uW{n$>raT|SjEq(ZL@bCG7U0G8uOu~0_X|$k}hLq8=m&X-itI5)}DzGjQdoTggW5P`MtH{ z+Weh{A%X~ZM=;*2X4JT;We9V*uS(XfTuSjy14xbZ6Mp)rNOwVnkgoJ6yW*KFPs9-a z;Iw*~bKkS)#6S>vzvJ>9i2v69g3o@zXU}`!Z;4vSHj)3b>lUF%Xh z`%O&%rFyliF9$oiGpU{YF1q-YU6BqC<`I3v{*ow4h+W_@K92bL(;Zje{taU1rah+| z$GL_$wO_#yvz1Npj0Q(5{CsdPS2oni1T2=C%+e6g#JewNm>S>RFWQwxHc5kHQ=?^f zlvuFmDXY8Fo(n)Sk_TR1jClo-dU*N5@RB8XA^TDgkS3%;IAYR6^eF^k2E@N{@D59r z8juK0^PT*Y6*Isk72jYPh)3;;dZ1V;7s@csa=rjR8>dF|_~UV4L@rMh3i3c%E*~vf zrNhN?o2(ZGCgk|k#Kgd8tDGtg7E6Z*M%&QeBz+ozRVCpL{NlOHKS}Ov*kSg?GY4=y z#Qoe~rb<@h1pcUZrZ>VJ-){2Yr{S_41d|O1k(x~RstV4x0(&NOMrKh|9_3S2;=?Gn zbA9vX6hu10$65R+_q2)u;R*+TxTPh+J1e#Xr$Km|wM2N%o~xf`ZNEMp2u|1I09>E; zt1h;QGuRtn*SO&7G!l+9E#dYNo~303$2mC0!BmyhVVzcB{%+dCRx$wlAen}%k{2!v zbJr#Z=_*-+5%77>T6I@pM7*~GiIm!dVMKatAyO9)(XlMVrn?M5Pb@m#&Kcml>test>14-3-count-if-not.test ;; ;; ;; Syntax: count-if-not SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: Count returns a non-negative integer which is the number of ITEMs in the subsequence delemited by ;; :START and :END satisfying the test. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a non-negative integer ;; (do-test "test count-if-not 0" (and (= (count-if-not #'evenp '(2 52 44 5 3 7 8 9 0)) 4) (= (count-if-not #'evenp '(2 52 44 5 3 7 8 9 0) :from-end t) 4) (= (count-if-not #'oddp '(2 52 44 5 3 7 8 9 0) ) 5) (= (count-if-not #'integerp '(3 4 5 6 7 2 1)) 0) (= (count-if-not #'numberp '(3 4 5 6 7 2 1)) 0) (= (count-if-not #'atom '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 3) (= (count-if-not #'(lambda (x) (>= x 100)) ;; ;; create a list of integers from 0 to 149 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 150) b)) :from-end t) 100 ) ) ) (do-test "test count-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (count-if-not #'(lambda (x) (<= (realpart x) 8)) a ) 4) (= (count-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) 4 ) (= (count-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) 2) (= (count-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 15)) a :from-end t) 3 ) (= (count-if-not #'complexp a) 0) (= (count-if-not #'(lambda (x) (<= (realpart x) 8)) (append a a a a) :from-end t) 16) ) ) ) (do-test "test count-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (count-if-not #'lower-case-p a) 16) (= (count-if-not #'lower-case-p a :start 42) 8) (= (count-if-not #'lower-case-p a :start 49 :end 57) 3) (= (count-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) 6) (= (count-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\space))) a :end 60 :from-end t) 2) (= (count-if-not #'(lambda (x) (char/= x #\W)) (concatenate 'string a a) :start 1 ) 1) ) ) ) (do-test "test count-if-not 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (count-if-not #'oddp a :key #'cdr :from-end t) 3 ) (= (count-if-not #'evenp a :key #'cdr ) 5) (= (count-if-not #'minusp a :key #'car) 7) (= (count-if-not #'plusp a :key #'car) 1) ) ) ) (do-test "test fine-if-not 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (count-if-not #'listp a :start 1 :end 14 :from-end t) 11) (= (count-if-not #'vectorp a :start 6 ) 5) (= (count-if-not #'bit-vector-p a :start 5) 9) (= (count-if-not #'null a :start 10 :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3)) )) 1) (= (count-if-not #'(lambda (x) (char< x #\2)) a :end 10 :from-end t :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3) #\1) )) 2) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f8f636564090930d7e97ec9239f0b1b6b41937aa GIT binary patch literal 4646 zcmcH+e{369`Q1C)v17+g(olCDq?6`YrgNj z+>$f}*3l)p`+om=@B7|6PZ95tXk3YokDe&lxd~;wR6J2CD#POw%Bk_v#9&St2EOv8 zXwuXl>eHeJTkdJCPA`)TPUN!1+>m0Ga;Ju}r*|r?`xNcOM8O7R?_MBV_jk1IZ*Om@ z?$Oe5;q8Cgw4qJgo|fv$#Tlt~oDecd<`D!4sU*L04K1NZoGGX5 zhg#H3S~s2Y+BT&)enPc#pU>G?&gdy35#oHa?C;4KQ7e`-oN4K-6mlLb*Tf7p1*K`d zI-&kWFX&xz%GIsyYP%XuW(-S>^^l7*HRlNN`~Y+LY5s)+(xox-uNM!{{*8@mCGRnw zAj)b8u|1XVKS#d0!~?7l;{3VMB`#}kv&Y9z2qZgS7~I4cez92TS8lO>R}q7GDsv^5cGCsk{Vor6Xk{+p(yk7a z^eMn$S5X35uoQQ?O3NXn;@Z@HB!$tJ-NFJZ5)!+3eu)Q|9l>pc+{ah4TT!;J+DFJp zW$uuhJ~FqVfv+;Re>wABkQ7iGmu53cfZ-|xIW+=yBOgh<^4HyZYar_41^^}qc#F)S z$jnXTSdOFt(q$}%$L%|iJf3e{ z`3EB+lIMdm0=SJ6Q>ccKz^%$JliEI93TX91H!`6G?m_q5iH(bl6mB>4_?DHDf-8jx z?h2jFf50`mke_Y1+1O6yYYVl62Ayx0H$|dJqdSI&p4z7w-ErMiyJEmGdeaeF!vZt_ zj~^Z{JRUe**G8h6741_^-O8A7I!5{N>Pru#Ej>Y{)f!eZ!h&*$1>|ZtQNt14G?S*9 z%vh<66_LYW5Q=EVfXeyl2!o?_ZO4r#bVw$IdGK70;wgI(Jo$Q(Wo@jGp4D- zS^WOF&m@$c2if|iBBNSb7ok`X#Ye!C-#x^Uv7gl=Py}cI@tX8NqAM9!-P-}hK_Qk{ z15olmIVE2a)U%k}VLfUkO%y)J>JXIJIs`ek9>E@AaksFzOMoW9+$gA^0E9E?HBQk5 z0sbhMZwTs_0{oB%qR;R^^hq9w7KG*lkW&y=0rpNe;DH?IK_O}tpjiMBm5Qj+Ke%V< z&s-*57SueCBfZGuNYC&%(t|?fB-XB_Qo7L%A*92Cn-qrKg4!*BSYau|De@=olw9FX z$?M!H`HqlHvyXk5HJoJi!>r-6tUkjUAoXt6u#eTZu!cKWeIsk=gm9iS5Z%lB2&ocW z={^ISB#z`TYeJ9$u6$4*Ks?SbeKVO*MZTV16fWXzY!m9J!1AUo&E%cd#I_)F9Rvz> z#Vl29vzkJtkIUriAgdC5WXo@{W(0p_n-RPzlrDpkKW12ZuWoX!qpT6dhj@~5mjJs# zOO9&1jZ~hFybV~sM9j#fxmi8ihGum_=m()U6&Eu44!7<`Yx*`Puf#xt(K86@VdY8+jw^#(JHw5?|k1IJmpmbh*$*N>z+So0^@_6=P)9C z!jpE6L=|D11TNUVFjx*MmpAO=-q19fTc^I zRHJnt$iRem#r3mKql@R9vV3fC2+^mUZ&4~E_FWOpX!WE|fP%O&!iy_-)``t-RgiF-teKc$x)8Cf-Atq@|0wKk1a$@WvY)FO3zk^LU_9 zwhKLf!kP9%BC-cwUX1rHA~o>xh2W*g@Iv-q0)W&b6~vB|!|Xl)^r`@_3-A-3CQCsQ z?2wr6r&mSCrKC^s==46Pto7#$#at0OUm425Z^6>o5dI>}jwr>6Tu#XrmEso)cHvmQ z*rFJ@?1U06O-y9Rb}EU&V7_oHJJy2!j zeUI=-SP)+~|9#xx_uh(eldv;FT0GUKsnI^oR8vF>KC19YJ4B>AXGjf3`XKIaoMwqK zTg(Fub8phy0$dT`7pt~JdVbZGVE0Qu;#(q(I@2|ie9Ny-`U8_SxcS#7t27teEExQa zuWLf^-Xszgc~Zu)kqWGYASXapfX~g406)L{S8sKD_$vCL_v0zJE=9qTDcs&Gz}^`W zM(_Ci#$I#FA*c^F${$N;y%>VBFD^#e$x2YkjuqZFe+cjFD@#5%ij>#?KMV4Hf_~x5 zb32@ozpv^S@`qLZvK#i6{GRP9z~LdowGzP3XK%odXw?yCx=QwVeN|NIT|!%(=>Tot X>6NSe0n)sjkXA+{kE8P^Di!i?+t&VA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT.DFASL b/internal/test/LANGUAGE/AUTO/14-4-COUNT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0b107f52bc3f627c8d0a05ba90665461f29697b3 GIT binary patch literal 5634 zcmcIo3vg7`89w*1uRI`85?TaVsZa>Lsfj@$l$l&MH)NB|ZrFz=wXGA9g>15U5H?oE z79vt@bdvjR##P( z=hf*UA9=f?O(oi_sw~e-A0C&A`WR#F>=Y6gV?|71=D}o9S=b1LwK}iQ(ENInQD%;s zNhgd&i-e4znJlh!C;Ixec=VoV9Ea1hjY*7|2a?XZh~E?T2K?rjG$a+6`;&!Uzt#*x z(>EAQc4oYwcgai^R#a(KnkNwPhuPur!d;BnzJnckzVk$bbi7w;{z-#;XX%1s$rhIp zFJvsProZgBTu`_Wcqtk^dCy>Dhl;8(r1I=!fh!DAwxPqcxGmJ1qo*iN+ z=~P=*nx*-<-cw&dQM?kYumN)Ha%DQTMBp734lVdmui_o)q0Z@lCqQ`JE=Q5ndHkdw z+UG|b_xXRy*l6d2{svhBucH(5@BCD@BTg~8Q?d31Vj?s7lec8^=ZHH{6&%GCOqdw# zGZrXMX7O;(#jIvAf-GVq(up4)8fqL4>}3I%xqky5=8l=w#;gxrc=II1uN32iYWqY zVpi?x)a2Yj;4G|68Spi!05zH&s%vtxa|Zfk&jk!WH3MRm9E>l^#i1Bd_vXN0N9zM* zU+kJ@kr`Na^;FL)74}fRxV}oKYe1r=SHLw%iS1Z6C571AOpmD^3n#OX?K@PV$i^?G z=yroJj_Uw^P%`k2!Gj8UlPkuYqHp=m1dHVfx2gV&S%#2ts%1I~90rW#L6Tqzt)3x` zBD=T8@-%c(^*)OqC`9_*Yboo#0s?JSBFF}cuuIJvOQ6Y$r1ai7=fb$_kT2x{xS zfcQ6r%48RJ$xe72@Yvu{;Xo-a^XOquy%sdWksurh9&w`BL#?5((IiVVHNt^1p0DI{ zmx71LoH8RA3~!NevC5xE|?2HE{sWj_eKk;F zw%SNjQ|sj23dN{fB`#9IK$B+pYZ3T707|C4oG(P^CcYR+33nqY1_fIvtOtdCA*m=r zMg5Q9)PE57hA>cnOW>>gCNNiD;Y*M_i(wj#R&1w8?@7#tu`#0inh`w)8fvDS>JP~H zyJWnFe+D(~=QktS!IvW0PAUmfso)C`Tp==|E+S&XYp3opuf5nXv(cv1cc zDk`X;hH{QHUMA5?{IdwYNZ z1_7K-l zwudk6<64|Ajc_fKRtGby#e(<&)2KD7>x zD3GEzk2#ia?zNf2HgimcVHRYDr-fUa4K&=J%!~L#-VJ`ER$Jd1HY89g)N30eu*%l^ zjG_0^tXLZ7CVOD{nC=ub9OkgYGWklb z4+xtXMaIVrr!_d*^S3MK#@s;R`Ul%>4gCf-l+`g`_To%1{hncs}3i#Pq~-1VRx@ce z6ISystLYIb7yNEWs%U(J&ZVm98Lh;Q-Xbz8zcF`B|wMslOa3c z+V8^CO!vU-QV$*%8Is>IljU`7iMF^qIxqnL+QPkiu(v%C>+5yX1;5%I)h66s5XQy%1jj^hb&mIl-?JiQ`kIbHBVd339D&Z%?GSzuhnd|n)+o2 zAXQEu04`XmTnvD{0R<_^0I=Uowtha+hQJF%j^&<}6DWKv7d?;Ykz5oPAv>Il3J(vM z$+>O4iP+Y`sFrzlj%@9miFS-^g?~uep+d%BD}mlBaBu@@5bt&7m`jpXo81BXkEFO( jm}7Gk)wa6^0^4N?K4w)}l|MZzD$SlU_6YX+Y&!ivTpcFY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST b/internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST new file mode 100644 index 00000000..d08abd12 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: count ;; ;; Source: CLtL Section 14.4:Searching Sequences for items Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 29 ,1986 ;; ;; Last Update: Sept. 29 ,1986 ;; ;; Filed As: {eris}cml>test>14-4-count.test ;; ;; ;; Syntax: count ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: Count returns a non-negative integer which is the number of ITEMs in the subsequence delemited by ;; :START and :END satisfying the tes. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive number or nil ;; (do-test "test count 0" (and (= (count 2 '(3 4 5 2.0 6 2 1 9 2 8 4 2 4 2)) 4) (= (count 2 '(3 4 5 2.0 6 2 1 9 2 8 4 2 4 2) :from-end t) 4) (= (count 3 '(1 2 4 5 6 7 8 (3) 9)) 0) (= (count '(1 2) '( 1 2 ((1 2)) 3 4 (1 2)) :test #'equal ) 1) (= (count #\q "antique-que-que" :test #'equal) 3) (= (count #\q "antique-que-que" :test #'equal :from-end t ) 3) (= (count #*1011 (vector #*0000 #*1111 #*1011) :test #'equalp) 1) (= (count #\a (make-string 50 :initial-element #\a)) 50) (= (count '(1 2) (make-list 100 :initial-element '(1 2)) :test #'equal) 100) ) ) (do-test "test count 1" (let ((a '(3 4 7 8 -2 9 7 8 -3 4 6 1 7 4 5 -3 2 0 4 -2 7 2 -3) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 20 21 22 ;; (and (= (count 7 a :start 3) 3) (= (count 7 a :start 2 ) 4) (= (count -3 a :end 17 ) 2) (= (count -3 a :start 9 :end 16) 1) (= (count -2 a :start 5 :end 14) 0) (= (count -2 a :start 4 :end 14) 1) (= (count 2 a :start 4 :end 19) 1) (= (count 2 a ) 2) (= (count 34 a ) 0) ) ) ) (do-test "test count 2" (let (( a "Fatal error in function SYSTEM: TASK-SCHEDULER")) ;; ;; 0123456789012345678901234567890123456789012345 ;; (and (= (count #\n a :test #'char=) 3) (= (count #\: a :test #'char=) 1) (= (count #\s a :test #'char-equal) 4) (= (count #\space a :test-not #'char= ) 41) (= (count #\F a :test #'(lambda (x y) (and (alpha-char-p y) (char> x y)))) 6) (= (count #\R a :test-not #'(lambda (x y) (/= (- (char-code y) (char-code x)) (- (char-code #\a) (char-code #\A)) ))) 3) ) ) ) (do-test "test count 3" (let ((a '( (1 3 7) (2 4 6)(38 5 7) (4 2 1) (-3 -5 -7) (-2 -4 -1) (2 22 31) (38 -72 7)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (count 7 a :key #'third) 3) (= (count -4 a :key #'second) 1) (= (count 38 a :key #'first) 2) (= (count 38 a :key #'first :from-end t) 2) (= (count 0 a :key #'cadr :test #'(lambda (x y) (> x y))) 3) (= (count 0 a :key #'cadr :test #'(lambda (x y) (> x y)) :from-end t) 3) (= (count 0 a :key #'caddr) 0) ) ) ) (do-test "test count 4" (let ((a '(#*11111 #*0000 #*10101010 #*01010101 #*111 #*00000 #*1110 #*0101111 #*000 #*11100 #*01000) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 ;; (and (= (count #*10 a :start 4 :end 10 :test #'equalp :key #'(lambda (x) (subseq x 1 3))) 1) (= (count #*11 a :start 1 :end 9 :test #'equalp :from-end t :key #'(lambda (x) (subseq x 0 2)) ) 2) (= (count #*01 a :start 4 :end 10 :test-not #'(lambda (x y) (or (/= (elt x 0) (elt y 0)) (/= (elt x 1) (elt y 1)) )) :from-end t) 1) (= (count 'dummy a :test-not #'(lambda (x y) (find 0 y)) ) 2) (= (count 'dummy a :test-not #'(lambda (x y) (find 0 y)) :start 1 :from-end t) 1) (= (count 'dummy a :test-not #'(lambda (x y) (find 1 y)) :end 5 :from-end t) 1) (= (count 'dummy a :test-not #'(lambda (x y) (find 1 y)) ) 3 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL b/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8b06e578fa4b50f0874a540375bc8042cb05c12c GIT binary patch literal 4390 zcmb_f4{Q_X760zeah!iNp-I{%0S;QqFgP@UYy}4D#knL7{uAsoG(}@_lS^zk$64$Y zHU`a@MAr7YHH6Xo)^**cYEnCm(Nx<+yN*iJ)K1fcv_G0!ty8B;m8xnQQb)(ezI`G7pPffh##l8|m~+yu_8NN3@O1`)x-YDS zbgwh%*dEx6FCNpQj$PBL<}xEb%Y4MNa69QNlNfWJvOS&gu-^zo!p@X5E>$|;u&V-L zUoUJ;>(ZI*x$XtMOO9RMvc7Yf8en&Ize&z|-iXUrAETwY1O+9RDCW*_{#N8Y=< zp++h}Eq<#QJDEKD<+(6zd8|@P8Db1Ra3xzV%Z(bVB-tSTkYDZr;~Zka3tDI~6roZ? zXeii<^^?i*)T^Lae!O&qU{TZ%lr(u(8qt5f)nY`R~6ZJzA`(M$N&32EtjJXA&xR1Kf^;?nMZnMZ(%e2xUl+ ziwLQ?5eC7|-Yv3QF3h6}f4cCeca{%ZwW^SRX6gJ;e)?!JTSlL)@Kclr7U%Z-bZh~y zWg)L6KfQh_yjA(}0dm9LP`aTN2SK%};MC zVjhHm;#Rdv@M<>WawrSlV8uPTbvIxb)ZgfCn@m=xs&V9e({A$mBjJt!&Lv;B7VZe@ zQD1uiG~uq8S1#pcatVB0F!*Y`ejG)^g)#2Jk@*=MfDeEtcV{FD zQxV|~jOvd^qk6b#By$OE8^KmPyE(rW(4XS5$lqirZp+q4r47R~Xf( z|1GaW@fxp3@jRhZgbou*6WUEEM5u$rI#S+ENES%GCXoCdp?3-W2{ZCXdi#7aeK*9C zU*gMAoZ+{l_ztf{VbYoet=U0nE1^0X!;O=9`0yC@IJ1N8Cuj3@UPcx zt!R5^#wOse0D8o8JRA{@Ugs;2_6oKjs%ybs@Pdk;0a4kd_u=)+xTrH43Hcx*D!$EE zqj;LHLNUqLp!hn!8^z=N9uy-)IY71{vh|a#2ZBjEk=4bUP-w*3Nvy4WB`Q@+DG<`S z3Ms81^IhbmRwOQ8;r9YrzAS9=M_fhp4sS&9w(u^W;&&mkMN#E(68o{X{%$S018w_= zxmUQBqheojh@5?zuS3daqHH3Hm!hu~smjZUQbCkbqR4_GT@@7ReL<1l6BOw$WP6Kj ze-QDc3nHHMQ)0eM%rj(rfo#vyy60%!31WVgn2(CE(jY1ONx7fa>7;BYvwYRcD`XdRLr&2 zv2V+n*_@hAWz&gVe^SLG=xTH9RR*fp9MjgQg9&)s9Z*xl^rDKoV{3t?yyZ-}CRo*k zQaW)w4}bXc&j}ZbU!(nx&Q!&OBu~gLVZT}{#5J^EV>eoLg?P$@1Rorf%A2QI#RKqc z)!>`2W{%xxCDIQMBrux=^BA6nvY5xtl-EfNBu|QWi9+G(*P|)pvOzyjLH8{lv<=Nll_<%7Rth1y`7xHE zg&San5-L`*zY^>4zz2=)QT+$6&zF zqgpV=E06}GVRt-Y=rlN9TyTzY%*sFDJ`@4R&JLSHiCpRt6An(!95P3nRn|=z%wlLA@1(`!AZ_*1Xe&5Ad!&CYi7j0s_HP_}`Dkh=IX89m z^9B)~A@TH0c}L*CeDilE9imkak=WzdWi$0c-!NI`D%yy6XOSLfjZ{l|Hwn0J>*u#> zqi7Xy**^q{UAzH_`iZ2s#W~`ga7uU=jY=rNyfJqlGT#u#gV}KSol`DJR^VMu;TyP@ z&Y|Sz>v3dufPkZ4yLuxo`r3`y{BwN&b7kDA4)Ps5m-#(4LUY%~5@^~0$q2A$Z r?=y4>NL5-#PaNJ%+JpM|cP|}%{f-$AJk2wFL@1@XHD%xWQa=A*F24&( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.TEST b/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.TEST new file mode 100644 index 00000000..60398a9c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: mismatch ;; ;; Source: CLtL Section 14.4 Searching sequences for items Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 30 ,1986 ;; ;; Last Update: Sept. 30 ,1986 ;; ;; Filed As: {eris}cml>test>14-4-mismatch.test ;; ;; ;; Syntax: mismatch SEQUENCE1 SEQUENCE2 &KEY :FROM-END :TEST :TEST-NOT :KEY :START1 :END1 :START2 :END2 ;; ;; Function Description: The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are ;; of equal length and match in every element, the result is nil. Otherwise the result is a non- ;; negative integer. This result is the index within SEQUENCE1 of the leftmost position at which the ;; two subsequences fial to match;of, if one subsequence is shorter than a matching prefix of the ;; other, the result is the index relative to sequence1 beyond the last position tested. If a ;; non-nil :from-end keyword argument is given, then one plus the index of the rightmost position ;; in which the sequences differ is returned. ;; ;; ;; Argument(s): SEQUENCE1 SEQUENCE2 - ;; :FROM-END - nil or non-nil ;; :TEST :TEST-NOT - fuctions of two arguments ;; :KEY - a function of one argument which will extract from an element the part to be ;; tested in place of the whole element. ;; :START1 :START2 - non-negative integers ;; :END1 :END2 - non-negative integers ;; ;; Returns: a non-negative integer or nil ;; (do-test "test mismatch 0" (and (eq (mismatch #*101000001111010101111101110 #*101000001111010101111101110) nil) (eq (mismatch "this is a string this is a string this is ... " "this is a string this is a string this is ... ") nil) (eq (mismatch (vector 8 7 3 'a 'b (+ 3 4) (list 2 4 6 7 3 5) "lkj") (vector 8 7 3 'a 'b 7 '(2 4 6 7 3 5) "lkj") :test #'equal) nil) (eq (mismatch '( (1 2 3 . 4) (a b ( c d)) (10 20 33 44)) '( (1 2 3 . 4) (a b ( c d)) (10 20 33 44)) :test #'equal) nil) ) ) (do-test "test mismatch 1" (let ((a "negative integer. This result is the index within SEQUENCE1 of the leftmost position at which the two subsequences" )) ;; ;; 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 7 8 9 0 1 ;; (and (= (mismatch "negative integer. Thi" a ) 22) (= (mismatch "negative integer, Thi" a ) 16) (= (mismatch a "SEQUENCE2" :start1 51 :test #'char=) 59) (= (mismatch a "SEQUENCE1" :start1 51 :test #'char=) 60) (= (mismatch "SEQUENCE1" a :start2 51 :test #'char=) 9) (= (mismatch a " subsequences" :from-end t :test #'char=) 102) (= (mismatch "rightmost position" a :start1 4 :end1 10 :start2 71 :end2 80 :test #'char=) 10) (= (mismatch a "rightmost position" :start2 4 :end2 10 :start1 71 :end1 80 :test #'char=) 77) (= (mismatch a "This result is the index within" :start1 2 :end1 50 :from-end t :test #'char=) 19) (= (mismatch a "This result is the index within" :start1 2 :end1 49 :from-end t :test #'char=) 49) (= (mismatch "This result is the index within" a :start2 2 :end2 49 :from-end t :test #'char=) 31) ) ) ) (do-test "test mismatch 2" (let ((a '( #c(1 2) #c(2 4) #c(-3 20) #c(-2 -2) #c(0 0) #c(3 7) #c(-1 -9) #c(4 -5) #c(-3 3) #c(1 3) #c(1 1)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 ;; (and (eq (mismatch a (copy-seq a) :test #'equal) nil) (= (mismatch '(#c(10 0) #c(-3 7) #c(-11 -9) #c(40 -5)) a :start2 4 :key #'imagpart) 4) (= (mismatch a '(#c(10 0) #c(-3 7) #c(-11 -9) #c(40 -5)) :end1 8 :from-end t :key #'imagpart) 4) (= (mismatch a '(#c(3 10) #c(-4 30) #c(-1 -10)) :start1 7 :key #'realpart :test #'>) 10) (= (mismatch '(#c(-2 -2) #c(4 -5) #c(-8 0)) a :from-end t :key #'realpart :test-not #'(lambda (x y) (= (signum x) (signum y)))) 2) (= (mismatch '(#c(-2 -2) #c(4 -5) #c(-8 0)) a :from-end t :key #'realpart :end2 10 :test-not #'(lambda (x y) (= (signum x) (signum y)))) 0) (= (mismatch a '(#c(-2 -2) #c(4 -5) #c(-8 0)) :from-end t :key #'realpart :end1 10 :test-not #'(lambda (x y) (= (signum x) (signum y)))) 7) (eq (mismatch a '(#c(0 10) #c(3 7) #c(-1 -9) #c(4 -55)) :start2 1 :end2 3 :start1 5 :end1 7 :test #'equal) nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-5-MERGE.DFASL b/internal/test/LANGUAGE/AUTO/14-5-MERGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f090eb3e5904087dd38cc1dc1be9754f2448ec2b GIT binary patch literal 5916 zcmcgveQZT5dqO??d%L<5DNoPAbnn5mr=ut3>FYU|+MDon zfZp?9NQ)>BH3dW4R&S`YMe{6sQ;9w4MBEcQnCOe|>A%xcx6TvnO?7nxbNAgK)~yfJ zulM^`+cpQIVIJ*7HI+cjAFWHy`bUv8Cl zRxd6WO`U>(2E2fUM9a7^ar#MN_@j)2MU5kU#Z5bko7NRKRTVWIPUe1R0p&bmaf!*N zM^)heIk@c`>T`lHnEa}`RTAyM4Oi~;WXrX(TF1Kf*0MRuv_|?&wl$W0qsiTlF|~Vq z^77FyYmQ-;=1`N1Aq;4{CH4I1@I~M>2f&56G^e4tH1`TH z4ruP=;@vKQs?zB2tE2lePMWiO{PK|I8m~BltVVhA)68l%hFcW>mO<=X0dF zCPwZlVgba&$kKvFRdYZA6WFx8cCj)54;_0{bFh{@qB-W>GqNk&voZ*R{e=uN1Qa}B zlyOlFWFRQdHjdnX1MiV7a{w46yJAOH%n1z&_=f~+=FGCrE|*(Zz5IB#dK+eQGnWlg zhu-IC>v&~$P>B{v>X-W(bU6fRfpJ`~@`f~ZQ!{SgzNVnMDXc_%jm@A@w?w^?jh0Ada9Q9o z!6m~vQSJ=|W1%KrM2WRUV4n}MgTfqbkH(Z1Nt}y_X&20~H=?h#+bI5*9nphH&!jg~z zJc$ylEZEwrsGA^PiEw{``HLSiNAUwr-T|m3qU=y2Q3bH#-xyZBz_G8D7 zEw??#1Mq%}KcI^d*~E#9WhIugtVEGzC7fgK!i&sZ_$il$xnywZICVp@Q0RTMVmEaw zw4#x^SJH~*)O`A+a)Cg}(W))X%7{vy9JCdb6gk zL0W}UH%mkQ93$i{bPOx%mRJ)Q$(ziPyiPqRo#YE?C37T8xrc)h3G*Vs#wg$n1T&{qP8K>;P$z==&oP{g1)=2^ZOC*swgA(ag zCg5!fG%TH|mB3Y(IN>faLoL?gGzKvE^|kN{Ak$lwB967d7$|{=H|$fUJ0H6y$rva! zKgDbMpJoIV=OzQWc~2|!O#VAGdRAA@j=?QS(}F z&d!#=5 zQEtHK19UZ#?S}5Iuk$wq{DC#_^RHbKSi1(edIoASboo#saR`ykhVDr9!(I?ic625? zJ32e!ov2sfD|yY@0Q*Nd2tI4z5BZITE;ZoJA+IxZiysE@*VmyKFm!V&kxHl1DAj>W z2mB%LGjx$LcK{?A??`gUa_~?0r&Imuenizk;6w_!+rc;4nPmJTLnrY#^R58z_)L!F z5R?^UGjsvHN-(i{Ne#i)NDARTNB@*V{72T*wq z0GU3K-xcl?c_F`K@+^krC6m!i$>dCa$>bNaN+u)OlF1X`n<<(6Xr^THz5J5N>Aal3 zlgs(&N6j~Zg_1v)WB`I>=8}8`TZVH<4$qoP^2JPZ$>(`2hrR)fE zLKbs;%NVMho9NW+3=8Li$zc0QA&-*zaIWT1s z`^dq~M;CX&)h?Oo3W=@&6Q=)rHl5EPJI>fqWJjSW)=b_Q*~Dip+ta)W&Gl(!?g})T z&2r%$vdMcQm&NyUS)4M4yq0RY%v@RK^7`smxttbrrQJ>Jrn>6-N*PvUjw9Pz^kI=;2hM+U z!wpy3$Q~B4s;HL;TVuZ0UEn2_FfZW`@W3DF>FaOQ+CeM)8lGMhk^dDu)EPDISHNa1 zKg>ftocml>test>14-5-merge.test ;; ;; ;; Syntax: merge RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY :KEY ;; ;; Function Description: The sequences SEQUENCE1 and SEQUENCE2 are destructively merged according to an order determined by ;; the PREDICATE. The result is a sequence of type RESULT-TYPE. (for detailed function description, please ;; refer to page 260-261 of CLtL ;; ;; Argument(s): RESULT-TYPE - must be s subtype of sequence ;; SEQUENCE1 SEQUENCE2 - ;; PREDICATE - a function which takes two arguments ;; :KEY - a function of one argument that will extract from an element the part to be tested ;; in place of the whole element ;; ;; Returns: a sequence ;; (do-test "test merge 0" (and (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'<) '(1 2 3 4 5 6 7 8)) (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'>) '(2 5 8 1 3 4 6 7)) (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'=) '(1 3 4 6 7 2 5 8)) (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'/=) '(2 5 8 1 3 4 6 7)) (equal (merge 'string "BOY" "nosy" #'char-lessp) "BnOosYy") (equal (merge 'string "BOY" "nosy" #'char<) "BOYnosy") (equal (merge 'string "BOY" "nosy" #'char>) "nosyBOY") ) ) (do-test "test merge 1" (let* ((a (do ((m 1 (+ 2 m)) (n nil (append n (list m))) ) ((>= m 200) n)) ) ;; a list of odd numbers from 1 to 199 (b (mapcar #'1+ a)) ;; a list of even numbers from 2 to 200 (ab (do ((m 1 (1+ m)) (n nil (append n (list m))) ) ((> m 200) n)) )) ;; a list of numbers from 1 to 200 (and (equal (merge 'list (copy-seq a) (copy-seq b) #'<) ab) (equal (merge 'list (reverse a) (reverse b) #'>) (reverse ab)) (equal (merge 'list (copy-seq a) (copy-seq b) #'>) (append b a)) ) ) ) (do-test "test merge 2" (let (( a '(3 10 5 49 30 50 23 4 8 27 10 4 32 8 20 9 11 27 13 20 32)) ( b '(7 30 4 12 6 23 12 20 42 45 50 43 20 18 7 6 23 10 22 3 1)) ( c '(3 -10 5 49 -30 50 -2 23 -4 8 27 10 74 -1 32 8 -20 9 11 -27 13 -20 32)) ( d '(-3 4 10 -2 10 34 28 -5 59 20 -4 12 20 0 10 14 33 -6 -4 -2 100))) (and (equal (merge 'list (copy-seq a) (copy-seq b) #'<) '(3 7 10 5 30 4 12 6 23 12 20 42 45 49 30 50 23 4 8 27 10 4 32 8 20 9 11 27 13 20 32 50 43 20 18 7 6 23 10 22 3 1)) (equal (merge 'list a b #'>) '(7 30 4 12 6 23 12 20 42 45 50 43 20 18 7 6 23 10 22 3 10 5 49 30 50 23 4 8 27 10 4 32 8 20 9 11 27 13 20 32 3 1)) (equal (merge 'list (copy-seq c) (copy-seq d) #'<) '(-3 3 -10 4 5 10 -2 10 34 28 -5 49 -30 50 -2 23 -4 8 27 10 59 20 -4 12 20 0 10 14 33 -6 -4 -2 74 -1 32 8 -20 9 11 -27 13 -20 32 100)) (equal (merge 'list (copy-seq c) (copy-seq d) #'(lambda (x y) (> (abs x) (abs y)))) '(3 -10 5 49 -30 50 -3 4 10 -2 23 -4 8 27 10 74 -2 10 34 28 -5 59 20 -4 12 20 -1 32 8 -20 9 11 -27 13 -20 32 0 10 14 33 -6 -4 -2 100)) (equal (merge 'list c d #'> :key #'abs) '(3 -10 5 49 -30 50 -3 4 10 -2 23 -4 8 27 10 74 -2 10 34 28 -5 59 20 -4 12 20 -1 32 8 -20 9 11 -27 13 -20 32 0 10 14 33 -6 -4 -2 100)) ) ) ) (do-test "test merge 3" (let ( ( a (vector "fdf" "fgfg" "dfgfdg" "ddf" "hghr" "er" "tytryty" "hdfhrt" "f" "ffff" "rertrt" "ryergdhfghgfgfdg" "weew")) ( b (vector "45" "4543" "333" "43543" "32" "" "3" "4545421" "34" "6666" "67567567" "2143545656547657665623"))) (equalp (merge 'vector (copy-seq a) (copy-seq b) #'< :key #'length) (vector "45""fdf" "fgfg""4543" "333" "43543" "32" "" "3" "dfgfdg" "ddf" "hghr" "er" "tytryty" "hdfhrt" "f" "ffff" "rertrt" "4545421" "34" "6666" "67567567" "ryergdhfghgfgfdg" "weew" "2143545656547657665623")) ) ) (do-test "test merge 4" (let ((a '#((1 3 -4) (2 10 -5) (0 -2 -3) (4 5 6 7) (9 2 1 -3) (-5 -3 -2) (10 -2 40) (30 9 18) (2 -2 34))) (b '#((0 0 1) (-3 4 2) (2 10 -3) (5 6 2) (-7 4 2) (-3 -2 -7) (3 -2 10) (4 12 -7) (7 3 -2) (3 -3 3)))) (and (equalp (merge 'vector (copy-seq a) (copy-seq b) #'> :key #'second) '#((1 3 -4) (2 10 -5) (0 0 1) (-3 4 2) (2 10 -3) (5 6 2) (-7 4 2) (0 -2 -3) (4 5 6 7) (9 2 1 -3) (-3 -2 -7) (3 -2 10) (4 12 -7) (7 3 -2) (-5 -3 -2) (10 -2 40) (30 9 18) (2 -2 34) (3 -3 3))) (equalp (merge 'vector (copy-seq a) (copy-seq b) #'> :key #'third) '#((0 0 1) (-3 4 2) (2 10 -3) (5 6 2) (-7 4 2) (1 3 -4) (2 10 -5) (0 -2 -3) (4 5 6 7) (9 2 1 -3) (-5 -3 -2) (10 -2 40) (30 9 18) (2 -2 34) (-3 -2 -7) (3 -2 10) (4 12 -7) (7 3 -2) (3 -3 3))) (equal (merge 'list a b #'< :key #'car) '( (0 0 1) (-3 4 2) (1 3 -4) (2 10 -5) (0 -2 -3) (2 10 -3) (4 5 6 7) (5 6 2) (-7 4 2) (-3 -2 -7) (3 -2 10) (4 12 -7) (7 3 -2) (3 -3 3) (9 2 1 -3) (-5 -3 -2) (10 -2 40) (30 9 18) (2 -2 34))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-5-SORT.DFASL b/internal/test/LANGUAGE/AUTO/14-5-SORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..32004db05d0a9bc7cd963b74a6de40174155bbe7 GIT binary patch literal 6385 zcmcIoeQaA-6~FJd5; zi9ebqXroL)fMghHw&>kW6EI*KVuCFL#KyMp@edgrFxHI$LgPc4gqXCV{ehS?g>&w8 zKKhxp3TmBu?z!jw?zz8n@45HBSyDCR4M<*nY&@%}c}Xu7$4f;it>>kJUdks`DGhq* zv))ixx!Wgu`&#d4vqjdmB=c&bsHUW7NiC!jQ#VO%w@dPPKC6Ln+ig&7J9wb|U`I!* zty_)+INFAN+7BM+IC%4|t+wTd=LM%u2uYGfENTdG5)(1bl$|Y6B@%Ua`vZzQDEBKZ z#;j4c!d%?3h!Qr+Tid0gKJM1kld6W(87mNh5aVlQYj-T@jrv1DV@^0N*p2(j4u8-+ z08^8D6e3zHD2Of?<(jq*_W^e#6poUI=WFgI#5|oNWcM)h=BJtG`h;h4V8Sc zZ03uhx;{|=v)Lybj_p{1vJwL5i`iu3dS8VXR(!RhA@Io^f!5-?%0~a>*zVC7^ z_Aa@=SnF6`xDE+G8yD$yi74Q&mXOn#g`*et#rjJNhc8qEWIaIEZwz@lga0;<0Mp48 z0&324YJEt+J12POMDOg&3k?@d7}z?UdE_af`9cV+1M2`_UmRP8q7HEE6`YS>3g>d@ zh);fYd3-C!cL2Wi+VB_dx;(m>qgw#od~N8P9XIpmR^sN!0I#d*0OtU)JC9n30IG2@ zf4MTpE14}Mu51Lui9m#iMAR=Yw1HTG<9i2&(`=VrCRatonaq>hFSUhdGtR7&hz{d{ z@~#$dDA?u44CeO9!LEQ3c6h-z9N;DRRH0Nb` z(h`YBqDsFgTx<~ywa{8qEv+$OYOHHf!r@TZ9g0NU-arsPf^NfNkh-vt=!dXyutNMd-2pZ6 zP1a9*jW%HIx2(JP3vTiRFXp)A=egx1x18XX$GJ&>7yG&89&XvdEw^$@GcytX#Y}|1 zG85r1%tScLi{CIy;R)uv@LlG-K$-Kx37CErBNqG=`ZxOgP62t`-!0N4ZHx{^ng~KS-K)V@Fbf}o#go>$8 ziKF~1ZN_4b7u~c8Ylm5PQ!6XPH&~nadmPZ~lf#F=M4aZzBK_E@qk}aDlt=_y$nV&| zy1NI=OkO$MMVmhXqCFA~!wzw?K0VOMJYtkY|o#Q9rna=01I=g@WjQk`>oww5m zXF7)uPt0`g1nJ0Q-)GzPE%YC9ddi2#iROU0kk?+%G&X(^|7q)*+kyy5s|M(XizUPk zFQQwAlyGRs?G5$!Lz)iwBLfgL@ZR)i7?htHot!mrKnCgEjRuAOB1@^poQPb(FU}HQ zl{_#Ih}Y2uE0xW(L97MdgcgB%_<(1Pxq3ctWTg^BP8Bl82*Q{$S}OE0s*p5BGbb0g zZaTzB#c8~ZsH__&7YRpRDU}9`tvYB!c*vw&_0tsw+uC7)_BV&uR zdeLfq@c+QgeVe-&FQR6jK;xX6FL7!#;~`wWXUa`pmgZoCtXyT-Ngwb->XQQzT8n0o za0g?dsKT@Io#$n*c4RtE_hGTiDBDvhHIvKfdZAdHLfy7`vdgz*_AOaP&*BEREW##( zy>2r9Xz*H2O&R5?f|@I+@YGD?M@nOA4owQB9D=AxJqI9`G(574 z8PMmlpf^osbeNa;{yeFNL}k9(e7k-&VjXR-g-l^ZhS^bDRY|TQq$daFM5JjWl3?;e zB_pxy4R=meq-oBH_-k4~e_w#uBu8=>8hs+4FQM*7^Q6(YWc4jMcx)UP8%?~X$cQeg zt_DJUoDceSPLg#~NTR1!*|~e3SUZ`cSIdoHURf;S829nhK+I$*uj^VilTlR_iHXgV zoxUZzZ>f$GQ-{QiUK=ml*7M@yV;*q;zC;EBSw3t?Dv2hm(D}?`WPo10W zsqi9){~^mmbQrP>{UpDSedoON(gxuWzRA*ykT%MV(^ID=PnL>>{KUAP8`DNlWHTda zHI+P`K*Qt4Tq6<97OTTv=d5>a-_f|MNou~~BR96()Os^!Dj_~kGQOpHJoBIN%jXtu z!pi7bsA|BRgXD zTy9PhYeZ$hQG`?VTXGC00o$3Ti=0>f>2>BBb;Bm^7XkQKj}(dE5M7Jy1oGSHcDi*;+GE*EY6|$pe*R%EwLsotM zTB!r~%#DyRobb*WfDiFq?#h!68cckt{tdcml>test>14-5-sort.test ;; ;; ;; Syntax: sort SEQUENCE PREDICATE &KEY :KEY ;; ;; Function Description: The SEQUENCE is destructively sorted according to and order determined by the PREDICATE. ;; sort does not guarantee stability. For detailed funtion description, please read page 258-259 of CLtL ;; ;; Argument(s): SEQUENCE - ;; PREDICATE - a function which takes two arguments. ;; :KEY - a function of one argument that will extract from an element the part to be tested in place ;; of the whole element ;; ;; Returns: a sequence ;; (do-test "test sort - test cases copied from page 260 of CLtL" (let (( foovector (vector '("Tokens" "The Lion Sleeps Tonight") '("Carpenters" "Close to You") '("Rolling Stones" "Brown Sugar") '("Beach Boys" "I Get Around") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Beatles" "I Want to Hold Your Hand")) )) (setq foovector (sort foovector #'string-lessp :key #'car)) (equalp foovector (vector '("Beach Boys" "I Get Around") '("Beatles" "I Want to Hold Your Hand") '("Carpenters" "Close to You") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Rolling Stones" "Brown Sugar") '("Tokens" "The Lion Sleeps Tonight") )) ) ) (do-test "test sort 1" (let ((a "qazwsxedcrfvtgbyhnujmikolpPLOKIUJMYHNTGBRFVEDCXZSAQW" )) (and (equal (sort (copy-seq a) #'char<) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (let ((b (sort (copy-seq a) #'char-lessp) )) (and (= (length b) 52) (every #'(lambda (x y) (let ((c (elt b x)) ) (cond ( (char= c y) (char= (elt b (1+ x)) (char-upcase y))) ( (char= c (char-upcase y)) (char= (elt b (1+ x)) y))))) '(0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 ) "abcdefghijklmnopqrstuvwxyz"))) (equal (sort (copy-seq a) #'char>) "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA") (let ((b (sort (copy-seq a) #'char-greaterp) )) (and (= (length b) 52) (every #'(lambda (x y) (let ((c (elt b x)) ) (cond ( (char= c y) (char= (elt b (1+ x)) (char-upcase y))) ( (char= c (char-upcase y)) (char= (elt b (1+ x)) y))))) '(0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 ) "zyxwvutsrqponmlkjihgfedcba"))) ) ) ) (do-test "test sort 2" (let ((a '("should" "sequences" "sort" "two" "already" "sense" "argument" "sun" "second" "fourth" "nin" "who") )) ;; ;; 6 9 4 3 7 5 8 3 6 6 3 3 (and (let ((b (sort (copy-seq a) #'> :key #'length)) c) ;; ;; one possible value of b is: ;; ( "sequences" "argument" "already" "should" "second" "fourth" "sense" "sort" "two" "sun" "nin" "who")) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) ) ) (let ((b (sort (copy-seq a) #'char> :key #'(lambda (x) (elt x 1))) ) (c -1)) ;; ;; one possible value of b is: ;; ("two" "sun" "argument" "sort" "fourth" "already" "nin" "should" "who" "sequences" "sense" "second")) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) (every #'(lambda (x) (char= (elt (elt b (incf c)) 1) x)) "wuroolihheee") ) ) (let ((b (sort (copy-seq a) #'char< :key #'(lambda (x) (elt x 2))) ) (c -1)) ;; ;; one possible value of b is: ;; ("second" "argument" "sense" "sun" "nin" "should" "two" "who" "sequences" "sort" "already" "fourth" )) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) (every #'(lambda (x) (char= (elt (elt b (incf c)) 2) x)) "cgnnnoooqrru") ) ) (let ((b (sort (copy-seq a) #'char< :key #'(lambda (x) (elt (reverse x) 0))) ) (c -1)) ;; ;; one possible value of b is: ;; ("should" "second" "sense" "fourth" "sun" "nin" "two" "who" "sequences" "sort" "argument" "already" )) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) (every #'(lambda (x) (char= (elt (reverse (elt b (incf c))) 0) x)) "ddehnnoostty") ) ) ) ) ) (do-test "test sort 3" (let ((a '( 2.4 5.9 20 10.0 18.3 18.6 22.1 0.9 1.31 8.67 3.41 2.9 100.2 35.2 29.5 30 60 18.15) ) b) ;; ;; + 6 14 20 10 21 24 23 9 4.1 14.7 7.1 11 102 37 34 30 60 19.5 ;; - -2 -4 20 10 15 12 21 -9 -2.1 1.3 -1.1 -7 98 33 24 30 60 16.5 ;; * 8 45 0 0 54 104 22 0 3.1 53.6 12.3 18 200 70 145 0 0 27 ;; (and (equal (sort (copy-seq a) #'(lambda (x y) (> (apply #'+ x) (apply #'+ y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(100.2 60 35.2 29.5 30 18.6 22.1 18.3 20 18.15 8.67 5.9 2.9 10.0 0.9 3.41 2.4 1.31 )) (equal (sort (copy-seq a) #'(lambda (x y) (< (apply #'- x) (apply #'- y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(0.9 2.9 5.9 1.31 2.4 3.41 8.67 10.0 18.6 18.3 18.15 20 22.1 29.5 30 35.2 60 100.2 )) (let ((b (sort (copy-seq a) #'(lambda (x y) (> (apply #'* x) (apply #'* y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) )) ;; ;; one possible value of b is: ;; (100.2 29.5 18.6 35.2 18.3 8.67 5.9 18.15 22.1 2.9 3.41 2.4 1.31 20 10.0 0.9 30 60 )) ;; (and (= (length b) 18) (= (mismatch b '(100.2 29.5 18.6 35.2 18.3 8.67 5.9 18.15 22.1 2.9 3.41 2.4 1.31) :test #'=) 13) (every #'(lambda (x) (find x (subseq b 13) :test #'=)) '(20 10.0 0.9 30 60 )) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..785ac9f0cc1e0410d99e040e5b87cfc7fc2bc24e GIT binary patch literal 4950 zcmcIo4{RG(8GmQz|38wDHeK7b$D~zY=CY(|=|9$-FPGTy+2`DylQ=MjW1nLu&Yj~w zNmHPzN~R$&8)-*&S2P3&M5UooZ9-zusYsI$l{#tC!~_UUAWfPy4K#!hLa3DQd(TeX zCTmM6N__9V@B7~O=l8w$y?3`t>L*2+7p?hRCTrw*t5nRDihRn-^98GvPZ)d(==>K& zMU}qn7sTNHV|^`J4JVN|;zc9L>m{R*j4waJ_Z{JdTt1V9&f&u_>^pj}|LDNL{+3}u zlbN~rN#k1lDtcQ_zR-mnmoJoc(x zZh~06QB6|qa#ufJv~u38v1nv5ocRLb2(iCeZW@k;MLnQ|?ep9juFZa?+#U#fBM_P} zA`w?pMGI=@>~d${fcKzR(*+;c(G*oD&#yI~CB)rk60&!SI`xb63EHh z)$~(JN6^KA*y^R;i5*o{O@x5Bz1X!6PFdN6$UK-t++_yEETHB=L zOd9|0pVKa>>U8r>Zq&layno_WK8^tf#yxRc?%vyR?{`SCx*w>x&$HfUt0l zVYi2j_PEyl4^=$8tp`&Nr;HQkx%B(8S*TjkvzQ3($PaBF$}LU>4) zRIe`pl<xYv9%z(CQ|{sl%P$hntvyriNif z4GB67UDwg77*$m%TvJ&b4tehbuV*7bQP3o2%4tRRWzf`GQznr1L!dQ@N+jmhq%kBs z=WN5~jI$k^JR5zMjSe{7NPN`!C^o#)0}b~VD#E=3iaw&nLOw^II!5Fuk^GAi z$)72ayvK;|FydQ`_$DL1&WJBiL*ybgL~N&L0ka^DMFlxxVs~5;b;yacZPe)%oZdsu z1A7sZKLM|vW*0}lg;L%S#?;9;yz1=2=Ep#F2c;PHpK^9%GtHW9&Q2V)Q9159Yu=?i zj%pVDf_fZ8xT}o#n)4uzUSK24Wj%^KhQz1QO<4+$=zbi2oyj~2RF3j})EIY!S@E!D z8?akYg?B`i1YJ@iFqiz>*@Mlyz-*^XS<*Dhd4oDYzCm@76=zq;*);-UZc$K&oZXK> zw@uSk*j`>b=hL9a^-sIpT{H?szEF%$XAN(`$`|_kS|>4#D5ihaI&#rNw}YDIXTkQL$CYp<{P+TbCaLt6XK)Rn=@I9xq&U`4nDy}={S zg_Xgn&n&DAJ^;NFKYFpJXGP#)@`+R`wFfbEy}U+x2jPH7`mxAm+Xwwu$#33D@7&o* z?DDQ`e119^M`t!|SU9se$Z4Y}D_T^QVCUk0nVaNXupyfvemKnmOg#O&CM8vw^omL- z1SLogXb}JwtzQJ|?0g%91CI3s=>6?Z)?vPjmJ9p53ys1rR@V){*9(z|9P4m;o1BAn zPOqyKXq<<04l#q@Ll7w%h*bp*1|Z@|VMA~zSQStyfCwc8pFs{8*mImhjbU6st#lfL z9MgbkS1h3dnjeZiO&l``nF1FuRhZH}G@Zw(8Pxjp|B@Q#6SWy}K2-tyD{ExOR)Al> zN5q|jw?OUX93O-FOAcN4rRuVU!02kFkunfyPbng0Ve zpTED0aT7G3Fhm-*e?XBCR{HL8`|zJ;mez)FMIFoK_TrwLKP9bcvPA zN46>_{Rqv+oqf=7f3?rI+2w{p+A3v}*fA2837z_aVHOM^q~Kkln6}IALdk@unZajq z$%5xn8lKGsW1(c238P?_>#$nE{X3qYDa{)ubQ|MYc)v(4qpA1SNITY$S=hOEv2nS| z#--K5)c}FHC0WM+8&zpsQZf1%-^an8^P5$%EDU@e$(T5xH`wEKy%qCpst@%w<})IJl1$#N!ohE z8{V*FZ$z;v-_@Wiu%W3J*GS{w+`V}1UibPt%Uj7`O-6G&Rw~#LsON&b$E6`} j(QvT;0&vLNH*Wj~TT|)Y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST new file mode 100644 index 00000000..d7ed26dc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: stable-sort ;; ;; Source: CLtL Section 14.5: Sorting and Merging Page: 258 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 2 ,1986 ;; ;; Last Update: Oct. 2 ,1986 ;; ;; Filed As: {eris}cml>test>14-5-stable-sort.test ;; ;; ;; Syntax: stable-sort SEQUENCE PREDICATE &KEY :KEY ;; ;; Function Description: The SEQUENCE is destructively sorted according to and order determined by the PREDICATE. ;; stable-sort guarantees stability. For detailed funtion description, please read page 258-259 of CLtL ;; ;; Argument(s): SEQUENCE - ;; PREDICATE - a function which takes two arguments. ;; :KEY - a function of one argument that will extract from an element the part to be tested in place ;; of the whole element ;; ;; Returns: a sequence ;; (do-test "test stable-sort - test cases copied from page 260 of CLtL" (let (( foovector (vector '("Tokens" "The Lion Sleeps Tonight") '("Carpenters" "Close to You") '("Rolling Stones" "Brown Sugar") '("Beach Boys" "I Get Around") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Beatles" "I Want to Hold Your Hand")) )) (setq foovector (stable-sort foovector #'string-lessp :key #'car)) (equalp foovector (vector '("Beach Boys" "I Get Around") '("Beatles" "I Want to Hold Your Hand") '("Carpenters" "Close to You") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Rolling Stones" "Brown Sugar") '("Tokens" "The Lion Sleeps Tonight") )) ) ) (do-test "test stable-sort 1" (let ((a "qazwsxedcrfvtgbyhnujmikolpPLOKIUJMYHNTGBRFVEDCXZSAQW" )) (and (equal (stable-sort (copy-seq a) #'char<) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (equal (stable-sort (copy-seq a) #'char-lessp) "aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ") (equal (stable-sort (copy-seq a) #'char>) "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA") (equal (stable-sort (copy-seq a) #'char-greaterp) "zZyYxXwWvVuUtTsSrRqQpPoOnNmMlLkKjJiIhHgGfFeEdDcCbBaA") ) ) ) (do-test "test stable-sort 2" (let ((a '("should" "sequences" "sort" "two" "already" "sense" "argument" "sun" "second" "fourth" "nin" "who") )) ;; ;; 6 9 4 3 7 5 8 3 6 6 3 3 (and (equal (stable-sort (copy-seq a) #'> :key #'length) '( "sequences" "argument" "already" "should" "second" "fourth" "sense" "sort" "two" "sun" "nin" "who")) (equal (stable-sort (copy-seq a) #'char> :key #'(lambda (x) (elt x 1))) '("two" "sun" "argument" "sort" "fourth" "already" "nin" "should" "who" "sequences" "sense" "second")) (equal (stable-sort (copy-seq a) #'char< :key #'(lambda (x) (elt x 2))) '("second" "argument" "sense" "sun" "nin" "should" "two" "who" "sequences" "sort" "already" "fourth" )) (equal (stable-sort (copy-seq a) #'char< :key #'(lambda (x) (elt (reverse x) 0))) '("should" "second" "sense" "fourth" "sun" "nin" "two" "who" "sequences" "sort" "argument" "already" )) ) ) ) (do-test "test stable-sort 3" (let ((a '( 2.4 5.9 20 10.0 18.3 18.6 22.1 0.9 1.31 8.67 3.41 2.9 100.2 35.2 29.5 30 60 18.15) ) b) ;; ;; + 6 14 20 10 21 24 23 9 4.1 14.7 7.1 11 102 37 34 30 60 19.5 ;; - -2 -4 20 10 15 12 21 -9 -2.1 1.3 -1.1 -7 98 33 24 30 60 16.5 ;; * 8 45 0 0 54 104 22 0 3.1 53.6 12.3 18 200 70 145 0 0 27 ;; (and (equal (stable-sort (copy-seq a) #'(lambda (x y) (> (apply #'+ x) (apply #'+ y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(100.2 60 35.2 29.5 30 18.6 22.1 18.3 20 18.15 8.67 5.9 2.9 10.0 0.9 3.41 2.4 1.31 )) (equal (stable-sort (copy-seq a) #'(lambda (x y) (< (apply #'- x) (apply #'- y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(0.9 2.9 5.9 1.31 2.4 3.41 8.67 10.0 18.6 18.3 18.15 20 22.1 29.5 30 35.2 60 100.2 )) (equal (stable-sort (copy-seq a) #'(lambda (x y) (> (apply #'* x) (apply #'* y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(100.2 29.5 18.6 35.2 18.3 8.67 5.9 18.15 22.1 2.9 3.41 2.4 1.31 20 10.0 0.9 30 60 )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2f483266ad0db17f43db6bf8498725851b316d2a GIT binary patch literal 3216 zcmb^zZEO=|_`SQW-PQxTr2(uH&Iw8iCF=%8r$KMsbvtP9W_xoZF~Os~(T1+Yet^@c zLn4}Z7Pg_>3u=hb#28JG_(R07C_g39#6f5=c$MmVO%m9Qo!l#ny;*d0(wcp{}F z9lLu#suT}}^VVT2kHyTC2}g)?((Z^&Xi-DeHD{5V<3#6#y-L-><4~A9st~@T?ghPb zj_r%=3`fFI89qt!Cd3sIa&$QqDmibEh&vlT|#|eRE_+A9F zPq7o9WiRdKE*8kopYP@;dxPCvJ8}=MBIKQq$*~50;V@$O1;K>_t;AF-p|%o3t;E(= zqPK-O+k($!SN>f(KuFJv-T;@qcv%Dd`uv{PH0a5E_PDm2=OCN;^Xn%!G<+Zw30cae zC3epB>bNf()p@}ObkhCJ27_7nYh|_KAPxr6BO>X(rO7@#7Gzw`?(;8Y_w~Rxu%w+l zru)xt)=6ZT3`KtisA!}qI|jk$>SFdk0R!o z4lYdw>lLr(E~t~N8CNgtVqB~iwLr49A(56PP3h^nuz9lop6o*Q{JOtA)cLGG=O?@f z)7%@1>e`5kH!wUVYa?+b86H-Fqm8CQypINWFMQkK+XmOII~0|T=vX+Z7!ygjrcrj! zJ*mAZLrL)5?HYz2qHBdN5b&~0eZp!Q5Z1trS{+i7Nj(|XCyen4BP94iLk!8<-Z0~* zLX;D_fyaRnY>yo)w?|hyA?&`+-GO)TLvZPd>B)p_AbA=r1I@aka!PUi(zPJwZqSVg zexeeB4_(S}si)9WLLQIGNfhGkUz6IK7}n$A#->94I@*Vz+XX%b$PE|#?t<@`Uvh={ zB`2r|2ILqO4^uHm#V4q!Q*oGzJE^#ZioI0q0XhE~#A|0QKS_10ze4~RYQC=!{sT&I{;@J4+!!n68gvpT999n z&?e#-om^xQ$j8hzd5><|23-Dq$M#kW2Mfg`1ti~fY_VdMD^l8oPiYW&=Nx;ZfxN!w zv&MKzeF$0l?`ai`-Cx)pqL zzukIB1IYV@h7o+iywihVOY^SL`>xT7lZ~MEIoGHHxy~J(L(csy?Z#m(!fe&gQkVmm z94|C`0h%?lw!fBkO=_8%Rhvd1o8cMm$!8w@&QBcs&b&FZKV#y&+_nT@D7pGW8wP`$ z0-AsW^22RKkZ)NL&gSP|q^%+y|6$y(A8c!SEqyBEaVZ5FC#X%_Wfb`~M| zmJ$6YW#%ZDD@)aK)y(H-rF7mhOOjd0NabpwFzeWNAIVj+QpK7%WR=WHwPZDQAtt5( z=j)BBF+){SFv$=Y7O1KL3Rl<|Q-Bmk(H*Lqho-+P>Vgwih<$7`K!fhMaSlg5ipr97GaRt0WR2WF>IY+0E za%+lEpTXMVjxTnGh4`i}AHWQjxgQ{RSWaSp;Id%LKdSozE;OnUrqMfSS=|J%Js_=_ zqfDncQnh-v^kLT+x6Ll7l*i_@% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST new file mode 100644 index 00000000..2db29870 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAAAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 14 ,1986 ;; ;; Last Update: July 14 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caaaar.test ;; ;; ;; Syntax: CAAAAR LIST ;; ;; Function Description: (CAAAAR LIST) is equivalent to (CAR (CAR (CAR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaaar list) elm)) ((or cons string) (equal (caaaar list) elm)) (t (eq (caaaar list) elm)) ) ) (do-test "test caaaar0" (prog1 (and (mac '((((1)) 2 )) 1) (mac '((((1) . 2) 3 . 4) a) 1) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) '(1 2)) (mac '(( (((1 . 100) a))) (2 b) (3 c)) '(1 . 100)) (mac '((( ((#\a)) (( b))) ((c)) d)) '(#\a)) (mac '((( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(foo1) ) (mac '(((((((((( t )))))))))) '(((((( t)))))) ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '((((#\F) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '((((("the weather in January")) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January") ) )) ) (do-test "test caaaar1" (progn (setq a (list (list (list (list #'null #'oddp))) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaaar a) (mapcar #'caaaar '( ((((8)))) (((()(1 2) 3 ) 4)) ((((#\a #\b #\c))) ((#\d) #\e #\f)) ) )) '( nil t nil)) ) ) (do-test "test caaaar2" (let ((aa '((((((((((((((((t)) 1 2) 3 4) 5 6))) 7 8) 9 10))) 11 12) 13 14))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaaar aa) '((((((((((((t)) 1 2) 3 4) 5 6))) 7 8) 9 10))) 11 12)) (equal (caaaar (caaaar aa)) '((((((((t)) 1 2) 3 4) 5 6))) 7 8) ) (equal (caaaar (caaaar (caaaar aa))) '((((t)) 1 2) 3 4) ) (eq (caaaar (caaaar (caaaar (caaaar aa)))) 't) ) ) ) (do-test "test caaaar3" (progn (setq aa '((((a)) b) c d ) ) (and (setf (caaaar aa) '( (((2)) 4) (((2)) 4)) ) (equal aa `(((( ((((2)) 4) (((2)) 4)) )) b) c d ) ) (setf (caaaar (caaaar aa)) '((((3))) 9) ) (equal aa `(((( (((( ((((3))) 9) )) 4) (((2)) 4)) )) b) c d )) (setf (caaaar(caaaar (caaaar aa))) "magic kingdom") (equal aa `(((( (((( (((("magic kingdom"))) 9) )) 4) (((2)) 4)) )) b) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ddc25ddb0b35dfaddd910daea04726097545ac84 GIT binary patch literal 3193 zcmb_eU2GiH6~1?7fBZ9$O|TNQxG=Z`)J-<^+DTylVR1&MCQBTTND+XPpWbv(g}x5dWMvlv&i%mS*UFm$s?ozv|tk>B$8s zOgX9&VW<}cqf_4-O&v<6l4(Uz=1lTOSXay`>FuS^$$y=slz z?}gF0KnOHr^en*M!cM&7zI%*bt&&gQJ0=vy<2z{>wWsbPipkj~*W1MHlnc~D|VFGso*SY4NjBUCncfm8Z zsh@knh+W>RQ?!C?#C&6yG4?Q+e`}1n@sqp2Sr@Kd{sdA+^!4wjG9lWpY_$A6Mf`I= zqJ()C# zm19JZ-~f*&(uO{#;iXH?EBahkHIqj)(CA0=31O6t2~l{$@Py!o?M$Q5?PiSACQrfHZ-W6@ezv=U+rJfwu8 zpGb0jKEbHC6Lb_nFfb0@Ixt4Ugzzicj^nkv1R*0C!^|lbiZ20j>_%N_C9ei?*={h? z|F8#;e8yxXmjdbKKq_IRoU)KsOf+JyJMt%TM~rN;Kb%lM%qEbCoRI$o_Qus4f9T*bOuIaM91o~ zC|1}*KBtk#E60H+{{^1UIu!nm zf-yIT2=WCA`eGJWC;tF}?nCZPz81N}7a?8t(0SKe z&l_2>mtk6+Dp!|FwUyx^gd70~kaR%i7@y5~{}x|dnYUzlN~_vCXddZ1S~5Apo;oPICfpOt0lS7 zs#e#0@4?gMrYkp{l~t#1H(Pb*hA*s(X~51#Gg`*d)I6SNJlTS#0}Hp&npZ&-=ads% z4p~}G#WleMBN-12rrd^ak*Uc?8i-UZeze27c61)t=Q^1+ET~I6r+eMcbZWjQ)KUOi zs@0}?TXfzFWej5)z^~z1L*XDB4VXi0bQQj^oHNC8vs`UfaF1aa;unqzUu02~ZE><`Eqfnc~S|-BWDT#GVEE$$k!j zH&5Vg{{Ni;%{lZwqL|n~xJkGx-Ck_aLMQua_L~bm?LmOkz}m54XG5J|_L4$HfMGK| z3bW>?&;nWlMF<#z;|U5AxRQ+nC!n(+vRNElRM_WtBWJhZ2c7sm#fuq^M2ChS#O}}d duZai-B^%!Z8WJo8Ul%uDEb<4e=*z9G{{wcml>test>15-1-caaadr.test ;; ;; ;; Syntax: CAAADR LIST ;; ;; Function Description: (CAAADR LIST) is equivalent to (CAR (CAR (CAR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaadr list) elm)) ((or cons string) (equal (caaadr list) elm)) (t (eq (caaadr list) elm)) ) ) (do-test "test caaadr0" (prog2 (and (mac '(0 ((1)) 2 ) 1) (mac '(b ((1 . 2) 3 . 4) a) 1) (mac '(-1 ((( 1 2) 3 4) 5) 6 7 8 9) '(1 2)) (mac '((0 . z) ( ((1 . 100) a)) (2 b) (3 c)) '(1 . 100)) (mac '(#\q ( ((#\a)) (( b))) ((c)) d) '(#\a)) (mac '(foo0 (( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '((foo1) foo2)) (mac '((t) ((((((((( t )))))))))) '((((((( t))))))) ) (mac '(listen (("excitint" "vacations") "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '((#\w) ((#\F) #\o "o1") "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '("heading" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "the weather in January" ) )) ) (do-test "test caaadr1" (progn (setq a (list #'+ (list (list #'null #'oddp)) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaadr a) (mapcar #'caaadr '( (nil (())) (5 ((1 2) 3 ) 4) (t (((#\a #\b #\c))) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caaadr2" (let ((aa '(0 (((-1 ((( -2 ((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12) 13 14)) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaadr aa) '(-1 (((-2 ((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12)) (equal (caaadr (caaadr aa)) '(-2 ((((1 2) 3 4) 5 6)) 7 8) ) (equal (caaadr (caaadr (caaadr aa))) '((1 2) 3 4) ) ) ) ) (do-test "test caaadr3" (progn (setq aa '(z ((a) b) c d ) ) (and (setf (caaadr aa) '(2 (( 4) 8)) ) (equal aa `(z (( (2 (( 4) 8)) ) b) c d ) ) (setf (caaadr (caaadr aa)) '(1 ((3)) 9)) (equal aa `(z (( (2 (( (1 ((3)) 9) ) 8)) ) b) c d )) (setf (caaadr(caaadr (caaadr aa))) "magic kingdom") (equal aa `(z (( (2 (( (1 (("magic kingdom")) 9) ) 8)) ) b) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9ecac730866ab89a01963a9db125b8ff0fbb7cbb GIT binary patch literal 3199 zcmb^zZEO=|_bvtP9W_xoZF_NRbtqonf^kcXf zb+AN@p2ac1dqIscYK*@oKa8khM*o;d;t!3+#KeF8(-4iuXd*t(d+k;>KmN$LzR&m9 z`#jIx0`ZMU<5ILZHJ!`bC8=1gOjj$?M6o25i`7!vmL`BMJr*^R>f^&o^zfbsA|0tF zPP$}U6+0uDRlA(AW_L@G9w}kXN|F8d-@jYx?d#vWzdsV$(-BiranDvmW6aJJ8ak0C zou2-lz5S7%JssCycF)sbkr0w5%XqXC5+ovV&p5%bsisUhro~lRR}yO2U2vTZkcm8+ zQj@N;xmT(br{%moW9KoMsWPF2xGy*xVxxN0)C}ESq;oXjo_02Bx;z4jDMKm|Hq@=4 zb?Q1BBm3lt990x0NnQfCVnT_octRQXJlUi41s8I2+4Bb}rONf7@}BYuA(yoUZGIR6 z_Q+R*oO>-uSU?~|U@hR^T@+lWC9Z)PM^xhp+703OQf5-qheqhl?m4FwnInWiA^fL6 z?Om+G``Hf;(aQz$!-t22vF^}j+KSZU8wq*s9Wvj5FU=r?4=^rGHY4NBh}MksHzW5p zBi&8N#U^+zyY}ycNkTeL`MPNK@)aH6YYT^;*P$W{*{AeF0)=Q6mbQ)E-mrmZfRN=} zTH<$H&yHScWak4LP)F}K8wzDZ&4gwcn4u8bLm<6wvvbu0(=^Ka?m9PFk2?@bQLjK(UWO2D+F@SNV zL(5|!O7jAg1aUth+vugiFhu-Xi*?TGz5aK&XR=FM|Mp53 zvcX)C2m$Ej?r_x52Q{2Md05d0<7!eK(14;3rNV-rbqPLrTH$GdN!uKbDrR(8PO9c; z5(YHNC%i3nBxR}zfv%S@jWF9Hb^t?A6y_IiVqM}Un5Ubc%*#f)S^F%dlnnq8}TMU|B5*=1Xh zy&I(46Ut###z6)O{hi%`$M;Oa<1G(6>tR!9JE4q3l_WB61$0yDNMgW<%Z;st^jp{t zJT`epJ3q*u-tn7ve9i5WPqLyKxTU6q*8dnpl&eQsq-34s=C6}U~ddIUK@sx+n zc*i#G^Q=00Q1cV2>AmMV{i~P$S;WKqj8LiT;?9gJKQvR zgYDc6RN+n6@l^}Q3&j%!L|=0qf5k3Wq_kyOr9LFR;yQPjNZS5{vR#_6;1!pVas}`G zgtRAkwv+Cnh)ddA)vEw(Zg@F#Oj(n#wT|ZslbPaFJ8bk7$$t=lE*pR@gCpu4gN(2B zN7fp{7!&{ETwLc3DC__`$P`qKHbS9dJL3D+n}Q+Z;R;P^yBZ|a*|ws?x>qd=?nM+j zr!`jOp-#}YTrj)5vm zdpfUsI^W@wdQu=trSo%4h2;7E11##tGfFstd+Ob;N6Rc%wc5MPR zcff1BEuT5~Rgk#Ot$AzeSjNJ3ShozIH8lkt2`*uMYC3>0isrBi zs5qz`;dqOwB~2u|^uS7ONFqM<_-> zexg|HMN9DijMEY`j6Tpii*1F-Ugr0Jeav5i?=kz)bgq&sR0>?hhj+V5be;AYD{WPB z#X=d(SBhYyZCDvoG>ym7mareqrHcSBiuHIQW%%CHVwyLE?Xcv`;W7A_Lm>=`%bkXR zJOwalBsExc%x`-FYkp5!YY1!5ljFP}8_7m^V3=ty^P9XtycB#Mxyz6E@5i1Nhc94l z29zWg3Z?@K|1x^Wt!>trURWL z%DMp(P)rcn!3Z2wkln>rMpZD`+tq_ZMw0f}{QvNjg`?R7chgL HuV4QQeM!nB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST new file mode 100644 index 00000000..17819440 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 14 ,1986 ;; ;; Last Update: July 14 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caaar.test ;; ;; ;; Syntax: CAAAR LIST ;; ;; Function Description: (CAAAR LIST) is equivalent to (CAR (CAR (CAR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaar list) elm)) ((or cons string) (equal (caaar list) elm)) (t (eq (caaar list) elm)) ) ) (do-test "test caaar0" (prog1 (and (mac '(((1)) 2 ) 1) (mac '(((1 . 2) 3 . 4) a) 1) (mac '(((( 1 2) 3 4) 5) 6 7 8 9) '(1 2)) (mac '(( ((1 . 100) a)) (2 b) (3 c)) '(1 . 100)) (mac '(( ((#\a)) (( b))) ((c)) d) '(#\a)) (mac '((( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '((foo1) foo2)) (mac '(((((((((( t )))))))))) '((((((( t))))))) ) (mac '( (("excitint" "vacations") "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '(((#\F) #\o "o1") "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "the weather in January" ) )) ) (do-test "test caaar1" (progn (setq a (list (list (list #'null #'oddp)) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaar a) (mapcar #'caaar '( ((())) (((1 2) 3 ) 4) ((((#\a #\b #\c))) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caaar2" (let ((aa '(((((((((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12) 13 14)) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaar aa) '((((((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12)) (equal (caaar (caaar aa)) '(((((1 2) 3 4) 5 6)) 7 8) ) (equal (caaar (caaar (caaar aa))) '((1 2) 3 4) ) ) ) ) (do-test "test caaar3" (progn (setq aa '(((a) b) c d ) ) (and (setf (caaar aa) (make-list 2 :initial-element '((2) 4))) (equal aa `((( (((2) 4) ((2) 4)) ) b) c d ) ) (setf (caaar (caaar aa)) '(((3)) 9) ) (equal aa `((( ((( (((3)) 9) ) 4) (( (((3)) 9)) 4)) ) b) c d )) (setf (caaar(caaar (caaar aa))) "magic kingdom") (equal aa `((( ((( ((("magic kingdom")) 9) ) 4) ((((("magic kingdom")) 9)) 4))) b) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..59157e15d07e1ab95d60c37c544fb3f5aa0b3073 GIT binary patch literal 3320 zcmb^zTWlLu_RdUV=P?C0m{OT+I~!h-TbDRVSE-j>F>%K6wDwG}Cpd+VGT4*aYGSv3 zw9T%l(sqT|YVhI&%3R9+topGZd}RC8Le)qh_&^mxe4zbU?bm)H#0LV2)l$y6*G}9N zgtS7*_}ufn=W)-uw?+K(@stv;ES)SZI#s38sGn@qm4!-GsZ|=)yrV1tUHN0&%xEtq z)%cMEzl{!LyEyr(W7nO6Vl|vv!Cv04L`Rjhy{tqJO-}At#>Qh4hhov_fq{gYO>tWt zjhs^`cXXm%I-{}CiP-qqfq^@J^)3s63LzvM0lUt-RPTe@j@Yr={kdw+3v=tg7~ z0#j!+BKEbdpmo7>2crig(MViXr_~I38}^mbYJ77m6!I>Us5%~Kl~#&xJ}roXpxz0n z*VPXQxuLi8i%D>~O}`!B{I3Fp$|4~m?ExRWHPLf>QaV_2B`uW}eg!W1vsOkoW@d$; z_lDbx%vnMp8G{!N?OI2jl-e< zZnf5T=k|1LAe0H&DCHGa=5}zxN1fpOU;`4_{aXx$y3y`6utFjHLAwC+BOAF9EDhqf zipK&Q#bZP81viY>E}DV$#|#0vfSUo&95REC1N#*-SPUH-0%1eEwf;|V8MSZ!GLeb9 zJCO~Rej$q=b}Y*1XFjx%3qer0-Ys0yb1WCPul=4;G2Aw1Ux%Y?a<;f{wwYVy{ds3s zi|Y^lXk}Z)Kq){(8BX+YIBpu#I(A_ssT$KMEfbm2fnv;L!{Q(fihlTd;p>5x+Zm3l zRy-NWXx3Z?S~bpk-IqO@wY0P-+$&+3VY*8i0EVclbWpmF2BrI0SWBmsCNp&at;S)<8>XbvCYMkhurY`?E*WQ)VjCnN~>OO-B$6aUgRb zF+l#u!M7ZI&dihdnR(KrGU$;DRBlkYNag3LY*KlO%9B*yN9AEE2Z1lPVB21n3B>*k zv(jf^bSXq%qK^U){zD%@@Gp*i%E2lpUgFp}4jyLKp4E(5RCo|DDXkm0#!|o-oyT=Q ztl98Ggdk#0PooC;4iRH6g}all0r91^^pu7PBG=i5WS#9quF^;6A@@?kH0j_z;EV5g zuD?+}QLdaRBl>sGmFrHeuH*~ejcohX%$7b;8reJDQ#@&Mu-Oj9<_F4-(Jo#q0nhT)d> zEf${sJU~46;YEAt#e$91zNf|Ea0%^e8Okcm15UsI`S(4(lh2s%J= z@?2lpUUFhkHb}t#Z_;yreWp||Ds^Y+q*Jx)jjFS?J$QzWLh=0xJz?ou7SB7*Ur{$; z2|a5iH9)0l^(e!8EIqAZ7{G!d4#E_jz6j5mvC$`LsHs})^!FP2OcIvonu$MnYd);i zDNt-CnibC#D^bu`s8q&SadDpaKr4@f=IeMC5t*Qad~uKto`M&eb2eY9m&$c$PyT@N z+tqprGU%=01FpmN-2T&c-maG_yC!fI%~(YXT(nXo#-xpa7j``8@krqTLvn>X2pFtmQhrT+BP1NECA$YkI) z1PM{1u?aXf*upUTpp7Lo0B$l;ug~At{{)07h>tKT`p^E+E#VpFlQ0Y5b%{wyJ#_e? Wj-*IX79KixcP@Dgqy6ulJ3jzvN%3F+ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST new file mode 100644 index 00000000..9a6226ee --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAADAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 22 ,1986 ;; ;; Last Update: July 22 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caadar.test ;; ;; ;; Syntax: CAADAR LIST ;; ;; Function Description: (CAADAR LIST) is equivalent to (CAR (CAR (CDR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caadar list) elm)) ((or cons string) (equal (caadar list) elm)) (t (eq (caadar list) elm)) ) ) (do-test "test caadar0" (prog1 (and (mac '(((0 1) (1)) 2 ) 1) (mac '(((((q p))) ((1 . 2) 3 . 4)) a) '(1 . 2)) (mac '((a (( 1 2 3 4) 5) 6) 7 8 9) '(1 2 3 4)) (mac '((0.009 ( 1 a)) (2 b) (3 c)) 1) (mac '((#\3 ( ((a)) (( b)))) ((c)) d) '((a))) (mac '(('quack (foo bar) (foo1 . bar1)) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '((non-nil ((((((((( t ))))))))))) '(((((((( t)))))))) ) (mac '( ("article" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient)))) "excitint") (mac '((#\q (#\F)) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '(("name: " (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time)) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caadar1" (progn (setq a (list (list #'member (list #'null #'oddp) (list #'list #'max #'min #'evenp)) #'(lambda (x) (* 100 x)))) (equal (mapcar (caadar a) (mapcar #'caadar '( ((t ())) ((5 (1 2) 3) 4) ((#\* (#\a #\b #\c)) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caadar2" (let ((aa '((-1 (((-2 (((-3 (((-4 (1 2)) 3 4) 5 6)) 7 8) 9 10)) 11 12) 13 14)) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caadar aa) '((-2 (((-3 (((-4 (1 2)) 3 4) 5 6)) 7 8) 9 10)) 11 12)) (equal (caadar (caadar aa)) '((-3 (((-4 (1 2)) 3 4) 5 6)) 7 8) ) (equal (caadar (caadar (caadar aa))) '((-4 (1 2)) 3 4) ) (equal (caadar (caadar (caadar (caadar aa)))) 1) ) ) ) (do-test "test caadar3" (progn (setq aa '((z (a b) c) d )) (and (setf (caadar aa) '((2 (4 8))) ) (equal aa `((z ( ((2 (4 8))) b) c) d )) (setf (caadar (caadar aa)) '((1 (3)) 9)) (equal aa `((z ( ((2 ( ((1 (3)) 9) 8))) b) c) d )) (setf (caadar(caadar (caadar aa))) "magic kingdom") (equal aa `((z ( ((2 ( ((1 ("magic kingdom")) 9) 8))) b) c) d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2b69dbc156f67a57d91c913ceb376cb363284f15 GIT binary patch literal 3326 zcmb_eUu;`v760zN{*yo6>V~YV+^oCH+D&rnDo#?7rTp2Aa~LsgDD#~WFv|O}SPRj8SIb*HJ@fRj0PRgTWljAQ;#^a~@ zl1eV^VRby_O2ul&C*I{VGC49ndHVCG`gVTk+!Dey##n)E6X|6v%p~UAw8K$T&6%;J zmR4iBl2N11hGX|2lUP2dW*z(BsNAS6#TH7hmKG?P#bqWi=DcP1B=dU0)C}F(6jp_h z^QQfnrpIQHm@=a>v8Rnf=z?SS$4|%Nv4o;bPiNT=u&m-_p}Y|MhYRf(W@W`#lLd$ymHvy7n_{p)c1B~{|*(%n!zYl;lupS%~%J=T;Sbwr{?z=il zvQd6RKPw6dYh&y1+|dpO(GX+Xm4fUZb2~ZVx1HpIz(67Q|1U=(`-Pqasz`*8-9@A@ zygfHe=R>0V<%{9%^2GuC2DkOMZW!UMBae5Z9Ik|!7{aw4iY5$wTBBBsr4)TSt!86W8YKEmE-Lo(K{1G* zA3q=Z?qD>bn2A&@tD5;N`ZeJ;d?0rrXQ~-d*l%GPQGQ73gThDM%loCr`Ji+F&GmRx z&1Q{k%*dOwc{3`7VH1if`h}P)&qcW)9fV9!cs~Zo_})R%=V#1q-PI%1j_(07kTkLx z#U%De@EqLDETQC750@Vzb&x*|BK)1pMBekbAA8(ugp^Tc6H1np$G{%QUC2xs=~!oI zk^CqhCUV##10L!1h~yIXACLUgBOklFuwS{muoe%&ovrgwlZVPY^fewbcxZ};CV1!s z4-N6q6VQvdu)E(a2yrb;&VWuyrioqW$3TR?@Mnqq+2j7;k=vf|O^>_bk!M`Auc-Pg zIUE5eWi*}EPq=I4Jgw<;+)+qOfEZ(X+Vx<>==n75&i)0)pVx75i2Db)Kt|0>sZ=%g zzPml!a`$CF<;TwBK%}H$@ct9fi+3D5*sNZz)~-~E{h4Ej8l~liT(GQSu|7t!cOCm_ zlVro!m0@|_!uPKzSE}B}i)7c2lUd!_^wTx@Dy|901rW^gO-Yno>Jz}=6VkV6UBY0y zT&Z3v))sqv$aczeNq7X8lkh5gZAqBNCOpnZ9|0}(_V5Wl$zw>p5LR;A^X^B>6Iy9*5}tC^def zAWHbC`dZP}bI`S{*2}GeYbUgdtx{{A98cnt9at#7_;Hvy_K^i^@#UgL$Gfl5ahrtp zHyYnRU%`W^jHed%JZn{(R(-|2 zD3Qvt++1#23kxf9VWDKzWvg10mz&k<3gNurYzAJR`pwQY#|~7j#nPngCiee>I`%VH zDvh$-C@n6P>QS8;jnF7trZey-`6eX{TMi zWB0yl6|6?3R$azUjT-O*DP>O4G&jaTrgXJZsA0V+AqSKI&qFP#dF|SZF=(dd@bn`C zij990G4ZPaF|wMfLtbnL?SnQTq8&wpFLemcQ795ux27~V4*?ag7(5Il^jGK z120V}S#S@_5qHZ0Ar>xNr%t2bQ7C9=MKem^bfdo2mQqoHNg~`*x74sjbvr?IfKcbQ z3s&bmEgzae|KaVr)Ld$fdFZskP+L9GrkGP-bPWaT^)Gy`@gXc-BT?iq!MvCpcSo4y z8*w&+7(xI*q!?cml>test>15-1-caaddr.test ;; ;; ;; Syntax: CAADDR LIST ;; ;; Function Description: (CAADDR LIST) is equivalent to (CAR (CAR (CDR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaddr list) elm)) ((or cons string) (equal (caaddr list) elm)) (t (eq (caaddr list) elm)) ) ) (do-test "test caaddr0" (prog1 (and (mac '(3 (0 1) (1) 2 ) 1) (mac '(t (((q p))) ((1 . 2) 3 . 4) a) '(1 . 2)) (mac '(b a (( 1 2 3 4) 5) 6 7 8 9) '(1 2 3 4)) (mac '("a" 0.009 ( 1 a) (2 b) (3 c)) 1) (mac '("pup" #\3 ( ((a)) (( b))) ((c)) d) '((a))) (mac '(100 'quack (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '(t non-nil ((((((((( t )))))))))) '(((((((( t)))))))) ) (mac '((99) "article" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '(spurious #\q (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '(99.999 "name: " (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caaddr1" (progn (setq a (list #'member #'union (list #'null #'oddp) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaddr a) (mapcar #'caaddr '( (t nil ()) (5 (5) (1 2) 3 4) (#\* #\& (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caaddr2" (let ((aadd '(-1 1 ((-2 2 ((-3 3 ((-4 4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12) 13 14) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaddr aadd) '(-2 2 ((-3 3 ((-4 4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12)) (equal (caaddr (caaddr aadd)) '(-3 3 ((-4 4 (1 2) 3 4) 5 6) 7 8) ) (equal (caaddr (caaddr (caaddr aadd))) '(-4 4 (1 2) 3 4) ) (equal (caaddr (caaddr (caaddr (caaddr aadd)))) 1) ) ) ) (do-test "test caaddr3" (progn (setq aadd '(z y (a b) c d )) (and (setf (caaddr aadd) '(2 3 (4 8)) ) (equal aadd `(z y ( (2 3 (4 8)) b) c d )) (setf (caaddr (caaddr aadd)) '(1 2 (3) 9)) (equal aadd `(z y ( (2 3 ( (1 2 (3) 9) 8)) b) c d )) (setf (caaddr(caaddr (caaddr aadd))) "magic kingdom") (equal aadd `(z y ( (2 3 ( (1 2 ("magic kingdom") 9) 8)) b) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7007812913b0527c66ca60ac78528d56e3fa4974 GIT binary patch literal 3215 zcmb_eU5p!76}~gGw)e+rovleD*QCQXG{}j=dN(PX1w?1PGRy;JM%1Y%8MLh6O!3#p-4e?MR1X3jk-SXsBPZ+Y7piOJhFovAF0@+MFdEU!W@eWr}>+aWT>Scpl?xnYN5rkXe7DJ`SM zbtS9DoUUV!qLTPZUd=i7-Wj=7zYt$5zg%9UV%D2XV9a^l9!;(2NmDa)rzdO*LFfDS z9!-xgqcCMjW#VWbh0q1Z-jg^UPsEdovY2B(!m?6UN#0+He4Lx?s4^SsRyQj*pBDu| zxffF2Rer6vOCw=VeK+Je%Nq$Scnb@Zw>LAmEC{0fi-zG5Ed%8?&#n@?4J6bj)rtA*Y%U4 zfV8?>`wIsK7(|1N?Np1hyT$$Dg!c!<1%QDz4*ymnkzsL|hba;vOqVH6?G&c4E2Own zIUCxkoSnoI-qBybW`wp5>H>@qjgVtZ8sTSQea#40B4;PztBZHG{)lub`0giDl^7mW zHBtS95N{61^Uko^q=nQ@0)(uw>;R?|DEQI z%GQ$~yPw@ks2XBo5a&1=OB(v3MspWWEBaza&BYfqX!NCgOq}3hF@VR1X9QEWHz#bWEYG~d~iXLem|cgGU<_^ zMl|*X^VQn9Qhj}Flsp&U36k^(P9MR%xZ9VM z8nF5FBe2rgD1VO6@e}0pmHt}N7)gm;5hFvMhx*BljFM+`;K`#8!2HfzwAu~(Kr*K) zrW)UMSTmZb=9EmH?;|&yg%?%~Q}y=tBOV8?@Xv=jIYX+y^Uo9cl?%=@2<2HX=I36_ zI}gPq$oZ#UObgXr+1w<}7r-L)$|e%`fe}Or??kB+qaUmDQU^N$2cc8ylsl^w@ho1p z{zE-6yU&4n@1)oS*@}yO3Ta69(Ohl?px!r7AYik>Fajk4MWUE$^o9$X{gK(}p zJ)dLyYu0*sUiNDKzwsRVGncBZirgx%Unn=MR=ZJtur|`7EV0{xl$J6zHBU#F4zsA~ zU@?MbT7@VrDra1I#MH7X)c_MNWjaA^e2~mcA8JyRV!B7#r)x`Tu$McjSDjv^o zd_dAVRvul#wsvMcT!O|$;r8UYKE=KBWw?C%OHZ`kgO}?diX3K9;&aDfqRGUq z<)=_&=gK~RV07#dsuRR#yg7B@C>7xaHxFSM14S{&aS504^ylgj(c Hy?g%!A9v6_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST new file mode 100644 index 00000000..92712bd2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caadr.test ;; ;; ;; Syntax: CAADR LIST ;; ;; Function Description: (CAADR LIST) is equivalent to (CAR (CAR (CDR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caadr list) elm)) ((or cons string) (equal (caadr list) elm)) (t (eq (caadr list) elm)) ) ) (do-test "test caadr0" (prog1 (and (mac '((0 1) (1) 2 ) 1) (mac '((((q p))) ((1 . 2) 3 . 4) a) '(1 . 2)) (mac '(a (( 1 2 3 4) 5) 6 7 8 9) '(1 2 3 4)) (mac '(0.009 ( 1 a) (2 b) (3 c)) 1) (mac '(#\3 ( ((a)) (( b))) ((c)) d) '((a))) (mac '('quack (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '(non-nil ((((((((( t )))))))))) '(((((((( t)))))))) ) (mac '( "article" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '(#\q (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '("name: " (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caadr1" (progn (setq a (list #'member (list #'null #'oddp) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caadr a) (mapcar #'caadr '( (t ()) (5 (1 2) 3 4) (#\* (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caadr2" (let ((aad '(-1 ((-2 ((-3 ((-4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12) 13 14) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caadr aad) '(-2 ((-3 ((-4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12)) (equal (caadr (caadr aad)) '(-3 ((-4 (1 2) 3 4) 5 6) 7 8) ) (equal (caadr (caadr (caadr aad))) '(-4 (1 2) 3 4) ) (equal (caadr (caadr (caadr (caadr aad)))) 1) ) ) ) (do-test "test caadr3" (progn (setq aad '(z (a b) c d )) (and (setf (caadr aad) '(2 (4 8)) ) (equal aad `(z ( (2 (4 8)) b) c d )) (setf (caadr (caadr aad)) '(1 (3) 9)) (equal aad `(z ( (2 ( (1 (3) 9) 8)) b) c d )) (setf (caadr(caadr (caadr aad))) "magic kingdom") (equal aad `(z ( (2 ( (1 ("magic kingdom") 9) 8)) b) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..82e127bce39d126c9b6800cbe59993645ec018f4 GIT binary patch literal 3437 zcmb_eU2Gf25#GHcDN&M5>Zf+Vu+CMnQ-?N5os;(L9;FlaI&H0t&bn@?;XB zNP$0zg*LA2phgieOeCewZGKRoK_7~uh@t{TodniH(LN=wDUg=}?L&Y(6-6HlxHEgC zeUVZaC<6ZM%r`$fGrP09o5X)PnURw9)wN31Zb6wa#EFuO&@Y*PLy-K}VcdJBL&)z67bs7Zf54 z_Pn5X>U4sMnRp_elx2gwb9?wEA;L!(#|PyP7wMfEr5`N{g=l1y`mYj#fT~5>S5mU&>Q9bpAW&;*v)|nTE25v z1Nxtv7hlo-M960OmbNHRh;no1XyI7j#~>jikU^y=@htiYf6`BQ09?Roxc}uy#LIeV z5Je*B6p7;GUSX0_Wbc-*g!jr<#^5)xr@i))9^QFeqm%-thaG)PpLha@K7%09_T#T57vWexm*L9SP(5e8{Kz5jrN9gVk3cMH}?@oiv ztpuPa`e=lsef*6c{9q{`9_Lnh=g3#B;$}Hq2@_$&`9&uhOX}K!iaiid%i2OlG2-(o zAlijoOc-WCVE}%9`1zpGMq^3YOs3<8V&)BKlqB!8KyEo_Dp`RZ)G+lJ8y1H^AjtCl zuEc&453`^cf{r^JQw&2l;(Fd(%9}AU49X)hSzC^CJQrhB90iQZECj7Qy}y-*{Dd$c zHn4;(xdSc(Dc#7*CbGZ7n38$JP&Cg0!6?e!2HC`e^pkQbxo5#sFe_hF;u$r^ zoei)fXy;=`VW9tJkKphJ4$|Md;JYsP6O1A&FC}FIbxs2t$}MN-^-R2fJGzvAYX9zW??U8aR!*`In3FeH6o;2t^hFk3W6=_e7FaaPqUTvO z!J;Q&na6XAnTmsjq2CYS7~m5e-xnEXCu~8;e!c?8y$pwCK*OqLkiE`$trLKTR1J2I zoQW$LB@0CcG5vx)hQr^v7X8#6mqSxx=JYEK^F?S?B~%hwN)>R;`3pV4+DCJ<6Uu z31-4?oX(+^-E2uk%W9lO++M4bE0LIGgBk4>X%$=h!Uj zX8EjC3?d_Y4WW&<1=zv&Ri`l92t|HDqbg{{+Ezn?jVLwSwc0xRfg(dPd@udKZk*1yUZ}LnQp;Xlvl~{c-LM}_3DID1u#N*M zHD#(w4z?Ri38%8E0SR4arWIht1$mkCK2yyq7&?gHRsdzzb~?VPr@q}pE7|1x)vu`+ z(m-Mk+ualnuR7ZSu$V{`4OU$@_Zo!+& zzE-TXDzz3myva@RCDupbA@;mgv|5#VtqF6q>fkAmmJ70~@~8q?`&y+~2YOqCs3B>1 z(5Wfa?Xe)7VrIGkHxMddRBRohVQp}t8!DV&EW{Vhjrhy|H`=br|N6gC;pq$PBup#L z%Z4}81kV&eAh?5m38sLD8h`{TJTEB2)L-hMSTE=mgl?gss|$tehtYQgCF}`-`jIPT z<3H?eEjQWm9z4?<;lwap1cml>test>caar.test ;; ;; ;; Syntax: CAAR LIST ;; ;; Function Description: If the first element of LIST is a list, CAAR returns the first element of the sublist. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test caar0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (caar ,list) ,elm)) ((or cons string) (equal (caar ,list) ,elm)) (t (eq (caar ,list) ,elm)) ) ) (and (mac '((1) 2 ) 1) (mac '(((1 . 2) 3 . 4) a) '(1 . 2)) (mac '((( 1 2 3 4) 5) 6 7 8 9) '(1 2 3 4)) (mac '(( 1 a) (2 b) (3 c)) 1) (mac '(( ((a)) (( b))) ((c)) d) '((a))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '(((((((((( t )))))))))) '(((((((( t)))))))) ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caar1" (progn (setq a (list (list #'null #'oddp) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caar a) (mapcar #'caar '( (()) ((1 2) 3 4) ((#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caar2" (let ((aa '((((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) 13 14) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caar aa) '((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12)) (equal (caar (caar aa)) '((((1 2) 3 4) 5 6) 7 8) ) (equal (caar (caar (caar aa))) '((1 2) 3 4) ) (equal (caar (caar (caar (caar aa)))) 1) ) ) ) (do-test "test caar3" (progn (setq aa '((a b) c d )) (and (setf (caar aa) (make-list 2 :initial-element '(2 4))) (equal aa `(( ((2 4) (2 4)) b) c d )) (setf (caar (caar aa)) '((3) 9)) (equal aa `(( ((((3) 9) 4) ( ((3) 9) 4)) b) c d )) (setf (caar(caar (caar aa))) "magic kingdom") (equal aa `(( (((("magic kingdom") 9) 4) ( (("magic kingdoíŁ) 9) 4)) b) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADAA.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADAA.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2fe9cd5df3021013f0bf6eed9f81a2f6145d8d6e GIT binary patch literal 3305 zcmb_eOKclu5dL@9j@`WKIH9fF2dk>>!E~FrO;8e2wBV zC>5flDUV9HZk?2B{}zPAg&Rt9K(s}P)Cx|K5D1|jIB-A$iAyC8+z2zf-n?1?lB;Ah zJFjnN=AZmCMdBHdV!SjlHaRkyo#H2EXC`N7_~D5uetKedDxKwrLC(J=sha$Dk0|w> zcqvq=Z_%WuvZr$p$@nG+A!)LTWEUYm!Vz;J?+Y5TZU~WROcoR|E(gt` znfF2_LPD1{GhcU-pP85xMze2ZM=_bPX~GatU7r>i~ zteLMqas-SuRfwos+|1WItgO5e)l?-eD+VD9*t#JUuQAv!OQJ5rr#Lwlr&Wk?EnlG| z;+>GzA_oj}x+Jv1(m>*hMRkMvQEXYTswI_FMMr1d(4tDWt#Zp}5@HN2>2q|C<#MUy zBcIuj5~w?=I!6fn)?iYQMwcA1^5EewWJs(G=NOOqQNCW6jR=+mvn*AYbr z)8==bHunMs^f21y0)bqh^pZZdnmmSWkNipw`aL(~ho@mxxqex#T{@~Ts0CiFHC4ab za17K})P`JO$PdN}yR!5MVnOee6(DcBV5+b%@K zsC&&W@iU6@4=2j%tx@9pzEZ&O)g3IB(h(v39~E23E$w~kDHn6T5g%cz;SM|ygxj_& zii1Vy5tXi(tO=b_kSN`HkgcKu>xIV+j|*BU$6CLLbx(InLs} zxx>OxgS3&Wq<*fJ?%{TW0V|5Mit|x{tAjhfHYjVFstIbs=ua3y&JPyVK~WhLEV&+} z3|9{_2Ap6xHt!scl^*9tZ@^pnTO1oWutWpdJK)){nI8@)8<#esx{bCXIZE4raElhl zy<>9&h!hw5B~e2q1MF^nFy5)gHbw==*0+ zWfAsoKyxXH7<#i0EDQFYt@^?y=b;hYIE$^QTWJ_9nZIoErA=mS(rgj(r%je=_;ng? zqTz!W$^$d+nH_&^eB%5#vMVrrXR^~Xd^(j$rKV1y?4Fr_-ay&mi{fE^I0YM8h94QX z*DI7=Jc?#lt&ITp5ZYqxBk;;$7r;o~#z%JWQQ*O>*Cu^7>9L7St7sRZzqbKFBea|L zploVWhC2+?4aQcr)0>JeRCIv?tK>>eswokK#iijQBUb>Sg6Q~4)`?VC$4Y$i(;qjvAJ10bzds4Zwp@ba^%7{gM zirJkFrEP;||LSnt%90L)9X)4v-8CzC?!)cDhcLts?BHL8W4v@}4kZWiM4f=(#S71X zC9rnEMQ&Fb&3*%XhUH)@wWDFp8(bk(I9o^;#%zQ_rjRWRqirQFv!j{tPq_E(A5D#& z&7`oop13sN_GC(nF09JT0Pq9>Tmaw?7jttXU-cAwd||FQ;>-OP7;NWH17m-GqCo7= bR)N?@+Y8hLpJsog60_Zb+yXgSUSIzQdx66+ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADAA.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADAA.TEST new file mode 100644 index 0000000000000000000000000000000000000000..06be23f3bc67f2707a3dcc5e8c34805a6b1ecccb GIT binary patch literal 2453 zcmeHJO>fgc5OtBD>LDCJAmD(e?SZvuqB>1NXrWTtsuHDqHSMhjHqIuo@JG5{0}%p= zBNB)H4*mfW;>_=W3vfVi=E57>iBeP$Aa1a-$JyC8GjGO`XO@;|JqcaoMImiRw4!KR z#YVLkX|=J|XlxahmT*xsO0=sMDPK*al&>zt)QX~etZS;wg;Om#Fpa`k#Y6CI*@b1f zwvhW;)k-1)tqf9s*QNGCx>2I$K#e1q(Hek@w2}A&a%wc^T&~x0$fk@9?eyCzfDVPM zdp@Ex;+*v(rM>v^72k{dZlu++8~Doxxh^}^qEmEbTS{GGMHT@Pj6x$Hj8jPYMNkTR`U)oY8(cv)LAy<;&!1TPZ%L-;I+Nu*sS4RX%f*p|Z1G_MFSC~Ox zxiVI)0Q)crT1t;RL31_Th^$y?a62`IH5LgGX>#%MDK>biU7G|lmOlN+LYOh{nQyf> z7URT$7|(1f*hnBM@@t}*RAyY}X9{d4`a0@5g()G!HVIDfg1~ZYa&VW)PJe*xfitl{ zB`V{LpB0;=4YOQ#04vA=juvc2Rc)%#C92b9-j3l=2I0VyGe4jDn%&*A38g4g3vz*6 zL}J~TiGa=QF5=Gaws5<^37`QKg5ho4oJy)2+D#)4&O1?r+#tb>WvQAyYN<6epxcrf zlA#q6*i_Op-dmP+#GbqJ4o_Ya)=~AsvOavVtdIV=izh!lePvBdytPhc$7g^&{nDCz zGf(GV7g#6ugMI7xlh4+%;C+VqV|jf2`Pr|BSWiy;U;lIk4*5^~SN)|5pv#S#*TMcD zM|#*=zU%(0n`V>0wxgzBDODFSB51>XhCjVGl(b0hX_T=Bo#;~`UCyy z&MwJVE{Xy{Tc8gm?DO$%Z)bKmdtNN?ZeOHLRu;G`@y6rM*NxxI@pgH=T;2{B3;tkL z?yJ<#(LJli``nLetjqGFtgU>T!cHU0qh(S1x(|Nu9(XdIC0(w!m3KtIo1^CY!Bts- zA0w=e{v_f?7+o`Pj_>#R5q5@e?d8R+3%PM$H~4wC(E$8u$h$1}o5`~7SpVXytp4>? zp4Gdwto&8F&955PdS$1f4O6#qu8L%#Mc_zAMdJ>itL_VGmBGz-tGnM83;sMwcsk9AyEk7z-l_a zxb@AxD*9@Bu5iV%`H&S4vLH###^3J?Y+VY&({))jNWK{kOzs;P<1jLaqX{sLE`fLq z*l{G|MU?0`<7ymPU@QSPN;t(uG&={9Xu_9R*T>^1=E_vY_%fPu&MdPwlbr?#unvZU z0V&CVmqL)anUdfNOk{bF1pu+EA|?lbxWGg>*hxfOoXZ?m7RJOQmaHO?Gd(Q#NTUS{ zWjB<_@DE^?L>Z|`6gU*HPz#n~IkyTH3c}@uL?=p037&w>dayHz(ZGo&*P?Wo3b-A& zl_{hyCju}{BC26yfu#7Nh;E+iXf>5g^)){4l{Bu{U|?u8m&54SHEFp!hP8i$3-DrO za<^S?9Lxd70OktD?RIRi7o(RraN+6gNFRcUy9bzm^b&WHf$?HNBKhVKYnZ0uZNjEx zD(;=hCo~}r{MPDfrXpu~M#ic|=!g@OP(K>2x0rg47UW-k7xh@{N;*tkDHc@IiDT7@ z>>OeI1p>T!Dw#x21PH0mzaan>7#U%%jUojpb16Y<(K@v}l|n^m6_9S!-qVJnR;nBo zY^6kBeA~)vUO-=FfU{@ypSAV34gk~z|9}S|G$omKzV?1uc^S9RLkN3GEbCH<=MK6l5{b*9dtoD}al9c>`grTtpM z16kf?_0}~hH$GeVZ*dARmw!5JtJg$IdL;kJSI>Km&b-gq+y{Qu{aV_2E%7JE12X!n a3N^P3{0)Y|aCP_7`{D4b|DXSq0>1--q`>k3 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..79c6043595fd66484e9bf66d48d01b46dbbe9fac GIT binary patch literal 2673 zcmb^yO>7iZ_|44zwB13LS_>A00YuHp)^5vhO^nm+YB)# zPk+z8{=UBMw&i!+t6aED2+5Nr1g(UGi9p;-PB>yJ88eztQ%Y2m(@MmhbDb8bB$~}A zhU;wTm1^bb=%jtjp2T9Ns)QrNz38+gvRd3!b53 zbFLGL?TyBwad}W4G|1Z!S4hk8d!bOty-H$oUwE!KTX^$%p5r-rIV^u7e@V!qI;WmX zLdq-rTVYRrCrqfw6T(v;n`RGNDXQVM2FL)C^xxDNM<<455LA<&H0 zvxIPWu@j#bt`BpICGz8E!+dU2*9OjyT>RD%^3h2|CIv)G4D};wA$r8q$RLg%3I^8* z_N~F6TC4OZ5(QAdwuU=fc<}c+1ZY1SZ08D#H#ETS%pJO*K{w_KuWG|Q2ljIdn{r)E z9|%Q4mWuf;?1We9;y!HF6$Bs9!+-wY1wVzZuKd=e+*UjT^m?N(7G5fhwZqr3q+L9x zhZlBfAmcfp^{}hA>m5&k_%*$w&^6W$${K%T;af-$t#AE5b?{uXj!^O6Jzgp-Z2a5S z%oW1LFyTWm4O=2{T^m$!f}=@U8%!xibU+1;Hk66*LE6Fl;q$?$ZivKXGoFkZikUTF z#N%v70-4c_sib-CuNtNvp`C(AJA^iv!G|J>VdzFw&zd7yGa@_$24Y0kMx%_MiBL{h z4?Iq$A=tOR2lq|%5yB>Xb|X&h&)_nU(2cZgBKZwicC1zsmotjzmv*9<(ya*2(`^V| zM%%PJ5|<4m!$7XjjHUprPmJ<}IMj{p32qdg*AXe7uC@53VED>}pNQ zTjSPvr5AbMyUsQfc{@(aJERE{gX=Y%0+QPBEoI zo^mQfJ5dd~_d-@T6|Y5C=x%fYSM}QHG2~sK-3TmqUf>9i=uSYrNIqE}7=S68=jmp4 zWx}nA^UEmIM6w^@$ltNU~8LG7C?M{?eEwjVFn3R2CUnzk!etzNOKQoUNYCMRdGW3_@Uq5c_n z-Ve9>l;y>Ri@p;@$Kk;&z*7sF!&a$oRc5dpr>nT?BtL0e70D`%OVxU*H1l5qLdC&^ znlM!*gEeDUcvS-w2F*+=KnjDb9WYp?npQ9-h~NqVWtxRYsJG|IDq6`fK>+=lI+O(T zggYN>41jtg(I~qPUygz9M7i9H9@shf61v_8HkWZMkk~^*9K^p2`HFCIVFk<>VkJ`LIaeCi} ztq45A{P{Ru@c9G5me$9i`=WbUfO3&XH?J&Y>qZbfjDEamt$^S?ac{NATj=wP<>fyC DSrs^f literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST new file mode 100644 index 00000000..a886ba3f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cadadr.test ;; ;; ;; Syntax: CADADR LIST ;; ;; Function Description: CADADR is equivalent to (CAR (CDR (CAR (CDR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cadadr list) elm)) ((or cons string) (equal (cadadr list) elm)) (t (eq (cadadr list) elm)) ) ) (do-test "test cadadr0" (prog1 (and (mac '(19 (1 ((9))) 2 ) '((9))) (mac '(12 ((1 . 2) 3 . 4) a) 3) (mac '(21 (( 1 2 3 4) 5) 6 7 8 9) 5) (mac '((("p")) ( 1 a) (2 b) (3 c)) 'a) (mac '((((7))) ( ((a)) (( b))) ((c)) d) '(( b))) (mac '((foo0 . bar0) (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'bar) (mac '(((no-nil) t) ((((((((( t )))))))) tilt)) 'tilt ) (mac '( "canada" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "vacations") (mac '(#\B (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '("mac" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "with temperatures usually in the " ) )) ) (do-test "test cadadr1" (progn (setq a (list #'intersection (list* #'null #'list-length #'min #'evenp #'identity))) (equal (mapcar (cadadr a) (mapcar #'cadadr '( (aabb (a (((b))) )) (zero (1 nil) 3 4) (noway (#\a (#\b #\c)) ((#\d) #\e #\f)) ) )) '(1 0 2 )) ) ) (do-test "test cadadr2" (let ((aa '(0 (1 (2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (13 14) )) )) )) )) )) )) )) (and (equal (cadadr aa) '(2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (13 14) )) )) )) )) )) ) (equal (cadadr (cadadr aa)) '(4 (5 (6 (7 (8 (9 (10 (11 (13 14) )) )) )) )) ) (equal (cadadr (cadadr (cadadr aa))) '(6 (7 (8 (9 (10 (11 (13 14) )) )) )) ) (equal (cadadr (cadadr (cadadr (cadadr aa)))) '(8 (9 (10 (11 (13 14) )) )) ) (equal (cadadr (cadadr (cadadr (cadadr (cadadr aa))))) '(10 (11 (13 14) )) ) (equal (cadadr (cadadr (cadadr (cadadr (cadadr (cadadr aa)))))) '(13 14) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3627049384f1cfe826a2953a19a53f00d0d533f0 GIT binary patch literal 2980 zcmb^zO>7ip^qZOeX}b$-YXw{@jHL=$+1f3XKuw6lcD6fZcc$)6UFyMR+?}#3?Jn6L zpg~9hC1}Q#QmpfdhMN~J4PHc$9@K*gn0PV4g9k4rUL+nZQ=A08cs#15TpO`de#K@lAySIz|I|g^|8H_}F+hS5W;rMD=WXxQ#X%kst z(>K_+Yj9wow{7`jdw~m-2q9UrgrJp>01=3N!3u};a`^9SMaCpi*VoqT((-p!IVxPBKVq zy>qs;CNdC?grm}slp-HNSRpAz??pl#dx7*yI|6fs+5Ezb9M4J10qJw;D?+X+bIO@G zB;G=TENyiw9aQidQR)i2PZl}SLJUk-iEx;_~s)@|86sVU*XYs89yDOoX`$D z4vb(g>|DJU+T4V&X`J1N6ZQ_c^u)AOQqqyEfo13Yx}s8AcKp)yAm)Cin-P3RMFi&^ z>J5h)Lr+O*G%BS~xCY2|>G9+~EfH?+AmqDfHvsaN1MWKDcL#jW9Fi}YL-IEDpP>E< z^-og&E7Y%2zeN25)E}b$&D7rsUid>0#LenPDhvD0qhc)yBr~)J0QWWBg5bJCEjpm= zFkg45R~_I5Z!OA@tm=wBjy4=~|FW!(0!97=N=Pay;(q|{!(|mt$m*~jN8WG1bE#tq z3{E~{0m!G!Gr3HAvT(94T}kNFmjP7RC#9%wFYVe2+WcAD^45xnilw7PBv0FxuWDAR zV%EqReh_!=JTKT* z+q7{IHqW6#@nEhr-C8fyi`XSm=n?=!l2|Zu1Hbqmiq|4z|-I-8yIVC01bUms;JG?Ze z>9TXZKhf>rn)~sA^d&6_x#}Su~0{u~I7*XZ}wpxEXIuiRp@*hE{@*u&@*rP#6|HE(0kHN#l%$ z_D{+f6GX5uL7A4|gP^}}YXz+&7!81KRT+*0dd!~pfO0)n2PM7~0nN!$sUPj(KMYe$ z({_NxMQjcvc2b{%3{W4Kv>q|CMzv5XRt_;6{M0dzWee3pvAR+U&Z{MG;fYHbNl{o1 zo}_uKkSzf|FF=k^B789^F~ymdR@gCmJOiIYsKD;L0%_0^IMGrH><{XjU;?;(mhD5o zr)Vh6>civ(NFEygx%;I=SShd~0BJaKO6zCoxj=##b{9uaVEw?s!+=i2yPriPhYP3D zOrm*Ea6SzoV9@)lg5g-BSscVbC_p*LqFpd1=%aN5(}S0tLjr=MeQ)~6hnV`U<>kKtMmdn- literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST new file mode 100644 index 00000000..fd81655c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 16 ,1986 ;; ;; Last Update: July 16 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cadar.test ;; ;; ;; Syntax: CADAR LIST ;; ;; Function Description: CADAR is equivalent to (CAR (CDR (CAR LIST))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cadar list) elm)) ((or cons string) (equal (cadar list) elm)) (t (eq (cadar list) elm)) ) ) (do-test "test cadar0" (prog1 (and (mac '((1 ((9))) 2 ) '((9))) (mac '(((1 . 2) 3 . 4) a) 3) (mac '((( 1 2 3 4) 5) 6 7 8 9) 5) (mac '(( 1 a) (2 b) (3 c)) 'a) (mac '(( ((a)) (( b))) ((c)) d) '(( b))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'bar) (mac '(((((((((( t )))))))) tilt)) 'tilt ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "vacations") (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "with temperatures usually in the " ) )) ) (do-test "test cadar1" (progn (setq a (list (list* #'null #'list-length #'min #'evenp #'identity))) (equal (mapcar (cadar a) (mapcar #'cadar '( ((a (((b))) )) ((1 nil) 3 4) ((#\a (#\b #\c)) ((#\d) #\e #\f)) ) )) '(1 0 2 )) ) ) (do-test "test cadar2" (let ((aa '((1 ((3 ((5 ((7 ((9 ((11 (13 14) )) )) )) )) )) )) )) (and (equal (cadar aa) '((3 ((5 ((7 ((9 ((11 (13 14) )) )) )) )) )) ) (equal (cadar (cadar aa)) '((5 ((7 ((9 ((11 (13 14) )) )) )) )) ) (equal (cadar (cadar (cadar aa))) '((7 ((9 ((11 (13 14) )) )) )) ) (equal (cadar (cadar (cadar (cadar aa)))) '((9 ((11 (13 14) )) )) ) (equal (cadar (cadar (cadar (cadar (cadar aa))))) '((11 (13 14) )) ) (equal (cadar (cadar (cadar (cadar (cadar (cadar aa)))))) '(13 14) ) ) ) ) (do-test "test cadar3" (progn (setq aa '((a b) c d )) (and (setf (cadar aa) '(( #\g #\r #\i #\n)) ) (equal aa `(( a (( #\g #\r #\i #\n)) ) c d )) (setf (cadar (cadar aa)) '((3 6) 9)) (equal aa `(( a (( #\g ((3 6) 9) #\i #\n)) ) c d )) (setf (cadar (cadar (cadar aa))) "magic kingdom") (equal aa `(( a (( #\g ((3 "magic kingdom") 9) #\i #\n)) ) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a79e5440d47221614a9fda5e592b3567bf51f2b6 GIT binary patch literal 3169 zcmb_eO>7%g5PrMs#7VpbC$d^dOS=SGsKHU3w9po*>c&~eo7%g<-qei*DqDL~TR3*> zpSA%}g%ni?Ev9Y?>?d{(Nnkki~N~u=PSkes0rKcl$Qh6pONA?ds z67EU0X)6?d^(9%(CE zZ25%Se1`T6J-jEpd$4Ea4d)fkUm}EL$TE^{Li|J^&N|PG0fLm*i`N zTvi+E=@^9ElwbF|`rrJ7iaa4a^*{{HBJbFqxC%(Npu`j0T@aEtWh7N?e3A<|FWVic zoFoK_;adQ=cd!y4=dMg}my6`rPbT>Erv6^81Eu&~N61?rkcBpOsfp#>7#u|V1;x`Z%dSCy4!skgVd|&>5LVT}< zC}NzM{^fK(B!%lcxFt2+&!S)2%cPiYQ}aMeBi+=jYF}+CSI_XjgFTnKxZz)quaWcT z{e&0c=57i`bZtzMIZJxCXr@Ul#O!fiAl+z#DyTTn?R^<+q&GA5^tpx_4!F(_-( zAtp}+DJS%Ti~}c_6g$>Vik=QaSZ~g6zaDLm~|- zf(bc8#W^Y#sQ3gGQ&fynaW@qQsknuTeW2&(V22KtG;+sa{B>%WNE}&<-V21gPVYhT zsmon*$y2Vd>~b?M=>fDZbxhF=)tE*fFM~gzXp_K^8^HN+R)ykDS1GeG2vO2mGVXRL4&eWThVOFSrp(yHzB?}3g?cK*Hb@IFXI4S z6ogL4?wK`@!2EeKUp$g6&34y|V9Z6p7RVT7vp2rh3c+`^!0F(vuw8&dchZN@5Y+Bo zUERoT{x`pRe$_s(3Ws9!>1y+VuppBrIQP5r8p5BmH%F3+Y$%~McQmdVN>Yxe=z27R zd-3R$ZYb_K|3tCg+>ie(@G#20qah@3GITltzI4Cqbl!DZb1Gr9wq2(uAlQYKm6aR9 zbNk@@Q8U2ehuY&=;2GeDjsvV~$piv7j{^7cDAY}0>WAwYAPfh7-u@cF1bF!N?&B`) z@&eo;mJmF{*H?3vbOPRma_|-fJ5QL!npvL1gzWx&MXFV5W}z@AWeS#Amds*S zs?>_bImf>HM82Ans@CjLt87+lWoy+IU=WpV$9>@Dsv6wJmu$g^DZmP2@-*W;hMG`t zBT&JZ1!G!)mx|$``zq)q8|)5uXzF+jmKgs6t2542PgK`OsPB}UNj+LGxhi_fvH4OM zU}j3CVdp&FEVSK0eePl>_0_A2%~*HD4-19AE;zoiRBr zt1646Ghv;~XG*Y!Yk(no;r&aEs&21!!-z6sX?V9n19m@7!2YxXAbL`T@k4zUQ$R~M zZ_t{>vw+DPVQ7xvW6-hpLkeMOP&#au!`lx!iyh8+ET;hJuy}+~ISGq3hEONrX9nEL z9p)0adB7T1*vlN0$(2A2K|-;(XVA%&LbY0!JgY(A`B8Wn(K}%!430uq z?`PMlnP96`uus68ZSoPllhI2qK2Cwr)>gPXm!`hGE(q812R-w-29fe^)6tzH%m}Wr zhl7^u==64V2cg^^&o-8!0BcY%3Ei|2jx(3v;A)z+?`AT1K;!(mIU&deEXDULD}Mu+ CrpfvM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST new file mode 100644 index 00000000..3d678e30 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 16 ,1986 ;; ;; Last Update: July 16 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caddar.test ;; ;; ;; Syntax: CADDAR LIST ;; ;; Function Description: CADDAR is equivalent to (CAR (CDR (CDR (CAR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caddar list) elm)) ((or cons string) (equal (caddar list) elm)) (t (eq (caddar list) elm)) ) ) (do-test "test caddar0" (prog1 (and (mac '((1 ((9)) "hi") 2 ) "hi") (mac '(((1 . 2) 3 (4 . 4)) a) '(4 . 4)) (mac '((( 1 2 3 4) 5 6 7) 8 9) 6) (mac '(( 1 a (((w)))) (2 b) (3 c)) '(((w)))) (mac '(( ((a)) (( b)) (ab ba aa .bb)) ((c)) d) '(ab ba aa .bb)) (mac '((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) "(foo1 . bar1)") (mac '(((((((((( t )))))))) t1 t2)) 't2 ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "to") (mac '((#\F #\o ((foo3)) )"o1" "foo2" (foo4 . foo5)) '((foo3)) ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) 'fifties ) )) ) (do-test "test caddar1" (progn (setq a (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity))) (equal (mapcar (caddar a) (mapcar #'caddar '( ((a (((b))) (3 -3) )) ((1 nil (3 4))) ((#\a (#\b #\c) (2.0 2.01))) ))) '(-3 3 2.0 )) ) ) (do-test "test caddar2" (let ((aa '((1 2 ((3 4 ((5 6 ((7 8 ((9 10 ((11 12 (13 14) )) )) )) )) )) )) )) (and (equal (caddar aa) '((3 4 ((5 6 ((7 8 ((9 10 ((11 12 (13 14) )) )) )) )) )) ) (equal (caddar (caddar aa)) '((5 6 ((7 8 ((9 10 ((11 12 (13 14) )) )) )) )) ) (equal (caddar (caddar (caddar aa))) '((7 8 ((9 10 ((11 12 (13 14) )) )) )) ) (equal (caddar (caddar (caddar (caddar aa)))) '((9 10 ((11 12 (13 14) )) )) ) (equal (caddar (caddar (caddar (caddar (caddar aa))))) '((11 12 (13 14) )) ) (equal (caddar (caddar (caddar (caddar (caddar (caddar aa)))))) '(13 14) ) ) ) ) (do-test "test caddar3" (progn (setq aa '((a ab b) c d )) (and (setf (caddar aa) '(( #\g #\r #\i #\n)) ) (equal aa `(( a ab (( #\g #\r #\i #\n)) ) c d )) (setf (caddar (caddar aa)) '((3 6 8) 9)) (equal aa `(( a ab (( #\g #\r ((3 6 8) 9) #\n)) ) c d )) (setf (caddar (caddar (caddar aa))) "magic kingdom") (equal aa `(( a ab (( #\g #\r ((3 6 "magic kingdom") 9) #\n)) ) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e3be0ee92f2fb9ff2fd2437ad7c0150d98efcf77 GIT binary patch literal 3451 zcmb_eO>7%Q6rNq%vGe294Z$fX6vwD)?Tf93KBT+ zyqPy|-rv0Wo-53IL`jB}$rDp!!85jWjIpNE-Ugv~w=0L<)UGjBDZZ`^h=QN7bH&eFhOD?q1$`SBTOJ#2 zsuTlb0VaCP3+4MGN?MC0$Wy5wEhkl7I*>q)b}$i z!&yU3iNaEgooy$l9=E@v{-Y_yf@mY4o}n z12^SPOrnyScv?@%#y&jTyymYWXH~8R?MW!+u~hEF^w(%~AbB4I-Th|SJ2!EBV)Dg_ zm|1R^EzHb@Mo04b{B-Ajv;3ez>+mabICOLbD=;4#o8aX`yjOM#=6mLXh<0}$K-uI6xQ@no@xhtSFDvDiwV(Wd30 zCW?sUQFaW!?^T^G75SfCwSm8{+REqKhJwyXqP%FgSufLm2ZHWI;w1^kIL)`&exNVT zlIZpS$?zYJVP6rSSB8c|G{k9;$KB)Z+l#$q&@#H%zBYYu+&Au9Sqx(C@c%Zf?l`F_ z75~{sG}3a%?ATA*2YwM>p6J1^8|p*>8m$*6$k68UJw&cUGm*#nYPYpw*Q^!$jIYi>cpk!Y^iET9Mv?VraJnTsoH~$BN)8SVLq`@m z5)ghI!aXD^XELf5+X3M%r2kvEm&jEJ68V&q3;2fI58(&ehaM# zvP*nbf#6eU!z~->)F4gLu~;U96OTHmYMJdgtIH-*8ASC#RWZ`KrT-?hkp3GEN*u-Z zGh4K5{tWlg*8B7T&x;T_R~8OHo4G&$DJVEY65~Wga-I-Fh(jBW2f6d_ZaND4pa*(M zUEiA6Yi7CT#N-5aII>q-x0*N4yWO4|FYU}#&0`iuK`UB-?L0X>Jd|!H6b^WM>0~Dl z1;MojofKuP459}p9;6CIv)~a#7e?3K7OeLWSEZtf`)L3Hnx|#ken(#jC%t1D%3#)6GsFu*6rEDCxW=kW+ERidjQ%VvKhEaKwAs> zg6d^mmxpPGdS2p)mP=vxni?5BK60!8-Ih^2U!&x(6B*FPyVL5;vx^Y^|62^~5}IMR z)lz(v(G($<^Mm9j;bGH;mNM;NTQyy6DZ0a@mZIFHr399T0vlS&2XwZI=U}IeoQ-#H zE6t8&qP(pH*R_>FCmP;XYzIgh+luAOT3fMxSUGLwE`}}0zLRAevNyuD5Aa74BDEip zy52(SO}{aHt4Q5Q7b0_PZs%zH9mnP``05Rg%^*Dk9qS+%9!BW()A2Bej8=}PjT}Kg z;duHHUtK^vh3Fvc%|O?7=(b?;2@Wy6&g121X+g{*9AbQHSg;OIY(x+kz8gXqbb|d} z4I;m+9t6XIj~_R~$2ATg%j-R`;A4ry#~HMM+V2P-{^lM39z=Fmqlk?NHh#df7I?sO q1RRiG4;gUmKVb#T*)Rd~gb?sDLIa%K1PMSHENujXcZvJ;%F183`qdBs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST new file mode 100644 index 00000000..28e2c183 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cadddr-and-fourth ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 263 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 2, 1986 ;; ;; Last Update: July 2, 1986 ;; Oct 9, 1986 sye/ change ((1 . 2) . 3) to ((1 . 2 )) in "test fourth1" ;; ;; Filed As: {eris}cml>test>15-1-cadddr-and-fourth.test ;; ;; ;; Syntax: CADDDR list ;; FOURTH list ;; ;; Function Description: CADDDR & FOURTH both return the fourth element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the fourth element of list ;; nil - if list is () ;; (do-test "test cadddr0" (and (eq (cadddr ()) ()) (eq (cadddr '(1)) ()) (eq (cadddr '(a b)) ()) (eq (cadddr '(a b c)) ()) (eq (cadddr '(1 2 3 4)) 4) (equal (cadddr '((1) (2) (3) (4 5 6 . 7))) '(4 5 6 . 7)) (equal (cadddr '("sunday" nil nil "monday" nil nil)) "monday") (= (cadddr (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) 8) (eq (cadddr '(|****| |%%%%| |????| |####| |^^^^^|)) '|####|) (equal (cadddr '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '((a . b) (c d e (f . g)))) ) ) (defun fun (list elm) (typecase elm (number (= (cadddr list) elm)) ((or cons string) (equal (cadddr list) elm)) (t (eq (cadddr list) elm)) ) ) (do-test "test cadddr1" (prog1 (and (fun '(array (fixnum) "package" simple-vector 'cute-t) 'simple-vector) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) 1) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '(decf 1100)) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom)) (mapcar (cadddr a) '(4 5 6 7))) t) (fun (cadddr (cadddr '(1 2 3 (10 20 30 (100 200 300 (1000 2000 3000 4000) 400) 40) 4))) '(1000 2000 3000 4000)) ) ) ) (do-test "test cadddr2" (progn (setq a '(aa bb cc dd ee ff)) (setf (cadddr a) '(1 2 3 4 5)) (setf (cadddr (cadddr a)) '(44 33 22 11)) (equal a '(aa bb cc (1 2 3 (44 33 22 11) 5) ee ff)))) ;; ;; fourth should behave like cadddr ;; (do-test "test fourth0" (and (eq (fourth ()) ()) (eq (fourth '(1)) ()) (eq (fourth '(a b)) ()) (eq (fourth '(a b c)) ()) (eq (fourth '(1 2 3 4)) 4) (equal (fourth '((1) (2) (3) (4 5 6 . 7))) '(4 5 6 . 7)) (equal (fourth '("sunday" nil nil "monday" nil nil)) "monday") (= (fourth (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) 8) (eq (fourth '(|****| |%%%%| |????| |####| |^^^^^|)) '|####|) (equal (fourth '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '((a . b) (c d e (f . g)))) ) ) (defun fun (list elm) (typecase elm (number (= (fourth list) elm)) ((or cons string) (equal (fourth list) elm)) (t (eq (fourth list) elm)) ) ) (do-test "test fourth1" (prog1 (and (fun '(array (fixnum) "package" simple-vector 'cute-t) 'simple-vector) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) 1) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '(decf 1100)) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom)) (mapcar (fourth a) '(4 5 6 7))) t) (fun (fourth (fourth '(1 2 3 (10 20 30 (100 200 300 (1000 2000 3000 4000) 400) 40) 4))) '(1000 2000 3000 4000)) ) ) ) (do-test "test fourth2" (progn (setq a '(aa bb cc dd ee ff)) (setf (fourth a) '(1 2 3 4 5)) (setf (fourth (fourth a)) '(44 33 22 11)) (equal a '(aa bb cc (1 2 3 (44 33 22 11) 5) ee ff)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6258cff02bc341f76e1cf85d5261976515efcced GIT binary patch literal 2477 zcmdT_&2Jk;6rbI-W2bRkCr#5PsgkutL}jv7Hf_};An0bjZrnQSbiE<%0ij?!wW(`Y zw$rMrD5X@0!xC^)qMZ`198r{0Ls0?(q#~6I>V?06YbDMoyf^E0O;ZGiUhv1hnK$oi z-u!;Eb>cgxCPlS;>2jf%tBB>L+U2F1xLB@;)$&p$lM@#~FJ4zuhW6gHqMkYOs=O!N zvXZIf7HYYyXfEZd*@bH(qC6_jEL;=iiSh9faqQ^iv584pKC&mSq?1l8*JD1HExA5& zi_hrf==kIqxa@psuX3R>AtXb#QM3~hA_B4RSfQw?rA;ZGNNSR<%xF=&Zd-oXi8Pni z4BP4&6KmzmQZaWWSH#U+suGS6`!mZQpVL({k<#rI?j{$oKeaj&x-<(LQ%-4w_cx+o zbk4SVAvL) zaQV$G9mY@UXFkz?Af%rENI%VUorK)UuOFCayTTCo4-m3l$aL59p+bo8Ui)+FP*hFn zu>{sBO+(_OW=K;B(CDYqQQiX$=!&X}sZL9VX3iO~0hM*2Eqy+1YBM~y+rmsmX+ZGN zPQeeG4n{S@NEuRU&YYbyqe4441fq(5USj%ml)~;q@-t2J34~A&c8*U%khXZrm{H6V z;M?=GUR6nJP87%|ftiFAK`qrIMK+wv`yE|$tyOEKH(sO73PF|&}(Rz^?S z){u$Q$PFbTE-nE4vSOj+UW5=mYm@ZK|WvFG~lRaxqWb!UR<0dh#KE5Lbz-za(+eRbR%+HFaSa} zuCz`rv`!f8P=RKN{MNf~2e(tfV)oBJ)>1*ee=8Nd_!v~Tb*TD-_1}v;+6}o8T$%5O zPb13By!&lHH~7!ct*;-P?{R~mbdcN2$k`wR_m;aQe;%NI0v}`ekcvW4c(O6<`ajw@ z*c{U4$SLOEOJOW}UM&q4`DrKbg};aH;W-)<+5z~Tbg$4sL(jV%+MCGkz%x2W_n}Z} z4+!#z&B%RcX3@E7 z(0+g`9dHVH$TE{3-OP-AGPsfNSZ4C^vikmV?E12Lb$P0~tW4dWdgxhu-CltU0D=IM zIE997i+hJHI85W^SK5!`@Q&pL63!f@;X&DPaaA%6ceYrJ(Qpq2oEmIV9;4yIhoN}< zK^~Qc;TdC3jfP*cR|NVRE=)lI%!(#k4F+t>%NltAQ(NA}LZw=>t+r||Q!ZuQMO-LX zYI)~2Y4(P!(Z~zF66nj^K6;p40f-Os8^Yavd9W)W^nbYm81K4Wx}tRMfFAel)xtU8 zAnt*6^Qm!3)^2_r`Mn_t?C7|6d8g-%eX9vtbxnO3e&%pfse*rU~sRhUM k4TfQWWCOZ1hKQx{r$D6%7oUGeo&!yqdhw{dcVlPgFRBXP3jhEB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST new file mode 100644 index 00000000..1916213f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: caddr-and-third ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 263 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 2, 1986 ;; ;; Last Update: July 2, 1986 ;; ;; Filed As: {eris}cml>test>15-1-caddr-and-third.test ;; ;; ;; Syntax: CADDR list ;; THIRD list ;; ;; Function Description: CADDR & THIRD both return the third element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the third element of list ;; nil - if list is () ;; (do-test "test caddr0" (and (eq (caddr '()) ()) (eq (caddr '(1)) ()) (eq (caddr '(1 2)) ()) (eq (caddr '(1 2 3)) 3) (equal (caddr '((1 2) 3 (4 . 5))) '(4 . 5)) (equal (caddr '(#\a #\b #\c #\d #\f)) #\c) (equal (caddr '((1) ((2)) ((("s"))) ((((w)))) )) '((("s")))) )) (defun fun (list elm) (typecase elm (number (= (caddr list) elm)) ((or cons string) (equal (caddr list) elm)) (t (eq (caddr list) elm)) ) ) (do-test "test caddr1" (prog1 (and (fun '("first" "second" "third" "forth") "third") (fun '(a b ((c . d) . e)) '((c . d) . e)) (fun '((item1 10) (item2 20) (item3 30) (item4 40)) '(item3 30)) (fun `('a "b" 100.009 (1+ 9)) (+ 100 .009)) (fun (let (a i) (dotimes (i 100 (reverse a)) (push i a))) 2) (fun (list (code-char #16r41) (code-char #16r42) (code-char #16r43) (code-char #16r44)) #\C)) ) ) ;; ;; third should behave like caddr ;; (do-test "test third0" (and (eq (third '()) ()) (eq (third '(1)) ()) (eq (third '(1 2)) ()) (eq (third '(1 2 3)) 3) (equal (third '((1 2) 3 (4 . 5))) '(4 . 5)) (equal (third '(#\a #\b #\c #\d #\f)) #\c) (equal (third '((1) ((2)) ((("s"))) ((((w)))) )) '((("s")))) )) (defun fun (list elm) (typecase elm (number (= (third list) elm)) ((or cons string) (equal (third list) elm)) (t (eq (third list) elm)) ) ) (do-test "test third1" (prog1 (and (fun '("first" "second" "third" "forth") "third") (fun '(a b ((c . d) . e)) '((c . d) . e)) (fun '((item1 10) (item2 20) (item3 30) (item4 40)) '(item3 30)) (fun `('a "b" 100.009 (1+ 9)) (+ 100 .009)) (fun (let (a i) (dotimes (i 100 (reverse a)) (push i a))) 2) (fun (list (code-char #16r41) (code-char #16r42) (code-char #16r43) (code-char #16r44)) #\C)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fb67df9dea7a41eb7e75438c0a9e82cc348e561d GIT binary patch literal 2602 zcmds2&vO%X6#wofY0{E}rG@}SahnlkRu-F5hf+MSrdyhlY|3V9U^qA>o3fFRFiEO1 zB2&=u;H=fO!t7VjgD1yR?Wkh~siPirhJy#s{skU7!`Z3t?RL{Gt;)fZlOON<-gn=R z@B4l}Z(AgII+fv5wTqX^l~SFrO*b!1H~Fbrop02p>%|g31$O?8R8E!O9FP|~Ze zPtxPlH`F&cG;ril*XqaCO@^xxLW*P=MJFK~@eymzcBa4cZl?AJ1nISld zIFXlC%iPh=H*1%~O6k>71rKwvK^Q`;56sZWgp$(IImMc1W|*+`z8Og?;y4^kIw2D_ zv=#-UGnN@kJ})N4lr*f0k}@pjge;ef-7SMFbA%08H_XQc zOq9kt#ZkzdkyY`jGJ9y;KWdr5>FR}Q?X~K#Wk#B%Mw2g2>h-?k zmieTHTH>md;HM@5eL7#RI?zGe)%}ch%bI5)>%NpKOPVY`lsuExWL3)KX&4`a0!~fj zG@0%sx538;0BC~+ui3guo|O)Bt@4a<<2cJmtDN+W1UI&nZl&KE1<2Xf`yB4AaD*mU zLRh;C7~S+|(h$S+$(by(7m@|@nhMu6&UC{)25@tnAYww-31J#u)clU9=|xup^dmJ@~cfW+5-l<*QxR+yDaj(m$OOmB6sbg$c&wy zjqL+@p#O?B?{f?+N`GL(uAT*T_S|eSZO!{$6jAs}Zb zkTZhh-25hLbF&ls@SVfP&;Egp2yOC-17hG9YVXqcc9csFroY-qH5=7m{0~tLkX=JF Ptvv#SKf)G$y}J4r!cml>test>15-1-cadr-and-second.test ;; ;; ;; Syntax: CADR list ;; SECOND list ;; ;; Function Description: CADR & SECOND both return the second element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the second element of list ;; nil - if list is () ;; (do-test "test cadr0" (and (eq (cadr '()) ()) (eq (cadr '(1)) ()) (eq (cadr '(1 a)) 'a) (= (cadr '(a 100)) 100) (equal (cadr '(1 (2 3))) '(2 3)) (equal (cadr '( 3 ( 1 . 2))) '(1 . 2)) (char= (cadr '(#\a #\b)) #\b) (equal (cadr '(10 ((((( 20)))) 50))) '(((((20))))50)) )) (defun fun (list elm) (typecase elm (number (= (cadr list) elm)) ((or cons string) (equal (cadr list) elm)) (t (eq (cadr list) elm)) ) ) (do-test "test cadr1" (prog1 (and (fun '(1 2 3 4 5 6 7 8) 2) (fun '((propery . 10) (item . 100)) '(item . 100)) (fun '( (((((1 2))))) ((((((((((10)))))))))) ) '((((((((((10)))))))))) ) (fun '("first" "second" "third" "forth") "second") (fun '(#\a (#\b #\c) #\d #\e) '(#\b #\c) ) (progn (setq a nil) (dotimes (i 10 t) (push i a))) (fun a 8) (fun '(((2 3) (4 5)) ((20 30) (40 50)) 100) '((20 30) (40 50))) ) ) ) ;; ;; second should behave the same as cadr ;; (do-test "test second0" (and (eq (second '()) ()) (eq (second '(1)) ()) (eq (second '(1 a)) 'a) (= (second '(a 100)) 100) (equal (second '(1 (2 3))) '(2 3)) (equal (second '( 3 ( 1 . 2))) '(1 . 2)) (char= (second '(#\a #\b)) #\b) (equal (second '(10 ((((( 20)))) 50))) '(((((20))))50)) )) (defun fun (list elm) (typecase elm (number (= (second list) elm)) ((or cons string) (equal (second list) elm)) (t (eq (second list) elm)) ) ) (do-test "test second1" (prog1 (and (fun '(1 2 3 4 5 6 7 8) 2) (fun '((propery . 10) (item . 100)) '(item . 100)) (fun '( (((((1 2))))) ((((((((((10)))))))))) ) '((((((((((10)))))))))) ) (fun '("first" "second" "third" "forth") "second") (fun '(#\a (#\b #\c) #\d #\e) '(#\b #\c) ) (progn (setq a nil) (dotimes (i 10 t) (push i a))) (fun a 8) (fun '(((2 3) (4 5)) ((20 30) (40 50)) 100) '((20 30) (40 50))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..07dffbd673a8e684edb942fcc42e728b7346e945 GIT binary patch literal 3427 zcmb_eU2GIp6u$S)Zo6%_^v4Bi#bqc^VeJsMU@XO-4BIK)c7N*b)LKJgmhG0^bh=yj zMOm@Zf_n8jU7C@K6&I@kKmmZl{HoXfWN~ zn{&=L_kQPRPR`zGQvFCEBnNU6lNlqGmvg1!WT_~RE4{&xrbN`R<};_w zvI{a%hT>YxEH`z^#oVM~q@G9_n9M|hP(sY3WmoS|B%lYQ5%V}bOx@-y<@#Vm8HB{t z-5O!8ITmE6X1UpakK$JXYD`fhJ>V@C*9ipG^eiEc4>6*T)93r?xh#3+lYTZVw>D8{ z=KMZFnxCz1q3LrMBB0Ms54;@toRI1C^O1f=>p?r)GTerz?d2xqVkWu4%5jd7>NaDw z;Q$u+)e%CGukyHk4ke&a7K-X@Wyq*cZn_AYK4obSK?Q!sDD0_pS?HH@6r0k?c65h6B%hoypQ&6R#&sOB92P@c8Sqb}4yY#w1F4;8@ zvUzz*!9K79uS-v-4=+~=e7IKLTVL5=c z$rn)dK%WxR^r09G)qpjXtKuVZT?;e1bcY`G@dl}p*Gf$=h*$WuSS%V-qC@)NknWS3 z;egwxMn)71kNY^4ZsTsr12|JvUI$~oYw?(GbP~cHINV!tNS^`Ts@`ZUtmj&#r_Y0UFf>~{S(@I z!VianadgRkzz7~zLql2|&9h+Egw+8}u{Q`eOt@j2EvIay<&;iZ7TqH(udwPZi+sUv z2SV}=$3)4C{0uq738P<(M(c)urrsHn%^E z=4rFsS4mo3N>a1q*@k`qQTm4`dh-UD)}kjd_o z^OHs*nUL|4l`4)Q-{;+0?F8-Psu%`D%w zkl{ASFp=L^nn-1fa;5+Yj^>JZ?=v!mB5wbMx1*RbUv+UeWm1i+8s^L{>(xuAZ;BqV zg5-BY2)sl1J}7+eH_ICre0MJKUCftK^PUUBbEA2@in}3Ybc!M%L=TAL5(1h4dJ({R zMRyAT`V+075dHYr+CLzGkPu;!iraF-@8w;52khhBd?&E+`}qC*0sbH&yLf>2KrPs> zQ+^cRO>IN*?Nld<%L4owl9n6@d=A6vy5AhSv^GrChCyxCEY!xos5YB6Bc~_{^Dikd z+h`S-tuxC#7D+OZx0@H#|I@ncPOJX(=cTPlzk@7YH4qW~W?p-8Nl?_Vf}&~rtwSXL z)o*lEcx_+G)+*RmndS9%ivQk0wAtb!Q`V~?&rNN6daCo_ls|qW_inx+V3u2L&ZU)q PkhjwtkC2lS*RK5oK26_C literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST new file mode 100644 index 00000000..1b674a6e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: car-and-first ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 262 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 13,1986 ;; ;; Last Update: June 17,1986 Sye/ add "test car4" and "test first4" ;; ;; Filed As: {eris}cml>test>15-1-car-and-first.test ;; ;; ;; Syntax: CAR list ;; FIRST list ;; ;; Function Description: CAR & FIRST both return the first element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the first element of list ;; nil - if list is () ;; (do-test "test car1 - argument is ()" (eq (car ()) ())) (do-test "test car2 - argument is a true list" (and (eq (car '(a b c)) 'a) (eq (car (make-list 4 :initial-element 'rah)) 'rah) (eq (car (list 1 2 3 4)) 1) (equal (car (car (car (car (car '((((((3 4))))) 2 1)))))) (car '((3 4)))) (eq (car (multiple-value-list (values #\1 #\2 #\3))) #\1) ; create a proper list (progn (setq aa 10) (setf (symbol-plist 'aa) nil) (setf (get 'aa 'value) 100)) (eq (car (symbol-plist 'aa)) 'value) ; (equal (car '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))) '(a b c d (e f (g h i j)) (k l m))) ; ; push a function def to a variable (progn (setq a ()) (push (function +) a)) (= (funcall (car a) 1 2 3 4 5) (/ (* 5 6) 2)))) (do-test "test car3 - argument is a dotted list" (and (eq (car '(1 . 2)) 1) (equal (car '((a 1 2 3 9 8 7 . b) c d e f)) '(a 1 2 3 9 8 7 . b)) (eq (car (cons nil 100)) nil) (eq (car (car (list (cons 5 6)))) 5))) (do-test "test car4 - the car of a cons may be altered by using rplaca or setf" (let ((a (list 11 22 33 44))) (and (eq (car a) 11) (setf (car a) 1111) (eq (car a) 1111) (setf (car (cddr a)) 3333) (eq (car (cddr a)) 3333) (rplaca a '(8 9)) (equal (car a) '(8 9)) (equal a '((8 9) 22 3333 44))))) ; ; Function "first" should behave the same as "car" ; The following test cases are the duplicates of the above ones, except the function "car" was replaced by "first" ; (do-test "test first1 - argument is ()" (eq (first ()) ())) (do-test "test first2 - argument is a true list" (and (eq (first '(a b c)) 'a) (eq (first (make-list 4 :initial-element 'rah)) 'rah) (eq (first (list 1 2 3 4)) 1) (equal (first (first (first (first (first '((((((3 4))))) 2 1)))))) (first '((3 4)))) (eq (first (multiple-value-list (values #\1 #\2 #\3))) #\1) ; create a proper list (progn (setq aa 10) (setf (get 'aa 'value) 100)) (eq (first (symbol-plist 'aa)) 'value) ; (equal (first '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))) '(a b c d (e f (g h i j)) (k l m))) ; ; push a function def to a variable (progn (setq a ()) (push (function +) a)) (= (funcall (first a) 1 2 3 4 5) (/ (* 5 6) 2)))) (do-test "test first3 - argument is a dotted list" (and (eq (first '(1 . 2)) 1) (equal (first '((a 1 2 3 9 8 7 . b) c d e f)) '(a 1 2 3 9 8 7 . b)) (eq (first (cons nil 100)) nil) (eq (first (first (list (cons 5 6)))) 5))) (do-test "test first4 - the first of a cons may be altered by using rplaca or setf" (let ((a (list 11 22 33 44))) (and (eq (first a) 11) (setf (first a) 1111) (eq (first a) 1111) (setf (first (cddr a)) 3333) (eq (first (cddr a)) 3333) (rplaca a '(8 9)) (equal (first a) '(8 9)) (equal a '((8 9) 22 3333 44))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..10945608f7ce436445bdca299dfb8246cacc8e6b GIT binary patch literal 3289 zcmb_ePi!OA8Gkbq$4NX3-pE?0NnuD~p(YM-vWs@p9(Ll4p#1sRiku~R&6ykEXVE&sB~-+JvI~56Q`$7oE#sz^;iD|AzUSdd&Mh90Fi9& z-o12h2M$M>kiAk~VJqCuOL(=DR}e6uhWx)6jTYh8A$7&%<%4m21o@FXfy1a!)D|-i2qKbEcH z?p@!z>YK%IDNIBeHu^{`X&SRS9?p1LHD)uK6`#?8W6b4ZVu(h>AiM#1``{!VjU`n( znT}hUy=cJ+PO=uzpIgq^T2>Tp*RahPJthr-KvY#4lJ1}p=}tIocf>TyGOf6|XfG_< zF)0iha!fUrQUiDrc#DhRRb^K2GHkDu=;Nd=+2=EK{Ujh8EdxVDuRzcjyB+ zjL@Ip5aHAS8-xa93T00Hk`E%Fv2F(X-I7-{)tj!F@xCTO=eGCXNKf& ze7FMT3L3Bh3_U|barFA0?**Hcrz+J;6(sk3Pj0yNhLSHhj#HaL-VNWo&qm(px;me@ARR*}}O1yPy*nTmAtS5d;8SX|S!nEefIpU+Yd>J5tL*0B+kVwA|JT zf*pa|K!3S#=JPP|y?e^e>XQWr_u*|l1Gc}={`|u&LpTRC0RZylZMl(;S#IRRgSp`@ zBk!}^$Yp;UVuN@^$P2^wjx~y|atZEbMYz#{|9PjPoZTbjsy5C0}-( zn&MOnO1)XBtoh#kmr9MI(r{NVxHYHIthrrX076{YcfpjNvUM#7I~H6+L)8tKKI=(# zS_4v=RhJpvXX{xFeS!!YIw(_&`xUtHOinyhM@!Xa+dg3Eb7`3V2DKrJEw67zwGuSM zCzCXEk!1<_;nPZi62p39U!hg?J+Ybq?3HSD5^>-GY05OGzy}8f;sgVQ$w?YoMICSO zqLX(TrD~;KVrKo^30wu;r}L#osnY1x0WXaz0QaZWB~|Brp+D_`Knc$b3S+Ut@WaEF zpG%;2%)?hK8Sd?Ew1T=~J>c|UpzN%2E)=HYk}Uu)QQHKHrDNe?*RvJn`;DEQ&RJkd z;k_CjI!4n!$8qEoKO~He8&oJ@=M_Z?nxaI<9tDZ?h`${Ga{s~OhCOKTeq`-PxO&@g beUkd<$X#tH<_GS42agQ73Rwxmw{HChExF*q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST new file mode 100644 index 00000000..03373f82 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDAAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 15 ,1986 ;; ;; Last Update: July 15 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdaaar.test ;; ;; ;; Syntax: CDAAAR LIST ;; ;; Function Description: (CDAAAR LIST) is equivalent to (CDR (CAR (CAR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaaar list) elm)) ((or cons string) (equal (cdaaar list) elm)) (t (eq (cdaaar list) elm)) ) ) (do-test "test cdaaar0" (prog1 (and (mac '((((1)) 2 )) ()) (mac '((((1) . 2) 3 . 4) a) ()) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) '(3)) (mac '(( (((1 . 100) a))) (2 b) (3 c)) '(a)) (mac '((( ((#\a) #\b #\c) (( b))) ((c)) d)) '(#\b #\c)) (mac '((( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(foo2) ) (mac '(((((((((( t )))))))))) '() ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("vacations")) (mac '((((#\F (bar1 . bar2)) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '((bar1 . bar2)) ) (mac '((((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) 'non-nil ) )) ) (do-test "test cdaaar1" (progn (setq a (list (list (list (list #'null #'identity))) (list #'list ) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaaar a)) (mapcar #'cdaaar '( ((((8)))) ((((9 99 999)(1 2) 3 ) 4)) ((((#\a #\b . #\c))) ((#\d) #\e #\f)) ) )) '( nil (99 999) (#\b . #\c))) ) ) (do-test "test cdaaar2" (prog2 (setq aa '((((1 (((2 (((3 ((( 4 5 6 7 . 8))) ))) ))) )))) ) (and (equal (cdaaar aa) '(((( 2 ((( 3 ((( 4 5 6 7 . 8))) ))) )))) ) (equal (cdaaar (cdaaar aa)) '(((( 3 ((( 4 5 6 7 . 8))) )))) ) (equal (cdaaar (cdaaar (cdaaar aa))) '(((( 4 5 6 7 . 8)))) ) (equal (cdaaar (cdaaar (cdaaar (cdaaar aa)))) '(5 6 7 . 8)) ) ) ) (do-test "test cdaaar3" (progn (setq aa '((((a b))) c)) (setf (cdaaar aa) '(((( c d e)))) ) (setf (cdaaar (cdaaar aa)) '(((( f g h)))) ) (setf (cdaaar (cdaaar (cdaaar aa))) '(((( i j k)))) ) (equal aa '(((( a ((( c ((( f ((( i j k))) ))) ))) ))) c) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d5ecead4043492d4ffdadecbbcc4774bddc05b8a GIT binary patch literal 2937 zcmb_eU2NM_6u!3e(>5NeXf~Z%b34mrf~0R()|)Ru1oc zDAAW&Wy#lUt6>);vuW20*35vE7?d*BjFi~FZ{L74wClj`{Ra|>oqZ`em-e{2hzYw; z>0%PAFoOpY_}STa<9+unE?gyqNJoP~gZku-uwksk<>Hk?+@%Wn;j=^hL^QgN^P{%7hLDd>;jGN#w1QLoqHuKCBez;IK!2w8t77~zVS7Im2aI(PUD9ZE4*d{sZhbFjwT!lsF3 zKI9S!St{i>v+eC9#eL9CDhM1Dvt z*b*NnJz+(WSW&Dfqc!!kxFR@?0@o3KKpAr>Z}u7+}}M+BStq0A{cmC zrXit^Mua=yRNoO(vsoh>H^$AeaWf{Y1rISM>yvS&&&4Pwgh9sv2yXDMTW_%FCxqRZ z*$Cc)-9Q;g8QF|%qPPW+k(HbjIj4HObR(F#b94(1C#ZzO7-BQ>m?CFEB!7aqHaD3$ zXr$xa{($=5={6jG@rJJ%1-Z;9$g5O*fr`^qe2R*XQSmSpAEx4ND&9}UekzK9<2L}U zpXG*9A9SC9j`5~ZZWE+f|>jV3ZFinMkM(egn*KS zKNkD~V;~=T(D&$eB;*HOC)lh!SE-(;pg7<4m;OH|FZrn(?9v_ORS>_!tH!M zVLls-?>!&j`Dg!+&>zwzo@PEg)-FE>ECt|abRb^9+-*Pb0nyF^xbdGLBH`t{| z#|=~Uw&FFq15-VFbHx&1q0WE4rp0mjsOvQ z^B@a9dMIfBpyOv}83O7lw5-8A@8?$h5c z2-J$}JXGM>#T~)o0Rg$rszH;m81<4QU$G>~mp3Olh~A&GB*~dhR8F*1mzwpaRW8p+ z`Lb=*B&$-8>di`J=Cs@Pw;u7*a4%xcuCuXGw51d9PEdrm35fELRcTtanRzFuL#xrX zG+b`<`v+Rr*?OYXC`t```j}m_8qJ!$5&}@-3b41ql$J6zHHU=QsCZ3>>3K&mM^zAo zq&&%FpQ&Y3ToX*t>A;yb;h8%$cz+#HvI$=Ej$hYCMqzp!JX_ToX10~>8}4x{h3U;Z zzJqc$K||hTh=y8K*Ws%PV4JE|hj0z}fHh?pyMWchfUuikV6umXO6cS8jjE0GPH(YEKLI|BV8*3xPvsL z07>il&XHr+uzP7(dPu+6!2rN31DB+s{dh(oDo{R7Ltak-1WUa@`(ftA24G%bQC=Mc z9^U}l6|M(eyC1mmtn>A5g*djsy~T}g!$V&1(f&KZO=PYZ5WIfeeEG;b7~)SiZu|w3 C#DAXv literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST new file mode 100644 index 00000000..c9f4d558 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDAADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdaadr.test ;; ;; ;; Syntax: CDAADR LIST ;; ;; Function Description: (CDAADR LIST) is equivalent to (CDR (CAR (CAR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaadr list) elm)) ((or cons string) (equal (cdaadr list) elm)) (t (eq (cdaadr list) elm)) ) ) (do-test "test cdaadr0" (prog1 (and (mac '(12 (((1)) 2 )) ()) (mac '(34 (((1) . 2) 3 . 4) a) 2) (mac '((8) (((( 1 2) 3) 4) 5) 6 7 8 9) '(4)) (mac '((z 0) ( (((1 . 100) a))) (2 b) (3 c)) '()) (mac '(#\q (( ((#\a) #\b #\c) (( b))) ((c)) d)) '((( b)))) (mac '(bar66 (( ((foo1) foo2) . 99)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 99 ) (mac '((1 . 2) ((((((((( t )))))))))) '() ) (mac '("confusion" ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to")) (mac '(#\! (((#\F (bar1 . bar2)) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '(#\o) ) (mac '(#\? (((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(("is usually clear and sunny")) ) )) ) (do-test "test cdaadr1" (progn (setq a (list #'cddddr (list (list #'null #'identity)) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaadr a)) (mapcar #'cdaadr '( (80 (((8) 88))) (432 (((9 99 999)(1 2) 3 ) 4)) ((nil nil) (((#\a #\b . #\c))) ((#\d) #\e #\f)) ) )) '( (88) ((1 2) 3 ) nil)) ) ) (do-test "test cdaadr2" (prog2 (setq aa '(0.00 ((1 2.333 ((2 3.444 ((3 4.567 (( 4 5 6 7 . 8)) )) )) ))) ) (and (equal (cdaadr aa) '(2.333 (( 2 3.444 (( 3 4.567 (( 4 5 6 7 . 8)) )) ))) ) (equal (cdaadr (cdaadr aa)) '(3.444 (( 3 4.567 (( 4 5 6 7 . 8)) ))) ) (equal (cdaadr (cdaadr (cdaadr aa))) '(4.567 (( 4 5 6 7 . 8))) ) (equal (cdaadr (cdaadr (cdaadr (cdaadr aa)))) '(5 6 7 . 8)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b329295933654cce3385d10f0bd397d7386c4b5e GIT binary patch literal 3167 zcmb_eU2Gdg5Z=AB<0QTow}b#8f+G|PCa&V7{Ip1@SLYmGYTpI>LK=Zo4*P;F9J}&Q zOF&eiNC=_Bkfc<%6a*3vfW$)tFO;H20*MC%JR{G z=9}4>*`3*4BcY>-w3?_cA1{^Nnp$l(jyD_XQnjYmtIb;8RhNLTK9jJr`m-r5ab({E z@xfe=Bwur#hFehWrduyKE8}W>Ld`fUYW%?c_m8WSQwR4SI2e!b8%%1sw6N9DSa1uK zj!wKsXX0Rd;@}jhTzb<#OCwc6NS)AVnAWr`c>|V}Gg_j%5@P(bWS=$_Su3p;&mN*w(k?}`kG0PUId7~P z&!@m)!Tu`3rN2f9QzSwp7J&8r4axTcX#>o7vYyV+QE(@ev$KXdGe@uWU-N<}oFfDh z5k3uSA7K_gDPEYR=PTrgPiLit(UDy=h}_~1LOy&3XJrYe6`bOS#IY_S*UO$pqMS#> zeO<)ey@=5s;#|*swRq*g_}Dz za8wA{D&UCV96=SB5Ii#Lz_F}!bdHvsR>{>BW ziV#VGgFG5dSmv~Wg%?X{=5$)m#ts|6F=uj7Da?kX5PU)S0#IhVq6y7Tq+(g!p3g#c zCU|-GRQmQyyf>ex~eY$|zHIf`arS*bDLyky?em*Jq;JX(StL4-OK$4F>uLr|8dO zC=(P)T}&Nsh+GL z`Ihg68*aU!<_nHfn?lw(-@C;|*4Qa+OkHx|nklHIint??cj|V8Rj^C)Udcw=JrnjT z0sAEyC=kguA>&ROK)^67h9fM@qG)D`!=dHMY@Ef|KIA>T&AS_QW`s_P@m_0eOQR^A z7E)bEAMAAtq=!2T-RYl0(YkkYBCBh*9=qazqzzloYUvysMi^|$ZPqf?d{yj?0pavmVI@T}eBcR|4Md0w70tGyMbZ zB_1AwASSuxv>tEeg>tLVa$8G)B!9w9+*d9f`Zhv*@20Y|{CL5^({xoy1D3XL zU%24uQJ@JL`1Y#6$d^1Y^2KF=O(6I)9vC^zJq9x)rMlXzH=S~MMa`F8r=~iUf?97@ zDl4b_4R9YqlKe9~2yeJibk&paYAV8e3tXIaDov-hvhIaU=#Hk5hJyx~_&1}zck9Vg zqo_9A<>PM6X*6r@wgX@iSAZiJN*YPq&~s=I`>JG^Fnz_7?UW9rJgqHqI$#?a9oGaA zG-m)ajPfkJP9`Vz)=^Wl0lDr4O=Bhn(-VMhRckyp+*J5)B{9HtFK}4P##vZQCRw;u z^*yN?2U|SQ}(AWd4<6xb9xKepI8CjX6{q@QlnI9_};(? zC+{>$)k+=AH>$93UrJlh3{n4m8TYADz6$oC;6*Hu4tVAnNdtSwx;Fp~(M~PE8xBEu z=sE6na7ZYCK`U!O(_`UB1mK^3pPS=(fWs+Lffp2p2U%#(APsP0ar?RL_mK^0!uX+% z&_7cml>test>15-1-cdaar.test ;; ;; ;; Syntax: CDAAR LIST ;; ;; Function Description: (CDAAR LIST) is equivalent to (CDR (CAR (CAR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaar list) elm)) ((or cons string) (equal (cdaar list) elm)) (t (eq (cdaar list) elm)) ) ) (do-test "test cdaar0" (prog1 (and (mac '((((1)) 2 )) ()) (mac '((((1) . 2) 3 . 4) a) 2) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) '(4)) (mac '(( (((1 . 100) a))) (2 b) (3 c)) '()) (mac '((( ((#\a) #\b #\c) (( b))) ((c)) d)) '((( b)))) (mac '((( ((foo1) foo2) . 99)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 99 ) (mac '(((((((((( t )))))))))) '() ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to")) (mac '((((#\F (bar1 . bar2)) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '(#\o) ) (mac '((((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(("is usually clear and sunny")) ) )) ) (do-test "test cdaar1" (progn (setq a (list (list (list #'null #'identity)) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaar a)) (mapcar #'cdaar '( ((((8) 88))) ((((9 99 999)(1 2) 3 ) 4)) ((((#\a #\b . #\c))) ((#\d) #\e #\f)) ) )) '( (88) ((1 2) 3 ) nil)) ) ) (do-test "test cdaar2" (prog2 (setq aa '(((1 ((2 ((3 (( 4 5 6 7 . 8)) )) )) ))) ) (and (equal (cdaar aa) '((( 2 (( 3 (( 4 5 6 7 . 8)) )) ))) ) (equal (cdaar (cdaar aa)) '((( 3 (( 4 5 6 7 . 8)) ))) ) (equal (cdaar (cdaar (cdaar aa))) '((( 4 5 6 7 . 8))) ) (equal (cdaar (cdaar (cdaar (cdaar aa)))) '(5 6 7 . 8)) ) ) ) (do-test "test cdaar3" (progn (setq aa '(((a b)) c)) (setf (cdaar aa) '((( c d e))) ) (setf (cdaar (cdaar aa)) '((( f g h))) ) (setf (cdaar (cdaar (cdaar aa))) '((( i j k))) ) (equal aa '((( a (( c (( f (( i j k)) )) )) )) c) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..61bcf3d3b40b891a8e766295b84b25b9ddaa140f GIT binary patch literal 3308 zcmb^zTWs6b^^%k<+hS5V(~?zlQ`W1uRjmTccDgnNwlFjmF_B1>qUN|j5ik-Rs+A=} zkEULc%uRu87+9r_(u8+if%an`1y&%)HegwY7+8UR6xlxZF>L$W-+=xED7s!YwkEGLw#xrs; z7uXtTEIO6?KqozsGbLTIG(-1$+&U-vm%Tlj zo+?0K@^O{$qkSuAo%6kD`fw_pQWoR|*(5)KeTBTNe6|$|`PWEVo{Mc%*WK$!IiBO? zt(g2P`F%oeX&c%rS#Y^ezY`1icVmQ#JRv*{fe(I<_q|X~152Ku=JMPF;8LV$nVNpQ zz{UO7y)ZHhgg`Q)7eVb7X5!cGdndSCb@I30oZuHH6BAq*sqP*^ZhjwE_#m=6jM&47 zIgBX7$UGv<)HjF8_YcT#3{ltJoxk_a60+}NB+j|FZtJkVyK(YW9n!JkUeZtS95}Uc z<132?2R0CjgltyJ5-V{(Fz)?9U=gqZNgRH=i3I$IDZ^`EB@)b6faR&p#VITchm_my z>DZ=wdLKOTP5rf3jM$B7okKR@M$9+%8S$?J`-eu{O`P5b!a9HZ#-G4v)V}k@gvNh) z5L&eQ1zG&;1{ zy>Z}kOS|F5sxiWgaGWQTilHxP*n+97tS{tLGj&V@ihjJ9zjJ(yhY4W~yPm)%d>2fPWDGMeTZsCg8Q+dek&9|z zm+l8Pw?!XB@DY^|yc=LNz?x_&FBcTqL?*WXeZ{5xF(a26j4Grbpi>AY0uW_@Yz5$- z0r)roe_-axZDyYQh>91e*rwuHDn3ia0u>c1K2F6)s5nW*FM&ViBaE!*%pt4P&)@GU~xg=rLf4kvL>z$5T99DyEB zC*d^;q*DOL{Hwg+jjz~eVNg9^t)HzlR>n|P0a*YGl+9+_-ywsR^MPf0Xt&WGFN}=Q zdHOiYDNGKwVpOEeeXeFXKhSt2_<%4c%X!pz;9d>z>==y>#3TM2$iCtoR7_R2)YOg> zo6{`SlygP8AI0EMJY6y@H7N4GDCV2{$Gr)jMcT(Sh2WRWIyFF-76PSr0;L^QNu%`J zfl>$ZyADx6>iO=OZW&qM!ZNTgV;EShC?4-tVaf3Vd^4HsQ4s3ds1itbD_y6%jOx?y zNgkUGP zLN1|S-b3fAZC7eLE2~b^Zg-kaOX{>bcCEIC9<*IYg6u~!TE^1UB0DnVqTgdNd7(3n zl`||DFti_K&%w>gg*zFjp0Mj3ySavG@e~VM2pAJr9?Z*_m&&P*1klnGfsQ@hmLCsW28}8Z^3@ zZo~KZMjFJI8;x03Mx4^2jA6`y+EqM$h|JSyusBSkt9~!ydt)!yWxHK%)LUSo-2l0f zth^{|8ry9o@4Q$oH(=cpz#GUS+}X5@7WCg33@j_V2=_4*fJ+reu{JNme)K#TGE5Do z3yszo6Y?7_yVbhw_wc^wyjZTbtM&FS7nqH!?EO01mMyQb_x1m_4U`ctc6hM=)Boiq z;sO&5@V$&`w(W@cNqOC zCIb!4MC9rc< b03Hg`$pZoZAaLR4b8iEaA7ikeY;AoCk@oQ? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST new file mode 100644 index 00000000..972abdf6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDADAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 22 ,1986 ;; ;; Last Updadate: July 22 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdadar.test ;; ;; ;; Syntax: CDADAR LIST ;; ;; Function Description: (CDADAR LIST) is equivalent to (CDR (CAR (CDR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdadar list) elm)) ((or cons string) (equal (cdadar list) elm)) (t (eq (cdadar list) elm)) ) ) (do-test "test cdadar0" (prog1 (and (mac '((30 (1)) 2 ) ()) (mac '((((u)) ((1 . 2) 3 . 4)) a) '(3 . 4)) (mac '((10 (( 1 2 3 4) 5) 6) 7 8 9) '(5)) (mac '(((0 z) ( 1 a) (2 b)) (3 c)) '(a)) (mac '(("e" ( ((a)) (( b))) ((c)) d)) '((( b)))) (mac '(('foo0 (foo bar) (foo1 . bar1)) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '((nil ((((((((( t ))))))))))) () ) (mac '( ("china" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient)))) '("vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\% (#\F) #\o) "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '(("bomb" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties)) (in the daday time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdadar1" (progn (setq a (list (list #'stringp (list #'null #'identity)) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdadar a)) (mapcar #'cdadar '( ((5 ())) (("hi" (1 2) 3) 4) ((#\@ (#\a #\b #\c)) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdadar2" (let ((aa '((0 (1 (2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (12 (13 14)))))))))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdadar aa) '((2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (12 (13 14)))))))))))))) (equal (cdadar (cdadar aa)) '(( 4 (5 (6 (7 (8 (9 (10 (11 (12 (13 14))))))))) ))) (equal (cdadar (cdadar (cdadar aa))) '((6 (7 (8 (9 (10 (11 (12 (13 14)))))))))) (equal (cdadar (cdadar (cdadar (cdadar aa)))) '((8 (9 (10 (11 (12 (13 14)))))))) (equal (cdadar (cdadar (cdadar (cdadar (cdadar aa))))) '((10 (11 (12 (13 14)))))) (equal (cdadar (cdadar (cdadar (cdadar (cdadar (cdadar aa)))))) '((12 (13 14)))) (equal (cdadar (cdadar (cdadar (cdadar (cdadar (cdadar (cdadar aa))))))) '(14)) ) ) ) (do-test "test cdadar3" (progn (setq aa '((Q (a b) c) d )) (and (setf (cdadar aa) '((8 (88 99 77))) ) (equal aa `((Q ( a (8 (88 99 77)) ) c) d )) (setf (cdadar (cdadar aa)) '((9 (3 6)) 9)) (equal aa `((Q ( a (8 (88 (9 (3 6)) 9)) ) c) d )) (setf (cdadar (cdadar (cdadar aa))) "magic kingdom") (equal aa `((Q ( a (8 (88 (9 (3 . "magic kingdom")) 9)) ) c) d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..811d414d0f830e64eac74cbef6f78c81f0197b9c GIT binary patch literal 3392 zcmb^!O>EoN`H|F*ZLz5w2+68?DdRO=r$(9OI76BiTNs+Mm`bEeQI%a_2pEYDh02nl zpE};K)Juk9SXr%(vX*aMhn;#Th9WR}SlYqHP@o%zV22)tVTT=u9d-yXVAy~H-uFF9 zv16~;4vi&!@B9CI?|UyBB)XvFC8fE%QmZ>HsoCwUbUV^gvn92g-B!hsmVhpOS20ZW zdpTKo?$k4xvEm+1rRCTirz%-pr(LzzPD+_6sbH^3nWxX5Jt<9}J~#99xlHENSXM6P z16xClvQupgbuxQ&ra=DOG^p&nqAXw9ffnEOREENh`DR?5s(C27ZNttlW2nLjId1BcG0M)Yjd%&htFS%R6!T zSMtY%+|f3)8#xGhK))Lg`1j(3iaa4a4M7ZkpZC2`UIR;>pymtQmm#ER(K0oCZk|i{ zKk>rIoF@c|5xWj*TUdz?-H$GEcN*kxzrM(qCz9h_7^&_|2x>5?(L)h zwZ9u~ycQ?C2zz=Wr5O6GhUYMyll9rWYNjt}K+)%lDLzIMd=$Q6_=e!nji(gZQgUfi zwMr%&R)wARNO7@fsRf=pC}9~XdPEol1~1DrCLE#(;bAyehf=C(8fMxkS@R_;CB#8O zOv(CUn$e3X$_e8@<3I^!$jts3G8QI;o!a$B@g#17$w<~P3$lgiJD{1^%}bGsYG9Wh zL3W5f27tRqB?OxR_VWN+MN0*FUXe{?N`O9GTr6BL^6BBcLVA);B1i<_PyoUVkevYh zI{^O(z^BX$*gVQXV59|D@vx?g4Eqn33rc6s@Qt^#c|H`6csBenB693aI@1 zz8CE_UTQQ~8;HK=dt%3Fccew}2+$WsU-WPBf;YBoUx88fQmt{N+FTw*IVBLErEGdH`TJzh zvI!RG*Xh)Q_WHaK8KpDy42tA{2R;}L@w59?goR3BD16HA3m6vCP)%P*!_ErLizbgyGIy zsx^F%cWWTa@d8|_c&qlF?VShdo{j2Elj~J`PHzcKJqdSqq+UJ$$2jr5N9*?T<*JSC zK5*P&PjQ1w8r}lj0^kG;kUt+tiu{2kMSlNaC8kjN6P6Tt70c%xU#)dqspBlKI4!%= zZ8>eJ+wR)+`Wi;iaUBUVjApg0rKv@>W5{*C9|2-yuB2JAiGwM0xw(9qWd#AJH67f-;k9xqpkaIt zEiy{T(h4fN0w#=c+`k=&Z+hyhZPb%3w)exjHkX4X1O@M_aHmzP*Lx?hP1#-(n%B&L z&Qh~Ejh5hpJvNNfpnD59CL%L57A(%t*oxne`rhcvcE#@0nvFJC=rlntl9S7_rZJb1 zf^)T2X~McMKuAzic;abUEjWy$Fw?AD8J=$_fIjI}@I^ad#4t4&J~URx0z+6W2Qms* z+*-qC;g2|1E45Co0n~jVQ0(?=?AK#%+46Pv+xt8>tdH=nv<%qOxamLd^ZiBSfaC?- z1SJ;BXuBz`x^_qU7CT>qT1{b6SU3R+2L~O)dT+Os8CFWL0t@DBSmSBHp~%3&6 zpze(U6&nJ_7)h|1S(`u>I>W3$;6p>uqk#&n@949AmfnFv88LA8* z%sj{l=+B@+pTE8X|G*@NyROgUe*m}_*^=qcml>test>15-1-cdaddr.test ;; ;; ;; Syntax: CDADDR LIST ;; ;; Function Description: (CDADDR LIST) is equivalent to (CDR (CAR (CDR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaddr list) elm)) ((or cons string) (equal (cdaddr list) elm)) (t (eq (cdaddr list) elm)) ) ) (do-test "test cdaddr0" (prog1 (and (mac '(333 30 (1) 2 ) ()) (mac '((w) ((u)) ((1 . 2) 3 . 4) a) '(3 . 4)) (mac '(-10.0 10 (( 1 2 3 4) 5) 6 7 8 9) '(5)) (mac '((-1 y) (0 z) ( 1 a) (2 b) (3 c)) '(a)) (mac '("ha!" "e" ( ((a)) (( b))) ((c)) d) '((( b)))) (mac '("so what ?" 'foo0 (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '(toe nil ((((((((( t )))))))))) () ) (mac '("fret" "china" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '( "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '("trill" #\% (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '(guitar "bomb" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the daddy time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdaddr1" (progn (setq a (list #'string-upcase #'stringp (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaddr a)) (mapcar #'cdaddr '( (five 5 ()) ("fin" "hi" (1 2) 3 4) ((#\<) #\@ (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdaddr2" (let ((aa '(0 01 (1 2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdaddr aa) '(2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14)))))))) (equal (cdaddr (cdaddr aa)) '( 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14))))) )) (equal (cdaddr (cdaddr (cdaddr aa))) '(6 67 (7 8 89 (9 10 101 (11 12 123 (13 14)))))) (equal (cdaddr (cdaddr (cdaddr (cdaddr aa)))) '(8 89 (9 10 101 (11 12 123 (13 14))))) (equal (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr aa))))) ' (10 101 (11 12 123 (13 14)))) (equal (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr aa)))))) '(12 123 (13 14))) (equal (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr aa))))))) '(14)) ) ) ) (do-test "test cdaddr3" (progn (setq aa '(Q p (a b) c d )) (and (setf (cdaddr aa) '(8 08 (88 99 77)) ) (equal aa `(Q p ( a 8 08 (88 99 77) ) c d )) (setf (cdaddr (cdaddr aa)) '(9 90 (3 6) 9)) (equal aa `(Q p ( a 8 08 (88 9 90 (3 6) 9) ) c d )) (setf (cdaddr (cdaddr (cdaddr aa))) "magic kingdom") (equal aa `(Q p ( a 8 08 (88 9 90 (3 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..30251c7f521f588b5da0bdf92cc31ee62fc752c9 GIT binary patch literal 3201 zcmb_eU5p#m6}~gGws+S~@FuIIF-sVh1gIOY)|;gwfJ7#<<9HH#W*Lw1Zlx-n*s~c6 z?|ADU!U_mW0%=93hRud#E&%~TJRl(vA|42!>_a6as;Cc@TB()t+`ctZq*hfcZO^%5 zCr(n-KA>ICx##aY=bn4dy?2#F=H#3x*B6(nHM=3!+pVQ`OI)Zo#AdzSDBI!!$i)|A z-B4c2O7h`}C(^@(K25n{TP?dHnr*vTv6lCU=}9qfEsN=Wk3F_WoZ9>N^uEW_>51Wt zRLBKbJ&%%IaeF@LKA%aj2d|0Yjd%TXT)a*QDU)?1LxjYMK>RaaJZUNgGnG+uN=lRR zO448Ty+N2ss#s7A-y4|{TlJ+>&3?|V;baz@gd@a%(;LhbHQ7{k&0phIxS0Qjw@KAf zvoJB~phEb;E()S^zPBm;XeynOXQUZ}yaQo{yd>X@gf{*;G9m4auU1!_bNhLYmp0}@|9f0`$8t;1pITc_$LCNL0F-Rv;Fb!2ZILmGI z-||AJoFxPb5j_cRpJElhbiO*oU3SS|zdpp5#u6i32&K*@LN2|GBm5z=)X!M`jM2}? z{me8n4C;}7@s6JOLZ5WSx%2OYUaN@f;+zdhrLP zojnYsF+$d>Wsxm!cVgUnZ(!d2VOIo?O-9vN9iaZfnNxI1JGh4Nm(-GY|2o~ zq5+*Lv(^q5<_o5h=efHrOg%}r3B#b^C5c9b&2&__2O4Q}QZWqONa;m$wrD1WI9SAz zk~W`W@x9zGD0>2^3QWIIE9M$u-`VFWlKuWC4svavLW;}DG5SqBXH zH!y?hjG~#UIgf(BqgE^CFavU(jv)D*1tXuZDCB**>qj8v-}Ajl+kMupA9sK?1q7l+VF1}h*ll%2yR{|*}j%m4tL=*L>)h42uaqAaZ^K{EtL zK8Vm74EwBwxpKZ|xC@LR85E)6j;W=-GQ%%K? zas|2#&0xu&F6yQdEa5*WR+GDNTluC?^f#J9@)-lCGvG?QJ|6`>AKd1XM&ow_pPxh4 zD{!&#;M6(VDWhr{WWa_%KHz)2Qw4_O1-So&&VKw@XvvJYPNida7SL-PF4l0Zvj2~9 z;(Pbjti_`h3)k?jE`@!_5k-<3Z39ZR45_O|pV(fAvdJ~<7k`Q8J^ zt1U-t*^5hd!)mn~c2jIO+g7c%j0v7GHS+Dl>*xi=e+iEQ1t?wnOw;;YhUJhyM!7L0Rr$}cvn0GRrI;>DV4YmvQ z`V=C-KOkpxeJ}W&#l42iG>ry>M`?5k+PDX!?N?E4yv$A+ib_ZQ!V59`L`&i$_cSLRUz55NPGL8C>SGxkNd9+Q|j z7Ds^MK!0KeAKWTenw1MYVZZ|P>No{F6cRKz0tA@)i(Ls8974Pt#6=sZI`f7kdjL@X zt~rcyJuOG2EbBJT4nPriEYMP^OW{;{ipifq(={Gn)!a{5P-e{YXvzz83O7Osj;rt{ zhBkoR8wy7Thj!y(Iq*Qxy9f&iML;+!fC8=P*mh9v1QoosZf{8PHWumH#>RgDAb!ov literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST new file mode 100644 index 00000000..90abcdcb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Updadte: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdadr.test ;; ;; ;; Syntax: CDADR LIST ;; ;; Function Description: (CDADR LIST) is equivalent to (CDR (CAR (CDR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdadr list) elm)) ((or cons string) (equal (cdadr list) elm)) (t (eq (cdadr list) elm)) ) ) (do-test "test cdadr0" (prog1 (and (mac '(30 (1) 2 ) ()) (mac '(((u)) ((1 . 2) 3 . 4) a) '(3 . 4)) (mac '(10 (( 1 2 3 4) 5) 6 7 8 9) '(5)) (mac '((0 z) ( 1 a) (2 b) (3 c)) '(a)) (mac '("e" ( ((a)) (( b))) ((c)) d) '((( b)))) (mac '('foo0 (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '(nil ((((((((( t )))))))))) () ) (mac '( "china" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '(#\% (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '("bomb" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the dady time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdadr1" (progn (setq a (list #'stringp (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdadr a)) (mapcar #'cdadr '( (5 ()) ("hi" (1 2) 3 4) (#\@ (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdadr2" (let ((aa '(0 (1 2 (3 4 (5 6 (7 8 (9 10 (11 12 (13 14))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdadr aa) '(2 (3 4 (5 6 (7 8 (9 10 (11 12 (13 14)))))))) (equal (cdadr (cdadr aa)) '( 4 (5 6 (7 8 (9 10 (11 12 (13 14))))) )) (equal (cdadr (cdadr (cdadr aa))) '(6 (7 8 (9 10 (11 12 (13 14)))))) (equal (cdadr (cdadr (cdadr (cdadr aa)))) '(8 (9 10 (11 12 (13 14))))) (equal (cdadr (cdadr (cdadr (cdadr (cdadr aa))))) '(10 (11 12 (13 14)))) (equal (cdadr (cdadr (cdadr (cdadr (cdadr (cdadr aa)))))) '(12 (13 14))) (equal (cdadr (cdadr (cdadr (cdadr (cdadr (cdadr (cdadr aa))))))) '(14)) ) ) ) (do-test "test cdadr3" (progn (setq aa '(Q (a b) c d )) (and (setf (cdadr aa) '(8 (88 99 77)) ) (equal aa `(Q ( a 8 (88 99 77) ) c d )) (setf (cdadr (cdadr aa)) '(9 (3 6) 9)) (equal aa `(Q ( a 8 (88 9 (3 6) 9) ) c d )) (setf (cdadr (cdadr (cdadr aa))) "magic kingdom") (equal aa `(Q ( a 8 (88 9 (3 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3d2928281453854e1b1dda5657d73e775cdd176 GIT binary patch literal 3160 zcmb^zO>Em#_&vKx+9uo5QVj?dGaKV4%wy?VG{ym3*IC>pc5z&~9?;|^?h=tEU49q^ zG0KqmlPT+3zz>EriOUWg#)J?9v?3vKKobXqK;pm=Ar5E)2?;Lc`<@#bHYPZr#Qy$& z-}|255{VpAvyxhyohw(|x>Rd5=UPo^rdF34wN}00N;ANho>EOqdpe`22X{Y^>dkjZ z3U$|Mx<$!uxs9STze`H(k#f$wl)8W4zFpGL-u=V(?@y(6_okJ6Ht^N9m~xBNwoR(T zX3zfA(EilO?%uVx{nu%{MhGd8RRleR#ED4!(_TDjYk6Bv>sd`Ul$@6Imwc}qDv>Ai zn&o?aLsGLgCs*9Z-3k^n+aQz>|CHCAo-|ZjHw}N8F3_0&s<%luqYY$ODS&J(lDxVQ@QD4%Z%RsuE zdpVA>D{;bN0wDtHg4q7D;Co$J9ejAAmd(*yAeBhowshmb1nu`<^Fk<`AOxBaJqc## zumc~JJ|3qRtK`Q|#)YZDL>~6N0A;2CFZrDz=)DEzO>^U>sFG&*A)Z z-qvygy;j3ElWeQl3j#q=SXA812E;8eL7S7BWto<2PTCWbc2bOkMl7iq(=zAhlZ=Xe zz@uOUr^N8pr$ldv5I&y^37okz;4+*xt(;;b`2tuDY}BPHc`fkEwxW0kX!qolgPM$^ z3mp0j+lJtKCLuT*P+mZ}=sTxOsEUQc0U)>Jr*orbR&JkB$luI%Am|Q&zybL^0KW#{ zEAE$E;(p1?EOvs$nk;sd#U5p`2^LdX>^>H|o5coM>;`ZqJPolzydg-n;8+YBSY#H- zGTVt@5V%`(16EMU%34;-X$CLpYj!(`>1D1(KMlaifca!VRRhq+qdcM+6KD_xO3dj7 z;vtSJhX5yQfb(+@iQj0JzA{I_FR__+ewA(1YnHuqk6)>$`;cY{hR+~K@0~TImSlVeWnxNz>MXh5VVx;F|u_*~=m1{J`!-aE|+CI#{ytz~oF|0;{pn{uJu21STa& za{)elSl;51#R7_g`Y5oW^8yt_tPzMs2Q@gCE*2Nv#TnEdgs*M5Qhex}IPtw(D$eYY zqJ!&r%@D&@q3a)6_=eL%Kof94zPl!C@+Hrje9@Wp9@PDuXHA~RguL61mzyQ2>CVo% zb*I^?yA7$;XgQV2JjQR9TnXA7N$Y7_*YbP|kdyv06oX~?-d5B&4%eg-T(H1k+^M#l z`aIqOyhM4!SE1rMb;+p~rADh-o&PU!8MGA-P(e3f2f~Ee84XBrOqu3%m#ybC3Vo~r{FZpwQ2)AG;5$2&L~rguJb_Qoclz%Py-wW?HC9naP!jB zdN4jca0uC%DY#dm0>)%5h{cY96VuY+RAA8x7vMF`eWFlqmaENcVlrI67x?={9*3hZ z@%PKu^Lr!^T<`rXoDSFlaa6HbbdvW8n;=3HVB|33I~#3D@wR{}AlzfSUqieLT_8aW z_c~?IfE(msV_}@o6>J{fZs0{HxdNCeZb4TS{3vv%cYi*1wkrPy-C&2@K?d$VPCLL%aRu5KpTMhcOh6bocDUqp<5Xcml>test>15-1-cdar.test ;; ;; ;; Syntax: CDAR LIST ;; ;; Function Description: If the first element of LIST is a list, CAAR returns the second element of the sublist. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdar list) elm)) ((or cons string) (equal (cdar list) elm)) (t (eq (cdar list) elm)) ) ) (do-test "test cdar0" (prog1 (and (mac '((1) 2 ) ()) (mac '(((1 . 2) 3 . 4) a) '(3 . 4)) (mac '((( 1 2 3 4) 5) 6 7 8 9) '(5)) (mac '(( 1 a) (2 b) (3 c)) '(a)) (mac '(( ((a)) (( b))) ((c)) d) '((( b)))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '(((((((((( t )))))))))) () ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdar1" (progn (setq a (list (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdar a)) (mapcar #'cdar '( (()) ((1 2) 3 4) ((#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdar2" (let ((aa '((1 (3 (5 (7 (9 (11 (13 14))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdar aa) '((3 (5 (7 (9 (11 (13 14)))))))) (equal (cdar (cdar aa)) '( (5 (7 (9 (11 (13 14))))) )) (equal (cdar (cdar (cdar aa))) '((7 (9 (11 (13 14)))))) (equal (cdar (cdar (cdar (cdar aa)))) '((9 (11 (13 14))))) (equal (cdar (cdar (cdar (cdar (cdar aa))))) '((11 (13 14)))) (equal (cdar (cdar (cdar (cdar (cdar (cdar aa)))))) '((13 14))) (equal (cdar (cdar (cdar (cdar (cdar (cdar (cdar aa))))))) '(14)) ) ) ) (do-test "test cdar3" (progn (setq aa '((a b) c d )) (and (setf (cdar aa) (make-list 2 :initial-element '(2 4))) (equal aa `(( a (2 4) (2 4)) c d )) (setf (cdar (cdar aa)) '((3 6) 9)) (equal aa `(( a (2 (3 6) 9) (2 (3 6) 9)) c d )) (setf (cdar (cdar (cdar aa))) "magic kingdom") (equal aa `(( a (2 (3 . "magic kingdom") 9) (2 (3 . "magic kingdom") 9)) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c4b575c1265aab7c031861c1f5ed306a3ffbc5dc GIT binary patch literal 3342 zcmb_eO>7%Q6rSC6>?B@Vr?Ofa0$oDOk6TBz(+V0S$i`X6TkPFnZ*YSU)z)@ntBGCt zr)|WK(()sIwgx9D-JzgLAjE-7sX$Ob&4Cj?7laUS;D`_hBoHTrN_cP9+qfx+3yF7U z-rqOx&3p4^Tf}!DmXuPH)O>2Reg)hdl@t{@!-zVuj3Pb*I(hNzvhvJ^Mx?k)htWoJl%Zu0^(x zFS|C84x8O0k?6?qzMuhK!p&JBP%%c5E38)u@|jC$WSsyIIbp@uqLOJklnJa zZipm2l~K~R)fbiOm80R=!m+|E1~XS993l40R(E_#iy5k}*-P94C)zJrH>g^85(1Ma z6vB76Q4pQ8Eq`QhI1-MHkIQnJyawwEDLHm^DO9pwArW~v&?+qy&yI2&&&#U;`9t|r zLN2K-^{E87+~$87aOA%R2o-rkc?Pi|JV_OhEI~=8xSPQxU&ctQ+QcLmw9i;w zD4Zk&Hp71k%-+GB_^9~te(qA4{Qk*)K0DCg$8{kWpBo5y<6ZJ>2YK;WCo$7W9Oxv} zPGY2!*x5-8bP(q{<_pF3{~yl~vgwpB$Q3VL)?of?>w(i6>`bfpthS%$z|+=+8?(2# z7&wZAtdw#R%XT|P?tM2#A7H?KI&akOr2FBo2>-dkmFyrUf4&vwZV6p$;CQ#P+%NM=_*URP)s&riEvsmrqXaSW9(>q zGt(JEN%7qE8ipRCn}uEw@Ul$(!Uh@?Ho_s=5K_`97g+ zQeG;Rol6CIPwqgqN3f;hPoM*=D8?Ya*l0b?nPwGd%Yxvwdgsg;=rl)4<(YhCt_KSt z28u9@Q`ToQ_BtH|zrO>V?z$Fs31GW>Xq4_j&Am($mStSz?D!YkW~o_rt!`qFuCpjX z%Z=Asf{zeW+l2eWK8NB(>y}trkqsrht}2tNp`_(xhHgeRsDuZnbVG46`wP7b@VTF_ z-R&syexy5bc$=Zq6xdSDF*@fMtxHh^wU->D8HoDS>gwth;ptJxI7;pU*45Y`F_;ki zQPt6O86IvyaPCF62_~%DJk-oF9C*F?ErR*r*6kbRJ{;w_O9}PL@2x~Y4G`P9Y1W)O zlsB;`t~<^=*tKt5xY)S^;1@bZe!MO~@;wWXd~@xt>_+XcSb(I3?k-xsxEeQ9CBq7a zoQ4u(VL+g8sc)_q3(|4;I4Z(t6?nAYEH}*RJZf0|rJB^JHO$%Bc_}wrFsqVT&P%mM zxjb)Mw;nImi&DKXceGG7>y2t*O&4Ggl~!;mXn3jyCHs;k7zqVPVO*YOw8v0W3N8d9 zXtw(r}B(m^ng$iuFCjg($1Bjkhq3uwA-Srkf*9s?crFyAcx2>LIX3ngaD&-nm zmif8J-b-vLHeF`#GyevC1O>21MwI%YjMy-zaL2pmS-leZqljj(#}gguE! zL((C$8o~1={PZv@4c=bHtO>ABY$Jp*ISrG4GGHsan+mRgnFq9Sh6!wIz06FTlP9Y?y;pRvttW> zPPel03&*6b2t5$0Zf&0cn9EZCXd7@z;9M-wV)oyGh(};vpwYWw@cM>X;Qcml>test>15-1-cddaar.test ;; ;; ;; Syntax: CDDAAR LIST ;; ;; Function Description: CDDAAR is equivalent to (CDR (CDR (CAR (CAR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddaar list) elm)) ((or cons string) (equal (cddaar list) elm)) (t (eq (cddaar list) elm)) ) ) (do-test "test cddaar0" (prog1 (and (mac '(((1 ((9)) "hi") 2 )) '("hi")) (mac '((((1 . 2) 3 (4 . 4) 6 7) a)) '((4 . 4) 6 7)) (mac '(((( 1 2 3 4) 5 6 7)) 8 9) '(6 7)) (mac '((( 1 a (((w)))) (2 b)) (3 c)) '((((w))))) (mac '((( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c))) d) '((ab ba aa .bb) #\a #\b . #\c)) (mac '(((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '("(foo1 . bar1)" . 999)) (mac '((((((((((( t )))))))) t1 t2))) '(t2) ) (mac '( (("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient)))) '("to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '(((#\F #\o ((foo3)) )"o1" "foo2") (foo4 . foo5)) '(((foo3))) ) (mac '(((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties)) (in the day time) (and ) (the "20's" at night)) '(fifties) ) )) ) (do-test "test cddaar1" (progn (setq a (list (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity)))) (equal (mapcar (first (cddaar a)) (mapcar #'cddaar '( (((a (((b))) 3 -3 ))) (((1 nil 3 4))) (((#\a (#\b #\c) 2.0 2.01))) ))) '(-3 3 2.0 )) ) ) (do-test "test cddaar2" (let ((aa '(((1 2 ((3 4 ((5 6 ((7 8 ((9 10 ((11 12 ((13 14)) ) ) )) )) ))) ))) ))) (and (equal (cddaar aa) '(((3 4 ((5 6 ((7 8 ((9 10 ((11 12 ((13 14)) ) )) )) ))) ))) ) (equal (cddaar (cddaar aa)) '(((5 6 ((7 8 ((9 10 ((11 12 ((13 14)) ) )) ))) ))) ) (equal (cddaar (cddaar (cddaar aa))) '(((7 8 ((9 10 ((11 12 ((13 14)) )) )) ))) ) (equal (cddaar (cddaar (cddaar (cddaar aa)))) '(((9 10 ((11 12 ((13 14)) )) ))) ) (equal (cddaar (cddaar (cddaar (cddaar (cddaar aa))))) '(((11 12 ((13 14)) ))) ) (equal (cddaar (cddaar (cddaar (cddaar (cddaar (cddaar aa)))))) '(((13 14))) ) ) ) ) (do-test "test cddaar3" (progn (setq aa '(((a ab b) c) d )) (and (setf (cddaar aa) '((( #\g #\r #\i #\n))) ) (equal aa `((( a ab (( #\g #\r #\i #\n)) ) c) d )) (setf (cddaar (cddaar aa)) '(((3 6 8)) 9)) (equal aa `((( a ab (( #\g #\r ((3 6 8)) 9)) ) c) d )) (setf (cddaar (cddaar (cddaar aa))) "magic kingdom") (equal aa `((( a ab (( #\g #\r ((3 6 . "magic kingdom")) 9)) ) c) d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..aebb80cafe34b47ea3d237f49d603301aa2bd552 GIT binary patch literal 3408 zcmb_eOKcm*8J^wcLlWtP5>z{8RC}vDn$o7Kl^n#8fmSPWDXv2<6>=F`In-E_w8&cG z3gptZk~C0kH)z^59g2>#lcYH~w-hK`Ut%|f1vI@B2#WU5*P&=HMSJMMKyqsX_Wx%| znUPcU5{bJr|LdFoG4s#1iT^|_CC1FP_3CQ5E}Bhiy=jT3&AQkyoAqK@JPmyD#aJe* zd@m`-o|!r(jpPO-#d_JW$|X^6mK!BwjSHECkRsW}VVIB*5s0&8ha$R?)1wJBr9?G3 ztwfx*V-G-JD0uf=pVqd6UJlM6am>^-U$ zU4p>mMTPJ~JrqRe96KOA8I_{3cwCNW$vd#Fkd|XROQDi;jY#rrs9oKxygAQvJTG@c z@-6uzLT;;V^VMV zr9+%kQZ1KSL8P?26qBH5z=022C0~MT2=7Ow!;n8l0lRgESZdIe!sW@UozhdJ!6-Ps2b`NSgFf z7`Q*sM{xL!Oa0OvF1gH?Tx#7Nz5-}NYFyEDRbNIMOtx2fPSKW-@&XmWt`$uw+M=EW z9_a$lqvcb$AlYW1n@u*71iWR&W&$h+p) z2X*94zAR6QrwzE8N@BI<-Ydv^`7u;G>2z=(aSD{RUpL2HUAo>Dg9%jHaIsn-L$f02>(HYb_>U0F? z?u>`@6T7WE=t!&Ds`V`nz+HfFI|4Kt>zN63f=1CZ2%~4f{l|G5ua7PJKrE}sx)R;B z8B?mRWaU(j?nO1I(6jlBuDAugOTPi|+`m4bWb~Z-Cq0D2`wX4Nz?Q~cqjz1SU6qkg z`FuQY*(dE}NDUFket6YbJ5@4pKiqecd9drfc*Wwc*&nxyyW+vPtr7M|Bl5=+8D={?N6u)T~%^y*O1Gw%fNFQ z2gy(lPKlz$*j8kDu=iS(vUm=@nkw+U1*cy(HS6Vjx&VWyv;=8`Re4o|R9~?LJ*faG#N}m1dvrCe z;6fmRHjI1AgwKze>904?O4ix#_iE~55~djE_fgyZZP}hgCNt~uUtuv~?B29`LV@!F zWo{*K|FXiq;Mlw=0rqLroN=z=E=B7jG~iC2q=EBJ#|K)L2{K<&F376NmiML0=c`4N zA%c65UHCjx6RLYOhoNuj$pU`N8Rkc>jb4~|8>dNPf zRjXRF9DDezQ8cWoS!=MxDMtAkd;btZpeCFCh`sIqwZIt^K*IDH8d$-_a6ZjEc1`Yo zzru7RIK8;wJKw>a*dtFsdL(g5JZ01+Jdnaap2w`fiMe8Pc;1D?G~hzN!mnAzDL~(Z4T(0rA2hoH4WJ$P zNho}=3mo+FzMMh)7DPM+9bTZ)Q!x1avtYn7$qYRlFL=B@|Ily*vwD^HczpiHaoXXE zxQDO8r%|6zCmu$4o3B*&p$cs7cs`xRv%{J>dN$0&@D+l+cc(j&w=j>NcDw%tAx0R7 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST new file mode 100644 index 00000000..985e174d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddadr.test ;; ;; ;; Syntax: CDDADR LIST ;; ;; Function Description: CDDADR is equivalent to (CDR (CDR (CAR (CDR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddadr list) elm)) ((or cons string) (equal (cddadr list) elm)) (t (eq (cddadr list) elm)) ) ) (do-test "test cddadr0" (prog1 (and (mac '(dummy (1 ((9)) "hi") 2 ) '("hi")) (mac '((99) ((1 . 2) 3 (4 . 4) 6 7) a) '((4 . 4) 6 7)) (mac '(999 (( 1 2 3 4) 5 6 7) 8 9) '(6 7)) (mac '((0 z) ( 1 a (((w)))) (2 b) (3 c)) '((((w))))) (mac '(1 ( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c)) d) '((ab ba aa .bb) #\a #\b . #\c)) (mac '((- f00 1) (foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '("(foo1 . bar1)" . 999)) (mac '(t0 ((((((((( t )))))))) t1 t2)) '(t2) ) (mac '("title:" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((mixed) (#\F #\o ((foo3)) )"o1" "foo2" (foo4 . foo5)) '(((foo3))) ) (mac '('sentence (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(fifties) ) )) ) (do-test "test cddadr1" (progn (setq a (list "# 1" (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity))) (equal (mapcar (first (cddadr a)) (mapcar #'cddadr '( (z (a (((b))) 3 -3 )) (0 (1 nil 3 4)) (1.999 (#\a (#\b #\c) 2.0 2.01)) ))) '(-3 3 2.0 )) ) ) (do-test "test cddadr2" (let ((aa '(0 (1 2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) ) ) ) )) )) (and (equal (cddadr aa) '(23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) ) ) )) ) (equal (cddadr (cddadr aa)) '(45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) ) )) ) (equal (cddadr (cddadr (cddadr aa))) '(67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) )) ) (equal (cddadr (cddadr (cddadr (cddadr aa)))) '(89 (9 10 101 (11 12 123 (13 14) ) )) ) (equal (cddadr (cddadr (cddadr (cddadr (cddadr aa))))) '(101 (11 12 123 (13 14) )) ) (equal (cddadr (cddadr (cddadr (cddadr (cddadr (cddadr aa)))))) '(123 (13 14)) ) ) ) ) (do-test "test cddadr3" (progn (setq aa '(e (a ab b) c d )) (and (setf (cddadr aa) '(#\o ( #\g #\r #\i #\n)) ) (equal aa `(e ( a ab #\o ( #\g #\r #\i #\n) ) c d )) (setf (cddadr (cddadr aa)) '(1 (3 6 8) 9)) (equal aa `(e ( a ab #\o ( #\g #\r 1 (3 6 8) 9) ) c d )) (setf (cddadr (cddadr (cddadr aa))) "magic kingdom") (equal aa `(e ( a ab #\o ( #\g #\r 1 (3 6 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1a41d872add8845db7f03382362aa4da7384154 GIT binary patch literal 3240 zcmb_ePjC}e7=OE)CT$ZS#STcVvR3>TNv3IGgnF>sbki&(yLGcQ)PuN9LKA2cCVzmA z%2YtqnI(|6z&_D~deaMX5yYVfopGFT#_`}d96Wen91qSg!+3JAe&5>!0%gVvZFb-L z{{7zfeeZqW+dA>=iNwW7arR(-CR-AV)ylzYMch{`iREIol+KF#fG@ro(RBIkm=xI^ zdMVtQY>}i(S+kPOh(P{%$;LeikWo}bU18|HXkTJcMlrEdwj zqSTe+F>u&n|LAAZn|?xlJRv-F!TRn z69S3w9s{#aFbiMjuI}Ql6v(Y_cJZm+o-VEpx%jLhpHTjP>_;*C-8?J~+0$ zfrzG#Dp+R0n52%zWj#2e07o5526!*+<~{JV!Q+CW>Iy_8BN7YhvN54UEk;-|yOWbi zLr(DAY7IjR&<#Q-2zW`NUSTcm7S=)OtPRMzuIWK-!Wf@00)ihjd;v+F3^IN)Kslic zcpMl(i`aI5i|A}4gcaueMl80o0O^iudO|XgoCnM9yKzONr0n3*4It+JqMLEJPDLCp zIMjO%^#&p(r16NPqp%yub;-%Zh!zhv+Y$2D(motqY#{$S!*2|U{J@aNS?U87@&Wa| zMSVr;o1(r6>Wfj|OVk&lzRlF<2RVNTR%l~EBUOOD=TK#W zrz-Y+I*7TWiAlFM(G~%%y@U4CFe-$wc{?m5#Z~&Xe67$_-oTnYa|+pL08Tni!vf$7 zc->Iu{;))^bQanikmB)>EWkNG#XW#y$&jUDjv)mjkG|}v zIl*%Cf^)~YY9_2!o2sRmIlMmm6)`+;cXkbPmxp=oN=&(Zs~+@bj15E6?G zZsrY@Tvj{`UpG1UE&^|MnT4uZnnN?ICtnt;<*GR|Gbg5JvSvv%3mLIoEfnT#>&e6U zN=~d~XAfpeW~Exn-qi&dM5T}tY<;|K`Hc|UwA z4D>%+Mk~o+C%8>j#$qtVpx$L!XFIWAxuTjj=a8#Ver08kr1O=0p<-Jdhs?BD$rlS{wkE}JjZz#;W%_OfL)thYKyejw!G@pMz|K#gI5L@DYWW(6Q{O(0NV#@~V8JfiXf?SBylw`Y*4qIVoGxZ2#F_KpDag?G8!9_SJf rIwTQ3IKV%~qrH#ek`|xKZ)9Sjv3>{R!F7+_?@ogvAL1t6SXucGp*P`L literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST new file mode 100644 index 00000000..cd616524 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddar.test ;; ;; ;; Syntax: CDDAR LIST ;; ;; Function Description: CDDAR is equivalent to (CDR (CDR (CAR LIST))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddar list) elm)) ((or cons string) (equal (cddar list) elm)) (t (eq (cddar list) elm)) ) ) (do-test "test cddar0" (prog1 (and (mac '((1 ((9)) "hi") 2 ) '("hi")) (mac '(((1 . 2) 3 (4 . 4) 6 7) a) '((4 . 4) 6 7)) (mac '((( 1 2 3 4) 5 6 7) 8 9) '(6 7)) (mac '(( 1 a (((w)))) (2 b) (3 c)) '((((w))))) (mac '(( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c)) d) '((ab ba aa .bb) #\a #\b . #\c)) (mac '((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '("(foo1 . bar1)" . 999)) (mac '(((((((((( t )))))))) t1 t2)) '(t2) ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\F #\o ((foo3)) )"o1" "foo2" (foo4 . foo5)) '(((foo3))) ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(fifties) ) )) ) (do-test "test cddar1" (progn (setq a (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity))) (equal (mapcar (first (cddar a)) (mapcar #'cddar '( ((a (((b))) 3 -3 )) ((1 nil 3 4)) ((#\a (#\b #\c) 2.0 2.01)) ))) '(-3 3 2.0 )) ) ) (do-test "test cddar2" (let ((aa '((1 2 (3 4 (5 6 (7 8 (9 10 (11 12 (13 14) ) ) ) ) ) )) )) (and (equal (cddar aa) '((3 4 (5 6 (7 8 (9 10 (11 12 (13 14) ) ) ) ) )) ) (equal (cddar (cddar aa)) '((5 6 (7 8 (9 10 (11 12 (13 14) ) ) ) )) ) (equal (cddar (cddar (cddar aa))) '((7 8 (9 10 (11 12 (13 14) ) ) )) ) (equal (cddar (cddar (cddar (cddar aa)))) '((9 10 (11 12 (13 14) ) )) ) (equal (cddar (cddar (cddar (cddar (cddar aa))))) '((11 12 (13 14) )) ) (equal (cddar (cddar (cddar (cddar (cddar (cddar aa)))))) '((13 14)) ) ) ) ) (do-test "test cddar3" (progn (setq aa '((a ab b) c d )) (and (setf (cddar aa) '(( #\g #\r #\i #\n)) ) (equal aa `(( a ab ( #\g #\r #\i #\n) ) c d )) (setf (cddar (cddar aa)) '((3 6 8) 9)) (equal aa `(( a ab ( #\g #\r (3 6 8) 9) ) c d )) (setf (cddar (cddar (cddar aa))) "magic kingdom") (equal aa `(( a ab ( #\g #\r (3 6 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..94ed026dc17ae4bbce13bdfbe7ed57a77b6119fc GIT binary patch literal 3185 zcmb_eO>7&-6`tMYk0h>R${?JWRpX7~G%jTdq^zKhixyr|OL1j#S6!~k2rX)?Nm?XK zaRvUwR*M*l>;`SHWkO4JcGC8e7@va9Eu{zp=f(c4?P5E(E*lHF;qblTD-yD7EoPP0^zE&*TqQCc^Y zm$GvD{Ny*2BZYmEQnO;UD`m;-R9a&nA4amZQZVBgHK)Wi zIj_Xrp6d)jB=LoUVz|!el+?CY;`Pdll{yBq+#(zy?(5D_Wk+!`mkuQ`WQ zEj|x{$+HUKhx#ap&bdw~`CL31PtVNE$Oic(tSjW@^zKrq(6^471(I?nM2d4dF91`Nn?1$^FE!eT0j1Tyd>>@bCR4LXNBlBV6_FJq_lc_s;)JgOv2D zuV`~T2R6N}CyGxFz;F}^*{+o&R_1u^uDO=&7#q0HCh_qE{_ z?@;Z_LFC^aAd2W`DY{*ZLQptA#@|+pQRe;aZ!<2xCz%*Xq+Q9L^o_o7uXz98*_+j^ z$G@;{y=u4?CcFsybu5?8*Yiv?53^W38vrXHh5g%J?&vP?t5V>BWhhBNb6Ofd}Ii0cdH{DK)1 z!k{6>WNk6d_=Ondgi+veU;6fx;k=hYO4Ol%9(ZdJ*u+13Hewzr5jN20=bx z5Tr{*l>L~BSE+cJia(&DK}Cg%XQ((q#W5-#203p7w4X(b)Dm>NfQAv|ko+D!0R#5| zeHw@NJnCI+*dM zQ2=J#e;zV}y_^CM`xe|^-Cy7;H=QTbh9a9v{J_S`sitDcxdJ_kYEbj zB;tSiaF(Z#_Xiro;TA)uDX^t!&*)Xp=s;;OUT)np`Y!XATi@B)c>wX?&2{4(dHWMo zdBT%J!OC-1qhmE!F)$}uYe}6}$Ew#?rBc0OH6^Q2mRg-gW7Tz@x>9Rb zrFLa`rP8$8on~cE7hn(-iW_%yoA7;zHX*#d&K~KUq;tY(~zg&I=r3q zl&9QH+-WGDrXg?g91XSM0029Xm5Z{fvXuh)%GFxQhWUm7oczAPa;Obft!`;Mc2#^RS7E-bS6KCWk zq%1-?AIA$mKlZ<8K^zD^4PTZjct(JCyw4X1 f(y_-GSLo+^7z$af!PSjTY`4vjH?gvR-r4ytiYeKp literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST new file mode 100644 index 00000000..ed7b0b40 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdddar.test ;; ;; ;; Syntax: CDDDAR LIST ;; ;; Function Description: CDDDAR is equivalent to (CDR (CDR (CDR (CAR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdddar list) elm)) ((or cons string) (equal (cdddar list) elm)) (t (eq (cdddar list) elm)) ) ) (do-test "test cdddar0" (prog1 (and (mac '((1 ((9)) "hi") 2 ) '()) (mac '(((1 . 2) 3 (4 . 4) 6 7) a) '(6 7)) (mac '((( 1 2 3 4) 5 6 7) 8 9) '(7)) (mac '(( 1 a (((w))) #\w 100.01) (2 b) (3 c)) '(#\w 100.01)) (mac '(( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c)) d) '( #\a #\b . #\c)) (mac '((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 999) (mac '(((((((((( t )))))))) t1 t2 ((nil)))) '(((nil))) ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '(|HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\F #\o ((foo3)) . "foo0" )"o1" "foo2" (foo4 . foo5)) "foo0" ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) () ) )) ) (do-test "test cdddar1" (progn (setq a (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'identity))) (equal (mapcar (cdddar a) (mapcar #'cdddar '( ((a (((b))) 3 -3 )) ((1 nil 3 4)) ((#\a (#\b #\c) 2.0 2.01)) ))) '((-3) (4) (2.01 ))) ) ) (do-test "test cdddar2" (let ((aa '((1 2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) ) ) ) )) )) (and (equal (cdddar aa) '((3 4 45 (5 6 67 (7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) ) ) )) ) (equal (cdddar (cdddar aa)) '((5 6 67 (7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) ) )) ) (equal (cdddar (cdddar (cdddar aa))) '((7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) )) ) (equal (cdddar (cdddar (cdddar (cdddar aa)))) '((9 10 1011 (11 12 123 (13 14) ) )) ) (equal (cdddar (cdddar (cdddar (cdddar (cdddar aa))))) '((11 12 123 (13 14) )) ) (equal (cdddar (cdddar (cdddar (cdddar (cdddar (cdddar aa)))))) '((13 14)) ) ) ) ) (do-test "test cdddar3" (progn (setq aa '((a ab b bc) c d )) (and (setf (cdddar aa) '(( #\g #\r #\i #\n #\o)) ) (equal aa `(( a ab b ( #\g #\r #\i #\n #\o) ) c d )) (setf (cdddar (cdddar aa)) '((3 6 7 8) 9)) (equal aa `(( a ab b ( #\g #\r #\i (3 6 7 8) 9) ) c d )) (setf (cdddar (cdddar (cdddar aa))) "magic kingdom") (equal aa `(( a ab b ( #\g #\r #\i (3 6 7 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..12022832a362e939c47534a005aabab039cca1da GIT binary patch literal 2062 zcmah~TW=Fb6rNeHFG-wafe=b)%i1auGTA80r6Fk_vRRMGhV|O)t_i7Bsg~nl3y7m! zTA>!?&&C5t1H4BoZP1mM3Lg=D14EFqvX$d6w~8zL$VXl#;`2 z-`jOmUT>@@7posuFJdv5)(9oUzu_fvB};dWg5|eqlP3Kyy?(<|icpw#iV-2v@q*r| z@AauC6jjl)Fl++Z#Li(FKh+-0(fiBf%+GVe{J_XA8m&J#Psr|T@g%L?e`vw_N$d0% z)-Qy#YS*nff%X%!RlB=yJ}3rV;Fl!iQN6OeRg>xx5u*NA-s>5?U}X(VPnp%MtjTO; z#sGw+o5Oq>YBqsFAz@w zwP@h-5S)3;LIZO@9~NhQFTSySVY%_qa@O~f>(#Y&xv~gjb$r_Q4!X#vuWD&|sSL1N zl9wZ5cO~SZ2{uGsoP9*nesw-({P!snGR2)8l-ThRB##JOTGo02;BTrl;HjP zw}`48lUns=?dxd)hPEwf_cXY*`$o(7bQaLokw2Eg{U;LPX@L+SI1P;9iKYRbya+S% z^bH6ZcU&8;t4N37KBKrM7P8wo~5dNeO#aTM*qrbBM;aMP@XzYd58{u{)tyRXd;buE#G7#fbW`5q(_dkh{s#DEvGmo7f0>t*C2u9hQU6LVl)TD&5zm z!pGj{WAl70&(qU9J&D>{vB<3KL7wi%7z*Eun zfEs3n57edsv)>l+c(M#`gQuH80!`+(qkcQW$0-EB$3ak!^n@$Xu=LzwXPsqw4x)%A zc;RzT&EE~o(H7j(NJ#vff*9Rw9tYFS<~SJO-YZl_QT?Vsg~J^?U;&?VJoQ#b0Gz>7 z2Ldk0F9?I|mKW1Y@YK0H)okv=ETA;awzUP^#n;$4XO;5suCA0T7s}_WAnSFEd=dT` f&obRD*jQL_s$nd?(rktg>C?L*-$2FW`u6s}l~q#P literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST new file mode 100644 index 00000000..f31feeaf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDDDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 14 ,1986 ;; ;; Last Update: July 14 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddddr.test ;; ;; ;; Syntax: CDDDDR LIST ;; ;; Function Description: CDDDDR performs the cdr operation 4 times on LIST, and returns the result. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test cddddr0" (and (eq (cddddr ()) ()) (eq (cddddr '(1)) ()) (eq (cddddr '((a b) (c d) e f)) '()) (eq (cddddr '(a b c z . d)) 'd) (equal (cddddr '(1 2 3 4 (5 6))) '((5 6))) (equal (cddddr '((1) (2) (3) 100 (4 5 6 . 7))) '((4 5 6 . 7))) (equal (cddddr '("sunday" nil nil "monday" nil "tuesday" nil)) '( nil "tuesday" nil)) (equal (cddddr (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) '(9 10 11 12)) (equal (cddddr '(|****| |%%%%| |????| |####| |^^^^^|)) '(|^^^^^|)) (equal (cddddr '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '( 'wild)) ) ) (defun fun (list elm) (typecase elm (number (= (cddddr list) elm)) ((or cons string) (equal (cddddr list) elm)) (t (eq (cddddr list) elm)) ) ) (do-test "test cddddr1" (prog1 (and (fun '(array (fixnum) "package" simple-vector (((((cute-t))) nil) nil) ) '((((((cute-t))) nil) nil))) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) '((2) ((3)) (((4 . 5))) t nil)) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '( (defun fun () 'nil))) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom #'+)) (mapcar (car (cddddr a)) '(4 5 6 7 (nil) t))) '(nil t)) (fun (cddddr (cddddr '(1 2 3 (10) 20 30 (100 200 300) 1000 2000 3000 4000 400 (40) 4))) '((40) 4)) ) ) ) (do-test "test cddddr2" (progn (setq a '(aa bb cc dd ee ff)) (setf (cddddr a) '(1 2 3 4 5 6 7 8)) (setf (cddddr (cddddr a)) '(44 33 22 11 55 66 77)) (equal a '(aa bb cc dd 1 2 3 4 44 33 22 11 55 66 77)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b254f2b2f9b88ffe3eb07990930104be4e4465b9 GIT binary patch literal 2031 zcmah~TW=dh6rR2Kl54kZn$onQYl}*in~mZ&fhK^I$?mw>)Ly&0>!v|MBC?%2Y8!{d z0aZY83qm|BqK?~Yhl0cdk33X7pq8RW0tq412gEPnv5%Gb0pXloJES*Z%X8+OIp4X= zd^2v6*f~9`>a|NNOBXAvYHhu~vR+pgYpd#7ZGE*=Q5V6kexT=V_R$R0PmjEw?sj&p zlvXPX^-5WF*DGt~h0DWgdQ{CVTvpQ)Cr=Km$4^X-O-!cKBi$M5WW!h;#9XDk+`*)G zU`8j?(C`2OuhNq-l=D1qM%recQIhOL9z88m1w4%do z-`jm$t=CqxiGheGR)EInDMrM2I|@b@ ze6KG(uBA2IFbtbOG0}5a#ZT4yv%&H(T1}1pzo+N@3<@{3eS4D`4sP!V!Tg^L#zEMX4`pN z%NN~3(M?HR0O(CoYhDZNPKra%O8Tj-i%EoV8TU)fLXc=CZ|A7{8ej+ht5>HE3!^|j z4csC@$Rn`jQ40at1AI`P@x9pk@`dHv`^$#!_0%hCb+uG3msdxpeDAP}YVrzAs*4Li zy0W^o95M!NSB?n&ZNDW#+Lv{kQI}~?WzU)}vuW1hz32uNoGIpA#`lr00VBb=Z*v4s z*S|$Z=n18{)TrK?5=D`2DfBLdGrMOt%}-{4YN7d|60AN}2v3THh`~-^0#DAG5XO^O zHYXf{d@;wh;iwA2UO3ALE*1!~CVq_&A-9t`ezPJxyL^atOzxV;13sD|G*ar<9P+~%E^<_0=Qlp${igA3Wd z3c}e=LoxJd=f~-Ruo6-1C@3HPf7al-JTGngx&Wia2>fK;EegCJ*uCKilqaMvpn4zQ zCG~LSd9OfR?r^yuPlfWmD2Dj}2=Yguksm|N<4H6&c=9r`K1T~WwM#JF<;>@%^I5I) zlDy4F=J-gCC#QIF0$pjLz%1i1Pj+GOB;SW(h!3LZ4+Qx>Fp}>=&F6#f08plGKKB+* z@`h1xVG?0ynN=7<;G29uiisz#&2co1^8+a2eyb05L8Pz^D5s}Gsp~u;h|+Lkum|0U z-;&#N@{iw&z>*w+1@g#mMfn&X=dU8#FhVqAq0D4>0=@nUE+HR+8^8~SP5c&AMt*ss zvNSqB2r46=LmE(f?!vI^TNs4v@R}Tz(dARW1%*pxod1qX!!SsXV2J$*!!wu<0eN*D zdXOX0n2Gl=xa+dP^bGjRSy;l2GZ-8XPd0)&8w@IdEU+LP6WS0leXOeuHZ46&>gjHI*)jKj?HscF$WLp%0lVF!ubk+ TH-Pcg@V(qVD)QCGTU-AE#<582 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST new file mode 100644 index 00000000..aaccb9ce --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 10 ,1986 ;; ;; Last Update: July 10 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdddr.test ;; ;; ;; Syntax: CDDDR LIST ;; ;; Function Description: CDSDR performs the cdr operation 3 times on LIST, and returns the result. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test cdddr0" (and (eq (cdddr ()) ()) (eq (cdddr '(1)) ()) (eq (cdddr '((a b) (c d))) '()) (eq (cdddr '(a b c . d)) 'd) (equal (cdddr '(1 2 3 4)) '(4)) (equal (cdddr '((1) (2) (3) (4 5 6 . 7))) '((4 5 6 . 7))) (equal (cdddr '("sunday" nil nil "monday" nil nil)) '("monday" nil nil)) (equal (cdddr (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) '(8 9 10 11 12)) (equal (cdddr '(|****| |%%%%| |????| |####| |^^^^^|)) '(|####| |^^^^^|)) (equal (cdddr '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '(((a . b) (c d e (f . g))) 'wild)) ) ) (defun fun (list elm) (typecase elm (number (= (cdddr list) elm)) ((or cons string) (equal (cdddr list) elm)) (t (eq (cdddr list) elm)) ) ) (do-test "test cdddr1" (prog1 (and (fun '(array (fixnum) "package" simple-vector 'cute-t) '(simple-vector 'cute-t)) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) '(1 (2) ((3)) (((4 . 5))) t nil)) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '((decf 1100) (defun fun () 'nil))) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom)) (mapcar (car (cdddr a)) '(4 5 6 7))) '(t)) (fun (cdddr (cdddr '(1 2 3 (10) 20 30 (100 200 300) 1000 2000 3000 4000 400 (40) 4))) '(3000 4000 400 (40) 4)) ) ) ) (do-test "test cdddr2" (progn (setq a '(aa bb cc dd ee ff)) (setf (cdddr a) '(1 2 3 4 5)) (setf (cdddr (cdddr a)) '(44 33 22 11)) (equal a '(aa bb cc 1 2 3 44 33 22 11)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c734942bc4f19e42722394f3930a99f3f91a9be GIT binary patch literal 2971 zcmb_eZ)jUp6u}9D)2_Hx(7mQF&Fhl)YVu-N7>u_hZQ|Nw z=8vTeXWhUFKC`vi=DW^)6h8@bB3LIYDt?=YA4D7o`b7|g4M7zAFweO!Y2!BV%V?8( z&hOsyJLlYc&b?VCt|P&S7|hR~%+93?V!m8DSuTk)`GQ!?mkY_XI0LwNDyYYlSHp7f zaR0M`_ISfgvXC}Q>6B=c)5VmzxK9iWh*5J<3>-XgV4pZRG_wETNFdPP9+Kk`hpTQe zl}_dAHh~74fsw%Q$l!tg_Ip?D%bYh)2uYGP9NGx+5`ow&me+46aYG8J5k=DEsN%Pm zZL1YBkrHtwW?LPDVkv)8noGZup2KA3i-aS@zF@V65?atubx38v#qwkuoRGjV`DM$9(Wa^a&X-dF0n6@z4DNEIlGj(bcpBWdtUid`71(J z)n)Z;7{X=fEica9^%Cmg3E^oI__nLOZ8b$y;IITG66Ll-D6Y5>Q?>C)uG79`HRI$Y zA+QPVGhlWeci^+kjR|fwN51`hf}iT~b#TpyW;PLWeFi1`pfZKRtRt(96C;hv-bSUT zLAlZ(FJ&74ZUAZL8CMsVS-q)&e0TZq+ZtrNoOwf=;5qQUd~Ms*j=DXL9zxc#Ns*mk zEq?B5J$@H(z&<(O8K19FZIofk=R-CWlD%tFy*$sMelv5-yOufD37@Vt?ZR2zdu_MI z@jPg{*Va4rt|wvgO}#7QJJtzHHU8$c+Ylz&-g-pY+^J{d&ORDO-mWuxFwUfJZOX^b z@vtGNx(RulzyACb+mBn<_rn~|;{>36b=1euI{r=#-Z;wt4|FASZRGrPH%$MZBhBK zB4LLD!u?2h;_x*UaX9B_MMsMucT}DX$}yNE|A4wBJ{=v^BU1e;Li|s<8;3j2@S8LI z>o-Fkor5>GnMyY3*diGFH5A}2b1)l;B&1@S`I|_GRi-xI1P@SZG zI0%4lQ8hR>IU*?$C8}sFksI_0nC3oatGExGA?tvqqb1lt{$^fYRJ2JjAb)@+L{$yt z-ypEsZ?PIkp&e?rW`;p?i#%&u!twJ?4&Zn3@|KPl_noxDkd0KuErLAOrFV%Yb~;m;q)>KBNOL;~v2) z3}p+q79I;oMp%J2d2ryVBJ46R8>~E^SE@jf<0{rgDz%M3+}xs=oJ*Sp(afd9VmX&vw5?qW*-}OUqa0Gr9@2Qeo2 zU$L4(x;_NP7qNs;*-zb$FihPht7EPbs^lLurl-M(;>NwcZg7O{2KyD`V1sP4nnvXq zN^En%4(0$sw@_G&p%x6F;J+3etX?OsnLtd2(^~)t5G|t@zzl@-6ap*-06}0}j+3{T zE2|y_(=Iedz>t-7?@YbKzAqnkcmz5$UaMxfE1)%L0KNfz4p3KX+XyRaD4`~-_U0CV z`t6GXRH*3;$1zHaOVSW@uma~N^#OAwxvSP0mE=|@J`UbJZ0z;sBk$ryeR=QRzgE_F AcmMzZ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST new file mode 100644 index 00000000..453f5ae4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 10 ,1986 ;; ;; Last Update: July 10 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddr.test ;; ;; ;; Syntax: CDDR LIST ;; ;; Function Description: CDDR performs the cdr operation 2 times on LIST, and returns the result. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddr list) elm)) ((or cons string) (equal (cddr list) elm)) (t (eq (cddr list) elm)) ) ) (do-test "test cddr0" (prog1 (and (mac '((1) 2 ) ()) (mac '(#\a #\b #\c) '(#\c)) (mac '("a" ("b" ("c" . d) . e) . f) 'f) (mac '((( 1 2 3 4) 5) 6 7 8 9) '(7 8 9)) (mac '(( 1 a) (2 b) (3 c)) '((3 c))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) ) (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) '("o1" "foo2" ((foo3)) (foo4 . foo5))) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '((and ) (the "20's" at night)) ) )) ) (do-test "test cddr1" (progn (setq a (list (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (list-length x)))) (equal (mapcar (car (cddr a)) (mapcar #'cddr '( (()) ((1 2) 3 4) (#\a #\b (7 8)) ((#\d) #\e #\f #\g #\h)) ) ) '(0 1 1 3 )) ) ) (do-test "test cddr2" (let ((aa '(1 3 (5) 7 9 ((11)) 13 15 (17 .18)))) (and (equal (cddr aa) '((5) 7 9 ((11)) 13 15 (17 .18))) (equal (cddr (cddr aa)) '(9 ((11)) 13 15 (17 .18))) (equal (cddr (cddr (cddr aa))) '(13 15 (17 .18))) (equal (cddr (cddr (cddr (cddr aa)))) '((17 .18))) ) ) ) (do-test "test cddr3" (progn (setq aa '((a b) c d )) (and (setf (cddr aa) (make-list 2 :initial-element '(2 4))) (equal aa `((a b) c (2 4)(2 4))) (setf (cddr (cddr aa)) '((3 6) 9)) (equal aa `((a b ) c (2 4)(2 4) (3 6) 9)) (setf (cddr (cddr (cddr aa))) "magic kingdom") (equal aa `((a b) c (2 4)(2 4) (3 6) 9 . "magic kingdom")) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cd3c274619b6109b93a0d742105d6770eb5c55bf GIT binary patch literal 3335 zcmcguZ)_Ar6rY*B>p%MEinY*E+M$J7jxO{Hg;Gp#xo+EQuXp9{YQ;#*aouv4Uhmqw ztE3u8B}R=|1LaV5RKA*+_<=Mr5kWCA#KfQ`nn8)409q zoA>6;Z+>s)&D&i-#ZP(t)SI4~P9%*CP0!}0XLEESouS$EY$j&V39!=_yupxudO-6I z?LOow3$Gf9WsGRf7^jh0BRd|QYp0$LIvky&o`c=p?X+`m&%T2_9?$NwJ}vB*SoVxD zV?1Tg@vNHD(c|gr>Ds%yZ0WM~CU&I}LNRoMi&BJKNI}*G)8&rn;fUJj^XqCr8`j;{ zf@PLKBtTlWf4ZmI&YTrjRw3CUoc?h@jNcK&Y2ayfI0$! zY5h7PCCexr9RrM~OZBMU-jJ#VdesmZ5pb$Hi;!b0C-hPL+91A~LNnI~$yj53HFhSh zokVEk+2UFpzxqi4`oApRpm$~S80E9=R*uk(M66kaxQvLgjaZzl z0TlRcK!_wCS?S+eY@GxJwj^F(AKSiIJDDU&CFw{ylg_d21Xm`jmgeL0@pa;3*nCP> zmMN--hsSVhebyijdyP_#8f&;Q)&SvQ!nL}^p0Nh8*y5hC1_D3+)Gbom`l#&GkxR=K z9=!ZpCwfoY^eW;D@%eQ+Xr&L>e-)2$9SN%UT27=!7z+1c!cO_hilv!_>4Q_8R(Cg#X zMje0x;@3m!5g%9r{b4sLXBA`vvhlLOO7v{IrGA@HZdh(DCt`%-L^#yY8$34uNqM)ZNy z-jm`b*7!VYI>l&;HBBFuRld3cq zH$GtNAkpI46bg2)qY(50b|x!7Z@4ba$5=4QKCJEw6O zob3L&WfZoDb#SwXb;=nEpTVKzNh@>K+Y-Cc8`8CiuHJW3{Jw}D()?jo&fOsUj*bQ+ zx;Qyyif!ZTCM>gcP>Y>s;ytc8m%>!On=4rdWp zDBNAxw0U^=E#{^=2u`SLtQ##8XZdjDa)i18}8@2)W7sh``#(%&vci8d& zQxf96GQi?hNr>(iK%?6N8hvY-EjIMuCldOawS?E=^s{YV%WSmgFCX#p$=D}+n6==w L)6iR|mzMqlvj5J5 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST new file mode 100644 index 00000000..55226dff --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cdr-and-rest ;; ;; Source: Steele's book Section 15.1: Conses Page: 262 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 30,1986 ;; ;; Last Update: June 30,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdr-and-rest.test ;; ;; ;; Syntax: CDR list ;; REST list ;; ;; Function Description: CDR returns a list with all elements but the first of the original list. ;; ;; Argument(s): list ;; ;; Returns: a list ;; (do-test "test cdr - the cdr of () is ()" (eq (cdr ()) ()) ) (do-test "test cdr0 - argument is a true list" (and (equal (cdr '(a b c)) '(b c)) (equal (cdr (make-list 20 :initial-element 'quack)) (make-list 19 :initial-element 'quack)) (equal (cdr (cdr (cdr (cdr (cdr (cdr (cdr '(((((( 4 5)))))) ))))))) ()) (equal (cdr (cdr (cdr '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))))) '(q r (s t)) ) (setq a (list 1 #'+)) (= (funcall (car (cdr a)) 1 2 3 4 5 ) 15) )) (do-test "test cdr1 - argument is a dotted list" (and (eq (cdr '(nil . nil)) nil) (equal (cdr '((1 2 3 4 5 6) . "s")) "s") (equal (cdr (cdr (cdr (cdr '( () () () () ( () () () () (()) . nil)))))) '(( () () () () (()) . nil)) ) (equal (cdr (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 6)))))) '(2 3 4 5 . 6)) )) (do-test "test cdr2 - the cdr of a cons may be altered by using rplacd or setf" (let () (setq aa '(a b c d (e f) g h (i j k))) (and (rplacd (cdr (car (last aa))) '(l m)) (equal aa '(a b c d (e f) g h (i j l m) )) (rplacd (cdr aa) (nthcdr 5 aa)) (equal aa '(a b g h (i j l m))) (setf (cdr aa) "the end") (equal aa '(a . "the end")) ) ) ) ; ; Function "rest" should behave the same as "cdr" ; The following test cases are the duplicates of the above ones, except the function "cdr" was replaced by "rest" ; (do-test "test rest - the rest of () is ()" (eq (rest ()) ()) ) (do-test "test rest0 - argument is a true list" (and (equal (rest '(a b c)) '(b c)) (equal (rest (make-list 20 :initial-element 'quack)) (make-list 19 :initial-element 'quack)) (equal (rest (rest (rest (rest (rest (rest (rest '(((((( 4 5)))))) ))))))) ()) (equal (rest (rest (rest '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))))) '(q r (s t)) ) (setq a (list 1 #'+)) (= (funcall (car (rest a)) 1 2 3 4 5 ) 15) )) (do-test "test rest1 - argument is a dotted list" (and (eq (rest '(nil . nil)) nil) (equal (rest '((1 2 3 4 5 6) . "s")) "s") (equal (rest (rest (rest (rest '( () () () () ( () () () () (()) . nil)))))) '(( () () () () (()) . nil)) ) (equal (rest (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 6)))))) '(2 3 4 5 . 6)) )) (do-test "test rest2 - the rest of a cons may be altered by using rplacd or setf" (let () (setq aa '(a b c d (e f) g h (i j k))) (and (rplacd (rest (car (last aa))) '(l m)) (equal aa '(a b c d (e f) g h (i j l m) )) (rplacd (rest aa) (nthcdr 5 aa)) (equal aa '(a b g h (i j l m))) (setf (rest aa) "the end") (equal aa '(a . "the end")) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3e912be76118a93a180d7acf9204db791cb79a71 GIT binary patch literal 3827 zcmds)duUr#7{JfHH|aB}X(_H`wO*^6Th`R2kFD!KmZi6^r8ixYu6Br$CAUrNZ4#1H zExx)q6yciLwa$B#3GNR?{}7%2;T|~IKm|o%_yGS95ue~hLBW5de&0E{wXO5P z&hPuq{T}DL=X~5OkjmQvK{=3_$);tNKS2 zkGWtPRj?B8SVRe%Mtz4|$Yi~`cDJVEVrKG0AjEvasOle61JR+7YAy=%g2Oy&IEPg4 zC@joBpb)XD>;=6Grcv$d_WHbmkQyP7OI?u=n}CU&NuC`RPN&JqbHn1e+g&f%rwD60(qdL>(3dC(tWR z0~*4YjV0w*Cxw4GgStRyk4tDy<(i2wj+AD+NHg?BbPxb1~>G4)ksMD*LPi~?XOOFNh(e8VK+ z5|hYpOd?;=ru*rJByH+KU!Q<4J6kYHA3$TTP%+aWiWg`z4nevRhdwU#ut9v0DaGfw z^dukJxbh}0HL*c>mnns}xb!+7a#+5Dv;iCo8RQAhI`VCtQ^@0-Cy@_ujw6q8z7sjZ z`F7+m=LzKfoDU$6a*iN}IFBN$oJWvHI1eKSIS(N3RycPc_i?@jIl#FMc`xU!v=K@}K4Y~bmsrur+qC%(y72&Q9;VGbv~e5l+(NrH z(MC7z+CUrq_>g`!jmp{dbUJfS8pX?|;VfwRf*jAJ^E*)Uy=hz@MNR92{#JQ11}`NE zIhE#b6sUV}6W(^tT&l(KJNQ!NBB^jcR3wAn`if-a_kp6c_$Vpb7C!YnTtP07BYU4J zlDY;6_+EajNZK0TK+Bg`=%w-mk)AK#N2HT~S`z75<_nFU=B|N`^GHC)%7KYgD(69@ zocWBoC_=qj0%64;Rq)lK+(g)U3Jyh;us;}~4!jMv`2Mj_RAI%GCTTZ@I<&epOmhd_ z2@~Sa=5b=*v*!~RF^!FSZ01lRh6P%4%Hi<{?3BYnH(}F)Owj%^*jMP{RXaFnIryF> zF#YjWCNN>yf6eVbx=Q<%1$@YgOLsx(XfHp}7g^23^Q&uy{X;ywly2<_mdLr!DllQmk~S6fY(IuYT60 zI8bxp$2HGK_>w&z;d9g2ywbWlWUm~PVRz~JoUCWkQ!@PG!Cy<**U-;r?AZw~uUEm* z=iyQUhX+b=9Og=gaF{K{a3E{)Ccm(}$xo)SWhHMP200000 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CONS.TEST b/internal/test/LANGUAGE/AUTO/15-1-CONS.TEST new file mode 100644 index 00000000..fdc8b63a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-CONS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cons ;; ;; Source: Steele's book Section 15.1: conses Page: 264 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 20,1986 ;; ;; Last Update: June 20,1986 ;; ;; Filed As: {eris}cml>test>15-1-cons.test ;; ;; ;; Syntax: CONS x y ;; ;; Function Description: CONS creates a new cons whose car is x and whose cdr is y ;; ;; Argument(s): x y - a lisp object ;; ;; Returns: cons or conses ;; (do-test "test cons0 - test cases copied from page 264 of CLtL" (and (equal (cons 'a 'b) '(a . b)) (equal (cons 'a (cons 'b (cons 'c '()))) '(a b c)) (equal (cons 'a '(b c d)) '(a b c d)))) (do-test "test cons1 - one of the arguments is nil" (and (equal (cons 1 nil) '(1)) (equal (cons nil 1) '(nil . 1)) (equal (cons nil nil) '(nil . nil)) (equal (cons t nil) '(t)))) (do-test "test cons2 - a really long nested cons" (equal (setq longcons (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 (cons 10 (cons 'a (cons 'b (cons 'c (cons 'd (cons 'e (cons 'f (cons 'g (cons 'h (cons 'i (cons 'j (cons 'k (cons 'l (cons 'm (cons 'n (cons 'o (cons 'p (cons 'q (cons 'r (cons 's (cons 't (cons 'u (cons 'v (cons 'w (cons 'x (cons 'y (cons 'z (cons #\a (cons #\b (cons #\c #\d)))))))))))))))))))))))))))))))))))))))) '(1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d))) (do-test "test cons3" (equal (cons longcons (cons longcons (cons longcons (cons longcons longcons)))) '( (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) 1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d))) (do-test "test cons4" (equal (cons "great" (cons "gray" (cons "owl" (cons "perched" (cons "in" (cons "an" (cons "aspen" "."))))))) '("great" "gray" "owl" "perched" "in" "an" "aspen" . "."))) (do-test "test cons5" (and (setq a (cons #'(lambda (x) (1+ x)) (cons #'(lambda (y) (1- y)) (cons #'(lambda (z) (* 2 z)) (cons #'(lambda (x) (* x x)) nil))))) (= (funcall (cadr a) 10) 9) (= (funcall (car (last a)) 10) 100) (= (funcall (nth 2 a) 2) 4) (= (list-length a) 4))) (do-test "test cons6" (equal (cons 1000 (cons 20000 (cons 399999 (cons 4777777 (cons 5111111 (cons 60000000 (cons 76666666 (cons 833232323223 (cons 922222 (cons 13333333 2888888)))))))))) '(1000 20000 399999 4777777 5111111 60000000 76666666 833232323223 922222 13333333 . 2888888))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cbd39569ea95bcc296d3ceccf16bf33fe671670e GIT binary patch literal 4600 zcmb_f3v5%@89w*=l_xPF1!^eVrsI`y5r!~PpsR1pO=57a6Z-}?u&pzR!3JZej?;pw zwTPu`lUx^LVE1%tH-W~UogmUgDHYMirXg)q+f-?)rfuq0X;P&j{5Q@n=qqCsXmPl9|knPv(>(nXEFAnaqyHl_S6_&-z1Q z{d4`AfB%-<-lj;EWHcL(<>F(CIT@cAi=Eo6c(*D8u~Ulo(VaUtE8Dj3>V9;W*Sn>u zSBnJ6SH&V4A4^wkyj3<^cX>atYe)B%rrB4lOOiXo7#n3XxHK~6W;SM>&%3)!Jz}c8 zfuOD$+JN3=6|H;&RH639l@IWfT`#;kMshTdVrZw5k!Rgz9i zE!Io<)_|c7LSb5;&g6!&7xXS!`8Mwk)vKCeU03y?VJ*lYqvkV=*?pMK8;M){q?>7J z-<$j7=t|F0$#Il1c(pQi`8xaEv17D(8+Gwb@J=n9p0g<>uCpsCxvYukVj@9OD7-~D zJwx(pcKUeAma^9{(MpIK_VGHln^LW*Hqb%?h%mjPp5^Jp;{RJ<)PBa*E+uZ>HemnP z;{F$nJB$?*XN`Tb1f>?Qt&Dmq?#ljWlB27|l`OYT9BY7pQ%R6EADO^MdK{kFUL!mIGqHub`iB*TsYiTMQd_^ zr{(jK<#TzICDC@_2`8Tmcmf0^x<*R9m!T&Pq6KpGl3?OJlAh z5bV&x4glA;keluQ1JJ@-ZA~x~mvrgja44*XhRwlYv&*&wlv=tp zV?-5vq>ICJT)KVXkZp7_#_c#-`*2EjgC}QiC_JE<2-kv>j`@oHS_H-_hT$zBwtaxZ zcz)I*^?UBY<(IVlkd_(HYm1Bw^n`+HWtyYb_elI5z6#OHgwBDoBQo3*!3=D9lAYwM z5#TqUD~D$uqQkm&k9C zCgm%Cna~$Wc95@xMCD%oATAw5GOfFJsH00N$wfqp1s_& zgL~F<&qLhvI231p056m{4TzfHR_!$Km^yqk-s03#%bpK=BH zH^Grp+^q)@-X!*$!ad%@k^DN5UxEW^GlmDa8_BaoKE*$VC{5@PA%k}!xu3}0{1HSu z39TmdAR$>Gc~&6#E<|uC!9XyeM?@6)$G|iwHPjnGImQ#I%t=zY0obWj5m!ZY`3m{G zKoN?B_V6{3i`*?bByXgpNywys2|MW@gx-S|NRNTC^ez!^@lA-RZ_?|e{C$!w7jC5` z!k;9Ig}o;tvv>K!V8`wWO?F$@v0H?`P3RkhE{F)MNCs#4rsuhmf;41(D9IHA>Xcvv z?Z?&6-5y*u?q0#w-4MXO)ylgj)5p`9XVM5aTlw|5_(V?0W#e%*{?ueFrKpNvGHE5I zq+;2laUn$QjaGiGiQ1jdX`RZE7(B&}DakZFf+F|aI#9Fy$-2avd^Q-$8h*fJw(_e| zu@i^KVyL}n!a?1#m~d7}w(`;w@E!qHHE zUygTrs^>11b!18#r`=~DhlhOI-5B~6jn*s) z_Ob(5(7#o(;iZFNGc+7BbvSa4o*+E_b2rf31Z>ww^u6;C?j8}%n8!#sZ<>G9KbkF#j@GVGu+KLpj_z{%! zZh$xJ;>rKMbCr(t2Ey4~_AV(_hK;Qr_)gWL$maAP43!(#Fv`i84*FT@I?K;$q< z>2Hwml%~K>)RNo*J(>k;nz?&FZhjh!3HmB%GdI6+32 zH=^k~_tp3bX~>ez?m&w>3-EOaT+j+VD0>a}vBF{8UnXAcU#;TL!yZbC!5cd%6&B#n zLyqv0B|A!=uR%GCU9wB?2UfCdLzVG*WE|AEO2-G4VhivA@GIfBLJH6A_K1_ifn+a& zdpNYB?OVm!kl@bp@Q0m^ST1uy6tqzs4Tin9J269sO_uEvZhsC3ra9H>(^4JqW8#0A zg^~-tukxP9z!^HcG36`ou2^|z#0* Ow76)7hl;&3JNq9aVEpp{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST b/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST new file mode 100644 index 00000000..e2d9d5af --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TREE-EQUAL ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.1 Conses ;; Page: 264 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 1, 1986 Sye / create test cases ;; July 21, 1986 Masinter, comment out case where "list-length" was used as tree-equal test function ;; ;; Filed As: {ERIS}CML>TEST>15-1-TREE-EQUAL.TEST ;; ;; ;; Syntax: (TREE-EQUAL X Y &KEY TEST TEST-NOT) ;; ;; Function Description: ;; This is a predicate that is true if X and Y are ;; isomorphic trees with identical leaves, that is, if X and Y ;; are atoms that satisfy the test (by default EQL), ;; or if they are both conses and their CAR's are TREE-EQUAL ;; and their CDR's are TREE-EQUAL. ;; Thus TREE-EQUAL recursively compares conses (but not any other objects ;; that have components). See function EQUAL, which does recursively ;; compare certain other structured objects, such as strings. ;; ;; Argument(s): X - a tree ;; Y - a tree ;; TEST - a function ;; TEST-NOT - a function ;; ;; Returns: a tree ;; (do-test "test tree-equal - x & y are atoms" (and (tree-equal 'a 'a) (tree-equal 0 0) (tree-equal 3.0 3.00) (tree-equal #\A #\A) (not (tree-equal 'c 'e)) (not (tree-equal 2 2.0)) (tree-equal nil () :test #'eq) (tree-equal 2 2.0 :test #'=) (tree-equal 3 4 :test-not #'=) (tree-equal "string" "STRING" :test #'equalp) (tree-equal 2 (sqrt 4) :test #'equalp) (tree-equal 10 15 :test #'(lambda (x y) (<= 10 x y 20))) ;; ;; ROACH 1-JUL-86 The form ;; (tree-equal '(2 4) '(4 6) :test-not #'equal) ;; should not be expected to return T because two corresponding leaves of ;; these trees are both NIL. ;; '(2 4) = '(2 4 . NIL) and '(4 6 . NIL) ;; (tree-equal '(2 4 . 1) '(4 6 . 3) :test-not #'equal) )) (do-test "test tree-equal - x & y are conses" (and (tree-equal '(1 . 2) '(1 . 2)) (tree-equal '(a b c d) '(a b c d)) (tree-equal '((1 1 1 1) (2 2) . 3) '((1 1 1 1) (2 2) . 3) ) (tree-equal '((2 . 1) . 4) '((2 . 1) . 4)) (not (tree-equal '("a" "s") '("a" "s"))) (not (tree-equal '(#\a #\b) '(#\A #\b))) (tree-equal '(#\a #\b) '(#\A #\B) :test #'equalp) (tree-equal '((2 1 . 3) 4 . 5) '((2 1 . 3) 4 . 5) :test #'=) (tree-equal '((1 2.2 . 3) ((4 . 5) 6 7 . 8.8) . 9) '((1 2.2 . 3) ((4 . 5) 6 7 . 8.8) . 9) :test #'=) (tree-equal '(10 (20.0 (30.2))) '(10.0 (20 (30.200))) :test #'equalp) (tree-equal '(#\a #\c "t" 30) '( 40 #\e "u" 90) :test #'(lambda (x y) (and (atom x) (atom y)))) ) ) (do-test "test tree-equal - test on a large tree" (progn (setq tree '(1 2 (3 4 (5 6 (7 8) 9 10) 11 12) 13 14 15 (#\p #\l #\m #\g ('Fire 'Pink ('black 'eyed 'susan) 'North-Carolina) |asheville| (|yarrow| |phlox| \ fragrant \ water \ lilies)) (((((a b) c d (e) f g h) 100.0 (200 400) z w) f g) the end))) (and (progn (setq tree1 tree) (and (tree-equal tree tree1) (tree-equal tree tree1 :test #'equal) (tree-equal tree tree1 :test #'equalp))) (progn ; ; replace | phlox| with |phlox| ; replace '\ \ lilies with \ lilies ; (setq tree1 (subst '| phlox| '|phlox| tree)) (setq tree2 (subst '\ \ lilies '\ lilies tree)) (not (or (tree-equal tree tree1) (tree-equal tree tree2)))) (progn ; ; replace "Fire" "Pink" with "fire" "pink" ; (setq tree1 '(1 2 (3 4 (5 6 (7 8) 9 10) 11 12) 13 14 15 (#\p #\l #\m #\g ("Fire" "Pink" ('black 'eyed 'susan) 'North-Carolina) |asheville| (|yarrow| |phlox| \ fragrant \ water \ lilies )) (((((a b) c d (e) f g h) 100.0 (200 400) z w) f g) the end))) (setq tree2 (subst "fire" "Fire" tree1 :test #'equal) tree2 (subst "pink" "Pink" tree2 :test #'equal)) (and (not (tree-equal tree1 tree2)) (not (tree-equal tree1 tree2 :test #'equal)) (tree-equal tree1 tree2 :test #'equalp))) ;; (progn ; ; replace 15 with 15.000 and 100.0 with 100 ; (defun num (x y) (if (and (numberp x) (numberp y) (= x y)) t)) (setq tree1 (subst 15.00 15 tree :test #'num) tree1 (subst 100 100.0 tree1 :test #'num)) (and (not (tree-equal tree tree1)) (not (tree-equal tree tree1 :test #'equal)) (tree-equal tree tree1 :test #'equalp) (tree-equal tree tree1 :test #' (lambda (x y) (if (listp x) (= (list-length x) (list-length y)) t) )) (tree-equal tree tree1 :test-not #'(lambda (x y) (or (vectorp x) (vectorp y)))) (tree-equal tree tree1 :test #'(lambda (x y) (and (atom x) (atom y)))))) ))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL b/internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b131ffc766a9e44ccb143bf36ef4cce393462ba9 GIT binary patch literal 5237 zcmeHLeQaA-6~FiS+p!ZTwUQ>w($}aPlN(oYSZS6GHpg*3TF1_8hjdh969i?&mOC5N#?XfUYk+l%i7XR;!Ka~>s7}SXH?%q{rx>^-=_y2d}zSu zJ76F7$3oIprN@*uld1Ia)%EEe@EscP^&ha`_$GUiy0V0jB-uc)5#k~S!k#a*G z?j0Tr1-)Vac+kUES-}dCcqe1QC@VDgsrl@pSJ$4>bPQ%;iBLk=`GR$LG8~AHMZ&B^ zSEz%1z2F=RdnX_;|45K1*0L3}PFbPBchKAC^-oL$!$SnTaXd|k=>od)cIwJu`c{U# zboH<@)z#5VO(?}Tg&&8cH@}6<93jp!zmmEFT+7oIH%+~DEe!PER*yUveut3N)HC73 z3I)a0OS`AkinX$_jdZeGq@X-5U8{_1NmYM#=v+!&Cc;7Ns5^DH-lac~>VRLxqTN*X zWj%+YldtXp)eZquEWWI?`~sZ&-QW!LnqzLlZl8G1FN?3Y@{TQ?%^aHJJ7cYOCoWVdkh z;$=D?ahEgO4&1SbyV4M@>G;ESDt+OK#{D&o_DE};iY?Mw)*&BNb;t*Ij^MZ(90VgZ z@7CLDzP(hogA)=e{^|~FrJ#Ow#=2|9*4^bW>#eS&)<9d$s8pHsM>9jMPbzog2D&eyUSx)D1V* z_t&)`xw+m}CjnhhggVti{O@r+pSsj`+wE~R zy@O*Q36I1)iWANc>aQLcxYa8*?o_PsTHrOoYXqHUPrx4!jC!NN_+%8$h=4d`%&{k8 z@!+^Zw`;^B9^PbVJfR-J1Lr(gG7m?h+{G31Y-3x4TH;a)QWvz}v?CM}pqa zm`EAgx1Z##Px3Z!W*=|g1^F|b1Z9($5XhzBmSPTLwL{20$-4lIA3)J*fa3+k z_!p!HCH*IEM-k`uBCJZ~uL@9}5klphnE$vwimV*K7Cyz5ckB+Aa+hiZfDStGY|mG9wuk^dYl8UqrC*qWjg=aKA{&;v~h@~!Me zVtq_E!2abTtZSeTwkpz&=B5wmKQN>_1A@fU6LI&v#_6_I^wdo2( zgZ_BXd&|-fjm3jee<;SAPz`3%gWOgyFEy4Ufu}UM&tkh7Gh+WDGc91Z9bgQ=Eoo(8ND;4cGwrQVb zrCl}K4Xt~#V3lmahmPatDtwgv_<0#VhDBB~-&sS0v8w7*tkkk2>xK~I14i$`K?cEu zAP(-hJEX5JMGa_W4_FZdq;F?VDBly4jvs?$1 zL^Bc{K)8@-1p*#C_7q%-jYyzX+!NuPFHzht6*CYRzoGyE4^A`sZy<2~(SHGf(~W)z zgawJe17SwuuRy?qOOpN>2wac!4?y4+Lw^SZZYXpM2&^=PW$P*?iqpkpai(~(c&eze zLSs2Em^0WKsA4o*O%_dM-S+S8(Xw3n5DBVWS` z;>1L6%8%)`E8r8wPtvn(v(~8r&*z|ZvDaqO*@@f zScLz&6KDL4I-AQbsEdg?P3`+kKOW|RP(GybeQ;5#-k`kI0Y1e_78xPmE1bEG5e&;f gMz}+*1o7K@uuoY>Xl}Jttcml>test>append.test ;; ;; ;; Syntax: APPEND &rest lists ;; ;; Function Description: APPEND concatenates its arguments and returns a list. ;; ;; Argument(s): {list}* or a lisp object ;; ;; Returns: a list or a lisp object ;; (do-test "test append - example copied from page 268 of CLtL" (and (EQUAL (APPEND '(A B C) '(D E F) NIL '(G)) '(A B C D E F G)) (EQUAL (APPEND '(A B C) 'D) '(A B C . D)) ) ) (do-test "test append0" (and (eq (append nil nil nil nil () () () (not t) (and nil t) (null 'a)) nil) (equal (append '(a b c) '(1 2 3 4) (list 10 20 30 40) `(aa bb cc dd) (last '(z x w q))) '(a b c 1 2 3 4 10 20 30 40 aa bb cc dd q)) (equal (funcall #'append (rest '(a b c d e)) (nthcdr 4 '(1 2 3)) (make-list 10) (butlast '(a b c))) '(b c d e nil nil nil nil nil nil nil nil nil nil a b)) (equal (setq a (append (cons 1 (cons 2 (cons 3 (cons 4 '())))) (cons 11 (cons 22 (cons 33 (cons 44 '())))) '(((((111 222 333 444 555))))))) '(1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))))) (equal (append a a a a a a a a a a a a a a a) '(1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) )) )) (do-test "test append - nested append functions" (and (equal (append (list #\a #\b #\c #\d #\q #\w #\e) (append '("append testing") (list 1 2) (append (cdr '(2 4 6 8)) (append (cddr '(1 3 5 7))) (append '(stop))))) '(#\a #\b #\c #\d #\q #\w #\e "append testing" 1 2 4 6 8 5 7 stop)) ;; (equal (append '(1) (append '(2) (append '(3) (append '(4) (append '((5)) (append '(6) (append '(7) (append '(8) (append '(9) (append '((10)) (append '(11) (append '(12) (append '(13) (append '(14) (append '((15)) (append '(16) (append '(17) (append '(18) (append '(19) (append '((20)))))))))))))))))))))) '(1 2 3 4 (5) 6 7 8 9 (10) 11 12 13 14 (15) 16 17 18 19 (20))))) (do-test "test append - append copies the top-level list structure of each of its arguments except the last one" (LET* ((a (list 1 2 3 4 5 6 7 8 9 10)) (aa (list 11 22 33)) (aaa (list 111 222 333 444 555)) (b (append a aa aaa))) (and (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555)) ; (rplacd (last a) '(11)) (equal a '(1 2 3 4 5 6 7 8 9 10 11)) (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555)) ; (rplacd (last aa) '(44)) (equal aa '(11 22 33 44)) (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555)) ; (rplacd (last aaa) '(666)) (equal aaa '(111 222 333 444 555 666)) (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555 666)) ;; ;; (progn (setq a (list 1 2 3 4 5 6 7 8 9 10) b (append a)) (and (equal b '(1 2 3 4 5 6 7 8 9 10)) (rplacd (last a) '(22)) (equal b '(1 2 3 4 5 6 7 8 9 10 22)) )) ;; ;; (progn (setq a (list 1 2 3 4 5 6 7 8 9 10) b (append a nil)) (and (equal b '(1 2 3 4 5 6 7 8 9 10)) (rplacd (last a) '(22)) (equal a '(1 2 3 4 5 6 7 8 9 10 22)) (equal b '(1 2 3 4 5 6 7 8 9 10)) )) ;; ;; (progn (setq a (list 2 4 '(6 8) 10) b (append a nil)) (and (equal b '(2 4 (6 8) 10)) (rplacd (caddr a) '(9)) (equal a '(2 4 (6 9) 10)) (equal b '(2 4 (6 9) 10)) )) ) )) (do-test "test append - The last argument may be any List object, which become the tail end of the constructed list" (and (equal (append '(1 2 3 4) (+ 1 4)) '(1 2 3 4 . 5)) ; (equal (append '(nil) (list 'a 'b 'c)) '(nil a b c)) ; (equal (append '(1 2) "string") '(1 2 . "string")) ; (progn (setq a (append '(1) #'(lambda (x) (gcd x 3)))) (= (funcall (cdr a) 6) 3)) ; (equal (append '(2) #\k) '(2 . #\k)) ; (prog2 (setq a (append '(3) '#(a b c d))) (vectorp (cdr a))) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a1f1295fb0e9aac115f1e9e96054795ab518e285 GIT binary patch literal 3513 zcmcInYiu0V6~1?7rrC;Lj(5@ zMWemVqguugw(2X6*tueTO?1_ozM<&g(7<4C^Yyd-8??1V2$><5P&5(JN@U`n_F5yB zp0U)?grTdZHlauSMc-?LNYtr}p7y;BF{M(PQ(gNh+r?mJ%Y+i*zveZLPML8lkuv=y zxc^n)5&bY6BKh(%|iu;45>pB^V<YV?~gz?qI@t>HN zasDMUDbX;D&TT%j85h@|5FwWeGh28%>Ms1d?n1E6LfJydov}~ftJ`lxyWl^HmF4sr zH0;J80{DY{f#Pnzf!y{RLx^Z)c@wU~2T4r7!n z%MJ>6ub6w(&7s3NfediA=G-M1EP19#D9#bAVt=baR!*-=##_%(hEMwtuzF3=2XL&74-bJ`-V7 zz6W$vyK!G&r^9`5;MV)1B|r!Z;4Klup6>wb4Wp^_gk~X>z)1Ve;Nn_F7hA9pOiOFw8=@`96>n9x={28aj#g@B~XYX^0g3u;nvCL+&cLMnlV!rl>a%l$zdH2 zvd%%)xsP>jWt}^~r1T{)*71{p=qkJ(fDa|+W&474qxP?mtcD2GqCXFfi`nQKI2x&$J`wG73)66b{uBiN!Gm|$a0(S1*^p;ilwKE2-o{wbHy%Kl*g(S zH(Ra@pt8mHerTa`$4PC6lF!2TMouXd#m55bPVNGlbirSep&i+N{Mm;;dr~=&^%oS}_uA@EHxDP$DHB77SSfPhj66J* zvUIkS;D$?gdqXzFcJZA~-u<1R{QPi7;Vkn#ZT}3$eA?@Zr*+NJ)mtt(BVp-j&B(A2 z(7;oE?50^SW@hS^>h`1ZVb%wN{vBf3?tF6a{NopriLd_i_E^%{0`IO*l22T@@WNQ@ zxqtnS>d9cERz3JGqb6--3RDzLU-p**RFVTYz6f4X2}d8@82yZg#EhE`(^t5|^hMvh zclB|MDXLOb3S}i{=d)F}0`CMRipCa15b)6`vo=T$9cCL*#6{zbpy^}qgSrthrHiS9 zIMv3EqLuZ6A&;g~oD+b7Xk*%lmTi_t#uA)5@rU-11ouL11eZ%~G$8B)F^u-vG4^AY z#r;Rc{)dDZ69PIM=aPI8x#lmm++4(-Wb>@dDy)i>aY6awwxp3i@uZO}zL#8`v?wI4 zkXI^>t+)l~VkcWx^7hm4zeL5!79pRuYtP!nO1TF)MP=_k%<#Njsm>Se9OQ-kmS>l| z2X$N*ma%%|9T?Zj3MmP<^Sns#iLfL!K&~L_z=kc|crB5);A904YH*mo#|f75CML>TEST>15-2-BUTLAST.TEST ;; ;; ;; Syntax: (BUTLAST LIST &OPTIONAL N) ;; ;; Function Description: ;; This creates and returns a list with the same elements as LIST, ;; excepting the last N elements. ;; N defaults to 1. The argument is not destroyed. ;; If the LIST has fewer than N elements, then NIL is returned. ;; For example: ;; ;; (BUTLAST '(A B C D)) => (A B C) ;; (BUTLAST '((A B) (C D))) => ((A B)) ;; (BUTLAST '(A)) => NIL ;; (BUTLAST NIL) => NIL ;; ;; The name is from the phrase ``all elements but the last.'' ;; ;; Argument(s): LIST - a list ;; N - a number ;; ;; Returns: a pure list ;; (do-test "test butlast0 - test cases copied from page 271 of CLtL" (and (equal (butlast '(a b c d)) '(a b c)) (equal (butlast '((a b) (c d))) '((a b))) (eq (butlast '(a)) ()) (eq (butlast ()) ()))) (do-test "test butlast1 - if the list has fewer than n elements, then () is returned" (notany #'(lambda (x &optional y) (butlast x y)) '((1 2 3 4) (10 20) ((2 4) (6 8)) ((17 26 35 44))) '(5 10 3 2))) (do-test "test butlast2 - n is default to 1" (and (equal (butlast '(a b c d e f g h i j k)) '(a b c d e f g h i j)) (equal (butlast '(foo foo1 (((((foo2 foo3)))) foo4))) '(foo foo1)) (equal (butlast (make-list 50 :initial-element 'hi)) (append (make-list 29 :initial-element 'hi) (make-list 20 :initial-element 'hi))) (equal (butlast (nconc '(a b) '(c (d e)))) '(a b c)))) (do-test "test butlast3" (and (eq (butlast () 2) ()) (equal (butlast '(1 2) 0) '(1 2)) (eq (butlast '(1 2 3 4) 40) ()) (eq (butlast (make-list 100) 100) ()) ; (defun fun (n) (let ((i 0) buf) (dotimes (i n buf) (setq buf (append buf (list i)))))) ; (equal (butlast (fun 100) 50) (fun 50)) (equal (butlast (fun 20) 13) (fun 7)) (equal (butlast (fun 15) 12) (fun 3)))) (do-test "test butlast4" (progn (defmacro mac1 () ''*mac1*) (defmacro mac2 () ''*mac2*) (defmacro mac3 () ''*mac3*) (setq a '((mac1) (mac2) (mac3))) (and (eq (eval (cadr (butlast a))) '*mac2*) (eq (eval (car (butlast (reverse a)))) '*mac3*)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6a20c9c8f9c04446bec307cf54fde9b8e07d4989 GIT binary patch literal 3734 zcmdT`U1%It6uz^YWH&LCzdklD;R z_xybKoO92)lLZlaQctRS_0aU>lry7N=W5e)HMLZoQD>`jGX+O2L9QOrP0Khss_FZ7 zK9=antkM)_oP5nGs`i{STg)Hcp(b{zsr+Fzv8TU(huXJ$;GsPOiNwy1VJ(yNv6eh? zPO-A&lUU`mYar1-uxroGj%ydamz79W2vHDMn6wKK5kcWC)*~_7$k_4Wv7`}CYbhh< zEqL`XGKpt1hUL}Q^{KV$bbQKr)|ujD4$TTh2=B#ucsQHZ?J+a$HI(O-PVZd3Yb+ff zM`GHDAp+qh3ZpAt{jS8r@xHijj!(q3=Y99`Ugf=txctH1K<=JR z>l7(PkgU9V>G5XB{%YrStLW<0YpWN}yZ&?epb*_BL*0t|-iK-MKP~J#oBmjc1^0#Y z-hk2t?yY-ro7i>fuTzLClZ9Scs%C7;$Wm;f)tg-UYtj5Ou>_(^v4lC6Lid$icOi-w zDpu%e()BX>Tn{qF4;kUT@y})JZ(_Gbmg~+%uU_iO_3)-wFXYxs%0<3?T8r*m8*WEhmwXB9~^@uJ(7t9Lev###a|1Wc3n)@Y<)Ct8Ftn} z)9JEn+cFaw+eihJ8!c=zMxDWSC<2_%+F@xA2|+D9B6p+PmEQo`Hf&lc z&F1Cz@a=W}Cil`tCLOd1 zM0_iS;!B@=;*)oMa$Z`B6ST>qUW0lcrQQdrcQf_MkiX_2WV#IZ1tz~O%?TuV`6)%2 zya}72u35~#F75YceS?dzZ{a$#Y7yy%v~g=pH*Jcrq)sZ6GjuPLW6-w^ndXo-dihAHMEGo{tZ#6$zbER%Je+UNo88u%is)gbVc2TGE2OYKVk$w*62d}=> z=1{gB)3&LlJU$c>SAH>Ac1$Mmf!Ap9UJ7`1B~ROY=73+433Q)S6lkl@6c_8QsN)bc zyu&*yu25*><4IJp2|@QaeWB4YcgtW!x{rM?V8a44r+8;(s$h!DJPqamGf&(Ce{G02 zY;%364|=b9jR4L%s#}I;8~AE0-3oF*l4G`EX~_(AvKg9lf7Y}OdHl*2l7-rcQCxep z2@dmadH_Ux=QYBd^I}~Yrbt(lMbojAQlX|`1XlqI%+{vhDPO>TD3a7=+Zga0ACOXv zMdk_&St|&Xm3(fM-&gF{Xb&?Y-yk5kiO8fZvp6EKIWoOQFzkzPJ9&*e+NnfYDnglJ z1GaqRRuNH7Q*tt}Odx^J}oF##Zkmq34Dt$^=l^`#1 zf}b}7g_i@=EHtYkBlpIjfcr1T^O@IZ;~#n}Wf(X_B+B8s97?Mcn-o0 z)7mGCnt~b zZE|>XsZqLih`1tbW#Pen!_Hi5znWYkh+1Ib0LRh()7=L69z%bZ_(Mvm0Kfe!+Lc$g zE9I7)o|J!ehj;%CpB?`9(EoI-x%ju=LKki7EdJz>!(SpQNj??Wa0{Js{p^TWcshQ$ GcI^+q;|)gu literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST new file mode 100644 index 00000000..cde32c74 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: COPY-ALIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 268 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 15,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-COPY-ALIST.TEST ;; ;; ;; Syntax: (COPY-ALIST ALIST) ;; ;; Function Description: ;; COPY-ALIST is for copying association lists. The top level of ;; list structure of LIST is copied, just as for COPY-LIST. ;; In addition, each element of LIST that is a cons is replaced ;; in the copy by a new cons with the same CAR and CDR. ;; ;; Argument(s): ALIST - an association list ;; ;; Returns: an association list ;; (do-test "test copy-alist 0" (and (equal (copy-alist '((g . 5) (b . 7) (e . 5) (f . 2))) '((g . 5) (b . 7) (e . 5) (f . 2))) (equal (copy-alist '((D . 5) (Z . 3) (Y . 3) (Z . 6))) '((D . 5) (Z . 3) (Y . 3) (Z . 6))) (equal (copy-alist '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) (equal (copy-alist '((X X E G C G) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) '((X X E G C G) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) (equal (copy-alist '((C F X G D B G F X) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) '((C F X G D B G F X) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) ) ) (do-test "test copy-alist 1" (and (equal (copy-alist '((CATOR . C) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) '((CATOR . C) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) (equal (copy-alist '((MEEF G C E C C) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) '((MEEF G C E C C) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) (equal (copy-alist '((8 A B D Z E D Y D) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) '((8 A B D Z E D Y D) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) (equal (copy-alist '((F . 10) (D . 8) (F . 7) (G . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) '((F . 10) (D . 8) (F . 7) (G . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) ) ) (do-test "test copy-alist 2 --each element of list that is a cons is replaced in the copy by a new cons with the same car and cdr -- page 268" (progn (setq aa '(("a" . apple) ("b" . baby) ("c" . candy) ("d" . daddy)) aaa aa bb (copy-alist aa) cc (copy-alist aa)) (rplacd (assoc "b" bb :test 'equal) 'babe) (rplacd (assoc "d" bb :test 'equal) 'doodad) (rplacd (assoc "a" cc :test 'equal) 'apricot) (rplacd (assoc "c" cc :test 'equal) 'car) (and (equal aa aaa) (equal bb '(("a" . apple) ("b" . babe) ("c" . candy) ("d" . doodad)) ) (equal cc '(("a" . apricot) ("b" . baby) ("c" . car) ("d" . daddy)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0799dcbfba5905128580e161402aec528370d004 GIT binary patch literal 2096 zcmcJPUuYvm9LHxjO_Q`qN&j6-t#vt0k-ctc`j1|ZS~uHGn>5|+?QU%2gAm%(7Tct> ziFzC!dV(+Rao0a5^HanZ!3PiSKoHK#9ViHjFA9QB;-iS52)+sRH#@hr*Z3mbkqp0? z@63FDzu(MnXNQCqwVb3?Ha6GROIuQ7e ze6qfFBdQNOUVIgu6R*Oo*NtMmj;K%htG{ClZmFZYUeo1-?30y zF8h0u$My`2C&$Kzh7wJO@6&gLc!dzMMD8&YAtX)$gzma=+0kuBNoR7pVyJVvOn0ao z#!QsFty|P>9h9n-O=Z3Ga%r6v_2FOp@X*7D z3s3p*@FRe~>BA$B0RFQNk3D?2IN`&a{~vsJ^>){P-ssM1d@WAIW_rWzl{M3t%CHJl zW>jM;r&~%YgNiY2%VG>-Vgy?lTL@baTLYGRtE{PxHltX&lee&3HLu9!15>#d_FKbdHN5NKc@N*gQs zr;*f{Hmy0;VZ(NWbo`r)rrJ8kK@_Kj-*9#0=*wZsH_*<^r_jO7HRxn!gNp?&4stQ> ziR5ojBtLi}`GkufK*y`l`5d&TpyM&<^dgI(ub`I-BJnt`yNw2mGsisq1zpVCgj39X z$VZeLlZ(@Qblx-MPfsMj^3hM++~DF>K6(SX#^BTdbe+LJ^Ld84p<4N+a^;mW8%orT zALTBw$3z-sdM|aKa7x=%>GWmww6s#hr*&CcEAw}eX_ud5LHj&p`%PD}2au7@2v_QsfY10Im;S$J!v-s=BraL+hwh|wCn;K+}3 zzmWx(QqdcXKtCIJF40K>7n1LA1y0};jQZL^ojY>Nb4Na|cQ?o=A3@J0x)(;epm`Yz zIyckYq`6VKnZj69wl)QF6}Q0zJOh*PEU1veroHf>e+#;edcVmm^z_la7~|lnf`$yX fKLry^T106QCcAJ2WRFk6EYpPtU66OJ!^3|70oqzW literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST b/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST new file mode 100644 index 00000000..3322b2a7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: COPY-LIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 268 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-COPY-LIST.TEST ;; ;; ;; Syntax: (COPY-LIST L) ;; ;; Function Description: ;; This returns a list that is EQUAL to LIST, but not EQ. ;; Only the top level of list structure is copied; that is, COPY-LIST ;; copies in the CDR direction but not in the CAR direction. ;; If the list is ``dotted,'' that is, (CDR (LAST LIST)) ;; is a non-NIL atom, this will be true of the returned list also. ;; See also function COPY-SEQ and function COPY-TREE. ;; ;; Argument(s): L - a list ;; ;; Returns: a list ;; (DO-TEST "COPY-LIST TEST 1" (EQUAL (COPY-LIST '(Z Z F A Z B Z A)) '(Z Z F A Z B Z A)) (EQUAL (COPY-LIST '(Y Y D X B G B B D . C)) '(Y Y D X B G B B D . C)) (EQUAL (COPY-LIST '(D E X C E)) '(D E X C E)) (EQUAL (COPY-LIST '(X Z A C G E G . D)) '(X Z A C G E G . D)) (EQUAL (COPY-LIST '(F E F Y B)) '(F E F Y B)) (EQUAL (COPY-LIST '(Y B E A D D C X G G)) '(Y B E A D D C X G G))) (DO-TEST "COPY-LIST TEST 2" (EQUAL (COPY-LIST '(E F F B)) '(E F F B)) (EQUAL (COPY-LIST '(Z E D F . G)) '(Z E D F . G)) (EQUAL (COPY-LIST '(D A F G F B X D)) '(D A F G F B X D)) (EQUAL (COPY-LIST '(F Y C . E)) '(F Y C . E)) (EQUAL (COPY-LIST '(F D B Y B E . Z)) '(F D B Y B E . Z)) (EQUAL (COPY-LIST '(C E G F A D A B)) '(C E G F A D A B))) (DO-TEST "COPY-LIST TEST 3" (EQUAL (COPY-LIST '(QIX ZORK CATOR MEEF MORY ZORK FOO PERTY . FOO)) '(QIX ZORK CATOR MEEF MORY ZORK FOO PERTY . FOO)) (EQUAL (COPY-LIST '(BAZ)) '(BAZ)) (EQUAL (COPY-LIST '(CATOR MORY MORY BAZ QIX MEEF FOO . MORY)) '(CATOR MORY MORY BAZ QIX MEEF FOO . MORY)) (EQUAL (COPY-LIST '(FOO FOO QIX MEEF PERTY FOO MORY MORY)) '(FOO FOO QIX MEEF PERTY FOO MORY MORY)) (EQUAL (COPY-LIST '(PERTY PERTY MORY QIX MEEF)) '(PERTY PERTY MORY QIX MEEF)) (EQUAL (COPY-LIST '(BAR BAR ZORK FOO QIX . CATOR)) '(BAR BAR ZORK FOO QIX . CATOR))) (DO-TEST "COPY-LIST TEST 4" (EQUAL (COPY-LIST '(FOO CATOR CATOR BAR MEEF BAR MORY PERTY ZORK . BAR)) '(FOO CATOR CATOR BAR MEEF BAR MORY PERTY ZORK . BAR)) (EQUAL (COPY-LIST '(MEEF BAR BAZ BAZ BAR FOO)) '(MEEF BAR BAZ BAZ BAR FOO)) (EQUAL (COPY-LIST '(CATOR MEEF MEEF MEEF MEEF)) '(CATOR MEEF MEEF MEEF MEEF)) (EQUAL (COPY-LIST '(QIX ZORK BAZ PERTY MEEF CATOR MORY)) '(QIX ZORK BAZ PERTY MEEF CATOR MORY)) (EQUAL (COPY-LIST '(MORY QIX BAZ MORY)) '(MORY QIX BAZ MORY)) (EQUAL (COPY-LIST '(QIX QIX ZORK QIX PERTY CATOR . FOO)) '(QIX QIX ZORK QIX PERTY CATOR . FOO))) (DO-TEST "COPY-LIST TEST 5" (EQUAL (COPY-LIST '(7 6 8 2 8 7 . 10)) '(7 6 8 2 8 7 . 10)) (EQUAL (COPY-LIST '(7 10 3 5 6 5 7 9 . 7)) '(7 10 3 5 6 5 7 9 . 7)) (EQUAL (COPY-LIST '(8 9 10 8 9)) '(8 9 10 8 9)) (EQUAL (COPY-LIST '(4 . 5)) '(4 . 5)) (EQUAL (COPY-LIST '(6 9 7 6 2 4 3 . 10)) '(6 9 7 6 2 4 3 . 10)) (EQUAL (COPY-LIST '(7 . 6)) '(7 . 6))) (DO-TEST "COPY-LIST TEST 6" (EQUAL (COPY-LIST '(9 3 3 7 3 1 . 6)) '(9 3 3 7 3 1 . 6)) (EQUAL (COPY-LIST '(2 7 1 10 2 9)) '(2 7 1 10 2 9)) (EQUAL (COPY-LIST '(4 4 4 10 3 3 1 6 . 3)) '(4 4 4 10 3 3 1 6 . 3)) (EQUAL (COPY-LIST '(1 9 4 5 1 9 8 10 1 . 4)) '(1 9 4 5 1 9 8 10 1 . 4)) (EQUAL (COPY-LIST '(2 9 2)) '(2 9 2)) (EQUAL (COPY-LIST '(9 8 1 1 5 3 1 5 6)) '(9 8 1 1 5 3 1 5 6))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..693e62e3d996f572c3a235d7b4aff6867adaf3c3 GIT binary patch literal 2291 zcmcIlU1%It6uvW?pWS4)Z2p=MLmg@qSvn!R`Ei@#!(=j>Y_ge2XJ_+AD}-cYg2`@3 zcGXfWTEQ2mv`JH$qlhnp4+<6pp+;Iz5ENe&1fRr55kV1r6XH4dX0}N;B0>v$=iK|9 zbG~!Vz31NDX7#grM$wDw8>?&iO{G{aZInyOa&c4HDwa1F^U5;f%4OZMjaSAreWK@F zydir?v$&aGDCL(Fr<~tfTDWvZiT5g#3zwAm*<|vJlIR=iKRXnU_cWxmY({YT9y9r+ zg6|VQ%ApKi;S^Fc8^4eu_y~LZ^wNSMdE1^F z#7fj$*04RdDWQ~#8|qsA#rzr-v%bY7#=IMDFqJcPCvBPDP3cuB>|J*wX;YoT!n9F? z$-x5_VwXJkM0`L^sJb;Zr#iM_FifcNDr0g#W%Jp}-new9z}7w=muEUUo21%<97%k; z_dH|GSL>Ull{Tntnb2J;1BM^~8ID$Cpan$0d!FF$o>6)XDskY(dY;0GZ_j_G-F6$VR zvQ%y1STP6(!Vn2GV2huK8MbZNs+Du5a!xF80v*CJ&74y?o{a(adeh*8S0)@_3~K12 zG*i<*jZAeZ%bwI6TDBlb>-}PMEo%rm2%}p14Xs0!n?uMq&_d!{qe+Nr+nlye3w!L3-mdKJ2JjoK zlLCP{QvC97itoL5yqhwf$SK`6G{?X<%kMINFqyPt*jgqFVKT$rI-j!~Lsb72bP)F! z)j1Ckeiu4P?C^9b7h1h}WL4(T;R)o1Zb7;#Nb}XC{p7zONC!lL^xbg-=hL&5XPov7 zvDzuacIF^~GrR$oO|zPL%btJ)cjbP=8scbtpnyJ9!86c@$fRX+??B43AOSpfPbDby zLH~VbND4}HP5u{0M|H(vQ8E65Jb3hdRB;WjnEhBeRjPPco5!p$UL{o+MPv3|#R^7` zQSVhnXCL$E?8EBl2_pOeIxl1I__XwCML>TEST>15-2-COPY-TREE.TEST ;; ;; ;; Syntax: (COPY-TREE OBJECT) ;; ;; Function Description: ;; COPY-TREE is for copying trees of conses. ;; The argument OBJECT may be any Lisp object. ;; If it is not a cons, it is returned; otherwise ;; the result is a new cons of the results of calling COPY-TREE ;; on the CAR and CDR of the argument. In other words, ;; all conses in the tree are copied recursively, stopping ;; only when non-conses are encountered. ;; Circularities and the sharing of substructure are NOT preserved. ;; ;; Compatibility note: This function is called COPY in Interlisp. ;; ;; Argument(s): OBJECT - a tree ;; ;; Returns: a tree ;; (DO-TEST "COPY-TREE TEST 1" (EQUAL (COPY-TREE '(((D . X) . G) . Y)) '(((D . X) . G) . Y)) (EQUAL (COPY-TREE '(Z ((((Z . Z) C . G) C . E) . A) . Y)) '(Z ((((Z . Z) C . G) C . E) . A) . Y)) (EQUAL (COPY-TREE '(Z . A)) '(Z . A)) (EQUAL (COPY-TREE '((C F B . X) X Z . Z)) '((C F B . X) X Z . Z)) (EQUAL (COPY-TREE '(D . Z)) '(D . Z)) (EQUAL (COPY-TREE '(B D . B)) '(B D . B))) (DO-TEST "COPY-TREE TEST 2" (EQUAL (COPY-TREE '(((Z . X) ((F . A) F E . G) . F) (F G . B) . G)) '(((Z . X) ((F . A) F E . G) . F) (F G . B) . G)) (EQUAL (COPY-TREE '(F . C)) '(F . C)) (EQUAL (COPY-TREE '(B . F)) '(B . F)) (EQUAL (COPY-TREE '((((G . Y) ((A . D) . F) . X) B Y Y D . C) . A)) '((((G . Y) ((A . D) . F) . X) B Y Y D . C) . A)) (EQUAL (COPY-TREE '(((((B Z . X) . G) . Z) . Z) (D (Y E . D) . D) G . G)) '(((((B Z . X) . G) . Z) . Z) (D (Y E . D) . D) G . G)) (EQUAL (COPY-TREE '((((B (B . A) B . A) (E D . G) . B) . C) (F . X) (C X . Z) . B)) '((((B (B . A) B . A) (E D . G) . B) . C) (F . X) (C X . Z) . B))) (DO-TEST "COPY-TREE TEST 3" (EQUAL (COPY-TREE '((MORY . BAR) . CATOR)) '((MORY . BAR) . CATOR)) (EQUAL (COPY-TREE '(ZORK . MORY)) '(ZORK . MORY)) (EQUAL (COPY-TREE '(BAZ ((MORY MORY PERTY . BAR) ((PERTY . PERTY) . MORY) (BAZ . MEEF) ZORK . PERTY) (QIX QIX . PERTY) ZORK . CATOR)) '(BAZ ((MORY MORY PERTY . BAR) ((PERTY . PERTY) . MORY) (BAZ . MEEF) ZORK . PERTY) (QIX QIX . PERTY) ZORK . CATOR)) (EQUAL (COPY-TREE '(((PERTY . ZORK) PERTY . PERTY) ((((MEEF . FOO) BAZ . MEEF) (CATOR . MORY) FOO . CATOR) . CATOR) QIX BAZ (CATOR . ZORK) BAZ . CATOR)) '(((PERTY . ZORK) PERTY . PERTY) ((((MEEF . FOO) BAZ . MEEF) (CATOR . MORY) FOO . CATOR) . CATOR) QIX BAZ (CATOR . ZORK) BAZ . CATOR)) (EQUAL (COPY-TREE '(CATOR BAZ QIX . CATOR)) '(CATOR BAZ QIX . CATOR)) (EQUAL (COPY-TREE '(((BAZ . BAR) ZORK . MORY) . BAZ)) '(((BAZ . BAR) ZORK . MORY) . BAZ))) (DO-TEST "COPY-TREE TEST 4" (EQUAL (COPY-TREE '((FOO (BAR . PERTY) FOO . ZORK) . CATOR)) '((FOO (BAR . PERTY) FOO . ZORK) . CATOR)) (EQUAL (COPY-TREE '((((CATOR . BAR) (MORY QIX . MEEF) . BAR) (BAR (MORY . QIX) . FOO) ((FOO . MEEF) . PERTY) . MORY) (((QIX . BAR) ZORK BAR . BAR) . QIX) (((MORY . MORY) BAZ . BAR) . BAZ) . ZORK)) '((((CATOR . BAR) (MORY QIX . MEEF) . BAR) (BAR (MORY . QIX) . FOO) ((FOO . MEEF) . PERTY) . MORY) (((QIX . BAR) ZORK BAR . BAR) . QIX) (((MORY . MORY) BAZ . BAR) . BAZ) . ZORK)) (EQUAL (COPY-TREE '(BAR . BAZ)) '(BAR . BAZ)) (EQUAL (COPY-TREE '(((BAR . PERTY) ((QIX . ZORK) . MORY) ((CATOR . MORY) MORY . FOO) . CATOR) . MEEF)) '(((BAR . PERTY) ((QIX . ZORK) . MORY) ((CATOR . MORY) MORY . FOO) . CATOR) . MEEF)) (EQUAL (COPY-TREE '(FOO MEEF FOO . FOO)) '(FOO MEEF FOO . FOO)) (EQUAL (COPY-TREE '(((QIX PERTY . CATOR) . ZORK) ((BAR ZORK . QIX) (BAR QIX . MORY) . FOO) . PERTY)) '(((QIX PERTY . CATOR) . ZORK) ((BAR ZORK . QIX) (BAR QIX . MORY) . FOO) . PERTY))) (DO-TEST "COPY-TREE TEST 5" (EQUAL (COPY-TREE '(8 (7 8 . 6) . 8)) '(8 (7 8 . 6) . 8)) (EQUAL (COPY-TREE '(2 (5 (7 . 1) . 2) 9 . 10)) '(2 (5 (7 . 1) . 2) 9 . 10)) (EQUAL (COPY-TREE '(6 ((9 . 5) . 8) . 8)) '(6 ((9 . 5) . 8) . 8)) (EQUAL (COPY-TREE '(1 . 3)) '(1 . 3)) (EQUAL (COPY-TREE '(4 . 6)) '(4 . 6)) (EQUAL (COPY-TREE '((8 . 6) . 1)) '((8 . 6) . 1))) (DO-TEST "COPY-TREE TEST 6" (EQUAL (COPY-TREE '(10 . 4)) '(10 . 4)) (EQUAL (COPY-TREE '(9 . 5)) '(9 . 5)) (EQUAL (COPY-TREE '(((8 . 6) 9 5 . 1) . 8)) '(((8 . 6) 9 5 . 1) . 8)) (EQUAL (COPY-TREE '((((7 . 4) 9 . 4) . 8) . 7)) '((((7 . 4) 9 . 4) . 8) . 7)) (EQUAL (COPY-TREE '(((2 . 10) (((7 . 9) . 3) . 1) . 8) 4 . 3)) '(((2 . 10) (((7 . 9) . 3) . 1) . 8) 4 . 3)) (EQUAL (COPY-TREE '(10 9 (((8 . 6) 1 . 3) . 3) . 6)) '(10 9 (((8 . 6) 1 . 3) . 3) . 6))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..811b59c59ec50dcc5113cb96cd9548a1cf947ba6 GIT binary patch literal 4201 zcmb_fVQgDh6~6a9J8@E*q-oZ6@mRf*ti|mMani0yDp+2e=lCV|bMpMsH2Z<@VmJ1d z*jeIqE!|2IvH`-)mb&ZS9hwjz1e5qtTF__*3j=`=R6~e~NuZ%hAV46&;3xbD=iFKt~&Mp)KrwVg{`NG27WF~M5 zIi8hGO;g~8iSUW zw3LV*(-cFEYe9R>E_ommWh|+gc4=p4pjenyrZcBA)0oW6JfVcx&zC%rF(Yj03BxYa zMe4PmEBSOo8G*#qL5)bBiWl@w?b43WQKeJS^ueeVB@m5onGpFI4CO}lwIO;vPba=V zB#k$>?4<4~LU6!G$T~pyBFbjr`PFZecW|hJf9b$)IPf(G{<;Id=)hm7;;T;~n)ZPE zs|AGkL*`RXX4J{_JDDyg)9PgIaWDwM>0l5^ z<_8q+tJQEl=#_iEY9VpXdGqSSPSMt({dXIxs!V&{6*d20!j)I6;nqQ2-_O@kN~r1U zMkTQ623VTC>s6L+iiOV|cN?rKVZLCB*~VNWk?QOhO7{iB31dLV z^Q=TwV<4uPO1};gV=x(%Jj^H6!p{vq7c`BX!LVwDql&3nVFz*^Q$%&+;#U*;D zhLs31uk2$!c?UF#4+S;TOqfby%o-W9g0dG3yg}8NP`Er9WK^yP8C5r%5w;O%Mn|?c zBcF>9=E4?q06WTA@Lm&1m~quYHVsaiZzmR3lbV=8-lzf$OS=` zng2BNKgRr@WPX$RBh25+{O!zt5H`TBq-I4Fn959S=5asBo4I^jg1pv`Ks0W?U=W3D z!YiT1z{>A-JsK;8?ejNn4-nBxMuLG{{h!J&UK_)h+_i3gLqir z-y$9o_-(|xz;7WI{-s|b9u)F75l0061!7I$pCKL)_$P=(ZKWR}?iccPwhMxnKFjtY zImc6x3Y^flxRBly+z$m=gHpH>0|O(VPru0PazZmW_Y81yTsLs!GaRcY5#vsERkj_S zM+R1vTg(7MgQzowNI{fB^l?OOV*U?{iFdL<8wBploS9AK)3|)BX+QJtVckbSSzfS9 zwF~*j^Mxn#$Ub40yv59XF_6hkWsBJ^l+DPNm?Ek`CnZ;(~#)^KGcs zXP4{QF4oQzc9vlbXs+1|HAlr_zNP=NNmSV#N-y2U#0y zWgkKRJ=<+SD7|8T$u3Kf-~C}zQ!P!|c9dhfrI~6h$-JlryK!_ZVQFI3US>V$f^AK? z6J;;3<4AN!iAu7|T~q5s-ipjq=iA}E{XmO;yS!x-W$jEya^SsPpo(8;Haj(M2e8HQ z)@d8LA^kV622&wd)-QI!-+7YsuUnH0!EE$TJV|=PF3XFHODMSpPJep47qTkV8p}kPvUZKOVlGj92Po{D?)`U2oIg^_#04~e0%(4~L zKw1lTO+BK+jt8a=T8|YShqnZ3QT&1;yvXcJ63c*#gsDTf;pdy&vdeC;agD^rlAsPp z>yX%IZaAnYVh_Qv+tTA2GDk7ww;{+=g~BoA(bU{A6#N=CgRqh#i3ATq?pI9!mvGCv zKp0|806++U2UQ*D!eEwFhetQf5J8oMw}&>x z0=Wm_dXCVM3py#eAhm8FkX$#Kqi^wry;gD7gPu3#IJp>th;RrBhM9J-CcfRs&sX_U z|I{w~*aADlJ}r#dd0Y`J;4*(c%l)v0)yQfA*1ixD!Qeq9KM)DhG47t85UY1x6dt<~ z4^^u6B;c?uQFf5Qag^ADh}+NyFwkcpL~39XkRKL~idCZ{DC2@rF%d2z48z(x6JA0$ z7}huW^OedND2{_7UvzpBSDa348g6GE5h+|jSJ3^?+qWPc(OFRl%@qmu*AmSF#2g@- zYTYlEBwfUd_E^eROpQl$jX%GOPQL~tOL*$Zm!ba9ahH}rvbY3k)f#ZcGjw>xavl4U zyaaMS0XMk3qLSuwXnGM$=}I4IxFhF|NMDH4Y=+_?a#rP zuC~sn?Q(4eKVg?^1kAvx<7mPzyAZ@-C4j1sC6$gs2($(IlGP`DFG{aRC3*vH!b9RV z3{M^I(L;Ebh96#h#eh?qyHh0Y-v6u1$Lyk9f%`s=YKMl`&O(pKDy eV4X1G>4LXg5;c>S3D<5yxAs`_5>|O*W8=RhjHo35 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST new file mode 100644 index 00000000..6fadd61c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EIGHTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 7,1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-EIGHTH.TEST ;; ;; ;; Syntax: (EIGHTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (eighth list) elm)) ((or cons string) (equal (eighth list) elm)) (t (eq (eighth list) elm)) ) ) (do-test "test eighth0" (prog1 (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) ()) (mac '(1 2 3 4 5 6 7 8) 8) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 8.005) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) '(t . t)) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) '(j k) ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '(u v) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") #\o) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) "foo7-bar7" ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |Hawaii| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "to" ) ) )) (do-test "test eighth1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (eighth a) '(3 5 100)) '(nil nil t)) ) ) (do-test "test eighth2" (let ((aa '(1 2 3 4 5 6 7 (1 2 3 4 5 6 7 (1 2 3 4 5 6 7 (1 2 3 4 5 6 7 8 9 10 11 12) 8 9 10 11 12) 8 9 10 11 12) 8 9 10 11 12))) (and (equal (eighth aa) '(1 2 3 4 5 6 7 (1 2 3 4 5 6 7 (1 2 3 4 5 6 7 8 9 10 11 12) 8 9 10 11 12) 8 9 10 11 12)) (equal (eighth (eighth aa)) '(1 2 3 4 5 6 7 (1 2 3 4 5 6 7 8 9 10 11 12) 8 9 10 11 12)) (equal (eighth (eighth (eighth aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (eighth (eighth (eighth (eighth aa)))) 8) ) ) ) (do-test "test eighth3" (let ((aa (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm))) (setf (eighth aa) (make-list 15)) (setf (eighth (eighth aa)) (make-list 15 :initial-element 'rah)) (setf (eighth (eighth (eighth aa))) "magic kingdom") (equal aa '(a b c d e f g(nil nil nil nil nil nil nil (rah rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah rah rah) nil nil nil nil nil nil nil) i j k l m)) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL b/internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..70daa33193f69bcd3f439bb06b1787d84b5efe77 GIT binary patch literal 1267 zcmah|&2Jk;6rWwkU%?Je38Gm_7&YXw%7!{L&;$vz*-R2A>s@zu-89^cy{WBkb|ZfP zRYg_xz-cLU9ncJj11GK(oJtTqAg&xZaNxp?Gyg$&&&E(u5Qo*wd++yt`+FbLC+Vw( zNsZ|6s1^8a8uhwIy)He7+O!k(+I62EfS=wpY=^zStsA>buNNoX$0GH%U+ek}>h=6i zqjqDF7BA3p?FKEbUb?hMmtR@CxVly>E=_Lgt~ufwXYBcnaGXnadmCw)uqYP z&-o`(AtHp-$s;_ngcL}E@cVH=^_c5vn75Qz|eFV1XMEyF9>79U8rr5yh#&X+8$0)^>YjL4ZkS&&`gakjXkEo;o$s1VSS zz5^P5Lm}TZPj;k-A-VkRj=Wb;rln--le?+j*-zZ@ZtTJ@P>X=BD;$Bb#>vR)l(CBNXV(W zwXY5Rt}0*MkH9r0`+&hCn5UK2AJWH_{8A|IL3{%DsU@D*#O#7lW`*(;27l&px))v#qjy6zf8sIi`kgNI z!^RQSXsvy%cj$**+Un36tw&+U?;!3+9>3@z?))wNJUytvV{On@IC^R5yS0F@d(fz> zc!}XskN5yOmyqNHKbE0WlK$88!Nmv1x|rw3Nj^x6moSbd90nYNB*|vdkbSpy_iY|a zbqu^Uio2s@Ps~pwQ{dh}Jg!Lcif&e!n8(?suGnU^3CML>TEST>15-2-ENDP.TEST ;; ;; ;; Syntax: (ENDP OBJECT) ;; ;; Function Description: ;; The predicate ENDP is the recommended way to test for the end ;; of a list. It is false of conses, true of NIL, and an error for ;; all other arguments. ;; Implementation note: Implementations are encouraged to signal an ;; error, especially in the interpreter, for a non-list argument. ;; The ENDP function is defined so as to allow compiled code ;; to perform simply an atom check or a null check if speed is more ;; important than safety. ;; ;; Argument(s): OBJECT - anything ;; ;; Returns: T or NIL ;; (do-test "test endp - argument is a nil" (and (eq (endp nil) t) (eq (endp () ) t) (eq (endp (cdr '(1))) t))) (do-test "test endp - argument is a conses" (and (notany #'endp '((1 2 3) (a . b) ((a b c (0 9 8 7 (#\a #\b "c")) z s w) 4 5 6 . d) (value 10 volume 300))) (notany #'endp (list (list 10 20 30) (cons 1 2) (append '(99) '(88)) (make-list 2))))) ;;(do-test "test endp - (This is an error !! if) argument is an object other than nil or conses " ;; (notany #'(lambda (x) (nlsetq (endp x))) '(a 23 0.009 #\m "st" #(1 2 3) 7/3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6018e16838db04b028c14fd364ea39e3dbde5209 GIT binary patch literal 2105 zcmb_cPfR0K7=P2h{At&Lu)w-3JFsF*We6?cE-Y>w%9IwSGu@eKDv6hFDYV(rBD8K+ zBSDON(6QQO#d#Xz#fyoF8%$IdvmEqb3>V|wqX#dNc<|r>zi-N{{Ly%E{=E17f8Y1L z-+MLUeLgI4;nLz#zK~t!N|o|brOeHjmbsNuWjT}O=0VQA5>{04)u<4j8Mqp3(vD~{ z%h_}}JICpj?8;pFc0U&!(9QcB} z;NIWrLofXIwmNNcjM~)RS`Ocx1wvZay)2X4ekcRIUz>Sb{+5th?v6a|VEjPc?@YDZ zUO4**+0ADL%|Qbd@3DlSsb7uJH5UCZWr{w;~)D~%dvSDxBES#D-c%X$rxgS zj|%dnB&z&G3?%ZD7I1i}-{FSe1)ysQgathug*uNmtLb9g!JM|xl>qfQ z8$rPcj{u6$a{8&?*$m)26A)EZQF$e)Cz5)==>uC|K#*s7ORfbdps;1=B$yjrgisek zxCtTo5F&XZiW(PmWIu%Y>(dv|#x_mVBfK^npHL*;K4fTGrR^`%j%Fa4k0F-Z zDh#>z;W&C^%vwVBEqVc`Ram{bXHrmS_z5W~_E=dkmuMF%&)01pvnKKxJ-0-=a`eIr z^uk3{KQIk%rFgSgx>ZE>OVemBXIJ1h%g>i{Arx(y#zh@Py{kemH=l;PZH~(q>lYKs zR{PNG4Rgc429LSn!Dgu9BxQl{%!-nvq%7J!rHUf-2*j>LOrD`E?FQOCp(-g5qxTwy zT7($1mtLYz&_1-qqQLe^)WysX%?$@gyThs|=puh&)1;U#s)D3ZADTh$t|t{;theG> zYLz^Cti~Wl9icrikw4JKaF%mf7_-GWl>H8nfqeXJ-A{$aQSh6&;i|q^O;>MLEvH{B zCxD2-+(7-$C-@)D4X?xHY4H2bp!$1M*FV5G)^!bERDB1Quo^69eW0FzX5GVTnJ{Gy zCSz$V9=c1Tk3!XB&}*jQnuiA*yj*}=fWMB&9k8VR*vp8bjMQac;Z7Y92Vt!vZ0I;U zbetVNWa;&zKF`!6e{OD)VPS}^<=1lNbJjg19I(RI0^G~nv0Ci)DBM@JVvjwv*k_4p zoG+voZ_K3;U#Cv61Fll*1jCY0D4s;vCQ*tr-LTPKO;_RmNib*OWVun9AOyR*X(5I_ zZ6#^}fxKw}f!sL;gh4c3r#%TPyk}v#R9RX98pO`CFfeiHUp0|xWujWS3VXHo+GT5G Mj;~5SxOH&w7g&yQmjD0& literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST new file mode 100644 index 00000000..bb6a08f6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FIFTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 3, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-FIFTH.TEST ;; ;; ;; Syntax: (FIFTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test fifth0" (and (eq (fifth ()) ()) (eq (fifth '(1)) ()) (eq (fifth '(1 2)) ()) (eq (fifth '(a b c)) ()) (eq (fifth '(a b c d)) ()) (eql (fifth '(1 2 3 4 5)) 5) (equal (fifth '(nil nil nil ( t . t) (nil . t) (nil . nil))) '(nil . t)) (eql (fifth (list #\a #\c #\s #\g #\u #\r)) #\u) (equal (fifth '("infor" "system" (("division" "xerox")) "system" ("groups" (789 333)) "exit")) '("groups" (789 333))) )) (do-test "test fifth1" (prog2 (defun fun (list elm) (typecase elm (number (= (fifth list) elm)) ((or cons string) (equal (fifth list) elm)) (t (eq (fifth list) elm)) ) ) (and (fun '('foo1 'foo2 'foo3 'foo4 'foo5 'foo6) ''foo5) (fun '((1) ((b)) (c . "c") ((d d)) (((e e) e ) e) "ffff" | * g * |) '(((e e) e ) e) ) (fun (progn (setq a '(2 4 6 8 10 12 14)) (rplaca (nthcdr 4 a) '("a" "b")) a) '("a" "b")) (fun (fifth (append '(#\q #\a #\k #\!) '((10 20 30 40 50 60)) '("the" "end"))) 50) ) ) ) (do-test "test fifth2" (progn (setq a (make-list 10)) (setf (fifth a) '( red yellow green pink blue brown)) (setf (fifth (fifth a)) '!dark-blue!) (equal a '(nil nil nil nil (red yellow green pink !dark-blue! brown) nil nil nil nil nil)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-FIRST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-FIRST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..061c0e61bf0a2d058dc4311c1cbc31750d721802 GIT binary patch literal 744 zcmZWnTW=CU82xs+7NLR0OEg9&P5QFw5EgGOzPK(!fiAo4?hx8X0*eqSOSotnV`F^q zX^qlGGpq4G_*!f1gMY|>fV0rXrY19)$v59Q-#I5Ufyj=kA=TOIce?ffIpa}(JVGsJ zfQHU^(6CX9*U>B0Fv;tpqHd-i%Q5T1OJiWyM|Km@u{~_o_g9geL6!PGlGoSPR#Em| z?*4jCmea9-^|_+1OWEYjTWl9N=t^$j)XTtoPBT; zB^_^ZW6A~rF?z=0vkS~k$PaLqPcbbDTugY!SMj5LQWlPTu>G?v))sH2gizUZ77O_ca)#S3(neVW*Yf(}Wh5tLKA$jpY#7hLC z-0Gr4Ow%y2QKef|Dg_oeATBBTE}qpb$>W}r@}=k^0RS)P=Ot>KBwR4eib5Z8?A3pI zRmCE67CsO2w$O}ng-0INeSmh;yB;huH!|)$?>R4fdFEd6Q%19NGf$X%m)gS-T0T&g zQLD~BT@!VB^B?2a4ps#Al^uzE>>br43MKf`bge{*sc4oL_uIIF?W#eEcMZOv>GUr@ C65eb8 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST b/internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST new file mode 100644 index 00000000..06dfcebe --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FIRST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-FIRST.TEST ;; ;; ;; Syntax: (FIRST LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST FIRST0" ;; ;; The tests were incorporated in the test file "15-1-car-and-first.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..15ebd05e49f94ef30c5442daf8c18178efcc5a82 GIT binary patch literal 746 zcmZWnT~8B16urBJw%|e*;zu+_CnUUV7}6~op}x2-Q`)lKh27Z{9-DS+8_RCf4-GLA zveymPAmwswpuiE$Ohz`77y}G}I)C?+D_mR4`y1In2 zE4c@2IaOVr&TEb_<~m1Iyt;pmQ7>UKxojr4l3kuY`^G*CasU7|IE}9<02va%4ntX? z#GyD}Gzd1eGEvx&g=y{tyAH8gIG08Jpo81q3$GoU+3SG-z&?iQyld*TXqoItcq2&c zLpW13@fJ6xZ4eOC|5##nfrZ!9hd7J#mTS`ja5c%DSjLa$Nl7^NVf$xEtjyk-6DC_H z&j9A%rX-XqzL34mxK4ooySNiuKQWsN@K z*y|U1b!qmWj?guaZbrwo-%xD~M<_Qb$Q?J)Y z3kTW)YE=2!)lthI?@U}fSQOY-b|mt-_jH?Rl;A7ljUpwsW;l@)w{Z#Eu0=_71HPcM Fv%mG$-v|Hz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST new file mode 100644 index 00000000..a46241b8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FOURTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-FOURTH.TEST ;; ;; ;; Syntax: (FOURTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST FOURTH0" ;; ;; The test cases were incorporated in the test file "15-1-cadddr-and-fourth.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..83a50e00d57e913e43e54a6ebabae58cd8166ff0 GIT binary patch literal 2216 zcmb_dL2MgU5dFKh<0Oq+I|@y3Ti8S(%F>NuCqNpcs@u(X;$*#>?yl=bLP*B3>rlsz zY^SJ2R8@r#2ctGMRQubaN^s!7r9{1yRz#==K&lWI4j^&izy%Hni9-)nnAvZ;p+(|? zy!M-!KQsT$pZV)`5lD8m8w*$tW|S)sQ`BAEzPv(+q0@R zKl)0n*WR|0tLC%y{F3CX^ z$uE`LF|lniV^i_5sqx9t-mQ<^%R;z92+5I6gdRe|#7Epqjj-%c+ffopohpW!qO!a0 zHoBn_C2dp7ZA9Wyy|Sv5@~848EM}!f1VY@4jqXI+(43@cxJ}`l(C1!ggp!7`0EMYD zl!)D}ESOzz8$GcXmAIm-wnKnR=sY1}FB18pczaH`RVEkj%!!%Z(TEW6SPpDFpBVs> zsNCDw(~+ONni=qH>&xeg{B!#RA^qorVWD{IO9SLT*5}_h?h>+IeAk#0g%C(LhB8AK z)&BMovbmg#dMD8$AiUQm5QH4)2!WnMOaAzCa-moRBM9%b6M?!>->&4hE5}ae`Zpol zS0Y*m2$#QYXWy7Wb14KK@a*8b0zgovAD1BewM>8O6hLWL{D0Oh?rzuJ4J2T%?Z3rn zGzx4^mc){;w7=x{$Ot=u9yr1yv{;r#xBj~emx?zA|FsS4#qe?%2j;`ZURg7Z=_F2- zGOHTXI<=G|Nw63*wk!r&NDRQ&4`UmVHPz8(6^lA)3&u|K=C;dTv>lofg~vS{Q)Yd> z9#|06&WPi1`a)VPWz4oL^=-E`JT)0d-+PUqo#aG(TPzRPKNh zwCFKv*%bAgEQ)X)%)9Kx)Dcrx+E)?njO|5ea;UOF)Lvsl2%|v42hJ>v+H(wv3d3w4 z!V{3M3m8yi8r7Yk_N3H#s_03N2YKN6k)Jty&*3hIn;bsla2;AXU{fcdJi_k`8!WIP zg++&1G=jVQ0=opfQ$_73c&&69cw{=N-?0&dYv3cuC|yQLLFpn&FQDYGVFaD~9_FwE z>$KEaUS~I?-IX+8tW;g0I!#dn50?DNkOTRZgUj~4%7z^_GRsCJO!>fV1lP(Z%au3F zsNQ!Qp?bbnmrB`MJ&u;Y+{V)mT1L*QBT^v?ulFTsxy;|qXgm8Xy4`h~enIr@NBN9< z)oqHv?kUZpsza4WCPGg-)KYbu^`RS_&C#^!P+nr0c`4r5&Lf6N3(Pwm8Ai|RuW9nS z_i=+iVVbRuN5H}+Fh)cPt04CudQEt7=15n&(o2MFwcE-4s$?Z4n4kcn>~y& z6J2aD9%2a;)7&is77E2MlP$2LJYv)RKomrbz1@*Mg?$2O`owJppjCcPxeEW8-G|{d zr``+08tZo(drH}r*O#)`+Y@|0Y*maj><%IY$VQlVN|kyf)O@>2Yzm!(QU()7AsX7Z%l>|zn7v1uqh!DhxV XE8sIw2BU*maBEfg=eFcZd28!${D6UU literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LAST.TEST b/internal/test/LANGUAGE/AUTO/15-2-LAST.TEST new file mode 100644 index 00000000..1070043d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-LAST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LAST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - made PLIST for A even number of atoms in LAST1 test ;; because SUN complains if same variable is used in a DEFSTRUCT field name if odd ;; number of atoms in property list ;; ;; Filed As: {ERIS}CML>TEST>15-2-LAST.TEST ;; ;; ;; Syntax: (LAST LIST) ;; ;; Function Description: ;; LAST returns the last cons (NOT the last element!) of LIST. ;; If LIST is NIL, it returns NIL. ;; For example: ;; ;; (SETQ X '(A B C D)) ;; (LAST X) => (D) ;; (RPLACD (LAST X) '(E F)) ;; X => '(A B C D E F) ;; (LAST '(A B C . D)) => (C . D) ;; ;; ;; Argument(s): X - a list ;; ;; Returns: a list ;; (do-test "test last0 - test cases copied from page 267 of CLtL" (and (setq x '(a b c d)) (equal (last x) '(d)) (rplacd (last x) '(e f)) (equal x `(a b c d e f)) (equal (last '(a b c . d)) '(c . d)))) (do-test "test last1" (progn (defun fun (x y) (equal (last x) y)) ; (and (fun '(1 2 3 4 5) '(5)) (fun '() ()) (fun '(1 . 2) '(1 . 2)) (fun '(d k s i e u w d (k l j h)) '((k l j h))) (fun '(a b c d (e f g) h (((i)))) '((((i))))) (progn (setq a 1) (setf (symbol-plist 'a) '(foo1 foo2 foo3 foo4)) (fun (symbol-plist 'a) '(foo4))) (progn (setq a (append '(foo) (make-list 10 :initial-element 'rah) '(foon))) (and (fun a '(foon)) (fun (reverse a) '(foo))))))) (do-test "test last2" (progn (setq a (list (function +) (function -) (function *))) (= (funcall (car (last a)) 1 2 3 40) 240) (= (apply (car (last (reverse a))) '(1 2 3 40)) 46))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..24ff19c745285eeee20899d0141329d44b86d6ed GIT binary patch literal 3124 zcmb_eTWl0%6#i#sd)wW@7OFI*Ex*WhVG3O?a#3X1PU+I^Y}wsrAZldU3%fGxmc59C zKmhM%M3xH9kEn?zzL{V(F@R|!hUh~R9(*#InE0SiChCKUCI-*>|87eQi7%wPJ@@l} z=bV4eY?U&mY%gakVcL)>T6r)csD?u^XWh zbvUL+9lIq!%Y_luN;l>Bs392Z0*Th7DaIz|KelCVo?7%wLXoGMeZ7`Ng#P~|E@ZDRy6+=V z&H8daB70#uNZRx^z~@-@pl%oQ$j#10yTc!h7`-7}0cyWy^oI4Qx+?@4V|UCiH?etg zBYYd+TL)hkgtqvDT0GdVM)mk`6m~_BFPr+<{#aZel%;z;;t@adDQ@Of<}tT2A5ZUP z9>s@D5SSJ=Pgww)XP#e=Mk7%*G8`Woj{B8`;NbOZ#(tISV}2$ntr)Zqf*wLcO74GDD|^WBs-u} z4Nn^o6%3%f5mRbIL%Pw6;v(VY6@+ji|HYPoP5w=g+d}yb1S&Bdfym>GBDusCBRR`D zkZcxybzCX^!Ijc2fULl#W*%^nZbFWxL2W=+!=V^vl0Iikk$lV^LGqE1E(-FhP`)Ij zV}d*%?-Dqu541HBljfqV8Y0gY*-( zNZ$!^12WGK8E}EMu&RgkLEYdj`Gl>6Y|<4$&Ixh`veoS!hPRu@cuJ_tY!&(*71Czj z4e}2^jr_@vA-}NY&$4AETRy;+_kgovJ9a}Qe>h(_mPhe5$KF&YS%29E$5vEgWM$bc6Zt9gf6xG1dzV zpGEncV{e|-C(*BBx?CydOVFWw`WRi6DW*$V>o`po@}+cYHN{q8^c!pql6`=md6}EF z0^YTNmsc?4j4GgA!CKL0hmgPrCFsU|BHX+lwgu3#tpcXRVM_lxwr2(=4qW=1pDm4_ zJBHF#K|XNamL(Y#)oCu{jJj&*&~jjoY{Fuiql!ACO?Rn8O*pcCm?>1n$G1n!7p^V~ zpluMCb$GyT7*umpV?#X(nlswWg*ulaOQ_lETq5qB+D>>Q!DrW`k2v;XD{CML>TEST>15-2-LDIFF.TEST ;; ;; ;; Syntax: (LDIFF LIST SUBLIST) ;; ;; Function Description: ;; LIST should be a list, and SUBLIST should be a sublist ;; of LIST, that is, one of the conses that make up LIST. ;; LDIFF (meaning ``list difference'') will return a new (freshly consed) ;; list, whose elements are those elements of LIST that appear before ;; SUBLIST. If SUBLIST is not a tail of LIST ;; (and in particular if SUBLIST is NIL), ;; then a copy of the entire LIST is returned. ;; The argument LIST is not destroyed. ;; For example: ;; ;; (SETQ X '(A B C D E)) ;; (SETQ Y (CDDDR X)) => (D E) ;; (LDIFF X Y) => (A B C) ;; but ;; (LDIFF '(A B C D) '(C D)) => (A B C D) ;; since the sublist was not EQ to any part of the list. ;; ;; ;; Argument(s): LIST - a pure list ;; SUBLIST - a pure list ;; ;; Returns: a pure list ;; (do-test "test ldiff - test cases copied from page 272 of CLtL" (progn (SETQ X '(A B C D E)) (SETQ Y (CDDDR X)) (and (EQUAL (LDIFF X Y) '(A B C)) (NOT (EQUAL (LDIFF '(A B C D) '(C D)) '(A B C))) ))) (do-test "test ldiff0" (progn (setq a '(1 2 3 4 5 6) b (nthcdr 3 a) c (nthcdr 5 a) d (nthcdr 1 b)) ; (and (equal (ldiff a b) '(1 2 3)) (equal (ldiff a c) '(1 2 3 4 5)) (equal (ldiff a d) '(1 2 3 4)) ))) (do-test "test ldiff1" (let () (defun fun (list n diff) (equal (ldiff list (nthcdr n list)) diff)) (and (fun '(10 9 8 7 6 5 4 3 2 1) 5 '(10 9 8 7 6)) (fun '(( a b c d) e f g h (i j k) l m n) 1 '((a b c d))) ; ; sublist is a nill ; (fun '(a b c d) 4 '(a b c d)) (fun (make-list 200 :initial-element 'quack) 190 (make-list 190 :initial-element 'quack)) (fun (make-list 150 :initial-element '(1 . 2)) 100 (make-list 100 :initial-element '(1 . 2))) (fun (make-list 125 :initial-element #\w) 75 (make-list 75 :initial-element #\w)) ))) (do-test "test ldiff - ldiff returns a new (freshly consed) list" (progn (setq a '(a b c d e f g) b (cdr (cdr (cdr a))) d (ldiff a b)) (and (equal d '(a b c)) (rplaca (cdr d) 'w) (equal d '(a w c)) (equal a '(a b c d e f g))))) (do-test "test ldiff - 'sublist' should be a sublist of 'list' " (and (let (a b) (set 'a '( l d i f f)) (set 'b a) (eq nil (ldiff a b))) ;; (prog2 (setq a '( l d i f f) b '(t e s t i n g) c (append a b) d (append a nil)) (and (equal (ldiff c a ) c) (equal (ldiff c b) a) (equal (ldiff d a) d) )) ;; (progn (setq a '( l d i f f) b '(t e s t i n g) d (append a nil) c (nconc a b)) (and (equal (ldiff c a) nil) (equal (ldiff c b) d))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3c7f9b64683a557cc025738a042c096ebf426107 GIT binary patch literal 2775 zcmb_eO-vhC5PrLBz<{AkMEPq7FC;{%m5pK((uAlgi&?P2tf_Y?p*=*dF|3KPsejT& zQ6dznRikc|5YlvC+uVBS5pfD63Q{XoY7af7?Wwm)y;Mph4mspNXZB%ANR;*v+3R`p z^JeCoH}lqur0Ps4N<+E1`E(|gr@2ybzEq^sxjZf8O8I1pPJ^6Y48`KwrLYO8aQ?Gmf4|)14(@LGU@(?7E1qi~%rpNF$E5t7(bCo+RLl^0rD~60t=`vR{b+IIbNvU@eWDMGLLID@TPE7jbNTTRvYt-v zbvS%c-{X`{J?)hN+E;!m}1; z%+GvMEhvOD+hc|UBKcUIR0AVa@7Ln-SX_yXn`7gqU#bUNpI_A{6<2Qf8O%~c&+d_| z^$@~5IEd{yQs==_Nh|w!7wu!xz||>l7rx)dQ=_J z+?hp52Wv&r!u8dh2rdyepni>pW)3RG^t2a+{NzoY<^whBX~a^H1)!6*zY8c)wpqSluH7DINfJ9N(4gK~^0F>=kR8Ch2AGUQ<7AMNAs|aQ zH$s>TBAg6!GU6VM@WfdXB@eh19>YoyarF@1UcNpRZX~z}`Zr}bI@aLWuVoT*?@uKV zz%vs8CXzc5kRsX&lkmJNRx&EVDORduW12nyM(F-G=W7TBiR}x;HPzIVU9%F6m|9$o z8q9}g&;xIe$4rf%;?L|5y7@v5?JAF4&!C#q@&p@xQGIX8?ns&^~;5ABePZuD`4xM%E)4PEm1K``33oiuy P9y=^N?UQ`ag<~e8 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST new file mode 100644 index 00000000..4c9cb4ae --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LIST-LENGTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 265 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-LIST-LENGTH.TEST ;; ;; ;; Syntax: (LIST-LENGTH LIST) ;; ;; Function Description: ;; LIST-LENGTH returns, as an integer, the length of LIST. ;; LIST-LENGTH differs from function LENGTH when the LIST is ;; circular; LENGTH may fail to return, whereas LIST-LENGTH ;; will return NIL. ;; For example: ;; ;; (LIST-LENGTH 'NIL) => 0 ;; (LIST-LENGTH '(A B C D)) => 4 ;; (LIST-LENGTH '(A (B C) D)) => 3 ;; (LET ((X (LIST 'A B C))) ;; (RPLACD (LAST X) X) ;; (LIST-LENGTH X)) => NIL ;; ;; LIST-LENGTH could be implemented as follows: ;; ;; ;; (DEFUN LIST-LENGTH (X) ;; (DO ((N 0 (+ N 2)) ;COUNTER. ;; (FAST X (CDDR FAST)) ;FAST POINTER: LEAPS BY 2. ;; (SLOW X (CDR SLOW))) ;SLOW POINTER: LEAPS BY 1. ;; (NIL) ;; ;; IF FAST POINTER HITS THE END, RETURN THE COUNT. ;; (WHEN (ENDP FAST) (RETURN N)) ;; (WHEN (ENDP (CDR FAST)) (RETURN (+ N 1))) ;; ;; IF FAST POINTER EVENTUALLY EQUALS SLOW POINTER, ;; ;; THEN WE MUST BE STUCK IN A CIRCULAR LIST. ;; ;; (A DEEPER PROPERTY IS THE CONVERSE: IF WE ARE ;; ;; STUCK IN A CIRCULAR LIST, THEN EVENTUALLY THE ;; ;; FAST POINTER WILL EQUAL THE SLOW POINTER. ;; ;; THAT FACT JUSTIFIES THIS IMPLEMENTATION.) ;; (WHEN (AND (EQ FAST SLOW) (> N 0)) (RETURN NIL)))) ;; ;; ;; See function LENGTH, which will return the length of any sequence. ;; ;; Argument(s): LIST - a list ;; ;; Returns: a number ;; (do-test "test list-length0 : test cases copied from page 265 of CLtL" (and (= (list-length '()) 0) (= (list-length '(a b c d)) 4) (= (list-length '(a (b c) d)) 3) (eq (let ((x (list 'a 'b 'c))) (rplacd (last x) x) (list-length x)) nil))) (do-test "test list-length1 : more test case copied from page 265 of CLtL" (progn (defun list-length2 (x) ; ; list-length could be implemented as follows: ; (do ((n 0 (+ n 2)) (fast x (cddr fast)) (slow x (cdr slow))) (nil) (when (endp fast) (return n)) (when (endp (cdr fast)) (return (+ n 1))) (when (and (eq fast slow) (> n 0)) (return nil)))) ; (and (= (list-length2 '(4 3 2)) 3) (= (list-length2 '()) 0) (setq x '(1 2)) (eq (list-length2 (rplacd (cdr x) x)) nil) (= (list-length2 '(8 7 (3 4))) 3)))) (do-test "test list-length2 : for non-circular lists, the function returns an integer" (every #'(lambda (x) (and (setq a (list-length x)) (integerp a) (not (minusp a)))) '( () '(1 2 3) '(a b c d e f g)))) (do-test "test list-length3 : for circular lists, the function should return a nil" (notany #'list-length (list (prog2 (setq x '(1 2 3)) (rplacd (cddr x) x)) (prog1 (rplacd (last (setq x '(a b c d))) x))))) ;;(do-test "test list-length4 : CLtL didn't talk about the behavior of the function when the argument ia a non-list." ;; (notany #'(lambda (x) (nlsetq (list-length x))) '(a 23 0.009 #\m "st" #(1 2 3) 7/3))) (do-test "test list-length5" (let () (defun fun (x y z) (= (list-length (append x y)) z)) (and (fun '(1 2) '(3 4) 4) (fun () () 0) (fun '(a b c d e f g (h i j k)) '(2 34 5) 11) (fun (make-list 30) (make-list 20) 50) (fun '(((((a))))) '((((())))) 2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..278b2db7565a4d1a73e396b3c3a82c16f1252db7 GIT binary patch literal 3434 zcmdTGZD<>1_`SQdO|!-|+sbBI>QVRAxa*d7U+p%wYkKX{T`o0uUE6_ROw%S?mXtP~ zPTAZSif}r+>UOVF1O-t+nKG1ZvceRRA)+wE9|J`Z87Pj4qA1SidEcbV)@_LT$2OPe z%Xwy#;v=SGxFa#u2g$?O~>0wK=Rw!5>}2wCB%;Y79u&hHb-GE&AhObC23 zu9P4DQ10V1z?gHOVu6r4b=Cm<^2C-WjrR$eNIhnBi-H%h6ASw4QMUM05i*rd$SmQ4 zAHh}hQ-M<4PXYVyot-Q?b8|q#s89M_oegLGY)=^|mH~aMh;K9N zM^Y!|-*ng~Qq}2dB33!i+I4|Y)aVG~5mh#;Mu)D&l=d)ij4m@E&Z1t?3r{8NfO&ie zgmg_cdV7@4Xe?p|s35xGeFZ#a@VG$E7YM0VXtNU2tlk)$^$=SY<>r8CX%SJFDPcte z)FXM|g{Z32iv?GLbO-fHvteo65zu0>XiSOrT0Om1K&l4es(@+?D2$JBNIu{RD)mWo z5a|bGE+PYf%tK@w^}(WAb>pJ)z;sX-uBQdKZw&BOj=8B8lC7XQ?^=aIs;P08)Pt`D zkS*}4I(rsrTeaALVnShc4Y^;_dIT3i$%QKqiPw8gY-bAO6GoBKv@T9-BeZTgh)B!9K^bcUQcGazmm63= z%t5N9OA(aQ`2fVqc%6yD+B4U|kiG!oAaDo_S4`8qJA zY3fCai3;~~^?t6WbKu3$w{Wcr#Jf3;CqW2v9A{qG%y9B2;$0m79q~?%|BATA@t+az z;P@59c~s;_+6Zxw?^!X(2^J1{mBm4x=io^YFE`;JTiiE!3>cL$ty9-RmR7KN5O|V_ zqZFb`*3qTQ>C$@ISW9bIueu$(Vm!Men|m+|-lR^)_U4mgc{!6F%dbLCyJO#FA*W%l z+8__b;leT~r?dRFfxNwoP^`w8bRXKdfAJ++<2)luaKxlTo5ux@j->}Gqi;msY)~><+()cxu-7H!AShI>< z+G`g2)`a$6f>5jACx-tn`u|42BHNf)K)Y(;!ov1|L+{vgi=<|34acHJL^CW%i^>F3 z5}ueD`olc*U5?!_J!dVlBEw}BFS-|ucC>{y z)8MTYz}Ejz2TP*-lcYeAd_JQeuy)TRX+fd@)gi>MkL~6NjZ@lNkj98Msqvmk@#>@ZeG1c f&JD>SJ+JrDjg1h4CML>TEST>15-2-LIST.TEST ;; ;; ;; Syntax: (LIST &REST ARGS) ;; ;; Function Description: ;; LIST constructs and returns a list of its arguments. ;; For example: ;; ;; (LIST 3 4 'A (CAR '(B . C)) (+ 6 -2)) => (3 4 A B 4) ;; ;; ;; Argument(s): ARGS - anything ;; ;; Returns: a pure list ;; (do-test "test list0 - test case copied from page 267 of CLtL" (equal (list 3 4 'a (car '(b . c)) (+ 6 -2)) '(3 4 a b 4))) ;;ROACH 25-JUN-86 This test fails because Xerox's Lisp has ;;an upper limit on the number of arguments a function can take. ;;This upper limit on the number of arguments is currently 80. ;; ;;(do-test "test list1 - can list take 100 arguments ??" ;; (equal (list 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999) ;; (make-list 100 :initial-element 999))) (do-test "test list2" (equal (list "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" Shanti))) (do-test "test list3 - nested list functions" (and (equal (setq aa (list (list (list (list (list (list (list (list (list (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k))))))))))) '((((((((((a b c d e f g h i j k)))))))))) ) (equal (list aa aa aa aa aa) '( ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) )))) (do-test-group (more-tests :before (defmacro mac () `(list ,(* 2 2) ,(list-length ()))) ) (do-test "test list4" (progn (setq aa '(a b c d e f g h)) (equal (list (last aa) (nth 3 aa) (nthcdr 5 aa) (list (car aa) (endp aa)) (progn 1 2 3 (setq x 1 y 2 z 3)) (prog2 (defun fun () "fun1") (fun)) (prog1 (setq a 100) (setq a (1+ a))) (mac) ) '( (h) d (f g h) (a nil) 3 "fun1" 100 (4 0)) ) ) ) ) (do-test "test list5" (equal (list 1.009 'a (cons 3 4) (funcall #'list 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0)) (apply #'list 'm 'n 'b '(88)) (list (+ 2 3) (caddr '(w x y z))) ) '(1.009 a (3 . 4) (2.009 #\g "string") t nil (m n b 88) (5 y)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..62c279a7ee0ca519767464c1950bf9a2cf443c15 GIT binary patch literal 3672 zcmd5M{qpLjCfZ9iZsEEV(h;*9DvinW>ijpJ&3KuzawsPS`W&mLD3gTtrJ4aegr zx<_=|6uyEHx#CPE7!!YB%)oFWF+2c6?%(lWC*i6jNd>8iO_wBvC0X)sd*PU4*p4=m zG7Zhr(?-l+_PtJsM4PmYtnckgsP*ci<`$nRx){ttO(K%yf7R<8nY5BlDr5O87#~3J6m4RJMq2l_-QSnnJL?`9X%@npYV&4q+CNXKP=rFCvR4y@4Yon zbJ6H7(l#ea8^35Yik;Ti_HU?A4%Ex#o28qjdtiI)#g09s^yb?Z;6E>4e$9GEl9o$f zu*NCr1$4JBw;u-vPe_uQ<-$Rpjur#*UcjKEBES28_=BMTw}0*cBm)BJ5phEv*4GYT z21G7f2z?@4->yW`J3%5lTT{5QtMEBc#s?Sy2iS)w0I!me1TT1_y1Px1T-*#n(5PJB zp0$>*1{Ax{YoV{1>jO5qK1wO!Z%T80fIu0YFC1>Vw9wyl<-*YxIpEyv1b#CG_3fNG z|MP;{#GTg)rwI^#*vVBsT?zsaY2Ky?{t-mbD<=Cd?~VDRg+89dwLQ7M;17*lxn0Yz zyc#g;acN2TUONNyAeWFPSApF?=UpYI?pXNO{k47bE_G$W0WyVD0zMyv(e2XRz3+Rp zmrLPtSfV}t*S!6)WX8Ib!g8gJ>DDFF$Z8i;ps_~n80}@fv_ zo#dF7HJr&T)V3rqj_vle?HFlFw)Su`F&2_TV4%9bQAn`_%H6D2-T_5&N6g4(Gg&P& z=}b&IF?lC+4#jk9TH|^<#)upS9no1>-i6=_fX5I_1K5q=lPnB{dFau?9D?o06fDP4 ztgTZpTl+{Ro7No^br>1h%tBJP4KXDPfm!|&^xkPtr!QtqEvW3Me}|zn`MYc%HctrY zLtLW2hRp7^4QE74>&a~9!Ey8#V2g0uR;RQHTx6Jq;Uz%tv4hxr3m7Pdb!h^HTPT>i zjnwHJpOxBT)AH^?Q$}`Lvtd=S2u?C5L;o(CUqQd#;`PORWd;|K51_vUrMw~ilwkts_t_zAQrrvG z#qiUj>1TV;wwDcJ6T!J#Ys+_VTDa|D{a_~l>vJ5G*#hr1=;r!AEGW9N#)xSo9YaJ-ZXj8^wU@{>SeTtD3r@OjYKCc~4a<3&JwC~frP#4S zmKb1z8jGkbet;#SY;Z4&3;+uSK6E-7mHA5b*$Rr5?+w+9wYut-YxUS^Ra4bt9IDr! zP|G#7_?brenY>%9)Zq-O*VU&M^K(TtF?9B696j!Pha4Pz_<8-XI-7^jz8SS#5#Ma6 zd;SP^`>?+%`zsXQgaRN+n@93!i1@2Cz};v7rTkj}6v0pYZ{Vog-oa$n&>cg23> z$H?lY%|h4>Hti=SGmatFzRAv`i+jG;zZu>s2oF9V@zYbpINPWc>g8&shJD{)7qIz~ zzq-?3?O_oHNn~+0z)rFgOk>B{$5?C|4evhzGN}K@S3Y!cltB`btwe5SL-4VOTM?y%`aS= z$>XYSDZ_AmQC@~I|6ZuSzf~NeTKL}XKs2nWR5oMb{*(w|{Su$*4VbDOFTf8lNvqbw z8G`R?&X>D*#b4=sG>aHTbxVe5foF(beJDc-?EI9-&`HS9%NJfa`g?|ZQdVHEzWi}% zrEzP{Yp>Op%9XhnZu+YVJHv+9;FUH}1)`9{E9e9^wL+ElPQc`EelP;1zuua|=8xPN zqTldY5Up>aNq)p>lD8hB8OP2);55mX{na)&!0=y`3Q%HCvSE;5Y0Uh5k)6YipWjrV z*x2li;yeTgt^98Al3se4#k1^u&G$}iZleJ>Gh8aCML>TEST>15-2-LIST*.TEST ;; ;; ;; Syntax: (LIST* ARG &REST OTHERS) ;; ;; Function Description: ;; LIST* is like LIST except that the last CONS ;; of the constructed list is ``dotted.'' The last argument to LIST* ;; is used as the CDR of the last cons constructed; ;; this need not be an atom. If it is not an atom, ;; then the effect is to add several new elements to the front of a list. ;; For example: ;; ;; (LIST* 'A 'B 'C 'D) => (A B C . D) ;; This is like ;; (CONS 'A (CONS 'B (CONS 'C 'D))) ;; Also: ;; (LIST* 'A 'B 'C '(D E F)) => (A B C D E F) ;; (LIST* X) = X ;; ;; ;; Argument(s): ARG - anything ;; OTHERS - anything ;; ;; Returns: a dotted list ;; (do-test "test list*0 - test case copied from page 267 of CLtL" (and (EQUAL (LIST* 'A 'B 'C 'D) '(A B C . D)) (EQUAL (LIST* 'A 'B 'C '(D E F)) '(A B C D E F)) (EQUAL (LIST* 'X) 'X) ) ) (do-test "test list*1" (and (equal (list* 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999) (append (make-list 48 :initial-element 999) '(999 . 999))) (equal (list* "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" . Shanti)) ) ) (do-test "test list*2" (equal (list* 1.009 'a (cons 3 4) (funcall #'list* 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0)) (apply #'list* 'm 'n 'b '(88)) (list* (+ 2 3) (caddr '(w x y z))) ) '(1.009 a (3 . 4) (2.009 #\g . "string") t nil (m n b . 88) 5 . y))) (do-test "test list*3" (progn (setq aa '(a b c d e f g h)) (equal (list* (last aa) (nth 3 aa) (nthcdr 5 aa) (list* (car aa) (endp aa)) (progn 1 2 3 (setq x 1 y 2 z 3)) (prog2 (defun fun () "fun1") (fun)) (prog1 (setq a 100) (setq a (1+ a))) (progn (defmacro mac () `(list* ,(* 2 2) ,(list-length ()))) (mac))) '( (h) d (f g h) (a . nil) 3 "fun1" 100 4 . 0)) )) (do-test "test list*4 - nested list* functions" (and (equal (setq aa (list* (list* (list* (list* (list* (list* (list* (list* (list* (list* 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k))))))))))) '(a b c d e f g h i j . k) ) (equal (list* aa aa aa aa aa) '((a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) a b c d e f g h i j . k) ) ) ) (do-test "test list*5 - (list* x) is equivalent to x [page 268]" (and (eq (list* ()) ()) (eq (list* 10) 10) (equal (list* '(1)) '(1)) (equal (list* (list* (list 2))) '(2)) (prog2 (setq a (list* #'-)) (= (funcall a 4 3 2 1) -2)) (equal (list* (list (list* 1 2 3) '(4) ) '(5 . "a")) '(((1 2 . 3) (4)) 5 . "a")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a8a1cc2ca31d50ee972d7a07503698b484afe40c GIT binary patch literal 2530 zcmb_eVQdp+82;|Mt=m{f#|n&XumhZ6!;!TEvQ1)kD>vHhdfo1>j1gi|)|M7-ZEZUc zjbs7En4CyifcqdOMvXsANRSwli8vGeA(0;%|Cs0xjs7yxkZ8is`M&q9Y&aAC*!KFo z&+~ove&74v`+jYOxDSUEA(WpkWX)7j$j_7uGi4#2FAAmnOmQkDq(K*64#hP2m9P{V z-TiE!QC~4KRZJzysia`cq)N%enO#DlM~EiQ2!Z~-zFk7FcVJKdKp?QYaaht7=Bs+g zL@Jr9-V<1HPtQOwI1udL-MIL+eU=lDzR2r2{d&PPu=()pQ*v1U_q)l-bN3VC&Ago4L&V=PK9_Dx+_zUlLNuTu?`N&I8u1 zwh15JU%i?LS;$UpaFVdJEElUT>o$4tf>Wz&+)l5S##c-GS4%q_$@Dz(kd*2JL*DC$Ao&%3FIuZ61y%D%-Pl8jJT)MO*BLD`0!y06nGbwiHw z-0B%d%ukzK4b2#%?fniLuuidx^0kV_8VGPnV5hQJ;(s#T2o66ySo- z(@hBdv=yP7`T)q^5NX4s?nmVp+K%uogS!kqWN?kP7ijBI>g%QLTWNb6ZO4fC&ETZg z$uF|?a0b<>m^=k(1MLLhes)q3i?LMvKsTd!8bnTFQl4%>=@<)Wf(6t;J5X$8KHLtF zKVX5i5f!RQQbbviqq2(GCO^?GgnJA=VelS9-G(2FJIrl_0&?qy28)kD)Vv3FRRv$3wwv32Cxq$l||_0VQI{nxyEo38z6DjK^b!%&K-T#p2=uwiSK6ngmgpDP?oV zg=99JP8CzRvQR!#NR@W~v3a1h#{0Bj&BHa!^ z9^$HVJjcFJdEijAegn(nLF;?4E*35p(7w;$3y>i7r}090zG~dWfjOQIVQa#{<=Au_ z=X|ijz7F=QgM)-PUpPAFST8#Hq7s|hVbZM`+uHkh_yLIDQKk|l2zn}C$U-Bfi}`7x k5Zu>?SqLd*B}upMgCeE^zMrz^YG?7qJ-z_Bo>*M`2P}Th(EtDd literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST new file mode 100644 index 00000000..d3f6f51e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-LIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 268 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-MAKE-LIST.TEST ;; ;; ;; Syntax: (MAKE-LIST SIZE &KEY INITIAL-ELEMENT) ;; ;; Function Description: ;; This creates and returns a list containing SIZE elements, each ;; of which is initialized to the :INITIAL-ELEMENT ;; argument (which defaults to NIL). ;; SIZE should be a non-negative integer. ;; For example: ;; ;; (MAKE-LIST 5) => (NIL NIL NIL NIL NIL) ;; (MAKE-LIST 3 :INITIAL-ELEMENT 'RAH) => (RAH RAH RAH) ;; ;; ;; Argument(s): SIZE - a number ;; INITIAL-ELEMENT - anything ;; ;; Returns: a pure list ;; ;;ROACH 25-JUN-86 These NLSETQ's don't seem to protect against CL:ERROR's. ;;I've therefore disabled this test. ;; ;;(do-test "test make-list0 - check syntax" ;; (not (or (nlsetq (make-list)) ;; (nlsetq (make-list 'dfd)) ;; (nlsetq (make-list :initial-element 3)) ;; ;; ;; ;; check spelling of keyword :initial-element ;; ;; ;; (nlsetq (make-list 3 :initial 2)) ;; (nlsetq (make-list 3 :initial-ellementt 4)) ;; ;; ;; ;; size should be a non-negative integer ;; ;; ;; (nlsetq (make-list 2.0)) ;; (nlsetq (make-list -1))))) (do-test "test make-list1 - test cases copied from p268 of CLtL" (and (eq (make-list 0) '()) (equal (make-list 5) '(nil nil nil nil nil)) (equal (make-list 3 :initial-element 'rah) '(rah rah rah)))) (do-test "test make-list - using different types of data objects for the initial values" (and (equal (make-list 2 :initial-element 3.0) '(3.0 3.0)) (equal (make-list 2 :initial-element ''n) '('n 'n)) (equal (make-list 2 :initial-element "w") '("w" "w")) (equal (make-list 2 :initial-element #\p) '(#\p #\p)) (equal (make-list 2 :initial-element 10) '(10 10)) (equal (make-list 2 :initial-element '(1 2)) '((1 2) (1 2))))) (do-test "test make-list3" (let () (defun fun (size &optional value) (make-list size :initial-element value)) (defun test (list size value) (and (every #'(lambda (x) (cond ((or (listp x) (stringp x)) (equal x value)) (t (eq x value)))) list) (= (list-length list) size))) ; (and (test (fun 10 'a) 10 'a) (test (fun 100 #\q) 100 #\q) (test (fun 50 "s") 50 "s") (test (fun 50 -1) 50 -1) (test (fun 200 (* 2 7)) 200 14) (test (fun 40) 40 nil) (test (fun 30 'foo) 30 'foo) (test (fun 25 '(1 2 3)) 25 '(1 2 3))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cfa91506d3f2e25d814141b93985190a595c5595 GIT binary patch literal 4030 zcmcgvYit}>6~1?7{a!ok)={>09#h9@lf~m?H%@T_sGh9H@jAP+?(RBUlL~3OJI-!1 zyX$&)Nkd8MRHzZs7V20nb179zMRjSQQY1i>A4o;05|Q}94^)M7 z?w#=?t`vR*WY3&?&iU@S=QU?$7fH(#;iwWW7v~C=Ij@v!)wx<#nJv#Nm2z!9YbvuK zSDp*U6Z+W+EqrX~Q^EG+I!$)o%v8;slB$`NT;|N65;YSY# zgG24(S~4nZxjWKkuH^0suG@3qa42+m_>rOZ+ppWNQeT-6k|oPX+6eIxnb;TWzCcP( zrquCBR96ixrU&dryWR?ssMAS3Vb{AuO0_(vTIT0X3xg?E2qnaRx!yWHZG=;ixM45R z1?siGTJMY)>J$W~9o31{>R3VR)ULM&52+#5I5M4zYRMDbLLUFFpCshI7g~B~{_0N+ zSl?Pa_LA{)1iolYO0*MJm;LFTxZSd+K-wQST3zXF04Ts&pLoc(F#GF@DJW){f#HB9jmO>v$}-9v%QVa za0BVyl}0e_N3s`fv~IrNqeT49O+;Hh>t84x8tsEpY>wgV&InXWU-6nCPxi>M$-*IE; zgmgQ}Ty_p$wnFGcZ=(QSgun~T`U#Qzgw?|xT((*S<}tvuI~cb>))ogN3(Qu)cm?Ja zZpID9rS~Q%&%7H{$GV_IJHhG8|GiLDXqk7GL?H;+daJR=tx_*nxblr%clS`BLAHJD z)4Z7X6?{bMuwSWf4}{~!SOlk(I-wb3Q9Yp^iGaj7nhZ#ttW#=(s}-&mxSHVdz)0*4 zgtb(7LQUwY=>&|lFrSId$(dwIk4bbhA{7rXuj~Z{)mFzR4nDaZWk;A#?qZ$t7MPJ; z0X>n3C)D_KYHB(akbMB~1~g+v{JQMnsr@_0PXd@z0=xpVw_n+aha9J(Q#pfNDo zJRVQPv=p)AHsCUztq-Jtvh+m4v)YzLCdg8R1M&NDv>i|hd;A#u{fJm6`A z`B1ov?L^WgbTa3pe+%+=E|lIE+)Y7#%S}r^;HD*;o0f6{`B{juEv6mQ)o3J%8ImT1 zVxJ)0oY24Vz4Qj(OJ5SgFF}wkPa2TTFs7Oog*b;9*QTa)V+^GkwhPH|L5>PCD4=be zkoUQD@+)qgd=K_F>BsfN%=65Diaqcc>lRDrd$sUF?Ljt?(U>)`y zwhysyZ^Q-#_WKUjVc%e%Kx~%nMskAtEXO&K-V-JJ3fD<53gH(xq3>}aeOGWl66AAW zTbhXQgXjrJ$Ciiz5409l^{5`x4Xi0mG8M@b8$vQBIE{1UXWS~e%FU6t*+7Qvo?!zq zHgE{Qo`_vUO=WYF4UB>8V=P%2cYuDAnxxt`ti9&uRV2Yz98$a!R2j zzQRy;ZV$q`;HiXvHVBOTFMCPi4Bi4L`Ln$wuSsyV7sV^~tE3r6rH|P4J}XmvDwjdy zo1T1tNc_o1%XRO-fb(2Jd)W2+T~;@aM-p)ZQvXqmh)J(4tA^1sM3poAfN(kNG(B zan+Y=EC@>J*AT*v{FTwGPhXpieDu$6Oibo`;eB{z^3;uM=O=uZKfFu%WGIJIKKLM} z2KBKAp`>W~9quzrta&7TmwP0A>rRgjBK}R`(c|`#hf1;sMW0@`J_L5Cgwny))lPRs zZ*4k^{*@m_|6vu<`DWSfS?Bl@x< zVg5^E0}Z6YFHey&0gxnLs)@XtOzmKG>9R@<*O;a?`F`8}c25d>3YwYTi_=0*sq{rlQQ6r{ULR zHJ>R#DNM^Onx$%G5HTfX?>;QfyjiWymtZ2nwC8&>^CxQvLuIL4Rf^?YVYXoA(DC2% z%8^UZE=`>>HVOGAtex(G1b6oEEKBeyv?MjR@=SZWdw1hd!{2RW%jlI+4H_T5vnEDY z?l!dG$Ktx7MW2AqpP@~x4~(I~3mcR39NT}|t_L?HCML>TEST>15-2-NBUTLAST.TEST ;; ;; ;; Syntax: (NBUTLAST LIST &OPTIONAL N) ;; ;; Function Description: ;; This is the destructive version of BUTLAST; it changes the CDR of ;; the cons N+1 from the end of the LIST to NIL. N defaults to 1. ;; If the LIST has fewer than N elements, then NBUTLAST ;; returns NIL, and the argument is not modified. (Therefore ;; one normally writes (SETQ A (NBUTLAST A)) rather than simply ;; (NBUTLAST A).) ;; For example: ;; ;; (SETQ FOO '(A B C D)) ;; (NBUTLAST FOO) => (A B C) ;; FOO => (A B C) ;; (NBUTLAST '(A)) => NIL ;; (NBUTLAST 'NIL) => NIL ;; ;; ;; Argument(s): LIST - a pure list ;; N - a number ;; ;; Returns: a pure list ;; (do-test "test nbutlast0 - test cases from page 271 of CLtL" (and (SETQ FOO '(A B C D)) (EQUAL (NBUTLAST FOO) '(A B C)) (EQUAL FOO '(A B C)) (EQUAL (NBUTLAST '(A)) NIL) (EQUAL (NBUTLAST NIL) NIL))) (do-test "test nbutlast1 - if the list has fewer than n elements, then () is returned and the argument is not modified" (every #'(lambda (x y) (let ((a x)) (and (eq nil (nbutlast x y)) (equal a x)))) '((1 2 3 4) (10 20) ((2 4) (6 8)) ((17 26 35 44))) '(5 10 3 2))) (do-test "test nbutlast2 - n is default to 1" (and (setq a '(a b c d e f g h i j k)) (equal (nbutlast a) '(a b c d e f g h i j)) (equal a '(a b c d e f g h i j)) ; (setq a '(foo foo1 (((((foo2 foo3)))) foo4))) (equal (nbutlast a) '(foo foo1)) (equal a '(foo foo1)) ; (setq a (make-list 50 :initial-element 'hi)) (setq b (append (make-list 29 :initial-element 'hi) (make-list 20 :initial-element 'hi))) (equal (nbutlast a) b) (equal a b) ; (setq a (nconc '(a b) '(c (d e)))) (equal (nbutlast a) '(a b c)) (equal a '(a b c)))) ;;ROACH 25-JUN-86 The last (eq a ()) in this test appears to be an ;;incorrect test. A will still be bound to the value of (make-list 100). ;;I have therefore modified this test to omit the (eq a ()). ;; (do-test "test nbutlast3" (and (prog1 1 (setq a ())) (eq (nbutlast a 2) ()) (eq a ()) ; (setq a '(1 2)) (equal (nbutlast a 0) '(1 2)) (equal a '(1 2)) ; (setq a '(1 2 3 4)) (eq (nbutlast a 40) ()) (equal a '(1 2 3 4)) ; (setq a (make-list 100)) (eq (nbutlast a 100) ()) ;; (eq a ()) )) (do-test "test nbutlast4" (progn (defun fun (n) (let ((i 0) buf) (dotimes (i n buf) (setq buf (append buf (list i)))))) ; (and (setq a (fun 100) b (fun 50)) (equal (nbutlast a 50) b) (equal a b) ; (setq a (fun 20) b (fun 7)) (equal (nbutlast a 13) b) (equal a b) ; (setq a (fun 15) b (fun 3)) (equal (nbutlast a 12) b) (equal a b)))) (do-test "test nbutlast4" (progn (defmacro mac1 () ''*mac1*) (defmacro mac2 () ''*mac2*) (defmacro mac3 () ''*mac3*) (setq a '((mac1) (mac2) (mac3))) (and (eq (eval (cadr (nbutlast a))) '*mac2*) (equal a '((mac1) (mac2))) (eq (eval (car (nbutlast a))) '*mac1*) (equal a '((mac1))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..48332cb215c3871b8232720ea09aa067a1574603 GIT binary patch literal 2531 zcmb_e-)~b@96$GVUB}u&S4KArY=^ncannoaHV8veF6C}5>uyJT%VoyIl&)K=UAt^8 zgc!)gga=d6t^BwLqKU-B2TjCjq6lFoCdS112l!&*gHQTEVj>SF&hPggx)m_-g{-&V z&-woNobUPG@Aq_z#BnkdrJ>@?Y%ZUfqs4M*wp^l9#W^}(EYGDgbPDwJjZiGEo(n6X z(LK)xn-g`G^js!Y%1lzdoSC0Yoej|7UOJXKOM^oP4g_fbz`?6n+Wj`8!?wE9!Xadx;z|-sax$UD%}Pr@Efr_weCBi}kB6C=CjuendzGf)q!!X6G0m(B3xdmhx8jay@;Dq! z8BvMY^pFMF1+(G~?vwjvEfmv21d{PyAVj>0nS7JIb4<8hARpa5CK@~ZErQ)j(`Tib z?prZ@MxUDyRIXk#e3o3u-kB!Ed%@usvbXPPfbTDkzN39d$YS=Qc1#o?VDVPF(ShEz z$3@6WE=?`o+NOWiHg)8l4x_lQ#@K}WrrY^3{9JUeWYZFd0WNxPeonqO+6}+aZS)$F z5rE9=Kj|*(z~J=(cy+A;s2YAtcTZc=ZargkTZ>n{D>3g<%zM%3wbo17Te-X)3IiXf zl}G)`zmj)v*nG=}pvXSVf^VJfT3znTw;Em0C2Pw&kPsg*-l)S1+4{eyRK6c;<#X5V zgm86vFw0YhZ-3U0sdBwljXLj|0kix6te{YB|Jf&tSx?SGM7MdRvO|KlJsQDYm&1y7 zG^)nsBN5POBMC`tVs6m^j~$){7^oI0r0Air99Q*Z90np}O;lrIBB85eqVS}L9+Q~M z<^+Rqa((!4Y-}#nDa>PQMsNhcX6CkSfl=EmsquI$F2|Dkcv6>a9&m6;iZ&rz`h>&; zTMGsqhafM45P+=+h5@u9m;kU1!BGG{1S<2uzz;q?@J<*V)_`N~$FaQ%`!^29;$w=A z%Qqpib)!HbC86>pmsrI#Jw#kmersgc_fa z6Hw%+irUZEE)*Za?#^fguB@o4jp$+2UEwTCT)YJyo5qw;RYo_om)Wx@rn#WpZ6_Cg zF50+gwFLRr%7=W)It#4hW!AZy(QUvWo&jpRRbgBe;TCMvunV5tq!0qg;5sP&`w>f*ropHjvY*O~hJkg!#34Jb6K1ucb(;?xQ5ZI>wugrq0tl}OwLNClvwl!?g=|1i z{@I8m55WDQ`j2%I^4mHI`2`@5VB8PZYhf?q+kA<4;a#iRGDjbP@=hcnxchV9`6P6B@3K>lO8l(Gcml>test>15-2-nconc.test ;; ;; ;; Syntax: NCONC &rest lists ;; ;; Function Description: NCONC returns a list that is the argument lists concatenated together. The ;; arguments are changed, rather than copied. ;; ;; Argument(s): {list}* ;; ;; Returns: nil or a list ;; ;;ROACH 25-JUN-86 It seems that NCONC is supposed to be a destructive APPEND ;;and that APPEND does in fact allow non list arguments. From page 268 of the ;;manual: ;; ;; "The last argument actually need not be a list but may be any LISP ;;which becomes the tail end of the contructed list. For example, ;;(append '(a b c) 'd) => (a b c . d)" ;; ;;This isn't said so explicitly on page 269 where NCONC is documented, but given ;;the well known similarity of these two functions, the comment "Compare this ;;with append", and the similar examples between APPEND and NCONC used in the ;;manual, it seems intended that NCONC should also "in fact allow non list ;;arguments." I have therefore disabled this test. ;; ;;(do-test "test-nconc0 - syntax checking ( NCONC takes lists as arguments) " ;; (prog2 (setq save car/cdrerr car/cdrerr t) ;; (notany #'(lambda (x) (nlsetq (nconc x))) ;; '(2 a #\k "w" 3.0 #(1 2 3) t :keyword)) ;; (setq car/cdrerr save))) (do-test "test-nconc1 - this test case copied from page 269 of CLtL" (progn (setq x '(a b c)) (setq y '(d e f)) (and (equal (nconc x y) '(a b c d e f)) (equal x '(a b c d e f))))) (do-test "test-nconc2 - input argument is a nil " (eq (nconc) nil)) (do-test "test-nconc3" (and (setq a '(1 2 3) b '(4 5 6) c '(7 8 9) d () e '(10 11 12) f'(20 21 22 23)) (equal (setq q (nconc a b c f d e)) '(1 2 3 4 5 6 7 8 9 20 21 22 23 10 11 12)) (equal a q) (not (or (equal b '(4 5 6)) (equal c '(7 8 9)) (equal f '(20 21 22 23)))) ; (setq a (make-list 5 :initial-element 'rah) b (make-list 5 :initial-element 'quack) x (make-list 10 :initial-element 'foo)) (equal x (setq q (nconc x a b))) (= 20 (list-length q)) (every #'(lambda (x) (eq 'rah (nth x q))) '(10 11 12 13 14)) (every #'(lambda (x) (eq 'foo (nth x q))) '(0 1 2 3 4 5 6 7 8 9)))) (do-test "test-nconc4" (and (equal (nconc '(1 . 2) '(3 . 4)) '(1 3 . 4)) (equal (nconc nil (list 'a (cons 'b 'c))) '(a (b . c))) (equal (nconc '(11 . 22) '(((((1 2) 3) 4) 5) 6) '(33 . 44)) '(11 ((((1 2) 3) 4) 5) 6 33 . 44)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..63b52607f977b9ae3caec4fac5c9f93f5f847d65 GIT binary patch literal 2977 zcmb_eZ){Ul6u(KrR`{;Yv=x; zXvATRCgvF&3*=pi8i~flgak-T92gekSB&4}gWohUF`CF1{bul-cVA1p5yXVHufN|p z_uO;OIrsM5E|cm>e@OD@XJ#|m)SQ%GT$o*4kf!r<(tLh#E|HR^K`*`TkLcvxoVlp%Hgc4$XV7i85n%@XUG;4(}QMYx*^aM3|3=&fg zszh)(UeG(WOpkAm+#_p2%?J<(#`6{-;v`0LEq#52uIA|0Z$^ZPO>K>|@+cuV;2~rU zD14A*D~_ex+Adxp7mMtCk-f*+)i)hnbnv)?aR(l6w-2v{l?%u;iJ4_trBRs&4 zoK0VDx#tmDPB&y4h)`plGavW*Bic|9f1z?f(S|~*E)NDlqaBQT1sC%O)$mlpQvq$D z(d$g;f}E<5CS}v12)hLwvw)J>0J&JP>PDk(9jsz({Z~lhg8j$MnMw8K@CS# zn=6yZU&JZSVW52|s2ZQ&3j+0`4OW=S$hIMS9vJ!EUZ4D8FHCN+_AUtAlX`VFo=f8P zv8E1Ch&F3sdocqsV42m6x#PL~D>)R0EVFJQHNPO`GP#9xFRBJCbE|=>j#Em9G#!V3 z1W75A#5tJ;gfMljz^Q-W-&|3G0HjB0y5@eqB`zRbKZq3k3~TS3*(dMl(2*Ycc<`>_1Et!`MisyG{wsVD_RI-iuuOMn zr_Uhz(jHxjdyFTrN6636h4&N1UR-CML>TEST>15-2-NINTH.TEST ;; ;; ;; Syntax: (NINTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test ninth0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (ninth ,list) ,elm)) ((or cons string) (equal (ninth ,list) ,elm)) (t (eq (ninth ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) ()) (mac '(1 2 3 4 5 6 7 8) ()) (mac '(9 9 9 9 9 9 9 9 9.99955) 9.99955) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 9.999) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) '(t nil . t)) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) '(l . l) ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '((w)) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") "o1") (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) '("foo8" "bar8") ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) 'Hawaii ) ) )) (do-test "test ninth1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (ninth a) '(3 5 100)) '(t t nil)) ) ) (do-test "test ninth2" (let ((aa '(1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 9 10 11 12) 9 10 11 12) 9 10 11 12) 9 10 11 12))) (and (equal (ninth aa) '(1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 9 10 11 12) 9 10 11 12) 9 10 11 12)) (equal (ninth (ninth aa)) '(1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 9 10 11 12) 9 10 11 12)) (equal (ninth (ninth (ninth aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (ninth (ninth (ninth (ninth aa)))) 9) ) ) ) (do-test "test ninth3" (let ((aa (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm))) (setf (ninth aa) (make-list 15)) (setf (ninth (ninth aa)) (make-list 15 :initial-element 'rah)) (setf (ninth(ninth (ninth aa))) "magic kingdom") (equal aa '(a b c d e f g h (nil nil nil nil nil nil nil nil (rah rah rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah rah) nil nil nil nil nil nil) j k l m)) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d2c53b6e5c49279287e4f5a5374ef0658c280dba GIT binary patch literal 2532 zcmb_dPi)&{6#wk}Pm?z73hTP6^Qx@fvbk!yp=|}Bxvtx|O`H%rO3RR@HcfH0HmULl z7=NZQO^Aah)}mu0_eH7#AI4}CnktfgU?6( z>NZQRl%K8S=Q*vKFVD}OJHkbWxWw!^E_(9Bi6h+b(UD^(N21X||G1#W?Oe@>Y<|Ab zjEQcG85$WrHZpW#(Esog^EwkM5<+sMj>Jbuh&YIO)d)p2N!9pqIWF;vkdPwgs%dzk z5NlRi<5edL)zevCdvE0&cPcoYY^2?n`HrvtN&bUyk2MIxXZzHB7 zeIy>&(R5W`=TZHbse6Z}8FN9$&+S(U>A2|WV)V_s3h?(=r!Fhs5wfbkr%bX8IIpgE zWjmWWkOl~;FXo=LTGoKcTyDbjphvF9GUmGK*)C{muGbd3>)CD;Ia}sDt}O-iuLlO9?!LIVyT4LX7_sI3txold6t zWJXJ6w1}ex0s;|1nc*$H8lj9M06J#$(K6r|JN&2PUsA(fJpF?9Hf?nm;uO|DT6rT1;}Hk?PN zDrw`qI+GYp#`)&9qfeIhA`$66BrIh0G&UP#@_>es{ArV45rvpc%`{PvAL#+Ke`X~i z2HkgthNo$GoQ99n@L?M6p zB*m)qCOwGe8#bxhHJzmWsEpd72P{G^(*8H;K!FZewg;x+sTR%_imw;Y^)J)#SMucw zS19Fk#X@cvmG@0!pN7i5^FklDFblW(Jhxb|uVmDn$NHFCW{owC{hFTV;O;DNh3fKL zzEtLBOL;C=t>lkzON(doBb-@tuueBdd}&4a=Bl}~6}?z0z!boNdeSi=p=4D1P(MYV zt8j`LEt7zQZupER<1$>kw$CampZdjcS1OsFnt^DTmy|qVhg~*nAqZ=PvJR)q?eY48 zEzMMpfWOr=+7`>jdO~jIE1P@5mOhSNN!1^!Qxg1(d0*g}<uyT>_QTJq;yJpSB;7DQ4n^sHc!dAiLhE*^zcN9E??rZe$92D#IAaW<3 zG2?Rkf~O(e7u4YC@uuLd+pRLZZp)WtJl;{u@5LQ{gP>*D0qeOBo-DK5;+e-0l8+F_ I7Y`r)12_xSW&i*H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST new file mode 100644 index 00000000..e23d2263 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NRECONC ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 269 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 10, 1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-NRECONC.TEST ;; ;; ;; Syntax: (NRECONC X Y) ;; ;; Function Description: ;; (NRECONC X Y) is exactly the same as ;; (NCONC (NREVERSE X) Y) except that it is potentially more ;; efficient. Both X and Y should be lists. ;; The argument X is destroyed. ;; Compare this with function REVAPPEND. ;; ;; Argument(s): X - a pure list ;; Y - a pure list ;; ;; Returns: a pure list ;; (do-test "test nreconc0" (and (equal (nreconc '(1 2) nil) '(2 1)) (equal (nreconc nil '(1 2)) '(1 2)) (eq (nreconc nil nil) nil) (equal (nreconc '(1 2 (3 4 (5) 6)) '(7 8)) '((3 4 (5) 6) 2 1 7 8)) (equal (nreconc (nreconc '(1 2 (3 4 (5) 6)) '(7 8)) '(9 10)) '(8 7 1 2 (3 4 (5) 6) 9 10)) ) ) (do-test "test nreconc1" (progn (setf a '(1 2 3 4 5) b '((1 . 2) (3 . 4) (5 . 6)) bb (copy-list b) c '( (( 10 9) 8 7) 6 5) cc (copy-list c) d '(11 12 (13 (14 15 ((16)) 17)) 18)) (setf aaa (nreconc a b) bbb (nreconc bb c) ccc (nreconc cc d)) (and (equal aaa '(5 4 3 2 1 (1 . 2) (3 . 4) (5 . 6))) (equal bbb '((5 . 6) (3 . 4) (1 . 2) (( 10 9) 8 7) 6 5)) (equal ccc '(5 6 (( 10 9) 8 7) 11 12 (13 (14 15 ((16)) 17)) 18)) ) ) ) (do-test "test nreconc2" (prog2 (defun fun (x y) (let (save) (mapcar #'(lambda (x) (push x save)) x) (equal (nreconc x y) (nconc save y)))) (and (fun '(a b c d (e . "s") ( 90 100 111) ((( 3 4))) 'hi) '(the tail)) (fun '((1) ((2)) 3 4 5 6 7 8 9 10 11 (((12 13 14))) "isomorphic list" 'do 'you-understand (staghorn sumac)) '((((((((((porky pig)))))))))) ) (fun (append (make-list 50 :initial-element '(Autumn (foliage))) (make-list 50 :initial-element '("buckthorn" (Rhamnus)))) (make-list 100 :initial-element '("The even numbers are cute, like: " (2 4 6))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..94b9fbebd8964e2f9d4291faf5a613ca202f7d73 GIT binary patch literal 2271 zcmb_d&u<$=6rS0&W4m>z)4HvbmS#xRsF-Y2yT8*S*lgCZll40FZq!EN;yUZv%Ek_{ zO%)+Zs8mi{fg92802K!g9JrKlp%k@3Js_kW;D*GNKcHtgg!gvilD0^2sO|Ne_syF( z?|t*$Y=?v{C>m25i%T`zT4s%QYpLC0mBun_HrmT&i&X$;?<$3&`d(I6rbo}Dwi#Py z%F9-%Wz93QZ8hghDzSSmHTEh8J6@2k7wyft6%u1RfK zb7U-iY%G0zblb*l_a==s2q9(i07Zn57!iqk!-*wL)i9+@PE#da&Z|kc<2qr;M4C0! zqU-dfS*x)m+15Ljjma!F2_?k+*a>H5b;ZmTba#!e(y059)0@+!8Awc?REZGY^n%_g zj8n&@w4|F^0-;2%5+aOY9N$;(P0_n`Qu<*^I3FMAqruv}ON8va8j8{C-TOL>A9tp& z>kkR(R6o?G1lkLuJBjmqaCP^I67rx{PI#GhJ^tAB80uP~+)l`g@lUUJ{f8k&bPa($ zSg-|Kv;)-v_}~DxTYt+A*ueq2#|{lFAT}@n3w#S<6F{@0b^vhrfno=r48f~60qEzr zi!Jyjt5y8Im|O&BZ%`>#jbsm5wCB1GIzoc&3qpiktm0;R01PiSgU8qWcu zPZ~)f%zK3pJVAH@Q09F}MK+bJR8-B`B9y7()p?IGXP9bUpwC;Fg(Q!Py}Vc44yFB4 zQY{t>MX4}r&di!gF$xQ!Nm-whJlsffsPVpI&$ddhNC*#LgT%4qN5NB1rclhwCaV45 zB>qnlifpL9J068;`WsjWG}%B~`V%POLxyT%4KZ;=tK%SXV^$AoDf*Q%o)2gK9e7gkShZEa9bMl8TegU@QuysZ<=JMkOP3m?& zn3Au(0LU#KZ=-X)U;-=CeAh`H-wpG^4nTt*NvMV3;s6_9K*N3h;)5uDg|Mm26F8pZ z2T+{zXH;LD0)s%NP)PeWuX$+}3ckkp5UzL`T<^%~P!O^vshXNsbuabZXk3)DzVS|e z5RA#6xZ{imk)Qo6uX`JlYkY8p4@&&NAwJm82ls-tkaV3;yS`9wT&|-!>^jF=REZJTqn}aB8|WTKa3*nu3^I<-A8z0bClu<{>tX~s88D?_a+${ z?^IW7-(@@5YvW?4wpzUaHWIT3*->k&968aefxg41y!ydU^8^Bm~X~p|8Aj$d|68cGH1Fsa063YBAfYUxGtw zY-%;&z1C!BUuX3ZoUeOE%T}{(dlU7V&Cur;{P5dALr|pQMWkabNChzvgk6Qes=F43 z!+`o3_voPt2#+#4;RC8KGKk|D(McbG5=5=&3xg*^Q#5KWFb_&;=QQiW6nl)+}##=EZaV!Uz8VwWM8oOX~JP^~nQXGUw2uOFRX zkk=z&z-#B0L#i@G!AR2|ue)FOaB@NyrH)*ZYntZto@vU~aonfz^vAuE6MSfrmnPyq zeJEEnqKRWpxnXHAnvVQ2d-XnbdhITa66>tIzEKP4bYJ&sD+9v{hUxvPPgqyVB$__9 zX|m!bU2&SO=r&i;a$8(bokOcnKb4xP`=;4BK6+hCjFffsa}oP8oMPSeHm*<`P>_8(*2SRi<(Fb&Ti#IwkdK+Nu~Jd z)30oDw`?@l`fbseLQI)O=?#u4E1@yNE7G}cX4BIkw;uV<2mm@h+0B%CB>B`PET zBylPo)8PD8OacguAQmPD3%o^1GhO6{_;-~RDf`sQJ6S%(`_u?7uCM7mjD0v8T!kUM zJ0-l?k?K4v1)UwKgJ-1xYAq$dgFGvc(^--xZiOTZH`g)aNkk-6t1=X!s@x@#Z&1pD z=Ic(2R4U8_p_-y`zf2G@vSyPkNflC`)2wu2p7=pU4!!ZzDu86@4z%0GuGoT2WVB5c zs+i}APJDMufgO`dtN+{A1oCJ$-0qAW-6qQm)5 zvV2#vj(Fc7_f^CtB>Qq#b z`XWT;t2a9*9(d(b6$J}`Onv5-XVM|{{k5gi*80yA=(Y-D=R$bh5pc}NY}NMMp{2d2o=?Bn(jtFhP39d3(V>=Q-nF^BM$@KbW?{Ao*_)Y)- literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fc4147d30a284451bcc0117e980920fb181c9127 GIT binary patch literal 1862 zcmb_cPi)&%7=O0Y|H+naX}6Yib-NX$P*+RZt$#Rx-M(<@@ZWD;)<8*nax{yx;r& zz3+34v|N%DUMjCtie_PzFRxcC>s5ZKyvnbY*H?1|ehKvaH7S*rUyX~>+{iQGcJ0tk zZncoD7V^BlURcX#uMYF!^L#RUl@Cu&Obqjp(W$Y?sc?9teOlBM*H+`iLLpyjoCzN~ zbABo^HZ>L*Y2UkT-(>t{LP(B0K+;BtpK!$9viu=k)^uSyp~!+NCgqS_v#nOhM964z z+O|3)e6?H=%)*s|iOH<25rz=^hSfTqQ6)W*Qtdjk$$0H|Enh+v<{>e0MkZ|Qz7@32 z*j7jQf)Ei@Jub!41fprZP6+c0hVr$sGt1m9k?g%$cHu;CC(~5ixlG83>n+C^@&9=bVJ%S-1mQq_P0i~t)>s+g%5%{%yyXF=72eDjvKxB zm`$d~@og_+vm&x3XIvYyWMS`LB3|ZWuA7G|zso(fSf*G7Gu51Q{-NKU6yX(5%-=QDbU>wp8^kf<&S zj$R8<=)%s?qs`pL5kfuK!U62aAHh=dbSj+`brkP`k-(z_BvF%HbJUC5HxTXiG>UK1 zE+p4nQgVrc7;%1HR%5ss0SEA^b~B6zvxLMzfz2Y?0{nq2JB!Mag1=| zbJ~mK6WWcW?n-ad-VNGYfpP~lS)UfP#bh+42#o=qqbJ8{;20cWw!wXqQxKFsgE4Ma zF6=-mX_Vv&{OqBV-wp!Lp%cb(mB^1B6EpN53R^>}oBbQ%|pzd4S>eo>>xFHVm zOIi4D=J{gD{pq1@V+dg{*>#p>kYnr*fQNw2NNHKrW#P!3DG6Opi;70Q2!j$lpGoPm z8|t5Q08EfS{uxIYb-&ZINWO&juOs|cD<>idtmsH=2N@g%&?qoG3&6dz*f|-YC%AP#51pWsbP91X+Vcun;XF;vRo5|a zrhStPMr+1q@vC?({(6+F6*rAr;&U+C(T9GQ?)r&sJz-{7Ud(5)nvcx_{MR{W7Tmxu zLGX*PUSNZ?D?qy-WX-8F9fB&-Cuwko4oJ3j;n4N*0`Ew<>{?-s&y_1hxVfd(@(N$c dUM}#Fi{pHGiI{;-r9jR^1imW_cv(g5)A+V literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST b/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST new file mode 100644 index 00000000..86d02e65 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NTHCDR ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-NTHCDR.TEST ;; ;; ;; Syntax: (NTHCDR N LIST) ;; ;; Function Description: ;; (NTHCDR N LIST) performs the CDR operation N times ;; on LIST, and returns the result. ;; For example: ;; ;; (NTHCDR 0 '(A B C)) => (A B C) ;; (NTHCDR 2 '(A B C)) => (C) ;; (NTHCDR 4 '(A B C)) => NIL ;; ;; In other words, it returns the Nth CDR of the list. ;; Compatibility note: This is similar to the Interlisp function NTH, ;; except that the Interlisp function is one-based instead of zero-based. ;; ;; ;; (CAR (NTHCDR N X)) = (NTH N X) ;; ;; ;; Argument(s): N - a number ;; LIST - a list ;; ;; Returns: a list ;; (do-test "test nthcdr - test cases copied from page 267 of CLtL" (and (equal (nthcdr 0 '(a b c)) '(a b c)) (equal (nthcdr 2 '(a b c)) '(c)) (equal (nthcdr 4 '(a b c)) ()))) (do-test "test nthcdr1" (progn (defun fun (x y z) (cond ((listp z) (equal (nthcdr y x) z)) (t (eq (nthcdr y x) z)))) ; (and (fun '(1 2 3 4 5 6) 2 '(3 4 5 6)) (fun '(((((a b c d))))) 2 '()) (fun '() 3 nil) (fun (append '(a b c) '(0 1 2 3) '("u" "v" "k")) 4 '(1 2 3 "u" "v" "k")) (fun (nth 1 '((a b c) (11 22 33 44 (55 66 77)) "p" "q" "r")) 4 '((55 66 77)))))) (do-test "test nthcdr2" (let ((a (append (make-list 10 :initial-element 'east) (make-list 10 :initial-element 'west) (list 11 22 33 44 55) (cons 5 (cons 4 (cons 3 (cons 2 (cons 1 nil)))))))) (and (eq (car (nthcdr 10 a)) (nth 10 a)) (equal (nthcdr 28 a) '(2 1)) (eq (car (nthcdr 20 a)) 11) (eq (nthcdr 30 a) nil) (eq (car (nthcdr 24 a)) 55)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-POP.DFASL b/internal/test/LANGUAGE/AUTO/15-2-POP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3ffff2ad28a3f5fed85206c7f4f06efd882dfa1b GIT binary patch literal 2287 zcmb_cZ%i9y7{6ge293R2fKa5m!J=-3L145~c6QMvc-&oS-EmjiYmgBI zXEerS&hEqF7ZW34!J5&HR0KBKr~wn>C$;X&77`Z|A{a4j%dnFAyuG#@|C}+tq`iCI z=lT79&+~g<8Y1$K+m9f--0kyG9Aw>w{Ge7*Ugy|t>| zTG+11aDIVR1Rfm=3IU$&t3cLj)W-H9>;8TFDp1Xnb+!BJtk$Z+!w1`ss9afuOW>s} z#;UPvp+B1}0IOXeefw#B?}(Dlrm1oJ^e>Hr9IdQS0hZZFJK1 zu`)b6_f2ZFYJMoHqZD~{;6!Tby}UEg*sZg-N^bv=_iXgF1j8_^$<(OzxyZbJdhz$w zq$}YXnq7HgBo&G7wT)b~9Z;Ca=&Z_u*_qYU=-Jcb$??65ZHc9(mnRp(;fOU4cxEm% zjwJT%WNviKN9;{AHxfU>ZlZL#;m|VEbSMxhTW*;6i(%TnZ(YXaHy186-eH&l`NcWr z^F7DYsq3G1MympZWr-_U?O}Y+KJgxf4 zWnvz}n1k%t9e3y;<#;&m+>P-m$bG9R2O`)RKPl=&y{O*;^q{x{W6n8E82%l+z724l zmYme(=%LH8&MjE57h_Esj*=6RQhUGr+ZeL9s(Yi&sH)z$^HlrUq(MzMJZCVwGHi_UeEk6yBk>ce_MSv;F z)88WRb-Pg|QlEZ73Hqe~Vv!{DBFgO-0v@psak3N;cpBm9%hwvFe15qLoCyd@4?rvw zi#id9cmzL(sEdYx;&{L2i-is#O{ro~4GkF#>iiTdK}P5avLcjZxN!RhScvlbM3!S! zF6hM4i;-EV7S)TmG%E(F`GF7D@s8 z14sc;2_FInjrn{6n2Y)2rm zgJIK^xkvY#`o;4|a366;>h*z3uyw~YHg%hpd3*y5v=OdB`!VNH_~E+O($N*q-^>(| z#C=`u1o5jAKH^IESLn^F1WEo(Jf!B0*XWAkX`)~(RQ@ipfcK~my3Y{>#Yc%9(hnJq S|N7X$|8m*A1z1o1f9r2l4wW|m literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-POP.TEST b/internal/test/LANGUAGE/AUTO/15-2-POP.TEST new file mode 100644 index 00000000..79da7ff4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-POP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: POP ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 271 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 2, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-POP.TEST ;; ;; ;; Syntax: (POP PLACE) ;; ;; Function Description: ;; The form PLACE should be the name of a generalized variable containing a list. ;; The result of POP is the car of the contents of PLACE, and as a side effect the cdr ;; of the contents is stored back into PLACE. ;; ;; Argument(s): PLACE - a list ;; ;; Returns: anything ;; (do-test "test pop - test cases copied from page 271 of CLtL" (progn (SETQ STACK '(A B C)) (and (EQ (POP STACK) 'A) (EQUAL STACK '(B C)) ))) (do-test "test pop0" (and (setq a '(1 2 3 4)) (= (pop a) 1) (= (pop a) 2) (= (pop a) 3) (= (pop a) 4) (eq (pop a) nil) (eq (pop a ) ()) )) (do-test "test pop1" (let ((a `(a #(1 2 3 4) 100.0 (d e "f" #\i) ,(function +) k) )) (and (eq (pop a) 'a) ; (= (pop (cdr a)) 100.0) ; (vectorp (pop a)) ; (= (funcall (pop (cdr a)) 1 2 3) 6) ; (equal a '( (d e "f" #\i) k) ) ; (string-equal (pop (cddar a)) "F") ; (eq (pop (cdr a)) 'k) ; (equal a '((d e #\i))) ; (char= (pop (cddar a)) #\i) ; (equal (pop a) '(d e)) (eq a ()) ))) (do-test "test pop2" (progn (setq a '(10 20 30 40 50 (60 77 88) (a b c d) (e (f (g (h)))) i j k (99 100))) (setq aa a b nil) (dotimes (i (list-length a)) (setq b (cons (pop a) b))) (equal aa (reverse b)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28997814a8aa89ff360d17de11b974b581e6fed6 GIT binary patch literal 3042 zcmb_eUu;`v760zN{+GmV<1|fOFH1kF{sF7Ei``DF=@7edZW_1O*QtG-n?N6MY^T2T z#kw8L~hJ+Afd!-sLNJvydnuK@==X}?8 zy%xp`aqRQ&cm90mJNMYz#J`->XtK6mx9su;t!*~zn@ze_+n|lw=0>qh*FaCdmCR(- zZ!ajx3n$OUhjRm#;zqg9ESIRUS#FdHTPJ9Inx+d|G=AoV7f#T`shQJfX5#Ua!}Cf` zb7S>9%yOyP^NA1mOwS~qpNXG2IlTL}^M){5BZL&m4w4~4Mu|k6*IJ`7L(LiTd`eSg zT}i7kXWMB7;3RTBr)Hg2I6<4Wx@?!PmTf%DdV>grI6rCy=JR^eNM&@VEnF9Z&JSCm zlrAsA!IX0<5d+;Q7+r8$L-FV3guIx~EfA<>>{UXfPq2_*RqmY^-m8*3_s@&w;b>U! z@+#?$Nk!WWA3`)Dpz3#Tnv~P)m3x;78GF?q5i0M!uLJ*R`@#?O-w?80`JR4W6hgq= zjhIIe-FpWK*|Cbp_}RND#jo^I`YXjKw-hH`5^>4Yj%7xp#VAjE=Uw55*=G-!QLu^8 zgJRDp^^N3HbJ8xElLJ=r(46c7$%kNlU{3bWb?05O^Vr%kBO?4&#rrNZ2)kuQdO^O= zttfG(kLp};Wsd7y;==p7$g2d>FRAm@ZmiB}b4s)i!pCFVA&{W0gSt1(DIW5A{ti_2Pa{{}9e|VbyaiHeUnxJg3_qG283~IYHfU{q8;zEg=qO z)sF0T=C7c_maqn456{?{#xg>gacF@shANnK>rv-`IRO>$#{?8zy?arevsj`XDt-~` zEXMG&Ux>?KZg96lySJen-~jT-_5R=23B@1ykB{1RWz-raVhHwvM@!`lafpRrDZJjA zj3qPrTnaabyrAfFnwphoQ=rk$8Ug9%N>L*^A5^Fr&yU0~2N=(ioJyC#Ghz znXH`28;f}(ChY@2FsA4$GS}x~OpwMw=UGy+aq!#U@wJG;A2nZvZ-&TS?DmG=2Sm7)iaDSF}YG z^B{Va#YJrer8Gz$P08^jbI|(Xqw12HU6FIpYmJAAurB~o{3jsyc2o4$I_f`RN05B% zk`G++4uFT!$^})%dqumSJqtwm2b;3lv&(F1KSGflSbCjtd}YG7XHePK@i~~FI4!G zOE7`gOwAdPLTAV3+3^{6{5il$e{@>@&FYnE?OGMZ-#ab2S#C6GeX~)aGEKq6(slSU z-zcxaZ-Zuy7OGoRvl?|;Tm5Fa*hHrfoYo-&oesaE9Hwgp__(??=)EM*i(X&JAGjGC3bB(T zL8mpcW?OY=Zn0)zTg1vueotqgwj6cZK`7bd_4xxsp^+e>_c}jz+9I@kDw$OkLzSO+ zMl|SZR?%{77-29V7xNiI<@Y8^Y#KrcyH0Cv@E#U5C8^RzrM798=xP~CyIii8Hww1( zGW7atVZ$n{!jH6Kt=cSDRSQM}Cc|pr^$7oB2_!#v+5xD^x0KQHX_bXT?74#|n`-LZ zg2BSL7JLg`VG2Ed>a=|TV&})%1+HjA+Xlqz5E0Jqv^`EsYSy-(3D8~e6z}^3z%3Vt zFw8YPWnZ#6i~380j;P2yshD-+qV2TP_VZlW>c?4lf-m)DL_$+Nu7W%eN_?8&zIk1s z00j9vAi5Uv7Z?;5ME(GE-nfB)-@@>5<`+HYXFcXE>`5xr?+JN*urQbb^uGx~q1Yy$ z1D1riY>pkPu<4T1IyHE$oG%s{CML>TEST>15-2-PUSH.TEST ;; ;; ;; Syntax: (PUSH ITEM PLACE) ;; ;; Function Description: ;; The form PLACE should be the name of a generalized variable containing a list; ;; ITEM may refer to any Lisp object. The ITEM is consed onto the front of the list, and the ;; augmented list is stored back into PLACE and returned. The form PLACE may be any form acceptable ;; as a generalized variable to SETF. If the list held in PLACE is viewed as a push-down stack, ;; then PUSH pushes an element onto the top of the stack. ;; ;; ;; Argument(s): ITEM - anything ;; PLACE - a list ;; ;; Returns: a list ;; (do-test "test push - test cases copied from page 270 of CLtL" (progn (setq x '(a (b c) d )) (and (equal (push 5 (cadr x)) '(5 b c)) (equal x '(a (5 b c) d)) ))) (do-test "test push - PLACE should be a generalized variable containing a list" (progn (setf a '() b '(1 2 3) c '(1 2 3 (4 5 6) 7 8 9) d '(volume 10 weight 20 height 30)) (and (equal (push t a) '(t)) (equal a '(t)) (equal (push t (cdr a)) '(t)) (equal a '(t t)) ; (equal (push 100 (rest b)) '(100 2 3)) (equal b '(1 100 2 3)) (equal (push 200 (first b)) '(200 . 1)) (equal b '((200 . 1) 100 2 3)) ; (equal (push 700 (fifth c)) '(700 . 7)) (equal c '(1 2 3 (4 5 6) (700 . 7) 8 9)) (equal (push "toy" (cadddr c)) '("toy" 4 5 6)) (equal (nth 3 c) '("toy" 4 5 6)) (equal (push '(88 . 99) (cdddr (cdddr c))) '((88 . 99) 9)) (equal c '(1 2 3 ("toy" 4 5 6) (700 . 7) 8 (88 . 99) 9)) ; (equal (push '25 (cddr d)) '(25 weight 20 height 30)) (equal (push 'width (cddr d)) '(width 25 weight 20 height 30)) (equal d '(volume 10 width 25 weight 20 height 30)) ) ) ) (do-test "test push - ITEM may refer to any Lisp object" (and (progn (setf list '(1 2 3 4 5 6 7 8 9 10 11 12)) (push "flip a coin" (cddddr (cddddr (cddddr list)))) (push '| a symbol with a long name | (cddr (cddddr (cddddr list)))) (push #\* (cddddr (cddddr list))) (push (1+ 99) (cddr (cddddr list))) (push #30r20 (cddddr list)) (push (make-list 5 :initial-element 'rah) (cddr list)) (push t (first list)) (equal list '((t . 1) 2 (rah rah rah rah rah) 3 4 60 5 6 100 7 8 #\* 9 10 | a symbol with a long name | 11 12 "flip a coin") ) ) ;; (progn (setf list ()) (push #'* list) (push #'evenp list) (push #'list* list) (push #'(lambda (x y z) (* x y z)) list) (push #'null list) (and (eq (funcall (car list) t) nil) (= (apply (nth 1 list) 2 3 '(4)) 24) (equal (funcall (caddr list) 1 2 3) '(1 2 . 3)) (eq (every (fourth list) '(2 4 6 8 10)) t) (equalp (apply (car (last list)) '(2 3 10)) 60.000) )) ;; (progn (setf list () var1 10 var2 'a) (push 'var1 list) (push 'var2 list) (and (= (symbol-value (nth 1 list)) 10) (eq (symbol-value (nth 0 list)) 'a) )) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL b/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9fa449b036d71b2334cea2b1a4782c5d623d7a80 GIT binary patch literal 3996 zcmb_ee{3699e?-EcAV5noi1c)RwYNbrN!+fani9iFs+x%WpU!1Q~NSEQZ?k-&g{*N zL*gt{Q?n42iVYLydK>rnF`=SKAkel35G&mpUZm@k>HX0>SvJe82Dc z;?&ue4M^nszR&l^=Y7BL-TU4vk-C$5Skd!mX0y5UoRVKC%q|p^>HM5BpI?|urj=>X zD-Y|DsBvyY)5p3$7Ho)Zu_Wixi9$N1SPSX-RO0MmCD^NsC(bItV@Ho3R{Ht}jvN~Z z2D=-EwOCkiIT7)6YQ~8PZi(p~=(}U!$kFbG>tD5>lKgo>NRq6hs3*ivWMW?|`U92` zv(({G*icPv+z8kuyXb{V)XA6;wTsPtN+Cb1=F$(Pb6Cuoc_I;FKVI|>Pnx2p>1QW18nyb@{Y#k%vCV$S*hD2 zWv*N^Vf7=kC63jvV$*9B_Wz~67pt}E$f+h3*?b( z;R#&2EM;&2dQ4-BWi1{TE^Fah%Q3EKuTZQVjJNO_S}3g+xR-MNFIGsFGtU2|%j6%G z8LM&CND7Nni3QJBwzxRlH#j`Alfz2Y!6De3VD0pK8TCzLC9oRT^{%Gv^*VL`fA-RK z+}X=|zKE^3Z8(A)aR}!D5&m`&0=s)(#SKNg6+DC!ye7$3{*wF;%6KcXZooeMvocH0 z$LSE&%urRuTPgfqLxl+gsZs#=^Rt03034Z3YF42}QJX93Hr5L9R?Y^*TkAu%>Xwby z#BX{wcyK8MQ`h@&a`qGD&U<<>^Zd>4ctA@Tf7VZEz5QfyUqFwTLm_NI>WF3zg^j2> z7y^xXPb@&atdY9m=Yk&B9MCmOA5o)*H5r8-rSm4|iA}{UW1LFcJ*-H8`Q%10NZMvU z#7-vffq+L98(5><1nQ=M5sgNoYGl%yn6v`&ZgB7gG;>Pj`dENLA8hWg zZKsW}kj#Zm^boehL%`%2jzq^b3t=mev{dWVwU{C3m=DbIo9L|#jYdKy!rubi9h({- zjD%IEJ){1Y>=qO+vUU_N2=tr~C81muXilKKK)OI(Lfpg!eM^YHau@m=fnFErrvkk! z&}D(173c{_&TZUlM5iDL`lwK@z(%&j3~N~3o;JOgwV~@E+Y3VaH)oUH5aP!|JR`(s zgh&Z7D1?^_@_QkECd6|>JjU7{Vta>J`vKP84eT!bfVufbA#%Y7&ST;(gaOKLvrZJh z1|OHM4Mh>W1}^fLfyKx_2LtW73x}`br;&eB%?R$G{5`PAy2fMH*oRT|ZBR+v` z=qe!Bcqlw3;L`xzAvj+B0-r-XW`>3VTKN^-(SiuXI>a7jrg@vW;uH$R0{buxs>&1-p{o3 zU8|AovbVBava?L|ZM)ob{`hgYWS1q@eg5uc7{STQ7YeyFd_g>?`G~T^@DhQ8iydo~Ks>yGOt1&oLG}QK7QwQa74HYt zY*#h(ShAm@yC;rMz-2+h`wZC-%On%FXNQfKYByejE-txP7vFwb*eUJ%Y^aPvqv+71 zhGrRR&9^fQJt?Y%W6Xzc&>l}rMl3`0yC@4{_NHBI*xE{ZQ8~)`Q9zUzI~jJiAoH_; z1Ns0QW-9A;6h}aTEe?N;TR#QgD*ncsG?8e z>8S8c;EwZ_+JiCYfLmpc!2HraWbNVq%?xXiT9BoO2}J&d{%Eh@Kiyz`?FIxHZi##e z=dVP47v^6Ea&nPx0KCST;S_UR_x+Ox2`L+XbzK!`SiS!%+F?_^G?s@&nUBr z`_oF_oxMtaTG7LW@Dl5X`eZljWj+1Q;AYGPS}{c}thzMB{L+n+lP_ULPhY?OAKsu) AUH||9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST b/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST new file mode 100644 index 00000000..6c799b68 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PUSHNEW ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 270 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; JULY 1,1986 SYE/ CREATE TEST CASES ;; ;; Filed As: {ERIS}CML>TEST>15-2-PUSHNEW.TEST ;; ;; ;; Syntax: (PUSHNEW ITEM PLACE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; The form PLACE should be the name of a generalized variable containing a list; ITEM may refer to any Lisp ;; object. If the item is not already a member of the list (as determined by comparisons using the :test ;; predicate, which defaults to eql) ,then the ITEM is consed onto the front of the list, and the augmented ;; list is stored back into PLACE and returned ; otherwise the unaugmented list is returned. ;; ;; Argument(s): ITEM - anything ;; PLACE - a list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a list ;; (do-test "test pushnew - test cases copied from page 270 of CLtL" (progn (setq x '(a (b c) d)) (and (equal (pushnew 5 (cadr x)) '(5 b c)) (equal (pushnew 'b (cadr x)) '(5 b c)) ))) (do-test "test pushnew0" (and (progn (setq a ()) (equal (pushnew () a) '(nil))) (progn (setq a '(a b)) (and (equal (pushnew 'c a) '(c a b)) (equal a '(c a b)) (equal (pushnew 'c a) '(c a b)) (equal (push 'c a) '(c c a b)) (equal (pushnew 'c (cddr a)) '(c a b)) (equal a '(c c c a b)) )) (progn (setq a '(item1 item2 item3 item4)) (and (equal (pushnew 'cup (cddddr a)) '(cup)) (equal (pushnew 'cup (cdddr a)) '(item4 cup)) (equal (pushnew 'knife (cdddr a)) '(knife item4 cup)) (equal (pushnew 'item3 (cddr a)) '(item3 knife item4 cup)) (equal (pushnew 'milk (cddr a)) '(milk item3 knife item4 cup)) (equal (pushnew 'cup (cdr a)) '(item2 milk item3 knife item4 cup)) (equal (pushnew 'bottle (cdr a)) '(bottle item2 milk item3 knife item4 cup)) (equal a '(item1 bottle item2 milk item3 knife item4 cup)) )))) (do-test "test pushnew - with :test/:test-not/:key keywords" (and (progn (setq list '(1 "bottle" 2 milk 3 (knife) 4 cup 5 #\a)) (defun fun (x y) (equal list (pushnew x list :test y))) (every #'fun '(1.0 "BOTTLE" 3.000 (knife) #\A) '(= equalp equalp equal equalp))) ; (progn (setq list '(1 "bottle" 2 milk 3 (knife) 4 cup 5 #\a)) (pushnew "Bottle" list :test #'equal) (pushnew 1.0 list :test #'equal) (pushnew '(knife) list :test #'eq) (pushnew 3.0 list :test #'eq) (equal list '(3.0 (knife) 1.0 "Bottle" 1 "bottle" 2 milk 3 (knife) 4 cup 5 #\a))) ;; ;; (progn (setq list '(1 2 3 4 5 (6 7 8) 9 10)) (pushnew 12 list :test-not #'(lambda (x y) (or (numberp y) (listp y)) )) (pushnew #\a list :test-not #'(lambda (x y) (characterp #\a))) (pushnew "lucid" (cadddr (cddddr list)) :test-not #'(lambda (x y) t)) (equal list '(#\a 12 1 2 3 4 5 ("lucid" 6 7 8) 9 10))) ;; ;; (progn (setq list '((1111 2222 3333) (4444 5555 6666 ))) (and (equal (pushnew '(1111) list :key #'car) '((1111 2222 3333) (4444 5555 6666)) ) (equal (pushnew '(100 200) (cdr list) :key #'cadr) '((100 200) (4444 5555 6666))) (equal (pushnew '(1111.0) list :test #'= :key #'car) '((1111 2222 3333) (100 200) (4444 5555 6666))) (equal (pushnew '(1111.0 17) list :test-not #'/= :key #'cadr) '((1111.0 17) (1111 2222 3333) (100 200) (4444 5555 6666))) )) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-REST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-REST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1451af98e3f673672832faa4c9ce98dd0f747d35 GIT binary patch literal 742 zcmZWnT~8B16urBJwvd)A#E)oCWsO>ExErZInJ*2I!tSqAJ z{oI4qoTe>J=XKXS<2pxFy@r2|(Jo;!x$JUITV9$z{l-2^N&oP1ngm;VnW${U!X$TsD=u+ZIGaU-po=@+3$G*0?DjzdU?0O|zG4})Xj|-1dLyOS zhcI2V@Fq8=uM?1y|5yaO#KI}j9Txkk}RbG4qD%DR>xKZg;*(olXiV>)Kc0C$dl|-ctDtY}w~OT+-82@#iUa*}x7cFH<^#Ie^d z^cuQL&RF<7%-bf%lnXrZxFrDQt?0%?frW{o|J)B=`fDsqi;$5BH}iyr_o&w&p!t1$ z9yM$H%QaBjKl?ADw!a{;uk29fQ|}rM(J8@KhMPr79Nl!IlxX7uwkkFy(RKKOPEY>= Dk?`Hy literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-REST.TEST b/internal/test/LANGUAGE/AUTO/15-2-REST.TEST new file mode 100644 index 00000000..9e8b6a2d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-REST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: REST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-REST.TEST ;; ;; ;; Syntax: (REST LIST) ;; ;; Function Description: ;; REST means the same as CDR but mnemonically complements FIRST. ;; macro SETF may be used with REST to replace the CDR of a list ;; with a new value. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST REST0" ;; ;; The tests were incorporated in the test file "15-1-cdr-and-rest.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL b/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cec96f528666316ce0fd3379db112ee0340201c7 GIT binary patch literal 2553 zcmb_ePfQ$T6#r(H{Rg|SAZaUYU`n=>t_fCbD9q_)u2ico)T-QUsmxVMwQ^SHW za(L+V;h~|y=I7s;H<>_*5RxSuNW6puh=Z6nj6g^eRgI5IvdAk!Tnw2@rs081_>?Lp zO{0B?tCkk{IsLLehsn%W2t$bZwc&}Tl!zuJ6tm7;Wqjs!!!IfPBqSz`iG=lRMZxHd zX|#r4FpR8%SXsYA$!Cs+7?XaZUd$pEwUXO>5go-Ws&XNNOxvAn?JCTK9KDNWx5k0XM>Gy5FL97XM!+>}Vqs4^#uM z08keAEq?V)WEuy4ZfMJ_g^=Amc+KT@RB-%n7@>s+|FPUl`9L9nGxUvdBos*~qY@4p z9}|>OSxoXH5=fLWHN?89pLN1t6HIb@C?aT)7z~+~O2Q;YtWkEU)2b%MS!Tb5mIzUw z!wU*V*q(ZvSBD>EBQ)S>K_&u>kNO?WFypNuF_}yx`9w;aOlcuUD;W4ff-=opay3L5 zM;pjkK>)7+aw8b19k~cb>Hy9mSn8LM9kKMC$VSirR_@f^mGiY^ zxkouX-Lc7aXh^3jYEfRDj*lc{zVQa2&HJ<)$$8oXggnE0w)Y(+PiYXz6Pw(%tcgK; z-lM@O8jRB5X&QWm29MBSGsbxe0i0G*@$?tGI4%WKmht!}?L+biq-~M{(;>*bD2s7X zu~J&6$5H)*O}?z6YN3wkjZMzO;*dNdUGUJ-h^*$h1EIj&H&-(-|su`c?}th1(ZRLkoeJf20aSeu{G z%M~tD*12r0st<5;g-iM{XVx8TlMA6ev^=~swd|#8zEmzk!=ZQXWK4)FDb?=ZD%#wD zhNZMr9D2HC6HUkxyt}r|_bB|=Uvzg)CXy4=;0>cODUI1~cg;G6+j3R zLOFcRtx%Cdr8HkEFXRhZNT5i4CHGt6)504 zxl#iq;BEk5W0LLvrFoN_%Kvn3Ee~&a{(i?w;Z zSOrm`!evVf1wA*w6-!kv2a{SZE$X>JjQTDOA?b&LI$cmWxYzIXxEbs=DqtF2P+ZV0 zVxw-Lwf=gCML>TEST>15-2-REVAPPEND.TEST ;; ;; ;; Syntax: (REVAPPEND X Y) ;; ;; Function Description: ;; (REVAPPEND X Y) is exactly the same as ;; (APPEND (REVERSE X) Y) except that it is potentially more ;; efficient. Both X and Y should be lists. ;; The argument X is copied, not destroyed. ;; Compare this with function NRECONC, which destroys its first argument. ;; ;; Argument(s): X - a pure list ;; Y - a pure list ;; ;; Returns: a pure list ;; (do-test "test revappend0" (and (equal (revappend '(1 2) nil) '(2 1)) (equal (revappend nil '(1 2)) '(1 2)) (eq (revappend nil nil) nil) (equal (revappend '(1 2 (3 4 (5) 6)) '(7 8)) '((3 4 (5) 6) 2 1 7 8)) (equal (revappend (revappend '(1 2 (3 4 (5) 6)) '(7 8)) '(9 10)) '(8 7 1 2 (3 4 (5) 6) 9 10)) ) ) (do-test "test revappend - For (revappend x y), The argument x is copied, not destroyed." (progn (setf a '(1 2 3 4 5) aa a b '((1 . 2) (3 . 4) (5 . 6)) bb b c '( (( 10 9) 8 7) 6 5) cc c) (setf aaa (revappend a b) bbb (revappend b c) ccc (revappend c a)) (and (equal a aa) (equal b bb) (equal c cc) (equal aaa '(5 4 3 2 1 (1 . 2) (3 . 4) (5 . 6))) (equal bbb '((5 . 6) (3 . 4) (1 . 2) (( 10 9) 8 7) 6 5)) (equal ccc '(5 6 (( 10 9) 8 7) 1 2 3 4 5)) ) ) ) (do-test "test revappend1" (prog2 (defun fun (x y) (let (save) (mapcar #'(lambda (x) (push x save)) x) (equal (revappend x y) (append save y)))) (and (fun '(a b c d (e . "s") ( 90 100 111) ((( 3 4))) 'hi) '(the tail)) (fun '((1) ((2)) 3 4 5 6 7 8 9 10 11 (((12 13 14))) "isomorphic list" 'do 'you-understand (staghorn sumac)) '((((((((((porky pig)))))))))) ) (fun (append (make-list 50 :initial-element '(Autumn (foliage))) (make-list 50 :initial-element '("buckthorn" (Rhamnus)))) (make-list 100 :initial-element '("The even numbers are cute, like: " (2 4 6))) ) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f0ee10ca5a80ad3a80d4e186c84e0e30fe68a375 GIT binary patch literal 746 zcmZWnT~8B16urBpAK*e-;zu+_CnUUV7}70%(E8%Kozj-=F6>SNJT~ptHbS@QhlUu5 z@xiAxT8L&=$Z2j9`c8S?r?yb zeh>BiVXy9?Ca?`{uC4B&>!>PEY0g?~_b{Hg8 zN?eKyC6i!FuMm}uSdidOaMdLa3sM<0@Vj`|d+zNDGkblI0N95hQK(u5E!h@3l3q&+ zdmqe}EWE*u>1zb!#9tP{F0tT>b{}W3OAOn}16LE<7BarKPRi182R46{<*m6}DJj}M zc?vN9Cay@W_(_RZtTk7ar?~HwYUtD`Vu#SG!*v^D<1u%~rKBQD|94PZ4V6ed zoQ)*7*Ey9qj_qK(N;j%hjZAZZqUzQT9@kwpo-6aziJ`eM@=$LYmXCAWzz`Pk=pDMB-KI}Z}_%Awn7APWSG>JF;m<4yK*B_vT z1APHCYkch*sNI?DjHn$fO6&_elKI>_hC_5p@TKu)i4sRQ-B1y2T*7A6rX;)upV8Ub EAJ^aB-2eap literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST b/internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST new file mode 100644 index 00000000..663182fe --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SECOND ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-SECOND.TEST ;; ;; ;; Syntax: (SECOND LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST SECOND0" ;; ;; The test cases were incorporated in "15-1-cadr-and-second.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..322d19ffabbcb851e4e3b6ca67b87bc52161e0cc GIT binary patch literal 2964 zcmb_eU2qds6ux)2Y0{F|(gN)iElX_y1B*?84h<@7(=ADxY}(xoZQqPdAeA)fv?<6a z&|yZ$pP+^+?uBuj(FY%V5SeilaOi{Mi^7b)sBb>_Bv0_*IL_$cIeRxHO&!D;l5D>3 zoO|v$_niB;CE^|rMWs-FdS)t{o|W?Rg_-$+bT~gN&E@B3C)3hl&`U3d;<|b=tb~Sl z?hDi#6)lsq>0}|DlFa$^Tq=2DhZN|RV#yOypl|Qq9a7J(;O@R)Ah5H3P%)z1SGmVn zI+ZK;2~_my4)*j0clYkBzx%#*o;KzQA(LbYp^lJ7A`+oZELCP2qDBOCV3bW~+>JDI<+=v^c4_#m_BA1;%q!ZEKp}zBrPi?xm{$4mLQ+$ct@eDBYw%6E z25#^Hlk|W8(Kl47{F!W98fz2m4=smX!$)xA;fz?wl}GF;2e@%rLs}8`#^qpzW<|rM z)eTO2)_t27{NW5#++QAO9TfFJeie0udS2J~xUvl}Ev-wAM9WI<5Ncc9+ zl|Prc)bg*3rIcx$Y9vCP^=|P|e<-dEL~sYnVMQB=s=C}C0gZOh@CzR16Ws8);HiOa zzSbX7%ura?RWqT(HVxVPyw;d7Of@FZ)fQ&l&%C0K`NTD_wIA`Tx*pf%c)}b>n10a< z9lU-;n~-h2;b&B=2OU+Gj}P4VaD42pK0bUkgs>VsG&bN7;0N!ugK<5km?*9XC+qGd z7E%nAhhSc47QP4Tx|lMo%F&2{9fZ$WE5bNKZ^8g;0id7S61~W!0)~hwBOyh{Mh(OU zVPvVl^v&)4(V_b z?);QAmE#vS>P~fmnQ+HitY^(^2iwm4>BiRd+U?XwmH*I#{$(w$Xh+>G7Do8> z{yxy;XKwjJh2?Vm6>h7;-sBy>u*<;?K(b8X%kdLCOZstDmH`a+k)0(y4(5Uj6*JbN zD7sQev#7*Z8ais7C$-tsfgc-*Ros|OPCu7Q;{2~V2Vo6T`y7O$&??e#kO?|)tr`{i z(;gN1y=qk5U{3C^U>k%q4+vj|>6NfRufkO{w0yrs;1(Ogn+zVje0W2pc51bX-+cd- zfCy9WBp|>GUT3Fs=)u`#6`RYVsvU~xaSe|s;&}!ZmD_m<+y`7xN4K-oHe71zXhMmu zXQ?K(rvcCML>TEST>15-2-SEVENTH.TEST ;; ;; ;; Syntax: (SEVENTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test seventh0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (seventh ,list) ,elm)) ((or cons string) (equal (seventh ,list) ,elm)) (t (eq (seventh ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) 7) (mac '(1 2 3 4 5 6 7 8) 7) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 7.00) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) 'non-nil) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) '((i) (((ip)))) ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '((((t)))) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") #\F) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) '(foo6 bar6 gack6) ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |Hawaii| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "vacations" ) ) )) (do-test "test seventh1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (seventh a) '(2 10) '(3 5 100)) '(2 5)) ) ) (do-test "test seventh2" (let ((aa '(1 2 3 4 5 6 (1 2 3 4 5 6 (1 2 3 4 5 6 (1 2 3 4 5 6 7 8 9 10 11 12) 7 8 9 10 11 12) 7 8 9 10 11 12) 7 8 9 10 11 12))) (and (equal (seventh aa) '(1 2 3 4 5 6 (1 2 3 4 5 6 (1 2 3 4 5 6 7 8 9 10 11 12) 7 8 9 10 11 12) 7 8 9 10 11 12)) (equal (seventh (seventh aa)) '(1 2 3 4 5 6 (1 2 3 4 5 6 7 8 9 10 11 12) 7 8 9 10 11 12)) (equal (seventh (seventh (seventh aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (seventh (seventh (seventh (seventh aa)))) 7) ) ) ) (do-test "test seventh3" (let ((aa (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm))) (setf (seventh aa) (make-list 15)) (setf (seventh (seventh aa)) (make-list 15 :initial-element 'rah)) (setf (seventh(seventh (seventh aa))) "magic kingdom") (equal aa '(a b c d e f (nil nil nil nil nil nil (rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah rah rah rah) nil nil nil nil nil nil nil nil) h i j k l m)) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4b588856859985219158689f377808ae7b6cedce GIT binary patch literal 2756 zcmb^zZ%i9?^mkV%U7^rI$2!K?1=)ffhZJYFu}wV6m6o-4-Q88j7njQ^%Og{br2G5{;RO5MPe#=Eji@nhF`5`nOpHsGV2plrzIR6j#*BVgbHCqv zzxV&W`@MIaAvK4CQ7%|KHlE98Cb;5cd3>_WjTI-jQgL!3mEp#K&OINL74e0z5Ioqu zFW^*HaZ(eRWI2=Ow8=~v^^t8{w$dUy8)_I5k(zHOXm+(kl2iYy@5K!}^zh;deT`!!M3_)sJ&@{$k}{l<); zJ0KH2p^A#3dwRKYah%U*p3CGhnPVlw5MrFs9ifC2)FQHE%retVo$-e5ib#AM5)+0* z!aA0%pmoO3U4h5=US5qH*1`mWX*f-YjloE+X0Hu1R|@3P^o!$&m4SB`izj7>?_hR z%eVlW^NsAN=pd{kWFeR8G>ftv3Nug%rDoa7e1An{alUs2-CjYL=6w}(acx8x)dP#` zn@U^`hzlJ;LJL-ih~=xE$+oo2Z(oL6EclKE&Rf8W=RrkeYpF!E0m6Vg^?!DV(fp&=;;%D(^x%NE>oApg-xj}9-4Ks~c>dmG%x6G}gE&lg?gB!c)z87vL>(03e z>xQV=X3|0{SX?bi`TO+NtH9=hUeo;|m zg_jdrJfZn*UJ$PH3(_cW(p5iYY#XTyM#QdrM}()E5L$(Up%EIL{R6DoL$VSRG(7$Y zhP*4;1qD^KOj0MZ;~?Fjj>ZP$C|{W|KxclZn-Scxz%Lf~$pYV7;HCw>w7`dS6DnMw zJ_HA$s7kv2-hKSGT4o%k8S*mSG){e6z#@AK0aKP9wtV@dcxrny|f`nnq*u;bQ440l20CcI-SGA@0zLwP}pr&jeKX!R>KQnRhgPICn{J_ivT=_FTn;g z4*U(uDAwO^-M?F)Mu%vaMnH%Tn|zAxMZQ8UD8C?o9 zBr}w%?h#?s#8?gL06nQBfPY`gXYex)gc$A?%w?ymc}$J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST new file mode 100644 index 00000000..fc9a6f47 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SIXTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 3,1986 ;; July 3, 1986 Sye/ create test cases ;; ;; Last Update: July 3,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-SIXTH.TEST ;; ;; ;; Syntax: (SIXTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (SIXTH X) = (NTH 6 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test sixth0" (and (eq (sixth ()) ()) (eq (sixth '(1)) ()) (eq (sixth '(1 2)) ()) (eq (sixth '(1 2 3)) ()) (eq (sixth '(1 2 3 4)) ()) (eq (sixth '(1 2 3 4 5)) ()) (eq (sixth '(1 2 3 4 5 6)) 6) (eq (sixth '(a b c d e f g)) 'f) (equal (sixth '(nil nil nil t t (nil . t) non-nil)) '(nil . t)) )) (do-test "test sixth1" (and (eq (sixth '(Do a deer a female deer !!)) 'deer) (equal (sixth '("Re" "a" "drop" "of" "golden" "sun---nn" ! ! !)) "sun---nn") (equal (sixth '((Mi) (a) (name) (i . call) (myself) (Fa a (long logn .way) to . run) nil)) '(Fa a (long logn .way) to . run)) (eq (sixth '(|So| #\a |needle| "...." Oh! #\I |forgot|)) #\I) (equal (sixth '( A needle pulling thread "yes !" ((((((a) needle) pulling) "thread") "--") . "--ead"))) '((((((a) needle) pulling) "thread") "--") . "--ead") ) (equal (sixth '((so . how) (do . you) (like . my) (do . re) (mi . fa) (so la ti ( and . do) ?? ) ) ) '(so la ti ( and . do) ??) ) ) ) (do-test "test sixth2" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (sixth ,list) ,elm)) ((or cons string) (equal (sixth ,list) ,elm)) (t (eq (sixth ,list) ,elm)) ) ) (and (mac '(New Mail for Sye dot pasa xsis xerox) 'pasa) (mac (make-list 5) nil) (mac (sixth '(1 2 3 4 5 (10 20 30 40 50 60 70 80) 7 8 9)) 60) (mac (sixth (sixth (sixth (sixth '(a b c d e (1 2 3 4 5 (11 22 33 44 55 ( 111 222 333 444 555 (aa bb cc dd ee (ff . gg) hh ii) 777) 77) 7) gg) )))) '(ff . gg)) (mac '(blackberries "monroe" (county) (tennessee . olympus) om-2 ((with 90mm . macro) (lenx . kodachrome) . peter) 'arnold 'inc) '((with 90mm . macro) (lenx . kodachrome) . peter)) )) ) (do-test "test sixth - using setf and rplacd with sixth" (progn (setq list (list #'+ #'- #'* #'= #'<= #'max #'equalp)) (setq aa (mapcar #'(lambda (x) (funcall x 10 20)) list)) (eq (sixth aa) 20) (setf (sixth list) #'cons) (setq aa (mapcar #'(lambda (x) (funcall x 10 20)) list)) (equal (sixth aa) '(10 . 20)) (rplacd (sixth aa) "end of testing") (equal (sixth aa) '(10 . "end of testing")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c87791099f5b3c0abbe6571b8d15579aa722b6e3 GIT binary patch literal 2917 zcmb_eO>7%Q6rNc-iIdpGNlO!@s9BX(t=w)KCvDTD1-jX6YA5z?vb$~?BqU7i)~1df z5(lWN{-_6pU=gH&vcr#%dVm`$IUw4iMk+$$&;uvnz^%t#3IeGYRNmWJJ8?n_NVUED zz4zwL`>HRU=cg*>pLZ5v}>`Tqb>bw;1gflj+l9wEy72-C|Ggz`p*0Xmn50uxuu{t;&pv zY^GS56J0f@d!VOpU|-*!rU#!omua{}2$>?w2#th~O?VO-mY%Csaw3lWN3S zaO?nNBBe~#aO~C|v0R#w3fWh)1x#joj!;6J_w2xMN>i-3t~rbJ0u4Iv+M&26jX`4a zQI!Y*&k9U=(Qs4`gTN^*x1=h>rN7a10h0| zfrKAY1^>&r&dw`ektxS8W;96Wy) za*zJrfQZ{JHiT*J+D#4UdkdrQXx|aCkb6TL5hx_HaJ6G%6Q)>sf{5BGN-F|hyjHk& zc;~~0R}>4OdwdNZPw2iQmCzf}Hx&D(R&`cr0ls5-ML<^#!J@#g`C$qxs%RICApD1V zU&>u=|HmD&kPGL-L}+wAu%C)3x;7NY11QC0Z787{(qJ4U+EFti1XxIDfTs=~Kb-Q` zh$34`Ofpm}Wxy#_++$vEPMVgQ6zF;lOOLRiFT_H=W;oeTL{!7j4M|T~V<{`*3&Mn8 zMAjxHS8hfa^)-Qv%GK_H=N`JpzO~&WxXqCDO<>H0wWt&5>sST zfBwIO#4bXwvX>;^d@ zsR=a+eHP^tYzukx?~1zZV!9K^+Mx38@`OJp&ZE>-r~mT*u^R*0mjS31wfONf$F%C)TzV zlXIzdwhJ@x?Qrad`QoW!>9r!VPdj#VIXhPt%h_T%*NdVq$L_LFwDp|4RXmY~yEY@{ zi~OQQ*}3hYCj9O!Hn9z0pAND%1aOBi#6jgS%;6{pC^D+V0Tx>>R6am6aqZW!o2Jtz z^HbufeDP$aG`%wJPD3-J+**P|k}u%hwG%PcMK@N~&7!P_^|F0zKRdws(8dUBV~5yb zhV>NAIv+cW0*JRLhALaCwC4OI;+AU236lj;4Yt;JO1D(LGhSi1IKp&IJ$q1;XL}La zAqFb={B`vWfyP=oSe1vGgZzgx!p>sN2*~JtHiGcmqYa?S9j^Int>)?wYK&Li(qH(* zTW&GfAf(C^zR|ySbEHc(IY!ahmu`;qqO<5jb~nEMfY**NQfENytIHtyf^(VF7cxhF z3KPfPTu4v9lu6^}TG!oRdsDZ&L4$K_dK`Fy23psLRmZ~uwN+cW8x6__y$Vuzp_nf@24_ZS&d|bRWmw zP+?W=SlrMxY%(P9Ebb`xf88OV1a*8D%kD&(I-ZgfPqJ(qi?je=uceZMs)4sjz?vLW iv9;4}P-2{=8}RnSzBN(Pv<$e#2(7Id`DpIJgTDd3@Cq&f literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST new file mode 100644 index 00000000..eb5e02b1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TENTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 5, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-TENTH.TEST ;; ;; ;; Syntax: (TENTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test tenth0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (tenth ,list) ,elm)) ((or cons string) (equal (tenth ,list) ,elm)) (t (eq (tenth ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) ()) (mac '(1 2 3 4 5 6 7 8) ()) (mac '(9 9 9 9 9 9 9 9 9.99955) ()) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 10.001) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) '((t))) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) 'm ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '(x . y) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") "foo2") (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) '(((('foo9))) (((('bar9)))) bar10) ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '|Mexico| ) ) )) (do-test "test tenth1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (tenth a) '(3 5 100)) '(300 500 10000)) ) ) (do-test "test tenth2" (let ((aa '(1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11 12) 10 11 12) 10 11 12) 10 11 12))) (and (equal (tenth aa) '(1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11 12) 10 11 12) 10 11 12)) (equal (tenth (tenth aa)) '(1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11 12) 10 11 12)) (equal (tenth (tenth (tenth aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (tenth (tenth (tenth (tenth aa)))) 10) ) ) ) (do-test "test tenth3" (let ((aa (copy-list '(a b c d e f g h i j k l m)))) (setf (tenth aa) (make-list 15)) (setf (tenth (tenth aa)) (make-list 15 :initial-element 'rah)) (setf (tenth(tenth (tenth aa))) "magic kingdom") (equal aa '(a b c d e f g h i (nil nil nil nil nil nil nil nil nil (rah rah rah rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah) nil nil nil nil nil) k l m)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL b/internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b447133228b8228acaa8aaf9e05d5fda13c0f359 GIT binary patch literal 744 zcmZWn%Wl&^6uowuM}t$P6%TQX%|M#Jx8L6Ny2u~&_XmBn z<9AWdA9NcY+TnHdO0#V8x~yvJOOKVbbLpqi_3C}EiRi%VHR}h9NLfbJ`TK{wQF0de@Jj6Ln%eq|zE+(-Rsrb=4tq3O_*!)=$YcqFdg?Rh) z8Nl4zq$IRXewqCJXSn{}{0%T{y)!GKkO4SqeZN&3dx-a)@iFBBk33;U0ONLebE?dOAsCML>TEST>15-2-THIRD.TEST ;; ;; ;; Syntax: (THIRD LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST THIRD0" ;; ;; the test cases were incorporated in the test file "15-1-caddr-and-third.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..285a517fbd8ca1b1a8e2e4c909cc8eb477246e7c GIT binary patch literal 3375 zcmb_eZ){Ul6uqc1F?aq9@Ys|v*rXLYCo3pMdsQbdUc#!xW0!aw)$$Q zOVk<4CqnEHA+>1TdN&agayD}fu+=9j>uKid4HNXcbA6}HuL+sUoHF+?>H+OyZNiV< z#pNa>Kay$^jTf@foyBaG==C7arCr4!nfFpl`Szyr?el16r0Z-(ewL}g+r00uMmJBqLY6ArkXt0H`2gfe-5))luRNI7Hu5(vw zibc7{T=3q)D2U=Zgt&qFkT0JZs)JPzOUs*cnc0z{hP>4d}z*HY&U755t^}l zG|>UF7Cfyw$EvrqMhJYv(lWlGdZ01c4a>)X^Wv4ltS!&!sz-{AtQHN(k;dtTu14?w zf0Fsk#SM>rv*$A25ien@op*9|{;*|s_u{=2=+VvYs1Xb7>IKBy9rrUg_poYM9#|`2 zRl%x+<$|TcWmw}6>vp&&5Hsw-7+hvyaT`{|55#SwpV6frw&mw;Wesdl{lUeFSDvz# zdz5u>DX#Jxv6vMLScCS!pzT-IgRk4Kn+E~{kNY`QHUP%-UEHhG3QY&?3FO=jiVqY; z*Ad%@7`VZ$-1+FOyao=Dt9Tc$$E#I`)D;mc*00-WHbLathbI%(ak-6)U|g|kAgcrCml{nhbm!_d%W%t-x%k0o4`eF zfGC$ZNVI(Lvs7VX(-^O=;+sJzU-AYNpGoUuA=o_uvOlHuixfi=Oh~Iwik)zDYQ(bI zxEE+xSHWzRW=FvcNi$S1gTkbD1tI-iFwvi-cwK_i(#i-y{tzJfRa!qt@e#05Lr{@7 z`PN?Ep!3b`eDjltcXKZus`{*xtDG4h9nZcpj^++0=blbaO>2`AW64yq1F?1|x5-AV z;ke$Q4JYA$$U$vnT>gnb?D!UNQ~rYKp{V@koOc!&B&iR_4Ba*Yk4#Rq*EV8$G|t`V z22Wt`pk*7P1La5VM~d&t%VL)H9gS?(%XuBW`*HuSC#<+3|S zQ^RYa0<1L*W#!bDl9M51*(&u`j;}TCkwb7BA|xIZVLbBK2;K)-*v$e1>Q@VXsDD~u zKpmb&u>>CB+hk(M7vWyMUecUg(i%G|T4OWit+gWI%d$1YSycE_OhKp#bT~#-*DvMr zNUn-`f}aa_c8PG*wikR<*jL3~BOo|L!tgGwQI$24@)}!! zjQk^NBsZN!bykic`3m&HNRsQ26~0OZL+8(hirQtw7ij613YSlC>bLS*eA4Ln0odS$ zBUpqk0CZ;bq3xU*MbAZyEO9&i2-C@u{cL%UDefO~a&09ShZfL;l}b*fwN!Ru1g?zX z$?RcmB6%pSg|>&Z?64M&PDfwhO#ys6Yxp)E*@CkPa)U&mVp^VvoWn{l+`s=HxCX;* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST new file mode 100644 index 00000000..498662db --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RPLACA ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.3 Alteration of List Structure ;; Page: 272 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 1, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-3-RPLACA.TEST ;; ;; ;; Syntax: (RPLACA X Y) ;; ;; Function Description: ;; (RPLACA X Y) changes the CAR of X to Y and returns ;; (the modified) X. X must be a cons, but Y may be any ;; Lisp object. ;; For example: ;; ;; (SETQ G '(A B C)) ;; (RPLACA (CDR G) 'D) => (D C) ;; Now G => (A D C) ;; ;; ;; Argument(s): X - a list ;; Y - anything ;; ;; Returns: a list ;; (do-test "test rplaca - test case copied from page 272 of CLtL" (let () (setq g '(a b c)) (and (equal (rplaca (cdr g) 'd) '(d c)) (equal g '(a d c))))) (do-test "test rplaca0" (and (equal (rplaca '(a b c d) 'e) '(e b c d)) (equal (rplaca '(a b c d) #\k) '(#\k b c d)) (equal (rplaca '((a) b c d) 'e) '(e b c d)) (equal (rplaca '((((((1))))) . 2) '(3 . 6)) '((3 . 6) . 2)) (equal (rplaca '(1 2 3 . 4) ()) '( () 2 3 . 4)) )) (do-test "test rplaca1" (let () (setq a '(1 2 3 4 5)) (and (prog2 (rplaca a (nthcdr 2 a)) (equal a '((3 4 5) 2 3 4 5))) (prog2 (rplaca (cdar a) '(4 . 4)) (equal a '((3 (4 . 4) 5) 2 3 (4 . 4) 5))) (prog2 (rplaca (cddar a) "hi") (equal a '((3 (4 . 4) "hi") 2 3 (4 . 4) "hi"))) ))) (do-test "test rplaca2" (let () (setq ab '(5 4 3 2 1)) (rplaca (nthcdr 2 ab) (nthcdr 3 ab)) (rplaca ab (nthcdr 2 ab)) (tree-equal ab '(((2 1) 2 1) 4 (2 1) 2 1)) )) (do-test "test rplaca3" (prog2 (rplaca (rplaca (rplaca (rplaca (setq a '(1 2 . 3)) 'foo1) 'foo2) 'foo3) 'foo4) (equal a '(foo4 2 . 3)) )) (do-test "test rplaca4" (progn (setq aa '(a b (c d (e f)) g h) aaa (append aa nil) ) (rplaca aa "bar1") (rplaca (cdaddr aa) "bar2") (rplaca (cdadr (cdaddr aa)) "bar3") (and (equal aa '("bar1" b (c "bar2" (e "bar3")) g h)) (equal aaa '(a b (c "bar2" (e "bar3")) g h)) ))) (do-test "test rplaca5" (progn (setq a (make-list 5) b '(v w x y z)) (mapcar #'(lambda(x y) (rplaca (nthcdr x a) (nthcdr y b))) '(0 1 2 3 4) '(0 1 2 3 4)) (equal a '((v w x y z) (w x y z) (x y z) (y z) (z))) )) (do-test "test rplaca6" (progn (setq a '(1)) (rplaca a a) (= (list-length a ) 1))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-3-RPLACD.DFASL b/internal/test/LANGUAGE/AUTO/15-3-RPLACD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c6b9d939750b52cc65c43bf105f074acf78edf49 GIT binary patch literal 2650 zcmb_dO>7%g5PrLB$N6({Oi1l0O}9xJMONI#NlMa`qHZ>u#LZ^ctk>F>A0gv7wN=*+ z{-LTOs;E@$#WW;N=|0Mz#Gyh$Pz51TS~UmYL=Ie#kT}5&4hV6m#Dy@k>-@Dn^uWP8 z-^`nt_q~}n&r8I0N|bpqcWy47N#^-nsW?|E^0T=-U&xj6i6lP@c79$|HR;VsL7X~t zEL0!ev69FqE zS~y8C7L_!!+|9y`0&F~&2w`s_m2XmaPcnD1kJ`&)YfkpU6x!(Eu`*()qBb1V^VkSD}eu6ntEILmXM{?73Cz$xB=bv8LjBQ`D-L( zEuCnyj$Yl5>D}DVg);k2`1BersPncD z4;G)%!x}CAvqnoRbh-z3U$@JP-_>JPI#yi9?O!umScXL-LWbRj+tzB1CoIo$>h|8p z-k7D7C+#7u+q_S4V01SCyUwV)c)BQZU| z?E&A$fS{ZXTJ~swGTc)bKT18E2Z02j3Bfo3FM?A5o<<-7XhtwbJuu{h4-a_*w2nG( zw7oc~H(~#paaEfZbX2cEWb<}8L?J5KBxoZphrrt*3sLlC{-NzCez(Q1m`I33BxMY( zKiSsrZ81;V(0GRKLooub4RRPBCs|S^^hvZ0QXT~lOLd|eIUU4xwD{-&5afZCf&51I zrD3EByQd6{;gh}zniCCJZ~k^E?D-_gz~+9A@; zA=-I>`g<|@hFNx%vS+io^I23YX1TGLEEM_tTqd5F=||h5S>CUst>dE5!OzCwPhf^m zXYCgpZ5I!s+e_w((_C?wD;&dKKC!2H-r>A_;x@drD_o81@`(qtv$b_@bc|Z7h$bxu zM8_=$L_KB&y2hCmm=K2(M2)Mq4j1;CmA%k4$Al`#)Pon0)m7;Ia@jQ=)AUJ60|jCi z%N!`^X@sM2fdFyvPhbI7g^PsQVO53^00rCufWc`9I_98*DTlN<1^`aF`df-H98C)PF+0}hIv5eXlxXi zDIz3+qA?qASUN<9=~2{vL0%Pxj-ql8!^b#;Um-lqBK+Kf48mJx#br^YlFg4!Z1JMu z$55eDbQ%LcHY+u>j~>HR&*2AaMvv1YRM^^`LaV?hgrc7g&_Sr*PO5L2Hz5*E)Glfg zG$#1au*zX*mLNxIBf7zOybyz0+B0yTb|H;|SsvVRm-!%HDkQ5H8(s@Ok;@i}`BI|D zC(`*uDHG50nRKC8z}Ot^M$u+goDD6o!-3u*t7y%@mti>vERugMiu5%+VZt7?zpb6g zpS!0hgx-Hx8Ohf$4%B+mCa}%Sq}3<#rMbe=+_wG&CT+rs_^2Q8GqeS>dCML>TEST>15-3-RPLACD.TEST ;; ;; ;; Syntax: (RPLACD X Y) ;; ;; Function Description: ;; (RPLACD X Y) changes the CDR of X to Y and returns ;; (the modified) X. X must be a cons, but Y may be ;; any Lisp object. ;; For example: ;; ;; (SETQ X '(A B C)) ;; (RPLACD X 'D) => (A . D) ;; Now X => (A . D) ;; ;; ;; Argument(s): X - a list ;; Y - anything ;; ;; Returns: a list ;; (do-test "test rplacd - test case copied from page 273 of CLtL" (and (SETQ X '(A B C)) (EQUAL (RPLACD X 'D) '(A . D)) (EQUAL X '(A . D)) ) ) (do-test "test rplacd1" (and (equal (rplacd '(1) 2) '(1 . 2)) (equal (rplacd '(1 . 3) 2) '(1 . 2)) (equal (rplacd '(2 4 . 6) ()) '(2)) (equal (rplacd '(a (c d (e f))) '(g . h)) '(a g . h) ) ) ) (do-test "test rplacd - use rplacd to construct circular lists" (let (( a (copy-list '(1 2 3 4))) (b (copy-list '(11 22 (33 44) 55 66)))) (rplacd (nthcdr 1 a) a) (rplacd (nthcdr 2 b) b) (not (and (list-length a) (list-length b))) ) ) (do-test "test rplacd2" (and (prog2 (setq a '(To further (the wise use of) (land and water)) b '(To work (for (the (stablilization))) of world (population)) c '(To (protect "all" life . from) pollution #\, "radiation" (and toxic) substance) d '(Goal 1) e '(Goal 2) f '(Goad 3)) (and (equal (rplacd (last f) c) (cons '3 c)) (equal (rplacd (last b) f) (append '((population)) f)) (equal (rplacd (last e) b) (cons '2 b)) (equal (rplacd (last a) e) (cons '(land and water) e)) (equal (rplacd (cdr d) a) (cons '1 a)) (equal d '(Goal 1 To further (the wise use of) (land and water) Goal 2 To work (for (the (stablilization))) of world (population) Goad 3 To (protect "all" life . from) pollution #\, "radiation" (and toxic) substance)) ) ) ;; (progn (setq a '(((1 2) 4 5) (6 7) 8 9)) (rplacd (last a) 10) (rplacd (cdr (second a)) 7.7) (rplacd (cddar a) 5.5) (rplacd (cdaar a) 2.22) (equal a '(((1 2 . 2.22) 4 5 . 5.5) (6 7 . 7.7) 8 9 . 10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2017879ca9779659e06a71ca78c29db18f5fc07d GIT binary patch literal 5089 zcmb_feQaA-6~FhrXFExg;*8RyN!q@2EnB_0)z4m%X&@ZinZ0~C z#12tFY+=fPKi*v2xaHl!B!)Bz1VvjA(n=?WH2y${KPpX{Ktc%65E4je+9ZTPS~=%l zzr;?`t)QxTKKGt`K7QxkbI!dj6W63asQUBsi@CYXlA2#GE-n|8;V}8R$Dd(0}e!)9n|nYt)@5grvwDNE!)o6PZ|7Ot&Yl z8*%S&AgFu8T1fX;Wy@@UNW2L{k6C7GpIXc>dgn4<%*1*9R_Z`5el3FhX0yxYJV^-r0s7|Z(pvT=Fz$QSbsx>%_<0z{@0Q1(55GxB zIs3Knm_)%w`IYvG4%-4!P<|tq>f$?5^-eF?-d!k>I>;9%4sJmh*_(Z8Z}um$yDY3_ z@!!2cD>d6_8|wV;+Mdni&UKvIo42X$T&>^S&7(WlYqjrbKsW7x8b8eCZosvGHoJG~ z)`xTN_FsO&hTF2YOK^+}O-?(5Pu`u}-6Y7B>?>`1=5smg&bf)yVqG=6JpM>{D1hbZ z9o51^K|SUj3;-uQVtAxR)*>~)=Yr1xp8|cL)#KOV{!wpCk0)YK$9~=joW_(9*FzHB zEfJ4+ShKtj7O1w>GqBp_X4WD%K|k2<(PObl%o|C>qlvgj-Vd_P9xXiO<$S}#pfR+b z+1X$ADTFWuyUJ1Q5hGy9IUI?Fv^Y-tz{r8^;QX4Q3v;X)mm5LaRc$jcmp*{`$Be1a zU?k|Z8y52a#M+U(%?=@XnH@w@W^G7j#9B(M4U5@>oX~%AN&06lNq;Js-x8$473hkX zO$qXtV4e_qtz3`1!`H|yL2d~0J=VU$4yIV!0Be7Q9XiU|y8(^-AVlEc8-_C#IIOUv8>Es5EpAO>J_>WD20W@uD! zUEB=0&GpIqtaFNWTwpaa4_p&3yAS?SV)3v-XyO3X5!0AQHREwEHQC%o3PtWBF zs#jgf6|?F9?1DO*SzXC5rBUvJWgd;A+_9&%W9m#2uHdwqTM+jr@}53{V$IeD7J)Jx zNyM1j+K?m}rq1|;9(+tk2Bj#bSl39Gubf@Wy*64Neai8bxS=#O62Q*UN$-dtq`^T%EQ45S(K4m!Y1I8aKyTj(eZwbFclLjTJr0p_puYwu zhz~jdcw_@GF0Ft|V3~BEwfhUM@hep4U|h?0Qn4BF=-NY;7cLc>(;k%6Rwy? z{4rgN>)ss&9}L9xm=-h`#4cgJUrI#cx=7@g7?zFnqGg`gGePWhuE`RKvHMXcC!EUh zNQk+CLEc901fCXPADXPVOq+=kqF;K$GYzq@D|&Er9UE- z8xSf83~G?YEvPvN$G%VV;VX#W4j-PN;6SP-D4yXIe3MjWD)7>q3xcB}Z81~t)DpItH2@xECAi^3*dj;OX zw$%oNMnB-`%woW1hUl5^@hqkPu*~i|W@$}^(!cQxrLS40QYa>u(CVuYaOci|uRZ0X zvwwN_u8R6j5!3JEX7j>!3?)J#$jfc7FF}x!!_|cM4t;^wHm?pYu0(m>LW)O&njae{ zXFH?#?1##SmTE+G-9KutI1ISRg3KKif=Vq%(xbW>f$m#tbv3UzgioSZL}sD&f2zNd%lhV*y2?T z9|itPP%BVi0n3!9msdr8=NEI!^Ekw8cO@5>a;ba~&U|rhxd0v@;kktAOyy^0G8sf% zfHc^TSI|{n<{y3Xu$i?d9|jB|`0pCrM8ohx#CGa3;xTwBMnwV8r$hmia@&ZY(`Tw! z09Gkk3n;ZaE+v(pg+4FBQs#2=nYx(fGV}Qb(>a}7fPWa%6JTQ9=OcvoymjAqt6gr5 zw-es&wpt(d5CF(qAGDNb(P+Weh%@nCV#cemdyNOaaDz#Y=Tsyv@G|cDWmEdhqiEo=Nj-2M zNt2UM%Rr}~G^_lFuv+M0{(Gd#^X|d>R4osYeTUaPe|3OWv5NZuZ;NW-Q+(HwtAK>B zV*loYF8=!f|2=6l)xDU<_F^8dWj<4X&;{0=x6HG32kaFO)Ks#NDX1x^TX=cSEam6b z#pIJ2weOMBYJNub2aCa3c0cYGH{WFsj@yGhu~boG&{4jnT)8e5xPMC8ViKr zQb}_YXO(m(DDtt+e;=?CML>TEST>15-4-NSUBLIS.TEST ;; ;; ;; Syntax: (NSUBLIS ALIST TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; NSUBLIS makes substitutions for objects in a tree (a structure of conses). The first argument to NSUBLIS is an ;; association list. The second argument is the tree in which substitutions are to be made, as for SUBST. ;; NSUBLIS looks at all subtrees and leaves of the tree; if a subtree or leaf appears as a key in the association ;; list (that is, the key and the subtree or leaf satisfy the test), it is replaced by the object it is associated ;; with. This operation is non-destructive. In effct, NSUBLIS can perform several SUBST operations simultaneously. ;; NNSUBLIS is like NSUBLIS but destructively modifieds the relevant parts of the tree. ;; ;; Argument(s): LIST - an association list ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test nsublis - test cases copied from page 274 of CLtL" (and (equal (nsublis '( (x . 100) (z . zprime) ) '(plus x (minus g z x p) 4 . x)) '(plus 100 (minus g zprime 100 p) 4 . 100) ) (equal (nsublis '(((+ x y) . (- x y)) ((- x y) . (+ x y))) '(* (/ (+ x y) (+ x p)) (- x y)) :test #'equal) '(* (/ (- x y) (+ x p)) (+ x y)) ))) (do-test "test nsublis 1" (and (prog2 (setq a '(>= (* x y) (+ x y) (- x y) (/ x y) )) (equal (nsublis '( (x . xx) (y . yy) ) a) '(>= (* xx yy) (+ xx yy) (- xx yy) (/ xx yy)) )) (prog2 (setq a '(1 2 (2 3 4) ((3) 4) 5 6 ( 6 4 2 1))) (equal (nsublis '( (2 . 3) (3 . 6) (6 . 1)) a) '(1 3 (3 6 4) ((6) 4) 5 1 (1 4 3 1)) )) (prog2 (setq a '( (#\a #\b) #\c ((#\d)) #\e)) (equal (nsublis '((nil . 7)) a) '( (#\a #\b . 7) #\c ((#\d . 7) . 7) #\e . 7))) (prog2 (setq a '()) (equal (nsublis '(( nil . "empty list")) a) "empty list")))) (do-test "test nsublis - with :TEST keyword" (and (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (equal (nsublis '((1 . 3.0) (3.0 . 5.0) (5.0 . 7.0) (7 . 9.0) (9 . 1.0)) a :test #'equalp) '(3.0 2.0 5.0 (4.0) (7.0 6.0 (9.0)) (8 ((1.0)) 10)))) (prog2 (setq a '( "I" "buy" ("coke") (("lime")) "plus" ("lemon" . "banana"))) (equal (nsublis '((#\i . "apricot") (#\e . "opium") (#\a . "coffee")) a :test #'(lambda (n m) (and (stringp n) (find m n)))) '("I" "buy" ("opium") (("apricot")) "plus" ("opium" . "coffee")))) (prog2 (setq a '( ((( park . place) (small . talk) (small . 80))) (park . play) ( (small . 72) ) (park . small))) (equal (nsublis '(((park . play) . (pool . swim)) ( (small . talk) . (public . speech))) a :test #'equal) '(((( park . place) (public . speech) (small . 80))) (pool . swim) ( (small . 72) ) (park . small)) )) (prog2 (setq a '(2 5 7 13 27)) (equal (nsublis '( (dummy . "star")) a :test #'(lambda (y x) (and (listp y) (evenp (first y))))) "star")))) (do-test "test nsublis - with :TEST-NOT keyword" (and (prog2 (setq a '(78 65 (45 ((66) 23) 121) 8 100)) (equal (nsublis '(( 30 . "<= 30") (50 . "<= 50") (80 . "<= 80")) a :test-not #'(lambda (y x) (or (listp y) (> y x)))) '("<= 80" "<= 80" ("<= 50" (("<= 80") "<= 30") 121) "<= 30" 100))) (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (equal (nsublis '(((4.0) . foo) ((9.0) . bar)) a :test-not #'(lambda (y x) (not (equalp x y)))) '(1 2.0 3 foo (5 6.0 (7.0)) (8 (bar) 10)))) (prog2 (setq a '((John 250) (Susan 78) (Henry 140) (Kelly 115) (Mark 350))) (equal (nsublis '( ((Edward 200) . (Tom 214))) a :test-not #'equal) '(Tom 214))))) (do-test "test nsublis - with :KEY keyword" (and (prog2 (setq a '( (a b c) (1 2 3) (#\q #\w #\e) ("a" "b" "c"))) (equal (nsublis '((b . bb) (#\w . #\p) ("b" . "bb")) a :test #'equal :key #'(lambda (k) (if (listp k) (second k) ))) '(bb (1 2 3) #\p "bb"))) (prog2 (setq a '( (1 2 3 4) (2 3) (8 9 0 12) (1))) (equal (nsublis '( ( (4) . four) ( (12) . twelve)) a :test #'equal :key #'(lambda (x) (if (listp x) (last x) '(3)))) '(four (2 3) twelve (1)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5caf36f50ecbb84f422a8216fa938be9e70da3bd GIT binary patch literal 2875 zcmbVOO>7%Q6rS1jPny{2CjHA#m27{ZrW=x`v`r9_H}<-AYVW4rb(0hcktR-U)v<$r znns8!RD}atLY;)N1A+rb4yg2iC`GLh*B-fXK;nYLg^C;EVBXucn>49ti!ATVoA>7Z zeDlrQtrG76v_E z&%lN~{lkO(!~G}wnrok1H>pq{giMqBIBX+CAUv^FOd((>x**(;ri%F(^zvtq`uM z?ghP5%WNNbMLI62dTIoM#Uhfb83dAQx<&|n7c=@kb9a>9$&&{^jB?}cU2W8Drz_mg zP2gl)XdwhA4{jTE#YJafgXUCSg9H9IsJb)Lf?YZ6g5uXTOBwv#h2{2Z-d38qb5Di& z!|It2)t?BdX5LpvIqHYmt&Z`X4aYe82)Un~-fcUrCr>|UB=1FwO%dz)HoF^z#5Ne= zbX?eCaV}fw=vE6u3osww1PUrY;uf-k z-^TpBA9&LmP?AY4DQPKVEM)}v7O?dNWOY)q*YyAc0&V4ClZz1MLiV*Hiz?vB6VZ|h z*+B74aI$l~ppdL9jyvW<^$DywEQEiN_ajqB~K0|xS^GyKLnQTmqc z#^Fo0r@}hsS?BAlBgi@qvySb!-1ujJ1U1a5$Vq@hI%(&nS~PKfw0l;AcHBkl&r*SFrc$MiLy1;j+cLaJXTIA=g>= z9A*P(=wl}#rsuQfmGQE}jrF>x_kK&wV9x10wWiel>Tqu>L?5vb8ltodL zByk~I&WOX1iFhf!xKJq0;D)Sa_8Pch|5bUvI6DPhZbr=Jofd^_R}Z1tVe2N@<#0C$ z_X&wzbJ%B@-MOi`3o}!=YiqlKz4kG~Nn0kJfX)K7$YW#iNf+y+6eKFqmg_%`fkzCq z*IM9P})*q}h|IJRjlLJ;tJ$T@Cy0EGuPtR(g3jCUX;8qM?lJDs9Z-EsJO=NuxT2mmqJ;KZrhBF` zH@Aq0lV6B*rn3{wVCU9zWs~eRb{_ZLvp%y{IjFHGlvHFxkv4TMIAA3y$93jI zGvNQ(lm<}PxBNESk1oEp%$-lTw*#pAiXFUSnSOb`n8lZPAqRJMgY<^A=J7ZCERzoe z0@fPmOl--1qyWvK&1g2jwONce`cAAG!#5a!jAHJy+CWreMs_smg$mmem+{6EqEdsg+gQ0Jphpz!U7}p3!ZI-i3AhR6nBA+5Rzp2&!1;=?< AO#lD@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST new file mode 100644 index 00000000..ba503349 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSUBST-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: AUG. 14,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-NSUBST-IF-NOT.TEST ;; ;; ;; Syntax: (NSUBST-IF-NOT NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; NSUBST is a destructive version of SUBST. The list structure of ;; TREE is altered by destructively replacing with NEW ;; each leaf of the TREE such that OLD and the leaf ;; satisfy the test. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test nsubst-if-not 1" (and (prog2 (setq a '(1 2 3 (3 2 1) ((2)) (3 (1)))) (equal (nsubst-if-not 88 #'(lambda (x) (or (not (numberp x)) (not (eq x 2)))) a) '(1 88 3 (3 88 1) ((88)) (3 (1)) ))) (prog2 (setq a '("one" ("two" . "three") ("four") "five" "six" . "seven")) (equal (nsubst-if-not 'gotchu #'(lambda (x) (or (not (stringp x)) (not (find #\r x)))) a) '("one" ("two" . gotchu) (gotchu) "five" "six" . "seven"))) (prog2 (setq a '(10 13 12 (17 18) ((30 5) 31 4) 40 -5)) (equal (nsubst-if-not "***" #'(lambda (x) (or (not (listp x) ) (some #'(lambda (x) (not (numberp x))) x) (/= (apply #'+ x) 35) )) a) '(10 13 12 "***" ("***" . "***") . "***"))) (prog2 (setq a '()) (equal (nsubst-if-not "April fool" #'consp a) "April fool")))) (do-test "test nsubst-if-not -- with :KEY keyword" (and (prog2 (setq a `("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (equal (nsubst-if-not #\y #'stringp a :key #'(lambda (x) (if (and (listp x) (= (list-length x) 3)) (first x) "dummy" ))) '("sleepy" #\y "grouchy" . #\y))) (prog2 (setq a '("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (equal (nsubst-if-not '(foo) #'(lambda (x) (find #\s x :test #'char-equal)) a :key #'(lambda (z) (typecase z (string z) (null "s") (symbol (string z)) (t "s")))) '("sleepy" (sneezy ((foo) bashful (foo)) (foo)) (foo) (foo) snow (foo)))) (prog2 (setq a '(a b c (10 3 5 2 5 8) d (3 4 5))) (eq (nsubst-if-not 'end-of-testing #'(lambda (x) (/= (apply #'- x) -13.0)) a :key #'cadddr) 'end-of-testing)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c3b814276c65dd9fa7788bc44d750c61269c55ec GIT binary patch literal 3952 zcmb_eU2NOd6~3f??N}L|CUu;o37fSmpoUo#r)cA#g=w0Wl~ANYQE-GlDH3A|Q6$fj zmX`s;UW%eX2dobbu!ms_2KSsx zO7dT3q^N&*?>+zDx#t|RMIxsZO;qaVrYlu@My$^^r)Qhunfi>_sL#$6ZSf4y#pe{m zR9~2ol@kY#C3>?fIK>&e(6mdUHETCYg$oD7#33@$k^_k)y+j#KGQi zIjecL+8UE~sn*s>tk5|$JalOI@Z$%2mw(}2=7c&Sq)2Yy(nE+q0>oW#gt(<Jm>vP|B zVkuq905CbJ5uX2#6lHrObQTaaT^O6Nt41BLU42Q+74V8ZCjf*Uw-ccausRCuIdya@CRmA=x(q0 zq!p^ynrjq0_BZi)?WnJ~fx@10NQN~e)G^5%2x+AjJ;JBDgxmn?$4Y(amCQbQdmgRgshKgsws`8fTAa}aXv(2 zd=RR%Kd#7@G9j6&l{2Br6jr9;Y(8tLX`WjzVHt7S7l;CblRFiSwHW9D8ZXOK2*hYC zum$RNYg{!=!<3AimC0H0Kp#l-#brG&F?u#mp@7%-K@<{7gIN7Lu#&$4OW|?DOv@G? z{|-jBccCeAR`tx$K4f17>7GtIAmuGOh|5`TnF9U~vibC=p-JsVL-r6Iz-1rZ2@AQ+ zgvnpM23k7-2%}N!-}Ur zL34+71ft>b6Z!xy9|E2osy-$e&_$_D!PN;d5eV6XV2#h72T=HH*NM#5 z&erO4H9Y>qb$-~i8%?p+m_6NSN|iIBD2a2GW?3AD*u=B;g}M4n2}QqjoqZOH?tf9< zFPlUJF$e*~ zT_@C-E|hG@SWwY&qf~Gg!@wxQf7M;&fzIWC2n+I11Behj$e)1bLt5x3v$kDB%5fO$ z-aWq#fCfie<@w4-6Rn9?M*^+Ne0d2n#9>SS|0KbSW5XoPgU#J*ZC)OMoSj`3%J*uO zyALw7MN7epMpN~qHQ`^y^9T~}WENAj7=U8|{)-;yfUKwtGs_x%e08?yFg@m}lt888 z=SfZ*W1z$GMxScui;kj`n!6Zs9p0)V+X)n^kaUhd2-~?b(%2T>r)UZpsPi=Bp&wzp zIBT(9Hb)PFt8&WYL<^3?1m$59$yz2{W`=O#x0+LIJ@zw2yIQqtO$_&#`*Q@h;OtdQRkl=V&A8K2mTJmcmiD0-)bPoiVX0o1|CqA& zden7} zI3Az0A1)jELczNQ0`>$qi3hej+1aI7OOU^z)Dj{Ld+COTnUKv4$SpC(f)j=5Git~t zlnYES!%WIL6)1*sr7H}c83o*hlev^7n`i+O9LuPtlFMe{C5Z-tV`eVx`Th$eBszlS za&xmj0hv{m0!JRqdp_CoU6!0bcZi+PFsx5Klqq{9E^64bQnpjP5h@5U~KQ{3k|K;JA$6Cb$W_r>AUyTec4nx10TuW z6-(;LoUHK_zJ?=yv(%)K-I<{9v&d7P6#t8700bd$S2yCSdJ=s3QCSkOhX;t%juSbz}%g~Gr zI50i$thWEX(lHEly#N1r4|JZXGpB%RUpJ-isNp~sw%IIhR{bD-^zaoq9 zB3R-XfgMVFk&JxycnYpQJW`F_zW2r_WSE&4TICQecO2qjjl(#bHPsmQ&?aws0KaP1 ua6z1otYCML>TEST>15-4-NSUBST-IF.TEST ;; ;; ;; Syntax: (NSUBST-IF NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; NSUBST is a destructive version of SUBST. The list structure of ;; TREE is altered by destructively replacing with NEW ;; each leaf of the TREE such that OLD and the leaf ;; satisfy the test. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test nsubst-if 1" (and (prog2 (setq a '(10 20 (10.0) (10 . 10.0) 100 30 (10) . 10) aa (copy-tree a)) (and (equal (nsubst-if 99.99 #'(lambda (x) (equalp x 10)) a) '(99.99 20 (99.99) (99.99 . 99.99) 100 30 (99.99) . 99.99)) (equal (nsubst-if 99.99 #'(lambda (x) (eql x 10)) aa) '(99.99 20 (10.0) (99.99 . 10.0) 100 30 (99.99) . 99.99)) ) ) (prog2 (setq a '( (apple . orange) (banana) ((papaya) (tomato) mongo) watermelon . cantolope) aa (copy-tree a) ) (and (equal (nsubst-if 'yummy #'null a) '( (apple . orange) (banana . yummy) ((papaya . yummy) (tomato . yummy) mongo . yummy) watermelon . cantolope) ) (equal (nsubst-if t #'atom aa) '(( t . t) (t . t) ((t . t) (t . t) t . t) t . t) ) ) ) (prog2 (setq a '("string1" ("sTring" "string2") ((((( "string")))) "STRING") "string3" ("string" "string4") ) aa (copy-tree a) ) (and (equal (nsubst-if "bow" #'(lambda (x) (and (stringp x) (string= x "string"))) a) '("string1" ("sTring" "string2") ((((( "bow")))) "STRING") "string3" ("bow" "string4")) ) (equal (nsubst-if "bow" #'(lambda (x) (and (stringp x) (string-equal x "string"))) aa) '("string1" ("bow" "string2") ((((( "bow")))) "bow") "string3" ("bow" "string4")) ) ) ) (prog2 (setq a '( (string . guitar) ((keyboard . organ) string . guitar) (string guitar (percussion . drum)) )) (equal (nsubst-if '(string . harp) #'(lambda (x) (equal x '(string . guitar))) a) '( (string . harp) ((keyboard . organ) string . harp) (string guitar (percussion . drum)) )) ) (prog2 (setq a '( (1 2 3) (a b c) ( (w) (q) (i)) )) (equal (nsubst-if "poco ret." #'(lambda (x) (= (list-length x) 3)) a) "poco ret.") ) ) ) (do-test "test nsubst-if - with :KEY keyword" (and ;;(prog2 (setq a '( ("1" 2) (11 12) ("111" 212) (1111 2121) (111111 . 32112)) ) ;; (equal (nsubst-if "k" #'(lambda (x) (and (numberp x) (<= x 11110))) a :key #'car) ;; '( ("1" . "k") "k" ("111" . "k") "k" (111111 . 32112)) ) ;;) (prog2 (setq a '( "To" ("all" ("those")) "who" ("strive" "for") (("excellent")))) (equal (nsubst-if (second '(last least)) #'(lambda (x) (and (stringp x) (find #\t x))) a :key #'identity) '("To" ("all" (least)) "who" (least "for") ((least))) ) ) (prog2 (setq a '( ("a" "c" (ace)) "spade" club ("c" "l" (u b) ("d" "i" (amod)) ((king) "queen") Jack)) ) (equal (nsubst-if "*" #'(lambda (x) (and (listp x) (= (list-length x) 1))) a :key #'(lambda (x) (if (listp x) (third x) t))) '( "*" "spade" club ("c" "l" (u b) "*" ((king) "queen") Jack)) ) ) (prog2 (setq a '(10 23 34 23 100 2000 9)) (eq (nsubst-if 'end-of-nsubst-if-test #'(lambda (x) (= (apply #'+ x) 2166)) a :key #'(lambda (x) (nthcdr 2 x))) 'end-of-nsubst-if-test) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8ad40d9c0cfb3dfbdd1727c3382ba999df35bf2f GIT binary patch literal 5028 zcmb^!ZERat_1^d5*!iqmN|PpO@{+De>%>Xiq^t`R{NlXCZtQ2z@40CvKy?$Rj_TS` z;;brYRknprVkTSaY`oinG$HtdKq?W^z7UnRUxV@oX$XWsAOsOeNJIOFRE2ZywPPm^ z3qqA_pL@^ux##0vuM_)aUr_O7ZY<2F5{pV^IlHi&Rpv5_%2H-|aVDY60bcpKFC5jL z^Q*qe{?B`AjWWv2Vj`YR%qr$`Vre#ht55L^Dxvr-#q-qp^L@(Mp^@RIMm(PW+Hutg z3SC8ssl;r$DB~%U85|iJ92q{}U%UNX>vihP5JG0i0|YgMIEhTGyE&)J)C|)-9tdh~ zT@7h2Yu(B@AQE@X(4toE@L46BS#YNk&n8kB%#9^N39(+yImTnU&kTfhD^FKwz4c12 zA)vb>5STil5y?@|g4(H-tMi<554&|EHfopzys3YI5cv&s<=y0a7wJ1`^7hXzN>j}( zhpFuvA@D(3od6Fv&jBL23)6|a;#WvOP_?###7c4{`5vH;ykI{JrLHWj_r6iTp*<7tz;Rx zwZxCB66NtZCmkv}=O`FMAgom$%BHp-6XJHxZBr?*r210rQ^!EZF7jja{1-*fYs#Dg zdzD5v17#ezZu*Y2V^sPdewFL~5{J%eA?DVSOxsUGDa) z`dCnlx<>ruqPc?mhcT_WDQ5Xk4K2NHRX~Wb)60PJg z!!A}Y*8xFN)t%XcQ$wz24RS5al}48qjfSJ{aLkOvOqbjU%=Io+pLTP+;bK%igbGGS znG+_~xxEvs4o;0#;hgHgvGWS(tR4?XL#m0}uYu^%Qk*{3(1c>fhg1l;#o$8jA$A-= zod5)ghm7gaXgKID&O;zef8k{5x2y$s-)Bt-US-V)5`s1+fLE||@E!d-=cFHTPWnTE zd|7~`0JB_x4hYUx&PhJzH1Zn(9td!kHQi>-20I>RE#P)1J3avRLEMWlmgQ!1a_^_p%d+>SpZ-PBMPBGDk{}@X)lUV`?x0 zMCsq4t_pLCo8JqTkGLDig2-R9P6Qu<{;FrRXqcOj?yy$G-sVn8ivoNFFCTts>0z$$ zG762wLeoMh23vVNTu^ZV%+v>TQ;QlJzphZ>2zvrSlK@B9DcI3pa%1!ZZiT)j!1uUc z^hE*UtP456Dt3p3Kn>?4j|A8P>ozqK32NLM@-90KBIGSVSBImjJ^}bFYfZ7XE37TZ zx&o}Tmvy%QxyB!hMgu-o2aYD#+o5A3aAwRo0UG3&t(<*1eLbDIna1r)R<0wPSjsBt zrRA#t+{(@QY*HD4q$$@Ew{B(@XOZniU^9`e>$cjZ%*EjeGONs|#rpwqw=s4(V&$t@ z2N*9zg$I@%Tn>mL{cIUa`~EDAR=#RgjS$jl z<>eM|n{RrsI^}Bcv{6K#_e%eN_|iX%M!*J`khqQ0y9{!QBvsX7KT3ZCXYm7tuIXcE zd1`Rwfoz>bhChO9$Gz*xmHD^*>;7*DCpWzK&O0zk@SfY1B>EZXnW~@)FEySm=^Pr3RbJRTm0fK4vhtQJ){intYs1F6v8K8?D6DYDx{=`u9FIeVx;^+bAZDph zvJ#doe5VU#E5TbAFF8qv;Udn&W@x$r4U4-xWzPcDF|KJrydlL|O;|a3E|Wnoh9PJy zPh1a{&}UF9Qb3qKgSs%$6vi2X%R7jWKrsx-&Uax zQdQdr2M?uC5j-!4x?lkQB?L8n!t@ua0y+iEq7QZv00l>6Nyb?4vW1Tg5OxPFYJiRY zix&r*!&tA0+4)zVbNXj1rziKaO z(dlLeCdv9y0SG+-#t#*aD(_Vb6>_RH(MzlSW_x+9grHG$P|imNeGW2DSG`_BR=sZu z)U92IfT1s1d8`mBbDrJjCG&$TX`r$VMXuun&s8tMJ(kW|xtjP~HnEt_WYQ>|t4d~4 zUO(7U7vkX8%Jb+xSGIzHlER+ilLCdv`&dZ$ z?h3+$!tqGi8LWAHhfRyK00h|Q4>Pzlch+!~qJsONfa`8R+0%TFtQc-53fKe+^7s{={OAfEZI>WC{YDPp;qv$QTI2Fa49m@iCP$pV%-1G~Q9+>dM yvlj0xc&N$T(;oiI>lj@+!?&&{D#?&n+4O6y_e3R)3k@(A-JKzF4^^Ju-u@3Fi_UKV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST b/internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST new file mode 100644 index 00000000..49f804c8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSUBST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 13,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-NSUBST.TEST ;; ;; ;; Syntax: (NSUBST NEW OLD TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; NSUBST is a destructive version of SUBST. The list structure of ;; TREE is altered by destructively replacing with NEW ;; each leaf of the TREE such that OLD and the leaf ;; satisfy the test. ;; ;; Argument(s): NEW - anything ;; OLD - anything ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (DO-TEST "TEST NSUBST - test cases copied from page 273 of CLtL" (and (equal (NSUBST 'TEMPEST 'HURRICANE '(SHAKESPEARE WROTE (THE HURRICANE))) '(SHAKESPEARE WROTE (THE TEMPEST))) (equal (NSUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) '(SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO)) (equal (NSUBST '(A . CONS) '(OLD . PAIR) '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) :TEST #'EQUAL) '((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS))) ) ) (do-test "test nsubst 1" (and (prog2 (setq aa '(allen (apple) apply ((apple) apple1) apple2)) (equal (nsubst 'orange 'apple aa) '(allen (orange) apply ((orange) apple1) apple2)) ) (prog2 (setq aa '(twinkle (nil t) (twinkle) () little (star) "!")) (equal (nsubst 999 nil aa) '(twinkle (999 t . 999) (twinkle . 999) 999 little (star . 999) "!" . 999)) ) (prog2 (setq aa '(#\A #\a '(#\G (#\o)) ((#\b) #\a) (#\N (#\a)) ((#\n) #\a))) (equal (nsubst 'apple #\a aa) '(#\A apple '(#\G (#\o)) ((#\b) apple) (#\N (apple)) ((#\n) apple))) ) ) ) (do-test "test nsubst - with :TEST keyword" (and (prog2 (setq aa '("silent" "night" ("holy" ("night")) (("last" . "night")) ("lonely") "night")) (equal (nsubst "afternoon" "night" aa :test #'equal) '("silent" "afternoon" ("holy" ("afternoon")) (("last" . "afternoon")) ("lonely") "afternoon")) ) (prog2 (setq aa '((1 3 5.0) ((1.0 3) (1.0 3.0 5.0)) 1 3 5)) (equal (nsubst '(11.1 22.2) '(1 3.0 5.0) aa :test #'(lambda (x y) (and (listp y) (= (list-length x) (list-length y)) (every #'(lambda (m n) (and (numberp n) (= m n))) x y)))) '((11.1 22.2) ((1.0 3) (11.1 22.2)) 11.1 22.2)) ) (prog2 (setq aa '(20 77 45 (60) 5 0.2 ((30)) (39) 10 8 35)) (equal (nsubst 44 30 aa :test #'(lambda (x y) (and (numberp y) (>= x y)) )) '(44 77 45 (60) 44 44 ((44)) (39) 44 44 35)) ) ) ) (do-test "test nsubst - with :TEST-NOT keyword" (and (prog2 (setq aa '((1 2) (2 3 4) (4 ((5))) (7 8 (9)) )) (equal (nsubst '(foo) 'dumy aa :test-not #' (lambda (x y) (and (listp y) (= (list-length y) 4)) )) '((foo) foo) ) ) (prog2 (setq aa '((a z) (y x) (m n) (b c))) (equal (nsubst "foo" '(a b) aa :test-not #'intersection) "foo") ) (prog2 (setq aa '(no (sense) ((no)) feelings)) (equal (nsubst 'foo 'dumy aa :test-not #'(lambda (x y) (not (atom y)))) '(foo (foo . foo) ((foo . foo) . foo) foo . foo)) ) ) ) (do-test "test nsubst - with :KEY keyword" (and (prog2 (setq aa '((end2 end1) ((end) end))) (equal (nsubst 'zero '(end) aa :test #'equal :key #'(lambda (x) (if (listp x) (last x)))) '((end2 end1) zero)) ) (prog2 (setq aa '(13.0 ((2) 13.0 40) (26 (13.0) 39) ((2 4) 13 28))) (equal (nsubst 33 13 aa :test #'equalp :key #'(lambda (x) (if (consp x) (second x)))) '(13.0 33 (26 (13.0) 39) 33)) ) (progn (setq aa '((a b) a (a c) b c (d a))) (setq bb '((a b) d (a c) b c (d a))) (and (equal (nsubst 'w 'a aa :key #'(lambda (x) (if (consp x) (first x)))) '(w . w)) (equal (nsubst 'w 'a bb :key #'(lambda (x) (if (consp x) (first x)))) '(w d w b c (d . w))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f17448038e9227acb84735c489e2b0251a642587 GIT binary patch literal 5759 zcmb^!YiwIr`JQ|INYkXa9VA)OwRat_x^sz}R&4`izHx49H-6O*k`&nH*v{GI@sSsf`(siordR3@j60A78}AC2pe z2Q+{G{!e=w6IGPVR4!f4W!2<#u9QvB-m7{$)o^-N^&UNPuN#`Xhhxj5+=%RQ1C!(hfs5|bqJ>qbLgD&kKDqY-nN&9Nr) zoY5SNcw!Kkc3hX_hKd%{&P-#g_mJnHCz0w21rri@v-PYbDZfBhF6Cc2!Csz_o_Y0z zJkZv@o!JqKpJoBBUfgM69+D*Z2j`nAq`CYnfY@=?xr60jek}s)cNhDgiCmGS#r#u| z6EXuGi!Zhfv|Abwg7E8w%uYIpigh+@S$85wriF+DEtU(<4zwWt>RkR}b~6TTGlpIH zHTo|Mv@GW53Uhh!cYA`8KW_!qP~*~?Q>=>aiF!`lTc=&cm#XKhy_YJ^z4e^yYrLI- zE1$Fi-*RKdFRlq^eJ3yOtJk+t*ci_3xkcqSRxr)$8wVGV(CDzrrR&D{uHVs(xVn^o zv31=tTFko&E=g`S&l@}4{%E8(h)uy0&?3DdJ?`lV0w!`i;g+}XX1M`APWag2V}tIq z-R;+s{(vX0CsT3g9)4;+j>J$RsfT5@mLnN;^Co305SX^wsj$Z=O}trYgf6trt;gfh zxF?!Q#!^YQvJH5f+*)MFL->T7Lp$1jsJ^RhwMi1UVK3W_t?4z;??kYJw*Zj;$6FD+MKt+M zqRG#T-HZUb;PetFd!LZ(Z2^8w0_^)@Hz&a30vRGXc0|a@M3eq3z!d>r;B7O!CBs|0 zdD~%r=WgD1H~RKGL|~`$!rimb?i~?4j1X?0<{bzo0IT%tL%7Zp|H+hK$N|NMmx81| zz7v6u--X~9-vvPa7jH-KchV%kBfu46kuT$Lp`jFsq6XRIcqQ_r0G|+|yM@dh1lW6| zmR%(c>@BhTjsTD1<>=^J4Aih0f!$AP*vEx@JMS3c?I(GM&N~kByS#kYN#Ip3nTB(E zVsxT7GlAQeOk;OBS1PNe>EW?LN%g2Rg>qi)hC@(CbF(wWsVuTx1hyoy?Kz|EQAg4+ z_OohXLd4*?)r_Bq}P9F}Bp9U5KU-l`BFhy2;IN-4jxFpl)7)y^2XVd7ynzV;m&M56cpJ}i` zb_bl6EuW z1lQZ@U0?Re%$2`MxBDSda`Z45LI0pVfJJ^EtQTg$B%lm7Y#Ht(rxm`P2awZm`3AxZ zr-46*S`3y(8Te$-*>>|eJcK16X6*D zqU8{O0R7-;+@pD(L909mdtvQ|=CXs$`+y9(VKE1<$YsSo@4Ji(K)geU1~Sj)H5WVp zL0EpFN^Z$e`l3;~uJr|hp+|#qA<5?;zqa}`d;-#p`rt|c$K*;SV6qItXNW0W1w6X3 zga<+;K(6!0DjW2ZpFxhNs~o+V0MEivMl?7J51LqJJ*~41*hl0?@r(`oXO5{yI#(fP zCZY~O5+nC2fv{bjvjWl8Nh(Tk1RwErxv(i%J;LSF-n)VNsy>V%JP5a*L7HyZ{^IOlQ|&0gQlSjPs7lKin3*jqc8*D?r<|! z7|#Ki9GfnI9VoA{+<0-qa15s>;19k1(OMPu;$&fZ+|uDpPfisw#d3`r;xHVU;>bvj z+T?d3X}96zKCk(pX>FdTkR{c58i6pv@WUGhcptpFaSAyT$vC{eW1@5!j4-@`g@Uo_ z5$tkC#amdXs~uWd8`sSq%`G-X_9U2|_xU7=CdRz)+m#_PM?->!#p>k177T$|ljA<% z!T!%qWB*){VYGlASXA_(D%=1RLuW;H(zpTamU)y$Vd!$VGOk#1O>biX>TRsoG#aaW zn-|UasF5+~^Ub;O$?~iU@5(X|r2k;6fraT4!>xK0Uu$aQ|LFGRc^7Hx$ebx7ey9a8vFK|WENg(ZG>(KHTKXP-yR z*-W~WE2$aiMerMCWU4r>PNpBqsRs@pREs03KU5Bl@_X<)$QyX=i^YT1VqI4%PUEe` zaC!)tno!`avysXgK8vjyIb$JfjPIpXgoIqj8aZFXP3bQxWy2U6L6f0#e-oO>seAUW6O4cAg!OG?;-2Lze3xuqUb63je=P$Zf(XUHm%hO Wl(lllAmZ0p?afNxK=}*TuKgc74xO?9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST b/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST new file mode 100644 index 00000000..7822dba4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBLIS ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 15, 1986 ;; ;; Last Update: Aug. 15, 1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-SUBLIS.TEST ;; ;; ;; Syntax: (SUBLIS ALIST TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SUBLIS makes substitutions for objects in a tree (a structure of conses). The first argument to SUBLIS is an ;; association list. The second argument is the tree in which substitutions are to be made, as for SUBST. ;; SUBLIS looks at all subtrees and leaves of the tree; if a subtree or leaf appears as a key in the association ;; list (that is, the key and the subtree or leaf satisfy the test), it is replaced by the object it is associated ;; with. This operation is non-destructive. In effct, SUBLIS can perform several SUBST operations simultaneously. ;; NSUBLIS is like SUBLIS but destructively modifieds the relevant parts of the tree. ;; ;; Argument(s): LIST - an association list ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test sublis - test cases copied from page 274 of CLtL" (and (equal (sublis '( (x . 100) (z . zprime) ) '(plus x (minus g z x p) 4 . x)) '(plus 100 (minus g zprime 100 p) 4 . 100) ) (equal (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y))) '(* (/ (+ x y) (+ x p)) (- x y)) :test #'equal) '(* (/ (- x y) (+ x p)) (+ x y)) ) ) ) (do-test "test sublis 1" (and (prog2 (setq a '(>= (* x y) (+ x y) (- x y) (/ x y) )) (and (equal (sublis '( (x . xx) (y . yy) ) a) '(>= (* xx yy) (+ xx yy) (- xx yy) (/ xx yy)) ) (equal a '(>= (* x y) (+ x y) (- x y) (/ x y) )) ) ) (prog2 (setq a '(1 2 (2 3 4) ((3) 4) 5 6 ( 6 4 2 1))) (and (equal (sublis '( (2 . 3) (3 . 6) (6 . 1)) a) '(1 3 (3 6 4) ((6) 4) 5 1 (1 4 3 1)) ) (equal a '(1 2 (2 3 4) ((3) 4) 5 6 ( 6 4 2 1))) ) ) (prog2 (setq a '( (#\a #\b) #\c ((#\d)) #\e)) (and (equal (sublis '((nil . 7)) a) '( (#\a #\b . 7) #\c ((#\d . 7) . 7) #\e . 7)) (equal a '( (#\a #\b) #\c ((#\d)) #\e)) ) ) (prog2 (setq a '()) (and (equal (sublis '(( nil . "empty list")) a) "empty list") (eq a ()) ) ) ) ) (do-test "test sublis - with :TEST keyword" (and (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (and (equal (sublis '((1 . 3.0) (3.0 . 5.0) (5.0 . 7.0) (7 . 9.0) (9 . 1.0)) a :test #'equalp) '(3.0 2.0 5.0 (4.0) (7.0 6.0 (9.0)) (8 ((1.0)) 10))) (equal a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) )) (prog2 (setq a '( "I" "buy" ("coke") (("lime")) "plus" ("lemon" . "banana"))) (and (equal (sublis '((#\i . "apricot") (#\e . "opium") (#\a . "coffee")) a :test #'(lambda (n m) (and (stringp n) (find m n)))) '("I" "buy" ("opium") (("apricot")) "plus" ("opium" . "coffee"))) (equal a '("I" "buy" ("coke") (("lime")) "plus" ("lemon" . "banana"))))) (prog2 (setq a '((((park . place) (small . talk) (small . 80))) (park . play) ((small . 72)) (park . small))) (and (equal (sublis '(((park . play) . (pool . swim)) ((small . talk) . (public . speech))) a :test #'equal) '((((park . place) (public . speech) (small . 80))) (pool . swim) ((small . 72)) (park . small))) (equal a '((((park . place) (small . talk) (small . 80))) (park . play) ((small . 72)) (park . small))))) (prog2 (setq a '(2 5 7 13 27)) (and (equal (sublis '((dummy . "star")) a :test #'(lambda (y x) (and (listp y) (evenp (first y))))) "star") (equal a '(2 5 7 13 27)))))) (do-test "test sublis - with :TEST-NOT keyword" (and (prog2 (setq a '(78 65 (45 ((66) 23) 121) 8 100)) (and (equal (sublis '((30 . "<= 30") (50 . "<= 50") (80 . "<= 80")) a :test-not #'(lambda (y x) (or (not (numberp y)) (> y x)))) '("<= 80" "<= 80" ("<= 50" (("<= 80") "<= 30") 121) "<= 30" 100)) (equal a '(78 65 (45 ((66) 23) 121) 8 100)))) (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (and (equal (sublis '(((4.0) . foo) ((9.0) . bar)) a :test-not #'(lambda (x y) (not (equalp x y)))) '(1 2.0 3 foo (5 6.0 (7.0)) (8 (bar) 10))) (equal a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))))) (prog2 (setq a '((John 250) (Susan 78) (Henry 140) (Kelly 115) (Mark 350))) (and (equal (sublis '(((Edward 200) . (Tom 214))) a :test-not #'equal) '(Tom 214)) (equal a '((John 250) (Susan 78) (Henry 140) (Kelly 115) (Mark 350))))))) (do-test "test sublis - with :KEY keyword" (and (prog2 (setq a '( (a b c) (1 2 3) (#\q #\w #\e) ("a" "b" "c"))) (and (equal (sublis '((b . bb) (#\w . #\p) ("b" . "bb")) a :test #'equal :key #'(lambda (k) (if (listp k) (second k) ))) '(bb (1 2 3) #\p "bb")) ) ) (prog2 (setq a '( (1 2 3 4) (2 3) (8 9 0 12) (1))) (and (equal (sublis '( ( (4) . four) ( (12) . twelve)) a :test #'equal :key #'(lambda (x) (if (listp x) (last x) '(3)))) '(four (2 3) twelve (1))) (equal a '( (1 2 3 4) (2 3) (8 9 0 12) (1) ) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4d136c38b5a37e3661061850933b790966442d4b GIT binary patch literal 3159 zcmbVO|8G-O6uRS zF_1~n#N;_GLwHxBiHSe>gC>N;M1;5)WBfr9fAB~D0)NBbOf;$Iyw|RPBz=^@5 zzIOGYm8oKSvYejgwMx1)Jy|`#`wsH4$tv#~9vV8pA38j8WO&5q8*C4WYSi-8+>uI8 z=bL+c5A8WPa@YsE2HWeO8rK=FKnR&4%P2Mw!Vw!WuIijulT=LzMWT`*i!sS-)C|21 zkO)atN*H?AA--Ig6LRVE=^TQYEfIzg<0HK-l#~NnM3IdpW`S`VAL^cnEW`nrcw8cE zTf+-_XTXi`CEcOd zaU7($4nlBn|3=EhaepCm`)tGHthMx58?j-70{>e^w|8fzII|eAAL`Lsxt`)`nT6~^ z#`?Pp>zgjSI+@I!?`0T2sGayg{*jPc<~@0gWjrvt)t%bXjDXTj$Z~dStLeRgjQOdF z%!L-KLN_3^JJzB+{g62hQ`{4b2OGu>6Vn#P01sWm=s~M~i0 z-WmqC*$JU`V{+)+0!p9O38!$ii(DVW@-PQ*r) zsL;F@I6q9gQMgS(>a+(m@*CZXVwrA3@xHZoh4vI^_ZaQoL%TQPo*KAxm@rU#A8wpe z#vG%lUZmSmya}mxN^($8LIM^B3Qjp(cmp8?#9%O(K=m~2ww;hBaIDcCD15XJh20e7 zAFy|+S^^xzVVZnHdr^FCh9RF@;vLKg3ZuqFi0eGAz-cBaw;TO@W$3O-{#?E=pGWme zL*G|Um&$ypa;8)kvNJ-yQ094F5cv6QIm3@YGW@x8b-qxXM*A-eylCF#_JnJuWcpn^!Q>aI~y4Tq9ZQ*kE5(b0%z zjvZskSRCzj*V$sBGL@-bIWsrxgUA>qqF!Y=#R&n40;Mg@O*R zE@-p9CY`ZQ+=0ab}ff(p$wDlvNjIkTVX zgXqyHKo?*sqG1hLP*-e`ns{?!U`<0U7O6i&h|O_?fWj*>-E2rP#v%; zb4dTBNVa&@zFFVk({a+O|x_tlu literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST new file mode 100644 index 00000000..ec080eb9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBST-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 273 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 14,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-SUBST-IF-NOT.TEST ;; ;; ;; Syntax: (SUBST-IF-NOT NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; (SUBST NEW OLD TREE) makes a copy of TREE, ;; substituting NEW for every subtree or leaf of TREE ;; (whether the subtree or leaf is a CAR or a CDR of its parent) ;; such that OLD and the subtree or leaf satisfy the test. It ;; returns the modified copy of TREE. The original TREE is ;; unchanged, but the result tree may share with parts of the argument ;; TREE. ;; Compatibility note: In Maclisp, SUBST is guaranteed NOT to share with ;; the TREE argument, and the idiom (SUBST NIL NIL X) was ;; used to copy a tree X. In Common Lisp, the function function COPY-TREE should ;; be used to copy a tree, as the SUBST idiom will not work. ;; For example: ;; ;; (SUBST 'TEMPEST 'HURRICANE ;; ;; '(SHAKESPEARE WROTE (THE HURRICANE))) ;; => (SHAKESPEARE WROTE (THE TEMPEST)) ;; (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) ;; => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) ;; (SUBST '(A . CONS) '(OLD . PAIR) ;; '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) ;; :TEST #'EQUAL) ;; => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) ;; ;; This function is not destructive; that is, it does not change ;; the CAR or CDR of any already existing list structure. ;; One possible definition of SUBST: ;; ;; (DEFUN SUBST (OLD NEW TREE X TEST TEST-NOT KEY) ;; (COND ((SATISFIES-THE-TEST OLD TREE :TEST TEST ;; ;; :TEST-NOT TEST-NOT :KEY KEY) ;; NEW) ;; ((ATOM TREE) TREE) ;; (T (LET ((A (APPLY #'SUBST OLD NEW (CAR TREE) X)) ;; (D (APPLY #'SUBST OLD NEW (CDR TREE) X))) ;; (IF (AND (EQL A (CAR TREE)) ;; (EQL D (CDR TREE))) ;; TREE ;; (CONS A D)))))) ;; ;; See also function SUBSTITUTE, which substitutes for top-level elements ;; of a sequence. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test subst-if-not 1" (and (prog2 (setq a '(1 2 3 (3 2 1) ((2)) (3 (1)))) (and (equal (subst-if-not 88 #'(lambda (x) (or (not (numberp x)) (not (eq x 2)))) a) '(1 88 3 (3 88 1) ((88)) (3 (1)) )) (equal a '(1 2 3 (3 2 1) ((2)) (3 (1)))) ) ) (prog2 (setq a '("one" ("two" . "three") ("four") "five" "six" . "seven")) (and (equal (subst-if-not 'gotchu #'(lambda (x) (or (not (stringp x)) (not (find #\r x)))) a) '("one" ("two" . gotchu) (gotchu) "five" "six" . "seven")) (equal a '("one" ("two" . "three") ("four") "five" "six" . "seven")) ) ) (prog2 (setq a '(10 13 12 (17 18) ((30 5) 31 4) 40 -5)) (and (equal (subst-if-not "***" #'(lambda (x) (or (not (listp x) ) (some #'(lambda (x) (not (numberp x))) x) (/= (apply #'+ x) 35) )) a) '(10 13 12 "***" ("***" . "***") . "***")) ) ) (prog2 (setq a '()) (and (equal (subst-if-not "April fool" #'consp a) "April fool") (equal a ()) ) ) ) ) (do-test "test subst-if-not -- with :KEY keyword" (and (prog2 (setq a `("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (and (equal (subst-if-not #\y #'stringp a :key #'(lambda (x) (if (and (listp x) (= (list-length x) 3)) (first x) "dummy" ))) '("sleepy" #\y "grouchy" . #\y)) (equal a `("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) ) ) (prog2 (setq a '("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (and (equal (subst-if-not '(foo) #'(lambda (x) (find #\s x :test #'char-equal)) a :key #'(lambda (z) (typecase z (string z) (null "s") (symbol (string z)) (t "s")))) '( "sleepy" (sneezy ( (foo) bashful (foo) ) (foo)) (foo) (foo) snow (foo)) ) (equal a '("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) ) ) (prog2 (setq a '(a b c (10 3 5 2 5 8) d (3 4 5))) (and (eq (subst-if-not 'end-of-testing #'(lambda (x) (/= (apply #'- x) -13.0)) a :key #'cadddr) 'end-of-testing) (equal a '(a b c (10 3 5 2 5 8) d (3 4 5))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d1a167122378715fe85b0464c766ae9667766870 GIT binary patch literal 4531 zcmb_fZ)_V$6`x)IO&a%{UUf;^Yr6y;;@objllF9%T-Q?xh^eKm!w*Cd1>B}7C

GlomwG(>9`a>DW&q4r1*2sK6_jm9UDLO+;}{G zqJLV+=$xx{BIgt;tuyhCGbhK#M#tkPPxNno)4L)>tAvnwavO&}LZZY+yfrr(v$c#Z zPbYOvHk6bW^BSHT22bQ{MzcJ3a8#;S7v-{Z(J7-d7ivTx#CzKfPiGC)PMU_dF02Xz z-k04-(vZ{On3B+l7;ds4yWqL~@ze4tIg_0PUCC(z_JrRgL_Ceg{IvM)8R2F{aDH}1 z%lzh-Ydv)ac7d?c--_UH$ zn3B!uc5%xXEs7MvpWu*hR-425Z|RdbT%(6^SVf1DQ<`BXZMOXym)C(XpleEtAx;k> z{AsT4Fg^4t9P}%;nff?RjI6G|j7R3Osni^eo&vD=l;?()E9WcKl?pCD;JG7pr&gD0 z%jar!xwIfjvb0jF7o~A9O*-#fTB$A-5P8^hkJ^YFd0iQi7V^-q3sR}Vn=Q&-e+rHH zhqoSz42=xonb7b0Q1oZ-3JFYzVw8C9p>qDhxk4Tf_V!M|vLt{!@Lb^~s3(Hwe-G!e z9-$Z~ps*|9i<=Ki1sxaeOG&5oIX^uh2(S{4arR&L8hqPZhg|f54SD#RM|0L(pQ36s z>bZg1V!q&jz_04rNsz1u8ORmN-ns~KAqzqn*dCG;;IG6<{7TB4!ZTuXJqs1dSYKUs zoC>m@fk%QT$dAzsSBSNA((!Ix^ac7N+h=T40~}+aNsQX}A!-LE8pYMpPi7i3pPleE zN~^^UxCQ~c#Qkpq9l_K8>*6K^8 ziztDY9U+M7b3Qrml*>+~js|{VCn|chO~R(_)AT5wS%DZ1V#qvv1Tdj@j~oEI?nB&z z^*s#@U4%&}V_T3$X(9x_RA&`)VJEvD&BdGtw}5GVM71=<*5qw{SWnuTrRW(tfG{Ys zvsu&Dcw?HSA4HE6p8HsLkBOsLrL1A}W2LS81Q9>!Afz1s2kxkl)1-@*stu;3cy>`-6ENBhTu1zbU7&OYrZgs*TK1g{B zg3`f(mlH{AmYU6E;Jrr*|CE(Yu?Ug(x&9WJe@3y=EzL~$^InZDP)i@fy$4>f$uGP3 z{|EsOPhcwF*{%Ko)0M@r6kDXXxDFQlKeUCQiQ9{A-|6(EWfBIE&3oKvA|AwtU$Als zVZB#giLsCLs*j0ArD zV0|z+sTlBs%Vv)Zrj@iZ$0XP&gYXp)z6JsSSW>2u;L}JB8n~6xblxTURK>7O-An`V zr@7WQ-T>A3;ct$xz<(vajWs14>$HbgpCHo_eug1Ff-4qNAx=k_XskJ&UUNIu+V|q+ zy;P97hn%(9SAi4F7-OH?_!8bmIICML>TEST>15-4-SUBST-IF.TEST ;; ;; ;; Syntax: (SUBST-IF NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; (SUBST NEW OLD TREE) makes a copy of TREE, ;; substituting NEW for every subtree or leaf of TREE ;; (whether the subtree or leaf is a CAR or a CDR of its parent) ;; such that OLD and the subtree or leaf satisfy the test. It ;; returns the modified copy of TREE. The original TREE is ;; unchanged, but the result tree may share with parts of the argument ;; TREE. ;; Compatibility note: In Maclisp, SUBST is guaranteed NOT to share with ;; the TREE argument, and the idiom (SUBST NIL NIL X) was ;; used to copy a tree X. In Common Lisp, the function function COPY-TREE should ;; be used to copy a tree, as the SUBST idiom will not work. ;; For example: ;; ;; (SUBST 'TEMPEST 'HURRICANE ;; ;; '(SHAKESPEARE WROTE (THE HURRICANE))) ;; => (SHAKESPEARE WROTE (THE TEMPEST)) ;; (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) ;; => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) ;; (SUBST '(A . CONS) '(OLD . PAIR) ;; '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) ;; :TEST #'EQUAL) ;; => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) ;; ;; This function is not destructive; that is, it does not change ;; the CAR or CDR of any already existing list structure. ;; One possible definition of SUBST: ;; ;; (DEFUN SUBST (OLD NEW TREE X TEST TEST-NOT KEY) ;; (COND ((SATISFIES-THE-TEST OLD TREE :TEST TEST ;; ;; :TEST-NOT TEST-NOT :KEY KEY) ;; NEW) ;; ((ATOM TREE) TREE) ;; (T (LET ((A (APPLY #'SUBST OLD NEW (CAR TREE) X)) ;; (D (APPLY #'SUBST OLD NEW (CDR TREE) X))) ;; (IF (AND (EQL A (CAR TREE)) ;; (EQL D (CDR TREE))) ;; TREE ;; (CONS A D)))))) ;; ;; See also function SUBSTITUTE, which substitutes for top-level elements ;; of a sequence. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test subst-if 1" (and (prog2 (setq a '(10 20 (10.0) (10 . 10.0) 100 30 (10) . 10)) (and (equal (subst-if 99.99 #'(lambda (x) (equalp x 10)) a) '(99.99 20 (99.99) (99.99 . 99.99) 100 30 (99.99) . 99.99)) (equal (subst-if 99.99 #'(lambda (x) (eql x 10)) a) '(99.99 20 (10.0) (99.99 . 10.0) 100 30 (99.99) . 99.99)) (equal a '(10 20 (10.0) (10 . 10.0) 100 30 (10) . 10)) ) ) (prog2 (setq a '( (apple . orange) (banana) ((papaya) (tomato) mongo) watermelon . cantolope) ) (and (equal (subst-if 'yummy #'null a) '( (apple . orange) (banana . yummy) ((papaya . yummy) (tomato . yummy) mongo . yummy) watermelon . cantolope) ) (equal (subst-if t #'atom a) '(( t . t) (t . t) ((t . t) (t . t) t . t) t . t) ) (equal a '( (apple . orange) (banana) ((papaya) (tomato) mongo) watermelon . cantolope) ) ) ) (prog2 (setq a '("string1" ("sTring" "string2") ((((( "string")))) "STRING") "string3" ("string" "string4") )) (and (equal (subst-if "bow" #'(lambda (x) (and (stringp x) (string= x "string"))) a) '("string1" ("sTring" "string2") ((((( "bow")))) "STRING") "string3" ("bow" "string4")) ) (equal (subst-if "bow" #'(lambda (x) (and (stringp x) (string-equal x "string"))) a) '("string1" ("bow" "string2") ((((( "bow")))) "bow") "string3" ("bow" "string4")) ) (equal a '("string1" ("sTring" "string2") ((((( "string")))) "STRING") "string3" ("string" "string4"))) ) ) (prog2 (setq a '( (string . guitar) ((keyboard . organ) string . guitar) (string guitar (percussion . drum)) )) (and (equal (subst-if '(string . harp) #'(lambda (x) (equal x '(string . guitar))) a) '( (string . harp) ((keyboard . organ) string . harp) (string guitar (percussion . drum)) )) (equal a '( (string . guitar) ((keyboard . organ) string . guitar) (string guitar (percussion . drum)) )) ) ) (prog2 (setq a '( (1 2 3) (a b c) ( (w) (q) (i)) )) (and (equal (subst-if "poco ret." #'(lambda (x) (= (list-length x) 3)) a) "poco ret.") (equal a '( (1 2 3) (a b c) ( (w) (q) (i)) )) ) ) ) ) (do-test "test subst-if - with :KEY keyword" (and ;;(prog2 (setq a '( ("1" 2) (11 12) ("111" 212) (1111 2121) (111111 . 32112)) ) ;; (and (equal (subst-if "k" #'(lambda (x) (and (numberp x) (<= x 11110))) a :key #'car) ;; '( ("1" . "k") "k" ("111" . "k") "k" (111111 . 32112)) ) ;; (equal a '( ("1" 2) (11 12) ("111" 212) (1111 2121) (111111 . 32112)) ) ;; ) ;;) (prog2 (setq a '( "To" ("all" ("those")) "who" ("strive" "for") (("excellent")))) (and (equal (subst-if (second '(last least)) #'(lambda (x) (and (stringp x) (find #\t x))) a :key #'identity) '("To" ("all" (least)) "who" (least "for") ((least))) ) (equal a '( "To" ("all" ("those")) "who" ("strive" "for") (("excellent")))) ) ) (prog2 (setq a '( ("a" "c" (ace)) "spade" club ("c" "l" (u b) ("d" "i" (amod)) ((king) "queen") Jack)) ) (and (equal (subst-if "*" #'(lambda (x) (and (listp x) (= (list-length x) 1))) a :key #'(lambda (x) (if (listp x) (third x) t))) '( "*" "spade" club ("c" "l" (u b) "*" ((king) "queen") Jack)) ) (equal a '( ("a" "c" (ace)) "spade" club ("c" "l" (u b) ("d" "i" (amod)) ((king) "queen") Jack)) ) ) ) (prog2 (setq a '(10 23 34 23 100 2000 9)) (and (eq (subst-if 'end-of-subst-if-test #'(lambda (x) (= (apply #'+ x) 2166)) a :key #'(lambda (x) (nthcdr 2 x))) 'end-of-subst-if-test) (equal a '(10 23 34 23 100 2000 9)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bb44393c09dd5475c8a91788cf9be7125bc34aac GIT binary patch literal 5748 zcmb^#ZERat^}hG)IG?RMsy0c}^rh<;uHDv23vFTG7xyK0<2+}6&vjD-nwvOvRM#$v z)6%hZUYAv3@-k9q?Yo_r_|Om%0=l4$c0(;65(rd&Aduh(5<~o`1VTa#_yJTb^ch0%TnI)d%;g}pQoH;w5%S_0Hsp8qGqC8fZkS7aM6C)XU4Dj;j z!|{arbVLac?D<%*QFl;ACNk+_W>hw&GLxg}3w}AcPaaHPkb{Q~9`wuIJ%{%nIvfn{ zY3x(<7}sS>q%xy||7`*2Usp2meQnO6mGfeiuh?hvjyi)f13{^J* zebJa2(3C;dXU>}CdN@fSsjCUIysld=7S0B8nRA&O9_Gv>5ePBASg!9&YGET9*UXAg z5}M7I$}LeXFa!rv`c)#1d$Pi}ty zsF-SPUnjUv5dt5iHSy){`~g5@YcO31*co$-+l79z_rVbXTYgB&9p?r>|V4YqgJQX7zR zx0IcaSS)$zUUo%>?NuGPTZ!l4xh@XauGd>;ap88Chs<$|;g#4Cw-{dsv(IAA`E#AA z4WRcvj1TWz(l+~C4Gu@a@`KFJf7-!|TgD7R&a`nH%WtvsKs`wF!#kMkkbSV0s`Vwl z+5z@hnO=4ItFM!nEU{cyuF-M6`^(Iquq4>hxtQCwgk4Yb`>Z6N-wq`Bq&kIDe*01}-2HGOl z!`A~}H+)^t($@LHiV=r$1>xMcg3d=c+xQ{kVO+XM8WwHNZ=aQOf zi_{3cZH-S&B;tucJZTIi4WG0In45iyHXLAh-A4s!Eh^~krC#Wo2bOltCI}^UVXxeR zy>C6}tm}&>1{DK9X#qsnSI-$%bd@Wn*eRu-0JobpPlUck+i>|TU&es8Rv#YhjmH9Z zOGffzoZL;@0TSP%8*%v)ZN=pcMiXD)%Vo~;DGqJtoa-2;@H>VSzRQ=(e7VE~gh9qB z9O9fVMkDX=)Vc7LB5;7S z>}75s3nKlr3ztVhzw3mWh%*!7J9HCZ#oscg#Jha?7T$mC-qhl#Q2Yi89Z3!jbD`G& zl=|Y9is!&gb5t|bgs!q16D3M?8!kFuG`bxj4>Kk#Fe}2leEBu=OZX;Vo}pWTQ+SF) zd%3_)&bf&#5g_F zH$;+&L^P~uz_Afv4;0K0#Eg3JlrBhY&s6?&zHmN|V6$27EM_K)^5oP>cn0M2`OQ64#IYPUa`0#ZT%x>XkUwues%MP=_mCZiyV7ZTH zPni|hv@!&vT1A3$iEO_MfOdcwu#-_l(bdT6t!N8$)iAM|$idOp@Q7AI;s*$+ZX0>O zUPT}P_<{0LwIkguFK`!RsevyHDh*)Bjx4^j5a*{EIz}Hw#6fVqEi{`gjo*ySMxN(~ zmh_Se_v}zyWTzqiUD!0L=+?<}2L)&Tv9i3^lN%%g3V7 z7nGPzn~@FL;^WDa$-ti)HrH?R**fKpPj9b(Wl+IbnBx9k1{f6>qlptpk4!tq7KAV+8nfrW{}FPdd( ztWd!1lS~Q48%I1>MHg)K%;Fp}0SCFtp4V)UGVnTrmgX@oCqO<*qJ$pebq*glAUyT3 zX+TS#0RrsppdEvtbtsGZhv6$_uPKm!IoHDKfrJ!X7D$$cO|dBaY>TN{zYziN(ehDd z7I)$I=W2lECcS`%e3GYJ7f-p((6k*XXSa6DIA^xCv1}9WnU$vXg8?xAarg8mVt0Q5 zJNQ6n5_Y!KV;Ks+2NpkP@%uR$mz{n;BmV}Xv|j1)VsOlm@}GCv0Jv&_!oinC2XGh- z;is!Rb=$1qyA!18(3i1MVyBt@WC^+kVA*Cm6e5IC1<8$C-{g^s3skgsr0+eiWW6yS5|$)W>SuFDnj8DO<==*SmpwKk;3 zikXRgp^#sq*-3C}uf{1(-(&LR@BgP^@@KQ+fh)jcq@vmYPPgDe=~*yrNdRA2 zz&VEe(VVO2yylz)2a!GNSA z&EBhANtO438o;su8eKz56kmMRhJ{g@&{6@kne=j)8Je^|Cb66wj(s}m$+_vRp$N|ZSsC4({CML>TEST>15-4-SUBST.TEST ;; ;; ;; Syntax: (SUBST NEW OLD TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; (SUBST NEW OLD TREE) makes a copy of TREE, ;; substituting NEW for every subtree or leaf of TREE ;; (whether the subtree or leaf is a CAR or a CDR of its parent) ;; such that OLD and the subtree or leaf satisfy the test. It ;; returns the modified copy of TREE. The original TREE is ;; unchanged, but the result tree may share with parts of the argument ;; TREE. ;; Compatibility note: In Maclisp, SUBST is guaranteed NOT to share with ;; the TREE argument, and the idiom (SUBST NIL NIL X) was ;; used to copy a tree X. In Common Lisp, the function function COPY-TREE should ;; be used to copy a tree, as the SUBST idiom will not work. ;; For example: ;; ;; (SUBST 'TEMPEST 'HURRICANE ;; ;; '(SHAKESPEARE WROTE (THE HURRICANE))) ;; => (SHAKESPEARE WROTE (THE TEMPEST)) ;; (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) ;; => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) ;; (SUBST '(A . CONS) '(OLD . PAIR) ;; '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) ;; :TEST #'EQUAL) ;; => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) ;; ;; This function is not destructive; that is, it does not change ;; the CAR or CDR of any already existing list structure. ;; One possible definition of SUBST: ;; ;; (DEFUN SUBST (OLD NEW TREE X TEST TEST-NOT KEY) ;; (COND ((SATISFIES-THE-TEST OLD TREE :TEST TEST ;; ;; :TEST-NOT TEST-NOT :KEY KEY) ;; NEW) ;; ((ATOM TREE) TREE) ;; (T (LET ((A (APPLY #'SUBST OLD NEW (CAR TREE) X)) ;; (D (APPLY #'SUBST OLD NEW (CDR TREE) X))) ;; (IF (AND (EQL A (CAR TREE)) ;; (EQL D (CDR TREE))) ;; TREE ;; (CONS A D)))))) ;; ;; See also function SUBSTITUTE, which substitutes for top-level elements ;; of a sequence. ;; ;; Argument(s): NEW - anything ;; OLD - anything ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (DO-TEST "TEST SUBST - test cases copied from page 273 of CLtL" (and (equal (SUBST 'TEMPEST 'HURRICANE '(SHAKESPEARE WROTE (THE HURRICANE))) '(SHAKESPEARE WROTE (THE TEMPEST))) (equal (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) '(SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO)) (equal (SUBST '(A . CONS) '(OLD . PAIR) '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) :TEST #'EQUAL) '((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS))))) (do-test "test subst 1" (and (prog2 (setq aa '(allen (apple) apply ((apple) apple1) apple2)) (and (equal (subst 'orange 'apple aa) '(allen (orange) apply ((orange) apple1) apple2)) (equal aa '(allen (apple) apply ((apple) apple1) apple2)))) (prog2 (setq aa '(twinkle (nil t) (twinkle) () little (star) "!")) (and (equal (subst 999 nil aa) '(twinkle (999 t . 999) (twinkle . 999) 999 little (star . 999) "!" . 999)) (equal aa '(twinkle (nil t) (twinkle) () little (star) "!")))) (prog2 (setq aa '(#\A #\a '(#\G (#\o)) ((#\b) #\a) (#\N (#\a)) ((#\n) #\a))) (and (equal (subst 'apple #\a aa) '(#\A apple '(#\G (#\o)) ((#\b) apple) (#\N (apple)) ((#\n) apple))) (equal aa '(#\A #\a '(#\G (#\o)) ((#\b) #\a) (#\N (#\a)) ((#\n) #\a))))))) (do-test "test subst - with :TEST keyword" (and (prog2 (setq aa '("silent" "night" ("holy" ("night")) (("last" . "night")) ("lonely") "night")) (and (equal (subst "afternoon" "night" aa :test #'equal) '("silent" "afternoon" ("holy" ("afternoon")) (("last" . "afternoon")) ("lonely") "afternoon")) (equal aa '("silent" "night" ("holy" ("night")) (("last" . "night")) ("lonely") "night")))) (prog2 (setq aa '((1 3 5.0) ((1.0 3) (1.0 3.0 5.0)) 1 3 5)) (and (equal (subst '(11.1 22.2) '(1 3.0 5.0) aa :test #'(lambda (x y) (and (listp y) (= (list-length x) (list-length y)) (every #'(lambda (m n) (and (numberp n) (= m n))) x y)))) '((11.1 22.2) ((1.0 3) (11.1 22.2)) 11.1 22.2)) (equal aa '((1 3 5.0) ((1.0 3) (1.0 3.0 5.0)) 1 3 5)))) (prog2 (setq aa '(20 77 45 (60) 5 0.2 ((30)) (39) 10 8 35)) (and (equal (subst 44 30 aa :test #'(lambda (x y) (and (numberp y) (>= x y)) )) '(44 77 45 (60) 44 44 ((44)) (39) 44 44 35)) (equal aa '(20 77 45 (60) 5 0.2 ((30)) (39) 10 8 35)))))) (do-test "test subst - with :TEST-NOT keyword" (and (prog2 (setq aa '((1 2) (2 3 4) (4 ((5))) (7 8 (9)) )) (and (equal (subst '(foo) 'dumy aa :test-not #'(lambda (x y) (and (listp y) (= (list-length y) 4)) )) '((foo) foo)) (equal aa '((1 2) (2 3 4) (4 ((5))) (7 8 (9)) )))) (prog2 (setq aa '((a z) (y x) (m n) (b c))) (and (equal (subst "foo" '(a b) aa :test-not #'intersection) "foo") (equal aa '((a z) (y x) (m n) (b c))))) (prog2 (setq aa '(no (sense) ((no)) feelings)) (and (equal (subst 'foo 'dumy aa :test-not #'(lambda (x y) (not (atom y)))) '(foo (foo . foo) ((foo . foo) . foo) foo . foo)) (equal aa '(no (sense) ((no)) feelings)))))) (do-test "test subst - with :KEY keyword" (and (prog2 (setq aa '((end2 end1) ((end) end))) (and (equal (subst 'zero '(end) aa :test #'equal :key #'(lambda (x) (if (listp x) (last x)))) '((end2 end1) zero)) (equal aa '((end2 end1) ((end) end))))) (prog2 (setq aa '(13.0 ((2) 13.0 40) (26 (13.0) 39) ((2 4) 13 28))) (and (equal (subst 33 13 aa :test #'equalp :key #'(lambda (x) (if (consp x) (second x)))) '(13.0 33 (26 (13.0) 39) 33)) (equal aa '(13.0 ((2) 13.0 40) (26 (13.0) 39) ((2 4) 13 28))))) (progn (setq aa '((a b) a (a c) b c (d a))) (setq bb '((a b) d (a c) b c (d a))) (and (equal (subst 'w 'a aa :key #'(lambda (x) (if (consp x) (first x)))) '(w . w)) (equal aa '((a b) a (a c) b c (d a))) (equal (subst 'w 'a bb :key #'(lambda (x) (if (consp x) (first x)))) '(w d w b c (d . w))) (equal bb '((a b) d (a c) b c (d a))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL b/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..041094fbeadc68d7d5182e9a7260a73145a5a6d0 GIT binary patch literal 1259 zcmb_bO-vI(6rSxCT1z3tP_f0xgoJ||m$0A#%fT$m77Fby-Q5O_2SdtYQD_lb4N(ap z(U`af3;yh2^x(n7#6&M1P@^%POuTvZ;K73z6A#{T-mEBM;>l$9z4yI&@7p)?%~nz1 zn3BdyX=Zk6+MdIuN_nP{Rwl8~g1P*OJ29@kdKm_1S4>XEkfbSApH6P-OB zq0M{lZ7xzm2<6dhaJvwSARf7^PDHR&(-M=Zv?^+HMitzu>jdde#GI)buG83s%cWUy z+CFDb!)9jY5r>d_!wDvHnqsAN&0XV`xUjq8)TcCYlx|EORFNM_mwYLaW3s_jiS* z3na`3NIf5Trq#fD@c!Y=_1g!&ozEGmt zq;6zn3*ZOJ(e!(6MK)EBjf7$OF;sgB16(IjaMwumB8kqB=m`={k!TNzwv#AZc}MGO z*fdc0hF+;!4Zf8I_>44zdqit^HOo>DX@wuI6D-^zd%@i#F>qHIRW|4KUM8^x5CML>TEST>15-5-ADJOIN.TEST ;; ;; ;; Syntax: (ADJOIN ITEM LIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; ADJOIN is used to add an element to a set, provided that ;; it is not already a member. The equality test defaults to EQL. ;; ;; (ADJOIN ITEM LIST) = (IF (MEMBER ITEM LIST) LIST (CONS ITEM LIST)) ;; ;; In general, the test may be any predicate; the ITEM is added to the ;; list only if there is no element of the list that ``satisfies the ;; test.'' ;; ;; ADJOIN deviates from the usual rules described in chapter ;; for the treatment of arguments named ITEM and :KEY. ;; If a :KEY function is specified, it is applied to ITEM ;; as well as to each element of the list. The rationale is that ;; if the ITEM is not yet in the list, it soon will be, and so ;; the test is more properly viewed as being between two elements ;; rather than between a separate ITEM and an element. ;; ;; (ADJOIN ITEM LIST :KEY FN) ;; = (IF (MEMBER (FN ITEM) LIST :KEY FN) LIST (CONS ITEM LIST)) ;; ;; See macro PUSHNEW. ;; ;; Argument(s): ITEM - anything ;; LIST - a list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (DO-TEST "ADJOIN TEST 1" (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((1 2) (3 4))) :TEST (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((3 4))) :TEST (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((1 2) (3 4))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((3 4))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((3 4) (1 2) (2 1) (3 4))) :TEST (QUOTE EQUAL)) (QUOTE ((3 4) (1 2) (2 1) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) NIL :TEST-NOT (QUOTE EQUAL)) (QUOTE ((1 2)))) (EQUAL (ADJOIN (QUOTE (1 2)) NIL :TEST (QUOTE EQUAL)) (QUOTE ((1 2)))) (EQUAL (ADJOIN (QUOTE (1 2)) NIL :TEST (QUOTE EQL)) (QUOTE ((1 2)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((1 2))) :TEST (QUOTE EQL)) (QUOTE ((1 2) (1 2))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..076afc56bd2edc9066ebd792f71b7827ab5e4fbe GIT binary patch literal 4761 zcmb^!ZA@F&_1^bv^JNntR+<2DUPwY)7o!;RRk~F?JC9(npTU02Vbi)e#>8xZEifh7 zlqic>q-q`+(4_D7Lz>!2o2G4IDC$a+CR?XynuN4z{V{Es)-{_pDN>|J)js;8V&~jz z69-tRP=x%>x##PibMCq49%e|%aeq+pr$;hF!^trvJ(0~!WR=16m@=N87)vCTL7*$& z@P{MX*-q8p-Ta)lJX*v_j3wjQOVX>B|3Y@65H zT;8EZgThupBbFQ(E$DcQboRHkwzhc>HkU8IVP2tCX+lVX+(b}DNEMNZIh(6;8(P%x zbOeH$M^{6d+nh0Tr4WgyFRDe%Ty=|*O=mpA$rqEu7|h5xp@f*<&6Rfa>3$;+*3CJ3 zp4!bzIY&VE^gv+hF^x#2c`In0f*J2Y&p}T>H?&Ap<7xzas=7dkMMsC;O>nMq~=1&Hkw+z zp#y$@ru#ekuLzk*UDUfI3I=B8x5xIPeBoy&5nftv7#0-dJVH6|2vOBcfQ?nh)bjOqofYA40W-Bq~+Y zQUS`sRpA=gSnLgcS5rrrAL`P=p>PcfEiF8QAne?^z_S!~7R#GqC;BHXqjCJJsi{Hm zc(Nv4DrBt!eRw!)D{ibH$`>l{^ag6{9MXbs zBb~gb+w-2Tz9ph2H!jB6)ch0c-r<>4)le0Y%FWBUdbdBU9}Qr8@^q^D(V!Ob_yR!D zk44>*ojIfm_&K2eNq+xI$HQJFl_AmRV|Hj^fT=2AB_M2tp9Lt@Zog{yJ3SH2=!-zZ z^Ye~ri}ptiEhN#k5=Pj~s^vBo#tqf<5b3%sg zMY@**>2GW|tfbpqQ~Ip{mvIxLGY~n7yjidycWeEK=YT^$kJw9W4}#}}eydP?k^_1l zq-4L!6L60;f*k!PkR+`a(Z6#|dWCD!X`ymKfD<5Q(|Y^VU=NCZS%~guZd`fzid+R5 zE0;OJb{}UALDtX>Y|Hazu4H2LYoqDOQCzl}xvkmccvcx2%_hgjlZot5dQ>@ptV3pQ zmw~K?b83S!7>Chl0K~*xgS2y4+w!O892UBnv!%!4qoBWaG8WrjwR@l0k| zupE;xLXC|ihtueQ{0WRb)}HnyoOM{anX4O)kDMHc<3?+46^u2M-zsjG9)}7bXyapZ zPJXa|u4u#Ds@?7i$&>L>_yd(pJQF{Ii0~JU{l&aO{MaYoX;)!#SWLmlk-FZAFaCR> znb1@KvDvP9S0@eNxN^Pgy6HD3Y0@$Klsc zpN2EDbU+Uzl$vwW^vHCa$M?I>9N%v?j_-X;-kj`^WQ_K0v65^hxcU*qUI*_#%pmO$ zn!r@RmPO-!bWD)5H8EMRiCWd3o?w3^bCt3eEX*ZU0F6FF*;mBzy^c?#8%ZOkpR zJ;K9r$V){#CStRBpfYpks}-(+P56EQ-T|ws8sQMLLj<&`D4G{Q3N95*O&eSo&k3pn zyF5fZ&Li$cB4z=@4?Hl-POrAszSbH$yJF`6gjd$CE^RhA2#nWhI^+*@W%-7&> zAs;S(L{kmTv+8*a2H@WkH5g^pC@)#v(L^NZS2WH8A(48gzhJq()?N*J>er7*`TsStk*TUo?#tx$!-g*>-XH#eP zKC!TNYI+2;I##4npDqh&?$Y8wUbI_{pk_;c8SRUzu;g#zAB*H~plPo8i&a*CUnIq? za;aNrkYm5*wyyu*w9t8;7W(6L)8a+Pf5_89W78*brBBBZ9D@y}eFA?T@wi|&6w&L7 z=w;~VEIbp;jsVhw=>+VHqH#c7;M_}L5Jmu#F#^8;N4X5S2R3+6f8yWUV1Xll28YN$ zzyM!;$iIK(-;enB4)Xs1%G7E>^aFgb+k5Iab2~sC8wJ6OXwF%wBwL`fTP;>vT88wu ziWl%K2npm|T>lKd&YE5{b8R@eDaFIF;!*filZcNel|(u-1f$E~Sb9Xs#7`xamcxgY z^q}GoW`kp_*_Tgl2eTKY;7(g1Uk|0kTS(i7t^)tx#ad4ks1Iq;^}Q#rLTHpMFaHmd CL0(}1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST new file mode 100644 index 00000000..a38e06aa --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: INTERSECTION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 277 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-INTERSECTION.TEST ;; ;; ;; Syntax: (INTERSECTION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; INTERSECTION takes two lists and returns a new list containing ;; everything that is an element of both argument lists. ;; If either list has duplicate entries, the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (INTERSECTION '(A B C) '(F A D)) => (A) ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the intersection operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' For every matching pair, ;; exactly one of the two elements of the pair will be put in the result. ;; No element from either list appears in the result that does not match ;; an element from the other list. ;; All this is very general, but probably ;; not particularly useful unless the test is an equivalence relation. ;; ;; NINTERSECTION is the destructive version of INTERSECTION. ;; It performs the same operation, but may destroy LIST1 ;; using its cells to construct the result. (The argument LIST2 ;; is NOT destroyed.) ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (DO-TEST "TEST INTERSECTION - test case copied from page 277 of CLtL" (prog2 (setq aa '(a b c) bb '(f a d) cc (intersection aa bb)) (and (equal cc '(a)) (equal aa '(a b c)) (equal bb '(f a d))))) (do-test "test intersection 1" (and (prog2 (setq aa '(1 2 3 4 5) bb '(4 5 1 8 9) cc (intersection aa bb)) (and (every #'equal (list aa bb) '((1 2 3 4 5) (4 5 1 8 9))) (= (list-length cc) 3) (every #'(lambda (x) (member x cc :test #'eq)) '(1 5 4)))) (prog2 (setq aa '(a b c d) bb '(x y (z)) cc (intersection bb aa)) (and (equal aa '(a b c d)) (equal bb '(x y (z))) (eq cc nil))) (let* ((aa '(#\a #\b)) (bb '(#\B #\a)) (cc (intersection aa bb :test #'equalp))) (and (equal aa '(#\a #\b)) (equal bb '(#\B #\a)) (member #\a cc) (member #\b cc :test #'equalp) (= (list-length cc ) 2))))) (do-test "test intersection 2" (progn (setq aa '((Kathy 100) (Karen 50) (Susan 80)) bb '((ken 85) (Henry 70) (kathy 96)) cc (intersection aa bb :test #'eq :key #'car )) (and (equal aa '((Kathy 100) (Karen 50) (Susan 80))) (equal bb '((ken 85) (Henry 70) (kathy 96))) (or (equal cc '((Kathy 100))) (equal cc '((Kathy 96))))))) (do-test "test intersection 3" (progn (setq aa '((10 20 120) (30 60 360.0) (40 50 450)) bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0)) cc (intersection aa bb :test #'= :key #'third)) (and (equal aa '((10 20 120) (30 60 360.0) (40 50 450))) (equal bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0))) (and (= (list-length cc ) 2) (every #'(lambda (x) (member x cc :test #'= :key #'third)) '(360 450)))))) (do-test "test intersection 4" (and (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (intersection aa bb :test-not #'(lambda (x y) (not (equal x y))) )) (and (equal aa '(1 "h" #\T (2 . 3) (list) "st")) (equal bb '((2 . 3) #\4 aatom 300 #\t "St")) (equal cc '((2 . 3))))) (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (intersection aa bb :test-not #'(lambda (x y) (not (equalp x y))) )) (and (every #'(lambda (x) (member x cc :test #'equalp)) '((2 . 3) #\t "St")) (= (list-length cc) 3))) (progn (setq aa '((1 3 5) (2 6 7) (10 20)) bb '((10 2 3) ( 20 5 1) ( 2 4 1)) cc (intersection aa bb :test-not #'(lambda ( x y) (/= (apply #'+ x) (apply #'+ y))))) (or (equal cc '((2 6 7))) (equal cc '((10 2 3))))) (progn (setq aa '("banana" "papaya" "tomamo") bb '("orange" "pineapple" "watermelon") cc (intersection aa bb :test #'(lambda (x y) (car (mapcar #'find '(#\m #\a ) (list x y)))))) (and (equal aa '("banana" "papaya" "tomamo")) (equal bb '("orange" "pineapple" "watermelon")) (some #'(lambda (x) (equal cc x)) '(("orange") ("tomamo") ("pineapple") ("watermelon"))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7e72823e9c2edfc945c834a055019dd2626d9bfe GIT binary patch literal 3820 zcmb_fduUr_6#u@PXS-&mTbt>e^*Y~~x2&ymIu&!5-Zbfwn|gCYR}`gf5);=ZqifXR zgLF=DaGhpxdcQgGfr6s=mK>G$ZdRm1iciat?6$?r_r3?v1M99lh7~ zwWpdSlQY@z*=$BO%h^4d@x52beVgUP_+Gj1nyatALhc{fcI7qO`ucj?BWfxxd^Ida zvzcPUrmx9n^R@x78t835^_2ZM^_K`CljJy(HbVTwLF_}8KWJ(xQ;Edlnxd--EofJ5 z%L|z(>6B*JR%gFFTiUHmW$(yNVKUQu2qnaR)bd8sdf1F5b-P9@w8MVH^2Kyz1QJt+ zG$MKHUeG(Wtu=jHlr2g^OKjH+B^FWiq)8ws?><7Lw=kmj^6wARcZ)Ri!LT&CW_>4h z-NwU2nU4@8C!TwQoM?%@)e=4065YQXJvQ9}8*PE9EwD{3uwI5)2sd z${oA;bi(UTC+s+4!pznb?K{P=<&wl)OANqsPeQ=mjueJ~C$_x2bd`cNt;d6-Xf!N&<>))@?|W;m)C znwd6WOu~H5+^MmYsU;-3T*FKTS%;&I`5ZnNt<^!zFp`FnOq(NVGw4_a1|30FA5%D< z3No0n&Vi+)+U6jHIdMQY;h?<;p4^e7kx)%!Yv817A%U=((u6zKf#Mu!w=bGlL=&tV z$uJ1dN{uD9C*w+E5g^_##OH8A|6pqYq(8DQB*z5!8VexzoFIn5fLce9}fTLe>EBdh@uhb1xG@vgD&8GqM=xN-aBM3hNyf-$e>1NEtW2hzc z_5tox&13?x8DOB{X~T>nTM{Z+RMFFM449^YafHQDhLA_ORXnMh{G<*Mqmu_m{uJbE zwgIfkaZq)|V=1mlUPcaHs1(|fCs+@X`vLTbH)W*6Z=!7Ded8ilu`~J+v<-w1+^yZ$4NVEj}WejRd_Sn*11#T z(-WC-^to)RK#TIJg2A#ax|6m+Hme|S7;#O952XOOQ>FoXfVvvemGrnpId3md?S<9hNT_4;KNc`Uz?{QrU1Jfu=5l+5@-Qf~Ar^IcF!_*O zgLQ;GY2eEMm)o=CEHq!y<8@GqD?`pH=gGq%=;29!Xuw}BRPxn=KUB?E3hzX#(FZ~f zgjk4Thp}Y&GZhVf<1FrRFBEO{qM}_-y(~(D^;~$Nwm@$uBqwA_KF{FyXP9&^gy;(G z`sPe$g8rg2f#+T?wQHWq2IxAF=K@v17|3=(1_j}h<-h=IPG1+e=(!BHA>AeH zxI4zbkMQp&`S($fF1NV_tMQoR!>gXcZ+P%2?Z2Ty$o|k6JAzE;&4B^$yh=as5i5(p z`K@({DE-FPrQeK>dwA)|PrPUn>=#@lkiLt%fjvmKVhz5B>cGBOS>Xf(I9I8l?q|Xm zRL4E4#fG9Li)8AecR*B`tDtYx{D_a>8?C_Su^sq#i!{fbKDC60ra+s7>;TBP;yrZ` zY9N4|usWFGZx%h6J($C$4MDdon!nYqd3hZ5mY^sMq8e>B;2K|{K5SXX!Q28L!;9iE zN3#q5{Pl_+wn03+eWG{!RX=RI0hnM4-Gr_-!xzD6UZHUw9JJ8-W+l3~>EsBO_19CU F{sDaNM)3du literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST new file mode 100644 index 00000000..a3643836 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MEMBER-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 17,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-MEMBER-IF-NOT.TEST ;; ;; ;; Syntax: (MEMBER-IF-NOT TEST LIST &KEY KEY) ;; ;; Function Description: ;;The LIST is searched for an element that satisfies the test. ;; If none is found, NIL is returned; ;; otherwise, the tail of LIST beginning ;; with the first element that satisfied the test is returned. ;; The LIST is searched on the top level only. ;; These functions are suitable for use as predicates. ;; For example: ;; ;; (MEMBER 'SNERD '(A B C D)) => NIL ;; (MEMBER-IF #'NUMBERP '(A #\SPACE 5/3 FOO)) => (5/3 FOO) ;; (MEMBER 'A '(G (A Y) C A D E A F)) => (A D E A F) ;; ;; Note, in the last example, ;; that the value returned by MEMBER is EQ to the portion of the list ;; beginning with A. ;; Thus RPLACA on the result of MEMBER may be used ;; to alter the found list element, ;; if a check is first made that MEMBER did not return NIL. ;; ;; See also function FIND and function POSITION. ;; Compatibility note: In Maclisp, the MEMBER function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for MEMBER in Common Lisp. Where in Maclisp one would write ;; (MEMBER X Y), in Common Lisp one must write (MEMBER X Y :TEST #'EQUAL) ;; to get a completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (MEMQ X Y) ;; by writing in Common Lisp (MEMBER X Y :TEST #'EQ). ;; ;; Argument(s): TEST - a function ;; LIST - a pure list ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test member-if-not 0" (and (equal (member-if-not #'floatp '(1.0 3.4 5.6 8 9.0 10)) '(8 9.0 10)) (equal (member-if-not #'integerp '(1 2 3.4 5.6 8 9.0 10)) '(3.4 5.6 8 9.0 10)) (equal (member-if-not #'consp '((a b . c) (#\d) ((#\e)) #\f g "h")) '(#\f g "h")) (equal (member-if-not #'symbolp '(a b c (#\d) ((#\e)) #\f g "h")) '((#\d) ((#\e)) #\f g "h")) (equal (member-if-not #'null '( () 1 2 t nil)) '( 1 2 t nil)) (equal (member-if-not #'symbolp '(() 1 2 t nil)) '(1 2 t nil)) (equal (member-if-not #'atom '((nil) 1 2 t nil)) '((nil) 1 2 t nil)) (equal (member-if-not #'consp '(() t nil (weight 100))) '(() t nil (weight 100))) (equal (member-if-not #'listp '( (weight 100) t nil ())) '(t nil ())) (equal (member-if-not #'numberp '(8 (1 2) ((3 4) 5) '6 "7")) '((1 2) ((3 4) 5) '6 "7") ) ) ) (do-test "test member-if-not 1" (and (equal (member-if-not #'floatp '((1.0 3.4) (5.6 8) (10 . 12)) :key #'car) '((10 . 12))) (equal (member-if-not #'null '((a b d e) (1 2 3) (10 20 (30 40) 50)) :key #'fourth) '((a b d e)(1 2 3) (10 20 (30 40) 50))) (equal (member-if-not #'atom '("a" t #(1 2 3 4) 'star (8 9 10)) :key #'identity) '('star (8 9 10))) (equal (member-if-not #'numberp '( ((1 2 3) "a" "b") ((1 3 "a") "b" 2 "c") (("c" "a" "b") 1 2 3)) :key #'cadar) '((("c" "a" "b") 1 2 3)) ) ) ) (do-test "test member-if-not 2" (and (equal (member-if-not #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197)) '(99 98 2 4 200 100 197)) (equal (member-if-not #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197) :key #'(lambda (x) (1+ x))) '( 98 2 4 200 100 197)) (equal (member-if-not #'(lambda (x) (cond ((symbolp x) (eq x 'june)) ((numberp x) t) ( (listp x) (string= (first x) "July")) )) '(("July" may june) (("July" may june) 5 6 7) ( 7 6 ("july" may june)) (6 8 ("July" may june) 5 7)) :key #'caddr) '((7 6 ("july" may june)) (6 8 ("July" may june) 5 7))) (equal (member-if-not #'(lambda (x) (string-equal x "end-of-testing")) '("end-OF-" "END-OF-" "end-OF-" "end-" "endd-of-" "endd-off-") :key #'(lambda (x) (concatenate 'string x "TESTING"))) '("end-" "endd-of-" "endd-off-")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..39132cd0e36d6d6d399c8dd9464676df7fc2cbca GIT binary patch literal 3684 zcmb_eZERE589wLwGbLuu2uTE#-9nkba6`gJQ|P++a&r?q*w?|n9;9PGjAPd+NgU;) zjH04Y(vC^D8OD^}1EoLsfkeeN7ACE5QBOUOu43 z;`);zRomYDQ0qO3Ig<2nCN-MrmCdotNN;NYI=Qt)j;8j@ty>;^aGktiIZ$EIcL#!XvWz~t6x`vmpp2_b261(zB^{KP@*W0pT)>IqZn z2uF0qP@{UlF4&eADp8UNJ#Jfd8|2aakkX%dJkyWG42%#;h<()Zb|ekW495(+NXKcd z{Zq>qHk58COzqT(D!%bwUccXN)e1f?DB1)6NFe zEq!VUxzd+z;ssBKpl3=UJe48N{E}R&%3iF>o~p_ou4JeBt8m}1!Ud~vfht`6Jg$%% z?;FpR|J|K_NqbBE^3KMDCjp?rd~c?9-%j}O?S#v3BNQdwokASWQXw^^<542)$vX;#eh&)RoOzqBz9m`#4ta>C1Ie(v@NHz9z*0O*WGup#ANJ>aG+9NO@+rq#Y zor!?tWj@IR9~XR_Fs*d~O*OTU64%XS9Hvd<_Ee25m}baCNZOh)=LTZYS7kovTc8do(_xFkn`a(6^xs@eSnTk&1i_yB7P zu%)#LKx};y68A z57YuYGD<`@I?WKF_fFSOu)yc-q9?saa>6sY+Kb=6NBSsa=?d<>ey0pTe_jTFx!a#q zcl$KBUG!LR@4s%aV1N4N7yLfHW10Ui$U$g%S>F4q#~rz=aeru^vWpTNmE~GoS4~|h zyM!ZQIO1v~!D>+rCU!?MX6oWH*umCdf1{PBxfS^^TZ>C0Kds{A(KKvr3O;+Ngyl+j z+{8Z+C7C#ubOuWxNSDrPxeNL=CRUW#ZanV^Q;oA`@aV1afq(jMm=kn+$UfqP2#^IR zvd3o?KH%04j9zs5>H#fZjk8Gq!qdX{B~`&AEZfA=E*2Oo(5STgEtY#+^5J`nUf@oo ziSLaQG7;=yC&B+j@Z!de-WiqSd;{1IL}qx&(j&aDbfU7aEhrx6eWl;w9g!#&5C0CQ zi@R_`xp?Q$^$>e}9EHa$_f9?B88TTjP6b^JmWQ~A0VFSQaw*>?X$}L;s8oXugGL@2 zM?VCci$B~2CSL%a0iVnTf1eB9oeTbmVJ(`&M1E%%y*&P5{yl+B*RaiWvX^H^Co_{- zWIKVKHo6F9PG-5mREaxZ=7>vwUgl@M$!SQ6?~vG@3Dplb7bbNArjWv>!RD2Vehi_# zvzpLr_v}v3Rqma?$Gg}X)3(~m-T;csiF9ftBd7C2eQ@<>hw}sSQ0mc)yrFHgoX^Ty tWHi#v*4_`h`i#o~op5x-VyyXI*c4vQ;Yk^I{`dx+AC#QLYOdY7^*@W67N7tC literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST new file mode 100644 index 00000000..91e6cd47 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MEMBER-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 23, 1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-MEMBER-IF.TEST ;; ;; ;; Syntax: (MEMBER-IF TEST LIST &KEY KEY) ;; ;; Function Description: ;; The LIST is searched for an element that satisfies the test. ;; If none is found, NIL is returned; ;; otherwise, the tail of LIST beginning ;; with the first element that satisfied the test is returned. ;; The LIST is searched on the top level only. ;; These functions are suitable for use as predicates. ;; For example: ;; ;; (MEMBER 'SNERD '(A B C D)) => NIL ;; (MEMBER-IF #'NUMBERP '(A #\SPACE 5/3 FOO)) => (5/3 FOO) ;; (MEMBER 'A '(G (A Y) C A D E A F)) => (A D E A F) ;; ;; Note, in the last example, ;; that the value returned by MEMBER is EQ to the portion of the list ;; beginning with A. ;; Thus RPLACA on the result of MEMBER may be used ;; to alter the found list element, ;; if a check is first made that MEMBER did not return NIL. ;; ;; See also function FIND and function POSITION. ;; Compatibility note: In Maclisp, the MEMBER function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for MEMBER in Common Lisp. Where in Maclisp one would write ;; (MEMBER X Y), in Common Lisp one must write (MEMBER X Y :TEST #'EQUAL) ;; to get a completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (MEMQ X Y) ;; by writing in Common Lisp (MEMBER X Y :TEST #'EQ). ;; ;; Argument(s): TEST - a function ;; LIST - a pure list ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test member-if - test case copied from page 275 of CLtL" (equal (MEMBER-IF #'NUMBERP '(A #\SPACE #.(/ 5 3) FOO)) '(#.(/ 5 3) FOO)) ) (do-test "test member-if 0" (and (equal (member-if #'integerp '(1.0 3.4 5.6 8 9.0 10)) '(8 9.0 10)) (equal (member-if #'floatp '(1 2 3.4 5.6 8 9.0 10)) '(3.4 5.6 8 9.0 10)) (equal (member-if #'characterp '(a b c (#\d) ((#\e)) #\f g "h")) '(#\f g "h")) (equal (member-if #'stringp '(a b c (#\d) ((#\e)) #\f g "h")) '("h")) (equal (member-if #'null '( () 1 2 t nil)) '( () 1 2 t nil)) (equal (member-if #'symbolp '(() 1 2 t nil)) '(() 1 2 t nil)) (equal (member-if #'atom '((nil) 1 2 t nil)) '(1 2 t nil)) (equal (member-if #'consp '(t nil () (weight 100))) '((weight 100))) (equal (member-if #'listp '(t nil () (weight 100))) '(nil () (weight 100))) (equal (member-if #'numberp '((1 2) ((3 4) 5) '6 "7")) nil) ) ) (do-test "test member-if 1" (and (equal (member-if #'integerp '((1.0 3.4) (5.6 8) (10 . 12)) :key #'car) '((10 . 12))) (equal (member-if #'null '((a b d e) (1 2 3) (10 20 (30 40) 50)) :key #'fourth) '((1 2 3) (10 20 (30 40) 50))) (equal (member-if #'listp '("a" t #(1 2 3 4) 'star (8 9 10)) :key #'identity) '('star (8 9 10))) (equal (member-if #'stringp '( ((1 2 3) "a" "b") ((1 3 "a") "b" 2 "c") (("c" "a" "b") 1 2 3)) :key #'cadar) '((("c" "a" "b") 1 2 3)) ) ) ) (do-test "test member-if 2" (and (equal (member-if #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197)) '(200 100 197)) (equal (member-if #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197) :key #'(lambda (x) (1+ x))) '(99 98 2 4 200 100 197)) (equal (member-if #'(lambda (x) (and (listp x) (= (list-length x) 3) (string= (first x) "July"))) '(("July" may june) (("July" may june) 5 6 7) ( 7 6 ("july" may june)) (6 8 ("July" may june) 5 7)) :key #'caddr) '((6 8 ("July" may june) 5 7))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL b/internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e8bce7a8382d31ad403e94e1c33deb3a7fc48791 GIT binary patch literal 4830 zcmb^#ZERat_1^pJB+bW~CRv+?lD>9b*{rzK{cg6FzB(_B8-FCvFKx4R(;WMy_UhPa z;)6O17cAR#0sRzPAJNJvbmoO7>V z;v^O2M;pI)?)g6Vo{wvHic}s6hSgwxXgHI#M%4URVR)>d4(3PH(frs*(ozS3u6{8X zGxVprv|#t9hXU2{GEQ>DN))V=YK~c>sl<4j8rZBx660!M_pV)S>XxnT+jh4H0-LHk zwRl+Cay1THshq15DAU>8zI9uBVE3l#Tii%Z*Iw4c(v(bZ$*1_sx^Wheh zb)Q;7u4R&I#GYM8e{mgEf(`GqWE%hOPW0@Y8~w797dY5!u!Ik;vK|Z|s{jgz2N7J# zBLSZ$=V|@0Tr4-Y$#Ug3S2^pM*S^;!&RdjQynEYJ9(A`_=Q;!bb0K7t%}AcT^mtbA z%X!Esarc(#;rJ^$-J8>^L)&-5wxfI_WLi}w2kJ?`UFSq?O+%}q_5cQ7?~ES{RR9zwVWXXO?g zeJxk@lQVy{72G{$wa z(;v}-My&iO=*z%s61=77L{EzlX-mkbTy8@Vfc*`mYvZN?z310Uk+7R0684S+ z7&_aF-q{67ndUyk&Pl9W*kwU!aHj+uP4c2pA=45}^5zcS`Y>O+nXg^X8&{!)cvLq!ctZr- zc~&}ha1r}$-IPjQ}ON(H>A2VUMfv;nZfvFR~EMawS= zsuytlUPu#y0SZF)j@swv?99OY1f|xxCbT+^`VenZE4-Up(RGP4TnY^)^M2j{NuWXA zz#Bn;ALWhwQPe&J7!m;GM{xmQk;oqBTWDz7ZVei`X6pV$6FM9+bwdlsc`b@T1@`vE zOkH+NfNw)De#h>?Y*~v^oPrd)tv;7$C{)$Zd%{{!yF<>E2l);#&;I4ic)tuMnsRJq z%hqj^yO8*SGlR#UfM;Ma?~g#xQ0TYfh}e-NCdGr4UjgMv5?Aj!FOZsjaO-RE+^Q#z z{i$qXXdsoqsFvJpP%TW{Y-rJ@N8ssa6>uCi;Sl_?2yRc2M9Zx2*W0pE%6~;z# z*l?q&bpmdE(W=AwkwPY)Q}cr=9)dbx9n0i$*t(}Og|rHFgX4fbCbJ0j>n-*c$BKz! zvUnUBEyWWEmcfRapytnLFA;L)ZG6Eg5{U{LzEILDXt1LH#PhXT0)l1(kbgFStHc2E zKAKzo0bIh#dvS=uc!OmnEOp(G2+%`F=bx1vV7a4q7K1%e7A(CXf~Bv6V;nB%=(|us zfqm?97rPRoZ-f~BG=WbSJqYh^M$;|$57+b{uJO53oq1rJ^L19cVMFQGhr8CX8(mb7 z9ts(;Xhe^i#Iqi%up(-91v`wD{DFGjT+Myryy!Dal1(Q>vgsEbduLg){UV0HxL$)EeSOf6WSd~AG^SLb6AU!EkN;{y6L^sksa1@o=RHic zcfhIRbYgsBvaHvs54r#fq?izs5nvI!n{F&75Uj;oz{UcuqA-fI<=7;Gu$WUbM?g6o z=V$icSbcsPF5xINDiFyn=Q-#*Nf%6bv2$3VD7i%Z6G1`6k6|XsK??(%;!fa&O^(c) z;22sNmwy5|3OjRqA7%qel@f}bL qI6WbHcnk0MJ2O?%lL#L7gH4ThV3|}4REZlOT^JELk9Ka}y7gbvn_3M3 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST b/internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST new file mode 100644 index 00000000..f9c350f9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MEMBER ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach / Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 16,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-MEMBER.TEST ;; ;; ;; Syntax: (MEMBER ITEM LIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; The LIST is searched for an element that satisfies the test. ;; If none is found, NIL is returned; ;; otherwise, the tail of LIST beginning ;; with the first element that satisfied the test is returned. ;; The LIST is searched on the top level only. ;; These functions are suitable for use as predicates. ;; For example: ;; ;; (MEMBER 'SNERD '(A B C D)) => NIL ;; (MEMBER-IF #'NUMBERP '(A #\SPACE 5/3 FOO)) => (5/3 FOO) ;; (MEMBER 'A '(G (A Y) C A D E A F)) => (A D E A F) ;; ;; Note, in the last example, ;; that the value returned by MEMBER is EQ to the portion of the list ;; beginning with A. ;; Thus RPLACA on the result of MEMBER may be used ;; to alter the found list element, ;; if a check is first made that MEMBER did not return NIL. ;; ;; See also function FIND and function POSITION. ;; Compatibility note: In Maclisp, the MEMBER function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for MEMBER in Common Lisp. Where in Maclisp one would write ;; (MEMBER X Y), in Common Lisp one must write (MEMBER X Y :TEST #'EQUAL) ;; to get a completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (MEMQ X Y) ;; by writing in Common Lisp (MEMBER X Y :TEST #'EQ). ;; ;; Argument(s): ITEM - anything ;; LIST - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test member - test cases copied from page 275 of CLtL" (and (equal (MEMBER 'SNERD '(A B C D)) NIL) (equal (MEMBER 'A '(G (A Y) C A D E A F)) '(A D E A F)) ) ) (do-test "test member - if the ITEM is not found in LIST , nil is returned" (notany #'member '(a b c d e f g) '((c d e) (e f g) (a b) (a b c) (b c d) (c d e) (a b c d e f))) ) (do-test "test member- the LIST is searched on the top level only" (and (equal (member 2 '(1 3 (2 4) 2 4 6)) '(2 4 6)) (eq (member a '(b c ((a)) (a) d e)) nil) (equal (member 100.05 '((100.05 100.05) 100.005 (100.05) 100.05 . end )) '(100.05 . end)) (equal (member '(1 2 (3)) '(1 2 (3) (1 2 (3)) 3 2 1 ) :test #'equal) '((1 2 (3)) 3 2 1 )) (eq (member #\a '((#\a) ((#\a)) #\A)) nil) (equal (member 'dummy '(a (d ()) "234" () 56) :test-not #'(lambda (x y) (not (null y)))) '(() 56)) ) ) (defun fun1 (item list nth fn) (eq (member item list :test fn) (nthcdr nth list))) (do-test "test member - the value returned is eq to the portion of LIST beginning with ITEM" (prog2 (defun fun1 (item list nth fn) (eq (member item list :test fn) (nthcdr nth list))) (and (fun1 4 '(1 2 3 4) 3 #'=) (fun1 #\q '(#\q #\u #\a #\c #\k) 0 #'char=) (fun1 'pretty '(prety preeery prity pretty prreety) 3 #'eq) (fun1 "ab" '("aa" "bb" "ba" "ab") 3 #'equal) (fun1 20.0 '(20 (20.0) -20.0 0.0 20.0 20.0 20.0) 4 #'eql) (fun1 #\q '(#\Q #\u #\a #\c #\k) 0 #'equalp) ) ) ) (do-test "teste member - include :TEST-NOT keyword and REPLACA in the following test cases" (and (equal (rplaca (member 11.0 '(11 22.0 33 44) :test-not #'eq) 99) '(99 22.0 33 44)) (equal (rplaca (member 10 '(1 3 20 4 5 (2 4 6) 24) :test-not #'>=) #\y) '(#\y 4 5 (2 4 6) 24)) (equal (rplaca (member '(a b c) '((c d e) (1 2 3) (a b c d e) (2 . 4)) :test-not #'(lambda (x y) (= (list-length x) (list-length y)))) '(88 99)) '((88 99)(2 . 4))) (equal (rplaca (member "A" '("a" "b" "d" "234" () 56) :test-not #'string-equal) t) '(t "d" "234" () 56)) ) ) (do-test "test member - incluse :KEY keyword in the following test cases" (and (equal (member 'a '((a b c) (b c a) (c a b)) :test #'eq :key #'caddr) '((b c a) (c a b))) (equal (member 10 '((10 20 30) (20 30 10) (30 10 20)) :test #'= :key #'cadr) '((30 10 20))) (equal (member '(1 . 4) '( ((2 . 8) "a" (1 . 4) 1 . 4) ((3 . 6) (1 . 4) (5 . 10)) ((5 . 6) "g" (1 . 4)) ) :test-not #'equal :key #'third) '(((3 . 6) (1 . 4) (5 . 10)) ((5 . 6) "g" (1 . 4)) )) (equal (member 100 '((10 200 300) (1 2 3 4) (1000 2000 3000)) :test-not #'< :key #'second) '((1 2 3 4) (1000 2000 3000)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..028f15162d90a799e750a36e5e8b28575577ee75 GIT binary patch literal 4447 zcmb_feQaA-6~FgA+esWdwKJ<9Nt!&RpL6Q2NmFRMf%4+K)K2W@)PBZI$4A}7t<4fU zBo3pDRnZg%2rtaZ*1gNLKL8k~8}uI}gb?E6k7+{H{sAGeaL&DU z>LsQfQB^tT+;h*z@0@$yxwl19bHX1|{JHUo%vfqt$xY`crt`{~+@vywWkBBe{lb!o%UG8&d6jcnNN)>#&l|GG8!9haP(mJ(e97zx39cnUZAcVA!LLsA*mz8MPy>m7hGOL ziy6NDU`X@nYFP7{MYB)~nfT%{Eov6rT}nPT;TubRJ~f8Pj873ti1~b>wm+`>jbKDK z7w8OinBOQkgSu}B5>t<9M5--$LGRQoGjjoT3b<$8t?`F%w6divS` zy_zK#uMbFx_9i#Aa<~eIJJPb0P!cUpz~8!*XvLl7ml7?U&ZMuMC8Y70n$0wQ^@a}o zo#Nng`b|QL>1Xu;iGo$}^47#o)Gq%Vge+x7c5~;Y$n=eJ zgisv_Mb8`#|Ds<&QDr*eh;Q>mOW)~_Nw4e2nUQ!ElTy$ zYIUH2zIPuR+{Pbtm09jX=%(@em{mE9#gE?4M!;L!#lX;;QYB)j=y zp~dTu=zT$)C%%BH_l2~muQv!1{aDN^Iha$bho2J$mgM)Zjwl>1QXL9=dzk}f4sfap zTn#8&;b#Gf+v`^if4~>jjCd3#l%J0{TWmOHXkm%2*DxYp=9U{+gS?5^Wf$8dyO~pN zgbCN+)uPcz)E9{xLvh0^KLo}Ouc{CGxIE@%FzVcg)=ta@_#Bu8=j1M&ckh8GTYn@P zRt;SK5uAALX75*HnsCS5xP1kxr7LV3lIPfVBULq@#8>1Uz9PTjAju7GNPY^2R-Pl+ksk=n@37`6w)Hb?+rz9`0l9peYvDQK>P@)H zY&srB2$xH22a*dQwP1JQ;xyiN{Fc-sT+qSr9HoB>a*?&;>Ra4WdQp%w7{mw!qkXtH z0v_Z+Z5a7a!4CZxawpkNBo1M3;fC~If-HlU>{odKZm~U}M{j~i(vBnhb8bl|xh4Iq zF!{6~9|tv?c08_zhEVlUp}K{2;L5{SeSboPmC?#V1J z-!TiGd}=DMWHZ@(YH}(ylF#I_N;mHP-7K^jxYvGOZCB1D;cYXjWU}I6g0l0x*MDR# zVB?zwTW&I$J)07IJ~y5m&vCwPB9l!eCnmwRP`Y~gHg%DEY!avA&A~}&fhm0sTR^n-_ z%!2HcWL$kttR!0vu2PVDGhE>Cgy@0P1g8SGBBu1cbAp)g@zkgTP=Is z!rG*IkkJmxJ}J&7fuK1e`0KGEI>|y2&yd)mvK3{v8Yqg>gBy?G#tV`p&*ja66w9OR zFg|a4hF0GnaHnphW8hO%>HwsTb;xX|K)4_3Qs0Ax*k~Q7%sNV~sF({jfxR1szExF? zNSHYw1G=vwn{A*4Ukpvp8C)693AzI(I%GV>Gj2d3Rsqwu-F3^R*Laiu4GGlssLLCL z574m_rFZWY=7hi17n~xjemZDk}pGBG*z_4YJcGSbR!KSZ)Qp(Yl9xKY+}0| zY>$oYEq97EEjo6#_f%cs&@$S%=RkqMq7}(_RjkMEXo=AzqA8F+v)iNFs+Zx z`XL5zd%IS1?cz0NuqH()1ZU<&33rPUwpTA9x{z9V3F#d^67Zy~gQ^i2W{y)B;IBf= zeO}_J{ej~_MYz^<=7@{)wFWdj3ReAP1edt|PlPtNUqn^Ty}Cy0hZS0vMoSI{)hPP! zDlKF2mHv3=f63%eu+Q_m#sB^qb~*DV1R%f1>kxF|jfw;wtw{WW^a%&IzyY;d zQ2m#9{q+pBY@}Dg9KTy~g&&^PVx_fpxHip&y9;O)E0tu6^{MK`%rV~+X5k@x{3w;L zKjpw#_Q;V^CHk3zXZSY%d%Lro@!PHCQv9WIe@j^^^nc6uen+bVAm2pH@2;%;7e>AL AF#rGn literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.TEST b/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.TEST new file mode 100644 index 00000000..8296be08 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NINTERSECTION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 277 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 24,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-NINTERSECTION.TEST ;; ;; ;; Syntax: (NINTERSECTION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; INTERSECTION takes two lists and returns a new list containing ;; everything that is an element of both argument lists. ;; If either list has duplicate entries, the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (INTERSECTION '(A B C) '(F A D)) => (A) ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the intersection operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' For every matching pair, ;; exactly one of the two elements of the pair will be put in the result. ;; No element from either list appears in the result that does not match ;; an element from the other list. ;; All this is very general, but probably ;; not particularly useful unless the test is an equivalence relation. ;; ;; NINTERSECTION is the destructive version of INTERSECTION. ;; It performs the same operation, but may destroy LIST1 ;; using its cells to construct the result. (The argument LIST2 ;; is NOT destroyed.) ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (DO-TEST "TEST INTERSECTION 0" (prog2 (setq aa '(a b c) bb '(f a d) cc (nintersection aa bb)) (and (equal cc '(a)) (equal bb '(f a d))))) (do-test "test nintersection 1" (and (prog2 (setq aa '(1 2 3 4 5) bb '(4 5 1 8 9) cc (nintersection aa bb)) (and (every #'equal (list bb) '( (4 5 1 8 9))) (= (list-length cc) 3) (every #'(lambda (x) (member x cc :test #'eq)) '(1 5 4)))) (prog2 (setq aa '(a b c d) bb '(x y (z)) cc (nintersection bb aa)) (and (equal bb '(x y (z))) (eq cc nil))) (let* ((aa '(#\a #\b)) (bb '(#\B #\a)) (cc (nintersection aa bb :test #'equalp))) (and (equal bb '(#\B #\a)) (member #\a cc) (member #\b cc :test #'equalp) (= (list-length cc) 2))))) (do-test "test nintersection 2" (progn (setq aa '((Kathy 100) (Karen 50) (Susan 80)) bb '((ken 85) (Henry 70) (kathy 96)) cc (nintersection aa bb :test #'eq :key #'car )) (and (equal bb '((ken 85) (Henry 70) (kathy 96))) (or (equal cc '((Kathy 100))) (equal cc '((Kathy 96))))))) (do-test "test nintersection 3" (progn (setq aa '((10 20 120) (30 60 360.0) (40 50 450)) bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0)) cc (intersection aa bb :test #'= :key #'third)) (and (equal bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0))) (and (= (list-length cc ) 2) (every #'(lambda (x) (member x cc :test #'= :key #'third)) '(360 450)))))) (do-test "test nintersection 4" (and (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (nintersection aa bb :test-not #'(lambda (x y) (not (equal x y))) )) (and (equal bb '((2 . 3) #\4 aatom 300 #\t "St")) (equal cc '((2 . 3))))) (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (nintersection aa bb :test-not #'(lambda (x y) (not (equalp x y))) )) (and (every #'(lambda (x) (member x cc :test #'equalp)) '((2 . 3) #\t "St")) (= (list-length cc) 3))) (progn (setq aa '((1 3 5) (2 6 7) (10 20)) bb '((10 2 3) ( 20 5 1) ( 2 4 1)) cc (nintersection aa bb :test-not #'(lambda ( x y) (/= (apply #'+ x) (apply #'+ y))))) (or (equal cc '((2 6 7))) (equal cc '((10 2 3))))) (progn (setq aa '("banana" "papaya" "tomamo") bb '("orange" "pineapple" "watermelon") cc (nintersection aa bb :test #'(lambda (x y) (car (mapcar #'find '(#\m #\a ) (list x y)))))) (and (equal bb '("orange" "pineapple" "watermelon")) (some #'(lambda (x) (equal cc x)) '(("orange") ("tomamo") ("pineapple") ("watermelon"))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ea73eaec992a9241aca9f6f7ea1ae9113a4a43ba GIT binary patch literal 7976 zcmdT}d2Afj8J}|x$LrXMArMHi4NeFfkLxRG5(;Fz9v|^~*V!GjF$IBHud^NMt``)(`uP+4x zDr%gW_kQ2|?sv~lO8#BZSU5VoXJlY7I~pFI7$2D!5BCp`hR22{Ml;!PKj`7Bqlu(- zO`93*s5!r`BvsUs8O`>NXZynTM0TvNcVBh5t~T7+yDwa~b<39OaDBtJ#;x1x>S{__ z%v6kZc@pVt-;gI$S0q!rtzpx)y84=u<99oE%H_k7BxR&&DuR+!E~%1pd%iqkTPfRU zX^&Y(-0ZX>&ZLtMAQGcHWhI?_MSXaDc*GdYemgrz!R#56WJz*mz{iN-6ms`5l>mR(cIqBVkND3)RN%V>DNh;zpA2K zA-A5&J>4N68j|jLrb9`uU0EUfc1sd9gd}Nt;Awzm*ZEh;xkHziO()6#|27%BEm8I> zNt(>vm?-N|WH3%Xx-wlwLIv4UlFh82e$4lHkqvpTXCpw=f{{XTaL)p?^a3<<0ouj| zXs6Am9msiqpE|BHI4)0@7Z~9}=9E@1s-VY(j8GND!QDl)91-jyg2!~>0<;Z9G$HuE zibq}H#SGXzlWX5o&dOBV0<*=i`nck48Il&&u)Gi=XlddgNQV%7Qxtr4U1x*KXUtlEuq!$Tq zp$kP)@TJ6uNQ)x+yk0=#9LDl zWvLrd%J7unDaEq{PY6#CPXLb(kB&{hA`&(2Xq%C=?CvBs?WoxGeW{+5ZFMRNI4b#A z5RF-8yt~V2NhCW{5m#2^`OX~^)Kt?nQ9XmIO``owYHx0Kmpl3Lx;dwl z3M9+b=t#1g4i>B7k!D?N#t2jZ_$U(72K4<0YAR>488uTD`{+QI63!7}<u3*-0=Hffd(!gyICY~hh+8!M4|jr5S2$5-6IP5 zPl71F&FEDwRxq(lAnCYUbus3Bs5P0uszsGDg`l=cF2}er!9|=4i;KdF^`dj9Oxb85-=2l0C8Wv3bNuAml!7*e zwBhMde9-8NS@Bl8O>vtGY9Do`RD^Q?|C}j}qDs5V-5Ph3Ylvj1p~}^0a2u$p9Zhu* za2wnXw~oAeP>8EC2`efs`#Q9_)x?dRgbHjUZY>El5^7;$D~c(fTkRTdjmRvq=x&`` z58aLKCel6S{0L1DS{+SVrfnH>wu)H0Z6(cE$}J@}Or4$G3EL8*$#fC%{5b5ub^}MgHzM*l`W+xxYv)9vQ$i z?;joB6CUZ^oekH2ZA*B#KOBvX(~7D;A-Z3`PWa>t;157cTriTncRXSA`bw49P!*5y){ifjL>qEKUp$noCOU}!MCC8eR8Y|a z;PCrYYIzsaR`V%=0D-rlMiqQ-cmltHlAtDNhv&+^=u8ECT0rx|42eIDMI-$L*mTGqcYq}iL!9YrGoR<~tYLOLf?_yb@l}8&BSMz?XLRL96gWE%ZvJe$cy^Z#q!cfdhZo^Q8Vxz z3#N+sB35&~%SzhV@LcdnFB2n8S>o8)PCF+mEeY(B)Upe*%qQNj%*Z5ItJY~**dzq~ zD8EUr4TDFZSH=4Xlxm%cq-XUN!j~kH9R?z_#W;`Ys`CTw7 zC|qZrBP4x3`j3?oYV>q*7_W(z*TtJ<=IdgfVQX_YwQ_P1gQA0fiYBljVG>jU7NF)6T$w_Po&|QOvY}n8!>|+uI zg{&cXYuOLdb3NO#A=8aVa9^{ixBHx_5VR7n0qfw0pDEWMO@oU{_U<_em;8uNIzT9H##Xn4&4q(8Uh#!Bz@-`>Dw0`DAM;iD>Wp8b@IfJ z+dpSW=4L0q$2||fXx40NvhWqq;$Jhx547UcE-vTZt$cr~a8IvUh12)OAxT=ZYkQ?M z-F8^=F2M&YiAo=wE2Xwd#iaB3$*xrR>2%(eN?nJKG$re-i>+jjk-~@Em_=VIm&9<^ zHu%C^LJOQ+BgtpMnPuDI1U?MoKU~3&fOIRUnz`H0)aKsuVO_>28GkgENOdPIEF|CML>TEST>15-5-NSET-DIFFERENCE.TEST ;; ;; ;; Syntax: (NSET-DIFFERENCE LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-DIFFERENCE returns a list of elements of LIST1 ;; that do not appear in LIST2. This operation is ;; not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set difference operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' An element of LIST1 ;; appears in the result if and only if it does not match any element ;; of LIST2. This is very general and permits interesting applications. ;; For example, one can remove from a list of strings all those strings ;; containing one of a given list characters: ;; ;; ;; REMOVE ALL FLAVOR NAMES THAT CONTAIN "C" OR "W". ;; (SET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" ;; "LEMON" "PISTACHIO" "RHUBARB") ;; '(#\C #\W) ;; :TEST ;; #'(LAMBDA (S C) (FIND C S))) ;; ;; => ("BANANA" "RHUBARB" "LEMON") ;One possible ordering. ;; ;; ;; NSET-DIFFERENCE is the destructive version of SET-DIFFERENCE. ;; This operation may destroy LIST1. ;; ;; Compatibility note: An approximately equivalent Interlisp function ;; is LDIFFERENCE. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group (group-test :before (defun EQUALLY (x y) (and (= (list-length x) (list-length y)) (every #'(lambda (w) (member w x :test #'equal)) y) ))) (DO-TEST "NSET-DIFFERENCE TEST 1" (and (EQUALLY (NSET-DIFFERENCE '(A B C X C D) '(C C B A)) '(D X)) (EQUALLY (NSET-DIFFERENCE '(D X D Z D F G F) '(C C B A)) '(F G F D Z D X D)) (EQUALLY (NSET-DIFFERENCE '(Z A E D B E F) '(C C B A)) '(F E D E Z)) (EQUALLY (NSET-DIFFERENCE '(F C Z E) '(D X F D D F G)) '(E Z C)) (EQUALLY (NSET-DIFFERENCE '(D Z E E) '(C F A E G C)) '(Z D)) (EQUALLY (NSET-DIFFERENCE '(Z A E D B E F) '(Y F B Z Y F X E)) '(D A)))) (DO-TEST "NSET-DIFFERENCE TEST 2" (and (EQUALLY (NSET-DIFFERENCE '(Y F B Z Y F X E) '(D Z E E)) '(X F Y B F Y)) (EQUALLY (NSET-DIFFERENCE '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (EQUALLY (NSET-DIFFERENCE '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(A F X G X F)) (EQUALLY (NSET-DIFFERENCE '(C B Z B B D Y B E) '(D X D Z D F G F)) '(E B Y B B B C)) (EQUALLY (NSET-DIFFERENCE '(C C B A) '(A B C X C D)) NIL) (EQUALLY (NSET-DIFFERENCE '(C F A E G C) '(Z C Y B E Z D B D)) '(G A F)))) (DO-TEST "NSET-DIFFERENCE TEST 3" (and (EQUALLY (NSET-DIFFERENCE '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK)) (EQUALLY (NSET-DIFFERENCE '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(CATOR)) (EQUALLY (NSET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK PERTY MORY FOO)) (EQUALLY (NSET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (EQUALLY (NSET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (EQUALLY (NSET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(BAZ QIX ZORK PERTY QIX)))) (DO-TEST "NSET-DIFFERENCE TEST 4" (and (EQUALLY (NSET-DIFFERENCE '(MEEF) '(QIX FOO)) '(MEEF)) (EQUALLY (NSET-DIFFERENCE '(MEEF) '(PERTY QIX CATOR)) '(MEEF)) (EQUALLY (NSET-DIFFERENCE '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(CATOR CATOR BAR BAR MORY)) (EQUALLY (NSET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(BAR)) (EQUALLY (NSET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(MEEF MEEF MEEF)) (EQUALLY (NSET-DIFFERENCE '(BAR PERTY BAR) '(QIX FOO)) '(BAR PERTY BAR)))) (DO-TEST "NSET-DIFFERENCE TEST 5" (and (EQUALLY (NSET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(2 6 2 9 2 8)) (EQUALLY (NSET-DIFFERENCE '(3 4) '(6 4 8 4 7 3 2 9)) NIL) (EQUALLY (NSET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(1 5)) (EQUALLY (NSET-DIFFERENCE '(2 7 2) '(4)) '(2 7 2)) (EQUALLY (NSET-DIFFERENCE '(7 3 4 10 8) '(2 9 4)) '(8 10 3 7)) (EQUALLY (NSET-DIFFERENCE '(8 2) '(4 5 1 10 5 7 7 10)) '(2 8)))) (DO-TEST "NSET-DIFFERENCE TEST 6" (and (EQUALLY (NSET-DIFFERENCE '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(10 7 7 10 4)) (EQUALLY (NSET-DIFFERENCE '(4 6 2 8 8) '(2 7 2)) '(8 8 6 4)) (EQUALLY (NSET-DIFFERENCE '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(9 4 4)) (EQUALLY (NSET-DIFFERENCE '(4) '(3 4)) NIL) (EQUALLY (NSET-DIFFERENCE '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(4)) (EQUALLY (NSET-DIFFERENCE '(2 9 4) '(2 7 2)) '(4 9)))) (do-test "test nset-difference - test case copied from page 278 of CLtL" (equally (NSET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" "LEMON" "PISTACHIO" "RHUBARB") '(#\C #\W) :TEST #'(LAMBDA (S C) (FIND C S))) '( "RHUBARB" "LEMON" "BANANA") ) ) (do-test "test nset-difference 8" (and (prog2 (setq aa '("STRAWBERRY" "CHOCOLATE" "BANANA" ) bb '("123456" "chocochoco" "strawstrawst") cc (nset-difference aa bb :test-not #'(lambda (x y) (/= (length x) (length y))))) (and (equally cc '("CHOCOLATE")) ) ) (prog2 (setq aa '((1 2) "hello" long-atom) aaa aa bb '(2 3 4 5 6 7) bbb bb cc (nset-difference aa bb :test #'(lambda (x y) (numberp y))) dd (nset-difference aaa bbb :test-not #'(lambda (x y) (not (numberp x))))) (and (eq cc nil) (equally dd '(long-atom "hello" (1 2))) ) ) ) ) (do-test "test nset-difference 9" (and (progn (setq aa '( (1 () (2 3 4 (5))) (a b c d (e f g)) (a z x (8 9) d (l o n e y))) bb '( (() () () () (w x y z)) ((10 20 30)) (n i l (n i l))) cc (nset-difference aa bb :test #'(lambda (x y) (= (length x) (length y))) :key #'(lambda(x) (car (last x))) )) (equally cc '((a z x (8 9) d (l o n e y)))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5e89174e718dc336591ddc78e4e409cf043cf3d9 GIT binary patch literal 12964 zcmds83vg7`8NTn`gltFv5mJgvj1I2ZnDCmA3Uaf#c|fuob~h}^IF^tsCKVDUBnYTT z7;GJ98^EZ&*II{RsKwD~mC`DekW!u2ajezSRy#V?R;RVrTF0@i(--|8_a-+l#KN7{ z4!QT7|D6Av|NGDXxaXd`2)^}^`e3Ac%ht}#>7HPBU+>nw-r%P0p5V6bzMi&pa1*o# zZ;8a>#%;BFWKGHE%CZx#p0=KJYj3(enCwe$Yj53I94sphHni>xmMt$YFAgqRT(M+% zMOj%%cD0_U=ee8_sdRgnGp5WnrnF-5(u$>vOR~>?&Ad;{>lOr|O&G=^OAzt|SupR; zENTvld&C@befdW|7SetQ<2T{JVZ%a(?hhNB5188%?@rbOL3BOHqh z0Br7FLGZnopC=)(r#eoq5l?gpCx+HYsVfWeMeRmGz>a_*3_}(Eu-17JDl_)_7Kj}u zKA$@r%LVfNgZ2Akxlaqi!HzG*a@R;AFdlrYAhi&OLq8TdIJPY`{J5{zB~3i&Nb_T> zbHRA{JGRB4v9#M#leFoRv|T+(+a(j*_H;P^&RefJtd}#FqZrcm8cH`hT4gz0Sboa2 zl2kO%+48g_EQf zL2XaR;m3u2W9D2k`P|FSPey7H_ee;f_2($}{iH%nLh5qgUJs?^kk$q95<3paoB-GXbYnyniEN*L6U%D7VmK)^@bj8 zY7AG$;th$AB}(GN(aBiI%8~P-L(=t;tq^WvrkD8)k>OcF7{VdL1O{b6zE5W&tM%G zP})4?Fbpf-%;c4g+l=KyELsZgz;3}^)Y||`G1lqzNW2P!hPvuWB!2|c%o<(qh@LPQ zrj>);4}v|iuQ1jb@#b&>3{Y=i>pfN>7I(r_`4cv8*mDQ;Oiwg7RL1JV&V~@%`>e~c z=&_2h*a%!%kyvAMI2ku+;uh-)>?pQ^Sj@2&K%xDKq-k%`SnVk;_7RJ=m02RpvYd+& zE()3RG7_duXDWv%^&dp3ACNrt9WGww;tUt3X%_VfE*{|lM|rr()Btnd&c%9yq*f6m zbtaF?BTnTkQ3{Jy{=n4R-1jn5KV#}?roPYAx0rgAsl6mY=^_cr3ht}mzN?tJlBr9W zn!%Jvl>9HEK9BsN)lv~B*>lIw~70jn2Ix{GqsYbFjFC><}x*#DCu3A zQ+kEwl)gcI(h=?(WaIo%)22s89GEQ*SYKhN%~s8fNMwQ;#rp zl&P;Ub&qxVjaD#eEw~zDZ6>@5Rfik&NIW(YI18YC7PXIysB17t-h?1h8{@H>C{ibp zqBMilx8a3Mi(;%(=pV5{*t!>Zl!#sxN8)y1k=Gc_Snq}oIigehW~&&RvaPGIP-vv~ zXD(jD_dI$(jK(mDXveJ*EYifRUC&$%T+D+>a}vooB#*GMwuz8vb72MrXTV`uz~N(# z6-aAVDHQ70p;@C5jYuBm*5xEaEv3oT1ym?))Tp#DwT24$%hV|EW2%n|>BrP4J;T&@ zs1W~3jpBPuz0Sn~Zk)qZmKE9nnQ|U$J^p<)ToaEqHCp*~)>W&lP?;542)u#xj;*a- z?PyFZ{|ac3sa9Yu0d<6j;O2YT%=r4cZtCj3xeLiNX6EYN^tRq$*S2(TIK887bKkbk z?ddR_6$Hb%|uf)!w@;7#eBH+T26yk!XuTNMx$OcQdwkei0$jf{Stz{^o$jn?bg#$SDcf!u? z1VO7DMr*(KX7OY*lQrUtW+u?yxoK0nC*9SSHZv-mVfA+43Tm%|^y#Z$AE(20_FzX| z=f}I3WV@FH?xn+3DQW0p^+vQNSu0t+;1@XcOSoXREHfkT=-!E~&!IUoGK9)FP;Rtx zS9dQmKaHCqtUPgnFxLajW`a4bz79^v9IP<6u+PT(Fd*Aw4$6D>z#Za3>hA~fa4G%J zAolkoki)T8)*D%o*}6YXh>jlFMj&$Yr!!r_LE} zmvOm^wu9Yeg*WbkwpsGIoce2X&<70^22f%rYK9u(#5LdsD!67PYl>g-!IC46XT1@xs96fDd~(Fl%9HNJKJJZR)#nHONcW?ls$Z3|Buzv=Q;qEB(Qi(Sz z1OU7m5LHF;(@GYOM5qGWN7W}Q0ScG`Z^Uc3e6o*3=Q?o$J3u>OD4I876$SDF3YGsh zHb~^ZjP)e>18)Fmkf#(;B?!MA2jMqP=8%8ojc_$f^7%EA{nN4jCciLF{pY+vFpWZn zqla)DpAb0mQ3@RS$kc&@uX^$!3LJSOEE;U-|GPG`g?nI_V7`aB9l@y}{2Q7+4=mqq`f>1~T3Zh&AeB)$Ab%4U;?d;M=?$ z@CK;j0>`o$2YHtC;e;F`y-hhrdTZ(&vl!q?Z%~er4xPguF3D&L=>f+P-SO`>yW6GR z3yE$lU8EDG@h3GLi*6HghTyegM7HJ7oKgnfnq1~&W@h6!V&FWa6-V6Zn3<@3-k6!= ziKQ|EM#K2l6Z9RQ7<%s*=v)7L(BWw8KhI$joMMc5qLBU0+wrdVMs4<@iMiM9a*VNw ztOw_Q7qA5NuyG}|-2&Oi*+nQqYrRobBFXHQeWc8_7o<%27`I&F4d?)Y<|X30d+FTK z#S6$htRx*+Nb@Hq*BP8#bEi(Oi!fybD7lJw`hqBg{qSfL;ZWZ);M5MP@DX;j9lqIG zI)NPqUh#)cMjk>=+~7p0^AwFZK=mPH{DGJ2Htawmsr!L4>>BEGz{YeMok9FAB8Kxw zh6YEH*f>OY(&!i-RF1X{0cQlsZ+fEud+V?jCvb;h_s>vlV8ciW`|UQwahh6qWlv+n zgN}D2ROZ%g^@h=eH1-s7-tUbH(@4S?TsHbsARQ4nc!o&Hfe}ZefkUGpZTN_F#H2{v zWe#$HoaTwaq^u}*p0b6Vw#`ho6!v4+7rj(?1R*KOZa<2T{fb>~*C$qZ`+3{62UN^k z)o~%;y>hG-S@69}vsTJhDSeWFBUw8L-2O)~Es`g}%buTO4E)jYI*K`k1qB^^)rwg8n9ttu-y~e0 zy>p6+>>vBUuXN1JOoue0>+0gMXoC?=3hFF=nCDw70`z%YZ>X%&eNY|w&lU>)o`8O( iCl%l^O{slWBb8Vyv+eDCML>TEST>15-5-NSET-EXCLUSIVE-OR.TEST ;; ;; Modification: Changed calls to COPY (not a CML fn) to COPY-TREE. With ;; packages, COPY in LISP does not exist. ;; ;; Syntax: (NSET-EXCLUSIVE-OR LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-EXCLUSIVE-OR returns a list of elements that appear ;; in exactly one of LIST1 and LIST2. ;; This operation is not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set-exclusive-or operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' The result contains precisely ;; those elements of LIST1 and LIST2 that appear in no matching pair. ;; ;; NSET-EXCLUSIVE-OR is the destructive version of SET-EXCLUSIVE-OR. ;; Both lists may be destroyed in producing the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group ( test-nset-exclusive-or-group :before (progn (defmacro mac (x y) `(every #'(lambda (z) (member z ,y :test #'equal)) ,x)))) (DO-TEST "TEST NSET-EXCLUSIVE-OR0" (AND (MAC (NSET-EXCLUSIVE-OR '(A B C X C D) '(C C B A)) '(D X)) (MAC (NSET-EXCLUSIVE-OR '(D X D Z D F G F) '(C C B A)) '(A B C C F G F D Z D X D)) (MAC (NSET-EXCLUSIVE-OR '(Z A E D B E F) '(C C B A)) '(C C F E D E Z)) (MAC (NSET-EXCLUSIVE-OR '(F C Z E) '(D X F D D F G)) '(G D D X D E Z C)) (MAC (NSET-EXCLUSIVE-OR '(D Z E E) '(C F A E G C)) '(C G A F C Z D)) (MAC (NSET-EXCLUSIVE-OR '(Z A E D B E F) '(Y F B Z Y F X E)) '(X Y Y D A)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 2" (AND (MAC (NSET-EXCLUSIVE-OR '(Y F B Z Y F X E) '(D Z E E)) '(D X F Y B F Y)) (MAC (NSET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (MAC (NSET-EXCLUSIVE-OR '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(D B D B Y A F X G X F)) (MAC (NSET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(D X D Z D F G F)) '(F G F X E B Y B B B C)) (MAC (NSET-EXCLUSIVE-OR '(C C B A) '(A B C X C D)) '(D X)) (MAC (NSET-EXCLUSIVE-OR '(C F A E G C) '(Z C Y B E Z D B D)) '(D B D Z B Y Z G A F)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 3" (AND (MAC (NSET-EXCLUSIVE-OR '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(QIX QIX MEEF MEEF MEEF BAZ BAZ QIX BAR ZORK)) (MAC (NSET-EXCLUSIVE-OR '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(BAR CATOR)) (MAC (NSET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(MEEF MEEF MEEF ZORK PERTY MORY FOO)) (MAC (NSET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (MAC (NSET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (MAC (NSET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(CATOR CATOR BAZ QIX ZORK PERTY QIX)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 4" (AND (MAC (NSET-EXCLUSIVE-OR '(MEEF) '(PERTY QIX CATOR)) '(CATOR QIX PERTY MEEF)) (MAC (NSET-EXCLUSIVE-OR '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(QIX CATOR CATOR BAR BAR MORY)) (MAC (NSET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(MORY ZORK MORY PERTY BAR)) (MAC (NSET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(ZORK PERTY MORY FOO MEEF MEEF MEEF)) (MAC (NSET-EXCLUSIVE-OR '(BAR PERTY BAR) '(QIX FOO)) '(FOO QIX BAR PERTY BAR)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 5" (AND (MAC (NSET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 10 4 2 6 2 9 2 8)) (MAC (NSET-EXCLUSIVE-OR '(3 4) '(6 4 8 4 7 3 2 9)) '(9 2 7 8 6)) (MAC (NSET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(3 7 4 4 1 5)) (MAC (NSET-EXCLUSIVE-OR '(2 7 2) '(4)) '(4 2 7 2)) (MAC (NSET-EXCLUSIVE-OR '(7 3 4 10 8) '(2 9 4)) '(9 2 8 10 3 7)) (MAC (NSET-EXCLUSIVE-OR '(8 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 5 10 1 5 4 2 8)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 6" (AND (MAC (NSET-EXCLUSIVE-OR '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(2 6 2 9 2 8 10 7 7 10 4)) (MAC (NSET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 7 2)) '(7 8 8 6 4)) (MAC (NSET-EXCLUSIVE-OR '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(5 9 4 4)) (MAC (NSET-EXCLUSIVE-OR '(4) '(3 4)) '(3)) (MAC (NSET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(3 7 7 5 4)) (MAC (NSET-EXCLUSIVE-OR '(2 9 4) '(2 7 2)) '(7 4 9)))) (do-test "test nset-exclusive-or - with :TEST keyword" (and (progn (setq aa '(2 4 #\a #\z 8 10) aaa (copy-tree aa) bb '(#\Z 10.0 4 2) bbb (copy-tree bb) cc (nset-exclusive-or aa bb) dd (nset-exclusive-or aaa bbb :test #'equalp)) (and (mac cc '( 10.0 #\Z 10 8 #\z #\a)) (mac dd '(8 #\a)))) (progn (setq aa '("a" "b" "c" "d" "e" "F" "G" "I" "J") aaaa (copy-tree aa) aaa (copy-tree aa) bb '("A" "B" "c" "D" "E" "f" "G") bbbb (copy-tree bb) bbb (copy-tree bb) cc (nset-exclusive-or aa bb) dd (nset-exclusive-or aaa bbb :test #'string=) ee (nset-exclusive-or aaaa bbbb :test #'string-equal)) (and (mac cc '("G" "f" "E" "D" "c" "B" "A" "J" "I" "G" "F" "e" "d" "c" "b" "a")) (mac dd '("f" "E" "D" "B" "A" "J" "I" "F" "e" "d" "b" "a")) (mac ee '("J" "I")))))) (do-test "test nset-exclusive-or - with :TEST-NOT keyword" (and (progn (setq aa '((1 2 3) (a b) (x y z (g))) bb '(nil (nil nil nil) ((t t) (t)) (t nil (t . nil) t)) cc (nset-exclusive-or aa bb :test-not #'(lambda (x y) (/= (list-length x) (list-length y))))) (equal cc '(nil))) (progn (setq aa '("set" "difference" "exclusive" "not") bb '("south" "xoy") cc (nset-exclusive-or bb aa :test-not #'(lambda (a b) (/= (length a) (length b))))) (mac cc '("exclusive" "difference" "south"))))) (do-test "test nset-exclusive-or - with :KEY keyword" (progn (setq aa '((a 10) (b 20) (s 80) (t 100)) bb '((S 160) (x 100) (a 30) (y 45)) aaa (copy-tree aa) bbb (copy-tree bb) cc (nset-exclusive-or bb aa :key #'car) dd (nset-exclusive-or bbb aaa :key #'cadr)) (and (mac cc '((t 100) (b 20) (y 45) (x 100))) (mac dd '((s 80) (b 20) (a 10) (y 45) (a 30) (S 160)))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..20f593426e3654ecde7cc34f622e1c2fc119c4e2 GIT binary patch literal 5218 zcmcIoO>7&-6`t88DN=u?6v0+hSy}lvVYHGd*_N%qtyZhmk42Hxa#=}1(3U2tA6O<8 zinQYd6`TM;4k74BO5GjD4vM6gBn6TRXizt)1-O8L251ij0dW{1ca^9jPYb5Rhr{pH|JPS*U6p}o$ZzPZ`#+WH%$nMlQrx-gm{Te?B%@IXBiPo z9T*N6YET zq1E=)e9drB4MSkspg|;e(F$6pcD~AgLOr1dqd}NJ0FCz*LL4qC+1OQEU;P+QGzuk_@4TdSj7 zsaZH|SsQO2Z$XE9Hz*z1ffAmq-!I{)xfsK zkol;lb{y^U%t!mSJu^!)-dQh^YV4onn|*pH*guR#MIF+D{Q<*N`-XuN9E|uR537;f z&|J`*P`T=Sx@PG^s%cnJ6Dp6+OP4D$8L^B}iEh=fLOxb4SAjs%^>UfR0wq@ilWNQ> zSK^=#2DPZBA!`qg`jF>kHF6ykx>}!MnjupSMXhku^2zm}QSH-$lPc#&e2mJE@%cEb z0Y+43UZ|zVH`mfC*sIKe6|@@)qWnKF?ivW0qnd@}7cjHo>y+qP#1I}>HHvRT$|?^V z-#5%jH3B&b7|2}(8^O#r9+OM{Yv8gZ709nOml2ha}Zj*e>ZIahnOO73Uo+&d-u~_REQ@+bu4zt$d5Sjcph~CNf z1X7>Ft?3Hl>IRU!%MN4r3)Imyt=~lIJf(~dFtrf_ z_Xo;u|wGXg9DKMEV@rX)e+DlxLu@Q^XU@q zC8seK<$$FR0f7S%pvF!1GP`8d-rgwN$^cD|?zRx@I0cVnT1hv8rr(m9} zYvy@&G|BwunED*Lm|)%@>l|T6H83cDY3D0)sq?Ayr4*9?vGbMLqpmkxF4<7$@lnU>?EH7;Vi(ROVhCtU&4KqDCG^SR9Y zoLF0K9Py<2y34fCh0E_L_`$BbaJm7Ac;OUkoZr3Gn}E!^`Rd*Cl1E!NSVpPP%~N`u zr$PqOvjw~=WX15Dg>Dff#qNUUI|-fi8SYwcU+ROB0e&j_jX~2eBBDy%-Lj$!^bkz1=fZdS z@7qFAgzt=mq6mcZZs6nypDe+Y$6!Py=^i@_l2N{gLQEk zghVkOuJHxmBOE#8P^2R-%J*OS7NCFGv<3WV_;bDm=yiL=4N0OBo_L27eq0r9Pfb-J zR=5bKdLf&cO--ZzwOtFIz6t;ev9h<#aB2z{5x^p@7{`O^c>8oA5Q8o6WV`_{j2RE1OV*g|qaiKpjh;bk+GNncRrW7A2cv-_kHOC?G~ zx00Sx^gtG$wB$BFpyV}J75HNvP$KXqpwBX|vKr2){&VNeOYwFvN9PX=P`~1rCML>TEST>15-5-NUNION.TEST ;; ;; ;; Syntax: (NUNION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; UNION takes two lists and returns a new list containing ;; everything that is an element of either of the LISTS. ;; If there is a duplication between two lists, ;; only one of the duplicate instances will be in the result. ;; If either of the arguments has duplicate entries within it, ;; the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (UNION '(A B C) '(F A D)) ;; => (A B C F D) or (B C F A D) or (D F A B C) or ... ;; ;; (UNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) ;; => ((X 5) (Y 6) (Z 2)) or ((X 4) (Y 6) (Z 2)) or ... ;; ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the union operation may be ;; described as follows. For all possible ordered pairs consisting of one ;; element from LIST1 and one element from LIST2, the test is used ;; ;; to determine whether they ``match.'' For every matching pair, at least ;; one of the two elements of the pair will be in the result. Moreover, any ;; element from either list that matches no element of the other will appear ;; in the result. All this is very general, but probably not particularly ;; useful unless the test is an equivalence relation. ;; ;; The :TEST-NOT argument can be useful when the test function ;; is the logical negation of an equivalence test. A good example ;; of this is the function function MISMATCH, which is logically inverted ;; so that possibly useful information can be returned if the arguments do not ;; match. This additional ``useful information'' is discarded in the following ;; example; MISMATCH is used purely as a predicate. ;; ;; (UNION '(#(A B) #(5 0 6) #(F 3)) ;; '(#(5 0 6) (A B) #(G H)) ;; :TEST-NOT ;; #'MISMATCH) ;; => (#(A B) #(5 0 6) #(F 3) #(G H)) ;One possible result ;; => ((A B) #(F 3) #(5 0 6) #(G H)) ;Another possible result ;; ;; ;; Using :TEST-NOT #'MISMATCH differs from using ;; :TEST #'EQUALP, for example, because MISMATCH ;; will determine that #(A B) and (A B) are the same, ;; while function EQUALP would regard them as not the same. ;; ;; NUNION is the destructive version of UNION. ;; It performs the same operation but may destroy the argument lists, ;; using their cells to construct the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test nunion - test cases copied from page 276 and page 277 of CLtL" (and (let (( a (NUNION '(A B C) '(F A D)) )) (every #'(lambda (x) (member x a :test #'eq)) '(A B C F D)) ) (let (( a (NUNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) )) (and (member 'X a :test #'eq :key #'car) (every #'(lambda (x) (member x a :test #'equal)) '((Y 6) (Z 2))) ) ) ) ) (do-test "test nunion 1" (and (progn (setq a '(1 2 3 4) b '(5 6 7 8 9) ab (nunion a b)) (every #'(lambda (x) (member x ab)) '(1 2 3 4 5 6 7 8 9)) ) (progn (setq a '( (1 2) "one" "two" ( 1 . 2)) b '( "three" ( 3 4) "four" (3 . 4)) ab (nunion a b)) (every #'(lambda (x) (member x ab :test #'equal)) '("three" ( 3 4) "four" (3 . 4) (1 2) "one" "two" ( 1 . 2))) ) (prog2 (setq a '(1 2) b '(1 2) c (nunion a b)) (every #'(lambda (x) (member x c :test #'eq)) '(2 1)) ) (prog2 (setq aa '("a" "b" "c" "d" "e" "f") bb '("d" "e" "f" "g" "h" "i") cc (nunion aa bb)) (every #'(lambda (x) (member x cc :test #'equal)) '("d" "e" "f" "g" "h" "i" "a" "b" "c")) ) (prog2 (setq aa '((1 2 3 (4 5) (6 7)) 8 9 10 11) bb '(#\a "string" (1 2 3 (4 5) (6 7)) 10 #\v) cc (nunion aa bb)) (every #'(lambda (x) (member x cc :test #'equal)) '((1 2 3 (4 5) (6 7)) 8 9 10 11 #\a #\v "string")) ) ) ) (do-test "test nunion 2" (and (progn (setq a '((a b) (x y) (o p)) b '((1 2) (4 y) (7 p)) cc (nunion a b :test #'eq :key #'cadr)) (and (member 'p cc :key #'cadr) (member 'y cc :key #'cadr) (every #'(lambda (x) (member x cc :test #'equal)) '((a b) (1 2))) ) ) (progn (setq a '((poco a poco rit end) (sound little)) b '((rit little by little ) (by degrees) (end)) cc (nunion a b :test #'equal :key #'last)) (and (member '(little) cc :test #'equal :key #'last) (member '(end) cc :test #'equal :key #'last) (every #'(lambda (x) (member x cc :test #'equal)) '((by degrees))) ) ) ) ) (do-test "test nunion 3" (and (progn (setq aa '((1 #\3 4) (5 #\7) (9 #\1)) bb '((2 #\7 9) (8 #\9 20) (99 #\8)) cc (nunion aa bb :test-not #'char/= :key #'second)) (and (member-if #'(lambda (x) (char= x #\7)) cc :key #'second) (every #'(lambda (x) (member x cc :test #'equal)) '((1 #\3 4) (9 #\1) (8 #\9 20) (99 #\8))) ) ) (progn (setq aa '(("blue" ("green")) ("yellow" ("red")) ("purple" ("blue"))) bb '(("blue" ("Green")) ("yellow" ("blue")) ("yellow" ("Red"))) cc (nunion aa bb :test-not #'(lambda (x y) (not (string= x y))) :key #'caadr)) (and (member-if-not #'(lambda (x) (not (string= x "blue"))) cc :key #'caadr) (every #'(lambda (x) (member x cc :test #'equal)) '( ("blue" ("green")) ("yellow" ("red")) ("blue" ("Green")) ("yellow" ("Red"))) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f5e38556847de7b96907c54687a7b4938a8f4949 GIT binary patch literal 11673 zcmds7du$u^9lxg^Ax_gKEiCOi)7OfL-K1~YsP)CU#3qg}wVk@@Iv_X>4zx*>rsc8G z6~s2QS|!0>4B;P9c*d?7dh^}#R1 zth9N3+=z8Xwl`O0Dq8ZRg}$*ue=vKfaInAc+QwjWQ?RS=+F##KJF0wUR2?x0Px` zSu>Ljw~i?ORKML@L}3f*BpAr1;9S;Ow$ps%zd9-W1N5*>GE;z1>WkshBANSM@ha zlK1e!S_QfKaq)Pk{N#}I(9@ktZbidF*>i;?VM9QYCgBnO@M-WkJS@7=yHqYdd1=k0 zRRi#y@#L*m%}*t1y!chCrc;rja!0C~N~xyuCghDXn4G+Rhui`rmtRY3 zQa&`9Tbm0_5zRMJeXbD`aeZzr_I>fLT!>1{nU7K?{*d7_=8H_`8gDB;62u8|k@;pl zT0E1YKH!MT%kNyGmL;z8fGSQU@+V~tXkFX@tN&!NR#Iy1J4(w!F)P)Uz=b>gf)*Tj{P$NXUvjdvw+ciE4GB2&ju-S5Xr((`hRmwtBMN zJ=u_22Lq}@MyfYV^*D)I4|R%RoZPzLrbAtfm94F!PF;deu^2p^i%)HBqRuYWHqY4D zEc8l}&~P_X#7)Tv(ALb|MiN0DfCqUtvIs4hrhZCqF(YF#H=-Jw>p-tntIgeJx;LBw zMJ7$G^`bD-cR*0>d0s5V;xVxdi^Jm6SoDkKSY)^ea%DXs{r5CL{{;=u@258XTiiCp zZF{-x0&ZKwZHpN#Vk8sN{!2)Eo6+AGy~gObjDE)GSw=Qd&~73MT87)Yxosz-7Dg8` zTFdBMMl6G-GLooG{RbiSEk@501@&Q~pkB{y*Kyk*qX9-ejM9t@MmrdV8HE^qiqR56 z%3DN1d6g(A-=Q|;0dAXMbd1rL7=4k^Rg8*^a*VQ!VvM4UmM{f{D9Eo+oBR^B$xkzS ziqS)i9%OU}quUtWz~~601B|X@6eS9BBT8t_@F~e z%A#ILu^M|-i8WB@&(IkCN7Pw=kPDl-=oYuNbLAE)v}>tS8)4K(h5Bu(RPSc=bt;r! zQl;`7Bc>q#n=0kMQ>FYzF3#u5^BDQX%F7^QEG4Ef1DJ5W>d7Q_n_)<79cinlTht}Q zil|uGELN_Cu7SceBYi{tsCQAf8Y)zJY7lEdMCto*^ImF~yoZLa8XCTO2;t}K(&Dkg z!Li`M!dSR}aA2S?S{Q;u=SA3q!EFvSYUbvM&QZhigqqKu-+qfh$a!SClsGw7%+|4f;}x!2lQISI;2-+ z-zn8aag~SV4*p=hgCkO{WS1KD_Z_&rzYk@fnf{@-Oz9tGE6ID61(@@@%&t~5ji=iM zGkjg~lV|VhF_Ip!T2@FUb8si(%$S6nDZrUG3jD|)kDEO(KP*Q{Ba;O_VJ6S}Fw;3W zlL6O>Q_rT9Wm7=5J#h6Z9+WR>raH25MdZuVzD=fbTtI|HM644{mF8x%R@&F|mpSbV zhT18jXd@L26BBK78qZM=%Ji~*57-sVxjdFOjjS1-vBV}5Su<@UGol*1L0;L_V`WVW zHP3S*gj4)vo-o*ojmJeJ7GDNNzzube7t!^^yaEa?>BYkS{lh@tpR`gPVIymGi8|~v za%LP#bXSXAuy;zA9Yz&LP7<8}4#=>V0j;X&hT8GLqs8%J?ciyc7HmmVSumB~z^Q6s zyLT$@pXDLWG+@CBeQlemFL4A_v<|CFp62x%Hg4K%mje0XaDJF>cB%T{*l6F?KQKCc zAUM)@MIpF;%hurVKrogZ!zEdNg{9cz&}o5dx(pq*#$2bOaAUeCTqmv2@4jybiAk4NVnoVC3idnEap&|;-T!2 z=qUQ(+3LTN)jt5aXZrp=h%0_@GY-3)^@>ZZ;#IH))=pLNYxwArmn)i|Sgx@r{EF@a zx?Ycp^a8MMY97VsL*Q{ok+O!gwf}(WRTNVD7px-m@J}FE8!dj4wYge!`yrKjL|PTA zDcNbT2u%}G`;$H4^JqTJ3tC3{e{e@m)vvLnzdC7J?WGF+YA?7$SMz~%q~d2lP@k^& z6_1RLr9A~$)8&Bf^#%|>?hXTb0On^7?wb`8+U*n*+Oc_JViPh}qL|Q&XbzHiE^xsusYA(3;#KtN8+|mk6(NLLoTiGt1l|irI!}*3JkA*h5Y8 z8lOA#6Ic)wtM55^L46kppYe2{zB%2g)HkM!tG@1zxE{p=fk^J9zA!5))MqFv z)Tic&ijAnL$0;h*!=ND8imJO3eEL$`EjZ+0hf#1EY=M=K4n}&nna;x5OhBW&1A7d) zBb>?<=)RMm$+nk6>Lu7h_wB%()@7v~mUbfEYo$BOENSHsbyM<6nw=y$eEej|Ssfk3RGjY2)U+W~&wUce?8VOLImE3H zuX2tGQQO@SRVK0l-Usl0Hz;z~+cV}fJ+ z${X`!qz#}R<#ozP%6%VV`3f_jewBM2*Dj|7YG;pOTT})~rQt9z6x$tDu*+~hVP9Y_ z%HDx?QcCuOx58z(Gk4=SWM<1k;E0~qIOG~&C`E!b&W$T_+lmQPDy*ypkbR;r~^X%sne zcLd`^vya4R`9xyCu9+tzf8XdPyK!Q7`RuHb&oQ4x;mza@sBaTdtb5iSaa5Rphlrs#^5aOB-;GA_{V3Kw3U9{YISQ=d z22Oq$*f`_yD&G%#U=Tk77pehX$%+_K`zERgX*ak>XQ&cW(BjcW}vT zqS(ZUg)ay&NP5d1p%hRkZF!~FXD0>echfa4z3LVd5S6G==|z+s12qPB3RJ9p9@&UN zpn~ZUKj#h`__YS|B{A~E^t>cJHm6Y@afcBdglz@!fgNJzff>xeesr#MCf(}}J3e3s z5+*Q&$rF+&F$J%)D>JtQ`^TBtUAoyFhR|sv(&+T)%Zt!HyA;{hYQoP|O#a0#{Ro*p z0nqnf=fm%jO!-rA4`%S>e@y57oCML>TEST>15-5-SET-DIFFERENCE.TEST ;; ;; ;; Syntax: (SET-DIFFERENCE LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-DIFFERENCE returns a list of elements of LIST1 ;; that do not appear in LIST2. This operation is ;; not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set difference operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' An element of LIST1 ;; appears in the result if and only if it does not match any element ;; of LIST2. This is very general and permits interesting applications. ;; For example, one can remove from a list of strings all those strings ;; containing one of a given list characters: ;; ;; ;; REMOVE ALL FLAVOR NAMES THAT CONTAIN "C" OR "W". ;; (SET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" ;; "LEMON" "PISTACHIO" "RHUBARB") ;; '(#\C #\W) ;; :TEST ;; #'(LAMBDA (S C) (FIND C S))) ;; ;; => ("BANANA" "RHUBARB" "LEMON") ;One possible ordering. ;; ;; ;; NSET-DIFFERENCE is the destructive version of SET-DIFFERENCE. ;; This operation may destroy LIST1. ;; ;; Compatibility note: An approximately equivalent Interlisp function ;; is LDIFFERENCE. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group ( test-set-exclusive-or-group :before (progn (defmacro mac (x y) `(every #'(lambda (z) (member z ,y :test #'equal)) ,x)))) (DO-TEST "SET-DIFFERENCE TEST 1" (and (mac (SET-DIFFERENCE '(A B C X C D) '(C C B A)) '(D X)) (mac (SET-DIFFERENCE '(D X D Z D F G F) '(C C B A)) '(F G F D Z D X D)) (mac (SET-DIFFERENCE '(Z A E D B E F) '(C C B A)) '(F E D E Z)) (mac (SET-DIFFERENCE '(F C Z E) '(D X F D D F G)) '(E Z C)) (mac (SET-DIFFERENCE '(D Z E E) '(C F A E G C)) '(Z D)) (mac (SET-DIFFERENCE '(Z A E D B E F) '(Y F B Z Y F X E)) '(D A)))) (DO-TEST "SET-DIFFERENCE TEST 2" (and (mac (SET-DIFFERENCE '(Y F B Z Y F X E) '(D Z E E)) '(X F Y B F Y)) (mac (SET-DIFFERENCE '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (mac (SET-DIFFERENCE '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(A F X G X F)) (mac (SET-DIFFERENCE '(C B Z B B D Y B E) '(D X D Z D F G F)) '(E B Y B B B C)) (mac (SET-DIFFERENCE '(C C B A) '(A B C X C D)) NIL) (mac (SET-DIFFERENCE '(C F A E G C) '(Z C Y B E Z D B D)) '(G A F)))) (DO-TEST "SET-DIFFERENCE TEST 3" (and (mac (SET-DIFFERENCE '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK)) (mac (SET-DIFFERENCE '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(CATOR)) (mac (SET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK PERTY MORY FOO)) (mac (SET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (mac (SET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (mac (SET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(BAZ QIX ZORK PERTY QIX)))) (DO-TEST "SET-DIFFERENCE TEST 4" (and (mac (SET-DIFFERENCE '(MEEF) '(QIX FOO)) '(MEEF)) (mac (SET-DIFFERENCE '(MEEF) '(PERTY QIX CATOR)) '(MEEF)) (mac (SET-DIFFERENCE '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(CATOR CATOR BAR BAR MORY)) (mac (SET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(BAR)) (mac (SET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(MEEF MEEF MEEF)) (mac (SET-DIFFERENCE '(BAR PERTY BAR) '(QIX FOO)) '(BAR PERTY BAR)))) (DO-TEST "SET-DIFFERENCE TEST 5" (and (mac (SET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(2 6 2 9 2 8)) (mac (SET-DIFFERENCE '(3 4) '(6 4 8 4 7 3 2 9)) NIL) (mac (SET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(1 5)) (mac (SET-DIFFERENCE '(2 7 2) '(4)) '(2 7 2)) (mac (SET-DIFFERENCE '(7 3 4 10 8) '(2 9 4)) '(8 10 3 7)) (mac (SET-DIFFERENCE '(8 2) '(4 5 1 10 5 7 7 10)) '(2 8)))) (DO-TEST "SET-DIFFERENCE TEST 6" (and (mac (SET-DIFFERENCE '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(10 7 7 10 4)) (mac (SET-DIFFERENCE '(4 6 2 8 8) '(2 7 2)) '(8 8 6 4)) (mac (SET-DIFFERENCE '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(9 4 4)) (mac (SET-DIFFERENCE '(4) '(3 4)) NIL) (mac (SET-DIFFERENCE '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(4)) (mac (SET-DIFFERENCE '(2 9 4) '(2 7 2)) '(4 9)))) (do-test "test set-difference - test case copied from page 278 of CLtL" (mac (SET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" "LEMON" "PISTACHIO" "RHUBARB") '(#\C #\W) :TEST #'(LAMBDA (S C) (FIND C S))) '( "RHUBARB" "LEMON" "BANANA") ) ) (do-test "test set-difference 8" (and (prog2 (setq aa '("STRAWBERRY" "CHOCOLATE" "BANANA" ) bb '("123456" "chocochoco" "strawstrawst") cc (set-difference aa bb :test-not #'(lambda (x y) (/= (length x) (length y))))) (and (mac cc '("CHOCOLATE")) (equal aa '("STRAWBERRY" "CHOCOLATE" "BANANA" )) (equal bb '("123456" "chocochoco" "strawstrawst")) ) ) (prog2 (setq aa '((1 2) "hello" long-atom) bb '(2 3 4 5 6 7) cc (set-difference aa bb :test #'(lambda (x y) (numberp y))) dd (set-difference aa bb :test-not #'(lambda (x y) (not (numberp x))))) (and (eq cc nil) (mac dd '(long-atom "hello" (1 2))) (equal aa '((1 2) "hello" long-atom)) (equal bb '(2 3 4 5 6 7)) ) ) ) ) (do-test "test set-difference 9" (and (progn (setq aa '( (1 () (2 3 4 (5))) (a b c d (e f g)) (a z x (8 9) d (l o n e y))) bb '( (() () () () (w x y z)) ((10 20 30)) (n i l (n i l))) cc (set-difference aa bb :test #'(lambda (x y) (= (length x) (length y))) :key #'(lambda(x) (car (last x))) )) (and (mac cc '((a z x (8 9) d (l o n e y)))) (equal aa '( (1 () (2 3 4 (5))) (a b c d (e f g)) (a z x (8 9) d (l o n e y)))) (equal bb '( (() () () () (w x y z)) ((10 20 30)) (n i l (n i l)))) ) ) ) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cf4cb82dcbb19a4475089b508c449435734cd788 GIT binary patch literal 13001 zcmds84RBml6@LG_NwaCTKTsmJ+nD~4c0-f4Oi4@4?&jsENp{2TrrTt&l5RF6v`uQ7 z{;H+vFvu`#A&uaB2--nJ7*H`*2DD6C!XQFr5E;c8M$zdggWz-=R7A0!pZ7K|KZQd3 z#(`Q83^ zUCJtPZEsSE3CkRD? zEEq?!MP*4nkqp*0H0i-;s97&FhK#HiGzqpQ^th4rR|W?9b_BO&c4xMsGTV0wq97P| zWWBYm(MYl(7Bz;&gJOYkd)C(w4Yq({p*mfVyw)r@yJ%$RR;&)L4kq+uP=~o&6Ac^n zU@R^Gu1gOIg7STF-H)%sS** zAa+0T`NGjyA&_T=nr@F3jtRn0_g7+tjgknALys1xmg8{f$D#norprfv=(*1!O&qkP zd9l^LU_AVdY`1AFt+v!OZJ}w}mQB+(cWT?gZu{SP>ot${vgfiDL)x;Tl(MzTv$?SR zm}?~mZLNHtB(2`EwVE-FRxWwlMf5dg%*J0Z4gQa71gWO2RsJVPEA4q(t3uQ&T{4;~ zNiU{dAzeC}DornihEyr!iS&xm)Z)}q$er*9I|d|~bR~8!J~gs1Rhn9QYGfWxky-)F zCeR;^3>8)>8X)LIf0gJl*qDIq(Zpz;VOV@ z23$V4^5F8qrNO1bX~$m{2_+--!ML7mjl*drLdP8~(UwT+&5{HhbND`o((lQ6beCg4pzg|I@k2cm%x#! zuuPA~WAR|DHQCadER!zaO{`_^)?f{RO-b2d$_$xI1Esb`2%e@>k0C>P)1#`~D%2veI# zkXl26)Y;6*kd(7TDgPl(JUj#dP#zE4fj=XADci~ z%+y@&o5hq!l>A?!*Bsvrs7P6m|D+Nkf}1JE@O(# zD!oZ_O0UqI(s!v(x}P|uVW#e2>L#YX#MD-%x|vEbm1HWyR5eqVump)Dh`*#h@dfG= zpJeJMOg+TZ15Dk?6tAB+$kYMu+s@RDOjVNvaXCp4{!M+tJJcuqnW@uE{fem?8FDc+S$I7_Jz-o|nueSUd_mN+eVhN8)?HA~))7SicuK4W% zrbcry7GWN_l8Zcie51#{Xbkg!_O!VSi><`0Z6Pi#!9@{FT98P_A^wBw1740Q!ft}diPNmHZJ&Qv26@>i)*zL}|A zR7k&|M(Js$eoTe69etQD+_$68xVe}lQW+FVj$ zE?Ek!zRcbo9lf2nmZpCZG{{sdHY-3I;Q_dLRU_-!)w{K~Z%;3h@R(aRkl8s9*qIp! zX7;AH?b_M1I}?N#0D)j&PtQPipb8c$ur;%9PhWp0jPSf?WEUiHM9G0rNua9(UJ!H! zdV2Zk9@`EqLbhj&yM)=*cx-@eF}L*=2}ZVfTgUb-ogFx4@-_h6B5eb(6Bt>sU7CsO z(X2Oz^>~3n`((-6#P?U^e%^1cFP)wNq7OM&y*c_`08<@|kwweAQRL$!7cwYwy zg`)!EJbrO-npK3)Tx$V?y-XVHL|N+*jTuJih;)&mc&I6179bm#?%LK^QYRntbeStr z!WJW2KK=UJ%Wub=(+4)2t8wsW+_9Z(Wb<;aXk>kzJzZUy{!DK=V`No$FE!9j1}p&S zGppge6@u&RPdg+qVx} z-@?_%$`C1&KsnLMy?uCu(SGNSZN!5F@MjmO`zFx6jdY*U)Bvy2Yy$vt;TFpX$3WeK z#;|TAZZ2O220 zpu|qp3^l}w>%a}vmyO{(sCU4H1Ca+cL``vG6wm+)nL^gsSa^?MqS)cO2gD^&x%zl;}{C6dh`dk-c>C{vV)txC#e0 zQ6#94 zcLb{*FX%_QL$>#NRVh!>MD#P|exMaq^r;>Xy0CK89RxEZ4P<(KAcb+-LK6e`M9lWX8*6#Y?d};x)9M z>><&Gc9_7K(#jW#=8jlJfwX`^<##8>i2RRaGsN| zZGguZtklM0bhMK$k)P~Q! zc|=-l090v?#cg=)NVmu0jTT(zG;ORD9A#054faHBG#xW`QoWNV)%99yk}hiHJM(SC z8EW0Jf`_D~>CT#Op*kz<#L`6;sj?MuGV^c-J7EY-#S`Llrwr+n?KzDZh#hV4OMqR9$H3XqyZl|6uqY#2(5QVRZimUmU~EX${o-?G8CJL@6J_nMwc^Tu##y~a{koZI*W5_;W=|_C1wmC?Nuv>bM>*a$3Y^tQe%~Dh*jZ1SF#>lV9Q_%J z1?(hJ!jRR5IL4@jEjxw{-?W_@p)&V+OTCl0gf#X9a^CHZ3NuK;1Y8#S6CfQC*my=s z$-_BEqk*I2AT9WaHMgWl+-3}Oe2nqLu%xUgcAl_=jakb~Ybgw2*DY=;oI^-TvfGd2 zW4~gT+y9{z-hJL{+7BugRd-*=XS4#dDi1!NY35ql4ALhKcpGa4fz$serbY53c+~T9 zjDbJeUPmzpG^h2lC&h2olXrb7G(Dz2hbD8O6F z^HEPYV;ylIKpkl>=euk$3{v4ucMPF|3BuMwoHVOZc>&&ZYF1#ON_JQf7!Di}GqUjN z`>(O^iaU^b?KnttnRy(qo$E*yczHT`sZk|zO6zW=9aQL9TOn%WoNi5r&L}+XjzW~M zEyLQ#*fE)6!*dF!1Sr6J+3B_z;n;b*)1&UF;#eDNOJq~BBTrC=)(773POAt!rhV9L zOt{A#l?ohtJ^Bvs^bt~TKAqC5jqT5A1r2!8ToWM|u?9^Kdwk42mHXi`w;@Mi8et9zhOB(#S1P+o`m}~Q`)44DtC==7Za5u74ojvCML>TEST>15-5-SET-EXCLUSIVE-OR.TEST ;; ;; ;; Syntax: (SET-EXCLUSIVE-OR LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-EXCLUSIVE-OR returns a list of elements that appear ;; in exactly one of LIST1 and LIST2. ;; This operation is not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set-exclusive-or operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' The result contains precisely ;; those elements of LIST1 and LIST2 that appear in no matching pair. ;; ;; NSET-EXCLUSIVE-OR is the destructive version of SET-EXCLUSIVE-OR. ;; Both lists may be destroyed in producing the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group ( test-set-exclusive-or-group :before (progn (defmacro mac (x y) `(every #'(lambda (z) (member z ,y :test #'equal)) ,x)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 1" (AND (mac (SET-EXCLUSIVE-OR '(A B C X C D) '(C C B A)) '(D X)) (mac (SET-EXCLUSIVE-OR '(D X D Z D F G F) '(C C B A)) '(A B C C F G F D Z D X D)) (mac (SET-EXCLUSIVE-OR '(Z A E D B E F) '(C C B A)) '(C C F E D E Z)) (mac (SET-EXCLUSIVE-OR '(F C Z E) '(D X F D D F G)) '(G D D X D E Z C)) (mac (SET-EXCLUSIVE-OR '(D Z E E) '(C F A E G C)) '(C G A F C Z D)) (mac (SET-EXCLUSIVE-OR '(Z A E D B E F) '(Y F B Z Y F X E)) '(X Y Y D A)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 2" (AND (mac (SET-EXCLUSIVE-OR '(Y F B Z Y F X E) '(D Z E E)) '(D X F Y B F Y)) (mac (SET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (mac (SET-EXCLUSIVE-OR '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(D B D B Y A F X G X F)) (mac (SET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(D X D Z D F G F)) '(F G F X E B Y B B B C)) (mac (SET-EXCLUSIVE-OR '(C C B A) '(A B C X C D)) '(D X)) (mac (SET-EXCLUSIVE-OR '(C F A E G C) '(Z C Y B E Z D B D)) '(D B D Z B Y Z G A F)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 3" (AND (mac (SET-EXCLUSIVE-OR '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(QIX QIX MEEF MEEF MEEF BAZ BAZ QIX BAR ZORK)) (mac (SET-EXCLUSIVE-OR '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(BAR CATOR)) (mac (SET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(MEEF MEEF MEEF ZORK PERTY MORY FOO)) (mac (SET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (mac (SET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (mac (SET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(CATOR CATOR BAZ QIX ZORK PERTY QIX)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 4" (AND (mac (SET-EXCLUSIVE-OR '(MEEF) '(PERTY QIX CATOR)) '(CATOR QIX PERTY MEEF)) (mac (SET-EXCLUSIVE-OR '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(QIX CATOR CATOR BAR BAR MORY)) (mac (SET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(MORY ZORK MORY PERTY BAR)) (mac (SET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(ZORK PERTY MORY FOO MEEF MEEF MEEF)) (mac (SET-EXCLUSIVE-OR '(BAR PERTY BAR) '(QIX FOO)) '(FOO QIX BAR PERTY BAR)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 5" (AND (mac (SET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 10 4 2 6 2 9 2 8)) (mac (SET-EXCLUSIVE-OR '(3 4) '(6 4 8 4 7 3 2 9)) '(9 2 7 8 6)) (mac (SET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(3 7 4 4 1 5)) (mac (SET-EXCLUSIVE-OR '(2 7 2) '(4)) '(4 2 7 2)) (mac (SET-EXCLUSIVE-OR '(7 3 4 10 8) '(2 9 4)) '(9 2 8 10 3 7)) (mac (SET-EXCLUSIVE-OR '(8 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 5 10 1 5 4 2 8)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 6" (AND (mac (SET-EXCLUSIVE-OR '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(2 6 2 9 2 8 10 7 7 10 4)) (mac (SET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 7 2)) '(7 8 8 6 4)) (mac (SET-EXCLUSIVE-OR '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(5 9 4 4)) (mac (SET-EXCLUSIVE-OR '(4) '(3 4)) '(3)) (mac (SET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(3 7 7 5 4)) (mac (SET-EXCLUSIVE-OR '(2 9 4) '(2 7 2)) '(7 4 9)))) (do-test "test set-exclusive-or - with :TEST keyword" (and (progn (setq aa '(2 4 #\a #\z 8 10) aaa aa bb '(#\Z 10.0 4 2) bbb bb cc (set-exclusive-or aa bb) dd (set-exclusive-or aaa bbb :test #'equalp)) (and (equal aa aaa) (equal bb bbb) (mac cc '( 10.0 #\Z 10 8 #\z #\a)) (mac dd '(8 #\a)))) (progn (setq aa '("a" "b" "c" "d" "e" "F" "G" "I" "J") aaa aa bb '("A" "B" "c" "D" "E" "f" "G") bbb bb cc (set-exclusive-or aa bb) dd (set-exclusive-or aaa bbb :test #'string=) ee (set-exclusive-or aaa bbb :test #'string-equal)) (and (equal aaa aa) (equal bbb bb) (mac cc '("G" "f" "E" "D" "c" "B" "A" "J" "I" "G" "F" "e" "d" "c" "b" "a")) (mac dd '("f" "E" "D" "B" "A" "J" "I" "F" "e" "d" "b" "a")) (mac ee '("J" "I")))))) (do-test "test set-exclusive-or - with :TEST-NOT keyword" (and (progn (setq aa '( (1 2 3) (a b) (x y z (g)) ) aaa aa bb '( () ( () () () ) ((t t) (t)) (t nil (t . nil) t) ) bbb bb cc (set-exclusive-or aa bb :test-not #'(lambda (x y) (/= (list-length x) (list-length y))) )) (and (equal aaa aa) (equal bbb bb) (mac cc '( () ) ))) (progn (setq aa '("set" "difference" "exclusive" "not") aaa aa bb '("south" "xoy" ) bbb bb cc (set-exclusive-or bb aa :test-not #'(lambda (a b) (/= (length a) (length b))))) (and (equal aaa aa) (equal bbb bb) (mac cc '("exclusive" "difference" "south")))))) (do-test "test set-exclusive-or - with :KEY keyword" (progn (setq aa '((a 10) (b 20) (s 80) (t 100)) bb '((S 160) (x 100) (a 30) (y 45)) cc (set-exclusive-or bb aa :key #'car) dd (set-exclusive-or bb aa :key #'cadr)) (and (mac cc '((t 100) (b 20) (y 45) (x 100))) (mac dd '((s 80) (b 20) (a 10) (y 45) (a 30) (S 160)))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..26fff79b2cd371672719a02d502378c8b921bc2d GIT binary patch literal 4441 zcmb_feQaA-6~FgBeCwsOwB zeyNv4+dA6z`MmSH=lh;}?rVX#hXVa-AaiyqJ(0|+nVHjsdQI zB@mA2U+dKZC-)s|t1`+~MzhIyE}2lHGs)>hd~UDW)~W{Mb86esBS-eC2iiLh9_?sr z+gH`C8U50htudHPOxikaWjd`L?V!@SujoTp$5JE=D4J4I>)DVSOOJ;?c<&iPQqA_#j)}x7bEQmdK4t&C2J%}M+*@htwd)~x zzg;-_jnM0a6jGN$Cm01!g_Wkk9kwpgYC>+LM|X;Pm13mN+cCOrNw5X~pq?Q9>g(>gY`SeEzx|CXJ+_2FLshV^RVIJ!RbB8w&4t4e6>Gt(%p{{;C z;_K`KB-CSgSta+d3V7V`IN@=?7^(FJv}mB$7ty1!2#kS%m?JJ@*of*uM%PP3!(Lvk zRB?~88AiuuuO5knBffAfIuMI`l`Wu9?bSlVK7kuv4l|_o(ArT{r4Yg$IDq!zIJpFt zT;1VFP>Uk_6d0+yn@B)2bZL%PCAlWaw z>yY4KsrQiNc1dot`7HNyx8K%L&^43-Rm)y@m*lk23aJEo|yw01S=8dzwX`DA5gAR7$ zt=zVHD`QFfKu%e(O!v&>_+(~w64?uuxjC1d&Z*Ngr>B#-DfIxN=PmQWD5ASBXuH+1 zIDCO5)bynMd_e3%3ySqvmx;$e!C)Fa`A!Y7%1-UnKE~sdXX4pR2I`cV&Slf1DfFpAJo)qaY(A5pMShD_bY46@Psl|- zn7QbG34a6&JPK?At5k8qD|`R$>${LVQxN=KzC-%g3;_ZrfQEB;*R}!A?Em;SF#j>~ipC>Ek)v zjba59h6Z>Gl1@o9AVs_pXqN;GNgm@Z{81jWif)C`N+_1Y$!rV5Qe;SyL6Ce54GaJe zrizq*kw3vlFtx7>w+=oiZBaf18&1&>*n?LdM@d@?H8Mg&0W%EXyhhhQsPQ5pvKAio+5bGd=7sKg+^K89EUP8eLM5UdN~k--*W z%mMhz|8q|8BPBOK!z!DeY%&+mCgPJhm<^kzGNTzat|GBaS3D6vlg^;ipMq@uZ2rsn zIplr_A#By~3+qR{h29!XDWq#sA5{eSkJ7p$1Cihnq$?N-Om`z33(0f9!rh|1oxzyV z2S)~_zKbnm(s6jw@Z{i0BK`_)#*_Z>Ki`&LZTCL0?Kr-w@3*?7KtX}mpaB5JgXu0<*u!s)4Aq)ax40I(L@;Bb`I*Q~%nc3<@S z3HcCp@*b#*@lO6`6+Pk>@YIPLL2)>Rwo6r}9tb=WrYW1wM%PW9LmmhDK=uZgnR% zEq;<5m9w|R9g(ez3kP93f5w(-=Pd_7NzP{&$%FeKc|HhZo6XN}hjPMbcEAop&FBY% MCNE-S@87xeKjO0z?*IS* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST new file mode 100644 index 00000000..e5dc5abc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBSETP ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 279 ;; ;; Created By: Kelly Roach , KARIN SYE ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-SUBSETP.TEST ;; ;; ;; Syntax: (SUBSETP LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SUBSETP is a predicate that is true if every element of LIST1 ;; appears in (``matches'' some element of) LIST2, and false otherwise. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: T or NIL ;; (do-test "test subsetp 0" (and (subsetp '(1 2) '(1 2 3 4)) (subsetp () '( () ()) ) (subsetp '(a) '(z x y b a)) (subsetp (list 'name1) '(name9 (name8) name4 name1 name3)) (subsetp (list (1+ 99)) '(100.0 88 99 1 100)) (subsetp '(#\q #\h #\a) '(#\h #\a #\p #\q #\y)))) (do-test "test subsetp - with :TEST keyword" (and (subsetp '("str1" "str2" ) '(str5 "str6" "str3" "str4" "str7" "str1" "str9" "str2") :test #'string=) (subsetp `((1 . 2) (())) '(a b (1 . 2) t (()) c d e ()) :test #'equal) (subsetp '(1.0 2.0 3.0 4.0) '(2.0 10 20 1.0 3 4 5 3.0 6 4.0) :test #'=) (subsetp '(#3r10 #5r10 ) '(3.0 #c(1 -1) 5 10 12 #c(1 2) #c(-1 -1)) :test #'=) (subsetp '(#c(1 -1) #c(-1 -1)) '(#c(1 -1) 5 10 12 #c(1 2) #c(-1 -1)) :test #'equal) (subsetp '(a b c d) '(((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) :test #'rassoc))) (do-test "test subsetp - with :TEST-NOT keyword" (and (subsetp '(2 4 6) '(a b c d) :test-not #'(lambda (x y) (oddp x))) (subsetp '("k" "i" "t" "e") '(sound of music) :test-not #'(lambda (x y) (listp y))) (subsetp '(#\m #\x #\y) '("retardanto" "poco a poco" "adagio") :test-not #'(lambda (x y) (find x y))) (subsetp '(#c(1 9) #c(-1 2) #c(0 3)) '(2 ) :test-not #'(lambda (x y) (eq (type-of x) (type-of y)) )) (subsetp '(a b c d) '(((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) :test-not #'assoc))) (do-test "test subsetp - with :KEY keyword" (and (subsetp '((8 2) (2 4) (4 6)) '((2 3) (4 5) (6 7) (8 9)) :key #'first) (subsetp '( (a ((#\A) 1) 1) (b ((#\B) 2) 2) (c (( #\C) 3) 3)) '(( 1 ((#\A) 1) 1) (b ((#\B) 2) 2) (c (( #\C) 3) 3)) :test #'equalp :key #'caaadr) (subsetp '( (a b c (d)) (1 2 3 (4 5)) (w x y ((z))) ) '( (c b a (d) s z b c) (3 2 1 9 (4 5) 2 3) (y x w s p ((z)) x y)) :test #'(lambda (x y) (member (car x) y :test #'equal)) :key #'(lambda (x) (nthcdr 3 x)) ))) (do-test "test subsetp 2" (not (or (subsetp '(2 3) '(1 3 5)) (subsetp '(1 3 5) '(1.0 2.0 5.0 4.0 3.0)) (subsetp '(#\z #\r #\o #\w) '("zebra" "kangaroo" "ostrich") :test #'(lambda (x y) (find x y))) (subsetp '(-1 -3 -5 -6) '(t) :test-not #'(lambda (x y) (plusp (expt x 2))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL b/internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3e6f228e9cfcebd8500faeb24a14b347670ff809 GIT binary patch literal 2014 zcmb_c&2Jk;6rbJoXJRLgWzr;0)5U>OnQW*NA~oSqHk){Bzj?oT z-}7c##Qln*iAr^2vs5l@iPc7Zvr!kH~(URV{)MxnNv+a42R=fz}hTZ~O#xG*M8OwPPGJrj$Kcg1Bxvwd|evW3-3$0l~d z=KRd$^vvYMc-PS<)*ctA5<>Fi5W!1GfC$9eZ3d#IYM4?yp{bHCC)KFcvYH;KM9LUy z+G_Sqi1q5GR4%+xC}S}jHNp{MebDs8GrD3XQo7aVb~vB)e$$`OrDZ5go>vL)Irf6y zIjiZ9O-WOdDJQgL0?GJp5W){&CU=YX7P&hW^4XV*e71k6k8>h>oTHzR1ASNDA4EAH zJj@1*K;=WQ$cA9mD(;l-T_GfR!yV*`cMfz||JGW1SHF*YZ|jRZhg$msSr)6~*+ zDL=$IaU7p(b>h1p#^QONg#v`t@L@K@=SSc-8w97fL)l@rxRo7YxKrFI-Y!4_Xb%d^ zd)bMqNu<_sC6~Vj4fyXSqo9aX4qw{7^a%!xhFNuRFwJz zFKlq~!*Rz!75vD}(tyxS{Q}N(PgG5(Q)wxcF_$xDROkW)UsTptB*q(2$_YJaq<~Q` zF6L+eZq4N5x5n!xggWr94CCyhZ&y5(PRb^T+#g^WdQ`6>8>$_E;!WYc0c|I{JScqy zl0%aXW_duv$bDhM=QiB5VVw@*UX~6aJO?oZxU@8YQUsiMlk$=(X$jj?h@QrcUOIxn zF^T-eB=V~*J+R?NIG&K9nsLckNzSG;sq++oA^DcYCiiW)OT*iAut0|{((n}4EH5vs z`doyD&tL*dYI%hv(1S650m{kxiqZpkWL!G7NJH@lI*O2_5d_tirfmp=YHvb^VUaaS z)zqY_v*vi{GoVcVgvyfIbLu$tv2s+TW!JP z^>?$QtXUre2MLWRX;n5=>9JGS5~iA#HG}$44f=5@lQLDi=qvOrI?r3pt`m91L?mCM z=MYBTyNb|leaLe>tjN!hiPd({J{qJ?(S8UFy$c}3ZJ4)V0iZ1)pRkEV8=z%KYBnTo zuxE(;WVQW%ugC3jIs~4>Xy03Vq+5O&o-F(V(5-Mew{dwjhdp}YPJjW=?gW+!BMpOS zH8~wFcUZt#(ai;AE)81f`j*vpv6i|}dW*G@j)5hWXrw{UzHT+gPjp2Rjm#{16iYR+ sQmuCML>TEST>15-5-TAILP.TEST ;; ;; ;; Syntax: (TAILP X Y) ;; ;; Function Description: ;; This predicate is true if SUBLIST is a sublist of LIST (i.e., ;; one of the conses that makes up LIST); otherwise it is false. ;; Another way to look at this is that TAILP is true if ;; (NTHCDR N LIST) is SUBLIST, for some value of N. ;; See function LDIFF. ;; ;; Argument(s): X - a list ;; Y - a list ;; ;; Returns: T or NIL ;; (do-test "test tailp - SUBLIST is not a sublist of LIST " (not (or (tailp '(1) '(1 2)) (tailp '(a b) '( d c a b)) (tailp '() '(1 2 () 3 4)) (tailp '( 4 . 5) '((2 . 3) (4 . 5))) (let* ((a '(1 (2 3))) (b (copy-list a))) (tailp a b)) (progn (setq a '(1 2 3 4) b (append a nil)) (tailp a b)) ) ) ) (do-test "test tailp 1 " (and (progn (setq a '(1 2 3 4 5 6) b (nthcdr 3 a) c (nthcdr 5 a) d (nthcdr 1 b)) (and (tailp b a) (tailp c a) (tailp d a)) ) (let () (defun fun (list n) (tailp (nthcdr n list) list)) (and (fun '(10 9 8 7 6 5 4 3 2 1) 5) (fun '(( a b c d) e f g h (i j k) l m n) 1) (fun (make-list 200 :initial-element 'quack) 190) (fun (make-list 150 :initial-element '(1 . 2)) 100) (fun (make-list 125 :initial-element #\w) 75) t ) ) ) ) (do-test "test tailp 2" (progn (setq a '(1 2 3 4 5 (6 7) (8 9 10) 11 12)) (and (tailp (cdr a) a) (tailp (cdr (cddddr a)) a) (tailp (cdddr a) a) (tailp (cdddr (cdddr a)) a) (tailp (last a) a) t ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..85bcc9dbc2d65e8077da5ef9e09790d72eecc295 GIT binary patch literal 5542 zcmcH-e{2)i`Q1DJ3`uZk1}O{a1qhUsqc}kM(Y5mBav>p(ZO-SJuvVLK9FjHIsgpqI zT82=kPQ!wRtnEDz+Q$Bw)>UHZghbaiS}RRrt27Bs`(x9lO4F)MLK>Q;O=`EX@B3bC zk`M@NMalVnzkj~_-m@o|f1erE%)+6Oq2XLnD~ykgjE`vpg`zfE7%ygX+5phCubFY% zda=tedp12Du1e10WQ)1XSgv1l#&e_nnWG!E@Mf(yb5slO+_7V$*0yEW)}6b;;Z0SY zMlvdGl{M12{(M;{JWFTut}Q!vZQZe{>c)BZH6>JFjAhw0EUZMKcl()E%OlFw zs-a}&biWd01(>PUyl|mhbAz0UE@%vi_iE~{vpq9-am9kK=fq%WD8zV;`)aAN)r`kF zx^aBzT}G@UYT0^wH&9}`ldU``YIp!1A3R=|k#()6;h0^zZ8<3$W}Hbw(wFQ@I#w@N zZk2H2t)g080u05d%u}3%YBkc@MM$jzfSV>jwFnsoKuZy7M{Y>esC6(>Yg;Ybj@x=X zjV6t$4L3T#yMTD|R1yzWjt7AI3Hfx0x= z*V`VC>g6K>r2|0s(gA>&M`*C9e-KT$Tm@dRVhJg~lKgi?Gh&w|c2O?Ri$)|4h*h}k zlqPgA;gcqix*pBz9b4MTvDt>@kT22xFfR#(qII*(I{cPKu^+vF2H! z4GPT>&3lFRq-bgp&08TePd65qwgh4kIG%kmY;F|MuxP<$1D?x)rYVm z*1@9wN36%?pLn>_r9gI6{SXvArqolfNTEw&1IoT7u{S}2Kl%hxekdNsd{pe+eCzzYvdqEO{SE z-tQ&vBE`nvl)N9{OVKCr#=*}^&RNNM6*&pX`KIK2Lvp^3`B-~VK4z@e1~PDO?AM0!^3sR2W7NLO1Tc`L;VDNEQuI*?|{!l4OWzW@boFFNI-~a?3z2N-d*)(8UaS; zRA1Iq{nG+=7U`F7WV|>sEPG4FF`nO2-&N(MNCe6Wkp-*4av)d_V0Ir${N}!OPyGNY z>x&HgZ-m&rbq$J1)%*@sLFNA7yr5mlxS5vsrN~F{RRiwk<13 z140eozmh`V@D8C`u?{(m{vioI$jFIWl6IA<<3TyQ+YuoFL9=u8`HF-g`dR1%*dP=? z_%AWFNxaK=5^*yQ>UG4tK%eKOpiJMJjHfUVqMbwK_ehz8$})fyjTxvz~LSD zo`P}g8yzbS_>0z~Wi_`VLuKaVLE+0sG;Bvq~9&=O8?T@C;$_Ka+f@lyU%`EIbui_pgR^M> zSM&j{=%MV?{VT-x7D?mmB59n4uG3yuUamkd0K^px{5c5R8%Z?Mq4?k;lW^Xl2rn*9 zLa0jF!&fR$5@&nKJ2nWXGZ0lkJOl6}k^60cQK?5B`gq)_g*-G!9XnD0t_(GTJMebu zsT;I`|ixdg;K7HfHe*y2^_{IPL literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-5-UNION.TEST b/internal/test/LANGUAGE/AUTO/15-5-UNION.TEST new file mode 100644 index 00000000..172f1a64 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-5-UNION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: UNION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 276 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: July 22,1986 ;; ;; Last Update: July 23,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-UNION.TEST ;; ;; ;; Syntax: (UNION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; UNION takes two lists and returns a new list containing ;; everything that is an element of either of the LISTS. ;; If there is a duplication between two lists, ;; only one of the duplicate instances will be in the result. ;; If either of the arguments has duplicate entries within it, ;; the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (UNION '(A B C) '(F A D)) ;; => (A B C F D) or (B C F A D) or (D F A B C) or ... ;; ;; (UNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) ;; => ((X 5) (Y 6) (Z 2)) or ((X 4) (Y 6) (Z 2)) or ... ;; ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the union operation may be ;; described as follows. For all possible ordered pairs consisting of one ;; element from LIST1 and one element from LIST2, the test is used ;; to determine whether they ``match.'' For every matching pair, at least ;; one of the two elements of the pair will be in the result. Moreover, any ;; element from either list that matches no element of the other will appear ;; in the result. All this is very general, but probably not particularly ;; useful unless the test is an equivalence relation. ;; ;; The :TEST-NOT argument can be useful when the test function ;; is the logical negation of an equivalence test. A good example ;; of this is the function function MISMATCH, which is logically inverted ;; so that possibly useful information can be returned if the arguments do not ;; match. This additional ``useful information'' is discarded in the following ;; example; MISMATCH is used purely as a predicate. ;; ;; (UNION '(#(A B) #(5 0 6) #(F 3)) ;; '(#(5 0 6) (A B) #(G H)) ;; :TEST-NOT ;; #'MISMATCH) ;; => (#(A B) #(5 0 6) #(F 3) #(G H)) ;One possible result ;; => ((A B) #(F 3) #(5 0 6) #(G H)) ;Another possible result ;; ;; ;; Using :TEST-NOT #'MISMATCH differs from using ;; :TEST #'EQUALP, for example, because MISMATCH ;; will determine that #(A B) and (A B) are the same, ;; while function EQUALP would regard them as not the same. ;; ;; NUNION is the destructive version of UNION. ;; It performs the same operation but may destroy the argument lists, ;; using their cells to construct the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test union - test cases copied from page 276 and page 277 of CLtL" (and (let (( a (UNION '(A B C) '(F A D)) )) (every #'(lambda (x) (member x a :test #'eq)) '(A B C F D))) (let (( a (UNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) )) (and (member 'X a :test #'eq :key #'car) (every #'(lambda (x) (member x a :test #'equal)) '((Y 6) (Z 2))))) )) (do-test "test union 1" (and (progn (setq a '(1 2 3 4) b '(5 6 7 8 9) ab (union a b)) (and (every #'(lambda (x) (member x ab)) '(1 2 3 4 5 6 7 8 9)) (equal a '(1 2 3 4)) (equal b '(5 6 7 8 9)))) (progn (setq a '( (1 2) "one" "two" ( 1 . 2)) b '( "three" ( 3 4) "four" (3 . 4)) ab (union a b)) (and (every #'(lambda (x) (member x ab :test #'equal)) '("three" ( 3 4) "four" (3 . 4) (1 2) "one" "two" ( 1 . 2))) (equal a '( (1 2) "one" "two" ( 1 . 2))) (equal b '( "three" ( 3 4) "four" (3 . 4))))) (prog2 (setq a '(1 2) b '(1 2) c (union a b)) (and (every #'(lambda (x) (member x c :test #'eq)) '(2 1)) (equal a '(1 2)) (equal b '(1 2)))) (prog2 (setq aa '("a" "b" "c" "d" "e" "f") bb '("d" "e" "f" "g" "h" "i") cc (union aa bb)) (and (every #'(lambda (x) (member x cc :test #'equal)) '("d" "e" "f" "g" "h" "i" "a" "b" "c")) (equal aa '("a" "b" "c" "d" "e" "f")) (equal bb '("d" "e" "f" "g" "h" "i")))) (prog2 (setq aa '((1 2 3 (4 5) (6 7)) 8 9 10 11) bb '(#\a "string" (1 2 3 (4 5) (6 7)) 10 #\v) cc (union aa bb)) (and (every #'(lambda (x) (member x cc :test #'equal)) '((1 2 3 (4 5) (6 7)) 8 9 10 11 #\a #\v "string")) (equal aa '((1 2 3 (4 5) (6 7)) 8 9 10 11)) (equal bb '(#\a "string" (1 2 3 (4 5) (6 7)) 10 #\v)))) )) (do-test "test union 2" (and (progn (setq a '((a b) (x y) (o p)) b '((1 2) (4 y) (7 p)) cc (union a b :test #'eq :key #'cadr)) (and (member 'p cc :key #'cadr) (member 'y cc :key #'cadr) (every #'(lambda (x) (member x cc :test #'equal)) '((a b) (1 2))))) (progn (setq a '((poco a poco rit end) (sound little)) b '((rit little by little ) (by degrees) (end)) cc (union a b :test #'equal :key #'last)) (and (member '(little) cc :test #'equal :key #'last) (member '(end) cc :test #'equal :key #'last) (every #'(lambda (x) (member x cc :test #'equal)) '((by degrees))))) )) (do-test "test union 3" (and (progn (setq aa '((1 3.0 4) (5 7.0) (9 12)) bb '((2 7 9) (8 9 20) (99 88)) cc (union aa bb :test-not #'/= :key #'cadr)) (and (member-if #'(lambda (x) (= x 7)) cc :key #'cadr) (every #'(lambda (x) (member x cc :test #'equal)) '((1 3.0 4) (9 12) (8 9 20) (99 88))))) (progn (setq aa '(("blue" ("green")) ("yellow" ("red")) ("purple" ("blue"))) bb '(("blue" ("Green")) ("yellow" ("blue")) ("yellow" ("Red"))) cc (union aa bb :test-not #'(lambda (x y) (not (string= x y))) :key #'caadr)) (and (member-if-not #'(lambda (x) (not (string= x "blue"))) cc :key #'caadr) (every #'(lambda (x) (member x cc :test #'equal)) '( ("blue" ("green")) ("yellow" ("red")) ("blue" ("Green")) ("yellow" ("Red"))) ))) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3ea747c5d3b82dfec403759e622da780ccfb7d2c GIT binary patch literal 2924 zcmcIkO>9(E6u$4xZ`&EtmQwmVJZ9?9nea#l3ZX?~9@AGCn3)G}-UN!PrX6ghbVz?B zXh0>#L^DRqtN5-)6BkC~stXq)L>96%E?l@E(L@(6j0>0S@H_W1*r6l_Lo;)K&UxSY zx#xWMuCUPQY+lP&&tI6Gt1M{M<)sVDOWN7$g0@&)UYM$AXQ9_#&04m3`KXaSzUNS; zxwP)f)Iw!)sWPoO%az6H$xFMn%#c=?yrgAD4j$aC?cFyzJTjWe>}ei1N_pw4ZgHwI zJzuxUtg{&!9UdCZ?BCOT{}b=J(pqJVO|jdwG%?o7e9XI6YfU?5$wX%FK=LirD|Xa{S%m_l&K~yj47=DpBm#x=sl!8PSL^c6)ZJPn@*w z|EIeD5PUrJ{xm}H%8j!cW|XYcp%x zAKUAdnbz4>rnYz=)cVq3*;tOKsUJ0pV|mlo59gpM9x0{OD37X57-5VMMgYT)d(f87 z8cz18ZktZo29LAiA_PklCC4nN%0`4^rFp~`;Za{RxW6TB+O}ouR@pgGcGA8rFo>j$ z;)E{rr8LJSXgl!eU5fY^<9@n95xNm3JO#%syI?pZ4#7#szlX^hB~!ZNgjRm%TWR@` zchK^Nl+H^jCZ(v5*exNkFL}oV-)i!XF7lp4uz<*pq!_Mrut=fvB)0QTa(ahvqve*A z*5vXT(o!ZKz7urA2{a|KFG!FjmuG?X9X8Hz3aKywVfVy0_Lp3KA$NuVu)Em%3zj`0 z#ZM*vx&*$%J1-LUH19gZx9#JdyLjhzQo#EzxK|CY7FwP^H($LtPvUc4Eh1hVjZ)MO zkZ#1Q?QklKOIrMj5!cR6;z^#?X6NO5O1dl05G>-kVb5&}^Ir0Qn0L`K#=CfoHYPR+ z-pv!9>kCU&77(|ki4X7?@5Kk8#vh>iCE^Gn)F4lJZZyDCaFD$4Dc-S8HpsGAd8MM}smjtpbS zNR$ORDSvt&BP8k&%i5;lnEE3;&gUG{Hu5EoQme$olV!^>C53+FJIKY|#{TUm-Oqd{ zEnj(V&|6h~sK~0Sh}n;dt>Rku3jHAFARi>`=bjt*Z`9i&Up|U#IM_vomt`848q*l2 zPs=imoTLfw!O4@NPt>ghk9#h?DgJ_K5(`pjD^vk)i#h>GcGqfw6Q=Ee>Hx&hEAjyL z5U?yLFbL+jL186%08WGuj7ZXrqQeMe;(drnyi34C96rD)%5hAv!VmMu#z%}z3Hv+| z;*oMtI?0U%?vVxVY%K6TLbr&Eo=lK(ZC{+mQS zw*}2iqQAZ3KK7z@bi>iQ5Ei0K5(6EjUgC~pn?eDpX-WLR2NkAR`~-rJ{?~|J|J(W% z8D~R2lZ_`V^BpG}PnIe0ojdU=QB`9K%>#a#2UVI=KAMwJF$;Z4AP0p$5$+?-KcS7% Om=gPlYWv0g`~Lux=7Kl? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST b/internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST new file mode 100644 index 00000000..5808af45 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ACONS ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 279 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ACONS.TEST ;; ;; ;; Syntax: (ACONS KEY DATUM ALIST) ;; ;; Function Description: ;; ACONS constructs a new association list by adding the pair ;; (KEY . DATUM) to the old A-LIST. ;; ;; (ACONS X Y A) = (CONS (CONS X Y) A) ;; ;; ;; Argument(s): KEY - a function ;; DATUM - anything ;; ALIST - an association list ;; ;; Returns: an association list ;; (DO-TEST "ACONS TEST 1" (EQUAL (ACONS 'G 5 '((B . 7) (E . 5) (E . 2))) '((G . 5) (B . 7) (E . 5) (E . 2))) (EQUAL (ACONS 'C 5 '((G . 3))) '((C . 5) (G . 3))) (EQUAL (ACONS 'G 9 '((G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) '((G . 9) (G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) (EQUAL (ACONS 'F 3 '((F . 4) (Y . 2))) '((F . 3) (F . 4) (Y . 2))) (EQUAL (ACONS 'D 3 '((D . 5) (Z . 3) (Y . 3) (Z . 6))) '((D . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) (EQUAL (ACONS 'Z 1 '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) '((Z . 1) (E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8)))) (DO-TEST "ACONS TEST 2" (EQUAL (ACONS 'X '(X E G C G) '((D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) '((X X E G C G) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) (EQUAL (ACONS 'E '(A G C) '((E F F))) '((E A G C) (E F F))) (EQUAL (ACONS 'D '(G F X Y E A Z F E Z) '((C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) '((D G F X Y E A Z F E Z) (C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) (EQUAL (ACONS 'B '(C C Z) '((D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) '((B C C Z) (D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) (EQUAL (ACONS 'C '(F X G D B G F X) '((C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) '((C F X G D B G F X) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) (EQUAL (ACONS 'X '(C F A F D A Y C X F) '((X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X))) '((X C F A F D A Y C X F) (X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X)))) (DO-TEST "ACONS TEST 3" (EQUAL (ACONS 'CATOR 'B '((FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) '((CATOR . B) (FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) (EQUAL (ACONS 'FOO 'E '((MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) '((FOO . E) (MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) (EQUAL (ACONS 'ZORK 'X '((BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) '((ZORK . X) (BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) (EQUAL (ACONS 'CATOR 'C '((PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) '((CATOR . C) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) (EQUAL (ACONS 'PERTY 'E '((FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) '((PERTY . E) (FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) (EQUAL (ACONS 'MORY 'A '((CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y))) '((MORY . A) (CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y)))) (DO-TEST "ACONS TEST 4" (EQUAL (ACONS 'MEEF '(G C E C C) '((MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) '((MEEF G C E C C) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) (EQUAL (ACONS 'BAZ '(G X A) '((QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) '((BAZ G X A) (QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) (EQUAL (ACONS 'FOO '(B D E Y B D C B) '((BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) '((FOO B D E Y B D C B) (BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) (EQUAL (ACONS 'CATOR '(E D F G Z) '((BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) '((CATOR E D F G Z) (BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) (EQUAL (ACONS 'QIX '(A Z F C Y G) '((BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) '((QIX A Z F C Y G) (BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) (EQUAL (ACONS 'BAZ '(E C G F A G D B) '((MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F))) '((BAZ E C G F A G D B) (MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F)))) (DO-TEST "ACONS TEST 5" (EQUAL (ACONS 1 'E '((1 . B) (4 . G))) '((1 . E) (1 . B) (4 . G))) (EQUAL (ACONS 1 'Z '((4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) '((1 . Z) (4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) (EQUAL (ACONS 2 'F '((3 . Z) (2 . G))) '((2 . F) (3 . Z) (2 . G))) (EQUAL (ACONS 9 'Z '((4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) '((9 . Z) (4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) (EQUAL (ACONS 4 'Y '((8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) '((4 . Y) (8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) (EQUAL (ACONS 3 'Y '((1 . Y) (4 . E) (8 . A) (3 . F) (6 . F))) '((3 . Y) (1 . Y) (4 . E) (8 . A) (3 . F) (6 . F)))) (DO-TEST "ACONS TEST 6" (EQUAL (ACONS 5 '(X G E) '((8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) '((5 X G E) (8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) (EQUAL (ACONS 5 '(Z A D A Z Y) '((7 C F Y E G B))) '((5 Z A D A Z Y) (7 C F Y E G B))) (EQUAL (ACONS 6 '(G) '((4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) '((6 G) (4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) (EQUAL (ACONS 10 '(Z F B) '((7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) '((10 Z F B) (7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) (EQUAL (ACONS 6 '(Z D F Z) '((4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) '((6 Z D F Z) (4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) (EQUAL (ACONS 8 '(A B D Z E D Y D) '((8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) '((8 A B D Z E D Y D) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8f9a90c18a7824a17d458f63fa1b3b89b891483a GIT binary patch literal 1134 zcmb7D-%ry}6u#XLHpoT>I!TDZ8xkI9xP&4a7!RhD4m!Gaws%3E%(4}>2pjH)290Fn zffs9ZBbrv@|KKZPe zIUPI3Q`w{>si-p1#I(#iZO0D7BqVFfhGUP+<9cPE>{`#PT{g^K4RHuL@9c0gt4UPR zHRptDauMgP9aS`vfx*Nz8TrDODomXN8Q~tePejwyC88vWrc(qx4IDu)9oEp-;#rD2 zEu+`pQohaM@ewY#gAgl35jy{mkWqe~0b%qg6yb`e-!+JTwKv{qKM-mckF}JK1IbSD z%h+bu5Jq5c1kNetN880%DTaJO=e>QKmvn7aVIz`tQCn4IgRCf!(bi1f7Xa@@cuAzv zIx%FLHDGqBYuqn_iKP zOqBI?`q|eg=62LR;`XF55-BmorAxlfJD0+P+v+$F51*H`Uv zo2@Ai)?e%~`e5T8jN>5ZVfz}r>ZIA?oKFCN&L<>87O70Gtxi>_Y_L5<7z`HhFsoD9 Ly@fuS7Z<+)S}ITn literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST new file mode 100644 index 00000000..ca024c6e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASSOC-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 280 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ASSOC-IF-NOT.TEST ;; ;; ;; Syntax: (ASSOC-IF-NOT PREDICATE ALIST) ;; ;; Function Description: ;; Each of these searches the association list ;; A-LIST. The value is the first pair in the a-list such that ;; the CAR of the pair satisfies the test, or NIL if there is ;; no such pair in the a-list. ;; For example: ;; ;; (ASSOC 'R '((A . B) (C . D) (R . X) (S . Y) (R . Z))) ;; => (R . X) ;; (ASSOC 'GOO '((FOO . BAR) (ZOO . GOO))) => NIL ;; (ASSOC '2 '((1 A B C) (2 B C D) (-7 X Y Z))) => (2 B C D) ;; ;; It is possible to RPLACD the result of ASSOC PROVIDED ;; that it is not NIL, ;; in order to ``update'' the ``table'' that was ASSOC's second argument. ;; (However, it is often better to update an a-list by adding new pairs ;; to the front, rather than altering old pairs.) ;; For example: ;; ;; (SETQ VALUES '((X . 100) (Y . 200) (Z . 50))) ;; (ASSOC 'Y VALUES) => (Y . 200) ;; ;; (RPLACD (ASSOC 'Y VALUES) 201) ;; (ASSOC 'Y VALUES) => (Y . 201) now ;; ;; A typical trick is to say ;; (CDR (ASSOC X Y)). ;; Because the CDR of NIL is guaranteed to be NIL, ;; this yields NIL if no pair is found OR if a pair is ;; found whose CDR is NIL. This is useful if NIL serves ;; its usual role as a ``default value.'' ;; ;; The two expressions ;; ;; (ASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CAR) ;; ;; are equivalent in meaning with one important exception: ;; ;; if NIL appears in the a-list in place of a pair, ;; and the ITEM being searched for is NIL, ;; FIND will blithely compute the CAR of the NIL in the a-list, ;; find that it is equal to the ITEM, and return NIL, ;; whereas ASSOC will ignore the NIL in the a-list and continue ;; to search for an actual pair (cons) whose CAR is NIL. ;; See function FIND and function POSITION. ;; ;; Compatibility note: In Maclisp, the ASSOC function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for ASSOC in ;; Common Lisp. Where in Maclisp one would write ;; (ASSOC X Y), in Common Lisp one must write (ASSOC X Y :TEST #'EQUAL) ;; to get the completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (ASSQ X Y) ;; by writing in Common Lisp (ASSOC X Y :TEST #'EQ). ;; ;; In Interlisp, ASSOC uses an EQ test, and SASSOC ;; uses an Interlisp EQUAL test. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "ASSOC-IF-NOT TEST 1" (EQUAL (ASSOC-IF-NOT (QUOTE NUMBERP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (A 2))) (EQUAL (ASSOC-IF-NOT (QUOTE SYMBOLP) (QUOTE ((A 2) (1 1) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (1 1))) (EQUAL (ASSOC-IF-NOT (QUOTE STRINGP) (QUOTE (("FOO" 3) (A 2) (1 1) ((1 2) 4) (NIL T)))) (QUOTE (A 2))) (EQUAL (ASSOC-IF-NOT (QUOTE LISTP) (QUOTE (((1 2) 4) ("FOO" 3) (A 2) (1 1) (NIL T)))) (QUOTE ("FOO" 3))) (EQUAL (ASSOC-IF-NOT (QUOTE NULL) (QUOTE ((NIL T) ((1 2) 4) ("FOO" 3) (A 2) (1 1)))) (QUOTE ((1 2) 4)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..08d5bc7121d7676eb9c132b2b670f958601d4ad4 GIT binary patch literal 1118 zcmb7DO-~a+7@pnI51JMWv62vj6CwvU4Cw+IC4_0b7@(gjAj&DKlAD-R^3vyr;*QTQt25vJ)N42o_?h7ghUMhPy{FZ(+@xb z1OV-L35j5vpp2$tWGFc-(KhuWY!c+y*rMLx6l~VE(Wd*@-Q>e;HGlvBed9$kj-e9G zH0YtQC&cJ$FRmFV&jwSLFc2fZT)4YHy{LQ}-9d_Nn<~;Wfb|pFXMJ>dGoQ=HS>dP( zUVh1ns{sACH)Xslu^*^=1DavPLXg{aHO z!o;!I+-f(tkiBLToD+q=8N`(QSRm}j0}+bMj+Z#)|Zkzw0Mw{Nyb^IqD}P z8*C-m-R}WA(2&8MblV?RS-sD2bbXc+bj>Dt#8B8K77HLh*2QbN1yj!tb8I-d1#IQx zyr+HYgYT_J#Z&K=~>4ZV$g5r;W10bu7>}I^m(8D(`8WSbOI?mOemUC6CML>TEST>15-6-ASSOC-IF.TEST ;; ;; ;; Syntax: (ASSOC-IF PREDICATE ALIST) ;; ;; Function Description: ;; Each of these searches the association list ;; A-LIST. The value is the first pair in the a-list such that ;; the CAR of the pair satisfies the test, or NIL if there is ;; no such pair in the a-list. ;; For example: ;; ;; (ASSOC 'R '((A . B) (C . D) (R . X) (S . Y) (R . Z))) ;; => (R . X) ;; (ASSOC 'GOO '((FOO . BAR) (ZOO . GOO))) => NIL ;; (ASSOC '2 '((1 A B C) (2 B C D) (-7 X Y Z))) => (2 B C D) ;; ;; It is possible to RPLACD the result of ASSOC PROVIDED ;; that it is not NIL, ;; in order to ``update'' the ``table'' that was ASSOC's second argument. ;; (However, it is often better to update an a-list by adding new pairs ;; to the front, rather than altering old pairs.) ;; For example: ;; ;; (SETQ VALUES '((X . 100) (Y . 200) (Z . 50))) ;; (ASSOC 'Y VALUES) => (Y . 200) ;; ;; (RPLACD (ASSOC 'Y VALUES) 201) ;; (ASSOC 'Y VALUES) => (Y . 201) now ;; ;; A typical trick is to say ;; (CDR (ASSOC X Y)). ;; Because the CDR of NIL is guaranteed to be NIL, ;; this yields NIL if no pair is found OR if a pair is ;; found whose CDR is NIL. This is useful if NIL serves ;; its usual role as a ``default value.'' ;; ;; The two expressions ;; ;; (ASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CAR) ;; ;; are equivalent in meaning with one important exception: ;; ;; if NIL appears in the a-list in place of a pair, ;; and the ITEM being searched for is NIL, ;; FIND will blithely compute the CAR of the NIL in the a-list, ;; find that it is equal to the ITEM, and return NIL, ;; whereas ASSOC will ignore the NIL in the a-list and continue ;; to search for an actual pair (cons) whose CAR is NIL. ;; See function FIND and function POSITION. ;; ;; Compatibility note: In Maclisp, the ASSOC function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for ASSOC in ;; Common Lisp. Where in Maclisp one would write ;; (ASSOC X Y), in Common Lisp one must write (ASSOC X Y :TEST #'EQUAL) ;; to get the completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (ASSQ X Y) ;; by writing in Common Lisp (ASSOC X Y :TEST #'EQ). ;; ;; In Interlisp, ASSOC uses an EQ test, and SASSOC ;; uses an Interlisp EQUAL test. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "ASSOC-IF TEST 1" (EQUAL (ASSOC-IF (QUOTE NUMBERP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (1 1))) (EQUAL (ASSOC-IF (QUOTE SYMBOLP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (A 2))) (EQUAL (ASSOC-IF (QUOTE STRINGP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE ("FOO" 3))) (EQUAL (ASSOC-IF (QUOTE LISTP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE ((1 2) 4))) (EQUAL (ASSOC-IF (QUOTE NULL) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (NIL T)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..64006e243be257c90a707a716eb6d70e459be083 GIT binary patch literal 1482 zcmbVM&2Jk;6rb63Y$tUpr^18~ryZs0fmJu^Hi5S30WI5cn#=l9@OiL=hq^0ui-_uRcb1VYIB(D=f4`C&bYL6%B!v;+}nN(&EzuiZ>5XIjoa%D(d@&88#pI_eZ zT;H$O_N%DvA#o8s$=9mbGjwX}^~azdxt_|<+QVly$bWUFzP4Wy(y86FCl%UD$VTnw z{#n_AodkHYdi6-BmaS)r(iMFh<~7T)FBI`o^$F9yP~xusK@kx9qNgbd=vJR*nZ7ll zyWFq1aNCw_SJIpFd|p=Q>kQw~L`F@CUNsFJI;?TmbzI%4_|p|%Q@g<-qnY-cE^$v2 z(5kF)pyMf(5Rt$(AA+`#EeMn>IBwbWQT-EQys=leWqLf0CNgOL71&*}@2K4qIovkl z?S{y;MD8PzD~jA1kvk!B18DsNU1UM1{SLF1v@u-?)!#%vZZCk7;2*}=Q=q6*d=3qd zz@YLO$$bEL0tXNccg0({{Ul_LA7zf2N*v$^oM-tCY)6uBfjQ;*F5LVydWEsqx;T1O z419(uEYod>flDG^5km!$x5Utx$Qxp4Smck1L3zr5qcGKOTy8YKXkd(gqA(*bf?+0R zAoh0@9`l3M78|~14ztC1_=i|v^+x=>5xaH*X}`ebN1F;RxSE-Y<8zQH0%`&Y_oa%` zon5LpzMpe@m-7`!xI$_|^QgD`EbdL{~BvsG`O~D&1Y( z&A(mV$6%t$OiX|;Oet0!>)V_%XjFMW#-t3N9nQAHd5P->!@ncp!GmzWglY60>~O}T emdj0_>j&nvRP?!PmOPOGnm8`rBzJ0CTmJz~%$;xm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST new file mode 100644 index 00000000..a4c544e6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASSOC ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 280 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ASSOC.TEST ;; ;; ;; Syntax: (ASSOC ITEM ALIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; Each of these searches the association list ;; A-LIST. The value is the first pair in the a-list such that ;; the CAR of the pair satisfies the test, or NIL if there is ;; no such pair in the a-list. ;; For example: ;; ;; (ASSOC 'R '((A . B) (C . D) (R . X) (S . Y) (R . Z))) ;; => (R . X) ;; (ASSOC 'GOO '((FOO . BAR) (ZOO . GOO))) => NIL ;; (ASSOC '2 '((1 A B C) (2 B C D) (-7 X Y Z))) => (2 B C D) ;; ;; It is possible to RPLACD the result of ASSOC PROVIDED ;; that it is not NIL, ;; in order to ``update'' the ``table'' that was ASSOC's second argument. ;; (However, it is often better to update an a-list by adding new pairs ;; to the front, rather than altering old pairs.) ;; For example: ;; ;; (SETQ VALUES '((X . 100) (Y . 200) (Z . 50))) ;; ;; (ASSOC 'Y VALUES) => (Y . 200) ;; (RPLACD (ASSOC 'Y VALUES) 201) ;; (ASSOC 'Y VALUES) => (Y . 201) now ;; ;; A typical trick is to say ;; (CDR (ASSOC X Y)). ;; Because the CDR of NIL is guaranteed to be NIL, ;; this yields NIL if no pair is found OR if a pair is ;; found whose CDR is NIL. This is useful if NIL serves ;; its usual role as a ``default value.'' ;; ;; The two expressions ;; ;; (ASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CAR) ;; ;; ;; are equivalent in meaning with one important exception: ;; if NIL appears in the a-list in place of a pair, ;; and the ITEM being searched for is NIL, ;; FIND will blithely compute the CAR of the NIL in the a-list, ;; find that it is equal to the ITEM, and return NIL, ;; whereas ASSOC will ignore the NIL in the a-list and continue ;; to search for an actual pair (cons) whose CAR is NIL. ;; See function FIND and function POSITION. ;; ;; Compatibility note: In Maclisp, the ASSOC function uses ;; an EQUAL comparison rather than EQL, which is the default ;; ;; test for ASSOC in Common Lisp. Where in Maclisp one would write ;; (ASSOC X Y), in Common Lisp one must write (ASSOC X Y :TEST #'EQUAL) ;; to get the completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (ASSQ X Y) ;; by writing in Common Lisp (ASSOC X Y :TEST #'EQ). ;; ;; In Interlisp, ASSOC uses an EQ test, and SASSOC ;; uses an Interlisp EQUAL test. ;; ;; Argument(s): ITEM - anything ;; ALIST - an association list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: anything ;; (DO-TEST "ASSOC TEST 1" (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)))) :TEST (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)))) :TEST-NOT (QUOTE EQUAL)) NIL) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)) ((2 1) (3 4)))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((2 1) (3 4)))) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((2 1) (3 4)) ((1 2) (3 4)))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((2 1) (3 4)))) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)))) :TEST (QUOTE EQL)) NIL) (EQUAL (CL:ASSOC 1 '(((2 3) 4) ((4 5) 6) ((1 2) 3) ((7 8) 9)) :KEY 'CAR) '((1 2) 3)) (EQUAL (CL:ASSOC T '(("A" S)(1 2)) :KEY 'CL:STRINGP) '("A" S)) (EQUAL (CL:ASSOC NIL '(("A" S)(1 2)) :KEY 'CL:STRINGP) '(1 2)) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((QUOTE (1 2)) (3 4)))) :TEST-NOT (QUOTE EQUAL) :KEY 'EVAL) NIL) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((QUOTE (1 2)) (3 4)))) :TEST (QUOTE EQL) :KEY 'EVAL) NIL)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..57e879c7148282ce9d1c13aeebe5ef1dcc4a84f4 GIT binary patch literal 15021 zcmd^`3v8X`dB?xYxh6iwVWA5dO%1U#$McCXP(-tC!!aip;!8MoAYtvclmtR*9113F zS4tT}0lA)V>a0EAU|O{z6{$#t4ymnRN+pm=Rg_g4QaiQM+O5)vUl5W4y~DN8@cI@BZp>>9PXaF>&Tsl4}E-~d+5^c zu|ps49(vzZR}FMucKP-z-nV^dXxo~d!;_=FSGMAYBZp_QHA8J{F5P~`(Do~?+P3Dk zKW}_C>^dFdrl*wd(lrSgpTtsxe;@C)NFvwR&TI z-DTag$8WDrA31Sk8fI?0GYEsAu`plSxqp0QYR|-YV==rp>}WhRU)eKW-6zI|ch!QZ zlxv-f>7&o=4Zl7UeCn_FMmJovaa~xr zB?uU(1i_hGpHb)h`-&HYN5B62oo6OG)&0q-(T65FpACXjM<1Bz+#7|OcytlaeCF3`~F5|cIj^H;pobkK%9l>vYDC4)|9l>wm z;*8%lzr6e^Vqd#aIqA&Nt{_^|_|y4|`bQ?luh~O-sqP*gzh<;nukP3*$oQ_w{-`6V zL~He5(SKS0CH)ulpI1Ix*FQ2mHL|-}uTAZ*D<6$mLMu!joSdqSMUiH#_l!3(S{okU zzpuJ;qCPg+pM+7ka`n_if6@_mCYAU+<+slMTD?9|uTJcr+P8nIKkm|kj{f2CgH?mG zNn^fiXj#7OjDsM_kt7e0^44ghT{IPrumir7m^EkdnDP&+o!#EzxVF+-n93A*Lzdm8}{CI?{y^? zXnF3{ zZ7hD)d(U|9OWu3bdyC$i_uePGH|xDa-n-Fzml}rnBEt~hz1Np_+K^_{?x|8fAroDy!UPIJ?A}_VCWJIANH}+ zKK4i6`$O;TGYsMT9m855%h_1)@74=m_TKls_oDY)f`Lmg_>zx3>SL$8HsjlP3^2s9vs^-F$n|?jnw9(mn9Ex6T%op#P`S8r~kIvA2r7_=`x=J^zx~~NK z)5iRJrjFb>+kMGB!tfmPR%D=qX|`(R`SW#WQ*Ec_3F)*>|}{z z-R8z(DN1?--mKw)q(A9zEXJYUH4M@GkYE|L3ARM^$)I94qAl9GHkn5*@(`)5B5;_0 zOe0~ToG(RTR0i-Djm3_}VlI|+wy<*{78NdOQBtf}yU#|eqO1Ug>M<6Ja@VM|Y8pX% zXmLPKk*;0Qw2xJ_Z?9fvA({!EfP~^oA2+HhJ`T`m*^3# zsk9=P5y?ws1yiZ0ipFc3q*e$jr>Q0B@2mQi83li*$Q1KgPFLNr~)~zqKTZqsUpxIGEskp8VZ`$ zriB$sKrnxRJWEljT*_5S0B$f3F|Q)~NHYSs)e+wWQ8Xx-PNcCs#%mfAv|u`tZu6k( zL6=%v)EarcY1DjhpVGi;@KMtd?%YINFby~H66`I&wqcDkq`3?yT^bTCbY@pbzrrfOEH z<~x#ZcGGR>(u(uFKy%3@ddqzik2@X3lH+N`_^O@-#UCI%rE5KN@|V-n{#Jtz>RCtz zS^W($qTc^9>lqo1*i~Fhwy^4J>c_*eJB* zjTYIuwRtK-=&34`T_3|E-_VLjWk%+!*sQ#dT|O^ZxloC6R8P6jIi*gQV^*9sEYL2e z(o=STtUmXkAW@-MGO>ON7s!aJ7?}kl zCogA0Fc6}GPtURmQ9;q>BT5x6Y^YQjEr-pDTysf+6;WDgjJdZ9t^z1us+1%8w~$sd zBdVAPDhh*`3K&9Dt3s06KC1YvwhBc(RUql<^r}cw+h=mTV7_5g6o$h$wZ{h#B4LMQ z$^k2PK#;gn3Guz$Si5g1b{TS>c_Yv@uCm1-&K%F2i*KikkMg|<+abG@b@3vGDQko0 zw*`&Mm3$oM>Gqk+Cu#;i(jM0M2lMFMMds1D4a+_H3f8SRkB+|!)iVFj=*V2FPwB8{ zHbN_yd(#1>LIaJ}YC7eKCOgaJK^x9UGL~IYJAh-Ra;h6tuXyb9j%jm> z9|iwHb0Hw5ai=BTF|4Dg_9mN9jj8IWK*`ud9TGW6P|=Y-DQ0lM_&cms>~K=v3d(Hj z*=1xI@WkpQy?|E5ByQIfDM{A7Fn&JOm?Q<&)39+y$taW5jHz8oEme^&3@7U1-^+1| zLM6LmN`WIGA_-VA;7JM3(<%oC0)PZuk{~5u_8}PqB|R!Nu3fT->W(uEXD>3j4bGt? zROwjfG{XudZ6vI&&SL_iIwg3lOW3a4!&L)VDAiG^%qt^uMgYQt)Tm*rUXcTF{|%rq z>K5K0j;D~TIK#P2%F1S`NKCYu=2D?@GF>4~jucCzSV?CslOHD*aSv-xWPHt}0!R5L z+S+sNZB~5I4j!(bY0*HX<1xY2sxyFV9E+ipLMdJpQn1^0)8dW#2z4vJN;N5%c@+D& zj4n+wo1DcYeAfjnqQD{)vD~zm8AMjY+HPn7Lu5X-X24nDMZ=C=^{q2D~7QnNCl$I%jydhi7qTsAJz}PwLr1nHk0i=^{Hfzo}kUM0vj>!i6WNT;SEY)yi zAcM;<9E7EDSJt+dW0V0B9~8fKPE06%VRM`zMO=pCq!}%)Bg@Oo{e))WD-NdIiXRk} zuM?kfc=pX8yPp`ZT-zq>g2@Vbn3#!0CSYzCQqdCY+Jwp}iIbYRDl8Qwhmll-uy$|8 zcACRdO=~E0Gw`Q}G@rxOcKlJ4WHFm%r}Kvmzg<`mJAj@8J>PtmaXkum-P{ z-Lz*ef{)z?X$Q+nzG_BYJ6dWjVrVAG1%d6BLtwU5+|KAaX;`q9CXNLY5@8EV=JrM; zWQL11t1`*DC)5#{aI2Cx&dB^3x0uElt&VSsN(Z5pLMjR8GVypyS|OOyN|BJ_RtSSD z18#pL26#D|S-(5J>-Vhb{iHn|zTgm6e9$7TSAVnGpY7yBnbuGul0-omtvQ&LvZ0bz zW?u^?Ty%=xOMSlI38n+g^1!tAz?7}ZQrm3Uqx?w$g}XJAn!{YdwvdBoL=imLhSYn-|H;MR8gpHFz+Pbds&gJC;sHBK z#C^+;5|^{C$Bq)wKjF})U2TesSyR^DYBr%Nm^0`}DI{GsEd``a)eKp4t~GbY4tQo* ziUL9&{ZPJ|O?-1Z{Q&V0QB;Sp^Y=1wxuD#f{dt1%zwuLRYWGdTWsey>Gwsdh1ZB5u z!r2zu|235Gv_LYXTkvVj}ytLbSXBxJRymi`979K zxik)&ox10@OWk$iaDTdH&O*OF18h21n;*}$6r-$~@jTa(`&`S!wTzuqGUi(on|gh{ z%k`n03Q{&&pruAg$ci2yv82|p#M`)PvuV>UziJCgC+w2TCMb@y<~BX^WQ#9Z4ydSe zvWYXTL>R;zU7C<)Ys|p7y(&==T`WwxO4aZj|k(3pZjn zTsPCUNWA-;i7R@)C9deI<%#Puc(}q6SNI=kVa1u*%1ufOCsW?U8Bzrmk&J?#dXGZN zt}i%pQH4^naCTN<%ybn{CrIl}?eMY{kW}RI zAbdKvXs&8gS8WeXAEVUs!;-X$agY(DbibeSI{+OE7(+Wcpt40q8TV45(sc#gZ(j}Mgu z=S7MmGTF?$?Pu3SP{j=zK}fdAmSiXF-~0^ql87*N6JuFTKX?<|w4F)_2^_13ES}^F zqsOz6^QN;eQe=Ap;QxdP)-C8QLUD&#Dw=N-FvlH2b5p!!v9Ut9*j7`teA8x$V9N+Y zuO(t7f2KkuVW%R+&QpQH^^Dsz+CW;!UJ_>Hz&VSdaMX&SaQE_JXoz*!crm0arcUa* zK`VCqW7?ZTo>hAe@KJfvYqj5iJqP*RH|epNy>*FFPmL&qQ$g^r>CS_OziL?Xfvu8h_f(I%d zOp=3buovWfC4Kv$TnP1b8)iL^JK`etX`ZO@f)LdQ`smQ`Z+1Mk&t}8sTHE3flhGFA zU#atT&(()zp)GoXe2eb|U&Jvaf<7a>&y{bi4jR1IMC0UC4Y@yiOrVO(HrIQPNQF@) zESCy7W3)jif=NmgVwu7bIR7M7nX7uUF+AW*nix+i>_XGZk^6+Nau3809$no@4kq3D zA>p>|J8Jr=L(P9gXupe`ZGPK2`&=wfe#8q<&a3T3e?t@2u7D6Q`=9week3yX_`5eliGuO~jmkwFuA;RrDt^ z^h-N%_Ox)eTB~3W^$q#r$mqo6{(24l=x;u}A?g&u!dPu=N3FhA&GVLh@m@coCML>TEST>15-6-PAIRLIS.TEST ;; ;; ;; Syntax: (PAIRLIS KEYS DATA &OPTIONAL ALIST) ;; ;; Function Description: ;; PAIRLIS takes two lists and makes an association list that associates ;; elements of the first list to corresponding elements of the second ;; list. It is an error if the two lists KEYS and DATA are not of ;; the same length. If the optional argument A-LIST is provided, then the ;; new pairs are added to the front of it. ;; ;; The new pairs may appear in the resulting a-list in any order; ;; in particular, either forward or backward order is permitted. ;; Therefore the result of the call ;; ;; (PAIRLIS '(ONE TWO) '(1 2) '((THREE . 3) (FOUR . 19))) ;; ;; might be ;; ;; ((ONE . 1) (TWO . 2) (THREE . 3) (FOUR . 19)) ;; ;; but could equally well be ;; ;; ((TWO . 2) (ONE . 1) (THREE . 3) (FOUR . 19)) ;; ;; ;; Argument(s): KEYS - a pure list ;; DATA - a pure list ;; ALIST - an association list ;; ;; Returns: an association list ;; (do-test-group (group-test :before (defun equally (x y) (and (= (list-length x) (list-length y)) (every #'(lambda (w) (member w y :test #'equal)) x) ) )) (DO-TEST "PAIRLIS TEST 1" (and (EQUALLY (PAIRLIS '(F) '(10) '((B . 7) (E . 5) (E . 2))) '((F . 10) (B . 7) (E . 5) (E . 2))) (EQUALLY (PAIRLIS '(Z Z C F C B D D) '(2 10 1 9 8 6 4 4) '((G . 3))) '((Z . 2) (Z . 10) (C . 1) (F . 9) (C . 8) (B . 6) (D . 4) (D . 4) (G . 3))) (EQUALLY (PAIRLIS '(B) '(6) '((G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) '((B . 6) (G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) (EQUALLY (PAIRLIS '(G Z Z Z E D Y A G Z) '(8 3 7 6 9 6 1 6 5 4) '((F . 4) (Y . 2))) '((G . 8) (Z . 3) (Z . 7) (Z . 6) (E . 9) (D . 6) (Y . 1) (A . 6) (G . 5) (Z . 4) (F . 4) (Y . 2))) (EQUALLY (PAIRLIS '(F D F G) '(10 8 7 3) '((D . 5) (Z . 3) (Y . 3) (Z . 6))) '((F . 10) (D . 8) (F . 7) (G . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) (EQUALLY (PAIRLIS '(F Y B D E C) '(8 3 1 1 7 4) '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) '((F . 8) (Y . 3) (B . 1) (D . 1) (E . 7) (C . 4) (E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))))) (DO-TEST "PAIRLIS TEST 2" (and (EQUALLY (PAIRLIS '(D C X Z A A X A Z) '((D E B B E C) (B B Y G F X F) (C G E X B E G Z G) (Y C E C Y) (F E D D D Z B) (E E E C C X F C Y) (C Y F G) (X D F X) (B Z X G Z)) '((D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) '((D D E B B E C) (C B B Y G F X F) (X C G E X B E G Z G) (Z Y C E C Y) (A F E D D D Z B) (A E E E C C X F C Y) (X C Y F G) (A X D F X) (Z B Z X G Z) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) (EQUALLY (PAIRLIS '(Y B F D B) '((A C E F) (B D Z) (B D D Y D X E E) (Z F E C F) (B A G E)) '((E F F))) '((Y A C E F) (B B D Z) (F B D D Y D X E E) (D Z F E C F) (B B A G E) (E F F))) (EQUALLY (PAIRLIS '(D B F A B D Y Z F) '((G) (D A C A Z A A B) (B F F Z) (Z D A E F Z A) (X) (G A) (B D B A E) (Y D X A A) (B D)) '((C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) '((D G) (B D A C A Z A A B) (F B F F Z) (A Z D A E F Z A) (B X) (D G A) (Y B D B A E) (Z Y D X A A) (F B D) (C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) (EQUALLY (PAIRLIS '(E) '((C F A E Y)) '((D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) '((E C F A E Y) (D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) (EQUALLY (PAIRLIS '(Z X F) '((C D G E) (G D A) (C G)) '((C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) '((Z C D G E) (X G D A) (F C G) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) (EQUALLY (PAIRLIS '(B F Y) '((Y A G D) (B Z Y Y) (X)) '((X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X))) '((B Y A G D) (F B Z Y Y) (Y X) (X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X))))) (DO-TEST "PAIRLIS TEST 3" (and (EQUALLY (PAIRLIS '(BAR MORY ZORK MEEF QIX PERTY BAZ QIX MORY) '(F B Z E B A E B F) '((FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) '((BAR . F) (MORY . B) (ZORK . Z) (MEEF . E) (QIX . B) (PERTY . A) (BAZ . E) (QIX . B) (MORY . F) (FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) (EQUALLY (PAIRLIS '(MEEF) '(G) '((MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) '((MEEF . G) (MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) (EQUALLY (PAIRLIS '(QIX) '(C) '((BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) '((QIX . C) (BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) (EQUALLY (PAIRLIS '(QIX CATOR BAZ PERTY FOO MORY BAZ BAZ MEEF FOO) '(A Z C X B B X Y Y D) '((PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) '((QIX . A) (CATOR . Z) (BAZ . C) (PERTY . X) (FOO . B) (MORY . B) (BAZ . X) (BAZ . Y) (MEEF . Y) (FOO . D) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) (EQUALLY (PAIRLIS '(CATOR MORY MEEF MEEF PERTY FOO BAR) '(B G G B G Z Z) '((FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) '((CATOR . B) (MORY . G) (MEEF . G) (MEEF . B) (PERTY . G) (FOO . Z) (BAR . Z) (FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) (EQUALLY (PAIRLIS '(CATOR QIX QIX MORY) '(G C G D) '((CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y))) '((CATOR . G) (QIX . C) (QIX . G) (MORY . D) (CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y))))) (DO-TEST "PAIRLIS TEST 4" (and (EQUALLY (PAIRLIS '(BAZ CATOR ZORK QIX) '((A Y Z X) (C B X D D A D E G X) (X) (E E D F E X G)) '((MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) '((BAZ A Y Z X) (CATOR C B X D D A D E G X) (ZORK X) (QIX E E D F E X G) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) (EQUALLY (PAIRLIS '(MEEF BAZ FOO CATOR MEEF QIX CATOR) '((Z G Y Y Z) (D G F A G D D Y C) (Y X Y Z G C B D) (A C D Z A B D D F G) (D A E Y X F Y G) (A A A F F X Y A D) (Y Z B Z D)) '((QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) '((MEEF Z G Y Y Z) (BAZ D G F A G D D Y C) (FOO Y X Y Z G C B D) (CATOR A C D Z A B D D F G) (MEEF D A E Y X F Y G) (QIX A A A F F X Y A D) (CATOR Y Z B Z D) (QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) (EQUALLY (PAIRLIS '(PERTY ZORK PERTY BAZ BAZ BAR PERTY MEEF) '((D E D Z A) (E X A F Y D) (G X E) (B E E Y) (F C E E X B) (Y F G Z) (A F B E D X) (C A B Z F)) '((BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) '((PERTY D E D Z A) (ZORK E X A F Y D) (PERTY G X E) (BAZ B E E Y) (BAZ F C E E X B) (BAR Y F G Z) (PERTY A F B E D X) (MEEF C A B Z F) (BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) (EQUALLY (PAIRLIS '(ZORK MEEF ZORK ZORK BAZ QIX) '((C Y E E E G G Z Z X) (E B C B Y F Y E F) (X E F Z Y C D) (F Y F X G Y C X) (C) (Z F A C C Z Y X Y)) '((BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) '((ZORK C Y E E E G G Z Z X) (MEEF E B C B Y F Y E F) (ZORK X E F Z Y C D) (ZORK F Y F X G Y C X) (BAZ C) (QIX Z F A C C Z Y X Y) (BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) (EQUALLY (PAIRLIS '(MEEF CATOR MORY CATOR BAR CATOR BAR) '((E G E F) (X F Z Z X G) (F D B C Z G) (A C Z E Z G Z Z E) (Y F Z Z Y D C) (A C Z A D D A X G D) (G E A)) '((BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) '((MEEF E G E F) (CATOR X F Z Z X G) (MORY F D B C Z G) (CATOR A C Z E Z G Z Z E) (BAR Y F Z Z Y D C) (CATOR A C Z A D D A X G D) (BAR G E A) (BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) (EQUALLY (PAIRLIS '(PERTY ZORK) '((F D B X Y F) (F D E)) '((MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F))) '((PERTY F D B X Y F) (ZORK F D E) (MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F))))) (DO-TEST "PAIRLIS TEST 5" (and (EQUALLY (PAIRLIS '(3 9 10 5 3 3 5) '(C C C E E G B) '((1 . B) (4 . G))) '((3 . C) (9 . C) (10 . C) (5 . E) (3 . E) (3 . G) (5 . B) (1 . B) (4 . G))) (EQUALLY (PAIRLIS '(3 10 10 1 1) '(X E B Z C) '((4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) '((3 . X) (10 . E) (10 . B) (1 . Z) (1 . C) (4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) (EQUALLY (PAIRLIS '(3 10 6 5 8 10 9 2) '(E F Y G D G Z X) '((3 . Z) (2 . G))) '((3 . E) (10 . F) (6 . Y) (5 . G) (8 . D) (10 . G) (9 . Z) (2 . X) (3 . Z) (2 . G))) (EQUALLY (PAIRLIS '(2 6 7 8 3) '(Z Z F D E) '((4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) '((2 . Z) (6 . Z) (7 . F) (8 . D) (3 . E) (4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) (EQUALLY (PAIRLIS '(9 6 10 2 4 9) '(D C C Z C F) '((8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) '((9 . D) (6 . C) (10 . C) (2 . Z) (4 . C) (9 . F) (8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) (EQUALLY (PAIRLIS '(3 7 6 3) '(C D X X) '((1 . Y) (4 . E) (8 . A) (3 . F) (6 . F))) '((3 . C) (7 . D) (6 . X) (3 . X) (1 . Y) (4 . E) (8 . A) (3 . F) (6 . F))))) (DO-TEST "PAIRLIS TEST 6" (and (EQUALLY (PAIRLIS '(2 8 1) '((C Z Y C G) (D) (Y Y A)) '((8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) '((2 C Z Y C G) (8 D) (1 Y Y A) (8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) (EQUALLY (PAIRLIS '(5 4 8 4 6 8) '((Y E C B Z) (Z A G D C B) (F B G) (X Y G B) (E B C) (Y G Y Y)) '((7 C F Y E G B))) '((5 Y E C B Z) (4 Z A G D C B) (8 F B G) (4 X Y G B) (6 E B C) (8 Y G Y Y) (7 C F Y E G B))) (EQUALLY (PAIRLIS '(10 8 2 8 9 8 4 10 8) '((D G E Y D Y X) (X A F Z Z C G B B A) (X C D D C G E G X) (D F A F F X D F C A) (D B Y G) (X E) (B C Z X Y Y D Y C) (D C B C D X) (Y Y X C F E X C)) '((4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) '((10 D G E Y D Y X) (8 X A F Z Z C G B B A) (2 X C D D C G E G X) (8 D F A F F X D F C A) (9 D B Y G) (8 X E) (4 B C Z X Y Y D Y C) (10 D C B C D X) (8 Y Y X C F E X C) (4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) (EQUALLY (PAIRLIS '(2 10 7 2 5 10 7 1) '((G X E) (C E A B D) (E Y) (A C Z G E Y) (X Z D D) (Y C E Y D F Y) (F C D F D Y F) (Z A Z Z)) '((7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) '((2 G X E) (10 C E A B D) (7 E Y) (2 A C Z G E Y) (5 X Z D D) (10 Y C E Y D F Y) (7 F C D F D Y F) (1 Z A Z Z) (7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) (EQUALLY (PAIRLIS '(3 3 10 6 3 4 3) '((F X F) (Z G B F Y) (G B Z F X D) (A Y F Y) (C B X X X X) (F D A D E A C) (C Y X)) '((4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) '((3 F X F) (3 Z G B F Y) (10 G B Z F X D) (6 A Y F Y) (3 C B X X X X) (4 F D A D E A C) (3 C Y X) (4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) (EQUALLY (PAIRLIS '(1 6 9 5 8 2 1 2 9) '((B G C X C) (C G Z A Z Z A Y) (X E D D C) (A X D A A C Z A F) (B) (G Z B A E Y Y) (Y B) (G) (B B B X X E C Y Z)) '((8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) '((1 B G C X C) (6 C G Z A Z Z A Y) (9 X E D D C) (5 A X D A A C Z A F) (8 B) (2 G Z B A E Y Y) (1 Y B) (2 G) (9 B B B X X E C Y Z) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e2c0db5b42f9f8421a9b9343872ba5c854cab6a1 GIT binary patch literal 1158 zcmb7DT~8B16rI_A(zK)yDhV+-A>qM|OS*sx<-sh=6k4{sb$1%%$u#Xk8==L1XwXQM z2VPvGZPmuH@ZR_tQsgd?Bf#1qp~iTK@#(9swA5k{*3fC4z=uRZ{x zzyoO8iHZbUL`tSKEa^%Hi?l_ZAe%(WS=gk`z$9u^x1p0Dcew;P5{}PWg4f2!p$UFf8r=&{_Puwfsi^2|%l~r>6zT zB-^F0!z*1!IDtQ5R;OGTY?Y$rC=h(~gL7R}4SgZSXOxx{eL=&fG@oJ_ebEvHFEejI zR28BwNhT&alMSzS-Sb*RnuaMEIg-s0(bLBWVNuan zrEcC5UFKX=zOaCR2LRX0T@P^g_Lz`AX_y&>JZAi%)1Fnu!aXH7oMx!dIs5Oqv1vDU z(~XU~vEVv8_H~OsWUKY-Tu!sxVU^{*dQQ`3I6zBTBrCBfU=fqKkR9vBtC@L2%MSBc z&t>MZnT_zqcBvC+RvuNVPb)jr89G-S@oRzPXVket?0N%@?I>etEzf?CA}UvUx0~m7 z#xu0z@j@Xm9ldRLaKvJ`}KT{tIR3FWGB4!=tCxHN;0 z_u!XSK9%YA&DBSGa0uDiC7k0){=y;sOgjQw<)~_6g<$EzMzs{dCf`n&!`NEx=L~|~ KYv2<;I{E{!3sVyS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST new file mode 100644 index 00000000..af7006da --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RASSOC-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 281 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-RASSOC-IF-NOT.TEST ;; ;; ;; Syntax: (RASSOC-IF-NOT PREDICATE ALIST) ;; ;; Function Description: ;; RASSOC is the reverse form of ASSOC; it searches for ;; a pair whose CDR satisfies the test, rather than the CAR. ;; If the A-LIST is considered to be a mapping, then RASSOC ;; treats the A-LIST as representing the inverse mapping. ;; For example: ;; ;; (RASSOC 'A '((A . B) (B . C) (C . A) (Z . A))) => (C . A) ;; ;; ;; The expressions ;; ;; (RASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CDR) ;; ;; are equivalent in meaning, except when the ITEM is NIL ;; and NIL appears in place of a pair in the a-list. See the discussion ;; of the function function ASSOC. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "RASSOC-IF-NOT TEST 1" (EQUAL (RASSOC-IF-NOT (QUOTE NUMBERP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (2 . A))) (EQUAL (RASSOC-IF-NOT (QUOTE SYMBOLP) (QUOTE ((2 . A) (1 . 1) (3 . "FOO") (4 1 2) (T)))) (QUOTE (1 . 1))) (EQUAL (RASSOC-IF-NOT (QUOTE STRINGP) (QUOTE ((3 . "FOO") (2 . A) (1 . 1) (4 1 2) (T)))) (QUOTE (2 . A))) (EQUAL (RASSOC-IF-NOT (QUOTE LISTP) (QUOTE ((4 1 2) (3 . "FOO") (2 . A) (1 . 1) (T)))) (QUOTE (3 . "FOO"))) (EQUAL (RASSOC-IF-NOT (QUOTE NULL) (QUOTE ((T) (4 1 2) (3 . "FOO") (2 . A) (1 . 1)))) (QUOTE (4 1 2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..aad11bf8c833795a007cebe1bf6fbe5f2ce7e003 GIT binary patch literal 1144 zcmb7D-%ry}6uxcu3$l?xoFv5H4G9l6mQa`m#)B#44m!Gawzol^%(4}>2rKS~28~2{ z;Kdr7Q=YHRJ&iT%58$=(dI#j*gz3PrzhhD3> z*J{EouMQhtt6p;97R|%ws%fDYYl^x)vm_7OmrhD`x7c*c5Vzb$xwwBD%Cj(E+=uew z!oqDhH=ju_W@LG0IIGxtU+bK);g)OX9QhJwHj|#u$myBkvoGW$m-GMtC2-0x+__VZJVm3WdUs{a!4ELux`FpPIBCF z4ZQxI<2OboM!E1d0PG+E!07-Xqx?Fdgt5bDoU0uFFlhX{z5d4d2|&AYWaM~`N_Hw= z$2WRzFamqxv`)1&)~+P0Nx+B62mgksn#PL8=9AVGV?{@nw5-vLv1*Hah#EI4stQ)u zBnx53qJyhF=OXr|jZvQG{zqU_4B|pGNC+`%)`*BK%d{lZ!3774!Vo3IMa9^ZdU;z6 zsB202iuq9ifFQ&ik23d;s8A$pT6qOOru=LFdR7%1^_7Bnj-rMxtiKne(n0E0keUoq zv2A)3?iGAUR~j*xlx_#(D$R!sN7ok^K-X+skZ2UOu|*vyO!eZ;{IaPR##wAQ`DJ7k z60E61;zwJxM>X$h?SPJOQ5dqT0Oe=Izlq&O6HXl{Q*f(De~L1!*7`S^2ZK)x2It6U(&gy_Cshk6 d7)e+5sB0KmY%g&JqYJt3m>31u!6$Tf_6PHxP$mEX literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST new file mode 100644 index 00000000..f937f1e9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RASSOC-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 281 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-RASSOC-IF.TEST ;; ;; ;; Syntax: (RASSOC-IF PREDICATE ALIST) ;; ;; Function Description: ;; RASSOC is the reverse form of ASSOC; it searches for ;; a pair whose CDR satisfies the test, rather than the CAR. ;; If the A-LIST is considered to be a mapping, then RASSOC ;; treats the A-LIST as representing the inverse mapping. ;; For example: ;; ;; (RASSOC 'A '((A . B) (B . C) (C . A) (Z . A))) => (C . A) ;; ;; ;; The expressions ;; ;; (RASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CDR) ;; ;; are equivalent in meaning, except when the ITEM is NIL ;; and NIL appears in place of a pair in the a-list. See the discussion ;; of the function function ASSOC. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "RASSOC-IF TEST 1" (EQUAL (RASSOC-IF (QUOTE NUMBERP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (1 . 1))) (EQUAL (RASSOC-IF (QUOTE SYMBOLP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (2 . A))) (EQUAL (RASSOC-IF (QUOTE STRINGP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (3 . "FOO"))) (EQUAL (RASSOC-IF (QUOTE LISTP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (4 1 2))) (EQUAL (RASSOC-IF (QUOTE NULL) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (T)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c56099232ef4a9d6771389a242c79739249e80d7 GIT binary patch literal 1562 zcmcIk&u`mw6#sthH0eS*r4ym+nlLX?4_I?GcLlcYfQR|_Dex%iq9~0Vv0|z7o5(ma6KmrK~iNg*%?0|%X#DNpy51@RXze}67SCEoC zzt89MK7L=n7k5bFvRP8h=E`b)*3l+=sinbMQ(`z&pz8?$}E$t#dm~nv- zssEu1y3;UtOn+K?Msp0;wN1jiiEk1@b!_FE+MQ{7yFt~v)6(4GV}rC0QT$$sJ}Dwv z{_hdtpNt>4!T&;ZYS-#_xbu3W(-ec_EDtD3fTzKG9Wn=-8PCFW?)7dc{Ga8)VBhdQX5hG$M`4)ZDw zABq`GHSW&49xF@qpu)3NNXZEpko)-{539^^Y)7*z-o=Wi%7=JCN;Rx`Ey7(D_(aqC zzQst$gg^|pA%(*o?UW4<(=_*Ze6MfQaG7ueRFgkZE!G3mdyv8KwFtLFxDJ^W z$h-iVB4nP0%qV0|pmUs;_C<|h$v=EG;}+hwgz4Wfgy9daiLpxp`<+YV88(l^Z=8_X zY^42_<1ySds*zWg7Wg}7QK>h?3j?vMquA90KBsV74!0#ahG(0t z*dF5gpiR6TUqU%c4~1@9ye9-LI$n%hCUnUHyAKee@W<6A9V}$yXzy z+Cxz3r3jnlzungMnxs-WVxQ|__ga$Zxro&s@p~%5MjpY2B8-MN(Pt}o(sY>NF>T*M Wmx>;9jFJl}E`vNgK|XqMXXjs`*`oIV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST b/internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST new file mode 100644 index 00000000..a943d7fd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RASSOC ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 281 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-RASSOC.TEST ;; ;; ;; Syntax: (RASSOC ITEM ALIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; RASSOC is the reverse form of ASSOC; it searches for ;; a pair whose CDR satisfies the test, rather than the CAR. ;; If the A-LIST is considered to be a mapping, then RASSOC ;; treats the A-LIST as representing the inverse mapping. ;; For example: ;; ;; (RASSOC 'A '((A . B) (B . C) (C . A) (Z . A))) => (C . A) ;; ;; ;; The expressions ;; ;; (RASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CDR) ;; ;; are equivalent in meaning, except when the ITEM is NIL ;; and NIL appears in place of a pair in the a-list. See the discussion ;; of the function function ASSOC. ;; ;; ;; Argument(s): ITEM - anything ;; ALIST - an association list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a list ;; (DO-TEST "RASSOC TEST 1" (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2))) :TEST (QUOTE EQUAL)) (QUOTE ((3 4) 1 2))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2))) :TEST-NOT (QUOTE EQUAL)) NIL) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2) ((3 4) 2 1))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((3 4) 2 1))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 2 1) ((3 4) 1 2))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((3 4) 2 1))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2))) :TEST (QUOTE EQL)) NIL) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)))) :TEST (QUOTE EQUAL) :KEY (QUOTE EVAL)) (QUOTE ((3 4) QUOTE (1 2)))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)))) :TEST-NOT (QUOTE EQUAL) :KEY (QUOTE EVAL)) NIL) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)) ((3 4) QUOTE (2 1)))) :TEST-NOT (QUOTE EQUAL) :KEY (QUOTE EVAL)) (QUOTE ((3 4) QUOTE ( 2 1)))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (2 1)) ((3 4) QUOTE (1 2)))) :TEST-NOT (QUOTE EQUAL) :KEY (QUOTE EVAL)) (QUOTE ((3 4) QUOTE ( 2 1)))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)))) :TEST (QUOTE EQL) :KEY (QUOTE EVAL)) NIL)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8de3af0b90dc8f4fa7d48aa968eb1447756e1031 GIT binary patch literal 1731 zcma)7O>7%g5Ps{w#Bt&}R@638)NcMNSg{FCLKIx7(#!TacD>#;yX%^S14M~~jnX)B z90aNwg-C!9D}}UB_O%qG+_*KlRW0%XB#vCTazWz8p_Mps2{XHPVhR$-($0MIKlA22 z?~~x`iYhAA8yl6iQcbLG)i<{4;%c=fZdSKy%O!CYc^P zSBO;!A=`xId_B|q1)NBdor4wht}vkBfidN6pSu7c6VY%PRNRCq^X%E z5AKF{2@wu@V?M0rarsGBc(hIqzsvfHeFMEh=xsvQg6^jqYK}L6Eym#!A;ja?JC06x z3~>V5jhcMr2{7^9j$Wbs=*?(Dj{EdKA{KLhyBH~7!35Cgh1v- zW%+#LkUVQEQaET8*$HOFIQU_>gF|AsFx2++=w=I{Z}RA!7DVHt#lN9z#WeW&*LtB1%U$WI#m(u0SIAv)Iw-ueM-SFnAUbvxPZD_ zpzAvwk3vo6rR5P+r(k>?^UT5~5MSm4NG3co;*oP6>4B^r%_{;%k~9{87u9&l0W${h{+!q(=2F)uBSZ3 z?|cLmzwl8cKk+dnKZ2R>deO6J@JlFjKo&Kb)iw}M{{a`@<3klb^cH{N4L)q~7j-@| z$46)Q*aVj(e(56gA2FCaNHep@1^@?;2|--pL&v^ol{V|*@HQP5SC`<~UlA+o-iwX0 zZMUS~c8T!OH(1EG&VA<&_IE)s7`2%E+%~Bhiy2fkc?8YiAYLoz7ULrNe(u=g$vFnA m%Dl(f{l}@Fq;KWjHk*}<&%1d8ZcaV{5&6qpB==^IkN*M}qw3%Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST b/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST new file mode 100644 index 00000000..0bd3de14 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: clrhash ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-1-clrhash.test ;; ;; ;; Syntax: clrhash hash-table ;; ;; Function Description: clrhash removes all the entries from hash-table and returns the hash table itself. ;; ;; Argument(s): hash-table ;; ;; Returns: hash table ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table3 (make-hash-table :size 5 :rehash-size 5)) (setf (gethash 'car hash-table3) 'vw) (setf (gethash 'year hash-table3) 1970) (setf (gethash 'mileage hash-table3) 99999) (setf (gethash 'option hash-table3) 'sunroof) (setf (gethash 'owner hash-table3) 'smith))) (do-test clrhash-test (and (eq (gethash 'car hash-table3) 'vw) (eq (gethash 'year hash-table3) 1970) (eql (gethash 'mileage hash-table3) 99999) (eq (gethash 'option hash-table3) 'sunroof) (eq (gethash 'owner hash-table3) 'smith) (typep (clrhash hash-table3) 'hash-table) (eq (gethash 'car hash-table3) nil) (eq (gethash 'year hash-table3) nil) (eq (gethash 'mileage hash-table3) nil) (eq (gethash 'option hash-table3) nil) (eq (gethash 'owner hash-table3) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-GETHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-GETHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5a3d0137af9029bc897192e934ec096fe4c16109 GIT binary patch literal 1594 zcma)6O>7%Q6rQym$BrFiM^Q)@4vPR2H@(w*W0=>w#$qdg;T@$;lw(QhDtUK7w zon0aj;yrL9Yqq9XMP2ibgaaY&-FGL8np}a_Xr7TkWS9lB3!WR#zA0zrJhKYaERcuC z(R+jlPAVBdHa|2@O2VTZ^39K>Ky`XHC4@g9#2KFix>J2PR;S<-Bg8*DGv~*h(3A7C zb9{ardN)ttFm-P{B{Ux0PW1Hzz|%wZzMgnY$YJACJy8k>P~`C2%hgNB1MCq(;!vo$ zIn)1+Jib6qa7N@J;8vZ2I84{OJwndRX|FN@Kl&Imcjr@ib5fIRKJI6&|L&Zzim zfRRh%pn1@E`upE4T>7^bAnW=p+;zW^#2fkCy&@^Pwpzq%lM7T^Rhc2L6hWiqO(_uO z(ZCq&L`qVqr4(d?S+)UpstlGQY;KqqD+dDLG3{@SqB5%46?siJ%BIAHfbh>~OP6>o z7zINN?_Rd(ipsL*TZa1)oaE793^phsF~iUeS+}iCCsBO^od$D4v0d-QM8!hD}Dz>a9v;V(XRtD zE9MJ6AMynFgf+Xo!VFCK6MDnb;CuJcdtEmRHuV+XgCc|vkPjaKOqk5NFbST#%hPQx z*0^|!Up4tcfxmQvzntZ-Nc`0WF3m#6A+z`%3t^|a=ccXtZdaV&r}N@=4PM_ZvAN?v zoT%GhKvrLSUwTKl(Jv?lqZX5&SpXH=rK-te=mrCR*VZk@(-`Y|ZYHcml>test>16-1-gethash.test ;; ;; ;; Syntax: gethash key hash-table &optional default ;; ;; Function Description: gethash finds the key in hash-table and returns the associated value. If none, returns default or nil if not specified ;; ;; Argument(s): key, hash-table, and default(&optional) ;; ;; Returns: value of the specified key or NIL ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table1 (make-hash-table :size 7)) (setf (gethash 'name hash-table1) 'joshua) (setf (gethash 'age hash-table1) 24) (setf (gethash 'number hash-table1) 1234) (setf (gethash 'weight hash-table1) 150) (setf (gethash 'job hash-table1) 'writer))) (do-test gethash-test (and (eq (gethash 'name hash-table1) 'joshua) (eq (gethash 'age hash-table1) 24) (eq (gethash 'number hash-table1) 1234) (eq (gethash 'weight hash-table1) 150) (eq (gethash 'job hash-table1) 'writer) (eq (gethash 'address hash-table1 'unknown) 'unknown) (eq (gethash 'salary hash-table1) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..486fef64257a58b4435843941f9d77884bf556c4 GIT binary patch literal 1911 zcmb_dUuauZ7(e%>Nt33@ZrvXL|b#vU)ZTc*Gnc~ZE5{7~g1Hngq@I{}c58{I$_51E^+SCaO`f%_0{{Fr{ z=R4Bt=fWYuh-TV=HGZs&O9O0mDPF!h=~bcGm~e=CdbD|`(~(B4AB13Cp(!PpFA@$ z+P8b-svtE9Ayv}GB}RxuLd5&Pl@yy= zy;f^rIp^1iK#2Fg8=Y}<&CVOTcUia~^m~`wL|#|RP#T?OM2zmCAiChW4`$A)88t_( zoNCi4h@}~hZj&2V`!@*@ejboSOzVrKI|bqPGP(O@L98544G57}2x)}hXM}?)^FD2VX64;%s;w2;b6(L(o?-|L0C?tTq zb)u3&FwjQ{fynK8b*TNRknKuRIMqoq>SqLgjquLDjxhLl5xU_ocHm=`LD;VCPLNl3 zE-d|jQGV@2NkFZQ1QbzCZ&%X50QuiT0nRfi$iBTK5i#L?=ng5Gp-<;=ZeSYp=^``L zsXR#ZSxXUPJSIlri@+C#;T%vjYHK;wWVU0%aB2Q@Myxr@W+hPsi(|p~YDGqMr>xEx zX30{xAPV<;+lIp9p*Sew2XmO+A9ozoP(P1_`e2lk3NuZ^R1L>2JGK%^f>*yn^*Pm- zV~Eg^!${*?@?0tNm(vmt6T*A&h#bd3{}Hfz*g0B6<~v{_m@&1H{T5T!9Mfca*Lmau z>e`??cF;MES}e$f$5DL+I-AH*)1-4{(@^+3(FCcAHbY^nN2D;aBbki_qxMTnqG0J#2 zxHN^T5?sr0opR|ca6NO3g3seXisvd^QlLvAjhe$ydE8`vx!8adKOMsozwz8*ySCPn zM>gn)yf_aJ(1KiF4&DxwZ9I%-%icBbGM=ThW-@By)!aFu{+t!_HZy6_;&C*Cjd|8F zY!-C!MV>*3s1L!%z<_6iM*Ze%$S3z}u6XX~K|yZa{;ZXt63 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST new file mode 100644 index 00000000..ec36ed7f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST @@ -0,0 +1 @@ + ;; Function To Be Tested: hash-table-count ;; ;; Source: CommonLisp by Steele Section: 16.2: Hash Table ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 19, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-2-hash-table-count.test ;; ;; ;; Syntax: hash-table-count hash-table ;; ;; Function Description: hash-table-count returns the number of entries in the hash-table. When a hash table is first creatd or has been cleared, the number of entries is zero ;; ;; Argument(s): hash-table ;; ;; Returns: number of entries in the hash-table ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table3 (make-hash-table :size 5 :rehash-size 5)) (setf (gethash 'car hash-table3) 'vw) (setf (gethash 'year hash-table3) 1970) (setf (gethash 'mileage hash-table3) 99999) (setf (gethash 'option hash-table3) 'sunroof) (setf (gethash 'owner hash-table3) 'smith))) (do-test hash-table1-test (eq (hash-table-count hash-table3) 5)) (do-test hash-table2-test (and (clrhash hash-table3) (eq (hash-table-count hash-table3) 0))) (do-test do-hash-table3-test (and (setf hash-table4 (make-hash-table :size 10)) (eq (hash-table-count hash-table4) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..498bbcb86a3d50a3a7c82d731d0fff7708a1a437 GIT binary patch literal 947 zcmaizZBNrs6vuD7N4BAZxDc6vhDeMJC6=eaOiV82jul2bZ@U1#BU^EcgDrb7F-Ag2 zG`yI>fs$Sg-@*6}G4jGM&C2 zTB|8-SL;%v+Nu{EX&d~~OUBJ2w> z_o&^k8%hpZ!^;GT;olTa7XYKqDXNmeRz|V$BIL@Uv(w-Kl=7a}^R;xbBAoA{qi-wX z`i2qS;(*(958xSwcg~3iKUXCL%;C^V|ku}p;(s_?ixv`Wb zR9V!)V=P;;=m+rzWDVO|Mxn&cQ)piE)C*dhmQB_~;ok_`lv&glVtu|a2zEmzl$umA z^L8$8%f3E15R1JWkIUw9z!>gocK6hDSh$SMNc)*FhlT-Li|6CJpJOe_&tGNI-BWUny zvg>SE2NgpZOex;XVU~OZBw>RMEwH2taZySbG z(%2pzleV|u|0zo4-R{-rzP)k5{p6mAKpoL2!8TE@HJH_HLUGn&Q62_0KF*sqVYku8 H@vEy}BXJoJ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST new file mode 100644 index 00000000..309a7c4b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: hash-table-p ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 284 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-1-hash-table-p.test ;; ;; ;; Syntax: hash-table-p object ;; ;; Function Description: hash-table-p is true if its argument is a hash table, and otherwise false ;; ;; Argument(s): hash table ;; ;; Returns: hash table ;; ;; Constraints/Limitations: None (do-test hash-table-p-test (and (hash-table-p (make-hash-table)) (hash-table-p (make-hash-table :size 10)) (hash-table-p (make-hash-table :size 8 :rehash-size 4)) (not (hash-table-p 'x)) (not (hash-table-p 100)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL b/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3ad93928ff0771be703ce733b0464c756c7babd GIT binary patch literal 1329 zcmah}-D@LN6u*;%1A>9GChaf*=T5A7nqUqWCZP2khfM?SrqhxbS4w;haeiC3Z23uE(-+3y%0`_YW~E+Q zZj@HJyH(m;UHlC{@4ZHzSyf@EmFT&EW~&sBMU9>BCZ$ z(pleR3S<7gW+dmCx?8YJe^tkrhR4L5jTQ z!FSJKc zgqFToFa9Y(qqvaUF0)@IJbp}8W6{vbsr`9^Cyve>iC+FS#PG$s;aVM|g&?{i+Kuy0 zx%)gpdgN|6rj#H3X5#)uYvBv?PsUp1&&>INf|=Ye|CGGZ?h4ZA1VcTjtc9>H>~QKtLKF+UC+ky>+Sx9oF&JV#eni( z3)fO%Fc^k`U<6w>q)OYiY+-rsqUWl?0Xz^>HFHU{aYqI0T_SsG1j0eappW`KLhTEq zqfpMWi<(PnJ1pI^ZE5z*6)4EDf6)JEHz!?lWalOrB>E5Z6n2*urLc0OAE18b)X)(A z1L4k6an>@#@fZ^R5RxQ(NZp3yN053ClJ7!FLUI;T0+K4E&O-84NS#9~g^DwJ%DJF% zJ^2DiA%D;Dy8d=SNPC9EA2KOjgVev_Jc+;1Cf*%wf__EAge^N@-j+_@GUkZbM`G}Z za0>58!hS@o?^yZ1ec^SlbHjH;9mnzwq{;jqjFI>pG9-3@Z$r8cW9yJ91AiaV9%L4Q z=OO(zWTt?>0qKjt(~zd`js5F4Gj3_K!7prU7x>yT{+U*Jcml>test>16-1-make-hash-table.test ;; ;; ;; Syntax: make-hash-table &key test size rehash-size rehash-threshold ;; ;; Function Description: This function creates and returns a new hash table ;; ;; Argument(s): test: determines how keys are compared ;; [#'eq, #'eql, or #'equal] Default; eql ;; size: initial size of the hash table ;; rehash-size: specifies how much to increase the size of the hash ;; table when it becomes full. Must be integer greater than 0 or ;; floating-point number greater than 1 ;; rehash-threshold: specifies how full the hash table can get before ;; it can grow. ;; ;; Returns: hash table ;; ;; Constraints/Limitations: None (do-test make-hash-table-test (and (eq (type-of (make-hash-table)) 'hash-table) (eq (type-of (make-hash-table :size 10)) 'hash-table) (eq (type-of (make-hash-table :size 8 :rehash-size 4)) 'hash-table) (eq (type-of (make-hash-table :size 20 :rehash-size 1.5)) 'hash-table) (eq (type-of (make-hash-table :size 10 :rehash-size 20 :rehash-threshold 12)) 'hash-table) (eq (type-of (make-hash-table :size 50 :rehash-size 1.4 :rehash-threshold 0.5)) 'hash-table) (eq (type-of (make-hash-table :test #'equal :size 30 :rehash-size 40 :rehash-threshold 0.5)) 'hash-table))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1bb34f089a8b4748a2c334c8a82cd42a6ddf29ed GIT binary patch literal 1750 zcma)7U1%d!6uvV_lV;P#q||lW4eqqsRZ^#t{%wtdxt+ajVkR@$nTfTENViQ*HQAIl zRYWbN6nt=C%`RK!Dk~xgKCb$->`EVe5TAVWMG#+n@ktQ`MXcw{ZDOf{63G3|ckVg& zoO91T(;{8ZXu6^`>g#K@%7)U|YOZfJmDR?Evf0?$Sgt6mz$>q7rp4aOQLQlcc>0um zOtZXES!z~R6lbflxw7=yBTD))g|2U`)d0-QfSArqjb|n&$4<>rTNmE`(`F(wF_jqy zo5P#?QoKP3StbX#L|*=CmKCdQR!V_mIP zUa8bDo%$w`2=U%=yXVS==HyMoyDsfWJ>FHfH*csVNR7@jB6lBoLGP01_N1rPv|6O4 z9JO=g=6+1h_7!sH^Mbt4KbVk0FA`D<_d>XR2LKoPUXBtXQ2oyi ztVKGo{znJa20F0*dk5Ci2-og{x4zwQLaN?=A$DNKK>VqtUo~T25Yno?WyT7!1jn{+ z4J@3-$UxssNDrDWpE>x1e0eNfX}2A2H?j+TV0f*1tKtU?7|G11<+cc_TpJ73Oj`ui zXd4UF*|ylKx^3udcB=UM-)Wrww=}@vQ-ja}2h}*<(+xM7(oExG9xqePQRAY{EOj;y zj4^MgPb;!QT2H| z!gJ&46MY&962gPnocCd`y#bDb>}jf_&;TKX;ZX<08pfxUEsGh)UILd;_dMwO|1OV4 zZ6=Q8QB;pY`NH$e!6Z;t_#iF`v2^(h`Bf}Gisf6ed<`*#j~)b=kdHaWNj~CdaM|Yr zb=&|6qwC8&xxkY;Pg0(o=E+f>JO|o)inPGs#@h8mOX*cmbd@Y~-au&$Yjt#ridE%t zq%GX!R}ZB;Jm-*s&+ z(06-J?g;eNzI5+P^p_ji61?qrwnX6t!A!w1$`hVDSX-)JURlBePIe*;Oxf>5@4D={ zfdX5Ef9S+Of+u5e5kdQs<%9u*Emp+aB;v%+y!X)JntQ)yG3qe&L>uaPhgnp&c@($7 zg>ikh8rwCk{KA5~^7=%2cml>test>16-2-maphash.test ;; ;; ;; Syntax: maphash function hash-table ;; ;; Function Description: Maphash calls function on two arguments the key of the entry and the value of entry for each entry in hash-table. ;; ;; Argument(s): function to be mapped and hash-table ;; ;; Returns: hash-table or nil ;; ;; Constraints/Limitations: None ;; Alter every entry in hash-table7, replacing the value with its ;; square root. Entries with negative values are removed. (do-test-group (set-hash-table :before (progn (setf hash-table7 (make-hash-table :size 7)) (setf (gethash 'entry1 hash-table7) 1) (setf (gethash 'entry2 hash-table7) -2) (setf (gethash 'entry3 hash-table7) 9) (setf (gethash 'entry4 hash-table7) -4) (setf (gethash 'entry5 hash-table7) 25) (setf (gethash 'entry6 hash-table7) -6) (setf (gethash 'entry7 hash-table7) 49) ) ) (do-test maphash-test (and (eq (maphash #'(lambda (key val) (if (minusp val) (remhash key hash-table7) (setf (gethash key hash-table7) (sqrt val)))) hash-table7) nil) (eql (gethash 'entry1 hash-table7) 1.0) (eql (gethash 'entry2 hash-table7) nil) (eql (gethash 'entry3 hash-table7) 3.0) (eql (gethash 'entry4 hash-table7) nil) (eql (gethash 'entry5 hash-table7) 5.0) (eql (gethash 'entry6 hash-table7) nil) (eql (gethash 'entry7 hash-table7) 7.0)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..37b7b36b41a333078c6c628e91bb392e991baf06 GIT binary patch literal 1636 zcma)7O>7%Q6rQym$Bq+YTT#hR)vVH{NULsy(*%XUWwM#rPS(3&f9jSVswi==ksDi% zT`2;hs8m9Tl~Ok%+5z;Kqdm5*L&U7cSww-E0~aB#tXBr02S#ic0- zJP=ZKLdY8FqKFfcB4Oe_a8i=ROiNxYs7%&qkx6dHbz;zqY@5t*o%EF0syF0X`A)fp z?cClX0wL~wC$?y7idE1xcVE~Q`rSQeprFYs&>GD#5{jKf!RUhP^k?6Yv$Da8d1~g# z!-M!;LWI3^DumU1S2m-e}HUQ%>zp@26l=c%@!GDDs( z0HfthDHP@LP!Ft4T2iQ`qMCv`+anvO~g5rWNGQNmo zF0OL%x|h}{Sj^xllaJ^5#kcvTET53ju%w%LoAT5IzdQoXMa;sxECNA=rt6GZ<*k-D zzC*{wja7K3*Tw3l|HLA<<5l#P`=z^&i+w>c7`2%E(jKUom#QXD;4zrxJGO2yK8AHW qt}{6|&tS=z|Au=17+R-EgKRtIN&d-*myKV6SX|~~cml>test>16-1-remhash.test ;; ;; ;; Syntax: remhash key hash-table ;; ;; Function Description: remhash removes any entry for key in hash-table. This is true if there was an entry or false if there was not. ;; ;; Argument(s): key and hashtable ;; ;; Returns: T or NIL ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table2 (make-hash-table :size 7)) (setf (gethash 'name hash-table2) 'joshua) (setf (gethash 'age hash-table2) 24) (setf (gethash 'number hash-table2) 1234) (setf (gethash 'weight hash-table2) 150) (setf (gethash 'job hash-table2) 'writer))) (do-test gethash-test (and (eq (remhash 'name hash-table2) T) (eq (remhash 'name hash-table2) NIL) (eq (remhash 'age hash-table2) T) (eq (remhash 'age hash-table2) NIL ) (eq (remhash 'number hash-table2) T) (eq (remhash 'number hash-table2) NIL) (eq (remhash 'weight hash-table2) T) (eq (remhash 'weight hash-table2) NIL) (eq (remhash 'job hash-table2) T) (eq (remhash 'job hash-table2) NIL) (eq (remhash 'address hash-table2) NIL)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5fb1d3390d0b5402ef6c5e484f5e451093aaaa0b GIT binary patch literal 916 zcmah|TT2^36rSCfn3yP0Obb@p#a0SSM~F9U`ZR7PCT6p%vlBFLm1OO1i6-PClu{ck z2!(BH6lJ%?|4{m7E%l*)sLuD$Pc< z*^o9XHK|@{){3UI$>P#;MJM=08Y$VSNAUsUN~TydHyUP1qD`}2+IaRria(T4wPu%@ zv9Q40cw%lkF*`dokV1yq>-OI>Gl`kG#O(akK()11FfuYYNTintLR)goyjj z8O&&Kg;7IG7>L2kF1)+oI^p;{oQB4F8X0MDdJ@=UAdWeb&(`^}aJCH&zATGtLu12& z|8W=IcBk{BZ8<&X=}%_2>`#+rKSR#GUiR&8_cGtMTUN_De*(bBUVlWe&c15Q{@%{M z(Y^uDw)VAUQ5Xc^(E1o#>&n5>K>#8ET-e2twiUIbK=ixE&bX}TS~A1w!8Fp6Dkg9- z!y?*}A&Y%Xw_#a9R7pdEX`V3NN>{jmQ7|aZiNe1XRF}Q5uip##f=sI+855!tsORZQ zp31%uI}nkPR)F2OA$v@;X#AS?{XPJ^J}!8O3;3Ef3Z!(BLzKJw{8A-P2-dC))Dw1C zeDp6L1sS+^ix*zv9ePtq@(Jcp7DGe`DlB-hIq$}OFE-}Iy3=~ax`cbBkPr3Go^Yqk z4*R>vOKdd)8pourd$;bf_^66&*+np5L5AKo3ZoaJ$j3|cJXs8*A2~rI&%*z;t)x1uzHwNC{?R0(tvBeh4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST new file mode 100644 index 00000000..73003850 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: sxhash ;; ;; Source: CommonLisp by Steele Section: 16.2: Hash Table ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 19, 1986 ;; ;; Last Update: Aug 8, 1986 ;; ;; Filed As: {eris}cml>test>16-2-sxhash.test ;; ;; ;; Syntax: sxhash object ;; ;; Function Description: sxhash computes a hash code for an object and ;; returns the hash code as a non-negative fixnum. ;; ;; Argument(s): simple-string,string,symbol,list,array,floating point number, integer, ratio, :: and complex number ;; ;; Returns: hash-code (non-negative fixnum) ;; ;; Constraints/Limitations: None (do-test sxhash-test (and (and (<= (sxhash "hello") most-positive-fixnum) (>= (sxhash "hello") 0)) (and (<= (sxhash "1298!@#$)(#)") most-positive-fixnum) (>= (sxhash "1298!@#$)(#)") 0)) (and (<= (sxhash lambda-list-keywords) most-positive-fixnum) (>= (sxhash lambda-list-keywords) 0)) (and (<= (sxhash '(a b c)) most-positive-fixnum) (>= (sxhash '(a b c)) 0)) (and (<= (sxhash (make-array 5)) most-positive-fixnum) (>= (sxhash (make-array 5)) 0)) (and (<= (sxhash 3.78) most-positive-fixnum) (>= (sxhash 3.78) 0)) (and (<= (sxhash 999) most-positive-fixnum) (>= (sxhash 999) 0)) (and (<= (sxhash 3/4) most-positive-fixnum) (>= (sxhash 3/4))) (and (<= (sxhash -7) most-positive-fixnum) (>= (sxhash -7) 0)) (and (<= (sxhash #C(5 -3)) most-positive-fixnum) (>= (sxhash #C(5 -3)) 0)) (zerop (sxhash 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL b/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..675f7c6e4b15ea6c0881853bf7ed686dfc177b67 GIT binary patch literal 2801 zcmcIm-)|IE6uvXlF57mu-Ih{H#WHCD*QHZwX)RO)r?Yq4X=i7anOUX<6C~|Is|(xo z2SUUKdCv7vnv~Gg5fUR3@vj$S370yqlF|*Tm};6P{8hgghP^0RhuVIz zxnEu?%q#iagO#Pxw>WgYr+*F;$JI9byLZ}*3?l-#PGTbstbOx zsc%T>Q_|`LRaDznr^xLa+piKLe$pHhF`=(#?@tK#&I>2MnGn79j%FeBGUPZdm-4k} zyMnCG5`wV};MiSufDiHB4H#VcE%mkFjhDUUWu2vb7-+8(W5ggPQOZXF&7n#Uzt2ku zddrIgYJVA(rTR;r>~(p&y}e%C>+}*{kJsz%_xfi$s(;f1rMdec-g0%zE@AfGsm7Ak z2=JFxR9goJog7>^#-o)4M0)mQyaN&~&Bln>;J;to znb0gVspFwn##A$DP+J+%!DEg(2{Fp*#5%abaE0Kih3;xjXsWA?DK>SpHgty;v{%TP za$K4gMTltS{ihjJHM1EdW!Y&b!30s*yxO%AtU-#fI;kGItuaAu+p-la>t?cULTZEs zk%VeaDS;nFq$co%f_{6p($?6JQmjJsu@(*c0oq<+hXS^}!X5;6M+F@M)B&hPH4H_wsp`@s9}*60@r$v(M+Q)&i4azUQ%A-L zatCTrLyxNlg7*M~u!gFOa1~^mwXAJZbHj*Z0&-V@YpuRdO?4=*9BV-OB)sqXJ@h!W zrxXWXutCv#9Q2!1MmZ2)|=8BUaW-W)MCIVuT-q7~wk} zbBjHN+$GLk;M`fx9p+p+=eBV!6maBA(2iEeDQJ+7SscwxZr*0`6&8Pm#ZRz!lEnvD zyqm?JVDY^WBYp_0YcsYrY9e|ED$!KcQt*VZ7Gz$BJ- z)qt0Af^Jq7z6w-@yIk%gZf=5V+v69b_9AHS$)JKODx?6FlGE@aF!ka-!8J6lEVTTnqxD}o*zU>!xxw*w9xobu3 zlFyumubmlr?mYicLEp+A413=Hz+c0;*U38_ce*}NgAO!w*o|s9tO3K|^c~AuF6Ad? zA3FjP!cTz&I|>2p1^#Nj=gb?MnF43JH#3cXv3Gcc!myzHyC(QpTdHiKocoHizMEbw z@)!OZj2_WnlVA^m3Ihtv2sav-HAxVqYCw`Rl$%r#01?%IQO=BUqXz+^Bvb>&IWxhH z5d=UUn9HZ|v>H*u+uLv}iQ?HHJD!46QyT*BmT(>XMjIk8fo6>~4!@!}3@$MHgU4Vt f%w!grXe;-y40GYGGyXLEiek-Qt4D5Ke)#ZDE0Gnr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST b/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST new file mode 100644 index 00000000..d6063c27 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-array ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.1: Array Creation Page: 286 ;; ;; Created By: John Park ;; ;; Creation Date: May 29, 86 ;; ;; Last Update: Oct 16, 86 ;; ;; Filed as: {eris}cml>test>17-1-make-array.test;; ;; ;; Syntax: make-array dimensions &key :element-type :initial-element ;; :initial-contents :adjustable ;; :fill-pointer :displaced-to ;; :displaced-index-offset ;; ;; Function Description: Make-array constructs an array according to ;; the given dimension and key specifications. ;; ;; Argument(s): dimensions: non-negative integers ;; keys element-type: type of the elements of the array ;; (default: t (general array)) ;; initial-element: initialize each element of the array ;; (may not be used with :inital-contents or :display-to option ;; initial-contents: initalialize the contents of the array ;; adjustable: used to alter the array size dynamically after ;; it is created (default: nil) ;; fill-pointer: indicates that the array should have a fill ;; pointer. If specified, an array must be one-dimensional ;; ;; Returns: array or NIL ;; ;; Constraints/limitations: None (do-test-group (array-creation-test :before (progn (setq array1 (make-array 0)) (setq array2 (make-array 5)) (setq array3 (make-array '(2 2) :initial-contents '(((a b) (10 20)) ((c d) (30 40))))) (setq array4 (make-array '(2 2 2) :element-type 'single-float)) (setq array5 (make-array '(2 2) :element-type 'fixnum :initial-element 7)) (setq array6 (make-array '(4 3) :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq array6.1 (make-array 8 :displaced-to array6 :displaced-index-offset 2)) (setq array7 (make-array 10 :fill-pointer T)) (setq array7.1 (make-array 10 :fill-pointer 3)) (setq array8 (make-array '(3 2 2) :adjustable T)) (setq array9 (make-array '(4 2 3) :initial-contents '(((a b c) (1 2 3)) ((d e f) (3 1 2)) ((g h i) (2 3 1)) ((j k l) (0 0 0))))) (setq all-created-arrays (list array1 array2 array3 array4 array5 array6 array6.1 array7 array7.1 array8 array9 )))) (do-test array-dimension-limit-exist? (and (boundp 'array-dimension-limit) (integerp array-dimension-limit) (> array-dimension-limit 1024))) (do-test array-total-size-limit-exist? (and (boundp 'array-total-size-limit) (integerp array-total-size-limit) (> array-total-size-limit 1024))) (do-test array-rank-limit-exist? (and (boundp 'array-rank-limit) (integerp array-rank-limit) (> array-rank-limit 7))) (do-test make-array-test (every #'arrayp all-created-arrays))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL b/internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d1e80647c6cdc387cd8f11cfc6a78ea40a30a9dd GIT binary patch literal 982 zcmah|T~E_c7(Q*;2W*T&(8L9?ni!JCk`z#J+;}W!Y|yo{J!9^YjNt}@E&DK0BOzRP zRilGIT9NnzyfIuXL5y7ZhxQNfJsVM?7p7@@-uF4@InVpN=d_UTnWjrxWwTl;7iv? zRw~0_b{0Z4c7G~1Gc!35$F|;M`|q0R*z|*#3TrNo4>_@d5Xz%-_UlJTL;`a698spk zrb;}i6UD$OBD*cu2|_JO#wM2Q3{OdoN>wQrUKGl#oXtAo5OO~_!Fa~dXwo#?eQt*f zyYHRBq@kptG`v6%AG~B??40X_)Q5_yEEA2I7CJr*?t+LfOv$(6*&=tkh1%a2`Rqt^ znDcFv`LYlKsS!|lk|+zs=yQZh@OF`6G#VZ70W30jA{$w6XT|k)=OmhqY`}1%-8sre z$~+9=)7dHZo-;0 zf4x-{OCsWZ?twEVYo;-uWJN0pY|QJ#Ql2CsV=UM*-v@3E%NnLyLa_+VSm1`%wbO6s zY)Vo*_wNj9%3eqa0KhM+zpZDc2|<>`sy8I`d;P*77#xv_Wto;@W@tJ?Wg!GJ!ZJ2; zN;hxI9yl$ke>E%sW_f+AO9AHkXCU&&O)G^d3qLVUTE?=7ape?v9K#&IM*ozoVVm@J z@^r|=R{y76uA#ux*8z4kL64|qboSYf4kLoB-svwU6Qui!ZO4JJw7 z^2R425|akljCBQer=ZN1AsHq*Nimr;mnJ-;IB=a?v`}wIcee2zX>A3r*s4_8>fH{O u+rG=WNA5lk0>(9qU`iO{WedCY=t)W}tlM6QO#?+wGbSb8P4sc%;^G%CZzW{_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST b/internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST new file mode 100644 index 00000000..0e1f5758 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vector ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.1: Array Creation Page: 290 ;; ;; Created By: John Park ;; ;; Creation Date: June 5, 86 ;; ;; Last Update: July 29, 1986, MASINTER, TYPE-OF IS NOT GUARANTEED TO RETURN 'ARRAY ;; ;; Filed as: {eris}cml>test>17-1-vector.test;; ;; ;; Syntax: vector &rest objects ;; ;; Function Description: Vector provides convenient means for creating ;; a simple general vector with specified initial contents ;; ;; Argument(s): any number of lisp objects ;; ;; Returns: array ;; ;; Constraints/limitations: None (do-test vector-test (and (TYPEP (setq v1 (vector 1 2 3)) 'array) (TYPEP (setq a1 (make-array (list 3) :element-type T :initial-contents (list 1 2 3))) 'array) (and (eq (aref v1 0)(aref a1 0)) (eq (aref v1 1)(aref a1 1)) (eq (aref v1 2)(aref a1 2))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-2-AREF.DFASL b/internal/test/LANGUAGE/AUTO/17-2-AREF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fe350ac332b087bb65da26736907d21bdfbe4229 GIT binary patch literal 2925 zcmb_eU2GIp6uxt3TXwsiHNI#x!E^52U0Q0QiKN{< z=X~co=bn4+owGAfY7V6gB{gw;a=e(EQYL0+CTC}qV-r)#^u+AcXihl>xbkAkvh`B~ zT57OsZ+D%u!ZSLRJ2I0ys<^Yc>7z%U-==gwu4t1}<3&*R>;bd8cW1JCnftvQCs z_OCHJdUx#VO(whQ?p``C#U=#eOiT`#fmT+~)Rnr+mS50k5Px$kGDF}N} zvyN{2rG}(3Gcl2}+|Kc7A`#-hRSKrFX3EW2roSMamLmSyQZ!?#!>~22UnewJ z&Vtz`zZB};ttM5?*3;zD`3+|Xkw0mOQ7q;9*o{Hy+6nUOXM@yhZElcii#5*?g03*s ztMGbP0G$;8urgd%1H?oHuS7O4@kCxTu!@v(;`eh}md0;@d&8M^P14x4XX=-%dN7yg zjk8w$=Y-6Uy=K)9QYi}Rl_swpQ-eQ9NQ983@zIW@kLXV;HX)s`Ky>}vD;G$ zLfhggMJm*XL6y16Knrl~^qBbj&joGzr-D{gLqnBnLSAP+e+ON+7CS*Nl=Wt>vrxt_ zfLewhbQy0}%7}W2d_E7Y!%BJ=6)+1`^OBb+6bcn5*6_d@A$L?N2z&ATRj)Z;q<5AV z_j>UH7|?;`Mb(SL*?>_1qZJGp4WwNJBLGH`0`GyJk^F6?w20Rtn!|662^Q~0kuEPj z<+T)`7U&IHk9jRcD$K(2VjEa;9{YxI7ts>Fe6`sB+et{gzZoXR(pZeph<~osl1N!* zUj`q3bwD%w4Bb}uWdJezodgZD5RJko1fL*$YT;7@lcph&(%jU5YU^&+hDnj)qo&pw zaa?_fQeZTSS(Gw#&CCv~Y0DmR5=^4f+Gy8Gu&`VQj#|yOwUM6c*usG$*H<08SWI5e zLUOE%bOX{*wRVEF0ftw7Lbq+pR;{c%oOKiOMqoq|nmM9!9P5x9t5HdadZ=pcU@^ZG z>%MPL)p){Wt?F{OX+!w-OYh3a?j;j z2if*Mz}8oC=!QN7IW#z-hy(Kg-YU|DrMXXHVA-jOU6|roo`UTL0^1`zrtmbq^7QwFASYbWq`#`#cWdILTRcuW2dP>+Ax?S&ld5bR z>T{q+8&R7=w1ah_?yb$D^DN}cH6HS@U+U`Jr^AfU#cLOTmz=4#snVZ0r`)lwQ~m-> z8|p8}xFAzOk*Hiowy{U?vZP^BEy#ci7@>ZEKnw_x;RGs6_Xzu0jBP=R!F_PaPC||V zl}Gr3Vi7q|Qw!+2U2{tHSH}84L>mQyT?4JPb1QsP+U76R Sh#fGfIcml>test>17-2-aref.test ;; ;; Syntax: aref array &rest subscripts ;; ;; Function Description: This function accesses and returns the element of ;; array specified by the subscripts. The number of subscripts must equal the ;; rank of the array, and each subscript must be a non-negative integer less ;; than the corresponding array dimension. ;; ;; Argument(s): array and element-position ;; ;; Returns: element specified by the subscripts ;; ;; Constraints/limitations: None (do-test-group (array-creation-test :before (progn (setq array1 (make-array 5 :initial-contents '(a b c d e))) (setq array2 (make-array '(2 2) :initial-contents '(((a b) (10 20)) ((c d) (30 40))))) (setq array3 (make-array '(2 2 2) :element-type 'single-float :initial-element 7.0)) (setq array4 (make-array '(4 3) :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq array5 (make-array 5 :displaced-to array4 :displaced-index-offset 2)) (setq array6 (make-array '(4 2 3) :initial-contents '(((a b c) (1 2 3)) ((d e f) (3 1 2)) ((g h i) (2 3 1)) ((j k l) (0 0 0))))))) (do-test aref-test1 (and (eq (aref array1 0) 'a) (eq (aref array1 1) 'b) (eq (aref array1 2) 'c) (eq (aref array1 3) 'd) (eq (aref array1 4) 'e))) (do-test aref-test2 (and (equal (aref array2 0 0) '(A B)) (equal (aref array2 0 1) '(10 20)) (equal (aref array2 1 0) '(C D)) (equal (aref array2 1 1) '(30 40)))) (do-test aref-test3 (and (eql (aref array3 0 0 0) 7.0) (eql (aref array3 0 1 0) 7.0) (eql (aref array3 1 1 1) 7.0))) (do-test aref-test4 (and (eq (aref array5 0) (aref array4 0 2)) (eq (aref array5 1) (aref array4 1 0)) (eq (aref array5 2) (aref array4 1 1)) (eq (aref array5 3) (aref array4 1 2)) (eq (aref array5 4) (aref array4 2 0)))) (do-test aref-test5 (and (eq (aref array6 0 0 0) 'a) (eq (aref array6 0 1 1) 2) (eq (aref array6 1 1 2) 2) (eq (aref array6 2 1 2) 1) (eq (aref array6 3 0 1) 'k) (eq (aref array6 3 1 2) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL b/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0bff00f80a482fb02cd4f929d2f5fa8449f1b9c8 GIT binary patch literal 1682 zcmbtV-A^M`6u&d2-9l+o)`mbu8Q5jbjtoi5t|BJHVYr3LFvHGFsr#ZqDBHTT+olu~ z-H5m$F(zXWH?DK{LsO*1X}-i)fvj=Y@du#b3_ z>ZQd-X<2gCN~_C@?+iN6F=Nsu=1VmHlnsi$X6-!KRk)b!DYSwWheGw@WUz zb7hqXg!rF$(OkjMoV;oHH-rtL)8F#qc|)0p*3@ZA#OPratS!pe`l=N4b0s5{?0I<&@Sdd&pUmfwQ+6#4#05B(PFnz{(t;nK(D4@rJCg= z5!?OGygpeojj23thccrYQ#!Sj$vjw$X`9-M3AZKpxQ*LTEViYapa^i0e$ztmwG%cO|@z8TE-8_`&fxyD5&~8Mz64^Q4F#k z6#c9hMUtgKkWFqRAF$p!OHX57Fa(A5@uZ)?6rQ)tX#pA4s`*~HTyotiDsOJS@=;)x z{oDQx+{tG(i>eM)j{RBLdZIN8J4{47~a*`7*g5#WA+mltvt+9iHzW}rf@csY* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST b/internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST new file mode 100644 index 00000000..83186fc2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: svref ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.2: Array Access Page: 291 ;; ;; Created By: John Park ;; ;; Creation Date: June 9, 86 ;; ;; Last Update: Aug 8, 86 ;; ;; Filed as: {eris}cml>test>17-2-svref.test ;; ;; Syntax: svref simple-vector index ;; ;; Function Description: This function accesses and returns the element of ;; a simple vector specified by the index. The index must be non-negative and ;; less than the length of the vector. ;; ;; Argument(s): vector and index ;; ;; Returns: element specified by the index ;; ;; Constraints/limitations: None (do-test-group vector-access-test :before (progn (setq vector1 (vector 'a 'b 'c 'd 'e 'f)) (setq vector2 (vector 'A 2 10 4.3 "hello" -1.7))) (do-test svref-test1 (and (eq (svref vector1 0) 'a) (eq (svref vector1 1) 'b) (eq (svref vector1 2) 'c) (eq (svref vector1 3) 'd) (eq (svref vector1 4) 'e) (eq (svref vector1 5) 'f))) (do-test svref-test2 (and (equal (svref vector2 0 ) 'A) (equal (svref vector2 1 ) 2) (equal (svref vector2 2 ) 10) (equalp (svref vector2 3 ) 4.3) (equal (svref vector2 4) "hello") (equalp (svref vector2 5) -1.7)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7160a5bd7829077207e4ec1d3a605f5de054e42d GIT binary patch literal 1349 zcma)6O>7fK6rSC+9XtMEokU3#jJvT^kXEdPlR&|hkS3dPV!YWk`-91)RpdC>l7myn zMj%8KAyvJsL`_t*(<(jo+FW`-P31%Hy>jQs0fE#bQg~x0CL*BL2haQ7d-J{DoeuKf zRy9d&Y;4x*m8R5aw>H}?X}!^uwi@kbxgxEDUV5k+CV8}k)k6B~%&>LBQf^jOTa`7* zZdbO}Rv%oHGS?)$*{sz;xOx>}CVP1%J2#ge&S6XIv;F6t+3f64aG&CCH80apuj!9i+=s9z?Vj*;#{B}g=EWP$7z?xd(s_*YGKe%4)jyq z+5u=s9uJLj)#u;Fx<(A(n~wIxi2aRFr}~2tEAU(t#Qn)qf&~M65TOV{-C8->-G6W* z0dC?rfnaG25_nqOPn5>{!f0s{1X`Mc|4wzMwp0DzfyX};7}B`GxVlx5_3bA&A*+VI zkY~+Rmax8{5mTAZgGOJpWIjMcydNePmsM=5ONvQs$Ar$Sz0n1%70V{eJP#gY{n@G- z!Mamaa)!BV$&}-{)3Qd6v6|;3>AgQ0L=m#9-uiuF<6F} zOia@-6~nQMjx7skz#}4KeMRZ%SstD%W6^0HA*X1XvB& zX7DW###P5OiGE^zDaULt!8Z1xhbp#6KP(M1^B=%8a(Wk;>34dL9l!ODJ$mjTow`rY z)@b57T#7E^!qMu^(d2oWOweSM`M(3Bzi1kZIzz7^{KRQ~g|(52%;N>~?=^yWveBnwsA^YUxjyPO{(4P zKN(E7{Uvkz-uuPdWm}R|O@eKreAF*3Zxa)177a5uNcW~=*o01h=egcml>test>17-3-adjustable-array-p.test ;; ;; Syntax: adjustable-array-p array ;; ;; Function Description: This predicate is true if the array is adjustable ;; otherwise false. ;; Argument(s): array ;; Returns: T if array is adjustable, NIL otherwise. ;; ;; Constraints/limitations: None (do-test-group adjustable-array-p-tests :before (progn (setq array1 (make-array 10)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(3 3 3) :adjustable T)) (setq array4 (make-array '(3 4 5 2)))) (do-test adjustable-array-p-test (and (not (adjustable-array-p array1)) (not (adjustable-array-p array2)) (adjustable-array-p array3) (not (adjustable-array-p array4))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a7da2773f8c0a6540e4e2484c112e85eddadcc2e GIT binary patch literal 1527 zcma)6&2Jl35P!St&%|+UV};73W)rmtnXXkQAuZ;#*}NpK?cHQ|%@PhE<7}|Oj*UMM z5o#2bLpdxe!6Moh+Dj!4+^7#oRf~M+oj-s(cmDxMVcu?Hq7VtRTFv}s=FQBT_j~UU zdEb``ywq&8YIU>CH+$VyugmW=+kB_lYgbHu2kiV;lA_{!>!OrTznhuR&Uq?rv)nbe zdA(o>&#Nf}8C>*DPcgZf9>Tr6*1vA2E?8 zLa2g2?|& z#2{pUX9ZSEvZUt}+3qt3Ovrv{P32@^1GXlvVZ;Vbv(W5}ZN)RUg#|%WRdGvL$rZ7z z!AkV_D0CkorXP*4w5#XU7kTE{E;{}#&l*<~QN~wKLZ_9)Saw^??%3v& zJJ>X0XAvt#%#HAl21}rGr_pbM?x8v)On~ln^)Eb^L`VtpjYdVxaGlqBlXx}ajcqyhybheJMX zOVe?YWg#N&l1wUKQ7&x=tBP9GQiNfdf3Mb+6q)3L;P5$YSse3`GKrfSI~GWUn;fHg zKp_(3CdQTwSi-={a0;ucq6$h$-ze!R?g~VNQlh*iICk2HZACH{SRV8vL_Cz*S1Cik zg+w0wo>-vZ0DzC~LDVU{2MME6Nma3Y?j8|_`WoPi|1(2L)UaEYOj7q-km<^WOF`{C zxkg3Y6#++}zg#hL#hDuaC$dXWlg5&V~U&+QM3g&-Y3&NJ0rMDWe6e{Nfe%SsC!v)gMmY%85z#&BHNeZHJGnYQM(bJoYc pcG_8b$?p3(kC$Uv|4qBku^w&?3UXeL(;vAGfZQNFI?kM&{0$e*y@vn* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST new file mode 100644 index 00000000..79ec7a45 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-dimension ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-dimension.test ;; ;; Syntax: array-dimension array axis-number ;; ;; Function Description: This function returns the length of dimension ;; specified by axis-number of a given array. ;; ;; Argument(s): array and axis-number ;; Returns: length of a given array dimension ;; ;; Constraints/limitations: None (do-test-group "array-dimension-test-setup" :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7)))) (do-test "array-dimension-test" (and (eq (array-dimension array1 0) 30) (eq (array-dimension array2 0) 3) (eq (array-dimension array2 1) 5) (eq (array-dimension array3 0) 2) (eq (array-dimension array3 1) 4) (eq (array-dimension array3 2) 3) (eq (array-dimension array4 0) 3) (eq (array-dimension array4 1) 4) (eq (array-dimension array4 2) 5) (eq (array-dimension array4 3) 3) (eq (array-dimension array4 4) 2) (eq (array-dimension array4 5) 2) (eq (array-dimension array4 6) 7)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3f22f31a9538f5cb2355ea6f312f560519ee694d GIT binary patch literal 1361 zcma)6&u<$=6rSC+9XoN{b#bF&QnRtzs$F$0oCH$LX|kCl#_Qd5cU==MC~`K~l2ZrA z0U<-Ve_{ z34fv+ir(7XYBasJ(%R{4?R1olR$JL_?X+v2vH|DHH@aoBZftAAMPMnd54UMT2Q3Ei*OP5Bw<9qE#Gb2Yzx|>9n@AruU`S#Bw&b zi9ks3gCAY2n7UiE%-}${EyRO6{&>;UR-iPx#E2Mu5e1_QfqyPPr_E^8w&|+2P%Jak z0Z)e<-Hq=NBBYYCh_e2uKP(9kZjr-BC9!%oofIO?3`nh|2BK>dL+kv|N_QI%KPTku z-pE@*{lRC6u9X1z&%SZTN<1NCzy6(-D2c*2n7_SUoy0`IM+u1&(rwf--QUUgC$b9{ z2ic?56l6#0>Afq}iJ_gYo*&qU)%3u;UB}-WE17tm643QA2JF^lY~fG-q^euyLJ|9{ zEmL#BV74}2gcEbgQN;+4iD4LGQq`%eFKae)D>e*4?@ck{tU4|$iz3`e^~bCmjGC1d zZPBvJj>-j5c-7mrR6ZufcuX1xGSZt_ez+AlPibsOOmkU^577*u(IJ`zlz_cRsLZx4 zTeB+eO2t*BGjJoWQgc=7ouiJxm-DCgEH*+258-m1!4<(kA$F4*2m}BTtbw`!$ukI; z)GM~l%oCf;1?2t)F7>j9I(1k-EgwVr5k!(tuO$-q_yzp@(*GRt3t#bchri?T$pW~H zmuZRh*ZDo3xy&<@JQIWaLJY|8ift{K==~ogKX*F1hAreW@_*s&UK0@g3ID2yiB(~d z)D51U=h>dze*^zr*W2zW*^|Ux`C`+=Y`PR2QOt^>r2Y^cml>test>17-3-array-dimensions.test ;; ;; Syntax: array-dimensions array ;; ;; Function Description: This function returns the dimensions ;; of a given array. ;; ;; Argument(s): array ;; Returns: dimensions of a given array ;; ;; Constraints/limitations: None (do-test-group array-dimensions-test :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7)))) (do-test array-dimensions-test (and (equal (array-dimensions array1) '(30)) (equal (array-dimensions array2) '(3 5)) (equal (array-dimensions array3) '(2 4 3)) (equal (array-dimensions array4) '(3 4 5 3 2 2 7))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f64e73b343513fd00fc2ac00a28925fa87232c7f GIT binary patch literal 2586 zcmb_eU1%It6uvW?Z1ykf?lz{hrsBhXqZ8Wo}C!1nGlF{Q=R^)>R6EPzAvk5y9ePU;5ySPxYL8lTGRx6fEq_ znRC8#zI*PubI#5ZX+EwSiatFxQ?8U|mFb1~nT2`f^z^JUH@z@BQBqEWT{){;Hhq0W z(??TB(jjLZGBH~kpD&$K+=bHIsqt6$D(Say_ii()ofcEQ>j67)O1yMEKkYROY!rB$UntnGA4F&^46$y;|#ffdsHrN-5Qtt zmFAZSK`0E_@8a2mLHy7hY6ko6TBT*3Th|6|N{zFL;GzPuB8OTazPnbw1zO^K%NA+! z#*5LK6$SOdlJSley+g>-T9di!QyV9#xx%rx!k@=-dgMea$NT=uf|0ydV!nDP=m*}-dn5d zg^S9{X4aNN%i~?{kJaTO#qNgX(DMJ6gY!7L6_{$1F(OC2_o^L9-7<%=*eU9WW)2zD zRtK|SF^8R`9A-he6|Nv$0l55dHA7p*le*^WBdSf^f(>n@^S<;uV~$I6vJ4(=qH%SD zYGxs?W-L4BB$*^jjnS@^WMN;31$|Ly(`b^~wq>hU!Oa)kr0)p`h$J-=8WZhE;){XJ z&%3p+J`b>yeepWb%M!jsUF!#JQ(a4g)>hYgSi-Bu(tn#HA?O~~gu`P84uBsZvnF~> zGf?>k6hH1rb5Z>YsN#CTwsC6ICl!+r`xvmcwF>K+L&ZK=7~u=R6mSZIIBW7~SOi0& zaSkCg%eJGi*;6Pi)`8+VwhhG=)`{Xt;o{>$`ki}9zj06LNA4+o$UUWN!ev>AIpH}Y zJjaFS0fDs(Y?Hv6I7WWq82OT8N+l275oe(Ph%0qiM2$jC&q0((0BV89_ipTV96mv|(*Nhh zr$Z{VIX$jgnT$i-8Gs^dkZVn`oiC$p{ommUFvPMZObg9W;jMPzjdzM{r^`}0OZBpS z``I3qr8?NYO?Vn#c-8H0X>MNWI;V9hr^n$F#QVj_y42PThlSA%-ihZ6mP`5Gcml>test>17-3-array-element-type.test ;; ;; Syntax: array-element-type array ;; ;; Function Description: This function returns a type specifier for the set ;; of objects that can be stored in the array. ;; ;; Argument(s): array ;; ;; Returns: element specified by the index ;; ;; Constraints/limitations: None (do-test-group (array-element-type-test :before (progn (setq array1 (make-array 5 :initial-contents '(a b c d e))) (setq array2 (make-array '(2 2) :element-type 'single-float :initial-contents '((1.2 9.1019) (-5.39 0.1)))) (setq array3 (make-array 7 :element-type '(mod 6))) (setq array4 (make-array '(4 3) :element-type 'fixnum :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq array5 (make-array 5 :element-type 'fixnum :displaced-to array4 :displaced-index-offset 2)))) (do-test a1-element-type-test (eq (array-element-type array1) T)) (do-test a2-element-type-test (eq (array-element-type array2) 'single-float)) (do-test a3-element-type-test (or (equal (array-element-type array3) '(UNSIGNED-BYTE 8)) (subtypep (array-element-type array3) T))) (do-test a4-element-type-test (or(eq (array-element-type array4) 'fixnum) (subtypep (array-element-type array4) T))) (do-test a5-element-type-test (or(eq (array-element-type array5) 'fixnum) (subtypep (array-element-type array5) T)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..620c9c30bfa0b97f8cf6a8eac6a7850135e8a5d5 GIT binary patch literal 1714 zcma)7O>7%Q6rSDnPwd3T4we&4Vm1~nlIcb`Nog?%X|tImZk*k8cg+%ngd)emKbtxv zPAi0nqHsV+D+M>A+G$h?ao|eRTSY1#5JKXJ5VxMVz%7SLNJuEW*=bDFR4VJk_kHu; zym>S4&A5&H?^>+-$9Fw#1d@y13EYTrXF|6&M#kQ8XQYIx8!4qi^QI z#wkmAy|UD*EQ{u5Wn+2i;|pT$4N+cOuh~E@Uj~`WUmVL%OpJ!7WuwTVJ#)@@e*98? z;^Jud_|7dZ)CIbbfJhPRi4LLx9vJTuotOhVBK}%V`8hh zCfSwi6`O8nbpvq-xnDXx(spEdmcxj(K**i<}OL& zlC10Uq6BV}T1lNUqy=>6R^JXnd^jHCXoDt^1MX$3-{u(|0P15j0yN@L^bgP!qeno88T}n-8t7j2 z0R3hq>h)e44gG8-8VyDt0JV9>zq1lHegR1nU!>GmUL)8#p~aIv1pihp69_M!5UmCVp%OMNYk1=Z)6F_b7yCp zT9)(*Aut5IPR(`i0_|cU(lv~cn9$o*ZYG z>dVUNqU4R!JX|N1d*X(Lf(Q{Gy;dT<8$k%`XWIlob15XcNkl1@<IUguEomkuBde}6nxDi_ZOmR?@9(75UGQY3E#vXpqp!PrLBZ!2cs_W+-4l49 Xkb#hb-{)mO&VeB3$q2fgJ3jswqCe?L literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST new file mode 100644 index 00000000..21f5c6d4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-in-bounds-p ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-in-bounds-p.test ;; ;; Syntax: array-in-bounds-p array &rest subscripts ;; ;; Function Description: This predicate checks whether the subscripts are all ;; legal subscripts for array. The number of subscripts must be equal to the ;; rank of the array. ;; ;; Argument(s): array and subscripts ;; Returns: T for legal subscripts; NIL otherwise. ;; ;; Constraints/limitations: None (do-test-group array-in-bounds-p-tests :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7)))) (do-test array-in-bounds-p-test (and (array-in-bounds-p array1 0) (array-in-bounds-p array1 2) (array-in-bounds-p array1 4) (array-in-bounds-p array1 10) (array-in-bounds-p array1 26) (array-in-bounds-p array1 29) (eq (array-in-bounds-p array1 30) NIL) (array-in-bounds-p array2 0 0) (array-in-bounds-p array2 1 1) (array-in-bounds-p array2 1 2) (array-in-bounds-p array2 2 2) (array-in-bounds-p array2 2 4) (eq (array-in-bounds-p array2 3 5) NIL) (array-in-bounds-p array3 0 0 0) (array-in-bounds-p array3 1 1 1) (array-in-bounds-p array3 1 3 2) (eq (array-in-bounds-p array3 2 4 3) NIL) (array-in-bounds-p array4 0 0 0 0 0 0 0) (array-in-bounds-p array4 1 1 1 1 1 1 1) (array-in-bounds-p array4 1 2 0 2 1 0 6) (eq (array-in-bounds-p array4 3 1 2 2 0 1 0) NIL)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ab3259791b3961b87e75d62281613a3e00a7ecc4 GIT binary patch literal 966 zcmah|TTc@~6rSDfjZ&Zx+ZZsqA(6z5LsBjQ>x;uOh0?N%v$H`SNxRsFLYrQU#z+Vc zzPJWU1KCk|@E;i75F-!%q5cD$X^AxW;O-_f-#K%>Ip=(5o524<&#HQPr&26ARkhrx zR~mJ7t6WuUli?JyvR$_S#!M%t=aRE?li{n=6De8-0OY`>So#2n0tI+SZd9Y# zqA-=tVrZaMta(k(4e?r_ZDHcM!&7R#T!AI$l~WSs?9_k+fcMD_rEEi|Y18mp(!Lb& z4&8yY0oQnGXbA&3bj>2zCC?p7%)x1h2tgZ=AR_}#PXY%#k#8cKABBq*>3kP_{kbBq z4~`B?{%xKh|F+v_3)ks#RFd0gi5{r5&(t0mXrK0=V0*vNeJ@@DFme!#NQLuX2H&@v znUBVA0GfsO#)>Qr0B}_J9$W9Uhr2@nL;$!f=0=)@XfX<8zjy53({$5VOp9{iGBOsk zn81ZJw-`&7Ci{3Fhcz8heHju=ZNmGYcN!V6HY|!)W$E7&)YMqN5@dZ!i1%(#!-SXw znl@dtsiyStfQW{S4cM_;8skljCT?jFQ~+Q;AwXC(^OzF_QYKkNRKO!~scsX3jUIuS zBzyeSBtydSr@jw zhkV$Aa`$=WwE{lHFH1_oYblE28~0k=BY9u=%JaCd6O1T^w~EZBDJCduv3_xkXY<@P MDQ2VK^TgHFAD8YG5C8xG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST new file mode 100644 index 00000000..d60245ae --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-rank ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 9, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-rank.test ;; ;; Syntax: array-rank array ;; ;; Function Description: This function returns the number of dimensions of ;; array. ;; ;; Argument(s): array ;; Returns: number of dimensions (non-negative integer) ;; ;; Constraints/limitations: None (do-test array-rank-test (and (eq (array-rank (make-array 1)) 1) (eq (array-rank (make-array '(2 2))) 2) (eq (array-rank (make-array '(3 3 4))) 3) (eq (array-rank (make-array '(4 3 5 2 1 3))) 6) (eq (array-rank (make-array '(2 2 2 2 2 2 2))) 7))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9e3211ef304362fc0a11bcc01ac82ea64b8967ed GIT binary patch literal 1755 zcma)7&2Jl35P!S=NbJPMF|G+t8m}B$#Ht(B`G8gv7;C2@%!4M(u$U$2Nyb6-7SK{s)K~CoUW~L{vyzsxaeqOem>f_b~gL-K*sFWbcpp|(|D->M6%wGCmjwzW|x3ag+OK2Yp3GqRC$z5S=nSY~W8a~W)o z@7&@dH9|;%G*JWyi4YHQzG_57lNzQplg&{{l^3Y!>^Y5Y*o%}msO~iSMumE9U9yWG z7H!m_@k$y`WlVn|& zmn2=Yqy_nkrb}6MnqDJ!ZuRaG!e8i%@R-|orAPDJ!yDxG_w&4!Nc3@jI|TU_`cE=1 z#5-TH&R4Wqe)K*e(cP|>xzfY;!c8p<@Mtf0Qw#q<$X@9SEj-V2A^5!asx^p#fbS-x zmyl+;Fx0%y9h{2JPn<;Ww)!hzRXO_RK9{lj?EnBffJn6Bl}b;W8nEJ3n+IffAs4dZ zHg9_ohXIp6tyrZ}fmrB={0hkCs{mW8$xl|ST5Z7~(od`yur`nUE2ua`1-__BpysX> z1%K6`kB}*8w`9*0) z(-#bpaXj~LYf}?hk0$_xztzR#ojJh{_k=pc7>js%I%pJ7ZwI9T1zErohG_|lRM%k! zw7j{PH$~4&u&P&-)g`H=$2^=yB>mj<1-b}fUL3h0oS7sz^3r$Z9D*nSKkh*`5u(FB zC9msLJvHBqLk=fD_V*bovO(RjtOscB0eCuh=CC4r7ubl)nwlx+BqMvBBEi^s6ra1I z$}mN4)kUT&s4FI1@tP~5uHagN{O*chT=AnT9=qa!E53Eb0XzQ@OVrswkqu@bsnCKv zPu)xAGD}`$$w8J3Kn{EYNZ+Ea&8mp79*Hw|Ct)pF1k?TlOcml>test>17-3-array-row-major-index.test ;; ;; Syntax: array-row-major-index array &rest subscripts ;; ;; Function Description: This function takes an array and valid subscripts ;; for the array and returns a single non-negative integer less than the ;; total size of the array that identifies the accessed element in the major ;; ordering of the elements. For a one-dimensional array, the result ;; of array-row-major-index always equals the supplied subscript. ;; ;; Argument(s): array and subscripts ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group array-row-major-index-tests :before (progn (setq array1 (make-array 10)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(3 3 3))) (setq array4 (make-array '(3 4 5 2)))) (do-test array-row-major-index-test (and (eq (array-row-major-index array1 0) 0) (eq (array-row-major-index array1 9) 9) (eq (array-row-major-index array2 0 0) 0) (eq (array-row-major-index array2 1 2) 7) (eq (array-row-major-index array2 2 4) 14) (eq (array-row-major-index array3 0 0 0) 0) (eq (array-row-major-index array3 0 2 1) 7) (eq (array-row-major-index array3 1 1 1) 13) (eq (array-row-major-index array3 2 1 2) 23) (eq (array-row-major-index array3 2 2 2) 26) (eq (array-row-major-index array4 0 0 0 1) 1) (eq (array-row-major-index array4 1 0 0 1) 41) (eq (array-row-major-index array4 1 1 1 1) 53) (or (< (array-row-major-index array4 2 3 2 1) (array-total-size array4)) (>= (array-row-major-index array4 2 3 2 1) 0)) (or (< (array-row-major-index array4 2 1 4 0) (array-total-size array4)) (>= (array-row-major-index array4 2 1 4 0) 0))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0101ba7d8e5f1b94af0056cc451709df5266d8af GIT binary patch literal 1377 zcma)6O>Y}T7@pm=9otFVb#bgT7<=W2BCR?GCn*GTnr{2I9s0!@F)D=*igEXhrqOF|_M2N8 z+i&h|ZGL`5E55Ih-Cnx`!tye}V(IEaX=$ktUm>m;M0=^vVrg-?R9r5^PaZv#)Gk7( zfd=A;A*3P&`QLh~&Zx`qO4+2?BI{K54}C8Rwcwgd9p6hXX#MUk?leDbc0@UM_K<{- z|BV-2saXaq+m?SM-IJ#L2i|nq!c{1ZtWqRLpGOhVCEuGVzK0hvaU8ONnazla-SSO} z9zBfTM@Y&gRawybwe_qbJ>5Z%f2+v#i*rdS(#ZnVM(UJwBR!U8$I{&3wlK;J+Rr{g z=;Hl}8L9R3R$^c$01gk$2X^9jgbrI@+KGxRO@sL4Qavm3fj)}R6heb`LmT{zzCJ@j zdi#__w4Q?ao$TpB2*V@Hkzc18L{AC&TaS8IW!d@3n&OmD!~Kj}379 zP(&WIRME}vyo_$x*7dSzIbI{yb(1>yS{ZJvRaciIJSK->o=M#x%vi$?Wi*JT+jQo+OxlM<^|#VfY6?&@5Ur5C-Kt@BAG#$(DfC?lis6~_xAMypJY6$@Nd zrp9OyP<)J*042ugDxeFnFbSPHj_qK(#;P@@D=Jt_>BQQ=qkF;1_tfIK1&qPSct~tr zQtZwp2o$0p6H@@Oh7nN_VFJb=VA7~L4z(6ewSxD{0#!0)9a){gLN$-X%TQJ(MnUZHf2LicI#P>f!`{y5=jrUUnR?!vqN(S#BTE3!Os#XnNykdlXxN;ouP Qz%K*fZ}B|(Vd3QDUjrzOBme*a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST new file mode 100644 index 00000000..1658f86f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-total-size ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-total-size.test ;; ;; Syntax: array-total-size array ;; ;; Function Description: This function returns the total number of elements ;; or the product of all the dimensions ;; ;; Argument(s): array ;; Returns: product of a given array ;; ;; Constraints/limitations: None (do-test-group (array-total-size-setup :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7))) (setq array5 (make-array 0)))) (do-test array-total-size-test (and (eq (array-total-size array1) 30) (eq (array-total-size array2) 15) (eq (array-total-size array3) 24) (eq (array-total-size array4) 5040) (eq (array-total-size array5) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..019b065d5cc8a6d19089786a639d80c13fad44a8 GIT binary patch literal 1869 zcmcIl-%s0C6ux%&5%R0fMk7cwa3i&JUL7q!R~BAo+zX^}Y-T&nc$!cMOWKs65GGYq zQCDeNrA2BP9rbP1m;C|L#zUoQMS0jCviChqyiI#z=h%h;t+YLCN}}U)zVDv<-Q#m| zw@B|NswS$<+iUekwIwz;+G`taai!T3*P9!yN>yBexcG%?nDp+vq82jK*^qS%skEv~ z?dq~r??21cUVa+u8ZmJ9x3q^w>=#0|YF`_%0?$R^@yFq^h`9j|5)vV#Td$fprcmg)?;@1AXn)mtFLK1Hha$LpU zp^5=i0pcr3P?7XiBz+Z0Uq$l&QNhm~s)(YBx>t&XFCyWKNcbWW|DgzYL)VkgvE7Js!>HREy%NmS+pd^@!adHZ9`(=Kp23i+svk^EM|{J2Ae$)0Z=fh zRnly);gQ3HKnUU?ot94oV{9OB=0vt}pb9WeF^QU{Vai6yUMSg8AP%gEr09#X8%Kdo zN64O<&Tu~=tOrN(ZJe;nkf?{=P&9N#!Rf=pDK@$(NEla3rb+c<^UpZMQ0w5|MOGDy zdfT!vz}y~W>i35k{iiI6<_SB8<^fBg`GCEHX3)dp9>%*E*>y4Ujf;^7?A#re(jjTI zs1&HIV8uRSBN7`Kh7|l5AiWEwF{h(94BA5e<}y}%f(aPsk>%C~xBV0TqWW|^ES{bF zjiu2%KD`#Ijq$teJes!0s(L1Nnw)jXNPnrty)m7RxFH(0s=(gGlP z9z;c`MvGW-dvSqIK|sjs(8`J?L%nSPtSju|I2%i|OQY;!ij74<8GqL4jM~-pwwT^j z(&EYzTqet6ebu`MFt&LC5AeP7%-P149#KuI*c5a6gW|qJEpJm((JU558r19Kl3`Qt z@Q>KLm?Gt-U=k46dma*X5wi0dLcVl5ncNJ8rlQ{E;NE!cBcX>1H!WXtX4={Afg6Oo QfR=Dv&&j0Z>GZ+DUppclWdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST new file mode 100644 index 00000000..bed57802 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-and ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-and.test ;; ;; Syntax: bit-and bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical AND ;; operation and creates a new array unless the third argument is t (stores ;; the result in bit-array1) or in result-bit-array. ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise AND operation ;; ;; Constraints/limitations: None (do-test-group bit-and-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-and-test1 (and (bit-and bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 1))) (do-test bit-and-test2 (and (setq new-bit-array (bit-and bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 1))) (do-test bit-and-test3 (and (bit-and bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5788b48fefc4b78606058026091feea208d34307 GIT binary patch literal 1881 zcmcJQQBT`e6vwZfkS2tr&PF3hv*1Q*>AV^#KvxDYGwublI5xALW;{(Oge7fCPzaN% zsi>dQXBwDC}>T2UVQLHfRjiMMG_>>N8}Fe+^in-c5zp8vVWzk7VH z?>6cCMAbyKd3(LysJ6uBW_x|JEv`0O;zo0`RjG=r;1|D84U^toP}IWMOs?NLrc_$h z<#u&Nv^T38E6aDTh`A3$WxZ8zz|GVY40F?0$EPPJ$NJ|KOY^h+*% zXc9syq=P0xh(H3w{nimAn_9L!m)EGQD@7`~+pZIawa6ulny!-=7u(Hsxl#SR+Q8-9 z-XI(y?jt8WSJG8GZ|Lq0caIxzA3CwTE-%8;lzB?{a5oEP=UgYAyCzS{vw2%q^y_Ml zJll=mCxjnQ2t4xqQhQn8UaXNH_X~VEol0<_M({I2{67Zt_W^sd^CoYm=Z!+lP^bP9 zroDCl%sH<1;?sD?h{Nz;TYG54UlFoh``U;XcrFIFKMj{f%nf>&kO4wE^-8w$Gxzuy z5qIr~C|pjKGvy(8#@^-f(9P#J5B6Yq>-nvNy}|NOg9pbGumQ05YX0wEgCySsa-3rS zh$4a%0AEP~MXF1Y>Qbb-6siA*f}cI2h#^JYFGaEok?cYwyAa9$5CY!NM=9vpPE8B+uORAw?&tv<^3(!#-HKDn{qt9CsA7K$b3|9!QKIrj;q$;+$Ae+=Knb4!E*W@8< z$+BsY=OJRy-vz2h6}_}5&lzUXk{HKxr)S%S#G-*H2r;jnO;cIQ^)?N*dtd-W!K7A6 zv;CIG7$yYz!QZdb@(E|0MFM9}WE+Q20rpc|qNZt>vQe@ZOSTk9K-7Sw=u5KaM?lvR za(~;O(KCdwAa2UHafe-jL_vB((Qq&VgAguGv2mD&gbB4|np8jb1z;R%$U68}kyXW_ z{$p7bWNsfaMS9yAJx^H*%@cMW%>$N3^FDhA&7iL(e2w=svgc{!8&4w-*!epwtwY*a zQ7KSa!J2)@G7`%SLkfNrl)gpNnAdSM40LCEkC(CP6HGvb$2hM(_~1X_Llx3-!MJ|z zSC&Qd`1EY3IVyMA1vG6xuIiik>F}HvPJZ{o$!}g9dF`98PKR4eSYsC;-3^v40AK*n z7XWR5YP5*Ox0e>_6gY&u4o$6SGF09M!Me&WjkD1#yF9`!rP*i<==gK4Gh$aa+G2J~ z$%?DXaImb1^)>%YK;PCyT*MFV_wEihcSbd-VpGi7-7?cml>test>17-4-bit-andc1.test ;; ;; Syntax: bit-andc1 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical AND ;; operation on complement of argument1 with argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise AND operation on complement of ;; argument1 with argument2. ;; ;; Constraints/limitations: None (do-test-group bit-andc1-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-andc1-test1 (and (bit-andc1 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 0))) (do-test bit-andc1-test2 (and (setq new-bit-array (bit-andc1 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 0))) (do-test bit-andc1-test3 (and (bit-andc1 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..258b779c2e9022aef7fddcb568498b28112dfbc8 GIT binary patch literal 1881 zcmcJQ-%s0C6vwZfK=Xs7&PF3hv*1Q*>AX5>0$nM*%(xdwN^Wv|JQJExEX~XIk8{Q*$F5CYzMKgi zyx8G{CLyFkI%tA~2*gL6Z`*=oQ_GfT@*0(OrAQ@b%V`H-Epo}Crqhn)#8z`vZd5<7 zHgGw2)(J<5^SB+DDe0=6H*{y4yUz_ckJ^#EF3-c#lvzsnKsO6!=bUyldsQBnr}MU~ z=-1U8d9f3HKnS0U2|V(=uDvO6uU5zpdj-CnOvJeUhW|4{ygvqn`hY#&d7C%Y^M)a2 zs8fFf)82V->I_$V^=Y(YL}9qUr9CpDKNGT5``U;WcrF6BKMt2g%nf>gkO4wE^-8+) z6Zhl@5qI^FC{T` z$@{GZ%ce!1hloLM7pNLl^wPXMW0*xtVjRz%oNXHt3;V(#MBH{ZO=Th5+cenjz5x&g zlUgOs_F5ienBWV6Kcv(0F=vzoeW#CQ%R#6B`zb0>(=<%kDB1HRTk^#qYCux-1=;l@ zpwkwzf7_qoQ-m--ZpwFYhh2h1etJ{Ua4-Uceq5Yl<1h&cV`|AXsea@Oz&O;9b?~nu ztBOUv$FeZU+#X~K_O>&6p0Na)r|c}6hb)QaL-rn;K~IZ$8t-ak*VV{3u0|fRvv*li zhqRHRQlPSeHT#IAB$gV66#OVCeee5X4662V z$*`$cfXD28Op$a`FbM+K2c8mf6|!?eAzwP}%;YqM_M+ZF;hui29_S(ArqyN6OgYcml>test>17-4-bit-andc2.test ;; ;; Syntax: bit-andc2 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical AND ;; operation on argument1 with compliment of argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise AND operation on argument1 with ;; compliment of argument2. ;; ;; Constraints/limitations: None (do-test-group bit-andc2-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-andc2-test1 (and (bit-andc2 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 0))) (do-test bit-andc2-test2 (and (setq new-bit-array (bit-andc2 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 0))) (do-test bit-andc2-test3 (and (bit-andc2 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9ea46e537b353ebc180a7fd58afa8ab44c820f24 GIT binary patch literal 1869 zcmcIl-%s0C6ux#s2>CTKvarwN6yq)iD5VNx{} zb(N-7TBMfIQQuB|*&i@%JXESyl!yHxd*8#v+q5Tkj%^swO54MxBsxCl`|i2lJw7LQ zoAi9FYNFb_vtDmhTVivwy}sENSDP(yqq*6tRK-<@i=V58N$<@mYH@Tb7qLztl~#4R zU0o6F&FaR=^4%+9?z*U~x9Saen3w=JH+eNbIX*rbnNcjw%l40J#wN$EPv&6F;qzTi zXc9syq>HAH5P<}U^G!#PY--u^OhKcvuFO-(*>*Z%IE!4esOfZ)d9mGGmmAg3str8O zoejbf;ymtzXG*$i7YyCm;qG%W=TRqK(B%adAeZB^yVUY zzMFVJ2%k?1JgWJ*_NvIeTq8g17x{7~o#aA|;HQLmUnE3&KzXYBrs&XdGzy%7Zv7Q3 zd;3A}Ij;8dlSJ1@fP1j5Ju(u%5VBqS%19J>E)I`B4wgmC4S1N47$MzyCENXpdvZb% zckM_~xST2vl?Pytz02i+TQ6=O?16jx#jS(A{_;SBhli(N0|4Bwd7pnRB=sgCCsphp zspvx$Aik0Y6=`2Z+EB zA#2I9={(N^qu-kWRilbtT99W9bKa5|$8)c*whf6z15p6t*vyJ)DoeTJk-=sU!~hgb zYLztGZFrZ%gg^x15uKJ#1rw|<@Ybnpd7ug~O$mvbreVrP$zCYgQXmPen55`SvKvQ% zPDjX{na*f0AuNa^`3_Fl6-X4Mi;9NMFgPJRoMNM!frLr5WSUezG5?H147K+EU1U|U zsJAVP0?h40re1%T(SOF$Xr8k3Xdbc*nh)5!X!<=Y>0!K!kv$h9U%ME2$j;wo86A?w z=anM$s`?=tlGxB7q~J#Y=~*z1SslGW&=&DGm$BkwOu#sgEVnke?Vs=$71Hsrcy{hL zmPPaA>{_Tc#_zEUXxbjD>Y2n@a?T}_KU^~T-DQzqJ@e&Rvc-fob^%f?vTPBg1wir~ zh>B5-&SS~#r3E?x0imEnD=V4|^|k@9uChycHj-tRhuNhJ8;OH5{+!bpwyPU$F}tN? z#nolFOjgADns*OiZ0jN(;CtsgX9rt)NHwWqQ_SfPiu(?=f=x|Dvse^qP_LUM!=~Qh zAG7x`MaE6RBp|T&JtXcTWcM|MeBpFPC#NYi74cml>test>17-4-bit-eqv.test ;; ;; Syntax: bit-eqv bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical equivalence ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise equivalence (exclusive nor) ;; operation ;; ;; Constraints/limitations: None (do-test-group bit-eqv-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-eqv-test1 (and (bit-eqv bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 1))) (do-test bit-eqv-test2 (and (setq new-bit-array (bit-eqv bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 1))) (do-test bit-eqv-test3 (and (bit-eqv bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..50cbd1c778a0be394f595c6f6ce17b7e01530a13 GIT binary patch literal 1869 zcmcIl-%s0C6ux%&k>7JR8bO+Y8>yx9>PQK6h43=tULcFHne8;=X+j~4v?)O$Osb}$ zuF|whi_|hY>f5O={R5_rhf39o@~}T-?|YbdoA$)cu?+)SX?xg|M91fR-#z!c$LHj3 zlip8MO;nq=*Xxa1OKfho*EieZO0y+yG&ft-nz#aS@e9>3>D@U+EoG;2Ve14^ZPk|A zwPn%XtZghW-MJ#>CPihvRd2w<#00px!qt3Xd^{VTQ7p~N_K$1E3S*On{A4zK_-vOG znuL%l>7oe{B9H)azU>H-O)XoVDQZ;Km3b;T+fFA4XOYVmHJwf(FSeWOa-;Tnt%1k6 zy+JraoJXDDOj%d$qMuXqe>L zZu~wWd_E!YsOIO@S0(P{8u?+r#8=X(1lQN-`HT?ni-d45C{K3Z6dgW}Mu0Qet-pe0 zZ{P1f$F08nG~PAh;2vyi4~_UQglw;VZNy7F7lX$ihbkiG20Tbel#p({n(6+;JwBm` zyLO}~SV>lfD}%7d-sQ^R%@;Qh_Q1XM;?}|5KxMGO!^0D>0kHR0z0bcEl6;eplPdO) zRD@6kh_9wVMaox^@>QgK6{-J61wVbHB8DpJUMZ5kh@>wf>5EAIha%t&eUyTZ?XC)h zk2&9U(voWE*NfPE@|>by*Qg1t1rdGLlK2n{@j>|Y!LJuOJRzxytHRFUT{7Id4gf5peqOaEgs?8WJYdvT0KN#QZZ3G1NNncac@a zqTaSF0x-7^nfm=wtvE3RG*HA#j|t2 zu?(8WXV*ftF@Bd_K-2bEHP6J)l5;MZ{Na+x?=Fk{>Y1<3k}W2zu?vvu2FsK{S^y-^ zfv70e=scF(URngjHXQLT*d4yd`v(XqRUOYn_^CXP~3N@6>VxNn#CeWgL-{jHf-u0 z{t5J#OacOX-$P<9LUvz6$d^thTbQQMRMfj1+#9cbEc8g>mgQ^CPB}Y0aD#9c Q(Grg9Ih~X|ojN@H3*-$Q{r~^~ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST new file mode 100644 index 00000000..63f97d35 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-ior ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-ior.test ;; ;; Syntax: bit-ior bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Inclusive OR ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Inclusive OR operation ;; ;; Constraints/limitations: None (do-test-group bit-ior-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-ior-test1 (and (bit-ior bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 1))) (do-test bit-ior-test2 (and (setq new-bit-array (bit-ior bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 1))) (do-test bit-ior-test3 (and (bit-ior bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..97c5aa7f0a0b7046fb574eeed3a9f44584fa4ee9 GIT binary patch literal 1875 zcmcIl-%s0C6ux#sn%{Fa8bO)`H&RRI)kp!_((p3lULcFHGuvs#(}W<5v?)O$Osb}$ zuF|whi_|hY>f5O={R5_rhf39o@~}T-?|YbdoA$)cu@eSMrR`x;VjbV}eLnX)$LIL& zkb#d?O;j6qHfr^1Q*3OtHnv*gYNIJ`Hny6}RdE&k;^(Si(tGoYS{$3sg{>3FaF#AQcU@FAnzcIIOijTum%lQepPU>E&nlMYMf=BRCh`;4^OIM{!bi{d zIH5rZStcDcAwmS=BhEK%L9(f3%d-WI%DS>ZC1=NJ2O$@^Y*Eu`C&tBAV?(Z2KdaU; zojaR^BgA>!4$hW!)h-yiv&-G*qRyjstf0#!NKKiegb#M3V06xDhjZ8DNqMGV!zTI- z@_aA;fDnE>A@C^Yr?uBb?$tW^{-DTL(y0U&sQW)9#QP&5JOI*@oi}+i$KD8VhB~#^ z@YvfA&Yb1eUVRep7;#u0?r4vU_|JswtbJv~i#!*D+aHE2BE|+hNJx~BPHj2c`H_2a zLJ@bZrzluSRx*_#*kk`vW$4z++lTwGyp49SGF0c`<|$a;%Ug%{*Sz1q7Lt6EkdrD7 zdMZMw0>m$;Kt-ynBGpxq>Z(ZnKPvc{o{AW%sClJGc10w+B9dJZ$^TFUyrBiN6_tvRs<3JT)oZ=ESO~aIpvRx|Mk}mXr2amXTOy7((!)fDDvOV@}7_Fo=uyc9*f{6HGvWN19t5-1iUoN(FRG7qjPn zWmz;&`W}XYBXEzMN7M3XRnNrx*g2O?es|gAHNr&>^ua!$+AUI=L6aE zpesr>x`1`J7fW;s96~{depWOYif#j7U11l;*=Uws8etdHY%~Vi__I!X#IA0(#O$_` z6<3$wNLdkU>)vUAzU>Q`!VBj+XBYcAqncE)DaPzhi~AzAf=x|DvseUaP_mE8hE2Wn zAG7x`MA{9(Bp|T&JtXELWUmh)UpVct{0xQ8qTUhVo_nohp*@A$R#)@bw6p7nbA-Eq PmT;W^bWrka`snCSXEGmF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST new file mode 100644 index 00000000..c110bcfb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-nand ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-nand.test ;; ;; Syntax: bit-nand bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Not-AND ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Not-AND operation. ;; ;; Constraints/limitations: None (do-test-group bit-nand-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-nand-test1 (and (bit-nand bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 0))) (do-test bit-nand-test2 (and (setq new-bit-array (bit-nand bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 0))) (do-test bit-nand-test3 (and (bit-nand bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..348e302167158db3c459fa7879cb8521b9ecc40f GIT binary patch literal 1869 zcmcIl-*4Mg6ux%)Bh4=y=%O|YsTXPMFmtqI9V_Vzu6NspICim}g+8IGO-Z(_snQf_ zLaW9k#3UkZrK9s5+6#XGf<8=|Sd|C<5Z-w}eM3Bzb8NS?-6VJbCD!pd-*=C{dwh=X z7U}<3)kL**d#%x|wZ+y(XKkY+uC&_XdTXP-R1;SqE`F{WCcQhSsHN;wE@T};mfE$& zPHkDVH)`w4i+3)Gx%Wk7t=(wC&EzDwxx&?aVPYa1no%sx%l40Jt`sIN7cS?sp@U~T zoX{eKERi0XAwmQaAkH^kL9(f3%QHod%DPgflC$M>gRmF5Vo}rS#`9vQwI(-fpVgYU zo!je#BgA>s4bD__)h-&kv(4S(BF@8Zw5ZGTur+0t5!R(yVjpVM$6Y_M?mUY7< z&vs(>3E}f`fk!nz*I$;n7pvrly%JwdCF9&cv+q+vygw2`{h&P2dtEer6b%Dsq}O-} z%ig>{c!sOL_$1adV&Lv?X%CIqFNAE>zcOMao{PfmkE2x)a|0eEBtl59v6Sik#63Qy zh`V;EC|FHY)724p#_q-H$j#@s_IJU(_59}k?r?Ra$-~VPumQ05>fY~P3rW0A$Z-{W zhbo3p1&Citf{LWCBI&D0`YMwDj|zVJP(>6~G`vzId=Uv>M8X%5_zy+E8~QK_9owr5 zgpWGkc2kmS=+}$beDa*4U)QJ!tpyQ%){^)kHpB&sK-H+CSLWpz!z^18<9P1X)wUtAa3Bmo6q{KwO=Tf>G&0!ife3(t zNv(=zyAAJhm=Fj-Jfzd=iC~Nk1>QK3Ee})yrYR;-(=<%ksMzxrTMER16_FHuL3ZOP z(CG@fQ_~q9B!uQ(gvmX=t06jJcxfb`Fs#;lIsC}<1$50|mxSD1it9$9W}@UefwCu#t`HD!12 z+;1#{(Z{FPLbWk|mz_h?@mMv_#7>iQE}8t{lF9Ebi~Q=DFHe&#Cakh^km?4@lt5Yl zB+r4U2-RpAOKvaB(@6*jMIBmM(PXH%4S;o(UC6WX47)hSE~MCa6qNC2obH%iTknXO zO(i3)EW%;3EH+lXa{yzT=WzqyJKs6m*wSg$q>4>3r#~p}JJgCcH5JWbVWdI5KB^ct z^)~;Ay@M%IZVDy=fxYV?Q5PXQuOQ?Lr<*NIQ)nvc9S-h^*Ete;sBqKrHD{-s?LIg` SxbtWU$Mu~|N}f&~9Q*~I=N<(B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST new file mode 100644 index 00000000..8af6e987 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-nor ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-nor.test ;; ;; Syntax: bit-nor bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Not-OR ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Not-OR operation. ;; ;; Constraints/limitations: None (do-test-group bit-nor-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-nor-test1 (and (bit-nor bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 0))) (do-test bit-nor-test2 (and (setq new-bit-array (bit-nor bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 0))) (do-test bit-nor-test3 (and (bit-nor bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a72ccd2bf197190529aed1e9d7764455d5ae1965 GIT binary patch literal 1786 zcmcIl&u`mw6#v>uv;4-Hij`)ebt`om7LG{QX~;seMpM`XyYP;p8~Em`tW*jw731a! zPovjd?>9FDYtY=?SbysUp?FD)tB`qBPz&H2*ei>2bl zLj3sN9fs>7gc@i_MGPShg^>H9!-*C)Eor%|Vo8&$Sac6uCknYpbrTz|lUWe@-5sgZ zywU8?bgu6r1|jzYC%RnM6sxRj?jf_!B;DIis;o&hNKIbBh>ZqOXmrMPlEsVCqI9`z zNt$k0g&T!x8s!fztv|0y6o0nGW~$eI8xJ8VA! z!0B73o@H7O-$)PjG^j@h>TNy!H9`liclC6IWm53^`IJ3Pqkun(P!geGyCDp}VBSBm zH#0NZJ8JWG7M9&VXJ@ZH*gCpDZD+TroV2qY_QAEIk3oh&?zjBkzoxEjB_ars zFrBf}bYwUP6vnT~Dpf+DL}(_mMO8Y^8KrI*SUWM$gaIG(Gx#R|tf(TJ*x!~UsQXih zbSjums_&C2DsGY-72D(t6?u{efqwIR=&|QRKY2cMm*fXzsz-7Sa%KsFrK)lT`=t}f zb3CkL6JVaG8TyJwgZ)lR73?U{qMj!lwf{&_UO}k#JzO*qjb=y_X1*n}RJ=XDcEMlU zAOdy2?xQN6K);TIiyj#L;DOP1KI$7X+Z_j*gu6-voy@*WW-kD(5YSx!LP@ORDy^}# zR>N~(;K~{_s;o*-U<(}P44Kc9voT8MvFprO&E38*w bit-array ;; ;; Filed as: {eris}cml>test>17-4-bit-not.test ;; ;; Syntax: bit-not bit-array &optional result-bit-array ;; ;; Function Description: This function returns an array with all the bits ;; inverted. If an array is specified, that array is used to store the ;; result. If t is specified, the result is destructively stored in the ;; the original array or bit-array. ;; ;; Argument(s): bit-array result-bit-array ;; Returns: array with all the bits inverted. ;; ;; Constraints/limitations: None (do-test-group bit-not-tests :before (progn (setq bit-array (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-not-test1 (and (bit-not bit-array result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 0))) (do-test bit-not-test2 (and (setq new-bit-array (bit-not bit-array)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 0))) (do-test bit-not-test3 (and (bit-not bit-array t) (eq (bit bit-array 0) 1) (eq (bit bit-array 1) 1) (eq (bit bit-array 2) 0) (eq (bit bit-array 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..676f4ac6843385542c6e0937c2333dce127eaa1e GIT binary patch literal 1875 zcmcIl-*4Mg6ux%SF2CnM7qwYPy+~V!nJbcZtfViv-fbJ=+QoJj`h==BCE2p3N>ii> zts0XMlZdpHj?Q;zFZ=-r`Y>tQsyy(A@XiD38{(;)V<)90li&fASjYE#=YIaq@j1Rb zWZ+{}6V=A;jat3Z6dPNujjfir)@X{GjjiTNMO*{F__=DB^zOW(7RRTvA?pOP(yT1E zDyyQsRoPr!zH>#)zAq{p%~~C9rlw$-&0o#sCnv{4vx=p8Z2!1tB0u?Veqv%gbo6YG z6B>k&71BWyBt#%S;(XHIcEQk{UG5$iaUQm#1zlc*)RZ|&_&}Eh**T{j%3hNv<(Yyl8>X5i z&-P;X3E^{bfk!zntFMaOi*@qDL6I+~l5uXZ?*Eh!?~ehY0g#^Pyw00G_J$#5xKn!t z+upc;<{Vdj@ky*>#9(>2qdhcYKNGT3{mO_Hc`gdKKaP||pF~#E>@xszw#Pv?$LS=7J?Lj_3M!+lIu#zAyk$>}JI@m8I)d)cHX6 zJm`v0jV@r_?WILJ1rDL0Lq98;3`MsAu&%O8IX0GImq*#96dQ|zHvXK`9)I8s){+PZfdpl|ykrtrPIBv#57OxaVH$SZGh-w$;@ea0ssI2 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST new file mode 100644 index 00000000..8b3efc6c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-orc1 ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-orc1.test ;; ;; Syntax: bit-orc1 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical OR ;; operation on complement of argument1 with argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise OR operation on complement of ;; argument1 with argument2. ;; ;; Constraints/limitations: None (do-test-group bit-orc1-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-orc1-test1 (and (bit-orc1 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 1))) (do-test bit-orc1-test2 (and (setq new-bit-array (bit-orc1 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 1))) (do-test bit-orc1-test3 (and (bit-orc1 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3ae1a89ca76fce9ab0a74bb14f48f98974ba4434 GIT binary patch literal 1875 zcmcIlQE%H+6ux%SE=`)?Ko_-HXuU{VhnXXiWvrwxxZZ6W;@H7<7W#y$G$q-xrfO59 z39TBF5R-_sm5$DLXfON#1bvt^u__Pz5Z-w}eM3BzbL^zFWD-1p66^S$@7&MdIX=gC zhYWqBYNFb@z20cnHpJFedwr`duC_MB&DPdNwI;5DU;IopOnP@wQ46WrbkI71R5xnN z?b?cHZ`C$emhW5^)9;DO`bMJ(H#0M^Oy{m@sX5e z&-Nns3E?wQfk!z%)n6947i;AEg92Yk#G~AB)Bgz}-X8;kLm)lYeU*3e*c*bF@owWK zY;w4fc1gBSNDGZT1f0wLQbkU z=&Kk(6(GJE2Nm(2ig-^&yr&}m|ES>S`YOVxqT!Vy))NuyiHP+?#QsAO@P5JVcCnL!fF@(aR-y-Y|=n#5kTC+-(~Y3;99-gt40y(^Qty$1{W7?i&SA zFsW76Y`5dx7$*3F;1BAwa>^NDBfi&8v1K4sfN_dQ)HDrKHp+IXY)if^xwuabcPV-$C-QsC+sp1`RNTs!^IRVhA}zC#$^HsqiWeSsea-Ez&ONE>)2mK zRuzkSk7Xf%xdUJd^rsmePgxwz6Lt>G1C~JZE_)Nrn1@9@jCV1z?_%UD7b6eYxjQVO z18cab6sT9$_t~VxCMSS`p9W;8WEu-Pt|mZSr2ljoYkq|Z2=Ex@RtKN^2YjW5bxaqt z=YC~LG>->1L%|Wa%g&=|dto)tLtu zsh9pE_7+kkTnZ*Z0DId*!Y)Gg1`zVO(@Ev#D0CL}jtKYMYaa{kE8Mnvnp3mRt{=`3 R?gCoEasJb!cml>test>17-4-bit-orc2.test ;; ;; Syntax: bit-orc2 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical OR ;; operation on argument1 with compliment of argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise OR operation on argument1 with ;; compliment of argument2. ;; ;; Constraints/limitations: None (do-test-group bit-orc2-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-orc2-test1 (and (bit-orc2 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 1))) (do-test bit-orc2-test2 (and (setq new-bit-array (bit-orc2 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 1))) (do-test bit-orc2-test3 (and (bit-orc2 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b9d2379506e626be31b7025ce55aa96ee780d432 GIT binary patch literal 1869 zcmcIl-%s0C6ux#KAs+Gy6-#MVZ8b)zjVwbsP-*2Y?`E-pb_{6aNMdUr-q%Y}(z%sPhD*6IuG z`l4uW)Ylgm?pzj&ABxKATB8XMV`JbJ$47_9M@9;OJyxzp) z++HUfA?_n5GF8!4yJYC@Hg}IpxDTCVNtfr~Xv#Dtd?d(%**Vuq6tBu7@?^=DZx|+d zwv)O~2tS+_cvSOp`Bj;Fu|j^_EA!P{HqC{bU7r!+e~}RD2IZN~o1z0p(KvAWI*nJb z?5+DfXSwAUpQbuS3f%oI?V*wSg^;b~uZ>ih=aTUFQ-4*&+<-?2Nf6R$)bgF5xyQ#8 zaaRu&MXH(VK(!C{*u7NkyZQX){w}z;p5NNv?XC7Td3bmNHUz-EW&iW9g=F3&}P>~H(WCIo1Kt=ZdQNd3hsz{=WhF^+IAR-fp$OIxX|DgzYLmy|MV>`55)mUVlykIsmvFTMh2TblmJjL zsa4Tzui-ro6GAbF$8=gf5lpdY=*)?1!$1{ano<%qO~aIpial4crBE7J2}#lCWiO5b zT}LRMn$CC+A*>5W@@<^3%aEvxURN}92EhsA;S?L)93)Ju71N~pvH52lVyLzE?;@*; zMg47A9AIt_GW7(*jQ&%WMe~H6L-T;;(0st&LDTDFX&>V~jO=Pp^e)WBe{VkEZRj>b^;xCKo+2`NJcV-#r%j)i+gTN2KD-+V%XF_ z{3G@*rpS3Im;?m&o{uCwgzUVAkS|@QFg{74si=QBcsE}ANa&%$O)Jn`m~gkd;0EC? Qpd}pFbuuY=I&pCD7g|gnNB{r; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST new file mode 100644 index 00000000..a5beaa48 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-xor ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-xor.test ;; ;; Syntax: bit-xor bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Exclusive OR ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Exclusive OR operation ;; ;; Constraints/limitations: None (do-test-group bit-xor-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-xor-test1 (and (bit-xor bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 0))) (do-test bit-xor-test2 (and (setq new-bit-array (bit-xor bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 0))) (do-test bit-xor-test3 (and (bit-xor bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2025ec2a5adfe0d8bf7650fd6b93d7703d5a8d27 GIT binary patch literal 1609 zcma)6-EZ4e6u)+wEZ<8)RIw~$ZZ)(jnuC%Swgn;NxwmZ=#}2lG=@XPTC0}c*G({SS zYO2JS6lru7oA0J+h*x-EMFJHzVHtqv6ImP0u(FfcYf#No^yPBcZl~5 zSrO#Uwe?23))hLNz4gtWu-fSg8=cMWa!ptTUU*;Dbo#-9B$u);=Yqx&%W}82)T^xs z=4NeUW$F3_A$M7j*1L^1fJ>J^%@tnE7iMO%!8yrL+-(0DGhLX;74o@k@bLa^F4iH0 zERz9>03k8rA@;3)EMro`6z7Tx6;-KBGxm<%_d_pY)u6iFkLQJ6XI*U9-mSH||wSbtRF_SeXR$0go+HWlZ5ZSOmTz!QRMlTNj+4*#v77s&DBBxZ5=#GvsAoD$n7 zp5f~IZ$<}N6x4$q<)#+>iIAQ8$6B<+a}j{woU&3F2X;RpVL}Ft<@Deompf7t_heL( z-%2*WYaV?0ko;yPTQ2&=O160y?gR9=@N0l$E_`5(H=Dn=FzOb-mJ2_$##_klT?c^N z-kOzYHk(ia;I|OB05=czbigg-0nZ{v9(-Q160MQ{6yhPD0zCA;i_lGTqyF!||2?qr ze;OE!?`jHmX;6>h8~?nY&d8cNTg0^x7bJC7p*p;DVAOdd!~0l(_rlJ_GqPmL3!+ZV zst!9NJ4@#?77de@c^*8H?pDeQmDFlQoYVBOkzpLq{XN>$GA!f?fFT0wB}%$3ElxjO zVq8B@JN}GE?0G(sz*LM#-Z&iuqFSTpez~GJ(fA& z%-fL315Ki<#nLEBu6WfI)2=x0iqoz*=?KziryziQ%2MyK(;8%ol%*1N=XH^tnPg|; znDA$?cq_U#ucG!n6y(RT;v88FsV~sMnFVTh;3n{?*qqbrCu{;(@)3juMqvhvb(pZq zCM-5F5ALy|3JW4BA~b5k5R6%tmVggag_dzB=3<5BfjBvG92#C==?m=KS(Z+-b0_fd zZ|(kBv$oL_Cby(XVRZ>^*cG9%=3b7-Z9R|G+_CT3ySP=)$vTxxiU$vO)S0kSG^s8r z1`DAZboW|SGbs}=cH8b}3s)$-KI-0n&XwMKdg$o1En|3o_9`ZE9*%${+)zPD$Sd}) Zhv)ezP "initial" ;; ;; Filed as: {eris}cml>test>17-4-bit.test ;; ;; Syntax: bit bit-array &rest subscripts ;; ;; Function Description: This function returns an element of a bit-array ;; specified by subscripts. Analogous to aref. ;; Argument(s): array ;; Returns: 0 or 1 ;; ;; Constraints/limitations: None (do-test-group bit-tests :before (progn (setq bit-array1 (make-array 5 :element-type 'bit)) (setq bit-array2 (make-array '(2 2) :element-type 'bit :initial-element 1)) (setq bit-array3 (make-array '(2 2 2) :element-type 'bit :initial-contents '(((1 0) (0 1)) ((1 1) (0 0)))))) (do-test bit-test (and (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 0) (eq (bit bit-array1 4) 0) (eq (bit bit-array2 0 0) 1) (eq (bit bit-array2 0 1) 1) (eq (bit bit-array2 1 0) 1) (eq (bit bit-array2 1 1) 1) (eq (bit bit-array3 0 0 0) 1) (eq (bit bit-array3 0 0 1) 0) (eq (bit bit-array3 0 1 0) 0) (eq (bit bit-array3 0 1 1) 1) (eq (bit bit-array3 1 0 0) 1) (eq (bit bit-array3 1 0 1) 1) (eq (bit bit-array3 1 1 0) 0) (eq (bit bit-array3 1 1 1) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL b/internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6b8ee2cba35ad002d0376e16beb639860e5b06dc GIT binary patch literal 1854 zcma)7Pi)&{6#r}|S^h7nLIhQ5t!_wDR(GTg+vvo>b-uJ|T|3wgStX>cYE$xWP1UBL zX`-4oAubW4t(g36nvizjgb=F$Q8AQ5B~F~UaNxiJ35g3T7fwj!Jv;pe2v8iq-}}8k z-}|25XKxViRYet*=8ffQqr4(E*ILVKEpf5ABCa;qR_4p%BJkoZMK|c%ld>{Bd?g(; zk6Gqd%5$yqf@rOkR~P1P4vFcPMR|Fp+5m9*GN|dXmqx}inc-kgHdQyX4fUQL-6dqB z@~$48=D7&KPoFFGVn(q02?-O@sm}Lxo^a`7<@4c#^8KYm?Tgyp<0s_1QljpnZ%T;< z@4_8`f(t(e=yBnPrDU!4YaOFD0oGmkPAOSOcKap(q%G4kMZvD8yP@IQyR%l88A`aeMErnz1D_uv0+Sn{752JM^bh1Pc}F&vK%+I=ZS z*Rpw>A!$<9vMM#C@jNivgqh-fEWmqVK;tPzwvVnNF3#*CR_9MAnd+R{@jBm}?^!daAL!;oi34@Vw{RfwFlrddn~ouo#93bTL^ zgrSe7sA1@aq!+D1(MkzXa1EzqZB}x4EJQecGCTv}F`#_T>K8$agBCn0C^HO;+U;2S zFGnu`-D4g+ZwWj>zr*q#`kJhw@(U~v=FNgCD>N&?tkJ8Ip39lkS_V`2$YkjaB;d8EN(DWy zS=6Wi5s|Y~MbnbURXPi5EU&@%%Blq2w4l@G1WRS1S^>HzV?0&q3_byCwm?UKIDHV% zHC$llhuF{nJKx8K0=T;$?e>6GUTukk>++zuI0qk%1+lv1zVDG+e*w3&Yd^HNaQ6EZ zgUS}g0=g&3d7Nq<3YJxqh0qP!_i9nMsN0TD?Dp{3IE7iE?hD=dO0^CbJy>ns?5;oj zy1fNcCvdy~caPTx_f!4=+#{iI5f<cml>test>17-4-sbit.test ;; ;; Syntax: sbit simple-bit-array &rest subscripts ;; ;; Function Description: This function returns an element of a sbit-array ;; specified by subscripts. ;; Argument(s): simple-bit-array ;; Returns: 0 or 1 ;; ;; Constraints/limitations: None (do-test-group sbit-tests :before (progn (setq sbit-array1 (make-array 5 :element-type 'bit)) (setq sbit-array2 (make-array '(2 2) :element-type 'bit :initial-element 1)) (setq sbit-array3 (make-array '(2 2 2) :element-type 'bit :initial-contents '(((1 0) (0 1)) ((1 1) (0 0))))) (setq sbit-array4 (make-array '(4 3) :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq sbit-array4.1 (make-array 8 :adjustable t :fill-pointer t :displaced-to array6 :displaced-index-offset 2))) (do-test sbit-test (and (eq (sbit sbit-array1 0) 0) (eq (sbit sbit-array1 1) 0) (eq (sbit sbit-array1 2) 0) (eq (sbit sbit-array1 3) 0) (eq (sbit sbit-array1 4) 0) (eq (sbit sbit-array2 0 0) 1) (eq (sbit sbit-array2 0 1) 1) (eq (sbit sbit-array2 1 0) 1) (eq (sbit sbit-array2 1 1) 1) (eq (sbit sbit-array3 0 0 0) 1) (eq (sbit sbit-array3 0 0 1) 0) (eq (sbit sbit-array3 0 1 0) 0) (eq (sbit sbit-array3 0 1 1) 1) (eq (sbit sbit-array3 1 0 0) 1) (eq (sbit sbit-array3 1 0 1) 1) (eq (sbit sbit-array3 1 1 0) 0) (eq (sbit sbit-array3 1 1 1) 0) ; (eq (sbit sbit-array4.1 0) 3) ;; tests to see if sbit fails ;; on non-simple-array ;; ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL b/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b5f4a7149c02189f3b3762d7957e33db53d9de97 GIT binary patch literal 1417 zcma)6&1(}u6rbHRF=^7csiB0L#%=He7dN;y#TpMXuG2PVyBl{mjXg<8Qxl1%q^VHU zQatEoL8B-;ihA@WMZAbg1pff9-aUFy1dmeRBvz|d^fEJVe((L>=S&NEPpg`!*3U0g zYvqPmUurHaHO2XQLtLycHA-c19`40Us$r5VlUU8Ajw-#@CZyCT&o;|*qPhywIrD;4n4@qLLXM$)wY%-f?VcUABMP9Ll7XOnNNUyZ+!VC)5!_CDdkH03iW+ zkbBD!B%4^aJf78vtm7#nxh>c6LoRZ`BBtv^M#N@)L9UfAmTN4X^NWZ>$i31F_lDD#)#W^-h9?N({oh#_JLft>%3*m_#-@p9(vbs%7IgcLP z4P8Zu^G5`ph4-TJGRHl?fF8Zd@x}hZ2m0QFwhmM>>S(3sx;WH zz66#2tJ`*PmFH)|Z6gfgryp+TvRXW>Sluq56`1H2a+7?D(LtCO-x?1BjmP&*y;Su>VRrg$DSqTLp& z8o_!YFOM7MlqFG)=l-;|4T%Ol0UGf10l4FrE_Irx{1^|`SWj?ktr04CLR&+J0P5Wu zN&^&zISNa}G!0WW3UW`4dZq;N<0wtkZG)e zfWCm>V|inniJyTmq83b(=$j^=atwP9SoCMzRcw*2TN-5WGhmASZH$@16FS7U$KCBA z9lA^hm+8)PG=2+WfFvWMw ztWy;xy@hA#(^;CGtY6dQ#eWi6R5(M2r)hG6CKa#`ZSMJQy4%Z$Ke)~=yS&&GlPfqW z&d)_32jqd>rWdOH5-UJ&R$I*jfeTwnhN_@|r) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.TEST b/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.TEST new file mode 100644 index 00000000..cf7d974f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-has-fill-pointer-p ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointers Page: 295 ;; ;; Created By: John Park ;; ;; Creation Date: June 12, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-5-array-has-fill-pointer-p.test ;; ;; Syntax: array-has-fill-pointer-p array ;; ;; Function Description: This function returns t if an array has a fill ;; pointe, and otherwise returns nil. Returns nil if array is not ;; one-dimensional. ;; ;; Argument(s): array ;; ;; Returns: t or nil ;; ;; Constraints/limitations: None (do-test-group array-has-fill-pointer-p-tests :before (progn (setq fill-pointer-array1 (make-array 4 )) (setq fill-pointer-array2 (make-array 5 :fill-pointer 2)) (setq fill-pointer-array3 (make-array 5 :fill-pointer t)) (setq fill-pointer-array4 (make-array '(2 3)))) (do-test array-has-fill-pointer-p-test1 (and (eq (array-has-fill-pointer-p fill-pointer-array1) nil) (array-has-fill-pointer-p fill-pointer-array2) (array-has-fill-pointer-p fill-pointer-array3) (eq (array-has-fill-pointer-p fill-pointer-array4) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.DFASL b/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9bedb1f77bd69948319ea732db1260d50dc63450 GIT binary patch literal 977 zcmah|T~E_c7(Q*;7aOAxFu@O~Bx+JUB*PIAjmfc`!A954wsUg1jN+CQw(P^i7?E&c zyqLj3B&`PTy)(N*j9mDK_7Ctqo8rU^(~F+>>v^B|dCzGf-xEcZl=4QUQ8X<)7b@Vs|A{sg@i# z%+G@vTbP?&h{tCJ6U0<|X#cIby%2}8`I*7f!vjt%BZLa*g#AJYiAX^1UQ?7UYFapv zR4LX-n#yj=Z3bZ$oHeQ8Hb-Wqdbxrf`<*q|T~wUWlbS^hba)Wl0V=fv<$8%9f7y@3sn9$iS{{D^uXLKhJ z<%&n&H8^)#D{r+Q2(^l@wG_`m(O&V(cy5f*fN&6@2tp^N!i82*EQyHsx$m2oWkuH( zlWbbNOteLn8u(!nJlc{e^8+B`h^!DxS;hvnvIfYYbanKbtENTMJoj&grORGe2ta^; z96QsTsU-xv&RK6*2zeo42$YS=)G%}d>sc$4wPYa-84;OitGMeoWe+44W9K#%@FC<4 zu=RwP(0c&nPv}OPSj^mIoRq9#P_1wM9`_3TV}Hg~h)H{0yl@5(BKZEtc&$>2Q*M11hM)rmqknZaavjKO@uQ8fx-kZDu)?Y0r zyeXamy>XjUmR+k$(_3U(TF=AlT9Znfy@$bkTh}=Eqr1;T!%4-U#G?4zRB95gAyG{) T%+jF$qpWUG?+W^G{q*!FqzNGY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST b/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST new file mode 100644 index 00000000..6cecc824 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fill-pointer ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointer Page: 296 ;; ;; Created By: John Park ;; ;; Creation Date: June 13, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-5-fill-pointer.test ;; ;; Syntax: fill-pointer vector ;; ;; Function Description: This functions returns the fill-pointer of a vector ;; ;; Argument(s): vector (one-dimensional array with fill-pointer) ;; ;; Returns: fill-pointer ;; ;; Constraints/limitations: None (do-test fill-pointer-test (and (setq v1 (make-array 7 :fill-pointer 2)) (setq v2 (make-array 7 :fill-pointer t)) (eq (fill-pointer v1) 2) (eq (fill-pointer v2) 7) (setf (fill-pointer v1) 3) (eq (fill-pointer v1) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0511c4e59f786397adad60e2a12d6fda6ee1dae2 GIT binary patch literal 1965 zcmb_dPiP!v6#r)SPd2;R?WCk3-KOazHPVco&`lFeA_|kqmt@_^%sMlh7!OKFHty1G zH*7Wqk%m$!A}q!jtn;<>;6V_)=z1zf_8@o>#DgcnlUEN5;yJ!IUy@DQfP%6tzu))X z``-6^-@G@oLqf0XhOC!wt`|%Bid^2Tu5VW5wQ@z?C~sC)^70zk<#%<dLZss>um*2T6rzT`=y;3Xz86SsbYI1C3a&&Y!I-@xT&-Radu1}7R zOkSH9j_yBxAV_6G$O>s7v=btc0P#MqNs3DySDi^4R5i7Es(3qIEdsTuIfvR_t#d@K zmeaJz0Su0B(KZxEVL>%mtL=^OGVJ{;*xkc*VWyHl~vQr3`+TJDvT>zzUGz8ka z8>L{&SoCc@Cu}9rH_DCT9t57f*LF@QJb5e8uoAFr?ikxv;(J1N3h!Hqj3~r`eszAa z_u!NWAsvJ?iYtAMuZ8!HsS+}Wsv?WsaCN0{vp&IDs99Gz3pVThoCTWobDW9IPknNu zdAD%*``5y{PZM@r)lY}2+82936;@auY|)-0%8nQp@xMtB#||aL7iGMduBOLH94h{A z$3Qu+CLw2|AQ3U{eNyXHbjzGhW6P;?nmKJyTb)XS#hi5%v7NPx5%`DUAA-K_RCLYN z=Tw`zIUD*?_ZvIxEIBTn7e$EZ;+?M>R5No~b;h#i9fb*^@a%5aQdley14pdY!l|Q4 z!5$BEob-+`DG+7tfdmXjLZP+|eQ)L5Y|d2zXCSmg(aa^)x8tb+>E!n7O!8_{>Z#d_ zg$ZFn9JpQ_o=cEBNEb8%7iVD+#v(Kqmv}~}p0jOg9-D3^pbzK1t96;W=1{JL#lS86 zg0tMJ6HPxdJW%+Ook#eBB@r0AfKcGRH#s;Q<~Us88wUA?Zhr&$-S?4SIsDAw2M&82 z>KwNH?WD$%ci06RWzB0Ds%o~aExpVx4zY`UBAK~*;w!_0j*N03-xX%M`bGQNVg2n@ukxy~HfL!N1gM6Cv z0pL%|OL13>=NJ9Nwkmw8&E|DyuJ;1t)@+v+7t{@+Jr&T3>BWT z3mxE$v!N7IF0-Ltrr<-y_wyw;zfqM3wzL6xZ5h5!t8(!c|FEEKYY=Pw#(U)L;Nb zoTAXjlz(mfPiXZ>=%Kcml>test>17-5-vector-pop.test ;; ;; Syntax: vector-pop vector ;; ;; Function Description: Vector-pop decrements the fill pointer of a vector by ;; 1 and returns the value designated by the new fill pointer. rwards. If the ;; fill-pointer is 0, vector-pop signals an error. ;; ;; Argument(s): vector-pop vector ;; ;; Returns: value designated by the new fill pointer ;; ;; Constraints/limitations: None (do-test-group vector-pop-tests :before (progn (setq vector-pop1 (make-array 7 :initial-contents '(1 2 3 4 5 6 7) :fill-pointer 6)) (setq vector-pop2 (make-array 4 :initial-contents '(a b c d) :fill-pointer t)) (setq vector-pop3 (make-array 4 :initial-contents '(10 20 30 40) :fill-pointer 2))) (do-test vector-pop-test1 (and (eq (vector-pop vector-pop1) 6) (eq (vector-pop vector-pop1) 5) (eq (vector-pop vector-pop1) 4) (eq (vector-pop vector-pop1) 3) (eq (vector-pop vector-pop1) 2) (eq (vector-pop vector-pop1) 1))) (do-test vector-pop-test2 (and (eq (vector-pop vector-pop2) 'd) (eq (vector-pop vector-pop2) 'c) (eq (vector-pop vector-pop2) 'b) (eq (vector-pop vector-pop2) 'a))) (do-test vector-pop-test3 (and (eq (vector-pop vector-pop3) 20) (eq (vector-pop vector-pop3) 10)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..761ec79bd43655c3bbfd17bd0937d8962d3470fc GIT binary patch literal 2137 zcmb_dO>7%Q6rQ!?*p8FNNz>X*C|MN|$cByN{4{M4g3V?eZ(^_A-E|UIAQTb@8{9hN z2em?!&;yl_`EjeZ9->GUa6sY`EG{Kgi_`-g;DCe#Hx3Ai14t{C0}_Yu-mW)JTc8(Y zS>N~G%)EKun|ZTk;+d7>yj(oBlrLnL`QqB@(%LG&SX|~;ifhaBS$+}x{A+Sjqp!y# zd8+@(NRz&2WPUk2x0+qxjkWB`!ra*>_{ecyT3XH*fE+spW@L1DV037xzbPu|aXZ=r z*9?vh4U7&P?Qh!Iyut;Ggphf13&BrFkhn?ZVksyXR5!$^5~rdnC8$s-S4uw6BBph! zRZ49G{AzJYEM#BJ7EsQq6~YlxdB5a~rd8Qcl4|7=x6USftH8GXeVuxGU*xtYx$CFN_Kiu`OnYY==P7t! zBqR_2f~Uzt$W8U77T{j9ItD%!xyP&yIlR%V_Bb5ogdOfPE477p)^pBp8%EpDd-rj< z>o-;4W_juz^)?~p+*|6Ti-XwZt%EZim=}!t2x%tdR(}4VRli!M+?!6O-g>5uR;IXj z!4rTCA*+*h3-X$*TRyWoTDSaWRj6AnX0@|!1sn~{rlSDy|4`vtaa8y~CJF}eAAUxz z?rO^KN~)FrEGC8=1ib8UNdGy9L-I+72h6IZ7Q!&SI^y`kX0_MhhsckPFXpxm{KLVObHRKNFXrXaLxP-C#}&N2VoXxU<5UyJ6!54My5RCMzsm#v z2565qL6!_TCTi43YjC|~t3Mj`jBe0`i@Se@krY_K?Pq>>3$(;OfodAu_+;8hr47Ly zfCbHhq-I3RuL}%%qiyis7W2CaVGY<=k79E?3y~V5Ni886Xl8I%Ijw0_-P5>?!!ZTM zI_lzNNvHN!EP%tU5Gk;y3(?oW4ghd}+VGnVKSPy*IEt;k%E^;H#DfdNKd4tIF4O_v2a|` zQ=&DV0Hu<3T1F;CaYCN8BP_E02s5k$p$AsATJgnk1=i?rzUV(}=g?{cX92lm!!I`c zV8gd83=7CdR&;XBicZR`;|120VW9*INh~zXLcOf(5f--2W*Q0}zP}zKzI%haZz)<3 z*!47I=&_C-tr2)e8&y146z%F`JObVkH$08(Fk1LVb0;m%{ee7V^IwtA+WdRu)aG9! zx7Ttvkju7z3;CGMKSnOud;@Z5hS&eDL%s^m7HNDktsBx<+$#7ytob*c19qqc>xPUW z5tP9lw;_akMePZGh9x6^u^xoq*<%PlvBwdqFT5k4+<1OmcyBzrpww z#;2jQjZ~S488HQ@SEti(Yhq7f#dT%Yh((Y^m8cOr%!EU%&kH-a;0xDnWLH-CBj=cml>test>17-5-vector-push-extend.test ;; ;; Syntax: vector-push-extend new-element vector &optional extension ;; ;; Function Description: Vector-push is just like vector-push except that if the ;; fill pointer gets too large, the vector is extended (using adjust-array) so ;; that it can contain more elements. The option, extension must be a positive ;; integer, is the minimum number of elements to be added to the vector if it ;; must be extended. The default (*DEFAULT-PUSH-EXTENSION-SIZE*) is 20. ;; ;; Argument(s): new-element vector extension (optional) ;; ;; Returns: vector-push-extend ;; ;; Constraints/limitations: The variable such as *DEFAULT-PUSH-EXTENSION-SIZE* (xcl) ;; is implementation-dependent. (do-test vector-push-extend-test1 (let ((vpe1 (make-array 7 :adjustable t :fill-pointer 5))) (and (eq (array-dimension vpe1 0) 7) (eq (vector-push-extend 'fifth vpe1) 5) (eq (vector-push-extend 'sixth vpe1) 6) (eq (vector-push-extend 'seventh vpe1) 7) (eq (vector-push-extend 'eighth vpe1) 8) (> (array-dimension vpe1 0) 7) ;; vpe1 should now have been extended to contain more than 7 ;; elements (this is implementation-dependent) ) ) ) (do-test vector-push-extend-test2 (let ((vpe2 (make-array 7 :adjustable t :fill-pointer 6))) ;; In the following cases, the array size should increase by 5 ;; so that its total dimension is equal to 12 (and (eq (vector-push-extend 'a vpe2 5) 6) (eq (vector-push-extend 'b vpe2 5) 7) (eq (vector-push-extend 'c vpe2 5) 8) (eq (vector-push-extend 'd vpe2 5) 9) (eq (vector-push-extend 'e vpe2 5) 10) (eq (vector-push-extend 'f vpe2 5) 11) (eq (array-dimension vpe2 0) 12) ) ) ) (do-test vector-push-extend-test3 (if (string-equal (lisp-implementation-type) "xerox") (let ((vpe3 (make-array 7 :adjustable t :fill-pointer t))) (and (eq (vector-push-extend 'a vpe3) 7) ;; fill-pointer is already 7. The total-dimension of the array ;; should increase to 27 since the *DEFAULT-PUSH-EXTENSION-SIZE* ;; is 20 (eq (vector-push-extend 'b vpe3) 8) (eq (vector-push-extend 'c vpe3) 9) (eq (vector-push-extend 'd vpe3) 10) (eq (vector-push-extend 'e vpe3) 11) (setf (fill-pointer vpe3) 24) ; resets fill-pointer to 24 (eq (vector-push 'x vpe3) 24) (eq (vector-push 'y vpe3) 25) (eq (vector-push 'z vpe3) 26) (not (vector-push 'end vpe3)) ) ) T ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b1a05adfecb9c958467084170d2e7dfe4fc05c08 GIT binary patch literal 1259 zcmah}+i%lW7(cd~Ta%`4#io%~#p+h1S-4Vq(Vz&SGjl@Hx^`xt)T?-^+H?srq)O8v zw1KK>+FpWKKp>w1dzhw4yspH>1{*V0uJViVsmG4Wq1ei4C;pBJuzT@v=w@Bnm z)6&e^rLAgEu4}cO#@0?l+pN{K?b=R#y{v5luYF@WF1wbe=F;@(?4Z}Dtk=tHjq--Z zcgouvYgbQb*;5+bs#gQ}bMhp>?85xa!ra{SV2*lLFWdjd%r4A9%>4A=;e)%9S|fz4 zlP7p22vLbb!dp#M=gi|qu3$04rprtZTVXQ}wHPIjxnXl;Mr+izjG+8=Ilyu*Z4-%* z@W*C6SF%lBaP085v@4~;o6VtuZ4{w2dY%zE{xS<@m%^r+{mhs*R+z~h*C>{}Jb7?8 zu}6qBhL7`CpKy^602P+B4ioaumW^mEG!Y<-dOiU>ebRAYE{&#O5{j*r#Y^hj(x6xoi_5+K4&r4_`Cp&ecsdM0T|(kZc=XM z4VUqf3nMVQGmLtx9%sw4^uB{Tx=1Q95E3gzgSswV&AuKx4or#nYcpb4N%Rx5Kn#h5 zl7ykBb>_M-Q>Vm>C9W$eFs5{BuNqz6(?xgs?<`R)N{AT1%}L`D3`3%5&T*G1M~FE_ z%#!OeyKggv1R8k`+L1RMF{#ITH;E+5k0DdCZ_SWv1DApYw~V4wusL&)d?+$_w8R)5 zKZs0CWPCBUBr<2fKD11iSg$kFVthi34}(j>Ca8VM4eXUbi9Ca#NVj4{PvQND+E|Z; z@LzEZkA3jOJhlQ=;ZF3F2I~!W{a_^IY-1R9bycgboASGRm3p cPD8B%bctG?NTLlY`=aDR literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST new file mode 100644 index 00000000..7cc60c4c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vector-push ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointer Page: 296 ;; ;; Created By: John Park ;; ;; Creation Date: June 13, 86 ;; ;; Last Update: Jan 7, 87 ;; ;; Filed as: {eris}cml>test>17-5-vector-push.test ;; ;; Syntax: vector-push new-element vector ;; ;; Function Description: Vector-push stores new-element in the vector specified ;; by the fill-pointer, which is incremented by 1 afterwards. If the ;; fill-pointer is t (i.e. size of a vector) or is incremented to the size of a ;; vector, nil will be returned. ;; ;; Argument(s): new-element vector ;; ;; Returns: vector-push ;; ;; Constraints/limitations: None (do-test vector-push-test (and (setq vp-array1 (make-array 7 :fill-pointer 2)) (setq vp-array2 (make-array 7 :fill-pointer 6)) (setq vp-array3 (make-array 7 :fill-pointer t)) (eq (vector-push 'new vp-array1) 2) (eq (fill-pointer vp-array1) 3) (eq (aref vp-array1 2) 'new) (eq (vector-push 'new2 vp-array1) 3) (eq (aref vp-array1 3) 'new2) (eq (vector-push 'last vp-array2) 6) (eq (fill-pointer vp-array2) 7) (eq (aref vp-array2 6) 'last) (not (vector-push 'last2 vp-array2)) (eq (fill-pointer vp-array3) 7) (not (vector-push 'seventh vp-array3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.DFASL b/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..78d1b3d153cbb9fe515622490aa8d757ddec4763 GIT binary patch literal 1792 zcma)7OK%%h6uvWl#Ch1*RutMODnmkejF?DvQyRjC>+wx8@p#6}11FUbiX5kL>(-Iu zAn|BaWdRkkC?OEdrK*q+J0wKAizxDbsj8@4qVLUYF=jyU_$;VFA?K;)VR;{QTU=61DXp+keKKU!2b`Ubr|na(eez zNVf>YaD1oWb~HnY5LCNFhbJ4&QZR#FA^Mj%FI(k#JKO^KN&OnxRynHM-1*m)Pv{H3O4Y#5! znO51BxgZMvj&@9$k4A>UkqY?1iUC6&GZ8ryN%G;yD1uB&Th~eF>(q!7u1CKeNftx_nYbaG91^Fp>#C3pc5bO)R^Ck_08HnGW?;@)v&r0?40WjX5i< zZ~h(hAy%<9-82H=ZvpUE1Qwaz2R=ld>Xnr+-(djz49a>&Gk}<|_;89F0G(1TMjdF} z0MZP+E@6MGe46r^JfE3`_+$W}1)ZG(HQi4Kn{!|(b^<%S>UE!U>bo6jdY?{9TO06d zZ%U2p!Gnvo{aNhq2k%IX#8CRwm)hPPIH90(VL?yOLDw8+QQhXF2!nyY<(dxT)9-lQ zxy1qlp0VI{_5U(Dj|=GEyl;oK%suZN0b`?FhRdP_f514hWm+!7$oMPhdl`L~`o4%S z@R!i@B4SIlQUNTK5!Y$CP^5eolfqIBSSp@tntu+NWlgnkV}KPa+9VVojYj=mc^(vg Mo==mnOQ)xQ1Bp5vI{*Lx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST b/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST new file mode 100644 index 00000000..7d98cd49 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: adjust-array ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.6: Changing the Dimensions of an Array Page: 297 ;; ;; Created By: John Park ;; ;; Creation Date: June 16, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-6-adjust-array.test ;; ;; Syntax: adjust-array array dimensions &key :element-type :initial-element ;; :initial-contents ;; :fill-pointer :displaced-to ;; :displaced-index-offset ;; ;; Function Description: Adjust-array resizes or reshapes an array according to ;; the given options, which are similar to those of make-array . ;; ;; Argument(s): ;; array: array being adjusted ;; new-dimensions: same rank as that of original array ;; element-type: same as that of original array ;; initial-contents: The elements of the new array that are not in the ;; bounds of array are intialized to this value ;; displaced-to: same as for make-array ;; displaced-index-offset: same as for make-array ;; fill-pointer: reset for adjusted array as specified for one-dimensional ;; array. Original array must also have a fill-pointer ;; Returns: adjusted-array of the same rank and type ;; ;; Constraints/limitations: None (do-test-group create-and-adjust-array-test :before (progn (setq original-array (make-array '(4 4) :initial-contents '((alpha beta gamma delta) (epsilon zeta eta theta) (iota kappa lambda mu) (nu xi omicron pi)) :adjustable t))) (do-test adjust-array-test (and (setq adjusted-array (adjust-array original-array '(3 5) :initial-element `baz)) (eq (array-rank adjusted-array) 2) (equal (array-dimensions adjusted-array) '(3 5)) (array-element-type adjusted-array) (eq (aref adjusted-array 0 0) 'alpha) (eq (aref adjusted-array 0 3) 'delta) (eq (aref adjusted-array 0 4) 'baz) (eq (aref adjusted-array 1 0) 'epsilon) (eq (aref adjusted-array 1 3) 'theta) (eq (aref adjusted-array 1 4) 'baz) (eq (aref adjusted-array 2 0) 'iota) (eq (aref adjusted-array 2 3) 'mu) (eq (aref adjusted-array 2 4) 'baz)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-1-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/18-1-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9f6a81ea1f2e4f9da7e2b6a49d9d5c4b1605a899 GIT binary patch literal 3863 zcmeHKeQX>@6`$R^bIxbq^&DF!KAChe`O?K}#jz`l^SNHHeHX8HFS~oa8br{=KIbmJ z*yip`D1{J$N*n34tz&BKq>Y4H6$Db-#Og=V79FSpQGvuCsFnH$l`2(KijXkMAAmqL z@6DVqA5?$@f1>+%^M3C)Z|1#uGqbx)0uQOWq%NFUEEIDkX<@0dxKxp57fMojVW~8o zlV$;z9#Kt8`({E>C;ATbhwM8n)1_RtlADp7rCfO?`*5$+|9MGSEES5-7#ae#fB1p@ z!-Io;p)tkQxwn7YXJB}6V7Px@UufgXst{cugiMnfie^Hh#7DeK)o9$&Y)2kT>Y8jQ zlUm$c_NqaMMNZqAS{X=rUtR@tTTv=_qK!`ux78P+SZ{**c5N^ziAOB=R%xsIb z2~DTi{MNcbHoh?7d@Kgv*s<8_Re-T8sG$9y{y)l0y)dRbScx=Jk8mger6X;Y&U9xj z(*Y~epkz82p@$KsW3^1|E^7>kh0qpov7=TDH+rGthGo}1E(>UZAGiiz(|c;rhQ`_$ zmtT(5%*Z7(@+eoIsrw2OQoGs%7<>_e%y0#|{);Rj6}uMR1oqYoTe^h&4K@O(>&yBR zX5=kGmh+F9kqJ=%;_}t5Om}_AAR(>Tb$Wa4ns64udPVzgZdPY62wBmptT?YJ1E&0-V$0&x1Z#Z|>o6SAc_X$wv-l^uUg_LS{tlcETW4t_qWx~3TE zlsslylXjd6qVUhX9Wzc_d|@y&*~!V2t~HKQJOq6$U4 zMid9tBjBw~OJ)T99evCez4!Tzi9S zKjvDM_C7-8FVS9|%6+u=(^NhI4*ZyiK*}=54b%?8y0_zs%Z6#x7q7AS{+)CelDgq( zqshQBV^tTT`vCP_gRW85_1=EI%dDSonG-K?kq0l)qyeV_tN>J^1669Hqa4hrg;xxF zKtb#zkXtofo5WIfrc#&~Uku8i8Anu9N3#GCe-3j9vpI}gW;(@6R(z3-E+IMx`HW7=RDMkjOJl*hyzPn!;oC7z%=QG5|VKUN+p7AKB#F~r3_E_UFA8%Kcb znAkx=5KjO(WhNnDHfPLc7|wvS?I2mWU}m&W$cp`A3=Ll4Jj47a_1$gAG((02R-6cp}1==UwB1@j| zj<>SaO#o7ML+~GRXCbjg_=Ma=cY!6j;^y2E_z_-)=~m9dFsS^ZT<>U+H5PY+ta^cJ(yn9OJN~th^3X>^3&SPVHZi=_rev0!p k?ilhn-e!B^*SyWD{t9nzo9D9Y2$wPc-78Hl&unb`11|g;EdT%j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST b/internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST new file mode 100644 index 00000000..1e3948a1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char ;; ;; Source: CLtL p. 300 ;; Chapter 18: Strings Section 1: String Access ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 24 July 86 ;; ;; Last Update: 19 December 86 ;; ;; Filed As: {eris}cml>test>18-1-char.test ;; ;; ;; Syntax: char string index ;; ;; Function Description: Returns the character index positions (counting from 0) into string. ;; ;; Argument(s): : any character string ;; : a non-negative integer less then the number of characters in the string. ;; ;; Returns: the character at index ;; (do-test-group char-group :before (progn (test-setq simple (copy-seq "This is a simple string.") arraystring (make-array '(13) :element-type 'string-char :initial-contents '(#\S #\h #\o #\r #\t #\Space #\Linefeed #\s #\t #\r #\i #\n #\g)) twine (copy-seq "twine") displacedarray (make-array (length simple) :element-type 'string-char :displaced-to simple) fillpt '(#\H #\a #\s #\Newline #\a #\Newline #\f #\i #\l #\l #\Newline #\p #\o #\i #\n #\t #\e #\r) fillptarray (make-array (length fillpt) :element-type 'string-char :initial-contents fillpt :fill-pointer t) adjarray (make-array 10 :element-type 'string-char :initial-contents '(#\a #\d #\j #\u #\s #\t #\a #\b #\l #\e) :adjustable t) all3array (make-array (length simple) :element-type 'string-char :adjustable t :fill-pointer t :displaced-to simple) ) ; test-setq (test-defun stringchartest (string index character) (let ((stringchar (char string index))) (and (char= character stringchar) (string-char-p stringchar) ) ; and ) ; let ) ; test-defun ) ;progn ;; ;; Test with simple strings. (do-test char-simple-test (AND ;; The simplest case (stringchartest simple 0 #\T) ;; See that it goes past a line-feed (stringchartest simple 8 #\a) ;; See that is distinguishes upper from lower case (not (char= #\t (char simple 0))) (char-equal #\t (char simple 0)) ;; See if it treats 1-dimensional character array as a string. (stringchartest arraystring 12 #\g) ;; See if the setf/char combination alters a string destructively. (setf (char twine 0) #\s) (eq (string= twine twine) (string= twine (make-array '(5) :element-type 'string-char :initial-contents '( #\s #\w #\i #\n #\e)))) ) ;and ) ;do-test ;; ;; Test with non-simple strings. (do-test char-nonsimple-test (and (stringchartest displacedarray 4 #\Newline) (stringchartest fillptarray 4 #\a) (stringchartest adjarray 9 #\e) (stringchartest all3array 5 #\i) ) ;and ) ;do-test ) ;do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL b/internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..415202abe058baaa03f98be7bc54bac5534a58c8 GIT binary patch literal 1670 zcma)7&2Jk;6rZ(Y<8L;>DyfO+(j*Ant|d1qN<%AkvmGaH*1Ox?HEvFoNu1b~6GvVL zgepQ632|9%n}$X^RK0QGfK+-2Diry^l|O(3M-Ciw;2z%FbxKr_Kwjz1`$7W~VL|5=W2s zIle;(StflHaYA?!Cf);w&s)^A#8O$IqAFEr-rMz@7~~>WO=@_~@CBjQ*%aH2j~Z=E zXWb?oA>Mr_R;sG9Rn}B*kGspIyn9Z%tcp6MCe2e4iVaS|(>c#c7iYwxXvzzcK_2fX zcL?Dw5Az|!@?-P)BKK^Act0(MYNv9;T+|0T;saeHB>2#lh(H3P#|bQF``|)*nvj0$ zIVdALue`=JpWVvzwG60-yUIN+^D`m4%`ddfVu*vl-6yAOIot&P7$GU#x;)nZj(m;A z0T%A^F_u_uT5nlr^bU z63wN`oTiA!19JtAipiS3B%1Wb6e#J6v`9t2N(tD{6~PwK4Q*aUZ5;5VeIz2**oWiK zTg0ywhJ;}rqbeqkwIF}8iO>8baNNXsL#yhHZ?f@QY(i%fG8;Pw@qAeY=17VNm9U^n z<~wlfAa4;jPC`(MDzt(nw3c-GDqeNQbIw=|yCX_ZjOoTTu>@(5Z3wtmMKDQxP7(RN_bK-b}Bm-muoqBju zCzl|shb1X^dkNQcn{LPLx;$cntckL~pc_QaIqgJzJC*Z3m?AH1w{D;`R YZfj$$FyvQ^or8L?^K6`ab@k}zFGIZPga7~l literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST b/internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST new file mode 100644 index 00000000..dc9e57ca --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: schar ;; ;; Source: CLtL p. 300 ;; Chapter 18: Strings Section 1: String Access ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 24 July 86 ;; ;; Last Update: 24 July 86 ;; ;; Filed As: {eris}cml>test>18-1-schar.test ;; NOTE: The contents of this file are a subset of {eris}cml>test>18-1-char.test with schar replacing char and tests on non-simple strings removed. ;; ;; Syntax: schar string index ;; ;; Function Description: Returns the character index positions (counting from 0) into string. ;; ;; Argument(s): string : any simple character string - i.e. any vector of type string-char with no displacement, no fill-pointer and no adjustability. ;; index : a non-negative integer less then the number of characters in the string. ;; ;; Returns: the character at index ;; (do-test-group (schar-group :before (progn (setq simple "This is a simple string." arraystring (make-array '(13) :element-type 'string-char :initial-contents '(#\S #\h #\o #\r #\t #\Space #\Linefeed #\s #\t #\r #\i #\n #\g)) twine (copy-seq "twine") ) ;setq (defun stringschar (string index character) (setq stringchar (schar string index)) (and (char= character stringchar) (string-char-p stringchar ) ) ) ;defun ) ;progn ) ;schar-group ;; (do-test schar-test (AND ;; The simplest case (stringschar simple 0 #\T) ;; See that it goes past a line-feed (stringschar simple 8 #\a) ;; See that is distinguishes upper from lower case (not (char= #\t (schar simple 0))) ;; See if the setf/char combination alters a string destructively. (setf (schar twine 0) #\s) (string= twine "swine") ;; See if it treats 1-dimensional character array as a string. (stringschar arraystring 12 #\g) ) ;and ) ;do-test ) ;do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b691b9b3ca104e7fcba117363ed9f7b1db50fc6d GIT binary patch literal 4335 zcmeHKU2NOd6~3fw$C7{I-xX1u^hR~kL^0LcO<~7gR?sqSE0!sRqN=*XHYhS3ah4^8 zl#>}n1Fr=(6kyw>K|9{2*@_NW26R7NR$%Me!N3Y^FGJCnq7Qp0us(F?fTH_B_b?3J zIrmDo6BpZnWe)>JkT|^OobR0P-g|gRUM9^C#gjB%S*hA3%b}IkT6MKXmnsf*E2~by zqD!EskHk}k_UNn{pNmZlhcY`X1;@(QtVL?BTJBwb2E*a;`$xu4 zoQQ>{)l5=E`mm!r(?O0z?W&HtaVbYtLhQ z?vRSFeW`OJ)d|CoFDIW)b-qc+<>J>|h|% z27_P@GS_p~)0bpEF3InNAo*=f`prht4oCpAMnaI`M&C_CG27dhHZaym+Xi{y#Iztv zP22Zy7i#A96%N##n8;G0j(#_dsjdJGci2Hl=aVm_VJ zhPRp~w!1*jwq=C%1bQK0OH$Kk%vs;-8os5UcEUr=ny`ruVMqKcI5%kzs!1Gth)86u znmGIbX~(mMq3Jt1Hj~iyF4+3ES2C_O;iwbw!0K9$I%lWJU>Qp^-8 zzk^D6|0b1mDxsU2fy!@#vO}FZoz0l)WKu)b3y`3#{sxWDs@#nsR!eI0SP|wznmgv$ zAo}Yf=L16A3!ZxuIy`4;QmG@*OJT=QL|GJs{Cf_S-{TnhZ6P+Gv^wS!4{1}h0AP4u`7^!TU(;@G2D0z!x$c7Nl z!&LEE%j&$I5dQ@0MS+XZd?uSRar?;QLb;ABlhMpGUtzt=Z1iE)mt$il>pR0vCRpER z+30cBf0T_KX8jR%GR*q#0&L)Y-@DVTId=KnDSFYa6=|N9D`myCSE}&!nRlH08oIp) zZl>kdXylR_p-XxAG+m^2S$tKZ?h-H8E56q>F%gW2{}Q5#`o*@0h9CJmDiIamgQ+&k@Y$!%qv{DzVMXKp z%5D~4^u2uz7JR7%1*M!{v3T-_Me;*_y>5lGVx5oGVCgYxPs6nJUCc`wOwuR25=tNV zUVkIuvbA=x;w-{^MJVZgo=p1cZkXeH2MR^2uuNU6wpw+?KZ&Rjr2#Kcml>test>18-2-string-eq.test ;; ;; ;; Syntax: string= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: Compares the 2 strings; returns the length of the common portion iff the corresponding characters of the substrings designated by the keywords are identical (i.e. are char=), nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string "characters" and the end-position 7, comparison stops with the letter "t". ;; ;; Returns: a length or nil, depending on the results of the comparison. ;; (do-test-group (string=-group :before (progn (test-setq simple1 ";; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string characters and the end-position 7, comparison stops with the letter t. ;; " ;;END SIMPLE1 DEFINITION ;; ;; Simple1 and Simple2 are the same length, but simple2 starts and ends 1 character later. ;; simple2 "; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string characters and the end-position 7, comparison stops with the letter t. ;; " ;; END SIMPLE2 DEFINITION length (length simple1) ) ; test-setq ) ;progn ) ; string=group ;; (do-test "check setups for string=-test" ;; Make sure the setup was right (AND (eq length (length simple2)) ;; The common portion of the strings is all but the end characters. (string= simple1 simple2 :start1 1 :end2 (- length 1)) (not (string= simple1 simple2)) ) ; AND ) ; do-test "check setups for string=-test" ;; (do-test "string= keywords test" ;; Use all 4 keywords, out of order. (string= simple2 simple1 :end2 (- length 1) :start1 1 :start2 2 :end1 (- length 2)) ) ; do-test "string= keywords test" ;; (do-test "string= with symbol-names" ;; Remember that the reader sees everything as upper-case. (and (string= (symbol-name '18-2-string-eq.test) "18-2-STRING-EQ.TEST") (not (string= (symbol-name '18-2-string-eq.test) "18-2-string-eq.test")) ) ; and ) ; do-test "string= with symbol-names" ;; (do-test "string= coerces symbols to strings" (and (every 'string= (list 'atom "atom" 'two\ lin\es (make-array 4 :initial-element #\q :element-type 'string-char)) (list "ATOM" '|atom| "TWO LINeS" '\q\q\q\q) ) (not (string= `|MIXED cASE| "MIXED CASE")) ) ; and ) ; do-test "string= coerces symbols to strings" ;; (do-test "string= with a simple array" (string= " " (make-array 10 :element-type 'string-char :initial-element #\newline)) ) ; do-test "string= with a simple array" ;; (do-test "string= with a non-simple array" ;; Not working 27 7; see AR 6190 (string= ";; ;" (make-array 4 :element-type 'string-char :adjustable t :fill-pointer t :displaced-to simple1)) ) ;do-test "string= with a non-simple array" ) ;do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f09e785c97867d07a7289ec34dc1462da47af131 GIT binary patch literal 5889 zcmeHLeM}t372n-EFx&wKe?X0$cuX*cgT+4l5dwyIITn28xI1q5j7jSz=VS40Iqr_# z!wGU@Icb%s)rrJGad%wVQoj_XA8O*NABhtYsehzVDpl%7sw!38kEoHNs;#Q3suET1 zdoy=@n5s=w{%E8EKi<4IZ{B+|Z{E!AUJ}Yq1wtf{oynPL!y?(ad~PmJrm_~XvvXF` zAX6YG=L3MGJ9j|8dMg7|`SI>h#>YdReT^3WAUnmXK5mLapEuoTm!4K3&yxc_ww5lO6u=5ss72^xg{3PGq6 zge5cCwDi2|@m0$#?Jq5J1xm-8$6H_(Vf6JQ<1OQ@*k~^`2=;=pX~1~L^v^uyg77(z zq1MF||9#)FHSpNb>8jvXM|Q0gStUx-UhvBQkoA-a0=V5ccdn0=+*LDoWy|hNXd%X% z;a^(vcsJVf>m|?LabJ4#vft7)LGXzp(jE-Kbh+U;9YvM+Bb0eFX5!Y|&Zs>FU9Q4c7lWGjzxhT_g zU1plD$GGMMsBGf5W*;h{i|SEjM3t3TOkv|XKvcE*Vnw}rdKVDs_spjBJ7!b*39~7E zoq3m@KM zzaK*vpJq120&IEDUN&o4gFPNnvGW1$;xu;=<}P;82Iv#sVH4!b3OSGC0O1!PEFXx( z!-G*|Z_rjGU!`qG3bge+Z97d{L$s}vw%$S8PJ!6{Cm2%}jYWpT$i0Rf+sVki0#7uM zd)P&6Q$0^RQ2IqS7xxrxNA5HihB-M#x1-R_`dsfZq3aKv+=Pu*HEKQt&vTwY!Zrxq z0=lkOKUj7Xi{tEX2EW#LSyuoF!(WA(Hk8VTq zZHkp7T<6?3X+Lt$aPA7%{0!Tb!edSn}Nv?QT17nVGZ2 zg?rG^D}3%X*rXaG0^rrJ%(h+DQvRMnOxey@^Sl^M>@00-cF~mZ;icV)_@mD zyJ*mcJCg8z8!a?2yRJ8#HAf8exPAnpncyjPka&`C<)P?xXXVIwbyfQd>%wq7 zgkhe|WGx6Ii3i)HIW=WiMh4>QAZOr>m#g-X$*f^#_Tgr6E%33;WqDgMm*D1n&Z2k0v-~@|-14A(NT=6>KeOyViptix6#wQF zb|h0qa(b;}+sM!5FwNp$m@n~>%VI_J7(7Sb!uNRE;1n9uiJ3E#39Q1~AD`fjU1X0> z@C4=H4S{drqKh`b@qsp{*T-?vDRlM>sPJ5+^0$8WDFe%&mwc(#FKET;??gjTsCDV| zSohrQbjyTa!&WYb9b26Ok{|ctau3agle!tnkU>=o#DY<3><>CnK!c#M{6=W z2lm15l$D(!2ikDOF=orqqG~`l&l#n%1ZS0%m88eWOrirIMf1@5*T&l+ck3O<#O#Fd zSA}E4HyN9-9gePZmT}I^&OuFVf*Flov+b&}#wB`zm!ZTR@JCcBv=t`r$G?4)Jpu)Qw3JScl5yLkc!3C6T> z*|j$~yLQfiiGAp^%eM1v`{&;M1& literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST new file mode 100644 index 00000000..e2a31638 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-equal ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 27 July 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-equal.test ;; ;; ;; Syntax: string-equal string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: Compares the 2 strings ignoring case differences; returns the length of the common portion of the keyword-delimited substrings iff their corresponding characters are identical (i.e. char-equal) but for case, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string "characters" and the end-position 7, comparison stops with the letter "t". ;; ;; Returns: a length or nil, depending on the results of the comparison. ;; END PREAMBLE START WORKING CODE ;; (do-test-group (string-equal-group :before (test-setq simple1 ";; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string \"characters\" and the end-position 7, comparison stops with the letter \"t\". ;; " ; END SIMPLE1 DEFINITION ;; ;; Simple1 and Simple2 are the same length, but simple2 starts and ends 1 character later. ;; simple2 "; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string \"characters\" and the end-position 7, comparison stops with the letter \"t\". ;; " ; END SIMPLE2 DEFINITION ;; ;; Simple3 is simple2 with some letters capitalized. simple3 "; ;; FuNcTiOn DESCRIPTION: Compares the 2 STRINGS; returns T IFF their corresponding characters are identical, nil otherwise. ;; ;; Argument(S): :start1, :start2: the start-comparison positions (counting from 0) in the reSPECTive strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string \"characters\" and the end-position 7, comparISON Stops with the letter \"t\". ;; " ; END SIMPLE3 DEFINITION length (length simple1) arbitrary "llQ8uqk&Y1SlQ8upp" ) ; test-setq ) ; string-equal-group ;; (do-test "check string-equal setups" (AND ;; Don't bother unless I set things up right. (every #'(lambda (string) (= length (length string))) (list simple1 simple2)) (string-equal simple2 simple3) (string/= simple2 simple3) ;; The common portion of the strings is all but the end characters. What are string= are a fortiori string-equal. (string-equal simple1 simple2 :start1 1 :end2 (- length 1)) (string-not-equal simple1 simple3) ) ; and ) ; do-test "check string-equal setups" ;; (do-test "string-equal with a simple array" (string-equal " q " (make-array 11 :element-type 'string-char :initial-contents '( #\Newline #\Newline #\Newline #\Newline #\Newline #\q #\Newline #\Newline #\Newline #\Newline #\Newline))) ) ; do-test "string-equal with a simple array" ;; (do-test "string-equal with a non-simple array" ;; NOTE: Not working 27 7. See AR 6190 - can't displace to a string ;; The quoted portion starts on the 3rd character of simple1 - i.e. 2 if counting from 0. (string-equal " ;; f" (make-array 5 :element-type 'string-char :adjustable t :fill-pointer t :displaced-to simple1 :displaced-index-offset 2) ) ; string-equal ) ; do-test "string-equal with a non-simple array" ;; (do-test "string-equal ignores case differences, but string= doesn't" ;; With every corresponding letter of different case (and (string-equal arbitrary (make-array 15 :element-type 'string-char :initial-contents '( #\L #\L #\q #\8 #\U #\Q #\K #\& #\y #\1 #\s #\L #\q #\8 #\U)) :start1 0 :start2 0 :end2 13 :end1 13 ) ; string-equal ;; The same comparison for string= should fail. (not (string= arbitrary (make-array 15 :element-type 'string-char :initial-contents '( #\L #\L #\q #\8 #\U #\Q #\K #\& #\y #\1 #\s #\L #\q #\8 #\U)) :start1 0 :start2 0 :end2 13 :end1 13 ) ) ) ; and ) ; do-test "string-equal ignores case differences, but string= doesn't" ;; (do-test "string-equal coerces symbols to strings" (and (every 'string-equal (list 'atom 'Atom '|Mixed Case|) (list "ATOM" "ATOM" "mIXED cASE") ) (not (string-equal "Mixed Case" '|Mixed Case |)) ) ; and ) ; do-test "string-equal coerces symbols to strings" ;; (do-test "string-equal with a symbol-name" (string-equal (symbol-name 'simple3) "simple3") ) ;do-test "string-equal with a symbol-name" ;; (do-test "char-equal portability test" ;; The function should be portable - not contingent on keyboard layout. Upper- and lower-case numbers and punctuation should fail. (notany `string-equal '("\\" "1" "2" "3" "4" "5" "6" "7" "8" "9" "0" "-" "=" "[" "]" ";" "'" "`" "," "." "/" ) '("|" "!" "@" "#" "$" "%" "^" "&" "*" "(" ")" "_" "+" "{" "}" ":" "\"" "~" "<" ">" "?")) ) ;do-test "char-equal portability test" ) ;do-test group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..81e063ecc93b105ddc9ffd7e106cc68df52ae771 GIT binary patch literal 4762 zcmeHLduUtd6~7P3@l%o0#IZ%{-kQYm6kikDc{pB^`dYfS70bG^bQQ&cu&VO4tyq>E zNv`9SgpiW0Wx}l!mfbH~{#e;a8Ei`f>(->hg}}D3F-B<$8+5Qo853jD<-C69eCM3+-22_D6~TGj7gT)Nx%pJu$|>1}!u&!(nabvre0Cw1w3I2( zD=+$th<I&XUYoiGnq$m}-TnJ}`uFYY zsvXjzL5lXVKE2@3-+QR5cJ0~~(VZ0pAt|gPsSyOXAPe@TqT6fgQBxfX1a&o}jp<%{ z#V%GuEov;PN96D~;vMYE%vUpysw_hzb1VU;U zO4EjQL8>lA!RVr0banTsJ!;g91VY0q*sopLc0mxFvyE;E^SM3q&ZziyM*6|`N2T}< zPor2h&6B*j18C(3ScS#ye*30XO@8vI`-=-W($O8P}@ex@5R6lK2%|1=t2b zSiR8(4E#!aNdmb3mwFJ2t`8mSKuWy>@|Fvmo)l-^=IeoYe;;kqLTD>I)rT%(c* zZYwuh;z}ujYC(V!R#VBg)i_HH1M!d?)x;7!T)K%PM4WFoAsHEVfe? z7-(G@D3)`0y_`eMsmB-9(Nm7v5ckgBqaK!OtaU=2>y;@m;Ki$Lhw5r!XFPB{#(Zv- z^QnV{XsmEK=%&X*Vp;+V{m_D0ax3im7B;==Eu)Z$ypgW-I~^dLKV2s-hE7Qy-HgKy0O>#23`H zP%Nwt8IiH5mx+?N(c3hlaLn|| zjR3CqYM}|0>oK~#1$3K&MjRtBxBLXg^9P0lW)!5YAT4VxpN*#?>#uvZjK zWe6Qk0NIWZbb`L<$3f8yiaISA9?{BPcG2Da$hqi(X=DyO3^hF2EJ)v>AJc*;90#Ea z`=OaA#vop!FBXaDp>-!O6VaxFZR^85!m6lPR)=N}M5?Atj~qtDc2G2oX`{NTMIzb+ zs;XEU5XXJ6$a)Z0bo`XHBKa|U3dwDzAUQ+I1yWk1JOW-${g@uXP>usUlzg8fPR+~6SJB!_Q7l)BPs4~Q`|y+)?zDAq}eHAb--NV$nCrN45e z^fQ>(+Fd*sH3|b7)FF&?m$f5#m&jX0zDeXI9!5G(VNO$+5eU;5)lJoJ_+n$wat)^+ zWAuY%D_Dlq=)~Bd5md{sG-zyw5;kwti)*|=IF^7C{{oUL8rFRQ4cuXe)iA0*LiL#D zix}%;iXVb{)6k$13;8+hJ&>y+a2p!fA@N5j(ukq>E{Jt73UJ@)A-GWYCfkeTbs~#^ zs4wLRqZZ?kDU9-PjS<#^9tT-3k`|Jxxg`97OTy1dx=qqINGh_P7g_H~))QpCU99Ix z);kRWoX{vN z!#AQ~ADwl8tuJ9zb0UnDI0be9h~uB^Adg0eyLAB{y#ZIF+kd<}8%#vD|` zMj&MBSb=<%FC%}6FC)JU5O=wD*hAPsGm5Z_1iL`6K}zEgt?%VT`Xg6Lzai;;B41;> zz+E~EH=V0||Et3hBNpa2o-{>HCkY)QqCuxC@9F4%grf8kX~&Hif`>;e#ODPO+sL#9 zw|P8f@Tr4yz>78~C>?mefFS;Z1I0fR`8APW5cw_ut0+r^UIY=JQ4g093#<_>r`Z6K z3`w)4_~WQclI|Gup`^2|NCpZ2EJ@EWKPvZ;w40Dk%!A4&24TYO_IJ%$m=9sCFCot8IhkO<$^9NYdGt9S#wREt7U96>z`8}+q6P%sncCj;G$fYvVM-D5gypn;BK>i`g zbxL+hS;$zY7ZPbDZDpnlGw3sB7oRe%d_ieDr?n|l3HaEYR8krGPDI@~93RIA_LuF; zcviRiB04-$)JIO5U;w6B3r1NTz}NtvDaQ}tE3lH!thKb5%}wSp+8u_I;5g5Nvf*_u zr|n{MLLsLT!CDG=D?NoSbL82*T#M3nyC~HnCqLK_O8&iF?5M1s%_xN#OPNefL#$3^ zArDPb<`T1(n#ko6OBmuK9$J0_PU7W5sQ7|?xn{Y0xo5d|dEfH>PS+aSJ(owUBNg_gUnwBbPvKdBb|r zl3ncTAJpMc(&@vU4^g2qB<1Ni7cI?87Y6d%#YIy|O-=De!&iT9NvV{JvxogpCg2~A zDJ7vyW()YI#e5>g6{UvZ&{mrGpF&LLI{9R0Az*GXmAClv2d)Tprv}6U3EqF#+=5;7 zq!V+`PbP4dAARG3`%L6-T+ju(xXEvrVJ#35tJu?E!CF2=6UiT(rGZ9Xd|(%Mhtn2x z8VbnlE+{!`(wc&uRL*I*P(tBd!hbsu{)Sy_*xTLHyKn!2gMBzsB7?jV&nLlYdM0&h zHa(Zg&Y#ZZ3kxqSo>{`35ibEk8}#}0q2ZCh(b3>o$Ow-|qGs$^{P+a!r}#1@#~*_e r#Pdg-mv|3ggufHdA5%Xeo= ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-ge.test ;; ;; ;; Syntax: string>= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>=). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string>=-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly>= (dotpair) "T iff the every character of the car of a dotted pair of strings is string>= every character of the cdr, nil otherwise." (= 0 (string>= (car dotpair) (cdr dotpair))) ) ) ;; (do-test "B-Z string>= A-Y, upper and lower case" (every 'strictly>= (list (cons (string-trim '(#\a) lowcase) (string-trim '(#\z) lowcase)) (cons (string-trim '(#\A) upcase) (string-trim '(#\Z) upcase)) ) ; list ) ) ; do-test "B-Z string>= A-Y, upper and lower case" ;; (do-test "string>= strings-strictly-outside-characters inequalities" (and (or (string>= "A" "9") (char<= #\0 #\Z)) (or (string>= "A" "9") (char<= #\0 #\z)) ) ) ; do-test ;; (do-test "string>= on the digits, using make-array" (strictly>= (cons (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) ) ) ) ;; (do-test "a string string>= itself" (every 'string>= (list upcase lowcase digits " ") (list upcase lowcase digits (make-array 2 :element-type 'string-char :initial-element #\newline)) ) ) ;; (do-test "string>= keywords" (and (string>= "123464" "12345" :end1 5) (string>= "12345" "55512345" :start2 3) (string>= "fghi" "abcdr" :end2 4) (string>= "55512345" "12345" :start1 3) (string>= "000000000" "000000001" :end1 8 :end2 8) (not (string>= "000000000" "000000001")) ) ) ;; (do-test "string>= is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string>= (make-array (1- longlength) :element-type 'string-char :initial-element letter) (make-array longlength :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..241963779234257b8e5f3c5eac7904fe5a3c99f3 GIT binary patch literal 4514 zcmdT|du&tJ8NUzbD>6B^Rq*a@yNzct5qJlQuK@|!DqQbjviveS|^XFKWS{4Oc9Us7g^*&H+m2Z0R@?d=~L80hnl zDW=A(eW=c!p@F?aq1}D{rQ5goK!M}96t{?^f#U+4$ay#1K+sZ6OCF18svK3O)S$QE zx%Ds>Ic}zG4Nf^Pbxl8kGBG(=sB_ae3TO6-zZ@-0fQ%u5et<`qqGeQQghFImy4C=O283 zQb=s;Y~^cD(opYg0lNHy*fX7-@asI-`GyNHssan#|Fbx)PB*PiYUg628-|(M#n_(3 zL=UpT#mWH37(LdqsJGnETRzL!m(T<>n>lXrl`d$&uaXNfM4 z*Qp0!?=NW2=`C+@+(PDaddsB1gW$p|n-WsRWj)6=p=zpY@l|mM!AdQK>(yG;Cw7AW z#IB_~A?#1=1QWE;4Gs9+d2E?m?g#jC=5ppE2egp|g!(HYLbe*tzpCLhAc`OOsOIsR z71*QmDY{jk&57XYUsa02D&nt!OfZlESs?gfB#9n~%@0Wf^60|xZK#IR2!3(`^ILI= z@l=wM=uTi|fMBI?xjou2veht}KKg|F(E9p*SGDTLv?h8ggIRhhCoZRS=~2$8no!ka z%c=jdNKk`=olx$@On?(wycgUp!LS}3jo>CLPbkq*O*Q0^2q4jMGbs2;gU|$DBYe&9 zHNaO7UoCt!u(P)Y!-^H2kPX#}8?ZBn>DFFrPMelGB?utV#`gZOrYg~ROdivXDKkiT zfnTd_=|R#ct|JX%0CxJ8plTSpA?tA~7Po?8D=0JtmFTogaWo>X2dp+83oE9&e5BxE zAZ~z;I!#Yt4_Pm^q1JYt!^wFB1xoTf&{tqA}+0BBUS*o0DrJU0+pbtbKY)lPhP z5FNnt1P>#hdRWnb@ht&Ui$hZ^Wd8~FTElU}P@^kOJ;Gz(U!bq;VahQ;HXzc7-QOUa zk$jD8L2`?1MUn&a>sFm>h#w={knCeR15Brz>WKF!D85TU@#hSD84B*-p&nL^Y1xDd zYbxlAU#4b6!pIFqo&}%HQ_7?&D~6#=qufzuGQmuaGm{dGCxEeqEp57b>XP*+zm-Tx zHi4zaO7tK%1(@(Y?Gk=UEeb!O7KPWSMPY$#N0Ez+B$$ZBL`Ip&Cf3(Mx=_;3h(JMp ziE{kk82KYshE)|r`5#kj{12%${=3u~{|scM%~Y*1*_@sl(KWex>p+bR&HY+j2fT*P zM3fo@uEmV0;fMn2FcIV!!g~>(Qo@G*0h=uXJUU9ny2-~;x}6g4&(Paci3H|X z9Bah=2Ef{74el-pBKl3zi^L_t3#9kcB&d)PYV-%+SY?^W7smk^CC2 zRkcx^s&wYQO=Lu$Wt~?T=P?(uXG$1F?%B+fC|5&1fkYs?fe3%6obVpw{t60#YV5EuEr{Jj zv2W8bgs)Qn!V8S-XW(weZKs4^gf-B5cscCCH_lH`gumKvgvvjQ#1w( zEgq%i1<$6Y zr^(P!(w-oL7HL03h9ji?Nix(+I(o?94${#@hC4||2$X#fJohoDRLtg2$|vbVr8p~{ zw&%|kifIS?-}Bs$S+-M>x-KbQ(upLzb<$Ec&z>oWUBU$UUiH4<-Nch;TbMopz?;O8k`6qs3VEbicxz?zX~3jByqQw)4oeoZP9cwO zzeqlbxo?+*134D5Yk-{5{ko@U4%ieTb>2WW)ksTKZrd+zqt{!;}T-gFKeLy|K; zbG(p4-Cfj;_@^}{#NT@E&ZNYQNLfe97fKcGVLG!V$IhJqJK{UcPT6w>zaN2X1Zz@klqNR@K)_$GF; zX&4& zJTw$+%t3<==-Aq@W1joeNMB#yQ7p#l+A7d7J-lKHp-?L6*m5@S*m(zHIBTN^jl~ea z)O`klI&7hH{vX)Fcz8%BUru7{7i;3+?|N?E(1;3$lFHuJY~;%esk(wLnUyuwhlZ}* z;u=nUN`dS6{Q&2=ow?-9@pKZG+v1Xq*TIi@t*-y-Mn%|Vfx{p0k<=GJOxT8 zGucz8b2ItE?3todnmc>${5+cml>test>18-2-string-greaterp.test ;; ;; ;; Syntax: string-greaterp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string-greaterp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-greater (string1 string2) (eq 0 (string-greaterp string1 string2)) ) ) ; progn ;; (do-test "B...Z is string-greaterp A...Y; comparison is case-insensitive" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-greater (string-trim '(#\a) lowcase) (string-trim '(#\Z) upcase) ) (strictly-greater (string-trim '(#\A) upcase) (string-trim '(#\z) lowcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string-greaterp as for the character inequalities" (or (strictly-greater "9" "A" ) (strictly-greater "Z" "0" )) ) ;; (do-test "string-greaterp with digit strings created with make-array" (strictly-greater (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) ) ) ;; (do-test "a string is not string-greaterp itself" (every 'null (list (string-greaterp (make-array 2 :element-type 'string-char :initial-element #\Linefeed) " ") (string-greaterp upcase upcase) (string-greaterp upcase lowcase) ) ) ) ;; (do-test "string-greaterp coerces to symbol" (and (= 4 (string-greaterp 'b66643yz 'abc6660999xx :start1 1 :end1 5 :start2 3 :end2 7)) ) ) ; do-test "string-greaterp coerces to symbol" ;; (do-test "string-greaterp stops as soon as it finds a nil comparison" (and (= (1- diglength) (string-greaterp digits "0123456788")) (= 3 (string-greaterp "0124456789" digits)) ) ) ;; (do-test "string-greaterp keywords" (and (string-greaterp "vwxyz" "ZSTUVW" :start2 1) (string-greaterp "XYZbcd" "ABC" :start1 3) (string-greaterp "012012" "0123456" :end2 3) (string-greaterp "lmnABC" "abc" :end1 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9321bb41d7de8c829f5e876984109d9e385d59f8 GIT binary patch literal 4498 zcmdT|YitzP6`sfXwSKL^*kvK^;F^cljDw9$j7bUO^?1E_ytB;CvY4tu!|uQ?taqK= zHN-?vnly=srkgmZXf6p&q)KU);Msm-& zch|T$Y9f_Cm3DN_`R;k$bMBoxcNe&tBSB3H=4WOzS-T+R=Ss74CFw-IAQkg-g`_Q= z09<-Js2l3}2_-n$x3AwDTQ!m_*jC9-N#>kgOj+|grT)E=GF!-Gff*hKv43P}U}SKx z&pWQfH0JFKZFY|g4vh@%>hmsNyTbeO9LFWOB_s_T=i@}qeZlbsOf_c8<6%veBg&K- za2H&s9_Av)W2)ggZ39v%KPzYLGjc``epc&R9?q&WW-{d~$G>0Q{ z6sD$xR8FX`ctP*H>$LO_%L8)EG{TXP95T6USJpqlaW!(APr!U`rf*I1H*)+Z?@S7b zE`J+edy*!(xEbim53)}C{qXZ2^#9ZW7)?P0>Hk@s_N9mRCAniM(F4;=?quS&rNlNA z151?&jx&0!Wl3*&L2r4Ai7%lGV4FE^>CJ9n;8&>)6aIVUP!&xxw?KQ{6Lp*T^bHyT z#M=wnb9&3qIc_2SjNURS@SwQx=Ej6n30co^O=z0zUb-&E5v=r5xK!rl&a}8Ac_yfsMhh>RoG(p zD&g}K?rU0aRMTos1WtcY=^JaBw+4#EKn7%h;Dh-kwn6${s4I~BS0zthHJwI?lNDIp zN=VG7Qny48?IP^G`y2i{)$mPUel31s>pgd>UcFe(#J0*LmS4(>E2Uh%pIxodsu5dG z{g2Io+8^{oo0rl)PH1tz=WGrH^~hKl-@NjK5*gD}LmmwS5(&iuf|oQ1P4G0r(+p1o zJoWI@!czmU`?f$(F@qDbp_*|6Ue`hTzORi<$4qrf5J01y9SA{9RU+}IJgys4u>j!( zeyz2s2S}sXN*Y8Ty#8APs$uActjEo0+zg0qV9*p$BGWR((TTVYu-bSusKnHja|TZc zaXk)gh(^9!;G z$WZIHQ2dmF;-4A#E;QP^RXwa4({cN|B`y+-=*I8pHOf7vrwG&m}-v8vFWK%U6ZR{B508Y z2d$rj>wwqLg@{^XAhpDzYA~#TIjjRYitrG^Q%ca#|HG#YaNYQ*9*>MswI1>{)ZRb| z_ZJv#szik46~|U_zXPy##e%y@0*JmwdXYFJ@HpxHCJAVyw~quKAiWWQYr4UvCTi#* zlsuo2ZAktBpIWsMT&cKlJs%Mn$*XMe8k5S53^K5nNt-DVKct}e0h4~k$gAMAH5`GL z2uxqq)G1i^;8y$rWKdlQ!3o7c>=n>$s_4k(bd;{d7eUbziEEgXc#MTO%zTF!*^Opn z;aF5tg6f!T>Zti3fX&L-!FbG6M%kL~MLqcX)a0lhj=;)9y&dF1BwNWYBz`7!GRX%9 zzH08UFHOij25Q3lG!5a`G`{dQBYPRRi%DB3;g?`Xcq`izHiRCJ((Sy^sSDEG|(uv^H zO!G-5T_pP+Bb}$o$WhXsAj2kUKScJ0N&CZOq?dH;Aj4ZpM>pB$CmlmzT(chDwZ&2) zlRLRzI&IIN%@nVi&M5p7-1r-OG5;bOq_F zNWSOYs)b<@C|Zm(f*Kj7E%ChLIs?_1MYxX?C94P*t9%Y=2JTszTnaEL2lu5U+`+6u zrkKxRxEti_NWSel&Aa*s1_y`sJT$x)kuwb0O%W`#=P1pL>|Ygk(sedg<0kVq+~bOH z%1FiendA8^+Ju;U&l*$lpRUtoNz7Qv6s26gRFU>W#zi}O0_?@VQ+x5c>j+*i0zWP{ zBYA4ALr8d~24^#+w3N!6gsHO#MX7ojq(d{-X(ZYcMc z2g>DopRdmGuJMLJ{!09$<~wkIq@yOetgILK6N+(-mHK9Uk|;@ES1Z zkhuzsh0GOTa3aEYt2&o}If}?UFbXnrRh?sNrxbOazR|wEzN6TfYJU{~rg6c}&CWvF zIM;0cEO1GyXro7s<>kXN(tPTW!-V)xk;C}>ZR9Wk{{1y^`I``TWK@L%M`d?uR*jWS zQ{62WVwL^VhmM}U!Zn;apum^*Z6D`4{;V}~JY`{~_kQxg))wd|5ALw)7fAmKH^6&H z7wDkVdA7>8Apeb3{DkXlk7jL{vXsi_wwI)Wow8wj+0q3CLt0V^)5U)R&~(%4U4$)x ze*zr8bvy}1C)1fzr?WG;{OqHJVrlNo*~jLwYG5xIY{gy>uFJ;u{F+%?8`<``{%gwc+BwjX!(Tg%J;2J}tXVgLXD literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.TEST new file mode 100644 index 00000000..ce920762 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string> ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 10 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-gt.test ;; ;; ;; Syntax: string> string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string>-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-greater (string1 string2) (eq 0 (string> string1 string2)) ) ) ; progn ;; (do-test "B...Z is string> A...Y in upper and lower case" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-greater (string-trim '(#\A) upcase) (string-trim '(#\Z) upcase) ) (strictly-greater (string-trim '(#\a) lowcase) (string-trim '(#\z) lowcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string> as for the character inequalities" (and (or (strictly-greater "9" "A" ) (strictly-greater "Z" "0" )) (or (strictly-greater "9" "a" ) (strictly-greater "z" "0" )) ) ) ;; (do-test "string> with digit strings created with make-array" (strictly-greater (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) ) ) ;; (do-test "a string is not string> itself" (every 'null (list (string> (make-array 2 :element-type 'string-char :initial-element #\Linefeed) " ") (string> upcase upcase) ) ) ) ;; (do-test "string> coerces to symbol" (and (= 4 (string> 'b66643yz 'abc6660999xx :start1 1 :end1 5 :start2 3 :end2 7)) ) ) ; do-test "string> coerces to symbol" ;; (do-test "string> stops as soon as it finds a nil comparison" (and (= (1- diglength) (string> digits "0123456788")) (= 3 (string> "0124456789" digits)) ) ) ;; (do-test "string> keywords" (and (string> "vwxyz" "zstuvw" :start2 1) (string> "XYZBCD" "ABC" :start1 3) (string> "012012" "0123456" :end2 3) (string> "lmnABC" "abc" :end1 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..047a92211d505000a151c86202345becf29787c6 GIT binary patch literal 4763 zcmeHLeP~*`)U%$Q~XT)5y$b8*3Z(jt@v3_mY$+G5LQ)wjup$2 zBgsv?k`Pk5wIJL&Vd33u`KJ^z3T0_v-I{c`5ZD$r#wbl;gAVpl#>NI23>N5^cg{VM zlg4ZHHhOedE*mF@$IwvbO}Kp7YSvwLt~&tP9) zSM7)vGl=aAV|oYs`UkrqX6@=_(VG(lAtkJ$s1XFOAPdgLlGktPF-si@8M+$QCUn2E z;*_dkEowZbN1ak*k5bGns2TeOJA=!aF9@O_IIowgN8;gt6*9xlCGosi@4QxO2!+)M zEKM8L1*y8sg6yJG@^lZVJ!;H~hQgz&p$k_pZ@VA}?zu*eSchhFDw1{N8?gr zhp$nrI>D2?u><7#A7nl2^TD6*u%r_?O?0BWV>Qt+cNes|k5XL-0rkcR$**}#=!C63U z5QNq1ZJ@wkc`wO;(EqX?gktD}z&fzf?}NSN!loz1+4uN-VBT9XUNb$n1z~0Oo2F-6 z5+Q8mdP_nnCr~X2u!Plgs%`Zh=`K3UohTcXPOJtR97ybh*mcFnwbqIY6>LlpUpkBJ zlm!w!lm?oW9NwtpP;>I}vATLHtPKhO++C_6{7;uJzOZ&!NG)u_=MXqj>xPBGz+=qk zW+k6G$bi}kXM$?_d}L;%^(-qn@KMlLJ0=Ub&6{(u<{hVZ$qj%nebp-0u>5O~6) zF~3yLYNR^28sMsds~WBax)qPYgFe7dimKRD%+e<$2@qT9Cdw^D|KrH%42gpVi48RwHkQ!K!#9pvCm{lLyZX*$XF%$FE1DW>hufRwQou zIVErRBj=(Ax{A^$j*ba_{32j_gwP;kE zLYIrRfpFb}5m`5IM%OP`D~g}7r%>Et3W_u2TqLJW&SxOXtsl{&NagD1RPsHJl>f?+ z@+TZAzYCc*U@8I2m^yffc_Bc)K>=4uFd(ZdANl~CK*V#zb)2{+h^v8|o48Z@2X{)p zgnq5v#dA?((4dA6@zNdEj^YCn?~-_%#7mq;I!`pGh-M6E8e_Vp2F*Zx0!pr7_anz3 zjBJIG5j8e7F>D%Y<&_2pn<4kj8~x%MFA%mRpv1p}<%vb~KuCjd*kLt-?oZJ@p#`Gm z!<^zL;NCPcY{tVu4*L-7swmusCYDD0DVo$`Xnp`@9kc@6cX}8u^u5FOqIiSEX+YGM zbA(olbI1&`JeXsQ^XaPN_S|&nD;B3%> zhvP9z8|IxVzk)b;u{P9*83Hm~sQfZfT_CDqO5*^{@8?4L3wKJtC+i~;Z?atwE}ey& z&QrPn)zPRKkMJ8$nxUZMgbtI?pwjE_=@|YDvGkH?$Bh_)hetfj`vno(XlM&=^JLuQ zT?glYAIIF_bm9F1hWJko6#quzcO-sI;s*e%qAU^mGMM;`dN7SxWQ{m-iVdO2k~LT6 zpG04Zd`DOSEuC#eF--Vp$vVh_=G^(?sKH@M~2@Z!XG$N z_$^t#;Yi_QvhEP_hip3{zfZ^;WPOj2*T}j;$X8i2BELb%m&iKLf@fIs919#{O$jz+ zv8G8D46&wzEU<^Qbg-datfh?weXOMug58r&sk2bbr?V#x9#YZ;B?}*c{6mual-!K6 zn6*zWCNoOL&YmdFV$6h7ddjj3MWyYW)~3uP;bU`JNoVOh5q;;deOwhMTWA314^5VWag#8@4`*bwh2*H7Rpa6O+nd+Bs8KV3k!+YCFwb)J*5(T74#Ii=>L zLP2GLYbh4&%nXLiQ)KsYEn3^1l2nVDe18L#{3oZ>u|9h)s}yH#WjcKVxH^@^0u)J^ zPtMtDGM`T_A;qVhT7KKPRI}W@+_T)f+_$`Mxqo^8^1$)|1YCkMnzY%CvrRdr1M9Pq zQczK*ikT%9zUm9fP|mW|Z1Q)<`LsR!j4R*%6F z78c;=f@F4D$>dIhmP!_E;E~oik8~T8#TN?cCThn}yN+5CwQHz-9kt~R^GQoiscUdp zheJuH4|m=~#q}nsbjP_^xnH`FDCm^VSW0?kh8G&X`twW5`f{=Nu>Pqe{K7G#B$er0 z5r4E;NT#`?Trg}}QWenr|lWoO68n}6D1X1Cj7Yr;oo&i4STzLdi(bE?;pS(5*g%`d_Dz1CuY+p=Q8uz z+`_4Rp}6?M=`%~XA>u_qXv2Y^J~BEMIy`Pngw4ogG-kz*B#utuHj1xMa{M_sMLK`R n`APQyM)-_${+#+b>HJA_mGtH;$);yXwzxju2EvuIYis`oM{OEz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.TEST new file mode 100644 index 00000000..4297f1e2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string<= ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-le.test ;; ;; ;; Syntax: string<= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char<=). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char<=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string<=-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly<= (dotpair) "T iff the every character of the car of a dotted pair of strings is string <= every character of the cdr, nil otherwise." (= 0 (string<= (car dotpair) (cdr dotpair))) ) ) ;; (do-test "A-Y string<= B-Z, upper and lower case" ;; In upper or lower case, the characters a-y should all <= b-z. (every 'strictly<= (list (cons (string-trim '(#\z) lowcase) (string-trim '(#\a) lowcase)) (cons (string-trim '(#\Z) upcase) (string-trim '(#\A) upcase)) ) ; list ) ) ; do-test "A-Y string<= B-Z, upper and lower case" ;; (do-test "string<= strings-strictly-outside-characters inequalities" (and (or (string<= "9" "A" ) (char<= #\Z #\0 )) (or (string<= "9" "A" ) (char<= #\z #\0 )) ) ) ; do-test ;; (do-test "string<= on the digits, using make-array" (strictly<= (cons (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ) ) ;; (do-test "a string string<= itself" (every 'string<= (list upcase lowcase digits " ") (list upcase lowcase digits (make-array 2 :element-type 'string-char :initial-element #\newline)) ) ) ;; (do-test "string<= keywords" (and (string<= "12345" "123464" :end2 5) (string<= "55512345" "12345" :start1 3) (string<= "abcdr" "fghi" :end1 4) (string<= "12345" "55512345" :start2 3) (string<= "000000001" "000000000" :end1 8 :end2 8) (not (string<= "000000001" "000000000")) ) ) ;; (do-test "string<= is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string<= (make-array longlength :element-type 'string-char :initial-element letter) (make-array (1- longlength) :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0a0e017b9123a86f6c3da71bbf1477dee463b4ea GIT binary patch literal 4284 zcmdT{eQX>@72l8Z*ZCu7*LH}Tn62x$(Yb44$4(qOK-cHBeewGCvb&dyQ=w{ex5-^{ zzH@KSNlcX}O4OjV%e79_Xs0xQ5Tbkt(FTFqCdi0_1Og!>L?u9~RH+gl5>g~2D5}7` zH*;q@2?8YY57Ol@^yu((yu3atlkvlp`Gn zTzV#=8|t|kB{DlOJ{UANNm50}E;(t*T5{a9z5KW|xL;Bhi`g6uMn{1i92*%L8y+4A zPAR6wy!}U;J!8Xr$A(7+f@?Rf^PvLAaVc&UNdw1)IFa+OdZDnTnwC5j)l@mA%&B32 z#rNuAE^@+D4c}`Wl1ha|Ip>^qayXp@m*Y9kf6=R-O2i^oRFC=B_zQfK|AN;XjmdGC znli0&LVd*xdgsB-;HW$#o0bucP0N~UnsM&N^|p%~7r5OT5-_D(ncK7cn|c0&@68Iy z?Om;W?FpLa&Fw(fe~@^ls|$Wz2fN<#07g?_f%|_}r>*Ixtx5H+Cc9ypsW4;vR+D|m z?pm!(aEj5VT2}Rzt9r|`jC}=Nz_6L)R$uFZ0sJbpVa&g;9IB#e_BLp@U98*2XWpa{ zfW5P#y`ZWqq<2;wQsv zHwRIk>;@Nf&IWB zgg7DSzvOKXNA%ca6wg9=Mu|;osv%EA0f|kUVWEjM2#xSG!_xpyJv_DW)WG4}8jdJd zWJWerD`CLl8KI|dtvPR6>YN~eMmsy6Bbutj5^;G-H|ESR;RXJFYfBH4MzMu7h+9Bd zn}|mgQ(ZsJ@f;RIa7wp?Rm0E?Sx;E;gcTNBLAfcc#O7s+qj#|lusTgoq6ZQZA3}eV z(dnpV0@n^)18|xeo3>^E=m4Nm(c&{o74p5%;61O67TA*{fbWU}c&ndI2tQdwe zk9tR$%OrC-&0I>5cMx-kSlT>&0g@0Z?;sMAdPV}^t+A3R=+1#i_$hTK{Fu5E-k|P; z74itm&M}f?Di%|jWGdU3tdsPhW{?qqg8Ulg_`fjndn`X|9jNj@qTcu)P;dOVsW<*P zC`r4iT2rz)KR2Oka`o+x78!7`+98(kS&=|s>Xbj<-G!5a)G`{c>Bl{V+n{kg&!mq+wZ`-`z^-;q|Z;@&5tNZw=IyA_9r5POGVKOtkty+PWMe23}ZWZbvN zID)S-?q#NVg=|IeGSj@oxC>6Ej4rcg|~DEz$debjQ?lGJlv>5-1xaIr{B**v=w zAa)+B6L`}9oPQ19A>9!}RV-D$=h)Pu&}T(6Nh7F{QQDV)=6n0@3hctyzbn};Tw@A( zq*=JtWb4yUb1u9Qr5v0B7C3bEPU4Ycsw73D=;{UgJl>fI9P%K&HkzT zbB_Dom@+UhFpoXBYcWg!dUSlF<*1OdT}RI5T_^8C{L>D4*I4`zR)&VF!_lWf#QzOP zHjeJ#2(#jUabFJnE#Dg$n^563p|V>ioAvstuP*oVW@Q85w&5>d=Ne8vp}@E5oe<}H zT{(Ney*DxIP-<1Ed>t(CIQ;q4>h(pWHN_@x905IR~aM zr3?ATN>b5DJFqnz>AZp=ZK;Im;++{yAKttJu=H?e_PXq2DKI*b$(}rwTgVp{pDwzk zrPF85F4JPwfQB*=nN+8yXQBsZwYiucKV+Cz;&AfFJeH38kR?RVvY)XrJ*RH4@zy+} S9iL>hGjMmQxtGtZt^E_Prld0f literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST new file mode 100644 index 00000000..c5b91b3f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-lessp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-lessp.test ;; ;; ;; Syntax: string-lessp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string-lessp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-less (string1 string2) (eq 0 (string-lessp string1 string2)) ) ) ; progn ;; (do-test "A...Y is string-lessp B...Z;comparison is case-insensitive" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-less (string-trim '(#\Z) upcase) (string-trim '(#\a) lowcase) ) (strictly-less (string-trim '(#\z) lowcase) (string-trim '(#\A) upcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string-lessp as for the character inequalities" (or (strictly-less "9" "A" ) (strictly-less "Z" "0" )) ) ;; (do-test "string-lessp with digit strings created with make-array" (strictly-less (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) ) ) ;; (do-test "a string is not string-lessp itself" (every 'null (list (string-lessp (make-array 2 :element-type 'string-char :initial-element #\newline) " ") (string-lessp upcase upcase) (string-lessp upcase lowcase) ) ) ) ;; (do-test "string-lessp stops as soon as it finds a nil comparison" (and (= (1- diglength) (string-lessp "0123456788" digits)) (= 3 (string-lessp digits "0124456789")) ) ) ;; (do-test "string-lessp keywords" (and (string-lessp "zSTuvw" "vwxyZ" :start1 1) (string-lessp "ABC" "XYzbcD" :start2 3) (string-lessp "0123456" "012012" :end1 3) (string-lessp "abc" "lMnABC" :end2 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5a7c32b446d2d04720288b5e8ce507b2a2c1d8f1 GIT binary patch literal 4304 zcmdT{YiJzT6`sfHwR(7E%W|za>R6Q@tU9V!mSR~_+l*EtX|2)DdS=#ZITSPA9c$NG z?JBz~If}6{2}y96Zlai)xlY^$3Tc}kNvslxYX{NvMIk@ZA89FtKxrX;KyiQ6B($KO zbMLOK+MzAfe+oN$&iU?n-E;1}Gk1lnIUd%eaDILvlXVJGezCN$SdvcX3sNz^SV%h3 zX~3m(Vck&APb%T5-rYb& z*FUb98uRuaZ4M6g9~ugUdj0FyuJD08$8kw+4M_vX1vruOUUCCLOEoQdJff*`RGC(T z-iqhe!(8OJsT!W!+9#Fr3v$+3aUt%x4=F7p@pChrBeITDp) zFg0aD<%If*7xd11ZcAuT?vqW+h(sr3&El?I+4>a6`F_049$jU4~UyHi49 zS4S&fJ4=&X-34^x2U({(I^frFq~ixJz-S60NdM33v@cz>FUh@Yi7uFCGRVa4wL~|H z``0QH9B1@o%bMQulHT$R6JJ3Wz&3N-+FM<~z^_spCj9%#p(>hYZh`jJr|Nd{=^Hcx zh__d?7xb1NaokG!IlW~{;6ZWat(}R^O2~SSYeLhcw02!sN3haM;Zn7i^@+U@KM`DC z4dHmA3tVh4z^{IeN_(p?GVr^YzL@^66WYNNLPwi2La~yLC{@#GKolQ{QLW?io3Pcc zO~Pj>JkYe>tftkR*gy9n>lXZHDi5ZT=!Q)FSVE?O7*q7u&{;gVD*1Y==`=!wtiZy+ zKgPspNFkd<7wsbKJrEvX_*bjpn{cihlV5)&D<--tvDY7D{e5?;5&dWW$9X`Nj&wkm z*3tn^@O$5IcLl?GbS#2rq&%ra$28TDMh!fc$(p9fTtdwT6k*UP;L!| z6)QX`8>$sI;7|?IQ@PfhF)ejk5J01i9ou0|Rig2jJgytlW{~g#f4{Y*2T7yYLK?&^ za7ecVRm0E?S&v(>xD^xwV9*p)qBAnZ(TUg!SZzEOR!nu{ZGh*vxD^M+A`=nIBwNL8 zAk}Gl0`)*_1F-=HH8nb6O#-kTfJQ}&O)6E$a|5A!UMDTEU5O9hAz#K9!Y?32pL$Hu zQ1~$jwKz4!Lh*;-uQePu3^lsxg++KAyAES*cgu|_u?dkz9L|x4kj#-?NFE~(BME`~ zI`&E$LAjfB0ulc~b;VDquJ}i)E4~N)^zTuRsm6?KLIX7wRc|qiw;6c@{54N2Q>v^O zhBAW+=b5i3nXfa2UA=bwwqL1&3N=Ahnn=H5^gE9QrNC z5FS8yS_vEazxb2^t{WfKE+S@7N{sf~2ZiE0QkIGLaFDvB3!@ z4N@Y0L_zUGCjFF=*T8;DBnoE&%v9CXX;{kOLHsrZt2R44sThd83c5`d9od?R(G~YH zDEgvt4a18kS%_oIHw!P0kT2obVR8UTA2Bs{9()~Ya!ikaIZbUFixHqPgb!#M!p~?L!aIx{X5axP?WTlZtFHX$ z#E3j$=dHhOT!;0dyvGj zLbx7L(3qmaNFO6XO1Muz5x47Izud=U8(49_Cxb|S%cPGg4v!-CONRZN459Q6*^cCG zroYOhH_0%9-(k{Krg@3%K=4_n`81O*lHn)FjyW=Pg0v;bphen_lHmwx8zDnIqg(?xc;wLFVI1gW$U%x=p?yA@ z8TrcHxZ>YDx6_tbWGPdWa`{q48iBAyCwm$U#lO-R;&smz{C)(!SEl5d`yDQAn#kEq zDJ`WkvyeZFP?V}yDLOQ7&pEPPDA>#Bv%rE3c$XW>p>kjOV7b3MP=2I*s61H435mPm z?L|4^&V6x(k3Ba-LqU~tDap<*q-`mgwhMN$7B_lvQJ6Kkn+e_4R)Of?T8j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.TEST new file mode 100644 index 00000000..2b525511 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string< ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 10 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-lt.test ;; ;; ;; Syntax: string< string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string<-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-less (string1 string2) (eq 0 (string< string1 string2)) ) ) ; progn ;; (do-test "A...Y is string< B...Z in upper and lower case" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-less (string-trim '(#\Z) upcase) (string-trim '(#\A) upcase) ) (strictly-less (string-trim '(#\z) lowcase) (string-trim '(#\a) lowcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string< as for the character inequalities" (and (or (strictly-less "9" "A" ) (strictly-less "Z" "0" )) (or (strictly-less "9" "a" ) (strictly-less "z" "0" )) ) ) ;; (do-test "string< with digit strings created with make-array" (strictly-less (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) ) ) ;; (do-test "a string is not string< itself" (every 'null (list (string< (make-array 2 :element-type 'string-char :initial-element #\newline) " ") (string< upcase upcase) ) ) ) ;; (do-test "string< stops as soon as it finds a nil comparison" (and (= (1- diglength) (string< "0123456788" digits)) (= 3 (string< digits "0124456789")) ) ) ;; (do-test "string< keywords" (and (string< "zstuvw" "vwxyz" :start1 1) (string< "ABC" "XYZBCD" :start2 3) (string< "0123456" "012012" :end1 3) (string< "abc" "lmnABC" :end2 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6fbcf3e4e93e783c36bc42e168a5fd44d13d55b1 GIT binary patch literal 1578 zcma)6&2Jk;6rZ&d$9589TTy7O08>jvW$C&k4I(&HXtS9lZZ^BleqeG!i@mP5INoTz zCPb)Fh>&_&siYOvPOJU{JwXphEk%~##<~9iR}S1bhBs>`L}Bh9?8-}}AyX6Fcv zek{pYa<_M!w(ViJ=kN4<+;lzMb$edj#!b-UFC|qYx7I{yy|g%+*3Ve#o^APd0~ioyvH4I6XBg;vZ4r8C{0`?D3%#^EYA;%?dL@b}oz<#=bcB@c;Rk&Vw7J!Vr$-<_{bvly@^5t=}#@6^xrzek5> z*l;r^Y?8G+|rfm%QMi{fpgIM-wdYzjREkvUVvQvR+csK+hB&5 zRAsrsIxVb;%Cbx}VW|QdWmV^637U$H!WeVBBpTA1pb^8=U<^_;$ArG68)PFE1COb} zpe31zidhv_RBc1&DHr4Z8EvRM9gnBLFe$5$CYsvmy)vVI&O?ttiMU56e z0JO;saotoRB5%{&C5FFgss_18b43tFbYg54Xl{(59f!dihTZjXabGOrrUh?N13R6; zGs1NH7n$3WFyN}}a5sDy-eb4sbx9+lL4=pOELRMoiLy?|!HvF2FWd@)QhABM+{oaS zh@L+GH04RIeSMg{R0#u?>BWxaIh`B0>qpzJ$*$9G<4^5@kL@#?Q%b>yhhHkaxCjetw%_wQ-EykZ#1_Py zVs&xX@||vTFH&8(R*tZoPQ(5JU#h#kj?YLoJ$Dcml>test>18-2-string-neq.test ;; ;; ;; Syntax: string/= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char/=). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char/=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string/=-group :before (progn (test-setq longstring "paring string with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char/=: the index (counting from 0) of the first non-identical chara" ;; END LONGSTRING DEFINITION ) ) (do-test string/=-test (AND ;; Change just one character from upper to lower case; the predicate should hold. (let ((string2 (copy-seq longstring))) (replace string2 "P" :end 0) (string/= longstring string2) ) ;; A string shouldn't be unequal to itself (not (string/= longstring longstring)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d28f1f918248d9e4198a33cbe57d9542477f3a5d GIT binary patch literal 1669 zcma)6U2oe|7(PzgG)bE-sk+id1CH8GDxr=@>7b-Ylk1+gSzSBz2c=iYB+lZI#>H_c z6{^gvg$V(;Gc79cmmn5R{izU#=D_SlRqlrjA%ruh|1zlX_RiYaz%tQ=_8q>Bk zovcS9;4#{rx+oDrHp=|6qONN>%0;;6qje=m2crovq$CB>gd;p%5;opwiYB6iumHn3 zqN<9@D~4V+^jvfZf`)Q}yv2ulmLc%dg>ws)=tGG1u`Rm5cHu<;>Lc$65);xO#27n4 zXJV4k6Ae`*@|l&T9N5rbU>p6XJEEYGZdy9X%)bCq`uzSe!_Q#2&@(J4n=%Vz`kz3b z?CFj2iS`GYWyYsq98gJF62#E?E0E)&Qr_Y?o6dhyP+sW-VeJL%-4~ zc6vkv87q*km^qPepzHxl~ EH(eg;DgXcg literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST new file mode 100644 index 00000000..fdf82187 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-not-equal ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-not-equal.test ;; ;; ;; Syntax: string-not-equal string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char-not-equal). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char/=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string-not-equal-group :before (progn (test-setq longstring "paring string with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char-not-equal: the index (counting from 0) of the first non-identical chara" ;; END LONGSTRING DEFINITION ) ) (do-test string-not-equal-test (AND ;; Change just one character; the predicate should hold. (let ((string2 (copy-seq longstring))) (replace string2 "?" :end 0) (string-not-equal longstring string2) ) ;; A string shouldn't be unequal to itself (not (string-not-equal (string-upcase longstring) (string-downcase longstring))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..615c8a7be2849f14665cc3586a82b3b47e0d42a4 GIT binary patch literal 4965 zcmeHLeP~b{u7NmV~D{z&4u>Dnjh$yO}uDbiCEhlNg+WlOOl zIg*^j>zam^v>iO$I$`16ZegqxG78<&z}hwKaJRx(#uy_sgNBDPQU=^q*x9NO92<663SL39@cK}ZRUDCz{kEy#j>&T@N9J!YzbU`SWP z+L-RK7i_B*=Ay=9depX>`;>BFM$M&9q;oi(Vco2Kyze zF&I`OFg0yh7o^$>3$ly0)!I9#_Ng&58VnDsVZ&61qq=75(TH&I!p3I>!C7o}OBmU^ znfFG;ckKb-g7$y-eaZ|kmkwSo zsjZ8N4#;_GC#hYFi7r$EqqvWzsg#Y0R5Hs)a@j(4} zA@q{b^noBOWL_|uMkNv47B06Xlu7`#f&f!k%%(aQ-;{oX#!4m1p=u@80u6Q~I>47V zwnC$QxwYJfg$X^MIf_jb1^V9+2CCH&sHuzpDvh) z3l`xn1opU`Fn8#zRa#C01N|z!u9^x07XSW*XM$k*gzG*dNlPsy7Ih@Nmo{HLyCV9fow{s|GG7oE*&_pJw_-)TnO8 zqpyghN91fZ> z&^Cb97&5}cAw4{7j(}w&Sn8mE+0asj&}jvbO$b3J$cugm46R_O*FupIt?Ff4?%sP2 z$|k5r=D^cY!vih{;XCw$S_qXVK&ioeXeO#(1iofpJQ~%*cO1n`#J&*pZMeNgI4hbg ztHHGedjdIzpl1X01k~90nAZrY)h8e9Y=zj@uC$9wJXct( zfD-=!T2m~d`+^#{!@8>xG=GHVG0hh>?&K72f_Y8AYsABT4!aI|O%!fU15+dZ1XU_L zRNn`+9ts5RMm-D{+TLV4QM^jxBp@0pF+u^xIb;%9ZjUj-`p{z!>qpT>S}oUvzi>_X z6>0C1_Bv@6>wAjzA7OnV*5AYW9$@`hAaG6ryE76shB1RqjXjKF5FQ(A!dUhECU}VL zLTf8n*9OC|1wn4~kdC=W`$n8sr7CTnIplN0zXZ`y@nU5qmT1CK2N;e#QQl!mowRt0>7kE zPM6ArZem+tT=_a5LcYei<*OuKhp^q%DZ*00LYXl{U*g>IYn)qt8E5AY#v&ojr~6gY zK!^p#M$NxJ9y2vBuWk87#K9ALNR1dlAj8ziXNl@rqViH0dueD zZ3B1dX_!~rD*FgLs2lMJpQ1EL{zu3$OhSWYT7DNmrY{g-KZ!0}#QR--fgU{lLgvYTQ@j6582k9Qn{GTPpSDrS)JlO8!2^7mHWtrRAe*?ju=Y%-_h()p=!2Hj2DdeDT@S2|B?oyueq-fbt8Y@S|A(RLb( z%5l^Fx_us>1Uh{Dbx*zL918`Zc(qWB)dP%C%{qQ=Tbox4Z8|-7vQV5TA@NVy2#Oat zKMUUBeag1Fk_!3bY*u5+mP_f}BodT~XV<(7wN17qxv(YQT0t!T*|z#uBP-;Uawe@z zWT$|(TbV6EPL*TH>9m?G7L#+x_7NXNe#1UrH{UzoH{U-$Fu!Yl_xzsu!TG%iI1f(= z)XJ$0?F^D@T!S zE2^pEtLDqA9)^j{%)obzWPU=)6;47cl`N$nQIr&X@kkc4B}fBg8;xoOC{l3%_MB(6NNHLK(&{)`r9Eiru_`$@Xaa=O-MGB7Zw&T?1JE@1-?SK*fNo~Fx{*2mu Zzq?57);!6U$4It0?k)r2m1mZg{ta0OUzY#? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.TEST new file mode 100644 index 00000000..2b8d445a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-not-greaterp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-le.test ;; ;; ;; Syntax: string-not-greaterp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char-not-greaterp). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char<=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string-not-greaterp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly-not-greaterp (dotpair) "T iff the every character of the car of a dotted pair of strings is string <= every character of the cdr, nil otherwise." (= 0 (string-not-greaterp (car dotpair) (cdr dotpair))) ) ) ;; (do-test "A-Y string-not-greaterp B-Z, upper and lower case; comparison is case-insensitive" (every 'strictly-not-greaterp (list (cons (string-trim '(#\Z) upcase) (string-trim '(#\a) lowcase)) (cons (string-trim '(#\z) lowcase) (string-trim '(#\A) upcase)) ) ; list ) ) ; do-test "A-Y string-not-greaterp B-Z, upper and lower case" ;; (do-test "string-not-greaterp strings-strictly-outside-characters inequalities" (or (string-not-greaterp "9" "A" ) (char<= #\Z #\0 )) ) ; do-test ;; (do-test "string-not-greaterp on the digits, using make-array" (strictly-not-greaterp (cons (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ) ) ;; (do-test "a string is string-not-greaterp itself" (every 'string-not-greaterp (list lowcase upcase digits " " '|this is a test|) (list upcase lowcase digits (make-array 2 :element-type 'string-char :initial-element #\newline '|THIS IS A TEST|)) ) ) ;; (do-test "string-not-greaterp keywords" (and (string-not-greaterp "12345" "123464" :end2 5) (string-not-greaterp "55512345" "12345" :start1 3) (string-not-greaterp "aBCDR" "fghi" :end1 4) (string-not-greaterp "12345" "55512345" :start2 3) (string-not-greaterp "000000001" "000000000" :end1 8 :end2 8) (not (string-not-greaterp "000000001" "000000000")) ) ) ;; (do-test "string-not-greaterp is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string-not-greaterp (make-array longlength :element-type 'string-char :initial-element letter) (make-array (1- longlength) :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b7ecdd94b20e4b73bd4342608ba6089dc6b1304d GIT binary patch literal 4860 zcmeHLeP|rl5#NtHSvpDQlVi));V2tn%kEh#tPk6=5)!TUR?=Ck+tcly&oY?ia#~4e zo$lnjlWjHFH4bSLx+sxN-FOTv&%$u3t%$u1v@4dZU=Df#LT~hON^O>w&kn#(q`Gt}+l`lxe{6ZmZ zOH&}1UQms=c5XybM?0VD@|kNi>4Kdq*^`pBU>7G-iyczeVM&=UWU?^m>jSo{|3G(t zZ*Qk>NHKNh?PG0v`g{BOdk%E^R<2#)19^_)(p(uy9mfSYk#jFOfsmz{mOK>EH94w` zX(4ynb!s6OIbmvX*JbT3YA0KhyOQkw(L>1N@eYn;z$9-lp>bdw*Gf)$rfp zxaFD88~#y&2eaiHElH^oKrP2X3gt|?t^B5N4~3OZ6!mH+)`A;UBzJ)=9kjwAxH?+Z zVPk^k6GyR~MS=Ef!a%kf!|T-;>P|j7ub%Fz*T!UM_8zNYB}bnZ@?0y-fC3+yWIJT% zgOv%w^9bX)RgI?}CSq-c(?KhJ*%EC)C5!2u~e6weZxyWSev&i5^Hmd<^}CBf}BP1a2#Ejk*yX*0t!c zH3E`tAgKfWs-U?FVRsZjwj%_Mpf1`m5bOX!y`slPl&Y2M1iIE;kACPz;=wyn!JEy7 z@IBg5MMvfsFf~{Y#X>d#{+iT8Jg!C8T)>1!od&wC57!8@V#$(vR0qLRVEt{1itV6i z98*R$S&7G$2^7_kHXxq+pb<44XZHM*v?BR2c>>98A|W};gbPe)GvPB}<<*XAadhQ5 zNL`8dDN_6sMT#F%r1%y@yahv2Eq&tQ6;A?SDBfg--vV#-m9POhhN{N)1~1oJt@ zd^R%SCMp#EN`=DDpnrY4X-u*S4XbP5Mz~Abk-W>uTa0{@kr$~O;R17Win$p9H%+Ey z$zelHjKLBpxEs(%KWMgsW=J+C#s&>tuD6n})`F-46VYkl$`f_T%=ppl4%DeOJqYvQmi4XhCVBV<|2A^R?{_0Sry549*f zD0`FaNAfx&X8_Sqi4j^aK_OG<<>4G7q#G>`ksc&1jH{&__Xo;xKWE%+#(jfv4(Wb@ z^qe5wI_c>o-H(%=X>j0u4!nC~abp-O=qF^1p^?+@tU}S3|hM9OdauA5;pX3mdzmYy9H|Ug}>vRr}%gAvi z9B14hBc05AA2Z*}%>Cp^@FKoP4aBlj2hV#ahu)xxr6Ao8mqY*fNW5~igL z(iRl2Ar4-obvb54qLzjkh*#+};+N<&;>!RDRC9+lgcY<*guTRI7a44jg>jh8AEHF~ zBNYn2Vch$Se2we|bKx9pzUKAkfjk^H5;3{~g(+ryf>}iwQJ~_hukq;S8Ro5rk#<~= zAvjDDQQ9|%*v3>_aJk152JJq$A3~_}g3yEe1{nSy6v+RXkzX_N3r4;Rz#0}ULSF(F z&#Z^j@FmiOnp0!|Nse)|760QXOEcL~q9Uh}tw;tL{#nL7O~NSbW!xTyY$ibzKE{v% z#`zf1OF8ZVMRLC*_}_&4Ek$y_V%#q&lKX&hcNy|~WIH0i!;m)__icu}&bX@#`3l*A z$j>q4i;TNK!e_~jS)v{%%}Fv~k>+s{j*#Z3iMo%p>?H%cNlP0E2T4l@7<Cz0^j=9bgmR&4KZReFX zX(|Q(NhhUDj{TiP*?DXy&j;?8-OG5Fx2kasju?5}O{7PlyA|Ce^#CISw6{Dzbe)zB zan0I`XYz%~B6__;uroXtsB<#B#`KiyNGXXKSIFAjN<}+6g{E`NL)VfIx$Uka_;4gX z*x*w9z3c4X5KTTOm1b;dGBcei6+5JbA{0@YOU>GHs!&KRqN|VS6yh6jgD)LM!57@i zbxU1K-Ag@7y-Np{4lW&9>SLOjjk8X;j8#rh)Hdz z?|*VNS?HjfA`gxWXEH^W{=q9;{mB7-K!8{4l>p~D!E9>o`N6y&Q+3Z{{KYyxFEG?Wqb9NC|jlTp4 zWl#-kL&GDHBcu9Q)QFA8O)GIUd29mLkbjv4M^DlTHm0X!h>e4Q;r`CX^rZU<8`HDw Y8XND(G1~krqb;6)?*{Jbxs{cF0b#Q~&;S4c literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST new file mode 100644 index 00000000..ef6d5eed --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-not-lessp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-not-lessp.test ;; ;; ;; Syntax: string-not-lessp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>=). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string-not-lessp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly-not-lessp (dotpair) "T iff the every character of the car of a dotted pair of strings is string-not-lessp every character of the cdr, nil otherwise." (= 0 (string-not-lessp (car dotpair) (cdr dotpair))) ) ) ;; (do-test "B-Z string-not-lessp A-Y; comparison is case-insensitive." (every 'strictly-not-lessp (list (cons (string-trim '(#\a) lowcase) (string-trim '(#\Z) upcase)) (cons (string-trim '(#\A) upcase) (string-trim '(#\z) lowcase)) ) ; list ) ) ; do-test "B-Z string-not-lessp A-Y; comparison is case-insensitive." ;; (do-test "string-not-lessp strings-strictly-outside-characters inequalities" (and (or (string-not-lessp "a" "9") (char<= #\0 #\Z)) (or (string-not-lessp "A" "9") (char<= #\0 #\z)) ) ) ; do-test ;; (do-test "string-not-lessp on the digits, using make-array" (strictly-not-lessp (cons (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) ) ) ) ;; (do-test "a string string-not-lessp itself" (every 'string-not-lessp (list upcase lowcase digits " ") (list lowcase upcase digits (make-array 2 :element-type 'string-char :initial-element #\newline)) ) ) ;; (do-test "string-not-lessp keywords" (and (string-not-lessp '|123464| '\1\2\3\4\5 :end1 5) (string-not-lessp "12345" "55512345" :start2 3) (string-not-lessp "fghi" "ABCDR" :end2 4) (string-not-lessp "55512345" "12345" :start1 3) (string-not-lessp "000000000" "000000001" :end1 8 :end2 8) (not (string-not-lessp "000000000" "000000001")) ) ) ;; (do-test "string-not-lessp is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string-not-lessp (make-array (1- longlength) :element-type 'string-char :initial-element letter) (make-array longlength :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL b/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..11c9bff862c5f22253bd1005df07a5e49e659763 GIT binary patch literal 1680 zcmb7F-A~(A6u-__fk2jI5h@WK7G0;#;E3?i(ri;@%q668?8LraMx|*&5Ee9-APD=^ zP{+gilG3qim2W3r_q_73iLF&8^?i@~6ZSf^=Sl1w8)(#3+Lm19+~4`SzjJ(ivq!@3 zsG6uYZmq96wGFYc)m-0diYtu`akH_tu~ZXRKreo#8YcaGUQvsgH?loehh=G_w%DvK zi)^d5xxDzvsF=MbD(f4o4s52U0cLYk*# zLdX(nqv$3iPJ+b!x)qlgwU|6t(5S2{B`UdlZmSDwk!_2bZYwb^HXG}*Q~R*yU^%xo zi9m?^RjX^x)>T$8boah+Tj+J~wfYLWT!zw=JSBmylPs8Ba9i>0v^*h~lp>WaW)}23 z*?-WtLx^xU5f31vpX-l{!r>bE?MX3EO{Eh;WA;e+C~iE(VlkCh&?4_uYSjf6$3&aY`-6< zp2q}W?;@m^koM|Qy8Vd!*inga_q39(Y7%%K+;qZD7&fqu4vNmQr#(8jjxp7wv-HE! zK^FJUMeuNj0g6rvPCy;-gB>g-j<74}#H7Kcu zK3l+NE6*$XtVT_FrT`i}Z%Kg&?+%1va1xTLFm+xwDYH#@@TxaC5o^I>v=j({N6H^9 zRilb-m*qLbELjp40>VF|nIZ9Lup11aN_K4QYzA?9f_=O@7zI;Uomb2Xj|XwsViGk? z!;}r1m2D;kd%&SrQuGDc)8j!nbvF43x2)ULTSd(WGKd_8fKj_Y<;$z;X@a= zh@Qd@Xv1aG$m@ujP(!?fl#IRRaWrARu-8UJ3|{t#j(zdkMER?z&4M;W_1SR*qv&EW z#bh3Q9a4+g@rlW)D=+*^O-@XV`$r8yE{C z(KJtZm(jZ08e+B0rZ~K<42vs^aAhxxt84yki@NPgSnlxd6%?^uf+Db6K{~&>-@5m4 z>|aq$sxT@)Hy>JoQB%<@9tAf(;@5EKwlcXH3R6e@%hmhGXr56xJ$u_aVUziIx3cCZ VNM844BIKRSGbee;!|CJWzX1s4*r5Ob literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST b/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST new file mode 100644 index 00000000..ed283579 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-string ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-make-string.test ;; ;; ;; Syntax: make-string size &key :initial-element ;; ;; Function Description: Create a simple string of length size with each position initialized to :initial-element ;; ;; Argument(s): size - a positive integer ;; :initial-element - a character (default: #\null) ;; ;; Returns: a simple string. ;; (do-test-group make-string-group :before (test-setq charQ #\Q q100 (make-string 100 :initial-element charQ)) (do-test make-string-test (AND (stringp q100) (eq 5 (length(make-string 5))) (eq 100 (length q100)) (char= #\Q (char q100 99)) (char= #\Null (char (make-string 35) 34)) (string= (make-string 20 :initial-element #\6) '\12345666666666666666666666654332 :start2 5 :end2 25) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..402fe0c0b2c75f112375d1ae2388fa23bba3cdf2 GIT binary patch literal 2597 zcmdUxTTC2f6vt0-Ama`6%h zscoV$nWWOjX1)W70$))TA#>OiY^SOCL2p;Q7x0*3v{@P08kX={^s+zpmD+T)k z?M=D*W1jd-Vr(ukE*SHP+3~SA8-%6b_di;j08)A1TEQ^ZNFZ-=!%XCvNVpNwk z%PeXZ=F-z*D)Cw(g>=r$ay-Xb@0srIs1h_ns$yN{&++-zMYABJh!ILn>XA8@dwmtG z&Rb?#Q>(aFRCGfNDLrCPii8X)96By@*RJHA=Qx*CFbMhjQfLQ)?shcBvyUvu1Y@*TCX&&3ze@WzfRub!`OUWC98(uZG9n%rmX@|wUw0^39CfG7nLZcsY zv+RzotyHWZAe95J3-Ws!UPA$CX8QzQ`Yxj9{;*$wpM8I~%kweYQTR8*;zPMG+;=s|bc=Nr^_p zZdL2o{fu|^9jL_Q9!N&-H zeXze%4U1Hts0`zMoTpQbDqRt%x0w&(V^#xUGT#EL8D_pPs|hgQPF7P-X4ih2lNHg_ z9tB!06|QV+2}Jarc@R;Ac)PjK-1J?|R?ri)i2sAtK|CO97F{3>jpFZ*`?sqyvLBG@&RqSLbfP2V_Akf0Bfv9TO z_4wH_J|JVJE*o~?esXNzG7<4NSuw;HEC8|MXrHo1XxAO>suTGx^TPPH6M4bW&auWf znD;ajkF(Mk3mB|)fHj6#X$KSQSy?R$)UdK@)>zKUw$Wsl&oXxziP<@!dP%AlCdTLo zc3ha8a()|OTSBM!hnDFbdszsMCnio+CnsMyojNm>o`&Z~#}nV``N%SHyz8;_%(wuY z0L}tcz!6|K-~(!akxlq9ss-u*5f}vy3ie|47!Lspz%Z}~v;%Fx9-taH2`m8(KnD;2 z4grn8VI(tYePCV2x2rO!$&w+9PdwOg$dENDtg}1{V*%$P7?v4m>y+s;AUi+q_WxMs zHjBDZ%_V)kzGy5jSZ3wf6IDlc`)Wpn=l!*HqxIs!g~g%aw(6yhLx&pzXgI&aGK&ug zt-_1Keqo=`BJ35Kg(l$zxU$yE`#K$708RjBfhyn#up96JHNeOw{20{&b$|$r0#sgz zdSD1x0EU4@pdDxf_5jtuNnicml>test>18-3-nstring-capitalize.test ;; ;; ;; Syntax: string &key :start :end ;; ;; Function Description: convert the first letter of each word in string from :start :to :end to upper case. Counting for :start and :end starts from 0. A word is a consecutive subsequence of characters having at each end either a non-alphanumeric character or an end of the string. ;; ;; Argument(s): string - a valid character string ;; :start, :end - the first and last+1 characters to be modified. ;; ;; Returns: string, modified as described. ;; (do-test-group nstring-capitalize-group :before (test-setq testcase "word word\\word|word!word@word#word$word%word^word^word*word(word)word-word_word= word+word[word{word]word}word;word:word'word\"word`word~word,wordword/word?" testcase2 testcase stablecase (copy-seq testcase) digits "9 8 7 6 5 4 3 2 1 0" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test nstring-capitalize-test (AND (string= testcase stablecase) ; for future comparison ;; The result is one and the same string (eq testcase (nstring-capitalize testcase)) ;; ... yet with different contents. (not (string= testcase stablecase)) (string-equal testcase stablecase) ;; A pointer to the changed string points to the new contents. (string= testcase2 "Word Word\\Word|Word!Word@Word#Word$Word%Word^Word^Word*Word(Word)Word-Word_Word= Word+Word[Word{Word]Word}Word;Word:Word'Word\"Word`Word~Word,WordWord/Word?") ;; Results should be the same length regardless of keywords. (= (length testcase) (length (nstring-capitalize testcase :start (random 10) :end (+ 10 (random 20)) ) ) ) ;; Within the :start-:end portion, skip over the non-alphanumeric characters. (string= (nstring-capitalize "ab cdefg\"hijklmnop" :end 9 :start 2) "ab Cdefg\"hijklmnop") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..aef1aced73b67b3889e4229993ed70c46c38ff46 GIT binary patch literal 2485 zcmd^BU2GIp6uz_DmhI23yX|&`O({dM6&9v++k&NnIy;?ix1G*xXJ#3SBG&DeEwtUz zZut@U5sXHi6bpgO#gG_ZOnecVnDA%%U}9q8i!VkKW1`V$e8R*BjWP9{x#h<~qVHyZ z&iTG`?wNDXx##ZAkWl!?c;6a}Mm zj$Iq?5ZVOQF!hw06uLA^l|(}(moElR6XJO@6!c(PH}kjpxa$+#wU7HeRx}#o%J#Xr z&ewsw`-bH6(I~v5z0n&s(6|&Jp#PD(+s*0)t2$c;Ur>{5cuCf~EzU-mSh+BI3(8V` zdPOalzrHuHpalTlo>R_hflmmT%fGG#`aGN;)GMnj9>ap&M@SVR3!~YFg{$QI`+DQK zbf-5ytJ;0;?f0&dS3nO#h;#WX#U*uqzg36pfSuoCMXU&p$->@~|C3?A|DZT*wFU;9junVv?qIrSNnM zJ)+vB$hwe70i!03n5T@EdrDz+LNQ4+r5-_-&5RC5Uvg)s%osFGx!>afk1!i9Ns&c0 zlNP!)z2AsY&ci*p+SFpS(pwG&AC3%8$K6Rp!s`c<-!R35BBPN8y_LX}b)}Li(*RTj zs3Z+D33>%B_XYr$-wD+U zw(z}LQ+zuo+-*`5l6WC>R1psy_{v7`tM2ApI!iQTQ>6q{+G@BP6r| z1osRTM9=`cl)>wkXKf_&=R7XP*l*3C{|$ZtnL80zo>xXEMyRQAcLf?Wzud6+!49~ z{R-~GxEGjs9Af$V#lDQ{76Tn3G=!oCGakrjrdzKdBP)O`F=W#%Y^lqU-|1%XCqL0z z6hF`w6yGuQEsZ1klA+I-=QUc58jsSjTlsOvUSsB_i+sZgv4I~Mg8v1>{OAPx zNk{Gkw%+4)&aasD&sNQr&sNNyob}CC0n7dIQ1&awjt;$;9nOvH%a86qFg89>m^?T& zU7R^|_{hUH|fPYoA&7SmX12Q*8Z)y&Huc$BsX{r?cV2_NSiS)QsKX z(vIzKiMO`3Z`t}p$2MfzVH09P>XN&YJ*nP4rC-(31G-^mc3QgzccVv)<%Xw${K<5; g#h)|XZQ^C7M<$r8d78;^iCX}=mB9_T@=Kufz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST new file mode 100644 index 00000000..d8339999 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nstring-downcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-nstring-downcase.test ;; ;; ;; Syntax: nstring-downcase string &key :start :end ;; ;; Function Description: converts all upper case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to lower case, destructively modifying string. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: a string of the same length with the specified conversions. ;; (do-test-group nstring-downcase-group :before (test-setq testcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" testcase2 testcase stablecase (copy-seq testcase) alphalength (length testcase) digits "0123456789" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./" ) ;; (do-test nstring-downcase-test (AND ;; The result is one and the same string (eq testcase (nstring-downcase testcase)) ;; ... yet with different contents. (not (string= testcase stablecase)) (string-equal testcase stablecase) ;; A pointer to the changed string points to the new contents. (string= testcase2 "abcdefghijklmnopqrstuvwxyz") ;; Numeric characters, punctuation marks and non-string characters have no lower case. (string= digits (nstring-downcase digits)) (string= punc (nstring-downcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (nstring-downcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6 ) ) ;; Results should be the same length regardless of keywords. (= alphalength (length (nstring-downcase stablecase :end 20 :start 10))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..870d016aacee864a2c3fd966cdf0404cfef42290 GIT binary patch literal 2477 zcmd^BU2Gdg5Z<$s)N$fq$F6CuG`*%Iv~JIhleDCvrJOGp$I0c+xjWZQp_Je_b=o9O z6Q@6vrhf@OC@+m zK6~c-c6N4lW@mkKqWw`e_Zs(&d@X#P-s6t^=rML0t2w=GXsMwQHzrrPJZlU%iZ*7BuPAq`s-lQMC6mb{>M z&bET_cA-^J4O364NgtU#Pw#t@4}#N7H;)&*T=bQANRVlkw}26*ylt# zUkCE;1ECip5qKg!ksB7!I29nE|B<;<%i4u(ZLSV}ASb!dlB{3U4`^u`*kq4I$(F_>hMAizf^BKL2@#;YaNdeD_4a$8(6~=&J%6%>uScF(>Ns270 znY7TQ>3v3&axU(lvrR2ZtK5|^;K7E$?zr2BNVt74frz`;k})M71%{m(Uae5|+WJI1dJy&@yUg8X)hw`+pB~?TRA+Ny)GbP|zpne?PjkZp85%t4WUZG;Soa!ZL z6xnsamcwz=of@tMRfNt7N zgIU^a(qKQ0r)Y2+-L!#**3srh8fu{N2n{)TAG591W`3%~H_V6){O};W4-D}m=y7hZE2-}Yxe{N4l!_2m4c5IAcb-1)``I_S` zt!PPW8=k%gOgLG=|hK)9DNxrqAWH%4dhRzJ0<>{ d=}r+ZGd(=cWN-(Qp)w}{bPI#)$))7t;@_9kppgIo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST new file mode 100644 index 00000000..fe140aa0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nstring-upcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-nstring-upcase.test ;; ;; ;; Syntax: nstring-upcase string &key :start :end ;; ;; Function Description: converts all lower case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to upper case, destructively modifying string. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: string with the specified conversions. ;; (do-test-group nstring-upcase-group :before (test-setq testcase "abcdefghijklmnopqrstuvwxyz" testcase2 testcase stablecase (copy-seq testcase) alphalength (length testcase) digits "0123456789" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test nstring-upcase-test (AND ;; The result is one and the same string (eq testcase (nstring-upcase testcase)) ;; ... yet with different contents. (not (string= testcase stablecase)) (string-equal testcase stablecase) ;; A pointer to the changed string points to the new contents. (string= testcase2 "ABCDEFGHIJKLMNOPQRSTUVWXYZ") ;; Numeric characters, punctuation marks and non-string characters have no upper case. (string= digits (nstring-upcase digits)) (string= punc (nstring-upcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (nstring-upcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6) ) ;; Results should be the same length regardless of keywords. (= alphalength (length (nstring-upcase stablecase :end 20 :start 10))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..57f962a0a50796bd56b5ed26b46e06958a19fc69 GIT binary patch literal 2002 zcmcIlTTB#J7(TNLTkhF~1?!4>K(Mkf%T>h{)L}R*Bg4!xmr_KebXi;~vV==*gA%Gq z8NndO=`_R|E_PvjNXws(d4gLQar7BI@mnM_%KmYwQ|C!k$#c#B3zqXvo(m9aRby+vqtzk(XNu2F0GhfhTma{Xf*;#6> zWmjfrK4_zzXQ;HaJih>k-d^PMu+ueRBg!6=u z3@IQfB_vFO#Qn?($1P@B;*g>;QIkel+}(1W66i&=O=h@Gq>HZRm&Aqad)WnS=lTi} z2ys7kN``DrwiI1+?+cqkg?rDbR5URStw||H0wvF)V06KC>NBop)In5i$!KLNJ-_G>jl?(uY0L9YV#_bv6FUiAYZTe*+*s*!+D z3CFJwj@MxT(3cQWK}caf^LpVMa__~)A3SfoWW0L38X5)99nm{^0FvFELl6RV3lgGx%V zOdbwa0auiU#pPkw33tA-+NB{vcoFV%6qoW7NKwSzlvHFs1SW)4OBS*l5GW$shQYKK zE)N$_mj_++@2O$^enH&Z^+BxMR7TTqbvN7AQ`G99h{@@3}lKjSFNPgyrkT~F1VNQ$==&A@U+H4)O4CuBtn4aQP z$?V;VYi+0iu-{le1TRAF?*qYZry5HpyBp+cXW43NF z`&Q_Mf27sDI-VD>VLmG{=kDq9n zZWa62Z%s}m8#nsSoo`FDqt%zLcml>test>18-3-string-capitalize.test ;; ;; ;; Syntax: string &key :start :end ;; ;; Function Description: convert the first letter of each word in string from :start :to :end to upper case. Counting for :start and :end starts from 0. A word is a consecutive subsequence of characters having at each end either a non-alphanumeric character or an end of the string. ;; ;; Argument(s): string - a valid character string ;; :start, :end - the first and last+1 characters to be modified. ;; ;; Returns: the modified string ;; (do-test-group string-capitalize-group :before (test-setq testcase "word word\\word|word!word@word#word$word%word^word^word*word(word)word-word_word= word+word[word{word]word}word;word:word'word\"word`word~word,wordword/word?" digits '9\ 8\ 7\ 6\ 5\ 4\ 3\ 2\ 1\ 0 punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test string-capitalize-test (AND (string-equal testcase (string-capitalize testcase)) (= (length testcase)(length (string-capitalize testcase))) ;; Within the :start-:end portion, skip over the non-alphanumeric characters. (string= (string-capitalize '|ab cdefg"hijklmnop| :end 9 :start 2) "ab Cdefg\"hijklmnop") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fc979a19d3ce8fddfa1bf1370cc5a682d9663247 GIT binary patch literal 2301 zcmdT`TWl0%6#i$oTiWe**|tk5Yk{E`DO+aS(xRnuo6b(ROJ`@cb73ihq;9utOX=2L z5JYN&Mq;vAsEuTPl=!I82a#x$i*AfQXhKYUG0_K&iALj-PsYRtJZJuLv6ASk>2}Zg z&h0;!|IF+n@f?s8UdkPx8k@*W^SQa%skvExG&jx9UpU$4` z?L8gc5%2BG7r8)=5RxWEB;|wzh@03i=L2C=HcX)}uE>HaCgiZaXy?nI7Qr%P-Og8S z<7abI!bIjoW&+DOK0`P{>MbjR{dLrAne9lgk&qX9;obt_rv?s~g#y1KhPq?(9bcu2d*g#g!g)QoULa z^zH|8&xS(q3GEAA&x06U0Rs9zn>*797NLZ6bukr$D$~3(t8^_Rb;YrppshZ;Y7LjY zcEn%Q`~ZJjRL*PuPYGGfp40pTF0K;TE9+AA7!UMig!l+4j-@vg-zB&1>#|F|)8(>M zwR0YLUL6O%8qP-kP^vanyUeSpx>VgVzjrw_*xcjbsB!q8DD`@ncO6DWiSt#tEMCao z`TNhc)IO*d2)r)@`4qDOylb!I>%)?!M&o!Pg?>?uDzYy0#zCUSjIgVemb*M~+pEHo zXiEKpE}NDPw^eekd#N#Gm~z790*fHq2T74d)k+F|nw~JilyhARnNTBy14yURv(X6{bF%5SBWEG;4>=zYTjhX#4VCMrJD^|1|hE7XxFL_+AZirnX?-vyWtpG}~ zD$zvP0`aOOOV?%fzJ~ziP`3_r!FyfBI#?#O0@U0u5UIw9Cz9~wSYB*-&~i@UegfU< z72A$JUxD2JH=kW7{*rD)@(Jc9X|gWK2tS~kki1Q?3hqs2^EyMXF|@?c1%}Qs^a4Xi z=tJmth}I)X(Dg`ycm!)5K=LaZ$3O*|`%>pFH)9<4OL2^C}bKfTcPef+*x? zT8-pKtZLBGOs9!IFyVI~EHPwr5G}rDvM(sMjC@F|ki1XZkX&Wx9omlQ4Tdf;%a`a{ z6u!tTpJ!-+wx6VHkI~3MT9cw}CaoEy?QvSOlSW!;u!XiY(_jN_57D3>oL!sj{6;e~ zGs`#3iw*qfFuaXN__0a$B1PGJGnjGL?WI+P%7U*@Uho#4E0h&{D82GP>A3x>y@bz< z4U#U4rYx-36(w%Ux~Lem0?cR|Yq@3TBR#z`Y@p0ur_OJL*}IwDNon3#P7-^?LG~M- zJ+x_WV^i}J4~JW}9BCDHoj&vU;hu*1oxAsJjkGx{60-A^?H$`XyS6{_X!j2E^Vs>2 z*egZlzF2>J-++=(wd9~~nAZN(fuVz7LH=a9ITO6acxNn^8NYUt(V9Js21}fxX%~Z= K$))J++kXN0ly)Ql literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST new file mode 100644 index 00000000..b58d570e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-downcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-downcase.test ;; ;; ;; Syntax: string-downcase string &key :start :end ;; ;; Function Description: converts all upper case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to lower case. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: a string of the same length with the specified conversions. ;; (do-test-group string-downcase-group :before (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase '|abcdefghijklmnopqrstuvwxyz| alphalength (length upcase) digits "0123456789" punc "|\\!@#$%^&*()_+-={}[]:\"~<>?,./ ") ;; (do-test string-downcase-test (AND (string= lowcase (string-downcase upcase)) (string= lowcase (string-downcase lowcase)) ;; Numeric characters, punctuation marks and non-string characters have no lower case. (string= digits (string-downcase digits)) (string= punc (string-downcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (string-downcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6 ) ) ;; Results should be the same length regardless of keywords. (string-equal lowcase (string-downcase upcase :end 20 :start 10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3edceb463b237b1179ef527bee2d0a475114b16 GIT binary patch literal 3246 zcmcInU2Gf25#A#uMSqm3zq)2@XQMbpKHhP_#u|@Q$-HJ2T(R?Cx;6MOsg(I#p}y8|8{yr?pLQW7DInwK{FoHtR)~u7aFi zP)$qw;k=?QjC?EAY44gT*4={Vu25&wZLAcY9j2*Cs%+HD6&OrR0GpZ`ADudWe57+$ zv323?-`b2#jUSsD8y)GqdG!q`UL%AQ$qteZLgFM!!q@zG($Q>3o=xkTY$zEm8E%Ds zJLDqgY|RS&-cjn+Hsp$X)~#SV>kT3i629uU&*lu(Nt;HvEnSkj!&m%R+K{u5nlh)6 zNc$}>=v@l^!PJC2CfkmcHs)kqn{{LuX2{hy_FX0mc&yhB0=@k}@TEiop2W$-uYC}sDX_r(-_?slJAhFR zo*lCX*c)5=D`wAc3E3*WX!a~bq!!df25$$v?eMn2+X~H~ zH>oO)IxkzAle6G3tGpYu*-N&gWg-#K7!d73)iuS)W#w7Z%GgOJMWnsfj+ta#(N5M8 z?SbadlhiEBv}7~qWOGh3x(^JxlZvq|>BwxFCx#c;_%w<_0SdmY-75PZ0Ul-&TU==%-8XY@6 ze&X?oNul{J2or_n;)=VvRw{r0naX;#wsEH3@HWq$JOAu+Lg}Zdq)e+b+U(qX`s9M1 zG0g0uWjnd2^QV?h3#B)q0x?+6oWU!NVZ6)+ko*{nx|lN^+*0HPA-n{_7F%-`&$EGN z*wNE$Fwce^Hn_;-G#h+^9X-nWA7jIhvi>0^Cs;q$JUSZslMSz4uCBr5VAYdhxK4|u zLcLJ*+`7D6Sff=JE;QAeN0(h%s8sIEHqgOH=s)DR4UZ08REFqk0q#dDv|JTe8-P6>yLB{3h1(G}3|~#!8f%XB4Ztl$skrCM4GK?zE|qYMG5B-_F_fJPw_8Bc9drck$gd;6Yd+88WXi56=0ksI zPZUt7Vxi&64Y%4Td*!n(I-3!=P}yiu2$q8)2&FHPQ-bM0Med6|{-sYt-`eB9Sg2CI zBWkOw)GN8vt$O9UONAnZw4rBHQ43mkS2m#zRqyUPNFVcfq${CM5PK^aNAeOhb}@SX z*2LLxyDOLsCW6O<6Tx_JJQxc`;gjNfK>FU^kQYOLeox2^xaT(LxsqF@We?&l);6oK zlN)e>Uw6F{Y;?YtVTaze%Q2*k2s9D;U;kGJ6V-ZgL9vwi;B>GQ%z%u1xhFdEr_djn wn%3Y)N)tD3{x`zAeN>ufcml>test>18-3-string-left-trim.test ;; ;; ;; Syntax: string-left-trim character-bag string ;; ;; Function Description: starting from the left end of string and moving rightward, the function removes all occurrences of any characters found in character-bag until it encounters a character not in character-bag. ;; ;; Argument(s): character-bag - a list of characters of type string-char ;; string - any valid character string ;; ;; Returns: the substring of string consisting of string with the elements of character-bag removed as described; if the function trimmed no characters, the result is string= to string (but not eq in the Xerox implementation). ;; (do-test-group string-left-trim-group :before (test-setq upcase '|ABCDEFGHIJKLMNOPQRSTUVWXYZ| lowcase '|abcdefghijklmnopqrstuvwxyz| digits '\0\1\2\3\4\5\6\7\8\9) ;; (do-test "string-left-trim stops when it encounters something not in character-bag" ;; In this case, D should not get trimmed. (string= (string-left-trim '(#\A #\B #\W #\Z #\Y #\D) upcase) "CDEFGHIJKLMNOPQRSTUVWXYZ") ) ; do-test ;; (do-test "string-left-trim can trim off the entire string and to accept redundant characters" (and (string= (string-left-trim '(#\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\2 #\1 #\0) digits) "") (string= (string-left-trim '(#\5) (make-string 5 :initial-element #\5)) "") ) ) ;; (do-test "string-left-trim is case-sensitive" (and (string= lowcase (string-left-trim '(#\A #\B #\C) lowcase)) (string= upcase (string-left-trim '(#\a #\b #\c) upcase)) ) ) ;; (do-test "string-left-trim accepts non-standard characters" (string= (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed) 'string) (string-left-trim '(#\G #\Page #\Tab #\Backspace) (coerce '(#\Backspace #\G #\Linefeed #\linefeed #\Return #\Linefeed) 'string) ) ) ) ;; (do-test "string-left-trim character-bag need not be all characters" (and (string= digits (string-left-trim '(50 '('(5 10) '(15 20)) "Alexis is a bitch") digits)) (string= "23456789" (string-left-trim '(50 #\1'('(5 10) '(15 20)) "Alexis is a bitch" #\0) digits)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..73ec729108529794782b70c0d7841cdadf98f7af GIT binary patch literal 3240 zcmcInZ)_Y_5r4a9yZ#^lOVeJR^wmiPJ!ehs95;?j1?%(ryz$-cWp^(ZM<8@LuYE_) zcjj)LI1P=W78OO>Zg8ze``Sk03-Af41R+rf7^$DCeyY@dsD#7^KnQ^l{lF)xhMD(r ziJcPyi6HNK-pres-^{#uvkkiXa z)6!mAP?L)j&&9j#T|33PTkzav>TI};<-(<-G=7q*>-BO47Sq$f#%HDyGslllbkD1H zT6p`9Hj^_`$7ZJD6Ww=i-jD`rgpeZHLDEIY0Ev+Bb$=k{Xttxw>uF6f)QlDjw?e-Y za#3=&W`+J>f_k-erQ%+2E11q&gGhvg-}5`?b4Jq9O(Wcvu1dY(b-zzHlq{sCrZggV z-t~gsrOFZ|ydxUJ2zH9a`%2FRJ-+4SgigChzCn3Fr?39a#c77u3yYs%>%)1k% z`7toW1(5$5=74}fvt2m5K|XJSba4=RALQ0SlvLUwMqKo8WL$yD)zZTYL9RDL=*u7B zK^y@Dc(zKf<;S=HQ-|jvV*as-*@FO(BDlxZeePjHM!wdB?9Ef26%`P-hMU0oyORI8 zx{%MQC|r!4(g2Zr!#DiVSkg4+biAR;f@;jAHA|V*L1LurnB2p<LeEwOLKA-T<0X82Oaj3?PwWU28|IhFp_CaHF8;H-n24yj7hT8YVDXY))VPw zU6Fnm5B)LCvP?@cb51tr#3K8^pf{!(OA42xlgI$bI_C70?%4O{5KfTDAa3NcN!8Za zP-FMrH<>4h&m$kUasu29r6<(u`eW zkV&}r1=t(8Uq*xz!LlCMmOsa=Y(0~O*(pZb^ChL|dNS%_GZVm(z9TeV5*kaw$r<5fUO0JDs6571$fsO|{Ee%S-*FY< zgXdm*DKl%P6*z*Nb{UhJHFL&X_UnwM*;5mY9%N6A17u_t_S&MXf zr^CR51ouNht^?FQ z-GJMprWGx%WuQ60gY=wGP6(~ToRGgjmmFw0ZzW}!xhxw3Gx8BPBOeI;+k*TU%%X+! z#btM8wN(D*3zfBMZT(yIhPQFy;^w6nh2@V>Nu5p3Y4fQC{nTPQW0={~mhI%u>S&lXX6grf0`ZD z+5RuH*f<;hA{&324Ue&-Q8tWaj!cIBOv9^}tE)=Ayjt=USg+AysZcKzJ-4o$FRaq4 z3m-7mnn%yOv{0$s-)*3WFNOY-j@$6)*cEk*t`y*VXqlF);!_4?SNI|QBiwFJ1o3cN zX5;XyN!$CHt9>J41=m)sxSQn$g{MHzm%U<%4F$&lOa3(U`;NsElgFo?Ju!U}CBF~1 zBZ;PqCf)6nO`+Nc;aji?ML(3ZG}Y0R2X22_cQi{)+pLHC5Dj%Z^b@VMDHMzDy4Ro$ zcde{6yh3%kP+#6#6Zz+C0#UymZg&KI@Y4-%SI~>HO$azh1-(HRa@BCVt*L?hSso|* z>aHmC&_CQ71=OZkXt+wltv1SD`GSkqnt<&_h|St=hddhT?a(I}$Lj%}gmew2w^&`h zyKynx?g>r?)4_@0*y@Cxc@INp?&)rf$q4U9JZi*%tfgXW7!}fng(BZbdkmSwPJ9qvC Db)TA9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST new file mode 100644 index 00000000..2b83dfce --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-right-trim ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-right-trim.test ;; ;; ;; Syntax: string-right-trim character-bag string ;; ;; Function Description: starting from the right end of string and moving leftward, the function removes all occurrences of any characters found in character-bag until it encounters a character not in character-bag. ;; ;; Argument(s): character-bag - a list of characters of type string-char ;; string - any valid character string ;; ;; Returns: the substring of string consisting of string with the elements of character-bag removed as described; if the function trimmed no characters, the result is string= to string (but not eq in the Xerox implementation). ;; (do-test-group string-right-trim-group :before (test-setq upcase '|ABCDEFGHIJKLMNOPQRSTUVWXYZ| lowcase '|abcdefghijklmnopqrstuvwxyz| digits "0123456789") ;; (do-test "string-right-trim stops when it encounters something not in character-bag" ;; In this case, W should not get trimmed. (string= (string-right-trim '(#\A #\B #\W #\Z #\Y #\D) upcase) "ABCDEFGHIJKLMNOPQRSTUVWX") ) ;; (do-test "string-right-trim can trim off the entire string and accept redundant characters" (and (string= (string-right-trim '(#\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\2 #\1 #\0) digits) "") (string= (string-right-trim '(#\5) (make-string 5 :initial-element #\5)) "") ) ) ;; (do-test "string-right-trim is case-sensitive" (and (not (string= lowcase (string-right-trim '(#\x #\y #\z) lowcase))) (string= upcase (string-right-trim '(#\x #\y #\z) upcase)) ) ) ;; (do-test "string-right-trim accepts semi-standard characters" (string= (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed) 'string) (string-right-trim '(#\G #\Page #\Tab) (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed #\Tab #\Page) 'string) ) ) ) ;; (do-test "string-right-trim character-bag need not be all characters" (and (string= digits (string-right-trim '(50 '('(5 10) '(15 20)) |Alexis is a bitch|) digits)) (string= "0123456789" (string-right-trim '(50 #\1'('(5 10) '(15 20)) '|Alexis is a bitch| #\0) digits)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..86f0308bf37304abfe8230e4e4e74fb4d34c5a43 GIT binary patch literal 3235 zcmcInZ)hCX5r2Cp$)~@TEGfoU%Xv9$YOdakPnHr{NhzzOq_q4m`vkaj*pH{wW zPIvO%%70tOIJ8M%Sw|5G`(oUFN$97N)CrW-F@p9>@ux!jp%BQ2B!rR>FckVFEzZn) zKKUFM5{Qd-cizmKncvL3_vW6~N&7K1P1V}UYPsUnX>HA2U32Mjtxg-YwR+K^%OIy0 zRKwJMF{h~WiKmiXR?AGW?i5^SiP~#UW2tcN08JjI%4)q_fx*NCu*u2s(aEu~MAwXB zrG>X|wK+67o}5f36J2+%y)O0F2q8tXiKLT|eiA0Zt6qQH)+}3|Nu@PeS29{WSP#4i z!K<%)CKsbD%Q4I&W|yy8V>a=L1#3_aM8E=fJX6|Xm?%UMWGnbk-r za@PxbmjbUpIUygCE!#}#vod@$c!Y5U=;WAFWoGE0Njqt+jdH&_kY^AY4ibm zdp&){==(Dv>!lZszWI>U3&VGI<#%J4FdreLhmg&3anI)OL-Va^pKqoeL1{h)hByH7 zondwg7&L3aX$ARj6Qq-a(0d@)M^I8}hZu3t&5>~gDwj$RFNDykW(d9cy*!A$fB?_0 z^D)k1;tw11(kBTAM8WB1 zsh@;;g4ev=an;bLQ+PP#IYpmNYo)jC%h4OJK$}HPB0Kx6WS#=11H)EqWGBGafSNN+O>gOdOv1VSFgJ9s zj0h)!W!*3xx`SC+sZ18yrs!%vM)7|@+}+aUQ1&k_Tg*%uY2IN`_66IG7za zkp99Aq~CBADG(~JVYnG(zL^)`NG}MDp9_s+!bwgz(S(ydLS-jcA-A~-`I4)UkGKl) zz;ll!3IPj}(=K3AQ$|jo&OXB)OS4#lJvPE(eBD%-YtNd-tPTN$N08%t1-T*k`RUMc z8TqQVvwc{M+puDh(L-b7PdqtsnC(E(n`|$Vt3tsOD^61FlxBAA7{gPmay6I0((5ghM#8gkJ#XTme|JzW9;!Le8Dz67I4ya18&~W62Q*D&p@@WU{rUfvRG3=l9&-v#;D1C*T;!pW1a-TflTKaq79cgu4 zEL169`P%X_bxRI)s&2XNP@zL1Wh$yb>(0^|6rk$fUjXT^JPzq<;1R@J_s5aE1YKQ> zp1(VBI@sv;5Bn4Tll~L_xIg9}@<-t>$roCB_Q6mW0#9oVwE>sg20c@9scml>test>18-3-string-trim.test ;; ;; ;; Syntax: string-trim character-bag string ;; ;; Function Description: starting from both ends of string and moving inward, the function removes all occurrences of any characters found in character-bag until it encounters a character not in character-bag. ;; ;; Argument(s): character-bag - a list of characters of type string-char ;; string - any valid character string ;; ;; Returns: the substring of string consisting of string with the elements of character-bag removed as described; if the function trimmed no characters, the result is string= to string (but not eq in the Xerox implementation). ;; (do-test-group string-trim-group :before (test-setq upcase '|ABCDEFGHIJKLMNOPQRSTUVWXYZ| lowcase '|abcdefghijklmnopqrstuvwxyz| digits '\0\1\2\3\4\5\6\7\8\9) ;; (do-test "string-trim stops when it encounters a character not in character-bag" ;;In this case, W and D should not get trimmed. (string= (string-trim '(#\A #\B #\W #\Z #\Y #\D) upcase) "CDEFGHIJKLMNOPQRSTUVWX") ) ;do-test ;; (do-test "string-trim can trim off the entire string and accept redundant characters" (and (string= (string-trim '(#\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\2 #\1 #\0) digits) "") (string= (string-trim '(#\5) (make-string 5 :initial-element #\5)) "") ) ; and ) ; do-test ;; (do-test "string-trim is case-sensitive" (and (string= lowcase (string-trim '(#\A #\B #\C) lowcase)) (string= upcase (string-trim '(#\x #\y #\z) upcase)) ) ; and ) ; do-test ;; (do-test "string-trim accepts semi-standard characters" (string= (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed) 'string) (string-trim '(#\G #\Page #\Tab #\Backspace) (coerce '(#\Backspace #\G #\Linefeed #\linefeed #\Return #\Linefeed #\Tab #\Page #\Backspace) 'string) ) ; string-trim ) ; string= ) ; do-test ;; (do-test "string-trim character-bag need not be all characters" (and (string= digits (string-trim '(50 '('(5 10) '(15 20)) "Alexis is a bitch") digits)) (string= (symbol-name '|23456789|) (string-trim '(50 #\1'('(5 10) '(15 20)) "Alexis is a bitch" #\0) digits)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9a59a0649e11bfeb0200cb505ec3afa8018e15e0 GIT binary patch literal 2293 zcmdT`Uu;ul6#s6!j;(8J*VQrVfXn{K=(yd+hK>os-Q8VRc6)Dk|4@b?nO(;=#yYnS zL1Yp%5|d^y7s>rl;-f|%M50mtXk+w26Jp|vi9TpdG#a0LGA2IYIrl4nh9vrG*7cm< z`Og3IoqM}PJbNXDmvTpDCZ@8pd~QBJGoRi{Bj%~a+GdnQ_Om{cHj-IVsdb+w|-hRFn9s z(bL%;^WMC8o(tv(AsJFcQb|aVxQYErAs97f!xZ`xiY%yNQjXe7cA)}l5iCR2?Lzey zKA)Qrrm{z~Q&`TCIl>WQpDR@KTdHIxG}T__PH{f_Y{8#Ug%p$~#%1EFD0xBeoLvZY zbPJt=Vd@DrE?6l^G-Pt|y!SLAuE(o`F3joL`1L{V$~1TS<3U$C5~=3O4>^fmt_OPi z1DTIUBJhdqj$AE(7)=2J`ai2Xvk4WUgiN@Y4ndU}-kDUUmXW&R#C13gonG}IH-6<{ zpr{1^{=TG~)dHUpvNV213kuNLZ~lBV`0@Hz?uqS~j(y3m^di5fSeu5w!G^1xlMj!L2_ z4G6kyS~}cS$+_(1#;{?^NtX*W!fYEPMHW>nCG=~0(uh*d#r@OT)S|S?T?q%}>^|RK z9K7;wKOC%5v^3sy8gy5oUSA@fFbzOHKxHY|AK<;T(j9>92}EUG*K|R%%#>wD-4B3{ zFDk0Tf+NQ?+(D34iArifRAe=74$z=o2zK1Fpp`ImT83N6<9c<2?=pFhs32$sP>xlJ zCc+l*S1nn(E~|Gv0w{-PYv3$=r>j^8%Y;_JG50HYsxcDD6g)RdYb_61P89BEIPYaBrG8$h2iob1&U0or3>T=FgI^lFycmqK`rHX?bOHX$j{#uK#Z z0BuxgQ;asQg>MkMI>E-1(zUpXs2TbeT2Z`!7lH=y5C`pX=84DykI`}!r-8%a{-7;L zegLV*Fhw0l#C-?IEvtRVe?g;2KBt?Ie1fU6KnUNbtw@F;e9g-6ab2@gPJFJHZbYSR zEK-yayp55Or!u42u|wk%lZU5{Oy_2vo}J6jAARQ7@n;=N@+U;|C&fWab-Dvy$S<@S z$xm3*kfoVU1Ak<~??G5*$mS4ge8Xg4QfwFbh=!1SK--X9X6Rkoj_6H>E-=lP>1q_d z#57-E=oD=~MpqxEv3;~AP1{UbGep}Hv}QYvwbF14ZEL3C2HGB>;Q$!BHrR#rW_B*m zH!O$^{MZP*g-7{`Y4!p|*+Mg@aaZl-Rg3;b-(uyWck%hfibWqvFWpx#K|WP^fWANe|+cW81|5h*ad%k$Cl2nt&cp~y$vNEyATn3 zr9QboK9JZws3cV_HKZG+wI{uIcpqqxzgTY01aC0j8Oue+ubyVKW+$WJGN)+T#o$JA Jq3`C+zX9_-bH)Gw literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST new file mode 100644 index 00000000..16797e06 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-upcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-upcase.test ;; ;; ;; Syntax: string-upcase string &key :start :end ;; ;; Function Description: converts all lower case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to upper case. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: a string of the same length with the specified conversions. ;; (do-test-group string-upcase-group :before (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase '|abcdefghijklmnopqrstuvwxyz| alphalength (length upcase) digits "0123456789" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test string-upcase-test (AND (string= upcase (string-upcase lowcase)) (string= upcase (string-upcase upcase)) ;; Numeric characters, punctuation marks and non-string characters have no upper case. (string= digits (string-upcase digits)) (string= punc (string-upcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (string-upcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6) ) ; string= ;; Results should be the same length regardless of keywords. (string-equal upcase (string-upcase lowcase :end 20 :start 10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1880be5d1649881ae83c760eefe8e92053b6a6dc GIT binary patch literal 2646 zcmb_eO>7%Q6rQz{5dS1~egv(Xq(dMGIbEwx+A27ubi3IkZk*j@cij*q1g^7*P5q~} z4T(xiRRmmCp=m_415`pn;=+aYR%jJa)dL3*7Y-bdK&s#bDiRWxO69#>JB0MWZ?u~? z@0<5O?~QkjG(RmSsaPtMb9uw0rCPOItJ1}iNh_tAnK9@h;Pi~BsM6UYM*5c{IlI-Zh6J)y|d!fsnJ|Fg)QC;g2nV zQ59I={-L;2haRU6pxFjR>D$a*hh^u52fDcIwddM5m3Cn7tR>%6+HVrFmVHBMpYm`Z zy7tkYx!q_0_FD-F60(`ggg38n&u`0wGa8w+B0ASI*OzYw1@}S7-%Lop&rK;D2D^XT z{X?#MG_uYAcIUSm&V7jD`@h=vNDcdK4f}N;;O44R8_4T4@qRx0AM*oiC&FNM zGaDkFHv28BCn75HSOWWxpA_V=q@?o46M)DQTEydHK2IyWE$}u&lXpZ!K^G@^Rnk)` zG^yxxd5bo$>C&{v0}|ct7>G$pkW(}KxS~#L5ypAA`?Yl?!UEm^^Ler9+ar>yDk`s} z^qG_%@%lj_7!l-o-oep`w;iyyqynKi{l7I~I2+zwu<29A#@s#DXlQAY$L3Q&$GruNcO~eZhK>yw7$cd5`Tua*>6R?t-f}$GxDc!aPDZ9WC;yqeZSbTI6*MNmL|N zl%9oUP@A7Vt|WP=Qc6nV-f<-*kIh8c!@aD3ADHnB0@^&IDibnt&B!@N1{`-6F1QvM ztBOVDeqsYiz6EqwLWZsrlDw3ZrlH7)zs4R#^0F&caLIrR_PCtiA>>!~7)X*|z*)ep zA1_V{Dq=r_@nGF3ug}k5fyfOwvS3|sLRC^TtP|l69NXlwYjo8mud?3LU>A#(lAUay zVO?{W)@(}AC7pH60@I{P`fP%A9bu6{*8Mme9AMr3Y=4+_gp%LAS*3+E!#o z%+;(xD=URlr959u7Ytfj#55cL{n;#v#IVv0;uZBhKy1zB`3 z<)qIJY)kHlZN+vZm#bEc{33H)4J?;%> zaVG?K>Ay%I$a-7YUN7r)VygQ{CS(rAuzTD@JOuh{F} z)!|isHMneB5Iy;RXqcX;%ENOvyBkW(xVE z=;5gIq2X36ih!$*7POUOHN6~fwDYoSXzPE&Ppz1#=1N66W>hj}u8iwAEu>Ey+eQKU z2}YqY4@H_Tm(3D;&Z QT-x3A=Q@(NXYbwn9pb|8A^-pY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING.TEST new file mode 100644 index 00000000..98281d43 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string ;; ;; Source: CLtL p. ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string.test ;; ;; ;; Syntax: string x ;; ;; Function Description: makes a string of x if x is an appropriate object; signals an error otherwise. ;; ;; Argument(s): x - a string, a symbol or a character ;; ;; Returns: - if x is a string: x ;; - if x is a symbol: the printname of x ;; - if x is a character: a 1-character string consisting of the character ;; (do-test-group string-group :before (test-setq longstring "23 July 86 ;; ;; Filed As: {eris}cml>test>18-3-string.test ;; ;; ;; Syntax: string x ;; ;; Function Description: makes a string of x if x is an appropriate object; signals an error otherwise. ;; " ; END LONGSTRING DEFINITION oddstring (coerce '(#\3 #\- #\page) 'string) ) ; test-setq ;; (do-test "string returns itself if its argument is a string" (every #'(lambda (string) (and (string= string (string string)) (eq string (string string)) ) ) ;; NOTE: not working 14 12; eq doesn't hold. See AR 7066. (list longstring oddstring (make-array 5 :element-type 'string-char :initial-element #\1) (make-string 30) ) ) ) ;; (do-test "string returns the symbol-name of a symbol" (every #'(lambda (string) (string= (symbol-name string) (string string) ) ) '(sym \1 |This is a symbol.| nil) ) ) ;; (do-test "string returns a string if x is a character" (and (string= "1" (string #\1 #\2)) (string= (string #\page) (make-string 1 :initial-element #\page)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST b/internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST new file mode 100644 index 0000000000000000000000000000000000000000..3b46f054d5db7939971d9634cc4f210de0f3f494 GIT binary patch literal 7726 zcmcIp*=`%j6;%d#p@4isfD65_X{#BLmPQsmupuv+aiG|SrNIOU^3ZG+sUA1Gm|kR2 zgZYm9OTI4W-dehvlr2pLA-puZ?t1R2TMM5(qqC++>r5APsp+MnOI6isHldlCS9RH> z_3pE0_(K=EDN{9}S9-aG@Of6PsJ>Eko)n8FSty#W>HB6)7qwEkVh#7XP{#h~WP(vP z*_5iUh ze4fDckE@vs(&?(qaysF0ie6p(G!Q53=!dMTb&1gFbT)&NQY{ce#fCY$3Rsm5?{a{g>QX&Vm-%xx^L%s?`@#(QjScf+UDV0V zgd#smMY2?JQp{q#;__DXkC{$m)HEv=|D<24T-UHwrDZ1Lzdn{^I2X@|*X=L@yS&OO znme|@QC0xu1gRp%8Cy1`C4iMsyOxHQ*! zu0JEb2^4$1UXV@1>5xe!9=V4x4Tn-m2={tzen!35+e|VZeQ{*$Mqp7)N@-8aMZ>g- zssRu%BJU8%gq976F;&RFS}&(Me?}R9PxTU@@We0y&mmB#&n+g_NH0Z6z!@aV%w=S< zqNE!M7Gs0~=|n!1F?ABjVRd-T)$_+wx$p%jMAOyaod>1sP#ePFPFo zI!Ui!29@z~%j5!{l6=Daaqw_dHfSz!5Tuc~*x*(CGk|*o542T`p9$`5yd0%VtQU!> z0Ej%2Ca>eH$e8O=XH!tnV4y_t zb=~P=s1Tszc6H3{NTwS1W{|bw>BAN-xi7v-Dn)N8s-y?D?IY&)0anYj=4S#6QcOpb zLg*Sxec>db)b?gJ>RGvuev66AQB$f{Yu_8t+vP19psF3iJA{V(a-|E7l>^_1m4js# z*>c)AgFt7z4lJepWb>e%u$IS{jiyP#bF^BiG@EB?w!6FO>aA;RfV%A!Inpi4l zagkjsbau_={8YmPOW2WdnKN{$C$zN8P!vCvM&9W4W%RZ*RsO+;z zEHgzNyI#95&2(Qn%FNKD%bg+eie_3W8ZS!StSH*^VVTz`MYG!5?MeCT43}gX3V3CV{Wf0Zjsb2OJuIAmiN~9kPu7dUCR5{s~1)Qt@rF9dF5CN%rxv zd7tj+pc}&os%kCS zO_ROSCHRo*q-J~gL?I$ylM6s{*5=tw(JWg-9=5v$I2pPtzpdEF#3lhwc;gl8B41NI z5Tp$XE?x9&1Gal%b-S<+Pu%Mu-|=`nJn;iTf=7-UAs0|PXX8tmAU=ymuboJ=cW1{$ zZwC6@^dc_J%5Z5!eIa#^T}8qHHzJlJwLQhGifCZiXa(gLE8_u;ghM?xVPpa*oXn<3 z0E!biI`ok^GrsUn2J@yHjv(eni!9$5-i-Fi1EPh@ebGYX-e@87m1r?~f3$}j?Pe^S z;IhzG)?MHrvh6JBMuOj+LM^=EFdF9k3v{>>Jm03ok%)lL9VTxqrvZuG^ov)%6U8=R z!|%vT1l9KMMgyjCw>#O1(JBU*{x-#c#vR3=gWciGSLeYxQiqOog*|Srf|kqO3svz# zUjPGyGCiN?YaYmNxwxaF8lG*!{t)yw>g~53;U0>M&W#I8a=ZFO3MXT|#<4n@cr9$~ z3LMVMcmQVexrbFU>;0oy@rqVMf*I zGoe^joQ0BXsVjIWlUEv}GskYaLhKZ?!R?P|FW886;E~QJjlG2@X>ckcRV=XCq^X{* zO^N1H-4wGG65{O)3z_$=VkDY^soV9@w8`?Bksf@-W*{aZ$^MCRGA7$$n%KblPt$cy z6ONDiNbg#eSaW?RXT8{pIy*p_l^zl{E(x+laev&Q9Q)oxop-#OfSZLhfQ>H^J_#3D zoMz1`m;G@p1K{IUEd(BHW@{~5C9|n8W;{NlZv%inXESBd@z7eg8}6_Vw`K!0MKpxd zL`Hpa(xPtUq$UiylM?Sznjq_Hg$`O_b7-caq|Qsq9qIBpF!KB}TUxJe!t4U?j~Mr3 zuXSDld#{1>d0gY=3)cs#>{ih%!;KH00!*%gAxpUp9Y34Be=l+da8!c8#zeFyp8Mij zsj|Y6W3v&3#}ixz)}<~$bcFBDUPe!XoTiV zJXM%b+CwpgX9&mLOJnfC^$uZnOa-pJwcrUj1652Jr_gy^zOlH*`$2Es_asD!*rWW=55 zHjZAw0@`WM-Lvm~P!m(IZrK|c4t;vEX#Ux|ORnr-s z-0&_D$4eUXf48`@J_zb!#bPWw5(%o(*;Kmmbvq6_4pM9oO#Ja}JI)RSayN#pnY9ha z!Aiyr?_PkWS)oxjb6CTTvRxT^kp`s_Trg4pg*#@-P38bsC>X)bG2gSAr?Cl0a1w+5 z_-4#cT4RqLpUpcl)4w7AZA>k#!67HwEurx4{|W#u++?nF0|{pA??T{7fWZ5+vx_&E@yoaG-hUXA z0|c}&H_Q0JaO1bQpoN}(q~mXo4mM>lL$|i3bFCeY_G+H&ITYKY3d=?{28XD6BE80( zldvuc2&_AS3|}0|T8cfK)-m2xe7}IV`1Nh~;`03moZEMIclh(ioo{wt?2Mwio~|RNwjYzuC$+JN)p6 H+yDF*bRR_J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/20-1-APPLYHOOK.DFASL b/internal/test/LANGUAGE/AUTO/20-1-APPLYHOOK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9da2986b786cc0c20a9b64e15b65283dd1805f32 GIT binary patch literal 2082 zcmbtV&2Jk;6rbI766eEi97i}c&@7>$(zfe1X)BdfrCo2wiIerNySq+__>xIBby_EO zW4ln5T2*`CvQnFdMmwO2E60{wp(qD9aHzxu!I?h*sS+HK!h5^169N)QSh8o{@4fe% zH}7M-MmpY9HBqfBSC`7ps#s~%tBtz2SXmWomB#A4BQ63i-cSvb-keg@nbhgA9&49o ze$^?~odwZuIJJf1^&{fg>!MO!T`I%o)F}|hCQgn|oH&u{$tacGsgar8NMJk_)H zaD(fw5JKk3CNABip9sXe@AgYJwQM<))u^m1IVyQ;o*Ra%$OVgy@fpcCI;P zyv=fraD;gG+;FC#t9I7Vy>;#u*XP}JBUxR}!_AaQO8D?L3$k;b8y!C;kI70tugy&v z#teD55xGqW_d%?m$8f$bJ)Pm6tdKk3%e;$jhA#|3d|C3x5nYmTDXL2o_O1s~kM?5zu3 zJODg=5E%5S<{ns5pm2p~aKOxUr*-Y3|jT$&BQuZn7c9TY-H(bJ+} zhuIM{PPIJP(Y?lG3v?WwOrAp&9Pd+*pS{ljhXW3%CRJ=I@97yWYg1FvEY|B&2WkA? za|fh$RwUW^aH&>5i`3t-Lm&B!?98_PWzUT}*NWwK{^XidZ&VjOH#L!_(9AS=nf-qo z%x{p>Rx+E`c6w7|8=(vE48%ARx3Byd<2VZ+n`~M5=^Q?c=adp?;fYB1bolF6ZM{-T zqD5PtMrj&M;Vt1D!5>w~r|0q+ z-E%{VIcWh^_iIKT-zG)#T!HGdT{-ME7~=x9WNg$amY84(2}Y&s?c6LPhtRFvj3XfJ z+cQ5yEWr=6B*&7%S;%U0v^jguo-LLe&V<;!(X^U3k9uw*fR)utjb&%0UTdlLwLLP8 lmHGNoWo1GXn-)o8`R}@2R-UR^MPu>MU+YIceQRrr{0WF1SWN%` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.DFASL b/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2991f22d6b73f291a74dd5a485cadc8745759076 GIT binary patch literal 1125 zcmah|T~8B16rF7gE#C#rN({jb#uzs)v4Bz0M22MwTb5beofV0Ru_?tiskF9>(HMmg zqA{*$A>xdN7oUAFCO+U7CMG`l5BwAUgE~_v5;ZZK-M#0|+%xx{d#4QQF6pMC=dTyC zxpYy<&wGV=PnpdZl~R7bm`W?N+^^ixEgRh(gZg;y*;u2qXC+lkC%yEHLgv$@ndI%` zO6-gR3&m`X8>dfm7#lpq8PY>8h308tPG zbk&cl1UW>D8z#~)oIolqQ$NCM(Od`F)Nk)oynI2+rEjKlqMYj`AOS$1`jNPcbz)eU zu1SkhGkxN>7+9O+rNL1I0+AgS!7fq1weN%$({u|v1Y$A?HrB&SJdf`pnfI9w32Ac< zeEXOPOtl_tm+CS+zqdEC;+x$`_wALbsK9OwCu+v|nlVr_j@69rnz8R%wdUtLcro*@ z=L6r=u@r8VGMk?24E|j+F#B@vr!PJ zqtE;dP^Q@|D0nH8gEV1jH6 z%_ia8q<&i}KUeaSb6!F7(j_k@-0!G=h;X3v+=D&JY?5EM86`WneN%+*-jM=b3y9+` zxE4XYj9}cdcE?=|>eUC!=NAE39^!mcOCS)wh3O+e9|F1-;(0V96HN$7$n+%I=4y1Y zV~k=nq76?IB=Joxa3taKDIYe`B3enFqkg?ZY~KF<<%NYxusS d5+rWM&d^i^H4R=cG#%E&x3MmE0KCvDm0v{jOqu`y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST b/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST new file mode 100644 index 00000000..00325f1c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: constantp ;; ;; Source: Guy L Steele's CLTL ;; Section: 20.1 THE EVALUATOR (Run-Time Evaluation of Forms) ;; Page: 324 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 11, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>20-1-constantp.test ;; ;; ;; Syntax: (constantp object) ;; ;; Function Description: If the predicate constantp is true of an object, then ;; that object, when considered as a form to be evaluated, always evaluates to ;; the same thing; it is a constant. This includes self-evaluating objects ;; such as numbers, characters, strings, bit-vectors, and keywords, as well as ;; all constant symbols declared by defconstant, such as nil t and pi. ;; In addition, a list whose car is quote, such as (quote foo), is considered ;; to be constant. ;; ;; Argument(s): object ;; ;; Returns: T or NIL ;; ;; Constraints/Limitations: (do-test "constantp-test1" (and (constantp NIL) (constantp T) (constantp pi) (constantp *evalhook*) (constantp most-positive-double-float) (constantp "STRING") (constantp #\a) (constantp #*) (constantp 132984) (constantp #C(1.0 2.0)) (constantp :INTERNAL) (constantp (car '((quote foo) (quote bar)))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL b/internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..da2e3e879d82d97f25a17090c121957054011437 GIT binary patch literal 1910 zcmb_d?@JqJ9DnXk>yJd2WLaxdr#I2PICo~T3fe)(c{yuryi4ycP2FIU#<&Dxb%_dP zv`AaFGBRp(v-foC3Vl=Pn>iU2?J$&4)))Q(8w>`6L0|Uu-nj4gp4ho=&^JSq&-cgY z`+Yv&=bqFu%AU&de3X(%fP(lNDzmE`F>UrgmveQBU{1 z6KS>%WHQBUdLcV4+KbuJbo%03Vq{oU=8O3P7(+wgMotX&pBNbEYaUgsIP3P(n&Vj0 z-{04~cYB@l%@IN}q>9i)h>r-wSuOh{TeEC=G#1xnU764%r{a_wVHP=QX{J;5_lpa2 z^Kv1(lr7*mvn9e2;;fV#N0Yj0#|+(B{| zk+ri*oZMdbULk}Jp^oj`!*Oow0=f6YIG<_@`MLTJ3Bg1z6atOlJlpK42}ZzA3n9B- zABgQO=azF1ff~5daG1+&?dVumIsLi*BO#UCC;B+gK}}`jNXlIkOB)IC5>m})+THD_ z$>3J@Wi%iu({cAZQb~1ykV4ZQ*jJ%3IGEerEY&2q8m9{_8L?UjX1c22XSz4f0I+|U zB(#&8@>O$F0r&)~`pQ+qx6!S0&DF^K4=EQxQRO?*9k>fi|bB~`K2G1=7YqzOk*bYVTA{!zDf*=B#x03*!YdFHMh)Zn z<-lVt_#n!iqkh4U#v~X4G~T0rxHrdNyf@wkLTDY{mJpu*R#^Jbs9{bhHo6|D^s7nJ z)bsK%nMGr z)6SL_#IDOqmpGG#ABJf$e}TQzF?P8JXxvB6SI!y_3v{Tarr4VN!U>4SY|T{S7WE(v zw)jlaur)U1d8gdMB)~fT*zE%<1CU3+rC~P6Hml|3@nE;e zB9*mkC!hYbb<$ZAXb)>5sD^dz-DUV?aJ2|lOn2Qu^kI)wxDxW|bS3iVS-!WOSX cgog1eN+D3Q6*>}P&KGWi`==&yE3vot7kWP}4*&oF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST b/internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST new file mode 100644 index 00000000..9b2f8068 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: eval ;; ;; Source: Guy L Steele's CLTL ;; Section: 20.1 THE EVALUATOR (Run-Time Evaluation of Forms) ;; Page: 321 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 11, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>20-1-eval.test ;; ;; ;; Syntax: (eval form) ;; ;; Function Description: The form is evaluated in the current dynamic environment ;; and a null lexical environment. Whatever results from the evaluation is ;; returned from the call to eval. When a call to eval is made, two levels of ;; of evaluation occur on the argument. First the argument form is evaluated, ;; as for arguments to any function, by the usual argument evaluation mechamism ;; (which involves an implicit use of eval). Then the argument is passed to ;; the eval function, where another evaluation occurs. ;; ;; Argument(s): form ;; ;; Returns: result of evaluation of form ;; ;; Constraints/Limitations: (do-test "eval-test1" (and (eq (eval (list 'cdr (car '((quote (a . b)) c)))) 'b) (equal (eval '(append '(a b) '(c d))) (append '(a b) '(c d))) (= (eval '(* (cos 1.0) (sin 1.0))) (* (cos 1.0) (sin 1.0))) ) ) (do-test "eval-test2" (and (setq foo '(1- 10)) (= (eval foo) 9) (equal (eval 'foo) '(1- 10)) (eq (eval (quote (quote foo))) (quote foo)) (setq x 10 y 20 z 'last-element) (equal (mapcar #'eval (list 'x 'y 'z)) (list x y z)) ) ) (do-test "eval-top-level-variables" (and (boundp '+) (boundp '++) (boundp '+++) (boundp '*) (boundp '**) (boundp '***) (boundp '/) (boundp '//) (boundp '///) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST b/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST new file mode 100644 index 00000000..2dbbd02b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST @@ -0,0 +1,846 @@ +;; This is a listing of the 21-Streams.NoteFile. It tests all of the functions in chapter 21 of Common Lisp the Language by Guy Steele. The individual test files for each of the functions have been appended together in this big file to share routines for testing a stream and to gain diagnostic information by testing the functions in a particular order. +;; +;; The source for this text file is the NoteCards database at {eris}cml>test>21-Streams.NoteFile. Changes are NOT made directly to the listing: +;;Filed As: {eris}cml>test>21-streams.test +;; +(do-test "setup stream source and sink names" +;; Note: implementation dependent file names below. For +;; portability the stream names at minimum use the file +;; name "TEST". Thus they are a function of the current +;; connected directory at the time the test is run!!! +(test-setq stream-io-names +(nconc (list "TEST") +(cond +((string-equal (lisp-implementation-type) "Xerox") +(when nil +(list "{core}test" "{dsk}test") +; ignored for testing test +) +(when nil +(list "{erinyes}test" " {pele:}test" +"{10.0.0.56}" +; SUMEX requires loading TCP and +; having an account on SUMEX +*terminal-io* *debug-io* +*query-io* +; testing these means hand typing +; appropriate response +"{VAXC}/user/xais/test/test")))))) +;; the following may be useful in some tests if set up correctly +(test-setq stream-source-names +(append stream-io-names (when nil (list *standard-input* "string")))) +(test-setq stream-sink-names +(append stream-io-names +(when nil (list *standard-output* *error-output* "string"))))) +(do-test "defun setup-input-streams" +(test-defun setup-input-streams (stream-names) +(mapcar +#'(lambda (stream-name) +(if (string-equal stream-name "string") +(make-string-input-stream test-string) +(let ((astream (open stream-name :direction :output +:if-does-not-exist :create :if-exists +:supersede))) +;; put something in the sources +(output-test astream) +;; open them for input +(open stream-name)))) stream-names))) +(do-test "define error logger" +(defun print-stream-error (fun-name &optional (stream-name "")) +(print (concatenate 'string fun-name " failed" +(unless (string-equal stream-name "") +(concatenate 'string " on " stream-name))) +*error-output*))) +;; Functions To Be Tested: streamp input-stream-p +;; output-stream-p and stream-element-type +;; +;; Source: CLtL p. 329-332 +;; +;; Chapter 21: Streams Section 21-2&3: Creating New +;; Streams and Operations on Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-streams.def +;; +;; Function To Be Tested: streamp +;; +;; Source: CLtL p. 332 +;; Chapter 21: Streams Section 21-3: Operations on +;; Streams +;; +;; Syntax: streamp object +;; +;; Function Description: streamp is true if its argument is a +;; stream, and otherwise is false. (streamp x) = (typep x +;; `stream) +;; +;; Argument(s): object +;; +;; Returns: true or false +;; +;; Function To Be Tested: input-stream-p +;; +;; Syntax: input-stream-p stream +;; +;; Function Description: This predicate is true if its +;; argument (which must be a stream) can handle input +;; operations, and otherwise is false. +;; +;; Argument(s): stream +;; +;; Returns: true or false +;; +;; Function To Be Tested: stream-element-type +;; +;; Syntax: stream-element-type stream +;; +;; Function Description: A type specifier is returned to +;; indicate what objects may be read from or written to the +;; argument stream, which must be a stream. streams +;; created by open will have an element type restricted to a +;; subset of character or integer, but in principle a stream +;; may conduct transactions using any LISP objects. +;; +;; Argument(s): stream +;; +;; Returns: type specifier +;; +;; Function To Be Tested: output-stream-p +;; +;; Syntax: output-stream-p stream +;; +;; Function Description: This predicate is true if its +;; argument (which must be a stream) can handle output +;; operations, and otherwise is false. +;; +;; Argument(s): stream +;; +;; Returns: true or false +;; +(do-test "stream predicates" +(defun input-test (astream &key keep-open dont-test-for-eof) +(and (streamp astream) +(input-stream-p astream) +(or (subtypep (stream-element-type astream) 'integer) +(subtypep (stream-element-type astream) 'character)) +(equal (read astream) 'hello) +(or dont-test-for-eof (read astream nil t)) +(or keep-open (close astream)))) +(defun mult-input-test (streamlist options) +(if options +(if (atom streamlist) t +(and (input-test (car streamlist)) +(mult-input-test (cdr streamlist) nil))) +(if (atom streamlist) t +(and (input-test (car streamlist) :keep-open :dont-test-for-eof) +(mult-input-test (cdr streamlist) t))))) +(defun output-test (astream &key keep-open) +(and (streamp astream) +(output-stream-p astream) +(or (subtypep (stream-element-type astream) 'integer) +(subtypep (stream-element-type astream) 'character)) +(print 'hello astream) +(or keep-open (close astream)))) +(test-setq test-string "hello")) +;; Function To Be Tested: make-string-input-stream +;; +;; Source: CLtL p. 330 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-string-input-stream.test +;; +;; +;; Syntax: make-string-input-stream string &optional start end +;; +;; Function Description: This returns an input stream. The input stream will supply, in order, the characters in the substring of string delimited by start and end; after the last character has been supplied, the stream will then be at end-of-file. +;; +;; Argument(s): string, start -- integer, end -- integer +;; +;; Returns: output stream +;; +(do-test-group "make-string-input-stream" +(do-test make-string-input-stream-simple-test +(and (test-setq astream (make-string-input-stream test-string)) +(input-test astream))) +(do-test make-string-input-stream-bounded-test +(and (test-setq astream (make-string-input-stream test-string 0 5)) +(input-test astream))) +(do-test make-string-input-stream-bounded-test +(and (test-setq astream +(make-string-input-stream (concatenate 'string "well " +test-string " hi") +5 (+ 5 (length test-string)))) +(input-test astream)))) +;; Function To Be Tested: make-string-output-stream and get-output-stream-string +;; +;; Source: CLtL p. 330 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-string-output-stream.test +;; +;; +;; Syntax: make-string-output-stream +;; +;; Function Description: This retruns an output stream that will accumulate all output given it for the benefit of the function get-output-stream-string. +;; +;; Argument(s): none +;; +;; Returns: output-stream +;; +;; +;; Syntax: get-output-stream-string string-output-stream +;; +;; Function Description: Given a stream produced by make-string-output-stream, this returns a string containing all the characters output to the stream so far. The stream is then reset; thus each call to get-output-stream-string gets only the characters since the last such call (or the creation of the stream, if no such previous call has been made). +;; +;; Argument(s): string-output-stream +;; +;; Returns: string +;; +(do-test-group +("make-string-output-stream group" :after +(progn (close astream) +(close bstream))) +(do-test "make-string-output-stream" +(and (test-setq astream (make-string-output-stream)) +(output-test astream :keep-open t) +(test-setq bstream +(make-string-input-stream (get-output-stream-string astream))) +(print "somemore" astream) +(input-test bstream) +(test-setq bstream +(make-string-input-stream (get-output-stream-string astream))) +(string-equal (read bstream) "somemore") +(close astream) +(read-char bstream nil t) +(close bstream)))) +;; Function To Be Tested: with-input-from-string [Macro] +;; +;; Source: CLtL p. 330 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>21-2-with-input-from-string.test +;; +;; +;; Syntax: with-input-from-string (var string {keyword value}*) {declaration}* {form}* +;; +;; Function Description: The body is executed as an implicit progn with the variable var bound to a character input stream that supplies successive characters from the value of the form string. with-input-from-string returns the results from the last form of the body. See CLtL p 330-331 for more info. +;; +;; Argument(s): var - variable; string -- form; +;; keyword -- :index -- form of place acceptable to setf +;; :start, :end -- form resolving to non-negative integers +;; +;; Returns: result of last form of the body +;; +(do-test-group "with-input-from-string" +(do-test with-input-from-string-simple-test +(with-input-from-string (astream test-string) +(input-test astream))) +(do-test with-input-from-string-book-test +;; from the CLtL book +(and (with-input-from-string (astream "Animal Crackers" :index j :start 6) +(read astream)) +(eql j 15))) +(do-test with-input-from-string-bounded-test +(and (with-input-from-string (astream (concatenate 'string "well " +test-string " hi") +:index j :start 5 :end 11) +(input-test astream :keep-open t)) +(eql j 11)))) +;; Function To Be Tested: with-output-to-string [Macro] +;; +;; Source: CLtL p. 331 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>21-2-with-output-to-string.test +;; +;; +;; Syntax: with-output-to-string (var [string]) {declaration}* {form}* +;; +;; Function Description: The body is executed as an implicit progn with the variable var bound to a character output strema. All output to that stream is saved in a string. See CLtL page 331 for more. +;; +;; Argument(s): var -- variable; string -- form; declarations; forms; +;; +;; Returns: if no string is specified, then string. Otherwise value of last form. +;; +(do-test-group "with-output-to-string" +(do-test with-output-to-string-simple-test +(input-test +(make-string-input-stream +(with-output-to-string (astream) +(output-test astream :keep-open t))))) +(do-test with-output-to-string-supplied-test +(let (astring) +(and (with-output-to-string (astream (setq astring +(make-array 14 +:element-type +'string-char +:fill-pointer 0))) +(print 'hello astream)) +(string-equal " +hello " astring)))) +(do-test with-output-to-string-supplied-test2 +(let (astring) +(and (with-output-to-string (astream (setq astring +(make-array 14 +:element-type +'string-char +:fill-pointer 0))) +(output-test astream :keep-open t)) +(input-test (make-string-input-stream astring)))))) +;; Function To Be Tested: with-open-stream [Macro] +;; +;; Source: CLtL p. 330 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> day month << 86 +;; +;; Syntax: with-open-stream (var stream) {declaration}* {form}* +;; +;; Function Description: The form stream is evaluated and must produce a stream. The variable var is bound with the stream as its value, and then the forms of the body are executed as an implicit progn; the results of evaluating the last form are returned as the value of the with-open-stream form. The stream is automatically closed on exit from the with-open-stream form, no matter whether the exit is normal or abnormal. The stream should be regarded as having dynamic extent. +;; +;; Argument(s): local variable, stream form, declarations, and forms +;; +;; Returns: result of last form +;; +(do-test-group +("with-open-stream" :after +(dolist (stream-name stream-source-names) +(delete-file (probe-file stream-name)))) +(do-test with-open-stream-output-test +(dolist (stream-name stream-sink-names t) +(declare (special stream-name)) +(with-open-stream +(astream (open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create)) +(or (output-test astream :keep-open t) +(print-stream-error +"WITH-OPEN-STREAM-OUTPUT-TEST" +stream-name))) +;; make sure it got closed +(or (close (open stream-name)) +(print-stream-error "WITH-OPEN-STREAM-OUTPUT-TEST" +stream-name)))) +(do-test with-open-stream-input-test +;; note this test assumes with-open-stream-output-test +;; has been run +(dolist (stream-name stream-source-names t) +(declare (special stream-name)) +(with-open-stream (astream (open stream-name)) +(or (input-test astream :keep-open t) +(print-stream-error +"WITH-OPEN-STREAM-INPUT-TEST" +stream-name))) +;; make sure it got closed +(or (close (open stream-name)) +(print-stream-error "WITH-OPEN-STREAM-INPUT-TEST" +stream-name))))) +;; Function To Be Tested: make-broadcast-stream +;; +;; Source: CLtL p. 329 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-broadcast-stream.test +;; +;; +;; Syntax: make-broadcast-stream streams +;; +;; Function Description: This returns a stream that only works in the output direction. Any output sent to this stream will be sent to all of the streams given. The set of operations that may be performed on the new stream is the intersection of those for the given streams. The results returned by a stream operation are the values resulting from performing the operation on the last stream in streams, the results of performing the operation on all preceding streams are discarded. If no streams are given as arguments, then the result is a "bit sink"; all output to the resulting stream is discarded. +;; +;; Argument(s): stream(s) +;; +;; Returns: stream +;; +(do-test-group +(make-broadcast-stream-test :before +(test-setq output-streams +(mapcar #'(lambda (stream-name) +(open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create)) +stream-sink-names)) :after +(progn (mapcar #'close output-streams) +(dolist (stream-name stream-sink-names) +(delete-file (probe-file stream-name))) +;; note each of the following tests must be done in +;; sequence +)) +(do-test make-broadcast-stream-creation-test +(test-setq astream (apply #'make-broadcast-stream output-streams))) +(do-test make-broadcast-stream-list-test +(expect-errors (error) (make-broadcast-stream '(some random list)))) +(do-test make-broadcast-stream-output-test (output-test astream)) +(do-test make-broadcast-stream-results-test (mapcar #'close output-streams) +(test-setq output-streams (mapcar #'open stream-sink-names)) +(or (mult-input-test output-streams nil) +(print-stream-error "MAKE-BROADCAST-STREAM-TEST" +(namestring astream))))) +;; Function To Be Tested: make-concatenated-stream +;; +;; Source: CLtL p. 329 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-concatenated-stream.test +;; +;; +;; Syntax: make-concatenated-stream &rest streams +;; +;; Function Description: This returns a stream that only works in the inut direction. Input is taken from the first of the streams until it reaches end-of-file; then that stream is discarded, and input is taken from the next of the streams, and so on. If no arguments are given, the result is a stream with no content; any input attempt will result in end-of-file. +;; +;; Argument(s): streams +;; +;; Returns: stream +;; +(do-test-group "make-concatenated-stream" +(do-test make-concatenated-stream-simple-test +(setq astream +(open "test" :direction :output :if-exists :new-version +:if-does-not-exist :create)) +(output-test astream) +(setq original-stream (open "test")) +(prog1 +(and (setq astream (make-concatenated-stream original-stream)) +(input-test astream)) +(close original-stream) +(close astream) +; just in case +(delete-file (probe-file "test")))) +(do-test make-concatenated-stream-string-test +(setq original-stream (make-string-input-stream test-string)) +(and (setq astream (make-concatenated-stream original-stream)) +(input-test astream))) +(do-test "MAKE-CONCATENATED-STREAM" +(setq input-streams (setup-input-streams stream-io-names)) +(prog1 +(and (setq concatenated-stream +(apply #'make-concatenated-stream input-streams)) +(dolist (astream input-streams t) +(or (input-test concatenated-stream :keep-open t +:dont-test-for-eof t) +(print-stream-error +"MAKE-CONCATENATED-STREAM" +(namestring astream)))) +(close concatenated-stream)) +(mapcar #'close input-streams) +(dolist (stream-name input-streams) +(delete-file (probe-file stream-name))))) +(do-test make-concatenated-stream-closed-test +(and (close (setq closed.file.stream +(open "emptyfile" :direction :output :if-exists +:new-version :if-does-not-exist :create))) +(delete-file (probe-file "emptyfile")) +(setq concatenated-stream +(make-concatenated-stream closed.file.stream)) +(expect-errors (error) (read-char closed.file.stream)) +(expect-errors (error) (close concatenated-stream)))) +(do-test make-concatenated-stream-empty-test +(and (setq empty-stream (make-concatenated-stream)) +(read empty-stream nil t) +(close empty-stream))) +(do-test make-concatenated-stream-string-test +(setq astream (make-string-input-stream test-string)) +(and (setq concatenated-stream (make-concatenated-stream astream)) +(input-test astream)))) +;; Function To Be Tested: make-two-way-stream +;; +;; Source: CLtL p. 329 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-two-way-stream.test +;; +;; +;; Syntax: make-two-way-stream input-stream output-stream +;; +;; Function Description: This returns a bidirectional strem that gets its input from input-stream and sends its output to output-stream. +;; +;; Argument(s): input-stream output-stream +;; +;; Returns: stream +;; +(do-test-group "make-two-way-stream" +(do-test make-two-way-stream-file-test +(dolist (stream-name stream-io-names t) +(test-setq instream +(open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create)) +(output-test instream) +(test-setq instream (open instream)) +(test-setq outstream +(open "testout" :direction :output :if-exists :new-version +:if-does-not-exist :create)) +(unless +(prog1 +(and (test-setq two-way-stream +(make-two-way-stream instream +outstream)) +(streamp two-way-stream) +(input-stream-p two-way-stream) +(output-stream-p two-way-stream) +(equal (read two-way-stream) 'hello) +(print "it works" two-way-stream) +(expect-errors (end-of-file) (read two-way-stream)) +(close two-way-stream) +;; should instream and outstream be +;; closed? if so, should test here +) +(close instream) +(close outstream) +(delete-file stream-name) +(delete-file (probe-file "testout"))) +(print-stream-error "make-two-way-stream-file-test" +stream-name)))) +(do-test make-two-way-stream-string-test +(test-setq astream (make-string-input-stream test-string)) +(test-setq bstream (make-string-output-stream)) +(and (test-setq two-way-stream +(make-two-way-stream astream bstream)) +(streamp two-way-stream) +(output-stream-p two-way-stream) +(input-test two-way-stream :keep-open t) +(prin1 'garbage two-way-stream) +(string-equal "garbage" (get-output-stream-string bstream)) +(close two-way-stream) +(close astream) +(close bstream))) +(do-test make-two-way-stream-closed-test +(test-setq astream (make-string-input-stream test-string)) +(close (test-setq closed.file.stream +(open "emptyfile" :direction :output :if-exists +:new-version :if-does-not-exist :create))) +(delete-file (probe-file "emptyfile")) +(and (test-setq two-way-stream +(make-two-way-stream astream closed.file.stream)) +(expect-errors (error) (print "any random thing" two-way-stream)) +(close two-way-stream) +(close astream))) +(do-test make-two-way-stream-backwards-test +(test-setq instream (make-string-input-stream test-string)) +(test-setq outstream (make-string-output-stream)) +(and (test-setq two-way-stream +(make-two-way-stream outstream instream)) +(expect-errors (error) (print "backwards" two-way-stream)) +(expect-errors (error) (read two-way-stream)) +(close two-way-stream) +(close instream) +(close outstream)))) +;; Function To Be Tested: make-echo-stream +;; +;; Source: CLtL p. 330 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-echo-stream.test +;; +;; +;; Syntax: make-echo-stream input-stream output-stream +;; +;; Function Description: This returns a bidirectional stream that gets its input from input-stream and sends its output to output-stream. In addition, all input taken from input-stream is echoed to output-stream. +;; +;; Argument(s): input-stream output-stream +;; +;; Returns: stream +;; +(do-test-group "make-echo-stream" +(do-test make-echo-stream-file-test +(dolist (stream-name stream-io-names t) +(test-setq instream +(open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create)) +(output-test instream) +(test-setq instream (open stream-name)) +(test-setq outstream +(open "testout" :direction :output :if-does-not-exist +:create)) +(unless (prog1 (and (test-setq echo-stream +(make-echo-stream instream +outstream)) +(output-stream-p echo-stream) +(input-test echo-stream :keep-open t +:dont-test-for-eof t) +(output-test echo-stream :keep-open t) +(read echo-stream nil t) +(close echo-stream) +(test-setq outstream (open "testout")) +(input-test outstream)) +(close echo-stream) +(close instream) +(close outstream) +(delete-file (probe-file stream-name)) +(delete-file (probe-file "testout"))) +(print-stream-error "make-ECHO-stream-file-test" +stream-name)))) +(do-test make-echo-stream-string-test +;; DEPENDS ON TEST-STRING SETUP WITH +;; STREAM PREDICATES +(test-setq astream (make-string-input-stream test-string)) +(test-setq bstream (make-string-output-stream)) +(prog1 +(and (test-setq echo-stream (make-echo-stream astream bstream)) +(streamp echo-stream) +(output-stream-p echo-stream) +(input-test echo-stream :keep-open t) +(string-equal "HELLO" (get-output-stream-string bstream)) +(close echo-stream) +(close astream) +(close bstream)) +;; just in case +(close echo-stream) +(close astream) +(close bstream))) +(do-test make-echo-stream-closed-test +(test-setq astream (make-string-input-stream test-string)) +(close (test-setq closed.file.stream +(open "emptyfile" :direction :output :if-exists +:new-version :if-does-not-exist :create))) +(delete-file (probe-file "emptyfile")) +(and (test-setq echo-stream +(make-echo-stream astream closed.file.stream)) +(expect-errors (error) (print "any random thing" echo-stream)) +(close echo-stream) +(close astream)))) +;; Function To Be Tested: make-synonym-stream +;; +;; Source: CLtL p. 329 +;; Chapter 21: Streams Section 21-2: Creating New Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> n MonthName << 86 +;; +;; Filed As: {eris}cml>test>21-2-make-synonym-stream.test +;; +;; +;; Syntax: make-synonym-stream symbol +;; +;; Function Description: Creates and returns a "synonym stream." Any operations on the new stream will be performed on the stream that is then the value of the dynamic variable named by the symbol. If the value of the variable should change or be bound, then the synonym stream will operate on the new stream. +;; +;; +;; Argument(s): symbol +;; +;; Returns: stream +;; +(do-test-group "make-synonym-stream" +(do-test make-synonym-stream-test +(dolist (stream-name stream-io-names t) +(test-setq original-stream +(open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create)) +(or (and (test-setq astream (make-synonym-stream 'original-stream)) +(output-test astream)) +(print-stream-error "MAKE-SYNONYM-STREAM-output-TEST" +stream-name)) +;; make sure the actual stream did not get closed. +(or (write "1" :stream original-stream) +(print-stream-error +"MAKE-SYNONYM-STREAM-output-close-TEST" +stream-name)) +(close original-stream) +(test-setq original-stream (open stream-name)) +(or (and (test-setq astream (make-synonym-stream 'original-stream)) +(input-test astream :dont-test-for-eof t)) +(print-stream-error "MAKE-SYNONYM-STREAM-input-TEST" +stream-name)) +;; make sure the actual stream did not get closed. +(or (string-equal "1" (ignore-errors (read original-stream))) +(print-stream-error +"MAKE-SYNONYM-STREAM-input-close-TEST" +stream-name)) +(close original-stream) +(delete-file (probe-file stream-name)))) +(do-test "MAKE-SYNONYM-STREAM with declare special" +(dolist (stream-name stream-io-names t) +(declare (special stream-name)) +(unless +(and (with-open-file +(afilestream stream-name :direction :output +:if-exists :new-version :if-does-not-exist +:create) +(declare (special afilestream)) +(and (test-setq astream +(make-synonym-stream 'afilestream)) +(output-test astream))) +(with-open-file (afilestream stream-name) +(declare (special afilestream)) +(and (test-setq astream +(make-synonym-stream 'afilestream)) +(input-test astream)))) +(print-stream-error +"MAKE-SYNONYM-STREAM with-open-file declare special TEST" +stream-name)) +(delete-file (probe-file stream-name))))) +;; Function To Be Tested: close +;; +;; Source: CLtL p. 332 +;; Chapter 21: Streams Section 21-3: Operations on Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 31 October 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>21-3-close.test +;; +;; +;; Syntax: close stream &key :abort +;; +;; Function Description: The argument must be a stream. The stream is closed. No further i/o operations may be performed on it. However, certain inquiry operations may still be performed, and it is permissible to close an already closed stream. +;; If the :abort parameter is not nil (it defaults to nil), it indicates an abnormal termination of the use of the stream. An attempt is made to clean up any side effects ofhaving created the stream in the first place. For example, if the stream performs output to a file that was newly created when the stream was created, then if possible the file is deleted and any previously existing file is not superceded. +;; +;; Argument(s): stream -- stream +;; :abort nil / t +;; +;; Returns: t always? +;; The simple case of close is tested in all the other stream tests. Here we test the abort condition. +;; +(do-test-group ("close") +(do-test "close abort delete output file" +(dolist (stream-name stream-sink-names t) +(let ((astream (open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create))) +(output-test astream :keep-open t) +(unless +(and (close astream :abort t) +;; make sure the file got deleted +(expect-errors (error) (open (pathname astream)))) +(print-stream-error "close abort delete output file" +stream-name) +(delete-file (probe-file (pathname astream))))))) +(do-test "close abort input" +(dolist (stream-name stream-io-names t) +(let ((astream (open stream-name :direction :output :if-exists +:new-version :if-does-not-exist :create))) +(output-test astream)) +(let ((astream (open stream-name))) +(unless +(and (close astream :abort t) +;; make sure the stream got closed +(close (open (pathname astream) :direction :output +:if-exists :append))) +(print-stream-error "close abort input" stream-name)) +(delete-file (probe-file (pathname astream))))))) +;; Definition To Be Tested: finish-output, force-output, and clear-output +;; +;; Source: Xerox LIsp Manual +;; Chapter 22-3-1: Input/Output Output to Character Streams +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>22-3-1-finish-output.test +;; +;; +;; Syntax: finish-output &optional output-stream +;; +;; Function Description: The function finish-output attempts to ensure that all output sent to output-stream has reached its destination, and only then returns nil. force-output initiates the emptying of any internal buffers but returns nil without waiting for completion or acknowledgment. The function clear-output, on the other hand, attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the desitnation. +;; +;; Argument(s): output-stream +;; +;; Returns: nil +;; +;; These tests just test that the functions dont break for a variety of devices. It could be improved by putting out a huge string or simulating a slow channel by advising \bufferedbout (whatever its called) and do some elapsed time tests after each type of output. Then do an input-test to see if all the characters made it (or not in the case of clear-output). Try calling finish/force-output on a stream to a file server and then killing the connection. +;; +(do-test "finish-output" +(dolist (stream-name stream-io-names t) +(with-open-file (astream stream-name :direction :output) +(output-test astream :keep-open t) +(finish-output astream) +(close astream) +(with-open-file (astream stream-name) +(unless (input-test astream) +(print-stream-error "finish-output" +stream-name))))) +;; cleanup +(dolist (stream-name stream-io-names t) +(delete-file stream-name))) +(do-test "clear-output" +(dolist (stream-name stream-io-names t) +(with-open-file (astream stream-name :direction :output) +(output-test astream :keep-open t) +(clear-output astream) +(close astream))) +;; cleanup +(dolist (stream-name stream-io-names t) +(delete-file stream-name))) +(do-test "force-output" +(dolist (stream-name stream-io-names t) +(with-open-file (astream stream-name :direction :output) +(output-test astream :keep-open t) +(force-output astream) +(close astream) +(with-open-file (astream stream-name) +(unless (input-test astream) +(print-stream-error "finish-output" +stream-name))))) +;; cleanup +(dolist (stream-name stream-io-names t) +(delete-file stream-name))) +STOP +J(Ź(\(†( (Ł(Ś(}(ľ((ú(ł(l(’(î(v(_(o(Œ((R(=(+(œ(…(K(‹(x(d(ˆ(.(N(™(ű(Î(›(“(ä(:(‰(€(0((Ă(ó(C(1(Z(?(T(H(((J(–(z(6(((´(k(W(V(7(i({(U(‚(g(S(P(<((((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8))M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8))G9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA HELVETICAJˆŰJJ›J *JJ.I8I6I7I3IHGF3E D CBE D7A@!@AA @!@A#I?I?FI?>?J%I/HG=,<'<0;&;::::&J9@8/7&6+5444+33$33<4%3333"33)33;34$33 3;4 33*33@4<4 3333(33+331339474'3333(33/33633;4=464>4>443333)34,332339484'3333(3J9=82261522,2!9,8 02#/)02A/)9,82261522!9!J3JJJ@JJJJ!JJ(JJNJJJNJJúJJ:JJ'JJ*I..@-I/.D-I/.D7,+-JQJJJ@JJJJ!JJ(JJOJJJ5JJšJJJJ'JJJIJJbJJ&JJ JJI**)I%H5G#GF?GGGF?G)GGGJ=JJJ@JJJJ!JJ&JJLJJJfJJ1JJ2J>J>JJ9JJ(I,..(I*HHK'& +I-.C%;$#-J=JJJ@JJJJ!JJ&JJKJJJXJJËJJIJJ`JJ'I+H GF!#'I-H G3"!! +! I.H G3"!! +! $4J3JJJ@JJJJ!JJ&JJMJJăJJFJJ-JJI**)I&H*GGF9*F)GG23I%H6H +H,GG/F(GG22J0JJJ@JJJJ!JJ&JJKJJJ8JJ`JJJJ JJI$H 0*<H'G(E(G2G I-.DI).EIBIL.=.)1(J3JJJ@JJJJ!JJ(JJNJJJAJJoJJJJ JJ*I.HG8HH%HG?GGC +G$I..>.?-I$H;HG2F"3FGG$E*I..%0+-'-=/-7-6I-.4--I..6.C-J.JJJ@JJJJ!JJ(JJIJJJIJJ‰JJ,JJ JJ%I'H(G0*GG%G;GF#  !%"4#!D&F4 +I).;.0.D'--!-)- -<---I).;.% 0C+.'.D2-B--I,.<.2.D*-;-.---J+JJJ@JJJJ!JJ(JJFJJJFJJÖJJ,JJ JJ"I$.(2 0C*22(2 6C 2+    % '   ' '&1I&H#HH;H0HG@&:G +GGGI&.;.% 0C+.'.D/-?--J.JJJ@JJJJ!JJ(JJIJJJ5JJ9JJJJJ JJ%I"H(G0*GD/26G0G*F(GG/GD/+25G0G@F'GG)I4H(GGF,+ $*$F:G*J JJJAJJJJ!JJ&JJ;JJJ3JJřJŸJJ"JJJ#JhJJI*H*G;+F#F35 +2IH(G;+FG F 36F2JJJJ%J=JJJJ"JJ&JJEJJJ@JJáJJJJJJĚJJI(H9#& $II(JI(9#II(JI(H9#& $I I(wĆÜzş \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..73f41b07b72575326e32a1bbbd5af5f224938480 GIT binary patch literal 3686 zcmb_fU2Gf25#Bq>)DI<^`mwAsvU(c4tnm9W- zIo1(TtQhz9Uooc`=Hyt%ofmh6K#>r#LiUif6A~aE;@&6+!nS7FawHnlWL=4CVRzdt zx4~NEq@|f|xqCu#itBPdb0w3<<*aQGfe`oEa$6*+t9I1T-RFesLZ|yoxhty630Rsk zuMx4W>IJ)inn(|RlW_M&jBAol!b zQCu1bb_?FiEY~*%f!05ed^Q+_Pw-sub{WJ71s1q0=vIc<5>dD`@+544>$;o(==^zd5CmaWA_5iI)ncu`}Tq9+q_#4zJlm?Vb)8CjPKynuaMGNjs6W!yZ2XI>U;-EHgPe@f-wMz?kE+L^gCywwH|h{KCoO z34lp&-NarnH4TzTnzYB$jVaVsk>~|YwxSn7(F5Uq;rfsYyXC<67lvSGDlz?hvY4`Wlk^GS!LGo*+6L-1p7hHFZ>n?De#dULBcLYk_aZJ0Qnai+neLkjv z8{u!vRQL-s6+U97!kb{)ZE3bVXQ;_IEJVR3LGxEY(+8S}Y%RxUjhI|J6;Sy@*olK* zB7Xwp2Ur==>bt=Ct%RmV6@bIO$q5vnM{!(HO=F+WD2Q7lvqn;%V`h(_+5S@n(GP;S zvl<%el4NV^1);YA#WM?Yhty$37v+d)#AS6sF~I@(oE}H=S2~R3Lpp-wT{?>7HrKt% z$xUu@osJagXqF!T7CnBB4v*21BXsmEn0q!M&Vht!%;S!EE<;iK?`k`_QRD;-q1`;3 zv0fe9h;`L8J%Q3LKo8W>jec(6#eXoo_!$F;f8yjdz#XdNs*g$&XorJ-!mYPBNdV}u zWy2^?%(=#?-2{7x!%lMhqnrd_y=_t5*5);n)#y|318v@X^2_t4kxa0z7CvN7gbx^6 zxXsCH=%l%se#Kf@c!`r6p!P-L%3@My1%`}7P7 z-{D+^o_>nFICK-cdSvjP{1;nIQZJd(Vnn{<@vnaHP zs>2M%C2SK;J|CU&&>2vm_W}0>_c@&ALn`QO4Q_F@bApYmSk%@`C1z0{n9)gAPLG#P z16KU~4mr#-yU8=kPh)!jS5kDQttlPxEtU>_xDibJB@cE5f>ooiP1w1oVC{59sI6Um z?CxMO7EJi}T^ixfZh7qNtOi3&<9B8D0^ro^S1a6>RW0QhY>}|*mVuC;tHt%J61)ba zozx|GS8$3_xXy)7NNcGla)rxM&XJsKM#`+NW>%cs6|iI0_@;r@QgJ;~N;$b=VPi~^ zv@5CnCcIZjn8WI3;RM)hIK>hOz{iG@Dx_1TbkzkgpmsJ(1*S!4Mk=n>uq@Y?cSPwC z6K{fe2Z7r|w?H0O{I~Gp&BRf-Oc3azK)60QqB=XlMcV(BZ72#vWM?Y&TDiS`{<`H> z9F8yxT7q=ApAP%L{Qx|oa9-Oc99%LBfQ+WZJ#?4|t?=?OJ|Uf&l%`H&2Mf>hUcrM> zc(Unt+AWVH@|n~|MoJe8BMz)TomtHlGSZfUk4lOyp4AeeQyj|1fwzJOgdkSfGyks& zI~o32nF1mCgxj$(@Fue(yA_-scml>test>22-1-5-copy-readtable.test ;; ;; Syntax: copy-readtable &optional from-readtable to-readtable ;; ;; Function Description: Make a copy of from-readtable (default: *readtable*, the current readtable). If NIL is explicitly supplied as the value of from-readtable, the function makes a copy of the standard readtable. ;; If to-readtable is nil or unsupplied, the function makes a new copy; if to-readtable is supplied, it must be a read-table; the function then copies from-readtable into it. ;; ;; Arguments: from-readtable, to-readtable: nil or readtables. ;; ;; Returns: the readtable to which the copy was made ;; ;; (do-test-group copy-readtable-group :before (progn ;; Create 3 new readtables, but don't put them into effect yet. Substitute 1 and 2, 3 and 4 and 5 and 6, respectively, for left and right parentheses. (test-setq oddtable-one-two (copy-readtable nil)) (set-syntax-from-char #\1 #\( oddtable-one-two) (set-syntax-from-char #\2 #\) oddtable-one-two) ;; (test-setq oddtable-three-four (copy-readtable nil)) (set-syntax-from-char #\3 #\( oddtable-three-four) (set-syntax-from-char #\4 #\) oddtable-three-four) ;; (test-setq oddtable-five-six (copy-readtable nil)) (set-syntax-from-char #\5 #\( oddtable-five-six) (set-syntax-from-char #\6 #\) oddtable-five-six) ;; (test-setq *readtable* (copy-readtable nil)) ;; (test-defun rttest (readtable testfun) "Copy readtable to *readtable*, making it the effective table for read operations. Evaluate testfun, restore the standard table and return the value of testfun." (copy-readtable readtable *readtable*) (let ((*standard-input* (make-string-input-stream "12 34 56"))) (prog1 (funcall testfun) (copy-readtable (copy-readtable nil) *readtable*) ) ; prog1 ) ; let ) ; test-defun ) ; prog ;; ;; For each of the new readtables, the changed digits and no other digits will be NIL, the empty list - '() - and an integer otherwise. ;; (do-test standard-readtable-test ;; With the standard readtable in effect, all are integers. (every 'integerp (list '12 '34 '56)) ) ; do-test standard-readtable-test ;; (do-test oddtable-one-two-test (rttest oddtable-one-two #'(lambda nil (and (null (read)) (= 34 (read)) (= 56 (read)) ) ) ) ) ; do-test oddtable-one-two-test ;; (do-test oddtable-three-four-test (rttest oddtable-three-four #'(lambda nil (and (= 12 (read)) (null (read)) (= 56 (read)) ) ; and ) ) ) ; do-test oddtable-three-four-test ;; (do-test oddtable-five-six-test (rttest oddtable-five-six #'(lambda nil (and (= 12 (read)) (= 34 (read)) (null (read)) ) ; and ) ) ) ; do-test oddtable-five-six-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d093244d6c09d06eff45fb1b9efe60d9d4803b3 GIT binary patch literal 3497 zcmcgvUu+yl8J}G{t{vNFJ5*76T*%6fo9LQ#a*jDYNhpTcu6=f^o1Aw{&ZH(L1@aX zM#Sz7D`;H^{gLr;IU!HVvzjF*(`HVw)RerSsD>`9DaBA!OEbvTE4|MXaBFB#L??gd zzBwQA!u%D3iYr`;rFS6WdloJp% zjNu!di@xD+OM%)Ta4OfuiM^bHY5&g^%Wr}QyPkjGQ-b?Cix9}0tC@>> z{|D=|*?_6%-Ch5726o>q18w1Vkj?P>dHB63boJd>+V=4E-I%{k4wGL$d>gsuUfX*c zW7Yi@(va0v_k8)k_8Rgv7X@SM?jR9+p)vcEjAdv_(o&`~+E!CyJBj__OMWb_>e*x( z8&FOu*hY+tTB7preoWb?k&SBXP|zbVJtjRxWSFJ0ciJ zT*)rVjE_b_e=u>!k#*asCmQCvTcVJ z6;Sp8dcK_%RWUWbEFD1cPe43iT1iNk$?O&d8sC5#wBC4KSl(!0m>__PygbDf(!YGXb2>*amM@F-{g*h~#xET%E zZv%VhsCH5_+PSCbJ`_$eL&7*SB#baa2DouLF1CzXtprtfr{-1B}SbX=+-5=};^=hwN`7n;-J+HZKDEfthJNpG`8g z3v~D^bmTPM{{$VKpbwAI1AFPg17JY>8?KTw^jUON{1cRE>RuO!d@60FWat~s$SRh$ zon9H+hS&N%I*PX5g&V9Zi`$CrvK#afaqI`iNZc$_){DOWO z>uzUMNthMwn}Q`p1o2?N{^VL<*0iP^eQGq4f!S(awh zc$bTQjwyXIuUoi}$QyJ&!cT$OiCX}PSGnRV94>S4Ied+dtXp2iG%Bt`dY zH1Rl%C1`Az#-cQK42+1s5B+_X)AXd_6=hf|+3@%&O64klw;*qYmElJLgR2~9z^dSL zxDcRk;&WVfj#IVpQU^HOl~ER^lL``RzHplMBP?=w3cw$*+;UTbuPu4t#u!@q61Q}Q zTY8$q6XAEmOL*peMul#KO>@Tql1amEQZgnT05y7q7gwg^U{LrdIF9gPfFTQi2p&cF zUGQ0i-v*Ni?*|hIzX^^ayce)}zYY>e{W3U$@WbFV!uJCc;d_CB@N%Fdgn^21IhaOx zF;Ecv0K*Y31Tw-4EL+0);8~=e4W35$a_~6>FPK882Zs;y*aUI!-Ryv)lLo8Q1=bguLEO-;V@)U8|p E1e9yQ5dZ)H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..c99ae066 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-dispatch-macro-character ;; ;; Source: CLtL p. 364 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 4 November 86 ;; ;; Last Update: 4 November 86 ;; ;; Filed As: {eris}cml>test>22-1-5-get-dispatch-macro-character.test ;; ;; Syntax: get-dispatch-macro-character disp-char sub-char &optional readtable ;; ;; Function Description: returns the function called by the sequence DISP-CHAR/SUB-CHAR under READTABLE. Returns NIL if the seqence isn't a dispatching-macro sequence in READTABLE - alway if SUB-CHAR is one of the decimal integers. ;; ;; Argument(s): disp-char, sub-char - characters ;; readtable - a readtable ; defaults to NIL (the readtable currently in effect). ;; ;; Returns: a function or NIL. ;; (do-test-group (get-dispatch-macro-character-group :before (progn (test-defun has-dispf-p (disp-char sub-char &optional readtable) "Return T iff get-dispatch-macro-character returns a function for the same arguments. If the value is a symbol, it must satisfy fboundp; otherwise, it must be non-nil and satisfy functionp." (let ((func (get-dispatch-macro-character disp-char sub-char readtable))) (cond ((symbolp func) (fboundp func)) ; if it's a symbol (func (functionp func)) ; if it's anything else but NIL (t nil) ; if it's NIL fail ) ; cond ) ; let ) ; test-defun (test-defun std-has-dispf-p (sub-char) "Call has-dispf-p with #\# as the disp-character and the standard readtable." (let ((std-table (copy-readtable nil))) (declare (special std-table)) (has-dispf-p #\# sub-char std-table) ) ; let ) ; test-defun ) ; progn ) ; get-dispatch-macro-character-group ;; ;; (do-test get-dispatch-macro-character-with-standard-readtable-test (let ((*readtable* (copy-readtable nil))) (and ;; For every defined #-macro character in table 22-4 (CLtL p. 352), see if it returns a function ;; NOTE: #\# and #\= lack standard definitions. See AR 6795. (every 'std-has-dispf-p (list #\# #\' #\( #\* #\, #\: #\= #\\ #\| #\+ #\- #\. #\A #\B #\C #\O #\R #\S #\X)) ;; Decimal digits must never be dispatch macro characters. (notany 'std-has-dispf-p (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ; and ) ; let ) ; do-test get-dispatch-macro-character-with-current-readtable-test ;; ;; ;; Try the function under an alternate readtable. Note that the alternate readtable never actually becomes *readtable*, the ruling table. (do-test get-dispatch-macro-character-with-alternate-readtable-test (let ((altreadtable (copy-readtable nil) ) ) (declare (special altreadtable)) (make-dispatch-macro-character #\$ nil altreadtable) (set-dispatch-macro-character #\$ #\% '(lambda (x y z) "This is a test.") altreadtable) (and ;; Is the function is in effect for the character pair? (has-dispf-p #\$ #\% altreadtable) ;; This should not have affected other pairs in the same readtable. (not (has-dispf-p #\$ #\+ altreadtable)) (not (has-dispf-p #\+ #\% altreadtable)) ;; Should not have affected the standard readtable. (not (std-has-dispf-p #\%)) ) ; and ) ; let ) ; do-test get-dispatch-macro-character-with-alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..49061ee0cfc3d153b4a5b317ffa61e926d3f4221 GIT binary patch literal 2494 zcmcguU1%It6uvV_x7qwGNvmylQ_^YLlCosBY}#r}#dYL=X`ad=U{56a?cr_a?im4fR2h zWH|Gkd(U^ibLXCWcb;rGrWuM>JULaE%uOrB+0xW(Ntq~4D>KE}>9L$L0eaLomnr*3ClG;>rb(>th)O3~*d8w^cMs4rq?+i(|Pmw$C56Qz@ zB5hJ&RWXQ`;JJ0Aie>3mUlsAuy;Uqr7xGJ6SMhxQwaVLEVJ?qFmbMQvUW+ zp=B!s@TYm>oE5rD$b9})D>NiaE%3UuWq2C~!*~NB&4er$#v*(nSH(&%tch*NgG3;! zs^F?z#8wE%U>H>Q*J3^+R_o!)+bf>=yjS!7pR1SMHTA(7^_a0>g|J$D#V22dPzL;S z<#t7zsO|Au%x83?M@0P3l`XAR)`FFdZC@_@yKfFV;7A0Rmh-JdZt*XA+oPIg4y3RV z)Fd?r4Bb}yQ{XWNov0jSLAe2*06ZI@+uEWUb+x2w>u%PDZqazV1)LGb)zh*JGaeBA zs2Msnvl%sE*=Z-rBw4yQ+O?vrsji6y>#+MmQQfvJTeY%oChJD)8X=%LO3e|K`;nwB z1oN7rwoV6J+HXLwd#&-mwRclJA*>#I`XOw}8xT>iAEgF@s{jJ1h`Igw9o;(L|tK+4^0Cz^JVpqU$K6!Pr5 ze;%q1q!J08@6;-tbcEAMRPgk0L*4+o?)%eOHuN{OM^xO`4wpte&P85koh8=Ufhre# zPwk@#xZ=dc$$t%$ax*2R^9=1&3a7*^e#TKIM&ZZ7cnpJ5{uO@#4}uO2TEm4^s2nf6 ziHsERQNv+PI1N6+6IsjE#j-r?dpq0;zaXuo!JKFIKnm%%avaSM<cml>test>22-1-5-get-macro-character.test ;; ;; Syntax: get-macro-character char &optional readtable ;; ;; Function Description: returns the function associated with char and the value of the character's non-terminating-p flag. Returns NIL if char is not a macro character. ;; ;; Argument(s): char - a character ;; readtable - the readtable in which char's syntax is to be examined; defaults to *readatable* (the readtable currently in effect) ;; ;; (do-test-group (get-macro-character-part-1-group :after (setq *readtable* (copy-readtable nil))) (do-test get-macro-character-test-with-ordinary-cases ;; Try with characters in the standard readtable (and (functionp (car (multiple-value-list (get-macro-character #\#)))) ;; This is a non-terminating macro. (cadr (multiple-value-list (get-macro-character #\#))) ;; (functionp (car (multiple-value-list (get-macro-character #\')))) ;; This is a terminating macro. ;; Return on nil non-terminating-p not working in 29 October sysout. See AR 6759. (null (cadr (multiple-value-list (get-macro-character #\')))) ;; Some non-macros (null (get-macro-character #\|)) (null (get-macro-character #\1)) ) ; and ) ; do-test get-macro-character-test-with-ordinary-cases ;; (do-test get-macro-character-test-with-a-different-table ;; The same characters in another readtable (let ((oddtable (copy-readtable nil))) (and (functionp (car (multiple-value-list (get-macro-character #\#)))) ;; This is a non-terminating macro. (cadr (multiple-value-list (get-macro-character #\# oddtable))) ;; (functionp (car (multiple-value-list (get-macro-character #\' oddtable)))) ;; This is a terminating macro. (null (cadr (multiple-value-list (get-macro-character #\' oddtable)))) ;; Some non-macros (null (get-macro-character #\| oddtable)) (null (get-macro-character #\1 oddtable)) ) ; and ) ; let ) ; do-test get-macro-character-test-with-a-different-table (do-test get-macro-character-test-with-non-standard-settings-in-the-current-table ;; The same characters in another readtable (let ((oddtable2 (copy-readtable nil))) (set-macro-character #\8 '(lambda (stream char) "this is a test") t oddtable2) (set-macro-character #\page '(lambda (stream char) "this is a test") nil oddtable2) (and (functionp (car (multiple-value-list (get-macro-character #\8)))) ;; This is a non-terminating macro. (cadr (multiple-value-list (get-macro-character #\8 oddtable2))) ;; (functionp (car (multiple-value-list (get-macro-character #\page oddtable2)))) ;; This is a terminating macro. (null (cadr (multiple-value-list (get-macro-character #\page)))) ;; Some non-macros (null (get-macro-character #\| oddtable2)) (null (get-macro-character #\1 oddtable2)) ) ; and ) ; let ) ; do-test get-macro-character-test-with-non-standard-settings-in-the-current-table ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..572b506fc4723e8d8bfe6450603abdcdb53c134f GIT binary patch literal 3404 zcmb_fUu;uV7(e&6bpP7fj%Mhb>;?u(<<528a7-V(yE|J;+k3lvZz%%}nWM1Lv5oyP zXd_X1Ffny7kmVkf#Q17Vbea$nv5CZ(#b{zQ8hs!!G4a8eVB(7pWPabd?FthM52kcq z&pF@U-*>+6J1mh+2h@b5PM?^Wn9R;f(+l%63-i*^=~-!RdSP}fD;DX;1VeL1SA z@s6j$_2z9SW3$=O`RozNTFA~F8GUiL6y7T-GqV$u@T0dEmf^mhuDj`~5xOgP%^ zDHG}IiS$K!JL=aiFAM%@LdX~?BB>+9Ph7-4U+{-4YFhGOEJ0;WNz#zLWEW~77CCKF z!!886r1|L?c{2M#b`rxmF-HVK>~n?M!L+7YFoOQCO*lE~`<+P*jT=W(AQ7L zuO)=5Q{?(*2{E&^B_PxsACrp5$6AZy5XM+b@fab<=Oa#R6PcEV(ofvRZ>Gh2*PV%L zAlvj>%@$$&>S2FT_rvn$Qu3_szfQ=~`0KhqAqt>(>BEOI+fWgl*AjxtCdS%}ABkby zEIBBASaz@u9SaD)2|R_LH{bh+oZ*X-4)E{h%2ere->qPKov3 zCDVF*4d@3I$yzSyt17wj63VU2R;1iq%2QqH87|dZk%9yQ;$l^)JJ9=IFoc}M5wPO8 zpNLp84IzUn1D4XCpdqorzF24tsk$~0!@82AiZ+m-hTI>69c{=Ai9S{*)-j)0178mm zZy==dIx?u0HlX-aUcDZ3#I$HqbOA@uDQ`7F6)l~T2X!N9hL|7<|CYA&5c9g~;b3#O zrtk0F6OQ!suDiG17Oq7#l;>FmyxK(^e{N zgYD8X#2btbvElA#A4{1K~($+>}*OI`jCdJuK=mx zs#fJp%!M7C_yfpe3GdT)hv|!=qvPcsAc* zJ78CM9qjkrhkermLy9r5!8|u4%&>OUb<9zDz#$Ygi^Id5gWP~c9iWm_j5sx%y-TpS zy}IckLr*)wkTb0PCAK5Sc09oz+m7*kX&2h8?A*Mx?XGtK(7ZJ+Z6DpJ^<{{LUCoYZ<6>8S-IK)q+wKArL^SMos8u+MrMh_^;p| zibQ$@Hz4Z9+Xq(wl}|5|MoR~*=JA1XZASy$Mvnd)h)PLXUUE*l z68dq`e%rnvg3_%jq!+4eL-R_+puUuZ$-Kx0X&g?&g>kO^85TknPjLYKWdNJ1hY_v- zD9GG#d<8{Uo9^NG78{D{B-(3O78EWLMCev_8Ze;Sa?w?1x!K6AU8)?HUn3mh=89`B zkp%%|VdI_ZbnRrF&8!o!7A1g1M3@nD7l2*@oZRAm2f3Bz>VA{o9KhR8I)Ia(7cmI( z!yo zi}}9AeAlv2lgfQR#$WU-Xct;0M^8L|WE5M_#;FQ#cNd?kXb7BvFBH6R5F#hOJ7cZ~ zIK&rWhWJ%InS%cw49KNUgasEMjWdK^;EiLmC7?;P@lL!NZVE{D``LjGna1+d_I RHf0&nv=$F{U7A~4`v(L9wJrbv literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..8b810733 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-dispatch-macro-character ;; ;; NOTE: the code for 22-1-5-make-dispatch-macro-character.test and 22-1-5-set-dispatch-macro-character.test are the same, because the two functions work so closely together. Only the comments and the test names are different. ;; ;; Source: CLtL p. 363 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 4 November 86 ;; ;; Last Update: 2/2/87 Jim Blum - rewrote test ;; ;; Filed As: {eris}cml>test>22-1-5-make-dispatch-macro-character.test ;; ;; Syntax: make-dispatch-macro-character char &optional non-terminating-p readtable ;; ;; Function Description: Makes char a dispatching macro character in readtable. If non-terminating-p is non-nil, this will be a non-terminating macro character. ;; ;; Argument(s): char - a character ;; readtable - a readtable ; defaults to NIL (the readtable currently in effect). ;; ;; Returns: T ;; (do-test-group (make-dispatch-macro-character-group :before (progn (setq 3nov862036 0 3nov862040 0 4nov861358readtable (copy-readtable nil)) ; These have to be setq'd anyway. (DEFUN setmarker (x y z) (incf 3nov862036)) (make-dispatch-macro-character #\{ T 4nov861358readtable) (set-dispatch-macro-character #\{ #\E '(lambda (stream char arg) (incf 3nov862040) ) 4nov861358readtable) (set-dispatch-macro-character #\{ #\K '(lambda (x y z) T) 4nov861358readtable) ) ) ; make-dispatch-macro-character-group ;; ;; (do-test make-dispatch-macro-character-with-standard-readtable-test (let ((*readtable* (copy-readtable nil))) (and ;; Test whether the functions return T. (eq t (make-dispatch-macro-character #\$)) (eq t (set-dispatch-macro-character #\$ #\q 'setmarker)) ;; The read under the standard table should stop at the to . ;; Since non-terminating-p defaults to nil, the read should terminate at the macro char and not increment the counter. (with-open-stream (s (make-string-input-stream "tok$qen ") ) (and (eq 'tok (read s)) (= 3nov862036 0) (eql 1 (read s)) (= 3nov862036 1) (eq 'en (read s)) ) ) (equal 'Qq (with-open-stream (s (make-string-input-stream "Qq")) (read s) ) ) ; this should have no effect (= 3nov862036 1) ) ; AND ) ; let ) ; do-test make-dispatch-macro-character-with-current-readtable-test ;; ;; ;; Try the function under an alternate readtable and non-terminating = T. (do-test make-dispatch-macro-character-with-alternate-readtable-test-and-non-terminating-p (let ((*readtable* (copy-readtable 4nov861358readtable))) (and ;; {E read in under the alternate table ought to increment the counter. {k ought to do nothing. ;; Since non-terminating-p all occurrences should invoke the new syntax. (with-open-stream (s (make-string-input-stream "tok{Een ") ) (eq 'tok{een (read s)) ) (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "{k{K{K{k"))(read s)) ; this should have no effect (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "kKkKkK"))(read s)) ; nor should this (= 3nov862040 0) ;; What we do in 4nov861358readtable should have no effect on the other readtable. (with-open-stream (s (make-string-input-stream "$q$Qxx"))(read s)) (= 3nov862036 1) ) ; and ) ; let ) ; do-test make-dispatch-macro-character-with-alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e7a29899d1287f4ae50c82c20d86bac7d0c2943a GIT binary patch literal 1902 zcma)7O>7%Q6rObwH$S#(2diqWP&SdGSX(xd(?m)F2sZ0+?0UVs-Jd2ofg5kIB`1y? zrxHbkwo<5&Rtio;v;$N^>K&CH5QU-~5LfOTIUpf%;lz>f-mc?B0RgMkzIkuvee=Da znQfE4Wm)0n#`88@Xk#R9zQzd z;tfK`Dmg+iKuDbQ5O3d&3l=pkF;`His7fU&cx}(^hgd}0q=x4vrubH4Q>;68oH~ZH zzC}1fypP=eoUO`MK~ud0?j9HM_S|Se6?F(rTBIb@-$6li4q>Lmj5s42RLWY?f3{v9zsgrR-YHSXB*_t?~0+NOQ{4Ge%t5yG#AJ>V@FzSUyJPq>SyQ!!zdv~ zPsU&XFPf^URG>hJForjEBlV4YItyAyL01^U!lxsFPw@R0&nnEVCXZ^*Vde0H3omfh zXFe}be{U;$TI_p5+SP|ztQg_|zWwCN(&Y}(enKL!VQn>a^d)(CCSq>)B;tO6SsHga)91LqfMa0u=CLcSMji zHCwP(qL;OU^@WE!%(=ko_JCn=7V8OQ8^~NCr(N zD^yZ#UCe1l$rKnD;{NV!X#$J%L}6k;%Lc8I>9!;`Q_m2K_F%ik1Zo(XA!@dz+m_HX z2tE-(QddOZjvMsE*nsE8Gv``3+D8cM#l9WJ4tyWLdg(1mL8S>w7zs)istsf)+lE2a zGlzt6IQJIJB~KG1OC}ArW)Ym81EfBBiyAAaC6KYK=_{v40Ll@V zPUV86_@xl_aWs`A+0eujj2FRlAs1|fY`D7!pc~qvidr3Fzu4^-UBt?;1kTuO6omp; zL|DZ<`e}WQO`vt0`5C{;22hIt$Y2+w3qgJXd%SDc#YIE2bswGl=%bS#d^qw|AU+3b z(UMfORi7_FlRbYU;v(srwr2Uc`!Fzm0LEU(+sz#|yv5RMpbq6u-EEdO*tI<4X=h#T zRhG`M^cYL0SlTab)pK96oUIl=wj+)4Yh}3FD|~GuxRueiGmi1icnAIW;kgG7>S+&- z7~J!fR{3__5zsUWT^LmR5ARd&01wMm8A7+Hc&@XQf<+BUFsde)inS`2`C7 zN`uSU|Kqf})J{0rgrn4HG}!tk9#5`P0OfUl)?KAvw^P+*G~1e!Eh}c+MXj zxcNi=!9k{OSX;P3Wy^D8bQ#*oqS>HLxez2SdRjl&u@>x@E_URs=T7K#r@ZCxmBz+I ji*Gs=XRWs3@H-N2T;}~4@PE_m=Y?GlJV(hV^!WHMcX=9N literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST new file mode 100644 index 00000000..8999ca0e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: readtablep ;; ;; Source: CLtL p. 361 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 October 86 ;; ;; Last Update: 24 March 8y - Reidy - changed the copy-readtable example. ;; ;; Filed As: {eris}cml>test>22-1-5-readtablep.test ;; ;; Syntax: readtablep object ;; ;; Function Description: Returns non-nil iff object is a readtable, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group readtablep-group :before (progn ;; See if readtablep is true or not true of object, and whether its value is equivalent to (typep object 'readtable). ;; JRB - AR 6654 is declined; it is sufficient that the Lisp truth value of whatever readtablep returns is correct, not its exact EQ value. (test-defun readtabletest (object expected-value) (let ((value (readtablep object))) (cond (expected-value value) (t (null value)) ) ) ; let ) ; test-defun (test-setq oddtable1 (copy-readtable nil)) ) ; progn ;; (do-test readtablep-test (every 'readtabletest (list *readtable* (let ((crt (copy-readtable))) crt) oddtable1 (let ((*readtable* oddtable1)) oddtable1) '*readtable* '(copy-readtable) 'oddtable1 "*readtable*" ) ; list '(t t t t nil nil nil nil) ) ; every ) ; do-test readtablep-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bf369439e2d634ad53d52247dd0edc3a024f6253 GIT binary patch literal 3400 zcmb_fZ)jUp6u<8!OaCP`=|a`ot&gpnF8XHEw6p8{;Opyc6O+7`zW1`MQ<2(bwoBJ` z{UdH+W4aH5#BSYOd3QPxzsg`%K?=@*L!^j;D2jd<2!bC(nBW&bNImDir0MF+{2*C+ za_>EVe&?Kf&beD8TMnrSNu4@AJwB10k*4P7rswCRqf;}|?9}|sXjVE3`%+%j4SG7N zsPVlA!u95clhK*%$Xxb_WX)%1kBpprObYLplj?Lsa1BBxDi z*o8o+G&eOZPh?-pPM|x-XNf?FeW6f0kk(Wyrfc>k;jG}b&lh|#O-_Mp${;0TZAlAi z7wp2$&Q3WjcgrTVl@RggNkZBV7XyA5Lj8E` zMnYJbBsV`vh?(sz0iovDs8l>Q+FBd~FGgF6FA{=$KH|7Go@r?){lsnjW?H;=-5I|D zvQ4kn+%Jr+Jnt{+epudKOrF>MHwjrBdrkKzL;>_JUVkvN0~Nt}Eg`6Ee6+pzz8J>M z5lh`EJgl^^&LJA7xJ)GA-OyZv~r|V{5F64dU@p zruEnw&}$XRS}y6UD!F_L<(6kEQf@BgsV?;tm+GlVK>{J-VpXX-qW8bV5ONa7fECC5 zM8t||2pLrAx0JpF4T%l*8&b4kneQVUyWkIR>N52nLYNy{%Y)bwZh;~dEc4>=bD-&gq!OpHX&De>Ii>+dTu>#63=gwyK!o2N@{vQX zp;xM&8kX0?gG_I*79_8;hmho1E0Tw}2>I0^KY?UxwH62>)uF zaHHfZH%b;*YnHW{tW9CkKDbUnur(l?!^u89A(#909=6>NqT&x=XG_Y^2Q^%M0g*~o zgC=KUR#a9J(5N-Vq7~m|K0x5I${O5SI8MfZ0i&5>0aX1V8sf>u)q5~IJQ`+?C-ZH# z3wDLq!2JGun>Q`6qZs|0taCfUG;2pyFFG0zIfQ~@acGEhkXx{*11m|zh*QJay8?SV zs#+d2^t9s&Img;hv0XW~>v8tTPW0w;yU=E3XXm6HXOtb%(GeK(N2KvdXFlWJ8FWuP zy+oR$t2hi+#-iAGVk^gX z=?V*Oh^HH`9^@aDPc4x~P!8QCx+=nK0i|$1C$b}x^8B`ye$Zxs+pI0y^i{PP*}uW2i`%T_HhtA?3ctbIB%jO2;gbWa!uLz0 zg$sJY@NJ$U$W1vzckwpTBh;`C0lR38rN{G>YAnG05mq@4FIU%i4;&u=j=8B^o@OT{ z#Btev%f2Ln((Njw7iw%%=Ssw&x|D>;yvPP=97@B5ac=!N7D5#VcmVz705(;31EzCZF1qS0w;H*%E0yE&Q-nvjxdP24 zvLHlR*mS2N`&_$OM>FeySc?*bMZ_>;&|MJpQozYy9CwggX|9f&{Ne<>{e%;6^5X(J zLB3nS#z9sc@*d9u8-N(IK^|PPWEb}K_EDHQ)Tt-_u%BD6`*OjbF-t9A@ALL07i7qj zP?CN93N9`dghMQVWY{5xS>Tmt7UG$Od=k#tGbIUU_+W|S!x)`aj6sm#8F$Atb%1S+ zEl|3U?_J1uE(tZM+_$6rHP3=}p=Dy^_zOoyumx=%sqk)h@sWy#01SMg;Dy8BIq}`; zb3KGZJP8BDujcml>test>22-1-5-set-dispatch-macro-character.test ;; ;; Syntax: set-dispatch-macro-character disp-char sub-char function &optional readtable ;; ;; Function Description: causes the reader to call function when it encounters the sequence disp-char/sub-char under the control of readtable. ;; ;; Argument(s): disp-char, sub-char - characters ;; function - a function ;; readtable - a readtable ; defaults to NIL (the readtable currently in effect). ;; ;; Returns: T ;; (do-test-group (set-dispatch-macro-character-group :before (progn (setq 3nov862036 0 3nov862040 0 4nov861358readtable (copy-readtable nil)) ; These have to be setq'd anyway. (DEFUN setmarker (x y z) (incf 3nov862036)) (make-dispatch-macro-character #\{ T 4nov861358readtable) (set-dispatch-macro-character #\{ #\E '(lambda (stream char arg) (incf 3nov862040) ) 4nov861358readtable) (set-dispatch-macro-character #\{ #\K '(lambda (x y z) T) 4nov861358readtable) ) ) ; set-dispatch-macro-character-group ;; ;; (do-test set-dispatch-macro-character-with-standard-readtable-test (let ((*readtable* (copy-readtable nil))) (and ;; Test whether the functions return T. (eq t (make-dispatch-macro-character #\$)) (eq t (set-dispatch-macro-character #\$ #\q 'setmarker)) ;; The read under the standard table should stop at the to . ;; Since non-terminating-p defaults to nil, the read should terminate at the macro char and not increment the counter. (with-open-stream (s (make-string-input-stream "tok$qen ") ) (and (eq 'tok (read s)) (= 3nov862036 0) (eql 1 (read s)) (= 3nov862036 1) (eq 'en (read s)) ) ) (equal 'Qq (with-open-stream (s (make-string-input-stream "Qq")) (read s) ) ) ; this should have no effect (= 3nov862036 1) ) ; AND ) ; let ) ; do-test set-dispatch-macro-character-with-current-readtable-test ;; ;; ;; Try the function under an alternate readtable and non-terminating = T. (do-test set-dispatch-macro-character-with-alternate-readtable-test-and-non-terminating-p (let ((*readtable* (copy-readtable 4nov861358readtable))) (and ;; {E read in under the alternate table ought to increment the counter. {k ought to do nothing. ;; Since non-terminating-p all occurrences should invoke the new syntax. (with-open-stream (s (make-string-input-stream "tok{Een ") ) (eq 'tok{een (read s)) ) (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "{k{K{K{k"))(read s)) ; this should have no effect (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "kKkKkK"))(read s)) ; nor should this (= 3nov862040 0) ;; What we do in 4nov861358readtable should have no effect on the other readtable. (with-open-stream (s (make-string-input-stream "$q$Qxx"))(read s)) (= 3nov862036 1) ) ; and ) ; let ) ; do-test set-dispatch-macro-character-with-alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9b3e2743870c3a3c912d8359710cf28b72152700 GIT binary patch literal 3609 zcmd5zUa&jzF-i$K5UK zU9-E6QzA^%(js7KaH2+Y3qe&MK zPiza2=mV>nJ#)@I-#O>rbMBct8&czCJx=xF@=7l6m1uFbva(vCOT`i`7gtLek1m0n zUe_(#_}Yx7&kmj+YIF9CWJ+GT;w@5l)hjQipZgRY8l&1uDVK+b(NSQB#?K9ppFKO+ zHl;anVeLO+&WxWsJAMW*TX*k}P*IYkj8sF?DoG(pk^EcLP}DUXSDlK*4b{{VM%3T% zt1U1WHRTw#Ukwk_N^wQadsn?YPG`9+5lQmDS8bU}nYtUZO#e2yK|1`K)j-TtlQ1=H z+K}Xyx)roe{Ay%)SRGQ&sgB{Q2~D>xRiDvpO?M4jx_c+|yd){#4u@on?SA&XS@Ldy z{QBp!@_Zx`CQZ-qfH!-A?p!c~Y$O6#76GS(yNAX+ZHIw;W8GyI zS9ZQ{YqRs&ha~-5ALC4wH?|$O&(kpJ$hYkCwb^wbpc~mE|J%f&9xg^;0c+WiB;$5& zkJ^Sd>1q>kBPzH1uT*=Zx@AtraL=nVnmHLaY;__A5_8&#$^jOTTj6ejy9w?_XfENX zuDSY*Y8!6KhUTF2?$YEeIIfY9Wzgsn?MIIrnwd(fQS&4 z##pCvWRGNM=rl+=S*u?S4ee`zZOxLz8nEx3!p8Lt2&cigq{We01EvY5p}ELbz+_lY z**1i*+hiHRF%QPNc9&Gw976=pI&k>YXckj|%o$)FOK7u(>bN#6xEeEI+Q=AM0u}n% zQ6!Wd10sLKB1k@DpFr|w){EpFt|I?bsQgH9uM2Kn0Imx_UI27Rdh_QJm*O!8CnH~g zAUdZHc5oaUW=|kF#VC?CVJ^VUk$-Y?Z zdMbgr#1cgHIE-|`$du|VBqpr5y8TYV!6>+UF*$Jo|>>y<|J49BdY0Easf)bzE=?ad-fEP`!L#3j{wReWuWj45H{^v zsIusFHt=~CjkAG47Cp)a#z0H?I%qW}ZEG6mseA=0wEVtM|Aipe0CmDKutHTHz8Z5>6E;7@ zk%&PgSckA@TPK$2joWfIc5vu?y-XK`c{RNJRugQZNK8H%`bdQJBY6~r4On@|1cjo)iS(f$e--36pcr__uJjJ;0+jR?8$q%uxS!Mw&Y|qb zLiQ>fMebXy70F9N{{_L_U}M)<>zCQ+71lk^MqJiC$Hro;`!j5Gfb~4dMvk+dJ~kF% zJ-jb0`_(60uUw&h>slXOO2c7vk>(2G9Eq}ZUOuP%YU2s~fkUMij&R58Kj7sp|NH)J zY}&_ks3EAseZ4ClgTm0_4(k9lHX@4QZ)_Z~_x9QP;T}iwOWZJfdJn83VB;@iSn|Nj z7?9k3P*34{7#|Y~|rJGfG2v!R^ zIf8kOJK%`?in}HE!77VkR2SJS*kB3Pjhu;uFiaJBn}`O7~ zhdZa>f7Q3#CcC5fwbMG|t;lgw5=z!j1s~7xX-4Y((tPqkEnMe)VKB@1ghq$y7oe)3>KekY)O=iU|1tp!25KPzZY!^1@&y;|Jb`WNvX@Ie3o literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..54ab5232 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set-macro-character ;; ;; Source: CLtL p. 362 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 November 86 ;; ;; Last Update: 17 January 87 ;; ;; Filed As: {eris}cml>test>22-1-5-set-macro-character.test ;; ;; Syntax: set-macro-character char function &optional non-terminating-p readtable ;; ;; Function Description: Makes char a macro character which causes function to be called when the reader encounters it. ;; ;; Argument(s): char - a character ;; non-terminating-p - if true, makes char a non-terminating macro ;; readtable - the readtable in which char's syntax is to be set; defaults to *readatable* (the readtable currently in effect) ;; (do-test-group set-macro-character-group :before (progn (test-setq percentable (copy-readtable nil) *readtable* (copy-readtable nil) 2nov862039 0 2nov862110 0 ) ; test-setq (test-defun dmactest (val var string) "See if var=val after reading string. String will contain characters whose macro-function may or may not increment var; val (which was initialized to 0) is the expected value after reading occurrences of the character." (= val (write (progn (read (make-string-input-stream string) nil) var ) ) ) ) ; test-defun ) ; progn ;; (do-test set-macro-character-returns-t-test ;; Change #\&'s syntax in the current readtable and #\%'s in a non-standard one. Note that these test-setq's are real setq's that persist after the file is run; thus the odd names, which are unlikely to step on anything. (and (eq t (set-macro-character #\& '(lambda (x y) (test-setq 2nov862039 (1+ 2nov862039)) (values)) ) ) (eq t (set-macro-character #\% '(lambda (x y) (test-setq 2nov862110 (1+ 2nov862110))(values)) T percentable ) ) ) ; and ) ; do-test set-macro-character-returns-t-test ;; (do-test second-value-is-non-terminating-p-flag ;; NOTE: Always T in 29 October sysout. See AR 6759. (and (null (cadr (multiple-value-list (get-macro-character #\&)))) (cadr (multiple-value-list (get-macro-character #\% percentable))) ) ; and ) ; do-test second-value-is-non-terminating-p-flag ;; (do-test current-readtable-test (and ;; In the current readtable, #\&'s read function bumps a marker; 5 occurrences should bump it 5 times. (= 5 (progn (read (make-string-input-stream "&&&&&") nil) 2nov862039 ) ) ;; Macro-char settings in another readtable should not be invoked in this one. (= 0 (progn (read (make-string-input-stream "%%%%%%%%") nil) 2nov862110 ) ) ) ; and ) ; do-test current-readtable-test ;; (do-test alternate-readtable-test (let ((*readtable* percentable)) (and ;; In percentable, #\%'s read function bumps a marker; 8 occurrences should bump it 8 times. (= 8 (progn (read (make-string-input-stream "%%%%%%%%") nil) 2nov862110 ) ) ;; Macro-char settings in another readtable (i.e. the default one, as altered earlier in this file) should not be invoked in this one. (= 5 (progn (read (make-string-input-stream "&&&&&") nil) 2nov862039 ) ) ;; Macro-char settings in another readtable should not be invoked in this one. ) ; and ) ; let ) ; do-test alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..861d7759f2f4348b110548ec2f9a9d1ca351fbea GIT binary patch literal 6305 zcmeHLeQX@n5#O&n`_8d*c8rra!CvR$#<{S@_SueOl90Xg+IR7J_p-Z}!zfkiTujg4 z#36A&P!n8eQz1?c2AbXrM2(92L0bfMm5M;afsk53D+~fOO`~ z-C>ecfRsP_2l9F6{pS5<-n_T(&Cc$;;JGfEP@_}(4opmrA5^CfPailut==$oP(3tt z_+VySy#e&noayWKyiI|=gku{PoUp6>phzIOlllgGutlpqKhp@70C2mwJB^7rQgA=hwR zZ7`lNG*cfjLizc8t`g>=r5wY~=W4su>8S(Sc@bg5Je^ZdF&8)~WSqj^S#~sOjq0X@j;kqD5o6Eu1{Q z?k+*7IK5vGny)X^24oEJr`fX!@yvdu@0o;@?r5wPE569%URVvX{DX;P8yn%*INbPj z4%BE05YT7z&sOIDYZDYtUZ%HjW2UcgQ>MQ#DP=YT*a~19f=D4fkg*F{*w&c=5`!dS zB({@CkT6Lk3&p*@?HADy|l@XLbh)Rsi6+`H^E*;CVrq&wkAc zBqXsKnoq1uci~K+zfusE2tr{Z(_Q$H{PyBg`(o+T`cRAi>A@U1y64}J?x zycJgGCuXzr*&Ijw0^`hP>ppQr4VQ{&Q8=ElQaDxRaAG{17-9&eR`SDSD3XPy$u6rg zJJ|({^Cyc0ig-4AIm7ZUDTP&24r@DxRYr;Qc3j|6km6DZ5+b4N`ML#_Zg{#6{`xTs zru);I)0?pcerB_mZ3Vq|mqHDs6QyvZx=E=R$_bM5*;%-im+!_^Y%UGEth^>Bu26B_ zThm+9+xWbpWnr#S4FJX+vt zxDi4wWCMbQK}&2jW-`XffR!NEo&jiG#)*azauA6bDry+t3GGJ(4g&(iO}n z)w6188OS>541^pPtaN)oi<`-m8F!qkSM zx*LsYw&A91C_$pUhVeS1j%$oaGBE0?$cZKl-ApC5LCYR-LQIszi>+NN#QgFK=95=K zU^OAbwk=z;QZ9xiH-f>EkZz7@T#ruVRiN|1#2go9I8rX3u<(&rL!YciqO4xN5}Hbw z+D)h)?_-t)lmCv_VvWq#=tb|so;!)qmu0|p7F+A_{F+A_^F+9(*4bbN~3#JOr z1;LXH>vqp+7Dn+H>p*c2Ssx|qTglpFo!GaLb)nG6E<|?g2(2a5L|z(rC>}2t%5S+( zPS>^A^nNZUiul^2nNz= z?p68*p`(PdgwljI5o#k;&5`(Tj>Iq4!~K?|py_ze3_F2wU6&-Jbt|r?r$B zie|;P=0(X?AB2#(H_soqH_z+bjpr96?gk&NALAopK#HW0Jd@-kL)I>dZgwriqr3*b zn$od2Jlo(!-=JVht47PkBT=5?PLwCPwelzl9ju#ieHSn6B5(M_B=ZoNw~$>O7xLq* zA7YU6yiYzx%2^V(vLN=2vtAS~zo+sJy#4%Xh)R=`!=O}P^lf53$Qn>NPs}+&_Y(7NLbnieoGnM@9%Ak$w2PQ7p&?@S zvK7b-6SISmM$A@1D~MUaRw7d&rpS@_0cVQu68bA=im$OoV2Z!uOz~wxFA?+Sgq|Yi zqihv2zeCJN2%REkp3uF-yq&E<=B>n>CUi3~CkX8#<}j;9W{j8yp$IYi32DS!%~m6G zB{3TaEhA&qXUnJ_Z=K2rv!s)FrSm*ipsZ+ z3%+gi`VkQFxyH${eS7wfp{on)ELa?o*I7_%<#S$o21*{*BQXv7(AgVvxGTJ`&T-ez z@rkja55x98&W4e2%W*-Ey?}2$bUn8aq=rYvZvhL-79)D8oXwue#_$y`e&)t)HHA0? zi(fBOW*XizG^= zZV39}8VUx(!LIe7^!uf~^GV9=xDxVh$^2Wt{H<#kzQ?Eqo~Xb-r8V zU(fk~EOt|9Tsm)XBS!(m7IY(`t7I#ydC%z79^V9}=5l=8rUN2Ldr>94# z-8@ZFg>8$xmgy;gkJ#%<$5Q5S*9p|! Id;a`?0e*^Y7XSbN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.TEST new file mode 100644 index 0000000000000000000000000000000000000000..a68478a322c52949bb52311ced3ed625488dc34c GIT binary patch literal 5380 zcmd5=TXWk)6n404z;uR7TkfX`v~sDO*db}^lo03Erel)QxP8itY_Ag!w&hB4ry0sS z`~~=F{1cuy-;q{bMXpqsfgw}LyWgJkovT*ruCLSHbleRG-k91RZ7FK2AXL2u1uArc zvvKG?b^5+Ha=NFkUtVA5e{|$c{jO?I{I}f-TQsTC@@g#>*gkb9q4KF-Z_xgDG7T3G zry>7X){%;A)v7BEYM&~4pxj>Qc7{r;`pRYdv~?!@_Z4^^s6p?{6o9)sEZ3kq9e7XF zsKZigtFcJS4MKW2=|uvI^~JTDbZ;=Ct>JV;4*6=tDm}7yA2nNq;K*jHJ>tmucT}O! zBY!%k!I(mJ@#x_}OuRQ3vR*TYL;p$ngW%`e!$C0VdcNA|j)of{lWf%MPR&_yW~I=1 z>iVIxRI5TTrah80&rUh}BB>WYqtR7wf_k|_tif@~UnG!BnOfHeznCV4-cdoZ!gv9fs_lN7oaT>tw_AWKP|w@3TY0 zGdQjKeeTLi#tu^)?6)G-Aaut)*Y7>&s7Q2n&vQ^o=fwA>lbH`qv{b&(=%_w-N!hX| zzIQS%|7zKy$zAf8Cl*&R>OZnaToZ>UgYk(o!1IF%cP7nSD;CMs;omK5zEb9Fxt%U8 zVX%x*4Wna>>KHv+u6f;XZMC+%RC^YQF?6`y7O3@Tx4pmJEWK5dzgJ47JEdFp&hB3G zVXM7&c+jRA*>`tiFk6qkGiffBti-y({sI^= zyi&Ty_g^r4gReg@c%82~41j2nS1~k!-_HYYYv4KtFGo^^=xeyKC;NOCGq|lqSaeUV ztiEvN<_lMr&#!y}KpVcx;}1>X4o@UjEwRUdaA;tcfwHNx!xJ)rZJuz0L?L~Qfz0^6 zrN_Bs5{#B;vdX*Q(7+~-6ZR`u(d?;}Pt6sOd;~y~0FbI_V3UEDV3k~HdmvfhD`8C) z>pQGyQLKCcK-4K~ooUty@(LAGcDsIxq}S^{;J zjsqYC$Ls=M3CXuSzF`8ld2;PMAdY}U*l=4iMb>$8^*oTOXM8dffvx+&2Q zuwsfPX2hj8u^i_nmHAr?Z(>cS0?%72S?Irn3>f?}8c3Dm8%A*@8wMt# zD@kTDJWOKR1imy?W=bIWDN-r8$&n$IuyZBmP12cWD}@rMaN<~o1K}43N9Q?Gq~J)l zSkxn91%T|mxzTQ#RzRA`={u&xOe?aB*-aPO^?zWYg4+0gxwE1OHkq z^5EoJk(XAkM5fr-c~ZfpI1n86!jwb?fK(#!55v!IeprzGF*mq+p&yx2$_IcZ{clQ% zH%RL31E-`6va9ej2d6F}77ZXUc^XVW3Z(&bF?Pz7%ID{S)GG$0S4;``k&=KP@|bEX zc->q!Rlu=e0_agGWv)syS7oLjnS98{jyyKapJGu7>3o>KJW4Olk$0|)O5>gJ7;QMfIWBjAto?v= zJ|2f(d~f`c2WFfKDrl=YWxH1jm%-6;WL+E0Uwk&QVn#syeMvuVMm{EFDSyJ6=F09(aSyf=*GuJbma5+Y$61J-vH}U zezCBa7k@2xOsGu|LMXtfGD3B=KJ@!4o#yfG7;PHwhLSArLK^+}sIfYcztC|zUW@sA z$V@t2WfqxBVue#DGpLY+9zjQ>YXv9kA) z{k1Cl2rudXI7AQp+aZGN_hKe1`6!Vh{wc2`ku;6L6n2X;q8fv`W+{78U@?a6gcO3_ zi6(3Z9I7>_q>PN~B&0A4N=>X;Y6cku*$A=${_CM>V~M2dBu5lWb6g9WF3G#L!JdHT zN=p(%w2HP)>Y8e}8D+?{(sqJTiQYQfF%v8tSkHoiC=iJxG|MtA#dIB{5s1Nra6&aE z6mCb5KnvLFhFyKAc2{7R`(Cu~A9uz2Izm_-UJzTc-LC?Eoi?WGsC)%V1M*TGRKGxC zN!PM80ld7!=HY|+p*8!Od-=&Zmi zu#FfpT_c4>kzo@0yoHU$v50bzUH{(OTeweLI4O^5w1&M zi}T`SEDc@_V^B3^d?W>150^exi@Yx)&$CUay~@`iM_KzJ7EiNHy#NrlC(?UNU4b*; zY8%1Ou*Y9eLcGGZ%(BE3>v37n69A7p>l!@O9@hFOrm)X79c?pf#WPoD zYtFtnYi&c;pZcCMpbj~jC0@7u8={gcSLCk4YL{G?6Yu`RwmdxvpA=KQIO!$-P5&hJ zeP;3K$MO(EKjK-iZEGCq`Mc(r%}ZdsZv`d;tA9t|!=?GE=p#o?Y3MQg45J0v+{ H-MH}=Z#e`g literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.TEST new file mode 100644 index 0000000000000000000000000000000000000000..ac3bbeeab66cf635ee951998ddaf174c239f3638 GIT binary patch literal 2469 zcmb7D|8E;L6wk&0-L&vsFaa8m09#Ua*&4P{E~s>E*RE5vB9e)p-8)}u&F8!Me1Qn@ zm-7qn`R;<9Ov;E_pWnxy_w3Kd&*L$iR4O(iS1`-rki(3Zh9?n7fnU`fkMR$td8K0> zLGwGBmG~8{LAk}#Wn4wurIa8xK z%gVMA26zBCT-xn^|Na@}7ICimew@jDgC6XUM&T&j4Qn5U1U0$Sr84Z#)*-l^ z7i1rkAV_#vS~-B^)-L)|xN`cKm$4Q$Edrw}4kAr~LA>%rlpwN6SX^20?VeQ#2F$mQr%_3g(qep`Wpr zoE#Er9*SFzUA;N<1_MfEDcyKKmU+o-)}Tw~&7MAilk>^s{P(lxr!admox#}@4$n_t zOyPpZtU|Uh-zL1^Dk%Z`gY=;)WA$M`Rj_m>=&qQt>qcZ8CvAj+psWO@=t`AjZO{sZ zp2>?)@&%Wzi;ZfSb2OAG;Cb4kO@g4WDk-5~_YTU!Is*W-zc%g7Yjp#Xj-4wE{2|OG z;Oj{4+A*YVxr_TIbtr}6!>)5)l`FhVRE*C|EXWJ{&e~IBiy7Ua-__2SIPTK)8Vv}% zgX0G@ZGkhK-*$ng7`#OQ4d2k@Dh)V#D<9R^e=B2}wpEFGe;s(&1x_(IaDlHd_;ek( zwGMbkrIcu$@yR;i$)%JJT?UE;2>1^FS5Do) zx#!do0^hp~O1ZNR(8aE59OL|+3xpW_vJQA!i1BgDxI&Y+X+ZJMaHK6e7Ht6QkPDEH z9^+sg*hsN=>DJg_e7&_se=CEoz&qH+E*rqZZ7ElN+Qz6`$Q5^UYYJ>-c#T5BdX&;O z8@(~>M+;Cpe&I5xS-swRAAud0K`GQdtD@9KpSi#YgGVm#IR@{!0M)Rb(qOl9Uy!%m z2{ODkq&D_65U^3*dg-e4n*FsJyca|o>?OA~{-=fm%wIY5S`Bwx#+zvvbUOb6J$z|a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..64b1c42fd5551b6b42d4809c110a97aae0d36fe1 GIT binary patch literal 4072 zcmcgvTWl0n7(O%8%XW9WY%g-DEv}^n+&B#_Eh#ldhS}M6+ufNmGux$6#HJLt?bdC2 z!2m)CYJ6}B6qW2m(U2HIqNb(tf@0PiO2mLsTO|g3F!2d555Adn{r@?$+oe>I*x1hO zf4={A{{PJE`OZ#|{Ow}UBgTh@`(u40p7{9K@c5W#cYMS%8Xq6&?epvgy=T9usM3Kp zLF}k|sNSySSb9hLddB*8dGztV(Oo@zAN163_6Wlx{V^CcHv_D1X=-R`Y^<~U1uaOk z-7#ikOVg&74IAq0>60fIcbpK?OHwF`2yqjRB#$TDUR~03-X91`yexzyZ*n4;ut6_; zSd-LbqNKqy79ZwgeS7+1*v`->VF*bcOW6EjS=0lHoP3En#5j{j6U70U?}XNbR*A4S zD+^|4l8N$$2EKu>2fM0Cd_dNvR!Jo%Pq+^gk~b6CF}Wffp1D|1_V!HG)Xb66o0Fn+ z@p|}?IYLSa*|qtK&31(ldV%7r#zwdrUv3;*b(N4C&=5dC0H}M$7b2F<{o4BPFG035 zpSK;nRt$sBwj7+?GJED)IgG#Utxok{coL>NT)2XXp5N(8DK3D&PXv!Du1^S=h`yk> zI#{L{hEuB|mG~6EZX?7=NUFbgb?PklDJtKOUg%)XKgAAw(7{G3DoPj|YVn4LHk7so zvz9~wX=3>fQ-TYifm{&d0A<|RoH6RbnTEtT%u-;_hff?@0Wd-p_++&Zg|K&KC>_gN z%yTwYc$*p&F&01aFzY!bH#G3d}6#tj7%6O*AVmdRdXnN_==dH}7cVrvGcOpG4S#9+L zIv$;BvS6lJ7M~92t1LxiEiRJz;5b~ViRhvJrCf)+KQe_naYk4LxR{(_dO9Adj?_RE zsDz?n6!G9kwe?=IOnN#nVAYFlK?c-qTtsKK1@^(2+x+Ph{?ENZW$hI(Ln`VftTXva zqS7lWvM+%9B;O{;zM!P?TLYkxTQx81FpAh>xQpPn!Ce4%K5WV*UQy7+HeQwVunL>1 zXzt1dTDPW4A(jP?a=LAcK}nFqoxERBLz>rMSmyR!OH8TD{bWHS->vrz#q+)u{6D84Z&QJki>7pWMfqK}G)&44v6 zG{8#(SkuPdFm3D)rj5O9+SrrSc7%#&sOX`hnFch`fLb$vnS+(F*GgTI+RbawLQsO5 zm|x5Y=11tS*z8YGRiPU#m#O8FaX+Fdirz8qLv)Iw*Qt#*#2mmi(z-)im7sZyK*y)4 z;~*6~sfZZWXxm0nJ4HT<==w1mC|YLMU~*m6;RIUL=E+c;bOsV$N7~tQi;ZZq5hGBa2LvJI8Ehj-tqF z)GuXnZeu2Sam2Ia$&Y1{J0jIfk{lL!o~s;ptxy!Bi zDDCiyEb)3oxs|ez%F41XdYdXqK$c+@C=A)GBx~{qx?q0~Y`3`W4t(Y;% zCc|gk5P*3;;|6e=#rceT6l{ObXIvwg3sfDs*C@q#+~!^gT#n4b&QUV>&Lki9UApg2 zQQIkM+ed9()TU9JkJ_ph<%Hi%SLUYa%3L>HnRDP;qDeaMQ^arxh*`h`4b;G#21_|u z{Jgc{W_}f-@i|zDWsB$sL7&}anI{0bv`$G32to58!*^ovHdKcMQC0ZdoB>c5`srql zZd=ezR64uiuw)%TP+bG+TQ~rfcu=u;03rTn#oD2C=x96dSCtSiwh1a2fp#81@vE^G M#n;9<6dxIX0ZkqcfB*mh literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.TEST new file mode 100644 index 0000000000000000000000000000000000000000..c9b0a42fe7cedb1f434d1603ae2f259c452ff9b7 GIT binary patch literal 4022 zcmeHKOK%%h6n0QbuxO+%FzyEFC`iQ)8CQ0iG#aB?ZAwK^XrU=9*o^IKXUKSFn7NbK zLf{lHs6Z9$SR<80ELc>E<;q3Gk~gU0PXrWIqN_@C8-${kb7sb`ywn0aYWX$yp7WjW ze)n`xixj-A=#FAlVCHmS za6#2D##uWU(kIMP?N8s(RNKrM7CVzGX=gac~pJ^w^!4^UTg!s!5Y1gPl`! z8~6eP+sOtI@=Q}pD#?}YMvCQGL2)#WwuWb(WkprjiI7nUsKr4cI>c#@IX3#;3g@h3 z`Z%5d=mfMbGR|iwo6XnVTC2KN7I*8eh>q0U9k(i?k40wX_HB2j{J0fuG^6cxcjkJ1 z#uc|B(X}7$-NSctIkU5}-WsWuxA1AB+RjAQcD9<^!vFUpwry5x_|#}_J{;NJYGzs+ zWzR@FavSyaNX^ZZMJ>{Ld5DXhmyY{Dj^R0=NVxN%6rKmD%~ zeo~r}21VE};}2TE3Bya%isn@}J^e5V_a2@&*T17IGEjhGP|~J?sfW@{*)oiG=V^Sx z%k??OvY5`H+a6B^^2*Il{4+P^^3}Xo3ccQTxYE;dNC5!vaU|1U~>>XUpE$)1dAJ>G`T0N)8r!S<;F| zEO|>d?J3cvj1+Z3Q<3;CA+eY-K;=Z27@xI@P6^esxigNg$aaG2HiEdq zxMS&5R+2JZ11iOq7u4K>KS?yL%cy%v$+KO>AK}FEhD0@{RJ07o91RaHwN9&?Wd*EN zN5e7GGKxAy_jeLZ0twg+Zcjkg;gC1<*EnEJP8>>9$Qi&21uV~@!ZMqR)=1-x}h zzF?TlQs@qa+Z5iUa}KYCojBfV=D3eM47{uPN0|>nYv1yAwAb4`A_IYESZAIQ!q6>7Wa0=->jT|DF6Tf literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b528233b28571da46f5beb40ce0cbb92173f3e54 GIT binary patch literal 4029 zcmeHJPjC}u6#sTNiAkG=gqD2BHGbVVJJ3Be7fv{PDV z9K|VIWSoq&FhW)a8M$$?oCKOsqgKVq(L(RPH&Lxm-l|( zd*A!>ec!&9W#W8EOohdn>DgR9I~Sf=n4evk4IeTr9XD7e1{? zYOxTAhv#Qz`F!@RY#!5@K1LWqic1CeXj&Hagd!KuGK-A2c)HM%koieSO&F61>#kTq z>rAoWkH`5q-_K7vQGlS*ab=afLC!g5C znAZ;Y%8C!*>T>F|;`@e>W%GT-mt>h1U{^YfDEa`on-DJ{e3d&`cTnsn)q`@| zXJB-}%GJ_TJs3k^bitvmmiAB{l**>9`=8`!-yVD2+MSn4@7WnwvK;vd^lKHDf$E zBW7=C(1?NO3pi!csg2zbM@QAI*BA&eO^|RoA2&@iABTfq+rR`JpH@BjFdH0r8>&3g z<_b3YAm^cvamt7z`w&+k*y!$}rOFL(j#k6iWDI6@myIqXW(*j8MjXpZCGq$HIePQZ*jrbStwVy`x z7?%0>YF&w1Ual1cPBk$F?V{Q{uUafHBEC+V1VQfBrFyWAe}SxR{cJ=* zlV~oM7sXe=l2c46nuO>zYdexxtf!EqtT2)YddAohv|AA*c$l4QB(rxG%z&z`3?KCB6_`=j6# z6}$(6trJ30;x%1`n@ulq4**G+K)qL~_x;p+f_mR(2gq)wHkv7M*o3)D$sJ1m1pCct z*^a5=nz?CpgJtFh)%c#0%eEiplI@3Cvi&fxTRo^bMM;Vhk&;15I>3Rqyb^)e7apuM zP)I0%ml=4hD~ zLNEcwQwb4uHe%44X&27g59CyO@ge-w*?^_%P4)ge5HuR>KwbJAsixmT)3;lzsRXNy zrn&`65ch8#fxPtGJ@AaV^5i`e%jO4&VON*U#T;;KPw&2)K=H#6XTF_~Tl)z4J%9U; zXMZ_yoiNO=WD6CyT*AniXujkw6+LSfWjnRByt%c_Cx>S7&EKB6#p1 zUJD)!*n|EDJ?TX~c#`^G=&gdDy*abHk(%aYn?oSO!tA{H-h1DCGhaRrD}iHj>N-$& zVHu&0KF5X*9^$5IwhWfe=fwv#H((}0f0W9+3|mg7nmFkBA0J=>T8FQKHh5v2C3J@5Y0rP1aMO4)8UxA$EGQ7Y{OQ?aq$!OR@7fA;9 zVe6+%=K*tk;4K6PJ3KsXq2O%=GVW+4HD#pb%l^0bwc*7{U;B0o_!#R z#5Xb%?Vo>_nV;PwXSQ}B)!UY_tK0S~l3uz_PO@HH<9{cmU48j}Nb=MeJkbfo5h^g` zO-w?^r@)~9Gs6EH(*O0xdvw76ABF$Fl4S3~<;_pOC56cUFDkSwpgmD{DQ)zhu1f9!}e!5wNRJa*V{ zg;uXpIgDHn7gw&}c6D=OZF7CSbb7nos%dY3yXWHO#wBbko&M|TliXZj7=~@^%dfm) z%o!(*(c`_j<#x5zwzhX_RjXcpx4JxfG}=3bT&%mTYIC%AW{pG;S{{GEJ(o`cJRVeJ37fQ!!!2Q`A0x!WR# zcUj_z7<3?&mMN2(tgw?P!dV^y^@(@8+!n=gASoJ~aM?|KTeyKwPzJy$;Y^a@lIaAN z;IXiJQILd%yxHTz8e^mZQbDU|$BQ;Q9Gv8ZeBKPBpy%TvZz?YcH}R>@V&$W2g*af0 zzyyG|f=~tn?6O3P(no$lhfHn2-lgM0!A@Q3sobRORms_a6HBWQgBClwU=Ns=NFo4_ zcsS?;-U_*b21zU^X2OlTL+W;d#CO6i3g9Su=*E1qro+h(e9K33V7@cil0qAn7E}(V z$A!Aco2G=Fj)he5QPU#h#{`t3h9z&>f$wOi@T!9kRZ)v%rZMZ=BGH!QtSgo#d5(AL zaK>Cn9n9|VheAq&xEFKkpqGLz5C-&+aZJ%vl}8alpinGwCN!I>kpvRwYS{tcaA;+~ zt3)&KA#{&LoXj|cPAV0XzJjWo+Fy)Lj1B|i@QrO6SfRnfyv{p74WeO`xJHoX2D9ZGVD660&BpU zuomoI$_RvfBOMQp+jG&sRh#i;9E3(P?y#gsP=*qQi0p%=A0V?K9U1W3IBONQ2D=Db zhi$+v!7jtDz^>|86p>`Zg69eS)YU)dOgd%`Qbv;x$+l5?skm`(A#_n>%6v>wj5!|< zSyLj!Bn$9^=rf^q9kPZrRM2w*@ehHS9SnF(Q`}rpd!xjY{Yp^_;JttjvQrOcl?eeW zGASIYgaRFWsg9*S%;(z1v^!lJbHMKNBgZXjcusaAiD4E;F)tZn#>b3lwQq6vJkgTr zu|daSWPU_L`nX67?LOw88iBGMmlleLIiFJYj&877UFGiagNAy}mQ~N_OCfWkcQl1( zTjDtcb$<3NwM=qHh7|XM#B(rU1seSWjBoWQgGQnTvGS`VYEVb#Sp%_kjTQVno$5flXRoO?G-YD2?r&fas+ z`Mz_%bMDOSEXlUKYUKDHv3xSmh{eK))zTzjc8yk7?SOhdUA4WHq1jpZ5Yul3RhA~* zKP?~SNi#_vnR&Pypsm`?hy^5-N|T(|Y(-P0Rs=>-OeTp^$?5JEsRw?8Kt^C!F~^L6 zwh?Y4!2)U_^BaP$%rL}YPHkg%0G6JCxHOr5lob6n)>wwHnG@ZZyd6fQ(yYmd8Iono zLCX#{$jnJXC0debext!WkNujY6w#0KYC;@634kdvwD6Ui<^ z)^QLdzUz##guJ*Df8>ypq}K_P69h@%rb!n4m3A3}q5Cxj#@ zce`@Tm$E?fkYw%0MvLum$~{U##&*jo19mHkMRjX>!vPggh#jd()pp%U;`uN)ev`Vt zthZdifDeqB&@e5IvLi2!0`Y@geFOZk$*NA>VKqg;UJXsue2No7R|3D)1iJs-OX(j{ z(#xz4^ERX?6V1S1@!*FtAreCtJ*QNCw?-x!_OlEp2j-b#FRWatNEg*&Ca)WGK3B}- ziVJ3!Gu~|qQZ|L zy$2v}AYtfg#!~0=dZN?5V_Is=)|gA+*o}d{Sd8~|w&E8~ycmo1T!oB2{j{3L#oMsx z$BI-7mv3Q7TE#H*qD8a0yiSX1LFaMYdj*f8l|TofjHa5ptb-5W_A^+pRw^%n65V3Z zt@3-&%<+5COz}ft;{QVIT?@KJ3#w+6sJ5sYs%Gg1?)|}s(frhTvwho{!s&d@#LD77 zNcT68sbnif4QnXl##ej<%@=b26S?|Wu0G_WxOYuDKakEVNN(;;eu>|Q2`}@*XjVk+ z@tUYTUXisQl_-a$Q6zM~SjGMke6hcTGxn!+{wh~L%hk6sU{VNA1?8cJRjEh=wp236d#`EBS}7djE^4SBV&B{AXM7(9-L`k*(fa(ading zMfQ-FmQ}-o$LxYps+4g`_dliODGn!QT|f*mSh!m6Tx|CjaWKT3tnzX6&I0n{UdUp? zpUhc{v-UYbHTf>zMxZkR=L~*W7QCh4muwpOq@raL)VU=5*HchKp z7*%nzLi{h^gyZMcad`W{d(dU%yh-Zt5@59?CgnPpJ6rf57}MZtSfIj&Z_JL@1`w@;$Nld>i!7f5Nr;x^zd}`0Yw&d}} pq4{wPosd0wnolCqn5^|qS!-Zt$# literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d5edee26f5876e7e255f13da43c9de731529366e GIT binary patch literal 3589 zcmd^CUu+!38Q%p*kcaq)K_}11c|(KuD;4Nz|uGRqKA= zjD0pqB!a{nvRA+Pee?aBnQy+`TNN69uA8!6o?k4M@=J1grLwqEk>|=w@^X1)DVLY$ zKrTO{+m7+b(Sc1Xf!$9LBhY};h z!-Fm3nrm`z-)eJk;$X9O;ZA{fCHAlE|spGsLgtF0yh#6fkd^ANqTp(ZmWlGHK zi$zJ}DVFB7-GKFf$h#1W!GG*%?9V=k(G)1KACUU`3FZbi&N4SxANAEoL$ypIH(V>g zp5+p?;zzJS?dP}cC4~=9gll#f=S(`#?o9RO_kuh`*pMV?Xn_m`4%Y9poXnV~3Yg}Aj+ z!tN@R65ApE_ZjKdMx+*8C_Zp{?C>`@L}WZO0E@nH8O51F9DavG*mbXBKu_yu5L(?x zBb@2W3}pr~gLpe*u*ZcHJ@Clz^g_A4{M^-kJ4|r~HPfLhOVLx^`Fu ztE-=7hQCv}-ZMie-lH*yRVzdUF&w<=?^bl%8cSloQYSTQ%rqQzGzk)G!d1i;+ALxR zizu!KlbSQ8CaqN3Q^f5s(?;9GX22$R8sTYxwi#7)&C@5LpLuBq+Mdq(W}|!D^^9pz z1dR^fSas9TtaM5px1DKMp+qEiTYI)bTcvi|EbV~FhEdbD$Lehu8>rL)$%PfeacoDm z(;lWK?F8LcMYE2pOpeZ_T_6jg1&vCb=nKaQAYDMDqXx>m!Pj;L8?mR2nua39V6NHK zW(>w@6uNc%j;7xZdr3ps=?`Jk{sp)Q88e!R!~)WY%hNohQ{XMCrya+zw!Bs-!MR6a zu4D5cbj>w*^0XDErCZ>sK{svJK=v-(gYY)(LAXr!A}nHL%pFOdK8S$X>~;-L9ZR|? zb}G}F?%3=#qv@XEpwbj5?Leh_%RF7D@aE7&O;kSKvat$-;@(nYQ==(-!~0 zwHK+3Dn&4AG!1LQn?yQS_hBY2T$K1Lx(~tQa1`ddrnM9Nu6C=Co}Y61e3!khr=AO zNLtHKBo%8b6dP0q{xA zvpMoK7oO(uFeKgvCz`g{KB3+&x)WgsF6mg>_SjZNxUdC;A*jk@sL{Y=!oTSdFyU*u z3*jpoNBDxXn>2y!GtU0XH9w&3DEt%GyvEskT=VywUFMoE(oWQTfond`**ThcigrFh zhaRWh85;L!_c5AC((Xs;(2r?XKaKCFUA;6Bqg{Pq92yIJbwnG7YsEhY**9(_zg&@f z&uYDLae;rEo^|E9EPV3Lva@W;a$x_=CIc0VK}ovsceoTy@Jk}{Ws<|D;I5k6cZLg2?r+4+;RSv0$|r@=-@tfvJR zrND3GmoD%nXb^!P!d?O=vJbS-ty?{UU{@bPnBYMQ_Z3834}62ed5E$(&hUS-=v zhqr7(PvGx{p9ZsPu8>`l^W`}?yL4)0KEF^|mT}iHoftg~AbxU}wfKJEE1TBYTrR%| zcG*%TzqF986wl;gW8im+x?BORd317>`+B^}`dO-)Md5hhZ_CP~a!$s+D-PWq=)u5$ zU^CEs`AiR U7dUqRjAK{mn;8q2Pp+-~A9yFx)&Kwi literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST new file mode 100644 index 00000000..06cf6d8d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read-char ;; ;; Source: CLtL p. 379 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 12 November 86 ;; ;; Last Update: 1-6-87 Jim Blum - fixed macro char tests ;; 2-3-87 Jim Blum - changed (read test t nil t) to (read test) ;; and for test2 in last test ;; changed (read-char nil nil 50) to ;; (read-char *standard-input* nil 50) ;; Filed As: {eris}cml>test>22-2-1-read-char.test ;; ;; Syntax: read-char &optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads and returns the next character from input-stream. ;; ;; Argument(s): input-stream - a stream ;; eof-error-p - if true, signal an error if eof is encountered before the end of the line ;; eof-value - if eof-error-p is nil, return this value if eof is encountered before the end of the line ;; recursive-p - if true, this is an embedded call, not top-level ;; ;; Returns: the character read ;; (do-test-group (read-char-group :before (test-setq test(make-string-input-stream "@5") test2(make-string-input-stream "#@4") blood (make-string-input-stream "12345") jet (make-string-input-stream "100") savetable *readtable* *readtable* (copy-readtable nil) ) ; test-setq ;; :after (progn (mapcar 'close (list blood jet test test2)) (setq *readtable* savetable) ) ; progn ) ; read-char-group ;; (do-test "read-char moves the pointer" (and (eq #\1 (read-char blood)) (eq #\2 (read-char blood)) (eq #\3 (read-char blood)) (= 45 (read blood)) ) ; and ) ; do-test "read-char doesn't move the pointer" ;; (do-test "read-char accepts alternative input-stream" (let ((*standard-input* (make-string-input-stream "a B c D"))) (and (eq #\a (read-char)) (eq #\space (read-char)) (= 5 (length (read-line))) (or (close *standard-input*) t) ; for portability ) ; and ) ; let ) ;do-test "read-char accepts alternative default stream" ;; (do-test "read-char eof arguments test" (let ((*standard-input* jet)) (read) (= 50 (read-char *standard-input* nil 50)) ) ; let ) ;do-test "read-char eof arguments test" ;; (do-test read-char-recursive-p-test (set-macro-character #\@ #'(lambda (stream char) (read-char stream t nil nil))) (set-dispatch-macro-character #\# #\@ #'(lambda (stream mac disp) (read-char stream t nil t))) (and (equal #\5 (read test)) (equal #\4 (read test2)) ) ; and ) ;do-test read-char-recursive-p-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e9ada3b36b33c814fe9660ed8c985aa82cc094d0 GIT binary patch literal 2699 zcmcImT}&KR6uvVHl;7>HKvT99N3bod9n1o?Eo$sA%(BbQ&TMC9i!`at3QLDb0r@dn zQbIA-G?`FnYcsdDFTUtQW3W%9&~D<-i_!RKOpVdRXnZhf;+u)7=geJ@){WW+lihpn z`TOoU_nvd_ERo_DWmS;JPL28bJQDPd@ALYN$zo*2jqLm(GsWZh6s$0Rw? z`fQ}!+@u+p$Y!RpgMu}kogB=(u~$r}Nq;Srb|H~?&GC~5xN8AfeAZ#h7B}U__B5G1n3A;aeq$tU(o$; zG4?732-7M;a?6b{fnPpm#{6?eXo{}GYheA@{FZ9YUh!4{_TG|uUiW`O$ddiG?oaR> z7%nZ>^=;2DSxQJHx(nBQZ*Xnl`MQJOc0Kq|m|U19?ouH4rEioR_yeDR-S z*j6Zp%>fLp2T+#ZS8stw$gsA#*?23a# z>oLQ8DJ|nm;9m^=5Dd$bCC8vpt+WC4EPD-6V)mPslH_@?s9_x=tBRzhQ({y%l4h84 zJok5ROApfuUllF$Re-Vxdtsx!knv&L_``}}=!U4LtyJ0y`^v$zGAwERq9;depC9Zh z!q_~P)TJt6-&QaxMu;{VaGgNpp(d>=A%qrTXFh?gl>+x7<%pyrBLh={QA-xGhcIk8 zZ5WES=^CIM>LQ@4`D^E7$y8WSv;x(ofK)82x~U*Xfb+|Gs^4pJFHR71KhQcP-_a0~ zujmdW?_)ri4l?i21|(NOR&6Sln3QBg7v-2_NV26EsH3RsDXeoqSC4+(aWmzeT>*e| zV6@fjPj>05xPEaV@G%zMQ5Ic-Mb`)wQv--mv497mjo?Ur2EbzPfROtZIKP=v3f#eBkD;eiG=Mg{ z>61uy!X00tVVQVUxw`iKi4%;7pCXTh(mX-0%sZZJE+4EyL_ zggnIT_cOz0Mt0DrQRmft6t*Uo*c@4WQN}` z@;M_PGjatCs~*HXM{CgQER7&}lW}u-z{9W8npbH1Q5x){5sL;7(~dX|K1bW1qP5L5 zvWwO>(vA?Vtp;EIpzDa8QWR>Jy_nu-z*Kf}N@$#w8inCe_I%Hp!cYdj3I0u7hR3B1}54a4hk(_XP}*{iX|Gx0!dEymxr z@7VBM*~bI9cml>test>22-2-1-read-delimited-list.test ;; ;; Syntax: read-delimited-list char &optional input-stream recursive-p ;; ;; Function Description: reads objects from input-stream until the next character after an object's representation (ignoring whitespace characters and comments) is char. ;; ;; Argument(s): char - a character ;; input-stream - a stream ;; recursive-p - if non-nil, indicates that this is an imbedded rather than top-level call ;; ;; Returns: a list of objects read ;; ;; ;; Steele's example, CLtL p 377-378 ;; (do-test-group read-delimited-list-group :before (progn (test-setq *readtable* (copy-readtable nil) test (make-string-input-stream "((p q) (p z) (p a) (q z) (q a) (z a))") test2 (make-string-input-stream "#{p q z a}") ) (test-defun |#{-reader| (stream char arg) (declare (ignore char arg)) (mapcon #'(lambda (x) (mapcar #'(lambda (y) (list (car x) y) ) ; lambda (cdr x) ) ; mapcar ) ; lambda (read-delimited-list #\} stream t) ) ; mapcon ) ; test-defun ) ; progn :after (progn (setq *readtable* (copy-readtable nil))(close test)) (do-test read-delimited-list-test (set-dispatch-macro-character #\# #\{ #'|#{-reader|) (set-macro-character #\} (get-macro-character #\) nil)) (equal (read test2) (read test)) ) ; do-test-read-delimited-list-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-FROM-STRING.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-READ-FROM-STRING.TEST new file mode 100644 index 0000000000000000000000000000000000000000..aaf6ce39c0579aa1147c6506e20a040070480388 GIT binary patch literal 3552 zcmbVO&2Hm15O#p}AOk)11tu=Ak7=im-Ug;|+JJ35hasrokqSPoM3?ulEmzDnRW2NcgdDm#|gq^Ni0@e?- zLyDO9Tx+sARkbF1Ay?pHZp?i`7WoC!WWFlEp1&oz2)YCKxwyyah{R3?PUcD|4ZoI& zkqAThN#vD~b2$0l3A{@)vT?3lNPnVC)n7kksVd__;#oY+&NM-C7KT9>bc3g`ba>IJ zx}N7+%$`FB7D4Y#Q8LgX11!b?j>m-zN;AF}S%sv6RIwf@pj27kuTVs80UoYBtkB1Mq*^|}&y~oG1#91b zrlm!mx7x6Afmf`fc6S}Ed-lzm`K#@nuG&K4+GfS97iiD6bz|6CKJW(w%)*kv#sq0b zE`={bhf?mn2u{=0Eu5Ayfq@ZP=NZmY1@sj#N_BkKX>E${c1`f&!_DRU&TY#;`C_MQ zA71J-vum9JJX3B1*=reAl20~$PWU-H{3T-@7yMJ`Qo9h6D9uO6)-*0GP_BsXEB>rnNG_LZ6gji#tj^* zZMyuBF9z^eZ4T?r2Kl8UeqM0a*fCa{P$FNYw_EGwKJ!2JFa0u(u{R6nmL#!!p$xcw zxV_TX39y4L_Ugb#I3MM7n|LT>VhhK%%x?~e*3(fUz!!2tnLgc+o>n*P5erygSwEZP zj#v=#G&4VUap~H7#If1xZRotT>3C%qd)nJ7%qCW)ZG<~*Jl)1dj_a$HJ)YR4cs83k`ThO<6{KwlJ)58I zQQaMh0^822rP=K=ud=qR05jT7`yIILK%K6FOkaBsUAsA)!qFxsdln|bgjhj+ZC28K zH!#;vMWORGbmJ|;HZIfVx^(fO?g<*KmKTTm#MxC~+%4_;=HsVkv%#M)8heee8(;o- Ze);~q@s*h}f6c%7vDawOVDFEA{sk2yHpBn` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fa5ea2b406dda4e7f2849a698cf7734de904c13b GIT binary patch literal 2900 zcma)8U2GIp6uvXvZnrJFY;l3QA`B%6tWIMK2rMynI=%ZtcW2g_SrD~0+jiPrSh{uF zs$d`$qxdiZT0%2dl zbM8I&&XUI0)QqH7j!l%xc2%lOPfbiuNu!mjG+CLh4%^Zw@TK=v-JmB^irU|~zpKTp zlMGkw!jwHCS=099Na6SkQrA97nW&b^@UeFm23R#hd-Y!Z`Won||@ohG?7M zN9;$6t%Mx77YWo#@E@$9KJp{vKtw$H2o<_MR&U|s7XFnjcGg=EZXvE{F;ko=-W(%j z&FQ9yP+S-c)$|aMcV{!_^w9T&%ofk+p?*;a!soShhc=>rkOv4^MZo{CRBHAZsmPNqbCbZU}#ZLeS{BnaHg0K76d-aeg47S(w z_Sxc0X)s#TqjP%nW4*m$wlq_`z8S8e8giSx^M7#r~W~id&b8I=pbEvPVd#de=dE1c ziZz76U{y@f4$GX6p_V(ep$0;j50C14JY*-qlaC%$GDuW_@FPyeLb8ky)VyI(t!^$b z0c8Uqi!4<^RZQx|Wi22U{z6X~swJ%ylD`8P<|jU3=vmpc3@8-}eg?r)Cbi_Oq8hra zrW8X_Eoz|bHpoJ%o;%EE1us9czhG-|`JAo8v$d7S_=Y#^Sr6*O)W(q=r-pO54nfg(LIf6h;EY2HS{B z8YZt_!(Q>$#o0FC3O|8ui(;ASq{gd84Yn2eSAieoK9h!?&w0%A+>>y|Gkwonj(~%#CYdy4=y*{OYQ{`Fl|(!JQkJzv!^p~ zD;Y}0WG$e^p7$zt#dSL4y%aVH^=?9by-z(v`2gN2a}jVSh8mwI-93C1-zfGJi=~!E zZ%p4k{|U^T6iA|Bcml>test>22-2-1-read-preserving-whitespace.test ;; ;; Syntax: read-preserving-whitespace &optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads the printed representation of an object from input-stream, builds an object and returns it, preserving the character that ended the extended token. ;; ;; Argument(s): input-stream: a stream ;; eof-error-p: if true, signal an error at end-of-file. ;; eof-value: if eof-error-p is false, return this value at end-of-file. ;; recursive-p: if true, this is an embedded call, not top-level. ;; ;; Returns: the lisp object or eof-value. ;; (do-test basic-read-test (and (with-input-from-string (s "foo bar") (read s) ; read should throw the whitespace away (eq (read-char s) #\b)) (with-input-from-string (s "foo bar") (read-preserving-whitespace s) (eq (read-char s) #\Space)) (with-input-from-string (s "foo(bar)") (read s) ; read better not throw ALL terminators away (eq (read-char s) #\()) )) (do-test-group (read-group :before ;; Steele's example, CLtL p. 376 (test-defun atsign-reader (stream char) (declare (ignore char)) (do ((path (list (read-preserving-whitespace stream)) (cons (progn (read-char stream nil nil t) (read-preserving-whitespace stream) ) ; progn path ) ; cons ) ) ((not (char= (peek-char nil stream nil nil t) #\@)) (cons 'path (nreverse path)) ) ) ; do ) ; test-defun ) ; read-group (do-test read-test (let ((*readtable* (copy-readtable)) val) (set-macro-character #\@ 'atsign-reader) (setq val (read-from-string "(zyedh @usr@games@zork @usr@games@boggle)")) (and (= 3 (length val)) (listp (cadr val)) (listp (caddr val)) ) ; and ) ; let ) ; do-test-read-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ef6a5aff865dd1de61aab379ac03d0d314c9c1f6 GIT binary patch literal 2870 zcmcImU2GIp6uvXN-L`C7x9yhTQp(ttx-87X78+|Y+S%#tcIoWQc4n5fCZws`#ceEY z(;xp(f|!UV6H0At=0bQdKKNivfW!v`(+3lMAwHN$^huw6GCq))Na{Ir*><5MV1mis zoO^!0bIv{Y+_SSxs$Nz#Nu4=4J2_RHlV%ndW)~Nv6Ekzt{LJE9p(vdIxpYc3O#0rC zq7KK8B(_-EiKH<%2UNRic@%;lk-F%#J%9u4CZvzP8+(rBAgNG+$E4V@*#muU=%n9PmR&0*pCv~b|tVKFa78il}XUWV6Nfo}XD z4XaM%lWo^l5 z_>Pd}(mA7HSQP4Ed*$hTJGugW4Iy=etW6d=*RF~$R+iwaatUfsiVL7#v@#zAeyTek zoh(g)kM+lnzWrg*D?*FGa_HK8R|yj?oq7DTJ<|Jh*?T?4ga}CBEVrKA0dAE;1icV3 zXqYGG-FLF=y)GZkcjaT)h;ZMfu?VbISZ#3k7v8@TH5vqnjBLa;T8*|Y(0*jJl_F!U zU~4ppfVy(K1U7~J|Dk&xT4Cs=qY?15RtgcZ&i&MBjj4t{kj7^z4=MV9Mol@H28o`s zVq%chiuJH+Vb#D2z^Z~7&=^w{TOESOY3EFM!>Ts~0@kQy(~KyBMVL znXzI_5QVL1+laBCFT`qnjW81$V$?JZQ#NvTHfP6tO#rBiDf+1F$`0%^_g6gX3TfM~ST@H5ge=DDl9Q3RM%r{5YCAanz&$;itzG4VgY* z0(b<)M)o;y-KgeFlj;?7kO`=Zf-bySQdO}iPn-ooE#Acwsz!Fyn`>S&DE<}1RjOuK z6gkEsNLJZSB?FOCji>DKQ_H@Gco=&*Lb?e|XNx8US`= zlwm4cwh2uor**hiWT=t>kK}9Cj^s;D95Ao5Ml(r6lcD%IdI|)Aq>Ky2vL@8*LOZW}kPE|KQ9#Gb^zOEbML{aA z06OBK^JyC!8}8RiAERNMZ3YsKb90;9QIC*2tP8Rxzj-=xn+t#7+do@P8k69SWhgh_coMB^2k`K7>3<&*j{UdL&@as%|g*E3{+-A)q>_D0|zrf^u ztR>3gdss_5I}l+l*vGzut|Rv;gU~_zbHMw?St!mgNbRSUc4=~&f18}Pq!Z)t$ukiL zkocK<$z8!g(xyUfZ7M(TrnEHpQ#6YO!HmUuftOrox4q$*d)x4j!A|c%-=pq|4?GJB z!{H(%IZ?f45mhfROH{Z`upWR3cU{K^w}jg}o7>;F*b6^$`?Fg$vs?qt{ZPq(reu-> z3T6Wge-e;TwUtZaql2`Toa(f0(-eGHc}CR(RMixdVrc-9PC*}2mcm?z*$|T5%u7%{ z-;a6jJ>P-k8HmRa#0CN8N9V{K<+zaw+%Ar*-jX``%XQ*?NeWYtKK?b58}L!rA03xo sl?rcml>test>22-2-1-read.test ;; ;; Syntax: read &optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads the printed representation of an object from input-stream, builds an object and returns it. ;; ;; Argument(s): input-stream: a stream ;; eof-error-p: if true, signal an error at end-of-file. ;; eof-value: if eof-error-p is false, return this value at end-of-file. ;; recursive-p: if true, this is an embedded call, not top-level. ;; ;; Returns: the lisp object or eof-value. ;; (do-test-group (read-char-group :before (test-setq test (make-string-input-stream "#@50") test2 (make-string-input-stream "") test3 (make-string-input-stream "@(a b c)")) :after (progn (mapcar 'close (list test test2 test3)) (setq *readtable* (copy-readtable nil)) ) ; progn ) ;read-char-group (do-test basic-read-test (set-macro-character #\@ '(lambda (stream char) (declare (ignore char)) (read stream) ) ; lambda ) ; set-macro-character (set-dispatch-macro-character #\# #\@ '(lambda (stream subchar integer) (declare (ignore subchar) (ignore integer)) (read stream) ) ; lambda ) ; set-dispatch-macro-character (= 50 (read test t nil t)) ) ; do-test basic-read-test (do-test read-with-eof-error-p-test (null (read test2 nil)) ) ; do-test read-with-eof-error-p-test ;; (do-test read-with-eof-value-test (equal "EOF" (read test2 nil "EOF")) ) ; do-test read-with-eof-value-test ;; (do-test read-with-recursive-p-test ;; From CLtL p. 374 (equal '(a b c) (read test3)) ) ; do-test read-with-recursive-p-test ) ; do-test group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6024e6d74f76e6d0cbb7b93c35add826065fc51f GIT binary patch literal 2370 zcmcIlU2GIp6uvXtE^XN^yDM$VxZu#xS{G*9-2#?sLZ;K(cIoU)J3p-TCk-wO+gRGB z-TD(EA|wdO1X@rs7a{RUW1^<^4TNl>ufF(z4?g)~;)6ysCMLerbLQH*3W+>uvUks% zzwi9qd+uE(_0MR!tj(U7o0=}o%d?A>xy6cnY<6B=m|dJNmgHj~mrrV@MPDCLwbArb znI^kNQ=Bgysg#b&&SGid=#kg<$e9DOIyXNx4Ih1dz-IdQW&8K;O*ajxw$9Q1)u*?A zUtfRk{&dsYjjKXzmJm`TRV0ms#7Kzvm%UiZp|+z8<#ehTYM!S2W#4OnS`^o&mhZ*0 za%FZ-nJ&Ftn#OWYED(VZf5~eYat+PNnTCHwI4wl{OI~x%P{yD%b(j*d;ZGDq7kn>~ z%_>rYQ7v-gYV-^t;`Mk;#GF1W-yRii&Ir<-QL(T?iVNZ6L87Zkpc_BP zyevuZlMYF@JP@NRu)zJl=0W#5*SlAgtA$R;rPx)Sx($I7XEtpU$~PyYRWl0gy=DE9 z8U2Egr*bW{|Y;d5nMp&d~`-#|!&km^)%SM^ija&7hJ*Q;*;vw{pEf{+Cn5Xut# zJ#@6z2Suw1CAO@GYAkfcg=Wa9y1vkCJv7Mft+v8H2n1L`-P57FYp2VJ|1O!2)|1&> zkPBU~q0q|mWE(6ARubB}^yW&J8O02cZSzgZOm>3yyqPRZlM>jPQ4zdWzJB-}d0>yA z@rNX=z8oXsX8#>8nbJ&SFo%a-8BvWvom$F34kX5~of4bj=*LpF0}9m|RC30c>!id+ z)+jc>3d5?0Ig6(>)zL;2i#o0abD{-<7PcpBhvr2QEVlAV)O4yE?wB%UT6sIg1W~x( z+c8rt657HVLorZpGTi(Cwd{?_#hDAmA+2bNT9#=krt4r*p#)e*QmQeb1agEAJ%X}~ zoRxd!h06TY%yAYEZ3S7ql{-u=7Wcha<{wwUmM|f#4(Gld2ly&Ps-uTh9hnQjgfVy3 zLG~OV#WmNms8MstFadS1fNtwwoz+yE^1N6C)!l$puj!^uffIgV5|W?Tqe#AGNhGTn zOsB@MGlJ~LYzLALVaql>pFgbUY|KG;AFLXKYe&x+0oZ#R61<4e#s|sfn#&1gOKc|+ zkCXG9lz1L5@;q#w#~z5-)Ip(N6N(L|LJy)m&ageg_P~++7C4e$14r^*;7D#k*tWbn zN)_9&z>%LGWT=`4XR^w6A@RU2Vo&4;OkIISyYwUo!ULvj4353PI&{{VW*ysECmM^( zpsOFV%wYq$v$z8_l_|rP>5j2D>ZZ{$I10!W;Z_eDxOKr!IxGcJ;Ro>FUF*-kZRL;) z?}lm6;4)V=2ZjOz6ZHe4<~JqYMtTg zm>T(+bs_mCFeG0E7UXkIu7P1QwA3|%_MqJb)`H|5Ry*#R4(<*)%Y~;A*QU<+tE}ZE zmVTBc3ar~(8XV5akY2qNKt#yBoPp%EEt^EPhSCu#b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST new file mode 100644 index 00000000..baaf68b6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unread-char ;; ;; Source: CLtL p. 379 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 11 November 86 ;; ;; Last Update: 1-6-87 Jim Blum removed system dependent test and reorganized ;; ;; Filed As: {eris}cml>test>22-2-1-unread-char.test ;; ;; Syntax: unread-char character &optional input-stream ;; ;; Function Description: puts character at the front of input-stream, thus setting the stream's pointer back one position. ;; ;; Argument(s): character - a character ;; input-stream - a stream (default: *standard-io*) ;; ;; Returns: nil ;; (do-test-group (unread-char-group :before (test-setq |1 2 3 string| "1 2 3" numbers (make-string-input-stream "1234567890") river (make-string-input-stream |1 2 3 string|) ) ;; :after (mapcar 'close (list numbers river)) ) ; unread-char-group ;; (do-test unread-char-returns-nil-test (every 'null (list (progn (read-char numbers) (unread-char #\1 numbers) ) ) ; list ) ; every ) ; do-test unread-char-restores-correct-char ;; (do-test unread-char-unreads-just-one-character-test ;; This also tests the default for stream. (let ((*standard-input* river)) (read-char) (read-char) (read-char) (unread-char #\2) ; this is the "right" character (and ;; Should point to the third character (eq #\2 (read-char)) ;; Now it should point to the fourth (= (length (car (multiple-value-list (read-line))) ) (- (length |1 2 3 string|) 3) ) ) ; and ) ; let ) ; do-test unread-char-unreads-just-one-character-test ;; ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7ae5cdc151248c570dd92f8fdb80f49c8ca53f6c GIT binary patch literal 2935 zcmcImO>7%g5PrLM{+z_Mjq@YwhE-ZWHad`k`B4H)qaT(@w);ck37c$yOp~=E9?}=g)e5sdFkPx(D)*Y zHs!CF{!P>WRyF$DU=Ces>J)N2%mwQ28}Tcq|7$`va+gj2tSGd@<96qKFTMi)WvhBO!H2NaY|B z!oox(-GBsPRFQOZBp~XLbk`#R^?yO~{T>n@M}lD^`|svbp;V+|MmEg|kYNho*rTEc zIJy^q504*2UHm=u@q@Y_|3|e+FbYL*5DvlbHEzL<<&_OC|!A5(*cCX<3?4Gd-w)zE8jxzLx@3u{9nH zZAG^UJ9*87W`H8xp&cmxqMayyqg^Pj&~6k%+}F>267!L7Xm_4=WNGI-?dr#!;-)ew zVQ>>>(wIzy;Z5;6=nV`%YFjX_8Vw9Rj_PF^K@mqQA4I6?ptelvmd1t}ScISHQ4~M2 z<-)gIl<6@vzD;{jbnqo@%t!8U@fBM_Dzqn!iNN?|;CB$FUv*^KG#IBxRT>$lkz=st zSgj9A<{3?%&@@BFSG7qR48d9A=We+zy_{Jr$^3Fb+h=b15ht^{CiPxadZp|l+%Zd1 zzQC^sv|W4@mzB22$ru|{FcT~A1oOWtc5*T75q;;SaeqY*@GBu{%tN`#3CnaK9Z+o| zV1@iNsd3XzS{f7ue#+kIp(jT@9hhwNXnuHVQ{$SlSB^~pu9fFl#yX=x!HapG)wG0+ zB|r$qm);_N9$#$N3xgEGDEn2wT9DUQ_^kt%4xuO5UDHlav0WOJ3Da`;4h`;y?o|;^ z>rtV~9Zfz^esSH=EG2H!R$K=0KAi+?oV`CGv2e4cGxriJ{6TvmFyY1)c>xDZEKC+K zVK5W!%OKdvF5aj*n>p}XJ96~8i36JdCeQfHP0aXAfY9R}IEi7~PwKGuB<=2@r@Anq z&~&O+?e74M3O@R{IL#S_Q#W$&;2>f_>|%5W8KuXOz54w}#16<+C}HW)z16|M+Jy$a z;DDPPuIDOaL}+)*zHGjbU(HoBL`Lr;jGjKo5bYzxqrx~0sODS({$D^B@bVd<;{w=Q zo=-SdENRRRW2!$sAt>KRDUULYUVH){?iyKs_E1JO%7Vh5t8)kPk1ONa4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST new file mode 100644 index 00000000..1de5d522 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST @@ -0,0 +1 @@ +;; Definition To Be Tested: finish-output, force-output, and clear-output ;; ;; Source: Xerox LIsp Manual ;; Chapter 22-3-1: Input/Output Output to Character Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>22-3-1-finish-output.test ;; ;; ;; Syntax: finish-output &optional output-stream ;; ;; Function Description: The function finish-output attempts to ensure that all output sent to output-stream has reached its destination, and only then returns nil. force-output initiates the emptying of any internal buffers but returns nil without waiting for completion or acknowledgment. The function clear-output, on the other hand, attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the desitnation. ;; ;; Argument(s): output-stream ;; ;; Returns: nil ;; ;; These tests just test that the functions dont break for a variety of devices. It could be improved by putting out a huge string or simulating a slow channel by advising \bufferedbout (whatever its called) and do some elapsed time tests after each type of output. Then do an input-test to see if all the characters made it (or not in the case of clear-output). ;; (DO-TEST LOAD-CH-21-FUNCTIONS (OR (BOUNDP '21-FUNCTIONS-HAVE-BEEN-LOADED) (LOAD "21-functions.def"))) (DO-TEST ("finish-output" :AFTER (DOLIST (STREAM-NAME STREAM-IO-NAMES) (DELETE-FILE STREAM-NAME))) (DOLIST (STREAM-NAME STREAM-IO-NAMES T) (WITH-OPEN-FILE (ASTREAM STREAM-NAME :DIRECTION :OUTPUT) (OUTPUT-TEST ASTREAM :KEEP-OPEN) (FINISH-OUTPUT ASTREAM) (CLOSE ASTREAM) (WITH-OPEN-FILE (ASTREAM STREAM-NAME) (UNLESS (INPUT-TEST ASTREAM) (PRINT-STREAM-ERROR "finish-output" STREAM-NAME)))))) (DO-TEST ("force-output" :AFTER (DOLIST (STREAM-NAME STREAM-IO-NAMES) (DELETE-FILE STREAM-NAME))) (DOLIST (STREAM-NAME STREAM-IO-NAMES T) (WITH-OPEN-FILE (ASTREAM STREAM-NAME :DIRECTION :OUTPUT) (OUTPUT-TEST ASTREAM :KEEP-OPEN) (FORCE-OUTPUT ASTREAM) (CLOSE ASTREAM) (WITH-OPEN-FILE (ASTREAM STREAM-NAME) (UNLESS (INPUT-TEST ASTREAM) (PRINT-STREAM-ERROR "finish-output" STREAM-NAME)))))) (DO-TEST ("clear-output" :AFTER (DOLIST (STREAM-NAME STREAM-IO-NAMES) (DELETE-FILE STREAM-NAME))) (DOLIST (STREAM-NAME STREAM-IO-NAMES T) (WITH-OPEN-FILE (ASTREAM STREAM-NAME :DIRECTION :OUTPUT) (OUTPUT-TEST ASTREAM :KEEP-OPEN) (CLEAR-OUTPUT ASTREAM) (CLOSE ASTREAM)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7e5e6648dd5ffcb8885b7346955582c7baefdbff GIT binary patch literal 4205 zcmb_fU2Ggz6~1@YUOWC7uidptwg%sXIyKvjCEH2cm@0HUp0&5$omtP!)-eS|+x0lR zj?@jS z>0g~!wT1D|PjuNWoP5R2)!Y^4Y`WEz+{?$<#7U-ZREq2H@buHLotQo`Ieq;2cvnKT zQ^MN+)R~$-adLWMYP@UrjXI5#2_bp1gUbOzA|yoo*StvF(QQXbBvZO#sA)a!Z~I;+ z_@ZQO-SWNuNmeUwDC_P^?mD`2zDg(|{xz>Nku@|YX&V0P^b+myuX?>nL&<<^>YPrb z&W07VPSMPyGNnu?2}`%NuLnqo-KAKPghlo0C~dB>Dr zGv#lI?T=6x9(xJdxqbv5;DaR46`Q+zfTF0nuh__l+|{HHCrF7NEW|V|!rR_MU68)&QW5&508sI&lN1z+Yaow^^ zOEI%fChNpQQBdfKtH!bt(9uX}5NXT0t>~xKbS9^oun8kh)xqr*1gd2%OE+5DET_oZ0$y}KZklTA0v(r;y##UX z8r7fIt!2fAK&Eu09tZoK8Pg78jf4pxbXX{62LkP&Hj-8sbnNOWC1WNH2eKgop@;;6 zp7a}j2$#2c43{_gqqtlIW9?eX3`|KId>Dyoz}dIox)sbi??uiSAHk(pnCb{j(SHS| z==+=jkNyGR$fJhoVC?tYpg-k@k^4$ufW8nIpr?g_q%gohv)|SoW!BWPX^5YS<%L=U zz=;AUq1emm88f9cUq-+rAA$>gA4C5Wx)vlKrQU~~Y-e;Wse(GBOUWSlJtU`9%`$JZ z`D-9|BxcO4F`M}^Johy0L(a2$3J77r8|U#)^C!l@Qiub!J!6@3h&WW`M{!w$H)q(u z;s|Qx1+D;9@&l%HRqQT_WgPU|jBE-8>E8nh`a!^=x5RRpk0UP&*@?7dXU;OSnIJv% zlu$b%#dB?)WhW~C9=CSQ2Z>&8l?<8R;l6W`9GoCe;pnWNjKu6ac=qwT? z6tdTWmm_QGaQX4$waraEH6?X{9|z~4RByXwc-i3IcB1q934$;on4voDS%fA#e^Y{Y zJe*A7WKY)C-CRl8+z`VSg<*@I3`VR@&ZqoZR4%6+*%Pd!8wSvoDbk7z`rDEwUD+7-; zk|_OxKZWNH1n2Wai}jH2J^3-#YiPSvuHD@(-3{#0)sNVvi@rBLJ)^_z*G0I4fgQ@L zQAo`S+Oiup72LOB-@B+^bn}}vnCdr6`C74DVq+Hy#e9Lm&|ig#|GZl(1pdKqfLfX5 z3%N?Q1~EAQISc?uw|LXS9B0f5A{T_|rQG_aiy_(<4$hbBv=^&21LccTJeJMf(hhaI zpZ2|rPs99_$T)>U#zbO2CLgps|Izmz&pVG13=`_39Lr)W}Sxb-O;8&sp%W}$^WMhfWlDb z87m1G5XZHL;T#T7gwiX*HLp$|LDzyr;>3U7feZBkPI$*84XuNpl6anC@9N4kGtD+q zNtmtlSq|Ai2VSiQlm305LECweQobgveDi^<0JyN7#7V1(>e2&+wMW#9=&}&lplV*J z(~fiZ?`EhO$_WV8#Rs$j?U|IsO^SX&tb=X0_n#0XC3G0(n22VkGw}0!R%yIhkTJl& a28;Ah;2-!>#cml>test>22-3-1-fresh-line.test ;; ;; Syntax: fresh-line &optional output-stream ;; ;; Function Description: puts a newline out to stream iff stream is not at the beginning of a line. ;; ;; Argument(s): stream - a stream (defaults to *standard-output*) ;; ;; Returns: t if a newline was output, else nil ;; (do-test-group (fresh-line-group :before (progn (test-setq yes-examples ;; These do not write a newline themselves, so fresh-line will be required. (list #'(lambda () (print 1 charstream)) #'(lambda () (prin1 1 charstream)) #'(lambda () (write-string "1" charstream)) #'(lambda () (princ 'simple charstream)) #'(lambda () (princ '\c\ om\ \plicated charstream)) #'(lambda () (terpri charstream) (fresh-line charstream) (princ '\c\ om\ \plicated charstream)) #'(lambda () (write-char #\1 charstream)) ) ; list ;; no-examples ;; These write a newline themselves, so fresh-line won't be required. (list #'(lambda () (terpri charstream)) #'(lambda () (fresh-line charstream)) #'(lambda () (write-line "1" charstream)) ) ; list ) ; test-setq ;; (test-defun fresh-line-test (function) "Execute function (which puts something out to charstream) then (fresh-line charstream). Return the value of fresh-line." (funcall function) (fresh-line charstream) ) ; test-defun ) ; progn ) ; fresh-line group ;; (do-test "fresh-line returns t if not at the beginning of a line" (let ((charstream (make-string-output-stream))) (declare (special charstream)) (prog1 (notany 'null (mapcar 'fresh-line-test yes-examples) ) ; notany (close charstream) ) ; prog1 ) ; let ) ; do-test "fresh-line returns t if not at the beginning of a line" ;; (do-test "fresh-line returns nil if already at the beginning of a line" (let ((charstream (make-string-output-stream))) (declare (special charstream)) (prog1 (every 'null (mapcar 'fresh-line-test no-examples) ) ; every (close charstream) ) ; prog1 ) ; let ) ; do-test "fresh-line returns nil if already at the beginning of a line" (do-test "fresh-line writes a #\newline" ;; If fresh-line is true - i.e. if an output command has left the stream-pointer where fresh-line will actually put out a newline - the last character of the output (the first of its reverse) will be #\newline. (every #'(lambda (newline-position) (= 0 newline-position)) (mapcar #'(lambda (item) (position #\newline (reverse (with-output-to-string (charstream) (declare (special charstream)) (progn (funcall item)(fresh-line charstream)) ) ; with-output-to-string ) ) ; position ) ; lambda yes-examples ) ; mapcar ) ; every ) ; do-test "fresh-line writes a #\newline" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..182ad503a7420d662b7fd10639c18dcc4412d9da GIT binary patch literal 1909 zcma)7?Q2_A7(X{}wnx*Pb90j3=H}kp`_eRmjFP4%+AXC` z1(B6*2>TM4-EiD9**~yP+Yn@PBf>z~2S57<_)!oA!4H0@&vS2fELBkmJip&_p7-7y7XBt^o+yWUG>9cnvLN!6&N%T=27_PpK@^dh-7wY*+>TI_Z< z&2?<&!WIz-@jmYjm0VqMR73Y}2)jbkyVe^~b;*R*;3B#8xDu)z$)ttY2Y!wBPk`hI8yKLYL8mFLnz>%sZazA*~)mp$#8G5Um%z1CG@v=S0V0Ny=TJBmJVK14{8 zkbb+7>E9zy4^$&Go>enc8;9K2TX#PK`+xhz!31*F#*IZaEpBjNc3mFX6O5sg>(L0e<485r0bxHHGUeu^16;#mZWjh;+ zvEfh@b|IZrWJj5oEb6!x+@<0#L(Hz*4y}elU@;zSi=t6kcTK5eSXDdAgplxeZ^y{8 zM0f-aB1K9~zE-#p;RG8F%#&GJuS>ojV|%?+{?H1JLi3uczb;%CWDi)@=mPPdgOU?v5dk4=51@+$E06Shb`r%Mb_&H+_5zB} z*wJlvEC-fJyIw6AngpG=^d!0#3|B9jXe}%QkD8WI#`wYll%5CzOE^%LLhTIN_=7{1 zg^x6*<0SmS9A{IgeI7g`__g~kRMb)DI8-SXh*l83`*-I$CV=tq4f<-7Wqag6NK+|eTDjL+5biYmOr!{GbS~jdHIzPl5VC@^(sQDVh1GCQE(DCRf;$ z#irhdK1Zr@#nt_pzQ)q8;II~5!=a~HdICtqrp{u9rDG6MD0#gXo#s|ooY;{k#I+T8 zyjR8c#o*mV-HzYvb?-~>27VZ)f*z$q>!hg;wPej^2{2=MHhIbG<>m?$7L*3Bss9(z z<(ZzP*s%vmb83)4kXdSg3LGgM6*+>79oUsPDswc?k;>5mM-`4Vj;b8#92p$Jj0f2k vIkGsieRO$X;d1>FM>UR?IjSSV7e#oFrQQW+7+gByPnyjJbducK*x&yX=w>-q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST new file mode 100644 index 00000000..6398d30c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: pprint ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-pprint.test ;; ;; Syntax: pprint object &optional output-stream ;; ;; Function Description: outputs object to output-stream (default: *standard-output*) as if *print-pretty* were true. Returns no values. ;; ;; Argument(s): object - a cml object ;; output-stream - a stream ;; (do-test-group (pprint-group :before (test-setq deep '(A(B(C(D(E(F(G(H(I(J(K(L(M(N(O(P(Q(R(S(T(U(V(W(X(Y(Z))))))))))))))))))))))))))) ) ; pprint-group (do-test pprint-test (and (null (pprint deep)) (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (prog1 (null (pprint deep stream)) (close stream)) ) ; let (let ((stream (open 'file :direction :input :element-type 'unsigned-byte))) (prog1 (read stream) (close stream) (delete-file 'file)) ) ; let ) ; and ) ; do-test pprint-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..873928126e37e701b4a47cf5d5cb4434bdb1d4f2 GIT binary patch literal 4001 zcmc&%Z)_Y_5r4bq^Pls-bK*4ZHFY0OQzu8(!gd0Q8xrrW*S@pwZZErgbu22P_1!vm z_4&@+trINL$V8?s;^g3_we}GLNJvPLS~Wy`NFc>P1QJ3;MeqSpp$Z`+q)HG8AwGtg zeP`!l0x9AH*81kn%$s>Lzc+98?Hci)QsPu8%`fB&cA1tIorOh*&X&rwQd%r$Y&r{a z`UOSP)t92OGTHy!K)|TeWXiVX*jZ{W+Lf%ebdU}lrSd{KUx2}pBft&}A08Y&bf`Zt zCL3|??U6P^!-tO!A3D+>xOa732$l#T8M1+-g^(ce5%;xfFl?%ZDUHSAs+5!yYS>+K ztId#$lr~h|t#%Dkr?emy?6Y!XPYSn+V&a`i zajHAiB{ZJ#g1xZ^=+*<#=RzTPLKC6yS3!)XzygOO5ae6A5ZSqcZ_BbE2K-#pOo#wt zaD{W~|3OpplFNl~l*6B?JySh3O^s~Y6x!>YOwodWYqk95Vj%IHV91aB%Y-&~U^m7% zJ>9XPb-bo^e2KGPuSM5R$j0?vkip}H847XcKfqI)il+As0jvMRiuv0R!H$bfyM){= zFGFDOuEj5D9d`&>%e|s?Oo{>ox_14EsmE$51M+PUY(De&#&^kwDBLWVw>Ar=8KqMp zF#O2=cXR(}Shql(ci*Qry|-}G;1|_}Zh(63HxI~g%ekPo+5dYa;BF!WD{bV0L~L>2 zsO||XT5>dohfj*i$??z+V zFx7-8!i;Wy{*|~YC(|iuOw$uam8z!VH>!VUEiHo|`;J~)_)ZRo0Yrvk=hmEBd%o^0^TyjUx!#rI(s0{hhGRef4A0QR_w(qDl8_JlmCO0urY z(_x1;8T>-AcNU2Ip26MngN};%l;)JZ| z+5DtQ)5thbB?@ff_rQf+Sekc$8Cf*1b+Z@0!ImI+pk_yOxj@++to zzeQ(ghV4N9m%#hvNR7J#Hl48~oJoLEjjOm-IO|8SKr4UONlH}KQT7hZZL7_Z%;}U@ zJ8z@Afx#i}{7v9KAqNbnoG+fC=kiXDrWY3AUSSopfq3bhT@EN##YUFK^F@2swzCy( zdJRmQ6fKdGb(Krzd0JVXN1BsoVA`&2Z)0g(*U~9&6yQb;-fZFToctNG*?R9oD#D-G zCz1S)lXo%MG1#JX(!&^4x4G&T0(~;Ad0Q#G&5Pwt5H?^5nzrFMCAA`JyttIhY=Ah;p#vLPgwVS?Y7gz7wtc|fx;Y}{G6N_|#a@=68FpUlKB3W^(PizmoUVF z7AMz9%Lu&4;0Y498Y)=xGg%9R+}_0jUcu|)(8%3tqZXM^6%*cQ(1G}2N{KM;+*ZF} zh07fFa$wQA2&r4`AC9Qd<5Yf$^={_Q7F?S+T`+3M;gJ_UbgMwfHN4e-)UEIwTl7r+ ztX-s~nHTMhL-$vf=4VO;iXQ{sCLZXg)Ua*pC*)@i*OSU#ehZpURdXJjgF=&qBAN7i8RY zi+US?9~Fr95=VPEUMkJiP~?eAb%}ds9K>M?;GuhmmcZxU7Z6|SoGa12=ld!LQR_kE zSY^ip%r0gR;vBmG5$)~m0~jAN#RG9}oka15Hv+e}o6)ss@WoB;?o~d78V23n<=m~< zTI}DdABnp7utIN=0rKXQW_VY;<5=}N-Zcz$h}pf&ewxj8GrN)5#D8?Pw|})aw0gdC z^}Mk90@lCqS-uBeR~)GuOYAh3^B>_rorSV2m63aY72o3Ir>lpN{CMRA{Nm`QTWzc4 z=NI6k)hd^*C6s+{WhC8m6GzwK>#kydZqY7gY~-)K>}x>!jg{knyJO*qt&9Y@r%M-! z@bb4%_UbxmC}ba9hqVhFSa_kVtejZpqhcml>test>22-3-1-prin1-to-string.test ;; ;; Syntax: prin1-to-string object ;; ;; Function Description: outputs object as a string with escape characters. ;; ;; Argument(s): object - a cml object ;; ;; Returns: a string containing the representation of object ;; (do-test-group (prin1-to-string-group :before (progn (test-setq examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list ) ; test-setq (test-defun find-escape (object) "Look for a escape-characters in a string: at least one #\\ or two #\|'s, at the start and end, or else #\"'s at the start and end." (or (position #\\ object) (and (eq 0 (position #\| object)) (eq 0 (position #\| (reverse object))) ) ; and (and (eq 0 (position #\" object)) (eq 0 (position #\" (reverse object))) ) ; and ) ; or ) ; test-defun find-escape (test-defun compare (object) "Compare prin1-to-string with princ-to-string for a given object (symbol or string). See that the first representation contains escape characters and the second doesn't." (and (find-escape (prin1-to-string object)) (not (find-escape (princ-to-string object))) ) ) ) ; progn ) ; prin1-to-string-group (do-test "prin1-to-string all types" ;; Prin1-to-string an example of each of the standard types (every #'(lambda (object) (stringp (prin1-to-string object))) examples) ) ; do-test "prin1-to-string all types" ;; (do-test "compare prin1-to-string with princ-to-string" (every 'compare (list '|A String with Upper and Lower Case and Linefeeds| '\123 "this is a string" (make-array (1+ (random 20)) :element-type 'string-char :initial-element #\t) 'ab\c '\a\ \b\ \c) ) ) ; do-test "compare prin1-to-string with princ-to-string" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..506b23082180b1cf01731ebdc0bb478a2d3de48a GIT binary patch literal 3730 zcmb7HeQaA-6~FJ!fL^_K`R__k7-S&OPVc>lM~@RLx52{K9vtqy`P!-wnP-fZSernIu?Pz=_xV;NZflk;r!rYh)|H$VcURn2 z4`PuEmS(!G=&013Uy!TLDW^)|oNO?GG55JvPpY7+cE-@%7lbE;e)mFaAfwB9gr-bt zOzi1cA?t$M>K`4I_sb)4-puGD?6uYKS;oZoq7jk2`FZ)ulyJEw?)}A-I2{{|3f+(S zE?(LSxc-69<-tLG1`iGXtOYWu0tNQ*#n-LgvFODvr9nSO;8gnfF0|8$YG7TqD)x49 zP7h-O$j~C0jep<}3TC-HNUJjao8CSxbvPZcrc)i*U}Soz+O@u0WoKWADnLzCDmJs$W^;?1^7K@H+@nl zU-tI{dSfMf!3bYvY^8k82v3Ou)K)HjYI;k@0py{dR7>}^f5LuA#I<^OcC8+IU}kzN z^ggorEq61&(e^*qY=@=?5osq^A0vRf?f^dz`R2+ICWhRXT3h3)p(iucCvsZRlUdD_ z6B$tSNh>b)cpl#PO&FWB)wKNR}oiasOzbTSg?g5$ze!y40*;X@r%%`v^GRRsu)7Z3OPeLH6#_ zj%enLY~kdxzG#SxcKf2j`@X2~8;C|N&6bmfTFAjeg^nIZgtx(ofs>N0nOwri%4_qJ zn6JZ$&3Bk*ni1@YUF27d`i+*5`KW}eUPKRf{EiZax#w5rqJ1Y;B59eX~jy* z>l)X+&k*}6DP}XcR+MaZ?MkqSbA@mCT@GG^T+qmC`d6{&?}U#-FKAg1y1DDa-tac> z{t0M{zXP=^ZyJ-7Q1Km{b)SEq$djf~$a|k4>W{pg1iptGs#~X;@k{6>ZN4)(#%ZbeF{ zNgkrG6L}a=l7|X7JASOfr)hI^Itp1<(~3zpw?nKSeL)o~+cSCpl>Z81mo?Qna|$Vl z*7DEsO_E02`tehP^|B128eE_z=g@VfU9f#<;KE$CKeQrD7lVun}Iceu>A zVXIq3<#FmcpwUbU4WwDJZrHMR6qQ6)mci-MwP_iRXz{LM-vTWJXzj-%Zm+phX%cvgpI|w z-IhF|q!1>50r}6mrqgIjLrcn#RH^aj*pem974gcO9VVp(_Z9aA8r$1>Z1NprDVu>k zC2M(o5c9@))ji_2cG&BNxwUoswAs=wvK{knd)Zr>!cDg|Jdw~a6||4;q;TDBQD)!t zOIs?|r1@jVol+CSSt|0NinUq7;*BO&#rmwwU$*hRQp0g7wa3Uir&uaWrDDU8n&o0s z@{R3oNT-U`MMtVMBQ7nJ`dy44D%MqZI)!O8t! z7!$+T<=#o$P`pn%dlSGw*o2K4n^(D8uq8- z%7*ol+uEJSmME&(c`AvzGwaNu45TH6&Y&py4M^We$jlh>ehQU4UngwudFoqX%X#1I zJH^VTMv4MmHJ+&G0S;rq+vfp$`Si`3{{y@)3Jd@M literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST new file mode 100644 index 00000000..5fbcfb26 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prin1 ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 December 86 ;; ;; Last Update: 2 December 86 ;; ;; Filed As: {eris}cml>test>22-3-1-prin1.test ;; ;; Syntax: prin1 object &optional output-stream ;; ;; Function Description: outputs object to output-stream (default: *standard-output*) with escape characters. ;; ;; Argument(s): object - a cml object ;; output-stream - a stream ;; ;; Returns: object ;; (do-test-group (prin1-group :before (progn (test-setq stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte) examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list ) ; test-setq (test-defun prin1test (object) "PRIN1 an object to a file and to *standard-output*, seeing in each case that PRIN1's value is eq to the object. Verify that the result doesn't start with a newline, as PRINT's does." (and (eq object (prin1 object)) (eq object (prin1 object stream)) (not (eq 0 (position #\newline (with-output-to-string (charstream) (prin1 object charstream))))) ) ; and ) ; test-defun ) ; progn :after (progn (close stream) (delete-file 'file)) ) ; prin1-group (do-test prin1-test ;; Prin1 an example of each of the standard types (every 'prin1test examples) ) ; do-test prin1-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..733874a1d06906664645de11b8d3f98104fe9d0b GIT binary patch literal 4494 zcmd^DYit}>6}~g$=lZoyoTl9-?$l|TW}C5MJE4u!)SexWy&LcDY-VQb7y{8`J15#E(jq011HrA%w)^2SF7`2t+t% z?%LTpfkfgb(R$83&wKB8&OLJ{OQiOw5*L-?shM2fE{VlicV^ZVCyOP~DbAKMwm1oL z@kK?`)t92OGTMExCty@*G9}w`?FrGGwVerTevjC5K$K@nxjYP>eHPfB{{6lE`}TDQ zhGiqpqTSbLU;o~{{eAnp1GlfNaKR!WBtuq_G!had0`V@DgJDxOOlde4SEZz!P{ZDm zS8jm4NNGdWy>ff6=oV+Bygg^F)kIj{UsZ?DuR^++i_mQ*BDlME9^Bjn0T;5;D$Z4dIeuJ2}Vj&e5&{Oa4I z{8&e*ovSy|`*}|?3 zGkUyrRcpPZwSJnhuUA&rLdfdXE|9^`UuG!8nEwJ##S~rdI09Dx7c=H=!k#ysuiwID zZ}^x3duu6vQEPpdkfrRaTI(p!0W?cj9~pb70y5;f8Q{rf9$x(x`6CJ|B`S2Tm1qNm z84H2m1Bc(r!eg|m_|?I`widjRr3s#>&UZj=r+@Mx8P*sRRI2NLUkQXe9Da{J%Q1)$09k{2R8FMgsZJK!RvK+OFM#R*x_ zwd$DM-#}bH9MRIrA>ZuJR7C6F(8rOi(k>)#(j7=H(*X-w13Beb&{bj=mqplH(Sb`aFDJx3v?un2r@O4mj( z2SV0gyl@=ezjaBhE5FQA)GxgVlu)fDo)9y16B-WyFUXM!w-0>UVo5l}fV~=5F}G-i znQLNiV@Zk1I?B4iwz*;>nd2$H*hCE1)7!^_ZwGF#95CEcu5eO3opZBddS(W0K2~8O z5HFs#O991lY-GiFu3%5v_JqS+L*QDkXo-}ptGsehP0)VKJKXMW~!$V z{3B`2PcQ$tUqE~(2y5^hpy3u~*y0oJAB=p!$nWU^FyVejKZ4}vjJ!wtk-N#b8}uM@ z-(;ovb^07~Utv0rkuy#fUP*!jd0DHMGb>htp8#l{4@@?S+}hd$bS9G8ohvqi_o5 z5F6-XhK&^jmrAI2EtWJ@{RC))NX$G=`x10ut#MT#f0}N7iXPlaH+NOAJrbguB?v9N z?3MRq;8JasY!Pn5g&xT*N={YLp)hkth(0fR<;P6hamB8)a+f%1!Nq$*%oW(38D(d& zNeIs@x=40FPj|C9M}(gxvd}26@h*GI_`>Q`;P{)Ww4pi2W3VeZZqOz$qX${x{naZ! zvT>PKJ}}MB`&iq+S);NgJoEg= zy)qE8Y}mHwW-S*U_S(lsangsZ3LQVBC7#U9*#)t9V#?0A)!W9yx<{NX?= z%mv|k;gv&q>(q$}3lp^Q)e0XPod0Ttx2spK(;|me#S}KvL-kN5^{i*5co?^BXbJE+ z@>;nOyP2#&mIy(pA`EQ*=s!_4ZuiQ&Qh6Jj)kLwd%N0xZggpr@OFS#%sw~k@0)G2I z817FD@wf0(??J2bUbsKy%%3_@%!~Mi=-2b^Zc+SD8YgolDB_YmQ?eZ!kaly$!X3=- z0^D!4n108G#7w|uYzMZ3dEkDzLbhTa;CHz~A1DJ*T6brlCO{9h(4)2V&^q=#RiAV| z+T8mLVZZfVs~W#SkKuym8H(rP#o}}Y9kwCqP6aXW894nS)HWu`6^oFW9mfzi(LG%h zcbwVf>_M%+b=NAnJ`gsRGT7L8$m@=-U2wSXVd8@`y+WdRyB>s_^Y!RbG&r@!-MYet z02}CToy*>cEyez$`o8td-wVxp849=|r5XP9`gyEu9q)OD+DE6l=+t9$x`R&D(J4}U zV6m%vu`9HArfu;Iw|ESzn)?L9)^GfSRb$D=nfw;c%^V!_VhN1NFBb6zMSifjAIbL@ z2H=UK>t4Cp$(@>k|Dmu-C2JmK-(DC@cV5TQRrr*5>`%_xg^Z2-TNi{Hq+eQi{)2Zd z9MOfrAd7VIJmD^U8D*bYAvO7l`3 dxe)o$I~TEQ3bg}lvzu9;UT>x3i}SZ{{~IR$-L3!t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST new file mode 100644 index 00000000..2bf8b3e8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: princ-to-string ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 7 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-princ-to-string.test ;; ;; Syntax: princ-to-string object ;; ;; Function Description: outputs object as a string without escape characters or quotation marks. ;; ;; Argument(s): object - a cml object ;; ;; Returns: a string containing the representation of object ;; (do-test-group (princ-to-string-group :before (progn (test-setq examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list ) ; test-setq (test-defun find-escape (object) "Look for a escape-characters in a string: at least one #\\ or two #\|'s, at the start and end, or else #\"'s at the start and end." (or (position #\\ object) (and (eq 0 (position #\| object)) (eq 0 (position #\| (reverse object))) ) ; and (and (eq 0 (position #\" object)) (eq 0 (position #\" (reverse object))) ) ; and ) ; or ) ; test-defun find-escape (test-defun compare (object) "Compare prin1-to-string with princ-to-string for a given object (symbol or string). See that the first representation contains escape characters and the second doesn't." (and (find-escape (prin1-to-string object)) (not (find-escape (princ-to-string object))) ) ) (test-defun princtest (object) "See that the output of princ-to-string for a given object is a string and, unless the object is a character, that is contains no escape characters." (let ((obstring (princ-to-string object))) (and (stringp obstring) (cond ((not (typep object 'character)) (not (find-escape obstring)) ) ;; Characters get this for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ) ; progn ) ; princ-to-string-group (do-test "prin1-to-string all types" ;; Princ-to-string an example of each of the standard types; see that it contains no escape characters. (every 'princtest examples) ) ; do-test "princ-to-string all types" ;; (do-test "compare prin1-to-string with princ-to-string" (every 'compare (list '|A String with Upper and Lower Case and Linefeeds| '\123 "this is a string" (make-array (1+ (random 20)) :element-type 'string-char :initial-element #\t) 'ab\c '\a\ \b\ \c) ) ) ; do-test "compare princ-to-string with princ-to-string" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b01ccf24b0c04be8b0a253e0a1a0fb69d4c4db89 GIT binary patch literal 3197 zcmcf@TWlj&_0Ht6v6FZm!is7DiRXX*yo;e?s?vG&$&CK@3Nv%#arKS8%~RQoBqb8PuIK_ZF`%onnTxsPM=W> zQ~hp1Ru(57&Bm=moLbAN`pzn~H=Xus_4;|5eT2#zEw=%S3l{**&g3R%rl%+3dD+sq zw$GHAo_Xk@ncRhm_}y1`g``IasgVwX7$Hg0L&E2SWX4u4Tgn$TRnp~>nhAHpU;tu~ zDwb-7!N?@_y$z}1JmoYnob@&l2nl~04CE`iViyfPd_nlWFcjVhhKssXhS21Bm52jf zEvQ`xgQ3YuX-djUWwWR&NaxKlSipy*dOFP!hz{29r5Dn-f={`CbrBThdr@$ZV<7hb zwCLUj4?g$Yu@RxZ7exr@M?2aLBk?;zcIrPi5{se$j_$nq`K1%xkOv4E0%zUY$<9sk z2@>~n_x6772D%|4voQ%V@i@EGcwdy8H0b@W&7b&p<`3Bx<$c?+16y5lU>-LDfDaEO z{l8lV)eC7**QqCo7zw{t+$tbd| z6eLr%D<%}H5>&gV=okGt)O@bm@DmTjpfi3(Mk`zCyUQ*3v$%3qCDpEfL{evZW zQI)La(yW0tg}(r;5AP_N6y9Se5&W8^5Zq+4BTP5urZjaaHJ%^6Ci1QE%2da#{*2%Hpf@?Ec_{WgQlKY;4v+}k7c zo9K3wXWaEmz!FwjRf@6}ouE`k^2L+VYE^0K zl3+k7@sU z#jw#bxy4Q+_ze(yu}lzogKzu=2QP9EaPR|`-9j((&=4fmQslDA&bC=@jZIcq&SX;s zc3NfAUt_r}%Z;&In&q&}#RtP+)OOlF9ov$}=voz~_bPRpeDES|D>|+BVM5w|s>uZBqn~ zhe3*)ia+i8^?1{Hy5TmRHu9Fkpr7*)yBHZ`j~r5UE(|7SW>sh`Dxc@kBgH=mbw9=} zs~a_jL;e;9%}Y+pUAs>Gdex`ZCiPaHaBBW|n_>ZEY0KGYIc=xuSAExO(wYY=x7nsn zyH?$BXsuptRcpS}YM-Yo@G^3JE~wlqxav9W=C~hO{a}~ee-ZjUOsiMAaHpPhlhFCY zAl<00udG(_Q0{H3;II(2Rp_jc4`X&gRctZNa(yf(4r4tre@A5QZX_L1O ztzQp=@p8kdwjH|afp6gQspdf`ulXsq;d6vS<@ywO(w(ILFUSqsHL8QT7Gy(cav zIz{jqAGj5L2`@i%ZX3z~hPDXh0bT8wq8V1jRIx~~PI~93zM2z8z^Rk-Fq)2-Mh~E~ zLW)LrNdk;PRTl2_!^;s9lTe^Kn$qS5zftf&CTt0(x)2o`+EImGFbR#_Fl|D5z6{|e v6{A#!clVssb>s`|+XB#ISIV|osOXE+E-%8|Vi#UuTJO;tO@4Ou?%jU^wPuVI literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST new file mode 100644 index 00000000..7f8567cc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: princ ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-princ.test ;; ;; Syntax: princ object &optional output-stream ;; ;; Function Description: PRINC is like PRIN1 in that it prints its object without a leading newline or trailing blank; it prints only the characters of its print name, omitting escape characters from atoms and flanking double quotes from strings. ;; ;; Argument(s): object - a CML object ;; output-stream - a stream (default: *standard-output*) ;; ;; Returns: object ;; (do-test-group (princ-group :before (progn (test-defun find-escape (object writefunc) "Look for a double quotation mark in a string's representation, #\| or #\\ in a symbol's. Return a position or NIL." (let ((obstring (with-output-to-string (obstream) (funcall writefunc object obstream)))) (cond ((stringp object) (position #\" obstring) ) ; stringp object (t (or (position #\| obstring) (position #\\ obstring) ) ; or ) ; t ) ; cond ) ; let ) ; test-defun find-escape (test-defun princtest (object) "Verify that an object's PRIN1 representation contains escape characters, but its PRINC representation doesn't." (and (find-escape object 'prin1) (not (find-escape object 'princ)) ) ; and ) ; test-defun ) ; progn ) ; princ-group ;; (do-test princ-on-strings-test (every 'princtest (list "string" "string with newlines" (make-array (random 50) :element-type 'string-char :initial-element #\space))) ) ; do-test princ-on-strings-test ;; (do-test princ-on-symbols-test (every 'princtest (list '|||||| 'abcd\e '|1 2 3| (make-symbol "This is a string.") (make-symbol (print "This is a string."))) ) ; every ) ; do-test princ-on-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a01fe2232f8f9740b921dbbc1be6093400b1b074 GIT binary patch literal 4040 zcmd59ZHyaN@$Ih9_wCq?)!w=J*hcx1n?3Gw`6v!FS+Cb;$Ln2Zcb&UKp_OZIVkeI8 zYWq^6LWshV2xKKBg_B=O1phz?L5YNDXu+ZtKY}U{QUyY)gaiU1kgD(@Q2|w$dC%uu z)2gNaNbYXle7>1^GxOeFC4F<6A!`e#7b{h-E-x%K7nhpy@rAnFSXinTJ^47$ z7A5cKcDohYEjJeym8y5ft715(8$=+a{iW7GGH+^b+A`bE3Fn28_LbIX+Ej87nmVHs zaiD7jtqbke$nM?Bv@)gS?6m2U8!N#Jgh=U7P(*KDD!-f&Zq>wZ{wO2Ph9e=te}cJq za|6KM5BOY;MBpcKIP$|5kWm#-!2aLFdp_T{7=jpz5q1K=sSNWNFpg7IsV7?%hx#~Y zfDi%5poKDPe}RK2Fw5l#uFCjlcGIlf<#fTSPIYvRk=ZTPzTR$?)y>crvjiFbz<UjjJ{jm(fooRa^Bnyu+J)sPA)Obtzyf}{TXE$5&lW{d^`0VRu2Xp# z@CPpRKO~fIvHbwObJe(F1zsiOYWb2C$cO@{U43DE_Q9?Lkd+ZsEsk}*M}C6DZtY3^ ztF<=(W@a~l-v4a=!S^!1)^=sp_TX#;BJJktLj>@iJAj{unYnV1h=c8~v^GRF%S@!P zCzX_HCJfzH;%T6mGfq?-po5|xe*2*5Ls3n2wUlD(Zr+Bb)mYd2oq5OAv!VzRVLlc# zLs!jwPDxsJ)`?O<6yB}vT2VSIjnYAB7=}O~s@t|@D^}jk<=v<>0tzEh)tpxt9gRps zAm?{nTUWDE0Qdv?oSMxUy3?CII5nhoAT}87PL!w=1oYu(LQkrB!-YZPrf^;}7n*z0s7f?v{22wtI^5j+ovJhV+es@wC51E*>*(IqZg=b}X}8UxXg zqq|DN((+mGP{p!9BfEeT22N6O=Cg6jP*&$SGDpFQb?>GNe?{lm0fLn9N5BG3PS?^Z zs6#@O9Fl*H@mwFM!;ij9Ym#!Ne{BKAKfCx}w^)I**#CX%xXRG@x0zc_>UZ z;i_>KppXZ0h$+}`v{qJuBX%)#;Q(;fF-}T#Qc6!_C*6kZM^Mp7!}X>b#_HANASc2% zBn*(hft=6E>6jn#5+Ebp6u`mfaU=3AAo_bDkQSYMmQH<=P8xJ-f=+IvQ%R7L9tWwu zoNdjZA!!n7V3^%^%8YI0b96mY$0;kUAl#sS6Kjc;mO%FaQ+x|le0UWzS@Gw9j&cjw z5S;h}W&}p!I74~UNza&iLW$3_;K*ON%%8xPUxSL|)IR_k zN++SQbVo5QSJCI7!qCd^fHMq}Mu7%(c(;+?0&NhanGm{0-avDFIwJZT6iB3PoxP=y z@+-O*!ENvf+vMI6kQZqPIp3!-1UEVMU5p!Ye*|gY;I!*BgV+~n7{Ns@|2dAGr^csf z_!P~2f{xA7m`lfwP$NypK1MT-((#=%wvCQ&p+hw&^vR z@|JVz7P(U6PtkLZe7pcJ+|mRniEp%@Z$F3E$R?gQ<-Sp9q`{tQICL1qXpC3r&)Tic zZqG2c*0YbBox`RU&okQ;o}E3-Q|;D7EUv>O(m#Zg``Rtc&bL|H$c37`@YG4K*n|r~ zF7TiVwGv{{MiW+rdP(80`sgmX;dzzX3G~h@6w7k4(D3ADxzLoEu^kQhOrg5u$(4re zJ&h)sWv^>~LY9wu^~&+HT)xtj!Fs*fke{hE%dm0Hd!|~cdEie;_G+aby|Gv*dMvp+ zSELg)LN?DG3X={zXi{&7#ZCqO`Z`F)hew#C!s4lSV1Zky+XQ~#{c-2!cD}aZvb%Hh zp_5J;7I&|obko4aWw6Zt6G@~YNupztkB+xnk!s=eQ>6k%egCy7Nb4JFp0E#GQ&q1}Q<@6$arxxnJ-y`B ziXP%~7bPFU?DFG(f3<+C)bgPqxAgc0B3%4B()OrheFii%84y+pk;!7I_PjCiUU!HJ&~;FK_U5xW?hwK@P`# N@0=v$`nkJz{|iKQPj~cml>test>22-3-1-print.test ;; ;; Syntax: print object &optional output-stream ;; ;; Function Description: outputs object to output-stream (default: *standard-output*) with escape characters, preceded by a (terpri) and followed by a space. ;; ;; Argument(s): object - a cml object ;; output-stream - a stream ;; ;; Returns: object ;; (do-test-group (print-group :before (progn (test-setq stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte) examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list newline " " blank " " ) ; test-setq (test-defun printtest (object) "PRINT an object to a file and to *standard-output*, seeing in each case that PRINT's value is eq to the object. Verify that it starts with a newline and ends with a space." (let ((stringstream (with-output-to-string (charstream) (print object charstream)))) (and (eq object (print object)) (eq object (print object stream)) ;; Acknowledgements to Bob Bane. (= 0 (search newline stringstream)) (= 0 (search blank (reverse stringstream))) ) ; and ) ; let ) ; test-defun ) ; progn :after (progn (close stream) (delete-file 'file)) ) ; print-group (do-test print-test ;; Print an example of each of the standard types (every 'printtest examples) ) ; do-test print-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3576b03ad1dadd99043fca18e054c41c2630a12c GIT binary patch literal 1812 zcmbtUZEM?B6h2pu9ovarCwOc%qY(++im1YzWF$=otE$|@s%1&Nl9~nv#Y>dhtz!qj zY;ZS+6vYiNf*>{I{E{=mr2mD0Dg(3Ke*-+Og+p7T8CIp+Y9*Hv9q zJA3=hme&V0oVbOv5; zr+(+WSiT@C``u;>7b`2cEw6sMu)4G~pIujMJ&yL)ca~N^DX%VGn9m+P8j?Z>0JdSo z|1tmtNI>w5UyvMXJMy}wQ`t~zR0<9PKaE^u*QPA+rxwJ1XJ2l4UwJJ~XRikYAo$r& zue*loXr>W7BtMYJ;DMjh4B0|z$_51?eH?{HCxM?`SdbUxvg}Z1F%2FK$M0bpKTZ_{ zp3dXOlPWoEL;ugJuvsWgkrY3D)2~tDpB%uGn*h`I#!r#P;f?&r%;Wa&1O0)S{|n%t z@spXa3Iwkm{PF(g^s_)|fJuN+bGtag>sLys!l+RIAr<`Ue<-P@v8HiCaz!!Lbjsw* z8lD&%wj?A`sVPZS9JL}d>bMM zQaF)FhnYkMmCH+%F_X!r>sYQMC35(}q@);Ia&*pv1b(4>q7vx@Ksd(bPkxU<#^^Og z@8TlGffc92QB{{QYP?k6klf&zz96eAHjQDzi4_zgdzN0KY)iJ0xlYHv!GKANnHz?~ zS5ZDyEPu-2Ao^!vDRVpUKkj>7H0!bLd*WQ%`?}R^d*YzI-D&SM`^`?f-fG>s8Td1f z*XxV3ca>Rjw~jrrBR1Qyo%z|_v-3l8x|PKGSQA(ti`R(P&%$CJTQ;Xw6lOb&Dz)ck z3kL6~Z|nsld-Wjb=~8Z(Z!8Fz^xLJmVX&=cL~OC!9-#=YXJJ zPDY;n|B+t^r)vg%Bg&Z}NpYRtDQ&{l04NQ~#Wujq^-IOL=-9B$%0ES6G(`x1z=bJ7 zr6}BfWtX3h%ps7s=p+D;$OG6jfuD)W!Kaw8jKtEGX-Dm!$0nGmDOJjcqApveW}rKc zdsB`r0g3ZNQo2=n3i%O3wug-J*c=EGG0v+kuilmi`|*4x z-07=)EJX2=9ElPEL6gd5lQ{sn``N@fWLZ$nnuUXZO+L=16siQzGhbK^tGGsWVJ!GP pc*sZF85P@&H_Y=P8O;qHn}{j89Zv9T*gRKVBpRNE->w`T{R=g_0Ga>* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST new file mode 100644 index 00000000..0bc433d5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: terpri ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-terpri.test ;; ;; Syntax: terpri &optional output-stream ;; ;; Function Description: puts a newline out unconditionally to stream ;; ;; Argument(s): stream - a stream (defaults to *standard-output*) ;; ;; Returns: nil ;; (do-test-group (do-test "terpri returns nil" (every 'null (list (terpri) (terpri *standard-output*) (let ((outstream (make-string-output-stream))) (write 4761 :stream outstream) (terpri outstream) ) ) ) ; every ) ; do-test "terpri returns nil" ;; (do-test "terpri outputs #\newline unconditionally" (every #'(lambda (writefunc) (position #\newline (with-output-to-string (charstream) (declare (special charstream)) (funcall writefunc) ) ; with-output-to-string ) ; position ) ; lambda (list #'(lambda () (terpri charstream)) #'(lambda () (progn (write-line "This is a test" charstream) (terpri charstream))) #'(lambda () (progn (write-string "This is a test" charstream) (terpri charstream))) #'(lambda () (progn (terpri charstream) (write-string "This is a test" charstream))) #'(lambda () (progn (write 5 :stream charstream) (terpri charstream) (write-char #\? charstream))) ) ; list ) ; every ) ; do-test "terpri outputs #\newline unconditionally" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3c021f9cbdcf69624abc39230ca99372a3f1363b GIT binary patch literal 3099 zcmcf@ZEPG@@$LES+=uPlK}eHp>~3B1b-8tIHwlRo)U5a3*%#mKUUv85m;&YETj#E^ zedg|*QbH}Lgg|07#ffU|E3Np&4hyLPA1B>OUkDW_Hi^ zB^4AQglRP+wj~7#-fxh zZhCHVLT)!!l_lqfvqa%6x0uA3_gy!VE9;t_H+1i|^mVDq-ejQ>Qr#MLJf< zx44vy;GR1rnY4{!fgM=KY=X9u^8!CS`QHv{xF62j#GV_SDdaDiXP zLV)}m`yEkI-BpYS7^=PXf84SD9(wSJm-Zy3+Fd_FMDJ}BUN#1Q!PrLaTgKpQNJ2+9 z?i`#u&p@4Z9uLL%ONenUAaGY4BydZl2wV?%wSYGt@W#+g(&Dy~HMDXO-B9T?NPGl2`;e1U ztoh=UQBbzW1~D1NvG=2N_GhH``pH2l_ItzztrFMrDyn1DN{Pt7A#zdGOrzT-`vA#% za#KcG&-!BTi$_WNj-WI$5JPKX_&M>|GeWk+=aIT-%a*Iks;1&;y8it1lYGldR+|N z6epS@b4_Hfh)hXj&f{hSyS|+e$zvjYSR_X}PFzZf=3 z1Hx~B0$xI<%&#MtSq$gL9&xZx!#i7HAik$mL0jV;>Z+p z+gYI}i*I0VlpjDmic&t)+C%EWO&1oXBuajHv+oBL;17&%bk-{(m-lX81r?@1 zgDh~!!8FW39xlQx6rcz?7*K*sV1flUl;JYW!4;T?&p`#Q!U9ymfkn6mHK@aLa2=Ll z8CIYHtMFxLLJQik1~=e&_zJuLUxhIkhY5HJPQocT4WEHCa26hi5qJVV4Ts?f9ED?W z9MW(CGN8aHJPDI<4$i}8@&7bjfM?+I@CEoHJPTifoA5Pw5!OM*UkqYT2O%ZH4|Xwo JwQ~RdKLH|Yhfn|j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST new file mode 100644 index 00000000..7c51263a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: write-char ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-write-char.test ;; ;; Syntax: write-char character &optional output-stream ;; ;; Function Description: writes character to output-stream (default: *standard-output*) ;; ;; Argument(s): character - a character ;; output-stream - a stream ;; ;; Returns: character ;; (do-test-group (write-char-group :before (progn (test-setq charlist ;; 94 standard characters (CLtL p. 21) plus space and newline (2 notations each) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) (test-defun readback (character) "Write-char a character to a file and read-char it back; return the character read." (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (write-char character stream) (close stream) ) (let ((stream (open 'file :element-type 'unsigned-byte :direction :input))) (prog1 (read-char stream) (close stream) (delete-file 'file)) ) ) ; test-defun readback ;; (test-defun write-char-test (char) "See if a character read back is the same one written out." (char= char (readback char)) ) ) ; progn ) ; write-char-group (do-test "write-char to default stream" (every #'(lambda (char) (char= (write-char char) char)) charlist) ) ; do-test "write-char to default stream" ;; (do-test "write-char and read back" (every 'write-char-test charlist) ) ; do-test "write-char and read back" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a49afc60c0920771d0ee3ae22893a14946ce84eb GIT binary patch literal 6030 zcmds5eQX>@72n-Ef1T~iU2?V)Hy_(HA;~3c#dexFPD--3xAt9p-aYT`)d{qv=etes zob%bbJ2!~}rXNsRY1<|ZxH~C92nit-3MGh-q^%AKB!~nOf~pcot%_8Hs8rNS{86cb z@ZQXx?W8n8lz%`v`^|gv=Ixs|zj<$F&T&mgm6WK=&de1{c14_>ug%TZ#N)FSu{t|n z$=Tv@kc(#&-B3T5kd?8%1N{MWMNh6`XKQv|wC3$jvT6f3D~?s@(pzQcXm z=}c-;8m1Ipts7aHJ5B{6S|LfB30J8!7St$&VQo_{fo7m`lA7;)G83E6)0;qHFOaW-}=v zYw?t7NU$#`Nh6KynR6Rm0E?NzYj6 zj1~0-LAxU=YsVxiNAtc_AZs$=s~QRULdX~}nSNlxXj@Y!G4TSsy3sd4Lar0)zaho9 z1A>Sj^ZI_w(5K+@e)VoSh0F2fv9^(Z`X!NH!rk57Kt?*mz7&(aMFg zCqdRZE{~~_Y#1^%oMDCyW;n(S-^L7wnI(Y|;eB#D*brW!1B5GdfbeZPKzIaD5;j#! zit9>d940FxSWvwNJrU>`kvv}-brCxa@MqP(knab16J0pe>H{ulrd1^=rzlvYG>SK& zcwANtU0P|g2gEHSF+HQjsal9^Ms0!I0fc{(Y(er1vK7h88M51hveI&Yp?8JrgS7A(3+R#Tatp0K8k3SA4jb;tuM$vaCk+2iN z-=gT_Y1sfcgT(h+s_wf=`+Zj!ISXoQtU|FW!Y?ZZ#Omppso7E=8}c}q?v&$4GNvWR zQs}ntVGylKYLEzEA=H$L3ytyxaIM|649EwPl8_CQodMkrPe-zjrKy2^%#A+w{Y{hz zeAFH_vf$a+R1jI@zE zQKgym0pUMj2|X=dMGeWQ#FF|wNy?tPdXriA5KaDOIYFwDJ0O>uu@ z+#6mHCa~)@Cc8=wAomjzLGnYUe~EG5BL`9VEyi77nop2!6h6i@A7$J_mWI>lk{vSLt9DDW^%BX^z4Gc{=Dl9pR5#Xwp6WEisc8y{H$Fq zZ>x#fd>&9-Dwgfzww>Q4o-E*%f~lgEDx!t^U1yVJS8L+t1$nc0JPT@hu~=r829zyq zMYSD^zAh+*PzcjNCg9HqG%sBYIuYmqE>#|fiougEpFnzCr?-@ynaXF;+>K=eE)-tb z5W*PrWpw+A2<7dp<5RVGE6^s`at2%ro^kfm?P;HytJu|Qakd;NWUEk(#3?(Ft%)T& z3$v&dij~@FF;~b|vbmaFsfwl9@&hEqaX5>ui+qPS3pk(Qt%e-Bxtnl*Vbu+)dJJ6S zd7?5~w=W7U>4}D!FwFWEri6wm-bZ4v@aWLGj}9w2^q&N>g9VapbQ(&cw37Ie*Igeg z0;%gF5dJt3NU;d`-glpK&*M30qXO`O``!(QfE3&T4LN0!c2FZjENA}3b+)X)GHq7H z>3IqOTddAcvF!jM_Wg-`63G{y!pi5XE^@oe9JlG{;Rq*3gjmF1Ph8~^SB1n?KO7dZ z3(t-bE)fv`>~wi=iVy&Zk0Qi9?{l4I7I@b~txHkt+XV;@!f7oH_hzPW*A6ng4y4Uy zCT6M=94{{N-QWmrEO3VY_j?_&Be1@cZ-tJ&5WVaOZRFL6WWQ= zMB3ZLBYFvREsKq8MnTC@8w+JP5?d#te7?sZ;@oG%4>AbJ;nF6Xs_OlwHnCO9=`jki1rebS8UR zEMyWg zGI@FWaIl_)Tq{6=#5bgjHVM}y2~Ka8s#tKN5qNOnen2Vy9RKLxz9GI9zP@%8&d}@* z<9);1J+Q>RkjK2u0^1g>(|HCJr~+kaevYjd?gMK0A!@G)fv)lb78N8)8^Yn-W8wfKGZ4Ur~(^zV-f?}bq*m?Un7Ssh9>s(f(_`t_6L{*3DR88Av zi=6fFKv%nFmqoe<*wQnk(5ft!XKRQN)_q6WK1mBUtKc`Yu~gUTiR&MW{JQD%VV1<+ zJy!@#r)9=mqlK^grfCfx?gS4Og6piJuwbbR!QnaqD#0rv^8N_TQL1bxi7?sQLSXLP zlYX)n2sHWkSOlqGzgyA%DOG$7RW7(rd2;1RCR-MlOFfqPEIX5Ir%`(_TPbFz8b=z~ zV5QOynnB=cG%wLe6l>yCHh1CxED=W{;b$`EWY%qQ^I&QYY@-&INTVZAmVfD zC=JxZF%ZK!UXD}MyMXiSX;s_KdN)w=?5Z)?W_}z+Li-WxNex~B_Cl*Io-|;~!DSRT zcOavg$x#goKM?k0m09q+EA+o1O_$JqBuNG(K sV8L^+_Yhtmup#tx{wvm|C+~}_-Cbt1>ky+o{_7JwcL9yOaP8VZ0TJ43(f|Me literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST new file mode 100644 index 00000000..88fc2811 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: write-line ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-write-line.test ;; ;; Syntax: write-line string &optional output-stream &key :start :end ;; ;; Function Description: writes string (delimited by :start and :end) to output-stream ;; ;; Argument(s) ;; string: a string ;; output-stream: a stream (default: *standard-output*) ;; :start, :end: delimiters within string. ;; ;; Returns: string (entire, regardless of :start and :end) ;; ;;NOTE: the test files for write-line and write-line contain virtually identical code, and changes to one file should be made to the other. ;; (do-test-group (write-line-group :before (progn (test-setq simcase "simple case" sclen (length simcase) newline " " rand1 (random 10) rand2 (* rand1 (1+ (random 3)))) ; test-setq (test-defun readback (write-line-call) "Write-string an expression to a file (with variable write call) and read-line it back; return the object read." (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (declare (special stream)) (funcall write-line-call) (close stream) ) (let ((stream (open 'file :element-type 'unsigned-byte :direction :input))) (prog1 (read-line stream) (close stream) (delete-file 'file)) ) ) ; test-defun readback ;; (test-defun compare ( writestringcall writelinecall) "See that a string written with write-string does not end with #\newline while a string written with write-line does." (and (not (eq 0 (search newline (revstring writestringcall)))) (= 0 (search newline (revstring writelinecall))) ) ; and ) ;; (test-defun revstring (writecall) "Reverse string, capturing the end-character that write-line may have added." (reverse (with-output-to-string (charstream) (declare (special charstream)) (funcall writecall) ) ) ; reverse ) ; test-defun revstring ) ; progn ) ; write-line-group ;; NOTE: not working in 18 Nov. sysout; write-line returns the substring, not the full string (AR 7023). (do-test "write-line returns the full input string" (every #'(lambda (string start end) (string= string (write-line string nil :start start :end end))) (list simcase "string with linefeeds and spaces." (make-array 25 :initial-element #\newline :element-type 'string-char)) (list 0 (random 5) 2) (list sclen (+ 5 (random 20)) 19) ) ) ; do-test "write-line returns the full input string" ;; (do-test "write-line writes just the substring" (every #'(lambda (string start end) (string= (subseq string start end) (readback #'(lambda () (write-line string stream :start start :end end))) ) ; string= ) ; lambda (list simcase (make-array 50 :element-type 'string-char :initial-element #\" :adjustable t) (symbol-name '|This is a symbol.|)) (list 0 (random 20) 4) (list sclen (+ 20 (random 32)) 10) ) ) ; do-test "write-string writes just the substring" ;; (do-test "write-string doesn't add a linefeed, while write-line does" (every 'compare (list #'(lambda nil (write-string simcase charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) (list #'(lambda nil (write-line simcase charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) ) ; every ) ; do-test "write-string doesn't add a linefeed, while write-line does" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..026dd6325d34419513d0f8817aef0377d0e20dde GIT binary patch literal 6038 zcmdrQZERat^}T01A5P-ft(&x_ACInGJGU=1N!O3GV|jjliQU-G&U??z0%OCmUuLJS zli5zYvaOUMI>8>@(rMw{eIO)$07JkwF|lp~OCUfM2!S*q(9k44q#=gb#E%ICsGM`J zoj4t95#tX?&p!8@d+xdCo_p>&=iVjGbDNS7mHCqk#gbJK=ND@Wi#2g}z9LrV7b`hS zoCUgguaeT$`(v^)F>qwiYqa#_Dps~;h5=R3*dI2sR_u6&?+AryiybS(6u4P+b&C}97~>~wQB)~7bY`f^+8CgsF> zsRz;R^^yx1-XDq%9YhL$2dp}>eL~RP_TT6+DQ@-zU+*0Aely5@d!8A+HY?=x+jNHL- z-C&+#Zgc%v{_99=c(7}+>A@XHo!W^1rA;8RF%nu{5B1v6T*-r5E1*M9Z7q39K|o(A ztw$WB|J!QyGqrGn7QGN{DCPDymFh(5)W*^fsKLI5T19U=r7$M})lip`yP;aJBvRFS z{`;yu)Kskp^g(5sKb)%BMu<4LeuXePyEEt*hu zDG~>YHg1H4PSPoKz^@H{9tfF%up*mEOwv^|qeIA3Xv}OgrVUd~3IcEhSx{9Hs;p(w z(pXAQ8ezf<{5waRsW9nsb&*b2H*~fe@uVUf>PisC@aghGaP@^%T~Fy!Dr2TIX4vHe z?(VRxO-q!H;$6K!^B6FzM*J>6iqq7oL|jt=4Pc)RYa0Y)T@x81e#iC?UKQfIz=Mbz z zVX-ng3$jdjazqX;q2K3F<6T8p&IboRk$k zCAG@j0Oa_G5+vJ=6Js3@sq zTGqk0f#UipWq19M_PbtS-~u?{db3chituGcuUI{Ea%R3Xz=oU$(LHkXSjI5rNCMS% zeH=)=aSZ|iY=oLnaifubAE?&FiWW(U$vV=`0B?7LM>40=RKU$ljlFFCEfffUCPOel zc#{kx_&pg!@I2_YuC*GH#`RPtO;r;!eej{G8)|lq$OF`F*NgJCS{_+!YJK+;T9me(TS0^pE2IVK!|~L478J*k;P30 z0Pufh;E&`WVy`mn7vvCPKVg3LBZ4u6|1RtM76V^q;0p{qMrHCBVL2VTDn}zwL(L1EPv-0LI&g1O&OQQWT?_FBUT zli2lhM!QUoAoc4nT*VE`e0O6NP@&HQ@%s@*Cv!2&l&M zL}jwJEeq}G$)=b9tok~lgr+FoMIx~As8IjAo0Z)9pBS>cHBeAf5~YJgSF~RLo-B}9 zV}aiHVu1v+fa`7N3FlF)gtjW+K5*l^sticLEl`&e2I&Gea)?FE*B$%DHEvIlsyMeu zUBD8ni!lY>Ge=&r{ubFs@p?6MmQM(o1+ zG04S&0=PTf;A{E_xQL7Ti1Vn+vD;XTbsB!_P(OCDyd6)b;qJ^BZn=q!Yy!`3GcplF zo#c3NnePKd@MwWD^xxe$Vm#%e$IG#ItRAY>*44+0XE*P5C6O{Rx=JtJ>qtWAB8rDZ zAuMl(TEvfe5pMHQslmnrvGew{smC(f#C|l^hw1K+$rjru96P+m_7$tPSSiCvEWp#n zVyOhj9UnAS?H{A|7v8ww1(CvU9D5h*^PVo&3Zf`_n_&u4Z#fSHvAU4WSyfCN!mpOO z;OJ-p>>bxFQYAd&OLK0qle^8VzNY^U_L?0ty7Mmf(Ccdqyl| zPgxkotvnT3Ugi%r-L?)@cQN*lpimF+{2GTnu?F+40|$nS%k@H&0GYGl!SDdnNkfPt zClbOiI9@x{4XSRac>CE#3ubr$N=WHcT!WL@xMiSIL-6N>-OGGv4&2yR*J18U1*&EI z(%h)89*1}MHNmnI2nI8#+jxYr0gsPIwnQ~YfA`0&BQdo(xDdp$#&Lmz3)1O2eF|iPvb4Cs_6tt}6?~4$^PsD%ynu;Cj-+%GJY@%&=_501 zoS&9qS?2Y$Oj26f`@nRB0cT~?(2flpxQRXvVfH7tv5a<<_Q zbhm3(S)^xR&3VEUE|%wO=p(HAhO%{a(ma*-fo>DqAULXPRXV9I#U9CK^HD zfiy2sOB8G3Og4Ao2y77sDSGtgXXdONZd#U}EdDdgya}P@-99fEEWmT^e?O^@#|O zp_-SY655^?iy1^c7ifdw+K2mkEw(AICfXHcya-@JO`%_ n9qeyx2(8h7%-Xd6eu}j>lo{;1mBD`Z+7Qn@jzYe6<;p(+C01>G literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST new file mode 100644 index 00000000..95543859 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: write-string ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: JRB - 9 March 87 - Fixed bug in rand{12} selection ;; ;; Filed As: {eris}cml>test>22-3-1-write-string.test ;; ;; Syntax: write-string string &optional output-stream &key :start :end ;; ;; Function Description: writes string (delimited by :start and :end) to output-stream ;; ;; Argument(s) ;; string: a string ;; output-stream: a stream (default: *standard-output*) ;; :start, :end: delimiters within string. ;; ;; Returns: string (entire, regardless of :start and :end) ;; ;;NOTE: the test files for write-string and write-line contain virtually identical code, and changes to one file should be made to the other. ;; (do-test-group (write-string-group :before (progn (test-setq simcase "simple case" sclen (length simcase) newline " " rand1 (random 10) rand2 (+ (random 3) 10)) ; test-setq (test-defun readback (write-string-call) "Write-string an expression to a file (with variable write call) and read-line it back; return the object read." (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (declare (special stream)) (funcall write-string-call) (close stream) ) (let ((stream (open 'file :element-type 'unsigned-byte :direction :input))) (prog1 (read-line stream) (close stream) (delete-file 'file)) ) ) ; test-defun readback ;; (test-defun compare ( writestringcall writelinecall) "See that a string written with write-string does not end with #\newline while a string written with write-line does." (and (not (eq 0 (search newline (revstring writestringcall)))) (= 0 (search newline (revstring writelinecall))) ) ; and ) ;; (test-defun revstring (writecall) "Reverse string, capturing the end-character that write-line may have added." (reverse (with-output-to-string (charstream) (declare (special charstream)) (funcall writecall) ) ) ; reverse ) ; test-defun revstring ) ; progn ) ; write-string-group ;; NOTE: not working in 18 Nov. sysout; write-line returns the substring, not the full string (AR 7023). (do-test "write-string returns the full input string" (every #'(lambda (string start end) (string= string (write-string string nil :start start :end end))) (list simcase "string with linefeeds and spaces." (make-array 25 :initial-element #\newline :element-type 'string-char)) (list 0 (random 5) 2) (list sclen (+ 5 (random 20)) 19) ) ) ; do-test "write-string returns the full input string" ;; (do-test "write-string writes just the substring" (every #'(lambda (string start end) (string= (subseq string start end) (readback #'(lambda () (write-string string stream :start start :end end))) ) ; string= ) ; lambda (list simcase (make-array 50 :element-type 'string-char :initial-element #\" :adjustable t) (symbol-name '|This is a symbol.|)) (list 0 (random 20) 4) (list sclen (+ 20 (random 32)) 10) ) ) ; do-test "write-string writes just the substring" ;; (do-test "write-string doesn't add a linefeed, while write-line does" (every 'compare (list #'(lambda nil (write-string simcase charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) (list #'(lambda nil (write-line simcase charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) ) ; mapcar ) ; do-test "write-string doesn't add a linefeed, while write-line does" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e0b92d1b16ff0245b30caaab2c8bcc90343476bb GIT binary patch literal 23983 zcmdUX33yx8mA@9twq#k}?IaNLvXBJFaxB@76D1HUwwyRPRw^qb?4#I9Y@*mkc1S{q z3e;?^8rG%~YX{oWPRjsd28IF+dx2r=Fr7k63oW$JDKjub%al@v|L>ghp0+0k_&2k6Ry zE`PvxaD%t&ZEelA z9`8V(So>6+Hcv~d$JO3!`{bs>#>z2+!7ykzLWR{}s5F=jiEHAOjX~c)(Am@5=X3UZ zH~AV9S1017Xp3{pfG?1USGkqRv2kZ4d|o(0&DlL+Fd7VrtKy|STl%|#z5f2hwZ;pL z_QaL(^4@;uW;D&a-e)kCs#eIlF%h@9-Og70*W(Xt@&*kz9ab(j7-o4#4TgEAu}2RK zKX|h7{!!z;hfX$a?VeL*EFLCD%MAv#xb<$sUo(ktSvL7{ChyFqrp{&BsBuw7GIe?Z z^;CBuqO%aOz5wyU;q3n&gb&phmn=07-+#8_h~EMD-qn3q`W=rM3|9|d=69TIGNM6O z-_@|Shgw0OQiH*6FdP{f+>jjxlU)l#X@Oc(%b1wk;yR|~w3vLGIiJi`nom})Dq_yW z7M*ibA>yS>-2HJzGBvJ~`@hsNMK&!6<+^qt2-oR|shFNL!laz21V!pVR-o4ENsUYz zEy~LORIN@dJ0)i_0g67*+FmAgmS(&~+b_})Q@iw}Q<${-PZ`yemr0}Mx3g%H;kh(5 z!?WeGn>uruZh1{>s9hRRp7AWx&@7_X&}@?0&<`@IT0@t-kVR7)nnP0?noawkX{a@< zHPj{z%^A|>;|dW=n3$csx87}fuYjcK6(;6S*QSRHlW#9fK2(^zhs^jgElT9YF^1z)%EY13V`G7FDf;delm=VAEW#MUGBh$&*XS+W)tQ>Df+ z=W&dG&^Sf;oR>9@C7<)4#wpI{d_&`uI7m( z6mnx=_>-n%%jdkRaUA&^>0Q{W$me`h)2Yno$O0ZI${H3?7T*1r42iq*TEFA28XYUO zPE2PTkR?1)6e+^;N=bo*HziAWE-`y#eV*%?n{KRs)<&U2+EKDA%V%lGu5+?TvsjE8 z6)DM($@!Ucs_bsfsfu)Mna;TNZsVrH`!UkR;l`nyg!0VG&@Csz|LPC4WQht zqkK7+lG>Yx!+Cfh4}0_Q@`x!@V`^SDx@olNpEA5c!I`+a zVUrNfVDKK*f>)CpywtYbu%!65E-O>o^7spKao+gLbp6cvUb#~9UDo-`4fQQNOJ(p( zt{#<-Xtl~-Hd9M#QC_urH)hh2st(N&S^G1N=sO6I^GjCDOy{Id%*&FL z-1=rDwAoYc4>I%__V5MG!#V5_4PW|1O0t7>_EC6pbDP$)K(jc#1gGZbYFZ)=@JrHs znGj|!5o+(ynsW@gmYhQ1Xm^l0KkbN`m(QlcdeUY+X*HAJw?o}xJ)2s5jyeNAo0`2# zySzTqpj}FyBlo&dCh1BTUE|hC;|5g+j^JiCC(t^yS zLPSY%xJ&Z|PbLww4dTPlZb(KaW z{nW`UhhEOglXi^;a;CbJ3_;N3|Ns9Uzh?NZ`a;L$R}WW?R2oe46JLuT+t}sr@9qua zVT5yox4*m37jUlY1*L!eK%+@XT21rtIS!8~Y>k@(z5PLFpYIf3U!!R*NRBkAe|>O6 zqv=?P9)r&ud}iY_3!esj>hY<=rxu?Ye5&!O!lx3S3Va;+*zmFAQ-)7DK3056@hQf~ zf`=_tja}Yg*9K?67u*uS!;&t3+EP4l>Oj!9$z;?^1pSRkn|VRfYF@~$`T_xe!0F!- z+`J{&XkG*bd!x7iR43C18k2a^QtfWfe`2%1Y%nB?=s67@x)}eKp1icfT(LZiA?T*6 zyS4-ZJ_INIEGTIt-hA+CGXd`M4)~{m=zc-BNpVPu^Q9OTk&vLEpiP3jf;@s6q^M2SQ4K}OdKC3PW|8`5 zm{1-S$*5u^yJ7gWKh>K!S5$HuB&VPjQ) z%OX{`BPNx>Q#bpZU47nx4eFqojRsX67Ktm9#}e9~Jcf#(*!qIl@`^2~u1c-W%zBl7 zVadw(1pQ9X6H+|N>Xj*0uas`Bly0ruFA7nS^h?nv3Ts56N<_+qXJl0IXGRrLUxn0H z@uUzRWA%!ASiR!QqVOf*oiAuY&}Jz%iNcAZU>6aZ9cyJia(4Us`n-VwXHTEs8%$EX z9MZdv50Y~U{Tu5zek~G=JmdQU%-pp z%hc==smA1SRP%g6a|B7O9OaB`e`cQTeL?>!=nX+X6ZDdxrvyDB=w3m03i_s?n*?1W z=qrLQ;MUl-avW_zZjG&*TVoSnY~^T8g&IfSw$1*2Oz0d!ySQh6KRFK#v5R~5Hw1}$ z_Ll_7aIrrqNG1*Y_XXX?4%u%MbhV%_3p&8=*-v5j>;vqcy^Gzmmx?4Uady?cOpwdO zx3c$>^j1LGJ1krF8$rJm^ix643;L0u9}2opkPN%B+XdY$ysrz23%W$m`GO_{4YA*4 zYuWFzHSBj;6Z>8MdzLJJlX>MY33^u01A_iekVK~ZMnPW@-jtwo1hyK??*`3o2t|{fLqE4}#tl^b0|f_Es5_R!J%Aox;0Zic7d*);-)X>qb%U5?-sI zCP9jz*^Elxm*PEEFMXZWOD|%P(({EUi({!Qj-}GRQfXglw@98SlG46XX?%a*M3x7Fo+JGAu2!idiJtEwYGOBm@=-fn~QCJBNGBavJxTMOHD3tYVfLsn*Vt zMV~M#`ja5Z`69{rB5|TfoG5xiB!4K9vY9H9%~X*jd(lN)ZPB@0ZP7`h&>;$qf))yr z?k|$=FETOD{1Nla5(%?J!u+c6ej>ad33^!24N@eyTJz;xt$9F1`h+KA%q(Nf+$6l? zg*RJJwIJyZlXQpaedd|oVV>!AL9Yn=KAD_? z7K`32K~;jxjEu6%8)els%BpMpx$yp(C5=xCIwI(LDZb857%yWdjAw|*7U9XFXY>k^ z#577`8jFQ!W_82+tZtAg)^H#54BusAhFb+)C+MrmS`0c2xO0*XgUQ-ck`35dAmj)) zhC7D(`Iyyb)#Eh&PCl%V9eOXrs`g#>veMdEM0r$ zx{np>xC7m&#`OfD~(4q-KTimT*x$&cy1Sg0^u{^*j@+o)C1e6t^MjWdj@h0o>Nn zrUu?teFL5?45SI#?%|*p`m{@U(psS>C3-JU&bGUFkB>TFQ6z8#s zW4G|m;=*>JY?k&&v5G}(EyA16h5d`NVVRU-C5zaX3s2#qY*_XNXG$@jMapIg&&oyl zFAxuF*9LFE+ZE&pl|PYeL2SzJkm74n9F$^^3+p*-$r@r4)&Li!KVf3&vw|MtqIeW{ zMA}|S8#l$5{f~7}L2Ny*eyN7?~{o4Qd$M_tU~$P@MLlY6%T?dboqvHBBzA=ZP*R&4UbOlcTNsR z!(k;dHW7|aG?U0JiFmO?DB`;h_i+S|P-Fi5n8vn$Y3Lbp?FhAZ}aJr)qrY z)7OhM_x24WZ6t=-{0m$BK_6#CLnXqf_We0~CMHLAj0}b*N5)3Uygk{5qW-x=yj)Qb zeePGHJei0)Vy+fX=Nh5Ls5k2$f}AF$&<#QTy?B2Za=BvPXLFiC68n~jd2+1XpcA_e z9RX`OQs}XAa!qoMjD0B)uT1+ETMeJZyZvmBL`jw;qsT9kB!gLk!w_V#v|vb@nzhNOZ!ZtnoIvPEyvaYjWeetEu%Q z>i)VvkgdgLx_pl=mze1C9lBgfM|yQ{C*pNtA?E2kpkPon#Rg7_9c1laewz8G(ATQA zPWgwQrhH%GTC+GJp3%3sdQZlzC*P;K2VSImDs0bh4=Hm)p~>;tFrWzojozCPIm zT#<;+%C{FgpkR)YfJSvaTsN4A&sBREbL7wn4V6&D8QwP@4NpwSxT!l^x_eO~uJlfZ zccZ(JPfe6|^mSU35*i&+6xxiiw-|!mA{SeDx-yFSB(|EIpf481watouiW2jzj&&Y@ z7?@-vb|wj))f77zJCkh{C*pH-b#is6m?Ucdm^_b)-y_T!K{f{eSmKu=@z05PSw@06 z&j{yX3`CVf-ZJZcVcm%z9w_+r!|0?E36Jia99B+L+Nr*8CgM)az-b=+D&a&-h?tPG zsHz5$N$GGRZrKrvOoRy>qTzZv!`NypPGOO`1a59dHjIQu6--?uc|jt6TRH+F}{>0MouFs^k9o4CpHAPJEpP{-gT{6|SCF1p3GKD61)jf|| z!n1E}3ujTye<0(smmhU;QHH{k;X(ZHgrZ;bTlA)XG%UPa*3U6zoEDCb71Vn%5ii-+ zdy2Aegp#7>2{bO&8Bk(aECakm)?iX!8{E)4pkPfo#TN(;D0l)BI92KMZ}kOeby3nA zDJAGvwrt+)3n;mCvW%5rZE$#GLcyp(8z(0e{4NDUwr^~2I68>ND}xxrAv7q8hak$H z@o`+_(#cE;eTJEDY0N9${Y@giNX&-DM_k1a|-qt+9HJ+EQ&0WjH?Mq#?8h8xMs)Ln9_cd;-VcuO<4kWaARY1S%PM)iFq+{ zY0a-OV?Pq>Tnh+P{b3?*)igVZ@Na3w>fhxkR{thP5lNb>_+y&Exl)UR3}FwFRc-at zm>6POtw-{e{~l|Ts!Y0f=jz^(t$SD(pX$rdd^J9kq3vYgOB|Q#J|tgAwxUe-5stMs zt?Udk#&EW(e1!?lJb{H6r6jPOjSPw@g_5)SSnM2N3zlN-ox#CaM`w`f)kG(aL1jom zMk_m&VUkCWD3B*{k`4~VRt3W`mn*m<=4uV@#D+Uaa#erOwXX`1*LHl9Baxx7b2Pj+ zGBQeYY}K#0rBxVKJ8^5NM8oIqL4r&uBN(t)Zg=k4jSV*q(CuMmY=<(re>|+v4QZ2N z+m2t&jbOBeFvgMiSd{mUVEV_boYvDcvTkc>_Nuxj5s%RAX>NTJVOn7`+PSr=x3{0K zV!1`;I`! z8}ryeGffCpXXq0GPTRGFr-UG}UP%O`pF@5TIia*Fu~>|zvMMVUd5wx&npkTL6Au`b zpI{@eG29R*>B zjE`ZbI)Ey>r8=8t!A6hTE3qrns#^?P@o^5j0ujn#BQW9(DOX^;it91feO~8H1t!4R zsy7(R>`P7%Djs03DlSdLmvJj?Hg)dFDS~78{i=dBdK1Q7Xg>{;iZ5beQUi5-%-s?! zBy(OO-Y8~s%&DM|#u)CK#p<+1x9OYNo7sC0jYT4%=!A1eWDGZ1qdT4BW7u+%!#-(h zX(GPdTtAbAN7Irr2NK+?S5-M0|0YIM;dnxlRyxZ;U#(G|x15=HZdU3D*7 z*5c9>TiQHnE{PXU`MOU%7gsh+0jeUr$ye-KmR1Cp#NSOTV(0%kYP7wUR{WPNMK{`m zu+oUlzET@PZM3~G)pb)X9q8E}XGJKGJc&2AX^PsF%A_+O+e1^{j|Lv2D{S83Dj5|; z^qH!dzEYX2_`Rvl-ijAV@f)m2!6!xT1Xj#kDJqi{lT#;s;}u$ZY`A6Ag5z|nQFS7g ztmt#1W7O_&avLw3I?-^)A4zfF%ng#|u~kj(CRY;%#(EE~TY*}emaGL~QJR2Zb36n0 zdKxjdvvniJwi$;X>LicT2HbX!PL32BHMTw;H8!N;(#)vApCQ0Bh+)(2S%wQ2hRrIE z;%aua;EJ-}Ry=iJ;AeCSZbvR2MH3mQYO3SL{%%?m$yh+s<<{zStEO9?_&;Q8hI- zXM$cOQ$E#~It;)ib5{)lIA}&%CH)$wXFsV=xmmcQei)3*! z`k7^ah7F5?DPsjz4rPTDjG9;AUk9cK`69G}?qkbdy3|CcvSrV3$HNuO98MI-Eh^CQ z?XsSpwnZuVPeb3ZtRqt;;f7ouD>b|~{I;`w^ zxa-2!AQN&GDO`F~#0AM;JGJg918ZJRA>s^I(_2kwAWYV7DdgMLzKV1&(sI1)ymXGs z>VVaSQ`$qSm;$JfYtbCja=h%X4jZcEri?Zxo%AmH=ii;!)ZNMA*or21kB7c7{Vr)# zFOlYSg%5LkxVh_fnO(LrbC#cdLs8bo>0JI6`jd}@uwTX@sFTk;u@lWY$I9GSm%o09 zw({lJkKIl>rOSXrxf~9pVBvjYpAE%p>}u_4GoR#gNf3&xk04|@m!=A|L8~o$ADvzAtgGt8&{)yc5lb=ejC+S8pSyd zS`(N~D%Qy zq&?9KbmG)?_sHm;3H(8=JyEG_Fr=63z=Oq@>P#U%#^}P)@J<|EoQE^rqnbh|9n}=N zYtGRvSdVU@1cyz6p@m55p`r)nn%|YO3bx_pA?q7k+0gGQN^e% zsM;>77?`=Wwq;Zwm`1ftRPW4JZOy3u^)#xjqWU$=TRCk-yC<+2;>KdtDd@3VbPwd~ zx>%RbS4yzD6x4NzZYW>3g>~IrFH*ChZj0!y&ui`~R&8Zf%m?)a`e&7B;`}2g#w%Hq zhh53M!kQ~ZvnEfogEiZ^PD^3U4%RIGFi(?{Nlv?p@yxl9w~|c7ujOfSF1g)QXYr2< zYf3H^Kar=&snp7yT8y1fp*kg%iociFFPup($%o>b3ad&g6=NGypPfpQNwk$Fhrd)< zS5m2X;IMg7=lvV-=ZpsM2lI0NmdcUg4fJP`@Z-B`{7BA(-=EQ|_cgh{KkEtjH_`9Q z%t;LHWAHqC5VKmL=Z0pZ!H5?&OS<~}16u+Tg24_liG(3R$sjO`e)cV*_~udlR?!K zp8Czstu5Cv%SW1H7Hm?mgDGssf<$e|WxCKbx7s|*n`tZ9oD{GkL&1Uxj!_hcsszxia@fy&j5&2V^MXb3yu-MqW8Z0F5@1t=R?&S+$5Irhmz*v7 zrM|*8Q9{pS-vt1Epg=xCY&yk{CXs$CEU2Jf4-6mSt+T@L9 z?lr}wRa>eH7={t+n*UqJQk*iaoByb?%c$0kJA_o7)>sPEyqOY_{Wi#qyVbg>HL zccW9wl$i`J_;7W$rdgr=9Kt?Ea*E>=}=E1KW;QqAqU zzBeUs^QKO?naS349e2J7JIX?nZSG=d!VfrPl{VpIVwyDIn=jKzpT0z!I%S>(xA$7NlJ|ZdxO?M_rsvIA~K_g}qUJXLqn4#!qw{b!9f<$T=@}@KTN_;Z8Tt z937Bilo;R8abm5a^HUv%jzUT2c^ya7c~m!}i^l!>?2t-s)n$kAS~Nq=j)B~lQ;k=0 ziWs*cihW~ayOfZ;E2rL*yH~mAlY9Nxp%h@p2AGQ{vQ^pK2wos#29}G8Y=$b2^&zLS z1>s0|d^j{Zxq!8h7Nr`6D#xa=kQIlnod$HIwsM6g21iDqZTN^AXuw38Q|D5xh7+hx z!#%lm8tz1YWP83e=JAT;xAF`rie`xo-JFCuQwiC;KFby{7MSQxa1%x{+_;Ak>m1-)s;+k_aCML>TEST>22-3-3-format.test ;; ;; ;; Syntax: (format destination control-string &rest arguments) ;; ;; Function Description: This function is used to produce formatted output. ;; Format outputs the characters of control-string, except that a tilde (~) introduces ;; a directive. The character after the tilde, possibly preceded by prefic parameters ;; and modifiers, specifies what kind of formatting is desired. Most directives use ;; one or more elements of arguments to create their output; the typical directive ;; puts the next element of arguments into the output, formatted in some special way. ;; It is an error if no argument remains for a directive requiring an argument, but ;; it is not an error if one or more arguments remain unprocessed by a directive. ;; ;; Argument(s): destination - where output is sent (NIL or stream) ;; control-string - string containing directive for formatting output ;; arguments - Parameter(s) to the directive ;; ;; Returns: Formatted output (string or NIL) ;; ;; Constraints/Limitations: (do-test "format-ascii" (let ((w '(a b c)) (x 'lion) (y "elephant") (z 292)) (and (string-equal (format nil "foo") "foo") (string-equal (format nil "Look at the ~A!" y) "Look at the elephant!") (string-equal (format nil "Look at the ~A!" x) "Look at the lion!") (string-equal (format nil "Look at the number ~A!" z) "Look at the number 292!") (string-equal (format nil "Look at ~A!" w) "Look at (a b c)!") (string-equal (format nil "Look at the ~10A!" y) "Look at the elephant !") (string-equal (format nil "Look at the ~10@A!" y) "Look at the elephant!") (string-equal (format nil "Look at the (~:A)!" y) "Look at the (elephant)!") ) ) ) (do-test "format-S-expression" (let ((x 'lion) (y "elephant") (z 292)) (and (string-equal (format nil "Look at the ~S!" y) "Look at the \"elephant\"!") (string-equal (format nil "Look at the ~S!" x) "Look at the lion!") (string-equal (format nil "Look at the number ~S!" z) "Look at the number 292!") ) ) ) (do-test "format-decimal" (let ((n 3) (n1 -3) (n2 12982298)) (and (string-equal (format nil "The answer is ~D." n) "The answer is 3.") (string-equal (format nil "The answer is ~3D." n) "The answer is 3.") (string-equal (format nil "The answer is ~3D." n1) "The answer is -3.") (string-equal (format nil "The answer is ~3@D." n) "The answer is +3.") (string-equal (format nil "The answer is ~7D." n2) "The answer is 12982298.") (string-equal (format nil "The answer is ~:D." n2) "The answer is 12,982,298.") (string-equal (format nil "The answer is ~:D." (expt 1000 n)) "The answer is 1,000,000,000.") (string-equal (format nil "The answer is ~15,'0,:D." n2) "The answer is 0000012,982,298.") ) ) ) (do-test "format-binary" (let ((n 3) (n1 -3) (n2 123)) (and (string-equal (format nil "The answer is ~B." n) "The answer is 11.") (string-equal (format nil "The answer is ~4B." n) "The answer is 11.") (string-equal (format nil "The answer is ~4@B." n) "The answer is +11.") (string-equal (format nil "The answer is ~4B." n1) "The answer is -11.") (string-equal (format nil "The answer is ~10B." n2) "The answer is 1111011.") (string-equal (format nil "The answer is ~:B." n2) "The answer is 1,111,011.") (string-equal (format nil "The answer is ~:B." (expt 2 10)) "The answer is 10,000,000,000.") (string-equal (format nil "The answer is ~15,'0,:B." n2) "The answer is 0000001,111,011.") ) ) ) (do-test "format-octal" (let ((n 8) (n1 -8) (n2 1000)) (and (string-equal (format nil "The answer is ~O." n) "The answer is 10.") (string-equal (format nil "The answer is ~4O." n) "The answer is 10.") (string-equal (format nil "The answer is ~4@O." n) "The answer is +10.") (string-equal (format nil "The answer is ~4O." n1) "The answer is -10.") (string-equal (format nil "The answer is ~10O." n2) "The answer is 1750.") (string-equal (format nil "The answer is ~:O." n2) "The answer is 1,750.") (string-equal (format nil "The answer is ~15,'0,:O." n2) "The answer is 00000000001,750.") ) ) ) (do-test "format-hexadecimal" (let ((n 10) (n1 -10) (n2 10191)) (and (string-equal (format nil "The answer is ~X." n) "The answer is A.") (string-equal (format nil "The answer is ~4X." n) "The answer is A.") (string-equal (format nil "The answer is ~4@X." n) "The answer is +A.") (string-equal (format nil "The answer is ~4X." n1) "The answer is -A.") (string-equal (format nil "The answer is ~10X." n2) "The answer is 27CF.") (string-equal (format nil "The answer is ~:X." n2) "The answer is 2,7CF.") (string-equal (format nil "The answer is ~15,'0,:X." n2) "The answer is 00000000002,7CF.") ) ) ) (do-test "format-radix" (let ((n 3) (n1 -3) (n2 12982298) (r 12)) (and (string-equal (format nil "The answer is ~10R." n) "The answer is 3.") (string-equal (format nil "The answer is ~10,3R." n) "The answer is 3.") (string-equal (format nil "The answer is ~10,3R." n1) "The answer is -3.") (string-equal (format nil "The answer is ~10,3@R." n) "The answer is +3.") (string-equal (format nil "The answer is ~10,7R." n2) "The answer is 12982298.") (string-equal (format nil "The answer is ~10,:R." n2) "The answer is 12,982,298.") (string-equal (format nil "The answer is ~10,:R." (expt 1000 n)) "The answer is 1,000,000,000.") (string-equal (format nil "The answer is ~10,15,'0,:R." n2) "The answer is 0000012,982,298.") ;full radix form (expect-errors (il:format-error) (format nil "~:R" 1/2)) ;; The following tests various radix cases. (string-equal (format nil "~D in radix ~D is ~2R." r 2 r) "12 in radix 2 is 1100.") (string-equal (format nil "~D in radix ~D is ~3R." r 3 r) "12 in radix 3 is 110.") (string-equal (format nil "~D in radix ~D is ~4R." r 4 r) "12 in radix 4 is 30.") (string-equal (format nil "~D in radix ~D is ~5R." r 5 r) "12 in radix 5 is 22.") (string-equal (format nil "~D in radix ~D is ~6R." r 6 r) "12 in radix 6 is 20.") (string-equal (format nil "~D in radix ~D is ~7R." r 7 r) "12 in radix 7 is 15.") (string-equal (format nil "~D in radix ~D is ~8R." r 8 r) "12 in radix 8 is 14.") (string-equal (format nil "~D in radix ~D is ~9R." r 9 r) "12 in radix 9 is 13.") (string-equal (format nil "~D in radix ~D is ~10R." r 10 r) "12 in radix 10 is 12.") (string-equal (format nil "~D in radix ~D is ~11R." r 11 r) "12 in radix 11 is 11.") (string-equal (format nil "~D in radix ~D is ~12R." r 12 r) "12 in radix 12 is 10.") (string-equal (format nil "~D in radix ~D is ~13R." r 13 r) "12 in radix 13 is C.") (string-equal (format nil "~D in radix ~D is ~14R." r 14 r) "12 in radix 14 is C.") (string-equal (format nil "~D in radix ~D is ~15R." r 15 r) "12 in radix 15 is C.") (string-equal (format nil "~D in radix ~D is ~16R." r 16 r) "12 in radix 16 is C.") ;; The following tests various directive cases for formatting a numer (string-equal (format nil "~R is a cardinal number." 4) "four is a cardinal number.") (or (string-equal (format nil "~R is a cardinal number." -4) "negative four is a cardinal number.") (string-equal (format nil "~R is a cardinal number." -4) "minus four is a cardinal number.")) (string-equal (format nil "~:R is an ordinal number." 4) "fourth is an ordinal number.") (string-equal (format nil "~@R is a roman number ~D." 4 4) "IV is a roman number 4.") (string-equal (format nil "~:@R is an old roman number ~D." 4 4) "IIII is an old roman number 4.") ) ) ) (do-test "format-plural" (let ((zero 0) (singular 1) (plural 7) (float-pt 9.99)) (and (string-equal (format nil "~D tr~:@p/~D win~:P." plural singular) "7 tries/1 win.") (string-equal (format nil "~D tr~:@p/~D win~:P." singular zero) "1 try/0 wins.") (string-equal (format nil "~D tr~:@p/~D win~:P." float-pt plural) "9.99 tries/7 wins.") ) ) ) (do-test "format-character" ;; Implementation or I/O dependent characters (i.e. control-C) are not included (let ((a #\a) (Z #\Z) (n #\1) (s #\*) (ch 'character) (Space #\ ) (Tab #\ ) (Newline #\ )) (and (string-equal (format nil "This is character ~C" a) "This is character a") (string-equal (format nil "This is character ~C" Z) "This is character Z") (string-equal (format nil "This is character ~C" n) "This is character 1") (string-equal (format nil "This is special character ~C" s) "This is special character *") (string-equal (format nil "This is character ~@C" a) "This is character #\\a") (string-equal (format nil "This is character ~@C" Z) "This is character #\\Z") (string-equal (format nil "This is character ~@C" n) "This is character #\\1") (string-equal (format nil "This is special character ~@C" s) "This is special character #\\*") (string-equal (format nil "This is non-printing ~A ~:C" ch Space) "This is non-printing character Space") (string-equal (format nil "This is non-printing ~A ~:C" ch Tab) "This is non-printing character Tab") (string-equal (format nil "This is non-printing ~A ~:C" ch newline) "This is non-printing character newline") (string-equal (format nil "This is non-printing ~A ~:@C" ch Space) "This is non-printing character Space") (string-equal (format nil "This is non-printing ~A ~:@C" ch Tab) "This is non-printing character Tab") (string-equal (format nil "This is non-printing ~A ~:@C" ch newline) "This is non-printing character newline") ) ) ) (do-test "format-fixed-floating-point" (and (defun format-float (x) (format nil "~6,2F:~6,2,1,'*F:~6,2,,'?F:~6F:~,2F:~F" x x x x x x)) (string-equal (format-float 3.14159) " 3.14: 31.42: 3.14:3.1416:3.14:3.14159") (string-equal (format-float -3.14159) " -3.14:-31.42: -3.14:-3.142:-3.14:-3.14159") (string-equal (format-float 100.0) "100.00:******:100.00: 100.0:100.00:100.0") (string-equal (format-float 1234.0) "1234.00:******:??????:1234.0:1234.00:1234.0") (string-equal (format-float 0.006) " 0.01: 0.06: 0.01: 0.006:0.01:0.006") (string-equal (format-float -0.006) " -0.01: -0.06: -0.01:-0.006:-0.01:-0.006") (string-equal (format-float 2/3) " 0.67: 6.67: 0.67:.66667:0.67:0.6666667") (string-equal (format-float 4/2) " 2.00: 20.00: 2.00: 2.0:2.00:2.0") (string-equal (format-float 4/2) " 2.00: 20.00: 2.00: 2.0:2.00:2.0") (string-equal (format-float 1234) "1234.00:******:??????:1234.0:1234.00:1234.0") ) ) (do-test "format-exponential-floating-point" (and (defun format-exponent (x) (format nil "~9,2,1,,'*E:~10,3,2,2,'?,,'$E:~9,3,2,-2,'%@e:~9,2E" x x x x)) (string-equal (format-exponent 3.14159) " 3.14E+0: 31.42$-01:+.003E+03: 3.14E+0") (string-equal (format-exponent -3.14159) " -3.14E+0:-31.42$-01:-.003E+03: -3.14E+0") (string-equal (format-exponent 1100.0) " 1.10E+3: 11.00$+02:+.001E+06: 1.10E+3") (or (string-equal (format-exponent 1100.0L0) " 1.10L+3: 11.00$+02:+.001L+06: 1.10L+3") (string-equal (format-exponent 1100.0L0) " 1.10E+3: 11.00$+02:+.001E+06: 1.10E+3")) (string-equal (format-exponent 1.1E13) "*********: 11.00$+12:+.001E+16: 1.10E+13") (or (string-equal (format-exponent 1.1L36) "*********: 11.00$+35:+.001L+39: 1.10L+36") (string-equal (format-exponent 1.1L36) "*********: 11.00$+35:+.001E+39: 1.10E+36")) ) ) ; AR 7427 (do-test "format-general-floating-point" (and (defun format-general-float (x) (format nil "~9,2,1,,'*G:~9,3,2,3,'?,,'$G:~9,3,2,0,'%G:~9,2G" x x x x)) (string-equal (format-general-float 0.0314159) " 3.14E-2:314.2$-04:0.314E-01: 3.14E-2") (string-equal (format-general-float 0.314159) " 0.31 :0.314 :0.314 : 0.31 ") (string-equal (format-general-float 3.14159) " 3.1 : 3.14 : 3.14 : 3.1 ") (string-equal (format-general-float 31.4159) " 31. : 31.4 : 31.4 : 31. ") (string-equal (format-general-float 314.159) " 3.14E+2: 314. : 314. : 3.14E+2") (string-equal (format-general-float 3141.59) " 3.14E+3:314.2$+01:0.314E+04: 3.14E+3") (or (string-equal (format-general-float 3141.59L0) " 3.14L+3:314.2$+01:0.314L+04: 3.14L+3") (string-equal (format-general-float 3141.59L0) " 3.14E+3:314.2$+01:0.314E+04: 3.14E+3")) (string-equal (format-general-float 3.14E12) "*********:314.0$+10:0.314E+13: 3.14E+12") (or (string-equal (format-general-float 3.14L36) "*********:314.0$+34:0.314L+37: 3.14L+36") (string-equal (format-general-float 3.14L36) "*********:314.0$+34:0.314E+37: 3.14E+36")) ) ) ; bug AR 7427 (do-test "format-dollars-floating-point" (and (defun format-dollars-float (x) (format nil "~$:~3,3,7,'*$:~,,10,'*$:~0,,10,'*$" x x x x )) (string-equal (format-dollars-float 0.99) "0.99:000.990:******0.99:********1.") (string-equal (format-dollars-float 10.99) "10.99:010.990:*****10.99:*******11.") (string-equal (format-dollars-float 119.99) "119.99:119.990:****119.99:******120.") (string-equal (format-dollars-float 12345.78) "12345.78:12345.780:**12345.78:****12346.") (string-equal (format-dollars-float 12762877.49) "12762877.00:12762877.000:12762877.00:*12762877.") ) ) (do-test "format-new-line-character" (and (string-equal (format nil "Hello~%~20TToday is Monday.") "Hello Today is Monday.") (string-equal (format nil "Hello~2%~20TToday is Monday.") "Hello Today is Monday.") ) ) (do-test "format-fresh-line" (and (string-equal (format nil "Hello~&") "Hello ") (string-equal (format nil "Hello~2&") "Hello ") (string-equal (format nil "Hello~2&") "Hello ") ) ) (do-test "format-page-separator-character" (and (string-equal (format nil "Hello~|") "Hello ") (string-equal (format nil "Hello~2|") "Hello ") ) ) (do-test "format-tilde" (and (string-equal (format nil "outputs ~D ~~~:P" 1) "outputs 1 ~") (string-equal (format nil "outputs ~D ~2~~:P" 2) "outputs 2 ~~s") (string-equal (format nil "outputs ~D ~3~~:P" 3) "outputs 3 ~~~s") ) ) (do-test "format-tilde-newline" (and (defun type-clash-error (fn nargs argnum right-type wrong-type) (format nil "~&~S requires its ~:[~:R~;~*~] ~ argument to be of type ~S, ~%but it was called ~ with an argument of type ~S." fn (eql nargs 1) argnum right-type wrong-type)) (string-equal (type-clash-error 'aref nil 2 'integer 'vector) "AREF requires its second argument to be of type INTEGER, but it was called with an argument of type VECTOR.") (string-equal (type-clash-error 'car 1 1 'list 'short-float) "CAR requires its argument to be of type LIST, but it was called with an argument of type SHORT-FLOAT.") ) ) (do-test "format-tab" (and (string-equal (format nil "a~3Tb~5Tc~7Td~9Te~11Tf~13Tg~15Th") "a b c d e f g h") (string-equal (format nil "a~3@Tb~5@Tc~7@Td") "a b c d") (or (string-equal (format nil "a~3,8@Tb") "a b") (string-equal (format nil "a~3,8@Tb") "a b") ) ) ) (do-test "format-indirection" (and (string-equal (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) " 7") (string-equal (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) " 7") (string-equal (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) " 7") (string-equal (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) " 14") ) ) (do-test "format-case-conversion" (and (defun f (n) (format nil "~@(~R~) error~:P detected." n)) (equal (format nil "~:(~A~)" "this capitalizes all words") "This Capitalizes All Words") (equal (format nil "~@(~A~)" "this capitalizes just the first word") "This capitalizes just the first word") (equal (format nil "~:@(~A~)" "This converts every Lowercase character to upper case character") "THIS CONVERTS EVERY LOWERCASE CHARACTER TO UPPER CASE CHARACTER") (equal (format nil "~@R ~(~@R~)" 14 14) "XIV xiv") (equal (f 0) "Zero errors detected.") (equal (f 1) "One error detected.") (equal (f 23) "Twenty-three errors detected.") ) ) (do-test "format-conditional-expression" (string-equal (format nil "~[Siamese~;Manx~;Persian~] cat" 0) "Siamese cat") (string-equal (format nil "~[Siamese~;Manx~;Persian~] cat" 1) "Manx cat") (string-equal (format nil "~[Siamese~;Manx~;Persian~] cat" 2) "Persian cat") (string-equal (format nil "~[false~;true~]" 0) "false") (let ((*print-level* nil) (*print-length* 5)) (string-equal (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) " print length = 5") ) (let ((foo "Items:~#[ none~; ~S~; ~S and ~S~ ~:;~@{~#[~; and ~] ~S~^,~}~].")) (and (string-equal (format nil foo) "Items: none.") (string-equal (format nil foo 'foo) "Items: FOO.") (string-equal (format nil foo 'foo 'bar) "Items: FOO and BAR.") (string-equal (format nil foo 'foo 'bar 'baz) "Items: FOO, BAR, and BAZ.") (string-equal (format nil foo 'foo 'bar 'baz 'quux) "Items: FOO, BAR, BAZ, and QUUX.") ) ) ) (do-test "format-iteration" (and (string-equal (format nil "The winners are:~{ ~S~}." '(fred harry jill)) "The winners are: Fred harry jill.") (string-equal (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) "Pairs: .") (string-equal (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) "Pairs: .") (string-equal (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) "Pairs: .") (string-equal (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) "Pairs: .") ) ) (do-test "format-justification" (and (string-equal (format nil "~10") "FOO BAR") (string-equal (format nil "~10:") " FOO BAR") (string-equal (format nil "~10:@") " FOO BAR ") (string-equal (format nil "~10") " FOOBAR") (string-equal (format nil "~10:") " FOOBAR") (string-equal (format nil "~10@") "FOOBAR ") (string-equal (format nil "~10:@") " FOOBAR ") ) ) (do-test "format-escape-construct" (and (let ((donestr "Done. ~^ ~D Warning~:P.~^ ~D error~:P.")) (and (string-equal (format nil donestr) "Done. ") (string-equal (format nil donestr 3) "Done. 3 warnings.") (string-equal (format nil donestr 1 5) "Done. 1 warning. 5 errors.") ) ) (let ((tellstr "~@(~@[~R~]~^ ~A.~)")) (and (equal (format nil tellstr 23) "Twenty-three") (equal (format nil tellstr nil "losers") " Losers.") (equal (format nil tellstr 23 "losers") "Twenty-three losers.") ) ) (let ((up-out-str "~15<~S~;~^~S~;~^~S~>")) (and (string-equal (format nil up-out-str 'foo) " FOO") (string-equal (format nil up-out-str 'foo 'bar) "FOO BAR") (string-equal (format nil up-out-str 'foo 'bar 'baz) "FOO BAR BAZ") ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST new file mode 100644 index 00000000..03a87c48 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 416 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 12,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-MAKE-PATHNAME.TEST ;; ;; ;; Syntax: (MAKE-PATHNAME &key :host :device :directory ;; :name :type :version :defaults) ;; ;; ;; ;; Function Description: ;; creates a pathname ;; ;; ;; ;; Argument(s): host - the name of the host ;; device - the name of the device ;; directory - the name of the directory ;; name - the name of the file ;; type - the type of file it is ;; version - the version of the file ;; defaults - the default values ;; ;; Returns: a pathname ;; (do-test "Simple make-pathname: host & name only" (let ((temp-pathname (make-pathname :host "core" :name "hello"))) (and (pathnamep temp-pathname) (string-equal "{CORE}HELLO" (namestring temp-pathname)) ))) (do-test "Make sure host defaults." (let ((*default-pathname-defaults* (pathname "{test}dev:foo.bar;3"))) (string-equal "{test}xxx" (namestring (make-pathname :device nil :directory nil :name "xxx"))) )) (do-test "Make sure only host defaults." (let ((*default-pathname-defaults* (pathname "{test}dev:foo.bar;3"))) (string-equal "{test}xxx" (namestring (make-pathname :name "xxx"))) )) (do-test "Make sure NILs don't default or fill in." (let ((*default-pathname-defaults* (pathname "{test}dev:foo.bar;3"))) (and (string-equal "{test}d.e" (namestring (make-pathname :name "d.e"))) (string-equal "{test}d.e" (namestring (make-pathname :device NIL :name "d.e"))) (string-equal "{test}d.e" (namestring (make-pathname :directory NIL :name "d.e"))) (string-equal "d.e" (namestring (make-pathname :host NIL :name "d.e"))) (string-equal "{test}d.e" (namestring (make-pathname :version NIL :name "d.e"))) ))) (do-test "Make sure :defaults fills in" (let ((dff (pathname "{x}y:w.t;1"))) (and (string-equal "{a}b:d.e;3" (namestring (make-pathname :defaults dff :host "a" :device "b" :directory "c" :name "d" :type "e" :version 3))) (string-equal "{x}b:d.e;3" (namestring (make-pathname :defaults dff :device "b" :directory "c" :name "d" :type "e" :version 3))) (string-equal "{a}y:d.e;3" (namestring (make-pathname :defaults dff :host "a" :directory "c" :name "d" :type "e" :version 3))) (string-equal "{a}b:d.e;3" (namestring (make-pathname :defaults dff :host "a" :device "b" :name "d" :type "e" :version 3))) (string-equal "{a}b:w.e;3" (namestring (make-pathname :defaults dff :host "a" :device "b" :directory "c" :type "e" :version 3))) (string-equal "{a}b:d.t;3" (namestring (make-pathname :defaults dff :host "a" :device "b" :directory "c" :name "d" :version 3))) (string-equal "{a}b:d.e;1" (namestring (make-pathname :defaults dff :host "a" :device "b" :directory "c" :name "d" :type "e"))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X new file mode 100644 index 00000000..96439b8e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 416 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 12,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-MAKE-PATHNAME.TEST ;; ;; ;; Syntax: (MAKE-PATHNAME &key :host :device :directory ;; :name :type :version :defaults) ;; ;; ;; ;; Function Description: ;; creates a pathname ;; ;; ;; ;; Argument(s): host - the name of the host ;; device - the name of the device ;; directory - the name of the directory ;; name - the name of the file ;; type - the type of file it is ;; version - the version of the file ;; defaults - the default values ;; ;; Returns: a pathname ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.dfasl")) T) ; get here and functions were defined (do-test "test a simple case" (let ((temp-pathname (make-pathname :host "core" :name "hello"))) (and (pathnamep temp-pathname) (string-equal "{CORE}HELLO" (namestring temp-pathname)) ))) (do-test "check defaulting works." (let ((temp-namestring (namestring *default-pathname-defaults*)) (t-host-namestring (host-namestring *default-pathname-defaults*))) (and (equal temp-namestring (namestring (make-pathname :defaults *default-pathname-defaults*))) (equal (concatenate 'string "{" t-host-namestring "}") (namestring (make-pathname))) ))) ;;; test do same type of test on several different HOSTS (do-test "test a couple simple variations, core" (and (23DRIVE-MAKE-LIST "{CORE}TEMPDEVICE:HELLO.TYPE;2" "core" "tempdevice" "tempdir" "hello" "type" 2) (23DRIVE-MAKE-LIST "{CORE}HELLO.TYPE;2" "core" nil "tempdir" "hello" "type" 2) (23DRIVE-MAKE-LIST "{CORE}TEMPDEVICE:HELLO.TYPE;2" "core" "tempdevice" nil "hello" "type" 2) (23DRIVE-MAKE-LIST "{CORE}HELLO.TYPE;2" "core" nil nil "hello" "type" 2) )) (do-test "test a couple simple variations, dsk" (23DRIVE-MAKE-LIST "{DSK}TEMPDIR>HELLO.TYPE;2" "dsk" NIL "lispfiles>tempdir" "hello" "type" 2)) (do-test "test a couple simple variations, erinyes" (23DRIVE-MAKE-LIST "{ERINYES}HELLO.TYPE;2" "erinyes" nil "CMLTEST" "hello" "type" 2)) (do-test "test a couple simple variations, pollux" (23DRIVE-MAKE-LIST "{POLLUX:AISNORTH:XEROX}HELLO.TYPE;2" "pollux:aisnorth:xerox" nil "CMLTEST" "hello" "type" 2)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X new file mode 100644 index 00000000..2b549251 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: MERGE-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 415 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 11,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-MERGE-PATHNAME.TEST ;; ;; ;; Syntax: (MERGE-PATHNAME pathname &optional defaults default-version) ;; ;; ;; ;; Function Description: ;; returns the name of the file as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; defaults - the default values ;; default-version - the default version ;; ;; Returns: the name of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.dfasl")) T) ; get here and functions were defined (do-test "test a simple case" (23check-merge "{CORE}TEMPDEVICE:HELLO.TYPE" "hello" "{CORE}TEMPDEVICE:NAME.TYPE")) ;;; test do same type of test on several different HOSTS (do-test "test lots of variations in {CORE}" (let ((temp-name (string (gensym)))) (23DRIVE-MERGE-LIST-STREAM (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1") "CORE" NIL NIL temp-name NIL "CORE" "TEMPDEVICE" "TEMPDIR" temp-name "TYPE" 1) )) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (MERGE-PATHNAMES value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ; get ride of some stuff, what's the better way? ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X b/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X new file mode 100644 index 00000000..89590449 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X @@ -0,0 +1 @@ +;; Function To Be Tested: NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 7,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-NAMESTRING.TEST ;; ;; ;; Syntax: (NAMESTRING pathname) ;; ;; ;; ;; Function Description: ;; returns the full name of the file ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the full name of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq temp-name (string (gensym))) (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdev" "tempdir" temp-name "type"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-list simple-list 'name (concatenate 'string "{CORE}TEMPDEV:" temp-name ".TYPE"))) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23DRIVE-NAMESTRING-LIST (host device dir name type expectvalue) "build the list and check get what want" (let* ((delete-list (23BUILD-LIST-OF-STREAM host 1 device dir name type)) (big-list (23Multiply-stream delete-list)) (result (23TEST-NAMESTRING-VALUE-list big-list 'name expectvalue))) (23Delete-file-list delete-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (let ((temp-name (string (gensym)))) (and (23DRIVE-NAMESTRING-LIST "core" nil "tdir" temp-name nil (concatenate 'string "{CORE}" temp-name ".;1")) (23DRIVE-NAMESTRING-LIST "core" "tdev12-23" "cmlfiletest>sub" temp-name "type" (concatenate 'string "{CORE}TDEV12-23:SUB>" temp-name ".TYPE;1")) ))) (do-test "test lots of variations in {dsk}" (let ((temp-name (string (gensym)))) (23DRIVE-NAMESTRING-LIST "dsk" nil "lispfiles>cmltest>sub" temp-name "type" (concatenate 'string "{DSK}CMLTEST>SUB>" temp-name ".TYPE;1")) )) (do-test "test lots of variations in {ERINYES}" (let ((temp-name (string (gensym)))) (23DRIVE-NAMESTRING-LIST "erinyes" nil "cmltest>sub" temp-name "type" (concatenate 'string "{ERINYES}SUB>" temp-name ".TYPE;1")) )) (do-test "test lots of variations in {POLLUX:AISNORTH:XEROX}" (let ((temp-name (string (gensym)))) (23DRIVE-NAMESTRING-LIST "pollux:aisnorth:xerox" nil "cmltest>sub" temp-name "type" (concatenate 'string "{POLLUX:AISNORTH:XEROX}SUB>" temp-name ".TYPE;1")) )) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (namestring value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X b/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X new file mode 100644 index 00000000..ca07f46a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X @@ -0,0 +1 @@ +;; Function To Be Tested: PARSE-NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 414 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PARSE-NAMESTRING.TEST ;; ;; ;; Syntax: (PARSE-NAMESTRING thing &optional host defaults ;; &key :start :end :junk-allowed) ;; ;; ;; ;; Function Description: ;; Turns thing into a pathname ;; ;; ;; ;; Argument(s): thing - a string, or symbol, or pathname, or stream ;; host - where ought to be ;; defaults - the default values ;; start - where start in the string ;; end - where end in the string ;; junk-allowed - could there be junk in the string? ;; ;; Returns: a pathname ;; ;; comment: For most tests don't need to worry about host ;; and default for the file system doesn't need ;; the information. See page 414. (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-name "{core}any-name.type") (temp-pathname (parse-namestring temp-name))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Parse-Basic (host) (let* ((temp-name (concatenate 'string "{" host "}any-name.type")) (temp-pathname (parse-namestring temp-name))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23Parse-Variable-Type (host) (let* ((temp-pathname (23BUILD-PATHNAME host)) (temp-stream (open temp-pathname :direction :io)) (toss-away (close temp-stream)) (expect (namestring temp-stream)) (temp-list (23Multiply-stream (list temp-stream))) (result (23check-parse-list expect temp-list))) (delete-file temp-stream) result)) (test-defun 23Parse-Junk (host) (let* ((temp-name (concatenate 'string " uh {" host "}any-name.type")) (temp-pathname (parse-namestring temp-name :junk-allowed T))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23Parse-Start (host) (let* ((temp-name (concatenate 'string " uh {" host "}any-name.type")) (temp-pathname (parse-namestring temp-name :start 5))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23Parse-End (host) (let* ((temp-name (concatenate 'string "{" host "}any-name.type uh")) (string-length (length temp-name)) (temp-pathname (parse-namestring temp-name :end (- string-length 3)))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23DRIVE-parse (host) "run a set of tests across several hosts" (and (23Parse-Basic host) (23Parse-Variable-Type host) (23Parse-Junk host) (23Parse-Start host) (23Parse-End host) )) ) ; End of defining functions for this test group. (do-test "test with lots of variations in {core}" (23DRIVE-parse "core")) ; problem with dsk vs pseudo-dsk ;(do-test "test with lots of variations in {dsk}" ; (23DRIVE-parse "dsk")) (do-test "test with lots of variations in {erinyes}" (23DRIVE-parse "erinyes")) ) ; End of defining functions for this test group. (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (parse-PATHNAMES value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ; get ride of some stuff, what's the better way? ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X new file mode 100644 index 00000000..7fc34957 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-DEVICE ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-DEVICE.TEST ;; ;; ;; Syntax: (PATHNAME-DEVICE pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the device as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the device name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 3 "tempdevice"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'DEVICE "TEMPDEVICE")) ;;; test do same type of test on several different HOSTS (do-test "test lots of variations in {CORE}" (and (23DRIVE-DEVICE-LIST "core" "tempdevice" "TEMPDEVICE") (23DRIVE-DEVICE-LIST "core" "tempdevice12-32" "TEMPDEVICE12-32") )) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-DEVICE value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-DEVICE "DF")) (not (PATHNAME-DEVICE "OCT-6-65")) (not (PATHNAME-DEVICE 'hello)) (not (PATHNAME-DEVICE 'bye)) (not (PATHNAME-DEVICE (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X new file mode 100644 index 00000000..5a8a3b2a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-DIRECTORY & DIRECTORY-NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-DIRECTORY.TEST ;; ;; ;; Syntax: (PATHNAME-DIRECTORY pathname) ;; (DIRECTORY-NAMESTRING pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the directory as a string or symbol ;; returns the name of the directory as a string ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the directory name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test, PATHNAME-DIRECTORY, a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 3 nil "tempdir"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'directory "TEMPDIR")) (do-test "test, DIRECTORY-NAMESTRING, a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 3 nil "tempdir"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-list simple-list 'directory "TEMPDIR")) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-DIRECTORY-LIST (host directory result-type) "build a list to test pathname-directory" (append ; general cases, for many file serves (23file-generator result-type host 2 nil directory) (23file-generator result-type host 2 nil directory nil "temptype") (23file-generator result-type host 2 nil directory nil "temptype12") )) ;Do each type (test-defun 23BUILD-DIRECTORY-LIST-ALL (host directory) "build the master list for the checker" (append (23BUILD-DIRECTORY-LIST host directory 'PATHNAME) (23BUILD-DIRECTORY-LIST host directory 'STREAM) (23BUILD-DIRECTORY-LIST host directory 'STRING) (23BUILD-DIRECTORY-LIST host directory 'SYMBOL) )) (test-defun 23DRIVE-DIRECTORY-LIST-PATHNAME (host directory-create directory-match) "push the same test across many hosts" (let* ((big-list (23BUILD-DIRECTORY-LIST-ALL host directory-create)) (result (23TEST-PATHNAME-VALUE-list big-list 'directory directory-match))) (23Delete-file-list big-list) result)) (test-defun 23DRIVE-DIRECTORY-LIST-NAMESTRING (host directory-create directory-match) "push the same test across many hosts" (let* ((big-list (23BUILD-DIRECTORY-LIST-ALL host directory-create)) (result (23TEST-NAMESTRING-VALUE-list big-list 'directory directory-match))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "testing PATHNAME-DIRECTORY, lots of variations in {CORE}" (23DRIVE-DIRECTORY-LIST-PATHNAME "core" "cmltest>sub>sub12" "CMLTEST>SUB>SUB12")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {DSK}" (23DRIVE-DIRECTORY-LIST-PATHNAME "DSK" "lispfiles>cmltest>sub" "LISPFILES>CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {ERINYES}" (23DRIVE-DIRECTORY-LIST-PATHNAME "erinyes" "cmltest>sub" "CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {pollux}" (23DRIVE-DIRECTORY-LIST-PATHNAME "pollux:aisnorth:xerox" "cmltest" "CMLTEST")) (do-test "testing DIRECTORY-NAMESTRING, lots of variations in {CORE}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "CORE" "cmltest>sub>sub12" "CMLTEST>SUB>SUB12")) (do-test "testing DIRECTORY-NAMESTRING, lots of variations in {DSK}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "DSK" "lispfiles>cmltest>sub" "LISPFILES>CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {ERINYES}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "erinyes" "cmltest>sub" "CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {pollux}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "pollux:aisnorth:xerox" "cmltest" "CMLTEST")) ) ; end of do-test-group (do-test "testing PATHNAME-DIRECTORY for error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-DIRECTORY value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-DIRECTORY "DF")) (not (PATHNAME-DIRECTORY "OCT-6-65")) (not (PATHNAME-DIRECTORY 'hello)) (not (PATHNAME-DIRECTORY 'bye)) (not (PATHNAME-DIRECTORY (make-broadcast-stream *terminal-io*))) ))) (do-test "testing DIRECTORY-NAMESTRING for error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (DIRECTORY-NAMESTRING value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (DIRECTORY-NAMESTRING "DF")) (not (DIRECTORY-NAMESTRING "OCT-6-65")) (not (DIRECTORY-NAMESTRING 'hello)) (not (DIRECTORY-NAMESTRING 'bye)) (not (DIRECTORY-NAMESTRING (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X new file mode 100644 index 00000000..dea52dd5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-HOST & HOST-NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 4,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-HOST.TEST ;; ;; ;; Syntax: (PATHNAME-HOST pathname) ;; (HOST-NAMESTRING pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the host as a string or symbol ;; returns the name of the host as a string ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the host name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test, PATHNAME-HOST, a simple case, dsk" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 3 nil "lispfiles"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'HOST "DSK")) (do-test "test, HOST-NAMESTRING, a simple case, dsk" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 3 nil "lispfiles"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-LIST simple-list 'HOST "DSK")) (do-test "test, PATHNAME-HOST, a simple case, pollux" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "pollux:aisnorth:xerox" 3 nil "cmltest"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'HOST "POLLUX:AISNORTH:XEROX")) (do-test "test, HOST-NAMESTRING, a simple case, pollux" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "pollux:aisnorth:xerox" 3 nil "cmltest"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-LIST simple-list 'HOST "POLLUX:AISNORTH:XEROX")) (do-test-group "test do same type of test on several hosts" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-HOST-LIST (host usedevice InOneDir result-type) "build a list with which to test pathname-host" (append ; if don't need to stay in one directory, wander (if (not InOneDir) (append (23file-generator result-type host 2) (23file-generator result-type host 2 nil "aisbu.modem12") (23file-generator result-type host 2 nil "aisbu.modem32" nil "temptype") )) ; if able to support devices on this host, test (if usedevice (append (23file-generator result-type host 2 "tempdevice") (23file-generator result-type host 2 "tempdevice" "cmltest") (23file-generator result-type host 2 "tempdevice" "cmlfiletest" nil "temptype") )) ; general cases, for many file serves (23file-generator result-type host 2 nil "cmltest") (23file-generator result-type host 2 nil "cmltest>sub") (23file-generator result-type host 2 nil "cmltest>sub" nil "temptype") )) ;Do each type (test-defun 23BUILD-HOST-LIST-ALL (host usedevice InOneDir) "build the big master list" (append (23BUILD-HOST-LIST host usedevice InOneDir 'PATHNAME) (23BUILD-HOST-LIST host usedevice InOneDir 'STREAM) (23BUILD-HOST-LIST host usedevice InOneDir 'STRING) (23BUILD-HOST-LIST host usedevice InOneDir 'SYMBOL) )) (test-defun 23DRIVE-HOST-LIST-PATHNAME (host-create host-match usedevice InOneDir) "push the same test across many hosts" (let* ((big-list (23BUILD-HOST-LIST-ALL host-create usedevice InOneDir)) (result (23TEST-PATHNAME-VALUE-list big-list 'HOST host-match))) (23Delete-file-list big-list) result)) (test-defun 23DRIVE-HOST-LIST-NAMESTRING (host-create host-match usedevice InOneDir) "push the same test across many hosts" (let* ((big-list (23BUILD-HOST-LIST-ALL host-create usedevice InOneDir)) (result (23TEST-NAMESTRING-VALUE-list big-list 'HOST host-match))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test (PATHNAME-HOST) lots of variations in {CORE}" (23DRIVE-HOST-LIST-PATHNAME "core" "CORE" T nil)) ;Ought to test around the problem with psuedo-dsk ;(do-test "test (PATHNAME-HOST) lots of variations in {DSK}" ; (23DRIVE-HOST-LIST-PATHNAME "dsk" "DSK" T nil)) (do-test "test (PATHNAME-HOST) lots of variations in {ERINYES}" (23DRIVE-HOST-LIST-PATHNAME "erinyes" "ERINYES" nil T)) (do-test "test (HOST-NAMESTRING) lots of variations in {CORE}" (23DRIVE-HOST-LIST-NAMESTRING "core" "CORE" T nil)) ;Ought to test around the problem with psuedo-dsk ;(do-test "test (HOST-NAMESTRING) lots of variations in {DSK}" ; (23DRIVE-HOST-LIST-NAMESTRING "dsk" "DSK" T nil)) (do-test "test (HOST-NAMESTRING) lots of variations in {ERINYES}" (23DRIVE-HOST-LIST-NAMESTRING "erinyes" "ERINYES" nil T)) ) ; end of do-test-group (do-test "test error conditions for PATHNAME-HOST" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-HOST value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-HOST "DF")) (not (PATHNAME-HOST "OCT-6-65")) (not (PATHNAME-HOST 'hello)) (not (PATHNAME-HOST 'bye)) (not (PATHNAME-HOST (make-broadcast-stream *terminal-io*))) ))) (do-test "test error conditions for HOST-NAMESTRING" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (HOST-NAMESTRING value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (HOST-NAMESTRING "DF")) (not (HOST-NAMESTRING "OCT-6-65")) (not (HOST-NAMESTRING 'hello)) (not (HOST-NAMESTRING 'bye)) (not (HOST-NAMESTRING (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X new file mode 100644 index 00000000..483648a7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-NAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-NAME.TEST ;; ;; ;; Syntax: (PATHNAME-NAME pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the file as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the name of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" ; test on dsk, lispfiles, so atleast the basics work. :before (progn (setq temp-name (string (gensym))) (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 1 nil "lispfiles>cmltest" temp-name))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'name temp-name)) (do-test "test a simple case" ; test on pollux, lispfiles, so atleast the basics work. :before (progn (setq temp-name (string (gensym))) (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "pollux:aisnorth:xerox" 1 nil "cmltest" temp-name))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'name temp-name)) ;(do-test "make sure can have a file like HELLO.GOOD.BYE & be consistent" ; :before (progn ; (setq expect-name (concatenate 'string (string (gensym)) ".bye")) ; (setq temp-name (concatenate 'string expect-name ".solong")) ; (setq delete-list (23BUILD-LIST-OF-FILENAME-PATHNAMES ; "core" 1 nil "tempdir" temp-name)) ; (setq simple-list (23Multiply-stream delete-list))) ; :after (progn (23Delete-file-list delete-list)) ; (23TEST-PATHNAME-VALUE-list simple-list 'name expect-name)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-NAME-LIST (host name result-type usedevice InOneDir) "create a list of files of one type" (append (if (not InOneDir) (append (23file-generator result-type host 1 nil nil name) (23file-generator result-type host 1 nil "TEMPDIR12-23" name))) (if usedevice (append (23file-generator result-type host 1 "TEMPDEVICE" nil name))) (23file-generator result-type host 1 nil "cmltest" name) (23file-generator result-type host 1 nil "cmltest" name "temptype12") )) (test-defun 23DRIVE-NAME-LIST (host name-create name-match usedevice InOneDir) "push the list through the checker, valid function?" (let* ((delete-list (23BUILD-NAME-LIST host name-create 'STREAM usedevice InOneDir)) (big-list (23Multiply-stream delete-list)) (result (23TEST-PATHNAME-VALUE-list big-list 'name name-match))) (23Delete-file-list delete-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (let ((temp-name (concatenate 'string "MM" (string (gensym))))) (23DRIVE-NAME-LIST "core" (string-downcase temp-name) temp-name T nil))) (do-test "test lots of variations in {DSK}" (let* ((name-create (concatenate 'string "LL" (string (gensym)))) (delete-list (23file-generator 'STREAM "dsk" 1 nil "lispfiles>sub" name-create "temptype12")) (big-list (23Multiply-stream delete-list)) (result (23TEST-PATHNAME-VALUE-list big-list 'name (string-downcase name-create)))) (23Delete-file-list delete-list) result)) (do-test "test lots of variations in {ERINYES}" (let ((temp-name (concatenate 'string "HC" (string (gensym))))) (23DRIVE-NAME-LIST "erinyes" (string-downcase temp-name) temp-name nil T))) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-NAME value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-NAME (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X new file mode 100644 index 00000000..cf47c8e2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-TYPE ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-TYPE.TEST ;; ;; ;; Syntax: (PATHNAME-TYPE pathname) ;; ;; ;; ;; Function Description: ;; returns the type of the fil as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the type of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 3 nil "lispfiles>tempdir" nil "hello"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'type "HELLO")) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-TYPE-LIST (host type result-type) (append (23file-generator result-type host 2 nil "cmltest" nil type) (23file-generator result-type host 2 nil "cmltest>sub" nil type) )) ;Do each type (test-defun 23BUILD-TYPE-LIST-ALL (host type) (append (23BUILD-TYPE-LIST host type 'PATHNAME) (23BUILD-TYPE-LIST host type 'STREAM) (23BUILD-TYPE-LIST host type 'STRING) (23BUILD-TYPE-LIST host type 'SYMBOL) )) (test-defun 23DRIVE-TYPE-LIST (host type-create type-match) (let* ((big-list (23BUILD-TYPE-LIST-ALL host type-create)) (result (23TEST-PATHNAME-VALUE-list big-list 'type type-match))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (23DRIVE-TYPE-LIST "core" "hello" "HELLO")) (do-test "test lots of variations in {erinyes}" (23DRIVE-TYPE-LIST "erinyes" "Nalpha-123" "NALPHA-123")) ) ; end of do-test-group (do-test "test a few variations in {dsk}" (let* ((big-list (23file-generator 'STREAM "dsk" 2 nil "lispfiles>sub" nil "temptype12")) (result (23TEST-PATHNAME-VALUE-list big-list 'type "temptype12"))) (23Delete-file-list big-list) result)) (do-test "test a few variations in {polux}" (let* ((big-list (23file-generator 'STREAM "pollux:aisnorth:xerox" 2 nil "cmltest" nil "temptype12")) (result (23TEST-PATHNAME-VALUE-list big-list 'type "temptype12"))) (23Delete-file-list big-list) result)) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-TYPE value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-TYPE "DF")) (not (PATHNAME-TYPE "OCT-6-65")) (not (PATHNAME-TYPE 'hello)) (not (PATHNAME-TYPE 'bye)) (not (PATHNAME-TYPE (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X new file mode 100644 index 00000000..b95e6135 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-VERSION ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 18,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-VERSION.TEST ;; ;; ;; Syntax: (PATHNAME-VERSION pathname) ;; ;; ;; ;; Function Description: ;; returns the type of the fil as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the version of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-STREAM "dsk" 3 nil "lispfiles>tempdir" nil "hello"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'version 1)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-VERSION-LIST (host result-type) (append (23file-generator result-type host 2 nil "cmltest") (23file-generator result-type host 2 nil "cmltest>sub") )) ;Do each type (test-defun 23BUILD-VERSION-LIST-ALL (host) (append (23BUILD-VERSION-LIST host 'STREAM) ; (23BUILD-VERSION-LIST host 'STRING) ; (23BUILD-VERSION-LIST host 'SYMBOL) )) (test-defun 23DRIVE-VERSION-LIST (host) (let* ((big-list (23BUILD-VERSION-LIST-ALL host)) (result (23TEST-PATHNAME-VALUE-list big-list 'version 1))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (23DRIVE-VERSION-LIST "core")) (do-test "test lots of variations in {dsk}" (let* ((big-list (23file-generator 'STREAM "dsk" 2 nil "lispfiles>sub" nil nil)) (result (23TEST-PATHNAME-VALUE-list big-list 'version 1))) (23Delete-file-list big-list) result)) (do-test "test lots of variations in {erinyes}" (23DRIVE-VERSION-LIST "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-VERSION value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X new file mode 100644 index 00000000..595ace2a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: pathname ;; ;; Source: CLtL p. 413 ;; Chapter 23: File System Interface Section 23-1-2: Pathname Functions ;; ;; Created By: Herb Jellinek ;; ;; Creation Date: 8 August 86 ;; ;; Last Update: October 9, 1986 ;; ;; Filed As: {eris}cml>test>23-1-2-pathname.test ;; ;; ;; Syntax: pathname pathname ;; ;; Function Description: converts pathname to a pathname. ;; ;; Argument(s): pathname - a pathname, string, symbol or stream ;; ;; Returns: a pathname ;; ;; ;;;; Watch out for implementation-dependent filenames below ;; (do-test-group ("pathname-test" :before (progn (test-setq termstream (make-broadcast-stream *terminal-io*)) (test-setq closed-stream (let ((s (open "{core}directory>empty" :direction :output))) (close s) s)) (test-setq bstream (open "{core}directory>empty" :if-does-not-exist :create)) (test-setq cstream (make-broadcast-stream bstream)) (test-setq dstream (open "{core}junk" :direction :output)) (test-setq open-streams (list termstream bstream cstream dstream)) (test-setq all-streams (list termstream closed-stream bstream cstream dstream)) (test-setq some-symbol 'five) (test-defun pathtest (object) (cl:pathnamep (cl:pathname object))) )) :after (progn (cl:mapcar #'cl:close open-streams) (cl:mapcar #'cl:delete-file all-streams)) (do-test pathname-test ;; Will the function accept all these files and streams? (and (cl:every #'(lambda (item) (streamp item)) all-streams) ;; Will it accept t and nil? (cl:every #'(lambda (x) x) (cl:mapcar #'pathtest '(t nil))) ;; Symbols? (pathtest (cl:gensym)) (pathtest (cl:gentemp)) (pathtest some-symbol) ;; Pathnames? (cl:every #'(lambda(x) x) (cl:mapcar #'pathtest (cl:mapcar #'pathname all-streams))) ;; Strings? (pathtest "abc") (pathtest (cl:pathname (cl:make-array 10 :element-type 'cl:string-char :initial-element #\newline))) (pathtest (cl:pathname (cl:make-array 4 :element-type 'cl:string-char :initial-contents "path" :adjustable t :fill-pointer t)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X new file mode 100644 index 00000000..c2aae103 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAMEP ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 416 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: October 31,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAMEP.TEST ;; ;; ;; Syntax: (PATHNAMEP object) ;; ;; (PATHNAMEP object) is exactly equal to: ;; (typep object 'pathname) ;; ;; ;; Function Description: ;; This predicate is true if object is a pathname, nil otherwise ;; ;; ;; ;; Argument(s): object - can be anything ;; ;; Returns: T if the object is a pathname, nil otherwise ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "try a simple test" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 1 nil "lispfiles>tempdir"))) :after (progn (23Delete-file-list simple-list)) (eq T (PATHNAMEP (car simple-list)))) (do-test-group "test same type on different hosts" :before (progn ; this function is just for this test case. (test-defun 23BUILD-PathNameP-Host-List (host usedevice InOneDir) "build the master list to drive past the checker" (append ; if don't need to stay in one directory, wander, not use directory (if (null InOneDir) (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1) (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "aisbu.modem12") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 3 nil nil nil "temptype") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "aisbu.modem" nil "temptype") )) ; if able to support devices on this host, test (if usedevice (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 3 "tempdevice") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 "tempdevice" "cmltest") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 "tempdevice" "cmltest" nil "temptype") )) ; general cases, for many file serves (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "cmltest") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 3 nil "cmltest>sub") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "cmltest>sub" nil "temptype") )) (test-defun 23DRIVE-PATHNAMEP-HOST-LIST (host usedevice InOneDir) "push the same test across many hosts" (let* ((big-list (23BUILD-PathNameP-Host-List host usedevice InOneDir)) (result (cl:every #'(lambda (item) (eq T (pathnamep item))) big-list))) (23Delete-file-list big-list) result)) ) ; end of local functions (do-test "test lots of variations in {core}" (23DRIVE-PATHNAMEP-HOST-LIST "core" T nil)) (do-test "test lots of variations in {core}" (let* ((big-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 2 nil "lispfiles>sub")) (result (cl:every #'(lambda (item) (eq T (pathnamep item))) big-list))) (23Delete-file-list big-list) result)) (do-test "test lots of variations in {erinyes}" (23DRIVE-PATHNAMEP-HOST-LIST "erinyes" nil T)) ) ; end of do-test-group (do-test "test other types return nil" (and (NOT (PATHNAMEP T)) (NOT (PATHNAMEP 54)) (NOT (PATHNAMEP #\h)) (NOT (PATHNAMEP "A string")) (NOT (PATHNAMEP 'symbol)) (NOT (PATHNAMEP (list 'hi 'bye))) (NOT (PATHNAMEP (make-array '(2 3 4)))) (NOT (PATHNAMEP (make-hash-table))) (NOT (PATHNAMEP (copy-readtable))) (NOT (PATHNAMEP (find-package 'Lisp))) (NOT (PATHNAMEP (make-broadcast-stream *terminal-io*))) ; (NOT (PATHNAMEP (make-random-state))) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X new file mode 100644 index 00000000..356d4e7d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: truename ;; ;; Source: CLtL p. 413 ;; Chapter 23: File System Interface Section 23-1-2: Pathname Functions ;; ;; Created By: Herb Jellinek ;; ;; Creation Date: 8 August 86 ;; ;; Last Update: October 7, 1986 ;; ;; Filed As: {eris}cml>test>23-1-2-truename.test ;; ;; ;; Syntax: truename pathname ;; ;; Function Description: if pathname is an open stream, returns the pathname of ;; file. Otherwise looks to see if pathname names an extant file; is so, ;; returns its pathname, if not, signals an error. ;; ;; Argument(s): pathname - a pathname, string, symbol or stream ;; ;; Returns: a pathname ;; ;; ;;;; Watch out for implementation-dependent filenames below ;; (do-test-group (truename-group :before (progn (test-setq astream (make-broadcast-stream *terminal-io*)) (test-setq bstream (open "{core}imaginary" :direction :output)) (test-setq cstream (make-broadcast-stream)) (close (test-setq dstream (open "{dsk}emptyfile.;1" :direction :output :if-does-not-exist :create))) (delete-file "{dsk}emptyfile.;1") (test-setq estream (open "{core}JUNK" :direction :output)) (test-setq file-streams (list bstream estream)) (test-setq extant-streams (list astream bstream cstream estream)) (test-setq all-streams (cons dstream extant-streams)) (test-setq symbol 'five)) :after (progn (mapcar #'close file-streams) (mapcar #'delete-file file-streams)) (do-test truename-test (and (every #'(lambda (x) x) (mapcar #'truename file-streams)) (expect-errors (simple-error) (truename "{core}non-existent.;1")) (expect-errors (simple-error) (truename dstream)) (expect-errors (simple-error) (truename astream)) (every #'(lambda (x) x) (mapcar #'truename (mapcar #'pathname extant-streams))) ) ) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X new file mode 100644 index 00000000..97e8a32a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: USER-HOMEDIR-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 418 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 10,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-USER-HOMEDIR-PATHNAME.TEST ;; ;; ;; Syntax: (USER-HOMEDIR-PATHNAME &optional host) ;; ;; ;; ;; Function Description: ;; returns a pathname for the user's "home directory" ;; ;; ;; ;; Argument(s): host - the name of a host ;; ;; Returns: a pathname for the user's "home directory" ;; (do-test "test a simple case" (pathnamep (USER-HOMEDIR-PATHNAME))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-2-OPEN.X b/internal/test/LANGUAGE/AUTO/23-2-OPEN.X new file mode 100644 index 00000000..0c48fea4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-2-OPEN.X @@ -0,0 +1 @@ +;; Function To Be Tested: OPEN ;; ;; Source: Steele's book ;; Section 23.2 ;; Page: 418 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-2-OPEN.TEST ;; ;; ;; Syntax: (OPEN filename &key :direction :element-type ;; :if-exists :if-does-not-exist) ;; ;; ;; ;; Function Description: ;; renames a file ;; ;; ;; ;; Argument(s): filename - pointer to a file ;; direction - the direction of data ;; element-type - the type of data stored in the file ;; if-exists - what to do if it exists ;; if-does-not-exist - what to do if it doesn't exist ;; ;; Returns: if it succeed a stream to the file ;; (do-test "need to load the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) (do-test "if able to build a file, then part of open works." (let* ((temp-name (string (gensym))) (simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name)) (probe-result (probe-file (car simple-list))) (expect (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1")) (result (and (pathnamep probe-result) (string-equal (namestring probe-result) expect)))) (23Delete-file-list simple-list) result)) (do-test "check can open and reopen." (let* ((temp-name (string (gensym))) (temp-pathname (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name))) (temp-stream (cl:open temp-pathname :direction :output :if-exists :new-version)) (probe-result (probe-file temp-stream)) (expect (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;2")) (result (and (pathnamep probe-result) (string-equal (namestring probe-result) expect)))) (cl:close temp-stream) (Delete-file temp-pathname) result)) (do-test "Try for files which do not exist" T) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:open value)) )) (and (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X b/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X new file mode 100644 index 00000000..fbded6be --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: WITH-OPEN-FILE ;; ;; Source: Steele's book ;; Section 23.2 ;; Page: 422 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-2-WITH-OPEN-FILE.TEST ;; ;; ;; Syntax: (WITH-OPEN-FILE (stream filename {options}*) ;; {declaration}* {form}*) ;; ;; ;; ;; Function Description: ;; opens a file while within the control of the body ;; ;; ;; ;; Argument(s): stream - to a file ;; filename - pointer to a file ;; ;; Returns: not clear, the last form inside? ;; (do-test "need to load the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) (do-test "try a simple case" (let* ((temp-pathname (23BUILD-PATHNAME "DSK" nil "lispfiles")) (result (with-open-file (temp-stream temp-pathname :direction :io) (probe-file temp-stream)))) (delete-file temp-pathname) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23With-Open-Basic (host) (let* ((temp-pathname (23BUILD-PATHNAME host)) (result (with-open-file (temp-stream temp-pathname :direction :io) (probe-file temp-stream)))) (delete-file temp-pathname) (pathnamep result))) (test-defun 23With-Open-More-Test (host) (let* ((probe-result nil) (temp-stream nil) (length-result nil) (with-open-result nil) (temp-name (string (gensym))) (temp-pathname (23BUILD-PATHNAME host nil "CMLTEST" temp-name)) (expect (concatenate 'string "{" host "}" temp-name ".;1"))) (setq with-open-result (with-open-file (temp-stream temp-pathname :direction :io) (setq probe-result (probe-file temp-stream)) (setq length-result (file-length temp-stream)) "HI")) (and (string-equal expect (namestring probe-result)) (eq nil temp-stream) (eq 0 length-result) (equal "HI" with-open-result) (delete-file temp-pathname) ))) (test-defun 23DRIVE-With-Open (host) "run a set of tests across several hosts" (and (23With-Open-Basic host) (23With-Open-More-Test host) )) ) ; End of defining functions for this test group. (do-test "test with lots of variations in {core}" (23DRIVE-With-Open "core")) (do-test "test with lots of variations in {erinyes}" (23DRIVE-With-Open "erinyes")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X b/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X new file mode 100644 index 00000000..83445c26 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: DELETE-FILE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 424 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-DELETE-FILE.TEST ;; ;; ;; Syntax: (DELETE-FILE pathname) ;; ;; ;; ;; Function Description: ;; deletes the file ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: T if succeeds ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-name (string (gensym))) (temp-pathname (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 1 nil "lispfiles>temp" temp-name)))) (and (Delete-file temp-pathname) (not (probe-file temp-pathname)) ))) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23TEST-DELETE-FILE (temp-pathname) "check return T and file really gone" (and (eq T (Delete-file temp-pathname)) (not (probe-file temp-pathname)) )) (test-defun 23TEST-DELETE-FILE-LIST (delete-list) "check that each item in the list exists, and give the right pathname" (cl:every #'(lambda (item) (23TEST-DELETE-FILE item)) delete-list)) (defun 23DRIVE-DELETE-FILE-LIST (host device directory name) "build the list and check able to delete the files" (let* ((delete-list (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 device directory name "typea") (23BUILD-LIST-OF-STREAM host 1 device directory name "typeB") ; (23BUILD-LIST-OF-FILENAME-STRING ; host 1 device directory name "typeC") (23BUILD-LIST-OF-FILENAME-SYMBOL host 1 device directory name "typeD")))) (23TEST-DELETE-FILE-LIST delete-list) )) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (and (23DRIVE-DELETE-FILE-LIST "CORE" NIL NIL NIL) (23DRIVE-DELETE-FILE-LIST "CORE" "tempdevice-12" NIL NIL) (23DRIVE-DELETE-FILE-LIST "CORE" NIL "cmltest>sub12" NIL) (23DRIVE-DELETE-FILE-LIST "CORE" "tempdevice-12" "cmltest>sub12" "hi-23") )) (do-test "test lots of variations in {DSK}" (23DRIVE-DELETE-FILE-LIST "DSK" NIL "lispfiles>cmltest>sub12" NIL)) (do-test "test lots of variations in {ERINYES}" (23DRIVE-DELETE-FILE-LIST "ERINYES" NIL "cmltest" NIL)) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:DELETE-FILE value)) )) (and (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (handle-expect-errors "DF") (handle-expect-errors "OCT-6-65") (handle-expect-errors 'hello) (handle-expect-errors 'bye) (handle-expect-errors (make-broadcast-stream *terminal-io*)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X new file mode 100644 index 00000000..e5eddf73 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-AUTHOR ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 424 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-WRITE-DATEAUTHOR.TEST ;; ;; ;; Syntax: (FILE-WRITE-DATEAUTHOR file) ;; ;; ;; ;; Function Description: ;; returns the author of a file ;; ;; ;; ;; Argument(s): file - an existing file ;; ;; Returns: the author of a file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "erinyes" 1))) (author-create (file-author simple-file))) (Delete-file simple-file) author-create)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Test-AUTHOR (temp-pathname expectvalue) "check the author is who we expect" (string-equal expectvalue (file-author temp-pathname))) (test-defun 23Test-AUTHOR-list (big-list expectvalue) "check the author is correct for bunch of files" (cl:every #'(lambda (item) (23Test-AUTHOR item expectvalue)) big-list)) (test-defun 23Build-AUTHOR (host) (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2) ; (23BUILD-LIST-OF-STREAM host 2) ; (23BUILD-LIST-OF-FILENAME-STRING host 2) (23BUILD-LIST-OF-FILENAME-SYMBOL host 2) )) (test-defun 23DRIVE-AUTHOR (host expectvalue) "build a set of files and check author works" (let* ((big-list (23BUILD-author host)) (result (23Test-author-list big-list expectvalue))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test the date with lots of variations in {core}" (23DRIVE-author "core" nil)) (do-test "test the date with lots of variations in {erinyes}" (let ((expectvalue (concatenate 'string (IL:username) ".pa"))) (23DRIVE-author "erinyes" expectvalue))) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X new file mode 100644 index 00000000..e1112d42 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-LENGTH ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 425 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 20,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-LENGTH.TEST ;; ;; ;; Syntax: (FILE-LENGTH file-stream) ;; ;; ;; ;; Function Description: ;; returns the length of a file ;; ;; ;; ;; Argument(s): file - a stream which is open ;; ;; Returns: the length of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-stream (cl:open (23BUILD-PATHNAME "DSK" NIL "LISPFILES") :direction :output :element-type 'string-char)) (result (eq 0 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Length-Empty (host) (let* ((temp-stream (23File-SetUP host)) (result (eq 0 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Length-String-Char (host) (let* ((temp-stream (23File-SetUP host)) (toss-away (prin1 'hello temp-stream)) (result (eq 5 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Length-Unsigned-byte (host) (let* ((temp-stream (23File-SetUP host 'unsigned-byte)) (toss-away (write-byte 8 temp-stream)) (result (eq 1 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23DRIVE-Length (host) "run a set of tests across several hosts" (and (23Length-Empty host) (23Length-String-Char host) (23Length-Unsigned-byte host) )) ) ; End of defining functions for this test group. (do-test "test the length with lots of variations in {core}" (23DRIVE-Length "core")) (do-test "test the length with lots of variations in {erinyes}" (23DRIVE-Length "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (and (not (file-length 54)) (not (file-length #\h)) (not (file-length (list 'hi 'bye))) (not (file-length (make-array '(2 3 4)))) (not (file-length (make-hash-table))) (not (file-length (copy-readtable))) (not (file-length (find-package 'Lisp))) ; (not (file-length (make-random-state))) (not (file-length "DF")) (not (file-length "OCT-6-65")) (not (file-length 'hello)) (not (file-length 'bye)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X new file mode 100644 index 00000000..1741b057 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-POSITION ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 425 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 20,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-POSITION.TEST ;; ;; ;; Syntax: (FILE-POSITION file-stream &optional position) ;; ;; ;; ;; Function Description: ;; either returns the current postion, or sets current position ;; ;; ;; ;; Argument(s): file-stream - a stream which is open ;; position - where want to go to ;; ;; Returns: the current position ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-stream (cl:open (23BUILD-PATHNAME "DSK" NIL "LISPFILES") :direction :output :element-type 'string-char)) (result (eq 0 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Position-Empty (host) (let* ((temp-stream (23Length-SetUP host)) (result (eq 0 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Position-String-Char (host) (let* ((temp-stream (23Length-SetUP host)) (toss-away (prin1 'hello temp-stream)) (result (eq 5 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Position-Unsigned-byte (host) (let* ((temp-stream (23Length-SetUP host 'unsigned-byte)) (toss-away (write-byte 8 temp-stream)) (result (eq 1 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Position-String-Char-Complex (host) (let* ((temp-stream (23Length-SetUP host)) (toss-away (prin1 'hello temp-stream)) (first-position (file-position temp-stream)) (toss-away-2 (prin1 'hello temp-stream)) (second-position (file-position temp-stream)) (result-set-position (file-position temp-stream 0)) (result-read-char (read-char temp-stream))) (23File-CleanUP temp-stream) (and (eq first-position 5) (eq second-position 10) (eq result-set-position T) (eq result-read-char #\H) ))) (test-defun 23DRIVE-Position (host) "run a set of tests across several hosts" (and (23Position-Empty host) (23Position-String-Char host) (23Position-Unsigned-byte host) (23Position-String-Char-Complex host) )) ) ; End of defining functions for this test group. (do-test "test the length with lots of variations in {core}" (23DRIVE-Position "core")) (do-test "test the length with lots of variations in {erinyes}" (23DRIVE-Position "erinyes")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X new file mode 100644 index 00000000..e406446e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-WRITE-DATE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 424 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-WRITE-DATE.TEST ;; ;; ;; Syntax: (FILE-WRITE-DATE file) ;; ;; ;; ;; Function Description: ;; returns the date the file was created, or last written to ;; ;; ;; ;; Argument(s): file - an existing file ;; ;; Returns: the time in universal time format ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((before-time (get-universal-time)) (temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "DSK" 1 nil "lispfiles"))) (after-time (get-universal-time)) (time-create (file-write-date simple-file)) (result (<= before-time time-create after-time))) (Delete-file simple-file) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Test-Date (temp-pathname before-time after-time) "check the date of a file is nicely bound" (let ((time-create (cl:file-write-date temp-pathname))) (<= before-time time-create after-time) )) (test-defun 23Test-Date-list (big-list before-time after-time) "check the date of a set of files are nicely bound" (cl:every #'(lambda (item) (23Test-Date item before-time after-time)) big-list)) (test-defun 23Build-Date (host) (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2) (23BUILD-LIST-OF-STREAM host 2) ; (23BUILD-LIST-OF-FILENAME-STRING host 2) (23BUILD-LIST-OF-FILENAME-SYMBOL host 2) )) (test-defun 23DRIVE-Date (host) "build a set of files and check date works" (let* ((before-time (get-universal-time)) (big-list (23BUILD-date host)) (toss-away (sleep 5)) (after-time (get-universal-time)) (result (23Test-Date-list big-list before-time after-time))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test the date with lots of variations in {core}" (23DRIVE-Date "core")) ;(do-test "test the date with lots of variations in {dsk}" ; (23DRIVE-Date "dsk")) ;(do-test "test the date with lots of variations in {erinyes}" ; (23DRIVE-Date "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (and (not (file-write-date 54)) (not (file-write-date #\h)) (not (file-write-date (list 'hi 'bye))) (not (file-write-date (make-array '(2 3 4)))) (not (file-write-date (make-hash-table))) (not (file-write-date (copy-readtable))) (not (file-write-date (find-package 'Lisp))) ; (not (file-write-date (make-random-state))) (not (file-write-date "DF")) (not (file-write-date "OCT-6-65")) (not (file-write-date 'hello)) (not (file-write-date 'bye)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X b/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X new file mode 100644 index 00000000..0c4c9141 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: PROBE-FILE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 4124 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-PROBE-FILE.TEST ;; ;; ;; Syntax: (PROBE-FILE pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the device as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the device name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-name (string (gensym))) (simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name)) (probe-result (probe-file (car simple-list))) (expect (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1")) (result (and (pathnamep probe-result) (string-equal (namestring probe-result) expect)))) (23Delete-file-list simple-list) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23TEST-PROBE-FILE (temp-pathname expectvalue) "check one pathname at a time" (let ((probe-result (probe-file temp-pathname))) (and (pathnamep probe-result) (string-equal expectvalue (namestring probe-result)) ))) (test-defun 23TEST-PROBE-FILE-LIST (big-list expectvalue) "check that each item in the list exists, and give the right pathname" (cl:every #'(lambda (item) (23TEST-PROBE-FILE item expectvalue)) big-list)) (test-defun 23DRIVE-PROBE-FILE-LIST (host device directory name type expectvalue) "build the list and check get what want" (let* ((delete-list (23BUILD-LIST-OF-STREAM host 1 device directory name type)) (big-list (23Multiply-stream delete-list)) (result (23TEST-PROBE-FILE-LIST big-list expectvalue))) (23Delete-file-list delete-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (let ((temp-name (string (gensym)))) (and (23DRIVE-PROBE-FILE-LIST "CORE" NIL "TDIR" temp-name NIL (concatenate 'string "{CORE}" temp-name ".;1")) (23DRIVE-PROBE-FILE-LIST "CORE" "TEMPDEVICE" "TDIR" temp-name NIL (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1")) (23DRIVE-PROBE-FILE-LIST "CORE" NIL "CMLTEST>SUB" temp-name "TYPE" (concatenate 'string "{CORE}SUB>" temp-name ".TYPE;1")) (23DRIVE-PROBE-FILE-LIST "CORE" "TEMPDEVICE" "TDIR" temp-name "TYPE" (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".TYPE;1")) ))) ;For now don't worry about, problem with DSK vs PSEUDO-DSK ;(do-test "test lots of variations in {DSK}" ; (let ((temp-name (string (gensym)))) ; (and ; (23DRIVE-PROBE-FILE-LIST "DSK" NIL "TDIR" temp-name NIL ; (concatenate 'string "{DSK}" temp-name ".;1")) ; (23DRIVE-PROBE-FILE-LIST "DSK" "TEMPDEVICE:" "TDIR" temp-name NIL ; (concatenate 'string "{DSK}TEMPDEVICE:" temp-name ".;1")) ; (23DRIVE-PROBE-FILE-LIST "DSK" NIL "CMLTEST>SUB" temp-name "TYPE" ; (concatenate 'string "{DSK}SUB>" temp-name ".TYPE;1")) ; (23DRIVE-PROBE-FILE-LIST "DSK" "TEMPDEVICE:" "TDIR" temp-name "TYPE" ; (concatenate 'string "{DSK}TEMPDEVICE:" temp-name ".TYPE;1")) ; ))) (do-test "test lots of variations in {ERINYES}" (let ((temp-name (string (gensym)))) (and (23DRIVE-PROBE-FILE-LIST "ERINYES" NIL "CMLTEST" temp-name NIL (concatenate 'string "{ERINYES}" temp-name ".;1")) (23DRIVE-PROBE-FILE-LIST "ERINYES" NIL "CMLTEST>SUB" temp-name "TYPE" (concatenate 'string "{ERINYES}SUB>" temp-name ".TYPE;1")) ))) ) ; end of do-test-group (do-test "test for files not there" (and (not (probe-file "{core}fdadzzzzzzzzzzxxxxx.")) (not (probe-file "{core}fdadzzzzzzzzzzxxxxx.dfwqe")) (not (probe-file "{zzzzzz}aaaaaa.aaaadfzzz")) (not (probe-file "{zzzzzz}dfdad:aaaaaa.aaaadfzzz")) (not (probe-file "{zzzzzz}dfdad:aaaaaa.aaaadfzzz")) )) (do-test "test error conditions" (and (not (probe-file 54)) (not (probe-file #\h)) (not (probe-file (list 'hi 'bye))) (not (probe-file (make-array '(2 3 4)))) (not (probe-file (make-hash-table))) (not (probe-file (copy-readtable))) (not (probe-file (find-package 'Lisp))) ; (not (probe-file (make-random-state))) (not (probe-file "DF")) (not (probe-file "OCT-6-65")) (not (probe-file 'hello)) (not (probe-file 'bye)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X b/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X new file mode 100644 index 00000000..b1842f4f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: RENAME-FILE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 423 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-RENAME-FILE.TEST ;; ;; ;; Syntax: (RENAME-FILE file new-name) ;; ;; ;; ;; Function Description: ;; renames a file ;; ;; ;; ;; Argument(s): file - an existing file ;; new-name - the new name ;; ;; Returns: three values ;; a) the new name filled in ;; b) the truename of file before renamed ;; c) truename after renamed ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test another simple case" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name))) (new-name (concatenate 'string "{CORE}" temp-name ".ren;1")) (new-pathname (make-pathname :host "core" :directory "tdir" :name temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Check-rename-simple (host) "complete test for just adding a type" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 nil "cmltest" temp-name))) (new-name (concatenate 'string "{" host "}" temp-name ".ren;1")) (new-pathname (make-pathname :host host :directory "cmltest" :name temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (test-defun 23Check-rename-name-type (host) "complete test for renaming the name and adding type" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 nil "cmltest" temp-name))) (new-temp-name (concatenate 'string temp-name "ab")) (new-name (concatenate 'string "{" host "}" new-temp-name ".ren;1")) (new-pathname (make-pathname :host host :directory "cmltest" :name new-temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (test-defun 23Check-rename-directory (host) "complete test for changing dirctories" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 nil "cmltest" temp-name))) (new-temp-name (concatenate 'string temp-name "cd")) (new-name (concatenate 'string "{" host "}sub>" new-temp-name ".ren;1")) (new-pathname (make-pathname :host host :directory "cmltest>sub" :name new-temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (test-defun 23Drive-rename-test (host) "make sure the tests work" (and (23Check-rename-simple host) (23Check-rename-name-type host) (23Check-rename-directory host) )) ) ; End of defining functions for this test group. (do-test "test variations in {core}" (23Drive-rename-test "core")) ;DSK vs Pseudo-dsk problem, need to redesign test to handle ;(do-test "test variations in {dsk}" ; (23Drive-rename-test "dsk")) (do-test "test variations in {erinyes}" (23Drive-rename-test "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:rename-file value value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (handle-expect-errors "DF") (handle-expect-errors "OCT-6-65") (handle-expect-errors 'hello) (handle-expect-errors 'bye) T )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-4-LOAD.X b/internal/test/LANGUAGE/AUTO/23-4-LOAD.X new file mode 100644 index 00000000..efae9ef0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-4-LOAD.X @@ -0,0 +1 @@ +;; Function To Be Tested: LOAD ;; ;; Source: Steele's book ;; Section 23.4 ;; Page: 426 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-4-load.TEST ;; ;; ;; Syntax: (LOAD filename &key :verbose :print :if-does-not-exist) ;; ;; ;; ;; Function Description: ;; renames a file ;; ;; ;; ;; Argument(s): file - an existing file ;; new-name - the new name ;; ;; Returns: three values ;; a) the new name filled in ;; b) the truename of file before renamed ;; c) truename after renamed ;; (do-test "simple case, try loading the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.DFASL")) t) (do-test "building a file in core, make sure can load" ; open a file, write to it, use evaluate to load file T) (do-test "test for files which do not exist" T) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:load value)) )) (and (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X b/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X new file mode 100644 index 00000000..3095dd91 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X @@ -0,0 +1 @@ +;; Function To Be Tested: DIRECTORY ;; ;; Source: Steele's book ;; Section 23.5 ;; Page: 427 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-5-DIRECTORY.TEST ;; ;; ;; Syntax: (DIRECTORY pathname &key) ;; ;; ;; ;; Function Description: ;; returns a list of pathnames to files ;; ;; ;; ;; Argument(s): pathname - a pathname ;; ;; ;; Returns: three values ;; a) the new name filled in ;; b) the truename of file before renamed ;; c) truename after renamed ;; (do-test "make sure have the functions for chapter 23" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.DFASL")) t) (do-test "make sure able to do a simple directory." (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 nil "TDIR" temp-name))) (expect (concatenate 'string "{CORE}" temp-name ".;1")) (dir-pathname (directory simple-file)) (result (and (pathnamep (car dir-pathname)) (string-equal expect (namestring (first dir-pathname)))))) (delete-file simple-file) result)) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:directory value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS new file mode 100644 index 00000000..a9d00161 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "13-May-87 17:24:00" {ERIS}CML>TEST>23-FUNCTIONS.\;8 83482 |changes| |to:| (FUNCTIONS XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::23DRIVE-DIRECTORY-LIST-NAMESTRING XCL-TEST::23DRIVE-DIRECTORY-LIST-PATHNAME XCL-TEST::23DRIVE-RENAME-TEST XCL-TEST::23CHECK-RENAME-DIRECTORY XCL-TEST::23CHECK-RENAME-NAME-TYPE XCL-TEST::23CHECK-RENAME-SIMPLE XCL-TEST::23DRIVE-PROBE-FILE-LIST XCL-TEST::23TEST-PROBE-FILE-LIST XCL-TEST::23TEST-PROBE-FILE XCL-TEST::23DRIVE-DATE XCL-TEST::23BUILD-DATE XCL-TEST::23TEST-DATE-LIST XCL-TEST::23TEST-DATE XCL-TEST::23DRIVE-POSITION XCL-TEST::23POSITION-STRING-CHAR-COMPLEX XCL-TEST::23POSITION-UNSIGNED-BYTE XCL-TEST::23POSITION-STRING-CHAR XCL-TEST::23POSITION-EMPTY XCL-TEST::23DRIVE-LENGTH XCL-TEST::23LENGTH-UNSIGNED-BYTE XCL-TEST::23LENGTH-STRING-CHAR XCL-TEST::23LENGTH-EMPTY XCL-TEST::23DRIVE-AUTHOR XCL-TEST::23BUILD-AUTHOR XCL-TEST::23TEST-AUTHOR-LIST XCL-TEST::23TEST-AUTHOR XCL-TEST::23DRIVE-DELETE-FILE-LIST XCL-TEST::23TEST-DELETE-FILE-LIST XCL-TEST::23TEST-DELETE-FILE XCL-TEST::23DRIVE-WITH-OPEN XCL-TEST::23WITH-OPEN-MORE-TEST XCL-TEST::23WITH-OPEN-BASIC XCL-TEST::23DRIVE-HOST-LIST-NAMESTRING XCL-TEST::23DRIVE-HOST-LIST-PATHNAME XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::23BUILD-HOST-LIST XCL-TEST::23DRIVE-TYPE-LIST XCL-TEST::23BUILD-TYPE-LIST-ALL XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::23DRIVE-NAME-LIST XCL-TEST::23BUILD-NAME-LIST XCL-TEST::23DRIVE-PATHNAMEP-HOST-LIST XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST XCL-TEST::23DRIVE-VERSION-LIST XCL-TEST::23BUILD-VERSION-LIST-ALL XCL-TEST::23BUILD-VERSION-LIST XCL-TEST::23DRIVE-MERGE-LIST-NO-STREAM XCL-TEST::23DRIVE-MERGE-LIST-STREAM XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::23CHECK-MERGE-LIST XCL-TEST::23DRIVE-MAKE-LIST XCL-TEST::23DRIVE-NAMESTRING-LIST XCL-TEST::23DRIVE-PARSE XCL-TEST::23PARSE-END XCL-TEST::23PARSE-START XCL-TEST::23PARSE-JUNK XCL-TEST::23PARSE-VARIABLE-TYPE XCL-TEST::23PARSE-BASIC XCL-TEST::23DRIVE-DEVICE-LIST XCL-TEST::23BUILD-DEVICE-LIST-ALL XCL-TEST::23BUILD-DEVICE-LIST XCL-USER::23DRIVE-ENOUGH-LIST XCL-USER::23DRIVE-FILE-BOTH XCL-USER::23DRIVE-FILE-LIST XCL-USER::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::23DRIVE-FILE-BOTH XCL-TEST::23DRIVE-ENOUGH-LIST XCL-TEST::23CHECK-PARSE-LIST XCL-TEST::23CHECK-PARSE XCL-TEST::23CHECK-RENAME XCL-TEST::23CHECK-MERGE XCL-TEST::23MUL-NO-PATHNAME XCL-TEST::23THREE-TYPES XCL-TEST::23MULTIPLY-STREAM XCL-TEST::23FILE-GENERATOR XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::23TEST-NAMESTRING-VALUE XCL-TEST::23TEST-PATHNAME-VALUE XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::23DELETE-FILE-LIST XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME XCL-TEST::23FILE-CLEANUP XCL-TEST::23LENGTH-SETUP XCL-TEST::23FILE-SETUP XCL-TEST::23BUILD-FILE XCL-TEST::23BUILD-PATHNAME) (VARS 23-FUNCTIONSCOMS) |previous| |date:| " 8-May-87 13:40:30" {ERIS}CML>TEST>23-FUNCTIONS.\;4) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT 23-FUNCTIONSCOMS) (RPAQQ 23-FUNCTIONSCOMS ((FUNCTIONS XCL-TEST::23BUILD-AUTHOR XCL-TEST::23BUILD-DATE XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::23BUILD-DEVICE-LIST-ALL XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::23BUILD-FILE XCL-TEST::23BUILD-HOST-LIST XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::23BUILD-NAME-LIST XCL-TEST::23BUILD-PATHNAME XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::23BUILD-TYPE-LIST-ALL XCL-TEST::23BUILD-VERSION-LIST XCL-TEST::23BUILD-VERSION-LIST-ALL XCL-TEST::23CHECK-MERGE XCL-TEST::23CHECK-MERGE-LIST XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::23CHECK-PARSE XCL-TEST::23CHECK-PARSE-LIST XCL-TEST::23CHECK-RENAME XCL-TEST::23CHECK-RENAME-DIRECTORY XCL-TEST::23CHECK-RENAME-NAME-TYPE XCL-TEST::23CHECK-RENAME-SIMPLE XCL-TEST::23DELETE-FILE-LIST XCL-TEST::23DRIVE-AUTHOR XCL-TEST::23DRIVE-DATE XCL-TEST::23DRIVE-DELETE-FILE-LIST XCL-TEST::23DRIVE-DEVICE-LIST XCL-TEST::23DRIVE-DIRECTORY-LIST-NAMESTRING XCL-TEST::23DRIVE-DIRECTORY-LIST-PATHNAME XCL-TEST::23DRIVE-ENOUGH-LIST XCL-TEST::23DRIVE-FILE-BOTH XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::23DRIVE-HOST-LIST-NAMESTRING XCL-TEST::23DRIVE-HOST-LIST-PATHNAME XCL-TEST::23DRIVE-LENGTH XCL-TEST::23DRIVE-MAKE-LIST XCL-TEST::23DRIVE-MERGE-LIST-NO-STREAM XCL-TEST::23DRIVE-MERGE-LIST-STREAM XCL-TEST::23DRIVE-NAME-LIST XCL-TEST::23DRIVE-NAMESTRING-LIST XCL-TEST::23DRIVE-PARSE XCL-TEST::23DRIVE-PATHNAMEP-HOST-LIST XCL-TEST::23DRIVE-POSITION XCL-TEST::23DRIVE-PROBE-FILE-LIST XCL-TEST::23DRIVE-RENAME-TEST XCL-TEST::23DRIVE-TYPE-LIST XCL-TEST::23DRIVE-VERSION-LIST XCL-TEST::23DRIVE-WITH-OPEN XCL-TEST::23FILE-CLEANUP XCL-TEST::23FILE-GENERATOR XCL-TEST::23FILE-SETUP XCL-TEST::23LENGTH-EMPTY XCL-TEST::23LENGTH-SETUP XCL-TEST::23LENGTH-STRING-CHAR XCL-TEST::23LENGTH-UNSIGNED-BYTE XCL-TEST::23MUL-NO-PATHNAME XCL-TEST::23MULTIPLY-STREAM XCL-TEST::23PARSE-BASIC XCL-TEST::23PARSE-END XCL-TEST::23PARSE-JUNK XCL-TEST::23PARSE-START XCL-TEST::23PARSE-VARIABLE-TYPE XCL-TEST::23POSITION-EMPTY XCL-TEST::23POSITION-STRING-CHAR XCL-TEST::23POSITION-STRING-CHAR-COMPLEX XCL-TEST::23POSITION-UNSIGNED-BYTE XCL-TEST::23TEST-AUTHOR XCL-TEST::23TEST-AUTHOR-LIST XCL-TEST::23TEST-DATE XCL-TEST::23TEST-DATE-LIST XCL-TEST::23TEST-DELETE-FILE XCL-TEST::23TEST-DELETE-FILE-LIST XCL-TEST::23TEST-NAMESTRING-VALUE XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::23TEST-PATHNAME-VALUE XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::23TEST-PROBE-FILE XCL-TEST::23TEST-PROBE-FILE-LIST XCL-TEST::23THREE-TYPES XCL-TEST::23WITH-OPEN-BASIC XCL-TEST::23WITH-OPEN-MORE-TEST))) (CL:DEFUN XCL-TEST::23BUILD-AUTHOR (XCL-TEST::HOST) (CL:APPEND ( XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2) (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST 2))) (CL:DEFUN XCL-TEST::23BUILD-DATE (XCL-TEST::HOST) (CL:APPEND ( XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2) (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 2) (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST 2))) (CL:DEFUN XCL-TEST::23BUILD-DEVICE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::RESULT-TYPE) "build a list for the checker" (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE "cmltest") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE "cmltest>sub") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE "cmltest>sub" NIL "temptype"))) (CL:DEFUN XCL-TEST::23BUILD-DEVICE-LIST-ALL (XCL-TEST::HOST XCL-TEST::DEVICE) "build the big master list" (CL:APPEND (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'PATHNAME) (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'STREAM) (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'STRING) (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-DIRECTORY-LIST (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::RESULT-TYPE) "build a list to test pathname-directory" (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE CL:DIRECTORY) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE CL:DIRECTORY NIL "temptype") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE CL:DIRECTORY NIL "temptype12"))) (CL:DEFUN XCL-TEST::23BUILD-DIRECTORY-LIST-ALL (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY) "build the master list for the checker" (CL:APPEND (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'PATHNAME) (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'STREAM) (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'STRING) (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-FILE (PATHNAME) "build a file" (LET ((XCL-TEST::STR (OPEN PATHNAME :DIRECTION :OUTPUT))) (CL:CLOSE XCL-TEST::STR) XCL-TEST::STR)) (CL:DEFUN XCL-TEST::23BUILD-HOST-LIST (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR XCL-TEST::RESULT-TYPE) "build a list with which to test pathname-host" (CL:APPEND (CL:IF (NOT XCL-TEST::INONEDIR) (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "aisbu.modem12") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "aisbu.modem32" NIL "temptype"))) (CL:IF XCL-TEST::USEDEVICE (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 "tempdevice") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 "tempdevice" "cmltest") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 "tempdevice" "cmlfiletest" NIL "temptype"))) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub" NIL "temptype"))) (CL:DEFUN XCL-TEST::23BUILD-HOST-LIST-ALL (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "build the big master list" (CL:APPEND (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'PATHNAME) (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'STREAM) (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'STRING) (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of pathnames for created files on {host}" (LET ((XCL-TEST::RESULTS NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:PUSH (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE) XCL-TEST::RESULTS) (XCL-TEST::23BUILD-FILE (CAR XCL-TEST::RESULTS))))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of strings for created files on {host}" (LET ((XCL-TEST::RESULTS NIL) (XCL-TEST::TEMP-PATHNAME NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:SETQ XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:PUSH (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME) XCL-TEST::RESULTS) (XCL-TEST::23BUILD-FILE XCL-TEST::TEMP-PATHNAME)))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of symbols for created files on {host}" (LET ((XCL-TEST::RESULTS NIL) (XCL-TEST::TEMP-PATHNAME NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:SETQ XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:PUSH (XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME XCL-TEST::TEMP-PATHNAME) XCL-TEST::RESULTS) (XCL-TEST::23BUILD-FILE XCL-TEST::TEMP-PATHNAME)))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-STREAM (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of stream for created files on {host}" (LET ((XCL-TEST::RESULTS NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:PUSH (XCL-TEST::23BUILD-FILE (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) XCL-TEST::RESULTS)))) (CL:DEFUN XCL-TEST::23BUILD-NAME-LIST (XCL-TEST::HOST XCL-TEST::NAME XCL-TEST::RESULT-TYPE XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "create a list of files of one type" (CL:APPEND (CL:IF (NOT XCL-TEST::INONEDIR) (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL NIL XCL-TEST::NAME) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL "TEMPDIR12-23" XCL-TEST::NAME))) (CL:IF XCL-TEST::USEDEVICE (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 "TEMPDEVICE" NIL XCL-TEST::NAME))) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME "temptype12"))) (CL:DEFUN XCL-TEST::23BUILD-PATHNAME (XCL-TEST::HOST &OPTIONAL XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "build a path name with default directory, and if need generated name" (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DEVICE XCL-TEST::DEVICE :DIRECTORY XCL-TEST::DIR :NAME (CL:IF XCL-TEST::NAME XCL-TEST::NAME (STRING (CL:GENSYM))) :TYPE TYPE)) (CL:DEFUN XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "build the master list to drive past the checker" (CL:APPEND (CL:IF (NULL XCL-TEST::INONEDIR) (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1) (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "aisbu.modem12") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 3 NIL NIL NIL "temptype") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "aisbu.modem" NIL "temptype"))) (CL:IF XCL-TEST::USEDEVICE (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 3 "tempdevice") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 "tempdevice" "cmltest") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 "tempdevice" "cmltest" NIL "temptype"))) (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "cmltest") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 3 NIL "cmltest>sub") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "cmltest>sub" NIL "temptype"))) (CL:DEFUN XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME (XCL-TEST::TEMP-PATHNAME) "get the name of a stream into SYMBOL form" (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))) (CL:DEFUN XCL-TEST::23BUILD-TYPE-LIST (XCL-TEST::HOST TYPE XCL-TEST::RESULT-TYPE) (CL:APPEND ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest" NIL TYPE) ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub" NIL TYPE))) (CL:DEFUN XCL-TEST::23BUILD-TYPE-LIST-ALL (XCL-TEST::HOST TYPE) (CL:APPEND ( XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'PATHNAME) (XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'STREAM) (XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'STRING) (XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-VERSION-LIST (XCL-TEST::HOST XCL-TEST::RESULT-TYPE) (CL:APPEND ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest") ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub"))) (CL:DEFUN XCL-TEST::23BUILD-VERSION-LIST-ALL (XCL-TEST::HOST) (CL:APPEND ( XCL-TEST::23BUILD-VERSION-LIST XCL-TEST::HOST 'STREAM))) (CL:DEFUN XCL-TEST::23CHECK-MERGE (XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME &OPTIONAL XCL-TEST::DEFAULTS XCL-TEST::DEFAULT-VERSION) "check both a pathname, and value is as expected." (LET ((XCL-TEST::RESULT (CL:MERGE-PATHNAMES XCL-TEST::TEMP-PATHNAME XCL-TEST::DEFAULTS XCL-TEST::DEFAULT-VERSION))) (AND (CL:PATHNAMEP XCL-TEST::RESULT) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::RESULT))))) (CL:DEFUN XCL-TEST::23CHECK-MERGE-LIST (XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION) "make sure each type can be merge with all the other types" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (EQ T (XCL-TEST::23CHECK-MERGE XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME XCL-TEST::ITEM XCL-TEST::DEFAULT-VERSION))) XCL-TEST::DEFAULT-LIST )) (CL:DEFUN XCL-TEST::23CHECK-MERGE-LISTS (XCL-TEST::EXPECT XCL-TEST::BIG-LIST XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION) "make sure each type can be merge with all the other types" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (EQ T (XCL-TEST::23CHECK-MERGE-LIST XCL-TEST::EXPECT XCL-TEST::ITEM XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION))) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23CHECK-PARSE (XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME) "check get what want" (LET ((PATHNAME (CL:PARSE-NAMESTRING XCL-TEST::TEMP-PATHNAME))) (AND (CL:PATHNAMEP PATHNAME) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING PATHNAME))))) (CL:DEFUN XCL-TEST::23CHECK-PARSE-LIST (XCL-TEST::EXPECT XCL-TEST::PATHNAME-LIST) "check a list, make sure get good results" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23CHECK-PARSE XCL-TEST::EXPECT XCL-TEST::ITEM)) XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23CHECK-RENAME (XCL-TEST::EXPECT XCL-TEST::OLD-PATHNAME XCL-TEST::NEW-PATHNAME) "check both a pathname, and value is as expected." (LET* ((XCL-TEST::RESULT (CL:MULTIPLE-VALUE-LIST (CL:RENAME-FILE XCL-TEST::OLD-PATHNAME XCL-TEST::NEW-PATHNAME))) (XCL-TEST::RESULT-1 (CL:FIRST XCL-TEST::RESULT)) (XCL-TEST::RESULT-2 (CL:SECOND XCL-TEST::RESULT)) (XCL-TEST::RESULT-3 (CL:THIRD XCL-TEST::RESULT))) (AND (CL:PATHNAMEP XCL-TEST::RESULT-1) (CL:PATHNAMEP XCL-TEST::RESULT-2) (CL:PATHNAMEP XCL-TEST::RESULT-3) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING (CL:PROBE-FILE XCL-TEST::RESULT-3))) (CL:PROBE-FILE XCL-TEST::NEW-PATHNAME) (NOT (CL:PROBE-FILE XCL-TEST::RESULT-2))))) (CL:DEFUN XCL-TEST::23CHECK-RENAME-DIRECTORY (XCL-TEST::HOST) "complete test for changing dirctories" (LET* ((XCL-TEST::TEMP-NAME (STRING (CL:GENSYM))) (XCL-TEST::SIMPLE-FILE (CAR (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::TEMP-NAME))) (XCL-TEST::NEW-TEMP-NAME (CL:CONCATENATE 'STRING XCL-TEST::TEMP-NAME "cd")) (XCL-TEST::NEW-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}sub>" XCL-TEST::NEW-TEMP-NAME ".ren;1")) (XCL-TEST::NEW-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DIRECTORY "cmltest>sub" :NAME XCL-TEST::NEW-TEMP-NAME :TYPE "ren")) (XCL-TEST::RESULT (XCL-TEST::23CHECK-RENAME XCL-TEST::NEW-NAME XCL-TEST::SIMPLE-FILE XCL-TEST::NEW-PATHNAME))) (CL:DELETE-FILE XCL-TEST::NEW-PATHNAME) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23CHECK-RENAME-NAME-TYPE (XCL-TEST::HOST) "complete test for renaming the name and adding type" (LET* ((XCL-TEST::TEMP-NAME (STRING (CL:GENSYM))) (XCL-TEST::SIMPLE-FILE (CAR (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::TEMP-NAME))) (XCL-TEST::NEW-TEMP-NAME (CL:CONCATENATE 'STRING XCL-TEST::TEMP-NAME "ab")) (XCL-TEST::NEW-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}" XCL-TEST::NEW-TEMP-NAME ".ren;1")) (XCL-TEST::NEW-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DIRECTORY "cmltest" :NAME XCL-TEST::NEW-TEMP-NAME :TYPE "ren")) (XCL-TEST::RESULT (XCL-TEST::23CHECK-RENAME XCL-TEST::NEW-NAME XCL-TEST::SIMPLE-FILE XCL-TEST::NEW-PATHNAME))) (CL:DELETE-FILE XCL-TEST::NEW-PATHNAME) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23CHECK-RENAME-SIMPLE (XCL-TEST::HOST) "complete test for just adding a type" (LET* ((XCL-TEST::TEMP-NAME (STRING (CL:GENSYM))) (XCL-TEST::SIMPLE-FILE (CAR (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::TEMP-NAME))) (XCL-TEST::NEW-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}" XCL-TEST::TEMP-NAME ".ren;1")) (XCL-TEST::NEW-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DIRECTORY "cmltest" :NAME XCL-TEST::TEMP-NAME :TYPE "ren")) (XCL-TEST::RESULT (XCL-TEST::23CHECK-RENAME XCL-TEST::NEW-NAME XCL-TEST::SIMPLE-FILE XCL-TEST::NEW-PATHNAME))) (CL:DELETE-FILE XCL-TEST::NEW-PATHNAME) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DELETE-FILE-LIST (XCL-TEST::PATHNAME-LIST) " delete every file in the list" (CL:MAPCAR #'CL:DELETE-FILE XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23DRIVE-AUTHOR (XCL-TEST::HOST XCL-TEST::EXPECTVALUE) "build a set of files and check author works" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-AUTHOR XCL-TEST::HOST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-AUTHOR-LIST XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DATE (XCL-TEST::HOST) "build a set of files and check date works" (LET* ((XCL-TEST::BEFORE-TIME (CL:GET-UNIVERSAL-TIME)) (XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DATE XCL-TEST::HOST)) (XCL-TEST::TOSS-AWAY (CL:SLEEP 5)) (XCL-TEST::AFTER-TIME (CL:GET-UNIVERSAL-TIME)) (XCL-TEST::RESULT (XCL-TEST::23TEST-DATE-LIST XCL-TEST::BIG-LIST XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DELETE-FILE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME) "build the list and check able to delete the files" (LET* ((XCL-TEST::DELETE-LIST (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME "typea") (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME "typeB") (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME "typeD")) )) (XCL-TEST::23TEST-DELETE-FILE-LIST XCL-TEST::DELETE-LIST))) (CL:DEFUN XCL-TEST::23DRIVE-DEVICE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE-CREATE XCL-TEST::DEVICE-MATCH) "check each file in the list checks" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DEVICE-LIST-ALL XCL-TEST::HOST XCL-TEST::DEVICE-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::DEVICE XCL-TEST::DEVICE-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DIRECTORY-LIST-NAMESTRING (XCL-TEST::HOST XCL-TEST::DIRECTORY-CREATE XCL-TEST::DIRECTORY-MATCH &OPTIONAL XCL-TEST::DEVICE) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIRECTORY-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST 'CL:DIRECTORY XCL-TEST::DIRECTORY-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DIRECTORY-LIST-PATHNAME (XCL-TEST::HOST XCL-TEST::DIRECTORY-CREATE XCL-TEST::DIRECTORY-MATCH &OPTIONAL XCL-TEST::DEVICE) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIRECTORY-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'CL:DIRECTORY XCL-TEST::DIRECTORY-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-ENOUGH-LIST (XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE XCL-TEST::EXPECTVALUE) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::NAME XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-FILE-BOTH (XCL-TEST::HOST XCL-TEST::NAME-CREATE TYPE) "pathname doesn't give version unless you give it first" (LET ((XCL-TEST::NAME-MATCH-1-V (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".;1")) (XCL-TEST::NAME-MATCH-2-V (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".type;1")) (XCL-TEST::NAME-MATCH-1 (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".")) (XCL-TEST::NAME-MATCH-2 (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".type"))) (AND (XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::HOST XCL-TEST::NAME-CREATE NIL XCL-TEST::NAME-MATCH-1-V) (XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::HOST XCL-TEST::NAME-CREATE "type" XCL-TEST::NAME-MATCH-2-V) (XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::HOST XCL-TEST::NAME-CREATE NIL XCL-TEST::NAME-MATCH-1) (XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::HOST XCL-TEST::NAME-CREATE "type" XCL-TEST::NAME-MATCH-2)))) (CL:DEFUN XCL-TEST::23DRIVE-FILE-LIST (XCL-TEST::HOST XCL-TEST::NAME-CREATE TYPE XCL-TEST::NAME-MATCH ) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME-CREATE TYPE) (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 NIL "cmltest>sub" XCL-TEST::NAME-CREATE TYPE))) (XCL-TEST::BIG-LIST (XCL-TEST::23MUL-NO-PATHNAME XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::FILE XCL-TEST::NAME-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION (XCL-TEST::HOST XCL-TEST::NAME-CREATE TYPE XCL-TEST::NAME-MATCH) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME-CREATE TYPE) (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest>sub" XCL-TEST::NAME-CREATE TYPE))) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::DELETE-LIST 'XCL-TEST::FILE XCL-TEST::NAME-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-HOST-LIST-NAMESTRING (XCL-TEST::HOST-CREATE XCL-TEST::HOST-MATCH XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::HOST-CREATE XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::HOST XCL-TEST::HOST-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-HOST-LIST-PATHNAME (XCL-TEST::HOST-CREATE XCL-TEST::HOST-MATCH XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::HOST-CREATE XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'XCL-TEST::HOST XCL-TEST::HOST-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-LENGTH (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23LENGTH-EMPTY XCL-TEST::HOST) (XCL-TEST::23LENGTH-STRING-CHAR XCL-TEST::HOST) (XCL-TEST::23LENGTH-UNSIGNED-BYTE XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-MAKE-LIST (XCL-TEST::EXPECT XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::VERSION &OPTIONAL XCL-TEST::DEFAULTS) "create the path name and check what want" (LET ((XCL-TEST::TEMP-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DEVICE XCL-TEST::DEVICE :DIRECTORY CL:DIRECTORY :NAME XCL-TEST::NAME :TYPE TYPE :VERSION XCL-TEST::VERSION :DEFAULTS XCL-TEST::DEFAULTS))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))))) (CL:DEFUN XCL-TEST::23DRIVE-MERGE-LIST-NO-STREAM (XCL-TEST::EXPECT XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::D-HOST XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE XCL-TEST::DEFAULT-VERSION) "check the pathname and defaults can be of any type" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23THREE-TYPES XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::VERSION)) (XCL-TEST::DEFAULT-LIST (XCL-TEST::23THREE-TYPES XCL-TEST::D-HOST XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE)) (XCL-TEST::RESULT (XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::EXPECT XCL-TEST::BIG-LIST XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION))) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-MERGE-LIST-STREAM (XCL-TEST::EXPECT XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::D-HOST XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE XCL-TEST::DEFAULT-VERSION) "check the pathname and defaults can be of any type" (LET* ((XCL-TEST::BIG-LIST-DEL (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::BIG-LIST-DEL)) (XCL-TEST::DEFAULT-LIST-DEL (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::D-HOST 1 XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE)) (XCL-TEST::DEFAULT-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DEFAULT-LIST-DEL)) (XCL-TEST::RESULT (XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::EXPECT XCL-TEST::BIG-LIST XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION))) (XCL-TEST::23DELETE-FILE-LIST (CL:APPEND XCL-TEST::DEFAULT-LIST-DEL XCL-TEST::BIG-LIST-DEL)) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-NAME-LIST (XCL-TEST::HOST XCL-TEST::NAME-CREATE XCL-TEST::NAME-MATCH XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the list through the checker, valid function?" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-NAME-LIST XCL-TEST::HOST XCL-TEST::NAME-CREATE 'STREAM XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'XCL-TEST::NAME XCL-TEST::NAME-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-NAMESTRING-LIST (XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE XCL-TEST::EXPECTVALUE) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::NAME XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-PARSE (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23PARSE-BASIC XCL-TEST::HOST) (XCL-TEST::23PARSE-VARIABLE-TYPE XCL-TEST::HOST) (XCL-TEST::23PARSE-JUNK XCL-TEST::HOST) (XCL-TEST::23PARSE-START XCL-TEST::HOST) (XCL-TEST::23PARSE-END XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-PATHNAMEP-HOST-LIST (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::RESULT (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (EQ T (CL:PATHNAMEP XCL-TEST::ITEM))) XCL-TEST::BIG-LIST))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-POSITION (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23POSITION-EMPTY XCL-TEST::HOST) (XCL-TEST::23POSITION-STRING-CHAR XCL-TEST::HOST) (XCL-TEST::23POSITION-UNSIGNED-BYTE XCL-TEST::HOST) (XCL-TEST::23POSITION-STRING-CHAR-COMPLEX XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-PROBE-FILE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::EXPECTVALUE) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PROBE-FILE-LIST XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-RENAME-TEST (XCL-TEST::HOST) "make sure the tests work" (AND (XCL-TEST::23CHECK-RENAME-SIMPLE XCL-TEST::HOST) (XCL-TEST::23CHECK-RENAME-NAME-TYPE XCL-TEST::HOST) (XCL-TEST::23CHECK-RENAME-DIRECTORY XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-TYPE-LIST (XCL-TEST::HOST XCL-TEST::TYPE-CREATE XCL-TEST::TYPE-MATCH) (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-TYPE-LIST-ALL XCL-TEST::HOST XCL-TEST::TYPE-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'TYPE XCL-TEST::TYPE-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-VERSION-LIST (XCL-TEST::HOST) (LET* ((XCL-TEST::BIG-LIST ( XCL-TEST::23BUILD-VERSION-LIST-ALL XCL-TEST::HOST) ) (XCL-TEST::RESULT ( XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'XCL-TEST::VERSION 1))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-WITH-OPEN (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23WITH-OPEN-BASIC XCL-TEST::HOST) (XCL-TEST::23WITH-OPEN-MORE-TEST XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23FILE-CLEANUP (XCL-TEST::TEMP-STREAM) "close the stream and delete the file" (CL:CLOSE XCL-TEST::TEMP-STREAM) (CL:DELETE-FILE XCL-TEST::TEMP-STREAM)) (CL:DEFUN XCL-TEST::23FILE-GENERATOR (XCL-TEST::RESULT-TYPE XCL-TEST::HOST &OPTIONAL CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE) "allow standard interface, so can just wory about type" (CASE XCL-TEST::RESULT-TYPE (STREAM (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (STRING (XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:SYMBOL (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:OTHERWISE (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)))) (CL:DEFUN XCL-TEST::23FILE-SETUP (XCL-TEST::HOST &OPTIONAL (TYPE 'CL:STRING-CHAR)) "create a file of a certain element-type" (OPEN (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST) :DIRECTION :OUTPUT :ELEMENT-TYPE TYPE)) (CL:DEFUN XCL-TEST::23LENGTH-EMPTY (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM ( XCL-TEST::23FILE-SETUP XCL-TEST::HOST)) (XCL-TEST::RESULT (EQ 0 (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23LENGTH-SETUP (XCL-TEST::HOST &OPTIONAL (TYPE 'CL:STRING-CHAR)) "create a file of a certain element-type" (OPEN (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST) :DIRECTION :IO :ELEMENT-TYPE TYPE)) (CL:DEFUN XCL-TEST::23LENGTH-STRING-CHAR (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM ( XCL-TEST::23FILE-SETUP XCL-TEST::HOST )) (XCL-TEST::TOSS-AWAY (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT (EQ 5 (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM) ))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23LENGTH-UNSIGNED-BYTE (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23FILE-SETUP XCL-TEST::HOST 'CL:UNSIGNED-BYTE)) (XCL-TEST::TOSS-AWAY ( CL:WRITE-BYTE 8 XCL-TEST::TEMP-STREAM )) (XCL-TEST::RESULT (EQ 1 (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23MUL-NO-PATHNAME (XCL-TEST::STREAM-LIST) "take a stream and push it, string and symbol into a list" (LET ((XCL-TEST::RESULT NIL)) (CL:DOLIST (XCL-TEST::ITEM XCL-TEST::STREAM-LIST XCL-TEST::RESULT) (CL:PUSH XCL-TEST::ITEM XCL-TEST::RESULT) (CL:PUSH (CL:NAMESTRING XCL-TEST::ITEM) XCL-TEST::RESULT) (CL:PUSH (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::ITEM)) XCL-TEST::RESULT)))) (CL:DEFUN XCL-TEST::23MULTIPLY-STREAM (XCL-TEST::STREAM-LIST) "take a stream and create four types pointing to the same file" (LET ((XCL-TEST::RESULT NIL)) (CL:DOLIST (XCL-TEST::ITEM XCL-TEST::STREAM-LIST XCL-TEST::RESULT) (CL:PUSH XCL-TEST::ITEM XCL-TEST::RESULT) (CL:PUSH (CL:NAMESTRING XCL-TEST::ITEM) XCL-TEST::RESULT) (CL:PUSH (PATHNAME XCL-TEST::ITEM) XCL-TEST::RESULT) (CL:PUSH (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::ITEM)) XCL-TEST::RESULT)))) (CL:DEFUN XCL-TEST::23PARSE-BASIC (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}any-name.type" )) (XCL-TEST::TEMP-PATHNAME ( CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME ))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME)) ))) (CL:DEFUN XCL-TEST::23PARSE-END (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}any-name.type uh" )) (XCL-TEST::STRING-LENGTH (CL:LENGTH XCL-TEST::TEMP-NAME )) (XCL-TEST::TEMP-PATHNAME (CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME :END (- XCL-TEST::STRING-LENGTH 3)))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))))) (CL:DEFUN XCL-TEST::23PARSE-JUNK (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING " uh {" XCL-TEST::HOST "}any-name.type" )) (XCL-TEST::TEMP-PATHNAME ( CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME :JUNK-ALLOWED T))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))) )) (CL:DEFUN XCL-TEST::23PARSE-START (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING " uh {" XCL-TEST::HOST "}any-name.type" )) (XCL-TEST::TEMP-PATHNAME ( CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME :START 5))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME)) ))) (CL:DEFUN XCL-TEST::23PARSE-VARIABLE-TYPE (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST)) (XCL-TEST::TEMP-STREAM (OPEN XCL-TEST::TEMP-PATHNAME :DIRECTION :IO)) (XCL-TEST::TOSS-AWAY (CL:CLOSE XCL-TEST::TEMP-STREAM )) (XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::TEMP-STREAM )) (XCL-TEST::TEMP-LIST (XCL-TEST::23MULTIPLY-STREAM (LIST XCL-TEST::TEMP-STREAM))) (XCL-TEST::RESULT ( XCL-TEST::23CHECK-PARSE-LIST XCL-TEST::EXPECT XCL-TEST::TEMP-LIST ))) (CL:DELETE-FILE XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23POSITION-EMPTY (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM ( XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST)) (XCL-TEST::RESULT (EQ 0 ( CL:FILE-POSITION XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23POSITION-STRING-CHAR (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST)) (XCL-TEST::TOSS-AWAY (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT (EQ 5 (CL:FILE-POSITION XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23POSITION-STRING-CHAR-COMPLEX (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST)) (XCL-TEST::TOSS-AWAY (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::FIRST-POSITION (CL:FILE-POSITION XCL-TEST::TEMP-STREAM)) (XCL-TEST::TOSS-AWAY-2 (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::SECOND-POSITION (CL:FILE-POSITION XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT-SET-POSITION (CL:FILE-POSITION XCL-TEST::TEMP-STREAM 0)) (XCL-TEST::RESULT-READ-CHAR (CL:READ-CHAR XCL-TEST::TEMP-STREAM))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) (AND (EQ XCL-TEST::FIRST-POSITION 5) (EQ XCL-TEST::SECOND-POSITION 10) (EQ XCL-TEST::RESULT-SET-POSITION T) (EQ XCL-TEST::RESULT-READ-CHAR #\H)))) (CL:DEFUN XCL-TEST::23POSITION-UNSIGNED-BYTE (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST 'CL:UNSIGNED-BYTE)) (XCL-TEST::TOSS-AWAY (CL:WRITE-BYTE 8 XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT (EQ 1 (CL:FILE-POSITION XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23TEST-AUTHOR (XCL-TEST::TEMP-PATHNAME XCL-TEST::EXPECTVALUE) "check the author is who we expect" (STRING-EQUAL XCL-TEST::EXPECTVALUE (CL:FILE-AUTHOR XCL-TEST::TEMP-PATHNAME))) (CL:DEFUN XCL-TEST::23TEST-AUTHOR-LIST (XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE) "check the author is correct for bunch of files" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-AUTHOR XCL-TEST::ITEM XCL-TEST::EXPECTVALUE)) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23TEST-DATE (XCL-TEST::TEMP-PATHNAME XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME) "check the date of a file is nicely bound" (LET ((XCL-TEST::TIME-CREATE (CL:FILE-WRITE-DATE XCL-TEST::TEMP-PATHNAME))) (<= XCL-TEST::BEFORE-TIME XCL-TEST::TIME-CREATE XCL-TEST::AFTER-TIME))) (CL:DEFUN XCL-TEST::23TEST-DATE-LIST (XCL-TEST::BIG-LIST XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME) "check the date of a set of files are nicely bound" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-DATE XCL-TEST::ITEM XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME)) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23TEST-DELETE-FILE (XCL-TEST::TEMP-PATHNAME) "check return T and file really gone" (AND (EQ T (CL:DELETE-FILE XCL-TEST::TEMP-PATHNAME)) (NOT (CL:PROBE-FILE XCL-TEST::TEMP-PATHNAME)))) (CL:DEFUN XCL-TEST::23TEST-DELETE-FILE-LIST (XCL-TEST::DELETE-LIST) "check that each item in the list exists, and give the right pathname" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-DELETE-FILE XCL-TEST::ITEM)) XCL-TEST::DELETE-LIST)) (CL:DEFUN XCL-TEST::23TEST-NAMESTRING-VALUE (PATHNAME XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test for correct string" (LET ((XCL-TEST::RESULT (CASE XCL-TEST::TEST-TYPE (XCL-TEST::NAME (CL:NAMESTRING PATHNAME)) (XCL-TEST::FILE (CL:FILE-NAMESTRING PATHNAME)) (CL:DIRECTORY (CL:DIRECTORY-NAMESTRING PATHNAME)) (XCL-TEST::HOST (CL:HOST-NAMESTRING PATHNAME)) (XCL-TEST::ENOUGH (CL:ENOUGH-NAMESTRING PATHNAME))))) (STRING-EQUAL XCL-TEST::RESULT XCL-TEST::VALUE))) (CL:DEFUN XCL-TEST::23TEST-NAMESTRING-VALUE-LIST (XCL-TEST::PATHNAME-LIST XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test list for correct string" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-NAMESTRING-VALUE XCL-TEST::ITEM XCL-TEST::TEST-TYPE XCL-TEST::VALUE)) XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23TEST-PATHNAME-VALUE (PATHNAME XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test for correct string or symbol" (LET ((XCL-TEST::RESULT (CASE XCL-TEST::TEST-TYPE (XCL-TEST::HOST (CL:PATHNAME-HOST PATHNAME)) (XCL-TEST::DEVICE (CL:PATHNAME-DEVICE PATHNAME)) (CL:DIRECTORY (CL:PATHNAME-DIRECTORY PATHNAME)) (XCL-TEST::NAME (CL:PATHNAME-NAME PATHNAME)) (TYPE (CL:PATHNAME-TYPE PATHNAME)) (XCL-TEST::VERSION (CL:PATHNAME-VERSION PATHNAME))))) (CL:IF (CL:EQUAL XCL-TEST::TEST-TYPE 'XCL-TEST::VERSION) (CL:EQUAL XCL-TEST::RESULT XCL-TEST::VALUE) (OR (STRING-EQUAL XCL-TEST::RESULT XCL-TEST::VALUE) (AND (TYPEP XCL-TEST::RESULT 'CL:SYMBOL) (STRING-EQUAL XCL-TEST::VALUE (STRING XCL-TEST::RESULT))))))) (CL:DEFUN XCL-TEST::23TEST-PATHNAME-VALUE-LIST (XCL-TEST::PATHNAME-LIST XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test list for correct string or symbol" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-PATHNAME-VALUE XCL-TEST::ITEM XCL-TEST::TEST-TYPE XCL-TEST::VALUE)) XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23TEST-PROBE-FILE (XCL-TEST::TEMP-PATHNAME XCL-TEST::EXPECTVALUE) "check one pathname at a time" (LET ((XCL-TEST::PROBE-RESULT (CL:PROBE-FILE XCL-TEST::TEMP-PATHNAME))) (AND (CL:PATHNAMEP XCL-TEST::PROBE-RESULT) (STRING-EQUAL XCL-TEST::EXPECTVALUE (CL:NAMESTRING XCL-TEST::PROBE-RESULT))))) (CL:DEFUN XCL-TEST::23TEST-PROBE-FILE-LIST (XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE) "check that each item in the list exists, and give the right pathname" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-PROBE-FILE XCL-TEST::ITEM XCL-TEST::EXPECTVALUE)) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23THREE-TYPES (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::VERSION) "want in three types, no file, so no stream" (LET ((XCL-TEST::RESULT (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DEVICE XCL-TEST::DEVICE :DIRECTORY CL:DIRECTORY :NAME XCL-TEST::NAME :TYPE TYPE :VERSION XCL-TEST::VERSION))) (LIST XCL-TEST::RESULT (CL:NAMESTRING XCL-TEST::RESULT) (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::RESULT))))) (CL:DEFUN XCL-TEST::23WITH-OPEN-BASIC (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-PATHNAME ( XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST )) (XCL-TEST::RESULT (CL:WITH-OPEN-FILE ( XCL-TEST::TEMP-STREAM XCL-TEST::TEMP-PATHNAME :DIRECTION :IO) (CL:PROBE-FILE XCL-TEST::TEMP-STREAM )))) (CL:DELETE-FILE XCL-TEST::TEMP-PATHNAME) (CL:PATHNAMEP XCL-TEST::RESULT))) (CL:DEFUN XCL-TEST::23WITH-OPEN-MORE-TEST (XCL-TEST::HOST) (LET* ((XCL-TEST::PROBE-RESULT NIL) (XCL-TEST::TEMP-STREAM NIL) (XCL-TEST::LENGTH-RESULT NIL) (XCL-TEST::WITH-OPEN-RESULT NIL) (XCL-TEST::TEMP-NAME (STRING ( CL:GENSYM ))) (XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST NIL "CMLTEST" XCL-TEST::TEMP-NAME)) (XCL-TEST::EXPECT (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}" XCL-TEST::TEMP-NAME ".;1")) ) (CL:SETQ XCL-TEST::WITH-OPEN-RESULT (CL:WITH-OPEN-FILE (XCL-TEST::TEMP-STREAM XCL-TEST::TEMP-PATHNAME :DIRECTION :IO) (CL:SETQ XCL-TEST::PROBE-RESULT (CL:PROBE-FILE XCL-TEST::TEMP-STREAM )) (CL:SETQ XCL-TEST::LENGTH-RESULT (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM )) "HI")) (AND (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::PROBE-RESULT )) (EQ NIL XCL-TEST::TEMP-STREAM) (EQ 0 XCL-TEST::LENGTH-RESULT) (CL:EQUAL "HI" XCL-TEST::WITH-OPEN-RESULT ) (CL:DELETE-FILE XCL-TEST::TEMP-PATHNAME) ))) (PUTPROPS 23-FUNCTIONS COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF new file mode 100644 index 00000000..03633f89 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF @@ -0,0 +1 @@ +;; These functions are defined once for the ;; test for chapter 23. ;; Not using "test-defun", for there is no reasonable way to undo it. ; Since DO-TEST reads in package XCL-TEST, all these functions must live there as well... (in-package 'xcl-test) ; do so the tests will work on the 1108, give it a directory it can use (if (not (il:lispdirectoryp 'il:lispfiles)) (il:createdskdirectory 'il:lispfiles)) (defun 23BUILD-PATHNAME (host &optional device (dir "CMLTEST") name type) "build a path name with default directory, and if need generated name" (make-pathname :host host :device device :directory dir :name (if name name (string (gensym))) :type type)) (defun 23BUILD-FILE (pathname) "build a file" (let ((str (open pathname :direction :output))) (close str) str)) (defun 23File-SetUP (host &optional (type 'string-char)) "create a file of a certain element-type" (cl:open (23BUILD-PATHNAME host) :direction :output :element-type type)) (defun 23Length-SetUP (host &optional (type 'string-char)) "create a file of a certain element-type" (cl:open (23BUILD-PATHNAME host) :direction :io :element-type type)) (defun 23File-CleanUP (temp-stream) "close the stream and delete the file" (cl:close temp-stream) (cl:delete-file temp-stream)) (defun 23BUILD-SYMBOL-FROM-PATHNAME (temp-pathname) "get the name of a stream into SYMBOL form" (make-symbol (namestring temp-pathname))) (defun 23Delete-file-list (pathname-list) " delete every file in the list" (cl:mapcar #'cl:delete-file pathname-list)) (defun 23BUILD-LIST-OF-FILENAME-PATHNAMES (host &optional (number 5) device (dir "CMLTEST") name type) "return list of pathnames for created files on {host}" (let ((results nil)) (dotimes (i number results) (push (23BUILD-PATHNAME host device dir name type) results) (23BUILD-FILE (CAR results)) ))) (defun 23BUILD-LIST-OF-STREAM (host &optional (number 5) device (dir "CMLTEST") name type) "return list of stream for created files on {host}" (let ((results nil)) (dotimes (i number results) (push (23BUILD-FILE (23BUILD-PATHNAME host device dir name type)) results) ))) (defun 23BUILD-LIST-OF-FILENAME-STRING (host &optional (number 5) device (dir "CMLTEST") name type) "return list of strings for created files on {host}" (let ((results nil) (temp-pathname nil)) (dotimes (i number results) (setq temp-pathname (23BUILD-PATHNAME host device dir name type)) (push (namestring temp-pathname) results) (23BUILD-FILE temp-pathname) ))) (defun 23BUILD-LIST-OF-FILENAME-SYMBOL (host &optional (number 5) device (dir "CMLTEST") name type) "return list of symbols for created files on {host}" (let ((results nil) (temp-pathname nil)) (dotimes (i number results) (setq temp-pathname (23BUILD-PATHNAME host device dir name type)) (push (23BUILD-SYMBOL-FROM-PATHNAME temp-pathname) results) (23BUILD-FILE temp-pathname) ))) (defun 23TEST-PATHNAME-VALUE (pathname test-type value) "common pattern of code, test for correct string or symbol" (let ((result (case test-type (HOST (pathname-host pathname)) (DEVICE (pathname-device pathname)) (DIRECTORY (pathname-directory pathname)) (NAME (pathname-name pathname)) (TYPE (pathname-type pathname)) (VERSION (pathname-version pathname)) ))) (if (equal test-type 'VERSION) (equal result value) (or (string-equal result value) (and (typep result 'symbol) (string-equal value (string result)))) ))) (defun 23TEST-NAMESTRING-VALUE (pathname test-type value) "common pattern of code, test for correct string" (let ((result (case test-type (NAME (namestring pathname)) (FILE (file-namestring pathname)) (DIRECTORY (directory-namestring pathname)) (HOST (host-namestring pathname)) (ENOUGH (enough-namestring pathname)) ))) (string-equal result value) )) (defun 23TEST-PATHNAME-VALUE-LIST (pathname-list test-type value) "common pattern of code, test list for correct string or symbol" (cl:every #'(lambda (item) (23TEST-PATHNAME-VALUE item test-type value)) pathname-list)) (defun 23TEST-NAMESTRING-VALUE-LIST (pathname-list test-type value) "common pattern of code, test list for correct string" (cl:every #'(lambda (item) (23TEST-NAMESTRING-VALUE item test-type value)) pathname-list)) (defun 23file-generator (result-type host &optional number device dir name type) "allow standard interface, so can just wory about type" (case result-type (STREAM (23BUILD-LIST-OF-STREAM host number device dir name type)) (STRING (23BUILD-LIST-OF-FILENAME-STRING host number device dir name type)) (SYMBOL (23BUILD-LIST-OF-FILENAME-SYMBOL host number device dir name type)) (otherwise (23BUILD-LIST-OF-FILENAME-PATHNAMES host number device dir name type)) )) (defun 23Multiply-stream (stream-list) "take a stream and create four types pointing to the same file" (let ((result nil)) (dolist (item stream-list result) (push item result) (push (namestring item) result) (push (pathname item) result) (push (make-symbol (namestring item)) result) ))) (defun 23THREE-TYPES (host device directory name type version) "want in three types, no file, so no stream" (let ((result (make-pathname :host host :device device :directory directory :name name :type type :version version))) (list result (namestring result) (make-symbol (namestring result)) ))) (defun 23Mul-No-Pathname (stream-list) "take a stream and push it, string and symbol into a list" (let ((result nil)) (dolist (item stream-list result) (push item result) (push (namestring item) result) (push (make-symbol (namestring item)) result) ))) (defun 23check-merge (expect temp-pathname &optional defaults default-version) "check both a pathname, and value is as expected." (let ((result (merge-pathnames temp-pathname defaults default-version))) (and (pathnamep result) (string-equal expect (namestring result)) ; (equal expect (namestring result)) ))) (defun 23check-RENAME (expect old-pathname new-pathname) "check both a pathname, and value is as expected." (let* ((result (multiple-value-list (RENAME-file old-pathname new-pathname))) (result-1 (first result)) (result-2 (second result)) (result-3 (third result))) (and (pathnamep result-1) (pathnamep result-2) (pathnamep result-3) (string-equal expect (namestring (probe-file result-3))) (probe-file new-pathname) (not (probe-file result-2)) ))) (defun 23check-parse (expect temp-pathname) "check get what want" (let ((pathname (parse-namestring temp-pathname))) (and (pathnamep pathname) (string-equal expect (namestring pathname)) ))) (defun 23check-parse-list (expect pathname-list) "check a list, make sure get good results" (cl:every #'(lambda (item) (23check-parse expect item)) pathname-list)) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b152cd214837e92aec597c59f9796f5afb2bb3d6 GIT binary patch literal 25564 zcmd5_ZBQHMo!?!(fWcsFjE%7|YX@w{Shj&APW*}x0tp17lE6tWlUN4Xk`dq{h~s#C zNt3&JuH~9{s!h^qJJZf|=H{k3-y{P#4VQMNGyRY@O|R3sAKKhZa-Z56Uo*|Ow)gx0 zpWW3i5(HbMcdgOBXtn!1zyJHovw1;sJ?IOmzKOAmsdQpeotU1wI6bAFo0wEH6VsE! z3H2P#t5^JyVD#$oP%t{+3rGAXeSM*mF@H36vbD|AHQ4Wq1;hQ(gU9YKi&}m(Jei13 zB}UZKiIMR{W+Z<3fZEcg_Qfx&Ef3s(1P4csw%&8}@cjqNy1dblc+hHobKlW>j~p!f z>o;bVZ4;6to#%h$lC*K7OvmdasY+7h>?<>sUBQsw7x8;z{?1U?r%2i7W~%l_W8VHw zZ=}-`>>n76?a$6swWw1Q7d`33*XLx?q3IA0c? zoH$rV1MS50qXfr#E3xDf{3QFblAYPq(&hnCJog_lD029fnSHCJxb%AV#hJ?1wvNGI zsMF&ej0M7x>l{k|aK{QzdEJFld=aO{17`2Ex&pqYPlWy#qkA zvjR75Fm4K1VxDjpqu%fB^LwHX^>u_pTCEdT?Oyh(0dFiomq)c)JdK740K_l}60LSt z+G-t{*k_nEwZQnC)mnX(wv&do#ki3%v}g>}?Zb$)2K`yp#wDHpp`g$2p)2W;4|L!; z-u05iTOw?kYq^6Ye_bL;xE!E0;bMmlnnMQ-+#(*3ohgs_ql2NCC-%^Q-*vB6-->}& zwYD*@cKiGN5pOIU(P~w#xms&>Yt53=12Rn|#x71>zL?mD8w`)7rxKZ|lbPwW+wF&y z*_jgk+dE^+jZuHh(;4;+_WAo`UQ!oe(C2a@CTmUL$eA5yr&H+>HLj*p8KH%yk_mM< znHU~TOfn6(7Qofx4S^eGrKWZ-Iv*b{)xEClmbrhUSQGiA=A7JM!=iOTU9<6z+ z)?5k}Qg&r$Dhw8CY29RDs3L&y5)gZBtS~j95^Jg#<5S7;_*lX-lA25mPfbi-W?1S> zu3)umz+y1Q-R<5Ea0bY~!j52$zLkY62aBsotKY48w`txg&0C^*oekR2E!wd%?YL7r zQ4AaO(d?UYY+zvlw#!Q;!qjRc=_Cf#?ZRq+&T|1+!^HrU$B=B(xF*9Yq;*}sP&n!@ z)!d3pD^ax4Vun9N!(VR@kGuz_&_;tor0PwceFkV}J6=q_(M&vw0n?!nRX~W!=(4X`M2C*QY*)aS?T6`{ zK7QEp!$ENsflku$1zk8t5|5{b6L2#O9qzS#ai8s|(Q?0r>`Ylal{q_oaBN~EG1f)` zZavY`T7;B8N{r$$7=;!7rPNeXy_8H1C*hGT5%}bUt^#ZFIOz_=d>Rnv+tPxh6@vcg zHto?W?a>nL(KQqFX#!v+eXljlO2iA#CN6yPaw6^iWOg*|h6A;j7`-`i;nu&mrj_`d z*xjFY#OKBCuCz10Aa=K>UGW>EH*slo+8uxUpVO|nEr3!|6(Iq?`Q&k3SL- z-XsigH0JM<mi(tJ5LjKfbVrqJFT(}w&=SD^znQFNW{l(M_rj-7{}2@OnSN#9@vhK_R(b0Tjr){ zbd>!eK7hUPU9ZL|vK!)i;P!OVc9D6&ewZ1tlIXsLKbLMZT!zh<(anK1W<|_V$g?Vq zYV`wJ^C_+QuvYKUn(MXtI<2`3ev_-$7JPK&{F?`IyL)gAEXRQG*fzs8<)dJvrPb5g zR)h`Vxe--%3sYePt*|7z%{T|Mkx(hPmR=W3F)LjVJnkY>?y{KjJvmcepEKoKg(<&q z>tD%`erpIW9xN3lMU1sn|X)fIp2+$Se z{mZA;#EA3shyb024@tqHO3|Upj^s$HwQe0!-~$e%@kPM)#Yx-I(!`Y| zM%iI`%!W0LRv293wnK#@bHpnnlc~oOa3hhXu*K*sh~J%+*0n=E@lO}c?*dIr4z!H) zk|}M93$j+u0x0ac!gtByH@BY_HWExUhwsuH?mnLoV`O20#)_+OrpT70#xW7`L{5d< zV|Q}i&Di}e%3umc^p=%~9H!+kr-MGlWAk~EwFbDwlC^X+X!SdUZb!P^mXCzqG8lu0 zWCnrekc=R3l}SLt;xG8iPXzM7L>iDT`g98;|7oSzxW&e~T{~K>9V^$4J1E;j+2zfK z@)+_*qKJk}pc=deP$a0f0}~|KQE)6abhc~twOVsIrQNDmMyIyWPz-?9li|RFO-__? zVC6(s(n_gT@1nWN4q4HTiz$}1w)p~nU$3XnAL-^?Q?0kd2URr}_z@C0?UZezDJ2Dq z%auqv897GSez*U@0Te|bl{Q`{TU3h5iWk}IXm)0UzU$F(bZmksR7Zn-11P#6<%;a9 z$Nz;vZ)gLPB1?JX4Ll%IdZO~W;&N~_?@E%C!<>6o&rZOy#LW;<7?Q{1>FI=;%Bb;- znt0+O(vgXggUkw>Y&e;WuzOsR8Xj!lEO|F8zRk`>IwYOGSqf}cI&!>FXMqi=*=1mZ zD`OxzEyZ$l`q^kKvgG?el=B|);%&1iv$My zd+#YqdC7G|k_X1(qX{)LJ(*Aw@nK|&;9#l4@p1KRLLEy?p4Y8^Je_7W49X#aP8VgE zHYm(kc$jH}3el`&5~rg8alAR=99V`pr5(X;zS}D3!jSFC5d)M^EX1f^i5O9$2H)VW zLWHPeLh$!{#bx`7!~DP+U~cM-0dFMAdSiVKUSDFv`^i))3i#|7r8EDZ5XcbOXVXNBV|{@>B_g#pc+WiZPB|+KKJjiJIb>aDcGAGg|~-z>2ZQ49y7b zxCk2O^ngD=4vIVv{~$ni35IY_2!SAr zeYzj;2!3O6b=kovrD(Fe(;xE31j<7U=s=j^eeWLn))(&gp;X_Gzn%PTe52Oj)Q+)Y zlYZ*%=4*fEs5B!=8`NYooQ#j3M;4QUR4QktbSt%# zYRpsQ>;4U?mM%y&LRUVsgjjqsUObHqAKylwiX44R+QiSU9c|J?o3?z~fIs46L>r3c zI8vhYL40I{&v9A@Za*Rsn|ujJmB=)>oN$=}#ZpEBMPf#7xh_zY)?r!09d7gldm&J7 z_mV(`bb)%3llm3&yMis{lmQZ`2pVi0z%_P zv`s?OmSg|BOo7>nNIXZ7Z6qvfM~Wwj6pi_$xG;^NT1P&vr__Kwtgl6Zn0|IsJIY*? zB?~Oz;E-Q$q#`b=ZpZNF0^~Z(b2UGx^T5{>o0}wx zaWmy2#v1a52K^59jpS>k0xBw+={MG)Qn(STxVe3e=GJVa;4(1tW(JhRMfV4$r;^Zi zmnJ4hh2=-nf|#h$ilu_p=V+?)X%}&NFn|+efXK2h_ULo|I;{CpzIWFVg zkbtJwk;s`slamj%k0QWkRRArq`~iRhOgc#4#ypIu`!hOwIAiN-26E`D63FF^VxLyu zr0uNL8q1Lbbg0=G7X?$DNI~#U2U0V<6E9LozD?k@@lGeV@?TEu@LVUYb0G>xTXik|v~Um&sH1cBourM4F|x z-RA`;%b>FWbPO)a)orRw_t6AsL+%t~WGO8;HVL?>s*n04!<8F@#|oHJL&pJRGFLh% z7O@3FtnuP>1}OqCONQzK+(Q;0o}9>J5Sxr&R;j2jFheC@XCXUg26;alu^+D`Vhr4y zj0*4muvj>Le0y*pO(Nj%_lF0&1Exl5U?tQ^P761eL9+aLlJ!22aO>`gQE`F;v3$J= z-nqqYIkyS6+02`FiF;7E>_d7mI1oZAOK-L<)f(k0e8)hL1F(v^K zx7c=sV*%ok$AE~JG&YHrWuKxd<2<>0#{P|VZ!&;1+;t?b>1RROhu%u|VCPkFt{1y{ zTr1p`-@Li8*HrAXD&A2!mfTCH#xKk^Egmt3jU-pf?@*u$In zF0rW*n{{I2Y|@TxquxhEX2;wEs4IIeH+hJiRpC+guW9^440l8=tHK&?0q9&0I5 zGyaz7cAwE0s*X$~GUI!ZY@lKcJgrO$%{$ZM=;Fz!mnWvh`4pOqQR%$hB z-W|l+wga{xFs~pQ<+|-gR;+rGGD-p1s@8&!qfGyP-Koh#4BQooBj@({@%&yaTT>=5%iIBg<_cSt}+zm z#?uxD%QTl<)iyHaZN&cgqyBs!{yOpJ$6puzx+}{-rovSMWe>94rMi!?&Qc`P<6zU- z$T^fSN2GzVp+p+Are0vQ)gK+g&eiNEE|Ibgym_y*Q9H2>B`~v0Swr1p*(($9w}sS+(x_qe4d-cAZbD?) z>5sA}*VSFwUDds*dov|~=i39p?k#XR77%tj9AF<~rW%(cl=~dAv|fjP{T)H??&QWA zs{48judp1uhU-nvBI`@u5#-9N3o~ux16wda6qsUxh~LkPpHR*#Wf|`R1&ibI`v~_| z5p@}`o0&kpzbIoAAE}Q5Aq9Cl9F%S=Kmike=>hL3;cq(9^IfAR5nx9bsKRlhJ=n{X zc)KS6F9c_d44~2jLjB*i$l!|s=% zcT`>@=IbPeHv*Zw6oK*xtWSRPqTRc*xOK}|W2cd!BCeF*ePJ9QYA`mgF){SJRuh;Wu4Sg=L-c))N7CckH zg1c&=smfd1M4=X|T(#P2p}WKxEKH8TJFCPwq({ZM9yCoro#7Pf4C2&~Hxi^}#H{Ot zdB;e_cOBkn(6R zuI(--8|Yt4a_Ov8nrcUNnEP3ptSuDF4r~dLsGkM>PE@WfQWBpc{8sNFBWJ4(#VuolA(&$&p>ns0KP??nT4a^Xlk2r)jbNa$MJ6NIo1=)MN+JUYzyE}!5 z>Q2AOXj@23Ifp))7sX%4Nb=%1Va~3Vi^mBlE6}O*45HE_;$h~bPX}WG54~T4CS68P zGD1b60cdf>(g!FM3&L8MzxDLtl^y&p24O95_uO}DWij5mZRtf!%8657$nWhR9H1GN z(+n5sLpP&~_W6}_->C4R6~T*V6z$=n`EZfd^>BJ31OB60foO)N&}vD!2?@jIS?Ltj z>TkWu0aO=x@Kv9E!g8^M7G6mz(Ico*r1LCI&f z=xF55WbWC$b9b_t5V;pUloOYL27ri9V&%j*-bHXOKAbp!m&0(>!*zMc>SZ;47O#%U z#XfLgn7DZDgCK32SoosQ!WViQ2(4kgaO*p??B!X2$)#Ux#Xs&t(plgG*}j6sc=H8C z?JS>;Lzl0+n19Re2JJ4SFF0IK7D*qKGo~Vw!-_-s0F0!+ zfyK!E6pi?YcY-)i?pJ#Oyb=r()_elXQSO`vNg;lC2N3U?mDok6>I=D=i)mK@talZ_ z+PRfSy~rV%^1BK^?ixVDd5aFV?1pM}1^l55At@io)Y@8R^U(B1%YT}cnv-+w=yeIc5PUYd5U7$D zdIEKGlsnKjVlSx7(;99dD*wseLP7F?SJ$vPbEtHM^v8PMWW~aVqL-Y=e9n$p#a6VR*NQifL^7=>!mB|3jynU(f{y(ng3fq}V1)~H61AlxR+<8{e^~`T7ICH3k=jLN=`Mx&I)M+O_;ZpC~lYCYJJ=-9m<0q2&g;Lk!f#sfN!cx^09{ z&PpC~%`i&*!>II^%iz>}AX$gaLa+y%c!M}$u~#?WPud&o*taQRa?59UjIvKq{U(=` zrEHbEq%!{is z94{7lhRtv|>bbjK`MrLBnb(Xde=r{N{HzorAWi#3fN|3`&|9Q~g}?;^$hR5IVA^%- z`j(z_#jV$SQ@3VAqzrCZI|7vFk;hyb36ye`Sy|i*d0I!WpYu=_fKhi~p&gKQ)C-IE zdtOVmbl^%g!}14x{Brx(0y>%G5`ul*ev#h;qha z&Kvjy>pTJ-^qJDR;5g=F$sXo$L5IJKBVe?Bq6@>@g;ySN!y%CnN2W=dq; zl~2|jG)!Il9i6`tbcMB zvwTTeR|^>1EpD&X?qRc7De8zn6a~ajnO<_Sbuq^y!* z4p>$y>FQbpYdW*OyGph7u3c@}msu17SzbYD?aAZr9D0_X;^hpTP+&yyHC15m5{&n( z2qPC{dDYhvEJ11{Y?;%H&L}YvV(|$JE1$6J-!8k)iQfj8?fG*aS%WHGx!*xvCW(Vy zzjR!M=eAmbs7MKcIHw&uE%v?uzIO2%eINF)ELW5Sjh0hdUYTP7k}Z;&+!-P#$;>A6 zhoYhCp@qsC*(7MN^jiep-Nb*%;KO@i~}if}F? zSXN9SVyJrv5i{#^Bwl*`hH@$1rBd)Jrn<`TV(D^p76iNtwdl3Kj#p{^JA^f*7fP9( z&M>T43zwpI7co=U_X}rN5V0@i-z-$ z(m%o4ai=Ew?DdzMxVl^JJ<=v~dx<=RAvVoQmAEY?lnb9Ked$De+%tWV-<6aB=|#qw z?((!;p*<|qoBv(jj&LLfdwPgRzE`x!8DW!<-39Rq#8(7-G;V28j6OM!)E6eR(9T`< zv?_#_-<#=Rb5Z`=y;i)PjJMk!NG`#9J|u90;lEyY0n@tmO}cFm$1l@zV_Sl0p+JIZ z9Vj7vRnUWWzf8N1XCLP?HR6?%*-p*<0H288MH}f_t#(Z0`hM#0(i!FBlUnIstktJ) zzl4SNf#3+Tws;{5#=uCJyUHRBkm>4PH0eq=anO3TLNvTb;oO$;JA;(+R(^yu!~}IR zLERh=^L^eaL`DAQKP2fMv0??w(=BVD@d^R?3YJA1FQ#>zq08mH5wQ`2qPMWDqrnrd z2+{KXqZ9bb`0qHl;JuXU{~d=YBD?HM4y~Hr)Zq&cJQN9b2V&Wm@Z$Q74<;rjp1^;* aWAfqzUSx+(K0LPMN7AbV$1nf-*Z&0wzs*bl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/24-1-BREAK.DFASL b/internal/test/LANGUAGE/AUTO/24-1-BREAK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..19d14e50c6539ee60be4936844fbfbda5c721704 GIT binary patch literal 1632 zcma)6&u<%55PoYXj_oAIj?w~2T5pR=(ZVxvNKr9T)%E&0Hd*hQ{XvKjLXN$O4Yt?v z4^XHGRW4jsDkc!^E9wP_1GgSqQDjA&kT`PSfW(mt2jCwF^VW8V0#b=&W#_$l-+VLQ z%=FRZo07~+cB56RTW#L%bz8kIziqeqj@@gQEq)u$`CF2zk&kksw4Qi18P-qTl-pLR zYgKroXLTy2-52=eE4S`jK6?J)t_SiS8spV^_<&{ME_}(EG zwGl#PG+_Ti2t|<}xt}>v!63SUvw4|dMJy1(?YmA8a>1rfG}no(@Ljuw>(={Lou$+0 zAPyn-Qzw`;70Jk}ihID_=4RYG&TL-6MMzCtBghvVp)hpLb!JyqaT2FBBCex*hrxZ| z@K-GAV_d$iK3eAQ_HeBkMj6(E9hE-k4_q>=#661|VzY^Mm_uvx6~@KgT?R z00V{k-{4RFCpdt-wg51LYLr#w3uj4?R3(#VrNcQ<$;d>*={%e$Yr5bI(2#EubcqR) zXh=D%5yRA=u97EAK;P62QtKSV?RSOBXBSzeONdH`JIGP9}x*_)Fju_M}p?Sqyba z()e=#buuPbz#%HBg#t*9GkLwpP(8XJz z@~My=tJ`aR;5vy^nt+yMIPKmFW0Zy@#?klm5ub$Q9t0rv)F?F?re#|kaio^ZNutxN;?)`>+rBXn{21nw)qm@*==mub-r5a@J%}$^8Q+FyJfYzyL_|M z0Kc-`Xq1{2LAY>;F5W!y{lIq5)d#tL?RNFx-CV@mpf_QWJccMNNX{D-m=@RZON9)# wKre6sin()4(yBEM#X}u|Xs_9}%JxpP_Muftpb1Y;`YfnLuhKCML>TEST>24-1-break.test ;; ;; ;; Syntax: (break &optional format-string &rest args) ;; ;; Function Description: This function prints the message and goes directly into the ;; debugger, without allowing any possibility of interception by programmed error ;; handling facilities. When continued, break returns nil. It is permissible to call ;; break with no arguments; a suitable default message will be provided. Break is ;; presumed to be used as a way of signalling errors; it is expected that continuing ;; from a break will not trigger any unusual recovery action. ;; ;; Argument(s): format-string: Error message . ;; ;; Args: ;; ;; Returns: Error message or NIL ;; ;; Constraints/Limitations: Due to the nature of break function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. Tests requiring user interface are commented out. (do-test-group ("break-test-setup" :before (progn (defun command-dispatch (cmd) "**Error message is printed if a symbol has no property named command**" (let ((fn (get cmd 'command))) (if (not (null fn)) (funcall fn) (break "The command ~S is unrecognized." cmd)))) (defun turn-off-val1 () "ABANDON!") (setf (symbol-plist 'emergency-shutdown) '(command turn-off-val1 switch emergency reactor-status 7)) ) ) (do-test "break-test-0" (fboundp 'break) ; Is the function break defined? ) ;; The following are tested manually: ;; (do-test "break-test-1" ;; (break)) ; Should break and return NIL upon exit from break. ;; ;; ;;(do-test "break-test-2" ;; (and (command-dispatch 'emergency-shutdown) ;; (let ((cmd 'switch)) ;; (if (member cmd (symbol-plist 'emergency-shutdown)) T ;; (break "change the emergency-list to include ~S!" cmd) ;; ) ;; ) ;; (if (member 'switch (symbol-plist 'emergency-shutdown)) ;; (print "Switch function is now activated!!") ;; (print "Switch function is still not included. ;; Critical Time: 10 minutes before meltdown!!") ;; ) ;; ;; (let ((cmd 'shutdown-reactor)) ;; (if (member cmd (symbol-plist 'emergency-shutdown)) T ;; (break "change the emergency-list to include ~S!" cmd) ;; ) ;; ) ;; (if (member 'shutdown-reactor (symbol-plist 'emergency-shutdown)) ;; (print "shutdown-reactor function is now activated!!") ;; (print "shutdown-reactor function is still not included. ;; Critical Time: 10 minutes before meltdown!!") ;; ) ;; ) ;;) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL b/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..305bee876ef5da55f3e36389bf9ab379e9f66d6a GIT binary patch literal 2962 zcmbtWU2NOd6~2^g*RpIw?%Xs{ljb_D*OWEY*>$_l>5plNj#SH}LQ-?wAGEYgMQkNe zC8;=BTQvxZ1qcXaYEXkWMSwnbPiu=ltXMX0*oHmsr7s({_dOO^9|{zOdk!hbuDc}} zCWtsZ=bn4+Ip6)xz3h_y)7c`;+KrY~HyvuXy;j?!RokJi-F7M_t%9AtkyTXbt-P3B z%AA-U()Ns09Mka3b*i^bcilKYMW=s4#g=2$;pNFEL7kp^d}eNTHZ!y+YQ-qpZRgC+ z{pj(z>6y&X_VrCJWfMXwWD7-tkQ9lN;9Wn(>yoAmi-n>j$l|iZ2i?FQgj$5MCaHlx zHbXtTCDhHcW*y6ExP&7l_=P{XSeCPTL6L*2+y!npxZ;l#WT6D5i6qLS;IBNqwb{yvt9VKTp|-B{v2Ym#66b}6=UAU(znoFN1UMhMx0*PfP) zwEuCyx&hPgzIfLdSNrVc(Jf^Z)GxZlE6V5}3F+1@DWgj<4i@TulwLWAvGExsWEfVn zD(S6{IUX&&9J!&L90wr|pm@j8@BNR__l9olgifFpVs~p7?mYY3$N$?-{E;Yi1mfE6 z>xJ6?Sqp@EE)8jK)lwuj61?Xh=Cg{NDY9^(;Jvqedi%Ozn^QI|EIaWU@uvvq}M$#{|_ z;z-OI*?SEiRX!4`*)nAa)OW zy~z%tc!7)T-MUs2RtDKejD z$I$#VJBng9nmQQ@^3TvnK996NN8)$5M-eV>v!iDjJ;UhpV7qy6t*}Eyc1UCoJ_Ac7 zmt^?o1tLlx6;Y)9}+*Ar&Ycq8zS>Y&kM9q|~g8gRm| zQ>z&r&S>jQqFW_+Ke&nnzCWur`3MrKnDQ-@4Nnu*4oh zaVWSN=VEbujfYFH;}C#79D(uW?o9KX<$BM8ANeAjNk06(`z9Rqdkb_;uie5a?*@Km zZb1UFOVRlsUTO$JRQ6829j%8z=B2>T(?XMaHOr;uIit~no6n$i+ip>?v|T{Sv#Hs1 z+l~odh6ke>QDe0Y7~$vBS}K?&dRekj4<8rk~jA9$U? z9mJn1OX{jnQ24-4*Nw*7x`A7=zq#QO#cY^OFN~5QxxjDmypGVpzhYn*x^^C5GO24; z?B+V{ZPQI;!Q{YhIZd|*piZqSwY)G(+Atey_(4()Lxc$nSPR_gzzUv!Vv`KdBbtZ1 zRtk>pTf+ui+Xow1V!_n`HUR{WVGo1k#8C8yJ;e^PV~A|Apy}k1z(-R3e78ivaikIbhJgv4Jz|HAR z1L8Tr1*eEzj<{0<1=$phQqzea8n zF^@!?f3+S53FccP2Omv)k%N0g8^{4H16p}OlTJOw9uQCyOC?Fp@$3`@0)iols0l?$ zKB?zP|BnNIRkv;0z~astb@*09a(A>7oyktG%0z+!9*zku2S_^R>ut+Hr1p-l0X`j- zZXnifyVa^gr)3@s{Nsf)O&e^$x}ESw74QlHu38TCd>A@22}chAbTIH=!F;OFAOAI- z#I3VQ^pfe!y@2_2PHY%%=cV1W#^I0^UANtc8p~>)*;xwf`CML>TEST>24-1-cerror.test ;; ;; ;; Syntax: (cerror format-string &rest args) ;; ;; Function Description: This function is used to signal continuable errors. Like error, ;; it signals an error and enters the debugger. However, cerror allows the program to ;; be continued from the debugger after resolving the error. If the program is continued ;; after encountering the error, cerror returns nil. The code that follows the call to ;; error will then be executed. This code should correct the problem, perhaps by ;; accepting a new value from the user if a variable was invalid. ;; ;; Argument(s): format-string: Error message (same way that error uses it). ;; continue-format-string: This is given as a control string to format ;; along with the args to construct a message string. ;; Args: ;; ;; Returns: T ;; ;; Constraints/Limitations: Due to the nature of cerror function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. (do-test-group ("cerror-test-setup" :before (progn (defun cerror-example (vals) "**This is an example of where the caller of cerror, if continued, fixes the problem without any further user interaction**" (let ((nvals (list-length vals))) (unless (= nvals 3) (cond ((< nvals 3) (cerror "Assume missing values are zero." "Too few values in ~S;~%~ three are required, ~ but ~R ~:[were~;was~] supplied." nvals (= nvals 1)) (setq vals (append vals (subseq '(0 0 0) nvals)))) (T (cerror "Ignore all values after the first three." "Too many values in ~S;~%~ three are required, ~ but ~R were supplied." nvals) (setq vals (subseq vals 0 3)))))) ) (defun known-wordp (word) "**This is called by the second cerror-example and returns T if it is a member of the known-wordp-list**" (if (member word '(this is a known wordp list)) T) ) (defun cerror-example-2 (word) " In this example a loop is used to ensure that a test is satisfied" (do () ((known-wordp word) word) (cerror "You will be prompted for a replacement word." "~S is an unknown word (possible misspelled)." word) (format *query-io* "~&New word: ") (setq word (read *query-io*))) ) ) ) (do-test "cerror-exist?" (fboundp 'cerror) ) (do-test "cerror-test-1" (eq (cerror-example '(1 2 3)) NIL) ) (do-test "cerror-test-2" (and (eq (cerror-example-2 'WORDP) 'WORDP) (eq (cerror-example-2 'THIS) 'THIS) ) ) ;; The following tests should be performed manually ;; ;; Does the following test return the delineated error message in a similar format ;; if not totally identical? Is the value returned after continuation equal to ;; '(-47 0 0). This is for the first condition where nvals < 3. ;; ;; (do-test "cerror-test-2" ;; (cerror-example '(-47)) ;; ) ;; Should return: "Error: Too few values in (-47); ;; three are required, but one was supplied. ;; Error signalled by function example-cerror. ;; If continued: Assume missing values are zero.") ;; ;; Does the following test return the delineated error message in a similar format ;; if not totally identical? Is the value returned after continuation equal to ;; '(4 5 6). This is for the second condition where nvals > 3. ;; ;; (do-test "cerror-test-2" ;; (cerror-example '(4 5 6 7)) ;; ) ;; Should return: "Error: Too many values in (4 5 6 7); ;; three are required, but four were supplied. ;; Error signalled by function example-cerror. ;; If continued: Ignore all values after the first three.") ;; ;; Does the following test prompt you for a new word if the given word is not part ;; of KNOWN-WORDP-LIST (THIS IS A KNOWN WORDP LIST). ;; (do-test "cerror-test-3" ;; (cerror-example-2 'NOWN) ;; ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST b/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST new file mode 100644 index 00000000..d69b96ba --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: check-type ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.1 ERRORS (General Error-Signalling Functions) ;; Page: 433 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 5, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-1-check-type.test ;; ;; ;; Syntax: (check-type place typespec &optional string ) ;; ;; Function Description: Check-type signals an error if the contents of place are not ;; of the desired type. If the user continues from this error, he will be asked for a ;; new value; check-type will store the new value in place and start over, checking ;; the type of the new value and signalling another error if it is still not of the ;; desired type. Subforms of place may be evaluated multiple times because of the ;; implicit loop generated. The error message will mention place, its contents, and ;; the desired type. ;; ;; Argument(s): Place: Generalized variable reference acceptable to setf. ;; Typespec: a type specifier; it is not evaluated. ;; String (optional): English description of the type, starting with an ;; indefinite article ("a" or "an"); it is evaluated. If string is not ;; supplied, it is computed automatically from typespec. ;; ;; Returns: NIL ;; ;; Constraints/Limitations: Due to the nature of check-type function, which enters the ;; debugger (check-type), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. Tests requiring user interface are commented out. (do-test "check-type-test-0" (macro-function 'check-type) ; Does check-type have a macro definition? ) (do-test "check-type-test-1" (let ((array-type (make-array 10 :initial-element 7)) (atom-type 'adam) (bignum-type (+ 1 most-positive-fixnum)) (bit-type 0) (character-type #\A) (common-type 'abc) (compiled-type #'cos) (complex-type #C(1 2)) (cons-type '(a b c)) (double-float-type most-positive-double-float) (fixnum-type most-positive-fixnum) (hash-table-type (make-hash-table 10)) (function-type 'xyz) (integer-type 10000) (keyword-type ':element-type) (null-type nil) (number-type 820) (package-type (find-package 'user)) (pathname-type (make-pathname)) (random-type (make-random-state)) (ratio-type 3/4) (read-table-type *readtable*) (string-type "hello") (stream-type *standard-input*)) (and (null (check-type array-type (array))) (null (check-type atom-type (atom symbol))) (null (check-type bignum-type (bignum))) (null (check-type bit-type (bit))) (null (check-type character-type (character))) (null (check-type common-type (common))) (null (check-type cons-type (cons))) (null (check-type compiled-type (compiled-function))) (null (check-type complex-type (complex))) (null (check-type double-float-type (float))) (null (check-type fixnum-type (fixnum integer))) (null (check-type hash-table-type (hash-table))) (null (check-type function-type (function))) (null (check-type integer-type (fixnum integer))) (null (check-type keyword-type (keyword))) (null (check-type null-type (null))) (null (check-type number-type (number integer))) (null (check-type package-type (package))) (null (check-type pathname-type (pathname))) (null (check-type ratio-type (ratio rational))) (null (check-type read-table-type (readtable))) (null (check-type null-type (null))) (null (check-type string-type (string)))) ) ) (do-test "check-type-test-2" (and(setq aardvarks '(sam harry fred)) (null(check-type aardvarks (list)) (setq narrds 1) (null (check-type narrds (integer 0 *))) ) ) ; Should not break ;; The following should break, print the appropriate error message, prompt for ;; a correct value, and return. ;;(do-test "check-type-test-3" ;; (and(setq aardvarks '(sam harry fred)) ;; (setq new-aardvarks '(1 2 3)) ;; (null (check-type aardvarks (list integer))) ;Enter new-aardvarks ;; ) ;;) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL b/internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e2872f6004a874504bc851bb99ebf304e2696191 GIT binary patch literal 1665 zcma)6O>7%Q6rQyc$959qgtW*8oNc92v@ixIDJn*)x>=87ll88|3iXyAx0%wjKI3RIENL=6)-mIN83P{D$%JXL4y!XBD zd-Dcp@=ZzRCA-yWG%bg>`@K%T$8XsV-?jTr)#A5cpT8xk8u_3gO6%#@GEx21N!76` zJ*&nWeXCom?7YZlUggD((`drt>Qyi^*(*!gm6dcfFY59r+GFpmWM96LU0zN{kM16D zaT_62MML%%K`4%b$os^N3kJ~*oG;1*D`JTV-oSIiPzyG7qIvGz65q2sxM{s>HCZ{W zF5(dKK6b--Q<03Ks(Aa{ZEnW9|nvj`1gIku)p)~SPs{`CbkY&-y;`Ms$p zxcdFKV?#9t<{tz3jvD(Op+Ws4HMSn$All$Cv9Z7curG|z41{b{&kql4Y~vWmU&lDY z5C(`EXZ+tep8C%m5bO0ML>t!QjGWKhX9P)Aaz(}SS4`TB(PP2C`+Kma@zMgmGQ5f!tH^Qu+QZJUu(3QHO0VkN;Fh^OwgsX8$ zEtP;YoGa>OM$k#uvVLO`_UOWg^qfu4XMyVlofvtnZm;2RNrnW(hEg zOp6Qj=_tGZJ0O@WYwDW9tRI-=)5WYIw0}rpb^2u=(nYp=4{*(s64BO(B5h*5U>Z4f zL!pTpO}#}IWx9Bc^2^{9^`%tvc?`T|XySPYe)5_w(PWY)eG-0wXJa{z?cko(?XeU; zd+wqEYyRS{c#+?#z(}d_jrM37u)W<&%!MO%{OBJQZiHxlot(Cr-`Xo4p4|a!#MKXWV6z`S*x(J z&-NyGjC&Iy4x0Cb1oVRE%7Q=`nS9IYb}QQ!-{|r%U)yZxHn#W*-`#25w3~dr(&gKB zG~)j{j@_}G-VWccw7{=ww_25UO%R?vK&k5w13$9iboraYpmDpt|4t$1kJ#%lX&wU< zCMf4WB6vrh8lelgjr{aM}0NQUmR@L5aH{Q2uX*A*MNuL9?=w+Hh JpICML>TEST>24-1-error.test ;; ;; ;; Syntax: (error format-string &rest args) ;; ;; Function Description: This function signals a fatal error. It is impossible ;; to continue from this kind of error; thur error will never return to its ;; caller ;; ;; Argument(s): format-string: Error message ;; Args: ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group ("error-test-setup" :before (progn (defun command-dispatch (cmd) "**Error message is printed if a symbol has no property named command**" (let ((fn (get cmd 'command))) (if (not (null fn)) (funcall fn) (error "The command ~S is unrecognized." cmd)))) (defun turn-off-val1 () "ABANDON!") (setf (symbol-plist 'emergency-shutdown) '(command turn-off-val1 switch emergency reactor-status 7)) ) ) (do-test "error-test" (and (string-equal (command-dispatch 'emergency-shutdown) "ABANDON!") ;;(if (string-equal (lisp-implementation-type) "Xerox") ;; (eq (il:nlsetq (command-dispatch 'emergency-shotdown)) nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL b/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b8223d4124809b293ef7fce6eadc4fdc079ad2a9 GIT binary patch literal 2270 zcmbtVU2NM_6ux%4w#k~-{n^?^V{3e3d#$$GHwZ(B_kr7)vQ*j3XsWlytT0{PH8+}3#XOWIO(}%!+(JQg#&g4?V`4&_ zlXR8bT#sHMg!#Tg$dQ*@y<7+r`k{C$%WPK2jUTh@TrAehbetmuC!&P3;Bm{^A6UC4 zZnJ0%kXGpy#PnV1=x2(XXSkNef%(^J?wZE^M96CKJ&nt<44|!U#O4m+8vJz<(gl#E z!r|7}%n|f#C-V1pB4NM*y8biz;6u@OK{K1%(9r-I=OD3fUhC!d2cFg9O3ANbP2)Bc zoS*&&N-V-Z+nT;ZnAed!^be5f0k-?hP)i%adaqC4VK)Y}A;09S+7QJ0Mfa@~|7QV! zJ`)2TT1Aeq`(d~Hg-KnJW<*W(w>6_q83G&iK5`EUvZf|8C=D?!smZLOi<24f_z__m zWjo;44%+J#WXY7%qOO>h4%(4@@wFTChNXfsJq*{3~rRh0CpbX1AxZ2bN z+7*h>Xs8>q>lPGU*K|>{%)Dg^p&nS!B}nSL==%}GbGgJGZAU_c&^8owA4>FF0BTcS zl(J}i4n{jBAem@>h8f6~t}E)U?x76MUB}GtkswQk611Bs$CYXvEF&=`b}Kj;A*ey0a<_{B#jUt+qGnx!W5 z=zTwkd6ynsrh^l(O9O^trbJ^tH>qXC?N&Ys6TL7YCN$^l`;?rbPbsQAFB)mhOlor~9mbfp zy_43xN%FIgLs~u#*$9R&X!tzkZ91aUkt98K8UP}`jbh6Ll_{kL(Xc3r7Ivr z{JL$&O=*hhp)q!lj&#wZgkUa$_p!Ie!n+R3(1@lY?onJeV=B6oHE0)x!Dh``nyCak z0$FrQlOQ}z#f>6=`dBm$k@Ts6?B6`MZ-*oCf?Y4!XO|od{*|7+?|5#{y)_M| zxm>&Cx$*Hy1sX>Qt`GlCMBW3cw>iFSY_T5Ccx!k#bZoT-9j1?i*>22bpg$;fO?XE{ zzS#}s%O*6t0eZCzI^6NxI%&t#kt3cPTe8b%7wm`84G~-I4s-&~JCu-w=Vk>#sn_BD zE<25eea_)a4Ib{}3SQEsMc(Ec7t3d>OMKC8@Re#L?0;(YYR#!PFY*<;3~_~OxolS! z1mV~^IXrQjy@U7IiSN>@rIq5^`E<8`B~QTF|A<84#%26-$(KV&&Lx=`>}VU_r%XG2 zo;iT>EjrsTCML>TEST>24-1-warn.test ;; ;; ;; Syntax: (warn format-string &rest args) ;; ;; Function Description: This function prints an error message, but normally doesn't go ;; into the debugger. (However, this may be controlled by the variable ;; *break-on-warnings*). Warn returns nil. This function would be just the same as ;; format with the output directed to the stream in *error-output*, except warn may ;; perform various implementation-dependent formatting and other actions. For example, ;; an implementation of warn should take care of advancing to a fresh line before and ;; after the error message and perhaps supplying the name of the function that called ;; warn. ;; ;; Argument(s): format-string: Error message . ;; ;; Args: ;; ;; Returns: Error message or NIL ;; ;; Constraints/Limitations: Due to the nature of warn function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. (do-test-group ("warn-test-setup" :before (progn (defun command-dispatch (cmd) "**Error message is printed if a symbol has no property named command**" (let ((fn (get cmd 'command))) (if (not (null fn)) (funcall fn) (warn "The command ~S is unrecognized." cmd)))) (defun turn-off-val1 () "ABANDON!") (setf (symbol-plist 'emergency-shutdown) '(command turn-off-val1 switch emergency reactor-status 7)) ) ) (do-test "warn-test-variable" (boundp '*break-on-warnings*) ; Does this variable exist? ) (do-test "warn-test1" (and (string-equal (command-dispatch 'emergency-shutdown) "ABANDON!") (let ((*break-on-warnings* NIL)) (or (eq (command-dispatch 'emergency-shutdown) NIL) ; This should not break (ignore-errors (command-dispatch 'emergency-shotdown)) ; should not invoke the debugger ) ) ) ) ;; The following is tested manually, in which case the function warn should break ;; or go into the debugger since *break-on-warnings* is set to NIL. ;; (do-test "warn-test2" ;; (let ((*break-on-warnings* T)) ;; (command-dispatch 'emergency-shotdown)) ;; ) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL b/internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..373d67f93dae1a183aacfa335a2f92c133ce6d27 GIT binary patch literal 2019 zcmb_dPfR0K7=P39r!BCwgn%h*_l1Q7D?^qp#FgDdhv{@Fv{Rg!Qi$;|Tgpzge@I)_ zC99+%akGapY?nypX?Aa3^nzT>%0>=)FvjRjZ+rIWpJ-xYg5Ni@uplOS*e28O@B6*q z_r3ScG)VJ;n4n_0xRNjADzv;>TUo8q<#L5q%d3@ajxK|r-V#%a^v<*(&W>Il^Qp%o z*-B2Y<(8^7#aw0N0K0fM;32MSY`_DDwlNTl?Cte)& z9o*mM{AEH&mh7YO65=OrV%;Zkw+EtYqqT=K9)2N%{&QpYJ^4#Q8pdsT z#>I7jw$q#GK?r<2gtQZ~pU*yL*LR5e$02GfCS?bAp9d&ZVf{X+yS?xS%>Yyb#Qx5& z4Wpi~8+GHE?9bH?_xBV!vUI=Doel06LfL`c7cw*x{H)AEBJeJ|&w!f~Sis$h$`mMmP+F658FRr5*ru@X#OwmI zMb!i?t+D{j)A&E1r6dIn%|BszKujx&Bp;hn#$oIyh;={h znh5(l{8<}@_n@n7&dBjGA)Y|rXMo-*D2lMiN8?FJR-xVK|CEJLeBy|Y9I@?)yN9^Q96pPGeKF|8lim`qaee5g<^1U4+-`X+q$c~XsCw2$;pP3gD^Aay6 zQmPc?=UCuvVBM`sT8vj0lT)b#fB2qBv0#GrU19w}Jiw$NDygHGA9s8V{$~69(E0)1 zQ7tm|(JuTOHi+IU>^zEb#~QW;*|nYIW5;^nhH;Mp%Fi aWlqwWwoKo#W8*JG*)Vr9g?u0#9Q+L!ElCML>TEST>24-2-assert.test ;; ;; ;; Syntax: (assert test-from [({place}*) [string {arg}*]]) ;; ;; Function Description: Assert signals an error if the value of test-form is nil ;; Continuing from this error will allow the user to alter the values of some ;; variables, and assert will then start over, evaluating test-form again. ;; ;; Argument(s): Test-form: any form ;; Place: each place (none or more than one) must be a generalized ;; variable reference acceptable to setf. These should be ;; variables on which test-from depends, whose values may ;; sensibly be changed by the user in attempting to correct the ;; error. ;; String: Error message string ;; Arg: additional arguments; they are evaluated only if an error ;; is signalled, and may be re-evluated if the error is re-signalled. ;; ;; Returns: NIL ;; ;; Constraints/Limitations: Due to the nature of assert function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. Tests requiring user interface are commented out. (do-test "assert-test-0" (macro-function 'assert) ; Does assert have a macro definition? ) (do-test "assert-test1" (and (setq status '(switch-1 switch-2 switch-3)) (defun valve-closed-p (x) (if (member x status) T)) (eq (assert (valve-closed-p 'switch-3)) NIL) ; Should not break ) ) ;; The following should break and print the error message as indicated. ;; (assert (valve-closed-p 'switch-9) () "Live stream is escaping!")) ;; (assert (valve-closed-p 'switch-4) (status) "Live stream is escaping!")) (do-test "assert-test2" (and (setq minbase 10 base 20 maxbase 30) (eq (assert (<= minbase base maxbase) (base) "Base ~D is not in the range [~D, ~D]" base minbase maxbase) NIL) ) ) ;; The following should break and print the error message as indicated. ;; Note here that the user is invited to change BASE, but not the bounds ;; MINBASE and MAXBASE. ;; ;; (setq base 40) ;; (assert (<= minbase base maxbase) ;; (base) ;; "Base ~D is not in the range [~D, ~D]" ;; base minbase maxbase) (do-test "assert-test3" (and (setq a (make-array '(2 3))) (setq b (make-array '(3 2))) (eq (assert (= (array-dimension a 1) (array-dimension b 0)) (a b) "cannot multiply a ~D-by-~D matrix ~ and a ~D-by-~D matrix." (array-dimension a 0) (array-dimension a 1) (array-dimension b 0) (array-dimension b 1)) NIL) ) ) ;; The following should break and print the error message as indicated. It should ;; exit the debeugger and return NIL after an appropriate change is made. ;; Note here that it is probably not desirable to include the entire contents ;; of the two matrices in the error message. It is reasonable to assume that the ;; debugger will give the user access to the values of the places a and b. ;; ;;(setq b (make-array '(2 2))) ;;(assert (= (array-dimension a 1) ;; (array-dimension b 0)) ;; (a b) ;; "cannot multiply a ~D-by-~D matrix ~ ;; and a ~D-by-~D matrix." ;; (array-dimension a 0) ;; (array-dimension a 1) ;; (array-dimension b 0) ;; (array-dimension b 1)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4809f1ccaf08f59c973cf86133d9f5ebbb0711fc GIT binary patch literal 1739 zcmbVMO>7%Q6rNotO>pdBJ8l}>U{(%9XvK!+2UHR+o6R_OV(*0AwbJxrnT>-@ojQu0 zNEJ#|il{0uv`!$}DarvPuE?BFDa2B_a^}v30}@ijjZ=7UHwmGsRHwSsTULa^c!*(&$@~y0%`ffO7F7n4^<#j7?5VjQEqPneot`nlmwZ;myg>@e%*Q z-mVa;5<+a!M)4dWA>t#>b|WNP)U=djIzts*%~IKEI*o4VMah}ea2nw;sa{=ED#guW z1>0Gz5rGirZlgPy(={v2bZ1AnAq1Q|jbK_=7N9kCmJ+f15Czc%rx6^RP{tKaQ%y?t zcKtUA5%#c?EYx~m7s5gh>j#)eUqEH8sT2C^ zo}M3Qvw>|k@bQVIXc;nCKcYf2`Tln6=LmqZki#M@It+W=ddAK-SW)&HakHcO#$h=@Hv4&l-<8}J;(F6Ya}psX={CXFYrq*Q$-Lk(p* z4IX{gl*LXS5IZ0Pw32H)SsPLcGTp27jlTSxBio=!>AivUC=WJ}^2iQw#Md=)Q$i zng^f6XFtr4cOZ)+NXsT{e}`Ap*SBphnu>W zfD8PI)9A77LanIOi?#YF;0d>!#!D6$QsTOrkX8zCX)a6UtKNNwzU!}G*nqRs!TWfW zpY>{c_?W%7OYkBI5vOs!QdoU=xqu+2uQKSsJ9;7@Cj)R=3Y@*-5r+_L@zZC+@=vRV zi*?9ILasd{5b(nVI^;Pai_TZhjtKR}HG`@aRUYGDCT&qe&6vCw!(im^CML>TEST>24-3-ccase.test ;; ;; ;; Syntax: (ccase keyform {({({key}*)|key} {form}*)}* ;; ;; Function Description: This control construct is similar to case, but no explicit ;; otherwise or T clause is permitted. If no clause is satisfied, ccase signals ;; an error with a message constructed from the clauses. Continuing from this ;; error causes ccase to accept a new value from the user, store it into keyplace ;; , and start over, making the clause tests again. Subforms of keyplace may be ;; evaluated multiple times. The name of this function stands from "continuable ;; exhaustive case." ;; ;; Argument(s): Keyplace: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of ccase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "ccase-test0" (macro-function 'ccase) ; Does ccase have a macro definition? ) (do-test "ccase-test1" (and (setq x 'alpha) (defun foo () 'foo-for-alpha) (defun bar () 'bar-for-omega) (defun baz () 'baz-for-zeta) (setq alpha 1 omega 2 zeta 3 phi 4) (equal (mapcar #'(lambda (x) (ccase x (alpha (foo)) (omega (bar)) ((zeta phi) (baz)))) '(alpha omega zeta phi)) (list (foo) (bar) (baz) (baz))) ) ) ; This should not break since each of the three clauses is satisfied. ;; The following (ccase-test2) should break with the appropriate error message, ;; prompt for a new value, and return when the new value satisfies one of the ;; three clauses ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; ;; (progn (setq x 1/3) ;; (ccase x ;; (alpha (foo)) ;; (omega (bar)) ;; ((zeta phi) (baz))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ecaae617eb7f2d4a9e5c391d4c894757eb4b25d2 GIT binary patch literal 1241 zcmah}&1)M+6rWvL)~B7dan{8a>DEwEmX7gPLgECQ57FTF!DMQ*pZOr zKqv_&hvc#)l}*h~Oa6lvL{3c;B4}?t_7CW>=UjUT&YN|<+7xowoq50a<~Q&6-rMb> z_*Kg`tj2D$zT>xy#$Knn*D@8jO|e5t)C{{}kOVEb>`^xiM&^u8qltI?TmFuev)e`r zLg9BoGGBHqUSv*qsO&4*@L@1ibnrSzBP$fC$=58BT?vEXxdl9rExxf%E#gu1=qPy) zp_80`tvy{;p4>#+&sNpSClez|{6>`FQ&>jtB}SFnljjcXUv$^Lb$&;vTf6V9s>%@T zdgGM|sYgCZgt7?r>(yK&@inV5@rE@K>DM1$tLV=w`gN^e(dUhBeZO{C(R)jPi~<7m z*T?#7?0}6uV59H+Q%nQbQALN!^-k9z8%NUB(s8J%-tYY^t>gXL$8$cY_4NNsx?9ug z8d4MC_d(9In6q4z#l;2UEZfw@OGQAO70*=TBBc&M=SED6aI1h_%F8ZP-ilf`=xunM zmQ>}#2+mBAiDkf{Tz%VR*`HWeq+)64;IK(um${gg`Ffd~v0;eKn#9?_5$>4+TKVBb zWCjot19A>hvZ({WG?-^@iEwE~nOJ4lrOtbECKT|Y7jVJYJF#*!POcIe>HZChamp%C zYYofE!Ff`&CH@$0$a)*4C1&HViCv~loVJC2S&UCe6(wT148NJrA$j6&z~hk!Y5fKB zJLt#^Bf39DPNKgEO)fvdr3t&p31=l~cjZx+KsV;Zq$zS|L~b0Q)Z1Z}qS4DRI92W3 zZu-^DwvRi0yE7}{f5PBX4u&yxmrNPkoA49ZGU_)^zF&#m{al9qabJna^;vi*tEVy- z-ie~a=?Z*=4})ZMze8-;Lx-jCT{uz+e+&;*sNosQrG!)bpHhMf>Jr-%85ssLu9O+4 fVzLkh+P{;X`D$5wrbKk&ECh=$#3cG*=J@y(R^M@& literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST new file mode 100644 index 00000000..149819cf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ctypecase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-ctypecase.test ;; ;; ;; Syntax: (ctypecase keyplace {(type {form}*)}*) ;; ;; Function Description: This macro resembles typecase. Its control construct ;; is similar to typecase, but no explicit otherwise or T clause is permitted. ;; The keyplace must be a generalized variable reference acceptable to setf. ;; If no clause is satisfied, etypecae signals an error with a message constructed ;; from the clauses. Continuing from this error causes ctypecase to accept a new ;; value from the user, store it into keyplace, and start over, making the type ;; tests again. Subforms of keyplace may be evaluated multiple times. The name ;; of this function stands from "continuable exhaustive type case." ;; ;; Argument(s): Keyplace: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of ctypecase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "ctypecase-test0?" (macro-function 'ctypecase) ; Does ctypecase have a macro definition? ) (do-test "ctypecase-test1" (and (setq x 1/3) (= (ctypecase x (integer x) (rational x) (symbol (symbol-value x))) 1/3) ) ) ; This should not break since the clause (rational x) is satisfied. ;; The following should break with the appropriate error message, promt for ;; a new value, and return when the new value satisfies any of the type cases ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; ;; (progn (setq x "HELLO") ;; (ctypecase x ;; (integer x) ;; (complex x) ;; (list x) ;; (symbol (symbol-value x))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4733e3fc745e220ad452c045800a5ce342e3ab3a GIT binary patch literal 1733 zcmbVM-A~(A6u)-(T1aRTQec5)R@l&H&8Vd5)X_?lF%Ah$e3|Wt(ifBkGovL9g1}Tw ztyuRVqHTdLccU$qWaxvQhBSUYL^^J@@WtCOsTH z*xlhGbwWsmG*P@lNQ4B4yX8bgQ#DK}n=h!6CKpxF-E^G}=tU|Ss_r_`w9u$8N>yvs zs$x5}Wx^5SZa5v;lBSq>s=3?T8W(c!I^nz~O+jn&gi831Lli{kTqm5)NarP0kqwpX z?gVcW!rj9{ezG4=a*wW))hCnubRrSuT0iotdki9WySdV-SA)vlH<7 zb9YwedWjxs;Q&@q(&LV|nms z6NbpQvJl?_nNd-ZO(iGks#(&35Q@jBHe<#x)gsTGjxednx&lEK3UmR9xoy zIaM;nz!^vgiLy2$d45A=Tp+?a15xm|%7v+%%))^f8nmcRpwSIR%Qe+RJq~(cDwk*B z=P@}5Gh{8u-xw0|4s73+rFu~|(Oiezs8Z5(RXcG%7>8@0z*_vjX&|lr`dAk(tGMl$ ze2sorHM5d2 zQyilO>F5&T;$0@(WCCTc7Fgmk>rdb`i?X8A%RDmC0ALp#=6riC9=UJ8|?Kq#W{Jv zU${=ERVgo9Qo~wqi~t_D<~pyNUT4xaSQ_Hkd6pvgFC85G3+k8hWdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST b/internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST new file mode 100644 index 00000000..8b8024ed --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ecase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-ecase.test ;; ;; ;; Syntax: (ecase keyform {({({key}*)|key} {form}*)}* ;; ;; Function Description: This control construct is similar to case, but no explicit ;; otherwise or T clause is permitted. If no clause is satisfied, ecase signals ;; an error with a message constructed from the clauses. It is not permissible to ;; continue from this error. The name of this function stands for "exhaustive ;; case" or "error-checking case." ;; ;; Argument(s): Keyplace: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of ecase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "ecase-test0" (macro-function 'ecase) ; Does ecase have a macro definition? ) (do-test "ecase-test1" (and (setq x 'alpha) (defun foo () 'foo-for-alpha) (defun bar () 'bar-for-omega) (defun baz () 'baz-for-zeta) (setq alpha 1 omega 2 zeta 3 phi 4) (equal (mapcar #'(lambda (x) (ecase x (alpha (foo)) (omega (bar)) ((zeta phi) (baz)))) '(alpha omega zeta phi)) (list (foo) (bar) (baz) (baz))) ) ) ; This should not break since each of the three clauses is satisfied. ;; The following (ecase-test2) should break with the appropriate error message ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; ;; (progn (setq x 1/3) ;; (ecase x ;; (alpha (foo)) ;; (omega (bar)) ;; ((zeta phi) (baz))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c623a3bf41d8fd799c9a26fe15a137d005b9b2cd GIT binary patch literal 1235 zcmah|&2JM&6rWwk@n^y&avhXdbc=+FR!o$H&_ducY{s#Z^-j7wX2}Uf&ZcWA!Ite* zLKP_D0GCDJM4%lI|3MECmx`t$s@h}!fF671RH=s^Dm8tx;j>iYusidd(%hB ztEQ!!t<83G!|&*=tzLVpr?0m4JPhZeUyVKl&%lY#lPS2g2nVX%R%$A939ie?RW_E7si@9@OPG%3EK2o$6 zLa2cbqSE6uuW)`2tl&>sPleiQ;eU!e9 zkTN8T`61X}RGwc)>pw24-tqAfCHZw+;XWLrw^O4^@ce}h_dohe_w1h$>IZl1MO7Js z+uoQrE+OQXMktTaL9lODdfo2pm z0DrA;zzRF8aF>m~wU?L%riWe;I(ILCVr+>PWRpj^54VGlSGyDJ75}f?exNlqq^6>W zVaYI=Jzte=#T8=DThzgqtDvzLTtiKYj5+`_8!=46%?frXuRG9lGalNYyW(TUKJ$9f#WQY?x4_?IqX>Z^_D~I7%gQ()<%Ncm1(B$zQBu!aWPB^Pcxi3Q<0@Iig6NV_A5T!9tW!|iDO!}`VJm&XqwEf0v z*T+4-+nbibe@5Y_90dL3Epk#{UxnwtrZ=x2yd5CPPze&uj-6bF;R&^ a?fqi$)V%miiQ&ZO;4Dsy3G{gC@bF(3m2h+b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST b/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST new file mode 100644 index 00000000..f46afc84 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: etypecase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-etypecase.test ;; ;; ;; Syntax: (etypecase keyform {(type {form}*)}*) ;; ;; Function Description: This function resembles casetype. This control construct ;; is similar to typecase, but no explicit otherwise or T clause is permitted. ;; If no clause is satisfied, etypecae signals an error with a message constructed ;; from the clauses. It is not permissible to continue from this error. ;; The name of this function stands for "exhaustive type case" or "error-checking ;; type case." ;; ;; Argument(s): Keyform: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of etypecase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "etypecase-test-0" (macro-function 'etypecase) ; Does etypecase have a macro definition? ) (do-test "etypecase-test1" (and (setq x 1/3) (= (etypecase x (integer x) (rational x) (symbol (symbol-value x))) 1/3) ) ) ; This should not break since the clause (rational x) is satisfied. ;; The following should break with the appropriate error message. ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; (progn (setq x 1/3) ;; (etypecase x ;; (integer x) ;; (symbol (symbol-value x))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X b/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X new file mode 100644 index 00000000..4fbd6736 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X @@ -0,0 +1,735 @@ +;; This is a collection of tests from the ErrorSystem.NoteFile. It tests Xerox extensions to the CommonLisp ErrorSystem mostly dealing with proceed cases. The individual test files for each of the functions have been appended together in this big file to gain diagnostic information by testing the functions in a particular order. Nested proceed-cases use find-restart and so find should come first. +;; +;; The source for the text file listing is the NoteCards database at {eris}cml>test>ErrorSystem.NoteFile. Changes are made only to the NoteFile. The listing is +;; Filed As: {eris}cml>test>24-ErrorSystem.x +;; +;; +(do-test "define our-little-condition" (define-condition our-little-condition (condition))) +;; Definition To Be Tested: ignore-errors +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Handling Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-ignore-errors.x +;; +;; +;; Syntax: ignore-errors &body forms [Macro] +;; +;; Function Description: Executes its body in a context which handles errors of type error by returning control to this form. If no error is signalled, all values returned by the last form are returned by ignore-errors. Otherwise, the form returns nil and the condition that was signalled. Synonym for (condition-case (progn . forms) (error () nil)). +;; +;; Argument(s): forms +;; +;; Returns: nil if error followed by the signalled condition, else value(s) of last form +;; +(do-test-group "ignore-errors" +(do-test "ignore-errors with simple error" (not (ignore-errors (error)))) +(do-test "ignore-errors no error" +(and (string-equal "success" (ignore-errors "success")) +(ignore-errors (signal 'simple-condition)))) +(do-test "ignore-errors cerror" (not (ignore-errors (cerror)))) +(do-test "ignore-errors second return no error" +(second (multiple-value-list (ignore-errors (values-list (list nil t)))))) +(do-test "ignore-errors second return error" +(second (multiple-value-list (ignore-errors (error)))))) +;; Definition To Be Tested: find-restart +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-find-restart.x +;; +;; +;; Syntax: find-restart name +;; +;; Function Description: Searches for a proceed case by the given name which is applicable to the given condition in the current dynamic contour. If name is a proceed function name, then the innermost (ie, most recently established) proceed case with that function name that matches the given condition is returned. nil is returned if no such proceed case is found. If name is a proceed case object, then it is simply returned unless it is not currently valid for use. In that case, nil is returned. +;; +;; Argument(s): name -- a proceed function name or +;; a proceed case object +;; +;; Returns: proceed-case, proceed case object, or nil +;; +;; The simple tests for this fall out of compute-proceed-cases. +;; +;; +(do-test-group "find-restart" +(do-test "find-restart nil 1" (not (find-restart `none))) +(do-test "find-restart nil 2" +(not (or (find-restart `none) +(restart-case (find-restart `none) (use-food))))) +(do-test "find-restart nil 3" +(not (restart-case (find-restart `proceed) (use-food)))) +(do-test "find-restart nil switched" +(not (restart-case (find-restart `use-food) (proceed)))) +(do-test "typep find-restart" +(restart-case (typep (find-restart `use-food) 'restart) (use-food))) +(do-test "restart-case signal positive " +(restart-case +(condition-case (signal (make-condition `our-little-condition)) +(our-little-condition nil (find-restart 'use-food))) +(use-food))) +(do-test "find-restart nil :condition" +(not (restart-case (find-restart `use-food) +(use-food nil :condition our-little-condition nil)))) +(do-test "find-restart nested inner" +(define-proceed-function use-food :report "Select this food.") +(restart-case +(restart-case +(and (setq our-restart-case +(find-restart 'use-food)) +(typep our-restart-case 'restart) +(string-equal "The inner case." +(princ-to-string our-restart-case))) +(use-food nil :report "The inner case." t)) (use-food))) +(do-test "find-restart nested outer" +(restart-case +(progn (and (test-setq our-restart-case +(find-restart 'use-food)) +(typep our-restart-case 'restart) +(string-equal "Select this food." +(princ-to-string our-restart-case))) +(restart-case (find-restart 'use-food) +(use-food nil :report "The inner case." t)) +(and (test-setq our-restart-case +(find-restart 'use-food)) +(typep our-restart-case 'restart) +(string-equal "Select this food." +(princ-to-string our-restart-case)))) +(use-food)))) +(do-test-group "old-style find-restart" +(do-test "old style find-restart nil 2" +(not (or (find-restart `none) +(proceed-case (find-restart `none) (use-food))))) +(do-test "old style find-restart nil 3" +(not (proceed-case (find-restart `proceed) (use-food)))) +(do-test "old style find-restart nil switched" +(not (proceed-case (find-restart `use-food) (proceed)))) +(do-test "old style find-restart positive" +(proceed-case (find-restart `use-food) (use-food))) +(do-test "proceed-case signal positive " +(proceed-case +(condition-case (signal (make-condition `our-little-condition)) +(our-little-condition nil (find-restart 'use-food))) +(use-food))) +(do-test "old style find-restart nil :condition" +(not (proceed-case (find-restart `use-food) +(use-food nil :condition our-little-condition nil)))) +(do-test "old style find-restart nested inner" +(define-proceed-function use-food :report "Select this food.") +(proceed-case +(proceed-case +(and (setq our-proceed-case +(find-restart 'use-food)) +(typep our-proceed-case 'restart) +(string-equal "The inner case." +(princ-to-string our-proceed-case))) +(use-food nil :report "The inner case." t)) (use-food))) +(do-test "old style find-restart nested outer" +(proceed-case +(progn (and (test-setq our-proceed-case +(find-restart 'use-food)) +(typep our-proceed-case 'restart) +(string-equal "Select this food." +(princ-to-string our-proceed-case))) +(proceed-case (find-restart 'use-food) +(use-food nil :report "The inner case." t)) +(and (test-setq our-proceed-case +(find-restart 'use-food)) +(typep our-proceed-case 'restart) +(string-equal "Select this food." +(princ-to-string our-proceed-case)))) +(use-food)))) ) +;; Definition To Be Tested: proceed-case +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-proceed-case.ux +;; +;; +;; Syntax: proceed-case form &rest clauses [Macro] +;; +;; Function Description: The form is evaluated in a dynamic context where the clauses have special meanings as points to which control may be transferred in the event that a condition is is signalled. If form runs to completion and eturns any values, all values returned by theform are simply returned by the proceed-case from. If a condition is signalled while form is running, a handler may transfer control to one of the clauses. If a transfer to a clause occurs, the forms in the body of that clause will be evaluated and any values returned by the last such form will be returned by the proceed-case form. See the documentation for further information. +;; +;; Argument(s): form +;; clauses -- (proceed-function-name arglist [keyword value]* [body-form]*) +;; valid keyword/value pairs are: +;; :filter-function expression +;; :filter form +;; :condition type +;; :report-function exp +;; :report form +;; +;; Returns: value of last form or handled form +;; +(do-test-group "restart-case :filter-function" +(do-test "restart-case :filter-function simple positive" +(restart-case (find-restart 'use-food) +(use-food nil :filter-function +(lambda () +t)))) +(do-test "restart-case :filter-function simple negative" +(restart-case (not (find-restart 'use-food)) +(use-food nil :filter-function +(lambda () +nil)))) +(do-test "restart-case :filter-function simple negative 2" +(restart-case (not (find-restart 'use-food)) +(use-food nil :filter-function +(lambda () +(typep *current-condition* +'our-little-condition))))) +(do-test "restart-case *cur-cond* :filter-function positive" +(restart-case +(let ((*current-condition* (make-condition 'our-little-condition))) +(find-restart 'use-food)) +(use-food nil :filter-function +(lambda () +(typep *current-condition* 'our-little-condition))))) +(do-test "restart-case :filter simple positive" +(restart-case (find-restart 'use-food) +(use-food nil :filter t))) +(do-test "restart-case :filter simple negative" +(restart-case (not (find-restart 'use-food)) +(use-food nil :filter nil))) +(do-test "restart-case :condition negative" +(restart-case +(not (let ((*current-condition* (make-condition 'our-little-condition))) +(find-restart 'use-food))) +(use-food nil :condition error))) +(do-test "restart-case :condition positive" +(restart-case +(let ((*current-condition* (make-condition 'our-little-condition))) +(find-restart 'use-food)) +(use-food nil :condition our-little-condition))) +(do-test "restart-case :filter and :condition error" +(expect-errors (simple-error) +(restart-case (find-restart 'use-food) +(use-food nil :condition our-little-condition +:filter t)))) +(do-test "restart-case :filter and :filter-function error" +(expect-errors (simple-error) +(restart-case (find-restart 'use-food) +(use-food nil :filter t :filter-function +(lambda () +(typep *current-condition* +'our-little-condition))))))) +(do-test-group "restart-case :report-function" +(do-test "restart-case :report-function" +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'use-food))) +(use-food nil :report-function +(lambda (restart-case *standard-output*) +(write-string "Select this." *standard-output*))))) +(do-test "restart-case :report-function 2" +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'use-food))) +(use-food nil :report-function +(lambda (ignore stream) +(write-string "Select this." stream))))) +(do-test "restart-case :report" +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'use-food))) +(use-food nil :report "Select this."))) +(do-test "restart-case :report" +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'use-food))) +(use-food nil :report (write-string "Select this." *standard-output*)))) +(do-test "restart-case :report and :report-function error" +(expect-errors (simple-error) +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'use-food))) +(use-food nil :report +(write-string "Select this." *standard-output*) +:report-function +(lambda (ignore stream) +(write-string "Select this." stream))))))) +(do-test-group "nested restart-case inner catch and throw" +(do-test "nested restart-case catch and throw" +(restart-case +(catch 'test-throw +(restart-case +(block test-throw +(throw 'test-throw +(string-equal "Select this." +(princ-to-string +(find-restart 'proceed)))) nil) +(proceed nil :report "Select this." nil))) +(proceed nil :report "Don't Select this." nil))) +(do-test "throw restart-case" +(catch 'test-throw +(throw 'test-throw +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'proceed))) +(proceed nil :report "Select this."))))) +(do-test "throw nested restart-case" +(catch 'test-throw +(throw 'test-throw +(restart-case +(restart-case +(string-equal "Select this." +(princ-to-string (find-restart 'proceed))) +(proceed nil :report "Select this." nil)) +(proceed nil :report "Don't Select this." nil))))) +(do-test "nested restart-case outer catch and inner throw" +(catch 'test-throw +(restart-case +(restart-case +(progn +(throw 'test-throw +(string-equal "Select this." +(princ-to-string +(find-restart 'proceed +(make-condition +'simple-condition))))) +nil) +(proceed nil :report "Select this." nil)) +(proceed nil :report "Don't Select this." nil)) nil)) +(do-test "internested restart-case nested catch and throw" +(not (catch 'test-throw +(restart-case +(catch 'test-throw +(restart-case +(progn +(throw 'test-throw +(string-equal "Select this." +(princ-to-string +(find-restart +'proceed +(make-condition +'simple-condition))))) +nil) +(proceed nil :report "Select this." nil))) +(proceed nil :report "Don't Select this." nil)) nil)))) +(do-test "restart-case: dynamic environment" +(let ((x t)) +(declare (special x)) +(restart-case +(let ((x nil)) +(declare (special x)) +(invoke-restart (find-restart 'use-food))) +(use-food nil :report "Select this." x)))) +;; Definition To Be Tested: define-proceed-function +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-define-proceed-function.test +;; +;; +;; Syntax: define-proceed-function name [keyword value]* &rest variables [Macro] +;; +;; Function Description: Defines a function called name which will proceed an error in a typed way. The only thing that a proceed function really does is collect values to be passed on to a proceed-case clause. Valid keyword/value pairs are the same as those which are defined for the proceed-case special form. That is, :test, :condition, :report-funciton, and :report. The test and report functions specified in a define-proceed-function form will be used for proceed-case clauses with the same name that do not specify their own test or report functions, respectively. See the documentation for further information. +;; +;; Argument(s): name (of function to be defined) +;; keyword/value pairs: +;; :test function +;; :condition type +;; :report-function exp +;; :report form +;; &optional variables +;; each variable has the form +;; variable-name or +;; (variable-name initial-value) +;; +;; Returns: value of function or handled proceed clause +;; +(do-test "define-proceed-function" (fmakunbound 'test-fn) +(and (define-proceed-function test-fn :report "our little report") +(fboundp 'test-fn) +(proceed-case (string-equal "our little report" +(default-proceed-report 'test-fn)) +(test-fn nil t)))) +(do-test-group "define-proceed-function default parameter collection" +(do-test "define-proceed-function test-fn" (fmakunbound 'test-fn) +(define-proceed-function test-fn :report "Select this food." (y t))) +(do-test "define-proceed-function find test" +(proceed-case (find-restart 'test-fn) (test-fn))) +(do-test "define-proceed-function default parameter collection" +(proceed-case (invoke-proceed-case (find-restart 'test-fn)) +(test-fn (y) y)))) +;; Definition To Be Tested: compute-proceed-cases +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-compute-proceed-cases.x +;; +;; +;; Syntax: compute-proceed-cases condition [Function] +;; +;; Function Description: Uses the dynamic state of the program to compute a list of proceed cases which may be used with the given condition. See the documentation for more information. +;; +;; Argument(s): condition +;; +;; Returns: list of proceed cases +;; +(do-test-group "compute-restart-cases" +(do-test "compute-restart-cases single" +(restart-case (member-if #'(lambda (case) +(eq (restart-case-name case) +'proctest)) +(compute-restart-cases)) (proctest)))) +(do-test "compute-restart-cases multiple" (fmakunbound 'test-fn) +(define-proceed-function test-fn :report "Select this food." (y t)) +(restart-case +(restart-case (and (member-if #'(lambda (case) +(equal (restart-case-name case) +'test-fn)) +(compute-restart-cases)) +(member-if #'(lambda (case) +(equal (restart-case-name case) +'proceed)) +(compute-restart-cases))) +(test-fn nil t)) (proceed))) +;; Definition To Be Tested: restart-case-name +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-restart-case-name.test +;; +;; +;; Syntax: restart-case-name restart-case +;; +;; Function Description: Returns the name of the given restart-case, or nil if it is not named. +;; +;; Argument(s): restart-case +;; +;; Returns: name or nil +;; +(do-test "restart-case-name named" +(restart-case (equalp (restart-case-name (find-restart 'proceed)) +'proceed) (proceed))) +;; Definition To Be Tested: default-proceed-test +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-default-proceed-test.x +;; +;; +;; Syntax: default-proceed-test restart-case-name +;; +;; Function Description: Returns the default test function for proceed cases with the given name. May be used with setf to change it. [This is a Xerox Lisp extension.] +;; +;; Argument(s): restart-case-name +;; +;; Returns: function +;; +(do-test-group "default-proceed-test" +(do-test "default-proceed-test simple" +(functionp (default-proceed-test 'proceed))) +(do-test "default-proceed-test override" (fmakunbound 'test-fn) +(define-proceed-function test-fn :report "our little report" :filter t) +(setq testfn (default-proceed-test 'test-fn)) +;; begin test +(restart-case (equalp (default-proceed-test 'test-fn) testfn) +(test-fn nil :filter-function #'nil)))) +;; Definition To Be Tested: default-proceed-test +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-default-proceed-test.x +;; +;; +;; Syntax: default-proceed-test restart-case-name +;; +;; Function Description: Returns the default report function for proceed cases with the given name. May be used with setf to change it. [A Xerox Lisp extension.] +;; +;; Argument(s): restart-case-name +;; +;; Returns: function +;; +(do-test-group +("default-proceed-report" :before +(fmakunbound 'test-fn +(define-proceed-function test-fn :condition simple-condition +:report "Select this food."))) +(do-test "default-proceed-report simple" +(string-equal (default-proceed-report 'test-fn) "Select this food.")) +(do-test "default-proceed-report override" +(restart-case (string-equal (default-proceed-report 'test-fn) +"Select this food.") +(test-fn nil :report "A different report.")))) +;; Definition To Be Tested: invoke-restart +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Handling Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-invoke-restart.x +;; +;; +;; Syntax: invoke-restart restart-case &rest values [Function] +;; +;; Function Description: Transfers control to the given restart-case, passing it the given values. The restart-case must be a proceed case object or the name of a proceed function which is valid in the current dynamic context. If the argument is not valid, the error bad-restart-case will be signalled. If the argument is a named proceed case that has a corresponding proceed function, invoke-restart will do the optional argument resolution specified by that function before transferring control to the proceed case. [The CL error proposal does not specify a required second argument.] +;; +;; Argument(s): restart-case -- object or name +;; condition +;; optional values -- for the restart-case +;; +;; Returns: can abort, does not return +;; +(do-test "invoke-restart single" +(restart-case (invoke-restart 'test-proccase) +(test-proccase nil t))) +(do-test "invoke-restart multiple" (fmakunbound 'test-fn) +(define-proceed-function test-fn :report "Select this food.") +(and (restart-case (invoke-restart 'test-fn) +(proceed nil nil) +(test-fn nil t)) +(restart-case (invoke-restart 'proceed) +(proceed nil t) +(test-fn nil nil)))) +;; Definition To Be Tested: catch-abort +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-catch-abort.x +;; +;; +;; Syntax: catch-abort print-form &body forms +;; +;; Function Description: Sets up a restart-case context for the proceed function abort. If no abort is done while execinting forms and they return normally all values returned by the last form in forms are returned. If an abort transfers control to this catch-abort, two values are returned: nil and the condition which was given to abort (or nil if none was given). +;; +;; Argument(s): print-form -- e.g. string / format +;; forms +;; +;; Returns: values of last form or nil and a condition. +;; +(do-test "simple catch-abort" (not (catch-abort "it worked" (abort)))) +(do-test "catch-abort nested" +(catch-abort "level 1" (not (catch-abort "level 2" (abort))))) +;; Definition To Be Tested: abort +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-abort.x +;; +;; +;; Syntax: abort &optional condition +;; +;; Function Description: Transfers control to the innermost (dynamic) catch-abort form, causing it to return nil immediately. +;; +;; Argument(s): optional condition +;; +;; Returns: never +;;simple abort is tested in catch-abort +(do-test-group "abort with condition" +(do-test "abort with condition" +(multiple-value-bind (result acondition) +(catch-abort "test" (abort (make-condition 'simple-condition))) +(and (not result) +(typep acondition 'simple-condition)))) +(do-test "abort with condition 2" +;; the proceed case below should be ignored, so we return +;; t if this proceed case is seen. Normal return from +;; catch-abort is nil. +(multiple-value-bind (result acondition) +(catch-abort "test" +(restart-case +(progn (abort (make-condition 'simple-condition)) t) +(abort (condition) :filter-function +(lambda () +nil) t))) +(and (not result) +(typep acondition 'simple-condition))))) +;; Definition To Be Tested: proceed +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-proceed.x +;; +;; +;; Syntax: proceed &optional condition +;; +;; Function Description: This is a predefined proceed function. It is used by such functions as break, cerror, etc. +;; +;; Argument(s): optional condition +;; +;; Returns: nil +;; +(do-test-group "proceed" +(do-test "proceed simple" +(restart-case (find-restart 'proceed) (proceed))) +(do-test "proceed body" +(and (not (restart-case +(invoke-restart (find-restart 'proceed)) +(proceed nil nil))) +(restart-case (invoke-restart (find-restart 'proceed)) +(proceed nil t)))) +(do-test "proceed filter" +(restart-case (not (find-restart 'proceed)) +(proceed nil :filter nil))) +(do-test "proceed report" +(restart-case (string-equal "Select this." +(princ-to-string (find-restart 'proceed))) +(proceed nil :report "Select this.")))) +(do-test-group "proceed nested" +(do-test "proceed nested inner" +(restart-case +(restart-case (invoke-restart (find-restart 'proceed)) +(proceed nil t)) +(proceed nil nil))) +(do-test "proceed nested outer" +(restart-case +(progn (restart-case (restart-case nil (proceed nil nil))) +(invoke-restart (find-restart 'proceed)) +(restart-case (restart-case nil (proceed nil nil)))) +(proceed nil t))) +(do-test "proceed nested both" +(restart-case +(progn +(restart-case +(invoke-restart (find-restart 'proceed)) +(proceed nil nil)) +(invoke-restart (find-restart 'proceed))) +(proceed nil t)))) +(do-test-group "proceed bindings" +(do-test "proceed closure" +(eq 'x +(let ((val 'x)) +(restart-case +(invoke-restart (find-restart 'proceed)) +(proceed nil val)))))) +;; Definition To Be Tested: use-value +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-use-value.ux +;; +;; +;; Syntax: use-value &optional new-value +;; +;; Function Description: This is a predefined proceed function. It is intended to be used for supplying an alternate value to be used in a compuatation. If new-value is not provided, use-value will prompt the user for one. +;; +;; Argument(s): optional value +;; +;; Returns: n/a +;; +(do-test "use-value" +(and (not (restart-case (invoke-restart 'use-value) +(use-value 'simple-condition nil))) +(restart-case (invoke-restart 'use-value) +(use-value 'simple-condition t)))) +;; Definition To Be Tested: store-value +;; +;; Source: Xerox LIsp Manual +;; Chapter 24: ERROR SYSTEM Proceeding from Conditions +;; +;; Created By: Kirk Kelley +;; +;; Creation Date: 21 November 86 +;; +;; Last Update: >> day month << 86 +;; +;; Filed As: {eris}cml>test>24-use-value.x +;; +;; +;; Syntax: store-value &optional new-value +;; +;; Function Description: This is a predefined proceed function. It is intended to be used for supplying an alternate value to be stored in some location as a way of proceeding from an error. store-value does not actually store the new vlaue anywhere: it is up to proceed case to take care of that. If new-value is not provided, store-value will prompt the user for one. store-value is used by such forms as check-type and cerror. +;; +;; Argument(s): optional value +;; +;; Returns: n/a +;; +(do-test-group "store-value" +(do-test "store-value" +(and (not (restart-case (invoke-restart 'store-value) +(store-value 'simple-condition nil))) +(restart-case (invoke-restart 'store-value) +(store-value 'simple-condition t))))) +STOP<,¨,{,N,R,”,Ł,K,,],o,˜,Ë,˛,,ˇ,’,/,,,đ,Ü,Č,´, ,Œ,x,d,ˆ,~,j,Á,Š,q,˝,™,e,`,ś,ž,f,Š,U,•,g,‹,,b,…,P,v,t,<,(,M,1,,c,Q,4,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA<“<<Ź<8<<<\<*<<%<3<<<<"<<&<<><<<<<<_<<<<f<<;J;":89-;@;0:K;-:9<)<<%<:<<<<"<<&<<=<<<<<ř<<5<$<<C<<@<<<8:87628798%7987E8)54@354 +8'7,268%5?5410/"/ .%198%54(-,","+%*'),*!-,","+&4<(8(7628(798/798+748)54@354 +817,268/5?5410/"/ .%198/54(-,","+%*'),*!-,","+&4<)<<%<:<<<<"<<&<<><<<E<<•<<<^<<<?<0<3<8<0<<<<</897'()'897-()'8;7-()'&8=54@14%36807'(807-(8,54@%4"8,54@141857$'#."8;54'!)+ </8)54,4%"348+54,4%3)8 54,4(8 54,4I8;541,13033+<;8/541 +418541+)8%541+*38;541*168;51 +8<-8 554 11+4+<4<<%<:<<<<"<<&<<K<<<b<<p<<2<*<2<3<8<0<<!<<%<<E<<:C0#<F8B7E8-728@7<(<2<<%<:<<<<"<<&<<F<<<D<<ť<<<</<<'8(7  '<A8D85! +     +    <.<<%<:<<<<"<<&<<E<<<9<<`<<<<%<<#B <1<<%<:<<<<"<<&<<E<<<A<<‡!<<#<<"<<&8'7-8@5H5.5 5> (<1<<%<:<<<<"<<&<<E<<<A<<Ł<<#<< <<8"=8)7F8+7>(/<+<<%<3<<<<"<<&<<?<<<P<<N<<0<<=<<4<<!.<:>-(<(<<%<:<<<<"<<&<<<<<<=<<q<<4<<<E<<G<?<"<<%<:<<<<"<<&<<6<<<4<<~<<$<<<&<&8 5)4@4(8"585555)415$ 4)<$<<%<:<<<<"<<&<<8<<<6<<u<<$<<<<87285)47!87,(85+-+ (< 8 547!48 54;*)*548541)1*4<"85 4 1)<&<<%<:<<<<"<<&<<;<<<8<<á<< <<<<43$*#<(<<%<:<<<<"<<&<<:<<<:<<˛<< <<<<;:6&9, & i> zş \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.DFASL b/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..21330442a559239fed478f3b336a2a2b9903add5 GIT binary patch literal 777 zcmah{K~EDw6n?u)OMyZPQKH7+hJ?$;A(TMCdT|`4w6L9p+1VgRQWo2!uuZ!)Ax2_6 zcv_={NOm>+2d{{cgMY|>fHSQ|A_q_N=9_un_rCXD7gEoNZIWQWS#S6)Gw6iPPH650 zEwdeTT2rL0L0y50Wt$>~ zE7Xd+ag>o>kmph!N8|Hm7&KACf8jTjo&7dw0P%+?Q}h@SWrxKl+G{NvzmG=C3~fkj zc$I>l`OTu(HASq-Q?uZo7h3bnWI3;aJItF_;V)8R>V- zqMSP%IiA??gk=oLgsg?xHtON7l}O{c{6GC0GyswT)ih&WlBA0cuV7J9V#MQ|vTMUg zv?Yn(`s;&Wm-g9Z9Z069dQvlT9%-hC?7PXNu@Xmjs{KtwYVFWLfI`0=qC-D?5=Re& zjLqpIJZwoQ!J<)+n+x6^zE{s9NTU(qQ1!*Ha$ns LCML>TEST>25-1-compile-file.test ;; ;; ;; Syntax: (compile-file input-pathname &key :output-file) ;; ;; Function Description: The input-pathname must be a valid file specifier, such as a ;; pathname. The defaults for input-filename are taken from the variable ;; *default-pathname-defaults*. The file should be a lisp source file; its contents ;; are compiled and written as a binary object file. The :output-file argument may ;; be used to specify an output pathname; it defaults in a manner appropriate to the ;; implementation's file system conventions. ;; ;; Argument(s): Input-pathname: pathname ;; :output-file(key): ;; ;; Constraints/Limitations: none ;; JRB commenting this test out until a better file can be found to test #| (do-test-group (" compile-file-test-setup" :before (progn (defun file-exist? (file) (if (not (eq (probe-file file) nil)) t nil)) (defun compile-source-file () (cond ((and(file-exist? '{erinyes}tools>do-test) (not (file-exist? '{erinyes}tools>do-test.dcom))) (compile-file '{erinyes}tools>do-test)) ((and (file-exist? '{eris}tools>do-test) (not (file-exist? '{eris}tools>do-test))) (compile-file '{eris}tools>do-test)) (t nil))) (defun compile-source-file-default () (cond ((and(file-exist? '{erinyes}tools>do-test) (not (file-exist? '{erinyes}tools>do-test.dcom))) (progn (rename-file '{erinyes}tools>do-test '{dsk}do-test) (compile-file 'do-test))) ((and (file-exist? '{eris}tools>do-test) (not (file-exist? '{eris}tools>do-test.dcom))) (progn (rename-file '{eris}tools>do-test '{dsk}do-test) (compile-file 'do-test))) (t nil))) (defun compile-source-output-file () (cond ((file-exist? '{erinyes}tools>do-test) (compile-file '{erinyes}tools>do-test :output-file '{erinyes}tools>do-test-output-file.dcom)) ((file-exist? '{eris}tools>do-test) (compile-file '{eris}tools>do-test :output-file '{eris}cml>do-test-output-file.dcom)) (t nil))) (defun delete-compiled-file (file) (cond ((file-exist? file) (delete-file file)) (t t))) (defun move-file (from-file to-file) (cond ((and (file-exist? from-file)(not (file-exist? to-file))) (rename-file from-file to-file)) (t t))))) (do-test "compile-file-test" (and (compile-source-file) (or(file-exist? '{erinyes}tools>do-test.dcom) (file-exist? '{eris}tools>do-test.dcom)) (delete-compiled-file '{erinyes}tools>do-test.dcom) (delete-compiled-file '{eris}tools>do-test.dcom))) (do-test "compile-file-test(*default-pathname-defaults*)" (and (compile-source-file-default) (file-exist? '{dsk}do-test.dcom) (move-file 'do-test '{erinyes}tools>do-test) (move-file 'do-test '{eris}cml>do-test))) (do-test "compile-file-test(:output-file)" (and (compile-source-output-file) (or (file-exist? '{erinyes}tools>do-test-output-file.dcom) (file-exist? '{eris}cml>do-test-output-file.dcom)) (delete-compiled-file '{erinyes}tools>do-test-output-file.dcom) (delete-compiled-file '{eris}cml>do-test-output-file.dcom)))) |# (do-test "compile-file-no-test-yet" t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7d0335ee5d52e142a342dc9467aa8961d89e04d2 GIT binary patch literal 2184 zcmb6aNo*5W^pBS~8`MrymXN}bKq6cw!4`oeRhRL2oH!ZJIJ009sj5seV7G=uj#E^% zMS%n2;HpicM)RN)i7vNF)Hezu2c#Z)t3*|)w@STnLE=`4rti%d0wM@i9?#p?|K6V^ z7CbH~yfk}yu2{0m{Om$yZlS`ToGtV7vkT>En?H$s{u4>l<sWxIQf@R3MQ;o#=%Ius_vOls* zRL<#n#xdr6S#3;Ns$`}$)mh;dxmM?k>Xx)BWU(}HL}tFmx)<`!In~zqfDjWTEtADS z?CNUE1;)4sE+wKjJb4Ud#;Uq(7%zf zR>szf)9r5C>bY`Hat)!2dc5mDvG0(=2P2~&q?bJcv5V+vdRy(&5ALX?_@jqklMSk^ zsUP0EbG~@~#{Js+q_LxRj6g>%^J2wAq|sUH&2{EFen%g<9l31;A3eP0h1;a+|5N{R z;l{Sj8n9Fd7sJdKa=xl|MkP&6rs?p7QBh4QvMwaj$Wcd(s4oajz5q^EBr1ufG%Dz_ zY3Vo_k~>-r#-w4&86Wq&hN(rN#oq``{wAEJtx;LmHC@mwGi#Yq{}wc8jf(1|;PQwZ)Qt}j$+`2)cbh9CE3^4`)8tvUQsXt&s4Jl2} zh$fNWqJ2cNbX``TS{>j>wv4j&js8fYA$u8vJM&ZMsU?*W$1OFXS!$9@4A@0r3`Kr1 zVGy2xP69`e_1cJR3Tf4pbyZXZ-BR5$NZN~`!n9Mkb_(`i*D`VzA|z^u*9kPcfc;DP zx-Op6WcNLlzcEs%zMp8x{={=`H)Jy<7?YWVrU;MMorHg&@++J0e}%my{vLJ^xDGoB zEJMc(?0OGPUak92K5-^wr-08wcLusd;0K^P4qXR;-wk`)(UiM{MnU(uiCV;4r$MDd zP>8I+egZjgPbdp}kYazi6uakv-#q4BkGcf=NM#ZBqiG&n((+8(#*h=h_QxQSgx+E3 z?T4No=;?-@?aKegWeUGID}L-rgCb@UNzqve5Mh`) zZXRMyJzAEQQdFE3A664IOi?!>!aUM1t4W-86p;s69Wh5i@EnGc8ZD7Q)N+*@Cp8Kb zOevbCdpIXR4ElZNJ*vS{71?kN@aC6BMO~05EQ(Ba0b)FM&bCKpaZ;t8`_id; z`kAz98CjS@66>0RsgAlq00ihGZa=jjV)Tl;ErBDX;x=TEFlvX_S8$`fO-#2{et7pq Wt%KAe=e7&R$+H6c*yV-w_5T10C8Ht$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST new file mode 100644 index 00000000..6a57fb98 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compile ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.1 The Compiler ;; Page: 439 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 25,1986 ;; ;; Last Update: ;; Changed by Pavel on January 29, 1987 to change the uses of DEFUN into ;; (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA ...)) so as to avoid having ;; the interpreter create spurious interpreted closures. The compiler ;; cannot yet break one of these down. ;; ;; Filed As: {ERIS}CML>TEST>25-1-compile.test ;; ;; ;; Syntax: (compile name &optional definition) ;; ;; Function Description: If definition is supplied, it should be a lambda-expression, ;; the interpreted function to be compiled. If it is not supplied, then should be ;; a symbol with a definition that is a lambda-expression; that definition is ;; compiled and the resulting compiled code is put back into the symbol as its ;; function definition. The definition is compiled and a compiled-function object ;; is produced. If name is a non-nil symbol, then the compiled-function object is ;; installed as the global function definition of the symbol and the symbol is ;; returned. If the name is nil, then the compiled-function object is returned. ;; ;; Argument(s): name: symbol with a definition or nil ;; definition (option): lambda-expression ;; ;; Returns: compiled-function object ;; ;; Constraints/Limitations: none (do-test "compile-test-general" (and (setf (symbol-function 'palindromep) '(lambda (string &optional (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil))))) (eq 'palindromep (compile 'palindromep)) (compiled-function-p #'palindromep) (eq (compile 'abs1 '(lambda (x) (if (minusp x) (- x) x))) 'abs1) (compiled-function-p #'abs1) (compiled-function-p (compile nil '(lambda (a b c) (- (* b b) (* 4 a c))))) (fmakunbound 'palindromep) ) ) ;; Test to determine if the compiled version runs faster than the interpreted one. (do-test "compile-test-time" (and (setf (symbol-function 'comp-palindromep) '(lambda (string &optional (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil))))) (setf (symbol-function 'inter-palindromep) (symbol-function 'comp-palindromep)) (compile 'comp-palindromep) (setq i-time1 (get-internal-run-time)) (dotimes (k 50 t) (inter-palindromep "Able was I ere I saw Elba")) (setq i-time2 (get-internal-run-time)) (setq c-time1 (get-internal-run-time)) (dotimes (k 50 t) (comp-palindromep "Able was I ere I saw Elba")) (setq c-time2 (get-internal-run-time)) (< (abs(- c-time2 c-time1)) (abs (- i-time2 i-time1))) (fmakunbound 'inter-palindromep) (fmakunbound 'comp-palindromep) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL b/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2652bbce0d521efe92dcd2d51dd64002812e80c7 GIT binary patch literal 1326 zcma)6&2Jl35P!RNTsux&rwWPc1iBOgV&S=UnwHia;Cb_$xLNOp-F4ekLMSAg+LBXS z{y+lM$O;EItQ1^}XdhJ%{09-Yh*mzpkpl-Lj!1|LJ@r2bGwY;8X(c$U=FPmB-~8rd zUzZHs(sV_uZPqJQx1rS9t$MqqY}6V`v(|2`xylCEl`k~Y;`bJrwv>J^Gi)EbS!=kf zEq7gU+HP}w^|N=B%r%A88?u3iN-lf68fotsM!=b5b!(Ec-KE_?Ca?4?Y4_~7BL zl&ld#)<_>kjF2P=5&yoIR2^D-15D#S*2C0)2jQaTg7rV zn?xeS|Hg~vONQnYOvCR<9cjeh@kR>Lv%E;))@}nhb|1POLUXpK~NsUR7JA~lHC?WmIBT&w4pE@m-_dibb%><}V zyZVlq_=%8i`71NABun7f-8*}89E0$S5;B6ZYZLvw&yT10`zS>eV4xF#@xxhk7@Wm3 zYp2{P|L@F`FU$;B*HeJoFDJ1l-+I%kW*YMaY#d!=#=Oognk#_CSg=(&B4Y9oOl3^f zn4>LHi#sI?x~c_ZiP$T)!;7*E9^-?#X*y>{X_@9tt7xl2lBMUP9a9zYP)x)^qcEj} z$}P*Zs9AEBOO6_fL%@j2j1?N#5d_ASIWhHEh!7FRQO9v=e*sXK-(Wf_zk?D%0?a}6 zH)NodEQ=e*_DV>2_cJp8w*eZn`5>(bV0Qs2er!oF#1oS!I%4u8F@9UTbX`om3Vj^6 zxs#{%N-<~Z^k@}_(en=g8Ctf?1p~Ex)Pl-T+k?f87)Ui>{=Jw&s{p)Hdck3iSwy`D zG1A+3+7Z(zz7*5p4om^gwoH`K{3rrRQpZqS?$OQyp`>W1%4 zoTN^hZmV5~S0J6uahNb4ya2(ohNTV4IjUpJKCCSLGEft*b+(E0=Lg|{k4Qr{aY3ZW Jch?RM{sGG|jO_pb literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST b/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST new file mode 100644 index 00000000..d949c136 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: disassemble ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.1 The Compiler ;; Page: 439 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 28,1986 ;; ;; Last Update: Oct 8, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-1-disassemble.test ;; ;; ;; Syntax: (disassemble name-or-compiled-function) ;; ;; Function Description: The argument should be either a function object, ;; a lambda-expression, or a symbol with a function definition. If the relevant ;; function is not a compiled function, it is first compiled. In any case, ;; the compiled code is then "reverse-assembled" and printed out in a symbolic ;; format. ;; ;; Argument(s): function object, a lambda-expression, or ;; a symbol with a function definition. ;; ;; Returns: disassembled-function object ;; ;; Constraints/Limitations: none (do-test-group ("disassemble-test-setup" :before (setf (symbol-function 'xyz) '(lambda () 123456)) ) (do-test "disassemble-test" (and (typep (disassemble 'xyz) 'symbol) (typep (disassemble '(lambda (a b c) (- (* b b) (* 4 a c)))) 'symbol) (typep (disassemble '+) 'symbol)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL b/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..05156ceb48295e0682d3e7e6bea420bf9979eea2 GIT binary patch literal 4962 zcmbstdu$tL{kyZ{Jewv>wl;3kT_0(O+e@1^S-Z4lxm?ciC63R%JGV`FY_5H&O&vSf zP9K_9LJFdP9BR9C(S555VrbGNH0VH}q%A}U1e!n~gjNXz(j<^7A;e37Kthz??>;AX zlCki}!{7a$-|zW-zw=E}by^M!a&BTWow4#lZmKvrRTRc^d7+S-$|o#g9Pq-6vZgC9 zg(P{T>u7hKQ9()Mt$5K&3g(nmNX9Sk6S|)jq{)0b0}n@z0NCBvd$6ykr>ia~8DXYv zU74P~1Bd&1y1VKg-TX=(f8hejTS(ZMJp7o6o1dX z(yQ1J%y>azUDdKNW%U&b!Shl8DwYa*#be1{G%@`EfK4;i&0K2X`Nl=95x_s(3}4q8 zzeC8))MvED5uO7>Z{BS?)ru;BUPDL&iYA_1e2e@Qk)>SmZ!YDk2H4;a1WVh#_7<^M zChXp+gv_l%rKQvo(GOr)_rnV zks`6E7}WGpBS1NxTPtm90b1{=rL~?7&})qWMb|Z5)M92dW(GX|YrTX}FE(`#cIO+gnO8X}g%P+7fDet7OavX= zK#u7;v~>9dp&Zh#0j;$hBv~>PW*V(WvH_Y}40SXLmKmlFaTApjF}6z>Xmu-&3Y3tj zAD2G56_@=CdYVBU40@75^$ha55chW%;{L>-M+|zGK|f{C4;l12-3+R^*XR~pW@#HP zAA@W+8;ZH|>_W?ah3+csu2>A+Yq5%L@jEn zqv{z&H<0Z)j7FJFl4Zp(G)6nJk`~pKK^4kMLAh?W%Wklw8psGQw_aasW9xqyjKoG*_8IaDvXdcq0J4T$LDvN56F><&iW&yNw|3oGO3LmlqO{J@+T_*1Lz*JkA5bn3Y=?$w9 zg)#gRw>t^yp|V^}Kc_9I@NIekm+t|0!=P%&I#gLiikM95^MKy6qO(Nz_J;_>qKxGl z4WNQgxbfj8*^;1m7H}`nUR+|JrB>FWV`AB!VZ@C}BT5BMX6(n<(#w_rF#1qVEN!?G zJb41+QL2a)b;t>jwz>+cTQ6J()Aa<1HZ4a<)CPtX84o6|#-)>gu;q_#OvvwOH_*r< zFrd}CG#Sq(#kJ`nzh+!Nqt7ApkLW>Men1c5@?8*ZD_)+o#FG5l%#m-?k!fT@!TR zEZz4!-G3T*YGP67as{h0M)wcXXNG9YQQGn}J$pgob9N?HX0)iaV%yqFV{X>hmz z?#45qCLh0CfDO67IQHgDI%^53ctM!VfoTQd66~K8E+hF@j@_1>nmCIy{kU);T}YpW zIsRfgo6KEw<$vth2NN*%PeBY_OOxqBBA=c}XX9D+0uUF#yks6Coe(T|#E7HnyUuNA z7N>x1vaUeV#8ua2STz-03LCT@+2Alc5z|bC_2+HJ?&=#*ASw!*%H3RG8d>U=a(2Zi zWw8r)9DjdbPtTF={`r0!1n;({Vdx3Le+uW&vt;q^qZbHyYChEeHfbe`u<)(?VyKBY zwm%b}IGc=Pova=v;8lThhY6S`9Cm(jt#GGoltYR`d9l}uW_29vP$enc4 zM%r6Xd%d)m5Hx*sjywa_Y~#LOotjTAT#e7C7nb0Asry&s_tN*#zz6EBa0m<>xfLD; z1HEgbu>d4SGewD zhZEuWC5JX*QfEB?y0^EcMj+cRf~OXGj9I4^dnV58W-yJ98nl=8v8v(Vu7IdX&*fb#I`{tD8<5X0WaP0ViaaB*pNOuO{QH-eDwVEC#UH+sAT6e zs-N}I3}VkMV_~;xYSOeT1aE;$vkJtjc6m0Lo(2cVpa08NCcl^?BmMk*h+k0odoX_A zhXjv=xRl?Y^1~xSIGFqWD&orEFoNk}o^kq--S1x~Juv0+rKIzY-LPv{X~2OA!LeJG zKqYcg)wKw|vvN3g`-YSVOnctF@XQ@=$IoMJ@ae_YZG;C;STXti5P2ft2bM1R$^Umk zk#EeAU2a%rLp(PFZe!txUJkj>s_KSkU4Qu%<=D`nBQO!qW^+a1tmR%gaHU;@O9Tn={JBDxo1|+MUY0Me$vJWiLZ4bl!5I^}F{9qy zjCHBr8Xnnw?^7cw|CxmlKY#bpd_NcRF97LYsGlEB`BSPJhW9@lSC(Ks>m>Ib5DKz< z*Jm$yj<`CML>TEST>25-2-documentation.test ;; ;; ;; Syntax: (documentation symbol doc-type) ;; ;; Function Description: This function returns the documentation string of type ;; doc-type for the symbol, or nil if none exists. Some kinds of documentation ;; are provided automatically by certain Common Lisp constructs if the user ;; writes an optional documentation string within them: ;; ;; ;; Argument(s): symbol: symbol ;; doc-type: symbol ;; Variable (defvar, defparameter, and defconstant) ;; Function (defun and defmacro) ;; Structure (defstruct) ;; Type (deftype) ;; Setf (defsetf) ;; ;; Returns: string of type doc-type for the symbol or nil ;; ;; Constraints/limitations: (do-test-group (documentation-test-setup :before (progn (defun discriminant (a b c) (declare (number a b c)) "computes the discriminant for a quadratic equation" (- (* b b) (* 4 a c))) (defvar *visible-windows* 1 "number of visible windows") (defsetf accessfn updatefn "expands into a call on updatefn") (defsetf foo (x) (y) "Doc for FOO's SETF" nil) (define-setf-method baz (x) "Doc for BAZ's SETF" (values 1 2 3 4 5)) (deftype square-matrix (&optional type size) "square-matrix includes all square two-dimensional arrays" `(array ,type (,size ,size))) (defmacro arithmetic-if (test neg-form zero-form pos-form) "if analogous to the FORTRAN arithmetic IF" (let ((var (gensym))) `(let ((,var ,test)) (cond ((< ,var 0) ,neg-form) ((= ,var 0) ,zero-form) (t ,pos-form))))) (defstruct line "line has points x and y" x y))) (do-test "documentation-test" (and (string-equal (documentation 'discriminant 'function) "computes the discriminant for a quadratic equation") (string-equal (documentation '*visible-windows* 'variable) "number of visible windows") (string-equal (documentation 'line 'structure) "line has points x and y") (string-equal (documentation 'square-matrix 'type) "square-matrix includes all square two-dimensional arrays") (string-equal (documentation 'arithmetic-if 'function) "if analogous to the FORTRAN arithmetic IF") (string-equal (documentation 'accessfn 'setf) "expands into a call on updatefn") (string-equal (documentation 'foo 'setf) "Doc for FOO's SETF") (string-equal (documentation 'baz 'setf) "Doc for BAZ's SETF") ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..407fc391422a31817612a653bbbf38a7dc3f0afc GIT binary patch literal 1941 zcmbVN&rc&&9Dmb7fdZwixFEsZ5#ivh54ZdZiyPxGyh3FrBify)~O*=K& z7?JE{4^DzWB=g*G+dp9ak(kxh9*hSQ58g~Xcrx+eWfKn`@%wFIEd`_5!{ois=lj0j z_x<^1mvpWvs;HET<$NJq5lc0@T(iZEQbnwmYL!e@+yGvDPtgtb{)()uPQD!Rn=O(| zC7ZUh>!MZ5R@c+FUKAr&MY&wb7hp3#4=}PYJGC$~GwF}YrrNajpE@%OSLPS4%uV`_ z4iAK2i4c+@bzFJ~2@)@H_ne?)G1H>an98Uo$C>2rx=uI5LX##lTqiUo+NClrWZ%se zFq~qQ2!yyFIo;8urdTmubN7X9q0ilM`ePbRKxpzZBcASKD`;InGqZG>$_YbH=q6QT zrbP}925u7~#6m$2y7YDK;i~XplYH^bs^>;{BqaE5W`^qpPiCZE@McEqg^tX{dM+cv zHwNE${T)J3ub+^A+2$X@k?`%VAtCqRtw3E50DQEo?&yK<2-(fu(F3a<0n~TzkK7nU zQ}}fg(gzmvnG5w#$-NfGgtZgLx{-wp;sWY>x%=17Fw(JiaBTFm(H3yGWxt)<&i!v6 zhtBm8ti3h@m(+7X%=yR8sHEuHQVa`2S7dETWd>c00i!LOlE=q;Je^SWkfg|#vO*1J zB@L*W(kQ#nOqmvodpvMru-O-i%498>pi$k3n-Uj1!dY!gmw2zYhxd5#p3Vo8SrD%gkBi=sX{MZ>5)spc=W<(x$9kO13yL^g=y@7Ue8pwfmat6pC zkOMM3bpg;Jq!&-oXg7?sa*77at`m&3b$$;Nn|ENlhp=%K2)2V=msJFF0DPDv*+MuC zHbY9%FqqadTU}qCi@5ySTzbimOH-KHo0U-Vv@Gwk#g2v(rmBk?? za-%)1RD#)j{3f4xlTYZ7mGDwB9*?IUdljK?@bJ>Pf)o#5Jy)>C!$EZQC3thvxae&+@vM-)z39$Za)(`qOnfHwvXv1w;7Vbvn=( z?tgKeK)zTmWQ*BNJ8kDno5=p??tA%VF7X!-eeXKH^;)r5yoKm1cfX52#RvJ*`~n~1 z!~7X!KZi5ulT8sFx_8}uoV$yP!DNfkwgypS7BghkY%c;l~xS2t5|68n~UoQ+B2fONvc5+trOQb-ryUQc6!+Q$J* rACChO@Kq3?ScEJ;nJ(0mkZVt-3neF{qme*93+dr=e4Ko;a&+`JQkyj% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST new file mode 100644 index 00000000..5c894ca2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Testapropos-list: apropos-list ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 443 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 30, 1986 ;; ;; Last Update: Jan 20, 1987 ;; ;; Filapropos-list As: {ERIS}CML>TEST>25-3-apropos-list.test ;; ;; ;; Syntax: (apropos-list string &optional packages) ;; ;; Function Description: (apropos-list string) tries to find all available symbols ;; whose print names contain string as a substring. (A symbol may be supplied ;; for the string, in which case the print name of the symbol is used.) ;; Apropos-list performs the same search that apropos does, but prints nothing. ;; ;; Argument(s): string or symbol ;; package (optional) ;; ;; Returns: list of the symbols whose print names contain string as a substring. ;; ;; Constraints/Limitations: none (do-test-group ("apropos-list-test-setup" :before (progn (setq testt-number1 1) (setq testt-number2 2) (setq testt-number3 3) (setq testt-number4 4) (setq a-testt-number1 nil) (setq b-testt-number2 nil) (setq c-testt-number3 nil) (defun dummmy-function1-x nil 'x) (defun dummmy-function1-y nil 'y) (defun dummmy-function1-z nil 'z) ) ) (do-test "apropos-list-test" (and (eq (set-difference (apropos-list "testt-") '(testt-number1 testt-number2 testt-number3 testt-number4 a-testt-number1 b-testt-number2 c-testt-number3)) nil) (eq (set-difference (apropos-list "dummmy") '(dummmy-function1-x dummmy-function1-y dummmy-function1-z)) nil) (member 'lisp-implementation-type (apropos-list "implementation")) (member 'apropos (apropos-list "apro")) (member 'ffloor (apropos-list "floor")) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL b/internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3c468513f164382bd780ac72183463bca54538e0 GIT binary patch literal 1742 zcmbVM&2Jk;6rc51ZO3tKW3|W%>E;6=tr&yT6eWfOo6R^ews+0$x~&lsGPZ-Q+O_2m zqzVzLTq?mz!KsLLK=~hvKtdG-OK?Ks#DOFK0TL&!;XT`FgE0d2Fq(P4H}5y^a|XnH zQ^|@-tJ$tMsvWV_@3s3qaj(@8yRCkwTov~K7e7!moqf0~E1CGK3BPepQ|?qty=p}? z`_*oxbmv7eu_?;!PQ3w#jSUbJ$!lxL_4T+vB^%i>+ke`uCtu!3CN|^#)01N%)FOnG z$q+XmAtB-<_K_8mOlFugmCiD%$~h+41KaXKEVN)S-L}GOVz1Svjq3Z=28Pq@5`hr= zQ_GtwsEV1^RQtYgR|wdL)_hu}c?eD3VZ`B`upql&TY$B-Nz?sK@IoMB0kO=Xwr%q-|o4rNqNk5M#CmUB4ZMs!?o zCCg;Bkf$k4&lwUI9Kt`XO-|d;3#R0p1A~Aht3^7(k;EAQ z%#S5EsanWwF+K6Poe*{Ur}b+*;tWoMR{^{@4Xy(i0`QsbLM~UNe|rQ};n^zWkIYuV zE4CF%OtrTUx`Ml~r-Rs{OAxq=U6->cL_zRi!ekRgd@`&Qbe*Z^28au&!)!*M6ikr~ zHck_t12y>-m@Z7F0p*{$h}#e2?VIs-#Gga(kS~73uUv-~h#JgHQKOjK(z5hy{4#v$ zb-skG!UC|mVZ?S+wEGjKQE5>69Y)rpqVE_A`HipQ_7k}2J7Y@lNRO}F;;V1-RSjbs zXZo?4zQrTkv+yF1Y|g@O@<;$)5&SU!rFN&)Zgpv|+U+6cv#l#8oW$k@r8)EygTf@U(lg0`R7R^+^Mv|H`<+o-u`Tk+%;gMzd1&o}zc@zJr%A-hKOy&8l~pDl@f+D-C{sJX|Zvi2#{AocAm}_a!<%>PiG7DA;dMx9gjn1_)C0+ Jd@i4!{srrj{4xLl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST b/internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST new file mode 100644 index 00000000..f5e077bb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST @@ -0,0 +1 @@ +;; Function To Be Testapropos: apropos ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 442 ;; ;; Creatapropos By: John Park ;; ;; Creation Date: Sep 30, 1986 ;; ;; Last Update: ;; ;; Filapropos As: {ERIS}CML>TEST>25-3-apropos.test ;; ;; ;; Syntax: (apropos string &optional packages) ;; ;; Function Description: (apropos string) tries to find all available symbols whose ;; print names contain string as a substring. (A symbol may be supplied for the ;; string, in which case the print name of the symbol is used.) Whenever apropos ;; finds a symbol, it prints out the symbol's name; in addition, information about ;; the function definition and dynamic value of the symbol, if any, is printed. ;; If package is specified and not nil, then only symbols available in that ;; package are examined; otherwise "all" packages are searched, as if ;; by do-all-symbols ;; ;; Argument(s): string or symbol ;; package (optional) ;; ;; Returns: nil ;; ;; Constraints/Limitations: none (do-test-group ("apropos-test-setup" :before (progn (setq testt-number1 1) (setq testt-number2 2) (setq testt-number3 3) (setq testt-number4 4) (setq dummy-testt-number1 nil) (setq dummy-testt-number2 nil) (setq dummy-testt-number3 nil) (defun dummy-function1-x nil 'x) (defun dummy-function1-y nil 'y) (defun dummy-function1-z nil 'z))) (do-test "apropos-test" (and(eq (apropos "testt") nil) (eq (apropos "dummy") nil) (eq (apropos 'function1) nil) (eq (apropos "apro") nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL b/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..30effa98b5b70d407816826bb4db22a401ee8154 GIT binary patch literal 3588 zcmb_eVQgDh6~6b`aqKv0lEz!0=`y#d2{?V-(so_RVCwVBb^YS!_q_L>X*@v8aopOF zCc&{06;PRW>xATKWGUg@m4T*e0!^BzDh)MVyCA`jBKQLme<#6@O&}o^?Z=Qn3g_IH zmnImgf0E?p+*}X1vSZCMng*#d>)*?lj6vv&9RC-Y31wu%PtRsmK(nkWseXZ4(aG34LDNSdxp=4RY zU3Obxh(*rZ%yL`(N8|N{MR~6Lt@0d(bAE|XLfjv=!l}HWI+|&?E3`?w-B(*Znjz;P zH03lSQh3t}TBmNS>*!PRF?o{Ns--0vd1JNv5+Q*B^yPNty(zjjPriL;N;mFLmyvm9_T`nBQN{ykh)@kmbr1V@jeuFuO5$WDszY*%p) zu)hv-oZ^@Z!J@0fW5N{vwjm%`1Vg~>1hqHi+orphn}F>5-i`Lb4J3YgZjN|KcSk&q=wf^PAkTw&MY~p z0mnFPC!{EkNIftjFv2i8VRXOoA?2_6k} z@kn3~+~GY5W?7~sn|UXfcM^eKQ0Pu5MnM*QJHg>H_dor=J)tW=2oGW>knvu3f~8Q( zw6cnWOW~KAw=8CC>olB#O!^o$h&>2aRcz*M#iJ0w=5pBzG(z2Ozw5;|#vxJWa05Zc%#7@C^F$4{jEYkUL+XFOQOBS}bHP}dB$^*rLkhPbCe5>d@u0m{%|Jb}E!$Pr+2phvm^7($Gk^E5la^GEO`WHz0{a@d}GNdjlPwn>=XOJaPcQK^saG z5adIFARh=3`IARp@t801(F=U^I3GF8N8@~S5VMj}RL8Vn8=g1_`tS|XdSte|RH{{H z%5uHDRF@ZvrEe6^l|d-|$8A0C055*QTelT0&Xl%m z{;HkzCbTEu`e!YVKZ&}pw*y~vuemD{I6JIb4DJ)O8NU~c_M~eLvlQLtQG`LIJ(o8f zCPJ1PZfkI7I7{_fqf~FyL_puhp{5v-_K8iOX#tEQQnkwxvK z6ipBAhxnqw0M;HdKf@Efd@Rbxf_#h+^zn&Rk_E4Z>ARhkTa~rT#aq=ie+{2jmy5Tn z_|yscoyy(I#XHrz==l5ERU-|KXRaDk;CS|`p@ZYb!yNA<(xnaf*>pY#c@2(aSOIE{ zD)=vn|5Oqj=cf;Fy`N_&pYlBIT_qvR<-@jsYTcHbkas}{l{O=$|8!RZ@CQrLHBHTc za~2GV+kyr;b_n_pT-f-FtG~J{gW#={v-ud8K?Iql3Qr(OdPD_+kIH73Z8qIjhq(1{ zN?hhgK=|oNmQwP%^WehEIZJrJ4>w5@&8~#_^Ud!!xdWEHrh&Tv_shu5Z*g%`;C=wic6Jxab^y01CML>TEST>25-3-describe.test ;; ;; ;; Syntax: (describe object) ;; ;; Function Description: Describe prints, to the stream in the variable ;; *standard-output*, information about the object. Sometimes, it will describe ;; something that it finds inside something else; such recursive descriptions are ;; indented appropriately. For instance, describe of a symbol will exhibit the ;; symbol's value, its definition, and each of its properties. Describe of a ;; floating-point number will exhibit its internal representation in a way that ;; is useful for tracking down round-off errors and the like. ;; ;; Argument(s): object ;; ;; Returns: no values or what the expression (values) returns. ;; ;; Constraints/Limitations: Visual inspection of results is required to see if ;; the function describe prints sufficient information about the object. This is ;; dependent upon each implementation but it should return (values). ;; The following is an example of what describe might print: ;; (setq array-1 (make-array '(3 4) :initial-element 0)) ;; (describe array-1) => It is a simple-array (brief description) ;; Dimensions: (3 4) Element Type: t Adjustable: no Displaced: no, etc. (do-test "describe-test-function" (flet ((factorial (n) (lambda (n)(cond ((zerop n) 1) (t (* n (factorial (1- n)))))))) (eq (describe 'factorial) (values)) ) ) (do-test "describe-test-string" (let ((xyz "string")) (eq (describe xyz) (values)) ) ) (do-test "describe-test-number" (let ((number-1 10000.88)) (eq (describe number-1) (values)) ) ) (do-test "describe-test-hashtable" (let ((hashtable (make-hash-table :size 9))) (eq (describe hashtable) (values)) ) ) (do-test "describe-test-array" (let ((array-1 (make-array '(3 4) :initial-element 0))) (eq (describe array-1) (values)) ) ) (do-test "describe-test-structure" (let ((structure (defstruct line a b c))) (eq (describe structure) (values)) ) ) (do-test "describe-test-package" (let ((package-1 (make-package "abc-package" :nicknames '("NICKNAME-10")))) (and (eq (describe package-1) (values)) (if (and (fboundp 'delete-package) (member (find-package "abc-package") (list-all-packages)) ) (progn (delete-package (find-package "abc-package")) (identity T) ) T) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL b/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9a610f4ae5ab3eed652c0db8203f3ec6b0a2fe4b GIT binary patch literal 2038 zcmb7FO>7%g5Ps|Y*>MutA%8dtY@-B0|(AX95``8;uL0fHz5tFDDuzS`FY>_ zX5P$fowQt%6kaN?tQJdFg)gtwR@Z9$a=F4+%WIWIi(dvke@)VKx{(p3+3{B=+Koe& z#fmjwvzB;s&8jZVUww(6ILC{tm0}4V&YlHvB5`IiF*P;bo)!(oL;KG?Q;AdO5~n7{ z+xPD5aFH@0WRWy*2@w(@O~korN8%PC^>+=u2TwI^Ixx0AAf& zZBedp|Lv}Z)&=4pb!A)YdPqpUa6{{w4RC;0zZ<*QhYQ~k%8XpF(B9|L`Wdyd}A6lP}=A*>mzaR7_!1^_kFH$(-6_d#ey z0-}lHd&oe_>pE2rl|JLpb{U!flLSdLsCO(2qxn1_wfS|7GS7N&8D_n>w6i`~$ZzPB zPHK5Il|%U#z>K7*LQN{jX@Opn4bwPiG;9&{`U%5y8_{!^W-(O%!1{4{2$(H7T~=M+ zZ$0HVpbX|jGlQ**USEUaDMQZYpq&j9yk`V@A@3%EdVmuWp?5O8;Jr3Zp&k;&8R57 ziIRJ7C>bz0T2;IV_g+$L47C9^3JdwmmB{bj@+<3KW}|PhF_n#p0CF&J&a=VOZ15y| zZj24Z*ibhjR2{o}sZv~6C|N?ys@8<6Ra;v{OWCo7gqSv|?u{>ZCZh{KvMG-6#Vg({ z-8A^+c^J`4PEpm4b$#06~yax z>}Sn`GrfZjjz%7vm5Z8u2v0))WgY;=P?f7P+a6G;k)mL^% z`)e>^ZsT917$J@wE6uMgEX`y5M|&7pac&Po8#{J0HbbBd@*DP>$5nvbnbWl-b>CXB uCML>TEST>25-3-dribble.test ;; ;; ;; Syntax: (dribble &optional pathname) ;; ;; Function Description: (dribble pathname) rebinds *standard-input* and *standard- ;; output*, and/or takes other appropriate action, so as to send a record of the ;; input/output interaction to a file named by pathname. (dribble) terminates the ;; recording of input and output and closes the dribble file. ;; ;; Argument(s): pathname (optional) ;; ;; Returns: NIL when opened and the name of dribble file when it's closed. ;; ;; Constraints/Limitations: Due to differences in filenaming convention among ;; various operating systems, only xerox implementation is tested. For other ;; systems, use appropriate filenames for the test. ;; ;;;; Watch out for implementation-dependent filenames below ;; (do-test-group ("dribble-test-setup" :before (progn (defun file-exists? (file) "Is the dribble file created?" (cond ((probe-file file) t) (t nil))) (defun delete-if-exists (file) "Delete if dribble file exists" (cond ((probe-file file) (delete-file file)) (t t))) ) :after (progn ; just in case the file is not dribbled during test (dribble) ) ) (do-test "dribble-test" (if (string-equal (lisp-implementation-type) "xerox") (progn (and (not (dribble (pathname "{core}test-dribble"))) (print "some output") (dribble) (file-exists? "{core}test-dribble") (delete-if-exists "{core}test-dribble") ) ) (fboundp 'dribble)) ; Is it defined if not the xerox implementation? ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL b/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..11c0d959aad810dcdd07841255fac31069f77372 GIT binary patch literal 774 zcmah{T~8B16urCshC&K4kPw3t5??k>V=GOd`Z8>%u&|x2v$G;lR}$*m>455 zKKQgo3z6(<_z%7!Mjre_{)0N(nn>`$r+eqj+;h*lcZLvqs+&k}A9k88w~N|?erM1} z2kkEEwFljriw-1?Ug;L6ueXT4lYN+*vaj9Ly6%48ts^mTd-eU7_fT#fkxsYSlF8bd zJm!jpd~tO(J5?sOIbr*6&1&)fdNEhXPL0mbluR1{YH$^X6hHp83V{F7OO_p`3&Udmsq#ii`yad+gW;;Q zMm8y^$v-S1yW)F^d;veev;^m8@n@leZ;i`s<>CmQeBV}gXP4%b*z>WhOBv?hCeljd z;s=xYui?&n_7h;(c*nL?Wd`7+@pWN$Y$oJM0;B=1nzi|1Bh$=)8uLGSw>8~jB_mXa zw+Jhll;aIUB5c#v)Tp#Qr|CrKTbNVfa4B0K`;OatwxAVN`S*pev|u`t2vU)xv^uL% z&Ml5DM^qi5MN+aLtr50|$GEKp(sL$vV|0lKKoAY*6|G8=c-i6=A}V1s-Qk?FYkLTk zM-spF*N0AQI$;l{mt=LKykR-4RE_54AvSKS$+g5;NNO$zi;EIhX(?jJ>AQ8@cYA&6 zdv}D4Xyur!po4w+CF`hpH2F;-c6?Xyzxb!BY`v^=N(99>6qtsfoS1en9X^wtA3K(y K!2*0nqtS00zUAEj literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-3-ED.TEST b/internal/test/LANGUAGE/AUTO/25-3-ED.TEST new file mode 100644 index 00000000..40467198 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-3-ED.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ed ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 442 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 2, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-3-ed.test ;; ;; ;; Syntax: (ed &optional x) ;; ;; Function Description: If the implementation provides a resident editor, this function ;; should invoke it. (ed) or (ed nil) simply enters the editor, leaving one in the same ;; state as the last time he was in the editor. (ed pathname) edits the contents of the ;; file specified by pathname. The pathname may be an actual pathname or a string. ;; (ed symbol) tries to let you edit the text for the function named symbol. ;; ;; Argument(s): nil, pathname, or symbol ;; ;; Returns: ;; ;; Constraints/Limitations: This function requires user-interface so it's not realistic ;; to run this test automatically. This test merely tests to see if there is a global ;; function definition for ed, which does not necessarily mean it has met the require- ;; ments prescribed in CLtL. This will require manual testing. (do-test "ed-test" (fboundp 'ed)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL b/internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..55d58378ad253903be4b07adac3380718cc495ec GIT binary patch literal 789 zcmah{&rcIU6n?w?2^3O@frJ>Gka*cR#1=@PdKrc(ENo}%?5s%Qg_OlMDYR*~CdNpN z2TyCX5Xr8F|G_I_AF^*S{V?I|3+rnX>j)(PF5dsG;9ZoJew-j46>BH8o0yF0HQpu#dD?M|bq4ogew zS|}|ROA8Bg!)4-FS8V^SStvbRE*0nJhA&S~w0sKyYH$&UA%Hw2AUq24hGdS!Wz%Aq zlL|A!ei&qx7wkGrgu!?b`K>l?dM~|ZY-hg<8bJ6d$d+ABrD^l@`cwu7yFaxQOSm$(<^r5>8Lj&tn*pKV*#SKLv7v8`O^<7-7XxkQDonh~ zSr^QGlcRx5=%6qnIZPkOR1A)F%4%d?OEfD*PPWHK@&3 z%~&E{Cw$dn0akeSyd$IvMnk^R^n#V6@u{_ z%ZRkc3cvH$2PF=>Vvk0qRduGkV!M2`nk=eIYS7kDyGiqy)S8K=rsAaQu_sKmhsHs- z?bUqjdtIM}!9A%Wnmr`5Xm3aT&|TCxxcXc%c6eV4zlO)U5-~#sBa-1;S}apCK`bX4 SiPMyZC$247GznkO<>em*hU+o_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST b/internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST new file mode 100644 index 00000000..ae01316a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: inspect ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 442 ;; ;; Creatinspect By: John Park ;; ;; Creation Date: Oct 2, 1986 ;; ;; Last Update: ;; ;; Filinspect As: {ERIS}CML>TEST>25-3-inspect.test ;; ;; ;; Syntax: (inspect object) ;; ;; Function Description: Inspect is an interactive version of describe. The nature ;; of the interaction is implementation-dependent, but the purpose of inspect is to ;; make it easy to wander through a data structure, examining and modifying parts ;; of it. Implementations are encouraged to respond to the typing of the character ? ;; by providing help, including a list of commands. ;; ;; Argument(s): object ;; ;; Returns: process (i.e #) ;; ;; Constraints/Limitations: This function requires user-interface so it's not ;; realistic to run this test automatically. This test merely tests to see if ;; there is a global function definition for inspect, which does not necessarily ;; mean it has met the requirements prescribed in CLtL. This will require ;; manual testing. (do-test "inspect-test" (fboundp 'inspect)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL b/internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..231176227741dc5c5312d79b41d642c2671c1db7 GIT binary patch literal 791 zcmah{&rcIU6n?u)OACb*B9IsZ8xk%X2W=?{l+(COp|G9B*;x?}CQaG0Oo(iR#WPryj{^v_S$0KKY4)O?6&0X>cqZN~z$ZKT@P< zOGv|O1mwhDln7l4{A6|!Eg)u^B{)5aH=-GSxaS+v**@(3+>p0N?~h5b1b}<_ttN(Z zFHhWlICKx)^F4s^cY`U(J^MvPe%agnKz{@D-1l@tmPP=M-0zdyeSHzIfJp&d)GFgW zH(g7E91A}C4>aARtHo$ww2tYjK^S^c6cxH=Y4U(@VocL9*Vhpv+-5?F-nSxd?O2?Y zWa-}*+|oc#2WyNWP zYdi|4low(dEzfJ9j??Zu3;Y=_qB?tkXVq$1{Lx*twtxM-qT0cn6nqViWkEcxGlDrm ccleDWCkz`_I2=6_q)%;=lW-Eg%v@dl0g$-vEdT%j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST b/internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST new file mode 100644 index 00000000..ae0f49f1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: room ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 441 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 9, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-3-room.test ;; ;; ;; Syntax: (room &optional x) ;; ;; Function Description: Room prints, to the stream in the variable ;; *standard-output*, information about the sate of internal storage and its ;; management. This might include descriptions of the amount of memory in use ;; and the degree of memory compaction, possibly broken down by internal data ;; type if that is appropriate. (room nil) prints out a minimal amount of ;; information. (room t) prints out a maximal amount of information. ;; Simply (room) prints out an intermediate amount of information that is likely ;; to be useful. ;; Example: ;; Type Assigned Free items In use ;; Total alloc ;; pages [items] ;; FIXP 10 1280 670 610 ;; 68329 ;; FLOATP 14 1792 1176 616 ;; 75731 ;; LISTP ~ 1126 130616 963 129653 ;; 1052227 ;; ARRAYP 4 256 163 93 ;; 9512 ;; STRINGP 146 9344 1367 7977 ;; 26366 ;; STACKP 2 256 256 0 ;; 737 ;; VMEMPAGEP 136 136 30 106 ;; 489 ;; STREAM 36 162 8 154 ;; 1226 ;; BITMAP 12 510 45 465 ;; 1560 ;; COMPILED-CLOSURE ;; 30 1920 1607 313 ;; 22852 ;; ONED-ARRAY 2 85 64 21 ;; 693 ;; TWOD-ARRAY 2 85 80 5 ;; 14 ;; GENERAL-ARRAY 2 64 53 11 ;; 327 ;; ;; TOTAL 5356 ;; ;; Data Spaces Summary ;; Allocated Remaining ;; Pages Pages ;; Datatypes (incl. LISTP etc.) 2020 \ ;; ArrayBlocks (variable) 3822 -- 51492 ;; ArrayBlocks (chunked) 3336 / ;; Litatoms 1036 1012 ;; ;; variable-datum free list: ;; le 4 19 items; 76 cells. ;; le 16 89 items; 939 cells. ;; le 64 48 items; 1261 cells. ;; le 256 5 items; 385 cells. ;; le 1024 1 items; 428 cells. ;; le 4096 1 items; 1456 cells. ;; le 16384 1 items; 7992 cells. ;; others 1 items; 30998 cells. ;; ;; Total cells free: 43535 total pages: 341 ;; ;; Argument(s): nil or t ;; ;; Returns: No value or (values) ;; ;; Constraints/Limitations: none (do-test "room-test" (and (eq (room) (values)) (eq (room t) (values)) (eq (room nil) (values)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..da40ef37b239d96b56c797197480526700da6ff9 GIT binary patch literal 1493 zcmbVLTW=dh6h33ew_GZxB571gvx?MKTD(!5CTeRQ&}2PnoUC`#-8F40@nD<{Hge+N z*a(EEq6+nC5jYXnPEp@@MS@6`C`Ii9Jm$yrAB1yuLuebRAY`p)&Sk#uoHO6_AaO@G z6uq^%-DrAkrPb|hcRR{PtF7#`y6u{$Y@lEHQnzgJ)e_fNrr*mCIxj_PZLiw#))lww z?W|Y7$SL_73g2!wnz*@s9nE}Uezq_-H$Aw>9V0^f*E4g4nHz<<{Pf__qdv>F0H6lX zX~_U&Ar8TwpH*GqxY}aL5Sq!$LJfL>pT=IaiX-g6ADvY?t!=I8edaZ(oy{F!0Ks>D zda+{aZpku(eYVSngKzzjlBum?Yy75wSo#=+&{^PTX6Lo5np-Lhc+^kc#}fXeI)1A^ zU1m?V;MwoXvD;_PkFo@LKL(&>C|V8=?w)oQ4)oK`!-L$b&aEri7YF07`p7!mtw+D7 zNOkspYM9lZJTr0sqPOym`3FF+{=i(0u@Qj1`p@IH!_m>fG{7*x^G5A#ubypWA(jZf z_b;frWfn^`3vG#;MMK!yLJ2+QO-GFl;E+dEoxA#yW(&7s6nwiz1volu6PgN`uS?^4u1BM(B7^qf+k52_YwD{6y#YeQRG`1rBlkeW8&jUZ@xHe7u(_lYFZANBfByLqKS71kfC!GkK zr1?o7(s=LTdkFmV&Fbby>s2CneVSOy@if_hyug@L06q-%<48B)2=^8eusd=RYrc~G zpwCh$y;}IjCML>TEST>25-3-time.test ;; ;; ;; Syntax: (time form) ;; ;; Function Description: This evaluates form and returns what form returns. ;; However, as a side effect, various timing data and other information are printed ;; to the stream that is the value of *trace-output*. ;; ;; Argument(s): form ;; ;; Returns: value of (form) ;; ;; Constraints/Limitations: none (do-test "time-test" (and (equal (time (identity '(a b c))) '(a b c)) (eql (time (cos 0)) 1.0) (equal (time ((lambda (x y) (append x y)) '(a b) '(c d))) '(a b c d)) (eq (time (setq x 10000)) 10000) (equal (time (string 'strings)) "STRINGS"))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c57c63325036ea868cae7669f455cbce24dec060 GIT binary patch literal 1962 zcma)7-A~(A6u&l*CVZqJqjXCtn5voDs22f)sfB66HJ6a$*vxiFnI=svxJ{TL2tu`~ zT2-|V-BznzS{3Pzt4I=96KqDA#IT8p5OVpzkAO)H&xPd zSy3gWyu4a+>@}&pQCZ!nNLR{h(t3Ggtzb)6KrdZabc200Eh{qv<3p|HK1*TEUZ~iM zlC@#4FD`s}P8zx($*XH62ZZzI0S=9g4v&qD475(krW$1X&zO<1!3$%fg9ELvpKJ=T zG9jcuYPduQiIFDaJ#b?wikAtAb#t}F`@YU(`ZeP0^F^t_x0$ngj9=n^yrKzfMazl zk?+MI{KAIq7+a8P+vM>+Qo^MMsc=34Ty{Rlcj5A0z8jZRzDunC2}`>>@8rARKqs>M zC?C)Fyu4X#{Qqxe#}8!&2f2hCYQ-2{_anC_rRdsZ25Um6Wo=Sr2ECX8jg~f3Vu(k? z7ASaUN|7yPni|Z?8Bj3AuXxCuH!YSGMeyhfT0&8otmS6ulx}3r6c69`hj>u@Nx$awV_jo|Jl529sO17!+Igg@6|C+1<3Jw;U07EvIz-RE z5BMl_UNprFLpP|Nvu1NvswswXDOsDRz8=|oZfxj4Cr6;nycyd!j{P?ZiJIA*tRgrA zAcQBEErdx(*s0_UgK7I_g$rmq2DYxfn^$C$1>5pAFq0aXyAN&rSsp`&XS^4e?O?gb zPawL>d#>}722{1nWY!cl=d%}el{RMXLogiqBs-^OOlusd9y@e{AubK@{v?-9@%{vO z#na3>FnnRyOc(@P%dDZNHAEeV{Ch(rz^I2bya>D(@&`|@^3zv&@-k1(@LoT>AI5vp zE|eE-y0KEaX0NR;IJ8n)wrRy)uV9jsp4(@EESn4Ejx zdk?V#dliGp7NZAlRn1t;kX4hnp&PLLD5qPDpT^ibo_peO66?5}k@e2I4YMdL|LNy@Yfn?( zvhjrNt<_Qt-XZ7&XJPrX#RaVH!Fhw<4Z)u`7&*_4;M-5Jft&lFn_H6%eiP=Y39psP zdZ4-?gJtzOhVy;&K>K6y+c1=>OiNqS{?AW1qggD?j9Ee^Z?}*i&b1iLenasy&@TKe LKTRHwzkdBUqEbGr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST new file mode 100644 index 00000000..75e3fbd1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: decode-universal-time ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 446 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 19,1986 ;; ;; Last Update: Oct 2, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-4-decode-universal-time.test ;; ;; ;; Syntax: (decode-universal-time universal-time &optiona time-zone) ;; ;; Function Description: This function returns the time specified by universal-time ;; in Universal Time format, converted to Decoded Time format. ;; ;; Argument(s): Universal-time: time in Universal Time format (integer) ;; time-zone (&optional): integer (between -12 and 12) ;; ;; Returns: Nine values (second, minute, hour, date, month, year, day-of-week, ;; daylight-saving-time-p, and time-zone) ;; ;; Constraints/Limitations: none (do-test-group ("decode-universal-time-setup" :before (progn (setq universal-time (get-universal-time)) (setq decoded-time (multiple-value-list (decode-universal-time universal-time))) (setq decoded-time-zone0 (multiple-value-list (decode-universal-time universal-time 0))) (setq decoded-time-zone9 (multiple-value-list (decode-universal-time universal-time 9))) (setq Oct-1-86 (encode-universal-time 54 25 13 1 10 1986)) (defun decode-universal-timep (time-list) (if (and (eq (list-length time-list) 9) (every #'integerp (remove (eighth time-list) time-list)) (and (>= (first time-list) 0) (<= (first time-list) 59)) (and (>= (second time-list) 0) (<= (second time-list) 59)) (and (>= (third time-list) 0) (<= (third time-list) 23)) (and (>= (fourth time-list) 1) (<= (fourth time-list) 31)) (and (>= (fifth time-list) 1) (<= (fifth time-list) 12)) (>= (sixth time-list) 1986) (and (>= (seventh time-list) 0) (<= (seventh time-list) 6)) (or (eq (eighth time-list) T)(eq (eighth time-list) NIL)) (and (>= (ninth time-list) -12)(<= (ninth time-list) 12))) t nil)))) (do-test "decode-universal-time-test" (and (decode-universal-timep decoded-time) (decode-universal-timep decoded-time-zone0) (decode-universal-timep decoded-time-zone9) (eq (ninth decoded-time-zone0) 0) (eq (ninth decoded-time-zone9) 9) (> universal-time Oct-1-86) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c81b06309e7f9c997d74ff2655e9c6ce6f6b0668 GIT binary patch literal 2204 zcma)7L2MgU5dCX6j+3UY?Yc>Dqp%HW6fOBCPLqga7TWl$b zL*i6IKq*B64wjM-sCEmzaqJ;fNT_O&rNW&aKpZ$AapVFVkje!!vzxSW5~wdSkV0&lEaYYX#l4e`l~ytuMjUWCo~IIziyv5|?<(M0={sLP(Wr`n88B!?%G z=M(LXTQ|6Hg%DCCbtG+sgo&TnpVY#F!E}R8Wn@MbafS)@mR$=%E;O$*&8|g8_-bW^ zE?QTtMNDUDjc|n6o3-FnUXhH9s@U7yHLkZgnby>z0&_|rgjd1&c|wJDLxki3pL~e+nt9;I~W9GxX7m% z|5%LQ$w4llX~yBKJK}!E&BW{mIpD<$cX$lSWhr*3(rM>_EE>+i& zrGfxniG$O6DU6NsS*=HqR3(+cZlcqol9HK5Co>>X(z@UaIBmWbXw`@yiH0;yHD=^B zXf?_0)qq~m4L0NRfkw=0W=UqElF!j8Rh!WThx2iVtqoOhj{7?RIGJMDl_|FwsVqMJ z0I+ra?P%)t?Vd(PH=M9P_<#mq?4fSx`Ym7&~#b^?03$#z;* z(pgvlb^&-W&E&;VOtTxHNRyrHmFF242qA%KnyOJXZ{+fZ;E#iHhaf5i>dNtI{AWNG zh0@?8pk8%of$8A72VEaP6sUn+3nvfEq>cz7&M_QBQJf@yz}d&xtSBS%8!!Rv1kphD zSM)07HH|6zrk=wg_5)zCC!HvXI`blRjw5^%Jo&{*9rqi~b4Y6FT+HQ|l0x=9Px_8C zh}@e1wg4y>kXr=qq+XbrRAst1I#Ip={oj6$!POV24!t2Wl+HN6jha%Z@70LTf;uNa=0t4JyE>;#Sy1rb#Vy&*tFVbpx$)Z(jt%@2y+qGv6*zJUn&_e0kY>r%-kkW9B}DJAxxmANdfV!WB?(&clxU^?3Kd{@mWi&%0OBm}oG1 z;ELpo!8B3Uo#Utm>A#v+4dx}XW7p0c9r>D7U0=b2ZrioQ#3X|jVcrAhzS@|Wm&{%k zSM}Yz5(RrZaEWyF`oX;QQ_bFPJrV1O1(ADjz0qhq${rH^n`#n~mzvm?3r%d`g(kLj l5YBsY!r3M;7zePcx3$MT{^2pVR?dr131{4)CML>TEST>25-4-encode-universal-time.test ;; ;; ;; Syntax: (encode-universal-time second minute hour date month year ;; &optional time-zone) ;; ;; Function Description: This function returns the encoded time (in Universal Time ;; format), which was specified by the given components of decoded time. ;; ;; Argument(s): Second (integer between 0 and 59, inclusive) ;; Minute (integer between 0 and 59, inclusive) ;; Hour (integer between 0 and 23, inclusive) ;; Date (integer between 1 and 31, inclusive) ;; Month (integer between 1 and 12) ;; Year (integer indicating the year A.D. eg: 1986) ;; Time-zone (optional) (integer specified as the number of hours ;; west of GMT (Greenwich Mean Time). eg: California- 8 ;; ;; Returns: Encoded time (integer) ;; ;; Constraints/Limitations: none (do-test-group ("encode-universal-time-setup" :before (progn (setq decoded-time-yr2000 '(23 30 7 28 8 2000)) (setq decoded-time-LA '(10 20 12 20 8 1986 8)) (setq decoded-time-LA-nosaving '(10 20 12 20 8 1986)) (setq decoded-time-Denver '(10 20 12 20 8 1986 7)) (setq decoded-time-Chicago '(10 20 12 20 8 1986 6)) (setq decoded-time-NewYork '(10 20 12 20 8 1986 5)) (setq decoded-time-GreenWich '(10 20 12 20 8 1986 0)) (setq decoded-time-Greenland '(10 20 12 20 8 1986 -2)) (setq decoded-time-HongKong '(10 20 12 20 8 1986 -8)) (setq decoded-time-yr1940 '(59 0 23 30 3 1940)) (setq decoded-time-list (list decoded-time-yr2000 decoded-time-LA decoded-time-Denver decoded-time-Chicago decoded-time-NewYork decoded-time-GreenWich decoded-time-Greenland decoded-time-HongKong decoded-time-yr1940)))) (do-test "encode-universal-time-test" (and (setq encoded-time-list (mapcar #'eval (mapcar #'(lambda (x) (append '(encode-universal-time) x)) decoded-time-list))) (every #'integerp encoded-time-list) (apply #'> encoded-time-list) (setq LA-time-saving-yes (eval (append '(encode-universal-time) decoded-time-LA))) (setq LA-time-saving-no (eval (append '(encode-universal-time) decoded-time-LA-nosaving))) (= (abs(- LA-time-saving-yes LA-time-saving-no)) 3600)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..eec97a32dac0622505f528007f0b72d72d256293 GIT binary patch literal 1661 zcma)6&2Jk;6rb57j-9VMB{Z#7@U{>H784~QMI}Ap&3a;+tar`sI3c1^73@uH*u+-i zpdv&R^+JIa#jS{TsCucmlePz_T4br*IKTz|2Ck9HwS+gjHi=v$Sg*D3^Y`Aok7=Nu zcT`PQt82B2V{gdSt$J;%F0WKKAAyGa=lt3j{TwSh~unn zB8-stl^dQb=qk$^x_1Nb-~sQNJDAl;9*(A@DU!l16oHOC_t~j)WSXQYBPpsHDVicI zo1^H~ZsZE2^ZRgA5@|gsKb*(+*U{x4=cUEtv0)rqMMx+H5o(70w2LFn%0rMIztTI5 z%l9u0HH{%)_Z!+ZW9TP@8s$%op?L{|M`Q2Q;tAm`{@^_TAeG|D=HA7lv3_gE3NMa8 zS^hWn=)Yn^DsROArdf`P8hq`ZPN;^S%8EjfjH0JBYLeM3Nc6OokU~5n^*|Sf6RN`0 z3^6Gym{3L4Z$rphvKY-t5?G7`eNr{5=!HC)Gt8Wo;8?;>dov@!`@14M(lrRm9%iJJ zrGL6A`q9-7-5N?z(=<$C6j;8%5?upeJCIQHCF08kxaUSEJGvj~Mu>NdmiLRs{R%+c zbV1Ps^9Y!bNK9dZZHmm)f@xCy$b4}ubl-t)+uWi0+W=2 z2Pa{L;JtkZ{guS;KY83JUrl1?0(^HWAp9dK1=7!eI28W^{(<~+K{=ys`+EWye;{za z@JT1$R_zMDrE>$?8Ss^NFZ-;7*Lxp5d3?RRw;J%R5MQ=AClr{cTLKAJ_J7DUG69+Z z7g^tZsjZgq+Mhn&Gl!B^$enWMuThD@HhXT&Szdduv@Dw0xfXCGVt*}QGdwpU?lvN3 zvpWuR*f&NOsJTQe*m;efhK7brnll#YF(8k1%%|vgzi=fQ)zd8F->l)R&S;vNd4#(C S+2Jq1WbhYx9DVcp!NK3l=<@{t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST new file mode 100644 index 00000000..95523211 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-decoded-time ;; ;; Source: Guy L Steele's CLTL Chapter 24: Miscellaneous Features ;; Section: 24.4.1 Time Functions ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-4-get-decoded-time.test ;; ;; ;; Syntax: (get-decoded-time) ;; ;; Function Description: This function returns the current time in Decoded Time ;; format. Nine values are returned; second, minute, hour, date, month, year, ;; day-of-week, daylight-saving-time-p, and time-zone. ;; ;; Argument(s): none ;; ;; Returns: second, minute, hour, date, month, year, ;; day-of-week, daylight-saving-time-p, and time-zone ;; ;; Constraints/Limitations: none (do-test-group "get-decoded-time-setup" :before (progn (defun get-decoded-timep (time-list) (if (and (eq (list-length time-list) 9) (every #'integerp (remove (eighth time-list) time-list)) (and (>= (first time-list) 0) (<= (first time-list) 59)) (and (>= (second time-list) 0) (<= (second time-list) 59)) (and (>= (third time-list) 0) (<= (third time-list) 23)) (and (>= (fourth time-list) 1) (<= (fourth time-list) 31)) (and (>= (fifth time-list) 1) (<= (fifth time-list) 12)) (>= (sixth time-list) 1986) (and (>= (seventh time-list) 0) (<= (seventh time-list) 6)) (or (eq (eighth time-list) T)(eq (eighth time-list) NIL)) (and (>= (ninth time-list) -12)(<= (ninth time-list) 12))) t nil)) (setq today (multiple-value-list (get-decoded-time)))) (do-test "get-decoded-time-test" (get-decoded-timep today))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3fe1009c9c3ea79dff1120623d2c11d15a376508 GIT binary patch literal 2682 zcmbtW%WoS+7@u7`j`Ma>_vNImDYR;rPH56pN`ruI*5i0%dw09LZfb-?-Ndb3IS&#W zQ9&!yg5Y4O4QazptKPU%4v3^lu>=wl2X62eAc4dQi4&*ree2jsN~I!^*qNDczQ^x- zP8Lbi1tk$yW~b-!h3tHIwp5%e6~mWj=fexLrTNKh_%hJL?<=~=uE%60-v8=AtF`TB zaz2|WW~ah-DZ4P0xppEva3(Cz&F2fS86Jk?z{u&rk)fgf)~IYHYTBMFGc+=Aa%5<@ zzjfo`vJjXhgiMkuE-i!vh=(|zRRWUDESpBv1f!aqWRkP!RQ%uzObf_9Nz%_Y{5z)V?1+@!KrFZZ&9in5* zrmAK$Q-&cf#?{ z#l&sB^Ls)TbD!v)aZv!t#YdruJ#`!)+74Foll!V)kspw{>4-2`cf?#wI%{w;0m5^wW#@D@)SR9UCQOj9?hp0bUUEqU5Opk0!+GQZCht?0q;r(Z7Yn5Y_S?}?)JdzplQ#u+XSV<|c_?pO;$x%H)>rGtZ2d;vegAf*ZG@)8Cid+_jEK}Wp z(5Y`S)0za9U0W=&qA<(SP3x_lbi-s36$*f*_Ox<`5eD6JC*=9l$dRt8OJs%=pNYQbWd9~AncCi|c!RN+Ujfd}o1ZltND zs7zBB@0meTQjW7N(iI>zHyAE*Da|DfXf2yGYVe*hK(HH~rtE@&QEs>z0XJH=-7r(; z(ivb6G+3xUI?fdP1ed~G>OwC+bSitUWQ#OEQ_RlKWC|3XlL9T~r?Yr_-KiY1vkS%W z;T!Vd@Z}6VMN{GYOzjmx+6|16aLjq&EMapVRA4yUj6PMT2^CsJPFTDR*&y`iQo7CD z7zz8G%8`a~v`b4f`Qied%g)nCML>TEST>25-4-get-internal-real-time.test ;; ;; ;; Syntax: (get-internal-real-time) ;; ;; Function Description: This function returns the current real time in Internal ;; Time Format. This time is relative to an arbitrary time base, but the difference ;; between the values of two calls to this function will be the amount of elapsed ;; real time between the two calls measured in the units defined by ;; internal-time-units-per-second. ;; ;; Argument(s): none ;; ;; Returns: Integer ;; ;; Constraints/Limitations: none (do-test-group ("get-internal-real-time-setup" :before (progn (setq before-internal-time (get-internal-real-time)) (defstruct science physics chemistry math) (setq after-internal-time (get-internal-real-time)))) (do-test "internal-time-units-per-second-exist?" (and (integerp internal-time-units-per-second) (boundp 'internal-time-units-per-second))) (do-test "get-internal-real-time" (and(integerp (get-internal-real-time)) (> (- after-internal-time before-internal-time) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1384490c893a85c2ada61c46298e318265324cc1 GIT binary patch literal 2678 zcmbtW+iw(A7(X++-EQyO(h6(~tSAIVPNk(JP@^)PJ=>jjc4nBFrPP?n(k|?h-rVjQ zi9#08=))#Z3v~{JH{ZnvV@r#hXky}nZ~7OQXyTKJPd?S}o4vF}5=?A&bI$qBclmwS zvrDAmyrM;v`Pqf+Oga~tFXR^r`N*aDTx4;+kefontH&Y(rz7%0E;|F8Q>WlKFnn@wcxb4_hK51xILK^1 zToFR^gpesx#-)jn5b+WBvrj*fWkd{CwV-yvErkb9(jhv^9IEOL zvvgUbR#K;qnqcJNO3O_`ga@4=5wWdjHpYduIr8(9adDzM+$jWtfID2iOh^{*TL{5D zZt*)4fJ1Xbg$P^tY~yIF(7|7n*}0%}^}e=6OMT_+2Jm*>Y}_Se*4}9^8|`rXb4j~x zw0}>?Qsxt*eOweka_Lcc;)NOx5N!o3*{MC{ugDKbtvVtM)*J~|ApB?TyPv6jyXyNj z)lFdjL}V#j%zQr4Hxd5j%3sCI|Fi>O$HEw~Oo)h0?!8iwsfc$ZrW4Lnu$ZBSv{kF~xVi}fBr@w0QXhKEn#5I`4X2ag}44@%Oq zn7*yCxPW&Bgtiq%MYdT5IQM$s4bar{%q~IU2;YOtKE4;1W*&xx{D#IyjHDhl@%Wv` zL&_cx`Le?E5%0yjA|$cfW=@RSlZg>SqqP<;@O@W6&3=fAJff*~oFbP^A<5J*A#&C?M!TrztycVwCHyM!}8dZ8yx4xpW%X zLv{mt z7Zy=Q)(t$J6F1M=~^`WPTj+|@Neu0IEPBN1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST new file mode 100644 index 00000000..d0bd3f6d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-internal-run-time ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 446 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 20,1986 ;; ;; Last Update: Oct 2, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-4-get-internal-run-time.test ;; ;; ;; Syntax: (get-internal-run-time) ;; ;; Function Description: This function returns the current run time. The intent is ;; that the difference between the two calls during which computational effort was ;; expended on behalf of the executing program. ;; ;; Argument(s): none ;; ;; Returns: Integer ;; ;; Constraints/Limitations: none (do-test-group ("get-internal-run-time-setup" :before (progn (setq before-internal-time (get-internal-run-time)) (defstruct science physics chemistry math) (setq after-internal-time (get-internal-run-time)))) (do-test "internal-time-units-per-second-exist?" (and (integerp internal-time-units-per-second) (boundp 'internal-time-units-per-second))) (do-test "get-internal-run-time" (and(integerp (get-internal-run-time)) (> (- after-internal-time before-internal-time) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..390df6d30d69b4c8c9e8eba3cba2ee27ff4532f1 GIT binary patch literal 1378 zcma)6-*4Mg6ux%aG{2f9SzslUVWk2jiyJMaLtT0DoZHmIu{-;^VF(FTsk>N8n<#N6 zA+)L*AcSPJg^A%iG#>a1roBxJ<$<^T2fXr*G%@kO!&J^qT2{JAAlbh6oO91P-#Op$ z9ir(ER9#X#J6*5s_N30h?+$!vyVH~Uok6eZO5329K2=SNTw7DrTIs!V!ainc_S{Y1 z-ID0Q?Qd;<^0rjIASvCR*M`mVGKl4s^NTA>OQpoBV(XJ=|LL=|0&a`vN{NHJw}ngx zA=E@8zQhsApa=@T2{JMzHpQ!&POzcWi5w2YAO^Ky$0k-7WEUmB)5UG~s@vw}?DUa< zP@W(CE`-6E#q)RxR|&-L;oX%!M4(zAa!A5RiWw{wg`1BU_l+z7_~3k zl+;BLPUI&%t2$8(XC1GaR^67FAPUcWQ&VQiNE{5Q3Q^4psf?-mXD~RWky$XO|IH=K zM3O8XNpVMFJaYtn0(42msp9elc$VJi6nB*s<1!xWIlwT; zlut}xdv?sh;eMjnZRwogDwB8xvFB5 zNm|CkqMNM1m#^8Y*Vudw!seczUIOZuCZ(R3>(_v~nUCrlx@OY?oXT+L*K+$ch&9nH{00v zc3kYceV?2E41?Dx?4{zKQk1qg;r7{*yxqyg!F79Y@MCwv@55VsKF+EZQ7FMD8lr2I zSc-15BtHiDE;%M8tjK-83WK>9An3dPpv&!Fgh6TLA^|qYCML>TEST>25-4-get-universal-time.test ;; ;; ;; Syntax: (get-universal-time) ;; ;; Function Description: This function returns the current time of day as a single ;; integer in Universal Time format. ;; ;; Argument(s): none ;; ;; Returns: integer in Universal Time format. ;; ;; Constraints/Limitations: none (do-test-group "get-universal-time-setup" :before (progn (setq decoded-time (multiple-value-list (get-decoded-time))) (setq encoded-time (encode-universal-time (first decoded-time) (second decoded-time) (third decoded-time) (fourth decoded-time) (fifth decoded-time) (sixth decoded-time))) (setq universal-time (get-universal-time)) (setq Aug-19-1986 (encode-universal-time 0 0 0 19 8 1986))) (do-test "get-universal-time-test" (and (integerp universal-time) (>= universal-time encoded-time) (> universal-time Aug-19-1986)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9e2225e37a8cf4f03acd97f3cc340e960fd1c17f GIT binary patch literal 849 zcmah{-%ry}6uxcQ4`7f%j2JX{L*h&0CD|AWqA%BS2ZgSkx3?gPFUu&d$+j+AM`Db` z_~28G4kBqa{13h&Mjrf!{15PSm|!r`r*nFGzVDpxJ9mImPc;K;eyig(-7fa~L8l+! zJ->^4e!p9H@gCIiOU>f!)jHKS7akVI>_7h0yKXITcd_WZz1`Z2`?&A`(@xiGLbALJ zpM{mB;!3HsFjl6vamn^yOlbvRi;D|m7bnM3-bV=4(RmU^5y~S4MTcQt70ec-tQ(A& zw8GSA5QSOLLL8g%D4Z(d!0(WzyYDs=IjtU&5Q;v8*|KA5LbuH5NO~>hqW9s1ZjvfU zqiYPw+21S)yA*}ExI{|C(CsSGD^-J4m?>z2CR>c#5YfqT`dPBt*T&g~blOH+-!|m! z$=N9>l^yPT_8g(rgS*Y*iisKc-ZT3T>TmCL9iWw4otsd&d^6 zB1?aF2uqE}l}tRUWWj?;m2qxyVmYGf2vr#cKu)FR4jI;MH3l>Cg=?N>6olfD#K=?? zNYZ7CSE#5Y!!(C;@apP7vGfS)H?DMO)Ml6L@%SvDGq&KMr#b`q?SD9~6rmwCTuX&} zrp;uiF&E!bbhua3>vf3N>NMS!+YV}h=eNne+wCPWaC-rZ!n*<@o_O=jcd=W#=@`s9@yU&W0`+r-mJmCvC9H6UP!PoCML>TEST>25-4-lisp-implementation-version.test ;; ;; ;; Syntax: (lisp-implementation-version) ;; ;; Function Description: A string is returned that identifies the version of ;; the particular common lisp implementation. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "lisp-implementation-version-test" (stringp (lisp-implementation-version))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8181e2c47b21680fd57f97aeaa10e6ed4891b2d5 GIT binary patch literal 810 zcmah{&rcIU7@ggvKY&6C8ZpG+gv86nX>3yxL@(?T;kpBUG+nR`Y@H8`T=6m0J@0%e?Jk?FCd+lzs<@T^Q@Vf&a z*S#L@dxKuh#dW~(OWor1)uyIz=N{yz>`OPbo?G?ZJuC)pf3N!DF3#V_TDRA1!De+8 zj`_8f!dkJIn<{CxIcEEBO>qs%iuZC;7bnM3)$yLMZ$Yq)QIdg<-MqNO~=0!uP?9!AJ$H zX&V&D>EA3dyA%f33M-^YOp9$0+YsYc=;S#0ELQWiakeF$cF>b=Tk_8A;+&L7k0hS$ zBQ*aem5~~!-x=(G4!7U29|#Q_Z`qbC%^-Bx_;O=sWGv=^stiKs&D#91k!@y?oCrS# zw^ZF?>qe}UY-()Xq?|l50AU-pDo;QJbE>WheUor191a%rQ3gqS*A}!aOaHzQmKsef zsc2G3gY8+Ba&B>AIilhSRhfi>jH&0{_|kl^9bBLeWH=U7`Xc$&$s(nkdK3 zbcb`wF3lv89s+*-j}Kk5>6ks5UWDqDEjak8EW~pD4p}JxmKZ5fVQNVh_c52En~DKb zX?dM}(r@}M=~UY;@!h^p!{D}n6)zuX%eY>JZ@Y(^o$-&0v4cBO_&Ge1LDG`WsRq-$ bqRfN|bIr7)>G&D6f9zO-MhoZ@zPR`W54rIA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST new file mode 100644 index 00000000..a95f68df --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: long-site-name ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-long-site-name.test ;; ;; ;; Syntax: (long-site-name) ;; ;; Function Description: A string is returned that identifies the physical ;; location of the computer hardware. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "long-site-name-test" (stringp (long-site-name))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..424df4b37b1f700a5430a290a6c55b22330b616e GIT binary patch literal 816 zcmah{O-~a+7@pmwA3z}sQ8C2egv86nA!$<#qL*=)(uM78ot+g)yfkHNH|bZ}t%)%b zIG@ z(e1-Qci69cupx2yirAdKE@QI2@*qFuTso=uy;|VyK{50Od$pH$Vg5eEy}sX)#oC(O z=GRvX>&4>AR0%uQ1>1jnitDnicyDFu{P;-Gy8wVXI7^mE0Cb>%=pfV$K^=igrbQ9M z6>3DID9lPP$aN@>!npzrx;@nLUU;p5+2!=1K`ZB&ySkAuLCs| zeF|?G#AX|2q7{`f+ps7{k4%ZMO~+6tWC(Kx!Ge?#r^4mZ1R1B0c6J>>E2{GE4PhJc zw3dk{wX8HgYf#Q@j%-&{U14aGvLR<+wu{ENW5hB6J%1(0j0QkFk))TZN|JQR<`pa| z$z#OjoU%((iIs;EzxLM$!4AD(kEa)9cg7K1`l&9+TE7~zR*-0Fti_O%OS9x9Ybm~| znQ}7iTD|FaJmhxvqRmxf- foMJ)I6?K*=D94r)Pbb%;fXA*aXuJSE!}Igs-P!Xi literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST new file mode 100644 index 00000000..36b29e22 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: machine-instance ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-machine-instance.test ;; ;; ;; Syntax: (machine-instance) ;; ;; Function Description: A string is returned that identifies the particular ;; instance of the computer hardware on which Common Lisp is running; this ;; might be a local nickname. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "machine-instance-test" (stringp (machine-instance))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a0734874e7e5b2377a16f32b673ca4cc4bdf2ea0 GIT binary patch literal 1052 zcmah|%}*0S6rXJ=w0zVBNvp)b2BRh$hgiM>cv_bM7PhlxcN)ONn5HbYNuf*uO!A5tyInz zKo}bXH8C+VI59jt&^o0#=0&yt<_u4WG{`wWI*{ZdLMV%B;xB@bjDpDD^JJ9~hv6y1 zB$#SRqWV?e3j-FMc8KkJor6lHSi%MOxmyr$R@ae)kpIC8Po=5O42$~v(vH;bzxO%} zic?u0;>ubgL4K7=~JZ0HQjS2NoG}Y6# zO=!cexg>mV!Pk9>N!J{5(TTU^ph}CwY`~UsL2hqcUMV+D2#QH|AR<%;xd{i>OvU(Sf%k-k z^AjA=Y9^b@uerFgRf3PZUJ;Ic-|J%_EB)JAzp|2ncebqL*Djujux;OY;(Hy7#I_dU z89f-AZPdm`8?>RpyA9gdXpirO7Tt1jQ}Pe}{QwZvtJ_3l1YhCHG#Ifp)8TC*3{cFc NEk^iF^!eWT`5*iRF6RIM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST new file mode 100644 index 00000000..5859eafb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: machine-type ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: Dec 19, 86 ;; ;; Filed As: {ERIS}CML>TEST>25-5-machine-type.test ;; ;; ;; Syntax: (machine-type) ;; ;; Function Description: A string is returned that identifies the generic name ;; of the computer hardware on which Common Lisp is running. ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "machine-type-test" (if (string-equal (lisp-implementation-type) "Xerox") (or (string-equal (machine-type) "XEROX 1186") (string-equal (machine-type) "XEROX 1132") (string-equal (machine-type) "XEROX 1109") (string-equal (machine-type) "XEROX 1108")) (stringp (machine-type))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..402dccbecbc505612fb1bcf82da5e39175e50ba1 GIT binary patch literal 813 zcmah{T~8B16urAkKY)UT5HZBygv6JPLu^wLtiFuPlrC&%>+BRH@uew?-K2DzevlX= zF+TXTMhlVbYWNSnB1RtkL;eGtEhZX#@M-RzoqO&%=gtrkPYnwh{(i@6xn1NB`kg@^ z?fG5Q^9S9Ai}oarUK%#1ugb*OTz;6FaQ^z!=(_d3yNkrY?d{fI+(Wqsh;+JMOBSoE z@-tUl$rlTS<%tq;tSh$v_7sY_eDQvMdE)Z)M9KO9(145h7zfCL2H{bV)dh6~E}0g^ zj8v!|4#OZVz2KTdc^J&(QQz<2mV4l~VmtdiPyoUYLAq39hA?dw9xJbvO!z*SG8wK) zYh;~*n*PlavnydRmtVmJTp>o;WE5{v?#NC!JxM-`<$P_PZzyMN*!s4iZci`FD2en) zB~l(qeD04AgE;hxJ(^sQ-6=8Cm`>l@cn*76cejHKvtZ%GypvKFIT znko0PUvD(Mwu=wkZqM`ExbOD*Gz{(td7`C5vV`{P^5yO#uYL9CV(jp)5`GSkRVixG g;FJi8uW7SPK{>IUXfnPg=Rc|0f=2W330+?P0!6R#bN~PV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST new file mode 100644 index 00000000..b614cc65 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: machine-version ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-machine-version.test ;; ;; ;; Syntax: (machine-version) ;; ;; Function Description: A string is returned that identifies the version name ;; of the computer hardware on which Common Lisp is running. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "machine-version-test" (stringp (machine-version))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7ff05ef318653decc822b0e695261990249b23bb GIT binary patch literal 813 zcmah{-%ry}82#F^AHcvth!|qm?IJ$#`n!#n_mFlUk#4Wu5yje? z_|(d)#d4`sn5q!R9JBqmr&QL8WlbwgU7nsuc^?3paFHC70C`X#ItueDrw+#z!=%_E zHL6C#D9j2k*mWq2!nq;}{4VZzFT74-XTJ{;K=d)pR$NQxhHXX1(i=Nned>GLP$G14yQF)`u7I6)p%OT z#FI)^_?}fMV>ZLK%j+&zl}XW%Q;D^MN4TTLB7nShEys)k5KkoGrRsttU9nk>@LDoV zcNwGBm8HbeLxC^+^`R4oj@jesCDEO6I1_&Ai=w`9EoG%Bz|=^JD)yGPl0oKjd`mIJ zUivM+7vO$7@bE!n-@}2|4`>wL;o?LqhhzoqHN?x^MeT#}qf4;EyHfNeI+lf~Wt~wX d_IXX4DR#_=>BQ5?H8KCOYjYYe!e?}O`5Pq9@;m?l literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST b/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST new file mode 100644 index 00000000..1289c09e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: short-site-name ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-short-site-name.test ;; ;; ;; Syntax: (short-site-name) ;; ;; Function Description: A string is returned that identifies the physical ;; location of the computer hardware. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "short-site-name-test" (stringp (short-site-name))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a9a7c5085dbaea6b945ae55b9c65a6f48ce42e24 GIT binary patch literal 1546 zcmb_cO>7%g5PrK(9RI||ZqtAq<7_P2!>Vh^u7gq|4x8 z93k!}PM}!T6sx3b?j7zXH|-uck&-4=pfq`f5E>crF6s{X}gRiSPrsX+UjkJvaP<{B(+*3yq{vX=NBQagjx#un%n;i9kk<>1i%gJ zF~SGkPo1Qw=-Raso|&{NYu8k2NXsSI(N;{653nHbhi?*wA}%VjrL0N@wWFQH(pu2Acw7Y03U+lwr9nay8f^J$h!u=xmta&I6>#n4wY)G&C`I{?(OaJ~H+mgQBM zW@#k*mM!4&^+CML>TEST>25-4-sleep.test ;; ;; ;; Syntax: (sleep n) ;; ;; Function Description: (sleep n) causes execution to cease and become dormant for ;; approximately n seconds of real time, whenupon execution is resumed. The argument ;; may be any non-negative non-complex number. ;; ;; Argument(s): none ;; ;; Returns: nil ;; ;; Constraints/Limitations: none (do-test-group ("sleep-test-setup" :before (progn (setq before-internal-time (get-internal-real-time)) (sleep 7) (setq after-internal-time (get-internal-real-time)) ;; For AR #8543 (setq before-internal-time2 (get-internal-real-time)) (sleep 0.10) (setq after-internal-time2 (get-internal-real-time)) ) ) (do-test "sleep-test" (and(eq (sleep 1) nil) (>= (abs(- after-internal-time before-internal-time)) 7000) ) ) (do-test "AR8543-test" (and(eq (sleep 0.10) nil) (>= (abs(- after-internal-time2 before-internal-time2)) 100) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1449780b38c8def64040b25d3aec6a8993e0490 GIT binary patch literal 863 zcmah{T~8B16usNh4+@xq29+4xkZ9t@At@;d;M2HFp|G7Tv$Fvb6VsHfZ7gil50w~+ zG0~?rT8LyPy`e?A0>WSEnCjQr3k^x#^VJ&Xy`WPHU^Qdtc4WtF+Oq)iIcx z!)sXu>!DtdqxS}y3OhHUr7Hz3T2N5u=QNBrfc}ok>jdbRcsfj2+Fc3PK zc#K2hIa3sIt% zk4~wT629&&wYJlLm|<@3&V=ucY&cE#g=*AV4aNWBA4HJ(q%Ihhj9e06CML>TEST>25-5-software-type.test ;; ;; ;; Syntax: (software-type) ;; ;; Function Description: A string is returned that identifies the generic name ;; of any relevant supporting software. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "software-type-test" (or (string-equal (software-type) "Xerox Lisp") (stringp (software-type)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f56800aa897dd446967e93a1dba50c99097e8286 GIT binary patch literal 816 zcmah{Pfyf99R0Or{{RaqM8yz;6A~|tL$aGC0rWDKStxYdbvgw}ylj@PyU9W~-7dx$ ziSgj6Mi(M!HGBuJh>?R|$Zvqt#YBS#PxI^Ryf^Q?nE_;;=qA$ry>7eX1<3D*-F}Fg zet>#@KWKQUDRA^sw;6r4PV~)%2gNbxuRo2ztB2k$;(f2TTYqsM6_*j|2JMa*mX^e4 zab>ZzQZ6ryRfuC=sr{EzUMULB^1|5V>4~KJ0MLMobQuLuL4o)vQZ-H;jw^;qu|=v> ziwAL(7g@0DP!>m1B^3Hy-0=>)P8w&g2NFR1A<9==OXr4d#mCZXsSv-9CJYPLL^QHS zLC*hHN!6t|x>;JpW$f4$zD*d#Ta-D13a2O8r>UQ>t@91(Y#+A1ZOGe`vr|$gKQwv% z3}E_At{}C}zFT7cIoNz>{QwxW-dY>7Gy!nb`f_V~7%kNitOCGAyD>dzscjYHO#Csr zqv^J_YNTHAI5e=xtYenW1fMg_XFH;jD*^14ogjdtU zbeAz|{dFse^ibe8{^Zb!L$B16@maynIh=_+wHYz1*K1Zv0?iD)XyWFwR(g^-m)uqi zaWg%?89uKE9zO7bUfbWtq1Ov(9Npz&Me~Pb9yROY@$RDb{?)rnvBP^({5d|Bg{?WA fQNk&{=FT)YWyExn@pPLo@YuCEO=jQ|y1e`a!M5}S literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST new file mode 100644 index 00000000..9f7df2bd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: software-version ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-software-version.test ;; ;; ;; Syntax: (software-version) ;; ;; Function Description: A string is returned that identifies the version ;; of any relevant supporting software. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "software-version-test" (stringp (software-version))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL b/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9f5bf9052b8c4052b78173f920daa39b49b8417b GIT binary patch literal 2984 zcma)8U2Gd!6}~feoFAu-lelR%n|8ffT2Uw-*b#uL3iC+O8|F&jY z{5xq?%S^s9)n^}CDX&*bjmk>g*{p1=l-_(fKJ|sTy0%`cV=yy=>C|j;diLD8$-V{E z&idAl+;eVrYI-&~Guij}y&WmK$`~uNHi=%wqAbANcUsYe!)-@d(6d}I)ErN^TW+fd zxhMsjTW)J`I^I}aQ|gs(RO*z@)eR;w=H6-bEEEjQ(M`kMmYPz(d%JZ^Hyq2*n@%c8MNe_V(VZfDZ)f->W70ndqcVl_p!zT)-M=QCe3X%w#>NJvQ2iJ} zEKjt1@c%RIr8DKT?WIKd<@VBK`Lpde7^~5?Fk>{PA${s0O!~Tf5JUVO(m3YhFiU%$ z6tsJ9{m`&H?bWJ0+HpcEwTIX}bhG=URK0&G(l#TQ{%0$D+l>5@v90P`W+Wp^P~6%b zTN>{~hAjGNZ~0XFr|c6#_cE4)os4^yMwdomuzG0-pBO$PFn;HjIkbD)j7T&aa?O}I zat4cUni?bQiBC-vfh>+u zk*iVS!Vg;G3C%Q8IuS-mt41ozEoEK@VqCBja!B;bU0~y2LQ@?rtytVCSYVUp(J^Ef zZHMP%85%L4uUeL?Mj@{(m{!hC2uYTn-R+nO5f1cYq1&8ak^XRMng<;Q|h4jswVmqqC6M-0%hYv#s>c^oTPFP$`d3F+k5i(5krwyNg=3oLA zjg)Go_A?oUexL1NNAAGta{!|N3mR&C5S-hJPCeD?{Sn4Qkox-sb?e{YB*?#{W@++A zOhQzB)uHJhC^D^JS!nQs%S1@D*2Y@w;Pf@s=6+>Gn3i|Ij>u`lMDRt$1|PDV;0^5R z?OYgn5hcul(*e7fn>Vvc=lUUh5qNiA)vc^QR(H6iW^EBB zH5Bu;g6VL-NdItK!%z5CHY$zHH7eEL-PYvnJV&Q+|M~R36Hsh^Je@$U+k2r+(ykA8 zSa?pFlYh5Wi{b`#TVwUo)ypd-iu>sBWdNiMf{*v#C$IeH9tV>LVjX?&{mDqm*p-A}&8*bDd4bH8CR)`pN{GKpX; z*iIjjCcbqXPLmiU#n4d$TAFJa#iPoCs%L}a$RHdHkOF}(iRgexhD9h8MwaX_@|cql+v!C6-?lUl|l%mc;8Q*$xX)6_2oviXW;< z$bV^=BvY=7E)I1&fT4Hsn7RQ5dw?ufJQ)-#3p7}v-&fpidPd~DEt29qU}D0u&xE2c zE<)UH^>i+&X47qTd94iUiSuFxi_djvvfs%{-ts()&o^0<%x;Io*P9^L!A(G3fYu4U z0=NGCKu&>PCG?Gb6frcLq6SMcs@K!GcrotXzigY$px4dfiypbfH2V>8^Ty-H{{wfi BkM#fm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.TEST b/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.TEST new file mode 100644 index 00000000..7ce2612d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: identity ;; ;; Source: Guy L Steele's CLTL Chapter 25:Identity Function ;; Section: 25.5 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: Oct 7, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-5-identity.test ;; ;; ;; Syntax: (identity object) ;; ;; Function Description: This function is occasionally useful as an argument to ;; other functions that require functions as arguments. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test-group ("identity-test-setup" :before (progn (setq array-object (make-array 10)) (setq hash-table-object (make-hash-table)) (setq random-state-object *random-state*) (setq read-table-object *readtable*) (setq stream-object *standard-output*) (setq structure-object (defstruct ship x y z)) (setq objects '(19 3/4 #C(1 -1) #\a 'abc "abc" '(a b c) t nil array-object hash-table-object *default-pathname-defaults* random-state-object read-table-object stream-object structure-object)) (defun identityp (pair) (if (equal (car pair) (cdr pair)) t nil)) )) (do-test "identity-test" (and (setq original-returned (pairlis objects (mapcar #'identity objects))) (notany #'null (mapcar #'identityp original-returned))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST b/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST new file mode 100644 index 00000000..f7dff256 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST @@ -0,0 +1 @@ +;; Macro To Be Tested: deftype (and the cml type specifiers) ;; ;; Source: CLtL p. 50 ;; ;; Chapter 4: Type Specifiers Section 7: Defining New Type Specifiers ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 27 August 86 ;; ;; Last Update: 27 August 86 ;; ;; Filed As: {eris}cml>test>4-7-deftype-and-type-specifiers.test ;; ;; Syntax: deftype name lambda-list {declaration|doc-string}* {form}* ;; ;; Function Description: Define a new type specifier. ;; ;; Argument(s): name: the type name ;; lambda-list: arguments to the type specifier ;; {declaration|doc-string}*: just one of these, or neither, may appear ;; {form}*: zero or more or these as the body of the type specifier ;; ;; Returns: name ;; (do-test-group deftype-group :before (progn (test-setq string "deftype defines a new type specifier." pname (make-pathname) rtable *readtable* simvec '#(1 2 3 #\a #\B #\c *package*) vcvec (make-array (random 6) :element-type '(complex integer) :displaced-to (make-array 10 :element-type '(complex integer))) svcvec (make-array (random 6) :element-type '(complex integer)) sname (symbol-name (gentemp)) ) ;; Rem0 has to be global, because anything SATISFIES uses has to be global. (test-defun rem0 (arg) (= 0 (rem arg 2))) ) ; progn ;; (do-test member-true-test ;; The EQUAL checks to see if deftype returns the type name. (and (eq (deftype oddlot () `(member 0 ,pname ,rtable ,*package* ,string)) 'oddlot) (every #'(lambda (arg) (typep arg 'oddlot)) (list 0 *package* pname rtable string ) ) ) ) ; do-test 4-4-member-true-test ;; (do-test 4-4-member-false-test (notany #'(lambda (arg) (typep arg 'oddlot)) (list ;; String= isn't sufficient. "deftype defines a new type specifier." ;; Objects of different type are never eql. 0.0 ) ) ) ; do-test 4-4-member-false-test ;; (do-test 4-4-satisfies-test (and (eq (deftype even () '(and (satisfies integerp) (satisfies rem0))) `even) (typep 100 'even) (not (typep 100.00 'even)) (rem 100.0 2) (eq 'oddorstring (deftype oddorstring () '(or oddlot string))) (typep string 'oddorstring) (typep "deftype defines a new type specifier." 'oddorstring) (not (typep 0.00 'oddorstring)) ) ; and ) ; do-test 4-4-satisfies-test ;; (do-test 4-5-array-test (and ;; v2da is a type containing vectors of any length whose elements are 2-dimensional integer arrays. Width and height of the element integers may be specified. (eq 'v2da (deftype v2da (&optional width height) `(array (array integer ,width ,height) (*)))) (typep (make-array (random 20) :initial-element (make-array '(2 2) :initial-contents (list (list 1 2) (list 3 4)))) 'v2da) (typep (make-array 10 :element-type '(array integer (5 4)) :fill-pointer t) '(v2da (5 4))) ) ; and ) ; do-test 4-5-array-test ;; (do-test 4-5-simple-array-test ;; Must be simple-arrays with only string-chars. This includes all simple strings, but also multi-dimensional arrays. (and (eq 'simple-and-string (deftype simple-and-string () '(and simple-array (array string-char)))) (typep (make-array '(5 4 3 2 1) :initial-element #\newline :element-type 'string-char) 'simple-and-string) ;; Not limited to string-char (not (typep (make-array '(5 4 3 2 1) :initial-element #\newline) 'simple-and-string)) ;; Not simple. (not (typep (make-array '(5) :initial-element #\newline :element-type 'string-char :fill-pointer t) 'simple-and-string)) (not (typep (make-array 20 :element-type 'string-char :displaced-to "This is a string of more than twenty characters.") 'simple-and-string)) (not (typep (make-array '(3 3 3) :element-type 'string-char :adjustable t) 'simple-and-string)) ) ; and ) ; do-test 4-5-simple-array-test ;; ;; NOTE: not working in 30 Dec. sysout; see AR 7184. (do-test 4-5-symbol-names-test (and (typep (symbol-name 'atom) 'string) (typep (symbol-name 'atom) 'array) (typep (symbol-name 'atom) '(array string-char)) (typep (symbol-name 'atom) '(array string-char (*)))) ) ; do-test 4-5-symbol-names-test ;; (do-test 4-5-vectors-and-complex-test (and (eq 'vc (deftype vc () '(vector (complex integer) *))) (eq 'svc (deftype svc () '(simple-vector *))) (typep svcvec 'vc) (typep svcvec 'svc) (notany #'(lambda (arg type) (typep arg type)) '(simvec vc) '(vc svc) ) ; notany ) ; and ) ; do-test 4-5-vectors-and-complex-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL b/internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28ae008bc05407395011db004897d4e31b35147a GIT binary patch literal 4036 zcmb^!TWlOxbsoFx_xc^$#YqRZX_8IG)JYl=C#gLLX6pVmM5u`kdP(S*EgpexnfmI}sK-8Rb@A#1> zP>^DI_T2M++%xCindSV4)VQRMofyyN?7TEKQ5>HrN+V-=sW3K?AF`zppi7@sb%UIY zDr$e*-u6m!4QD8Cr;GNmWKGzG;q+&=N$q+}^QsXIo{DV#b-Z z_te?h(Y~W&#}jRpOII)Rbz>aI4RH$yDmbo=6FKKXsV;00(~^5)aUyF3QJKgCx&=Swv)O-@2;N-yDr za?c7{=bci`PIcmh9clC1cG{^b2*4GIb%dN~S{rt^Q{ue*$7Y0J1dOmQJ1~}gW zaOEE&&V)knALk3>2P$R*dyO{0%*};04{o;M2hcJ$OM6o?+e5b^ma@5-12Ufd!nF8tH5oXt*U<~wqJ@P?8Q z$+C0QKtWy)9=qN#-=qii21xAq@2^wHcT8obGXHbX>+ToynutYdIpP{G6lCI)Q(z-K z8Y?W_wq^GH;PT!=HV-bqYs&#vvBnB;9PG^eBNzZKn!LqVJc#9afCcjHUG`s%4xk{g zLAdIe|IjJ{19|*zw3&s=6n03s;SVA-u-6xY{aDDNR9HBs8K!#-BoWAOYYXyR08UyV3VQN$AHrWoE|SOdHK{s=05OJ z%i_I@{wUD>w45k~+Y&UBM2#tN+F)`L$rVUWD5{~~rON}ktcNxYig9lO-slxZ)3rft z7=tJYp-ZF$KX6y;_>CP*hJ2+fD=^p zJ3+-K0o9*0^j<8g4|{zbYcJW-;aY(Gen`f5!)*Wo@t^MF2;PQkMnJ=c#(oh0=st-_J89;^Gq4V- zpvmm4Y90i}qn>eiaiRY$Q#Q$g6wxpn7#!vrKb_3aF6Lkp1^hcu8XtBCWWfIgYFii6 zV46Z#fE^;#wFvZ`-d@qW;Ai}TDA3)mtJ<9x5r_|OFA#g$w_9a0-kBTcb zUoQ5f>6O0?4P~6tq-onyc0@{#N@GWk*+WHXXv~Ihs$n=BrL;7ZN$1l;MfmE<7AUe` zDrRiS{`5GAf>7QrOyr7t(L%Pkseop(qec6uo!=%Em}N>wJNu>0z>{(5`PxFGIDDDg z(FK>08&PF(esdSQ<;<^-cHQiHJr`VjA(mVEQ*LQ-HuL#hS?sq{nZ>$n9o$=-QYe=` zab!4+o%HUrT!3AmXE~Oy6wo7mFk+ojEja{-g+;nyRGX=|#S7596*v>AGuEp?3XwsJ@E}y9boZs;ssrcF)bnU! z4!#eiLNT8mJt`sog7ak`yfeH4*B$^722{5JkZwAAxJxtTC^<{pnETSX>CO+I_`!5n u7mMk+>8@Dqn<#K*y6YOFojP05^z3Q;U>#*8YV2gN*>`t)a$kLRY3bkM5?4C_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST b/internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST new file mode 100644 index 00000000..1a67285e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: coerce ;; ;; Source: CLtL p. 51 ;; ;; Chapter 4: Strings Section 8: Type Conversion Function ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 6 October 86 ;; ;; Last Update: Feb 3, 87 Jim Blum ;; ;; Filed As: {eris}cml>test>4-8-coerce.test ;; ;; Syntax:coerce object result-type ;; ;; Function Description: Turns object into a like object of type result-type. ;; ;; Argument(s): object - any cml object that may be converted to an object of type result-type ;; result-type - any defined cml type specifier ;; ;; Returns: the converted object ;; (do-test-group coerce-group :before (progn (test-setq bound 0 type-examples (list (1+ most-positive-fixnum) ; bignum; common 0 ; bit; t 27/60 ; rational; ratio 5.00 ; float; double-float; single-float; long-float; short-float 3.1415926535897932384d0 #c( 6/7 3.00) ; complex #\* ; standard-char; character #\backspace ; semi-standard bound ; bound symbol (gentemp) ; unbound symbol '( a b c . d) ; cons; sequence (list) ; list (vector 5 4 3 2 1) ; vector " string " ; string; simple-string; simple-array #*1001 ; bit-vector; simple-bit-vector #'+ ; compiled-function #'(lambda nil nil) ; function (random 1000) ; integer; atom; fixnum (make-hash-table) ; hash-table :key ; keyword (copy-readtable) ; readtable nil ; null (car(list-all-packages)) ; package (pathname nil) ; pathname (make-synonym-stream nil) ; stream *random-state* ; random-state ) ; list ) ; test-setq (test-defun charcoercetest (object expected-result) "See if an object coerced to a character is char= the expected result; if it's an integer, see if it's char= (int-char object)." (let ((result (coerce object 'character))) (and (char= result expected-result) (cond ((integerp object) (char= result (int-char object)) ) ;; Non-integers get this one for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ) ; progn ;; (do-test coerce-converts-sequence-types-test (and ;; A sequence of one type can be converted to a sequence of another type. (listp (coerce '((1 2 3)(4 5 6)) 'list)) (let ((hexarray (make-array 5 :initial-contents '(#\E 8 3 0 #\B) ) ; make-array ) ; hexarray ) ; values (outer let) (let ((hexlist (coerce hexarray 'list))) ;; Corresponding elements must be eql. (and (eql (car hexlist) (aref hexarray 0)) (eql (aref hexarray (1- (length hexlist))) (car (reverse hexlist))) ) ; and ) ; inner let ) ; outer let ) ; and ) ; do-test coerce-converts-sequence-types-test ;; (do-test coerce-to-character-test ;; Digits, one-character strings and one-character symbols are coercible to characters. (every 'charcoercetest (list "a" "*" #\newline (char-int #\A) 1000 '? (make-symbol "?")) (list #\a #\* #\newline #\A (int-char 1000) #\? #\?) ) ) ; do-test coerce-to-character-test ;; (do-test coerce-to-float-test ;; Non-complex numbers are coercible to floating-point. (AND (typep (coerce (random 1000) 'float) 'float) (typep (coerce 100/1000 'long-float) 'long-float) (typep (coerce (* 3/4 50) 'double-float) 'double-float) (typep (coerce (* 35e2) 'single-float) 'single-float) ) ; and ) ; do-test coerce-to-float-test (do-test coerce-to-complex-test ;; Any number is coercible to complex (AND (eql (coerce #c(3 5) (type-of #c(3 5))) #c(3 5)) (typep (coerce 3/4 'complex) 'ratio) (typep (coerce (coerce 3/4 'double-float)'complex) 'complex) (typep (coerce (random 1000) 'complex) 'integer) ) ; AND ) ; do-test coerce-to-complex-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL b/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1ede3032b1b65ac0e0cbc2b7fd9cb51e09001c9 GIT binary patch literal 1353 zcmah}-EZ4e6u*v>CQUzO=GnNi2duS3*dqlj!7-B*Q35hpec;Fx4k^i8alXPqw>rE_Y zqeCP@qI+Sc@9z6{YXeJxMNik5?Jg7 zU%k9?9HR`Jj}r2>5NpX*6G>oxLe-ei z%GBY)bAUOmPyLYVyMmhu>7N$DR^t&l9S_SHV0&D3z^!dkS1`d?8L5)vn|jah8VFW_jXWIHAkDE^FzXrAM6>xD6iCDeTb zy2Nbv}&_koA(X?}@2K6RmRgWm+-FPUtaQ`fg_%g5{;&dd(rnJN=y9KjX{ z6NU~`$qeJ!M7cKr9oOut4}`IzUdIYy%$U>qF6d%N|2Y|@S z-1opvI`aw!IP}+N_J=4uA?ls3a`F~CsjS!Fi?F6NHV2m(v0JCF>=QZ2ktm#M);6xL z)lhx3Ul8lCU%0y%eUywog!UyN_$W8HiH*Xr(ftHuko7EAU$S_S7JR`aFdAdUiU(5z z4BozH!aY?w-F9R1nsOof6bDmc@iZ=l!J@^}AQa>2b9Xau-Br(gu=~!HjjwkX7YTV| zcTqp~`>EZcml>test>4-9-type-of.test ;; ;; Syntax: type-of object ;; ;; Function Description: find a standard type of which object is a member (object's canonical type). ;; ;; Argument(s): object - any commonlisp object ;; ;; Returns: a type name ;; (do-test type-of-test (let ((bound 0)) ;; Steele's requirement is simply that the function return some defined type. (every 'type-of (list (1+ most-positive-fixnum) ; bignum; common 0 ; bit; t 27/60 ; rational; ratio 5.00 ; float; double-float; single-float; long-float; short-float 3.1415926535897932384d0 #c( 6/7 3.00) ; complex #\* ; standard-char; character #\backspace ; semi-standard bound ; bound symbol (gentemp) ; unbound symbol '( a b c . d) ; cons; sequence (list) ; list (vector 5 4 3 2 1) ; vector " string " ; string; simple-string; simple-array #*1001 ; bit-vector; simple-bit-vector #'+ ; compiled-function #'(lambda nil nil) ; function (random 1000) ; integer; atom; fixnum (make-hash-table) ; hash-table :key ; keyword (copy-readtable) ; readtable nil ; null (car(list-all-packages)) ; package (pathname) ; pathname (make-synonym-stream) ; stream *random-state* ; random-state ) ; list ) ; every ) ; let ) ; do-test STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..11384d54cea9e0d6fb6ca1ac5baa7adcbf31bc94 GIT binary patch literal 2983 zcmb_dZ)jUp6u-kdCvrlXOV63NZxv$j=Ga`UD9d`X$k6_jFbzA$Mi(|{{4M-qm9YD|k9 z?tQ$!IoaTuELiE1HKmyIR&gqQ@-d}HvIV+W3JHP1TQ174^CR@tb zawd}r;U9*4dE+=C?Temvnz{Z-9Q2=-4xfwPB4jCZHhxH=0nn~>9_hwde7uCT5OOm+ zxs4ZI%Ru+kGk9!wc2$Pz1jn+CS*ybWv%Q&61DWb0b=daV0o%`A4gPWlKN~~&cAc_! z2D&21@s3oV0Kj%PBD*jIxz@W@?cgzu&<1jop09KBtw~c=;gDu*cVp^mCt%{gf%S&9 zO1fL86PSUsoe??2^{J}Znw3x&P_aE3csE9F7#;bYIvqdu!80S$g;rdoF>t|&p$m_# z;SN=I<0@axhXFo(1w=?=f;h!8(}8G%r7@HpS%f%*ru><7zsm7q|Aww z8I~V{1ubDMeoW)mlIC5Gk~EQsPc#_LQ8D=LHv zp>zb@yHJauwu5z|@Ngmh$hyFiuJYB=6~0WmD8wtmcS?wE5z--iUM}b_d>48TcRv6d z(YvT=sC~;qD9-U^^i>gmk_+-P2gw~_eaC`NvMoa_7-qrUutxsXsq8LU#gYLD!L)T1Q zU3EobQByaxSd#fM3=Zt+RKnDGp>olw^sTR;+3Z4T9*R}^F=vi-qj(Bt&vNOyHc=kifYfTua2`R7Tg?iCn$} zS3hkl>A5MT2QEixbz`W^d6C=De)k#q45aq@0ywV7`+q?cDUwSy8+nnl!YG#~R}wTg Zid^3W>)r`Tq_SKt)0Iicr6Ug>{0UAyO>h7J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST new file mode 100644 index 00000000..4230aceb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST @@ -0,0 +1 @@ +;; ;; ;; 5.2.2. Lambda-expressions ;; ;; test cases copied from page 63 - 65 of CLtL ;; ;; test file created by Karin M. Sye on Nov. 9, 1986 ;; (do-test "test Lambda-expressions - examples of &optional and &rest parameters 0" (and (= ((lambda (a b) (+ a (* b 3))) 4 5) 19) (= ((lambda (a &optional (b 2)) (+ a (* b 3))) 4 5) 19) (= ((lambda (a &optional (b 2)) (+ a (* b 3))) 4) 10) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x))) '(2 nil 3 nil nil)) ) ) (do-test "test Lambda-expressions - examples of &optional and &rest parameters 1" (and (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6) '(6 t 3 nil nil)) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3) '(6 t 3 t nil)) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8) '(6 t 3 t (8))) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8 9 10 11) '(6 t 3 t (8 9 10 11))) ) ) (do-test "test Lambda-expressions - examples of &key parameters 0" (and (equal ((lambda (a b &key c d) (list a b c d)) 1 2) '(1 2 nil nil)) (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6) '(1 2 6 nil)) (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8) '(1 2 nil 8)) (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6 :d 8) '(1 2 6 8)) ) ) (do-test "test Lambda-expressions - examples of &key parameters 1" (and (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8 :c 6) '(1 2 6 8)) (equal ((lambda (a b &key c d) (list a b c d)) :a 1 :d 8 :c 6) '(:a 1 6 8)) (equal ((lambda (a b &key c d) (list a b c d)) :a :b :c :d) '(:a :b :d nil)) ) ) (do-test "test Lambda-expressions - examples of mixtures 0" (and (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1) '(1 3 nil 1 nil)) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 2) '(1 2 nil 1 nil)) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) :c 7) '(:c 7 nil :c nil)) ) ) (do-test "test Lambda-expressions - examples of mixtures 1" (and (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :c 7) '(1 6 7 1 (:c 7))) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8) '(1 6 nil 8 (:d 8))) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8 :c 9 :d 10) '(1 6 9 8 (:d 8 :c 9 :d 10))) ) ) (do-test "test Lambda-expressions - examples of &aux " (and (equal ((lambda (x y &aux (a (car x)) (b 2) c) (list x y a b c)) '(6 8 10) '(3 4 5)) '( (6 8 10) (3 4 5) 6 2 nil)) (equal ((lambda (&optional (a 2) (b 4) &rest x &aux (c (+ a b)) d (e b)) (list a b c d e x)) 22) '(22 4 26 nil 4 nil)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..807f1de52b79466d2f852bc7a246fcd3b7a27d78 GIT binary patch literal 1009 zcmah{-%ry}6u#|#u#G`BLLj1%2IC$Y@62#SoG)IwJ2vQAylokaFV3yF#le>S&=4ar zKKN9lgGgEp|AViHkq7@F{{uXCGm)T)X_}sX_uTKC?>lFJ0$YkIDXpD$qiJ`fR=?No z_oVGsN9wlvovJNu11`N(bVgt0iL#!&pNbe4PO2Td(z9!l*|)p3%HAz0bx$JgPNNCI z@-qCUGE0k@bUGQy5knoZ{r65flS*gOcao9w<0B!~LI_pS8UKV4iXk6z51g26Qp3c# zf=aPQid1$7t`h<+*fJ<{o%o{EYqfFHer`9poSiNb5OO~_p`4{DWBM^ z1r2Y2G_p#O82Zh^*#*~`Tf&R*sHC`(C0H#$$#q&T=`3rY z#M0zkTnKQKzY_?ZK1FEi%~({ZpM2LK{yA8Gr~N=^P=Bkfi2`IC)W6J>h9dcu5JFLe z&KlLJK|R)pAu-^7bgs#Yu4N0nYn&%qR;3KD6adjy4O#Sq9dTJ9rjo~unic~&%FvIX zQ8r9k6otPtOkMWIePdqO7Xk|=Wy+Y&ux^lU1QmOAQ5C(?D zZ^O`n8mCroc(Vb`b*}X6Zcl1fcAnHKxY_9T@H2bwMXOWmuDQ;<$qyIy$%3?9f!(c1 zjos1OacuwQRrio94kz>t?k7=sp#+0*L*P%qbm1FM5LMMnSU2-vHDJc@kXT#8>=ixB zvx13IURNnZ(FD~t3ryFFAbR!)g&#Z~PCtfVg+`6?HZB_o^A?5%f`_gnYzYBgCI^!h vM2M#Uxpqi!Kf8w_xOrV+l$aD>GF2^@lo8eN#(5g3duZt<^=8ngt)(Z$oOSJ`;k!=YHf1(&`%UN7Be}RHD4brFgKiJC-Is1VvD4{;01$l&GgaGAnPwW%vG7*NM<2sU%|P4S z8r~ovX8y7y>_QYiSV7Bt>A1dL!90rcQjAaw=~`W5aC(y7O>}*4oo@+Gk&&%cLTAB;w0&+ zN$Z%^l47b&DKV}MCKeuZ{LVigDz?ZKJJ*4DdTLZ^k= lambda-parameters-limit 50)) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL b/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..af2275b20de1ebebc303e0714695742074b8dfee GIT binary patch literal 8023 zcmb^$3vg7`_5FAA!-NEgX-uC40>r#v5Kyp;dD*;>4V&Gty8+^lJ~l7xl9%0(Y!FJ- zfYmyl{ndd|K3!fsNB z*d~*gbI-Zwf6l${zMBz7+~M)bo0>3lL+z{rkLRw>sYF|HmrrhN{iR0DSowGtF=a~ zlpA7EIzw8}N|mgUlZk%CH1-)LhSN95unc28nR2&u`aNN9z;BJR!)&2-G*#sFD;*G; zx>;j5cSZ|pXRTDhI^`CnL21@Nig_+wa+qOUr_qy%==nBwJkE??XydlmRg|#eZic~$ zB8HjF8k&MB0?90$8Y{m#woCy+F^i^#qr=hjz`pRXtCEe5U-ZNH%E*?-{ckeNNc0hZ z8^?n5$eAVE>rpvAZiXoY8?ngEBqbR~Si^C|m1P}xQRLECt0{p&I^JkXCJ$OER*RVF zE^zR2iko?6ky(&0Wyt8~y!p!A?fB}>^0n9G9H&lxhdBx;OqvqJN*(=DhT@*4^f)}o z=$`g<%;#_t1y|{70PiKdGbWY*KK<*ccS4@Gu=y2E*m++m0@} zrqPyOQz8_{yRkJH%GGpKITU0>6J}Aq(*Re4nU`+kPdlL$fgLB5tRa#zWCWLvn~R+| z=c(a^2OSp*q8DdaHgPf1Us7)o^KkFjJ$}cBu@3ZVXZd7wX9YZ!@Kj9(%Ab5FP;q93 zKTyto7x4-!P#LJIf$2vBRndx_mB1V*=RoYtd&C4PfrWEv-daTXn-f%VR!CVxh+`yr z1pYda%u6}N9gf+OTwC$t-%QPm1*ycburSL43^N#HF?-j{op73XtbTg5lyW%h<3uh> zyM2BfKjk=HnsF5uZLWV5yE0aNEsl9=eb*Mpr?Om&nH86DFXLzy(HUma7zK`KMFmnX z9S2R&QzOyg*nD~UuH)sRTrV>imb@2j_x;;>`OGTgwM%#`dS>x|dpC|mi(|zMx5)Zh zstSx7x0ViJbnorHWt)s!C)Y$1UkbV zo#9%(90Uq$RezU4=%HF0P8|yyW}RLZ^9*APcxEy13~~ZgNiBh3yBbFH88qwZ3d`loOeX7Fq5Ke4{gqDP~ zurfM++zUL@pB+fJi|BVX z+RG5zM6oplNPoAN0#W*ih)Tbu;4&^pXmQeL(i`@2WT8owPQhG}vA*DissXB?}J3~uK=Cb{LMH%4P!ABR)b{bMW~?^3I}07 z!pY}hvM?j4gu6O$i{eL#MSdHx$oq*YzKMeCiBtRn!os~nShydPIc}1I7eFVArnzt6 z$b+M2?K%WUDA;c+i1kq5p}O2u7ekb=f2H7;M1XytaI%+CUlWM3@8C$q(VKMYB4wPg zS0nK>C7z+vpjJ%Zf~ph(2h@kwkwCE)jYL5`A*NzT1%3-zq11WREXN*3qby`g|BA zmp-5_m3wr!lIWIWaeAA8v3rUMKk!A$5a4rTjhpbFKrB_k#+5bWCI11i5 z7eOu)B4?!vmo3YjW8f8HrAi%C^KbJ81Ag449LJ8Le*awb&xmLr=@5G(6vw`u6kghG zrM{3;__*F@$gx4Fd2(nV4r>icj0=h`4p^9o(9XcCH7sw0*8CacERJt_@h2og@i{9c>hdl*g0v^B6c0Y(@PTZ4G8>6yBX^}42|s#1ljAJ3 zKQ)SrT<5$T1! zJPt`4iX_q1#UyFMuhWbOcL|>BCoNCd%9|Eo)R{Fi=D;!dIn;gA-Otn(lW#on|~n@5e8g9NrU5MvZFz9PHgy{OjVL@k9D} zW*nV3q)*U2T?NqSZG*3Q7{prhU3176&v1vQ;3u;Q!u2~3rz~(4K1xEko!10m7l&PC zi`KP05Nw8x z>+BXcyc-v&!Oi4z*ZB?>H^A$nc&3hv)wupQ-kuRki?3E?<$0SEdHF(&6rNu(UurQ3o)ld(3qf720_>1kw5%NlkA;&U0jl;?` z(_nP(xpKCwS3lSL{+=r@o18w5^_lpp$(=KW@#sXWx7GV@)Y}G|F8*Az=Vp{agt+r+ z0v&iAp!#4JCI<~0tTQRVc4QipFG(}kHL8s)^a!LJ69#7K4nQuob(Gb&>H?T%BDf+X`t^PMMw6Dl4_}Q?ptF z`vx4s2jC2lGzLg=D@bzL53NzbUTxRgb(jc#L0LFW~)i+n2(@;q(l56h}xZ3gconj&!Q|55cn6K64~DTL=G-Ox=8+-LO2()WD*8$}qW))AT=K zlVoW&44<(b;Qvd(} literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST b/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST new file mode 100644 index 00000000..83a158d8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defun ;; ;; Source: CLtL p. 67 ;; Chapter 5: Program Structure Section 3.1: Defining Named Functions ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 9, 86 ;; ;; Last Update: Feb 3, 1987 Jim Blum - changed DOCUMENTATION defun ;; and fixed (declare (type (array * (10))) ) ;; in &allow-other-keys test ;; ;; Filed As: {eris}cml>test> 5-3-1-defun.test ;; ;; ;; Syntax: defun NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}* ;; ;; Function Description: The defun special form is the usual means of defining named functions. For detailed description, please ;; read page 66-67 of CLtL ;; ;; Argument(s): NAME - a symbol which is the global name for the defined function ;; LAMBDA-LIST - (see page 60-61 of CLtL) ;; DECLARATION - a declaration form ;; DOC-STRING - a string ;; FORM - a lisp form ;; ;; Returns: NAME ;; (do-test "test defun - examples of &optional and &rest parameters 0" (progn (defun foo (a b) (+ a (* b 3))) (defun foo2 (a &optional (b 2)) (+ a (* b 3))) (and (= (foo 4 5) 19) (= (foo2 4 5) 19) (= (foo2 4) 10) ) ) ) (do-test "test defun - examples of &optional and &rest parameters 1" (progn (defun foo (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) (and (equal (foo ) '(2 nil 3 nil nil)) (equal (foo 6) '(6 t 3 nil nil)) (equal (foo 6 3) '(6 t 3 t nil)) (equal (foo 6 3 8) '(6 t 3 t (8))) (equal (foo 6 3 8 9 10 11) '(6 t 3 t (8 9 10 11))) ) ) ) (do-test "test defun - examples of &key parameters" (progn (defun foo (a b &key c d) (list a b c d)) (and (equal (foo 1 2) '(1 2 nil nil)) (equal (foo 1 2 :c 6) '(1 2 6 nil)) (equal (foo 1 2 :d 8) '(1 2 nil 8)) (equal (foo 1 2 :c 6 :d 8) '(1 2 6 8)) (equal (foo 1 2 :d 8 :c 6) '(1 2 6 8)) (equal (foo :a 1 :d 8 :c 6) '(:a 1 6 8)) (equal (foo :a :b :c :d) '(:a :b :d nil)) ) ) ) (do-test "test defun - examples of mixtures" (progn (defun foo (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) (and (equal (foo 1) '(1 3 nil 1 nil)) (equal (foo 1 2) '(1 2 nil 1 nil)) (equal (foo :c 7) '(:c 7 nil :c nil)) (equal (foo 1 6 :c 7) '(1 6 7 1 (:c 7))) (equal (foo 1 6 :d 8) '(1 6 nil 8 (:d 8))) (equal (foo 1 6 :d 8 :c 9 :d 10) '(1 6 9 8 (:d 8 :c 9 :d 10))) ) ) ) (do-test "test defun - examples of &aux" (progn (defun foo (x y &aux (a (car x)) (b 2) c) (list x y a b c)) (defun foo2 (&optional (a 2) (b 4) &rest x &aux (c (+ a b)) d (e b)) (list a b c d e x)) (and (equal (foo '(6 8 10) '(3 4 5)) '( (6 8 10) (3 4 5) 6 2 nil)) (equal (foo2 22) '(22 4 26 nil 4 nil)) ) ) ) (do-test "test defun - with &allow-other-keys" (let (aray1) (declare (type (array * (10))) ) (defun foo (str dims &rest keyword-pairs &key (start 0) end &allow-other-keys) (apply #'make-array dims :initial-element (subseq str start end) :allow-other-keys t keyword-pairs)) (and (setq aray1 (foo "string" 5 :element-type 'string :start 1 :end 5)) (equal (array-dimensions aray1) '(5)) (equal (mapcar #'(lambda (x) (aref aray1 x)) '(0 1 2 3 4)) (make-list 5 :initial-element "trin")) ) ) ) (do-test "test defun - the forms constitute the body are executed as an implicit progn" (progn (defun foo ()) (defun foo2 () (values 1 2 3 4 5 6)) (and (not (foo)) (equal (multiple-value-list (foo2)) '(1 2 3 4 5 6)) ) ) ) (do-test "test defun - the body is implicitly enclosed in a block construct" (progn (defun foo () 1 3 5 (return-from foo 4321) 7 8 9) (= (foo) 4321) ) ) (do-test "test defun - with doc-string" (progn (defun foo () "a b c") (setf (documentation 'foo 'function) "foo") (defun foo2 () "a b c" "a b c") (and (equal (foo) "a b c") (equal (foo2) "a b c") (equal (documentation 'foo 'function) "foo") (equal (documentation 'foo2 'function) "a b c") ) ) ) (do-test "test defun - name is returned as the value of the defun form" (and (eq (defun foo () "foo fun" (+ 2 3)) 'foo) (eq (defun foo2 (x y) (declare (number x y)) "foo fun again" (list x y)) 'foo2) ) ) (do-test "test defun - use defun to redefine a function/macro as a function" (progn (defun foo () 78) (defmacro mac () 90) (defun foo () (+ 78 78)) (defun mac () (- 90 78)) (and (equal (list (foo) (mac)) '(156 12)) (eq (macro-function 'mac) nil) ) ) ) (do-test "test defun - test case copied from page 67 of CLtL" (progn (defun foo (a b c) (declare (number a b c)) "Compute the foo for a quadratic equation.Given a, b, and c, the value ...." (- (* b b) (* 4 a c))) (and (equal (foo 1 2/3 -2) 76/9) (equal (documentation 'foo 'function) "Compute the foo for a quadratic equation.Given a, b, and c, the value ....") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..39ad15ba0cdf8cc4e2877ce2301662757842a43e GIT binary patch literal 3601 zcmbssU1%KV@!Q>#bdpZ;>CdtyS>DK!8!ui(k`-663(o4aC!Kw_r|j!wBQl~N+5k`p%CapA6)vm*mUEzi!2X4S6bt?MVn@fSp8wd@q(V`>V}(`P0p&zyRGv?Z<> zNv7?|WG2T(TQ=Wb=b|M-NRHe?&`d~_2*iKA7L`oZFy(k6smhv?QYC-QuZ1BNIb*20 zU+b6Z6I70j%*23|O7BdrR&A-jvG-XcVpLVtc$`0zY;*Cp@&`aGW<=c;mD>%pEUzm^xsB&^*U}VcY*IGB<1S*!1vArm4KE3XaXc(2$)nBixZ+3;AUa*gcPznqX zKf%j;&X%>qkBj8+zLDJd)^1~;)s3}5ux_KYx#n!A>9NZ9PZPM9j`pFmUAwICsk)Wc zD<5gg8<%oJ+d*ZAw9PlNL(7}nX1`o@_|NOMBIrTx__ihRZ7YL#KNtqN%pPCf*hUI{ zeSIi)|LLo_D{f)2?n}#Z?%78idGNtVkfq2gjJ_$ICrqhp3xOV6m8p63Y zj1%f4gw%+6QcOfofP#)#M%Pts*W9EWo*ja-?wyLn6hmb((+C{%e}{^77^*4Hq+^*B z$SYVlJoz)&2+!;3SW-!(knnpth~Pcihu~e>kKi>rfFKXdEqhdC=}|mP(IW`XG5Lc` zzKh8VfjswVaK`-t)P&RpB?o>qvd z8)Ayf#>LchIw{xR1(YCxC9)9+l1~Cb@*6tvZQ56*{Wcx=8a*o0BS-1r31Ao6!J~%Y zjv&?uuS}zcc}EZV|4^(3|4-VB-~j_)VBQuKJ)ywmK>A-9{bPC%vHJ{sj~+wp6{g{3 z1}r*)#7ndXfyuC!7#3$(EWo&b2jbj60y*vr27ZRVLd9mWe%vj_@*Q^OGBCo3M;O+@ zK!`pA0_0zi+ScG&!h3iMZz@uM8Ay=#16J}=2G)U9fQF=<-=N0~Iy_5qD za*TFkXu^nJJLB0EPt4m(xsqG)EY}ld(JR>ERjXLF#j@>H%PuS!P9>na)`|_xxuR9J z^Qhq&zjo9_4MR7SA#urqbp@DRwrL>kMv$(*`L$5RD^Gw3|0n-8559%#PdbgT5gQ=RCOh3&QU6V0E<72PB2-$uDK2(`_ zLcX&s?BF_0zIyH^At*f~)EXQ>`$12LKXt-}-!E8i>_0V$j zLHWvdrCRhvt5R_;V^zJbkS5CXzD?d0fr{=hnEfXxdvj_hdM`Ff0Q zv=Uk;&A3YmJsVG>g5&4~R09!{|FWWd1;78YC&A>8`z3e`ng0+Jg}k}WA9?XEY#E{5 zTZX>80Sg+W5S9acq`Mw|#^ZWAh0iqhY+HTw;G5{z`f`?+E9{$Jo+DiF7{Yr9y+2|q zv%+D}(38-hb2TL?n{zrm-SCcNRA}Ra@E$aMGqsRR7-obHa#8v$7iQru1hLH^Vy?96zztt2msZ48>#{ALp2EJ4CB5VdmCnK7)3%$P^>{_JJh5n7 tpkdW2V?PzIi&veB1Dzq3+@Mn`@XwR&p7>JI{Vc3*?%{~Yn}yBI{{f1K7-s+g literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST b/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST new file mode 100644 index 00000000..0273d57e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defconstant ;; ;; Source: CLtL p. 68 ;; Chapter 5: program structure Section 3.2: Declaring global variables and named constants ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 8, 86 ;; ;; Last Update: Nov. 8, 86 ;; ;; Filed As: {eris}cml>test>5-3-2-defconstant.test ;; ;; ;; Syntax: defconstant NAME INITIAL-VALUE [DOCUMENTATION] ;; ;; Function Description: defconstant is like defparameter but does assert that the value of the variable name is fixed ;; and does license the compiler to build assumptions about the value into ptograms being compiled. ;; ;; Argument(s): name - a variable ;; initial-value - a lisp form ;; documentation - a string ;; ;; Returns: NAME ;; (do-test "test defconstant - test case copied from page 68 of CLtL" (prog2 (defconstant *visible-windows-defc1* 0 "Number of windows at least partially visible on the screen") (and (zerop *visible-windows-defc1*) (equal (documentation '*visible-windows-defc1* 'variable) "Number of windows at least partially visible on the screen") ) ) ) (do-test "test defconstant 0" (= (catch 'cat (defconstant *defcons2* (gcd 10 12)) (let () (throw 'cat (1+ *defcons2*)))) 3) ) (do-test-group ( "test defconstant 1" :before (progn (defconstant *defcons30* 789) (defun foo2 () (let () (defun fun () (let ((a *defcons30* )) (+ (fun1) a) )) (defun fun1 () *defcons30* ) (fun) )) )) (do-test "test defconstant 1" (and (= (foo2) (* 2 789)) (= *defcons30* 789) ) ) ) (do-test "test defconstant - The initial-value form is evaluated and the result assigned to the variable" (let ((j 0) (k 0)) (and (progn (defconstant *reshaped-window-defc4* (incf j)) (= *reshaped-window-defc4* j 1)) ;;(progn (proclaim '(special *reshaped-window-defc5*)) ;; (setq *reshaped-window-defc5* 7) ;; (defconstant *reshaped-window-defc5* (incf k)) ;; (equal (list *reshaped-window-defc5* k) '(1 1)) ) ) ) ) (do-test "test defconstant - with documentation" (progn (defconstant *shrinked-window-defc10* (cos 0) "number of shrinked window-defc10") (equal (list (documentation '*shrinked-window-defc10* 'variable) (1+ *shrinked-window-defc10*) (documentation '*shrinked-window-defc10* 'variable) ) '("number of shrinked window-defc10" 2.0 "number of shrinked window-defc10") ) ) ) (do-test "test defconstant - the value returned is the name declared" (and (equal (defconstant *defc12* 1) '*defc12*) (equal (defconstant *defc14* 2 "str2") '*defc14*) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c4ed27456230923571ea515c4a33d9f09e193d6b GIT binary patch literal 3811 zcmb^!TTC3+_09~B1%ti3%my%?IDqX<2C>8-Oq@F7Wq`Gp88SQTt=lNpungXTWtZ;5 zZdwIdk(E@{R0(!V=caX4DN=s&5jP)=oJ3i*l`6GLK3dWK_OBo5NBvV(?GHWYUY3WU z5o#*!=-hkmd7pF7J-bF~zaEXt(fsm?n{^6uzFb-`H-d`7jc|u5u zbwqhq8CE8=$ywC|HI`kR}l2rcbeWY^fKztLp1P#1ax7%|5^Rzsqh322e;<{P(Kj8xRXgsN|%M^cnOI z5nyD+-BNbq%N%*)Kt~?T?bh{0RaZ0k3TigjQ)duthw4i;92_dJ(+GB<-EF&6iK|sr zM;1R_ydJ7nSVdpjcsczHfXxqB;E~Y?Ep1#6rTZ$WJ|ndG!&KiAShQ^urVj)dA)diE zjSx%W8%F5RIh2l7t!b3&}s*mGiG^(EX}GN2>-c zr3bgHdGtYl6`2*&LkHUU=+NQ0n|W~jpwd{&1l=GJkNQ9IdcsjdpNQebRi;&aBCeUr zr5IrJsYF<8qz&Q`_?qEsfG+?YqMdh$Xk1hEQ~p0sBxmF>S{5D|_WehVcCOf7N>qk2|-;MMiKR+S#LcXrQByH_&5HbhHNBW1+>rtfOYRKT-oIBVa@UsO$KJVLYyk2@j1EeXw1CX8ru2KZG> zGoI9dj=-#GMB{2~1`y)ksf^%r+JoTt^aO&BXfJ~A199WyBE(nelXzI9ClS2N`7dz( z^PK-I;}^bQXTqO3_ytI-(XOg-U=!Y9^uo^>z3>*Nx52BLNy8YXtw^JCny+!1K~B>Q zuC;?}lS<;+%q1hPR9_$9Apc^T$OdC1e_)K{SG4!rw5Lo@IJEZyeNv$(yQzEz$ff7O zqFPp1xH|`LS)GpIM+>EXI)I>;K7pW{1FX@&Rn?5CP*I3)WO(u4Gz2^GpB%hTF`weQ zOoI4h4&I=r5qXCmNAMlKyTx}|zH|Amm$P?pzB&ek_s~{I+!Ur!c%6|5tNg6MK_5r< z@LiAti9Q7k7-y$=|rr0+df za*8E+-dR|&3-+>8f~iK4OBqMLX=lrhTyRR|LJlStx5%(LpaJT1)-E{nDB?xmJ87Ya zQ>*GJdBKMH2Z(cgbV1xIEB`j%t0|TW!^lGXdm=bopP1F6F*VME{5L>Sg@^c0{!ftP zuGbqiHPzCT$1X!W27`qfPtYbVsrJRBVQDr&!LG zWV={&Z(veO`K?qJTzf9-pcN4o5#g`gm^MHOf8^^o;PVZu*+Pdmu4JvFsb$V1Jz z%SEUwt_+pWIkGJmSDZ8$FGoefj&Oa%Ba<4Cq^38PdH^4y)Zm*?hftmb{)9hkPdJ9`@>XjHVdjrIj- zpV-7YT~d$GR)NOFW9x!6i*q>b@V)*WnLDff(qZ`KZwKnBStqqyCLNM}+c-g>GbjT5 zCI8@Q?7;P3_QjWc{(nm25X%1@OCx!ET{`u`!(F3KT_t;=MGzs@mzOqRP=vt4#DZ77 zo;}vX@R+heqHXV}F=-kzI7&z~<$GOeyOhoxm=;MO0t+0xyU=m^Epcml>test>5-3-2-defparameter.test ;; ;; ;; Syntax: defparameter NAME INITIAL-VALUE [DOCUMENTATION] ;; ;; Function Description: defparameter is similar to defvar, but defparameter requires an initial-value form, always evaluates ;; the form, and assigns the result to the variable. defparameter is intended to declare a variable ;; that is normally constant but can be changed. defparameter therefore does not indicate that the ;; quantity never changes; in particular, it does not license the compiler to build assumptions about ;; the value into programs being compiled. ;; ;; ;; Argument(s): name - a variable ;; initial-value - a lisp form ;; documentation - a string ;; ;; Returns: NAME ;; (do-test "test defparameter - test case copied from page 68 of CLtL" (prog2 (defparameter *visible-window-defp1* 0 "Number of window-defp1 at least partially visible on the screen") (and (zerop *visible-window-defp1*) (equal (documentation '*visible-window-defp1* 'variable) "Number of window-defp1 at least partially visible on the screen") ) ) ) (do-test "test defparameter - defparameter proclaims variable to be a special 0" (= (catch 'cat (defparameter *defp2* (gcd 10 12)) (let ( (*defp2* (lcm 10 12)) ) (throw 'cat (locally (declare (special *defp2*)) (1+ *defp2*))) )) 61)) (do-test-group ( "test defparameter 1" :before (progn (defparameter *defp88* 789) (defun foo2 () (let () (defun fun () (let () (fun1) )) (defun fun1 () (locally (declare (special *defp88*)) *defp88*) ) (fun) )) )) (do-test "test defparameter - defparameter proclaims variable to be a special 1" (and (= (foo2) 789) (= *defp88* 789) ) ) ) (do-test "test defparameter - The initial-value form is evaluated and the result assigned to the variable" (let ((i 0) (j 0) (k 0)) (and (progn (defparameter *reshaped-window-defp4* (incf i)) (= i 1) ) (progn (defparameter *reshaped-window-defp5* (incf j)) (= *reshaped-window-defp5* j 1) ) ;;(progn (proclaim '(special *reshaped-window-defp6*)) ;; (setq *reshaped-window-defp6* 7) ;; (defparameter *reshaped-window-defp6* (incf k)) ;; (equal (list *reshaped-window-defp6* k) '(1 1)) ) ) ) ) (do-test "test defparameter - with documentation" (progn (defparameter *shrinked-window-defp10* (cos 0) "number of shrinked window-defp10") (equal (list (documentation '*shrinked-window-defp10* 'variable) (1+ *shrinked-window-defp10*) (documentation '*shrinked-window-defp10* 'variable) ) '("number of shrinked window-defp10" 2.0 "number of shrinked window-defp10") ) ) ) (do-test "test defparameter - the value returned is the name declared" (and (equal (defparameter *defp15* 1) '*defp15*) (equal (defparameter *defp18* 2 "str2") '*defp18*) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0384a4b475868c8a1562a00b003ca0bd3755d74d GIT binary patch literal 4347 zcmb_gU2Ggz6~1@I|5>}XcO9qBk0)+y;-%way9tSD)r{9;d*k)YGCONG5Q^5bej z?l%4tm~?O9w~PKbYZL9_j0 zeHTsKxo5!pqm`-Gjb9P6lDJ}=lqevs-0Yk^fKd1}5aNMDla9hotJqD)s&>}{#3F8N zNxiuC(XrcF8xW)l|LZDzBT6A}RhPb&mOGq2T{~zIkdSTt{96C zUjgy#AtTY%g*zX7^r){hKsKrdc&f*PrC{dOE66*CG0>H;V-*Sx5-@vs@!^LInDqa& z>919rnl{;VY0>dlOn7u#-L!Z)B|FbSz!o#ze#~d03;g3!Y|p8sTYxhT{_rClJy#BN|r6O=~*hXH=?( z^;&ppU{9MrpxJ>*)za;#1x+QuyHZ``RK(V&CAxKoZTgur36guB5m~77S_B8mo17h!z+hJp;-_j$KT38=j zzw?-%waZ>uuJ>bK8%EX#>>ht)(h3?=8+Q*5;d%$G*FXy#g!kQ*_hHr!efH?)KHCB% z$7-;GypgT998!Fwze=jC6^^NXr~X$_khfv1M3n=@X)bywsQmfY*>QAv= zB*(cibckC)n*>ZVhan$u7;=jX$y-ABUABLob$^~IA$ITucA%ei_b{aktZ$yyrlJOq z@DL!&*FjdxixRol;99LSFvaMh{8e@s$*XJ+lA<6BpwR#Y6x5(@QGQ0qKO;zpb)qmR z$cvmvAFz*sQ2IN^ll~&e?^r(y-($OxyeqhO1b0_(KNH*!1(_EpuLyNZkWVrnsM9s{ z11e<#%ZUDg@1(!wTj)E2WQ8yxxYL4|>={%TV~3C&WgS4sBfgWo&$p023i2CFC3FRz zO7e!-QW9&+>~My89p(+P{&D6#!up4pw~u){nHL?Ge^f5LRB-bJCGO6jjpY!t`9wdX)JX40LfNnHIAc z$}V8F$V=r?O}>yD#&@fHU4qcmN5Xm_sD(t1j)0IoCoC5Gkwb3OTGL=jx3&~hY6&b@JRDm3&GX=#(5uclj>6DuniGvg;V{G(#gDutBIWuQEgOL-`!%9(|XGUqBW zC7*R2uvr-deEK(jIQ`aE=qpbOeX(2`7#Y>!V$j8S&c8XhwY*HL^?4yusaT8#wN}aA z$_TS*a)kM=71F;q6H{G&618-^{Xs(70H9fmKxF|~qELD+aYY+I92 zV+wC1Iv{=u*of(#t@T>>1oetz43+p#fxNdW`%m22GOkKa-Tl-HZB&9>oLqbe6A&Z; z@{S!+Oj$TZ@d?noaYh`s%xRnfW#*JiT~4gvB(^PHnG(ta1EGaR-D_(THGP2I5j3FF z8d^xTCoLESVakZ=&~~4J2-TmSo(Tmbb_?sSXNt6+eS8;ls4ODoU|o?rTS7(P)*0T| zH8|(Q@~+}!vPo#X^SR8Dl8v2lm7~Y7BL_kSy!pwSO#Q4t_nL5b86URn^_^OY6_k`4 tgZn5O%VB>^omb8#^GWP{nKZw`^6(b|H+}5MAr4fmp&Q*K-#)jt_HS^K<$nMG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST new file mode 100644 index 00000000..ba7716d6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defvar ;; ;; Source: CLtL p. 68 ;; Chapter 5: program structure Section 3.2: Declaring global variables and named constants ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 7, 86 ;; ;; Last Update: Nov. 7, 86 ;; ;; Filed As: {eris}cml>test>5-3-2-defvar.test ;; ;; ;; Syntax: defvar NAME [INITIAL-VALUE [DOCUMENTATION]] ;; ;; Function Description: defvar is the recommended way to declare the use of a special variable in a program ;; (defvar variable) proclaims variable to be special, and my perform other system-dependent ;; bookkeeping actions. If a second "argument" is supplied, (defvar variable initial-value) ;; then variable is initialized to the result of evaluating the form initial-value unless it ;; already has a value. The initial-value form is not evaluated unless it is used. defvar also ;; provides a good place to put a comment describing the meaning of the variable. The value ;; returned is the name declared. ;; ;; ;; Argument(s): name - a variable ;; initial-value - a lisp form ;; documentation - a string ;; ;; Returns: NAME ;; (do-test "test defvar - test case copied from page 68 of CLtL" (makunbound '*visible-window-defv1*) (defvar *visible-window-defv1* 0 "Number of window-defv1 at least partially visible on the screen") (and (zerop *visible-window-defv1*) (equal (documentation '*visible-window-defv1* 'variable) "Number of window-defv1 at least partially visible on the screen") (setq *visible-window-defv1* 1) (defvar *visible-window-defv1* 0) (= *visible-window-defv1* 1) ; initial value should not take effect since var is already defined ) ) (do-test "test defvar - defvar proclaims variable to be a special 0" (= (catch 'cat (defvar *defv2* (gcd 10 12)) (let ( (*defv2* (lcm 10 12)) ) (throw 'cat (locally (declare (special *defv2*)) (1+ *defv2*))) )) 61)) (do-test-group ( "test defvar - defvar proclaims variable to be a special 1" :before (progn (defvar *defv3* 789) (defun foo () (let ( (y 100)) (defun fun () (let ((y 20)) (fun1) )) (defun fun1 () y) (fun) )) (defun foo2 () (let () (defun fun () (let ((*defv3* 20)) (fun1) )) (defun fun1 () (locally (declare (special *defv3*)) *defv3*) ) (fun) )) )) (do-test "test defvar - defvar proclaims variable to be a special 1" (and (= (foo) 100) (= (foo2) 20) (= *defv3* 789) ) ) ) (do-test "test defvar - The initial-value form is not evaluated unless the variable is used." (let ((k 0)) (progn (proclaim '(special *reshaped-window-defv8*)) (setq *reshaped-window-defv8* 7) (defvar *reshaped-window-defv8* (incf k)) (equal (list *reshaped-window-defv8* k) '(7 0)) ) ) ) (do-test "test defvar - with documentation" (progn (defvar *shrinked-window-defv12* (cos 0) "number of shrinked window-defv12") (equal (list (documentation '*shrinked-window-defv12* 'variable) (1+ *shrinked-window-defv12*) (documentation '*shrinked-window-defv12* 'variable) ) '("number of shrinked window-defv12" 2.0 "number of shrinked window-defv12") ) ) ) (do-test "test defvar - the value returned by defvar is the name declared" (and (eq (defvar var1 1) 'var1) (eq (defvar var3 3 "str3") 'var3) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL b/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b451ee233ee0c6e137ed234ff3267e4be7456124 GIT binary patch literal 767 zcma))O-~a+7{{O8rEgHMB}$?(I3eM(aY!pKB3>MqDJ?9sFgt7I*tA>Qq_j<6FvduX z2TyCX5Xr8F@8A_Na_|fJ4RE%YK=5Mbu(SV}=l_3xGc$n5bHhYNYqwo*xE<8$_uBm) zsJ>;(Iq1@w^=L88LA&PZ=B^MT=o4-)pDq%1INpf2^y;i92Z}Qa^nGF!?T) zRB9(bnVkO~Y4riw$J&>{|y1URdgCkM4uJq2pS|Lon>4U4T7 z!Ul1kuvL?C{Innywr1<IS-61SJ7}H`wLW@h< z37v9oacnta%MrSkkOfJdupKNhVr3}Vv@ci9J)<&k03th|jV3ysX%!IZWtV|#A5hupnV1HY`fO_X`!d-p`B z&FqsIR4vK3SV8sX#WM=E{aMBT>L02yaN6LM2#T-engu~QG3{V1+$OWP9ZS&Q7JQjL GKmP;%V&td* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST b/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST new file mode 100644 index 00000000..45ba62db --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: eval-when ;; ;; Source: CLtL p. 69 ;; Chapter 5: Program Structure Section 3.3: Control of Time of Evaluation ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 9, 86 ;; ;; Last Update: Nov. 9, 86 ;; ;; Filed As: {eris}cml>test> 5-3-3-eval-when.test ;; ;; ;; Syntax: eval-when ({situation}*) {form}* ;; ;; Function Description: The body of an eval-when form is processed as as implicit progn, but only in the situations listed. ;; Each situation must be a sumbol, either compile, load, or eval. Eval specifies that the ;; interpreter should process the body. Compile specifies that the compiler should evaluate the body ;; at compile time in the compilation context. Load specifies that the compiler should arange to ;; evaluate the forms in the body when the compiled file containing the eval-when form is loaded. ;; ;; Argument(s): situation - compile, load, or eval ;; ;; Returns: anything ;; ;;This test is incredibly bogus. -- Pavel (do-test "test eval-when 0" (and ; (equal (multiple-value-list (eval-when (eval) (values 2 3 4))) '(2 3 4)) ; (equal (eval-when (eval) (list 'a 'b 'c 'd 'e)) '(a b c d e)) T) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..50d7da4ab61833923bf7ee4a8a2926243f3d0c7a GIT binary patch literal 11684 zcmb_C3v^WFnfKng^U6B`LBeZ5f;Do%03zUn+)QpVLnd>_J2Qk>TnR9kupvqFz@n9g zr;nX#F&O6;S-SSDwMUNvyKVusY)j9!>*;YlZr#)Ewsq}lYxQh((fU}ovftz0$;<== zY9KS;{oddI|KI=r-~Zp)FS*wSBY|M=*1oRpRDYm%Xs~Z+FtE9|KQPcc)W0zm*bMZ* z9YNDF?hNU{mW9{W6~%Kn8~alogQ-n{#87HrQ^)oNfw~m|y|2Hk8y=P~2XxuWrAt>X zxq4wylOB(-wF}W%wzBT3g+*r%jmj0hk|b@EP9gA1QibG_G7qFHY7<60p*4jgh8ERZ zjoQrqOxg!+(UNh)%A_k72L^llwC>clR5vzf>wqLnQs$d!UsEy~OoYv7W<(yAOEUMT zOT$qu22InO4N39YR?xbfNtZ3t7Hf4{JlT+Fj~OxP&}h{zNh+c4i*=b4I-+7l=)}qK@ zcmI)TZS(C2eUemysvEy_>ZpHVZd12AP4yuaKcITS9;UJfRLgOZYyShszCXwQu^BnY z!JOye&f(69bFK_J&P%yhySktkj?HAG6Ol*Y8T}Jyg1x`)crUh{ut#(U1l!}pwN^dl z_$xv4=q4wN5baigQRL>-f=Bqvk+4${auzc(AE5U5R6VB;bz*(wc>b)2voiw(E>avc zI42TpoJQ!F(V3+$ho?@aUdbXXKO+Y@nDdM&WM!2tT%|+JQVx2e>!@0=HT(OJpY^T!^PF%-(y-vrML39_> zlPC)+oz%`7@-SL|v%FckJZDECHK$1v*qrY;%_(=h(u(NB$K$ooZYsw<%f^WJNG>w* z@%chdd{iZ1j2sdLIEHF=^vuNd90`=Cg}ceb=0j>CQ$3kq<%#Bi)-w^y4WeSq#k$H8B>^&R|Wz;oC?$VZPb>P-E^ z`P}<*xW{(n@Q(H7a@GTaQP?{Nv&Qc@x$F0_8MXnOH}=AsoeU0+IqM|f`QR6vJP^(5 zYTOGuDLZP1K1hOy$*LVC0@Vpv*37%0)^c&$<){7N}|%HUH3pAz^K!>1HJ ze)#y{bZG|NaNEht%oRP%b`?eT=sswf~anTz6J#L%P3nAT)kt?^nR zEAn{lgjp+!T~)&Gngk_qS*>ANrlpz5L@b%8bxj6^l3G35t`QxLxGn*?s#+?8p&{{* zme3m_PIzEjDpit%iuEf3-u!2D?gXs)P2>AZQ;13Lb&EQ1_&og+6 z!Cy1DkHOa&^fFk_z+`X(gDK(?h{ZQaOhMohQvrB?1_2k<7;6lxU5i6%MGU0=gfzS- z89d405Q8ByRk25&PfV;`Pld(Ytw=%eiK`R69E%zeE z0t_k{xG5I(WAd*4fnrf#W9;9U_X1<5n0Jh^Z%~}-y%eWp#eY>qW*+Gw*whJ;}Voj2&Qb4}%?$&$A%YVG@R6GGZpjHCSIX zGnNRqhHo;gIP|dVHV~UMCZ-32Mm%mZuP>h$vy8?tEHRimt}gcS7aYNjFwdsf#1mFB z2y2g_H5$Q)j!;kNxFXPObX^Dba7w{x+KL;ET2>wnUd0A$7*vbdNSq`B2uj2p1a9If z|4TlV{}ywBsQg@9hTs@=z4A15y>ghkUfD(+s&p}EV3AcUvWP`g;>jN}c#FZ0NK*a* zNyyi2lQX9g}z(DkG5p4>uwb2K~Dx}`Svilg@ z#$XHD4@VP5GaI~>$li}AS-kI1c6k4j!6}e+>z1XrgE{XrLPyZXl2H~}#h?}?n<6G{ z?B1E80VT^BxCwYZWbi#w_dG>pH#Vx@TkmqPcO6sr4GiqZWNgQvk#X`|7UfV;t%VbO$e zKMBMtT!W#G!A<~ZnP!5S-v*{9m+&pojOIsy?#(kZ!i;-F6Y}=~e^S2D9G71MuAkx< z^R!*8M#Wx%g^s(Mu?^H^?pqj3iZJpl#zG7XcDRDEWugT|Y8ktnjZJ6lQZ`n?n4gVd z1v;l-H1gxlhN%9Dny8);xEQH#gXXNpAaUh_flr4n<*vKHU(2Y0|AgRKlUfT)kBk`|-c<@z$LJeTBb4f(~#S`H)0>aEb zv4a{Lch@W=+fn6^r?QC(20Q_jPeB%zFA}rkQa%)I&`-+y6oB$SB(MA)g009_N1EBN z+6dy2MfoN3Ut(~8(o6X($}8n-48B5BPg&1k9*az8UI_vD6O2Q*8o~)nx7w+H9kC9<8w`FUZbs}evMC>8WA`z*f{6jfDhWux21jMiyAiF~GLt+S z(vL}6`aX+2&EPSRE=;ccD5bxlK%`M|3j`wF4+?q7RUnvo9s1EP8}w6VAe z1}hn*iYO_nEg-pXOqvNJBx(#mR4kOQ6V-L1dakIh7S)~LskAtgo-r`Afo53Xwywd> zK*zv9Z$G}+LfQbzcr)qQiPXSgVD1imZeViwp837+N5hytDAk3;_mXuUMo2cwfql_@M8cX~tC`5Gw6?2NTksd*Wsw zW9bY-3{RzF93B`CPtlzM%u08IM2T%8TZR2}R4T5A%O<*=yQo}HF%e|1sFoF>Q-^zh zi0wpIduXt{N3(b-w(Btmy>};~kLIHfA*vH+B%gC9^|SaoQn?qsJ(=`n`MucF+oNSE zo4N+J4E1arL^oTwQ#BYk=m5pEM3B}zZvcl9qkUL3P@(3n8lwc!Suc#Or@5sqW;N03 z=Y@P9Q^BIt^WGRGL}op|8W*kS#Y}ouHa1!ohI;<8r}ws=Ku(~Z7bsBAy<-+REYF=| z6b{|fJ4Uf(I>sorOgu}Wrcg@{afquXU~Rdg*=*GC5Es|lLQtZ@Sv`SAOv`{PxOjMt zkv#=EOOEIAiCS_*FSX_f&T>!Lxc+vZg(Wt>zk7zdyJ7hpO!W_>HV$_6_JF4Q6Y6mF zkE2p~{qcHuiG3ghUlnlU`ngLky#GJvk}JVYYezkue9cT0Y zBa^$Jts(ey;>-69@MDqRt(TWn;u!muLj9Ahw|}v zl?2|F3B1KorT(0;^l+&qL3-JZYlfv3m)(#Az2l9UcrjuTf%io$KU}o6z=L##A|M)+ z8B=k0ip51pB+<$P5Vx3ypaB5f@i=#+!y=r)gFYUDVN;VuQmg^~G&nKo$p{=9vbU=- zC=0;9NDNEE6qtt`el)yum>%8(>(229eT^{xV~78K4j+OTW~~p%7W@FpxdVpY^=I#V zhljC=3r3~d3r)iF3~YY(ITsxAWNN{0DdWm8Qvh$l%Q<|IOY+i5{(|Ymfh+%oMLncbSR!YbDaxxj?W0r#f%5#~zdc31+GwGWA z4WlD4G?41oVBhHKfs>SJjk&#s+{&Li#vi8E-z_xs@zZg}<>xc$`Hu0GfxiCUKKLo4 zO&ADt^rx~28aTn$cV$LYXpX8U%vN!|SOupAVD1=|{Pp$p8v8ui1q(sWuEkZgTT}xX z?QF}8xGCzp?AUc&3*yF&Nh2CGuv(V;$m4=LRaxRd>vkuQmL9GAEOy1)fT9lKwy5lh7a zfiI0zIDo|gmNc44c&E&lr_i7Vp^0Up9yngu6533w5ryG>R{~&Z#Dw!Pm260jCL<9# zx_a&3asts8(-R^5b*Q*jtQ1#M73a_y&fvg>Z&B?~mWxHi z+b32al;`dw^lp51PfSls?~Lnd=@*&w!j%mM9NG>34J-XHcQAVi;oLs#h}-uO_~u0t zSYW~p#PQJnP{jpYMdYv4V^BsQgvCz)&-3H|{odHe8%Zm&3~> zxDkW*UzQPvoj8-O%2I-cmC#`~Zg*V@jrK&0XmcXu!6IQ@>l#c%ELeQb6&Q2?Oh!EH zR=3!2c_w{%tUJ{)kP2+-?YVp~(4XQJFR(+$d!dd14JZCWS0!*S{cml>test>6-2-1-subtypep.test ;; ;; Syntax: sybtypep type1 type2 ;; ;; Function Description: Tells if type1 is a subtype of type2. ;; ;; Argument(s): type1, type2 - any valid cml types ;; ;; Returns: two values, the result of the test and the degree of certainty. T T indicates that type1 is definitely a subtype of type2. NIL T indicates that it definitely isn't. NIL NIL indicates that the function could not determine the relation between the types. ;; (do-test-group subtypep-group :before (progn (test-defun subtest (type1 type2 expected-result expected-certainty) (let ((vals-list (multiple-value-list (subtypep type1 type2)))) (and (eq expected-result (car vals-list)) (eq expected-certainty (cadr vals-list)) (= 2 (length vals-list)) ) ; and ) ; let ) ; test-defun (deftype arbitrary () '(or simple-vector compiled-function)) ) ; progn ;; (do-test "every type is subtypep itself" (every #'(lambda (type) (subtest type type t t)) '(arbitrary atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float null number package pathname ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; every ) ; do-test ;; (do-test "subtypep: proper subtypes are subtypes" (and ;; Try some standard types. (every #'(lambda (type) (subtest type type t t)) '(integer fixnum number atom t) ) (every #'(lambda (type) (subtest type type t t)) '(bit-vector vector array sequence t) ) ;; It doesn't work in reverse. (notany #'(lambda (type) (subtest type type nil t)) '(atom number fixnum integer) ) ) ) ;; (do-test "subtypep with a user-defined OR types" (and (subtest 'simple-vector 'arbitrary t t) (subtest 'arbitrary 'simple-vector nil t) ;; Not sure what's supposed to happen here. (subtest 'arbitrary '(or vector function) t t) ) ; AND ) ; do-test proper-subtypep-test ;; (do-test "subtypep with AND types" (and (subtest 'float '(and symbol float) nil t) (subtest '(and symbol float) 'float t t) ) ) ;; (do-test "subtypep with defstruct" (defstruct t-super a) (defstruct (t-root (:include t-super)) b) (deftype deft-root () 't-root) (deftype deft-super () 't-super) (and (subtest 't-root 't-super t t) (subtest 't-super 't-root nil t) (subtest 'nil 't-super t t) (subtest 't-root 'nil nil t) (subtest 'deft-root 't-super t t) (subtest 't-root 'deft-super t t ) (subtest 'deft-root 'deft-super t t) ) ) ;; (do-test "subtypep with null intersection" ;; and-t-float-t-super has a null intersection, so nothing should ever be a subtype of it. (deftype and-t-float-t-super () '(and float t-super)) (deftype and-t-float-t-root () '(and float t-root)) (and (subtest 't-super 'and-t-float-t-super nil t) (subtest 'float 'and-t-float-t-super nil t) (subtest 't-root 'and-t-float-t-super nil t) (subtest 'deft-root 'and-t-float-t-super nil t) (subtest 'deft-super 'and-t-float-t-super nil t) ;; on the other hand, it can be detected as the subtype of many things (subtest 'and-t-float-t-super 't-super t t) (subtest 'and-t-float-t-super 'float t t) (subtest 'and-t-float-t-super 't-root nil nil) (subtest 'and-t-float-t-super 'deft-root nil nil) (subtest 'and-t-float-t-super 'deft-super t t) (subtest 'and-t-float-t-root 't-super t t) (subtest 'and-t-float-t-root 't-root t t) (subtest 'and-t-float-t-root 'deft-super t t) ) ; and ) ;; (do-test "subtypep with unknown disjunct" (deftype t-unknown () '(satisfies god-knows-what-partial-recursive-function)) (and (subtest '(or (satisfies gkwprf) float) 'float nil nil) (subtest '(or t-unknown float) 'float nil nil ) (subtest '(or float t-unknown) 'float nil nil) (subtest '(or t-unknown float) 't-unknown nil nil) (subtest '(or float t-unknown) 't-unknown nil nil) ) ) ;; (do-test "subtypep with non-subtypep disjunct" (and ;; if we know that some disjunct is not a subtype, then the union isn't either. (subtest '(or t-root float) 'float nil t) ;; however, if both disjuncts are known to be sub-types, then it is known to be true (subtest '(or float float) 'float t t) ;; if none is known, we still aren't sure since the union may be a partition of the first type. (subtest 'float '(or t-unknown (satisfies gkwprf)) nil nil) (subtest 'float '(or float t-unknown) t t) (subtest 'float '(or t-unknown float) t t) ) ) ;; (do-test "subtypep with arrays" (and (subtest '(simple-array t ) '(array t ) t t) (subtest '(simple-array t ) '(simple-array t ) t t) (subtest '(simple-string 10) 'array t t ) (subtest 'array '(simple-string *) nil t) (every #'(lambda (type) (subtest type 'array t t)) '(simple-string simple-bit-vector simple-vector string bit-vector (vector t) vector simple-array)) ) ) ;; (do-test "subtypep with assorted types" (and (subtest '(integer 0 5) '(integer -1 5) t t ) (subtest '(float 0.0 3.0) '(number -132412341234 13212341234) t t) (subtest '(number -132412341234 13212341234) '(float 0.0 3.0) nil t) (subtest 'fixnum 'integer t t ) (subtest 'fixnum '(number 0 3) nil t) (subtest 'fixnum 'number t t) (subtest 'fixnum '(number 0 3) nil t) (subtest 'fixnum '(number 0 *) nil t) (subtest 'bignum 'number t t) (subtest '(float 3.0 4.0) '(float 2.9 4.1) t t ) (subtest '(float 3.0 4.0) 'number t t) (subtest 'complex '(number * *) t t ) (subtest 'ratio 'rational t t ) (subtest 'string-char 'character t t) (subtest 'character 'string-char nil t) (subtest 'standard-char 'character t t) (subtest 'hash-table 'readtable nil t) (subtest 'random-state 'common t t) (subtest 'common 'random-state nil t) (and (deftype unknown () '(satisfies something-or-other)) (subtest 'unknown 'stream nil nil) (subtest 'stream 'unknown nil nil)) (subtest 'function 'compiled-function nil t) ) ) ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7d08bf8fb24f6ca827bacbb253eed6b017c19171 GIT binary patch literal 2531 zcmbtV-ES0C6u+~(v)%2sOSe?SjmSbO;=)u~YQ>`1yR)~uL+4|ekCu%ZQrj&pY(LT# zi4sVK4M?K{Nm)(Fv(s}^<*iJsKr?3`3C zy?a71?K1~Q3>I60$BP8PM&Y+=g1UuLo z3Zyf&+7=Cj%(U}*7Bo-d3$z0KM|Pr67VCLY!2g!;au0-_fu$QZa4mO$&i|pdS@f-7 znL>Fo`LqvuL+X{OrO8K-ul;gULYRDbD!y*SLHuh)y+S0EY1z=T3N~NLQ$4FP zQ_3iy(Q{Th5a!W<2*^sLWopZL$z--;0y1O|T4Aeb*-Q%rz@x**o~$yeI|XUbFf}X9 zg@EwiXxm8hSTM??!B#+8Jk3ngFeSsW3yz%*#vq_2P4%MW=`l$V5gAXLusuVQESuT@ z?P^>16KIZx2;m`w@UsZX`w$dj!&F7#9tdIF6tz*ji@TB?(`5RV`@#jZE#ql6iy~8t z`CH*JG@ph{A{%CA5v61N86-#f4kQP;x3a)@f<%4;&!!x#z_bF&zk=MV(IF;L)1(+q zz5~^EPh}N#Loed#Ohz@deZ`YVZu{gac*bR;P=p@PtW7g2y8x<4f!cYz>*qm8s0v(v zs;Z5vYmI_-o0mUNt-R!g4TCQ1*D{M{tEgoRRcefYF8YrjgT8 zx&x(Y(;U@SyxVU{I1x663<~IV1!KJCq4Xilm#~hN_Zo4Qzl7R%(8rq~C>?>kaoa3z z$;vy?u!rwMveOTWdW1ZJjN23)FiTa5sZ4_sgBN)SIb%>ifUYFxsfoJp!MCOE<7G$X zmppwM^fAq_r7V*Gvx5|3L(p{V7%*Yk&@@BegRxn~DyURuS;;n%eE)9T&YD}@ZI>1n zQ+qGby{U;&_!^9-re^#>j=D=PqT86eDnhm<1rU&f`HKitPU?<^9FPp?R)Zh}43qZ& zZMGDx0JGaagS#3)M~$JQhzUG>-l zCZJjc_~c|aAOy-LRI2PG?*gGEYdC;cX;3w&%@2b{^jKgvzdW$YCPuw-G!3!hh+!f~ zLx^mkt*QadZ3KsOM^$+*=$q=_D!vPZmaT&VWYMHB-hhdCj80YHqZ`)<4Hi4$FkNQA z$E>_z!cf4yg4j~;Nux%Iy1ZEt-Un`t)@>9C;`ChO%$|b{&u6b++R*3`KHo;rF|B;FWjoQcz$Z8go5jS z5^}G@ObqdZJ`9>2-Gc5yw=zYW2>|g{nmz8oP=yXH-Nc|3@C*cy`?NCfGa<-bN2K1W z3Y2$(mA{F62KcHVqj~9Sv}2(%plthdrgD7rkEJs(g}MIj8VSO8#;qpHqtow=kK!G9 za%e+veP|cml>test>6-2-1-typep.test ;; ;; Syntax: typep object type ;; ;; Function Description: returns non-nil or NIL, depending on whether object is of type type. ;; ;; Argument(s): object - any cml object ;; type - a type ;; ;; Returns: non-nil iff object is of type type, else NIL ;; (do-test-group typep-test-group (do-test try-types-test ;; Run through the standard types (Steele p. 43) (and (every 'typep (list (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(list) ; list 37e5 ; long-float (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list '(array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; every ;; Type NIL is always nil. (not (typep (eq 1 2) 'nil)) ) ; and ) ; do-test-try-types ;; An object may be of more than one type. (do-test multi-types-test (every 'typep '(5 5 5 5 5) '(integer fixnum number (or integer simple-string) (member 5))) ) ; do-test multi-types-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2a6f6f03bef34ba926eceac3823f3c90dd306a69 GIT binary patch literal 5898 zcmc&&du&@*8NUzPc|R9Q=XLbbZEa(EqqTHdAA{w_zDb-ozOH@UHgwQA@lEZQQ6d3{)4Z zl}5y(ClhA8TIt%Rl?!uv&N<@bD4f}nBui5D@k--RG8(kQRJ^u~6>oEa{!Cs?q`7lx3N!Y|(jX*HJyu6A6k$g7;SB)i`p%KV( z25kHK2+Mh0%{8V~3Ub>Zd>F=Sb0n7Q5wW^@o4sNhTC&7Oi}(TmO$GSTn%c6Iy$WsJ zCmU{(Gne_^0eyQha@uNtMUoaX4_obHii|B-ym;fjjbsJ$FxZN1$WCoudS1CeME6vv zH`Y!?BT@HlfyRA-gWXG+gFSfG;8}~~v6wlLJ?LMu{AVoxgH|`8XRV%#2ds9P$ldb6 zbxS!f0-m|{Za@*jzQupmQT(K@r)sUS)^3FQN369O|G_mdX0!N!rVAEsT;mYUs8*GTO|xCVi`&S2hUp(V;G#905q z&VA^vy}<0H676U6sFuO6Hk^&|MD zOsAxDRlinQ7YJI>P?##AK4L^e5i_n2hCzuACjv?*Yf?J!G~)5$@uK8*1%ieh9MR*Z zos6So26@f(B_ z#u1k_t|x56#syL7-1?q7q1z`(%tIG}L3RByggoY6BSOfxf%qr_!zT1O3L%(`$Ia-f zTZhRs_ax?eR#r1;B;X^(!&+#%gw<}o&D?9oC-elCH)0YsL&l7_IYfv<#)P+o-pf8l z;D7*oG1)e5jG5vZqM0UkBLN@t1E_yvHxYP)tt0RnyP3eNTv&ZsfU5$$z}C~;v(VVW zH6|v;2Q7+MeR_pv$KfT>&N7Wao?BCAgtdEwwL65hKK5~9xmD<2PfCPNek)^2`74)J z{>-J7H@UR(5|>uaaetH(Tv|CMKv94WA=k>~V7nLf;Pa9blrVnna2xP`kdchR)F1hrNJV$wg@Ed>6~-H`qw!0TXcb(wMQl4M%? z0f@dqD;W(@h|)7GK;Sg{1c66zn7R_Ct%s~&avTd`PzHY<)E-cW^!Hfa&wB5MIxjzt z+c9cS#LQsWi16gpW494$+z7@kz2@xAATP}?TduBcK$ zT)Wzqh;EfN^(}5q{WVvwUK8NE><;Kuc?t^=LZ5@}Rx@JKs_9fHh*$-&qvnu1N%RWq zCy=?$1D+hKJ=h~W7!js-3b2XoBJp()2b3O26^p53TB=-_)h4rt^791B^yo*NsWQ6l zsZ6Svnku6O*QP`>p4O-5^Hb$)A^S4^4T4$E3V0 zz$qS@@+jMh$do2%Y;`pb$E{?H8QG=F@k1Dw=E+6 z5*Ium z#yTsDG_`SBOKXj(xt$X_I!W&s#)_iQu&eqMv7D)VEQpe6V@K+J1Hb7aVcU!wkpyc2 z8#6^VEVEI_s+Vd8NnSQsH-SL_u22pNLP!t<%@nkuI@7QqjPQe{exvS~`qZgrvT?dv z>DWA*nsIcIWZQ1vvkDeaX3R-pS*Qy_6{w%dWywc6JWM zLd57ItE!GmDV2-a{2|T7+=^5Jsa|JbJD*M!(>m2D4g5}OmH-#yz@0fZJ6XtSWlbod zb?!MYH4J3Yz;;U2ia(c{olK|bP`|esLo&&{8ACr-t@y0LQ8Q@ED(lAt^eFFKx1q{g zd_$GnKO_tO>n(VzmA+krCi*~Ad_~}&M#}XZttIF2gqyB(_sKu4o(&)wy}T|`RvNZ7 z4(J;U4@Z+UQU}8}KpTL*7jar~U`0rWw~px|;p zh_HvY762 z@pr96vr81W1h{I1`dUE^b<%aU&1mwYAtN5*R|+J2q62hCU}kr-9Tcoj=%9Uiy84LM z>roZz;^ik!@x42J>UP4uc#66%`RKx~uXGn^G*hj3%lBvV4k3rCU-eWUMSbueyHXBRC80JMom^La*!CU zhnlFk%f`Y$xZ@Wz+PyHEx^{v_cOp9&byRZTJld20oKx-#4h{xok-Tx?M<>K+-NL{# zVzjn;&cjk{lBF4suIJ%}yARC1urM$n<{Nmyl+{&1^Rx3U{`(w{PI~9$@;l4RFd_XB z;doRU{SG6QkA5XWV$AQ<1zv=uD+vdE%d}R`INDs%NoS|1)MZOrxj64=Xpg2- zxe^A`T4C}q8m28;+L?3mX(~VHkDQ}(AUbLNNGdn)?AA&`+h$(&=3JRx?XFLKTH9Pc zHs{nx+9uA?%ab~lKjv}@1?3F-t5ja&ESu1GWoMmy3GG-3BuC2^@_Ig->pOCu)>V3X z058|yHx@@uWS@OrS{xztZHyi?E`9m%<;;~Z5tbK69~%v4=xzQ=c;?#Wi@(2;xtzfV zqtVAthA;XDM(OL))$qBo$i^2JA{qaI%cIJbi*H`qjkkA*ul}Wv0(IdB!kq&%qjLLo zqQA*>W;-+Z|Nf;HUq%$S^s4pJi$mSC(TdUQ1rof{ZtlmMgN*~uUsM`rS??j%n_|6G zZ8~_R(?enO)(QHeKzU}wVrDe70YlN)>nI~*^m^nI{i4E;&#UTTkUE6|+p_UqkO+Uq zOs^2@S`(k+5Nl(WX$#(Z8cw*%Zq;DV&jXA-}1NYccIiBU!cM2HiC&jhAft R4(xe%k(ZvN-Ftm``Cm`&s_Os% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST new file mode 100644 index 00000000..8448fdc9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: arrayp ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 26 September 86 ;; ;; Last Update: Feb 4, 1987 Jim Blum - fixed to run on the SUN ;; ;; Filed As: {eris}cml>test>6-2-2-arrayp.test ;; ;; Syntax: arrayp object ;; ;; Function Description: Returns non-nil iff object is an array, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group arrayp-group :before (progn (test-defun arrayptest (object &optional (expected-value nil)) "See if the predicate is true or false of object, depending on expected-value; see if (arrayp object) <=> (typep object 'array) for any object; see that an array's dimensions are non-nil." (let ((val (arrayp object))) (and (cond (expected-value val) (t (null nil)) ) ; cond ;; Equivalent to typep...array (eq val (typep object 'array)) ;; If it's an array, functions on arrays won't break. (cond (expected-value ;;Each dimension of object (as counted by (array-rank object) should return a non-nil value to (array-dimension object dimension). Acknowledgements to Karin Sye. (and (mapcar #'(lambda (rank) (array-dimension object rank)) (do ((rank 0 (1+ rank)) (y nil (append y (list rank)))) ((= rank (array-rank object)) y))) ;; More thanks to Karin. (mapcar #'(lambda (func) (funcall func object)) (list #'array-rank #'array-dimensions #'array-total-size)) ) ; and ) ; expected-value ;; Non-arrays get this one for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun (test-setq type-examples (list (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(list) ; list 37e5 ; long-float t ; nil (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname nil) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence 6.25 ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list types '(array atom bignum bit bit-vector character common compiled-function complex cons float fixnum float function hash-table integer keyword list float t null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; test-setq ) ; progn ;; (do-test arrayp-with-arrays-of-all-types-test ;; See that an array of any element type is an array (every #'(lambda (object) (arrayptest object t)) (mapcar #'(lambda (type element) (make-array (list (1+ (random 5)) (1+ (random 5)) (1+ (random 5))) :element-type type :initial-element element) ) ; lambda types type-examples ) ; mapcar ) ; every ) ; do-test arrayp-with-arrays-of-all-types-test ;; (do-test arrayp-with-strings-test ;; Every string is an array (every #'(lambda (object) (arrayptest object t)) (list "array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum hash-table integer keyword list long-float null number pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector" (symbol-name '|array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum hash-table integer keyword list |) (make-string (random 100) :initial-element #\backspace) ) ; list ) ; every ) ; do-test arrayp-with-strings-test ;; (do-test arrayp-with-symbols-test ;; No symbol is an array. (every 'arrayptest (list (make-symbol "(make-array 20)") (make-symbol (make-string 20 :initial-element #\Newline)) (aref (make-array '(2 2 2) :element-type 'symbol :initial-contents '(((a b)(c d))((e f)(g h)))) (random 2)(random 2)(random 2)) ) ; list ) ; every ) ; do-test arrayp-with-symbols-test ;; (do-test arrayp-with-lists-test ;; No list is an array. (every 'arrayptest (list (list (list 1 2 3) (list 4 5 6) (list 7 8 9)) (aref (make-array '(2 2 2) :initial-contents '((((list 1 2) (list 3 4))((list 5 6) (list 7 8)))(((list 9 10) (list 11 12))((list 13 14) (list 15 16))))) (random 2)(random 2)(random 2)) '(make-array 20) ) ; list ) ; every ) ; do-test arrayp-with-lists-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8a1a73cfa241bfe3fc0a817541b25ac76660b263 GIT binary patch literal 3038 zcmbsrTZ|jk_0IUQ-iIA;x+JMf>Bu4tbuxxsQncNmX0ONBYwwO{hM6%Nw*|Chy|t;c zj`oqNR86haG-*4{vPoIZg+^4W_~HYIgb4EB z*qbFF5ee_ip7*)uo^$S*yGbG^G+ohJr%pGTwH2kczIJ+jO<8KKD66gYm6J7P3HZuS zHPdE4D^hJPdu)8j*(Eu-Qd?N7Eh_GMZFOB$4zuSx&e6}!B@AA1bBJ@s8+ zm=Jit9(hkSBd}QTAUzb>F##rok4$`*yWJiY@WFn0F9#fjb@(9!rc?*D`4m#kNN*7& zcDZU!fZ0<4+e<8gRH>w^J12 z`=h3uf)^^==fJwVP%JtAzH~IO?raM3vt3UTdC-5(yE~(qM!tmIt`@10*O{&6O29E@ zoQxdfgK`w!2pp%;j7D9psM^e}*l-*)ah{@1)p1!_mO*1IIB=TIs8O-hf@znX43}i- zv(~Pe;lrUg9}Eq{@k(TvZJV}gR$Qy%WaZXb zK8)fjByQ*+dz9H#)qzau47mny2Yz6HnKps6hU-zwVn!axFux0d#PBd= z;GjA%1A(xzg*1j5FVi`uQro6gWc?giUlA;)YM4e9lVCGiM%gOA8^MzSm

-W?EG! z70tUeC&H6-V8<-#7I7A$`V25e^%9Ios_Xsn=AdK(BzweKMd}pQ9T)c_->H^!rmps9 zB0aS!0Q zR_9A@QH5lR;q9n6(09HONTBvQ7cQFcU5FakJffE#<0=Z%;3|f$P@5kHmh=g>&MohV z1)c-(yTYAxUD!*155TX%`JR#irx3QqbXJB=Kwsw}?qMi1w3wefwE7dK@%mOoa5k&h#}x5PRg8gJTG_&U9(d zzY#munO*n??o7I`^VfEubx&vd4*`}s-#PyMQ*U&prvrNEVhmLy{$=>YOA`7dAD-)e z((NMl9;6InlT9q>KnZ$j25wx?Zb37n%6~y68jT|QFNiM^LF}JfWMH}hU%4dly;O7I z)RT(~SlHXgJg7=y%tJAJFKXsyndV9%o&^E=`Ln1EFWt&KdD-`}Q#l4hg9Vp8af4mk z>7su7oOOB)l|8dXj?%5^&}O~ecm_bDUB8+R$l(8t7kiYrSG5~Al6Cm|!pP-b;#NB7fK3Wt_ma4AsCJkoYWTFUxGbl=X!9`_YPUj+QMp0S!^vI gT2oePi?tyAV`IT<>|FWYz2><{9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST new file mode 100644 index 00000000..2a0045a8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: atom ;; ;; Source: CLtL p. 73 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 September 86 ;; ;; Last Update: Feb 4, 1987 - Jim Blum added nil args to (pathname) & ;; (make-synonym-stream) ;; Filed As: {eris}cml>test>6-2-2-atom.test ;; ;; Syntax: atom object ;; ;; Function Description: Returns non-nil iff object is an atom (i.e. not a cons), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group atom-group :before (test-defun atomtest (object &optional (expected-value nil)) (and ;; Must be non-nil for the true cases, NIL for the others. (cond (expected-value (atom object)) (t (eq (atom object) nil)) ) ;; Test the equivalencies in Steele's function description. (eq (typep object 'atom) (atom object)) (eq (atom object) (not (typep object 'cons))) ) ; and ) ; test-defun ;; (do-test atom-with-atoms-test (every #'(lambda (object) (atomtest object t)) (list (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)) ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float (symbol-function 'atom) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword 37e5 ; long-float (list) ; nil () ; nil '() ; nil (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname nil) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable 6.25 ; short-float (make-array '(2 2)) ; simple-array #*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list ) ; every ) ; do-test atom-with-atoms-test ;; (do-test atom-with-non-atoms-test (every 'atomtest (list '(nil) '(a b c) '(a b c . d) (cons 1 2) (list 1 2) (append '(1) '(2)) (nconc '(1) '(2)) ) ; list ) ; every ) ; do-test atom-with-non-atoms-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..68e20a7fa31fe50d9af5acb1e16606a6ba749921 GIT binary patch literal 4249 zcmb_fZ){sv6~FKKPZGyT)3kKM>#|3n>*n^QiPvo<-MYTmFNqt+&$FM~hA$|MUmCBk zv1L2e%2?^9mbIH{mqnC!#|jc3kdQ#yije5&)S+n-A1as-LV!R_XackktYQ?Tp{e}N zy|!Z(K$B?V_s%`%o26A*i|B3jP)@e^IoX;MQt-@>*L9ksi%!;GwLmS z^-koX=W}M(tFMn~wNhDkonwwm=^U*xg)#5>dgpjP9k-KK+FMahDq-(@y(gL0Gf2&t zFqzuf@Iu}duipQF9>f1w($@Ezaofu38FukP_-V#`H`e#5gy}~MSEiK9i|miDO{oVW zk@ZUOumE~#T++|?UbT8(uzF8R_9e1Gvxl*(FAt)DABh$s5y>D&wDF7Vi@aK2?FH9h z$W-c*VK=zq74ZE}cWh7=E{k|zuP>+0TfJ{Ew!H9+)jOpsFk624lLt080CX}ICeyir ztFQR(B4HyF<$N=fPLk5IsQgU^L@+npYEl=xx;;{Yx7&@^W0DO8L~?E*)FD!eM4ylyn}qET(8BJ%S?Ab-RXxF#gx0aOCI zm1ummCK{Sp3L^nDMtKb&Ah?y`{efoqM$utX@FN@;e|KXmzPpj;1S0|h1-$WV%+LP~ z2vPP?(Og~VV`|v@YJGDwZlx1R+C}t9Bb`W@S!@xIq$hGwwVQXTJ$SnCbm9r(31G`w zAB`J!d{WPvc0P+OCocA^U~VR7o71Wajg4|si>FK@ozLjwR(3iU<%+7TwYIG&@Aidw zm#-IFSZ~zKX0bV0c{`K0qrP=82uF?dj4tHl#H;s>d}K=u`55DV+6VX0hV~vD`OW=C zikLru2@(LqCieG)AfC@=&2-zQ%N6Q-i;%AlNZiPoGA!?=?(bm0LR-xJW_Cu;VT4j9 zNxupI-P6XDspn><$1D-^C6Y;2?CGS(A?uhxRC78*`~`kHkrjx0gt?K;8Z#t14^c3S z*|4UG{gPCCoJWXTqE5JhcVZvq8;PX(Cx|@4Hxap=-$taL-vOe2D9O)-rus9XslF~W zRW3Bu=i#)GgPlcYWcFpgnaESpIw7qMX&sZ+-NIVADO8ky3IpYRN&X~-?@01C0`$hM z%nWMANZ7`h7(3;f)cvs}uS(tTQ-<=40s!S(TqE)|+35-#N>SiYJ|}P}_emVvq{^Tq z9dOe{#~lVT9wQe_bg&zeydgZX*M%qcitxnFV2ao0Oj}P_@%%I<%b=z41xPnSI^LLK zy?OE;M2vNfd2Y%cfh-`3bthWAxr`Z48Y!^^^vo6#O&js7)$(yCL>=Q}Rz97`BmvX+ zE;-0#t%)>ozeP?h-$AuF(?(ut^{;_?dS*s-$q?i z=-ScVC4o=pQ+85MB;hrOp~c9Ex|f+q%bgPbHi>t$Bt1aWmrP@;f(h2B4OBUbL-XuI z9BTXdFo^mAzn{oIBzK+D?5o%Q%Rq{x+rq0q5aHGDin!`UNzNktx@P#sppe(&d?%4( zd!+=GaBuN{Fj_S#ixd*rP$@_-DvP7vkqdel!;%96U@MR$*p*q6_>7T53igVgg&fk}A_3gK0I+oHZV`EDXBQuA2>TbT#!!Bv2I zMo!$Sqz$rS3CPO0#QLBlTO{NGF%8Nc62NUTNWToZPWFXGANx>n>;uXDRdVl1?lr*a zUkwg86Im;t5v9VuEy6Q7N$i{m&z?d>v@XXdc&y4}^HksC*kv;jvF)Y<$1+>UY^rwWbZ8Fb1{xS$sqkwBn+?|C8*5SZhys z^Q98RT0bWiz!%}*+{n3M{Ev|7QK0*DbYyr~a7C}~ zZ?+w;-Z7#L<6m^8)_NWlo|RvFD?SX8YSFlLwRUk)_sTcCGXX{Qc`E@L$5awu9N^CQ zsqoR0 z{cpnu`?L4l2Jh?!p~(vnpDqdcI~Q2T-Xbndeax#z+}Wdt3bQnIAH6-mg(7YbH1hSJ zHMS2QNQ#fg&_Vuxx&|Y=?A3=x$4p!+O!-YFJ~V5sI%yWjiCm*(XbrPdUY*G0oa1Q4 zdF`G<#hQN1nX8p5dRZ$SdJN5bwTB+wquoYphHPVnyw`&Eb>?{^gomy#8a~>}vl2g!+&ALlY%Oj#_5=~W` zt+ZT}E2T2NrwP%}u?y_sy|_RAaFX8FFYPdvCr?c-FPto18Z<85d4!}lFKr;g=|$Ju zYkdp&FN*j7o(B|#+L#AlYaXcD?zS>?3>zu0-fJGjfoh`$aJ|c$fhhX>#R;OfA60bD z28B2?fM$=>z@2KU6KuGBJ5l+QOwnm6%_*!XmsD)3L3eretr^#u#fTP4i(6|NM%bJg^Bcml>test>6-2-2-bit-vector-p.test ;; ;; Syntax: bit-vector-p object ;; ;; Function Description: Returns non-nil iff object is a bit-vector (a one-dimensional array of element-type 'bit), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group bit-vector-p-group :before (test-defun bit-vector-ptest (object &optional (expected-value nil)) "See if (bit-vector-p object) <=> (typep object 'bit-vector); see if the predicate is true or false of the object, depending on expected-value; see if bit vectors are of the proper type." (let ((val (bit-vector-p object))) (and ;; Test equivalence of bit-vector-p to typep...'bit-vector. (eq val (typep object 'bit-vector)) (cond (expected-value val) (t (null val)) ) ; cond ;; Vectors are one-dimensional arrays. (cond (expected-value ;; The caller had better not pass anything but an array when expected-value is non-nil. (and (= 1 (array-rank object)) (typep object '(array bit)) ) ; and ) ;; Non-arrays are moot. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test bit-vector-p-with-bit-vectors-test (every #'(lambda (object) (bit-vector-ptest object t)) (list #*1000010101101111111 (make-array 500 :element-type 'bit) (bit-andc2 (make-array 12 :element-type 'bit) #*000100101110) (make-array 10 :element-type 'bit :displaced-to (make-array 11 :initial-element 0 :element-type 'bit) :fill-pointer 5) ) ; list ) ; every ) ; do-test bit-vector-p-with-non-bit-vectors-test ;; (do-test bit-vector-p-with-non-bit-vectors-test (every 'bit-vector-ptest (list ;; Vectors containing only bits are not neccessarily bit-vectors. '#(1 0 0 1 1) (make-array 50 :initial-element 1) '#() '#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6)) (vector) (vector 1 2 3 4 5 6 7) (make-array (list 7)) (make-array (+ 10 (random 100)) :displaced-to (make-array (+ 100 (random 100)) :displaced-to (make-array 300 :element-type '(or readtable string-char) :initial-element (copy-readtable) ) ) :adjustable t :displaced-index-offset (random 10) :fill-pointer (random 5) ) ; make-array ) ; list ) ; every ) ; do-test bit-vector-p-with-non-bit-vectors-test ;; No string is a bit-vector (do-test bit-vector-p-with-strings-test (every 'bit-vector-ptest (list "1 0 0 1" "1001" "#*1001" (make-array 4 :element-type 'string-char :initial-contents '(#\1 #\0 #\0 #\1)) (make-string (random 10) :initial-element #\0) ) ; list ) ; every ) ; do-test bit-vector-p-with-strings-test ;; ;; Multi-dimensional arrays don't qualify. (do-test bit-vector-p-with-multi-dimensional-arrays-test (every 'bit-vector-ptest (list (make-array '(1 4) :element-type 'bit) (make-array '(1 4) :element-type 'bit :initial-contents '((1 0 0 1))) ) ; list ) ; every ) ; do-test bit-vector-p-with-multi-dimensional-arrays-test ;; ;; Symbols aren't vectors. (do-test bit-vector-p-with-symbols-test (every 'bit-vector-ptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20))) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test bit-vector-p-with-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ca66bf3d45363f61ef6f227d4093af58712205c6 GIT binary patch literal 3439 zcmeH~U2GiH702()I*vb=b(FfWB4KbgPFNUI8{;~LhRlv~-x%b?A&z^Jc?1I>^U(YJ~)ZyvUM6s+)&CO2F%_?J4Wo2e+t~^py z#<*X3P`7O3SihzZw%ycT=d9C=l#9c&#ZkqbE6$7#KX9GWzDv=j%cTi!ba%7Z)zjJ8 zbHj~ob!pAXhSt8#obH~^uC}@hrx&Hzln`P>ECIDb#6(1Rrz)|eYdEf&&SVYM)N)4B zTktA1d=|Cf7`9hw>QH8Ui7b9hEbLU@l=YSIN$cQcmhJuV%W8oZO0#*C@v z`Dj|7A>^86E3htkl~|YB!M}RHW^1}@*m-e!vGIfuk@uToGIsRG@w0={E0f~wKMl(J zn&VAU^`T&!XVM`LM3=1SDJ%MLC_aNZ+-wwL>G>9J@E^LyLuiH%Lt_$$E*EPlF>J!wVX5Mp8cQ7bwqOFVGl`78EazPx0O5Dl0*5?^{D z(zI^x@)s+6uR-tk&;Q2<_{{%@KO7C;I%t~zUC^wHm`HggVrsuBTEf$Or;EP7vS=em z`^1LjbihLY^)hU0AkL|`G#(RjqxWRx%A{_Yy&2RAwO=!PvxcpvGTdYKIZ3(Jua#@~ zspe+`7o(=6uDN=@Y8!6B=3=4;)u`GTa$F-P%RFLpSg!P}p_zrenzrnmlk_E7x^%W{ zCH?wHylsW&L`nf5DEb+ivVN>><@* z&twhs9`H8#!{{I5VK|2@#jF9bUAQlJxO0-gAc-+YwKZ*~kf ztvW-wl$BLiD))Xq!DScq-NJnv0+)1hE9&G8J)`jyKBt=Bj;@@h+t#X$E!?#+ow5pM zZ+;6l`VI`_ZL80O^g5q>>sr-U_hsCE)#PA6pQGY-SiNu{V9xLSIPfdJWU5X0H*oiY z--6x~Y*5~Iqpv_X#zJ(>It+x0Ay({MQ-sSpMlPc|E=Qqe_paMOI3*RXx+`2J89@Fg z+u3%Boo_H9|1~fnzZuSbDS-F`n~1G5(PvwQe6XbOg7M;HIPkdNGUF%4*nRcsoHkf6 z1E&`Jgbk10TCiNB-@n3Op$Z@7&3>ZYPqg@nxSuG)8E3u9Rc>)+R%w~nT9mP2e%}~X zN|WKM0{Z5+W7xwU{D;;d?`iLGB-K{kHZ<2zFN)A?hA(O@>-hCN%)ch|Pr<(ybFZX_ zfXk^4*h~#TjDjn@fodStEQ*bLN?cN6!mGq5h7TVc9makx&N03!r69*R&Advrl^QT~ zSBm%vRb(wB5M@Hv%$&uAPtPltd{ zXbd<t%fZx+z;8`jFza?aq^lNf}Uy=1H5BHvzk; z2k4<)Ko@lb9rRI7Qo24E|70C8#un(0TtCb}MoQX9}nDo{<=0Wu+= z#g~)>KBsGd&uAxbo^}AAP%ChbkU-*NN&p|xHsC`-SrQ-6)xdk-P0WkeFNt~aoL6b< zNf}&-jqp7@_;NA3n(!-`KJP5&e%p~nu|<1g55LJiihm2^$4fpMcs`Bs4gH_eQeIBW z$ZA@0@u_XK^0>~mtXGK|`}uxwjb4@S#DXEJn)#}!T`hK-{B*6KuJY4Dl)~&y3@)?V utL(^66o+Su%IMVOj#;H#94(HOCX33vh9WVn1Si86j;gQwLOhkbaN#R8A8Y*p literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST new file mode 100644 index 00000000..4252d040 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: characterp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 21 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-characterp.test ;; ;; Syntax: characterp object ;; ;; Function Description: Returns non-nil iff object is NIL, the empty list, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group characterp-group :before (test-defun characterptest (object &optional (expected-value nil)) (and ;; Non-nil for characters, NIL for non-characters (cond (expected-value (characterp object) ) (t (null (characterp object))) ) ; cond ;; (characterp object) is equivalent to (typep object 'character). (eq (characterp object) (typep object 'character)) ) ; and ) ; test-defun ;; (do-test characterp-with-standard-chars-test (every #'(lambda (object) (characterptest object t)) (list #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ #\| #\} #\~) ) ; every ) ; do-test characterp-with-standard-chars-test ;; (do-test characterp-with-semi-standard-chars-test ;; NOTE: this test is not strictly portable; see Steele p. 21. (every #'(lambda (object) (characterptest object t)) (list #\backspace #\linefeed #\page #\return #\rubout) ) ; every ) ; do-test characterp-with-non-chars-test ;; (do-test characterp-with-non-chars-test (every 'characterptest (list 5 '\#\5 "#\5")) ) ; do-test characterp-with-non-chars-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..36f6dd3ccee98f4aee3650dfd3358c8cadd895ee GIT binary patch literal 3094 zcmbtW-H#hr6~AM9z5ZI)4oL`xHltOS#3r+9LRxJ@fsDu3YiGwZ&U|FEAc36qxNF$8 zEw49XL99yE0z#vfZNzp4$O{j=A+<~p?(DOf+lneG{jEWF(;15WozY-tBzF2kal5}WTzA9{|0Zr!{igqP62}w_CfH#LF*=@?hBA1hKRP_JwO#uU`A|^NXpfY^ovJ zC$V|)+H*^bsmJ#Zgj}C7w$2V|NivpWQRcnn=1LYfEvZ^pxunSrUh?)mH-T6r+vJAl z=C6pO{y^Gv?mC+k&ek>)81sJaCaSikSan_V?g_658ShPZuC7TH-<;X#l6?Sqxb>ghsWh`${8`1@+Oemi@p zXW!DZuZQff$p+*cV~6j|gTRkO8-+s1AUx3c6>b#XbB}hxjTtfxb;&RduKN)DsaI$7 z!p4K(Jg|@U)i?F*hm7rS{6x>LL|Z1tMx z{$cuwPdNMEPB;$#(F8vEv3MY$aGsQ}QeuvY!EF=>kaF~Ydj_-{1?2p2BgZ01?-%YD zN{X&k>Qo(4P1Y(ZH>7eM5^dQmMG}586371x$}eA1WJ{?@2DfYj<)Z}k7dO{Ti#H+> zXq*lUR8hIC*-fdc8x6DM3lZVt)|OuK)6qFU8BL=cvn6gAx*_Sd)wHcrGy{W7N!He+ zKu#dh6!cD&thFX@!cns(S#nuL54gF@C(3><#+V=*KPt*2~k-Y4Jrd#BuiFB!)#627^iy+8F;_pE1 zw8^ciWUe*Jx++b2kv3PcNy<$_ZxVmQFVM2!pP^;mKTFGJd$X;D&Xa$CCICdRtP%GBS<4|SlldXhRGAJcVo2*Z{&`w_45zq8 zw-H><&-@D{-34I0Twm7g2C+jRrpMEW?EM9jeizbnquqfskes`%%^gf+=^Nb8bwk&9 zsM3K-@`UW0eu=CtY@H!%$@$)()oY(Ly$Q!sRBIBy-9%S#gRC_FOSCBdC0fn{BQy3Z zh%!7i5roDb2eGh6;qn1=Qxn}~L${lOGW%_)d_UBBBV2xj_@^U#&o6HK#STR2YC~SJ zwIK7hUo+7w7$A!7t{?%RhMTdCS=ziSv8%yx3{sX={t! zUid1JY%fUX9@+&M(Q-YwpB>MgX$^<1U4r=50ZUw`3G{T1d2V5|wRNZ6B8-!b2NfY` zJOXo*3(r2Qmv3;zf;i&ci{LdPxat9m6WXT&%K$9652{Om2;RLY{Eatwqs)ylvgG{= z#~{_uC7ldqv8qY#8zyWmC5FhJVq2 z9`qctBHcnDIwd`+)MP_e00kxksqbQN#>ASb=r#tIR8@7^ z0w1r|Z==#d%>*L zA~R$?e&|6anzB`+PY2K$19h!8Boott_!)zy1StiCCKE~$d8`D3mNra&)8?8&+G(?< z8yK16ATnm1;*=)Y%a8dd5|faAIZI6x4}s}=|9-$`uXpi$eyXaAQOOBWzX$|E`D;*MzH(GP?1ASlUMq8y zB@e&3f)B~jwBshNwr7r;Z;^mr^ITfqHXTRocEpS8{jIHjZy@&Xe8*WI6~&jn`Ze)l zFx|!?@j|Fl4B%V6-Ld?Vi0LJ6hcKfJM;r{Dc6S}qQ0#7tqv4Jt;=2}Pr?t5ax-+$F zI|HZJ?)F|5`#lj;5a&8=iAJfjc=v#b*YTC`M|r>YT5W&hmG1o-@%VZ`3jh5mhp&hK zISKIH85vK4sOQGRF@PIMeo=4ITZH0rvly-DDKre;W}8RPVLxHo<=}}w1!gvAc)c1S zdOSRZGyV!=-S7g6E8}&^b1yVEofaZ&_j?ycB9h>Ax;;nSlW9=3#Na~cn>hC56|!H_ KJ-q(-@qYk6&XKzS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST new file mode 100644 index 00000000..35c3d5d1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: commonp ;; NOTE: COMMONP NOT IMPLEMENTED 15 12; SEE AR 7072 ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 28 September 86 ;; ;; Last Update: 28 September 86 ;; ;; Filed As: {eris}cml>test>6-2-2-commonp.test ;; ;; Syntax: commonp object ;; ;; Function Description: Returns non-nil iff object is a standard CML data type, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group commonp-group :before (progn (test-defun commonptest (object &optional (expected-value nil)) "See if (commonp object) <=> (typep object 'common) for any object, and see if the predicate is true or is false of object, depending on expected-value." (let ((val (commonp object))) (and (cond (expected-value val) (t (null val)) ) ; cond (eq val (typep object 'common)) ) ; and ) ; let ) ; test-defun ) ; progn (do-test commonp-test (every #'(lambda (type) (commonptest type t)) '(array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; every ) ; do-test-commonp-test ;; (do-test not-commonp-test (deftype zeroorone () '(member 0 1)) (notany 'commonptest (list ;; The name of a type isn't a type. "array" ;; A list with a type isn't a type. (list 'bignum) '(bit) ) ; list ) ; notany ) ; do-test-not-commonp-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a950f0ee78339fe73b4bf3b06c6b30dfa7d44a22 GIT binary patch literal 1776 zcmbtV;cHt}6u&QNv!rQiqFI-AYx~+-S)Y4hZRcz|5MEwyn%I~3viDw`6+udxnqbzH zHdTgL>jXu3P_we~?zVzo1i>$E2r``H!~O%m`rVHrg5bA$&bv*P&3+h2Th9HRbIl>A7X;Z9i*EhE7;#zG}+^TJF7E9t9_{EP^!=#^N6m=> zba)^{YlM&@X`%@c5+#1(-g2UnO)XnaXEiG8N{&iy!*znti(Ig%={m7#v0mGdtECT1 zRcz<_77++>zjlJ@g09+GLwEOuU7^?Ab0S$?&O>X;A|<}yF$=N_t}}31o`xUQ$mOBZ zg4{}$^W^X#bdwO_UM%WEX+M`AEeQ|T$!EVT`L4wWV?yA4LNE{^r1|s`x@cA&f$zne zr(#0+;d^~eqYvPp4Qb8A z5Viq5{63g`vOL#bHp))NdbhG$-Yq}3lKzvFbjrBbk`XE&caB1)I>8t({~*zp!P+Yn z^Zx|_-J64W#N{aQh1}cDIY~A2g)H8=oKf@zjhb>Q3m$#Zl6*lH@&(|p8-^+-sfw*; zWRuzj6NW50br@&u0EoKiTZ)F@D*yo$px6k% zKm}^SG^yV4Sug=(AEELmhoCAJ4Xu-7=_pi)^aXoXzk%g{~PQKnky`U zW(IbhI%YupDvzFL1Biw>I_n|w4~v77{LN0I`JMHn`N`Wte)QTQ`VeLL2%;^cX*MHu3ibUjT-?!10<^e;%!?4$qy literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.TEST new file mode 100644 index 00000000..6deee8a7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compiled-function-p ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 28 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-compiled-function-p.test ;; ;; Syntax: compiled-function-p object ;; ;; Function Description: Returns non-nil iff object is any compiled code object, NIL otherwise ;; ;; Argument(s): object - any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group compiled-function-p-group :before (progn (setf (symbol-function 'zero) '(lambda () 0)) (setf (symbol-function 'one) '(lambda () 1)) (compile 'one) ) ; progn ;; (do-test compiled-function-p-test (and (compiled-function-p #'one) (typep #'one 'compiled-function) (not (compiled-function-p #'zero)) (not (typep #'zero 'compiled-function)) ) ; and ) ; do-test compiled-function-p-test ;; (do-test compiled-function-p-before-and-after-test (and (not (compiled-function-p '(lambda () 3))) (not (typep '(lambda () 3) 'compiled-function)) (compiled-function-p (compile nil '(lambda () 3))) (typep (compile nil '(lambda () 3)) 'compiled-function) (compile 'zero) (compiled-function-p #'zero) (typep #'zero 'compiled-function) ) ; and ) ; do-test compiled-function-p-before-and-after-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c5a98ea599f8b9875d869093bbf7beec375d7b8f GIT binary patch literal 2916 zcmcH*ZEO=|_`PfQ(S4LoCqe`G2BeJ24aSB6MCt8z+sfKry}JVQ4=LM?b}4P$IwBh9 zBz4D+MjR-)7bGSm_)7`!OZ>=4_~#G(rO_CpQ4=+qfYHSLAgRxDcPn#ZG%>clKJW9q z&-e4Z&%JY`?w}N-QsHPZn=>Y8VX9P|D$%jR1f48QO^g_H4CwSZNm1qJ2SsV9^Rccb zZOP8agpn>8qg0Fa z;>nnNFi9?)^_?JuH`)R``tx4q{UPppo_zYj5PzUO*v8c#v7Nlu@4!R;dBuNP@xSDt zucHhsTM3!JvK|)jLsBLfbP$LS*6<7N3%*;qy9=0$ps2%(g3W+s-v|7@6Af)#=DKYU z(A#sdQ;Pp4A#)j1@elDFh|OJDePE^QKqDb7C_1ug{wjA0iEbp^JByJtBK7}%AYL@# zgbh*O>jSR;>j+ogE5aq=@y23!KFHE|zFGy-M;DMI=W)?ba&>eiYhlLm++U@2CCr*Vt<2|Xh9lw+%c`oV zf|AmcDLw3I0fCmVm>3ppIx4X$fv#mouGK>b^Wr&Mg@@)4DDukt#TX(gAob{gs3WSN z2U1E^<;0Rh%{bhPpyzj!Ac>mnm}Skly&96#v{BwKtHXi@S&7L=^@9H9xHu#W+HkyA zL7Uv?Xj6q8Dse#h0Qc0VeylHcj3l7`M4tNowt4-}`7Mf(CF(5VfLwQpPI}Iro!iK7QGNtJ9AX_5? z;>GmuVWBP-TF*j37TSst4qBCmbYrqa*H4S<=~x=xZlg4tcV0|Lo5qlNVpV(_MmoB; z_RwvcG1xoH2@A6xFK+xgyV35LTeBys)#@);5ALT~50CKsazyLy#?`mw$k&A6>Z@|3 zdfD!{kIRvWLwnmgZ=Jydx=vDMQJ0}si$~t>_E=PxRWYWqW?*BFI4M2P1k^WV4rLMc znPr$_#QsA(VwU$s$7jlsfMa8i>8V5dPM5#Oob~ax&%fKgZgc5dOpN1u{QDC5JIr$A z_=+#egHPSC{eO5FPR;WE`g6BxcGsBYCz>z*Si@H>^Q#@?7ryzay!VFVSHNtTZEZqJ zEvB2o7Q`Bt`R_H$;%5-w{ta*S;65?Sdm(-0$kPLt0Vj7{J8quIf=L>X{+sEw;cau4 z_c%2pKRdY~Ke+I_v!o%Ch1nf|x(9RVqlZV+*c8hL8mQy!fd(_ps?;mJ`(#PyJS+qo zXzL@pj%?fADv|3}rE_<$43kcFt|9i_s#NR1#nzkF+-B@VMP;jk;F4w-G&@E|;Chxb zo+;AoBrQ!$85FK(`9g^n#%MZE3x~&zk7K`*pdB?+j@HdJDL4&jdU!K6p3c>{C{j9)oh1X}s}Zcml>test>6-2-2-complexp.test ;; ;; Syntax: complexp object ;; ;; Function Description: True iff object is a complex number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group complexp-group :before (test-defun complexptest (object &optional (expected-value nil)) "See if complexp is true or not of an object, depending on the expected value; see if (typep object 'complex) <=> (complexp object); see if #c(a b) eql (complex a b)." (and (cond (expected-value (complexp object)) (t (null (complexp object))) ) ; cond (eq (complexp object) (typep object 'complex)) ;; #C(a b) is equivalent to (complex a b), for all numbers except floating-point, whose imagpart is 0.00 (see Steele p. 220). (cond ;; So test this for non-floating numbers ((and (numberp object) (not (floatp object))) (eql object (complex (realpart object)(imagpart object)))) ;; ... but give floats and non-numbers this one for free. (t t) ) ; cond ) ; and ) ; test-defun ;; (do-test complexp-with-complex-test (every #'(lambda (object) (complexptest object t)) (list #c(3 5) ; the simplest cases #C(3. 5.) #c(2/3 3/4) #c(12/3 77/11) #C(0 #5r12) ; zero real part is ok #C(0.00 #5r12) #C(3/4 3.77) ; mixed types get converted #C(27 44.99e12) #C(33e5 27/12) #c(#O-17/32 12) #c(#5r12 #4r22/31) #c(7.7777 3/2) #C(0 0.0) ; imaginary part can be zero if it's floating zero #C(3/22 0.00) #C(37e12 .00) (+ #C(3/4 22.4e4) pi) ; computed numbers (+ pi #C(3/4 22.4e4)) (- #C(50/2 35)) (* 3 #C(50/2 35)) (/ 27 #C(3 3)) (cadr (list 25 (* 3 #C(50/2 35)) 40 30 " ")) '#C(3. 5.) ; complex numbers evaluate to themselves '#C(33e5 27/12) (eval '#C(0 0.0)) (eval (cadr (list 25 (* 3 '#C(50/2 35)) 40 30 " "))) ) ; list ) ; every ) ; do-test complexp-with-complex-test ;; (do-test complexp-with-non-complex-test (every 'complexptest (list 0 (random most-positive-fixnum) ; integers -16/2 (realpart (complex 3 3.2)) (imagpart #c(3/2 3)) (- (random most-positive-fixnum)) '5 7.99 ; float (realpart #C(7.00 3.3)) (imagpart (complex 7.00 3.3)) 3/2 ; ratios #o-17/32 #c(37/22 0) ; fixed zero imaginary part yields just the real part #c(0 0) #c(3/4 0) "#c(3/4 0)" (make-symbol "#c(3/4 0)") ) ; list ) ; every ) ; do-test complexp-with-non-complex-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ef5b15fa3dccfd68e3b4c5a522bcc61de1e96a07 GIT binary patch literal 3288 zcmbtWU2Ggz6}~h39TUBanjg_^AvQ%4D>b14i1y5N5 zu6#|mY~%c_rq7Q&I@;|Vm|0l$iVbg3ao4>1V)40QWi+X1E34%S2B%JeePm*MeB!eY zk91FKPA0JS5p*6tIdO7)qzyH~SN=;kfE_I%BA&mNgRo zw%_bTENb2{Y`-}$rZj3RYQ;O}RVbY0I+GalFEu--^QP{mEz`duZAd--E6v`tspb%x zHe)ckvt@;>OMWx^ia!zPR4pjb>ZIKH>5ui z*os6dwIk^y^x*f)6*-PCoNJ>ndSFOi(;v`}?9tHw@`!A<+>x)h-RWw@|3QNI@j*1C zbG8z}Z15qzI}+dlg4DL1t?uoC1B_qjRu6NGX|jYrq5vg)Pm4$^k(Pa$IbfwS2CcJL zzHPRI$;x1`TFYSD1z0GH1%ecP`0xLnL^v=PheNxiekOPM-)bI7pn_9rDtmQSGgBGE zR;SWH%o!&kck(Vdif;txY9OI&u0E^UhMTu>E_89QqE5kajjSv~VlX&)ddASqd`_LV z?5vaEk}UnVwreGLEY!=pLNT1PzJy`hmaSTOHn!(%8RKC(z{lu7{t!xG<0&me%xhqx(-K-p%`3+_ciM3`mXI9-e@hifeLUzi^sO^qN^1lEc4f0FukGVqR^}wAiejjl! z2i(Pg*`2)~!e08-TP1rs^c$B2)TbuE`O%oJGmj!9v2;5J)L%ERcw)H@P?yO*WbTLh#~p&`~e~j zTpm%A3QN?P$43bLG|)q76Gsak85x5DBK&?V8N;@tZd83%vkChIWP4gNs$0m3dW!Og zFem*EbFr+2tQabe)-++igpIJ~T2wgF4PwY^Vy=UU>Q**uQAE;rq1@kg0x~X~5OP-` z7n(|wN0QG+iM$Yy=gF5;+R0@!-AJjfMRRpzrb}doV&}tzS-^%4WQ&HaOa%g`M0%u$ zL_Q=%5cW2-Vu99-ZRK-9l)WxQ*|k7sDNlVYbY`OQzcUcI3lUDu8(OGP|h7L{@}cy|!CE;`1z ze=!mXhh)(PhPT8{erD?=;*|%s5=6Q;C%%5TMkD4oBaN?=s~%2{+Fi_p3-pma)d3t{iK5O&*tH4N*L#)pYa1w`k=U{XP4 z{0)Bb0{=XJ8Yb9#(4cml>test>6-2-2-consp.test ;; ;; Syntax: consp object ;; ;; Function Description: Returns non-nil iff object is a cons (i.e. not an atom), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group consp-group :before (test-defun consptest (object &optional (expected-value nil)) "See if an consp is or isn't true of an object, depending on expected-value; see if object consp is true of object iff object isn't an atom; see if (consp object) <=> (typep object cons)." (and ;; Non-nil for true cases, NIL for others. (cond (expected-value (consp object)) (t (eq (consp object) nil)) ) ; cond ;; Test the equivalences in Steele's function description. (eq (typep object 'cons) (not (typep object 'atom))) (eq (consp object) (typep object 'cons)) ) ; and ) ; test-defun ;; (do-test consp-with-conses-test (every #'(lambda (object) (consptest object t)) (list '(nil) '(a b c) '(a b c . d) (cons 1 2) (list 1 2) (append '(1) '(2)) (nconc '(1) '(2)) ) ; list ) ; every ) ; do-test consp-with-conses-test ;; (do-test consp-with-non-conses-test (every 'consptest (list (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)) ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex 5.00 ; double-float (random most-positive-fixnum) ; fixnum (symbol-function 'atom) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword 37e5 ; long-float (list) ; nil () ; nil '() ; nil (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable 6.25 ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list ) ; every ) ; do-test-consp-with-non-conses-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3d4d31e4e03f6a814895f47a8322efd9a5a4dfaf GIT binary patch literal 2630 zcmbtWU2Gdg5Z*f{X?`5n4prK^e@jIF+^*I9wIxNum&-YEWBc5@bDF$>-1t(va%?Mh z3Z)_{RcH}dg`^_fLM!zF^{rBighXjekjf+C0SSbJct8Sy!~^9434~NLb7!X|AgDxQ zdv<1bzWru)X73hAOmlVll13n5h5Slcs5V5(2g6M)(aqnk6 z@E?wnm)gz}B8Gil5!u|z+#VHf=E;|LM#ZBW{63-SxJ~iBup^)KEUTVH)$_8W zUP2!jwiB{^y$c5LK~u)>cNB;Y#_;hU_J3G;Fbi5uL04xjI<|q9y$yQD*)@*|nVa^0 zpx#@EzOH)i60(pvuX;vB0o)d@Z#?R+5ojjFjjofMmv0C~G}a;!PS+!8MypR~L4jYj z!}$e@@TpsCta2_iAaB?RNB}+rjynEckNcK#DdM6WRv!*z!3xkjJRR%1{nl&Oc9 zuU3KQ2}gXPcIFykC0PEIG0ac@R)?yGy(X1@u8@qvB3yf;=_7CY~gKUGk1$k@NEPTUqF@&d4y?-k<_4= zWxE@i^aQB-$f$BbFASX3V zi9giNT)?@iZ;P?$V^m0>sR2^q8l2txn$U>^^Gf< zI?iM@7K3y~BYFbYeU8z|YGMM?CJhZ=;B07PKKH!}wt|4a)&Owc#dX-ZY z8NMEc$v2=F;~P-~xgQ1PTT%G=HW1`K_&4ZBG>n-1!7(Z1uI)`ew!O&>+nc-sA^CL0 zU_+{$j6q5yEP)rmx(=*irccBM)hMgqVdH?ic9rdE48T5|J{WoQgd#^IaDj}o#C9~r zBw15eFt&hcO?XgE#)lHfSv-UQ2~8c2qsAbeo1FWP9gP?xEDkxeb)8|k@^)O+$+x3u zg$uSRj%SNUE!^jOP}~AQ!5+QO@d6dDIN~*cZg-$pkc4AkT>tQXtM?K{?Y)FS2fWu2 zEqpH^lRMz;u6Yk@YBFKdBUfz~a@k%>E;!;PptbTenB%O(*%X-C!ZB$y8MhOXRK(7We<#L=QvY3dL5 z_L&Dzy8ul#AG$&aDn;uZ>ms)MRvBvAP@v@Nmx$dv(TJgFQdH+2SjKytJU+ww(6^(u zvwLOd#`!&g#UF4^m`^@;Z6A!tuk)d`o9^J~=lVMG(-K(|%EH~~C050sOHCh3r!e%@ zmjXBm_N4%nAqI8uup%3Ri!+!&#P8~Hkk9Nm_<;v3$xW*g92iufiWTQ^Zoi|HS2A8t z^_*Tyeh?w&tqO|sx@pqv6iwx6;n)dtvP`ojI+ZJ=%0&uqI{89*FHM_8GoQ}pkJCb) zn$H(um6>KIQ@L655G^_WyXrnR$Zo(((_Q6LMH65g+@1D{-E_t*&(7p&Ib+gNYTBeW zPVnRs*&)3ZYIH4R&tzV$$%V|B?4{Z`1P|?dUU)YAS0cq)B3&zqgvxB$p(gOUkfK(_ zql`o28_E!aYd5J7VH?~bO-^SJl65l6Mr-n*RoR)ynW>UV(}n!bGVo8EQ`x*p=OjGJ T6ty#r?@cml>test>6-2-2-floatp.test ;; ;; Syntax: floatp object ;; ;; Function Description: True iff object is a floating point number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group (floatp-group :before (test-defun floatptest (object &optional (expected-value nil)) "See if an object is floatp or not, depending on expected-value; see if (floatp object) and (typep object 'float) return the same value." (and (cond (expected-value (floatp object)) (t (null (floatp object))) ) ; cond (eq (floatp object) (typep object 'float)) ) ; and ) ; test-defun ) ; floatp-group ;; (do-test floatp-with-floats-test (let ((five 5.00)) (declare (special five)) (every #'(lambda (object) (floatptest object t)) (list pi five (sqrt 5) (sqrt (truncate five)) 17.02020e12 .6060e-12 (caddr (list "5.00" '(.005) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; let ) ; do-test floatp-with-floats-test ;; (do-test floatp-with-non-floats-test (let ((five 5)) (declare (special expected-value five)) (every 'floatptest (list '(5.00) "5.34e7" (list 5.14159) #\5 'five (random most-positive-fixnum) ; integers (- (random most-positive-fixnum)) five '5 (eval 'five) (truncate (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable)))) ;; 3/2 ; ratios -16/2 #o-17/32 #x11/eff #7r33/66 ) ; list ) ; every ) ; let ) ; do-test floatp-with-non-floats-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a4b52c1a1a65f34f67769dedb746252809ead5c5 GIT binary patch literal 2524 zcmb_eU1%It6uvV_H$R(fHd-rge;i`l=+eoWpVk@$nN02`+sw{P=cj2zkTp9okt7?E zO{sse6s1rGYFZlSs(n#>60t4#&{~NgKKdZ|3qnB<1Ydj*6kp;w_wH_DA~ayh4(Fcl z-1D7t?wNZs%Vft%-B9$>%-qy;Ft3yr%X5omWui2%ER+`K#{*>oaOGv)a_FnWnm*F? zM0c~h!7@G{6v{zS@fL%HV&TO@O84W6Ha9;t4U3~kK|Rvn*Vo^BxT`s#5nCK~+=B({!{Pg^f^)>bum5!uB4e zT$)p-gHypYmNTR!$=qf62msU^A)w&qOLhSIblO60~03$ja5*mgwi zfxoJcO|Go8oFzoQ(w>wtp-(4ojYv0U$q%26$fK!LyA*q#XL&s<&exEq6hPz~C&{bKG&`gfJI_3n|%R+Th<7fC;=lD5D(9KP!6ux1V#)KLd=fS5yWT8^_OxfPx!cpBk}!LtMIReM_3JbhSosOLLy zFLZvfV(ysh(Y!3fj-BG>=?2wI-&V7hlXufhlBKQQo|R_tx@Oi?mwD;kHdjAAD}0wGp4$5LIy?j5Zj635q2Mn6x#(t`ksT* zHyo6{6yR9_z9zsq0jdH_3vf3F$sg=~U?IOj>hZibLREJxKVV@w!9?1T(b! zz@VlYIoA_G)E>4UH@6Ay7$=kd6yob`F?4eV=_Y58t_j!ogm?uQlsn}h`~%_tjBv~g z(Fy*$H~EVeiS&hQQn)s7AM%$FKZC2B_xTQT8%`%Ciic{+cMO|DK87uA>+D00<=bL^ z#2Lv2L3M^5T!5|hPgBQY`zL@ao`o0GH+iFdmT|Dl$9>DA!)z}Fr5<0fCt0SOWja_U z#WL-9$Y-MPK`&S+D;-N(hcZ!s?}wr?H7ox0Berw^x83JQ;pUpMvt&X~Myt*!k72+_w- literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST new file mode 100644 index 00000000..95268732 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: functionp ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 26 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-functionp.test ;; ;; Syntax: functionp object ;; ;; Function Description: Returns non-nil iff object is suitable for applying to arguments, NIL otherwise. Always true of ;; - symbols ;; - lists whose car is 'lambda ;; - values returned by the FUNCTION special form ;; - values returned by COMPILE when the first argument to it is nil. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group functionp-group :before (progn (test-defun zero () 0) ) ; progn ;; (do-test functionp-with-symbols-test (every 'functionp (list (gensym) (gentemp) 'lambda 'mu (make-symbol (symbol-name (gensym)))) ) ) ; do-test functionp-with-symbols-test ;; (do-test functionp-with-lambda-lists-test (functionp '(lambda "lambda" 'lambda)) ) ; do-test functionp-with-lambda-lists-test ;; (do-test functionp-with-lambda-lists-test-1 (functionp '(lambda)) ) ;; (do-test functionp-with-lambda-lists-test-2 (functionp '(lambda 3 4 5)) ) ;; (do-test functionp-with-predefined-functions-test (every 'functionp '(zero cons)) ) ; do-test functionp-with-predefined-functions-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fa0a90555ba3e8f1b20eb41dc8dc7100c1f406b8 GIT binary patch literal 2647 zcmbtWU2NM_6ux$vu7AnWwHjU6k15(;GFR=kj;$N4uIsc}lQ^}Vc72+%#$7U{NtC36 zim^>o>4ao4x{2aDs00rP32A7XK-!?F6Y#(T4+Na^32Ma7_5?A# z-F>|fQ(0PMe0f61Bw0bxNQjTPh4sRB#r4{ROIq(j*RRfe^nMb2FIY66T9@^+?hI#M?Bt?-GUQTH7gcfkMKtM}Ch)wVoj!9fi zfYpV4o(E}*GXeS1eK$p)FUrJL-hy}6BCLe#U2`L z%Ak!0Tl;EnL_w8oHnbVd_0YSf?b4W}OzaEbTyXnr=cNQe?~Y(2Xc|AWsF3Lyn@ljcx%!{~jeE3X=t#IOKi&@Vnd zflyQs6}gsY6rgpX0XY#HjCaAh#mNWFPDon-sJCs;LP2&2baz~lhmae42)etiddKnO zVQrX?!4v2pDvxJNH=t)HeFnuQxJc_`cyiW3dgyLInI9o36U5a`+J@p9I$5|amz!CT8Pq{xZ5#gF`C1(EM8Z}NpLJ^@~}Yae)# zTNGK64{UJ_%*~;wFp`K_9YWJEIr|q8v2)wOjrn<=VNu?j z>kqHLhpX=|x!owgy)@UK*m`^J=v_ik|7I@n;`MG^eO>eY%89-^-wFnA1+B~T7b}&@ z1M7jlZLROS5dV1IWmUTVdM~Q)n+9Vo-h*Ma3NFp{ziXG8Gv79^;+?Wpgh|pQe$6CC z!kVNA5tTNB8|}6au1NP|-i}4Gu0I1;rH`0~KbxFBnM&fm*IpFRbjG?UpuB0+%LB(G zQDa;*2nNiDyxsZ0m{aYQvTh`i__Bq%> z+LrE-t#j2{2hU&Q4mpn3j}U~;pvJ2Gn;JL6eB rS<<;wKDV>X74?)pmC5PcIRQ^C$yx2i7pkLnNL$@M4~ASDtyKO71{dw6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST new file mode 100644 index 00000000..0d97222e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: integerp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Removed :5 keyword from last test;; ;; Filed As: {eris}cml>test>6-2-2-integerp.test ;; ;; Syntax: integerp object ;; ;; Function Description: True iff object is an integer, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group integerp-group :before (progn (test-setq five 5) (test-defun integerptest (object &optional (expected-value nil)) "See if (integerp object) <=> (typep object integer); see if (integerp object is true or false, depending on the expected value." (and (eq (integerp object) (typep object 'integer)) (cond (expected-value (integerp object)) (t (null (integerp object))) ) ; cond ) ; and ) ; test-defun ) ; progn ;; (do-test integerp-with-integers-test (every #'(lambda (object) (integerptest object t)) (list (random most-positive-fixnum) (- (random most-positive-fixnum)) five '5 (eval 'five) -15/3 (truncate 26/5) (truncate 5.0) ) ; list ) ; every ) ; do-test integerp-with-integers-test ;; (do-test integerp-with-non-integers-test (every 'integerptest (list ;; expressions that contain the numeral 5 but aren't equal to the integer 5. (float 5) '(5) "5" (list 5) #\5 'five 3/2 ; ratios -16/3 #o-17/32 #x11/eff #7r33/66 pi ; float 17.02020e12 #c(3.33 3/2) ; complex #c(5 5) (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; do-test integerp-with-non-integers-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..401a7c8cdc1eee844f835bd52d8147d601510baf GIT binary patch literal 3354 zcmbtXU2Ggz6}~h38}F z+1~p?z!h)Z?Mp5H6y9DbMY6CR4ANt%S>R*z0&NS%Im6~HgtDWxFGbouQvPBx|~C3 z%CyGB?v@p@F1XFeqw;b5X400OW7oF&FES=x9~u( z^YGS`Pro^^Z46vB1}^#Ro1}wbKV#cB4q|{0L8WNaXAm65_(W%-zi2*~1=nIo)t4p3 z2)OcH@cS=z4GEo>m?{N{|P9 z5Ebd1t%NY^e~9l5`M8fD#cijnJ3HV2<1cip`#Hw#NdQ6#6LVg;l~Bt#P46;MIS!Sx zSi7x8DwSb>sg||&`mj(YvE4~(C+lPM|IQv3pNYbm?b09DHu82ZZ^r_CQ0R*(dO`MZG7{+Z2p_n@(unFfzR*}BD4I{L>}P}6B$B^y1uR>hw5?S!(?5_SPgkKass0PE2pVx1z};6<=i2HvWjXN zoj5-SsB3D{$m_}65%?kgm<;4hV_GNfHEjCnIypO(`Z}5@h>YGO}IBdF2%0 zU&5U5KIS4>14+?joUAFreg_*t#WtvJgxka*&)%m03`|%xvRQ)y65fXLVA~1E*l@y= zqqqZ;Y4S*Ti;okz?30V+OEPWcGK#7tW!s>+7m%19FEJE5A0=!K*h9OLMMFPP{(QpA zj_{b54&kUr*t<}Q_)62Jk}^k!UGrtueewgi*twHed3>427Xd}4P}6zc+rvDM zn}9-3HdFl51seT&E%BBw^~;yno_zM)&({(OpTD`@O#(l4H*u>8f@g_e+_}HA zLvYjG48SANpk#HWQ3ca@387H@G9-~p5DACFG+c#Op%9H6_YI2WYV-3dnvjk9>s%FH zN6e&c%~UcLk3ft+;qSM_6QtXV9_)qIg8`*e5L*bl-$K|u_eVik7Zg59WYQ-p9|e>2 zE939*ix>Da{8^Y_A3~Ed!Tz?zx)NpFhJ(y)Mk~d0XBLXIoqMkXhzj0y07bVMHYR5@ z)fNIgjtR2!doM!%)C2$79k)3)F{z=2X#Vrid-FCrwbL$|RjXA-R3vQ8Z4$X_IgZpQ z6&q5eyxgcu1tR3~u`I^V1$G`T3bhPn&-Kn>XNk>TF*lv}M1MOvt)wXbXaZxHa$gTNW z)$_2rQmKrc-(t(kt>MH*=|cH-Y9nyf=s z;x-B1NpGarQe@)ZUcml>test>6-2-2-listp.test ;; ;; Syntax: listp object ;; ;; Function Description: Returns non-nil iff object is a cons (i.e. a cons or NIL), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group listp-group :before (test-defun listptest (object &optional (expected-value nil)) "See that listp is or is not true of object, depending on the expected value. See that (listp object) <=> (typep object 'list). See that listp is true of an object iff it is cons or null." (and ;; Non-nil for true cases, NIL for others. (cond (expected-value (listp object)) (t (eq (listp object) nil)) ) ; cond ;; Test the equivalences in Steele's function description. (eq (typep object 'list) (listp object)) (eq (listp object) (typep object '(or cons null))) ) ; and ) ; test-defun ;; (do-test listp-with-lists-test (every #'(lambda (object) (listptest object t)) (list '(nil) '(a b c) '(a b c . d) (cons 1 2) (list 1 2) (append '(1) '(2)) (nconc '(1) '(2)) (list) () '() (eq 1 2) ) ; list ) ; every ) ; do-test listp-with-lists-test ;; (do-test listp-with-non-lists-test (every 'listptest (list (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)) ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex 5.00 ; double-float (random most-positive-fixnum) ; fixnum (symbol-function 'atom) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword 37e5 ; long-float 3.1415926535897932384d0 ; number (car (list-all-packages)) ; package (pathname nil) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable 6.25 ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list ) ; every ) ; do-test listp-with-non-lists-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6b1face373b6b615ecd6e96eeec7aab6c1320486 GIT binary patch literal 2027 zcmb_dOKclO7@l<=b>athTS4lk?JBAjWU@vnX%qrd*=)v%Hdstsy^B?_*@+2KD(P6Laadu zSt8p=`Ur`UF5=yGV=0T8mXyh=RMO-;O?m5{8-!XU+oXo)#xIEN#)?#Pt~fO;XSqcL zLcGu2V8+%IE30eX9pRb~_HMb6tR@wpG?=z`})#-$7JXtt`7&5h7?LWGC$ zSO9bRvGOP>|1GlzQqzd{|3^KdUt zBpwSvm?|3iA2K}P{}2&?=MvD=?MjRULNGE>x=^5sMW?09vTD=)fx%ZDh zl(-&2JU2FaWWvK;gs^TL>k~Mq-vdxLg;G)Y283QrK(194H!<^r zMkumL{je;G<}x&@KS?iBV^K1pGb%-Gn!SMJB{qO$kevcT{$dFvPq>Zz#BJohZ~F{j z;wH7EX@1S2aGLaL*i+u(_t<&V>Hrf&A4KujzX+<+N0BkmQ>bwtHOOJe-#+=1B>|K? z280Mlm@#y_z+uU^+<|QRD{uPbBdBTrh+AXH7E6{v70Tr0oUQTVZI(2!@;7bWqOkZF6XF095IJ71YiRB_(1tqas_fK)utzmY;Tb|ohuhx)V zxN+%^-+xBV#6d)6-22MAgWKV(Vo=$l(vjIxvlcaE)nrjv#!`M4&a)BlCBJZA_VR&+ zYcml>test>6-2-2-null.test ;; ;; Syntax: null object ;; ;; Function Description: Returns non-nil iff object is NIL (the empty list), and NIL otherwise. Equivalent to the predicate not. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group null-group :before (test-defun nulltest (object) "True cases of NULL return non-nil, others NIL." (cond ((not (null expected-value)) (not (null (consp object)))) (t (eq nil (consp object))) ) ; cond ;; For null or non-null object, test the equivalencies in Steele's function description. (and (eq (null object) (typep object 'null)) (eq (null object) (eq object '())) (eq (null object) (not object)) (eq (typep object 'null) (eq object '())) ;; See that (null object) has the expected truth value. (eq (null object) expected-value) ) ; AND ) ; test-defun ;; (do-test null-test-with-null-objects (let ((expected-value t)) (declare (special expected-value)) (every 'nulltest (list nil '() (not t) nil) ) ; every ) ; let ) ; do-test (do-test null-test-with-non-null-objects (let ((expected-value nil)) (declare (special expected-value)) (every 'nulltest (list t '(nil) (not nil) (sqrt pi) "nil") ) ; every ) ; let ) ; do-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..83aa69b5084b2b640574742e326ec20f9e580d6b GIT binary patch literal 2394 zcmbtWO>7%Q6rNqjZsNqQ-9#ld{aFR|$8I-m+NLTgg045?#EreX-CZa30U?t(*vN?^ z$0@3SP*rUzq*aSs5q1haa6ljss1z=RLJmD4^}q#z1QG`XQg21#&;ycrZ+G+4fS?k| z+Hc-B^S<{p^Jd*3{!?;BkgHQO-c@aHzjGn39Z)%k~I1 z{e1)d2YZ9f>x*2ZN(dPzODNh1i4Y&LuUL_UNexp>r887iq%2L?4clskT*RC~b=!&_ z6zbI(u~Ix;tYA7*vxFnWe#2@_SOB9bsGwE+ z&bJlO>1Gpxc+nN#jm0W{AO{5JrXJw;@@ExC1T+*CAAVzbz(2$WZlMCGula+iN6ujL zKV^VEyzu$HM#5yH3GZ(3UuvZ@TG@$iYmk}{Z~ zx|mD@q6`@czLmA{0r>dgbVn1iWXi*$PR*PSr&D&0cfiOSCe89Ztmtyjznr0xlGDVL zs%MP^<9P1x)~1?Z?Yfi4=1RutGcM>Of6?7d>vrWk&u+U=-^1=3j)@XN{`Z& zrowixtw`UxrV6zX!dkGCV%QgZfxm^0N*PqPgA%~FBoo!gF)%r&>r`3Owv59$jG=3_ zHnL<;HyYLs)7-C6yWmbbO7*;GK(R6u(T~_;C_Z4_C>YylxXC$ zNi`!bUnyu|0nf&D_$>N$%3Fd_*wCn)mcR^(BWihsvXZQ;D?BFw+K@`BIb~4mg>i?+ z2bImyZ2$z^xgK!H?*iSg>FSVzS~rw(n|ED_V`+0(RN%C^fFa^GvQ4;-V*&{70o;fI z1vd%zjJwD7p!kV(qWA{5+C8onOYS{Dw><2@xgFQAbC+E93ohMhSEL|NZZ8rag%Pi% zaVR*h$S*(|TqYgT)tu&pN$xsC+aM7*5qVP zHR&sC#~DysaJyz$yvX9CEUvKlQvilmZTGUyJ#7C@*4g7NJ{e=3c)s{9+uC6kXX`@G zywoF17T|R_A(W@xHyL8{J28(RF7>1M*0wlja2J}wkH}~C+xAuL*zGc$MU#r_&Uq$n zQeDaztR0rI{chpjWrxsKUEp|>>GQ|a8-K)6^5XslpMyPpKKIhc2M{~#tvav}1vT76 zY~RAUX0!Rb(+s;ji_jw3aJ&rHT7=kEtWubIexiVxtZ!;4Bj+?Vq+nYCHF<){Cg)>u zm;i3_hm#RIvKlY>*|vHIk`xX!bzip5FNpd|*_P`yZ+I2#MWPQEN#gjSNTYnV1`Xw(U|iyl8+ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST new file mode 100644 index 00000000..f5b85dc7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: numberp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 September 86 ;; ;; Last Update: Feb 4, 1987 - Jim Blum - removed :5 keyword from last test ;; ;; Filed As: {eris}cml>test>6-2-2-numberp.test ;; ;; Syntax: numberp object ;; ;; Function Description: True iff object is any type of number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group numberp-group :before (progn (test-setq five 5) (test-defun numberptest (object &optional (expected-value nil)) (and (eq (numberp object) (typep object 'number)) ;; Non-nil for true cases, NIL for others. (cond (expected-value (numberp object)) (t (null (numberp object))) ) ; cond ) ; and ) ; test-defun ) ; progn ;; ;; Returns NIL for true cases 18 September. See AR 6493. (do-test numberp-with-numbers-test (every #'(lambda (object) (numberptest object t)) (list (random most-positive-fixnum) ; integers (- (random most-positive-fixnum)) five '5 (eval '|FIVE|) 3/2 ; ratios -16/2 #o-17/32 #x11/eff #7r33/66 (eval 'pi) ; float 17.02020e12 #c(47 3/2) ; complex (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; do-test numberp-with-numbers-test ;; (do-test numberp-with-non-numbers-test (every 'numberptest (list '(5) "5" (list 5) #\5 'five ) ; list ) ; every ) ; do-test numberp-with-non-numbers-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a8c62651ec87abdeb551123136c15bafc9857551 GIT binary patch literal 2745 zcmb^zTWl0n^v-T+yWO&E5mClcujRdAs)a&oL1j9<+b%mhv(C)Y_QRN^J7rgw?xwpX zAhAKB=*LDZ#AdG27)>;O8Q{ZMg_MNEPyhV&%NUIx;)jWeiFnT3-BMa&OeEdune%?! zbI#m3vTjV%sa85!E)?BqTAHbrXR36vG)*g|ndu3aP6C~t)l7@MKB8*LoLS z^HQ`#2$>*D2ttHJNsxG#YSEa(Y)6SFbfy?;ip9J+uht5=C>fhsUaeyvt(MA4(LLoB zF`bhYA`#-fS8I)D49!WHhId&yC$)PQYwHt+l7`gOVMYS2bt`CH@@kQT%0Bq3v(sc@ zzWqEQfqX|afbo2jzmb#{r^rt?lY!C4XRt|w&a zYB#*V4@r4h76{}A@9>k4%3s&+aRI9%s48SpF$`GY2H+ddw>%={7kz(#-kH-cnvvUt z%;n!UBgudSYI9e&jLP)@S_x@K)rrofYtkho)-#cY8=15s734tkKRej`AO|b0f84Mh z8tp1POv{0;hUN7TGgJWn!%x%`s)WuK1OaG>oy$M8v;wCa&cnjR|FaCyAC)1>rF@hG z!ruF}&X{HzLkVnJWkfZGbY>}o37{Cmb}X=-hXNsZTH$GiXB|vOM@&;4ZA7t{ld+(? zHGe#s?Qz>-sXzcEHi`Msbfy}av=TS1lpW(zKw7Kqm@ys>w)0T14W=a$W0qxFikWfJ z87CHufI@prHO3X6jz)qTKrR%k4^7OgMSE8bV|x=Jya^|8Cyvu`kZ)qgR2`8FAk7$$ z>L6-iKw8GKn6YBqxr96o6S-F#O|_Ybf`^gaiJ>({7YBNIM<9X{TfkR`o`6N7>Uv|! zZQw|M@kbH-$u}eTg+GSi7MBs+0Il|vnq&%e~P2FEeNc$2~8D<8M5xp+d zzu=vSea^Qc_>^}c_(Xs!0?Z2UXNC8o@Xmz#cENi}@HYB9@+-7S+YWY&S>uWgeW5cj zN`B@~Ah_*okXyb6xh6E;0gVouIm(c!Wl~UF75nQopl$+cT&bth*p_3E%7#_67l5|T zKlMI%i`Z$VB~;z-B_+KBNhwvcOr>FCE09{^gJ#AUN_RtGftS!g+A@a?#7sD@ZH?nn zMib76;vbC}Z`9dV@Zk6slNI@3e;;BT&@{3 zNNA^-#)YBka7kigF#0%Ku);Hp1j8WEQg6`~o(k|3d~?N#%E>zH_iDS+MK@bcml>test>6-2-2-packagep.test ;; ;; Syntax: packagep object ;; ;; Function Description: Returns non-nil iff object is a package, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group packagep-group :before (test-defun packageptest (object &optional (expected-value nil)) "See if (packagep object) <=> (typep object 'package); see if the predicate is true or false, depending on the value of expected-value." (let ((val (packagep object))) (and ;; Packagep is equivalent to typep...'package (eq (packagep object) (typep object 'package)) (cond (expected-value val) (t (null val)) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test packagep-with-list-all-packages-test (every #'(lambda (object) (packageptest object t)) (list-all-packages) ) ) ; do-test packagep-with-list-all-packages-test ;; The current package (do-test packagep-with-current-package-test (packageptest *package* t) ) ; do-test packagep-with-current-package-test ;; An invented package (do-test packagep-with-invented-packages-test (and (packageptest (make-package (gensym) :nicknames (list (gensym) (symbol-name (gensym)))) t) (packageptest (make-package (symbol-name (gensym))) t) ) ; and ) ; do-test packagep-with-invented-packages-test ;; ;; A list of packages is not a package (do-test packagep-with-list-of-packages-test (packageptest (list-all-packages)) ) ; do-test packagep-with-list-of-packages-test ) ; do-test group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e05a37963df31f50c4706f710f5a9e8934a1e41a GIT binary patch literal 2772 zcmbtWUu;uV7(e%R-T!qRTM#P9VFU&pcVWOL4wT*9-EQ65-g58lVDZ6}?T(goZPRur zK_>wm(OktsSnfedd^6EVaES>Zx~TEN2NQkJ7)^ZAM-xa$<;yxyYsFaz_CR0X^X66dnxdNTZ3nirHK;1%m?zKk@IEekSs*RuzA@h& z6U>+jDrhP9lyAA56L929o@K>zS@FE#sPAJi3|k0UzS#)__>}V<e{%(ZF@dY?-fIr6wfz=6cZN}&p6LPTJh$_qwC8A>IrGa)Ts^2pK|?ZtgQZn z%IfRUnl6=q(n&}Bbkvt}12|YxJJCD)5PvIQtV!h$rh8&m>mS7mLCci*!3w1Yn7lGu z%AN4xc$I0DnsT9njDQIg1=b52vBL0w^Mh%}d{BtxgqQFQ)>U(pUs58&LF_GIRE!LV zWK|dnf+aGd`T2U*z}Ldp4ej3Mmqc9}6;xS|snD*H-S4&9q^8SZo`;AI=RimyS&YP@ zLO@Z&nxAnz_up(?@v|mZ3u|ySLHm3BvZ^Yopv3fOO!vE*A)(nXMkWQ@jv%f^u+;>D z6LR&G;rXykZ||B@)>1hk z;OkhajU;Na!-h41n|lDYYuqkR$m*n^L9s$ITK~YsNJ?}Psw58U;*ewh9n5Yq8VyZi z(A(@O6mPK&D9*5rD0GHwxn8y&#SY}D!geTORJX9rAjsc#B6(mZl0WT4auXkBB^BTc*F2^e{_s4N9VNP~I_(MdFg zMM+hvI7h%#7Z_4vk>O|$jGN1NQ0$nz84R_KZyQX=_kr$?s>(Rk`q z$Pz=QbX19wv(ERM$_cAe1mrsG<`VjYPoy8J4mr$MQ~eay0MgLO}^?g;BX1jd$? z+-}yslkM5g+B?g^M|`Xu8;jp&nOk%tU!a}yVke!6!?SdnCezMi5N-3@A&mQZf#XsB zaA7dm`WueEyXbbK{PsfZ$7+>Arn7`WIX_#SM$3ZZHW~ zp_f>uFBP9XJ{`vu^{%-Hpq!k25db;MtW}1_WJ%{-tQ#DN&D&hrvnx!*c^?g zVfh8)1in0hMs45~P&+A`Gp3VM@Saq`!qAy`Di5I3M%GAAC(|crCjE%n?KOV1NQ}XK zw3s}bxHVcFJwFH!>A_q0dplSRE{r;^drODKrLMJcOYInkXg)grO@#WJCvyNdSsa%`50VWx;!k{_YiTv2mx;U)E;7E{cNm*jd|FZ-2>#h zv-#bxmu1Q_yP_#0o;T=pCf!w_P&Q*GnKtOWh&>jkb~E7H++ioBz2@I-M6Ri&(my>h B9diHx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST new file mode 100644 index 00000000..eecb783b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: rationalp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Jim Blum - removed :5 keyword from last test ;; ;; Filed As: {eris}cml>test>6-2-2-rationalp.test ;; ;; Syntax: rationalp object ;; ;; Function Description: True iff object is any type of number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group rationalp-group :before (progn (test-setq five 5) (test-defun rationalptest (object &optional (expected-value nil)) "See that (rationalp object) <=> (typep object 'rational); see that, if the expected value is true, the object is either an integer or a ratio; see that the predicate is true or false, depending on the expected value." (and (eq (rationalp object) (typep object 'rational)) (cond (expected-value (and (rationalp object) (or (typep object 'ratio) (integerp object)) ) ) (t (null (rationalp object))) ) ; cond ) ; and ) ; test-defun ) ; progn ;; (do-test rationalp-with-rationals-test (every #'(lambda (object) (rationalptest object t)) (list (random most-positive-fixnum) ; integers (- (random most-positive-fixnum)) five '5 (eval 'five) #7r55 3/2 ; ratios -16/2 #o-17/32 #x11/eff #7r33/66 ) ; list ) ; every ) ; do-test rationalp-with-rationals-test ;; (do-test rationalp-with-non-rationals-test (every 'rationalptest (list '(5) "5" (list 5) #\5 'five pi ; float 17.02020e12 #c(5 5) ; complex (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; do-test rationalp-with-non-rationals-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6b0dba36ae36565565d87ad2adf81f403812c85f GIT binary patch literal 4854 zcmb_gdu&_f760zNj`L0v8p`SgxU`f|uQwznEu{t4o15#zjqU5&*KH&1<;FL)+Z#Kx zooWTGlnT0*T7@($+^^7S(-7K2h?YIeV`1tZ+B9v_g!cMpo5ZI5!6v4mX=u{AbG~CI zSrZV_D*O6;=X~e!JKuM{$Mr00*l$Etqc}C4cb$@2oT*IDRMg30Ni7#=N)wJc33Bxz z!%CW;9o3DozMTUtsbxJAB_~sHvZ_7fl(U(mThxJjReidYccHO;JFwe!3=ZzNduv}y zSWiXC+Xt}O8rm^nukHobEq^6IU zOm3=qLGO}RUB68W!6y}oB_PmH#MbtjhHWLa1iLWba)L46i(Q>ELVG3m>X>x7!2bN& zn7pqi&?Wf~3cN3ciGH$U!Rk0?bv#DwvuFd&cE%PiZh!`SQIrb=h=Ek04d1}-z{}O8 zUf^mBnvyOWwgQ)b75E!YG~OuXE{k};zC9a#!s@uf*lg}|R>znuf!XZE_4{tA0cc{Z z4NWK1g-gnBQCQ1FI$6)838nR?AiYCDA>d*gB)OIb#@se&9j1Qd(Fo#U7J&dXJ}|y@ ztKnM)PL9;UHA6JF9e-LWF5p@MAbN<+3xKFe-$U2(AkMWk*1VC9+XVCw3a@_(%5C)& z5EJI+hM;j6@Yly0=H{>~yNc^`8(hEJD9|21^se5P;e! zuK)xHu4kS47V6S0{p_aHb4J2Ac(RXi)JC$$>bLA z^VOc9Va10dxD9HfdVDx)CSh{}Nqi&~l-qc-+zL-SJk9Vl!Q+Rg0ruUlprPBwsFpPC zbQ1PWLu|bM)OgA^W3mhy-Lx|sQB#kn6I$3x#!^8p$PNeOi(g_A_K|MaM2{}6Ps+|MZ?CTv0W88uUj;`#bFUsn=2>9;2tc=y z<%qyYCzED;*~!5r?0X!MFAa*Jr%VdVTd{ir2CZe2xz|jN!(k8~iJB-K2mh@xeazHS zCerbu%)IIZPiCm}O5 z+r@j3>=f4We}uLCZ(%LJC9LHi3Tyc?seDTq$S)B25(&RRqBDf zd92*Hox4qMR*GD~Da zc#%FOyhwY|G*PgbVh%aKSDK7wi;NNLR|VwPDLh z$6&5?TwM=>v>T-1T7_u!+sA$gwWd}kb=gNj)*xzq5Lz9nglR968;g?z+GqCDjJkVEFHBY+HeG7q+q;ZxWrnbyo3YgZz37xPXfL2 zD)r;8DF~;0AMhzq1K9o^??>`Yz7@$O;=abQGL)0=Ke}QhmZK;V zib)E;kB9*%*3?ndMhczZ%?FY6^Sh8}6u3tOmj4BTSG$nXc*J2xU%I9)10erV0FZwp zBFjG^a*_8z1ofbpXT>q&yxb0 z{5UAIE!o=^_C3sZB8idaFrilg{os4fCZb=_xjczxN`eXW(%*^vUL+y?j>xaYY)Nm3 zu+mTY4gewji2ANj-|N)(Z4!QigcnKpJQ;kMgkL1#)5JX`vX#yfcZRr=B2DQLk)QN& z$gh7z3RX3nCIbOXLx#|HXHtV?0#mp-EiZVK}JLak1H?c_;~@hCOM^Hb?pG zCNMtS!fdDiYK;#iJGV9(K`Dc%ZdTo+0BByNDM@?*FNcym5@ z)x%R=c^Nb$AGTgtY&|91b92d9IYGwZvtqe#0|#dZ&i2D+08M)V-NxWRf4|^1dR1S& zeXCb(98mk=Bf9)6Jj?G0&+?o%r@$b|7LHr<;yEamx4hpw)gZ}=H`jpU7>&S-Cvc|} z`t>#V0fcOOrx?-^REF#@J-KgXz#b7$I=rGs8mFF{y)$jz={Crb_rnlC$d)v0og;Br z_e0~hDe)c0Z}e}m+@{>o^N-k4T?=0u1rd>xnkgsS*oQX=Yq)n^E1BalwS-tQ62h=+& zN2i^-NbOyrzFCCM6pq%ccB*B^A>WmpqfVEcY<>d%5>fMIwNjdKRQM}JM9x=w%Ye=; zJ6qJOGwl?zQ15E70KJatd}bODz~VTPac7)mJ~QeH1n4;fhK`oaPdSBhzF5e(YNk}e zzh5$iEQKo;+@m#Hl@cwhpPtFMFcN)7=2`D9cpv!gDE_|v(t3S%^wH7T-0}Q*eg3eJ zb>=&B@Ol54ghG^SGpQ`jBv$wxRswH7dep0SnET-#V?%Ypr95paJ<#7S&S(wpxnoVh zu3crHk~z*GK6zTGp|Kj>?p1peu9GP{YPMMDt*9{K&SbvesK<0Hw~Q+40{`>z{ck0) L^XTvN)vNynU3npF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.TEST new file mode 100644 index 00000000..9b23529a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: simple-bit-vector-p ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-simple-bit-vector-p.test ;; ;; Syntax: simple-bit-vector-p object ;; ;; Function Description: Returns non-nil iff object is a simple bit-vector (a one-dimensional array of element-type 'bit, not displaced or adjustable, and without a fill-pointer), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group simple-bit-vector-p-group :before (test-defun simple-bit-vector-ptest (object &optional (expected-value nil)) "Verify that (simple-bit-vector-p object) <=> (typep object 'simple-bit-vector) for any object; see that the predicate is true or that it's false, depending on the expected value; see that a simple-bit-vector is a one-dimensional array, and that only simple vectors qualify." (let ((val (simple-bit-vector-p object))) (and ;; Test equivalence of simple-bit-vector-p to typep...'simple-bit-vector. (eq val (typep object 'simple-bit-vector)) (cond (expected-value val) (t (null val)) ) ; cond ;; Vectors are one-dimensional arrays. (cond ;; The caller had better not pass anything but an array when expected-value is non-nil. (expected-value (eq 1 (array-rank object))) ;; Non-arrays are moot. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test simple-bit-vector-p-with-simple-bit-vectors-test (every #'(lambda (object) (simple-bit-vector-ptest object t)) (list #*1000010101101111111 ; quoted or not '#*1000010101101111111 (make-array 500 :element-type 'bit) (make-array 500 :element-type 'bit :adjustable nil) (bit-andc2 (make-array 12 :initial-element 1 :element-type 'bit) #*000100101110) ) ; list ) ; every ) ; do-test simple-bit-vector-p-with-simple-bit-vectors-test ;; (do-test simple-bit-vector-p-with-non-simple-bit-vectors-test (every 'simple-bit-vector-ptest (list (make-array 10 :displaced-to (make-array 11 :element-type 'bit) :element-type 'bit) (make-array 10 :initial-element 'bit :adjustable t) (make-array 10 :initial-element 'bit :fill-pointer 0) (make-array 10 :initial-element 'bit :fill-pointer 0 :adjustable nil) (make-array 10 :initial-element 'bit :fill-pointer 8 :fill-pointer 0) ) ; list ) ; every ) ; do-test simple-bit-vector-p-with-non-simple-bit-vectors-test ;; (do-test simple-bit-vector-p-with-non-bit-vectors-test (every 'simple-bit-vector-ptest (list ;; Vectors containing only bits are not neccessarily bit-vectors. '#(1 0 0 1 1) (make-array 50 :initial-element 1) '#() '#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6)) (vector) (vector 1 2 3 4 5 6 7) (make-array (list 7)) (make-array (+ 10 (random 100)) :displaced-to (make-array (+ 100 (random 100)) :displaced-to (make-array 300 :element-type '(or readtable string-char) :initial-element (copy-readtable) ) ) :adjustable t :displaced-index-offset (random 10) :fill-pointer (random 5) ) ; make-array ) ; list ) ; every ) ; do-test simple-bit-vector-p-with-non-bit-vectors-test ;; (do-test simple-bit-vector-p-with-strings-test ;; No string is a bit-vector (every 'simple-bit-vector-ptest (list "1 0 0 1" "1001" "#*1001" (make-array 4 :element-type 'string-char :initial-contents '(#\1 #\0 #\0 #\1)) (make-string (random 10) :initial-element #\0) ) ; list ) ; every ) ; do-test simple-bit-vector-p-with-strings-test ;; (do-test simple-bit-vector-p-with-multi-dimensional-arrays-test ;; Multi-dimensional arrays don't qualify. (every 'simple-bit-vector-ptest (list (make-array '(1 4) :element-type 'bit) (make-array '(1 4) :element-type 'bit :initial-contents '((1 0 0 1))) ) ; list ) ; every ) ; do-test simple-bit-vector-p-with-multi-dimensional-arrays-test ;; ;; Symbols aren't strings, so a fortiori they aren't vectors. (do-test simple-bit-vector-p-with-symbols-test (every 'simple-bit-vector-ptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20))) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test simple-bit-vector-p-with-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f0d741f4a0578ec89de5d44cbd2958c74549be14 GIT binary patch literal 3698 zcmcInZ)_Y#6`$R+&;KuW>X^g{Wb4LtbM^YL^QWm3gxBk}@9ewXWp}TMkx+ZNTgOYz zch|dfL_sm3Dr%8VTU7J5N|E?L)mp05lonSCLPA0n5&{GgpFkqtD11OjAk2F+ zYxm+rs1gw0=FR)f%zMB0=FQCRI%&P2rX{t!Qt^szRVuI6E30*Bsa%z6<<)B5m6iaP zzM&eHb~UM}3u9-;JME^PeAUg>-Gbz-y0t>?nNex{aY?CEy&^QuoB{RphdJ9ft_!_oLP(x$q39r_mqbYLQlmHSXtpEIrqY_MD;X^wtOt#D zh(*rYniVwqCZu|~A{X5&ZV|&-sS$yY;Jc0X*{rTQDMJr7glj@~@M5DUrOPISrp#$X zY!9uVbs=aRI4w`WpPkB>;K+8Yls+e$L330Yr$-iR%T0!&+f>(KeZkU%>j-8eOW zWb18l5y3DL;f0+@+7ZR46uASm;Kv&w5Ab}M^MF>dKSVjw*&0GzMI#7dSnv<1d}_u6 z_hZ~dSA1}XZU^`(ev><1m1 zEJSOlc8DGDw8ImHrxo^kUtCojH7Q$~leJ*4s%*1I?M2(s zGNK40`uS;~rZq*+n)0k+W$ZW=MB(1qjuEF_k#5=%>4d!>i))r;ShA6I%&ZfS#9%^q zT+tV0hNF?7(L289Ea{FALR;_v8OLMbI2dZto>0=L904VY1QZ9=L&!kQT9&3aomN!9 zz8+-$NitN$*0@`Wr;GRpNLJ^t_Jn3F!U3eur8Puqva4^HWF$o_r^TLn0_#qcR z;9`~85vtryp4&Ocq7o+fkfU65b0K0_JXCgE0~zvndIZH^=}{Da=Gtv$nS97Bled{= z@&YjIvo%MaG1P1Z5}{zBejU($KxgGJUptq`1#q@+5B5dCT3Pv=gjUQpH8rKASy9U7 zFhUtcwG4U3#%BR)o1HeY`iwaR{36HDfN2?XI%)$@C6Dg8faLQjCn@W&gTgC`)q*YK zt+jg*q5=lQZTb+3zrp1f)v++y>i>y8is zds8~>TZjdU)`3nNNB;!)J+Ox#x~9jm_jTxfa8EC1&$Grk^ReIIM6YpXPjg{_-+eoN zLsDpX4oSlGpO#G{1#B4e89Iu63YAeLAhsxv4b@SaK+z72M(@jr<+J&wZz3oBg^?5P zFjm5Exxl3KC^Pd}+fk<3{uF-7Cs#f0X~IyIJn8dn_PQ?Yp-D-Gb!6lE2=gl zI|fd8g%1h%kPXIMCl_YW-5yaI_>H(m-j!O?Qqa#%W@RCI)E&PrAtdpmEf3YjtU8O&OAwa`1{;kh~Iq zyF_el7>0?z3^v3lp0wi6gN>+P^Xq=q_xzH739&bWSD+ta`J8HLilbpshu0E2iPI@4 zDkW{xE*M77^4ffregWrNeh$T%pb@Rrt6qs29AF0NRMYSlHe9%RPmge!_sGFUzyEoE z+@J7I_$U2S{%QX)|BU~*pYt#JdB5PhzT!{&sz2l7E)@Fxt02g~{9`EYH2WuiyiVGt zJh-rXNzfQ9=2k8ia+sC9w--zl*zE-u7#J|7=QY(4A~XRVX!WCe*pgd8V{CF-gKJIW zFVpM`p}xBWJGo!8!_~k7BhLj56d&5ID|t&&ec6>NRkz^f;fq1?YLff(s&^$rNRORg_p^EMM9G#tvq%I3gj9JT#2y!c=P*JHWYgNOh9=e2=v z6fsN;pAB3GsM6Cl*2pML%K|-5g}TP%e$sC0J5- b$t$_inu6t)lUQBgH&@Hul|){?w7var<$nXr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST new file mode 100644 index 00000000..f19c3720 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: simple-string-p ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 21 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-simple-string-p.test ;; ;; Syntax: simple-string-p object ;; ;; Function Description: Returns non-nil iff object is a string (a one-dimensional simple array [i.e. not displaced or adjustable, and without a fill-pointer] of type string-char), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group simple-string-p-group :before (test-defun simple-string-ptest (object &optional (expected-value nil)) "See if the predicate is equivalent to (typep object 'simple-string); see if it's true or false of object, depending on expected-value; see if the object and its content are of the right types." (let ((val (simple-string-p object))) (and ;; Test equivalence of simple-string-p to typep...'simple-string. (eq val (typep object 'simple-string)) (cond (expected-value val) (t (null val)) ) ; cond ;; Strings are one-dimensional arrays of type string-char. (eq val (typep object '(array string-char (*)))) ;; Strings are vectors of type string-char. (eq val (typep object '(vector string-char))) ;; If the object is an array, see if it's the right kind of array. (cond (expected-value (and (= 1 (array-rank object)) ;; The type must at least be consistent with 'string-char. (subtypep 'string-char (array-element-type object)) ) ; and ) ;; Other objects get this for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test simple-string-p-with-simple-strings-test (every #'(lambda (object) (simple-string-ptest object t)) (list "string" ;; symbol-name does not return a simple string ;; (symbol-name 'string) ;; (symbol-name (gensym)) ;; (symbol-name (gentemp)) ;; (symbol-name (make-symbol "string")) (make-string (random 1000)) (make-string (random 1000) :initial-element #\$) (make-array 1 :element-type 'string-char) (make-array 20 :initial-element #\} :element-type 'string-char) (make-array 20 :element-type 'string-char :initial-contents '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\A #\B #\C #\D #\E)) ) ; list ) ; every ) ; do-test simple-string-p-with-simple-strings-test ;; ;; Non-simple strings don't qualify. ;; Should be notany here (do-test simple-string-p-with-non-simple-strings-test (notany 'simple-string-ptest (list (make-array (- array-rank-limit 1) :element-type 'string-char :displaced-to (make-array (- array-rank-limit 1) :element-type 'string-char)) (make-array (- array-rank-limit 1) :element-type 'string-char :fill-pointer 10) (make-array (- array-rank-limit 1) :element-type 'string-char :adjustable t) ) ; list ) ; notany ) ; do-test simple-string-p-with-non-simple-strings-test ;; ;; Symbols aren't strings, so a fortiori they aren't simple-strings. (do-test simple-string-p-with-symbols-test (every 'simple-string-ptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20) :initial-element #\a)) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test simple-string-p-with-symbols-test ;; ;; Only one-dimensional string-char arrays are simple strings. (do-test simple-string-p-with-non-string-arrays-test (every 'simple-string-ptest (list (make-array 6 :initial-contents '(#\s #\t #\r #\i #\n #\g)) (make-array '(6 1) :element-type 'string-char) ) ; list ) ; every ) ; do-test simple-string-p-with-non-string-arrays-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..07646e2833b77521fc0ddb361b0dd21ad1911232 GIT binary patch literal 3693 zcmb_fZ){sv6~FH}cAPkIo&KYE9es2wSxukUv|X3BTelbcC2{lYXWn~m8$N)%_@!~@ z*p}^7D~QmQA&TZP(rVFrY}LMvZ)l4&X&tLFX?#FJAU>cWG$as0Fa**jJ|K`l;dkz} zvm~uxADZ~RbI&>Vp7T5Ro_p?nODuRkWhklIe7#(88%k}VRbOZ+v$clOtSvNVTxAw= zMn}OOKY8rf$)k@X z`^Pog5Y|4$m`9GDJUW`}U%R<1#cGVP8MaEKkFgjFFzE=R617Dx}pWP(LQ0b`zE1^nne=lRzz=wcY3BpYo54uQrsCT6V1vNw% zh@w9TY42Q|1`KlbuR2|*8z0lPLkxAN;5&Z+{i$QyeYe=iW+yP&=mypY&|NUptO60{ zaieH(GhYVV#Vg?5Q)EBuA{zu8@&iECwg2D^9>0!vvq&>8|^TaEHb0tS1nl zg*SfpC~mkoL)ox87h`h7d#SxQkur1X4DCyGQp=?c-BQOgkmM%pggof?$$fajctUuB zC;&r=l;)%+RZDjY7B+B-SAdW`Z995ameFIUC=n?`*K&otI&NB7JK;;RbmwTtO!$$& zfZrGBM?r`tbj!j%Hw#X_;3NW33>ZjgxoMTl$%xmEjch3}0|CbT9;zy%R2xpiP>+6A zGl&@h6CwbbLu`@|qzaa$=QfluUn1Q;LjK8Qq%>O>Zha~_@;@Gy*Bwcvg!xStF16Cr$+86;;kvRXAPe&BJBC)& z&g-d+X7HR=^9M+j)l!zZZsUH4ddJ7iLN1+u7{CH2$UxpQCvwDn5lQy>Er*(VF5^sg zu-Gb{f9ppoF*Iza{~(bFj?qw#vY98^zx_jy%D;h!knLDVN@CxKiyd2BkR3lk+7)Pz zY|#n;*@EF@)N}^(WMh^PB+oE`NDO|N!;r5Fzuyw11yF-p`b@#@uAzJphyr67f-YZx zdO$aHnts)p&hu?^&QFr=D8L-ME0`S0QAdG&p<6&BmV6_ey#me-fun~L>977_n3g^u zx45Jrh0F}LokhZ*k}#dI^M;nv)2d^V@HWRH`M`4cu2}vb4(Te#Azc;#E((%|uUICB z$_nf#D-PnPG?oni2$8V=D3Kn{vD@&zYpeGO%Pi#i%(K_H3wD#+X5SO!Sxoc#t!mLv zHvQx*M3HgSheD3$V8KsX5Cy+fFdco;e?SM*L%IK$pB(X%`~76xPu>S0fnl$`&vBbA zW&fhKUzsi9_E}QORdI17+2R3olmFngL(NvBT)jZtyWY#*4J!GcOJNf`ItAJ}OnCh? zGMIVIu>AyKnCpPqcnD>_c;XNPrz8m&#V8Wn9 z82tt0=|m3eI5zF*l7IM00VbrsZv-g)@D790OTwV--3UHQe>7;^yB5SPRU#157%_4H zdYUXMMZ{eTh<8sgM4e81*BH_JHo4orkz;>cX1!0Aaao8luN|)x=btJSX-c;qU?^V_ zKfrK?!GJk-2G?CF;3uJg5B7^Yf?&72cJkzyj+0Fnmu&v!&{|)=?!qnFou#Dx#-8)q zL_V-xS1Hdb4>im4^@^)ra%Wn#hFVu@PhCXwpz_$`rX*CvHr8cXOLYPzVNdrZ-*5b-TO3AIe)e*mGR&v^gmYzc_DXJC$PRc$c(-(n0Y!*G{b90_47Cw z9ONSI9Rq1(9Xjf@hw~M;*mRXr itvcLNFy-!Sx#}v58f8>b;Y&}STRoeTh5ewpw)S60w*h?s literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST new file mode 100644 index 00000000..b1e1454a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: simple-vector-p ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-simple-vector-p.test ;; ;; Syntax: simple-vector-p object ;; ;; Function Description: Returns non-nil iff object is a simple general vector (a one-dimensional array which can accept elements of any CML type and which is not adjustable or displaced and has no fill pointer), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group simple-vector-p-group :before (test-defun simple-vector-ptest (object &optional (expected-value nil)) "See if (simple-vector-p object) <=> (typep object 'simple-vector); see if the predicate is true of the object or is not true, depending on the expected value; see if a simple-vector is a one-dimensional array of type t." (let ((val (simple-vector-p object))) (and ;; Test equivalence of simple-vector-p to typep...'simple-vector. (eq val (typep object 'simple-vector)) ;; non-nil for true cases, NIL for others. (cond (expected-value val) (t (null val)) ) ; cond ;; Simple vectors are one-dimensional arrays. To satisfy the predicate, they must be of type t. The test fails unless both conditions are met. (cond (expected-value (and (= 1 (array-rank object)) (eq t (array-element-type object)) ) ; and ) ;; Other kinds of objects get this one free. (t t) ) ; cond arrayp object ) ; and ) ; let ) ; test-defun ;; (do-test simple-vector-p-with-simple-general-vectors-test (every #'(lambda (object) (simple-vector-ptest object t)) (list (vector) (vector 1 2 3 4 5 6 7) (make-array 1000) (make-array 5 :element-type t :initial-contents (list (car(list-all-packages)) (copy-readtable) "string" (random 100) (make-symbol "string"))) (make-array (list 7)) (make-array (+ 10 (random 100))) '#() '#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6)) '#(1 0 0 1 1) ;; Note that an array of type nil isn't restricted as to the type of its members, so it qualifies as general. (make-array 5 :element-type t :initial-contents '(t t t t t)) ) ; list ) ; every ) ; do-test simple-vector-p-with-simple-general-vectors-test ;; (do-test simple-vector-p-with-non-simple-general-vectors-test (every 'simple-vector-ptest (list (make-array (+ 10 (random 100)) :displaced-to (make-array 110)) (make-array (+ 10 (random 100)) :fill-pointer 10) (make-array (+ 10 (random 100)) :adjustable t) "string" #*01010101 ) ; list ) ; every ) ; do-test simple-vector-p-with-non-simple-general-vectors-test ;; (do-test simple-vector-p-with-multi-dimensional-arrays-test ;; Multi-dimensional arrays don't qualify. (every 'simple-vector-ptest (list (make-array '(6 1)) (make-array (random (- array-dimension-limit 1)) :element-type 'bit) (make-array '(2 2) :adjustable t) ) ; list ) ; every ) ; do-test simple-vector-p-with-multi-dimensional-arrays-test ;; (do-test simple-vector-p-with-symbols-test ;; Symbols aren't vectors. (every 'simple-vector-ptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test simple-vector-p-with-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..194281d5694a31a262e3bc7383c66eebde7eebd9 GIT binary patch literal 3473 zcmb_fUuav`89(0a&rY2u7+DE4)w zRhERL6uMB;br~H)yQyoI-P1OMz7z_5NJAf%wZ(-FHW-w`!d~_;*dORa$I4)=P^kBP z=UmxNGDg{EOa9LHJKz8Foj+bDUFX!Cq}EpJ<%-*oY8PAei!EuT){vUDi;X2$S^-?T zq#CC7Oh!=`MjsxFSi5GH8g8-WE=%@Bx4B$=Iwg%wNlLv@uE1b&64;Z|6BE+W#COp@Rc)5yN@A^v;5Cvr2yV?t*xBC@~;}pI|ZG zNOSt_*rpMC(TM$kv#+2I4EqV$ygm#A_#jkDBsc@w zeh2t_p6ebEN;jE5U_V*UT`^+s6S7`<-iR%T0;sKD-+y*r5I_$heW<#W*nCq=BN${N zeA>yR2hl(r!UB!$zlZ_@pK9o%-Gd-Ti0VlmV=yXnF49FvWiSxB1L7=N-j?D}We_~T z5N%Wj8Fve4KcKg^>jrZj)d);r0k?l3^)FnZp?_B)v>cR2e5+HQULGBk1wKJRSZ*Bu zZ=#04d6joE_zFn}H2a>8{s~OqUY{!JnsIuK0wiYd0%ZnmN4D#)+ z<}^ij3Ub;o^H!1yqHwpiZ6s+l6s5f(+}yFGW}1d68;)IY>|`hc3VlgMUz8b+M*Mbs z?2f}C8X|=5!4qN<_xlhS+M_+L<=?|e$krC~2&0Lf%s7y{n^f!1U<&_0ZR!mb_MCesIh~#JV%Sf)!AtWVwFOqM8 zc$A4-i}@J?LlnP(7-!kxh}b#6y5}HBEnh(1q5F}TbRQC(lPM4io3LI+9?>y+5XoUq zzQi^9=m7*-8NeR60ao}63sLwZ3sLwj3sHE3g($qjj0-*|-)Gi@OPs87@=ZQB&&erH zj&gEnCqs4&qq{+_7Ndudi*l}uCXf?Zoa8gckxyB;$ATtr zvY^QiVO0h!&6Z~k)yYG_6zt;f0y+q2S`O;kxkj+Ad+)#=1FVbn*944WRzXv*oFPjKypb?jKy9k*x_(O&`@&+4#8Av9=G8&b7!ViVj&19xbN9!2zJ zK=TbC6ce#CAlnzn$o67^ZHOd- zvstTc6*c!HDaCxvZGna+cRB{%Lf*76RUG`J@FzRMK1<78&9d5Q7lu} zM|Q-8-!pMx!+Qn=&iNaI-Z5{?JMN8p6W$5$q<6}j^rpO`cfniomOa-~yctjRW8GUIyN=G@tZt)}Ew+*P*B2Xrv{)KxNn23`X{&*0xrZk$%uGnX^#rDw}G9txn5fF4k83_XcbTQ9*I0tZ;R zQoIab{`;S+2yc2ZsA6cliqN9H4;TeJww0XUj%nxM0Jh=ifE(P=x~E~j$8u)yd?}m) z<{oy@%Dc~>21^b{Vu?53_N%q{n#N?&o*4DoO!}+f{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST new file mode 100644 index 00000000..4d821219 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: stringp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 21 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-stringp.test ;; ;; Syntax: stringp object ;; ;; Function Description: Returns non-nil iff object is a string (a one-dimensional array of type string-char, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group stringp-group :before (test-defun stringptest (object &optional (expected-value nil)) "See if (typep object 'string) <=> (stringp object), and if the string and its elements are of the proper type." (let ((val (stringp object))) (and ;; Test equivalence of stringp to typep...'string. (eq val (typep object 'string)) ;; non-nil for true cases, NIL for others. (cond (expected-value val) (t (null val)) ) ; cond ;; Strings are one-dimensional arrays of type string-char. (eq val (typep object '(array string-char (*)))) ;; Strings are vectors of type string-char. (eq val (typep object '(vector string-char))) ;; If the object is an array, see if it's the right kind of array. (cond (expected-value (and (= 1 (array-rank object)) ;; The type must at least be consistent with 'string-char. (subtypep 'string-char (array-element-type object)) ) ; and ) ;; If it's not an array, it can't be the right kind; the test is moot (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test stringp-with-strings-test (every #'(lambda (object) (stringptest object t)) (list "string" (symbol-name 'string) (symbol-name (gensym)) (symbol-name (gentemp)) (symbol-name (make-symbol "string")) (make-string (random 1000)) (make-string (random 1000) :initial-element #\$) (make-array 1 :element-type 'string-char) (make-array 1 :adjustable t :element-type 'string-char) (make-array 20 :initial-element #\} :element-type 'string-char) (make-array 20 :element-type 'string-char :initial-contents '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\A #\B #\C #\D #\E)) (make-array 20 :element-type 'string-char :fill-pointer (random 20) :adjustable t :displaced-to (make-array (list (+ 20 (random 20)) (+ 20 (random 10))) :element-type 'string-char :initial-element #\})) ) ; list ) ; every ) ; do-test stringp-with-strings-test ;; ;; Symbols aren't strings (do-test stringp-with-symbols-test (every 'stringptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20) :adjustable t :displaced-to (make-array (list (+ 20 (random 20)) (+ 20 (random 10))) :element-type 'string-char :initial-element #\A ))) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test stringp-with-symbols-test ;; ;; Only one-dimensional string-char arrays are strings. (do-test stringp-with-non-string-arrays-test (every 'stringptest (list (make-array 6 :initial-contents '(#\s #\t #\r #\i #\n #\g)) ) ; list ) ; every ) ; do-test stringp-with-non-string-arrays-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b0fc45b3cd902b474c4ec5977008e0a69b65e225 GIT binary patch literal 2274 zcmbtVO>7%Q6rNo>KXq)!u1ckv{%oU01-EOQl9n_e(amNYyI$`uyX&+$A(J?@g&RkX zQ;DKRQ4v29tCqA-?G$=~3*tbjghZhzAg&xa6d{4c0VFt3kdU~b^4^S-ray;DBY>r$;n61#W+FMwHH5c^usJw9 zIy91r+`e*2N;C-}(_|IJCPES0l-Bdm$IK>{2K2lLwS` zb6#y!PgNV3&dCKL5fZ%R_vXr`?iDOExF{`4(cruvE10Scsc93G$h{pe=v@l@$RYIr z{JT@7G0U*Yl}qungh+oT6Ef2IqIRPwU7sU2zbwkfcBYb2_X*DNT29F4ULAk|JP6fNDWO1mFoq{}H1)ZE=PPI(1x@QWK-qk@=MkxPoksxm){1f7 ziho1MO6_$kUX&%6xN>#dF{Kl-myjr$P7kbpB0au=yEM1Py|>=z0#C_MAH3nQwt^8n z92F4SMY?#30Mu*9l>b4r%@56L>w{Qrpd?Fcl%fzNnT(6zP#h}-FQBykegL-@JEZK+|eCpDu?*Eki`WjjK{c~%t2xUlxoIZJ(*4$+m1fCMKZ}GC5I&x!j$=8hRrc(% zmkuStAez?9DV5{sB=8eM_iU#A5Fsp#J7@>)hu^_bm_kud`4N*s0-A^F56D0-I}SBB zY*!}Xw{Ma8odW5aOGQ|g#Lpi<0V9KSk~&kW3l%dcq73}UN?MVsn&W6w2)zbSpQs~0 z3=n$-u$~DBN=r8C%WM~lGsq5Ln2qXbfi4PBWGMvm>`@el*>)63#&aYXgNGG?;1l_m z?L_e#Q&9ZMcBA-|J0aJ&6Y@UWej3u);!-cyIY!jA6X-a&?C;QC!=44KiFMsXJ! zuAmuwK~;MYp^~OM*1C@!0QKa?tg<<7?}6~rFX+H_tO*mfn^55$B808-6Z2TX%c~}| zqd;92!+Bq`K@^|C0oiTh+VQ3QknKZs1JIjT2h^CfEmi*B(uM7SmZodvUzl|bw433Nf>oeHZw*Cm+6^0|2NKde zs|44I;F~RWcml>test>6-2-2-symbolp.test ;; ;; Syntax: symbolp object ;; ;; Function Description: Returns non-nil iff object is a symbol, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group symbolp-group :before (test-defun symbolptest (object) (and ;; Non-nil for true cases, NIL for others. (cond ((not (null expected-value)) (not (null (symbolp object)))) (t (eq (symbolp object) nil)) ) ; cond ;; Test the equivalence in Steele's function description. (eq (symbolp object) (typep object 'symbol)) ) ; and ) ; test-defun ;; (do-test symbolp-test-with-symbols (let ((expected-value t) (five 5) (symbol 'cymbal)) (declare (special expected-value five symbol)) (every 'symbolptest (list 'cymbal symbol (gensym) (gentemp) (make-symbol (make-array 5 :element-type 'string-char :initial-element #\g)) (car '(one two three)) t nil ) ; list ) ; every ) ; let ) ; do-test-symbolp-test-with-symbols ;; (do-test symbolp-test-with-non-symbols (let ((expected-value nil) (cymbalname 'cymbal)) (declare (special expected-value cymbalname)) (every 'symbolptest (list (symbol-name 'cymbal) (symbol-name cymbalname) (symbol-name (gensym)) (symbol-name (gentemp)) (make-array 5 :element-type 'string-char :initial-element #\g) (car '(1 2 3)) ) ; list ) ; every ) ; let ) ; do-test-symbolp-test-with-non-symbols ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bbaa70d7d1b3f844c6cf60f39a277695fa405a67 GIT binary patch literal 4452 zcmb_gYit}>6~1?7y|&knIEkA!OOj4Pg41ort+Pp*SEo$btQ5=%(1@s8_l zCcDO7M@^wo2z?~VYJy{G<`yC$At3|;l2(PLO>v6{!M&Kt)wiK@BK~AE<%QI7Bt}+gC z<#W1e8BYvr`bh7-zKFf3XKc#NSKNZ)%(&Bq{E2N!-yTJqoGNl<@WuY<7Z8yf<>=;ympt6GFzw0+Lojx`<4I3)QZeW7v*5m`oXJMoSy9U^b|> zKrU*|Hmsn!a=TI~PpY1K-1RV>W7C8Z5`3xJGMLNgPSVT-bMzE#56)LRk{LA%scAz7 zky>hA&^ryPkzML`_&aFmj%j7d#rgKrgoGYg*(D*IS0=8G&?_bK?yDoxp=fj^4L`y$ zK0hevr#lzS&I@MeQ-b{(+CZ~|kcCT|paBnxCZbWnKzh)ICwd_Ia`k2}a5V-^g)SPl z0av^V{HoKDW-qNhw5|rAg^+eM9ow*QSbL;5D?)nU~t0K*MW4Idvf0nO_M zq&4I?pMeuI0~#FFGL#G4AHYSjFwsS%_Tbs-x|nWe5=q>G)L|`?NEwzokOWC)$c{;E ztX1lOw-w$Nc*F2E!G5Kg zZO0gu=u&IPjIlO3!dm4{*#A0XhGm(SYUZ45&WXt@z@R;*WkyvlM<+qGtM9h`G$Iqi zLb!>J;Fj12jzY#kErrZxV8RGMbCBJL2=ts~8JR^pHlx_L3X$I|h_2a&2+P`_TYeu3 z7TIDPG^|n8h6<$&l>Q0)x23faL$ycK1183l|9~>V@&f^7zXMtG5JWZ7S>)elcOm%= zh&#BsW?9-OirxTG*n-h8)5yLo6klLb6TR#`Wav+NEekFzyMY<4G-5%w`8 z{etXZ>yT3grwA^}Iq9F=i}VlfMS6#Ok*;zt(u)wVbs*`e07%~sE~M`Xqi+aO5w@Qd zwnv2RK4H5}sH_zv%nALMAb$hDwYoVLR1-YYcQ`8gdv-T+zZKkDY%OxX=4GI72=3>+ z8uX`v`!QRODnAn3vm6navGG*2LGr4#a3@4Lzx)`07%#TTqnNbjxh`SP!D+!2vUu zNo11%EVK zz*LmJ3DOnG4D2KT$VeHOAj*FR@^-iwrPQpMgt>2_@FxJH&E})7>cbkBEudn}P<2ML zd~JOf6vILh?Y<3w+iHLj6}uOuPlGgeOB(51%1Nq;B!IA?#(;>gEs>WnDvM;s1^PpR z3;~7?EpZ@c*GFA`5D>^P`!Ud7)`ujZ9{r3U z!|Xn^?+37J5=lFo(sU!C!U<#?R?WddSQ*&8Um&!O2zeFo zMC!vaWSO}vA9nIhj)7d{!HF-(7hsGVH}R7!KF#9eI70_vTh3+p^2xEd1)`>hbEabq zv&{xDAzZfmS-g+MH?eq>#Xk;_L(!mmx8qJ%luakKP0Dy4zE}!Mu_Qh=PG#fx$9Ym6Z ztu@dJ<9Q~1$o;XzO>OCYt}R^-&b0?;+k?3f>w{j%CX$1-GL(Vh4~#knWjjx;`Xl<7 z56-O)&aUQ~ECb@F%3OY7o;3Ft;il9@f@;*uA3IXWW1hDk%`h00AI)$&L$c<;0r-5O zGK)h8`v3e=jE@S8J;7YJf4|@7Z};Q=4u7Y=%YVS%?eFpP{t|TPTjfx4TlDRw`37t^(iu<9Tly8siFT2#4F0f;;J!3b0<3 za*21ik4-`(SYyZY-i+JunpZ>|beIQSS1lBexuxl1xs>;m{M1zbMDOu=($f#O;g^Q- z_uBJowb|h(hi4~F6`#}Qk8)X8v1L4OB7l~lOtjkEyUT-&cCh9x}(Z&57V_(+ZJ4yrv_&&@+w3guEyMS-%p eCm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST new file mode 100644 index 00000000..6ac4b4e7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vectorp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-vectorp.test ;; ;; Syntax: vectorp object ;; ;; Function Description: Returns non-nil iff object is a vector (a one-dimensional array), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group vectorp-group :before (test-defun vectorptest (object &optional (expected-value nil)) "See if (vectorp object) <=> (typep object 'vector); see if the predicate is true or false of the object, depending on the expected value; see if a vector is a one-dimensional array." (let ((val (vectorp object))) (and ;; Test equivalence of vectorp to typep...'vector. (eq val (typep object 'vector)) ;; non-nil for true cases, NIL for others. (cond (expected-value val) (t (null val)) ) ; cond ;; Vectors are one-dimensional arrays. (cond (expected-value ;; The caller had better not pass anything but an array when expected-value is non-nil. (eq 1 (array-rank object)) ) ;; Non-arrays are moot. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test vectorp-with-vectors-test (every #'(lambda (object) (vectorptest object t)) (list '#() '#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6)) '#(1 0 0 1 1) (vector) (vector 1 2 3 4 5 6 7) (make-array (list 7)) (make-array (+ 10 (random 100)) :displaced-to (make-array (+ 100 (random 100)) :displaced-to (make-array 300 :element-type '(or readtable string-char) :initial-element (copy-readtable) ) ) :adjustable t :displaced-index-offset (random 10) :fill-pointer (random 5) ) ; make-array ) ; list ) ; every ) ; do-test vectorp-with-vectors-test ;; All strings are vectors (do-test vectorp-with-strings-test (every #'(lambda (object) (vectorptest object t)) (list "string" (symbol-name 'string) (symbol-name (gensym)) (symbol-name (gentemp)) (symbol-name (make-symbol "string")) (make-string (random 1000)) (make-string (random 1000) :initial-element #\$) (make-array 1 :element-type 'string-char) (make-array 1 :adjustable t :element-type 'string-char) (make-array 20 :initial-element #\} :element-type 'string-char) (make-array 20 :element-type 'string-char :initial-contents '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\A #\B #\C #\D #\E)) ) ; list ) ; every ) ; do-test vectorp-with-strings-test ;; All bit-vectors are vectors (do-test vectorp-with-bit-vectors-test (every #'(lambda (object) (vectorptest object t)) (list #*1000010101101111111 (make-array 500 :element-type 'bit) (bit-andc2 (make-array 12 :element-type 'bit) #*000100101110) ) ; list ) ; every ) ; do-test vectorp-with-bit-vectors-test ;; ;; Multi-dimensional arrays don't qualify. (do-test vectorp-with-multi-dimensional-arrays-test (every 'vectorptest (list (make-array '(6 1)) (make-array (list (random (- array-dimension-limit 1)) 1) :element-type 'bit) (make-array (list 1 (random (1- array-dimension-limit 1))) :element-type 'bit) (make-array '(2 2) :adjustable t) ) ; list ) ; every ) ; do-test vectorp-with-multi-dimensional-arrays-test ;; ;; Symbols aren't strings, so a fortiori they aren't vectors. (do-test vectorp-with-symbols-test (every 'vectorptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20) :initial-element #\a)) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test vectorp-with-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a475379f9fa325a46f2b1b96cf97bd60736c4c1c GIT binary patch literal 1447 zcmbtU&u<$=6n?u-jDN(IT~b3_i*5p3wro&nQndjIrrSwkyxDbj$CPrZLgLgGPHb!k z6cABWMdGqjYa*&0pywVzLPCmY6;)jO5A-kKniJRX-fjYIK_U{;j^50h?|tukGjDbP z!ylTKX13Qm%~rjuwKw~n&AztQ?rOdEW_P8ot)XB0(sW$@)dDjslW$L@yr*_ny7lFL zeN_{i_1^08)*IT?C5?5u%@$5BUc}{v+3D%o^D~pFIp$dr+X-T3re|j^O{Na--BogJ z09b*2GD(0O#31;_&*_4D!k8;t+_2dq*MmXeC$JWy=5aUh^KWVWcE@PdKdZN>ob?_k z0KpwUF;}xqQFiQLSGlQ-1h@T6**2?NIm*C#r%q;+AC!bSE z$FGeC6=iP&Rv%W>tA%1-i8mkI062B)g}l<(yPn;5vba1LSht<*ZvcbF*G{&gDjA&q z^wQOriGoG~U<6>lxl#aE@;rqo561p`8s*L7G|5(s)D%PA zPWIr$rTk}#o#Pal|EU|Rc)y6Zzu(A#nhC!3OSMa{+AHp6y_d)GX{7gZGzqftMZ7H4*?YRozAqNhtmRsI<* z99^bkX_<^s_hfbMx{hl&HBqezJ(j|N5uMrBjL=UcfuEatt{c-a069c0n4-SgMxr79 z0kdfFDK6q9fC*Y|kOH&jy4-%M-=#u(*Gc)`2VpXgM`>l6wo7u9%$Ph)CL;@IU@vsS zFQF6e%YrLM9eMg)SqQ;fn0>hFI`cNge1Zv5e96F5_7<6CRlUF78NCpK2nq;mrBwx= zSllM@VJ+{-5_tCPDqjn}4|b^;UNK$HL@4p7#ln-d%7VMh@?@G|SoKoP5j+&6oRZ^I!;_u&?f}s2 sQAj2y5Gr4dME@wqKYG?%3FvgS_J-EmTK~A+>dnjXp=TlR-PGaXpT(b?m;e9( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQ.TEST b/internal/test/LANGUAGE/AUTO/6-3-EQ.TEST new file mode 100644 index 00000000..a81ee2e6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-3-EQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQ ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 77 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: 16 12 86 Peter Reidy - added do-test-group ;; ;; Filed As: {ERIS}CML>TEST>6-3-eq.TEST ;; ;; ;; Syntax: (eq x y) ;; ;; Function Description: ;; (do-test-group eq-group (do-test "EQ on symbols" (and (not (eq 'a 'b)) (eq 'a 'a))) (do-test EQ-on-CONSes (not (eq (cons 'a 'b) (cons 'a 'b)))) (do-test EQ-on-the-same-CONS (let ((x (cons 3 4.5))) (eq x x))) (do-test EQ-on-smallps (and (eq 0 0) (eq 65534 65534) (eq -32700 -32700))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..64251c99e92fc0b88e73a8fbe7552d09367e1995 GIT binary patch literal 1816 zcmb_dO>7%g5T0EpuK%&y#1O|SOVUcnu#rNNstt&;-M%Eon_YKzOfdoQ|2nwhYNA5_RLEN~&kubB*hLj)?iAsK&eKX&DGxOfe za~B3L>4u`$*BaGYxvA7Q+Kr92vRZE{t@=iDxvZ?BUU^HmZ1(norWYojos2m9EX&RE zQoFpOxEtlx%F^c3%H$bEYc#7h{5X9Yx2I;Or)Q^TCL(j1V+giG_{_}APEJik_U_%0 zl63%BhFub2fFuOKd$*I!xy*6ZxxB$tQ(I&?uj_R}Sc_V6nC*2^&nWGBL#>rxFW0D? zwH8PK-tA6ku4L+N-ZH%{>ADp2Zgt{$Q!Qd?+B^d})MFub$?F_BrB12rf&usL#BKn{ z6RD(3iF{SrDM;Jv(Ehq0U(94uQn0#n72xQNBgdr5_Lao0mB8(2_f;p3!59Q6J7Fw)t6m~bsX z*<}2@t;Fo1OZm?b@AX5(A7b9W^hu)+k5qoXPa6B5q(t&&?Txw*h2=n%_k z=4I8_6N%SJPX1$nA^`wCKvQ#!CgDjW8elJJ25m-h6Ql$*m$r{l271Z1nYnL7xkR=w zW&Zbp=$gYsSRO^Q^c^1}ai0&9_=2ZNye5?ELU~0fvqCu{lyP4P+rARM^p)^2PuqOR z;=^ZoI*UZ|IOaK6w5@rQcEgxT0*710i*a0=?&Gglgyx?@|3M!9vC!@}d_aOG)k$Sb zKXGD}zS+m4TZ=`5UE(8T_=Jy=_(;IILcF>U?I4j+bOhQJ=z@SfCq$Z#tCyp@z*Gm{ zIu(yk_`sg;1Hb!V_*sb0(I?XLAt>vCKNR3Cfx5}FZz51S$4A~Esqv8(f1<(1rupbo zJe%d&1ST)1yw2lpxz$$2u4!Y+>Jt7PtSHrW@sgA7+DWSMd+)BdMO}GZx0&YpIre(q zzhWcrGFvko9wiu_>4lQzGEwmkA18`UpMsx206!@#SB2%oLCaC!0zce*;Whwz!?y=8 k@F^dE`9W>L^DkVfuPd$1wO8u3);u2{cn||0oY~v^6MZZHYybcN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQL.TEST b/internal/test/LANGUAGE/AUTO/6-3-EQL.TEST new file mode 100644 index 00000000..c1f9bb66 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-3-EQL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQL ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 78 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: 16 12 86 Peter Reidy - added do-test-group ;; ;; Filed As: {ERIS}CML>TEST>6-3-eql.TEST ;; ;; ;; Syntax: (eq x y) ;; ;; Function Description: ;; (do-test-group eql-test (do-test "EQL on symbols" (and (not (eql 'a 'b)) (eql 'a 'a))) (do-test EQL-on-CONSes (not (eql (cons 'a 'b) (cons 'a 'b)))) (do-test EQL-on-the-same-CONS (let ((x (cons 3 4.5))) (eql x x))) (do-test EQL-on-smallps (and (eql 0 0) (eql 65534 65534) (eql -32700 -32700) (not (eql 0 1)) ) ) (do-test EQL-on-complex (and (eql #c(3 4) #c(3 4)) (eql #c(3 4.1) #c(3 4.1)) (not (eql #c(3 4) #c(3.0 4.0))) ) ) (do-test EQL-on-strings (and (not (eql "Foo" "foo")) (let ((x "foo")) (eql x x) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..09e0593428e657514816a07853846d27c9937dc1 GIT binary patch literal 2008 zcmb_dO>7%Q6n?u-jQ`@=RpOG=YFBB>VPPYsO-e|GV7nbV#+zMtcTImdpww|1BPX`} z0}6;zRY+Wnl2B3Y06ig29H=TGQIX0L+z?kJ&LHl<5f0(aj2#++L?j}4^gQ4D-uK@8 zyxA=nykeM&QCqE7s^x}KYq#p{ma<%HD9u{CQ7S9Th%0XywnN^Y*Nyz-`KgHen5Wbz zFSg1{iq|eTmloHbQKp_#^m?OG#XqyNI6XHvJw11JW-^k|T~nwXAZBJ}?#%3DWar*p zDNzG}5_Fjf10)~-{s*0e>Jit|GC7lImcBq#f6MQLa4lNVC63=oo>5x0x>hZ}Uaqp` ztTsUc@Hac5OwlsDoNf7cq+3$V-{=hGEUkb`)3XHRP)~)aOMWMOPCKiSOGVv;dv_zZ z0pxd*37M7h^~!c$dbkFyM|t^jdMqggE88~!j^2J^L|S?HYP@U5ar*0)xnak@1=w17 z&yMG1X$b$`KX&;9lVBqR5CiB|N(x_KU-ienY6wN}H`X)XA2>%!ueu&tkY!{Hi_S7kqFcp+ma&}$SEZ6H?T_|sl|}<`8V(%6K8mZvacoDki(aAV zseuFr#8ln7s&Sl&_?^VmKl(Br0H6b`8B?si)=_AHysVpSQpHJ-6`*@;T45C!MaLo5 zW1UYW=DWr!|9evm-6bL|jWYK!I?T*49bsmWvRu+P9F)2ol zOz=Mu#P@}{v4`(saERgTzri+JP8p6fAT2!ozvlGVZOkq zBfC+IOnP)*&^H9{7EQm2ROtd8eS=w@jyCCdot~Pe$DgL@G)*Vird;RH4(orX3isyZn`weXm}Qvind31 zL2`snu+9CBOVHCupihbY_)2)%`#mM$QTBV{+yg(n`{E`5>cXRa9Qd40T-%H0v3>Za ZDYZ4FxxRY6R&8eK#K2w_eDwUz&R?YLGQ9u* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST b/internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST new file mode 100644 index 00000000..251e098c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQUALP ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 80 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: 16 12 86 Peter Reidy - added do-test-group ;; ;; Filed As: {ERIS}CML>TEST>6-3-equal.TEST ;; ;; ;; Syntax: (equal x y) ;; ;; Function Description: ;; (do-test-group equal-group (do-test "EQUAL on symbols" (and (not (equal 'a 'b)) (equal 'a 'a))) (do-test EQUAL-on-CONSes (equal (cons 'a 'b) (cons 'a 'b)) ) (do-test EQUAL-on-the-same-CONS (let ((x (cons 3 4.5))) (equal x x))) (do-test EQUAL-on-smallps (and (equal 0 0) (equal 65534 65534) (equal -32700 -32700) (not (equal 0 1)) ) ) (do-test EQUAL-on-complex (and (equal #c(3 4) #c(3 4)) (equal #c(3 4.1) #c(3 4.1)) (not (equal #c(3 4) #c(3.0 4.0))) ) ) (do-test EQUAL-on-strings (and (equal "Foo" "Foo") (not (equal "Foo" "foo")) (let ((x "foo")) (equal x x) ) ) ) (do-test EQUAL-on-chars (and (equal #\A #\A) (not (equal #\A #\a)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..69e63f8329c51ac60e95202728b70be4ea0eed8e GIT binary patch literal 3172 zcmb_eU2GIp6uvXtF5R}64vop)gEKp1!wQSqfZMW{W zXfcq67>&9DrGRr$5~Cr}7!yPiL%>u+!Xq(0Xz8dbh9_- z-tT=dBD@3N%V~+4k+$;B72~3VuRAORnbN>$rN<9Y=PmXZ7nU^np-!Pc4&?v)E*(G zwRKy|=8dJZ=gvr>G$Ev)%%BMn5+Xk0oy>*8E_GbBBVth1)S@)(O?kNzn2Q>BsO{yd zo>j)uqiQN~Fp<% z+@vj*A6-@}4PD+} zF=JK0@XnNR+^V=n$kfo=Rz;621)+PPc6TF6U@IY{oRFDh|2jUyg6b~?)e;bae_h@{ z_#;>rO?Wul|c(a3qUJ@=7&}cw^dbG*Id0zwW%Ao;kMEF zb>(+@9hXLB85q^#KGO}Vnemv~VcAh9%p_S_80}hNR^|(_fUgQ}uZl3WZOc}zxEqVR zVc&8HC=Y99ugY;0@p7T2hi=1=j}TUbSD=b_+AR<&qPsK$2RC8h#{x7Lhd*Hjdfc|D z`M`b4B=lX!%I6kG*BmO+vNCj^LnYI4p&A^10K;HZ>!GS<+Zu=7Wh>D$DNI(FLEshB zUDW23J^}6%W~VT^FdKwf%Z+@ORfCxP7h8emcUFVuGFye_YtXE6TpRXG)wNi})r`nq zik=H1cvJ)ri{O1CxL$xO1sLFpo=- zh@Jw@vWV%@PRdzRz$&K(jp7!%y)m4(?=X-8dY5Kvx+`dhn1YTJt4H%9TZ?9o0J~A5 zJ>tX+O{eXuYoTvDfT4&9Pljfwa130~chIo~w0&(6etueoz*7ME&3Lp;0CesKVCbQ(rB|KSL}R{hzrOmbupN3ZjotQ{0tUTQ!{J+{zO z#XZuE1s>_D@JuZ93<}S>g`VZyLw7B%+CG`rE^xA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST b/internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST new file mode 100644 index 00000000..e5243f4e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQUALP ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 80 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>6-3-equalp.TEST ;; ;; ;; Syntax: (equalpp x y) ;; ;; Function Description: ;; (do-test-group equalp-group (do-test "EQUALP on symbols" (and (not (equalp 'a 'b)) (equalp 'a 'a) (equalp 'a 'A))) (do-test EQUALP-on-CONSes (equalp (cons 'a 'b) (cons 'a 'b)) ) (do-test EQUALP-on-the-same-CONS (let ((x (cons 3 4.5))) (equalp x x))) (do-test EQUALP-on-smallps (and (equalp 0 0) (equalp 65534 65534) (equalp -32700 -32700) (not (equalp 0 1)) ) ) (do-test EQUALP-on-complex (and (equalp #c(3 4) #c(3 4)) (equalp #c(3 4.1) #c(3 4.1)) (equalp #c(3 4) #c(3.0 4.0)) ) ) (do-test EQUALP-on-strings (and (equalp "Foo" "Foo") (equalp "Foo" "foo") (let ((x "foo")) (equalp x x) ) ) ) (do-test EQUALP-on-chars (and (equalp #\A #\A) (equalp #\A #\a) ) ) (do-test EQUALP-on-strings (and (every 'equalp (list "string" "RRRRRR") (list "STRING" (string-capitalize (make-array 6 :element-type 'string-char :initial-element #\r))) ) (not (equalp "string" "strings")) ) ) (do-test "EQUALP on arrays" (and (every 'equalp (list #*100101 (make-array '(3 3)) (make-array '(2 2 1) :element-type 'number) ) (list (make-array 6 :element-type 'bit :initial-contents '(1 0 0 1 0 1)) (make-array '(3 3) :displaced-to (make-array '(4 4)) (make-array '(2 2 1) :element-type 'integer) ) ) ) (notany 'equalp (list (make-array '(3 4 5)) (make-array '(3 3 3) :element-type 'character)) (list (make-array '(3 4 4)) (make-array '(3 3 3) :element-type 'integer)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-4-AND.DFASL b/internal/test/LANGUAGE/AUTO/6-4-AND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4a994deb272bc1fb140f77686afeff6a2a591e89 GIT binary patch literal 753 zcma))Pfrs;7{=e-rGJ1z7NR5?gA)=i8>dMX5b@%;Oliw@7G`HtIg+y2CWSWrV`7ZN zc<{7F3z5uf_zqqXBL}~b-=NO6CK9}O+SzC3eV+IC&h#Pi%yy97JZRM$K^rxD-Bz!Q z_M2_gY4+OH0PQOsy|P_SUl)kInSGp_@UHAs+re%(*h8WhboO>%-b1-Zh_u@EhFYwy zs^68hrKPn8%h`!M@tl#{f7C3mtmSgqiNV>aW;Ow!3YYO`9KZwv0QoUY=Y3|2qRZro_D0Ld58+gi;Vp$m zHYn)nKQ6JmCd1SUUc!W}!`W%F5_j;ec2UyK4`KUzNv}-bp3xHZi{}8dZ&MkqcK(B@ z^{@Wsd-fBcUwg+&x;6!HT>Cm#8FIuHX@CsCWxYDvubFid^o0Br-mz?#trz3Qa6tt+ zl;fvGrLYap(#I6>jAavH7ci&7=c;3Sh@A9xJVDF4_U{SdTG6DDipGt!qMWuU=Pt*t zFSdMP8RM!TV-dE4hq`A)3fIhCn_9{Mh{obk8Jo%^nRj`ah(a7@`s z<*?U4~Qfw2`7lxhFEbD}qiJEgX>rw7;uf-yW(T ujvh{|9W83|i#*X))V$3p5foobbc%v<;&{vqTP53-N82kpWgWp>K literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-4-AND.TEST b/internal/test/LANGUAGE/AUTO/6-4-AND.TEST new file mode 100644 index 00000000..e1346b77 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-4-AND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: AND ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.4 Logical Operators ;; Page: 82 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: 25-Jul-86 ;; ;; Last Update: 25-Jul-86 ;; ;; Filed As: {ERIS}CML>TEST>6-4-AND.TEST ;; ;; ;; Syntax: (AND &REST FORMS) ;; ;; Function Description: ;; ;; (AND FORM1 FORM2 ... ) evaluates each FORM, one at a time, ;; from left to right. If any FORM evaluates to NIL, the value NIL ;; is immediately returned without evaluating the remaining ;; FORMS. If every FORM but the last evaluates to a non-NIL value, ;; AND returns whatever the last FORM returns. ;; Therefore in general AND can be used both for logical operations, ;; where NIL stands for FALSE and non-NIL values stand for TRUE, ;; and as a conditional expression. ;; For example: ;; ;; (IF (AND (>= N 0) ;; (< N (LENGTH A-SIMPLE-VECTOR)) ;; (EQ (ELT A-SIMPLE-VECTOR N) 'FOO)) ;; (PRINC "FOO!")) ;; ;; The above expression prints FOO! if element N of A-SIMPLE-VECTOR ;; is the symbol FOO, provided also that N is indeed a valid index ;; for A-SIMPLE-VECTOR. Because AND guarantees left-to-right testing ;; of its parts, ELT is not called if N is out of range. ;; ;; To put it another way, ;; the AND special form does SHORT-CIRCUIT Boolean evaluation, ;; like the and then operator in Ada ;; and what in some Pascal-like languages is called cand (for ``conditional ;; and''); the Lisp AND special form is ;; unlike the Pascal or Ada and operator, ;; which always evaluates both arguments. ;; ;; In the previous example writing ;; ;; (AND (>= N 0) ;; (< N (LENGTH A-SIMPLE-VECTOR)) ;; (EQ (ELT A-SIMPLE-VECTOR N) 'FOO) ;; (PRINC "FOO!")) ;; ;; would accomplish the same thing. The difference is purely stylistic. ;; Some programmers never use expressions containing side effects ;; within AND, preferring to use IF or WHEN for that purpose. ;; ;; From the general definition, one can deduce that ;; (AND X) = X. Also, ;; (AND) evaluates to T, which is an identity for this operation. ;; ;; One can define AND in terms of macro COND in this way: ;; ;; (AND X Y Z ... W) = (COND ((NOT X) NIL) ;; ((NOT Y) NIL) ;; ;; ((NOT Z) NIL) ;; ... ;; (T W)) ;; ;; ;; See IF and macro WHEN, which are sometimes stylistically ;; more appropriate than AND for conditional purposes. ;; If it is necessary to test whether a predicate is true ;; of all elements of a list or vector (element 0 AND element 1 AND ;; element 2 AND...), then the function function EVERY may be useful. ;; ;; Argument(s): Any number of Lisp objects. ;; ;; Returns: A Lisp object. ;; (DO-TEST "TEST AND 1" (AND (EQ (AND) T) (EQ (AND T) T) (EQ (AND NIL) NIL) (EQ (AND 123) 123) (EQ (AND 'ATOM) 'ATOM) (EQ (AND T T) T) (EQ (AND T NIL) NIL) (EQ (AND T 23 100) 100) (EQ (AND 100 T 23) 23) (EQ (AND T 1 T 2 T 3) 3) (EQ (AND T T 10 20 T) T))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL b/internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..989c43ebc3040d44d48c29a26bfa2b123856b721 GIT binary patch literal 753 zcma))Pfrs;7{=e-rGF`;5GBzVoRDzYI8Ca6fEUMQN=uhnn4L}KNZPG!QfSjZCdNpN z2TyCX5Xr2D@8A_Na_|fJ4RE%YNZ{gWXP=q(dEVbUGlbZ4%SKjvuhVS#UDO`*JA*!| zx4Wp<9(1cdsw*A6wj5616p2;NJ;|rtD?8P$zuWg~NDTa5ZTHm!lwU!l(`~lYVtHBp zF0C#stUg-Ir3=KhFWvs5W^rjXzmiK|oE&S}HUL!NJo=;nvS5Hb46>%6uE2$oO)(>z z)RaRRBozzxT*_rI^$_*j9o+I?`mG3OuLl}{{1hY$9-z z6!hd@m&jd{L1GCnVCD!oIgVGN4!$?eHnh`y*#5DhS0?XHX|d+n3xMf&iHz1b{mIn& z_ptnd{Q?*^-m?u|n*ca$e4D9^I3kNAKnCEvS)Cp>vdt{$G5I;TXIc(hD@BdrB4KMb z<@i}iDQw*}^)W>}Wm-g7Ma-%2xa!y%A;;YvSI|veyLm!5W;kvn!jzFzl#?dq+~L^q z#Fi&aBc%#5CSf~xq`PLQaI^VqQ%e{C;aD^(qpVEg1&41EQH;VYk8{edTtTQkR{E`f z92RlurMv0_tMb?=YF^z!oJB_Vop8ojlfgtZZKTGG@=s-OU--Q~nmZtKsJ^RSUkx?) uFCR{%9n5R;t31+G)U3rR5foobv`d0=V!PpZbWEjgdyb&tZTK>Kaq$NOw%?xs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-4-NOT.TEST b/internal/test/LANGUAGE/AUTO/6-4-NOT.TEST new file mode 100644 index 00000000..592eae64 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-4-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.4 Logical Operators ;; Page: 82 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: 25-Jul-86 ;; ;; Last Update: 25-Jul-86 ;; ;; Filed As: {ERIS}CML>TEST>6-4-NOT.TEST ;; ;; ;; Syntax: (NOT X) ;; ;; Function Description: ;; NOT returns T if X is NIL, and otherwise returns NIL. ;; It therefore inverts its argument considered as a Boolean value. ;; ;; function NULL is the same as NOT; both functions are included for the sake ;; of clarity. As a matter of style, ;; it is customary to use NULL to check whether something is the empty list ;; and to use NOT to invert the sense of a logical value. ;; ;; Argument(s): See CLTL manual. ;; ;; Returns: See CLTL manual. ;; (DO-TEST "TEST NOT 1" (AND (NOT NIL) (EQ (NOT NIL) T) (EQ (NOT T) NIL) (EQ (NOT 100) NIL) (EQ (NOT "STRING") NIL) (EQ (NOT 'ATOM) NIL) (EQ (NOT (NOT T)) T) (EQ (NOT (NOT NIL)) NIL) (EQ (NOT (NOT 1000)) T) (EQ (NOT (NOT (NOT NIL))) T))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/6-4-OR.DFASL b/internal/test/LANGUAGE/AUTO/6-4-OR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d5f9bde7ac674f219fa0acb93255c8b36eb7fef GIT binary patch literal 751 zcma))Pfrs;7{=e-rKN>JTB0NxgA)=i8>dMT3f7C`GNq-ZPa%{?Cn-tpgkBKo7 zCK9}O+SzC3eV+IC&I}>;%(9Wy-tRP9eiyX|{m!6| z_S#+4YY)10AMGg}y|NrmUzdng$v)0axYu^-UBA}%caa$Qz1`Z&2PpRlkxsYSQj679 z^_wp&EfpRvXD5opwXfX%qh>i@SX{|YT%Mk2={5k=;UfAZ0n%WAJPOjLpsv8hvQ04~ zo79v;86*@7_FT$kkXc0ib_cio7k(?k+3$e{AU_6)qQ@*zc9=ZY-e@WLA($#Nyrs~{ zIt4xP$0c&tWDw8eCG2oGJ&9MN2EH}UH?*?@*#5quSEui0v{>`}Il#=@@s!p$`@z)u z*Rb-Q{R9{`-mwi`n*um$e4VY1Fd~ZtKnmcZS)Um;(#e)ov;esZ=$YWh4%~_lhLGg`1yDTUtwi`}H$5iOH=Lj0!hR<`Cm%jlzGT!+B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/6-4-OR.TEST b/internal/test/LANGUAGE/AUTO/6-4-OR.TEST new file mode 100644 index 00000000..e2b93290 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/6-4-OR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: OR ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.4 Logical Operators ;; Page: 83 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: 25-Jul-86 ;; ;; Last Update: 25-Jul-86 ;; ;; Filed As: {ERIS}CML>TEST>6-4-OR.TEST ;; ;; ;; Syntax: (OR &REST FORMS) ;; ;; Function Description: ;; ;; (OR FORM1 FORM2 ... ) evaluates each FORM, one at a time, ;; from left to right. If any FORM other than the last ;; evaluates to something other than NIL, ;; OR ;; immediately returns that non-NIL value without evaluating the remaining ;; FORMS. If every FORM but the last evaluates to NIL, ;; OR returns whatever evaluation of the last of the FORMS returns. ;; Therefore in general OR can be used both for logical operations, ;; where NIL stands for FALSE and non-NIL values stand for TRUE, ;; and as a conditional expression. ;; ;; To put it another way, ;; the OR special form does SHORT-CIRCUIT Boolean evaluation, ;; like the or else operator in Ada ;; and what in some Pascal-like languages is called cor (for ``conditional ;; or''); the Lisp OR special form is ;; unlike the Pascal or Ada or operator, ;; which always evaluates both arguments. ;; ;; From the general definition, one can deduce that ;; (OR X) = X. Also, ;; (OR) evaluates to NIL, which is the identity for this operation. ;; ;; One can define OR in terms of macro COND in this way: ;; ;; (OR X Y Z ... W) = (COND (X) (Y) (Z) ... (T W)) ;; ;; ;; See IF and macro UNLESS, which are sometimes ;; stylistically more appropriate than OR for conditional purposes. ;; If it is necessary to test whether a predicate is true ;; one or more elements of a list or vector (element 0 OR element 1 OR ;; element 2 OR...), then the function function SOME may be useful. ;; ;; Argument(s): Any number of Lisp objects. ;; ;; Returns: A Lisp object. ;; (DO-TEST "TEST OR 1" (AND (EQ (OR) NIL) (EQ (OR NIL) NIL) (EQ (OR T) T) (EQ (OR 123) 123) (EQ (OR 'ATOM) 'ATOM) (EQ (OR NIL NIL) NIL) (EQ (OR NIL T) T) (EQ (OR NIL T 100) T) (EQ (OR 100 NIL T) 100) (EQ (OR NIL 1 NIL 2 NIL 3) 1) (EQ (OR NIL NIL 10 20 NIL) 10))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..50139375407ec60f9a42926c07c4c977429a3b24 GIT binary patch literal 1813 zcmb_cOK%%h6ux&RiJxgaPEzusOcJ$~Mx8)jeS}4sOeVDxdnU|`DM13sI1aXO>L_tQ z6{3o|VC9Os0W*gxV!?uKB{q~GvOp|ZAR)2jFR(#kffUY}u}erR3KFucbMAS6=YDq@ ztn*bpBkR?T&2pu#gmy}BiDS9i7wMR^_V@_V{v8}FwyeR<-=$*6P8Q`joz zYsEF$-6?Lbdr&u94 z8{3RC=H0D_7jvfWrY+OkFa$IkKQn2amEhIh0}h`cGshJ*AT|E zN*^9mG4228!*90xgt0hopL(>!le;!byXB{MzE^tC{{)DQQlgxoJNURhqUe^nkfw`L zQ<}MuF>G}{jTZBoqX;302%Y%vKqg3vuDN}pq6o`ot zh=|>I`==Dcwk=z=a_&mbRm2!3#1+k4Reigo02kwEQQXmYvmHI$D@1={egr%wv=WPQI(?>-%dLy5<a1qxt&G}cJ2|^y1O+=H&S$mdoaxh=OuxgkBz}eg5E#OE+f;>#jsaZ2QMaLOkwGs6PzoiF}o6q!NLeU|xN=lHYi9El(+rkpn+WEpiAwaIOQ+332G8# z2VxY4H}i7Na*bezKfrk^algr=093Put@Jc>nAJuX3($pe1X0lykmz-aiiTP+;awlA za184-Vx9SqSl{(=!UaSDDvTE4{H(Xv0ZHhEKIk9!_QXgy^o&;*OZg4{_gMDnOGih4 E0&#%%p8x;= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST new file mode 100644 index 00000000..0be1f22d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: boundp ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 90 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 3, 1986 ;; ;; Last Update: June 3, 1986 ;; ;; Filed As: {eris}cml>test>boundp.test ;; ;; ;; Syntax: BOUNDP symbol ;; ;; Function Description: BOUNDP returns true if the special variable named by symbol has a value ; otherwise, ;; it returns nil. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: true or nil ;; (do-test test-boundp0 (and ;;(every #'boundp '(nil t :start :end :initial-contents :key :from-end :circle multiple-values-limit ;; call-arguments-limit pi)) (setq a "ham" b 90 c '(9 8 7) d (1- 9)) (every #'boundp '(a b c d)))) (do-test test-boundp1 ;; ;; test for dynamically bound variables ;; (progn (defun fun1 () (let ((*a* 1) (*c* 2)) (declare (special *a* *c*)) (fun2))) (defun fun2 () (and (boundp '*a*) (boundp '*c*))) (fun1))) (do-test test-boundp2 ;; ;; test for lexically bound variables ;; (progn (makunbound 'a) (makunbound 'b) ; make suere a & b are unbound (not (or (boundp 'a) (boundp 'b))) (defun fun1 () (let ((a 1) (b 3)) (fun2))) (defun fun2 () (or (boundp 'a) (boundp 'b))) (eq nil (fun1)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0990fc2e3340614de81da73379268db3e73ec3a9 GIT binary patch literal 3441 zcmcH+ZD>_x_&w)-@80RXPM1!d$2l{vJL+unV}Wq)x$oV*dhR*b^Rcy{U~Shn+1%Qu zWTA+Gzi!%E*?AMIAA(>%5(&bLgd!*cA)!DJ3W9=led- zdp1o%PwR%FkByEGkCZ2ru_IICN2Zj6V-w2c*pZ2WvT_jk$}75M)8lzf-@o;#_Bv;d zWMHD)KUE%7+#}`5!Tw`yO8Xu~8=n{+0c7`XAa{0kbaXx0xwS5*Ifn4|05+XFyE=Dl zt-E{SoRl0Rgba`y2x5dJNr3ooRFY|zIFLreQsE$!%`fi=9Kfo1^|0a`G%f!2j7JdB>n zduzdC5Cd*hwQY|i*5z8P`u`d0jiDzGRo0|+%gh$=YO8t8%o@~I zGX>z7-A-DLv6vi%Uj%+3_yu8xQfXat^}K3R*Rx>;bUs93r_XU|QI-~KxK^6Q1927$ z;M^=pQ`@#|)$-hu=cWU7V30^_W}nLWPMS%9CBT!kd$WmC6Vo0kPR zBy0v*Bf8zR(6n8cri5vX+mOEn_=TI2pTH&vXCR`GJ3z+EFOByf9>msExwqL9;Gf)N zn-P3nH4)y)=kraf+#3wrPCjB=5PXOx(2J_Si>wW~?^U@~lQ)@)7k^&y+ga)v)&jlH zu?^7b$64!Rtd-x~V}50wTb`U!T25#!%E5kk^#_&V!{Wh4-ieJ6L(cm%GB}OEX+u2_ zX_gSl$X%epwzGEBZuZX${bt>!noHFMLueFSYHNnW;;06<<$!0ol($z-ux;Q%x-%OP z3Z4ykuX^bw2HeBCQ2Qzm$U2bKDURuV;b+{RiLhm?fh}h%SR-VeFfG;bVEf&3JC`Gh zk)DNh6GX>7enrBPB%Q&}5Ji&Osg90}tKlO%p+^+^Bd^Mn1^ z*G20MRAj#1u;5CfwY56QFfo3mp+-`(r(j!V5w;v;A))TsNzDfXd{2fuBpr z%~KnfDeTnsEJYx1^6?|i2D+Z+fi9gR_&xLhRacifRKwZ`w|)D+*s6q_n13iEY#Ut0 z2sWr>l>h`wo|6X{L1@xmK%-fj-iHkv_CT9I zvyz!04Cq-KKv>r_t%_ygAM!$aR^=|T)D)I-^}OcfRaeUx z_}E2s!$t<6$you+tY>2Q5Py3Bfh~?tC163vDxzf+I9$3G8i1-9*bn;=;U5@)By_7- zf^T&j3Pop;EY%Ij5zrWgcB{R4ij52AgnafZ{cJ_2mu%57?WvJl*77&U-0BInj z{1gRm;X%T~WPr-@1?O9`t?qW$3vbdA&+ILjSrweQRENJEaP{5WMC2Wuz6*En{sVB>cml>test>7-1-1-fboundp.test ;; ;; ;; Syntax: FBOUNDP symbol ;; ;; Function Description: FBOUNDP returns true if the symbol names a global function, a special form or a macro. ;; It returns nil otherwise. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: true or nil ;; ;; (do-test test-fboundp0 ;; ;; tests for system provided functions, special forms, and macros ;; (and (every #'fboundp '(block catch compiler-let declare eval-when flet function go if labels let let* macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq tagbody the throw unwind-protect)) (every #'fboundp '(car cdr caaadr cddddr cdadr endp list-length nthcdr last rest nth copy-list append make-array aref svref adjust-array make-hash-table clrhash hash-table-count every notany some notevery)) (every #'fboundp '(pop push pushnew defmacro multiple-value-list multiple-value-bind multiple-value-setq)))) (do-test test-fboundp1 ;; ;; tests for user defined global functions and macros ;; (and (defun fun1 () 'fun1) (defun fun2 () 'fun2) (defmacro mac1 () ''mac1) (defmacro mac2 () '(car '(hi there !))) (every #'fboundp '(fun1 fun2 mac1 mac2)))) (do-test test-fboundp2 ;; ;; tests for symbols not associated with function definitions ;; (and (setq a 0 b #\q c "1" d '(4) e 'e) (notany #'fboundp '(a b c d e no-such-fun1 no-such-fun2)))) (do-test test-fboundp-local-functions ;; ;; tests for user defined local functions ;; (and (flet ((locfun1 () 'locfun1) (locfun2 () 'foo2)) (notany #'fboundp '(locfun1 locfun2))) (notany #'fboundp '(locfun1 locfun2)))) (do-test test-fboundp-local-macros ;; ;; tests for user defined local macros ;; (and (macrolet ((locmac1 () ''locmac1) (locmac2 () ''bar2)) (notany #'fboundp '(locmac1 locmac2))) (notany #'fboundp '(locmac1 locmac2)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..58a41f512875d48a00c6433d234341dcca16b67f GIT binary patch literal 2949 zcmbtWT}&KR6uvXd0t?G_X|d3S!lX)Cmkx1hu}Dp17-q|s-I;Y}R*I=3^SO&Z^HJ!kGvmO|{0*@bh@ zx%Zs&o$uar?=BMWF*z>Cxv80~m6;WC^ZA+iyfB`d73OmDvtt=y9PGkdvZgC%2PJu^ z^KhibD4Q9Z&5Y(VX~CS&%%w-q>=z<02-3`K)`CG#52(-g9z584pu4jsDj9JW?Gb#s z5A{YOoi(NFMJ|{lgp83@6h1s<4ONHuaN|nu+rrJx~InHliEY!tRF$twfM-;+WyHPMYXBPs8 z#0Y%We8}~p|2!f5dkE&%#OGouPWpdy){Gs3T<6@&MMc)>X@UYPdCE zRhO1~%4aKawrO>8xQPo`m8IofR>!H~CLWZIlFh6grE?Sbxeb2X&sS~dCT^~%FuuDu z^pW~CA&V0i)T2BH$rf+y91dY(n5`zn59zaGEe>HWMs92kW7Wh8u2e%?i%FFWV2fFThV&s?Q+~#)^OKZyydYfEHC`=fFxiA zO3ORTjCdddQ-8s(K1%9FmKsx)Z7CE0l|Z1?i6G(Y?2ijAVOdiLVtAm%K}j8mE4tVp z1B-gZ2=hMbgA;wZ(7?Jyjw_OyN{UfUPZ(j!@l`PIg}(||Qy-QkQyvs`#Z2kY5wg=# zmBxr+DhZz3yu#GN)bFXKK93(JE1*Y=`%Q@L3WOD1*K|=!naPwH_5@(5KP;&u zqGLxCo^9wZ4GbKhL1^3q4>oSCmk?Tk?YawlZvmoKD6dFyRAxY_#BwAP)hR?Nr*vIW z%kBos;oNI5*RW2OEEx*JK%JKEhG`GfK!dngpv@q-d$b9~pA<85zt9kh6`;MrP|T=k zj3oNC`2E`fCyM}R+ZOh-VD~yD>H;(S9wZ z4misWGgLhc)w2#Na@{eKtB#R;NJITlP_;SigfeLGMcVQVSiHcqqSIh2Z4n?P{|4ep z>e>+%HG{UI7=nAUQbkrBl3$|ji0%(?53pO;y+XSjvbdidFYbG`><$xOFa|$^__fi5 zG?Y@E0x-}Lo4SOlUruSJg2oGUH;Q+`Sb^lC@+MoDV?I!3waU68 znTq(pagE1JMVI0R^}{l{j}`j6UFhuXSKt&W?4fgBZwG^uZ7t1$;U?}xYHtOdWN}U}LOa?8?igQBch}L~d;qqM6RYrl2O*f? za|Y3AqYui)r|rVtq?H++%LwV*^xnKMn@MNJv(p)2LBf=y0;3O}Yzz~1D4|_t1xIKE zX2=gkf)8%+;fUSagK!+}bik4Cp2SyVzIUF)cR%y}>PdVVq2$v|OpqlS=_!(Z(}c7g z>uVsZIKUU9febeA8x(jHA4U}XJle3eaBQ24#MhS|{2M}}cl-LmSRZXVA{Ynmk19E? z87W=CgW{Z(5dcO4K)~R)&Za$bG(ru${L$Uh2zPH#))Gnh-8Ue*DeCA52X^1_q^S?4 q)S<3Wku+^h%Hxy30pu!x-1p<-QQ&|stDHxa^i^)-E|RO`rP9A8IzT7@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST new file mode 100644 index 00000000..bb86457c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: function ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 87 ;; ;; Created By: Karin ;; ;; Creation Date: June 5, 1986 ;; ;; Last Update: June 5, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-function.test ;; ;; ;; Syntax: FUNCTION fn ;; ;; Function Description: FUNCTION returns the functional interpretation of fn. If fn is a symbol, the ;; function definition associated with that symbol is returned. If fn is a ;; lambda-expression, then a lexical closure is returned. ;; ;; Argument(s): fn - a symbol associated with a function definition or a lambda-expression ;; ;; Returns: functional interpretation of fn ;; (do-test test-function0 ;; ;; the following two test cases were copied from page 87 of CLtL ;; (and (progn (defun adder (x) (function (lambda (y) (+ x y)))) (setq add3 (adder 3)) (= (funcall add3 5) 8)) ;; (progn (defun two-funs (x) (list (function (lambda () x)) (function (lambda (y) (setq x y))))) (setq funs (two-funs 6)) (and (= (funcall (car funs)) 6) (= (funcall (cadr funs) 43) 43) (= (funcall (car funs)) 43))))) (do-test test-function1 (let ((funlist '())) (push (function (lambda () 'fun4)) funlist) (push (function (lambda () 'fun3)) funlist) ;; ;; (function f) is same as #'f ;; (push #'(lambda () 'fun2) funlist) (push #'(lambda () 'fun1) funlist) (and (eq (funcall (car funlist)) 'fun1) (eq (funcall (cadr funlist)) 'fun2) (eq (funcall (caddr funlist)) 'fun3) (eq (funcall (cadddr funlist)) 'fun4)))) (do-test-group (test-function2 :before (test-defun fun (x) (if (evenp x) (function +) (function -)))) (do-test "test function2" (and (let ( (fun1 (fun 2)) ) (= (funcall fun1 2 3 4 5) 14)) (let ( (fun2 (fun 3)) ) (= (funcall fun2 2 3 4 5) -10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ae6cbcb6f53b4198be8be6982176e1576948bad2 GIT binary patch literal 1275 zcma)5%}*0i5PxrLKcKBy5Oq@&R*WWYTq5EpBqrMYvTtES_MYeR;4vb(>h*<0tCuH>hx`5Dz;$j{GA zUD>Pl9950EO0k6C$PrWz^&L3S*L$$LdC>5z2HStc96a3D+uPl|`t%W(%Z#yUwnCzb zF_}eJaK9#NzVLi~Fl!0jHb#UN)Pq_AYteI_aD!UQezjVj(@Xiw`4W|Lah`F;f_t^Z zV9qxEtYZgDe37SuyR~%I)<>~4OqH^Eqnv6bSq5|+A_fN%PlAbz1Fl~TA77iK9%OR!C9;^Tmk7|K8y{8YClW zXo@7UWg9i&x{j+mIe#?gYmpQNq%^~x)I+St&taR*8G04RiS6E+)ok??U) zu8}lA@lmczwhxqJkU0eH8nkDiV=Hu~k%3D=t<%rXSJkfTMwdD}h3|bvEnaFoRkB^* zMTtHIOL%hcml>test>quote.test ;; ;; ;; Syntax: QUOTE object ;; ;; Function Description: QUOTE does not evaluate object. It simply returns object. ;; ;; Argument(s): object - any lisp object ;; ;; Returns: object ;; (do-test test-quote0 (and (eq (quote a) 'a) (equal (quote (1 2 3)) '(1 2 3)) (equal (quote (cons 10 20)) '(cons 10 20)) (equal (list (quote a) (quote b)) '(a b)) (equal (quote (setq a (quote c))) '(setq a 'c)) (equal (quote (quote (quote (quote "string")))) ''''"string"))) (do-test test-quote1 ;; ;; (quote f) is equivalent to 'f ;; (and (eq '1 #6r1) (equal `(1 2 ,(* 3 4) ,(list 'a 'b) 5 6 ,(cons 'c 'd)) '(1 2 12 (a b) 5 6 (c . d))) (equal 'urthelorj9037958u3270-ikorldflgkdjmihret02-38 'urthelorj9037958u3270-ikorldflgkdjmihret02-38) (equal (multiple-value-bind (a b c d) (values (list '(x y) '(w z)) (eq (cadr '(m n o p)) 'n) ''quack) `(,a ,b ,c ,d)) '(((x y) (w z)) t 'quack nil)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..98eb79a3c4e0305fb887ab32b2d762bebcbb9eb8 GIT binary patch literal 2601 zcmb_eU1%It6uvXN*=%-`&1M^#x{c|Wq^Mgbvi&zII6Hgy$IQ-5XYO$53mGipg(059jJ~r}v zHs-cSYK!&BMtw?Q%k`zH$+w?Tvd<~n!s5&<3{IYe>G9E{M@Nqw8;KP(*9g!az~90!fNuB?u%ZCILCq(qKxpdh;BH+xU0 zS$JHV>SfJP3zkz+ZE|I;`ywIIzdcDAqq;GDb4D@_-1rrUYa# zAj9i3H_sB1y4c<)O<#XCv2G<`dV9sVWF>A9vNHXll^BzyE*M^WteQq3kVgsWBxHT2 z*1!IZbiUQ+?Mj3@PYC7-VeV8T&iq>cL;Fhk%E7<3El+@gpI8ZK1z5wz6l@S zfFFKncmR4i4Uw)-Cy5;QKWp}9bj!?_v6|G9X66m*sJSw5%%Yo-yLgA(0dExE2)u1j zwmlhLV|qz-DDxaBJ6+Um#GP;%t;jNH^ah2k8&oqrTU4Bz;gT%vwq{m_$3vaGBNT%& zPGqR#SdMCW%=TC&lmLUyjAl-#f{!4fZr~+ai`mU?^$k{hD7j1FFi(YgfSWR5k=so{ zlDe-1Z2V?2yQ2d;+X>-eY`eYKJ$E4HFg>jqIQa`E5$rCF;q*^{?a@8Qp=L{ua|va? zfvopl-gV8T!3udC#b3j|Bo3Mu!2^I1WxQQL4r>WE8h5RB^$xlL++z3=ZWfXp*$;4tMNCYU$lSMl2)S25XWP!IHnQLU zfADMoKFbGDu@=CvfRy+!GKax>j|gqs#&3ib3oOIJgxm?pkM}nToRMq7gj@}DeLi#+ z)O%aORa-4OmS^*n%?FEo=p-LXVkp1+%>%5y)KCU5XoJd`Nw}4!l$mqEg@U{b2T^Us z|H5CzHX6_!sxhkWC={d2sG}J!kE0r-^^|8Z8Z6{p{xm`y77#oG3j9zYQG|s2y+*oU zg8u)mv{FjqAW8gYdUkT|wW&#rWoN;|g(HcAhnn}B(m0$Mut^n7cdV@%l=(26+u)b{ zy2~%Q75M%5q5bmXfuFaw`>6TNk@ph$k%D1qV$|+32U-@HVU1Z8pwc1y zWZ)ChaxRjJHZDln1R}riB7DPi+-5){j%{eV2EHSX0e5;H;s8gUiT6DW^pfVFeg_Vq zHu7|9fXpcn>%>x+uY2zYxcp25mC{M-Pt2W6~@l=bdl;~|pe z3K)y?~^LVb5?!=h9OqMu-jP4v8pggcxJV1=2d`WRA=Gs LRYE>*+`aoBL0$Tw literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST new file mode 100644 index 00000000..6f1cdbc3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: special-form-p ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 91 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 3, 1986 ;; ;; Last Update: June 3, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-special-form-p.test ;; ;; ;; Syntax: SPECIAL-FORM-P symbol ;; ;; Function Description: SPECIAL-FORM-P returns a non-nil value if the symbol names a special form. It returns ;; nil otherwise. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: non-nil & nil ;; (do-test-group (special-form-p-group ;; ;; the values assigned to special-forms1 & special-forms2 are copied from table 5-1 ;; of CTtL p 57 ;; :before (progn (setf special-forms1 '(catch compiler-let declare eval-when flet function go if labels let let* macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq tagbody the throw unwind-protect)) (setf special-forms2 '(block)) (setf non-special-forms1 '(null listp floatp stringp atom + * abs max min <= expt rplaca rlpacd union char= char-code char-name)) (setf non-special-forms2 '(no-such-form1 no-such-form2 no-such-form3)))) ;; ;; -- An implementation is free to implement as a macro any construct described herein (Table 5-1) ;; as a special form.-- (page 57 of CLtL) ;; (do-test test-special-forms1 (every #'(lambda (x) (or (special-form-p x) (macro-function x))) special-forms1)) (do-test test-special-forms2 (every #'(lambda (x) (or (special-form-p x) (macro-function x))) special-forms2)) (do-test test-non-special-forms1 (notany #'special-form-p non-special-forms1)) (do-test test-non-special-forms2 (notany #'special-form-p non-special-forms2))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..72ad45d2ff7f2067dbde9a655ca88c27c63ada1c GIT binary patch literal 4302 zcmb^!e{36P_505G;RGjjIyX(-G&zFXY-X3GP1?0VtiGJjja%o=y*sxJnv}VTGe>jm z$Z;mRiBKwjOq0=;q>Jv`RwU4nhL}W&gxDxbgpfdj0Ybo#00|)^1pgpFNT3NVy!UEWq0lNI8 zW?K4Z##HUxz$cEj+I2fq_b6 zO{jKCXuAuU<0nT3PYkqf-B_c+5+P)YY$9kOBuIS3U8x46j&3_jBAL<^Lmk(n?y_6; zLo7qJ|KWq| z2)3XWFHY%4HD}t8x{;sk+{{mQ!4uvzp8ed-h(W;-K+I0p>@vegVDBk2oDWZS0jD8t z-2A<8Z9VS62LOs6D$Iw0H!N^a1V2Fun|s5PdpDm(9@vH4ZrLR_2qAd&XC&sDplnrXz7*b9^~)rhBbOBqc9#W-U}rFPaLwZYQ@ z%_bz8jh50?Ba>DVrZsLy8I}C7-waP9JPp9t5!F;j8&fRZ$ym@-G~Sh(>8gEBltNxh~O)nMS6j= zNL9g-7ke?m*$*Bx@)V&!H(>2{TGx^)bZiJ+Nh6sjcwE&i^L86Yatm-bCq~VT5$9|Y zczqA|dIvB4FSknHVBH`|H@IkiQA=8!+B_SihiK6N(LGn9@Oze2WW`SGXW~k##=7`WzNI&-SUTvzPS^1C#F+ z%t6{R&lre(iM#0gEZlcZ2A)1Ih6NVE%_%rZI?B3m{RpmAvA!VAL>EBfDx^2LjP!Q_ z{)9yUiQxj$Z&^R+kbW${4+L<5r5o;Gg(nd{tL?`xWUmSJPYAt50kYh*be??_^?p)d zBN*BFjOk!9q(O1y3J@F60@5Oa@qhsB0yJ?zx4@mY+^6TW#c8GHIQ<`YmHv}`9K`7# zKv%P+k3;sb1n95C?yCZPhuw$7m&N&hT^#z?SQLrR3ziiDxF7+UuZ=z9qF! zp2@k>P{4g(0?%TwwbTO*AzH5?>v^LCqC46W zL@DvM1$hCTW=vTX|pa0oa`ZXI>2I-sja*i zq@S#j9=LMg7lTK|8#IjnV(PE+VYtygO!jCP%r~j&v~I+GeimzBrzv{~X4qA*i+Pp4 z!Sl*ay`44bx?3F>8P%Z?>S7M&!#yuBe)zRhU$VVA7(hkSaK_;GU3lqTJ%mzrfFG{p z2{k2JgVugK*bugaXfq+$hSW$qOY>mW-1y+-)lau+_-)mb1C z@ftU@J-2#K4b_bcNy{|G;o<|`aAa6k{g^cRXO2MY^?Q=oLg^np7F_@0gL(eVI?+$z zx?l97_>R+|$K2}VJALfOpr-LNzWx1{bCtz%aY3G1ESGb|%6oj@axpsxU-RWFUIW1Z z26$PMw>}>m8X5uu`4=y6iQ^4TekA?UUG+nK1-!Nb14Kq=yyC>|$a>i!*l$cEE!)9D zv~~Pyk>rdetvKrV*&6AN!Hl)O58uoAU>yj;-1WX4gL)kU1|52-p_7I8utR>2aK9wiS46Sh#VmpU1 y#&s>FS~}AB@QVv)%rY;+qCI0=Ou_^J$#Hbe*}og{AA-E6JAiNz%fp#>>m zc?GBnJ%x`56>gb1Ksy49q0X*OEy^sewaLjWE=bNVO0`SQ&9N&zykp0ui!{uCx0JZw@^Rl5Kn(UXy`#*2oGVG)Z*l#%mPqo15H5J zQ47U=6^ql;p#2f`!EGVR;re)@3f}<-hF&F5oq)Jq~9E;LR zbAdWFiZziP3GtMIu0o;$$lp*s3i*sf05FUKT803VrcU5vs0EA+tOex^3~%fi7+&Rs zuDhhyxQBs}@ezY4M4sb}rjFQE2G-Aoat}X)^=M4Uoz1{|wSa-GjDtc)vhjG$W5i+x z^AJd)qfVq@2w+JQqe9dR0rdP|4b1-zp#0BWy}uVV{|lT0=YO`l7nQPK_JW)M&i~wn z8-V$rn?fh?27S`;z+wg~4U^WW(L*2vu%wAmA?k$ydj4+&=6^>}{{PmtE($gO^SlA) le;%$63K=`PKu&<<|NR$$`CouSCvjvx`67YE3>Io7Q2;$rMNQU)DLJTAC)1Hg!wl((UNlFO8XFd;Zfc znkK;xNQfX-Dpd~Cj$Al#-Bz&!;>e8y7cOu?z+pl{;#R)r*j2@fkS1>Hi<9^K-tYbV z{eJIL{B4uLE2SEgthTKi)B(%)Y~O>X<$!DXj!L14^Kh%QQZL_ryI5Mv6()uohgMXF zDjwB9_Nl8Woh(dTgre=}1`cLt@is3`Pm5DCx#3E&QR}n)*B(AE&diEaleyvj`@7tz zMF>&JW7hG6jFJ;1_^dm6UM@Fep;E1t1*y1PJ|Aoc-6U!e)*9t{&^3*NN~5CtgJ~Txw;|+JKX!+NbqSlRh5KQlvaGJOcKe6g|Tx%_w)r}0zZwb%kwKW z;oV|wtxWFkzIca_#2+l6hpk78+yj$*ytkNGKX>L7H^^q$H$}*!O+rrJ89KwY9(*m~ z_{sLtC(<{BY_~p?784vIw!a!%hj_;ugp3gKSXakGtugg4G4&8qeDtj3$s@=+_O}@5 zaeKZUNMy3_{2W=pkwH60$nP0Kel`9aSlatwk8s>i%vD!!?Dx@CfF!8`?- zy7)d9VT-Ds<=Cl00Wavk@X&v)coE7pSW`y3PC$QIh97rVFNJ3MLjydb1f(fbN14 zxesXtERzbF-lnFD8x;c-$5A?&EGVW1Qndz_*P_l1-KDuGvZAx;Biu{78IkXYh2RdL zruY#NG717ch{M3Lk8vJq44T#~fk_uO9m}`l%;?{xcyWVbeMM7zI>czS>62Tfpzek57Ys7*~xH#gDVa3Kx|!hjA~4-O(clp~KKH=g48 zv_Vm48aF=`JQIchJT8_EGBbo;_jQC)6U%E1ELQ7T5Ngcja*@0oZUx|hPt)rxvVSol z!%oRxtjjn!QI;048?8!Jxmv6Vr4>moOLBuP zEtRigm#oxRmW4j-WT{#&)ygcml>test>7-1-1-symbol-value.test ;; ;; ;; Syntax: SYMBOL-VALUE symbol ;; ;; Function Description: SYMBOL-VALUE returns the current value of the special variable named by symbol. ;; ;; Argument(s): symbol - a lisp object ;; ;; Returns: a value - if the symbol has a value ;; an error - if the symbol has no value ;; (do-test " test symbol-value : a keyword should return that keyword" (every #'(lambda (x) (eq (symbol-value x) x)) '( :start :end :initial-contents :key :from-end :circle :test ))) (do-test " test symbol-value : a named constant should return its current value" (every #'symbol-value '( t multiple-values-limit call-arguments-limit pi most-positive-fixnum array-dimension-limit array-total-size-limit array-rank-limit))) (do-test " test symbol-value : when used with setf" (progn (setq a 1 b 2 c 3 d 4) (every #'(lambda (x) (let (val) (setq val (symbol-value x)) (setf (symbol-value x) (* val 2)))) '(a b c d)) (every #'(lambda (x y) (= (symbol-value x) y)) '(a b c d) '(2 4 6 8)) ) ) (do-test " test symbol-value : tests for global variables" (and (setq a 10 b "b" c (cons 'c1 'c2) d (char-code #\y) e (prog1 #3r10)) (every #'(lambda (x y) (equal x (symbol-value y))) (list a b c d e) '(a b c d e)) ;; ;; now unbound those variables. The follow-up symbol-value of those variables should signal errors ;; (every #'makunbound '(a$b c d e)) (notany #'boundp '(a b c ~ e)))) (do-test " test symbol-value0for lexical variables" ;; ;; tests for lexical variables ;; ( "symbol-value cannot access the value of a lexical variable" page ?0 of CLtL) ;; (and (progn (setq a 9) (let ((a 2)) (eq 9 (symbol-value 'a)))) (progn (setq a 9) (let ((a 2)) (declare (special a)) (eq 2 (symbol-value 'a)))) (progn (setq b 'foo) (prog ((b 'bar)) (setq b (cons b nil)) (return (eq 'foo (symbol-value 'b))))))) (do-test "test symbol-value for dynamic variables" ;; ;; tests for dynamic variables ;; (progn (defun fun () (let ((*c* 88)) (declare (special *c*)) (fun1))) (defun fun1 () (eq 88 (symbol-value '*c*))) (fun))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.DFASL b/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0d26c28278a354d114e2c9fd6ec019dfc0020857 GIT binary patch literal 2261 zcmb_de{2(V6#w2`2ko|Yos4Zx#QtFnX*`<2COCuaxLvy+-Q8?^6ht9p6x*cGxwVLl zrVIQb=wKEVS`3CrqU3ONAzcWJtyvbS|B_`QU@{Xi8F6uvtO6VSh*6^S8A%NYL-_o&9^d6yNdP% zcdA#`RKp$l*kQsLKnS&>6c##!jEF+9L)}KRi*veYYlEGmd8U~&$D*-rE%ZW*PRNeY#buBGbk9H z0GJhYCB2NcHZx5kzeW)GI&|!?b`L^?gzGu)9cU!ZZAYmKjikGzqL|2g2O;dxBb53t zM|@|e?MaD5l&B?lE%OO z@lN7K!rd!Lh$lJG2Ed&7W)e-d?eMUs;VxM&{GP43-*WiL* zo~~#3Iy>i}*EE2Iw>izEHm)P{;L*Tn6`NVc#n#gf&LuivG+1S}<~i3pU0gFsJRIQ? z%<%$BAJ^|myVD%UbG7`z@zhfY#Wi>+OYwMp z0Z8+#f}@#nVfAyIl@%Qhj-NC1aRU230$<6!=2*tbsj1=x*!?CT&9^GE+k*8sKrfgx z(AZ`L2+Ar5>Jp7m{rV~|J0(e%f4Mj+UtJPpS0^p2eo9Q9NLJP+CaA&5DR8>S!<{(h zc1{r|#A-lD3!RI>7Tb#Lud;+xv3_hi|IePii6e|{efSSACYUH&eY zjkF{tEyqJYV`qPOJ+^9d5v(N?arwHeXnPeQy(D*lPdcJRN=H>;v1TKup}ibVA(1jh zk#6J^amkvMcRf(d3N^6xu7Y(ba%Erm%0xITZ(LoQ=#p)Na0QN2d*yUeJtl6;w$zMO zmecEIVh_maw{fMT=}0>@y>lcpus@VKe>1c2?DVZn+5F5+I4HLL)4xJr`>vf@Tb)Pk z5_6Hdvzd|?Ze?(geEvhtf#lG1&vaSlre<|=C+z-MZc{Gn#@~o544W_FEVkTmy7QDZ zyZeU;OI3&>-4#FqIzNSXxI&>6!BBGnmIzp8!CaP!+UG2P)6DXhx)4Dyu1ub}bpycbbpoRYv6kbMS1tv2uFi+vXGEV`p4p0ZFg9o$F zJb3c(wm+7INWAmvUm$De7+!3lF>-9SRzAQ``F|7C0-y|X z2>@xhwTvAr&w+A}t;lj*|D)LoxcISbbunIo327w05Q}77A;Wi7<95}!Ni{A~jnAq^ Ky<$Y?u<G1( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST b/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST new file mode 100644 index 00000000..316761e6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fmakunbound ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 92 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 2, 1986 ;; ;; Last Update: June 2, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-fmakunbound.test ;; ;; ;; Syntax: FMAKUNBOUND symbol ;; ;; Function Description: FMAKUNBOUND causes the global function definition named by symbol to become unbound. ;; ;; Argument(s): symbol - a lisp object ;; ;; Returns: symbol - (same as the argument) ;; (do-test test-fmakunbound ;; ;; define some functions ;; (progn (defun fun1 () 'fun1) (defun fun2 (x) (expt x 2)) (defun fun3 (x y) (cons x y)) (defun fun4 (x y z) (progn (and (constantp x) (listp y) (special-form-p z)))) (defun fun5 (w x y z) (let () (- (* w (- x y) z)))) ;; ;; make those functions become unbound ;; (dolist (x '(fun1 fun2 fun3 fun4 fun5)) (fmakunbound x)) ;; ;; make sure no function definitions are bound to those symbols ;; (every #'(lambda (x) (eq nil (fboundp x))) '(fun1 fun2 fun3 fun4 fun5)))) (do-test "test fmakunbound - fmakunbound should return SYMBOL as the result value (p 93)" (prog2 (defun fun () 0) (eq (fmakunbound 'fun) 'fun))) ;;(do-test test-fmakunbound1 ;; ;; tests for some illegal inputs ;; ;;(every #'(lambda (x) (eq nil (nlsetq (fmakunbound x)))) '(3232 #\a (1 2 3) "string"))) (do-test test-fmakunbound2 ;; ;; this test case was copied from page 93 of CLtL ;; (and (defun foo (x) (+ x 1)) (= (foo 4) 5) (prog1 t (fmakunbound 'foo)) (not (fboundp 'foo)) )) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.DFASL b/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0fd7d9d097179656bed04e6ca57195351dcd4815 GIT binary patch literal 2162 zcmb_c&2JM&6rWi;iQ{}=n>3V!hDm5BSZs)s&_XzEHXAT(*6Hq=kQ3V28|<=)BY#AS zsv^XpC$}ZgM*B*mNt)Zaib|ut-l&U}N>$VlMQ8FOZ!`XGlsRuc}p|>W^zK*E9y*iWIrF;GV)RL`IqMV@n`J#C! zt>%o`EM1~}UNL5M&6H=d=rPV&X{iG`r8fLWktNBrs@Upz+0^X3iMOl*0U3&mG-55e#+Q1DY2o`#VLIC2z@3`1%VQVBY};5YHfacgz4 z>RfBAEmsoJSSuGbF&)XECf5WMkon_Ch(atM=^RP`DN3JU)V#UD+w!Y;n#5NlWCmTm$kAmi-1oNANp0m1KbZGZW?84Mr?27bbMcu8txuocMEe^+` z_&bPAkuG0`BsGhp>>;@XNtzVC2ua2$li_Wi3KO95$EO*2OV2W#d_@NM0*CyTdg1LT z3`;Q><1ikg_HVQ97HWX^3aqEqAjl|UaSkU#psxQ8bTkCYgg|UNasV?*au$4f@Rfq( zBniePJW*nh`S(O4PZQ<);hjhv#yj97hwupYr+?SKBVl)kR8v!IP2Mxade+uVMYo`f zmf;M%pU>G^$kN~N4cSY$al9Y)E2K$$zu*wz;}o@q|+o^^%LuTEnZ04aaM^;@G-#)fHzZMP)^(dR;%R OLz=&M0{b%i`0?LG-CZ*P literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.TEST b/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.TEST new file mode 100644 index 0000000000000000000000000000000000000000..ef117865bfb9dd08fd7b6a2ca21d6b3882b14b2d GIT binary patch literal 2239 zcmeH{&rcIU6vt=VfThqRd zfe?99Q?X{b9;@Oebzg`%yo`xO8VMGgjQK7vnz9Bf5hyotzXemaL=BVh%+@f(A3}6t ze$KHdh{S@bQSa^p^)LsVo17)(~_#B86}hH&a^6?mZPU`A912@BI_>b|j~ZD>f!|vB|m<1jCdS)~56Hb1oT=Cue3O{+v)Q zT-#@MHW^Pu{69~QxsXn?m(V$zMi2@iFY3H$g{CXna)r+=7qWa&SjkRz+MSk<=E7IY z*|kn(D!&YFq$gk4WgeO_#@i`Pm z=Q^#x96!TnpI3##DmpnHKS0R)Z6f4hT0S<;^4zJ0tWSB*I)o>OcCb`Dx z%iwt_NI$=~3x}oPXN1~~SEXRy!v*N;`^ojY48eXrgvJm$m!+w0hA#DsOZ8C*eZtN} z-LD(N!Ac5Dta1dNE$eN Zg(Sy@O_x1rJM`3kNI2Zf7EY!k=ok3f#2Nqq literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.DFASL b/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..dc75ea23d3c86ed1b028641a7b6ebc6d99db0d66 GIT binary patch literal 2154 zcmbQpz#8G~qu`vMTacNPTBML)T2fG2qL7wfq)?n+T9llskOmZ2sCM=ba;^1nboSP> zHslIMl1VN~O)N=GQ3xqbElx?S)KM_BRB$XP%FF>WEG&RrGbhl3$>klUkOV1M*I8F#{t5!;A?%9B!e0&LN)uelsRBHZbzc z=u}d*#?A+%EWPh0G-RpOlfnj1so1YgGBQKD(K|EXy zq#J}e7#MgM81`o-Yk<85HIUH{W*~bGOS01b9Oh(&{W(m@GW)ZW<@RSx%Gi(|E*CBn zt`M%2Aq4~=lg?}k0#U%g0jkXgD$U`8s=IRPH_BGqp<*wgCL+kUyj)rcP zjo9%gG}QOb%7h&+RgQ6x3`5g?qOhLe8eCMk>S;S{O`eYniVzwvx@`s|8)kY83OVT+O~k4 P0LlNW41oDx4!@HCKe48W literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.TEST b/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.TEST new file mode 100644 index 0000000000000000000000000000000000000000..7737ac4e81404d72222a5fd42f70383f1ff09f86 GIT binary patch literal 2251 zcmeHG!A?^_6rG}0L*i26M!Xsl0oxba5Ruk20Sgh)MDpr_Xx#7z%*=a$lA0Km1xarvv$%8az2~0HDVJfo#UsN6hnj#% zgc@pt^%6*p=Edc5*&YZ*OGQ|MG(v+I<1GyfLM*vlh)IXBpb!*GFrhVT@FsF|Sn-55 zZ25RG?RQ@xwL@TX+4r2Kig9=xK)8%QBOIx!1(x7pizAHYpfG;-PKtO$wSlLy?%%;7 z)^GfZm}aq^F`;4D(^x^p^ycA2EP1J1bq@fpIEFPBuRR|K5BWzW%dP}NkoH+wQx^bEc z^bFU)0Xl2kfxtF zc(glYZ?oiQ3S)DHaoL$K%#M$}azO4LkhSTVi4rpX{U|_*out-zhgFO*Ml@(~cWV1U66zoxA1W zQ);(*ShWp@U0&X`$k2i6_@a1Yn6I4S{Wph2uB9c$YhPgOr3S{3lmyZ>V%n?BI5D}l zT>DxszLx7)TmR@9d!r=sZL1|I-@Zzg+e;X+NKxdR>sY@&jsnR+l!-PG2-!Mw2iEeP zx36oy!{%?X1^>`tHMbx8w5dkMv!HGra{GngsJVT%=>Ok9Vdr9f3oovGX_BFG;=Fl_ zu}blrIV?EBRj%&N$#iJ61{jNAf{DE1y^d-dzNxmMp8Tp$Y*!dVNTQ$T^hn7NQ{Y0fS3_v>LDm<@u@*YEUs&gKBQWP zleKU@b#K7y>`~h>Mg+gt!%4>>CWRm

f%VQB|3gUCd2${XW`Wu+}OopmxR4DZ z3;z>S*Co={h~|*^JBG&etYsPIw&ev*wqMZJwAD^svkkvCh>`hgM3Qh3iN6U7k6BW%GRXaD=p@qX6XvC6e|f3duU=}lLT64H=5c2TUD?Mdh6!EW(tQZZ0w}M7 zG6TvfQ2IbQ0Lng4T0wb?;O|hO-VKL!9QF(S32|z@mqi{w;9XW{Qe#sjehW_!`3gcr zK8HpkS6~N`H@Aaz`(SerCsWA}d)_BH>?37AbP!R2N@0I&kM8oK+0R}y`_T(y-}~ei zw37cd*hA!sFMSHlBz*!+MBejlmwa2rx4rG#-h!5SXq$wGU&Ms9+F&P5*mJOF6k5Ar z&*RYA4$TiilXt$~-11(hFgqtJ3z{OI9>Z_cxIA&j|GbcH!Rw;ye&8+%glpF=LvsxE zuIWl89mCR6HpIvcyL&R5b_~BW=im@l%tzfN35Pl0F4b`%)dYf`EV#f33CCOng5;K1 z7E!!ePU0n-@$TRZeWxHIaR|BP*3#JIsqrzY@Sc5PqPj1l0hC&-qJCp!IS0IK3H|7D z4WVaFT4Ba)!uQa3AbO)DAS6i;c|ew$%`6d6>M={5zXMxIx|VBVeiHgz{KqUj1j-h4 m=VqT2uWfXucI3DqF5tZ-=t2c_`-61{4)K3#+502w>wg1UnP4>l literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST b/internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST new file mode 100644 index 00000000..c0391b6e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 92 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: June 4, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-set.test ;; ;; ;; Syntax: SET symbol value ;; ;; Function Description: SET causes the dynamic variable named by symbol to take on value as its value. ;; It cannot alter the value of a lexically bound variable. SET returns value as ;; its result. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: value ;; (do-test test-set0 ;; ;; tests for global variables ;; (and (= (+ (set 'a 1) (set 'b 2) (set 'c 30) (set 'd 100)) (+ a b c d)) (progn (setq a 2 b 3) (= (set (if (eq a b) 'c 'd) 100) d)) (eq (set 'ab&cd (+ (set 'ab 9) (set 'cd 20))) (incf ab cd)) (progn (set 'foo (list 'a 'b 'c 'd)) (and (= (list-length foo) (length (list 'a 'b 'c 'd))) (eq (caddr foo) (third '(a b c d))))))) (do-test test-set1 ;; ;; tests for dynamically bound variables ;; (prog ((m '(1 2)) (n '(3 4)) (o '(8 9)) p) (declare (special m n o p)) (defun funlist () (declare (special m n o p)) (set 'p (cons (list m n o) p))) (defun funappend () (declare (special m n o p)) (set 'p (cons (append m n o) p))) (defun funbutlast () (declare (special o p)) (set 'p (cons (butlast o) p)) p) (funlist) (funappend) (return (equal (funbutlast) '((8) (1 2 3 4 8 9) ((1 2) (3 4) (8 9))))))) (do-test test-set2 ;; ;; tests for lexically bound variables ;; set cannot alter the values of lexically bound variables ;; (let ((m 1) (n 2) (o 3)) (set 'm 10) (set 'n 20) (set 'o 30) (and (= m 1) (= n 2) (= o 3)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST b/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST new file mode 100644 index 00000000..6bea2f53 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: setq ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 91 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: June 4, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-setq.test ;; ;; ;; Syntax: SETQ {var form}* ;; ;; Function Description: SETQ evaluates the forms and assigns the values to the corresponding variables. ;; The assignment of variables are performed sequentially. The variables may be lexical ;; or special variables. SETQ returns the result of the evaluation of the last form. ;; ;; Argument(s): {var form}* ;; ;; Returns: the result of the evaluation of the last form ;; nil - if no arguments are specified ;; (do-test "test setq - return nil if no argument was specified" (eq nil (setq))) (do-test "test setq - return value of the last form" (and (= (setq a 1 b 2 c 3 d 4) 4) (equal (setq a (1+ #3r111) b (gcd 3 7) c (string-upcase "dr.livingston")) "DR.LIVINGSTON") (char= (setq a (progn 1 2) b (prog1 #\b 3.99) c (prog2 a b (* 2 a))) #\b))) (do-test "test setq - forms are sequentially evaluated" (and (equal (setq x (+ 1 2 3) y (cons x nil)) '(6)) (progn (setq a 1 b (1+ a) c (1- b) d (incf c)) (>= d c b a)) (progn (setq a (defun funa () 3) b (defun funb () (+ (funa) 2)) c (defun func () (+ (funb) 4))) (= (func) 9)))) (do-test "test setq - assignment performed for both lexical & special variables" (let ((a 1) (b 1) (c 1)) (declare (special b)) (defun funb () (declare (special b)) (setq b (if (= 1 b) 1000 -1000))) (setq a (incf c 99) c (decf b 99)) (funb) (equal (multiple-value-list (values a b c)) '(100 -1000 -98)))) ;; (do-test "test setq - there must be an even number of argument forms " ;; (not (or (nlsetq (setq a)) (nlsetq (setq a 1 b)) (nlsetq (setq a 4 (+ 3 4)))))) ;; ;; (do-test "test setq - illegal arguments" ;; (not (or (nlsetq (setq 43)) (nlsetq (setq (3 . 4))) (nlsetq (setq t nil)) (nlsetq (setq (1+)))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-10-CATCH.DFASL b/internal/test/LANGUAGE/AUTO/7-10-CATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..586ddb44758eb0ca036e6caaa7794297f3f50add GIT binary patch literal 8052 zcmeGhYiyg<_1^FEBTv_Pl%{D(Kl%idFKt>vA3PS z=(=j%#$*O{0>>*%)v`GlEbMCQSrwJ)g ze(VQQKA(HfJ@=e*&pqedb8n6?<7S6jb0i0cV(~~yOOB+6M$+2OWJ()Oj-7=z=}5m87>Nw`hxRpVt!p*=P%0LO#+o(Iy>{I-*Q{IB z)>6@F_q&PPMdz$uw_?S**0n7a6Zd7gHOUwYvvCCFj9Hn=az`^(TfpfL=$$=or|z-$ zI&HZlxl9?XMGyL&zFekerIt<(>G8xw|rDok5Qy(Bt*wM)^TrmAf-j z-Q&^wU}^R)CsWGuT#!4@WvW-}tt)hgJ>ckO_hqez7&FgGFt*@ksm`;}lP*4%V8>3m zlue5pYq)6_V*{wDEAfa}-l^wa z)TtY%b?PVC9VJd}s4X~kb=(Y|7O$Q--b^j?#BnXU;p2J*op1mH66e*k4fTozTM%Ex z2)np4(?=L^2A2o9<8`G^IBm&r@+%Glf{2xjB z>`^m!+Ne2}D%lmYUf7iy#KN{9I4u)@q4TALMw1MUsFf)-xqCA6Z4R%eqX*Abz1!~T za65ha`X0b|y8Jf9D$12vaA?=lq3v)x?Vezt-s$!A`fY+M78v8}izhgqy-Ee*?4nAk zg2|QeRl`>fUzw;@OaP5QP-Bxvv+i>Sf<8FK9kL8C`M3B3&R&I2r3iR!!m8Gaa~83o zK7x)37iJG&_rIuuBk1!vJtf78;5ha+jMbkvo5SvRl3amxhUo+h8#=vSx2VGI<6<6y z+eHI{?})hwc8f*?y|4rIerKRl_iyQ4?{({i8V3iLfJU>X!DH!Tl5T#C(O+N$Rr`ROQiaam;9%ElD{n}`J0lGzbYyDlai9>i1H4iJV2DYi84u)T}0VJ zl#7V6o+zt`(kLm}IZ4TWD=FESq-2juO7@Vr;(%z_FXj%2#=T%ovx@G~=ks=Xpl3QK z=a|kw0d4Z2cS~n~UM#`E0UF#vJwJg?^4DvDO=V}V-4*mmcR~7vG_(LEYz%q>PDIX@ z%9&~bX+T#-T)8APenQ|~0&fv`9d^>(^#U}(MU>YQSc)W&rQ35{@I*zr` zSTi9nCtw9GhEBV06|rG*Wy-%q3(QddE?1_!Ay=lnE?1`fiN=0MV2r?%1b&+5wo-Ca zvc&C>SdQGjN!&(=TZ*{FXlxq+FM%!s*NcTXubH?sP;WMIsU$9Ck_(@ZWBfw`e}di&Bk+J&^bOIp zNi69WOIC|!o6s*8`Uc==`Y@MSla36hwQwjMj%rJ_bTpORqv_h7Xe2>MxYNgmwUD-R zBoR)>k_j!8+BGs5Nu+W9d%4Vl0M1`{z`ju18G@^RzZOf-Egf+OWPG2>jT(@=9e&hr z!wz68CD|j;R8-j<&E1XeLzlR!1G!Agy7f*t#GG{Vm(Ll}PI8@v1s?F{myA(h>dC6twntCYaMcBM z(#cy+^}0X);J600CtUCyzk;jxA#)|%YvKyjp&J@c^bVXk^{oxoW3Mr&Mrsrl7HNiD z9f}o+KZOmns^~EEh;fU6sOe{-lsYrihXDkuX4%ktPkS48w z&mq9Z_(qo3!TL7xXErKfWxPAu2up+a6)tX^S$PgmDO3P)EbC_XcwienP&fp-ecnwv zltMu#>?!BMDHS%pOiIec{6tCnUeS$;jAU6^TmcimVr4T+hA=8fR>f7&!RZm=DAROD zNxM~YH+(FeP^_U5EKLmm%w;xD8#w7`1dKL35|?jagBUxJ-J$r1eB;^?0n0@o$RgTE zVoxm5A4}}ghEmCJWO!H$CkG*{po#q75~~pWA~y)%eFw-@T$T&9r{!gP+OOmaNKl7PJnFovwM z_WZk6v~i2P#GX560_*)dm)aONb6- zOu*>~fN8*UIn*#_huiB9`kcrY<4^5cxk{alQ#^2iaeE!$%d|nlS}VdP&jNH=My)^;mo^&u^+>=zZ`d- zVx~3Wk}w%k)iH=QNMx8Wpt$~%m z0P0z30QEsg*HB1+!*GYF5*6TZqpAP`Ca{B)*{pIyJDkp2PkDmx0^-A9_X|oR zSV=w-LL2@dHuDh*09;vtlUp9uGbBv7?3WnLuvVnnglnZpEyqKejyiRz&>Ky3<@lViV+OSo{}j^Sx)lg^$?;T zF9_J?A4%E#?4_H#L>hmdB*+URoTVsDwvUjsfzp*;vZ+^0S}FfJ$&=U1btUa(B%7DY zzGN%6PLj?3P4eUw^$#WOQ&Kj&eR44D$z@iRoC&&2_dAmP`!L_<0}}3=2`x4_6pw{t zX)KU;C5FYScF5mwTf8o-G+@$ReIi~Rua7rX%9L#VocTEKxMG`HFH%;Ks-Tbt-+_bE z)IJtBP@!`1cml>test>7-10-catch.test ;; ;; ;; Syntax: catch TAG {FORM}* ;; ;; Function Description: The catch special from serves as a target for transfer of control by throw. The form TAG is evaluated first ;; to produce an object that names the catch. A catch is then established with the object as the TAG. ;; The FORMs are evaluated as an implicit PROGN, and the results of the last form are returned, except that ;; if during the evaluation of the FORMS a throw should be executed such that the tag of the throw matches the ;; tag of the catch and the catcher is the most recent outstanding catcher with that tag, then the evaluation of ;; the FORMs is aborted and the results specified by the throw are immediately returned from the catch expression. ;; ;; Argument(s): TAG - a lisp form ;; FORM - ;; ;; Returns: anything ;; (do-test "test catch - the body of catch is an implicit progn" (and (eq (catch 'cat ) nil) (= (catch 'cat 1 2 3 4) 4) (equal (multiple-value-list (catch 'foo (block blk (tagbody 1 2 3 (go exit) 4 5 6 exit (return-from blk (values 10 20 30)) (return-from blk 200) )))) '(10 20 30)) ) ) (do-test-group ( "dynamic extent of tags" :before (progn ;; ;; test cases copied from page 39 of CLtL ;; (test-defun bar1 (x) (catch 'trap (+ 3 (bar2 x)))) (test-defun bar2 (y) (catch 'trap (* 5 (bar3 y)))) (test-defun bar3 (z) (throw 'trap z)) ;; ;; (test-defun far1 (x) (catch 'trap (+ 3 (far2 x)))) (test-defun far2 (y) (catch 'trap9 (* 5 (far3 y)))) (test-defun far3 (z) (throw 'trap z)) )) (do-test "test catch & throw - the tag of the throw matches the tag of the most recent outstanding catcher with that tag" (and (= (bar1 7) 10) (= (far1 7) 7) (let (var) ;; ;; this example also demonstrates that throw returns multiple values ;; (equal (multiple-value-list (catch 'cat (catch 'dog (catch 'cat (catch 'cat (push 'a var) (throw 'cat (values var var))) (push 'b var) (throw 'cat (values var var))) (push 'c var) (throw 'cat (values var var))) (push 'd var) (throw 'cat (values var var)))) '((c b a) (c b a) ) ) ) ) ) ) (do-test "test catch & throw - the tags of both catch & throw are evaluated" (let ((b 10)) (= (catch (prog1 'cat (incf b 2) (decf b 10)) (setq b (* b b)) (throw (prog2 (incf b) 'cat (decf b 3)) b)) 2) ) ) (do-test "test catch & throw - the result form is evaluated before the unwinding process commences" (let ( (a '("path" )) (b '("path")) ) (declare (special a b)) (and (equal (catch 'foo (unwind-protect (progn (nconc a '(unwfoo1)) (throw 'foo (nconc a '(throwfoo1))) (nconc a '(wrongfoo1))) (nconc a '(cleanupfoo1)) (nconc a '(cleanupfoo2)) ) (nconc a '(wrongfoo2))) '("path" unwfoo1 throwfoo1 cleanupfoo1 cleanupfoo2)) (equal (catch 'bar (block blk (unwind-protect (progn (nconc b '(unwbar1)) (return-from blk (nconc b '(returnbar1))) (nconc b '(wrongbar1))) ;; ;; the cleanup forms of an unwind-protect are not protected by that unwind-protect ;; (nconc b '(cleanupbar1)) (throw 'bar (nconc b '(cleanupbar2))) (nconc b '(cleanupbar3)) ) (nconc b '(wrongbar2)) (nconc b '(wrongbar3)) )) '("path" unwbar1 returnbar1 cleanupbar1 cleanupbar2)) ;; ;; Page 142 of CLtL (In the process, dynamic variable bindings are undone back to the point of the catch) ;; ;; ;; (equal (list a b) '("path" "path")) ) ) ) (do-test-group ("test catch & throw - when catcher is a function argument" :before (progn (test-defun getnum () (declare (special numlist)) (* 2 (getnum1)) ) (test-defun getnum1() (declare (special numlist)) (throw 'catcher (pop numlist)) numlist ) (test-defun fool (m) (let ( (numlist m) (newvar '()) ) (declare (special numlist)) (dotimes (x (length numlist) newvar) ;; ;; feed whatever returned from catcher to expt ;; (push (expt (catch 'catcher (getnum)) 2) newvar) ) )) )) (do-test "test catch & throw - when catcher is a function argument" (and (equal (fool '(2 3 4)) '(16 9 4)) (equal (fool '(10 20 30 40)) '(1600 900 400 100)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL b/internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..771f873b59bfc76a90daf6f899e08449b2300532 GIT binary patch literal 765 zcmah{T~8B16urCsE-h(^CSr_ENO;*eO)F@zzBn#Z+Oo{T?5veXQWo2!(54?I#z>40 zKCRJ0B)b~^gRh8@2mg@&0B2hx1Rs2wJLldx_ndoY1d(UDf%ML9x7Bufs52aNhXb_J z>7jmS*lRdwN8;#}ZgTp%LiE+#qe9ZUlxg&wt%0+R#L($)Z@s*W3J($K_F8QjEG^0F zgVN$+Y2kh@Stgb-Vf*i!VkuuJ5AiNCBL+8Z)D2rj-FT;(c;&X}ZaltAR9J zA#B;896zZ_gsoVb8kU~3nofjX!JG=4OU?S&bky3k1YJ{=e=CHk`BR~op9saJ&uNWv zZgOneV%-*6C?OxDG{QFV7`HTE8qO51%qR>%g%tUs$h_S`$d=?~D{KAA&1 zTkcml>test>7-10-throw.test ;; ;; ;; Syntax: throw TAG RESULT ;; ;; Function Description: The throw special form transfers control to a matching catch construct. The TAG is evaluated first to ;; produce an object called the throw tag ; then the RESULT form is evaluated, and its results are saved. ;; The most recent outstanding catch whose tag matches the throw tag is exited ; the saved results are ;; returned as the value(s) of the catch. ;; ;; Argument(s): TAG - a lisp form (which returns a symbol) ;; RESULT - a lisp form ;; Returns: anything ;; ;; ;; The tests for throw are included in {eris}cml>test>7-10-catch.test ;; (do-test notest t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL b/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d8bc20a010855b7a0897ebf0fa5615ef4f6e3baa GIT binary patch literal 6621 zcmcgweQaA-6~FI2Cvh6vbsWb@vow8#tOV0%IUh~iP)c3Ljq~EznLn0(X_f0Zb=Frq za-5Y4ZB!HAvNp1S@dFhoVhkh%)tCfjLzbwR^q~B=X%Z3w2_%pvjs1a`gw&OD&a)GL zq{%uOqP%;2&%5v4-#x!`&pG$4vZhnsfauL!URqR=SuwMcTUyD93z@9AoLR{xlHvmB z#m{;}Vc*k!k9XSj$)R15sym5nGM-D$i_w+j@_hX20deSv=vm4xD)8g*Vd##HkB*Ly z9CYnE>4^mNw{82(p>g-n_>kMR>)!POXU#Ci60C%xl`$(5Sn-9t)fx3gqSDE!fKLi~ zW_-@#YB6twwMemuFI>#G4~x0XlB6V`N-DUV%gc;otoXIO@nkIMjZTGv#Wn64XDU9Q zH%|qnSy-B9(#LpX`7QW%u9)vQBn`QxSa5DCI3dl3Ls6eM%B~l7Kg(Ftduhh@ogrMW zre2%oZl&3me?865_4l-M&4~6AHWt8)^3H1)8M8gx;^0!Z&Ra?$3v}OI4Ll#R+-7Vw z^`($yn&-^$^JdrF06u`1kueivrNzYlnrZ%7nZ}5Nc4``KwK7d>O1^79T*7vo+N0DS zE1?Atf}P2B{!&fPqL}Z!+$n40vUXI~j-`5fdT`{OYpI842>wt7p&7Bc3Dq#QqtuRV zjnIDYu^;0`Q?S4Qh%38my4anO5Cu_;BzO`cz4IiyQ+=URk304oa zz0~#r#BN#Zk+oh~>uZ3xack!wzFvW7L5Nm@Wuw+ktpgxhWz8mQc3E>YK-{>sV-TAb zD-d@hL?gj6Q){Bu0uYU|W|lRRtXUc$Zrs{2h|Q)7L@PpM1dFHEKy5QXWU|J~nnBi@ z8z64n`fw0mNZoX77KB$*)D!Kq2bAb`pj!lG5i@?Y0`U(m%I z7+e4+Suby}FoCJL_h>Zt4h`e}tc%BVrC;wIA;Eq|O7=s&_f56SuR1=hcDdEAFlUo_=v54&~*%2ydb~6Lrr#ioJGAa2rgJO8Yf7cGt#M;u#ZobQC zvvt&N$CKgE3~aYzes3;*@j_<)D&lP1O|Y4;ux#-LLXlY5huexVVX(lCDXo5u-L*I0 z7Y$&u02&5(_%~=QAiDMBaZ72+s#m$Sr6-`_fqS(dCc*!_FgbFVF}}CJ+Wi`zW(lYu zE6=L~4P%dREf^w#5VQgzuO}c)hSWBIZz-?=rKJo&$0NL1?kZ>I=~r_JAmuGyBtrr= zsHldTnh_dUGT`WjeP#8AW@e!*pODH1F{`eg0_(@>4@}O;`aIwy`=fRqe(~^j^}xpK zxZSV|4Zc&eQO0*w^A3yNa0q5rKOzjME{E#kVCvR$v(d0W7MvbN-v|}IU0mZ~y?x%W z&lB}Yb#W^&74?NZfe0`R!(h)p7K8epHcQj-|J$Z;Bh;g6FA4y%wbLJLg<*!bKcv%} zbf@yTef#skFu5L+EGduIuiO?rKuX z?rJJk+|^R=P%Y{w;8DI?b=5kg5gZbb>JDk5a~3+Jx&Haxs(Tw({8Ysi)e)rWC**(X zD0r88kle~}y_k>OC)Q#lEeAS@ww4&rCPfIORq^%0RS3B8hDePrWKhY445`gr=$iL5 z4)GT_&o;rb_83RuN%4X;pm-&p`4Y2Ngyr>0~T|O>5HPckj-2c%c%qGFZ`P*5`McGMb*f?xXXnXw`XgU)JAN< zY3P4oYoMIA`Zf%Y#G%>ywxVv7v(gp=_BzYKzI%N;_0$mtJJDRd=6bfCs9{T3Xk=@y zn2$X~wur0?N+xj$jUUmef;>wBIZ*|*rV2?AReXUP*=A!kQUwPI+DiLqQt?D!`u^ob zbpU>(OwWF#M@i_!43uDdKn5Lv3|dT)&?C2ZB-@hm@Q89x- z+$F`1h8Zs1QXC|ww#fEFm<{mxA47qw^uhSik}`o zsJJHB^%Vm9R>h3a4sR7C-IWyqv)zgvhL4wMVMoggJGS}4*qaRtW3LzU(q`Oclev{_ zdRe@@qU08rl%({O5{J+8B9g;?L&(``aScB}a2|CJiW9o<>S96{K6MX1@s$GWz<3TH zvf&>OC-fO!9RM9ipApJOk>Mi(R_$%N3rl#oHmaRXD!$|;#=(h2|NR}(e3#nqQG0{h z?<3Xh^94p<&+$9}-SUSDmq`gJdkaiR)h_||b1hK%X!2FsoQA*aVuFNl oL*KFQ>*6d4?&rFAQ5UeU!CoBfZ9My!D`%gP;cuZCZ{551Ut9QvmH+?% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST b/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST new file mode 100644 index 00000000..e062d429 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unwind-protect ;; ;; Source: CLtL Section 7.10: Dynamic Non-local exits Page: 139 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 29 ,1986 ;; ;; Last Update: Oct. 29 ,1986 ;; ;; Filed As: {eris}cml>test>7-10-unwind-protect.test ;; ;; ;; Syntax: unwind-protect PROTECTED-FORM {CLEANUP-FORM}* ;; ;; Function Description: unwind-protect guarantees to execute the cleanup-forms before exiting, whether it terminates normally ;; or attemps to exit from the protected form. The function returns whatever results from evaluation of the ;; protected-form and discards all the results from the cleanup-forms. ;; ;; Argument(s): PROTECTED-FORM , CLEANUP-FORM - a lisp form ;; ;; Returns: anything ;; (do-test "test unwind-protect returns multiple-vlaues 0" (equal (multiple-value-list (unwind-protect (values 1 2 3 4))) '(1 2 3 4)) ) (do-test "test unwind-protect returns multiple-vlaues 1" (equal (multiple-value-list (unwind-protect (values-list '(a b c d e)) "this is a cleanup form")) '(a b c d e)) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting 0" (let (a b c d) (and (= (unwind-protect (setq a 10) (setq b 20) (setq c 30) (setq d 40)) 10) (equal (list b c d) '(20 30 40)) ) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting 1" (let (a b c d) (and (= (unwind-protect (prog2 (setq a 10) (setq b 20) (setq b 22)) (setq c 30) (setq d 40)) 20) (equal (list a b c d) '(10 22 30 40)) ) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting from catch" (let (a b c d) (equal (list a b c d (catch 'cat (unwind-protect (progn (setq d 9) (throw 'cat (setq c 99)) (setq d 89)) (setq a "cleanup 1") (setq b "cleanup 2") )) a b c d) '(nil nil nil nil 99 "cleanup 1" "cleanup 2" 99 9)) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting from block" (let (a b c d) (equal (list a b c d (block blk (unwind-protect (progn (setq d 9) (return-from blk (setq c 99)) (setq d 89)) (setq a "cleanup 1") (setq b "cleanup 2") )) a b c d) '(nil nil nil nil 99 "cleanup 1" "cleanup 2" 99 9)) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting from tagbody" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (progn (setq d 9) (go exit) (setq d 89)) (setq a "cleanup 1") (setq b "cleanup 2") ) exit (setq c 67)) a b c d) '(nil nil nil nil nil "cleanup 1" "cleanup 2" 67 9)) ) ) (do-test "test unwind-protect - the cleanup-forms are not protected by that unwind-protect 0" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (progn (setq d 9) (setq d 89)) (setq a "cleanup 1") (go exit) (setq b "cleanup 2") ) exit (setq c 67)) a b c d) '(nil nil nil nil nil "cleanup 1" nil 67 89)) ) ) (do-test "test unwind-protect - an unwind-protect occurred within the protected form of another unwind-protect 0" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (tagbody (setq d 9) (unwind-protect (setq c 7) (go exit) (decf c 3) (setq d 90)) done (incf c 2) ) (setq a "cleanup 1") (setq c (expt c 2)) (setq b "cleanup 2") ) exit (incf c 4)) a b c d) '(nil nil nil nil nil "cleanup 1" "cleanup 2" 53 9)) ) ) (do-test "test unwind-protect - an unwind-protect occurred within the protected form of another unwind-protect 1" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (tagbody (setq d 9) (unwind-protect (go exit) (setq c 7) (decf c 3) (setq d 90)) (incf c 2) ) (setq a "cleanup 1") (setq c (expt c 2)) (setq b "cleanup 2") ) exit (incf c 4)) a b c d) '(nil nil nil nil nil "cleanup 1" "cleanup 2" 20 90)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.DFASL b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0e32d81c629a70f495a48e2e8056608f7619d077 GIT binary patch literal 4859 zcmd^DZ){sv6~Fg6ZvHxT94kq^bb0BYbanf(Wi)M9rqNgXId)>d8|;^EL5$$V&TQ($ z!A{1iiYf}ME5nQ>8PU6iNqiVWLPLZA+S;y(U?7ADAb}>tBqR_ZO+ui+2P8f~IprzaE~b)a5379-srqywn}e6*$ALV0;>eK` z@9Xbv2Ig3HEgYc;iynG^r6f{JIp)=e{)*Gzcd zTp0SC`34~inG5EiLc!F+O8cW7sESV=Ax&^jcHAejRQ88HQt_u&dVr$a{DCdxH%dSM zkKX;X;$2^F+HR9T-2yo1SgkP!W z^-3K)weUFMse#sS@dtD(5Z2;`H4=x`4T#>~kr+)_MogjGB`oIWjgCfM@4$9%_8ajy zi)(De8XmFyjs{R@^6TcPCin?IhrVy=zjb^xItbx4I5ZAo<39kFc7#|wrdvpAcxqrI z9yiRYp~NZfb;6$aW{?3rVaTI+BWx>wfo)f8RErwsfE5nim}5ABaQ}C_9hWyDSFH)d z3dsSaRmK?Z{TTMVVlOcoJH?_~Hm~sxl=&9lh0F8YgUe@mD=z1_7Z)8|s6!Vb2`j|g zkflkjy;2L4iazSY!-g4@BJ|Hfg#KQL&{u_F`fXvDzAOyWb7j3C8#xs<%6d~$FD3O( zODZa<1JcSqX~iq7kUxNxdN@54iC6q1zvR2YP4Xj%yagiHf-Eo+gXHT7B;2_w?2>N^ zyW}&%F1f&4pW@zua=3BGF!=Nk?>fXgy7{ht&~td8uug#lq+D=g>@cy+Q6QCn@@`yy zB}?*iu+x%$dOA6k(ry+|=I>`xm&d)0w~U&28u5$J|yuKjTAG>)MLVDB7&#+D<` zu)-{;p!_`Fw;T3qqK4%M3eNn-GHHkGf&XC)BCMddx8pE;5Z;-?M5#w_WslatD?KD# zShl~2K`)l>4a5!IGPGO9eKcYjaXp&gjVJ~K=7S^5GGt#rYnNOSNCf~62J|W3i_4I` zk&yYk=LAH--diqY9PN z;l^Z(-WF=%kE8zrwR61R#gEnkYNz41dItYdkaL8}5(*z|(5_zk-xyUc%uIx7K z#Gvd%Lv$kf0o-`0{5abA`rTH2m|2d19z%o0xx3D;cK?vUfLmxfJ}}FpWl5~W;`e}PPb;8 MT*8z*fBpKu0RE(4p#T5? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.TEST b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.TEST new file mode 100644 index 00000000..f7e6d693 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: define-modify-macro ;; ;; Source: Steele's book Section 8.2: Macro definition ;; Page: 101 - 105 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 26, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>8-1-define-modify-macro.test ;; ;; ;; Syntax: (define-modify-macro name lambda-list function [doc-string]) ;; ;; Function Description: defines a read-modify-write macro named name. ;; modifies the value in a given location ;; ;; Argument(s): name - the name of the macro ;; lambda-list - describes the arguments for the function ;; function - is literally the function to apply ;; doc-string - documentation for the macro ;; ;; Returns: the name of the macro ;; ;; ;; ;; comment: May want to try the functions nargs and argtype when ;; the work. ;; a macro agaisnt each type of variable? (do-test "try a simple case with lists, cdr" (let ((temp1 '(a b c d e f)) (temp2 '(1 2 3 4))) (and (eq 'MY-RESTF (define-modify-macro my-restf (list) cdr)) (equal (my-restf temp1) '(b c d e f)) (equal (my-restf temp2) '(2 3 4)) (equal temp1 '(b c d e f)) (equal temp2 '(2 3 4)) ))) (do-test "try with lists within lists, car" (let ((temp1 '((a b c) d e)) (temp2 '((1 2 3) 4 5))) (and (eq 'MY-FIRSTF (define-modify-macro my-firstf (list) car "doc")) (equal (my-firstf temp1) '(a b c)) (equal (my-firstf temp2) '(1 2 3)) (equal temp1 '(a b c)) (equal temp2 '(1 2 3)) ))) (do-test "test creating a modify macro with same name as a just defined macro" (let ((temp1 5)) (defmacro my-double (number) `(+ ,number ,number)) (and (eq 'MY-DOUBLEF (define-modify-macro my-doublef (number) my-double)) (eq 10 (my-doublef temp1)) (eq 10 temp1) ))) ; currently when run this by its self it works, but when run from ; do-test-file it fails. ;(do-test "test creating a modify macro with same name as a just defined ;function" ; (let ((temp1 #\M)) ; (defun MY-LIST*F (temp-var) "dummy-function" (list temp-var)) ; (and ; (eq 'MY-LIST*F (define-modify-macro my-list*f (first &rest list) ;list*)) ; (equal (my-list*f temp1 #\B #\C) '(#\M #\B . #\C)) ; (equal temp1 '(#\M #\B . #\C)) ; ))) (do-test "test &rest" (let ((temp1 '(a))) (and (eq 'MY-APPENDF (define-modify-macro my-appendf (first &rest rest) append)) (equal (my-appendf temp1 '(b) '(c)) '(a b c)) (equal temp1 '(a b c)) (equal '1 (setq temp1 1)) (eq 'MY-LISTF (define-modify-macro my-listf (first &rest rest) list)) (equal (my-listf temp1 '2 '3 '4 '5) '(1 2 3 4 5)) (equal temp1 '(1 2 3 4 5)) ))) (do-test "test &optional" (let ((temp1 5)) (defmacro my-length (position string) `(+ ,position (length ,string))) (and (eq 'MY-LENGTHF (define-modify-macro my-lengthf (position &optional string) my-length)) (eq 5 (my-lengthf temp1)) (eq 5 temp1) (eq 8 (my-lengthf temp1 "bye")) (eq 8 temp1) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.DFASL b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0c64a96a713393f6669c9e7e3069f7e385f6ef48 GIT binary patch literal 1955 zcmd^9Z%kWN6u<8k7!)X-MIeX69#7`!sTcRilpO#2Mjr)@Y2%g*OHt~a>jkkUG z-19rD1J&BSH}FlH=d;$o~In6;h`WbT3Ud8Zt{@5wW+z@*yRx2S!@5g z=TPgx#@6PhdgJbgX9#l$AvA!Jm=qvnMh2w5A2r(~R+Q*2mz$+IhljPPb80jnVxeV` z71SuvsK1l*ZhZOH?5*2tfWxUKoz zLi39eIktFhcd`EFe7x8mFvvSIKfZl=>+(yHww;(gejviM#m`2V#K!T|=uh*%>iP|P ze}Al8mQyQvmW!z>b1H4wh%qxOKg(;|aw-Q7T+nrkIic75&}mNGs91yfLd_1$v6>Z_ zf2sJrv($1&mS;lOzn4F&Iu^66$L`9qXEhmIk8NJi*FIUj7u$?^!OYs!*UoRjWX5bl z*O$R^yyCWHRTsw2&xy=3>61xtz% z3hqlUJ>{*)t_|s>3a>S@el4weD>JKC(;vk_C?LWiols6Z=Go^^hcJlx7QqakCCi z?xnkU!6VuU75K{FeQ_F#>G z8TVjKfSLAScEC#1*{I3J3IZ?Cye##~lFeYodNv2wM`v*Cvl=xwP?69m9aLUdg19M% z3*ZX19Q71&qU0n(L>m~&VPAH*G1CZ49*)-`VfFwR+|S5@z;X}uiAG>q4aiC#+&AM8 z+3c}eA&Aiii1Rc3Y~LyPY3U&yJU`mM2_Gc zXThrq5Yib14=XwOPMST^3n^xWDebWdtumlhJ+2)!f;Q0#+PS>~f0)BuDdsZQfw@BU zy=WeX@saif-t~c2-LKV3S{y;orKB`lDkX3cJd1+NdO1`D=zZOZt|-h@~WF85|GGc_@H+<7h!c0-Gr4l z1+35)Jp=(WZ{j=wD-4(dRyTo#FhG*Ujk)j^;-&&5b6z2S8`Y>a=o>!f_hHZW77rXp YW{O8WMXFKL@jxg@{09ca_OV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST new file mode 100644 index 00000000..1ece12cf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: define-setf-method ;; ;; Source: Guy L Steele's CLTL, Chapter 7 Control Structure ;; Section: 7.2 Generalized Variables ;; Page: 105 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 25, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-2-define-setf-method.test ;; ;; ;; Syntax: (define-setf-method access-fn lambda-list ;; {declaration | doc-string}* {form}*) ;; ;; Function Description: This defines how to setf a generalized-variable reference ;; that is of the form (access-fn..). Note that define-setf-method differs from ;; the complex form of defsetf in that while the body is being executed the variables ;; in lambda-list are bound to parts of the generalized-variable reference, not to ;; to temporary variables that will be bound to the values of such parts. ;; In addition, define-setf-method does not have defsetf's restriction that access-fn ;; must be a function or a function-like macrto; an arbitrary defmacro destructring ;; pattern is permitted in lambda-list. ;; ;; Argument(s): access-fn - name of a function of a macro. ;; lambda-list - subforms of the generalized-variable reference, as ;; with defmacro. ;; form - evaluating the form should generate five values representing ;; setf method. ;; ;; ;; Returns: Name of access-fn ;; ;; Constraints/Limitations: none ;; setf method for the form (ldb bytespec int). ;; Recall that the int form must itself be suitable for setf. (do-test-group ("define-setf-method-setup" :before (progn (defun test-ldb (bytespec int) (ldb bytespec int)) (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4)) ) ) (do-test "define-setf-method-test" (and (eq (define-setf-method test-ldb (bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method int) ;Get SETF method for int. (let ((btemp (gensym)) ;Temp var for byte specifier. (store (gensym)) ;Temp var for byte to store. (stemp (first stores))) ;Temp var for int to store. ;; Return the SETF method for LDB as five values. (values (cons btemp temps) (cons bytespec vals) (list store) `(let ((,stemp (dpb ,store ,btemp ,access-form))) ,store-form ,store) ;storing form. `(ldb ,btemp ,access-form) ;accessing form. )))) 'test-ldb) (eq (test-ldb byte-spec8-0 15) 15) (eq (test-ldb byte-spec8-1 15) 7) (eq (test-ldb byte-spec8-2 15) 3) (eq (test-ldb byte-spec8-3 15) 1) (eq (test-ldb byte-spec8-4 15) 0) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6caf8138aa62dec902de175dcf04cb10a67591f1 GIT binary patch literal 2203 zcma)7&2JM|5P!RN?0gX9q)~!Q2~V^M$Yl`$%10_tHtUzz&U)AEu7R{C6R%mTwl}gJ zK7@)8YI|B#LfU9wE7bl85r>KpD5_eihgPc8Ll2cIRq6q$Ql<3JQx9~;n}k4+z#ltr zKHki{ncth8CvE2xl`3v^wp_96)SYY2&NXStt<#1(SD&$I3FP#uq8sdkl&nl0cxR;3 z+@zVQ+l8iGq}H6>C>E~lrz0n*JXFWqx&^x)yq zk&y$PPwp%VF_#cBLmnaNAS6aY#J}yu5*9NpX(FvMNt3fI;m`YCJDf$zo6PXNoj_2Il48@lp$=&E_5?Ew-H`OWmCIX+P&aJYmXNh+sUzBFdH{G*Qdja>a4utUQ1d4w5JL^ZQc7!Qm|-$h{0dw8T0(O=JFctJI@nS9 zBj17KA&(>Rc`uUB_-jZ$;(ceqY1CjjRaV$hSnt>fkY!d%PfF}u4*J53{X9O%f z2D`Ra>5vlM+kE-JFUd=Lq?Ej+2~N!|}E`H$~L@-Iju!N~*pU*IZ?siXEWr%3+b z14w=kxZeWub0GX4>^JT*T74U+zvlER-__uQ7x>_5NGQy-v9>;#xucB4u6T$A_EQUQi&k(O)0{6pEbAv7cYLaRI}`3&Rz zkcl9-NLWiNfgqHWr-K6h4amgE%}egnn0WAC7D@M*JdSsHJVtzPXQfa*Uo2p_twWHI zPz%ZaLdf?7&G*7;+O&MH?ToDE88i#3I)t4ENP=(l|AX(v+)FiD+jLlzFE5hlm<*%h z6@rRuLB&l$g%AV_J&p5~|AoIGLJH7lt8TGex&p5?T6AlBo3v^-8gy=!LJ#eF1D)LD z``+_CkmmD-(60L_m&>t8xvCTWl-Hujfoj2o)%Z8#0RSQ5N0R*ri2VURRJE^+gahde?kM3NuX!2b1shJ`d^I#ZVE77HRd_dP?Iq=yrtmklg$*S*#;6}E9 a776YkR96^l`F#4xlm7tq6v4ihALI)!-tE4JzUU$OsZu?V%KsL&aZ!dO=9J!UYgFBv5&?-Vh2L%7FtCV|zXG z-kab1y*Izv$w|mn%Xa8^xWGn-VmhF2Cz$rTnI^G2cluD%lq6ff|wT6hJPmFp+fMv%o zitYJy$}YK6A+}&@LKqd|9*i(UXFEgC*UO>x>On6Kih~nz zG+4GxgFsj8s`uv=VF^nUXJnE{#wZM(LzpM=EifkJ7R7l}nO03DORii_ zULb^PGd`acZ_aTy%4F~Jxy17EhX%QxHA0x9pOC$OGG%*qi!TlADGg=wB8L<8A{M)+ zBzAYcXU-V(CW78~;b@vG-e55Uxcu?$nJx9xA3kpHfB4PM+uv<3f6{L6*S?5cb zznJD1?e=cFegC!LU$aA|X@2>E{L$@4cFgN9e!DGwg_M(b^TezS^zRZi=C{;=TZA-< zuc-rb2@Z>F>^!(Ubigl3NFQ=`?BVFJ;^uHW2hB;{o$2bMZZ~Fgd+uBvMh`33d8adJ z6gQpCBKzDUk4wd!2RcL$;E+e7n0C@6k!rqGf0&n4C7UGNbc} zWGj{E!CyB@Ymk>jLz)#d*)TPfh7@V*h<;W#fVVHpS6-&hx&0&Uw%K z9M@3WbxGl+;zlX&+GW02t(2-2eyv#MH;dJB*5=oM=f9M6L;fluN{bU8O?H{DM6zW& zQ?YZrRkb&BnJ>oq$q#w4RL;8qrl(>0!OZ2$GgI$Rbj^vT(o*~1cdpD_oSK=Mp6EK= z-@|MXA(TaRI&>n$q7d?TJXWw|(;{<8MJAf4%7S0>y$+~_q)gfHy}nC)rC1`ay=A+! zoQ+L{5%RzHI_6TEWF>XY-^JTF>VN0;BsH=GrHS)0Vmh9wP<8BkBUi{JGA~=il&v|U z%2q<3C2C5sl1s4gvZ$nFw7=JR3n6@wZt$V=XaOG;@XYZ7lOEvuaN9aUG|+=k9Uwf< z(EXp$FK#XytGiFLY`uWTvvHt)O2^z>1HipB>prF6PC5=jioQw53ZcK!Y@z)R;JP1l zMG!jttVuQw*PDD}$2qvs3{qskYH(tJ5-kLi6Ai}390SPU)()Gj z!*Sg2cPZPX8{5v=-y_J5-)d*Eb9ABsZqydP)qX{&=G@j67z}m75`*bMT0Z@EAQXjD z$YdGIuL}Zk(v$|1)<2CZm6O~4e<_W^hqhhkhNEg8eke@ zAvW-`a!EAh)=EJ)gwc<1GVM3iWhH4+DRd8%hyUA#G;J?9R|etU=GAC9R+J1q=zS0L z`d<>{`5hPrexS*lE9zBUc@c=xO-5kVwr2fQ{2#bH5sg--(COa+PlrE)Av!#14Zpz~ zVbHrqx&0Qm8w`yHLu0V7LHqMkrjR4AZEqwPdLtMK!%O&W-+Oo6u8>W;vPL%Sic`#y zjjCJ8mt31{W!$PwD)wfDroQES=Pkhe$W3vCU(3LUD#zywt#1tFZjNz#XzOF~yG z;WAt887VIotWwcwLY0=<%;rI@{3>E+|-q zR1Oj}UyteR1xUZGvktc!J5iWpm3e&dWRa?I9E*I9b2A&C<}!3gXMF?9F-_n2yNvHe zM@LoKCPJ;_d;QO+vbLNwbWH{OgvY40#HA%!o8qNm{ZYDrV44)1a-_Qo1Dv=h5BC)6;(ejSS3~ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST new file mode 100644 index 00000000..87ab1d32 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-setf-method-multiple-value ;; ;; Source: Guy L Steele's CLTL, Chapter 7 Control Structure ;; Section: 7.2 Generalized Variables ;; Page: 107 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 26, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-2-get-setf-method-multiple-value.test ;; ;; ;; Syntax: (get-setf-method-multiple-value form) ;; ;; Function Description: This returns five values constituting the setf method for form. ;; The form must be a generalized-variable reference. This is the same as get-setf-method ;; except that it does not check the number of store-variable; use this in cases that ;; allow storing multiple values into a generalized variable. ;; ;; Argument(s): form ;; ;; Returns: Five values constituting the setf method for form. ;; ;; Constraints/Limitations: none (do-test "get-setf-method-multiple-value-test" (and (defmacro test-setf-macro (reference value) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value reference) (declare (ignore access-form)) `(let* ,(mapcar #'list (append vars stores) (append vals (list value))) ,store-form))) (setf x 100 y 200 z 300) (eq x 100) (eq y 200) (eq z 300) (test-setf-macro x 1000 y 2000 z 3000) (eq x 1000) (not (eq y 2000)) (not (eq z 3000)) (eq (get-setf-method-multiple-value 'test-setf-macro)) (let ((setf-values (multiple-value-list (get-setf-method-multiple-value 'test-setf-macro)))) (and (eq (first setf-values) NIL) (eq (second setf-values) NIL) (symbolp (car (third setf-values))) (equal (fourth setf-values) (list 'setq 'test-setf-macro (car (third setf-values)))) (eq (fifth setf-values) 'test-setf-macro) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a69f35f19abc2561f66fb968030e727403af93d5 GIT binary patch literal 1496 zcmah}TTdHD6rNcdb2DZ!h_)M=Y!O7&ia{Y)N?*EJ25i_1*iiBKyVJ#V(8WXju z8lk9)RB5Z$prGAUNKyLO7s^ve2(Hvh$wMFd-apVst3ROh%sMxbhstZsH{Ut?&73*k zP93$~P*hQ=tgaPHPF1XI)Ydj?;&P=bu2(jyc}H9ZUi?ZiO!{?7R_4b)p6IgPh~%qI zuI3a(d&5~Tj+=Z!2m&dz~ zcXu#fK?vnhgAJVs@hF1)EsvLMYT0Batx}@P8kPLI?{z>eBx6z2_xjF@waOYPIk%h= zD`#~bVTAl2ypEZSuGncq_qXvTj{DzxJ!zdRKxy(UMO?=V6{e1Tum1`;PiCo2ENagX zjoK+=8tv|M-a!bTV>^26KAFP@Wju8_$7KhEKHRo~5DWAm)Bp(23-s_8^lPb*Pc%x; z^L(R>$MQ*_e$FOJg(iRpS-$j~fqU5`1R44^nKB;qTn9w;6<7g?`+#dzV;nogA))fTdkNb=b>E@<; z^7jO?lXu#A>>eEHfSdLC@ATggs=IgfISxaeu*6_?kd@E=9SFtY6pHzG>n>m95!dG5 z^M)kF(5KU^10*Hu(<(K|)if~rtR-<#XlJHs}l zpgYnI0es_?4Ojys9gJHHdLx|-dS}Ev; zF!~8jrv0XNT}@j|3OxYj-V?rK{7!JH3QE19`CFcp71IcMKLmmP*93X#^3%W%guJz= zT{YBKfjHY$43=pN3ufZ~!sijwSve}3{u797_$wGDEy=#oyZE@Sd&{!}u z3i}##zF5nZ3*@cs4F^N-1jA8y3BT`q11nCAtUI-3vg*{_N`cgz^%{%4=X+;tz~b<2 zd01S|!QE33i{;j}!MNL_!VbFi3HK<4!Q1d0q`Aj)9CKzG&oc`i&fye?T>;=z_sCsJ zG~6Y=q1N5a;!?63e5YtU;;(3A%424E`*n-!*twSV|nJ+@Z!j-Fr6A z)C7S?z9*D&tDhBeY)2=Z0n2frGyHAN_u?ZX8tV&T=73w|<&^5z)25+oV36o2GmpHm zK=o-MkU9e)7M#NU?08jbOK=$ek4$UJJFS>hwkbK`9yM)KQ&z2@o25Y?uVoCI24~Ry IiR0t{0A6dp0ssI2 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST new file mode 100644 index 00000000..9eea1d27 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-setf-method ;; ;; Source: Guy L Steele's CLTL, Chapter 7 Control Structure ;; Section: 7.2 Generalized Variables ;; Page: 106 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 26, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-2-get-setf-method.test ;; ;; ;; Syntax: (get-setf-method form) ;; ;; Function Description: get-setf-method returns five values constituting the setf ;; method for form. The form must be a generalized-variable reference. It takes care ;; of error-checking and macro expansion and guarantees to return exactly one-store ;; variable. ;; ;; Argument(s): form ;; ;; Returns: Five values constituting the setf method for form. ;; ;; Constraints/Limitations: none (do-test "get-setf-method-test" (and (defmacro test-setf-macro (reference value) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method reference) (declare (ignore access-form)) `(let* ,(mapcar #'list (append vars stores) (append vals (list value))) ,store-form))) (setf x 100 y 200 z 300) (eq x 100) (eq y 200) (eq z 300) (test-setf-macro x 1000 y 2000 z 3000) (eq x 1000) (not (eq y 2000)) (not (eq z 3000)) (eq (get-setf-method 'test-setf-macro)) (let ((setf-values (multiple-value-list (get-setf-method 'test-setf-macro)))) (and (eq (first setf-values) NIL) (eq (second setf-values) NIL) (symbolp (car (third setf-values))) (equal (fourth setf-values) (list 'setq 'test-setf-macro (car (third setf-values)))) (eq (fifth setf-values) 'test-setf-macro) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..659e61ddbf5cdd875be48c049bcaee154b637b75 GIT binary patch literal 23706 zcmd5^33yc1*`7OFX0pvpGTA4S$p%Or6a)m^m?RStNM_>9gn&yCkPyfqn`jlcT9;N4 zLqMI&qCQq_tF_wL#<~>T`qbT4?ayCre_MU5?cds>)cRYi{@-%Wy)&6yYDj#Zs)z5K z?|#dBzVn^so;$L`WLwhQ5olh&Zo``7s!f6QTh8CG<@`YJ`b~k&>$hxLxhl{L{J_@c zXe@kbTc~-_w3DXi#?zjx+_Y->`K!(iB(|*DeD3m#jtxwo8whRKv?d9aIdh;nd)~~M z^G=vGEw?ok?_g{HR_DZd$IqNMea^Jp&-dM|xYwIZrj@1xNSr2<+hj4N2DiDVCc^PV zu(iD-9E^lI!&6f`QrjHRmtc2197}EU%m|#nenT+1>Vj2C?9RH)CdFh*4Qz9?c1M~M z?a@eTr*egopSp2dL3gk&#p?3V(VWyFw~eduN)kz?ipM;aG+;k<=}z79evmL3?$8mcJ&PQ zAG)Fs|9y0|$y9V@PE6^0cz*=yhjuKwA@Y>Tw4?8u$U?JH0JR57du~QA@YG>4<(o_g z)~rlX|E1r5NxwN1oPnVr(ZQkmp27V+1IjWt0O%Q1$`3@M?sCL&P0s*|yf6X+2u9tE z;>M_(U|bt@e^DIft0WF*HV(pI1~ff`<_hoV816c9+tZ#m^=aIQ~_pY&mhM`fq{{mYay>9KB5-CAI2cX^lRu)EX)21q zan@tt4Dx?`fy-%;f%6yz&P;)$Y~#Sm$%%o};ECGA1uo}*B(kDxWH>$L{G^Pd8LCZD z$~c+ajAq?oDEN89L-Y7IG(49n5dL-5}w&$4LRzm>MWDUyxGWTT@wo% zWgG<#GLDxJ3>+^VlyP51;GDw}UP(4Q4xE_+M;XU~lPer$oEEr=UgHWDOJt=2*+Qa& zL-XYtCl@(h<#?IX*0~B==V&F_O$*(ZvCL6t`3*=Ex;r!o8e3jYwcveZR%tT%ZITN+r7lQ~xi=ZeI4e*UG6APb{ zAgi-MicAz6Ft3L^oz3Y%)Ipj>b>cG7wN~QuXXB$x)V5(>6L}-nc4Epz-r;yn{4%x_ zw@ZSo$p$H>Gw&%poyD#q_hZaNu?+)AS)I5by6>0x0@?U@I*TnCX9`Sb4x+XzQxJK# zOdTf)SNc9UC^DNPCcsH_m4r^)RZ&_=+9nWRX_drx%zq}n zCnUb90$&%=!J$^peLaA3bY%!-41F9!4&ojfV~nDG0;5>APNMvZK)G0;?9fq)ai+|J zxk11&5#b*(NBjaQL)|N&0@j=f#9FScX~znzX9=vaG^`p}J*rwH@WH7&qdhp( z+%vGhXE13WM%;tTdf_7wHu~`EOVa+(foNZ}7b%7nHgHg>2bbF#-CHTzIx$D$jf zed6m--xvKlW5{YW^1TnEQZ!*w9bIm6Xs{JW0Uu%)nQmzE`rI;RXx$` z(b- zYyH{l%uz$DJyk+G35-8s#wd9CrvgJ~WpUbw^DG4urzfYw6Xpo0(4%NC)a2-+1Vt4` zUu$HA6^x7{e``ON9XJ_%!AL_6uawonp~bvCW2D=8hsNs3VsXdBz^xM~umOjb6>v=f zOo9*B6tXH)cVd#a?ly`26m$f@^>-xPht>|`4#aCU)L}2_jjW|j$PEO;3?Dky4x{co zc!v|U>;R8z6ROv~{PF8<21wdd0GhU2u7w@N9qj{nk!bH&Kpu4l*Z)=q@iY;{W}<^b zb7?d0PYWW{DTw_XL?H0P4!FJOA6|RtX8484@F=$zsB!dLc!TyDJU<&9MGr7((d*~v z0WOH%7eaT`VQbXZ{g42*QG{(ZoD$4QE3D{{f|!8t`x|N^&H>!0l6c#cwC37r%Fxj< zorQ^6t7)Ot7jD&TQZqY6$8`d2d`qT4ljuuW^yMUg@%cOFIpEL<{ec}7aBzD7+XFO- z;Kw7tOwPv(8m!!&{W1YvAIAxKlD7VHY7PwjXW^TCj*MSR#(8*PXlq7$aA*x20q6(@ z3nH(k5Jp<0aQ{N)07f2}eYhh42M(BSZhTX4 z$~@V-a7J$ihAzx#4-TzLT37BKIvf7nJJbz5g#+{M{?}IShI!DlS6@c<0&nlKZ7>;n zb`LMx4y$ssF9Ivdc3Ang>F)+M?cKmOtX;Zb=06Hy5InzGL(~`%!4u)${Z*sLYWO^7L*xKrb9U%%5hMpK?y=R7RpzkOoeg`lqpaq zLzx7n5lRD;dMI^JYM}(6)Ijk=sfOZ%QU#?FN(Gd1C}mJep_D-JLMet)1jPfz4aEhe z5K1nTd?R_|kYH+-X*_B@)r8 zYM!MH9#~qVQSB#?_~S)OJ93*sG1X;Rs5&i+;FpetQ^T=XG!~3@C%U>5Q!O1Jl0P*R zSsEmMe5$HgI)SHzKq-QiCe@YNRy2G1$RAU-<(N#W6@Nkrzlk(`hChs)0}kx1(O73F zfz4T$si_}Ua4iLA6y1F`0vhg!$x#CMZo1z^-`BP8if28`5{6(!s@;0|#=hjQy z`Wd%|$yejuOfDyvjhB$i#&zVfaWXi`Z3%ZpfeO3d2ph#B~Zn1R0& zGw=>Ge*|a>J44N}XnKSL-&5-VRNz*a+Qs;b*|)7nOs-(&7AAez)di3= z;m$6UJzH%+auNfX!$6K9AT<{gv*to#*7Py+R4|Y)5@2ztqZLeu9{G^yk9y1jpejZ6bkEEYR(tkT;iGLT9Z$fXq)Z6Tw^IxG(1{eNIS#&d#er7IX zGLO38KaslNpF&-z{wElP7$n+4@is6}{hm4n$(tA&n7EStEA<#;zrs(SX7XcZewT>~ zDlVEzs1!_unmRBZ)mzDJ_1DO4^%{0tg>F0A4ui=iyY zb;Y7MOukn2SR?@^MMSFpOqx}HB+aT{lV;U=fMj1BZcapFpi$MX29cDpsFy`;BwBeh zO~J}*m@Ffa%CktMvXey$(OM+Y*4%>DDn3=GA^9nZRy;zY759>8#TpQGG{RT~K^~>f zQIA7X%EHAgY$f6H8;Dtc9Wl$d60_`OVwSx?%(9;{laZG(@-jwVx{4%ASCC|BoFq#g zCT7VnF-yL~%wlG`nW+%d%Tw9QQ`yT?x%gF*EdB*a7C%9f#dDcCo0*e|S#%dMi|!z1 z(N1PE&LYNH#5g@WNYb;NBt4gtr2Bnhy8lW{_nXY@U}ifr=MmHOePX)4M@-jlX67){ zO3cC!iCMUsn1$yuvzwT?PZBft05NkPU}haNYnbUKX8xtb%)gkJ`TfMq`z(M9iF(#I(ObO#6Qm)BY?oc@4Jn8f@n^*meg=+HNCB+W<-0EX*_!)A~L! zt!s#B?PX>UF)hy#)ADm-T7JUJ*~~nFnGM7=?<1ypH!;oEGtl#TW&_t8Hz9BQvpF}TtN^Tmy++sg+v;D4f0Nw z?`VNz7FcX}k^~zbW{G>4%mu-G7UXjQ%hs`M1q&4rsXqvzvW6oq*yZ|HFtYJPD3+k+ z)9NY6J)oY7WF1&75LTPo6J)c#hiukI*;q4?y4Q4|Qn2o)Bv|(&mbi<_Y!J*7CY#&v z;0ccE0xVk2GWkSmZ`QqQlC_tUWbFkkvYJTXeUS9B(ahrnSr5EHI)PVN_~%UU=vgFy z@IkN(cQw}VvqlMv+KJR0Ry}~V<`1eH$w6+t#I2{9JjTp>n539_ewHUXage8)uac*l z#q5HIz2+p=pU(OX+^S?!#!NR8J2CyAQp=C&Qj*apdAKEK{-?;9|50-0zn{rIHnD?E zT*a-6nOw-s4NT5u<`Qnr1ZTPIOq@d43CGS~%GNpOsz0Tqo$ zg_u_VTBVcBi%gzj<^d){YCDSD$ItF!d$;qmEnrIIDL~;lUCoiL?j{`7txN*wbRjz} zRTrT}2O0K##^eJgf1qc+2S8lRKQK&cK9z##8z6(euQR!T@c1?nI$u8p%Gb-bRuD+v znG`l(CyOj(ktTk28b6!EEgpB@u`JohlGSXil9^@9bg|of)^n1Ts&@dioMMaR5?A#y z!LH)$ui_M_`VNL;0rjh@pSoPthpcvHt-^X6*H@?!h*s4yWO0P6&Qec6)>1-NwV04q z#R*bX7eT7>fVdbLZMCiZCqb!vpF&sp7L%9Ae&vm{P*z^fWGSeNWsQ$-gr%~X4V=W9 z#}TP`2xP@rfh-AD+)jcOx3I)FnYeXKF?a_i$#TY2{sD=U|AEQ1ASoh=`w1H@-$+Kw z*RaglOqwWqWzXswk#?z3_8@7L-Akfnw=ua|jY9OwFhZh>;r0b>!b#~Tq*8jAWJ}*= z@{)?%O(~9nn0fK=VhvbnJL`m4covgtifhS(IA65*v}A8C}_M4~0%VzNm+9lVs} z>Kd)>twO{55ovh;Mxx%gnY>7e;9aMl35s6cAiTUmczJ{H21%s&MZLGJ(e9YATKo`M zE#?)e_}gT)csu1)@d-MPL|c1|SB&Cn*5DPo*hv~iA5sby-KINv;((JsG}^_xIeSwtZ6Pedb&xRHkzbr3QVd5@EkyoX3T@4HO)QNrg9 zqJA^)t9f{)*7UXE$n&wjmlYjE3O)r{rISDue1JweMFTCS84-~v*h)qUHnH|fCQE2) z7vP%r0;y06rE2o`3WtA&ihcmop&B58q@vDAUJ2UevlRYOp0kj zIvuDVf=fwQgB;(5hM3PdJ9%cSf3pvlJy`Y%0K3!3EIAsk0F`mwyVjb?Gkcj;|0vN zf)dQOMBM_4R!kQe)sXC?^<7f5a#XB*%CGZaN1tsSh`OdhQ>nH)o- zX|188usjWl;`{*P$iry)0qI#dD3;x%XStC^!*UIcrseo_J>kz%!Fq01P>7iSL4#p_ zk3ws{B~4Fu(EN4MGhf6C92qm8hs;YUKxRw2p75vqh4d6&0hQNCU3s1Yqg((A;)4?-S3i{pE3kgpk4SGPJHmK$C@6$gyO zk}t%jcJ*XW*1sp}o7Z#hyst?;U!AMOZu!ih1MSlSil!N~27#M>7{ z!Y#q3rHQZtLIt6gh23x`0N21*+yk)c{!cSOX78sze@K50UD1saZy7?V`-KLjZpD%8 zkf$?_Btf29j6KcJJ(;$L09Nfkw&S;y+9%=f>u3tb6EXN|i0wz94Uycofeo7_Kr|zQ%eYvT=n9p3~sYG@f>lnfE8v` zoS!JisxFcuE3eXW8TdYkQTt`IQGzK29X0(@vR{#$SM`Tb1)0DlQfBO`8#7c9xuI9> zp#XetioQD{fTd7{50hAJHV)c!GL7p*%|9WR<>G|x_pmJ%DQpjqXmh@PfRFARp}LQ( z9>zyk8v3r;p!xP2uM2*CUGRT9Gcfr5(|=0_uY`E3N8z2B!Sj+_lOZ<$@fx=3Zx~8d zZ`7scrFPnQF^8Dp(WQC@a(JoVLc5{wH@eIglJUK!%Rr<-%eUXqoA3LYx2nU2QdPg# zrD}|&ay6;SLF3i2^2(8`W94c?o0Z+V&H52G#gQUKGGO zGRpQ}{-7~}@_R=jD8I=NLHRc{1Z5u@+bo0Goq60SJ7{RL>}R^oQ;uMBR+dfU3@p<# zu=ILko2B0vX|r^lAHJl}I#>p7}v=J>iIMQax6NWZRc$vc$vSjWNY);RzS!Ha~ zsp0e<;cVi~I-7Wn&n8~|Y*PHOG0x)mN8&7g!w_fjvl`CgWk;~tlVvkxZ1XtHX3_J; zHjADbX|w1)Lz_i=bel)W&!VjSEHci|B0WDnaGWs8CC~jMae7okoSthnoSw4OE?a7s zHMPr<+Qs|(*VXgXuc>RWc`3Yex59O>x>-F}NL&uAg>c2LUZAcy-MeAOhVQP$M6UJzp zG_51CHAb{9L$rmTYG?~@$Z#L_}!u7^z&(_f9{xQSFc+lqlF2mH=(B?j8h&J~pI@-1j7vn-ZKf}}*(M~l+Tdtwa z|8|Cp@u1D$lVNIXX!EZ&M4P`^M+?jB1g*DupJbRC8``{g4AJJjs-eyMYKDvP#5Qkn zhN&^4oo|eGnufMue};?kpe-2AFf}%`1-BcbE!eK3t;ldOF0`HuQ)5Hx{KOEg^G_OD z=S3MV#)H*r0GrFHMbb-1IatV}WClOvq9FSY9#oV|iTnbC!6s z&@Txs3BeL(VUAc%HMVuEX3PAPW~&5W)j`qxsAlVQag%Sp%g~m2r*7*w%@!(>t;w1# zG>=~e%pOBq%IBIb<&HF4j7!;_W{bZtC|4QV+N9fR!gnu-40u;+u+G1QRN!3@`S@ck qMKQEw`kQ9S^ayLChUpgFk_j@5EL}9ZmDOy)z=vr!hUM_*pZ`AzdCML>TEST>7-2-psetf.test ;; ;; ;; Syntax: (psetf {place newvalue)*) ;; ;; Function Description: The psetf {place newvalue} is evaluated and then checked ;; for correctness. This function is like setf except it evaluates {place ;; newvalue}* in parallel instead of sequentially. ;; ;; Argument(s): Place - when evaluated accesses a data object in some location and ;; inverts it to produce a corresponding form to update the location. ;; Newvalue - when evaluated gets stored according to above update form created ;; ;; Returns: value(s) of the last evaluated form of the selected clause ;; ;; Constraints/Limitations: (DO-TEST PSETF-OF-A-SYMBOL (AND (SETQ FOO 1) (SETQ BAR 2) (NOT (PSETF BAR FOO FOO BAR)) (EQ FOO 2) (EQ BAR 1))) (DO-TEST PSETF-CAR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (NOT (PSETF (CAR FOO) (CAR BAR) (CAR BAR) (CAR FOO))) (EQUAL FOO '(B . A)))) (DO-TEST PSETF-CDR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (NOT (PSETF (CDR FOO) (CDR BAR) (CDR BAR) (CDR FOO))) (EQUAL FOO '(A . B)))) (DO-TEST PSETF-CAAR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (NOT (PSETF (CAAR FOO) (CAAR BAR) (CAAR BAR) (CAAR FOO))) (EQ (CAAR FOO) 'E))) (DO-TEST PSETF-CADR (AND (SETQ FOO '((A . B) G . D)) (SETQ BAR '((E . F) C . H)) (NOT (PSETF (CADR FOO) (CADR BAR) (CADR BAR) (CADR FOO))) (EQ (CADR FOO) 'C) (EQ (CADR BAR) 'G))) (DO-TEST PSETF-CDAR (AND (SETQ FOO '((A . F) C . D)) (SETQ BAR '((E . B) G . H)) (NOT (PSETF (CDAR FOO) (CDAR BAR) (CDAR BAR) (CDAR FOO))) (EQ (CDAR FOO) 'B) (EQ (CDAR BAR) 'F))) (DO-TEST PSETF-CDDR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (NOT (PSETF (CDDR FOO) (CDDR BAR) (CDDR BAR) (CDDR FOO))) (EQ (CDDR FOO) 'H) (EQ (CDDR BAR) 'D))) (DO-TEST PSETF-CAAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CAAAR FOO) (CAAAR BAR) (CAAAR BAR) (CAAAR FOO))) (EQ (CAAAR FOO) 'I) (EQ (CAAAR BAR) 'A))) (DO-TEST PSETF-CAADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CAADR FOO) (CAADR BAR) (CAADR BAR) (CAADR FOO))) (EQ (CAADR FOO) 'M) (EQ (CAADR BAR) 'E))) (DO-TEST PSETF-CADAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CADAR FOO) (CADAR BAR) (CADAR BAR) (CADAR FOO))) (EQ (CADAR FOO) 'K) (EQ (CADAR BAR) 'C))) (DO-TEST PSETF-CADDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CADDR FOO) (CADDR BAR) (CADDR BAR) (CADDR FOO))) (EQ (CADDR FOO) 'O) (EQ (CADDR BAR) 'G))) (DO-TEST PSETF-CDAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDAAR FOO) (CDAAR BAR) (CDAAR BAR) (CDAAR FOO))) (EQ (CDAAR FOO) 'J) (EQ (CDAAR BAR) 'B))) (DO-TEST PSETF-CDADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDADR FOO) (CDADR BAR) (CDADR BAR) (CDADR FOO))) (EQ (CDADR FOO) 'N) (EQ (CDADR BAR) 'F))) (DO-TEST PSETF-CDDAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDDAR FOO) (CDDAR BAR) (CDDAR BAR) (CDDAR FOO))) (EQ (CDDAR FOO) 'L) (EQ (CDDAR BAR) 'D))) (DO-TEST PSETF-CDDDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDDDR FOO) (CDDDR BAR) (CDDDR BAR) (CDDDR FOO))) (EQ (CDDDR FOO) 'P) (EQ (CDDDR BAR) 'H))) (DO-TEST PSETF-CAAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAAAAR FOO) (CAAAAR BAR) (CAAAAR BAR) (CAAAAR FOO))) (EQ (CAAAAR FOO) 'AA) (EQ (CAAAAR BAR) 'A))) (DO-TEST PSETF-CAAADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAAADR FOO) (CAAADR BAR) (CAAADR BAR) (CAAADR FOO))) (EQ (CAAADR FOO) 'II) (EQ (CAAADR BAR) 'I))) (DO-TEST PSETF-CAADAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAADAR FOO) (CAADAR BAR) (CAADAR BAR) (CAADAR FOO))) (EQ (CAADAR FOO) 'EE) (EQ (CAADAR BAR) 'E))) (DO-TEST PSETF-CAADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAADDR FOO) (CAADDR BAR) (CAADDR BAR) (CAADDR FOO))) (EQ (CAADDR FOO) 'MM) (EQ (CAADDR BAR) 'M))) (DO-TEST PSETF-CADAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADAAR FOO) (CADAAR BAR) (CADAAR BAR) (CADAAR FOO))) (EQ (CADAAR FOO) 'CC) (EQ (CADAAR BAR) 'C))) (DO-TEST PSETF-CADADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADADR FOO) (CADADR BAR) (CADADR BAR) (CADADR FOO))) (EQ (CADADR FOO) 'KK) (EQ (CADADR BAR) 'K))) (DO-TEST PSETF-CADDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADDAR FOO) (CADDAR BAR) (CADDAR BAR) (CADDAR FOO))) (EQ (CADDAR FOO) 'GG) (EQ (CADDAR BAR) 'G))) (DO-TEST PSETF-CADDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADDDR FOO) (CADDDR BAR) (CADDDR BAR) (CADDDR FOO))) (EQ (CADDDR FOO) 'OO) (EQ (CADDDR BAR) 'O))) (DO-TEST PSETF-CDAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDAAAR FOO) (CDAAAR BAR) (CDAAAR BAR) (CDAAAR FOO))) (EQ (CDAAAR FOO) 'BB) (EQ (CDAAAR BAR) 'B))) (DO-TEST PSETF-CDADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDADDR FOO) (CDADDR BAR) (CDADDR BAR) (CDADDR FOO))) (EQ (CDADDR FOO) 'NN) (EQ (CDADDR BAR) 'N))) (DO-TEST PSETF-CDDAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDAAR FOO) (CDDAAR BAR) (CDDAAR BAR) (CDDAAR FOO))) (EQ (CDDAAR FOO) 'DD) (EQ (CDDAAR BAR) 'D))) (DO-TEST PSETF-CDDADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDADR FOO) (CDDADR BAR) (CDDADR BAR) (CDDADR FOO))) (EQ (CDDADR FOO) 'LL) (EQ (CDDADR BAR) 'L))) (DO-TEST PSETF-CDDDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDDAR FOO) (CDDDAR BAR) (CDDDAR BAR) (CDDDAR FOO))) (EQ (CDDDAR FOO) 'HH) (EQ (CDDDAR BAR) 'H))) (DO-TEST PSETF-CDDDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDDDR FOO) (CDDDDR BAR) (CDDDDR BAR) (CDDDDR FOO))) (EQ (CDDDDR FOO) 'PP) (EQ (CDDDDR BAR) 'P))) (DO-TEST PSETF-FIRST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FIRST FOO) (FIRST BAR) (FIRST BAR) (FIRST FOO))) (EQ (FIRST FOO) 'A) (EQ (FIRST BAR) '1))) (DO-TEST PSETF-SECOND (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SECOND FOO) (SECOND BAR) (SECOND BAR) (SECOND FOO))) (EQ (SECOND FOO) 'B) (EQ (SECOND BAR) '2))) (DO-TEST PSETF-THIRD (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (THIRD FOO) (THIRD BAR) (THIRD BAR) (THIRD FOO))) (EQ (THIRD FOO) 'C) (EQ (THIRD BAR) '3))) (DO-TEST PSETF-FOURTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FOURTH FOO) (FOURTH BAR) (FOURTH BAR) (FOURTH FOO))) (EQ (FOURTH FOO) 'D) (EQ (FOURTH BAR) '4))) (DO-TEST PSETF-FIFTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FIFTH FOO) (FIFTH BAR) (FIFTH BAR) (FIFTH FOO))) (EQ (FIFTH FOO) 'E) (EQ (FIFTH BAR) '5))) (DO-TEST PSETF-FIFTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FIFTH FOO) (FIFTH BAR) (FIFTH BAR) (FIFTH FOO))) (EQ (FIFTH FOO) 'E) (EQ (FIFTH BAR) '5))) (DO-TEST PSETF-SIXTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SIXTH FOO) (SIXTH BAR) (SIXTH BAR) (SIXTH FOO))) (EQ (SIXTH FOO) 'F) (EQ (SIXTH BAR) '6))) (DO-TEST PSETF-SEVENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SEVENTH FOO) (SEVENTH BAR) (SEVENTH BAR) (SEVENTH FOO))) (EQ (SEVENTH FOO) 'G) (EQ (SEVENTH BAR) '7))) (DO-TEST PSETF-EIGHTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (EIGHTH FOO) (EIGHTH BAR) (EIGHTH BAR) (EIGHTH FOO))) (EQ (EIGHTH FOO) 'H) (EQ (EIGHTH BAR) '8))) (DO-TEST PSETF-NINTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (NINTH FOO) (NINTH BAR) (NINTH BAR) (NINTH FOO))) (EQ (NINTH FOO) 'I) (EQ (NINTH BAR) '9))) (DO-TEST PSETF-TENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (TENTH FOO) (TENTH BAR) (TENTH BAR) (TENTH FOO))) (EQ (TENTH FOO) 'J) (EQ (TENTH BAR) '10))) (DO-TEST PSETF-REST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (REST FOO) (REST BAR) (REST BAR) (REST FOO))) (EQUAL FOO '(1 B C D E F G H I J)) (EQUAL BAR '(A 2 3 4 5 6 7 8 9 10)))) (DO-TEST PSETF-NTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (NTH 6 FOO) (NTH 6 BAR) (NTH 6 BAR) (NTH 6 FOO))) (EQUAL FOO '(1 2 3 4 5 6 G 8 9 10)) (EQUAL BAR '(A B C D E F 7 H I J)))) (DO-TEST PSETF-NTHCDR (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (NTHCDR 6 FOO) (NTHCDR 6 BAR) (NTHCDR 6 BAR) (NTHCDR 6 FOO))) (EQUAL FOO '(1 2 3 4 5 6 G H I J)) (EQUAL BAR '(A B C D E F 7 8 9 10)))) (DO-TEST PSETF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (NOT (PSETF (AREF FOO 6) (AREF BAR 6) (AREF BAR 6) (AREF FOO 6))) (EQUAL (AREF FOO 6) 'G) (EQUAL (AREF BAR 6) '7))) (DO-TEST PSETF-SVREF (AND (SETQ FOO (VECTOR 1 2 3 4 5 6 7 8 9 10)) (SETQ BAR (VECTOR 'A 'B 'C 'D 'E 'F 'G 'H 'I 'J)) (NOT (PSETF (SVREF FOO 6) (SVREF BAR 6) (SVREF BAR 6) (SVREF FOO 6))) (EQUAL (SVREF FOO 6) 'G) (EQUAL (SVREF BAR 6) '7))) (DO-TEST PSETF-GET (AND (SETF (GET 'FOO 'A) 'B) (SETF (GET 'BAR 'C) 'D) (NOT (PSETF (GET 'FOO 'A) (GET 'BAR 'C) (GET 'BAR 'C) (GET 'FOO 'A))) (EQUAL (GET 'FOO 'A) 'D) (EQUAL (GET 'BAR 'C) 'B))) (DO-TEST PSETF-GETF (AND (SETQ FOO '(B C D E F)) (SETQ BAR '(H I J K L)) (NOT (PSETF (GETF FOO 'D) (GETF BAR 'J) (GETF BAR 'J) (GETF FOO 'D))) (EQUAL FOO '(B C D K F)) (EQUAL BAR '(H I J E L)))) (DO-TEST PSETF-GETHASH (AND (SETQ FOO (MAKE-HASH-TABLE)) (SETF (GETHASH 'A FOO) 'B) (SETF (GETHASH 'C FOO) 'D) (NOT (PSETF (GETHASH 'A FOO) (GETHASH 'C FOO) (GETHASH 'C FOO) (GETHASH 'A FOO))) (EQUAL (GETHASH 'A FOO) 'D) (EQUAL (GETHASH 'C FOO) 'B))) (DO-TEST PSETF-SYMBOL-FUNCTION (AND (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (A) NIL)) (SETF (SYMBOL-FUNCTION 'BAR) '(LAMBDA (B) NIL)) (NOT (PSETF (SYMBOL-FUNCTION 'FOO) (SYMBOL-FUNCTION 'BAR) (SYMBOL-FUNCTION 'BAR) (SYMBOL-FUNCTION 'FOO))) (EQUAL (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)) (EQUAL (SYMBOL-FUNCTION 'BAR) '(LAMBDA (A) NIL)))) (DO-TEST PSETF-SYMBOL-VALUE (AND (SETF (SYMBOL-VALUE 'FOO) 1) (SETF (SYMBOL-VALUE 'BAR) 2) (NOT (PSETF (SYMBOL-VALUE 'FOO) (SYMBOL-VALUE 'BAR) (SYMBOL-VALUE 'BAR) (SYMBOL-VALUE 'FOO))) (EQUAL (SYMBOL-VALUE 'FOO) 2) (EQUAL (SYMBOL-VALUE 'BAR) 1))) (DO-TEST PSETF-SYMBOL-PLIST (AND (SETF (SYMBOL-PLIST 'FOO) '(A B C D)) (SETF (SYMBOL-PLIST 'BAR) '(E F G H)) (NOT (PSETF (SYMBOL-PLIST 'FOO) (SYMBOL-PLIST 'BAR) (SYMBOL-PLIST 'BAR) (SYMBOL-PLIST 'FOO))) (EQUAL (SYMBOL-PLIST 'FOO) '(E F G H)) (EQUAL (SYMBOL-PLIST 'BAR) '(A B C D)))) (DO-TEST PSETF-MACRO-FUNCTION (AND (SETQ FOO (GENTEMP "FOO")) (SETQ BAR (GENTEMP "BAR")) (SETF (MACRO-FUNCTION FOO) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (SETF (MACRO-FUNCTION BAR) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (NOT (PSETF (MACRO-FUNCTION FOO) (MACRO-FUNCTION BAR) (MACRO-FUNCTION BAR) (MACRO-FUNCTION FOO))) (EQUAL (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (EQUAL (MACRO-FUNCTION BAR) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))))) (DO-TEST PSETF-CHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (NOT (PSETF (CHAR FOO 0) (CHAR BAR 0) (CHAR BAR 0) (CHAR FOO 0))) (EQL (CHAR FOO 0) #\B) (EQL (CHAR BAR 0) #\A))) (DO-TEST PSETF-SCHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (NOT (PSETF (SCHAR FOO 0) (SCHAR BAR 0) (SCHAR BAR 0) (SCHAR FOO 0))) (EQL (SCHAR FOO 0) #\B) (EQL (SCHAR BAR 0) #\A))) (DO-TEST PSETF-BIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (NOT (PSETF (BIT FOO 1) (BIT BAR 1) (BIT BAR 1) (BIT FOO 1))) (EQL (BIT FOO 1) 0) (EQL (BIT BAR 1) 1))) (DO-TEST PSETF-SBIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (NOT (PSETF (SBIT FOO 1) (SBIT BAR 1) (SBIT BAR 1) (SBIT FOO 1))) (EQL (SBIT FOO 1) 0) (EQL (SBIT BAR 1) 1))) (DO-TEST PSETF-SUBSEQ (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SUBSEQ FOO 2 4) (SUBSEQ BAR 2 4) (SUBSEQ BAR 2 4) (SUBSEQ FOO 2 4))) (EQUAL (SUBSEQ FOO 2 4) '(C D)) (EQUAL (SUBSEQ BAR 2 4) '(3 4)))) (DO-TEST PSETF-LDB (AND (SETQ FOO 100000) (SETQ BAR 200000) (NOT (PSETF (LDB (BYTE 8 0) FOO) (LDB (BYTE 8 0) BAR) (LDB (BYTE 8 0) BAR) (LDB (BYTE 8 0) FOO))) (EQL (LDB (BYTE 8 0) FOO) 64) (EQL (LDB (BYTE 8 0) BAR) 160))) (DO-TEST PSETF-MASK-FIELD (AND (SETQ FOO 100000) (SETQ BAR 200000) (NOT (PSETF (MASK-FIELD (BYTE 8 0) FOO) (MASK-FIELD (BYTE 8 0) BAR) (MASK-FIELD (BYTE 8 0) BAR) (MASK-FIELD (BYTE 8 0) FOO))) (EQL (MASK-FIELD (BYTE 8 0) FOO) 64) (EQL (MASK-FIELD (BYTE 8 0) BAR) 160))) (DO-TEST PSETF-APPLY-OF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (NOT (PSETF (APPLY #'AREF FOO '(1)) (APPLY #'AREF BAR '(1)) (APPLY #'AREF BAR '(1)) (APPLY #'AREF FOO '(1)))) (EQL (AREF FOO 1) 'B) (EQL (AREF BAR 1) '2))) (DO-TEST PSETF-EVAL-ONCE (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (SETQ A 4) (SETQ B 4) (NOT (PSETF (AREF FOO (INCF A)) (AREF BAR B) (AREF BAR (INCF B)) (AREF FOO A))) (EQL (AREF FOO 5) 'E) (EQL (AREF BAR 5) '6))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..68cdc1bc1d67d524e1ffac50783dd42b3e22d786 GIT binary patch literal 46886 zcmeHw33wdUm2P*n_I+vX``X%CyYV6~Y0E8Hw%lzb8O1Qf<4+iDEHGf3B_6hM7(aw8 z+ZeD4hxid5VHk#h#Q;MHI1Ixu3=ke62}1~vkB~qN0ZbT%1V}t*sasXItEFyj^!L3P zLG`)!+;i_a|2cQ7Th;ADw&<^S_Lg?;xag8?!&@#Z-LZSuCA)W(p10H~`(UQ<_DjB+L%jR8M&MO_*y=CWlo3CmpZCPCEx#Y5K!;o0C z2(o7^X>VWBwxBVg%hTV>t%a}rZ&1M_2oj?+Av!&S_w(*-s z)9MDi{R8f5TEW)ssfEy-p( zv2Ex!@|R|%vQtlRE{4bjgw7m04xSyNN8z(`{OlY+djumGT_8}VhKEv-Q7R^skj5^m42~*B)VF2|86cUs6Ba}Q=Hpfoyp zc#82U252NlXxy^`Z)Ui7l>oeuH}GPHLJN2yjjM^G;RQ-7iV{h@@sA3;&T#SC112TN z8+b88@r8K_(umit%}hWEuRW4;Q}R6mZ&tW?l>oeuH}GPH;*0aJHW7=NSWLx{#G9z^ z+OosNYq!f2732-Pm@&pLPsw6V7L#%$XXT`QBEC7{;#C6hLf*iO8DsqN!!N-11_Z=}@0iEC*6wJgA<84Ffmu>|uPtS!R&Dy%QV zkzAM31_kbdaB;)(D&t0mDbfNruxTyU7Gr%i)|cZ*;!fA^@e0Gm4a=;I8yN;}%JGtn z@rE*9ltsM7HUvr{c+Zg0E#h4iE^b(EW!%Uxa8r(#W{kIn8>n`lBya;Kg19qR2;9Zt z;)W$y#*GXEH|2PV#yuF6QM~nCn7$2*=swK3P~a{J7dI@$GHzrTxGBd=HO}Q4ZlGGc z1#aL(Fy2{B0(WV+xM4|_aU;XPO*tOl7;h-!@vY$ohS+vT5_h&s;4TXnH>}e#Ze$p^ zDaYfR*KVHA0WO`^L9upwr9={UPKm%>9xiTJrvf%;z%X!Qv9<;0^;_G7!@P!P22iYR z)9jJlm*(aO+!f*ChUm(;kzwGb9LJmIb8WMx;f7*uI}Y=C~Im2o4(z)d-dH{!+|bZ$0(fG!Bjc>yuiM!x4f!h@>Za^vHMuvf#ay-6y zKG(*#h_}EEauFQgh0hAyHH=$(sx+!SRT`T(pZEtS{$g;%`~c=4BGn%#W#D3!;ddf& z`rs3vl11W~Qqi3PPpuwDe%dmsJ#87AxL8AUUNA&7HgU(HzKtGTa()!Up{r{;)5@pVq690XNzS9G^T(l1qy3cs}IetAy!%M-d^cnqOm?w-moCdbI0 zF}X(ejmbH(cMSJL(m&PvgnwGuKhxd6(XJFGPTY&bbP2@igU?8f1J@yer%jLdLwdaL z(c^uTQW)<8@XiR&^5*U7n8uU$<1ppHQNwTyZd^5iM0n?FI0oN|(o*p5ke15!VIoqV zsL^MHcHI*X=$^Ps_rww16E`6+c&p6h2jGkWM|c6U2Qdpih$c~Bi~=JM^8PeP;5`{6 zGcXBvWsuB6yK8@#SGldjNzMdW0-;4wu767;R7=l>(}G zB);S~QAG_>GMAdeq)KgJYVO~ot9w)UXpw~We|%)T?b+ZGK3WVx;Qyf?L4SBZApcrG z{@H;1!;pVUc@EofJ!wiqcQWTPq?{9T@V`F|rxY!nVM^2N!+d?#>4Ch^1j$nq3j-OI z0gPh-`MK|F?jhmFB{c6~ANviZaQwYSDI9k%QVPf0Q-dR5l}nqHMlnqeG{x6K*3+s)0(!cF%I z=Pd9;}!kpD_~}L@&`oNC{j9G2ugsvpmin zPzklaFi~&L6q+(eO=;N`bMe-6v)+p^INR9^#~?YZaQYCY9h}~a=_p7~Tn?#O<8S6h z;7#`loO+-=dJSGnMx7ex)b@E;>5aoiJUtJ@n`~nO7W+GPLlIy=qaa2`5=Ma1OtP$xS!ytF>=M`9F7{jXzsg8TfXqw z3N!`6MU&3&L>V7zPG;@v-QEYfZ9S6UYMw%3Y^X#9D~Y~zMWd6r0hMB zn~MS0o-MriHPl2d??Kb^ktnPjQjs0 z-q^&|L=R5vq?m6v#T?Rl%ptAE9MTl??HqF?5OX9Db08S=%E6KCk6d_aq5!^O^vL#8 z#|FnRd)wea%*}n6&-kr?+WG%G)P=hR)Kv)eNgqu2KA7lz7sB)d0Ym0DVCUq|xDbK@ zJlqsPiq8l9^bL>~4#D@lLJu#9V^)x_cOBZAwk^%3tQx;{w6Lzz?_1S_-)VEN_V`xy zdi&ffdw}EX?ypli)p%tkTpqZ-2Gmcz9SuBC8wz_kRf#c(ZxYXMyCaJ9kJ3ReqU z&2Tlr)d-gxt_Ha3;i`kH7Oon&TyRyxRRvciTorJY!&L@XDO@FR6~k2oS0P*laOK05 z2Ujj!IdEmel?9g*u1vTx;7W%p4X#wUQs7E}D;BP3xT4^Tfa!Ieo`KHQ?mq9phCcWr zUnhMNFs6TF|A2R$Vz){R`0La}hZhPQU4Fm*wL$#CpQ8)8D?NQ`s-v5eXG3x|Bx6?g zdO;23denHw8u;2^N}ac_&)?_vZx~p=VW7^j7NnBuJid)?;`i67@cqGz1!n|)578TI zv#C+|?L+u7p*>g+-y>mlfpVw#lhNEi7vh7gjG~(Uq>G!fe zH4%%KL4Sy?>h}(Kd#R~*wE)>IpunNAiqt}2EjXp-BKbhgL-POBd?eA#REXLB2{GIA ziP@gR%s67U6%(_qfS7Gb#B41mW@`yCThoZy@(TKDou{+U?-pOZ1XV5nsum&nA(IE0 z+zsYug7sZ)YlZKq#aQ7sCSy!);(FIJ*~R2MCg-q-kBNs#JCiCfDz+Q^>s_}VTg_EV zkR%dm{xg$b5}fAO2u}0A5uB#KC1%sz#B92andd=sN&Oqwt@QW0&+_zc@IqrvXRD=1 z{7hCcS%i@Qgjmw7mLYL5DP~f@a;Z#Wh%}yN@)?OVzR%=MCa*9#PIfhZpX_QpMs_t` z2-;FLyG+h+{DxW%nj6n#vWm$faK4kAAEZXJT7flOOp2KlaK%(6F+|*_nS4ef?vqSj zXYwKw_Mw}7=w=_f{}Q`yw|8K*r++o5a`&s1NW4rIGO5M5!Eh5oC2AE4Ihn*Wi6PmB z|77wGlUJBLOCk;b$mCuow==mBy|vD>)(g{U|7!Pu2gW?K-mslq+pv{f+pv*bTmMHi zx3{Ms2R{ha|4MZs`Bx_2XVOG9>l>(MeG%2H`ySSWTI>7#*!Sv=sx?RsFxkswIg>^v z#Y|F&)V@ot*8ZAWt^FCbT3ZUnCzJ7>zCO=JXt6d$tp!r^C6o7$_0_yUqF+E2`)5n>kYA!gyd#4P+CF$<3nv*0CS7Q8^rf+vWXf0~&2UlKF_17^lD zGm4mbpAs`Km6&-+#LWE@F>`Z>nd@X`G%<5Zh?!GJ%$x*bX1j=)T}jOBEMjIg5i_fS zm{~={bS@;Ovz?gEDq?1?AZF%LVrIIDnbA$mj8(+USU}8lKQYsLiJ88Pm}!H=OdB9( znwOZVn~0hE7sO0mN6eH9h?#O8F;g}WGhqiY6NZVIa4s>Et|eyDUlB9uB4Q>UAZFqy zF%z#QX7Vv&CV!il$@_^J{{S)L|DKrfcMvn~1To`&NX)qVi5dG6F=JmKX6zHhjCqro zF~1~c%!|Z~{)m{-zawV!8_bMnW(+Z-J|kvS1u>&anVC*Z$1-9%mJriXPfUefr?Bf3 zcAb3>N!qU@N&7aEv@uK@!?ZC>`!*O_XIu%}iA3%94cxFnP*ah+83tlB?P4&u5q>ox z#)rF;Ud*mj8-Xl%54Ss_X8+0_uDal-svApRV4)uoX+Le&B1GFyl4$!|Eb}uaP7qDd zo9$eUdogIR?aw6K_Marx_8ya5vkiubIO|iL<{wd==6_`2zh`nt%>;{^zolj%xm?99Uh`Hp4awPDww}wn zxNIqxwQ^YvmlbnaHkT<>*7PBjHT{Chn*N2#n!X#vM%sjsjZLFuW7D_DxTY(aZ07a` zxxHR)&%^Dtb6Gu?m2+7xlPnfVVi5<4G=53U#@`dO@f~Kejg2pH*?nMRPJkc9hJ?&) zyp_ys+)ws3UeDwLZt@&%(nmHlvYCx+W+R)~$YwUOnT>2_Bb(XCX1du-_bF=A{VQtI z{Znew&8~E#D^rD;+FpdrbF&xS>_s_LVGf4yL;~eHNzSUI8NR_F>w~X}poJ zcX9e_nC|5C5=^h+bStJkoUTw8V-vY*2a*JJ84^2@hA-6>kZbsuL>k^Ak%k{L^Pklv zSayQT9#)rP?m-s$p1K@!cXBI7)J2%Pnd@x<-TIgY_-tx}pF-2nO)+WcAX5J>+UX}d z>)%lEhf(TZMAjN+J*}=p)QdW1G$?wS8 zy5AD6y0<8hb-yIAb^lKA>RzU>);&*{>z*Z)bw8pY*ZqJL);&UC>mHz=-w8 z8@Fs;?luGh=;yj-t?&0WOR7jX4@Hn)ab zsp3`&*xX!hEQ=dUWEaG7o6*!}?OWhNW70gU&&z?UeV&|H`!sp4_E9GPhcwsT4t1is z;g9@XdjPTyJ@+lhDWWJ3=Kr)F9~>}vdfjmAIRLj!{Se&RSQU3^HJ>tho5>SURqsO{ zVM@(CWJ=93vZ3ZMlk3Qon#)z(X4h<2yO8{)+6~0Tt-82X*UQwn>jV=Obfk!3%DYfP z;o3`DTzjZ_*A61phe2BJU?5GR)mM{f^=_8gMx^RSv+;d!B0#cLJ4v=`I}2?hQu!Fj z>P|tnTUK`LF0w5-#F^6rD@Lg?E{o z?)T#P2SuiEKS>wfz+zVsDR|D@bXQNG7RG{yNVwoWmg26M|3`DvovYxFcO3a|lXU*; zB%S{f6Fg7SLxa-V{v_{xlFoaZ#PVKc5+5M#(b~@agrsxdC$Zc&nWP6wYi;LzLDD&& zkXX*UO!8!DkFYz(LDJb@kXZIdOv(bJJzCq@i7f3Pv8>OS)JoFOv}Si!CP`-{l9=-} zla@eft!-xkNjo!HES5;-;s9yklgtW|&MaWDR3aIkKxwV*jCzvJs9>=iBI!M{wCkaSubi@AuTZVZqXcBgidbZQ5SH4#bK94M`|owAmsQ#x5} zA(4b_Ag#|1*sHh;CiIhV!djMEK_uy_0Aa1=q#+VcI)|nFL=tb5g@w_HJ4rZkJ4w78NI32&OC2B*`s`1gk$exsbfT9UJDS`T8?>|gkv6OsRxKep9EojZ2~{Do1spAS*=}18O!FeYyuGld#Jv0!BGp%d2nKn zw^(pMkN074?vBL1TN2e;wQnL(`yk7#C1S%cXNuL+-{tnW`NoD?w?VKW&>UpN0ZpH= zYkah1V9U;3rRCRn%1h7R3_l2XUg@@r`M3O#cMYDwozXdd*b&V&Dj*pZ9fRByNZN_J z;1A zem&$nP5Ca!uQcVCLLT~wE?;fY+U6v!t-m0xt^b#_wmw5zTYo@WTfZS|Z5@!cwyu%2 zwth|4+FEDP+L}vRTYe7R438vxJ?mDk^1#Ctbp`jen3dd%QduAh`dmMk*c;STlA=Cv zoHo=g&x07{@5eTlV_3mGwg&|JLBTn06habYT22TVs=7=F2CJ$U9;dy1%R^GtMN?JP z3y;%{K+B+1by^0mk*ex8g<~)Xo7|+^6s)RVs2SWWRmCVx>S4W53r^X%cnpXBc8=qt zy0bAEOG!M5ZvGsS@K_I%zqa(2=ATe+XOL|vgSQkPNans34h1@2wfsi{bO&@pi1 zVP8*EV)NBnaS!lUB7ZH*^>XnJY^_6GsxGEmyJnd3q6pJT`g~9I5PctQilyZ5A=&h~ z5c@z~N!$3Og73aAt@26_bG>= zYDmCR>Pf`=knZH`w`=X%GmvY~yq-uleL8_t4~`8`Ox3Ajdk#v#$PQF%^pN^>hFa)) zD8JC+g!(FSLhVPElG-=8q;ULjG60V9z#n0bS_yxg>V!W|!G;uWw@}Utf1K)qKNt@9 z7(Hq={4uu&{y4P;{>Xi`$*jX6R5*kNhfv@U?K?#C4sN}R{8dk%4fKgSpPD~#i;8Bm zqFJnH_9~jSie{@qmg4h#MYB`UtW-1`YhaKii;*OTGQ|S|jvAl0c(CR%@}LWCA5&PAFL-3D^vHzj%E2RBMUlb59|~Xa$X4ASh)<4e)e%c%t8SpkR;?ADto zD`B6*zMENOE8k%3ysxmvrt(=!WGf%0$X4zVnx}^xm$}NFqVDujEXlrXk*38qW<(TqKy^Liu%*XNcKN5IYx{@g>}KL;03oL z>;=~}Tfw5MBM*DwHP2SO?IPr1FTCd2iq|nhZdq@&=-QXjCae5u;n|r*w)`4V%YaGTnJk-2K8@r40*6E?m(?3k!OvoTwCs}-YpOIvoWC9-7~ zQDn>7gyvAlgYTfq>P7uf$h|bqEy&A7{ZPn*@1V-^0+Gu*sM7mH`=Ri$eSwiJy;IZ= zh0i=E8IdhLBI<|2XP%Rc-dnmq5TCK);A~uag(b43TPU)ndSoU?zI2kCzEU_J=b2_| z)OFfTUtm;A^F{rsQMXTW(^r}h{%>$BU{3e zEtxX19W>4+yPYoy8CgCK5V!Mzku3=sSw0S!>~_9HiY&%;37<=vB3t~h=slD7T&y`6 z#$vr^Ox=4Y!&t2MjH!F?WEhL7XK2TsK@Mw*ueXfZ;vF<*ix&h(zMNt@^+8RsThz6p z=DQ*Jpe8V~#g(GI6*V99@X9_Z>H@6Ks4+T=gCH-`_og$8Y|#l}qZMPY!>B-vMS9P& zVhrans)%~l6#wGipA< z3k!9Vh%DN$NL?NzvW0I89ReT9hJPSS1pk(c!nZdaFgL3j!gKGE!ZopX0J{6Y^mUzqCR_V zy5~y;mx}slOnQD+Fv)6zBR8CRsbGo~C!Beypvtfjbxs>&5!Rm~vay!P=6_0&&3}CS zmgwYlyS_gl`^}!!M zck;s@JeLB%Hhkck|B%I$Amc=s60n4uOwn#RK&eBs#9=bTq1oXOW;nwXL$rGre3-=^Q4D`5>{gLM<`luXbfiz>APMnetW1dtCu zq|c8uyKE;Z3s1B`y#UrJwTeA$Ho-;(_FtI;O`Kl?hl5PncO=&?wpcKm7?Xkzz;7bJ z#P|pp6kW=FY<6ptMg43dOYQ#w{Hw*4@}ENWhign&vso}6Aih^dJ&LXNFiv?jv)$G=pMs=Y@eb`Yoc^uBL z(ItE*8Fp0Nl5R^>O~Ymy5zVoV-e?-Vxz9`L<|fwElf?R9pK6-UwN4&$5olvaKoOXH zp3eP&1^!$_T3#k5o2YY-OUlCwwY&%zi?2RY!^u-4w(1(NRYLMjcHU=b~`jNaS?8ofEMNb0PyUM@C|Ave@CP^P!`=2+(rYn*F@ z1tIs*WWhAn-kg83fValERj3cSdnWba&eA!LNxC`C=ziFC&SdLMT>$S*a?X(&wnh{= zx=-gNs%Kg(utrsP>)c1R+oIkYRq`@=VveJ_Owv6!qc_K88NE4KG9eQ&l`(mkV)YGcI|(I(62%`T$RoAtJ&j$)gR{md>+<1#>=2XZ^$ip5rVXhYR&{J4-+9uk(FL-TcQIPDhP{U#E5MnD02l(yt%- zI)7mSKfiH?B|;nxJ71P`&nC_ov@i9Yvva4^@cc&sE+Tq? zMSU0%?WPVj>xiB!=?;h}yaQ-Bcp4Gywv67)1vGjyzL3<-MXYTfPV0m+!#aP=I@WM@ z7VZgU#(NeA%sSR^a2D1HWyV{Q?r>sl{{t4vYF(M>O2C$c!zL?r?+WU3lwr@V}d(*9R zhdIvtw$S{YPNx6f0^S^F?FB#KfVsWzO+P8=#yF$%;pM&mf{fc2jAaETcDV9gW_!OiA4ou@3l3 zim`#8#T`OPD5DWW>JYj5h+l5SH}r~mS+zH?5! zz%qJMH_+%!Es)gBG}h3$uH$e6Ug-5t4p;@ zx~GaYe)pWh8S*YE@;Fo9NTS!WDOf3C0V*-q8^S6?6XjRLg&rCR%;O{DBQy%{z68PcV)HoOb3HegJ zkW&oQ{5pN>Cn4RaXn_q4(>wS{kLyB)y{IyUFoM9ePy<6Rrc|y{rmspWtgovv-J`hQrRM$Wv0v6=9Dyht< z!yphIooZ{72;>u=*M(%iCqAVYSgjRW?ZK^0d{nAySc@&O1(-NVS@XSp;{8U&pngw0 zV)1+84dnO4wR%+nL|saLPwdo7ra}^fg{IDv2v31b<77$@cBkq0O%q#;iV_IK{GRp$ zsmZVFLc(0`CCM-A1yfl|WzGPTlb@C9PH8e&Vmx_He!{3InJj+KHTfQk-;-}8zbBug zSGB8)#7u+zJ-J^mVI=@9p%#9*bn4L=|Eg3se80!PXjBa9_xMLGeviMK{2squuc`x47o*?fhxC%r zNMiNLGX89-S||{pDEbJtPZMVRnMUORARbzE;=a%YbaQER#(k_8gtitXOhYv8U8!y; zla2l!_l8k1z+8Cx3rgaiwfH^mVe)(29=)nvQI}~eEBZZdr(R-4;t0`s;x3e`2@v*7 za_$rlA>%e16%ho+;={oH9+#*K1^C^r7nrT3bg2Fw`ha|#(rQ_4C?pTS1o>z zeTMuVdy`&O1EO~Dj2XLEFA0t$n%IGpW$ZVlYLkHA6;7HgV=px-nn0lYPwGE_9b2Fa z$$pPb*9(GMOWfe=YHX}jcM_9>tgA79GAf!(HnssV?^^sG^E2{$%u!QSeJ6?iJ?5}p zVke^~*+XKPY0$=u=+!g_gn9T70|QB3km;8p<@r6PUKf)69#f_lXllVM{gmTN%Kkhgb~y$zcm$qpwF9%a9IZ+RGvkmSF fPzE*IU|(}Bs1}=Y`t*MRVAZ!4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST new file mode 100644 index 00000000..9b3b2897 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ROTATEF ;; ;; Source: Steele's book ;; Section 7.2: Generalized Varibles Page: 93 ;; ;; Created By: Jim Blum ;; ;; ;; Creation Date: Nov 4, 1986 ;; ;; Last Update: Nov 25, 1986, Changes were made to ROTATEF-PUTHSH and ;; ROTATEF-CHAR by John Park ;; ;; ;; Filed As: {ERIS}CML>TEST>7-2-ROTATEF.TEST ;; ;; ;; Syntax: (rotatef {place}*) ;; ;; ;; Function Description: ;; ;; Each place form may be any form acceptable as a generalized variable ;; to setf. In the form (rotatef place1 place2 ... placen), the values ;; in place1 through placen are accessed and saved. Values 2 through n ;; and value 1 are then store into place1 through placen. It is as if all ;; the places form an end-around shift register that is rotated one place ;; to the left, with value of place1 being shifted around the end to ;; placen. Note that (rotatef place1 place2) exchanges the contents of ;; place1 and place2. ;; ;; ;; Argument(s): PLACE - when evaluated accesses a data object in ;; some location and "inverts" it to produce ;; corresponding form to update the location ;; ;; ;; Returns: NIL ;; ;; (DO-TEST ROTATEF-OF-A-SYMBOL (AND (SETQ FOO 1) (SETQ BAR 2) (SETQ BAZ 3) (SETQ BLETCH 4) (NOT (ROTATEF BAR FOO BAZ BLETCH)) (EQ FOO 3) (EQ BAR 1) (EQ BAZ 4) (EQ BLETCH 2))) (DO-TEST ROTATEF-CAR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (SETQ BAZ '(C . C)) (SETQ BLETCH '(D . D)) (NOT (ROTATEF (CAR FOO) (CAR BAR) (CAR BAZ) (CAR BLETCH))) (EQUAL FOO '(B . A)) (EQUAL BAR '(C . B)) (EQUAL BAZ '(D . C)) (EQUAL BLETCH '(A . D)))) (DO-TEST ROTATEF-CDR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (SETQ BAZ '(C . C)) (SETQ BLETCH '(D . D)) (NOT (ROTATEF (CDR FOO) (CDR BAR) (CDR BAZ) (CDR BLETCH))) (EQUAL FOO '(A . B)) (EQUAL BAR '(B . C)) (EQUAL BAZ '(C . D)) (EQUAL BLETCH '(D . A)))) (DO-TEST ROTATEF-CAAR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CAAR FOO) (CAAR BAR) (CAAR BAZ) (CAAR BLETCH))) (EQUAL FOO '((E . B) C . D)) (EQUAL BAR '((I . F) G . H)) (EQUAL BAZ '((M . J) K . L)) (EQUAL BLETCH '((A . N) O . P)))) (DO-TEST ROTATEF-CADR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CADR FOO) (CADR BAR) (CADR BAZ) (CADR BLETCH))) (EQUAL FOO '((A . B) G . D)) (EQUAL BAR '((E . F) K . H)) (EQUAL BAZ '((I . J) O . L)) (EQUAL BLETCH '((M . N) C . P)))) (DO-TEST ROTATEF-CDAR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CDAR FOO) (CDAR BAR) (CDAR BAZ) (CDAR BLETCH))) (EQUAL FOO '((A . F) C . D)) (EQUAL BAR '((E . J) G . H)) (EQUAL BAZ '((I . N) K . L)) (EQUAL BLETCH '((M . B) O . P)))) (DO-TEST ROTATEF-CDDR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CDDR FOO) (CDDR BAR) (CDDR BAZ) (CDDR BLETCH))) (EQUAL FOO '((A . B) C . H)) (EQUAL BAR '((E . F) G . L)) (EQUAL BAZ '((I . J) K . P)) (EQUAL BLETCH '((M . N) O . D)))) (DO-TEST ROTATEF-CAAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CAAAR FOO) (CAAAR BAR) (CAAAR BAZ) (CAAAR BLETCH))) (EQUAL FOO '(((I . B) C . D) (E . F) G . H)) (EQUAL BAR '(((Q . J) K . L) (M . N) O . P)) (EQUAL BAZ '(((1 . R) S . T) (U . V) W . X)) (EQUAL BLETCH '(((A . 2) 3 . 4) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CAADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CAADR FOO) (CAADR BAR) (CAADR BAZ) (CAADR BLETCH))) (EQUAL FOO '(((A . B) C . D) (M . F) G . H)) (EQUAL BAR '(((I . J) K . L) (U . N) O . P)) (EQUAL BAZ '(((Q . R) S . T) (5 . V) W . X)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (E . 6) 7 . 8)))) (DO-TEST ROTATEF-CADAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CADAR FOO) (CADAR BAR) (CADAR BAZ) (CADAR BLETCH))) (EQUAL FOO '(((A . B) K . D) (E . F) G . H)) (EQUAL BAR '(((I . J) S . L) (M . N) O . P)) (EQUAL BAZ '(((Q . R) 3 . T) (U . V) W . X)) (EQUAL BLETCH '(((1 . 2) C . 4) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CADDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CADDR FOO) (CADDR BAR) (CADDR BAZ) (CADDR BLETCH))) (EQUAL FOO '(((A . B) C . D) (E . F) O . H)) (EQUAL BAR '(((I . J) K . L) (M . N) W . P)) (EQUAL BAZ '(((Q . R) S . T) (U . V) 7 . X)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (5 . 6) G . 8)))) (DO-TEST ROTATEF-CDAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDAAR FOO) (CDAAR BAR) (CDAAR BAZ) (CDAAR BLETCH))) (EQUAL FOO '(((A . J) C . D) (E . F) G . H)) (EQUAL BAR '(((I . R) K . L) (M . N) O . P)) (EQUAL BAZ '(((Q . 2) S . T) (U . V) W . X)) (EQUAL BLETCH '(((1 . B) 3 . 4) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CDADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDADR FOO) (CDADR BAR) (CDADR BAZ) (CDADR BLETCH))) (EQUAL FOO '(((A . B) C . D) (E . N) G . H)) (EQUAL BAR '(((I . J) K . L) (M . V) O . P)) (EQUAL BAZ '(((Q . R) S . T) (U . 6) W . X)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (5 . F) 7 . 8)))) (DO-TEST ROTATEF-CDDAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDDAR FOO) (CDDAR BAR) (CDDAR BAZ) (CDDAR BLETCH))) (EQUAL FOO '(((A . B) C . L) (E . F) G . H)) (EQUAL BAR '(((I . J) K . T) (M . N) O . P)) (EQUAL BAZ '(((Q . R) S . 4) (U . V) W . X)) (EQUAL BLETCH '(((1 . 2) 3 . D) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CDDDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDDDR FOO) (CDDDR BAR) (CDDDR BAZ) (CDDDR BLETCH))) (EQUAL FOO '(((A . B) C . D) (E . F) G . P)) (EQUAL BAR '(((I . J) K . L) (M . N) O . X)) (EQUAL BAZ '(((Q . R) S . T) (U . V) W . 8)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . H)))) (DO-TEST ROTATEF-CAAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAAAAR FOO) (CAAAAR BAR) (CAAAAR BAZ) (CAAAAR BLETCH))) (EQUAL FOO '((((AA . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AAA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((A . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CAAADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAAADR FOO) (CAAADR BAR) (CAAADR BAZ) (CAAADR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((II . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((III . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((IIII . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((I . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CAADAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAADAR FOO) (CAADAR BAR) (CAADAR BAZ) (CAADAR BLETCH))) (EQUAL FOO '((((A . B) C . D) (EE . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EEE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (E . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CAADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAADDR FOO) (CAADDR BAR) (CAADDR BAZ) (CAADDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (MM . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MMM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (M . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADAAR FOO) (CADAAR BAR) (CADAAR BAZ) (CADAAR BLETCH))) (EQUAL FOO '((((A . B) CC . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CCC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) C . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADADR FOO) (CADADR BAR) (CADADR BAZ) (CADADR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) KK . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KKK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) K . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADDAR FOO) (CADDAR BAR) (CADDAR BAZ) (CADDAR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) GG . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GGG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) G . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADDDR FOO) (CADDDR BAR) (CADDDR BAZ) (CADDDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) OO . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OOO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) O . PPPP)))) (DO-TEST ROTATEF-CDAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDAAAR FOO) (CDAAAR BAR) (CDAAAR BAZ) (CDAAAR BLETCH))) (EQUAL FOO '((((A . BB) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BBB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . B) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDADDR FOO) (CDADDR BAR) (CDADDR BAZ) (CDADDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . NN) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NNN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . N) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDAAR FOO) (CDDAAR BAR) (CDDAAR BAZ) (CDDAAR BLETCH))) (EQUAL FOO '((((A . B) C . DD) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DDD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . D) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDADR FOO) (CDDADR BAR) (CDDADR BAZ) (CDDADR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . LL) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LLL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . L) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDDAR FOO) (CDDDAR BAR) (CDDDAR BAZ) (CDDDAR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . HH) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HHH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . H) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDDDR FOO) (CDDDDR BAR) (CDDDDR BAZ) (CDDDDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . PP)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PPP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . P)))) (DO-TEST ROTATEF-FIRST (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (FIRST FOO) (FIRST BAR) (FIRST BAZ) (FIRST BLETCH))) (EQUAL FOO '(AA B C D E F G H I J)) (EQUAL BAR '(AAA BB CC DD EE FF GG HH II JJ)) (EQUAL BAZ '(AAAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(A BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-SECOND (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (SECOND FOO) (SECOND BAR) (SECOND BAZ) (SECOND BLETCH))) (EQUAL FOO '(A BB C D E F G H I J)) (EQUAL BAR '(AA BBB CC DD EE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBBB CCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA B CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-THIRD (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (THIRD FOO) (THIRD BAR) (THIRD BAZ) (THIRD BLETCH))) (EQUAL FOO '(A B CC D E F G H I J)) (EQUAL BAR '(AA BB CCC DD EE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB C DDDD EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-FOURTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (FOURTH FOO) (FOURTH BAR) (FOURTH BAZ) (FOURTH BLETCH))) (EQUAL FOO '(A B C DD E F G H I J)) (EQUAL BAR '(AA BB CC DDD EE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC D EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-FIFTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (FIFTH FOO) (FIFTH BAR) (FIFTH BAZ) (FIFTH BLETCH))) (EQUAL FOO '(A B C D EE F G H I J)) (EQUAL BAR '(AA BB CC DD EEE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD E FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-SIXTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (SIXTH FOO) (SIXTH BAR) (SIXTH BAZ) (SIXTH BLETCH))) (EQUAL FOO '(A B C D E FF G H I J)) (EQUAL BAR '(AA BB CC DD EE FFF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE F GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-SEVENTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (SEVENTH FOO) (SEVENTH BAR) (SEVENTH BAZ) (SEVENTH BLETCH))) (EQUAL FOO '(A B C D E F GG H I J)) (EQUAL BAR '(AA BB CC DD EE FF GGG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF G HHHH IIII JJJJ)))) (DO-TEST ROTATEF-EIGHTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (EIGHTH FOO) (EIGHTH BAR) (EIGHTH BAZ) (EIGHTH BLETCH))) (EQUAL FOO '(A B C D E F G HH I J)) (EQUAL BAR '(AA BB CC DD EE FF GG HHH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGG HHHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG H IIII JJJJ)))) (DO-TEST ROTATEF-NINTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (NINTH FOO) (NINTH BAR) (NINTH BAZ) (NINTH BLETCH))) (EQUAL FOO '(A B C D E F G H II J)) (EQUAL BAR '(AA BB CC DD EE FF GG HH III JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH IIII JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH I JJJJ)))) (DO-TEST ROTATEF-TENTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (TENTH FOO) (TENTH BAR) (TENTH BAZ) (TENTH BLETCH))) (EQUAL FOO '(A B C D E F G H I JJ)) (EQUAL BAR '(AA BB CC DD EE FF GG HH II JJJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII J)))) (DO-TEST ROTATEF-REST (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (REST FOO) (REST BAR) (REST BAZ) (REST BLETCH))) (EQUAL FOO '(A BB CC DD EE FF GG HH II JJ)) (EQUAL BAR '(AA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BAZ '(AAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (EQUAL BLETCH '(AAAA B C D E F G H I J)))) (DO-TEST ROTATEF-NTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (NTH 6 FOO) (NTH 6 BAR) (NTH 6 BAZ) (NTH 6 BLETCH))) (EQUAL FOO '(A B C D E F GG H I J)) (EQUAL BAR '(AA BB CC DD EE FF GGG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF G HHHH IIII JJJJ)))) (DO-TEST ROTATEF-NTHCDR (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (NTHCDR 6 FOO) (NTHCDR 6 BAR) (NTHCDR 6 BAZ) (NTHCDR 6 BLETCH))) (EQUAL FOO '(A B C D E F GG HH II JJ)) (EQUAL BAR '(AA BB CC DD EE FF GGG HHH III JJJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGGG HHHH IIII JJJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF G H I J)))) (DO-TEST ROTATEF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AA BB CC DD EE FF GG HH II JJ))) (SETQ BAZ (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAA BBB CCC DDD EEE FFF GGG HHHH IIII JJJJ))) (SETQ BLETCH (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ))) (NOT (ROTATEF (AREF FOO 6) (AREF BAR 6) (AREF BAZ 6) (AREF BLETCH 6))) (EQ (AREF FOO 6) 'GG) (EQ (AREF BAR 6) 'GGG) (EQ (AREF BAZ 6) 'GGGG) (EQ (AREF BLETCH 6) 'G))) (DO-TEST ROTATEF-SVREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AA BB CC DD EE FF GG HH II JJ))) (SETQ BAZ (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAA BBB CCC DDD EEE FFF GGG HHHH IIII JJJJ))) (SETQ BLETCH (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ))) (NOT (ROTATEF (SVREF FOO 6) (SVREF BAR 6) (SVREF BAZ 6) (SVREF BLETCH 6))) (EQ (SVREF FOO 6) 'GG) (EQ (SVREF BAR 6) 'GGG) (EQ (SVREF BAZ 6) 'GGGG) (EQ (SVREF BLETCH 6) 'G))) (DO-TEST ROTATEF-GET (AND (SETF (GET 'FOO 'A) 'B) (SETF (GET 'BAR 'C) 'D) (SETF (GET 'BAZ 'E) 'F) (SETF (GET 'BLETCH 'G) 'H) (NOT (ROTATEF (GET 'FOO 'A) (GET 'BAR 'C) (GET 'BAZ 'E) (GET 'BLETCH 'G))) (EQ (GET 'FOO 'A) 'D) (EQ (GET 'BAR 'C) 'F) (EQ (GET 'BAZ 'E) 'H) (EQ (GET 'BLETCH 'G) 'B))) (DO-TEST ROTATEF-GETF (AND (SETQ FOO '(B C D E F)) (SETQ BAR '(H I J K L)) (SETQ BAZ '(M N O P Q)) (SETQ BLETCH '(R S T U V)) (NOT (ROTATEF (GETF FOO 'D) (GETF BAR 'J) (GETF BAZ 'O) (GETF BLETCH 'T))) (EQUAL FOO '(B C D K F)) (EQUAL BAR '(H I J P L)) (EQUAL BAZ '(M N O U Q)) (EQUAL BLETCH '(R S T E V)))) (DO-TEST ROTATEF-GETHASH (AND (SETQ FOO (MAKE-HASH-TABLE)) (SETF (GETHASH 'A FOO) 'B) (SETF (GETHASH 'C FOO) 'D) (SETF (GETHASH 'E FOO) 'F) (SETF (GETHASH 'G FOO) 'H) (NOT (ROTATEF (GETHASH 'A FOO) (GETHASH 'C FOO) (GETHASH 'E FOO) (GETHASH 'G FOO))) (EQ (GETHASH 'A FOO) 'D) (EQ (GETHASH 'C FOO) 'F) (EQ (GETHASH 'E FOO) 'H) (EQ (GETHASH 'G FOO) 'B))) (DO-TEST ROTATEF-SYMBOL-FUNCTION (AND (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (A) NIL)) (SETF (SYMBOL-FUNCTION 'BAR) '(LAMBDA (B) NIL)) (SETF (SYMBOL-FUNCTION 'BAZ) '(LAMBDA (C) NIL)) (SETF (SYMBOL-FUNCTION 'BLETCH) '(LAMBDA (D) NIL)) (NOT (ROTATEF (SYMBOL-FUNCTION 'FOO) (SYMBOL-FUNCTION 'BAR) (SYMBOL-FUNCTION 'BAZ) (SYMBOL-FUNCTION 'BLETCH))) (EQUAL (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)) (EQUAL (SYMBOL-FUNCTION 'BAR) '(LAMBDA (C) NIL)) (EQUAL (SYMBOL-FUNCTION 'BAZ) '(LAMBDA (D) NIL)) (EQUAL (SYMBOL-FUNCTION 'BLETCH) '(LAMBDA (A) NIL)))) (DO-TEST ROTATEF-SYMBOL-VALUE (AND (SETF (SYMBOL-VALUE 'FOO) 1) (SETF (SYMBOL-VALUE 'BAR) 2) (SETF (SYMBOL-VALUE 'BAZ) 3) (SETF (SYMBOL-VALUE 'BLETCH) 4) (NOT (ROTATEF (SYMBOL-VALUE 'FOO) (SYMBOL-VALUE 'BAR) (SYMBOL-VALUE 'BAZ) (SYMBOL-VALUE 'BLETCH))) (EQ (SYMBOL-VALUE 'FOO) 2) (EQ (SYMBOL-VALUE 'BAR) 3) (EQ (SYMBOL-VALUE 'BAZ) 4) (EQ (SYMBOL-VALUE 'BLETCH) 1))) (DO-TEST ROTATEF-SYMBOL-PLIST (AND (SETF (SYMBOL-PLIST 'FOO) '(A B C D)) (SETF (SYMBOL-PLIST 'BAR) '(E F G H)) (SETF (SYMBOL-PLIST 'BAZ) '(I J K L)) (SETF (SYMBOL-PLIST 'BLETCH) '(M N O P)) (NOT (ROTATEF (SYMBOL-PLIST 'FOO) (SYMBOL-PLIST 'BAR) (SYMBOL-PLIST 'BAZ) (SYMBOL-PLIST 'BLETCH))) (EQUAL (SYMBOL-PLIST 'FOO) '(E F G H)) (EQUAL (SYMBOL-PLIST 'BAR) '(I J K L)) (EQUAL (SYMBOL-PLIST 'BAZ) '(M N O P)) (EQUAL (SYMBOL-PLIST 'BLETCH) '(A B C D)))) (DO-TEST ROTATEF-MACRO-FUNCTION (AND (SETQ FOO (GENTEMP "FOO")) (SETQ BAR (GENTEMP "BAR")) (SETQ BAZ (GENTEMP "BAZ")) (SETQ BLETCH (GENTEMP "BLETCH")) (SETF (MACRO-FUNCTION FOO) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (SETF (MACRO-FUNCTION BAR) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (SETF (MACRO-FUNCTION BAZ) '(LAMBDA (C) (BQUOTE (CONS (|,| C) (|,| C))))) (SETF (MACRO-FUNCTION BLETCH) '(LAMBDA (D) (BQUOTE (CONS (|,| D) (|,| D))))) (NOT (ROTATEF (MACRO-FUNCTION FOO) (MACRO-FUNCTION BAR) (MACRO-FUNCTION BAZ) (MACRO-FUNCTION BLETCH))) (EQUAL (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (EQUAL (MACRO-FUNCTION BAR) '(LAMBDA (C) (BQUOTE (CONS (|,| C) (|,| C))))) (EQUAL (MACRO-FUNCTION BAZ) '(LAMBDA (D) (BQUOTE (CONS (|,| D) (|,| D))))) (EQUAL (MACRO-FUNCTION BLETCH) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))))) (DO-TEST ROTATEF-CHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (SETQ BAZ "C-STRING") (SETQ BLETCH "D-STRING") (NOT (ROTATEF (CHAR FOO 0) (CHAR BAR 0) (CHAR BAZ 0) (CHAR BLETCH 0))) (EQL (CHAR FOO 0) #\B) (EQL (CHAR BAR 0) #\C) (EQL (CHAR BAZ 0) #\D) (EQL (CHAR BLETCH 0) #\A))) (DO-TEST ROTATEF-SCHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (SETQ BAZ "C-STRING") (SETQ BLETCH "D-STRING") (NOT (ROTATEF (SCHAR FOO 0) (SCHAR BAR 0) (SCHAR BAZ 0) (SCHAR BLETCH 0))) (EQL (SCHAR FOO 0) #\B) (EQL (SCHAR BAR 0) #\C) (EQL (SCHAR BAZ 0) #\D) (EQL (SCHAR BLETCH 0) #\A))) (DO-TEST ROTATEF-BIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (SETQ BAZ #*01010101) (SETQ BLETCH #*10101010) (NOT (ROTATEF (BIT FOO 1) (BIT BAR 1) (BIT BAZ 1) (BIT BLETCH 1))) (EQL (BIT FOO 1) 0) (EQL (BIT BAR 1) 1) (EQL (BIT BAZ 1) 0) (EQL (BIT BLETCH 1) 1))) (DO-TEST ROTATEF-SBIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (SETQ BAZ #*01010101) (SETQ BLETCH #*10101010) (NOT (ROTATEF (SBIT FOO 1) (SBIT BAR 1) (SBIT BAZ 1) (SBIT BLETCH 1))) (EQL (SBIT FOO 1) 0) (EQL (SBIT BAR 1) 1) (EQL (SBIT BAZ 1) 0) (EQL (SBIT BLETCH 1) 1))) (DO-TEST ROTATEF-ELT ; make sure setf-inverse optimizations aware of side-effects (let* ((a '(1 2 3)) (b '(4 5 6)) (c a)) (rotatef (elt a 0) (elt (setq a b) 1)) (and (equal c '(5 2 3)) (equal b '(4 1 6))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..298e4fe2a5360c1a7fb919083f8f626ffa9ffaa2 GIT binary patch literal 302 zcmbQpz#8G~qu`vMTacNPTBML)T2fG2qL7wfq)?n+T9llskOmZ2sCM=ba;^1nboSP> zHslIMl1VN~O)N=GQ3xqbElx?S)KM_BRB$XP%FF>WEG&RrGbT&&_JB?8wpMilPnPESO;$&bDU|?pLF{wvDE5tQ8MAyyJ$5q$Q(brXL z#>5#t96-P5h6cL^&FB#{QYgtU(9KCLOU(g!C%2e^k%3{xgdPsJP(SAoPk+A|lNlQr qd1mzY@Ot{`1^~V0={`w1UkgQAFx|`b8es$gI!od2bwHItycfp3Hm21~Goxk>i_5A})D*y_3T$9DR70oTVD0_ z-V|IPxMA^isTU;ahEuzt?Rg;^)MaIwKh(F?l6_UkhICmIPunWaTSrpJhE>@KG;ew0R&feB_6p&ME(|l5 zR%E$~!p`G`a8wtDxl1*!=Az+zR0zj(VVJ#C<7x_frwZXZU07C^t7@)S-tP$EdR-W1 zF!ym4S1fmf5TBv~?Kvof$LYdQVXko%mrU2!g>aKD3>BstSMw3!`a}pHr3-^D)tE+g zmHN15jSwEM3xh8AaTS}o<{cqCK^1O*cQ5feBo7{_^xKdxEd-BN1;>)0I&)1jyzEt6 z^F^UKQPpf>O(6=Z=8CKOPZX+?RMqjSswNA%mdfisDRd{RxF;aZggP(NgM$gQ!#$27TyWp?$2XJp~ovBy4ZNN>;6URcanSMySsycwxtfB2ZJ< z3r?nHFW7dUy?h_sfT};aFTETZK!L+N+irj=cAyu2MkFz7&0xV)Fc&NZYr$5q7aRqr z3tHmun@*%lq|*YmTw~1R|sZlC( z3LO1Fq9^_xMYZG3lT^`J_-(0RfhABKV=%}I zxKk-uTsEA5=vVO_L!&nJ7pi$oInM#hA&mIFg^hGck5Sk%+;yM`DIWYyVPnObzVYXx z=}-O#sE=7E)Dt8240B<&LCeF$=IIViz`F-Rs3-7y9&97%1#xh9-%!QcWUNhO)jBe( zf~9}!t{J!zY#n^7e=DTaH9Gl3rEp_o)iySxS&_D_dNh2PkCiv9 z@~`$wrq<$(!;Q^t=~R0ceq)VyCQ|L)$xOVp3y{>JY_ln$I87%*SqSAMC?`TW0m=d> z^P$XxG8fA6P>zE#2g+`<&wEbyVawz(~lYwL_>lDT{aJ~X${mug#fSvHsKG0BH|*J`CPMk5qNu=6RBl!!n4haZ0-b1PAITO~=c;3shSq%Hj%ziay-uB{`T=}F}9rw21@%V#plRLN&{MTUEg{|om*dMCFf zvPl+J+<5y={HWfOSe%R}GMU6Ogubps&|IKI(X3QrXl8+*HPPGKO)gX5moK}lr#0Oj z7vJd7Yn)P#CZaT;aVm9S8h%aj8h%Of8h%Xi8g79IuJ&YaI@^UQC%fCx^?J@GyI6-- zF#B9)XPDgxe&+VxR^-&;b$2^n*MCUP^&gOP{afT*k5#m1lD*xDwj?@T1HWzAd}}s& zD*il+Ij1wHn>cm9C$R2A0_%Rl;06Z2#^7=SW1kZk`xAk&4;j3a!HXGO!{CXaTho(h z%cM)&EH(qCVKAG_b;J+7H%S=}DaOVr6VL>(B8#AplRdrgJ9>arqW?uI(O-~Cl-n!H z?G@$ricSTlNA0gAiS9hMLv$>FW)Q~furd*iOPK^FvY!G+en){LKcm2rhpAH|cR{)# zO83zIkKD*U*C~@R%qk8uz+skfm}cNZC32mKY$rN3V5MMUh~GYC3c^-pDwyzRaMwq} z6Ys}!iPmn+J^WJ&9e$fahhL)5;csK;?yfA(GjuwYol@+yke$rv1P;BKG&W-B_sTRh z-zVSDKJpDcO1_~Lpl(}|Y|EuH=+nYJGuY=S@(I38gFN^!-3vZQ_ky?az2(SHpBG`z(RAPZ3yq zKZElaJdVN11p1#Q(7&5N|9uQDU~n#jQwj9#Bha^pK;J(zm}Ib(!4?8*UL&yP6#{FX zWw4LI9D_*$T^|tWdY?eo8w{>za4m!95a{_cfu7F@^!%2=jSPO1!SfijGiV{u{U-w5 zTL^St%iyI9h8YYnXeQ8m8-ZShK<_mSPGGQ!!CC^H4-n|Qk3eUU!I=zBXK);Wj;9E8 zJVBu2UIw}29NcjZ?l}8P4Qy5%8pzSRJZEp~0`#ytbGI$z;iwU&y z3TWjO(8?>IbuD>X3*>1%lRPcFa9Mcavhc!Xxtu&LmyxGsEqi(yv=eCloIvw-0?k_) zyqv*C2J0B~5@@=QK+`=0nr>up7K6t!*hHZGF9gcZ5GX&$U?+n~29G09dYeG$O#-DC zl-P15a<&rfWy%VeKx3Tn;Pds;N|l5)FP=`dB^4jsY5XJ1H7h-Q@z+Q27tL%be3o|O z&tE9B(EJ-dkyZcaloo`F;OOs4!Db1f!4owHD{&TYtj9+z|HZR7JtE`j4tSgA0}lsn1*+O=I2WF zB*bHqWEx%~nTEX-zhM`fv%uf0rUuVQ_UvTOli6i9nfmv^)1`Xy!;zfpUm@rE@3Yr# zHVQO_C7Ei+iq-GH2F&IXnH>FG3W3}rP-|C?!?bdk`OKeArtX81?1X3CYvft?BD*}z z<~;E9h@fqqi3~-pTgtw@?9@&s_Q#S0G}qX>1KnjXncn{QzPaUE}-y%x%RrY<3%_E8*S}J-Qn;mSfV1r#WA{;%UIUM&@l=~{m zeHER=%sMs!Hcm2;-$1xXd3IulMiC=Fq68x^Q)ZE8**wT(h0QiLo7gOeh&5_N^})@N zx;YXzdt@$0ii5Y@#tsveAXGcjgb6eUdRSp zQM7@!l7ym6^fALsCioX(1b@rsby_Ea-vhpw&Ab7jst31Ggy1zyy^KwBNh5(XdxqH4 z!!8n;!0$*T@Nh|X8F<$rMxaQHz*cs>ip@N56-|H(CPxoUVBZFI;tJLN0et0CC|Kj+0`j_;*8oT>ovL8%7$%09;UweVk3`PM{}^10QJzgM z(Ngu_PE7xeOxetaBo~pSe-1E36|-GSRYm_e=0%y{CgY&SwN?Dsy-!`?!)d|3g!t=H(KZTxVB?=Sj^@qSV|^@oR2p za}^Erno~<;vPpb-q?*<&U``7=PiEtzk?(r1M5d!FqYet!%S3VQBVX5JY;LDvCnCmBpA4S&D2C^4B71(w<|(BQ z)&|cmr60{D9_fOcoM4jP& zj;QXTGHOE9+`XQuYnXEun;w)-k+gde^L^!fA?^J$@x7lA(fb=VZ&3$%Uni>frcx>> ztF`uSWa`(MQ($vCN~cNMn`i!*5q!1QUOVxf2Z`wXl+CXdJT7p)OH}7QQ8ewGb6wh8v^K0?oP8rMAPTQF#RW+cc@cLZ4=8^XkQGT+Fs4B{L6H!)}aUGjWsgCl6Ol$?B*sQ^k z2~9wG8uN~3LX3@_GL>c0m3~ypQ}v{$i6`wOg7jTBJ4jF3qI8}CoPfHi#kaLMpJpk( z4rS&^%B)%J|0z^*jI}sCE;n%ghNkhCCB`?cJQx0v)rzLo=kdRfLhLd;J8QhPxZNws zCbPwAvpbxKY%Bt10->>OnPeiD#Fs|(teuWwySsA9OrkrhxX}&XNl(qEb4kj(@jL}0 zNLOQ+>2UN*N4X7z4I^d+F-^-0NW(`YMjqdWaC9+5u^N7=#cH_X3Q68{7y1{B{ZG^V zEyBP4V?+P?cQya|hbS+lQ&~){fSJ|b1L>F{kW{}F6N7tred)*=)UPyF$mt69;RR`S zp-|l~HKDp~nh;@k(4TkFpLcVdOO4~K(c{dAf2GzM&*n1lO$F6wZAqY+vIS49>mqO$ z2A_6UGK?AfSc@6kTOKpEn_|WuqL{H;%45c^GLE@kk9l%&yBP+dtvk`v+Ma+hr*vV9 zZX33>^0@S|g9S!$mhZsigxw!@DpW<nX9coHzX_KRAvR6; z5LF9&II4D2Rc$Dvej(MGB7MDq1friCwp8>(t)-&7Vely}%IV57dT>VX$KOGvOC8$L zyGPvLGUEQXDbzbCXgmv}`YeomYM55!S6W(;on=kXgk~M0DE}jRsBdXJWtmD`ra@{4`rC{{&D2B5f~TCW5`FIpNOZjKWy4UuC$vz$ zt5u%Tq7nNK3Dsj9YJnaK_At03DS7bM>>nAb=551JH7{tPYPJ(k>ExXh_F&BghlD!Y zI8=`wY7Fv}E_G8zp|s``Rd($+4CVTn7Rm*yJWS)#nc#x`O!+R%b%}APReGqo#U0k- z4oh)|xwyk5<{e(D4;A$WEGEiYWhLHNudG%I^k(OZeo69jXh)Z9n4jklT7I5=N0#U} z$`2(xcO04AcSQ1#aef!-`E`5|3CLEoALTdki;znipU6JL{M>)l@^im-7zs+_Z}cxp zxF0$UdGRO)2a#_w&hIKczucFQ=!fw~5-neXjDwfRV~q22Yx#NK86nY+JF8JPf%lma zWZIUEmVA$4e%@_*e#^gXfLeBK)$z_Wtk>?rbH(6^x$A2Fp(Ld_(=lJ(S$fF;; zj^_;Xb3Cl)ci9(~=%?ogHi6^JFHGi#50Q;`a}Iqs=YWUX;h%5){L*x!A!Pp#Bl0K~ zPy6eJ?PuSkwV!=>bQ1j|pTF1y_QBDS4|#YKId7a_o1R~=OroFn<)d7}Y=0~xtDE}K zlHWDV&-RLzpY4_-Y+mq$#rBOOIN&E3+kml7R@a#@GEBat9vB9;P{z9`aIhMmT3Pi| zD=R#54;v=0zTsQ1GjI?`0M?5P>th|z>SLW#8YVyDp@!*3N*zW%xX{7)c*vq34_Wpa zhRM^3h2>5|2R_oUY&NWqz~N78i6KR#@jymkU( z-g#IDb-@4~^R0$D=FPg!GCfTGkV%JO=IaiJPAqgd+E^!`>6m`4E`S`P1&F2>%OE@< zH9cY&%XGUQ>#G{EMLmBq^=gnfk}}OVjx|M#C4XK*Y@uUX8Mb0(oOEh+Austw!&vfT zdaNr|VhcAU5@9nvGFGo~tdsOuHJkzd%@OHSH5p Tmom%XElIisL`^?Bc<}!L;YKcs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST b/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST new file mode 100644 index 00000000..297eecb0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SHIFTF ;; ;; Source: Steele's book ;; Section 7.2: Generalized Varibles ;; Page: 93 ;; ;; Created By: Jim Blum ;; ;; ;; ;; ;; Last Update: Nov 25, 1986, changes were made to SHIFTF-CAADDR, ;; SHIFTF-GETHASH, SHIFTF-APPLY-OF-AREF and reformatted for readability by John Park ;; ;; ;; Filed As: {ERIS}CML>TEST>7-2-SHIFTF.TEST ;; ;; ;; Syntax: (shiftf {place}+ newvalue) ;; ;; ;; ;; ;; The values in place1 through placen are accesed and saved, and newvalue is ;; evaluated, for a total of n + 1 values in all. Values 2 through n +1 are then stored into ;; place1 through placen, and value 1 (the original value of place1) is returned. It is as if ;; all the places form a shift register; the newvalue is shifted in from the right, all values ;; shift over to the left one place, and the value shifted out of place1 is returned. ;; ;; ;; ;; ;; Argument(s): PLACE - when evaluated accesses a data object in ;; some location and "inverts" it to produce ;; corresponding form to update the location ;; NEWVALUE - when evaluated gets stored according to the ;; above update form created. ;; ;; Returns: the value shifted out of place1 ;; ;; ;; (DO-TEST SHIFTF-OF-A-SYMBOL (AND (SETQ FOO 1) (EQ (SHIFTF FOO 2) 1) (EQ FOO 2))) (DO-TEST SHIFTF-CAR (AND (SETQ FOO '(A . B)) (EQ (SHIFTF (CAR FOO) 'C) 'A) (EQUAL FOO '(C . B)))) (DO-TEST SHIFTF-CDR (AND (SETQ FOO '(A . B)) (EQ (SHIFTF (CDR FOO) 'C) 'B) (EQUAL FOO '(A . C)))) (DO-TEST SHIFTF-CAAR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CAAR FOO) 'E) 'A) (EQUAL FOO '((E . B) C . D)))) (DO-TEST SHIFTF-CADR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CADR FOO) 'E) 'C) (EQUAL FOO '((A . B) E . D)))) (DO-TEST SHIFTF-CDAR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CDAR FOO) 'E) 'B) (EQUAL FOO '((A . E) C . D)))) (DO-TEST SHIFTF-CDDR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CDDR FOO) 'E) 'D) (EQUAL FOO '((A . B) C . E)))) (DO-TEST SHIFTF-CAAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CAAAR FOO) 'I) 'A) (EQUAL FOO '(((I . B) C . D) (E . F) G . H)))) (DO-TEST SHIFTF-CAADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CAADR FOO) 'I) 'E) (EQUAL FOO '(((A . B) C . D) (I . F) G . H)))) (DO-TEST SHIFTF-CADAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CADAR FOO) 'I) 'C) (EQUAL FOO '(((A . B) I . D) (E . F) G . H)))) (DO-TEST SHIFTF-CADDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CADDR FOO) 'I) 'G) (EQUAL FOO '(((A . B) C . D) (E . F) I . H)))) (DO-TEST SHIFTF-CDAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDAAR FOO) 'I) 'B) (EQUAL FOO '(((A . I) C . D) (E . F) G . H)))) (DO-TEST SHIFTF-CDADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDADR FOO) 'I) 'F) (EQUAL FOO '(((A . B) C . D) (E . I) G . H)))) (DO-TEST SHIFTF-CDDAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDDAR FOO) 'I) 'D) (EQUAL FOO '(((A . B) C . I) (E . F) G . H)))) (DO-TEST SHIFTF-CDDDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDDDR FOO) 'I) 'H) (EQUAL FOO '(((A . B) C . D) (E . F) G . I)))) (DO-TEST SHIFTF-CAAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAAAAR FOO) 'Q) 'A) (EQUAL FOO '((((Q . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CAAADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAAADR FOO) 'Q) 'I) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((Q . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CAADAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAADAR FOO) 'Q) 'E) (EQUAL FOO '((((A . B) C . D) (Q . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CAADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAADDR FOO) 'Q) 'M) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (Q . N) O . P)))) (DO-TEST SHIFTF-CADAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADAAR FOO) 'Q) 'C) (EQUAL FOO '((((A . B) Q . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CADADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADADR FOO) 'Q) 'K) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) Q . L) (M . N) O . P)))) (DO-TEST SHIFTF-CADDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADDAR FOO) 'Q) 'G) (EQUAL FOO '((((A . B) C . D) (E . F) Q . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CADDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADDDR FOO) 'Q) 'O) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) Q . P)))) (DO-TEST SHIFTF-CDAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDAAAR FOO) 'Q) 'B) (EQUAL FOO '((((A . Q) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CDADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDADDR FOO) 'Q) 'N) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . Q) O . P)))) (DO-TEST SHIFTF-CDDAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDAAR FOO) 'Q) 'D) (EQUAL FOO '((((A . B) C . Q) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CDDADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDADR FOO) 'Q) 'L) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . Q) (M . N) O . P)))) (DO-TEST PSETF-CDDDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDDAR FOO) 'Q) 'H) (EQUAL FOO '((((A . B) C . D) (E . F) G . Q) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CDDDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDDDR FOO) 'Q) 'P) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . Q)))) (DO-TEST SHIFTF-FIRST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (FIRST FOO) 'A) 1) (EQUAL FOO '(A 2 3 4 5 6 7 8 9 10)))) (DO-TEST SHIFTF-SECOND (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (SECOND FOO) 'B) 2) (EQUAL FOO '(1 B 3 4 5 6 7 8 9 10)))) (DO-TEST SHIFTF-THIRD (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (THIRD FOO) 'C) 3) (EQUAL FOO '(1 2 C 4 5 6 7 8 9 10)))) (DO-TEST SHIFTF-FOURTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (FOURTH FOO) 'D) 4) (EQUAL FOO '(1 2 3 D 5 6 7 8 9 10)))) (DO-TEST SHIFTF-FIFTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (FIFTH FOO) 'E) 5) (EQUAL FOO '(1 2 3 4 E 6 7 8 9 10)))) (DO-TEST SHIFTF-SIXTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (SIXTH FOO) 'F) 6) (EQUAL FOO '(1 2 3 4 5 F 7 8 9 10)))) (DO-TEST SHIFTF-SEVENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (SEVENTH FOO) 'G) 7) (EQUAL FOO '(1 2 3 4 5 6 G 8 9 10)))) (DO-TEST SHIFTF-EIGHTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (EIGHTH FOO) 'H) 8) (EQUAL FOO '(1 2 3 4 5 6 7 H 9 10)))) (DO-TEST SHIFTF-NINTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (NINTH FOO) 'I) 9) (EQUAL FOO '(1 2 3 4 5 6 7 8 I 10)))) (DO-TEST SHIFTF-TENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (TENTH FOO) 'J) 10) (EQUAL FOO '(1 2 3 4 5 6 7 8 9 J)))) (DO-TEST SHIFTF-REST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQUAL (SHIFTF (REST FOO) '(A B C D E F G H I J)) '(2 3 4 5 6 7 8 9 10)) (EQUAL FOO '(1 A B C D E F G H I J)))) (DO-TEST SHIFTF-NTH (AND (SETQ FOO '(0 1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (NTH 6 FOO) 'A) 6) (EQUAL FOO '(0 1 2 3 4 5 A 7 8 9 10)))) (DO-TEST SHIFTF-NTHCDR (AND (SETQ FOO '(0 1 2 3 4 5 6 7 8 9 10)) (EQUAL (SHIFTF (NTHCDR 6 FOO) '(A B C D E F G H I J)) '(6 7 8 9 10)) (EQUAL FOO '(0 1 2 3 4 5 A B C D E F G H I J)))) (DO-TEST SHIFTF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (EQ (SHIFTF (AREF FOO 6) 'A) 6) (EQUAL (AREF FOO 6) 'A))) (DO-TEST SHIFTF-SVREF (AND (SETQ FOO (VECTOR 0 1 2 3 4 5 6 7 8 9)) (EQ (SHIFTF (SVREF FOO 6) 'A) 6) (EQUAL (SVREF FOO 6) 'A))) (DO-TEST SHIFTF-GET (AND (SETF (GET 'FOO 'A) 'B) (EQ (SHIFTF (GET 'FOO 'A) 'C) 'B) (EQ (GET 'FOO 'A) 'C))) (DO-TEST SHIFTF-GETF (AND (SETQ FOO '(B C D E F)) (EQ (SHIFTF (GETF FOO 'D) 1) 'E) (EQUAL FOO '(B C D 1 F)))) (DO-TEST SHIFTF-GETHASH (AND (SETQ FOO (MAKE-HASH-TABLE)) (SETF (GETHASH 'A FOO) 'B) (EQ (SHIFTF (GETHASH 'A FOO) 'C) 'B) (EQ (GETHASH 'A FOO) 'C))) (DO-TEST SHIFTF-SYMBOL-FUNCTION (AND (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (A) NIL)) (EQUAL (SHIFTF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)) '(LAMBDA (A) NIL)) (EQUAL (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)))) (DO-TEST SHIFTF-SYMBOL-VALUE (AND (SETF (SYMBOL-VALUE 'FOO) 1) (EQ (SHIFTF (SYMBOL-VALUE 'FOO) 2) 1) (EQ (SYMBOL-VALUE 'FOO) 2))) (DO-TEST SHIFTF-SYMBOL-PLIST (AND (SETF (SYMBOL-PLIST 'FOO) '(A B C D)) (EQUAL (SHIFTF (SYMBOL-PLIST 'FOO) '(E F G H)) '(A B C D)) (EQUAL (SYMBOL-PLIST 'FOO) '(E F G H)))) (DO-TEST SHIFTF-MACRO-FUNCTION (AND (SETQ FOO (GENTEMP "FOO")) (SETF (MACRO-FUNCTION FOO) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (EQUAL (SHIFTF (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (EQUAL (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))))) (DO-TEST SHIFTF-CHAR (AND (SETQ FOO "A-STRING") (EQL (SHIFTF (CHAR FOO 0) #\B) #\A) (EQUAL FOO "B-STRING"))) (DO-TEST SHIFTF-SCHAR (AND (SETQ FOO "A-STRING") (EQL (SHIFTF (SCHAR FOO 0) #\B) #\A) (EQUAL FOO "B-STRING"))) (DO-TEST SHIFTF-BIT (AND (SETQ FOO #*01010101) (EQL (SHIFTF (BIT FOO 1) 0) 1) (EQL (BIT FOO 1) 0))) (DO-TEST SHIFTF-SBIT (AND (SETQ FOO #*01010101) (EQL (SHIFTF (SBIT FOO 1) 0) 1) (EQL (SBIT FOO 1) 0))) (DO-TEST SHIFTF-SUBSEQ (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQUAL (SHIFTF (SUBSEQ FOO 2 4) '(C D)) '(3 4)) (EQUAL FOO '(1 2 C D 5 6 7 8 9 10)))) (DO-TEST SHIFTF-LDB (AND (SETQ FOO 100000) (EQ (SHIFTF (LDB (BYTE 8 0) FOO) 128) 160) (EQ (LDB (BYTE 8 0) FOO) 128))) (DO-TEST PSETF-MASK-FIELD (AND (SETQ FOO 100000) (EQ (SHIFTF (MASK-FIELD (BYTE 8 0) FOO) 128) 160) (EQ (MASK-FIELD (BYTE 8 0) FOO) 128))) (DO-TEST SHIFTF-APPLY-OF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (EQ (SHIFTF (APPLY #'AREF FOO '(1)) FOO) 2) (EQ (AREF FOO 1) FOO))) (DO-TEST PSETF-EVAL-ONCE (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (SETQ A 4) (EQL (SHIFTF (AREF FOO (INCF A)) 'E) 5) (EQL (AREF FOO 5) 'E)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL b/internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..71469a66226265876f7a4c5a5fd6aac2fdebaef8 GIT binary patch literal 5401 zcmb_gdu&tJ89(QqYdcQt5cBLpa4rPW&2U*r0))pzZtR=H!SM}#kT_dK-C*Xx4axFA zViOfGN~Ot^rdfl}7<+ZC#2?*gs!2S$M%qJrh-#~*Rq8ZNQ?+iLR83UvAFEc)`@VDR zJO~=7!r|WUaen9fzVm(Ob(tiNzFB?3M9;ULT?X8Og(CJ zn}PgfK34`~(UWmAme2VbwejH*-OilI*f^Y_F+vH+KbtFSPey}@uocZu(bLqEznJre zqk0bv&FCTPB_5bXi9t1z=3w8hRyZhu>%vS93J z;dFNX?-n#HKkL$H_QvZ`;O|WCzYzU7A(Pqj(JqAoe)8Jt-YsYZTFZok*};LWB7?=q z=?A6AU5H!g_Xn?#=b>LwH47|g&e&>E2V}6^0i$Y|83ew!AzO{ZEi26Qfe6FxZNRP- z!ug#ULtqwa^n1Zp-$OY+V&opisFk0VMqMWT6$gpMvO$AlF;pbCOBGzA-!tER5gu!3 zE4FGo?Xqk&{IE4!4apGpN+Wt0V_^-YvA9d&K^=sfnH6_y9!~n$#ga?!-3}hch}7ni z`HEsKU_dzkU{ayKx#6|U>qNd`0m*T%EA~Sz&R5%6?p%=ihZ5wuQjng(hhfk0YRO(X z1Y8_xDZ5B>~?jVgy~W~~}Jumj%8A^)u9rvokUR_MU)*(imTdbzh5yA^ab3tyX#{FLJG@_x18PnUspow*}-I9MtJ zW-MmKbSs(YNhShp4Rr7XjA%+1`gnj-_6X?Q?Utn*v6zwKUiKMK&~{*|c_mxR%UKQg zuywowj49)`myZ5cqVqTd{5AwT48 z(MDbsj>t9Ph7M4@YL6kb+R^*K0w27d& zhi?R;{su4=2aQP5jO(Ro&<{GN)FEUC1XLleVPb0R5P_*0ufxViq#2JO?C*=A+hvV^ zFQDw#67!lQS0Nl`MnhnP{SbIZJYmFe7P2cCc26W3??LGq9zb#ql&Td93Ec?ag1U^H zEyiM}&C=;+>9kIITO)|_&SGejfGW2IRQZL(T$f~cF|<)aQxbYWVoXW=5Su3)O_;H` zDejyQoZ`eJLc-(_>Ax`kVuI=0D8RCe1Cag-fk7h_3dK--VX@zB!Y{ob{L-g{LwZt@ zBiw^MdeNE@Guu%(z$=lo@f}F^@(LskQVQ^Ll-5cK@5EJNJJJ(Y!iebcaKDM|czt$; ztYljRMe;F-RpBUXu7H7{6R^)<;N%Y9faG0CUS1q`gNU145^r&Ovi z6~&*OYt7w$1GyXLTH{Sk$o=SCt4HcyIJd9ZYD2dIcn zG!iCet#~+z9XJw(sbWOp+=noj><5xo!W5ZO8#yjr_K`5bg8<+m(Zb%5Ei<5Uw>#-70Kt;+UcPu4yUm; zOU^n*6m(w@=N&lD=TzK!@;MJ28G772kTjz~6O&dS6MA*OnTms~)&qn4NGRFeodSig z-iSo3UfoJ`!fgOiY6Ga95i{D6=-kZx8m}#bB2^l(j$}6;o?@$ngMAau_`5r=gTC&V z*=-#(^>Dk7_Y;Cyx0V*_3$jp9T(_by##Hzr)C;MVla4v3Nh9P2uRq1h?>*R7NSOgo z8$9r7alg!gEmq7L%jakxJSlkkU0eCK%`i?C&hUQjeYD8JC8Vy%_HnPDuV2B}m+|#% z4IlFGSf`Gwd3^=WShKGu;oxALJXH+oJFrmk-?MPXW%xGSZgv{oUjns&o@atQ?MCg?G--y# zN5$f!^NY`q{LM4zn=r`)f9p*8R%f_t|6DEq-x^dGuR$m8g;j{Fji;n<83@J~B+M_Q z3(KX_DG@TmrD@)>}-xYDvLjZIlqzf2a#dJF`E@bL} z!Amyz1WQxN%ehCKw&cBOvL|!&!xxX0_C`gNN0~1V%$ruZHNscl%`g|6V;8RRuKUfW zyY@#XR0hv&Q6k*qphPYFi;nFuzbfF^fe#xq3J>mlu0*QG)UEccml>test>7-3-apply.test ;; ;; ;; Syntax: APPLY function arg &rest more-args ;; ;; Function Description: APPLY applies function to a list of arguments. The last argumnet in the argument ;; list has to be a list. ;; ;; Argument(s): function - may be a compiled-code object, a lambda-expression, or a symbol ;; ;; Returns: value returned by applying the function to the arguments ;; (do-test test-apply0 ;; ;; test cases copied from page 107 of CLtL ;; (and (setq f '+) (= (apply f '(1 2)) 3) (setq f #'-) (= (apply f '(1 2)) -1) (= (apply #'max 3 5 '(2 7 3)) 7) (equal (apply 'cons '((+ 2 3) 4)) '((+ 2 3) . 4)) (= (apply #'+ '()) 0))) (do-test test-apply1 ;; ;; test cases copied from page 107 of CLtL ;; (and (equal (apply #'(lambda (&key a b) (list a b)) '(:b 3)) '(nil 3)) ; (defun foo (size &rest keys &key double &allow-other-keys) (let ((v (apply #'make-array size :allow-other-keys t keys))) (if double (concatenate (type-of v) v v) v))) (setq foo-array (foo 4 :initial-contents '(a b c d) :double t)) (= (apply 'array-total-size (list foo-array)) 8) (eq (apply #'aref foo-array '(1)) 'b) (eq (apply 'aref foo-array '(7)) 'd) (eq (apply (function aref) foo-array '(4)) 'a) (eq (apply #'aref foo-array '(6)) 'c))) (do-test test-apply2 (and (= (apply #'cadddr '((0 1 2 3))) 3) (equal (apply 'cons '(foo) '(bar)) '((foo) . bar)) (equal (apply (function list) '(foo) '(bar)) '((foo) bar)) (equal (apply #'append '(foo) '((bar))) '(foo bar)) (equal (apply 'intersection (list 2 4 6 8) (list '(1 3 5 7 8))) '(8)))) (do-test test-apply3 (and (equal (apply #'(lambda (&rest rest &key a b c) (list rest a b c)) '(:b 3 :a 9)) '((:b 3 :a 9) 9 3 nil)) (equal (apply #'(lambda (x) (multiple-value-list (values x (expt x 2) (expt x 3)))) '(2)) '(2 4 8)))) (do-test test-apply4 (equal (apply #'(lambda (x y z) (defun funx (x) (list x x)) (defun funy (y) (list y y y)) (defun funz (z) (list z z z z)) (append (funx x) (funy y) (funz z))) '(2 3 4)) '(2 2 3 3 3 4 4 4 4))) (do-test test-apply5 (progn (defun bar (test bar-sequence &rest keys &key dummy &allow-other-keys) (let ((x (apply #'remove-if test bar-sequence :allow-other-keys t keys))) (list (length x) x))) (and (equal (bar #'oddp '(-2 5 -7 9 10 13 16)) '( 3 (-2 10 16))) (equal (bar #'oddp '(-2 5 -7 9 10 13 16) :start 2) '( 4 (-2 5 10 16))) (equal (bar 'plusp '(-2 5 -7 9 10 13 16) :start 4 :end 6) '( 5 (-2 5 -7 9 16)))))) (do-test test-apply6 ;; ;; --It is illegal for the symbol to be the name of a macro or special form -- ;; (page 107 CLtL) ;; ;; (progn (defmacro mac1 () ''mac1) ;; (defmacro mac2 () '(list 1 2)) ;; (not (or (nlsetq (apply #'mac1 '())) ;; (nlsetq (apply #'mac2 '())) ;; (nlsetq (apply #'quote '(quote))) ;; (nlsetq (apply #'progn '())) ;; ;; setq is defined as a special-form in common lisp ;; ;; (nlsetq (apply 'setq '(foo (1+ 10)))) ;; (nlsetq (apply 'no-such-fun1 '())))))) t) (do-test "test-apply7 make sure APPLY returns multiple values" (and (multiple-value-setq (a b c d) (apply #'values 1.1 2.2 3.3 '(4.4))) (= a 1.1) (= b 2.2) (= c 3.3) (= d 4.4) (multiple-value-bind (a b c d e) (apply #'values-list '((1 2 3 4))) (and (= a 1) (= b 2) (= c 3) (= d 4) (eq e nil))))) ;; ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL b/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..837eb021259d47cefdde3ecff13b73ad1f850884 GIT binary patch literal 1100 zcma)6&rj4q6rS$Nvivd&0s=8QA>q7$Y$p zjE5Rs2&ChWizkm>QKJX{A^!t>vq&&v)I&3G-n{wV`@T1?E!1&W)v@YV>#oNd*l&jQ zW{B7Q1`hmYqr~t!`0*pPXljp_6m@0t##FcU%SoxhoRF0Qygi!o4N-x-kO7le{-j$w6z442v zFK>`lpr$NpD3Sh&BG9Ec8kr+mqAI#h6m!uoXa=>2o-gDndb{7b4Hdl?WqquCT9yuK z==SI3#GTAoztrJ=+CXSvyYsA6Irw6L{k^sF-1vr2tMb%XPDp)VeK>z-K-?Bz8lhf< zzPhEsHqT?gcgKL8{{gsD`7rz^#8xHaW>BIt-it2CYSEa_3;JY9G3Is6B)9V5F%~U3 z(ZRbCXF%J2SyiaIL`;p^CTOF!#Z6iFEUFa}(&-3VlzC4w&AXCapyydxGtHt&iZ)%f zshsSC3%#;p+#_wjC36t=bbr!Gg!mcJm6Q=I4=nO?b9^wh1$Z6p0yg0lqzr+q-{-@G4^8mlQ9j(xx)(=o$bt}; z9M2<8W20GRwJ;!_TXjQ>b2zLpyy@f#yC%_wGCWH}IV1+o( zsjihBQg<3om4&SF6Hn9*ul5oZ3CFjTalG!pw3V@2I~o+>+nO-r*YR!wI9^muO`#h3 zjjEofnyKg(?-60Z^0r;18Xr>Q$o?xADBlgRgX@0ahVCYVydm3wzkpLK;|DIxaLsR% g3#y<7_<>Ii&tAF7N2GR5d=xVBF+PM|jUOKV0E)6uyZ`_I literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST b/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST new file mode 100644 index 00000000..bb4a6369 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST @@ -0,0 +1 @@ +;; Constant To Be Tested: call-arguments-limit ;; ;; Source: Steele's book Section 7.3: Function Invocation Page: 108 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 6,1986 ;; ;; Last Update: June 6,1986 ;; ;; Filed As: {eris}cml>test>7-3-call-arguments-limit.test ;; ;; ;; Syntax: CALL-ARGUMENTS-LIMIT (* note: this is a constant) ;; ;; Function Description: CALL-ARGUMENTS-LIMIT is a positive integer that is the upper exclusive bound on the ;; number of arguments that may be passed to a function. ;; ;; Argument(s): none ;; ;; Returns: a positive integer ;; (do-test "test call-arguments-limit : it is a positive integer and wiil not be smaller than 50" (and (integerp call-arguments-limit) (>= call-arguments-limit 50))) (do-test "test call-arguments-limit : the value of it must be at least as great as that of lambda-parameters-limit" (>= call-arguments-limit lambda-parameters-limit)) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.DFASL b/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0749e3f22bd574eebfcf2fef3fc5f257d353389e GIT binary patch literal 2962 zcmb_e-A^1<6u)<7m*ty<0w&wFZd>}1g`q9bQt?5CVU{jkW^rbgElFd8yNinqh45k2 zrWI?|L|0l0;#{@rizddHH27fJYBxrGFg9wmsZaVJnDAiq#biC_&TgeklQv4i-E;1_ z=lss^ocl2>68AAB5>O^5rpBz)bYOCBc4}@mFgiIMn3gwp|YCqUo9+HiSgLcoD z&aSrhu8y|W^4z5r>YXHnBuExT86jRG68mDt8#GnJltST%Drxe78nhSfOexeN#SB%q zGqr7j*~ux%Nmd z5Pk)kXvu1HJh$2&-yPo@55`+87t~d4RpnN<709DZ`+PpYgFjx!e0pFD92(h|QL?v%k8h`UF*QwY-A5^&7STGhO@Y^INj~AGfkKOxNT})qYxXV#q zOnb+?L@2l4$oPXwRO=1n<&%!cT5m+vrJgWYv_2y!RI)Om0!Aqe4-7X97u@vPpdy>f z5lL6gm<~5p;a9!H7&c6GK%g5v%xI8Rh}E#*ftwo%8|Lk|0dKWf!^%W2-23XFs_Ri* zipI>rm>CpnA)+!UYr_(^8$m|JIsWDqvZ-#e67! zW?NBw&HO0d2Y9zSr0T;sdkuPCzKc&K1DYIB(fT5mZm6cz8xDn3$gFVlGhnU^Yo@9j zDt{l*H{v7-J4w2nBsD-xgwC=WbRldz2>QDtes#o8khvamgd}5lpeGvPPbls?x_$(i zL|8=q6`p{e;|b^-PeA)2+H-th2)7QM`XHcUNRGr*L(1F8U#tn1$RDs&;w<6x2M$MW za5(Y>ha=1ABM%O$S}*#XWqXb@-!R+S&-^}Eswtv~jTE;-jpfc4#(De?@oL2?2ypY` zfnEZ9Pf9f0%?M0|KUp)1AB$rTI-R=8g1Efuczx)IP_c7|@1pDY`0~s#J8a zBVjmra>QU2=mtH0EEY9Yrw2D!8$!HeFNvaupM4ut!Bv9RWl*W;M)ksq=;`T}Z?1V^ z!Ws!>4RH7B?aWqdWa5eB2-4bcKcOKazn_4^>RAKC;TZvh=YfgfLhaOTZ5A{tqHXH7 z?Wq;w?oLC}dnTg!MDTwFJyu9#^3Je!z+)Xw!9BcS`uDkRhYJ0Eh3xE6EI}S$Tk58l z8)ZuXMWCm?uNOTp^xr8NMp_0Vd?Z1OPY& zW0;Dtablm+n`iwQHb%bnU!V$nKH(5I{}06Z4gIC3o&FBMmM=^#SPK)dq4ZHlJhEWn ztaD)s1o>q{F!_cDlQ-=pSBcAwXOLU~puGB$z2ss0sDSe`j`=z8 H)4AL~p_n(T literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST b/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST new file mode 100644 index 00000000..8cf341d0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: funcall ;; ;; Source: Steele's book Section 7.3: Function Invocation Page: 108 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 6,1986 ;; ;; Last Update: June 6,1986 ;; ;; Filed As: {eris}cml>test>7-3-funcall.test ;; ;; ;; Syntax: FUNCALL fn &rest arguments ;; ;; Function Description: FUNCALL applies the fn to the arguments and returns its value. Fn may not be ;; a special form or macro. ;; ;; Argument(s): fn - ;; {argument}* ;; ;; Returns: a value returned by fn ;; (do-test test-funcall0 (setq fc (symbol-function `+)) (= (funcall fc 1 2) 3)) (do-test test-funcall2 (and (equal (funcall 'append '(+ 1 2 3) '(4 5 6)) '(+ 1 2 3 4 5 6)) (equal (funcall #'append `(,(+ 1 2 3)) '(4 5 6)) '(6 4 5 6)))) (do-test test-funcall3 (and (= (multiple-value-setq ( a b c d) (funcall 'values 1 2 3 4)) 1) (= (funcall `+ a b c d) 10) (equal (multiple-value-list (funcall (function values-list) (list #\p #\l #\m))) '(#\p #\l #\m)))) (do-test test-funcall4 (progn (set 'funlist '()) (push (function (lambda (x y) (+ x y))) funlist) (push (function (lambda (x y) (* x y))) funlist) (push (function (lambda (x y) (gcd x y))) funlist) (defun fun (m n o p) (funcall (case n ((1) (car m)) ((2) (cadr m)) ((3) (caddr m))) o p)) (and (= (fun funlist 1 3 9) 3) (= (fun funlist 2 100 100) 10000) (= (fun funlist 3 100 (sqrt 4)) 102) (= (fun funlist 2 (expt #3r10 2) (/ 8 2)) 36)))) (do-test test-funcall5 (and (funcall '> 10000.001 +10000.00009 9999.999 9998.999 -9998.9999) (funcall #'(lambda (x1 x2 x3 x4 x5 x6) (and x1 x2 x3 x4 x5 x6)) 'e 8 30 t 'null 'nill) (every #'(lambda (x) (funcall 'null x)) (list nil '() (intersection '(2 4) '(1 3)) (set-difference '(2 4) '(2 4)))) (funcall #'(lambda (x y z) (every #'(lambda (a b c) (eq c (+ a b))) x y z)) '(1 3 5) '(2 4 6) '(3 7 11)))) (do-test test-funcall6 ;; ;; --It is illegal for the fn to be the name of a macro or special form -- ;; (page 108 CLtL) ;; ;; (progn (defmacro mac1 () ''mac1) ;; (defmacro mac2 () '(list 1 2)) ;; (not (or (nlsetq (funcall #'mac1 nil)) ;; (nlsetq (funcall #'mac2 nil)) ;; (nlsetq (funcall #'quote 'quote)) ;; (nlsetq (funcall #'progn nil)) ;; ;; setq is defined as a special-form in common lisp ;; ;; (nlsetq (funcall 'setq '(foo (1+ 10)))) ;; (nlsetq (funcall 'no-such-fun1 nil)))))) t) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-4-PROG1.DFASL b/internal/test/LANGUAGE/AUTO/7-4-PROG1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..56335ae1b46d4b76137c7d02456d545c58474551 GIT binary patch literal 1460 zcmah}%}*Og6rWjRurb67rR2+M7DrLjRhD8x8$#2=vaG>i@0#6N5!6dvV`5hZBY#9{ zt3(M>D^=R2b*$2zR5|t7OBAVxd=yl*QZJSAC*)MAM-IJ{_jVznO{8cKv-5tx_nY@M z(!8&5c%5TCLTkMy*vZmZVj%OJ8WFrC*y9W`M+z8~NIJRzi?!dUztZgXO($!KG z(^+c}N{IKJ8%aBc#xkbib?6P+=Y8w;XAC6|sj0I%5hD94s7^gMdO?{`@|HQ9B6qi< zn}pC5#__QHXr4Y;Cr=;G3rmA1258t1QWUnA{BV!&7-;zGemSs%`3fQB6aA2hc!146 z$9^Yd2XM$Pz;^GSgDt|~fXH^_5CdrYP`h%Y9DI*}G`QI#((;3C1O9j03*Q(Z+b(}) z%nKA`+V_T+hR_dCQ0oK1N^#h)>V7u#(m^&oz=2bW$ABVMc3&@kyL|7>SE#qkVnrlE zkN3TskTuho$zb7?In|iS>XtH{0gEwf%R-n(g)ZpofUK!Zn^P>EITmz9^V`~OFWXGd z3G`(KGi4qNMF61c^9jJ-g`zwf>WA(gk#);5EyZ+L-eGbm2HZYbHI^0MZp)m8`p|!x z$6qxzkuV{=3y0+hw*L%BcBf4%r!w3oF(l2gEZsOXjGQ7i2-whztTolvgEM&yVDb+t z+023p;Py{GjLRSVC@#P7W4L?`oHy)DE)P>4P!)aAQL~6`^5fS4j-_+zf@4gZjxlo; zP7J|(^Y}WHe8|>WTCtaN(`HsVnEH>vrT>M;hp-Jh26QD3n)DP1#Qclp&wPse)(DdP zY9R+NQMZ8=@Wc3*Co!78!IS2FKKbpxDr155XFh_&p9205Jo!0K)Oq3xPh93AgLtFb zoNB2W)2&GqTjKFvJny9Eo?@j&Q%YV}lhSGd-lG+%vK~AoXuEy}b)R@YdL02A-_k5y zWxDde%4ahmtY&QJL{W8qd~#_M!r_$H6@)A+Lpa|MePEH;ndd>1HujGyKyKF-hIJnMBr e!Da+Pi$srlovs6z`dM+H2>cyBLhfAJ+j|DHmaX3a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST b/internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST new file mode 100644 index 00000000..455fb2b3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog1 ;; ;; Source: Steele's book Section 7.4: simple sequencing Page: 109 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 29, 1986 ;; ;; Last Update: May 29, 1986 ;; ;; Filed As: {eris}cml>test>7-4-prog1.test ;; ;; ;; Syntax: PROG1 first {form}* ;; ;; Function Description: PROG1 takes a number of forms and evaluates them sequentially. It discards the results ;; of all forms but the first one and returns the value of the first form. ;; ;; Argument(s): {form}* - a sequence of forms ;; ;; Returns: value of the first form ;; (do-test test-prog10 (and (equal (prog1 (cdr (setq a '(o p q r))) (rplacd a '(8 9))) '(p q r)) (equal (prog1 (setq a '( o p q r s t)) (setq a (union a (cons 'w ())))) '(o p q r s t)) (eq (prog1 (setq a #\s) (characterp a) (makunbound 'a)) #\s) (string-equal (string (prog1 (defun fun () 'fun) (equal (fun) 'fun) (fmakunbound 'fun))) "fun") (eq (prog1 () (cons 1 2)) nil))) (do-test test-prog11 ;; ;; - prog1 always returns a single value, even if the first form tries to return multiple values. - p109 ;; (and (eq (prog1 (values 1 2 3)) 1) (eq (prog1 (values-list (list (setq a (evenp (+ 2 #2r1010))) (setq b (string 'p)))) (equal a b)) t))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-4-PROG2.DFASL b/internal/test/LANGUAGE/AUTO/7-4-PROG2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..36ed2de877db252e4ff017c310f2226162d3b815 GIT binary patch literal 2007 zcmb7EO>7%g5Pom%#C9CVPLrmM6Q!%9fnaqb5)3Uts{NL&aryG|PjqD5Nm%$xb% zy!rXwtFfkeB`YeG)%BHfaYL+ZZ>?`{iOZD@akH|$u~-zB(JsEO=!W`cT2`ipUl?gI zPk0tLiiNG>l4xxgHpT@pv07v=Shl`<+yv3Pv!nP-PvlCqg~qdjuZ<+0H? ze#0$Cx9dDoVT>)ZLlObTBFw|=-D)Iesiq|*Gg(#AF$AJtWCYE zea%>{^o}+ua6Gzpr)#d0A|cYxSSy~fve@PHu#r129p~;t%<0_GNcp*fYI>Mr?}-f< z{1~HM$K)QJ+HUF2*?-BcR*I}dnBcQNtoFtfU7N_zkfgM%O=ML=N@UQYrOcSn1OdT| z3}}xjvZbUYL$&e-PEc_u&}=T4mYNgzX@sT6An5U%;3(eURfPg22OlXU#hM^mh zp0}p+R?HJbY->!`79_`R#sDdCnpu7?W8ft|brC~mFj8|;H*&H?ON}y7@`j;mC-@4S zd{@!e`LI|;HdXg12$H)CBL$N=c`C0Z^t?7fwlHq-AcrALt01_qdR97S zH#*rL1kK5c17*KK4;g=P#ZS1g!`X-cL;u^p?;%Ra&*3bIeW0q?Cva{Sx@Vw!3c6K@ z#-V2zdWN9452A$TQ+Qa=xs%Ry8FBNAV+Bo4^9XYZ?_aYWPdaR>VmO`+ne>xH!?=|P!4xb=Mt0|faDAt$nW+T9P(N6wma zK6@K3yn!%pGGnG8d;?WaTFyau4F<2#BB^5vFA^e!uLOjzLiZpH^h3`%7zj}2DZ6^X zDsFCx{Ws-)ak+pm=90Lw=00|0yE#ZOU!ApHUp=C$7NmE~uJ)7*t1mAV2z&auLYPY` z?k7Uc%GtbXVw>I?XY2_^`F~gE=f?%!&gqupm!{CsXek=Si^L%E-v{7xC^!e$dxBkU zy?C)f1RRfD?Kobl+HA(qwH%U{33Nxi*^FuVh?s6h60La~1;G!eJ(Jfh6}!c!A&e%7 zlRg7sC*`l~j|sM0?Nba@wp8gKSU?x{enT23fSu+Hev$6?Yboarpln0_T)oN}1q3Y*A+)<4#LqtkE#`(ZbQu EUt&-{CjbBd literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST b/internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST new file mode 100644 index 00000000..fc6e1f1c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog2 ;; ;; Source: Steele's book Section 7.4: simple sequencing Page: 109 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 29, 1986 ;; ;; Last Update: May 29, 1986 ;; ;; Filed As: {eris}cml>test>7-4-prog2.test ;; ;; ;; Syntax: PROG2 first second {form}* ;; ;; Function Description: PROG2 takes a number of forms and evaluates them sequentially. It discards the results ;; of all forms but the second one and returns the value of the second form. ;; ;; Argument(s): first - first form ;; second - second form ;; {form}* - the rest of forms ;; ;; Returns: value of the second form ;; (do-test test-prog20 (and (eq (prog2 1 2 3 4 5 6) 2) (eq (prog2 (defmacro mac (x) `(gcd ,x 20 30)) (mac 10) (mac 40)) 10) (eq (prog2 (defun fun (x) (nth x '(foo bar gack tank bush moon fish))) (fun 2) (fun 5) (fun 0)) 'gack) (eq (prog2 (rplaca (setq x '((a . b) c d (e. f))) 'foo) (car (rplaca x 'fish)) (car (rplaca x 'ham)) (list x)) `fish))) (do-test test-prog21 ;; ;; - prog2 always returns a single value, even if the second form tries to return multiple values. - p110 ;; (and (eq (prog2 nil (values 2 4 6 8)) 2) (eq (prog2 (defmacro mac (x) `(values-list (list ,x 'p 'q))) (mac 'a) (mac 'w) (mac 'o)) 'a) (eq (prog2 (defun fun () (values (signum 10) (signum -9) (max 2 2.0 1.9999999 2.000009))) (fun) (fmakunbound 'fun)) 1))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-4-PROGN.DFASL b/internal/test/LANGUAGE/AUTO/7-4-PROGN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3b290f273de70a5267aed67a3945f775b49dc5c5 GIT binary patch literal 1465 zcmb_c&u`mw6#sthrD^J>aYm?0))ueLD$Sa!wJWqMAaFgWP3zd5?aVDgnkqLXk-Vm) z>7)smrX3K6Ajm2ve}SF&2d3S|&@8mmq#fCjGe?k+kT{k1oONsi2@Xh!-{<>&e%|x@ zx`a3 zCKVfm5T8USQiO z=h7~rgoIzTdy5rQb4!*P?$c|uKm5F%E}6p1uncPJ&vP9|+!IPu@MC1*6L*7I!pU)$MN7riq3*T=K z`KE$&kPAk;9O4RhjzgP31)oE4c_DIFLU(o9LU0i;u)cj z2luqc#O4e<4o)n)&YiZvycml>test>7-4-progn.test ;; ;; ;; Syntax: PROGN {form}* ;; ;; Function Description: PROGN takes a number of forms and evaluates them sequentially. It discards the results ;; of all forms but the last one and returns the value(s) of the last form. ;; ;; Argument(s): {form}* - a sequence of forms ;; ;; Returns: nil - if there are no forms ;; value(s) of the last form - otherwise ;; ;; (do-test test-progn0 ;; ;; if there are no forms in progn, be sure it returns nil ;; (eq nil (progn))) (do-test test-progn1 (and (eq (progn 1 2 3 4 ) 4) (eq (progn 'a 'b 'c 'd 'e 'f 'g 'x 'z 'y) 'y) (equal (progn "simple-string") "simple-string") (equal (progn (setq x (+ 3 3 4)) (setq y (- 10 2 3)) (setq z (1+ (* 5 2 1))) (max x y z)) 11) (equal (progn (setq m 10) (multiple-value-setq (a b c) (values (incf m 100) (decf m 50) (gcd 7 21 28))) (list a b c)) '(110 60 7)))) (do-test test-progn2 ;; ;; check if progn returns multiple values ;; (and (equal (multiple-value-list (progn (values 10 20 30))) '(10 20 30)) (equal (multiple-value-list (progn (setq a :bar) (setq b :foo) (values-list (list a b)))) '(:bar :foo)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST b/internal/test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST new file mode 100644 index 00000000..0cba7a15 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compiler-let ;; ;; Source: CLtL p. 112 ;; Chapter 7: Control Structure Section 5: Establishing new variable bindings ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov 2, 86 ;; ;; Last Update: Nov 2, 86 ;; ;; Filed As: {eris}cml>test> 7-5-compiler-let.test ;; ;; ;; Syntax: compiler-let ( {VAR | (VAR VALUE )}*) {FORM}* ;; ;; Function Description: When executed by the Lisp interpreter, compiler-let behaves exactly like let with all the variable ;; bindings implicitly declared special. When the compiler processes this form, however, no code is compiled ;; for the bindings; instead, the processing of the body by the compiler is done with the special variables ;; bound to the indicated values in the execution context of the compiler. ;; ;; Argument(s): var - a variable ;; value - a lisp form ;; form - a lisp form ;; ;; Returns: anything ;; (do-test "test compiler-let - when executed by the interpreter 0" (eval-when (eval) (equal (compiler-let ((a 1) (b 2) (c 3 ) (d 4)) (list a b c d) ) '(1 2 3 4) ))) (do-test "test compiler-let - when executed by the interpreter 1" (eval-when (eval) (compiler-let ((a 1) (b 2) (c 3 ) (d 4) buf) (let ((a 11) (b 22) (c 33 ) (d 44)) (set 'b -2) (set 'd -4) (push (list (locally (declare (special a)) a) (locally (declare (special b)) b) (locally (declare (special c)) c) (locally (declare (special d)) d) ) buf) (push (list a b c d) buf)) (push (list a b c d) buf) (equal buf '( (1 -2 3 -4) (11 22 33 44) (1 -2 3 -4) ) ) ) ) ) (do-test-group ( "test compiler-let - when executed by the interpreter 2" :before (progn (test-defun foo (x y) (progv '(a b) (list x y) (compiler-let ((a (* 2 b)) (b (+ a 4)) (c (- a b)) ) (foo1 a c) ) )) (test-defun foo1 (a1 c1) (declare (special b)) (if (evenp b) (+ a1 c1) (- a1 c1))) )) (do-test "test compiler-let - when executed by the interpreter 2" (eval-when (eval) (and (= (foo 20 1) 21) (= (foo -7 8) 31) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-FLET.DFASL b/internal/test/LANGUAGE/AUTO/7-5-FLET.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bde2c13011762c846eba5405884354287e4ce8bd GIT binary patch literal 5352 zcmeGgTWl29_0D4-e#SNiSB99u39k+7V4Fumg7A15;rI`*LZi#Zam&~yz5XJ zg&HsViK+r=8VIeev{kF7v{IxBi7I`hX_YE!D;iR@Y17hk?%jnA zjzFpMS!-v`^PY3=Ip@y3*N2E}TOgf zLk$PHwd;;qyRK#Rx|J)NN-sS#B~+yeAu%$8poEYrA`$0suF4nD!V!N*S5WioYOm&V z4mmk5%*7uKYau6B-J)dEBYxX@$g*)d!xy_0@t4xzpQO zfbiClEF+|XkRiPiiAyIpTvNL6TGH{vc;XBw)a>!p3W?LxI^Y)$^&HTDK**uQe!W{1 zz|*1Qbz2qmg^!nzazbX3u|}4+e856uAz)APQ!yxRDH!zH6?U!NU@rr=P^Cf~#jw=H zL=Y-+K?#0&;_TN>kmu|>U|xj*kUiT2^iazCAt)v4@z1^k#k2XKaB=`e)A+itX2zCm z83OXKVMDeEw4_(&LzHb9@Dke#=It_DHfkzukL^aPf>RQV5P{9T)}zt0R}}%A7&R~i z>TuAgVTE|qsJV6}s;er{RK6JU)g%* z!EpkH0*f!q#S;RnT%iGeTWElC zSg!oXTNH5CdY9P+1}*}O{%n5rUO$lQeiK}m+pv_o`vm}e;CC+1!C*cOx6pmikFWNS#fU<9ZtoBMG0%};}u4p-mAB99!F4m0*h7g9-1T|!jgM%Bw{k`o* z&|lb8k^dm@%Q|}1o~Yh#MD>lx3jj~nwx~fQR?|5MT4*hTMmiUO{8xxU1~aQJZ{)ZI zqvS7nNei8iD+OQVs@Xt<&^aia1PtqyKfs0iTsc!;R8Sc{p zT`Hsx%H;1u_E(VIs|G?waZaTvV0$`PI+@x*s-X6EZds>`kP6U71gq#x2v*RW5iDk! z;=h@u_r7MpKGPJ>aLq}s`FXCH=9>3&&23zB70ajC% z=BOIP2!$MyTeLvL2qBrJOAsW0TLzs5>qFDwL7oA*^W3c?w*~1SqkFdmyIB2&E*t}` z6V<~00BR=hRQp!{(^L@+!T?n`0W7GPWivzRVS0;NWQvCOLSFb-VOAZZgg(ldi;ZTe+ac*S?m)RWL!$FjTdAx^9SssP|aPUj0kK!jV`=$dtOZ6jT? zfUaE+7F^$PavQQ%1}<2(l~w%8usLKYnXyqz$tKbnOG%l-aF-e!OU1IubSk5mAc^GgF1olu?TZtC-4m zJ3U~+%_~0@#Z1Lvjxa-O2cJmB zqU21<6}1gAU@{8ZW`_g0nlqfn%0i(s>_&}6M{S>zYg*T?!AD=?S5qcsv9p2}D!D71 zuPuH>q`yrOxVcmjCpX_VhX>*&R(#eW0NONv2tW+S{ekBQH#_NvMfeFPx3tf;OlZ4! zI<+)=rFy$mG;OlTS%5h733M-ga`z8&m$)lScNO8A=w@UsLbKv0H(Sk3;Vv&;D8hfm z%!;o}5ozcXTNR(@mhjLZ?k~bK-0Fr|WfuKTZhdjr?MP-5&~h;wmu@Bt{~H;$Qc(X} zl@W6k8Y&B|ZYN>s4p}>Qq(|e}TjFxoTf+O!q#GJbk}EubL2ote9tQ*)ZTD_KO1v0S zYni(YDG%t1w56iLgG!P(?)Hp>G2z%0S#J$p{JJeB@Wz+0Zjw&H!MQ0|! z!fSir{JqzFHF>5@?d`3WMdYqil3y%(8HrEo^79&95 zXHH(yqxI7k+A4VAb5f~>Hbr~!jLA+qv|MbUt<|)J^`dZeif9nqmn>VpcmyulGDc|G z;`#Uk7hbBhCG%AB^w9YSF1%>V7}(>scq(z)Zh$}`#_q1GV{Ex9MpsdcB}flB36(U%*M#r|CnuRP3)2+`5ku~Ga-tbSR>+wwg`_V7i3!gDJTZ8fCQQ+@H3Sz1 zeG{FJN6&zlqM82>!na?PyR;3J95C?|tmOpS>SN`C2f_T(_ciOJzllWUySd)Dwsb|>Fo2Ga4Qg$+h7um&S1XWMwz$+Z;QV0a8a3bFJ^ z5;vpK^f2`9c1vk)ZdKBQN+6iU!woq`Z%cml>test>7-5-flet.test ;; ;; ;; Syntax: flet ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}* ;; ;; Function Description: flet may be used to define locally named functions. Within the body of the flet form, function names ;; matching those defined by the flet refer to the locally defined functions rather than to the global ;; function definitions of the same name. Any number of functions may be simultaneously defined. ;; Each definition is similar in format to a defun form. Using flet one can locally redefine a global function ;; name, and the new definition can refer to the global definition. ;; ;; Argument(s): NAME - a function name ;; LAMBDA-LIST - ;; DECLARATION - ;; DOC-STRING - a string ;; FORM - ;; ;; Returns: anything ;; (do-test "test flet - test case copied from page 113 of CLtL" (flet ((safesqrt (x) (sqrt (abs x)) )) ;; ;; The safesqrt function is used in two places ;; (let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) ) (and (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist1))) (sqrt 30)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist2))) (sqrt 118)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist3))) (sqrt 16.5)) ) ) ) ) (do-test "test flet - with empty flet bodies" (and (eq (flet ()) nil) (eq (flet ( (fun1 () "this is an empty function") ) ) nil) (eq (flet ( (fun1 (m n) (declare (integer m)) "m is declared to be an integer" (declare (special n)) "n is a special variable" ) ) ) nil) ) ) (do-test "test flet - with declare statements / parameter list keywords" (and (eq (flet () t) t) (equal (flet ( (let1 () (values 10 20 30 40)) (let2 () (values "a" "b" "c" "d" "e")) (let3 () (values-list '(writing code for flet))) ) (multiple-value-call #'list (let1) (let2) (let3)) ) '(10 20 30 40 "a" "b" "c" "d" "e" writing code for flet) ) (equalp (flet ( (fun1 (m n) (declare (integer m n)) (+ m n)) (fun2 (m n ) (declare (string m n)) (concatenate 'string m n)) (fun3 (m n o p) (declare (type (integer 2 10) m n o p)) (max m n o p)) (fun4 (s) (declare (complex s)) (type-of s)) (fun5 (s r) (declare (number s r)) (vector (gcd s r) (lcm s r))) ) (list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) ) (list 59 "ace" 7 'complex (vector 1 2300)) ) (equal (flet ( (fun1 (m n &key o p) (list m n o p)) (fun2 (m n &optional (o 2 oflag) (p 30 pflag)) (list m n o p oflag pflag)) (fun3 (m n &rest x &key (y 6) (z 7 zflag)) (list m n x y z zflag)) ) (list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) ) '( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) ) ) ) (do-test-group ( "more tests for flet" :before (progn (test-defun fun1 () 1) (test-defun fun2 () 2) (test-defun fun3 () 3) (test-defun fun4 () 4) )) (do-test "test flet - locally defined functions overshadow the global functions of the same names" (equal (list (fun1) (fun2) (fun3) (flet ((fun1 () 10) (fun2 () 20) (fun3 () 30)) (list (fun1) (fun2) (fun3) (fun4)) ) (fun1) (fun2) (fun3) (fun4) ) '(1 2 3 ( 10 20 30 4) 1 2 3 4)) ) (do-test "test flet - one can locally redefine a global function and the new definition can refer to the global definition" (equal (flet ((fun1 () (+ (fun1) (fun2) (fun3))) (fun2 () (* (fun1) (fun3))) (fun3 () (+ (fun2) (fun4))) ) (list (fun1) (fun2) (fun3)) ) '(6 3 6)) ) ) (do-test "test flet - make sure those named functions are defined locally" (progn (dolist (x '(fun1 fun2 fun3)) (fmakunbound x)) (flet ((fun1 () 1) (fun2 () 2) (fun3 () 3)) (list (fun1) (fun2) (fun3)) ) (notany #'fboundp '(fun1 fun2 fun3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST b/internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST new file mode 100644 index 00000000..0d97e0f9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: labels ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 113 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 26 ,1986 ;; ;; Last Update: Feb 4, 1987 Jim Blum - removed empty body test, and changed (declare (integer 0 *) n) ;; to (declare (type (integer 0 *) n)) ;; ;; Filed As: {eris}cml>test>7-5-labels.test ;; ;; ;; Syntax: labels ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}* ;; ;; Function Description: labels may be used to define locally named functions. Within the body of the labels form, function names ;; matching those defined by the labels refer to the locally defined functions rather than to the global ;; function definitions of the same name. Any number of functions may be simultaneously defined. ;; Each definition is similar in format to a defun form. The scope of the defined function names encompasses ;; both the body and the function definitions. That is, labels can be used to define mutually recursive ;; functions. ;; ;; Argument(s): NAME - a function name ;; LAMBDA-LIST - ;; DECLARATION - ;; DOC-STRING - a string ;; FORM - ;; ;; Returns: anything ;; (do-test "test labels - test case copied from page 113 of CLtL (flet was replaced by labels)" (labels ((safesqrt (x) (sqrt (abs x)) )) ;; ;; The safesqrt function is used in two places ;; (let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) ) (and (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist1))) (sqrt 30)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist2))) (sqrt 118)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist3))) (sqrt 16.5)) ) ) ) ) (do-test-group ( "test labels - test case copied from page 113 of CLtL" :before (test-defun integer-power (n k) ; a highly "bummed" integer (declare (integer n)) ; exponentiation routine. (declare (type (integer 0 *) k )) (labels ((expt0 (x k a) (declare (integer x a) (type (integer 0 *) k )) (cond ((zerop k) a) ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a))))) (expt1 (x k a) (declare (integer x a) (type (integer 1 *) k )) (cond ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a)))))) (expt0 n k 1) ) ) ) (do-test "test labels - test case copied from page 113 of CLtL" (equal (mapcar #'integer-power '(100 9 8 7 6 5 4 3 2 -4 -6 -7 -9) '( 0 2 2 3 1 4 5 2 1 3 3 2 1)) '(1 81 64 343 6 625 1024 9 2 -64 -216 49 -9) ) ) ) (do-test "test labels - with declare statements / parameter list keywords" (and (eq (labels () t) t) (equal (labels ( (let1 () (values 10 20 30 40)) (let2 () (values "a" "b" "c" "d" "e")) (let3 () (values-list '(writing code for labels))) ) (multiple-value-call #'list (let1) (let2) (let3)) ) '(10 20 30 40 "a" "b" "c" "d" "e" writing code for labels) ) (equalp (labels ( (fun1 (m n) (declare (integer m n)) (+ m n)) (fun2 (m n ) (declare (string m n)) (concatenate 'string m n)) (fun3 (m n o p) (declare (type (integer 2 10) m n o p)) (max m n o p)) (fun4 (s) (declare (complex s)) (type-of s)) (fun5 (s r) (declare (number s r)) (vector (gcd s r) (lcm s r))) ) (list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) ) (list 59 "ace" 7 'complex (vector 1 2300)) ) (equal (labels ( (fun1 (m n &key o p) (list m n o p)) (fun2 (m n &optional (o 2 oflag) (p 30 pflag)) (list m n o p oflag pflag)) (fun3 (m n &rest x &key (y 6) (z 7 zflag)) (list m n x y z zflag)) ) (list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) ) '( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) ) ) ) (do-test-group ( "more tests for labels" :before (progn (test-defun fun1 () 1) (test-defun fun2 () 2) (test-defun fun3 () 3) (test-defun fun4 () 4) (test-setq buf '(results ) )) ) (do-test "test labels - locally defined functions overshadow the global functions of the same names" (equal (list (fun1) (fun2) (fun3) (labels ((fun1 () 10) (fun2 () 20) (fun3 () 30)) (list (fun1) (fun2) (fun3) (fun4)) ) (fun1) (fun2) (fun3) (fun4) ) '(1 2 3 ( 10 20 30 4) 1 2 3 4)) ) (do-test "test labels - the scope of the defined function names for labels encompasses the function definitions" (and (equal (labels ((fun1 () (+ (fun2) (fun3))) (fun2 () 20) (fun3 () (+ (fun2) (fun4))) ) (list (fun1) (fun2) (fun3)) ) '(44 20 24)) (equal (labels ((fun (n) (declare (type (integer 0 *) n)) (cond ( (zerop n) 1) ( t (* n (fun (1- n)))) ) )) (map 'list #'fun '(10 8 6 4 2 0 1 3 5)) ) '(3628800 40320 720 24 2 1 1 6 120)) (equal (block done (labels (;; ;; buf was initialized in :before section ;; (next-index-type (x y) (declare (list x) (atom y)) (nconc buf (list (search x input :test #'equal ) y)) (typecase (second x) ( null (return-from done buf)) ( list (lst (cdr x)) ) ( string (str (cdr x)) ) ( number (num (cdr x)) ) ( t (other (cdr x)) ) )) (num (x) (declare (list x)) (next-index-type x 'number)) (lst (x) (declare (list x)) (next-index-type x 'list)) (str (x) (declare (list x)) (next-index-type x 'string)) (other (x) (declare (list x)) (next-index-type x 'other))) ( num (setq input '(4 "st" (3) #\a 4/5 (4 . 5) "labels") ) ) )) '(results 0 number 1 string 2 list 3 other 4 number 5 list 6 string)) ) ) ) (do-test "test labels - make sure those named functions are defined locally" (progn (dolist (x '(fun1 fun2 fun3)) (fmakunbound x)) (labels ((fun1 () 1) (fun2 () 2) (fun3 () 3)) (list (fun1) (fun2) (fun3)) ) (notany #'fboundp '(fun1 fun2 fun3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-LET.DFASL b/internal/test/LANGUAGE/AUTO/7-5-LET.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..39cd1c771f4fde96a77202352a27f1420a711aa1 GIT binary patch literal 4132 zcmd^CZETxY6@EW#H;ZE@PE&8qvi9v)lDf5%v}xKpQ5M^IlcsTeQ-9QJ8Dx(Argr_t zc5Ns95+xK3D1DW#ji}yRRDK{n1VYeNAQ&66#58H3{oqGhi9dV^!2}YU*nWT}5ze_c zX|s0Hkk~(z*yldyKKI;n&pG#A-|K?)xlmXM6=zF1T`McaxoT;ys>~G2N~JhgPHV~x z=#`5h5>-EYBoG?+_4m}r*7c;zTB@pLl=z%h$)wKjReBC9fl@iAL*vjPfPMbnUjP0B zzWR|sEX=Ka?3jc8eTV$rJ-+&t+c(9gq96!qp@!lKL1+?W!MtHKdE#m;?j0EmtKLXp zLiL!}O`{Ih;!VWVsA;(NDb-@ht84R`j?0;?2%;dEFBx?siAX3uMk3~txF9x|*9^y4 z#5)N~3yi9QRJUpct&66y;h^_`H>}2m+c$eJ3xf5kt4TsfUd_HXF1}Kb#(zF8C1+Y) zqU{v(?rs~%2mj!1wzU=hTaUK>%m6hG1qkT>h^|X%y{5OM3pL%6uGVJXPnT-?mUOw6 zO=oJk*B}zjmp42sW?z|d)`%0}yVt|li1T$pxSstIagIx(1Dba>C$ktn=&uum20^Ih z(x+=L%kQpF$D3>EsB;Z9WSehf?`(AqHRYT0D|a{LbxD_X3yg%c;Gnk_vj6quPx8re z*t*%*O)clwrgrI$q@G_+7V`I8atql>+DRvtKr@^3Zg)~o7M7Fcq>f*ud-%1StS-AO zPZ1BAgSI zTbuni>AOGGS0laodjLsaei>08=>^YMmw7k~*@Rr71xOzU#EH=UQIK~*O7QQKON;gV z+M3%=gAb>t{OlZ=8sK6O3J#oi)^v&ZmvuXQp|gJUoD7gbbQcN+=%^S(6+#$>Z9j3c zRPiWjC_d^_ZxsZ+#kFw<8PY9ieu!BM=5-5%0u@2#&DvNp0_mR`sgWTPBqI+>2Z$ez z40-`>vE4Gbx?2Xu!A; zxD5M;g+O$PU1U&#=#T+ucas4LL{FAXljGzCa*}*z%}8@IxAQ+Q0M>i773QyHn*^x` z?g3GKaPZ@iEp?+VL>*EWHUiM_(R#^?AP8VDZIJdL7zW^>c4;?!I%%WS0UhnsDeVIG zPV=iqnw* zCxPPz&L)_l1=<@y*9`qG=x+kq2-pewdf+qwwgYwmegbeEaBT3gf~zi1C=d@F@kZ5n zA__NEh+TEI*ojzNoscA8wD7wy6jlR~#H4qGL?>b%DoWzxqvOOwo8^7bAqNv9)FJPu zO>!?>f=-VbjgqLBB;u2axJNz!lm<^Aa>C2>Xix5=_3}aLln>EH`7pK1e%fFfO+AlX zwEG}E)PlF`KD;qs1mhOChiLyk5)KXE)f7GtKm(K5`EP-EC_rCU)*Q~_c6J42Sgar6_~hRPq&XHa~TZb5Mo z$E(K@f$${4C_p>R4xv{g@If6xN-PnKsmBlo=nfPI*u-imPNE1Ux*df49v6RvPB|Q! zK-FzFt$d43D}RMeE5|r*n2Q5UNZ(~l>D!Dc-DFHC2lQH!nNoa@DaAL~!o**&g^6Eg z6!Aq)ndg+v;6g*}#6*yUy(~UpMXW=ogCr3d#?=acrR^wwLpxBs%F*{YGHCln+VN@H z9;O{W+Wrjf7zC1a0W4T2qhvIK=p-UmD2R^1&n#O6v&@nnq#n>(DBX?XC5}GN#V9%w zi$`HwL8tsLx(CJETzrm=kmngyKE=gR-q+8Cj|u52V@j79MXE3%zRi^4?>PE37nh-| zob0C~{HpVgMoD6lI$%yQ&)L(Q7UQA=+;dC>#uE`1EabUqJ&KLE;$sQIN<)PGjLLdY zT4HJ(>qE3Mo$ycU1tk21I#K+I`cV9VquOD#AN$QJJ`!U)zM(qRCyN9|vsc#o`Z>L?Y)ZGJvt!GRl zTGc95Mc1l|SE*(-WxAL-uM}sL6w~2vXC+rrQUxV9ThepsTvaKRi>C_x3be{vb*@~f zD6?~VHCKX{!hA}HmjGIxHI1!tw7mUNV7oGtf_Fql$rbn$0CkskA#1_8nkyERN)_HLvs$6rSz$H#eTuQLoHdtZ^Qz6fVl$U4P{R#sSe?M5DSl#7 zMMtg~^@&JqY&4<{dxIz9st6=UVEAYv77ql&>ca0$LxvTj8AD9LXBs|fH2uO_<9XDg z<~eAju+hDU;j-*qtfJ`TXy>AaNa4yh^QyzV;sCGcVcJgz7JeXL?cml>test>7-5-let.test ;; ;; ;; Syntax: let ( {VAR | (VAR VALUE)}*) {DECLARATION}* {FORM}* ;; ;; Function Description: A let form can be used to execute a series of forms with specified variables bound to specified values. ;; All of the variables VARs are bound to the corresponding values in parallel; each binding will be a ;; lexical binding unless there is a special declaration to the contrary. The expressions FORMs are then ;; evaluated in order; the values of all but the last are discarded. ;; ;; Argument(s): VAR - a variable ;; VALUE - a valid lisp form ;; DECLARATION - ;; FORM - ;; ;; Returns: anythihng ;; (do-test-group (test-let-group :before (progn (test-setq a 2 b 20 c 4 d -12 e 30 buf '()))) (do-test "test let 0" (and (eq (let ()) nil) (= (let () 100) 100) (eq (let (a b c d)) nil) (= (let (a b c d) (realpart #c(1 2))) 1) (equal (multiple-value-list (let () (values 1 2 3 4))) '(1 2 3 4)) ) ) (do-test "test let - variables are bound in parallel" (and (equal (let ( (a 10) (b (1+ a)) (c (1- b))) (list a b c)) '(10 3 19)) (equal (let ( (e (+ a b)) (d (+ e a)) (c (- e d)) (b (+ e d c))) (list e d c b)) '(22 32 42 22)) ) ) (do-test "test let - the expressions (forms) are evaluated in order ; the value(s) of the last form are returned" (and (equal (let () (push a buf) (push b buf) (push c buf) (push d buf)) '( -12 4 20 2)) (equal buf '(-12 4 20 2)) (equal (let ((a 20) (b 30)) (setq a (* 3 a)) (setq b (* -2 b)) (decf a) (incf b) (list b a)) '(-59 59)) (equal (let (x) (setq x (concatenate 'string "abcdefg")) (setq x (concatenate 'string x '(#\q #\w #\e #\r #\t))) (setq x (concatenate 'string x "zxcvbn")) x) "abcdefgqwertzxcvbn") ) ) (do-test "test let - include declaration statement(s)" (and (equal (let ((x 0) (y 0) (u "") (w "a")) (declare (fixnum x y) (simple-string u w)) (setq x (1+ x)) (setq y (lcm (+ 2 y) (+ 11 y))) (setq u (concatenate 'string u w "za")) (setq w (concatenate 'string w u w)) (list w u y x)) '("aazaa" "aza" 22 1)) (equalp (let ((a #*1010111000) (b (vector #\t #\e #\s #\t #\s)) (c nil) (d 20)) (declare (number d) (list c) (sequence b) (simple-bit-vector a)) (setq a (subseq a 4)) (setq b (concatenate 'string (subseq b 1 4))) (setq c (cons "a" (cons "b" (cons "c" c)))) ; (setq d (+ #c(1 2) #c( -2 -1) )) (list a b c )) '( #*111000 "est" ("a" "b" "c") )) ) ) (do-test "test let - the body of a let form is an implicit progn; it returns multiple values" (and (equal (multiple-value-list (let ((a 1) (b 2) (c 3) (d 4) e f) (values a b c d e f))) '(1 2 3 4 nil nil)) (equal (multiple-value-list (let (a b c d e f) (multiple-value-bind (a c e) (values 11 22 33) (values f e d c b a)))) '(nil 33 nil 22 nil 11)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..84a5d023e3a8f005c82fae3fd6d98cc5ef0efa08 GIT binary patch literal 4243 zcmd^DZ){W76@P!65bW4_FC+oNpFRR4!Q?pvLI8s(w)21x$2a&7SS&+70m(2HC22+4!)1nYIrbMcPzoD^J?^P>E`t1dK`3+I5vCu@9THs@gP-?3{a( zlES1-8s8T3IOlinIp>~x&bjZtn=3-qS3+SeRG65|nVF(im?}?Bm9?=#Q7aXuim8k? z26FAy5Q!S+4hBN~zTI8U*rJhCF_SE3(pr2fQ%Wb#bZA|>w7_IBX9BZxC%_(mcej7r zcAs;9AQtA{{-ezf|JI%UZQVZS-1Rp_r634GN~j=NDhP@o3-(n@@y3lETDdT(o0*dt6PGhl5=23;zhTwvPeelTJ`%BK#c8qDzHGVs zBKjaKEpWgPq?&mz=v}le*A9KV9ya2!cpxfVf3y37AXGh46$yiRC;M){cq=dUzt=Af zjWw%c^)VLV&DB7^_=S+O&CT%Je5m=h1!6P>2K@N+eLLsu22s(4hTPE{0BLa8au-E15; zB~vyX;1ddl?(R-!|Ld@p^RUotQCy3HlCLcUrJ8P4tS1}B@2TQ4(rQZgRk49=Ag!bw zdj!H^li%DkWDey)r;&JvOrTA~OFBSzInsN?2ci|o5+B)uhG@x6pJ&{Ts|#_jgm}`; zP^_W+Je{1UMMinl=ZDgqDVYtb*ley<#Z{(Ex*v>mS0)~lo(Cg671BL^A0X)&zlW%Y zbVK|L%ifiR27vOS7pOP~#DmcF?;sz7TH(LvSFftK7uLP{IK*&##Lr$oBYQa63q13{D;B%F>dr^cC%#imJ533l@)CnZ2s3Cd!aaQ5bI#p@G zbgn1+Ob5=hkGTzwn-0hc3W6-G1#8j^?J&|?A^S*>^v-t`>kZI-o>{7<3t8GQu8JE? zNfld7Sryw%hbp$K$|iD%gh_-9l4#ah&2|=c>3oL|tBO}uHmgd9s=%)FnJ%-*Tn8(H z4G5_v9#IuLiARF85y5RSJULch0P&33($tr@>1xJl& zd~vqmsUU4ZS%|u&PGkbW_^3XbIYXgl>tZ7|SE>!gh!+hBjo zTI~&yNN*pWMf$-&q&I9t^Tmg9<$UGo(f~*#>3$PpTQouE!Qw>iQgsOT&fq3Yk9yQ{LC>(|% zcA8elhGTJKK$1YCfgiV_un~wP2KD_UIuP?xQ4*iEjuS7fm$$-z98Bz|Zh0G3$ zcz|!k1Nl>M?l6u7!U%p1pc>-~#1Y=Z07Hpr)QBwlTA(71{Q|}sp41=|h#5Q-T93ms zP@^SZ9XJy1i!oQ1&@;@EFk(3T3Vi{|OH@O$i=!Tf9G}zGAawkdu0iq#x)#Z8v^NeX z0^vb~GXPyMJEY!-z=JY2MJy4F8HW*`qwA53vx$vRoJ0|Br!7cYIcbDJIUE`Qk^CW> zR{nrZE5FC4mET}`@+nTTj7SfergWcaN_Uthv>8S%t>Ho^6N(?Pg^9mq3lqQ2RK(Yr zig=Q%tb`D1W5WYM64qIMz>8ReK?g}9(u=DV9?@1LzoBhN-r?wn99gvWRoeCvZ4J{l zA8lPj+xCJ|)kol=YA{L;L=fFV#2N+B4fv9)j$oBp(Z5T*Aay*Xn~?mHqn~l|8U_-J zM`2sxUxFTz!=5#W-n$_}l}5{zQaj3-y|)6Uj1M^5Fzwy&)=G=meo7 zX2h{U#408e{zi2`!XIfJl254*$?rM(9qmN)fTQ=h=G(Lug+Jk%H#zz-*Ze+5*SO|I z>OsvnxaMmdP1DZP)H6=?qtrD-eR1kKOgsCiYY){o)24Rn+en*QXlFBR>H_1c4{a-6 z&XmfUnJIfUT`OlZ+GrttMk|bINiM`MbS+oXl6fsRF=^&fxw1A{EF8=4)_^N!%2UOB zNt>85%ehIokDN@JaNj`RcWvv1IQnimA866Wl5kr|Yq>nXXrS!;MpUErZ1wcI>85EH zq5vRKk{#32fE!8n6-dr(Ox+zPJ$$gk!WG)Tocu(D7&6>R7y{Ts~z^ zr88POlQNUVWI0#JYo#(=jV3bra(jvO<)0{~!|_vlR<lPJ<~rDaP%OCX;meYXOl3Q z45SHPpNcml>test>7-5-let*.test ;; ;; ;; Syntax: let* ( {VAR | (VAR VALUE)}*) {DECLARATION}* {FORM}* ;; ;; Function Description: A let* form can be used to execute a series of forms with specified variables bound to specified values. ;; All of the variables VARs are bound to the corresponding values sequentially ; each binding will be a ;; lexical binding unless there is a special declaration to the contrary. The expressions FORMs are then ;; evaluated in order; the values of all but the last are discarded. ;; ;; Argument(s): VAR - a variable ;; VALUE - a valid lisp form ;; DECLARATION - ;; FORM - ;; ;; Returns: anythihng ;; (do-test-group (test-let*-group :before (progn (test-setq a 2 b 20 c 4 d -12 e 30 buf '()))) (do-test "test let* 0" (and (eq (let* ()) nil) (= (let* () 100) 100) (eq (let* (a b c d)) nil) (= (let* (a b c d) (imagpart #c(1 2))) 2) (equal (multiple-value-list (let* () (values 1 2 3 4))) '(1 2 3 4)) ) ) (do-test "test let* - variables are bound sequentially" (and (equal (let* ( (a 10) (b (1+ a)) (c (- b 2))) (list a b c)) '(10 11 9)) (equal (let* ( (e (+ a b)) (d (+ e a)) (c (- e d)) (b (+ e d c))) (list e d c b)) '(22 24 -2 44)) ) ) (do-test "test let* - the expressions (forms) are evaluated in order ; the value(s) of the last form are returned" (and (equal (let* () (push a buf) (push b buf) (push c buf) (push d buf)) '( -12 4 20 2)) (equal buf '(-12 4 20 2)) (equal (let* ((a 20) (b 30)) (setq a (* 3 a)) (setq b (* -2 b)) (decf a) (incf b) (list b a)) '(-59 59)) (equal (let* (x) (setq x (concatenate 'string "abcdefg")) (setq x (concatenate 'string x '(#\q #\w #\e #\r #\t))) (setq x (concatenate 'string x "zxcvbn")) x) "abcdefgqwertzxcvbn") ) ) (do-test "test let* - include declaration statement(s)" (and (equal (let* ((x 0) (y 0) (u "") (w "a")) (declare (fixnum x y) (simple-string u w)) (setq x (1+ x)) (setq y (lcm (+ 2 y) (+ 11 y))) (setq u (concatenate 'string u w "za")) (setq w (concatenate 'string w u w)) (list w u y x)) '("aazaa" "aza" 22 1)) (equalp (let* ((a #*1010111000) (b (vector #\t #\e #\s #\t #\s)) (c nil) (d 20)) (declare (number d) (list c) (sequence b) (simple-bit-vector a)) (setq a (subseq a 4)) (setq b (concatenate 'string (subseq b 1 4))) (setq c (cons "a" (cons "b" (cons "c" c)))) ;; (setq d (+ #c(1 2) #c( -2 -1) )) (list a b c )) '( #*111000 "est" ("a" "b" "c"))) ) ) (do-test "test let* - the body of a let* form is an implicit progn; it returns multiple values" (and (equal (multiple-value-list (let* ((a 1) (b 2) (c 3) (d 4) e f) (values a b c d e f))) '(1 2 3 4 nil nil)) (equal (multiple-value-list (let* (a b c d e f) (multiple-value-bind (a c e) (values 11 22 33) (values f e d c b a)))) '(nil 33 nil 22 nil 11)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-MACROLET.DFASL b/internal/test/LANGUAGE/AUTO/7-5-MACROLET.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..62082c99df65fb643ee01ee52398e0c55dcd966f GIT binary patch literal 9134 zcmcIK32+=&m3>W*WJ#7rR-{}qM;)6&qeb;ZoxQ({F%5QLO4ji6W%Dg;@uKb)_qj~lVLzatnj{9(Pv zsJGAB`67tLpNJVzJMU}Ma+y)TWgasv3}-kih=O3>mM`i^gah$lBy3NL6Jn`-YrZTP z_V+?)dZ!^sMUEEKF53ChUH)c&j~<9dLPlJ;d#d)dAb1}`R~{OA_y+O85#ipi-XPuB zSnCr#mKW(|g7ENRL8v_K)x@C(&xfJ?{Mqggg}){UXNTSwzCjX!ZWwEq^!$F|bfM=jxSp3-QW{iSr@Y!jjUZ%sp?IxrOKi6z+zQ9Ik&dB zjXrExQn>cKrQoXwUy`L*MLzk8Wke#^0%K$|zUtw%DqI-AWmQmh!N_<&*jrS|46^A;c?SOcluSa7dh5}io3xU#Qraa`Ira0`uK-d|TGf3P55Mb&P; zt{lENyKY&SwBZ-SS;*omhlUK81xfTvNE9;GDG!pek67k+dyk1@d0;TnOxZh87 z3_xBBG&!8;VWsjqXnGIm(NHiJXQgnQ+OzODwb~;HOu<9cVLTIk7i=iT0X>AsG$1PG zMUNx;Rdg1l_KHYpjwU@q<5Ir zA?Yx?3PC@|cCs~y?O zk8z^KiD^#k=fq~n+bYW2q7aqqmc^5AeR5pwg6%NTh-4Op39ssHTg9eH^Ujg4JA5B|-65 z6rK1GTMq)_C)frAQ|xL4|HL*TcrUvK!ObKt9wc!w#KqTx-%4zM6oU{k2w88#2*fqe z_UOI6p?<`0d8)pqN2m1$7J*nI6!*tqVG3b3#4@rj{Eck`O!y1ij^Jh1fZ!$8h~T%J z<)@tG0%v)Qv;2Uw{0C?G1o-`qG z*&B^?h7tQDh3~x+KD5*@E&#M1{4;CD&f}~aL5hRboYlwsJOtD~(<(57FNKM1-n9{T6wwejSJk)+sVR%o*?F;L{x3&B6PCv24EHF;;_88MX_7 z#j&)ba6i(LoEBnx5Zg`etIeFhkz?Cf3-)ay%=0@6&GR(Hw#B(aXv4fTk`V` zuY>-E>B##T3PQezyq70ANWeIF1CgHIkkN-s`&a;hAINGf9){$+;plL7u7uyL|#IJDdOEmD}=cw|; z&#>Lt_c7i#$-xIWnBbs|t8U>sw{oxo3(Q%&L@yxXb)ZN19m5h9o?#f5@C}YlbL=jN z@+!zfFaSFct;aFki2UtFAf!iiJhj9qdf^tf;XSPR9jv(tTz|a}*!e`x%;vP=WNIv<`8CUYXF8R%tP@%`l^KPL9&;p@&ZW()mK-y+kxWiI zmd>UR!5z`@bZ#g;qUDB6jjAr2&Wvb-<0GjYG_t7tOLqRMI4a+8Qs1BrCgEmjKm!rF zVnW(UTqeC|>`AHAo|NI#aoEZnN?O{;_^_7FYH!iD+xeAN2K;eJw9egzQllVMw3O67 zlq#PmwPX816gdbYWlM>?b+L#ar=Y*6( z0UO&zqwn4JW+wJJJHNH1&46Ms_+1xW;L$izs@)u)j5%4yy-oe=lyvQW@qztPN}BF^ zpbHP>L-=Zi@AR&&3tboR>kgg@ps{LMWHokvjg=feG?2tmTXZ56MM0z!Ash->wOGy8 z2$FAM>QCx;nw&qbkZu7T`X8PzJk+WGS5*#p7R&p$f<&6sd%DNGJ-=0+awp14>5@LOe4ZYRQ=N1~uKrE@` zh(=Wkb8R-jq~@f`ok$ui=QPJg%;Vf4n2j*ePN{KC$^eW8P{V>|@|bMsou95ctVL&<^6@j|n%yICzWNc3!S7?ulo;Yy%9 zL4GJ-v?q&1Nwz1IvZ^`-S_*a^U+j`;=WB*Du;8FyS*mVYpkSC#BFSz-uxUzAETuwN zzD%K-C8ta!xZvHm(K*_}X~oX3a#16EAQ+8=d*G7=1h71nN>neuS?cA#p?c{}Q~&Ig zARm3xw10omn92Wc=dWK_Mz}{f^TyP&Irz)LFzhGUZKE)chRqyQua$=V;i!4ycxG$> zOGSQ=N=1g5tU{g0N|_g0P%3q&CZK_JbLtc{iec@S;M6I;twb$Bf*06{&|g;OMOImw zP`wkV^5i`1A6;e!eZpPHjZDXYOiGDtqgEu30ht>`Yy>dw3t~qc2eBQo^Kvp}VzbH4 zi`0O9NJ^%Vv=NsmASW4~-ep)=#UwPOnMG-op11RxmrSEMJeoVf7bje;4rK;Tpo-@x zU(&xU)^xj_-?>l|;VE2MVRui%c04$i8P-OVhfS@ap$R8%Ae6&1ymTAayK%AJ%GafL zCCy#&sVQM~t3KJM@wn=O|U%^D- zjPC#Li(pfD9&7^KRB?J{X6C<(2|S4%&%HsmgeT9me$l{4!Z*?U;v_>!DEOMx)&y42ObYBR0oa*&d9&VrMy?_Wg7Z)e$tJ1!6w_ z9RM1gTPmjyOTLET#bw1TM`tL~h9^`Ui6-U=RNF&JA{zl)7GxzNdXG0v!P)Z%~WXYh9d)Vc-lgd zKsTBYOE^V={{*OqogRhmfE&7ooeev%4L5gzcB&Z>&ey0=?1QUwr-xUQxT-*^3EHH% zir&=4S149Wlyc6jw$XJLSZ8GDj=Xem3o+E7hFz|j4MeL$FF{QkSmbK(TbjC7pgtaF zvm575jFWnO^xop4mGeVvaIJ7>{Vqx_V0Nw~@$G2B$x5Tk!$q)*ccml>test>7-5-macrolet.test ;; ;; ;; Syntax: macrolet ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}* ;; ;; Function Description: macrolet may be used to define locally named macros. Within the body of the macrolet form, macro names ;; matching those defined by the macrolet refer to the locally defined macros rather than to the global ;; macro definitions of the same name. Each definition is similar in format to a defmacro form. ;; Lexically scoped entities are not visible within the expansion functions. However, they are visible within ;; the body of the macrolet form and are visible to the code that is the expansion of a macro call. ;; ;; Argument(s): NAME - a macro name ;; LAMBDA-LIST - ;; DECLARATION - ;; DOC-STRING - a string ;; FORM - ;; ;; Returns: anything ;; ;; ;;; Test cases for macrolet, constantp, and other lexical macro facilities. ;;; ;;; Pavel, May 30, 1986 #+Xerox (do-test lexical-macros-and-constantp (macrolet ((foo (x) `(get ,x 'foo)) (bar (x &environment env) (if (macro-function x env) 7 ; A constant expression '(baz) ; A non-constant expression )) (my-constantp (x &environment env) `(constantp ,x ',env)) ) (my-constantp (bar foo)) ) ) (do-test lexical-macros-for-declarations (macrolet ((special (&rest x) `(declare (special ,@x)))) (macrolet ((test (x) (declare (special *foo*)) `(eql ,x ,x))) (macrolet ((special (&rest y) `(this-is-an-undefined-function ,@y))) (test 7) ) ) ) ) (do-test "test macrolet - test case copied from page 113 of CLtL (flet was replaced by macrolet)" (macrolet ((safesqrt (x) `(sqrt (abs ,x)) )) ;; ;; The safesqrt function is used in two places ;; (let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) ) (and (= (safesqrt (apply #'+ (map 'list #'(lambda (x) (safesqrt x)) longlist1))) (sqrt 30)) (= (safesqrt (apply #'+ (map 'list #'(lambda (x) (safesqrt x)) longlist2))) (sqrt 118)) (= (safesqrt (apply #'+ (map 'list #'(lambda (x) (safesqrt x)) longlist3))) (sqrt 16.5)) ) ) ) ) (do-test-group ( "test macrolet - test case copied from page 114 of CLtL" :before (test-defun foo1 (x flag) (macrolet ((fudge (z) ; The parameters x and flag are not accessible ; at this point. `(if flag (* ,z ,z) ,z) )) ; The parameters x and flag are accessible here (+ x (fudge x) (fudge (+ x 1))) ))) (do-test "test macrolet - test case copied from page 114 of CLtL" (and (= (foo1 2 t) 15) (= (foo1 2 nil) 7) (= (foo1 (1+ 5) t) 91) (= (foo1 (+ 1 5) nil) 19) ) ) ) (do-test "test macrolet - with empty macrolet body" (and (eq (macrolet ()) nil) (eq (macrolet ( (fun1 () "this is an empty function") ) ) nil) (eq (macrolet ( (fun1 (m n) (declare (integer m)) "m is declared to be an integer" (declare (special n)) "n is a special variable" ) ) ) nil) ) ) (do-test "test macrolet - with declare statements/parameter list keywords" (and (eq (macrolet () t) t) (equal (multiple-value-list (macrolet ( (let1 () `(values 10 20 30 40)) (let2 () `(values "a" "b" "c" "d" "e")) (let3 () `(values-list '(writing code for macrolet))) ) (values (let1) (let2) (let3)) )) '(10 "a" writing ) ) (equalp (macrolet ( (fun1 (m n) (declare (integer m n)) `(+ ,m ,n)) (fun2 (m n ) (declare (string m n)) `(concatenate 'string ,m ,n)) (fun3 (m n o p) (declare (type (integer 2 10) m n o p)) `(max ,m ,n ,o ,p)) (fun4 (s) (declare (complex s)) `(type-of ,s)) (fun5 (s r) (declare (number s r)) `(vector (gcd ,s ,r) (lcm ,s ,r))) ) (list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) ) (list 59 "ace" 7 'complex (vector 1 2300)) ) (equal (macrolet ( (fun1 (m n &key o p) `'(,m ,n ,o ,p)) (fun2 (m n &optional (o 2 oflag) (p 30 pflag)) `'(,m ,n ,o ,p ,oflag ,pflag)) (fun3 (m n &rest x &key (y 6) (z 7 zflag)) `'( ,m ,n ,x ,y ,z ,zflag)) ) (list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) ) '( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) ) ) ) (do-test-group ("more tests for macrolet" :before (progn (defmacro fun1 () 1) (defmacro fun2 () 2) (defmacro fun3 () 3) (defmacro fun4 () 4) )) (do-test "test macrolet - locally defined functions overshadow the global functions of the same names" (equal (list (fun1) (fun2) (fun3) (macrolet ( (fun1 () 10) (fun2 () 20) (fun3 () 30)) (list (fun1) (fun2) (fun3) (fun4)) ) (fun1) (fun2) (fun3) (fun4) ) '(1 2 3 ( 10 20 30 4) 1 2 3 4)) ) (do-test "test macrolet - one can locally redefine a global function and the new definition can refer to the global definition" (equal (macrolet ( (fun1 () (+ (fun1) (fun2) (fun3))) (fun2 () (* (fun1) (fun3))) (fun3 () (+ (fun2) (fun4))) ) (list (fun1) (fun2) (fun3)) ) '(6 3 6)) ) ) (do-test "test macrolet - using macro to define special declaration" (let (buf) (macrolet ((special1 (&rest x) `(declare (special ,@x)) )) ;; set only works on special variables (prog ((a 2) (b 4) (c 8)) (set 'a 22) (set 'b 44) (set 'c 88) (push a buf) (push b buf) (push c buf) ) (prog ((a 2) (b 4) (c 8)) (special1 a b c) (set 'a 22) (set 'b 44) (set 'c 88) (push a buf) (push b buf) (push c buf) )) (equal buf '(88 44 22 8 4 2)) ) ) (do-test-group ("test macro - lexically scoped entities are not visible within the expansion functions" :before (progn (test-setq num 100) (test-setq varlist '(10 8 12)) (test-defun lisper (num) (let ((var (pop varlist))) (macrolet ((mac1 (item) ;; the parameter num is not accessible at this point; ;; a reference to num would be to the global variable. (cond ((plusp num) `(list "global num is > 0" (format nil "local num is ~A" num) (* ,item ,item ,item))) ((zerop num) `(list "global num is = 0" (format nil "local num is ~A" num) (- 100 ,item ))) (t `(list "global num is < 0" (format nil "local num is ~A" num) (expt ,item 2)))) )) ;; The parameter num is accessible from here (list var (mac1 var)) ))) )) (do-test "test macro - lexically scoped entities are not visible within the expansion functions" ;; global variable num was defined in :before section (and (equal (lisper -4) '(10 ("global num is > 0" "local num is -4" 1000))) (equal (progn (set 'num 0) (lisper 30)) '(8 ("global num is = 0" "local num is 30" 92))) (equal (progn (set 'num -9) (lisper 0)) '(12 ("global num is < 0" "local num is 0" 144))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL b/internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..992be3ba0ddd7d73e2bf2a1d7269a80555e700d6 GIT binary patch literal 4401 zcmcgvYit|G5#GI{MLkGSQdGO4CHbsGelR-OitX5O3$!QdD9I-8s5{b*gA_4Eo=nz9 zQXwfjY7xVA;h;d7xQZI$wvB%TMT@2|P{-|`G(q$u1^Px`XnzD~&<9YU|N5g3pg`-+ z?2@u1J5h?X6?mB0+1Z_$Z)Rs#%VgVQ(YO*V7Z(byQ&Gx`wS~o+GGDGJ)$(E`>nQUe zS3VszE&Z8kEqZe7BjcU+x|wXn$<&;jl3H}Cxy;h2GXAKdEmR6FFvpI;@R8$(4SPkmTQh4KXmZ;!NX&nx34#7Pni&sC96m}2b(yuweo`MIu{%l!zoq?CB*wey*-vTqNy3v@K)$$8t|^wgENMj zgwV7pok;D?U2u2m)jN)=N7STcPMspx8=)(N$n)sOck-{Fps$t4jW}V9}b6`iVzEOKfauQ{Tv~ESNz*){;~O_cgWq>>kDn3`;hrzGi(l+L%g7H7V5a~a(*q7 z@9F8iiy5EqsElX2ZrCuTrmOxY1B$U;&FsP~J`5smAbkxr^H(@NM8Mx}O`_rtdhJ|F1yMxt6O zI;~oIDs4fBi1HTGW}mTBdP1UiYoyEw>yvv}NbZHM(jCz)%d}K8ol2%t5xEZ*1R|Po zM&)ue30>;&<}TGE6T*DhoAzS2ISV`a^ix_K2Nn$4&|fWuLla$yrY%c1)-^&#aqeR< z*MA3%sAlWJF6+Z-3DD|zV$vMrtqmm7AK4(1UkUPc7RJ$6*-j)cvH>Jd!J>X!PsLRG zOk%=}tF2ColQZC3=pOQeAm7F#My(MTb=yfjI-|jIh(t}IIE>JHA zjvnPWNRNQfhiO5XDintW*&#?s5G-o6GtTYMzcBQk{+2z2`kt73 zLy%Vmc}0-(0{$$I0gfQXNB+r$-~eQpn7? zP8HWrdG%c>Tt9qC8&>8s@RZ3Zg_3xMpzP8Js`Yy-zF_|l!Xf>uL4t6>@{ZO+y!uWz zQ=H3XaMfLB72;{0RZ7`Ig!;TMO5Td>)#;p9_hlW|1vXcgGg*h=-v0nQAjt>?n#Ea^ z{|)4%#Hx|A#)j^DaKTy~&54H+;j;klk$al5=CoBxf!APRDOP#b|;BW$cI4 z07gQ_1V%?}azW7W^x3sv;`aq5C7sv4B4_02%b+0~ld_splri&*g zuS8z3yx>}ucFAtm-Wa-GY{)wSS@tj$~t9`q_v(9-u9K-cO0HbmTT?1d z&Y3Ti9OaURCm^Hn;P5$(k@y?*{<|ZA(~}f&bZ_B5JjlgWC*Q~RVhHR>$;Zx8){Wju z;?&T;3kP|Z`t>^gEry4OuJFvW(_)5S37_%m=Qp&C!aQ8FWo6#E2>ro@|5TJr#Zjt@ z3kz<+$&D(tyaS;YGldfL6Q#OToGZIRXRf?h$|)K6K&PY>GdTygQu3J#j#4U%-O!6? z*f^3zgM0mC6HljM16E;GR%46o0=vkbM(M{J(m-++%8z%w>l*`r zw-}V<0Vv6_Ez&8q(kX3c3n6elz@C!$c~jYF8{{Y0&z-=E3-+VoV|a=WurUS-I3B(` zm-l(~llRJHF;iN4_hdRxXPs(w{e0nEsSMSORzf^i(3Y zayz&P?|<%J1^lamf3+=qTWdvd2|~TXgEg(&;N}t7Srpu8L+TNg#i8bB<3BE}06fAv zNAy#=wfTqyqtlwDMWM?l3E2nuKc9Ji?m^50)YttDB10W-5d*j@+7aSQH)2b^g!y~< H_U(TI1&`7y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST b/internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST new file mode 100644 index 00000000..9113ff90 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: progv ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 112 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 27 ,1986 ;; ;; Last Update: Oct. 27 ,1986 ;; ;; Filed As: {eris}cml>test>7-5-progv.test ;; ;; ;; Syntax: progv SYMBOLS VALUES {FORM}* ;; ;; Function Description: progv allows binding one or more dynamic variables whose names may be determined at run time. ;; The sequences of forms (an implicit progn) is evaluated with the dynamic variables whose names are ;; in the list SYMBOLS bound to corresponding values from the list VALUES. The results of the progv form ;; are those of the last form. ;; ;; Argument(s): SYMBOLS - a form which returns a list of symbols after being computed ;; VALUES - a form which returns a list of values after being computed ;; FORM - ;; ;; Returns: anything ;; (do-test "test progv - the body of progv is an implicit progn" (and (not (progv '() '())) (progv '(a b) '(#\a #\b) (every #'characterp (list a b))) (equal (multiple-value-list (progv '(aa bb cc) (list 1 -1 2) (values aa bb cc))) '(1 -1 2)) ) ) (do-test "test progv - if too many values are supplied, the excess values are ignored" (and (equal (progv (list 'a 'b 'c 'd) (list 11 22 33 44 55) (list d b c a)) '(44 22 33 11)) (equal (progv '(x y) '(1 2 3 4 5 6) (list x y)) '(1 2)) ) ) (do-test "test progv - if too few values are supplied, the remaining symbols are bound and then made to have no value" (and (progv '(a b c d) '(10 20) (and (equal (list a b) '(10 20)) (notany #'boundp '(c d)) ) ) (progv '(aa bb cc dd ee ff gg) '() (notany #'boundp '(aa bb cc dd ee ff gg)) ) ) ) (do-test-group ("test progv - progv allows bindings for dynamic variables" :before (progn (test-defun pro1 () (declare (special w x y z)) (set 'w (concatenate 'string w "ce")) (cons (pro2) w)) (test-defun pro2 () (declare (special w x y z)) (set 'y (concatenate 'string y "ell")) (list x y z)) )) (do-test "test progv - progv allows bindings for dynamic variables" (and (progv '(m n o p) '(9 8 7 6) (set 'm 99) (set 'o 70) (equal (list m n o p) '(99 8 70 6)) ) (progv '(w x y z) '("a" "b" "c" "d") (equal (pro1) '(("b" "cell" "d") . "ace")) ) (let ((w 10) (x 20) (y 30) (z 40)) (declare (special w x y z)) (and (progv '(w x y z) '("a" "b" "c" "d") (equal (pro1) '(("b" "cell" "d") . "ace")) ) ;; ;; the bindings of the dynamic variables are undone on exit from the progv form ;; (equal (list w x y z) '(10 20 30 40)) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-6-CASE.DFASL b/internal/test/LANGUAGE/AUTO/7-6-CASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4d50ba832d3c5580eeb0e8b944e215295a345714 GIT binary patch literal 2199 zcmb_eT}T{P6uvX->Z)t1Ms%^pTrDLq?MVEoCN`x`$5B_;nRI40Mks-GcXS5#$L`E3 zQW_+M($Wp>=8w54mbMV+OF?`~Qp`i?TcG4IPkjjVrIZSVKE|FqH%m2+JUTQqI`~Fk!-Qlc7~8+vjEoMR9v$rO zYuMYo#WfcYLTU7Xih6{aQ3(0h%FTkQ7^XN8Pbi`)%_@Rl@yij&MNArs?w4Bzuvb_S zv(~DWrRn5c#3AH=QI1R`RoRSds(+o^;G+KL<)*kQo`=+=Nd@tdXDpPRgZYR!EXtCh zpv_y+D+uvl(=hJY_ounLd9?b&G(Xqb*}{eGrxkm{xxa)^>y^4z&c3^&!hE+fb5;Ej zp^E*nI?Z!UFx%>w>!K8NL=cK1^uS4X2gy}gA68lGj*yi*QDu!BO_*H1N?3nHgg;ja zo1k>?g>u1p(?UHwlEU(ts)I&*$GNmUraHUZXTi~qvwb=^uI*D)W8QbSV*$3A4PVNJ zcWuF!Jx7rVTh$?oo(~S72f3w^r$eKDHr;oWfC8^^HMHkY7Yc@9DwK%(|%&&69#UOm`7p*q(dOFZW3z;kNj1?{F-cA>1Di{%EE1dUCYBx z9@8VkuIFU4c&Sjx&@0GwG8Q%Y)GwbjE!V@nm!)33n1ZV)LrsD^iDH*urP~z$OaD3# z@pj9)BAJT#!t;=bn~E+a4AMxqLHXZJYNirI$`Akls0K(6t>9MRmGlB9d4(0|8^4U@ zR34{Ou7!)1S1RUlu9Wqh6}UrL)^AhOO~&v(H9bkXDWn}_8}rMjSi#mTpv>bEu;xp- z1*_=NDtNYqm#uYrxlx950V#TVfC&9@7?Hc4TPS1?Aws_~qVEq9eFgcA7vP^k&cbVj u;xdgQxXhjW(!Nm8ZPGLMy!Dh{ZmU|lPL9^YgM)R)Ne}n@PIP;0Z|`r%a*f&m literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-6-CASE.TEST b/internal/test/LANGUAGE/AUTO/7-6-CASE.TEST new file mode 100644 index 00000000..143034d0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-6-CASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: case ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 117 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 13,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ broke into smaller tests. ;; ;; Filed As: {ERIS}CML>TEST>7-6-CASE.TEST ;; ;; ;; Syntax: (case keyform {({({key}*)|key}{form}*)}*) ;; ;; ;; Function Description: ;; The form keyform is evaluated to produce the key object. ;; The key is matched against each clause to see if the key is ;; in the keylist. The forms of that cluase are evaluated, and ;; case returns what was returned from the last consequent (or ;; nil if there are none for that clause. ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; KEY - a list of one or more keys. ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "Do some simple tests" (and ; Does case evaluate and return the appropriate things? (case T (T T)) ; catch everthing (case T (nil nil) (T T)) ; catch everthing (case T (nil nil) (nil nil) (T T)) ; catch everthing (eq (case T (nil T)) nil) (eq (case T (T nil)) nil) ; catch everthing (eq (case T (T)) nil) )) (do-test "Do some work in creating keyform" (and ; do some work inside (case (< 10 13) (T T)) (case (< 10 13) (T (> 13 10))) (case (< 10 3) (T T)) ; catch everthing (eq (case (< 10 13) (nil T)) nil) )) (do-test "Check we can use symbols in the keyform" (and (case 'foo (foo T) (T nil)) (case 'foo (bar nil) (foo T) (T nil)) (eq (case 'foo (bar T)) nil) (eq (case 'foo (bar T) (5 T)) nil) )) (do-test "Check we can use numbers in the keyform" (and (case (* 5 6) (30 T)) (case (* 5 6) ((20 30) T)) (case (* 3 10) (5 nil) ((4 5 6) nil) ((20 30) T)) (case (/ 3 10) (5 nil) ((2/10 4/10) nil) ((3/10) T)) )) (do-test "Can case return multiple values?" (and (let ((casevar 'foo)) (equal (multiple-value-list (case casevar (foo (values 'x 'y)) (t nil))) '(x y))) )) (do-test "Check values set in CASE still good outside" ; Define a function, tee returning T (flet ((tee nil t)) (let ((casevar 'foo)(sideffect nil)) (and ; Check values set withinside of CASE ; are still set outside of CASE (case (tee) (T (setq sideffect T))) (eq sideffect T) (case 'foo (nil nil) (hi nil) (foo (setq sideffect 'foo) T) (T nil)) (eq sideffect 'foo) (eq (case casevar (bar (setq sideffect 'nope)) ((foo baz) (setq sideffect 'winner) 'okay) (otherwise (setq sideffect 'lose) 'so-what)) 'okay) (eq sideffect 'winner) (eq (case (* 5 5) (5 nil) ((10 20 53) nil) ((1 2 3 4 25) (setq sideffect 5)) (T nil)) 5) (eq sideffect 5) )))) (do-test "Check values set in CASE still good outside" ; check the path not taken was in fact not taken (flet ((tee nil t)) (let ((sideffect nil)) (and (eq (case (tee) (nil (setq sideffect T))) nil) (eq sideffect nil) (eq (case 'foo (nil (setq sideffect 'nil)) (hi (setq sideffect 'he)) (bar (setq sideffect 'foo) T) (T 'everythingelse)) 'everythingelse) (eq sideffect nil) (eq (case (* 5 5) (5 (setq sideffect 5)) ((10 20 53) (setq sideffect 104)) ((1 2 3 4 6) (setq sideffect 65)) (T (* 2 3 4))) 24) (eq sideffect nil) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-6-COND.DFASL b/internal/test/LANGUAGE/AUTO/7-6-COND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0f38f99ed2f9fecac3c438c82d9d77a81a8d52ed GIT binary patch literal 3664 zcmb^!ZERat^}hF<#Lma$v`LCHCwq!$)Ox(EX}YE+F|yL5RvtUTQbb zcIJ;tg{?##jQx0QO}j?#uA3O3Nt1?Hl>KSfsSz4TXiSq30;K&x0;VAW($GK}5{)_M z-q>^S*!YnsSLfXGea=1iyz3Rx^k^h5NAlUFjBOR;O)5eRXwINpgFJz~ZT-MuC(3+?W+PDe~vPC{zx z35|%}Eh}hU0DM$AtV9g`Ve;bYJ(mgbd;!CFBYk^PxRoQ1y*VkK9_Z~9nliV~5wh!Y zOOKGgbw>yM!2DFTl732`6on4J*7ltKB5LFE64Fk{MrLl1aoL)}vh$G?tsw3~tL@wN@8uVd$i?(P>wkO>SfA2hplqaj1zq2C= zh!0f#bwFXzHdJ^6ym|m$$NkzqyTkU?cD*_2&makV7S7Yz%9av>9g6AgYD{hQFG z%*pzL=^DBZBx;+$`6~K+_DB`Qv)-}umIkY#wbzBVGrc7Juxh(CeJ6b;xRH}SIMcsj z^rw3n5bhZLq5yOq7?o8cxRPGZZ0lp-89|5(?##1BkX@SZ8o~ej)_9a^0Dg3Dk8eT^ z&ji=^8$n+8e(Vdo+4kBUtRs7YUti|Bj{K}puBO*|KJ5mtr2QE`5&iCUCm6z65ySDK zL{8-C0eI5K!0Y-X>4=)txGUO*>|a1p zTD~@YDjrLsDe326x$Tr1pV5*^mG(02M%FUjh2ROg8$p(K0T3&UDE^xf#lLbQ8tqDI z=7f@*ogO#hN_C{8#*ethOI+g$*GNH>O@=vpQmcI?aKNMdDcXx*ii3wZ7~w#ndywbl zCYzW^;h)T;@Gh8?z%dPgh_FHLMerI2Kj45eb)m%6g~zyhimQ7#QD8*!cSa9K zUaZ$I-D^#vr`g+qo1ef%7)Ru3_lA2-gpm3p2~9OM_7dQ?n>BhoW@-sFo}_Ik28Z*= zjA3dlC+VW=BeG+3alRIZyrF?EHPPt%}%7t7}&gbllG6*uhd?96*EqULPJUntl z&M(N3cqzUg!zxqO4lOJ?x)*%YLFQEa*mZ{LoiZFBbKC>im9u5Llv#o|9W!49d*VNs zJ@IF&1a{=f@M6VP`G{P*5Qg{1`UC3C^sO{JQleKb$JPQ-!4`jeJNDe<)ZiQ6o=W$A z^;T58x%U2+N+fJcmGz+p73qJfJOi_z|F>;D@m%L#JC!{X4(S>0y7|{!&sz&3y7ai82SksC?cLT5{X$F zAXowM)yBfU;5vP^!j4osF9(eU?S##UdM>Zyyz4X{la=8E2aq`HI?{2Op}Onr&gFAT zuADt<6%<76OtFMgDoEurHll|?{h{OXmiqoxG8Z24ufP{`eJp(bqwk09`MV#nHw=3i z`_G3f?7g!I7;v*MY~$hw&>zMx?#<{*^gCe*4c!RW=`#uP*#(D}v#?cgxKGW-_@ovw z;i$g;=?P)Vkc{a%9?b6;s91$UzA!xMIzC7ZOCu`>Yh@bXB?{CM?{b}%V^{(Ces&=K z#sh&kI%)@U5b7q}Wz`pc1y;`GOLOTI65rmodkZ3hNJfzJI>(vn%N!p@`t?=Pc0RoL z{)g~cSN)$;7^rSTCjt$F79MX1TFBN1&AerJ(8r;LStMgsf?AH;hy+Q{P+f^d2v!_9v&(^Qd0b#o^dA?Yw F{0CndF9`qu literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-6-COND.TEST b/internal/test/LANGUAGE/AUTO/7-6-COND.TEST new file mode 100644 index 00000000..0e49b57b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-6-COND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cond ;; ;; Source: Steele's book Section 7.6: Conditionals Page: 116 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 11,1986 ;; ;; Last Update: June 11,1986 ;; June 17, 1986 Sye/ change "set 'm ..." to "setq m ..." in "test cond - test the selected final clause" ;; ;; Filed As: {eris}cml>test>7-6-cond.test ;; ;; ;; Syntax: COND {(test {form}*)}* ;; ;; Function Description: COND processes its clauses from left to right and selects the first clause whose test is ;; non-nil. The forms (consequents) of the selected clause are evaluated in order (as an ;; implicit progn) and the value(s) of the last form evaluated is returned and the remaining ;; clauses are ignored. ;; ;; Argument(s): form - a lisp data object meant to be evaluated to produce one or more values ;; test - a form which returns nil or non-nil ;; ;; Returns: value(s) of the last evaluated form of the selected clause ;; (do-test "test cond - zero clause" (eq nil (cond))) (do-test "test cond - zero form" (and (= (cond (1)) 1) (= (cond (nil) (2)) 2) (eq (cond (nil) ((cdr '(1))) ((and t nil)) ((or nil nil)) ('()) ('non-nil)) 'non-nil))) (do-test "test cond0" (eq (cond ((oddp 20) (1+ 20)) ((evenp 3) (1- 3)) ((= (sqrt #18r10000) #18r100) 18) (t 180)) 18)) (do-test "test cond1" (equal (cond ((equal '(1 2 3) (list 1 2 3 4)) "err1") ((and 'a 'b nil) "err2") ((prog1 2) "2") ((prog1 3) "3")) "2")) (do-test "test cond2" (progn (defun fun (x y) (cond ((evenp x) nil) (t y))) (equal (cond ((fun 2 4) "err1") ((fun 10 9) "err2") ((fun 1000 'a) "err3") (t (fun -1 "gotcha"))) "gotcha"))) (do-test "test cond3 - test nested cond" (let (object) (defun otype (object) (cond ((numberp object) (cond ((plusp object) (cond ((>= object 100) ">= 100") (t "< 100 +"))) ((zerop object) (cond ("= 0"))) ((minusp object) (cond ((>= object -100) ">= -100 -") (t "< -100"))) (t "error1"))) ((listp object) (cond ((eq object nil) "nil") (t "list"))) (t "non-number-non-list"))) (and (equal (otype 101) ">= 100") (equal (otype nil) "nil") (equal (otype 'a) "non-number-non-list") (equal (otype (1- 1)) "= 0") (equal (otype (/ -400 2)) "< -100")))) (do-test "test cond - test for returning multiple values" (let () (defun fun1 (x y) (multiple-value-list (cond ((= x 1) (values-list y)) ((= x 2) (values-list (mapcar #'(lambda (z) (* z 2)) y))) ((= x 3) (values-list (mapcar #'(lambda (z) (* z 3)) y))) (t (values 'sorry 'wrong 'input))))) (and (equal (fun1 1 '(1 2)) '(1 2)) (equal (fun1 3 (list 10 20 30)) '(30 60 90)) (equal (fun1 10 '(9)) '(sorry wrong input)) (equal (fun1 (* 2 1.0) (cons 9 (cons 7 (cons 5 (cons 3 nil))))) '(18 14 10 6))))) (do-test "test cond - a selected singleton clause returns only a single value (p 138 of CLtL)" (let (fail a b) (multiple-value-setq (a b) (cond (fail 1) (fail 2) ((values 999 99 9)) ((not fail) 100))) (and (= a 999) (eq b nil)))) (do-test "test cond - test the selected final clause" (let (fail m) ; ; if the selected final clause is a singleton clause, be sure only a single value was returned ; (and (setq m (multiple-value-list (cond (fail 1) (fail 100) ((values-list (list 66 33 22)))))) (equal m '(66)) ; ; if the selected final clause has a test part (non-nil), any value(s) may be returned ; (equal (multiple-value-list (cond (fail 10) (fail 100) ((or fail 1) (values-list (list 2 4 6 8 10))))) '(2 4 6 8 10) )))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-6-IF.DFASL b/internal/test/LANGUAGE/AUTO/7-6-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1f684344547ad1a5091e1e770d68b47ae8244c9 GIT binary patch literal 3020 zcmb_eYitx%6uvXtZOisSI~2C1SjHA&T%9K6S!x0f%Pef!?v&kGUcr=Qcj^pGckAwK zNuy$0pV1-E^2l5PjWH%h|B%(hAfzOkkeH}3CYoqW3_tv#KTM6kj3jvOy}Qs-D29;D zopaAQ_kQO)=bpVYlgPU_7!iZnp<&a~b7Hn&4;O54Fq;$e*+MR*i-TYnpAV`r<;5Lx zaA)UJUB37%Pb#M;Z9Oe&1wEfmjy@@NZ4%|-oN2+NyBpLEJ?qx>tX<#f3(4^aL%Z*u zjXi6-de*J&^xeF0mTSl&gi`1#5sMINKpx~yISm0#iEC0Q98sjG+@}QGN!O`{T%<%? ziMdYW8qv-UOO`&OTO^&KJmL^?Pde41L^P;{)u?-l8{=x-6HZ+?D)mEZ@^%IB)g=^y z&bdzIMrnf-4xtNYeG>>(EFmO5H!k;bmon(NE4}=lw&jhS*S!2JLc&B<6K7nSj>3Fq za_8~rmk3Q7uSI)#t`24w{d+{Rn~Z9NY7x3>rrK#%Wxy}WfK?9%kV};Tt4Y*p@)!`V z9*)+Z0*(_f2-V{Hl3~oC>Z-%4FlWI#Wy6>;X^fd;2Kmj(7$8-FY@OVBLKSG%udBlU zPMb$%mUSh9lq?B4Wz~*bZC33}v6HElV}?~ZQ)~mqQx-pNwOB1P=c%&m9^@YUIQU&< zUNsNrIQZYnfVJj%R(xm-Xz90RDww6i0Z21QS%THSg*LW7=MV=st(OK6l=D_Fq8v-=lPB$CRi0H>nAoyu&<0L5m65+60jwF;gQ44q} z5jnh!h=WXfhG}u8^)oHN&>v&yeu~chM2*~!)W}_9MwuBmGh-(;qI1-UTxvvb;HF+I zY{yGB;-)T$?D-vNd1)<)b{*a#l~Gct2vL8)%|sNTCZ3S0-g*y_HwbZjgjK;5H)qn6H=ld<@-7VYz>pxI&HGr%d~hi4JC5&a@gT(7zM~{Y5d+ zpG^G0jK4DRGZWu2@eNz@6>dF-{Uf;fFm9Hxe>HAy!OgTMk?TBe>v>xoPTGc;$=afw zJfdgBqshEzX2ii{%D!zSmAv6PD>bsA{g~Vie)xDv)0N~ahS-j+Cd5o8W#DBy+=bqxBifzG|B5R6tN3%!5ni7*Eaa==|L38X%sG34+;yK_tPf*Sy zNee!T#Jp}32H}vH%;{p@HZ6;kb|IGm{1H8uv_wXMV1L3wyh=8=u@*>?c`IvxHS@7MT<1}W zohb|*(sOw+nMsTJ(V;_G3+9lDohuOb{7MSVU7rWReeXK0ccWKAgw5QyZ1dp42f__3 zSQ;)oKXy;Kb&eX)FsUR|JtCML>TEST>7-6-IF.TEST ;; ;; ;; Syntax: (IF TEST THEN [ELSE]) ;; ;; which is exactly equal to: ;; (cond (test then) (t else)) ;; ;; ;; Function Description: ;; The if special form corresponds to the if-then-else ;; construct common to other languages. First TEST is ;; evaluated. If the result is not nil, THEN is selected; ;; otherwise, ELSE is selected. Whatever is slected is ;; evaluated, and if returns whatever evaluation of the ;; selected form returns. ;; ;; ;; ;; Argument(s): TEST - a form which returns nil or non-nil ;; THEN - a lisp data object meant to be evaluated ;; to produce one or more values ;; ELSE - an optional lisp data object meant to be ;; evaluated to produce one or more values ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test the simple cases" (and ; Does if evaluate and return the appropriate things? ; Check just boolean values (if T T) (if nil nil T) (eq (if nil t) nil) )) (do-test "test when do some work in test" (and (if T (> 3 0)) (if (> 3 0) (> 3 0)) (if (> 3 0) (> 3 0) nil) )) (do-test "test when call a locally defined function" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and (eq (if (tee) 'foo 'bar) 'foo) (eq (if (tee) 'foo) 'foo) (eq (if (nill) 'foo 'bar) 'bar) (eq (if (nill) 'foo) nil) ))) (do-test "test able to return numbers" (flet ((tee nil t) (nill nil nil)) (and (eq (if (tee) (* 3 4) (* 5 6)) 12) (eq (if (tee) (* 2 3)) 6) (eq (if (nill) (* 1 2) (* 5 5)) 25) (eq (if (nill) (* 9 9)) nil) ))) (do-test "test numbers and symbols are true" (and (if 5 T) (if 5 T nil) (if 'hi T) (if 'hi T nil) )) (do-test "test able to return several values" (flet ((tee nil t) (nill nil nil)) (and ; Does if pass multiple values? (equal (multiple-value-list (if (tee) (values 'foo 'bar) (values 'baz 'bletch))) '(foo bar)) (equal (multiple-value-list (if (nill) (values 'foo 'bar) (values 'baz 'bletch))) '(baz bletch)) ))) (do-test "test values set in IF are still set outside" ; Check values set withinside of IF ; are still set outside of IF ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (if (tee) (setq sideffect T) nil) T) (eq sideffect T) (eq (if (tee) (setq sideffect 'foo) 'bar) 'foo) (eq sideffect 'foo) (eq (if (tee) (setq sideffect 5) 23) 5) (eq sideffect 5) )))) (do-test "test path not taken was in fact not taken" ; Check values set withinside of IF ; are still set outside of IF ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (if (nill) (setq sideffect T) nil) nil) (eq sideffect nil) (eq (if (tee) (setq sideffect 'foo) (setq sideffect 'bar)) 'foo) (eq sideffect 'foo) (eq (if (nill) (setq sideffect 5) (setq sideffect 23)) 23) (eq sideffect 23) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bbb3b82f4b624780a66bb59da9f2507ab1959166 GIT binary patch literal 5612 zcmcH-du$u!{myr1Cu!oQ@6wj`C|zkyT|z@kQwH?nTw=HOU3PXFLRpcUxIKd#XR!l{ zV34Ie2AH<#Bls(W4gT1MhP04Q+ZZU>nAnB}LueY?B$!}Ad%>h^LK^DO*ze&>+NK-( zBa?mpeZTkP`+eVi{zfG2rbt|mF&>@i+_N%bxV^7swJsjQl#?nQhg|8CR5?oSlkR-M#2o0 zN6Mut$R*s7G@Wv3!4|!k?+fQLcVu#y&Y^-NOH%n*sj9WZilkz;RX!mP$+hL9rMj3E zZim#2HdFFdRjiEfHoPsI>S{M5M$(j?7_A?cq^d(0$`9NZcFE88$}3;o4_Lc=avgXb zTh_S&gTMz2)k@N2wmU>sucWG!yi}`l+aQAD*|AmLU=a;QvR|&iA@_v)ocwX6Bp|tV zX1J^}9LYXBJ!1J+XN1Bt!~aQj1hV3oHcpS$OpliEXe9fPH(-Z*0fjG33=|UL)Uhl8 zm-EydVelXWR$7mtf%L?uic0^4N_t}JD&ngua539_*lMiDDaQwDCjIQcs(7;J1|*$= z6wZlf#=$J<aac&y!FJ8k{&rI8# zSy%Ua*6VV^yr8njI@}#wW(T1PBW}qKLMPyQn!sJSo%YJ{Hjeu- zB*XJS1p=5F-^e0*?hTXz`=!g7`gCFjqgED`$d(Skk!aa=dGKgK*N@RFE1ooM5pK_ z?@jxsCkDosUhL&N;?`&DCEvpGsnV)Y#I{;ucy0+t4XY(?I^pIRP^`9O$Twe9`-1S) zz*7s)Jb3EhsfMQt9t|E94owR}5hE3eh8;82;lQCMLZ>EwvMZS~6FzyiM9L0{dCDSD ztt^IvQZQsXj_ri)j#PU`Dx@p{h1!r|b%lwZ3<+6T3UW1YHggg&%ZP_#cBouhcy+^t zhp|PfBncIdVB7FSl?E+;tL-F=6r%eul1PW+nASN*JRu`50ldXC#lUkJyBG72y&Q@a zxFxYC9!rv`C1`n%5$`aQ$PS352vo5QK;S{K2*G_~F@mC4f}jyJ0?CvErEN!C7Rv$n z^Caufk*xm~lGT1iJZ+SC+6m%mhnZKy#5y9XXNjo3PX5(b$-nv(iKtJq$PpH~l8GCb zxSWW}86qlUL{z@U#11ApOl&5i?<|Gn`#of_AYtq_!w$5Iod_pWM#_Xld_M%v65=#F zw$TCwOaap|jRbN}0=KpmI?Fo}BXJ)PgAu#E3p&SWNg2&?vUDYo=aZ$Vk&K3?=_=6c zh;BHJ(FGRdH-Y3Q3~MUAN0CeKQsmMb6uDFummu#^vEp8_vQMn)5tr^2Yi<&&k$M__ zsv=-Tqh3SoIylYyEo_=NqF0H_5G;iL&{CbTh&la_0MGKsnhz}1w%e29azy8$WT#_W zZH#08Yet(9vj`9T3vnmb7ELjJ7F#PGgF4z+s=z;huQVGDb3YIpkoac??*UJ>>~@ox z?}&}ad;_S}o$z<#951hl^~icfY(nrd3%(>mh z9hv*72!TBeZeU(LXavnYrqh**LRXt{Pq#)~g-RN_X|-)~-$jx5Z(y*RMV7Ki5Y+vUo@H_k{Q)4T z_HLtM5Vx#A(hhe<4W0tOBsPN!?PGzvhW3%zir_=Cru|JcAof0kcNx6RydQ~1KL^^5bV6d(>QnSlS$6os;#^%_`V9fRd;(?_BC{tgbS zBT>UKBCyGW5#O)HjR;-_^R*Z5HD{Rjl-P+P0z~{XTg?b~SE0As$+_=-mMyUC?ZQBn zZcqtS{+uHoW$sSqZWj?GHi+vHtYPAECN5xNH7;5R7xp1cS^kiOGa z-OCC^mdvsUcZzH=uZ4L{%-c+JAg^ZPQYO|gQKj-pKcy*@CTZ@ZGYlT5s!7Kv329hF z?iS4jas5HjvRiD~D$FgSb)(q0UbL+gH(mp&RNY)Itt@5=MZM_a4NyOh5Ut$Ypvazb zX-x`gYwt1E>Ic$rP1K`jd-;Y3Y4>~v#a5P2_{0Wr1&jl4l}pNjd>)725W5i^Ek6!? zDD>(GbY{v7U+`jw-PUxBcv8$mF=+hHb=WDBQVa~0OP5hled(gB_vRtQ^zE5m{myh@ z216%zix>d^qob0V)9R&isT$5dR!5@Qbl}BOIfmc}rS7DNL>$9TkR!iaE^Q!3ccgQ0 z%cU2J=|R1aDdJ^WA={JD^9S_eU|*&?UC5w`9`dI>Im?oEv|L(GmU8*-G+av!^mZ4s z`QCyKma{!{>vnr)5O1r%j`j%KF)@@@fp1)G$!weca_MrincfcZ;PkT`18_K`vLO*GgfwgX9hW|l$qv}dq8-Rl`E3?AB_&lU7^Zx5v3pY1(ZKue*&gG!Lp}=YAH5cwm zan8}mE;8bi$|n?`q5?&}9|~aTe1=5)E-`?hk3ojP%?x%O!ARtt47M@|5s*HZ6_@lj j9H%L*0%ihDgi&B=q~D5IibGg-CML>TEST>7-6-TYPECASE.TEST ;; ;; ;; Syntax: (typecase keyform {(type {form}*)}*) ;; ;; ;; Function Description: ;; The form keyform is evaluated to produce the key object. ;; The type of the key is matched against each clause to see if ;; it is of the correct type. The forms of the clause which ;; match are evaluated, and typecase returns what was returned ;; from the last consequent (or nil if there are none for that ;; clause.) ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; TYPE - a type(s) against which match keyform ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test several types" (and ; Does if evaluate and return the appropriate things? ; Check each type from page 12-13 on Guy Steele's book (TYPECASE T (T T)) (typecase 54 (number T) (T nil)) (typecase #\g (character T) (T nil)) (typecase "A STRING" (string T) (T nil)) (typecase 'symbol (symbol T) (T nil)) (typecase (list 'hi 'bye) (list T) (T nil)) (typecase (make-array '(2 3 4)) (array T) (T nil)) (typecase (make-hash-table) (hash-table T) (T nil)) (typecase (copy-readtable) (readtable T) (T nil)) ; some of the early sysouts don't have a lisp package (typecase (find-package 'Lisp) (package T) (T nil)) ; put in pathnames? (typecase (make-broadcast-stream *terminal-io*) (stream T) (T nil)) (typecase (make-random-state) (random-state T) (T nil)) ; user defined structures? ; some functions? )) (do-test "test doesn't fall into another type" (and ; now make sure doesn't get caught in some other group (eq (typecase 54 (character T) (string T) (symbol T) (list T) (array T) (hash-table T)) nil) (eq (typecase #\g (string T) (symbol T) (list T) (array T) (hash-table T) (readtable T)) nil) (eq (typecase "A STRING" (symbol T) (list T) (hash-table T) (readtable T) (package T)) nil) (eq (typecase 'symbol (list T) (array T) (hash-table T) (readtable T) (package T) (stream T)) nil) (eq (typecase (list 'hi 'bye) (array T) (hash-table T) (readtable T) (package T) (stream T)) nil) (eq (typecase (make-array '(2 3 4)) (hash-table T) (readtable T) (package T) (stream T)) nil) (eq (typecase (make-hash-table) (readtable T) (package T) (stream T) (random-state T) (number T)) nil) (eq (typecase (copy-readtable) (package T) (stream T) (random-state T) (number T) (character T)) nil) (eq (typecase (find-package 'Lisp)(stream T) (random-state T) (number T) (character T)) nil) (eq (typecase (make-broadcast-stream *terminal-io*) (random-state T) (number T) (character T)) nil) (eq (typecase (make-random-state) (number T) (character T) (string T) (symbol T) (list T)) nil) )) (do-test "test able to catch everything" (and (typecase 54 (string nil) (T T)) (typecase #\g (number nil) (array nil) (otherwise T)) (eq (typecase "string" (T nil)) nil) ; the test below generated AR 6640 (eq (typecase 'smile (readtable T) (T)) nil) )) (do-test "test function valid for keyform & return numbers" (and (typecase (* 10 13) (list T) (number T)) (eq (typecase (* 5 6) (integer 5) (float 7) (number 9)) 5) (eq (typecase (/ 5 6) (integer 5) (float 7) (ratio 3) (number 10)) 3) )) (do-test "test can return symbols and strings" (and (eq (typecase 'foo (symbol 'asymbol) (T nil)) 'asymbol) (equal (typecase 'bar (symbol "a string") (T nil)) "a string") )) (do-test "test able to return multiple values" (and (let ((casevar 'foo)) (equal (multiple-value-list (typecase casevar (symbol (values 'x 'y)) (t nil))) '(x y))) )) (do-test "test local functions valid for keyform" (flet ((retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (and (typecase (retnumber) (number T) (T nil)) (typecase (retsymbol) (symbol T) (T nil)) (typecase (retlist) (list T) (T nil)) ))) (do-test "test values stay set outside of typecase" (flet ((retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (let ((casevar 'foo)(sideffect nil)) (and (typecase (retnumber) (T (setq sideffect T))) (eq sideffect T) (typecase (retsymbol) (number nil) (string nil) (symbol (setq sideffect 'foo) T) (T nil)) (eq sideffect 'foo) (eq (typecase casevar (number (setq sideffect 'nope)) (symbol (setq sideffect 'winner) 'okay) (otherwise (setq sideffect 'lose) 'so-what)) 'okay) (eq sideffect 'winner) (eq (typecase (* 5 5) (symbol nil) (list nil) (number (setq sideffect 5)) (T nil)) 5) (eq sideffect 5) )))) (do-test "test path not taken was not taken" (flet ((retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (let ((casevar 'foo)(sideffect nil)) (and (eq (typecase (retnumber) (symbol (setq sideffect T)) (list (setq sideffect 'why))) nil) (eq sideffect nil) (eq (typecase (retsymbol) (number (setq sideffect 'nil)) (list (setq sideffect 'he)) (string (setq sideffect 'foo) T) (T 'everythingelse)) 'everythingelse) (eq sideffect nil) (eq (typecase (retnumber) (number (setq sideffect 5)) (string (setq sideffect 104)) (symbol (setq sideffect 65))) 5) (eq sideffect 5) )))) (do-test "test the first test created" (let ((a-string "foo") (an-atom 'bar)(sideffect nil)) (and ; Does typecase evaluate and return the right things (eq (typecase a-string (symbol (setq sideffect 'lose)) (string 'win) (t (setq sideffect 'wrong))) 'win) (null sideffect) (eq (typecase an-atom (string (setq sideffect 'lose)) ((or number symbol) 'win-again) (otherwise (setq sideffect 'wrong))) 'win-again) (null sideffect) (eq (typecase a-string (symbol (setq sideffect 'nope)) (number (setq sideffect 'wrong)) (otherwise 'right)) 'right) (null sideffect) (equal (multiple-value-list (typecase an-atom (number (setq sideffect 'nope) (values 'ouch 'ouch)) (symbol (values 'right 'again)) (t (setq sideffect 'wrong) (values 'oops 'twice)))) '(right again)) (null sideffect) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1492a14c334c90bc601e33c8f8ab8333209690d7 GIT binary patch literal 2889 zcmb_eU2GIp6uvXt(xv}h3R`GXr-fo%yEO&mr67uH*%%E%+C+Wufv67}O-MA+Clh1#%?D%fo_lv`OGzPwZ0?+U z&bjxT@7#0t+*?4^FUJx>EIU47*+x#t=G}?BD;&<|1Sgx%r48XQkqf6{iYmReON{OA z+umQR&C{fFM#?qD1U+v!W2uw9LjN{FoXA-=nQYxk*v$i*HVtfizOQyr)Dq0vL-%YM z*tl_^zrU~c?)58Na~2_#MzcVcBh-un$iL_{M|4Tkql58;6qUshDdHD=FGymECN)X* zy_OAvo1KW-#&N@jaK;_PA>?21f`dsprpFc8zr;;(_5OLUAudPvkkG^-3Gu@}+rmn7ffdZ`>N@M?2TFaMjk$BM5~~*R*oxjTxED zONHGZ$X_E=Fwe-tJl8;G)8SD8cEboFRFBZCmF}jIRSbSrFfAR94^mS z&^45SQIOQ*+jf)PR4NXXnYH%XQt{a`v(8>uDt0iOWL?4ZD)V&}kPBcwenNPyg0Sw% zB!vI9Vz9mv>m}1%^FB)jsS;A-ptw!qlN%qbdP1=U&Q_q*QYa=A1}y~ZK*%Z;cPj9G zfr`!%d_>JqmWn+r>&14eJY!cAogKErrOQglt}a29u;08|dHf_)1uH-s7Xp2k0G%~S z&9*Bc@?A;MykmzCgbL<+3i(VuLej{_RS)`K7R+X=8S#z&Wv?R=Q{!G#y{aV=6ZP1xs4D46mGqhzZC1;)eVQ(f z@Z91Rx)Q;4fhN2>&`kPMV?R0 z!L5YwUr-_c85Qy$GvO(6bTzMy>`lZqaLT_481{;Zq@)3R5U&KXAFl$^%Pc&@EUcy$ zxI0wH{X&J@w@kQ=2{$w0dMZTMs1W&7h|b~GVH_I5E4JX)^~8GM8{)c}o)>Vp$VISB zhQmkzJB{0b#BdnMcE&x&NRS*xU{F!+-7j!6z%san0y{(%uOS@&ABI!r|H17*u2M_< zMQVaS!$_X#a%|-*jEpj26WdTjS91R{GDC&j=ZyP=k#;5wF)ly}Vs6o2)EN4ckvoih z&&X}uK8eG}aobVc7RBKn+_oCGbwMC^e6Pzj99Nh~xu%fGx`LZJW@LmDDQAv@g+Ke= zQ#vf{o)o)`cmn723%2fz6P@DcW{}N9QuQR4f zqAo@6tF%O1msByK;W}7Gvi4F^(IpynV4v^xQmDsMHhFLej^P3Tc0u!XS`*|^ z#4v#EPnnBJ*xNymn@_{Mo#lA=A+9$qcHQH9Pt!p2)Nv+1e#pot!$=@8fs|0Fo&od5+LfMh|tW^h|rBC5uuM3AwnPe-fD{IL^gL!IAUas rT*`&x03q>=F5pge;kFoQt8|NFjYGoIDaUYL#GTy2W$5ajyLbNwFW5$D literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST new file mode 100644 index 00000000..0d0ea169 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unless ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 115 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 10,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ broke up into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-6-UNLESS.TEST ;; ;; ;; Syntax: (unless test {form}*) ;; ;; (unless p a b c) is exactly equal to: ;; (cond ((not p) a b c)) ;; (if p nil (progn a b c)) ;; (when (not p) a b c) ;; ;; ;; Function Description: ;; First TEST is evaluated. If the result is not nil (T), ;; then no form is used. Otherwise the forms are evaluated ;; sequentially from left to right. The value of the last one ;; is returned. ;; ;; ;; ;; Argument(s): TEST - a form which returns nil or non-nil ;; {forms}* - a sequence of lisp data objects ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test simple cases" (and ; Does when evaluate and return the appropriate things? ; Check just boolean values (unless nil T) (unless nil nil nil T) (eq (unless T T) nil) (eq (unless T nil nil T) nil) )) (do-test "test work generating test" (and (unless (> 0 95) T) (unless (> 0 95) nil nil T) (eq (unless (> 0 13) T) T) (eq (unless (> 0 13) T nil nil) nil) (eq (unless (> 10 6) T T T) nil) )) (do-test "test local functions for test & returning symbols" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and ; check symbols (eq (unless (nill) 'foo) 'foo) (eq (unless (tee) 'foo) nil) (eq (unless (nill) 'bar 'bar 'foo) 'foo) (eq (unless (tee) 'bar 'bar 'foo) nil) ))) (do-test "test returning numbers" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and (eq (unless (nill) (* 3 5)) 15) (eq (unless (nill) (* 3 5) (* 5 7)) 35) (eq (unless (nill) (* 3 5) (* 5 7) (* 9 4)) 36) (eq (unless (tee) (* 3 5)) nil) (eq (unless (tee) (* 3 5) (* 5 7) (* 9 4)) nil) ))) (do-test "test using numbers and symbols for true" (and (eq (unless 5 T) nil) (eq (unless 5 T T) nil) (eq (unless 'hi T) nil) (eq (unless 'hi T nil T) nil) )) (do-test "test passing back multiple values" (flet ((nill () nil)) (and (equal (multiple-value-list (unless (nill) (values 'foo 'bar))) '(foo bar)) (equal (multiple-value-list (unless (nill) 56 'Hello (values 'bar 'foo))) '(bar foo)) ))) (do-test "test values set in UNLESS, still set outside" (flet ((nill () nil)) (let ((sideffect nil)) (and (eq (unless (nill) (setq sideffect T)) T) (eq sideffect T) (eq (unless (nill) (setq sideffect 'foo) 'bar) 'bar) (eq sideffect 'foo) (eq (unless (nill) (setq sideffect 5) 23) 23) (eq sideffect 5) )))) (do-test "test path not taken was not taken" (flet ((tee nil t)) (let ((sideffect nil)) (and (eq (unless (tee) (setq sideffect T) nil) nil) (eq sideffect nil) (eq (unless (tee) (setq sideffect 23)) nil) (eq sideffect nil) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL b/internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..74efc0cf69f913e0dafccb88036a4553c374d0e9 GIT binary patch literal 2929 zcmb_eU2GIp6uvXl(*Jh56k6J*4h8zKVX9DmN+mJFGNoI#GdMd-1r@U0PMyK&PTiRW zi4htSg~Tzi6mYJHFUBWh0!@q}N{z+`5~J}!BMFHn8ee>{FZx7+=ib|umXe}`?A|%| zoOACv-}#w4w}{H0i6_OlJ3e7MW?pm){zSnS$K1T=xrKbz6vsd=z7p4T<<$W>zPtO$ z4b`c6nrz<8_~xi+6ijb4b9BA9VVfvVD#oauV-_2b-$cSGHVaqv$e0M zr?02CyZX+h3tYrS2xZX>Ayo)PkbuIoK_q4Jq#K* zioQD`Ip$&0A>oXBh(jnm6IAx6)wq$+)NqQM zEz`rt zD#HIp>CexPaFv?x4R0Ge}7Gl5^UUelta7aj}%HmVKBnlprb}Ad*poJ5LL+RbjmhdhiON$k4Chp1@4d%e zgMbh&BZpi&Ik$cVOUwE-eMmM4`wQ_JPwTp(&O1agM|9tTuIX;TaXF_op+fFs#(ls@8xuwuCs2a^qE^r!jQq~X zO-8 z$;zL?;4y=&>^vrSienkL8H|c{j(yaL?ASW8?Dz#FSP>KkWojasgtKg}56O(^?eJna z#Y6f!;<_RmigZt}B@>3C%gGe3AYfQ!(crHdpP63jYITIpCIsj+i@rZ z7Z}eTHAQz!JYtzS;%_hR0K)$Wu;7Ib1Hn*~MX2~MC@Q=feBw@4jw@lXnmWsjz#YhU zAw!-gju#x?o&W)ZKumwgJRB!`+iAY}Q8I61Mc%!%=go^fcZGpSJ?GqXMMqdy62Ub78QSWeIvk94Xk& zD9ig;-W`XmmGT97L1%D>zR*HE3|7(ICML>TEST>7-6-WHEN.TEST ;; ;; ;; Syntax: (when test {form}*) ;; ;; (when p a b c) is exactly equal to: ;; (cond (p a b c)) ;; (and p (progn a b c)) ;; (if p (progn a b c) nil) ;; (unless (not p) a b c) ;; ;; ;; Function Description: ;; First TEST is evaluated. If the result is nil, then no ;; form is used. Otherwise the forms are evaluated sequentially ;; from left to right. The value of the last one is returned. ;; ;; ;; ;; Argument(s): TEST - a form which returns nil or non-nil ;; {forms}* - a sequence of lisp data objects ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test for the simple cases" (and ; Does when evaluate and return the appropriate things? ; Check just boolean values (when T T) (when T nil nil T) (eq (when nil T) nil) (eq (when T T nil nil) nil) )) (do-test "test when build test from a function" (and (when (> 5 0) T) (when (> 5 0) nil nil T) (eq (when (> 5 0) T) T) (eq (when (> 5 0) T nil nil) nil) (eq (when (> 5 10) T T T) nil) )) (do-test "test with a local function, & able to pass symbols" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and ; check symbols (eq (when (tee) 'foo) 'foo) (eq (when (nill) 'foo) nil) (eq (when (tee) 'bar 'bar 'foo) 'foo) (eq (when (nill) 'bar 'bar 'foo) nil) ))) (do-test "test with a local function, & able to pass numbers" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and ; check numbers (eq (when (tee) (* 3 5)) 15) (eq (when (tee) (* 3 5) (* 5 7)) 35) (eq (when (tee) (* 3 5) (* 5 7) (* 9 4)) 36) (eq (when (nill) (* 3 5)) nil) (eq (when (nill) (* 3 5) (* 5 7) (* 9 4)) nil) ))) (do-test "test non nil acts at true values" (and (when 5 T) (when 5 nil T) (when 'hi T) (when 'hi nil nil T) )) (do-test "test able to pass multiple values" (flet ((tee nil t) (nill nil nil)) (and (equal (multiple-value-list (when (tee) (values 'foo 'bar))) '(foo bar)) (equal (multiple-value-list (when (tee) 56 'Hello (values 'bar 'foo))) '(bar foo)) ))) (do-test "test values set in still set outside of when" (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (when (tee) (setq sideffect T)) T) (eq sideffect T) (eq (when (tee) (setq sideffect 'foo) 'bar) 'bar) (eq sideffect 'foo) (eq (when (tee) (setq sideffect 5) 23) 23) (eq sideffect 5) )))) (do-test "test path not taken, was not taken" (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (when (nill) (setq sideffect T) nil) nil) (eq sideffect nil) (eq (when (nill) (setq sideffect 23)) nil) (eq sideffect nil) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST b/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST new file mode 100644 index 00000000..cfbc9f8f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: block ;; ;; Source: CLtL Section 7.7: Blocks and Exits Page: 119 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 13 ,1986 ;; ;; Last Update: Oct. 13 ,1986 ;; ;; Filed As: {eris}cml>test>7-7-block.test ;; ;; ;; Syntax: block NAME {FORM}* ;; ;; Function Description: The block donstruct executes each FORM from left to right, returning whatever is returned by the ;; last form. If, however, a return or return-from form that specifies the same name is executed during ;; the execution of some form, then the results specified by the return or return-from are immediately ;; returned as the value of the block construct, and execution proceeds as if the block had terminated ;; normally. ;; ;; Argument(s): NAME - a symbol ;; FORM - a valid lisp form ;; ;; Returns: anything ;; (do-test-group (test-block-group :before (progn (test-defun hairyfun (x) (list x "hairyfun")) (test-defun fun (x) (typecase x ((integer 100 *) (return-from fun "x >= 100") ) ((mod 100) (return-from fun "100 > x >= 0") ) (t (return-from fun "0 > x") ) ) ("wrong!!")) )) (do-test "test block - test case copied from page 120 of CLtL" (and (equal (block loser (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) (hairyfun x) (return-from loser nil))) '(23 24 35 36)))) '( (23 "hairyfun") (24 "hairyfun") (35 "hairyfun") (36 "hairyfun"))) (eq (block loser (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) (hairyfun x) (return-from loser nil))) '(#\q 24 35 36)))) '()) (equal (multiple-value-list (block loser (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) (hairyfun x) (return-from loser (values 'multiple 'values)))) `(t nil t nil))))) '(multiple values)) ) ) (do-test "test block - the body of a defun form is a block construct which has the same name as the function" ;; ;; fun was defined in :before section ;; (and (equal (fun 150) "x >= 100") (equal (fun -9) "0 > x") (equal (fun 87) "100 > x >= 0") ) ) ) (do-test "test block - block construct returns whatever is returned by the last form" (and (eq (block name1) nil) (= (block name2 (1+ 99)) 100) (equal (block name3 (append '(2 3 4) '(0 9 8))) '(2 3 4 0 9 8)) (equal (multiple-value-list (block name (values #\a #\b #\c))) '(#\a #\b #\c)) (equalp (block name1 (concatenate 'bit-vector #*0000 #*1111)) #*00001111) (equal (block name2 ( (lambda (x) (cons x x)) 9)) '(9 . 9)) ) ) (do-test "test block - nested blocks" (flet ((fun (y) (let (temp) (block outblk (setq temp (mapcar #'(lambda (x) (cons x (block blk (typecase x (number (return-from blk '( is a number))) (list (return-from blk '( is a list))) (string (return-from blk '( is a string))) (t (return-from outblk "wrong input !!")) )))) y)) (if (null temp) (return-from outblk "no input")) (setq temp (cons "Results:" temp)) ) ) )) (and (equal (fun nil) "no input") (equal (fun '(1 "fg")) '("Results:" (1 is a number) ("fg" is a string))) (equal (fun '( (2 3) 100 20 "fgh" "as")) '("Results:" ((2 3) is a list) (100 is a number ) (20 is a number) ("fgh" is a string) ("as" is a string))) (equal (fun '(#*0101 3)) "wrong input !!") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL b/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e334df320169820f3f518950460d2efda42eaa1b GIT binary patch literal 8289 zcmcf`ZE#yh@!p3%?AVGED~_TBgXLx<1WQFG~BO4p|usNJ9f9U z>~7w^wKCv~hq<&H^6cE*+_JlI+t$jt^HV}imJrfI3J59)sUZ?E#`84|2{oSZ27+PL z8}&uh2IGv8x5HSx$+#Lb@~fJZTz1H-ryoe`IGlkIA`oJn&f5dYs6P?ZqQ-=9T&OZm z<*S2HZ#N9h*P#;8UX+5;1tY(5r+23}rY4fHs5cPPBINv3?HD0;eUOlipI|z@l)2a? zTo@$ZyVND#+vHv)Sanes=VrF+PTe^-b4P#wJ2RUI#5C;-Em>9zN^m;&sCR1s3>@7YnRkFd|w z$DRRE`U-u;+)Qg`JTu*Nn2FZKt3^0BsB0c3yF(bXj7va%HBc1S?(^-9>b$1T9<^+$Mh8 z0{&V7utoB<3ur`g?9HEFNjC?x0_QVx&;{@S3EpwC=pgg@+b7_u@ z8=Qwx9>K|&&4z(4IIeXs&}EC@KZbGp>0~-~??Ju&NXnnxe~dhH3Rj zG>-`M(^vW21Q@>p{2pK!*OXIGI=HEzZ5r1$eNl5wZxpb_(_C|=|9Iwc&7-;8IKzqv zJru37cmYGB%Zw|oVq9^3;J9MBVvcY%dX4UcVIF20=+)QWo%s+mgR!qN2eUR4y5=N>!?+(Kfs=%sqN5O+<+J#Kd%fX)YJb%1(uMti%Ob!> z7d40D{G!^t^W1p2OLq*01ABx03z-@sx{R~=4Gn%R+8)Hr#oOtNwujZ2w=D>mXh*z3 zTuUp&I(XJVYUJdpkw2{ZqRDP=K#N7<4O9@F&|VAAYIq#*RKl|Yo@#h1;IYGFg~tLi zRyFv234f=V`gHqQer1jCk0;cKD3ntqv<6xwt)mr^8&WDqgBpuzF|U?PbSD!H(t2R1 zYVbw(dl??pG4iV$8?VpN)=7j=88fp0W?6k8N>=ajg|V^^DpnkfFM-u0>fletVrsM` z4Wt6LsnF(JFqhvKS9!;@3Yu+iP$z=d=o$o9XdQxnj_l*edpObyhOdpQiGVla^T#x= znL8rGt37?gqGjZ4?&ydtE|oPIBT;!!rJ7w z8B+ceL&{e((v1inqY8qf9Qgo84j@NZjdmnDv2iz(D(&P_>zP#XuZ&Ur17j55V2t7gj{FWs zev>1gqPKt)G0UWgI+G$EU{Zvq7*cqWA%#;MnPTk1eT-e$%WF~8i4PZ~30pYht(>uz zF_KdZN%C~f=V@IRGN^l#zHoOdaM(W$bxU_l>xg1)H(iII5l$f1C^|9o=}mMqU~S)H zjkXtf?HLZbII@k`nmK3y&t92+Xec$<>rMDN+O+oljq@iTJhPyZ zt=~qs#z0Z~UL)_xrAKnga5^_SJm~Ek&JHO3gGw&-nM2v$qm4=2D~AdR?VIOp~{BQK8Ru(aBkkgJ`nYUHK9;WQ%cC+|l9u}~I7iB)XZro7Y51DON%x_z*+%YvNZz6UN{_@wK@u8HY>?o2+fMV3_GO2 zHhl#)8;Mqm0(F2Y5bb1GNGu>56QYr~1R?szp+yZRgacF&YQRKtN7MEl$K`#XDH<#o zr}Z%RQdCPoRq(NzHJXgHsj=26QrkHzqQ;mLbk54K!_^Rj$=C(wb3CBi{9!GgjH$Q_ zh$}%xO%%4gu;%xLi`x;cva{F}#kki*1T+%8lio$|rXMF;ro>NzRp3Cbzt}m82}9;m z=H;%_4^KCB37BX)c&0qAIr5qVv~hQ$A*bChhbJS^EtgJ2Gwx4a>=Iv^{@IwV8Vm$l z9`2mAI|@u!Q8dki<8FnsH=%9pD&bz*F5t#!i6@eQ0IesamhO;RK+_t(7U_nIigs^t zXq#wA0DQ%P?nJCJ8SUB*Q*C?OIEO|a&wKna6(YI!x(zH0#*g{Jaasjr^mgX9w%^>y zCAXpItCWGS8xz$=-qxEPOe?qC0uGmJg1O8!Zo}d(e6`|hC%(4hs|8=p_(IRNot?tn zRdAt0bvg;Z{>U)j6U)2|y>YSME#-;V(^QvnRh3~JWtf^W%<3|XvkX&LhH;f)++~;z zWf%{xC)oi@2dBSwapr`VMvxg9dF7Cv?Kz@!G&Q$iG$_w~AoVG_5+N(m&hivt>k_

te5b}>H;=%QHy%6ToC4yRU^%VuVi-OQK zn2sJblKd^?(DM9_ zQvPjA@;8(2d4pAzkT;il9yi$C%Xj1{UbotHY0iC4v=We zu~1IKC4u^ok@uG64tUKzkm?!ED!u8x{z1G(=Q*9XLqj?D8TqZd+f+F8sQeC_UCc8v zEV(eVievF&p0O3VHcm0WdlO^pzLIFw=@enBBL&#A*p>%ykLW%Ek->2Rc1&0l@P;3T ziv_@O@D9Q~0LwMl1;IiIt_!gB#SGhOL#M~OrV}AS$Sj0*=r{-@Awd*F;(08Ig1`kl z1~urISJ+J>+`qWpm%1jyku4WbL^AFJFNMSxr=JaiM7)@oe=q`W&{G44dQ(fsQ|qGC zrRu{UE*`WX`8M*kW>t;e6O3um2%I8ibcXL@-WpTelYTr(k>{y$3t~FdD4gHcQN)eo zA(A`|=oKYj1`ubk_6aPWgiNL~7=`mXq%G_iaRlXreQjzu9-+5~V5^W|wrPC_;N<|E zb)vyDJI$0|xdjSPu=iWx;R@rSdHaB7(^F1eX2Dc-nx30kkG?VSqhO2n;+y$bHZ^b9dAs zf%K>IQkS})<6wk-Uwdp1t8va|VdqmhwF6^19Mb`{M*&Sr=>8^oW z5J*3}eX+PI!q!++3N|}A;R}Z4HOyq~!9bvf$sDf$L`6i!q|+M=$kYuRBPiiZz$Y9c zq3XwJ$aY;C)&zK)gKK=YXl`!+k8ieWt~om`{oBabckAiYNLqnZsveI6eEBNJeCUcP zg{@Hh=mf0RUzf0cqbx93&l-96l7Rt_jtwZ_49niE5DY3(Bfa-OnEvcTJ&3;-=Au}{ zoE#but3eUSum~wM93IBz;17pvy|uh|ICiXCws+*IVVzrEzpiu3ujf0r{9?Xy%PaGp zTYkVgm$75ZQ)L}nCSdh0*>Ss;2u9R6vYldm%YQH9mftk;>zCm+uO?pO%+G)tcAJC| zQ9c6sFQIqCq7vF@y@aqGjwb+AT5m%L%Mn2*t;dxm_X4vliJ0}uw;K~yIEl#?E7mH@ zbdugP@~&lc!fBNL%@mS;1WIr@HhV=iHcS{37KXt}Te)CJz}GG#7&$)5cml>test>7-7-return-from.test ;; ;; ;; Syntax: return-from NAME [RESULT] ;; ;; Function Description: return-from is used to return from a block or from such constructs as do and prog that ;; implicitly establish a block. The name is not evaluated and must be a symbol. A block ;; construct with the same name must lexically enclose the occurrence of return-from ; ;; whatever the evaluation of result produces is immediately returned from the block. ;; ;; Argument(s): NAME - a smbol ;; RESULT - a lisp form ;; ;; Returns: anything ;; (do-test "test return-from for BLOCK - the name is not evaluated and must be a symbol" (and (= (block abc (return-from abc 2)) 2) (= (block |m & m| (return-from |m & m| 20)) 20) (eq (block nil (return-from nil t)) t) (eq (block t (return-from t 'hi)) 'hi) (equal (block first\ name (return-from first\ name '(first name))) '(first name)) (equalp (block 3.14159\s0 (return-from 3.14159\s0 #\p)) #\P) ) ) (do-test "test return-from for BLOCK - whatever the evaluation of result produces is immediately returned from the block" (let (a) (and (= (block blk 2 (return-from blk 11) 22 33 44) 11) (eq (block blk 2 (return-from blk ) 22 33 44) nil) (= (block |abc| (setq a 0) (incf a 2) (return-from |abc| a) (incf a 3)) 2) (equal (block \@ (setq a nil) (push 11 a) (push 22 a) (return-from \@ a) (push 33 a)) '(22 11)) ) ) ) (do-test "test return-from for BLOCK - be sure multiple-values are returned properly" (and (equal (multiple-value-list (block blk1 (return-from blk1 (values 1 2 3 4 5)))) '(1 2 3 4 5)) (equal (multiple-value-list (block blk2 (return-from blk2 (values-list '(5 4 3 2 1))))) '(5 4 3 2 1)) ) ) (do-test "test return-from for BLOCK - nested return-forms" (macrolet ((fun (x) `(cons 0 (block blk0 (return-from blk0 (cons 1 (block blk1 (return-from blk1 (cons 2 (block blk2 (return-from blk2 (cons 3 (block blk3 (return-from blk3 (cons 4 (block blk4 (return-from ,x 9))))))))))))))) )) (and (equal (fun blk0) '(0 . 9)) (equal (fun blk1) '(0 1 . 9)) (equal (fun blk2) '(0 1 2 . 9)) (equal (fun blk3) '(0 1 2 3 . 9)) (equal (fun blk4) '(0 1 2 3 4 . 9)) ) ) ) (do-test "test return-from for DO" (and (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return-from nil (values-list b))))) '(0 1 2 3 4)) (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(0 1 2 3 4 5 6 7 8 9)) ) ) (do-test "test return-from for DO*" (and (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return-from nil (values-list b))))) '(1 2 3 4 5)) (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(1 2 3 4 5 6 7 8 9 10)) ) ) (do-test "test return-from for DOLIST" (let (a b) (and (equal (multiple-value-list (dolist (y '(1 2 3 4 5 6)) (push y a) (when (= y 4) (return-from nil (values-list a))))) '(4 3 2 1)) (equal (dolist (y '(0 a b 3 d e 7 g h 8 ) b) (if (numberp y) (setq b (cons y b)))) '(8 7 3 0)) ) ) ) (do-test "test return-from for DOTIMES" (let ((a 0) (b 20)) (and (= (dotimes (x 10) (incf a x) (unless (< a 10) (return-from nil a))) 10) (= (dotimes (x 8 b) (decf b x) ) -8) ) ) ) (do-test "test return-from for PROG" (and (equal (prog ((a 1) (b 2) (c 3) (d 4)) (return-from nil (list a b d c))) '(1 2 4 3)) (equal (prog () (return-from nil (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) (do-test "test return-from for PROG*" (and (equal (prog* ((a 1) (b 2) (c (+ a b)) (d (- a b))) (return-from nil (list a b d c))) '(1 2 -1 3)) (equal (prog* () (return-from nil (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) ;; [Masinter] 4-Sep-86 ;; at AAAI, James Meehan of Cognitive Systems mentioned that this definition of TAGBODY uncovered a serious bug in ;; the Lucid Common Lisp compiler. Can anyone turn this into a test case for return-from? ;; (do-test-group ( "test return-from for macro defined TAGBODY-GO" :before (test-defmacro tagbody1 (&rest rest) (labels ((parse (tail &aux (rest (member-if #'atom (cdr tail)))) (if tail (cons (cons (gensym) (ldiff tail rest)) (parse rest))))) (let ((name (gensym)) (bodies (parse (cons (gensym) rest)))) `(block ,name (macrolet ((go1 (tag) `(return-from ,(car (find tag ',bodies :key 'cadr)) nil))) (labels ,(maplist #'(lambda (tail) `(,(caar tail) () ,@(reduce #'(lambda (body tag) `((block ,(car tag) ,@body) (return-from ,name (,(car tag))))) bodies :initial-value `(,@(cddar tail) ,(if (cdr tail) `(return-from ,(caadr tail) nil) `(return-from ,name nil) ))))) bodies) (,(caar bodies)))))))) ) (do-test "test return-from in tagbody1 0" (let (a) (eq (tagbody1 t1 (setq a (cons "t1" a)) (go1 t33) t2 (setq a (cons "t2" a)) (go1 done) t33 t3 (setq a (cons "t3" a)) t4 (setq a (cons "t4" a)) t5 (setq a (cons "t5" a)) (go1 t77) t6 (setq a (cons "t6" a)) t7 t77 (setq a (cons "t7" a)) t8 (setq a (cons "t8" a)) t9 (setq a (cons "t9" a)) t10 (setq a (cons "t10" a)) (go1 t2) done (setq a (cons "done !!" a)) ) nil) (equal a '("done !!" "t2" "t10" "t9" "t8" "t7" "t5" "t4" "t3" "t1")) ) ) (do-test "test return-from in tagbody1 1" (flet ((fun (items elt) (let (a) (tagbody1 (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) x (progn (push x a) (go1 lose)))) items) ) lose (nconc a '(is not a number)) ) (equal a (append (list elt) '(is not a number))) ) )) (and (fun '(1 2 3 #\q) #\q) (fun '(10 20 "st" "fre") "st") ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL b/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bf9496a1d4e86971f1bbc380ed4972733effd05a GIT binary patch literal 4040 zcmb_fZERat89w*RA4$CB!@Xs$m)^BnVbn0G0A49_PevEF&spvn3HVHB`gg^p`KS)SJ{R4=|yze=7 z?8Tj!P!b=%=REJ%^PY3=IoC@>`f5C>#BAX2rG-niJ!7R*7Ek3Lqd{T+c=QB2Ro_GR=j}HzE3_f;f zf5&hvon+Der_W(<7#ujbzoT~J8rPj8giMn)6n;Xwi9np?Qg_5q(?)bSkyN8vY)p+f zOHRoLwL~Y&wm>*SoR>s;oX_3qaR>Am0$an{YM2K|qhj(<)O&GyCnruPA8a^~{<QLsFMS?iO5>(Kb$mWdJ6 z#>52Xs@9~urrCkos%3@B`*ax=!Io++?LfcWr^}iZf}MtTr`N0HbymfJIRLDxE`zV5 zvDGUFHC?90fS+CmgYuv2MQji8jRx_q&p;g6wvcZS-`{j?sdB6FU$&FCxZdF1VbKZ4 z;FIAsYqEb$4=?NCi#YiYa5(IT=TGmq#oEjDNxh_pd9W>i#O8gN`u2lw7>t+o{wvU% zRMvE5Sy#TJ%jMl1YQm3oFTnxwvL4pu5G;h=&qMU`2km8{Qf6n%6%Ozd@%%_WV zzEN8b?g%?roum2fz{Z`*{kp7&aUb9|*|_u41zoi<81J&TPw>Vw?b z+P39}Q(V5=@xNqsXSxaB=Ugp?BXM0DO5i;e9gS&2Ni`KcngB!_Nk{lz*U$Gr>wwk; zEdb3A%?Hg3O@b!ECD{{+$Bg)B{Q`@Q$LTHUNk5Y|)G?lGw=ndG+bINHzpw)?#(N@a zDy65Q`h+n)VMGKO9J(Sg?U^XW(-9YL$limGY`tlN0wJ!5_v-*&m}v;*8P-!{F$0I= zm^MCEIFa3qjgMRnFN+eV3~xg zSX^v;T-AoaPq^gDC@#7?QCRNhP@H7o2?lEDkyN!2V-%JBl#Z~A(h)i-9sVQg$iGh= z`S++J{{{npz`)lSc-6fRqVOh-!k?m1_!N!8B`L@yD9Am@z;5c!bx?PX&=J`{POMyr zMn0sDpzkF%y^F`w{#S(;Z^qLsW>X6cjJB(YL7(SQLRp5m*#~qn7-?s0sgfCPo?f z6*d~6f;&J#?(=N4iwg2{3X(D#{m2a;c6S|c!+YKE5v(KWly(%&LQ%<^#fAJC`er&4OH%VF}6pUoq|{886^Wo_|A;jiw~mNeNM?gRhaq4bLO|cIgLQCQxfXk zd!P#nL<7(TGwc#)MdbJkHTV-?Ed9xO#aZFu;pmU2RM_~@Ezd|YVW_ECGVOMv8LZAz z6S|?&%A^mRQt)mSVBGiI-6(EsAt+tjBq%L!5|qBbNl>~-35t~5DN4?L5K_DQSkAOl z+PO97kZvT#)HLSPXq)8;9{FU0Pxiv zk)!UQfO5zkM4`HaUX&wjIO-1iFu(x_CJH$qr{ ziiuRFikaLQB{vIX3P2I5%q&a;!3=z|S#u@>9`<6B>uf%krS7Nf-1KQ+OnyZflk4!* c$equAlF-;)9v`-Tk0jjP+$W96^<1s?UvTr2f&c&j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST b/internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST new file mode 100644 index 00000000..494b6a41 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: return ;; ;; Source: CLtL Section 7-7-Blocks and Exits Page: 120 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 13 ,1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - changed = to eq in first test since = expects a number and was failing on the SUN ;; ;; Filed As: {eris}cml>test>7-7-return.test ;; ;; ;; Syntax: return [RESULT] ;; ;; Function Description: (return form) is identical in meaning to (return-from nil) ; It returns from a block named nil. ;; ;; Argument(s): ;; RESULT - a lisp form ;; ;; Returns: anything ;; (do-test "test return for BLOCK 0" (and (eq (block nil (return t)) t) (eq (block nil (return)) nil) ) ) (do-test "test return for BLOCK - whatever the evaluation of result produces is immediately returned from the block" (let (a) (and (= (block nil 2 (return 11) 22 33 44) 11) (eq (block nil 2 (return ) 22 33 44) nil) (= (block nil (setq a 0) (incf a 2) (return a) (incf a 3)) 2) (equal (block nil (setq a nil) (push 11 a) (push 22 a) (return a) (push 33 a)) '(22 11)) ) ) ) (do-test "test return for BLOCK - be sure multiple-values are returned properly" (and (equal (multiple-value-list (block nil (return (values 1 2 3 4 5)))) '(1 2 3 4 5)) (equal (multiple-value-list (block nil (return (values-list '(5 4 3 2 1))))) '(5 4 3 2 1)) ) ) (do-test "test return for BLOCK - nested returns" (macrolet ((fun (x1 x2 x3 x4 x5) `(cons 0 (block ,x1 (return (cons 1 (block ,x2 (return (cons 2 (block ,x3 (return (cons 3 (block ,x4 (return (cons 4 (block ,x5 (return 9))))))))))))))) )) (and (equal (fun nil a b c d ) '(0 . 9)) (equal (fun nil nil b c d ) '(0 1 . 9)) (equal (fun nil nil nil c d ) '(0 1 2 . 9)) (equal (fun nil nil nil nil d ) '(0 1 2 3 . 9)) (equal (fun nil nil nil nil nil ) '(0 1 2 3 4 . 9)) (equal (fun nil a nil b nil) '(0 2 4 . 9)) (equal (fun nil a b c d) '(0 . 9)) (equal (fun nil a b nil d) '(0 3 . 9)) ) ) ) (do-test "test return for DO" (and (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return (values-list b))))) '(0 1 2 3 4)) (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(0 1 2 3 4 5 6 7 8 9)) ) ) (do-test "test return for DO*" (and (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return (values-list b))))) '(1 2 3 4 5)) (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(1 2 3 4 5 6 7 8 9 10)) ) ) (do-test "test return for DOLIST" (let (a b) (and (equal (multiple-value-list (dolist (y '(1 2 3 4 5 6)) (push y a) (when (= y 4) (return (values-list a))))) '(4 3 2 1)) (equal (dolist (y '(0 a b 3 d e 7 g h 8 ) b) (if (numberp y) (setq b (cons y b)))) '(8 7 3 0)) ) ) ) (do-test "test return for DOTIMES" (let ((a 0) (b 20)) (and (= (dotimes (x 10) (incf a x) (unless (< a 10) (return a))) 10) (= (dotimes (x 8 b) (decf b x) ) -8) ) ) ) (do-test "test return for PROG" (and (equal (prog ((a 1) (b 2) (c 3) (d 4)) (return (list a b d c))) '(1 2 4 3)) (equal (prog () (return (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) (do-test "test return for PROG*" (and (equal (prog* ((a 1) (b 2) (c (+ a b)) (d (- a b))) (return (list a b d c))) '(1 2 -1 3)) (equal (prog* () (return (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL b/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..22a10022059c9cad9e4b9ba2c18b682b60c368ba GIT binary patch literal 4914 zcmcIoeN0=|6@T}>XJZIB#(6;Me7(_xE-ucRgcbtp65~8D!T3?zgk);Pm~mn!#%9Je zs;X8b%|4_)5r|d#?y5}tW16)8EV@m~n#rp+siK;cKlZ6g)wEXaKK_`Hs(ol%m7R01 z4R#zYRkKOHKKGt`?zzA7anHT>iex(z2x)=r>|83H$Z6Sy{M{;i0Cf_{ejU#1BaWURWtEiVmhCg(P9gU`I+hGy0yc{H2+*Km4;4V9}J)9@9F73 z`uL%yA%8R^wB2`2Z~xIJ`j7M+YPxe{mAJB!B*mo?l152#NwQ>JH(lPC9*y~iMnbwT z>>ty;){131z!u*`RF7C@>k%!Vo%5v=&nD7n&g{HIB*|Jf9YYi0Ky1VaTLrR6nyqVQ z%ShNa4yO5sb%{F4T2MQ&%$8nXpYO0QWEkVpjaBCrNwOcyNYcJ9ayV}!Z;g_h8Oi+d zD4qPQrbxrV)7R7+*cYrBzbenSu&h3+*k=+Gn_w_q?P2? z4d*B&Ezm7?OnPxCHislNOHwHn@2=j8L@HZ3lAsC&r`&?5CBwbeVYtauJM<{9jdsK7 z0jZZ@zstq>ae=Y7bRK7%|Q=p=}r1(BeZM<3*MjL9a07*2I zTcMV%P(QI1w54K2GlDtwvFhM9K&PeBX)b~Oi|A_;Ah-f%+ToIDCniW$;w z@O4W#kFB!uw|v2?<%RX;Jy>$dxr%u_M<5zXB^vg7M1x}iUn{&*n;#Ddr(Ld8WF{nd<(;nX3Gtf`pf$@>v7Vh@Sh&`AKZRrZ|RxA`30r^Ed-|n>XQNeH* zcNlKrI>UYOmoQoU1LEwhREO@g-B3STe#uZlvg~9-1xdA3{4j0*zf}f%xB}aqguM`U zIRgNB!v>bN_JYw~Y=fa=W2&oUbX_;PuEMBsqhc06Iu*0thE;2Wm6Hbck)y5^D9ZOf za90fH<>I?MAfM`xT~8L%?YguS~D~UG&?jKTz#$HfIk)p`XYL4A_7-efZu)g=-FsYAETsRB4&8m zHd$qjavNNCPOlz`7!jW_5gVU~dF6Ik(Cqbx&-yq&>Sb{6wH~|s`c!2}VhUcG`|uX@ zfhPNq5gGHxaOlNd0~3*m9ijjvC`ggv7evi-5Zwuy%Aibbm9`r}JYTARN zAwz6L-sTI)n_QBt3Gy;mMxJMT00c>iky}VMauMmDg52aH((7zbh;;pU|vkDZ1 z_XZ-mKc@TcO5e~(Opo|OQML`mAnH#|7%`n2YztVXb}u_FB@>x$Z6T9R%+KQ<$C-x2 zVHFxV#4=3fcUD2E^k3sRSQqTV9^vX0(=vN%)#noVgLQDVSBd+?O}L>h1lOq(-YW3!fU<>N z+fiF|h9bro6cx+##HaJ|BznKDVo=BhI0FrVkP)4T=;(d;n92c2XzB!=Z6jfDW7r?^ z#exxI(kIR$+qR9h5t;3hB*ffRg-NQy#2&xz=B!uj$@-v{4%BGfzAD+V%)2DZY=AX9lz z=z>l1KUO6f?gPt|W4c~H{a#(vso!wKGWXYRC~|9dA)Qan!B0Y-Wb=nmnJz%M0ff+r7={D} z$SfS4qF49w8bI%?(l4BVA5YKxD7bE4DYk)w#Ya4LG4)`Aya8V{__1m)jRw~h z5A>8$@izY$iWZ7Qc4{Y$lr=m$7D z%_i9yu#w)ba}oWCWqNB}R6dE9Qu(BI4@c2k+)?zaR-t8SW+}e(<)vxiu+31=7r;YH zk1qLe&pAQTOON6xwCUb0=|Gh~Rj3jw~ne&!un@?tQc{on#R6Y+0VwvP_>&OkubP9Q1B4His zE3A^wowylXZ(hb9N_Z@j9ufX#0?E;g;cqUT3a&da{Ekxb*HDx0bN=DAQWbX6$_9vo z?IKXI?gD@Zl3cC#E%{0rRm=EY^+6eKf_i{i~#jUpFb?!TU#* zVpQ=F3Ln--8X>CuqG+hy(+-G~06h0x0b^_&{vtZ*D_=r5(a8|-Dtys@ZFb4Et?sPo X5>U|i^mr^1oCuHheiIj2ckcWLqkxoo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST b/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST new file mode 100644 index 00000000..2afdbd89 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: loop ;; ;; Source: Steele's book ;; Section 7.8: Iteration ;; Page: 121 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 16,1986 HC3/ documented, and added ;; several more test cases ;; October 27,1986 HC3/ broke into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-8-1-loop.TEST ;; ;; ;; Syntax: (loop {form}*) ;; ;; ;; Function Description: ;; Each form is evaluated in turn from left to right. When ;; the last form is evaluated, then the first is evaluated again, ;; and so on until execution is terminated explicitly. ;; ;; ;; ;; Argument(s): FORM - what is evaluated. ;; ;; Returns: depends on what is used to terminate execution. ;; (do-test "test simple function" (and (loop (return T)) (catch 'looptag (loop (throw 'looptag T))) (eq (loop (return)) nil) )) (do-test "test loop can terminate with return." ; first return a symbol, then a number (let ((sideffect nil) (foo '(a b c)) (bar '(1 2 3 4 5 6 7))) (and (eq (loop (if (null foo) (return 'bar) (push (pop foo) sideffect))) 'bar) (equal sideffect '(c b a)) (eq (loop (if (null bar) (return 1013)) (push (pop bar) sideffect)) 1013) (equal sideffect '(7 6 5 4 3 2 1 c b a)) ))) (do-test "test loop can with throw and catch." ; first return a symbol, then a string (let ((sideffect '(c b a)) (foo '(a b c)) (bar '("a" "little " "short" "string"))) (and (eq (catch 'looptag (loop (if (null foo) (throw 'looptag 'bar) (push (pop foo) sideffect)))) 'bar) (equal sideffect '(c b a c b a)) (equal (catch 'looptag (loop (if (null bar) (throw 'looptag "string testing")) (push (pop bar) sideffect))) "string testing") (equal sideffect '("string" "short" "little " "a" c b a c b a)) ))) (do-test "test loop can return with multiple values." ; first return two symbols, then two characters (let ((sideffect '(c b a)) (foo '(a b c)) (bar '(#\a #\b #\c #\d))) (and (equal (multiple-value-list (loop (if (null foo) (return (values 'foo 'bar)) (push (pop foo) sideffect)))) '(foo bar)) (equal sideffect '(c b a c b a)) (equal (multiple-value-list (loop (if (null bar) (return (values #\+ #\-)) (push (pop bar) sideffect)))) '(#\+ #\-)) (equal sideffect '(#\d #\c #\b #\a c b a c b a)) ))) (do-test "test loop can throw multiple values." ; first return two symbols, then two characters (let ((sideffect '(f e d)) (foo '(a b c))) (and (equal (multiple-value-list (catch 'looptag (loop (if (null foo) (throw 'looptag (values 'foo 'bar))) (push (pop foo) sideffect)))) '(foo bar)) (equal sideffect '(c b a f e d)) ))) (do-test "test loop can go" (let ((sideffect '(c b a)) (foo '(a b c))) (and (null (tagbody (loop (if (null foo) (go looptag) (push (pop foo) sideffect))) looptag)) (equal sideffect '(c b a c b a)) ))) (do-test "test loop can return and throw value from a function" ; try returning, and throwing the value from a function ; is the complier smart enough to hardcode in the value ; instead of making a dumb function call? want the call (flet ((tee nil t) (retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (let ((sideffect '(c b a)) (foo '(a b c))) (and (loop (return (tee))) (eq (catch 'looptag (loop (throw 'looptag (retnumber)))) 5) (eq (loop (return (retsymbol))) 'hello) (equal (catch 'looptag (loop (throw 'looptag (retlist)))) '(hi bye)) )))) (do-test "test loop can nest: when, unless" (let ((sideffect nil) (i 1) (j 1)) (and (eq (loop (when (> i 4) (return i)) (push i sideffect) (setq i (+ i 1))) 5) (equal sideffect '(4 3 2 1)) (eq (loop (unless (> 6 j) (return j)) (push j sideffect) (setq j (+ j 1))) 6) (equal sideffect '(5 4 3 2 1 4 3 2 1)) ))) (do-test "test loop can nest: type, typecase" (let ((sideffect nil) (i 1) (foo '(1 23 abc))) (and (eq (loop (case i ((7 8 9) (return i))) (push i sideffect) (setq i (+ i 1))) 7) (equal sideffect '(6 5 4 3 2 1)) (equal (loop (typecase (car foo) (number (push (pop foo) sideffect)) (T (return foo)))) '(abc)) (equal sideffect '(23 1 6 5 4 3 2 1)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-2-DO.DFASL b/internal/test/LANGUAGE/AUTO/7-8-2-DO.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f3046468d929cdda08801e35601d68c51a51ced7 GIT binary patch literal 3717 zcmb_eZ){sv6~FgAyGfHYb)B|roiu$*yB2wMOSY9X?FZ&MFO3uDz07`D*#H&KdG34E zv4j1bYD|=@grSbNG)_wNF8lL=KSKL}WO@72KcoVL#)qPUsKkITuu4T5LR6ZNKpHCN z+*_wf4I6^Wx<2=wbMEh)d+s^s-3sx4CYDfQg~=&9XBL%0*_kRkO14l`N`-PUV=7tT zD=)am zs2cVvp4$v(iHxVzq~~sWOmPZRk(@bg=I}U^B|-`D=H2GOaV=)Vbaml(oOfTlin^%UV}75KMQc`*maBiSSTpvFC4QG-TkvetHfmj5)?j|S zGV+S{Q$i}%OWLqRH^8j=(D6NpfTNj^HbSo2nNRR|+;xOb)E#NEmQn3QfQwHAuj;}1 zS%9sE^dLp}Mfm$B%$N0`1mfx+ky$&)P1pA6f%)0I{I}{BJwS1DKmsH^sD+lRw}5|p zNkjB&4X&eB0Ff#q=k)-0{~LPXzxV&cy8j#QdJmSR`B%UTm|zg#;sFr7sovr))Ivz= zqm^rL!Hl&kr2nU1(rn$YRtumIAFr|6rSVvLaAGY4f^!;$f4tk97F?XpQ})^e^y5!; zKia^g$TEJ|2WLY5Zrwx+BJ;q}oczHe+(A9^f6e)>)#CTWa4BoV+@%`NRk7cf^WCmM zs;}01AJYUA=mGlv&${pJHkx~I$i7k?dE+TKQchad13CW(6>ScvbOTnWZUDdf=Umh6 zRaXD^O7?fu4F(!2Ie>lRM9)>dXF>1zx*o*k1&AipHq=RwhM-KbM(TB2y^f(?DcO(r z54zRXf7fa%R=^GrDd2s}?Fz?qZ6J>QGcpv_1`=vAax@Mc?N}--ZDi}Eb{H)%+F-Q8 z*Z`vmh98Cx8uzAfENaAtB1zR4PeS93@y@+2^-Ri8M*Vd!DjDhJtmxdWPYdss~- z^<+dJH^#<|u)G;Iw1uPEGZD^Dg&B11P5t*b|Da3=^I^+Zu#5i%kk$?A$O9MNOX@eL4|O z;lbzKmJCYwlfP4eGrmlQ}@!N@#dDeyG0NaLSuTbygME((H%5RI+_XWua=Cfio zBFIs|2VXk@L;3+%klx@D>AWB_pwN`i^)VxQOsEYAwIf2lPmmT+^C#oSh76(9jJPpA zr&ss}`WDxu-xFlFUF@?$}+Fw83QHX!;meN1JYCfoLTw*4u# zJ;b_uLFT*VxsN(#$x)swIF>S%E~axic$t(;$FcJ#m2`eWvGedSnl$ssz%B22?oI=@ z^qh(IDA_bT#864Rp^$gx5mbB2Ta>*E5>uFhWCz;;1kV;_oeQo!sO$WUz7k|VuLWzXGPE}0PUX%k|vOxW41S%hFK*>XOEj+UTjC?$9_qD#{PXqUI>qYzM68nU@} zt3xJtaXzX`AEhVV^cMY8l6`(qm44CSo3!k?3O{TnomU*ISU9bu#i8&$t`xG$L;<&6 z;!a8DJa?m&o;E=#Z^H{6p4}*&U80XZc@e+CmxjfguWOj{Px5Q<9l(hdf|nG$$}Uy^ z0PP%;p<`_`9!%<^&}=<7lu0`o3zMy(lR_huzNa%bks02R(OP&UT!fDMS1`m!>_}Uz&u~Z6UqaMVn7u9hhR|TK6@6B>3a>x^w*xdgCiGBr(Dcql}?r& zdn#u}Rx+4g=N9N|U}5h0x&FB?A=rW-b94Q;dU+17hkgz7M-kS(aG&+zM(amBxBEWp zSV)dpoV4@2un@FQm?z!^zfYDRQ-Mj|T#HV=18Yn_l)b#x(hK$IITnoqA&qR2Ly$cz{*h@Sfp_&ZVIy=s)2Ph4fw|TJ^6lw6cm4%ehFC)Y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST b/internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST new file mode 100644 index 00000000..a0f230e1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do ;; ;; Source: Steele's book ;; Section 7.8: Iteration ;; Page: 122 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 16,1986 HC3/ docuemented, and added ;; several more test cases ;; October 27,1986 HC3/ broke into several tests ;; Feb 5, 1987 Jim Blum - changed (do nil nil (return T)) which is wrong on the SUN ;; to (do nil ((return T))) ;; and (catch 'lloptag (do nil nil (throw 'looptag T))) to ;; (catch 'looptag (do nil ((throw 'looptag T)))) ;; ;; ;; Filed As: {ERIS}CML>TEST>7-8-2-do.TEST ;; ;; ;; Syntax: (do {(var [init [step]])}*) (end-test {result}*) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; The initial variables are each evaluated and then bound. ;; Then the end-test is checked to see if can terminate. ;; If ok, the forms in result are evaluated, and the value of ;; the last one is returned If suppose to go on, loop thru ;; the body, update the variables and start over again. ;; The difference between DO and DO* is here DO first ;; evaluated everything and then binds the variable. ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; TYPE - a type(s) against which match keyform ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; ;; The first section is similar to DO* (do-test "test the simple stuff" (let ((x nil)) (and (do nil ((return T))) (catch 'looptag (do nil ((throw 'looptag T)))) (eq (do nil ((return))) nil) (do nil (T . (T)) nil) (eq (do nil (T)) nil) (do nil (T nil nil T)) (null (do ((x '(a b c d) (cdr x))) ((null x)))) ))) (do-test "test returning for termination" ; first check can return a symbol, then a number (let ((sideffect nil) (x nil) (foo '(1 2 3 4))) (and (eq (do ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (return 'right) (setq sideffect (car x)))) 'right) (eq sideffect 'b) (eq (do nil ((null foo) (return 1013)) (push (pop foo) sideffect)) 1013) (equal sideffect '(4 3 2 1 . b)) ))) (do-test "test returning mutiple-values" (let ((x nil)) (and ; first return two symbols, then three characters (equal (multiple-value-list (do ((x '(a b c d) (cdr x))) ((null (cddr x)) (values (car x) (cadr x))))) '(c d)) (equal (multiple-value-list (do nil (T (values '#\y '#\9 '#\q)) nil)) '(#\y #\9 #\q)) ))) (do-test "test can go out of do" (let ((sideffect nil) (x nil)) (and (null (tagbody (do ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (progn (setq sideffect (cons 'right x)) (go dotag)) (setq sideffect (car x)))) dotag)) (equal sideffect '(right c d)) ))) (do-test "test can throw a value out of do" (let ((x nil)) (and (equal (catch 'looptag (do ((x '("a" "small" "little" "string") (cdr x))) ((null x) 'nope) (if (equal (car x) "little") (throw 'looptag "have a nice day")))) "have a nice day") ))) (do-test "use several different functions to stop" (let ((x nil)) (and (equal (do ((x '(1 2 3 4 5) (cdr x))) ((> (car x) 3) (car x))) 4) (equal (do ((x '(1 b "Hi" '(a b c)) (cdr x))) ((stringp (car x)) (car x))) "Hi") (equal (do ((x '(1 b "Hi" '(a b c)) (cdr x))) ((if (symbolp (car x)) T) (car x))) 'b) ))) ;; Do some parallel testing ;; this will be different in DO* (do-test "test parallel evaluation setting initial values" (let ((x nil)) (and (do ((x '(a b c d)) (y x)) (nil) (return (and (equal x '(a b c d)) (eq y nil)))) (do ((x '(a b c d)) (y x)) (T (and (equal x '(a b c d)) (eq y nil)))) ))) (do-test "test parallel evaluation for incrementing values" (let ((x nil)) (eq (do ((x 1 (+ x 1)) (y 2 (+ x 2))) ((> x 5) y)) 7) )) (do-test "test both parallel setting and incrementing" (let ((sideffect nil) (x nil) (y nil)) (and (eq (do ((x '(a b c) (cdr x)) (y '(foo) (cdr x))) ((or (null x) (null y)) 'done) (push (cons (car x) (car y)) sideffect)) 'done) (equal sideffect '((c . c)(b . b)(a . foo))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..233946602c96775d70aefdd14d9fd42587b162f1 GIT binary patch literal 3727 zcmb_eYit}>6~1?7*LG~j*=!z7){ZlA(gtlahBir^hXmcM$MHJr8E1Fg5FQF!dp0v< zy=!)79hHjU1_Mf&I(`H*7g~Ps5b7VaTFQ^4=|+GM{0M@IAS(D%h*Sg!5mb=)Q54R( z*X#HJr4rU^_S}2Ux!-x*bI-lAB>3TYQi&JF#+{s1R0?HxyzDC3LQyFd%Eb{&$pT+_ zHg2S}&-BOQr@D_n)|_4@87W#B*BVvKvQ-+*Jaa&K?5GkOFFH9G9618hCypIDbnM{a z?&iK&Iw{cp=bD~l2YZekdZN4e{!0rqR3L@i6hx=K*V>~VQ6E=(jkFm{k(UR5fw6_1Jjx%eAoDh*h{+GRuXxz|y6WB`C{+QmI)Kcn+1aS0|>8P}cZIIgF zYlg2Cz83g4!q*625WWEP@XgV9%#8P|Da{;CK@X1eCf<-fn>MvUiLTW!jVNo8!)$}R z1^RYdR7<6dlxhr{L&IiN-U4*!>k~=7GNhQbV7S z8jP7Z{To`152sR^zU+2k6lHIMZ0m!dpJiJLZ0mkd3H%Dy z2YF&~b{lTe1|74O#OZ5nCz9_%f&#sUt}R{0c#WcDj&&e8$aWx!3iWnQUPg07*I;01{e zO$ea9{(OM4UA`yvJKQ(Own!f;b#Ok8q<7Pk?)vjVD#?K$s7gOuNmqPtlbxBcKr8RSdmSF(D4klMk3M-FZ{r&S;`P@t zK>6kTB3uYKup{uMg7?{t%A3&9vDEn055n8!mpR(757oTV;R8~r&4r!NBd^fS{(r$2?@bAn7yAH~`8)3`PCb67l! z)<3bz`oLQ2$9=DJm32Hru2md!^88F8Xpb;Y{An zeQz7L;@WU7oG}Ov>c5=LUSxX@FN5h^pv_NShZ1r`{Xpd~IPLFJA`*C4FACy`x!f literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST b/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST new file mode 100644 index 00000000..087657d3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do* ;; ;; Source: Steele's book ;; Section 7.8: Iteration ;; Page: 122 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 20,1986 HC3/ docuemented ;; October 27,1986 HC3/ broke into several tests ;; Feb 5, 1987 Jim Blum - same changes as in "do.test" ;; ;; Filed As: {ERIS}CML>TEST>7-8-2-dostar.TEST ;; ;; ;; Syntax: (do* {(var [init [step]])}*) (end-test {result}*) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; The initial variables are each evaluated and then bound. ;; Then the end-test is checked to see if can terminate. ;; If ok, the forms in result are evaluated, and the value of ;; the last one is returned If suppose to go on, loop thru ;; the body, update the variables and start over again. ;; The difference between DO and DO* is here DO* does the ;; first evaluation and binds it, and then does the second ;; evaluation and so on. ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; TYPE - a type(s) against which match keyform ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; ;; The first section is similar to DO (do-test "test the simple stuff" (let ((x nil)) (and ; do* some simple tests... (do* nil ((return T))) (catch 'looptag (do* nil ((throw 'looptag T)))) (eq (do* nil ((return))) nil) (do* nil (T . (T)) nil) (eq (do* nil (T)) nil) (do* nil (T nil nil T)) (null (do* ((x '(a b c d) (cdr x))) ((null x)))) ))) (do-test "test returning for termination" ; first check can return a symbol, then a number (let ((sideffect nil) (x nil) (foo '(1 2 3 4))) (and (eq (do* ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (return 'right) (setq sideffect (car x)))) 'right) (eq sideffect 'b) (eq (do* nil ((null foo) (return 1013)) (push (pop foo) sideffect)) 1013) (equal sideffect '(4 3 2 1 . b)) ))) (do-test "test returning mutiple-values" ; return two symbols, then three characters (let ((x nil)) (and (equal (multiple-value-list (do* ((x '(a b c d) (cdr x))) ((null (cddr x)) (values (car x) (cadr x))))) '(c d)) (equal (multiple-value-list (do* nil (T (values '#\y '#\9 '#\q)) nil)) '(#\y #\9 #\q)) ))) (do-test "test can go out of do*" (let ((sideffect nil) (x nil)) (and (null (tagbody (do* ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (progn (setq sideffect (cons 'right x)) (go dotag)) (setq sideffect (car x)))) dotag)) (equal sideffect '(right c d)) ))) (do-test "test can throw a value out of do*" (let ((x nil)) (and (equal (catch 'looptag (do* ((x '("a" "small" "little" "string") (cdr x))) ((null x) 'nope) (if (equal (car x) "little") (throw 'looptag "have a nice day")))) "have a nice day") ))) (do-test "use several different functions to stop" (let ((x nil)) (and (equal (do* ((x '(1 2 3 4 5) (cdr x))) ((> (car x) 3) (car x))) 4) (equal (do* ((x '(1 b "Hi" '(a b c)) (cdr x))) ((stringp (car x)) (car x))) "Hi") (equal (do* ((x '(1 b "Hi" '(a b c)) (cdr x))) ((if (symbolp (car x)) T) (car x))) 'b) ))) ;; Do some serial testing ;; this is different in DO (do-test "test serial evaluation setting initial values" (let ((x nil)) (and (do* ((x '(a b c d)) (y (cdr x))) (nil) (return (and (equal x '(a b c d)) (equal y '(b c d))))) (do* ((x '(a b c d)) (y (cdr x))) (T (and (equal x '(a b c d)) (equal y '(b c d))))) ))) (do-test "test serial evaluation for incrementing values" (let ((x nil)) (eq (do* ((x 1 (+ x 1)) (y 2 (+ x 2))) ((> x 5) y)) 8) )) (do-test "test both parallel setting and incrementing" (let ((sideffect nil) (x nil) (y nil)) (and (eq (do* ((x '(a b c d e f) (cdr y)) (y (cdr x) (cdr x))) ((or (null x) (null y)) 'done) (push (cons (car x) (car y)) sideffect)) 'done) (equal sideffect '((e . f)(c . d) (a . b))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL b/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d5b0273a451c40988b2f129f1e5a215518123ef2 GIT binary patch literal 4649 zcmcIoeQaA-6~FiSJ-Z*N=Qybw(l&Vw?Ix_c>qpkFAvV`>nh(b>^T$fJj^aA6d)C|} z@<&HDR;69ZwAHvx!n$`U71|JDAc5Tc0qO??!9c4hs-V*TfK3ek;U5G+6+%Lq$~oux zIZo4M6&h--d+#~to_o&ke7w_6GUbb*h#DF>Hk!%mId!C17%djmqa!&rKT^!4b@eFF z)fYorEc{YWFx0>0(QPZ@b)0lgPZjhbHBr>_L#eUN>b5;9HR@H*qxmjx171$lv5$Mt)z3~LQcz)$6#$10KW~}`wGU%#tt)E{W z=DDBtO9why8@UtBJnWt|4tr)b_mt-TI_wU6XEpDX<~^A?!-+0|MCC7UU1EPCaSw>Q zXEo21<^gf{0&%2EaEZi!bhq|$o%U0jr(XS^r;N&1(TtkzlLqi>`u-05L(eky9O`t> z4BoB!q;VRJ&CGNzuyI=RR94p+Iia~Hjd66WruqGG!}@a#)O%04eB8KKvDr-e!Fqrln{0qrp*!dnS>=VT&jR->><+ig zYAsV*%gbQoT8we*FyEBs z1D)QxbYdt`r?;xpC&4q7Tj(0Z^Jg`s?2@IFy}h)d?j;N*`(|{FN?>m0DbNT(iy;|* z#!5)F|Jm9%s;1h(S{yR)(qo6rQw^EtzC$LzV25mlorOyyF&{Drl~41u63kY}2noRV zC-eCJ0JK8T*qfyFV__hCDQK7gRjt*a;mx_3FIo8Bn2Cc%z_)*CGv@>LF=oC|)i)39 zr&kBc6&qBy(f3iaWL1IPZl*PNr3sv%#E0}f-FIE8Y^0Xsfo&_@&^%fB_BYT+C_rjN z@8SXKfC&(?_h*bD5(hv|5FmApgqjo<7rb$@vVlt9J^ujJ`MFoBee0$HDju~p&upF7 zyAhJ>IqapVznS$lOH`3_rY&qE`03&2YOwKp0P(ZFD%FOfx$l7=t2}7q#}GdTHIbD+ zx_$068f_!^Ya6xi_g$ybL^Lmur)(CJw7fKgTWtvKHwZ#Ij9;@lXARMxR}r;dsv^o} z0p=wTwS@lE80dO$3f-0)igzg6&a!cT#bq|qM=CPF=dSU8c4!AKFJnZy}C7*B);B)(W8q4~v1 zN26Ho@WL44_J?CJEf&y{iNR#T?`VPx4gO&CV1Vdxzkqq9ap&D*O{0S`A>%N!24|C- zpvl>-#Rh^2Jl?=pL&;by9IYFc1V`Rg;5E-X8Vbh4)>DF}oN)lcb!gy8oP1FHCDi<6 zFp><%@wiW{#^o{LgT?tD;l<_Oq6wG3ie^}pw~45Hmx#*iM3fC8$~qC{BoQ4=M09wF z=wL*YUd0E4gM;B{7ii;OCK>(=$?yTuydJ2o3J56#5T3pV1D-RA-be6giqGKkd2p16 zY6BvUc1YfX0arxR1{1;kmRMe_L$M(=;EAM` z2*XKvjqWNZ>5`JOmR`}0ybW|g?jsR7NIZEvEz-Y;DE-YkePAuWK%=_oHK`f*-Lwar z(Llb3q`03J_8ZY21gh&@v(#G9^941h7mB%I^;ofx8O`c} zhk7&x1OAYj8MbC~q@CD=V&}|hhvIbM_8@G_Un!53U%*ogPNGe$CwE*e=Co{`#0KO_ z<^^+F0&Cksv2ZXE4&0Stk={f&7L3HjN)Qt&x#GNSmQ*tO`Aor3i^EwxpWm#eQ+a)} zS{NJEaR zwE%KDRY)6%+oF)(OezjRCd+FDgSdJobm^7RjJ}B|E>-~8A_=J zu3TDxr#!j{PZ=KnET#GJR4y}8%&WMjj=(>#G0F3oOxaAn02ay55U_Fw7-p87`9dx; z{48v;nL;6}qaP^LT4TY<@gd2ghc&V4Mdbb-oGK5M)8!*&yz97L9>V1;l2brTTjvuK zRPv5ID1$BJ+l1sm!97Tj97wPv)-LkT(Ey!={5w+2WQV|Fawo4I8B>oIhtrrosA?Jc zCS6CEp($3gSUQcFw~o4qG>&`dF(5AG%4u9OU_i}$>0vyP-N zfDGzYKrM<65a#f1Eu4G;3k-_@ImRNF_(8L@np`Rvx|+`%gH}p?2|FoIk|S&mbj&{j z4E7!tE0!j^d7iJYPksD1_*G~&8LQLWM_$YD5PjfLXD4rgy!MKA4*3jEuonRb>+Q$_ zE7lX+wa_69r1RU*U_2phU=aT6q$^PEQNU0J1RDGr2mbOygNayAGTOiWn@B6&x$|FL CU5oty literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST b/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST new file mode 100644 index 00000000..16112402 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: dolist ;; ;; Source: Steele's book ;; Section 7.8.3: Simple Iteration Constructs ;; Page: 126 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: October 23, 1986 ;; Creation Date: October 27, 1986 HC3/ broke into several tests ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-8-3-dostar.TEST ;; ;; ;; Syntax: (dolist (var listform [result]) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; listform is evaluated returning a list. The the body ;; is executed, once for each element in the list, in order, ;; with var bound to the element. Then resultform is ;; evaluated and the result is the value of the dolist form. ;; ;; ;; ;; Argument(s): LISTFORM - evaluated to build a list ;; RESULT - creates the value for dolist ;; DECLARATION - ;; TAG - for go ;; STATEMENT - where do the work ;; ;; Returns: If allowed to finish the list DOLIST will ;; return the value of RESULT. If control is ;; aborted during the iteration, then the ;; value of DOLIST depends on how it was aborted. ;; (do-test "test the simple cases" (and (dolist (aitem '(a) T) nil) (dolist (aitem '(a b c d e) T) nil) (eq (dolist (aitem '(a b c) aitem)) nil) (eq (dolist (aitem nil) nil) nil) (catch 'looptag (dolist (aitem '(a)) (throw 'looptag T))) (dolist (aitem '(a) nil) (return T)) (dolist (aitem '(a b c d e) (null aitem)) nil) )) (do-test "test building lists by function" ; again the question about how smart the compilier is ; do we really need to have a function here? (flet ((listnum nil '(1 2 3 4 5)) (listsym nil '(a b c d e f)) (listchar nil '(#\a #\b #\c))) (let ((sideffect nil) (oldval nil)) (and (eq (dolist (aitem (listnum) oldval) (setq oldval aitem) (push aitem sideffect)) 5) (equal sideffect '(5 4 3 2 1)) (null (setq sideffect nil)) (eq (dolist (aitem (listsym) oldval) (setq oldval aitem) (push aitem sideffect)) 'f) (equal sideffect '(f e d c b a)) (null (setq sideffect nil)) (equal (dolist (aitem (listchar) sideffect) (setq oldval aitem) (push aitem sideffect)) '(#\c #\b #\a)) (eq oldval #\c) (null (setq sideffect nil)) (eq (dolist (aitem (append '(a b) '(c d) '()) oldval) (setq oldval aitem) (push aitem sideffect)) 'd) (equal sideffect '(d c b a)) )))) (do-test "test various variable types in list" ; first pass back a list, then single value ; again the question about how smart the compilier is ; do we really need to have a function here? (let ((sideffect nil) (oldval nil)) (and (equal (dolist (aitem '(2/3 4/5 6/7) sideffect) (setq oldval aitem) (push aitem sideffect)) '(6/7 4/5 2/3)) (equal oldval 6/7) (null (setq sideffect nil)) (eq (dolist (aitem '(#\a #\b #\c #\d) oldval) (setq oldval aitem) (push aitem sideffect)) #\d) (equal sideffect '(#\d #\c #\b #\a)) (null (setq sideffect nil)) (equal (dolist (aitem '("a" "little" "string") oldval) (setq oldval aitem) (push aitem sideffect)) "string") (equal sideffect '("string" "little" "a")) ))) (do-test "test termination, use when" (let ((sideffect nil)) (and (equal (dolist (aitem '(1 2 3 4 5 6 7) sideffect) (push aitem sideffect) (when (> aitem 4) (return "hello"))) "hello") (equal sideffect '(5 4 3 2 1)) (null (setq sideffect nil)) (null (tagbody (dolist (aitem '(a b c d) sideffect) (push aitem sideffect) (when (eq aitem 'c) (go dotag))) dotag)) (equal sideffect '(c b a)) (null (setq sideffect nil)) (eq (catch 'looptag (dolist (aitem '("a" "b" "c" "d" "e") sideffect) (push aitem sideffect) (when (equal aitem "d") (throw 'looptag #\y)))) #\y) (equal sideffect '("d" "c" "b" "a")) ))) (do-test "test with unless, case, typecase" (let ((sideffect nil)) (and (equal (dolist (aitem '(1 2 3 4 5 6 7) sideffect) (push aitem sideffect) (unless (< aitem 4) (return "hello"))) "hello") (equal sideffect '(4 3 2 1)) (null (setq sideffect nil)) (null (tagbody (dolist (aitem '(a b c d) sideffect) (push aitem sideffect) (case aitem ('c (go dotag)))) dotag)) (equal sideffect '(c b a)) (null (setq sideffect nil)) (eq (catch 'looptag (dolist (aitem '(1 a "b" (c) 4/5) sideffect) (push aitem sideffect) (typecase aitem (list (throw 'looptag #\y))))) #\y) (equal sideffect '((c) "b" a 1 )) ))) (do-test "test return mutiple-values" ; first return two symbols, then three characters (and (equal (multiple-value-list (dolist (aitem '(a b c d) (values 'a 'b 'c)) nil)) '(a b c)) (equal (multiple-value-list (dolist (aitem '(#\x #\y #\z) (values 5 6 7)) nil)) '(5 6 7)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL b/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6624bf74bdd4840b8bf4f74d94ff1676045fca0d GIT binary patch literal 4759 zcmb_geQXow8GrB2cXkruI!^eQ3E`jwT8~3O+VZ8T7{`z}jxX~^fsGBBL8w+$-okM56YlCiWu=*O(8NK-XBO)6#D)csLutu$$EJ*AU6wHbTf z_wHhcqyuRPAJ6+fU+?q$-uHR#z04x^L@>e!bD7DsBIWs9QJpNR{Ae!E7jnh?u*8o7 zpMN$e#zN=%0>Ob@hxRnb8zjSdDWysye4;27Mp9Ed`8@~tz+^tHz+nG=m_BjvvBwVf zJie>>XdoUjz1`Dh-@%>(2X}+boh$Q{Cx;LkMpaCj5b_`f>6bN+KM{&2grohDkPrvl7uyHx%}VQZD7C3Mtud~Mc;WHW z-m2(TS{E0tS~!SafWuq;G3M4@1dLiCj#BykN(S^H-Vw`$Th)XkCY)vRglQsJCV^E= z0>mU>nmqV~nUbAwtBEvD*533Pr5SHta}Bon-v1Y?-7L!vPmD@*>cou zs9P{%aJ&fdR^`(hstPk9y4|OJaO66xVyEa^TzDDC1|P`8PB?R&)fus~RQ^ceFp_@} zH`u7Z1Lkw`HFQI9fYLa)5Pf1NHuqWPJ}~!zxeuE=u=z`M^A{}h(!_-5z0UwDG0VPk z46LDmpHw((tvGNJ@7+%rOwEqrtKr7AXP2_qDrN6|mohtN!~Kv96>Dv}b8(@vOLU7~ zA1Q4b|G)ao?0cjUy{$MQTrWXn^qd`V;s)ft`1ta0l(iqnd6j+k5xmAaQx9R1Q3GN5$A+ zAc3a}UNxAE#X`}BTb)5+*|$N~QBOD+h=*gHJ{JN(GfqoqAwV2QHnWCbmClyI} zCZ)hv2UZ=?wap2vy7jrhR(>=E-z+11I%|GzVBT}xSZ%jH$FQ6e51lYHHW{79MwmHo z>Oa%xXo$Eg7z+gwA>ppm7U@rfVu489Xu)c*Ti;BIi4Y0g`G&6XB+RpERpyIXMJg0_ z^24cuw3An-CM7(=Yg{+BU@{FAfbih#g(*xj^VH*quaCbP#+S#+_HZ9`=|0@0!#y7O zN|1jJO$YZ6*$209Pk7?itEF(M{4O*CT&V5KOZjL_9E4KUHQ#Vb9hNZ!E9wx+kb)!T z3`WFwG8Tex@K1Ae!>OQlfX}u4QOGtLhzNV8pj4%NCY?>G z>0EXvUo1%cSy{?r4^sq0?yx?$w8B1uBPYyLdrcf40URF&9BGUrT@5QtZFLZDV-St6 z-xDoEFhMeQQQM3?)JA}z%Y=bzZ^)JXqdvziWzODcNS3WMPNr65&W`I^H_3cBmE}ir zd;z{&^C^WdsPJ{2k+Nz5_Og&3!6%6wB_Oap`kb@Ap5yikuMWU_JMn5)(3xUd!G)np zWAL$mW{MvzW`{A#;MVaLaqBn_m0@n417L1g0M$Wf-fWaG=jRc3SYdB@kghcyN%lv2 zqshS@I2aUZ_~d+1Ct!|G3Uh8Av4;;YSKjkg%3~|CVovCquq-R9FN~x|N2NSqMar(g z=SKOZ4#6Zya`3L2V|0y5!E*+lVH}TpC6E40*XY3`Af-QE8odiA^+MzV?#lGdhH=GY z{mLX4!5e36ggTJE})TIH2oZnD6uvc%`p zW3tL;iCcO>&>!( zyN&_9CT%tv`F?8yztQ0bwb2H((PDH#FIXN114}v6@RIff#la!?gH5ks^&Sv#j~d^j VK-P3>C=u&RMhEu(^!s=2{1+B2^uquE literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST b/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST new file mode 100644 index 00000000..9a7db00e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: dotimes ;; ;; Source: Steele's book ;; Section 7.8.3: Simple Iteration Constructs ;; Page: 126 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: October 23, 1986 ;; ;; Last Update: October 27,1986 HC3/ broke into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-8-3-dotimes.TEST ;; ;; ;; Syntax: (dotimes (var countform [result]) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; countform is evaluated returning an integer. Then the body ;; is executed, once for each integer from 0 to what counform ;; returned, minus one with the var bound to the indexing value. ;; Then resultform is evaluated and the result is the value of ;; the dotimes form. ;; ;; ;; ;; Argument(s): COUNTFORM - evaluated to build a list ;; RESULT - creates the value for dolist ;; DECLARATION - ;; TAG - for go ;; STATEMENT - where do the work ;; ;; Returns: If allowed to finish the list DOTIMES will ;; return the value of RESULT. If control is ;; aborted during the iteration, then the ;; value of DOLIST depends on how it was aborted. ;; (do-test "test the simple cases" (and (dotimes (i 3 T) nil) (dotimes (i 2 T) (return T)) (catch 'looptag (dotimes (i 5) (throw 'looptag t))) (eq (dotimes (i 5 i) nil) 5) (eq (dotimes (i 4) T) nil) (eq (dotimes (i 0 i)) 0) (eq (dotimes (i -5 i)) 0) )) (do-test "test it loops the right number of times" (let ((tmpcnt 0)) (and (dotimes (i 10 (and (eq i 10) (eq tmpcnt 10))) (setq tmpcnt (+ tmpcnt 1))) (eq (setq tmpcnt 0) 0) (dotimes (i 6 (and (eq i 6) (eq tmpcnt 6))) (setq tmpcnt (+ tmpcnt 1))) (eq (setq tmpcnt 0) 0) (dotimes (i 65 (and (eq i 65) (eq tmpcnt 65))) (setq tmpcnt (+ tmpcnt 1))) ))) (do-test "test able to return different types of values" (and (eq (dotimes (i 10 13) nil) 13) (equal (dotimes (i 19 '(6 1)) nil) '(6 1)) (eq (dotimes (i 21 'KY) nil) 'KY) (equal (dotimes (i 11 '(6 C J)) nil) '(6 C J)) (eq (dotimes (i 8 #\L) nil) #\L) (equal (dotimes (i 5 '(#\L #\L)) nil) '(#\L #\L)) (equal (dotimes (i 9 "MB") nil) "MB") (equal (dotimes (i 11 '("a" "b" "c")) nil) '("a" "b" "c")) )) (do-test "test able to build integer by function" ; again the question about how smart the compilier is ; do we really need to have a function here? (flet ((Buildnum1 (x) (+ x x)) (Buildnum2 (x) (* x x)) (Buildnum3 (x) (+ x 5))) (let ((sideffect nil)) (and (eq (dotimes (i (buildnum1 3) i) (push i sideffect)) 6) (equal sideffect '(5 4 3 2 1 0)) (null (setq sideffect nil)) (eq (dotimes (i (buildnum2 2) i) (push i sideffect)) 4) (equal sideffect '(3 2 1 0)) (null (setq sideffect nil)) (eq (dotimes (i (buildnum3 1) i) (push i sideffect)) 6) (equal sideffect '(5 4 3 2 1 0)) (null (setq sideffect nil)) (eq (dotimes (i (- (buildnum3 6) (buildnum1 4)) i) (push i sideffect)) 3) (equal sideffect '(2 1 0)) )))) (do-test "test can do several statements inside" (let ((sideffect nil)) (and (eq (dotimes (i (+ 3 4) i) (push i sideffect) (pop sideffect) (push i sideffect) (pop sideffect) (push i sideffect)) 7) (equal sideffect '(6 5 4 3 2 1 0)) ))) (do-test "test termination, use when" (let ((sideffect nil)) (and (equal (dotimes (i (* 2 10) i) (push i sideffect) (when (> i 4) (return "hello"))) "hello") (equal sideffect '(5 4 3 2 1 0)) (null (setq sideffect nil)) (null (tagbody (dotimes (i (* 5 5) i) (push i sideffect) (when (eq i 4) (go dotag))) dotag)) (equal sideffect '(4 3 2 1 0)) (null (setq sideffect nil)) (eq (catch 'looptag (dotimes (i (+ 20 20) i) (push i sideffect) (when (eq i 3) (throw 'looptag #\y)))) #\y) (equal sideffect '(3 2 1 0)) ))) (do-test "test with unless, case, typecase" (let ((sideffect nil)) (and (equal (dotimes (i 6 i) (push i sideffect) (unless (< i 4) (return "hello"))) "hello") (equal sideffect '(4 3 2 1 0)) (null (setq sideffect nil)) (null (tagbody (dotimes (i 10 i) (push i sideffect) (case i (0 (push (cos 0) sideffect)) (1 (push (* i 5) sideffect)) (2 (go dotag)))) dotag)) (equal sideffect '(2 5 1 1.0 0)) (null (setq sideffect nil)) (eq (catch 'looptag (dotimes (i 10 i) (push i sideffect) (typecase i (number (throw 'looptag #\y))))) #\y) (equal sideffect '(0)) ))) (do-test "test able to return multiple-values" ; first return two symbols, then three characters (and (equal (multiple-value-list (dotimes (i 5 (values 'a 'b 'c)) nil)) '(a b c)) (equal (multiple-value-list (dotimes (i 5 (values 5 6 7)) nil)) '(5 6 7)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bdd731313ff0976ba08e24eaeeeb449e7a546f58 GIT binary patch literal 3433 zcmcInU2Ggz6~1?7*Ixhaj_svJ&ek0{B%q}e)rm{fP^664B{?m6e4d+xbs))nGC9ZATM<;9ixg=}74E)`cwMfv=4UM?(`@|moB z9(eg;#4xp|qiSUO(5J_`lWjAZd^TOo&dF9OTbN5f^`JcVsI0E!=NAARJqp859UC7% zcI4qh-BW5Z;d*;tn@5fvdGy%BM-O#x-?&btWkN`XG*EOAA`y`|>t!iyX-P|&iX}8f zS7)@aQ*p{Z*o%@%YNk`}KP(rQSCob9li3B_&SHU3LY%8*-&9JESTRF)s`N7Lb)GNx z#dKvBwx*uYh~R5_LGRQl_dTKN%;QS8|u<&kZz;fvPc38#4TS9BdfDbtCw!A>r^En$!k$VbkynU}{JL zSk~S|dh5Hdl7Ii7{C>OLuN$ZYi?18fvu>O(pu*ZtT(#fxi0bKFYm@I~RLQkj{Bb>3 z8~Xt2n2yUid^Ro+GO*e?Omnw3b-@3uOh2dpn2<{Dt9o3ZeSm61_9rkR{PPjgOGslr z6Xuz3o{jL)*4gxc3)BO<#)souJlXQyi;i0e?RePj1Y|B+! zt_|9w>-OkcQwuA1w|d)?b~k?ix`r!r-+L8yB`3{GMCf*|l|$i(p-;xJg(*>0pG;_` zG7$qtKamUzy{t>Sq+rC&P@2_W|eC6S1Vl0?@R__cm=m)C2Qis~*PQy991KrVMjNwQ%?ZSocR#rm5*| zp8`g4?kvm&cQX}HlbX9O>w#(U9hes3Q^2sNi*K^~QCxGy=Uj0Lk{wKH)|8SwGc#c% zl-8F6Rl^Je5~RxR@;z z<;C<$W*nJ}Q+~igX7rLeDxXiokCQohe#!k^f!rmG)8lul0u=y>Z#z}d=k*}`>kj!A zkb=m`Ujr09UY!30z>ZEI!XE+j3Rp+t#*S6psd{MB>}4oPZuA`h+@u0}o!sTufZ}UE z4S+NGmiC2~_F3@N=@Iz~=5_Q$RxNtd5;DF6mj$vckn66A;iSsrUm11;bI!>qIWZi6&G&TenUhL8-g|_I?kM%p{eGBQuFU+Me&G+0-kC#w>KVf4Il#dmg(URhmY<~f3L${)lNpl5YZ?pVQ zsfiT)%9@4kvwk+f23c^LMF=K33LMXMGtExbi`n)%RUenlqdDw+3$&nmMk1!BTAH%w zjwfQ4W~zxK>p?Xr@RKRS(%kah-(F8gaM1_YCqW2*Zi@%UzuPnZ*`Dza*-2D;1!9Cq z=p+j;(|wSBu}MdOw%iBlD@}R==u_^4^u;Ev0)5(jkY3rds_T?Zm~+N}dG_M|bWKRj4^H~fdN{+f55BI?3RN!|rChv299 z!UnKA+JX`90pura38y!~2VO|>Jp^zp;_CMH_J8p8F23#*!9oz1*%!~l9Mq)Yiv1wE We4QZ>9&g7GE77|*Oul(>d;7n(b^!?h literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST new file mode 100644 index 00000000..1324a254 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPC ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - removed nil lists from mapc test1 as it is an illegal construct on the SUN ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPC.TEST ;; ;; ;; Syntax: (MAPC FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; ;;(do-test "test mapc0 - syntax checking" ;; (not (or (nlsetq (mapc #'+)) ;; (nlsetq (mapc #'- '(1 2 3) 4 5 6)) ;; (nlsetq (mapc #'* 'a 'b 'c 'd (list 3 6 9))) ;; (nlsetq (mapc #'car (+ 2 3) (char-code #\a) (cons 1 2))) ;; (prog1 nil (makunbound 'fun)) ;; ; non-existing function ;; (nlsetq (mapc #'fun '(1))) ;; (nlsetq (mapc 'm 'n 'o 'p)) ;; ; missing argument(s) ;; (nlsetq (mapc #'(lambda (x) (list x)))) ;; ; non-function type ;; (nlsetq (mapc #'progn '(list 1 2)))))) (do-test "test mapc1 - make sure MAPC always returns the first list argument" (and (equal (mapc #'+ '(1 2 3) '(4 5 6) '(9 8 7)) '(1 2 3)) (equal (mapc #'- '(1) '(2 3) '(-9 -8 -7)) '(1)) (equal (mapc #'* '(100 200) '(3 4)) '(100 200)) (equal (mapc #'list (cdr '(a)) '(9 8)) nil) (equal (mapc #'append '() '((1 2))) '()))) (do-test "test mapc2" (let () (defun fun1 (list1) (let (buffer) (list (equal (mapc #'(lambda (x) (setq buffer (cons x buffer))) list1) list1) buffer))) ; (and (equal (fun1 '(1 2 3 4)) '(t (4 3 2 1))) (equal (fun1 '('a 'b 'c 'd 'e `f `g `h `i)) `(t ,(reverse '('a 'b 'c 'd 'e `f `g `h `i)))) (equal (fun1 '( 0 0 1 1 2 2 3 3 4 4 5 5)) (list t (reverse '( 0 0 1 1 2 2 3 3 4 4 5 5))))))) (do-test "test mapc3" (and (equal (mapc #'(lambda (x y z) (set x (make-list y :initial-element z))) '(n1 n2 n3 n4) '(5 10 15 20) '(a b c d)) '(n1 n2 n3 n4)) (equal n1 (prog1 '(a a a a a))) (equal n2 (prog2 (setq z '(b b b b b)) (append z z))) (equal n3 (progn (setq z '(c c c c c)) (append z z z))) (equal n4 (progn (setq z '(d d d d d)) (append z z z z))) ; (equal (mapc #'makunbound '(n1 n2 n3 n4)) '(n1 n2 n3 n4)) ; (notany #'boundp '(n1 n2 n3 n4)))) (do-test "test mapc4" (progn (setq nlist '((1 2) (1 2 3 4) (1 2 3 4 5) (1 2 3 4 5 6 7 8))) (defun fun (ntimes) (setq n4 (pop nlist) n3 (pop nlist) n2 (pop nlist) n1 (pop nlist)) (push n1 nlist) (push n2 nlist) (push n3 nlist) (push n4 nlist) (mapc #'(lambda (x y) (set x (nthcdr y (symbol-value x)))) '(n1 n2 n3 n4) ntimes)) ; (and (fun '(7 4 3 1)) (equal n1 '(8)) (equal n2 '(5)) (equal n3 '(4)) (equal n4 '(2)) (fun '(7 4)) (equal n1 '(8)) (equal n2 '(5)) (equal n3 '(1 2 3 4)) (equal n4 '(1 2)) (fun '(5 2 1)) (equal n1 '(6 7 8)) (equal n2 '(3 4 5)) (equal n3 '(2 3 4)) (equal n4 '(1 2)) (fun '(8 5 4)) (not (or n1 n2 n3 (not (equal n4 '(1 2)))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b4e27223d094c6af6b87875f9b718cf89998d33d GIT binary patch literal 760 zcmah{T~8B16urAkODTmEq9huF6B1rF4&kF(tS^qkloqzLFgqLMk(8}%QfSi;6JsRC z2cOnxA(CAU|G`(p$b)~#e^6&z6A3){G0->7=PnMF-m6LMI+v|AyNOryU{@$wxXz4K`%~q|hiq%!M zeU!^&aw`uPl6m4-L$?3+WOJFt+{*GovVV4}r5gZHhRbLf14x4b!Lgq3u=ZCQUV?*DWygQ}EY8Nj6rr(XG zwCed!uIk^t%@6z+K(G3qZ|K?tz;X54%+A0}M3DeU0bJI~)4giCmIgf*eD?2|)aGl& zXgXXVe9dA4KPxJPuREqbqHIr@lt@~@f=O4XvFX5f+}U*`E9u(J8`3tzabq+bGZM<` zq{)P^1-4ze9Wzv((@WQ)8#MsJkti=?Q<22;wkQ!CML>TEST>7-8-4-MAPCAN.TEST ;; ;; ;; Syntax: (MAPCAN FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (DO-TEST "TEST MAPCAN0" t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..631f08d004f724cda216da46acd2ac02df3c1c50 GIT binary patch literal 4662 zcmb_fU2GHC6~1@IcAP(BylyDQOWY`U!NgG#vLPEN&De2>gEJ@b4}UB0hQz^^oS){W z6rpYng$f~8C2@*oS|P1g+J~Z+2;MZfVgsH9PNHm|dEm$oQsE z?zdo(fqui=;bQ@W4Xy62wA7`(FE9*%+QCF4jm48nwAKW=74A4+z zBb#;`>TdqrtNf98 zK_PqhJY%jaH61+r!95l6-qRNisoBx%!QXRLuSBR6qcB!4|( z>5Ywu8)jZ}&hVT0+WgJ@kMm>si!<^sXCx6#*7M}=3#8=T3cE&*+@k>l5yZ?b~WFz*7QGd54*twATRd3V5%9)6A8t+#_-YPF|0eFqJM1+|cAlE7ze36XvFRZ6pkw z66UY`9=-3uOG=x3W+QFeszci7mFLy@kjlwr2Tx<1P2hQiZEzX3Q1`M3;LhapUr5PY z0Z&z91x2#39bVj8qBJinM>c&UM`F|e-?DqEwnPbc+bgu{3 zV?fU;^iy zDoh8D5cC_+zY6^ohFvcNAp=4s2$e5@SMUP{43uD?d>&c^KWM;U2?on2pjGfg1`L&8 zsC*Rsf*&?uxCF!HgRocdF#}>Hh?QT1fZ$aF)DoyzqBg;g8Zf#7qt~FF*j4DLu*$~P z1Q!Q42M>oP4qgr|99lW}Iqc;S;LygQomU+!;)KC;L5Bui(Cx?UU59Q=a~J0FnY|1y ziB4d*L>=vs#72^6Q+XviELx;=ivg`ty43)`l=d62SHfyRKuQM;Xp_=y2DD39rpn`t zxu=G6Sv)|q!ky1K;r6Ipg!`OR|DiBc$iAfWrRK)Q-q}~(wuG^5>2qWrnOomG$LYku z6gfGjDBqZO=OvXpOaM(A!0VtKP(rt|x5RP&;H7+rYCARp4s0o4`X-dX`{b~|$jtBQ zlW#$P$l-sl{GNIVYlAf%F`sboM7;(~^NqMiy0c_N_W)oy#wvp2;3GGn@h?u9$)n&&}F zwn2!GC`n>>&|AZ)cs!z3-8*$ob2glFKMgdjBqHXkbh*YWJMkn3*@j^ARiD5q(70z%IIiB z9Y7taMd(P)LI-n9Z{oi|9rD%6C{7fT*UXIkOyf9koblOP2Z0%)!T%}wo6*E zrOM-O^mt+E99F?ETt+gpl+V-R3&L~TQOscBa^W(HtdBA8T4@`W!(z47*lQc>8|oa} zaK;kF8395F93(k}ppHNg0qsnS9|47EX+}^>;L8Z?1hylnA%OYeR8IM?2&mTbpAk^4 z<&P=G5}jC<M!G;zwdWu$@f>c~+SVBrHMk-bkk4DvF>ndC^ z=hbL9B9JuU03>G(G-JEYJAdTxMpHRvi)rlIy4~ zOE%mF4Gt#)E?evCs20-C#EdM&^17^I%1|3UKvmLvAG1M)VfS};c99^00?IkNFLw%! ze$sI7-YaGUo4l2FX~msY-gZ$}eSMyq>ih)xD(w)yaxA9YC{ykEMTEO|^$?s#=&lVC zoPMf+DQdhLy3g2E59!U) zIt=U0@)?}R9dZ&0R-YE$5Myx+lPFsxt8E7XIsiVEX#5Wi|K|VeD*GX=ytTIWU(ITe AOaK4? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST new file mode 100644 index 00000000..46a4002e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPCAR ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye,Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPCAR.TEST ;; ;; ;; Syntax: (MAPCAR FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; ;; ;;(do-test "test mapcar0 - syntax checking" ;; (not (or (nlsetq (mapcar #'+)) ;; (nlsetq (mapcar #'- '(1 2 3) 4 5 6)) ;; (nlsetq (mapcar #'* 'a 'b 'c 'd (list 3 6 9))) ;; (nlsetq (mapcar #'car (+ 2 3) (char-code #\a) (cons 1 2))) ;; (prog1 nil (makunbound 'fun)) ;; (nlsetq (mapcar #'fun '(1))) ;; (nlsetq (mapcar 'm 'n 'o 'p)) ;; (nlsetq (mapcar #'progn '(1 2)))))) (do-test "test mapcar1 - test cases copied from p128 of CLtL" (and (equal (mapcar #'abs '(3 -4 2 -5 -6)) '(3 4 2 5 6)) (equal (mapcar #'cons '(a b c) '(1 2 3)) '((a . 1) (b . 2) (c . 3))))) (do-test "test mapcar2 - sqrt & gcd" (and (equal (mapcar #'sqrt (list 10000 400 9 144 169 81 121 #31r100 #27r100 #17r10000)) '(100.0 20.0 3.0 12.0 13.0 9.0 11.0 31.0 27.0 289.0)) (equal (mapcar #'gcd '(10 3 9) '(20 9 45) '(30 27 54)) '(10 3 9)))) (do-test "test mapcar3 - max & append" (and (equal (mapcar #'max '(10 20 30 40 50) '(1 200 3 49 5)) '(10 200 30 49 50)) (equal (mapcar #'append '((2 4 6) (1 3 5)) '((12 14 16) (11 13 15))) '((2 4 6 12 14 16)(1 3 5 11 13 15))))) (do-test "test mapcar4 - subst & list & null" (and (equal (mapcar #'subst '(hat ball pink) '(chair pen blue) '((this is my chair) (that is your pen) (blue is a nice color))) '((this is my hat) (that is your ball) (pink is a nice color))) (equal (mapcar #'list '(1) '(2) `(,(+ 1 2)) (list 4) (cons 5 nil) (car '((6))) '(7) '(8) (cdr '(nil 9)) '(10) '(11) (list (- 14 2)) (progn '(13)) `(,#14r10) (union '(15) nil)) '((1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) (equal (mapcar #'null (list t nil 'non-nil '())) '(nil t nil t)))) (do-test "test mapcar5 - lambda list" (equal (mapcar #'(lambda (fn1 fn2 fn3) (let ((x 10) (y 20)) (list (funcall fn1 x y) (funcall fn2 x y) (funcall fn3 x y)))) '(+ - *) '(gcd >= cons) '(list eq min)) '((30 10 (10 20)) (-10 nil nil) (200 (10 . 20) 10)))) (do-test "test mapcar6 - tests with different length of lists" (and (equal (mapcar #'>= '(8 20 93) '(87 -40 900 -2) '(2 81 90)) '(nil nil nil)) (equal (mapcar #'expt '(2 4 6) '(1)) '(2)) (eq (mapcar #'+ '(1 2 3) '()) nil))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6ac055d2003639cb4aff6cf91b7073808e4bdc83 GIT binary patch literal 988 zcmbtT&rcIU6rSCswa}I<4Hh*G^^$0CKQwNSSfA#GT-#f67g zVQdVdO0`&GMl#9V8>x6ab?y2{UmBU&F55r%BvSEMYBVv@ceK4F$YlUP0krwA7XTSZ zz->9QLa|BJbS8^cf^t}Ko30aJTGYIW4c8eMh4pepEm;q&5|^`F0|Ef_Vr!Wp8@FllH412OQMg|iE;6H2H_HLm8+jHVN?z2#qLRs7_oe6&AJ3A-!c z$LA?=cJSPQ;N$3?J>TE9=Vi7cZL;x1@87vX1ZL~asaagJU+WPj ziKP>9Z|Cd%!w;GNCgB7JYxbvm07TYL$%4JRN0@!soPJLB0chIK$do9A0chDf(b*_Z z=PLj}2!M96aHeU?MHz@b_my*AVXDV7{I=9dM8>n&P;X@zLMBW_>|t#fP&7ofN!7qK zZ?J3BI(_h)b0)<(QTRK9>WUYX!d|ZwWLMv>V8hT2RnOCzJXNF++YnL^nNvHssd%gh za_mGa!x8{q5AUCkx8pk_@~3qphbVWy@k6z|VPJA>K0JZP_E~K3k0uS7xOd7LL=DgDq2X-0Y>y*O1_iTLpgdddU?mKU&GY(%|C(6eKcBceF6(R#B#*zu1b>KP| zsa31P;Z-yYmloJ_T7<=w?n~g<>Sdm`?Y@)*QM&7HitJ<75Ys0J?pqGDoC}(P5yk3> b+Orvo4U{##AWvhp-p=b3dr|P_($Uc`{N5;Z literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST new file mode 100644 index 00000000..fa811802 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPCON ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPCON.TEST ;; ;; ;; Syntax: (MAPCON FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (DO-TEST "TEST MAPCON - AR 7987" (and (eq (mapcon 'car '(1)) 1) (equal (mapcon 'car '((1 2) 3)) '(1 2 . 3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..aec2214e279d9dbf76385269bd3e340090e1ea9f GIT binary patch literal 2623 zcmb^zTWl0n^v>N!-^+H{wo*!&6biaB)jot$ewa?D>~?2o>g+6S(WI$;xV77deW1ih z3X-6418i5DxsdvbB>rfYMkA#yjhdKX8cj&})IZ~oA0#Gz7`2`=vxTLY;D_1XIq!4s zJ?EZtnAn8ll_DI5b*ieBu$rJ4~kN_?nr%M zG)K}uIoLNnIKUe-gHr>2rw;J-hk0>gayS7codbKY@6NIzLaP(X;6IEXoy^acz$Y6$HiMHW;sA_vTrnaqc?2(hTFo5|7! zetLXDNDQ7FOyF@wrwB)gc`2FS9#bVFq^V|_o8^kli^-CZDs;lp#A7m{`B^XMoimdq zhlFOKNr;G@3R#%XKT8Pxe2kFYC#>x($5+DK(ir(=HB7szDoZ(cyw|f9@Abm+SsFlU zp3PsOix7*^>j!Rc`I=UK=?%@F+5eJO4ksJ=`7YDSIn7%M4&Fq}R|#&katf-MJDO*G zu}1SIN?s%c{)z}$e^2w}lC$yI_zH-8XY>4AdDn_7I; z_C2yVn(G4bIQm&MKo?H0Y^t?xRYTg++?Sx)c#AvkMZ0`I6lQ1Z?>|-)Hc z!(KuQ&3BVk0ZCKaLU{Rwps2PfvM#iSfTJFZ252!Wpl(<$=&sU$BpOms&}Ad0Lw874 zd%2@MQA3VU?qLl>3$P-GhZQ)sK}UH4vaV~opv8>Nm=SPz!Js%Gsy%|mj|LdDR%zqb z4)r()VNUGJ$FR{p0Z;CBO^=8Ml2o=1GfdpA8ZGxkUN$gxoz2zuPr+=4|^?$h+$d44Wrt5R(YJ2 z9l>mfot?7Uwhg%SEudXiI+2=%$>vruR|=9Zvt0nV1v~0hvZvpa7*P>dNnJ(<^Cs2Oy%PFiPi-lPQ+rw(j zB$t3S0&DC-;=;&jy{F7H1%GT0eyng$0tfw~bU!HO z`bQpUI_}5G2dczhjRLr!4(fCx3Y&E}TzP5}e~ z?as5rUx8+ScLX(80kyqyOMu#5xi0|Cdc6i{*6YXfx#H~^kzpYK09o^ zCTY!+X$)JWcTMxAHE(9GVv+a&q%~irEMk%H>iFk0|2Y+@xlpFIBdkPJ98AGmq%w%} zvxD9U(`ALOMChtYZ)UEvt$T@?+?nVbePN&vtM*XW!b9YO8@8$9?K^9mMZE?F(GT=ZvSnjzcQcrxdL zB^uD%7^^{W7?WlDZ?IB`qk*e4(@rj%PONiQg9p^<#s{6NGSdZ4>UL5}ZH5^1C8eCRDgoK8>EObCML>TEST>7-8-4-MAPL.TEST ;; ;; ;; Syntax: (MAPL FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (do-test "test mapl1" (let (list1 foo-var bar-var) (setq list1 '(foo bar foo bar)) (setq list1 (append list1 list1 list1 list1 list1)) (and (equal (mapl #'(lambda (x) (cond ((evenp (list-length x)) (push (car x) foo-var)) (t (push (car x) bar-var)))) list1) list1) (equal foo-var (make-list 10 :initial-element 'foo)) (equal bar-var (make-list 10 :initial-element 'bar))))) (do-test "test mapl2" (progn (defun fun (l1 l2) (let (result) (and (equal (mapl #'(lambda (x y) (cond ((member (car x) y) (setq result (append result '(1)))) (t (setq result (append result '(0)))))) l1 l2) l1) result))) (and (equal (fun '(1 2) '(2 2)) '(0 1)) (eq (fun '(1 2) nil) nil) (equal (fun '(4 2 6 4 2 2 2 6 8) '(4 6 8)) '(1 0 0)) (equal (fun '(1 3 5 7) '(3 5 1)) '(1 0 0))))) (do-test "test map13" (let (result) (defun fun (v w x y z) (equal (mapl #'(lambda (n1 n2 n3 n4 n5) (push (append n1 n2 n3 n4 n5) result)) z y x w v) z)) (and (fun '(1 2 4) '(3 5 7) '(2 4 6) '(10 20 30) '(99 88 77)) (= 3 (list-length result)) (equal (car result) '(77 30 6 7 4)) (equal (cadr result) '(88 77 20 30 4 6 5 7 2 4)) ; (prog1 1 (setq result nil)) (fun '(1 2 4) '(3 5 7) '(2 4 6) '(10 20 30) '()) (eq result nil) ; (prog1 1 (setq result nil)) (fun '(#\l #\k #\n) '("l" "k" "n") '(l k) '((l) (k)) '(88 99 00)) (= 2 (list-length result)) (equal (car result) '(99 00 (k) k "k" "n" #\k #\n)) (equal (cadr result) '(88 99 00 (l) (k) l k "l" "k" "n" #\l #\k #\n))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7f9dc3e77720bbd192378d6e735ffcd323bdac77 GIT binary patch literal 3255 zcmb_eO>7fa5PrLB=RdA(AW6gDHjqG;E|5Qd5?X2FY<`HdFW8%g^b(oG!7h%S#tssy zKq(bf4z5b#7VT>Vk$T`jrOI$B1tqBMfddj3s?wHTdf?brs?}r{*uA5>eLk z^JeDFd^7Lu&JyQQpI`PR#wVh&@T8oWN=;0qqjj)dhg(97@mXh1*Rt@(O) zw>6Xm^HxSC!=Y4oR5qu=$IU4J#u|3uV@a>GB>!?T6B|E}e))%TX}8 zV5Lj;s|VC(wNLB!_XJIH@j~fYLYxJd%U6*bhlT5L^6=(iad3OJM{uHcAu{Y*j10Ts z@h%$Y-=nVV_Tz*Y)gV%rMcvd}2dgvG8>t?4gRLPhWPd=Kt{Un4#|M zE`z#YSFoUNi+X8A9h5OcD*ym5Kmh!%d7c1k14JoFH}2Nl3D?)Ycv1!X7A=dyEgyzmE_ zz==J**wYB~)9&k*MY<(Jw`42r#tzGiRGy>qIqJ6i?9CoRe5nh6-0)Kh@n9Id7OkLF zbr5TYRzb@vpaUx{r*07@AUn^2e<6eGbmz+QB@k*m$=o|XLXtv#zZdCD-WoOz_R ztL=ej0nX0a@o&vVvcvzkf_jMl9I?OVxj)YwK@t^DyDDZQ?x>rH9_!=uCdEgMjvl;G z)o#t`@aqA!y$3W#S5OgMtXM38ryL$9JPx?JJ&I2=ecft6HwOZ6_4@eTT@V}!ntGoo zJZWK4g_TNPRxGW9>)NI0fdCDtbinK%FcoP%IFu=xF{E;RP+@|!0d&QFYILc1ZLho< z@KT3YL(Ai@2Cst<=D-)iM!4P`f5R>Xoixy=nJE5+8TkeR0o}-Z;V=Q$9>UuC{{Zl5 zLETP+;fq5086uTp3aVc>y3B6W-Dg!uX4nQK=U4@jDOQQ37I)VA`*ouO#TpO`1Ns|! zAgH6fnN=gH;zYd4BZyz{2;wCkK|BdAPKe+i0!#62kX{N7^|e#KntSh|zL)19HocBs`|@C8p6nVEVNn0wOfBmw}MG+?L$ow&W(O^nlj!02APyK4PRKQ`Bv)+d z5|j5pKcr4dnP(gB_lK2kN`;dtc|0@`izZVovMQsTnOZcvWo1MwBjNvCTF{sWNxMyaHtDd5 z4g_sQR>yWQ1)axHs<-(FgkZI}hASnHNHChBQv$v8Ip{^nf$U{a3L9z&HX4%0rs5;1Xd;eVoMzjR z9Kkv>#Y}+;YO&H@=E0sMzL7a~AsesCq6;&Xo0?4rDL39e`oYe}C>e%BGnp8dCql==azo=mJS{$d z3ePq9mSaRN06>r{5d;B}D8$L&jjYG9hS`C%oUDeccd&YpLBPWRtOP7)L}2PGag84a ORxdo7Ci&#l($c?>#^6!_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST new file mode 100644 index 00000000..bbe93d9b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPLIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPLIST.TEST ;; ;; ;; Syntax: (MAPLIST FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (do-test "test maplist1 - test cases from page 129 of CLtL" (and (equal (maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) '((foo a b c d) (foo b c d) (foo c d) (foo d))) (equal (maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c)) '(0 0 1 0 1 1 1)))) (do-test "test maplist2 - append & first & butlast" (and (equal (maplist #'append (list 1 2 3 4) (cons 5 (cons 6 (cons 7 (cons 8 nil))))) '((1 2 3 4 5 6 7 8) (2 3 4 6 7 8) (3 4 7 8) (4 8))) (equal (maplist #'first '('x 'e 'r 'o 'x )) '('x 'e 'r 'o 'x)) (equal (maplist #'butlast '(1 2 3 4 5 6 7 8)) '((1 2 3 4 5 6 7) (2 3 4 5 6 7) (3 4 5 6 7) (4 5 6 7) (5 6 7) (6 7) (7) nil)))) (do-test "test maplist3 - list-length " (and (setq long-list (maplist #'list-length (make-list 50))) (= (apply #'+ long-list) (/ (* 50 51) 2)))) (do-test "test maplist4 - lambda function" (equal (maplist #'(lambda (x y z) (append (reverse x) (reverse y) (reverse z))) `(a c e) `(b a k) `(l o p)) '((e c a k a b p o l) (e c k a p o) (e k p)))) (do-test "test maplist5 - tests for different length of lists" (and (equal (maplist #'(lambda (x y) (+ (list-length x) (list-length y))) '(1 2) '(2 3 4)) '(5 3)) (eq (maplist #'list `(a b c) nil) nil) (equal (maplist #'cons `(a b c) `(d e)) '(((a b c) d e) ((b c) e))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e2da19554019c2168e58b4704db9aa8d0b999f89 GIT binary patch literal 6507 zcmc&&du&tZ760ycukAc+*Ku4ogaq7{5a!~b(2zhtT`!Ik0?xgu?TogX7O`OJOh8Z) zx|iA!RwlN30w<8&yA@5^q*bk2)lI8TG;1<#>&6}(Ohek(KUF8eChecL`;TqP&N=tt zN0RbbV2bR|=ljn2o%gx-OO81nkH$mMkwZs@52i;$BS*)N932lG7#R(XjT{{vN{0@> ze(0-FH4%GemmJ;Gvc0t`S#&Zqn%*~_-XBUGO^@y0_vMYD)@>pA$msAv__1{>knNpq zZJiHqX{qX#lW_y>hB6(UZJRsWT3f0X&P@xx5ysdMo5!V+F&`6|HktK>Q?XIKIyCbqS(iZ8H`}<=Fc5b@*IAiX2(Ui9{v%7`!hk4IW zcJsaK>T3i?W)AlUz4MttAAJ1q3CyeB(_dG8`3TB5upZ7&s)0=XpdYwZ zF9*5&Wd!)$4_+6}nMkx0z%qkDV9jNY4G-4Mt96rV-3ir)0>$#RMztvQb7o=ujVyq|c+{{3ezniFwPQQy;&MIpjidKH(}XT3zl73N!V|#7}(4X!@`-(HY7xABHxHPh5qqj zB2H&jpY3A)14!MmVJmAZmpf;Rl{>F(OIfW^$Ad+x7h3P;I)0L}cx&AeQN60~=KB2| zGtEZN`Y+YwbyN*DoY~@+P!Jv|>>~@5U0pd)%?8b`5a^6K;bz)x zKx%aGjuHwz4*9g^;x+2=X~T-rR!3?jMz!aFl|!FxQCYcRySIUT@PNl>Eezmke8jJs ze@+eHa0-Yym_y%D1Na7DJ&5xc%*+TE%_25aY`r;r;=_JBsKbXn=z}L(U>YCys4s~4 zK~rDQeB+>(3$q?xv$XF0e`saz-+iq!8B=Fj)+X{@5X7Pvf-U$$FlW3k-DD2mzB6;f zeaWi1noq1bV}jgH&E3w+*ftt4w_I_rTNS6?M(+Pdo$Sip);Y6(xoUgVoM1V65v3V+ z3z?g{ol2X`c#s|WS6XT#bb%c&R*D2dXi!8(<}Ks z@bSW@3O)|_NO1Y82}k8rbXO!1OARF8@)V`pmoxc9G8OCN!eWk;8rG{tzg{WU!iCEl zjwKRmBBBnY`Ug^BF#rPYu&g{0q5Wi7hnrVTd-(;QlzDnikKi#-iwc zIP>h$YjN432VklE51mz>HI}usRJ>#?+l-|S6o~T9B(S^wLKv<;5r*pmVK{@d>8zzq zr$n3LKWJ0@J8gs#QGx3!c#Grt$p45-~b^^hRKD`hees{Jo^uah*gQ9}}I{BiYuBjE!Ix{NV7T8Tk+6xyg$3XSDC3vdQe4Xd))3Vv(|Dj`yZw2|1qB ztC0;#{;>fy6{BQ(y7UJT!iVtdbWCAoz7)RlC9pv|!}TTszt?g6ZV-_(3MT@mpF7Hg z9$rqU;yvI5AqfB~eu?gpCrG`stju0pQAK}=NRKw<5GC$#g1qZG62})77XHog`(OBV z9S{CW0n+=>Nrn7&T_V3-lNb@O0ZR-*TpU(cri>m$^NK2v$dc+Tt!1+=U0}S0iyiIS zUPeQ66iUN&pZ-N;avSI{&yAV{86!mv2#fVvUf5KpF7n2TsPh^^+tja7aiON2Khr@I zn}9Fpk4YT}lRAU2nuAoA6go=0S^}Lbp~jK2irsmL)I5(upEupWP6rmVu#1Yls0on& zakRKl=}x(fZYSs|WL>i;$4)op*zxD(bL@D&6wvV;m_;^PYQa)t^1yaUt|3;1N#xjA z?6IS%fQlJ+G!W|IgpnqDU@RI!5{!xBgh|*Sb~>du2^GqsBsa8aW0LFE5RyKNyjEVM z0b3Gml;UJeQT$Q&@EIHMK|Z$32;va>C1(?VjFA3_!X1l3$eSpH!be8$<9HUnUm6raGksY! zo`pwjdxefNp_b)@7=*@(7=uw=aGyanF7X`rf}v!{W_=Pp#gV*fDVK#(AK7=oCHCRM G!hZqvlK_YS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST new file mode 100644 index 00000000..34766631 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST @@ -0,0 +1 @@ +(do-test mapcar (let (sideffect) (and ; Simple stuff first (equal (mapcar #'abs '(3 -4 2 -5 -6)) '(3 4 2 5 6)) ; Two lists (equal (mapcar #'cons '(a b c) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Two lists of uneven lengths (equal (mapcar #'cons '(a b c) '(1 2 3 4)) '((a . 1) (b . 2) (c . 3))) ; And the other way, just in case (equal (mapcar #'cons '(a b c d) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Test of (go) out of mapcar (null (tagbody (mapcar #'(lambda (x) (if (eq x 'c) (go mapcartag) (push x sideffect))) '(a b c d)) mapcartag)) (equal sideffect '(b a)) ))) (do-test mapc (let (sideffect) (and ; Simple stuff first (progn (setq sideffect nil) (equal (mapc #'(lambda (x) (push (abs x) sideffect)) '(3 -4 2 -5 -6)) '(3 -4 2 -5 -6)) ) (equal sideffect '(6 5 2 4 3)) ; Two lists (progn (setq sideffect nil) (equal (mapc #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(1 2 3)) '(a b c)) ) (equal sideffect '((c . 3) (b . 2) (a . 1))) ; Two lists of uneven lengths (progn (setq sideffect nil) (equal (mapc #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(1 2 3 4)) '(a b c)) ) ; And the other way, just in case (progn (setq sideffect nil) (equal (mapc #'(lambda (x y) (push (cons x y) sideffect)) '(a b c d) '(1 2 3)) '(a b c d)) ) (equal sideffect '((c . 3) (b . 2) (a . 1))) ; Testing (go) out of mapc (progn (setq sideffect nil) (null (tagbody (mapc #'(lambda (x) (if (eq x 'c) (go mapctag) (push x sideffect))) '(a b c d)) mapctag)) ) ))) (do-test maplist (let (sideffect) (and ; Simple stuff first (equal (maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) '((foo a b c d) (foo b c d) (foo c d) (foo d))) ; Two lists (equal (maplist #'cons '(a b c) '(d e f)) '(((a b c) d e f) ((b c) e f) ((c) f))) ; Two lists of uneven lengths (equal (maplist #'cons '(a b c) '(d e f g)) '(((a b c) d e f g) ((b c) e f g) ((c) f g))) ; Two lists of uneven lengths the other way (equal (maplist #'cons '(a b c foo) '(d e f)) '(((a b c foo) d e f) ((b c foo) e f) ((c foo) f))) ; Testing (go) out of maplist (null (tagbody (maplist #'(lambda (x) (if (eq (car x) 'c) (go maplisttag) (push x sideffect))) '(a b c d)) maplisttag)) (equal sideffect '((b c d) (a b c d))) ))) (do-test mapl (let (sideffect) (and ; Simple stuff first (equal (mapl #'(lambda (x) (push (cons 'foo x) sideffect)) '(a b c d)) '(a b c d)) (equal sideffect '((foo d) (foo c d) (foo b c d) (foo a b c d))) ; Two lists (progn (setq sideffect nil) (equal (mapl #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(d e f)) '(a b c)) ) (equal sideffect '(((c) f) ((b c) e f) ((a b c) d e f))) ; Two lists of uneven lengths (progn (setq sideffect nil) (equal (mapl #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(d e f g)) '(a b c)) ) (equal sideffect '(((c) f g) ((b c) e f g) ((a b c) d e f g))) ; Two lists of uneven lengths the other way (progn (setq sideffect nil) (equal (mapl #'(lambda (x y) (push (cons x y) sideffect)) '(a b c foo) '(d e f)) '(a b c foo)) ) (equal sideffect '(((c foo) f) ((b c foo) e f) ((a b c foo) d e f))) ; Testing (go) out of mapl (progn (setq sideffect nil) (null (tagbody (mapl #'(lambda (x) (if (eq (car x) 'c) (go mapltag) (push x sideffect))) '(a b c d)) mapltag)) ) (equal sideffect '((b c d) (a b c d))) ))) (do-test mapcan (let (sideffect) (and ; Simple stuff first (equal (mapcan #'(lambda (x) (list (abs x))) '(3 -4 2 -5 -6)) '(3 4 2 5 6)) ; Two lists (equal (mapcan #'(lambda (x y) (list (cons x y))) '(a b c) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Two lists of uneven lengths (equal (mapcan #'(lambda (x y) (list (cons x y))) '(a b c) '(1 2 3 4)) '((a . 1) (b . 2) (c . 3))) ; And the other way, just in case (equal (mapcan #'(lambda (x y) (list (cons x y))) '(a b c d) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Testing (go) out of mapcan (null (tagbody (mapcan #'(lambda (x) (if (eq x 'c) (go mapcantag) (progn (push x sideffect) (list x)))) '(a b c d)) mapcantag)) (equal sideffect '(b a)) ))) (do-test mapcon (let (sideffect) (and ; Simple stuff first (equal (mapcon #'(lambda (x) (list (cons 'foo x))) '(a b c d)) '((foo a b c d) (foo b c d) (foo c d) (foo d))) ; Two lists (equal (mapcon #'(lambda (x y) (list (cons x y))) '(a b c) '(d e f)) '(((a b c) d e f) ((b c) e f) ((c) f))) ; Two lists of uneven lengths (equal (mapcon #'(lambda (x y) (list (cons x y))) '(a b c) '(d e f g)) '(((a b c) d e f g) ((b c) e f g) ((c) f g))) ; Two lists of uneven lengths the other way (equal (mapcon #'(lambda (x y) (list (cons x y))) '(a b c foo) '(d e f)) '(((a b c foo) d e f) ((b c foo) e f) ((c foo) f))) ; Testing (go) out of mapcon (null (tagbody (mapcon #'(lambda (x) (if (eq (car x) 'c) (go mapcontag) (progn (push (car x) sideffect) (list x)))) '(a b c d)) mapcontag)) (equal sideffect '(b a)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ee050df1d09f18f38f2a8993df2504edcaa335cd GIT binary patch literal 751 zcmaiyPfrs;7{=e-rGF@ev_wfX1}7w3HVz5U3f7C`c1jD&EX>XZIX3N>$=`3-Qkm`LE@Y2STj-sgFLGc$zP3&TW)x8G^C-7fM5{m!6| z8eSLmyg|3-qK4GbYs2F7O_>-Q3r`nQ_O+E-*RA&5IuZl7SFgT$gchG5(&@I^vRGY} zzmE&KTwyuCkSY<|ymI?*&q^V;T*xmiq%KcSl#B-eHModA;{X}ZAUN_fx}dherHV;0 zBb!tYhJl}yEZDIr5B%&B>U$mBc3-;f2xq?s3PAA5PnH~Jh>FF6W96-q4nF#m6^6GY z8d;;DCjYub?ux8e@G8#ZH49Ep;ycj@-<#*_%Gm*I|5#UdrtW8zSnGTbVESDmtu)Vm zGFkr~ZhTg9xLHITa3;xV>u&x~VF+cL+-lC$vO3t|cYrlukLf zIJO+IUaKe7{sPm?s5(++he1sd3g!UsIS>QhuQ8{-==1`+5-(DTH v4z8X}q#e#H!Pnqel{vEpr$kVEBhIV{%86-*6VWyqx$RhjhIir1?B(SjE}h@B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST b/internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST new file mode 100644 index 00000000..5fff190c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: go ;; ;; Source: CLtL Section 7.8.5: The "Program Feature" Page: 133 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 14 ,1986 ;; ;; Last Update: Oct. 14 ,1986 ;; ;; Filed As: {eris}cml>test>7-8-5-go.test ;; ;; ;; Syntax: go TAG ;; ;; Function Description: The (go tag) special form is used to do a "goto" within a tagbody construct. ;; It transfers control to the point in the body labelled by a tag eql to the one given. ;; ;; Argument(s): TAG - a symbol or an integer ;; ;; Returns: This form does not ever return a value ;; (do-test "test go" ;; ;; the test cases were incorporated in 7-8-5-tagbody.test ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-PROG.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-PROG.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..79b8283d5b2cf4f53fddd93d3f2c8e154f693a00 GIT binary patch literal 4601 zcmeGfTWk~A_0Ej#I1d{;B!L|s8D3d1ah5;`A*C#inGgrZ6a0t+rJHpeC*x)kr?G+3 z2b(}kOXV$uurPO9q^kSVpGpB$DzGc8YFBMPkdRi}s%pQtqUv@Rsa4fgx1{IXYX^q~ z(T{#s_RM+QbIv`l`g?%k+ts;yZ%ftU^{av_LkLNd0)k3HTtp(~<-E%iRU=VvcOa;GL%u%MW6qg* zJH+CRMbxmFckfhknJKT4I+-#soQW(E2r)0^?cK4EKN`?N=DaW?)R-6ZjzGxU525)E zsYJ9Ft)O+m%scjYJG{HS{bB78xqkJfvxL}=qa%0pw|j-#lfqZu=@sM0Ww&5O?p=Hh zIhm{DAtzGzZt4h@sKFw2Szib)8~7rlG-pw(c{#bJM9%5?5{mHNj9&V^Jw{0F*@|{S zzYQ*EP9Pu79loeJ-z8*D|E}ij6$J;N3#;O%zEjd^)?8%XW;Yf}a z^yINZx>&P4&#jsK)SBH8Y-KgGY%kT!VL0LghWJ5zAU^nkd(#T7L0hk_*4ApQWU?GT zCd2G{?Yw@2d?$VkZQQ&0_4sgnP(~FwKFD7Kvb(M>eoWh{HEEkQMcarKm*v%<3jNzt z(%k=*`0)6L57Y61hw*{S@!=UAtbj3;c3W110gu+KwP-t-I%?19=ZnhNz5jIjvhhM1)`Qz6YtBpGU#J_`+T@|O!a}_vaqNO&FS7omIj`wM&P%fk zzdNV3)z0d*V3Z~2CpUyKZe{t$ogc-@Vn=< z_9qP2aKmfC@cD7ALmujY#ar~_ujjOm<>KUzTzsA8gq4i*cgjPZg@s0#pJN{z6-BHb zJYl>GhNH-O?8z_BX`SV!Z@$J2uSdg;5a2#}XderZAuK?SVSvR!2S*kjn}q=PEi>E1 z%{D@KkCx*4`#EiYQEE<~Ntd>;rB-Nv?t*xFE0ov&AEo*$Mwc;YG#Jf>!(HEmBE>EG zuGTva8?F|Vhk^y84)$n{PApD5n)vs`XKsr}3q6*AKAV&tz!qB2`j=$2AoK|QYin7f zlx@OyL!baV@arMA0iO@?{TCKa!_yY?obF1yi0FZ{O*pu8nBg%bZbM!db%R->^n9L9cj zn%g2rBT=|X|d43ek6ZSHzD{n-HhNZPF?2IB&WX2 zslA-q$|(z@$ln-6?z8F1JvKdghpyWV)@(arDl4lRQXaUw*+N(b48yjbHUY4HN~;i@ zq*yBJ1ZTd&fHa5tcykNEm^98rq+vc5VL(hVrg)rFeH^R@Jx8DKa4f{)1Z8MuCxQyJ zcqFDpG4rB@GX-E;pkhaWCw$6y!k_6@q<%|l5WG*fA-K<}d(?x}dz|_?m;5n{L%7Z* z-{jOaE_sntuW`w7T8-*DmrQYLm`fhxR48zQrW)AgZ#juFd88(*`z#Pq6W@n%Z zl4!BvPz~c*XCT=&tc=YDFAKgz92dbO(6KsZEHiebf5387KB4$cGykRX46sgNk!F?Q z%n3-w$;5OzF>ItD2}`NTDwFUDc}h=BDmgu+q+lR3%FyA=$Y~{=g%l=|I!l)LH8bDR z*`>lBt@2Mj_WjBxWi40gwKI`o_qCv}8+cZ5VGAE|oUPVha2)p);Vj45itFPzTT{@h zSYozn{_we&$#2YjcX`Z8)<}=(Ipef4kr_#krlJ4Ya59mFsFRr~; zasu0%$SkXwLl7m4)mCAzbex1>W}vUF2V;GGN2w!&3lRL3s>Q=v6 z6l+GQ4e$~h;3ZVUGPRau8a6Z^`5(C5`=rY+qsuhg@oZ09%RKcw!_!U6Jzaa1G#wCb z9T0EpcX}?(_PPR>zKxf<+dV=+kbC7j0r7T^cx&N90=I_#a3JJYy;`@|AM}L-(W4Ty zOW9Tv2ht6zmpUojh-fv`gcpdcx=LE~TRKc~K)8KCyc2k%7rr>^XM0=$p;wT5P&vnHK7fMc@|ql<8hvHXX&*d5Z|kyOX?$?4Kcml>test>7-8-5-prog.test ;; ;; ;; Syntax: prog ({VAR | (VAR [INIT])}*) {DECLARATION}* {TAG | STATEMENT}* ;; ;; Function Description: The prog construct is a synthesis of LET, BLOCK, and TAGBODY, allowing bound variables (processed ;; in parallel ) and the use of RETURN and GO within a single construct. ;; ;; Argument(s): VAR - a variable ;; INIT - a form ;; DECLARATION - ;; TAG - a symbol or an integer ;; STATEMENT - a list ;; ;; Returns: anything ;; (do-test "test prog - slightly modified test cases copied from page 132 of CLtL" (flet (( king-of-confusion (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (prog (x y z) (setq y (car w) z (cdr w)) loop (cond ((null y) (return x)) ((null z) (go err))) rejoin (setq x (cons (cons (car y) (car z)) x)) (setq y (cdr y) z (cdr z)) (go loop) err ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) (go rejoin) ) ) ( prince-of-clarity (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (do ((y (car w) (cdr y)) (z (cdr w) (cdr z)) (x '() (cons (cons (car y) (car z)) x))) ((null y) x) (when (null z) ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) )) ) ) (and (equal (king-of-confusion '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (king-of-confusion '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (king-of-confusion '( () dummy)) '()) (equal (king-of-confusion '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) (equal (prince-of-clarity '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (prince-of-clarity '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (prince-of-clarity '( () dummy)) '()) (equal (prince-of-clarity '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) ) ) ) (do-test-group ( "test prog - prog allows bound variables and returns nil when the end of the body is reached" :before (progn (test-setq a 2 b 4 c 6 d 8 e 10 buf () ))) (do-test "test Prog 0" (and (null (prog ( (a 10) b (c (+ a 2)) d (e (+ a c)) ) (push (list a b c d e) buf)) ) (equal buf '((10 nil 4 nil 8))) (null (prog ( (a (cons b c)) (b (cons a c)) (c (cons c c)) (d (cons c a)) e) (rplaca buf (list e d c a b) ) )) (equal buf '((nil (6 . 2) (6 . 6) (4 . 6) (2 . 6))) ) (null (prog ( (a (evenp b)) (b (eq t a)) (c (and a b)) (d (list a b c)) ) (rplaca buf (list a b c d)) )) (equal buf '((t nil 4 (2 4 6) )) ) ) ) ) (do-test "test prog - go and return statements are allowed" (macrolet (( mac (m n) `(prog (buf (switch t) ) 0 (and switch (go ,m)) (go ,n) 1 (push 1 buf) (go 99) 2 (push 2 buf) (go 6) 3 (push 3 buf) (go 99) 4 (push 4 buf) (go 10) 5 (push 5 buf) (go 99) 6 (push 6 buf) (go 4) 7 (push 7 buf) (go 99) 8 (push 8 buf) (go 1) 9 (push 9 buf) (go 99) 10 (push 10 buf) (go 9) 99 (if switch (or (setq switch nil) (go 0)) (return buf)) ) )) (and (equal (reverse (mac 3 8)) '(3 8 1)) (equal (reverse (mac 2 4)) '(2 6 4 10 9 4 10 9)) (equal (reverse (mac 99 1)) '(1)) (equal (reverse (mac 7 6)) '( 7 6 4 10 9)) (equal (reverse (mac 9 2)) '(9 2 6 4 10 9)) (equal (reverse (mac 99 99)) ()) ) ) ) (do-test "test prog - with declarations" (equal (multiple-value-list (prog ((a 66) (b 88) (c 22) (d 44) (e 10) (f 20) buf) (declare (special a b c d)) (flet (( fun1 (x) (declare (special a b)) (list x (cons a b))) ( fun2 (x) (declare (special c d)) (list (cons c d) x)) ) (push (fun1 e) buf) ;; buf = '( (10 (66 . 88))) (push (fun2 f) buf) ;; buf = '( ((22 . 44) 20) (10 (66 . 88)) ) (let ((a -1) (c -2) (b -3) (d -4)) (push (fun1 a) buf) ;; buf = '( (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (set 'c 1000) ;; set only updates dynamic binding (push (fun2 c) buf) ;; buf = '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (return (values-list buf)) ) ) ) ) '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8907c505478611fe9e18e0e0638773f06dc4800c GIT binary patch literal 4685 zcmeHKYitzP6}~gGyMFC1GsYM)JUqM{*mxZb#yFHFtd}ufv)*g=;Rhm^Wxe)n8GBvt z8k#c=iGDdJ?GAyY2@q+hP7aJWGrK*$F=N4erzJI4Q0o*Ty|nSmDYv; z*S;3SQT-bof#ANzFEmxg7L26E)5&~#P>WBbbA!oO8nmVtw7}SS#ssFd6~vaE&CNTv zZEvh>55&UU+f!|JP@Cqa#>%+s5K5sUB^3zCNJ7^6g6xayvADlI6xRKbK$q^b zrmaFbM3UIJ=^irJyRdMXIF&g1$*Y`FYTGf^e94=BD-;|DgH_kDizs_Yq1LK z5}+%vidW$^bo*4bw?~CYjB5IC#<+ss?(LyI@4R&dUFtpDdkAV<#u}qa?;%F3@dm5` zzEqKGdVBCDTu%YKjyqgoJA(?3+rF-LeyR8H(NFFv!m~But=ISY<8l2ioCk!j{O54liw@eYYr~@s< zGp2(x;Lc@ppPCh=L5~gnZQk*Rr*O+7j@^p9%65GEC~j2;TA|hLIR1JHw=PykzgOhd zTpjwJ&c9O~*jb#dgZVl4saa-o%ODbloiRN&^e~bipTavAy1x3VBCjbqu7d=3sRO%M zf{bAaa*ifw4|+H=`_L^UxNDKydPT0Y(|a(V*FR3-7j3O+V=_}Z@a9XQ<*DuS_)=J~ z|7ESE{nyMkMObV0DZ)ClRuR^l4T`XV_R~g1uBR6E`FOn<>^tJmMzG1c7;$G67)ffsxu0?Z9rNm=4Sa zQYEe@mEt<$7S|H5s9CQUR{4TBvL{5}p8k$NWKUR+`rAT)ME1sfVjWo`u7PJYJgeYY z36BcTGei+rfVbt~trom318+4%7MB864VVI$4A>IDyns~#<_4?^Fb~*Pz*7!k)$mt- zFsuh6iEe*8j&{X-L=c@Y?tpQ{7YxLM9sZ~uPekFB9%Od{SFAr4*SkdF^BQsNBQ?@< zWQo*36v+=)0k2PwMsd`S6Y=gu+$S}Hk=qxD^!pi3r<0y1mC_dCmYRrH+DfXVZA6Ca zM)RZBjptxbiGyA;HqslzdGPL{AqV1AJWHbqCZbV2vfvU!1UhyC#%dlebTAOp`ShfQ z4tK*wlpXBq35R0LRTp@!>IsAsddy$Kb^#{EbUN<*30X-=k*uQRJ+hjTuYy8ZRPWKF zF`deBvKENrGfv*(B*%%$i1br1ap*7+C`#9uQ|W!?RC;xr;*x_&=sRZJDhtREZzR5smff1=l?dkn5 z0%HPxpas4sPqw+-shS>V0j3ax#k;Oy2Lfla_LpBd6ZO9 zbAxN9xpahU9^g_Z*K8p&)!fE4w{XeNH8*l;8P^oZ63|2sm?ru+m;T8#(LF9*VJn4x z$d(8ZQojW(T;H(@Yx3z_UK<ne1qeYQ1I^>f%&u-HE_D zZ72!fC4*XKlz&oC>;!AH1J(?5ooHPU!AQE>aB^;L?g0Rl&H>ui$46@$YJl-Dgu0h5 ziWS}a)!lIEpr07f6~^XI|1u*EIFP@ z9x>Cf9`mb|(?;Q|^th28)$&GKOT$2Rh_OeqgRf|r9IR$CWw3Ph46$uEa(f?OMJ-w9AFRaGtg9HO|vRMmWiN)_z@_XAQQ3^Q?t__qnXm z&#l7VMOkY(Gc#=D%~!OM>|kan1I@t3Q^_2poyv|;WN17)qKzeo(^}KEtu)DUBl~;J6n8Zmaa_62zS64srWNBAY2XqRFnTl)*p=uaZVU*fd9k$gPsMcEe z5o_T`sDhq#mUL>@Hthc&gx&dQ$S={5$wcduBW+p`sqYDqu3sGKs*9+8w{U&8c*D5a zac-(p4xRfZz2e>I5JH05soo5UH#)@Yv!5WiLv%+&k)ZC!?fzgm5DmrqC8(DL=T0w( z3Uo5@5;v(NRj?;~gV6GesL{A?z$Ckc8@t7uq1QX%n`GHkha3_*1+_!H4)b)1H)rp% s`|j+Y>2&+x+Qufsk@iFk?sSit?%74t5n4L$B4KfPqBkh~-rU@O0CG?vWdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST new file mode 100644 index 00000000..60baa5ca --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog* ;; ;; Source: CLtL Section 7.8.5: The "Program Feature" Page: 131- 133 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 15 ,1986 ;; ;; Last Update: Oct. 15 ,1986 ;; ;; Filed As: {eris}cml>test>7-8-5-progstar.test ;; ;; ;; Syntax: prog* ({VAR | (VAR [INIT])}*) {DECLARATION}* {TAG | STATEMENT}* ;; ;; Function Description: The prog* construct is a synthesis of LET, BLOCK, and TAGBODY, allowing bound variables (processed ;; in serial ) and the use of RETURN and GO within a single construct. ;; ;; Argument(s): VAR - a variable ;; INIT - a form ;; DECLARATION - ;; TAG - a symbol or an integer ;; STATEMENT - a list ;; ;; Returns: anything ;; (do-test "test prog* - slightly modified test cases copied from page 132 of CLtL" (flet (( king-of-confusion (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (prog* (x y z) (setq y (car w) z (cdr w)) loop (cond ((null y) (return x)) ((null z) (go err))) rejoin (setq x (cons (cons (car y) (car z)) x)) (setq y (cdr y) z (cdr z)) (go loop) err ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) (go rejoin) ) ) ( prince-of-clarity (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (do ((y (car w) (cdr y)) (z (cdr w) (cdr z)) (x '() (cons (cons (car y) (car z)) x))) ((null y) x) (when (null z) ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) )) ) ) (and (equal (king-of-confusion '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (king-of-confusion '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (king-of-confusion '( () dummy)) '()) (equal (king-of-confusion '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) (equal (prince-of-clarity '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (prince-of-clarity '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (prince-of-clarity '( () dummy)) '()) (equal (prince-of-clarity '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) ) ) ) (do-test-group ( "test prog* - prog* allows bound variables and returns nil when the end of the body is reached" :before (progn (test-setq a 2 b 4 c 6 d 8 e 10 buf () ))) (do-test "test Prog 0" (and (null (prog* ( (a 10) b (c (+ a 2)) d (e (+ a c)) ) (push (list a b c d e) buf)) ) (equal buf '((10 nil 12 nil 22))) (null (prog* ( (a (cons b c)) (b (cons a c)) (c (cons c c)) (d (cons c a)) e) (rplaca buf (list e d c a b) ) )) (equal buf '(( nil ((6 . 6) 4 . 6) (6 . 6) (4 . 6) ((4 . 6) . 6) ) )) (null (prog* ( (a (evenp b)) (b (eq t a)) (c (and a b)) (d (list a b c)) ) (rplaca buf (list a b c d)) )) (equal buf '((t t t (t t t) )) ) ) ) ) (do-test "test prog* - go and return statements are allowed" (macrolet (( mac (m n) `(prog* (buf (switch t) ) 0 (and switch (go ,m)) (go ,n) 1 (push 1 buf) (go 99) 2 (push 2 buf) (go 6) 3 (push 3 buf) (go 99) 4 (push 4 buf) (go 10) 5 (push 5 buf) (go 99) 6 (push 6 buf) (go 4) 7 (push 7 buf) (go 99) 8 (push 8 buf) (go 1) 9 (push 9 buf) (go 99) 10 (push 10 buf) (go 9) 99 (if switch (or (setq switch nil) (go 0)) (return buf)) ) )) (and (equal (reverse (mac 3 8)) '(3 8 1)) (equal (reverse (mac 2 4)) '(2 6 4 10 9 4 10 9)) (equal (reverse (mac 99 1)) '(1)) (equal (reverse (mac 7 6)) '( 7 6 4 10 9)) (equal (reverse (mac 9 2)) '(9 2 6 4 10 9)) (equal (reverse (mac 99 99)) ()) ) ) ) (do-test "test prog* - with declarations" (equal (multiple-value-list (prog* ((a 66) (b 88) (c 22) (d 44) (e 10) (f 20) buf) (declare (special a b c d)) (flet (( fun1 (x) (declare (special a b)) (list x (cons a b))) ( fun2 (x) (declare (special c d)) (list (cons c d) x)) ) (push (fun1 e) buf) ;; buf = '( (10 (66 . 88))) (push (fun2 f) buf) ;; buf = '( ((22 . 44) 20) (10 (66 . 88)) ) (let ((a -1) (c -2) (b -3) (d -4)) (push (fun1 a) buf) ;; buf = '( (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (set 'c 1000) ;; set only updates dynamic binding (push (fun2 c) buf) ;; buf = '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (return (values-list buf)) ) ) ) ) '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..241726d3853e5ad7c222ebaa5ec6800e187480b8 GIT binary patch literal 4003 zcmb_fT}&L;6`q;>0Tvc73$bBE>3}i9YZmeEHFhcMW%$c7m+a2gvEqcTVc1zS?9$!E z5=v`1j_X9~rWhmJGj**-RV!7k6p^TE>z{xkSL#C}=b>?wrc#yWsgbIx5ie~YLeII^ zvw&T-uF{7y-#O>IbI!eY?mhR;3g>t>91+8r`Gu6OX2r~6eqk{$&StV=F0+`OR>fKH zi!X*rRQlFvDExH$(N0%v2Q!^j6M1z;R2J3TOk$}`>^vfd7P2WFlwc6dzW$z`{_fs( z*KjBnVbT8UJBRywdi%Tj+Fe^WukoG?$8po#20|Ifc{m$qTq$_`iWE}RDCC;mqeap5u(mh0@`;99G7NY^?I<`3hsX;2x6$ zlQ6WZ2ZDj#fD#%xPKHi$H?Ngn;5cUp`*K^mGtS>ib7$|43nzws zRlGyHqODbHD_Q~MRgjAy=Tmo*9Ou1I(#mVM)@9KDw(|6A@;#1Q(Jsm30`CTGZQqGe z42e?8aTOf5k(wT-BYv2L_gh&?boaVmGv(RPro0=nZhL=S)`bt&<+%szn14jp>$ct+ zB%ZnVp$+lq?g!Wwm_uNcZ@sl2^)KoBh}Q=J^dLj%=_TUD{O_LE&TBjR42_7Fb$gk3 zX}@0~-Y4()rqyvbb{I3TjNjQ-*T%Q?FQTozvHkYL!TkRQ;y7vzq#OsL;jFG}Q?;P^ zKg5nucSB&k3?l2L5Lz#R*t!#f>kf#n+abJegZR1t3FaUH@yV11m~{65;cz{r=@?!$6=!SdQH@2^NLw63-McFX@d@qyoG z`5l)3RZ5j91^tKr8)nd*lXb_`?y zWN?G@Uw)Y!Tk9nKP)E@oxJCxZVBN+=G6>Dcplu~}Ub{{Pksg5N0t8t5Ev%P!ckUxt zQ9-L91RoZJ;1d@F$Iq>O)JVG+q&0ypKN76GY4u$fz}j7jzF1=Cu$8z8w;kpoLErzN zks!YFq*DP^cJIHd>MNQj<>7=T<7%PaA13n97#>D}(U3e8k)na)W8jfTVt%2~EECE> z+#n?&4iGz>d{zE%NC}SyqLLDi!pRk;N1roxGNwoq0{?gmh4{^K+kUgm)(odzrC*9h zNi;y>%4A&e+YZ1B75b^OruBK*LtMp!m$5DqeD3v=$JPWxXmXJ~R# zl82y;{bMlgkx&dfV1EaUlBo1GDH@Z|z7Eq{a!Q7@;V!h#nY9Qig9w9e20jKn1>2t) zyvN`d3~n;G$Y72^l)(`OjSR{t2%j1#KAgP613C`{$mTwcs4lBY8>OJYD=%&Fo?29}6;W^sN2 zF;QgmS|Tr|a$-6IZ)mERN~hKAd}hb{)0uQWkxHl1NoW9#lNn6oHws@?Fiq3BP?I>D zfNSRryv%Nl=sR}+2l;nn)nOED$<7XV=DWI$f{>?=F4Q`)$zK?c>L;ubsvpvpsNF{m zSB2x(#dm&c+%Q%JSg8%+s1#D9z#|JbGNwq;P$XuSV>9?9&%}u$u_?Y`6eb^;pkzjz zPNc=ta5%vQ)| z9%Nsl$tW~G@+ESq`33lafe(_)!;i|mn$C;#+c(hJwg1Rit*-V~dG=JgD$3nur6o>> z-6mk+vcC@14!QwlB^Hk;&^2@}gVP*F?W{S9@H~Sd28S4UDcJtO;9~~AVekfns|>!$ zV4A@=gH8r@40sB{rwo3_;2witQs6&*Y%chZjKco^I2Uv(aKrE)(5c{mY^=JCLdi@f zt%{9}bd%ur!JQ`LkKiMSkHh%r#YYc5=;otg%TB#}RA0u1IDPyQYC+U8s2xU4 zMXeXL=TPfG?HSa%QIk-^FUI$yMl*?z54XxFe0A4wp-jPM!;Ph;XT;2`NNX2tNZ5!o zZN+kxRr8D4G?c59jyYU(D!30}Q3dxUcc*#QD4g1rBEZU?IGcml>test>7-8-5-tagbody.test ;; ;; ;; Syntax: tagbody {TAG | STATEMENT}* ;; ;; Function Description: EACH ELEMENT OF THE BODY IS PROCESSED FROM LEFT TO RIGHT. A TAG IS IGNORED ; A STATEMENT IS EVALUATED, AND ;; ITS RESULTS ARE DISCARDED. IF THE END OF THE BODY IS REACHED, THE TAGBODY RETURNS NIL. IF (GO TAG) IS ;; EVALUATED, CONTROL JUMPS TO THE PART OF THE BODY LABELLED WITH THE TAG. ;; ;; Argument(s): TAG - a symbol or an integer ;; STATEMENT - a list ;; ;; Returns: nil, if the end of the body is reached. ;; (do-test "test tagbody - a tag may be a symbol or an integer , and it is ignored during the processing" (and (eq (tagbody 20) nil) (eq (tagbody |tag name|) nil) (eq (tagbody another/ tag/ name) nil) (eq (tagbody tagbody may have many tags) nil) (eq (tagbody the following numbers will be treated as tags 1 2 3 4 5 6 7) nil) ) ) (do-test "test tagbody - if the end of body reached, tagbody returns nil" (let ((a 10) (b 20) c) (and (eq (tagbody) nil) (eq (tagbody (incf a 3) (setq a (* a 2)) (decf a) a) nil) (= a 25) (eq (tagbody (incf b) (go tag1) tag2 (incf b 2) (* b 2) tag11 (setq b 0) tag1 (decf b 10) b) nil) (= b 11) (eq (tagbody tag (values a b )) nil) (eq (tagbody (block blk (return-from blk (push 23 c)) (push 34 c)) (push 56 c)) nil) (equal c '(56 23)) ) ) ) (do-test "test tagbody - simple go statment 1" (let (a) (eq (tagbody t1 (setq a (cons "t1" a)) (go t33) t2 (setq a (cons "t2" a)) (go done) t33 t3 (setq a (cons "t3" a)) t4 (setq a (cons "t4" a)) t5 (setq a (cons "t5" a)) (go t77) t6 (setq a (cons "t6" a)) t7 t77 (setq a (cons "t7" a)) t8 (setq a (cons "t8" a)) t9 (setq a (cons "t9" a)) t10 (setq a (cons "t10" a)) (go t2) done (setq a (cons "done !!" a)) ) nil) (equal a '("done !!" "t2" "t10" "t9" "t8" "t7" "t5" "t4" "t3" "t1")) ) ) (do-test "test tagbody - simple go statement 2" (let ((c '(results)) i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 i14 i15 i16 i17 i18 i19 i20 ) (setq i1 20 i2 19 i3 18 i4 17 i5 16 i6 15 i7 14 i8 13 i9 12 i10 11 i11 10 i12 9 i13 8 i14 7 i15 6 i16 5 i17 4 i18 3 i19 2 i20 1 ) (equal (block blk (macrolet ((mac (counter num) `(if (> (decf ,counter) 0) (nconc c (list,num)) (go t1)) )) (tagbody t1 (if (> (decf i1) 0) (nconc c (list 1)) (return-from blk c)) (mac i2 2) (mac i3 3) (mac i4 4) (mac i5 5) (mac i6 6) (mac i7 7) (mac i8 8) (mac i9 9) (mac i10 10) (mac i11 11) (mac i12 12) (mac i13 13) (mac i14 14) (mac i15 15) (mac i16 16) (mac i17 17) (mac i18 18) (mac i19 19) (mac i20 20) ) ) ) (append '(results) (mapcon #'(lambda (x) (reverse x)) '(19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1))) ) ) ) (do-test "test tagbody - go can break up catchers if necessary to get to the target (p131)" (flet ((fun (items elt) (let (a) (tagbody (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) x (progn (push x a) (go lose)))) items) ) lose (nconc a '(is not a number)) ) (equal a (append (list elt) '(is not a number))) ) )) (and (fun '(1 2 3 #\q) #\q) (fun '(10 20 "st" "fre") "st") ) ) ) (do-test "test tagbody - use Go to jump to a tagbody that is not the innermost tagbody containing that go" (let (a) (tagbody (push "t1" a) (tagbody (push "t2" a) (tagbody (push "t3" a) ;; ;; the inner tag shadows the outer one ;; (go g23) (push "wrong3" a) g23 (push "t23" a) (go g10) g30 (push "t30" a) ) g20 (push "t20" a) g23 (push "wrong2" a) ) g10 (push "g10" a) ) (equal a '("g10" "t23" "t3" "t2" "t1")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bee2669d50c6f71a3e55e6c3b0253ebfcde83e2a GIT binary patch literal 9048 zcmcgx4R9OPo!<|wR}&$@$ z8S37ZvB40+2olGMyRU7a^z){j;e_Yzrs2abv_o%t>Ci$BXnW--&`!(I!*|f(=B_#4 z|NnoIEypcQJEpOA-+TY>|L^_xy|Omlo{n@3Nq?b0-XU z)NkKjzwNrsB~8J2gj@TAI@i~4-%($;eRIj|*$J_tR}h4DVHz8^AXEslV4uoX)F$+J zBG43$=m8@b)oblBJL`g60&Q_UW@o)ywM=hcz)IbjvM`;a1A-_B_Q|ZPsm%x_!lq%5 zi^F1>eIn}#8-Z3xE!eCJk}Gcot&4Wne|=zAU~3?{FBWKsn4!IakZHsdv9?emE}WgX z>K;KT&0t_prk`pN&-IAWr(2}`O@6PabX$@oTMkPpQ7CSdIzM^W?Sg}e{KUhLmATta|d`mV*0pMZgLa@d7i9IMzJZ1Wchp~_Y;7*tHr4!23FP2XC5`M zgBLe+EFT%SwS={;^b~L|S&(a0QLe`=_u;gxNLDen=^)sd~?FU_8O{sUYFvdnX^pwJz@*RI;dY9~Ie1zPOh#d$qHW zeFeC{2q4huA|UQJV4_UlNbX&T<;V=6aBndR$MPtQC7O7IOG2ArJI=F*c!BxZn@E~IdbOC5@0|9;%2|)KKcIKgjE#db9_Ii=# zWJeyhQ(d{`1<=NfJXXIfmfU$MV5cF}oDcox;TkhIJZ}}LEg?vrUlc%E=G9i1wdS?y zZc9$5OH@LF@3R2KGgigX*R8rKue8!IH=CRIVpD0=0kr})WIvYLgr!=pDXRh?^NLlF zNqZ|ErP^cgM0Q^Qs_8S#x`L|La#<>=PTqnEn7=2q;08vGzGa$I0ih~7m{AO17|v!VOdlQ2V5Pq7(^=_j1+-Ry5sU&$%B!uhUTK}#aA~5a&4$X{ zDwB33FabXf(YV=IIg&;jsB!*s3*=Nf=lfkJ(y??!SA`(0gLeS2VeZh6$8~8f(t^w* zX{=1DVWmDmP3CTE0HSU^1@XCS2Xp6z?MTp){ zobiM4gdUZ|#S#g#mX*s_u@ZSbypmi|tH)wyEMT@JTH6w}^3|YFRvR=928bT7Wukly zE0Z^{Qu$ioIrIbJ1oOxnp|49Jj4jj_i|Izu>lG7`mjK@Kc?d(nxXuG&<;dOuY`MuanFmK}&~8+ZHs~=N`e9fe zKNxK=BZ0yz7}6EC8XJkNfyVPDTZPTjy!jGu7);&rxSnVVEY|mASQTpA!LGz6$^6)C z1P%2Q(S4C{9Fy`~gR$%jM%wf^4p);;&z0P#%4(44U>Y>;{~@0H1LC<~AfEd?=bh%G zF+LjPqkcYWqBz_kio?B);&3~;h)j97{tcsu=tgs54|sBM+phDR`3x}S=1?PYzCvoQ zFLKUF;5eF~Op$dD4s@fj6$jm1F3sik1FIA>4$S*#V$~?PmV$FtQ*f>;C^+@Uq^-U} z@vA?C$#ca+dN=}413p*Y1A5Fn0581JC_FA;7hS54v$fcq;ku{5Wm%&hG8^?kQ^ceS zQXgRJP~&R_p>#`L7hT z^9jn;`54%7M}vEH3=F5(Im{Vdz>p)MD3aow6lEK6w2hDagoyGRGOqj=8CTvQc^~pVPS?2b8ZPW5kMb3)4s@jN6Hodc@uYD+I>|>Z%`F#EB15q{1<_Q|x26vYNkQJNL6)QC58;tJ%fsuVdBgS_{+49a8Qxrgd2!NuLTk=Bb`uy^Pp}{~&KF6;`8^VKPVwd&I6sXh z?13n97V<6+8?ey_BLO|4M`15RdJDI(j9e?Pk|E^>WI_23Z*r^wB$cx)giRwUIDSl$ zju%P9@jP!BBG}j#jUFVYj%paI%`vkrw1-pVGo&UzMDp?oZ}u`=$7MgEVVWF%d1ZbG z`!;Z;@4^t$;bkg)2S(1gq3gGB!_u=1pMNPp_NA-IFdSX50wfOzm%#=RFq`-%OR^}Q zCRs5{LgFxQ4pEk3ls9|mp%w#Rz?1r9U$UnoF!!X?vYlXDtYLexQCU4S!u!1b&yi{2 z39>1Cg*W%GP=o-U6-Cq@DdlCN+@JT4QFj7SK|kOtxpNA+5J3 zrQMmd22)zsfHpXg>e!@pb@ETQTCzW-^(6;@s3ixqWDgK-A3U1s$-wzWOKP2iJ?)vU z-X5(zX_1dZcD5#gKGxkGT&Hy=;Tv{`*44v5KO^mK++j*<;UEM*R*HiPdmK-0B7j~X zv$A}z3LgXJ3n?)MY=+;v#YJ-(c3zb=y>r-4Db`_ zB!=d);sF>7Xz_3C&)MS=1X3M>-5{ak7w7zumCjp{Fs!A)NSu|U7_104x0wl@roeO5 z&IXI2rSINaZAWjd)}P7@_V;K<2dzw3AAHd#qzAOS(y1OTlTHn3wFBwiL93${4?&(T zh8w77E4s)-1n98V!eAjV>pp~6&U(?3K#lv?ym_l&2UzacVL%YNhwO26cz9Tphli12 z5EASV1i@~l1l_ys>@AdFqxsQPj{646-0g;-@J#Fa&BH_3ylZDyHef;B)isb#4Pe;~ z^$u#c4-O3=`zMT~UIZm0CBslFlX^rTXsBKhMFllEO$ zc?CM?+}__i*q$cQyiUOk+U^0{3U(Tnrs7;17vb#k+u7aoIRB|-ork#y_#zP11BASK;~#^( zx(!?__PFAZB@v%h=Ld_BbNCv0MMX)&cjqc|7I(UCg` zwtD#@^xR-d{sEX0CE0;1fc)g5cBa}hxZX;;DKW_lC05N^fFi!1 zUsPcGkJ2oNd@@A%mH`pMw21pT{Qz(HK}>wPko_x^(yMg;5n6nqzBFQmpA?(5fcpJaR55P zLUDL5;%5E@s($pjf1-6uTsI*&@w?#VoR_5hc}cRfW$V}HU)kUd$j&Y+40U5)IA$7n z;D<=ydBh`}gqQU~)IvJwX2{#1c zgQZz}h1V9_>4_JJzcVhrJ)igs}mTs;$6qY7&;Y10a#Rp);?Ck#o DFkw_B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST new file mode 100644 index 00000000..64700a3e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST @@ -0,0 +1 @@ +;; ;; Functions tested: BLOCK, DOLIST, DOTIMES, DO, PROG ;; (do-test "test BLOCK - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (block foo (values 1 2 3 4 5))) '(1 2 3 4 5)) (equal (multiple-value-list (block nil (defun fun () (ffloor 99.5)) (return-from nil (fun)) t)) '(99.0 .5)) (equal (multiple-value-list (block |exit 1| (defmacro mac () `(fceiling -99.5)) (return-from |exit 1| (mac)) nil)) '(-99.0 -.5)) (equal (multiple-value-list (block |exit 1| (setq a '(mo mo talo son)) (multiple-value-call #'values (make-list 4 :initial-element (first a)) (make-list 4 :initial-element (last a)) ))) '( (mo mo mo mo) ( (son) (son) (son) (son)) )) ) ) (do-test "test BLOCK - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (block foo (values 1 2 3 4 5))) 1) (eql (foo (block nil (defun fun () (ftruncate 99.5)) (return-from nil (fun)) t)) 99.0) (eql (foo (block |exit 1| (defmacro mac () `(fround -99.5)) (return-from |exit 1| (mac)) nil)) -100.0) (equal (foo (block |exit 1| (setq a '(mo mo talo son)) (multiple-value-call #'values (make-list 4 :initial-element (butlast a)) (make-list 4 :initial-element (last a)) ))) '( (mo mo talo) (mo mo talo) (mo mo talo) (mo mo talo) )) ) ) ) (do-test "test BLOCK - when forms are used for side-effects" (and (equal (progn (setq a '(m n o) b '(w x y)) (block t (values (intersection a b) (union a b))) (list a b)) '((m n o) (w x y)) ) (equal (let ((a 10)) (block tag (incf a 20) (return-from tag (values-list (list a (* a a))))) (list a 'end-of-block) ) '(30 END-OF-BLOCK)) ) ) (do-test "test DOLIST - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (dolist (x '(1 2 3 4 5) (values x x x x x x)) )) '(nil nil nil nil nil nil)) (equal (multiple-value-list (dolist (x '() (values 'grouchy 'sneezy 'doc)) (1+ 9))) '(grouchy sneezy doc)) (equal (multiple-value-list (dolist (x '(tree bird dog green grass) 99) (if (find #\G (symbol-name x)) (return-from nil (values x 'foo1 'foo2))) )) '(dog foo1 foo2)) (equal (multiple-value-list (dolist (x '(#c(1 2) #c(4 2) #c(7 4)) 'dummy) (if (evenp (realpart x)) (return (values x (imagpart x) (realpart x)))) )) '(#c(4 2) 2 4) ) ) ) (do-test "test DOLIST - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (dolist (x '(1 2 3 4 5) (or (values 9 8 7 x x x) 23)) )) '(9)) (equal (multiple-value-list (dolist (x '() (cond ((values 'grouchy 'sneezy 'doc)))) (1+ 9))) '(grouchy)) (equal (multiple-value-list (dolist (x '(tree bird dog green grass) 99) (if (find #\G (symbol-name x)) (return-from nil (cons (values x 'foo1 'foo2) nil))) )) '((dog))) (equal (multiple-value-list (dolist (x '(#c(1 2) #c(4 2) #c(7 4)) 'dummy) (if (evenp (realpart x)) (return (list (values x (realpart x) (imagpart x))))) )) '((#c(4 2))) ) ) ) (do-test "test DOTIMES - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (dotimes (k 0 (values k k k )) )) '(0 0 0)) (equal (multiple-value-list (dotimes (p 4 (decode-float (float p)) ) (1+ p) )) '(.5 3 1.0)) (equal (multiple-value-list (dotimes (k 100 t) (when (= (lcm k 3) 21) (return (values k (expt k 2)))) )) '(7 49)) (equal (multiple-value-list (dotimes (w #b1010 'dot) (unless (< w 6.0) (return-from nil (values-list (make-list w :initial-element w)))) )) '(6 6 6 6 6 6)) ) ) (do-test "test DOTIMES - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (dotimes (k 0 (values k k k )) )) 0) (eql (foo (dotimes (p 4 (decode-float (float p)) ) (1+ p) )) .5 ) (= (1+ (foo (dotimes (k 100 t) (when (= (lcm k 3) 21) (return (values k (expt k 2)))) ))) 8) (eq (foo (dotimes (w #b1010 'dot) (unless (< w 6.0) (return-from nil (values-list (make-list w :initial-element w)))) )) 6) ) ) ) (do-test "test DO - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (do ((i 0 (1+ i)) (var nil (cons i var)) ) ((= i 5) (values (list-length var) var)) )) '(5 (4 3 2 1 0)) ) (equal (multiple-value-list (do ((j '("sneezy" "grouchy" "sleepy" "bashful") (cdr j)) (var nil)) ((endp j) (values var (reverse var)) ) (cond ( (find #\s (first j)) (setq var (cons (first j) var)))) )) '(("bashful" "sleepy" "sneezy") ("sneezy" "sleepy" "bashful")) ) (equal (cdr (multiple-value-list (do ((i 3 (+ 2 i))) ((= i 51) t) (if (= (gcd i 22) i) (return (decode-float (float i)))) ))) '(4 1.0) ) (equal (multiple-value-list (do* ((i 0 (1+ i)) (str "Best wishes to you guys") (size (length str)) ) ((= i size) 'fail) (if (char= (char str i) #\y) (return (values i (fceiling i 2) ))))) '(15 8.0)) ) ) (do-test "test DO - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (equal (multiple-value-list (foo ( do ((i 0 (1+ i)) (var nil (cons i var)) ) ((= i 5) (values (list-length var) var)) ))) '(5)) (equal (multiple-value-list (foo (do ((j '("sneezy" "grouchy" "sleepy" "bashful") (cdr j)) (var nil)) ((endp j) (values var (reverse var)) ) (cond ( (find #\s (first j)) (setq var (cons (first j) var)))) ))) '(("bashful" "sleepy" "sneezy")) ) (equal (multiple-value-list (foo (do ((i 3 (+ 2 i))) ((= i 51) t) (if (= (gcd i 22) i) (return (values i (decode-float (float i))))) ))) '(11) ) (equal (multiple-value-list (foo (do* ((i 0 (1+ i)) (str "Best wishes to you guys") (size (length str)) ) ((= i size) 'fail) (if (char= (char str i) #\y) (return (values i (fceiling i 2) )))))) '(15 )) ) ) ) (do-test "test PROG - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (prog (a b c (d 1) (e 3) f g) (return (values a b c d e f g)))) '(nil nil nil 1 3 nil nil)) (equal (multiple-value-list (prog ((a #x10) (b #x-20) (c #x30)) (go exit) (decf a #x2) (decf b #x3) (incf c #x4) exit (return-from nil (values c b a)) )) (list #b110000 #b-100000 #b10000)) (equal (multiple-value-list (prog ((a #o7) (aa #o10) ( aaa #o20)) (setq exit 'exit1 exit1 'exit2) (go exit) tag1 (decf a) (decf aa) (return-from nil (values-list '(another wrong exit))) exit (incf aaa ) (go exit2) exit1 (decf a #o10) (return (values 'wrong 'exit)) exit2 (return (values aaa aa a) ))) (list #o21 #o10 #o7)) (equal (multiple-value-list (prog ((a '(a)) (b '((b))) (c '(c ((b)) a ((a)))) ) (cond ((member a c :test #'equal) (return (values a c))) ((member b c :test #'equal) (return (values b c)) )))) '( ((b)) (c ((b)) a ((a))) )) ) ) (do-test "test PROG - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (prog (a b c (d 1) (e 3) f g) (return (values e b c d e f g)))) 3) (eq (foo (prog ((a #x10) (b #x-20) (c #x30)) (go exit) (decf a #x2) (decf b #x3) (incf c #x4) exit (return-from nil (values c b a)) )) #b110000) (eq (foo (prog ((a #o7) (aa #o10) ( aaa #o20)) (setq exit 'exit1 exit1 'exit2) (go exit) tag1 (decf a) (decf aa) (return-from nil (values-list '(another wrong exit))) exit (incf aaa ) (go exit2) exit1 (decf a #o10) (return (values 'wrong 'exit)) exit2 (return (values aaa aa a) ))) #o21) (equal (foo (prog ((a '(a)) (b '((b))) (c '(c ((b)) a ((a)))) ) (cond ((member a c :test #'equal) (return (values a c))) ((member b c :test #'equal) (return (values b c)) )))) '((b)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0bad97fd2cd53befede6e5eb3b03ddaefcdd251a GIT binary patch literal 2570 zcmb7FO>7fK6rSC+9Vbp=LxMw`1SU{GHEcveXdqRqY@BuMuwIAVb$+Dw;MyB(v9Z(G zrbQJ9A+;x0ZAk0x6roBz_Jp`4RCOf|Jrt=I)Si0irN^r3t*7+8-4GH$sgUfQd2eRk z``&xsn^_~?g_uHP<>i&4Wv7do_-WdYx0eR6uUI^=5U+7 zYbCd8W~*kN8a1<$&t5-6hc8lTWwmI*-ED%>hOgzX1!w{&uajUQB)|GjqUQ}q!cYlTnL8J+`!YxjHR zyKz7M{e-lGk76$Dq-`50cj+n6mc8Cx%-|0#KR5~B9gXGNdeF6_C`4WX(VfEm@XH{r z6+*=j;alu4>;2JKTAfN_ImCpdPARe`P9{O4PU}(L%UXF4)cQcw$-St_Mn;2L#hhaM z^hMo}Q#|+L4kI090m08&g;rP;CNuFJc3@qF4ybx(RMxb#CZ;pSY{rNR0od6dmDEMi z(d$tL<$sYyeh(qcgWTyv9-IeDzIa+oNd}4|h$WWMG+EunO~&EcAgpyi3pXa|vg?Wk zV43`hNaN`=3!?Od9me4&$Wga08*x!zOiiX0@hN$6@mqEXhi_OIhtF6~9(K39lbTbK zx{(EQ9@u@B1r64lWW8^*-Vp5LdH}K42@$0rbc9bu{0fQ!8$ers;o;eIY#Yq)Ao^43 zDOr<@ZPjnML!VEkT)01j=+iT)l&ramA6@((v;G@w;C(ibVttc%1P~3g;22B=n6lt0 zJSa^`(@8Mg!;W?%iXprHZq=+*sZ(|;QuD)Xu4-MU<&sISWv!Y?ixpa{nE5lbxa4*> z&90hsC0hX{%~oi(1d1!QWwTU;dw^!?QmvG$7Rx1?%UTvXiQ4s}20A%*Q#wYMvT)7i zX|d$qP^i0k0#orXl-mA+=XezUX>i>W8{56(b|`cna2Yw+wU?!FEu8`u+Vw~-Tg?^F z^b1!K4>%k$p_97jgdt4}Aux3)sT#7TN{VPCwDi0Ujqh(^SIA%i;8WMgqXuc4C`91*cx@t72oby9XJwb)%V%Gj zI&i%!b=<;JEZ^C8F&TI2M`D^R8M63X$0|NlZM8&~YgVS3%~*vpKS<(z%Y1LVw)4&Pe5-IF7)P(1Zn0O-0yH& zn3JI6prmd4r%TwCE|wAwL*yPs(v2>5yn|ilkiT9-ODYN&>q9o;wYey>U>ky(CUS!t znB74G_-0W8^1EMrlv!$j2>AZGH>bCk4TV{x3qbf>DuncAxJA=g{{HB zPLvR=n|n9m`*il6e4qA2SR~Abx>zK{7PuDn8X*+u;cM?}cu%3XxlQO)Xi^U}DRgQ_ zQ#YRInP1)fhW5A>1a?mFuu;Lw&hOi4!k%6gju z2SVF4lLqK^6jPHleV5PBf!$$BJ2a@7wke&s-F|3kN`I7HI<(Vvmz`{Pr*)a`LZKx+ z=UhEoi2{T{Z1DB@+8v(3k;VE4xB+A5+&JtLV!JewHRV$+GK(fEN4TH7|wKbc7xfNb3g)V5 zdqY8A*xwiQnzLrk3BLFSqQQunt7+G=6O%q8u|Hv;JL6M=ChY*j(A_IX~RCwsb z+QWiS(TV1LJ^9ow@pM{T{f%AHP`JKER1A6ib;B|Kiid2+F=zAdGowl*t%9)Ruw#>$Jbfk%`26hdqv3B0!ff*H@GePI0Xw;D zs2`PJa|!}XGnX2PPyj6pKWbU%FyuE3d44ukCe4z^((DA|&;qb%4p49mt<8Ipx8P;H z(FnNFIR9WVyNsSn$1QtYI74wO4u3)Y8QLlp^8dMn7Ryqm>>|I_MyIjC0wvyj+QO4%~A5+>{ zVVSqokj{h)Y5d5O!o6Va0-Zl-+%XcHGn^xXb3?JALCC~2;o~s+WJ7_3?MbgYuGb~& z??KMNK9Ap_YoQ0T_(Gb^TmLbdd{tZ`v_QIyd>*=lP1QsXvmSS&L zEcsoRAr1w$chdzGw@K7DSw&aos#9yMfUGc7NVK7tA^(D4(Y{)ib4Go_nyKE9tfVtu zEH1}uEH=X8W2pX33b<@rzI$Ply%MH+W1)uD8t%nXTxRqYf?_7ipPKHkSn;v$L3HX! zSR2xOz6oPu+4Zm?!8ri+QMj{|Ee@VEw~o8V05&w@1B1cYvnntl|e&#uCPBZ+#)A%D0C7SoJ)@Efp%j-0j%r; z1vRjwC)bc#+}rOT8XSrN1nyB}V&f!SQftIDa8Iof*FuWwA$=EA$b!>vU!wOVPu5-P zNiv(PPE`xiT6oWiI~E>r`1F$2ATPjFsoDHYuED$T`11Am!#hI3h;Mr@JjcR2qh9GM z9J(Ebu13TUNE54+G*%_80@w&}C99Acpj`>A9@+|M%b?XkTMDff+7-}hpjAVwf>sHw z0-6fV1ve=*) zIxD@wNJNkL^nqCaK+G$z0|AfMA0GA*Kk8+o>}6H*dR8fKU>@1W+-7b`d)vjY+7^c( zFdM#Q;T0+{e2Q)a_4aN((&vvMxgJdk3`8QqaM632iP%>UeYK0R4fvx$K0m90ZqFY< zlN-9h(_k1H@?L=TaNOKC80w9pde8GX+n_%*5R4-E3~NB}G+T*a4mxe!uu@2z;$2Vj zuFtbZWZniNbrSgAcXQV65909q!w%hkVvI0qlI7)Tob<8uhbWO)t%)w(!1Y z-d9U~uK%Jw*ME`~uAgw~N1Xa9r%rL|QzY)Xhs0gCb8(F`S8`?rF`ZA6obw5ib7nX- z!Kv#wwUtv2=2?RZFq7=Nc-KzWg48xnUCXIfPOTxImDfqL@+xUo&XHz? zubaZxP2uaN1W8WW&gHJ)R5eky|0c?Ij#K|aI&E{L)Al9OX**1jvrTi5;$SZa!xTfOwb- zWVk?(A|ZBiu#tl%4(cg9!vB(-@G{8>zau%}0nRiz^OLOpCf2Zrt?Xe9LDsT`HFU6* zt69S;wsIIUp`sdcMWJ00DJOixvxjka3jyi*D_e))9E`EUCppMaBv-Ol1WS3Ri-3Cx zG2JRr>KhzIH>UaGg2blN{*l&mYksUP5 z^&8;Wdh}3%{1uR{Xw1Jc+8+!Sc)w)p!9v$KDRd>creO|bVmeM-t=HQ>hW;{LIYR zwI=+B)U#&J_I~(>`01Hx1dq;4AvkX4lm(%qK#&^jx!XJ@IqML+r>CyzfAWi>bq%KZZadMrqR@oYA8`%0Wo+z}ti8V9tNbc;4V zZDdoE;Me}R0e^*{kR=hJM|2B$#&&?+j2rB3HFGx?8*JG+ zkuI31rKV`jHfX7_qGgYa^P==( z3Aag+E|ze&G;`t}pm8bHe2K&Aqh@YrvBUJ|7R@_4k#5O)wM-&Aok^Fh66J6L?(%ajC+sJ%u15EDvImEmuwoosb#3cL?%*@GN?J6AcgGKba3*Ff9ts*(3zYeOUBV7>L zBmR>VUg1ULKVgxs$Eg>2_mz0+`h=NlB~SIp!S2RIi!EczSZhujndtZ# zgbgdr@qJj+zKJ{I8Qf_du%<=SW96wb$4rT%j*pwU;G(1NuErc6;XZ8xpCt6+8bI(x z=-3E|4Ur{~=B$cUG7nNtVB?`>e-;q739&PPp{)Ip5?k%Z%-s7gVe31rK>NL9rTrfu z1K?1QV?B5yQ+jmx6E9N%m52OMLR=AlI0}ElE!?i`QLI_8O*lrskJInZ&~H3Y?R~Ia zAMtBYcXKcZIe`++^~mY!f^87{+b^Kjqy7%InYFVv?3GJGpuo|(jzR$6D=w!xm3eYj zDcxTc*k5nESe2FN?@3iEd<#}4pbizAEMZY9o55!!5Emgi00-3eOo{8Zr_9_Lte7Fc7C{Kaft}k`lXXd(#+sOgOZF-3gcn zmtUS-z*1=7Hnx>*Vb`*2un&%D*PA04lX$*V?9MLWaiCT-;(o$RP*3L+_!p&Xl8wkaE`{93Mq0b@o zHH0qnnZ!sUwLg`mWrIo*(ceL$ZhiZ#LEmGUC&`gLc6e zknwF`5cRJ}od#VqZ8PmNn`b(Z{t^dYnAwcfV>9gt9-YDcPCQ!Tn0U}ShsiN3{$;Fr z@lNh@k9izl61H$Ku$!rXY}a=T^GBB-y2zoIE?~F8eQa_9PixV;h}M;7ClLNt5)0uE z)=^Edcy}9t@OyGwc(imHc!Tj%_QGl2VVw(~W;c8gviI=$^XFf|U$5e?zwCxAmLxy@ g?u68kko#JzYYpHu_H_qIh!@%=+z(+E-Z+2$?+E+r761SM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST new file mode 100644 index 00000000..3884c15f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: IF, AND, OR, and COND ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137-138 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 5,1986 ;; ;; Last Update: August 5,1986 ;; ;; Filed As: {eris}cml>test>7-9-2-mvr-conditional-constructs.test ;; ;; ;; Syntax: [not applicable] ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely these circumstances: ;; ;; ;; Conditional constructs ;; ;; . IF passes back multiple values from whichever subform is selected (the THEN form or the ELSE form). ;; . AND and OR pass back multiple values from the last subform but not from subforms other than the last ;; . COND passes back multiple values from the last subform of the implicit PROGN of the selected clause. if, however, ;; the clause selected is a singleton clause, then only a single value (the non-nil predicate value) is returned. This is ;; true even if the singleton clause is the last clause of the COND. It is not permitted to treat a final clause (x) ;; as being the same as (t x) for this reason; the latter passes back multiple values from the form x. ;; (do-test "test IF - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (if nil nil (values 3 -5 7 -9))) '(3 -5 7 -9)) (equal (multiple-value-list (if t (values 2 -6 40 9) (values 9 40 -6 2))) '(2 -6 40 9)) (equal (multiple-value-list (if (evenp (values 3 8)) (floor 3 8) (floor 8 3))) '(2 2)) (equal (multiple-value-list (if (zerop (1- -1)) (if (evenp 33) (values 7 8 9) (values 17 18 19)) (if (oddp 157) (values -9 -8 -7) (values -4 -3 -2)))) '(-9 -8 -7)) ) ) (do-test "test IF - forms *don't* return multiple values when they *shouldn't* " (and (eq (if nil nil t) 't) (eq (if t (values 3) 55) 3) (equal (if 'non-nil '(foo) '(bar)) '(foo)) (equalp (if () 2.1 3.0) 3) ) ) (do-test "test IF - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (if t (values 'a 'b 'c) 99)) 'a) (equal (foo (if nil 10 (values "pot" "cup" "brush"))) "pot") (eq (foo (if t (values-list '(30 300 3000 30000)))) 30) (equal (foo (if t (values-list '( (neck . body) (rosette . sound-hole) (metal . plastic))))) '(neck . body)) ) ) ) (do-test "test IF - use MULTIPLE-VALUE-LIST for receiving multiple vlaues" (and (equal (multiple-value-list (if nil nil (values #\1 #\2 #\3 #\4))) '(#\1 #\2 #\3 #\4)) (equal (multiple-value-list (if t (values 'value0 '(value1) '((value2)) 'value3) (values 9 40 -6 2))) '(value0 (value1) ((value2)) value3)) ) ) (do-test "test IF - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (x y) (if t (values 10 20 30)) (list x y)) '(10 20)) (equal ( multiple-value-bind (x y z) (if t (values 10 20 30)) (list x y z)) '(10 20 30)) (equal ( multiple-value-bind (x y z q) (if t (values 10 20 30)) (list x y z q)) '(10 20 30 nil)) ) ) (do-test "test IF - when forms are used for effect" (and (eq (progn (if t nil (floor 5 3)) 'prognn) 'prognn) (equal (progn (if t (truncate 30 4)) 'end-of-IF) 'end-of-IF) ) ) (do-test "test AND - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (and 1 2 3 (values 11 22 33))) '(11 22 33)) (equal (multiple-value-list (and 11 (values 'a 'b 'c 'd) (values 'e 'f 'g 'h 'i))) '(e f g h i)) (equal (multiple-value-list (and 'foo1 'foo2 'foo3 t (truncate 123 10))) '(12 3)) (equal (multiple-value-list (and (>= 2 1) (= 2.0 2) (< 1 90) (floor 43 3))) '(14 1)) ) ) (do-test "test AND - forms *don't* return multiple values when they *shouldn't* " (and (equal (and 1 2 3 4 5 6) 6) (equal (and (member 'a '(d a n c e)) (= 3 (car '(3 6 9)))) t) (equal (and (evenp 10) (oddp 33) (zerop 0) (cons (floor 4 3) nil)) '(1)) (equal (and 'a 'b 2 3 () 4 5 'c 'd) ()) ) ) (do-test "test AND - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (and (values 11 22 33 44))) 11) (eq (foo (and 1 3 6 7 (truncate 50 3))) 16) (equal (foo (and "star" "moon" "sun" (values "tree" "rock" "grass"))) "tree") (equal (foo (and '(1 (2)) '((3) 4) (values-list '((5 (6)) (7 . 8))))) '(5 (6))) ) ) ) (do-test "test AND - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal (multiple-value-bind (x y z) (and 1 3 4 5 (values 5 4 3 2)) (list x y z)) '(5 4 3)) (equal (multiple-value-bind (x y z p) (and 1 3 4 5 (values 5 4 3 2)) (list x y z p)) '(5 4 3 2)) (equal (multiple-value-bind (x y z p q) (and 1 3 4 5 (values 5 4 3 2)) (list x y z p q)) '(5 4 3 2 nil)) ) ) (do-test "test AND - when forms are used for effect" (and (eq (and (floor 4 2) (ceiling 8 3) (+ 2 3.4) (1- 34)) 33) (equal (and (values-list (list "a" "b" "c")) "end of AND") "end of AND") ) ) (do-test "test OR - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (or (values 'foo1 'foo2 'foo3 'foo4))) '(foo1 foo2 foo3 foo4)) (equal (multiple-value-list (or nil nil (ffloor 10 3))) '(3.0 1)) (equal (multiple-value-list (or () () (fceiling 9.5))) '(10.0 -0.5)) (equal (multiple-value-list (or nil (not t) (values-list '(the house was ransacked)))) '(the house was ransacked)) ) ) (do-test "test OR - forms *don't* return multiple values when they *shouldn't* " (and ;; OR won't pass back multiple values from subforms which is not the last one ;; (equal (multiple-value-list (or () (cdr '(1)) (truncate 234 100) 99)) '(2)) (equal (multiple-value-list (or (null 'a) (listp 'a) (values-list '(atom a)) (endp '(())) )) '(atom)) (equal (multiple-value-list (or (progn (setq a 120 b 8) (floor a b)) (ceiling a b) (* a b))) '(15)) ;; (equal (or 'foo) 'foo) (eq (or (member 'z '(a b c)) (values (floor 34 11))) 3) (equal (or (null '(())) (cons (floor 45 10) nil) (endp ())) '(4)) (eq (or (intersection '(1) '(2)) (cdr '(2)) (eq 2 2.0)) nil) ) ) (do-test "test OR - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (or (values 1 2 3 4 54))) 1) (equal (foo (or (truncate 10000 999) (* 10000 999) (+ 10000 999))) 10) (equal (foo (or (tailp '(a) '(b a c)) (values-list '("Mozart" "Beethoven" "Bach")) (find #\q "quit"))) "Mozart") (equal (list (floor 57 7)) '(8)) ) ) ) (do-test "test OR - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (or (zerop (1- 2)) (values 10 20 30 40 50 )) (list w x y z)) '(10 20 30 40)) (equal ( multiple-value-bind (v w x y z) (or (zerop (1- 2)) (values 10 20 30 40 50 )) (list v w x y z)) '(10 20 30 40 50)) (equal ( multiple-value-bind (u v w x y z) (or (zerop (1- 2)) (values 10 20 30 40 50 )) (list u v w x y z)) '(10 20 30 40 50 nil)) ) ) (do-test "test OR - when forms are used for effect" (and (equal (progn (setq a 10) (or (and (decf a 3) nil) (floor a 2)) (list a)) '(7)) (equal (progn (or (truncate 200 45) (floor 200 35)) "end-of-or") "end-of-or") ) ) (do-test "test COND - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (cond ( (= 1 3) 13) ( (= 2 2.0) (values 2 2.0 22.0 220)) ( t 'true))) '(2 2.0 22.0 220)) (equal (multiple-value-list (cond ( nil 'fail1) ( (and nil t) 'fail2) ( (or nil t) (values "transfer" "repeat" "* #")))) '("transfer" "repeat" "* #")) (equal (multiple-value-list (cond ( (equal #\a #\A) (values 'char 'equal)) ( (equal 2.0 2) (values 'number 'equal)) (t (values 'pick-up 'sta.speed 'hold 'forward)))) '(pick-up sta.speed hold forward)) ) ) (do-test "test COND - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (cond ( (equal #\a #\A) (values 'char 'equal)) ( (equal 2.0 2) (values 'number 'equal)) ( (values 'pick-up 'sta.speed 'hold 'forward)))) '(pick-up )) (equal (multiple-value-list (cond ( () 10) ((floor 100 9)) (t (* 100 9)))) '(11)) (equal (multiple-value-list (cond ( (values 9 8) 77) ('non-nil 'true))) '(77)) (equal (multiple-value-list (cond ( (= 2 3) (values 2 3)) ( (= 4 5) (values 4 5)) ( (> 5 9) (values 5 9)))) '(())) ) ) (do-test "test COND - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (cond ( (= 1 3) 13) ( (= 2 2.0) (values 2 2.0 22.0 220)) ( t 'true))) 2) (equal (foo (cond ( nil 'fail1) ( (and nil t) 'fail2) ( (or nil t) (values "transfer" "repeat" "* #")))) "transfer") (equal (identity (cond (nil) (t (values-list '(time and tide wait for no one))) (last '(2 3)))) 'time) (equal (list (cond (t (values (floor 8 3) (floor 9 4)))) 3 8 ) '(2 3 8)) ) ) ) (do-test "test COND - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal (multiple-value-bind (a b c) (cond (nil 'dummy1) ((= #5r110 30) (values (truncate 99 8) (truncate 88 77) (truncate 77 2) (truncate 44 3)))) (list a b c)) '(12 1 38)) (equal (multiple-value-bind (a b c d) (cond (nil 'dummy1) ((= #5r110 30) (values (truncate 99 8) (truncate 88 77) (truncate 77 2) (truncate 44 3)))) (list a b c d)) '(12 1 38 14)) (equal (multiple-value-bind (a b c d e) (cond (nil 'dummy1) ((= #5r110 30) (values (truncate 99 8) (truncate 88 77) (truncate 77 2) (truncate 44 3)))) (list a b c d e)) '(12 1 38 14 nil)) ) ) (do-test "test COND - when forms are used for effect" (and (equal (progn (setq a 5 b 20) (cond ((= 5.0 (gcd a b)) (values (incf a 3) (incf b 2))) (t nil)) (list a b)) '(8 22)) (equal (progn (setf a "dance" b "music" c nil d nil) (multiple-value-bind (c d) (cond ((find #\s a) (values a b)) ((find #\u b) (values b a)) (t (values "????" " !!!!!"))) (concatenate 'string d c)) ) "dancemusic") ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..02adbd6f836fb2260199fbeffee2ddeefb6e57d1 GIT binary patch literal 3575 zcmb_fe`p)`75{!uk|oFXVyAJOI7zK~NxQ1KEKZ#!ahAd5a<-L7I`wplN*Yg+J-=2?FNOWDYT?NmO`N2k8Y)7u+lC zXW3^b%f_fI@jmbO`@Zk{e(yXZLWlK4R3ASvQFQW?(eY|!qFRZLjZa3)ybKkxG6vYFG2+(UFI@M0<8ewTa21gJ9P#Wbfl@AbkP z2jta~c=gQ#%Fyc0HW@l5#BoP)0)pu6(Cndc+AHFZz;PIbJW7s9%vL zfxp$X1O9K(&oK6OjdqScKHsl#DSdqn$e*-rlp2ePo9YZp7^%j+vg%pOGE%YHYl!@cxt}q)#KMbSfD~rXx0BI%=pb^I$&Z*k%H$M#mN7>Y z-DE~at>=A+Ro~;FN7#Odg*L3EkV)naFt-_2k+2(XBeDusBawggOysAYiTnj~&ok#T z_cXPRlat5eEPWK#5qHE3Du=wFa)5(&vPp+mnp}zgD>K8%eP%+fU*qJecvfQ0vl9P? zP85p2v+y$({)vUZVd1+he4B+Az0Be{FSDq@>Ib3y0ZbL7E8m3n1g!rqwC{oScR~9m zSic#g2g0Zid1Hf|GKUYAh7`?2g4ln+Mj{__x8B4lkov;&iJmN^y-MPJ&_(!F!W!e3 z*y{-t1^Z3YW~t*fNzs`^U<0`cFOU2ulRr?9Bc8c@pYSl__XrJPlPTEn2y86D z#vWMP0qeHmvI4iewQZGrxe`55bt=UPC$F9waq#^@ovb?fakjARU#6V}aS5)U+Vxw8Q@ zl-~|V$n|4(g&uN)d&vcMz

0yV&9bv{)%mlcXE&fGBzW+?@?efIlEjabIe~FZA{9b8j4hR5fN&b6jQSV!s{1TrEdO@hGBn#zmt8%H zxNTTkA_GlihVy%W*0c>CCG7d8TlRdcTAJ^((h0Op@-ug~8McB7Ti_muoq@aITW}ZL z37cUPsb8elouhIhcvTu!TuVR~&h(IJ?x(&gkYII?-rq>oFp!Pg8cv%}*^;)fM(>3U zy6{NS9ZJzJadfb5hzRygBEgW)7rPW#*dS_!*EC60;Ur@zMEa?W0HFaE43a?77iDoC z_ZbRv3<|7(B2{*lBf?S00d27S$wDsTrjQHDGX#%%`vnKRt zo4g4dsmODRzYku|Luo6n<5JKxc$p0RT_OKfH*`-O2Qk6fi%Lb*DTKUT(2;!CeH|A*t}Sl;x=bZ(kjC_ZKK$#jmmkETb6 z{LY;XNhJ^r5p&(oyl_Kfh3nStxMgGWc*jtnbFl5`d~5IkBcd%=u!8}*G*F;y*?E|D zY%Mher;47Ul u!a6eP!K07&4M{I(?ra0!Ej(hq^D&kPW0X_D+UZ7Em@x4St?;$Exvv0Bod}}< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.TEST b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.TEST new file mode 100644 index 00000000..250b5f81 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: EVAL, APPLY, FUNCALL, and MULTIPLE-VALUE-CALL ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 4,1986 ;; ;; Last Update: August 4,1986 ;; ;; Filed As: {eris}cml>test>7-9-2-mvr-evaluation-application.test ;; ;; ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely there circumstances: ;; ;; EVALUATION and APPLICATION ;; . EVAL returns multiple values if the form given it to evaluate produces multiple values. ;; . APPLY, FUNCALL, and MULTIPLE-VALUE-CALL pass back multiple values from the function applied of called. ;; (do-test "test multiple-values-rules : eval" (and (equal (multiple-value-list (eval (list 'values 1 2 3))) '(1 2 3)) (equal (multiple-value-list (eval (list 'values-list ''(a b c d e f)))) '(a b c d e f)) (equal (multiple-value-list (eval '(values (1+ 99) (1- -99)))) '(100 -100)) (equal (multiple-value-list (eval '(values-list (list (cons 'a 'b) '(1 (2) (3 . 4)) (nthcdr 2 '(11 (22) 33 (44 55))))))) '((a . b) (1 (2) (3 . 4)) (33 (44 55)))) ) ) (do-test "test multiple-values-rules : apply" (and (equal (multiple-value-list (apply #'values '(1 2 3 4 5))) '(1 2 3 4 5)) (equal (multiple-value-list (apply #'values #\a #\c #\e ())) '(#\a #\c #\e)) (equal (multiple-value-list (apply #'values-list '(( "frets" "strings" "sound-whole" "tuning-pegs")))) '("frets" "strings" "sound-whole" "tuning-pegs")) (equal (multiple-value-list (apply #'values-list '((material . wood) (price . 1200) (name . guitar)) ())) '((material . wood) (price . 1200) (name . guitar))) ) ) (do-test "test multiple-values-rules : funcall" (and (equal (multiple-value-list (funcall #'values (max 2 4) (min 3 1) (>= 3 2 1))) '(4 1 t)) (equal (multiple-value-list (funcall #'values '(a b c) '((d e) f) '(g h ((i))))) '((a b c) ((d e) f) (g h ((i))))) (equal (multiple-value-list (funcall #'values-list '((material . wood) '(name . guitar) '(protection . case)))) '((material . wood) '(name . guitar) '(protection . case))) (equal (multiple-value-list (funcall #'values-list (list 'o 'p 'q 'r 's 't 'u 'v 'w 'x 'y 'z))) '(o p q r s t u v w x y z)) ) ) (do-test "test multiple-values-rules : multiple-value-call" (and (equal (multiple-value-list (multiple-value-call #'values (floor 5 3) (floor 19 4))) '(1 2 4 3)) (equal (multiple-value-list (multiple-value-call #'values (floor 9 7) t '(()) 'foot #\q "sunshine")) '(1 2 t (()) foot #\q "sunshine")) (equal (multiple-value-list (multiple-value-call #'values-list `(,(lcm 3 15) ,(gcd 2 7) ,(>= 3 3 4) ,(list 'a 'b 'c)))) '(15 1 nil (a b c))) (equal (multiple-value-list (multiple-value-call #'values-list '( (1+ 2) (1- 23) (* comment) (/ 7 8)))) '((1+ 2) (1- 23) (* comment) (/ 7 8))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..934b8db0edbfc9f03086bf2af5ff8bc22386958d GIT binary patch literal 15342 zcmdTr3wWGWmH%U2nMWRN`U+{7CZ&b6lafB5Ev3yQnPjG!nLnMGG%28UnoOBA)1>B6 zsIpjUpoqhxjgE6c*yT~c&*f92E-77!imr=Rk&lO>vZBlS?W(MGQ3PF@J&*sNyh_tT z&~G90pL@=|_uO;OIrrRi@BjCRWNxbqy6bxO?(0k?dfhz({rd*`-Mf2w-F-a+z3mD2 zZlJqATBk*Pf9LnsHC0_vZI4ctN0ljSF z+O-?ktgEs&c%wn)He;X5H?G~VarK5O``Eo1xv)o)q;_c(L7pTPN~)ASnl7x2`JypT zLm=q$guNkOW%fumZG*XZTB5#4HeIyZ-QTm%lS=GQq;NWW`y^SCvUjCz4K3liSU?MB zhvb8@Gka&+6$pEpVQSt+pQPAyF34TZrb{mOZ1Al1gtkXKflzZWP#1`Knj>0c*i$Xt zoADl!q=H*euqToyw#vu5<PXY=;in|&Nb;8ORz-#}k9=`K>meKue>O>S zf*76cgQP@VR%MqVt99}?!`J3yy?RPbAf*`7*fgc8GAH)%;>lGaWzstt@-v*3S*S~l zS=c6zYA7Ej4_<@V#^KO}CS5uelr_9&0)2dj7fhgb>Ff}koJH|X!-n{I6Gmg1pA0KI zi$}F$W#{}+ZN9Q|;i$Gy*;z8Gl_)z)N3~LAXW6J$rtEZ&hGnf-*5=FFLRl-3wNhCt zlQlQ|DRQ#J_>V+?;7ig^&X+r|*;)RMW0cEU`NUy#FaPkn8wGgnTza;#mde`FNyG7Y zXp&j+C-d!wLFP^{2ozH)J}j`1z;T`o%k7!bup+l-M_V(k+2>Pvr-mmk7Fa>&V!ksP zu57~mbbp(bsac*erdB+8YJlls3f$wz;|t~_px-%5)6aFKl$4q>u}%#CI`U3EhWpRt z6LOI}&+u+2&u5iXYAeCnb?==shjp$W$gOsLl^P*uRy1h+fuX?#?<5Ke zqAL@c=%w=~jvHZYxE{OfED-E{12|96`S22GZG`2y*h1F?7H2b9*#gG&7bcDI%5$ap zMk#9)W-(6MzHbb@XoBXGuoSz-hRYG|eRFJh0T!VCl)wT`e{2?I$orEaLkW!0ei!cR z?MFxVwBI(`)t(-0y{q*oMB7wbsy)?%VHd}r;E%AF9>N~CP`_L0dB~R{ZN0VhdUoQKj|X1%_)`LMXO1baS5JUZA!@@T;Sfbsh*!2>M6$w7{4O*BCX-HF6#=U z!crsvtMRs@t+yTQMC{}}_?(b}&dOe3f6kC;+4)%D29%{pUJgc(FV@1k@|z7f$q4$) z8dDub@+GO&MRFzBLSBKkh~#V$n`n#e(`}(|o@k9(nRotxG4GW;6%T_d2CKBIPR}tm z>}sT)*(Sqtlc$d)Z^H(&ZJC0{3<)oVooF;w49exdlnWp|z)^AWJdNXX9i((ca%@?MrTj*m`*sL38bJ+womruxZ*5`70V7x)wqouTN zZ69Xuy>@m2WUupIJkH-Z27}N@oXx0RxX;kr#_{n;Emw@sXA{f^B)&2U!W~V1v1z=e zqR5DB9KNg*w2sBoj4$PI#Ib?+ZHCObNZz8|2(AK^6iH`xP8e?fnGUr_l7*dxlClME z1?1Y?H2@yqmCZ==3YT&v7V4m|NjQ`%gj3m={dBstvQ7)v2k!ANyQK+l|d^O>0sKnfw+Ma<;kN*O^I_b1(7qVT zbK#c~Yl*`XUi6;?Y`S%`LG?wH7)!E4|?z9->Dpg{;;AO>NLL;Zp0dSnG{I(I=d0gK(&g zNQ!vtIeVufdW(qQ$2di{GU=){*T2{Xp#R<;z9&p7H$L&iX{m4bCW)9 z(#2Sku@=T6q5@kw7_(8G{SCtGuT!1%NKtdYhYl;dkf%a5c?=&*E6=Au_(>Y*$myC^}af--sb@>WKyRO zhB7q-+KAg(Df~MqnmZs!rW@3nmS2D4H zx;va=Ik0x*k?al&6IGJd^}j@Py+uUV8%+EiW4~qWS;l@q6LNh|R01>C*GX#E2!lsR zc-KQDpi3~ggZq7wgm>M_#Ot}`0AqU?e2`mS%`MxQSWPo>Rnd%GWi+F_{{e?L!J-Tb z7f6x!J3v*q?PTmZP-}727i;iDcZ6!SpvSle#irjBD-n!Bo4jl4wJN;g+>Vr^TydvZ zg;)z?5ymbORY;Ub6x-V*itRNL#rAa)+V(Z!fhM;5sio~MCf-inZ95sehA}r|iwU#7 zNIb325l`z=#M7D)3xJvRb_RnCZeVa7jbM#%KaKlsp?;Ph5z+EI5iQ?h;%87-A#dGU z(vIchI=Y6@1H{#`U#G5S>K<@c@Jw2MmNstEqBp7LCfi63O9Lo!E-4#^h-edaZP~<4 zs>M2(jb%AwrHsvC%u1N~ZNkhyCi%@Tko@Lvll*4ZrTKOkUWGAebn^||ub2B(kxI=g z#APs$xt!}3aveuEvqE*IQ&eaA71f!Zqkg6za^1JN?gZCmNEXu&$zu9A$zm#^I`#L| zPyKJQx%vtdPf!PSggU5?QU|q!TP~oM%2x0!k#9O|HiFYyRq9NoY4I#Jj5G7P6 zjWKwY!FL%PqYlyo)ImBbmh2K$eo?hvRF!dq2SI>>YcN96zKK{2UO-sFxO)W=^@|M% zFmo|)Z3#8+ATt(RBsLVI%ff-+M~s~$$H;pG6t7_Rf>rku0vQS-_aK5< z4^D4$;4HRLFR{bWfV7U|4xF~eo7M9o?-BLYH2%0{cLxW1hxUO8T#3J z#1;gdq6Wcw8psA2Ct@q9gZ0mZS^q!-S&!2Q)-Mrj>oEp*fzZ~F770UMOOjjn(K@iM zx~m!Lr`|?D z@l%~*r#eXeF_Oq{G5Cq_BlazQ1XiW|k4*g(b(BBBu`o>i;haPLH!>*GJM!iz&lMQ0 zWL2lK^`tjN2&mG3iY5dvGx!0GAw9+5R$?w46dU@*hTS4~wFm}9$SXpdL{qhBDi{6* z-0&e_QP7u7Z|_g^^}9nY!C0UfUhGodO-C}fhhO5lD?56+m-kn?dlUTwz1{A;1F8Pb zeei~Qe>??mpxxIc6W#9qWa5CkvM<>)km{hu$h{|F*tgVX!)nJL+ap`8Zb?c^gNN~!zv%#qPKc7drx*q0d1Al zMSR|v&oku^5)8zA5pOUm=3q0}AGWnT$FA2Pg8`x`8rE8w zYpWl$q!$Bln&kmL0F1;HqFwBQ*4A2Y)Zfs;(peiLT1%ZD7>W)Y5{`{lZYes&9?>DL z1*-k+?2u`2i(8URWWa++`x;p=M?=yrWI+)D`-mtR#(rHk-AINB`eK#u*&XeDWDk2C z9Bv0|zE0j{zcN><2C{;JR6xOmg;IkuFPoO*NP#aE)~Vwq63y|s2|9H=Xz0{&udYGIow`mPw;Gh2bj3OL>pFGx>N<6F z8&z%7r4MA&HD{9kJXPxOvD|Z~s?_zu8CB|f%uuOo!!)5>mD%(MNGLkPfl?FK$J_f; z2i!f~dX#i`_PGc85*;huoxAm@8t+ZG_r?2w=#KZfBB05x3Th*8OxmJZ4rHJ7#{RP%2@!zFNEP2!SDqzyaR?WJ@?`B#ZrCv!w?)HtST`` zZ~>}b*sZZ(j`_8yzFoBX_3SsCQLN3|;8J&@fzEDlB{yX?H{~T6$zGEzfxnYSY6_Eu z(oBM*d*PKJ{-xzM5S>(Ko3;{cZ)MZ9lU4$K28J2Lc`i`fAIaTqPl0|!fpC!j+)K~< zz%sUb|6eQv_WH@rKXE3gM%xffQTO`8W^}#3=>7&C+uBVV2}h9b$qLK+$fv15-xJ-ot}m z{n*&p;5RsET6SmC=JsS~yay|Haht0LYhIy{Y6;DbjVEwF9CzzP;I>zS1BYHc*wQ)R zo_zBfViEWp8_vjsHK#zSIPNRcmXZ0{Y}z+<8NJ(xVE#U>6*KH~Dl8KfmI$t1^Ub_w z%-w%|Z>3G+*SexE<9{52Zk%S6s*t3XPw=ie~?UXvS*aq#GcoWbtNGYA5C<< zwCB|4Qc8RznW#{Y52ngSlE)!xl&N1eC!e?}juC{)CvJ+LsPPB3HrdS>>=YF~Dp0`X z&VFDsNwoQm>FGD#Kj7yAdCRnB{Di_A1VSx2$ZxV~69!uhvCEp^{RL{Mnx2;`n?;2c zHrRY`q_G7)s|d&!hzhtr4aj0E5BAhF!>M1%rc=`mXB?@QcQ2oI1BvE@8)mQ~p0KGe*xB9f zsb1;sUI~}v?(P-U?(TuTyAr*9?w;Mbo6C4N^Z*U0UnI+`2eU&CJbYc{qmL_~XbEXy z)F$R9mimadQPXpkdY=zoP+()YqBCyjqG9+pfODDJK!or1Ebu`{EXY)Abldpdo(|Spl2gJ{qzjbb1OZY=ozFZ-V7^`W{2_!J8vG?yD1~( z;a*Iq+!<^P&5Xme8BVh@Y_;!6dfbPU)ziE|sW9$VAf2OSY&gO!-mSn_KzLItzjnt* z5c~?3QY!wD16Y1JBiU-awRFicvqn^XovL_DhTjhOT_r<;!TYTI9G{>uF_gcPk@A6a z9i|J-m$~*=10ob)>EnmDRYt`P!OecBq>8JmY$kt%jZ!gUd>o)4;cX@Dgb`LfFc{nU!4~QVZ0$ ziqYz6b?^ROTJ7~2sWj2``or+A^DxuF{AQ%a>qn*1E$sPuFc}n0i2|`F!v~fXHbcH* z8dF-EksP^y4mjiFfzyBz-et4i>FIB=OHC|bgkrwIy ooGN8bSyI-NEtQvY+0P}#0j|dOH;=-*JlR{MyJ1B6@v*W01KpL~lK=n! literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.TEST b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.TEST new file mode 100644 index 00000000..8cc4483a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: DEFUN , DEFMACRO, EVAL-WHEN, PROGV, LET , LET* , MULTIPLE-VALUE-BIND ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 7,1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - many changes to make this pass on ;; the SUN ;; Filed As: {eris}cml>test>7-9-2-MVR-IMPLICIT-PROGN-1.test ;; ;; ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely these circumstances: ;; ;; ;; ;; Implicit PROGN contexts ;; ;; . The special form PROGN passes backs multiple values resulting from evaluation of the last subform. Other situations ;; referred to as "implicit progn," where several forms are evaluated and the results of all but the last form are ;; discarded, also pass back multiple values from the last form. These situations include the body of a lambda-expression, ;; in particular those constructed by DEFUN, DEFMACRO, and DEFTYPE. Also included are bodies of the constructs EVAL-WHEN, ;; PROGV, LET, LET*, WHEN, UNLESS, BLOCK, MULTIPLE-VALUE-BIND, and CATCH, as well as clauses in such conditional constructs ;; as CASE,TYPECASE,ECASE,ETYPECASE, CCASE, and CTYPECASE. ;; ;; (do-test "test DEFUN - forms *do* return multiple values when they *should* " (and (defun fun1 () (values 1 2 3 4 5 6 7 8 9 10)) (equal (multiple-value-list (fun1)) '(1 2 3 4 5 6 7 8 9 10)) (defun fun2 (x) (values-list (list 1 2 3 4 5 6 7 8 9 10 11 12 131 14 15 x)) (equal (multiple-value-list (fun2 888)) '( 1 2 3 4 5 6 7 8 9 10 11 12 131 14 15 888))) (defun fun3 (x y &rest z) (values x y z (decode-float 16.0))) (equal (multiple-value-list (fun3 10 20 "mvr")) '(10 20 ("mvr") .5 )) (defun fun4 (x &optional (y 99) &rest z ) (values (floor x y) z (list x y) ) (equal (multiple-value-list (fun4 98 100 'm 39 'n 38)) '(0 (m 39 n 38) (98 100)))) ) ) (do-test "test DEFUN - forms *don't* return multiple values when they *shouldn't* " (and (defun fun1 () (cond (nil (floor 4 2)) ((ffloor 4 2)) )) (equal (multiple-value-list (fun1)) '(2.0)) (defun fun2 (x &optional (y 2) (z 30.0)) (values (list x (expt x y) (decode-float z)))) (equal (multiple-value-list (fun2 8 )) '((8 64 .9375)) ) (defun fun3 (x y z) (or nil () (values (* y z) (+ y z)) (- y z))) (equal (multiple-value-list (fun3 2 4 6)) '(24)) (defun fun4 (&rest z) (values-list (list z))) (equal (multiple-value-list (fun4 'software 'quality 'assurance)) '((software quality assurance))) ) ) (do-test "test DEFUN - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eql (foo (progn (defun fun () (decode-float -8.0)) (fun))) .5) (equalp (foo (progn (defun fun1 (x y z) (and (values x y z))) (fun1 #\a #\b #\c))) #\A) (equal (cons (progn (defun fun2 (w x y z) (or (values-list (list w x y z))) ) (fun2 "a" "b" "c" "d") ) nil) '("a")) (equal (find (progn (defun fun1 (x y z) (and (values x y z))) (fun1 #\z #\b #\c)) "lazy") #\z) ) ) (do-test "test DEFUN - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (defun fun () (values-list '(zebar monkey dragon deer rabit snake bird turtle sqirrel elephant))) (and (equal ( multiple-value-bind (a b c d e f g h i) (fun) (list a b c d e f g h i) ) '(zebar monkey dragon deer rabit snake bird turtle sqirrel)) (equal ( multiple-value-bind (a b c d e f g h i j) (fun) (list a b c d e f g h i j) ) '(zebar monkey dragon deer rabit snake bird turtle sqirrel elephant)) (equal ( multiple-value-bind (a b c d e f g h i j k) (fun) (list a b c d e f g h i j k) ) '(zebar monkey dragon deer rabit snake bird turtle sqirrel elephant nil)) ) ) (do-test "test DEFUN - when forms are used for effect" (and (eq (progn (defun fun (&key a b) (values a b)) (multiple-value-setq (c d) (fun :a 3 :b 6)) (+ c d)) 9) (equal (progn (defun fun1 (a &optional (b 30) &rest rest &key c d) (values a b rest c d)) (multiple-value-bind (s t1 u v w x y z) (fun1 10 11 :d 14 :c 13) (list s t1 u v w x y z))) '(10 11 (:d 14 :c 13) 13 14 nil nil nil )) ) ) (do-test "test DEFMACRO - forms *do* return multiple values when they *should* " (and (defmacro mac () `(ftruncate 7.5)) (equal (multiple-value-list (mac)) '(7.0 .5)) (defmacro mac (w x y z) (list 'values w x y z )) (equal (multiple-value-list (mac 1 2 3 4)) '(1 2 3 4)) (defmacro mac () `(block bar (return-from bar (values #o111 #b1111 #x-11)))) (equal (multiple-value-bind (a b c d e) (mac) (list a b c d e)) '(73 15 -17 nil nil)) (defmacro mac (m n o) `((lambda (a b &rest c) (values-list (list a b c))) ,m ,n ,o)) (equal (multiple-value-list (mac (complex 3 4) (realpart #c(3 4)) (imagpart #c(3 4)) )) '(#c(3 4) 3 (4)) ) ) ) (do-test "test DEFMACRO - exactly one value is used, if forms are passed as an argument to a function call" (defmacro mac1 () `(ftruncate 7.5)) (defmacro mac2 (w x y z) (list 'values w x y z )) (defmacro mac3 () `(block bar (return-from bar (values #o111 #b1111 #x-11)))) (defmacro mac4 (m n o) `((lambda (a b &rest c) (values-list (list a b c))) ,m ,n ,o)) (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (progn (mac1) )) 7.0) (equal (foo (progn (mac2 (find #\a "chiao") ( expt #c(2 -2) 2) #b-1010 '|good earth|))) #\a) (equal (cons (progn (mac3) ) nil) '(73)) (equal (identity (progn (mac4 (complex 3 4) (realpart #c(3 4)) (imagpart #c(3 4)) )) ) #c(3 4)) ) ) (do-test "test EVAL-WHEN - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (eval-when (eval) (values 1 2 3 4))) '(1 2 3 4)) (equal (multiple-value-list (eval-when (eval) (floor -8.0))) '(-8 .0)) (equal (multiple-value-list (eval-when (eval) (values-list '(Morning has broken just like)))) '(Morning has broken just like) ) (equal (multiple-value-list (eval-when (eval) (decode-float 16.0))) '(.5 5 1.0)) ) ) (do-test "test EVAL-WHEN - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (eval-when (eval) (values 1 2 3 4))) 1) (= (foo (eval-when (eval) (floor -8.0))) -8) (eq (foo (eval-when (eval) (values-list '(Morning has broken just like)))) 'Morning) (= (foo (eval-when (eval) (decode-float 16.0))) .5) ) ) (do-test "test PROGV - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (progn (setq aa 'a bb 'b a 0 b 1) (progv (list aa bb) (list 88 99 111) (values a b)) )) '(88 99)) (equal (multiple-value-list (progn (setq foo 'f bar 'b rah 'r f nil b nil r nil) (progv (list foo bar rah) '(to all those who) (values-list (list foo bar rah f b r))) )) '(f b r to all those)) (equal (multiple-value-list (let () (setq foo 'oo bar 'ar rah 'ah) (progv (cons foo (cons bar (cons rah nil))) '(#c(1 -1) #c(2 -2) #c(3 -3)) (values (* oo ah) (+ ah ar) (- ar oo) (list foo bar rah))) )) '( #c(0 -6) #c(5 -5) #c(1 -1) (oo ar ah)) ) (equal (multiple-value-list (progn (defun fun (a b) (progv (list a b) '(prince frog) (values a b (symbol-value a) (symbol-value b) ))) (setq foo 'f bar 'b f nil b nil) (fun foo bar) )) '( f b prince frog)) ) ) (do-test "test PROGV - exactly one value is used, if forms are passed as an argument to a function call" (defun fool (x) (and (equal (list x) (multiple-value-list x)) x)) (and (prog2 (setq aa 'a bb 'b a 0 b 1) (= (fool (progv (list aa bb) (list 88 99 111) (values a b)) ) 88) ) (prog2 (setq foo 'f bar 'b rah 'r f nil b nil r nil) (eq (fool (progv (list foo bar rah) '(to all those who) (values-list (list foo bar rah f b r))) ) 'f) ) (prog2 (setq foo 'oo bar 'ar rah 'ah) (= (fool (progv (cons foo (cons bar (cons rah nil))) '(#c(1 -1) #c(2 -2) #c(3 -3)) (values (* oo ah) (+ ah ar) (- ar oo) (list foo bar rah))) ) #c(0 -6) )) (progn (defun fun (a b) (progv (list a b) '(prince frog) (values a b (symbol-value a) (symbol-value b) ))) (setq foo 'f bar 'b f nil b nil) ( eq (fool (fun foo bar)) 'f ) ) ) ) (do-test "test LET - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (let () (values-list (make-list (1- multiple-values-limit) :initial-element 'rah)))) (append (make-list (- multiple-values-limit 31) :initial-element 'rah) (make-list 30 :initial-element 'rah)) ) (equal (multiple-value-list (let ((size 80)) (values-list (make-list size :initial-element 'rah)))) (append (make-list (- 80 30) :initial-element 'rah) (make-list 30 :initial-element 'rah)) ) (equal (multiple-value-list (let ((a 100.9) (b 3)) (values (fround a) (fround b) (decode-float (float b))))) '(101.0 3.0 .75)) (equal (multiple-value-list (let ((a 100) (b 50) (c -30)) (multiple-value-call #'values (floor a 3) (floor b 30) (floor c 2)))) '(33 1 1 20 -15 0)) ) ) (do-test "test LET - forms *don't* return multiple values when they *shouldn't* " (and (equal (let ((a "a") (b "b") (c "c")) (cond (nil 'atom) ((values-list (list a b c ))))) "a") (equal (let () (setq a '(2) b '(4)) (or nil () (values a b) t 'non-nil)) '(2)) (equal (cons (let () (fceiling 39 7)) nil) '(6.0)) ) ) (do-test "test LET* - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (let* ((size 80)) (values-list (make-list size :initial-element 'rah)))) (append (make-list (- 80 30) :initial-element 'rah) (make-list 30 :initial-element 'rah)) ) (equal (multiple-value-list (let* ((a 100.9) (b 3)) (values (fround a) (fround b) (decode-float (float b))))) '(101.0 3.0 .75)) (equal (multiple-value-list (let* ((a 100) (b 50) (c -30)) (multiple-value-call #'values (floor a 3) (floor b 30) (floor c 2)))) '(33 1 1 20 -15 0)) ) ) (do-test "test LET* - forms *don't* return multiple values when they *shouldn't* " (and (equal (let* ((a "a") (b "b") (c "c")) (cond (nil 'atom) ((values-list (list a b c ))))) "a") (equal (let* () (setq a '(2) b '(4)) (or nil () (values a b) t 'non-nil)) '(2)) (eq (let* (x (y 2) (z 9)) (values (values x y z))) ()) (equal (cons (let* () (fceiling 39 7)) nil) '(6.0)) ) ) (do-test "test MULTIPLE-VALUE-BIND - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (multiple-value-bind () nil (values-list (make-list 20)))) (append (make-list 10) (make-list 10))) (equal (multiple-value-list (multiple-value-bind (a b c d) (decode-float -10.0) (values a b c d))) '(.625 4 -1.0 nil)) (equal (multiple-value-list (multiple-value-bind (a b c d e f) (values-list '(dopey sneezy sleepy bashful grouchy doc witch)) (values a b c d e f) )) '(dopey sneezy sleepy bashful grouchy doc )) (equal (multiple-value-list (multiple-value-bind () (values-list '(sleepy sneezy doc snow white witch)) (values-list '(blue sky red apple squirrel rabbit broom dwarf)))) '(blue sky red apple squirrel rabbit broom dwarf)) ) ) (do-test "test MULTIPLE-VALUE-BIND - forms *don't* return multiple values when they *shouldn't* " (and (eq (multiple-value-bind (a b c) (decode-float 300.0)) ()) (eql (multiple-value-bind (m n o) (decode-float -6.0) (prog1 (values o n m) m n)) -1.0) (eql (multiple-value-bind () t (values (decode-float (float #o-10)))) .5) (eq (multiple-value-bind (a b) (values 'dopey 'jumpy) (cond ((values-list (list b a))))) 'jumpy) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-2.TEST b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-2.TEST new file mode 100644 index 00000000..5589f140 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-2.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: WHEN, UNLESS, CASE, ECASE, CCASE, TYPECASE, ETYPECASE, CTYPECASE ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 6,1986 ;; ;; Last Update: Feb 5, 1987 - Jim Blum - many changes to make this run on the SUN, mostly having to do ;; with floating pt differences. ;; ;; Filed As: {eris}cml>test>7-9-2-MVR-IMPLICIT-PROGN-2.test ;; ;; ;; Syntax: [not applicable] ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely these circumstances: ;; ;; Argument(s): [not applicable] ;; ;; Returns: [not applicable] ;; ;; ;; ;; Implicit PROGN contexts ;; ;; . The special form PROGN passes backs multiple values resulting from evaluation of the last subform. Other situations ;; referred to as "implicit progn," where several forms are evaluated and the results of all but the last form are ;; discarded, also pass back multiple values from the last form. These situations include the body of a lambda-expression, ;; in particular those constructed by DEFUN, DEFMACRO, and DEFTYPE. Also included are bodies of the constructs EVAL-WHEN, ;; PROGV, LET, LET*, WHEN, UNLESS, BLOCK, MULTIPLE-VALUE-BIND, and CATCH, as well as clauses in such conditional constructs ;; as CASE,TYPECASE,ECASE,ETYPECASE, CCASE, and CTYPECASE. ;; ;; (do-test "test WHEN - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (when (= 2 2.0) (values 1 2 3 4 5))) '(1 2 3 4 5)) (equal (multiple-value-list (when (stringp "l") (round 4.5))) '(4 .5)) (equal (multiple-value-list (when (eq (cdr '(9)) nil) (values-list '(xerox flexible benefit account)))) '(xerox flexible benefit account)) (equal (multiple-value-list (when (characterp #\r) (setq a 100 b 3) (floor a b))) '(33 1)) ) ) (do-test "test WHEN - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (when (and (setq a #c(1 1)) (complexp a)) a)) '(#c(1 1))) (equal (multiple-value-list (when (consp 'atom) (values 1 2))) '(nil)) (equal (multiple-value-list (when (and (atom ()) (listp ())) (values-list '(single-value)))) '(single-value)) ) ) (do-test "test WHEN - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (when t (ffloor 5 3))) 1.0) (= (foo (when t (setq a 80 b 33) (fceiling a b))) 3.0) (= (1+ (when t (when t (values 24 5)))) 25) (equal (multiple-value-list (values (when t (ftruncate 4.7)) (when t (fround 5.6)))) '(4.0 6.0)) ) ) (do-test "test WHEN - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (x) (when t (fceiling 8.5 3)) (list x)) '(3.0)) (equal (multiple-value-bind (x y) (when t (ceiling 8 3)) (list x y)) '(3 -1)) (equal (multiple-value-bind (x y z) (when t (ceiling 8 3)) (list x y z)) '(3 -1 nil)) ) ) (do-test "test WHEN - when forms are used for effect" (and (equal (progn (setq a 2 b 3) (multiple-value-setq (c d) (when (evenp a) (values (* a b) (complex a b)))) (* c d)) #c(12 18)) (eq (progn (when t (values-list '(a b c d))) 'end-of-WHEN) 'end-of-WHEN) ) ) (do-test "test UNLESS - forms *do* return multiple values when they *should* " (defmacro mac5 () `(ceiling 7.0 2)) (defun fun () (floor 7.5 2)) (and (equal (multiple-value-list (unless (= 1 3) (values 2 4 6 8 10))) '(2 4 6 8 10)) (equal (multiple-value-list (unless (consp ()) (round 7.5 2))) '(4 -.5)) (equal (multiple-value-list (unless (member '(a) '(aa bb cc)) (fun))) '(3 1.5)) (equal (multiple-value-list (unless (endp '(a)) (mac5))) '(4 -1.0)) ) ) (do-test "test UNLESS - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (unless (eq #\a #\A) (values '(is that impossible ?)))) '((is that impossible ?))) (equal (multiple-value-list (unless (equal "clock" "CLOCK") (last '(a b c)))) '((c))) (equal (multiple-value-list (unless (and t nil) (values (fround 6.9 4)))) '(2.0)) (equal (multiple-value-list (unless nil (complex 8 7))) '(#c(8 7))) ) ) (do-test "test UNLESS - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (unless nil (setq a 99 b -8) (ffloor b a))) -1.0) (= (foo (unless nil (setq a 99.4 b 8.5) (fceiling b a))) 1.0) (= (* (foo (unless nil (setq a 75 b 7) (fround a b))) 2) 22.0) (equal (complex (foo (unless nil (setq a 75 b 7) (ftruncate a b))) 2.1) #c(10.0 2.1)) ) ) (do-test "test UNLESS - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (x y z) (unless nil (values-list'( 1 2 3 4))) (list x y z)) '(1 2 3)) (equal ( multiple-value-bind (w x y z) (unless nil (values-list'( 1 2 3 4))) (list w x y z)) '(1 2 3 4)) (equal ( multiple-value-bind (v w x y z) (unless nil (values-list'( 1 2 3 4))) (list v w x y z)) '(1 2 3 4 nil)) ) ) (do-test "test UNLESS - when forms are used for effect" (and (eq (progn (setq a 10) (unless nil (values (decf a 2) (decf a ) (decf a))) a) 6) (equal (progn (setq a '(1 2 3 4)) (values (rplaca a 'a) (rplaca (cdr a) 'b) (rplaca (cddr a) 'c) (rplaca (last a) 'd)) a) '(a b c d)) ) ) (do-test "test CASE - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (case 11 ((1 2 3) 'case1) ((11 22 33) (values 'case2 'case3)) (otherwise '(case4)))) '(case2 case3)) (equal (multiple-value-list (case #\m ((#\p #\r #\e #\t #\t #\y) (values-list '(pretty blouse))) ((#\c #\u #\t #\e) (values-list '(cute toy))) ((#\m #\e #\l #\o #\d #\y) (values-list '(soft melody))) (otherwise (values-list '(wrong !!))))) '(soft melody)) (equal (multiple-value-list (case (sqrt 100) (10 (floor 8 3)) ((20 30) (ceiling 8 3)) ((25.0 10.0) (round 13 7)) (otherwise (truncate 999 7)) )) '(2 -1)) ) ) (do-test "test CASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (case (setq a 7) ((1 3) (values 10 30)) ((5 7) (cond ((evenp a) (values (* 2 a) (* 3 a))) ( (values (* 4 a) (* 5 a))))) (otherwise (values 10 100)))) '(28)) (equal (multiple-value-list (case 'foo (foo0 (ffloor -4 -3)) (foo (or (ftruncate -5 -2) 3 2 )) (foo3 (fround 7.9)))) '(2.0)) ) ) (do-test "test CASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (case 'a ('A (values 'blocks 'and 'exits)))) 'blocks) (eq (foo (case #\a ( #\d nil) ( #\a (floor 7 -3)))) -3) (equal (list (foo (case 100 (10 t) (20 nil) (t (values 9 6 3)))) 99 999) '(9 99 999)) (eq (list-length (foo (case 20 (20.0 '(())) (10 '(1 2 3)) (20 (values '(a b c d) '(e f)))))) 4) ) ) ) (do-test "test CASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (a b c d e) (case 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) (t (ceiling 1000 99))) (list a b c d e)) '(-3 1 14 1 4 )) (equal ( multiple-value-bind (a b c d e f) (case 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) (t (ceiling 1000 99))) (list a b c d e f)) '(-3 1 14 1 4 -8)) (equal ( multiple-value-bind (a b c d e f g) (case 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) (t (ceiling 1000 99))) (list a b c d e f g)) '(-3 1 14 1 4 -8 nil)) ) ) (do-test "test CASE - when forms are used for effect" (and (equal (progn (setq a 2) (case a (1 (defun fun () 'fun1)) (2 (defun fun () (values-list '(fun2 fun22)))) (3 (defun fun () (ffloor -999 37)))) (cdr (multiple-value-list (fun)))) '( fun22)) (eq (let ((a 83)) (list-length (multiple-value-list (case (evenp a) ((t) (values 12 34 56)) (t (values 00 99 88 77 6 66)))))) 6) ) ) (do-test "test ECASE - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (ecase 11 ((1 2 3) 'ecase1) ((11 22 33) (values 'ecase2 'ecase3)) )) '(ecase2 ecase3)) (equal (multiple-value-list (ecase #\m ((#\p #\r #\e #\t #\t #\y) (values-list '(pretty blouse))) ((#\c #\u #\t #\e) (values-list '(cute toy))) ((#\m #\e #\l #\o #\d #\y) (values-list '(soft melody))) )) '(soft melody)) (equal (multiple-value-list (ecase (1+ 9) (10.0 (floor 8 3)) ((20 30) (ceiling 8 3)) ((25.0 10) (round 13 7)) )) '(2 -1)) ) ) (do-test "test ECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (ecase (setq a 7) ((1 3) (values 10 30)) ((5 7) (cond ((evenp a) (values (* 2 a) (* 3 a))) ( (values (* 4 a) (* 5 a))))) )) '(28)) (equal (multiple-value-list (ecase 'foo (foo0 (ffloor -4 -3)) (foo (or (ftruncate -5 -2) 3 2 )) (foo3 (fround 7.9)))) '(2.0)) ) ) (do-test "test ECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (ecase 'a ('A (values 'blocks 'and 'exits)))) 'blocks) (eq (foo (ecase #\a ( #\d nil) ( #\a (floor 7 -3)))) -3) (equal (list (foo (ecase 100 (10 t) (20 nil) (100 (values 9 6 3)))) 99 999) '(9 99 999)) (eq (list-length (foo (ecase 20 (20.0 '(())) (10 '(1 2 3)) (20 (values '(a b c d) '(e f)))))) 4) ) ) ) (do-test "test ECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (a b c d e) (ecase 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e)) '(-3 1 14 1 4)) (equal ( multiple-value-bind (a b c d e f) (ecase 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f)) '(-3 1 14 1 4 -8)) (equal ( multiple-value-bind (a b c d e f g) (ecase 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f g)) '(-3 1 14 1 4 -8 nil)) ) ) (do-test "test ECASE - when forms are used for effect" (and (equal (progn (setq a 2) (ecase a (1 (defun fun () 'fun1)) (2 (defun fun () (values-list '(fun2 fun22)))) (3 (defun fun () (ffloor -999 37)))) (cdr (multiple-value-list (fun)))) '( fun22)) (eq (let ((a 83)) (list-length (multiple-value-list (ecase (evenp a) ((t) (values 12 34 56)) ((nil) (values 00 99 88 77 6 66)))))) 6) ) ) (do-test "test CCASE - forms *do* return multiple values when they *should* " (let (( z '(11 #\m 10))) (and (equal (multiple-value-list (ccase (car z) ((1 2 3) 'ccase1) ((11 22 33) (values 'ccase2 'ccase3)) )) '(ccase2 ccase3)) (equal (multiple-value-list (ccase (cadr z) ((#\p #\r #\e #\t #\t #\y) (values-list '(pretty blouse))) ((#\c #\u #\t #\e) (values-list '(cute toy))) ((#\m #\e #\l #\o #\d #\y) (values-list '(soft melody))) )) '(soft melody)) (equal (multiple-value-list (ccase (caddr z) (10.0 (floor 8 3)) ((20 30) (ceiling 8 3)) ((25.0 10) (round 13 7)) )) '(2 -1)) ) ) ) (do-test "test CCASE - forms *don't* return multiple values when they *shouldn't* " (let ((a 7) (b 'foo)) (and (equal (multiple-value-list (ccase a ((1 3) (values 10 30)) ((5 7) (cond ((evenp a) (values (* 2 a) (* 3 a))) ( (values (* 4 a) (* 5 a))))) )) '(28)) (equal (multiple-value-list (ccase b (foo0 (ffloor -4 -3)) (foo (or (ftruncate -5 -2) 3 2 )) (foo3 (fround 7.9)))) '(2.0)) ) ) ) (do-test "test CCASE - exactly one value is used, if forms are passed as an argument to a function call" (flet (( foo (x) (and (equal (list x) (multiple-value-list x)) x))) (let (( a 'a) (b #\a) (c 100) (d 20)) (and (eq (foo (ccase a ('A (values 'blocks 'and 'exits)))) 'blocks) (eq (foo (ccase b ( #\d nil) ( #\a (floor 7 -3)))) -3) (equal (list (foo (ccase c (10 t) (20 nil) (100 (values 9 6 3)))) 99 999) '(9 99 999)) (eq (list-length (foo (ccase d (20.0 '(())) (10 '(1 2 3)) (20 (values '(a b c d) '(e f)))))) 4) ) ) ) ) (do-test "test CCASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (let (( aa 'sun)) (and (equal ( multiple-value-bind (a b c d e) (ccase aa ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e)) '(-3 1 14 1 4)) (equal ( multiple-value-bind (a b c d e f) (ccase aa ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f)) '(-3 1 14 1 4 -8)) (equal ( multiple-value-bind (a b c d e f g) (ccase aa ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f g)) '(-3 1 14 1 4 -8 nil)) ) ) ) (do-test "test CCASE - when forms are used for effect" (and (equal (let (( a 2) ) (ccase a (1 (defun fun () 'fun1)) (2 (defun fun () (values-list '(fun2 fun22)))) (3 (defun fun () (ffloor -999 37)))) (cdr (multiple-value-list (fun)))) '( fun22)) (eq (let ((a (evenp 83))) (list-length (multiple-value-list (ccase a ((t) (values 12 34 56)) ((nil) (values 00 99 88 77 6 66)))))) 6) ) ) (do-test "test TYPECASE - check if forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (typecase (car '(100)) (string (values 'str1 'str2)) (array (values 'ary1 'ary2)) (number (values 5 10 15 20)))) '(5 10 15 20)) (equal (multiple-value-list (typecase (cdr '(c a b)) (number (values 1 2 3 4)) ((or list character) (values '(1 . 2) '(3 . 4) #\n)) (complex (values #c(1 2) #c(4 5))) (t (values 'something 'is 'wrong)) )) '( (1 . 2) (3 . 4) #\n)) (equal (multiple-value-list (typecase (caddr '(2 4 "August")) ((simple-string 10) (round 3.7)) ((integer -2 100) (round 2.3)) ((simple-string 6) (round 4.5)) )) '(4 .5)) (equal (multiple-value-list (typecase (second '(2 1 9)) ((integer 2 9) (floor 9 2)) ((float -2.0 9.0) (floor 9 2)) (complex (truncate 5 4)) (bit (truncate 13 -7)) (t (values 'something 'else)) )) '(-1 6)) ) ) (do-test "test TYPECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (typecase (second '(1200 9.99 #c(5 6) 87)) ((or rational float) (or (values-list '(to all those who strive for excellence)) 99)) ((float 5 6) (values 100 99 98 97)) ((complex integer) (or (values-list '(twinkle twinkle little star)) 999)) (t (values -10 -20 -30 -40)) )) '(to)) (equal (multiple-value-list (typecase (cdr '(m n o p)) ((or string cons) (values (fround 7.9))) ((vector) (values (ftruncate 7.9))) (bit (values (fceiling 3.4))) (t (values (ffloor -3.4))) )) '(8.0)) ) ) (do-test "test TYPECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (typecase (second '(a #\r t #\i s t)) ( character (values 88 999 10000)) )) 88) (equal (foo (typecase (third '(a #\r t #\i s t)) (list (values 1 2)) (atom (values 11 22 33)) )) 11) (equal (cons (typecase (fourth '(a #\r t #\i s t)) (number ()) (character (fround 3.999)) ) #\%) '(4.0 . #\%)) (equal (list (typecase (first '(1 2 #\3 (4))) (list (values 100 200 300)) (character (values #\a #\b #\c #\d)) ((integer -1 2) (values -1 0 1 2)) )) '(-1)) ) ) ) (do-test "test TYPECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (typecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) (otherwise (values-list '(love story sung by Andy Willium))) ) (list w x y z)) '(the simple truth about)) (equal ( multiple-value-bind (v w x y z) (typecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) (otherwise (values-list '(love story sung by Andy Willium))) ) (list v w x y z)) '(the simple truth about love)) (equal ( multiple-value-bind (u v w x y z) (typecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) (otherwise (values-list '(love story sung by Andy Willium))) ) (list u v w x y z)) '(the simple truth about love nil)) ) ) (do-test "test TYPECASE - when forms are used for effect" (and (eq (progn (setq a 20.0) (typecase a (integer (floor 5 2)) (float (floor 15 2))) 'prog10) 'prog10) (eq (progn (setq a 200 ) (typecase a (integer (values 'a 'b )) (float (values 'c 'd))) 'the-end) 'the-end) ) ) (do-test "test ETYPECASE - check if forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (etypecase (car '(100)) (string (values 'str1 'str2)) (array (values 'ary1 'ary2)) (number (values 5 10 15 20)))) '(5 10 15 20)) (equal (multiple-value-list (etypecase (cdr '(c a b)) (number (values 1 2 3 4)) ((or list character) (values '(1 . 2) '(3 . 4) #\n)) (complex (values #c(1 2) #c(4 5))) )) '( (1 . 2) (3 . 4) #\n)) (equal (multiple-value-list (etypecase (caddr '(2 4 "August")) ((simple-string 10) (round 3.7)) ((integer -2 100) (round 2.3)) ((simple-string 6) (round 4.5)) )) '(4 .5)) (equal (multiple-value-list (etypecase (second '(2 1 9)) ((integer 2 9) (floor 9 2)) ((float -2.0 9.0) (floor 9 2)) (complex (truncate 5 4)) (bit (truncate 13 -7)) )) '(-1 6)) ) ) (do-test "test ETYPECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (etypecase (second '(1200 9.99 #c(5 6) 87)) ((or rational float) (or (values-list '(to all those who strive for excellence)) 99)) ((float 5 6) (values 100 99 98 97)) ((complex integer) (or (values-list '(twinkle twinkle little star)) 999)) (bit (values -10 -20 -30 -40)) )) '(to)) (equal (multiple-value-list (etypecase (cdr '(m n o p)) ((or string cons) (values (fround 7.9))) ((vector) (values (ftruncate 7.9))) (bit (values (fceiling 3.4))) (character (values (ffloor -3.4))) )) '(8.0)) ) ) (do-test "test ETYPECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (etypecase (second '(a #\r t #\i s t)) ( character (values 88 999 10000)) )) 88) (equal (foo (etypecase (third '(a #\r t #\i s t)) (list (values 1 2)) (atom (values 11 22 33)) )) 11) (equal (cons (etypecase (fourth '(a #\r t #\i s t)) (number ()) (character (fround 3.999)) ) #\%) '(4.0 . #\%)) (equal (list (etypecase (first '(1 2 #\3 (4))) (list (values 100 200 300)) (character (values #\a #\b #\c #\d)) ((integer -1 2) (values -1 0 1 2)) )) '(-1)) ) ) ) (do-test "test ETYPECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (etypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list w x y z)) '(the simple truth about)) (equal ( multiple-value-bind (v w x y z) (etypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list v w x y z)) '(the simple truth about love)) (equal ( multiple-value-bind (u v w x y z) (etypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list u v w x y z)) '(the simple truth about love nil)) ) ) (do-test "test ETYPECASE - when forms are used for effect" (and (eq (progn (setq a 20.0) (etypecase a (integer (floor 5 2)) (float (floor 15 2))) 'prog10) 'prog10) (eq (progn (setq a 200 ) (etypecase a (integer (values 'a 'b )) (float (values 'c 'd))) 'the-end) 'the-end) ) ) (do-test "test CTYPECASE - check if forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (ctypecase (car '(100)) (string (values 'str1 'str2)) (array (values 'ary1 'ary2)) (number (values 5 10 15 20)))) '(5 10 15 20)) (equal (multiple-value-list (ctypecase (cdr '(c a b)) (number (values 1 2 3 4)) ((or list character) (values '(1 . 2) '(3 . 4) #\n)) (complex (values #c(1 2) #c(4 5))) )) '( (1 . 2) (3 . 4) #\n)) (equal (multiple-value-list (ctypecase (caddr '(2 4 "August")) ((simple-string 10) (round 3.7)) ((integer -2 100) (round 2.3)) ((simple-string 6) (fround 4.5)) )) '(4.0 .5)) (equal (multiple-value-list (ctypecase (second '(2 1 9)) ((integer 2 9) (floor 9 2)) ((float -2.0 9.0) (ffloor 9 2)) (complex (truncate 5 4)) (bit (truncate 13 -7)) )) '(-1 6)) ) ) (do-test "test CTYPECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (ctypecase (third '(1200 9.99 #c(5 6) 87)) ((or rational float) (values-list '(to all those who strive for excellence))) ((float 5 6) (values 100 99 98 97)) ((complex integer) (or (values-list '(twinkle twinkle little star)) 999)) (bit (values -10 -20 -30 -40)) )) '(twinkle)) (equal (multiple-value-list (ctypecase (cdr '(m n o p)) ((or string cons) (values (round 7.9))) ((vector) (values (truncate 7.9))) (bit (values (ceiling 3.4))) (character (values (floor -3.4))) )) '(8)) ) ) (do-test "test CTYPECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (ctypecase (second '(a #\r t #\i s t)) ( character (values 88 999 10000)) )) 88) (equal (foo (ctypecase (third '(a #\r t #\i s t)) (list (values 1 2)) (atom (values 11 22 33)) )) 11) (equal (cons (ctypecase (fourth '(a #\r t #\i s t)) (number ()) (character (fround 3.999)) ) #\%) '(4.0 . #\%)) (equal (list (ctypecase (first '(1 2 #\3 (4))) (list (values 100 200 300)) (character (values #\a #\b #\c #\d)) ((integer -1 2) (values -1 0 1 2)) )) '(-1)) ) ) ) (do-test "test CTYPECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (ctypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list w x y z)) '(the simple truth about)) (equal ( multiple-value-bind (v w x y z) (ctypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list v w x y z)) '(the simple truth about love)) (equal ( multiple-value-bind (u v w x y z) (ctypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list u v w x y z)) '(the simple truth about love nil)) ) ) (do-test "test CTYPECASE - when forms are used for effect" (and (eq (progn (setq a 20.0) (ctypecase a (integer (floor 5 2)) (float (floor 15 2))) 'prog10) 'prog10) (eq (progn (setq a 200 ) (ctypecase a (integer (values 'a 'b )) (float (values 'c 'd))) 'the-end) 'the-end) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-MISC-SITUATIONS.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-MISC-SITUATIONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..23c504b64e83df8293359fdafec52b9cf0e72301 GIT binary patch literal 6683 zcmc&2YiwK9`P_5uYv<9_NkeHulis9{6gMtSNYfIa#C4q7iS3*Ekv658aT5n8xp6`g z0~G^>(iLs9%F>K*50r-n8WPe5WYQ1=WQlE>GIiRYmQB?(wrNO+X{-qCB?Q^`onyOB z%wvN{i*oPxIOlw?^PTT}*K@>t)a6rM6XTO3dVETqNX<;9X4K({DRp`xH8mJlhk>u& z=hA}i`#nxq@9vvhN<#%BgH!R?OngWUr{dE?v6Ibe%T20ta%w~eWdD93+dJCYI&R#% zyR_RG@(F2QxMp9+-nNd`_T8n+PcBHd2|~yq$si~p#71OdoJ-s6VRtC(==S>Dj)2qe zwi|Os+6ulnA|ZFsNLRM1GZT{zJ$`pwM|Z}jiA0F;owT((5^#mRTELi>W~FlDk@Pxm zz|jY;IS;uBwPvNDbje89>~q}YXm$AegATtpjTBXFR(Ta>#0pyiA-y>SZPYIbzJgimpQfVEaFI{`24<+GaC8V5?%*bG{&?0Kf zS!AtL*Ny2^mvxhFE;aLra^X_68dOjzS_MFYIA^pfonEQ>-pk}n0%lb1DMk4(0RPd= z8Evx^t%Wy@)@QVODY^;XG^%DaRf=weH%J1THw#G>bBWoJs>P1VJsS#ypifeC2dd2q z+=c?BXk*@lM)bLAjf1g}3r6)QcRjZqTXj<*{WRz)gm% z7EDV`PB~BiF$`n{WE|hW#rt*I^KrE)qgw$e8N2{+pqlhl)3Fs)e$7)oOQxPBC1>qy zVzHeIAwmevjILbA6~Q9XvqY~hTH6R)ewA}_JE{Zs@*Zl)$US8R18u8kHsof(rGzNv zdVwUgcr7=^I+3$^M?rniDX7%x^5RWd^AKEEyuN_ySgb(`tmGGC)>9}h|C5F15-)B1 zw99rbVH>d#y2E%hz1i;40$pD05gZ<8pv&hDIu3e)6F3yI)9tK;Zi8nlJPpvsNC)$M z3w9h-MV^zD(Rx-+>sTqR1y}=c6D+tEo{jKa15Y(P8*uV5m|TU(03el!90jD5*=RXi zPs>;ZT?flcK#UcZDDaqJQl;JH47)szpgSB1Li^+5{gV+!qPkw9D5JOs;@@d)t3hy-)gth)>kw>&6_(@vexEnQZQlR}l=VA(5qHRuGOO!eM~IhCYTL^S;?*=M0$$zq$fB}`Zk{k zIgeqL+6B0gE0DHuihLlz`s&dR<1)!vR{H?EZWlu>oX&I#h@08%GK+T6+-k!llDwhLfo+kmNjlaDF0oT=Q!f%!SkG(RDz zv;a+lSud#d9LVQ6Q=S*pX#wtoOtyw1fsn@=aPxGQQ*1kElLy51)QMHqV!D|Fn&wRU zkf3G+xPz~Q8i5{2A9JSkz5ti`m^3TK?h(v{0AB+Ws2}RjG;17XTW@Dud)W447=?ct z>Dy=G(=%$=<5nGN{NC8$jDAv`NXFH>V|psCj!dhm>G)8yIx;N2($v^gT%C+f15=Gn ztFa_7?o5rxlQU2^)R;P)N)FD9OeEF8n69IW4~_JeFsf*Lz}ct{$KZ2yNF7OvFHPh< zfWff5YNSnQ3F30q^6SUcuJocnS`%+9`b4RoeBBc-6u@+hS*iHmB#=M-3&x2qiD3f9HaHI@P-iw$i8#Hn?kjlSd9gm#p z^lh`;E9Gy+tapJ`5XG~@AhQHSD!i~p9donI0Bchqb~??a)nh$zVX;tT%ArqdVSdtDd%~JlsG87MnPNp0V}s6=39__ z*ur_LiTE)fQ9A(LAuZ?*Jw@GN#L$tvX>d{JnIpe=&8 zP5i*JGK8QQen63!7o_2T+H`2&p8fJxFw+)*UdN}ooW5*7!KzfYrH(a#8MOrTP2dhn_A+)}f6oC;`9Zcwac^ zi3ECEaR>I`uE>Zr;I5bvt6m_xJWD1KV-v(!(dA1JV+BwXP{QTW&Wa3pZX>L>*u{O& z^r(4vP^iLPG6|Q2P~no20TF#GeSih#zk)rdmY0`5!Phc!-dP|8zl0R%2e0$xL4>$n zUe8o3+hS%aks$H~lCX4`|FA%0C_StXBPRMN#Bk`BMd!o(nvw3{=ffZIg}vAr@wNlc z$)OfFB)m3=^MQpJYcuYQ8Xq2x4`T5&zrxRe`4m_p;~6mfi?tju()WF#mfU5~lx!+0 zQK&n9?BE0T_uW;NLyOAe{YT`g)dHGU#KHLXqz=Sy2G2`kX54q>L*m@i>< zkfSDO_F7n37HiF8H|DXnJhnHFwdb*YtZWwKn$8>ZR#wMG*eDxgIvZz6Hi7&{KZD=? z8GMH^Z&@h^q{zSh^x5*8MKP9tWTf@ai*YWzYk1enFY=(u$JgrKlU>DrwHfKdpXb+? zE#C4TZan=6L%bdGfO-S0jP1aTa1Xdce5YlX6PU>IJA0v<;={5l2)zw#5B-3zWq^_g z*$xg*@%KageLBng2G0Ep91v6Pz|%jjpe`Hp3MsK#6f9D7u_y@iStIS?LBMm_3g_4 zKUzs39LF84_UU~0-gC}(?z#8fd*9oBBV$u#*k8H3qq8m9+U4K9r>ApIkAKJRE`Rs# zJzXuW{vBBFf20zkp-0yRE7up^SCk!_(9+V?+SJp!-5=l6+P%GL|5AU^N`J7kt1XFO z#R@Ezm6w*5mn<*Lt`5e+;_Y*7?k!)wyu5ftVfMAB2hH5whGDcAHVL<3=PDi(48b<1=K38=^ zq%vLuk<@^B*vv_Nz0X?{3DjfPf@?#Da*cW+?`EoR#=U`+fx3opyrv$B8iV16P|SFG zaDA^~w!dDhHvYFS&&>FJ4zs`QaN;$D`Mp`aX5!p%1o24!`X?jb zHH`kmkw~pFy@+0#z423WgRL%fX&81}%dfesqmET>+Huy-q)IxH&SXY*22+sT#i1aH zqywE{a-?c0dgIy_1PNc#Inm%G@}Opa;xI-?e^V0Wo^+J1QEuY*jK?$;B#x3aiF+&+ z$;@O{(v@^4y-80xJrn9?-K1{*P3rERR9Bo`JjKyJmyX`Mv*qg09Z7|m`V9`-(Cm#@ z5#pFk7{jR=80YCUtA|DeN$@)yQPvzgV!|B!Dl_5p`FP?y^RjU?kybGy+`wc7j(jG}#jm& z7l$>^oQWfA71&UKcs3L$tI&o*#B-ofS;aOKBlbbDvdU~ILp&GClvQp+IpTRxuB_EI ztVZmI)yk@{p#t#&s8Ck54b_MjLbbALZKy@O2x^rTu_1zZF<@*_8={B{AgZiJ8yXQW zg+^stAIE^?CrvN>P@#ATZycOpbZg_HhU?0= z2*Ltb2#a7bEQMuI3M*h0tbr<62Vtm(IBbHg@E~l51SFvodf;I=2#4Wu_$u_lQ*Z)O z@D2Dg_$K^0oPn3%+wdy94u1pRgYUyd_&az9-h~g~$MBQ?&&_~A9!}(c@lV^xRNVaD zyVEy+7v^nzJ;bQmMuzrd-A>%aGZH?mNX`_2`yQ4s$N2v`3(_f19}7@9sl>p=0$b7L z0l?3N5z~#4af+sd z_vtk69^^%q!);UHHs?&*?Ou#ozB10EU8A0j;7$4L#w&@jo&Utmbtk5Q%!b--%*0T` zXISDH1NRhcq(MhG$(1kd3Uws45>5IHFg2%u>_j>p`;dnQ54rG*$;dMwj?mT*Bcn$l zNfV!J%$BR8=NsGr$2x)Mn>0?J+9Y_fM7R0a*(sYL*`K6ir&WO5QYz&H&m=>4Nr5|a zKstkortbU~-9-7U^}8hUcq08QLMG!6BmIfowp>FUz-KNqIQEc5k4I{M>W};87F0r{ zs)in@0_%d2s&FV8sHnl3$l6$edRTkZKAofX;cZ0*S3qAh9hKNNfcHiEXh!Vp}AT*cJ*Twgm!-&5uw; zh-@As;+o5dsCofv@RH@;s+E*WkWO?icENMp-pQ00k+K?zmqD1v5=7KAT>XMcUsogy2fx# zj9nc;b!SOkV@!Lg`JfJy*stqI>_O$3u~57^5Zhc=0pURUjR!T>>lzYux|YOh&2KVp z!9X*D_4VP+R5?Su<%-CrPRNT7YV=|;XVfp(Ql(RGK;ijcY;zzn;a}(|iOcN7^AEb7 zO0P@l9O`+*Wni>No)a9Gr=R2U^m1IDI`O+!M47lO5HU-9<+Eq+6;| zmX1-WMhqShv0Ox+m``JK*EKeGU1D?B+dR4v9RA8;bm011cIWyY2kiQ`D7~yHude4s z3`*sIl%5iUCz;=ML@NJKDi4d7{ZiQ_qDjoRiOQG7u8c!;l}LySImE0VU~JiUh8jcB z&4Cy$>fsPZk+n!SkeH7HIeqdZbAE^YI)~Y>b0zzAma$*wUF_HK8&+}rnpGSZr1V`W z9b*H>*Vw>uPz)lXvR+h{NNF*b)W=*>BT{-#N|&W{R!Xl(sh?e|W9(Wz#;#RdR5oy? zRD_3JRq?o~FNwh%F>tei`4cuUf5Zmn@3D%xg;mV;qOwp_Zf6zaQ&urPVHM+NtYVyJ z72~f(eqdI&**GF{?=-M@Uy$@5KSpf}^s`}kH1UcWqat1F`R62(* zI5Q)(;_!m-mzrG=NLN23*!j^0f4I&2pHli)DgBT&y_Z57xA35otCy|rIJ?j&kP&)APmOa z#$kJ#I9_jq2-+b((@?VN%@;#2Tez=^_ytGm{;`Oc(2ehAX{(RI+9L7eKFNOE$Hl=B z5wt&KZ$q~4X1^J z__{p;@jy6)hzVT@B3yz@t~erf4-Kb_4jXyguL(=MOaqrs+~x@i7`WLe*V7|51nXlHbrB&ZP(S{Bq-CH3iaj%dNZ9MX5H{Ri6~W~ubg*NeZHR7?jCDL*#MyhXavZhJx`>;D)nUxF#No2E#EOBsE-eH#9&z#M#TK*89kXZ!8|qUyZ|Wuw#7?&Ge(J z?>Wl)o;WJ$YQ0rfI7JFrLQmccc#4!Y>d8sg-bdKlTQ<36A-A|cMNfz65b7SDq~ks# zIvuG2r*6XTn)P^`MX^CdlxMB`*2#uhZ0P!7Y9IrX{s+1h30$uY8uz#E{P;v`()sb9 z;7=${dOB@Qs`s|HkGz<4G`-q(Zs&XLBhMwBP3Mm!Z+|s$E^&TMa9vHUyrcWvp>i0i z_ZoiqT#d}BK1VQG#Q%$N5ZsHPo*q1dVXi9S|E1k$KB%g~ z2}YTE0tdxSD}rky_Cq-{AE$`8V)dkCyOwgYvjT%=#+seiFuva@HghyKoI7Yiv{?&M z110(ay;|R|SLyq7xn8MP=zDdUUam`Zi7wVfdYQgQ7wUjss+Z^jeYak$@6wC(oqD0Z zLod*`Yrmea=jq$@T>T~O)3@q5`W8J~&(bsX44tp@bgrJRr|E2Da|S2%#CZ?*#PI>n z_0$QaJ-S1;(@amw+B-PO!tuCRtW6DM8aUIO8R*%8cbx-E1Q%Y{a2sY58+g8}e;?CQ zKTY2R>f(6ii{nsFB355vVujl_P9r+n zo2`?4nlbTt7Y3)hC^xjdJE{RU__0z&Q0`0<`%CKxx-$Nr{M|ZUew)h1B>%>Luz%xa z%#`*VYi^;%rOQbko<7!0VgP;Muii!eCH`Xn{eD_ejjv3opz>j~<{odko?xBcXI@`p LoFx69Uc2^xHcL1B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST b/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST new file mode 100644 index 00000000..1e4cc6a1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: values, values-list, multiple-value-list, multiple-value-call, ;; multiple-value-prog1, multiple-value-bind, and multiple-value-setq ;; ;; Source: Steele's book Section 7.9: multiple values Page: 133-137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 21, 1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - fixed mult val setq2 test ;; ;; Filed As: {eris}cml>test>7-9-multiple-values.test ;; ;; ;; Syntax: VALUES &rest args ;; ;; Function Description: VALUES takes any number of arguments and returns that many values, in order. ;; ;; Argument(s): args ;; ;; Returns: values ;; ;; .................................................................................................... ;; ;; Syntax: VALUES-LIST list ;; ;; Function Description: VALUES-LIST takes all of the elements of list and returns multiple values. ;; ;; Argument(s): list ;; ;; Returns: values ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-LIST form ;; ;; Function Description: MULTIPLE-VALUE-LIST evaluates form and returns a list of multiple values ;; it returned. ;; ;; Argument(s): form ;; ;; Returns: a list of multiple values ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-BIND ({var}*) values-form {declaration}* {form}* ;; ;; Function Description: MULTIPLE-VALUE-BIND evaluates the values-form and binds the values returned to ;; the variables specified in {var}*. The forms, which make up an implicit progn, ;; will then be executed. ;; ;; Argument(s): ({var}*) - a list of variables ;; values-form - a form which might return multiple values ;; {declaration}* - ;; {form}* - a number of list form(s) ;; ;; Returns: value of the last form evaluated ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-CALL function {form}* ;; ;; Function Description: MULTIPLE-VALUE-CALL first evaluates the function to obtain a function and then ;; evaluates the forms. All the values of the forms are given as arguments to ;; the function. The result of MULTIPLE-VALUE-CALL is whatever returned by the ;; function. ;; ;; Argument(s): function - ;; {form}* - ;; ;; Returns: value returned by the function ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-PROG1 form {form}* ;; ;; Function Description: MULTIPLE-VALUE-PROG1 evaluates the first form and saves all the values produced ;; by that form. It then evaluates the remaining forms and discarding their values. ;; MULTIPLE-VALUE-PROG1 returns the values produced by the first form. ;; ;; Argument(s): form - ;; {form}* - ;; ;; Returns: value returned by the first form ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-SETQ variables form ;; ;; Function Description: MULTIPLE-VALUE-SETQ evaluates the form and set the variables to the values ;; returned by that form. MULTIPLE-VALUE-SETQ returns the first value produced ;; by the form. ;; ;; Argument(s): variables - a list of variables ;; form - ;; ;; Returns: the first value returned by the form ;; ;; ;; **** check if the constant "multiple-values-limit" was properly defined **** ;; (do-test test-multiple-values-limit (and (boundp 'multiple-values-limit) (integerp multiple-values-limit) (>= multiple-values-limit 20))) ;; ;; ;; **** tests for "values" & "multiple-value-list" functions **** ;; ;; (do-test test-values0 (and (eq (values) nil) (equal (multiple-value-list (values 1 2 3 4 5)) '(1 2 3 4 5)) (equal (multiple-value-list (values "1 + 2 = " (+ 1 2))) '("1 + 2 = " 3)) (equal (multiple-value-list (values 'a #\b 99 (list 'list) (/ 8 2))) '(a #\b 99 (list) 4)) (equal (multiple-value-list (values)) nil))) (do-test test-values1 (and (equal (multiple-value-list (values 'list ''foo ''bar)) '(list 'foo 'bar)) )) ;;;**** (equal (multiple-value-list (values (multiple-value-list (values 'list ''foo ''bar)))) ;;;;**** '((foo bar))))) (do-test test-values2 ;; ;; input 50 arguments to "values" and see if it works ;; (and (equal (multiple-value-list (values 1 2 3 4 5 6 7 8 9 10 11 2 3 4 5 6 7 8 9 10 21 2 3 4 5 6 7 8 9 10 31 2 3 4 5 6 7 8 9 10 41 2 3 4 5 6 7 8 9 50)) '(1 2 3 4 5 6 7 8 9 10 11 2 3 4 5 6 7 8 9 10 21 2 3 4 5 6 7 8 9 10 31 2 3 4 5 6 7 8 9 10 41 2 3 4 5 6 7 8 9 50)))) (do-test test-values3 (and (setq x 1) (setq y 2) (equal (multiple-value-list (values x y)) '(1 2)))) ;; ;; ;; ;; **** tests for "values-list" & "multiple-value-bind" functions **** ;; ;; (do-test test-values-list0 (and (equal (multiple-value-bind (n0 n1 n2) (values-list '(0 1 2)) (list n0 n1 n2)) '(0 1 2)) ;; ;; with more variables than values returned ;; (equal (multiple-value-bind (n0 n1) (values-list ()) (list n0 n1)) '(nil nil)) (equal (multiple-value-bind (n0 n1 n2 n3 n4) (values-list '(0 1 2)) (list n0 n1 n2 n3 n4)) '(0 1 2 nil nil)) ;; ;; with less variables than values returned ;; (equal (multiple-value-bind (n0 n1 n2) (values-list '(0 1 2 3 4 5)) (list n0 n1 n2)) '(0 1 2)) (equal (multiple-value-bind () (values-list '(0 1 2 3 4 5)) (= 1 1)) 't))) (do-test test-values-list1 (and (equal (multiple-value-bind (n0 n1 n2) (values-list (list (cons 'a 'b) (list 'c 'd) (prog1 'efg))) (list n0 n2 n1)) '((a . b) efg (c d))) (equal (multiple-value-bind (n0 n1 n2) (values-list (list (cons 'a 'b) (list 'c 'd) (prog1 'efg)))) nil))) (do-test test-values-list2 (equal (multiple-value-bind (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50) (values-list (list 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)) (declare (special n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50)) (and (every #'boundp '(n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50)) (every #'(lambda (x) (= x 1)) (list n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50)))) 't)) ;; ;; ;; ;; **** tests for "multiple-value-call" function **** ;; ;; (do-test test-multiple-value-call0 (and (equal (multiple-value-call #'/= (values-list '(2 4 6 8.0 10))) 't) (equal (multiple-value-call #'+ 1 (+ 2 3) (* 4 5) (values 6 7) (values-list '(9 10))) 58) (equal (multiple-value-call #'(lambda (x y z) (notany #'oddp (list x y z))) (* 10 2) (/ 10 5) 8) 't) (equal (multiple-value-call #'(lambda (ar1 ar2 &optional (ar3 33 ar3-flag) ar4) (list ar1 ar2 ar3 ar3-flag ar4)) (values 1 2 3) 'last-not-least) '(1 2 3 t last-not-least)))) ;; ;; ;; **** tests for "multiple-value-prog1" function **** ;; ;; (do-test test-multiple-value-prog10 (and (eq (multiple-value-prog1 'a 'b 'c 'd 'e) 'a) (= (multiple-value-prog1 (setq a 10) (setq a 20) (setq a 30)) 10) (eq (multiple-value-prog1 () (values 1 2 3)) nil) (equal (multiple-value-call #'- (multiple-value-prog1 (values-list (list (prog1 1) (prog1 2) (prog1 3))) (evenp 3))) -4) (eq (multiple-value-prog1 (car (setq x '(o p q r))) (rplaca x 'u)) 'o))) ;; ;; ;; **** tests for "multiple-value-setq" function **** ;; ;; ;; (do-test test-multiple-value-setq0 (and (eq (multiple-value-setq (n0 n1) ()) nil) (equal (list n0 n1) '(nil nil)))) (do-test test-multiple-value-setq1 (eq (multiple-value-setq () ()) nil)) (do-test test-multiple-value-setq2 (and (eq (multiple-value-setq (n0) (values 'x 'y 'z)) 'x) (equal (list n0) '(x)) (eq (multiple-value-setq (n0 n1) (values 'x 'y 'z)) 'x) (equal (list n0 n1) '(x y)) (eq (multiple-value-setq (n0 n1 n2) (values 'x 'y 'z)) 'x) (equal (list n0 n1 n2) '(x y z)))) ;; ;; ;; ;; (do-test test-mixed0 (equal (multiple-value-call #'values (multiple-value-bind (a b c) (multiple-value-prog1 (values-list '(1 2 3))) (multiple-value-setq (x y z) (values a b c)) (multiple-value-list (values x y z)))) '(1 2 3))) (do-test "test case from masinter.pa" (PROGN (DEFUN 3MVS () (VALUES 1 2 3)) (AND (EQUAL (MULTIPLE-VALUE-LIST (3MVS)) '(1 2 3)) (EQUAL (MULTIPLE-VALUE-BIND (A B C) (3MVS) (LIST C B A)) '(3 2 1)))) ) ;; ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST b/internal/test/LANGUAGE/AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST new file mode 100644 index 00000000..ad9bed2a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: macro-function and defmacro ;; ;; Source: Steele's book Section 8.1: Macro definition Page: 144,145 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 12 '86 ;; ;; Last Update: May 19, 1986/ Masinter, fix (optional0) test, ;; comment out some tests that now (correctly) ;; signal errors ;; May 21, 1986/ Sye, add test cases test-redefine0, test-redefine1, ;; test-redefine2, and test-macros4 ;; June 2, 1986/ Masinter, put &allow-other-keys in tests that have ;; extraneous keywords, add more ;; descriptive name to (currently failing) test ;; Dec. 4, 1986/ Sye ;; add test cases for MACRO-FUNCTION ;; comment out nlsetq statements ;; ;; Filed As: {eris}cml>test>8-1-macro-function-and-defmacro.test ;; ;; ;; Syntax: MACRO-FUNCTION symbol ;; ;; Function Description: MACRO-FUNCTION determines if the argument has a macro ;; definition ;; ;; Argument(s): symbol - a lisp symbol object ;; env - optional lexical environment in which to look for ;; definitions ;; ;; Returns: the expansion function - ;; nil - ;; ;; ;; ;; ;; Syntax: DEFMACRO name lambda-list {declaratioh | doc-string}* {form}* ;; ;; Function Description: DEFMACRO globally defines "name" as a macro with the ;; arguments "lambda-list" and the definition form "form". ;; ;; Argument(s): name - the symbol whose macro definition is being created ;; ;; lambda-list - a list that defines how the argument list ;; passed to the macro "name" is interpreted. ;; It may contain the ;; lambda-list "&-keywords", support the imbedded ;; lambda-list, and allow the dotted-list format ;; ;; declaration | doc-string - ;; ;; form - an entity which constitutes the body ;; of the expander function ;; ;; Returns: name - same as the argument "name" ;; ;; ;; (do-test "test macro-function - if a macro has a macro global definition, then MACRO-FUNCTION returns the expansion function." (progn (defmacro mac () '(* 7 9)) (and (functionp (macro-function 'mac)) (equal (funcall (macro-function 'mac) '(mac) nil) '(* 7 9)) (equal (first (multiple-value-list (macroexpand '(mac)) )) '(* 7 9)) ) ) ) (do-test "test macro-function - if a macro does not have a macro global definition, then MACRO-FUNCTION returns nil" (and ;; special forms ;; (notany #'macro-function '(let progv throw catch go)) ;; ;; ordinaly functions ;; (prog2 (defun fun () 99) (flet ((locfun () 'locfun)) (notany #'macro-function '(fun locfun)))) ;; ;; local macros ;; (macrolet ((locmac1 () '(list 23)) (locmac2 (x y) `(cons ,x ,y))) (notany #'macro-function '(locmac1 locmac2))) ) ) (do-test "test macro-function - use setf and MACRO-FUNCTION to erase previous macro's definition" (let (buf) (defmacro mac (x y z) `(list 'glob ,y ,z ,x)) (macrolet ( (mac (m n o) `(list 'loc ,o ,n ,m) )) (push (mac 11 22 33) buf) (setf (macro-function 'mac) #'(lambda (x y) (list 'cons (fourth x) (second x)))) (push (mac 1 2 3) buf)) (push (mac 111 222 333) buf) (and (equal buf '( (333 . 111) (loc 3 2 1) (loc 33 22 11) )) (equal (funcall (macro-function 'mac) '(mac 8 9 10) nil) '(cons 10 8)) ) ) ) (do-test "test macro-function - use setf and MACRO-FUNCTION to erase previous function's definition" (let (buf) (fmakunbound 'fun) (defun fun (x y) (+ x y)) (push (fun 2 5) buf) (setf (macro-function 'fun) #'(lambda (x y) (apply (second x) (nthcdr 2 x)))) (push (fun - 10 2 6) buf) (push (fun * 6 3 -1) buf) (fmakunbound 'fun) (equal buf '(-18 2 7)) ) ) (do-test test-macros1 ;; ;; ** test defmacro, be sure it returns the name of the symbol ;; (and (string-equal (string (defmacro my-first (list) `(car ,list))) "my-first") ;; ;; ** check if the defined expansion function has two arguments ;; ; (= 0 (argtype (macro-function 'my-first))) ; (= 2 (nargs (macro-function 'my-first))) ;; ;; ** try some macro calls ;; (equal (my-first '(1 2 3)) 1) (equal (my-first '((a b c) d e f)) '(a b c)))) (do-test test-macros2 (and (string-equal (string (defmacro my-rest (list) `(cdr ,list))) "my-rest") ;(= 0 (argtype (macro-function 'my-rest))) ;(= 2 (nargs (macro-function 'my-rest))) (equal (my-rest '(1 2 3)) '(2 3)) (equal (my-rest '((a b c) d e f)) '(d e f)))) (do-test test-macros3 (and (string-equal (string (defmacro my-cons (object list) `(cons ,object ,list))) "my-cons") ;(= 0 (argtype (macro-function 'my-cons))) ;(= 2 (nargs (macro-function 'my-cons))) (equal (my-cons 99 '(1 2 3)) '(99 1 2 3)) (equal (my-cons "string" '((a b c) d e f)) '("string" (a b c) d e f)))) (do-test test-macros4 ;; ;; test for a zero-form macro ;; (and (string-equal (string (defmacro empty-macro ())) "empty-macro") ;(= 0 (argtype (macro-function 'empty-macro))) ;(= 2 (nargs (macro-function 'empty-macro))) (eq nil (empty-macro)))) ;; ;; test &rest keyword in the lambda-list ;; (do-test test-rest-keyword0 (and (string-equal (string (defmacro my-when (test &rest form) `(cond (,test ,@form)))) "my-when") ;(= 0 (argtype (macro-function 'my-when))) ;(= 2 (nargs (macro-function 'my-when))) (equal (my-when (zerop 0) (list 'test 'is 'successful)) '(test is successful)) (equal (my-when (oddp 8) (list "error!")) nil))) (do-test test-rest-keyword1 (and (string-equal (string (defmacro rest1 (&rest form) `',form)) "rest1") ;(= 0 (argtype (macro-function 'rest1))) ;(= 2 (nargs (macro-function 'rest1))) (equal (rest1 2 4 6 8 10) '(2 4 6 8 10)) (equal (rest1) nil) (equal (rest1 a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0) '(a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0)) (equal (rest1 "arg1" arg2 (arg3 (arg4 arg5))) '("arg1" arg2 (arg3 (arg4 arg5)))))) ;; ;; test &body keyword in the lambda-list (it should work like &rest keyword) ;; (do-test test-body-keyword0 (and (string-equal (string (defmacro my-when (test &body form) `(cond (,test ,@form)))) "my-when") ;(= 0 (argtype (macro-function 'my-when))) ;(= 2 (nargs (macro-function 'my-when))) (equal (my-when (zerop 0) (list 'test 'is 'successful)) '(test is successful)) (equal (my-when (oddp 8) (list "error!")) nil))) (do-test test-body-keyword1 (and (string-equal (string (defmacro rest1 (&body form) `',form)) "rest1") ;(= 0 (argtype (macro-function 'rest1))) ;(= 2 (nargs (macro-function 'rest1))) (equal (rest1 2 4 6 8 10) '(2 4 6 8 10)) (equal (rest1) nil) (equal (rest1 a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0) '(a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0)) (equal (rest1 "arg1" arg2 (arg3 (arg4 arg5))) '("arg1" arg2 (arg3 (arg4 arg5)))))) ;; ;; test &optional keyword in the lambda-list ;; (do-test test-optional-keyword0 (and (string-equal (string (defmacro optional0 (&optional n0 n1) `(list ,n0 ,n1))) "optional0") ;(= 0 (argtype (macro-function 'optional0))) ;(= 2 (nargs (macro-function 'optional0))) (equal (optional0 100 200) '(100 200)) (equal (optional0 9) '(9 nil)) (equal (optional0 9 8) '(9 8)) ; used to be (optional0 9 8 7) (equal (optional0) '(nil nil)))) (do-test "missing optional signals error" (and (string-equal (string (defmacro optional1 (n1 n2 n3 &optional (n4 9) n5 (n6 99 n6-flag)) `(list ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n6-flag))) "optional1") ;(= 0 (argtype (macro-function 'optional1))) ;(= 2 (nargs (macro-function 'optional1))) ;; ;; if all three required args are not supplied, be sure an error signal occurs ;; ;;(eq nil (nlsetq (optional1))) ;;(eq nil (nlsetq (optional1 2))) ;;(eq nil (nlsetq (optional1 2 4))) ;; ;; more testing follows ;; (equal (optional1 100 200 300) '(100 200 300 9 nil 99 nil)) (equal (optional1 2 4 6 8 10 12) '(2 4 6 8 10 12 t)) (equal (optional1 'a 'b 'c 'd 'e) '(a b c d e 99 nil)))) ;; ;; test &key keyword in the lambda-list ;; (do-test test-key-keyword0 (and (string-equal (string (defmacro key0 (&key n0 n1) `(list ,n0 ,n1))) "key0") ;(= 0 (argtype (macro-function 'key0))) ;(= 2 (nargs (macro-function 'key0))) (equal (key0) '(nil nil)) ;;; (equal (key0 1 2) '(nil nil)) This now signals an error (equal (key0 :n1 80) '(nil 80)) ;;; (equal (key0 :n0 900 0 1 2) '(900 nil)) This now signals an error (equal (key0 :n0 20 :n1 1000) '(20 1000)))) ;; (do-test test-key-keyword1 (and (string-equal (string (defmacro key1 (n0 n1 &key n2 (n3 (+ 9 90 900)) (n4 (quote (cons 2 4)) n4-flag) n5 &allow-other-keys) `(list ,n0 ,n1 ,n2 ,n3 ,n4 ,n4-flag ,n5))) "key1") ;(= 0 (argtype (macro-function 'key1))) ;(= 2 (nargs (macro-function 'key1))) (equal (key1 () ()) '(nil nil nil 999 (2 . 4) nil nil)) (equal (key1 1 2 :n3 3 :n5 8) '(1 2 nil 3 (2 . 4) nil 8)) (equal (key1 10 20 :n2 :n3 :n4 :n5) '(10 20 :n3 999 :n5 t nil)) (equal (key1 'a 'b :n5 500 :n4 400 :n2 200 :n3 300) '(a b 200 300 400 t 500)) ;; ;; -- it is an error for the first member of any keyword-argument pair to be anything but a keyword-- ;; (page 62 of CLtL) ;; ;; "is an error" isn't the same as "signals an error" ;; (eq nil (nlsetq (key1 10 20 30 :n2 22 :n3 33 :n4 44 :n5 55 nil))) )) ;; ;; ;; test &allow-other-keys keyword in the lambda-list ;; (do-test test-allow-otherkey0 ;; ;; by specifying &allow-other-keys in the lambda-list, unmatched keywords are allowed ;; (and (string-equal (string (defmacro otherkey0 (&key n0 n1 &allow-other-keys) `'(,n0 ,n1))) "otherkey0") ;(= 0 (argtype (macro-function 'otherkey0))) ;(= 2 (nargs (macro-function 'otherkey0))) (equal (otherkey0 :n0 20 :n1 1000) '(20 1000)) (equal (otherkey0 :n0 20 :n3 6 :n8 900) '(20 nil)) (equal (otherkey0 :n10 20 :n3 6 :n8 900) '(nil nil)))) (do-test test-allow-otherkey1 ;; ;; &allow-other-keys is not specified in the lambda-list ; unmatched keywords are not allowed ;; (and (string-equal (string (defmacro otherkey1 (&key n0 n1) `'(,n0 ,n1))) "otherkey1") )) ;(= 0 (argtype (macro-function 'otherkey1))) ;(= 2 (nargs (macro-function 'otherkey1))) ;(eq (nlsetq (otherkey1 :n0 20 :n3 6 :n8 900)) nil) ;(eq (nlsetq (otherkey1 :n10 20 :n3 6 :n8 900)) nil))) (do-test test-allow-otherkey2 (and (string-equal (string (defmacro otherkey2 (&key n0 n1) `'(,n0 ,n1))) "otherkey2") ;(= 0 (argtype (macro-function 'otherkey2))) ;(= 2 (nargs (macro-function 'otherkey2))) ;; ;; ** by setting :allow-other-keys to non-nil, unmatched keywords are allowed ** ;; (equal (otherkey2 :n0 20 :n1 1000 :n2 44 :allow-other-keys t) '(20 1000)) (equal (otherkey2 :n50 20 :n100 1000 :n28 44 :allow-other-keys 'non-nil) '(nil nil)) )) ;; ;; ** by setting :allow-other-keys to nil, unmatched keywords are not allowed ** ;; ;; (eq (nlsetq (otherkey2 :n0 20 :n1 1000 :n2 44 :allow-other-keys nil)) nil) ;; (eq (nlsetq (otherkey2 :n50 20 :n100 1000 :n28 44 :allow-other-keys nil)) nil) ;; ;; test &whole keyword in the lambda-list ;; (do-test test-whole-keyword0 (and (string-equal (string (defmacro whole0 (&whole n0 a1 a2 a3 a4 a5) `'(,n0 ,a1 ,a3 ,a5))) "whole0") ;(= 0 (argtype (macro-function 'whole0))) ;(= 2 (nargs (macro-function 'whole0))) (equal (whole0 1 2 3 4 5) '((whole0 1 2 3 4 5) 1 3 5)) (equal (whole0 a b c d e) '((whole0 a b c d e) a c e)))) ;; ;; test &aux keyword in the lambda-list ;; (do-test test-aux-keyword0 (and (string-equal (string (defmacro aux0 (&aux a (b 20) (c (* 10 9)) (d (- 100 10)) e) `(list ,a ,b ,c ,d ,e))) "aux0") ;(= 0 (argtype (macro-function 'aux0))) ;(= 2 (nargs (macro-function 'aux0))) (equal (aux0) '(nil 20 90 90 nil)))) ;; ;; test {declaration | doc-string}* in defmacro ;; (do-test test-dec-doc0 (and (string-equal (string (defmacro dec-doc0 (n0 n1 n2) (declare (number n0 n1 n2)) "This is a simple macro which returns the sum of three arguments" `(+ ,n0 ,n1 ,n2))) "dec-doc0") ;(= 0 (argtype (macro-function 'dec-doc0))) ;(= 2 (nargs (macro-function 'dec-doc0))) (= (dec-doc0 11 22 33) 66) (/= (dec-doc0 -1 1 -1) 1))) (do-test test-dec-doc1 (and (string-equal (string (defmacro dec-doc1 (n0 n1 n2) "This macro returns a list of 3 character codes for the 3 input characters" (declare (character n0)) "n0 is 1st arg" (declare (character n1)) "n1 is 2nd arg" (declare (character n2)) "n2 is 3rd arg" `(list (char-code ,n0) (char-code ,n1) (char-code ,n2)))) "dec-doc1") ;(= 0 (argtype (macro-function 'dec-doc1))) ;(= 2 (nargs (macro-function 'dec-doc1))) (equal (dec-doc1 #\a #\b #\c) '(97 98 99)) (equal (dec-doc1 #\1 #\2 #\3) '(49 50 51)))) ;; ;; test imbedded lambda-list in defmacro ;; ;; (do-test test-imbedded0 (and (defmacro imbedded0 ((mouth eye1 eye2) ((fin1 length1) (fin2 length2)) tail) "This test case was copied from Steele's book p149" `'(,mouth ,eye1 ,eye2 ,fin1 ,length1 ,fin2 ,length2 ,tail)) ;; ;; the following "equal" should return t ;; (equal (imbedded0 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) my-favorite-tail) '(m (car eyes) (cdr eyes) f1 (count-scales f1) f2 (count-scales f2) my-favorite-tail)) )) ;; ;; now try make some mistakes in the following macro call forms, I'll expect error signals to occur ;; ;; (eq (nlsetq (imbedded0 (m (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) ;; my-favorite-tail)) nil) ;;(eq (nlsetq (imbedded0 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) ;; )) nil) ;;(eq (nlsetq (imbedded0 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) ( (count-scales f2))) ;; my-favorite-tail)) nil))) (do-test test-imbedded1 (and (defmacro imbedded1 ((&whole head mouth eye1 eye2) ((fin1 length1) (fin2 length2)) tail) " ** This test case was copied from Steele's book p150 **" " ** &whole keyword was included in the imbedded lambda list **" `',head) ;; ;; check contents of "head". It should be a list whose components are called "mouth" "eye1" and "eye2" ;; (equal (imbedded1 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) my-favorite-tail) '(m (car eyes) (cdr eyes))))) ;; ;; test lambda-list dotted form ;; (do-test test-dotform0 (and (defmacro dotform0 (n0 . n1) " ** test for top-level lambda-list ** " `'(,n0 ,n1)) (equal (dotform0 1 2 3 4) '(1 (2 3 4))) (equal (dotform0 100) '(100 ())) (equal (dotform0 (a b c) 8) '((a b c) (8))))) (do-test test-dotform1 (and (defmacro dotform1 ((n0 n1 . n2) n3) " ** test for imbedded -level lambda-list ** " `'(,n0 ,n1 ,n2 ,n3)) (equal (dotform1 (1 2 3 4 5) 6) '(1 2 (3 4 5) 6)) (equal (dotform1 (a b "string1" "string2" 3 4) (x y z)) '(a b ("string1" "string2" 3 4) (x y z))))) (do-test test-dotform2 (and (defmacro dotform2 ((n0 n1 . n2) n3 . n4) `'(,n0 ,n1 ,n2 ,n3 ,n4)) (equal (dotform2 (1 2 3 4 5) 6 7 8 9 10) '(1 2 (3 4 5) 6 (7 8 9 10))) (equal (dotform2 (a b "string1" "string2" 3 4) w (x y z)) '(a b ("string1" "string2" 3 4) w ((x y z)))))) ;; ;; ;; more testing on defmacro ;; (with lambda-lists contain & keywords, imbedded lambda lists, and/or dotted forms) ;; (do-test test-arithmetic-if (and (defmacro arithmetic-if (test neg-form zero-form pos-form) "** This test case was copied from p147 of CLtl **" (let ((var (gensym))) `(let ((,var ,test)) (cond ((< ,var 0) ,neg-form) ((= ,var 0) ,zero-form) (t ,pos-form))))) (equal (arithmetic-if (+ 10 100) 'neg 'zero 'pos) 'pos) (equal (let ((x 3)) (arithmetic-if (- x 4.0) (- x) 'zero x)) -3) (equal (let ((x 4)) (arithmetic-if (- x 4.0) (- x) 'zero x)) 'zero) (equal (let ((x 5)) (arithmetic-if (- x 4.0) (- x) 'zero x)) 5))) ;; (do-test test-lamb0 ;; (and (defmacro lamb0 (x &optional (a b &rest c) &rest z) ;; "** This test case was copied from p150 of CLtl **" ;; `(,x ,a ,c ,z)) ;; (eq nil (nlsetq (lamb0 4))) ;; (eq nil (nlsetq (lamb0 4 ( 1 3 5) 7))))) (do-test test-lamb1 (and (defmacro lamb1 (x &optional ((a b &rest c)) &rest z) "** This test case was copied from p150 of CLtl **" `'(,x ,a ,b ,c ,z)) (equal (lamb1 1 (2 3 4 5) 6 7 8) '(1 2 3 (4 5) (6 7 8))) )) ;; (eq nil (nlsetq (lamb1 (car pool)))) ;; (eq nil (nlsetq (lamb1 (car pool) (10)))))) (do-test test-lamb2 (and (defmacro lamb2 (x &optional ((a b &rest c) '(nil nil)) &rest z) "** This test case was copied from p151 of CLtl **" `'(,x ,a ,b ,c ,z)) (equal (lamb2 1 (2 3 4 5) 6 7 8) '(1 2 3 (4 5) (6 7 8))) (equal (lamb2 (car pool)) '((car pool) nil nil nil nil)) (equal (lamb2 (car pool) (88 99) 100 200) '((car pool) 88 99 nil (100 200))) )) ;; ;; if the macro call specifies a explicitly then it must also specify b explicitly ;; ;; (eq nil (nlsetq (lamb2 (car pool) (10)))))) (do-test test-lamb3 (and (defmacro lamb3 (x &optional ((&optional a b &rest c)) &rest z) "** This test case was copied from p151 of CLtl **" `'(,x ,a ,b ,c ,z)) (equal (lamb3 1 (2 3 4 5) 6 7 8) '(1 2 3 (4 5) (6 7 8))) (equal (lamb3 (car pool)) '((car pool) nil nil nil nil)) (equal (lamb3 (car pool) (88 99) 100 200) '((car pool) 88 99 nil (100 200))) ;; ;; if the macro call specifies a explicitly, it doesn't have to specify b explicitly ;; (equal (lamb3 (car pool) (10) 100 200) '((car pool) 10 nil nil (100 200))) (equal (lamb3 (car pool) ((+ x 1))) '((car pool) (+ x 1) nil nil nil)))) ;; ;; ;; - It is permissible to use defmacro to redefine a macro, or to redefine a function as a macro - ;; - It is an error to attempt to redefine the name of a special form - ;; [from 8.1. Macro Definition (p 146) of CLtL] ;; (do-test test-redefine0 (and (defmacro redefine0 () ''fine) (equal (redefine0) 'fine) (defmacro redefine0 () ''fine-fine) (equal (redefine0) 'fine-fine))) (do-test test-redefine1 (and (defun redefine1 () 'fine) (equal (redefine1) 'fine) (defmacro redefine1 () ''fine-fine) (equal (redefine1) 'fine-fine))) ;;(do-test test-redefine2 ;; (and (eq nil (nlsetq (defmacro progn () ''new-macro))) ;; (eq nil (nlsetq (defmacro function () ''new-macro))) ;; (eq nil (nlsetq (defmacro labels () ''new-macro))))) ;; ;; (do-test "defmacro and defun" (equal '(fun macro macro fun) (list (PROGN (defun xx () 'fun) (XX)) (PROGN (defmacro xx () ''macro) (xx) ) (PROGN (defmacro xxx () ''macro) (xxx)) (PROGN (defun xxx () 'fun) (xxx))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.DFASL b/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2eb5cc9e7f704cf9cc482f0d0283c2d7898f6692 GIT binary patch literal 1118 zcmah|-%ry}6u#{kFb1;_kOUMOh|yGw83H1jn9|+BpzDR(JAr6I$QW$NV9Pd42$2vT z^rZ#|k+d3Kd@wQb!QhLCfd^mxWB3p7+=4(b#x_mQ&+pvxopZ~`KdBqCo?FOgvZ;cc zTPo$3O7dK;AQy8>g=9*e1G~JU6N+C9Yx-!{!*Gpt!ILbcW=g49nJuM?vop(gN;?HlOn8MxQmRTI@L;{@%$Irj&8`vulI{F;g9b*0dpv#OhNNjxIQMs9z0(lUi6EB#|k!vt79k=lI4C^F6&kBJ3@q zuRlh_iH4SX!OyM#`qC{YPrA-)WALx-j~Egcd`6nNIrZYK$O(y!g-tVkpQ+C6r% zJ`&=>TAIK6^9VJpSA~T1-hm17QF-*W`4gdX`lUG{3IM*D{?atj$N|A!jZiH@hneKn za$3qrNc1~z?Q4oo%t(xrpbl$h#K2S?jDf`*vJ|lb*sWJ|jp@TG#VkRA9o?h1(wedu zj*G(I5sWBq&=+t6zB*tuq+m)3RY`)4C79w1LPD*gnNzA~w-gtsmBN=M6!0PBR`9V@ zagIL&P-T?RxW>5pi5Jxqlw$M3*j<79T<|rX_oQnuF0Yas%ySe2n?r1P-feme-B&$} zKQUq!djv^!=cDEOQ$L9*nN)QWj{`LjG*-dkKSJb{^GKEN#@V`Yg$HdwA-`9YYp-C_ zDouWPW5sO?a?=OLZfB`tN$yzHI^?+-xL31sX7S`oaNFvQr_PoLwE}$ARNlJVDvUdJ zO(d68i={$labE5W--RGo7H`9H4(4W;1&*h@cml>test>8-2-macroexpand-and-macroexpand-1.test ;; ;; ;; Syntax: MACROEXPAND-1 form &optional env ;; MACROEXPAND form &optional env ;; ;; Function Description: MACROEXPAND-1 will expand the form (macro call) once and return two values ;; MACROEXPAND will repeatedly expand the form until it is no longer a macro call. ;; It also returns two values. ;; ;; Argument(s): form - a lisp form ;; env - an environment ;; ;; Returns: the expansion function and t - if the argument "form" is a macro call ;; form and nil - if the argument "form" is not a macro call ;; ;; ;; tests for *macroexpand-hook* variable ;; ;;This test commented out by Pavel because we do macro-caching by default in the system and thus don't use 'funcall as the default hook. ;;(do-test test-hook ;; ;; ;; ;; make sure its initial value is 'funcall' ;; ;; ;; (and (boundp '*macroexpand-hook*) ;; (eq *macroexpand-hook* 'funcall))) ;; ;; tests for "macroexpand-1" with null environment ;; (do-test test-macroexpand-10 (and (defmacro expand-10 () `(a b c)) (equal (multiple-value-list (macroexpand-1 '(expand-10))) '((a b c) t)))) (do-test test-macroexpand-11 (and (defmacro expand-11 (n0 n1 n2 n3 n4 n5) `(/= ,n0 ,n1 ,n2 ,n3 ,n4 ,n5)) (equal (multiple-value-list (macroexpand-1 '(expand-11 10 10.1 20.2 30 33 50))) '((/= 10 10.1 20.2 30 33 50) t)) (equal (multiple-value-list (macroexpand-1 '(expand-11 0 0.0 -1 1 (- 0 2) (+ 3 9)))) '((/= 0 0.0 -1 1 (- 0 2) (+ 3 9)) t)))) (do-test test-macroexpand-12 (and (defmacro expand-12 (n0 n1 n2) `(progn (defun () (list ,n0 ,n1 ,n2)))) (equal (multiple-value-list (macroexpand-1 '(expand-12 'good 'better 'best))) '((progn (defun () (list 'good 'better 'best))) t)) (equal (multiple-value-list (macroexpand-1 '(expand-12 (cons 1 2) (= 1 1.0) (evenp 4)))) '((progn (defun () (list (cons 1 2) (= 1 1.0) (evenp 4)))) t)))) (do-test test-macroexpand-13 ;; ;; tests for non-macro forms ;; (and (equal (multiple-value-list (macroexpand-1 '(no-such-macro 1 2 3))) '((no-such-macro 1 2 3) nil)) (equal (multiple-value-list (macroexpand-1 '(again-no-such-macro))) '((again-no-such-macro) nil)))) ;; ;; ;; ;; tests for "macroexpand" with null environment ;; ;; ;; (do-test test-macroexpand0 (and (defmacro expand0a () ''macro-no-fun) (defmacro expand0b () `(expand0a)) (defmacro expand0c () `(expand0b)) (equal (multiple-value-list (macroexpand '(expand0c))) '('macro-no-fun t)))) (do-test test-macroexpand1 (and (defmacro expand1a (a0 a1 a2) `(list ,a0 ,a1 ,a2)) (defmacro expand1b (b0 b1) `(expand1a (progn (defun fun1 () (+ ,b0 ,b1)) (fun1)) (progn (defun fun2 () (- ,b0 ,b1)) (fun2)) (progn (defun fun3 () (/ ,b1 ,b0)) (fun3)))) (defmacro expand1c () `(expand1b 10 20)) (equal (multiple-value-list (macroexpand '(expand1c))) '((list (progn (defun fun1 () (+ 10 20)) (fun1)) (progn (defun fun2 () (- 10 20)) (fun2)) (progn (defun fun3 () (/ 20 10)) (fun3))) t)))) (do-test test-macroexpand2 (and (defmacro expand2a (n0) `',n0) (defmacro expand2b (n0 n1) (let ((var (cons n1 n0))) `(expand2a ,var))) (defmacro expand2c (n0 n1) (let ((var (cons n1 n0))) `(expand2b ,var "d"))) (defmacro expand2d (n0 n1) (let ((var (cons n1 n0))) `(expand2c ,var "c"))) (defmacro expand2e (n0 n1) (let ((var (cons n1 n0))) `(expand2d ,var "b"))) (defmacro expand2f () (let ((var (list "-" ))) `(expand2e ,var "a"))) (equal (multiple-value-list (macroexpand `(expand2f))) '('("d" "c" "b" "a" "-") t)) (equal (multiple-value-list (macroexpand-1 `(expand2f))) '((expand2e ("-") "a") t)))) (do-test test-macroexpand3 ;; ;; tests for non-macro forms ;; (and (equal (multiple-value-list (macroexpand '(no-such-macro 1 2 3))) '((no-such-macro 1 2 3) nil)) (equal (multiple-value-list (macroexpand '(again-no-such-macro))) '((again-no-such-macro) nil)))) ;; ;; ;; tests for macroexpand/macroexpand-1 with &environment argument ;; ;; (do-test test-env0 (and (defmacro foo () ''global-foo) (defmacro env0 (&environment env) (macrolet ((foo () ''local-foo))) (macroexpand-1 '(foo))) (eq (env0) 'global-foo))) (do-test test-env1 (progn (defmacro test-env1-foo () ''global-foo) (defmacro env1 (&environment env) (macroexpand-1 '(test-env1-foo) env)) (macrolet ((test-env1-foo () ''local-foo)) (eq (env1) 'local-foo)))) ;; ;; ;; tests for AR # 5532 regarding "&body and &rest args don't get destructured" ;; ;; (do-test test-5532ar0 (and (defmacro 5532ar0 (&rest (foo bar)) `'(,foo %% ,bar)) ;; (equal (multiple-value-list (macroexpand '(5532ar0 1 2))) '('(1 %% 2) t)) (equal (5532ar0 1 2) '(1 %% 2)) )) (do-test test-5532ar1 (and (defmacro 5532ar1 (&body ((foo (bar (bar1 &optional (bar2 88)))))) `'(,foo %% ,bar %% ,bar1 %% ,bar2)) ;; (equal (multiple-value-list (macroexpand '(5532ar1 1 (2 (3 4))))) '('(1 %% 2 %% 3 %% 4) t)) (equal (5532ar1 1 (2 (3 4))) '(1 %% 2 %% 3 %% 4)) (equal (multiple-value-list (macroexpand '(5532ar1 1 (2 (3))))) '('(1 %% 2 %% 3 %% 88) t)) (equal (5532ar1 1 (2 (3))) '(1 %% 2 %% 3 %% 88)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST b/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST new file mode 100644 index 00000000..a6d244af --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST @@ -0,0 +1 @@ +;; ;; Created By: Karin M. Sye ;; ;; Creation Date: 21, Dec., 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test> 8-macro-arg-eval-order.test ;; (do-test "test order of evaluation of arguments to system provided macros" (let (counter macro-name) (macrolet ((foo (counter-value foo-value) "define the test parameter production" `(progn (unless (= ,counter-value (incf counter)) (print (concatenate 'string "arguments to macro '" macro-name "' evaluated out of order") *error-output*)) ,foo-value)) (test (name) "reset the variables COUNTER and MACRONAME" `(setq counter 0 macro-name ,name)) ) ;; ;; now let's do the tests ;; ;; AND ;; (test "and") (and (foo 1 1) (foo 2 (values 6 60 600)) (foo 3 (values nil t)) (foo 99 #\a)) (and (foo 4 'a) (foo 5 'b) (foo 6 'c) (foo 7 'd)) ;; ;; CASE ;; (test "case") (case 'bar ( bar1 (foo 99 'bar1)) ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju)) ( bar4 (foo 99 'bar4)) ( otherwise (foo 99 'other))) ; (case 'quack ((3 quack3) (foo 99 '3)) (('quack) (foo 99 '0)) (t (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit))) ; (case nil ( non-nil (foo 99 'non-nil)) ( nill (foo 99 'nill))) ; (case t ( t (foo 9 t))) ;; ;; CCASE ;; (test "ccase") (let ( (bar '(bar bar2 t)) ) (ccase (pop bar) ( bar1 (foo 99 'bar1)) ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju)) ( bar4 (foo 99 'bar4))) ; (ccase (pop bar) (bar2 (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit))) ; (ccase (pop bar) ((t) (foo 9 t)))) ;; ;; CHECK-TYPE ;; (test "check-type") (let ((var '(12 #\w "str" (1 2 3)) )) (check-type (caddr (foo 1 var)) string (foo 2 (concatenate 'string "a " "string")) )) ;; ;; COND ;; (test "cond") (cond ((foo 1 (oddp 20)) (foo 99 (1+ 20))) ((foo 2 (evenp 3)) (foo 99 (1- 3))) ((foo 3 (= (sqrt #18r10000) #18r100)) (foo 4 'gochu)) ((foo 99 t) 180)) ;; (cond ((foo 5 nil) (foo 99 10)) ((foo 6 nil) (foo 99 20)) ((foo 7 t) (foo 8 30) (foo 9 40) (foo 10 (values 30 40 50))) ((foo 99 t) "buggy")) ;; ;; CTYPECASE ;; (test "ctypecase") (let ((var '(100 #\q t) )) (ctypecase (foo 1 (pop var)) ((or float string) (foo 99 'fool1)) ((integer 105 200) (foo 99 'fool2)) ( fixnum (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy)) ( package (foo 99 'fool3))) ; (ctypecase (foo 6 (pop var)) ((or vector stream) (foo 99 'fool4)) ((or string character) (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9))) ( ratio (foo 99 'fool5))) ; (ctypecase (foo 10 (pop var)) (atom (foo 11 'hwow!)))) ;; ;; DECF ;; (test "decf") (let ((a 0)) (declare (special a)) (decf (symbol-value (foo 1 'a)) (foo 2 -5)) (decf (symbol-value (foo 3 'a)) (foo 4 50))) ;; ;; DEFCONSTANT ;; (test "defconstant") (defconstant mac-arg-3 (foo 1 246)) (defconstant mac-arg-4 (foo 2 135) (foo 3 "a constant")) ;; ;; DEFINE-MODIFY-MACRO name lambda-list function [doc-string] ;; ;; ** Test case was not generated since none of the arguments need to be evaluated ** ;; ;; DEFMACRO ;; (test "defmacro") (defmacro mac ( x y) (foo 1 (declare (integer x y))) (foo 2 "a dummy macro") (foo 3 'nonsense1) (foo 4 'nonsense2) (foo 5 `(progn (values (+ ,x ,y) (- ,x ,y) (* ,x ,y))))) (fmakunbound 'mac) ;; ;; DEFPARAMETER ;; (test "defparameter") (defparameter mac-arg-2 (foo 1 100)) (defparameter mac-arg-2 (foo 2 300) (foo 3 "a global var")) ;; ;; DEFSTRUCT ;; (test "defstruct") (let () (defstruct new-blocks (length (foo 1 10) :type fixnum) (wide (foo 2 5 ) :type fixnum) (height (foo 3 20) :type fixnum) (volume (foo 4 (* 5 10 20)) :type fixnum) (number-of-block (foo 5 8) :type fixnum :read-only t) (total-volume (foo 6 (* 5 10 20 8)) :type fixnum) ) (make-new-blocks)) ;; ;; DEFTYPE ;; (test "deftype") (deftype square-matrix (&optional type size) "SQUARE-MATRIX includes all aquare two-dimentional arrays." (foo 1 (setq a1 'array)) (foo 2 (setq a2 `,type)) (foo 3 (setq a3 `(,size ,size))) (foo 4 (list a1 a2 a3) )) ;; ;; DEFUN ;; (test "defun") (defun fun (x y buf) (foo 1 (declare (integer x y) (list buf))) (foo 2 "a fun function") (foo 3 (push 'form1 buf)) (foo 4 (push 'form2 buf)) (foo 5 (push 'form3 buf)) (foo 6 (if (evenp x) (push 'form4 buf))) (foo 7 (if (oddp y) (return buf))) (foo 8 (return (progn (push 'form8 buf) buf)))) (fmakunbound 'fun) ;; ;; DEFVAR ;; (test "defvar") (every #'makunbound '(mac-arg-1 mac-arg-11)) (defvar mac-arg-1 (foo 3 11)) (defvar mac-arg-11 (foo 2 22) (foo 1 "a special var")) (evenp (+ mac-arg-11 mac-arg-1)) ;; ;; DO ;; (test "do") (do ((z '(1 2 3 4 5) (rest z))) ((foo 1 (null z)) "something is wrong") (foo 2 (and (= (car z) 1) (return 'gochu)))) ; (do ((w 0 (+ w 1)) (buf '(9))) ((foo 3 (zerop w)) (foo 4 (nconc buf (list w (+ 1 w)))) (foo 5 (reverse buf))) (foo 6 "wrong")) ; (do ((m 0 (incf m)) (n 2 (incf n 2)) (o 3 (incf o 3))) ((foo 6 (< 10 (+ m n o))) "sum > 10") (foo 7 (declare (fixnum m))) (foo 8 (declare (fixnum n))) (foo 9 (declare (integer o))) (foo 10 (if (plusp (lcm m n o)) (return "+"))) (foo 11 (if (minusp (gcd m n o)) (return "-"))) (foo 12 (return 'hooray))) ;; ;; DO* ;; (test "do*") (do* ((z '(1 2 3 4 5) (rest z))) ((foo 1 (null z)) "something is wrong") (foo 2 (and (= (car z) 1) (return 'gochu)))) ; (do* ((w 0 (+ w 1)) (buf '(9))) ((foo 3 (zerop w)) (foo 4 (nconc buf (list w (+ 1 w)))) (foo 5 (reverse buf))) (foo 6 "wrong")) ; (do* ((m 0 (incf m)) (n 2 (incf n 2)) (o 3 (incf o 3))) ((foo 6 (< 10 (+ m n o))) "sum > 10") (foo 7 (declare (fixnum m))) (foo 8 (declare (fixnum n))) (foo 9 (declare (integer o))) (foo 10 (if (plusp (lcm m n o)) (return "+"))) (foo 11 (if (minusp (gcd m n o)) (return "-"))) (foo 12 (return 'hooray))) ;; ;; DO-ALL-SYMBOLS ;; (test "do-all-symbols") (progn (do-all-symbols (x) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 (if (find-symbol (string x) (car (list-all-packages))) (return 'first))))) ;; ;; DO-EXTERNAL-SYMBOLS ;; (test "do-external-symbols") (progn (import '(lisp:vector) 'user) (export '(user::vector) 'user) (do-external-symbols (x (find-package 'user)) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 (if (find-symbol (string x) 'user) (return 99))))) ;; ;; DO-SYMBOLS ;; (test "do-symbols") (let ((pac (or (find-package "macro-arg-pac") (make-package "macro-arg-pac" :use NIL) )) result) (progn (set (intern "joke" pac) 789) (do-symbols (x pac (foo 5 result)) (foo 1 (push (numberp x) result)) (foo 2 (push (arrayp x) result)) (foo 3 (push (rationalp x) result)) (foo 4 (push (symbolp x) result)) ))) ;; ;; DOLIST ;; (test "dolist") (dolist (x (foo 1 '()) (foo 2 "bye")) (foo 3 nil)) ; (dolist (x (foo 3 '(#\q)) (foo 5 "end-of-list")) (foo 4 (characterp x))) ; (dolist (x (foo 6 '(2)) (foo 99 'jumpy)) (foo 7 (setq x (sqrt x))) (foo 8 (return x))) ;; ;; DOTIME ;; (test "dotimes") (dotimes (x (foo 1 0) (foo 2 "bye")) (foo 3 nil)) ; (dotimes (x (foo 3 1) (foo 5 "end-of-list")) (foo 4 (characterp x))) ; (dotimes (x (foo 6 1) (foo 99 'jumpy)) (foo 7 (setq x (sqrt x))) (foo 8 (go tag)) done (foo 10 (return x)) tag (foo 9 (go done))) ;; ;; ECASE ;; (test "ecase") (let ( (bar '(bar bar2 t)) ) (ecase (pop bar) ( bar1 (foo 99 'bar1)) ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju)) ( bar4 (foo 99 'bar4))) ; (ecase (pop bar) (bar2 (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit))) ; (ecase (pop bar) ((t) (foo 9 t)))) ;; ;; ETYPECASE ;; (test "etypecase") (etypecase (foo 1 100) ((or float string) (foo 99 'fool1)) ((integer 105 200) (foo 99 'fool2)) ( fixnum (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy)) ( package (foo 99 'fool3))) ; (etypecase (foo 6 #\q) ((or vector stream) (foo 99 'fool4)) ((or string character) (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9))) ( ratio (foo 99 'fool5))) ;; ;; INCF ;; (test "incf") (let ((a 0)) (declare (special a)) (incf (symbol-value (foo 1 'a)) (foo 2 -5)) (incf (symbol-value (foo 3 'a)) (foo 4 50))) ;; ;; LOCALLY ;; (test "locally") (locally (foo 1 (floor 3 8)) (foo 2 (ceiling 3 8)) (foo 3 (truncate 3 8)) (foo 4 (round 3 8))) ; (locally (foo 5 (declare (inline floor round car))) (foo 6 (declare (notinline truncate ceiling cdr))) (foo 7 (declare (optimize space))) (foo 8 (floor 3 8)) (foo 9 (ceiling 3 8)) (foo 10 (truncate 3 8)) (foo 11 (round 3 8))) ;; ;; LOOP ;; (test "loop") (loop (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 8) (foo 9 9) (foo 10 10) (foo 11 (return t))) ;; ;; MULTIPLE-VALUE-BIND ;; (test "multiple-value-bind") (multiple-value-bind (n0 n1 n2) (foo 1 (values-list '(0 1 2))) (foo 2 (setq n1 (+ n0 n2 100))) (foo 3 (setq n2 (* n1 23))) (foo 4 (setq n0 (lcm n1 n2))) (foo 5 (list n0 n1 n2)) ) ;; ;; MULTIPLE-VALUE-LIST ;; (test "multiple-value-list") (multiple-value-list (foo 1 (values 'a 'b 'c 'd 'e 'f 'g))) (multiple-value-list (foo 2 '(1 2 3 4 5 6 7))) ;; ;; MULTIPLE-VALUE-SETQ ;; (test "multiple-value-setq") (multiple-value-setq (n0 n1 n2) (foo 1 (values 10 20 30 40 50))) (multiple-value-setq (n0 n1) (foo 2 (values-list '(11 22)))) ;; ;; OR ;; (test "or") (or (foo 1 (values nil 1 11)) (foo 2 'nil) (foo 3 3) (foo 4 'atom4) (foo 5 55)) (or (or (foo 4 nil) (foo 5 'nil)) (or (foo 6 nil) (foo 7 99)) (foo 8 nil) (foo 9 t)) ;; ;; POP ;; (test "pop") (let ((a '(10 20 30 40 50 (60 77 88)) )) (declare (special a)) (pop (symbol-value (foo 1 'a))) (pop (fifth (foo 2 a))) ) ;; ;; PROG ;; (test "prog") (prog ((a 1) (b 2) (c 3) (d 4)) (foo 1 (setq c (* (+ a d) (- c b)))) (foo 2 (setq d (gcd (expt c 3) (* 99 d)))) (foo 3 (setq a (lcm c d))) (foo 4 (setq b (complex c a))) (foo 5 (return (list a b c d))) ) ;; ;; PROG* ;; (test "prog*") (prog* ((a 10) (b (* a 2)) (c (+ a b))) (foo 1 (declare (fixnum a b c))) (foo 2 "a simple prog* form") (foo 3 (if (evenp (+ a b)) (go tag1))) tag2 (foo 5 (go exit)) tag1 (foo 4 (go tag2)) exit (foo 6 (return (mapcar #'list (list a b c))))) ;; ;; PROG1 ;; (test "prog1") (prog1 (foo 1 "1") (foo 2 "2") (foo 3 "3") (foo 4 "4") (foo 5 "5")) (prog1 (foo 6 "66") (foo 7 "77") (foo 8 "done")) ;; ;; PROG2 ;; (test "prog2") (prog2 (foo 1 'a) (foo 2 (prog2 (foo 3 'c) (foo 4 'd) (foo 5 'e)(foo 6 'f) )) (foo 7 'g)) (prog2 (foo 8 (defun fun () 'fun-fun)) (foo 9 (fun)) (foo 10 (fmakunbound 'fun))) ;; ;; PSETF ;; (test "psetf") (let ((a 22) (b '(1 2 3 4 5)) (c '(11 22 33 44)) (d 44)) (declare (special a d)) (psetf (symbol-value (foo 1 'a)) (foo 2 b) (second (foo 3 b)) (foo 4 a) (rest (foo 5 c)) (foo 6 d) (symbol-value (foo 7 'd)) (foo 8 (incf a d)) )) ;; ;; PSETQ ;; (test "psetq") (let (a b c d) (psetq a (foo 1 'a) b (foo 2 `b) c (foo 3 'c) d (foo 4 'd)) (psetq a (foo 5 b) b (foo 6 a))) ;; ;; PUSH ;; (test "push") (let ((a '(1 2 3 4 5 6 7 8 9 10) )) (push (foo 1 100) (third (foo 2 a))) (push (foo 3 200) (rest (foo 4 a))) ) ;; ;; PUSHNEW ;; (test "pushnew") (let ( (a 0) (aa '( 5 4 3)) ) (pushnew (foo 1 (incf a)) (first (foo 2 (list (list a) a)))) (pushnew (foo 3 (first aa)) (second (foo 4 (setq aa (reverse aa)))) :test (foo 5 #'=) ) ) ;; ;; REMF ;; (test "remf") (let ((a 1)) (setf (symbol-plist 'a) '(color blue height 6.6 near-to bar weight 230)) (remf (symbol-plist (foo 1 'a)) (foo 2 'height)) (remf (symbol-plist (foo 3 'a)) (foo 4 'weight)) ) ;; ;; RETURN ;; (test "return") (do () () (return (foo 1 100))) (prog () (return (foo 2 30))) (dolist (x '(1)) (return (foo 3 x))) (dotimes (x 1) (return (foo 4 x))) ;; ;; ROTATEF ;; (test "rotatef") (let ((a '(a b c d e f g h) )) (rotatef (car (foo 1 a)) (cadr (foo 2 a)) (caddr (foo 3 a)) (cadddr (foo 4 a)) (fifth (foo 5 a)) (sixth (foo 6 a)) (seventh (foo 7 a)) (eighth (foo 8 a))) ) ;; ;; SETF ;; (test "setf") (let ((a '(1 2 3 4 5 6 7 8 9 10)) ) (setf (subseq (foo 1 a) 1 3) (foo 2 '(11 22)) (cadddr (foo 3 a)) (foo 4 44) (ninth (foo 5 a)) (foo 6 99))) ;; ;; SHIFTF ;; (test "shiftf") (let ((a '(a b c d e f) )) (shiftf (car (foo 1 a)) (cadr (foo 2 a)) (caddr (foo 3 a)) (cadddr (foo 4 a)) (fifth (foo 5 a)) (sixth (foo 6 a)) (foo 7 'z)) ) ;; ;; STEP form ;; ;; ** single form doesn't need test cases ** ;; ;; TIME form ;; ;; ** single form doesn't need test cases ** ;; ;; TRACE {function-name}* ;; ;; ** no arguments need to be evaluated ** ;; ;; UNTRACE {function-name}* ;; ;; ** no arguments need to be evaluated ** ;; ;; TYPECASE ;; (test "typecase") (typecase (foo 1 100) ((or float string) (foo 99 'fool1)) ((integer 105 200) (foo 99 'fool2)) ( fixnum (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy)) ( otherwise (foo 99 'fool3))) ; (typecase (foo 6 #\q) ((or vector stream) (foo 99 'fool4)) (otherwise (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9))) (t (foo 99 'fool5))) ;; ;; UNLESS ;; (test "unless") (unless (foo 1 nil) (foo 2 3) (foo 3 4) (foo 4 5) (foo 5 (values 6 66 666))) (unless (foo 6 t) (foo 99 "ouch")) ;; ;; WHEN ;; (test "when") (when (foo 1 nil) (foo 2 "ouch")) (when (foo 2 'star) (foo 3 3) (foo 4 4) (foo 5 5) (foo 6 (values 6 66 666))) ;; ;; WITH-INPUT-FROM-STRING ;; (test "with-input-from-string") (let (a str buf) (with-input-from-string (s1 (foo 1 "abc")) (foo 2 (read s1))) (with-input-from-string (s1 (foo 3 "abcde") :index (symbol-value (foo 11 'a)) :start (foo 4 1) :end (foo 5 4)) (foo 6 (setq str (string (read s1)))) (foo 7 (push (map 'string #'char-upcase str) buf)) (foo 8 (push (map 'list #'char-code str) buf)) (foo 9 (push (map 'vector #'standard-char-p str) buf)) (foo 10 buf))) ;; ;; WITH-OPEN-FILE ;; ;; (more coming) ;; ;; WITH-OPEN-STREAM ;; (test "with-open-stream") (let (buf) (with-open-stream (strim (foo 1 (make-string-input-stream "abcdefg"))) (foo 2 (setq buf (string (read strim)))) (foo 3 (setq buf (concatenate 'string buf " has length of " (prin1-to-string (length buf))))) (foo 4 buf))) ;; ;; WITH-OUTPUT-TO-STRING ;; (test "with-output-to-string") (let ((str (make-array 10 :element-type 'character :fill-pointer 0)) buf) (with-output-to-string (s1 str) (foo 1 (write-char #\a s1)) (foo 2 (write-char #\b s1)) (foo 3 (push str buf)) (foo 4 (write-char #\c s1)) (foo 5 (write-char #\d s1)) (foo 6 (push str buf)) (foo 7 buf))) ) ; end of macrolet ) ; end of let ); end of do-test STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST b/internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST new file mode 100644 index 00000000..5b3b1319 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: declare ;; ;; Source: CLtL p. 153 ;; Chapter 9: Declarations Section 1: Declaration Syntax ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov 3, 1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - removed null :before forms in do-test-groups ;; Feb 5, 1987 Jim Blum - more fixes ;; Filed As: {eris}cml>test> 9-1-declare.test ;; ;; ;; Syntax: declare {decl-spec}* ;; ;; Function Description: The declare construct is used for embedding declarations within executable code. Declarations may occur in ;; lambda-expressions and in the forms listed below. ;; ;; defmacro defsetf deftype defun do* do-all-symbols do-external-symbols do-symbols ;; do dolist dotimes flet labels let let* locally ;; macrolet multiple-value-bind prog prog* ;; ;; ;; ;; Argument(s): decl-spec - anyone of the following declaration specifiers: ;; ;; special, type , ftype , function , inline , notinline , ignore , optimize , declaration ;; ;; Returns: It is an error to evaluate a declaration. Those special forms that permit declaratins to appear perform ;; explicit checks for their presence. ;; ;; ;; (do-test declare-is-not-a-macro (let ((decl (declare (special foo)))) (multiple-value-bind (new-form anything-changed) (macroexpand decl nil) (and (eq decl new-form) (null anything-changed)) ) ) ) (do-test-group ("test declare - with test case from page 155 of CLtL" :before (progn (test-defun fool (x y &optional (z "tail")) (list x y z)) ;; ;; test case copied from page 155 of CLtL ;; (test-defun nonsense (k x z) (fool z x) ;; first call to fool (let ((j (fool k x)) ;; second call to fool (x (* k k))) (declare (inline fool) (special x z)) (fool x j z))) ;; third call to fool )) ;; I now believe that this test is correct with respect to CLtL. ;; If you disagree, please talk to me before changing it. --Pavel (do-test "test declare - with test case from page 155 of CLtL" (and (equal (progv '(x z) '("special x" "special z") (nonsense 33 "loc x" "loc z")) '(1089 (33 "special x" "tail") "special z") ) (equal (progv '(x z k) '(10 20 30) (nonsense 3 1 2)) '(9 (3 10 "tail") 20)) ) ) ) (do-test-group ("test declare - with test case from page 157 of CLtL" :before (progn ;; ;; test case copied from page 157 of CLtL ;; (test-defun hack (thing *mod*) (declare (special *mod*)) (hack1 (car thing))) (test-defun hack1 (arg) (declare (special *mod*)) (if (atom arg) *mod* (cons (hack1 (car arg)) (hack1 (cdr arg))))) )) (do-test "test declare - with test case from page 157 of CLtL" (let ((modvar "mo")) (and (equal (hack '(atom) modvar) "mo") (equal (hack '(((atom0 atom1) atom2) atom3) modvar) '(("mo" "mo" . "mo") "mo" . "mo")) ) ) ) ) (do-test-group ("test declare - with test case from page 158 of CLtL" :before (progn ;; ;; test case copied from page 158 of CLtL ;; (test-defun example (x y) (declare (special y)) (let ((y 3) (x (* x 2))) (list (+ y (locally (declare (special y)) y)) (let ((y (incf y 4))) (declare (special y)) (list (fo y) (fo x))) ))) (test-defun fo (x) x) )) (do-test "test declare - with test case from page 158 of CLtL" (prog2 (proclaim '(special x)) (and (equal (example 15 10) '(13 (14 30))) (equal (example 5 0) '( 3 ( 4 10))) ) ) ) ) (do-test-group ("test declare - with test case from page 160 of CLtL" :before (progn ;; ;; test case copied from page 160 of CLtL ;; (test-defun often-used-subroutine (x y) (declare (optimize (safety 2))) ; (error-check x y) ; (hairy-setup x) (prog (buf) (dotimes (xx y) (setq buf (append buf x))) (setq x buf)) (do ((i 0 (+ i 1)) (z x (cdr z))) ((null z) i) ;; This inner loop really needs to burn. (declare (optimize speed)) (declare (fixnum i)) )) )) (do-test "test declare - with test case from page 160 of CLtL" (and (= (often-used-subroutine '(3 4) 5) 10) (= (often-used-subroutine '(1 3 4 5 ( a b)) 10) 50) ) ) ) (do-test-group ("test declare - with test case from page 161 of CLtL" :before (test-defun strange (x) (declare (author "Harry Tweeker")) (member x '(strange weird odd peculiar))) ) (do-test "test declare - with test case from page 161 of CLtL" (progn (proclaim '(declaration author target-language target-machine)) (proclaim '(target-language ada)) (proclaim '(target-machine IBM-650)) (and (equal (strange 'weird) '(weird odd peculiar)) (equal (strange 'strange) '(strange weird odd peculiar)) (not (strange 'n0way)) ) ) ) ) (do-test-group "test declare in let construct" (do-test " test declare in let construct - type function and ftype" (equal (let ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in let construct - inline notinline and ignore" (equal (let ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third ))) '(2 1 4 3))) (do-test "test declare in let construct - optimize and declaration" (equal (let ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) )) 50)) ) (do-test-group "test declare in let* construct" (do-test " test declare in let* construct - type function and ftype" (equal (let* ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in let* construct - inline notinline and ignore" (equal (let* ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third ))) '(2 1 4 3))) (do-test "test declare in let* construct - optimize and declaration" (equal (let* ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) )) 50)) ) (do-test-group "test declare in prog construct" (do-test " test declare in prog construct - type function and ftype" (equal (prog ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (return (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2)))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in prog construct - inline notinline and ignore" (equal (prog ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (return (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third )))) '(2 1 4 3))) (do-test "test declare in prog construct - optimize and declaration" (equal (prog ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (return (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) ))) 50)) ) (do-test-group "test declare in prog* construct" (do-test " test declare in prog* construct - type function and ftype" (equal (prog* ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (return (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2)))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in prog* construct - inline notinline and ignore" (equal (prog* ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (return (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third )))) '(2 1 4 3))) (do-test "test declare in prog* construct - optimize and declaration" (equal (prog* ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (return (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) ))) 50)) ) (do-test-group "test declare in do construct" (do-test " test declare in do construct - type function and ftype" (equalp (do ( (a 0 (+ 2 a)) (s '(2 3 5 6 8 12 9 8 3 4 56) (cdr s)) (b #*10 (concatenate 'vector b b))) ((or (>= (length b) (length s)) (>= a 8)) (list a s b)) (declare (fixnum a) (list s) (type (simple-bit-vector 12) b)) (declare (ftype (function (list) t) cdr)) (declare (function concatenate ((or list vector) sequence sequence) sequence)) ) '(6 (6 8 12 9 8 3 4 56) #*1010101010101010))) (do-test " test declare in do construct -linline , notinline , ignore and optimize" (equal (do ((i 0 (1+ i)) (buf nil (append buf (list (expt i 2))) )) ( (> (apply #'+ buf) 500) buf) (declare (inline 1+ oddp expt list) (notinline apply) ) (declare (ignore *no-such-var* *no-such-symbol*)) (declare (optimize speed (space 2) (compilation-speed 0) )) ) '(0 1 4 9 16 25 36 49 64 81 100 121))) (do-test " test declare in do construct - declaration" (= (do ((s "abcdefghijklmn" (subseq s 0 (1- (length s))) )) ((equal (elt (reverse s) 0) #\f) (length s) ) (proclaim '(declaration ugly-dec1 ugly-dec2 ugly-dec3)) (proclaim '(ugly-dec1 nonsense1)) (proclaim '(ugly-dec2 nonsense2)) (proclaim '(ugly-dec3 nonsense3)) ) 6) ) ) (do-test-group "test declare in do* construct" (do-test " test declare in do* construct - type function and ftype" (equalp (do* ( (a 0 (+ 2 a)) (s '(2 3 5 6 8 12 9 8 3 4 56) (cdr s)) (b #*10 (concatenate 'vector b b))) ((or (>= (length b) (length s)) (>= a 8)) (list a s b)) (declare (fixnum a) (list s) (type (simple-bit-vector 12) b)) (declare (ftype (function (list) t) cdr)) (declare (function concatenate ((or list vector) sequence sequence) sequence)) ) '(6 (6 8 12 9 8 3 4 56) #*1010101010101010))) (do-test " test declare in do* construct -linline , notinline , ignore and optimize" (equal (do* ((i 0 (1+ i)) (buf nil (append buf (list (expt i 2))) )) ( (> (apply #'+ buf) 500) buf) (declare (inline 1+ oddp expt list) (notinline apply) ) (declare (ignore *no-such-var* *no-such-symbol*)) (declare (optimize speed (space 2) (compilation-speed 0) )) ) '(1 4 9 16 25 36 49 64 81 100 121))) (do-test " test declare in do* construct - declaration" (= (do* ((s "abcdefghijklmn" (subseq s 0 (1- (length s))) )) ((equal (elt (reverse s) 0) #\f) (length s) ) (proclaim '(declaration ugly-dec1 ugly-dec2 ugly-dec3)) (proclaim '(ugly-dec1 nonsense1)) (proclaim '(ugly-dec2 nonsense2)) (proclaim '(ugly-dec3 nonsense3)) ) 6) ) ) (do-test-group "test declare in lambda-expression construct" (do-test " test declare in lambda-expression construct - type , function and ftype" (equal ((lambda ( a b &optional (c #'floor) (d #'-)) (declare (integer a) (type (float 2.0 10.0) b)) (declare (ftype (function (integer integer) (values fixnum float)) c)) (declare (function d (number number) number)) (list (multiple-value-list (funcall c b 2.0)) (apply d (list a 9))) ) 20 8 ) '((4 0.0) 11) )) (do-test " test declare in lambda-expression construct - inline, notinline, ignore" (equal (mapcar #'(lambda (x y z) (declare (inline car) (notinline last) (ignore *no-such-var1* *no-such-var2*)) (declare (list x y) (function z (integer integer) integer)) (funcall z (car x) (car (last y))) ) '((2 3) (5 1) (3 9)) '((10 2 -1) (2 4 -8)) (list #'* #'+)) '(-2 -3))) (do-test " test declare in lambda-expression construct - optimize and declaration" (equal ((lambda ( lst0 &key (lst1 '(3 9 8 39 1)) (lst2 '(10 45 -3 -17))) (declare (list lst0 lst1 lst2)) (declare (optimize (speed 3) (safety 2))) (proclaim '(declaration proc1 proc2)) (proclaim '(proc1 foo1)) (proclaim '(proc2 foo2)) (sort (append lst0 lst2 lst1) #'<)) '(40 52 32 66 -1 -20) :lst2 '(-17 -47 -27 37)) '(-47 -27 -20 -17 -1 1 3 8 9 32 37 39 40 52 66)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST b/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST new file mode 100644 index 00000000..3b8c2abe --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: locally ;; ;; Source: CLtL p. 156 ;; Chapter 9: Declarations Section 1: Declaration Syntax ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 4, 86 ;; ;; Last Update: Feb 5, 1987 Jim Blum - fixed typo in specifier 1 test ;; ;; Filed As: {eris}cml>test> 9-1-locally.test ;; ;; ;; Syntax: locally {declaration}* {form}* ;; ;; Function Description: Locally may be used to make local pervasive declarations where desired. ;; ;; Argument(s): declaration - a declare statement ;; ;; Returns: anything ;; (do-test "test locally - test case from page 156 of CLtL" (equal (multiple-value-list (locally (declare (inline floor) (notinline car cdr)) (declare (optimize space)) (floor (car '(2 3)) (cdr '(8 . 1))) )) '(2 0) )) (do-test "test locally with 'special' declaration specifier 0" (equal (let ((a 6) ( b 8)) (declare (fixnum a b) (special a b)) (let ((a 1) (b 9)) (list a b (* 10 (locally (declare (special a)) a) ) (- 99 (locally (declare (special b)) b) ) (+ a b) ))) '(1 9 60 91 10))) (do-test "test locally with 'special' declaration specifier 1" (= (catch 'exit (let ((x 10) (y 20)) (declare (special y)) (prog (( x 90) (y 40)) (declare (special x)) (let ((x 99) (y 88)) (throw 'exit (+ (locally (declare (special y)) y) (locally (declare (special x)) x) )))))) 119)) (do-test-group ( "test locally with 'inline' 'notinline' and 'optimize' declaration specifiers" :before (test-defun get-list (num inc) (declare (type (mod 26) num) (type (mod 20) inc)) " get-list function returns a list of numbers less than 100. The first arg indicates the starting number and the second arg indicates the incrementation." (do (( x num (+ x inc)) (buf nil (locally (declare (inline append) (notinline list)) (append buf (list x)))) ) ((>= x 100) buf) (declare (fixnum x)) (declare (optimize (safety 2) speed (space 2))) ) )) (do-test "test locally with 'inline' 'notinline' and 'optimize' declaration specifiers" (equal (let ( (aray (make-array 4 :element-type 'list)) (index -1)) (declare (type (simple-array 'list 4) aray) (index fixnum)) (declare (inline sort)) (sort (mapcan #'(lambda (x y) (setf (aref aray (incf index)) (locally (declare (inline get-list)) (get-list x y)) )) '(25 20 15 10) '(20 20 15 15)) #'>) ) '(90 85 85 80 75 70 65 60 60 55 45 45 40 40 30 25 25 20 15 10) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST b/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST new file mode 100644 index 00000000..259ec9ce --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: proclaim ;; ;; Source: CLtL p. 156 ;; Chapter 9: Declarations Section 1: Declaration Syntax ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 5, 86 ;; ;; Last Update: Nov. 5, 86 ;; ;; Filed As: {eris}cml>test> 9-1-proclaim.test ;; ;; ;; Syntax: proclaim decl-spec ;; ;; Function Description: The function proclaim takes a decl-spec as its argument and puts it into effect globally. Because proclaim ;; is a function, its argument is always evaluated. Any variable names mentioned are assumed to refer to the ;; dynamic values of the variable. Similarly, any function names mentioned are assumed to reger to the ;; global function definition. ;; ;; Argument(s): del-spec - one of the following declaration specifiers: ;; special type ftype function ;; inline notinline ignore optimize declaration ;; ;; ;; Returns: ;; (do-test "test proclaim with type and special decl-spec" (progn (proclaim '(special x)) (proclaim '(fixnum x)) ;; x was just proclaimed to be always special and its value be a fixnum (defun foo (x) (let ((x (* x 2))) (list x (locally (declare (special x)) x)) )) (progv '(x) '(99) (let ((x 88)) (equal (foo x) '(176 176)) ) ) ) ) (do-test "test proclaim with type, ftype , and function decl-spec" (equal (progv '(x y) '(0.0 (a b c d)) (proclaim '(type float x)) (proclaim '(list y)) (proclaim '(ftype (function (integer list) t) nth)) (proclaim '(function sin (number) float)) `(,(nth 2 y) ,(sin x)) ) '(c 0.0) ) ) (do-test "test proclaim with inline and notinline decl-spec 0" (equal (let (buf) ;; ;; advise that floor should be open-coded in-line by the compiler ;; (proclaim (list 'inline 'floor )) (push (list (floor 8 2) (floor 100.0 10) (floor 30 5.0)) buf) (defun foo (x y) ;; ;; now advise floor to be compiled out-of-line in the body of foo by the compiler ;; (declare (notinline floor)) (floor x y) ) (push (list (foo 8 3) (foo 10 2) (foo 20 4)) buf) (push (list (floor 999 9) (floor 7777 11)) buf) buf) '( (111 707) (2 5 5) (4 10 6)) )) (do-test "test proclaim with inline and notinline decl-spec 1" (equal (progn (proclaim '(inline expt)) (proclaim '(notinline sqrt)) (list (expt 3 3) (sqrt 10000) (flet ((expt (x) (declare (fixnum x) ) (* x x x)) (sqrt (x) (declare (float x) ) (* .5 x)) ) (let () ;; ;; advise local functions sqrt & expt to be compiled in-line and ;; out-of-line respectively by the compiler ;; (declare (inline sqrt) (notinline expt)) (+ (expt 4) (sqrt 6)))) (- (expt 3 0) (sqrt 81)) )) '(27 100.0 67.0 -8.0) )) (do-test "test proclaim with ignore decl-spec 0" (= (progn ;; Specify that the bindings of the specified variables are never used. (proclaim '(ignore broken-var1 broken-var2)) (defun foo (x &optional broken-var1 broken-var2) (values x x)) (foo 234 567 890)) 234 )) (do-test "test proclaim with ignore decl-spec 1" (progn (proclaim '(ignore broken-var1 broken-var2)) (let ((x 100) (y 234) (broken-var1 "error1") (broken-var2 "error2")) (> y x) ))) (do-test "test proclaim with optimize & declaration decl-specs" (progn (proclaim '(optimize (speed 2) space (safety 3) (compilation-speed 0) )) (proclaim '(declaration funny1 funny2 funny3)) (defun foo (x) ;; the following declaration should be ingored (declare (funny1 fun1) (funny2 fun2) (funny3 fun3)) (do ((i 0 (+ i 1)) (z x (cdr z)) ) ((null z) i) )) (= (foo '(2 3 4 5 6)) 5) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/9-3-THE.DFASL b/internal/test/LANGUAGE/AUTO/9-3-THE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..18d23ecea6988ca13c08af152611e8ba775b8706 GIT binary patch literal 2053 zcmb_dO=ufe5PrL|tp7xI6vqy>vkrt(wQK7C*rkN^>e-gPS~zbz|*T%2FX6*7xLajCqpR2F87i$bZmv^bp+W&sy2$VrWUG$zRtoo{ye z^*x^H#Z0=KnGuYoOlc8xD-8(nAaFGx)O&+1}5fUaYVqG`GQG@D+I1*Q=s7eVMwJMhBg<8avPBqJH=oZSw z1+kEMKU2VR=1YVl#JXmBM^dV6#FMJE!L4vX>#7-wtKuY-CXG_Ud#fzS&RM2sQ0x(n zF-q>-^j#!`@4#Jrn|(0OZJj6ShvWR&$k7JQoqO;uA&nP3VJ^G%y$br@m5Gnl9YQME zRdt-_LZIC{a<&Px@%0iCB;-+Uy4fzPO33xs2t9=ekYHrM5sx=Z`MLbu++05Ihh+2s z=jJ(707V=gKVS&U2=6C&YGHtoFYpCdp|0Tey9wE6fO{qD{9aB`H)=(BaaYxySF$TF zr)T_YHF_VGg!Irdm=n|xQ=uX1O6MONKlqYSc(+FpIK1%=P+|ZqNkJ z{XfD;Mp?iWVm?;@=J!C9YFbhglPO~|Wkg*;NC-wHbxO2xJ<4E^8+xC;4`aP{^+vf$pJk%!z1qB7$}V`5jlF zr&E$L2{Gh1dqFB2Ne#`PSPP0B){J5soS}p?K}AW^q$z|p*-;dqIRT$I;cJd{iM6~3 z838*(H#9iGan?A>4h^u#LCE6%0k7L`G+KYb7p7jtE-GmL!P-!ySu2Vu$4WSYw?Xo+ zZIM46u?6|zxC)aaDI&Dkfc9h8$XBd=4txh|KB~|J9t~?f!P;6_+c5~@4_IcXoGF!s zayBFMAQH07V+JC}m!;#vY#Ki1GeYjX^BqQP`2_ClS8Kz?t@6Ih93C+DV^#hD5ZXK7 zwl;WEl1q9Aq2j$BT)Mi!g<%FQ;gk0^V28Vs&yNJV0zkRjY*-X|pic8X*jrmS@|IW!3du5E?@Z62`qp|H#VhtQ>{TFPQ75~3 zZ??Vvh@DLy;!5_OfT;Etf**g_B{$6asy-Ps0Aj2U79jTl<$2V;cG6it8vuw01cjv7cuF^cml>test>9-3-the.test ;; ;; ;; Syntax: the VALUE-TYPE FORM ;; ;; Function Description: The function is used to declare the type of the value of an unnamed form. It returns the ;; evaluated value of FORM. It is an error if what is produced by the form does not conform to ;; the data type specified by VALUE-TYPE. ;; ;; Argument(s): VALUE-TYPE - a lisp type specifier ;; FORM - ;; ;; Returns: any lisp object ;; (do-test "test the 0" (and (= (the integer 30) 30) (= (the float 23.9) 23.9) (= (the (integer 2 10) 2) 2) (= (the (mod 100) (1- 1)) 0) (= (the (mod 1000) (1+ 998)) 999) (= (the (unsigned-byte 3) 7) 7) (= (the (unsigned-byte 4) 13) 13) (= (the (float -99.2 99.2) -99.01) -99.01) (= (the complex #c(1 -2)) #c(1 -2)) (= (the (complex float) #c(1.1 -9.3)) #c(1.1 -9.3)) (= (the (complex integer) #c(2 10)) #c(2 10)) (= (the (complex ratio) #c(2/3 5/9)) #c(2/3 5/9)) (= (the rational 20) 20) (= (the (rational 2/13 2/5) 2/7) 2/7) ) ) (do-test "test the 1" (and (equal (the string "jkfldjskl") "jkfldjskl") (equal (the (string 20) (make-string 20 :initial-element #\a)) "aaaaaaaaaaaaaaaaaaaa") (equalp (the simple-vector (vector 1 0 1 0 0 0 1 1)) #*10100011) (equalp (the (bit-vector 10) #*0000011111) (vector 0 0 0 0 0 1 1 1 1 1)) (equalp (the array (make-array '(2 2) :initial-contents '((a b) (c d)) )) (make-array '(2 2) :initial-contents '((a b) (c d)) )) (equalp (the (vector * 5) (vector 1 2 3 4 5)) (vector 1 2 3 4 5)) ) ) (do-test "test the 2" (and (= (the (satisfies evenp) 10) 10) (char= (the (satisfies characterp) #\q) #\q) (= (the (member 2 4 6 8 10) 6) 6) (eq (the (member abc def ghi) 'def) 'def) (equal (the (not list) "abc") "abc") (eq (the (and symbol list) nil) nil) (eq (the (or t nil) (find #\a "bcd")) nil) ) ) (do-test "test the 3" (and (equal (multiple-value-list (the (values integer integer float) (values 2 3 1.2))) '(2 3 1.2)) (equal (multiple-value-list (the (values list string character) (values '(1 2) "12" #\1))) '((1 2) "12" #\1)) (equal (multiple-value-list (the (values bit ratio complex) (values 1 2/9 #C(1 1)))) '(1 2/9 #c(1 1))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL b/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..67e708201adf97ce31c5b9f5f5ae52d22561ffc9 GIT binary patch literal 64041 zcmeIb3wT`Dbsl=oyzn3if)7g+^g04X5ri}p-Y?1$hro~k3Cw^4Kp(hwMMKn!Le zJopeLih5X%W0>Z{R4_0=#*vferj4ukb8jTu5z@H%Y&A~Pv`)V!X}`*e9lJ^Hje3)N z@7MNobpN&1-shYd3;;^DLg(w{2hQ1NpZ#2W?X}llYwfi!8%0OjyRG)j_{3-`F==IH zrYB~mt&z;6HIwmO66ge;uIuL#|G|(S?G!zR`Y_L7l z7w+3l!98_#rG2ivLz9X4bYj>VObn+JQ^WDI4_S3qBy%b;ejF9nwzjl9WYyNR)wQtR1;{^Y$GmK4}OnNUdjB>+c&Rv@=+uzk4 zZjXgS{o#)8XuHRl``m1Kbzgrd(h-Vv1iK==1O3%=v*oqcbY>!$N}Nih2omESlrnc| zws`+Qq`ki@8kxIlUhsSb1(tV&_jg6YK`Iy7_ea;EL|?Qw9Ptz*Lm)cPk0SjDmUMK* z!kpQ&Y3^zOF-5(h_Co;U+-yl#q(2<%?&|BMglJwze`sGfK6o)Si1O_NY&V#5vw?Gw znN;dI16?)lm2Of8(bXk--mae9;knsO^?BWxLK-9M<<{Sc)|XJT`?{l{j&*n|LQ8vN z(O&Nsyll!D*7j&mpHFA#0QC9@nwxXd@X&j2N8$M7KhWM8I2WPYHBo-wx$zP)7DUYDlx@4H!^w#m=cOj?Y6A`A02#ouj3>Nu_J8QMEOtqLv(sXAKgYjmi=329ihHq`3!8tPQ*TO0JqAf!ufu-nqmpzCdD z)j1k#?2w(Vu|>x<**$8~aA|F7(7kMGv_s9hzfCQ=%}uR3uDM>vH8<*3HEY~xZK+kG z1(50l+B95_BbKqUj^CEp{7ZusOD&#%^yzy&Y_1 z4CVxl05a1rA5lOAvlZDp=Vm|B527`tNyU&_IzcG1maee1uC9nk;paVbvzx8DAeOse zOA9S?^)+p^E!SorexEBU(fq(kqViu$e*K{NX4)A3#zD_uS;Z#Pe{ziC>3=er94!qP z#vi}?bu15?Uo2X0Cf|H3g7CYS4}CWBO~bgHd?j+wV{R~vE6LYy8!V?>_)L%WSUyIF zHeXJbk7B*_qbqk+w?`u#U9{u{JF!T1hhxEgU5JSs=&Sbl=B~_cs%{VUw|53(;r@YG zB-qU4k@6e&&` z@Blg(=s!E548It*~(^)UU--vi`(VlJs<+SpIjHlNUx6ILg+*{LRZSf2+oPu5A@?pjR7@MPpqD4uy|~n5XMg zu(|5pz?pMlMC?G3&qmRHPLkcrkNMkCTA5uCGk(6F?Di)9y0Duci5_VV+37eCel zRe(VE$+ThI`vkLxUr&DH5D|`Ne(R8DupERVKp;5ylqQ}oq2gQmdes%DHhbp#b zxaTZq$tL(Q@1M-x{{#mY1dkT?@!O){+M<7kU$3Y6aiezbRqwrf-|T$b@bm!!9)bYa z<)vgN0f4#+(kDoFk;&JVTmrX07VXgl%*#byoSVIUC_X)uBqHFDr6x4mYk~xT(QogL z_6@|sv>xDZ*0-ZSbigdfxUbuXUC1Hq3! zr#$>Z!LCR6^~Sw(vm5qDqx(WJ3;(vw&6b|8t=apCM4f+h4PsSHGw`Y#h>HZo&9rC( z*XV=u00jdk5iuL)lXLE}@LEIY-I`NJ5X zbsgdEaKG%K577!p(nz|eS#Hk}oi$wQgR#2PrTfeQI`HxB$J;lOQ#12W_oU|~2^4meudxDdTZSDKH-R02{-6sBgns{Lg$@77yMgd05*~D? z5zM&gUC$uA>MiAGKBhD@6cuSqVVHf9lkv}I`FDPdAMYeE(CcDhY6S~kK1T0gt-y&Q zvOg@0#P{}P0}Y(v&xNvn|8{=+0T(`>-RTVO!a4r3n30D}{qH}_DaGGJ39pcA)8^&?lfpEXt1t=n<2zM<$7GW3G3z1b77OH!h41hp% z2YaI|Kg-Q_KhkXN3-|92f*$OPb_ccWE-;a;I>Hq$MES8OjM(CCpsp8$og=R?vY0-< z5UT4bj=j+cuKu36S50qkx#1=0;ri-c(4PJvN$4=R+fwoIR)9Kfn80m9ldppX zxPYhH9B`boKJ)8>S%JovtIl==75jh%x#)Q}BAm4mfnqW0^w0|iUV#x9{&|YUbFl2) z3rQCythOs$83}}cTR!+jXtCMry(t`kfXm^A0|Maelic-r5^Ai6NVQ`(M3L>`zCIQL z2!Zbn;^R6MPm;rwN5Zk_5$xl7daxxXiR~KHzv!5I#2%*+<1PDO`6!0x z!y69n811dE%@$MR_jiX5tjc6JL)hqyirQ#oACXZZd@R9a>W}t59_sdWWvlD>!-BBF zi}&!`qPLr$*M&t`b9*xE2F)jI&|>0LDtZLfOKb+h)jJUCgDB zjcfM+aiuH$L2Y?Fw1SN=#I2<^feXxzwEeNOb6OBRE)bmS7m0quB=2=wsiBo zxxHX-(8_}qXz)@Jn>-O_T=XcC<;mZnlH6u%H3^wOfWx84KyQ%5N_~Rz*K8rl28Bn$ z?L{s@FdTh!k0KrA}Y3%OM@B>5X`p};yC*hjIT_`;ZB^is>^ z(vK-C!1$+5?1B@#ie^I@ z77Okd=IYw9>_b8&7KFqs1|>1GYUZ9&s!O7XxiTM^n+>*wAo7c`K2CH+#Dt3!PK)2p z_bGwgZff9v!%|D7ntSN&Pgmag(&sIPYh2D3C3TW>Bs~#INS@9eG;|D9Rin9+>2! zvY+6`{3DnX*k(pL_JulxQEcH}o1|0WxhQly8yL$5g;X!dDyP}TMo!;LV!RE<=Fv2z65_pPTizhhm)mpq=pjcprgB&-BQmg1Us2|2kC!sems?kj3C{)*IJBf;J6#`$8rFVS!@FGKLwotTq>jJN@-2_FVXkvT%@E3@W)PI66v?Poza zm&z6+U|eXw9_nUVYhIOE;Ih9FT69H`Oh|)R{YcVzDWvGaTEIW$2L6N%eBgO53ylcY zi6n!xm}%|Ot=W%|Er&BGzLN~XtW1UZI)E6g8z=;0y6FuJWou=vT97TvqD+XzD!_jO z7CcTImZ7x;9wS`nbzw$sJOp7!(cU+)hLZ^ue|od9!h_o80akDtl5*(f>KmpE7IOjXMjnFvSTviaPuRgYQ*+@lPP14q4}YAW*LjUMZtQ%Sz;E&I zDiC8e^$MyYf)M@3fCFN;cm;vglQVm~xvHW{B2ewoaI8J-k7eukFd!BbTy_e0?nN3O zp;n%f=uQwZ)8myL{co=YDWZ&DbtBf7ZNvhUa)}QmBeJvXgG?Y7iw$dz`^J!T^xdy) z8yf?xk>cHK$}^Vo;N?3PlD8Z;>s`1>+g;;V8LIsAdH$Ur$Mg>DgSt&iVV|OS^IOao zncrg3tobe3_?k@9Op|#l)B6y{rkG@d-Jz}?MF3e1^u=rgRrd2-1MOjr7dg0iN*+U~ z)6*}k{k2YN0A#?n7&s&iU>3ss*D}K2V#WHGI6H3`MGJ7F8MJa8z}{FLeSR%JEv>>7meQImtbkoSN9@ zU$0N|<3&;vrF z>gO@~A&Emc>knX054vu@4k0nnr%04bAJyzClF`|G`&^qVWVsJ5D-Q`EA0O~>Dh`&VnMPWmQa`m=}@tzg5Qn|^vK%h@jaPs z>6D=mQn%Q^Z;OHB{Jbv05NsS~eYJJFYwmqHwAa`G4kxU^7TaRYeP z25=!_h&X_^Ae{vCmxwd^84zJKHM;iHyav3&K+8_@WBw4xm>0H2{C16Z$fn6Gy6N4G z!PvqIZI*M``fSDPYrcP;&fS?X$oxka~O1I1z*plTmCAW*OYH(mQSshvu7SMRR-mvr6h zC>9kLFf?_#`1)4v;-#ODZiXQ$_i^dwfpL35U;uW9Y>nSK!a7KNH>fAswUxJbhT9JX z+3Ysh*Y!l0wER9ggXSqx$pZYm>=AyU&Q|=bm+#7)>8iJk-=TZR*YveCH8!rd?N=FJ zc*kHi(JZ^f+33f7j)SDTGiCB}P>_^A{hxLMY@T=*@)E~nC*;FU>Jf>agVY0MvQM8p zyIH$8M`5##emGMq4|8r2$dWvO2WU#{T&$&L{P5lW6IrjG?_-wX~ z`5U;N9d;kX1UgKvs|ESLAzWo<4rG*hyerKyYdZiwbF|~ zPgb~`L8ygD+1@T}pP52{ZlrmO9_|0redM)3wz@oJiN(zORv`b71M< z*G}#&TRI5Z4UDNCh+u)}2x9x(4=s=|_LqRMIdBucsG+Xj+=Wc*X|D}61Y6)ylRUf4 zJ773jgfk62Q1b#(uNqe8+n!%Y4x>ijQu!zkA7?ZD(nY-7;_XzlOTY1O}aN2hej`qsrP-iFi6VGa*`4l+IgWvB*-2?eAe# zxP(o~zG$o;f&wJ@QXy2J4;NP+YT4#oKf@Tdza5Qvn0np$b}qHe($^^~rKS*cYxuQ=IrPnU-(N zv;AZNgRv0Ar!pl?W22rRObHQ{%UD-XnfpZ!aXZ!bH(53$`H$RGUif zING^xKg?la7DPgmh(wFr>a`HRWms`%zRYvRvyI2kv+Z6}`TKn#0oWv?u8-sG!Nvs0Ke9E@J2-E8$V%MhTbvv*IXsP6R%M9UU z4Zb2Y!K_mUJ}#;QAGX0;&Z$65_LdST{KVM+W0vqfj6Z+LzdYG5yVzLs@F#fmGhzO| z(8g~Q5Ax&b?fjVBNC@};W{GPw{)?oe;D6vC&%|#z!HZcDv}TJlock0DCp_DZaFW*q z8#6pp%$N6Zl5NfM;4QFcnUpRZ{yjvm6lQR2tgz|j~td_;`>N8$&xP5XUt8~SWijL zsv3+B)7b+o@2;g*MKX)?1{QX0W2skjfYi+$aSg^h*txG*%CDo83Y@DWP-u?EbF&;x zgRlff7E%ZH5#jkCRbngUxYn@lu{~p0l{gAqY2BkdXjql35+-x(%3Y;Z)%dI_*_jO23x% z>=102P9&zDwVs{Mv^{HCRRU4#%up&gGnJTZYdapF+@(@W9@lTxsW`ZMR~=ZfW6v!!>eJU}$yR@`wVlpv3eU?tKPlDH5-q6yj$%**WPv?KIs;FZ( z+0>O_BcKG8&jlrQt!gOM2AYpLTptSp!m6R1XPxmMe8UY4w# zRaI@NIIPyFlF{_g$XZqG!aqO?zHufq@EhV94!9+;;a|B7>Xkeoly^8W1b#Yktc@15 zY03ncFshEnC# z(&yDG?O_?7XWIoV%sGp$HcOP_)}C$5GkBg~<;WU#aM&7%v!~U@KTx|BOI7GEBuA%2@ZFclr0oed*Jr}cJrWkaaW+j8` z`z&fOzwJMh{b-zGj6BVj@Md2u=D{+w+6rfgJr`bpu7cSyla*Io-VgCX4X5XeFVM@C z*^+2?hqFIayyO>k-X+TC`4#^CVk4IeE7jG?RcYPTNb;Pba+Oq`FRsC#1%9TD;NZE& zWicZ1;pIkfk2c5%KE#hzjNs_Ic|`#bYC>olMW3n6;CM&CiJ(Fx< zm{vQ#buv=6g#Yh;e(b|OTSi_)I@*<=u^etS&+@yl|AiK~9dc%;k9k2O%eXDvmVFu zcHYEzdyTPR@$P?IwsA3jpEfSG_XZjn{U3q_43d7MCzcJwKyJaC4T`~XfC3ON!)s3<5ulHPiU5ac|{IYr90MBm|I;h#77S9TYWPn7NmKOT-9g>XM| zpga65eKdcW#op#GkI36#Hn0z46%fP1$B+q@V04_ghQ53LILMDb;Su@W>|VqfzfMsG z3jw~wLEd`sc3o@U{^D@9m{-Mba{}Hs{7Vke(=h>F247`nH~5!bsv64?#9oNRk#H1 zAo)zCbvo>CL%SHM~TBfV!yw0t6_^iQuiZU4ZX0XMHG|;nB^?dOrUc_xLdH zCrxhyi2XXUP*JCOIq5at+nVP6oYY&C&V~m0gFc$v&Toqk^LL-@N&iaZHGk!Qnm=AY z$&VX*^s?gfk(KQ>nz~2!LgnVn;m)m|mC*)WS&lYl2!mFJ;)?bHCBI9#D;ISxqfWk{~>q`X zc>Z2S|L^_N*?pp3Tj=AIiyiW)kYxVT{CZt9gJhd%l&0V34%-oV#D6L?NuckOndo=upJYJQ@tv6_e zLp^8i2V@p%TYR#n@zIQ6?!sHjOux5OnEt+^p=^6M!zj-%pANYD+GE}O$v2s&dq163 z@wCT$yiOU~CLfFhjO&^8hCw{SI7bwYf-e+q99sc=CZ5EE%Q~j)<}}>cXlE2t(~45a zKF>U*IGDgbc0DG!sde5>QjF&q4;8%eQ&)oL*Xh)b1(-rSK1pkBk2KM7%SH~VoW#k$1 z`vy2xJ9)xUI!`Io$Y0RN1$~EWk7bA>z7^aRXd(sbm|CY-nOkGvM=nwwaQQ^at=$z6 zEg}0yMT2~Yvtbsn8+i^2d}4Z{9TK>S%@d#$LSqKlvoF(_GbDFF+2&clf|{4kiXz6> z+dUwt`7s_UL^D+RJI6f9zxG!lX=HWiotha}b$N3Vtu;u`xfzAiZiZ5p4RDTZoC(a1 zoWwS0iCt>a8@}A?(W`UWofivtm;E?nDtzO>Oa<&CDL9)z?uvVrH!jj;lILdn!2F?i z(n8cmc8}v|Z11LGJQ*xg`-NRtV6BI-$Xu$iNXkw*_sia|XzB8gbJf>n@wrh4znA9{ zlcQ52Ij7yhqv9ca>QQ*a!ZG>e{c9&#Yy6&ckKa-E_+frwh;Au4B6q{C`6YnN3IyjF z!sag%AV0#uhwq0_2b_*-Z)*PT>;WeJP(U+e7w?k?9Ub>{c6r74@_Hx7u62T7CEt8N zbNdehfm;l(1{e9xJ8-p~yZPtEv215S8f}561Pdj0D#o?DNnuW>perO^PNEocY|;3k zHRUx=2CJ%GR`$C4FKmc5noK;;^liJUS>Pa33+o2VwZI~=MVr%W?5}yt*%@3)Z}~YaDx8PV%q6g(R}_O73VoM< z#=hHjbCzGN{s9mRk|Pi=+Jy@T$YbJ0dI=83V0srM@BHmZQ`{cyJxcN9*IJHOZ^{O| zF}#&_u{&Zob*98+*`jsX;*yWQ_&kn$9eL6GUj2m#EGlKUK>E?(=}Gt(2oB>8hafAy zW8PN1RHh6NHSu*z_PPf_{p zqv?bQnqlgZe(VB?PhowNu9r|557i(Yj-%1xK%0wFujc>m{S#@js!?XsaG1&}sH9v}lifJ@zMuH(I{tJmj!*0OlRK6d zMe{eA)SJKAPDxGk5qa?Nn_eY)lWD(sW z=VB@Ms~o&B{PJTL4C7<``!MEn(cTaSV?_xhfdIA3#*5IL_7ylTg8xTZ8nx~i?kX9S z{vjbrIsJP>Kl(rgBL8Z_DUS$dUB^6l%3UE8%&{XgK4q(8fQk4+57)BnQYfpvndPz# z|Dc|=0dkk*(MN+XR7D?1VjY;LX*&(5IgRt1-6ED;_yiB}qOh!s`?0E&oP!tZ@N?K< z(vIA>FWTS9EV1|Z3!EQ%40rWVZC_5`UkSl7fVMQCp6UCys}LTn5~1n)<`{@>m-idp zm%Cqh-7>#^FctXQ%dg*l2x+YMF1>`!!P3F8?|!Yz^XBV+s`H`j6uHEE{5B8Y1B7Em zUq>--9#X|rnr|LV`B2OqUC07r;wtEn=j*TkagxolT}Dh^x)cGfW_##B(f(+p-y5I^ z3c(znR$Bs#XRqH=(5$PzmZ#Ze4cOc~kK7hx< zjg5FM>gemG`edE^Bl9?C{{zn`CJYL?e>*gjjH~b6UrEKkX9SGK54@PJyb5?~sbYJ9 zB`0AkxVjW{U$(Hm@B1jIz5>gnT1Hp(*F<-{IILj4b4x1NlksN0%AGV9hj)+M8O3X?QDQro8XI8u6Ip?>SytZ;=oQ7o<3_@(nTAvog_b zz5=VwdgY&%4X7CxDtyPXYOz}o-g=Rd#8||kQ5wAKB9USbOPoVlt4F1Nk^bNLxH z*99uL>Zo>|ZL7;o}V(;R0g1Ha_r48SqqOi*C;r`$(mE2NrH1jO^VMJ^c0wy;>Q?q4=zZD^dIzsNDz8hi3PrfHrvPB5<|yicsPPQ~5B;#_G* zvGgC4;1&-;L$gDRlxE4k(vCXnDT9a80j9u4-feb%VX*XVc6Yw~*suNCuYryPIA8gN z4ZaH()__kDvyGaV@HLMt6HVQdx(BcUj@nm3X-{b%!g&Y`dvPBW1>wlP9!H`{y)X(} zS-0ZaQ^(5MFA}2cLC!Hx22I5fU9gcDc|I<|i`` zk>JsR`@d5nac}Z}IKl68RzA%A zpDAcE6Z*Rxdx|prhLhmS6f|C=pD%GNH~xzhG+(CJIVbIBo#2ZSd`2F;a(Yhjl1Uzx zxk#qxo}5$MrcaguAA?spYchR&k%Z`dNEUByS*%dCTA+Ciu)%8;y%xxpU2rXS6|4N6W2_x_q^N$SmmKVwB__;<?+pd8Ed* zzGOAX7ED;z#9IJseklbBqByhaIoHhbybSuu6YTQD3Mh8s7gURk1?Wj5nQ1GI%f-i! zXHr&X5@DP|oo=(vGfA@#?f9Nk4fTGN`hYPSh~TDnj1hO*`=A00wEBP(C8BlN8;SO- z4_>C9{DGlChYgUT8260Q6_VU)E}Onm%kGwzornfVKp)OUt{%^v}UUHE7c zJCyUz6U6iUT1)u~ZjogVAd5Nf?)z{lw;}gHl^nw%|DN5^{T-_wWo&H(3u=o4^Dfln z`>k}x?-##`T&+XH+xEiOjeiZMk1{h zwj*vWKZzUP9e%P{_Ad4*5fGW;&S)&wwNJE1#BRlaWuhyP9A(;Tahh>*s#Xs^hdS2#V?inf9xFfq;X*+-EpYlB?p zHF(GPPhD)6@yo<^(fw3@puHm;1orE3f-H)yu9C2kNWvpr^>^VaKsLbd4K@>+g!R`!VDXCPf%cKtPr{xErjX({aJqP3}} zeuEbxN-Q?!1=e)l;Ntk_GyFUMFg;A)gZ$8keHc!2*(dPHc!AR`h-7MUoZl8%$8N9d zT=WGlm}mvYR;nL-`@&%*hXijSmk8q{>N;xR0{j=B$|e_J--+Y0g7I=blgc-Guj&uKmIA5wJylVpSG6 zG&g&j*oK8-tpF6s_;+`ZbHa9TL)v`@PExV-A15?%j}WDUO__35;^f-{CxOO2z(VRJ z{f9vF{fTQ^Ou@gb;VHg&4;+m=zud{lc?dS(?KuQ$th|hzZ>v5Z(oLldI$Ws(%iCYc z?jj~L@cA%04tEn%6N#bGcnY59GWar@Y9mJv=XXH;^g+$s3IRyO;I_JeX6>dtlqh_F z%TvlYs*ZuagUj)7$4B9D+v9kEaShF?YlE8m(36oPAoG4|l9FziyJ&5wptV6YRBkb3 zr7Oml76|%4|5N1BkYQ_?vvZ7YF6+@x5BtOdRuhcZz6u|yGZ@|zl)a9jg|VgT~-H|Vevwi zcQ3DS(C{wm7!uHf{KAb6-J{jPn2ej$<+5_o7jBT39bW}>#JKKAePkgwG{J}}sa6o1Jl3)5Pg8tO}Jibf8Xuv?~Oim3tb0Sw;4|0iO{$vmZ&zJ7~D zJS=y|hKnK=D7}xJR$k?->@MU*2|kUy_kbE;qIJQo9G$M}3)0O^(O$S(ha=Wl-$^9d z;v@;RlfTJmtZyhc9=v}?7v25La!k{ED7*Dh0PoHnHrRqnU`fWYA+jN-CK#7?p&Ys* z7?+91$p4+4o^F%kOK9<>{ZQyYm_3(n${wR^A|_yo!Mj`zpZxxw6Z{XZm(}01y*+Af0Ab0 zaX3Z%;ZsHtw2U!ovf{W$&NX z+o{(o>>`ttPcsNgW#?WRlQ%NU_(#G(Hm=G*e*9(`$d3yHiJ6eQvLOP0v^1*K25(q7 zZ<49JDJHU^*~fV2d*`8SfQ`>RcQBPPz5ZRHBz#o6F-y1Ch z#m*+9bWQ*fv(Yl`d>(He6F*eocgQ90&wx2hQ*(>sDT3W<{&N~`sB}!}I z1Acp+4|t(l7z93Pg*UPzli6@lUq|S;fxkW94Lt8An_E`!0Dl`b&;0ThdU(IpL9lzYPJ;j)ynXJ6Q03!@G`;vJ~;J$-k>oEf#>=C!I__RHXO4ci5_EHKwcV zdp*GW4{_fM;peWwGHMO=B+qw)^MoW2&VSmTJyp#Q1lwPKs zg{wUu;o!gE6ioMiiGtpzDRz!FFnXg4YqVC>Lh%JQxs=KG_b2)B9^ZL&tcYmw+_uK*gQ+ur)P3IWsgpGs#Ne&%${2ku|rVZ(JEvo-KZ&Cf{x$FM(yhSzde2O;Ao6613v81%KGikSztM$LQO4~dbIv!6E!pm~u z|J2RxGh17bJFjcG`%G#j_L(?u;gtcUyR3_ksLQOeyOb7QrhO$Rup}A(l6o4Lw=L+} zA>uZQ9(dX7j`jx`DTHb8SJFNcC!{or>g}fgIWFk}|L)-5=Xqa=7BNlmUz2Z_U*L~d zaA_C^J}-~p|5|&*=6ct9yIjc-zsWtK*>CR=LEP=Xo6#{KF^Ip`*x@a9o8B6F$^T0c z#u$q}Zv#EJ$ZHw;;d?`4jkkkF(eoK@ujDv2W2R}I7bU5 zjyX2p_sZ$b_h+Tqq7B*NB6{)vs;3^zL8V%}pesN-S%USx6a|g7W;qrFKO1y=)>t@lHR z(`V6^ysZrx;8I(Bm_G~u;HO42Gvxl9d;q`!dTwKDn%nB?Z=$i}uDl8&p8o!$#2k`9 z$!S?>RjfC3_^^(EbMdb3wrcCxo@0BgN}KnFv+eQmM0&b%msRDo8NT3yPP?IBDXnVn zZUc`n5V3N;Syc>zst2uFtBy1@N-hki+#NVlNoyoI<)(3gWr$T3>FOq@+Pj zPd*rcM&xcU3Pm8UVucH6i5!4=WZR0Dihk;5hcEGzX5$sQdNu-AFu@*pK#F##Yih2o zZpYHx=)QWEh{l^&+@)VWPGUq0R!f0n+;%_^^O@Ww%KJAsqECImoUgQEOjTZtb) zUtHHiUotPCD1*+_`%){r^lYVE_{X&=RlXdX_m0{7qt;eyCvGpO-L-2&3H`Gy`YWlb zLS( }9C05;07fS{16pX9$F;qf>5E99v>TAHn;tKchZ`BYv znYF4WG82?zR|!>LM@^AjjaH+osL5(lp=PUDg<7ngPtS}_uT^B#^e*b3YKKMXxea@` z4SV*KI7$g>ltfpN%M+_|D47@<3r?S%NK|s3s#F5E2ha@&(C*gOS=*1DwkpBPR$5h{ zEda|dOLefy$%^X+;={v}(tuhrvqLguqRX}ZKJ*h(N-f0$SFZu zSb2Qr#EG*2z0*j-7upEWNn9sZqYGgQp>!c^si^_F;64o(isSov00%WH%r|&~ixyS?FV?XsIhs@xXkdYjeiQ{q;v|rsGf?1{vN#ZJY z1W{~F9Aq?>o}y0vPGq~z3Zfep&n_M$REfp`s#I5@-1V;94bFtHi47Pl*wyky=mpw8 zg1L(;ScpfXuc*b2vBu*=LEI@A1i_FMrLLh#pi(edgCwi7YU?%iueU%7of`5Xy1y$D z4)(y*bpKJD6>N`1*@77t8IB(xjtAN7cw{C$MEBuX9~;gL1qFRR?(_p{A@hid2s%BM3;nU6olsS>MX(l-7ht60Jodt#l?NGG}X^gKzr^aT| z$8l}Zu(cD-ST<^q>Om(3>*PWZnZV2*Phe_0P_d(IjKW$a7=^{h!Kf9}VSz?E4F!Pc zL@IL}=2@7@pz$S6GeG2RS)&u{3>WYR(ku6j6@U>w%Qs-e=^!6)pP~ZzAD9Qe*VUmC zAk`psB~}~JNJW(u=#iu9^yqMc=B%Be&T6!Ft(-oY;0vMb|S#hxFnkG2l5X2scI57@V&!ipj%%m+)Osfi%#X3GSqQ*{5w!#ER)lR8(y_}wD z5f!FMu+(A`BV4aFl_VBra=e!7a#w~vIiKs6eQtDr#l=$F7KDU%w@pKKSSFn+BjKYIT+^Hbv>gI$lkh;r2<7;*bQZ{ zDkN#^1hw+%$qem`s1g}*OrtpMd9X1V0sx-DCc_y?y%SN5}7o2<1WxIR6Mya2g;hZNct%7l1Z1Zas=v zH>iN_HhU@i0SlG6Uz-VY(H_Dzvl@DU+ zb!P!4QkL=2H0L=nG`u`dFfR|lqh>2MD!BPjvqKK^8g=nvdWL1HHNneN|7_qQHRERs z8L378KQ{i0D zsQ}CT%82EWuB)D@l5H>*2D20EhO-mv2DB5qI;5pbHdI?_L0S&cRREcbKq9$BuK=FR zB;>;jEVMQjMQyuCt{S#zU0e*TZa)mjaJxI7GY@>+$8vMyI*Y#z`0|_GeJ;$`0+2oB zqv71Sd4Wo4UoW#!AVH)3DO9?wEC>{(lCokN6d()=2i!#|(n-}$6GSfR6!9U~~c z%u(7=uej$~{1_Cb^Pv*_MOV6#Ba+28;2T;`vvfUv;4e1$&VXw-)rm;?K*76 zE+>BuVQ2&4MC|?P+3P&4!#DnnoLdI^4$;v&_;P^5p(^8pd#$}22OHwYhjy(p^aZ@v zemG|Zd_=6|WY=bOvP($B^5e#~x|3miRVg=dG%I&(>s)8amm7kN-=rak5mSaB4c1R2 z+?Tydf&>+!!K2M%6X`efLdlAYpEaR=4m$!%>E)7m+H@(7OBT#kCGosP`@oX;m2$5o ziD%c9-AA3ys0|I=X@YNrx{AJ3sW;6MRzZmb#YsJj*3@3VYA7*^tJ+SuW3jP>aFcbB z?r5+olPt;Q0=Ndjft+fv+jZ>-=@vNBU7=dZ3)WF_Fb)rd{i>Y>^7hd*=dzoiTR1el zJga*LOQO4Rl8a4&!-4Qj(9mXyv6o%ee{5fM=`N_ymesD^9gltKG6*mTz}eyw=H3Fs zk(sc^0)hjZH_Dz`?}1tlsdr2ckPT&>`~S;$z!B4r6vi$#W|b>#MbIPZSxeO(0< z$>TGr>Cp*X1i~t&;Bo8+RCfw|fsmrcO4nLxM|`BzZlZtLS%sF7@InbafuY#3a67Si zXW=GtLuf(8K=niNd;x$fr51xC0c6EUUuO$HT&aMnQXWQ{*#wZi3Q6%4X68NL%YHfQ?X<5`ajv%>QXBHMmR+pa7?W zP^_-hZGg~h(cVm|Y;olxBZpj!>McMfpi0(Mf^AEH5>>fCwW^wGtY&DhNh<=OzKddN z`7HFl)PWLKOs}{gxzmh{j!Y*tn2&SSq(+V=sP61{$T_wQ;+Z)J;%qy88V=vHt{!*V8MNr5sjB`luo{3!B(pZ zG!PRc4cfkwiJJ?6s7^B4B#EF`>%db{PwGsq3!zl?P(2`4szcxFbQop;^*Y>ORW|5w zqgB}mi7*wCCO!)JwUOu*~OB#ilNnncrx z>cXH<1^BXt$;xpQHRt0nnlyk`w@C zrkiLG4ME-vFSt-r+x61OTLPY;x=!vIl)6&B-~=WR=-#2%2@6SIZ(aFE88E5T~XhGNjDO{&I0 zb*v^Y#?4MhrUXRPcm#AWc-hEfntIVjxCbiOOsMVMErqTQW={B}B@gtdfpl3~&rem; zP06a6YTS4rNxCfYm~n2>vx}Rq0qZUR)RBeKRvc~4MKZlgpcUwysOl&c(zUS>D7T;y zRPLj+CggQD7VcR-pC%LI`O^s$Sf)bGOqk%-!)glv7|Nu;TpWi{qNVIOns$TBNW>?D zWLN|`ds@sp!1XF)ml8C1+?iKWngW>H6l|vysGG1-rrdq!PN`0hh>e7>0R~?y7XPk7{`N0?if_s;) zm!Z&LQL5ZY9*e>kOt`?9!6s!okw0uZfuhV1SlG#0C#3YF zMetOj1h(~WJz=QC=tM->5ar^>8YxCoG$8Bf8O^CNO(67zfv%2gmi&wxYF4*Ul$uHQ zxDn-dfkLgo1t|Xt)We>c3WH~kPbHpqI*!o=qbBdXK@omFx38-ELIbgUaC=Hhuz7_3 zST&w|FXc2bW6hv&y3yISzrYeUl>|S#>gYKmCuwiRz){Ds9+4$OUa$JYy(PrdIdl^& zCkzr{ba+BMRg7E1nZ#6j=d?05q@|E#Z&R>a%*h2mN?~$s@lz=)7HSV$=fFv@^<

E!9rsRTG3)$V+&YZ1!XonyMRwp^Bz>7w-Z4RCNO#ET%WbNIrMK521AzJc{L z1C#RUvbAZoJ)OnDv5X!4DzY?_P9>(a>RVnksd0AnSS^TfqImG4DkNq^6o>tdNEpBZ zHPIhzj(O5mxyx&^PYR%km6@3#@KU)`bFeeKe6>5BOlWI43KnXcyRa%J5ojaqq_x4i zTPUHs;6C)SLKkfC4R-Z+Dpd~ocu{UYmVxv1=yWnTnx2@M4vtJ_#+CiEn-_zr*EF~f zZR!Wp(?U70^f+5I=vn|P={guOGWE2k^iGqES645AY`TvR4Pz5#wL!Fq&3OUlo$Tmo zd4%J{IF$Z8*bTJKwEwVoS@>OSYwaUA z+jr6#gWwD{x-j7ajKH6hm7!X>-1)J&aOG#_MdcpKz>e3+tEh~tYHZ|OS(VmgJ0VJX zI6gTXFi~(O0EH?!lB*+nb12KS1Qc@ zoK(j-m3xXPDlJ$}U12ch*M_ZFPB}vbYXf1=NhMS#zbwpuo>D7T*6hreUDh6p=m|!i zk4s=5y`jVvN$13dFUOhcTcoXyK&8JFp~JoE5__0;$RDg9 z@={1VGT4E?BTrdx;gt$dkH|l~`}G{1d3}RRXHNc1jc>4yoqv9nf7uHR+tYZO*kHob z#JygvK)9vKn1z?Pt6@nkB(*dYIGq(Zkcko`5_} zE^=KqyLS0`j^*GBDEszv9eszM8wtjzhDUC?Wuca z#MO@o|2P^w7hcImnMwbdlFb3fAzTq^pv2JLpk#;vRk^_)K%r z2-^w0K~Zw1`8POtqaS`7$qvjSzj}4gJmiI+#4zXV3{cw1bzqy z{k=u7_bRH!iNf|n)eOFCD_=E~JF%M@ovSMNZf%*(T*&A7cRoP|Pmp=Ai(%zJK)KWn z$Jmz9^zwx8+_9H(nBGc$e4qU>ncpU#M#dMj=jb8Rll?)x$fYmxtwYA*arB^q+Ma$;08vzr8_-g7M{7(C>0MY`Yc5lD;8S!Iu(~4;byv=|3-}Xe((`4V}Tu1 z`sUgDkZ;~2K!3TEJ{Fzx?$+*Yg@B!c8zQdTRPS(5Uf)N$1PyQY;d#Cfl8`i=*2MWs zvVp;2OyW^-zYfVIrgj@`fDIdvuHIDuCa#98JTU|R z(#IB_#&vPWapN8Z>A-In=K}dfE>H|=7udph&<)nZ-#GZ9_(QqXaLc)P-6KRJ%lw2f z@9W4uC-&J3yc`>g$|Tl%fV+2{X_w)?6AzahG3puau7ASa^&`M2;@F(uu-ObQvkgcjQoPB=Au8Et=ZF~k|eO031+C`3+Lpb5If0R z&Xk4naLSh&s+5d{^WhjPB+?K^R3pcjdq>G%ursoC_R3m~>UG+wQjsKr|Je#r>dmrb zv@=SfqbKR3v`&<9IgOKEQEs%p3-Z>}Aa$ux=mBsL9ljxuWlErr=TK&H65bSq1VUj4 z8%?ChFzk0r2_x3o%#1Y*AIm2u6N!f`SQe0c1IKd5C?yUBA5TDp3~HK;r%#ZH;OO*j z%L)d2Ac^GtUGCE@I zke0RsYv0FYw9Av$yYspyV-jvYU=Nuj45%K@3|Fh(qOua;xib?qfF)60Dk=qXLsFD+ zQLZ_aUm22N#dhVtsY;Lt#xKYUvo2ckcS&P)->9`E0EB*I1a&T5h6_k)lfYT80t_xqBpxN$%8|jlt~g6P7Y%% zWT>&|7ZOr>z!;Mr5R>atc2-qUL0p=(TMEs2QB}x;et%NTZTTrXwEYt(c>di-SaYcvG&>cdBd7?z9;8}wI)QG3WJ6wC3quex1CRzTPYu-$ zB}Qr}eyU(LLYZ|fR2lyNgjfrMOU0}dqPK!bF2q}l_i>8TBjS*1_t<1cAe;_DIDnIv zGsm$=z#bkJRXHf^&|KT*y=p2xg0mR8Sh@#LCP(W~9>9m0%Z&_Lk8jEN=;YZT_O4in zoHL{{kbDFl_%sZAd@-${7AS=Z$;+$a6OjH7lLS>TPIN72^2E9*0OpXRa=LyLY8%D` zfgU(Z%q^JpGvA}Z0yM#RSE=*<)~G83VBF8% z437R+08*Gu32l|e$(%IG{&LjSNFBuU1I-a<*m;g9{3quGg$EiK&6-SjLI6fnM^;S> ziwht>#NjYMJC5l>Q>c;i{S+oZtuq0rA&TPwF92>&Z5SY02XjdHsfNh`W_)Hk2_1T6 zCzKUut^U)A#29(<(dot$x;$N;Mc-#uJI@U<&=3pcs+5}P_|(2yn8Bp4-m7B8Zf>z5;(i1dTC*7H@IZbX9 zREPOVKZWRO9%D3`h9(WRDdZ50-6T;NR?ZBPt%}|=?Fyifw?JJ zJg@>Qb9pi$JZ?4YCi_HKTjC@I%_7VTt?(!O(Z;D%3S?ZoTfv&a2s@54*Z90>jfC6#l$*1eoCI&jcdeVYQ)&GA$^6|s~ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.TEST b/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.TEST new file mode 100644 index 0000000000000000000000000000000000000000..4a9a78a75175c305b07f3ce4e5fa07ab23f3e836 GIT binary patch literal 36822 zcmeHw&2MAJmR~!0W2AxUL9)oKf=LY<&!XhMYJTX8Y`YVRq9nQ{QcY5}+R!2tc_ne0 zA~ht{mY&@P0%V`;g8=y#f~;PURkBU~g}2D;f+Rq8na#}ney6H#)xEs>Xxo`dFs;|m zB@to!XYl6m!8=*b6o`R6bu`-6-dZ8TIL}zOS|F z?e|}FYVFR;y-H)}5F@;-9Cn&7E3JT~K@}agm-+ShMPcpJPgHSjBbQU^$rB}iKlIMK zqqA`OgZg1MF8`oZmUY{z(#q%7*H+}SlwV&|*{>@t7JJ=RoBQp>sH4kC_--)1Vo&|< zEJR-!Rf>S#C>QhPLLs9*5ad-1@Z^Q6jxTQ}gR}FQ%Jvpjz63m++^C~)GQP&M$>n&` zoejpLWu+>^p^}KwQPt@t)I_#tE6d-iY2Phm2Lxs<->WzoPut)IJ_*8YL z)A3}6x~_v~YIfe80o?9zc%#NwoaSt-&cc~8b;nmTH5jpMGQPT;a_*;BBk8j{R9&=W z*R%6bO>d^N@M0N%8LSyesI7LYyOksSvMak%T-gAqE2Ux)A8W<60zXQttN2*Y73HH) zEXl7GlE8X#omJM?3-W7YMXGG9ud(pAId-;QTH~*cJXQuDtE)Nr*kFT=wR~QGNR_oB zJKMmx`a>G5t>|C6-P)>du&SF2WE*Q6>(W4vuvU^^>v`#HJsw%WBKDQ%-Y3Nr^7Lb zDLcBlI6*!Afrjt8!z&P)ZErpo(TVOQI|*l3laa~}2cXLA2;-`P>Z9d!Fj8H7_Qq2s zUmRGoKUF=I$rp+%tC>Yqxwsn62A9JykkJC&l?LcU6)@PMQX1-otXfsM<($gn|Enrn z;179BfU^B@AjF-~G~N$;Ly#z-SC^CV8TP|yI-6YeW-370a4-thXgo9Dx}&}toQ=kl zFvGcJfxPbUaaI~;vt6~2&0}UowL);rk!93DIaU z&)R&1Edm6CvImI=^U%rI$@Wn-Fm7x!bYs?uD~7q6`l}%8Cs+YX(}6Hxr7~&ju;fTP z^900c8{r_lr#g1R?B+6zn7S<9DU0TI!4i(6uF3)26ScCO!44>BwBSXOwhg=KCs`l2GE z0+UJ^${chb8R~=R=tDTFrlpT86{mvb2Zp73TN!&ZVssDSsle$+ruqvpRU8hHus}w5 z2SfF%K8TxMf@_XdmWK>Zp3fmvSk8#UamqsvQU>^`g2q))C42~jUE{%q6Ui~E6ZLc{ zk1had4|>lC|5pp|An-$wJ0VxqY!GallHJQMan5MT@PtQ>{)*n@QCDrq@ng>-1yLXE zMI->c`rv(>HRz>WC$hy9Uxdj++`FIzcQTj-2829LWy{*5F2K2U{YdbXj)ZYzb`i*S zS2zLHpQX%50MKLM;IzVS^aYIF%D-~1%3Kz*YYPA7FiS+n|3~b7z`8@26nXNQCs95# z@}!)pb|-tsD(Qd%#he6!6ZYy}yPU(S>oh+Ir@!OEgoMyU=( z?&-qkY_X_Tc}mMySxEVhcRU-IA^eQ{{Yxc1>toatQ31j5X3@yseq)i9)zWAjOs{(9 zkliOs?$`9@;$%FGlnqNk%871TF!Kbsd8rM+YogSIsIWI6`9s<$sr;HMtiq(Apg+M_ zu#t!D0?!H}=zYMt#RXL$DEsAOSr-UYSw7 zAA5(}yr{)fS)sfB9-`<$o$;UHZsat!Dfn#`^QwYHZnV+K3-2yx!5$GTmo)+Xf(AS_2d;&L`?K3OeHvjKkR;ElxBm;<)SMdtgr> zPa1T_0V_yqn?Qj!KHByo5t7HUwg1e?khU9ZpNtHbMqt&dK8~!&qTu&t_5A*v{nMBV z%*km*uylK+F}?MG1VE4Tk-{6KG4v{;YFCvYRN~ZxRicoC3~GASr!o%w?21@3;b)=T zbGP()_rhtx&XYy0C>oPKjR_Ge6D{Gjx>3I|a6uM|5N;$zSR64eXTBVEX>+k=OJ5Ys zd$J%T!$Kqp`n?KTFeJK&)B)Jt<`&bgssqg0IccSX6_ln=eqtWbsBbiy9bTbOp~5Px zfC|PctOAh@&8eUQ78M{-22_9aIz3%jq6Dppl`?05dXRU1){0p1f8IC>Fs-l{ErS|P zXF2uR+wcZ3O=o!k0l29NLh=)WfVpP!D$kpQY_RJT&DG=v3wY+KXJit*v9 zinJd)g97n_6??ky1vk<{b_GrVEN(%;1r+2}PyoLubCz7S{JIKO@c+WPDgry428&G* z>Jn>gmWP790raw?A}W`Z?sp9)O^vNgx?a@Ef&!7B@#bF@u~^?#kx`0sx5@$YXn22yC^W6>{!ffp~Hym+Cu ztwh@ytIbe#5HS+=%W62LbNB`|Sg8#sa4#&=N5;SE-fT}@F01_Nn&RW?dG~ULP=Hcd zZHe41mMHl0<*#kxO7gL%s(mw>b+63;RYZp{-emJe26@$mPfzVHqf+SCV93H2Dxy+j z{BBvTJX0HMrotZOxx-5d>rrYuJW;F97=*K~zJiTxa|r)wU?N~(Rvy#S4;iL6I2{1; zymo$?uC@^tgE*O~neg}FWH5dI1tg@)9(?{Udl$o(^p(Cu=ukc|m|A9uZjb+(*+qC% z-+OY<`z7@~!f`I}8UM4x+a=iwr@hHQl%%rS(<`Dbx;N@1R991gh+rGK#r0~bO9T>i zr-OH)uTf9ccjqAj8~WjNFkzUHUeU_r?23-_>~s;c^ne4By5={mkTW1#{ObnL$EJBp zLOFn-?&t=A0r0>2f20p|tLBA%Mn#|k}$)o ztnv$Mv2IRv<%AlH$fD@pXqG3&3xF<{pf{u35SAMu>J&4F|Hf*cXb~s`DBaNlP8@>e zwfI~>19fQifPP$<;d2UMPY59dbUzDmc~Z-lkD<}cdO&k{J;3BO2Cmt^%HBYMHaK`p z8l9gdbU-Vv<1v(sGoT+~F(uu6C2H<3f<@7_ZH$L@+)_!#-7qUhx_g|RolnN!SqMMB z3x|LQdZ`9U+QPkX`x*fN>a@Tlk@@&>KF=k0ST(^Q*~B)~WT|(~f?A07%z|j03s%p& zgy7??@_H&-Ccm(Y|wDjO<`#e2y z1VvssjBR_>!^obGnWlvE+qwR13S<si1`*-6G6PW9DakeD7Ej>-W(>RGSjm3Jl9P*oE0{F_yf~{?X-v$+xCLs^Yo*I! z-qPi(Yy{9=as}~!{C6Q+f&p?>{^ivAs#?#fHG~}Czp$vR(x}9LurB3P5glO+Zy2r+ z`k~LynMEGMEW*XZ|9&A+_G33c4FgI2|8wa7|C###pa1UP|F5|I{|A4e_5c6#`XB$h zKiuPRTL1sAfB(^^H~;9T4Ij1oduRXjU;dZqm;3Uoztzg`$H{-Rx%L z*4eGJcUAVF(%EfP_L1Y0)OM$$`%kI$o_D9`nMJiLqUMt<@`sqM!K?zND6l`BxRQN+ z*zDBQZXHJw3im6oYQbi!S=mCOPbX-1kT0}PX*J#j!gHe95jbT5%5;eIqu{VzYn96! z7xw$kn}eE4d3e;B?;dFr?7sH;u(GGJ=&Jlpy|Wusn|sJ$>eQPJU1)v-Bdz96q6{h( zy&QH#M)}X9f{7W~y;=uKgoAgx-onh8=>i1Pi141NH^Fz4!7L1DvXEp1;MQx?u2q|j zt$P~+gIYuP<`1G$fh=#;TLvrT=3(dH5C~P-&An#z z6(hx{8C9DHZ)8HL9k@bo8faB}4deqNwhX>$)jPFd3&~?16!H4M1`fWiwK_;pLq=Mo zvKMsf`?a9c461vFm?H?7T}k>{>X>%1>XM~~W#({PH2_oJX*654pw?7|u*}G3dbqHtvUr zCldg-4;vn6+z7$;!QNrJ;M2~LSLF?6DmA>a_;ao%=bqAad$0M;1NuKcW<>*sTZgn^ znBK;Hkg{!~sThL3yQ&A8so$=3UVD>lHZTe%R{r(&Ub6yX!FMvdJluRp78JibiW059 zO>dJcMs0+K-6Z`bV6KsS@+}bSen~wKXh}?RkG}tbpsqg{%VG0wO3POBo9PCPl-!t`HsLsafq}zMTQmG0nQBJGHe@wOmJP11! zCZRbrsHWLeS(exW&DX!LV%NOKL$uQ+o6Qan1+pCM(`vQ3Ra2z`@^o~it@goo6A6u2 z&;44XBj5Ftc>TPoj}_sjKIpVqAbBL)&6cVoL$0|GTWzO_kmpKUwdy;&$R6FT;2Bu8 zh6QSlM0*xjpot&@jM*mYuz?&yZ1FGsHrY+IA{>iq3lkMKz)3t{c%=Nz4Zmr|mx<#H zI6gjp2ETQ}WOl58?ySB-5wIYEUZWC?tM3$+^ zKv?n5y{;?X_f1p_yx;L>w5rVnthGKbS)qaxb%uCYVm+a1TdbV^7#j zmeN+G)vCNv`4ya_s!_*7O*mvlM|_TvqY@EU7NuHlxdirT$QDxC6z%uMMkBZ_avz5UZtgZX#1d6twV5%H8!Y5*79Ksq6IgndmfE%Brbs1 zX&nlc30NW(w%;_GjW_#7CbaW*od7~v3BR#GEQm;A0vWEvgd31_3dT<)XMU_^5KrA^ z5}>9KjTaGaC{KXL)f+q5{pP92Cc;}xE7eXxKC)@&guRNJpI&N9y#=Apa=lUS0G9z| z4YEV+QP7eR48xdwxrIY_zw%YH6#)O+9#Sj94DYEz%l|!9m<4%H6^3oE%u`!I3;GVn zl>;0Q*e8bjp;sfL$99xAhbo*Xt`?Y$ZHr}cKM3A^9a+*az%(E$g303Af)0YaH9TG~ z(KxP*OdwgWno{-)0*Te7ZmGC#!WZu$fn`); zD>w9C+loB|JVzF!&?Kk;I*uioH7}izizia&q@OX~F2S;q*Pn$>73~@v=O9JtFH%F6zIzeoElS`o!KuKb!T=e&s-47D7{Tk?uc{wqC0?ifawlf~;t& zY{Et$zgsn&olzAOCdHZ6TtQ{_Dx0;vHgfTp&>gB1L=?P*gSsQ$X6R3hJM3Te;P??; zOZBgG-mpsmho~YldQuSr;)GiocEnpMur6l2n3mscB1X{LkW{^>#KRVV7VS6to6Wrg zkNNSrBRhRtgDz+GSQ&KejXRb{x=+ zui^0usLx;?RyY;$D0N<}=!75FBXk_|0L@<2-h9(+ZTS;Ku3ZjAb`xf)7kYtHmAkcE`dEulLQ zwBZU}iS-~h2!?R=YDc*CrQH?-6l!a$LA-jbev(Q!4$!8-<_3c{#2G}gy&H;6Aso1Z zBWagP^qc60dtC6Ox0X-pcnngP3a&dA8p*=!6_!wt@a8L((pnm^kD>adk*Av;BDZZu(36V(~`&_`vYH{;r$E!?)W zS9xQtqlwNpz~LeoEsukTa6FkHyb6jJ+}(XRzM*?Hw$e>SyUkXs&TE{!#SmU53@Ylp zd_)ujMA}gOx>0*rUcD}&V%_R4)Y_^a-fsfeYp}*-s+!Z|TBGh@2zNfr9YZ>ok=i^8 zzf-;8Sj;6;Zl=4a|#10&n7VrgfqiIkB#4U62Ml zgI7eavHQu+Xj_i;^_5ovT}ZzNhcwJ%fM_S{y|}-*RS_^H;p;l0WXk(PWBd|1Xq_zf&xx) z7uEPXnm~~egj`t0%1xK`lKnIrx3RgyQ2~g^?p~y+ysBK^4r)g@Y}=~bsC^T_@Jzm} zm&53i4hLc{fZj}?2h8k^Yf#~J&L<}JcS4OByU46FVV zKl{N(96?{llfkeI!oK|R*BULfxM@R}k*eI<#~cVg1~4sS?zT|e0gkZ|!j6i2-n0k9 z^|idUU1{%GH-v9PpR4-9baZDW-5;vX(bEbJbuCdY8K9x*kw(SwF@JlV-3LHA80#Ut zB5wV-+ug62w#pr7hoMCiYB)?bOAtI|6O@<4Zb_2?x;$*v^b^4GHJm0`N`fTz4Xyvv zY$Ih`O?oe2m2%_O)vA6*tD{sBmEZN{RYgVVm5`Txfa|Kf>CL5X$0L||L{(b2=G|gz ztK_8aIAs3R1g5+x+z;ak&K22_u7Xh0om&y8-mg?!O{G0`gw@IsWMtqZGD~~7$}?*^ z#W;JFh`$*N>hUo(mfF|#s+cE5uF8DRtCil9Lii^=-fri@PSqrfP}OO7vJ83dGL-}9 zj?#8ILV87$kQ?)Ommb8U5|H=fue02c*oOuRGq2dLiw$c@!SghwL8n1U*(Rp5{%LnQ zOxq&s5JN=v1~NU~o@Rj6{x1<3V386=mvD(0F}TCa0(np1NYzOoM4(oqKnh6%N^^S~ z9s{vvb03fftDb?40*W4OQDtuL_zApXyo=yT3Kzf?4swLT=8pkDa50w{SKts%yh^9i zzya#^k5$}w_M#m)$L9$jjH%In-Gct~Tpq$mOs5VTKvMVl$C38_3i%~mLU9lRbdbwI zynR|lP8qDY`L(qiv(T1T*K@d&kXE*&fK$RMS`MVy+RtKiU|^-S(gtZyv^L8|Y`GoG zAq$Qw9D|&8`Jf$O*9I&Jxch7|?%J$vIVLzy3E2B~08UYlJvW3?6giq!k^_4ru_&oP z325w)e{nf^y$Damvg{3UeN7ea&q3@Y?ya14Apt^iW;nZcw9-s~g6W;?4CCLe+0o5cm4rT9-HDWPZK)4D_X705nbha?Cx@fNbw|g zVe4@wpARZmXS}hsP%IZ#%DFt`mD_JW#eA2Kk6+*d0GNpI7u~C>osixIt#T17s$(bM z`c>9V`O8|#w(SlJEU2#e!~9*X33zks>ID0UmTGRb$%&f{aKYrs$Mv5t)z*U4K`HWU=}7Z>H{h~2;4<0*I`=RR z4KaG#Gqi;J`L?GZE&-C>RyHct{lci zLIJb78AuNCf{Z%6hJ1lLA@m~N<2UwY;7v0ZY6AKYQ5n5A7~_TYVqjFYR)cj!?y*Mo zm>+i&Tj@y080k$60+RK?(YcXNar1p$Z;Ls_?Y!;eDq<(2M_FNqThmT(Z)Kr&88*O9 z1#wQ=HSR6w{+qx&n@2o`hF;EKDhv}?mK3e2M76nrbv0Q{5dyT7=s*x9>ejIw9F`su zd&J^{N>U``wY6&YuwKz|;yj1YVx(C_c!4eQIQb_kgN+smo|P?X1{l*ABeJ?cRn#W? zo9l5M&JC_>FvlSLZB$X8!9MNn9ACepi_kavYzoGgyxKlt!c&I&sY5~#b;~n9B$|nv z(68gZV|urAyS=TMisn+T#Ww6TP!!?6DOZ^m<&VCDv@ASB?h?B__Fa9o7Vc+H7FH08 z_vTwaaButmDm(XA*`Dhr=Kro%5f%jV40n4BNX*$yRH7BO>yT9MsfabEMjAWB@9a6H z!A^q2kZePC0rJv%umcOf3wmWdg*UN_DwT>|gjABjCO3V=`!%Zu>(l(gpoyN;H@i)R z@%-sxyyS!lLcPt3YSZ5W9D07P2nfg=z?CL3i&5|*FW&A!UF606Vt2)b&*3x(2D||t ztX@)qwBZ&hd*2OkPqI{H&XqiyULiCVn|!-GFtPMl5PDI&d$zO;qd znyfan=p>Z_^(&+Ie5vGdfY?t7JI&;S{q98GSWw92DA$?tLMcEBv3tNCZfm@bh{AZ| z4c*v2xU2EnZH?`NyBZ^vCw*l5;FiW;bw|Ml?uUstF6N^*A;^Qf8uMDr*qm+Sd*&=7 z+d2`pZR309ERAiQxyEkJDfEHY2V{-$vL@NwwC235jo!UvviHH;vzNPYpg1)Uduz?nElnBTVY!Qgc@IZ9--r>}INC7ExR`*$ z#%A*nG7dDXI^W8Hp(%ktZGqtt55yvkuyGsOH&vEB}(Sn48xV2x=^zCzDi?HLY?7&#;_d&BQRv^E=4me8UD37qN%*$sA zTGnGy? z#p^|h6zbIW;gv>$hFMcgXTP?;S)&6yrrx0m-fKdYN{60^=fj3L20BrPjhPFiy&@Dt zO$elUt~VTN9X81GU|igMW0ExzV-<4H3sU7H7J{dW{RutkFkrn*^tyhnIn6SFA0lx10x>?6XFCw#(2MvoGJJrVH}DU!5fnj zo$DP^oBIL(i_eW?qMTq!Ml)Jd0(P^h^-|llcU@~k$4`cgBKQ5U>6Q4ujRi=w7|3A3 z&2SDMbL3vYz0$JzB~z-|dIKlZR{Pca=a;w4{g2O2 zx)V)hAh7CQlTro`K#y#;?mOI?aEr^4W{4!co5K(7Ch6G+fOGbg>Ta$23XUCwYHz~D z0~4IZg55Wo=|Xj(C?;89wuW6~vXplHTPU==7{s#ayISZlv4_|9d%vsSSVkJ;M@dY3 z2tbsxq_%B@Y1}oCtX8bS-Sy+Saz@a87_P7xBG^QglI?XDaCIL#)8rvYz#HTcPXr%g zzZ+hRM?(DfuRaeVU`y|J*xD*BL|LK$)ONd@r>!C)@&!MUkvx5#1w`zhlDq?x=WZ5$`(=;{9M%(jT(z9QQ;_adde4Ovy3G593KT!PRT8zX}tj ztbLXNxW9x@fVsjOi_Z8uzwiQ~vl9l%Nno^=a;-rhlw={`M({&0@H3fM1ko2ZZB|TS*->R= zxin0*^!y;*ji#@ZiPE5hDBbP)kt!~))IKLM7K@?+ZIsrL)0a3qi%hsm9+U8)0nEEL zcC=)7#Dhd>OO80(q(4V(BBb0m*bxK-b5g&^#pBN`Cjqc2gCR=SJD)yLyJYMd-$p1j( zJgja(>S_u_px1nWaQYZOU;xd$qlMBx5um7v(C80Qcv42ugf0wl8(#@vy}e&Y`m4#@ z{~LjU$`^L1_?(PP@AE=4$8;PJ&lU?Yp$VlA?*t2w-pRw)@I%*oo=cIfRd*2xj{SJp zs2{z5j*A>8)92H3z7X;1d3Shu-ksMBinwx#yB^j(XeJ&vphcqk3La^36v=BR^>pT( z54e>&Xl}!rhx*zHq3I~;Th<-gU9ZiF0c8y1{`Ll+?=s1Nap{vuAl*Ss*c;yZA@eZV zxjcB}@JYD2q#0_)-6RZ;Oq)C^O0KoXo;j?Hb8PWv5ba5D^}& z>N4;PzvA8jYxyYHX*CZI5Zsy1t>Aw5@@5U*0O-h!Z}#MfU5LZ+L<*P>b%^Q7V8$1X z0WUfXjYe|7Dp8P#cVspiqEt*Rn6bx~M4I%!S=*^M@apO#KgtmID#RW~0+tc5nJq4@ zw+{CYbb7rvYs5dA9RO>^vU-|dTjKQs*mDnUwl2-qqh_#uR}dGW1wdaozhnMeO?e?V z{Psj6|AXsXBnKLLI3gZ8h_siuX_&@AT?jg!j7Mj_B{u!)n%jm{X<8Zrm4)^7E+Fgpbz2OLT07G2;0tZjb`giGb@27}JGift0I; zKX@8omHhyatU;0C05MSXh;!g3IaPw|VwR~~3+qVO=91gdT`UGkC!IZLs+g=O2niOo zig-oq&C_=?6QwWrX>r3#<)<%kT_p;pZU>60=9cxKd9d7&7tS-J9|>y70T6zhsa(y* z7l3gDa$*zA*GB)w)Bn+dp#3}sOWQistOHF%YyckzdY1tu{7w2ir)x)qepMt!- z%ap~$x#-`gqwlFP;j(g`+P&`PN!x~@tGj>@?&?|{sn41Rj2$u;Wf@N6b82+#gUwm^ z?cMjtx{}aWaQ}s-J|N_v(n3@*d5UYdglr2_<1WZCFwQpDEQX-_@aLLgv%l>RM+Tt^=(F^ zzTCxjo)qYOXoU!p72YtkH8EWe8;SM;wmqQ?U$^uw%lnh?<0S6`^_?f0_Iwm7@mUNeYd4S-}{!lZl#V~p1bnS zjO38;9#3a}>bAMF1X~ETJ#3qD(*^FgJ-z7SIx)UO2UpGV6>tRh(N0(n=@P76=|i8X9J&xIt_tjDhS=&%&5;8 zO$ZrPOup@XL`_y&JHjaq)kc{|dZC{@`Se$j<)BmRBjAYV#Wb_{=_d>f2MeMYEmB_z zmsaV+yHi7&%CgArqO4O6FcH|9moNY1YV;PO9lkAn@kItZkZKIis$_q7ZxFMB5lx|W ze%B4R$+xvu6GAU8Jvg!f5z7BaI=mc&603&8qLF=xLz~F@qa7)EkBTFH?gxC*=6hhcIA!u8+CZOth*n2zGx1oIn*%y*D zt)7w1=W={079ZT~-Fy2CHc;dVCb=T&!3hwfRlkK$4mgNpV(Y*G_n2+1$WA7s zk9=Q{(>1iPU=~^SNKF4>FMuqvkk5CsZ8BYxa-wt}P0G*AG17-EaxkMSG;qJ`dx?x5 z-cxydx@OAV8UTV@Jh}(c@7>Nnap@+CJzi*M0SszAKpP&=M!ulf>YWa33BuoNa*N{m zH@k3@rmPNT8q+G_t_j$PD4^L(>kbsN(TPTGLZk+4aeSd5G26K1!!$sD>=r>6jxZv; zrjFs}=9UCtq9bhsnIA?T$`;h~Fl%nEw}=UT8Y;7{<10P=(#jD^3-YE5t!BmiWyie;3h75@Pqj^ zXtC&j|FHlgc*HB#J@k6t_c@L9f&3f;4g^^=o@U^Btvoj-F83>NhR`~KELjjtRe`^H@P=Mk6)2JTB0NxgA)=i8<(V7q|}S!c1l~8S(u#-a%{>%Hz{n>KPJXV zj0aC^v=GUxhVS4NF>>$=`3-Qkm`L#8X=a|8_j%sm%nTv%+_aDx?05XO*G0jg-x>7L zZqP-&V9;%PXjkg!m1#5bx{A%U#V7d*=h{xQ>oxk`4&no^x6^p}0OeN@?sWaOoD_?4 z`M6XllpZZDPE@dCUAg_YX1TPqQYsV|CoWG z;&q~np$Jow#c&a_;)E}4FT@hgtv!&%i9!^h^TX6&5TIY4;>;N{u*VV1*yE!G{pYH+8ydBRdt+O9g z&VLQp-qW7|!`3@mSCuJ%qt@5itr13Skpjp7T=>nIVJqurK~0EH;XU27X}K2nWmGXO zTZ9?UYEq%Aj;@YL;GAw^ZdMIOxXWb2=7>1yY&)E+tIEG8xUEN%+IW=KQWA1nCyd$5 zuwB04a$QTyf{c#owlUHjJ(9H9{EbT+*8rli_@=ZqX_BniY#sAz9A>(V5qj+fB4t_X zxBhaN*dbT$vJXR+Cq_{V@)43WHnQ$Svszh%nNBy@L%n9u@elT%its-7dVMs1i09F6 zLw>&<K8W_FvTP~^zAX6E;sH(zi3 zHd*AnqVY=gQmtHZ>U?#zSzB%LOVv8xsIJy+hhIXRUsH01`suW+%nqFy?lPZZ?7CBI zI*Yuu>NFOMpS;NrpXTLSy<9z zTxu|mG4BgEI+@oME1T23ZEl0>@vghQSzVgP*5oObg`!WQP;}07J7i;Qc=Ro{bF=d* zW869w@v!u0hI_EWMZcQ~or}NF$3-gPWyXRpIdnz*N=g0st8dutHuU|qc4VO)`EENh z-G{u5)HrEB_3i0eh|-r%`@YJ`4K#(EfgT($@N z%h;R4mAyH1RtEkx2Q(_-uFivD9G-8hbT9FL2{%jea-4-ay&G;)RC4;+EM1{AE$e4B z)sQ~OBBD>3VkiQ!&=K5^K2eb^Wm+;+D{tWaD*l3Wm7r;Bq{>W6>~UaD+B%fYzmskvb-G#++=CS*5H> z-Y``Csm%qBxC_V)95klLrW&MzZlcFA(y@6Xt1FU~lS~V>DZ)o+f9K>`Rgw)uULc5r zeiZC)c#g#HK$WoX;dv4dAwlBHz}g9{&jM=$5=(noh7YpXkjTQ|BqT%_JOzm)p64v| zi}-^eOT&LvhfZB;WWEn4NDLv`gMUv=n$Kl*OEm~Qh2XKQj+ZBElB%h5I0?dE#(>>H zSCTR<`@SzyfG0kZwJ@)uBl``Gllaxo!F~zEee{g)Ma3Cf7}X@VyFlf#JCGuA1JWe6 z0`NMdu0VPfl66RZ1nKjT%tPuuNS}e^1f)(vItj@Wkn->GW6yo#wabp(q-U{NFRv_1 zcBxo@oyUi6rHN*S9<~Z!tD@=DF$=fsxhE~B(d317S>Tt7_=+y_<(1$8By9Z^a?5yb zxL7QbDz4+vVyLpEO8;33EsL|1H50nY4e#N@e9lsXvHaz^uO3pT)3A#* zr$K}G6L=CoQV9i{)Nj4*aI4rVw0!GpA_QOc0zwFgYeZbM*8=cj%P!+XDHIC@Tez?v jK?^X!7UccIlIKPQJShnKM>)S;Kp+G!!EttLe0TRB-OJi5 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR6150.TEST b/internal/test/LANGUAGE/AUTO/AR6150.TEST new file mode 100644 index 00000000..804b5294 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR6150.TEST @@ -0,0 +1 @@ +;;; AR 6150 Test cases (do-test "(vector string-char) printing: escapes" (and (equal (prin1-to-string (make-array 3 :element-type 'string-char :initial-contents '(#\a #\b #\c))) "\"abc\"") (equal (prin1-to-string (make-array 3 :element-type 'string-char :initial-contents '(#\a #\" #\c))) "\"a\\\"c\"") (equal (prin1-to-string (make-array 3 :element-type 'string-char :initial-contents '(#\a #\\ #\c))) "\"a\\\\c\"") (equal (princ-to-string (make-array 3 :element-type 'string-char :initial-contents '(#\a #\b #\c))) "abc") (equal (princ-to-string (make-array 3 :element-type 'string-char :initial-contents '(#\a #\" #\c))) "a\"c") (equal (princ-to-string (make-array 3 :element-type 'string-char :initial-contents '(#\a #\\ #\c))) "a\\c") ) ) (do-test "(vector string-char) printing: fill pointer" (equal (princ-to-string (make-array 20 :element-type 'string-char :initial-element #\a :fill-pointer 3)) "aaa") ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR6247.DFASL b/internal/test/LANGUAGE/AUTO/AR6247.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..011aa31d82c9f8151dda0c6f588d686744ef1060 GIT binary patch literal 2293 zcma)8O>7%Q6rNdc96Pbiy0~d-s%8}+DW)4G!EMr@O5JQGw(Iq-vp)?%s8y7@IH{XN z`Kg2u6_f+CGHOFav;%4{NSsS=Q7JwkA>{xPs7OdXz=cyUTsWfe-maUbrJ_iioqfOa zeQ(|yXN|PHq3N==aA9$_R#}o4R#z5RSLAaGOY-u<>e5U_J_maFUCp%EdwEqW_PsvP zX794hELEmgDraS9wX%G6`klk_z%f}}T$-)H$M7(SM@O>Rk=Ks&wT-K`9%OrF%d8TQ zWnodNRW4R)Naw;bp@ewX>ydHS(42y4c)SrW+XrCXc>r@YorWh} zOy8-48bd(@sYwYuX3~w>yI|XMxpg0{Zk~}ErUc@jYo%+Z^c^8<)sIX`7ib(lZ|$Ev zh>>8A5E3J#F*_qSzNTy!Ci>tZrs!n)>;e17W@j~hrUSf9Nr1Rp_x^VgJDyfVfL%-jj7C)=Le%@L zejuZn##jOSMaiqin9eL^v;Z0-XJ>>~9u>mSjLD3qI$B<_nB!W|Oq$<~VSCDUSV;(h zM=EGnO=qg%mX&eSD%lxM1^Vx3$IS5dP#YMcj-KRFXb*lAx#ZQQfhR_zElda(aULXW@;@N8$WEy` z3crF7M!2ej;xCXTskxTLj9tUWDcZgVTk27{G}UGS5bn>;Y0RWEBj@DNI}6qADyc<= zGps9RvtT$-+<=P$w3%8$zX1q~`+llrsZ*dLe}SsgR|VBk3I_0h6hj)k3;ovleq65e zG%g?T7f!*Rky0^;vO#FUx!1CgFJ@1bMonD-+Aez$p^loaF;?CKq4alqy~>k^KoD)_OvpSL!_+@| z^)9EfydrmBQoH4I({Qt&m1pOJOBr>SUPd=(gYL8PTLkW!&1xQpwy-&OBGD+o)hlpp zC@JF_lQ0De)Wl($0}U%sLIHWJrkl2FF=!@y>SAtaaEP`btTHsR16**6@ePuI9bnw@ zTLRol67lK@tyYl$ur!Uz0II*#F(m{Ae-Xi-N^3o>D%y&Lpcek%+kyP4k- zVYzue5NpEydoyC=YE#7Tg3l)M7@NJkACdbT?EpR^c0+H(bIie?m$G9$&yTkQ?HJ4> zb{Pz$QpS-K@i$GxGDEkHHMzC=+`>M$h|i55-A#rMQ;{F@;gjEd_^|+f9O2L9w@`ct zzbQU~567_UFj7y0pB20LafHlIh+GX&k)M22F&|ap8K`c0UwG>R5I(2@FNY~l47FZ> zNmX^5w}Ts3cn_Qex#HFPMn)N26)ZSF|DTAJopyWJXP4||=k=N1dI%zWuHfq`yn03G z8%&st`v`chnZFf`vTEST>CMLSTREAMS>AR6247.TEST ;; Verify that WITH-OUTPUT-TO-STRING and WITH-INPUT-FROM-STRING can handle 16-bit characters. (do-test-group AR6427 :before (test-setq fatstring (il:mkstring (il:packc '(9865 9866 9988)))) (do-test AR6247 (with-input-from-string (s fatstring :index j)(read s)) (with-input-from-string (s fatstring :index k :start 1)(read s)) (mapcar #'(lambda (stringlen) (= 3 stringlen)) (list j k (LENGTH (WITH-OUTPUT-TO-STRING (STREAM (MAKE-ARRAY 10 :ELEMENT-TYPE 'STRING-CHAR :FILL-POINTER 0)) (PRINT FATSTRING STREAM) ) ) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR6273.DFASL b/internal/test/LANGUAGE/AUTO/AR6273.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ce46bba6dc88120b83653c4d4581ca713909b436 GIT binary patch literal 774 zcmah{O-~a+7=CA$mI8$oqG*hf3C7FDMG6R5PvbC!mhCLg&IXC6rfl6Ng*N>#F-Af> zcv_={NOm>+2d{{cgMY|>fV0I!f(K7C^US=@$NNqX63?iGX=A5Zt9vcn=ysaj4z4y@ zxZUWsDju#X9KWWvU~kq4U7vZJ9d<6=R9arS<85Qv_1fFzSNC!D5hl%6t*$o9%j&q8 zTUf}=Kb#rP6UVw>`)|#1Zgw^|w>UF=etd*74FIUXS-cDZWI%`TAjlY!InvA*EM{_2 zVn)~tgOti*x(*XzFg}Mnjiy=mUV8O7&Q2Q;K=?68}%K#e2GV_Xi)rA!m@ANxeSS&BYc4_t6wbiTF=kpcp+9%omH)eVD%9YitOY`~Trw3B0hY)I^ zvH0W=Dj@|$kHeD2iOcnhWfR@Ob)rS1D9pkvy5|xWh0}}bptqxU{XM@c#<{nPB!r@G z!)(QK3~o^;+LsxEH9v^2kD1U|7aVb**i%q zzXi`~66}Bdy(Zr-y)`YRMT6qE{%0AD19;2h_2)>sD`JGbjMmF?@sr}17C%Mk#dqt^ z<--|T`~#sUviRpC{J8L#!`b`TgPSw@q6u>&I8JHWU z&ItDyz+xo0rrk}Kle#SZ_XMX}JgH>koRR}5iyC2!GM#$7;c-owf`EdColQNlyIKsG zmKM%XlT{FkCj=h}$iG0MbcM1y<^uDdMNz|Jj5x3G9ZSL&gRlJ0Oa^wzNu_vlTV!zw zW`^m<H3AVPO#X>Rz)u^wnN_HriJJNSQKtgOchusST@) z<#19Z?CmI2+P&U|STDpnx)l8o?aP4gy9Ohe6M*wnunDV5C|BE&Kle6auk literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR6781.TEST b/internal/test/LANGUAGE/AUTO/AR6781.TEST new file mode 100644 index 00000000..758ab0ab --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR6781.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 6781: etypecase produces incorrect error message (do-test "AR 6781" (not (search "the value of" (xcl:condition-case (progn (etypecase "foo" (symbol 1) (integer 2)) "the value of") (xcl:type-mismatch (c) (princ-to-string c))) :test 'char-equal)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR7412.DFASL b/internal/test/LANGUAGE/AUTO/AR7412.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c82f53fbdb80dc8bf161ccf03844032e272c7917 GIT binary patch literal 823 zcmah{O-~b16umR0A3z}k(U{=Z3z5ylArvb@T|Hl4p)j2(Z{CP3Twob&lR}$*m>455 zE?kY#LL@U9{)1b@$ihG5KfpVMD8YrBnfK1S=iYPfy*-FOVJ2aX?Pjg+wMe7eX?8ng ztI;CuMz>Y*$QI({6|)6@y+ql{^ux@MbK#}Z@-{l&CXrpQy}9x7F3Btq+HBS8c$lBZ z>s&6I&E2~{Jyf8Md6w0_plA&MsK80|8wAiG2Em@M>5@CrC=^X@ zShU3TpcnWl^kTRU7lA)EOFE6FQTJYW^~lb48x(-xqn|3c7L!HW3ig#ZN;>%9j}$GV zjMnHP2Q_t`CCaV@eu9bz*~}~)9weSc0=`v`mzAR(c=~-=T^pSkQ{vD2s!$jnejVdy z{B1I=RF8gG5zt$CZ~X-5Ro_|5sxktwSN(c*t#1jRQvhjzlUilGSJi47sPW*Fe?w=s zl`lpTjU{U3O)iW_MMSJcM^^{X`0CBwm3 z3jL1iTnJkjwkyl7)MJB4NbA&EH~P4vhiF{OTn;gG3E-v ztqa2l6^8hgzdjgs_*wRF_$IQGa=pwAyD))%2Nt=^C(1}TZ}y)_Ml)Ez=y+dO28Wlh zqN?Upc%2|qV|J;G3y?RMX*;gq*AR^5i$XO6|F-nn9WuE~C&|_Z?(in5?VPP&gzZi# n!IxlP#j3ZM;8b$sl3KGUxuB*K4o6`qV%4=J4=3RBozv6b`xo^i literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR7412.TEST b/internal/test/LANGUAGE/AUTO/AR7412.TEST new file mode 100644 index 00000000..8130e774 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR7412.TEST @@ -0,0 +1 @@ +;; AR 7412 test ;; Filed as {ERIS}TEST>CMLEXEC>AR7412.TEST ;; Verify that the interlisp function DIR is defined (do-test AR7412 (eq (type-of (il:getd 'il:dir)) 'il:compiled-closure)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR7475.DFASL b/internal/test/LANGUAGE/AUTO/AR7475.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3faaf92ebdd228b80de9b8c994479edeb8041b16 GIT binary patch literal 1359 zcma)6OK%%h6ux6S#*W`r2$j{6t5ikKl(7<;&|r|zWOALj9?!V*Ak7N7j#C>s8Osl( zf*O?yshg3CTT#s|>JMO7u|b6*FDiA*o+S$;Bo-{#bmg8iPD9jIg3(BGzw`ReYwnOt zT~<`8ID4H|yV0f2px+tv>8{hIJ!jCZH|Q?N>6eObu*^U(VM_O&ZGmF z$Is2jW#Q32x&KQ!uyrDv5yDsf-=i0@ZDzCZW-n%cazTu)00H?m&5T-)L3-lm z8yTVb=+op#PXhdVsNU9-PY4+{Z|TW$KuEyx;mNI8^Z|W@kT@ZuR{iAYVdHo*;}^+9 zwq}6Zk9S8;-uV9{v#%oo%8OZuH)^J_J>R;gL`B!uOV~qcQ`Xj1W=Lx#kZ2pG7zp!d zUf-CTn(8D(XhX6uA%(UiG$gk;j5j z9t|d7U}4iTfGik;b5dl6p&OEJTUFZ zBx_XM;&0;TYd$;RZ{@)%Zf;lBbX9^BY<3zGSkrB7y_!O^e*jNa4ShpH^apUpCR-`t zk{<0n0yOv)&HdsLJ%yDIYgmn6+>e~1^eYH*xZ3>mXMC>4sln+-;F+k%Wn1&v&+$|a zV_mX!i=E}Ec>p1kS(mar6~-vPd+wao==JIRfjm!lYj9KS(ANIsCr8=ASu`7Z-+6a& z;BPC?42wxGbxbW;%#c-+$H0uA;d9qLH(yv|FatLEb^ZIOf5h~H;=nv4&6hm4dFEUW zZ>?*4SDbdM-lP2%ZSS=frlZkluG4j{?&FEVliPJ1UyR^YuOn6NO09bwe6fIN;p0h` RsgPe5f9Ei1a({6=eh$O~h{gZ_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR7475.TEST b/internal/test/LANGUAGE/AUTO/AR7475.TEST new file mode 100644 index 00000000..d7bc15f0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR7475.TEST @@ -0,0 +1 @@ +;; AR7475.TEST ;; Filed as {ERIS}TEST>CML-IO>AR7475.TEST ;; By Peter Reidy ;; Read an expression with nested #+. The expression only has to be readable, not executable. (do-test-group AR7475 :before (test-setq string "#+(or symbolics ti lmi) (progn (foo) #+(or symbolics ti) (bar) (baz)) )" ) (do-test AR7475-test (or (read-from-string string) t) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR7525.DFASL b/internal/test/LANGUAGE/AUTO/AR7525.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..51c34b5a2c14420db85000625e4f398cdd0b6940 GIT binary patch literal 1832 zcma)7PfR0K7=Ker=^rSCut@8ovn1*tgZY1;6J?+thWD^t7H5|Nn@M>b>!NkOq7tdbs`(_GD&_t6-zd!GN-}n3e zz3!9V6G<(2MWOy1_muPKkTHAKJT6y;+aq6Z>w_5cEF!S>u&Sht2veUDfXr7v?@9jTr=ChMi*~z&~^yJ}z zkZ2M@*2poE2q6j5L)`mLB5g6#lJbhmB#jnX+TC}ZFytbYO=h^x&<(NE+>#phUAuwl zY_y3$i2Jb<&X+aWQgqFIAnXeL?w&KCXi^DMql=6L!d)-uU2vTcHC~>*F-smEgzpg| zOb;ajh~wMZlO^G3ll<`AQeb&FH6(=I^1waL`}EEDu^zv#$3OJN&(Q|h0YZ)sCxC$u zRkc*g7a%X-;Y;04ed9bm1*t2bY5fTZ!}t0Ih1!u90mMJ|)jd7_Jt6zGkM#IbK!A(; zhhxhl-H>5I`q6Z4^!V`YbI^t9Q|Mvv0w37%Gj6x`zeA1wTPSdJI|WG{*AiILPn^qX zS=Vw3)?F%4EvGU=T2MfvEt=^-h(`jw(A1%{Of9(}8O$mh&=lG0YRFtQEmjN!;KqpG zc3EXqE0?6aZWPTl7XrdRtt~yxV?7Zb=^20~$J5L(bVJh1R;g^IdtzYFpQhTXm;Tw3{9j5suILW8N~KW;3&x6pehO?2q6SOEfmKQfm}8Wrkxv0F5p=lkv}bfOikv8 zIaY0w5)4^T= zV1pNQw?NnHWjX^~+$=F!pl|_x^q=i+Bq4sCE z6tviim-A0>C1zR%jE5u_sDT&0YUeE4X_y_e8#r_KfZXzT z(EokSC(%AazV7aGAqHp)xLW=htS$ZV2zXQ}3F11bMrGqpwSrk(9OnQb0dJf!87IV4 zYqi8&C(2e}9xP}E%Dp$SnmML2$P?e!N$5;$5vm8gqUH4$u(YzOo9qg5-r!!s3hO1N z4a`B6`ea>I70u*h-o~KUG|!IXa6nTTEe;{;mog6Qkdl{jIx{6rwTEST>CMLSTREAMS>AR7525.TEST ;; by Peter Reidy ;; Verify that CL:OPEN's :element-type argument determines a file's IL TYPE attribute for element-types string-char (type text) and unsigned-byte (type binary). (do-test-group AR7525 :before ;; Open (with variable element-type), write to the conn'd directory, test file-type and delete. Return the value of the file-type test. (test-defun writefun (eltype expected-type) (let ((dynasty (open 'collins :direction :io :element-type eltype :if-does-not-exist :create))) (write "Alexis is a bitch." :stream dynasty) (close dynasty) (prog1 (equal (il:getfileinfo 'collins 'type) expected-type) (delete-file 'collins) ) ) ) (do-test AR7525 (and (writefun 'string-char 'il:text) (writefun 'unsigned-byte 'il:binary) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL b/internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8b170fa38ff4f58b9062f3905323dd2e47c4e997 GIT binary patch literal 1888 zcmah~&2Jk;6rWwEjuXemwn8X2A4^abVY*QQDM?)rOg3Z3vAt{dgC<<4n`~kWCywk* z)q;ph1p=WJC5;+(fLuAZ+ybqF)H^4{U%&y03mlL*5#HN%(h!i4R{Q4tX5O3Md-LAR z7CAMqlqIFLy54BoZK<{4tZz8da;q(MS{v;}TUrKOdRNhO_TDU2N~0IX`;B8Wi*38+ z*h`YRVRx2l*Un1g=Owz{ZZu&qH3jNRxrvF~i|0oB^VBE@-u~BSDmONs8$UnVf3UkF zBwB=!MY4~gkB|fj5$~3p$ePSB<$STsWR+G}*4y&j2*e^=2Gcz^`GVxM*5#&s#cpCa zs~sW`;(g{u@|LQYMNRd#h3mqAchij(Rk;eG(E=l4r0WH}3!WRJ`sBH(NqI(7$nH+$ z1|hdI#Xu4JY57t zEf`rb%=^SsPzA}XLQQ2>)|qMPaEgjw24Q2tFj++uVZ~rjCrX)7)vC&QO|KYPE{MXv ztxYY8k?^|wg4l4f{)$;IM<7nqvpV}#>qdxz@KE5D(b)T42oZnBG?!U6;vPaK@{I} z42In0LnuCm(@7f4#GbG!;Gg0ly#weVpm`Z=r?s+t*k<$K@{tqRtAL&I(>MX6xKU+F zk%9^2My{Sg$dBd7$CCi{=BG7FovHeHwa`IT*9s~y5(*G$wA-i{AWtJY#-Bkk0zDsA zG3)*zoaQ4K#C;}`H2I76#=IFlI14u;i+^0>u<4D7sbXZ!h!M(a9HP(VF5wXoP$m}m~ zJH*ez4;=OXBgNjf$e#z^p}eN?w6F2!JU2y~_SHs5g0CiBZa9neQS|e>=L-H&|LnP; zXLAL_e(=5oGjQ>gqBCkT`9z78izd@)+2GN@J0_6qdG2U#n!(|);3D;32j?h~!w@!& zZczUAA9(HfZ3xt{SKxtJueBYiwG32O?6uCdRS8}i7&-Rp`skG%(*GKT zTLA7I_$P?xrkl0Z%S$!P)5%r?YNFq27?K-NW~pAKy6L&l{#b#bKFlCM&^txdWCf;& z0f`#W5Nbijw!j=myS0gr2)Jwnk!MO>Ipw({)uvtR*wRvKZN!n<_L9BaShJ-~imYmq Vp9y?ndi?D2$!_k*7o~%PzX46FB6k1) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST b/internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST new file mode 100644 index 00000000..e5d7b645 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST @@ -0,0 +1 @@ +;; AR7587-DOC.TEST ;; Filed as {ERIS}TEST>CMLDOC>AR7587-DOC.TEST ;; By Peter Reidy ;; Verify that (macroexpand '(setf (documentation...) does not use gensyms or gentemps. (do-test-group AR7587 :before (test-defun gentrim (charpart symbol) "Extract the integer part of a gensym or gentemp." (parse-integer (string-trim charpart (symbol-name symbol))) ) (do-test AR7587-test ;; See that the integer parts of generated symbols advance exactly once before and after execution of the SETF - i.e. that the SETF itself did not advance the counter. (let ((beforesym (gentrim "#:G" (gensym)))(beforetemp (gentrim "T" (gentemp)))) (macroexpand '(setf (documentation 'foo 'function) "Alexis is a bitch.")) (and (= (1+ beforesym (gentrim "#:G" (gensym)))) (= (1+ beforetemp (gentrim "T" (gentemp)))) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR7647.DFASL b/internal/test/LANGUAGE/AUTO/AR7647.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..89ee6a66b9de43ee69a5d4492646c475ea863053 GIT binary patch literal 749 zcmaiyPfrs;7{=e-rGF@ev_wfX1}7w3Hg0330@jP;GNpxO7G`HtIg)m3n-sR`9}{CF z#)GFdT8Ly;!*}qC7&-Wb{04Qlm`L#8X=k6A_j%smJ2QmXGt)w*zu#%Ky)N-;&u?At_IX`cO{ za{X(#`JVm+7&hP04ON*2IBI^KtBx@uizGlA;G$KV9X2zq45%^jDY&DXHeIVkeHmp; z*DS(}rxmHtbw^hxByd(YF*nNwBiv=OVRK9zcXl04wp8Wc6WrFrDJ>CBYDoz>qZ7t# zX4o#@cDb%i%7V0x>8>%>9X*t^nf$e(B{YC=BAS%8DNW)fn{8oUj>1frF+#80K&Y%p z{l;Go6FcP6UG`zf^4K_PQC>ovMn=}Ha86qjK>{-rP5Frk?sBi!M+=8|0X6pI%d4Z- v!R4cgw8KS3d=ba0%$YYC!JHV^;;afM3|me(6&;h2JFd-1coRO)k4C=%WDDLb literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR7647.TEST b/internal/test/LANGUAGE/AUTO/AR7647.TEST new file mode 100644 index 00000000..13c23096 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR7647.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7647: CASE macro loses on () clause - Lucid L211 (do-test "AR 7647" (let ((foo nil)) (case foo (() nil) ((nil) t))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR7742.DFASL b/internal/test/LANGUAGE/AUTO/AR7742.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9f8b4b2f825a9cd1da379d5f70d1990df25082d9 GIT binary patch literal 1014 zcmah{&rcIk5PrLDw}lqc5+X@8xM@OSHY~AN0c%WrU0z{fy9;k$1>&i;#Wq=J(;p^= zNQ?(hYqSu_u7>}?D`Mo})j!7n0Oz%!1P>lIJM+z(nQy+C9tv%0hO9Mqnsukzk{jJl zv)hrk8!frr=(fsLc^hzfPqQd_wT!jZnTP3N`%0wTs+Ky{ip;vzcBS-kT24QZakEu- zz*txScP^XBWbfUd8O~$d7*zXj&O-KXI-7x<^W!5S-arVI(HZ{@Arwae#WdY&7BS=6FUsOKhToMi3o-A# zJEEKF8jOaQ2ofU~Rd{v5b0tjY=QFeD_(&Y)cv+1Zj2@qLg+a{JTQXL z8JHJd6g+3d2?EN4KTiQ4dlQZcwUh5A*uQ$K@5~}n=%(P{d5>})zl-5^8 zvbStT3Zn4u3uY;PG!XWO0uc~mR3VgFRJDq1t;m$X5G2GDY;LK2+*W*0B%Zz|Y&d|B zALMFE4JabzEn2|L;mx!nrNq3lC0}?7`1s#BG;EVWbw8ScP#|wve>TZ?Fb#uCc=3sD zlSwegZNl=Zy;aCrhI+Y4X&w58`W$uGuw-%u#v}jc6i?0(U_?^>#DqT~)jT(hsmym; z@!Z?2+V04yeVmfFOK|5ExxPC%QI73T&3lJpEO^H|3_t@>&ku|MSvMfSd**d&GoTGM zmkb?DIKspxq1L9VS%m^D3edHYL0*t^heSW+PsNf)DEt`LlF2yo+@w?5c~&X$?$_0Y zV-Wl5@{X>6;mZMr1n)CP4%|tN63htnyS$CQriRW4#fI%iFQ~2;Ek^t#`ZRZb{u?1* BE|LHM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR7742.TEST b/internal/test/LANGUAGE/AUTO/AR7742.TEST new file mode 100644 index 00000000..cce5c8f8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR7742.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7742: ADVISE doesn't work on Common Lisp functions (do-test "AR 7742" (defun foo (a b) (list a b)) (il:advise 'foo 'il:before '(if (eql (first xcl:arglist) 10) (setf (first xcl:arglist) 12))) (equal (foo 10 4) '(12 4)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8135.DFASL b/internal/test/LANGUAGE/AUTO/AR8135.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4016e44920a02be7c51e365ddb9e3f2047475942 GIT binary patch literal 2075 zcma)7T}&KR6uz^tz_PIJwxr;s){$69CJrqY8oCb9|&+uFp$_-H~%GzDvTFuwZkqYow~zBDnuis#G>KS86yviF{!@BE)j zi^Q)hs-QF$mTGl(S!k>_msXp?d}CQyX{;{Ky23p0h4&TRq#qPyr8M%&Xt#AlGP~?n zn(mxnuevL9m3LnfMlT8S(sHd1mx&1=FJ{NavKPijy7RK7hSvTQGm$+%njHts-lO|m zxys0e#`f|AQ#E8sOfu|mxX3yNvgXy-8!bT zutGRO{7<~DyrU_0QP=!?+=pC`f5+=BYLWq|$y1cXx*{uRo%6j8*_;@?FisxbPizpv z-N>Y47{|BOCnausk^K2xDR%7ypW!;*3WD3phv$vduAaK9r*4JhXNZAoFCn{|gK&Wl zvZ_2E5|9_%;loe!JKmubsE9x)TtRW`bchMR{{@L2X8U$)PeAj;MrVerZU=Dz`Lw0p z(No_O(yD%}r%Evn%(pfNuAPbk?INTH9M)zBb~h`?ixTE;>?hoHtq)v>pa1RP)IT|Z zaHe@Mv|CMM`9Jkei;AvI7O_WCLDnW!YD&2xaI`5)jCHU?EDi&Z5f#~13X(}}$Aktd z!31Ct23muM%1wd2g4z(JY;L+$i+Sw%tx zq65Q|Z6u2rpW>J%)s74}<4~3bS>IuK6xpJoTb4xeNf5(0LtGNZ%hJe9gZY87T%r;H zp=eZtzex%5qjDJ)x(^h>oTbphfdcuB^@ASyl?~wW6MGhqyMXGkX39BTl^_v^B6A&6 z$?1+ZX}kxm?6atymm;P8#k&qV&m7}j23|a<-x%CdmO+)GtOh-kjI+op%ZjN>`!=2f zR%bqRgwb#|8Zb)qJ!*U1J?`Ojp`7Z$Ji6B#^?ifMw z$d3Vr{17UA6CR&~vtFpEqXiKl{0__D;b9n89o-J9aXVyw1k84*#ML#HSz-JdnIlLv+Q3cSg4LTxd8PLa2E7QO%B zKlJb6=$}!bw|3C*Xpw?RQHwS;Wz}LyP-9}4+Rwf>lFd<=KN>!i!Ry~V@V4(}&59h4 zpsTNZFJ5))^#&4Ogyu3g?~|tc_U~W5Q;nXhGqJDZ)yM0V$FStVeS5vKeFc_%s}y`I z_zf~p-5slqfYM-Jlu}nMoZsFL(r?DiYQ6z1Xw3qUsiX z15r@j$r5`F8`fnxIeW&S29EH_(6B^RTE^`~!9{lYJi8)-G<9^ZB;!S3b%p?=6PlKi z%_%2<1&hFvaSgcf0##L=rE{R2PztgsE6~IXh%IV1ouXzx%O=?+LTX_b_)>IE_};Kl scPlHdFxOZdZVJopoI77zbcHn;3sn(xo9lNgYw?qUxh4LHvj+t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8135.TEST b/internal/test/LANGUAGE/AUTO/AR8135.TEST new file mode 100644 index 00000000..da5f25ed --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8135.TEST @@ -0,0 +1 @@ +;; AR 8135 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR8135.TEST ;; by Peter Reidy ;; This code is adapted from {ERIS}CML>TEST>21-STREAMS.TEST. AR8135-test is the full test file's make-concatenated-stream-test. (do-test-group AR8135-group :before (progn (test-defun input-test (astream &key keep-open dont-test-for-eof) (and (streamp astream) (input-stream-p astream) (or (subtypep (stream-element-type astream) 'integer) (subtypep (stream-element-type astream) 'character) ) (equal (read astream) 'hello) (or dont-test-for-eof (read astream nil t)) (or keep-open (close astream)) ) ) (test-setq test-string "hello") ) (do-test AR8135-test (let* ((original-stream (make-string-input-stream test-string)) (astream (make-concatenated-stream original-stream))) (input-test astream) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8136.DFASL b/internal/test/LANGUAGE/AUTO/AR8136.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d4b214aaadfe140a1f6046956a47fb1d713df07b GIT binary patch literal 1458 zcmb7E-%lfT5dUrqy%uQGZ7Sl1yZZ`q;r86dQY26{X4!s$Ubnkte^@awhLmC(IZ8?~ z8kHCx^kw6T7ccwO@apsF8+w@~Nj zbI{!1+I;_cnqQ*oUbnpiFN=$yE)?hIi-i|+BP*({huQu$X0iCfTrr=|jhvm_7t$R< zNQ3lIBnU~9DDl7W(z3&BM_DQBOfl3dll^1gi$gDpYctFD#5vmQ>?u3Vcbhxd&YgWC z5aNIC#aCQIbIPXS-xEF-#{9cpvTP_dXiZ&ZBoZHF!R&(X#Z+rCUsxa~_mfA22uor* zf_41RdRP%ocgfF>Dv^3d5{1~?L2=(rg1mU3+Lk22Bi)w1_rQ#ypn~>4j}LlpWY1Y> zjQ86QAxY-wiYT;B-%9n(6sW%+>vzr6V?vHwpPH#kL`cHxgNgbCCIEk&kTF8~?S|BU z(74oyuyo!?yq>L(Llo2w&wqv(|0f6lye&bNek+Z{e(6ohnrW2E$iA|s8YP`s%5oVj z#;PqxVmuKUhS7?$raIc1Vll_HU^H4V+nBv!JFFUsz=>=)d`)Mn;ntKD)2iAs7b3#n zqa9P`qtOIUM3dmWVmlU7tNDv%!7)cipLphYI*L1yl9^?hmSVb2&2{AH2pk!cRbxX5 z?1<)j>HJ@IEHO+7AHu~-t!y!%%8i(GqZeVhG(Yu4T)#skV}~Kz3WbMzelGI)hW8Y3D?;c zZSRIR5!w!C5b`JgYyTeZ)-??{bpjp-n;P)1mmOxQy3I%77@rC2JoUX?ahbtXS$M|; z7iaGR?HuON9suVM>d5zmoA1FDHTw!(ptHAVffjC3{OyLh#aBa_848Nxvja%-)%@An EpNHd_4FCWD literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8136.TEST b/internal/test/LANGUAGE/AUTO/AR8136.TEST new file mode 100644 index 00000000..0c92ea5e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8136.TEST @@ -0,0 +1 @@ +;; AR 8136 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR8136.TEST ;; By Peter Reidy ;; Verify that a concatenated stream is readable even when the first ends with whitespace. (do-test-group AR8136 :before (test-setq stream1 (make-string-input-stream "(= 6 (+ 3 3) ") stream2 (make-string-input-stream ")") ) (do-test AR8136 (eval (read (make-concatenated-stream stream1 stream2))) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8190.DFASL b/internal/test/LANGUAGE/AUTO/AR8190.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bfbdc31c0f959f72e2517e405a854f4259614060 GIT binary patch literal 1093 zcmah|U2D@&7=Dv(UF){c&5BO^2;y#n8S9)f=Z!HvUAv|^_2dMnC{nu47Ux>JP7qN< z1Q8-yKW2{Nm4Cq7q0$Sl{5SpqneR#G{JIcAa`L{<`}I8U>B8WW?dW#%W~;GUYwOL8 zPHUs1uQc2GdUK;)t?4Uh*YDVrk-K@zE>4}z?D2l{RNJ*mr?#x~joSKh<@O0Zb4IsX z?Zzq|=H~GC^!)7X{K->OdvccN^t1gpW^R6ZW_|`^w%=_ksU`qap(j5{fE2_ad>*6> zPCRbr3Jx({t3-^j8wLrS#q>SG!eDGh?=)NHYVB5SRgQCW9Tb4@S&+#2uFVV74PPkt zm67miFj{cUGLB{~5Kt34S!8x44B{4>%bb~pcboACSpWSRz|qT5Dj2+gE`C)%q^b4=pxby%HN>jQ zD8MIljz1XEl={{#w(C6Y1M82dR*YcJ>mT-A9G7_!p8yyE=ryY8ZavjVff^5A1&0iq zy4ix9)683L)*;M1UqFky;2G*55;$hq7Ps>zBiv_5fE_Uy_bz#ylvL$k1gC}=jwM7g zmPFDtgD^&!Nqt`Sxe*)1fDyxTFPV|uGX%1i%KRllA_gD^B=ZB3&exbIo};W}arygF z7PWoGi2IweLXp0Q=u7{a$+kSwuOx=AigYAS7a==(?Jk3q@itZ&jJj%}{&82 z1)p-vB+n{k;?Pi(KpaPtm=p)p3~o{ii74YO%bGit6*MNVlsU`$ZgJ+#^!D}-qQXNT literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8190.TEST b/internal/test/LANGUAGE/AUTO/AR8190.TEST new file mode 100644 index 00000000..49e7e2a6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8190.TEST @@ -0,0 +1 @@ +;; AR 8190 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR8190.TEST ;; Verify that (expect-errors (file-not-found) (open xxx)) fails if the file isn't found. (do-test AR8190 (expect-errors (file-not-found) (open '23april871509)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8207.DFASL b/internal/test/LANGUAGE/AUTO/AR8207.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f5e839b3ef2a722c7458249c80fe74b8ad4e2c00 GIT binary patch literal 887 zcmah|&rcIU6rSDEvQS#Lgm`E`R}7bpOQ51wFeJk;g|*w+Iy);g9+Z^DHWu3ShlwE& zRNrk>YhF{UciN3k zTidBOwN|~;EPL7xuWS3rrubkTqWtXA{HSy3q}=qj+TOOtI$mpg>&+c){-FjN&1#JY z*(^`*FD@)B-n}Ke`c5yD#@3}ZVk<>Z>pbUEAGXj7LA|Uwat2)CDGjgVd z4FU^T54wS`a4m-GU>f+TjMlCtjxI;J2`L>xhSm*=nM=6{)OR7~lpKZ&vdnKx z3~WLchQuuzIhz(7J(OhW-)?5>VLYOQBasnqN>ay^+SIUJR&<#jN$`d-9g>pKuM3dC zSLd&otV93^hlI0HkAn>1r_kEuK}-yW%oS6SODQIoRu@V+!St_K1RXpW6UL{w5sGEQ zRb&^6u@@XGTBPbA>`$T4tDgUBJW*(=rMCo6Kvqwdq4Rt?g{_e_&gy?hT%=s2$D>1z&<=Vet(_ fF=W`d!rw9(rqFW2xVXmoJaKJ?!%6UY=HlWPajXaM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8207.TEST b/internal/test/LANGUAGE/AUTO/AR8207.TEST new file mode 100644 index 00000000..b4a962a0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8207.TEST @@ -0,0 +1 @@ +;; AR8207.TEST ;; Filed as {ERIS}TEST>CML-IO>AR8207.TEST ;; By Peter Reidy ;; (LOADCOMP 'TEDITMENU) without error. (do-test-group AR8207 (do-test AR8207-test (il:loadcomp '{erinyes}library>teditmenu) t ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8297.TEST b/internal/test/LANGUAGE/AUTO/AR8297.TEST new file mode 100644 index 0000000000000000000000000000000000000000..1ec2b6c341695b8f7eba1fe9ffef83fd0f39d7d0 GIT binary patch literal 343 zcmZ9G%}T^D6oupHrh(at%e!nA9jqHGl}hZSW1v4n8r_dHm0)S5(^*vUvE29`zK=l|d7JWb8yA8_wh+Zx>hU7_w{t(j zRt>5Lp>#D`%9HAKJwn^Tp{n7zSG!lJJ5ykE?WH_t(CTK^3cFS34QfAlFMW4-JAMf} zb9@Y@3U(aV;3}`tt(pmT67w=(hhT#2IYSF{ftHeItQ18?bF`dtd)*=5U9*HfrZOpV t2|lZN=#t;J=j3L=L4Fxo{#>2QwY3+8m%+87&jFQsQ#?m(ZATdT_ zym;A&l}L6q{0FZ@Ob`Ac{{gwD0%(JkL8jK!K;4u4t{jcD+&QD6M|4-R~*Y zR!8Z!`kit`sX|JD5d3|z2nQRX^{Wu@0@<3?q_(hzj^x=2FE{pf_VwxRL7X}CwyTWQigbf)qK zE&(;NPLUkGm?EZ2t`j6Iy|R=-C&!`vL|hgazSqtQ(rFV_e-z}+_-sN7ULYIRE{rLJ z&UO)+eiynX)lQ$shGq=hUjzNnjQvDtPImB zqqrF2I`PyMy~93)Jiib*)P^B``h@6ZFoI$+;V;Bi&1Q@mm#*kZ8v^NHvKq1Ic#RiT zp*vEdw1Bl7VT<71D3Suj7H6OX&KrPEIFuCUAQ`m{FxN)KftL^nl$g10Jc9+%@l~-n z@}GAjoUAAtv3dwkC1?n!deWQsZ@JDquXKCL!U0)Os@w2W>?rl-_&tl*!R=eF6Kb}4 uwR&@R_JiVgzq&_4_BjnuaEh;R(({}$qFY{6l)=^w+vL=nLthrp&wm4a+7B-P literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8301.TEST b/internal/test/LANGUAGE/AUTO/AR8301.TEST new file mode 100644 index 00000000..cc2a99c7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8301.TEST @@ -0,0 +1 @@ +;; AR8301.TEST ;; Filed as {ERIS}TEST>CML-IO>AR8301.TEST ;; By Peter Reidy ;; Verify no udf break for unread-char, peek-char. (do-test-group AR8301 (do-test AR8301-test (CL:UNREAD-CHAR #\Space) (CL:PEEK-CHAR NIL (make-string-input-stream "nothing")) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8319.DFASL b/internal/test/LANGUAGE/AUTO/AR8319.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..98483055dd7256dca251c12f644dd1b78cd8a8c2 GIT binary patch literal 790 zcmah{O;6N77=GLC7oRDFKw=0^NW3(5&5;tKNv(sM+hbdR?^F zY@<%I*RDorPvGdK!1CNck~B9zxI}{tI7z#QSHm**0|)5qW~}ra8a*L^lN%u2Q`~~jHeCDrz?&$ zXRcwo;u2;qI|8ArfuUwZ>M_H@+*&gk;UN>Qt*h9%U_0Q%QBKM1)zv9^2MVkiNfT+Q!K^XIy>4$tXz3d`3yjs zk%iPY1xe2KnTNS2ZCD{=g#Oi_RCy@yi9ZP~9FS}FbSN_?o@cM54AG+;l|=4LIyEI+ zXKjyo%bJtKdCZV(2T9`FJnD4O>>-{-dpqKb?xOm^_3x6{;T7@Vw literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8319.TEST b/internal/test/LANGUAGE/AUTO/AR8319.TEST new file mode 100644 index 00000000..3fa36acb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8319.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8319: FMEMB not on UNSAFE.TO.MODIFY.FNS (do-test "AR 8319" (member 'il:fmemb il:unsafe.to.modify.fns) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8458.DFASL b/internal/test/LANGUAGE/AUTO/AR8458.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a1aafdc7c05cc86299328998c48229b89de50769 GIT binary patch literal 784 zcmah{TTc@~6h6DXa?O?yjK<4^#0NJnp;AmKPvbJBg=H3JXH$t!q-<@ILYrPpjFA{0 zd|IQ0NM<$s2VW5*5B?$l0nQYo1Rs2u%$aY_`Of*yIRi*Mu^nW$cH50+&_S(!uifvV zTC0P)t$wE(pqj+dOWS4SRSDbcbIaLL@6u1T6KwZ_9mM-VcW3*>eUx27xZPb2TdGk6{}m7Lu!XaM3vm@fL%=4F?PL+!OTF5ZU|Wom6o zX?T@@p8n0E*fkL*G0W!`^Kg8Wda4TeT0dRWPWHh6wx(AmZ)CJY#rOem`V3&|O=?oB zpM0m%{yA8GM0mcE&8rA7R-Dnt~C&b6_rfIu$rL1bR zN|>%VgjtWu5}~V}smG=0jA>(Tmn=rO&t%c|P<7JV@;KShwSPUhYer+SR5TJxOQDk{ zXV@l|>+?;Yo3W80Mi_J1A8bOBjGLHlSwq}2BiRKbd!?DFI6xFv9gMk>Bw2LX2Ih_` z!1fs<^wMM^ZCT>ef3?}zBNyz^SUfAk6T?*Zsrn%&22wAHzSu)1i^*g%>A1ea`zn&v~Br^dMGIbxCdPHtU|#k{aDk zv)hrj8!f5b=(ehkw9Rm7Uo|Lxy^7TJ=|{68=8cnT%h~EUHOcBa?b_C>2h!|A2{l`F zk8SdK_Pbcf>ep=l?a3Er<_mK((<4`>C!E*-fGYH(&oF=p0t83CC|lUH zl%l3%g`g6agI?e#nHR-2F%A68oYZMF70-F;c#)mmHgEvJ2R~V~iE3#E368l#E)~4@ zM>V39nKiV6flvNoiP*Wok0YATEiS<6Nn$^`z*qNtjXT?e?zc65V=SBDV)Y%5_XIba z&0b`<1mT{Eeez(z;#E7nEe6U_32j4N1GN@yJ`Hd!{%67yaj7|&ENH7bf~lu8Cs zbj>XDvEZYBM^+88tVM2>RYaC`OqC^#A!Nmr`60%ckyT`=s|v-IO<4@;fG%!sniekc z+`ko;A%|&UI7|tnEV{IeDK)5K*jCxLWZ@QTNXdw7Dg)e&*{0#PZN zT`lnMSx&nnO&y>qX?u&k=bBXCyMBrhc5puz91Fk;T<|$K=9%1Gm11OJmgn#E2CBMd YVTyD!Oh;u*`H5{`TnuZhFyn-xq}XBV?W?v=p9lAI<)-nwMD8sp$1_3e&nh<8#I9MV~{F(j0nqN;gNQrrNa-wh{eox zX$>z^&{Ka{6uTA%3C#2JkLKXyIN>V+->PRN?Q{>Ge=q5qqf=vA`~`paD(KKLL8xcdVpqBLIihuM?YnQ;IMJkOnxfmB)M4Of3U?Jp2?) z8^mEtmQrc1V76paZa%Rj!j@e_ACUIP41xt&F*y|;m-0#9f5P2z1zpp%e>;R@M8mOU zG#E=s%cBP6+~KC`ESyMkRjZuMdJ>+Z{Bsk7v-%w*0FVRNK4!W(wQCtA$^}BVB5_ML5NR dn%5-RmY^KlZZxdgq?o6kBWN@MpYL2;{04eT?3Vxl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/AR8470.TEST b/internal/test/LANGUAGE/AUTO/AR8470.TEST new file mode 100644 index 00000000..104bab21 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8470.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8470: VIRGINFN calls u.d.f. PACK-IN- (do-test "AR 8470" (not (member 'il:pack-in- (first (il:calls 'il:virginfn)))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8491.TEST b/internal/test/LANGUAGE/AUTO/AR8491.TEST new file mode 100644 index 00000000..ae14d4b8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR8491.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8491: Arg not a NUMBER error when format ~:R given RATIO (do-test "AR 8491" (labels ((find-il-lambda (form) (if (atom form) (eq form 'il:lambda) (or (find-il-lambda (car form)) (find-il-lambda (cdr form)))))) (not (find-il-lambda (macroexpand '(prog1 a b c))))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR8575.DFASL b/internal/test/LANGUAGE/AUTO/AR8575.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a9449777ef78a6719d20839241506a9151798e83 GIT binary patch literal 883 zcmah{TTc@~6rSB)D7275M50025J}AHG(f4=nwSjBl(uYVadtM?2NOxV*qTC{UQCRU z7$1CEqlHLzHT(x(5hD-&A^!oMZ4DAM@oCOw&UeoDozp|1N1Co^jqPTwZnu<1x6|x) zl&wZfX*as9vaM`ETzRP(oW9BtZ7p$sVZ=O_DYxv+j$Khi*KSufU))v}?kS|%s@1_r zr@_6GSz5{@Q;Cr*G4%o3e{0g2`D7+FpBOnkJdolIgisls_|GsxaTGxAo)cFEH3iP* zb&44&Qq}FbP6W7M%cR_O#ut@NqlxSGbGz=-*={2VA@_q5$y!Vkd4sw8(rYQ^zIR6R z46g$Ty9j+Ck60737VvtK(9r9)zJH2#q3i zQm=r0<{m#qXyVOKOsXDzXJG&At-WJE5b9OmvVtr@!Cv*tk5ImP|p5vh?>4 zVW?g-FysvfB0zpjrJNfa8VXRJg$rU11rYLrzJjA=010Oe zUL@j)-%PVOr|jHjJZT-`m;Uh3h)DTEST>MATMULT>AR8575.TEST ;; By Peter Reidy ;; Verify that MATMULT-N33 will execute without error or crash. (do-test AR8575-test (il:matmult-n33 (il:make-homogeneous-n-by-3 4) (il:make-homogeneous-3-by-3)) (il:matmult-n33 (il:make-homogeneous-n-by-3 (random 100)) (il:make-homogeneous-3-by-3)) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST new file mode 100644 index 0000000000000000000000000000000000000000..6c07bd5dd9c414bbb82ce747391ae88061b0e6cd GIT binary patch literal 2445 zcmah}ZEw<06vkzXuF3r5%QVp(x9D!gvcAv)ON=4Nbje=K#Kf-!F3_ZFp)JVv)BG*| z7|*@sLR%>9m)@T9JkNRUC4FCsXc)l}osT03ox8D1VKDW2k>h(uAQ3v5+AfgR0Orw8|W&si9j(a#biQ&b|#nAd!T`zqoU^JFbHg( zJOs8A(mq5!L?a3-sZ}xL6f{;0)7nstM~8Og%xFT%1|h#8Eu{`zv5Ey9w}@8J>J443 zY1pjAN!}1;MuU5B?O;gr+lE~?jfSdOwA^3`>lMSQn>AIVWv!lRTsR3L_~S$)5Pe>o z28UpVY#O}tqW`OL+M(kWsBj3cQ>gF{Osm$gs_4sV(8c_HW|I5HB{3uEI_YbubGB!$dH~*fTQ<4+huch+%uO>fCwA@ z1yskS!No}x*rz?ePnCh|+Y#7aAHtsPF24f`j)&6@X?P?NbW0?p(FEpTRO))wqDobh zC2}`)BM1K?WoElms&ELgp$k13NGie{qc8r?IgnH==;ErSayxf@Kj2Aqogr=n<^b7P zT?ca}0|+n@7J+z0*DUkYQtJ%^3{9=+vb4XyPd=v{qznO&k1$w3SY%nkzAZ0@=zdHA zZx}3^1~5S3R(w;$jR4~L5fFwNv-y}{$#Al~CwM=ZD8x@L(D5QVq(K~CDzRs;v{NGd zRKgQJJC7D$>o0-ho-H`$-$k{<(n06qs{Ql!=BjyJI#>#RDQVa=gKF0PxGfNPncGo2lt?7R55GCUTBm+TN%5<~epX#fEgVoUBx zA$LveMXnh4B;&4el`MBx7!C^)ITg^gBDiO3+~ZuXTo`w)i1)c-uL{NTxy6(CkQ?`P zVcdM~vb;SZuNA627f>;ZC&I8)dnzn^)wT}D%*NxHBq`652ASPETm;{wvKM{{9D#vv_#` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/ARRAY.DFASL b/internal/test/LANGUAGE/AUTO/ARRAY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7c0c245408a056c9174c0440f7e1813940e87dd8 GIT binary patch literal 2769 zcmb_eZ)_Ar6rb7cwRdf=T%jI<1-4cG3L{OEXI*`3WPW7+ZCU`p8y{mKE|vW-`J zG<`?glN)Lib4CVpseycINO8tfV?zTI4=Wp{5bUeBVer>h4PM@TqEFol&Tt)~G5+XA3ju%1^$4EG8S2Sj*rWQ9MUePP~VJ>Pi zVc1@waifyYj;d~If6B$_>>VSN5bw=`zbk3#PSi5J6LgZ+dsBsA)KvRmYFf8JB!5W- z)u~tTX|}EPlhY^b4-q2IU=5$8FZR-zedPS-z0%I+<&D(m`k*df_4H;pI7~>8+v~WE z@paq}SNxHB>?md?)8g+Ua26k`X`<B=B@ZF)UQnXaEZ%~r^jz{2FG!0sv8 z3t8Wda(#h&)mK`xYtwC_Mp5u8sH;;xdaZv8P%*WFg!vA+lis?`$M5J2p?Lu=zx6JKPJp5{pW^Ruewz@3}J!W?z zBGt2iR0k~xEdZ?snh#nP+%}C7U32sv)i#`@4Y!5Pubb*bf5I{15}hC6SP@nyH?V-b z2yU2$h+*57ty)Q^FX=?&5D@Akn%S@N{zQbqRnz$R-8WW)ObDyOd#W98pASK)y34ZT znuG2+%&I4C+c4+cgN))BgR!RDlhw6^AyTnA9L~aG1azyfpWklSGtBNocmW2)m4{xE zg%MP?7$L%zAS`E10MZSV;B?E5c4N<9JX-pVEk*BF;mvTa^a}X=c>zZ`og8LM z@~o+gh1*$pH486e;q{P8o`N0q@kao?qwsdBHgSJr=pJAz5T1pt3}|XB>S&G?ue{~( z{e;7Dm`HV3%+efO4LQV`5&WDh{VU))Q=n7&fwdsK%R{8M#Mm1G4v3Ip5wcE%C}ONh z0G^vebzFR literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/ARRAY.TEST b/internal/test/LANGUAGE/AUTO/ARRAY.TEST new file mode 100644 index 00000000..1f762e7f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/ARRAY.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: All of chapter 5 of the IRM ;; ;; Source: IRM, p 5.1 ;; ;; Chapter 5: Array ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Array.test ;; ;; (do-test "test array" (and (il:arrayp (il:array 5)) (il:arrayp (il:array 10 'il:floatp)) (il:arrayp (il:array 10 'il:floatp 3.141592)) (il:arrayp (il:array 10 'il:floatp 3.141592 0)) T )) (do-test "test elt" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (equal 3.141592 (il:elt tempx 3)) (equal 3.141592 (il:elt tempx 8)) (equal 'a-litatom (il:elt tempy 2)) (equal 'a-litatom (il:elt tempy 72)) ))) (do-test "test seta" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (equal 2.71828 (il:seta tempx 3 2.71828)) (equal 2.71828 (il:elt tempx 3)) (equal 'Janet (il:seta tempy 62 'Janet)) (equal 'Janet (il:elt tempy 62)) ))) (do-test "test arraytyp" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (equal 'il:floatp (il:arraytyp tempx)) (equal 'il:pointer (il:arraytyp tempy)) ))) (do-test "test arraysize" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (eq 10 (il:arraysize tempx)) (eq 100 (il:arraysize tempy)) ))) (do-test "test arrayorig" (let* ((tempx (il:array 10 'il:floatp 3.141592 0)) (tempy (il:array 100 nil 'a-litatom 1))) (and (eq 0 (il:arrayorig tempx)) (eq 1 (il:arrayorig tempy)) ))) (do-test "test copyarray" (let* ((tempx (il:array 10 'il:floatp 3.141592 0)) (tempy (il:array 100 nil 'a-litatom 1))) (and (il:arrayp (il:copyarray tempx)) (il:arrayp (il:copyarray tempy)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/ARRAYP.DFASL b/internal/test/LANGUAGE/AUTO/ARRAYP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..74b55b95a00e26aed2b9502267c13d20286544b9 GIT binary patch literal 3481 zcmcgvZ)hCV7Qc7)PtyEP8ciE(I>t8Lu1-j6eTl7zlgVte?e5HWX4bf$>Nc5l*K9Ij zcjGgPwbXwot94r%=eDm8M0xN;u~c~Avm~IP2qMV)BJX{B2qGx-gQ5?f)N}6LZPG?~ z{SY4PaPB$x+}}OFbMBlwTP2}KwS=sBv-A0aTa>+p^87+sp7x4z$y+E+y7DyG<)<~% z(w`YuwZnr4_B7dRW+sbnw(L&H&VpN-$}Zk3?|DF0=ZpCQ3`Ryk{lor!`}W^=|6o&0 zwG#sEf36wXKLl%r2Ai&3T%sKwA!L%Qpx8u62MG}WOr<00=(eN8;t5?b)TAEutA3>s zxF~5`xBN=yUb*beD+Tunw}5nJON0{Qzg}sKr47xAn}&auo}?}Q=}K$dP*OlmJ*X3@ zv4(=^)USk9%ThBba&f8s6d}R;F^IqCJ~~7{oFnYYA!$PH?WCbX2m)I!v>qn}9UgBX zO171O@?L7kupdIZJQC#k>h4F^jWp+V0 z8yC#gdN9Zy(r{T9a@nXFFNoovkc$Xt<@=G8n_JccQO%vTx<|s)I1p zbYQfyN;woh2MG#=Hz=)=T4&On-;g>5j@1EMApZYDYHGV|2YLN>E2*6vSjmUNXL6VB z$#Jm*R`bCfSfx<7nmf%CUCq5TF@WmH4NB0JdV-qj8*LDB(5xf3@yLPOgD{|+)!rN= zg^wZ=5iVtsIX>>LQGHo>-5OcIzy0@K+iI>O-$A4{|6FBTR5OjSICdUoTs6iLx}}W9 z!D1Y=qf!&wB(=cP3{NXOjqrrv2|}yujB2W*jVqS!q%CMw8t-*sJ7YU~QljfU95c$A z1MM);ExM$Z&{ZRyQevi+w4;m$I@qQ_C$zq{sBT%NrI=|am3E?mE?CnNRgH|o?c8@W z+F+-Yl88I1V$qx4~#y< zcA$12+leB=22jXs7YK5VW0L=JO!7U)B=4~Z&b=kX8!S>}Js#U~lx^L`B3oHx7-oab z95on#%ROx1kxGCy@H5+u;%nd&gww;T_9XWV%!{chA^L>zcA>R$A$<$gX{eodQJjAO zFYy|r%(&s`V}LGw0_d%94AKVA7@FQ^n^C+AGod4C)8R$@t1$irgMs25L61KR+gYAA z={cBcj@=05iKzk`ME_%=xJPRkF|<7*JPr%-un;3$&|gKef8vDbcS5`?jBg9g7vcq= z)*x6}fJ&bf068{MHHfshqHYg6rYkp;?4d0ZqHwXI`vy1a3dAjJ$%B96p*`1ZA7v?6* zd2bE_3B1DaXa+K`&7jcuer#k7+CIOsl}B2tL3)3LFl!LFW{4w5SK%A9R4(S{j)PJ9 zR3PvZwzNb-aBp=Gzj8+*J9}&@i%i!wUPx`N@e)eeJ%k|6ivkBMW53eF({kLyJl~WQx-1qxy+k(EzHo1yJ`J%5mGJEu%{V&G1D#pr zP7kda53_?1Cv8|4Ao<0wY~um)GbaPF>r8V{B&0`vWW!J0xN-)rM4q`)es&)IPfbFG XOUK!8|ML&W+rOqaI+OE{UAy)hZ6(X< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/ARRAYP.TEST b/internal/test/LANGUAGE/AUTO/ARRAYP.TEST new file mode 100644 index 00000000..61a074d6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/ARRAYP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ArrayP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>ArrayP.test ;; ;; (do-test "test simple cases" (let* ((temp-array1 (il:array 5)) (temp-array2 (il:array 10 'il:FLOATP 3.141592 0))) (and (equal temp-array1 (il:arrayp temp-array1)) (equal temp-array2 (il:arrayp temp-array2)) (eq nil (il:arrayp -5)) (eq nil (il:arrayp 1000000)) (eq nil (il:arrayp 'a-floatp)) (eq nil (il:arrayp 12.34)) ))) (do-test "Test lists of various things" (let* ((temp-array1 (il:array 10 'IL:POINTER NIL 1)) (temp-array2 (il:array 20 'IL:FIXP 2 0)) (temp-array3 (il:array 1 'IL:WORD))) (and (equal temp-array1 (il:arrayp temp-array1)) (equal temp-array2 (il:arrayp temp-array2)) (equal temp-array3 (il:arrayp temp-array3)) ))) (do-test "Test go on own function" (flet ((temp-small nil (il:array 10 'IL:POINTER NIL 1))) (test-defun temp-fun nil (il:array 1 'IL:BYTE)) (and (il:arrayp (temp-small)) (il:arrayp (temp-fun)) ))) (do-test "Try various types of Litatoms" (and (eq nil (il:arrayp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:arrayp 'A-couple-dashs)) (eq nil (il:arrayp 'Numbers-1234567890)) (eq nil (il:arrayp 'il:other-packags)) (eq nil (il:arrayp 'il:other-packagsNumbers-1234567890)) (eq nil (il:arrayp 'il:other-packagsA-couple-dashs)) (eq nil (il:arrayp T)) (eq nil (il:arrayp nil)) (eq nil (il:arrayp ())) (eq nil (il:arrayp '())) (eq nil (il:arrayp (list))) (eq nil (il:arrayp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:arrayp (tee))) (eq nil (il:arrayp (nill))) (eq nil (il:arrayp (temp-litatom))) (eq nil (il:arrayp (temp-string))) (eq nil (il:arrayp (temp-fun))) (eq nil (il:arrayp temp-litatom)) ))) (do-test "Stop on arrayps from system functions" (and (eq nil (il:arrayp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:arrayp (second '(#\. #\k)))) )) (do-test "Test other datatypes aren't lists" (and (eq nil (il:arrayp #\backspace)) ; character (eq nil (il:arrayp #\*)) ; character (eq nil (il:arrayp #\.)) ; character (eq nil (il:arrayp (make-hash-table))) ; hash table (eq nil (il:arrayp (car (list-all-packages)))) ; packages (eq nil (il:arrayp (pathname nil))) ; pathname (eq nil (il:arrayp *random-state*)) ; ramdom state (eq nil (il:arrayp #'cons)) ; compiled function (eq nil (il:arrayp (copy-readtable))) ; readtable (eq nil (il:arrayp #*1001)) ; simple-bit-vector (eq nil (il:arrayp "twine")) ; simple-string (eq nil (il:arrayp (make-synonym-stream nil))) ; stream (eq nil (il:arrayp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST b/internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST new file mode 100644 index 0000000000000000000000000000000000000000..49dbcc4c48e1dd0ddbf82a062ca4af4b6f04d869 GIT binary patch literal 512 zcmZ8c(N4lJ6fLL^TjG;Ha04&x!xl)87)MAdZbCAFY{lqfWyLMdLAIiq#((nJud|nE zM4R09^z__wPdyKK1pQvW4_Z~)_B;r(TqPhYc=Mx4{5}XL@q9Fk{Gsq;F$_ZlG+890n zeJL}o9KCjai2surW42{cStRDLXr*MiOrf=(q6NQ>D7I*^&2!k(e#iPFM5QTaGdmWu zxos0%honhP$k7!ajX62qQMd^b&`Uqyi%qNs5|H2X#ZvBm(cQxBZIH(~x~<7rm$f4?Mq+&M zsYVBpv>N^gUlAh@{zLu;csocW_~6q$_q*qO_xsK{JxILJbfmfaZKr8>klXd!T_4rl z4)WY?r)r}b$I)xep!iKe)i!6J%@3P5UaB3t;@f+Ob!~62^6CkiUqfoU<1~4&y2`K1 z*~P`|!qV(;PBrx_w*S_wX6Kf&a|^S>m!~H}#sz>XT*Su^Kn5fTkAjTMu*sBMQO62V z%UBM3VUXfp6wAak491@#-)$>R`@n9-cJ@6G0K!i}DrXUm6%7&|3vY#V_%RqQ5@m~9 zQ}Y<~mFy~g+>|43KQn);i-QtCG!VB=+TJ>;~m_AJH@XN2%;cr0=y iQyRr8!^$l|dXZtO>Si<&r*To+mcejz7rsngUj6|M@bC5j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.TEST new file mode 100644 index 00000000..f6178224 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "AR 7690 - Shifting negative bignums loses" (and (= (ash -100000000000000000000000000000000 -82) -20679516) (= (ash -100000000000000000000000000000000 -90) -80780) (= (ash -100000000000000000000000000000000 -100) -79) )) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/BINDING.DFASL b/internal/test/LANGUAGE/AUTO/BINDING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6b3a08fe5d1242cf20a4fe15fafe8037e1b481ee GIT binary patch literal 1961 zcmb_dO>7%g5T0Ep@n1}xG>xl}G^>WH$Yf0e2})CO*lyOblg&EaT~i7NWbAcp#j!2_ zL;^%rMFK8cfm>Sbqpi3gam@))ic*PQ5C;yGIKq(=haR{fgu={j4QZ1I3FYuKo_X_q z-@JLV&mHJ}T~-CTwq7q+tcFl)x9aVdP^>kCX06@GTS5`z!h3Q?SKd!a@>1g5RLI!1 zlW$nLmQ@hUw$&`;-kB7p&I(e!QLf;R*;#a7nVX)TdwC`iN=k<6vHd4zcJ9o~+|+a; zv~%Ys7p(z69`2I~0z|rLPQoKNgPGONjEI-@z)xhq`1^RXRCYvKwXOyj#pSrF)Cq-70+W?IM41cw~U729z0Q~^>%lQ%a=v~p@x}yHwqK7TR z>0OzCD^ua=Xos%yRaYhGs!*q#Zo3YtVf;u}Bl7<=@IHt4yOmBUT8;uAac%{mkd)`=DEEY zW+u+UzAy{=Xk?#>E4rT1#Z1;*$(nIr2m$?ZNxLMvaU;%fb_Zsj{sh840M56KYOXNO4H~5;Q zr=|0%Vo+q85^z^DQ{;Zm2FcuJN6FZ1h)jVUBl8xf1}Ih17hLQcEJpEj9%k0VJnvz6 z7XyDHCW07*&|`q<@VkqGpIj6?bW!k~i-Ox8>IRjW)Dd9Fl18AbELLTMYwYNoY-olZ zOJIT@X=z(v&mLznx87f|Z@q4#sjgq}QR&mDiz>Mf*%+BkHcIAQ&#QXogclt4yohVy zYc~j6p7(`kI@s?cMk;=pWt*8p!NO}S5P}uls zCX6!S2o>;`V<(#B^*TP{%~rcubf5N(T%(+OyJ9sbg?!1%uL*^k)vTUw35BvH5b6)d z9yhIKOE`I1Iw=%$_#aRZ%2n_Arr70El=h`_%el^D0ViZ#kxWH=YC_bsspyhwurQ@z z(=KE)rs6fhacprjg;na@=Z;DaC7#Kx0ctByUnUttHatest>binding>stkscan.test ;; ;; (do-test "simple stuff for stkscan, check doesn't die " (let* ((sp (il:stknth 1))) (and (equal nil (il:stkscan 'should-not-find sp)) (equal nil (il:stkscan 'should-not-find sp 'please-ignore)) (il:relstk sp) T ))) (do-test "simple stuff for framescan, check doesn't die " (let* ((sp (il:stknth 1))) (and (equal nil (il:framescan 'should-not-find sp)) (il:relstk sp) T ))) (do-test "simple stuff for stkargname, check doesn't die " (let* ((sp (il:stknth 1))) (and (equal nil (il:stkargname 2 sp)) (il:relstk sp) T ))) (do-test "simple stuff for stknargs, check doesn't die " (let* ((sp (il:stknth 1))) (and (il:stknargs sp) (il:relstk sp) T ))) (do-test "simple stuff for variables, check doesn't die " (let* ((sp (il:stknth 1))) (and (il:variables sp) (il:relstk sp) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1a19964ea70afb0372a45e620a32632fe04a41f4 GIT binary patch literal 2543 zcma)8O-vg{6rQy)U;`E)=eHr5Qj$2^EafK&2~Dc3*JEs0cAedIfGAQ$U=x!X8ySO? zMnN=H)kC*Ufr570M(v?edyINRO~j$6NV)djV-Gz<>anWQ_trK6;wtsu?0et5H}8ME zLIUH8N|nOw+)U0c(!xS%ZlOeP7K(Jfuuz<`=}q9%yNYhGdr4Ut>3+92WbQzwiuPp5 zo~G70vCTa306WtZpX#`)SjL8hwY3rk~Yr?Y7>^^W>Qks+o*W@8ae2oabqQYA_f6jlq%^$3IUG@Iw;k}H3y^O9sjPEM+y561(JYUXM-|dgV zw)XoC?Lv0*{m7Oc0rL5Z`aqBTO2|s~Q#~@`6I$T$(SfnUr~|)^gftUyVCu*&pI56s zH-Qq|2Xb3G9xEmw3sSff0fh)Y`=7?FW*_aZWz9;qb*7d0n%s5gh^XjVJcTKilCl=Z z#Kls;(S}UX7la)FF`?@sr22sq7Sl#bvm}*iLsnAsH2^QP&AZA}(O1udz5rBQo2bZ^ zl7u3#G6qzP;+0&zIbm9C)F-^U!_q|__BZpOKjfXn3_~|0J!7Ramgo|@Dm3~0_ZJ?Xfl$jpSXaa|gh>@$p7Dr$4@gVQsP-JPT;74p13-eifKPeH z5-{sys6<`l9kWPT9%b{6ZirQ#o@Sco?+u^=UZ_EtFaeXGUc)%5NDlMkxSYe7SYtXr zgw#9yFfK><30&Gdiu}gAfFjR40rG?&7eP~##>S+p%)rTT66jzmA+hn4X_;MkPC4ao zA`nl32UwaI2H`{3c~3UzK;OCEK^nVLvbX2(e73NVo2L0fi5BhI!lF$}c5!wlKbfOi zN~M#Z%)F%o~AST@~lPPlIL99T?+_4|MD`*TyWR? zSW2oq8jH*Bnh&FM0*0FfA*hp$A(J2CJ-G8Eg6obCkab7UkaY}&A<|W0tbJh|1O^a| z0Lr_U-L-mtqIw?r+x-UhtU5;(C=(0wUhPq@Fx8aB3|TdKxMItdjBc@Vtp9W!8KczO z*HeztRQ0y1M5$=sn8{C55w4wlsXX$<(=W;Vtx{G5%g7)6G%i25PUx;uDBAaA1C@3o z^V?d?ub}VH>jdujtk#Z?VF!;x9(QXjdhD6K>`9NUZIGkMr{37Z(bq)CW;TfzLTdB& zD$o9|RX_s6kP6Gh;Bc4L(lY&_I8W(9HM2<@Lpnb*=-( z3ZF#dERoV!c_^f`gie<*@^MR!sf>2&YFvW3#|-RUZ&N2-8Wfk5%0);!x6#g1AzI@V z#c@+kW}NoYKHC2u`{GPdWrGb;c2!m{SNfgCbqyLdJyBCP92dm`q0uM|a2nMzs!DfF z<=SWMF>{ZcH{nmcPBIFk?+W#92pUbR8ME@-dkSAQ%{47OT@xUeH%JcA`ssSgqj zsdd6i&YsLm3v=baCGf9=@KMO*ve1G}h}mUA9V9v+$8^IYq+@RxHF(X$FG8#EOT5cJ h3^m$X32a=dl*dJW4Qn@eJ#87uj5gBu_4OAo{sp>2wPyeT literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.TEST new file mode 100644 index 00000000..901085b9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.TEST @@ -0,0 +1 @@ +;; ByteCompiler regression tests (do-test "AR 7120: Bytecompiler should rebind *print-level*, *print-length*" (progn (with-open-file (s "{Core}AR7120." :direction :output :if-exists :new-version) (format s "(DEFINE-FILE-INFO ~CREADTABLE \"OLD-INTERLISP-FILE\" ~:*~CPACKAGE \"INTERLISP\") (FILECREATED 1 2 3) (DECLARE: EVAL@COMPILE DONTCOPY (COND ((AND (NULL *PRINT-LEVEL*) (NULL *PRINT-LENGTH*)) (SETQ *FOO* (PLUS *FOO* 1))))) STOP " (int-char #o247))) (let ((*print-level* 3) (*print-length* 3) (il:*foo* 0)) (declare (special il:*foo*)) (and (progn (il:lispxunread '(il:f)) (il:tcompl "{Core}AR7120.")) (progn (il:lispxunread '(il:f)) (il:bcompl "{Core}AR7120.")) (progn (il:lispxunread '(il:f)) (il:recompile "{Core}AR7120.")) (progn (il:lispxunread '(il:f)) (il:brecompile "{Core}AR7120.")) (il:fake-compile-file "{Core}AR7120.") (eq il:*foo* 5))))) (do-test "AR 7261: ByteCompiler should not remove terminal NIL arguments" (progn (setf (symbol-function 'one) '(lambda () (two 1 2 3 nil nil))) (setf (symbol-function 'two) ; First trick compiler into '(il:lambda (x) x)) ; believing TWO is ARGTYPE 0. (progn (il:lispxunread '(il:st il:n)) (il:compile 'one)) (setf (symbol-function 'two) ; Now here's the real '(lambda (&rest args) args)) ; definition of TWO. (equal (one) '(1 2 3 nil nil)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1e3b84f6ea211a2fceb441052eeb67bff7511f9b GIT binary patch literal 2301 zcmb_dO-vkR82)A!w!5$_EI%y*mf^3(k)hH;gQ(HzFbfN_GuxTjU`?Z0m!(TfS+cv> zs1a+M*qCg#E{!-}4PH&uLnYCOZ9>$Tc+i7~CYm(SgNgCx$(zCVotXs|ZS>H? zdw-tqcS@xCSxMof%*Cbog;bWyEa#V&^W0n}%jGi5*<^~F13&kwr0Mc&lcF>|_{30+ zv1cTiO(pWFS-+*)WB0M3DtmjLN)KvI;(!ix4+t-718RbNS4Y zu#kEwwSd#Pm?I1!*4qVNIIc=&L{qIB%w;BET`$x{R3Qda6DMTC`rIm5ov{k_(xj*h zx;&xFh5<=reJyZ>5cUmJ^F{jh6tlTVKE5->&a}0Km}*yJi1E4>LLDI+-Ie_PN_shc zIo){s93hQY4m2|9%@=}OS`g?TrRnQh@M}U!>1$eWie;cw>DIxS4ort}A0Yukw&s(E z?bUJhFlt$k&utT8{FMzihWGLN=sW)z#*LxA2dR){%L?mu6xQxj6yC@0r})D5Mhk}G z2g~DvqxgYpez&YS04om%5%*`~GmR86^8Qd5trMDMwl6pAn|U(}1Uj`aMDD5#(iE*K|RPo3Xgbd+H$} zz>De`!S)+Gg_{%_-hUx$JcQ6HyoNkpsb#3-4QqN-G?8Yps}$FDS>1EZDT8A#!dUa} z%q7u~omSMooX22gym0~D7~P9h*`clU5PAdjAOf+0`I$BWWA4#rgzsq!!aB~)h(u%X z#u%m!i~1D0*RURRhc!cb4XKLngn@L0wjx{tuP-|7q@iQc@t>pZ$ewrDjKiW391O$0 z!49~ag+Y%xqWT?C580x~uOO;E24W<^)LdB*Ozzng$zA#|vhN)Bjl=FZ>{Ew*L_09# zExS5-lQv(XEz?l7sbZ>vd^#>F_~0g-UxV2 zBg)QejPEE0%s`=P`#2y|;UV^_xYr8Or)e+3aftCqqK@_e?L#;UE905VWYF${Bu`k= z&~B$k5L(dX4%cI-JM5?ZIP9U105E^iqX<8N#wPnc$K^AH^6tv^NSmV=i&6FKo zcd39Ss8y(v68Rk3t3?}%7A$lkkDjYV4&fE6z}QC4;pc%Ta3EQ<;W^+Ua-(QN1d1vV zBZjUMwnjP#3g|JXb(h_m{9fEXg5l(svhkzahx}moA>X=v$d`5>^10iGd}8+@AMExa wrOH09Q(?j?9OyY~EG3euXNue?%&O;XVyKwtw=J=&C?0b2naW&pb8370ZyRrC`~Uy| literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST new file mode 100644 index 00000000..89f8d692 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for Character Printing (AR 7403) and IL:U-CASE/L-CASE (AR 7600) (do-test char-print-escaped ;; When *print-escape* is true, print chars as #\x. ;; This works ok already in Lyric Jan 21. (let ((*readtable* (il:find-readtable "LISP"))) (and (string= (prin1-to-string #\A) "#\\A") (string= (prin1-to-string #\a) "#\\a") (string-equal (prin1-to-string #\Space) "#\\Space"))) ) (do-test char-print-unescaped ;; When *print-escape* is false, print chars as themselves. ;; This fails in Lyric Jan 21. (let ((*readtable* (il:find-readtable "LISP"))) (and (string= (princ-to-string #\A) "A") (string= (princ-to-string #\a) "a") (string= (princ-to-string #\Space) " ") (eql (char (princ-to-string #\GREEK-A) 0) #\GREEK-A))) ) (do-test char-print-mkstring ;; Interlisp integration: passing character as string arg should act ;; like string of single character. ;; This fails in Lyric Jan 21. (let ((*readtable* (il:find-readtable "LISP"))) (and (string= (il:mkstring #\A) "A") (string= (il:mkstring #\a) "a") (string= (il:mkstring #\Space) " ") (= (il:nchars #\Space) 1) (string= (il:concat "Cat" #\s) "Cats"))) ) (do-test ucase-in-il ;; Assure that Interlisp fns really do intern in IL (and (eq (il:u-case :foo) 'il:foo) (eq (il:u-case :|foo|) 'il:foo) (eq (il:l-case :|foo|) 'il:|foo|) (eq (il:l-case :foo) 'il:|foo|) (eq (il:u-case 'car) 'car)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CHARSET.TEST b/internal/test/LANGUAGE/AUTO/CHARSET.TEST new file mode 100644 index 00000000..c740a52c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CHARSET.TEST @@ -0,0 +1 @@ +(do-test "CHARSET accepts 255 OK" (let ((strm (IL:OPENSTREAM '{NODIRCORE} 'IL:BOTH))) (NOT (NULL (IL:NLSETQ (IL:CHARSET strm 255)))))) (DO-TEST "CHARSET 255 == CHARSET T" (let ((strm (IL:OPENSTREAM '{NODIRCORE} 'il:BOTH))) (il:for ch il:in '(255 255 0 0 1 2 0 3 3) il:do (il:bout strm ch)) (il:setfileptr strm 0) (il:charset strm 255) (equal (list 1 512 771) (list (il:readccode strm) (il:readccode strm) (il:readccode strm))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b3638823e7d4cbcb2260c358486e542230b834ff GIT binary patch literal 6083 zcmb^#TWs6bm8ATBMNXV_wew)pG!LeqW&b^`} zKhW+Yu*JjkxaW26J@;I$bM5o0E~=&Fm3+Z1i>1}-%4$_yDwV}bX|?a#bt~EQvk!{nkBG`jIbVR6sVP9uPESrwKlJcuPeieG zrtLGwOiiCTJAGzywCB!^O+HxSI4;Azi=dn1f?R;}uGfN+quGueiR+qdC<#sS*1cL6 z#3H9`&GKr46JoWrA{X3CZUMttu5diZc`w$wA}K?4;-=wk@N0aZcdgbRH{>LQrbIPP z=&EZ$?YvjJ7Zk<~N3)Wa22a`2qLyacFr2%wIq(9<1wKT-ewlmgasJIBSAP3(;ljb; zLB72pymgV|_P)?L#OL0;ZNU2{>oZr4Uvb=e?wiKr0^bjBuibOuFb>CG7svH++`IXV zNF((%{>j(a=?lWZ8=wwSffT^ja(BfP|5x8s7b*t*?}C||uXAqzcwhKE2jB#tuM|2n zNB!BTi(F+60rz=-Y+(?jfPAaaGW^z4J{vih6<_hK$F{4zbsE^<#jX4NF@=7n^5vFs zYq{P2?n*+0n4ggD!eGI;T^PJ=+_^iNZ}^(~LG$3=2DUGVFKUpxHT zpg;{us^X|Is2EPlf&!z`3e{mR*p8ME_?;4tDUsg50O=0wfub}ZX_jSLvYB#{DMtzf zVL+dx7z;9`+Y;degFp*JOmhv&-PHDSH_*m$qz#Llgk|b?ptB=lS_#EL^fzc_dzvz1}C?qkHmj5t7v{BJ3d|1~A@Z!qFT@Tv>^S9K+x0Db%yfzS=< zu^q*5l1Q=02!e+g7-FEC90VfwZ;EjrG4OM0f%_@7z`a8De+~Tac|e=ftOePIg{5oH zfcib#BK?Cb5h7^5Hu|OeTB|!u$419rsIR;d6Kk^=B*f|DHfr=ng zp+hp0ni{A1;Eyu?AqF}q;O;Q+F*ydBxW6#$j|>p%A-7IF3fX+| zqIfyy7R8ENa5Gitvho%2B&!L|LQ*>g&II1^YDXNmQWcM0QI3jBX=uQ*V!p_FC!}3@ z0L5PPHUhW|aBpEVgDdF*6fDh(q;vzC6h`Y0S#e#DD~77!sBd{29U$3Rce*aq^uXH? zfZa!X9zAX+h<*ZDGYS(9MeXGRj`B9ab$(aWr{bJ<{XQjVZcKdQl9rFq<+R zjm}#j>(#1sa?U(FEmkp+E9KI~OQJ01m!L|P#3lE#cqv_gj#W&TU9qydvQo&q*$2gH z&K1k58l>vgTIhx33_M_%P+t6+&_)jPJVe4ZQWiT9OP}3NUL>P=l$pnY~odyNOBuO$$EMgOfq>y_5rf@Jhn;RZR zr$5-*WCnBf#+wJ50bCF~8vXR3gho&YNMa8J(MJqnFPm7N`O1T<9YEziEQ{QogIJUvQrk=FQmoGjGwU6|$b0{;t`=~xWX zHvCzN;07Yp6$xIg@7S^Wp#`PetL^hq&6tZ@rjdZ7nd94G+S~B7VJ5Ha%tFblDVT-v ziF4CpD2=6}>Xy?qZgJ7AUUp%@QbW4t&?Owf7g&WN-Gm@qgH%i+|6n#pv!lH!&@SwTOR`K8Q$C zvEVKTTbufsfm><1_$(O1nJZm#%jG=mJ2#!li6z*F=r#W~vy@@0s)HQ>SfmE$HOrib z!jVWo1BbPYR(Bq1B^H)0-!SQA^f6pnSJ-ogveNJM}n*&t50swVS;{y9Y>b15r_|1x3*=#-%L(y+wtpTTOl1>|7Ix zo5<;B!wqJtZWo%HCd;&_?z$jgE!tsmHWkj(QA4Vt>#|}+Q@Eq-Mxc9CSclNi?;xpW zxS5V1m4db6SkQWcG^l4IBS32?8=zt_IKrt)5bB{6SjL!Bf6tI((M6Ry(wXZfH@(iO)d~-ViuUk7om>&VkvMQw9csdTk9n#VH!nl|(44fPe6j zWJX)KU|L}t==ap=jg8jK$B3>eAlxw5>I96ucN-gAjWW-HIlPT&$4m?E6&M$Aw`*pN z?sj(4wBfD=aqe!o!QRbqgSo5WCYN^D4a0kzs#=me(n4({qnZ2Rg!w618rsT@#OIAv z0#fj~t@Ne|%MLsvA{3Hwcj%2KGYg>%eX^Z=-UTAzwB+C1f#u@l1%CgG1Hup z&<805{p5@c@~SodDPF0V=LRh`!E# zDFQ8O3cd^C-~kC%eOQJYUC6ZIv*fkfUWuN*_1m&Ps#~gmb3~CIDQUr;hAIUm90`4O zLI^J3tvFuB5g(}Y)wreVTPT{XD#mv;HQ_6}R`x1fL_AoZoMKEd8 z6fy;l0<{q(f)ZY};bstqPqFwh1ZaazTKx+N5PRU8u$72oUG#l(EJfA)k0>C*<6uF; zXF#HWKaG^r_zaw;fS2K&A4BpOJ_BQ8WBE<4_q_kD65G74dTa0)oWU*4VE}Hg9N$5X zah$!i9SD21X=nwe#;2f%I_bnT@g&{tr;P}Pc?Yececk}L=xfl~md!yB@SKF&F zCrB0p(HxOMfO{p#PyA#|F#cc=6%#bk5Tl8S`jdZxQKONB=zN~{r7+5jzYtCO=DGKI zpU>y{_C9xABEhGXl&Cm!<>IVe5uKV_uDRljQxU69t&+3F8PJOhif*Wf#${#iz@8mp zbHz!nVrN}DFIqLbn$ONZBJOxXl*^UkEIjPq4cnpNUAu;NK0Xjm$YzSO{VQho@Ziw! z&Yc6{<@0BRs6z|ghWXb@lSfuxTTtwlt`vjNt4rR++Xs&R>(!ln5yA>9gm5w zQP0lJRzlhcxmwJ{Smt#%f7ac!6oCUk zw*)*r59{q)TPPH6j}-2USK;Nl*VfgN%XMF!>gLhF1GujD>i#(YqwYNP-#ZVub?5E> zgY#eN&Lj8P`N_hi&eg8kQXyK5l0d{i?e)eLT^mi}q)6kkHkwimX(S06ZOn`Z+G!{d zg4GJE1y&GNGmK?NT#+qh9EQcp7%)}}o69xkv}vj7fN-ycrN?QcsSOUA61skSh;jUy z!Zg&h76x=}Tr~{cko1f-nX%$c4}f)BT-K%~rZ?jhCbeUzap2pU38Bq6=G$>vuLIMX zgl?o|3%6fjEK0^ORBgp;gbH}}0i3PBlfELGDtARAczha|BBN?bwN&;3LfvuD1(lR; zs<=A_1&oZT7QUX6T0%$ND`3&APpTSj(sTog3EGKbn0BG)rrju_bR&v(+5ZqjseKG3_z|i0J#8( zv?$}UVX9a)at@N%ke2tV(ukqUqfi-3;x9-%^}#v>Y2VSDpuKqD0qj8rv!--uN}gT; zdY#75WRb?6qZ^*3ooU*&oo?JlH%Xulyo+^ZZN}Y2c!96cu!kw!Qrd^&HLR>PJ;_Rc z5H=AA0Pd-TfulhUU~SN^H1@h~SV1m+rO?KKZD=%UsO;l_nn5a}*v6goa?wKjK`Gn> zFCnCt6-z}Q!VS6^#qV?rieKqg6z?+%;T?t*E^zS%r#Q?4O^#{ms5CNdVerBNCppMT zYMf+eU!2LpUx~a}gBvFL!7m=Tz)NGme9b7aA2A|D1m+ z08<%L;A0G9*D#!^By>SenKXiCaATgz=$6X+m+-yVs=;EE*_>;$P)8`cZtEL73qLg~ zeqf={L2yKO@XmbskL7^k*m-H+ylX>R!spC~aJG^1#YV+5_xecrUjM3D)JoWb6<)@< zm!1Yv@>`?g$9uexuYGS2%Tl#nF%VX}33+RBdHHX? C4+ez* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST new file mode 100644 index 00000000..7137c9c4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for open accepting cl:character as element-type. (do-test "open with character element-type" (close (open "{nodircore}" :direction :output :element-type 'character))) ;;; Regression test for open accepting cl:character as element-type. (do-test "charset applied to two-way and broadcast streams" (and (il:charset (make-two-way-stream (il:getstream t 'il:input) (il:getstream t 'il:output)) 0) (il:charset (make-broadcast-stream (il:getstream t 'il:output)) 0))) ;;; Regression test for AR 7525 to have openstream assign the file ;;; types of the file based upon the :element-type. (do-test "open assign filetype unsigned-byte" (setq foo (open "{core}foo" :direction :output :element-type 'unsigned-byte)) (eq (IL:getfileinfo foo 'type) 'il:binary) (close foo) (delete-file "{core}foo")) (do-test "open assign filetype signed-byte" (setq foo (open "{core}foo" :direction :output :element-type 'signed-byte)) (eq (IL:getfileinfo foo 'type) 'il:binary) (close foo) (delete-file "{core}foo")) (do-test "open assign filetype character" (setq foo (open "{core}foo" :direction :output :element-type 'character)) (eq (IL:getfileinfo foo 'type) 'il:text) (close foo) (delete-file "{core}foo")) (do-test "open assign filetype string-char" (setq foo (open "{core}foo" :direction :output :element-type 'string-char)) (eq (IL:getfileinfo foo 'type) 'il:text) (close foo) (delete-file "{core}foo")) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL b/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..34d27f840a9c9e2d3e0867eff8c1381e180601e1 GIT binary patch literal 1031 zcmah|T~E_c7(VS7>)0TJ81S2hL=qcH0D%C;#6x!mgRULzX@JC=WgBif=(27SG?K{$ ziKa#ek+d5AgSUv03;&S+0N>LQA$s9O&-v*-kuf;uPLgi*qhaIrC1Z~M!njo ziyL-LbnHegUlcb07hfs5L0&InWqI`Bc$azQBws7$>cxUc8%3v(+ZhqZXGL7Cl`G)P z%)oYfZgO(&!PID13Y%&>+JEoN%#BUYO-+n;ogW`@2^%4lM`z4L5lWyC@($dDM2Sh| zR9YpnhBHL+TAnLFFS2D4!*hEl#JXLTE5#SZ3TtQ6K^#KfM^{K$nnKgM<{ffPF7ADB zyVIJSh1T!_LA-Dgg+=E)w@1mS*f8)qFsQPKj*mL`ppJc3%(v3%5_htNn%|fB)t;NZ zT$rIx5h}xX;W85ozzW|LX~W%r%qbB2_9Ahvbn-(3|5t1Iz4jBKR%u^b;yEB5l)m<_ z1`4o90zz?w&dT||Rw+?VAU^DUa&JqDt|il~C3z8RNtGD#d>RmK!Ibz8(5hEbSn;w! zsAWK}N+4FJxo%RD;kkbqRG0i%DB?#$0_f8t5yQ|8S+{7`qEaXd7vd7u*5v>MgPVa?D~^wGpk~SBxMkYtjT&R zWfD3JM~Sos5@J<`A}ADR4gwgzh_uMb%eCK@MJ$(>)s%TJYt+(q9+kvfK zx83W))s_Q0t)5f0;VQ%7E5#uAbsi~8(+_3^^RGWu$F6kk6-aw_XQi@v3(nq$sO{7n zELd1z*SqPtx%8d+X(5YDZOHcDnuYYtz4Xk?v~Y5;&xtJnKouMZ$0z_I2mx=`6(x#I zDrZ#<%Q`Az$?JP=jA@ZA6BEx(-iF;)TW;7Jb|a9p-T@o{-Um09wRDB5hVJcg+g#k+ zaTBU8mzXq^!+?*SvIOiLi>p1eVJGu4~l{>20$Eu<9ca`^PUS&=iH|bq+$p4CJxB8rAMrlAmn6l|Gio47&LcgeVInW84AFC@ z#D|$zNl8Ie$;$*&i!iOqz^tfQHYqOh+`k#rkbEID>W_sIgQl1egUE(OOBR(vW2_)9 zA-yaQa8vS`QR3_wzehs=_~F3h@N-5I%^IYL=(C`iViAIwu-}j8b1K8f|L9PViHGdI zaE(<*22O+?2H~LTJbTHg9#Cpi{)O-p&z-6`PGu9a)oXU^%{AD1*|D7sy91>G#5SS1 z)~!iwHLg;-(}j~;XcDeg*mkeLdULp#0k(DhviCmay-Rs}Vb&y$HCzmarR5U#_INgd zVCkls({V;#EK|&}qy)+oER&)|4R8Or@rd(22bsI>6@_3#v3y3Drcz9hX8OXAF!Ida!4=)q(+^X8j3?|tukZ`vSo56ci&%e9hi zIHM&cP6JU-=N=Ee|Kw>OH=^>1#rNY7ytx%K7s@zVF;7_xS_z#pXLZ#}wY~ezUusw)NcZQ~1xz7ClpVT1e|vuux0k zJFOLKjXe6gzfxM+-rIWs!0>7x&sn?sgxa0<>`U?qfVTC5WJ25^0PEKF@ws6}gZ)te z;s6|!3L|YRQA&VN#CzkO7O+C5)2vc4g~+rlsp6e9MaYaMgnFoiLjp!RPKm0d=T#~J z4m9l5<~3c)hPZz{bVcw7!cjjKj#1foK~hyk6_vc6%j-gTkY0!jh|G%tt_eQXFERdC z8=_$V{2r!#Ams)P)SFb)EYg{>EtVALRaGKKdh2t~C_eJ19*i{UFpEEsr4eFm0z}rQ z4BIgy7z)g2&ZsDtO5@;I%!Qj2iv$eIbQ*dI%PkxJ$uP_BdhUgaQ8vYbWjN5N6d^N2 z20_CyVX3lcI(4(oeAhhptZvpDaC8Zc!UcoAlOlCE9C3y%UF5uX-bRRWKZ8{X>6GH{ emINipX*yL%*8BnHMtR-ME4t*L0B_HAyFUSgJ{~jx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST b/internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST new file mode 100644 index 00000000..7409802e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for CMLCHARACTER - 7801 ;;; bill said to use the short form ;; This test is slow, since it applies to all 2^16 characters. ;; Almost as good to replace (1+ char-code-limit) with something smaller, say #x2323 (do-test "name-char and char-name are inverses" (dotimes (i #x2323 t) (let ((char (code-char i))) (or (graphic-char-p char) (char= (name-char (char-name char)) char) (return nil)))) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST b/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST new file mode 100644 index 00000000..d133ba11 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST @@ -0,0 +1,350 @@ +;; FILE MANAGER - tests for Common Lisp FILE COMMANDS "FUNCTIONS", "VARIABLES", and "STRUCTURES". + +;; Functions To Be Tested: MAKEFILE, IL:LOAD, CL:LOAD MARKASCHANGED, +;; UNMARKASCHANGED, +;; ADDTOFILE, GETDEF, PUTDEF, HASDEF, +;; COPYDEF, DELDEF +;; RENAME, BCOMPL, BRECOMPILE, COMPILE-FILE + +;; Source: KOTO IRM, [NOTE: Can't find any LYRIC documentation on this] + +;; ;; Created By: Jim Blum +;; +;; Creation Date: Jan 9, 1987 + +;; +;; Last Update: Jan 21, 1987 +;; FEB 16, 1987 - MOVED Into {ERIS}TEST>FILEMANAGER>CMLFILEMANAGER.TEST + +;; +;; Filed As: {ERIS}TEST>FILEMANAGER>CMLFILEMANAGER.TEST + +;; +;; 3 new FILE MANGAGER TYPES have been added for COMMON LISP - +;; FUNCTIONS, VARIABLES, & STRUCTURES +;; The tests below test the FILE MANAGER to see if these are being handled correctly + + +(do-test "load a test file and make sure it gets noticed" + (do nil ((null (il:delfile '{DSK}testfile)))) ; delete any old local versions + (do nil ((null (il:delfile '{DSK}testfile.lcom)))) + (do nil ((null (il:delfile '{DSK}testfile.dfasl)))) + (setq il:dfnflg nil) ; make sure DFNFLG is set to nil + (il:smashfilecoms 'testfile) + (il:deldef 'test-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (makunbound 'test-variable) + (defstruct test-structure) ; redefine test-structure to dummy def + (il:setproplist 'il:testfile nil) ; remove entire property list + (IL:load '{eris}test>filemanager>testfile) + (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-TEST")) + (member 'il:testfile il:filelst) +) + +(do-test "define a new function and add to the COMS file" + (and (eq 'test-function (defun test-function)) + (member 'test-function il:changedfunctionslst) + (eq 'il:testfile (il:addtofile 'test-function 'il:functions 'il:testfile)) + ) +) + + +(do-test "define a new macro and add to the COMS file" + (and (eq 'test-macro (defmacro test-macro nil :test)) + (member 'test-macro il:changedfunctionslst) + (eq 'il:testfile + (il:addtofile 'test-macro 'il:functions 'il:testfile) + ) + ) +) + +(do-test "Define a structure and make sure it gets noticed" + (and (defstruct test-structure x y) + (member 'test-structure il:changedstructureslst) + (eq 'il:testfile + (il:addtofile 'test-structure 'il:structures 'il:testfile) + ) + ) +) + + +(do-test "Define and set a variable and add to the COMS file" + (and (defvar test-variable (make-test-structure :x 1 :y 2)) + (member 'test-variable il:changedvariableslst) + (eq 'il:testfile + (il:addtofile 'test-variable 'il:variables 'il:testfile) + ) + ) +) + + +(do-test "MAKEFILE, DELDEF test" + (and (il:makefile '{DSK}testfile) + (il:deldef 'test-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (il:deldef 'test-structure 'il:structures) + (null (il:hasdef 'test-function)) + (null (il:hasdef 'test-macro)) + (makunbound 'test-variable 'il:variables) + (null (boundp 'test-variable)) + ) +) + +(do-test "Reload test" + (and (makunbound 'test-variable) + (null (boundp 'test-variable)) + (il:load '{DSK}testfile) + (eql (test-structure-x test-variable) 1) + (eql (test-structure-y test-variable) 2) + (equal (il:getdef 'test-function 'il:functions) '(defun test-function)) + (eq (test-macro) :test) + ) +) + +(do-test "edit the function definition and see if marked as changed" + (and (il:putdef 'test-function 'il:functions (append (il:getdef 'test-function 'il:functions) '((a b) (+ a b)))) + (member 'test-function il:changedfunctionslst) + (equal (il:getdef 'test-function 'il:functions) '(defun test-function (a b) (+ a b))) + ) ; and +) + +(do-test "edit the macro definition and see if marked as changed" + (and (il:putdef 'test-macro 'il:functions + (subst ':new-test ':test + (il:getdef 'test-macro 'il:functions) + ) + ) + (member 'test-macro il:changedfunctionslst) + ) +) + +(do-test "edit the structure and see if it gets marked as changed" + (defstruct test-structure x y z) + (member 'test-structure il:changedstructureslst) +) + +(do-test "edit the variable def and see if it gets marked as changed" + (defvar test-variable (make-test-structure :x 3 :y 4 :z 5)) + (member 'test-variable il:changedvariableslst) +) + +(do-test "makefile, load and execute the new version" + (and (il:makefile '{DSK}testfile) + (il:deldef 'test-function 'il:functions) + (null (il:hasdef 'test-function)) + (il:deldef 'test-macro 'il:functions) + (null (il:hasdef 'test-macro)) + (makunbound 'test-variable) + (defstruct test-structure) ; redefine to dummy defstruct + (equal (il:getdef 'test-structure 'il:structures) + '(defstruct test-structure) + ) + (il:load '{DSK}testfile) + (eql (test-function 3 2) 5) + (equal (test-macro) :new-test) + (eql (test-structure-z test-variable) 5) + ) +) + + +(do-test "rename the function, makefile, reload and execute" + (setq il:defaultrenamemethod '(il:editcallers)) + (il:rename 'test-function 'new-function 'il:functions '{DSK}testfile) + (and (null (il:hasdef 'test-function)) + (il:hasdef 'new-function) + (eql (new-function 2 3) 5) + ) +) + +(do-test "copydef" + (and (il:copydef 'new-function 'newer-function 'il:functions) + (il:hasdef 'newer-function) + (member 'newer-function il:changedfunctionslst) + ) ; and +) + + + +(do-test "test dfnflg set to PROP and ALLPROP" + (flet ((dfnflg-check (functions-def cell-def) + (declare (special il:dfnflg)) + (and (equal (il:getdef 'new-function 'il:functions) + functions-def ; make sure there is a new functions def + ) + (member 'new-function il:changedfunctionslst) ; test marked as changed + (equal (symbol-function 'new-function) + cell-def ; make sure it hasn't taken effect + ) + ) ; and + )) + (il:addtofile 'new-function 'il:functions 'il:testfile) + (and (let ((il:dfnflg 'il:prop)) + (declare (special il:dfnflg)) + (defun new-function (a b) (- a b)); redefine the function + (dfnflg-check '(defun new-function (a b) (- a b)) '(lambda (a b) (block new-function (+ a b)))) + (il:makefile '{DSK}testfile) + (true (setq il:dfnflg nil)) + (defun new-function) ; redefine the function in both places + (defstruct test-structure) ;redefine test-structure + (il:load '{DSK}testfile) + (dfnflg-check '(defun new-function (a b) (- a b)) '(lambda (a b) (block new-function (- a b)))) + (defun new-function) ; redefine the function + (il:load '{DSK}testfile 'il:prop) ; load with PROP + (dfnflg-check '(defun new-function (a b) (- a b)) '(lambda nil (block new-function))) + (equal (il:getdef 'test-structure 'il:structures) + '(defstruct test-structure x y z) + ) + ) ; let + (let ((il:dfnflg 'il:allprop)) ; now check dfnflg = ALLPROP + (declare (special il:dfnflg)) + (defun new-function (a b) (* a b)) ; redefine the function + (dfnflg-check '(defun new-function (a b) (* a b)) '(lambda (a b) (block new-function (+ a b)))) + (defstruct test-structure a b c) + (il:makefile '{DSK}testfile) + (true (setq il:dfnflg nil)) + (defun new-function) ; redefine the function in both places + (defstruct test-structure) + (il:load '{DSK}testfile) + (dfnflg-check '(defun new-function (a b) (* a b)) '(lambda (a b) (block new-function (* a b)))) + (defun new-function) ; redefine the function + (il:load '{DSK}testfile 'il:allprop) ; load with PROP + (dfnflg-check '(defun new-function (a b) (* a b)) '(lambda nil (block new-function))) + (equal (il:getdef 'test-structure 'il:structures) + '(defstruct test-structure a b c) + ) + + ) ; let + ) ; and + ) ; flet +) + + + +(do-test "test BCOMPL" + (and + (defun new-function) + (defmacro test-macro) + (defvar test-variable 1) + (il:delfromfile 'test-structure 'il:structures 'il:testfile) ; get rid of structure as this will cause a problem later + (il:defineq (test-fns (a b)(+ a b))) ; define a fns + (il:addtofile 'test-fns 'il:fns 'il:testfile) + (il:makefile '{DSK}testfile) + (il:bcompl '{DSK}testfile nil nil 'il:ST) + (true (il:smashfilecoms 'testfile)) + (il:deldef 'test-fns 'il:fns) ; delete fns definition + (il:deldef 'new-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (makunbound 'test-variable) + (il:load '{DSK}testfile.lcom) ; reload file + (eq (test-fns 3 4) 7) ; make sure fns got loaded + (equal (il:getdef 'new-function 'il:functions) + '(defun new-function) + ) ; make sure functions and macros didn't compile + (equal (il:getdef 'test-macro 'il:functions) + '(defmacro test-macro) + ) + ) +) + +(do-test "test makefile, brecompile, & load in a different package environment" + (il:defineq (test-fns (a b)(- a b))) ; redefine fns + (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-USER")) + (il:makefile '{DSK}testfile) + (il:brecompile '{dsk}testfile) + (il:smashfilecoms 'testfile) + (il:deldef 'new-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (il:deldef 'test-fns 'il:fns) ; delete fns definition + (makunbound 'test-variable) + (and (il:load '{DSK}testfile.lcom) + (eq (test-fns 4 3) 1) + (equal (il:getdef 'new-function 'il:functions) + '(defun new-function) + ) + (equal (il:getdef 'test-macro 'il:functions) + '(defmacro test-macro) + ) + (eql test-variable 1) + ) +) + +(do-test "test COMPILE-FILE new compiler" + (and + (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-TEST")) + (il:putprop 'il:testfile 'il:filetype 'compile-file) + (il:defineq (test-fns (a b)(* a b))) ; redefine the fns + (defun new-function (a b)(* a b)) + (defmacro test-macro nil :test) + (defvar test-variable 1) + (eq 'test-macro (defmacro test-macro nil :test)) + (il:makefile '{DSK}testfile) + (compile-file 'testfile) + (true (il:smashfilecoms 'testfile)) + (il:deldef 'new-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (il:deldef 'test-fns 'il:fns) ; delete fns definition + (makunbound 'test-variable) + (il:load '{DSK}testfile.dfasl) + (eql (test-fns 4 3) 12) + (eq (test-macro) :test) + (eql (new-function 4 3) 12) + (true (il:smashfilecoms 'testfile)) + (il:deldef 'new-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (il:deldef 'test-fns 'il:fns) ; delete fns definition + (makunbound 'test-variable) + (cl:load '{DSK}testfile.dfasl) ; test CL LOAD + (eql (test-fns 4 3) 12) + (eq (test-macro) :test) + (eql (new-function 4 3) 12) + ) +) + +(do-test "test makefile, compile-file, & load in a different package environment" + (and + (il:defineq (test-fns (a b)(- a b))) ; redefine fns + (defun new-function (a b)(- a b)) + (defmacro test-macro nil :new-test) + (defvar test-variable 2) + (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-USER")) + (il:makefile '{DSK}testfile) + (compile-file '{DSK}testfile) + (il:smashfilecoms 'testfile) + (il:deldef 'new-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (il:deldef 'test-fns 'il:fns) ; delete fns definition + (makunbound 'test-variable) + (il:load '{DSK}testfile.dfasl) + (eq (test-fns 4 3) 1) + (eql (new-function 4 3) 1) + (eql test-variable 2) + (il:smashfilecoms 'testfile) + (il:deldef 'new-function 'il:functions) + (il:deldef 'test-macro 'il:functions) + (il:deldef 'test-fns 'il:fns) ; delete fns definition + (makunbound 'test-variable) + (cl:load '{DSK}testfile.dfasl) + (eq (test-fns 4 3) 1) + (eql (new-function 4 3) 1) + (eql test-variable 2) + ) +) + + +(do-test "delete test environment items" + ˙˙ (˙il:deldef 'test-function 'il:functions) + ˙˙(˙il:deldef 'new-function 'il:functions) + ˙˙(˙il:deldef 'newer-function 'il:functions) + (il:smashfilecoms 'il:testfile) + (do nil ((null (il:delfile '{DSK}testfile)))) ; delete all local files + (do nil ((null (il:delfile '{DSK}testfile.lcom)))) + (do nil ((null (il:delfile '{DSK}testfile.dfasl)))) + (setq il:filelst (remove 'il:testfile il:filelst)) + (setq il:loadefilelst (remove-if #'(lambda (a) (equal "TESTFILE" (pathname-name a))) il:loadedfilelst)) + (il:setproplist 'il:testfile nil) + (il:updatefiles) + (true) +) + +STOP + HELVETICAC5(TEXTFONT 5 (HELVETICA 14) (CLASSIC 10) (CLASSIC 10)) HELVETICAC5(TEXTFONT 5 (HELVETICA 14) (CLASSIC 10) (CLASSIC 10))‚ň 7 '2'+bG -,ó/zş \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4eece1e36a3bf58bbc1c23ea5bd537bfe0c2a97b GIT binary patch literal 1241 zcmb7EOK;Rx6uzEG!b~O^P0~P=fWifdE-V~1ZGa(_D!I;0GQqJ^+rwi68fH8l!^9r^ zAgT~3%A#G=eGI6PFDN^HK$fLcL@LWJSRi%9ieJ!wke=fKk&;TNk}co!opaCQJLkAd z`Y$UgRlK#1)3$x;MPVljY18v*;6;AjrcJ=<9Yr_T-6dJMF#Y+=pt(;|_w8C}H>efa zL8JD~X*zSB${pWn!=YRT@$B5}?A&K(rUw^fQ|)>C;GOc^C+Fs7%F}~;+gn1(BZSn+ zE`IWalt`8&_v4aiG1HP3Dk_sSd4-8dH;Hpli&Qn4k;EgP($MQjZTq&}#&XsIA`p`N z9Oo9QnqpOSEqNep2t&zF@o+_xR-rU`k&#U9jTiJTB=KQoMa3BA6;m?UqQOiPu9EGo zLz|G!Ys~4l*3)I-iAy@aFJ~@|PL2ruh<=?u1wx)_kaV}T;an^3;&E3mJ_Y6I=Aoj{ zdh$$z^WWVIKWNX<>RW9&BMif7XZ+F_y1_R`$PnCf>PJ!z-o|_NHeT*vy#EvHerxB* ze+BEdN=^w0`6WIkD!MjbLDr-tS({gxA$?f^L|Zh)Oh3 zdolpjS!^XE9JH`>kr%Rgp3e?L8;T+`4Be3QsPGnra64H$v?Wt$7cB9j{z*CrgGI<(v1^*d>D;?MTcoEDDA*3 z4rrLDisEBFiJu=4?JyW@#~&%-)(x{t>jViAOl2BDF%}*CcVd}TCtcRt0pg? z8Pxw(Rks+QxSqtbY1*|YY~j!5UrB2fwU_T3trO75z3F=E?o~cDejo`UO@dPh!B6lB J@=)B{`v(FYcr5?` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST new file mode 100644 index 00000000..b3f3cfb5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST @@ -0,0 +1 @@ +;;; test file-author and file-position ;;; Last edited: 8-February-1988 by was -- Don't use CORE device when writing temp files; use NODIRCORE. (do-test "file-author should return NIL when author is unknown" (let ((strm (open "{nodircore}foo" :direction :output))) (prog1 (not (file-author strm)) (close strm)))) (do-test "file-position should return a number when passed just a stream" (let ((strm (open "{nodircore}foo" :direction :output))) (prog1 (file-position strm) (close strm)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST b/internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST new file mode 100644 index 0000000000000000000000000000000000000000..48356a04b115c328503c73f336285777ab6c12b1 GIT binary patch literal 390 zcmah?O-sW-6x`NcTPi& z6-_xc#nBdBCrc}$tW-`PGx-U7F6ym>svz5LQyb&{grawYHA;h>!JW>*4*Jn;n#Wo? zRjmr`d^KT>?SrV;943G0)c0%55%Fy7=l7YdlC1x`i Ik)79%PfMC!+W-In literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..38a2599f6de7984cd30551b9afc2cbc318d785b8 GIT binary patch literal 862 zcmah{TTc@~82xrjFF+v+G2kt@ff$nwO9W9%eQ{i-H@3TVW>zE`lcrs0wY1H)H8BKY zeDG<_y;&!Y9#pJ(|mL0yPR{r=|cFarpsDmvsta#j@;<9o1M12 z-f-krqvMopd7b0(mSz&Xok7~l+=KZcdhVs<*u}P8mRZMcm5Xm?<@qHUHJxgW2Z;o~ z-b*enChy#x8%iOnpLP3hO(J>wesW=HZs_!2UyvFAP=e#&7zB_Y1m3PIDGXDlrm{L# z4V1@<*Y(^O*P>b!6VDx6klT%>TC-o8^Y*egSkV?~R-&i~#IbzD=z5lm<01fH=T$wKU$X zNL2~Mu=m-$u4tyQoDHa}8DuQ$n5d7k95K>V5eK*@V~U2Dmf<{^MYtxdXG(;wQHJxP z@NWh)6@NGs^#?;S?!%~p2{DOkTC89(B{awj;tDd>)E-V1pBp00U+^^=0`La{Gb1l} zlSs-WdBmOt!!(N!Y@Az?FXT9W>8}nAQGC|jAHEe->)1%M%oLX!eV%`!XDPeJVX1%! zPYjko8R3FM4>=m{(Ms^0MvP#nKI>lzuX^rev*@&JwO-t`TWzOW-;ir|eWP8Wo_m9F zNS@w7)AD+ef9$ect)KnL0Nc4aOZ6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST new file mode 100644 index 00000000..6f74cee2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for returning the proper length from cl:parse-namestring (do-test "parse-namestring length" (multiple-value-bind (path len) (parse-namestring "{dsk}") (eq len (length "{dsk}")))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c4251a76326854588e30b7c944939995f8a77d0e GIT binary patch literal 1262 zcmah|-*4Mg6u#GKezZy3w2V$FWxI5gNu~}h>$)yHInGU*&apGwVN`+#w{dDqNgO3k z(S(>L9(Xc>tfKM-`akeGhS&qI{4x6vx^v@hj3U9q^||->obR6RJLis3@-syxir?*f z9cMuNQP3X+r0oyL&>syB9nuCr`AX3Z`t`1?+$(&tIb*)@=WyWIfzu+^$QicmhwEhX zE|L2KuLGN%9XM_mx3-G6ZWm@MvZ=;s|C_T@+_+P`wOyDwKRd;FA0c#zo^vyeP#z^v z^d!uS7BwxYQd6m<$#p75<0#Ak7pZAdBMKKjCV}6VI?l1v;dHt~gb|8<2s4$YrdTyy zi%#%koQu8>XKR|&0BUlTA|Z2u!qIUQzNOUFhM`wKl?+-nsA)nXIy+4Tyqe$KXM6Z* z5A}ZE6CTVhFW@BizFJv?e&KtUf8g-geRhP<;y39WcAx&C!T!bg-gnxc2#wuuwLJmP zBJ{-lb?L!`Fi*-Lltbvbceprq^Ijea$>_&$MO1XHT;mL+U0Exu)R0Ow@Mu+26sAC$ z1yPYLWfv;8ng&o)CfcOTebb_K0slL~(nXd{q}g;L19HrX)G%~I(wkPJX^DwxNXUt@ zwl7WmrpQ2-{N^Qj(+Pyw6xTHA0!XT&8+F-o_+?7dFsSxMuNbz#f8}o;ifqyton<$G zO5@1tHoKa!qcD&Sa%XGfc98_mFd+Sbe{@VF;-|?K*Itg5d44kg*^}OB@89wYD_?HOkQVWJ@o;nBqqX%@G!GqydF73S&gM}RE_dwi zLCfZ$m*s+GML+>6JEWkwQwurR;uKY0qTc`mV)dG;>Ov1`I&bRzKVxI_#Uroc0M1-&ydSEG|D uCbAD%fqjIdpX1O@U}5`uUboY`a(uN~~MLez)K**L6QZ@k?L zQiMPeNW5SK8wB!j5wASvHGn`B4^@T46Hok#{)6<)ZV?e6QOWkqxqat+-*}p+gisN^l1mpt zS(HM_R-Dy1b2!Q64Mt2_U|P~l;tX&huEXpk9{35@qY4TAOMWQnlxs*qD7h17a;~ZK zyk#bLl})8LxgGcAO|l5o=qy8O=06mPt|W01!~+dpX6k((`#`XB`DE z=GCR_fdQrCB0_(veYsIaLas+P_uNyoL7}T*lmw2 z4N6q`W)SK{=v7c0YSI1B=-r1#X-I$v%AN$Eg?uGMX*2jgt+qiVs=1gAdL*{_D!EACa4<2*Y(bNvnrS1dq2Q-~>eU8|SyEcfYx76=+mL1Lts`7aT zw=~g{%80I17YN?3G26CmV!3?L}`2l892#J02*m~tryalAr zoMjg%m*yMURd;QhnR|Wg4Bh!HGdDr4V>z5?{zTF$QdgIzgc_j+l k6I=|V6)y}oNUh=*120?>hm}?zF$O5&h!{Z+#&>uB1r6O=ZU6uP literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLRAND.TEST b/internal/test/LANGUAGE/AUTO/CMLRAND.TEST new file mode 100644 index 00000000..2f3737dc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLRAND.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for CMLRAND - 7511 (do-test "random state symbols are globally-special" (and (get '*random-state* 'il:globally-special) (get '*read-default-float-format* 'il:globally-special)) ) ;;; test for CMLRAND - 7263 (do-test "make-random-state's are equalp" (and (equalp (make-random-state) (make-random-state)) (not (equalp (make-random-state t) (make-random-state t)))) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1e51f992d7eb486602487b23d3b32e589fc7561 GIT binary patch literal 3661 zcmdT{O>7fa5PrLMf}J1ZfE$wl&1+mBak?mhgajk1ZZ@05iS0GJ>+mBg>NrkpNW8&z zC{RHWhyH0*8fc?^R5?^?Z@hIZ{B<}^UdsLmQ);(VpKAwrt_28A~j~p(=%l{ZWL+Bm?>tmbR6XLHAzwB3xlFG zy!${$m9}CfQ_QBz*)gimWJ_b|b1%@2{ZyPT<|pAtPY+D@MLIhpd%Jd5^^01}Iqe^H zdLr%Jk*>YFtM1Luaejjkk|7H?cnR?n7qPCI{;)1vKuFUu8{4hi?P2a_fqe1hFn_qdv5u=m z#CYZKR!zvA&tF_CYF#S|tPx$x;pg@QA)795@N>DFCwvQv52kl!V^M9=aQ-T*$%QvoN$+ z$(_Qep*%o_0=)0OGw%;AdTs<9fAViDKG)-5Zq)x(vSxGsyr1y3)(7Ucu%smVqDWa`P)zj2WL4;m zf+R7Zg?TUY@*cP<;i`bTs0&M?E)4=z^^^*{mh8f))Q)Pp9Ot>UJ9H(?s$JF0>%v;_ zg=JM$R6$AU$&?;;Re?fHSWFxhY`GR@P!x5Y57$<;ixB3d0vBF z$e$c^%3~oncsJl)z)lAI=7F`y$<3=-i+Mp-x|r888#C#0CWnUC(9XpX4h(LPVv3eh zW#AuvP4^C69N_9$J-3xL5Q1pFu|Bk}@nGp$2{NzCkcH)%vMCpf>ar@vG**qJltFsGe0pWzRoS^w>@(XlxhfXF(1q439+99qKrK+6Ea~3DOA-uc&N0VyRlW=5X;3 z%RGn<^tA5*2f}udX{lrqpPFHsE{xHc!dP}ZUjQcM(xn`oN@t1&&E(R>bf%oOc}IS? zT_uawH5Vkz)vqY`pY8ZmMp>_@GTHfYjL86od}Wz!E#rnkLv01))$}W{?6{M2u%R@0cWU7)L&Oc#xb!a5Z2VDxxBMo=fzhDdYMbaEj+a~Oc`(j*5bf;5U_F{0j=lc|1M$=<#wGo?L<9x)Fh_tXG-VO zM>9KU{{zk1nX;29&p83x^)%7UF3gn`v7T!9cP!h^lntxfp$psE5Ago!hZmM4{F~J$ cEInp%p_?7%V9k3xsjGvj#BkU3qxbIp3DgRJ&;S4c literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.TEST new file mode 100644 index 00000000..686b4cf2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the file CMLREADTABLE (do-test "AR 7475: Nested #+ reading fails" (let ((eof-value "foo")) (and (eq eof-value (read-from-string "#+(or symbolics ti lmi) (progn (foo) #+(or symbolics ti) (bar) (baz))" nil eof-value)) (eq eof-value (read-from-string "#-(or symbolics xerox) (progn (foo) #-(or hp lmi ti) (bar) (baz))" nil eof-value)) (eq eof-value (read-from-string "#+(or symbolics ti lmi) (progn (foo) #-(or symbolics lmi) (bar) (baz))" nil eof-value)) (eq eof-value (read-from-string "#-(or symbolics xerox) (progn (foo) #+(or hp lmi ti) (bar) (baz))" nil eof-value))))) (do-test "AR 7802 - *READ-SUPPRESS* and undefined hash macro characters" (equal (read-from-string "(foo #+noway #Pnope bar #+noway \"junk\" baz)") '(foo bar baz))) (do-test "AR 7608 - #0\a loses" (and (char= #\a #0\a) (expect-errors (xcl:simple-error) (read-from-string "#1\\q")))) (do-test "AR 8160: printing forms containing backquoted vectors" (flet ((r-p-r () (read-from-string (prin1-to-string (read-from-string "`#(:a :b :c)"))))) (and (not (expect-errors xcl:unbound-variable (eval (r-p-r)))) (equalp (eval (r-p-r)) '#(:a :b :c))) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL b/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6a072a6778037fc7e65920f1d2240ebff1154de3 GIT binary patch literal 873 zcmah{-%ry}6h7_NF$S287)aFU4F+Qx@4^(#oKK~@gF@HB?QL)mCX%gljfF1zp)p2c zeDJA8$0BJp{13h&Mjm|ikMTdi+hHQX2Vd^J=j%CN&-a}(0O_HsBh}w-yPnfQe!ti5 z_fXUCpswHV)E(61IC`m?l)PF|)V2JBLdH7trQUJ2dQJnezSC`Ny|{%6_mR@>xE_BL zi#)tnT3jsMxtq^a6iYv4`)^ILv`{P+7V?>sgMA_E13(>)<7*rs3keAKf~?Gl#c)N_ z2{x1}k;6e4q`4MsTZD!|?l$WAZR|PE950r$-30+4{1BuowxKf3G{T|qT9^#q2UD7X z*SR!hnShx7!xFO#VKA*$b&G6N&9YXh@hqmUz`=gXi<|k{I$9MDccA%gRouLADJMuV z`UJoe`Qc_HfEf6B#G~mqW0OMb@Vmj^zXogXj2{4l)>~s$6s7?7T3=>1M>^wzG{7Xl zv0I-Ww6bm%L@E3jT#;4NC~I-!cttVFI-z(;B0=Z)#lJdK#UiKd(ZoEj&XtKy7{O(GUDvo6Vo6IJ zmPQSf`0P?fOt0soSu~m?HLI8y<;y&fET&K<)xzLL!||M+gB$&}=hpdhcF}Xc^OT=% zuZ2p@j=znaorWC-*O=4op}AdU4mG#8b5$e{w^th%Odn@gP+wwvQiz1}rvcL}YKz_r)dV0$fJ zP(qao^#LTbqBs@NE|CAgYebPBc zwVgh3N5kG|NE&XR4BSz_=8y*Z$wSp(^su0)rSwi_!F=IOt?yKaPMugIXHc&mTqBv= zMCtWgZ9Hsmqq&*Abt`*wBfXGQOl?-}e{;68*SE8o&Gf?A$+3`d0iXsG{ucvCKnVOJ zFCkgfwB%e-qq44)spOA+FN#=X+oa6*R&J1?+mqYQ=T4i$=?p*s@W1n-Ia^n)qM`dw zg)fCA|B1I;)a437Q}PtV=y?@hUGTkCwXB)c%E^r888uDJgOlUPW9;Rm3$S*7+SV`4 zXC>jZ3rD|}#J$9o6(Pc#{bc$q0^I#036mE7iW8p0-zDL0QvB>6R{Sr7&oFWI@qAop zo_-Xc7;!XzA8SvH_-_E?=GR8NBnry_N6nvK+FRwt_%{l$1b9m=Ic_Fe2@oUx_ui|L zYUsN~j#e%x`mRQqe5Z&WJ#R{47-?LQRK-#Y2+y(^(x6UxjF|UKiiiY&@v`0Ns4|?p88EGKn@d`3!{jJ0D?Krf0z?F#zK*t!ODuo z&2Raos?8YHUzl$o9HKw@Hy%|n>FkzZ@qMhYq#ET4R|A*C+vu1xDpU{m@f4mm)576L zbbgI?KX~O$Zq3?$1CO!YBBN7T%<~?;@x8Rd$kxX7tt{d5C!K1o?>hUvYPUW>I4*Ij z{q_MaNyizsI?jM+edT*=mNOWVtB;hcq*2AqsgqWBCVK9B^cGj)9u!v zmp_Ipe1?VRfO9=<7PwN1r=PwXpA-`_vD^9{&P}c`!@@Rk1R{Wdeb1|!VcLu$nf&qQ z@>@4Ig(wGIVMSd90iC?JpLTW@$i+{p?lh*ra6?>@+FvIhryf-Mdn>{ zw-C!H9cpNwt=8%K1a>rm6z-yOrJMaJKKNV3rud9qI7L_k3NGn>DDViB9@-VFX no{ba-FNajzpTxPQcI9)LH-dKr^v6D|Sgc^{r5itF&d&Y>T`_={ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST new file mode 100644 index 00000000..0b2ea8dd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the SETF machinery (do-test "AR 7507: SETF macroexpands too early sometimes" (progn (with-open-file (s "{Core}AR7507.lisp" :direction :output) (princ ";; (defmacro foo (x) `(bar ,x)) (defsetf foo set-foo) (defun baz (y) (setf (foo y) 17)) " s)) (compile-file "{Core}AR7507.lisp"))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a8a29c547e0efd4d521aa5531fec704fb8e092a3 GIT binary patch literal 1089 zcmah|U2hvj6rJ^V9H(+B)JiRsQ3Zmo*eDLB7$Y7gld-eOde)tpC5gmKus8Kej@Po+ zAV5@z2c8yz6H)Dg`X6{LMf8DJehmL0+_3|#+6P{|>pSP1IrrYPbCf@%4yNJhI2ig9 z9L}QgEW#(@1W&`+r03%ksN=7wE7;e&gzj&ASS!otPI?pnIP&{g&HQQq_=|UN?E_54 zlVAuhjRyR^+pO1{@4mNDZV~A$)&7^$Xl^!|TlJ0d#iNHtHAD#Y&{O?bL8ywdC^?I( zreacAE!$xhCmm)c^CT`oFP0~nNaFP^9ED?R=zr!9bvvh1WFVCM7?)Zer^C^sw-$Huc-!$)53e zgg*IwFLQ9^#=4Qew5lI}J-Lt2)o+UxWAOM74)1@@_rK?VA~YX-$M-VE8bW7-U#}f3 zy3~XcLKTFb2ED8EK{cqNOg{N3e$}Kd-?6oAYnSjHhY4%jh6-;>Gn0dPtecc5x(oi4 zC!im?7)U`LNyR!D<7I?$&2%+eOjoicn86j33E>LM^;FkWW_AS#6_fBIYf+bG3d5+@ zUYKbyi%^==gUo#lA_YAnqNKizdO|S%+=5bL8|tq->w^->mg?#1O<Ozqou8wpQR;+Ib_ro_CYjBLcr)zgur&$s9)2y|<<~97n-v@Fiq;ItXXOKJJIO z7mlXU@hGxR!eKuc-N&B~{1Kk|L%$b6!h00l5?$W)tbSyW>sdg3#akfOIRtp zP600QIEWWUhKEOn&JVVaDyFuLwr@;)1In3cQ`U3K9_VpLn6sjIPpTTKAs` zb)nOL>~$q|c^q0(t`Q`Lc2GFF;CtO_N~2Tb!~_qjCeYeya2e|O!HaooZ;lBYMO1$` zCQe2U_Xw>!B|??&b;0?$qKmNC?bort3=R9ij$v~aq2A?Sw_tC)*Wv!Nas8405ut|t zP#+V8F1W2nCwqA`Um=7#5&Gcd`kKSo&HsHjfABWMKEK_DP~C3Wb!UJ0r}ldP|L_}j z#EBp==&yJKlA6}9Ci%qVgrZ;7h#_A|f=0h)N@6Pui!DG$kEHVX$OfSq1IDQ~`Dinz zOiEIsu-Aj8CDsuLv2Y*^6m(0(Fw%yc&d~7;l>%K5&?zbUl-$&t5(6&wQW^>%#9BC! zU7VF~fYdgcHc|@Z;#Zzk%@_vJ|9B`&;I>a->-*i9s+eRu73)}Fz4Poqp7mXX?t{~* z2`y>TVSw(KP_zuZ1TG(A2amA+5Qo|XQ){zKF1>*#)~53sG%mhkF@CH8R9H^}XVZQiYKV2wWWqik}+PG46o#L#Vv$HOD|Ll9msa2`s6N}0ToX^6i zoWV|U`#*8r;z{nd!oIX5G}EvF5ZF-`MK4ZmZT$kRXG+}w literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST b/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST new file mode 100644 index 00000000..d81461aa --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST @@ -0,0 +1 @@ +;; (do-test "Subtypep on exclusive ranges" (and (multiple-value-bind (r c) (subtypep 'bit '(unsigned-byte 1)) (and (eq r t) (eq c t))) (multiple-value-bind (r c) (subtypep '(integer 0 2) '(integer (0) 2)) (and (eq r nil) (eq c t)))) ) (do-test "Typep with string-char" (eq (typep 1 'string-char) nil) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/COMMON.TEST b/internal/test/LANGUAGE/AUTO/COMMON.TEST new file mode 100644 index 00000000..8daa2b3b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/COMMON.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for COMMON - 8168 (do-test "#n# reads properly" (consp (cdr #1='("This structure is circular" . #1#))) ) ;;; test for COMMON - 7610 (do-test "Guy Steele Jr. memorial test case" (setq foo '(bar baz)) (setq bar '(barola)) (setq baz '(bazola alozab)) (equal (eval ``(,@,@foo)) '(barola bazola alozab)) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST b/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST new file mode 100644 index 00000000..7aea76ee --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8409: MKATOM should return a single value (do-test "AR 8409" (eql (length (multiple-value-list (il:mkatom "abc"))) 1) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST new file mode 100644 index 00000000..cefdec5b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7875: Report-methods for ILLEGAL-GO and ILLEGAL-RETURN are misspelled. (do-test "AR 7875" (every #'(lambda (x) (not (search "non-existant" (princ-to-string (xcl:make-condition x)) :test 'char-equal))) '(xcl:illegal-go xcl:illegal-return xcl:illegal-throw)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST new file mode 100644 index 00000000..9b961639 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7893: Default handler for STREAM-NOT-OPEN uses TEdit function when TEdit not loaded (do-test "AR 7893" (or (get 'il:tedit 'il:filedates) (null (xcl:condition-handler 'xcl:stream-not-open))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST b/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST new file mode 100644 index 00000000..33970300 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7383: ENTER-DEBUGGER-P should say yes for STORAGE-CONDITIONs (do-test "AR 7383" (il:enter-debugger-p 0 nil (xcl:make-condition 'xcl:storage-condition)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST b/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST new file mode 100644 index 00000000..ff57da7d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8512: System errors get breakwindows the say "In \LISPERROR..." (do-test "AR 8512" (member 'il:\\lisperror il:*debugger-entry-points*) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST b/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST new file mode 100644 index 00000000..f33a44e5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST @@ -0,0 +1,286 @@ +;; Functions To Be Tested: XCL:def-define-type, XCL:defdefiner +;; +;; Source: {ERIS}CML>DOC>DEF-DEFINE-TYPE.TEDIT +;; {ERIS}cml>doc>defdefiner.tedit +;; +;; Created By: Jim Blum +;; +;; Creation Date: Jan 9, 1987 +;; +;; +;; Last Update: FEB 2/16/87 Moved into {ERIS}TEST>FILEMANAGER>DEFDEFINE.TEST +;; +;; +;; Filed As: {ERIS}TEST>FILEMANAGER>DEFDEFINE.TEST +;; +;; Function: defdefinetype +;; +;; Syntax: (defdefinetype name &optional description &key undefiner) +;; +;; Function Description: New kinds of file manager objects can be defined with defdefinetype. +;; +;; Aruments: NAME should be the name of the define type in plural, e.g., FUNCTIONS, VARIABLES, STRUCTURES. + +;; DESCRIPTION is the documentation of this definition type, and should be a string suitable for the sentence + +;; "The following have not been saved on any file: " + + +;; The only keyword currently defined is a global "undefiner" for this definition type. +;; Each individual defdefiner is allowed to define how to "undefine" a given name, +;; but def-define-type also has a shot at removing a definition for all instances of this type, if there is such. + + +;; Function: def-definer +;; +;; Syntax: (def-definer name-and-options type arg-list . body) + +;; +;; Function Description: DefDefiner creates macro named name that creates definitions of type type. +;; DefDefiner arranges that: +;; -- the body will be evaluated if and only if IL:DFNFLG is not one of IL:PROP or IL:ALLPROP +;; -- the form returned by the body will be evaluated in a context in which the file manager has been disabled +;; (so that subordinate definitions like the accessor defun's of defstruct will not be noticed by the file-manager) +;; -- macro-calls to the new definer will return the name of the thing being defined +;; (as DEFUN, DEFMACRO, and others are defined to do) +;; +;; +;; Arguments: name-and-options is a defstruct-style name. That is, it is either a symbol, name, or +;; a list, ie, (name (option . value) ...). +;; type must be a file-manager type previously defined using def-define-type. + +;; The following options are supported: + +;; (:name name-fn) +;; name-fn should be a form acceptable as the argument to cl:function. When name-fn is +;; applied to any form representing a +;; macro-call on the new definer, it should return a Lisp value to be used as the name of the thing +;; being defined, for the purposes of +;; saving the definition with the file-manager and returning the name as the value of the +;; macro-call. name-fn should have no +;; side-effects nor should its workings depend upon any data outside of that provided as an +;; argument. The default value for name-fn is cl:second. + +;; (:prototype-fn defn-fn) + +;; defn-fn should be a form acceptable as the argument to cl:function. When defn-fn is applied to any Lisp value, it should +;; return either NIL or a form that, when evaluated, would create a dummy definition of type type named by that Lisp value. +;; This function can be used by SEdit to provide dummy definitions for names that have no other definition. +;; For example, the defn-fn for DEFUN might be +;; +;; (lambda (name) +;; (and (symbolp name) +;; `(defun ,name ("args") "body"))) +;; The default value for defn-fn is +;; (lambda (name) nil) + + +;; (:undefiner function) +;; a function which will clear any definition of the name given to it. This is an "incremental" undefiner, in that when DELDEF +;; is given the type, it calls all undefiners for all of the types. The undefiner function should be undoable, if at all possible. + + +;; +;; Returns: name of definer if successful or, error if not. +;; + +;; ------------------------------------------------------------------------------ + +;; Use DEF-DEFINE-TYPE to define a new file manager type. +;; Give it a recognisable description string and an undefiner. +;; The undefiner will take a name and remove a certain property +;; (call it PROPERTY-ONE) from that name. +(do-test "define new file manager type" + (and (def-define-type definer-tests "Definer Tests" + :undefiner (lambda (name) + (remprop name 'property-one))))) + +;; Use DEFDEFINER to define a definer of the new type. +;; Use the :NAME option in some non-trivial way to make a new +;; name. The effect of the definer will be to put T onto the +;; properties PROPERTY-ONE and PROPERTY-TWO of the name. Use +;; the :UNDEFINER option to remove only PROPERTY-TWO from the +;; name. In conjunction with the undefiner on the type, this +;; will clear the whole effect of the definer. + +(do-test "define a new definer of the new type" + (and (defdefiner (def-test-one + (:name (lambda (whole) + (intern (concatenate 'string + "FOO--" + (string (second whole)))))) + (:undefiner (lambda (name) + (remprop name 'property-two)))) + definer-tests + (proto-name value-one value-two) + (let ((name (intern (concatenate 'string "FOO--" (string proto-name))))) + `(progn (setf (get ',name 'property-one) ',value-one) + (setf (get ',name 'property-two) ',value-two)))))) + +;; Also use DEFDEFINER to definer another definer for the new +;; type using neither :NAME nor :UNDEFINER. The effect of this +;; definer would be to only give the name the property PROPERTY-ONE. + +(do-test "use DEFDEFINER to definer another definer for the newtype using neither :NAME nor :UNDEFINER" + (and (defdefiner def-test-two definer-tests (name value-one) + `(setf (get ',name 'property-one) ',value-one)))) + +;; With DFNFLG bound to NIL, use both definers to make objects +;; of the new type. These definitions should take effect. Use +;; SEdit-style comments to test that they get properly stripped. + +(do-test "make objects of the new type which take effect" + (and (let ((il:dfnflg nil)) + (declare (special il:dfnflg)) + + (def-test-one (il:* il:|;| "An SEdit-style comment") + one-1 + (il:* il:|;;| "An SEdit-style comment") + 1 + (il:* il:|;;;| "An SEdit-style comment") + 2) + + (def-test-two (il:* il:|;| "An SEdit-style comment") + two-1 + (il:* il:|;;| "An SEdit-style comment") + (il:* il:|;;;| "An SEdit-style comment") + 3)))) + +;; With DFNFLG bound to PROP, again use both definers. Neither +;; of these should take effect. + +(do-test "make objects of the new type with DFNFLG = PROP which should not take effect" + (and (let ((il:dfnflg 'il:prop)) + (declare (special il:dfnflg)) + + (def-test-one (il:* il:|;| "An SEdit-style comment") + one-2 + (il:* il:|;;| "An SEdit-style comment") + 1 + (il:* il:|;;;| "An SEdit-style comment") + 2) + + (def-test-two (il:* il:|;| "An SEdit-style comment") + two-2 + (il:* il:|;;| "An SEdit-style comment") + (il:* il:|;;;| "An SEdit-style comment") + 3)))) + +;; With DFNFLG bound to ALLPROP, once again use both definers. +;; Neither of these should take effect either. + +(do-test "make objects of the new type with DFNFLG bound to ALLPROP which should not take effect" + (and (let ((il:dfnflg 'il:allprop)) + (declare (special il:dfnflg)) + + (def-test-one (il:* il:|;| "An SEdit-style comment") + one-3 + (il:* il:|;;| "An SEdit-style comment") + 1 + (il:* il:|;;;| "An SEdit-style comment") + 2) + + (def-test-two (il:* il:|;| "An SEdit-style comment") + two-3 + (il:* il:|;;| "An SEdit-style comment") + (il:* il:|;;;| "An SEdit-style comment") + 3)))) + +;; Check that the define-type, both definers, and all six uses +;; of the definers got marked as changed. + +(do-test "Check that the define-type, both definers, and all six uses of the definers got marked as changed" +(and (flet ((is-changed (name type) + (let ((changes-var (first (find type il:prettytypelst + :key 'second)))) + (member name (symbol-value changes-var))))) + (and (is-changed 'definer-tests 'il:define-types) + (is-changed 'def-test-one 'il:functions) + (is-changed 'def-test-two 'il:functions) + (is-changed 'foo--one-1 'definer-tests) + (is-changed 'foo--one-2 'definer-tests) + (is-changed 'foo--one-3 'definer-tests) + (is-changed 'two-1 'definer-tests) + (is-changed 'two-2 'definer-tests) + (is-changed 'two-3 'definer-tests))))) + +;; Check that the define-type got installed with the +;; right description name. + +(do-test "Check that the define-type got installed with the right description name" + (equal "Definer Tests" (third (find 'definer-tests il:prettytypelst + :key 'second)))) + +;; Check that all six uses of the definers got putdef'd correctly. + + +(do-test "Check that all six uses of the definers got putdef'd correctly" + (and (equal (il:getdef 'foo--one-1 'definer-tests) + '(def-test-one (il:* il:|;| "An SEdit-style comment") + one-1 + (il:* il:|;;| "An SEdit-style comment") + 1 + (il:* il:|;;;| "An SEdit-style comment") + 2)) + (equal (il:getdef 'two-1 'definer-tests) + '(def-test-two (il:* il:|;| "An SEdit-style comment") + two-1 + (il:* il:|;;| "An SEdit-style comment") + (il:* il:|;;;| "An SEdit-style comment") + 3)) + (equal (il:getdef 'foo--one-2 'definer-tests) + '(def-test-one (il:* il:|;| "An SEdit-style comment") + one-2 + (il:* il:|;;| "An SEdit-style comment") + 1 + (il:* il:|;;;| "An SEdit-style comment") + 2)) + (equal (il:getdef 'two-2 'definer-tests) + '(def-test-two (il:* il:|;| "An SEdit-style comment") + two-2 + (il:* il:|;;| "An SEdit-style comment") + (il:* il:|;;;| "An SEdit-style comment") + 3)) + (equal (il:getdef 'foo--one-3 'definer-tests) + '(def-test-one (il:* il:|;| "An SEdit-style comment") + one-3 + (il:* il:|;;| "An SEdit-style comment") + 1 + (il:* il:|;;;| "An SEdit-style comment") + 2)) + (equal (il:getdef 'two-3 'definer-tests) + '(def-test-two (il:* il:|;| "An SEdit-style comment") + two-3 + (il:* il:|;;| "An SEdit-style comment") + (il:* il:|;;;| "An SEdit-style comment") + 3)))) + +;; Check that only the first two uses took effect. + +(do-test "Check that only the first two uses took effect" + (and (= 1 (get 'foo--one-1 'property-one)) + (= 2 (get 'foo--one-1 'property-two)) + (= 3 (get 'two-1 'property-one)) + (null (get 'two-1 'property-two)) + (null (get 'foo--one-2 'property-one)) + (null (get 'foo--one-2 'property-two)) + (null (get 'two-2 'property-one)) + (null (get 'two-2 'property-two)) + (null (get 'foo--one-3 'property-one)) + (null (get 'foo--one-3 'property-two)) + (null (get 'two-3 'property-one)) + (null (get 'two-3 'property-two)))) + +;; Use DELDEF on each of the first two uses and check that all of the appropriate REMPROP's +;; happened. Also check that those two uses are no longer marked as changed and that HASDEF returns NIL for both. + +(do-test "DELDEF test" + (and (il:deldef 'foo--one-1 'definer-tests) + (il:deldef 'two-1 'definer-tests) + (null (get 'foo--one-1 'property-one)) + ; (null (get 'foo--one-1 'property-two)) + (null (get 'two-1 'property-one)) + (null (get 'two-1 'property-two)) + ; (null (il:hasdef 'foo--one-1 'definer-tests)) + ; (null (il:hasdef 'two-1 'definer-tests)))) +STOP HELVETICA HELVETICA/"/"zş \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST b/internal/test/LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST new file mode 100644 index 00000000..c190bfc6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST @@ -0,0 +1 @@ + ;;; Additional tests for testing the structure facilities. ;;; Greg Nuyens (xcl-test:do-test-group "standard behavior" :before (progn (defstruct tname a b) (defstruct (s2 (:include tname)) c)) (xcl-test:do-test "constructor keywords" (and (setq in (make-tname :a 3 :b '~b~)) (eq (tname-a in) 3) (eq (tname-b in) '~b~))) (xcl-test:do-test "prebuilt predicates" (tname-p in)) (xcl-test:do-test "simple inheritance" (setq sub (make-s2)) (and (tname-p sub)(s2-p sub))) (xcl-test:do-test "#s form for constructors" (equalp '#s(tname a 3 b 2) (make-tname :a 3 :b 2))) (xcl-test:do-test "try named constructors" (and (defstruct (t6 (:constructor my-make-t6)) a) (t6-p (setq in (my-make-t6 :a 3))) (equal (t6-a in) 3))) (xcl-test:do-test "try the copier" (let ((in (make-tname :a 3 :b 2))) (equalp in (copy-tname in)))) (xcl-test:do-test "setfs?" (let ((in (make-tname))) (setf (tname-b in) 'this) (equal (tname-b in) 'this)))) ); end of use of tname (xcl-test:do-test "defstruct lexical inits" (let ((var1 '~init~)) (defstruct t7 (a var1) b) (equal var1 (t7-a (make-t7))) (setq var1 33) (equal 33 (t7-a (make-t7))) (setq var1 40) (equal 40 (t7-a (make-t7))) (equal 99 (t7-a (make-t7 :a 99))))) (xcl-test:do-test-group "t8 and t9 tests" :before (progn (defstruct t8 (a 0.0 :type short-float) (b 'this :type symbol)) (defstruct t9 a (b 'this :read-only t))) (xcl-test:do-test "slot types" (let ((in (make-t8))) (and (setf (t8-a in) 1.2) (setf (t8-b in) 'foo) (equal (t8-a in) 1.2) (equal (t8-b in) 'foo)))) (xcl-test:do-test "read-only slots" (let ((in (make-t9))) (and (setf (t9-a in) 1.2) (xcl-test:expect-errors xcl:condition (setf (t9-b in) 'foo)) ))) ) ; end "t8 and t9 tests" (xcl-test:do-test "lexical init forms" (and (let ((a 'this)) (defstruct that (a a)))) (eq 'this (that-a (make-that)))) (xcl-test:do-test "simple vector structure" (and (defstruct (vfoo :named (:type vector)) (bar 1.0) (loo 2.0) baz) (let ((vfoo (make-vfoo :baz 'Me!))) (and (eq (vfoo-baz vfoo) 'Me!) (vfoo-p vfoo))))) (xcl-test:do-test "included named vector type" (and (defstruct (vfoo2 :named (:type vector) (:include vfoo) (:initial-offset 2)) this) (let ((vfoo2 (make-vfoo2 :bar 'one :loo 'two :baz 'three :this 'four))) (and (vfoo-p vfoo2) (vfoo2-p vfoo2) (eq (vfoo2-this vfoo2) 'four) (eq (vfoo2-baz vfoo2) 'three))))) (xcl-test:do-test "simple list structure" (and (defstruct (lfoo :named (:type list)) (bar 1.0) (loo 2.0) baz) (let ((lfoo (make-lfoo :baz 'Me!))) (and (eq (lfoo-baz lfoo) 'Me!) (lfoo-p lfoo))))) (xcl-test:do-test "included named list type" (and (defstruct (lfoo2 :named (:type list) (:include lfoo) (:initial-offset 2)) this) (let ((lfoo2 (make-lfoo2 :bar 'one :loo 'two :baz 'three :this 'four))) (and (lfoo-p lfoo2) (lfoo2-p lfoo2) (eq (lfoo2-this lfoo2) 'four) (eq (lfoo2-baz lfoo2) 'three))))) (xcl-test:do-test "simple BOA" (and (defstruct (snake (:constructor snake-make (a b))) a b) (snake-p (snake-make 1 2)))) (xcl-test:do-test "not so simple BOA" (and (defstruct (snake2 (:constructor snake-make2 (a &optional b (c 'sea) &rest d &aux e (f 'eff)))) a (b '3) c d e f ) (snake2-p (snake-make2 1 2)))) (xcl-test:do-test "circle-printing" (let ((*print-circle* t)) (defstruct loopy a b) (let ((loopy (make-loopy :a '(this and that)))) (setf (loopy-b loopy) loopy) (eq "#1-#s(loopy a (this and that) b #1#)" (format nil "~S" loopy))))) (xcl-test:do-test "try the inline extension" (and (defstruct (bebop (:inline nil)) rhythm) (let ((what (make-bebop :rhythm 'you-bet!))) (and (eq 'you-bet! (bebop-rhythm what)) (eq 45 (setf (bebop-rhythm what) 45)) (eq 45 (bebop-rhythm what)))))) (xcl-test:do-test "try the inline extension some more" (and (defstruct (bobep (:inline :predicate)) rhythm) (let ((what (make-bobep :rhythm 'you-bet!))) (and (eq 'you-bet! (bobep-rhythm what)) (eq 45 (setf (bobep-rhythm what) 45)) (eq 45 (bobep-rhythm what)))))) (xcl-test:do-test "suppressing copier and predicate" (and (defstruct (goz (:predicate nil) (:copier nil)) a) (not (fboundp 'goz-p)) (not (fboundp 'copy-goz)))) il:stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST new file mode 100644 index 0000000000000000000000000000000000000000..2664a2c27d1283680a609fd6f656a50c48d7823f GIT binary patch literal 1837 zcma)7;cnYT3|7`|fK?P2us{2;0fh4-C!-4DIi3w0L7^pX8z8X**?EAIb#jDBI_>V{ z#Cf7V!=A3>$#LX11sXs$#Upv&_mOnQ7n2Y3MRTGQ{o%kJ zFN8L5&b1i9EYd=)1(-W-ppdWEcv%XrKo)o+AX~~DWC9!#{;%-ytxPlFC-`v` z1AW1LYVPnn7Kt{hS{h1C%`warD1o(%h_emke5s^(D0vYBdyY+{#N5aO@~1|Ft|E+5 zLhDo(8qxyhBF1v=*irz43`7jwp&yhAt~M%Nx-N^QPY2KrLdzFvU+nNyT43F^5(z;o zWZ~;HFA@1#ER9sU?Y0_-7(rqqvnd6zIs%eRa^ra(M5s)}A3e;-gaO7LfaN3%C5`B` zd;Av}kI*|l#SFLAVwN)1E8zi-zN(1g-9s z_YQ`=zfat8E0L<<7?E;8s7W^p!{{GS4lC^`N7OV_McsBDp=L|$ifuDqm*9!PHq|3A zDtL~aktMmluW6QQ<3SyaZO7iDnBu>RXU|f4C=)4Kq!~Rmb7)c@4EnwOwv&gzKdr!# zhJR)OPV5e^hFBIy25=r|T6vWjSo5qBFHb-t6Q_6EV}@9OaTri*u}OovMZAH%MqBUU zZ8-67!prFbkqu6J1Kh*Y-f#!pUnyCYz}lTsrG@dAsaj^D18aQ@TURZ1r9=lMZM8;` zz((U_KCjS9@$wGGIu@EHWN#PfPQ1FV3mK0@h8v#U^Nog;1S6rN4bCT5u`erAR)(&j z+3w(Q+fA_45k*?8wjn;g37*^G24LS*0L-Jor?Z;ZGYK%;6PojSbu4}o4HrQRlK`_G z-!h_&vukIM?^SAqUBc0pk}bz-cxRX?%sxoMipVV_XdiaZ4(IG+7~Fh<>Fi=Mhr{ln z*R~z|TDRd=w<<%VI|BGaB6DHV9QOh*gG}PD4$q9lmph>v;ysPTmR_w#)Z~myKurU_ zQ}PA1z9S1qQR*Yh52;&id?TM2bJ)|U)q08jw_?<4c=%_sB4>|^pCEJst%e;oMm048J1b;PDbV01k6x>17BCvbvLYFi-C z7K|OP*H$|&Q%twU;+KvQ^j5rJDUMAR0~HK9+dz&X5ew3XWnvt-gbKTXQ1rrSN0|;S zLRO@qxO+RpNoChiXHpKlqiSb$z(K@`=6YUyJH`~4$U-b9ySqM&NvLWMmhuw|Y*KW6 zn4KgDKX`h1_V2+_ip@sBb~(wNo~NqUQ7zT0yF+QWj;DY9h3KzU=QS8j19f>qw}n#b Ys=}I#2Dmu~e$RngePn6fs_xJJ4<9pUWB>pF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/ERROR-RUNTIME-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/ERROR-RUNTIME-REGRESSION.TEST new file mode 100644 index 00000000..66da6b6c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/ERROR-RUNTIME-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression tests for ERROR-RUNTIME patches ;; Patch 1. (do-test "AR 7563: Default filter function for unnamed proceed cases" (not (expect-errors (error) (proceed-case (compute-proceed-cases) (nil nil :report "This one")) )) ) (do-test-group ("AR 7564" :before (progn (il:remprop 'foo 'il:%proceed-arg-collector) (defun foo () '(1 2 3)))) (do-test "AR 7564: INVOKE-PROCEED-CASE v. defined functions" (not (expect-errors (error) (proceed-case (progn (invoke-proceed-case (find-proceed-case 'foo)) nil) (foo () t)) )) ) ) ;; Patch 2. (do-test "ECASE report" (macrolet ((capture-error-message (form) `(condition-case ,form (error (c) (write-to-string c :case :downcase :escape nil))))) (and (equal (capture-error-message (ecase "foo" (x 1) (y 2))) "\"foo\" is neither x nor y.") (equal (capture-error-message (ecase (+ 1 2) (x 1) (y 2))) "The value of (+ 1 2), 3,is neither x nor y.") ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST new file mode 100644 index 00000000..d4a5498f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Incidental evaluator regression tests (do-test "simple lexical binding" (= 3 (let ((a 3)) a))) (do-test-group "simple special binding" :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (special a)) b)) (defun goo () (declare (special a )) a)) (do-test "special 1" (let ((a 3)) (declare (special a)) (eq (goo) 3))) (do-test "special reference in let value form" (let ((a 'outer)) (declare (special a )) (eq (goo2) 'outer)))) ;; now try with specvars for references. (do-test-group "using il:specvars in declare for bindings." :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (il:specvars a)) b)) (defun goo () (declare (il:specvars a )) a)) (do-test "special 1" (let ((a 3)) (declare (il:specvars a)) (eq (goo) 3))) (do-test "special reference in let value form" (let ((a 'outer)) (declare (il:specvars a )) (eq (goo2) 'outer)))) ;; from AR's (do-test "#' finding lexical functions AR 5995" (equal '(2) (flet ((bar (n) (1+ n))) (mapcar #'bar '(1))))) (do-test "THROW vs. closures AR 6092" (let ((this-one t)) (catch 'foo (let ((closure #'(lambda () (throw 'foo this-one)))) (funcall closure) (values nil) ) ) )) (do-test "Interpreted &ALLOW-OTHER-KEYS AR 6122" (eq ((lambda (&key key &allow-other-keys) 'ok)) 'ok) ) (do-test "Interpreter: invalid keywords ar 6123" (expect-errors (error) ((lambda (&key foo) 'foo) :bar 'bar)) ) (do-test "value of eval-when 6252" (equal 3 (eval-when(eval) 3))) (do-test "simple special in let* ar 6369" (eq t (let* (x) (declare (special x)) t))) (do-test "shadowing flets ar 6734" (eq 4 (flet ((foo () 3)) (flet ((foo () 4)) (foo))))) (do-test "interaction of FLET and MACROLET AR 7127" (= 17 (macrolet ((foo (x) `(bar ,x))) (flet ((bar (y) (+ 1 y))) (foo 16))))) (do-test "setq of lexical variable." (eq 4 (let ((foo 3)) (setq foo 4) foo))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/EVENP.TEST b/internal/test/LANGUAGE/AUTO/EVENP.TEST new file mode 100644 index 00000000..46401116 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/EVENP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EVENP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-EVENP.TEST ;; ;; ;; Syntax: (EVENP NUMBER &OPTIONAL MODULUS) ;; ;; Function Description: ;; This predicate is true if the argument INTEGER is even (divisible ;; by two), and otherwise is false. It is an error if the argument is not ;; an integer. ;; ;; Argument(s): NUMBER - a number ;; MODULUS - an integer ;; ;; Returns: T or NIL ;; (do-test evenp-test (and (evenp 2) (evenp -4) (not (evenp 3)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST new file mode 100644 index 00000000..e22b4d0a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST @@ -0,0 +1 @@ +;;;; Regression tests for Lyric FASDUMP patches ;;; AR 8655: FASL dumps some integers incorrectly (do-test ("AR 8655: Dump integers s.t. (mod (integer-length x) 8) = 0" :before (let ((fasl::check-table-size nil)) (fasl:with-open-handle (fh "{core}test.dfasl") (princ "Test dumping large integers" (fasl:begin-text fh)) (fasl:begin-block fh) (fasl:dump-value fh (expt 2 31)))) :after (ignore-errors (il:delfile "{core}test.dfasl"))) (with-open-file (s "{core}test.dfasl") (let ((once nil) (ok nil)) (fasl:process-file s :item-fn #'(lambda (x) (if once (setf ok nil) (progn (setf once t ok (eql x (expt 2 31))))))) ok) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST new file mode 100644 index 00000000..ca0552c1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression tests for FASLOAD-PATCHES ;; Patch 2. (do-test-group ("Patch 2 tests" :before (progn (fasl:with-open-handle (h "{core}test.dfasl") (princ "This is a test." (fasl:begin-text h))) (with-open-file (s "{core}test.dfasl" :direction :output :if-exists :append) (write-byte 64 s))) :after (ignore-errors (il:delfile "{core}test.dfasl"))) (do-test "Observe end-of-data mark" (with-open-file (s "{core}test.dfasl" :direction :input) (null (expect-errors (error) (fasl:process-file s)))) ) (do-test "Don't print anything when loading :verbose nil" (and (equal (with-output-to-string (*standard-output*) (load "{core}test.dfasl" :verbose nil)) "") (equal (with-output-to-string (*standard-output*) (load "{core}test.dfasl" :verbose t)) "This is a test. ") ) ) ) (do-test-group "Compatible with old FASL versions" :before (with-open-file (s "{core}test.dfasl" :direction :output) (map nil #'(lambda (byte) (write-byte byte s)) (list fasl:signature 0 4 fasl::end-mark fasl::end-mark))) :after (ignore-errors (il:delfile "{core}test.dfasl")) (do-test "Read old FASL file" (null (expect-errors (error) (with-open-file (s "{core}test.dfasl" :direction :input) (fasl:process-file s)))) ) ) (DO-TEST-GROUP "Reader environment hackery" :BEFORE (FASL:WITH-OPEN-HANDLE (H "{core}test.dfasl") (PRINC "This file tests reader environment hacking." (FASL:BEGIN-TEXT H)) (FASL:BEGIN-BLOCK H) (FASL:DUMP-EVAL H '(LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (FASL:DUMP-EVAL H '(PROGN (SETQ *PRINT-BASE* 7) (SETQ *READ-BASE* 12) (SETQ *PACKAGE* (FIND-PACKAGE "FASL")) (SETQ *READTABLE* (IL:FIND-READTABLE "OLD-INTERLISP-T")) (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)))) :AFTER (IGNORE-ERRORS (IL:DELFILE "{core}test.dfasl")) (DO-TEST "Ensure reader environment not affected" (IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT* (LET ((OLD-VALUES (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (FORM-COUNT 0)) (BLOCK READER-ENVIRONMENT-TEST (WITH-OPEN-FILE (S "{core}test.dfasl" :DIRECTION :INPUT) (FASL:PROCESS-FILE S :TEXT-FN #'(LAMBDA (S) (UNLESS (EQUAL S "This file tests reader environment hacking.") (RETURN-FROM READER-ENVIRONMENT-TEST NIL))) :ITEM-FN #'(LAMBDA (X) (CASE (INCF FORM-COUNT) (1 (UNLESS (EVERY #'EQL X OLD-VALUES) (RETURN-FROM READER-ENVIRONMENT-TEST NIL))) (2 (UNLESS (AND (EVERY #'EQL OLD-VALUES (IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT* (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))) (EVERY #'EQL X (LIST (FIND-PACKAGE "FASL") (IL:FIND-READTABLE "OLD-INTERLISP-T") 12 7))) (RETURN-FROM READER-ENVIRONMENT-TEST NIL)))))) ) ) (EVERY #'EQL OLD-VALUES (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST new file mode 100644 index 00000000..89d58fe1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the File Manager (do-test "AR 7737: (HASDEF & 'FILES) shouldn't create new symbols" (let ((name (il:gensym))) (and (null (il:hasdef name 'il:files)) (null (find-symbol (il:concat name "COMS") "INTERLISP"))))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FIXP.TEST b/internal/test/LANGUAGE/AUTO/FIXP.TEST new file mode 100644 index 00000000..b9f8d938 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FIXP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FIXP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>FixP.test ;; ;; (do-test "test simple cases" (and (eq 5 (il:fixp 5)) (equal 100000 (il:fixp 100000)) (eq nil (il:fixp 10.13)) (eq nil (il:fixp 'a-fixp)) (eq nil (il:fixp "a string")) )) (do-test "Test fixed numbers" (and (eq 123 (il:fixp 123)) (eq -4567 (il:fixp -4567)) (equal 1237654 (il:fixp 1237654)) (equal -4567321 (il:fixp -4567321)) )) (do-test "Test go on own function" (flet ((temp-small nil 2) (temp-large nil 100000)) (test-defun temp-fun nil -325) (and (eq 2 (il:fixp (temp-small))) (equal 100000 (il:fixp (temp-large))) (equal -325 (il:fixp (temp-fun))) ))) (do-test "Test work against system functions" (and (eq 3 (il:fixp (third '(1 2 3 4 5)))) (equal 3300000 (il:fixp (car '(3300000 2.2 1.1)))) (equal -23123456 (il:fixp (second '(1 -23123456 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:fixp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:fixp 'A-couple-dashs)) (eq nil (il:fixp 'Numbers-1234567890)) (eq nil (il:fixp 'il:other-packags)) (eq nil (il:fixp 'il:other-packagsNumbers-1234567890)) (eq nil (il:fixp 'il:other-packagsA-couple-dashs)) (eq nil (il:fixp T)) (eq nil (il:fixp nil)) (eq nil (il:fixp ())) (eq nil (il:fixp '())) (eq nil (il:fixp (list))) (eq nil (il:fixp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:fixp (tee))) (eq nil (il:fixp (nill))) (eq nil (il:fixp (temp-litatom))) (eq nil (il:fixp (temp-string))) (eq nil (il:fixp (temp-fun))) (eq nil (il:fixp temp-litatom)) ))) (do-test "Stop on fixps from system functions" (and (eq nil (il:fixp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:fixp (second '(#\. #\k)))) )) (do-test "Test arrays aren't fixps" (and (eq nil (il:fixp (make-array '(2 2)))) (eq nil (il:fixp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:fixp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:fixp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:fixp (make-array 50 :initial-element 0))) (eq nil (il:fixp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't fixps" (and (eq nil (il:fixp #\backspace)) ; character (eq nil (il:fixp #\*)) ; character (eq nil (il:fixp #\.)) ; character (eq nil (il:fixp (make-hash-table))) ; hash table (eq nil (il:fixp (car (list-all-packages)))) ; packages (eq nil (il:fixp (pathname nil))) ; pathname (eq nil (il:fixp *random-state*)) ; ramdom state (eq nil (il:fixp #'cons)) ; compiled function (eq nil (il:fixp (copy-readtable))) ; readtable (eq nil (il:fixp #*1001)) ; simple-bit-vector (eq nil (il:fixp "twine")) ; simple-string (eq nil (il:fixp (make-synonym-stream nil))) ; stream (eq nil (il:fixp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FLOATP.TEST b/internal/test/LANGUAGE/AUTO/FLOATP.TEST new file mode 100644 index 00000000..cf4d85b1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FLOATP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FLOATP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>FloarP.test ;; ;; (do-test "test simple cases" (and (equal 5.9 (il:floatp 5.9)) (equal -10.13 (il:floatp -10.13)) (eq nil (il:floatp -5)) (eq nil (il:floatp 1000000)) (eq nil (il:floatp 'a-floatp)) (eq nil (il:floatp "a string")) )) (do-test "Test floating numbers" (and (equal 123.0 (il:floatp 123.0)) (equal 45.67 (il:floatp 45.67)) (equal 37e5 (il:floatp 37e5)) (equal .001 (il:floatp .001)) )) (do-test "Test go on own function" (flet ((temp-small nil -1.2) (temp-large nil 100000.01) (temp-floating nil 12.2)) (test-defun temp-fun nil 32e5) (and (equal -1.2 (il:floatp (temp-small))) (equal 100000.01 (il:floatp (temp-large))) (equal 12.2 (il:floatp (temp-floating))) (equal 32e5 (il:floatp (temp-fun))) ))) (do-test "Test work against system functions" (and (equal 1.2 (il:floatp (third '(1 2 1.2 4 5)))) (equal -3.3 (il:floatp (car '(-3.3 2.2 1.1)))) (equal 10101012.3 (il:floatp (second '(1 10101012.3 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:floatp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:floatp 'A-couple-dashs)) (eq nil (il:floatp 'Numbers-1234567890)) (eq nil (il:floatp 'il:other-packags)) (eq nil (il:floatp 'il:other-packagsNumbers-1234567890)) (eq nil (il:floatp 'il:other-packagsA-couple-dashs)) (eq nil (il:floatp T)) (eq nil (il:floatp nil)) (eq nil (il:floatp ())) (eq nil (il:floatp '())) (eq nil (il:floatp (list))) (eq nil (il:floatp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:floatp (tee))) (eq nil (il:floatp (nill))) (eq nil (il:floatp (temp-litatom))) (eq nil (il:floatp (temp-string))) (eq nil (il:floatp (temp-fun))) (eq nil (il:floatp temp-litatom)) ))) (do-test "Stop on floatps from system functions" (and (eq nil (il:floatp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:floatp (second '(#\. #\k)))) )) (do-test "Test arrays aren't floatps" (and (eq nil (il:floatp (make-array '(2 2)))) (eq nil (il:floatp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:floatp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:floatp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:floatp (make-array 50 :initial-element 0))) (eq nil (il:floatp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't floatps" (and (eq nil (il:floatp #\backspace)) ; character (eq nil (il:floatp #\*)) ; character (eq nil (il:floatp #\.)) ; character (eq nil (il:floatp (make-hash-table))) ; hash table (eq nil (il:floatp (car (list-all-packages)))) ; packages (eq nil (il:floatp (pathname nil))) ; pathname (eq nil (il:floatp *random-state*)) ; ramdom state (eq nil (il:floatp #'cons)) ; compiled function (eq nil (il:floatp (copy-readtable))) ; readtable (eq nil (il:floatp #*1001)) ; simple-bit-vector (eq nil (il:floatp "twine")) ; simple-string (eq nil (il:floatp (make-synonym-stream nil))) ; stream (eq nil (il:floatp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST b/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST new file mode 100644 index 00000000..cb884870 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7912: Arg not a NUMBER error when format ~:R given RATIO (do-test "AR 7912" (expect-errors (il:format-error) (format nil "~:R" 1/2)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST new file mode 100644 index 0000000000000000000000000000000000000000..775a9b9411270826f6ade04f5c01785467f71cc3 GIT binary patch literal 603 zcma)&U2B6d6o%6>C=+_W%R_EvM2p|+gfV66Cinp^`vHS#5jF*NH@om(^=9nHEwL-3 z#X=8xlb1Kib4bLuM(K;L2V6Go$7`=pr7bpX(REc*W8qTl`nIY!cOdTep|0Km4>~QI z1{1&lqalJI9+QGoq%g}9k3t&7jHDT|E$i}4fWcU4re@u8sxdls6)38W$rN2Wi|)g~ zhARy|1`{l>8Jw@?G&Da2J$SsVtMav!Ga{o&M^!eT?KIqR71uedf#Y(xP7eRvb#^Hs zh}Q+0qbszeQ4&1oS>mN=Ip%!2N1Esdq4yHgFiRK(uI!>80S=`K+#-=<0rZM5^cxJIre*Ti#7A?NMe*y8FkGcQ= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST new file mode 100644 index 00000000..456af393 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for floating-point printing ;;; Basically checks accuracy of normal numbers ;;; and whether extreme numbers print at all ;;; (denormalized numbers can't have read-print consistency) (do-test "fp-accuracy" (and (string= (write-to-string 1.2345678) "1.2345678") (string= (write-to-string -1.2345678) "-1.2345678") (string= (write-to-string 6.02e23) "6.02E+23") (string= (write-to-string 654.32) "654.32") )) (do-test "fp-extremity" (and (ignore-errors (write-to-string il:max.float)) (ignore-errors (write-to-string il:min.float)) (ignore-errors (write-to-string 3e-40)) ; denormalized # (ignore-errors (write-to-string -5e-45)) )) ;;; AR 7427 test: IL:FLTSTR was losing when it had to round a number to zero ;;; decimal places. (do-test "fp-round-to-integer" (and (string= (format nil "~4,0F" 31.4159) " 31.") (string= (format nil "~4,0F" 31.6159) " 32.") )) ;;AR 7616 test: 1e7 was printing as 1.E+7 and should print as 1.0E+7 (do-test "fp-print-at-least-one-decimal-place" (string= (write-to-string (read-from-string "1e7")) "1.0E+7")) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/HARRAYP.TEST b/internal/test/LANGUAGE/AUTO/HARRAYP.TEST new file mode 100644 index 00000000..35084e83 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/HARRAYP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: HArrayP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>HArrayP.test ;; ;; (do-test "test simple cases" (let* ((temp-harray1 (il:hasharray 5)) (temp-harray2 (il:hasharray 3 1.7))) (and (equal temp-harray1 (il:harrayp temp-harray1)) (equal temp-harray2 (il:harrayp temp-harray2)) (eq nil (il:harrayp -5)) (eq nil (il:harrayp 1000000)) (eq nil (il:harrayp 'a-floatp)) (eq nil (il:harrayp 12.34)) ))) (do-test "Test various combinations" (let* ((temp-harray1 (il:hasharray 3 5)) (temp-harray2 (il:hasharray 10 2.5)) (temp-harray3 (il:hasharray 4 nil))) (and (equal temp-harray1 (il:harrayp temp-harray1)) (equal temp-harray2 (il:harrayp temp-harray2)) (equal temp-harray3 (il:harrayp temp-harray3)) ))) (do-test "Test go on own function" (flet ((temp-small nil (il:hasharray 3))) (test-defun temp-fun nil (make-hash-table)) (and (il:harrayp (temp-small)) (il:harrayp (temp-fun)) ))) (do-test "Try various types of Litatoms" (and (eq nil (il:harrayp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:harrayp 'A-couple-dashs)) (eq nil (il:harrayp 'Numbers-1234567890)) (eq nil (il:harrayp 'il:other-packags)) (eq nil (il:harrayp 'il:other-packagsNumbers-1234567890)) (eq nil (il:harrayp 'il:other-packagsA-couple-dashs)) (eq nil (il:harrayp T)) (eq nil (il:harrayp nil)) (eq nil (il:harrayp ())) (eq nil (il:harrayp '())) (eq nil (il:harrayp (list))) (eq nil (il:harrayp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:harrayp (tee))) (eq nil (il:harrayp (nill))) (eq nil (il:harrayp (temp-litatom))) (eq nil (il:harrayp (temp-string))) (eq nil (il:harrayp (temp-fun))) (eq nil (il:harrayp temp-litatom)) ))) (do-test "Stop on harrayps from system functions" (and (eq nil (il:harrayp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:harrayp (second '(#\. #\k)))) )) (do-test "Test other datatypes aren't lists" (and (eq nil (il:harrayp #\backspace)) ; character (eq nil (il:harrayp #\*)) ; character (eq nil (il:harrayp #\.)) ; character (eq nil (il:harrayp (car (list-all-packages)))) ; packages (eq nil (il:harrayp (pathname nil))) ; pathname (eq nil (il:harrayp *random-state*)) ; ramdom state (eq nil (il:harrayp #'cons)) ; compiled function (eq nil (il:harrayp (copy-readtable))) ; readtable (eq nil (il:harrayp #*1001)) ; simple-bit-vector (eq nil (il:harrayp "twine")) ; simple-string (eq nil (il:harrayp (make-synonym-stream nil))) ; stream (eq nil (il:harrayp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST b/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST new file mode 100644 index 00000000..fab2f6ea --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST @@ -0,0 +1 @@ +;; AR7587-HASH.TEST ;; Filed as {ERIS}TEST>CMLDOC>AR7587-HASH.TEST ;; By Peter Reidy ;; Verify that (macroexpand '(setf (gethash...) does not use gensyms or gentemps. (do-test-group AR7587 :before (test-defun gentrim (charpart symbol) "Extract the integer part of a gensym or gentemp." (parse-integer (string-trim charpart (symbol-name symbol))) ) (do-test AR7587-test ;; See that the integer parts of generated symbols advance exactly once before and after execution of the SETF - i.e. that the SETF itself did not advance the counter. (let ((beforesym (gentrim "#:G" (gensym)))(beforetemp (gentrim "T" (gentemp)))) (macroexpand '(setf (gethash il:*definition-hash-table* x) y)) (and (= (1+ beforesym (gentrim "#:G" (gensym)))) (= (1+ beforetemp (gentrim "T" (gentemp)))) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/HASHARRAY.TEST b/internal/test/LANGUAGE/AUTO/HASHARRAY.TEST new file mode 100644 index 00000000..f06716e7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/HASHARRAY.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: All of chapter 6 of the IRM ;; ;; Source: IRM, p 6.1 ;; ;; Chapter 6: HashArray ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>HashArray.test ;; ;; (do-test "test hasharray" (and (il:harrayp (il:hasharray 5)) (il:harrayp (il:hasharray 3 1.7)) T )) (do-test "test harray" (and (il:harrayp (il:harray 5)) (il:harrayp (il:harray 10)) T )) (do-test "test harrayprop" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (equal 0 (il:harrayprop tempx 'il:numkeys)) (equal 0 (il:harrayprop tempy 'il:numkeys)) (equal nil (il:harrayprop tempx 'il:overflow)) (equal 1.7 (il:harrayprop tempy 'il:overflow)) (equal 1.7 (il:harrayprop tempy 'il:overflow 1.8)) (equal 1.8 (il:harrayprop tempy 'il:overflow)) ))) (do-test "test harraysize" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (<= 10 (il:harraysize tempx)) (<= 20 (il:harraysize tempy)) ))) (do-test "test clrhash" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (il:puthash 'key "The value" tempy) (il:harrayp (il:clrhash tempx)) (il:harrayp (il:clrhash tempy)) T ))) (do-test "test puthash & gethash" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (equal 3.141592 (il:puthash 'pi 3.141592 tempx)) (equal 3.141592 (il:gethash 'pi tempx)) (equal 1 (il:harrayprop tempx 'il:numkeys)) (equal 2.71828 (il:puthash 'e 2.71828 tempx)) (equal 2.71828 (il:gethash 'e tempx)) (equal 2 (il:harrayprop tempx 'il:numkeys)) (equal "A simple string" (il:puthash 'string "A simple string" tempy)) (equal "A simple string" (il:gethash 'string tempy)) (equal nil (il:gethash 'should-not-find tempx)) ))) (do-test "test rehash" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (equal 3.141592 (il:puthash 'pi 3.141592 tempx)) (il:harrayp (il:rehash tempx tempy)) (equal 3.141592 (il:gethash 'pi tempy)) (equal 1 (il:harrayprop tempy 'il:numkeys)) ))) (do-test "test maphash" (let* ((tempx (il:hasharray 10)) (tempy '(start))) (and (equal 3.141592 (il:puthash 'pi 3.141592 tempx)) (il:harrayp (il:maphash tempx (function (lambda (val key) (push (list val key) tempy))))) (equal '(3.141592 PI) (first tempy)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST new file mode 100644 index 00000000..89e347b7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST @@ -0,0 +1 @@ +;; A Bogus test written by Larry to try to figure out whether or not ;; DEFUN was interacting in the ``proper'' way with the Interlisp ;; argument-list functions. Something like this needs to be decided ;; and then tested. (DO-TEST INTERLISP-ARGUMENT-TEST ; (PROGN ; (DEFUN ARGTEST (FN ARGLIST NARGS ARGTYPE FNTYP) ; (ARGTEST1 FN ARGLIST NARGS ARGTYPE FNTYP) ; (ARGTEST1 (SYMBOL-FUNCTION FN) ARGLIST NARGS ARGTYPE FNTYP)) ; ; (DEFUN ARGTEST1 (DEF ARGLIST NARGS ARGTYPE FNTYP) ; (AND (COND ((EQ ARGLIST T) (SYMBOLP (IL:ARGLIST DEF))) ; (T (EQUAL (IL:ARGLIST DEF) ARGLIST))) ; (EQUAL (IL:NARGS DEF) NARGS) ; (EQUAL (IL:ARGTYPE DEF) ARGTYPE) ; (EQUAL (IL:FNTYP DEF) FNTYP))) ; ; (AND (PROGN (DEFUN TESTEXPR (X) (HELP)) ; (ARGTEST 'TESTEXPR '(X) 1 0 'EXPR)) ; ; (PROGN (DEFUN TESTEXPR (X &OPTIONAL (ARG 3)) (HELP)) ; (ARGTEST 'TESTEXPR T 1 2 'IL:EXPR*)) ; ; (PROGN (DEFUN TESTEXPR (X &KEY (ARG 3)) (HELP)) ; (ARGTEST 'TESTEXPR T 1 2 'IL:EXPR*)) ; ) ; ) T ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST new file mode 100644 index 00000000..f0c19e33 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7398: COMPILED-FUNCTION-P should always be NIL on symbols (do-test "AR 7398" (funcall (compile nil '(lambda () (block foo (do-all-symbols (s t) (when (compiled-function-p s) (return-from foo nil)) ) ) ) )) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST new file mode 100644 index 00000000..5b2741b3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ATOM ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Atom.test ;; ;; (do-test "test simple cases" (and (eq t (il:atom 'a-atom)) (eq t (il:atom 5)) (eq nil (il:atom "a string")) )) (do-test "Try various types of litatoms" (and (eq t (il:atom 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq t (il:atom 'A-couple-dashs)) (eq t (il:atom 'Numbers-1234567890)) (eq t (il:atom 'il:other-packags)) (eq t (il:atom 'il:other-packagsNumbers-1234567890)) (eq t (il:atom 'il:other-packagsA-couple-dashs)) (eq t (il:atom T)) (eq t (il:atom nil)) (eq t (il:atom ())) (eq t (il:atom '())) (eq t (il:atom (list))) (eq t (il:atom (eq 1 2))) )) (do-test "Test numbers are atoms" (and (eq t (il:atom 123)) (eq t (il:atom 45.67)) (eq t (il:atom 8/9)) (eq t (il:atom #c( 6/7 3.00))) (eq t (il:atom most-positive-fixnum)) (eq t (il:atom 37e5)) (eq t (il:atom .001)) (eq t (il:atom #c( 6/7 3.00))) )) (do-test "Test able to take atoms from own function" (flet ((tee nil t) (nill nil nil) (temp-atom nil 'atom) (temp-number nil 12.2)) (test-defun temp-fun nil 'atom) (test-setq temp-atom 'il:temp-pointed) (and (eq t (il:atom (tee))) (eq t (il:atom (nill))) (eq t (il:atom (temp-atom))) (eq t (il:atom (temp-fun))) (eq t (il:atom temp-atom)) (eq t (il:atom (temp-number))) ))) (do-test "Test able to take atoms from system function" (and (eq t (il:atom (car '(a b)))) (eq t (il:atom (second '(a b)))) (eq t (il:atom (third '(1 2 3 4 5)))) (eq t (il:atom (first (multiple-value-list (gentemp))))) (eq t (il:atom (first (multiple-value-list (gentemp "il"))))) )) (do-test "Stop on atoms from own functions" (flet ((temp-string nil "string")) (test-defun temp-fun nil #\*) (test-setq temp-atom *random-state*) (and (eq nil (il:atom (temp-string))) (eq nil (il:atom (temp-fun))) (eq nil (il:atom temp-atom)) ))) (do-test "Stop on atoms from system functions" (and (eq nil (il:atom (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:atom (second '(#\. #\k)))) )) (do-test "Test arrays aren't atoms" (and (eq nil (il:atom (make-array '(2 2)))) (eq nil (il:atom (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:atom (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:atom (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:atom (make-array 50 :initial-element 0))) (eq nil (il:atom (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't atoms" (and (eq nil (il:atom #\backspace)) ; character (eq nil (il:atom #\*)) ; character (eq nil (il:atom #\.)) ; character (eq nil (il:atom (make-hash-table))) ; hash table (eq nil (il:atom (car (list-all-packages)))) ; packages (eq nil (il:atom (pathname nil))) ; pathname (eq nil (il:atom *random-state*)) ; ramdom state (eq nil (il:atom #'cons)) ; compiled function (eq nil (il:atom (copy-readtable))) ; readtable (eq nil (il:atom #*1001)) ; simple-bit-vector (eq nil (il:atom "twine")) ; simple-string (eq nil (il:atom (make-synonym-stream nil))) ; stream (eq nil (il:atom '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST new file mode 100644 index 00000000..ac9127a5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: DataTypes ;; ;; Source: IRM, p 8.20 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>DataTypes.test ;; ;; (do-test "Test returns a list, and have some stuff in it" (let* ((datatypes (il:datatypes))) (and datatypes (find 'il:fixp datatypes) (find 'il:floatp datatypes) (find 'il:litatom datatypes) (find 'il:listp datatypes) (find 'il:arrayp datatypes) (find 'il:stringp datatypes) (find 'il:stackp datatypes) (find 'stream datatypes) (find 'random-state datatypes) (find 'pathname datatypes) T ))) (do-test "Test returns a list" (let* ((userdatatypes (il:userdatatypes))) (and userdatatypes T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST new file mode 100644 index 00000000..d8611c0e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LITATOM ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Litatom.test ;; ;; (do-test "test simple cases" (and ; Does the function work? (eq t (il:litatom 'a-atom)) (eq nil (il:litatom 5)) (eq nil (il:litatom "a string")) )) (do-test "Try various types of litatoms" (and (eq t (il:litatom 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq t (il:litatom 'A-couple-dashs)) (eq t (il:litatom 'Numbers-1234567890)) (eq t (il:litatom 'il:other-packags)) (eq t (il:litatom 'il:other-packagsNumbers-1234567890)) (eq t (il:litatom 'il:other-packagsA-couple-dashs)) (eq t (il:litatom T)) (eq t (il:litatom nil)) (eq t (il:litatom ())) (eq t (il:litatom '())) (eq t (il:litatom (list))) (eq t (il:litatom (eq 1 2))) )) (do-test "Test able to take litatoms from own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom)) (test-defun temp-fun nil 'litatom) (test-setq temp-atom 'il:temp-pointed) (and (eq t (il:litatom (tee))) (eq t (il:litatom (nill))) (eq t (il:litatom (temp-litatom))) (eq t (il:litatom (temp-fun))) (eq t (il:litatom temp-atom)) ))) (do-test "Test able to take litatoms from system function" (and (eq t (il:litatom (car '(a b)))) (eq t (il:litatom (second '(a b)))) (eq t (il:litatom (first (multiple-value-list (gentemp))))) (eq t (il:litatom (first (multiple-value-list (gentemp "il"))))) )) (do-test "Stop on litatoms from own functions" (flet ((temp-number nil 12.2) (temp-string nil "string")) (test-defun temp-fun nil #\*) (test-setq temp-atom *random-state*) (and (eq nil (il:litatom (temp-number))) (eq nil (il:litatom (temp-string))) (eq nil (il:litatom (temp-fun))) (eq nil (il:litatom temp-atom)) ))) (do-test "Stop on litatoms from system functions" (and (eq nil (il:litatom (car '(1 2)))) (eq nil (il:litatom (second '(#\. #\k)))) )) (do-test "Test numbers aren't litatoms" (and (eq nil (il:litatom 123)) (eq nil (il:litatom 45.67)) (eq nil (il:litatom 8/9)) (eq nil (il:litatom #c( 6/7 3.00))) (eq nil (il:litatom most-positive-fixnum)) (eq nil (il:litatom 37e5)) (eq nil (il:litatom .001)) (eq nil (il:litatom #c( 6/7 3.00))) )) (do-test "Test arrays aren't litatoms" (and (eq nil (il:litatom (make-array '(2 2)))) (eq nil (il:litatom (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:litatom (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:litatom (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:litatom (make-array 50 :initial-element 0))) (eq nil (il:litatom (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't litatoms" (and (eq nil (il:litatom #\backspace)) ; character (eq nil (il:litatom #\*)) ; character (eq nil (il:litatom #\.)) ; character (eq nil (il:litatom (make-hash-table))) ; hash table (eq nil (il:litatom (car (list-all-packages)))) ; packages (eq nil (il:litatom (pathname nil))) ; pathname (eq nil (il:litatom *random-state*)) ; ramdom state (eq nil (il:litatom #'cons)) ; compiled function (eq nil (il:litatom (copy-readtable))) ; readtable (eq nil (il:litatom #*1001)) ; simple-bit-vector (eq nil (il:litatom "twine")) ; simple-string (eq nil (il:litatom (make-synonym-stream nil))) ; stream (eq nil (il:litatom '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST new file mode 100644 index 00000000..143b941e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST @@ -0,0 +1 @@ +;; ;; Source: ;; ;; Created By: Bob CHERRY ;; ;; Creation Date: APR-2-87 ;; ;; Last Update: ;; ;; Filed As: {ERIS}TEST>I.S.Oprs>ISOPRS.TEST ;; ;; ;; Syntax: Just run with DO-TEST ;; ;; ;; Function Description: Chapter 9 (IRM) Iterative Statements ;; ;; ;; ;; Argument(s): FORM - what is evaluated. ;; ;; Returns: depends on what is used to terminate execution. ;; Should return T ;; (do-test "test FOR - IN - EQUAL funct" (LET ((FOO1 '(A B C D E)) (FOO2 '((A) (B) (C))) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 3 IL:as Y IL:in FOO1 IL:COLLECT (IL:LIST Y) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test FOR - WHILE - NOT - GREATERP funct" (LET ((FOO1 '(A B C D E)) (FOO2 '((A) (B) (C))) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT (IL:LIST Y) IL:WHILE (IL:NOT (IL:GREATERP X 3)) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test FOR - WHILE - LESSP funct" (LET ((FOO1 '(A B C D E)) (FOO2 '((A) (B) (C))) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT (IL:LIST Y) IL:WHILE (IL:LESSP X 4) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test SMALLEST & LARGEST funct" (LET ( (FOO1 '(7 15 1 3 9)) ) (AND (EQ 1 (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:SMALLEST Y) ) (EQ 15 (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:LARGEST Y) ) ) ) ) ;; ;; Next Test ;; (do-test "test UNTIL funct" (LET ( (FOO1 '(1 4 9 16 25) ) ) (EQUAL FOO1 (IL:for il:old X IL:from 1 IL:until (EQUAL x 6) IL:COLLECT (IL:TIMES X X) ) ) ) ) ;; ;; Next Test ;; (do-test "test FOR - BY funct" (LET ((FOO1 '(A B C D E)) (FOO2 '(A B C)) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 6 IL:by 2 IL:as Y IL:in FOO1 IL:COLLECT Y) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test COLLECT - WHEN funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(1 3 5)) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT Y IL:when (IL:NUMBERP Y) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test UNLESS funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(B D)) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT Y IL:unless (IL:NUMBERP Y) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test REPEATWHILE - REPEATUNTIL funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(B D)) ) (AND (IL:EQUAL (IL:for X IL:from 1 IL:REPEATWHILE IL:NOT (IL:EQUAL Y (CDR FOO2)) IL:as Y IL:in FOO1 IL:COLLECT Y IL:unless (IL:NUMBERP Y) ) FOO2 ) (IL:EQUAL (IL:for X IL:from 1 IL:REPEATUNTIL (IL:EQUAL Y (CDR FOO2)) IL:as Y IL:in FOO1 IL:COLLECT Y IL:unless (IL:NUMBERP Y) ) FOO2 ) ) ) ) ;; ;; Next Test ;; (do-test "test I.S.OPR funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(B D)) ) (IL:I.S.OPR 'RATS '(SETQ IL:$$VAL (IL:NCONC1 IL:$$VAL IL:BODY)) ) (AND (IL:EQUAL (IL:for X IL:from 1 IL:REPEATWHILE IL:NOT (IL:EQUAL Y (CDR FOO2) ) IL:as Y IL:in FOO1 IL:RATS Y IL:unless (IL:NUMBERP Y) ) FOO2 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST new file mode 100644 index 00000000..0c162c66 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST @@ -0,0 +1,665 @@ +(do-test-group |records| :BEFORE (PROGN (SETQ S (QUOTE (FIRST SECOND THIRD))) (SETQ ALFA "some string")) :AFTER (PROGN (IL:RECORD RECORD-TEST-NAME) (IL:RECORD RECORD-TEST-NAME1) (IL:RECORD RECORD-TEST-NAME2)) + +;; record type record + +(DO-TEST |setup-record| + (IL:RECORD RECORD-TEST-NAME + (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (ODDP (LENGTH IL:DATUM))))) + +(DO-TEST |create-record| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) + +(DO-TEST |type?-record| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-record + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-record| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-record| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-record| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-record + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-record| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST |using-record| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) + S))) + +(DO-TEST |reusing-record| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + +(DO-TEST |copying-record| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-record| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD4 RECORD-TEST-RECORD2) )) + +; record type typerecord + +(DO-TEST |setup-typerecord| + (IL:TYPERECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A))) + +(DO-TEST |create-typerecord| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-typerecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-typerecord + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-typerecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-typerecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-typerecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-typerecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-typerecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST |using-typerecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD + GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + +(DO-TEST |reusing-typerecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + +(DO-TEST |copying-typerecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-typerecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + + +;record type proprecord + +(DO-TEST |setup-proprecord| + (IL:PROPRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (EVENP (LENGTH IL:DATUM))))) + +(DO-TEST |create-proprecord| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-proprecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-proprecord + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-proprecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-proprecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-proprecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-proprecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-proprecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + + + +(DO-TEST |using-proprecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD + GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + +(DO-TEST |reusing-proprecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + +(DO-TEST |copying-proprecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-proprecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + + +;record type datatype + +(DO-TEST |setup-datatype| + (IL:DATATYPE RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A))) + +(DO-TEST |create-datatype| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-datatype| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-datatype + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-datatype| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-datatype| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-datatype| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + + +(DO-TEST |typeglobalvariable-datatype| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + + +(DO-TEST fetchfield-datatype + (AND (EQ (IL:FETCHFIELD (CAR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) S) + (EQ (IL:FETCHFIELD (CADR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) + ALFA))) + +(DO-TEST replacefield-datatype + (AND (EQ (IL:REPLACEFIELD (CAR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD ALFA) ALFA) + (EQ (IL:REPLACEFIELD (CADR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD S) S))) + +(DO-TEST refetchfield-datatype + (AND (EQ (IL:FETCHFIELD (CAR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCHFIELD (CADR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD) S))) + +(DO-TEST getfieldspecs-datatype + (EQ (CAR (IL:GETFIELDSPECS (QUOTE RECORD-TEST-NAME))) + (CADDAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))))) + +(DO-TEST IL:typename-datatype + (EQ (IL:TYPENAME RECORD-TEST-RECORD) + (QUOTE RECORD-TEST-NAME))) + +(DO-TEST typenamep-datatype + (IL:TYPENAMEP RECORD-TEST-RECORD (QUOTE RECORD-TEST-NAME))) + +(DO-TEST |using-datatype| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + + +(DO-TEST |reusing-datatype| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + + +(DO-TEST |copying-datatype| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-datatype| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + + +;record type arrayrecord + +(DO-TEST |setup-arrayrecord| + (IL:ARRAYRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (COND (IL:DATUM T))))) + +(DO-TEST |create-arrayrecord| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-arrayrecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-typearary + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-arrayrecord| +` (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-arrayrecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-arrayrecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-arrayrecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-arrayrecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST getfieldspecs-arrayrecord + (EQ (CAR (IL:GETFIELDSPECS (QUOTE RECORD-TEST-NAME))) + (CADDAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))))) + +(DO-TEST IL:typename-arrayrecord + (EQ (IL:TYPENAME RECORD-TEST-RECORD) + (QUOTE il:arrayp))) + +(DO-TEST typenamep-arrayrecord + (IL:TYPENAMEP RECORD-TEST-RECORD (QUOTE il:arrayp))) + + +(DO-TEST |using-arrayrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + + +(DO-TEST |reusing-arrayrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + + +(DO-TEST |copying-arrayrecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + + +(DO-TEST |smashing-arrayrecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + +;record type assocrecord + +(DO-TEST |setup-assocrecord| + (IL:ASSOCRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (NOT (IL:ATOM (CAR IL:DATUM)))))) + + +(DO-TEST |create-assocrecord| + (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-assocrecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST synonym-assocrecord + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-assocrecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-assocrecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-assocrecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-assocrecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-assocrecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST |using-assocrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + + +(DO-TEST |reusing-assocrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + + +(DO-TEST |copying-assocrecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-assocrecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + +;record type accessfns + +(DO-TEST setup-accessfns + (IL:ACCESSFNS RECORD-TEST-NAME + ((ALPHA (CAR IL:DATUM) + (SETQ IL:DATUM(CONS IL:NEWVALUE + (CDR IL:DATUM)))) + (BRAVO (CADR IL:DATUM) + (SETQ IL:DATUM (CONS (CAR IL:DATUM) + (CONS IL:NEWVALUE + (CDDR IL:DATUM))))) + (GAMMA (CADDR IL:DATUM) + (SETQ IL:DATUM (LIST (CAR IL:DATUM) + (CADR IL:DATUM) + IL:NEWVALUE)))) + (IL:CREATE (LIST ALFA S NIL)) + (IL:TYPE? (ODDP (LENGTH IL:DATUM))))) + +(DO-TEST create-accessfns + (SETQ RECORD-TEST-RECORD + (IL:create RECORD-TEST-NAME))) + +(DO-TEST |type?| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + + +(DO-TEST |fetch-accessfns| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-accessfns| + (AND (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) + (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA))) + +(DO-TEST |refetch-accessfns| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) )) + +(DO-TEST |typeglobalvariable-accessfns| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +; blockrecords + +(DO-TEST setup-blockrecord + (IL:DATATYPE RECORD-TEST-NAME1 + ((ALPHA IL:POINTER)) ALPHA IL:_ S) + (IL:BLOCKRECORD RECORD-TEST-NAME2 + ((BRAVO IL:WORD) (GAMMA IL:WORD))) + (SETQ RECORD-TEST-RECORD (IL:CREATE RECORD-TEST-NAME1))) + +(DO-TEST TEST-FETCH-BLOCKRECORD + (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) + (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) + IL:OF RECORD-TEST-RECORD) + (IL:FETCH (RECORD-TEST-NAME2 GAMMA) + IL:OF RECORD-TEST-RECORD))) + (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST TEST-REPLACE-BLOCKRECORD + (IL:REPLACE (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD IL:WITH ALFA)) + +(DO-TEST TEST-reFETCH-BLOCKRECORD + (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) + (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) + IL:OF RECORD-TEST-RECORD) + (IL:FETCH (RECORD-TEST-NAME2 GAMMA) + IL:OF RECORD-TEST-RECORD))) + (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) ALFA))) + +(DO-TEST "TEST THAT REPLACES THROUGH THE BLOCKRECORD STRUCTURE" + (IL:REPLACE (RECORD-TEST-NAME2 BRAVO) IL:OF RECORD-TEST-RECORD + IL:WITH (IL:\\HILOC S)) + (IL:REPLACE (RECORD-TEST-NAME2 GAMMA) IL:OF RECORD-TEST-RECORD + IL:WITH (IL:\\LOLOC S))) + +(DO-TEST "TEST REFETCHING AFTER REPLACING THROUGH THE BLOCKRECORD" + (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) + (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) + IL:OF RECORD-TEST-RECORD) + (IL:FETCH (RECORD-TEST-NAME2 GAMMA) + IL:OF RECORD-TEST-RECORD))) + (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) S))) + +(Do-test "look at floating point" + (IL:DATATYPE flnum ((n IL:floating))) + (setq num1 (IL:CREATE flnum)) + (setq num2 (IL:CREATE flnum)) + (IL:BLOCKRECORD fldisect + ((sign IL:BITS 1) (exp IL:BITS 8) (mant IL:BITS 23))) + (setq anynum (IL:RAND)) + (IL:REPLACE n IL:of num1 IL:with anynum) + (IL:REPLACE n IL:of num2 IL:with (IL:times anynum 2)) + (eq (IL:add1 (IL:fetch exp IL:of num1)) + (IL:fetch exp IL:of num2))) + + +(Do-test "test blank fields and playing with integers" + (IL:DATATYPE intnum ((int IL:integer))) + (setq num (IL:CREATE intnum)) + (IL:BLOCKRECORD evenodd ((nil IL:bits 16) + (nil IL:BITS 15) + (lastbit IL:BITS 1))) + (setq anynum (IL:RAND)) + (IL:REPLACE int IL:of num IL:with anynum) + (if (evenp (IL:fetch int IL:of num)) + (progn (IL:replace lastbit IL:of num IL:with 1) + (oddp (IL:fetch int IL:of num))) + (progn (IL:replace lastbit IL:of num IL:with 0) + (evenp (IL:fetch int IL:of num))))) + +;Testing WITH + +(Do-test "simple with using a datatype" + (IL:with flnum num1 + (IL:setq n 0) + (zerop n))) + +(Do-test "compound with using two datatypes" + (IL:with flnum num1 + (IL:with intnum num + (IL:setq n (il:times n 2)) + (IL:setq int 0) + (and (equal (float int) n) + (zerop int))))) + +) ;END OF DO-TEST-GROUP + +STOP +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) _í_ízş \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERPRETER-AR8538.TEST b/internal/test/LANGUAGE/AUTO/INTERPRETER-AR8538.TEST new file mode 100644 index 00000000..7b8262da --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERPRETER-AR8538.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8538: Interlisp interpreter doesn't bind variables to NIL when no initialization is given in LET* (do-test "AR 8538" (makunbound 'b) (il:eval '(let* ((a 7) b) (list a b))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST b/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST new file mode 100644 index 00000000..9bf6c5ba --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8366: the local variable RPTN was unbound in RPT (do-test "AR 8366" (makunbound 'il:rptn) (equal (let ((x ())) (declare (special x)) (il:rpt 2 '(push il:rptn x)) (il:rptq 2 (push il:rptn x)) x) '(1 2 1 2)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST new file mode 100644 index 00000000..9177390d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for changes to LLINTERP (do-test "AR 7404: MAKUNBOUND and BOUNDP disagree" (let ((*foo* 7)) (declare (special *foo*)) (makunbound '*foo*) (not (boundp '*foo*)))) (do-test "AR 7398: COMPILED-FUNCTION-P should always be NIL on symbols" (and (not (compiled-function-p '+)) (compiled-function-p #'+))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/LLREAD.TEST b/internal/test/LANGUAGE/AUTO/LLREAD.TEST new file mode 100644 index 00000000..1301b72b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/LLREAD.TEST @@ -0,0 +1 @@ +;;; test file for LLREAD 4-30-87 by woz ;;; AR 7741 (do-test "SKREAD understands vertical bar" (with-input-from-string (s "(a |b) c| d) e |") (il:skread s) (eq (read s) 'e)) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST new file mode 100644 index 00000000..d932fde8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for changes in LLSYMBOL (do-test ("AR 7385: (setf (symbol-function ...) ...) doesn't remove macro definition" :before (fmakunbound 'zab) :after (fmakunbound 'zab)) (progn (setf (macro-function 'zab) 'expand-zab) (setf (symbol-function 'zab) '(lambda () 9)) (not (macro-function 'zab)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST new file mode 100644 index 00000000..c117fec4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST @@ -0,0 +1 @@ +;;; regression tests for LOCALFILE-PATCH: ;; Patch 1 (do-test "DLion renamefile bug" (or (not (eq (il:machinetype) 'il:dandelion)) ;This is only a DLion bug (let (foo) (il:closef (il:openstream "{dsk}foo" 'il:output 'il:new)) (setq foo (il:openstream "{dsk}foo" 'il:input 'il:old)) (prog1 (not (il:renamefile "{dsk}foo" "{dsk}bar")) (il:delfile (il:closef foo)))))) ;; Patch 2 (do-test-group "Rename nonexistant file" :before (ignore-errors (il:delfile "{dsk}this-file-does-not-exist;1")) :after (ignore-errors (il:delfile "{dsk}rename-target")) (do-test "Renaming nonexistant file" (expect-errors (error) (rename-file "{dsk}this-file-does-not-exist;1" "{dsk}rename-target") ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST new file mode 100644 index 00000000..7a5fac81 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST @@ -0,0 +1 @@ +;; regression test for NAMESTRING-PATCH: (do-test "enough-namestring bug" (cl:enough-namestring "{eris}sources>foo.bar;7")) (do-test "namestring radix bug" (let ((*print-base* 2)) (eq (length (namestring "foo.bar;8")) 9))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/NLISTP.TEST b/internal/test/LANGUAGE/AUTO/NLISTP.TEST new file mode 100644 index 00000000..123b77c6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/NLISTP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NListP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>NListP.test ;; ;; (do-test "test simple cases" (and (equal nil (il:nlistp '(a))) (equal nil (il:nlistp '(1 2 3 (a b) (c (d e))))) (eq T (il:nlistp -5)) (eq T (il:nlistp 1000000)) (eq T (il:nlistp 'a-floatp)) (eq T (il:nlistp "a string")) )) (do-test "Test lists of various things" (and (equal nil nil(il:nlistp '("a" "list" "of" "strings" "23 #$%"))) (equal nil (il:nlistp '(a list of litatoms qw-32))) (equal nil (il:nlistp '(1 3/4 5.5 32e5))) )) (do-test "Test stop on own function" (flet ((temp-small nil '(12 BV "hi")) ) (test-defun temp-fun nil '(34 QW "bye")) (and (equal nil (il:nlistp (temp-small))) (equal nil (il:nlistp (temp-fun))) ))) (do-test "Test stop against system functions" (and (equal nil (il:nlistp (append '(a) '(b)))) (equal nil (il:nlistp (il:append '(a) '(b)))) (equal nil (il:nlistp (il:cons 'a 'b))) )) (do-test "Try various types of Litatoms" (and (eq T (il:nlistp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq T (il:nlistp 'A-couple-dashs)) (eq T (il:nlistp 'Numbers-1234567890)) (eq T (il:nlistp 'il:other-packags)) (eq T (il:nlistp 'il:other-packagsNumbers-1234567890)) (eq T (il:nlistp 'il:other-packagsA-couple-dashs)) (eq T (il:nlistp T)) (eq T (il:nlistp nil)) (eq T (il:nlistp ())) (eq T (il:nlistp '())) (eq T (il:nlistp (list))) (eq T (il:nlistp (eq 1 2))) )) (do-test "Test go on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq T (il:nlistp (tee))) (eq T (il:nlistp (nill))) (eq T (il:nlistp (temp-litatom))) (eq T (il:nlistp (temp-string))) (eq T (il:nlistp (temp-fun))) (eq T (il:nlistp temp-litatom)) ))) (do-test "Stop go from system functions" (and (eq T (il:nlistp (car '(#*1001 '#( 5 4 3 2 1))))) (eq T (il:nlistp (second '(#\. #\k)))) )) (do-test "Test arrays aren't lists" (and (eq T (il:nlistp (make-array '(2 2)))) (eq T (il:nlistp (make-array '(6 6 6) :element-type '(or integer string)))) (eq T (il:nlistp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq T (il:nlistp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq T (il:nlistp (make-array 50 :initial-element 0))) (eq T (il:nlistp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't lists" (and (eq T (il:nlistp #\backspace)) ; character (eq T (il:nlistp #\*)) ; character (eq T (il:nlistp #\.)) ; character (eq T (il:nlistp (make-hash-table))) ; hash table (eq T (il:nlistp (car (list-all-packages)))) ; packages (eq T (il:nlistp (pathname nil))) ; pathname (eq T (il:nlistp *random-state*)) ; ramdom state (eq T (il:nlistp #'cons)) ; compiled function (eq T (il:nlistp (copy-readtable))) ; readtable (eq T (il:nlistp #*1001)) ; simple-bit-vector (eq T (il:nlistp "twine")) ; simple-string (eq T (il:nlistp (make-synonym-stream nil))) ; stream (eq T (il:nlistp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/NUMBERP.TEST b/internal/test/LANGUAGE/AUTO/NUMBERP.TEST new file mode 100644 index 00000000..e242be3e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/NUMBERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NUMBERP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>NumberP.test ;; ;; (do-test "test simple cases" (and (eq 5 (il:numberp 5)) (equal 10.13 (il:numberp 10.13)) (eq nil (il:numberp 'a-numberp)) (eq nil (il:numberp "a string")) )) (do-test "Test numbers are numberps" (and (eq 123 (il:numberp 123)) (equal 45.67 (il:numberp 45.67)) (equal 8/9 (il:numberp 8/9)) (equal most-positive-fixnum (il:numberp most-positive-fixnum)) (equal 37e5 (il:numberp 37e5)) (equal .001 (il:numberp .001)) )) (do-test "Test go on own function" (flet ((temp-small nil 2) (temp-large nil 100000) (temp-floating nil 12.2)) (test-defun temp-fun nil 32e5) (and (eq 2 (il:numberp (temp-small))) (equal 100000 (il:numberp (temp-large))) (equal 12.2 (il:numberp (temp-floating))) (equal 32e5 (il:numberp (temp-fun))) ))) (do-test "Test work against system functions" (and (eq 3 (il:numberp (third '(1 2 3 4 5)))) (equal 3.3 (il:numberp (car '(3.3 2.2 1.1)))) (equal 2.3 (il:numberp (second '(1 2.3 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:numberp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:numberp 'A-couple-dashs)) (eq nil (il:numberp 'Numbers-1234567890)) (eq nil (il:numberp 'il:other-packags)) (eq nil (il:numberp 'il:other-packagsNumbers-1234567890)) (eq nil (il:numberp 'il:other-packagsA-couple-dashs)) (eq nil (il:numberp T)) (eq nil (il:numberp nil)) (eq nil (il:numberp ())) (eq nil (il:numberp '())) (eq nil (il:numberp (list))) (eq nil (il:numberp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:numberp (tee))) (eq nil (il:numberp (nill))) (eq nil (il:numberp (temp-litatom))) (eq nil (il:numberp (temp-string))) (eq nil (il:numberp (temp-fun))) (eq nil (il:numberp temp-litatom)) ))) (do-test "Stop on numberps from system functions" (and (eq nil (il:numberp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:numberp (second '(#\. #\k)))) )) (do-test "Test arrays aren't numberps" (and (eq nil (il:numberp (make-array '(2 2)))) (eq nil (il:numberp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:numberp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:numberp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:numberp (make-array 50 :initial-element 0))) (eq nil (il:numberp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't numberps" (and (eq nil (il:numberp #\backspace)) ; character (eq nil (il:numberp #\*)) ; character (eq nil (il:numberp #\.)) ; character (eq nil (il:numberp (make-hash-table))) ; hash table (eq nil (il:numberp (car (list-all-packages)))) ; packages (eq nil (il:numberp (pathname nil))) ; pathname (eq nil (il:numberp *random-state*)) ; ramdom state (eq nil (il:numberp #'cons)) ; compiled function (eq nil (il:numberp (copy-readtable))) ; readtable (eq nil (il:numberp #*1001)) ; simple-bit-vector (eq nil (il:numberp "twine")) ; simple-string (eq nil (il:numberp (make-synonym-stream nil))) ; stream (eq nil (il:numberp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST b/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST new file mode 100644 index 00000000..356ed4ad --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST @@ -0,0 +1 @@ +;; ;; Creation date: Jan 26, 1987 ;; ;; Created by: Karin M. Sye ;; ;; Regression tests for the Lyric Package System Ars ;; ;; AR 6713 ;; (do-test "package-ar6713: (PACKAGE-NICKNAMES package) returns the primary name of a package" (prog2 (make-package "pac" :nicknames '("pac1" "pac2" "pac3" )) (notany #'(lambda (x y) (find x (package-nicknames y) #'string=)) '("LISP" "pac") '(lisp "pac")) (xcl:delete-package "pac") ) ) ;; ;; AR 6632 ;; (do-test "package-ar6632: CTYPECASE should be in the LISP package" (find-symbol "CTYPECASE" 'lisp)) ;; ;; AR 6652 ;; (do-test "package-ar6652: ARG NOT PACKAGE wrong error attempting to read PHYLEX:PARC:XEROX" (and (catch 'bar (handler-bind (( xcl:missing-package #'(lambda (x) (throw 'bar t)) ) ( xcl:condition #'(lambda (x) (throw 'bar nil)) ) ) (progn (read (make-string-input-stream "PHYLEX:PARC")) nil ) ) ) (catch 'bar (handler-bind (( xcl:symbol-colon-error #'(lambda (x) (throw 'bar t)) ) ( xcl:condition #'(lambda (x) (throw 'bar nil)) ) ) (progn (read (make-string-input-stream "PHYLEX:PARC:XEROX")) nil ) ) ) ) ) ;; ;; AR 6700 ;; (do-test "package-ar6700: Symbols in wrong package" (and (every #'(lambda(x) (find-symbol x 'lisp)) '(copy-symbol make-symbol intern gentemp keywordp)) (find-symbol 'make-keyword 'il) ) ) ;; ;; AR 6742 ;; (do-test "package-ar6742: Shadowing-Import does not seem to add imported symbols to the shadowing-symbols list" (unwind-protect (progn (make-package 'abc :use nil) (shadowing-import '(lisp:if lisp:numberp) 'abc) (or (equal (package-shadowing-symbols 'abc) '(if numberp)) (equal (package-shadowing-symbols 'abc) '(numberp if)))) (xcl:delete-package 'abc) ) ) ;; ;; AR 6822 ;; (do-test "package-ar6822: Various package related bugs in cmlarray and friends (adjustable-array-p, *default-PUSH-EXTENSION-SIZE*, and CHAR were in the wrong place)" (and (find-symbol 'adjustable-array-p 'lisp) (find-symbol '*default-PUSH-EXTENSION-SIZE* 'xcl) (find-symbol 'CHAR 'lisp) ) ) ;; ;; AR 6835 ;; (do-test "package-ar6835: DEFPACKAGE fails for shadowing-import or shadow" (prog1 (and (xcl:defpackage "foo" (:shadow bar)) (xcl:defpackage "fooo" (:shadowing-import cl:*))) (xcl:delete-package "foo") (xcl:delete-package "fooo") ) ) ;; ;; AR 6858 ;; (do-test "package-ar6858: The variable *modules* should be in CML package rather than in Interlisp package" (string= (package-name (symbol-package '*modules*)) "LISP")) ;; ;; AR 6888 ;; (do-test "package-ar6888 : XCL:DELETE-PACKAGE should un-USE the dying package" (and (unwind-protect (progn (make-package 'p1) (make-package 'p2) (use-package 'p1 (find-package 'p2)) (xcl:delete-package (find-package 'p2)) (null (package-used-by-list (find-package 'p1))) ) (xcl:delete-package (find-package 'p1)) ) (unwind-protect (progn (make-package "p3" :use nil) (make-package "p2" :use "p3") (make-package "p1" :use "p2") (xcl:delete-package "p2") (null (or (package-used-by-list "p3") (package-use-list "p1"))) ) (xcl:delete-package "p1") (xcl:delete-package "p3") ) ) ) ;; ;; AR 6889 ;; (do-test "package-ar6889: Export interns NIL in package being exported from" (unwind-protect (progn (make-package 'pack :use nil) (intern "PRIVATE" 'pack) (export (intern "PUBLIC" 'pack) 'pack) (null (multiple-value-bind (name where) (find-symbol 'nil 'pack) where)) ) (xcl:delete-package 'pack) ) ) ;; ;; AR 6908 ;; (do-test "package-ar6908: Need do-internal-symbols for consistency" (let ((pac (make-package "PAC" :use nil)) buf) (progn (import '(cl:if cl:do cl:when cl:unless cl:let) pac) (xcl:do-internal-symbols (x pac (xcl:delete-package pac)) (push (symbol-name x) buf)) (every #'(lambda (x) (find x buf :test #'equal)) '("IF" "DO" "WHEN" "UNLESS" "LET")) ) ) ) ;; ;; AR 6909 ;; (do-test "package-ar6909shadowing-use-package removed from system" (not (fboundp 'shadowing-use-package)) ) ;; ;; AR 6941 ;; (do-test "package-ar6941: INTERN FOO NIL should make an uninterned symbol" (null (symbol-package (intern "FOO" NIL))) ) ;; ;; AR 7157 ;; (do-test "package-ar7157: Exec symbols not exported [xcl::*eval-function* xcl::*exec-prompt* xcl::*debugger-prompt*]" (every #'(lambda (x) (eq :external (second (multiple-value-list (find-symbol x 'xcl))))) '(*eval-function* *exec-prompt* *debugger-prompt*)) ) ;; ;; AR 7233 ;; (do-test "package-ar7233: IMPORT function interns NIL in package being imported to" (progn (make-package "pac" :use nil) (import 'cl:if (find-package "pac")) (prog1 (null (multiple-value-bind (name where) (find-symbol 'nil "pac") where)) (xcl:delete-package "pac") ) ) ) ;; ;; AR 7240 ;; (do-test "package-ar7240: UNINTERN fails to remove the symbol from the package's shadowing-symbols list" (progn (make-package 'pac :use nil) (shadowing-import 'lisp:if 'pac) (unintern 'if 'pac) (prog1 (null (package-shadowing-symbols 'pac)) (xcl:delete-package 'pac) ) ) ) ;; ;; AR 7285 ;; (do-test "package-ar7285: symbol-colon-error conditrion should be exported from the XCL package" (eq :external (cadr (multiple-value-list (find-symbol 'symbol-colon-error 'xcl)))) ) ;; ;; AR 7344 (do-test "package-ar7344: import returns nil instead of t in 21-Jan-87 sysout" (prog2 (make-package 'pac :use nil) (import 'il:plus 'pac) (xcl:delete-package 'pac) ) ) ;; ;; AR 8057 ;; (do-test "package-ar8057: Missing symbols from the LISP package" (every #'(lambda (name) (multiple-value-bind (symbol where) (find-symbol name "LISP") (eq where :external) )) '("SPEED" "SPACE" "SAFETY" "COMPILATION-SPEED") ) ) ;; ;; AR 8130 ;; (do-test "defpackage foo (:use nil)) breaks" (prog2 (if (find-package 'foo) (xcl:delete-package 'foo)) (defpackage foo (:use nil)) (xcl:delete-package 'foo) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST b/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST new file mode 100644 index 00000000..55c64c33 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST @@ -0,0 +1 @@ +;; ;; Creation date - Jan. 22, 1987 ;; ;; Created by - Karin M. Sye ;; ;; The following test code attemps to test all the PACKAGE conditions implemented by Xerox Common Lisp ;; ;; ** CONDITIONS RAISED WHILE READING SYMBOL NAMES ** ;; (do-test "test xcl:read-conflict condition" (catch 'done (handler-bind ((xcl:read-conflict #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (let ( (il:litatom-package-conversion-enabled t) (xcl:*preferred-reading-symbols* (remove 'il:* xcl:*preferred-reading-symbols*)) (*readtable* il:coderdtbl) ) (read (make-string-input-stream "*")) ; no condition was signaled nil ) ) ) ) ;; ;; (do-test "test xcl:missing-external-symbol condition" (catch 'done (handler-bind ((xcl:missing-external-symbol #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (progn (read (make-string-input-stream "lisp:dopey-sleepy")) ; no condition was signaled nil ) ) ) ) ;; ;; (do-test "test xcl:symbol-colon-error condition" (catch 'done (handler-bind ((xcl:symbol-colon-error #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (progn (read (make-string-input-stream "aa::bb:cc")) ; no condition was signaled nil ) ) ) ) ;; ;; (do-test "test xcl:missing-package condition" (catch 'done (handler-bind ((xcl:missing-package #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (progn (read (make-string-input-stream "ugly:duckling")) ; no condition was signaled nil ) ) ) ) ;; ;; ** CONDITION RAISED WHILE IN THE PACKAGE SYSTEM ;; (do-test "test xcl:symbol-conflict condition" (every #'(lambda (subtype) (subtypep subtype 'xcl:symbol-conflict) ) '(xcl:use-conflict xcl:export-conflict xcl:import-conflict xcl:unintern-conflict) ) ) ;; ;; (do-test "test xcl:package-error condition" (subtypep 'xcl:export-missing 'xcl:package-error) ) ;; ;; ** CONDITION RAISED WHILE CALLING USE-PACKAGE ;; (do-test "test xcl:use-conflict condition" (catch 'fool (unwind-protect (handler-bind ((xcl:use-conflict #'(lambda (condition) (throw 'fool t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'fool nil)) ) ) (progn (every #'(lambda (x) (make-package x :use nil)) '("p1" "p2" "p3")) (export (intern "a" "p1") "p1") (export (intern "a" "p2") "p2") (use-package '("p1" "p2") "p3") ; no condition was signaled nil ) ) (mapc #'(lambda (x) (xcl:delete-package x)) '("p1" "p2" "p3")) ) ) ) ;; ;; ** CONDITION RAISED WHILE CALLING EXPORT ;; (do-test "test xcl:export-conflict condition" (catch 'off (unwind-protect (handler-bind ((xcl:export-conflict #'(lambda (condition) (throw 'off t) )) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'off nil) )) ) (progn (make-package "p1" :use nil) (make-package "p2" :use "p1") (export (intern "A" "p2") "p2") (export (intern "A" "p1") "p1") ; no condition was signaled nil ) ) (mapc #'xcl:delete-package '("p1" "p2")) ) ) ) ;; ;; (do-test "test xcl:export-missing condition" (catch 'bye (handler-bind ((xcl:export-missing #'(lambda (condition) (throw 'bye t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'bye nil) )) ) (progn (export '( sssnow-whiteee sssneezyyyy) 'lisp) ; no condition was signaled nil ) ) ) ) ;; ;; ** CONDITION RAISED WHILE CALLING IMPORT ;; (do-test "test xcl:import-conflict condition" (block exit (handler-bind (( xcl:import-conflict #'(lambda (condition) (return-from exit t) )) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (return-from exit nil) )) ) (progn (import '(lisp:* lisp:length) 'il) ;no condition was signaled nil ) ) ) ) ;; ;; ** CONDITION RAISED WHILE CALLING UNINTERN ;; (do-test "test xcl:unintern-conflict condition" (catch 'fool (unwind-protect (handler-bind ((xcl:unintern-conflict #'(lambda (condition) (throw 'fool t) )) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'fool nil) )) ) (progn (every #'(lambda (x) (make-package x :use nil)) '("p1" "p2" "p3")) (export (intern "A" "p1") "p1") (export (intern "A" "p2") "p2") (shadow 'a "p3") (use-package '("p1" "p2") "p3") (unintern (find-symbol "A" "p3") "p3") ; no condition was signaled nil ) ) (mapc #'(lambda (x) (xcl:delete-package x)) '("p1" "p2" "p3")) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA b/internal/test/LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA new file mode 100644 index 00000000..b4157449 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA @@ -0,0 +1 @@ +(CL:SETQ CONVERTER-TEST-CASES (QUOTE ( (*CATCH "INTERLISP" :EXTERNAL "ERROR") (*FEATURES* "LISP" :EXTERNAL ) (*PRINT-ARRAY* "LISP" :EXTERNAL ) (*PRINT-LENGTH* "LISP" :EXTERNAL ) (*PRINT-LEVEL* "LISP" :EXTERNAL ) (*PRINT-STRUCTURE* "INTERLISP" :EXTERNAL ) (*THROW "INTERLISP" :EXTERNAL "ERROR") (*STANDARD-OUTPUT* "LISP" :EXTERNAL ) (ADJUST-ARRAY "LISP" :EXTERNAL "O.K.") (ADJUSTABLE-ARRAY-P "LISP" :EXTERNAL "O.K.") (ALPHA-CHAR-P "LISP" :EXTERNAL "O.K.") (ALPHANUMERICP "LISP" :EXTERNAL "O.K.") (AND "LISP" :EXTERNAL "EQ") (APPLY "INTERLISP" :EXTERNAL "PREFERRED") (AREF "LISP" :EXTERNAL "O.K.") (ARRAY "INTERLISP" :EXTERNAL "PREFERRED") (ARRAY-DIMENSION "LISP" :EXTERNAL "O.K.") (ARRAY-DIMENSION-LIMIT "LISP" :EXTERNAL "O.K.") (ARRAY-DIMENSIONS "LISP" :EXTERNAL "O.K.") (ARRAY-ELEMENT-TYPE "LISP" :EXTERNAL "O.K.") (ARRAY-HAS-FILL-POINTER-P "LISP" :EXTERNAL "O.K.") (ARRAY-IN-BOUNDS-P "LISP" :EXTERNAL "O.K.") (ARRAY-RANK "LISP" :EXTERNAL "O.K.") (ARRAY-RANK-LIMIT "LISP" :EXTERNAL "O.K.") (ARRAY-ROW-MAJOR-INDEX "LISP" :EXTERNAL "O.K.") (ARRAY-TOTAL-SIZE "LISP" :EXTERNL "O.K.") (ARRAY-TOTAL-SIZE-LIMIT "LISP" :EXTERNAL "O.K.") (ARRAYP "INTERLISP" :EXTERNAL "PREFERRED") (ASET "XEROX-COMMON-LISP" :EXTERNAL "O.K.") (ATOM "INTERLISP" :EXTERNAL "PREFERRED") (BIT "LISP" :EXTERNAL "EQ") (BIT-VECTOR "LISP" :EXTERNAL "O.K.") (BIT-VECTOR-P "LISP" :EXTERNAL "O.K.") (BOTH-CASE-P "LISP" :EXTERNAL "O.K.") (BOUNDP "LISP" :EXTERNAL "EQ") (CASE "LISP" :EXTERNAL "EQ") (CATCH "LISP" :EXTERNAL "O.K.") (CHAR-BITS "LISP" :EXTERNAL "O.K.") (CHAR-CODE "LISP" :EXTERNAL "O.K.") (CHAR-CODE-LIMIT "LISP" :EXTERNAL "O.K.") (CHAR-DOWNCASE "LISP" :EXTERNAL "O.K.") (CHAR-EQUAL "LISP" :EXTERNAL "O.K.") (CHAR-FONT "LISP" :EXTERNAL "O.K.") (CHAR-GREATERP "LISP" :EXTERNAL "O.K.") (CHAR-INT "LISP" :EXTERNAL "O.K.") (CHAR-LESSP "LISP" :EXTERNAL "O.K.") (CHAR-NAME "LISP" :EXTERNAL "O.K.") (CHAR-NOT-EQUAL "LISP" :EXTERNAL "O.K.") (CHAR-NOT-GREATERP "LISP" :EXTERNAL "O.K.") (CHAR-NOT-LESSP "LISP" :EXTERNAL "O.K.") (CHAR-UPCASE "LISP" :EXTERNAL "O.K.") (CHAR/= "LISP" :EXTERNAL "O.K.") (CHAR< "LISP" :EXTERNAL "O.K.") (CHAR<= "LISP" :EXTERNAL "O.K.") (CHAR= "LISP" :EXTERNAL "O.K.") (CHAR> "LISP" :EXTERNAL "O.K.") (CHAR>= "LISP" :EXTERNAL "O.K.") (CHARACTER "INTERLISP" :EXTERNAL "PREFERRED") (CHARACTERP "LISP" :EXTERNAL "O.K.") (CHECK-TYPE "LISP" :EXTERNAL "O.K.") (CMLPATH "INTERLISP" :EXTERNAL "ERROR") (CMLPROMPT "INTERLISP" :EXTERNAL "O.K.") (CMLRDTBL "INTERLISP" :EXTERNAL "O.K.") (CMLREAD "INTERLISP" :EXTERNAL "O.K.") (CMLSHOW "INTERLISP" :EXTERNAL "ERROR") (CMLWINDOW "INTERLISP" :EXTERNAL "ERROR") (CODE-CHAR "LISP" :EXTERNAL "O.K.") (COERCE "LISP" :EXTERNAL "EQ") (COMPILE-FILE "INTERLISP" :EXTERNAL "PREFERRED") (COMPLEX "LISP" :EXTERNAL "EQ") (COMPLEXP "LISP" :EXTERNAL "O.K.") (COND "LISP" :EXTERNAL "EQ") (CONSP "LISP" :EXTERNAL "O.K.") (DECLARE "LISP" :EXTERNAL "EQ") (DEFINE-MODIFY-MACRO "LISP" :EXTERNAL "O.K.") (DEFMACRO "LISP" :EXTERNAL "EQ") (DEFSETF "LISP" :EXTERNAL "O.K.") (DEFSTRUCT "INTERLISP" :EXTERNAL "PREFERRED") (DEFTYPE "LISP" :EXTERNAL "O.K.") (DIGIT-CHAR "LISP" :EXTERNAL "O.K.") (DIGIT-CHAR-P "LISP" :EXTERNAL "O.K.") (DO "INTERLISP" :EXTERNAL "PREFERRED") (DO* "LISP" :EXTERNAL "O.K.") (DOLIST "LISP" :EXTERNAL "O.K.") (DOTIMES "LISP" :EXTERNAL "O.K.") (DOUBLE-FLOAT "LISP" :EXTERNAL "O.K.") (EQ "LISP" :EXTERNAL "EQ") (EQL "LISP" :EXTERNAL "EQ") (EQUAL "INTERLISP" :EXTERNAL "PREFERRED") (EQUALP "LISP" :EXTERNAL "O.K.") (FBOUNDP "LISP" :EXTERNAL "O.K.") (FILL-POINTER "INTERLISP" :EXTERNAL "PREFERRED") (FLOAT "LISP" :EXTERNAL "EQ") (FLOATP "INTERLISP" :EXTERNAL "PREFERRED") (FUNCALL "LISP" :EXTERNAL "O.K.") (FUNCTION "INTERLISP" :EXTERNAL "PREFERRED") (GO "LISP" :EXTERNAL "EQ") (GRAPHIC-CHAR-P "LISP" :EXTERNAL "O.K.") (IF "INTERLISP" :EXTERNAL "PREFERRED") (INT-CHAR "LISP" :EXTERNAL "O.K.") (INTEGER "LISP" :EXTERNAL "EQ") (INTEGERP "LISP" :EXTERNAL "O.K.") (LAMBDA "INTERLISP" :EXTERNAL "PREFERRED") (LET "LISP" :EXTERNAL "EQ") (LET* "LISP" :EXTERNAL "EQ") (LIST* "LISP" :EXTERNAL "EQ") (LISTFILES1 "INTERLISP" :EXTERNAL "O.K.") (LISTP "INTERLISP" :EXTERNAL "PREFERRED") (LONG-FLOAT "LISP" :EXTERNAL "O.K.") (LOWER-CASE-P "LISP" :EXTERNAL "O.K.") (MAKE-ARRAY "LISP" :EXTERNAL "O.K.") (MAKE-CHAR "LISP" :EXTERNAL "O.K.") (MAKECMLINDEX "INTERLISP" :EXTERNAL "ERROR") (MAPCAR "INTERLISP" :EXTERNAL "PREFERRED") (MEMBER "INTERLISP" :EXTERNAL "PREFERRED") (MOD "INTERLISP" :EXTERNAL "PREFERRED") (NAME-CHAR "LISP" :EXTERNAL "O.K.") (NEWPRINTDEF "INTERLISP" :EXTERNAL "O.K.") (NOT "LISP" :EXTERNAL "EQ") (NULL "LISP" :EXTERNAL "EQ") (NUMBERP "INTERLISP" :EXTERNAL "PREFERRED") (OR "LISP" :EXTERNAL "EQ") (PPLISTFILE "INTERLISP" :EXTERNAL "ERROR") (PROG "LISP" :EXTERNAL "EQ") (PROG* "LISP" :EXTERNAL "EQ") (PROG1 "LISP" :EXTERNAL "EQ") (PROG2 "LISP" :EXTERNAL "EQ") (PROGN "LISP" :EXTERNAL "EQ") (PSETQ "LISP" :EXTERNAL "O.K.") (QUOTE "LISP" :EXTERNAL "EQ") (RATIONAL "INTERLISP" :EXTERNAL "PREFERRED") (RATIONALP "LISP" :EXTERNAL "O.K.") (SATISFIES "LISP" :EXTERNAL "EQ") (SBIT "LISP" :EXTERNAL "O.K.") (SET "LISP" :EXTERNAL "EQ") (SETF "LISP" :EXTERNAL "O.K.") (SETQ "INTERLISP" :EXTERNAL "PREFERRED") (SHORT-FLOAT "LISP" :EXTERNAL "O.K.") (SIGNED-BYTE "INTERLISP" :EXTERNAL "PREFERRED") (SIMPLE-ARRAY "LISP" :EXTERNAL "O.K.") (SIMPLE-BIT-VECTOR "LISP" :EXTERNAL "O.K.") (SIMPLE-STRING "INTERLISP" :EXTERNAL "PREFERRED") (SIMPLE-VECTOR "LISP" :EXTERNAL "O.K.") (SINGLE-FLOAT "LISP" :EXTERNAL "O.K.") (SPECIAL-FORM-P "LISP" :EXTERNAL "O.K.") (STANDARD-CHAR-P "LISP" :EXTERNAL "O.K.") (STRING "LISP" :EXTERNAL "EQ") (STRING-CHAR-P "LISP" :EXTERNAL "O.K.") (STRINGP "INTERLISP" :EXTERNAL "PREFERRED") (SVREF "LISP" :EXTERNAL "O.K.") (TAGBODY "LISP" :EXTERNAL "O.K.") (THE "LISP" :EXTERNAL "EQ") (THROW "LISP" :EXTERNAL "O.K.") (TYPE-OF "LISP" :EXTERNAL "O.K.") (TYPECASE "LISP" :EXTERNAL "O.K.") (TYPEP "LISP" :EXTERNAL "EQ") (UNLESS "INTERLISP" :EXTERNAL "PREFERRED") (UNSIGNED-BYTE "LISP" :EXTERNAL "O.K.") (UNWINDPROTECT "INTERLISP" :EXTERNAL "ERROR") (UPPER-CASE-P "LISP" :EXTERNAL "O.K.") (VALUES "INTERLISP" :EXTERNAL "PREFERRED") (VECTOR "INTERLISP" :EXTERNAL "PREFERRED") (VECTOR-POP "LISP" :EXTERNAL "O.K.") (VECTOR-PUSH "LISP" :EXTERNAL "O.K.") (VECTOR-PUSH-EXTEND "LISP" :EXTERNAL "O.K.") (VECTORP "LISP" :EXTERNAL "O.K.") (WHEN "INTERLISP" :EXTERNAL "PREFERRED") (WRITE-STRING "LISP" :EXTERNAL "O.K.") (CL::FOO1 "LISP" :INTERNAL) (CL::FOO2 "LISP" :INTERNAL) (CL::LYRIC "LISP" :INTERNAL) (:FOO "KEYWORD" :EXTERNAL) (:BAR "KEYWORD" :EXTERNAL) (:LYRIC "KEYWORD" :EXTERNAL) (:KEYWORD "KEYWORD" :EXTERNAL) (:WOW "KEYWORD" :EXTERNAL) (MAKEFILE "INTERLISP" :EXTERNAL) (CL:* "LISP" :EXTERNAL) (APPEND "INTERLISP" :EXTERNAL) (PLUS "INTERLISP" :EXTERNAL) (SORT "INTERLISP" :EXTERNAL) (LOGOUT "INTERLISP" :EXTERNAL) (LOGIN "INTERLISP" :EXTERNAL) (abc "INTERLISP" :EXTERNAL) (XYZ "INTERLISP" :EXTERNAL) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PRETTY-CIRCLE-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/PRETTY-CIRCLE-REGRESSION.TEST new file mode 100644 index 00000000..98772eae --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PRETTY-CIRCLE-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Testing whether *print-circle* overrides *print-pretty* because ;;; our pretty-printer can't hack circular structures yet... (do-test ":circle overrides :pretty" (ignore-errors (string= (write-to-string '#1=(#1# . #1#) :pretty t :circle t) "#1= (#1# . #1#)")) ) (do-test ":escape overrides :pretty" (string= (write-to-string '(defun foo (bar baz) (drek "junk")) :pretty t :escape nil) "(defun foo (bar baz) (drek junk))") ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST b/internal/test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST new file mode 100644 index 00000000..2d9be223 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST @@ -0,0 +1 @@ +(do-test "-0.0 doesn't blow up number printer" (string= (write-to-string (* 0.0 -1.0)) "-0.0")) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PROC-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/PROC-REGRESSION.TEST new file mode 100644 index 00000000..5a8e9fde --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PROC-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for WITH.MONITOR macro. ;;; AR 7706 ;;; Nested with.monitor's for same lock lose. ;;; Need to make sure that return from inner with.monitor does ;;; not release lock unless it actually acquired it. ;;; This also tests ar 7280--interpreted with.monitor fails. (do-test nested-monitor (let ((lock (il:create.monitorlock "Test")) ) (macrolet ((test-monitor () `(il:process.result (il:add.process `(il:obtain.monitorlock ',lock t)) t))) (and (il:with.monitor lock (and (null (test-monitor)) ; locked now (il:with.monitor lock (null (test-monitor))) ; still locked (null (test-monitor))) ; locked after nested exit ) (not (null (test-monitor)))))) ; but unlocked now ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/PROPERTY.TEST b/internal/test/LANGUAGE/AUTO/PROPERTY.TEST new file mode 100644 index 00000000..7ead376f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/PROPERTY.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: il:getprop ;; ;; Source: IRM, p 2.5 ;; ;; Chapter 2: Litatoms ;; section 3: Property Lists ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>property>getprop.test ;; ;; (do-test "test putprop & getprop" (let* ((tempx (gensym)) (tempy (gensym))) (and (equal 'tennis (il:putprop tempx 'shoes 'tennis)) (equal 'basket (il:putprop tempy 'games 'basket)) (equal 'tennis (il:getprop tempx 'shoes)) (equal 'basket (il:getprop tempy 'games)) (equal nil (il:getprop tempx 'games)) (equal nil (il:getprop tempy 'shoes)) (equal 'foot (il:putprop tempy 'games 'foot)) (equal 'foot (il:getprop tempy 'games)) ))) (do-test "test addprop" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(basket foot) (il:addprop tempx 'games 'foot)) (equal '(base basket foot) (il:addprop tempx 'games 'base T)) (equal '(base basket foot) (il:getprop tempx 'games)) ))) (do-test "test remprop" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(basket foot) (il:addprop tempx 'games 'foot)) (equal 'games (il:remprop tempx 'games)) (equal nil (il:getprop tempx 'games 'base T)) (equal nil (il:remprop tempx 'games)) ))) (do-test "test remproplist" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(basket foot) (il:addprop tempx 'games 'foot)) (equal nil (il:remproplist tempx '(games))) (equal nil (il:getprop tempx 'games)) (equal nil (il:remproplist tempx '(games))) ))) (do-test "test changeprop" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal tempx (il:changeprop tempx 'games 'sports)) (equal '(basket) (il:getprop tempx 'sports)) ))) (do-test "test propnames" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(games) (il:propnames tempx)) ))) (do-test "test deflist" (let* ((tempx (gensym)) (tempy (gensym))) (and (equal nil (il:deflist '((tempx Janet) (tempy Leslie)) 'friends)) (equal 'Janet (il:getprop 'tempx 'friends)) (equal 'Leslie (il:getprop 'tempy 'friends)) ))) (do-test "test getproplist" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(games (basket)) (il:getproplist tempx)) ))) (do-test "test setproplist" (let* ((tempx (gensym))) (and (equal '(work fun) (il:setproplist tempx '(work fun))) (equal '(work fun) (il:getproplist tempx)) ))) (do-test "test getlis" (let* ((tempx (gensym))) (and (equal '(work fun) (il:setproplist tempx '(work fun))) (equal '(work fun) (il:getlis tempx '(work))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/REGRESSION.TEST new file mode 100644 index 0000000000000000000000000000000000000000..6c07bd5dd9c414bbb82ce747391ae88061b0e6cd GIT binary patch literal 2445 zcmah}ZEw<06vkzXuF3r5%QVp(x9D!gvcAv)ON=4Nbje=K#Kf-!F3_ZFp)JVv)BG*| z7|*@sLR%>9m)@T9JkNRUC4FCsXc)l}osT03ox8D1VKDW2k>h(uAQ3v5+AfgR0Orw8|W&si9j(a#biQ&b|#nAd!T`zqoU^JFbHg( zJOs8A(mq5!L?a3-sZ}xL6f{;0)7nstM~8Og%xFT%1|h#8Eu{`zv5Ey9w}@8J>J443 zY1pjAN!}1;MuU5B?O;gr+lE~?jfSdOwA^3`>lMSQn>AIVWv!lRTsR3L_~S$)5Pe>o z28UpVY#O}tqW`OL+M(kWsBj3cQ>gF{Osm$gs_4sV(8c_HW|I5HB{3uEI_YbubGB!$dH~*fTQ<4+huch+%uO>fCwA@ z1yskS!No}x*rz?ePnCh|+Y#7aAHtsPF24f`j)&6@X?P?NbW0?p(FEpTRO))wqDobh zC2}`)BM1K?WoElms&ELgp$k13NGie{qc8r?IgnH==;ErSayxf@Kj2Aqogr=n<^b7P zT?ca}0|+n@7J+z0*DUkYQtJ%^3{9=+vb4XyPd=v{qznO&k1$w3SY%nkzAZ0@=zdHA zZx}3^1~5S3R(w;$jR4~L5fFwNv-y}{$#Al~CwM=ZD8x@L(D5QVq(K~CDzRs;v{NGd zRKgQJJC7D$>o0-ho-H`$-$k{<(n06qs{Ql!=BjyJI#>#RDQVa=gKF0PxGfNPncGo2lt?7R55GCUTBm+TN%5<~epX#fEgVoUBx zA$LveMXnh4B;&4el`MBx7!C^)ITg^gBDiO3+~ZuXTo`w)i1)c-uL{NTxy6(CkQ?`P zVcdM~vb;SZuNA627f>;ZC&I8)dnzn^)wT}D%*NxHBq`652ASPETm;{wvKM{{9D#vv_#` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST new file mode 100644 index 00000000..c936428a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "RESETVAR works interpreted" (il:defineq (il:foo (il:lambda nil il:unixftpflg))) (il:advise 'il:foo 'il:around nil '(il:resetvar il:unixftpflg t il:*)) (eq t (il:foo))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST b/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST new file mode 100644 index 00000000..76716b94 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST @@ -0,0 +1 @@ +;;;; Simple test of supplied-p parameters (do-test "supplied-p: funcitons" (setf (symbol-function 'supplied-p-test) '(lambda (&key (key 'init key-supplied)) (list key key-supplied))) (and (equal (supplied-p-test) '(init nil)) (equal (supplied-p-test :key 'foo) '(foo t)) (compile 'supplied-p-test) (equal (supplied-p-test) '(init nil)) (equal (supplied-p-test :key 'foo) '(foo t))) ) (do-test "supplied-p: macros" (defmacro supplied-p-test-m (&key (key 'init key-supplied)) `'(,key ,key-supplied)) (setf (symbol-function '|expand-SUPPLIED-P-TEST-M|) (il:closure-function (symbol-function '|expand-SUPPLIED-P-TEST-M|))) (and (equal (supplied-p-test-m) '(init nil)) (equal (supplied-p-test-m :key foo) '(foo t)) (compile '|expand-SUPPLIED-P-TEST-M|) ; This is implementation-dependent (equal (supplied-p-test-m) '(init nil)) (equal (supplied-p-test-m :key foo) '(foo t))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST b/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST new file mode 100644 index 00000000..de104fcd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST @@ -0,0 +1 @@ +(DO-TEST "AR 8409 - IL:MKATOM shouldn't return multiple values" (NULL (CDR (MULTIPLE-VALUE-LIST (IL:MKATOM "FOO"))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/SMALLP.TEST b/internal/test/LANGUAGE/AUTO/SMALLP.TEST new file mode 100644 index 00000000..b6f0d1bc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/SMALLP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SMALLP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>SmallP.test ;; ;; (do-test "test simple cases" (and (eq 5 (il:smallp 5)) (eq -4 (il:smallp -4)) (eq nil (il:smallp 'a-smallp)) (eq nil (il:smallp "a string")) )) (do-test "Test go on own function" (flet ((temp-small nil 2) (temp-large nil -3) ) (test-defun temp-fun nil 32) (and (eq 2 (il:smallp (temp-small))) (equal -3 (il:smallp (temp-large))) (equal 32 (il:smallp (temp-fun))) ))) (do-test "Test large and floating aren't small numbers" (and (eq nil (il:smallp 100000)) (eq nil (il:smallp 32.4)) (eq nil (il:smallp 32e6)) )) (do-test "Test work against system functions" (and (eq 3 (il:smallp (third '(1 2 3 4 5)))) (equal 3 (il:smallp (car '(3 2.2 1.1)))) (equal 2 (il:smallp (second '(1 2 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:smallp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:smallp 'A-couple-dashs)) (eq nil (il:smallp 'Numbers-1234567890)) (eq nil (il:smallp 'il:other-packags)) (eq nil (il:smallp 'il:other-packagsNumbers-1234567890)) (eq nil (il:smallp 'il:other-packagsA-couple-dashs)) (eq nil (il:smallp T)) (eq nil (il:smallp nil)) (eq nil (il:smallp ())) (eq nil (il:smallp '())) (eq nil (il:smallp (list))) (eq nil (il:smallp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:smallp (tee))) (eq nil (il:smallp (nill))) (eq nil (il:smallp (temp-litatom))) (eq nil (il:smallp (temp-string))) (eq nil (il:smallp (temp-fun))) (eq nil (il:smallp temp-litatom)) ))) (do-test "Stop stop on system functions" (and (eq nil (il:smallp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:smallp (second '(#\. #\k)))) )) (do-test "Test arrays aren't small numbers" (and (eq nil (il:smallp (make-array '(2 2)))) (eq nil (il:smallp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:smallp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:smallp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:smallp (make-array 50 :initial-element 0))) (eq nil (il:smallp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't small numbers" (and (eq nil (il:smallp #\backspace)) ; character (eq nil (il:smallp #\*)) ; character (eq nil (il:smallp #\.)) ; character (eq nil (il:smallp (make-hash-table))) ; hash table (eq nil (il:smallp (car (list-all-packages)))) ; packages (eq nil (il:smallp (pathname nil))) ; pathname (eq nil (il:smallp *random-state*)) ; ramdom state (eq nil (il:smallp #'cons)) ; compiled function (eq nil (il:smallp (copy-readtable))) ; readtable (eq nil (il:smallp #*1001)) ; simple-bit-vector (eq nil (il:smallp "twine")) ; simple-string (eq nil (il:smallp (make-synonym-stream nil))) ; stream (eq nil (il:smallp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/SPECIALS.TEST b/internal/test/LANGUAGE/AUTO/SPECIALS.TEST new file mode 100644 index 00000000..5df26ea7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/SPECIALS.TEST @@ -0,0 +1 @@ +(xcl-test:do-test "simple lexical binding" (= 3 (let ((a 3)) a))) (xcl-test:do-test-group "simple special binding" :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (special a)) b)) (defun goo () (declare (special a )) a)) (xcl-test:do-test "special 1" (let ((a 3)) (declare (special a)) (eq (goo) 3))) (xcl-test:do-test "special reference in let value form" (let ((a 'outer)) (declare (special a )) (eq (goo2) 'outer)))) ;; now try with specvars for references. (xcl-test:do-test-group "using il:specvars in declare for bindings." :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (il:specvars a)) b)) (defun goo () (declare (il:specvars a )) a)) (xcl-test:do-test "special 1" (let ((a 3)) (declare (il:specvars a)) (eq (goo) 3))) (xcl-test:do-test "special reference in let value form" (let ((a 'outer)) (declare (il:specvars a )) (eq (goo2) 'outer)))) ;; from AR's (xcl-test:do-test "#' finding lexical functions AR 5995" (equal '(2) (flet ((bar (n) (1+ n))) (mapcar #'bar '(1))))) (xcl-test:do-test "THROW vs. closures AR 6092" (let ((this-one t)) (catch 'foo (let ((closure #'(lambda () (throw 'foo this-one)))) (funcall closure) (values nil) ) ) )) (xcl-test:do-test "Interpreted &ALLOW-OTHER-KEYS AR 6122" (eq ((lambda (&key key &allow-other-keys) 'ok)) 'ok) ) (xcl-test:do-test "Interpreter: invalid keywords ar 6123" (xcl-test:expect-errors (error) ((lambda (&key foo) 'foo) :bar 'bar)) ) (xcl-test:do-test "value of eval-when 6252" (equal 3 (eval-when(eval) 3))) (xcl-test:do-test "simple special in let* ar 6369" (eq t (let* (x) (declare (special x)) t))) (xcl-test:do-test "shadowing flets ar 6734" (eq 4 (flet ((foo () 3)) (flet ((foo () 4)) (foo))))) (xcl-test:do-test "interaction of FLET and MACROLET AR 7127" (= 17 (macrolet ((foo (x) `(bar ,x))) (flet ((bar (y) (+ 1 y))) (foo 16))))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/STACK.TEST b/internal/test/LANGUAGE/AUTO/STACK.TEST new file mode 100644 index 0000000000000000000000000000000000000000..ee94094b48d9f0965b922e2b92656f2b50501573 GIT binary patch literal 1661 zcma)5!EO^V5Z$J&1o;6ZI55hA?jBMp5(j8dq$ng1kv3_waCdf{#H!cc+D>Vx_$Dr# z_!d5f87G@;NvK$@cE>Ys-kTZQ%_hWiVF6zTiI$QlPG|*s3XWT6VQO>+Zq8xsSaN-O zp&joD$xi|LZVl>7LpmzCgtX|+HB(M zd$D?967GwqxjBC4R&_{$D#(YmQGiC-VJ5YZGRG#&Vo?t6yGE!bx8L8zIRDl_*t|7Z z8j-X{k}2ET*#?}xn&Ggh!Hi*NT1l*3Z#351MPpu9;K5Wbg;HqSGk|+;1d1XePqg7J z+WnQ-T9O>qYMAOeSy1a0Zj3fHB)H4*V$}W8Lg@ckbE%Du8R4_1jjL|lyBePF>jOg++1H2R&R;+p z8`S1pN?oIht;16?tMePWF>C*(A*fcz@o-cP=s6CKf-t!Bw*OQPw)S6E7`)zk9>x9q zPuvz3Ji!^5K literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/AUTO/STRING.TEST b/internal/test/LANGUAGE/AUTO/STRING.TEST new file mode 100644 index 00000000..9a653eff --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/STRING.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: All of chapter 4 of the IRM ;; ;; Source: IRM, p 4.1 ;; ;; Chapter 4: Strings ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Strings.test ;; ;; (do-test "test strequal" (and (eq T (il:strequal "ABC" "ABC")) (eq nil (il:strequal "ABC" "def")) )) (do-test "test string-equal" (and (eq T (il:string-equal "ABC" "ABC")) (eq nil (il:string-equal "ABC" "def")) (eq T (il:string-equal "ABC" 'abc)) (eq T (il:string-equal "ABC" "AbC")) )) (do-test "test allocstring" (let* ((tempx "old string")) (and (equal "AAAAA" (il:allocstring 5 'a)) (equal "CCCCCCCCCC" (il:allocstring 10 'C)) (equal "****" (il:allocstring 4 '*)) (equal "...." (il:allocstring 4 '.)) (equal "HHH" (il:allocstring 3 'h tempx)) (equal "HHH" tempx) ))) (do-test "test mkstring" (and (equal "ABC" (il:mkstring "ABC")) (equal "(A B C)" (il:mkstring '(a b c))) (equal "NIL" (il:mkstring nil)) )) (do-test "test nchars" (and (equal 3 (il:nchars 'ABC)) (equal 5 (il:nchars "ABC" T)) )) (do-test "test substring" (and (equal "DEF" (il:substring "ABCDEFG" 4 6)) (equal "C" (il:substring "ABCDEFG" 3 3)) (equal "CDEFG" (il:substring "ABCDEFG" 3 nil)) (equal "DEF" (il:substring "ABCDEFG" 4 -2)) (equal NIL (il:substring "ABCDEFG" 6 4)) (equal NIL (il:substring "ABCDEFG" 4 9)) (equal "B C" (il:substring '(a b c) 4 6)) )) (do-test "test gnc" (let* ((tempx "abcdefg")) (and (equal "a" (il:mkstring (il:gnc tempx))) (equal "bcdefg" tempx) (equal "b" (il:mkstring (il:gnc tempx))) (equal "cdefg" tempx) ))) (do-test "test glc" (let* ((tempx "abcdefg")) (and (equal "g" (il:mkstring (il:glc tempx))) (equal "abcdef" tempx) (equal "f" (il:mkstring (il:glc tempx))) (equal "abcde" tempx) ))) (do-test "test concat" (and (equal "abcDEF" (il:concat "abc" "DEF")) (equal "abcDEFGHI" (il:concat "abc" 'DEF "GHI")) (equal "(A B C)ABC" (il:concat '(a b c) "ABC")) )) (do-test "test concatlist" (and (equal "AB(C D)EF" (il:concatlist '(A B (C D) "EF"))) )) (do-test "test rplstring" (and (equal "ABCEND" (il:rplstring "ABCDEF" -3 "END")) (equal "ABC(A B C)K" (il:rplstring "ABCDEFGHIJK" 4 '(A B C))) )) (do-test "test rplcharcode" (and (equal "ABFDEF" (il:rplcharcode "ABCDEF" 3 (il:charcode F))) (equal "ABCDXF" (il:rplcharcode "ABCDEF" -2 (il:charcode X))) )) (do-test "test strpos" (and (eq 4 (il:strpos "ABC" "XYZABCDEF")) (eq NIL (il:strpos "ABC" "XYZABCDEF" 5)) (eq 10 (il:strpos "ABC" "XYZABCDEFABC" 5)) (eq 4 (il:strpos "A&C&" "XYZABCDEF" NIL '&)) (eq NIL (il:strpos "DEF&" "XYZABCDEF" NIL '&)) (eq NIL (il:strpos "ABC" "XYZABCDEF" NIL NIL T)) (eq 4 (il:strpos "ABC" "XYZABCDEF" 4 NIL T)) (eq 7 (il:strpos "ABC" "XYZABCDEFABC" NIL NIL NIL T)) (eq 2 (il:strpos "A" "A" NIL NIL NIL T)) )) (do-test "test strposl" (and (eq 4 (il:strposl '(A B C) "XYZBCD")) (eq 5 (il:strposl '(A B C) "XYZBCD" 5)) (eq 4 (il:strposl '(A B C) "ABCDEF" nil T)) (eq 3 (il:strposl '(A B C D) "XYZBCD" nil T T)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/STRING.TESTS b/internal/test/LANGUAGE/AUTO/STRING.TESTS new file mode 100644 index 00000000..3fe235ca --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/STRING.TESTS @@ -0,0 +1 @@ +(and (string-equal "abc" "ABC") (not (string-equal "abc" "abcd")) (eql 3(string= "abc" "abc")) (not (string= "abc" "ABC")) (not (string= "abc" "abcd")) (not (string= "abcd" "abc")) (eql 0 (string< "abc" "bbc")) (eql 1 (string< "abc" "adc")) (eql 3 (string< "abc" "abcd")) (not (string< "bbc" "abc")) (not (string< "abcd" "abc")) (eql 0 (string/= "abc" "def")) (eql 3 (string/= "abc" "abcd")) (eql 3 (string/= "abcd" "abc")) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/STRINGP.TEST b/internal/test/LANGUAGE/AUTO/STRINGP.TEST new file mode 100644 index 00000000..b73de165 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/STRINGP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: StringP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>StringP.test ;; ;; (do-test "test simple cases" (and (equal "a string" (il:stringp "a string")) (equal "Try 12321*& ()" (il:stringp "Try 12321*& ()")) (eq nil (il:stringp -5)) (eq nil (il:stringp 1000000)) (eq nil (il:stringp 'a-floatp)) )) (do-test "Test lists of various things" (and (equal "ABCDEFGHIJKLM" (il:stringp "ABCDEFGHIJKLM")) (equal "NOPQRSTUVWXYZ" (il:stringp "NOPQRSTUVWXYZ")) (equal "abcdefghijklm" (il:stringp "abcdefghijklm")) (equal "nopqrstuvwxyz" (il:stringp "nopqrstuvwxyz")) (equal "1234567890" (il:stringp "1234567890")) (equal "!@#$%^&*()" (il:stringp "!@#$%^&*()")) (equal "-=[];'`,./" (il:stringp "-=[];'`,./")) (equal "_+{}:\"~<>?" (il:stringp "_+{}:\"~<>?")) )) (do-test "Test go on own function" (flet ((temp-small nil "abcdefghijklm") ) (test-defun temp-fun nil "-=[];'`,./") (and (equal "abcdefghijklm" (il:stringp (temp-small))) (equal "-=[];'`,./" (il:stringp (temp-fun))) ))) (do-test "Test work against system functions" (and (equal "A rat in the" (il:stringp (concatenate 'string "A rat" " in the"))) (equal "LITATOM" (il:stringp (il:mkstring 'litatom))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:stringp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:stringp 'A-couple-dashs)) (eq nil (il:stringp 'Numbers-1234567890)) (eq nil (il:stringp 'il:other-packags)) (eq nil (il:stringp 'il:other-packagsNumbers-1234567890)) (eq nil (il:stringp 'il:other-packagsA-couple-dashs)) (eq nil (il:stringp T)) (eq nil (il:stringp nil)) (eq nil (il:stringp ())) (eq nil (il:stringp '())) (eq nil (il:stringp (list))) (eq nil (il:stringp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-number nil 1234)) (test-defun temp-fun nil 45.65) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:stringp (tee))) (eq nil (il:stringp (nill))) (eq nil (il:stringp (temp-litatom))) (eq nil (il:stringp (temp-number))) (eq nil (il:stringp (temp-fun))) (eq nil (il:stringp temp-litatom)) ))) (do-test "Stop on non-strings from system functions" (and (eq nil (il:stringp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:stringp (second '(#\. #\k)))) )) (do-test "Test arrays aren't strings" (and (eq nil (il:stringp (make-array '(2 2)))) (eq nil (il:stringp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:stringp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:stringp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:stringp (make-array 50 :initial-element 0))) )) (do-test "Test other datatypes aren't strings" (and (eq nil (il:stringp #\backspace)) ; character (eq nil (il:stringp #\*)) ; character (eq nil (il:stringp #\.)) ; character (eq nil (il:stringp (make-hash-table))) ; hash table (eq nil (il:stringp (car (list-all-packages)))) ; packages (eq nil (il:stringp (pathname nil))) ; pathname (eq nil (il:stringp *random-state*)) ; ramdom state (eq nil (il:stringp #'cons)) ; compiled function (eq nil (il:stringp (copy-readtable))) ; readtable (eq nil (il:stringp #*1001)) ; simple-bit-vector (eq nil (il:stringp (make-synonym-stream nil))) ; stream (eq nil (il:stringp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST b/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST new file mode 100644 index 00000000..26dee76e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST @@ -0,0 +1 @@ +;; AR 7993 test ;; Filed as {ERIS}TEST>CMLSTRING>AR7993.TEST ;; By Peter Reidy ;; Verify that CLtL's string comparison functions work on single characters as well as strings. (do-test AR7993 (and (string= #\a #\a) (string-equal #\a #\A) (string< #\a #\b) (string> #\8 #\5) (string<= #\a #\b) (string<= #\b #\b) (string>= #\8 #\5) (string>= #\linefeed #\linefeed) (string/= #\a #\A) (string-lessp #\a #\B) (string-not-lessp #\B #\a) (string-greaterp #\B #\a) (string-not-greaterp #\a #\B) (string-not-equal #\a #\B) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/STRUCTURE-PRINT-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/STRUCTURE-PRINT-REGRESSION.TEST new file mode 100644 index 00000000..0db29bdc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/STRUCTURE-PRINT-REGRESSION.TEST @@ -0,0 +1 @@ +;; This tests for both AR 7437 (circle labels go to *standard-output*) ;; and 7438 (some circular structures don't get printed at all). (do-test-group (structure-print :before (defstruct graph nodes)) (do-test "structures circle-print" (let ((xcl:*print-structure* t)) (declare (special xcl:*print-structure*)) (string= (write-to-string (let ((foo (make-graph))) (setf (graph-nodes foo) foo)) :circle t) "#1=#S(GRAPH NODES #1#)")))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST b/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST new file mode 100644 index 00000000..94e71cfd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST @@ -0,0 +1 @@ +(do-test "timeall OK" (AND (EQL (IL:timeall (car '(1 2))) 1) (EQL (IL:timeall (car '(1 2)) 10) 1) )) (DO-TEST "time OK" (AND (EQL (time (car '(1 2))) 1) (EQL (time (car '(1 2)) :repeat 10) 1) (multiple-value-bind (a b) (time (values 1 2)) (and (eql a 1) (eql b 2))) (multiple-value-bind (a b) (time (values 1 2) :repeat 10) (and (eql a 1) (eql b 2))) )) (do-test "AR 7648 - encode-universal-time" (and (= (encode-universal-time 1 0 0 1 1 1900 0) 1) (= (encode-universal-time 1 0 0 1 1 1976 0) 2398291201) (= (encode-universal-time 0 0 0 1 1 3000 0) 34712668800))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/TYPENAME.TEST b/internal/test/LANGUAGE/AUTO/TYPENAME.TEST new file mode 100644 index 00000000..d027cb78 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/TYPENAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TypeName ;; ;; Source: IRM, p 8.20 ;; ;; Chapter 8: Record Package ;; Section 9: Built-In and User DataTypes ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>TypeName.test ;; ;; (do-test "test simple cases" (and (eq 'il:smallp (il:typename 5)) (eq 'il:stringp (il:typename "a string")) (eq 'il:litatom (il:typename 'a-litatom)) (eq 'il:floatp (il:typename 4.5)) )) (do-test "Test go on own function" (flet ((temp-small1 nil 12) (temp-small2 nil 'bv) (temp-small3 nil "hi") ) (test-defun temp-fun1 nil 34) (test-defun temp-fun2 nil 'QW) (test-defun temp-fun3 nil "bye") (and (eq 'il:smallp (il:typename (temp-small1))) (eq 'il:litatom (il:typename (temp-small2))) (eq 'il:stringp (il:typename (temp-small3))) (eq 'il:smallp (il:typename (temp-fun1))) (eq 'il:litatom (il:typename (temp-fun2))) (eq 'il:stringp (il:typename (temp-fun3))) ))) (do-test "Test work against system functions" (and (eq 'il:smallp (il:typename (+ 1 2))) (eq 'il:litatom (il:typename (car '(a b d)))) (eq 'il:stringp (il:typename (concatenate 'string "a" "b"))) (eq 'il:listp (il:typename (append '(a) '(b)))) )) (do-test "Test a bunch of data types..." (and (eq 'il:twod-array (il:typename (make-array '(2 2)))) (eq 'il:character (il:typename #\backspace)) (eq 'il:character (il:typename #\*)) (eq 'il:character (il:typename #\.)) (eq 'il:harrayp (il:typename (make-hash-table))) (eq 'package (il:typename (car (list-all-packages)))) (eq 'pathname (il:typename (pathname nil))) (eq 'random-state (il:typename *random-state*)) (eq 'il:compiled-closure (il:typename #'cons)) (eq 'readtablep (il:typename (copy-readtable))) (eq 'il:oned-array (il:typename #*1001)) (eq 'stream (il:typename (make-synonym-stream nil))) (eq 'il:oned-array (il:typename '#( 5 4 3 2 1))) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST b/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST new file mode 100644 index 00000000..4230910d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TypeNameP ;; ;; Source: IRM, p 8.20 ;; ;; Chapter 8: Record Package ;; Section 9: Built-In and User DataTypes ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>TypeNameP.test ;; ;; (do-test "test simple cases" (and (il:typenamep 5 'il:smallp) (il:typenamep "a string" 'il:stringp) (il:typenamep 'a-litatom 'il:litatom) (il:typenamep 4.5 'il:floatp) )) (do-test "Test go on own function" (flet ((temp-small1 nil 12) (temp-small2 nil 'bv) (temp-small3 nil "hi") ) (test-defun temp-fun1 nil 34) (test-defun temp-fun2 nil 'QW) (test-defun temp-fun3 nil "bye") (and (il:typenamep (temp-small1) 'il:smallp) (il:typenamep (temp-small2) 'il:litatom) (il:typenamep (temp-small3) 'il:stringp) (il:typenamep (temp-fun1) 'il:smallp) (il:typenamep (temp-fun2) 'il:litatom) (il:typenamep (temp-fun3) 'il:stringp) ))) (do-test "Test work against system functions" (and (il:typenamep (+ 1 2) 'il:smallp) (il:typenamep (car '(a b d)) 'il:litatom) (il:typenamep (concatenate 'string "a" "b") 'il:stringp) (il:typenamep (append '(a) '(b)) 'il:listp) )) (do-test "Test a bunch of data types..." (and (il:typenamep (make-array '(2 2)) 'il:twod-array) (il:typenamep #\backspace 'il:character) (il:typenamep #\* 'il:character) (il:typenamep #\. 'il:character) (il:typenamep (make-hash-table) 'il:harrayp) (il:typenamep (car (list-all-packages)) 'package) (il:typenamep (pathname nil) 'pathname) (il:typenamep *random-state* 'random-state) (il:typenamep #'cons 'il:compiled-closure) (il:typenamep (copy-readtable) 'readtablep) (il:typenamep #*1001 'il:oned-array) (il:typenamep (make-synonym-stream nil) 'stream) (il:typenamep '#( 5 4 3 2 1) 'il:oned-array) )) (do-test "Test fails correctly" (flet ((temp-small nil 12)) (test-defun temp-fun nil '(a b c)) (and (eq nil (il:typenamep 54 'stringp)) (eq nil (il:typenamep '(a b d) 'package)) (eq nil (il:typenamep (temp-small) 'stringp)) (eq nil (il:typenamep (temp-fun) 'package)) (eq nil (il:typenamep (car '(a b d)) 'smallp)) (eq nil (il:typenamep (concatenate 'string "a" "b") 'listp)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/USERDEF.TEST b/internal/test/LANGUAGE/AUTO/USERDEF.TEST new file mode 100644 index 00000000..ef59059a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/USERDEF.TEST @@ -0,0 +1 @@ +(DO-TEST "USER DEFINED RECORD TYPES -SET UP" (SETQ IL::CLISPRECORDTYPES (CONS 'IL:TESTRECORD IL::CLISPRECORDTYPES)) (IL:MOVD 'IL:RECORD 'IL:TESTRECORD) (IL:DEFINEQ (TESTRECORDMANIP(DECL) `(IL:RECORD ,@(CDR DECL)))) (IL:PUTPROP 'IL:TESTRECORD 'IL:USERRECORDTYPE 'TESTRECORDMANIP)) (DO-TEST "USER DEFINED RECORD TYPES - CREATION" (IL:TESTRECORD FOO (A B C)) (SETQ FOO1 (IL:CREATE FOO B IL:_ 2)) (IL:REPLACE (FOO A) IL:OF FOO1 IL:WITH 1) (AND (EQ (IL:FETCH (FOO B) IL:OF FOO1) 2) (EQ (IL:FETCH (FOO A) IL:OF FOO1) 1))) (DO-TEST "USER DEFINED RECORDS - CLEANUP" (SETQ IL::CLISPRECORDTYPES (CDR IL::CLISPRECORDTYPES))) (DO-TEST "SUBRECORDS" (IL:RECORD FOO ( X Y Z)) (IL:RECORD BAR (L M FOO) (IL:SUBRECORD FOO)) (SETQ BAR1 (IL:CREATE BAR X IL:_ 5)) (IL:REPLACE (BAR M) IL:OF BAR1 IL:WITH 2) (AND (EQ (IL:FETCH (BAR X) IL:OF BAR1) 5) (EQ (IL:FETCH (BAR M) IL:OF BAR1) 2))) (DO-TEST "RECURSIVE RECORDS" (IL:RECORD FOOBAR (FOO BAR)(IL:RECORD FOO (A B C)) (IL:RECORD BAR (D E F))) (SETQ FOOBAR1 (IL:CREATE FOOBAR A IL:_ 1)) (IL:REPLACE (FOOBAR D) IL:OF FOOBAR1 IL:WITH 5) (AND (EQ (IL:FETCH (FOOBAR A) IL:OF FOOBAR1) 1) (EQ (IL:FETCH (FOOBAR D) IL:OF FOOBAR1) 5))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/VECTOR.TEST b/internal/test/LANGUAGE/AUTO/VECTOR.TEST new file mode 100644 index 0000000000000000000000000000000000000000..d12d7b8c39df73d4d9860f580f7c41838836092d GIT binary patch literal 331 zcmYjL%TB{E5Hybqm3rs63Ks{}5z60SJ6v;Mrp#rR%_aEefdw;9*q@vjZyt zZumx!y3z*lC1kv=30Gy;h}LLJHb+q%lC zwsZiCJ+A>P!E;h5*${1%6~Os>XfR!|LANGUAGE>AUTO>AR*.TEST;) Test "(untrace) has the side effect of unbreaking all broken functions" failed in file "NIL" XCL-USER::OUR-FN is not broken. Test "AR8687" failed in file "NIL" Test "AR8688" failed in file "NIL" Test "AR9502" failed in file "NIL" Compiling 1 top-level form Done Compiling 1 top-level form Done Test "AR9643" failed in file "NIL" Test "AR9698" failed in file "NIL" Compiling 1 top-level form Done Compiling 2 top-level forms Done Compiling CL:DEFUN XCL-USER::FOO Done Test "AR9977" failed in file "NIL" Test "AR10014" failed in file "NIL" Test "AR10062" failed in file "NIL" Compiling DEFUN XCL-USER::TEST Done Test "AR10209" failed in file "NIL" Test "AR10219" failed in file "NIL" Warning in test IL:AR10598 in file NIL: The variable XCL-USER::Y was unknown and has been declared SPECIAL. Non DO-TEST form at top level in NIL (IL:PUTPROPS IL:AR-TEST-CASES.TEST IL:COPYRIGHT ...) Test "AR7587-TEST" failed in file "{ERIS}LANGUAGE>AUTO>AR7587-DOC.TEST;1" Warning in test "AR 7647" in file "{ERIS}LANGUAGE>AUTO>AR7647.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "AR 7647" in file "{ERIS}LANGUAGE>AUTO>AR7647.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Test "AR 7742" failed in file "{ERIS}LANGUAGE>AUTO>AR7742.TEST;1" Test "AR8207-TEST" failed in file "{ERIS}LANGUAGE>AUTO>AR8207.TEST;1" Test "AR8575-TEST" failed in file "{ERIS}LANGUAGE>AUTO>AR8575.TEST;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U b/internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U new file mode 100644 index 00000000..8d22d0dc --- /dev/null +++ b/internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U @@ -0,0 +1 @@ +;; Function To Be Tested: y-or-n-p ;; ;; Source: Steele's book ;; Section 22.4 ;; Page: 407 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: December 9,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>22-4-y-or-n-p.u ;; ;; ;; Syntax: (y-or-n-p &optional format-string &rest arguments) ;; ;; ;; ;; Function Description: ;; This predicate is for asking the user a questions whose ;; answer is either "y" or "n" ;; ;; ;; ;; Argument(s): format-string - the message ;; arguements - for format string ;; ;; Returns: T or NIL ;; ;; Comment: Don't try to get real clever, just make sure ;; lots of the format stuff is around and figure ;; it is completly tests in format.test (do-test "simple test" (and (y-or-n-p "Type \"y\" ") (not (y-or-n-p "Type \"n\" ")) )) (do-test "test formating with values" (let ((animal "horse") (number 25) (binary 7) (octal 12) (hexadec 31) (fixformat 12.3456) ) (and (y-or-n-p "Type \"y\" if \"horse\" equals \"~A\" " animal) (y-or-n-p "Type \"y\" if \" 25.\" equals \"~4D.\" " number) (y-or-n-p "Type \"y\" if \"Space\" equals \"~C\" " #\ ) (y-or-n-p "Type \"y\" if \" 111\" equals \"~5B\" " binary) (y-or-n-p "Type \"y\" if \" 14\" equals \"~5O\" " octal) (y-or-n-p "Type \"y\" if \" 1F\" equals \"~5X\" " hexadec) (y-or-n-p "Type \"y\" if \"tries\" equals \"tr~@P\" " 7) (y-or-n-p "Type \"y\" if \"12.35\" equals \"~5,2F\" " fixformat) (y-or-n-p "Type \"y\" if \"1.2E+1\" equals \"~5,1,1E\" " fixformat) ))) (do-test "test formating with formating output" (and (y-or-n-p "Type \"y\" if have a newline right after here ~% thanks ") (y-or-n-p "Type \"y\" if have a tilde here \"~~\" ") )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U b/internal/test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U new file mode 100644 index 00000000..0d636344 --- /dev/null +++ b/internal/test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U @@ -0,0 +1 @@ +;; Function To Be Tested: yes-or-no-p ;; ;; Source: Steele's book ;; Section 22.4 ;; Page: 407 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: December 9,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>22-4-yes-or-no-p.u ;; ;; ;; Syntax: (yes-or-no-p &optional format-string &rest arguments) ;; ;; ;; ;; Function Description: ;; This predicate is for asking the user a questions whose ;; answer is either "yes" or "no" ;; ;; ;; ;; Argument(s): format-string - the message ;; arguements - for format string ;; ;; Returns: T or NIL ;; ;; Comment: Don't try to get real clever, just make sure ;; lots of the format stuff is around and figure ;; it is completly tests in format.test (do-test "simple test" (and (yes-or-no-p "Type \"yes\" ") (not (yes-or-no-p "Type \"no\" ")) )) (do-test "test formating with values" (let ((animal "horse") (number 25) (binary 7) (octal 12) (hexadec 31) (fixformat 12.3456) ) (and (yes-or-no-p "Type \"yes\" if \"horse\" equals \"~A\" " animal) (yes-or-no-p "Type \"yes\" if \" 25.\" equals \"~4D.\" " number) (yes-or-no-p "Type \"yes\" if \"Space\" equals \"~C\" " #\ ) (yes-or-no-p "Type \"yes\" if \" 111\" equals \"~5B\" " binary) (yes-or-no-p "Type \"yes\" if \" 14\" equals \"~5O\" " octal) (yes-or-no-p "Type \"yes\" if \" 1F\" equals \"~5X\" " hexadec) (yes-or-no-p "Type \"yes\" if \"tries\" equals \"tr~@P\" " 7) (yes-or-no-p "Type \"yes\" if \"12.35\" equals \"~5,2F\" " fixformat) (yes-or-no-p "Type \"yes\" if \"1.2E+1\" equals \"~5,1,1E\" " fixformat) ))) (do-test "test formating with formating output" (and (yes-or-no-p "Type \"yes\" if have a newline right after here ~% thanks ") (yes-or-no-p "Type \"yes\" if have a tilde here \"~~\" ") )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/Hand/25-3-STEP.U b/internal/test/LANGUAGE/Hand/25-3-STEP.U new file mode 100644 index 00000000..be8cd8a9 --- /dev/null +++ b/internal/test/LANGUAGE/Hand/25-3-STEP.U @@ -0,0 +1 @@ +;; Function To Be Tested: step ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 441 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 29,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-3-step.test ;; ;; ;; Syntax: (step form) ;; ;; Function Description: This evaluates form and returns what form returns. ;; However, the user is allowed to interactively "single-step" through the ;; evaluation steps that are performed interpretively. The following is a list ;; of possible command for step (ref; VAX LISP 2.0): ;; (BACKTRACE DEBUG EVALUATE FINISH HELP OVER QUIT RETURN SHOW STEP UP) ;; ;; Argument(s): form ;; ;; Returns: value of (form) ;; ;; Constraints/Limitations: none (do-test "step-test" (and (equal (step (identity '(a b c))) '(a b c)) (eql (step (cos 0)) 1.0) (equal (step ((lambda (x y) (append x y)) '(a b) '(c d))) '(a b c d)) (eq (step (setq x 10000)) 10000) (equal (step (string 'strings)) "STRINGS"))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/Hand/25-3-TRACE.U b/internal/test/LANGUAGE/Hand/25-3-TRACE.U new file mode 100644 index 00000000..34023618 --- /dev/null +++ b/internal/test/LANGUAGE/Hand/25-3-TRACE.U @@ -0,0 +1 @@ +;; Function To Be Tested: trace ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 440 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 28,1986 ;; ;; Last Update: Oct 3, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-3-trace.test ;; ;; ;; Syntax: (trace {function-name}*) ;; ;; Function Description: Invoking trace with one or more function names (symbols) ;; causes the functions named to be traced. Henceforth, whenever such a function ;; is invoked, information about the call, the arguments passed, and the eventually ;; returned values, if any, will be printed to the stream that is the value of ;; *trace-output*. Tracing an already traced function, not currently being traced, ;; should produce no harmful effects, but may produce a warning message. Calling ;; trace with no argument forms will return a list of functions currently being ;; traced. ;; ;; Argument(s): function name(s) ;; ;; Returns: list of function(s) being traced. ;; ;; Constraints/Limitations: This test is divided into two parts: testing xerox ;; implementation of trace and other implementations of trace. Since this function ;; requires user-interface, it's not realistic to run this test automatically. ;; For the Xerox implementation, the test is conducted to determine if the functions ;; being traced are returned without opening or closing the tracewindow. On other ;; implementations, this merely tests to see if there is a global function ;; definition for trace, which does not necessarily mean it has met the requirements ;; prescribed in CLtL. For complete certification, manual testing is required. (do-test-group ("trace-test-setup" :before (progn (defun factorial (n) (cond ((zerop n) 1) (t (* n (factorial (1- n)))))) (defun fibonacci (n) (cond ((= n 0) 1) ((= n 1) 1) (t (+ (fibonacci (- n 1)) (fibonacci (- n 2)))))) (defun squash (s) (cond ((null s) nil) ((atom s) (list s)) (t (append (squash (car s)) (squash (cdr s)))))) (defun trace-test (implementation-type) (cond ((string-equal implementation-type "XEROX") (trace-test-xerox)) (t (trace-test-others)))) (defun trace-test-xerox () (and (boundp 'tracewindow) (equal (trace factorial) '(factorial)) (untrace) (equal (trace fibonacci squash) '(fibonacci squash)) (untrace squash) (equal (trace) '(fibonacci)) (untrace) (eq (trace) nil) (untrace))) (defun trace-test-others () (fboundp 'trace)) ) ) (do-test "trace-test" (trace-test (lisp-implementation-type)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U b/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U new file mode 100644 index 00000000..281f2a3a --- /dev/null +++ b/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U @@ -0,0 +1 @@ +;; Function To Be Tested: untrace ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 440 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 28,1986 ;; ;; Last Update: Oct 3, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-3-untrace.test ;; ;; ;; Syntax: (untrace {function-name}*) ;; ;; Function Description: Invoking untrace with one or more function names (symbols) ;; causes those functions not to be traced any more. Calling untrace with no ;; argument forms will cause all currently traced functions to be no longer ;; traced. ;; ;; Argument(s): function name(s) ;; ;; Returns: list of function(s) being untraced. ;; ;; Constraints/Limitations: This test is divided into two parts: testing xerox ;; implementation of untrace and other implementations of trace. Since this ;; function requires user-interface, it's not realistic to run this test ;; automatically. For the Xerox implementation, the test is conducted to determine ;; if the functions being untraced are returned without opening or closing the ;; tracewindow. On other implementations, this merely tests to see if there is ;; a global function definition for untrace, which does not necessarily mean ;; it has met the requirements prescribed in CLtL. For complete certification, ;; manual testing is required. (do-test-group ("untrace-test-setup" :before (progn (defun factorial (n) (cond ((zerop n) 1) (t (* n (factorial (1- n)))))) (defun fibonacci (n) (cond ((= n 0) 1) ((= n 1) 1) (t (+ (fibonacci (- n 1)) (fibonacci (- n 2)))))) (defun squash (s) (cond ((null s) nil) ((atom s) (list s)) (t (append (squash (car s)) (squash (cdr s)))))) (defun untrace-test (implementation-type) (cond ((string-equal implementation-type "XEROX") (untrace-test-xerox)) (t (untrace-test-others)))) (defun untrace-test-xerox () (and (boundp 'tracewindow) (trace factorial) (equal (untrace factorial) '(factorial)) (trace fibonacci squash) (equal (untrace squash) '(squash)) (trace factorial) (not (set-difference (untrace) '(factorial fibonacci))) (eq (untrace) nil))) (defun untrace-test-others () (fboundp 'untrace)) ) ) (do-test "untrace-test" (untrace-test (lisp-implementation-type)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG b/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG new file mode 100644 index 00000000..863932d8 --- /dev/null +++ b/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG @@ -0,0 +1 @@ +;;; Test results for sysout of 15-Mar-88 18:32:37 ;;; Tests run on 18-Mar-88 16:59:08 ;;; Running tests from ({eris}language>auto>24-errorsystem.x;) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/LANGUAGE/LOGS/31-AUG-88.1109 b/internal/test/LANGUAGE/LOGS/31-AUG-88.1109 new file mode 100644 index 00000000..b98fe932 --- /dev/null +++ b/internal/test/LANGUAGE/LOGS/31-AUG-88.1109 @@ -0,0 +1 @@ +:BEFORE forms for test "IMPORT-GROUP" in file "11-6-IMPORT" failed.#.(PATHNAME "{ERIS}Language>Auto>11-6-IMPORT.DFASL;1") Failed to load Test "export-test" failed in file "11-7-EXPORT" :BEFORE forms for test "FIND-PACKAGE-TEST-SETUP" in file "11-7-FIND-PACKAGE" failed.#.(PATHNAME "{ERIS}Language>Auto>11-7-FIND-PACKAGE.DFASL;1") Failed to load Test "list-all-packages-test" failed in file "11-7-LIST-ALL-PACKAGES" Test "package-use-test" failed in file "11-7-PACKAGE-USE-LIST" Test "unintern" failed in file "11-7-SHADOW" Test "unuse-package-test" failed in file "11-7-UNUSE-PACKAGE" Test "use-package-test" failed in file "11-7-USE-PACKAGE" Test "test concatenate - the result does not share any structure with any of the argument sequences" failed in file "14-2-CONCATENATE" #.(PATHNAME "{ERIS}Language>Auto>14-3-FIND-IF-NOT.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-FIND-IF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-FIND.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-NSUBSTITUTE-IF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-POSITION-IF-NOT.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-POSITION-IF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-POSITION.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-3-SUBSTITUTE-IF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-4-COUNT-IF-NOT.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-4-COUNT-IF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-4-COUNT.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>14-4-MISMATCH.DFASL;1") Failed to load Test "test caaaar0" failed in file "15-1-CAAAAR" Test "test caaadr0" failed in file "15-1-CAAADR" Test "test caaadr0" failed in file "unknown" Test "test caaar0" failed in file "15-1-CAAAR" Test "test caadar0" failed in file "15-1-CAADAR" Test "test caaddr0" failed in file "15-1-CAADDR" Test "test caadr0" failed in file "15-1-CAADR" Test "test caar0" failed in file "15-1-CAAR" Test "test cadaar0" failed in file "15-1-CADAA" Test "test cadaar0" failed in file "unknown" Test "test cadadr0" failed in file "15-1-CADADR" Test "test cadar0" failed in file "15-1-CADAR" Test "test caddar0" failed in file "15-1-CADDAR" Test "test second1" failed in file "unknown" Test "test cdaaar0" failed in file "15-1-CDAAAR" Test "test cdaadr0" failed in file "15-1-CDAADR" Test "test cdaar0" failed in file "15-1-CDAAR" Test "test cdadar0" failed in file "15-1-CDADAR" Test "test cdaddr0" failed in file "15-1-CDADDR" Test "test cdadr0" failed in file "15-1-CDADR" Test "test cdar0" failed in file "15-1-CDAR" Test "test cddaar0" failed in file "15-1-CDDAAR" Test "test cddadr0" failed in file "15-1-CDDADR" Test "test cddar0" failed in file "15-1-CDDAR" Test "test cdddar0" failed in file "15-1-CDDDAR" Test "test cddr0" failed in file "15-1-CDDR" Test "test eighth0" failed in file "15-2-EIGHTH" Test "test eighth0" failed in file "unknown" Test "test list*3" failed in file "15-2-LISTSTAR" Test "test list*3" failed in file "unknown" Test "test member - the value returned is eq to the portion of LIST beginning with ITEM" failed in file "15-5-MEMBER" Test "test member - the value returned is eq to the portion of LIST beginning with ITEM" failed in file "unknown" #.(PATHNAME "{ERIS}Language>Auto>20-1-CONSTANTP.DFASL;1") Failed to load Test "CURRENT-READTABLE-TEST" failed in file "22-1-5-SET-MACRO-CHARACTER" Test "ALTERNATE-READTABLE-TEST" failed in file "22-1-5-SET-MACRO-CHARACTER" #.(PATHNAME "{ERIS}Language>Auto>22-1-5-SET-MACRO-CHARACTER.DFASL;1") Failed to load Test "read-char-no-hang returns nil standard-input" failed in file "22-2-1-READ-CHAR-NO-HANG" Test "LOAD-CH-21-FUNCTIONS" failed in file "22-3-1-FINISH-OUTPUT" Test "finish-output" failed in file "22-3-1-FINISH-OUTPUT" Test "force-output" failed in file "22-3-1-FINISH-OUTPUT" Test "clear-output" failed in file "22-3-1-FINISH-OUTPUT" Warning: The command EMERGENCY-SHOTDOWN is unrecognized. Test "apropos-list-test" failed in file "25-3-APROPOS-LIST" #.(PATHNAME "{ERIS}Language>Auto>4-8-COERCE.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>4-9-TYPE-OF.DFASL;1") Failed to load Test "test defun - use defun to redefine a function/macro as a function" failed in file "5-3-1-DEFUN" #.(PATHNAME "{ERIS}Language>Auto>6-2-1-TYPEP.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-ARRAYP.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-ATOM.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-BIT-VECTOR-P.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-CONSP.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-LISTP.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-SIMPLE-BIT-VECTOR-P.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-SIMPLE-VECTOR-P.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-2-2-VECTORP.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>6-3-EQUALP.DFASL;1") Failed to load Test "TEST-BOUNDP2" failed in file "7-1-1-BOUNDP" Test "test symbol-function4 - use SETF and SYMBOL-FUNCTION to alter the global function definition" failed in file "7-1-1-SYMBOL-FUNCTION" Test " test symbol-value for lexical variables" failed in file "7-1-1-SYMBOL-VALUE" Test "test catch & throw - when catcher is a function argument" failed in file "7-10-CATCH" #.(PATHNAME "{ERIS}Language>Auto>7-10-CATCH.DFASL;1") Failed to load Test "try a simple case with lists, cdr" failed in file "7-2-DEFINE-MODIFY-MACRO" Test "try with lists within lists, car" failed in file "7-2-DEFINE-MODIFY-MACRO" Test "test creating a modify macro with same name as a just defined macro" failed in file "7-2-DEFINE-MODIFY-MACRO" Test "test &rest" failed in file "7-2-DEFINE-MODIFY-MACRO" Test "test &optional" failed in file "7-2-DEFINE-MODIFY-MACRO" Test "try the example from the book, modify so don't mess up others" failed in file "7-2-DEFSETF" Test "try with both functions defined" failed in file "7-2-DEFSETF" Test "get-setf-method-multiple-value-test" failed in file "7-2-GET-SETF-METHOD-MULTIPLE-VALUE" Test "get-setf-method-test" failed in file "7-2-GET-SETF-METHOD" #.(PATHNAME "{ERIS}Language>Auto>7-2-PSETF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>7-2-ROTATEF.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>7-2-SHIFTF.DFASL;1") Failed to load Test "TEST-PROG20" failed in file "7-4-PROG2" Test "TEST-PROG21" failed in file "7-4-PROG2" #.(PATHNAME "{ERIS}Language>Auto>7-5-LET.DFASL;1") Failed to load #.(PATHNAME "{ERIS}Language>Auto>7-5-LETSTAR.DFASL;1") Failed to load Test "test macro - lexically scoped entities are not visible within the expansion functions" failed in file "7-5-MACROLET" Test "test cond - test for returning multiple values" failed in file "7-6-COND" Test "test return-from for BLOCK - nested return-forms" failed in file "7-7-RETURN-FROM" Test "test return for BLOCK - nested returns" failed in file "7-7-RETURN" Test "test mapc2" failed in file "7-8-4-MAPC" Test "test prog - with declarations" failed in file "7-8-5-PROG" Test "test prog* - with declarations" failed in file "7-8-5-PROGSTAR" Test "test BLOCK - forms *do* return multiple values when they *should* " failed in file "7-9-2-MVR-BLOCK-CONSTRUCTS" Test "test BLOCK - exactly one value is used, if forms are passed as an argument to a function call" failed in file "7-9-2-MVR-BLOCK-CONSTRUCTS" Test "test CATCH - forms *do* return multiple values when they *should* " failed in file "7-9-2-MVR-CATCH" Test "test DEFUN - forms *do* return multiple values when they *should* " failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test DEFUN - forms *don't* return multiple values when they *shouldn't* " failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test DEFUN - exactly one value is used, if forms are passed as an argument to a function call" failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test DEFUN - when forms are used for effect" failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test DEFMACRO - forms *do* return multiple values when they *should* " failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test DEFMACRO - exactly one value is used, if forms are passed as an argument to a function call" failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test EVAL-WHEN - forms *do* return multiple values when they *should* " failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test EVAL-WHEN - exactly one value is used, if forms are passed as an argument to a function call" failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test PROGV - forms *do* return multiple values when they *should* " failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" Test "test PROGV - exactly one value is used, if forms are passed as an argument to a function call" failed in file "7-9-2-MVR-IMPLICIT-PROGN-1" #.(PATHNAME "{ERIS}Language>Auto>9-3-THE.DFASL;1") Failed to load Test "SETF in MACROLET" failed in file "AR6273" Test "AR8190" failed in file "AR8190" Test "AR8207-TEST" failed in file "AR8207" #.(PATHNAME "{ERIS}Language>Auto>AR8207.DFASL;1") Failed to load Test "AR8575-TEST" failed in file "AR8575" Test "simple stuff for stkargname, check doesn't die " failed in file "BINDING" Test "simple stuff for variables, check doesn't die " failed in file "BINDING" (XCL-TESTONE redefined) #.(PATHNAME "{ERIS}Language>Auto>CMLARRAY.DFASL;1") Failed to load Test "name-char and char-name are inverses" failed in file "CMLCHARACTER" Test "AR 7507: SETF macroexpands too early sometimes" failed in file "CMLSETF-REGRESSION" \ No newline at end of file diff --git a/internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE b/internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE new file mode 100644 index 0000000000000000000000000000000000000000..cf52829e742396cd4fc9edf5e7eaa4235edc68d4 GIT binary patch literal 114615 zcmeIb3w+$gbuT_E2|t#Hg?R)wPW)pnjO}=h9)3v}TWe`;E!GQ3j^XwZR?^zuSlU&z zE87Yrh?aYSluJOgX_6A!q%>}lwxLOzM?Y;)FL}`$k~GbyO-dV_!cG3UpWXuL15zIP zf6vTs<~K9HhgOm;l9o-7cYia#IWuR@IdkUBIcFFp5YTt%$So2KLS;*!dT+6C-BX%6N=T#n${bJO5zp z@`uf`3*#()7klTu?EHIJ{9nzo^W*INC)hiC*ab;;!Essk#8?$N7mvr@`!xIbx7o<& zV)uW~EW02cyQ_hH;y>8PiP(FdHOtPA$L?9dKK6%fq$zgqm-nNku+LJL@qRY{{gt2j z`@hFrY>u;IZ(_gVuw#$1{6!1xiyZss)_)JfY>%^FxSrkd^XzS(WN-U_X4&3&?33SS zcaE^GbnH`;X9r$$oONHv{`+e7^S{G>{+~^FyW*_lCiXw}vg>Qu^<4{v7xkVAuPM%s z470nx%np2u9lay!y>n5<`=aLdZE^PYe`W7K&5qy8j(^+i=cYK@{V03SyV$<1Y~QF^ zwjs`TCD?tx#CBiGb`P0l>*H+S&;QJ8IaU>}D7IB=$dg%(6Z4 z*l%^Q_jR!gJ{)^^n=BJF_@+49@)-M#ce2J+tZ~pR`?)yVc#u8tf7q7G*p{QRO!Ora zkM%yyZvPk7^?dAby(|-Lz9G))wy@t^#jgHccD3SnQFdvZIXU*=zp(Yc!q$J&eDC5o zd*dIl5Bwur_gUtwG|MiEv&%1M4>|0ORqTy7m}QVl7ykj9Ot8yF*=2t!%YOgmuP|1% zIv&gYCd2SA>Wvkr&9ckmvGn)Z^yk<`55*3uc^B`kiN`*D1v~j~?4o~;ec^oby|wY! z&RTZjt87&&*8TyrY+XFI`J3$4GF$cD*p8T4mWZ>PGwhzfWvl*<4Sm!syDA==eu4e! z$60MM_P#N*Y-5~#tHkdARaSdD`_8ag_Lew%{Jrd5A7-^*V_$pTEZZ7qU+iY@{yMw( zP3)_`W|lR?W50Kt-Sq)>@o4N1Z|7x-AFhqF{3x6H6npzB_V&(&@}Gn!)`xX*Hu4|r zwwG9GoRz-PF4nQc{`Yi)=2517WLfjgpT^TK7-h1}ColVFlx>f*58ul^@|Wx*8`(z+ zW*Ke}etq57_T@vEO@-Ec=H~ zd=l_h#n~S??2j*JpFYJtE$J+=tn*J%Rvl-5^=bB3)$E&JVt@6Mh2re>_khZP&+B*z zKnfoHXU7X;*R5Z_ejqc@neJa7k0lzLlRZP_1L>~7&fBk_ zAMeW@&6mpKlW}$_{x^*Ov7cjCtzVxm49lYaiNR7iTNui%hl;`WM32x9AtBqLuJ6Fx zy?s5s!MOFm+@0yfTQ?do8yb@BxgkC!+glpzTN=D65t_oDc%qamPmDPjSS~y2l!_DM zLpdi~7c#pFP)RCWfkgCjYoc*JQd7RtFonKw6r=H%2hSdDGpsTvb|vkT*$m^f|P zHnWZS!qCXXaL#G(Ne-m@2hjNFC>nSAb2;Zwp){5o${)$+hM{4yUjQsM5k6qMe84sy z8XL}*b0ufv#)Ik3&h$-A!uQtB#HLNucDI2Rpv;}FMzBuPp<-bO z2q@scVY|uD0XGpHHF{Gg2E5j7vV5|bJei%eTRRxu!R??bZ*D|u>)h6IL&u7CQ`T4& zfdg^dwzo9c9ZR@PfyDELqse?>Y{G}W0kd~{lbGCkyLVTaO%^B00c~0%Hri}z+16l9 z$;No%WWIbXSscq1>=EA((LGFs$C3hhZ*iLvLp?HHs%J1jDI~BsNl6GafxC7nOo_eE`SF3= zsdBt39{YOiL$S52`rYi>Yn}ZQg`sl3Sa8JJLjox`+~NcM|V}* znsA&{VbTE;j03Ah)B$$N$8t^q*mYOFllhSmXE5iW&XMByC=l${am&lcvSlYMb_ORo7%{G`j*~gUe;co=S4zi<6C=aU5EP`N zXn34@GgzD`3~%v(ngerqr^T@FhCQaO?i3Q*Q{zV`Xo1^U+JuP|9da?-C-BxHF`?t1 zs&MVLhE>7%*}Snmy+3uRb6|f@_kh#jZ0tyPzBN6NX-he~Hbwo~#8xOJ`3-EPdQE%G zs+Uuh7`AK6S?rzIw{@8U%I08iag-b!xHt|MhltgURoo{H{A~rS;=Z?bh*iAipF#x< zRt|5~72UkZ6*MgNSnT&>SF@Ur&n0N=_1T@bpIK2eoSk$=N!Tn_(AbEH5;b;Rm)fQH zl|=92R>^%s+6)|n0Pw_&E*Xl2kxA!dar}76$qPOd>$fwU9~Y7x?9YV|U+tU{DVyaY zI2%n`B1o2HA(5c>l6(<0O3u;ziCh6K4bZb(nTj>3#%0tfup1=DG+8Ia7&?ljsN}9Y z91yLZkbWE_2PFZ!Ajfm1iIK9zfe>(6*?rX!Cp(Ts7(L{2j%w3ew3?CDASEnc=~2mh z%@trHv^KdY0WRI4b0O$91^Im>vKhkM81SAOCMXhl)UDxsX(&5BoEsL>xKK1o#h9~L zLtJrL(qyj~2CV^DVFvT)BX&rMYaKpKVpjQt=ClFJVU#q$E{RzZnJWX3&Ti>Xi%_m< za)mO!aG`8&yr5_DuDsmi4xBN)twFCI4KFvot(}WCd!7C&d^?tt9saK z7lh0rX?7$(j_z0jd7@Cxk2nwpP}ql#K@-gthLgo3$s@2*T}wic76WLG0fJx)*IM~@ zDgasmyAcbRc%f8;rl+Kr5>#C1a`~l8N+GRW;ItETAn|}}GNeFqK`9pSv*mJbbgV2C zN-5|H`e3$3h^^93nb4}fL28mW2%*&%p-Dm(cvdkf3xv=LBFeet78>-nrn12~b?`$RSb7)kC407(EN- zXQLgX{`^=xcD6Q)tm;;mm+@t;U12bP2wt|PY)&?&wrus|()e6#EP5c=cruiYcj(4H zAtBx%*f{oV?CIDa#Fn$_opZ6VX2hI>hnwpE>)4(&tVA)eR&A-c7pE&+6F5uk3u98j z$qo00k;%BQp~y|qe2LDEmq}$d*L-D14>Vw#CZ&SQ!)P0)v98fYu(fz3 z6!g->*x1PA7F33rcsMsMG=3P4$FoCZ(xC#{v6SdIn)edB7Wdn5ZX`dN$0-IGr*T+~ zE|b21Zeu@igw7`DO>Tox4LZkQ5*f^4FT)|@TvR~R`^2|8usdO|qiunLwG7dfEiU+E z68$abj?y>?d){wb=WtaS7p#tEs!39SErp%>VprZ&Up(jTVmo-*JLi+U?AodQ9O}$1 zcLE!nQ|{m`*I0dCXRzGaMn}XDPCz4fYZiTdlPh;Fh!tZG#BO2dU09*qF?2^xVOaN) z##2&P!9lM}C0i;PSgJrQ8TECppzkhvqqiL66Lf9{Y2q5Eg)<0OSNIWAc4%l~bYcYO ziMq8@SW991kS627Tp@P^zg-*25h?M)rao9Yz_lS4%=vPIqmNP4#9wu?7zWLifF=>@ zP0fj}17v-N_16_ZW8=l)3D}rPl8S>*!O_Nikfem_Wt0 z+lD>ag$K*ek?gp;D!9*tDZfA_=Nv3LXlDX?9!ycr5O22VgrWllbP$Sj3kx{x+VBBV z%Rp&Dwzknd8W`fI(=gW?#xSf$N65Uy>%;nfB40#bcsJDgF`6CDZ3>=tAq~vgvB^Nx zG3Jb_ES2Q1dBBzY_`>(1meYuLLK!Aa4aslN$y}mev}ms-Z<=FAD*GV};)O8L4|jw{ z+X&_;mGkM?2eBiq*%Bf8eNHAn-<2I2FaDxCfni6LKlMA)kfTcJ#NZqDMx5rm;$f3> z%W!UJ1Ueb*(B8G#xrO`+@UQ-H@e?MU`Dq-y@`OC59UL90kzW;GQb#9Xkanez5=*Xp zP;Ld(BfQBy37|g01WcUmHVM6sEJ^&JPMDWbD3nL)Ek9_Z>Vw7MNp4}zoyrYOaQJ+| z$d8VVg(Tk%6Zt!+bzxbVGX(FrM1e3+%ze4;NqQ7(=G zza(TP9q#?Z{Wfx^XjP)aMgkky))o>~c$YNZlgDzXCp2IFD)3bRJSg>$c-cYm-GuIX zYe3^2&mH9_iZqU6*%LHa=?(%LJ`C-_@@}MvUMq(YQie(Ar?qr+i=$Bvjvz@v=hI=! zL)TIdG0YWqj#`_%mP$BQ|A|zK|74DBI9x^{Z)_X6Bi+F?SG76RVbPH1s3vq)XHJ(1!dL!W(wGtfwSO9g*b5XcodL1vOIF8;w)PQuYKSE$jkZdxea`3*_r892B!~ zIBSBRAOr|JbH;PQ5{p(6Y|drRt|gI0(hko^@<994#TI^YnMF>7_`jn(8eA<=ybFXV zXKQX$;0_<6e?26WPv+s1q8#Rwm_zrq4}n-RIoB-ZT(gjKp&k(sPvCibOT9tLIg3W; zRse%ri{AT-KFGa)F;qD1Y}sz>mYZDR^v2k4#C|i@&(2Fm2q(Vwx-%WB?KM^|f0|mH z9>ZO;pD&N{r1=~hEw3 zkgRU5`e5oPU@oB(;c+)Mj}zlu&B^y>qj?!L(^lADB2#K_@fJG!LW=RkYx=z02 z?mFfgO^TePU8GZSi6}P*SHF`$9XSvYk_DH+<|59^_&D4JBF&Re!238#5RtH)Ki-lwX_J}ee z(LGg@I+IesgRBPbQpl%Um&imQXI)TM|C3aq|49hSTOf^8h^6LJyp6}+*_O%mb8hg3 z5JNU1?`SPwzmcr#sc@#PxFbMP9{8AS_0J;jN0VZ9Uy>seyDi z{=v^CMcdd$q6j3V>Uf-s5hDE z1|D59qsde+oz|wWpQvYZ+<`6#qagQ?fa*s&_)*e-i->g`DubSj2&{DaC&qJlN?IT! z9;(4nK^S$hGok&4I9)>t_A+P!hg(M>r=gXOz?g!lZ%_aQGbZ9L&32`F+fqdRU=xsi z85(zgc@*!fhP@#9JQhfy#&1yNoE zAB8m+%}0_&L|@5U!c*amz9L3n^X(8qK7)J;VmpRSmE4KaE(8lk{74v2!qDvVL2q_- z?zgc29lNJ$J&V_o&aDEHOIAd(fI5aX-wPT~j&Xa7ampd%siqq{8jAu0;8R^Dzvi?iFX#Y zIxCBK7M15=aTbU#ZN*xvFsRh&;7L;TLU%v{%avi+XDQPV>_Kv)t|gfi2j5OI)cmO0 zs{cmxqkNaP;o}H>hIxU`4wWs63twtOR1`KKzCGtQTofP4j+Dp@vQaj5YLj!FvyrH8 z%sItTf3ql}FgP(4rl~>nTNNsmmUjqB4u@cjO4U_^vL?mk7*$;!@tVc%*bE5V_V3b- z^ms84$5${V4``9n@kbC94mX}WmWQ{6ZPwd_Wvqb1#lkR*BD_Z&o@c}hMYbA`iARBD zRX7hkhM`fk7$Q*&>NDyr2%#y5NJbqTaLb_B>p@ar&8KlmLm=#AFrNv!A)6i#jwQ>Z z*a?DWPLAiHFu;~Z(YQJOvYHPusx4?FXj(wZqC$zkB`tGs2g1x0gs&zngfKrLluC$N z(R1v;uyuv6Chu;RzfI1XBBEFM0nzERa*Z6MptJ&vb@0x~lW|PieEHinFfwmVfUC>n zNU;P@P{_oRtMHJSuQSu%D-l7PSpJ@!7=W(}s?ehg6W==h%gSMdVJ|gn8rbL=*Z zMyZYS?HWD=ZJx76t6qZ|_2Kjay+$BT*UVXilarkNz&7S4hlV+!$U{_A6g0L|e}x8j zwf-QmA7^7M*USlJ$DB2MlYO233XR2RgC6X$Yxo`*Ot`?|M-xBwV~gI8Kq!rK*6>Z` zF8!4yo66-sVDF`@F=mD=bH|2#mVF%G9JFH#I)JI5rMWhiVxPx1meoiRsFG7@O>b{O z;xaAwme>NfO9M?h_IVg+Zf4a9wox~p^k_TojBW}@(Xu}PmD}5qcV-Tzb<4~^M+O!b z7$DNv@86^~)Yh3g)SuQKbf?qp{kqjKGtjRU_Z-$C_on*N-DElNAm5bkw*hOfXY{t* zetYlkJ2ap}?&vwJy?Qv)sha{1>z#)61E$AJC&oO`p%>6-v^Ms`*?xB8DqWS z5bRp81$CwR4(_FKrMmUkfjoWm$Z*uV|4^qs+zwb+`}b-vG7ju7+VB2Ded(>*Zwy&~ zKSOiWuFv$rZUYNF-TLq_t=$K<#_1)Pq`Z-3wC{)0ea0(#<7AG~!2@|927NkH2GV z_T{Pru_svd&oPg!Tzh}=KwrzdR-IW+cr1nC#DV^>(JYy)W+4 zy+#JYCYc_%L7OAj7Dxc+Z`ib~jlyKilXQB0^^A==MY?0ssWx;_`+5#_x2M~M6;m*? zj-InUDyQDr&QC?W894njH!^M$HxF`*a~x1d;v`ZL8b>Oc%^Jndu{;dk+c9fz;eSCM zo$2la10A|>*Iog)m}^KB(#XCHwy*jEm`fceYFsb4%hLcPcSSRF6`@1Q2CY~- zBc;-M9x|wn**ii-aU)z<^p5E-Hkkr4I9 zoZzJa=XSeVw%cCwP2!j!_8o+0{yzH$#=ghm?M0_OH#kAZy-x24Y(eq(0Fna0hKM6F z9Q3F8c`)~lO7)3z=t0=SS_YBe8u^YW@PT_#rH0`nhBMlp-mUR?7q#H!kSlF1m&ivj z9^aoo1-CIIOfDz+K{Gtq3OHapg~B$T&~li&CAg>1Ipp_5o}{7UaLAx^oqK7o;5SRG z=8wgnKcs(XZ}Nx2S>OX9+$|8~t(`)3ZVGZ1@EDYiLpfSKYSbANvS7F3d_TIwE$&GEKzIOowx1EnR`vQr<%PB}K08&;*qWHJpk4Q~sbh8|AVs$w^v2KBRRPO=sU$^AMx??=zH!&$3uGV`i}@ixx` zC!C7sZe-4R*iHmW>oS)LZAK@Z=H&I+LUPwmrvY`alzH+>+{JQ!JOQVjdB<%+5Lri++GM)z#$;0xDYr9pI(|)$@UV8=e{t@EdLng(JehWZM4mo#0OX9Vojo@; zfOSsfM(0Sjy;u)YJ{;s2)aWF{b=0V%B`Xoc6%lYgefMC~jZ&vLcah{9{yR`G zbV|YD7-);T{?joYr8Ar)p93g7BF`a$01BXs!3lWpBS#9Ir)jP6$SZUUp7v-4@1bq- z55h^C2pd2k=+N;(@g$4`N6Bdd;0FLl;X`NBE;tzW|c1 z4B?4tT_mX^Cvo0aJc{E&p3{XVdm-!sqs5aHZ#sgbOB@BdFXDmc@GtT_BD*CIVxZ0d zt@*Nuf(UkE70tLr;j(}_0tCk0M;JET@=1RzId7*BWUfkbUtR(uF@kwSjss^9Gkct4 zGt2#Bb7c(r2s(2j4{u*!F;fPfDf2nvSm5?Q4*uaO6~L-|BG4LDKQAFti9nkk2l6j}WeBhBq@0 zDnXnIrBa~S3O7u|3v}?L?k0kOXdCJ%CrHlj*BCSpGE>LEL>D4%qm&z`QIdBJCZymT zhqD{CK(m8G;sSJa$Sk4(tjVN(SBD)69$@KnnezQSe#${d1UFMhNXe%k=np&ZeXN?y z`G>;RKC$w6`G)1nBi25wA{<=^UeXpa8DnRtUcS}L3xAMp1~2)(7qO@1_6O2S+QR&=h=3&m>%c2Fa^eZ^CJ3lQsJUu8JN1uA$Qahci{`xT>wWwKOu*D9r( zfw)Ig8{*XC8#^=I2ivh}=uF+z)zhAK1{_py_ILKA1~%cQPy=vMHZA*VHSPYCrxaG{ zA^_uhJQGRAPc>q>$FoZ31(*oVzXSE|E8yjVI8R|-YP;LE(vB?yPCAe)?=Mg}Q7->; z7HY(fv*kqjhWWVyGV&2A?j5p;59T0lV@QHRi4N#;DMFTuKVcAC8)xalFpaUK$U&66 zSyq&{JXv_Ro6)CmS)2e#6KymVN+J|caSf*4&`R^Cq6O7?y|RE>DfN5f*1p9ek+mii zS-7E7^rRAGp&5U-7lN!enhixGD-h~AL6%@tTn6f+EKzcS>~=J=R5N~Lxi@;vA>Slr ziH715st|8s$clivC}c4T5DZ{L(Hk9E9@?~T(XZpOXoc&*Z?V%+&{rtdU+N`DPLY7S zbSsbvcj*?Oz{&BZE?WHHdRA3c4nPP(Tx49i_@P@~HJxPPvieH1p)igTT?~Y}D2|Fo z7VhH>L6%amqQ#HsHkvs*$g*fV8d-r*&mpqF03pb_MvlJ{WLbQ)aLTHeP@`qFn4&C(Q%=$ch~iBT5OYlVMY%mv+$6yNbC zQFc2TS*n@EB1<&XB%wyLVFc7gAuC$cqI0Gq0=^TX)>0~0n4?hZm0$>KjOWk}CE#re z=(Z?P>uU5It7iOjybw`qZC9ch0-g6mUDO zt0mM*7y_O5Lp_Jc!g+;{Aw;*=%brw%EbG`~;Typ^3AGYr1wuV1$P)Yml=zS(N>sO_ zk)@jP&+$Uo&?1&-HdON|Fni8r7EDwj$WmscN|2>2U3#|{f-H+zqLCE{^&C$p=X}T#C2FaOMwV*E&xQ*T@M;aNL}po-J%?;4 zMtONCvfd!)xDsTcnX`keE6j$%*id!e5A~c-mY`&u>iH;3l&F)pXk@8o{M}xN%)()< z-cT5_BA_k~SwR*bwNq_Yhe!e^EwZ!XC(HwS-f-1u(sTk3fe@yw&|^WchvjG>1n)wa(mL3RX39XQ zi$hirQz|>_+blEe&77XJ;@65PRTo~v9)&TbAdrhg>1=gnOsSgjGvz|)>=FqzTCIqH zx;Q$EWJ)LxAxxkti}X`f1M=cA6Ajx`Qs$j4 zP0dJ&?1olF;=~JZ6W06fbKpd2AKjcS)X%dJndU=^zi%oxv>urj;sNa9$lpjMn02q8 zW?$7#>NP*%(6;^DDA2m2G9e=8AV732jxY3}+d1)kT__DKSMZ0doije+R>8Kv`Cz_a=e{e3l?GQ=CJ=;056b_^C<-!?}wd_tApC zk9zcYGzs|Mtz>PGAZP@DxZ5Zj=yafojBBCnBw1nEnploCFi z=Lcw<|L}=VLQASJI6*a|%RVsc|OPb`WKfMP@)gIiEGhreeRwmRIW>l_jy+&0Qly{tbQE*MPTv%LW4UW#3!wWlIqn6fJxHw!?G-953k$a+r=IyJ%Fl z^<`7j6t5_QZ?x_a(S92)OhWFH1q52KRjWg^@g2|%kc3TXBMsMhz zmi@uh!J~sjBvf&Vp>*?TsG@S9TesBK<^%P$@%P^^sjrf;25#8rcVZ*JEOnfen5w1r z)e*-6%D*xi!=kd{hala5KGd|-E)b&o%Hyw+v0f!fZ?R)tYA0JU)-AI8m5kMLj9<8H zT57jXG1jFH{uTVX)c(L?tefUDuYq2h3z7ayeHbjpsvI6Fp<(Noec?2`)NV6ktm@RW zlCfHDBMTqvQhP**u~sPkMP5ZzaP?3IjFiBEl1U&vUOI!bYAcS~}|A)r=BO~Qg3NKNxwa|G10XS=UV zGZj$Jo-I5Ys(-&N$k*DiMZ4Dd{Hzy!L|LQf32fY{j;CIGh>iaPPWK4)n;oh_&lK^vgE1 z>nrG1kf?h;cxhnccu~6$L*D9PfQh_qIPRQ2m`?X5`31-WaAGiTi*U!N-z^c?jb#6! z-rmlPcO6J)n(j=py2h_6msf>gyn#*mU&D>+c!>J_{!3EOq$uO}l%)FlQa8n&hHcL2 zbZ5FNjT_kqZtA5=cf>Ut)P}epx~(JCx5+t;wC!&M$d<1P=XPFOfAXl_Jbf0ps=p*503Eege;HL}uf zGl^y)512a#{H_z8VEiT6)s+98PmFkWH7Q1XmQ9|8-}fRM#pF#FQ~~MXbqQ6EEb=ga z${KnWe+aK8+@+zH8doat#I4r-AG(Jh-2$LrY68gKMH&sbMWdww7irMYs|WSt#`@&` z+#t`a&hK<+^!yaW$loFb=#kj+*t=tY!>ZTKB|t@1-y`G2(fLSFF{%6edb)x|DBX#~ zWrwdKh{K#{k{#X??Oq&y+q_qz(UJF1F}HDpPMF;Hbtbv5r{|!&A8E6LjNl*waceFm z5^n1(cRGW`;&D)cEfjrinN;s~4A%jr3i(mwy88Zs zRNsKJgWv#lxTs#g@Jo#nrRf{=Yv8VT8nzRgpgdUC^%4BK0ph;_AMo%QSKq9wYYhqJyO;-rCq|7sI1Me>vLFCZ4O3IPCNwY2TQ!$+E_Z3%gvf3J$-xB({(JY3v|-7v%*% zHaa@Wm=WY)qYU>$+06vWK|gR$4$|d28YXcimFtXo-t)SS(LfhWsyE|4~!jtSyb?Ntpx=;Ii z4)wLAc_A*86-{6tGmuWw^;6;j6xDt1Z*N)BTBT(NHC0*2dQJO1Qm&vMsSPVG!&+d! zkqBM%+8H3=?P=V6i;GeD2>N@|ZJCs=Rv5h%mBdca>l2=;5uBEbuCtNvQoRDLA?I{^ z1{c-ReO=CJv7LY_v_F}?5x4jDJEyzThm*LSx1X2ed3#T~KZ%RIL`jdK_!d&4INjGr%_i(|>bOs6N}Dz^F`q(x^KpOWO2$hU1UhpRfqCkh-JK*VC$?=>UjAQIHDm&Tc+C&o9R+XwGi310PN*)qo$^k+ZAA}#Lbra zeVqwM8493Lp#27;)Vp<%pyRGk-B6%isfkh;87S7zGcq*pkdc6-=i?SYeJhb@)U61( z%hR|B)Y?hl)>Sv)<*GjoTVS^l47I=tjdiE+S!Vwq+Y#Ftt7BK4l9zvMV&7%4i$7f& zo&8knbVprv;U6sU<Tz%fGmMTl2Rcm?9TAe5%%b<~#h0!~fDBT#sXas=oUf@yJmnzFO;^ zJn|S@K0Eu$qfgDAVYR$sRrS;gCht1AmDSd<+nzkSiaJfTW~ZiVUu4tE*nvCPtJ#-k zXHP+)uFbx9^=D^iUwUPB_MZBeSAF}jbuZsfFSwtVW?z_{{n1qI^p2f)^3n^Ly6Mb{ z+7H$J<|~iRKI+!_o!L58bq$)o3%ze8azvup^r@J1Vz51T1n(>~x zl}=_iTf2VEUex;L3!lo=#p=*j$HuDrYo=T8duv_QRLyiZ)pD5QoR^j5Y5wpOW9t-#%r6%iKX)6yydM{MU-7Np z_~rdr%ckJI$nP>@x3c;=+zkWF;o%DWN1qy?z3%fitz6pJTPt_3ZC5?YCd8u-f{gE9>rCS?4_c@N}l? zSWAYnyIAe>kFaS2tDWy%Q+LnfPdndV`@rK>9jklT@)c9HQ)6t}#Oht=4gc~=_S=6^ zH@y8?CU1j|iPYr^`K$p*m=jPw#`p+MMJI~OA>R0v0j2V;Nin8aZoY+wR7?a(K5^y_X zt70$HKkBnqeZ!Yl{P$)+o&7Vminr+&#*CJ4#?w_(u@`0^VbyM9d!M}x+@Zh1->jaA z|2utIHN*eT@>=xO_{3&KE7kP=^4S@q(ER~wyv>DmD~mn*l+hu#4kQ4+5xL^C>gA`N zeX)u;kU_0X|I}vxD76MadNHuV5aT?kZjG> znGN66TY@xsei{tS$rWt<%#ROTJv~%+>Y4kjT2phO0Bl=O03TROtz%W`HXz#`}c=`{(_5S!Q-f4P-iP!2k|)jM-YWm z3=*K0RpaNYFFZOs1JptYtl&*T7|+gLfv|G zYvP{d*)xy;tMhxj^yY%Qyu>U$gJaXQ0DoH(O1o+@DJab>&huY87fAOA)2Os$4?CcX4-S*5ynX50J`Fcsz;tV{gW3~EK428(8 zM%19cu_^qyc?N&H5AZUDU%pyi4fh)-N&4=P9GxPpUi^$8RC?Rtgi7VDRcxhma}79g zSuLBY&Hm&WL8$d#A9M-zkvAnD+`qj36=#24cIJIG_hXftzGRBzszIn%?tnH|JPePB)9bWh`{ud)MmKW?3_d0+-u?H6)YC)D$>a#gi%1fqW#wWiUp z(r-@r2(`KH!2{LJUt`@5zhh>)=KdLsvU&zXvOl%@1H!5$W<{}4i;L7V`g{EQ&3mWx zXCxL^`UJz?+1c+uqE$P^GWDPpz=#~wVv}H&^OM2x1I4GULZug_kb~L} z?5h)X7ajYJ7uS6KW>M=3`ez-~#@Sab95dD-s^ITh`gR-DQjgS^di9Oh^0k6xNYntg z*W!O`AptJ&O8}A+t+BcbxQzW@tOZzo>0zG)SoiT8&-`HB!z;dc&#u)o)Agt|{RaP1 zb!AK5$y~|a1m?XY^{o!z>-qNuNPt9UL(dwv;+cm!R<}-10{2sI4UhndjMH%*TUmD> z)jBW(tUlyls+vF2apq|A)XHz)y9>3r)L*9XqJ4=u-VeTF8ETIzn^E7`Zu+`>%6ky> zO=v0SpE1hb{4Cc%)U)`bD2D`?HMFHSKl_5vUap|>*zBKw0WUxT?46zcj(BxB7R^Uc zLaptcedW=opL!C%@qq*&R(y_+bT6+3dGf-)KQ;U8bL`ruo)oV`0^kdX2Q=(KMy)e= zyi3&K5`eza7Uoq?M95P6-&^em3;ONSW#qd;vjS;SEl&chU=BTyA1MJkAOY@adcTwa zYacVXfph>@0&Kt{BXt1m0%SY%uh6WN4sieDTnDJbF2JZIC4kTYrZc1iWa_XBFlxCH zK3x1j^B-?R$cmQwa?dHQTzP&QR~#rtz|4YncrUj zmAn38#Z+wI?vE^Mz2n!bu3WMDBel0*Qd4_()m8l~T5DU^Pfucp|G#QFoNuDmPgVos z|2+TuD=z+mfLQ&1dI@6PbPBZyBHFs@yz{B||9bJN`~IR9y|2CdUoX9H#jRtlSNH8Y z)8MRsrsMlHQ#9JBj{`29o391F^mg!G$miB~{CM4-T`yKoFP{Pb-xyY~AnP%c{Qf#e1qRxbd;(UtROHU9h!WJ~LSVgS8CkyJL5~IWWQ`%s2# zEuFvI@r}AEpzjVqtYNVg&{A1drtZEPNR???skp5LHkUef>sYF0&#o(X&cv2CKYTCr z;%|3XU(oTDn;viZ`Yvv38Ep6pt=ojN7^fw+8hiApkHZVK{gz#MZu~3FinY?qo?OL` z)*8aC_=L#SWyuGBbW!$2RVzfUVjoa5?X|^stUkH=jk@Xd@bmYnwu0sAin{6jHB-H+ zR{oo{bd_jlOBceE}Coz;A^JPkGg z>d0nQqZt7n*gc)O?13-0RyAKeU2|XEL#PGRfi_JefHR%BVs)$)gu5EGFau;?_3f?J zPQT+WXscBd>+eOaduh0VpVk$DkFAHT_11&Rey()pt_RJkl3KpKRZz=ZvkEFOo(av$ zcogshd#iw_=k}3J-!8N%9cqYXMG}GbR_-T60xYM!)tzTltzZd2dn-_@sue5&zT7dL z0kx`H!4e?WG2H=bRkea8z(vQVcd5ME!M@zbQ%5Ud(+3apY45Q`P9 zP%DiZ^h02kEP>SzzklV1I$EI~_t)ZB6++w70O?WW0i!!?e||%(|s3Tp?tOQK*wqX<7qF@7`V6Lk6rQ+Zd4#n#*mhZuriV^~?X?tKVrAq`O=!@H$qP z)oB3Z2tIc0N{@tgFuvoih0A9XohW??w)#o1D0_#fQ^FMa6x<;4* zc&+L)yw=p=?|$yF!498p+3PnZFCEn#b_J^9pkp1JR;4}I;QJgmBA08#7R{GWfH z3BYR15moS4oM=49*o=Cl)_w00HxmTd3S8O;?X=>5yuxh^r-3^A6FtXR&3$|mP`!e6 zf1j;jYlRNrvH#4wKQ{C$?|=7wvrFYle?pz8p7B&G@8MY?I zHnCko2hiC62Y0W({lOnF+5}{(I?hZ!AA5rBQMe+jy!g~ixnJm?o9T~kHL0fu7p!`< zn*Noa8TwNFoJp%|{#=;0MWvfvOYW^N0>}6en#pE5`A09t&P>r>1Mp*K7&rN_+S_p0 z`s{U&;_vJbsGTIhse795Tweb&8QE~SM4#HgI3o9;rWmTCKhrmfh!61@UD@{g$)}6S7sy#Hx5<-De+FZ_*cA0yuc)aEu1) z0G?dkmA$*}{ioLk>i|lw)=ghu_wbLLKpjAntK%1Ke(>%!fjWSPRajduuDiQN(*e4& z$8*V{VqplmzY6$oSf;!ZVOzqF=twp{QgVs~XXAJ-JM0wlBTjkK)_6QMJnV>ia5ySD zMUgX0xE>XT9TCF7e{OZ0Ore|`AIX=-9P&6y_3;Mb%|D8UdJ6Db$~kXM-N^qPrB0P5 z3&p}DkABEyM;-G261^G9j*L)eba2))bPDez#~jh~!Q4=GqC}oiIqEMpSDG9hERHzv zlp4vM%G2wUh$xsqug9~fHjcX4f-^i>$d2lzdyT%ry}ms|j&sSj6dcFU7~Vk}xg+^P zZrC|8Q5Y)ci-j#tspzC{gf}0Y=E$9`U-SzD?@tfI9Syh}5MRc#h0+M70WMhxOTgFC zF?>h)SZ;g>*>9Xu{%E1(Y{Y0v#xo$hRHn&6jwbc0bEG(qHws5ba?a4PEFv8+1x~Is zlpV|Q2=A$@r0=OESbdKat5!klQ7VcI@qaM$Vjbw*%&c^&m z%Vr0EZoT%}Tb;zIQ>WmXlPeEx<*scMAA&~`oo(6iVW&g1aWaoF!7I)gLl7c-{uC05 zgKy6bl}jzo`d>JOJ{>Mj@cdqOpMcV#V@9vCppvqK(2=7Ur)UJTK8$fwHB6>95uy|5 z*TDEB#*!S&i!^F3X}h$@=a=v$+!I}zb7bX{#qr}Mv~l=Y7Sn%>cT}GWNzubafee9X za2NdjH~|Pg0p(IJvd+<5AqN@5jA38OwN4b+%3RM zcR7FpED|HAylv4Vj>w`==^RVi5=~j;5;n!6vP!xjIJYlr{@wClMc`G6zNj7L_eZTom9sa}Z&u7Jw~ETohoH7qXHOTa>scz*anU z^oT7=TomBsd{Avs;-Uc8&j;{Uv+|+q`EkFG= zLI)XIzz?<;IkwQo|1+WXXNL&>YxVS}g~s?P@*){YwsG(_1K2k_KYqe;~QW(ROJW<&)FV9cOGsnAh=O8BBr8@?ZaD}1& z^-~be-LB0^o$Q^3QxJ(~VRyDjG>o1_DjVUEKEKN*08KL(Qp@a^kI(IGTKDLUDU~k3D+_=N5i$uP>aE{Wo?dzyQp&y zbG(+ZIU4Swjy+7cmaRD&?xIdTOt_Y*IU4S!#Tc_BTwy9*x-$Yzi8cd1V~Ot?#T$e|@dR`=0s&(3eq{7Ied$*%0Udx1jJHnIiDB}q)vIybp+?8ofA zvA?alnO*qL;mL)0uGeI4=or6z2HyTbm(OS^WBCOr>9!7j?F^;$rJTX?_5n(xKi_ny znI1i-uSz^B?ocpqV##!igte6CKRoU1SHmd8g=i1#OMiO2u&aA7Ztr)RSi@ncWG$VjSF3XoF2NS2g#?C`+NG5>7M-} z_pTy1*$1i;5AJ}`B277ZZryUB!-wHbz(6&TE!hL6)iZ|`gl>f{faG-VO}dq1*-Kul zjX=GQOEyHOBYG23Lr!8yu>wKmTnfxTp}6Q;d&GutzX{JlOaoBU6mSQNP3ZFK7@9Y{>L!A-J95P(}ZG^;^QUW?afNI-3lUB*r9bcd&#s?c;kF?eYdL zeq9%>n_zTA!N_duqQ5SIXrpw;v3~g4$wAF?pb`2Wy!l_7CNg#pKECq`IC&OO;8_=@{6INVycR^SJzZXt9-uqn)&XA+JU4ImOxeeccn4+-V^P}!)u5Vu%_`-hM;GoofssW> zR58b|b<^V_t)rq-x@L@#{p@WIOjL`>3z!29W3SC7!R)6oRr+qnsuoO)l2mysigqd_ z#(k-_gNIXn?fn%ATe(c3Bg8biJgkr)RsTFHRFAw>E}(rwg7KlA8+of%T8&2JuuTlx z3J4G)_lj{T1+jc3C@0TJN?a15*cfsoqG6?OX{>7z2{jcU(5za)mDE7p39#j!LJkxL zY{X(6q5D$o#Bdk4y%WpA!sB`W zqHSn#pO`!l+m8LR|3K_=cSFnm8@ng=MC=82-Xn}JLWla(eW!6UAkGEc9j&)K33lDr z*OO{T&MLl4(1{mUvQFhy}fh)p>A=XBroYq zb?s|Uxvf%rr*VHYzdn=h@+3;-ON`dORy@b{t>WDqbZSq;xb63=%QwN(>h@7G1b0V_ zNwSr$z?cZ(ryr;`-wnUk9|2!i@LiosU191U4#y^!POinC-v&tutSBKDCH6W}92qH| zq&!um^Ou}avY=weGF&X=$dX#hy<;L*7=ksGH^V^~^rVSHF7|zN#4iJ-glL?gf(gl+ z2Y1nO)%H|xZ|6;7;EI4aVI52-Z9w737hU%VIBW^DTTIf0v;J;JiD9++*==DELhI#| z*5890YcY^MtW`Z-4#7bu)iPotSew>h47;SJ;a9Mf{@jP*U|_nE5e%#^-G8WaK&b_M zHUiij&-o$|J}c@#(3UD*S4|#@U_g=b2kwL8 ziC~0L)9xmP*b!aB7FOdLPfg=X=Rtkx^vV2f*3x;o&!p>nMPH`$AQaehciBsvS{@Nf zRgZWkzJ@82uDN<5QpT_co2C4+%CNN+;Yi!{032)eL|Bm?NrjjqeQotyi}lr$?)XHn z36)icgI7;7Rg+0sDj_07dAUkYhWi2@WRI|0Sk-D~MpXA0x(a=6e`TlL$q)M{+*#8^r?o|P!$`{o`~o6->5`-s9VLOkkOV1M-F`u z7?2yDqK~&K{)B;8bc_GS;)rOBjfQZjpesA7Yk3rhN>bDrMFlLn;f!`nVdE|tGKg~* zoXVJa{(M1!TCf`O{3$gQaeKH6*HoSnN!eXI;fCLVM=T{(l>#mfUMvOID}{Co#oG*_ z+of7Y=$;vV$3y5KJY)zRLKRT~-6kGh)}`~XcUpz>D1foA!_7zy_!#SneWPjzG$O;S%)t<9$~Ko+gh;@^?#OSKK4Nv>$%N%+BlK5E-E$ej*&6Bww6 zY9Cfzh0*d;a$9zUj}qTk=&fiI#>Z)IYbBc07<>d`s}MSsi0LKWPV0D2FC_==mw3+X z_m>Gh2PM2usR1a6-oU*^(F7U6Eo+DF=7IOI{R(`dEbM{j2 zq^8Ikj1}5T-6JLLcWpCuvfwdjFg?_vQy769gP2qg8JgNmROJ;&Y6@d}kF(>UtnG5P zq1gtpHYX4tZ&%KZ{C$(RUC?v0wuUpw0l-59Yr7|P8{@&;tC67Ap25%a<3ySgd)J_K znuN6UM{*L!a@gTwHGx^`2gb^6uO^;GDD$~!W+~~`&}hHKEl6aUf)cA+XkdIYgX)n@ zV1I6q9Ga0zfJ{?*V0=8GCHI9p1x#Cp-maCx_=9+T-MVDF%xy!Bx^}HMjZ!Gcno5Cg zYbpblRmAffDgy>3qu*h=Ls-7vG{&qn3ar}DSgbvPr3Z8Ig8OSqWUo^n&k^$3RM{byvWx`l_A4!ihZlAonIgsg2b-E+6I?83N=|@Q>lF&h-EDTo>Ksgi-+uGvd zJ#-~cs5_!H4tKOdBhZGc2{4${V8st|IW&xPuFYRr>BQ+e(JH}E9h5|)!3x8KE8C=H zO5#&{(;5umNW@}c^10G#FKVKbcTZ>+5`yY%&;eusd22*u^@umF!Ht@-U_|LUb||7~ zIAZXe;(P$bGEL@cZ)n_m+3+>)*GW&jl9cfrd>|%)OKfS-f^Z|Wy8r{HvLOb%r5m~Q z-9f)VC_o2Tm|dFHX2W<@c<;x#vf-g2a7F@pWFGWa5P;zKVTTYBwzGidIgwXjJ_BEK z6aWLZ79Y^6tlE|0rc1G9(k;wB+ogdqS2ze%n#w<^aso!FX zRQ1yVBU}t+q`P_tZsL4q5Qc?TQA}F9Ga0=+RwD32X;6Dv>KF!*=o@>54Y>|;>4y!@d%`z3 z(0%Q5_cgj{GI)c-HD>qd-P+*bA`mOLm$F@(Lc|&#O|(I&Q|{MT$>Q{DlA$c6;Xt-NdHaUJ>55T$*qT{8!44R zqd{%i(Zr+sR4PBN=Aa-8_AplwOYuWT7k;!qFVAeQ&xmEt8&^;d1Ehd~DUyn|VZ$1g zC8VTVB|+0ARWM`w6(R?_axN&WDHB&Mxhj#uy5Ty(^#k{?-@8DHPWo}v7hRX++P;VL zxU>zIU>(ij3apW0DL1^82TTby@Ni#d08Sr?2JAG&oNGj2j~(do5FB+h8ax^fJ!(wz z*|I65sEO9`Z}nW#qI$`XNsWk9E!DJ!6OV?}!f1}RG8!_1Jp(mx3CM2^b>c8;0*vbC zJfi$DbDXYK6R|MjVzSEVs;7_G$X#A#L?Ot_*_b)d4G$xE3m#vJx#FPF zlr?WQw*@dz+}%-_li*%EcUCD5YK5uDTNd#h$<)&>v>XiV7_RSa&p{pK>r79ci861T99OW+8&HT?7RP zWdO4m2LlXPGOqDtw26)PiU?>?7$qqXhzd1Qc($o&(J8E+kt9*HQq#zp@5HvE8x)k zyb}hg_sx02z_mp~AN7(U*52sQ{{NoIBSg^kNqmUY$d~rHb8ft(oL4Aw!r@x%bQM&^uqsu^Xizex51OoS;j?nF!xVX~r*;K%eWlx}; z9B%c*HJUlxGCPbrFrm`XZMEnKVvuobZ2l;3hu@Bg%T964CiF<$Mk^X7I5gy})C?(j z4Hs!1&7y(feD-Lehzdh!4&4~d(&e?(bNL#L$h#dBuVkIE>^NSSz+&YT$A@#{TM?U2 z;rTScQgH&8*76bY&XqA8qIc*iwMBTQ+geM`aJHNsq?n-GZ*s#11Tme zNvO`Htpu6IWTsKtC%wHSsaXk%4c9O$=df_lk{h=QuW=MvDpgk9Xt1KP%c;aIe^e?DLX@4CwuhDIiabMa^#%fSkqc2x#dRL;oC`pqW`npu^1 zt&*7y%mX^V!HP9WCAy4;Dk>{G#-a!NW{I|Fu!0P%%y5FB7BX0sT{9Z07_5~qbP;5% zGE+u_6@yh1qT_fWgWXaYip5~9WTA@~tV)Mj$zaulEOxNh%xAEHcVR7vXH~A#N(LL4 z%XT3%3(Zrc7LSH1X4XnSyNH=xRT)@8#(~#xE@ZGO({d$)wQ@%DPX*ubkl z7cy8S)}x_{nY9vDFJiEl&1YtC$m|1n(ax_>m*z+YBEOxLeb$m2bF<8ZEI@ATttjdTS4OR?R2~i#FLddvL zVl5h~7;NBeh?NaiDyibu7IiB?G*nSpNp5|tv{B6!%5$j3N+TC7RY*_bl8ZokTF7A4 z)eF&s6;M@WeXt9Gs+O=ypen@7A1b_udwM}c_|zbnD{ z@o!BJAfuwQ3+5SkxSq&i%boT8+Qe4yX6Vlw*h=-9_L#A|sFbcCdy>9@s-R2YLr*r- z7ka|4*rO*W@Y8n%VeD-6(Txcrh=G9cJiLJ3;+=i{)z{G^?#29>BZ*MbUBpO2+g#={ zOzj6)69u;YW2o^Owp7?-?R9M~T0RLL>?)?j&Fs9?B(!bHdp< zmYnMdEb2fJ4ynEaMf2n-@(d2=kt!HP__yHv2RSg>(r&_A?HE(~bBH4`?!~6N8<@pW zM|$pfLe7>%^XlByJH?AWLc?ob)qpc{95x@x7xJZJYU;e|_R$vF5>6%Y1l&b(*}}va z$dR81EAOGew*yYv%oAwqxGk^|a&N=o+8SLx+2pIqCrQ2m^2vTnM7WCsED|K}_wtU< z5G+HHB_7{#QDa`&DZ^6KDHn=mybQP+k+MdRyjM!$G7vY``C5aFlcgBj?JbR_NH9vl z_m!|UoZU>eKHqgVt2)6>MYFX@9Oh&Pld8rWE(MvB{Zq%+neI$KTo(=v^d8cqG&Rnp zF5CX8S}{uJW^7$3=$!S_#MlYR)-p784!-s=s+{S#lA5|-jIX+zng(qBrbxE-j&S83 zvI4f&Jv@WhdPfCp&DUF(tpgYz(Q3M*Xu{)cM5g10S*+K<N@!rU zMod4HEg|#tU^ZKLX^FJtPFJkhRoAl(oV8>x%2W&$hohCFSPX}h%a^;L6!kj4>i_Yu{63Cc^?eL z+bhL#2e0t6vfNcqhHA0!{`R&h!oYTwT<+cyI~@CT>;YE2BS4Fl5uO`GqHmn^!zaRJ z5I4rtISRjtu>|zP)PCeOfb6EQFE=e%^a>$LHG=Ww3AGqB9^MU7usy#u@t)_crNMA% zS*$U_T}#A6xazN1h=j+PC!Hg8W1niw!P$NA8Vk>oYXn$u`4f7hgnvkojAB$=sf9yo zsW_S&g=hDHfwohOgA%JUgo4s-W-^a}DGCid9m?&zrXq zK>O9Uyj&J(y7^98V@2v4eT~*?z>I)Rt=0stJJ=?T43xhH3OMc*)7EG$$esit>d+Y$M1-A<2T%UuDKe#k--vXS7*_p)Y2z_1aL1D!~NY=q#$HBRQv zIq&6QImy!tAb>`03*lBs44sN8y+0UhKV=p021$1wZ{%ei5`A@`=kj4Bk71*iE1 z6mW^d?O=zx+o@L(hzc^KaM9}xI@qibGVQu})+R)XFkLO;OM>Qg>p|3CgjAyb2>)tx z3H4skJEMtzAvP5adi6B`+O)V&9PkR=vhc!nZ)L|TK~=0R>}fx_KbC8BW=qa>jSg=)T`WSm&$ zid9Mk(@VI^xM&re97Vs{d}#C~UiC~wCiV>2Eb9v~Omw;8x_=mfr9~6XWCPl7sv=1$a`!V_LXW7sv4ieB#k=IX@}@kc%|A)Q?XTuDtR} zQde|M!P~ERv~LSoXJa?Tx#PXKh;ZT^6#}4#-`#0NlW{c|ReO^>rw*mPOHr;hp8F2) z6F26@i>IUnIoy%%<}v6HfRv#P0b{q2Yx%pV=g?~sw+xq#iyunV#S?jW!y{>+@Lxwo znK#+Hz{PGC7G-i?FHGj(zs_COB>?A^F|6AynpeA9f;SrKx6=Q%?|2ufSX|D=6a9y} z(lR_d<9Q@cM2AXa z#e%qS4}E`Y>c+NrT?0xRzvfgnU%G~x;(vI`8@^^?Kv+5A2~LVC0rhBhk}^-@%_9>d z6uv;)IycmUF3v%uDp(1Vq6~k8LuKPqchu*jpmUs60OTs3!TH9m&*~xON(SLylt)Bf?E=ue2u($3BY~q9#@~ z6fF7SvNJ*X(;@%exKkmOd9qQi4`^g!=O7G9LIk??iAzq=B%naiZZaGGUFEXjzeKuy zqM^VB-1m7dN6@Edgb0SGk-P+qbnNbnx*Xh8@nL(@z|%?d4CZIrw!E@~8=1XZ>^m64HE9B^jQBKd1K*DE-#rV~}&fItD13!1B1vibM zN?OF}90u~#KnG!8TV)lua7934uHe1TTvH!7*@Q}3;-fZXk)7k|bky$JqDO-q1#24= zXykCvNKiw9`&1bdJo@_?v1Sp5b()LMWlTW*aM{Oq2VBVwHYUt%OQ1s;GBWDsGJb^O zrKt$EC3vQDw}X*%p)V_erbD5|iG{->O+RU4DGnkd?-h-1Xk|Dn6pcCX0Qmb9+$D`e z?LI-7>?wgfu4fbN^clH%`ZSoN9mYSZJbjZ_V`!VMYaCP`H(vJ4|fKke+67J@{jP^SeAq%Iyw^H4hqDPGw+<6sa)4?#9sSv~Hm2w@f1GfkUt!cf%LdO_JEJb>33iu_p&=q~05b zq5yu!Tdw^v^lH0+w+!Qe(M66$;6GpkEGI~tTjN!sE{7+6*4_)~lCcXVulpXlXa?kn z!{xqYx@W&=-jjeqI;WfHFrayN`uM8D?MB*Mc#JGZFPPMW70{rp`ZJvL*`R$5A7L!; zde-NPkJ(S3?Fkals9b?!#_Z zZo?5aW2J`1W;iN0wC-Amm#x&$#(|PQH?$tUM?Esl1IEk#+|c?C9|uZSYG~s$3f|3D XZfJcE505@G6(7vjW=1=e8~XnT;%>*k literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/README b/internal/test/LANGUAGE/from-sun/README new file mode 100644 index 00000000..fd2af62d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/README @@ -0,0 +1 @@ +This directory was taken from python. it originally came from Erinyes but I believe that Frank Shih created its subdirectories to better be able to run the testsuites without hitting several limitations that Unix will run into when dealing with directories with A LOT OF files. This is of course pure guess work, but he seems to have organized the subdirectories according to chapter? Carl Gadener 8/14/90 \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-1-GET-PROPERTIES.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-1-GET-PROPERTIES.TEST new file mode 100644 index 00000000..e8c94d85 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-GET-PROPERTIES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-properties ;; ;; Source: CLtL p. 167 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 24 June 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>10-1-get-properties.test ;; ;; ;; Syntax: get-properties place indicator-list ;; ;; Function Description: Search the property list stored in place for any of the indicators in indicator-list until the it finds the first property in the property list whose indicator is one of the elements of indicator-list . ;; ;; Argument(s): place: a property list; ;; indicator-list: a list of property indicators ;; ;; Returns multiple values: ;; If one of the elements of indicator-list is one of the properties in the list stored at place: the first indicator found, its value, and the tail of the property list. ;; If not: nil ;; (do-test-group get-properties-group :before (progn (test-setq alpha-list '(a b c d e f g H)) (setf (get 'alpha-list 'length) 7 (get 'alpha-list 'languages) '(english german spanish etc.)) ) ; progn ;; (do-test "get-properties test" (AND ;; The simplest cases: ;; First value is a property. (EQ 'a (car (multiple-value-list (get-properties alpha-list '(a 3 "Alexis is a bitch."))))) (EQ 'a (car (multiple-value-list (get-properties '(a b c d e f g H) '(a "Krystle is dipppy."))))) ;; Second value is the property's value. (eq 'b (cadr (multiple-value-list (get-properties alpha-list '(a 3 "Alexis is a bitch."))))) (eq 'b (cadr (multiple-value-list (get-properties '(a b c d e f g H) '(a "Alexis is a bitch." 3 ))))) ;; Third value is the list's tail, starting at the indicator found. (tailp (caddr (multiple-value-list (get-properties alpha-list '(a e)))) alpha-list) ;; (tailp (caddr (multiple-value-list (get-properties alpha-list '(C D)))) alpha-list) (equal (nthcdr 2 (multiple-value-list (get-properties '(a b c d e f g H) '(C D)))) (list (nthcdr 2 alpha-list))) ;; Should return NIL if it doesn't find any property from indicator-list. (null (get-properties alpha-list '(7))) (null (get-properties alpha-list '(weight price))) (null (get-properties (list (gensym) (gensym)) '(languages weight))) ;; See if it can work on itself: (equal 'etc. (cadr (multiple-value-list (get-properties (cadr (multiple-value-list (get-properties (symbol-plist 'alpha-list) '(languages)))) '(hebrew spanish))))) ) ; AND ) ; do-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-1-GET.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-1-GET.TEST new file mode 100644 index 00000000..959cdc6e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-GET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get ;; ;; Source: CLtL p. 164 ;; Chapter 10: Symbols Section 1: The Property List ;; Page: 164 ;; ;; Created By: Peter Reidy ;; ;; Creation Date: June 13 86 ;; ;; Last Update: 16 December 86 ;; ;; Filed As: {eris}cml>test>10-1-get.test ;; ;; ;; Syntax: get symbol indicator &optional default ;; ;; Function Description: Get the value of indicator from the property list of symbol. Return default if specified and the value of indicator isn't found. default defaults to nil. Note that the function returns the same value (nil) if nil is the value of the indicated property or if symbol does not have the indicated property. ;; ;; Argument(s): symbol - a valid CML symbol; ;; indicator - any valid CML expression ;; Returns: value of a property - if symbol has a ;; property eq to indicator's; ;; default - if specified and the property's ;; value is not found; ;; nil - if not found and no default ;; specified. ;; (do-test-group get-group ;; First, create some property lists. :before (progn (test-setq carre 2 four 4 five 5 cinq 'five) ;; The symbol FIVE, not the number which is FIVE's value ;; Start with clean property lists. (setf (symbol-plist 'four) nil) (setf (symbol-plist 'five) nil) (setf (symbol-plist 'cinq) nil) (setf (get 'four 'square) (* 4 4)) (setf (get 'five 'square) (* 5 5)) (setf (get 'four 'sqrt) (sqrt four)) (setf (get 'four 'odd) nil) (setf (get 'five'sqrt) (sqrt five)) (setf (get 'four 'spelling) "four") (setf (get 'five 'spelling) "five") ) ;; Try some ordinary gets. (do-test "regular-get-test" (AND (get 'four 'square) (eq (get 'five 'square) 25.) (eql (get 'five 'sqrt) (sqrt 5)) (eql (get 'four 'sqrt) (cadr '(1.0 2.0 3.0))) (get 'four 'spelling) (string= (get 'five 'spelling) "five") ) ) ;; Try the default feature (do-test "default get test" (AND (null (get 'four 'prime)) (get 'four 'prime (car '(10 20 30))) (setq epimenides t) (eq t (get 'four 'prime epimenides)) ) ) ;; Test the equivalence between get of a nonexistent property and get of a property defined to be nil. (do-test "nil get test" (AND (setf (get 'five 'odd) t) (member 'odd (symbol-plist 'four)) (member 'odd (symbol-plist 'five)) (not (member 'perfect-square-p (symbol-plist 'five))) (null (get 'four 'odd)) (null (get 'five 'perfect-square-p)) (eq (get 'four 'odd) (get 'five 'cube)) ) ) ;; Test the function's ability to distinguish between names and values. With acknowledgements to Ron Fischer. (do-test "use-mention get test" (AND ;; cinq is bound to the symbol 'five, not to the symbol's value. ;; A property of 'cinq... (not (equalp (get cinq 'sqrt) (get 'cinq 'sqrt))) (setf (get 'cinq 'carre) "vingt-cinq") (member 'carre (symbol-plist 'cinq)) ;; ...not of the symbol which is its value (not(member 'carre (symbol-plist cinq))) ;; A property of the value of 'cinq - i.e. of the symbol 'five (setf (get cinq 'carre) "vingt-cinq") (member 'carre (symbol-plist cinq)) ;; The symbol 'carre is on the plist, not carre's value. (not(member carre (symbol-plist cinq))) (setf (get cinq 'carre) 2) ;; The value of the symbol 'carre - i.e. 2 - should be part of the property list now. (member carre (symbol-plist cinq)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-1-GETF.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-1-GETF.TEST new file mode 100644 index 00000000..50fd0686 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-GETF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: getf ;; ;; Source: CLtL p. 166 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 20 June 86 ;; ;; Last Update: 16 December 86 ;; ;; Filed As: {eris}cml>test>10-1-getf.test ;; ;; ;; Syntax: getf place indicator &optional default ;; ;; Function Description: Get the value of indicator from the property list stored in place. Return default if specified and the value of indicator isn't found. default defaults to nil. Note that the function returns the same value (nil) if nil is the value of the indicated property or if symbol does not have the indicated property. ;; getf differs from get in that place may be any form whose value is a symbol, whereas get requires a symbol. ;; ;; Argument(s): place - a form whose value is a symbol; ;; indicator - a list (anything for which listp returns t) ;; Returns: value of a property - if symbol has a property eq to indicator's; ;; default - if specified and the property's value is not found; ;; nil - if not found and no default specified. ;; (do-test-group getf-group ;; First, create some property lists. Whether or not the symbol is bound shouldn't matter. :before (progn (setf (symbol-plist 'hundred) nil (symbol-plist 'thousand) nil) (setf (get 'hundred 'power) 2 (get 'hundred 'factors) '(2 5 2 5) (get 'thousand 'power) 3 (get 'thousand 'factors) '(2 5 2 5 2 5) ) (test-setq list1000 (symbol-plist 'thousand)) (mapcar #'(lambda (symbol) (setf (symbol-plist symbol) nil)) '(trunk branch twig leaf)) (setf (get 'trunk 'offshoot) 'branch (get 'branch 'offshoot) 'twig (get 'twig 'offshoot) 'leaf ) ) ; progn ;; ;; Try some ordinary getfs. (do-test "regular getf test" (AND (getf '(0 1 2 3 4 5) 4) ;; NIL because 5 isn't in a property-name position (null (getf '(0 1 2 3 4 5) 5)) ;; NIL becase 6 isn't there at all (null (getf '(0 1 2 3 4 5) 6)) (= (getf list1000 'power) 3) ;; Nested getfs - the property is itself a list. (eq (getf (getf (symbol-plist 'thousand) 'factors) 2) 5) ) ) ;; ;; Try the default feature (do-test "default getf test" (AND (= 10000 (getf (symbol-plist 'hundred) 'square 10000)) ;; Default should not override specified properties. (not (eql 50 (getf (symbol-plist 'hundred) 'power 50))) (getf '(Ennis concrete Hollyhock stucco Martin brick) 'Hollyhock nil) ) ) ;; ;; Show that getf works several layers deep. (do-test "recursive getf test" (setf (get 'leaf 'color) 'orange (getf (symbol-plist 'leaf) 'color) 'vermillion (getf (symbol-plist (getf (symbol-plist 'twig) 'offshoot)) 'color) 'blue (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist 'branch) 'offshoot)) 'offshoot)) 'color) 'black (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist 'trunk) 'offshoot)) 'offshoot)) 'offshoot)) 'color) 'green ) ; setf (equal (getf (symbol-plist 'leaf) 'color) 'green) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-1-REMF.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-1-REMF.TEST new file mode 100644 index 00000000..11972e1e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-REMF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remf ;; ;; Source: CLtL p. 167 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 June 86 ;; ;; Last Update: 1/28/87 Jim Blum - removed tests which evaluated to (REMF NIL) ;; ;; Filed As: {eris}cml>test>10-1-remf.test ;; ;; ;; Syntax: remf place indicator ;; ;; Function Description: remove the property whose indicator is eq to indicator from the property list at place. ;; ;; Argument(s): place is any generalized variable acceptable to setf. ;; indicator is any valid cml expression. ;; ;; Returns: T if indicator was found on the property list at place, else nil. ;; (do-test-group remf-group :before (progn ;; Create a property list (test-setq thread "twine") (setf (symbol-plist 'thread) nil (get 'thread 'material) 'cotton (get 'thread 'length) 30 (get 'thread 'brand) 'Pennys ) ) ;; (do-test "remf test" ;; Some ordinary examples (AND (remf (symbol-plist 'thread) 'material) (null (get 'thread 'material)) (remf (symbol-plist 'thread) 'length) (null (getf (symbol-plist 'thread) 'material)) (remf (symbol-plist 'thread) 'brand) (null (get 'thread 'brand)) ;; By now the plist should be empty (null (symbol-plist 'thread)) ) ) ;; (do-test "remf returns non-nil if it found the property" (setf (get 'tarski 'nil) 300) (and (evenp (search '(nil) (symbol-plist 'tarski))) ; Show that it's there and in property position. (remf (symbol-plist 'tarski) 'nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-1-REMPROP.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-1-REMPROP.TEST new file mode 100644 index 00000000..1b5b28c9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-REMPROP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remprop ;; ;; Source: CLtL p. 166 ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 20 June 86 ;; ;; Last Update: 16 December 86 ;; ;; Filed As: {eris}cml>test>10-1-remprop.test ;; ;; Syntax: remprop symbol indicator ;; ;; Function Description: remove from symbol's property list the property eq to indicator. ;; ;; Argument(s): symbol - a valid CML symbol; ;; indicator - any valid CML expression ;; Returns: property indicator if found (i.e. if symbol has a property with an indicator eq to indicator; ;; nil - if not found ;; (do-test-group remprop-group ;; First, create a property list. :before (progn (test-setq twenty-five 25) (setf (symbol-plist 'twenty-five) nil) (setf (symbol-plist 'minus25) nil) (setf (get 'twenty-five 'sqrt) 5) (setf (get 'twenty-five 30) 35) (setf (get 'twenty-five 'inverse) 'minus25) (setf (get 'minus25 'sign) 'negative) ) (do-test "remprop test" (AND ;; First, show that the properties are there. (get 'twenty-five 'inverse) (get 'twenty-five 'sqrt) (get 'twenty-five 30) ;; Now get rid of one. (remprop 'twenty-five 'sqrt) (null (get 'twenty-five 'sqrt)) ;; Show that something eq to indicator will do. (remprop 'twenty-five (+ 15 15)) (null (getf (symbol-plist 'twenty-five) 30)) ;; What evaluates to a symbol ought to be acceptable as symbol. (symbol-plist 'minus25) (remprop (get 'twenty-five 'inverse) 'sign) (null (symbol-plist 'minus25)) ;; One property should be left; get rid of it and the list should be empty. (remprop 'twenty-five 'inverse) (null (symbol-plist 'twenty-five)) ;; Remprop should work on arbitrary symbols and properties. (null (remprop (gensym) 'eyecolor)) ) ) ;; ;; Remprop must return non-nil if it found the property (do-test "remprop returns non-nil if it found the property" ;; NOTE: not working in 6 December sysout; see AR 5973. (setf (get 'tarski 'nil) t) (and (evenp (search '(nil) (symbol-plist 'tarski))) ; show that it's in property position (remprop 'tarski nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-1-SYMBOL-PLIST.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-1-SYMBOL-PLIST.TEST new file mode 100644 index 00000000..1f97d9cb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-SYMBOL-PLIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SYMBOL-PLIST ;; ;; Source: CLtL p. 166 ;; Chapter 10: Symbols Section 1: The Property List ;; Page: 164 ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 16 June 86 ;; ;; Last Update: 14 August 86 ;; ;; Filed As: {eris}cml>test>10-1-symbol-plist.test ;; ;; ;; Syntax: symbol-plist symbol ;; ;; Function Description: Return symbol's property list; return nil if no property list is found, whether because symbol is undefined or because it has no properties. ;; ;; Argument(s): symbol - a valid CML symbol ;; Returns: symbol's property list or nil. ;; ;; (do-test-group symbol-plist-group :before (progn ;; create some symbols (test-setq nothing nil unbound (gentemp) props '(true fixed ratio float complex character semistd linediv symbol list dot vector string bitvector hashtable readtable package pathname stream random) vals (list t 100 -3/5 3.14 #c(3 -5) #\Q #\return #\newline nothing '(a b c) '(33 . 50) '#(5 10 15) "twine" (make-array 7 :element-type 'bit :initial-contents '(1 0 0 0 1 0 1)) (make-hash-table) (copy-readtable) (car (list-all-packages)) (pathname T) *standard-input* (random 4761)) ) ; test-setq (setf (symbol-plist 'nothing) nil) (setf (symbol-plist 'unbound) nil) ) ; progn ;; (do-test "symbol-plist empty property lists test" (AND (null (symbol-plist 'nothing)) ;; Get an unbound symbol. (not(boundp (gensym))) (null (symbol-plist (gensym))) ) ) ;; (do-test "symbol-plist property types test" (AND (= 0 (list-length (symbol-plist 'nothing))) ;; Give nothing a property of each type. (not(setf (get 'nothing 'false) nil)) ;; acknowldegments to Karin Sye (mapcar #'(lambda (property value) (setf (get 'nothing property) value)) props vals) (= (+ 2 (* 2 (list-length props)))(list-length (symbol-plist 'nothing))) ) ) ;; (do-test "symbol-plist unbound symbol test" ;; Show that unbound symbols have property lists (AND (= 0 (list-length (symbol-plist 'unbound))) ;; Give unbound a property of each type. (not(setf (get 'unbound 'false) nil)) ;; acknowldegments to Karin Sye (mapcar #'(lambda (property value) (setf (get 'unbound property) value)) props vals) (= (+ 2 (* 2 (list-length props)))(list-length (symbol-plist 'unbound))) ) ) ; do-test "symbol-plist unbound symbol test" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-2-SYMBOL-NAME.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-2-SYMBOL-NAME.TEST new file mode 100644 index 00000000..d10c33d1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-2-SYMBOL-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: symbol-name ;; ;; Source: CLtL p. 168 ;; Chapter 10: Symbols Section 2: The Print Name ;; ;; Created By: Peter Reidy ;; ;; Creation Date: June 28 86 ;; ;; Last Update: 16 December 1986 ;; ;; Filed As: {eris}cml>test>10-2-symbol-name.test ;; ;; Syntax: symbol-name symbol ;; ;; Function Description: returns the print name of symbol. ;; ;; Argument(s): symbol - any expression whose value is a symbol. ;; ;; Returns: symbol's print name. ;; (do-test-group symbol-name-group :before (progn ;; Create a some symbols and a property. (test-setq five 5 fivename 'five) (setf (get 'five 'symbol) 'sqrt25) ) ;; (do-test "symbol name test" (AND ;; For a defined symbol (string= (symbol-name 'five) "FIVE") (not (string= (symbol-name 'five) "five")) (string-equal "five" (symbol-name 'five)) ;; NIL has a non-nil print name. (symbol-name nil) ;; For an undefined symbol (symbol-name (gensym)) ;; Indirectly (string= (symbol-name fivename) "FIVE") ;; For a property (string= (symbol-name (get 'five 'symbol)) "SQRT25") ;; With escape characters (string= (symbol-name '\f\i\v\e) "five") (string= (symbol-name (get '\F\I\V\E '\S\Y\M\B\O\L)) "SQRT25") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-3-COPY-SYMBOL.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-3-COPY-SYMBOL.TEST new file mode 100644 index 00000000..f1a8d488 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-COPY-SYMBOL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: copy-symbol ;; ;; Source: CLtL p. 169 ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 30 June 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>10-3-copy-symbol.test ;; ;; Syntax: copy-symbol sym &optional copy-props ;; ;; Function Description: returns a new uninterned symbol with the same print name as sym. If copy-props is non-nil, the initial value and function definition will be the same as those of sym, and the property list of the new symbol will be a copy of sym's. If copy-props is nil (the default), then the new symbol will be unbound and undefined, and its property list will be empty. ;; ;; Argument(s): sym: an object whose value is a symbol ;; copy-props: an object whose value is nil or non-nil ;; ;; Returns: sym ;; (do-test-group copy-symbol-group :before (progn (test-setq forty 40) (setf (symbol-plist 'forty) nil (get 'forty 'square) 1600) (test-defun forty nil 4040) (test-setq fortyname (copy-symbol 'forty)) ) ;; (do-test "copy-symbol nil test" (AND ;; The print names should be the same. (string= (symbol-name 'forty) (symbol-name fortyname)) ;; Since we didn't copy props, the new symbol should be unbound and without property list or function definition. (every 'null (list (boundp fortyname) (symbol-plist 'fortyname) (fboundp fortyname) ) ) ;; but 'forty is forty (symbol-plist 'forty) (forty) ) ) ;; Now try it with copy-props; it should bring everything with it. (do-test "copy-symbol copy-props test" (and ;; Returns nil 9 October; AR 6540 (setq fortyname (copy-symbol 'forty 40)) (eq (eval fortyname) forty) (eq (get 'forty 'square) (getf (symbol-plist fortyname) 'square)) (eq (forty) (funcall (symbol-function fortyname))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-3-GENSYM.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-3-GENSYM.TEST new file mode 100644 index 00000000..02426931 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-GENSYM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: gensym ;; ;; Source: CLtL p. 169 ;; ;; Chapter 10: Symbols Section 1: The Property List ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 5 August 86 ;; ;; Last Update: 17 December 86 Peter Reidy ;; ;; Filed As: {eris}cml>test>10-3-gensym.test ;; ;; Syntax: gensym &optional x ;; ;; Function Description: invents a print name and creates a new symbol with that print name; returns the new, uninterned symbol. ;; ;; Argument(s): x: If a string, the new default prefix (default: G) ;; If an integer, the new counter for suffixes. ;; ;; Returns: the new symbol ;; (do-test-group (gensym-group :before (progn (test-setq digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) prefix #\G nondefprefix "Fallingwater" iter (make-list 10)) ;; Acknowldegements to R. Fischer (test-defun integerpart (&optional (charpart prefix) (symbol (gensym (string charpart)))) "Extract integers from gensym symbol. Default symbol is a new gentemp; default non-integer part is #\G" (car (multiple-value-list (parse-integer (string-trim (string charpart) (symbol-name symbol) ) ) ) ) ) (test-setq defaultcounter (1+ (integerpart))) ) :after ;; Restore the defaults on exit. (prog2 (gensym "G") (gensym defaultcounter)) ) ; gensym-group (do-test "gensyms uninterned" (null (symbol-package (gensym))) ) (do-test "default prefix char G" (char= prefix (char (symbol-name (gensym)) 0)) ) (do-test "after G must be integer part" (integerp (integerpart)) ) (do-test "nothing after integer part" (string= (string prefix) (string-trim digits (symbol-name (gensym)))) ) (do-test "integers should be in sequence; 10 tries" ;; Acknowledgements to Karin Sye. (dolist (dummy iter (eq -1 (- (integerpart) (integerpart))) ) ) ) (do-test "integer argument should reset gensym counter" (gensym 65) ; make sure 47 isn't the next number in sequence (and (= 47 (integerpart prefix (gensym 47))) (= 48 (integerpart prefix (gensym))) (= 49 (integerpart prefix (gensym))) ) ) (do-test "string argument should reset gensym prefix; counter should keep incrementing" (and (= 50 (integerpart nondefprefix (gensym "Fallingwater"))) (string= nondefprefix (string-trim digits (symbol-name (gensym nondefprefix)))) (= 52 (integerpart nondefprefix (gensym "Fallingwater"))) ) ) (do-test "did string argument reset gensym prefix?" (string= nondefprefix (string-trim digits (symbol-name (gensym)))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-3-GENTEMP.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-3-GENTEMP.TEST new file mode 100644 index 00000000..917a078b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-GENTEMP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: gentemp ;; ;; Source: CLtL p. 169 ;; ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 10 July 86 ;; ;; Last Update: 17 December 86 ;; ;; Filed As: {eris}cml>test>10-3-gentemp.test ;; ;; Syntax: gentemp &optional prefix package ;; ;; Function Description: invents a print name consisting of prefix (default: T) and a number, creates a new symbol with that print name and interns in package (default: the current package); returns the new symbol. prefix is in effect for only one call, unlike gensym's, which becomes the new default. ;; ;; Argument(s): prefix: a string ;; package: a package ;; ;; Returns: the new symbol ;; (do-test-group gentemp-group :before (progn (test-setq digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) prefix "T" nondefprefix "Fallingwater" iter (make-list 10) pack1 (make-package (gensym)) pack2 (make-package (gensym)) ) ;; Acknowledgements to R. Fischer (test-defun integerpart (&optional (charpart prefix) (symbol (gentemp (string charpart)))) "Extract the integers from a symbol in gentemp form. Default symbol is a new gentemp; default non-integer part is #\T, the standard gentemp prefix." (car (multiple-value-list (parse-integer (string-trim (string charpart) (symbol-name symbol) ) ) ) ) ) (test-defun maketemps (base limit prefix) "Generate a succession of symbols of form prefix/integer. Base is the first integer, limit is the number of iterations. The integer part will range from base to base+counter-1. E.g. (maketemps 100 10 #\Q) will generate Q100 - Q109." (do ((cnt 0 (1+ cnt))) ((= cnt limit)) ;; Since gentemp creates symbols new IN THE PACKAGE, phony symbols have to be in the package as well; thus the import. (import (make-symbol (concatenate 'simple-string prefix (prin1-to-string (+ base cnt)) ) ) ) ) ) ; test-defun ) ; progn ;; (do-test "default prefix should be T" (char= (character prefix) (char (symbol-name (gentemp)) 0)) ) (do-test "after prefix should be an integer" (integerp (integerpart)) ) (do-test "nothing after integer part" (string= prefix (string-trim digits (symbol-name (gentemp))) ) ) (do-test "integers should be in sequence; 10 tries" ;; Acknowledgements to Karin Sye. ;; Might skip over a previously-used symbol; hence the <=. (dolist (dummy iter (<= -1 (- (integerpart) (integerpart)) ) ) ) ) (do-test "result should be interned" (symbol-package (gentemp)) ) (do-test "interned in *package*" (equal *package* (symbol-package (gentemp))) ) (do-test "created in specified package" (AND (equal pack1 (symbol-package (gentemp prefix pack1))) (equal pack2 (symbol-package (gentemp "pack2" pack2))) ) ; and ) (do-test "prefix should reset once, then go back to default" (AND (string= nondefprefix (string-trim digits (symbol-name (gentemp nondefprefix))) ) (gentemp nondefprefix) (string= prefix (string-trim digits (symbol-name (gentemp))) ) ) ) (do-test "w/default prefix, skip used suffixes" (let ((base (1+ (integerpart))) (limit (1+ (random 100)))) (maketemps base limit prefix) (or ;; maketemps will have used up limit consecutive symbols; gentemp will skip at least that many (> (integerpart) (+ (1- limit) base)) ;; In case of wraparound (<= (integerpart) (1+ base)) ) ) ) (do-test "w/non-default prefix, skip used suffixes" (let ((base (1+ (integerpart))) (limit (1+ (random 100)))) (maketemps base limit prefix) (or ;; maketemps will have used up limit consecutive symbols; gentemp will skip at least that many. (> (integerpart) (+ (1- limit) base)) ;; In case of wraparound (<= (integerpart) (1+ base)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-3-KEYWORDP.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-3-KEYWORDP.TEST new file mode 100644 index 00000000..be1d4ec0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-KEYWORDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: keywordp ;; ;; Source: CLtL p. 170 ;; ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 12 July 86 ;; ;; Last Update: 26 August 86 ;; ;; Filed As: {eris}cml>test>10-3-keywordp.test ;; ;; Syntax: keywordp object ;; ;; Function Description: returns T iff the argument is a symbol and the symbol belongs to the keyword package. ;; ;; Argument(s): object - any lisp object. ;; ;; Returns: T or nil ;; (do-test-group (keywordp-group :before (test-setq *package* *package*) ) ; keywordp-group (do-test "keyword is any symbol starting with a colon" (keywordp :nothing) ) (do-test "all keywords are in the keyword package" (equal (symbol-package :nothing) (find-package 'keyword)) ) (do-test "A keyword is its own value" (and (keywordp ':nothing) (eq :nothing ':nothing) (equal (symbol-package ':nothing) (symbol-package :nothing)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-3-MAKE-SYMBOL.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-3-MAKE-SYMBOL.TEST new file mode 100644 index 00000000..d3323036 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-MAKE-SYMBOL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-symbol ;; ;; Source: CLtL p. 168 ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Creation Date: 28 June 86 Peter Reidy ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>10-3-make-symbol.test ;; ;; Syntax: make-symbol print-name ;; ;; Function Description: creates a new uninterned symbol, whose print name is the string print-name. The value and function bindings will be unbound, and the property list will be empty. ;; ;; Argument(s): print-name - any object whose value is a print name. ;; ;; Returns: the symbol whose print name was the input. ;; (do-test-group make-symbol-group :before (test-setq test-symbol (make-symbol "emblem")) (do-test "should be unbound, without a property list or function, and uninterned" (AND (symbolp test-symbol) (every 'null (list (boundp test-symbol) (symbol-plist test-symbol) (fboundp test-symbol) (symbol-package test-symbol) ) ) ) ) (do-test "symbol-name/make-symbol reciprocity test" (string= "sirnoel" (symbol-name (make-symbol "sirnoel"))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/10/10-3-SYMBOL-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/10/10-3-SYMBOL-PACKAGE.TEST new file mode 100644 index 00000000..5fc0e707 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-SYMBOL-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: symbol-package ;; ;; Source: CLtL p. 170 ;; Chapter 10: Symbols Section 3: Creating Symbols ;; ;; Creation Date: 30 Oct 86 Ron Fischer (rewritten from Peter Reidy's version) ;; ;; Last Update: 17 December 86 ;; ;; Filed As: {eris}cml>test>10-3-symbol-package.test ;; ;; ;; Syntax: symbol-package sym ;; ;; Function Description: returns the contents of sym's package cell, either a package object or nil. ;; ;; Argument(s): sym - a symbol. ;; ;; Returns: a package if sym is interned, nil otherwise. ;; (do-test-group (symbol-package-group :before (test-setq test-symbol (make-symbol "Frivolity")) ) (do-test "fresh symbols have package NIL" (null (symbol-package test-symbol)) ) (do-test "set symbol-package to a package" (progn (setf (symbol-package test-symbol) (find-package 'xcl-test)) (eq (find-package 'xcl-test) (symbol-package test-symbol)) ) ) (do-test "set symbol-package to NIL" (progn (setf (symbol-package test-symbol) nil) (null (symbol-package test-symbol)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-6-IMPORT.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-6-IMPORT.TEST new file mode 100644 index 00000000..e15c3909 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-6-IMPORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: import ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.6 Package System Functions and Variables ;; Page: 186 ;; ;; Created By: Ron Fischer (original file by John Park) ;; ;; Creation Date: Oct 30, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-6-import.test ;; ;; ;; Syntax: (import symbols &optional package) ;; ;; Function Description: The argument should be a list of symbols, or possibly ;; a single symbol. These symbols become internal symbols in package and can ;; therefore be referred to without having to use qualified-name (colon) syntax. ;; import signals a correctable error if any of the imported symbols has the same ;; name as some distinct symbol already accessible in the package. Import returns T. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group (import-group :before (setq im-foo (make-package "IM-BAR" :use nil)) ) (do-test "import returns T" (eq (import '(lisp:rational lisp:plusp) 'im-bar) T) ) (do-test "symbols imported from LISP" (and (eq 'lisp:rational (find-symbol "RATIONAL" 'im-bar)) (eq 'lisp:plusp (find-symbol "PLUSP" 'im-bar)) ) ) (do-test "imported symbols :internal" (and (eq :internal (second (multiple-value-list (find-symbol "RATIONAL" 'im-bar)))) (eq :internal (second (multiple-value-list (find-symbol "PLUSP" 'im-bar)))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-ALL-SYMBOLS.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-ALL-SYMBOLS.TEST new file mode 100644 index 00000000..35563012 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-ALL-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do-all-symbols ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 188 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 28, 1986 ;; ;; Last Update: Mar 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-do-all-symbols.test ;; ;; ;; Syntax: (do-all-symbols (var [result-form]) {declaration}* ;; {tag| statement}* ;; ;; Function Description: This is similar to do-symbols but executes the body once ;; for every symbol contained in every package. (This will not process every ;; symbol whatsoever, because a symbol not accessible in any package.) It is not ;; in general the case that each symbol is processed only once, because a symbol ;; may appear in many packages. ;; ;; ;; Argument(s): var (bound to the symbol) ;; package ;; result-form (a single form) ;; ;; Returns: value of the do-all-symbols form ;; ;; Constraints/Limitations: Since do-all-symbols will executes the body for every ;; symbol contained in every package, this test may take unreasonably a long time. ;; In order to execute this test within a reasonable amount of time (i.e. 5 min) ;; do-all-symbols-test package will stop at the third package of package list. (do-test "do-all-symbols-test" (let ((p3 (third (list-all-packages)))) (catch 'stop-at-third-package (do-all-symbols (s (null s)) (when (and (symbolp s) (eq (symbol-package s) p3)) (throw 'stop-at-third-package t) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-EXTERNAL-SYMBOLS.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-EXTERNAL-SYMBOLS.TEST new file mode 100644 index 00000000..14b3c236 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-EXTERNAL-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do-external-symbols ;; ;; Source: Guy L Steele's CLtL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: Mar 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-do-external-symbols.test ;; ;; ;; Syntax: (do-external-symbols (var [package [result-form]]) {declaration}* ;; {tag| statement}* ;; ;; Function Description: do-external-symbols is just like do-symbols, except that ;; only the external symbols of the specified package are scanned. ;; ;; ;; Argument(s): var (bound to the symbol) ;; package ;; result-form (a single form) ;; ;; Returns: value of the do-external-symbols form ;; ;; Constraints/Limitations: none (do-test "do-external-symbols" (let* ((package (make-package "DO-EXTERNAL-PACKAGE" :use NIL)) (external-names '("EXTERNAL-FOO" "EXTERNAL-BAR" "EXTERNAL-BAZ")) (internal-names '("FOO" "BAR" "BAZ")) (external-symbols) ) (dolist (name (append external-names internal-names)) (intern name package) ) (dolist (name external-names) (let ((symbol (intern name package))) (export symbol package) (push symbol external-symbols) ) ) (and (let ((checking external-symbols)) (do-external-symbols (s package (and (null s) (null checking))) (if (and (symbolp s) (member s checking :test #'string=)) (setq checking (remove s checking :test #'string=)) (return nil) ) ) ) (delete-package "DO-EXTERNAL-PACKAGE") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-SYMBOLS.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-SYMBOLS.TEST new file mode 100644 index 00000000..ccb0531a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-DO-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do-symbols ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 185 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: March 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-do-symbols.test ;; ;; ;; Syntax: (do-symbols (var [package [result-form]]) {declaration}* ;; {tag| statement}* ;; ;; Function Description: do-symbols provides straightforward iteration over the ;; symbols of a package. The body is performed once for each symbol accessible ;; in the package, in no particular order, with the variable var bound to the ;; symbol. Then result-form (a single form, not an implicit progn) is evaluated, ;; and the result is the value of the do-symbols form. (When the result-form is ;; evaluated, the control variable var is still bound and has the value of nil.) ;; If the result-form is omitted, the result is nil. return may be used to terminate ;; the iteration prematurely. If execution of the body affects which symbols are ;; contained in the package, other than possibly to remove the symbol currently ;; the value of var by using unintern, the effects are unpredictable. ;; ;; ;; Argument(s): var (bound to the symbol) ;; package ;; result-form (a single form) ;; ;; Returns: value of the do-symbols form ;; ;; Constraints/Limitations: none ;; ;; Test description: creates two packages, one inherited by the other. Interns a ;; small number of known symbols in both packages. For each package we remember the ;; list of symbols expected to be found there and then do-symbols over the package. ;; At each iteration we remove the name we found there. NIL is returned if either ;; an unknown symbol is found in the package or not all the symbols are found. (do-test "do-symbols" (let* ((inherited-package (make-package "INHERITED-PACKAGE" :use NIL)) (direct-package (make-package "DIRECT-PACKAGE" :use "INHERITED-PACKAGE")) (direct-symbols '("FOO" "BAR" "BAZ" "GLORP")) (inherited-symbols '("IFOO" "IBAR" "IBAZ" "IGLORP")) ) (dolist (name direct-symbols) (intern name direct-package)) (dolist (name inherited-symbols) (export (intern name inherited-package) inherited-package) ) (and (let ((checking inherited-symbols)) (do-symbols (s inherited-package (and (null s) (null checking))) (if (and (symbolp s) (member s checking :test #'string=)) (setq checking (remove s checking :test #'string=)) (return nil) ) ) ) (let ((checking (append inherited-symbols direct-symbols))) (do-symbols (s direct-package (and (null s) (null checking))) (if (and (symbolp s) (member s checking :test #'string=)) (setq checking (remove s checking :test #'string=)) (return nil) ) ) ) (delete-package "INHERITED-PACKAGE") (delete-package "DIRECT-PACKAGE") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-EXPORT.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-EXPORT.TEST new file mode 100644 index 00000000..a3e1e450 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-EXPORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: export ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 186 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 6, 1986 ;; ;; Last Update: Oct 21, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-export.test ;; ;; ;; Syntax: (export symbols &optional package) ;; ;; Function Description: The function export takes a symbol that is accessible in some ;; specified package (directly or by inheritance) and makes it an external symbol of ;; that package. If the symbol is already accessible as an external symbol in the ;; package, export has no effect. If the symbol is directly present in the package as ;; an internal symbol via use-package, the symbol is first imported into the package, ;; then exported. (The symbol is then present in the specified package whether or not ;; the package continues to use the package through which the symbol was originally ;; inherited.) If the symbol is not accessible at all in the specified package, ;; a correctable error is signalled that, upon continuing, asks the user whether the ;; symbol should be imported. By convention, a call to export listing all exported ;; symbols is placed near the start of a file to advertise which of the symbols ;; mentioned ;; in the file are intended to be used by other programs. ;; ;; ;; Argument(s): symbols (list or a single symbol) ;; package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none ;; (do-test "export-test" (and (import '(lisp:machine-type) 'USER) (let ((SYM1 (intern "MACHINE-TYPE" 'USER))) (and (eq SYM1 'USER::MACHINE-TYPE) (eq :internal (second (multiple-value-list (find-symbol "MACHINE-TYPE" 'USER)))) ) ) (eq (export '(USER::MACHINE-TYPE) 'USER) T) (let ((SYM2 (intern "MACHINE-TYPE" 'USER))) (and (eq SYM2 'USER::MACHINE-TYPE) (eq :external (second (multiple-value-list (find-symbol "MACHINE-TYPE" 'USER)))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-ALL-SYMBOLS.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-ALL-SYMBOLS.TEST new file mode 100644 index 00000000..3ff17cad --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-ALL-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-all-sym\bols ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 22, 1986 ;; ;; Last Update: Nov 6, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-find-all-symbols.test ;; ;; ;; Syntax: (find-all-symbols string-or-symbol) ;; ;; Function Description: This function searches every package in the LISP system ;; for symbols whose print-name is the specified string, and returns a list of ;; such symbols. If a symbol is specified, its print name is used. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: list of symbols ;; ;; Constraints/Limitations: none (do-test "find-all-symbols" (and (member 'SETQ (find-all-symbols "SETQ")) (member 'MAP (find-all-symbols 'MAP)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-PACKAGE.TEST new file mode 100644 index 00000000..f229d7df --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 183 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 16,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-find-package.test ;; ;; ;; Syntax: (find-package name) ;; ;; Function Description: This function returns the package with specified name or ;; nickname. ;; ;; Argument(s): The name must be a string that is the name or nickname for a package. ;; This argument may also be a symbol, in which case the symbol's print name is used. ;; ;; Returns: package-name ;; ;; Constraints/limitations: None (do-test-group (find-package-test-setup :before (progn (setq test-package1 (make-package "test-1")) (setq test-package2 (make-package "test-2" :nicknames '("system" "module"))))) (do-test "make-package" (and (eq (find-package "test-1") test-package1) (eq (find-package "test-2") test-package2) (eq (find-package "system") test-package2) (eq (find-package "module") test-package2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-SYMBOL.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-SYMBOL.TEST new file mode 100644 index 00000000..cee00adc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-FIND-SYMBOL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-symbol ;; ;; Source: Guy L Steele's CLTL Package System ;; Section: 11.8 Package System and Variables ;; Page: 185 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 10, 1986 ;; ;; Last Update: Nov 6, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-find-symbol.test ;; ;; ;; Syntax: (find-symbol string &optional package) ;; ;; Function Description: This is identical to intern, but it never creates a new ;; symbol. If a symbol with the specified name is found in the specified package, ;; directly or by inheritance, the symbol found is returned as the first value and ;; the second value is as specified for intern. If the symbol is not accessible ;; in the specified package, both values are nil. ;; ;; ;; ;; Argument(s): string ;; package (&optional) ;; ;; ;; Returns: Two values (symbol and symbol status) if symbol if found. ;; or NIL if symbol is not found. ;; ;; Constraints/Limitations: None ;; (do-test "find-symbol-test" (and (let ((find-sym-list (multiple-value-list (find-symbol "COS" (FIND-PACKAGE 'USER))))) (and (eq (first find-sym-list) 'COS) (eq :INHERITED (second find-sym-list)) ) ) (intern "XYZ" 'USER) (let ((find-sym-list-1 (multiple-value-list (find-symbol "XYZ" (FIND-PACKAGE 'USER))))) (and (eq (first find-sym-list-1) 'USER::XYZ) (eq :INTERNAL (second find-sym-list-1)) ) ) (eq (find-symbol "JUNK" (find-package 'KEYWORD)) NIL) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-IMPORT.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-IMPORT.TEST new file mode 100644 index 00000000..d9287be0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-IMPORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: import ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 186 ;; ;; Created By: Ron Fischer (original file by John Park) ;; ;; Creation Date: Oct 30, 1986 ;; ;; Last Update: March 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-import.test ;; ;; ;; Syntax: (import symbols &optional package) ;; ;; Function Description: The argument should be a list of symbols, or possibly ;; a single symbol. These symbols become internal symbols in package and can ;; therefore be referred to without having to use qualified-name (colon) syntax. ;; import signals a correctable error if any of the imported symbols has the same ;; name as some distinct symbol already accessible in the package. Import returns T. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group (import-group :before (setq im-foo (make-package "IMPORT-BAR" :use nil)) :after (delete-package "IMPORT-BAR") ) (do-test "import returns T" (eq (import '(lisp:rational lisp:plusp) 'IMPORT-bar) T) ) (do-test "symbols imported from LISP" (and (eq 'lisp:rational (find-symbol "RATIONAL" 'IMPORT-bar)) (eq 'lisp:plusp (find-symbol "PLUSP" 'IMPORT-bar)) ) ) (do-test "imported symbols :internal" (and (eq :internal (second (multiple-value-list (find-symbol "RATIONAL" 'IMPORT-bar)))) (eq :internal (second (multiple-value-list (find-symbol "PLUSP" 'IMPORT-bar)))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-IN-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-IN-PACKAGE.TEST new file mode 100644 index 00000000..a93f66b9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-IN-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: in-package ;; ;; Source: Guy L Steele's CLTL Package System ;; Section: 11.7 Package System and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 7, 1986 ;; ;; Last Update: Oct 16, 86 ;; ;; Filed As: {ERIS}CML>TEST>11-7-in-package.test ;; ;; ;; Syntax: (in-package package-name &key :nicknames :use) ;; ;; Function Description: This function is intended to be placed at the start of a ;; file containing a subsystem that is to be loaded into some package other than ;; USER. If there is not already a package with the specified name, one is created ;; as with make-package. If there is an existing package, it is augumented to ;; reflect any new nicknames or used packages. ;; ;; ;; Argument(s): package-name: string or symbol ;; nicknames (key): list of string(s) ;; use: list of string(s) or symbol(s) ;; ;; ;; Returns: package-name or nil ;; ;; Constraints/Limitations: This file may be similar to other files that test ;; package functions as a file may use the following or combinations of the ;; following forms: ;; (provide ...) ;; (in-package...) ;; (shadow...) ;; (export...) ;; (require...) ;; (use-package...) ;; (import...) ;; (do-test "in-package" (and (boundp '*package*) (in-package 'foo0 :use 'user) (eq *package* (find-package 'foo0)) (in-package 'lisp) (eq *package* (find-package 'lisp)) (in-package 'user) (eq *package* (find-package 'user)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-INTERN.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-INTERN.TEST new file mode 100644 index 00000000..70673c12 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-INTERN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: intern ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 17, 1986 ;; ;; Last Update: JAN 14, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-intern.test ;; ;; ;; Syntax: (intern string &optional package) ;; ;; Function Description: The package, which defaults to the current package, is ;; searched for a symbol with the name specified by the string argument. This search ;; will include inherited symbols, as described in section 11.4. If a symbol with ;; the specified name is found, it is returned. If no such symbol is found, one is ;; created and is installed in the specified package as an internal symbol ;; (as an external symbol if the package is the keyword package)- the specified ;; package becomes the home package of the created symbol. ;; ;; Argument(s): package ;; ;; Returns: Two values: The first is the symbol that was found or created. ;; The second value is nil if no pre-existing symbol was found, and takes on one of ;; three values if a symbol was found: ;; ;; :internal - The symbol was directly present in the package as an internal symbol. ;; :external - The symbol was directly present as an external symbol. ;; :inherited - The symbol was inherited via use-package (which implies that the ;; symbol is internal. ;; ;; Constraints/Limitations: none (do-test "intern-test-internal" ;; Also test import function. (and (eq :inherited (second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER)))) (import '(lisp:software-type) 'USER) (let ((SYM (intern "SOFTWARE-TYPE" 'USER))) (and (eq SYM 'USER::SOFTWARE-TYPE) (eq :internal (second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER)))) ) ) ) ) (do-test "intern-test-external" ;; Also test export function. (and (export '(USER::SOFTWARE-TYPE) 'USER) (eq :external (second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER)))) (unintern 'SOFTWARE-TYPE 'USER) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-LIST-ALL-PACKAGES.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-LIST-ALL-PACKAGES.TEST new file mode 100644 index 00000000..7db42315 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-LIST-ALL-PACKAGES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: list-all-packages ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 15, 1986 ;; ;; Last Update: Oct 21, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-list-all-packages.test ;; ;; ;; Syntax: (list-all-packages) ;; ;; Function Description: A list of other packages that currently exist in ;; the lisp system. ;; ;; Argument(s): none ;; ;; ;; Returns: List of packages ;; ;; Constraints/Limitations: none (do-test "list-all-packages-test" (and (member (find-package 'LISP) (list-all-packages)) (member (find-package 'SYSTEM) (list-all-packages)) (member (find-package 'KEYWORD) (list-all-packages)) (member (find-package 'USER) (list-all-packages)) (make-package "FOO-PACK") (member (find-package 'FOO-PACK) (list-all-packages)) (notany #'null (mapcar #'packagep (list-all-packages))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-MAKE-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-MAKE-PACKAGE.TEST new file mode 100644 index 00000000..e6f11fbd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-MAKE-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 183 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 13,1986 ;; ;; Last Update: Oct 17, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-make-package.test ;; ;; ;; Syntax: (make-package package-name &key :nicknames :use) ;; ;; Function Description: This function creates and returns a new package with the ;; specified package name. ;; ;; Argument(s): package-name: string or symbol ;; nicknames: list of strings to be used as alternative names ;; for the package ;; use: list of packages or the names (strings or symbols) of ;; packages whose external symbols are to be inherited by ;; the new package. ;; ;; Returns: package-name ;; (do-test "*package*-exists?" (and (boundp '*package*) (packagep *package*) ) ) (do-test "make-package-test1" (and (make-package "PACK-EX") (make-package "PACK-WY") (make-package 'PACK-ZEE) (not(eq (member (find-package 'PACK-EX)(list-all-packages)) NIL)) (not (eq (member (find-package 'PACK-WY)(list-all-packages)) NIL)) (not (eq (member (find-package 'PACK-ZEE)(list-all-packages)) NIL)) (if (fboundp 'delete-package) (progn (delete-package (find-package 'PACK-EX)) (delete-package (find-package 'PACK-WY)) (delete-package (find-package 'PACK-ZEE)) (identity T) ; T is returned when a package is deleted ) T) ) ) (do-test "make-package-test2" (and (make-package "NEW-PACK" :nicknames '("NP1" "NP2") :use 'LISP) (member (find-package 'lisp) (package-use-list (find-package 'new-pack))) (or (equal (package-nicknames (find-package 'new-pack)) '("NP2" "NP1")) (equal (reverse (package-nicknames (find-package 'new-pack))) '("NP2" "NP1")) ) (if (fboundp 'delete-package) ; delete the package (progn (delete-package (find-package 'new-pack)) (identity T) ) T) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NAME.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NAME.TEST new file mode 100644 index 00000000..45e5228e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NAME.TEST @@ -0,0 +1 @@ + ;; Function To Be Tested: package-name ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 13,1986 ;; ;; Last Update: Dec 15, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-name.test ;; ;; ;; Syntax: (package-name package) ;; ;; Function Description: This function returns the string that names that ;; package. ;; ;; Argument(s): package-name ;; ;; Returns: string that names that package ;; ;; Constraints/Limitations: none (do-test "package-name-test" (and (setq PACKAGE-A (make-package "FIRST-PACK")) (setq PACKAGE-B (make-package "SECOND-PACK")) (equal (package-name PACKAGE-A) "FIRST-PACK") (equal (package-name PACKAGE-B) "SECOND-PACK") (equal (package-name (find-package 'USER)) "USER") (equal (package-name (find-package 'LISP)) "LISP") (stringp (package-name *package*)) (if (fboundp 'delete-package) (progn (delete-package package-a) (delete-package package-b) (identity T) ) T) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NICKNAMES.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NICKNAMES.TEST new file mode 100644 index 00000000..d10337fe --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-NICKNAMES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: package-nicknames ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Creation Date: Aug 13,1986 John Park ;; ;; Last Update: March 24, 1987 Ron Fischer ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-nicknames.test ;; ;; ;; Syntax: (package-nicknames package) ;; ;; Function Description: This function returns the list of nickname strings for ;; that package. ;; ;; Argument(s): package ;; ;; Returns: nicknames for the package ;; ;; Constraints/Limitations: Checks to be sure that the SYSTEM package has nickname SYS. ;; Does generic check that nicknames are on the nickname list and also makes sure that ;; any prefix-name becomes a nickname. (do-test "package-nicknames-test" (and (some #'(lambda (name) (string= name "SYS")) (package-nicknames 'system) ) (make-package "ALCHEMY" :prefix-name "ALCHEM" :nicknames '("METALS" "GOLD")) (every #'(lambda (name) (member name '("GOLD" "METALS" "ALCHEM") :test #'string=)) (package-nicknames 'alchemy) ) (delete-package 'alchemy) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST new file mode 100644 index 00000000..97f76cce --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: package-shadowing-symbols ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 183 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 23, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-shadowing-symbols.test ;; ;; ;; Syntax: (package-shadowing-symbols package) ;; ;; Function Description: A list is returned of symbols that have been declared as ;; shadowing symbols in this package by shadow or shadowing-import. All symbols ;; on this list are present in the specified package. ;; ;; Argument(s): package ;; ;; Returns: A list of symbols declared as shadowing symbols ;; ;; Constraints/Limitations: none (do-test "package-shadowing-symbols-test" (and (setq barr2 (in-package "BAZ2")) (lisp:in-package 'lisp) (member (find-package 'LISP) (package-use-list barr2)) (setq blap2 (in-package "FRUMBLE2" :use NIL)) (lisp:in-package 'lisp) (use-package blap2 barr2) (intern "HURM" blap2) (intern "OK" blap2) (shadow '(HURM OK) barr2) (equal (mapcar #'string (package-shadowing-symbols (find-package 'baz2))) '("OK" "HURM")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USE-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USE-LIST.TEST new file mode 100644 index 00000000..6427cb03 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USE-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: package-use-list ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 14,1986 ;; ;; Last Update: Oct 22, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-use-list.test ;; ;; ;; Syntax: (package-use-list package) ;; ;; Function Description: A list of other packages used by thae argument package ;; is returned. ;; ;; Argument(s): package ;; ;; Returns: package(s) ;; ;; Constraints/Limitations: none (do-test "package-use-test" (and (setq use-package-1 (make-package "USE-PACK-1")) (member (find-package 'lisp) (package-use-list use-package-1)) (setq use-package-2 (make-package "USE-PACK-2" :use 'SYSTEM)) (member (find-package 'system) (package-use-list use-package-2)) (setq foo-package-1 (make-package "FOO-PACK-1" :use NIL)) (eq (package-use-list foo-package-1) nil) (setq foo-package-2 (make-package "FOO-PACK-2")) (use-package '(use-pack-1 use-pack-2) 'FOO-PACK-2) (member (find-package 'use-pack-1) (package-use-list foo-package-2)) (member (find-package 'use-pack-2) (package-use-list foo-package-2)) (member (find-package 'lisp) (package-use-list foo-package-2)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USED-BY-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USED-BY-LIST.TEST new file mode 100644 index 00000000..b35e8100 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-PACKAGE-USED-BY-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: package-used-by-list ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 15, 1986 ;; ;; Last Update: Dec 22, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-package-used-by-list.test ;; ;; ;; Syntax: (package-used-by-list package ) ;; ;; Function Description: A list of other packages that use the argument package ;; is returned. ;; ;; Argument(s): package ;; ;; ;; Returns: List of packages ;; ;; Constraints/Limitations: none (do-test "package-used-by-list" (and (member (find-package 'USER) (package-used-by-list (find-package 'LISP))) (eq (package-used-by-list (find-package 'KEYWORD)) NIL) (make-package 'XYZ :use '("USER" "SYSTEM")) (member (find-package 'XYZ) (package-used-by-list (find-package 'USER))) (member (find-package 'XYZ) (package-used-by-list (find-package 'SYSTEM))) (if (fboundp 'delete-package) (progn (delete-package (find-package 'XYZ)) (identity T) ) T) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-RENAME-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-RENAME-PACKAGE.TEST new file mode 100644 index 00000000..16f94ec3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-RENAME-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: rename-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 14,1986 ;; ;; Last Update: Dec 16, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-rename-package.test ;; ;; ;; Syntax: (rename-package package new-name &optional new-nicknames) ;; ;; Function Description: The old name and all of the old nicknames of package ;; are eliminated and are replaced by new-name and new-nicknames. ;; ;; Argument(s): package ;; new-name: string or symbol ;; new-nicknames: list of strings or symbols ;; ;; Returns: nicknames for the package ;; ;; Constraints/Limitations: none (do-test "rename-package" (let ((test-package-1 (make-package 'old-package-1)) (test-package-2 (make-package 'old-package-2 :nicknames '("OLD-FOO" "OLD-BAR")))) (and (rename-package test-package-1 "NEW-PACKAGE-1") (rename-package test-package-2 "NEW-PACKAGE-2" '("NEW-FOO" "NEW-BAR")) (equal (package-name test-package-1) "NEW-PACKAGE-1") (equal (package-name test-package-2) "NEW-PACKAGE-2") (or (equal (package-nicknames test-package-2) '("NEW-BAR" "NEW-FOO")) (equal (reverse (package-nicknames test-package-2)) '("NEW-BAR" "NEW-FOO")) ) (not (member (find-package 'old-package-1) (list-all-packages))) (not (member (find-package 'old-package-2) (list-all-packages))) (if (fboundp 'delete-package) (progn (delete-package (find-package 'new-package-1)) (delete-package (find-package 'new-package-2)) (identity T) ) T) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOW.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOW.TEST new file mode 100644 index 00000000..87441938 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOW.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: shadow ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 185 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 22, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-shadow.test ;; ;; ;; Syntax: (shadow symbols &optional package) ;; ;; Function Description: This function extracts the print name of each symbol and ;; searches the package (defaulting to the current package) for a symbol with that ;; name. If such a symbol is directly present in the package, then nothing is done. ;; Otherwise, a new symbol is created with the print name, and it is inserted in the ;; package as an internal symbol. The symbol is also placed on the shadowing symbols ;; list of the package. ;; ;; ;; Argument(s): symbol(s) package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test "unintern" (and (setq barr1 (make-package "BAZ1")) (member (find-package 'LISP) (package-use-list barr1)) (setq blap1 (make-package "FRUMBLE1" :use NIL)) (use-package blap1 barr1) (set (intern "HURM1" blap1) 52) (shadow 'HURM1 barr1) (not (boundp (intern "HURM1" barr1))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOWING-IMPORT.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOWING-IMPORT.TEST new file mode 100644 index 00000000..0ccbff6a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOWING-IMPORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: shadowing-import ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 186 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: Oct 29, 1986 ;; ;; Last Update: March 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-shadowing-import.test ;; ;; ;; Syntax: (shadowing-import symbols &optional package) ;; ;; Function Description: This is like import, but it does not signal an error even ;; if the importation of a symbol would shadow some symbol already accessible in ;; the package. In additionto being imported, the symbol is placed on the ;; shadowing-symbols list of package. ;; ;; Argument(s): Symbol(s) ;; Package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group (package-shadowing-symbols-group :before (progn (make-package 'inherited :use nil) (make-package 'direct :use 'inherited) (export (intern "CAR" 'inherited) 'inherited) ) :after (progn (delete-package 'direct) (delete-package 'inherited) ) ) (do-test "import causes error on conflict" (expect-errors import-conflict (import '(lisp:car) 'direct) ) ) (do-test "shadowing-import doesn't cause error on conflict" (shadowing-import '(lisp::car) 'direct) ) (do-test "shadowing symbol on package's list" (member 'lisp::car (package-shadowing-symbols 'direct)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-UNEXPORT.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNEXPORT.TEST new file mode 100644 index 00000000..65653fb4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNEXPORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unexport ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 186 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 21, 1986 ;; ;; Last Update: Dec 22, 1986 ;; ;; Filed As: {ERIS}CML>TEST>11-7-unexport.test ;; ;; ;; Syntax: (unexport symbols &optional package) ;; ;; Function Description: The function unexport is provided mainly as a way to undo ;; erroneous calls to export. It works only on symbols directly present in the current ;; package, switching them back to internal status. If unexport is given a symbol ;; already accessible as an internal symbol in the current package, it does nothing. ;; If it is given a symbol not accessible in the package at all, it signals an error. ;; It is also an error to unexport a symbol from the keyword package. ;; ;; ;; Argument(s): symbols (list or a single symbol) ;; package (optional) ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test "unexport-test-1" (and (import 'new-symbol) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL")))) (export 'new-symbol) (equal :EXTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL")))) (eq (unexport '(NEW-SYMBOL)) T) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL")))) ) ) (do-test "unexport-test-2" (let ((*test-package* (find-package 'lisp))) (and (import 'new-symbol-xyz *test-package*) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL-XYZ" *test-package*)))) (export 'new-symbol-xyz *test-package*) (equal :EXTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL-XYZ" *test-package*)))) (eq (unexport '(NEW-SYMBOL-XYZ) *test-package*) T) (equal :INTERNAL (second (multiple-value-list (find-symbol "NEW-SYMBOL-XYZ" *test-package*)))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-UNINTERN.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNINTERN.TEST new file mode 100644 index 00000000..b8c2c190 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNINTERN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unintern ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 185 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: Oct 22, 1986 ;; ;; Last Update: Mar 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-7-unintern.test ;; ;; ;; Syntax: (unintern string &optional package) ;; ;; Function Description: If the specified symbol is present in the specified package, ;; it is removed from that package and also from the package's shadowing-symbols list ;; if it is present there. Moreover, if the package is the home package for the symbol, ;; the symbol is made to have no home package. Note that in some circumstances the ;; symbol may continue to be accessible in the specified package by inheritance. ;; ;; ;; Argument(s): package ;; ;; Returns: unintern returns t if it actually removed a symbol, and nil otherwise. ;; ;; Constraints/Limitations: none (do-test-group ("unintern" :before (progn (make-package 'hurm :use nil) (intern "HURM" 'hurm) ) :after (delete-package 'hurm) ) (do-test "symbol interned" (and (string= "HURM" (find-symbol "HURM" 'hurm)) (eq :internal (second (multiple-value-list (find-symbol "HURM" 'hurm))) ) ) ) (do-test "uninterning symbol" (unintern (find-symbol "HURM" 'hurm) 'hurm) ) (do-test "unintern returns NIL for symbol not in package" (null (unintern 'lisp:car 'hurm)) ) (do-test "symbol uninterned" (null (find-symbol "HURM" 'hurm)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-UNUSE-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNUSE-PACKAGE.TEST new file mode 100644 index 00000000..73cec8a4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNUSE-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unuse-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 15, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-unuse-package.test ;; ;; ;; Syntax: (unuse-package packages-to-unuse &optional package) ;; ;; Function Description: This function removes the packages-to-unuse from the ;; use-list of the specified package, which defaults to the current package. ;; The pacakges-to-unuse can be a package or package name, or a list of such. ;; ;; Argument(s): packages-to-unuse: list of packages or package names. ;; package (&optional) ;; ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test "unuse-package-test" (and (setq foo2 (make-package "BAR2" :use nil)) (eq (package-use-list foo2) nil) (eq (use-package 'lisp 'bar2) T) (member (find-package 'lisp) (package-use-list foo2)) (eq (unuse-package 'lisp 'bar2) T) (not (member (find-package 'lisp) (package-use-list foo2))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-7-USE-PACKAGE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-7-USE-PACKAGE.TEST new file mode 100644 index 00000000..473ced46 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-USE-PACKAGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: use-package ;; ;; Source: Guy L Steele's CLTL ;; Section: 11.7 Package System Functions and Variables ;; Page: 187 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 15, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>11-7-use-package.test ;; ;; ;; Syntax: (use-package packages-to-use &optional package) ;; ;; Function Description: The packages-to-use argument should be a list of packages ;; or package names, or possibly a single package or package name. These packages ;; are added to the use-list of package if they are not there already. All external ;; symbols in the packages to use become accessible in package as internal symbols. ;; ;; Argument(s): packages-to-use: list of packages or package names. ;; package (&optional) ;; ;; ;; Returns: t ;; ;; Constraints/Limitations: none (do-test "use-package-test" (and (setq foo1 (make-package "BAR" :use nil)) (eq (package-use-list foo1) nil) (eq (use-package 'lisp 'bar) T) (not (eq (member (find-package 'lisp) (package-use-list foo1)) NIL)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/11/11-8-PROVIDE.TEST b/internal/test/LANGUAGE/from-sun/language/11/11-8-PROVIDE.TEST new file mode 100644 index 00000000..ac656502 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/11/11-8-PROVIDE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: provide ;; ;; Source: Guy L Steele's CLTL Package System ;; Section: 11.8 Package System and Variables ;; Page: 188 ;; ;; ReCreated By: Ron Fischer ;; ;; Creation Date: Oct 7, 1986 ;; ;; Last Update: Mar 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>11-8-provide.test ;; ;; ;; Syntax: (provide module-name) ;; ;; Function Description: This function is called to indicate that the specified ;; module is being loaded. Its name, which can be a string or symbol, is added ;; to the list of modules maintained in the special variable *modules* ;; ;; ;; Argument(s): module-name ;; ;; Returns: T ;; ;; Constraints/Limitations: Checks that members of *modules* are strings and that the ;; insertion of elements is case sensitive. (do-test-group (do-test "*modules*-exist?" (boundp '*modules*) ) (do-test "elements of *modules* are strings" (let ((*modules* nil)) (provide 'foo) (every #'stringp *modules*) ) ) (do-test "provide-test" (let ((*modules* nil)) (provide 'foo) (provide "Bar") (and (member "FOO" *modules* :test #'string=) (member "Bar" *modules* :test #'string=) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-10-IMPLEMENTATION-PARAMETERS.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-10-IMPLEMENTATION-PARAMETERS.TEST new file mode 100644 index 00000000..a9161124 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-10-IMPLEMENTATION-PARAMETERS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: implementation-parameters ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 17, 86 ;; ;; Last Update: Aug 21, 86 ;; ;; Filed as: {eris}cml>test>12-6-implementation-parameters.test ;; ;; Syntax: ;; ;; Function Description: This file tests to determine if the following constants ;; are defined. They may be useful for parameterizing code in some situations. ;; Constants defined: ;; most-positive-fixnum, most-negative-fixnum, most-positive-short-float, ;; least-positive-short-float, least-negative-short-float, ;; most-negative-short-float, most-positive-single-float, ;; least-positive-single-float, least-negative-single-float, ;; most-negative-single-float, most-positive-double-float, ;; least-positive-double-float, least-negative-double-float, ;; most-negative-double-float, most-positive-long-float, ;; least-positive-long-float, least-negative-long-float, ;; most-negative-long-float, short-float-epsilon, ;; single-float-epsilon, double-float-epsilon, long-float-epsilon, ;; short-float-negative-epsilon, single-float-negative-epsilon, ;; double-float-negative-epsilon, and long-float-negative-epsilon ;; ;; ;; Argument(s): ;; ;; Returns: constant value ;; ;; Constraints/limitations: None (do-test-group group-constants :before (progn (setf implementation-parameters '(most-positive-fixnum most-negative-fixnum most-positive-short-float least-positive-short-float least-negative-short-float most-negative-short-float most-positive-single-float least-positive-single-float least-negative-single-float most-negative-single-float most-positive-double-float least-positive-double-float least-negative-double-float most-negative-double-float most-positive-long-float least-positive-long-float least-negative-long-float most-negative-long-float short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon)) (setf parameter-values (mapcar #'eval implementation-parameters))) (do-test implementation-parameters-exist? (and (every #'boundp implementation-parameters) (every #'numberp parameter-values)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TEST new file mode 100644 index 00000000..46401116 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EVENP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-EVENP.TEST ;; ;; ;; Syntax: (EVENP NUMBER &OPTIONAL MODULUS) ;; ;; Function Description: ;; This predicate is true if the argument INTEGER is even (divisible ;; by two), and otherwise is false. It is an error if the argument is not ;; an integer. ;; ;; Argument(s): NUMBER - a number ;; MODULUS - an integer ;; ;; Returns: T or NIL ;; (do-test evenp-test (and (evenp 2) (evenp -4) (not (evenp 3)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TST b/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TST new file mode 100644 index 00000000..8cd3ad9f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TST @@ -0,0 +1 @@ +;; Source: Steel's Book, Chapter 12, Section 2, page 196 ;; Created by: John Park ;; Creation Date: May 1, 86 ;; Predicate: The evenp predicate is true if integer is even and is false otherwise. ;; Syntax Format: (evenp integer) ;; Input: integer ;; Output: T or NIL (do-test evenp-test (and (evenp 2) (evenp -4) (not (evenp 3)) (not (evenp 0)) (not (evenp 10.0)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TEST new file mode 100644 index 00000000..fcc37363 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MINUSP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-MINUSP.TEST ;; ;; ;; Syntax: (MINUSP NUMBER) ;; ;; Function Description: ;; This predicate is true if NUMBER is strictly less than zero, ;; and is false otherwise. ;; Regardless of whether an implementation provides distinct representations ;; for positive and negative floating-point zeros, ;; (MINUSP -0.0) is always false. ;; (The function function FLOAT-SIGN may be used to distinguish a negative zero.) ;; It is an error if the argument NUMBER is not a non-complex number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: T or NIL ;; (do-test minusp-test (and (minusp -1) (minusp -4.0) (minusp -79) (not (minusp -0.0)) (not (minusp 1000)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TST b/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TST new file mode 100644 index 00000000..6c4bff4d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TST @@ -0,0 +1 @@ +;: Test File for Function: plusp ;; Source: Steel's Book, Chapter 12, Section 2, page 196 ;; Created by: John Park ;; Creation Date: May 1, 86 ;; Predicate: The minus predicate is true if number is less than zero and false otherwise. ;; Syntax Format: (minusp number) ;; Input: number (negative number or non-complex number) ;; Output: T or NIL (do-test minusp-test (and (minusp -1) (minusp -4.0) (minusp -79) (not (minusp -0.0)) (not (minusp 1000)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TEST new file mode 100644 index 00000000..5248b9d0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ODDP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-ODDP.TEST ;; ;; ;; Syntax: (ODDP NUMBER &OPTIONAL MODULUS) ;; ;; Function Description: ;; This predicate is true if the argument INTEGER is odd (not divisible ;; by two), and otherwise is false. It is an error if the argument is not ;; an integer. ;; ;; Argument(s): NUMBER - a number ;; MODULUS - an integer ;; ;; Returns: T or NIL ;; (do-test oddp-test (and (oddp 3) (oddp -7) (not (oddp 0)) (not (oddp 4)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TST b/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TST new file mode 100644 index 00000000..51b4b162 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TST @@ -0,0 +1 @@ +;: Test File for Function: oddp ;; Source: Steel's Book, Chapter 12, Section 2, page 196 ;; Created by: John Park ;; Creation Date: May 1, 86 ;; Predicate: The oddp predicate is true if integer is odd and otherwise false. ;; Syntax Format: (oddp integer) ;; Input: odd integer ;; Output: T or NIL (do-test oddp-test (and (oddp 3) (oddp -7) (not (oddp 0)) (not (oddp 4)) (not (oddp 3.0)) (not (oddp -3.0)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TEST new file mode 100644 index 00000000..53916c0b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PLUSP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-PLUSP.TEST ;; ;; ;; Syntax: (PLUSP NUMBER) ;; ;; Function Description: ;; This predicate is true if NUMBER is strictly greater than zero, ;; and is false otherwise. ;; It is an error if the argument NUMBER is not a non-complex number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: T or NIL ;; (do-test plusp-test (and (plusp 1) (plusp 4.0) (plusp +79) (not (plusp 0)) (not (plusp -9)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TST b/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TST new file mode 100644 index 00000000..2c0203bc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TST @@ -0,0 +1 @@ +;: Test File for Function: plusp ;; Source: Steel's Book, Chapter 12, Section 2, page 196 ;; Created by: John Park ;; Creation Date: May 1, 86 ;; Predicate: The plus predicate is true if number is greater than zero and false otherwise. ;; Syntax Format: (plusp number) ;; Input: number (positive number or non-complex number) ;; Output: T or NIL (do-test plusp-test (and (plusp 1) (plusp 4.0) (plusp +79) (not (plusp 0)) (not (plusp -9)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TEST new file mode 100644 index 00000000..87266fe5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ZEROP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 195 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-ZEROP.TEST ;; ;; ;; Syntax: (ZEROP NUMBER) ;; ;; Function Description: ;; This predicate is true if NUMBER is zero (either the integer zero, ;; a floating-point zero, or a complex zero), and is false otherwise. ;; Regardless of whether an implementation provides distinct representations ;; for positive and negative floating-point zeros, ;; (ZEROP -0.0) is always true. ;; It is an error if the argument NUMBER is not a number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: T or NIL ;; (do-test zerop-test (and (zerop 0) (zerop 0.0) (zerop -0.0) (zerop -0) (not (zerop 1)) (not (zerop -2.8)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TXT b/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TXT new file mode 100644 index 00000000..3a135355 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TXT @@ -0,0 +1 @@ +;: Test File for Function: zerop ;; Source: Steel's Book, Chapter 12, Section 2, page 195 ;; Created by: John Park ;; Creation Date: May 1, 86 ;; Predicate: The predicate is true if number is zero and is false otherwise ;; Syntax Format: (zerop number) ;; Input: number (integer zero, a floating-point zero, or a complex zero) ;; Output: T or NIL (do-test zerop-test (and (zerop 0) (zerop 0.0) (zerop -0.0) (zerop -0) (not (zerop 1)) (not (zerop -2.8)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-EQP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-EQP.TEST new file mode 100644 index 00000000..83835fd7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-EQP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: = ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-EQP.TEST ;; ;; ;; Syntax: (= NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test equal-test (and (= 3 3) (= 3 3.0) (= 7 7 7 7) (not (= 1 2)) (not (= 1 3 4 5 4)) (not (= -3 4 -9 0 100)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-GEQ.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-GEQ.TEST new file mode 100644 index 00000000..a51c6d65 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-GEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: >= ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-GEQ.TEST ;; ;; ;; Syntax: (>= NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test geq-test (and (>= 3) (>= 3 2) (>= 3 2 1) (>= 3 2 1 0) (>= 3 3 3 3) (>= 3 3 2 2) (>= 3 3) (NOT (>= 3 4)) (NOT (>= 3 4 5)) (NOT (>= 3 3 3 4)) (NOT (>= 3 2 1 2)) (>= 3.0) (>= 3.0 2.0) (>= 3.0 2.0 1.0) (>= 3.0 2.0 1.0 0.0) (>= 3.0 3.0 3.0 3.0) (>= 3.0 3.0 2.0 2.0) (>= 3.0 3.0) (NOT (>= 3.0 4.0)) (NOT (>= 3.0 4.0 5.0)) (NOT (>= 3.0 3.0 3.0 4.0)) (NOT (>= 3.0 2.0 1.0 2.0)) (>= 4 4) (>= 6 5 3 0 ) (>= 100 7 7.0 3 0 -8.0 -8 -9) (not (>= 1 2 3)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-GREATERP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-GREATERP.TEST new file mode 100644 index 00000000..dc22e12c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: > ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-GTHAN.TEST ;; ;; ;; Syntax: (> NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test greaterp-test (and (> 3) (> 3 2) (> 3 2 1) (> 3 2 1 0) (NOT (> 3 3)) (NOT (> 3 2 2)) (NOT (> 3 2 1 1)) (> 3.0) (> 3.0 2.0) (> 3.0 2.0 1.0) (> 3.0 2.0 1.0 0.0) (NOT (> 3.0 3.0)) (NOT (> 3.0 2.0 2.0)) (NOT (> 3.0 2.0 1.0 1.0)) (> 299 10 3 0) (> 4 3 2 0 -1 -10) (> 19828 1872 107 100 4 1 -1 -1000) (not (> -7 -6 -5 -4 0 1 2 3 4)) (not (> 4 3 3 2 0)) (not (> 4 3 1 2 0 -1)) (not (> 1 0 0.8)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-LEQ.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-LEQ.TEST new file mode 100644 index 00000000..622be6e2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-LEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: <= ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-LEQ.TEST ;; ;; ;; Syntax: (<= NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test leq-test (and (<= 3) (<= 3 4) (<= 3 4 5) (<= 3 4 5 6) (<= 3 3 3 3) (<= 3 3 4 4) (NOT (<= 3 2)) (NOT (<= 3 4 3)) (NOT (<= 3 3 2)) (NOT (<= 3 4 5 4)) (NOT (<= 3 3 3 2)) (<= 3.0) (<= 3.0 4.0) (<= 3.0 4.0 5.0) (<= 3.0 4.0 5.0 6.0) (<= 3.0 3.0 3.0 3.0) (<= 3.0 3.0 4.0 4.0) (NOT (<= 3.0 2)) (NOT (<= 3.0 4.0 3.0)) (NOT (<= 3.0 3.0 2)) (NOT (<= 3.0 4.0 5.0 4.0)) (NOT (<= 3.0 3.0 3.0 2)) (<= 4 4) (<= 0 3 5 6) (<= -9 -8 -8.0 0 3 7.0 7 100) (not (<= 3 -5 -7)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-LESSP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-LESSP.TEST new file mode 100644 index 00000000..f9247118 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: < ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-LTHAN.TEST ;; ;; ;; Syntax: (< NUMBER &REST MORE-NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBER - a number ;; MORE-NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test lessp-test (and (< 3) (< 3 4) (< 3 4 5) (< 3 4 5 6) (NOT (< 3 3)) (NOT (< 3 4 4)) (NOT (< 3 4 5 5)) (< 3.0) (< 3.0 4.0) (< 3.0 4.0 5.0) (< 3.0 4.0 5.0 6.0) (NOT (< 3.0 3.0)) (NOT (< 3.0 4.0 4.0)) (NOT (< 3.0 4.0 5.0 5.0)) (< -299 0 3 5 6) (< 1 3 4 100 107 1872 19828) (< 0 3 4 6 7 8 10) (< -7 -6 -5 -4 0 1 2 3 4) (not (< 0 3 4 4 6)) (not (< 10 5 -3 0)) (not (< 0 0 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-MAX.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-MAX.TEST new file mode 100644 index 00000000..277574d9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-MAX.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAX ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 198 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-MAX.TEST ;; ;; ;; Syntax: (MAX &REST NUMBERS) ;; ;; Function Description: ;; The arguments may be any non-complex numbers. ;; MAX returns the argument that is greatest (closest ;; to positive infinity). ;; MIN returns the argument that is least (closest to ;; negative infinity). ;; ;; For MAX, ;; if the arguments are a mixture of rationals and floating-point ;; numbers, and the largest argument ;; is a rational, then the implementation is free to ;; produce either that rational or its floating-point approximation; ;; if the largest argument is a floating-point number of a smaller format ;; than the largest format of any floating-point argument, ;; then the implementation is free to ;; return the argument in its given format or expanded to the larger format. ;; More concisely, the implementation has the choice of returning the largest ;; argument as is or applying the rules of floating-point contagion, ;; taking all the arguments into consideration for contagion purposes. ;; Also, if one or more of the arguments are equal, then any one ;; of them may be chosen as the value to return. ;; Similar remarks apply to MIN (replacing ``largest argument'' by ;; ``smallest argument''). ;; ;; ;; ;; (MAX 6 12) => 12 (MIN 6 12) => 6 ;; (MAX -6 -12) => -6 (MIN -6 -12) => -12 ;; (MAX 1 3 2 -7) => 3 (MIN 1 3 2 -7) => -7 ;; (MAX -2 3 0 7) => 7 (MIN -2 3 0 7) => -2 ;; (MAX 3) => 3 (MIN 3) => 3 ;; (MAX 5.0 2) => 5.0 ;; (MIN 5.0 2) => 2 OR 2.0 ;; (MAX 3.0 7 1) => 7 OR 7.0 (MIN 3.0 7 1) => 1 OR 1.0 ;; (MAX 1.0S0 7.0D0) => 7.0D0 ;; (MIN 1.0S0 7.0D0) => 1.0S0 OR 1.0D0 ;; (MAX 3 1 1.0S0 1.0D0) => 3 OR 3.0D0 ;; (MIN 3 1 1.0S0 1.0D0) => 1 OR 1.0S0 OR 1.0D0 ;; ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (DO-TEST "TEST MAX 1" T) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-MIN.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-MIN.TEST new file mode 100644 index 00000000..c918592c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-MIN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MIN ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 198 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-MIN.TEST ;; ;; ;; Syntax: (MIN &REST NUMBERS) ;; ;; Function Description: ;; The arguments may be any non-complex numbers. ;; MAX returns the argument that is greatest (closest ;; to positive infinity). ;; MIN returns the argument that is least (closest to ;; negative infinity). ;; ;; For MAX, ;; if the arguments are a mixture of rationals and floating-point ;; numbers, and the largest argument ;; is a rational, then the implementation is free to ;; produce either that rational or its floating-point approximation; ;; if the largest argument is a floating-point number of a smaller format ;; than the largest format of any floating-point argument, ;; then the implementation is free to ;; return the argument in its given format or expanded to the larger format. ;; More concisely, the implementation has the choice of returning the largest ;; argument as is or applying the rules of floating-point contagion, ;; taking all the arguments into consideration for contagion purposes. ;; Also, if one or more of the arguments are equal, then any one ;; of them may be chosen as the value to return. ;; Similar remarks apply to MIN (replacing ``largest argument'' by ;; ``smallest argument''). ;; ;; ;; ;; (MAX 6 12) => 12 (MIN 6 12) => 6 ;; (MAX -6 -12) => -6 (MIN -6 -12) => -12 ;; (MAX 1 3 2 -7) => 3 (MIN 1 3 2 -7) => -7 ;; (MAX -2 3 0 7) => 7 (MIN -2 3 0 7) => -2 ;; (MAX 3) => 3 (MIN 3) => 3 ;; (MAX 5.0 2) => 5.0 ;; (MIN 5.0 2) => 2 OR 2.0 ;; (MAX 3.0 7 1) => 7 OR 7.0 (MIN 3.0 7 1) => 1 OR 1.0 ;; (MAX 1.0S0 7.0D0) => 7.0D0 ;; (MIN 1.0S0 7.0D0) => 1.0S0 OR 1.0D0 ;; (MAX 3 1 1.0S0 1.0D0) => 3 OR 3.0D0 ;; (MIN 3 1 1.0S0 1.0D0) => 1 OR 1.0S0 OR 1.0D0 ;; ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (do-test min-test (and (EQL (min 4 18) 4) (EQL (min -4 -8 -2 0) -8) (= (min 3 9.0 10 9 (/ 5 6) -30 1.0 1.5E2 150 0) -30) (= (min 3 3.00001 (/ 10 3)) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONDECREASE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONDECREASE.TEST new file mode 100644 index 00000000..6c24219b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONDECREASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: <= ; monotonically nondecreasing ;; ;; Source: CommonLisp by Steele Section 12.3: Comparisons on Numbers Page: 196 ;; ;; Created By: John Park ;; ;; Creation Date: May 6, 1986 ;; ;; Last Update: May 6, 1986 ;; ;; Filed As: {eris}cml>test>12-2-monotonic-nondecrease.test ;; ;; ;; Syntax: <= number & rest more-numbers ;; ;; Function Description: The monotonically nondecreasing function returns true if all numbers increase monotonically or are equal contiguously. Otherwise returns false. ;; ;; Argument(s): number(s) ;; ;; Returns: T or NIL ;; ;; Constraints/Limitations: none. (do-test monotonic-nondecrease-test (and (<= 3) (<= 4 4) (<= 0 3 5 6) (<= -9 -8 -8.0 0 3 7.0 7 100) (not (<= 3 -5 -7)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONINCREASE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONINCREASE.TEST new file mode 100644 index 00000000..879ed2cd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-MONOTONIC-NONINCREASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: >= ; monotonically nonincreasing ;; ;; Source: CommonLisp by Steele Section 12.3: Comparisons on Numbers Page: 196 ;; ;; Created By: John Park ;; ;; Creation Date: May 6, 1986 ;; ;; Last Update: May 6, 1986 ;; ;; Filed As: {eris}cml>test>12-2-monotonic-nonincrease.test ;; ;; ;; Syntax: >= number & rest more-numbers ;; ;; Function Description: The monotonically nonincreasing function returns true if all numbers decrease monotonically or are equal contiguously. Otherwise returns false. ;; ;; Argument(s): number(s) ;; ;; Returns: T or NIL ;; ;; Constraints/Limitations: none. (do-test monotonic-nonincrease-test (and (>= 3) (>= 4 4) (>= 6 5 3 0 ) (>= 100 7 7.0 3 0 -8.0 -8 -9) (not (>= 1 2 3)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-3-NEQP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-3-NEQP.TEST new file mode 100644 index 00000000..5af4e7c1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-NEQP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: /= ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.3 Comparisons on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-3-NEQP.TEST ;; ;; ;; Syntax: (/= &REST NUMBERS) ;; ;; Function Description: ;; These functions each take one or more arguments. If the sequence ;; of arguments satisfies a certain condition: ;; ;; ;; ;; = all the same ;; /= all different ;; < monotonically increasing ;; > monotonically decreasing ;; <= monotonically nondecreasing ;; >= ;; monotonically nonincreasing ;; ;; then the predicate is true, and otherwise is false. ;; Complex numbers may be compared using = and /=, ;; but the others require non-complex arguments. ;; Two complex numbers are considered equal by = ;; if their real parts are equal and their imaginary parts are equal ;; according to =. ;; A complex number may be compared to a non-complex number with = or /=. ;; For example: ;; ;; ;; (= 3 3) is true. (/= 3 3) is false. ;; (= 3 5) is false. (/= 3 5) is true. ;; (= 3 3 3 3) is true. (/= 3 3 3 3) is false. ;; (= 3 3 5 3) is false. (/= 3 3 5 3) is false. ;; (= 3 6 5 2) is false. (/= 3 6 5 2) is true. ;; (= 3 2 3) is false. (/= 3 2 3) is false. ;; (< 3 5) is true. ;; (<= 3 5) is true. ;; (< 3 -5) is false. (<= 3 -5) is false. ;; (< 3 3) is false. (<= 3 3) is true. ;; (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. ;; (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. ;; (> 4 3) is true. (>= 4 3) is true. ;; (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. ;; (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. ;; ;; (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. ;; (= 3) is true. (/= 3) is true. ;; (< 3) is true. (<= 3) is true. ;; (= 3.0 #C(3.0 0.0)) is true. (/= 3.0 #C(3.0 1.0)) is true. ;; (= 3 3.0) is true. (= 3.0S0 3.0D0) is true. ;; (= 0.0 -0.0) is true. (= 5/2 2.5) is true. ;; (> 0.0 -0.0) is false. (= 0 -0.0) is true. ;; ;; With two arguments, these functions perform the usual arithmetic ;; comparison tests. ;; With three or more arguments, they are useful for range checks. ;; For example: ;; ;; (<= 0 X 9) ;true if X is between 0 and 9, inclusive ;; ;; (< 0.0 X 1.0) ;true if X is between 0.0 and 1.0, exclusive ;; (< -1 J (LENGTH S)) ;true if J is a valid index for S ;; (<= 0 J K (- (LENGTH S) 1)) ;true if J and K are each valid ;; ; indices for S and also JSailK ;; ;; ;; Rationale: The ``unequality'' relation is called /= rather than ;; <> ;; (the name used in Pascal) for two reasons. First, /= of more than two ;; arguments is not the same as the OR of < and > of those same ;; arguments. Second, unequality is meaningful for complex numbers even though ;; < and > are not. For both reasons it would be misleading to ;; associate unequality with the names of < and >. ;; ;; Compatibility note: In Common Lisp, the comparison operations ;; perform ``mixed-mode'' comparisons: (= 3 3.0) is true. In Maclisp, ;; there must be exactly two arguments, and they must be either both fixnums ;; or both floating-point numbers. To compare two numbers for numerical ;; equality and type equality, use function EQL. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: T or NIL ;; (do-test NEQP-test (and (/= 1 2 3 4 9 10 119.0) (/= 0 2 3.0 100 -1.1) (/= 7 77 100 192886) (/= 4) (not (/= 10.0 10 20 30 40 100 1000 203909)) (not (/= 1 1.0 1 1.000)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST new file mode 100644 index 00000000..6b08ead2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: + ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 199 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-PLUS.TEST ;; ;; ;; Syntax: (+ &REST NUMBERS) ;; ;; Function Description: ;; This returns the sum of the arguments. If there are no arguments, the result ;; is 0, which is an identity for this operation. ;; ;; Compatibility note: While + is compatible with its use in Zetalisp, ;; it is incompatible with Maclisp, which uses + for fixnum-only ;; addition. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (DO-TEST PLUS-TEST1 (AND (= (+) 0) (= (+ 0) 0) (= (+ 1) 1) (= (+ -1) -1) (= (+ 10 20) 30) (= (+ 10 -20) -10) (= (+ -100 -200) -300) (= (+ -100 200) 100) (= (+ 1000 2000 3000) 6000) (= (+ 10000 20000 30000 40000) 100000) (= (+ -10000 20000 -30000 40000) 20000))) (DO-TEST PLUS-TEST2 (AND (= (+ 1000000 2000000) 3000000) (= (+ 1000000 -2000000) -1000000) (= (+ -10000000 -20000000) -30000000) (= (+ -10000000 20000000) 10000000) (= (+ 100000000 200000000 300000000) 600000000) (= (+ 1000000000 2000000000 3000000000 4000000000) 10000000000) (= (+ -1000000000 2000000000 -3000000000 4000000000) 2000000000))) (DO-TEST PLUS-TEST3 (AND (= (+ (/ 1 2) (/ 1 2)) 1) (= (+ (/ 2 3) (/ 1 3)) 1) (= (+ (/ 5 6) (/ 1 6)) 1) (= (+ (/ 1 2) (/ 1 3)) (/ 5 6)) (= (+ (/ 1 2) (/ -1 2)) 0) (= (+ (/ 2 3) (/ -1 3)) (/ 1 3)) (= (+ (/ 5 6) (/ -1 6)) (/ 2 3)) (= (+ (/ 1 2) (/ -1 3)) (/ 1 6)) (= (+ (/ -1 2) (/ 1 2)) 0) (= (+ (/ -2 3) (/ 1 3)) (/ -1 3)) (= (+ (/ -5 6) (/ 1 6)) (/ -2 3)) (= (+ (/ -1 2) (/ 1 3)) (/ -1 6)) (= (+ (/ -1 2) (/ -1 2)) -1) (= (+ (/ -2 3) (/ -1 3)) -1) (= (+ (/ -5 6) (/ -1 6)) -1) (= (+ (/ -1 2) (/ -1 3)) (/ -5 6)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST new file mode 100644 index 00000000..86fb0249 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: - ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 199 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-MINUS.TEST ;; ;; ;; Syntax: (- &REST NUMBERS) ;; ;; Function Description: ;; The function -, when given one argument, returns the negative ;; of that argument. ;; ;; The function -, when given more than one argument, successively subtracts ;; from the first argument all the others, and returns the result. ;; For example, (- 3 4 5) => -6. ;; ;; Compatibility note: While - is compatible with its use in Zetalisp, ;; it is incompatible with Maclisp, which uses - for fixnum-only ;; subtraction. ;; Also, - differs from DIFFERENCE as used in most Lisp ;; systems in the case of one argument. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (DO-TEST MINUS-TEST1 (AND (= (- 0) 0) (= (- 1) -1) (= (- -1) 1) (= (- 10 20) -10) (= (- 10 -20) 30) (= (- -100 -200) 100) (= (- -100 200) -300) (= (- 1000 2000 3000) -4000) (= (- 10000 20000 30000 40000) -80000) (= (- -10000 20000 -30000 40000) -40000))) (DO-TEST MINUS-TEST2 (AND (= (- 1000000 2000000) -1000000) (= (- 1000000 -2000000) 3000000) (= (- -10000000 -20000000) 10000000) (= (- -10000000 20000000) -30000000) (= (- 100000000 200000000 300000000) -400000000) (= (- 1000000000 2000000000 3000000000 4000000000) -8000000000) (= (- -1000000000 2000000000 -3000000000 4000000000) -4000000000))) (DO-TEST MINUS-TEST3 (AND (= (- (/ 1 2) (/ 1 2)) 0) (= (- (/ 2 3) (/ 1 3)) (/ 1 3)) (= (- (/ 5 6) (/ 1 6)) (/ 2 3)) (= (- (/ 1 2) (/ 1 3)) (/ 1 6)) (= (- (/ 1 2) (/ -1 2)) 1) (= (- (/ 2 3) (/ -1 3)) 1) (= (- (/ 5 6) (/ -1 6)) 1) (= (- (/ 1 2) (/ -1 3)) (/ 5 6)) (= (- (/ -1 2) (/ 1 2)) -1) (= (- (/ -2 3) (/ 1 3)) -1) (= (- (/ -5 6) (/ 1 6)) -1) (= (- (/ -1 2) (/ 1 3)) (/ -5 6)) (= (- (/ -1 2) (/ -1 2)) 0) (= (- (/ -2 3) (/ -1 3)) (/ -1 3)) (= (- (/ -5 6) (/ -1 6)) (/ -2 3)) (= (- (/ -1 2) (/ -1 3)) (/ -1 6)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-1+.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-1+.TEST new file mode 100644 index 00000000..c4b82a90 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-1+.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: 1+ ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 200 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: Sep 24, 1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-1+.TEST ;; ;; ;; Syntax: (1+ NUMBER) ;; ;; Function Description: ;; (1+ X) is the same as (+ X 1). ;; ;; (1- X) is the same as (- X 1). ;; Note that the short name may be confusing: (1- X) does NOT mean ;; 1-X; rather, it means X-1. ;; Rationale: These are included primarily for compatibility with Maclisp ;; and Zetalisp. Some programmers prefer always to write (+ X 1) and ;; (- X 1) instead of (1+ X) and (1- X). ;; Implementation note: Compiler writers are very strongly encouraged to ensure ;; that (1+ X) and (+ X 1) compile into identical code, and ;; similarly for (1- X) and (- X 1), to avoid pressure on a Lisp ;; programmer to write possibly less clear code for the sake of efficiency. ;; This can easily be done as a source-language transformation. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (DO-TEST "TEST 1+ 1" (AND (= (1+ 1) 2) (= (1+ 0) 1) (= (1+ -1) 0) (= (1+ 10239999) 10240000))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-1-.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-1-.TEST new file mode 100644 index 00000000..c134f6a1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-1-.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: 1- ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 200 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-SUB1.TEST ;; ;; ;; Syntax: (1- NUMBER) ;; ;; Function Description: ;; (1+ X) is the same as (+ X 1). ;; ;; (1- X) is the same as (- X 1). ;; Note that the short name may be confusing: (1- X) does NOT mean ;; 1-X; rather, it means X-1. ;; Rationale: These are included primarily for compatibility with Maclisp ;; and Zetalisp. Some programmers prefer always to write (+ X 1) and ;; (- X 1) instead of (1+ X) and (1- X). ;; Implementation note: Compiler writers are very strongly encouraged to ensure ;; that (1+ X) and (+ X 1) compile into identical code, and ;; similarly for (1- X) and (- X 1), to avoid pressure on a Lisp ;; programmer to write possibly less clear code for the sake of efficiency. ;; This can easily be done as a source-language transformation. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test sub1-test (and (equalp (1- 3) 2) (equalp (1- 7.0) 6.0) (zerop (1- 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-CONJUGATE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-CONJUGATE.TEST new file mode 100644 index 00000000..9973e736 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-CONJUGATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CONJUGATE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 201 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-CONJUGATE.TEST ;; ;; ;; Syntax: (CONJUGATE NUMBER) ;; ;; Function Description: ;; This returns the complex conjugate of NUMBER. The conjugate ;; of a non-complex number is itself. For a complex number Z, ;; ;; (CONJUGATE Z) = (COMPLEX (REALPART Z) (- (IMAGPART Z))) ;; ;; For example: ;; ;; (CONJUGATE #C(3/5 4/5)) => #C(3/5 -4/5) ;; (CONJUGATE #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) ;; (CONJUGATE 3.7) => 3.7 ;; ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test conjugate-test (and (equal (conjugate #C(1 4)) #C(1 -4)) (equal (conjugate #C(1 -4)) #C(1 4)) (equal (conjugate 3) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-DECF.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-DECF.TEST new file mode 100644 index 00000000..61cc7588 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-DECF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: DECF ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 201 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-DECF.TEST ;; ;; ;; Syntax: (DECF PLACE &OPTIONAL DELTA) ;; ;; Function Description: ;; This returns the complex conjugate of NUMBER. The conjugate ;; of a non-complex number is itself. For a complex number Z, ;; ;; (CONJUGATE Z) = (COMPLEX (REALPART Z) (- (IMAGPART Z))) ;; ;; For example: ;; ;; (CONJUGATE #C(3/5 4/5)) => #C(3/5 -4/5) ;; (CONJUGATE #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) ;; (CONJUGATE 3.7) => 3.7 ;; ;; ;; Argument(s): PLACE - a generalized variable ;; DELTA - a number ;; ;; Returns: a number ;; (do-test decf-test (and (setq n 0) (equalp (decf n) -1) (equalp (decf n) -2) (equalp (decf n 5) -7) (zerop (incf n 7)) (equalp (decf n 1) -1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-GCD.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-GCD.TEST new file mode 100644 index 00000000..26848e4a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-GCD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: GCD ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 202 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-GCD.TEST ;; ;; ;; Syntax: (GCD &REST INTEGERS) ;; ;; Function Description: ;; This returns the greatest common divisor of all the arguments, ;; which must be integers. The result of GCD is always a non-negative ;; integer. ;; If one argument is given, its absolute value is returned. ;; If no arguments are given, GCD returns 0, ;; which is an identity for this operation. ;; For three or more arguments, ;; ;; (GCD A B C ... Z) = (GCD (GCD A B) C ... Z) ;; ;; ;; Here are some examples of the use of GCD: ;; ;; (GCD 91 -49) => 7 ;; (GCD 63 -42 35) => 7 ;; (GCD 5) => 5 ;; (GCD -4) => 4 ;; (GCD) => 0 ;; ;; ;; Argument(s): INTEGERS - an integer ;; ;; Returns: an integer ;; (do-test gcd-test (and (eq (gcd 14 49) 7) (eq (gcd 18 9 1) 1) (eq (gcd -3 -9 -81) 3) (eq (gcd 10) 10) (zerop (gcd)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-INCF.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-INCF.TEST new file mode 100644 index 00000000..85a1ab44 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-INCF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: INCF ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 201 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 22,1986, John Park ;; ;; Filed As: {ERIS}CML>TEST>12-4-INCF.TEST ;; ;; ;; Syntax: (INCF PLACE &OPTIONAL DELTA) ;; ;; Function Description: ;; This returns the complex conjugate of NUMBER. The conjugate ;; of a non-complex number is itself. For a complex number Z, ;; ;; (CONJUGATE Z) = (COMPLEX (REALPART Z) (- (IMAGPART Z))) ;; ;; For example: ;; ;; (CONJUGATE #C(3/5 4/5)) => #C(3/5 -4/5) ;; (CONJUGATE #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) ;; (CONJUGATE 3.7) => 3.7 ;; ;; ;; Argument(s): PLACE - a generalized variable ;; DELTA - a number ;; ;; Returns: a number ;; (do-test incf-test (and (setq n 0) (equalp (incf n) 1) (equalp (incf n) 2) (equalp (incf n 5) 7) (zerop (decf n 7)) (equalp (incf n -1) -1) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-LCM.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-LCM.TEST new file mode 100644 index 00000000..f2369259 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-LCM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LCM ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 202 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 25,1986 by John Sybalsky ;; ;; Filed As: {ERIS}CML>TEST>12-4-LCM.TEST ;; ;; ;; Syntax: (LCM INTEGER &REST MORE-INTEGERS) ;; ;; Function Description: ;; This returns the least common multiple of its arguments, ;; which must be integers. ;; The result of LCM is always a non-negative integer. ;; For two arguments that are not both zero, ;; ;; (LCM A B) = (/ (ABS (* A B)) (GCD A B)) ;; ;; If one or both arguments are zero, ;; ;; (LCM A 0) = (LCM 0 A) = 0 ;; ;; ;; For one argument, LCM returns the absolute value of that argument. ;; For three or more arguments, ;; ;; (LCM A B C ... Z) = (LCM (LCM A B) C ... Z) ;; ;; ;; Some examples: ;; ;; (LCM 14 35) => 70 ;; (LCM 0 5) => 0 ;; (LCM 1 2 3 4 5 6) => 60 ;; ;; ;; Mathematically, (LCM) should return infinity. Because Common Lisp ;; does not have a representation for infinity, LCM, unlike GCD, ;; always requires at least one argument. ;; ;; Argument(s): INTEGER - an integer ;; MORE-INTEGERS - an integer ;; ;; Returns: an integer ;; (do-test lcm-test-dup-factor (eq (lcm 14 35) 70)) (do-test lcm-test-with-zero (eq (lcm 0 5) 0)) (do-test lcm-test-1to7 (eq (lcm 1 2 3 4 5 6 7) 420)) (do-test lcm-test-with-1-neg (eq (lcm -4 5 7) 140)) (do-test lcm-test-with-2-negs (eq (lcm -4 5 -7) 140)) (do-test lcm-test-with-1-neg-dup-factor (eq (lcm -14 35) 70)) (do-test lcm-test-with-2-negs-dup-factor (eq (lcm -14 -35) 70)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-QUOTIENT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-QUOTIENT.TEST new file mode 100644 index 00000000..ccd439fc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-QUOTIENT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: / ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 200 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-QUOTIENT.TEST ;; ;; ;; Syntax: (/ NUMBER &REST NUMBERS) ;; ;; Function Description: ;; The function /, when given more than one argument, successively divides ;; the first argument by all the others and returns the result. ;; ;; With one argument, / reciprocates the argument. ;; ;; / will produce a ratio if the mathematical quotient of two integers ;; is not an exact integer. For example: ;; ;; (/ 12 4) => 3 ;; (/ 13 4) => 13/4 ;; (/ -8) => -1/8 ;; (/ 3 4 5) => 3/20 ;; ;; To divide one integer by another producing an integer result, ;; use one of the functions FLOOR, CEILING, TRUNCATE, ;; or function ROUND. ;; ;; If any argument is a floating-point number, ;; then the rules of floating-point contagion apply. ;; ;; Compatibility note: What / does is totally unlike what the usual ;; // or QUOTIENT operator does. In most Lisp systems, ;; QUOTIENT behaves like / except when dividing integers, ;; in which case it behaves like function TRUNCATE of two arguments; ;; this behavior is mathematically intractable, leading to such ;; anomalies as ;; ;; (QUOTIENT 1.0 2.0) => 0.5 but (QUOTIENT 1 2) => 0 ;; ;; In contrast, the Common Lisp function / produces these results: ;; ;; (/ 1.0 2.0) => 0.5 and (/ 1 2) => 1/2 ;; ;; ;; In practice QUOTIENT is used only when one is sure that both arguments ;; are integers, OR when one is sure that at least one argument ;; is a floating-point number. / is tractable for its purpose ;; and ``works'' for ANY numbers. ;; ;; Argument(s): NUMBER - a number ;; NUMBERS - numbers ;; ;; Returns: a number ;; (do-test quotient-test (and (equalp (/ 12 3) 4) (equalp (/ 40.0 4.0) 10.0) (equalp (/ 1 2) .5) (equalp (/ -8) -.125) (equalp (/ 1.5E4 2E3) 7.5))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-TIMES.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-TIMES.TEST new file mode 100644 index 00000000..1d1ceeee --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-TIMES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: * ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.4 Arithmetic Operations ;; Page: 199 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-4-TIMES.TEST ;; ;; ;; Syntax: (* &REST NUMBERS) ;; ;; Function Description: ;; This returns the product of the arguments. ;; If there are no arguments, the result ;; is 1, which is an identity for this operation. ;; ;; Compatibility note: While * is compatible with its use in Zetalisp, ;; it is incompatible with Maclisp, which uses * for fixnum-only ;; multiplication. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (do-test times-test (and (equalp (* 4 18) 72) (equalp (* 2.1 3.4 0.5 0.1) 0.357) (equalp (* -1 -4 -5) -20) (equalp (* 1.5E2 2E3 1E-1) 30000.0) (equalp (*) 1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXP.TEST new file mode 100644 index 00000000..f4bafdf2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EXP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 203 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-EXP.TEST ;; ;; ;; Syntax: (EXP NUMBER) ;; ;; Function Description: ;; Returns E raised to the power NUMBER, ;; where E is the base of the natural logarithms. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test exp-test (LET ((TOL .0001)) (and (setq e 2.718282) (> TOL (ABS (- (exp 0) 1.0))) (> TOL (ABS (- (exp 0.5) (sqrt e)))) (> TOL (ABS (- (exp 1) e))) (> TOL (ABS (- (exp 2.1) (expt e 2.1)))) (> .001 (ABS (- (exp 7) (expt e 7))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXPT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXPT.TEST new file mode 100644 index 00000000..c3be36f7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-EXPT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EXPT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 203 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 21, 1986, masinter, make it not require exact results ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-EXPT.TEST ;; ;; ;; Syntax: (EXPT BASE-NUMBER POWER-NUMBER) ;; ;; Function Description: ;; Returns BASE-NUMBER raised to the power POWER-NUMBER. ;; If the BASE-NUMBER is of type RATIONAL and the POWER-NUMBER is ;; an integer, ;; the calculation will be exact and the result will be of type RATIONAL; ;; otherwise a floating-point approximation may result. ;; ;; When POWER-NUMBER is 0 (a zero of type integer), ;; then the result is always the value one in the type of BASE-NUMBER, ;; even if the BASE-NUMBER is zero (of any type). That is: ;; ;; (EXPT X 0) = (COERCE 1 (TYPE-OF X)) ;; ;; If the POWER-NUMBER is a zero of any other data type, ;; then the result is also the value one, in the type of the arguments ;; after the application of the contagion rules, with one exception: ;; it is an error if BASE-NUMBER is zero when the POWER-NUMBER ;; is a zero not of type integer. ;; ;; Implementations of EXPT are permitted to use different algorithms ;; for the cases of a rational POWER-NUMBER and a floating-point ;; POWER-NUMBER; the motivation is that in many cases greater accuracy ;; can be achieved for the case of a rational POWER-NUMBER. ;; For example, (EXPT PI 16) and (EXPT PI 16.0) may yield ;; slightly different results if the first case is computed by repeated squaring ;; and the second by the use of logarithms. Similarly, an implementation ;; might choose to compute (EXPT X 3/2) as if it had ;; been written (SQRT (EXPT X 3)), perhaps producing a more accurate ;; result than would (EXPT X 1.5). It is left to the implementor ;; to determine the best strategies. ;; ;; The result of EXPT can be a complex number, even when neither argument ;; is complex, if BASE-NUMBER is negative and POWER-NUMBER ;; is not an integer. The result is always the principal complex value. ;; Note that (EXPT -8 1/3) is not permitted to return -2; ;; while -2 is indeed one of the cube roots of -8, it is ;; not the principal cube root, which is a complex number ;; approximately equal to #C(0.5 1.73205). ;; ;; Argument(s): BASE-NUMBER - a number ;; POWER-NUMBER - a number ;; ;; Returns: a number ;; (do-test expt-test (flet ((closep (x y) (< (abs (- x y)) (* .00001 (/ (+ (abs x) (abs y)) 2))))) (and (= (expt 1233 0) 1) (= (expt 0 5) 0) (closep (expt 28.8 0) 1) (closep (expt -2 9) -512) (closep (expt 3 4) 81) (closep (expt 2 -1) 0.5) (closep (expt 10000 0.25) 10.0) (closep (expt (/ 3 4) 2) 0.5625)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-1-ISQRT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-ISQRT.TEST new file mode 100644 index 00000000..7abd3f8a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-ISQRT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ISQRT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 205 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-ISQRT.TEST ;; ;; ;; Syntax: (ISQRT INTEGER) ;; ;; Function Description: ;; Integer square root: the argument must be a non-negative integer, and the ;; result is the greatest integer less than or equal to the exact positive ;; square root of the argument. ;; For example: ;; ;; (ISQRT 9) => 3 ;; (ISQRT 12) => 3 ;; (ISQRT 300) => 17 ;; (ISQRT 325) => 18 ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test isqrt-test (and (equal (isqrt 9) 3) (equal (isqrt 0) 0) (equal (isqrt 99) 9) (equal (isqrt 1000) 31))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-1-LOG.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-LOG.TEST new file mode 100644 index 00000000..cd499f6b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-LOG.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOG ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 204 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-LOG.TEST ;; ;; ;; Syntax: (LOG NUMBER &OPTIONAL BASE) ;; ;; Function Description: ;; Returns the logarithm of NUMBER in the base BASE, ;; which defaults to E, the base of the natural logarithms. ;; For example: ;; ;; (LOG 8.0 2) => 3.0 ;; (LOG 100.0 10) => 2.0 ;; ;; The result of (LOG 8 2) may be either 3 or 3.0, depending on the ;; implementation. ;; ;; Note that LOG may return a complex result when given a non-complex ;; argument if the argument is negative. For example: ;; ;; (LOG -1.0) = (COMPLEX 0.0 (FLOAT PI 0.0)) ;; ;; ;; Argument(s): NUMBER - a number ;; BASE - a number ;; ;; Returns: a number ;; (do-test log-test (flet ((equalp (x y) (< (abs (- x y)) (* .00001 x)))) (and (setq e 2.718282) (equalp (log e) 1.0) (equalp (log (* e e)) 2.0) (equalp (log 100) 4.60517) (equalp (log 8.0 2) 3.0) (equalp (log 1000 10) 3.0) (equalp (log 81 3) 4.0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-1-SQRT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-SQRT.TEST new file mode 100644 index 00000000..8e273768 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-1-SQRT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SQRT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.1 Exponential and Logarithmic Functions ;; Page: 205 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 17,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-1-SQRT.TEST ;; ;; ;; Syntax: (SQRT NUMBER) ;; ;; Function Description: ;; Returns the principal square root of NUMBER. ;; If the NUMBER is not complex but is negative, then the result ;; will be a complex number. ;; For example: ;; ;; (SQRT 9.0) => 3.0 ;; (SQRT -9.0) => #C(0.0 3.0) ;; ;; The result of (SQRT 9) may be either 3 or 3.0, depending on the ;; implementation. The result of (SQRT -9) may be either #C(0 3) ;; or #C(0.0 3.0). ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test sqrt-test (and (equalp (sqrt 9.0) 3.0) (equalp (sqrt 0) 0.0) (equalp (round (sqrt 399)) 20) (equalp (sqrt -9.0) #C(0.0 3.0)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ABS.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ABS.TEST new file mode 100644 index 00000000..ee89561e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ABS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ABS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 205 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 25,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ABS.TEST ;; ;; ;; Syntax: (ABS NUMBER) ;; ;; Function Description: ;; Returns the absolute value of the argument. ;; ;; For a non-complex number, ;; ;; (ABS X) = (IF (MINUSP X) (- X) X) ;; ;; and the result is always of the same type as the argument. ;; ;; For a complex number Z, the absolute value may be computed as ;; ;; (SQRT (+ (EXPT (REALPART Z) 2) (EXPT (IMAGPART Z) 2))) ;; ;; Implementation note: The careful implementor will not use this formula directly ;; for all complex numbers ;; but will instead handle very large or very small components specially ;; to avoid intermediate overflow or underflow. ;; For example: ;; ;; (ABS #C(3.0 -4.0)) => 5.0 ;; ;; The result of (ABS #C(3 4)) may be either 5 or 5.0, ;; depending on the implementation. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test abs-test (and (equal (abs -9) 9) (equal (abs 0) 0) (equal (abs 99) 99) (equal (abs -3.9E4) 39000.0) (equal (abs #C(3.0 -4.0)) 5.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOS.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOS.TEST new file mode 100644 index 00000000..66d70198 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ACOS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ACOS.TEST ;; ;; ;; Syntax: (ACOS NUMBER) ;; ;; Function Description: ;; ASIN returns the arc sine of the argument, and ACOS the arc cosine. ;; The result is in radians. The argument may be complex. ;; ;; The arc sine and arc cosine functions may be defined mathematically for ;; an argument X as follows: ;; ;; ;; Arc sine -I log (I X+SQRT(1-X2)) ;; Arc cosine -I log (X+I SQRT(1-X2)) ;; ;; Note that the result of either ASIN or ACOS may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group acos-setup :before (progn (setq acos-tolerance 0.001) (setq acos-test-cases '(0.0 0.1 0.3 0.7 0.99 -0.1 -0.3 -0.7 -0.99)) (setq complex-part #C(0.0 1.0)) (defun estimate-acos (x) (if (<= (abs x) 1.0) (- (* complex-part (log (+ x (* complex-part (sqrt (- 1 (expt x 2)))))))))) (defun acos-test (pairs) ; pairs: paired result (calulated vs correct) (cond ((zerop (car pairs))(zerop (cdr pairs))) (t (< (abs (- (car pairs) (cdr pairs))) acos-tolerance))))) (do-test acos-test (and (setq calculated-acos (mapcar #'acos acos-test-cases)) (setq correct-acos (mapcar #'realpart (mapcar #'estimate-acos acos-test-cases))) (setq calculated-expected (pairlis calculated-acos correct-acos)) (setq acos-test-result (mapcar #'acos-test calculated-expected)) (notany 'null acos-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOSH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOSH.TEST new file mode 100644 index 00000000..9d4d69a2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ACOSH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ACOSH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 29,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ACOSH.TEST ;; ;; ;; Syntax: (ACOSH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (acosh-setup :before (progn (setq acosh-tolerance 0.00001) (setq acosh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-acosh (x) (log (+ x (* (+ x 1.0) (sqrt (/ (- x 1.0) (+ x 1.0))))))) (setq correct-acosh (mapcar #'compute-acosh acosh-test-cases)) (defun acosh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (abs(realpart (car pairs))) (abs(realpart (cdr pairs)))) (realpart (cdr pairs)))) acosh-tolerance) (< (abs (/ (- (abs(imagpart (car pairs))) (abs(imagpart (cdr pairs)))) (imagpart (cdr pairs)))) acosh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) acosh-tolerance)))))) (do-test acosh-test (and (setq calculated-acosh (mapcar #'acosh acosh-test-cases)) (setq acosh-pairs (pairlis calculated-acosh correct-acosh)) (or (equal calculated-acosh correct-acosh) (notany 'null (mapcar #'acosh-test acosh-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASIN.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASIN.TEST new file mode 100644 index 00000000..21168b9b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASIN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASIN ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ASIN.TEST ;; ;; ;; Syntax: (ASIN NUMBER) ;; ;; Function Description: ;; ASIN returns the arc sine of the argument, and ACOS the arc cosine. ;; The result is in radians. The argument may be complex. ;; ;; The arc sine and arc cosine functions may be defined mathematically for ;; an argument X as follows: ;; ;; ;; Arc sine -I log (I X+SQRT(1-X2)) ;; Arc cosine -I log (X+I SQRT(1-X2)) ;; ;; Note that the result of either ASIN or ACOS may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group asin-setup :before (progn (setq asin-tolerance 0.001) (setq asin-test-cases '(0.0 0.1 0.3 0.7 0.99 -0.1 -0.3 -0.7 -0.99)) (setq complex-part #C(0.0 1.0)) (defun estimate-asin (x) (if (<= (abs x) 1.0) (- (* complex-part (log (+ (* x complex-part) (sqrt (- 1 (expt x 2))))))))) (defun asin-test (pairs) ; pairs: paired result (calulated vs correct) (cond ((zerop (car pairs))(zerop (cdr pairs))) (t (< (abs (- (car pairs) (cdr pairs))) asin-tolerance))))) (do-test asin-test (and (setq calculated-asin (mapcar #'asin asin-test-cases)) (setq correct-asin (mapcar #'realpart (mapcar #'estimate-asin asin-test-cases))) (setq calculated-expected (pairlis calculated-asin correct-asin)) (setq asin-test-result (mapcar #'asin-test calculated-expected)) (notany 'null asin-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASINH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASINH.TEST new file mode 100644 index 00000000..7e9d9eee --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ASINH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASINH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 29,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ASINH.TEST ;; ;; ;; Syntax: (ASINH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group asinh-setup :before (progn (setq asinh-tolerance 0.00001) (setq asinh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-asinh (x) (log (+ x (sqrt (+ 1 (expt x 2)))))) (setq correct-asinh (mapcar #'compute-asinh asinh-test-cases)) (defun asinh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (abs(realpart (car pairs))) (abs(realpart (cdr pairs)))) (realpart (cdr pairs)))) asinh-tolerance) (< (abs (/ (- (abs(imagpart (car pairs))) (abs(imagpart (cdr pairs)))) (imagpart (cdr pairs)))) asinh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) asinh-tolerance))))) (do-test asinh-test (and (setq calculated-asinh (mapcar #'asinh asinh-test-cases)) (setq asinh-pairs (pairlis calculated-asinh correct-asinh)) (or (equal calculated-asinh correct-asinh) (notany 'null (mapcar #'asinh-test asinh-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATAN.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATAN.TEST new file mode 100644 index 00000000..f38d1e37 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATAN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ATAN ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ATAN.TEST ;; ;; ;; Syntax: (ATAN X &OPTIONAL Y) ;; ;; Function Description: ;; An arc tangent is calculated and the result is returned in radians. ;; ;; With two arguments Y and X, neither argument may be complex. ;; The result is the arc tangent of the quantity Y/X. ;; The signs of Y and X are used to derive quadrant ;; information; moreover, X may be zero provided ;; Y is not zero. The value of ATAN is always between ;; - (exclusive) and  (inclusive). ;; The following table details various special cases. ;; ;; ;; ;; ;; Condition Cartesian locus Range of result ;; Y = 0 X > 0 Positive X-axis 0 ;; Y > 0 ;; X > 0 Quadrant I 0 < result < /2 ;; Y > 0 X = 0 Positive Y-axis /2 ;; Y > 0 X < 0 ;; Quadrant II /2 < result <  ;; Y = 0 X < 0 Negative X-axis  ;; Y < 0 X < 0 Quadrant III ;; - < result < -/2 ;; Y < 0 X = 0 Negative Y-axis -/2 ;; Y < 0 X > 0 Quadrant IV ;; -/2 < result < 0 ;; Y = 0 X = 0 Origin error ;; ;; ;; ;; With only one argument Y, the argument may be complex. ;; The result is the arc tangent of Y, which may be defined by ;; the following formula: ;; ;; ;; Arc tangent -I log ((1+I Y) SQRT(1/(1+Y2))) ;; ;; Implementation note: This formula is mathematically correct, assuming ;; completely accurate computation. It may be a terrible method for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formula given above is not necessarily ;; the simplest one for real-valued computations, either; it is chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; For a non-complex argument Y, the result is non-complex and lies between ;; -/2 and /2 (both exclusive). ;; ;; ;; Compatibility note: Maclisp has a function called ATAN whose ;; range is from 0 to 2. Almost every other programming language ;; (ANSI Fortran, IBM PL1, Interlisp) has a two-argument arc tangent ;; function with range - to . ;; Zetalisp provides two two-argument ;; arc tangent functions, ATAN (compatible with Maclisp) ;; and ATAN2 (compatible with all others). ;; ;; Common Lisp makes two-argument ATAN the standard one ;; with range - to . Observe that this makes ;; the one-argument and two-argument versions of ATAN compatible ;; in the sense that the branch cuts do not fall in different places. ;; The Interlisp one-argument function ARCTAN has a range ;; from 0 to , while nearly every other programming language ;; provides the range -/2 to /2 for ;; one-argument arc tangent! ;; Nevertheless, since Interlisp uses the standard two-argument ;; version of arc tangent, its branch cuts are inconsistent anyway. ;; ;; Argument(s): X - a number ;; Y - a number ;; ;; Returns: a number ;; (do-test-group (atan-setup :before (progn (setq atan-tolerance 0.0001) (setq atan-test-cases '((0.0 1.5) ; y=0 x>0 (1.3 1.4) ; y>0 x>0 (0.5 0.0) ; y>0 x=0 (1.4 -0.9) ; y>0 x<0 (0.0 -0.9) ; y=0 x<0 (-1.0 -1.0) ; y<0 x<0 (-1.1 0.0) ; y<0 x=0 (-0.7 1.2) ; y<0 x>0 )) (defun check-atan (pair) (let ( (y (car pair)) (x (cadr pair) )) (cond (( and (= y 0) (> x 0)) (= (atan y x) 0)) (( and (> y 0) (> x 0)) (and (> (atan y x) 0)(< (atan y x) (+ (/ pi 2) 0.0001)))) (( and (> y 0) (= x 0)) (< (atan y x) (+ (/ pi 2) 0.0001))) (( and (> y 0) (< x 0)) (and (< (atan y x) pi)(> (atan y x) (/ pi 2) ))) (( and (= y 0) (< x 0)) (< (atan y x) (+ pi 0.0001))) (( and (< y 0) (< x 0)) (and (> (atan y x)(- pi ))(< (atan y x) (- (/ pi 2) )))) (( and (< y 0) (= x 0)) (< (atan y x)(+ (/ (- pi) 2) 0.0001))) (( and (< y 0) (> x 0)) (and (< (atan y x) 0)(> (atan y x) (-(/ pi 2)) ))) (t nil)))) )) (do-test atan-test (and (setq atan-test-result (mapcar #'check-atan atan-test-cases)) (notany 'null atan-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATANH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATANH.TEST new file mode 100644 index 00000000..fb1a2e6c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-ATANH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ATANH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 29,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-ATANH.TEST ;; ;; ;; Syntax: (ATANH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group atanh-setup :before (progn (setq atanh-tolerance 0.001) (setq atanh-test-cases-1 '(0.1 0.3 0.5 1.0001 3.0 7.0 -1.0001 -1.7 -3.0 -7.77 #C(1.0 0.3) #C(-1.0 0.9) #C(-1.0 -2.0))) (setq tanh-test-cases-2 '(0.0 0.3 0.5 1.0 3.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 -0.7) )) (setq atanh-test-cases-2 (mapcar #'tanh tanh-test-cases-2)) ;; ROACH 20-AUG-86 Don't use the ATANH formula on page 209 ;; of the silver book. IT'S WRONG! Below is the correct formula. (defun compute-atanh (x) (log (* (+ 1.0 x) (sqrt (/ 1.0 (- 1.0 (expt x 2))))))) (setq correct-atanh-1 (mapcar #'compute-atanh atanh-test-cases-1)) (setq correct-atanh-2 (mapcar #'compute-atanh atanh-test-cases-2)) (defun atanh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (abs(realpart (car pairs))) (abs(realpart (cdr pairs)))) (realpart (cdr pairs)))) atanh-tolerance) (< (abs (/ (- (abs(imagpart (car pairs))) (abs(imagpart (cdr pairs)))) (imagpart (cdr pairs)))) atanh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) atanh-tolerance))))) (do-test atanh-test (and (setq calculated-atanh-1 (mapcar #'atanh atanh-test-cases-1)) (setq calculated-atanh-2 (mapcar #'atanh atanh-test-cases-2)) (setq atanh-pairs-1 (pairlis calculated-atanh-1 correct-atanh-1)) (setq atanh-pairs-2 (pairlis calculated-atanh-2 correct-atanh-2)) (or (notany 'null (mapcar #'atanh-test atanh-pairs-1)) (notany 'null (mapcar #'atanh-test atanh-pairs-2))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-CIS.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-CIS.TEST new file mode 100644 index 00000000..a55eb7ca --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-CIS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CIS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 29,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-CIS.TEST ;; ;; ;; Syntax: (CIS RADIANS) ;; ;; Function Description: ;; This computes E^i*^radians. ;; The name CIS means ``cos + I sin,'' because ;; E^iq = cos q + I sin q. ;; The argument is in ;; radians and may be any non-complex number. The result is a complex ;; number whose real part is the cosine of the argument and whose imaginary ;; part is the sine. Put another way, the result is a complex number whose ;; phase is the equal to the argument (mod 2Sail) ;; and whose magnitude is unity. ;; Implementation note: Often it is cheaper to calculate the sine and cosine ;; of a single angle together than to perform two disjoint calculations. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; (do-test-group cis-setup :before (progn (setq cis-tolerance 0.00001) (setq cis-test-cases '(0.0 (/ PI 6) (/ PI 3) (/ PI 2) (/(* 2 PI) 3) (/(* 5 PI) 6) PI (/(* 7 PI) 6) (/(* 4 PI) 3)(/(* 3 PI) 2) (/(* 5 PI) 3) (/(* 11 PI) 6) (* 2 PI))) (setq correct-cis (mapcar #'(lambda (x) (complex (cos x) (sin x))) (mapcar #'eval cis-test-cases))) (defun cis-test (pairs) ; pairs: paired result (calulated vs correct) (cond ((and (complexp (car pairs)) (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs)))(realpart (cdr pairs)))) cis-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs)))(imagpart (cdr pairs)))) cis-tolerance))t)))) (do-test cis-test (and (setq calculated-cis (mapcar #'cis (mapcar #'eval cis-test-cases))) (setq calculated-expected (pairlis calculated-cis correct-cis)) (or (equal calculated-cis correct-cis) (notany 'null (mapcar #'cis-test calculated-expected)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-COS.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-COS.TEST new file mode 100644 index 00000000..043e71bf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-COS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: COS ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Oct 3, 1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-COS.TEST ;; ;; ;; Syntax: (COS RADIANS) ;; ;; Function Description: ;; SIN returns the sine of the argument, COS the cosine, ;; and TAN the tangent. The argument is in radians. ;; The argument may be complex. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; (do-test-group (cos-setup :before (progn (setq cos-tolerance 0.00001) (setq cos-test-cases '(0 (/ PI 6) (/ PI 3) (/ PI 2) (/(* 2 PI) 3) (/(* 5 PI) 6) PI (/(* 7 PI) 6) (/(* 4 PI) 3)(/(* 3 PI) 2) (/(* 5 PI) 3) (/(* 11 PI) 6) (* 2 PI))) (setq expected-value '(1.0 (/(sqrt 3) 2) 0.5 0.0 -0.5 (-(/(sqrt 3) 2)) -1.0 (-(/(sqrt 3) 2)) -0.5 0.0 0.5 (/(sqrt 3) 2) 1.0)) (defun cos-test (pairs) ; pairs: paired result (calulated vs result) (cond ((or (zerop (car pairs)) (zerop (cdr pairs))) (zerop (cdr pairs))) (t (< (abs (/ (- (car pairs) (cdr pairs)) (cdr pairs))) cos-tolerance)))) )) (do-test pi-const-exist? (and (boundp 'pi) (numberp pi))) (do-test cos-test (and (setq calculated-result (mapcar #'cos (mapcar #'eval cos-test-cases))) (setq expected-result (mapcar #'eval expected-value)) (setq calculated-expected (pairlis calculated-result expected-result)) (setq test-result (mapcar #'cos-test calculated-expected)) (notany 'null test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-COSH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-COSH.TEST new file mode 100644 index 00000000..4aefbaac --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-COSH.TEST @@ -0,0 +1 @@ + ;; Function To Be Tested: COSH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 29,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-COSH.TEST ;; ;; ;; Syntax: (COSH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (cosh-setup :before (progn (setq cosh-tolerance 0.00001) (setq cosh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-cosh (x) (/ (+ (exp x) (exp (- x))) 2)) (setq correct-cosh (mapcar #'compute-cosh cosh-test-cases)) (defun cosh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (= (cdr pairs) 1.0)) ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) cosh-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) cosh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) cosh-tolerance)))))) (do-test cosh-test (and (setq calculated-cosh (mapcar #'cosh cosh-test-cases)) (setq cosh-pairs (pairlis calculated-cosh correct-cosh)) (or (equal calculated-cosh correct-cosh) (notany 'null (mapcar #'cosh-test cosh-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-PHASE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-PHASE.TEST new file mode 100644 index 00000000..4131fdaa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-PHASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PHASE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 206 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 31,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-PHASE.TEST ;; ;; ;; Syntax: (PHASE NUMBER) ;; ;; Function Description: ;; The phase of a number is the angle part of its polar representation ;; as a complex number. That is, ;; ;; (PHASE X) = (ATAN (IMAGPART X) (REALPART X)) ;; ;; The result is in radians, in the range -Sail (exclusive) ;; to Sail (inclusive). The phase of a positive non-complex number ;; is zero; that of a negative non-complex number is Sail. ;; The phase of zero is arbitrarily defined to be zero. ;; ;; If the argument is a complex floating-point number, the result ;; is a floating-point number of the same type as the components of ;; the argument. ;; If the argument is a floating-point number, the result is a ;; floating-point number of the same type. ;; If the argument is a rational number or complex rational number, the result ;; is a single-format floating-point number. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (phase-setup :before (progn (setq phase-tolerance 0.00001) (setq phase-test-cases '(0 1 2 -1 0.0 3.0 -5.0 #C(1.0 0.5) #C(1.1 -0.1) #C(-0.2 -1.0))) (defun compute-phase (x) (cond ((zerop x) x) ((complexp x) (atan (imagpart x) (realpart x))) (t (atan 0 x)))) (setq correct-phase (mapcar #'compute-phase phase-test-cases)) (defun phase-difference (pairs) ; calculated vs correct (cond ((zerop (cdr pairs)) (zerop (car pairs))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) phase-tolerance)))) (defun check-phase-range (x) ; x : value of (phase x) (cond ((complexp x) (and (> (phase x) (- pi)) (<= (phase x) pi) (not(integerp (phase x))))) ((plusp x) (= (phase x) 0)) ((minusp x) (> (phase x) (- pi 0.000001))) ((zerop x) (= (phase x) 0)) (t (and (> (phase x) (- pi)) (<= (phase x) pi))))))) (do-test phase-test (and (setq calculated-phase (mapcar #'phase phase-test-cases)) (setq phase-pairs (pairlis calculated-phase correct-phase)) (notany 'null (mapcar #'check-phase-range phase-test-cases)) (or (equal calculated-phase correct-phase) (notany 'null (mapcar #'phase-difference phase-pairs)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIGNUM.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIGNUM.TEST new file mode 100644 index 00000000..b0525335 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIGNUM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SIGNUM ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 206 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 18,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-SIGNUM.TEST ;; ;; ;; Syntax: (SIGNUM NUMBER) ;; ;; Function Description: ;; By definition, ;; ;; (SIGNUM X) = (IF (ZEROP X) X (/ X (ABS X))) ;; ;; For a rational number, SIGNUM will return one of -1, 0, or 1 ;; according to whether the number is negative, zero, or positive. ;; For a floating-point number, the result will be a floating-point number ;; of the same format whose value is minus one, zero, or one. ;; For a complex number Z, (SIGNUM Z) is a complex number of ;; the same phase but with unit magnitude, unless Z is a complex zero, ;; in which case the result is Z. ;; For example: ;; ;; (SIGNUM 0) => 0 ;; (SIGNUM -3.7L5) => -1.0L0 ;; (SIGNUM 4/5) => 1 ;; (SIGNUM #C(7.5 10.0)) => #C(0.6 0.8) ;; (SIGNUM #C(0.0 -14.7)) => #C(0.0 -1.0) ;; ;; For non-complex rational numbers, SIGNUM is a rational function, ;; but it may be irrational for complex arguments. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (signum-setup :before (progn (setq signum-tolerance 0.00001) (setq signum-test-cases '(0 1 2 -1 0.0 3.0 -5.0 #C(0.0 0.0) #C(1.1 -9.0) #C(-2.0 -3.0))) (setq complex-zero #C(0.0 0.0)) (defun compute-signum (x) (if (zerop x) x (/ x (abs x)))) (setq correct-signum (mapcar #'compute-signum signum-test-cases)) (defun signum-difference (pairs) ; calculate vs correct (cond ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) signum-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) signum-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) signum-tolerance)))) (defun check-signum-sign (x) (cond ((and (integerp x)(> x 0)) (= (signum x) 1)) ((and (integerp x)(= x 0)) (= (signum x) 0)) ((and (integerp x)(< x 0)) (= (signum x) -1)) ((and (floatp x)(> x 0.0)) (= (signum x) 1.0)) ((and (floatp x)(= x 0.0)) (= (signum x) 0.0)) ((and (floatp x)(< x 0.0)) (= (signum x) -1.0)) ((and (complexp x) (= x complex-zero)) (= (signum x) x)) (t (complexp (signum x))))) ) ) (do-test signum-test (and (setq calculated-signum (mapcar #'signum signum-test-cases)) (setq signum-pairs (pairlis calculated-signum correct-signum)) (notany 'null (mapcar #'check-signum-sign signum-test-cases)) (or (equal calculated-signum correct-signum) (notany 'null (mapcar #'signum-difference signum-pairs))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIN.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIN.TEST new file mode 100644 index 00000000..c829d0ee --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SIN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SIN ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Oct 9, 1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-SIN.TEST ;; ;; ;; Syntax: (SIN RADIANS) ;; ;; Function Description: ;; SIN returns the sine of the argument, COS the cosine, ;; and TAN the tangent. The argument is in radians. ;; The argument may be complex. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; ;; Constraints/Limitations (do-test-group (sin-setup :before (progn (setq sin-tolerance 0.00001) (setq sin-test-cases '(0 (/ PI 6) (/ PI 3) (/ PI 2) (/(* 2 PI) 3) (/(* 5 PI) 6) PI (/(* 7 PI) 6) (/(* 4 PI) 3)(/(* 3 PI) 2) (/(* 5 PI) 3) (/(* 11 PI) 6) (* 2 PI))) (setq expected-value '(0.0 0.5 (/(sqrt 3) 2) 1.0 (/(sqrt 3) 2) 0.5 0.0 -0.5 (-(/(sqrt 3) 2)) -1.0 (-(/(sqrt 3) 2)) -0.5 0.0)) (defun sin-test (pairs) ; pairs: paired result (calulated vs result) (cond ((or (zerop (car pairs)) (zerop (cdr pairs))) (zerop (cdr pairs))) (t (< (abs (/ (- (car pairs) (cdr pairs)) (cdr pairs))) sin-tolerance)))) ) ) (do-test pi-const-exist? (and (boundp 'pi) (numberp pi))) (do-test sin-test (and (setq calculated-result (mapcar #'sin (mapcar #'eval sin-test-cases))) (setq expected-result (mapcar #'eval expected-value)) (setq calculated-expected (pairlis calculated-result expected-result)) (setq test-result (mapcar #'sin-test calculated-expected)) (notany 'null test-result)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SINH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SINH.TEST new file mode 100644 index 00000000..128813a6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-SINH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SINH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Dec 16, 1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-SINH.TEST ;; ;; ;; Syntax: (SINH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (sinh-setup :before (progn (setq sinh-tolerance 0.00001) (setq sinh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-sinh (x) (/ (- (exp x) (exp (- x))) 2)) (setq correct-sinh (mapcar #'compute-sinh sinh-test-cases)) (defun sinh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs))) ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) sinh-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) sinh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) sinh-tolerance)))) ) ) (do-test sinh-test (and (setq calculated-sinh (mapcar #'sinh sinh-test-cases)) (setq sinh-pairs (pairlis calculated-sinh correct-sinh)) (or (equal calculated-sinh correct-sinh) (notany 'null (mapcar #'sinh-test sinh-pairs))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-TAN.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-TAN.TEST new file mode 100644 index 00000000..2f679949 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-TAN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TAN ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 207 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-TAN.TEST ;; ;; ;; Syntax: (TAN RADIANS) ;; ;; Function Description: ;; SIN returns the sine of the argument, COS the tanine, ;; and TAN the tangent. The argument is in radians. ;; The argument may be complex. ;; ;; Argument(s): RADIANS - a real ;; ;; Returns: a number ;; ;; Constraints/limitations: The test case for tan must not be equal to ;; (+ (/ pi 2) (* k pi)) where k is an integer; otherwise, the result approaches ;; infinity. (do-test-group tan-setup :before (progn (setq tan-tolerance 0.00001) (setq tan-test-cases (list (-(/ PI 3)) (-(/ PI 4)) (-(/ PI 6)) 0.0 (/ PI 6) (/ PI 4) (/ PI 3))) (setq expected-value (list (-(sqrt 3)) -1.0 (-(/ (sqrt 3) 3)) 0.0 (/(sqrt 3) 3) 1.0 (sqrt 3))) (defun tan-test (pairs) (cond ((zerop (car pairs))(zerop (cdr pairs))) (t (< (abs (/ (- (car pairs) (cdr pairs)) (cdr pairs)))tan-tolerance))))) (do-test pi-const-exist? (and (boundp 'pi) (numberp pi))) (do-test tan-test (and (setq calculated-result (mapcar #'tan (mapcar #'eval tan-test-cases))) (setq expected-result (mapcar #'eval expected-value)) (setq calculated-expected (pairlis calculated-result expected-result)) (setq test-result (mapcar #'tan-test calculated-expected)) (notany 'null test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-5-2-TANH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-TANH.TEST new file mode 100644 index 00000000..0a13db09 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-5-2-TANH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TANH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.5.2 Trigonometric and Related Functions ;; Page: 209 ;; ;; Created By: Kelly Roach and John Park ;; ;; Creation Date: July 29,1986 ;; ;; Last Update: Dec 16,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-5-2-TANH.TEST ;; ;; ;; Syntax: (TANH NUMBER) ;; ;; Function Description: ;; These functions compute the hyperbolic sine, cosine, tangent, ;; arc sine, arc cosine, and arc tangent functions, which are mathematically ;; defined for an argument X as follows: ;; ;; ;; Hyperbolic sine (E^x-E-^x)/2 ;; Hyperbolic cosine (E^x+E-^x)/2 ;; Hyperbolic tangent (E^x-E-^x)/(E^x+E-^x) ;; Hyperbolic arc sine log (X+SQRT(1+X2)) ;; Hyperbolic arc cosine log (X+(X+1)SQRT((X-1)/(X+1))) ;; Hyperbolic arc tangent log ((1+X)SQRT(1-1/X2)) ;; ;; Note that the result of ACOSH may be ;; complex even if the argument is not complex; this occurs ;; when the argument is less than one. ;; Also, the result of ATANH may be ;; complex even if the argument is not complex; this occurs ;; when the absolute value of the argument is greater than one. ;; ;; ;; Implementation note: These formulae are mathematically correct, assuming ;; completely accurate computation. They may be terrible methods for ;; floating-point computation! Implementors should consult a good text on ;; numerical analysis. The formulas given above are not necessarily ;; the simplest ones for real-valued computations, either; they are chosen ;; to define the branch cuts in desirable ways for the complex case. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test-group (tanh-setup :before (progn (setq tanh-tolerance 0.00001) (setq tanh-test-cases '(0.0 0.3 0.5 1.0 3.0 7.0 -0.9 -0.7 -0.3 -0.1 #C(1.0 0.3) #C(-1.0 7.0) #C(-1.0 -2.0))) (defun compute-tanh (x) (/ (- (exp x) (exp (- x))) (+ (exp x) (exp (- x))))) (setq correct-tanh (mapcar #'compute-tanh tanh-test-cases)) (defun tanh-test (pairs) ; calculate vs correct (cond ((zerop (car pairs)) (zerop (cdr pairs) )) ((complexp (cdr pairs)) (and (< (abs (/ (- (realpart (car pairs)) (realpart (cdr pairs))) (realpart (cdr pairs)))) tanh-tolerance) (< (abs (/ (- (imagpart (car pairs)) (imagpart (cdr pairs))) (imagpart (cdr pairs)))) tanh-tolerance))) (t (< (abs (/ (- (car pairs)(cdr pairs)) (cdr pairs))) tanh-tolerance)))) ) ) (do-test tanh-test (and (setq calculated-tanh (mapcar #'tanh tanh-test-cases)) (setq tanh-pairs (pairlis calculated-tanh correct-tanh)) (or (equal calculated-tanh correct-tanh) (notany 'null (mapcar #'tanh-test tanh-pairs))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-CEILING.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-CEILING.TEST new file mode 100644 index 00000000..f3688a1e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-CEILING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CEILING ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-CEILING.TEST ;; ;; ;; Syntax: (CEILING NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a real ;; DIVISOR - a real ;; ;; Returns: an integer ;; (do-test-group ceiling-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq ceiling-result1 '(3 3 3 1 1 0 0 -2 -2 -2)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq ceiling-result2 '(4 4 4))) (do-test ceiling-test (and (setq ceiling-test-result1 (mapcar #'ceiling arguments)) (equal ceiling-test-result1 ceiling-result1) (setq ceiling-test-result2 (mapcar #'(lambda (x) (append '(ceiling) x)) arguments-option)) (equal (mapcar #'eval ceiling-test-result2) ceiling-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-COMPLEX.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-COMPLEX.TEST new file mode 100644 index 00000000..1b6d4e9a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-COMPLEX.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: complex ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 16, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-complex.test ;; ;; Syntax: complex realpart &optional imagpart ;; ;; Function Description: This function returns a non-complex number if only real ;; part is specified as a rational number. Otherwise, a complex number is ;; returned if real part is given in floating-point number or if both real and ;; imaginary parts are given. ;; ;; Argument(s): non-complex number(s) ;; ;; Returns: non-complex or complex number ;; ;; Constraints/limitations: None (do-test complex-test (and (eql (complex 198) 198) (eql (complex 2.0) #C(2.0 0.0)) (eql (complex 3 8) #C(3 8)) (eql (complex 2.0 8.0) #C(2.0 8.0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-DECODE-FLOAT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-DECODE-FLOAT.TEST new file mode 100644 index 00000000..92e82a1d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-DECODE-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: decode-float ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 17, 86 ;; ;; Last Update: Jan 28, 1986 Jim Blum - fix (COND ... NIL) to (COND ... (T NIL)) ;; ;; Filed as: {eris}cml>test>12-6-decode-float.test ;; ;; Syntax: decode-float float ;; ;; Function Description: The function decode-float takes a floating-point number ;; and returns three vlaues. First value is a new floating-point number ;; representing the significand; the second vlue is an integer representing the ;; exponent; and the third value is a floating-point number of the same format ;; indicating the sign. ;; ;; Argument(s): floating-point number ;; ;; Returns: First value: Significand (floating-point number) ;; Second Value: Exponent (integer) ;; Third Value: Float-sign (1.0 or -1.0) ;; ;; Constraints/limitations: None (do-test-group decode-float-test-setup :before (progn (defun check-value(x) (if (and (or (= x 0.0) (and(>= x 0.5) (< x 1.0))) (floatp x)) t)) (defun check-sign (x) (cond ((< x 0) (eql (float-sign x) -1.0)) ((>= x 0) (eql (float-sign x) 1.0)) (t nil))) (setq test-decode-numbers '(0.0 -0.0 1.0 3.0 7.1 -10.0 299.2 1024.99 -239898989.9))) (do-test decode-float-test (and (setq value-result (mapcar #'decode-float test-decode-numbers)) (notany #'null (mapcar #'check-value value-result)) (setq sign-result (mapcar #'check-sign test-decode-numbers)) (notany #'null sign-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-DENOMINATOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-DENOMINATOR.TEST new file mode 100644 index 00000000..e22f1143 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-DENOMINATOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: DENOMINATOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-DENOMINATOR.TEST ;; ;; ;; Syntax: (DENOMINATOR RATIONAL) ;; ;; Function Description: ;; These functions take a rational number (an integer or ratio) ;; and return as an integer the numerator or denominator of the canonical ;; reduced form of the rational. The numerator of an integer is that integer, ;; and the denominator of an integer is 1. Note that ;; ;; (GCD (NUMERATOR X) (DENOMINATOR X)) => 1 ;; ;; The denominator will always be a strictly positive integer; ;; the numerator may be any integer. ;; For example: ;; ;; (NUMERATOR (/ 8 -6)) => -4 ;; (DENOMINATOR (/ 8 -6)) => 3 ;; ;; ;; Argument(s): RATIONAL - a rational ;; ;; Returns: a positive integer ;; (do-test denominator-test (and (eq (denominator 10) 1) (eq (denominator (/ 3 4)) 4) (eq (denominator (/ 10 -4)) 2))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FCEILING.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FCEILING.TEST new file mode 100644 index 00000000..dac989fd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FCEILING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FCEILING ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FCEILING.TEST ;; ;; ;; Syntax: (FCEILING NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group fceiling-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq fceiling-result1 '(3.0 3.0 3.0 1.0 1.0 0.0 0.0 -2.0 -2.0 -2.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq fceiling-result2 '(4.0 4.0 4.0))) (do-test fceiling-test (and (setq fceiling-test-result1 (mapcar #'fceiling arguments)) (equal fceiling-test-result1 fceiling-result1) (setq fceiling-test-result2 (mapcar #'(lambda (x) (append '(fceiling) x)) arguments-option)) (equal (mapcar #'eval fceiling-test-result2) fceiling-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FFLOOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FFLOOR.TEST new file mode 100644 index 00000000..9e390a45 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FFLOOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FFLOOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FFLOOR.TEST ;; ;; ;; Syntax: (FFLOOR NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group ffloor-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq ffloor-result1 '(2.0 2.0 2.0 0.0 0.0 -1.0 -1.0 -3.0 -3.0 -3.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq ffloor-result2 '(3.0 3.0 3.0))) (do-test ffloor-test (and (setq ffloor-test-result1 (mapcar #'ffloor arguments)) (equal ffloor-test-result1 ffloor-result1) (setq ffloor-test-result2 (mapcar #'(lambda (x) (append '(ffloor) x)) arguments-option)) (equal (mapcar #'eval ffloor-test-result2) ffloor-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-DIGITS.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-DIGITS.TEST new file mode 100644 index 00000000..626a9b2e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-DIGITS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: float-digits ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-float-digits.test ;; ;; Syntax: float-digits float ;; ;; Function Description: The function float-digits returns, as a non-negative ;; integer, the number of radix-b digits used in the representation of its argument ;; (including any implicit digits, such as a "hidden bit"). ;; ;; Argument(s): floating-point number ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group float-digits-test-setup :before (progn (setq float-digits-numbers (mapcar #'eval '(1.0 2.0 -3.10 -0.0 most-positive-double-float most-negative-double-float))) (defun float-digitp? (f) (if (or (and (integerp f) (>= f 0)) (= f 23)) t))) (do-test float-digits-test (and (setq sign-test-result (mapcar #'float-digits float-digits-numbers)) (every #'float-digitp? sign-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-PRECISION.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-PRECISION.TEST new file mode 100644 index 00000000..8fdbdc95 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-PRECISION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: float-precision ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: Aug 8, 86 ;; ;; Filed as: {eris}cml>test>12-6-float-precision.test ;; ;; Syntax: float-precision float ;; ;; Function Description: The function float-precision returns, ;; as a non-negative ;; integer, the number of radix-b digits present in the argument; ;; if the argument is ;; (a floating-point) zero, then the result is (an integer) zero. ;; ;; ;; Argument(s): floating-point number ;; ;; Returns: non-negative integer or zero if argument is zero (a floating-point). ;; ;; Constraints/limitations: None (do-test-group float-precision-test-setup :before (progn (setq float-precision-numbers (mapcar #'eval '(1.0 2.0 -3.10 -0.0 most-positive-double-float most-negative-double-float))) (defun float-precisionp? (f) (>= f 0))) (do-test float-precision-test (and (setq precision-test-result (mapcar #'float-precision float-precision-numbers)) (every #'float-precisionp? precision-test-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-RADIX.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-RADIX.TEST new file mode 100644 index 00000000..a2d85fbf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-RADIX.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: float-radix ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-float-radix.test ;; ;; Syntax: float-radix float ;; ;; Function Description: The function float-radix turns (as an integer) the ;; radix b of the floating-point argument. ;; ;; Argument(s): floating-point number ;; ;; Returns: integer ;; ;; Constraints/limitations: None (do-test-group float-radix-test-setup :before (progn (setq float-radix-numbers (mapcar #'eval '(1.0 2.0 -3.10 0.0 most-positive-double-float most-negative-double-float))) (defun is-radix-2? (number) (if (= number 2)t))) (do-test float-radix-test (and (setq radix-result (mapcar #'float-radix float-radix-numbers)) (or (every #'is-radix-2? radix-result) (every #'integerp radix-result))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-SIGN.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-SIGN.TEST new file mode 100644 index 00000000..3df45ea2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT-SIGN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: float-sign ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - fixed (COND .. NIL) to (COND ... (T NIL)) ;; ;; Filed as: {eris}cml>test>12-6-float-sign.test ;; ;; Syntax: float-sign float1 &optional float2 ;; ;; Function Description: The function float-sign returns a floating-point-number ;; x such that x and float1 have the same sign and also such that x and float2 ;; have the same absolute value. ;; ;; ;; Argument(s): floating-point number and optional floating-point number ;; ;; Returns: 1.0, -1.0, or other floating-point number ;; ;; Constraints/limitations: None (do-test-group (float-sign-test-setup :before (progn (setq float-sign-numbers1 (mapcar #'eval '(1.0 2.0 -3.10 -0.0 most-positive-double-float most-negative-double-float))) (setq float-sign-numbers2 '((1.0 -3.0) (-1.0 3.0) (-1.0 -3.0) (1.0 3.0))) (setq expected-sign-result1 (mapcar #'(lambda (x) (cond ((>= x 0) 1.0) ((< x 0) -1.0) (t nil))) float-sign-numbers1)) (setq expected-sign-result2 (mapcar #'(lambda (pairs) (cond ((>= (first pairs) 0) (abs (second pairs))) ((< (first pairs) 0) (- (abs(second pairs)))) (t nil))) float-sign-numbers2)))) (do-test float-sign-test (and (setq sign-test-result1 (mapcar #'float-sign float-sign-numbers1)) (or (equal sign-test-result1 expected-sign-result1) (notany #'null (mapcar #'(lambda (pairs) (cond ((equalp (car pairs) (cdr pairs)) t) (t nil))) (pairlis sign-test-result1 expected-sign-result1)))) (setq sign-test-result2 (mapcar #'eval (mapcar #'(lambda (x) (append '(float-sign) x)) float-sign-numbers2))) (equal sign-test-result2 expected-sign-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT.TEST new file mode 100644 index 00000000..b8ed6448 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FLOAT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 214 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FLOAT.TEST ;; ;; ;; Syntax: (FLOAT NUMBER &OPTIONAL OTHER) ;; ;; Function Description: ;; This converts any non-complex number to a floating-point number. ;; With no second argument, if NUMBER is already a floating-point ;; number, then NUMBER is returned; ;; otherwise a SINGLE-FLOAT is produced. ;; If the argument OTHER is provided, then it must be a floating-point ;; number, and NUMBER is converted to the same format as OTHER. ;; See also function COERCE. ;; ;; Argument(s): NUMBER - a real ;; OTHER - a floating point number ;; ;; Returns: a floating point number ;; (do-test float-test (and (eql (float 10) 10.0) (eql (float (/ 5 2)) 2.5) (eql (float 7.01) 7.01) (eql (float -3E3) -3000.0) (eql (float 3 4.0) 3.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOOR.TEST new file mode 100644 index 00000000..0ed5c8cc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FLOOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FLOOR.TEST ;; ;; ;; Syntax: (FLOOR NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group floor-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq floor-result1 '(2 2 2 0 0 -1 -1 -3 -3 -3)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq floor-result2 '(3 3 3))) (do-test floor-test (and (setq floor-test-result1 (mapcar #'floor arguments)) (equal floor-test-result1 floor-result1) (setq floor-test-result2 (mapcar #'(lambda (x) (append '(floor) x)) arguments-option)) (equal (mapcar #'eval floor-test-result2) floor-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FROUND.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FROUND.TEST new file mode 100644 index 00000000..b3da9296 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FROUND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FROUND ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FROUND.TEST ;; ;; ;; Syntax: (FROUND NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group fround-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq fround-result1 '(3.0 2.0 2.0 1.0 0.0 0.0 -1.0 -2.0 -2.0 -3.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq fround-result2 '(3.0 4.0 4.0))) (do-test fround-test (and (setq fround-test-result1 (mapcar #'fround arguments)) (equal fround-test-result1 fround-result1) (setq fround-test-result2 (mapcar #'(lambda (x) (append '(fround) x)) arguments-option)) (equal (mapcar #'eval fround-test-result2) fround-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-FTRUNCATE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-FTRUNCATE.TEST new file mode 100644 index 00000000..e0569c90 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FTRUNCATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FTRUNCATE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-FTRUNCATE.TEST ;; ;; ;; Syntax: (FTRUNCATE NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; These functions are just like FLOOR, CEILING, TRUNCATE, and ;; ROUND, except that the result (the first result of two) is always a ;; floating-point number rather than an integer. It is roughly as if ;; FFLOOR gave its arguments to FLOOR, and then applied FLOAT to ;; the first result before passing them both back. In practice, however, ;; FFLOOR may be implemented much more efficiently. Similar remarks ;; apply to the other three functions. If the first argument is a ;; floating-point number, and the second argument is not a floating-point ;; number of shorter format, then the first result will be a floating-point ;; number of the same type as the first argument. ;; For example: ;; ;; (FFLOOR -4.7) => -5.0 AND 0.3 ;; (FFLOOR 3.5D0) => 3.0D0 AND 0.5D0 ;; ;; ;; ;; ;; ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group ftruncate-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq ftruncate-result1 '(2.0 2.0 2.0 0.0 0.0 0.0 0.0 -2.0 -2.0 -2.0)) (setq arguments-option '((33.0 10) (35.0 10) (36.0 10))) (setq ftruncate-result2 '(3.0 3.0 3.0))) (do-test ftruncate-test (and (setq ftruncate-test-result1 (mapcar #'ftruncate arguments)) (equal ftruncate-test-result1 ftruncate-result1) (setq ftruncate-test-result2 (mapcar #'(lambda (x) (append '(ftruncate) x)) arguments-option)) (equal (mapcar #'eval ftruncate-test-result2) ftruncate-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-IMAGPART.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-IMAGPART.TEST new file mode 100644 index 00000000..ac90f5b1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-IMAGPART.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: imagpart ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 17, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-imagpart.test ;; ;; Syntax: imagpart number ;; ;; Function Description: This function returns the imaginary part of a complex ;; number. If the number is a non-complex, then imagpart returns the floating ;; point zero of the same format. ;; ;; Argument(s): number ;; ;; Returns: real part of a complex number or zero ;; ;; Constraints/limitations: None (do-test imagpart-test (and (eql (imagpart 198) 0) (eql (imagpart 2.0) 0.0) (eql (imagpart #C(3 8)) 8) (eql (imagpart #C(2.0 8.0)) 8.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-INTEGER-DECODE-FLOAT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-INTEGER-DECODE-FLOAT.TEST new file mode 100644 index 00000000..f4c0407c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-INTEGER-DECODE-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: integer-decode-float ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 21, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - fixed (COND ... NIL) to (COND (T NIL)) ;; ;; Filed as: {eris}cml>test>12-6-integer-decode-float.test ;; ;; Syntax: integer-decode-float float ;; ;; Function Description: The function integer-decode-float is similar to ;; decode-float but for its first value returns, as an integer, the significand ;; scaled so as to be an integer. Integer-decode-float takes a floating-point ;; number and returns three vlaues. First value is an integer ;; representing the significand; the second vlue is an integer representing the ;; exponent; and the third value is a floating-point number of the same format ;; indicating the sign. ;; ;; Argument(s): floating-point number ;; ;; Returns: First value: Significand (integer: f) ;; (f < (expt b (float-precision f)) ;; or (f >= (expt b (- (float-precision f) 1) ;; b: radix for the floating-point representation. ;; Second Value: Exponent (integer) ;; Third Value: Float-sign (1.0 or -1.0) ;; ;; Constraints/limitations: None (do-test-group integer-decode-float-test-setup :before (progn (defun check-decode-value(f) (cond ((and (floatp f) (or (> f 0.0) (< f 0.0))) (and (< (integer-decode-float f) (expt (float-radix f) (float-precision f))) (>= (integer-decode-float f) (expt (float-radix f) (- (float-precision f) 1))) )) ((and (floatp f) (zerop f)) (and (integerp (integer-decode-float f)) (zerop (integer-decode-float f)))) (t nil))) (defun check-decode-sign (x) (cond ((< x 0) (eql (float-sign x) -1.0)) ((>= x 0) (eql (float-sign x) 1.0)) (t nil))) (setq test-decode-numbers '(0.0 -0.0 1.0 3.0 7.1 -10.0 299.2 1024.99 -239898989.9))) (do-test integer-decode-float-test (and (setq type-value-result (mapcar #'integer-decode-float test-decode-numbers)) (every #'integerp type-value-result) (setq value-limit-result (mapcar #'check-decode-value test-decode-numbers)) (notany #'null value-limit-result) (setq sign-result (mapcar #'check-decode-sign test-decode-numbers)) (notany #'null sign-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-MOD.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-MOD.TEST new file mode 100644 index 00000000..4486d09b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-MOD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MOD ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-MOD.TEST ;; ;; ;; Syntax: (MOD NUMBER DIVISOR) ;; ;; Function Description: ;; MOD performs the operation function FLOOR on its two arguments ;; and returns the SECOND result of FLOOR as its only result. ;; Similarly, ;; REM performs the operation function TRUNCATE on its arguments ;; and returns the SECOND result of TRUNCATE as its only result. ;; ;; MOD and REM are therefore the usual modulus ;; and remainder functions when applied to two integer arguments. ;; In general, however, the arguments may be integers or floating-point ;; numbers. ;; ;; ;; ;; (MOD 13 4) => 1 (REM 13 4) => 1 ;; (MOD -13 4) => 3 (REM -13 4) => -1 ;; (MOD 13 -4) => -3 (REM 13 -4) => 1 ;; (MOD -13 -4) => -1 (REM -13 -4) => -1 ;; (MOD 13.4 1) => 0.4 ;; (REM 13.4 1) => 0.4 ;; (MOD -13.4 1) => 0.6 (REM -13.4 1) => -0.4 ;; ;; Compatibility note: The Interlisp function REMAINDER is essentially ;; equivalent to the Common Lisp function REM. The Maclisp function REMAINDER ;; is like REM but accepts only integer arguments. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group mod-test-setup :before (progn (setq mod-arguments '((13 4) (-13 4) (13 -4) (-13 -4) (13.4 1) (-13.4 1))) (setq mod-result '(1 3 -3 -1 0.4 0.6))) (do-test mod-test (and (setq mod-test-cases (mapcar #'(lambda (x) (append '(mod) x)) mod-arguments)) (setq mod-test-result (mapcar #'eval mod-test-cases)) (setq round-test-result (mapcar #'(lambda (x) (if (floatp x) (/ (fround (* 10 x)) 10) x)) mod-test-result)) (equal round-test-result mod-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-NUMERATOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-NUMERATOR.TEST new file mode 100644 index 00000000..b7c60994 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-NUMERATOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NUMERATOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-NUMERATOR.TEST ;; ;; ;; Syntax: (NUMERATOR RATIONAL) ;; ;; Function Description: ;; These functions take a rational number (an integer or ratio) ;; and return as an integer the numerator or denominator of the canonical ;; reduced form of the rational. The numerator of an integer is that integer, ;; and the denominator of an integer is 1. Note that ;; ;; (GCD (NUMERATOR X) (DENOMINATOR X)) => 1 ;; ;; The denominator will always be a strictly positive integer; ;; the numerator may be any integer. ;; For example: ;; ;; (NUMERATOR (/ 8 -6)) => -4 ;; (DENOMINATOR (/ 8 -6)) => 3 ;; ;; ;; Argument(s): RATIONAL - a rational ;; ;; Returns: a number ;; (do-test numerator-test (and (eq (numerator 10) 10) (eq (numerator (/ 3 4)) 3) (eq (numerator (/ -10 4)) -5) (eq (numerator (/ 8 -6)) -4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONAL.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONAL.TEST new file mode 100644 index 00000000..7ac2c6a0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RATIONAL ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 214 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: Jan 28, 1987 - Jim Blum - Substitued (= ...) for (eq.. ...) ;; ;; Filed As: {ERIS}CML>TEST>12-6-RATIONAL.TEST ;; ;; ;; Syntax: (RATIONAL NUMBER) ;; ;; Function Description: ;; Each of these functions converts any non-complex number to be a rational ;; number. If the argument is already rational, it is returned. ;; The two functions differ in their treatment of floating-point numbers. ;; ;; RATIONAL assumes that the floating-point number is completely accurate ;; and returns a rational number mathematically equal to the precise ;; value of the floating-point number. ;; ;; RATIONALIZE assumes that the ;; floating-point number is accurate only to the precision of the ;; floating-point representation, and may return any rational number for ;; which the floating-point number is the best available approximation of ;; its format; in doing this it attempts to keep both numerator and ;; denominator small. ;; ;; It is always the case that ;; ;; (FLOAT (RATIONAL X) X) = X ;; ;; and ;; ;; (FLOAT (RATIONALIZE X) X) = X ;; ;; That is, rationalizing a floating-point number by either method ;; and then converting it back ;; to a floating-point number of the same format produces the original number. ;; What distinguishes the two functions is that RATIONAL typically ;; has a simple, inexpensive implementation, whereas RATIONALIZE goes ;; to more trouble to produce a result that is more pleasant to view and ;; simpler for some purposes to compute with. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test rational-test (and (= (rational 10) 10) (= (float (rational 3.1)) (/ 31 10)) (rationalp (rational 3.1)) (= (float (rational 3.1)) 3.1) (= (float (rational (/ 3 10))) (/ 3 10)) (rationalp (rational (/ 3 10))) (= (rational 3E3) 3000))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONALIZE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONALIZE.TEST new file mode 100644 index 00000000..d58a88f6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONALIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RATIONALIZE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 214 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-RATIONALIZE.TEST ;; ;; ;; Syntax: (RATIONALIZE NUMBER) ;; ;; Function Description: ;; Each of these functions converts any non-complex number to be a rational ;; number. If the argument is already rational, it is returned. ;; The two functions differ in their treatment of floating-point numbers. ;; ;; RATIONAL assumes that the floating-point number is completely accurate ;; and returns a rational number mathematically equal to the precise ;; value of the floating-point number. ;; ;; RATIONALIZE assumes that the ;; floating-point number is accurate only to the precision of the ;; floating-point representation, and may return any rational number for ;; which the floating-point number is the best available approximation of ;; its format; in doing this it attempts to keep both numerator and ;; denominator small. ;; ;; It is always the case that ;; ;; (FLOAT (RATIONAL X) X) = X ;; ;; and ;; ;; (FLOAT (RATIONALIZE X) X) = X ;; ;; That is, rationalizing a floating-point number by either method ;; and then converting it back ;; to a floating-point number of the same format produces the original number. ;; What distinguishes the two functions is that RATIONAL typically ;; has a simple, inexpensive implementation, whereas RATIONALIZE goes ;; to more trouble to produce a result that is more pleasant to view and ;; simpler for some purposes to compute with. ;; ;; Argument(s): NUMBER - a number ;; ;; Returns: a number ;; (do-test rationalize-test (and (eql (rationalize 10) 10) (eql (rationalize 3.1) (/ 31 10)) (rationalp (rationalize 3.1)) (eql (float (rationalize 3.1)) 3.1) (eql (rationalize (/ 10 5)) 2) (rationalp (rationalize (/ 10 5))) (eql (rationalize 3E3) 3000))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-REALPART.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-REALPART.TEST new file mode 100644 index 00000000..25b2565d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-REALPART.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: realpart ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 17, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-realpart.test ;; ;; Syntax: realpart number ;; ;; Function Description: This function returns the real part of a complex ;; number. If the number is a non-complex, then realpart returns its argument. ;; ;; Argument(s): number ;; ;; Returns: real part of a complex number ;; ;; Constraints/limitations: None (do-test realpart-test (and (eql (realpart 198) 198) (eql (realpart 2.0) 2.0) (eql (realpart #C(3 8)) 3) (eql (realpart #C(2.0 8.0)) 2.0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-REM.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-REM.TEST new file mode 100644 index 00000000..81271e5d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-REM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: REM ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 217 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-REM.TEST ;; ;; ;; Syntax: (REM NUMBER DIVISOR) ;; ;; Function Description: ;; MOD performs the operation function FLOOR on its two arguments ;; and returns the SECOND result of FLOOR as its only result. ;; Similarly, ;; REM performs the operation function TRUNCATE on its arguments ;; and returns the SECOND result of TRUNCATE as its only result. ;; ;; MOD and REM are therefore the usual modulus ;; and remainder functions when applied to two integer arguments. ;; In general, however, the arguments may be integers or floating-point ;; numbers. ;; ;; ;; ;; (MOD 13 4) => 1 (REM 13 4) => 1 ;; (MOD -13 4) => 3 (REM -13 4) => -1 ;; (MOD 13 -4) => -3 (REM 13 -4) => 1 ;; (MOD -13 -4) => -1 (REM -13 -4) => -1 ;; (MOD 13.4 1) => 0.4 ;; (REM 13.4 1) => 0.4 ;; (MOD -13.4 1) => 0.6 (REM -13.4 1) => -0.4 ;; ;; Compatibility note: The Interlisp function REMAINDER is essentially ;; equivalent to the Common Lisp function REM. The Maclisp function REMAINDER ;; is like REM but accepts only integer arguments. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group rem-test-setup :before (progn (setq rem-arguments '((13 4) (-13 4) (13 -4) (-13 -4) (13.4 1) (-13.4 1))) (setq rem-result '(1 -1 1 -1 0.4 -0.4))) (do-test rem-test (and (setq rem-test-cases (mapcar #'(lambda (x) (append '(rem) x)) rem-arguments)) (setq rem-test-result (mapcar #'eval rem-test-cases)) (setq round-test-result (mapcar #'(lambda (x) (if (floatp x) (/ (fround (* 10 x)) 10) x)) rem-test-result)) (equal round-test-result rem-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-ROUND.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-ROUND.TEST new file mode 100644 index 00000000..f360a1cc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-ROUND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ROUND ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-ROUND.TEST ;; ;; ;; Syntax: (ROUND NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group round-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq round-result1 '(3 2 2 1 0 0 -1 -2 -2 -3)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq round-result2 '(3 4 4))) (do-test round-test (and (setq round-test-result1 (mapcar #'round arguments)) (equal round-test-result1 round-result1) (setq round-test-result2 (mapcar #'(lambda (x) (append '(round) x)) arguments-option)) (equal (mapcar #'eval round-test-result2) round-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-SCALE-FLOAT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-SCALE-FLOAT.TEST new file mode 100644 index 00000000..0960caca --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-SCALE-FLOAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: scale-float ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.6: Type Conversions and Component Extractions ;; on Numbers Page: 218 ;; ;; Created By: John Park ;; ;; Creation Date: July 18, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-6-scale-float.test ;; ;; Syntax: scale-float float integer ;; ;; Function Description: The function scale-float takes a floating-point number,f ;; and an integer k, and returns (* f (expt (float b f) k)). ;; ;; Argument(s): floating-point number and integer ;; ;; Returns: floating-point number (* f (expt (float b f) k)) ;; ;; Constraints/limitations: None (do-test-group scale-float-test-setup :before (progn (setq scale-float-numbers '((0.0 10)(2.0 1)(2.0 2)(3.0 3) (3.0 4) (10.9 3) (0.5 3)(19999.0 100))) (defun expected-scale-float (pairs) (if (and (floatp (first pairs)) (integerp (second pairs))) (* (first pairs) (expt (float (float-radix (first pairs)) (first pairs)) (second pairs))))) (setq expected-scale-values (mapcar #'expected-scale-float scale-float-numbers)) (defun modify-scale-float-values (x) (cond ((and (>= x 0) (< x short-float-epsilon)) 0.0) (t (/ (fround (* x 1000)) 1000))))) (do-test scale-float-test (and (setq scale-float-test-cases (mapcar #'eval (mapcar #'(lambda (x) (append '(scale-float) x)) scale-float-numbers))) (setq scale-float-test-result (mapcar #'modify-scale-float-values scale-float-test-cases)) (equal scale-float-test-result expected-scale-values)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-6-TRUNCATE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-6-TRUNCATE.TEST new file mode 100644 index 00000000..cdd5f735 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-TRUNCATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TRUNCATE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.6 Type Conversions and Component Extractions on Numbers ;; Page: 215 ;; ;; Created By: Kelly Roach, John Park ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-6-TRUNCATE.TEST ;; ;; ;; Syntax: (TRUNCATE NUMBER &OPTIONAL DIVISOR) ;; ;; Function Description: ;; In the simple one-argument case, ;; each of these functions converts its argument NUMBER ;; (which must not be complex) to be an integer. ;; If the argument is already an integer, it is returned directly. ;; If the argument is a ratio or floating-point number, the functions use ;; different algorithms for the conversion. ;; ;; FLOOR converts its argument by truncating toward negative ;; infinity; that is, the result is the largest integer that is not larger ;; than the argument. ;; ;; CEILING converts its argument by truncating toward positive ;; infinity; that is, the result is the smallest integer that is not smaller ;; than the argument. ;; ;; TRUNCATE converts its argument by truncating toward zero; ;; that is, the result is the integer of the same sign as the argument ;; and which has the greatest integral ;; magnitude not greater than that of the argument. ;; ;; ROUND converts its argument by rounding to the nearest ;; integer; if NUMBER is exactly halfway between two integers ;; (that is, of the form INTEGER+0.5), then it is rounded to the one that ;; is even (divisible by two). ;; ;; The following table shows what the four functions produce when given ;; various arguments. ;; ;; ;; ;; ;; ;; 2.6 2 3 2 3 ;; 2.5 2 3 2 ;; 2 ;; 2.4 2 3 2 2 ;; 0.7 0 1 0 1 ;; 0.3 0 1 ;; 0 0 ;; -0.3 -1 0 0 0 ;; -0.7 -1 0 0 -1 ;; -2.4 -3 ;; -2 -2 -2 ;; -2.5 -3 -2 -2 -2 ;; -2.6 -3 -2 -2 -3 ;; ;; ;; If a second argument DIVISOR is supplied, then the result ;; is the appropriate type of rounding or truncation applied to the ;; result of dividing the NUMBER by the DIVISOR. ;; For example, (FLOOR 5 2) = (FLOOR (/ 5 2)) but is potentially more ;; efficient. The DIVISOR may be any non-complex number. ;; The one-argument case is exactly like the two-argument case where the second ;; argument is 1. ;; ;; ;; ;; ;; ;; Each of the functions actually returns TWO values, ;; whether given one or two arguments. The second ;; result is the remainder and may be obtained using ;; ;; macro MULTIPLE-VALUE-BIND and related constructs. ;; If any of these functions is given two arguments X and Y ;; and produces results Q and R, then Q*Y+R=X. ;; The first result Q is always an integer. ;; The remainder R is an integer if both arguments are integers, ;; is rational if both arguments are rational, ;; and is floating-point if either argument is floating-point. ;; One consequence is that ;; in the one-argument case the remainder is always a number of the same type ;; as the argument. ;; ;; When only one argument is given, the two results are exact; ;; the mathematical sum of the two results is always equal to the ;; mathematical value of the argument. ;; ;; Compatibility note: The names of the functions FLOOR, CEILING, ;; TRUNCATE, and ROUND are more accurate than names like FIX ;; that have heretofore been used in various Lisp systems. ;; The names used here are compatible with standard mathematical ;; terminology (and with PL1, as it happens). In Fortran ;; IFIX means TRUNCATE. Algol 68 provides ROUND ;; and uses ENTIER to mean FLOOR. ;; In Maclisp, FIX and IFIX both ;; mean FLOOR (one is generic, the other flonum-in/fixnum-out). ;; In Interlisp, FIX means TRUNCATE. ;; In Zetalisp, FIX means FLOOR and FIXR means ROUND. ;; Standard Lisp provides a FIX function but does not ;; specify precisely what it does. The existing usage ;; of the name FIX is so confused that it seemed best to avoid it ;; altogether. ;; ;; The names and definitions given here have recently been adopted ;; by Zetalisp, and Maclisp and NIL seem likely to follow suit. ;; ;; Argument(s): NUMBER - a number ;; DIVISOR - a real ;; ;; Returns: a number ;; (do-test-group truncate-setup :before (progn (setq arguments '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (setq truncate-result1 '(2 2 2 0 0 0 0 -2 -2 -2)) (setq arguments-option '((33 10) (35 10) (36 10))) (setq truncate-result2 '(3 3 3))) (do-test truncate-test (and (setq truncate-test-result1 (mapcar #'truncate arguments)) (equal truncate-test-result1 truncate-result1) (setq truncate-test-result2 (mapcar #'(lambda (x) (append '(truncate) x)) arguments-option)) (equal (mapcar #'eval truncate-test-result2) truncate-result2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-ASH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-ASH.TEST new file mode 100644 index 00000000..03564f3e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-ASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ash ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.7: Logical Operations on Numbers Page: 224 ;; ;; Created By: John Park ;; ;; Creation Date: July 15, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-7-ash.test ;; ;; Syntax: ash integer count ;; ;; Function Description: ;; This function shifts INTEGER arithmetically left by COUNT bit ;; positions if COUNT is positive, ;; or right -COUNT bit positions if COUNT is negative. ;; The sign of the result is always the same as the sign of INTEGER. ;; ;; Mathematically speaking, this operation performs the computation ;; FLOOR(INTEGER*2^count). ;; ;; Logically, this moves all of the bits in INTEGER to the left, ;; adding zero-bits at the bottom, or moves them to the right, ;; discarding bits. (In this context the question of what gets shifted ;; in on the left is irrelevant; integers, viewed as strings of bits, ;; are ``half-infinite,'' that is, conceptually extend infinitely far to the left.) ;; For example: ;; ;; (LOGBITP J (ASH N K)) ;; = (AND (>= J K) (LOGBITP (- J K) N)) ;; ;; ;; Argument(s): INTEGER - an integer ;; COUNT - an integer ;; ;; Returns: a number ;; (do-test ash-test (and (eq (ash 1 1) 2) (eq (ash 1 2) 4) (eq (ash 1 3) 8) (eq (ash 1 4) 16) (eq (ash 1 10) 1024) (eq (ash 1 0) 1) (eq (ash 1 -1) 0) (eq (ash 15 -1) 7) (eq (ash 15 -2) 3) (eq (ash 15 -3) 1) (eq (ash -1 1) -2) (eq (ash -1 3) -8) (eq (ash -1 -1) -1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-BOOLE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-BOOLE.TEST new file mode 100644 index 00000000..d15eef6d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-BOOLE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: BOOLE ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 222 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-BOOLE.TEST ;; ;; ;; Syntax: (BOOLE OP INTEGER1 INTEGER2) ;; ;; Function Description: ;; The function BOOLE takes an operation OP and two integers, ;; and returns an integer produced by performing the logical operation ;; specified by OP on the two integers. The precise values of ;; the sixteen constants are implementation-dependent, but they are ;; suitable for use as the first argument to BOOLE: ;; ;; ;; INTEGER1 0 0 1 1 ;; INTEGER2 0 1 0 1 OPERATION PERFORMED ;; BOOLE-CLR ;; 0 0 0 0 ALWAYS 0 ;; BOOLE-SET 1 1 1 1 ALWAYS 1 ;; BOOLE-1 ;; 0 0 1 1 INTEGER1 ;; BOOLE-2 0 1 0 1 INTEGER2 ;; BOOLE-C1 ;; 1 1 0 0 COMPLEMENT OF INTEGER1 ;; BOOLE-C2 1 0 1 0 COMPLEMENT OF INTEGER2 ;; BOOLE-AND ;; 0 0 0 1 AND ;; BOOLE-IOR 0 1 1 1 INCLUSIVE OR ;; BOOLE-XOR ;; 0 1 1 0 EXCLUSIVE OR ;; BOOLE-EQV 1 0 0 1 EQUIVALENCE (EXCLUSIVE NOR) ;; BOOLE-NAND ;; 1 1 1 0 NOT-AND ;; BOOLE-NOR 1 0 0 0 NOT-OR ;; BOOLE-ANDC1 ;; 0 1 0 0 AND COMPLEMENT OF INTEGER1 WITH INTEGER2 ;; BOOLE-ANDC2 0 0 1 0 AND INTEGER1 WITH COMPLEMENT OF INTEGER2 ;; BOOLE-ORC1 ;; 1 1 0 1 OR COMPLEMENT OF INTEGER1 WITH INTEGER2 ;; BOOLE-ORC2 1 0 1 1 OR INTEGER1 WITH COMPLEMENT OF INTEGER2 ;; ;; BOOLE can therefore compute all sixteen logical functions on two ;; arguments. In general, ;; ;; (BOOLE BOOLE-AND X Y) ;; = (LOGAND X Y) ;; ;; and the latter is more perspicuous. However, BOOLE is useful when it ;; is necessary to parameterize a procedure so that it can use ;; one of several logical operations. ;; ;; Argument(s): OP - anything ;; INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test-group boolean-operation-tests :before (progn (setq boolean-constants '(boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2 boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1 boole-andc2 boole-orc1 boole-orc2)) (setq boolean-values (mapcar #'eval boolean-constants)) (setq integer-pairs '((0 0) (0 1) (1 0) (1 1))) (setq boole-clr-result '(0 0 0 0)) (setq boole-set-result '(1 1 1 1)) (setq boole-1-result '(0 0 1 1)) (setq boole-2-result '(0 1 0 1)) (setq boole-c1-result '(1 1 0 0)) (setq boole-c2-result '(1 0 1 0)) (setq boole-and-result '(0 0 0 1)) (setq boole-ior-result '(0 1 1 1)) (setq boole-xor-result '(0 1 1 0)) (setq boole-eqv-result '(1 0 0 1)) (setq boole-nand-result '(1 1 1 0)) (setq boole-nor-result '(1 0 0 0)) (setq boole-andc1-result '(0 1 0 0)) (setq boole-andc2-result '(0 0 1 0)) (setq boole-orc1-result '(1 1 0 1)) (setq boole-orc2-result '(1 0 1 1))) (do-test boolean-constants-exist? (and (every #'boundp boolean-constants) (every #'integerp boolean-values))) (do-test boole-clr-test (and (setq clr-test-conditions (mapcar #'(lambda (x) (append '(boole boole-clr) x)) integer-pairs)) (setq clr-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) clr-test-conditions)) (equal (mapcar #'eval clr-test-result) boole-clr-result))) (do-test boole-set-test (and (setq boole-set-test-conditions (mapcar #'(lambda (x) (append '(boole boole-set) x)) integer-pairs)) (setq boole-set-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-set-test-conditions)) (equal (mapcar #'eval boole-set-test-result) boole-set-result))) (do-test boole-1-test (and (setq boole-1-test-conditions (mapcar #'(lambda (x) (append '(boole boole-1) x)) integer-pairs)) (setq boole-1-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-1-test-conditions)) (equal (mapcar #'eval boole-1-test-result) boole-1-result))) (do-test boole-2-test (and (setq boole-2-test-conditions (mapcar #'(lambda (x) (append '(boole boole-2) x)) integer-pairs)) (setq boole-2-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-2-test-conditions)) (equal (mapcar #'eval boole-2-test-result) boole-2-result))) (do-test boole-c1-test (and (setq boole-c1-test-conditions (mapcar #'(lambda (x) (append '(boole boole-c1) x)) integer-pairs)) (setq boole-c1-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-c1-test-conditions)) (equal (mapcar #'eval boole-c1-test-result) boole-c1-result))) (do-test boole-c2-test (and (setq boole-c2-test-conditions (mapcar #'(lambda (x) (append '(boole boole-c2) x)) integer-pairs)) (setq boole-c2-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-c2-test-conditions)) (equal (mapcar #'eval boole-c2-test-result) boole-c2-result))) (do-test boole-and-test (and (setq boole-and-test-conditions (mapcar #'(lambda (x) (append '(boole boole-and) x)) integer-pairs)) (setq boole-and-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-and-test-conditions)) (equal (mapcar #'eval boole-and-test-result) boole-and-result))) (do-test boole-ior-test (and (setq boole-ior-test-conditions (mapcar #'(lambda (x) (append '(boole boole-ior) x)) integer-pairs)) (setq boole-ior-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-ior-test-conditions)) (equal (mapcar #'eval boole-ior-test-result) boole-ior-result))) (do-test boole-xor-test (and (setq boole-xor-test-conditions (mapcar #'(lambda (x) (append '(boole boole-xor) x)) integer-pairs)) (setq boole-xor-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-xor-test-conditions)) (equal (mapcar #'eval boole-xor-test-result) boole-xor-result))) (do-test boole-eqv-test (and (setq boole-eqv-test-conditions (mapcar #'(lambda (x) (append '(boole boole-eqv) x)) integer-pairs)) (setq boole-eqv-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-eqv-test-conditions)) (equal (mapcar #'eval boole-eqv-test-result) boole-eqv-result))) (do-test boole-nand-test (and (setq boole-nand-test-conditions (mapcar #'(lambda (x) (append '(boole boole-nand) x)) integer-pairs)) (setq boole-nand-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-nand-test-conditions)) (equal (mapcar #'eval boole-nand-test-result) boole-nand-result))) (do-test boole-nor-test (and (setq boole-nor-test-conditions (mapcar #'(lambda (x) (append '(boole boole-nor) x)) integer-pairs)) (setq boole-nor-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-nor-test-conditions)) (equal (mapcar #'eval boole-nor-test-result) boole-nor-result))) (do-test boole-andc1-test (and (setq boole-andc1-test-conditions (mapcar #'(lambda (x) (append '(boole boole-andc1) x)) integer-pairs)) (setq boole-andc1-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-andc1-test-conditions)) (equal (mapcar #'eval boole-andc1-test-result) boole-andc1-result))) (do-test boole-andc2-test (and (setq boole-andc2-test-conditions (mapcar #'(lambda (x) (append '(boole boole-andc2) x)) integer-pairs)) (setq boole-andc2-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-andc2-test-conditions)) (equal (mapcar #'eval boole-andc2-test-result) boole-andc2-result))) (do-test boole-orc1-test (and (setq boole-orc1-test-conditions (mapcar #'(lambda (x) (append '(boole boole-orc1) x)) integer-pairs)) (setq boole-orc1-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-orc1-test-conditions)) (equal (mapcar #'eval boole-orc1-test-result) boole-orc1-result))) (do-test boole-orc2-test (and (setq boole-orc2-test-conditions (mapcar #'(lambda (x) (append '(boole boole-orc2) x)) integer-pairs)) (setq boole-orc2-test-result (mapcar #'(lambda (x) (append '(logand 1) (list x))) boole-orc2-test-conditions)) (equal (mapcar #'eval boole-orc2-test-result) boole-orc2-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-INTEGER-LENGTH.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-INTEGER-LENGTH.TEST new file mode 100644 index 00000000..68be6c66 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-INTEGER-LENGTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: INTEGER-LENGTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 224 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-INTEGER-LENGTH.TEST ;; ;; ;; Syntax: (INTEGER-LENGTH INTEGER) ;; ;; Function Description: ;; This function performs the computation ;; ;; ;; CEILING(log2(if INTEGER < 0 then -INTEGER else INTEGER+1)) ;; ;; This is useful in two different ways. ;; First, if INTEGER is non-negative, then its value can be represented ;; in unsigned binary form in a field whose width in bits is ;; no smaller than (INTEGER-LENGTH INTEGER). ;; Second, regardless of the sign of INTEGER, its value can be ;; represented in signed binary two's-complement form in a field ;; whose width in bits is no smaller than (+ (INTEGER-LENGTH INTEGER) 1). ;; For example: ;; ;; (INTEGER-LENGTH 0) => 0 ;; (INTEGER-LENGTH 1) => 1 ;; (INTEGER-LENGTH 3) => 2 ;; (INTEGER-LENGTH 4) => 3 ;; (INTEGER-LENGTH 7) => 3 ;; (INTEGER-LENGTH -1) => 0 ;; (INTEGER-LENGTH -4) => 2 ;; (INTEGER-LENGTH -7) => 3 ;; (INTEGER-LENGTH -8) => 3 ;; ;; Compatibility note: This function is similar to the Maclisp ;; function HAULONG. One may define HAULONG as ;; ;; (HAULONG X) = (INTEGER-LENGTH (ABS X)) ;; ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test integer-length-test (and (eq (integer-length 0) 0) (eq (integer-length 1) 1) (eq (integer-length 3) 2) (eq (integer-length 4) 3) (eq (integer-length 7) 3) (eq (integer-length -1) 0) (eq (integer-length -4) 2) (eq (integer-length -7) 3) (eq (integer-length -8) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGAND.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGAND.TEST new file mode 100644 index 00000000..de0f4e44 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGAND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: logand ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.7: Logical Operations on Numbers Page: 221 ;; ;; Created By: John Park ;; ;; Creation Date: July 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-7-logand.test ;; ;; Syntax: logand &rest integers ;; ;; Function Description: This returns the bit-wise logical and or of its ;; arguments. If no argument is given, then the result is -1, which is ;; an identity for this operation. ;; ;; Argument(s): integer(s) ;; ;; Returns: -1 or integer ;; ;; Constraints/limitations: None (do-test logand-test (and (eq (logand 0 0) 0) (eq (logand 0 1) 0) (eq (logand 1 0) 0) (eq (logand 1 1) 1) (eq (logand) -1) (eq (logand 11 5) 1) (eq (logand 7 5 6) 4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC1.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC1.TEST new file mode 100644 index 00000000..1f06b788 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGANDC1 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGANDC1.TEST ;; ;; ;; Syntax: (LOGANDC1 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logandc1-test (and (eq (logand 1 (logandc1 0 0)) 0) (eq (logand 1 (logandc1 0 1)) 1) (eq (logand 1 (logandc1 1 0)) 0) (eq (logand 1 (logandc1 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC2.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC2.TEST new file mode 100644 index 00000000..a7510021 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGANDC2 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGANDC2.TEST ;; ;; ;; Syntax: (LOGANDC2 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logandc2-test (and (eq (logand 1 (logandc2 0 0)) 0) (eq (logand 1 (logandc2 0 1)) 0) (eq (logand 1 (logandc2 1 0)) 1) (eq (logand 1 (logandc2 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGBITP.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGBITP.TEST new file mode 100644 index 00000000..2fb1872a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGBITP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGBITP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 224 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGBITP.TEST ;; ;; ;; Syntax: (LOGBITP INDEX INTEGER) ;; ;; Function Description: ;; LOGBITP is true if the bit in INTEGER whose index ;; is INDEX (that is, its weight is 2^index) is a one-bit; ;; otherwise it is false. ;; For example: ;; ;; (LOGBITP 2 6) IS TRUE ;; (LOGBITP 0 6) IS FALSE ;; (LOGBITP K N) = (LDB-TEST (BYTE 1 K) N) ;; ;; ;; Argument(s): INDEX - an integer ;; INTEGER - an integer ;; ;; Returns: a number ;; (do-test logbitp-test (and (eq (logbitp 2 6) t) (eq (logbitp 0 6) nil) (eq (logbitp 0 1) t) (eq (logbitp 3 15) t))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGCOUNT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGCOUNT.TEST new file mode 100644 index 00000000..7839abe7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGCOUNT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGCOUNT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 224 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGCOUNT.TEST ;; ;; ;; Syntax: (LOGCOUNT INTEGER) ;; ;; Function Description: ;; The number of bits in INTEGER is determined and returned. ;; If INTEGER is positive, then 1 bits in its binary ;; representation are counted. If INTEGER is negative, then ;; the 0 bits in its two's-complement binary representation are counted. ;; The result is always a non-negative integer. ;; For example: ;; ;; ;; (LOGCOUNT 13) => 3 ;Binary representation is ...0001101 ;; (LOGCOUNT -13) => 2 ;Binary representation is ...1110011 ;; (LOGCOUNT 30) => 4 ;Binary representation is ...0011110 ;; (LOGCOUNT -30) => 4 ;Binary representation is ...1100010 ;; ;; The following identity always holds: ;; ;; (LOGCOUNT X) = (LOGCOUNT (- (+ X 1))) ;; = (LOGCOUNT (LOGNOT X)) ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test logcount-test (and (eq (logcount 1) 1) (eq (logcount 10) 2) (eq (logcount 15) 4) (eq (logcount -1) 0) (eq (logcount -30) 4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGEQV.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGEQV.TEST new file mode 100644 index 00000000..4526257d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGEQV.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGEQV ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGEQV.TEST ;; ;; ;; Syntax: (LOGEQV &REST INTEGERS) ;; ;; Function Description: ;; This returns the bit-wise logical EQUIVALENCE (also known as EXCLUSIVE NOR) ;; of its arguments. ;; If no argument is given, then the result is -1, ;; which is an identity for this operation. ;; ;; Argument(s): INTEGERS - an integer ;; ;; Returns: a number ;; (do-test logeqv-test (and (eq (logand 1 (logeqv 0 0)) 1) (eq (logand 1 (logeqv 0 1)) 0) (eq (logand 1 (logeqv 1 0)) 0) (eq (logand 1 (logeqv 1 1)) 1) (eq (logeqv) -1) (eq (logeqv 7 5 6) 4))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGIOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGIOR.TEST new file mode 100644 index 00000000..6ce9b96a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGIOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGIOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGIOR.TEST ;; ;; ;; Syntax: (LOGIOR &REST NUMBERS) ;; ;; Function Description: ;; This returns the bit-wise logical INCLUSIVE OR of its arguments. ;; If no argument is given, then the result is zero, ;; which is an identity for this operation. ;; ;; Argument(s): NUMBERS - numbers ;; ;; Returns: a number ;; (do-test logior-test (and (eq (logior 0 0) 0) (eq (logior 0 1) 1) (eq (logior 1 0) 1) (eq (logior 1 1) 1) (eq (logior 1 3 9) 11))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNAND.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNAND.TEST new file mode 100644 index 00000000..2407940c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNAND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: lognand ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.7: Logical Operations on Numbers Page: 221 ;; ;; Created By: John Park ;; ;; Creation Date: July 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-7-lognand.test ;; ;; Syntax: lognand integer1 integer2 ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test lognand-test (and (eq (logand 1 (lognand 0 0)) 1) (eq (logand 1 (lognand 0 1)) 1) (eq (logand 1 (lognand 1 0)) 1) (eq (logand 1 (lognand 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOR.TEST new file mode 100644 index 00000000..a29595c1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGNOR ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGNOR.TEST ;; ;; ;; Syntax: (LOGNOR INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test lognor-test (and (eq (logand 1 (lognor 0 0)) 1) (eq (logand 1 (lognor 0 1)) 0) (eq (logand 1 (lognor 1 0)) 0) (eq (logand 1 (lognor 1 1)) 0))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOT.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOT.TEST new file mode 100644 index 00000000..5ef676ff --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGNOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 223 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGNOT.TEST ;; ;; ;; Syntax: (LOGNOT INTEGER) ;; ;; Function Description: ;; This returns the bit-wise logical NOT of its argument. ;; Every bit of the result is the complement of the corresponding bit ;; in the argument. ;; ;; (LOGBITP J (LOGNOT X)) = (NOT (LOGBITP J X)) ;; ;; ;; Argument(s): INTEGER - an integer ;; ;; Returns: a number ;; (do-test lognot-test (and (eq (lognot 1) -2) (eq (lognot 0) -1) (eq (lognot -1) 0) (eq (lognot 19) -20))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC1.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC1.TEST new file mode 100644 index 00000000..c45a5f9d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGORC1 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGORC1.TEST ;; ;; ;; Syntax: (LOGORC1 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logorc1-test (and (eq (logand 1 (logorc1 0 0)) 1) (eq (logand 1 (logorc1 0 1)) 1) (eq (logand 1 (logorc1 1 0)) 0) (eq (logand 1 (logorc1 1 1)) 1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC2.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC2.TEST new file mode 100644 index 00000000..6ec7ba6f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGORC2 ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 221 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGORC2.TEST ;; ;; ;; Syntax: (LOGORC2 INTEGER1 INTEGER2) ;; ;; Function Description: ;; These are the other six non-trivial bit-wise logical operations ;; on two arguments. Because they are not associative, ;; they take exactly two arguments rather than any non-negative number ;; of arguments. ;; ;; ;; (LOGNAND N1 N2) = (LOGNOT (LOGAND N1 N2)) ;; (LOGNOR N1 N2) = (LOGNOT (LOGIOR N1 N2)) ;; (LOGANDC1 N1 N2) = (LOGAND (LOGNOT N1) N2) ;; (LOGANDC2 N1 N2) = (LOGAND N1 (LOGNOT N2)) ;; (LOGIORC1 N1 N2) = (LOGIOR (LOGNOT N1) N2) ;; (LOGIORC2 N1 N2) = (LOGIOR N1 (LOGNOT N2)) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logorc2-test (and (eq (logand 1 (logorc2 0 0)) 1) (eq (logand 1 (logorc2 0 1)) 0) (eq (logand 1 (logorc2 1 0)) 1) (eq (logand 1 (logorc2 1 1)) 1))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGTEST.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGTEST.TEST new file mode 100644 index 00000000..6e5e5322 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGTEST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LOGTEST ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.7 Logical Operations on Numbers ;; Page: 223 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-7-LOGTEST.TEST ;; ;; ;; Syntax: (LOGTEST INTEGER1 INTEGER2) ;; ;; Function Description: ;; LOGTEST is a predicate that is true if any of ;; the bits designated by the 1's in INTEGER1 are 1's in INTEGER2. ;; ;; (LOGTEST X Y) = (NOT (ZEROP (LOGAND X Y))) ;; ;; ;; Argument(s): INTEGER1 - an integer ;; INTEGER2 - an integer ;; ;; Returns: a number ;; (do-test logtest-test (and (eq (logtest 1 0) nil) (eq (logtest 0 1) nil) (eq (logtest 1 1) t) (eq (logtest 0 0) nil) (eq (logtest 4 5) t))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGXOR.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGXOR.TEST new file mode 100644 index 00000000..ebf980c0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGXOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: logxor ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.7: Logical Operations on Numbers Page: 220 ;; ;; Created By: John Park ;; ;; Creation Date: July 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-7-logxor.test ;; ;; Syntax: logxor &rest integers ;; ;; Function Description: This returns the bit-wise logical exclusive or of its ;; arguments. If no argument is given, then the result is zero, which is ;; and identity for this operation. ;; Argument(s): integer(s) ;; ;; Returns: zero or integer ;; ;; Constraints/limitations: None (do-test logxor-test (and (eq (logxor 0 0) 0) (eq (logxor 0 1) 1) (eq (logxor 1 0) 1) (eq (logxor 1 1) 0) (zerop (logxor)) (eq (logxor 11 5) 14) (eq (logxor 1 3 9) 11))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-POSITION.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-POSITION.TEST new file mode 100644 index 00000000..9b76c040 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-POSITION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: byte-position ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 23, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-byte-position.test ;; ;; Syntax: byte-position bytespec ;; ;; Function Description: Given a byte specifier, this function returns the ;; position specified as integer. ;; ;; ;; Argument(s): byte-spec (list) ;; ;; Returns: byte-position (integer) ;; ;; Constraints/limitations: None (do-test-group byte-position-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec16-2 (byte 16 2)) (setq byte-spec16-7 (byte 16 7)) (setq byte-spec32-3 (byte 32 3)) (setq byte-spec32-30 (byte 32 30))) (do-test byte-position-test (and (eq (byte-position byte-spec8-0) 0) (eq (byte-position byte-spec8-1) 1) (eq (byte-position byte-spec8-2) 2) (eq (byte-position byte-spec16-2) 2) (eq (byte-position byte-spec16-7) 7) (eq (byte-position byte-spec32-3) 3) (eq (byte-position byte-spec32-30)30)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-SIZE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-SIZE.TEST new file mode 100644 index 00000000..1e9e2800 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE-SIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: byte-size ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 23, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-byte-size.test ;; ;; Syntax: byte-size bytespec ;; ;; Function Description: This function returns the size specified as ;; integer. ;; ;; ;; Argument(s): byte-spec (list) ;; ;; Returns: byte-size (integer) ;; ;; Constraints/limitations: None (do-test-group byte-size-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec16-2 (byte 16 2)) (setq byte-spec16-7 (byte 16 7)) (setq byte-spec32-3 (byte 32 3)) (setq byte-spec32-30 (byte 32 30))) (do-test byte-size-test (and (eq (byte-size byte-spec8-0) 8) (eq (byte-size byte-spec8-1) 8) (eq (byte-size byte-spec8-2) 8) (eq (byte-size byte-spec16-2) 16) (eq (byte-size byte-spec16-7) 16) (eq (byte-size byte-spec32-3) 32) (eq (byte-size byte-spec32-30)32)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE.TEST new file mode 100644 index 00000000..c0b37625 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: byte ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 225 ;; ;; Created By: John Park ;; ;; Creation Date: July 23, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-byte.test ;; ;; Syntax: byte size position ;; ;; Function Description: This function takes two integers representing the ;; size and position of a byte and returns a byte specifier suitable for use ;; as an argument to byte-manipulation functions. ;; ;; Argument(s): size: integer position: integer ;; ;; Returns: byte specification (list) ;; ;; Constraints/limitations: Other implementations such as VAX Lisp 2.0 may return ;; a dotted pair for a byte spec (i.e. (byte 8 1) => '(8 . 1)) instead of ;; '(bytespec 8 1) as returned by XCL implementation). (do-test-group (byte-setup :before (progn (setq byte-spec '((8 0) (8 1) (4 3) (4 2) (16 4) (16 0) (32 10))) (setq byte-spec-others '((8 . 0) (8 . 1) (4 . 3) (4 . 2) (16 . 4) (16 . 0) (32 . 10))) ) ) (do-test "byte-test" (and (setq byte-spec-cases (mapcar #'(lambda (x) (append '(byte) x)) byte-spec)) (setq byte-spec-result (mapcar #'eval byte-spec-cases)) (every #'(lambda (x y) (eql x y)) (mapcar #'byte-size byte-spec-result) (mapcar #'car byte-spec-others)) (every #'(lambda (x y) (eql x y)) (mapcar #'byte-position byte-spec-result) (mapcar #'cdr byte-spec-others)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-DEPOSIT-FIELD.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-DEPOSIT-FIELD.TEST new file mode 100644 index 00000000..896b530f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-DEPOSIT-FIELD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: deposit-field ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 227 ;; ;; Created By: John Park ;; ;; Creation Date: July 24, 86 ;; ;; Last Update: Dec 22, 1986 ;; ;; Filed as: {eris}cml>test>12-8-deposit-field.test ;; ;; Syntax: deposit-field newbyte bytespec integer ;; ;; Function Description: This function returns an integer that contains the ;; bits of newbyte within the byte specified by bytespec, and elsewhere ;; contains the bits of integer. This function is to mask-field as dpb is to ;; ldp. (logbitp j (dpb m (byte s p) n)) => ;; (if (and (>= j p) (< j (+ p s))) (logbitp j m) (logbitp j n)) ;; ;; Argument(s): newbyte bytespec: list integer ;; ;; Returns: integer ;; ;; Constraints/limitations: None (do-test deposit-field-test (let ((bs-8-0 (byte 8 0)) (bs-8-1 (byte 8 1)) (bs-4-0 (byte 4 0)) (bs-4-1 (byte 4 1)) (bs-4-2 (byte 4 2)) (bs-2-0 (byte 2 0)) (bs-2-1 (byte 2 1)) (bs-2-2 (byte 2 2))) (and (= (deposit-field 1 bs-8-0 #b1111) 1) (= (deposit-field 1 bs-8-1 #b1111) 1) (= (deposit-field 1 bs-4-0 #b1101) 1) (= (deposit-field 1 bs-2-1 #b1101) #b1001) (= (deposit-field 1 bs-2-2 #b1101) 1) (= (deposit-field #b101010 bs-8-0 #b11111111) #b101010) (= (deposit-field #b101010 bs-8-1 #b11111111) #b101011) (= (deposit-field #b101010 bs-4-0 #b11111111) #b11111010) (= (deposit-field #b101010 bs-4-1 #b11111111) #b11101011) (= (deposit-field #b101010 bs-4-2 #b11111111) #b11101011) (= (deposit-field #b101010 bs-2-0 #b11111111) #b11111110) (= (deposit-field #b10110110 bs-4-1 #b100000001) #b100010111) (= (deposit-field #b10110110 bs-8-1 #b100000001) #b10110111) (= (deposit-field #b100011011 bs-4-2 #b111101111) #b111011011) (= (deposit-field #b100011011 bs-2-2 #b111101111) #b111101011) (= (deposit-field #b11000111 bs-4-2 #b10110001) #b10000101) (= (deposit-field #b11000111 bs-4-0 #b10110001) #b10110111) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-DPB.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-DPB.TEST new file mode 100644 index 00000000..7249888e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-DPB.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: dpb ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 227 ;; ;; Created By: John Park ;; ;; Creation Date: July 24, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-dpb.test ;; ;; Syntax: dpb newbyte bytespec integer ;; ;; Function Description: This returns a number that is the same as integer ;; except in the bits specified by bytespec. Let s be the size specified by ;; bytespec; then the low s bits of newbyte appear in the result in the byte ;; specified by bytespec. The integer newbyte is therefore interpreted as ;; being right-justified, as if it were the result of ldb. ;; (logbitp j (dpb m (byte s p) n)) ;; => (if (and (>= j p) (< j (+ p s))) (logbitp (- j p) m) (logbitp j n)) ;; ;; Argument(s): newbyte bytespec: list integer ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group dpb-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test dpb-test (and (eq (dpb 1 byte-spec8-0 15) 1) (eq (dpb 1 byte-spec8-1 15) 3) (eq (dpb 1 byte-spec8-2 15) 7) (eq (dpb 1 byte-spec8-3 15) 15) (eq (dpb 1 byte-spec8-4 15) 31) (eq (dpb 3 byte-spec8-0 15) 3) (eq (dpb 3 byte-spec8-1 15) 7) (eq (dpb 3 byte-spec8-2 15) 15) (eq (dpb 3 byte-spec8-3 15) 31) (eq (dpb 3 byte-spec8-4 15) 63) (eq (dpb 5 byte-spec8-0 15) 5) (eq (dpb 5 byte-spec8-1 15) 11) (eq (dpb 5 byte-spec8-2 15) 23) (eq (dpb 5 byte-spec8-3 15) 47) (eq (dpb 5 byte-spec8-4 15) 95)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB-TEST.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB-TEST.TEST new file mode 100644 index 00000000..d4585aaf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB-TEST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ldb-test ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 23, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-ldb-test.test ;; ;; Syntax: ldb-test bytespec integer ;; ;; Function Description: This function returns true if any of the bits ;; designated by the byte specifier bytespec are 1's in integer; that is true ;; if the designated field is non-zero. ;; ;; Argument(s): bytespec: list integer ;; ;; Returns: t or nil ;; ;; Constraints/limitations: None (do-test-group ldb-test-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test ldb-test-test (and (ldb-test byte-spec8-0 15) (ldb-test byte-spec8-1 15) (ldb-test byte-spec8-2 15) (ldb-test byte-spec8-3 15) (eq (ldb-test byte-spec8-4 15) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB.TEST new file mode 100644 index 00000000..319c5d00 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ldb ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 23, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-ldb.test ;; ;; Syntax: ldb bytespec integer ;; ;; Function Description: This function returns a byte of integer to be ;; extracted according to bytespec. For example, if the byte spec is ;; '(8 0) and integer 15, it extracts 8 bits from 15 starting at position 0. ;; ;; ;; Argument(s): bytespec: list integer ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group ldb-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test ldb-test (and (eq (ldb byte-spec8-0 15) 15) (eq (ldb byte-spec8-1 15) 7) (eq (ldb byte-spec8-2 15) 3) (eq (ldb byte-spec8-3 15) 1) (eq (ldb byte-spec8-4 15) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-8-MASK-FIELD.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-8-MASK-FIELD.TEST new file mode 100644 index 00000000..0861ca6f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-MASK-FIELD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: mask-field ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.8: Byte Manipulation Functions ;; on Numbers Page: 226 ;; ;; Created By: John Park ;; ;; Creation Date: July 24, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-8-mask-field.test ;; ;; Syntax: mask-field bytespec integer ;; ;; Function Description: This is similar to ldb; however, the result contains ;; the specified byte of integer in the position specified by bytespec, rather ;; than in position 0 as with ldb. The result therefore agrees with integer ;; in the byte specified but has zero-bits everywhere else. ;; ;; ;; Argument(s): bytespec: list integer ;; ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group mask-field-setup :before (progn (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4))) (do-test mask-field-test (and (eq (mask-field byte-spec8-0 15) 15) (eq (mask-field byte-spec8-1 15) 14) (eq (mask-field byte-spec8-2 15) 12) (eq (mask-field byte-spec8-3 15) 8) (eq (mask-field byte-spec8-4 15) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-9-MAKE-RANDOM-STATE.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-9-MAKE-RANDOM-STATE.TEST new file mode 100644 index 00000000..52fe7bf1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-9-MAKE-RANDOM-STATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-random-state ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.9: Random Numbers ;; Page: 228 ;; ;; Created By: John Park ;; ;; Creation Date: July 22, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - removed case which is implementation dependent ;; ;; Filed as: {eris}cml>test>12-9-make-random-state.test ;; ;; Syntax: make-random-state &optional state ;; ;; Function Description: This function returns a new object of type random-state, ;; suitable for use as the value of the variable *random-state*. If state is nil ;; or omitted, random-state returns a copy of the current random-number state ;; object. If state is a state object, a copy of that state object is returned. ;; If state is t, then a new state object is returned that has been "randomly" ;; initialized by some means (i.e. time-of-day clock). ;; ;; Argument(s): t, nil, or optional state ;; ;; Returns: object of type random-state ;; ;; Constraints/limitations: None (do-test-group make-random-state-test-setup :before (progn (setq random-state1 (make-random-state)) (setq random-state2 (make-random-state)) (setq random-state3 (make-random-state))) (do-test *random-state*-exist? (and (boundp '*random-state*) (random-state-p *random-state*))) (do-test make-random-state-test (and (random-state-p (make-random-state)) (random-state-p (make-random-state *random-state*)) (random-state-p (make-random-state random-state1))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM-STATE-P.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM-STATE-P.TEST new file mode 100644 index 00000000..05f7a3e0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM-STATE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: random-state-p ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.9: Random Numbers ;; Page: 231 ;; ;; Created By: John Park ;; ;; Creation Date: July 22, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>12-9-random-state-p.test ;; ;; Syntax: random-state-p &optional state ;; ;; Function Description: This function returns true if its argument ;; a random-state object, and otherwise is false. ;; ;; Argument(s): object ;; ;; Returns: object of type random-state ;; ;; Constraints/limitations: None (do-test-group random-state-p-test-setup :before (progn (setq random-state1 (make-random-state)) (setq random-state2 (make-random-state)) (setq random-state3 (make-random-state))) (do-test random-state-p-test (and (random-state-p random-state1) (random-state-p random-state2) (random-state-p random-state3) (random-state-p *random-state*) (eq(random-state-p 'random-state) nil) (eq (random-state-p 1234) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM.TEST new file mode 100644 index 00000000..8f0cf36b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: random ;; ;; Source: Common Lisp by Guy Steele ;; Section 12.9: Random Numbers ;; Page: 228 ;; ;; Created By: John Park ;; ;; Creation Date: July 22, 86 ;; ;; Last Update: Jan 28, 1987 Jim Blum - fixed (COND ... NIL) to (COND ... (T NIL)) ;; ;; Filed as: {eris}cml>test>12-9-random.test ;; ;; Syntax: random number &optional state ;; ;; Function Description: This function accepts a positive integer n and returns ;; a number of the same kind between 0 (inclusive) and n (exclusive). ;; The argument state must be an object of type random-state; it defaults to the ;; value of the variable *random-state*. ;; ;; Argument(s): number: positive integer or positive floating-point number ;; state (optional): object of type random-state. ;; ;; Returns: random number between 0 (inclusive) and specified number (exclusive). ;; ;; Constraints/limitations: None (do-test-group random-test-setup :before (progn (setq random-state1 (make-random-state)) (setq random-state2 (make-random-state)) (setq random-state3 (make-random-state)) (setq random-values '(1 3 7.4 10 38 100 860 99999.888 most-positive-double-float least-positive-double-float)) (setq random-original (mapcar #'eval random-values)) (setq random-state-values '((19 random-state1) (100 random-state2) (999.9 random-state3))) (setq random-state-original (mapcar #'(lambda (x) (car x)) random-state-values)) (setq random-state-first (mapcar #'(lambda (x)(union '() x)) random-state-values)) (defun check-final-values (random-pairs) (cond ((and(or(= (cdr random-pairs) (car random-pairs)) (< (cdr random-pairs) (car random-pairs))) (or (zerop (cdr random-pairs)) (plusp (cdr random-pairs)))) t) (t nil)))) (do-test random-test (and (setq random-final (mapcar #'random random-original)) (setq random-result-pairs (pairlis random-original random-final)) (setq random-test-result (mapcar #'check-final-values random-result-pairs)) (notany #'null random-test-result) (setq random-state-final (mapcar #'eval (mapcar #'(lambda (x) (append '(random) x)) random-state-values))) (setq random-state-pairs (pairlis random-state-original random-state-final)) (setq random-state-result (mapcar #'check-final-values random-result-pairs)) (notany #'null random-state-result)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-1-CHARACTERATTRIBUTES.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-1-CHARACTERATTRIBUTES.TEST new file mode 100644 index 00000000..6ba9f51f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-1-CHARACTERATTRIBUTES.TEST @@ -0,0 +1 @@ +;; To Be Tested: Character-attributes constants ;; ;; Source: CLtL pp. 233-234 ;; ;; Chapter 13: Characters Section : Character Attributes ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 8 October 86 - change plusp to not minusp and remove an implementation-dependent test. ;; ;; Filed As: {eris}cml>test>13-1-character-attributes.test ;; ;; Test Description: See that the constants are defined and that they are non-negative; see that char-bits-limit is a power of 2. ;; (do-test-group character-attributes-group (do-test char-code-limit-exists? ;; ensure that char-code-limit is bound (and (boundp 'char-code-limit) (not (minusp char-code-limit)) ) ) ;; ;; This will probably come out, since we don't support the font attribute. (do-test char-font-limit-exists? ;; ensure that char-font-limit is bound (and (boundp 'char-font-limit) (not (minusp char-font-limit)) ) ) ;; ;; Only zero for first delivery (do-test char-bits-limit-exists? ;; ensure that char-bits-limit is bound (and (boundp 'char-bits-limit) (not (minusp char-bits-limit)) ;; See if it's a power of 2 (i.e. if its base-2 log is a an integer). (or (= 0 char-bits-limit) (= 0 (- (log char-bits-limit 2) (truncate (log char-bits-limit 2)))) ) ; or ) ; and ) ; do-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHA-CHAR-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHA-CHAR-P.TEST new file mode 100644 index 00000000..0fb11db3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHA-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: alpha-char-p ;; ;; Source: CLtL p. 235375 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-alpha-char-p.test ;; ;; Syntax: alpha-char-p char ;; ;; Function Description: true if char is an alphabetic character, nil otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test-group (do-test "alpha-char-p on alpha characters" (every 'alpha-char-p '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) ) ; do-test "alpha-char-p on alpha characters" ;; (do-test "alpha-char-p on semi-standard characters" (notany #'alpha-char-p '(#\backspace #\tab #\linefeed #\page #\return #\rubout)) ) ; do-test "alpha-char-p on semi-standard characters" ;; (do-test "alpha-char-p on digits" (notany 'alpha-char-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ; do-test "alpha-char-p on digits" ;; (do-test "alpha-char-p on other graphic characters" (notany 'alpha-char-p '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) ) ; do-test "alpha-char-p on other graphic characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHANUMERIC-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHANUMERIC-P.TEST new file mode 100644 index 00000000..5b30e9bc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-ALPHANUMERIC-P.TEST @@ -0,0 +1 @@ +;;; Section 13.2: Predicates on Characters ;;; Peter Reidy after Greg Nuyens, 30 April 86 ;;; See if alphanumeric-p is true for just the alphabetic and numeric characters - not semi-standard characters or other graphic characters. ;;; Filed as {eris}cml>test>13-2-alphanumeric-p.tst (do-test alphanumericp-test (every #'alphanumericp '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (every #'alphanumericp '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (notany #'alphanumericp '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-BOTH-CASE-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-BOTH-CASE-P.TEST new file mode 100644 index 00000000..0700beb3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-BOTH-CASE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: both-case-p ;; ;; Source: CLtL p. 235 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 8 October 86 ;; ;; Last Update: 8 October 86 ;; ;; Filed As: {eris}cml>test>13-2-both-case-p.test ;; ;; Syntax: both-case-p char ;; ;; Function Description: Returns non-nil iff char is a character with both uppper- and lower-case representations (i.e. the 25 letters of the alphabet) and NIL for any other character; does not accept arguments other than characters. ;; ;; Argument(s): char - any cml character ;; ;; Returns: non-nil or NIL ;; (do-test both-case-p-test (let ((both-case-egs '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (semi-standard-egs '(#\backspace #\tab #\linefeed #\page #\return #\rubout)) (digit-egs '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)) (other-graphic-egs '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\ )) ) (and (every #'both-case-p both-case-egs) (notany #'both-case-p semi-standard-egs) (notany #'both-case-p digit-egs) (notany #'both-case-p other-graphic-egs) ) ; and ) ; let ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-EQUAL.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-EQUAL.TEST new file mode 100644 index 00000000..24d1d0b1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-equal ;; ;; Source: CLtL p. 239 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-equal.test ;; ;; Syntax: char-equal char &rest more-characters ;; ;; Function Description: true if all characters are the same apart from difference in case, bits or fonts attributes, nil otherwise ;; ;; Argument(s): character ;; ;; Returns: non-nil or nil ;; ;; NOTE: This file does not test bit or font attributes. (do-test-group (char-equal-group :before (test-setq upcase '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) lowcase '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) non-alpha '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ ) stdchars (concatenate 'list upcase lowcase non-alpha) semistd '(#\Backspace #\Tab #\Linefeed #\Page #\Return #\Rubout) pagechar #\page ) ; test-setq ) ; char-equal-group ;; (do-test "every character is char-equal itself" (and (every 'char-equal stdchars stdchars) (every 'char-equal semistd (list #\backspace #\TAB #\lINEfEEd pagechar #\rEtUrN #\Rubout)) ) ; and ) ; do-test "every character is char-equal itself" ;; (do-test "char-equal ignores differences in case" (and (every 'char-equal lowcase (mapcar 'char-upcase lowcase)) (every 'char-equal upcase (mapcar 'char-downcase upcase)) (every 'char-equal (mapcar 'char-upcase stdchars) (mapcar 'char-downcase stdchars)) ) ; and ) ; do-test "char-equal ignores differences in case" ;; (do-test "char-equal with >2 characters" (and (every 'char-equal stdchars stdchars (mapcar 'char-upcase stdchars)) (every 'char-equal semistd semistd semistd (mapcar 'char-downcase semistd)) ) ) ; do-test "char-equal with >2 characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GE.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GE.TEST new file mode 100644 index 00000000..2bac3b1c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char>= ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-ge.test ;; ;; Syntax: char>= char &rest more-characters ;; ;; Function Description: true if each character >= the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char>=group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char>=: upper-case characters in order are >=" (char>= #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char>=: lower-case characters in order are >=" (char>= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char>=: digits in order are >=" (char>= #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char>=: #\A >= #\9 or #\0 >= Z" (or (char>= #\A #\9 ) (char>= #\0 #\Z)) ) ;; (do-test "char>=: #\a >= #\9 or #\0 >= z" (or (char>= #\a #\9 ) (char>= #\0 #\z )) ) ;; (do-test "char>= accepts characters that are char=" (and (char>= #\3 #\3 #\3 #\3) (char>= #\Q #\Q #\Q #\Q #\P) ) ) ;; (do-test "char>= accepts non-alphanumeric characters" (and (char>= #\; #\; #\;) (char>= #\space #\space #\space) ) ) ;; (do-test "char>=: every item must >=" (not (or (char>= #\3 #\3 #\3 #\3 #\4) (char>= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a #\b) )) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GREATERP.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GREATERP.TEST new file mode 100644 index 00000000..dd4ebb16 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-greaterp ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-greaterp.test ;; ;; Syntax: char-greaterp char &rest more-characters ;; ;; Function Description: true if each character is greater than the next (ignoring differences in font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file doesn't test font or bit attributes. (do-test-group char-greaterp-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char-greaterp-upper-case" (char-greaterp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char-greaterp-lower-case" (char-greaterp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char-greaterp-digits" (char-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char-greaterp-digits-outside-upper-case" (or (char-greaterp #\A #\9 ) (char-greaterp #\0 #\Z)) ) ;; (do-test "char-greaterp-digits-outside-lower-case" (or (char-greaterp #\a #\9 ) (char-greaterp #\0 #\z)) ) ;; (do-test "char-greaterp ignores case differences" (char-greaterp #\z #\Y #\x #\W #\V #\u #\T #\S #\r #\q #\P #\o #\N #\m #\L #\k #\J #\i #\H #\g #\F #\e #\D #\c #\B #\a) ) ;; (do-test "char-greaterp: characters needn't be contiguous" (every 'char-greaterp '(#\Z #\e #\9) '(#\a #\B #\0)) ) ; do-test "char-greaterp: characters needn't be contiguous" ;; (do-test "char<: every character must be strictly less than the next" (not (or (char-greaterp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A #\a) (char-greaterp #\Z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) (char-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0 #\0) )) ) ; do-test "char<: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GT.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GT.TEST new file mode 100644 index 00000000..bb4015fe --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-GT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char> ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-gt.test ;; ;; Syntax: char> char &rest more-characters ;; ;; Function Description: true if each character is greater than the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char>-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char>-upper-case" (char> #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char>-lower-case" (char> #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char>-digits" (char> #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char>-digits-outside-upper-case" (or (char> #\A #\9 ) (char> #\0 #\Z)) ) ;; (do-test "char>-digits-outside-lower-case" (or (char> #\a #\9 ) (char> #\0 #\z)) ) ;; (do-test "char>: characters needn't be contiguous" (every 'char> '(#\Z #\e #\9) '(#\A #\b #\0)) ) ; do-test "char>: characters needn't be contiguous" ;; (do-test "char<: every character must be strictly less than the next" (not (or (char> #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A #\A) (char> #\z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) (char> #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0 #\0) )) ) ; do-test "char<: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LE.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LE.TEST new file mode 100644 index 00000000..8e96b430 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char<= ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-le.test ;; ;; Syntax: char<= char &rest more-characters ;; ;; Function Description: true if each character is <= the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char<=-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper-case characters in order are all char<=" (char<= #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ; do-test "upper-case characters in order are all char<=" ;; (do-test "lower-case characters in order are all char<=" (char<= #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ; do-test "lower-case characters in order are all char<=" ;; (do-test "digits in order are all char<=" (char<= #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ; do-test "digits in order are all char<=" ;; (do-test "#\9 <= #\A or #\Z #\0" (or (char<= #\9 #\A ) (char<= #\Z #\0)) ) ; do-test "#\9 <= #\A or #\Z #\0" ;; (do-test "#\9 <= #\a or #\z #\0" (or (char<= #\9 #\a ) (char<= #\z #\0)) ) ; do-test "#\9 <= #\a or #\z #\0" ;; (do-test "char<= accepts char= characters" (and (char<= #\c #\c #\c #\c #\c #\c #\c #\c) (char<= #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\8) (char<= #\0 #\0 #\0 #\2 #\2 #\2 #\4 #\4 #\4) ) ; and ) ; do-test "char<= accepts char= characters" ;; (do-test "char<= accepts non-alphanumeric characters" (every 'char<= '(#\newline #\") '(#\newline #\")) ) ; do-test "char<= accepts non-alphanumeric characters" ;; (do-test "char<=: every character must <=" (not (or (char<= #\X #\X #\X #\W #\X #\X #\X #\X) (char<= #\5 #\5 #\5 #\5 #\5 #\5 #\4) )) ) ; do-test "char<=: every character must <=" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LESSP.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LESSP.TEST new file mode 100644 index 00000000..84faa429 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-lessp ;; ;; Source: CLtL p. 239 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-lessp.test ;; ;; Syntax: char-lessp char &rest more-characters ;; ;; Function Description: true if each character is less than the next (ignoring differences of font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file doesn't test font or bit attributes. (do-test-group char-lessp-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper case letters in order are char-lessp" (char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ;; (do-test "lower case letters in order are char-lessp" (char-lessp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ;; (do-test "char-lessp ignores case differences" (char-lessp #\a #\B #\c #\D #\e #\F #\g #\H #\i #\J #\k #\L #\m #\N #\o #\P #\q #\R #\s #\T #\u #\V #\w #\X #\y #\Z) ) ;; (do-test "digits in order are char-lessp" (char-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ;; (do-test "#\9 char-lessp #\A or #\Z char-lessp 0" (or (char-lessp #\9 #\A) (char-lessp #\Z #\0)) ) ;; (do-test "#\9 char-lessp #\a or #\z char-lessp 0" (or (char-lessp #\9 #\a) (char-lessp #\z #\0)) ) ;; (do-test "char-lessp: characters needn't be contiguous" (every 'char-lessp '(#\A #\A #\b #\0) '(#\Z #\z #\e #\9)) ) ; do-test "char-lessp: characters needn't be contiguous" ;; (do-test "char-lessp: every character must be strictly less than the next" (not (or (char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\Z) (char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\z) (char-lessp #\a #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) (char-lessp #\a #\A #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) (char-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9) )) ) ; do-test "char-lessp: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LT.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LT.TEST new file mode 100644 index 00000000..ccaa20c2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-LT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char< ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-lt.test ;; ;; Syntax: char< char &rest more-characters ;; ;; Function Description: true if each character is less than the next, nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char<-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper case letters in order are char<" (char< #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ;; (do-test "lower case letters in order are char<" (char< #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ;; (do-test "digits in order are char<" (char< #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ;; (do-test "#\9 char< #\A or #\Z char< 0" (or (char< #\9 #\A) (char< #\Z #\0)) ) ;; (do-test "#\9 char< #\a or #\z char< 0" (or (char< #\9 #\a) (char< #\z #\0)) ) ;; (do-test "char<: characters needn't be contiguous" (every 'char< '(#\A #\b #\0) '(#\Z #\e #\9)) ) ; do-test "char<: characters needn't be contiguous" ;; (do-test "char<: every character must be strictly less than the next" (not (or (char< #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\Z) (char< #\a #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) (char< #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9) )) ) ; do-test "char<: every character must be strictly less than the next" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-EQUAL.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-EQUAL.TEST new file mode 100644 index 00000000..985e335e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-not-equal ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 5 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-char-not-equal.test ;; ;; Syntax: char-not-equal char &rest more-characters ;; ;; Function Description: true if all characters are different (apart from differences in font, bit or case attributes, which the function ignores), nil otherwise. ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file doesn't test font or bit attributes (do-test-group (char-not-equal-group :before (test-setq allchars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\newline #\backspace #\linefeed #\tab #\page #\return #\rubout) allcharsb (concatenate 'list (cdr allchars) (list (car allchars))) ) ; test-setq ) ; char-not-equal-group ;; (do-test "No character is char-not-equal itself" (notany 'char-not-equal allchars allchars allchars) ) ;; (do-test "distinct characters are always char-not-equal" (every 'char-not-equal allchars allcharsb) ) ;; (do-test "char-not-equal ignores case differences" (and (notany 'char-not-equal allchars (mapcar 'char-upcase allchars)) (notany 'char-not-equal allchars (mapcar 'char-downcase allchars)) ) ) ;; (do-test "char-not-equal: all characters must be distinct" (not (char-not-equal #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\newline #\backspace #\linefeed #\tab #\page #\return #\A)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-GREATERP.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-GREATERP.TEST new file mode 100644 index 00000000..ee495066 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-not-greaterp ;; ;; Source: CLtL p. 239 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-not-greaterp.test ;; ;; Syntax: char-not-greaterp char &rest more-characters ;; ;; Function Description: true if each character is <= the next (ignoring differences in font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; (do-test-group char-not-greaterp-group ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "upper-case characters in order are all char-not-greaterp" (char-not-greaterp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ; do-test "upper-case characters in order are all char-not-greaterp" ;; (do-test "lower-case characters in order are all char-not-greaterp" (char-not-greaterp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ; do-test "lower-case characters in order are all char-not-greaterp" ;; (do-test "char-not-greaterp ignores case differences" (char-not-greaterp #\A #\b #\C #\d #\E #\f #\G #\h #\I #\j #\K #\l #\M #\n #\O #\p #\Q #\r #\S #\t #\U #\v #\W #\x #\Y #\z) ) ; do-test "char-not-greaterp ignores case differences" ;; (do-test "digits in order are all char-not-greaterp" (char-not-greaterp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ) ; do-test "digits in order are all char-not-greaterp" ;; (do-test "#\9 <= #\A or #\Z #\0" (or (char-not-greaterp #\9 #\A ) (char-not-greaterp #\Z #\0)) ) ; do-test "#\9 <= #\A or #\Z #\0" ;; (do-test "#\9 <= #\a or #\z #\0" (or (char-not-greaterp #\9 #\a ) (char-not-greaterp #\z #\0)) ) ; do-test "#\9 <= #\a or #\z #\0" ;; (do-test "char-not-greaterp accepts char-equal characters" (and (char-not-greaterp #\c #\C #\c #\c #\C #\C #\c #\C) (char-not-greaterp #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\7 #\8) (char-not-greaterp #\0 #\0 #\0 #\2 #\2 #\2 #\4 #\4 #\4) ) ; and ) ; do-test "char-not-greaterp accepts char= characters" ;; (do-test "char-not-greaterp accepts non-alphanumeric characters" (every 'char-not-greaterp '(#\newline #\") '(#\newline #\")) ) ; do-test "char-not-greaterp accepts non-alphanumeric characters" ;; (do-test "char-not-greaterp: every character must <=" (not (or (char-not-greaterp #\X #\X #\x #\W #\X #\X #\X #\X) (char-not-greaterp #\5 #\5 #\5 #\5 #\5 #\5 #\4) )) ) ; do-test "char-not-greaterp: every character must <=" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-LESSP.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-LESSP.TEST new file mode 100644 index 00000000..05d2709c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAR-NOT-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-not-lessp ;; ;; Source: CLtL p. 239 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 9 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>13-2-char-not-lessp.test ;; ;; Syntax: char-not-lessp char &rest more-characters ;; ;; Function Description: true if each character >= the next (ignoring differences in font, bits or case), nil otherwise ;; ;; Argument(s): characters ;; ;; Returns: non-nil or nil ;; ;; NOTE: this file does not test font or bit attributes (do-test-group char-not-lesspgroup ;;; The inequality must be true for all items, and the function is nospread. Hence no every loop. (do-test "char-not-lessp: upper-case characters in order are >=" (char-not-lessp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) ) ;; (do-test "char-not-lessp: lower-case characters in order are >=" (char-not-lessp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) ) ;; (do-test "char-not-lessp ignores case differences" (char-not-lessp #\z #\Y #\x #\W #\v #\U #\t #\S #\r #\Q #\p #\O #\n #\M #\l #\K #\j #\I #\h #\G #\f #\E #\d #\C #\b #\A) ) ;; (do-test "char-not-lessp: digits in order are >=" (char-not-lessp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) ) ;; (do-test "char-not-lessp: #\A >= #\9 or #\0 >= Z" (or (char-not-lessp #\A #\9 ) (char-not-lessp #\0 #\Z)) ) ;; (do-test "char-not-lessp: #\a >= #\9 or #\0 >= z" (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z)) ) ;; (do-test "char-not-lessp accepts characters that are char-equal" (and (char-not-lessp #\3 #\3 #\3 #\3) (char-not-lessp #\Q #\q #\Q #\q #\P #\p) ) ) ;; (do-test "char-not-lessp accepts non-alphanumeric characters" (and (char-not-lessp #\; #\; #\;) (char-not-lessp #\space #\space #\space) ) ) ;; (do-test "char-not-lessp: every item must >=" (not (or (char-not-lessp #\3 #\3 #\3 #\3 #\4) (char-not-lessp #\z #\y #\x #\w #\v #\U #\T #\S #\r #\q #\p #\o #\n #\m #\l #\k #\j #\I #\h #\G #\F #\e #\d #\c #\b #\a #\b) )) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAREQ.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAREQ.TEST new file mode 100644 index 00000000..046f6742 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAREQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char= ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 5 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-chareq.test ;; ;; Syntax: char= char &rest more-characters ;; ;; Function Description: true if all characters are the same, nil otherwise ;; ;; Argument(s): character ;; ;; Returns: non-nil or nil ;; (do-test-group (char=-group :before (test-setq stdchars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ ) semistd '(#\Backspace #\Tab #\Linefeed #\Page #\Return #\Rubout) pagechar #\page) ) ; char=-group ;; (do-test "every character is char= itself" (and (every 'char= stdchars stdchars) (every 'char= semistd (list #\backspace #\TAB #\lINEfEEd pagechar #\rEtUrN #\Rubout)) ) ; and ) ; do-test "every character is char= itself" ;; (do-test "char= with >2 characters" (and (every 'char= stdchars stdchars stdchars) (every 'char= semistd semistd semistd semistd) ) ) ; do-test "char= with >2 characters" ;; (do-test "char= negative tests" (and (notevery 'char= stdchars (mapcar 'char-downcase stdchars)) (not (char= #\Z #\Z #\Z #\Z #\z)) ) ) ; do-test "char= negative tests" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHARNEQ.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHARNEQ.TEST new file mode 100644 index 00000000..34e231f9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHARNEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char/= ;; ;; Source: CLtL p. 237 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 5 May 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-charneq.test ;; ;; Syntax: char/= char &rest more-characters ;; ;; Function Description: true if all characters are different, nil otherwise. ;; ;; Argument(s): character ;; ;; Returns: non-nil or nil ;; (do-test-group (char/=-group :before (test-setq allchars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\newline #\backspace #\linefeed #\tab #\page #\return #\rubout) allcharsb (concatenate 'list (cdr allchars) (list (car allchars))) ) ) ; char/=-group ;; (do-test "char/=: no character is char/= itself" (notany 'char/= allchars allchars allchars) ) ;; (do-test "char/= for all characters" (every 'char/= allchars allcharsb) ) ; do-test "char/= for all characters" ;; (do-test "char/= takes more than two arguments" (and (char= #\a #\a #\a #\a #\a #\a (char-downcase #\A) (char-downcase #\a)) (not (char/= #\a #\a #\a #\a #\a #\a (char-downcase #\A) (char-downcase #\a))) ) ; and ) ; do-test "char/= takes more than two arguments; all characters must be different" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-DIGIT-CHAR-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-DIGIT-CHAR-P.TEST new file mode 100644 index 00000000..4e55389a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-DIGIT-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: digit-char-p ;; ;; Source: CLtL p. 236 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-digit-char-p.test ;; ;; Syntax: digit-char-p char &optional radix ;; ;; Function Description: Returns non-nil iff char is a digit of the current radix, not for digits of another radix or for semi-standard or other graphic characters. char must be a character. ;; ;; Argument(s): char - any cml character ;; radix - an integer ;; ;; Returns: non-nil or NIL ;; (do-test-group (digit-char-p-group :before (test-setq digit-char-egs '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) upper-case-egs '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) lower-case-egs '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) semi-standard-egs '(#\backspace #\tab #\linefeed #\page #\return #\rubout) other-graphic-egs '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\ ) ) ; test-setq ) ; digit-char-p-group ;; for the default case: radix 10 (do-test digit-char-p-with-decimal-test (and (every #'digit-char-p digit-char-egs) (every #'digit-char-p digit-char-egs '(#3r101)) (notany #'digit-char-p upper-case-egs) (notany #'digit-char-p lower-case-egs) (notany #'digit-char-p semi-standard-egs) (notany #'digit-char-p other-graphic-egs) ) ; and ) ; do-test digit-char-p-with-decimal-test ;; for binary (do-test digit-char-p-with-binary-test (and (every #'digit-char-p '(#\0 #\1) (list 2)) ;; #\2 - #\9 will fail. (notany #'digit-char-p (cddr digit-char-egs) (list 2)) (notany #'digit-char-p upper-case-egs (list 2)) (notany #'digit-char-p lower-case-egs (list 2)) (notany #'digit-char-p semi-standard-egs (list 2)) (notany #'digit-char-p other-graphic-egs (list 2)) ) ; and ) ; do-test digit-char-p-with-binary-test ;; for octal (do-test digit-char-p-with-octal-test (and (every #'digit-char-p '(#\0 #\1 #\2 #\2 #\3 #\5 #\6 #\7) (list 8)) (null (digit-char-p #\8 #7r11)) (notany #'digit-char-p upper-case-egs (list 8)) (notany #'digit-char-p lower-case-egs (list 8)) (notany #'digit-char-p semi-standard-egs (list 8)) (notany #'digit-char-p other-graphic-egs (list 8)) ) ; and ) ; do-test digit-char-p-with-octal-test ;; for hexadecimal (do-test digit-char-p-with-hexadecimal-test (and (every #'digit-char-p '(#\0 #\1 #\2 #\2 #\3 #\5 #\6 #\7 #\8 #\9 #\A #\a #\B #\b #\C #\c #\D #\d #\E #\e #\F #\f) (list 16)) (notany #'digit-char-p '(#\g #\G) (list 16)) (notany #'digit-char-p semi-standard-egs (list 16)) (notany #'digit-char-p other-graphic-egs (list 16)) ) ; and ) ; do-test digit-char-p-with-hexadecimal-test ;; for base 35 (do-test digit-char-p-with-base-35-test (and (every #'digit-char-p '(#\0 #\1 #\2 #\2 #\3 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) (list 35)) (notany #'digit-char-p semi-standard-egs (list 35)) (notany #'digit-char-p other-graphic-egs (list 35)) ) ; and ) ; do-test digit-char-p-with-base-35-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-GRAPHIC-CHAR-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-GRAPHIC-CHAR-P.TEST new file mode 100644 index 00000000..c0c7c8e0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-GRAPHIC-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: graphic-char-p ;; ;; Source: CLtL p. 234 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 8 October 86 ;; ;; Filed As: {eris}cml>test>13-2-graphic-char-p.test ;; ;; Syntax: graphic-char-p char ;; ;; Function Description: Returns non-nil iff char is a graphic character (any standard character except #\newline; space; none of the semi-standard characters) and NIL for any other character; does not accept arguments other than characters. ;; ;; Argument(s): char - any cml character ;; ;; Returns: non-nil or NIL ;; (do-test graphic-char-p-test (and (every 'graphic-char-p '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\ ) ) (notany #'graphic-char-p '(#\backspace #\tab #\linefeed #\page #\return #\rubout #\newline)) ) ; and ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-LOWER-CASE-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-LOWER-CASE-P.TEST new file mode 100644 index 00000000..3f6309a2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-LOWER-CASE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: lower-case-p ;; ;; Source: CLtL p. 234 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-lower-case-p.test ;; ;; Syntax: lower-case-p char ;; ;; Function Description: Returns non-nil iff char is a lower case character and NIL for any other character - upper case, digit and semi-standard; does not accept arguments other than characters. ;; ;; Argument(s): char - any cml character ;; ;; Returns: non-nil or NIL ;; (do-test-group (do-test "lower-case-p for lower-case characters" ;; Each lower-case character satisfies the predicate and and its upper-case counterpart does not. (every #'(lambda (char) (and (lower-case-p char) (not (lower-case-p (char-upcase char)))) ) '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ) ; do-test "upper-case-p for upper-case characters" ;; (do-test "lower-case-p for upper-case characters" ;; No upper-case character satisfies the predicate, but each one's lower-case counterpart does. (every #'(lambda (char) (and (not (lower-case-p char))(lower-case-p (char-downcase char)))) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ) ; do-test "upper-case-p for lower-case characters" ;; (do-test "upper-case-p for non-alpha characters" (notany #'lower-case-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ #\backspace #\tab #\linefeed #\page #\return #\rubout)) ) ; do-test "upper-case-p for non-alpha characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-STANDARD-CHAR-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-STANDARD-CHAR-P.TEST new file mode 100644 index 00000000..a2fbb065 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-STANDARD-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: standard-char-p ;; ;; Source: CLtL p. 234 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 P.R. ;; ;; Filed As: {eris}cml>test>13-2-standard-char-p.test ;; ;; Syntax: standard-char-p char ;; ;; Function Description: true iff char is a standard character (CLtL p. 21), NIL otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test-group ;; NOTE: fails in 6 December sysout on #\$ and $\&. See AR 7038. (do-test "standard-char-p standard characters test" (every 'standard-char-p ;; 94 standard characters (CLtL p. 21) plus space and newline (2 notations each) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) ) ; do-test "standard-char-p standard characters test" ;; (do-test "standard-char-p negative test" (notany 'standard-char-p (list "j" 'j (symbol-name 'j) "#\j")) ) ; do-test "standard-char-p negative test" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-STRING-CHAR-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-STRING-CHAR-P.TEST new file mode 100644 index 00000000..98491d60 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-STRING-CHAR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-char-p ;; ;; Source: CLtL p. 235 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy after Greg Nuyens ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-string-char-p.test ;; ;; Syntax: write-char string-char-p char ;; ;; Function Description: true if char is of type string-char, nil otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test string-char-p-test (every #'string-char-p ;; 94 standard characters (CLtL p. 21) plus space and newline (2 notations each) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ ) ) ; every ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-2-UPPER-CASE-P.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-2-UPPER-CASE-P.TEST new file mode 100644 index 00000000..9e3cee26 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-UPPER-CASE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: upper-case-p ;; ;; Source: CLtL p. 235 ;; ;; Chapter 13: Characters Section 2: Predicates on Characters ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 30 April 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>13-2-upper-case-p.test ;; ;; Syntax: upper-case-p char ;; ;; Function Description: true if char is an upper-case character, nil otherwise ;; ;; Argument(s): char - a character ;; ;; Returns: non-nil or nil ;; (do-test-group (do-test "upper-case-p for upper-case characters" ;; Each upper-case character satisfies the predicate and and its lower-case counterpart does not. (every #'(lambda (char) (and (upper-case-p char) (not (upper-case-p (char-downcase char)))) ) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) ) ) ; do-test "upper-case-p for upper-case characters" ;; (do-test "upper-case-p for lower-case characters" ;; No lower-case character satisfies the predicate, but each one's upper-case counterpart does. (every #'(lambda (char) (and (not (upper-case-p char)) (upper-case-p (char-upcase char))) ) '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) ) ) ; do-test "upper-case-p for lower-case characters" ;; (do-test "upper-case-p for non-alpha characters" (notany #'upper-case-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ #\backspace #\tab #\linefeed #\page #\return #\rubout)) ) ; do-test "upper-case-p for non-alpha characters" ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-BITS.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-BITS.TEST new file mode 100644 index 00000000..68b2f87b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-BITS.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 240 ;; Author: John Park ;; Creation date: April 30, 86 ;; Functions to be tested: char-bits ;; Filed in {eris}cml>test>13-3-char-bits.tst (do-test char-bits-test ; returns the bits attribute of the character object (every #'char-bits '(#\a #\A #\b #\B #\* #\+ #\2))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-CODE.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-CODE.TEST new file mode 100644 index 00000000..b9695335 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-CODE.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 239 ;; Author: John Park ;; Creation date: April 30, 86 ;; Function to be tested: char-code ;; Filed in {eris}cml>test>13-3-Char-Code.tst (do-test char-code-test ; returns the code attribute of the character object (and (< (char-code #\A ) 65536) (< (char-code #\a ) 65536) (< (char-code #\1 ) 65536) (and (< (char-code #\$ ) 65536)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-FONT.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-FONT.TEST new file mode 100644 index 00000000..1fecd176 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-3-CHAR-FONT.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 240 ;; Author: John Park ;; Creation date: April 30, 86 ;; Functions to be tested: char-font ;; Filed in {eris}cml>test>13-3-char-font.tst (do-test char-font-test ; returns the font attribute of the character object (every #'char-font '(#\a #\A #\b #\B #\@ #\"))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-3-CODE-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-3-CODE-CHAR.TEST new file mode 100644 index 00000000..54459050 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-3-CODE-CHAR.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 240 ;; Author: John Park ;; Creation date: April 30, 86 ;; Functions to be tested: code-char ;; Filed in {eris}cml>test>13-3-code-char.tst (do-test code-char-test ; returns a character object whose code attribute is code, whose bits attribute is bits, and whose font attribute is font (every #'code-char '(1 2 4 7 10 20 30 40 60 90 150))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-3-MAKE-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-3-MAKE-CHAR.TEST new file mode 100644 index 00000000..75c49c63 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-3-MAKE-CHAR.TEST @@ -0,0 +1 @@ +;; Test File for Chapter 13 (Characters) ;; Section 13.3 Construction and Selection, Page 240 ;; Author: John Park ;; Creation date: April 30, 86 ;; Function to be tested:make-char ;; Filed in {eris}cml>test>13-3-make-char.tst (do-test make-char-test ; construct a character object whose code attribute is the same as the code attribute of char, whose bits attribute is bits, and whose font attribute is font (every #'make-char '(#\a #\A #\b #\B #\c #\* #\9 #\}))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-DOWNCASE.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-DOWNCASE.TEST new file mode 100644 index 00000000..3b12e93b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-DOWNCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-downcase ;; ;; Source: Steel's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986 BY MASINTER TO PUT STOP AT END ;; ;; Filed As: {eris}cml>test>13-4-char-downcase.test ;; ;; ;; Syntax: CHAR-DOWNCASE char ;; ;; Function Description: CHAR-DOWNCASE attempts to convert its argument to an lowercase equivalent. ;; ;; Argument(s): char - a character object ;; ;; Returns: char - a character object with the same font and bits attributes ;; as the input char, but with possibly a different code attribute ;; ;; an error signal - if the argument is not a character ;; (do-test-group (test-char-downcase-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf non-alpha-chars '(#\Space #\Page #\8 #\> #\Newline )))) (do-test test-char-downcase ; be sure upper case letters are converted to lower case letters correctly (and (every #'(lambda (x y) (char= (char-downcase x) y)) upper-case-chars lower-case-chars) ; be sure lower case letters stay the same (every #'(lambda (x) (char= (char-downcase x) x)) lower-case-chars) ; be sure non-alpha characters stay the same (every #'(lambda (x) (char= (char-downcase x) x)) non-alpha-chars)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-INT.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-INT.TEST new file mode 100644 index 00000000..c02df2ee --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-INT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CHAR-INT ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 242 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986/ MASINTER, add RETURN after STOP ;; ;; Filed As: {eris}cml>test>13-4-char-int.test ;; ;; ;; Syntax: CHAR-INT char ;; ;; Function Description: CHAR-INT returns a non-negative integer encoding the character object. ;; ;; Argument(s): char - a character object ;; ;; Returns: a non-negative integer, which is the encoding code of the input char ;; ;; an error signal - if the input argument is not a character ;; (do-test-group (test-char-int-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf numbers '( #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (setf chars-have-names '(#\Backspace #\Tab #\Rubout #\Linefeed #\Space #\Return #\Page #\Newline)) (setf others '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@ #\[ #\\ #\] #\{ #\} #\')))) (do-test test-char-int1 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) lower-case-chars)) (do-test test-char-int2 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) upper-case-chars)) (do-test test-char-int3 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) numbers)) (do-test test-char-int4 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) others)) (do-test test-char-int5 (every #'(lambda (x) (and (integerp (char-int x)) (plusp (char-int x)))) chars-have-names)) (do-test test-char-int6 (= (- 26 1) (- (char-int #\Z) (char-int #\A)) (- (char-int #\z) (char-int #\a))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-NAME.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-NAME.TEST new file mode 100644 index 00000000..e5d660e8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-name ;; ;; Source: Steel's book Section 13.4: Character Conversions Page: 242 ;; ;; Created By: karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 5 '86 ;; ;; Filed As: {eris}cml>test>13-4-char-name.test ;; ;; ;; Syntax: CHAR-NAME char ;; ;; Function Description: CHAR-NAME returns a name if the argument has a name associated with it. ;; ;; Argument(s): char - a character object ;; ;; Returns: name of the input character ;; nil - if the input character doesn't have a name ;; an error signal - if the argument is not a character ;; (do-test-group (test-char-name-group :before (progn (setf chars-have-names '(#\Backspace #\Tab #\Rubout #\Linefeed #\Space #\Page #\Newline #\Return)) (setf chars-have-no-names '(#\1 #\9 #\A #\z #\* #\[)) (setf string-names '("BACKSPACE" "TAB" "RUBOUT" "LINEFEED" "SPACE" "PAGE" "NEWLINE" "NEWLINE")))) (do-test test-char-name (and (every #'(lambda (x y) (string-equal (string (char-name x)) y)) chars-have-names string-names) (notany #'char-name chars-have-no-names)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-UPCASE.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-UPCASE.TEST new file mode 100644 index 00000000..d7e69c5b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHAR-UPCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-upcase ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986// MASINTER ;; ;; Filed As: {eris}cml>test>13-4-char-upcase.test ;; ;; ;; Syntax: CHAR-UPCASE char ;; ;; Function Description: CHAR-UPCASE attempts to convert its argument to an uppercase equivalent. ;; ;; Argument(s): char - a character object ;; ;; Returns: char - a character object with the same font and bits attributes ;; as the input char, but with possibly a different code attribute ;; ;; an error signal - if the argument is not a character ;; (do-test-group (test-char-upcase-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf non-alpha-chars '(#\Space #\Page #\8 #\> #\Newline )))) (do-test test-char-upcase ; be sure lower case letters are converted to upper case letters correctly (and (every #'(lambda (x y) (char= (char-upcase x) y)) lower-case-chars upper-case-chars) ; be sure upper case letters stay the same (every #'(lambda (x) (char= (char-upcase x) x)) upper-case-chars) ; be sure non-alpha characters stay the same (every #'(lambda (x) (char= (char-upcase x) x)) non-alpha-chars)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-CHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHARACTER.TEST new file mode 100644 index 00000000..c8557934 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: character ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986/ MASINTER ;; ;; Filed As: {eris}cml>test>13-4-character.test ;; ;; ;; Syntax: CHARACTER object ;; ;; Function Description: CHARACTER function converts its argument to be a character if possible. ;; ;; Argument(s): object - a lisp object ;; ;; Returns: a character ;; an error signal - if it is not possible to convert the object ;; (do-test-group (test-character-group :before (progn (setf lower-case-chars '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) (setf upper-case-chars '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) (setf lower-case-strings '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")) (setf upper-case-strings '("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z")) (setf numbers '( 0 1 2 3 4 5 6 7 8 9)) (setf lower-case-symbols '(\a \b \c \d \e \f \g \h \i \j \k \l \m \n \o \p \q \r \s \t \u \v \w \x \y \z)) (setf upper-case-symbols '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)))) (do-test test-character (and (every #'(lambda (x y) (char= (character x) y)) lower-case-strings lower-case-chars) (every #'(lambda (x y) (char= (character x) y)) upper-case-strings upper-case-chars) (every #'(lambda (x y) (char= (character x) y)) upper-case-symbols upper-case-chars) (every #'(lambda (x y) (char= (character x) y)) lower-case-symbols lower-case-chars) (every #'(lambda (x) (characterp (character x))) numbers)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-DIGIT-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-DIGIT-CHAR.TEST new file mode 100644 index 00000000..0c2d5284 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-DIGIT-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: digit-char ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 241 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986 ;; ;; Filed As: {eris}cml>test>13-4-digit-char.test ;; ;; ;; Syntax: DIGIT-CHAR weight &optional (radix 10) (font 0) ;; ;; Function Description: DIGIT-CHAR attempts to construct a character object with the argument font. ;; The returned character has a code which is equivalent to the argument weight ;; when bases on the argument radix. ;; ;; Argument(s): weight - a non-negative integer and less then radix ;; radix - between 2 and 36 inclusive, the default is set to 10 ;; font - the font attribute, the default is set to 0 ;; ;; Returns: char - a character object whose font attribute is font, and whose code is ;; equivalent to the argument weight when bases on the argument radix. ;; ;; nil - it's not possible to construct such a character ;; ;; (do-test-group (test-digit-char-group :before (progn (setf weight-radix-10 '(0 1 2 3 4 5 6 7 8 9)) (setf char-radix-10 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (setf weight-radix-8 '(0 1 2 3 4 5 6 7)) (setf char-radix-8 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) (setf weight-radix-16 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) (setf char-radix-16 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)) (setf weight-radix-26 '(24 25)) (setf char-radix-26 '(#\O #\P)) (setq weight-radix-36 '(33 34 35)) (setq char-radix-36 '(#\X #\Y #\Z)) (setq weight-radix-2 '(0 1)) (setq char-radix-2 '(#\0 #\1)))) (do-test test-digit-char1 (and (every #'(lambda (x y) (char= (digit-char x) y)) weight-radix-10 char-radix-10) (every #'(lambda (x y) (char= (digit-char x 8) y)) weight-radix-8 char-radix-8) (every #'(lambda (x y) (char= (digit-char x 16) y)) weight-radix-16 char-radix-16) (every #'(lambda (x y) (char= (digit-char x 26) y)) weight-radix-26 char-radix-26) (every #'(lambda (x y) (char= (digit-char x 36) y)) weight-radix-36 char-radix-36) (every #'(lambda (x y) (char= (digit-char x 2) y)) weight-radix-2 char-radix-2))) (do-test test-digit-char2 ; if "weight" is not less than "radix" be sure it returns nil (and (notany #'digit-char '(10 11 12 8 9 20 ) '(10 10 10 8 8 8)) (notany #'digit-char '(16 17 18 19 26 27 282 29) '(16 16 16 16 26 26 26 26)) (notany #'digit-char '(36 37 38 40 2 3 4) '(36 36 36 36 2 2 2)))) (do-test test-digit-char3 ; what happens if "weight" is negative ? I assume it returns nil (notany #'digit-char '(-1 -2 -3 ) '(10 20 30)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-INT-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-INT-CHAR.TEST new file mode 100644 index 00000000..3d8b8ca8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-INT-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: INT-CHAR ;; ;; Source: Steelle's book Section 13.4: Character Conversions Page: 242 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 16, 1986/ Masinter, add STOP to end ;; July 31, 1986/ Sye, delete one test case which tests for "is an error" situation ;; ;; Filed As: {eris}cml>test>13-4-int-char.test ;; ;; ;; Syntax: INT-CHAR integer ;; ;; Function Description: INT-CHAR attemps to return a character object such that the integer encoding the ;; returned character is equal to the argument integer ;; ;; Argument(s): integer - a non-negative integer ;; ;; Returns: a returned character ;; ;; nil - if the attemp fails ;; (do-test test-int-char2 (every #'(lambda (x) (characterp (int-char x))) '(5 10 15 20 25 30 35 40 50 60 75 80 90 100 115 120 128))) (do-test test-int-char3 (and (char= (int-char 65) #\A) (char= (int-char 32) #\Space) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-4-NAME-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-4-NAME-CHAR.TEST new file mode 100644 index 00000000..f68dacbf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-NAME-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: name-char ;; ;; Source: Steele's book Section 13.4: Character Conversions Page: 243 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 5 '86 ;; ;; Filed As: {eris}cml>test>13-4-name-char.test ;; ;; ;; Syntax: NAME-CHAR name ;; ;; Function Description: NAME-CHAR returns a character object whose name is the same as the argument. ;; ;; Argument(s): name - an object coerceable to a string ;; ;; Returns: char - a character object whose name is the same as the argument ;; nil - no such character object is found ;; an error signal - if the argument is not a character ;; (do-test-group (test-name-char-group :before (progn (setf chars-have-names '(#\Backspace #\Tab #\Rubout #\Space #\Page )) (setf string-names '("BS" "TAB" "DEL" "SPACE" "PAGE")) (setf some-unknown-names '(time what why none-sense)))) (do-test test-name-char (and (every #'(lambda (x y) (char= (name-char x) y)) string-names chars-have-names) (notany #'name-char some-unknown-names)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-5-CHAR-BIT.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-5-CHAR-BIT.TEST new file mode 100644 index 00000000..31e39e3f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-5-CHAR-BIT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char-bit ;; ;; Source: Steele's book Section 13.5: Character Control-Bit Functions Page: 243 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 5 '86 ;; ;; Filed As: {eris}cml>test>13-5-char-bit.test ;; ;; ;; Syntax: CHAR-BIT char name ;; ;; Function Description: char-bit takes a character object and the name of a bit, ;; and returns non-nil or nil depending on whether the bit ;; is set or not set. ;; ;; Argument(s): char - a character object ;; name - the name of a bit of the bits attribute ;; (valid values for name are implementation-dependent) ;; ;; Returns: non-nil - if the bit is set in char ;; nil - if the bit is not set in char ;; an error - if the input argument, name, is not supported by ;; the implementation ;; ;; JRB - Our CL does not support char-bits; commenting this test out #| (do-test try-char-bit (and (eq nil (char-bit #\a :control)) (char-bit #\Control-A :control))) |# (do-test try-char-bit t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/13/13-5-SET-CHAR-BIT.TEST b/internal/test/LANGUAGE/from-sun/language/13/13-5-SET-CHAR-BIT.TEST new file mode 100644 index 00000000..d8c11c42 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/13/13-5-SET-CHAR-BIT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set-char-bit ;; ;; Source: Steele's book Section 13.5: Character Control-Bit Functions Page: 244 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: April 29 '86 ;; ;; Last Update: May 5 '86 ;; ;; Filed As: {eris}cml>test>13-5-set-char-bit.test ;; ;; ;; Syntax: SET-CHAR-BIT char name newvalue ;; ;; Function Description: set-char-bit takes a character object, the name of a bit, ;; and a newvalue. It returns a character just like the input ;; character except the named bit is set or reset according to ;; whether newvalue is non-nil or nil. ;; ;; ;; Argument(s): char - a character object ;; name - the name of a bit of the bits attribute ;; (valid values for name are implementation-dependent) ;; newvalue - non-nil or nil ;; ;; Returns: char - same as the input char, excep with the named bit set or reset ;; an error - if the input argument, name, is not supported by the ;; implementation ;; ;; JRB Our implementation does not support char-bits; commenting test out #| (do-test try-set-char-bit ; char-equal ignores the differences of bits attributes; char= doesn't ignore them (and (char-equal #\A (set-char-bit #\A :control t)) (char= #\Z (set-char-bit #\Control-Z :control nil)))) |# (do-test try-set-char-bit t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-COPY-SEQ.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-COPY-SEQ.TEST new file mode 100644 index 00000000..e140b9fa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-COPY-SEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: XXXX ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 29 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-copy-seq.test ;; ;; ;; Syntax: copy-seq SEQUENCE ;; ;; Function Description: copy-seq returns a copy of SEQUENCE ;; ;; Argument(s): SEQUENCE ;; ;; Returns: a sequence ;; ;; Assumes that CL:EVERY works. (do-test "test copy-seq" (flet ((fun (parent) (let ((child (copy-seq parent))) (and (not (eq child parent)) (equalp parent child)))) ) (every #'fun (list '#(a b c d e f g h i j k l m n o p q r s y) "on tuesday, employees will not be able to park on the east side oflbuilding 101" '(it is suggested that employees utilize the west parking log or the overflow etc) (make-sequence '(vector bit) 200 :initial-element 1) (make-array 100 :element-type 'character :initial-element #\< :fill-pointer t) (make-array 120 :element-type 'complex :initial-element #c(1 2) :fill-pointer t) '( (1 (2)) 3 (23 (34)) 5 6 7 (8 9 10) (((11)) 23 45 ) 66 77 88 99 100) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-ELT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-ELT.TEST new file mode 100644 index 00000000..51ae7a5c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-ELT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ELT ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 28 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-elt.test ;; ;; ;; Syntax: elt SEQUENCE INDEX ;; ;; Function Description: elt returns the element of the SEQUENCE specified by INDEX. ;; ;; Argument(s): SEQUENCE - ;; INDEX - a non-negative integer less than the length of the SEQUENCE. ;; The first element of a sequence has index 0. ;; ;; Returns: the element of the SEQUENCE specified by INDEX ;; (do-test "test elt 0" (let ((a '#(a b c d e f g h))) (every #'(lambda (x y) (eq (elt a y) x)) '(a b c d e f g h) '(0 1 2 3 4 5 6 7)) ) ) (do-test "test elt 1" (let ((a (vector #'+ #'- #'* #'oddp))) (and (every (elt a 3) '(1 3 5 7 9)) (= (funcall (elt a 0) 1 2 3 4 5) 15) (= (apply (elt a 2) '(1 2 3 4 5)) 120) ) ) ) (do-test "test elt 2" (let ((a (reverse '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))) (and (eq (elt a 0 ) 'z) (eq (elt a 25) 'a) (eq (elt a 23) 'c) (eq (elt a 5) 'u) ) ) ) (do-test "test elt 3 - setf may be used with elt to replace a sequence element with a new value" (let ((a (make-array 50 :initial-contents '( 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50) :fill-pointer t))) (do ((n 0 (+ 5 n)) (m (length a))) ((>= n m)) (setf (elt a n) (* 2 (elt a n)))) (equalp a '#(2 2 3 4 5 12 7 8 9 10 22 12 13 14 15 32 17 18 19 20 42 22 23 24 25 52 27 28 29 30 62 32 33 34 35 72 37 38 39 40 82 42 43 44 45 92 47 48 49 50)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-LENGTH.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-LENGTH.TEST new file mode 100644 index 00000000..898c347c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-LENGTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: length ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 29 ,1986 ;; ;; Last Update: Aug. 29 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-length.test ;; ;; ;; Syntax: length SEQUENCE ;; ;; Function Description: ;; ;; Argument(s): SEQUENCE ;; ;; Returns: a non-negative integer ;; (do-test "test length 0" (flet ((check-length (seq n) (= (length seq) n))) (and (check-length "1234567890abcdefghijklmnopqrstuvwxyz" 36) (check-length (make-list 100 :initial-element #\w) 100) (check-length (vector 1 0 0 1 1 0 0 1 1 0 1 1 1 1 0 0 0 0 1 0 1 0 0 1 1 0 1 0 1 0) 30) (check-length (make-array 90 :initial-element "string") 90) (check-length (vector '(1 2) '(3 . 4) '((1) (2)) '(1 (2) ((3)) 4) '(((55))) '(1 2 4)) 6) (check-length (make-array 100 :element-type 'integer :initial-element 650 :fill-pointer t) 100) ) ) ) (do-test "test length - if the vector has a fill pointer, the 'active-length' as specidied by the fill pointer is returned" (flet ((check-length (seq n) (= (length seq) n))) (let ((a (make-array 100 :initial-element 987 :fill-pointer t)) (b (make-array 200 :fill-pointer 100)) (c (make-array 4 :initial-contents '((a b c) (aa bb cc) (aaa bbb ccc) (aaaa bbbb cccc)) :fill-pointer 3))) (and (check-length a 100) (setf (fill-pointer a) 96) (check-length a 96) (check-length b 100) (setf (fill-pointer b) 190) (check-length b 190) (check-length c 3) (setf (fill-pointer c) 0) (check-length c 0) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-MAKE-SEQUENCE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-MAKE-SEQUENCE.TEST new file mode 100644 index 00000000..abd1b5b3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-MAKE-SEQUENCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-SEQUENCE ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 249 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 28 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-make-sequence.test ;; ;; ;; Syntax: make-sequence TYPE SIZE &KEY :INITIAL-ELEMENT ;; ;; Function Description: make-sequence returns a sequence of type TYPE and of length SIZE, ;; each of whose elements has been initialized to the :INITIAL-ELEMENT argument. ;; If specified, the :INITIAL-ELEMENT argument must be an object that can be an element of ;; a sequence of type TYPE. ;; ;; Argument(s): TYPE - a lisp type specfier ;; SIZE - an integer ;; INITIAL-ELEMENT - an object of type TYPE ;; ;; Returns: a sequence ;; (do-test "test make-sequence 0" (and (equal (make-sequence 'list 10 :initial-element 9) '(9 9 9 9 9 9 9 9 9 9)) (equal (make-sequence 'string 5 :initial-element #\a) "aaaaa") (let ((a (make-sequence '(vector t) 4 :initial-element '(1 . 2)))) (and (typep a 'sequence) (= (length a) 4) (every #'(lambda (n) (equal (elt a n) '(1 . 2))) '(0 1 2 3)) ) ) (equal (make-sequence 'list 5 :initial-element #\w) '(#\w #\w #\w #\w #\w)) ) ) (do-test "test make-sequence 1" (flet ((test-result (result expected-length expected-elt) (and (typep result 'sequence) (= (length result) expected-length) (every #'(lambda (x) (equal x expected-elt)) result) ))) (and (test-result (make-sequence 'string 100 :initial-element #\p) 100 #\p) (test-result (make-sequence 'list 80 :initial-element '(1 2 3)) 80 '(1 2 3)) (test-result (make-sequence '(vector bit) 20 :initial-element 1) 20 1) (test-result (make-sequence '(simple-array integer 1) 40 :initial-element #4r10) 40 4) (test-result (make-sequence 'list 50 :initial-element "hi") 50 "hi") (test-result (make-sequence 'simple-string 300 :initial-element #\%) 300 #\%) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-NREVERSE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-NREVERSE.TEST new file mode 100644 index 00000000..75aa0b76 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-NREVERSE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nreverse ;; ;; Source: CLtL Section 14.1: Simple Sequences Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sep. 2,1986 ;; ;; Last Update: Nov. 5,1986 ;; ;; Filed As: {eris}cml>test>14-1-nreverse.test ;; ;; ;; Syntax: nreverse SEQUENCE ;; ;; Function Description: This function returns a new sequene of the same kind as SEQUENCE, containing the same elements ;; but in reverse order. The argument may be destroyed and re-used to produce the result. The ;; result may or may not be eq to the argument. ;; ;; Argument(s): SEQUENCE - ;; ;; Returns: a sequence ;; (do-test "test nreverse 0" (and (equal (nreverse "") "") (equal (nreverse ()) ()) (equalp (nreverse (vector)) '#()) (let ((a (nreverse (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9))))) (equal (do ((n 0 (1+ n)) (contents ())) ((= n 10) contents) (push (elt a n) contents)) '(0 1 2 3 4 5 6 7 8 9))) (let ((a (nreverse '#(1 1 1 1 1 0 0 0 0 0)))) (every #'(lambda (x y) (= (elt a x) y)) '(0 9 4 5) '(0 1 0 1))) (let ((a (nreverse (do ((n 0 (1+ n)) (m nil (cons n m))) ((= n 40) m))))) (= (elt a 5) 5) ) ) ) (do-test "test nreverse 1" (flet ((test-one (seq) (let* ((expected-length (length seq)) (save-seq (copy-seq seq)) (rev (nreverse seq))) (and (= expected-length (length rev)) (dotimes (n expected-length t) (unless (equal (elt save-seq n) (elt rev (- (1- expected-length) n))) (return nil)) ) ) ) )) (and (test-one '#(a b c d e f g h i j k l m n o p)) (test-one "dhjfkdjshkjfhdskjfhbvncbmxytewywpoiop;alndbvur478362389uioewhjrheo;lasldkhfdkhffds") (test-one '((1 . 2) (((3)) 4) ((5 . 6) . 7) 8 9 10 (11 12 13) ((14 15 16 17) 18 19 20))) (test-one '#(1 0 1 0 0 1 1 1 1 0 0 1 0 0 0 1 1 1 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 1)) (test-one '(to all those who strive for excellence to all those who strive for excellence)) (test-one (append (make-list 50 :initial-element '((1) (2))) (make-list 50 :initial-element '(3 4 (5))) (make-list 50 :initial-element '(8 7 . 9)) )) (test-one (concatenate 'string (make-string 100 :initial-element #\u) (make-string 100 :initial-element #\s) (make-string 100 :initial-element #\a) )) (test-one (concatenate 'vector '#(1 2 3 4 5 6 7 8 9) '#(one two three four five six seven eight nine))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-REVERSE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-REVERSE.TEST new file mode 100644 index 00000000..9498370a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-REVERSE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: reverse ;; ;; Source: CLtL Section 14.1: Simple Sequences Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sep. 2,1986 ;; ;; Last Update: Nov. 5,1986 ;; ;; Filed As: {eris}cml>test>14-1-reverse.test ;; ;; ;; Syntax: reverse SEQUENCE ;; ;; Function Description: This function returns a new sequene of the same kind as SEQUENCE, containing the same elements ;; but in reverse order. ;; ;; Argument(s): SEQUENCE - ;; ;; Returns: a sequence ;; (do-test "test reverse 0" (and (equal (reverse "") "") (equal (reverse ()) ()) (equalp (reverse '#()) '#()) (let ((a (reverse (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9))))) (equal (do ((n 0 (1+ n)) (contents () (cons (elt a n) contents))) ((= n 10) contents)) '(0 1 2 3 4 5 6 7 8 9))) (let ((a (reverse '#(1 1 1 1 1 0 0 0 0 0)))) (every #'(lambda (x y) (= (elt a x) y)) '(0 9 4 5) '(0 1 0 1))) (let ((a (reverse (do ((n 0 (1+ n)) (m () (cons n m))) ((= n 40) m))))) (= (elt a 5) 5)) ) ) (do-test "test reverse 1" (flet ((test-one (seq) (let ((rev (reverse seq)) (size (length seq))) (and (not (eq seq rev)) (= size (length rev)) (dotimes (n size t) (unless (equal (elt seq n) (elt rev (- (1- size) n))) (return nil)) ) ) ) )) (and (test-one '#(a b c d e f g h i j k l m n o p)) (test-one "dhjfkdjshkjfhdskjfhbvncbmxytewywpoiop;alndbvur478362389uioewhjrheo;lasldkhfdkhffds") (test-one '((1 . 2) (((3)) 4) ((5 . 6) . 7) 8 9 10 (11 12 13) ((14 15 16 17) 18 19 20))) (test-one '#(1 0 1 0 0 1 1 1 1 0 0 1 0 0 0 1 1 1 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 1)) (test-one '(to all those who strive for excellence to all those who strive for excellence)) (test-one (append (make-list 50 :initial-element '((1) (2))) (make-list 50 :initial-element '(3 4 (5))) (make-list 50 :initial-element '(8 7 . 9)) )) (test-one (concatenate 'string (make-string 100 :initial-element #\u) (make-string 100 :initial-element #\s) (make-string 100 :initial-element #\a) )) (test-one (concatenate 'vector '#(1 2 3 4 5 6 7 8 9) '#(one two three four five six seven eight nine) '#(a b c d e f g h i j k l m n o p q r s t u v) )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-1-SUBSEQ.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-1-SUBSEQ.TEST new file mode 100644 index 00000000..702c210f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-SUBSEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: subseq ;; ;; Source: CLtL Section 14.1: Simple Sequence Functions Page: 248 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 29 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-1-subseq.test ;; ;; ;; Syntax: subseq SEQUENCE START &OPTIONAL END ;; ;; Function Description: returns the subsequence of SEQUENCE specified by START and END ;; ;; Argument(s): SEQUENCE - ;; START - an integer index into the SEQUENCE ;; END - an integer index into the SEQUENCE ;; ;; Returns: a sequence ;; (do-test "test subseq 0" (and (equal (subseq "abcdefg" 0) "abcdefg") (equal (subseq "1234567890" 5 10) "67890") (equal (subseq '(foo foo1 foo2 foo3 foo4 foo5) 2 4) '(foo2 foo3)) (equal (subseq '( ( 1 . 2) (3 . 4) (5 . 6) (11 . 22) (33 . 122)) 4) '((33 . 122))) (equalp (subseq '#(large medium small) 1) '#(medium small)) ) ) (do-test "test subseq 1" (flet ((test-one (seq1 subseq1 start1 &optional (end1 (length seq1)) ) (and ; check the type of subsequence ; this is the best you can do!! (etypecase seq1 (list (listp subseq1)) (vector (typep subseq1 'vector))) ; ; check the length of subsequence ; (= (length subseq1) (- end1 start1)) (= (search subseq1 seq1) start1) ))) (let (( a "abcdefghijklmnopqr" ) ; ; b is a list of 100 elements ; (b (do ((a 0 (1+ a)) (b nil (cons a b))) ( (= a 100) b) ) ) ; ; c & d are vector ; (c (make-array 80 :element-type 'character :initial-element #\k) ) (d '#(tremulous quiver happy mould gulp delight heart flash upon me) )) (and (test-one a (subseq a 5 15) 5 15) (test-one a (subseq a 0) 0) (test-one b (subseq b 20) 20) (test-one b (subseq b 1 89) 1 89) (test-one c (subseq c 0) 0) (test-one c (subseq c 0 77) 0 77) (test-one d (subseq d 1) 1) (test-one d (subseq d 3 8) 3 8) ) )) ) (do-test "test subseq - the returned subsequence never shares storage with its parent" (let* ((a (make-sequence 'list 10 :initial-element 'z)) (b (subseq a 5) )) (setf (cadr b) '(7 8 9)) (and (equal a '(z z z z z z z z z z)) (equal b '(z (7 8 9) z z z)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-CONCATENATE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-CONCATENATE.TEST new file mode 100644 index 00000000..5d0c76f5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-CONCATENATE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: concatenate ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 249 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 8 ,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - removed ARRAY test since ARRAY is not a legal sequence ;; ;; Filed As: {eris}cml>test>14-2-concatenate.test ;; ;; ;; Syntax: concatenate RESULT-TYPE &REST SEQUENCES ;; ;; Function Description: concatenate returns a new sequence that contains all the elements of all the sequences in ;; order. The result does not share any structure with any of the argument sequences. ;; ;; Argument(s): RESULT-TYPE - a subtype of SEQUENCE ;; SEQUENCE - ;; ;; Returns: a sequence ;; (do-test "test concatenate 0" (and (equal (concatenate 'string "foo0 " "foo1 " "foo2 " "foo3 " "foo4 " "foo5 " "foo6") "foo0 foo1 foo2 foo3 foo4 foo5 foo6") (equal (concatenate 'list '(gjd dshjgf lkds e4rohuew jdfhkk kjhdsf df l fgd jk dsf jlk dfs ewr fkldj) '(7983 873 478 32 90 435 7 43 98 32 894 67 45 243 564 76 54 342 12 43) '(fdg89 fgd- sadf98 gfh32 kjlu5 hfgkjjh1 kjhfgdhj435 kj54 kjfg9 bncmv8)) '(gjd dshjgf lkds e4rohuew jdfhkk kjhdsf df l fgd jk dsf jlk dfs ewr fkldj 7983 873 478 32 90 435 7 43 98 32 894 67 45 243 564 76 54 342 12 43 fdg89 fgd- sadf98 gfh32 kjlu5 hfgkjjh1 kjhfgdhj435 kj54 kjfg9 bncmv8)))) (do-test "test concatenate 1" (flet ((test-one (type &rest sequences &aux (expected-length 0) (contents ())) (dolist (seq sequences (let ((expected-result (if (eq type 'list) (reverse contents) (make-sequence type expected-length)))) (unless (eq type 'list) (setq contents (reverse contents)) (dotimes (i expected-length) (setf (elt expected-result i) (pop contents)) ) ) (equalp (apply #'concatenate type sequences) expected-result) ) ) (incf expected-length (length seq)) (dotimes (i (length seq)) (push (elt seq i) contents)) ) )) (and (test-one 'string "12345" "6789012") (test-one 'list "8547935743897598437598" "hjfgkjfdhkgjfhdkgjhdfkjghdkfhg" "rkjkthrek49837598473eukrhke") (test-one 'vector (make-string 200 :initial-element #\u) (make-list 200 :initial-element '(1 2 (3))) (make-array 200 :initial-element "concatenate")) (test-one 'list (make-array 50 :initial-element 1) (make-array 50 :initial-element 0 :fill-pointer 3) '#(3 4 5 6 7 6 5 4 3 2 1 9 0 9 4 5 6 4 3 6 8 6 4 2 1 2 3 547 90 8) '(sunshine on my shoulder makes me happy sun shine in my eyes makes me cry) "sunshine in the water looks so lovely sunshine almost always make me high") (test-one 'list () "" () "") ) ) ) (do-test "test concatenate - the result does not share any structure with any of the argument sequences" (and (let* ((a '(1 2 (3 4) 5 6)) (b (concatenate 'list a))) (setf (third a) 8) (equal (list a b) '((1 2 8 5 6) (1 2 (3 4) 5 6)))) (let* ((a "trees lists cons numbers floats") (b "t nil identity lisp cml function macro sequence") (c "gcd max min replace find setseq elt member if let prog") (d (concatenate 'string a b c ))) (setq d (delete #\r d)) (equal (list a b c) '("trees lists cons numbers floats" "t nil identity lisp cml function macro sequence" "gcd max min replace find setseq elt member if let prog"))) (let* ((a (vector 5 10 15 20 25 30)) (b (vector 3 6 9 12 15 28 21)) (c (concatenate 'vector a b))) (setq c (delete 10 (delete 9 c))) (equalp (concatenate 'vector a b) '#(5 10 15 20 25 30 3 6 9 12 15 28 21))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-EVERY.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-EVERY.TEST new file mode 100644 index 00000000..e6aada0e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-EVERY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: every ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Sept. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-every.test ;; ;; ;; Syntax: every PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: every returns nil as soon as any invocation of PRIDICATE returns a nil. ;; If the end of a sequence is reached, every returns a non-nil value. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test every - If the end of a sequence is reached, "t" is returned" (and (eq (every #'+ '(2 4 6) '(1 3 5) '()) t) (eq (every #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) t) (eq (every #'list "abc" "cde" "" "efr") t) (eq (every #'- (vector) "" (make-array 3 :initial-element nil :fill-pointer 2)) t) ) ) (do-test "test every 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (every #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test every - with 110 sequences" (let ((a '(1)) ) (and (eq (every #'nconc (list a) '((2)) '((3)) '((4)) '((5)) '((6)) '((7)) '((8)) '((9)) '((10)) '((11)) '((12)) '((13)) '((14)) '((15)) '((16)) '((17)) '((18)) '((19)) '((20)) '((21)) '((22)) '((23)) '((24)) '((25)) '((26)) '((27)) '((28)) '((29)) '((30)) '((31)) '((32)) '((33)) '((34)) '((35)) '((36)) '((37)) '((38)) '((39)) '((40)) '((41)) '((42)) '((43)) '((44)) '((45)) '((46)) '((47)) '((48)) '((49)) '((50)) '((51)) '((52)) '((53)) '((54)) '((55)) '((56)) '((57)) '((58)) '((59)) '((60)) '((61)) '((62)) '((63)) '((64)) '((65)) '((66)) '((67)) '((68)) '((69)) '((70)) '((71)) '((72)) '((73)) '((74)) '((75)) '((76)) '((77)) '((78)) '((79)) '((80)) '((81)) '((82)) '((83)) '((84)) '((85)) '((86)) '((87)) '((88)) '((89)) '((90)) '((91)) '((92)) '((93)) '((94)) '((95)) '((96)) '((97)) '((98)) '((99)) '((100)) '((101)) '((102)) '((103)) '((104)) '((105)) '((106)) '((107)) '((108)) '((109)) '((110))) t) (equal a (do ((n 1 (1+ n)) (buf nil (append buf (list n)))) ((= n 111) buf) )) ) ) ) (do-test "test every 1" (and (eq (every #'identity (vector t t 3 t 2 t t 5 t 9)) t) (eq (every #'identity (list t t 3 t 2 t t 5 nil t 9)) nil) ) ) (do-test "test every 2" (and (eq (every #'lower-case-p "twinkle twinkle little star !") nil) (eq (every #'lower-case-p "twinkletwinklelittlestar") t) (eq (every #'oddp (vector 1 3 5 7 17 35 17 39 97 77 91 -2)) nil) (eq (every #'oddp (vector 1 3 5 7 17 35 17 39 97 77 91 -3)) t) ) ) (do-test "test every 3" (and ( eq (every #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) nil) ( eq (every #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 7 99) ((a) ((a)) a 'a) (2 6 7 a) )) t) ( eq (every #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 17 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ) ) (do-test "test every 4" (and (eq (every #'>= '(100 90 60 50 40 1 2) '(95 87 43 30 35 8 11) '(5 9 40 25 3)) t) (equal (every #'>= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) nil) (equal (every #'>= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 20 3)) t) ) ) (do-test "test every 5" (and (eq (every #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) nil) (eq (every #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(4 4 1 5) "eeag" (make-array 4 :initial-element 'character)) t) (eq (every #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(4 3 1 5) "eeag" (make-array 4 :initial-element 'character)) nil) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-MAP.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-MAP.TEST new file mode 100644 index 00000000..14a6add4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-MAP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: map ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 8 ,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - put (not (null ...) around function in ;; test 2 to guarantee T being returned ;; ;; Filed As: {eris}cml>test>14-2-map.test ;; ;; ;; Syntax: map RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: map returns a sequence such that element j is the result of applying FUNCTION to element j of ;; each of the argument sequences. The result sequence is as long as the shofrtest of the ;; input sequences. ;; ;; Argument(s): RESULT-TYPE - a subtype of the type SEQUENCE ;; FUNCTION - a Lisp function which must take as many arguments as there are sequences provided ;; SEQUENCE(S) - ;; ;; Result: a sequence ;; (do-test "test map - test cases copied from page 250 of CLtL" (and (equal (map 'list #'- '(1 2 3 4)) '(-1 -2 -3 -4)) (equal (map 'string #'(lambda (x) (if (oddp x) #\1 #\0)) '(1 2 3 4)) "1010") ) ) (do-test "test map 1" (equal (map 'list #'list "12345123451234512345123451234512345123451234512345" '(6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 6 7 8 9 10 ) (make-array 50 :initial-contents '(a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e a b c d e))) (let ((x ())) (dotimes (ignore 10 x) (setq x (append '((#\1 6 a) (#\2 7 b) (#\3 8 c) (#\4 9 d) (#\5 10 e)) x)))) ) ) (do-test "test map 2" (equal (map 'list #'(lambda (w x y z) (not (null (equal (funcall w x y) z)))) (list #'member #'intersection #'+ #'>= #'subseq #'cons #'find #'typep #'elt #'complexp) '((a b) (1 2 13 4 (5)) #c(1 -1) 10.0 "funny" 11 #\s "apple" "orange" #c(9 10)) '(((ab) d) (10 20 3 4 5) #c(9 8) 9.999 3 88 "sun" list 5) '( nil (4) #c(10 7) t "ny" (11 . 88) #\s nil #\e) ) '(t t t t t t t t t))) (do-test "test map 3" (let ((a "12345678901234567890") (b "024680246802468") (c "9753197531357") (even t)) (equal (map 'list #'(lambda (x y z) ;; skip every other element slice. (unless (setf even (not even)) (concatenate 'string (vector x) (vector y) (vector z)))) a b c) '("109" nil "345" nil "581" nil "727" nil "963" nil "103" nil "347") ) ) ) (do-test "test map 4" (equalp (map 'vector #'values '(1 2 3 4 5 6 7 8 9 0) '(11 22 33 44 55 66 77 88) '(111 222 333 444 555 666)) '#(1 2 3 4 5 6))) (do-test "test map 5" (equal (map 'list #'(lambda (w x y z) (>= (char-code w) (char-code x) (char-code y) (char-code z))) "cfjiwuyrklmops" "kiemjcbsywq839ew" "KLFDDSLFKLDKLD" "736y47326479738") '(nil nil t nil t t t nil nil nil nil nil nil nil) )) (do-test "test map - if the RESULT-TYPE was specified to be nil, map returns nil" (and (null (map nil #'list "abcde" "defgg" "gdfsdfds")) (null (map (= 1 2) #'- '(1 2 3 4))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTANY.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTANY.TEST new file mode 100644 index 00000000..1912c143 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTANY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: notany ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Sept. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-notany.test ;; ;; ;; Syntax: notany PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: notany returns nil as soon as any invocation of PRIDICATE returns a non-nil value. ;; If the end of a sequence is reached, notany returns a non-nil value. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test notany - If the end of a sequence is reached, "t" is returned" (and (eq (notany #'+ '(2 4 6) '(1 3 5) '()) t) (eq (notany #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) t) (eq (notany #'list "abc" "cde" "" "efr") t) (eq (notany #'- (vector) "" (make-array 3 :initial-element nil :fill-pointer 2)) t) ) ) (do-test "test notany 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (notany #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) nil ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test notany - with 120 sequences" (let ((a '(1)) ) (and (eq (notany #'nconc (list a) '((2)) '((3)) '((4)) '((5)) '((6)) '((7)) '((8)) '((9)) '((10)) '((11)) '((12)) '((13)) '((14)) '((15)) '((16)) '((17)) '((18)) '((19)) '((20)) '((21)) '((22)) '((23)) '((24)) '((25)) '((26)) '((27)) '((28)) '((29)) '((30)) '((31)) '((32)) '((33)) '((34)) '((35)) '((36)) '((37)) '((38)) '((39)) '((40)) '((41)) '((42)) '((43)) '((44)) '((45)) '((46)) '((47)) '((48)) '((49)) '((50)) '((51)) '((52)) '((53)) '((54)) '((55)) '((56)) '((57)) '((58)) '((59)) '((60)) '((61)) '((62)) '((63)) '((64)) '((65)) '((66)) '((67)) '((68)) '((69)) '((70)) '((71)) '((72)) '((73)) '((74)) '((75)) '((76)) '((77)) '((78)) '((79)) '((80)) '((81)) '((82)) '((83)) '((84)) '((85)) '((86)) '((87)) '((88)) '((89)) '((90)) '((91)) '((92)) '((93)) '((94)) '((95)) '((96)) '((97)) '((98)) '((99)) '((100)) '((101)) '((102)) '((103)) '((104)) '((105)) '((106)) '((107)) '((108)) '((109)) '((110)) '((111)) '((112)) '((113)) '((114)) '((115)) '((116)) '((117)) '((118)) '((119)) '((120))) nil) (equal a (do ((n 1 (1+ n)) (buf nil (append buf (list n)))) ((= n 121) buf) )) ) ) ) (do-test "test notany 1" (and (eq (notany #'identity (vector nil nil 2 t t 5 t 9)) nil) (eq (notany #'identity (list nil nil nil nil nil)) t) ) ) (do-test "test notany 2" (and (eq (notany #'lower-case-p "twinkle twinkle little star !") nil) (eq (notany #'upper-case-p "twinkle twinkle little star !") t) (eq (notany #'evenp (vector 1 3 5 7 17 35 17 39 97 77 91 )) t) (eq (notany #'evenp (vector 1 3 5 7 17 35 17 39 97 77 91 -2)) nil) ) ) (do-test "test notany 3" (and ( eq (notany #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) t) ( eq (notany #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 7 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ( eq (notany #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 22 (3)) (4 5 (6) 63) (88 17 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ) ) (do-test "test notany 4" (and (eq (notany #'<= '(100 90 60 50 40 1 2) '(95 87 43 30 35 8 11) '(5 9 40 25 3)) t) (equal (notany #'<= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) nil) (equal (notany #'<= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 20 3)) nil) ) ) (do-test "test notany 5" (and (eq (notany #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) t) (eq (notany #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(5 1 1 5) "eefg" (make-array 4 :initial-element 'character)) nil) (eq (notany #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) (vector "summer" "winter" "fall" "spring") '(4 3 1 5) "eeag" (make-array 4 :initial-element 'character)) nil) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTEVERY.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTEVERY.TEST new file mode 100644 index 00000000..06096cd3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTEVERY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: notevery ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-notevery.test ;; ;; ;; Syntax: notevery PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: notevery returns a non-nil as soon as any invocation of PRIDICATE returns a nil. ;; If the end of a sequence is reached, notevery returns a nil. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test notevery - If the end of a sequence is reached, nil is returned" (and (eq (notevery #'+ '(2 4 6) '(1 3 5) '()) nil) (eq (notevery #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) nil) (eq (notevery #'list "abc" "cde" "" "efr") nil) (eq (notevery #'- (vector) "" (make-array 3 :initial-element nil :fill-pointer 2)) nil) ) ) (do-test "test notevery 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (notevery #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test notevery - with 110 sequences" (let ((a '(1)) ) (and (eq (notevery #'nconc (list a) '((2)) '((3)) '((4)) '((5)) '((6)) '((7)) '((8)) '((9)) '((10)) '((11)) '((12)) '((13)) '((14)) '((15)) '((16)) '((17)) '((18)) '((19)) '((20)) '((21)) '((22)) '((23)) '((24)) '((25)) '((26)) '((27)) '((28)) '((29)) '((30)) '((31)) '((32)) '((33)) '((34)) '((35)) '((36)) '((37)) '((38)) '((39)) '((40)) '((41)) '((42)) '((43)) '((44)) '((45)) '((46)) '((47)) '((48)) '((49)) '((50)) '((51)) '((52)) '((53)) '((54)) '((55)) '((56)) '((57)) '((58)) '((59)) '((60)) '((61)) '((62)) '((63)) '((64)) '((65)) '((66)) '((67)) '((68)) '((69)) '((70)) '((71)) '((72)) '((73)) '((74)) '((75)) '((76)) '((77)) '((78)) '((79)) '((80)) '((81)) '((82)) '((83)) '((84)) '((85)) '((86)) '((87)) '((88)) '((89)) '((90)) '((91)) '((92)) '((93)) '((94)) '((95)) '((96)) '((97)) '((98)) '((99)) '((100)) '((101)) '((102)) '((103)) '((104)) '((105)) '((106)) '((107)) '((108)) '((109)) '((110))) nil) (equal a (do ((n 1 (1+ n)) (buf nil (append buf (list n)))) ((= n 111) buf) )) ) ) ) (do-test "test notevery 1" (and (not (notevery #'identity '#(t t 3 t 2 t t 5 t 9))) (notevery #'identity '(t t 3 t 2 t t 5 nil t 9)) ) ) (do-test "test notevery 2" (and (eq (notevery #'lower-case-p "twinkle twinkle little star !") t) (eq (notevery #'lower-case-p "twinkletwinklelittlestar") nil) (eq (notevery #'oddp '#(1 3 5 7 17 35 17 39 97 77 91 -2)) t) (eq (notevery #'oddp '#(1 3 5 7 17 35 17 39 97 77 91 -3)) nil) ) ) (do-test "test notevery 3" (and ( eq (notevery #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) t) ( eq (notevery #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 7 99) ((a) ((a)) a 'a) (2 6 7 a) )) nil) ( eq (notevery #'(lambda (x y) (member x y :test #'eq)) '(2 6 7 a) '( (1 2 (3)) (4 5 (6) 6) (88 17 99) ((a) ((a)) a 'a) (2 6 7 a) )) t) ) ) (do-test "test notevery 4" (and (eq (notevery #'>= '(100 90 60 50 40 1 2) '(95 87 43 30 35 8 11) '(5 9 40 25 3)) nil) (equal (notevery #'>= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) t) (equal (notevery #'>= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 20 3)) nil) ) ) (do-test "test notevery 5" (and (eq (notevery #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) t) (eq (notevery #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(4 4 1 5) "eeag" (make-array 4 :initial-element 'character :fill-pointer 1)) nil) (eq (notevery #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(4 3 1 5) "eeag" (make-array 4 :initial-element 'character)) t) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-REDUCE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-REDUCE.TEST new file mode 100644 index 00000000..3402dd19 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-REDUCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: reduce ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 251 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Sept. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-reduce.test ;; ;; ;; Syntax: reduce FUNCTION SEQUENCE &KEY :FROM-END :START :END :INITIAL-VALUE ;; ;; Function Description: The reduce function combines all the elements of a sequence using a binary function. ;; ;; Argument(s): FUNCTION - a lisp function which takes two argument ;; SEQUENCE - ;; :FROM-END - t: the reduction is left-associative ;; nil: the reduction is right-associative ;; :START - an integer, used to specify a subsequence ;; :END - an integer, used to specify a subsequence ;; :INITIAL-VALUE - an object whilch is logically placed before or after the subsequence (depends on ;; the value of :FROM-END)and included in the reduction operation ;; ;; Returns: anything ;; (do-test "test reduce -test cases copied from page 251 of CLtL" (and (= (reduce #'+ '(1 2 3 4)) 10) (= (reduce #'- '(1 2 3 4)) -8) (= (reduce #'- '(1 2 3 4) :from-end t) -2) (= (reduce #'+ '()) 0) (= (reduce #'= '(3)) 3) (eq (reduce #'+ '(foo)) 'foo) (equal (reduce #'list '(1 2 3 4)) '(((1 2) 3) 4)) (equal (reduce #'list '(1 2 3 4) :from-end t) '(1 (2 (3 4)))) (equal (reduce #'list '(1 2 3 4) :initial-value 'foo) '((((foo 1) 2) 3) 4)) (equal (reduce #'list '(1 2 3 4) :from-end t :initial-value 'foo) '(1 (2 (3 (4 foo))))) ) ) (do-test "test reduce - when the specified sequence contains one element and no :initial-value is given" ;; ;; then that element is returned and the function is not called ;; (and (equal (reduce #'* "a") #\a) (= (reduce #'- (vector 4)) 4) (eq (reduce #'+ '(foo1 foo2 foo3) :start 1 :end 2) 'foo2) (eq (reduce #'list '(foo1 foo2 foo3) :start 2) 'foo3) ) ) (do-test "test reduce - when the specified sequence is empty and an :initial-value is given" ;; ;; then the :initial-value is retuned and the function is not called ;; (and (= (reduce #'list () :initial-value 3) 3) (equal (reduce #'evenp () :initial-value "little") "little") (equal (reduce #'listp () :initial-value '(1 2 (3 4))) '(1 2 (3 4))) (= (reduce #'stringp () :initial-value #c(-3 -4)) #c(-3 -4)) ) ) (do-test "test reduce - when the specified subsequence is empty and no :initial-value is given" ;; ;; then the function is called with zero arguments, and reduce returns whatever the function does. ;; (and (= (reduce #'gcd ()) 0) (= (reduce #'* ()) 1) (eq (reduce #'+ ()) 0) ) ) (do-test "test reduce 0" (prog2 (setq a '(sleepy jumpy grouchy doc bashful dopey sneezy)) (and (equal (reduce #'cons a) '(((((( sleepy . jumpy) . grouchy) . doc) . bashful) . dopey) . sneezy)) (equal (reduce #'cons a :from-end t :initial-value 'snow-white) '(sleepy jumpy grouchy doc bashful dopey sneezy . snow-white)) (equal (reduce #'cons a :start 1 :end 5 :initial-value 'apple) '((((apple . jumpy) . grouchy) . doc) . bashful) ) (equal (reduce #'cons a :from-end t :start 2 :end 7 :initial-value 'witch) '(grouchy doc bashful dopey sneezy . witch)) ) ) ) (do-test "test reduce 1" (prog2 (setq a (vector #c(1 2) #c(-1 -2) #c(-1 -1) #c(0 2) #c(-3 1) #c(2 -2))) (and (= (reduce #'* a) #c(120 40)) (= (reduce #'* a :start 1 :from-end t) #c(40 -40)) (= (reduce #'+ a :end 3 :initial-value #c(9 -9)) #c(8 -10)) (= (reduce #'- a :start 3 :end 6 :from-end t :initial-value #c(8 8)) #c(-3 -9)) (= (reduce #'- a :start 3 :end 6 :initial-value #c(8 8)) #c(9 7)) ) ) ) (do-test "test reduce 2" (prog2 (setq a (do ((n 0 (1+ n)) (m nil (append m (list n)))) ((= n 100) m) )) (and (= (reduce #'- a :start 49 :end 59) -437) (equal (reduce #'list a :start 70 :end 81 :initial-value -70) '(((((((((((-70 70) 71) 72 ) 73 ) 74) 75) 76) 77) 78) 79) 80) ) (equal (reduce #'cons a :end 21 :initial-value 900 :from-end t) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 . 900)) (= (reduce #'(lambda (x y) (+ (* x 100) y)) a :start 50 :end 52 :initial-value 2) 25051) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-2-SOME.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-2-SOME.TEST new file mode 100644 index 00000000..2170078f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-SOME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: some ;; ;; Source: CLtL Section 14.2: Concatenating, Mapping, and Reducing Sequences Page: 250 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 5 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-2-some.test ;; ;; ;; Syntax: some PREDICATE SEQUENCE &REST MORE-SEQUENCES ;; ;; Function Description: some returns as soon as any invocation of PREDICATE returns a non-nil value; some returns ;; that value. If the end of a sequence is reached, some returns nil. ;; ;; Argument(s): PREDICATE - a function which produces a Boolean value, and should take as many arguments ;; as there are sequences provided. ;; SEQUENCE - ;; ;; Returns: nil or non-nil ;; (do-test "test some - If the end of a sequence is reached, nil is returned" (and (eq (some #'+ '(2 4 6) '(1 3 5) '()) nil) (eq (some #'* '(1 2) '(2 3) '(3 4) '(4 5) '(5 6) '(6 7) '(7 8) '(8 9) '(9 0) '()) ()) (eq (some #'list "abc" "cde" "" "efr") nil) (eq (some #'- '#() "" (make-array 3 :initial-element nil)) nil) ) ) (do-test "test some 0" ;; the predicate is first applied to the elements with index 0 in each of the sequences, ;; and possibly then to the elements with index 1, and so on, until a termination criterion is ;; met or the end of the shortest of the sequences is reached. (let ( buf ) (some #'(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) (setq buf (append buf (list x25 x24 x23 x22 x21 x20 x19 x18 x17 x16 x15 x14 x13 x12 x11 x10 x9 x8 x7 x6 x5 x4 x3 x2 x1) )) nil ) '(elm11 elm12 elm13 elm14) '(elm21 elm22 elm23 elm24) '(elm31 elm32 elm33 elm34) '(elm41 elm42 elm43 elm44) '(elm51 elm52 elm53 elm54 elm55) '(elm61 elm62 elm63 elm64 elm65 elm66) '(elm71 elm72 elm73 elm74) '(elm81 elm82 elm83) '(elm91 elm92 elm93 elm94) '(elm101 elm102 elm103 elm104 elm105) '(elm111 elm112 elm113 elm114 elm115) `(elm121 elm122 elm123 elm124) '(elm131 elm132 elm133 elm134) '(elm141 elm142 elm143 elm144) '(elm151 elm152 elm153 elm154 elm155) '(elm161 elm162 elm163 elm164 elm165) '(elm171 elm172 elm173 elm174) '(elm181 elm182 elm183 elm184 elm185) '(elm191 elm192 elm193 elm194) '(elm201 elm202 elm203 elm204 elm205) '(elm211 elm212 elm213 elm214 elm215 elm216 elm217) '(elm221 elm222 elm223 elm224 elm225) '(elm231 elm232 elm233 elm234 elm235) '(elm241 elm242 elm243 elm244) '(elm251 elm252 elm253 elm254) ) (equal buf '(elm251 elm241 elm231 elm221 elm211 elm201 elm191 elm181 elm171 elm161 elm151 elm141 elm131 elm121 elm111 elm101 elm91 elm81 elm71 elm61 elm51 elm41 elm31 elm21 elm11 elm252 elm242 elm232 elm222 elm212 elm202 elm192 elm182 elm172 elm162 elm152 elm142 elm132 elm122 elm112 elm102 elm92 elm82 elm72 elm62 elm52 elm42 elm32 elm22 elm12 elm253 elm243 elm233 elm223 elm213 elm203 elm193 elm183 elm173 elm163 elm153 elm143 elm133 elm123 elm113 elm103 elm93 elm83 elm73 elm63 elm53 elm43 elm33 elm23 elm13 )) ) ) (do-test "test some - with 100 sequences" (= (some #'+ '(1) '(2) '(3) '(4) '(5) '(6) '(7) '(8) '(9) '(10) '(11) '(12) '(13) '(14) '(15) '(16) '(17) '(18) '(19) '(20) '(21) '(22) '(23) '(24) '(25) '(26) '(27) '(28) '(29) '(30) '(31) '(32) '(33) '(34) '(35) '(36) '(37) '(38) '(39) '(40) '(41) '(42) '(43) '(44) '(45) '(46) '(47) '(48) '(49) '(50) '(51) '(52) '(53) '(54) '(55) '(56) '(57) '(58) '(59) '(60) '(61) '(62) '(63) '(64) '(65) '(66) '(67) '(68) '(69) '(70) '(71) '(72) '(73) '(74) '(75) '(76) '(77) '(78) '(79) '(80) '(81) '(82) '(83) '(84) '(85) '(86) '(87) '(88) '(89) '(90) '(91) '(92) '(93) '(94) '(95) '(96) '(97) '(98) '(99) '(100) ) (/ (* (+ 1 100) 100) 2) )) (do-test "test some 1" (and (eq (some #'identity '#(nil nil nil nil nil nil nil nil nil nil)) nil) (eq (some #'identity '(nil nil nil nil nil 3 nil nil)) 3) ) ) (do-test "test some 2" (and (eq (some #'upper-case-p "twinkle twinkle little star !") nil) (equal (some #'upper-case-p "twinkle twinkle lIttle star !") t) (eq (some #'evenp '#(1 3 5 7 17 35 17 39 97 77 91 -2)) t) (eq (some #'complexp '#(1 3 5 7 17 35 17 39 97 77 91 -2)) nil) ) ) (do-test "test some 3" (and ( eq (some #'(lambda (x y) (member x y :test #'equal)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) 'a) (2 6 7 a) )) nil) ( equal (some #'(lambda (x y) (member x y :test #'equal)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 7 99) ((a) ((a)) 'a) (2 6 7 a) )) '(7 99)) ( equal (some #'(lambda (x y) (member x y :test #'equal)) '(2 6 7 a) '( (1 4 (3)) (4 5 (6)) (88 77 99) ((a) ((a)) a 'a) (2 6 7 a) )) '(a 'a)) ) ) (do-test "test some 4" (and (eq (some #'<= '(100 90 60 50 40 1 2) '(95 87 43 20 35 8 11) '(5 9 40 25 3)) nil) (equal (some #'<= '(100 90 60 50 40 1 2) '(95 87 83 20 35 8 11) '(5 9 90 25 3)) t) (equal (some #'<= '(100 90 60 50 40 1 2) '(95 90 43 20 35 8 11) '(5 90 40 25 3)) t) ) ) (do-test "test some 5" (and (eq (some #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 4 1 5) "sifn" '(number bit list array)) nil) (equal (some #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 4 1 5) "sian" (make-array 4 :initial-element 'character)) #\a) (equal (some #'(lambda (w x y z) (if (and (equal (elt w x) y) (typep y z)) y nil)) '#("summer" "winter" "fall" "spring") '(3 1 1 5) "sian" (make-array 4 :initial-element 'character)) #\i) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-DUPLICATES.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-DUPLICATES.TEST new file mode 100644 index 00000000..8adae10f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-DUPLICATES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: delete-duplicates ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Oct. 1 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-delete-duplicates.test ;; ;; ;; Syntax: delete-duplicates SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: The elements of SEQUENCE are compared pairwise, and if any two match, then the one occurring ;; earlier in the sequence is discarded (if :FROM-ENT is true, then the one later in the sequence ;; is discarded). The result is a sequence of the same kind as the argument SEQUENCE with enough ;; elements deleted so that no two of the remaining elements match. ;; ;; Argument(s): SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test case copied from page 255 of CLtL" (and (equal (delete-duplicates '(a b c b d d e)) '(a c b d e)) (equal (delete-duplicates '(a b c b d d e) :from-end t) '(a b c d e)) (equal (delete-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr) '((bar #\%) (baz #\A))) (equal (delete-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr :from-end t) '((foo #\a) (bar #\%)) ) ) ) (do-test "test delete-duplicates 0" (let ( (a '(1 3 5 3 6 8 9 4 2 0 3 4 2 3 1)) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (delete-duplicates a) '( 5 6 8 9 0 4 2 3 1) ) (equal (delete-duplicates b :start 3) '( 1 3 5 6 8 9 0 4 2 3 1) ) (equal (delete-duplicates c :end 10) '(1 5 3 6 8 9 4 2 0 3 4 2 3 1)) (equal (delete-duplicates d :start 2 :end 12) '(1 3 5 6 8 9 2 0 3 4 2 3 1)) (equal (delete-duplicates e :start 2 :end 12 :from-end t) '(1 3 5 3 6 8 9 4 2 0 2 3 1)) ) ) ) (do-test "test delete-duplicates 1" (let ( (a "sneezy SleePY grouchy dopey jumpy bashful") b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (delete-duplicates a :test #'char-equal) "nzgrcdoejmpy bashful") (equal (delete-duplicates b :test #'equal) "nzSPYgrcdoejmpy bashful") (equal (delete-duplicates c :test #'equal :from-end t) "snezy SlPYgrouchdpjmbaf") ) ) ) (do-test "test delete-duplicates 2" (let* ( (a '( (1 2 3) (4 5) (2) (3 4) (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) (b (copy-seq a)) ) (and (equal (delete-duplicates a :test-not #'(lambda (x y) (/= (length x) (length y)))) '( (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) (equal (delete-duplicates b :test-not #'(lambda (x y) (/= (length x) (length y))) :from-end t) '((1 2 3) (4 5) (2) (9 8 1 2) (2 2 3 1 4)) ) ) ) ) (do-test "test delete-duplicates 3" (let ( (a (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equalp (delete-duplicates a :test #'= :key #'realpart) (vector #c(2 -1) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (delete-duplicates b :test #'= :key #'imagpart) (vector #c(3.0 4) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (delete-duplicates c :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart) (vector #c(3 8) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (delete-duplicates d :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t) (vector #c(2 -1) #c(3.0 4) #c(3 8) #c(-3.0 7) ) ) (equalp (delete-duplicates e :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t :start 1 :end 7) (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(-3.0 7) #c(15 -1)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF-NOT.TEST new file mode 100644 index 00000000..0a7b32a2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: delete-if-not ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-delete-if-not.test ;; ;; ;; Syntax: delete-if-not TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: delete-if-not returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and not satisfying ;; TEST have been deleted. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements deleted from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test delete-if-not 0" (let ((a '#(1 3 4 2 5 6 3 20 6 8 5 6 7 4 3 2 4 6 7 5) ) b c) (setf b (copy-seq a) c (copy-seq b) ) (and (equalp (delete-if-not #'evenp a) '#(4 2 6 20 6 8 6 4 2 4 6 ) ) (equalp (delete-if-not #'evenp b :count 5) '#(4 2 6 20 6 8 6 7 4 3 2 4 6 7 5) ) (equalp (delete-if-not #'evenp c :count 5 :from-end t) '#(1 3 4 2 5 6 3 20 6 8 6 4 2 4 6 ) ) ) ) ) (do-test "test delete-if-not 1" (let ((a "aN inteGeR WhICH liMitS thE NumbEr oF eLemenTs reMoved FrOm SeQuenCE") b c) (setq b (copy-seq a) c (copy-seq b)) (and (equal (delete-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :start 20) "aN inteGeR WhICH liMit th umbr o eemens reoved rm euen") (equal (delete-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) b :end 40) "a intee h liit th umbr o eemenTs reMoved FrOm SeQuenCE") (equal (delete-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) c :start 5 :end 50) "aN intee h liit th umbr o eemens reoved FrOm SeQuenCE") ) ) ) (do-test "test delete-if-not 2" (let ((a '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "tyhfgwsjkkh" "olkdewskddc" "ppmmnnllkkplm")) b c ) (setf b (copy-seq a) c (copy-seq a)) (and (equal (delete-if-not #'(lambda (x) (find #\p x)) a :key #'(lambda (y) (subseq (reverse y) 0 3))) '("ikjlkmop" "jnmdkpmn" "ppmmnnllkkplm")) (equal (delete-if-not #'(lambda (x) (find #\p x)) b :key #'(lambda (y) (subseq (reverse y) 0 3)) :from-end t :count 2) '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "ppmmnnllkkplm")) (equal (delete-if-not #'(lambda (x) (find #\k x)) c :key #'(lambda (y) (subseq y 2 5)) :count 3) '("ikjlkmop" "jnmdkpmn" "olkdewskddc" "ppmmnnllkkplm")) ) ) ) (do-test "test delete-if-not 3" (let ((a (make-array 11 :initial-contents '( #c(2 10) #c(3 -5) #c(1 9) #c(10 20) #c(-5 42) #c(40 2) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) ) b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equalp (delete-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) a :start 2 :end 7 :from-end nil :count 3 :key #'identity) (vector #c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (delete-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) b :start 2 :end 7 :from-end 'non-nil :count 3 :key #'identity) (vector #c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (delete-if-not #'oddp c :start 1 :end 9 :count 3 :key #'realpart) (vector #c(2 10) #c(3 -5) #c(1 9) #c(-5 42) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (delete-if-not #'minusp d :start 1 :end 9 :count 4 :key #'realpart) (vector #c(2 10) #c(-5 42) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) ) ) ) (do-test "test delete-if-not 4" (let ((a '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) ) b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equal (delete-if-not #'floatp a :start 1 :end 8 :key #'cdr :count 2) '((3 . 2.4) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (delete-if-not #'floatp b :start 1 :end 8 :key #'cdr :count 2 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (2 . 222)) ) (equal (delete-if-not #'oddp c :start 2 :end 8 :key #'first :count 1 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (delete-if-not #'oddp d :start 2 :end 8 :key #'first :count 1 ) '((3 . 2.4) (5 . -5) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF.TEST new file mode 100644 index 00000000..1494ba45 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: delete-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Sept. 22 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-delete-if.test ;; ;; ;; Syntax: delete-if TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: delete-if returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and satisfying the ;; TEST have been deleted. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements deleted from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test delete-if 0" (and (equal (delete-if #'oddp '(1 2 4 1 3 4 5)) '(2 4 4)) (equal (delete-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) (let ((a '(1 3 4 2 5 6 3 9 8 7 10 20 31 25 87 3 4 5 3 4 2 10 22 38 100 50 25 22)) b c) (setq b (copy-seq a) c (copy-seq a)) (and (equal (delete-if #'evenp a) '(1 3 5 3 9 7 31 25 87 3 5 3 25 )) (equal (delete-if #'evenp b :count 10) '(1 3 5 3 9 7 31 25 87 3 5 3 22 38 100 50 25 22)) (equal (delete-if #'evenp c :count 10 :from-end t) '(1 3 4 2 5 6 3 9 8 7 10 31 25 87 3 5 3 25 )) ) ) ) ) (do-test "test delete-if 1" (let ((a "watermelon banana tomato pineapple pear peach plum apple orange cantalope honeydew") b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (delete-if #'(lambda (x) (> (char-code x) (char-code #\r))) a :end 30) "aermelon banana omao pineapple pear peach plum apple orange cantalope honeydew") (equal (delete-if #'(lambda (x) (> (char-code x) (char-code #\r))) b :start 60 ) "watermelon banana tomato pineapple pear peach plum apple orange canalope honede") (equal (delete-if #'alpha-char-p c :start 11 :end 64) "watermelon cantalope honeydew") ) ) ) (do-test "test delete-if 2" (let* ((a '( ( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) (1.1 (2.2) 3.3 4.4 5.5)) ) (b (copy-seq a)) ) (and (equal (delete-if #'(lambda (x ) (<= (length x) 2)) a :key #'cadr) '( (10 (20 30 40) 50 60) )) (equal (delete-if #'(lambda (x ) (< (length x) 2)) b :key #'cadr :count 1 :from-end t) '(( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) )) ) ) ) (do-test "test delete-if 3" (let ((a '( (10 20 30) (-2 23) (-9 99) (34 49) (3 2 1) (20 34 13) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) )) (equal (delete-if #'(lambda (x) (and (> x 5) (oddp x))) a :start 2 :end 7 :from-end t :count 2 :key #'(lambda (x) (first (last x))) ) '((10 20 30) (-2 23) (-9 99) (3 2 1) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) ) ) ) (do-test "test delete-if 4" (let ((a '(8 #\a (1 2) #\b 3.4 -9.85 #\e "abdesd" (2 3 4 5) #\o #\a (+ 2 3) #\a "banana") )) (equal (delete-if #'characterp a :start 2 :end 12 :from-end t :count 3) '(8 #\a (1 2) #\b 3.4 -9.85 "abdesd" (2 3 4 5) (+ 2 3) #\a "banana") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE.TEST new file mode 100644 index 00000000..c616dfa8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: delete ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-delete.test ;; ;; ;; Syntax: delete ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: delete returns a sequence of the same kind as the argument SEQUENCE that has the same elements ;; except that those in the subsequence delimited by :START and :END and satisfying the test have ;; been deleted. This is a destructive operation. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements deleted from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test delete - test cases from page 254 of CLtL" (and (equal (delete 4 '(1 2 4 1 3 4 5)) '(1 2 1 3 5)) (equal (delete 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5)) (equal (delete 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) (equal (delete 3 '(1 2 4 1 3 4 5) :test #'>) '(4 3 4 5)) ) ) (do-test "test delete 1" (let* ((a '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) (b (copy-seq a)) (c (copy-seq a)) (d (copy-seq a)) (e (copy-seq a) ) (f (copy-seq a))) (and (equal (delete 3 a) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (delete 3 b :from-end 'non-nil) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (delete 3 c :count 2) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 3 2 1)) (equal (delete 3 d :from-end t :count 2) '(1 2 3 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (delete 3 e :count 0) '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) (equal (delete 3 f :from-end t :count 0) '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) ) ) ) (do-test "test delete 2" (let* ((b "abcdefgabcdefgabcdefgabcdefgabcdefg") (c (copy-seq b)) (d (copy-seq b)) (e (copy-seq b))) (and (equal (delete #\b b :test #'char>) "bcdefgbcdefgbcdefgbcdefgbcdefg") (equal (delete #\c c :test #'(lambda (x y) (= (char-code x) (- (char-code y) 2))) :count 4) "abcdfgabcdfgabcdfgabcdfgabcdefg") (equal (delete #\f d :test-not #'char/=) "abcdegabcdegabcdegabcdegabcdeg") (equal (delete #\a e :test-not #'(lambda (x y) (equal x y) )) "aaaaa") ) ) ) (do-test "test delete 3" (let ((c '( (1 2 3) (2 3 4) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) d e f g) (setf d (copy-seq c) e (copy-seq c) f (copy-seq c) g (copy-seq c)) (and (equal (delete '(1 2 3) c :start 1 :test #'equal) '((1 2 3) (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (8 9 0) (4 5 6) )) (equal (delete '(2 3 4) d :end 6 :test #'equal) '((1 2 3) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) (equal (delete '(1 2 3 ) e :start 2 :end 7 :test #'equal) '((1 2 3) (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) )) (equal (delete 2 f :key #'second ) '( (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (8 9 0) (4 5 6) ) ) (equal (delete 6 g :test #'< :key #'third) '((1 2 3) (2 3 4) (4 5 6) (1 2 3) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) ) ) ) (do-test "test delete 4" (let ((a '((9 2 3) (8 2 4) (1 2 4) (-4 3 2) (5 3 5) (-5 2 1) (3 4) (2 9) (10 2) (-2 4)) )) (equal (delete 5 a :from-end t :start 2 :end 8 :test #'> :count 4 :key #'car) '((9 2 3) (8 2 4) (1 2 4) (5 3 5) (10 2) (-2 4)) ) ) ) (do-test "test delete 5" (let* ((a '#((1 #\2 3) (#\a #\b) (#\9 8 5) (#\1 #\2 #\3) (1 2 3) (3 #\2 1) (4 #\3 #\8) (#\q #\w #\e)) ) (b (delete 56 a :start 1 :end 7 :test-not #'(lambda (x y) (equal (type-of x) (type-of y))) :key #'second) )) (equalp b '#( (1 #\2 3) (#\9 8 5) (1 2 3) (#\q #\w #\e))) ) ) (do-test "test delete 6" (let ( (a (make-array 200 :element-type 'float)) b) (fill (fill (fill (fill a 20.0 :end 50) 30.0 :start 50 :end 100) 40.0 :start 100 :end 150) 50.0 :start 150 ) (setq b (delete 35 a :start 75 :end 150 :test #'(lambda (x y) (or (= (+ x 5) y) (= (- x 5) y))) )) (equalp b (make-array (+ 50 25 50) :initial-contents (append (make-list 50 :initial-element 20.0) (make-list 25 :initial-element 30.0) (make-list 50 :initial-element 50.0)))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-FILL.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-FILL.TEST new file mode 100644 index 00000000..52b9ae32 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-FILL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fill ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 252 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 9 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-fill.test ;; ;; ;; Syntax: fill SEQUENCE ITEM &KEY :START :END ;; ;; Function Description: fill destructively modifies SEQUENCE by replacing each element of the subsequence specified ;; by :START and :END parameters with ITEM. ;; ;; Argument(s): SEQUENCE - ;; ITEM - any Lisp object which must be a suitable element for the SEQUENCE ;; :START - an integer index into the SEQUENCE ; :START < :END ;; :END - an integer index into the SEQUENCE ; :END < (length SEQUENCE) ;; ;; Returns: a sequence ;; (do-test "test fill - test cases from page 252 of CLtL" (let ( (x '#(a b c d e)) ) (and (prog2 (fill x 'z :start 1 :end 3) (every #'(lambda (m n) (eq (elt x m) n)) '(0 1 2 3 4) '(a z z d e))) (prog2 (fill x 'p) (every #'(lambda (m n) (eq (elt x m) n)) '(0 1 2 3 4) '(p p p p p))) ) ) ) (do-test "test fill 0" (let* ((a "a b c d e f g h i j k l m n o p q r s t u v w x y z a b c d e f g h i j k l m n o p q r s t u v w x y z") (b (copy-seq a)) (c (copy-seq a))) (fill a #\0) (fill b #\1 :start 0) (fill c #\2 :end (length c)) (every #'(lambda (m n) (equal m (make-string 103 :initial-element n))) (list a b c) '(#\0 #\1 #\2)) ) ) (do-test "test fill 1" (let ((a (make-array 40))) (fill (fill (fill (fill a #'+ :end 10) #'- :start 10 :end 20) #'* :start 20 :end 30) #'max :start 30) (every #'(lambda (w x y z) (= (funcall (elt a w) x y) z)) (do ((n 0 (1+ n)) (lst nil (append lst (list n)))) ((= n 40) lst)) '(1 3 5 7 9 11 13 15 10 20 30 40 2 3 4 1 6 5 7 8 9 3 2 -1 -5 -3 -7 -8 0 2 -4 3 4 2 1 2 9 7 5 3) '(2 4 6 1 0 2 4 6 -3 -2 -1 -6 4 -1 1 2 0 1 2 3 4 5 6 7 -6 4 3 10 5 2 3 -1 2 1 0 3 4 6 2 3) '(3 7 11 8 9 13 17 21 7 18 31 46 -2 4 3 -1 6 4 5 5 36 15 12 -7 30 -12 -21 -80 0 4 3 3 4 2 1 3 9 7 5 3)) ) ) (do-test "test fill 2" (let ((a (make-array 400)) (b '(dopey sleepy sneezy grouchy))) (dotimes (n 400 nil) (fill a (elt b (mod n 4)) :start n :end (1+ n))) (equalp a (make-array 400 :initial-contents (apply #'append (make-list 100 :initial-element (subseq b 0 4))))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF-NOT.TEST new file mode 100644 index 00000000..8b70b167 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-if-not ;; ;; Source: CLtL Section 14.3: Modif-notying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 26 ,1986 ;; ;; Last Update: Sept. 26 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-find-if-not.test ;; ;; ;; Syntax: find-if-not SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the left most ;; (or rightmost) such element is returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test find-if-not 0" (and (= (find-if-not #'evenp '(2 5 3 7 8 9 0)) 5) (= (find-if-not #'evenp '(2 5 3 7 8 9 0) :from-end t) 9) (eq (find-if-not #'integerp '(3 4 5 6 7 2 1)) nil) (eq (find-if-not #'numberp '(3 4 5 6 7 2 1)) nil) (equal (find-if-not #'atom '( 3 4 (5) 9 8 (9) 7) :from-end t) '(9)) ) ) (do-test "test find-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) (and (equal (find-if-not #'(lambda (x) (<= (realpart x) 8)) a ) #c(10 -2)) (equal (find-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) #c(10 -4) ) (equal (find-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) #c(8 9)) (equal (find-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a :from-end t) #c(7 65) ) (eq (find-if-not #'complexp a) nil) ) ) ) (do-test "test find-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) (and (char= (find-if-not #'lower-case-p a) #\W) (char= (find-if-not #'lower-case-p a :start 42) #\space) (char= (find-if-not #'lower-case-p a :start 49 :end 57) #\,) (char= (find-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) #\.) (char= (find-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\space))) a :end 60 :from-end t) #\,) ) ) ) (do-test "test find-if-not 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) (and (equal (find-if-not #'oddp a :key #'cdr :from-end t) '(6 . 12) ) (equal (find-if-not #'evenp a :key #'cdr ) '(5 . -5)) (equal (find-if-not #'minusp a :key #'car) '(3 . 4)) (equal (find-if-not #'plusp a :key #'car) '(-23 . 9)) ) ) ) (do-test "test fine-if-not 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) (and (equal (find-if-not #'listp a :start 1 :end 14 :from-end t) "str1") (equal (find-if-not #'vectorp a :start 6 ) '(8 9)) (equalp (find-if-not #'bit-vector-p a :start 5) (vector 3 4 5)) (equal (find-if-not #'null a :start 10 :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3)) )) "str1") (equal (find-if-not #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3) #\2) )) "str3") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF.TEST new file mode 100644 index 00000000..304d86da --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 26 ,1986 ;; ;; Last Update: Sept. 26 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-find-if.test ;; ;; ;; Syntax: find-if SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the liftmost ;; (or rightmost) such element is returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test find-if 0" (and (= (find-if #'oddp '(2 5 3 7 8 9 0)) 5) (= (find-if #'oddp '(2 5 3 7 8 9 0) :from-end t) 9) (eq (find-if #'complexp '(3 4 5 6 7 2 1)) nil) (eq (find-if #'floatp '(3 4 5 6 7 2 1)) nil) (equal (find-if #'consp '( 3 4 (5) 9 8 (9) 7) :from-end t) '(9)) ) ) (do-test "test find-if 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) (and (equal (find-if #'(lambda (x) (> (realpart x) 8)) a ) #c(10 -2)) (equal (find-if #'(lambda (x) (> (realpart x) 8)) a :from-end t) #c(10 -4) ) (equal (find-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a ) #c(8 9)) (equal (find-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a :from-end t) #c(7 65) ) (eq (find-if #'integerp a) nil) ) ) ) (do-test "test find-if 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) (and (char= (find-if #'upper-case-p a) #\W) (char= (find-if #'upper-case-p a :start 42) #\N) (char= (find-if #'upper-case-p a :start 49 :end 57) #\M) (char= (find-if #'(lambda (x) (not (alpha-char-p x))) a :start 35) #\.) (char= (find-if #'(lambda (x) (not (or (alpha-char-p x) (char= x #\space)))) a :end 60 :from-end t) #\,) ) ) ) (do-test "test find-if 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) (and (equal (find-if #'evenp a :key #'cdr :from-end t) '(6 . 12) ) (equal (find-if #'oddp a :key #'cdr ) '(5 . -5)) (equal (find-if #'plusp a :key #'car) '(3 . 4)) (equal (find-if #'minusp a :key #'car) '(-23 . 9)) ) ) ) (do-test "test fine-if 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) (and (= (find-if #'integerp a :start 1 :end 14 :from-end t) 33) (equal (find-if #'vectorp a :start 6 ) "gcd") (equalp (find-if #'bit-vector-p a :start 6) #*101010) (eq (find-if #'(lambda (x) (equal x #\2)) a :start 10 :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) nil) (equal (find-if #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) "str2") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND.TEST new file mode 100644 index 00000000..a0cc9b79 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: find ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 25 ,1986 ;; ;; Last Update: Sept. 25 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-find.test ;; ;; ;; Syntax: find ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the liftmost ;; (or rightmost) such element is returned. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test find 0" (and (eq (find 2 '(3 4 5 6 2 1 4)) 2) (eq (find 3 '(1 2 4 5 6 7 8 9)) nil) (equal (find '(1 2) '( 1 2 ((1 2)) 3 4 (1 2)) :test #'equal ) '(1 2)) (char-equal (find #\q "antique" :test #'equal) #\Q) (equalp (find #*1011 (vector #*0000 #*1111 #*1011) :test #'equalp) #*1011) ) ) (do-test "test find 1" (let ((a '(3 4 7 8 -2 9 8 -3 4 6 1 4 5 2 0 4) )) (and (eq (find 7 a :start 3) nil) (= (find 7 a :start 2 ) 7) (eq (find -3 a :end 7 ) nil) (= (find -3 a :end 8) -3) (eq (find -2 a :start 5 :end 14) nil) (= (find -2 a :start 4 :end 14) -2) (eq (find 2 a :start 4 :end 13) nil) (= (find 2 a :start 4 :end 14) 2) (eq (find 11 a ) nil) ) ) ) (do-test "test find 2" (let (( a "Fatal error in function SYSTEM: TASK-SCHEDULER")) (and (char= (find #\n a :test #'char=) #\n) (char= (find #\: a :test #'char=) #\:) (char= (find #\a a :test-not #'char>= ) #\t) (char= (find #\F a :test #'(lambda (x y) (and (alpha-char-p y) (char> x y)))) #\E) (char= (find #\R a :test-not #'(lambda (x y) (/= (- (char-code y) (char-code x)) (- (char-code #\a) (char-code #\A)) ))) #\r) ) ) ) (do-test "test find 3" (let ((a '( (1 3 5) (2 4 6)(38 5 7) (4 2 1) (-3 -5 -7) (-2 -4 -1) (10 22 31) (38 72 10)) )) (and (equal (find 7 a :key #'third) '(38 5 7)) (equal (find -4 a :key #'second) '(-2 -4 -1)) (equal (find 38 a :key #'first) '(38 5 7)) (equal (find 38 a :key #'first :from-end t) '(38 72 10)) (equal (find 0 a :key #'cadr :test #'(lambda (x y) (> x y))) '(-3 -5 -7)) (equal (find 0 a :key #'cadr :test #'(lambda (x y) (> x y)) :from-end t) '(-2 -4 -1)) ) ) ) (do-test "test find 4" (let ((a '(#*11111 #*0000 #*10101010 #*01010101 #*111 #*00000 #*1110 #*0101111 #*000 #*11100 #*01000) )) (and (equalp (find #*10 a :start 4 :end 10 :test #'equalp :key #'(lambda (x) (subseq x 1 3))) #*0101111) (equalp (find #*11 a :start 1 :end 9 :test #'equalp :from-end t :key #'(lambda (x) (subseq x 0 2)) ) #*1110) (equalp (find #*01 a :start 4 :end 10 :test-not #'(lambda (x y) (or (/= (elt x 0) (elt y 0)) (/= (elt x 1) (elt y 1)) )) :from-end t) #*0101111) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 0 y))) #*11111) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 0 y)) :from-end t) #*111) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 1 y)) :start 2 :from-end t) #*000) (equalp (find 'dummy a :test-not #'(lambda (x y) (find 1 y)) ) #*0000 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF-NOT.TEST new file mode 100644 index 00000000..b0ece777 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nsubstitute-if-not ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 256 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 25 ,1986 ;; ;; Last Update: Sept. 25 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-nsubstitute-if-not.test ;; ;; ;; Syntax: nsubstitute-if-not NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and not satisfying the test have been replaced by ;; newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (nsubstitute-if-not 9 #'oddp '(1 2 4 1 3 4 5)) '(1 9 9 1 3 9 5)) (equal (nsubstitute-if-not 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 4 9)) ) ) (do-test "test nsubstitute-if-not 0" (and (equal (nsubstitute-if-not 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 3 9 3 4 100 3 4 7 2 9 3 3 3)) (equalp (nsubstitute-if-not 7 #'zerop (vector 0 0 0 1 1 1 0 0 0 0 0 0 0 0 8 8 0 0 0 0)) (vector 0 0 0 7 7 7 0 0 0 0 0 0 0 0 7 7 0 0 0 0 )) (equal (nsubstitute-if-not "*" #'numberp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test nsubstitute-if-not 1" (let ((a "seedhead of common sunflower marin county calif-notornia nikon") b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) ) (and (equal (nsubstitute-if-not #\% #'alpha-char-p a) "seedhead%of%common%sunflower%marin%county%calif%notornia%nikon") (equal (nsubstitute-if-not #\% #'alpha-char-p b :start 10) "seedhead of%common%sunflower%marin%county%calif%notornia%nikon") (equal (nsubstitute-if-not #\% #'alpha-char-p c :end 50) "seedhead%of%common%sunflower%marin%county%calif%notornia nikon") (equal (nsubstitute-if-not #\% #'alpha-char-p d :start 15 :end 40) "seedhead of common%sunflower%marin%county calif-notornia nikon") ) ) ) (do-test "test nsubstitute-if-not 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (nsubstitute-if-not 'z #'oddp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (nsubstitute-if-not 'z #'oddp b :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if-not 'z #'oddp c :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (nsubstitute-if-not 'z #'oddp d :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if-not 'z #'oddp e :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) ) ) ) (do-test "test nsubstitute-if-not 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if-not "**" #'integerp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (nsubstitute-if-not "**" #'(lambda (x) (<= x 6)) b :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (nsubstitute-if-not "**" #'(lambda (x) (= (length x) 2)) c :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) ) ) ) (do-test "test nsubstitute-if-not 4" (let ((a '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "bashful" "dopey" "snowwhite" "witch") ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if-not "no-y" #'(lambda (x) (find #\y x)) a :end 8 :from-end t :count 2) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-y" "dopey" "no-y" "witch")) (equal (nsubstitute-if-not "no-o" #'(lambda (x) (find #\o x)) b :start 4 :end 7 :count 1 :from-end t :key #'(lambda (y) (subseq y 0 3))) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-o" "dopey" "snowwhite" "witch")) (equal (nsubstitute-if-not "no-s" #'(lambda (x) (equal x #\s)) c :start 4 :end 6 :key #'(lambda (y) (elt y 0))) '("sneezy" "sleepy" "jumpy" "grouchy" "no-s" "no-s" "dopey" "snowwhite" "witch")) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF.TEST new file mode 100644 index 00000000..21c5bed5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nsubstitute-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 256 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 25 ,1986 ;; ;; Last Update: Sept. 25 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-nsubstitute-if.test ;; ;; ;; Syntax: nsubstitute-if NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (nsubstitute-if 9 #'oddp '(1 2 4 1 3 4 5)) '(9 2 4 9 9 4 9)) (equal (nsubstitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) ) ) (do-test "test nsubstitute-if 0" (and (equal (nsubstitute-if 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(3 -3 3 -5 3 3 -3 3 3 3 3 -4 3 -8)) (equalp (nsubstitute-if 1 #'zerop (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 )) (equal (nsubstitute-if "*" #'characterp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test nsubstitute-if 1" (let ((a "seedhead of common sunflower marin county california nikon") b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) ) (and (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) a) "seedhead%of%common%sunflower%marin%county%california%nikon") (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) b :start 10) "seedhead of%common%sunflower%marin%county%california%nikon") (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) c :end 50) "seedhead%of%common%sunflower%marin%county%california nikon") (equal (nsubstitute-if #\% #'(lambda (x) (equal x #\space)) d :start 15 :end 40) "seedhead of common%sunflower%marin%county california nikon") ) ) ) (do-test "test nsubstitute-if 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (nsubstitute-if 'z #'evenp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (nsubstitute-if 'z #'evenp b :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if 'z #'evenp c :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (nsubstitute-if 'z #'evenp d :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (nsubstitute-if 'z #'evenp e :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) ) ) ) (do-test "test nsubstitute-if 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if "**" #'floatp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (nsubstitute-if "**" #'(lambda (x) (> x 6)) b :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (nsubstitute-if "**" #'(lambda (x) (/= (length x) 2)) c :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) ) ) ) (do-test "test nsubstitute-if 4" (let ((a (list #*10110 #*00000 #*11111 #*00011 #*10001 #*001100 #*101010 #*01010 #*110110) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute-if "!" #'(lambda (x) (= x 1)) a :start 2 :end 8 :from-end t :count 2 :key #'(lambda (x) (elt x 2))) (list #*10110 #*00000 #*11111 #*00011 #*10001 "!" "!" #*01010 #*110110) ) (equal (nsubstitute-if "!" #'(lambda (x) (/= (length x) 6)) b :start 3 :end 8 :count 3 :key #'identity) (list #*10110 #*00000 #*11111 "!" "!" #*001100 #*101010 "!" #*110110) ) (equal (nsubstitute-if "!" #'(lambda (x) (= x 0)) c :end 5 :count 2 :from-end t :key #'(lambda (y) (elt (reverse y) 1))) (list #*10110 "!" #*11111 #*00011 "!" #*001100 #*101010 #*01010 #*110110) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE.TEST new file mode 100644 index 00000000..d513af5c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nsubstitute ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 256 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 25 ,1986 ;; ;; Last Update: Sept. 25 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-nsubstitute.test ;; ;; ;; Syntax: nsubstitute NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; OLDITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test nsubstitute - test cases copied from page 256 of CLtL" (and (equal (nsubstitute 9 4 '(1 2 4 1 3 4 5)) '(1 2 9 1 3 9 5)) (equal (nsubstitute 9 4 '(1 2 4 1 3 4 5) :count 1 ) '(1 2 9 1 3 4 5)) (equal (nsubstitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) (equal (nsubstitute 9 3 '(1 2 4 1 3 4 5) :test #'>) '(9 9 4 9 3 4 5)) ) ) (do-test "test nsubstitute 0" (let ((a '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) b c d e) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a) e (copy-seq a) ) (and (equal (nsubstitute 8 3 a) '(8 2 1 10 8 8 9 2 1 8 10 13 30 8)) (equal (nsubstitute 8 3 b :start 5) '(3 2 1 10 3 8 9 2 1 8 10 13 30 8)) (equal (nsubstitute 8 3 c :end 9) '(8 2 1 10 8 8 9 2 1 3 10 13 30 3) ) (equal (nsubstitute 100 10 d :start 1 :end 10) '(3 2 1 100 3 3 9 2 1 3 10 13 30 3) ) (equal (nsubstitute 200 20 e ) '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) ) ) ) (do-test "test nsubstitute 1" (let ((a "abdefgbcdefegAbcDabGecba") b c d) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equal (nsubstitute #\* #\a a :count 2) "*bdefgbcdefegAbcD*bGecba") (equal (nsubstitute #\* #\a b :count 2 :from-end t) "abdefgbcdefegAbcD*bGecb*") (equal (nsubstitute #\% #\b c :count 3) "a%defg%cdefegA%cDabGecba") (equal (nsubstitute #\% #\b d :count 3 :from-end t) "abdefgbcdefegA%cDa%Gec%a") ) ) ) (do-test "test nsubstitute 2" (let ((a (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 9 '(d w 2 4) 'b 'a 7 7 't 'u 9 0) ) b c d ) (setf b (copy-seq a) c (copy-seq a) d (copy-seq a)) (and (equalp (nsubstitute "!" 6 a :test #'(lambda (x y) (and (numberp y) (< x y))) ) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 "!" '(d w 2 4) 'b 'a "!" "!" 't 'u "!" 0) ) (equalp (nsubstitute '(11 22) 'dummy b :test #'(lambda (x y) (and (numberp y) (oddp y))) ) (vector 'x 'y '(11 22) 0 'a 'z '(11 22) 6 'm 'n '(11 22) '(11 22) '(d w 2 4) 'b 'a '(11 22) '(11 22) 't 'u '(11 22) 0) ) (equalp (nsubstitute 99 9.0 c :test #'equalp) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 99 '(d w 2 4) 'b 'a 7 7 't 'u 99 0) ) (equalp (nsubstitute "nlist" 'list d :test-not #'(lambda (x y) (typep y x)) :start 10 :end 15) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n "nlist" "nlist" '(d w 2 4) "nlist" "nlist" 7 7 't 'u 9 0) ) ) ) ) (do-test "test nsubstitute 3" (let ((a '( (1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) (-7 0 1) (2 2 4 4 6) (3 1 4 2)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute 'same '(2 4) a :key #'(lambda (x) (subseq x 1 3)) :test #'equal) '(same ( 5 3 1 2) same (0 8 9 1) (-7 0 1) same (3 1 4 2)) ) (equal (nsubstitute 'fun 2 b :test #'> :key #'second) '((1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) fun (2 2 4 4 6) fun) ) (equal (nsubstitute 'foo 4 c :test #'= :key #'caddr) '(foo ( 5 3 1 2) foo (0 8 9 1) (-7 0 1) foo foo) ) ) ) ) (do-test "test nsubstitute 4" (let ((a '( (1 2 3) (-4 3 1) (3 5 -4) (6 2 -1) (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) ) b c) (setf b (copy-seq a) c (copy-seq a)) (and (equal (nsubstitute "@" 'dummy a :from-end t :start 1 :end 8 :test #'(lambda (x y) (plusp y)) :count 4 :key #'third) '((1 2 3) "@" (3 5 -4) (6 2 -1) (4 -5 -3) "@" (0 0 -2) (2 2 -4) (3 1 -4)) ) (equal (nsubstitute "?" 2 b :from-end t :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '((1 2 3) (-4 3 1) (3 5 -4) "?" (4 -5 -3) "?" "?" (2 2 -4) (3 1 -4)) ) (equal (nsubstitute "@" 2 c :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '("@" "@" (3 5 -4) "@" (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF-NOT.TEST new file mode 100644 index 00000000..3d02b322 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: position-if-not ;; ;; Source: CLtL Section 14.3: Modif-notying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 27 ,1986 ;; ;; Last Update: Sept. 27 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-position-if-not.test ;; ;; ;; Syntax: position-if-not SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the ;; indext within the sequence of the leftmost (or rightmost) such element is returned, otherwise nil is ;; returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive integer or nil ;; (do-test "test position-if-not 0" (and (= (position-if-not #'evenp '(2 52 44 5 3 7 8 9 0)) 3) (= (position-if-not #'evenp '(2 52 44 5 3 7 8 9 0) :from-end t) 7) (eq (position-if-not #'integerp '(3 4 5 6 7 2 1)) nil) (eq (position-if-not #'numberp '(3 4 5 6 7 2 1)) nil) (= (position-if-not #'atom '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 6) (= (position-if-not #'(lambda (x) (>= x 100)) ;; ;; create a list of integers from 0 to 249 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 250) b)) :from-end t) 99) ) ) (do-test "test position-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) a ) 2) (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) 7 ) (= (position-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) 1) (= (position-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a :from-end t) 3 ) (eq (position-if-not #'complexp a) nil) (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) (append a a a a) :from-end t) 37) ) ) ) (do-test "test position-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (position-if-not #'lower-case-p a) 0) (= (position-if-not #'lower-case-p a :start 42) 42) (= (position-if-not #'lower-case-p a :start 49 :end 57) 54) (= (position-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) 41) (= (position-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\space))) a :end 60 :from-end t) 54) (= (position-if-not #'(lambda (x) (char/= x #\W)) (concatenate 'string a a) :start 1 ) 65) ) ) ) (do-test "test position-if-not 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (position-if-not #'oddp a :key #'cdr :from-end t) 3 ) (= (position-if-not #'evenp a :key #'cdr ) 1) (= (position-if-not #'minusp a :key #'car) 0) (= (position-if-not #'plusp a :key #'car) 5) ) ) ) (do-test "test fine-if-not 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (position-if-not #'listp a :start 1 :end 14 :from-end t) 13) (= (position-if-not #'vectorp a :start 6 ) 9) (= (position-if-not #'bit-vector-p a :start 5) 5) (= (position-if-not #'null a :start 10 :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3)) )) 13) (= (position-if-not #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3) #\2) )) 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF.TEST new file mode 100644 index 00000000..c83cabb7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: position-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 27 ,1986 ;; ;; Last Update: Sept. 27 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-position-if.test ;; ;; ;; Syntax: position-if SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the ;; index within the sequence of the leftmost (or rightmost) such element is returned, otherwise nil ;; is returned. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive number or nil ;; (do-test "test position-if 0" (and (= (position-if #'oddp '(2 52 44 5 3 7 8 9 0)) 3) (= (position-if #'oddp '(2 52 44 5 3 7 8 9 0) :from-end t) 7) (eq (position-if #'complexp '(3 4 5 6 7 2 1)) nil) (eq (position-if #'floatp '(3 4 5 6 7 2 1)) nil) (= (position-if #'consp '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 6) (= (position-if #'(lambda (x) (= x 199)) ;; ;; create a list of integers from 0 to 249 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 250) b))) 199) ) ) (do-test "test position-if 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (position-if #'(lambda (x) (> (realpart x) 8)) a ) 2) (= (position-if #'(lambda (x) (> (realpart x) 8)) a :from-end t) 7 ) (= (position-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a ) 1) (= (position-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a :from-end t) 3 ) (eq (position-if #'integerp a) nil) (= (position-if #'(lambda (x) (> (realpart x) 8)) (append a a a a) :from-end t) 37) ) ) ) (do-test "test position-if 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (position-if #'upper-case-p a) 0) (= (position-if #'upper-case-p a :start 42) 43) (= (position-if #'upper-case-p a :start 49 :end 57) 56) (= (position-if #'(lambda (x) (not (alpha-char-p x))) a :start 35) 41) (= (position-if #'(lambda (x) (not (or (alpha-char-p x) (char= x #\space)))) a :end 60 :from-end t) 54) (= (position-if #'(lambda (x) (char= x #\W)) (concatenate 'string a a) :start 1 ) 65) ) ) ) (do-test "test position-if 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (position-if #'evenp a :key #'cdr :from-end t) 3 ) (= (position-if #'oddp a :key #'cdr ) 1) (= (position-if #'plusp a :key #'car) 0) (= (position-if #'minusp a :key #'car) 5) ) ) ) (do-test "test fine-if 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (position-if #'integerp a :start 1 :end 14 :from-end t) 12) (= (position-if #'vectorp a :start 6 ) 6) (= (position-if #'bit-vector-p a :start 6) 7) (eq (position-if #'(lambda (x) (equal x #\2)) a :start 10 :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) nil) (= (position-if #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) 8) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION.TEST new file mode 100644 index 00000000..13a09b16 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: position ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 27 ,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - Changed = to eql in test 0 since one of ;; values in the list was a sublist which fails on the SUN. ;; ;; Filed As: {eris}cml>test>14-3-position.test ;; ;; ;; Syntax: position ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: If the subsequence delemited by :START and :END contains an element satisfying the test, then the index ;; within SEQUENCE of the leftmost (or rightmost) such element is returned as a non-negative integer; otherwise ;; nil is returned. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive number or nil ;; (do-test "test position 0" (and (= (position 2 '(3 4 5 2.0 6 2 1 9 8 4 2 4)) 5) (= (position 2 '(3 4 5 2.0 6 2 1 9 8 4 2 4) :from-end t) 10) (eql (position 3 '(1 2 4 5 6 7 8 (3) 9)) nil) (= (position '(1 2) '( 1 2 ((1 2)) 3 4 (1 2)) :test #'equal ) 5) (= (position #\q "antique-que-que" :test #'equal) 4) (= (position #\q "antique-que-que" :test #'equal :from-end t ) 12) (= (position #*1011 (vector #*0000 #*1111 #*1011) :test #'equalp) 2) ) ) (do-test "test position 1" (let ((a '(3 4 7 8 -2 9 7 8 -3 4 6 1 7 4 5 -3 2 0 4 -2 7 2) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 20 21 ;; (and (= (position 7 a :start 3) 6) (= (position 7 a :start 2 ) 2) (= (position -3 a :end 17 ) 8) (= (position -3 a :start 9 :end 16) 15) (eq (position -2 a :start 5 :end 14) nil) (= (position -2 a :start 4 :end 14) 4) (= (position 2 a :start 4 :end 19) 16) (eq (position 2 a :start 17 :end 21) nil) (eq (position 34 a ) nil) ) ) ) (do-test "test position 2" (let (( a "Fatal error in function SYSTEM: TASK-SCHEDULER")) ;; ;; 0123456789012345678901234567890123456789012345 ;; (and (= (position #\n a :test #'char=) 13) (= (position #\: a :test #'char=) 30) (= (position #\a a :test-not #'char>= ) 2) (= (position #\F a :test #'(lambda (x y) (and (alpha-char-p y) (char> x y)))) 28) (= (position #\R a :test-not #'(lambda (x y) (/= (- (char-code y) (char-code x)) (- (char-code #\a) (char-code #\A)) ))) 7) ) ) ) (do-test "test position 3" (let ((a '( (1 3 5) (2 4 6)(38 5 7) (4 2 1) (-3 -5 -7) (-2 -4 -1) (10 22 31) (38 72 10)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (position 7 a :key #'third) 2) (= (position -4 a :key #'second) 5) (= (position 38 a :key #'first) 2) (= (position 38 a :key #'first :from-end t) 7) (= (position 0 a :key #'cadr :test #'(lambda (x y) (> x y))) 4) (= (position 0 a :key #'cadr :test #'(lambda (x y) (> x y)) :from-end t) 5) (eq (position 0 a :key #'caddr) nil) ) ) ) (do-test "test position 4" (let ((a '(#*11111 #*0000 #*10101010 #*01010101 #*111 #*00000 #*1110 #*0101111 #*000 #*11100 #*01000) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 ;; (and (= (position #*10 a :start 4 :end 10 :test #'equalp :key #'(lambda (x) (subseq x 1 3))) 7) (= (position #*11 a :start 1 :end 9 :test #'equalp :from-end t :key #'(lambda (x) (subseq x 0 2)) ) 6) (= (position #*01 a :start 4 :end 10 :test-not #'(lambda (x y) (or (/= (elt x 0) (elt y 0)) (/= (elt x 1) (elt y 1)) )) :from-end t) 7) (= (position 'dummy a :test-not #'(lambda (x y) (find 0 y)) :start 2 ) 4) (= (position 'dummy a :test-not #'(lambda (x y) (find 0 y)) :end 4 :from-end t) 0) (= (position 'dummy a :test-not #'(lambda (x y) (find 1 y)) :start 2 :from-end t) 8) (= (position 'dummy a :test-not #'(lambda (x y) (find 1 y)) ) 1 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-DUPLICATES.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-DUPLICATES.TEST new file mode 100644 index 00000000..c07cd640 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-DUPLICATES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove-duplicates ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 254 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 22 ,1986 ;; ;; Last Update: Sept. 22 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove-duplicates.test ;; ;; ;; Syntax: remove-duplicates SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: The elements of SEQUENCE are compared pairwise, and if any two match, then the one occurring ;; earlier in the sequence is discarded (if :FROM-ENT is true, then the one later in the sequence ;; is discarded). The result is a sequence of the same kind as the argument SEQUENCE with enough ;; elements removed so that no two of the remaining elements match. ;; ;; Argument(s): SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test case copied from page 255 of CLtL" (and (equal (remove-duplicates '(a b c b d d e)) '(a c b d e)) (equal (remove-duplicates '(a b c b d d e) :from-end t) '(a b c d e)) (equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr) '((bar #\%) (baz #\A))) (equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr :from-end t) '((foo #\a) (bar #\%)) ) ) ) (do-test "test remove-duplicates 0" (let ( (a '(1 3 5 3 6 8 9 4 2 0 3 4 2 3 1))) (and (equal (remove-duplicates a) '( 5 6 8 9 0 4 2 3 1) ) (equal (remove-duplicates a :start 3) '( 1 3 5 6 8 9 0 4 2 3 1) ) (equal (remove-duplicates a :end 10) '(1 5 3 6 8 9 4 2 0 3 4 2 3 1)) (equal (remove-duplicates a :start 2 :end 12) '(1 3 5 6 8 9 2 0 3 4 2 3 1)) (equal (remove-duplicates a :start 2 :end 12 :from-end t) '(1 3 5 3 6 8 9 4 2 0 2 3 1)) (equal a '(1 3 5 3 6 8 9 4 2 0 3 4 2 3 1)) ) ) ) (do-test "test remove-duplicates 1" (let ( (a "sneezy SleePY grouchy dopey jumpy bashful")) (and (equal (remove-duplicates a :test #'char-equal) "nzgrcdoejmpy bashful") (equal (remove-duplicates a :test #'equal) "nzSPYgrcdoejmpy bashful") (equal (remove-duplicates a :test #'equal :from-end t) "snezy SlPYgrouchdpjmbaf") (equal a "sneezy SleePY grouchy dopey jumpy bashful") ) ) ) (do-test "test remove-duplicates 2" (let ( (a '( (1 2 3) (4 5) (2) (3 4) (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) )) (and (equal (remove-duplicates a :test-not #'(lambda (x y) (/= (length x) (length y)))) '( (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) (equal (remove-duplicates a :test-not #'(lambda (x y) (/= (length x) (length y))) :from-end t) '((1 2 3) (4 5) (2) (9 8 1 2) (2 2 3 1 4)) ) (equal a '( (1 2 3) (4 5) (2) (3 4) (9 8 1 2) (3) (2 2 3 1 4) (4 5) (1 -1 3)) ) ) ) ) (do-test "test remove-duplicates 3" (let ( (a (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) )) (and (equalp (remove-duplicates a :test #'= :key #'realpart) (vector #c(2 -1) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (remove-duplicates a :test #'= :key #'imagpart) (vector #c(3.0 4) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (remove-duplicates a :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart) (vector #c(3 8) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) (equalp (remove-duplicates a :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t) (vector #c(2 -1) #c(3.0 4) #c(3 8) #c(-3.0 7) ) ) (equalp (remove-duplicates a :test #'(lambda (x y) (= (abs x) (abs y))) :key #'imagpart :from-end t :start 1 :end 7) (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(-3.0 7) #c(15 -1)) ) (equalp a (vector #c(2 -1) #c(3.0 4) #c(5 1.0) #c(3 8) #c(6 1) #c(-3.0 7) #c(4 -4.0) #c(15 -1)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF-NOT.TEST new file mode 100644 index 00000000..2f3d448f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove-if-not ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 253 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 13 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove-if-not.test ;; ;; ;; Syntax: remove-if-not TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: remove-if-not returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and not satisfying ;; TEST have been removed. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements removed from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test remove-if-not 0" (let ((a '#(1 3 4 2 5 6 3 20 6 8 5 6 7 4 3 2 4 6 7 5) )) (and (equalp (remove-if-not #'evenp a) '#(4 2 6 20 6 8 6 4 2 4 6 ) ) (equalp (remove-if-not #'evenp a :count 5) '#(4 2 6 20 6 8 6 7 4 3 2 4 6 7 5) ) (equalp (remove-if-not #'evenp a :count 5 :from-end t) '#(1 3 4 2 5 6 3 20 6 8 6 4 2 4 6 ) ) (equalp a '#(1 3 4 2 5 6 3 20 6 8 5 6 7 4 3 2 4 6 7 5) ) ) ) ) (do-test "test remove-if-not 1" (let ((a "aN inteGeR WhICH liMitS thE NumbEr oF eLemenTs reMoved FrOm SeQuenCE") ) (and (equal (remove-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :start 20) "aN inteGeR WhICH liMit th umbr o eemens reoved rm euen") (equal (remove-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :end 40) "a intee h liit th umbr o eemenTs reMoved FrOm SeQuenCE") (equal (remove-if-not #'(lambda (x) (or (char= #\space x) (lower-case-p x))) a :start 5 :end 50) "aN intee h liit th umbr o eemens reoved FrOm SeQuenCE") (equal a "aN inteGeR WhICH liMitS thE NumbEr oF eLemenTs reMoved FrOm SeQuenCE") ) ) ) (do-test "test remove-if-not 2" (let ((a '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "tyhfgwsjkkh" "olkdewskddc" "ppmmnnllkkplm") )) (and (equal (remove-if-not #'(lambda (x) (find #\p x)) a :key #'(lambda (y) (subseq (reverse y) 0 3))) '("ikjlkmop" "jnmdkpmn" "ppmmnnllkkplm")) (equal (remove-if-not #'(lambda (x) (find #\p x)) a :key #'(lambda (y) (subseq (reverse y) 0 3)) :from-end t :count 2) '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "ppmmnnllkkplm")) (equal (remove-if-not #'(lambda (x) (find #\k x)) a :key #'(lambda (y) (subseq y 2 5)) :count 3) '("ikjlkmop" "jnmdkpmn" "olkdewskddc" "ppmmnnllkkplm")) (equal a '("ikjlkmop" "jnmdkpmn" "abcmnppkkn" "zxyuvmnog" "tyhfgwsjkkh" "olkdewskddc" "ppmmnnllkkplm")) ) ) ) (do-test "test remove-if-not 3" (let ((a (make-array 11 :initial-contents '( #c(2 10) #c(3 -5) #c(1 9) #c(10 20) #c(-5 42) #c(40 2) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) )) (and (equalp (remove-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) a :start 2 :end 7 :from-end nil :count 3 :key #'identity) '#(#c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (remove-if-not #'(lambda (x) (> (+ (realpart x) (imagpart x)) 30)) a :start 2 :end 7 :from-end 'non-nil :count 3 :key #'identity) '#(#c(2 10) #c(3 -5) #c(-5 42) #c(40 2) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (remove-if-not #'oddp a :start 1 :end 9 :count 3 :key #'realpart) '#(#c(2 10) #c(3 -5) #c(1 9) #c(-5 42) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp (remove-if-not #'minusp a :start 1 :end 9 :count 4 :key #'realpart) '#(#c(2 10) #c(-5 42) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) (equalp a '#(#c(2 10) #c(3 -5) #c(1 9) #c(10 20) #c(-5 42) #c(40 2) #c(-20 31) #c(-1 -2) #c(2 34) #c(9 21) #c( 2 4))) ) ) ) (do-test "test remove-if-not 4" (let ((a '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) )) (and (equal (remove-if-not #'floatp a :start 1 :end 8 :key #'cdr :count 2) '((3 . 2.4) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (remove-if-not #'floatp a :start 1 :end 8 :key #'cdr :count 2 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (2 . 222)) ) (equal (remove-if-not #'oddp a :start 2 :end 8 :key #'first :count 1 :from-end t) '((3 . 2.4) (5 . -5) (10 . 2.3) (-1 . -2.0) (9 . 9.0) (23 . 33.3) (5 . 15) (2 . 222)) ) (equal (remove-if-not #'oddp a :start 2 :end 8 :key #'first :count 1 ) '((3 . 2.4) (5 . -5) (-1 . -2.0) (9 . 9.0) (20 . 12) (23 . 33.3) (5 . 15) (2 . 222)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF.TEST new file mode 100644 index 00000000..d01873f3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 253 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 13 ,1986 ;; ;; Last Update: Sept. 13 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove-if.test ;; ;; ;; Syntax: remove-if TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: remove-if returns a sequence of the same kind as the argument SEQUENCE that has the same ;; elements except that those in the subsequence delimited by :START and :END and satisfying the ;; TEST have been removed. ;; ;; Argument(s): TEST - a function of one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements removed from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test remove-if 0" (and (equal (remove-if #'oddp '(1 2 4 1 3 4 5)) '(2 4 4)) (equal (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) (let ((a '(1 3 4 2 5 6 3 9 8 7 10 20 31 25 87 3 4 5 3 4 2 10 22 38 100 50 25 22))) (and (equal (remove-if #'evenp a) '(1 3 5 3 9 7 31 25 87 3 5 3 25 )) (equal (remove-if #'evenp a :count 10) '(1 3 5 3 9 7 31 25 87 3 5 3 22 38 100 50 25 22)) (equal (remove-if #'evenp a :count 10 :from-end t) '(1 3 4 2 5 6 3 9 8 7 10 31 25 87 3 5 3 25 )) (equal a '(1 3 4 2 5 6 3 9 8 7 10 20 31 25 87 3 4 5 3 4 2 10 22 38 100 50 25 22)) ) ) ) ) (do-test "test remove-if 1" (let ((a "watermelon banana tomato pineapple pear peach plum apple orange cantalope honeydew")) (and (equal (remove-if #'(lambda (x) (> (char-code x) (char-code #\r))) a :end 30) "aermelon banana omao pineapple pear peach plum apple orange cantalope honeydew") (equal (remove-if #'(lambda (x) (> (char-code x) (char-code #\r))) a :start 60 ) "watermelon banana tomato pineapple pear peach plum apple orange canalope honede") (equal (remove-if #'alpha-char-p a :start 11 :end 64) "watermelon cantalope honeydew") (equal a "watermelon banana tomato pineapple pear peach plum apple orange cantalope honeydew") ) ) ) (do-test "test remove-if 2" (let ((a '( ( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) (1.1 (2.2) 3.3 4.4 5.5)) )) (and (equal (remove-if #'(lambda (x ) (<= (length x) 2)) a :key #'cadr) '( (10 (20 30 40) 50 60) )) (equal (remove-if #'(lambda (x ) (< (length x) 2)) a :key #'cadr :count 1 :from-end t) '(( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) )) (equal a '( ( 1 (2 3) 4) (a (b) c ((d))) (10 (20 30 40) 50 60) (aa (bb cc) dd ee) (1.1 (2.2) 3.3 4.4 5.5))) ) ) ) (do-test "test remove-if 3" (let ((a '( (10 20 30) (-2 23) (-9 99) (34 49) (3 2 1) (20 34 13) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) )) (and (equal (remove-if #'(lambda (x) (and (> x 5) (oddp x))) a :start 2 :end 7 :from-end t :count 2 :key #'(lambda (x) (first (last x))) ) '((10 20 30) (-2 23) (-9 99) (3 2 1) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) ) (equal a '( (10 20 30) (-2 23) (-9 99) (34 49) (3 2 1) (20 34 13) (1 2 3 4 5) (33 44 22 11) (-7 5 9 12)) ) ) ) ) (do-test "test remove-if 4" (let ((a '(8 #\a (1 2) #\b 3.4 -9.85 #\e "abdesd" (2 3 4 5) #\o #\a (+ 2 3) #\a "banana") )) (equal (remove-if #'characterp a :start 2 :end 12 :from-end t :count 3) '(8 #\a (1 2) #\b 3.4 -9.85 "abdesd" (2 3 4 5) (+ 2 3) #\a "banana") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE.TEST new file mode 100644 index 00000000..f3819eb8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remove ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 253 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 12 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-remove.test ;; ;; ;; Syntax: remove ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: remove returns a sequence of the same kind as the argument SEQUENCE that has the same elements ;; except that those in the subsequence delimited by :START and :END and satisfying the test have ;; been removed. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :TEST - a function of two arguments ;; :TEST-NOT - a function of two arguments ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - an integer which limits the number of elements removed from SEQUENCE ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test remove - test cases from page 253 of CLtL" (and (equal (remove 4 '(1 2 4 1 3 4 5)) '(1 2 1 3 5)) (equal (remove 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5)) (equal (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) (equal (remove 3 '(1 2 4 1 3 4 5) :test #'>) '(4 3 4 5)) ) ) (do-test "test remove 1" (let ((a '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1))) (and (equal (remove 3 a) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (remove 3 a :from-end 'non-nil) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (remove 3 a :count 2) '(1 2 4 5 6 7 8 9 10 5 4 2 1 5 4 3 2 1)) (equal (remove 3 a :from-end t :count 2) '(1 2 3 4 5 6 7 8 9 10 5 4 2 1 5 4 2 1)) (equal (remove 3 a :count 0) '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) (equal (remove 3 a :from-end t :count 0) '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) (equal a '(1 2 3 4 5 6 7 8 9 10 5 4 3 2 1 5 4 3 2 1)) ) ) ) (do-test "test remove 2" (let ((b "abcdefgabcdefgabcdefgabcdefgabcdefg")) (and (equal (remove #\b b :test #'char>) "bcdefgbcdefgbcdefgbcdefgbcdefg") (equal (remove #\c b :test #'(lambda (x y) (= (char-code x) (- (char-code y) 2))) :count 4) "abcdfgabcdfgabcdfgabcdfgabcdefg") (equal (remove #\f b :test-not #'char/=) "abcdegabcdegabcdegabcdegabcdeg") (equal (remove #\a b :test-not #'(lambda (x y) (equal x y) )) "aaaaa") (equal b "abcdefgabcdefgabcdefgabcdefgabcdefg") ) ) ) (do-test "test remove 3" (let ((c '( (1 2 3) (2 3 4) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) )) (and (equal (remove '(1 2 3) c :start 1 :test #'equal) '((1 2 3) (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (8 9 0) (4 5 6) )) (equal (remove '(2 3 4) c :end 6 :test #'equal) '((1 2 3) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) (equal (remove '(1 2 3 ) c :start 2 :end 7 :test #'equal) '((1 2 3) (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) )) (equal (remove 2 c :key #'second ) '( (2 3 4) (4 5 6) (4 6 7) (6 7 8) (7 8 9) (2 3 4) (8 9 0) (4 5 6) ) ) (equal (remove 6 c :test #'< :key #'third) '((1 2 3) (2 3 4) (4 5 6) (1 2 3) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) (equal c '( (1 2 3) (2 3 4) (4 5 6) (4 6 7) (1 2 3) (6 7 8) (7 8 9) (2 3 4) (1 2 3) (8 9 0) (4 5 6) ) ) ) ) ) (do-test "test remove 4" (let ((a '((9 2 3) (8 2 4) (1 2 4) (-4 3 2) (5 3 5) (-5 2 1) (3 4) (2 9) (10 2) (-2 4)) )) (equal (remove 5 a :from-end t :start 2 :end 8 :test #'> :count 4 :key #'car) '((9 2 3) (8 2 4) (1 2 4) (5 3 5) (10 2) (-2 4)) ) ) ) (do-test "test remove 5" (let* ((a (vector '(1 #\2 3) '(#\a #\b) '(#\9 8 5) '(#\1 #\2 #\3) '(1 2 3) '(3 #\2 1) '(4 #\3 #\8) '(#\q #\w #\e)) ) (b (remove 56 a :start 1 :end 7 :test-not #'(lambda (x y) (equal (type-of x) (type-of y))) :key #'second) )) (equalp b '#( (1 #\2 3) (#\9 8 5) (1 2 3) (#\q #\w #\e))) ) ) (do-test "test remove 6" (let ( (a (make-array 200 :element-type 'float)) b) (fill (fill (fill (fill a 20.0 :end 50) 30.0 :start 50 :end 100) 40.0 :start 100 :end 150) 50.0 :start 150 ) (setq b (remove 35 a :start 75 :end 150 :test #'(lambda (x y) (or (= (+ x 5) y) (= (- x 5) y))) )) (equalp b (make-array (+ 50 25 50) :initial-contents (append (make-list 50 :initial-element 20.0) (make-list 25 :initial-element 30.0) (make-list 50 :initial-element 50.0)))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-REPLACE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-REPLACE.TEST new file mode 100644 index 00000000..7f6844c2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REPLACE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: replace ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 252 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 9 ,1986 ;; ;; Last Update: Nov. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-replace.test ;; ;; ;; Syntax: replace SEQUENCE1 SEQUENCE2 &KEY :START1 :END1 :START2 :END2 ;; ;; Function Description: replace destructively modified SEQUENCE1 by copying the subsequence of SEQUENCE2 ;; into the subsequence of SUBSEQUENCE1. ;; ;; Argument(s): SEQUENCE1 SEQUENCE2 - ;; :START1 :START2 - ;; :END1 :END2 - ;; ;; Returns: a sequence ;; (do-test "test replace 0" (and (equal (replace "12345678" "abcde") "abcde678") (equal (replace "12345" "abcdefghijklmno") "abcde") (equal (replace '(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :start1 5 :start2 2) '(1 2 3 4 5 c d e f 10)) (equal (replace '(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :end1 3 :end2 5) '(a b c 4 5 6 7 8 9 10)) (equal (replace '(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :start1 3 :end2 4) '(1 2 3 a b c d 8 9 10)) (equalp (replace '#(1 2 3 4 5 6 7 8 9 10) '#(a b c d e f) :end1 4 :start2 4) '#(e f 3 4 5 6 7 8 9 10)) (equal (replace "654368793789327932" '(#\a #\c #\e #\h #\i #\d #\p #\m #\k #\s #\b #\o) :start1 3 :end1 13 :start2 2 :end2 8) "654ehidpm789327932" ) (equal (replace "654368793789327932" '(#\a #\c #\e #\h #\i #\d #\p #\m #\k #\s #\b #\o) :start1 3 :end1 nil :start2 2 :end2 nil) "654ehidpmksbo27932") ) ) (do-test "test replace 2" (flet ((test-one (seq1 seq2 &key (s1 0) (s2 0) (e1 (length seq1)) (e2 (length seq2))) (let* ((seq11 (copy-seq seq1)) (copied-elts (min (- e1 s1) (- e2 s2))) (expected (concatenate 'list (and (> s1 0) (subseq seq11 0 s1)) (subseq seq2 s2 (+ s2 copied-elts)) (and (> (length seq11) (+ s1 copied-elts)) (subseq seq11 (+ s1 copied-elts))) )) (result (replace seq1 seq2 :start1 s1 :start2 s2 :end1 e1 :end2 e2))) (and (eql (length expected) (length result)) (dotimes (i (length expected) t) (unless (equal (elt expected i) (elt result i)) (return nil)) ) ) ) )) (test-one "kdjsfjkldsjoieurhhfkldsfjlkdsjhfg" "123456789" :s1 5 :e1 10 ) (test-one (make-string 200 :initial-element #\*) (make-string 50 :initial-element #\%) :s1 99) (test-one (make-list 100 :initial-element '(1 2 3)) (make-list 100 :initial-element '((1 2) . 3)) ) (test-one (make-array 150) (make-array 200 :initial-element "replace") :s1 70 :e1 120) (test-one '#(1 2 3 4 11 22 33 44 55 111 222 333 444 555 666) '("11" "22" "33" "44") :s1 4) ) ) (do-test "test replace 3" ;; ;; If seq1 and seq2 are the same (eq) object and the region being modified overlaps the region being copied from ;; (and (let ((a (list 1 2 3 4 5 6 7 8 9 0))) (replace a a :start1 2 :end1 5 :start2 3 :end2 6) (equal a '(1 2 4 5 6 6 7 8 9 0))) (let ((b (vector 1 2 3 4 5 6 7 8 9 0)) (replace b b :start1 2 :end1 5 :start2 3 :end2 6) (equal b '#(1 2 4 5 6 6 7 8 9 0))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF-NOT.TEST new file mode 100644 index 00000000..78f01f1c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: substitute-if-not ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 255 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 24 ,1986 ;; ;; Last Update: Sept. 24 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-substitute-if-not.test ;; ;; ;; Syntax: substitute-if-not NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and not satisfying the test have been replaced by ;; newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (substitute-if-not 9 #'oddp '(1 2 4 1 3 4 5)) '(1 9 9 1 3 9 5)) (equal (substitute-if-not 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 4 9)) ) ) (do-test "test substitute-if-not 0" (and (equal (substitute-if-not 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 3 9 3 4 100 3 4 7 2 9 3 3 3)) (equalp (substitute-if-not 7 #'zerop (vector 0 0 0 1 1 1 0 0 0 0 0 0 0 0 8 8 0 0 0 0)) (vector 0 0 0 7 7 7 0 0 0 0 0 0 0 0 7 7 0 0 0 0 )) (equal (substitute-if-not "*" #'numberp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test substitute-if-not 1" (let ((a "seedhead of common sunflower marin county calif-notornia nikon")) (and (equal (substitute-if-not #\% #'alpha-char-p a) "seedhead%of%common%sunflower%marin%county%calif%notornia%nikon") (equal (substitute-if-not #\% #'alpha-char-p a :start 10) "seedhead of%common%sunflower%marin%county%calif%notornia%nikon") (equal (substitute-if-not #\% #'alpha-char-p a :end 50) "seedhead%of%common%sunflower%marin%county%calif%notornia nikon") (equal (substitute-if-not #\% #'alpha-char-p a :start 15 :end 40) "seedhead of common%sunflower%marin%county calif-notornia nikon") (equal a "seedhead of common sunflower marin county calif-notornia nikon") ) ) ) (do-test "test substitute-if-not 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) )) (and (equal (substitute-if-not 'z #'oddp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (substitute-if-not 'z #'oddp a :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if-not 'z #'oddp a :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (substitute-if-not 'z #'oddp a :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if-not 'z #'oddp a :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) (equal a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) ) ) ) (do-test "test substitute-if-not 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) )) (and (equal (substitute-if-not "**" #'integerp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (substitute-if-not "**" #'(lambda (x) (<= x 6)) a :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (substitute-if-not "**" #'(lambda (x) (= (length x) 2)) a :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) (equal a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) ) ) ) (do-test "test substitute-if-not 4" (let ((a '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "bashful" "dopey" "snowwhite" "witch") )) (and (equal (substitute-if-not "no-y" #'(lambda (x) (find #\y x)) a :end 8 :from-end t :count 2) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-y" "dopey" "no-y" "witch")) (equal (substitute-if-not "no-o" #'(lambda (x) (find #\o x)) a :start 4 :end 7 :count 1 :from-end t :key #'(lambda (y) (subseq y 0 3))) '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "no-o" "dopey" "snowwhite" "witch")) (equal (substitute-if-not "no-s" #'(lambda (x) (equal x #\s)) a :start 4 :end 6 :key #'(lambda (y) (elt y 0))) '("sneezy" "sleepy" "jumpy" "grouchy" "no-s" "no-s" "dopey" "snowwhite" "witch")) (equal a '("sneezy" "sleepy" "jumpy" "grouchy" "doc" "bashful" "dopey" "snowwhite" "witch") ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF.TEST new file mode 100644 index 00000000..322124da --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: substitute-if ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 256 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 24 ,1986 ;; ;; Last Update: Oct. 1 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-substitute-if.test ;; ;; ;; Syntax: substitute-if NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; TEST - a function which takes one argument ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test cases copied from page 256 of CLtL" (and (equal (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) '(9 2 4 9 9 4 9)) (equal (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) ) ) (do-test "test substitute-if 0" (and (equal (substitute-if 3 #'plusp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(3 -3 3 -5 3 3 -3 3 3 3 3 -4 3 -8)) (equalp (substitute-if 1 #'zerop (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 )) (equal (substitute-if "*" #'characterp '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) '(2 -3 9 -5 4 100 -3 4 7 2 9 -4 3 -8)) ) ) (do-test "test substitute-if 1" (let ((a "seedhead of common sunflower marin county california nikon")) (and (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a) "seedhead%of%common%sunflower%marin%county%california%nikon") (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a :start 10) "seedhead of%common%sunflower%marin%county%california%nikon") (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a :end 50) "seedhead%of%common%sunflower%marin%county%california nikon") (equal (substitute-if #\% #'(lambda (x) (equal x #\space)) a :start 15 :end 40) "seedhead of common%sunflower%marin%county california nikon") (equal a "seedhead of common sunflower marin county california nikon") ) ) ) (do-test "test substitute-if 2" (let ((a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) )) (and (equal (substitute-if 'z #'evenp a) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 z z z z 93 z 65 z z z) ) (equal (substitute-if 'z #'evenp a :count 7) '(11 z 33 z 55 z 77 z 99 z z 31 41 z 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if 'z #'evenp a :count 7 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 z z z 93 z 65 z z z) ) (equal (substitute-if 'z #'evenp a :count 5) '(11 z 33 z 55 z 77 z 99 z 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) (equal (substitute-if 'z #'evenp a :count 5 :from-end t) '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 z 93 z 65 z z z) ) (equal a '(11 22 33 44 55 66 77 88 99 10 20 31 41 52 73 84 72 90 82 93 74 65 10 22 38) ) ) ) ) (do-test "test substitute-if 3" (let ((a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) )) (and (equal (substitute-if "**" #'floatp a :key #'third) '( "**" (1 4.2 8 5) "**" "**" (-5.0 3.0 2 1.1) "**" "**")) (equal (substitute-if "**" #'(lambda (x) (> x 6)) a :key #'(lambda (y) (car (last y)))) '("**" (1 4.2 8 5) "**" (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) (equal (substitute-if "**" #'(lambda (x) (/= (length x) 2)) a :key #'cddr) '((2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) "**" (3 4.2 6.3 5)) ) (equal a '( (2 3 7.0 9) (1 4.2 8 5) (9 2.3 4.1 9) (1.0 2.0 4.0 6.0) (-5.0 3.0 2 1.1) (8 9 4.0 3.2 8.8 2) (3 4.2 6.3 5)) ) ) ) ) (do-test "test substitute-if 4" (let ((a (list #*10110 #*00000 #*11111 #*00011 #*10001 #*001100 #*101010 #*01010 #*110110) )) (and (equal (substitute-if "!" #'(lambda (x) (= x 1)) a :start 2 :end 8 :from-end t :count 2 :key #'(lambda (x) (elt x 2))) (list #*10110 #*00000 #*11111 #*00011 #*10001 "!" "!" #*01010 #*110110) ) (equal (substitute-if "!" #'(lambda (x) (/= (length x) 6)) a :start 3 :end 8 :count 3 :key #'identity) (list #*10110 #*00000 #*11111 "!" "!" #*001100 #*101010 "!" #*110110) ) (equal (substitute-if "!" #'(lambda (x) (= x 0)) a :end 5 :count 2 :from-end t :key #'(lambda (y) (elt (reverse y) 1))) (list #*10110 "!" #*11111 #*00011 "!" #*001100 #*101010 #*01010 #*110110) ) (equal a (list #*10110 #*00000 #*11111 #*00011 #*10001 #*001100 #*101010 #*01010 #*110110) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE.TEST new file mode 100644 index 00000000..e287df81 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: substitute ;; ;; Source: CLtL Section 14.3: Modifying Sequences Page: 255 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 24 ,1986 ;; ;; Last Update: Sept. 24 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-substitute.test ;; ;; ;; Syntax: substitute NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY ;; ;; Function Description: The result is a sequence of the same kind as the argument SEQUENCE that has the same elements except that ;; those in the subsequence delemited by :START and :END and satisfying the test have been replaced by newitem. ;; ;; Argument(s): NEWITEM - ;; OLDITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :COUNT - ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a sequence ;; (do-test "test substitute - test cases copied from page 256 of CLtL" (and (equal (substitute 9 4 '(1 2 4 1 3 4 5)) '(1 2 9 1 3 9 5)) (equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 ) '(1 2 9 1 3 4 5)) (equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) (equal (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) '(9 9 4 9 3 4 5)) ) ) (do-test "test substitute 0" (let ((a '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) )) (and (equal (substitute 8 3 a) '(8 2 1 10 8 8 9 2 1 8 10 13 30 8)) (equal (substitute 8 3 a :start 5) '(3 2 1 10 3 8 9 2 1 8 10 13 30 8)) (equal (substitute 8 3 a :end 9) '(8 2 1 10 8 8 9 2 1 3 10 13 30 3) ) (equal (substitute 100 10 a :start 1 :end 10) '(3 2 1 100 3 3 9 2 1 3 10 13 30 3) ) (equal (substitute 200 20 a ) '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) (equal a '(3 2 1 10 3 3 9 2 1 3 10 13 30 3) ) ) ) ) (do-test "test substitute 1" (let ((a "abdefgbcdefegAbcDabGecba")) (and (equal (substitute #\* #\a a :count 2) "*bdefgbcdefegAbcD*bGecba") (equal (substitute #\* #\a a :count 2 :from-end t) "abdefgbcdefegAbcD*bGecb*") (equal (substitute #\% #\b a :count 3) "a%defg%cdefegA%cDabGecba") (equal (substitute #\% #\b a :count 3 :from-end t) "abdefgbcdefegA%cDa%Gec%a") ) ) ) (do-test "test substitute 2" (let ((a (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 9 '(d w 2 4) 'b 'a 7 7 't 'u 9 0) ) ) (and (equalp (substitute "!" 6 a :test #'(lambda (x y) (and (numberp y) (< x y))) ) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 "!" '(d w 2 4) 'b 'a "!" "!" 't 'u "!" 0) ) (equalp (substitute '(11 22) 'dummy a :test #'(lambda (x y) (and (numberp y) (oddp y))) ) (vector 'x 'y '(11 22) 0 'a 'z '(11 22) 6 'm 'n '(11 22) '(11 22) '(d w 2 4) 'b 'a '(11 22) '(11 22) 't 'u '(11 22) 0) ) (equalp (substitute 99 9.0 a :test #'equalp) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 99 '(d w 2 4) 'b 'a 7 7 't 'u 99 0) ) (equalp (substitute "nlist" 'list a :test-not #'(lambda (x y) (typep y x)) :start 10 :end 15) (vector 'x 'y 1 0 'a 'z 3 6 'm 'n "nlist" "nlist" '(d w 2 4) "nlist" "nlist" 7 7 't 'u 9 0) ) (equalp a (vector 'x 'y 1 0 'a 'z 3 6 'm 'n 5 9 '(d w 2 4) 'b 'a 7 7 't 'u 9 0) ) ) ) ) (do-test "test substitute 3" (let ((a '( (1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) (-7 0 1) (2 2 4 4 6) (3 1 4 2)) )) (and (equal (substitute 'same '(2 4) a :key #'(lambda (x) (subseq x 1 3)) :test #'equal) '(same ( 5 3 1 2) same (0 8 9 1) (-7 0 1) same (3 1 4 2)) ) (equal (substitute 'fun 2 a :test #'> :key #'second) '((1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) fun (2 2 4 4 6) fun) ) (equal (substitute 'foo 4 a :test #'= :key #'caddr) '(foo ( 5 3 1 2) foo (0 8 9 1) (-7 0 1) foo foo) ) (equal a '( (1 2 4 8) ( 5 3 1 2) (-9 2 4) (0 8 9 1) (-7 0 1) (2 2 4 4 6) (3 1 4 2)) ) ) ) ) (do-test "test substitute 4" (let ((a '( (1 2 3) (-4 3 1) (3 5 -4) (6 2 -1) (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) )) (and (equal (substitute "@" 'dummy a :from-end t :start 1 :end 8 :test #'(lambda (x y) (plusp y)) :count 4 :key #'third) '((1 2 3) "@" (3 5 -4) (6 2 -1) (4 -5 -3) "@" (0 0 -2) (2 2 -4) (3 1 -4)) ) (equal (substitute "?" 2 a :from-end t :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '((1 2 3) (-4 3 1) (3 5 -4) "?" (4 -5 -3) "?" "?" (2 2 -4) (3 1 -4)) ) (equal (substitute "@" 2 a :end 8 :count 3 :key #'caddr :test #'(lambda (x y) (>= (+ x y) 0)) ) '("@" "@" (3 5 -4) "@" (4 -5 -3) (-4 2 1) (0 0 -2) (2 2 -4) (3 1 -4)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF-NOT.TEST new file mode 100644 index 00000000..dbf5f110 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: count-if-not ;; ;; Source: CLtL Section 14.4:Searching Sequences for items Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 29 ,1986 ;; ;; Last Update: Sept. 29 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-count-if-not.test ;; ;; ;; Syntax: count-if-not SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: Count returns a non-negative integer which is the number of ITEMs in the subsequence delemited by ;; :START and :END satisfying the test. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a non-negative integer ;; (do-test "test count-if-not 0" (and (= (count-if-not #'evenp '(2 52 44 5 3 7 8 9 0)) 4) (= (count-if-not #'evenp '(2 52 44 5 3 7 8 9 0) :from-end t) 4) (= (count-if-not #'oddp '(2 52 44 5 3 7 8 9 0) ) 5) (= (count-if-not #'integerp '(3 4 5 6 7 2 1)) 0) (= (count-if-not #'numberp '(3 4 5 6 7 2 1)) 0) (= (count-if-not #'atom '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 3) (= (count-if-not #'(lambda (x) (>= x 100)) ;; ;; create a list of integers from 0 to 149 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 150) b)) :from-end t) 100 ) ) ) (do-test "test count-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (count-if-not #'(lambda (x) (<= (realpart x) 8)) a ) 4) (= (count-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) 4 ) (= (count-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) 2) (= (count-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 15)) a :from-end t) 3 ) (= (count-if-not #'complexp a) 0) (= (count-if-not #'(lambda (x) (<= (realpart x) 8)) (append a a a a) :from-end t) 16) ) ) ) (do-test "test count-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (count-if-not #'lower-case-p a) 16) (= (count-if-not #'lower-case-p a :start 42) 8) (= (count-if-not #'lower-case-p a :start 49 :end 57) 3) (= (count-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) 6) (= (count-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\space))) a :end 60 :from-end t) 2) (= (count-if-not #'(lambda (x) (char/= x #\W)) (concatenate 'string a a) :start 1 ) 1) ) ) ) (do-test "test count-if-not 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (count-if-not #'oddp a :key #'cdr :from-end t) 3 ) (= (count-if-not #'evenp a :key #'cdr ) 5) (= (count-if-not #'minusp a :key #'car) 7) (= (count-if-not #'plusp a :key #'car) 1) ) ) ) (do-test "test fine-if-not 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (count-if-not #'listp a :start 1 :end 14 :from-end t) 11) (= (count-if-not #'vectorp a :start 6 ) 5) (= (count-if-not #'bit-vector-p a :start 5) 9) (= (count-if-not #'null a :start 10 :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3)) )) 1) (= (count-if-not #'(lambda (x) (char< x #\2)) a :end 10 :from-end t :key #'(lambda (x) (if (and (stringp x) (> (length x) 3)) (elt x 3) #\1) )) 2) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF.TEST new file mode 100644 index 00000000..94a5436c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: count-if ;; ;; Source: CLtL Section 14.4:Searching Sequences for items Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 29 ,1986 ;; ;; Last Update: Sept. 29 ,1986 ;; ;; Filed As: {eris}cml>test>14-3-count-if.test ;; ;; ;; Syntax: count-if SEQUENCE &KEY :FROM-END :START :END :KEY ;; ;; Function Description: Count returns a non-negative integer which is the number of ITEMs in the subsequence delemited by ;; :START and :END satisfying the test. ;; ;; Argument(s): ;; SEQUENCE - ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a non-negative integer ;; (do-test "test count-if 0" (and (= (count-if #'oddp '(2 52 44 5 3 7 8 9 0)) 4) (= (count-if #'oddp '(2 52 44 5 3 7 8 9 0) :from-end t) 4) (= (count-if #'complexp '(3 4 5 6 7 2 1)) 0) (= (count-if #'floatp '(3 4 5 6 7 2 1)) 0) (= (count-if #'consp '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 3) (= (count-if #'evenp ;; ;; create a list of integers from 0 to 249 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 250) b))) 125) ) ) (do-test "test count-if 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (count-if #'(lambda (x) (> (realpart x) 8)) a ) 4) (= (count-if #'(lambda (x) (> (realpart x) 8)) a :from-end t) 4 ) (= (count-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 30)) a ) 2) (= (count-if #'(lambda (x) (> (* (realpart x) (imagpart x)) 15)) a :from-end t) 3 ) (= (count-if #'integerp a) 0) (= (count-if #'(lambda (x) (> (realpart x) 8)) (append a a a a) :from-end t) 16) ) ) ) (do-test "test count-if 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (count-if #'upper-case-p a) 4) (= (count-if #'upper-case-p a :start 42) 3) (= (count-if #'upper-case-p a :start 49 :end 57) 1) (= (count-if #'(lambda (x) (not (alpha-char-p x))) a :start 35) 6) (= (count-if #'(lambda (x) (not (or (alpha-char-p x) (char= x #\space)))) a :end 60 :from-end t) 2) (= (count-if #'(lambda (x) (char= x #\W)) (concatenate 'string a a) :start 1 ) 1) ) ) ) (do-test "test count-if 3" (let ((a '( (3 . 4) (5 . -5) (5 . 10) (6 . 12) (32 . 3) (-23 . 9) (21 . 3) (11 . 37)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (count-if #'evenp a :key #'cdr :from-end t) 3 ) (= (count-if #'oddp a :key #'cdr ) 5) (= (count-if #'plusp a :key #'car) 7) (= (count-if #'minusp a :key #'car) 1) ) ) ) (do-test "test fine-if 4" (let (( a (list 23 #c(4 -3) 7.9 "str3" '(2 . 3) (vector 3 4 5) "gcd" #*101010 "str2" '(8 9) 30.0 #c(0 0) 33 "str1" 0 ) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;; (and (= (count-if #'integerp a :start 1 :end 14 :from-end t) 2) (= (count-if #'vectorp a :start 6 ) 4) (= (count-if #'bit-vector-p a :start 6) 1) (= (count-if #'(lambda (x) (equal x #\2)) a :start 10 :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) 0) (= (count-if #'(lambda (x) (equal x #\2)) a :end 10 :from-end t :key #'(lambda (x) (and (stringp x) (> (length x) 3) (elt x 3)))) 1) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT.TEST new file mode 100644 index 00000000..d08abd12 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: count ;; ;; Source: CLtL Section 14.4:Searching Sequences for items Page: 257 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Sept. 29 ,1986 ;; ;; Last Update: Sept. 29 ,1986 ;; ;; Filed As: {eris}cml>test>14-4-count.test ;; ;; ;; Syntax: count ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY ;; ;; Function Description: Count returns a non-negative integer which is the number of ITEMs in the subsequence delemited by ;; :START and :END satisfying the tes. ;; ;; Argument(s): ITEM - ;; SEQUENCE - ;; :TEST - a function which takes two arguments ;; :TEST-NOT - a function which takes two arguments ;; :FROM-END - nil or non-nil ;; :START :END - integer indices into the SEQUENCE, with :START <= :END ;; :KEY - a function of one argument that will extract from an element the part ;; to be tested in place of the whole element. ;; ;; Returns: a positive number or nil ;; (do-test "test count 0" (and (= (count 2 '(3 4 5 2.0 6 2 1 9 2 8 4 2 4 2)) 4) (= (count 2 '(3 4 5 2.0 6 2 1 9 2 8 4 2 4 2) :from-end t) 4) (= (count 3 '(1 2 4 5 6 7 8 (3) 9)) 0) (= (count '(1 2) '( 1 2 ((1 2)) 3 4 (1 2)) :test #'equal ) 1) (= (count #\q "antique-que-que" :test #'equal) 3) (= (count #\q "antique-que-que" :test #'equal :from-end t ) 3) (= (count #*1011 (vector #*0000 #*1111 #*1011) :test #'equalp) 1) (= (count #\a (make-string 50 :initial-element #\a)) 50) (= (count '(1 2) (make-list 100 :initial-element '(1 2)) :test #'equal) 100) ) ) (do-test "test count 1" (let ((a '(3 4 7 8 -2 9 7 8 -3 4 6 1 7 4 5 -3 2 0 4 -2 7 2 -3) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 20 21 22 ;; (and (= (count 7 a :start 3) 3) (= (count 7 a :start 2 ) 4) (= (count -3 a :end 17 ) 2) (= (count -3 a :start 9 :end 16) 1) (= (count -2 a :start 5 :end 14) 0) (= (count -2 a :start 4 :end 14) 1) (= (count 2 a :start 4 :end 19) 1) (= (count 2 a ) 2) (= (count 34 a ) 0) ) ) ) (do-test "test count 2" (let (( a "Fatal error in function SYSTEM: TASK-SCHEDULER")) ;; ;; 0123456789012345678901234567890123456789012345 ;; (and (= (count #\n a :test #'char=) 3) (= (count #\: a :test #'char=) 1) (= (count #\s a :test #'char-equal) 4) (= (count #\space a :test-not #'char= ) 41) (= (count #\F a :test #'(lambda (x y) (and (alpha-char-p y) (char> x y)))) 6) (= (count #\R a :test-not #'(lambda (x y) (/= (- (char-code y) (char-code x)) (- (char-code #\a) (char-code #\A)) ))) 3) ) ) ) (do-test "test count 3" (let ((a '( (1 3 7) (2 4 6)(38 5 7) (4 2 1) (-3 -5 -7) (-2 -4 -1) (2 22 31) (38 -72 7)) )) ;; ;; 0 1 2 3 4 5 6 7 ;; (and (= (count 7 a :key #'third) 3) (= (count -4 a :key #'second) 1) (= (count 38 a :key #'first) 2) (= (count 38 a :key #'first :from-end t) 2) (= (count 0 a :key #'cadr :test #'(lambda (x y) (> x y))) 3) (= (count 0 a :key #'cadr :test #'(lambda (x y) (> x y)) :from-end t) 3) (= (count 0 a :key #'caddr) 0) ) ) ) (do-test "test count 4" (let ((a '(#*11111 #*0000 #*10101010 #*01010101 #*111 #*00000 #*1110 #*0101111 #*000 #*11100 #*01000) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 10 ;; (and (= (count #*10 a :start 4 :end 10 :test #'equalp :key #'(lambda (x) (subseq x 1 3))) 1) (= (count #*11 a :start 1 :end 9 :test #'equalp :from-end t :key #'(lambda (x) (subseq x 0 2)) ) 2) (= (count #*01 a :start 4 :end 10 :test-not #'(lambda (x y) (or (/= (elt x 0) (elt y 0)) (/= (elt x 1) (elt y 1)) )) :from-end t) 1) (= (count 'dummy a :test-not #'(lambda (x y) (find 0 y)) ) 2) (= (count 'dummy a :test-not #'(lambda (x y) (find 0 y)) :start 1 :from-end t) 1) (= (count 'dummy a :test-not #'(lambda (x y) (find 1 y)) :end 5 :from-end t) 1) (= (count 'dummy a :test-not #'(lambda (x y) (find 1 y)) ) 3 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-4-MISMATCH.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-4-MISMATCH.TEST new file mode 100644 index 0000000000000000000000000000000000000000..512c2c57030bd874179e6c9d6581f297f84052c3 GIT binary patch literal 4605 zcmb_fTWcFf6z)U7sNhGFJ|1MKSFKmkO0p%(jY}>Lw7EEqm4`mAS0ibg)vmI;iX}>E ziC)@-;6D+P_Mw!PxG5@Bg}n7&^dhtUC_|dl0at&6Za9p_JU*Y673(ji!bRI9dYt&7< zMjpG}Vz$9NsyZ&2K5KaLYbMxATO)a9b^x@^rFR66t#@1DJ^V&r! zl{dG`!K_}}0wq3gm(SfOYgEDx%;GI8-m;;Ek((|u&v4BqcUg(bbw*y38D`alZC-09 zM&7ALI%uTZmFO)?y35FL8cjSa#4Ofewy*A*9!nE_RwcjAI(!c#C-?v-_*1vYVs_21 z3uYoV2(DsxnA?#|mibw7nb)#>GCi_Q3oN&==yLWGUv;t_Ta{95R?~g+4g*u4)tHNe zNgyOLeud~5!AX*yLHp3i_cP&zw3-+RW)Iq z?~t%+-Kj2~q0Y=g_Jz+T8r zNVjRU!#WO}C9L5=9a+KykyQc@=_G}41c5S@s;<*e8BX3}on6PRz=5?EcP!Vt23&2S ziY?4)S}jkA2;dCSbIn?P96l)pSjQ+zT|KIp)hf^sPV!r>4fSv$_|dsgzT%}u^JP|s zP!t4ln#k0`Q{{0)C?uh=QmY`7_(nmAY{KShOVlJ!xC5S+KzPwPo^g{yg+HsZ6aoa^TSM z?TH}!HEvc|2S5S??&*mfiA@r9gWJR_NR|^Poq;I2!MMw0H4IK*4w7n;lZ*=0<6nB1VK9Lybm_z~a zc;xBi`Dht6IN+FtbQ(#M#P8T0Q#^tr$B0($py?qRi&UT-E$OthL(0b>^C?o$PJGHz zo>s-zl@ukdTVEydWyYxjEh&8OpcAwqgDNS= z1i0A@<)B&~uWzw+rsULo>Uhs<-18RmNl|o4PR7q`iuuEZx#5}o`|tU`{Fr~xJAE|# zXMZsKYjD(k^057ESbA7o=EQ{`__DYS>-a8w^j+bqB8o z-#+g3KHp#H_YQ_ndxwV{E#>S;mQHzXS+w9Jax6vKsz}1o{qVD_=Gi2bJRjvxqZQm= z!nif+x_dT7D{Chm)lNFPnwdHp$;3fDl$xC(m1asE?dTpPM{U!e)LP4Ar)5vK$XE#t znOs5#)(B}Appm5l(7;-jidY+mMVqz_h|ZEAnFai_F@H_+*Jki96sGhC|MJOqs@NI0 zehOn&p!iIb{`KHnZ6?Z-LeS+#FK*L9@@vNk5doB+7V>&K;@Ai*L7_cSNKOM>M3_#j zbJ@{4hl;vr@ba7DPe>3?HHWGjP+3xgZy5?!a#RSuXr!(QDo-l91diiaP7qr3)KIl4 z#odUe%O}~UGm_xf1U|x+&&eF0Fwj@TSP7r#GIA6oQIy15Kxi2$YepB>Nim#eN5ut@ z^i&kivwzI`12E z4`R7E9%XMMC5NmF+?2;Zp8*9Mum~5)A!}ekT7Z9UEpaQ9xxaywLEcXrBTP}Fc!{H; zh{)mSjEu2-42+P1IOCBKI7zh~A8;y`-q@+Yi*4%Qa)46qnKirBpf=t@vXjC>W%4nV7 dc@ni2*;#UN>kaiq_|3dIhP7?Gymg&N;D2Hci!}fM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-5-MERGE.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-5-MERGE.TEST new file mode 100644 index 00000000..2eb14b40 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-5-MERGE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: merge ;; ;; Source: CLtL Section 14.5: Sorting and Merging Page: 260-261 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 1 ,1986 ;; ;; Last Update: Oct. 5 ,1986 ;; ;; Filed As: {eris}cml>test>14-5-merge.test ;; ;; ;; Syntax: merge RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY :KEY ;; ;; Function Description: The sequences SEQUENCE1 and SEQUENCE2 are destructively merged according to an order determined by ;; the PREDICATE. The result is a sequence of type RESULT-TYPE. (for detailed function description, please ;; refer to page 260-261 of CLtL ;; ;; Argument(s): RESULT-TYPE - must be s subtype of sequence ;; SEQUENCE1 SEQUENCE2 - ;; PREDICATE - a function which takes two arguments ;; :KEY - a function of one argument that will extract from an element the part to be tested ;; in place of the whole element ;; ;; Returns: a sequence ;; (do-test "test merge 0" (and (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'<) '(1 2 3 4 5 6 7 8)) (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'>) '(2 5 8 1 3 4 6 7)) (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'=) '(1 3 4 6 7 2 5 8)) (equal (merge 'list '(1 3 4 6 7) '(2 5 8) #'/=) '(2 5 8 1 3 4 6 7)) (equal (merge 'string "BOY" "nosy" #'char-lessp) "BnOosYy") (equal (merge 'string "BOY" "nosy" #'char<) "BOYnosy") (equal (merge 'string "BOY" "nosy" #'char>) "nosyBOY") ) ) (do-test "test merge 1" (let* ((a (do ((m 1 (+ 2 m)) (n nil (append n (list m))) ) ((>= m 200) n)) ) ;; a list of odd numbers from 1 to 199 (b (mapcar #'1+ a)) ;; a list of even numbers from 2 to 200 (ab (do ((m 1 (1+ m)) (n nil (append n (list m))) ) ((> m 200) n)) )) ;; a list of numbers from 1 to 200 (and (equal (merge 'list (copy-seq a) (copy-seq b) #'<) ab) (equal (merge 'list (reverse a) (reverse b) #'>) (reverse ab)) (equal (merge 'list (copy-seq a) (copy-seq b) #'>) (append b a)) ) ) ) (do-test "test merge 2" (let (( a '(3 10 5 49 30 50 23 4 8 27 10 4 32 8 20 9 11 27 13 20 32)) ( b '(7 30 4 12 6 23 12 20 42 45 50 43 20 18 7 6 23 10 22 3 1)) ( c '(3 -10 5 49 -30 50 -2 23 -4 8 27 10 74 -1 32 8 -20 9 11 -27 13 -20 32)) ( d '(-3 4 10 -2 10 34 28 -5 59 20 -4 12 20 0 10 14 33 -6 -4 -2 100))) (and (equal (merge 'list (copy-seq a) (copy-seq b) #'<) '(3 7 10 5 30 4 12 6 23 12 20 42 45 49 30 50 23 4 8 27 10 4 32 8 20 9 11 27 13 20 32 50 43 20 18 7 6 23 10 22 3 1)) (equal (merge 'list a b #'>) '(7 30 4 12 6 23 12 20 42 45 5đ 43 20 18 7 6 23 10 22 3 10 5 49 30 50 23 4 8 27 10 4 32 8 20 9 11 27 13 20 32 3 1)) (uqual (merge 'list (copy-seq c) (copy-seq d) #'<) '(-3 3 -10 4 5 10 -2 10 34 28 -5 49 -30 50 -2 23 -4 8 27 18 59 20 -4 12 28 0 10 14 33 -6 -4 -2 74 -1 32 8 -20 9 11 -27 13 -20 32 100)) (equal (merge 'list (copy-seq c) (copy-seq d) #'(lambda (x y) (> (abs x) (abs y)))) '(3 -10 5 49 -30 50 -3 4 10 -2 23 -4 8 27 10 74 -2 10 34 28 -5 59 20 -4 12(do-test "test position-if-not 0" (and (= (position-if-not #'evenp '(2 52 44 5 3 7 8 9 0)) 3) (= (position-if-not #'evenp '(2 52 44 5 3 7 8 9 0) :from-end t) 7) (eq (position-if-not #'integerp '(3 4 5 6 7 2 1)) nil) (eq (position-if-not #'numberp '(3 4 5 6 7 2 1)) nil) (= (position-if-not #'atom '( 3 (9) 4 (5) 9 8 (9) 7) :from-end t) 6) (= (position-if-not #'(lambda (x) (>= x 100)) ;; ;; create a list of integers from 0 to 249 ;; (do ((a 0 (1+ a)) (b nil (append b (list a)))) ((= a 250) b)) :from-end t) 99) ) ) (do-test "test position-if-not 1" (let ((a '(#c(2 -2) #c(8 9) #c(10 -2) #c(7 65) #c( 10 -2) #c(30 -2) #c(-2 -3) #c(10 -4) #c(-1 3) #c(3 9)) )) ;; ;; 0 1 2 3 4 5 6 7 8 9 ;; (and (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) a ) 2) (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) a :from-end t) 7 ) (= (position-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a ) 1) (= (position-if-not #'(lambda (x) (<= (* (realpart x) (imagpart x)) 30)) a :from-end t) 3 ) (eq (position-if-not #'complexp a) nil) (= (position-if-not #'(lambda (x) (<= (realpart x) 8)) (append a a a a) :from-end t) 37) ) ) ) (do-test "test position-if-not 2" (let ((a "Whitetail deer under oak tree at twilight. Near Curran, Michigan." )) ;; ;; 01234567890123456789012345678901234567890123456789012345678901234 ;; 1 2 3 4 5 6 ;; (and (= (position-if-not #'lower-case-p a) 0) (= (position-if-not #'lower-case-p a :start 42) 42) (= (position-if-not #'lower-case-p a :start 49 :end 57) 54) (= (position-if-not #'(lambda (x) (alpha-char-p x)) a :start 35) 41) (= (position-if-not #'(lambda (x) (or (alpha-char-p x) (char= x #\sp \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-5-SORT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-5-SORT.TEST new file mode 100644 index 00000000..56d3bdfb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-5-SORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: sort ;; ;; Source: CLtL Section 14.5: Sorting and Merging Page: 258 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 6 ,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - There was an extra unfinished clause in test 2 ;; that was failing on the SUN. ;; ;; Filed As: {eris}cml>test>14-5-sort.test ;; ;; ;; Syntax: sort SEQUENCE PREDICATE &KEY :KEY ;; ;; Function Description: The SEQUENCE is destructively sorted according to and order determined by the PREDICATE. ;; sort does not guarantee stability. For detailed funtion description, please read page 258-259 of CLtL ;; ;; Argument(s): SEQUENCE - ;; PREDICATE - a function which takes two arguments. ;; :KEY - a function of one argument that will extract from an element the part to be tested in place ;; of the whole element ;; ;; Returns: a sequence ;; (do-test "test sort - test cases copied from page 260 of CLtL" (let (( foovector (vector '("Tokens" "The Lion Sleeps Tonight") '("Carpenters" "Close to You") '("Rolling Stones" "Brown Sugar") '("Beach Boys" "I Get Around") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Beatles" "I Want to Hold Your Hand")) )) (setq foovector (sort foovector #'string-lessp :key #'car)) (equalp foovector (vector '("Beach Boys" "I Get Around") '("Beatles" "I Want to Hold Your Hand") '("Carpenters" "Close to You") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Rolling Stones" "Brown Sugar") '("Tokens" "The Lion Sleeps Tonight") )) ) ) (do-test "test sort 1" (let ((a "qazwsxedcrfvtgbyhnujmikolpPLOKIUJMYHNTGBRFVEDCXZSAQW" )) (and (equal (sort (copy-seq a) #'char<) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (let ((b (sort (copy-seq a) #'char-lessp) )) (and (= (length b) 52) (every #'(lambda (x y) (let ((c (elt b x)) ) (cond ( (char= c y) (char= (elt b (1+ x)) (char-upcase y))) ( (char= c (char-upcase y)) (char= (elt b (1+ x)) y))))) '(0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 ) "abcdefghijklmnopqrstuvwxyz"))) (equal (sort (copy-seq a) #'char>) "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA") (let ((b (sort (copy-seq a) #'char-greaterp) )) (and (= (length b) 52) (every #'(lambda (x y) (let ((c (elt b x)) ) (cond ( (char= c y) (char= (elt b (1+ x)) (char-upcase y))) ( (char= c (char-upcase y)) (char= (elt b (1+ x)) y))))) '(0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 ) "zyxwvutsrqponmlkjihgfedcba"))) ) ) ) (do-test "test sort 2" (let ((a '("should" "sequences" "sort" "two" "already" "sense" "argument" "sun" "second" "fourth" "nin" "who") )) ;; ;; 6 9 4 3 7 5 8 3 6 6 3 3 (and (let ((b (sort (copy-seq a) #'> :key #'length)) c) ;; ;; one possible value of b is: ;; ( "sequences" "argument" "already" "should" "second" "fourth" "sense" "sort" "two" "sun" "nin" "who")) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) ) ) (let ((b (sort (copy-seq a) #'char> :key #'(lambda (x) (elt x 1))) ) (c -1)) ;; ;; one possible value of b is: ;; ("two" "sun" "argument" "sort" "fourth" "already" "nin" "should" "who" "sequences" "sense" "second")) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) (every #'(lambda (x) (char= (elt (elt b (incf c)) 1) x)) "wuroolihheee") ) ) (let ((b (sort (copy-seq a) #'char< :key #'(lambda (x) (elt x 2))) ) (c -1)) ;; ;; one possible value of b is: ;; ("second" "argument" "sense" "sun" "nin" "should" "two" "who" "sequences" "sort" "already" "fourth" )) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) (every #'(lambda (x) (char= (elt (elt b (incf c)) 2) x)) "cgnnnoooqrru") ) ) (let ((b (sort (copy-seq a) #'char< :key #'(lambda (x) (elt (reverse x) 0))) ) (c -1)) ;; ;; one possible value of b is: ;; ("should" "second" "sense" "fourth" "sun" "nin" "two" "who" "sequences" "sort" "argument" "already" )) ;; (and (= (length b) 12) (every #'(lambda (x) (find x b :test #'equal)) a) (every #'(lambda (x) (char= (elt (reverse (elt b (incf c))) 0) x)) "ddehnnoostty") ) ) ) ) ) (do-test "test sort 3" (let ((a '( 2.4 5.9 20 10.0 18.3 18.6 22.1 0.9 1.31 8.67 3.41 2.9 100.2 35.2 29.5 30 60 18.15) ) b) ;; ;; + 6 14 20 10 21 24 23 9 4.1 14.7 7.1 11 102 37 34 30 60 19.5 ;; - -2 -4 20 10 15 12 21 -9 -2.1 1.3 -1.1 -7 98 33 24 30 60 16.5 ;; * 8 45 0 0 54 104 22 0 3.1 53.6 12.3 18 200 70 145 0 0 27 ;; (and (equal (sort (copy-seq a) #'(lambda (x y) (> (apply #'+ x) (apply #'+ y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(100.2 60 35.2 29.5 30 18.6 22.1 18.3 20 18.15 8.67 5.9 2.9 10.0 0.9 3.41 2.4 1.31 )) (equal (sort (copy-seq a) #'(lambda (x y) (< (apply #'- x) (apply #'- y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(0.9 2.9 5.9 1.31 2.4 3.41 8.67 10.0 18.6 18.3 18.15 20 22.1 29.5 30 35.2 60 100.2 )) (let ((b (sort (copy-seq a) #'(lambda (x y) (> (apply #'* x) (apply #'* y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) )) ;; ;; one possible value of b is: ;; (100.2 29.5 18.6 35.2 18.3 8.67 5.9 18.15 22.1 2.9 3.41 2.4 1.31 20 10.0 0.9 30 60 )) ;; (and (= (length b) 18) (= (mismatch b '(100.2 29.5 18.6 35.2 18.3 8.67 5.9 18.15 22.1 2.9 3.41 2.4 1.31) :test #'=) 13) (every #'(lambda (x) (find x (subseq b 13) :test #'=)) '(20 10.0 0.9 30 60 )) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/14/14-5-STABLE-SORT.TEST b/internal/test/LANGUAGE/from-sun/language/14/14-5-STABLE-SORT.TEST new file mode 100644 index 00000000..d7ed26dc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/14/14-5-STABLE-SORT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: stable-sort ;; ;; Source: CLtL Section 14.5: Sorting and Merging Page: 258 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 2 ,1986 ;; ;; Last Update: Oct. 2 ,1986 ;; ;; Filed As: {eris}cml>test>14-5-stable-sort.test ;; ;; ;; Syntax: stable-sort SEQUENCE PREDICATE &KEY :KEY ;; ;; Function Description: The SEQUENCE is destructively sorted according to and order determined by the PREDICATE. ;; stable-sort guarantees stability. For detailed funtion description, please read page 258-259 of CLtL ;; ;; Argument(s): SEQUENCE - ;; PREDICATE - a function which takes two arguments. ;; :KEY - a function of one argument that will extract from an element the part to be tested in place ;; of the whole element ;; ;; Returns: a sequence ;; (do-test "test stable-sort - test cases copied from page 260 of CLtL" (let (( foovector (vector '("Tokens" "The Lion Sleeps Tonight") '("Carpenters" "Close to You") '("Rolling Stones" "Brown Sugar") '("Beach Boys" "I Get Around") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Beatles" "I Want to Hold Your Hand")) )) (setq foovector (stable-sort foovector #'string-lessp :key #'car)) (equalp foovector (vector '("Beach Boys" "I Get Around") '("Beatles" "I Want to Hold Your Hand") '("Carpenters" "Close to You") '("Mozart" "Eine Kleine Nachtmusik" (K 525)) '("Rolling Stones" "Brown Sugar") '("Tokens" "The Lion Sleeps Tonight") )) ) ) (do-test "test stable-sort 1" (let ((a "qazwsxedcrfvtgbyhnujmikolpPLOKIUJMYHNTGBRFVEDCXZSAQW" )) (and (equal (stable-sort (copy-seq a) #'char<) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (equal (stable-sort (copy-seq a) #'char-lessp) "aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ") (equal (stable-sort (copy-seq a) #'char>) "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA") (equal (stable-sort (copy-seq a) #'char-greaterp) "zZyYxXwWvVuUtTsSrRqQpPoOnNmMlLkKjJiIhHgGfFeEdDcCbBaA") ) ) ) (do-test "test stable-sort 2" (let ((a '("should" "sequences" "sort" "two" "already" "sense" "argument" "sun" "second" "fourth" "nin" "who") )) ;; ;; 6 9 4 3 7 5 8 3 6 6 3 3 (and (equal (stable-sort (copy-seq a) #'> :key #'length) '( "sequences" "argument" "already" "should" "second" "fourth" "sense" "sort" "two" "sun" "nin" "who")) (equal (stable-sort (copy-seq a) #'char> :key #'(lambda (x) (elt x 1))) '("two" "sun" "argument" "sort" "fourth" "already" "nin" "should" "who" "sequences" "sense" "second")) (equal (stable-sort (copy-seq a) #'char< :key #'(lambda (x) (elt x 2))) '("second" "argument" "sense" "sun" "nin" "should" "two" "who" "sequences" "sort" "already" "fourth" )) (equal (stable-sort (copy-seq a) #'char< :key #'(lambda (x) (elt (reverse x) 0))) '("should" "second" "sense" "fourth" "sun" "nin" "two" "who" "sequences" "sort" "argument" "already" )) ) ) ) (do-test "test stable-sort 3" (let ((a '( 2.4 5.9 20 10.0 18.3 18.6 22.1 0.9 1.31 8.67 3.41 2.9 100.2 35.2 29.5 30 60 18.15) ) b) ;; ;; + 6 14 20 10 21 24 23 9 4.1 14.7 7.1 11 102 37 34 30 60 19.5 ;; - -2 -4 20 10 15 12 21 -9 -2.1 1.3 -1.1 -7 98 33 24 30 60 16.5 ;; * 8 45 0 0 54 104 22 0 3.1 53.6 12.3 18 200 70 145 0 0 27 ;; (and (equal (stable-sort (copy-seq a) #'(lambda (x y) (> (apply #'+ x) (apply #'+ y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(100.2 60 35.2 29.5 30 18.6 22.1 18.3 20 18.15 8.67 5.9 2.9 10.0 0.9 3.41 2.4 1.31 )) (equal (stable-sort (copy-seq a) #'(lambda (x y) (< (apply #'- x) (apply #'- y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(0.9 2.9 5.9 1.31 2.4 3.41 8.67 10.0 18.6 18.3 18.15 20 22.1 29.5 30 35.2 60 100.2 )) (equal (stable-sort (copy-seq a) #'(lambda (x y) (> (apply #'* x) (apply #'* y))) :key #'(lambda (x ) (list (setq b (truncate x)) (* 10 (- x b))))) '(100.2 29.5 18.6 35.2 18.3 8.67 5.9 18.15 22.1 2.9 3.41 2.4 1.31 20 10.0 0.9 30 60 )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAAR.TEST new file mode 100644 index 00000000..8bc10e7b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAAAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 14 ,1986 ;; ;; Last Update: July 14 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caaaar.test ;; ;; ;; Syntax: CAAAAR LIST ;; ;; Function Description: (CAAAAR LIST) is equivalent to (CAR (CAR (CAR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaaar list) ,elm)) ((or cons string) (equal (caaaar list) ,elm)) (t (eq (caaaar list) ,elm)) ) ) (do-test "test caaaar0" (prog1 (and (mac '((((1)) 2 )) 1) (mac '((((1) . 2) 3 . 4) a) 1) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) '(1 2)) (mac '(( (((1 . 100) a))) (2 b) (3 c)) '(1 . 100)) (mac '((( ((#\a)) (( b))) ((c)) d)) '(#\a)) (mac '((( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(foo1) ) (mac '(((((((((( t )))))))))) '(((((( t)))))) ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '((((#\F) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '((((("the weather in January")) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January") ) )) ) (do-test "test caaaar1" (progn (setq a (list (list (list (list #'null #'oddp))) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaaar a) (mapcar #'caaaar '( ((((8)))) (((()(1 2) 3 ) 4)) ((((#\a #\b #\c))) ((#\d) #\e #\f)) ) )) '( nil t nil)) ) ) (do-test "test caaaar2" (let ((aa '((((((((((((((((t)) 1 2) 3 4) 5 6))) 7 8) 9 10))) 11 12) 13 14))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaaar aa) '((((((((((((t)) 1 2) 3 4) 5 6))) 7 8) 9 10))) 11 12)) (equal (caaaar (caaaar aa)) '((((((((t)) 1 2) 3 4) 5 6))) 7 8) ) (equal (caaaar (caaaar (caaaar aa))) '((((t)) 1 2) 3 4) ) (eq (caaaar (caaaar (caaaar (caaaar aa)))) 't) ) ) ) (do-test "test caaaar3" (progn (setq aa '((((a)) b) c d ) ) (and (setf (caaaar aa) '( (((2)) 4) (((2)) 4)) ) (equal aa `(((( ((((2)) 4) (((2)) 4)) )) b) c d ) ) (setf (caaaar (caaaar aa)) '((((3))) 9) ) (equal aa `(((( (((( ((((3))) 9) )) 4) (((2)) 4)) )) b) c d )) (setf (caaaar(caaaar (caaaar aa))) "magic kingdom") (equal aa `(((( (((( (((("magic kingdom"))) 9) )) 4) (((2)) 4)) )) b) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAADR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAADR.TEST new file mode 100644 index 00000000..bfc51e5b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAAADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caaadr.test ;; ;; ;; Syntax: CAAADR LIST ;; ;; Function Description: (CAAADR LIST) is equivalent to (CAR (CAR (CAR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaadr list) ,elm)) ((or cons string) (equal (caaadr list) ,elm)) (t (eq (caaadr list) ,elm)) ) ) (do-test "test caaadr0" (prog2 (and (mac '(0 ((1)) 2 ) 1) (mac '(b ((1 . 2) 3 . 4) a) 1) (mac '(-1 ((( 1 2) 3 4) 5) 6 7 8 9) '(1 2)) (mac '((0 . z) ( ((1 . 100) a)) (2 b) (3 c)) '(1 . 100)) (mac '(#\q ( ((#\a)) (( b))) ((c)) d) '(#\a)) (mac '(foo0 (( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '((foo1) foo2)) (mac '((t) ((((((((( t )))))))))) '((((((( t))))))) ) (mac '(listen (("excitint" "vacations") "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '((#\w) ((#\F) #\o "o1") "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '("heading" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "the weather in January" ) )) ) (do-test "test caaadr1" (progn (setq a (list #'+ (list (list #'null #'oddp)) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaadr a) (mapcar #'caaadr '( (nil (())) (5 ((1 2) 3 ) 4) (t (((#\a #\b #\c))) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caaadr2" (let ((aa '(0 (((-1 ((( -2 ((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12) 13 14)) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaadr aa) '(-1 (((-2 ((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12)) (equal (caaadr (caaadr aa)) '(-2 ((((1 2) 3 4) 5 6)) 7 8) ) (equal (caaadr (caaadr (caaadr aa))) '((1 2) 3 4) ) ) ) ) (do-test "test caaadr3" (progn (setq aa '(z ((a) b) c d ) ) (and (setf (caaadr aa) '(2 (( 4) 8)) ) (equal aa `(z (( (2 (( 4) 8)) ) b) c d ) ) (setf (caaadr (caaadr aa)) '(1 ((3)) 9)) (equal aa `(z (( (2 (( (1 ((3)) 9) ) 8)) ) b) c d )) (setf (caaadr(caaadr (caaadr aa))) "magic kingdom") (equal aa `(z (( (2 (( (1 (("magic kingdom")) 9) ) 8)) ) b) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAR.TEST new file mode 100644 index 00000000..f69c8d2e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 14 ,1986 ;; ;; Last Update: July 14 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caaar.test ;; ;; ;; Syntax: CAAAR LIST ;; ;; Function Description: (CAAAR LIST) is equivalent to (CAR (CAR (CAR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaar list) ,elm)) ((or cons string) (equal (caaar list) ,elm)) (t (eq (caaar list) ,elm)) ) ) (do-test "test caaar0" (prog1 (and (mac '(((1)) 2 ) 1) (mac '(((1 . 2) 3 . 4) a) 1) (mac '(((( 1 2) 3 4) 5) 6 7 8 9) '(1 2)) (mac '(( ((1 . 100) a)) (2 b) (3 c)) '(1 . 100)) (mac '(( ((#\a)) (( b))) ((c)) d) '(#\a)) (mac '((( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '((foo1) foo2)) (mac '(((((((((( t )))))))))) '((((((( t))))))) ) (mac '( (("excitint" "vacations") "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '(((#\F) #\o "o1") "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "the weather in January" ) )) ) (do-test "test caaar1" (progn (setq a (list (list (list #'null #'oddp)) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaar a) (mapcar #'caaar '( ((())) (((1 2) 3 ) 4) ((((#\a #\b #\c))) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caaar2" (let ((aa '(((((((((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12) 13 14)) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaar aa) '((((((((1 2) 3 4) 5 6)) 7 8) 9 10)) 11 12)) (equal (caaar (caaar aa)) '(((((1 2) 3 4) 5 6)) 7 8) ) (equal (caaar (caaar (caaar aa))) '((1 2) 3 4) ) ) ) ) (do-test "test caaar3" (progn (setq aa '(((a) b) c d ) ) (and (setf (caaar aa) (make-list 2 :initial-element '((2) 4))) (equal aa `((( (((2) 4) ((2) 4)) ) b) c d ) ) (setf (caaar (caaar aa)) '(((3)) 9) ) (equal aa `((( ((( (((3)) 9) ) 4) (( (((3)) 9)) 4)) ) b) c d )) (setf (caaar(caaar (caaar aa))) "magic kingdom") (equal aa `((( ((( ((("magic kingdom")) 9) ) 4) ((((("magic kingdom")) 9)) 4))) b) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADAR.TEST new file mode 100644 index 00000000..62d75336 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAADAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 22 ,1986 ;; ;; Last Update: July 22 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caadar.test ;; ;; ;; Syntax: CAADAR LIST ;; ;; Function Description: (CAADAR LIST) is equivalent to (CAR (CAR (CDR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caadar list) ,elm)) ((or cons string) (equal (caadar list) ,elm)) (t (eq (caadar list) ,elm)) ) ) (do-test "test caadar0" (prog1 (and (mac '(((0 1) (1)) 2 ) 1) (mac '(((((q p))) ((1 . 2) 3 . 4)) a) '(1 . 2)) (mac '((a (( 1 2 3 4) 5) 6) 7 8 9) '(1 2 3 4)) (mac '((0.009 ( 1 a)) (2 b) (3 c)) 1) (mac '((#\3 ( ((a)) (( b)))) ((c)) d) '((a))) (mac '(('quack (foo bar) (foo1 . bar1)) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '((non-nil ((((((((( t ))))))))))) '(((((((( t)))))))) ) (mac '( ("article" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient)))) "excitint") (mac '((#\q (#\F)) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '(("name: " (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time)) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caadar1" (progn (setq a (list (list #'member (list #'null #'oddp) (list #'list #'max #'min #'evenp)) #'(lambda (x) (* 100 x)))) (equal (mapcar (caadar a) (mapcar #'caadar '( ((t ())) ((5 (1 2) 3) 4) ((#\* (#\a #\b #\c)) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caadar2" (let ((aa '((-1 (((-2 (((-3 (((-4 (1 2)) 3 4) 5 6)) 7 8) 9 10)) 11 12) 13 14)) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caadar aa) '((-2 (((-3 (((-4 (1 2)) 3 4) 5 6)) 7 8) 9 10)) 11 12)) (equal (caadar (caadar aa)) '((-3 (((-4 (1 2)) 3 4) 5 6)) 7 8) ) (equal (caadar (caadar (caadar aa))) '((-4 (1 2)) 3 4) ) (equal (caadar (caadar (caadar (caadar aa)))) 1) ) ) ) (do-test "test caadar3" (progn (setq aa '((z (a b) c) d )) (and (setf (caadar aa) '((2 (4 8))) ) (equal aa `((z ( ((2 (4 8))) b) c) d )) (setf (caadar (caadar aa)) '((1 (3)) 9)) (equal aa `((z ( ((2 ( ((1 (3)) 9) 8))) b) c) d )) (setf (caadar(caadar (caadar aa))) "magic kingdom") (equal aa `((z ( ((2 ( ((1 ("magic kingdom")) 9) 8))) b) c) d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADDR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADDR.TEST new file mode 100644 index 00000000..b1da8fbd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAADDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caaddr.test ;; ;; ;; Syntax: CAADDR LIST ;; ;; Function Description: (CAADDR LIST) is equivalent to (CAR (CAR (CDR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caaddr list) ,elm)) ((or cons string) (equal (caaddr list) ,elm)) (t (eq (caaddr list) ,elm)) ) ) (do-test "test caaddr0" (prog1 (and (mac '(3 (0 1) (1) 2 ) 1) (mac '(t (((q p))) ((1 . 2) 3 . 4) a) '(1 . 2)) (mac '(b a (( 1 2 3 4) 5) 6 7 8 9) '(1 2 3 4)) (mac '("a" 0.009 ( 1 a) (2 b) (3 c)) 1) (mac '("pup" #\3 ( ((a)) (( b))) ((c)) d) '((a))) (mac '(100 'quack (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '(t non-nil ((((((((( t )))))))))) '(((((((( t)))))))) ) (mac '((99) "article" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '(spurious #\q (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '(99.999 "name: " (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caaddr1" (progn (setq a (list #'member #'union (list #'null #'oddp) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caaddr a) (mapcar #'caaddr '( (t nil ()) (5 (5) (1 2) 3 4) (#\* #\& (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caaddr2" (let ((aadd '(-1 1 ((-2 2 ((-3 3 ((-4 4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12) 13 14) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caaddr aadd) '(-2 2 ((-3 3 ((-4 4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12)) (equal (caaddr (caaddr aadd)) '(-3 3 ((-4 4 (1 2) 3 4) 5 6) 7 8) ) (equal (caaddr (caaddr (caaddr aadd))) '(-4 4 (1 2) 3 4) ) (equal (caaddr (caaddr (caaddr (caaddr aadd)))) 1) ) ) ) (do-test "test caaddr3" (progn (setq aadd '(z y (a b) c d )) (and (setf (caaddr aadd) '(2 3 (4 8)) ) (equal aadd `(z y ( (2 3 (4 8)) b) c d )) (setf (caaddr (caaddr aadd)) '(1 2 (3) 9)) (equal aadd `(z y ( (2 3 ( (1 2 (3) 9) 8)) b) c d )) (setf (caaddr(caaddr (caaddr aadd))) "magic kingdom") (equal aadd `(z y ( (2 3 ( (1 2 ("magic kingdom") 9) 8)) b) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADR.TEST new file mode 100644 index 00000000..7e840c66 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CAADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caadr.test ;; ;; ;; Syntax: CAADR LIST ;; ;; Function Description: (CAADR LIST) is equivalent to (CAR (CAR (CDR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caadr list) ,elm)) ((or cons string) (equal (caadr list) ,elm)) (t (eq (caadr list) ,elm)) ) ) (do-test "test caadr0" (prog1 (and (mac '((0 1) (1) 2 ) 1) (mac '((((q p))) ((1 . 2) 3 . 4) a) '(1 . 2)) (mac '(a (( 1 2 3 4) 5) 6 7 8 9) '(1 2 3 4)) (mac '(0.009 ( 1 a) (2 b) (3 c)) 1) (mac '(#\3 ( ((a)) (( b))) ((c)) d) '((a))) (mac '('quack (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '(non-nil ((((((((( t )))))))))) '(((((((( t)))))))) ) (mac '( "article" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '(#\q (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '("name: " (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caadr1" (progn (setq a (list #'member (list #'null #'oddp) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caadr a) (mapcar #'caadr '( (t ()) (5 (1 2) 3 4) (#\* (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caadr2" (let ((aad '(-1 ((-2 ((-3 ((-4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12) 13 14) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caadr aad) '(-2 ((-3 ((-4 (1 2) 3 4) 5 6) 7 8) 9 10) 11 12)) (equal (caadr (caadr aad)) '(-3 ((-4 (1 2) 3 4) 5 6) 7 8) ) (equal (caadr (caadr (caadr aad))) '(-4 (1 2) 3 4) ) (equal (caadr (caadr (caadr (caadr aad)))) 1) ) ) ) (do-test "test caadr3" (progn (setq aad '(z (a b) c d )) (and (setf (caadr aad) '(2 (4 8)) ) (equal aad `(z ( (2 (4 8)) b) c d )) (setf (caadr (caadr aad)) '(1 (3) 9)) (equal aad `(z ( (2 ( (1 (3) 9) 8)) b) c d )) (setf (caadr(caadr (caadr aad))) "magic kingdom") (equal aad `(z ( (2 ( (1 ("magic kingdom") 9) 8)) b) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAR.TEST% b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAR.TEST% new file mode 100644 index 00000000..2d84c532 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAR.TEST% @@ -0,0 +1 @@ +;; Function To Be Tested: CAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 8 ,1986 ;; ;; Last Update: July 8 ,1986 ;; ;; Filed As: {eris}cml>test>caar.test ;; ;; ;; Syntax: CAAR LIST ;; ;; Function Description: If the first element of LIST is a list, CAAR returns the first element of the sublist. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caar list) ,elm)) ((or cons string) (equal (caar list) ,elm)) (t (eq (caar list) ,elm)) ) ) (do-test "test caar0" (prog1 (and (mac '((1) 2 ) 1) (mac '(((1 . 2) 3 . 4) a) '(1 . 2)) (mac '((( 1 2 3 4) 5) 6 7 8 9) '(1 2 3 4)) (mac '(( 1 a) (2 b) (3 c)) 1) (mac '(( ((a)) (( b))) ((c)) d) '((a))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo) (mac '(((((((((( t )))))))))) '(((((((( t)))))))) ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "excitint") (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) #\F ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("the weather in January" ("is usually clear and sunny")) ) )) ) (do-test "test caar1" (progn (setq a (list (list #'null #'oddp) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (caar a) (mapcar #'caar '( (()) ((1 2) 3 4) ((#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(t nil nil)) ) ) (do-test "test caar2" (let ((aa '((((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) 13 14) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (caar aa) '((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12)) (equal (caar (caar aa)) '((((1 2) 3 4) 5 6) 7 8) ) (equal (caar (caar (caar aa))) '((1 2) 3 4) ) (equal (caar (caar (caar (caar aa)))) 1) ) ) ) (do-test "test caar3" (progn (setq aa '((a b) c d )) (and (setf (caar aa) (make-list 2 :initial-element '(2 4))) (equal aa `(( ((2 4) (2 4)) b) c d )) (setf (caar (caar aa)) '((3) 9)) (equal aa `(( ((((3) 9) 4) ( ((3) 9) 4)) b) c d )) (setf (caar(caar (caar aa))) "magic kingdom") (equal aa `(( (((("magic kingdom") 9) 4) ( (("magic kingdom") 9) 4)) b) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAA.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAA.TEST new file mode 100644 index 00000000..3917deae --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAA.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 16 ,1986 ;; ;; Last Update: July 16 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cadaar.test ;; ;; ;; Syntax: CADAAR LIST ;; ;; Function Description: (CADAAR LIST) is equivalent to (CAR (CDR (CAR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test cadaar0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (cadaar ,list) ,elm)) ((or cons string) (equal (cadaar ,list) ,elm)) (t (eq (cadaar ,list) ,elm)) ) ) (and (mac '((((1) 11) 2 )) 11) (mac '((((1) (3 . 2)) 3 . 4) a) '(3 . 2)) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) 4) (mac '(( (((1 . 100) a) #\q) ) (2 b) (3 c)) #\q) (mac '((( ((#\a) #\b #\c) (( b))) ((c)) d)) '(( b))) (mac '((( ((foo1) foo2) foo2.5 foo2.6)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'foo2.5 ) (mac '(((((((((( t ))))))) nil))) nil ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "to") (mac '((((#\F) (bar1 . bar2) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '(bar1 . bar2) ) (mac '((((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("is usually clear and sunny") ) )) ) (do-test "test cadaar1" (progn (setq a (list (list (list #'null #'(lambda (x) (listp x)))) #'(lambda (x) (* 100 x)))) (equal (mapcar (cadaar a) (mapcar #'cadaar '( ((((8) (88)))) ((((9 99 999)(1 2) 3 ) 4)) ((((#\a #\b . #\c) #\m)) ((#\d) #\e #\f)) ) )) '(t t nil)) ) ) (do-test "test cadaar2" (prog2 (setq aa '(((1 (((2 (((3 ((( 4 5 6 7 . 8))) ))) ))) ))) ) (and (equal (cadaar aa) '((( 2 ((( 3 ((( 4 5 6 7 . 8))) ))) ))) ) (equal (cadaar (cadaar aa)) '((( 3 ((( 4 5 6 7 . 8))) ))) ) (equal (cadaar (cadaar (cadaar aa))) '((( 4 5 6 7 . 8))) ) (equal (cadaar (cadaar (cadaar (cadaar aa)))) 5) ) ) ) (do-test "test cadaar3" (progn (setq aa '(((a b)) c)) (setf (cadaar aa) '((( c d e))) ) (setf (cadaar (cadaar aa)) '((( f g h))) ) (setf (cadaar (cadaar (cadaar aa))) '((( i j k))) ) (equal aa '((( a ((( c ((( f ((( i j k))) h))) e))) )) c) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADADR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADADR.TEST new file mode 100644 index 00000000..c062e54f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cadadr.test ;; ;; ;; Syntax: CADADR LIST ;; ;; Function Description: CADADR is equivalent to (CAR (CDR (CAR (CDR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cadadr list) ,elm)) ((or cons string) (equal (cadadr list) ,elm)) (t (eq (cadadr list) ,elm)) ) ) (do-test "test cadadr0" (prog1 (and (mac '(19 (1 ((9))) 2 ) '((9))) (mac '(12 ((1 . 2) 3 . 4) a) 3) (mac '(21 (( 1 2 3 4) 5) 6 7 8 9) 5) (mac '((("p")) ( 1 a) (2 b) (3 c)) 'a) (mac '((((7))) ( ((a)) (( b))) ((c)) d) '(( b))) (mac '((foo0 . bar0) (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'bar) (mac '(((no-nil) t) ((((((((( t )))))))) tilt)) 'tilt ) (mac '( "canada" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "vacations") (mac '(#\B (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '("mac" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "with temperatures usually in the " ) )) ) (do-test "test cadadr1" (progn (setq a (list #'intersection (list* #'null #'list-length #'min #'evenp #'identity))) (equal (mapcar (cadadr a) (mapcar #'cadadr '( (aabb (a (((b))) )) (zero (1 nil) 3 4) (noway (#\a (#\b #\c)) ((#\d) #\e #\f)) ) )) '(1 0 2 )) ) ) (do-test "test cadadr2" (let ((aa '(0 (1 (2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (13 14) )) )) )) )) )) )) )) (and (equal (cadadr aa) '(2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (13 14) )) )) )) )) )) ) (equal (cadadr (cadadr aa)) '(4 (5 (6 (7 (8 (9 (10 (11 (13 14) )) )) )) )) ) (equal (cadadr (cadadr (cadadr aa))) '(6 (7 (8 (9 (10 (11 (13 14) )) )) )) ) (equal (cadadr (cadadr (cadadr (cadadr aa)))) '(8 (9 (10 (11 (13 14) )) )) ) (equal (cadadr (cadadr (cadadr (cadadr (cadadr aa))))) '(10 (11 (13 14) )) ) (equal (cadadr (cadadr (cadadr (cadadr (cadadr (cadadr aa)))))) '(13 14) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAR.TEST new file mode 100644 index 00000000..1dc03d8e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 16 ,1986 ;; ;; Last Update: July 16 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cadar.test ;; ;; ;; Syntax: CADAR LIST ;; ;; Function Description: CADAR is equivalent to (CAR (CDR (CAR LIST))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cadar list) ,elm)) ((or cons string) (equal (cadar list) ,elm)) (t (eq (cadar list) ,elm)) ) ) (do-test "test cadar0" (prog1 (and (mac '((1 ((9))) 2 ) '((9))) (mac '(((1 . 2) 3 . 4) a) 3) (mac '((( 1 2 3 4) 5) 6 7 8 9) 5) (mac '(( 1 a) (2 b) (3 c)) 'a) (mac '(( ((a)) (( b))) ((c)) d) '(( b))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 'bar) (mac '(((((((((( t )))))))) tilt)) 'tilt ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "vacations") (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) "with temperatures usually in the " ) )) ) (do-test "test cadar1" (progn (setq a (list (list* #'null #'list-length #'min #'evenp #'identity))) (equal (mapcar (cadar a) (mapcar #'cadar '( ((a (((b))) )) ((1 nil) 3 4) ((#\a (#\b #\c)) ((#\d) #\e #\f)) ) )) '(1 0 2 )) ) ) (do-test "test cadar2" (let ((aa '((1 ((3 ((5 ((7 ((9 ((11 (13 14) )) )) )) )) )) )) )) (and (equal (cadar aa) '((3 ((5 ((7 ((9 ((11 (13 14) )) )) )) )) )) ) (equal (cadar (cadar aa)) '((5 ((7 ((9 ((11 (13 14) )) )) )) )) ) (equal (cadar (cadar (cadar aa))) '((7 ((9 ((11 (13 14) )) )) )) ) (equal (cadar (cadar (cadar (cadar aa)))) '((9 ((11 (13 14) )) )) ) (equal (cadar (cadar (cadar (cadar (cadar aa))))) '((11 (13 14) )) ) (equal (cadar (cadar (cadar (cadar (cadar (cadar aa)))))) '(13 14) ) ) ) ) (do-test "test cadar3" (progn (setq aa '((a b) c d )) (and (setf (cadar aa) '(( #\g #\r #\i #\n)) ) (equal aa `(( a (( #\g #\r #\i #\n)) ) c d )) (setf (cadar (cadar aa)) '((3 6) 9)) (equal aa `(( a (( #\g ((3 6) 9) #\i #\n)) ) c d )) (setf (cadar (cadar (cadar aa))) "magic kingdom") (equal aa `(( a (( #\g ((3 "magic kingdom") 9) #\i #\n)) ) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDAR.TEST new file mode 100644 index 00000000..84eb1ed0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CADDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 16 ,1986 ;; ;; Last Update: July 16 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-caddar.test ;; ;; ;; Syntax: CADDAR LIST ;; ;; Function Description: CADDAR is equivalent to (CAR (CDR (CDR (CAR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (caddar list) ,elm)) ((or cons string) (equal (caddar list) ,elm)) (t (eq (caddar list) ,elm)) ) ) (do-test "test caddar0" (prog1 (and (mac '((1 ((9)) "hi") 2 ) "hi") (mac '(((1 . 2) 3 (4 . 4)) a) '(4 . 4)) (mac '((( 1 2 3 4) 5 6 7) 8 9) 6) (mac '(( 1 a (((w)))) (2 b) (3 c)) '(((w)))) (mac '(( ((a)) (( b)) (ab ba aa .bb)) ((c)) d) '(ab ba aa .bb)) (mac '((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) "(foo1 . bar1)") (mac '(((((((((( t )))))))) t1 t2)) 't2 ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "to") (mac '((#\F #\o ((foo3)) )"o1" "foo2" (foo4 . foo5)) '((foo3)) ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) 'fifties ) )) ) (do-test "test caddar1" (progn (setq a (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity))) (equal (mapcar (caddar a) (mapcar #'caddar '( ((a (((b))) (3 -3) )) ((1 nil (3 4))) ((#\a (#\b #\c) (2.0 2.01))) ))) '(-3 3 2.0 )) ) ) (do-test "test caddar2" (let ((aa '((1 2 ((3 4 ((5 6 ((7 8 ((9 10 ((11 12 (13 14) )) )) )) )) )) )) )) (and (equal (caddar aa) '((3 4 ((5 6 ((7 8 ((9 10 ((11 12 (13 14) )) )) )) )) )) ) (equal (caddar (caddar aa)) '((5 6 ((7 8 ((9 10 ((11 12 (13 14) )) )) )) )) ) (equal (caddar (caddar (caddar aa))) '((7 8 ((9 10 ((11 12 (13 14) )) )) )) ) (equal (caddar (caddar (caddar (caddar aa)))) '((9 10 ((11 12 (13 14) )) )) ) (equal (caddar (caddar (caddar (caddar (caddar aa))))) '((11 12 (13 14) )) ) (equal (caddar (caddar (caddar (caddar (caddar (caddar aa)))))) '(13 14) ) ) ) ) (do-test "test caddar3" (progn (setq aa '((a ab b) c d )) (and (setf (caddar aa) '(( #\g #\r #\i #\n)) ) (equal aa `(( a ab (( #\g #\r #\i #\n)) ) c d )) (setf (caddar (caddar aa)) '((3 6 8) 9)) (equal aa `(( a ab (( #\g #\r ((3 6 8) 9) #\n)) ) c d )) (setf (caddar (caddar (caddar aa))) "magic kingdom") (equal aa `(( a ab (( #\g #\r ((3 6 "magic kingdom") 9) #\n)) ) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDDR-AND-FOURTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDDR-AND-FOURTH.TEST new file mode 100644 index 00000000..28e2c183 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDDR-AND-FOURTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cadddr-and-fourth ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 263 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 2, 1986 ;; ;; Last Update: July 2, 1986 ;; Oct 9, 1986 sye/ change ((1 . 2) . 3) to ((1 . 2 )) in "test fourth1" ;; ;; Filed As: {eris}cml>test>15-1-cadddr-and-fourth.test ;; ;; ;; Syntax: CADDDR list ;; FOURTH list ;; ;; Function Description: CADDDR & FOURTH both return the fourth element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the fourth element of list ;; nil - if list is () ;; (do-test "test cadddr0" (and (eq (cadddr ()) ()) (eq (cadddr '(1)) ()) (eq (cadddr '(a b)) ()) (eq (cadddr '(a b c)) ()) (eq (cadddr '(1 2 3 4)) 4) (equal (cadddr '((1) (2) (3) (4 5 6 . 7))) '(4 5 6 . 7)) (equal (cadddr '("sunday" nil nil "monday" nil nil)) "monday") (= (cadddr (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) 8) (eq (cadddr '(|****| |%%%%| |????| |####| |^^^^^|)) '|####|) (equal (cadddr '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '((a . b) (c d e (f . g)))) ) ) (defun fun (list elm) (typecase elm (number (= (cadddr list) elm)) ((or cons string) (equal (cadddr list) elm)) (t (eq (cadddr list) elm)) ) ) (do-test "test cadddr1" (prog1 (and (fun '(array (fixnum) "package" simple-vector 'cute-t) 'simple-vector) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) 1) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '(decf 1100)) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom)) (mapcar (cadddr a) '(4 5 6 7))) t) (fun (cadddr (cadddr '(1 2 3 (10 20 30 (100 200 300 (1000 2000 3000 4000) 400) 40) 4))) '(1000 2000 3000 4000)) ) ) ) (do-test "test cadddr2" (progn (setq a '(aa bb cc dd ee ff)) (setf (cadddr a) '(1 2 3 4 5)) (setf (cadddr (cadddr a)) '(44 33 22 11)) (equal a '(aa bb cc (1 2 3 (44 33 22 11) 5) ee ff)))) ;; ;; fourth should behave like cadddr ;; (do-test "test fourth0" (and (eq (fourth ()) ()) (eq (fourth '(1)) ()) (eq (fourth '(a b)) ()) (eq (fourth '(a b c)) ()) (eq (fourth '(1 2 3 4)) 4) (equal (fourth '((1) (2) (3) (4 5 6 . 7))) '(4 5 6 . 7)) (equal (fourth '("sunday" nil nil "monday" nil nil)) "monday") (= (fourth (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) 8) (eq (fourth '(|****| |%%%%| |????| |####| |^^^^^|)) '|####|) (equal (fourth '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '((a . b) (c d e (f . g)))) ) ) (defun fun (list elm) (typecase elm (number (= (fourth list) elm)) ((or cons string) (equal (fourth list) elm)) (t (eq (fourth list) elm)) ) ) (do-test "test fourth1" (prog1 (and (fun '(array (fixnum) "package" simple-vector 'cute-t) 'simple-vector) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) 1) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '(decf 1100)) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom)) (mapcar (fourth a) '(4 5 6 7))) t) (fun (fourth (fourth '(1 2 3 (10 20 30 (100 200 300 (1000 2000 3000 4000) 400) 40) 4))) '(1000 2000 3000 4000)) ) ) ) (do-test "test fourth2" (progn (setq a '(aa bb cc dd ee ff)) (setf (fourth a) '(1 2 3 4 5)) (setf (fourth (fourth a)) '(44 33 22 11)) (equal a '(aa bb cc (1 2 3 (44 33 22 11) 5) ee ff)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDR-AND-THIRD.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDR-AND-THIRD.TEST new file mode 100644 index 00000000..1916213f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDR-AND-THIRD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: caddr-and-third ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 263 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 2, 1986 ;; ;; Last Update: July 2, 1986 ;; ;; Filed As: {eris}cml>test>15-1-caddr-and-third.test ;; ;; ;; Syntax: CADDR list ;; THIRD list ;; ;; Function Description: CADDR & THIRD both return the third element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the third element of list ;; nil - if list is () ;; (do-test "test caddr0" (and (eq (caddr '()) ()) (eq (caddr '(1)) ()) (eq (caddr '(1 2)) ()) (eq (caddr '(1 2 3)) 3) (equal (caddr '((1 2) 3 (4 . 5))) '(4 . 5)) (equal (caddr '(#\a #\b #\c #\d #\f)) #\c) (equal (caddr '((1) ((2)) ((("s"))) ((((w)))) )) '((("s")))) )) (defun fun (list elm) (typecase elm (number (= (caddr list) elm)) ((or cons string) (equal (caddr list) elm)) (t (eq (caddr list) elm)) ) ) (do-test "test caddr1" (prog1 (and (fun '("first" "second" "third" "forth") "third") (fun '(a b ((c . d) . e)) '((c . d) . e)) (fun '((item1 10) (item2 20) (item3 30) (item4 40)) '(item3 30)) (fun `('a "b" 100.009 (1+ 9)) (+ 100 .009)) (fun (let (a i) (dotimes (i 100 (reverse a)) (push i a))) 2) (fun (list (code-char #16r41) (code-char #16r42) (code-char #16r43) (code-char #16r44)) #\C)) ) ) ;; ;; third should behave like caddr ;; (do-test "test third0" (and (eq (third '()) ()) (eq (third '(1)) ()) (eq (third '(1 2)) ()) (eq (third '(1 2 3)) 3) (equal (third '((1 2) 3 (4 . 5))) '(4 . 5)) (equal (third '(#\a #\b #\c #\d #\f)) #\c) (equal (third '((1) ((2)) ((("s"))) ((((w)))) )) '((("s")))) )) (defun fun (list elm) (typecase elm (number (= (third list) elm)) ((or cons string) (equal (third list) elm)) (t (eq (third list) elm)) ) ) (do-test "test third1" (prog1 (and (fun '("first" "second" "third" "forth") "third") (fun '(a b ((c . d) . e)) '((c . d) . e)) (fun '((item1 10) (item2 20) (item3 30) (item4 40)) '(item3 30)) (fun `('a "b" 100.009 (1+ 9)) (+ 100 .009)) (fun (let (a i) (dotimes (i 100 (reverse a)) (push i a))) 2) (fun (list (code-char #16r41) (code-char #16r42) (code-char #16r43) (code-char #16r44)) #\C)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADR-AND-SECOND.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADR-AND-SECOND.TEST new file mode 100644 index 00000000..ad41c510 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADR-AND-SECOND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cadr-and-second ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 263 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 2, 1986 ;; ;; Last Update: July 2, 1986 ;; ;; Filed As: {eris}cml>test>15-1-cadr-and-second.test ;; ;; ;; Syntax: CADR list ;; SECOND list ;; ;; Function Description: CADR & SECOND both return the second element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the second element of list ;; nil - if list is () ;; (do-test "test cadr0" (and (eq (cadr '()) ()) (eq (cadr '(1)) ()) (eq (cadr '(1 a)) 'a) (= (cadr '(a 100)) 100) (equal (cadr '(1 (2 3))) '(2 3)) (equal (cadr '( 3 ( 1 . 2))) '(1 . 2)) (char= (cadr '(#\a #\b)) #\b) (equal (cadr '(10 ((((( 20)))) 50))) '(((((20))))50)) )) (defun fun (list elm) (typecase elm (number (= (cadr list) elm)) ((or cons string) (equal (cadr list) elm)) (t (eq (cadr list) elm)) ) ) (do-test "test cadr1" (prog1 (and (fun '(1 2 3 4 5 6 7 8) 2) (fun '((propery . 10) (item . 100)) '(item . 100)) (fun '( (((((1 2))))) ((((((((((10)))))))))) ) '((((((((((10)))))))))) ) (fun '("first" "second" "third" "forth") "second") (fun '(#\a (#\b #\c) #\d #\e) '(#\b #\c) ) (progn (setq a nil) (dotimes (i 10 t) (push i a))) (fun a 8) (fun '(((2 3) (4 5)) ((20 30) (40 50)) 100) '((20 30) (40 50))) ) ) ) ;; ;; second should behave the same as cadr ;; (do-test "test second0" (and (eq (second '()) ()) (eq (second '(1)) ()) (eq (second '(1 a)) 'a) (= (second '(a 100)) 100) (equal (second '(1 (2 3))) '(2 3)) (equal (second '( 3 ( 1 . 2))) '(1 . 2)) (char= (second '(#\a #\b)) #\b) (equal (second '(10 ((((( 20)))) 50))) '(((((20))))50)) )) (defun fun (list elm) (typecase elm (number (= (second list) elm)) ((or cons string) (equal (second list) elm)) (t (eq (second list) elm)) ) ) (do-test "test second1" (prog2 (and (fun '(1 2 3 4 5 6 7 8) 2) (fun '((propery . 10) (item . 100)) '(item . 100)) (fun '( (((((1 2))))) ((((((((((10)))))))))) ) '((((((((((10)))))))))) ) (fun '("first" "second" "third" "forth") "second") (fun '(#\a (#\b #\c) #\d #\e) '(#\b #\c) ) (progn (setq a nil) (dotimes (i 10 t) (push i a))) (fun a 8) (fun '(((2 3) (4 5)) ((20 30) (40 50)) 100) '((20 30) (40 50))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAR-AND-FIRST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAR-AND-FIRST.TEST new file mode 100644 index 00000000..1b674a6e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAR-AND-FIRST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: car-and-first ;; ;; Source: Steele's book Section : 15.1 & 15.2 Page: 262 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 13,1986 ;; ;; Last Update: June 17,1986 Sye/ add "test car4" and "test first4" ;; ;; Filed As: {eris}cml>test>15-1-car-and-first.test ;; ;; ;; Syntax: CAR list ;; FIRST list ;; ;; Function Description: CAR & FIRST both return the first element of list ;; ;; Argument(s): list - a cons or () ;; ;; Returns: the first element of list ;; nil - if list is () ;; (do-test "test car1 - argument is ()" (eq (car ()) ())) (do-test "test car2 - argument is a true list" (and (eq (car '(a b c)) 'a) (eq (car (make-list 4 :initial-element 'rah)) 'rah) (eq (car (list 1 2 3 4)) 1) (equal (car (car (car (car (car '((((((3 4))))) 2 1)))))) (car '((3 4)))) (eq (car (multiple-value-list (values #\1 #\2 #\3))) #\1) ; create a proper list (progn (setq aa 10) (setf (symbol-plist 'aa) nil) (setf (get 'aa 'value) 100)) (eq (car (symbol-plist 'aa)) 'value) ; (equal (car '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))) '(a b c d (e f (g h i j)) (k l m))) ; ; push a function def to a variable (progn (setq a ()) (push (function +) a)) (= (funcall (car a) 1 2 3 4 5) (/ (* 5 6) 2)))) (do-test "test car3 - argument is a dotted list" (and (eq (car '(1 . 2)) 1) (equal (car '((a 1 2 3 9 8 7 . b) c d e f)) '(a 1 2 3 9 8 7 . b)) (eq (car (cons nil 100)) nil) (eq (car (car (list (cons 5 6)))) 5))) (do-test "test car4 - the car of a cons may be altered by using rplaca or setf" (let ((a (list 11 22 33 44))) (and (eq (car a) 11) (setf (car a) 1111) (eq (car a) 1111) (setf (car (cddr a)) 3333) (eq (car (cddr a)) 3333) (rplaca a '(8 9)) (equal (car a) '(8 9)) (equal a '((8 9) 22 3333 44))))) ; ; Function "first" should behave the same as "car" ; The following test cases are the duplicates of the above ones, except the function "car" was replaced by "first" ; (do-test "test first1 - argument is ()" (eq (first ()) ())) (do-test "test first2 - argument is a true list" (and (eq (first '(a b c)) 'a) (eq (first (make-list 4 :initial-element 'rah)) 'rah) (eq (first (list 1 2 3 4)) 1) (equal (first (first (first (first (first '((((((3 4))))) 2 1)))))) (first '((3 4)))) (eq (first (multiple-value-list (values #\1 #\2 #\3))) #\1) ; create a proper list (progn (setq aa 10) (setf (get 'aa 'value) 100)) (eq (first (symbol-plist 'aa)) 'value) ; (equal (first '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))) '(a b c d (e f (g h i j)) (k l m))) ; ; push a function def to a variable (progn (setq a ()) (push (function +) a)) (= (funcall (first a) 1 2 3 4 5) (/ (* 5 6) 2)))) (do-test "test first3 - argument is a dotted list" (and (eq (first '(1 . 2)) 1) (equal (first '((a 1 2 3 9 8 7 . b) c d e f)) '(a 1 2 3 9 8 7 . b)) (eq (first (cons nil 100)) nil) (eq (first (first (list (cons 5 6)))) 5))) (do-test "test first4 - the first of a cons may be altered by using rplaca or setf" (let ((a (list 11 22 33 44))) (and (eq (first a) 11) (setf (first a) 1111) (eq (first a) 1111) (setf (first (cddr a)) 3333) (eq (first (cddr a)) 3333) (rplaca a '(8 9)) (equal (first a) '(8 9)) (equal a '((8 9) 22 3333 44))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAAR.TEST new file mode 100644 index 00000000..46157704 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDAAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 15 ,1986 ;; ;; Last Update: July 15 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdaaar.test ;; ;; ;; Syntax: CDAAAR LIST ;; ;; Function Description: (CDAAAR LIST) is equivalent to (CDR (CAR (CAR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaaar list) ,elm)) ((or cons string) (equal (cdaaar list) ,elm)) (t (eq (cdaaar list) ,elm)) ) ) (do-test "test cdaaar0" (prog1 (and (mac '((((1)) 2 )) ()) (mac '((((1) . 2) 3 . 4) a) ()) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) '(3)) (mac '(( (((1 . 100) a))) (2 b) (3 c)) '(a)) (mac '((( ((#\a) #\b #\c) (( b))) ((c)) d)) '(#\b #\c)) (mac '((( ((foo1) foo2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(foo2) ) (mac '(((((((((( t )))))))))) '() ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("vacations")) (mac '((((#\F (bar1 . bar2)) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '((bar1 . bar2)) ) (mac '((((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) 'non-nil ) )) ) (do-test "test cdaaar1" (progn (setq a (list (list (list (list #'null #'identity))) (list #'list ) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaaar a)) (mapcar #'cdaaar '( ((((8)))) ((((9 99 999)(1 2) 3 ) 4)) ((((#\a #\b . #\c))) ((#\d) #\e #\f)) ) )) '( nil (99 999) (#\b . #\c))) ) ) (do-test "test cdaaar2" (prog2 (setq aa '((((1 (((2 (((3 ((( 4 5 6 7 . 8))) ))) ))) )))) ) (and (equal (cdaaar aa) '(((( 2 ((( 3 ((( 4 5 6 7 . 8))) ))) )))) ) (equal (cdaaar (cdaaar aa)) '(((( 3 ((( 4 5 6 7 . 8))) )))) ) (equal (cdaaar (cdaaar (cdaaar aa))) '(((( 4 5 6 7 . 8)))) ) (equal (cdaaar (cdaaar (cdaaar (cdaaar aa)))) '(5 6 7 . 8)) ) ) ) (do-test "test cdaaar3" (progn (setq aa '((((a b))) c)) (setf (cdaaar aa) '(((( c d e)))) ) (setf (cdaaar (cdaaar aa)) '(((( f g h)))) ) (setf (cdaaar (cdaaar (cdaaar aa))) '(((( i j k)))) ) (equal aa '(((( a ((( c ((( f ((( i j k))) ))) ))) ))) c) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAADR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAADR.TEST new file mode 100644 index 00000000..73e6ae4e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDAADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Update: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdaadr.test ;; ;; ;; Syntax: CDAADR LIST ;; ;; Function Description: (CDAADR LIST) is equivalent to (CDR (CAR (CAR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaadr list) ,elm)) ((or cons string) (equal (cdaadr list) ,elm)) (t (eq (cdaadr list) ,elm)) ) ) (do-test "test cdaadr0" (prog1 (and (mac '(12 (((1)) 2 )) ()) (mac '(34 (((1) . 2) 3 . 4) a) 2) (mac '((8) (((( 1 2) 3) 4) 5) 6 7 8 9) '(4)) (mac '((z 0) ( (((1 . 100) a))) (2 b) (3 c)) '()) (mac '(#\q (( ((#\a) #\b #\c) (( b))) ((c)) d)) '((( b)))) (mac '(bar66 (( ((foo1) foo2) . 99)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 99 ) (mac '((1 . 2) ((((((((( t )))))))))) '() ) (mac '("confusion" ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to")) (mac '(#\! (((#\F (bar1 . bar2)) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '(#\o) ) (mac '(#\? (((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(("is usually clear and sunny")) ) )) ) (do-test "test cdaadr1" (progn (setq a (list #'cddddr (list (list #'null #'identity)) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaadr a)) (mapcar #'cdaadr '( (80 (((8) 88))) (432 (((9 99 999)(1 2) 3 ) 4)) ((nil nil) (((#\a #\b . #\c))) ((#\d) #\e #\f)) ) )) '( (88) ((1 2) 3 ) nil)) ) ) (do-test "test cdaadr2" (prog2 (setq aa '(0.00 ((1 2.333 ((2 3.444 ((3 4.567 (( 4 5 6 7 . 8)) )) )) ))) ) (and (equal (cdaadr aa) '(2.333 (( 2 3.444 (( 3 4.567 (( 4 5 6 7 . 8)) )) ))) ) (equal (cdaadr (cdaadr aa)) '(3.444 (( 3 4.567 (( 4 5 6 7 . 8)) ))) ) (equal (cdaadr (cdaadr (cdaadr aa))) '(4.567 (( 4 5 6 7 . 8))) ) (equal (cdaadr (cdaadr (cdaadr (cdaadr aa)))) '(5 6 7 . 8)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAR.TEST new file mode 100644 index 00000000..6afd886e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 15 ,1986 ;; ;; Last Update: July 15 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdaar.test ;; ;; ;; Syntax: CDAAR LIST ;; ;; Function Description: (CDAAR LIST) is equivalent to (CDR (CAR (CAR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaar list) ,elm)) ((or cons string) (equal (cdaar list) ,elm)) (t (eq (cdaar list) ,elm)) ) ) (do-test "test cdaar0" (prog1 (and (mac '((((1)) 2 )) ()) (mac '((((1) . 2) 3 . 4) a) 2) (mac '((((( 1 2) 3) 4) 5) 6 7 8 9) '(4)) (mac '(( (((1 . 100) a))) (2 b) (3 c)) '()) (mac '((( ((#\a) #\b #\c) (( b))) ((c)) d)) '((( b)))) (mac '((( ((foo1) foo2) . 99)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 99 ) (mac '(((((((((( t )))))))))) '() ) (mac '( ((("excitint" "vacations") "to") |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to")) (mac '((((#\F (bar1 . bar2)) #\o) "o1") "foo2" ((foo3)) (foo4 . foo5)) '(#\o) ) (mac '((((("the weather in January") . non-nil) ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(("is usually clear and sunny")) ) )) ) (do-test "test cdaar1" (progn (setq a (list (list (list #'null #'identity)) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaar a)) (mapcar #'cdaar '( ((((8) 88))) ((((9 99 999)(1 2) 3 ) 4)) ((((#\a #\b . #\c))) ((#\d) #\e #\f)) ) )) '( (88) ((1 2) 3 ) nil)) ) ) (do-test "test cdaar2" (prog2 (setq aa '(((1 ((2 ((3 (( 4 5 6 7 . 8)) )) )) ))) ) (and (equal (cdaar aa) '((( 2 (( 3 (( 4 5 6 7 . 8)) )) ))) ) (equal (cdaar (cdaar aa)) '((( 3 (( 4 5 6 7 . 8)) ))) ) (equal (cdaar (cdaar (cdaar aa))) '((( 4 5 6 7 . 8))) ) (equal (cdaar (cdaar (cdaar (cdaar aa)))) '(5 6 7 . 8)) ) ) ) (do-test "test cdaar3" (progn (setq aa '(((a b)) c)) (setf (cdaar aa) '((( c d e))) ) (setf (cdaar (cdaar aa)) '((( f g h))) ) (setf (cdaar (cdaar (cdaar aa))) '((( i j k))) ) (equal aa '((( a (( c (( f (( i j k)) )) )) )) c) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADAR.TEST new file mode 100644 index 00000000..dc25210d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDADAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 22 ,1986 ;; ;; Last Updadate: July 22 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdadar.test ;; ;; ;; Syntax: CDADAR LIST ;; ;; Function Description: (CDADAR LIST) is equivalent to (CDR (CAR (CDR (CAR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdadar list) ,elm)) ((or cons string) (equal (cdadar list) ,elm)) (t (eq (cdadar list) ,elm)) ) ) (do-test "test cdadar0" (prog1 (and (mac '((30 (1)) 2 ) ()) (mac '((((u)) ((1 . 2) 3 . 4)) a) '(3 . 4)) (mac '((10 (( 1 2 3 4) 5) 6) 7 8 9) '(5)) (mac '(((0 z) ( 1 a) (2 b)) (3 c)) '(a)) (mac '(("e" ( ((a)) (( b))) ((c)) d)) '((( b)))) (mac '(('foo0 (foo bar) (foo1 . bar1)) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '((nil ((((((((( t ))))))))))) () ) (mac '( ("china" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient)))) '("vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\% (#\F) #\o) "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '(("bomb" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties)) (in the daday time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdadar1" (progn (setq a (list (list #'stringp (list #'null #'identity)) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdadar a)) (mapcar #'cdadar '( ((5 ())) (("hi" (1 2) 3) 4) ((#\@ (#\a #\b #\c)) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdadar2" (let ((aa '((0 (1 (2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (12 (13 14)))))))))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdadar aa) '((2 (3 (4 (5 (6 (7 (8 (9 (10 (11 (12 (13 14)))))))))))))) (equal (cdadar (cdadar aa)) '(( 4 (5 (6 (7 (8 (9 (10 (11 (12 (13 14))))))))) ))) (equal (cdadar (cdadar (cdadar aa))) '((6 (7 (8 (9 (10 (11 (12 (13 14)))))))))) (equal (cdadar (cdadar (cdadar (cdadar aa)))) '((8 (9 (10 (11 (12 (13 14)))))))) (equal (cdadar (cdadar (cdadar (cdadar (cdadar aa))))) '((10 (11 (12 (13 14)))))) (equal (cdadar (cdadar (cdadar (cdadar (cdadar (cdadar aa)))))) '((12 (13 14)))) (equal (cdadar (cdadar (cdadar (cdadar (cdadar (cdadar (cdadar aa))))))) '(14)) ) ) ) (do-test "test cdadar3" (progn (setq aa '((Q (a b) c) d )) (and (setf (cdadar aa) '((8 (88 99 77))) ) (equal aa `((Q ( a (8 (88 99 77)) ) c) d )) (setf (cdadar (cdadar aa)) '((9 (3 6)) 9)) (equal aa `((Q ( a (8 (88 (9 (3 6)) 9)) ) c) d )) (setf (cdadar (cdadar (cdadar aa))) "magic kingdom") (equal aa `((Q ( a (8 (88 (9 (3 . "magic kingdom")) 9)) ) c) d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADDR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADDR.TEST new file mode 100644 index 00000000..9e090923 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDADDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Updaddte: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdaddr.test ;; ;; ;; Syntax: CDADDR LIST ;; ;; Function Description: (CDADDR LIST) is equivalent to (CDR (CAR (CDR (CDR LIST)))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdaddr list) ,elm)) ((or cons string) (equal (cdaddr list) ,elm)) (t (eq (cdaddr list) ,elm)) ) ) (do-test "test cdaddr0" (prog1 (and (mac '(333 30 (1) 2 ) ()) (mac '((w) ((u)) ((1 . 2) 3 . 4) a) '(3 . 4)) (mac '(-10.0 10 (( 1 2 3 4) 5) 6 7 8 9) '(5)) (mac '((-1 y) (0 z) ( 1 a) (2 b) (3 c)) '(a)) (mac '("ha!" "e" ( ((a)) (( b))) ((c)) d) '((( b)))) (mac '("so what ?" 'foo0 (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '(toe nil ((((((((( t )))))))))) () ) (mac '("fret" "china" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '( "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '("trill" #\% (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '(guitar "bomb" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the daddy time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdaddr1" (progn (setq a (list #'string-upcase #'stringp (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdaddr a)) (mapcar #'cdaddr '( (five 5 ()) ("fin" "hi" (1 2) 3 4) ((#\<) #\@ (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdaddr2" (let ((aa '(0 01 (1 2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdaddr aa) '(2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14)))))))) (equal (cdaddr (cdaddr aa)) '( 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14))))) )) (equal (cdaddr (cdaddr (cdaddr aa))) '(6 67 (7 8 89 (9 10 101 (11 12 123 (13 14)))))) (equal (cdaddr (cdaddr (cdaddr (cdaddr aa)))) '(8 89 (9 10 101 (11 12 123 (13 14))))) (equal (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr aa))))) ' (10 101 (11 12 123 (13 14)))) (equal (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr aa)))))) '(12 123 (13 14))) (equal (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr (cdaddr aa))))))) '(14)) ) ) ) (do-test "test cdaddr3" (progn (setq aa '(Q p (a b) c d )) (and (setf (cdaddr aa) '(8 08 (88 99 77)) ) (equal aa `(Q p ( a 8 08 (88 99 77) ) c d )) (setf (cdaddr (cdaddr aa)) '(9 90 (3 6) 9)) (equal aa `(Q p ( a 8 08 (88 9 90 (3 6) 9) ) c d )) (setf (cdaddr (cdaddr (cdaddr aa))) "magic kingdom") (equal aa `(Q p ( a 8 08 (88 9 90 (3 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADR.TEST new file mode 100644 index 00000000..7dd21de2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 18 ,1986 ;; ;; Last Updadte: July 18 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdadr.test ;; ;; ;; Syntax: CDADR LIST ;; ;; Function Description: (CDADR LIST) is equivalent to (CDR (CAR (CDR LIST))) ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdadr list) ,elm)) ((or cons string) (equal (cdadr list) ,elm)) (t (eq (cdadr list) ,elm)) ) ) (do-test "test cdadr0" (prog1 (and (mac '(30 (1) 2 ) ()) (mac '(((u)) ((1 . 2) 3 . 4) a) '(3 . 4)) (mac '(10 (( 1 2 3 4) 5) 6 7 8 9) '(5)) (mac '((0 z) ( 1 a) (2 b) (3 c)) '(a)) (mac '("e" ( ((a)) (( b))) ((c)) d) '((( b)))) (mac '('foo0 (foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '(nil ((((((((( t )))))))))) () ) (mac '( "china" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '(#\% (#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '("bomb" (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the dady time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdadr1" (progn (setq a (list #'stringp (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdadr a)) (mapcar #'cdadr '( (5 ()) ("hi" (1 2) 3 4) (#\@ (#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdadr2" (let ((aa '(0 (1 2 (3 4 (5 6 (7 8 (9 10 (11 12 (13 14))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdadr aa) '(2 (3 4 (5 6 (7 8 (9 10 (11 12 (13 14)))))))) (equal (cdadr (cdadr aa)) '( 4 (5 6 (7 8 (9 10 (11 12 (13 14))))) )) (equal (cdadr (cdadr (cdadr aa))) '(6 (7 8 (9 10 (11 12 (13 14)))))) (equal (cdadr (cdadr (cdadr (cdadr aa)))) '(8 (9 10 (11 12 (13 14))))) (equal (cdadr (cdadr (cdadr (cdadr (cdadr aa))))) '(10 (11 12 (13 14)))) (equal (cdadr (cdadr (cdadr (cdadr (cdadr (cdadr aa)))))) '(12 (13 14))) (equal (cdadr (cdadr (cdadr (cdadr (cdadr (cdadr (cdadr aa))))))) '(14)) ) ) ) (do-test "test cdadr3" (progn (setq aa '(Q (a b) c d )) (and (setf (cdadr aa) '(8 (88 99 77)) ) (equal aa `(Q ( a 8 (88 99 77) ) c d )) (setf (cdadr (cdadr aa)) '(9 (3 6) 9)) (equal aa `(Q ( a 8 (88 9 (3 6) 9) ) c d )) (setf (cdadr (cdadr (cdadr aa))) "magic kingdom") (equal aa `(Q ( a 8 (88 9 (3 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAR.TEST new file mode 100644 index 00000000..0274dc45 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 8 ,1986 ;; ;; Last Update: July 8 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdar.test ;; ;; ;; Syntax: CDAR LIST ;; ;; Function Description: If the first element of LIST is a list, CAAR returns the second element of the sublist. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdar list) ,elm)) ((or cons string) (equal (cdar list) ,elm)) (t (eq (cdar list) ,elm)) ) ) (do-test "test cdar0" (prog1 (and (mac '((1) 2 ) ()) (mac '(((1 . 2) 3 . 4) a) '(3 . 4)) (mac '((( 1 2 3 4) 5) 6 7 8 9) '(5)) (mac '(( 1 a) (2 b) (3 c)) '(a)) (mac '(( ((a)) (( b))) ((c)) d) '((( b)))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(bar)) (mac '(((((((((( t )))))))))) () ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) () ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '("with temperatures usually in the " fifties) ) )) ) (do-test "test cdar1" (progn (setq a (list (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (* 100 x)))) (equal (mapcar (car (cdar a)) (mapcar #'cdar '( (()) ((1 2) 3 4) ((#\a #\b #\c) ((#\d) #\e #\f)) ) )) '(() (2) (#\b #\c) )) ) ) (do-test "test cdar2" (let ((aa '((1 (3 (5 (7 (9 (11 (13 14))))))) ((((((1 2) 3 4) 5 6) 7 8) 9 10) 11 12) ) )) (and (equal (cdar aa) '((3 (5 (7 (9 (11 (13 14)))))))) (equal (cdar (cdar aa)) '( (5 (7 (9 (11 (13 14))))) )) (equal (cdar (cdar (cdar aa))) '((7 (9 (11 (13 14)))))) (equal (cdar (cdar (cdar (cdar aa)))) '((9 (11 (13 14))))) (equal (cdar (cdar (cdar (cdar (cdar aa))))) '((11 (13 14)))) (equal (cdar (cdar (cdar (cdar (cdar (cdar aa)))))) '((13 14))) (equal (cdar (cdar (cdar (cdar (cdar (cdar (cdar aa))))))) '(14)) ) ) ) (do-test "test cdar3" (progn (setq aa '((a b) c d )) (and (setf (cdar aa) (make-list 2 :initial-element '(2 4))) (equal aa `(( a (2 4) (2 4)) c d )) (setf (cdar (cdar aa)) '((3 6) 9)) (equal aa `(( a (2 (3 6) 9) (2 (3 6) 9)) c d )) (setf (cdar (cdar (cdar aa))) "magic kingdom") (equal aa `(( a (2 (3 . "magic kingdom") 9) (2 (3 . "magic kingdom") 9)) c d )) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAAR.TEST new file mode 100644 index 00000000..af6b10b6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDAAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 22 ,1986 ;; ;; Last Update: July 22 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddaar.test ;; ;; ;; Syntax: CDDAAR LIST ;; ;; Function Description: CDDAAR is equivalent to (CDR (CDR (CAR (CAR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddaar list) ,elm)) ((or cons string) (equal (cddaar list) ,elm)) (t (eq (cddaar list) ,elm)) ) ) (do-test "test cddaar0" (prog1 (and (mac '(((1 ((9)) "hi") 2 )) '("hi")) (mac '((((1 . 2) 3 (4 . 4) 6 7) a)) '((4 . 4) 6 7)) (mac '(((( 1 2 3 4) 5 6 7)) 8 9) '(6 7)) (mac '((( 1 a (((w)))) (2 b)) (3 c)) '((((w))))) (mac '((( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c))) d) '((ab ba aa .bb) #\a #\b . #\c)) (mac '(((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2))) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '("(foo1 . bar1)" . 999)) (mac '((((((((((( t )))))))) t1 t2))) '(t2) ) (mac '( (("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient)))) '("to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '(((#\F #\o ((foo3)) )"o1" "foo2") (foo4 . foo5)) '(((foo3))) ) (mac '(((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties)) (in the day time) (and ) (the "20's" at night)) '(fifties) ) )) ) (do-test "test cddaar1" (progn (setq a (list (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity)))) (equal (mapcar (first (cddaar a)) (mapcar #'cddaar '( (((a (((b))) 3 -3 ))) (((1 nil 3 4))) (((#\a (#\b #\c) 2.0 2.01))) ))) '(-3 3 2.0 )) ) ) (do-test "test cddaar2" (let ((aa '(((1 2 ((3 4 ((5 6 ((7 8 ((9 10 ((11 12 ((13 14)) ) ) )) )) ))) ))) ))) (and (equal (cddaar aa) '(((3 4 ((5 6 ((7 8 ((9 10 ((11 12 ((13 14)) ) )) )) ))) ))) ) (equal (cddaar (cddaar aa)) '(((5 6 ((7 8 ((9 10 ((11 12 ((13 14)) ) )) ))) ))) ) (equal (cddaar (cddaar (cddaar aa))) '(((7 8 ((9 10 ((11 12 ((13 14)) )) )) ))) ) (equal (cddaar (cddaar (cddaar (cddaar aa)))) '(((9 10 ((11 12 ((13 14)) )) ))) ) (equal (cddaar (cddaar (cddaar (cddaar (cddaar aa))))) '(((11 12 ((13 14)) ))) ) (equal (cddaar (cddaar (cddaar (cddaar (cddaar (cddaar aa)))))) '(((13 14))) ) ) ) ) (do-test "test cddaar3" (progn (setq aa '(((a ab b) c) d )) (and (setf (cddaar aa) '((( #\g #\r #\i #\n))) ) (equal aa `((( a ab (( #\g #\r #\i #\n)) ) c) d )) (setf (cddaar (cddaar aa)) '(((3 6 8)) 9)) (equal aa `((( a ab (( #\g #\r ((3 6 8)) 9)) ) c) d )) (setf (cddaar (cddaar (cddaar aa))) "magic kingdom") (equal aa `((( a ab (( #\g #\r ((3 6 . "magic kingdom")) 9)) ) c) d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDADR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDADR.TEST new file mode 100644 index 00000000..bd2bd0d6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDADR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDADR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddadr.test ;; ;; ;; Syntax: CDDADR LIST ;; ;; Function Description: CDDADR is equivalent to (CDR (CDR (CAR (CDR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddadr list) ,elm)) ((or cons string) (equal (cddadr list) ,elm)) (t (eq (cddadr list) ,elm)) ) ) (do-test "test cddadr0" (prog1 (and (mac '(dummy (1 ((9)) "hi") 2 ) '("hi")) (mac '((99) ((1 . 2) 3 (4 . 4) 6 7) a) '((4 . 4) 6 7)) (mac '(999 (( 1 2 3 4) 5 6 7) 8 9) '(6 7)) (mac '((0 z) ( 1 a (((w)))) (2 b) (3 c)) '((((w))))) (mac '(1 ( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c)) d) '((ab ba aa .bb) #\a #\b . #\c)) (mac '((- f00 1) (foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '("(foo1 . bar1)" . 999)) (mac '(t0 ((((((((( t )))))))) t1 t2)) '(t2) ) (mac '("title:" ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((mixed) (#\F #\o ((foo3)) )"o1" "foo2" (foo4 . foo5)) '(((foo3))) ) (mac '('sentence (("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(fifties) ) )) ) (do-test "test cddadr1" (progn (setq a (list "# 1" (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity))) (equal (mapcar (first (cddadr a)) (mapcar #'cddadr '( (z (a (((b))) 3 -3 )) (0 (1 nil 3 4)) (1.999 (#\a (#\b #\c) 2.0 2.01)) ))) '(-3 3 2.0 )) ) ) (do-test "test cddadr2" (let ((aa '(0 (1 2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) ) ) ) )) )) (and (equal (cddadr aa) '(23 (3 4 45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) ) ) )) ) (equal (cddadr (cddadr aa)) '(45 (5 6 67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) ) )) ) (equal (cddadr (cddadr (cddadr aa))) '(67 (7 8 89 (9 10 101 (11 12 123 (13 14) ) ) )) ) (equal (cddadr (cddadr (cddadr (cddadr aa)))) '(89 (9 10 101 (11 12 123 (13 14) ) )) ) (equal (cddadr (cddadr (cddadr (cddadr (cddadr aa))))) '(101 (11 12 123 (13 14) )) ) (equal (cddadr (cddadr (cddadr (cddadr (cddadr (cddadr aa)))))) '(123 (13 14)) ) ) ) ) (do-test "test cddadr3" (progn (setq aa '(e (a ab b) c d )) (and (setf (cddadr aa) '(#\o ( #\g #\r #\i #\n)) ) (equal aa `(e ( a ab #\o ( #\g #\r #\i #\n) ) c d )) (setf (cddadr (cddadr aa)) '(1 (3 6 8) 9)) (equal aa `(e ( a ab #\o ( #\g #\r 1 (3 6 8) 9) ) c d )) (setf (cddadr (cddadr (cddadr aa))) "magic kingdom") (equal aa `(e ( a ab #\o ( #\g #\r 1 (3 6 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAR.TEST new file mode 100644 index 00000000..0267abde --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddar.test ;; ;; ;; Syntax: CDDAR LIST ;; ;; Function Description: CDDAR is equivalent to (CDR (CDR (CAR LIST))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddar list) ,elm)) ((or cons string) (equal (cddar list) ,elm)) (t (eq (cddar list) ,elm)) ) ) (do-test "test cddar0" (prog1 (and (mac '((1 ((9)) "hi") 2 ) '("hi")) (mac '(((1 . 2) 3 (4 . 4) 6 7) a) '((4 . 4) 6 7)) (mac '((( 1 2 3 4) 5 6 7) 8 9) '(6 7)) (mac '(( 1 a (((w)))) (2 b) (3 c)) '((((w))))) (mac '(( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c)) d) '((ab ba aa .bb) #\a #\b . #\c)) (mac '((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '("(foo1 . bar1)" . 999)) (mac '(((((((((( t )))))))) t1 t2)) '(t2) ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '("to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\F #\o ((foo3)) )"o1" "foo2" (foo4 . foo5)) '(((foo3))) ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '(fifties) ) )) ) (do-test "test cddar1" (progn (setq a (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'evenp #'identity))) (equal (mapcar (first (cddar a)) (mapcar #'cddar '( ((a (((b))) 3 -3 )) ((1 nil 3 4)) ((#\a (#\b #\c) 2.0 2.01)) ))) '(-3 3 2.0 )) ) ) (do-test "test cddar2" (let ((aa '((1 2 (3 4 (5 6 (7 8 (9 10 (11 12 (13 14) ) ) ) ) ) )) )) (and (equal (cddar aa) '((3 4 (5 6 (7 8 (9 10 (11 12 (13 14) ) ) ) ) )) ) (equal (cddar (cddar aa)) '((5 6 (7 8 (9 10 (11 12 (13 14) ) ) ) )) ) (equal (cddar (cddar (cddar aa))) '((7 8 (9 10 (11 12 (13 14) ) ) )) ) (equal (cddar (cddar (cddar (cddar aa)))) '((9 10 (11 12 (13 14) ) )) ) (equal (cddar (cddar (cddar (cddar (cddar aa))))) '((11 12 (13 14) )) ) (equal (cddar (cddar (cddar (cddar (cddar (cddar aa)))))) '((13 14)) ) ) ) ) (do-test "test cddar3" (progn (setq aa '((a ab b) c d )) (and (setf (cddar aa) '(( #\g #\r #\i #\n)) ) (equal aa `(( a ab ( #\g #\r #\i #\n) ) c d )) (setf (cddar (cddar aa)) '((3 6 8) 9)) (equal aa `(( a ab ( #\g #\r (3 6 8) 9) ) c d )) (setf (cddar (cddar (cddar aa))) "magic kingdom") (equal aa `(( a ab ( #\g #\r (3 6 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDAR.TEST new file mode 100644 index 00000000..cde4b41f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDDAR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 17 ,1986 ;; ;; Last Update: July 17 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdddar.test ;; ;; ;; Syntax: CDDDAR LIST ;; ;; Function Description: CDDDAR is equivalent to (CDR (CDR (CDR (CAR LIST)))). ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cdddar list) ,elm)) ((or cons string) (equal (cdddar list) ,elm)) (t (eq (cdddar list) ,elm)) ) ) (do-test "test cdddar0" (prog1 (and (mac '((1 ((9)) "hi") 2 ) '()) (mac '(((1 . 2) 3 (4 . 4) 6 7) a) '(6 7)) (mac '((( 1 2 3 4) 5 6 7) 8 9) '(7)) (mac '(( 1 a (((w))) #\w 100.01) (2 b) (3 c)) '(#\w 100.01)) (mac '(( ((a)) (( b)) (ab ba aa .bb) #\a #\b . #\c) ((c)) d) '( #\a #\b . #\c)) (mac '((foo bar "(foo1 . bar1)" . 999) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) 999) (mac '(((((((((( t )))))))) t1 t2 ((nil)))) '(((nil))) ) (mac '( ("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '(|HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) (mac '((#\F #\o ((foo3)) . "foo0" )"o1" "foo2" (foo4 . foo5)) "foo0" ) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) () ) )) ) (do-test "test cdddar1" (progn (setq a (list (list* #'null #'list-length #'(lambda (x) (min (car x) (cadr x))) #'identity))) (equal (mapcar (cdddar a) (mapcar #'cdddar '( ((a (((b))) 3 -3 )) ((1 nil 3 4)) ((#\a (#\b #\c) 2.0 2.01)) ))) '((-3) (4) (2.01 ))) ) ) (do-test "test cdddar2" (let ((aa '((1 2 23 (3 4 45 (5 6 67 (7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) ) ) ) )) )) (and (equal (cdddar aa) '((3 4 45 (5 6 67 (7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) ) ) )) ) (equal (cdddar (cdddar aa)) '((5 6 67 (7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) ) )) ) (equal (cdddar (cdddar (cdddar aa))) '((7 8 89 (9 10 1011 (11 12 123 (13 14) ) ) )) ) (equal (cdddar (cdddar (cdddar (cdddar aa)))) '((9 10 1011 (11 12 123 (13 14) ) )) ) (equal (cdddar (cdddar (cdddar (cdddar (cdddar aa))))) '((11 12 123 (13 14) )) ) (equal (cdddar (cdddar (cdddar (cdddar (cdddar (cdddar aa)))))) '((13 14)) ) ) ) ) (do-test "test cdddar3" (progn (setq aa '((a ab b bc) c d )) (and (setf (cdddar aa) '(( #\g #\r #\i #\n #\o)) ) (equal aa `(( a ab b ( #\g #\r #\i #\n #\o) ) c d )) (setf (cdddar (cdddar aa)) '((3 6 7 8) 9)) (equal aa `(( a ab b ( #\g #\r #\i (3 6 7 8) 9) ) c d )) (setf (cdddar (cdddar (cdddar aa))) "magic kingdom") (equal aa `(( a ab b ( #\g #\r #\i (3 6 7 . "magic kingdom") 9) ) c d )) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDDR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDDR.TEST new file mode 100644 index 00000000..f31feeaf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDDDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 14 ,1986 ;; ;; Last Update: July 14 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddddr.test ;; ;; ;; Syntax: CDDDDR LIST ;; ;; Function Description: CDDDDR performs the cdr operation 4 times on LIST, and returns the result. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test cddddr0" (and (eq (cddddr ()) ()) (eq (cddddr '(1)) ()) (eq (cddddr '((a b) (c d) e f)) '()) (eq (cddddr '(a b c z . d)) 'd) (equal (cddddr '(1 2 3 4 (5 6))) '((5 6))) (equal (cddddr '((1) (2) (3) 100 (4 5 6 . 7))) '((4 5 6 . 7))) (equal (cddddr '("sunday" nil nil "monday" nil "tuesday" nil)) '( nil "tuesday" nil)) (equal (cddddr (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) '(9 10 11 12)) (equal (cddddr '(|****| |%%%%| |????| |####| |^^^^^|)) '(|^^^^^|)) (equal (cddddr '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '( 'wild)) ) ) (defun fun (list elm) (typecase elm (number (= (cddddr list) elm)) ((or cons string) (equal (cddddr list) elm)) (t (eq (cddddr list) elm)) ) ) (do-test "test cddddr1" (prog1 (and (fun '(array (fixnum) "package" simple-vector (((((cute-t))) nil) nil) ) '((((((cute-t))) nil) nil))) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) '((2) ((3)) (((4 . 5))) t nil)) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '( (defun fun () 'nil))) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom #'+)) (mapcar (car (cddddr a)) '(4 5 6 7 (nil) t))) '(nil t)) (fun (cddddr (cddddr '(1 2 3 (10) 20 30 (100 200 300) 1000 2000 3000 4000 400 (40) 4))) '((40) 4)) ) ) ) (do-test "test cddddr2" (progn (setq a '(aa bb cc dd ee ff)) (setf (cddddr a) '(1 2 3 4 5 6 7 8)) (setf (cddddr (cddddr a)) '(44 33 22 11 55 66 77)) (equal a '(aa bb cc dd 1 2 3 4 44 33 22 11 55 66 77)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDR.TEST new file mode 100644 index 00000000..aaccb9ce --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 10 ,1986 ;; ;; Last Update: July 10 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdddr.test ;; ;; ;; Syntax: CDDDR LIST ;; ;; Function Description: CDSDR performs the cdr operation 3 times on LIST, and returns the result. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test cdddr0" (and (eq (cdddr ()) ()) (eq (cdddr '(1)) ()) (eq (cdddr '((a b) (c d))) '()) (eq (cdddr '(a b c . d)) 'd) (equal (cdddr '(1 2 3 4)) '(4)) (equal (cdddr '((1) (2) (3) (4 5 6 . 7))) '((4 5 6 . 7))) (equal (cdddr '("sunday" nil nil "monday" nil nil)) '("monday" nil nil)) (equal (cdddr (cddddr '(1 2 3 4 5 6 7 8 9 10 11 12))) '(8 9 10 11 12)) (equal (cdddr '(|****| |%%%%| |????| |####| |^^^^^|)) '(|####| |^^^^^|)) (equal (cdddr '(100 23 ((((5 6 4) 8 3) 1) .2) ((a . b) (c d e (f . g))) 'wild)) '(((a . b) (c d e (f . g))) 'wild)) ) ) (defun fun (list elm) (typecase elm (number (= (cdddr list) elm)) ((or cons string) (equal (cdddr list) elm)) (t (eq (cdddr list) elm)) ) ) (do-test "test cdddr1" (prog1 (and (fun '(array (fixnum) "package" simple-vector 'cute-t) '(simple-vector 'cute-t)) (fun (funcall #'append '((i)) '(((j))) '((1 . 2)) '(1 (2) ((3)) (((4 . 5)))) '(t nil)) '(1 (2) ((3)) (((4 . 5))) t nil)) (fun '((+ 1 2) (1+ 9) (incf 100) (decf 1100) (defun fun () 'nil)) '((decf 1100) (defun fun () 'nil))) (fun (progn (setq a (list nil nil #'evenp #'oddp #'atom)) (mapcar (car (cdddr a)) '(4 5 6 7))) '(t)) (fun (cdddr (cdddr '(1 2 3 (10) 20 30 (100 200 300) 1000 2000 3000 4000 400 (40) 4))) '(3000 4000 400 (40) 4)) ) ) ) (do-test "test cdddr2" (progn (setq a '(aa bb cc dd ee ff)) (setf (cdddr a) '(1 2 3 4 5)) (setf (cdddr (cdddr a)) '(44 33 22 11)) (equal a '(aa bb cc 1 2 3 44 33 22 11)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDR.TEST new file mode 100644 index 00000000..1b4c015a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: CDDR ;; ;; Source: Steele's book Section 15.1: Conses Page: 263 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: July 10 ,1986 ;; ;; Last Update: July 10 ,1986 ;; ;; Filed As: {eris}cml>test>15-1-cddr.test ;; ;; ;; Syntax: CDDR LIST ;; ;; Function Description: CDDR performs the cdr operation 2 times on LIST, and returns the result. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (defun mac (list elm) (typecase elm (number (= (cddr list) ,elm)) ((or cons string) (equal (cddr list) ,elm)) (t (eq (cddr list) ,elm)) ) ) (do-test "test cddr0" (prog1 (and (mac '((1) 2 ) ()) (mac '(#\a #\b #\c) '(#\c)) (mac '("a" ("b" ("c" . d) . e) . f) 'f) (mac '((( 1 2 3 4) 5) 6 7 8 9) '(7 8 9)) (mac '(( 1 a) (2 b) (3 c)) '((3 c))) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) '(((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5)))) ) (mac '((#\F) #\o "o1" "foo2" ((foo3)) (foo4 . foo5)) '("o1" "foo2" ((foo3)) (foo4 . foo5))) (mac '((("the weather in January" ("is usually clear and sunny")) "with temperatures usually in the " fifties) (in the day time) (and ) (the "20's" at night)) '((and ) (the "20's" at night)) ) )) ) (do-test "test cddr1" (progn (setq a (list (list #'null #'identity) (list #'list #'max #'min #'evenp) #'(lambda (x) (list-length x)))) (equal (mapcar (car (cddr a)) (mapcar #'cddr '( (()) ((1 2) 3 4) (#\a #\b (7 8)) ((#\d) #\e #\f #\g #\h)) ) ) '(0 1 1 3 )) ) ) (do-test "test cddr2" (let ((aa '(1 3 (5) 7 9 ((11)) 13 15 (17 .18)))) (and (equal (cddr aa) '((5) 7 9 ((11)) 13 15 (17 .18))) (equal (cddr (cddr aa)) '(9 ((11)) 13 15 (17 .18))) (equal (cddr (cddr (cddr aa))) '(13 15 (17 .18))) (equal (cddr (cddr (cddr (cddr aa)))) '((17 .18))) ) ) ) (do-test "test cddr3" (progn (setq aa '((a b) c d )) (and (setf (cddr aa) (make-list 2 :initial-element '(2 4))) (equal aa `((a b) c (2 4)(2 4))) (setf (cddr (cddr aa)) '((3 6) 9)) (equal aa `((a b ) c (2 4)(2 4) (3 6) 9)) (setf (cddr (cddr (cddr aa))) "magic kingdom") (equal aa `((a b) c (2 4)(2 4) (3 6) 9 . "magic kingdom")) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDR-AND-REST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDR-AND-REST.TEST new file mode 100644 index 00000000..55226dff --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDR-AND-REST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cdr-and-rest ;; ;; Source: Steele's book Section 15.1: Conses Page: 262 & 266 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 30,1986 ;; ;; Last Update: June 30,1986 ;; ;; Filed As: {eris}cml>test>15-1-cdr-and-rest.test ;; ;; ;; Syntax: CDR list ;; REST list ;; ;; Function Description: CDR returns a list with all elements but the first of the original list. ;; ;; Argument(s): list ;; ;; Returns: a list ;; (do-test "test cdr - the cdr of () is ()" (eq (cdr ()) ()) ) (do-test "test cdr0 - argument is a true list" (and (equal (cdr '(a b c)) '(b c)) (equal (cdr (make-list 20 :initial-element 'quack)) (make-list 19 :initial-element 'quack)) (equal (cdr (cdr (cdr (cdr (cdr (cdr (cdr '(((((( 4 5)))))) ))))))) ()) (equal (cdr (cdr (cdr '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))))) '(q r (s t)) ) (setq a (list 1 #'+)) (= (funcall (car (cdr a)) 1 2 3 4 5 ) 15) )) (do-test "test cdr1 - argument is a dotted list" (and (eq (cdr '(nil . nil)) nil) (equal (cdr '((1 2 3 4 5 6) . "s")) "s") (equal (cdr (cdr (cdr (cdr '( () () () () ( () () () () (()) . nil)))))) '(( () () () () (()) . nil)) ) (equal (cdr (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 6)))))) '(2 3 4 5 . 6)) )) (do-test "test cdr2 - the cdr of a cons may be altered by using rplacd or setf" (let () (setq aa '(a b c d (e f) g h (i j k))) (and (rplacd (cdr (car (last aa))) '(l m)) (equal aa '(a b c d (e f) g h (i j l m) )) (rplacd (cdr aa) (nthcdr 5 aa)) (equal aa '(a b g h (i j l m))) (setf (cdr aa) "the end") (equal aa '(a . "the end")) ) ) ) ; ; Function "rest" should behave the same as "cdr" ; The following test cases are the duplicates of the above ones, except the function "cdr" was replaced by "rest" ; (do-test "test rest - the rest of () is ()" (eq (rest ()) ()) ) (do-test "test rest0 - argument is a true list" (and (equal (rest '(a b c)) '(b c)) (equal (rest (make-list 20 :initial-element 'quack)) (make-list 19 :initial-element 'quack)) (equal (rest (rest (rest (rest (rest (rest (rest '(((((( 4 5)))))) ))))))) ()) (equal (rest (rest (rest '((a b c d (e f (g h i j)) (k l m)) o p q r (s t))))) '(q r (s t)) ) (setq a (list 1 #'+)) (= (funcall (car (rest a)) 1 2 3 4 5 ) 15) )) (do-test "test rest1 - argument is a dotted list" (and (eq (rest '(nil . nil)) nil) (equal (rest '((1 2 3 4 5 6) . "s")) "s") (equal (rest (rest (rest (rest '( () () () () ( () () () () (()) . nil)))))) '(( () () () () (()) . nil)) ) (equal (rest (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 6)))))) '(2 3 4 5 . 6)) )) (do-test "test rest2 - the rest of a cons may be altered by using rplacd or setf" (let () (setq aa '(a b c d (e f) g h (i j k))) (and (rplacd (rest (car (last aa))) '(l m)) (equal aa '(a b c d (e f) g h (i j l m) )) (rplacd (rest aa) (nthcdr 5 aa)) (equal aa '(a b g h (i j l m))) (setf (rest aa) "the end") (equal aa '(a . "the end")) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-CONS.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-CONS.TEST new file mode 100644 index 00000000..fdc8b63a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CONS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cons ;; ;; Source: Steele's book Section 15.1: conses Page: 264 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 20,1986 ;; ;; Last Update: June 20,1986 ;; ;; Filed As: {eris}cml>test>15-1-cons.test ;; ;; ;; Syntax: CONS x y ;; ;; Function Description: CONS creates a new cons whose car is x and whose cdr is y ;; ;; Argument(s): x y - a lisp object ;; ;; Returns: cons or conses ;; (do-test "test cons0 - test cases copied from page 264 of CLtL" (and (equal (cons 'a 'b) '(a . b)) (equal (cons 'a (cons 'b (cons 'c '()))) '(a b c)) (equal (cons 'a '(b c d)) '(a b c d)))) (do-test "test cons1 - one of the arguments is nil" (and (equal (cons 1 nil) '(1)) (equal (cons nil 1) '(nil . 1)) (equal (cons nil nil) '(nil . nil)) (equal (cons t nil) '(t)))) (do-test "test cons2 - a really long nested cons" (equal (setq longcons (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 (cons 10 (cons 'a (cons 'b (cons 'c (cons 'd (cons 'e (cons 'f (cons 'g (cons 'h (cons 'i (cons 'j (cons 'k (cons 'l (cons 'm (cons 'n (cons 'o (cons 'p (cons 'q (cons 'r (cons 's (cons 't (cons 'u (cons 'v (cons 'w (cons 'x (cons 'y (cons 'z (cons #\a (cons #\b (cons #\c #\d)))))))))))))))))))))))))))))))))))))))) '(1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d))) (do-test "test cons3" (equal (cons longcons (cons longcons (cons longcons (cons longcons longcons)))) '( (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) (1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d) 1 2 3 4 5 6 7 8 9 10 a b c d e f g h i j k l m n o p q r s t u v w x y z #\a #\b #\c . #\d))) (do-test "test cons4" (equal (cons "great" (cons "gray" (cons "owl" (cons "perched" (cons "in" (cons "an" (cons "aspen" "."))))))) '("great" "gray" "owl" "perched" "in" "an" "aspen" . "."))) (do-test "test cons5" (and (setq a (cons #'(lambda (x) (1+ x)) (cons #'(lambda (y) (1- y)) (cons #'(lambda (z) (* 2 z)) (cons #'(lambda (x) (* x x)) nil))))) (= (funcall (cadr a) 10) 9) (= (funcall (car (last a)) 10) 100) (= (funcall (nth 2 a) 2) 4) (= (list-length a) 4))) (do-test "test cons6" (equal (cons 1000 (cons 20000 (cons 399999 (cons 4777777 (cons 5111111 (cons 60000000 (cons 76666666 (cons 833232323223 (cons 922222 (cons 13333333 2888888)))))))))) '(1000 20000 399999 4777777 5111111 60000000 76666666 833232323223 922222 13333333 . 2888888))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-1-TREE-EQUAL.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-1-TREE-EQUAL.TEST new file mode 100644 index 00000000..e2d9d5af --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-TREE-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TREE-EQUAL ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.1 Conses ;; Page: 264 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 1, 1986 Sye / create test cases ;; July 21, 1986 Masinter, comment out case where "list-length" was used as tree-equal test function ;; ;; Filed As: {ERIS}CML>TEST>15-1-TREE-EQUAL.TEST ;; ;; ;; Syntax: (TREE-EQUAL X Y &KEY TEST TEST-NOT) ;; ;; Function Description: ;; This is a predicate that is true if X and Y are ;; isomorphic trees with identical leaves, that is, if X and Y ;; are atoms that satisfy the test (by default EQL), ;; or if they are both conses and their CAR's are TREE-EQUAL ;; and their CDR's are TREE-EQUAL. ;; Thus TREE-EQUAL recursively compares conses (but not any other objects ;; that have components). See function EQUAL, which does recursively ;; compare certain other structured objects, such as strings. ;; ;; Argument(s): X - a tree ;; Y - a tree ;; TEST - a function ;; TEST-NOT - a function ;; ;; Returns: a tree ;; (do-test "test tree-equal - x & y are atoms" (and (tree-equal 'a 'a) (tree-equal 0 0) (tree-equal 3.0 3.00) (tree-equal #\A #\A) (not (tree-equal 'c 'e)) (not (tree-equal 2 2.0)) (tree-equal nil () :test #'eq) (tree-equal 2 2.0 :test #'=) (tree-equal 3 4 :test-not #'=) (tree-equal "string" "STRING" :test #'equalp) (tree-equal 2 (sqrt 4) :test #'equalp) (tree-equal 10 15 :test #'(lambda (x y) (<= 10 x y 20))) ;; ;; ROACH 1-JUL-86 The form ;; (tree-equal '(2 4) '(4 6) :test-not #'equal) ;; should not be expected to return T because two corresponding leaves of ;; these trees are both NIL. ;; '(2 4) = '(2 4 . NIL) and '(4 6 . NIL) ;; (tree-equal '(2 4 . 1) '(4 6 . 3) :test-not #'equal) )) (do-test "test tree-equal - x & y are conses" (and (tree-equal '(1 . 2) '(1 . 2)) (tree-equal '(a b c d) '(a b c d)) (tree-equal '((1 1 1 1) (2 2) . 3) '((1 1 1 1) (2 2) . 3) ) (tree-equal '((2 . 1) . 4) '((2 . 1) . 4)) (not (tree-equal '("a" "s") '("a" "s"))) (not (tree-equal '(#\a #\b) '(#\A #\b))) (tree-equal '(#\a #\b) '(#\A #\B) :test #'equalp) (tree-equal '((2 1 . 3) 4 . 5) '((2 1 . 3) 4 . 5) :test #'=) (tree-equal '((1 2.2 . 3) ((4 . 5) 6 7 . 8.8) . 9) '((1 2.2 . 3) ((4 . 5) 6 7 . 8.8) . 9) :test #'=) (tree-equal '(10 (20.0 (30.2))) '(10.0 (20 (30.200))) :test #'equalp) (tree-equal '(#\a #\c "t" 30) '( 40 #\e "u" 90) :test #'(lambda (x y) (and (atom x) (atom y)))) ) ) (do-test "test tree-equal - test on a large tree" (progn (setq tree '(1 2 (3 4 (5 6 (7 8) 9 10) 11 12) 13 14 15 (#\p #\l #\m #\g ('Fire 'Pink ('black 'eyed 'susan) 'North-Carolina) |asheville| (|yarrow| |phlox| \ fragrant \ water \ lilies)) (((((a b) c d (e) f g h) 100.0 (200 400) z w) f g) the end))) (and (progn (setq tree1 tree) (and (tree-equal tree tree1) (tree-equal tree tree1 :test #'equal) (tree-equal tree tree1 :test #'equalp))) (progn ; ; replace | phlox| with |phlox| ; replace '\ \ lilies with \ lilies ; (setq tree1 (subst '| phlox| '|phlox| tree)) (setq tree2 (subst '\ \ lilies '\ lilies tree)) (not (or (tree-equal tree tree1) (tree-equal tree tree2)))) (progn ; ; replace "Fire" "Pink" with "fire" "pink" ; (setq tree1 '(1 2 (3 4 (5 6 (7 8) 9 10) 11 12) 13 14 15 (#\p #\l #\m #\g ("Fire" "Pink" ('black 'eyed 'susan) 'North-Carolina) |asheville| (|yarrow| |phlox| \ fragrant \ water \ lilies )) (((((a b) c d (e) f g h) 100.0 (200 400) z w) f g) the end))) (setq tree2 (subst "fire" "Fire" tree1 :test #'equal) tree2 (subst "pink" "Pink" tree2 :test #'equal)) (and (not (tree-equal tree1 tree2)) (not (tree-equal tree1 tree2 :test #'equal)) (tree-equal tree1 tree2 :test #'equalp))) ;; (progn ; ; replace 15 with 15.000 and 100.0 with 100 ; (defun num (x y) (if (and (numberp x) (numberp y) (= x y)) t)) (setq tree1 (subst 15.00 15 tree :test #'num) tree1 (subst 100 100.0 tree1 :test #'num)) (and (not (tree-equal tree tree1)) (not (tree-equal tree tree1 :test #'equal)) (tree-equal tree tree1 :test #'equalp) (tree-equal tree tree1 :test #' (lambda (x y) (if (listp x) (= (list-length x) (list-length y)) t) )) (tree-equal tree tree1 :test-not #'(lambda (x y) (or (vectorp x) (vectorp y)))) (tree-equal tree tree1 :test #'(lambda (x y) (and (atom x) (atom y)))))) ))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-APPEND.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-APPEND.TEST new file mode 100644 index 00000000..d5d9ff6c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-APPEND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: append ;; ;; Source: Steele's book Section 15.2: Lists Page: 268 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; ;; Filed As: {eris}cml>test>append.test ;; ;; ;; Syntax: APPEND &rest lists ;; ;; Function Description: APPEND concatenates its arguments and returns a list. ;; ;; Argument(s): {list}* or a lisp object ;; ;; Returns: a list or a lisp object ;; (do-test "test append - example copied from page 268 of CLtL" (and (EQUAL (APPEND '(A B C) '(D E F) NIL '(G)) '(A B C D E F G)) (EQUAL (APPEND '(A B C) 'D) '(A B C . D)) ) ) (do-test "test append0" (and (eq (append nil nil nil nil () () () (not t) (and nil t) (null 'a)) nil) (equal (append '(a b c) '(1 2 3 4) (list 10 20 30 40) `(aa bb cc dd) (last '(z x w q))) '(a b c 1 2 3 4 10 20 30 40 aa bb cc dd q)) (equal (funcall #'append (rest '(a b c d e)) (nthcdr 4 '(1 2 3)) (make-list 10) (butlast '(a b c))) '(b c d e nil nil nil nil nil nil nil nil nil nil a b)) (equal (setq a (append (cons 1 (cons 2 (cons 3 (cons 4 '())))) (cons 11 (cons 22 (cons 33 (cons 44 '())))) '(((((111 222 333 444 555))))))) '(1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))))) (equal (append a a a a a a a a a a a a a a a) '(1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) 1 2 3 4 11 22 33 44 ((((111 222 333 444 555)))) )) )) (do-test "test append - nested append functions" (and (equal (append (list #\a #\b #\c #\d #\q #\w #\e) (append '("append testing") (list 1 2) (append (cdr '(2 4 6 8)) (append (cddr '(1 3 5 7))) (append '(stop))))) '(#\a #\b #\c #\d #\q #\w #\e "append testing" 1 2 4 6 8 5 7 stop)) ;; (equal (append '(1) (append '(2) (append '(3) (append '(4) (append '((5)) (append '(6) (append '(7) (append '(8) (append '(9) (append '((10)) (append '(11) (append '(12) (append '(13) (append '(14) (append '((15)) (append '(16) (append '(17) (append '(18) (append '(19) (append '((20)))))))))))))))))))))) '(1 2 3 4 (5) 6 7 8 9 (10) 11 12 13 14 (15) 16 17 18 19 (20))))) (do-test "test append - append copies the top-level list structure of each of its arguments except the last one" (LET* ((a (list 1 2 3 4 5 6 7 8 9 10)) (aa (list 11 22 33)) (aaa (list 111 222 333 444 555)) (b (append a aa aaa))) (and (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555)) ; (rplacd (last a) '(11)) (equal a '(1 2 3 4 5 6 7 8 9 10 11)) (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555)) ; (rplacd (last aa) '(44)) (equal aa '(11 22 33 44)) (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555)) ; (rplacd (last aaa) '(666)) (equal aaa '(111 222 333 444 555 666)) (equal b '(1 2 3 4 5 6 7 8 9 10 11 22 33 111 222 333 444 555 666)) ;; ;; (progn (setq a (list 1 2 3 4 5 6 7 8 9 10) b (append a)) (and (equal b '(1 2 3 4 5 6 7 8 9 10)) (rplacd (last a) '(22)) (equal b '(1 2 3 4 5 6 7 8 9 10 22)) )) ;; ;; (progn (setq a (list 1 2 3 4 5 6 7 8 9 10) b (append a nil)) (and (equal b '(1 2 3 4 5 6 7 8 9 10)) (rplacd (last a) '(22)) (equal a '(1 2 3 4 5 6 7 8 9 10 22)) (equal b '(1 2 3 4 5 6 7 8 9 10)) )) ;; ;; (progn (setq a (list 2 4 '(6 8) 10) b (append a nil)) (and (equal b '(2 4 (6 8) 10)) (rplacd (caddr a) '(9)) (equal a '(2 4 (6 9) 10)) (equal b '(2 4 (6 9) 10)) )) ) )) (do-test "test append - The last argument may be any List object, which become the tail end of the constructed list" (and (equal (append '(1 2 3 4) (+ 1 4)) '(1 2 3 4 . 5)) ; (equal (append '(nil) (list 'a 'b 'c)) '(nil a b c)) ; (equal (append '(1 2) "string") '(1 2 . "string")) ; (progn (setq a (append '(1) #'(lambda (x) (gcd x 3)))) (= (funcall (cdr a) 6) 3)) ; (equal (append '(2) #\k) '(2 . #\k)) ; (prog2 (setq a (append '(3) '#(a b c d))) (vectorp (cdr a))) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-BUTLAST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-BUTLAST.TEST new file mode 100644 index 00000000..64972995 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-BUTLAST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: BUTLAST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 271 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-BUTLAST.TEST ;; ;; ;; Syntax: (BUTLAST LIST &OPTIONAL N) ;; ;; Function Description: ;; This creates and returns a list with the same elements as LIST, ;; excepting the last N elements. ;; N defaults to 1. The argument is not destroyed. ;; If the LIST has fewer than N elements, then NIL is returned. ;; For example: ;; ;; (BUTLAST '(A B C D)) => (A B C) ;; (BUTLAST '((A B) (C D))) => ((A B)) ;; (BUTLAST '(A)) => NIL ;; (BUTLAST NIL) => NIL ;; ;; The name is from the phrase ``all elements but the last.'' ;; ;; Argument(s): LIST - a list ;; N - a number ;; ;; Returns: a pure list ;; (do-test "test butlast0 - test cases copied from page 271 of CLtL" (and (equal (butlast '(a b c d)) '(a b c)) (equal (butlast '((a b) (c d))) '((a b))) (eq (butlast '(a)) ()) (eq (butlast ()) ()))) (do-test "test butlast1 - if the list has fewer than n elements, then () is returned" (notany #'(lambda (x &optional y) (butlast x y)) '((1 2 3 4) (10 20) ((2 4) (6 8)) ((17 26 35 44))) '(5 10 3 2))) (do-test "test butlast2 - n is default to 1" (and (equal (butlast '(a b c d e f g h i j k)) '(a b c d e f g h i j)) (equal (butlast '(foo foo1 (((((foo2 foo3)))) foo4))) '(foo foo1)) (equal (butlast (make-list 50 :initial-element 'hi)) (append (make-list 29 :initial-element 'hi) (make-list 20 :initial-element 'hi))) (equal (butlast (nconc '(a b) '(c (d e)))) '(a b c)))) (do-test "test butlast3" (and (eq (butlast () 2) ()) (equal (butlast '(1 2) 0) '(1 2)) (eq (butlast '(1 2 3 4) 40) ()) (eq (butlast (make-list 100) 100) ()) ; (defun fun (n) (let ((i 0) buf) (dotimes (i n buf) (setq buf (append buf (list i)))))) ; (equal (butlast (fun 100) 50) (fun 50)) (equal (butlast (fun 20) 13) (fun 7)) (equal (butlast (fun 15) 12) (fun 3)))) (do-test "test butlast4" (progn (defmacro mac1 () ''*mac1*) (defmacro mac2 () ''*mac2*) (defmacro mac3 () ''*mac3*) (setq a '((mac1) (mac2) (mac3))) (and (eq (eval (cadr (butlast a))) '*mac2*) (eq (eval (car (butlast (reverse a)))) '*mac3*)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-ALIST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-ALIST.TEST new file mode 100644 index 00000000..cde32c74 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-ALIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: COPY-ALIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 268 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 15,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-COPY-ALIST.TEST ;; ;; ;; Syntax: (COPY-ALIST ALIST) ;; ;; Function Description: ;; COPY-ALIST is for copying association lists. The top level of ;; list structure of LIST is copied, just as for COPY-LIST. ;; In addition, each element of LIST that is a cons is replaced ;; in the copy by a new cons with the same CAR and CDR. ;; ;; Argument(s): ALIST - an association list ;; ;; Returns: an association list ;; (do-test "test copy-alist 0" (and (equal (copy-alist '((g . 5) (b . 7) (e . 5) (f . 2))) '((g . 5) (b . 7) (e . 5) (f . 2))) (equal (copy-alist '((D . 5) (Z . 3) (Y . 3) (Z . 6))) '((D . 5) (Z . 3) (Y . 3) (Z . 6))) (equal (copy-alist '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) (equal (copy-alist '((X X E G C G) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) '((X X E G C G) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) (equal (copy-alist '((C F X G D B G F X) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) '((C F X G D B G F X) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) ) ) (do-test "test copy-alist 1" (and (equal (copy-alist '((CATOR . C) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) '((CATOR . C) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) (equal (copy-alist '((MEEF G C E C C) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) '((MEEF G C E C C) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) (equal (copy-alist '((8 A B D Z E D Y D) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) '((8 A B D Z E D Y D) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) (equal (copy-alist '((F . 10) (D . 8) (F . 7) (G . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) '((F . 10) (D . 8) (F . 7) (G . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) ) ) (do-test "test copy-alist 2 --each element of list that is a cons is replaced in the copy by a new cons with the same car and cdr -- page 268" (progn (setq aa '(("a" . apple) ("b" . baby) ("c" . candy) ("d" . daddy)) aaa aa bb (copy-alist aa) cc (copy-alist aa)) (rplacd (assoc "b" bb :test 'equal) 'babe) (rplacd (assoc "d" bb :test 'equal) 'doodad) (rplacd (assoc "a" cc :test 'equal) 'apricot) (rplacd (assoc "c" cc :test 'equal) 'car) (and (equal aa aaa) (equal bb '(("a" . apple) ("b" . babe) ("c" . candy) ("d" . doodad)) ) (equal cc '(("a" . apricot) ("b" . baby) ("c" . car) ("d" . daddy)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-LIST.TEST new file mode 100644 index 00000000..3322b2a7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: COPY-LIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 268 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-COPY-LIST.TEST ;; ;; ;; Syntax: (COPY-LIST L) ;; ;; Function Description: ;; This returns a list that is EQUAL to LIST, but not EQ. ;; Only the top level of list structure is copied; that is, COPY-LIST ;; copies in the CDR direction but not in the CAR direction. ;; If the list is ``dotted,'' that is, (CDR (LAST LIST)) ;; is a non-NIL atom, this will be true of the returned list also. ;; See also function COPY-SEQ and function COPY-TREE. ;; ;; Argument(s): L - a list ;; ;; Returns: a list ;; (DO-TEST "COPY-LIST TEST 1" (EQUAL (COPY-LIST '(Z Z F A Z B Z A)) '(Z Z F A Z B Z A)) (EQUAL (COPY-LIST '(Y Y D X B G B B D . C)) '(Y Y D X B G B B D . C)) (EQUAL (COPY-LIST '(D E X C E)) '(D E X C E)) (EQUAL (COPY-LIST '(X Z A C G E G . D)) '(X Z A C G E G . D)) (EQUAL (COPY-LIST '(F E F Y B)) '(F E F Y B)) (EQUAL (COPY-LIST '(Y B E A D D C X G G)) '(Y B E A D D C X G G))) (DO-TEST "COPY-LIST TEST 2" (EQUAL (COPY-LIST '(E F F B)) '(E F F B)) (EQUAL (COPY-LIST '(Z E D F . G)) '(Z E D F . G)) (EQUAL (COPY-LIST '(D A F G F B X D)) '(D A F G F B X D)) (EQUAL (COPY-LIST '(F Y C . E)) '(F Y C . E)) (EQUAL (COPY-LIST '(F D B Y B E . Z)) '(F D B Y B E . Z)) (EQUAL (COPY-LIST '(C E G F A D A B)) '(C E G F A D A B))) (DO-TEST "COPY-LIST TEST 3" (EQUAL (COPY-LIST '(QIX ZORK CATOR MEEF MORY ZORK FOO PERTY . FOO)) '(QIX ZORK CATOR MEEF MORY ZORK FOO PERTY . FOO)) (EQUAL (COPY-LIST '(BAZ)) '(BAZ)) (EQUAL (COPY-LIST '(CATOR MORY MORY BAZ QIX MEEF FOO . MORY)) '(CATOR MORY MORY BAZ QIX MEEF FOO . MORY)) (EQUAL (COPY-LIST '(FOO FOO QIX MEEF PERTY FOO MORY MORY)) '(FOO FOO QIX MEEF PERTY FOO MORY MORY)) (EQUAL (COPY-LIST '(PERTY PERTY MORY QIX MEEF)) '(PERTY PERTY MORY QIX MEEF)) (EQUAL (COPY-LIST '(BAR BAR ZORK FOO QIX . CATOR)) '(BAR BAR ZORK FOO QIX . CATOR))) (DO-TEST "COPY-LIST TEST 4" (EQUAL (COPY-LIST '(FOO CATOR CATOR BAR MEEF BAR MORY PERTY ZORK . BAR)) '(FOO CATOR CATOR BAR MEEF BAR MORY PERTY ZORK . BAR)) (EQUAL (COPY-LIST '(MEEF BAR BAZ BAZ BAR FOO)) '(MEEF BAR BAZ BAZ BAR FOO)) (EQUAL (COPY-LIST '(CATOR MEEF MEEF MEEF MEEF)) '(CATOR MEEF MEEF MEEF MEEF)) (EQUAL (COPY-LIST '(QIX ZORK BAZ PERTY MEEF CATOR MORY)) '(QIX ZORK BAZ PERTY MEEF CATOR MORY)) (EQUAL (COPY-LIST '(MORY QIX BAZ MORY)) '(MORY QIX BAZ MORY)) (EQUAL (COPY-LIST '(QIX QIX ZORK QIX PERTY CATOR . FOO)) '(QIX QIX ZORK QIX PERTY CATOR . FOO))) (DO-TEST "COPY-LIST TEST 5" (EQUAL (COPY-LIST '(7 6 8 2 8 7 . 10)) '(7 6 8 2 8 7 . 10)) (EQUAL (COPY-LIST '(7 10 3 5 6 5 7 9 . 7)) '(7 10 3 5 6 5 7 9 . 7)) (EQUAL (COPY-LIST '(8 9 10 8 9)) '(8 9 10 8 9)) (EQUAL (COPY-LIST '(4 . 5)) '(4 . 5)) (EQUAL (COPY-LIST '(6 9 7 6 2 4 3 . 10)) '(6 9 7 6 2 4 3 . 10)) (EQUAL (COPY-LIST '(7 . 6)) '(7 . 6))) (DO-TEST "COPY-LIST TEST 6" (EQUAL (COPY-LIST '(9 3 3 7 3 1 . 6)) '(9 3 3 7 3 1 . 6)) (EQUAL (COPY-LIST '(2 7 1 10 2 9)) '(2 7 1 10 2 9)) (EQUAL (COPY-LIST '(4 4 4 10 3 3 1 6 . 3)) '(4 4 4 10 3 3 1 6 . 3)) (EQUAL (COPY-LIST '(1 9 4 5 1 9 8 10 1 . 4)) '(1 9 4 5 1 9 8 10 1 . 4)) (EQUAL (COPY-LIST '(2 9 2)) '(2 9 2)) (EQUAL (COPY-LIST '(9 8 1 1 5 3 1 5 6)) '(9 8 1 1 5 3 1 5 6))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-TREE.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-TREE.TEST new file mode 100644 index 00000000..8266135c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-COPY-TREE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: COPY-TREE ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 269 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-COPY-TREE.TEST ;; ;; ;; Syntax: (COPY-TREE OBJECT) ;; ;; Function Description: ;; COPY-TREE is for copying trees of conses. ;; The argument OBJECT may be any Lisp object. ;; If it is not a cons, it is returned; otherwise ;; the result is a new cons of the results of calling COPY-TREE ;; on the CAR and CDR of the argument. In other words, ;; all conses in the tree are copied recursively, stopping ;; only when non-conses are encountered. ;; Circularities and the sharing of substructure are NOT preserved. ;; ;; Compatibility note: This function is called COPY in Interlisp. ;; ;; Argument(s): OBJECT - a tree ;; ;; Returns: a tree ;; (DO-TEST "COPY-TREE TEST 1" (EQUAL (COPY-TREE '(((D . X) . G) . Y)) '(((D . X) . G) . Y)) (EQUAL (COPY-TREE '(Z ((((Z . Z) C . G) C . E) . A) . Y)) '(Z ((((Z . Z) C . G) C . E) . A) . Y)) (EQUAL (COPY-TREE '(Z . A)) '(Z . A)) (EQUAL (COPY-TREE '((C F B . X) X Z . Z)) '((C F B . X) X Z . Z)) (EQUAL (COPY-TREE '(D . Z)) '(D . Z)) (EQUAL (COPY-TREE '(B D . B)) '(B D . B))) (DO-TEST "COPY-TREE TEST 2" (EQUAL (COPY-TREE '(((Z . X) ((F . A) F E . G) . F) (F G . B) . G)) '(((Z . X) ((F . A) F E . G) . F) (F G . B) . G)) (EQUAL (COPY-TREE '(F . C)) '(F . C)) (EQUAL (COPY-TREE '(B . F)) '(B . F)) (EQUAL (COPY-TREE '((((G . Y) ((A . D) . F) . X) B Y Y D . C) . A)) '((((G . Y) ((A . D) . F) . X) B Y Y D . C) . A)) (EQUAL (COPY-TREE '(((((B Z . X) . G) . Z) . Z) (D (Y E . D) . D) G . G)) '(((((B Z . X) . G) . Z) . Z) (D (Y E . D) . D) G . G)) (EQUAL (COPY-TREE '((((B (B . A) B . A) (E D . G) . B) . C) (F . X) (C X . Z) . B)) '((((B (B . A) B . A) (E D . G) . B) . C) (F . X) (C X . Z) . B))) (DO-TEST "COPY-TREE TEST 3" (EQUAL (COPY-TREE '((MORY . BAR) . CATOR)) '((MORY . BAR) . CATOR)) (EQUAL (COPY-TREE '(ZORK . MORY)) '(ZORK . MORY)) (EQUAL (COPY-TREE '(BAZ ((MORY MORY PERTY . BAR) ((PERTY . PERTY) . MORY) (BAZ . MEEF) ZORK . PERTY) (QIX QIX . PERTY) ZORK . CATOR)) '(BAZ ((MORY MORY PERTY . BAR) ((PERTY . PERTY) . MORY) (BAZ . MEEF) ZORK . PERTY) (QIX QIX . PERTY) ZORK . CATOR)) (EQUAL (COPY-TREE '(((PERTY . ZORK) PERTY . PERTY) ((((MEEF . FOO) BAZ . MEEF) (CATOR . MORY) FOO . CATOR) . CATOR) QIX BAZ (CATOR . ZORK) BAZ . CATOR)) '(((PERTY . ZORK) PERTY . PERTY) ((((MEEF . FOO) BAZ . MEEF) (CATOR . MORY) FOO . CATOR) . CATOR) QIX BAZ (CATOR . ZORK) BAZ . CATOR)) (EQUAL (COPY-TREE '(CATOR BAZ QIX . CATOR)) '(CATOR BAZ QIX . CATOR)) (EQUAL (COPY-TREE '(((BAZ . BAR) ZORK . MORY) . BAZ)) '(((BAZ . BAR) ZORK . MORY) . BAZ))) (DO-TEST "COPY-TREE TEST 4" (EQUAL (COPY-TREE '((FOO (BAR . PERTY) FOO . ZORK) . CATOR)) '((FOO (BAR . PERTY) FOO . ZORK) . CATOR)) (EQUAL (COPY-TREE '((((CATOR . BAR) (MORY QIX . MEEF) . BAR) (BAR (MORY . QIX) . FOO) ((FOO . MEEF) . PERTY) . MORY) (((QIX . BAR) ZORK BAR . BAR) . QIX) (((MORY . MORY) BAZ . BAR) . BAZ) . ZORK)) '((((CATOR . BAR) (MORY QIX . MEEF) . BAR) (BAR (MORY . QIX) . FOO) ((FOO . MEEF) . PERTY) . MORY) (((QIX . BAR) ZORK BAR . BAR) . QIX) (((MORY . MORY) BAZ . BAR) . BAZ) . ZORK)) (EQUAL (COPY-TREE '(BAR . BAZ)) '(BAR . BAZ)) (EQUAL (COPY-TREE '(((BAR . PERTY) ((QIX . ZORK) . MORY) ((CATOR . MORY) MORY . FOO) . CATOR) . MEEF)) '(((BAR . PERTY) ((QIX . ZORK) . MORY) ((CATOR . MORY) MORY . FOO) . CATOR) . MEEF)) (EQUAL (COPY-TREE '(FOO MEEF FOO . FOO)) '(FOO MEEF FOO . FOO)) (EQUAL (COPY-TREE '(((QIX PERTY . CATOR) . ZORK) ((BAR ZORK . QIX) (BAR QIX . MORY) . FOO) . PERTY)) '(((QIX PERTY . CATOR) . ZORK) ((BAR ZORK . QIX) (BAR QIX . MORY) . FOO) . PERTY))) (DO-TEST "COPY-TREE TEST 5" (EQUAL (COPY-TREE '(8 (7 8 . 6) . 8)) '(8 (7 8 . 6) . 8)) (EQUAL (COPY-TREE '(2 (5 (7 . 1) . 2) 9 . 10)) '(2 (5 (7 . 1) . 2) 9 . 10)) (EQUAL (COPY-TREE '(6 ((9 . 5) . 8) . 8)) '(6 ((9 . 5) . 8) . 8)) (EQUAL (COPY-TREE '(1 . 3)) '(1 . 3)) (EQUAL (COPY-TREE '(4 . 6)) '(4 . 6)) (EQUAL (COPY-TREE '((8 . 6) . 1)) '((8 . 6) . 1))) (DO-TEST "COPY-TREE TEST 6" (EQUAL (COPY-TREE '(10 . 4)) '(10 . 4)) (EQUAL (COPY-TREE '(9 . 5)) '(9 . 5)) (EQUAL (COPY-TREE '(((8 . 6) 9 5 . 1) . 8)) '(((8 . 6) 9 5 . 1) . 8)) (EQUAL (COPY-TREE '((((7 . 4) 9 . 4) . 8) . 7)) '((((7 . 4) 9 . 4) . 8) . 7)) (EQUAL (COPY-TREE '(((2 . 10) (((7 . 9) . 3) . 1) . 8) 4 . 3)) '(((2 . 10) (((7 . 9) . 3) . 1) . 8) 4 . 3)) (EQUAL (COPY-TREE '(10 9 (((8 . 6) 1 . 3) . 3) . 6)) '(10 9 (((8 . 6) 1 . 3) . 3) . 6))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-EIGHTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-EIGHTH.TEST new file mode 100644 index 00000000..068bfa28 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-EIGHTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EIGHTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 7,1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-EIGHTH.TEST ;; ;; ;; Syntax: (EIGHTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test eighth0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (eighth ,list) ,elm)) ((or cons string) (equal (eighth ,list) ,elm)) (t (eq (eighth ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) ()) (mac '(1 2 3 4 5 6 7 8) 8) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 8.005) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) '(t . t)) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) '(j k) ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '(u v) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") #\o) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) "foo7-bar7" ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |Hawaii| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "to" ) ) )) (do-test "test eighth1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (eighth a) '(3 5 100)) '(nil nil t)) ) ) (do-test "test eighth2" (let ((aa '(1 2 3 4 5 6 7 (1 2 3 4 5 6 7 (1 2 3 4 5 6 7 (1 2 3 4 5 6 7 8 9 10 11 12) 8 9 10 11 12) 8 9 10 11 12) 8 9 10 11 12))) (and (equal (eighth aa) '(1 2 3 4 5 6 7 (1 2 3 4 5 6 7 (1 2 3 4 5 6 7 8 9 10 11 12) 8 9 10 11 12) 8 9 10 11 12)) (equal (eighth (eighth aa)) '(1 2 3 4 5 6 7 (1 2 3 4 5 6 7 8 9 10 11 12) 8 9 10 11 12)) (equal (eighth (eighth (eighth aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (eighth (eighth (eighth (eighth aa)))) 8) ) ) ) (do-test "test eighth3" (let ((aa (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm))) (setf (eighth aa) (make-list 15)) (setf (eighth (eighth aa)) (make-list 15 :initial-element 'rah)) (setf (eighth (eighth (eighth aa))) "magic kingdom") (equal aa '(a b c d e f g(nil nil nil nil nil nil nil (rah rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah rah rah) nil nil nil nil nil nil nil) i j k l m)) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-ENDP.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-ENDP.TEST new file mode 100644 index 00000000..db9ef8a2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-ENDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ENDP ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 264 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-ENDP.TEST ;; ;; ;; Syntax: (ENDP OBJECT) ;; ;; Function Description: ;; The predicate ENDP is the recommended way to test for the end ;; of a list. It is false of conses, true of NIL, and an error for ;; all other arguments. ;; Implementation note: Implementations are encouraged to signal an ;; error, especially in the interpreter, for a non-list argument. ;; The ENDP function is defined so as to allow compiled code ;; to perform simply an atom check or a null check if speed is more ;; important than safety. ;; ;; Argument(s): OBJECT - anything ;; ;; Returns: T or NIL ;; (do-test "test endp - argument is a nil" (and (eq (endp nil) t) (eq (endp () ) t) (eq (endp (cdr '(1))) t))) (do-test "test endp - argument is a conses" (and (notany #'endp '((1 2 3) (a . b) ((a b c (0 9 8 7 (#\a #\b "c")) z s w) 4 5 6 . d) (value 10 volume 300))) (notany #'endp (list (list 10 20 30) (cons 1 2) (append '(99) '(88)) (make-list 2))))) ;;(do-test "test endp - (This is an error !! if) argument is an object other than nil or conses " ;; (notany #'(lambda (x) (nlsetq (endp x))) '(a 23 0.009 #\m "st" #(1 2 3) 7/3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-FIFTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-FIFTH.TEST new file mode 100644 index 00000000..bb6a08f6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-FIFTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FIFTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 3, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-FIFTH.TEST ;; ;; ;; Syntax: (FIFTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test fifth0" (and (eq (fifth ()) ()) (eq (fifth '(1)) ()) (eq (fifth '(1 2)) ()) (eq (fifth '(a b c)) ()) (eq (fifth '(a b c d)) ()) (eql (fifth '(1 2 3 4 5)) 5) (equal (fifth '(nil nil nil ( t . t) (nil . t) (nil . nil))) '(nil . t)) (eql (fifth (list #\a #\c #\s #\g #\u #\r)) #\u) (equal (fifth '("infor" "system" (("division" "xerox")) "system" ("groups" (789 333)) "exit")) '("groups" (789 333))) )) (do-test "test fifth1" (prog2 (defun fun (list elm) (typecase elm (number (= (fifth list) elm)) ((or cons string) (equal (fifth list) elm)) (t (eq (fifth list) elm)) ) ) (and (fun '('foo1 'foo2 'foo3 'foo4 'foo5 'foo6) ''foo5) (fun '((1) ((b)) (c . "c") ((d d)) (((e e) e ) e) "ffff" | * g * |) '(((e e) e ) e) ) (fun (progn (setq a '(2 4 6 8 10 12 14)) (rplaca (nthcdr 4 a) '("a" "b")) a) '("a" "b")) (fun (fifth (append '(#\q #\a #\k #\!) '((10 20 30 40 50 60)) '("the" "end"))) 50) ) ) ) (do-test "test fifth2" (progn (setq a (make-list 10)) (setf (fifth a) '( red yellow green pink blue brown)) (setf (fifth (fifth a)) '!dark-blue!) (equal a '(nil nil nil nil (red yellow green pink !dark-blue! brown) nil nil nil nil nil)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-FIRST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-FIRST.TEST new file mode 100644 index 00000000..06dfcebe --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-FIRST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FIRST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-FIRST.TEST ;; ;; ;; Syntax: (FIRST LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST FIRST0" ;; ;; The tests were incorporated in the test file "15-1-car-and-first.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-FOURTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-FOURTH.TEST new file mode 100644 index 00000000..a46241b8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-FOURTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FOURTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-FOURTH.TEST ;; ;; ;; Syntax: (FOURTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST FOURTH0" ;; ;; The test cases were incorporated in the test file "15-1-cadddr-and-fourth.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-LAST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-LAST.TEST new file mode 100644 index 00000000..1070043d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LAST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LAST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - made PLIST for A even number of atoms in LAST1 test ;; because SUN complains if same variable is used in a DEFSTRUCT field name if odd ;; number of atoms in property list ;; ;; Filed As: {ERIS}CML>TEST>15-2-LAST.TEST ;; ;; ;; Syntax: (LAST LIST) ;; ;; Function Description: ;; LAST returns the last cons (NOT the last element!) of LIST. ;; If LIST is NIL, it returns NIL. ;; For example: ;; ;; (SETQ X '(A B C D)) ;; (LAST X) => (D) ;; (RPLACD (LAST X) '(E F)) ;; X => '(A B C D E F) ;; (LAST '(A B C . D)) => (C . D) ;; ;; ;; Argument(s): X - a list ;; ;; Returns: a list ;; (do-test "test last0 - test cases copied from page 267 of CLtL" (and (setq x '(a b c d)) (equal (last x) '(d)) (rplacd (last x) '(e f)) (equal x `(a b c d e f)) (equal (last '(a b c . d)) '(c . d)))) (do-test "test last1" (progn (defun fun (x y) (equal (last x) y)) ; (and (fun '(1 2 3 4 5) '(5)) (fun '() ()) (fun '(1 . 2) '(1 . 2)) (fun '(d k s i e u w d (k l j h)) '((k l j h))) (fun '(a b c d (e f g) h (((i)))) '((((i))))) (progn (setq a 1) (setf (symbol-plist 'a) '(foo1 foo2 foo3 foo4)) (fun (symbol-plist 'a) '(foo4))) (progn (setq a (append '(foo) (make-list 10 :initial-element 'rah) '(foon))) (and (fun a '(foon)) (fun (reverse a) '(foo))))))) (do-test "test last2" (progn (setq a (list (function +) (function -) (function *))) (= (funcall (car (last a)) 1 2 3 40) 240) (= (apply (car (last (reverse a))) '(1 2 3 40)) 46))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-LDIFF.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-LDIFF.TEST new file mode 100644 index 00000000..39fdab24 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LDIFF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LDIFF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 272 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-LDIFF.TEST ;; ;; ;; Syntax: (LDIFF LIST SUBLIST) ;; ;; Function Description: ;; LIST should be a list, and SUBLIST should be a sublist ;; of LIST, that is, one of the conses that make up LIST. ;; LDIFF (meaning ``list difference'') will return a new (freshly consed) ;; list, whose elements are those elements of LIST that appear before ;; SUBLIST. If SUBLIST is not a tail of LIST ;; (and in particular if SUBLIST is NIL), ;; then a copy of the entire LIST is returned. ;; The argument LIST is not destroyed. ;; For example: ;; ;; (SETQ X '(A B C D E)) ;; (SETQ Y (CDDDR X)) => (D E) ;; (LDIFF X Y) => (A B C) ;; but ;; (LDIFF '(A B C D) '(C D)) => (A B C D) ;; since the sublist was not EQ to any part of the list. ;; ;; ;; Argument(s): LIST - a pure list ;; SUBLIST - a pure list ;; ;; Returns: a pure list ;; (do-test "test ldiff - test cases copied from page 272 of CLtL" (progn (SETQ X '(A B C D E)) (SETQ Y (CDDDR X)) (and (EQUAL (LDIFF X Y) '(A B C)) (NOT (EQUAL (LDIFF '(A B C D) '(C D)) '(A B C))) ))) (do-test "test ldiff0" (progn (setq a '(1 2 3 4 5 6) b (nthcdr 3 a) c (nthcdr 5 a) d (nthcdr 1 b)) ; (and (equal (ldiff a b) '(1 2 3)) (equal (ldiff a c) '(1 2 3 4 5)) (equal (ldiff a d) '(1 2 3 4)) ))) (do-test "test ldiff1" (let () (defun fun (list n diff) (equal (ldiff list (nthcdr n list)) diff)) (and (fun '(10 9 8 7 6 5 4 3 2 1) 5 '(10 9 8 7 6)) (fun '(( a b c d) e f g h (i j k) l m n) 1 '((a b c d))) ; ; sublist is a nill ; (fun '(a b c d) 4 '(a b c d)) (fun (make-list 200 :initial-element 'quack) 190 (make-list 190 :initial-element 'quack)) (fun (make-list 150 :initial-element '(1 . 2)) 100 (make-list 100 :initial-element '(1 . 2))) (fun (make-list 125 :initial-element #\w) 75 (make-list 75 :initial-element #\w)) ))) (do-test "test ldiff - ldiff returns a new (freshly consed) list" (progn (setq a '(a b c d e f g) b (cdr (cdr (cdr a))) d (ldiff a b)) (and (equal d '(a b c)) (rplaca (cdr d) 'w) (equal d '(a w c)) (equal a '(a b c d e f g))))) (do-test "test ldiff - 'sublist' should be a sublist of 'list' " (and (let (a b) (set 'a '( l d i f f)) (set 'b a) (eq nil (ldiff a b))) ;; (prog2 (setq a '( l d i f f) b '(t e s t i n g) c (append a b) d (append a nil)) (and (equal (ldiff c a ) c) (equal (ldiff c b) a) (equal (ldiff d a) d) )) ;; (progn (setq a '( l d i f f) b '(t e s t i n g) d (append a nil) c (nconc a b)) (and (equal (ldiff c a) nil) (equal (ldiff c b) d))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST-LENGTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST-LENGTH.TEST new file mode 100644 index 00000000..4c9cb4ae --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST-LENGTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LIST-LENGTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 265 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-LIST-LENGTH.TEST ;; ;; ;; Syntax: (LIST-LENGTH LIST) ;; ;; Function Description: ;; LIST-LENGTH returns, as an integer, the length of LIST. ;; LIST-LENGTH differs from function LENGTH when the LIST is ;; circular; LENGTH may fail to return, whereas LIST-LENGTH ;; will return NIL. ;; For example: ;; ;; (LIST-LENGTH 'NIL) => 0 ;; (LIST-LENGTH '(A B C D)) => 4 ;; (LIST-LENGTH '(A (B C) D)) => 3 ;; (LET ((X (LIST 'A B C))) ;; (RPLACD (LAST X) X) ;; (LIST-LENGTH X)) => NIL ;; ;; LIST-LENGTH could be implemented as follows: ;; ;; ;; (DEFUN LIST-LENGTH (X) ;; (DO ((N 0 (+ N 2)) ;COUNTER. ;; (FAST X (CDDR FAST)) ;FAST POINTER: LEAPS BY 2. ;; (SLOW X (CDR SLOW))) ;SLOW POINTER: LEAPS BY 1. ;; (NIL) ;; ;; IF FAST POINTER HITS THE END, RETURN THE COUNT. ;; (WHEN (ENDP FAST) (RETURN N)) ;; (WHEN (ENDP (CDR FAST)) (RETURN (+ N 1))) ;; ;; IF FAST POINTER EVENTUALLY EQUALS SLOW POINTER, ;; ;; THEN WE MUST BE STUCK IN A CIRCULAR LIST. ;; ;; (A DEEPER PROPERTY IS THE CONVERSE: IF WE ARE ;; ;; STUCK IN A CIRCULAR LIST, THEN EVENTUALLY THE ;; ;; FAST POINTER WILL EQUAL THE SLOW POINTER. ;; ;; THAT FACT JUSTIFIES THIS IMPLEMENTATION.) ;; (WHEN (AND (EQ FAST SLOW) (> N 0)) (RETURN NIL)))) ;; ;; ;; See function LENGTH, which will return the length of any sequence. ;; ;; Argument(s): LIST - a list ;; ;; Returns: a number ;; (do-test "test list-length0 : test cases copied from page 265 of CLtL" (and (= (list-length '()) 0) (= (list-length '(a b c d)) 4) (= (list-length '(a (b c) d)) 3) (eq (let ((x (list 'a 'b 'c))) (rplacd (last x) x) (list-length x)) nil))) (do-test "test list-length1 : more test case copied from page 265 of CLtL" (progn (defun list-length2 (x) ; ; list-length could be implemented as follows: ; (do ((n 0 (+ n 2)) (fast x (cddr fast)) (slow x (cdr slow))) (nil) (when (endp fast) (return n)) (when (endp (cdr fast)) (return (+ n 1))) (when (and (eq fast slow) (> n 0)) (return nil)))) ; (and (= (list-length2 '(4 3 2)) 3) (= (list-length2 '()) 0) (setq x '(1 2)) (eq (list-length2 (rplacd (cdr x) x)) nil) (= (list-length2 '(8 7 (3 4))) 3)))) (do-test "test list-length2 : for non-circular lists, the function returns an integer" (every #'(lambda (x) (and (setq a (list-length x)) (integerp a) (not (minusp a)))) '( () '(1 2 3) '(a b c d e f g)))) (do-test "test list-length3 : for circular lists, the function should return a nil" (notany #'list-length (list (prog2 (setq x '(1 2 3)) (rplacd (cddr x) x)) (prog1 (rplacd (last (setq x '(a b c d))) x))))) ;;(do-test "test list-length4 : CLtL didn't talk about the behavior of the function when the argument ia a non-list." ;; (notany #'(lambda (x) (nlsetq (list-length x))) '(a 23 0.009 #\m "st" #(1 2 3) 7/3))) (do-test "test list-length5" (let () (defun fun (x y z) (= (list-length (append x y)) z)) (and (fun '(1 2) '(3 4) 4) (fun () () 0) (fun '(a b c d e f g (h i j k)) '(2 34 5) 11) (fun (make-list 30) (make-list 20) 50) (fun '(((((a))))) '((((())))) 2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST.TEST new file mode 100644 index 00000000..9fded9c0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - moved DEFSTRUCT into :before DO-TEST-GROUP ;; in list4 test due to SUN problem. ;; ;; Filed As: {ERIS}CML>TEST>15-2-LIST.TEST ;; ;; ;; Syntax: (LIST &REST ARGS) ;; ;; Function Description: ;; LIST constructs and returns a list of its arguments. ;; For example: ;; ;; (LIST 3 4 'A (CAR '(B . C)) (+ 6 -2)) => (3 4 A B 4) ;; ;; ;; Argument(s): ARGS - anything ;; ;; Returns: a pure list ;; (do-test "test list0 - test case copied from page 267 of CLtL" (equal (list 3 4 'a (car '(b . c)) (+ 6 -2)) '(3 4 a b 4))) ;;ROACH 25-JUN-86 This test fails because Xerox's Lisp has ;;an upper limit on the number of arguments a function can take. ;;This upper limit on the number of arguments is currently 80. ;; ;;(do-test "test list1 - can list take 100 arguments ??" ;; (equal (list 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999 ;; 999 999 999 999 999 999 999 999 999 999) ;; (make-list 100 :initial-element 999))) (do-test "test list2" (equal (list "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" Shanti))) (do-test "test list3 - nested list functions" (and (equal (setq aa (list (list (list (list (list (list (list (list (list (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k))))))))))) '((((((((((a b c d e f g h i j k)))))))))) ) (equal (list aa aa aa aa aa) '( ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) ((((((((((a b c d e f g h i j k)))))))))) )))) (do-test-group (more-tests :before (defmacro mac () `(list ,(* 2 2) ,(list-length ()))) ) (do-test "test list4" (progn (setq aa '(a b c d e f g h)) (equal (list (last aa) (nth 3 aa) (nthcdr 5 aa) (list (car aa) (endp aa)) (progn 1 2 3 (setq x 1 y 2 z 3)) (prog2 (defun fun () "fun1") (fun)) (prog1 (setq a 100) (setq a (1+ a))) (mac) ) '( (h) d (f g h) (a nil) 3 "fun1" 100 (4 0)) ) ) ) ) (do-test "test list5" (equal (list 1.009 'a (cons 3 4) (funcall #'list 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0)) (apply #'list 'm 'n 'b '(88)) (list (+ 2 3) (caddr '(w x y z))) ) '(1.009 a (3 . 4) (2.009 #\g "string") t nil (m n b 88) (5 y)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST new file mode 100644 index 00000000..0d749cc5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LIST* ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 15, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-LIST*.TEST ;; ;; ;; Syntax: (LIST* ARG &REST OTHERS) ;; ;; Function Description: ;; LIST* is like LIST except that the last CONS ;; of the constructed list is ``dotted.'' The last argument to LIST* ;; is used as the CDR of the last cons constructed; ;; this need not be an atom. If it is not an atom, ;; then the effect is to add several new elements to the front of a list. ;; For example: ;; ;; (LIST* 'A 'B 'C 'D) => (A B C . D) ;; This is like ;; (CONS 'A (CONS 'B (CONS 'C 'D))) ;; Also: ;; (LIST* 'A 'B 'C '(D E F)) => (A B C D E F) ;; (LIST* X) = X ;; ;; ;; Argument(s): ARG - anything ;; OTHERS - anything ;; ;; Returns: a dotted list ;; (do-test "test list*0 - test case copied from page 267 of CLtL" (and (EQUAL (LIST* 'A 'B 'C 'D) '(A B C . D)) (EQUAL (LIST* 'A 'B 'C '(D E F)) '(A B C D E F)) (EQUAL (LIST* 'X) 'X) ) ) (do-test "test list*1" (and (equal (list* 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999) (append (make-list 48 :initial-element 999) '(999 . 999))) (equal (list* "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" . Shanti)) ) ) (do-test "test list*2" (equal (list* 1.009 'a (cons 3 4) (funcall #'list* 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0)) (apply #'list* 'm 'n 'b '(88)) (list* (+ 2 3) (caddr '(w x y z))) ) '(1.009 a (3 . 4) (2.009 #\g . "string") t nil (m n b . 88) 5 . y))) (do-test "test list*3" (progn (setq aa '(a b c d e f g h)) (equal (list* (last aa) (nth 3 aa) (nthcdr 5 aa) (list* (car aa) (endp aa)) (progn 1 2 3 (setq x 1 y 2 z 3)) (prog2 (defun fun () "fun1") (fun)) (prog1 (setq a 100) (setq a (1+ a))) (progn (defmacro mac () `(list* ,(* 2 2) ,(list-length ()))) (mac))) '( (h) d (f g h) (a . nil) 3 "fun1" 100 4 . 0)) )) (do-test "test list*4 - nested list* functions" (and (equal (setq aa (list* (list* (list* (list* (list* (list* (list* (list* (list* (list* 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k))))))))))) '(a b c d e f g h i j . k) ) (equal (list* aa aa aa aa aa) '((a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) a b c d e f g h i j . k) ) ) ) (do-test "test list*5 - (list* x) is equivalent to x [page 268]" (and (eq (list* ()) ()) (eq (list* 10) 10) (equal (list* '(1)) '(1)) (equal (list* (list* (list 2))) '(2)) (prog2 (setq a (list* #'-)) (= (funcall a 4 3 2 1) -2)) (equal (list* (list (list* 1 2 3) '(4) ) '(5 . "a")) '(((1 2 . 3) (4)) 5 . "a")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST% b/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST% new file mode 100644 index 00000000..0d749cc5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST% @@ -0,0 +1 @@ +;; Function To Be Tested: LIST* ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 15, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-LIST*.TEST ;; ;; ;; Syntax: (LIST* ARG &REST OTHERS) ;; ;; Function Description: ;; LIST* is like LIST except that the last CONS ;; of the constructed list is ``dotted.'' The last argument to LIST* ;; is used as the CDR of the last cons constructed; ;; this need not be an atom. If it is not an atom, ;; then the effect is to add several new elements to the front of a list. ;; For example: ;; ;; (LIST* 'A 'B 'C 'D) => (A B C . D) ;; This is like ;; (CONS 'A (CONS 'B (CONS 'C 'D))) ;; Also: ;; (LIST* 'A 'B 'C '(D E F)) => (A B C D E F) ;; (LIST* X) = X ;; ;; ;; Argument(s): ARG - anything ;; OTHERS - anything ;; ;; Returns: a dotted list ;; (do-test "test list*0 - test case copied from page 267 of CLtL" (and (EQUAL (LIST* 'A 'B 'C 'D) '(A B C . D)) (EQUAL (LIST* 'A 'B 'C '(D E F)) '(A B C D E F)) (EQUAL (LIST* 'X) 'X) ) ) (do-test "test list*1" (and (equal (list* 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999) (append (make-list 48 :initial-element 999) '(999 . 999))) (equal (list* "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" . Shanti)) ) ) (do-test "test list*2" (equal (list* 1.009 'a (cons 3 4) (funcall #'list* 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0)) (apply #'list* 'm 'n 'b '(88)) (list* (+ 2 3) (caddr '(w x y z))) ) '(1.009 a (3 . 4) (2.009 #\g . "string") t nil (m n b . 88) 5 . y))) (do-test "test list*3" (progn (setq aa '(a b c d e f g h)) (equal (list* (last aa) (nth 3 aa) (nthcdr 5 aa) (list* (car aa) (endp aa)) (progn 1 2 3 (setq x 1 y 2 z 3)) (prog2 (defun fun () "fun1") (fun)) (prog1 (setq a 100) (setq a (1+ a))) (progn (defmacro mac () `(list* ,(* 2 2) ,(list-length ()))) (mac))) '( (h) d (f g h) (a . nil) 3 "fun1" 100 4 . 0)) )) (do-test "test list*4 - nested list* functions" (and (equal (setq aa (list* (list* (list* (list* (list* (list* (list* (list* (list* (list* 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k))))))))))) '(a b c d e f g h i j . k) ) (equal (list* aa aa aa aa aa) '((a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) a b c d e f g h i j . k) ) ) ) (do-test "test list*5 - (list* x) is equivalent to x [page 268]" (and (eq (list* ()) ()) (eq (list* 10) 10) (equal (list* '(1)) '(1)) (equal (list* (list* (list 2))) '(2)) (prog2 (setq a (list* #'-)) (= (funcall a 4 3 2 1) -2)) (equal (list* (list (list* 1 2 3) '(4) ) '(5 . "a")) '(((1 2 . 3) (4)) 5 . "a")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-MAKE-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-MAKE-LIST.TEST new file mode 100644 index 00000000..d3f6f51e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-MAKE-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-LIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 268 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-MAKE-LIST.TEST ;; ;; ;; Syntax: (MAKE-LIST SIZE &KEY INITIAL-ELEMENT) ;; ;; Function Description: ;; This creates and returns a list containing SIZE elements, each ;; of which is initialized to the :INITIAL-ELEMENT ;; argument (which defaults to NIL). ;; SIZE should be a non-negative integer. ;; For example: ;; ;; (MAKE-LIST 5) => (NIL NIL NIL NIL NIL) ;; (MAKE-LIST 3 :INITIAL-ELEMENT 'RAH) => (RAH RAH RAH) ;; ;; ;; Argument(s): SIZE - a number ;; INITIAL-ELEMENT - anything ;; ;; Returns: a pure list ;; ;;ROACH 25-JUN-86 These NLSETQ's don't seem to protect against CL:ERROR's. ;;I've therefore disabled this test. ;; ;;(do-test "test make-list0 - check syntax" ;; (not (or (nlsetq (make-list)) ;; (nlsetq (make-list 'dfd)) ;; (nlsetq (make-list :initial-element 3)) ;; ;; ;; ;; check spelling of keyword :initial-element ;; ;; ;; (nlsetq (make-list 3 :initial 2)) ;; (nlsetq (make-list 3 :initial-ellementt 4)) ;; ;; ;; ;; size should be a non-negative integer ;; ;; ;; (nlsetq (make-list 2.0)) ;; (nlsetq (make-list -1))))) (do-test "test make-list1 - test cases copied from p268 of CLtL" (and (eq (make-list 0) '()) (equal (make-list 5) '(nil nil nil nil nil)) (equal (make-list 3 :initial-element 'rah) '(rah rah rah)))) (do-test "test make-list - using different types of data objects for the initial values" (and (equal (make-list 2 :initial-element 3.0) '(3.0 3.0)) (equal (make-list 2 :initial-element ''n) '('n 'n)) (equal (make-list 2 :initial-element "w") '("w" "w")) (equal (make-list 2 :initial-element #\p) '(#\p #\p)) (equal (make-list 2 :initial-element 10) '(10 10)) (equal (make-list 2 :initial-element '(1 2)) '((1 2) (1 2))))) (do-test "test make-list3" (let () (defun fun (size &optional value) (make-list size :initial-element value)) (defun test (list size value) (and (every #'(lambda (x) (cond ((or (listp x) (stringp x)) (equal x value)) (t (eq x value)))) list) (= (list-length list) size))) ; (and (test (fun 10 'a) 10 'a) (test (fun 100 #\q) 100 #\q) (test (fun 50 "s") 50 "s") (test (fun 50 -1) 50 -1) (test (fun 200 (* 2 7)) 200 14) (test (fun 40) 40 nil) (test (fun 30 'foo) 30 'foo) (test (fun 25 '(1 2 3)) 25 '(1 2 3))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-NBUTLAST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-NBUTLAST.TEST new file mode 100644 index 00000000..d39ec692 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NBUTLAST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NBUTLAST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 271 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-NBUTLAST.TEST ;; ;; ;; Syntax: (NBUTLAST LIST &OPTIONAL N) ;; ;; Function Description: ;; This is the destructive version of BUTLAST; it changes the CDR of ;; the cons N+1 from the end of the LIST to NIL. N defaults to 1. ;; If the LIST has fewer than N elements, then NBUTLAST ;; returns NIL, and the argument is not modified. (Therefore ;; one normally writes (SETQ A (NBUTLAST A)) rather than simply ;; (NBUTLAST A).) ;; For example: ;; ;; (SETQ FOO '(A B C D)) ;; (NBUTLAST FOO) => (A B C) ;; FOO => (A B C) ;; (NBUTLAST '(A)) => NIL ;; (NBUTLAST 'NIL) => NIL ;; ;; ;; Argument(s): LIST - a pure list ;; N - a number ;; ;; Returns: a pure list ;; (do-test "test nbutlast0 - test cases from page 271 of CLtL" (and (SETQ FOO '(A B C D)) (EQUAL (NBUTLAST FOO) '(A B C)) (EQUAL FOO '(A B C)) (EQUAL (NBUTLAST '(A)) NIL) (EQUAL (NBUTLAST NIL) NIL))) (do-test "test nbutlast1 - if the list has fewer than n elements, then () is returned and the argument is not modified" (every #'(lambda (x y) (let ((a x)) (and (eq nil (nbutlast x y)) (equal a x)))) '((1 2 3 4) (10 20) ((2 4) (6 8)) ((17 26 35 44))) '(5 10 3 2))) (do-test "test nbutlast2 - n is default to 1" (and (setq a '(a b c d e f g h i j k)) (equal (nbutlast a) '(a b c d e f g h i j)) (equal a '(a b c d e f g h i j)) ; (setq a '(foo foo1 (((((foo2 foo3)))) foo4))) (equal (nbutlast a) '(foo foo1)) (equal a '(foo foo1)) ; (setq a (make-list 50 :initial-element 'hi)) (setq b (append (make-list 29 :initial-element 'hi) (make-list 20 :initial-element 'hi))) (equal (nbutlast a) b) (equal a b) ; (setq a (nconc '(a b) '(c (d e)))) (equal (nbutlast a) '(a b c)) (equal a '(a b c)))) ;;ROACH 25-JUN-86 The last (eq a ()) in this test appears to be an ;;incorrect test. A will still be bound to the value of (make-list 100). ;;I have therefore modified this test to omit the (eq a ()). ;; (do-test "test nbutlast3" (and (prog1 1 (setq a ())) (eq (nbutlast a 2) ()) (eq a ()) ; (setq a '(1 2)) (equal (nbutlast a 0) '(1 2)) (equal a '(1 2)) ; (setq a '(1 2 3 4)) (eq (nbutlast a 40) ()) (equal a '(1 2 3 4)) ; (setq a (make-list 100)) (eq (nbutlast a 100) ()) ;; (eq a ()) )) (do-test "test nbutlast4" (progn (defun fun (n) (let ((i 0) buf) (dotimes (i n buf) (setq buf (append buf (list i)))))) ; (and (setq a (fun 100) b (fun 50)) (equal (nbutlast a 50) b) (equal a b) ; (setq a (fun 20) b (fun 7)) (equal (nbutlast a 13) b) (equal a b) ; (setq a (fun 15) b (fun 3)) (equal (nbutlast a 12) b) (equal a b)))) (do-test "test nbutlast4" (progn (defmacro mac1 () ''*mac1*) (defmacro mac2 () ''*mac2*) (defmacro mac3 () ''*mac3*) (setq a '((mac1) (mac2) (mac3))) (and (eq (eval (cadr (nbutlast a))) '*mac2*) (equal a '((mac1) (mac2))) (eq (eval (car (nbutlast a))) '*mac1*) (equal a '((mac1))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-NCONC.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-NCONC.TEST new file mode 100644 index 00000000..27d75656 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NCONC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nconc ;; ;; Source: Steele's book Section 15.2: Lists Page: 269 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 16,1986 ;; ;; Last Update: June 16,1986 ;; ;; Filed As: {eris}cml>test>15-2-nconc.test ;; ;; ;; Syntax: NCONC &rest lists ;; ;; Function Description: NCONC returns a list that is the argument lists concatenated together. The ;; arguments are changed, rather than copied. ;; ;; Argument(s): {list}* ;; ;; Returns: nil or a list ;; ;;ROACH 25-JUN-86 It seems that NCONC is supposed to be a destructive APPEND ;;and that APPEND does in fact allow non list arguments. From page 268 of the ;;manual: ;; ;; "The last argument actually need not be a list but may be any LISP ;;which becomes the tail end of the contructed list. For example, ;;(append '(a b c) 'd) => (a b c . d)" ;; ;;This isn't said so explicitly on page 269 where NCONC is documented, but given ;;the well known similarity of these two functions, the comment "Compare this ;;with append", and the similar examples between APPEND and NCONC used in the ;;manual, it seems intended that NCONC should also "in fact allow non list ;;arguments." I have therefore disabled this test. ;; ;;(do-test "test-nconc0 - syntax checking ( NCONC takes lists as arguments) " ;; (prog2 (setq save car/cdrerr car/cdrerr t) ;; (notany #'(lambda (x) (nlsetq (nconc x))) ;; '(2 a #\k "w" 3.0 #(1 2 3) t :keyword)) ;; (setq car/cdrerr save))) (do-test "test-nconc1 - this test case copied from page 269 of CLtL" (progn (setq x '(a b c)) (setq y '(d e f)) (and (equal (nconc x y) '(a b c d e f)) (equal x '(a b c d e f))))) (do-test "test-nconc2 - input argument is a nil " (eq (nconc) nil)) (do-test "test-nconc3" (and (setq a '(1 2 3) b '(4 5 6) c '(7 8 9) d () e '(10 11 12) f'(20 21 22 23)) (equal (setq q (nconc a b c f d e)) '(1 2 3 4 5 6 7 8 9 20 21 22 23 10 11 12)) (equal a q) (not (or (equal b '(4 5 6)) (equal c '(7 8 9)) (equal f '(20 21 22 23)))) ; (setq a (make-list 5 :initial-element 'rah) b (make-list 5 :initial-element 'quack) x (make-list 10 :initial-element 'foo)) (equal x (setq q (nconc x a b))) (= 20 (list-length q)) (every #'(lambda (x) (eq 'rah (nth x q))) '(10 11 12 13 14)) (every #'(lambda (x) (eq 'foo (nth x q))) '(0 1 2 3 4 5 6 7 8 9)))) (do-test "test-nconc4" (and (equal (nconc '(1 . 2) '(3 . 4)) '(1 3 . 4)) (equal (nconc nil (list 'a (cons 'b 'c))) '(a (b . c))) (equal (nconc '(11 . 22) '(((((1 2) 3) 4) 5) 6) '(33 . 44)) '(11 ((((1 2) 3) 4) 5) 6 33 . 44)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-NINTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-NINTH.TEST new file mode 100644 index 00000000..910353f4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NINTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NINTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 5, 1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-NINTH.TEST ;; ;; ;; Syntax: (NINTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test ninth0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (ninth ,list) ,elm)) ((or cons string) (equal (ninth ,list) ,elm)) (t (eq (ninth ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) ()) (mac '(1 2 3 4 5 6 7 8) ()) (mac '(9 9 9 9 9 9 9 9 9.99955) 9.99955) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 9.999) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) '(t nil . t)) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) '(l . l) ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '((w)) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") "o1") (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) '("foo8" "bar8") ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) 'Hawaii ) ) )) (do-test "test ninth1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (ninth a) '(3 5 100)) '(t t nil)) ) ) (do-test "test ninth2" (let ((aa '(1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 9 10 11 12) 9 10 11 12) 9 10 11 12) 9 10 11 12))) (and (equal (ninth aa) '(1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 9 10 11 12) 9 10 11 12) 9 10 11 12)) (equal (ninth (ninth aa)) '(1 2 3 4 5 6 7 8 (1 2 3 4 5 6 7 8 9 10 11 12) 9 10 11 12)) (equal (ninth (ninth (ninth aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (ninth (ninth (ninth (ninth aa)))) 9) ) ) ) (do-test "test ninth3" (let ((aa (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm))) (setf (ninth aa) (make-list 15)) (setf (ninth (ninth aa)) (make-list 15 :initial-element 'rah)) (setf (ninth(ninth (ninth aa))) "magic kingdom") (equal aa '(a b c d e f g h (nil nil nil nil nil nil nil nil (rah rah rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah rah) nil nil nil nil nil nil) j k l m)) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-NRECONC.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-NRECONC.TEST new file mode 100644 index 00000000..e23d2263 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NRECONC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NRECONC ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 269 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 10, 1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-NRECONC.TEST ;; ;; ;; Syntax: (NRECONC X Y) ;; ;; Function Description: ;; (NRECONC X Y) is exactly the same as ;; (NCONC (NREVERSE X) Y) except that it is potentially more ;; efficient. Both X and Y should be lists. ;; The argument X is destroyed. ;; Compare this with function REVAPPEND. ;; ;; Argument(s): X - a pure list ;; Y - a pure list ;; ;; Returns: a pure list ;; (do-test "test nreconc0" (and (equal (nreconc '(1 2) nil) '(2 1)) (equal (nreconc nil '(1 2)) '(1 2)) (eq (nreconc nil nil) nil) (equal (nreconc '(1 2 (3 4 (5) 6)) '(7 8)) '((3 4 (5) 6) 2 1 7 8)) (equal (nreconc (nreconc '(1 2 (3 4 (5) 6)) '(7 8)) '(9 10)) '(8 7 1 2 (3 4 (5) 6) 9 10)) ) ) (do-test "test nreconc1" (progn (setf a '(1 2 3 4 5) b '((1 . 2) (3 . 4) (5 . 6)) bb (copy-list b) c '( (( 10 9) 8 7) 6 5) cc (copy-list c) d '(11 12 (13 (14 15 ((16)) 17)) 18)) (setf aaa (nreconc a b) bbb (nreconc bb c) ccc (nreconc cc d)) (and (equal aaa '(5 4 3 2 1 (1 . 2) (3 . 4) (5 . 6))) (equal bbb '((5 . 6) (3 . 4) (1 . 2) (( 10 9) 8 7) 6 5)) (equal ccc '(5 6 (( 10 9) 8 7) 11 12 (13 (14 15 ((16)) 17)) 18)) ) ) ) (do-test "test nreconc2" (prog2 (defun fun (x y) (let (save) (mapcar #'(lambda (x) (push x save)) x) (equal (nreconc x y) (nconc save y)))) (and (fun '(a b c d (e . "s") ( 90 100 111) ((( 3 4))) 'hi) '(the tail)) (fun '((1) ((2)) 3 4 5 6 7 8 9 10 11 (((12 13 14))) "isomorphic list" 'do 'you-understand (staghorn sumac)) '((((((((((porky pig)))))))))) ) (fun (append (make-list 50 :initial-element '(Autumn (foliage))) (make-list 50 :initial-element '("buckthorn" (Rhamnus)))) (make-list 100 :initial-element '("The even numbers are cute, like: " (2 4 6))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-NTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-NTH.TEST new file mode 100644 index 00000000..5021c8a1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 265 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-NTH.TEST ;; ;; ;; Syntax: (NTH N LIST) ;; ;; Function Description: ;; (NTH N LIST) returns the Nth element of LIST, where ;; the CAR of the list is the ``zeroth'' element. ;; The argument N must be a non-negative integer. ;; If the length of the list is not greater than N, then the result ;; is NIL, that is, NIL. ;; (This is consistent with the idea that the CAR and CDR ;; of NIL are each NIL.) ;; For example: ;; ;; (NTH 0 '(FOO BAR GACK)) => FOO ;; (NTH 1 '(FOO BAR GACK)) => BAR ;; (NTH 3 '(FOO BAR GACK)) => NIL ;; ;; Compatibility note: This is not ;; the same as the Interlisp function called NTH, ;; which is similar to but not exactly the same as the Common Lisp function ;; NTHCDR. This definition of NTH is compatible ;; with Zetalisp and NIL. ;; Also, some people have used macros and functions called NTH of their own in ;; their old Maclisp programs, which may not work the same way. ;; ;; NTH may be used to specify a PLACE to macro SETF; ;; when NTH is used in this way, the argument N must be less ;; than the length of the LIST. ;; ;; Note that the arguments to NTH are reversed from the order ;; used by most other sequence selector functions such as function ELT. ;; ;; Argument(s): N - a number ;; LIST - a list ;; ;; Returns: anything ;; (do-test "test nth - test cases copied from page 266 of CLtL" (and (eq (nth 0 '(foo bar gack)) 'foo) (eq (nth 1 '(foo bar gack)) 'bar) (eq (nth 3 '(foo bar gack)) ()))) ;;ROACH 25-JUN-86 The NLSETQ's in this test aren't protecting against ;;CL:ERROR's. I have therefore disabled this test. ;; ;;(do-test "test nth - n must be a non-negative integer (CLtL didn't mention ;;about signal an error if n is not a non-negative integer) " ;; (notany #'(lambda (x) (nlsetq (nth x '(foo bar foo1 bar1)))) ;; (list 1.5 (sqrt 4) -1 -2.0 1.999))) (do-test "test nth - if the length of the list is <= n, then the result is nil " (notany #'(lambda (x y) (nth y x)) '((1 2 3 4 5) (2 4) () (a b c (d e f (g h)) r s t y)) '(5 3 1 8))) (do-test "test nth2" (progn (defun fun (list n elm) (cond ((listp elm) (equal (nth n list) elm)) ( t (eq (nth n list) elm)))) (and (fun (list 1 2 3 4) 3 4) (fun (list (cons 4 5) (cons 6 7) (cons 1 (cons 3 4)) 'p) 2 (cons 1 (cons 3 4))) (fun (append (make-list 4 :initial-element 'rah) (make-list 5 :initial-element 'foo)) 4 'foo) (fun (caddr '(1 2 (foo0 foo1 foo2 foo3) (bar1 bar2))) 2 'foo2)))) (do-test "test nth - nth may be used to specify a place to setf" (let ((a (list 1 2 3 4))) (and (= (nth 2 a) 3) (setf (nth 2 a) 300) (= (nth 2 a) 300) (setf (nth 2 a) '(a list)) (eq (car (nth 2 a)) 'a) (rplacd (last a) '(5 6 7 8 9)) (= (nth 8 a) 9)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-NTHCDR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-NTHCDR.TEST new file mode 100644 index 00000000..86d02e65 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NTHCDR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NTHCDR ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 267 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-NTHCDR.TEST ;; ;; ;; Syntax: (NTHCDR N LIST) ;; ;; Function Description: ;; (NTHCDR N LIST) performs the CDR operation N times ;; on LIST, and returns the result. ;; For example: ;; ;; (NTHCDR 0 '(A B C)) => (A B C) ;; (NTHCDR 2 '(A B C)) => (C) ;; (NTHCDR 4 '(A B C)) => NIL ;; ;; In other words, it returns the Nth CDR of the list. ;; Compatibility note: This is similar to the Interlisp function NTH, ;; except that the Interlisp function is one-based instead of zero-based. ;; ;; ;; (CAR (NTHCDR N X)) = (NTH N X) ;; ;; ;; Argument(s): N - a number ;; LIST - a list ;; ;; Returns: a list ;; (do-test "test nthcdr - test cases copied from page 267 of CLtL" (and (equal (nthcdr 0 '(a b c)) '(a b c)) (equal (nthcdr 2 '(a b c)) '(c)) (equal (nthcdr 4 '(a b c)) ()))) (do-test "test nthcdr1" (progn (defun fun (x y z) (cond ((listp z) (equal (nthcdr y x) z)) (t (eq (nthcdr y x) z)))) ; (and (fun '(1 2 3 4 5 6) 2 '(3 4 5 6)) (fun '(((((a b c d))))) 2 '()) (fun '() 3 nil) (fun (append '(a b c) '(0 1 2 3) '("u" "v" "k")) 4 '(1 2 3 "u" "v" "k")) (fun (nth 1 '((a b c) (11 22 33 44 (55 66 77)) "p" "q" "r")) 4 '((55 66 77)))))) (do-test "test nthcdr2" (let ((a (append (make-list 10 :initial-element 'east) (make-list 10 :initial-element 'west) (list 11 22 33 44 55) (cons 5 (cons 4 (cons 3 (cons 2 (cons 1 nil)))))))) (and (eq (car (nthcdr 10 a)) (nth 10 a)) (equal (nthcdr 28 a) '(2 1)) (eq (car (nthcdr 20 a)) 11) (eq (nthcdr 30 a) nil) (eq (car (nthcdr 24 a)) 55)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-POP.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-POP.TEST new file mode 100644 index 00000000..79da7ff4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-POP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: POP ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 271 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 2, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-POP.TEST ;; ;; ;; Syntax: (POP PLACE) ;; ;; Function Description: ;; The form PLACE should be the name of a generalized variable containing a list. ;; The result of POP is the car of the contents of PLACE, and as a side effect the cdr ;; of the contents is stored back into PLACE. ;; ;; Argument(s): PLACE - a list ;; ;; Returns: anything ;; (do-test "test pop - test cases copied from page 271 of CLtL" (progn (SETQ STACK '(A B C)) (and (EQ (POP STACK) 'A) (EQUAL STACK '(B C)) ))) (do-test "test pop0" (and (setq a '(1 2 3 4)) (= (pop a) 1) (= (pop a) 2) (= (pop a) 3) (= (pop a) 4) (eq (pop a) nil) (eq (pop a ) ()) )) (do-test "test pop1" (let ((a `(a #(1 2 3 4) 100.0 (d e "f" #\i) ,(function +) k) )) (and (eq (pop a) 'a) ; (= (pop (cdr a)) 100.0) ; (vectorp (pop a)) ; (= (funcall (pop (cdr a)) 1 2 3) 6) ; (equal a '( (d e "f" #\i) k) ) ; (string-equal (pop (cddar a)) "F") ; (eq (pop (cdr a)) 'k) ; (equal a '((d e #\i))) ; (char= (pop (cddar a)) #\i) ; (equal (pop a) '(d e)) (eq a ()) ))) (do-test "test pop2" (progn (setq a '(10 20 30 40 50 (60 77 88) (a b c d) (e (f (g (h)))) i j k (99 100))) (setq aa a b nil) (dotimes (i (list-length a)) (setq b (cons (pop a) b))) (equal aa (reverse b)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSH.TEST new file mode 100644 index 00000000..544f85db --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PUSH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 269 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 1, 1986 Sye/ Create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-PUSH.TEST ;; ;; ;; Syntax: (PUSH ITEM PLACE) ;; ;; Function Description: ;; The form PLACE should be the name of a generalized variable containing a list; ;; ITEM may refer to any Lisp object. The ITEM is consed onto the front of the list, and the ;; augmented list is stored back into PLACE and returned. The form PLACE may be any form acceptable ;; as a generalized variable to SETF. If the list held in PLACE is viewed as a push-down stack, ;; then PUSH pushes an element onto the top of the stack. ;; ;; ;; Argument(s): ITEM - anything ;; PLACE - a list ;; ;; Returns: a list ;; (do-test "test push - test cases copied from page 270 of CLtL" (progn (setq x '(a (b c) d )) (and (equal (push 5 (cadr x)) '(5 b c)) (equal x '(a (5 b c) d)) ))) (do-test "test push - PLACE should be a generalized variable containing a list" (progn (setf a '() b '(1 2 3) c '(1 2 3 (4 5 6) 7 8 9) d '(volume 10 weight 20 height 30)) (and (equal (push t a) '(t)) (equal a '(t)) (equal (push t (cdr a)) '(t)) (equal a '(t t)) ; (equal (push 100 (rest b)) '(100 2 3)) (equal b '(1 100 2 3)) (equal (push 200 (first b)) '(200 . 1)) (equal b '((200 . 1) 100 2 3)) ; (equal (push 700 (fifth c)) '(700 . 7)) (equal c '(1 2 3 (4 5 6) (700 . 7) 8 9)) (equal (push "toy" (cadddr c)) '("toy" 4 5 6)) (equal (nth 3 c) '("toy" 4 5 6)) (equal (push '(88 . 99) (cdddr (cdddr c))) '((88 . 99) 9)) (equal c '(1 2 3 ("toy" 4 5 6) (700 . 7) 8 (88 . 99) 9)) ; (equal (push '25 (cddr d)) '(25 weight 20 height 30)) (equal (push 'width (cddr d)) '(width 25 weight 20 height 30)) (equal d '(volume 10 width 25 weight 20 height 30)) ) ) ) (do-test "test push - ITEM may refer to any Lisp object" (and (progn (setf list '(1 2 3 4 5 6 7 8 9 10 11 12)) (push "flip a coin" (cddddr (cddddr (cddddr list)))) (push '| a symbol with a long name | (cddr (cddddr (cddddr list)))) (push #\* (cddddr (cddddr list))) (push (1+ 99) (cddr (cddddr list))) (push #30r20 (cddddr list)) (push (make-list 5 :initial-element 'rah) (cddr list)) (push t (first list)) (equal list '((t . 1) 2 (rah rah rah rah rah) 3 4 60 5 6 100 7 8 #\* 9 10 | a symbol with a long name | 11 12 "flip a coin") ) ) ;; (progn (setf list ()) (push #'* list) (push #'evenp list) (push #'list* list) (push #'(lambda (x y z) (* x y z)) list) (push #'null list) (and (eq (funcall (car list) t) nil) (= (apply (nth 1 list) 2 3 '(4)) 24) (equal (funcall (caddr list) 1 2 3) '(1 2 . 3)) (eq (every (fourth list) '(2 4 6 8 10)) t) (equalp (apply (car (last list)) '(2 3 10)) 60.000) )) ;; (progn (setf list () var1 10 var2 'a) (push 'var1 list) (push 'var2 list) (and (= (symbol-value (nth 1 list)) 10) (eq (symbol-value (nth 0 list)) 'a) )) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSHNEW.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSHNEW.TEST new file mode 100644 index 00000000..6c799b68 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSHNEW.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PUSHNEW ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 270 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; JULY 1,1986 SYE/ CREATE TEST CASES ;; ;; Filed As: {ERIS}CML>TEST>15-2-PUSHNEW.TEST ;; ;; ;; Syntax: (PUSHNEW ITEM PLACE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; The form PLACE should be the name of a generalized variable containing a list; ITEM may refer to any Lisp ;; object. If the item is not already a member of the list (as determined by comparisons using the :test ;; predicate, which defaults to eql) ,then the ITEM is consed onto the front of the list, and the augmented ;; list is stored back into PLACE and returned ; otherwise the unaugmented list is returned. ;; ;; Argument(s): ITEM - anything ;; PLACE - a list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a list ;; (do-test "test pushnew - test cases copied from page 270 of CLtL" (progn (setq x '(a (b c) d)) (and (equal (pushnew 5 (cadr x)) '(5 b c)) (equal (pushnew 'b (cadr x)) '(5 b c)) ))) (do-test "test pushnew0" (and (progn (setq a ()) (equal (pushnew () a) '(nil))) (progn (setq a '(a b)) (and (equal (pushnew 'c a) '(c a b)) (equal a '(c a b)) (equal (pushnew 'c a) '(c a b)) (equal (push 'c a) '(c c a b)) (equal (pushnew 'c (cddr a)) '(c a b)) (equal a '(c c c a b)) )) (progn (setq a '(item1 item2 item3 item4)) (and (equal (pushnew 'cup (cddddr a)) '(cup)) (equal (pushnew 'cup (cdddr a)) '(item4 cup)) (equal (pushnew 'knife (cdddr a)) '(knife item4 cup)) (equal (pushnew 'item3 (cddr a)) '(item3 knife item4 cup)) (equal (pushnew 'milk (cddr a)) '(milk item3 knife item4 cup)) (equal (pushnew 'cup (cdr a)) '(item2 milk item3 knife item4 cup)) (equal (pushnew 'bottle (cdr a)) '(bottle item2 milk item3 knife item4 cup)) (equal a '(item1 bottle item2 milk item3 knife item4 cup)) )))) (do-test "test pushnew - with :test/:test-not/:key keywords" (and (progn (setq list '(1 "bottle" 2 milk 3 (knife) 4 cup 5 #\a)) (defun fun (x y) (equal list (pushnew x list :test y))) (every #'fun '(1.0 "BOTTLE" 3.000 (knife) #\A) '(= equalp equalp equal equalp))) ; (progn (setq list '(1 "bottle" 2 milk 3 (knife) 4 cup 5 #\a)) (pushnew "Bottle" list :test #'equal) (pushnew 1.0 list :test #'equal) (pushnew '(knife) list :test #'eq) (pushnew 3.0 list :test #'eq) (equal list '(3.0 (knife) 1.0 "Bottle" 1 "bottle" 2 milk 3 (knife) 4 cup 5 #\a))) ;; ;; (progn (setq list '(1 2 3 4 5 (6 7 8) 9 10)) (pushnew 12 list :test-not #'(lambda (x y) (or (numberp y) (listp y)) )) (pushnew #\a list :test-not #'(lambda (x y) (characterp #\a))) (pushnew "lucid" (cadddr (cddddr list)) :test-not #'(lambda (x y) t)) (equal list '(#\a 12 1 2 3 4 5 ("lucid" 6 7 8) 9 10))) ;; ;; (progn (setq list '((1111 2222 3333) (4444 5555 6666 ))) (and (equal (pushnew '(1111) list :key #'car) '((1111 2222 3333) (4444 5555 6666)) ) (equal (pushnew '(100 200) (cdr list) :key #'cadr) '((100 200) (4444 5555 6666))) (equal (pushnew '(1111.0) list :test #'= :key #'car) '((1111 2222 3333) (100 200) (4444 5555 6666))) (equal (pushnew '(1111.0 17) list :test-not #'/= :key #'cadr) '((1111.0 17) (1111 2222 3333) (100 200) (4444 5555 6666))) )) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-REST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-REST.TEST new file mode 100644 index 00000000..9e8b6a2d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-REST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: REST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-REST.TEST ;; ;; ;; Syntax: (REST LIST) ;; ;; Function Description: ;; REST means the same as CDR but mnemonically complements FIRST. ;; macro SETF may be used with REST to replace the CDR of a list ;; with a new value. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST REST0" ;; ;; The tests were incorporated in the test file "15-1-cdr-and-rest.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-REVAPPEND.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-REVAPPEND.TEST new file mode 100644 index 00000000..699a1689 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-REVAPPEND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: REVAPPEND ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 269 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 3, 1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-REVAPPEND.TEST ;; ;; ;; Syntax: (REVAPPEND X Y) ;; ;; Function Description: ;; (REVAPPEND X Y) is exactly the same as ;; (APPEND (REVERSE X) Y) except that it is potentially more ;; efficient. Both X and Y should be lists. ;; The argument X is copied, not destroyed. ;; Compare this with function NRECONC, which destroys its first argument. ;; ;; Argument(s): X - a pure list ;; Y - a pure list ;; ;; Returns: a pure list ;; (do-test "test revappend0" (and (equal (revappend '(1 2) nil) '(2 1)) (equal (revappend nil '(1 2)) '(1 2)) (eq (revappend nil nil) nil) (equal (revappend '(1 2 (3 4 (5) 6)) '(7 8)) '((3 4 (5) 6) 2 1 7 8)) (equal (revappend (revappend '(1 2 (3 4 (5) 6)) '(7 8)) '(9 10)) '(8 7 1 2 (3 4 (5) 6) 9 10)) ) ) (do-test "test revappend - For (revappend x y), The argument x is copied, not destroyed." (progn (setf a '(1 2 3 4 5) aa a b '((1 . 2) (3 . 4) (5 . 6)) bb b c '( (( 10 9) 8 7) 6 5) cc c) (setf aaa (revappend a b) bbb (revappend b c) ccc (revappend c a)) (and (equal a aa) (equal b bb) (equal c cc) (equal aaa '(5 4 3 2 1 (1 . 2) (3 . 4) (5 . 6))) (equal bbb '((5 . 6) (3 . 4) (1 . 2) (( 10 9) 8 7) 6 5)) (equal ccc '(5 6 (( 10 9) 8 7) 1 2 3 4 5)) ) ) ) (do-test "test revappend1" (prog2 (defun fun (x y) (let (save) (mapcar #'(lambda (x) (push x save)) x) (equal (revappend x y) (append save y)))) (and (fun '(a b c d (e . "s") ( 90 100 111) ((( 3 4))) 'hi) '(the tail)) (fun '((1) ((2)) 3 4 5 6 7 8 9 10 11 (((12 13 14))) "isomorphic list" 'do 'you-understand (staghorn sumac)) '((((((((((porky pig)))))))))) ) (fun (append (make-list 50 :initial-element '(Autumn (foliage))) (make-list 50 :initial-element '("buckthorn" (Rhamnus)))) (make-list 100 :initial-element '("The even numbers are cute, like: " (2 4 6))) ) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-SECOND.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-SECOND.TEST new file mode 100644 index 00000000..663182fe --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-SECOND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SECOND ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-SECOND.TEST ;; ;; ;; Syntax: (SECOND LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST SECOND0" ;; ;; The test cases were incorporated in "15-1-cadr-and-second.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-SEVENTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-SEVENTH.TEST new file mode 100644 index 00000000..65935dd9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-SEVENTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SEVENTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 5 ,1986 Sye / create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-SEVENTH.TEST ;; ;; ;; Syntax: (SEVENTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test seventh0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (seventh ,list) ,elm)) ((or cons string) (equal (seventh ,list) ,elm)) (t (eq (seventh ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) 7) (mac '(1 2 3 4 5 6 7 8) 7) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 7.00) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) 'non-nil) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) '((i) (((ip)))) ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '((((t)))) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") #\F) (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) '(foo6 bar6 gack6) ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |Hawaii| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) "vacations" ) ) )) (do-test "test seventh1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (seventh a) '(2 10) '(3 5 100)) '(2 5)) ) ) (do-test "test seventh2" (let ((aa '(1 2 3 4 5 6 (1 2 3 4 5 6 (1 2 3 4 5 6 (1 2 3 4 5 6 7 8 9 10 11 12) 7 8 9 10 11 12) 7 8 9 10 11 12) 7 8 9 10 11 12))) (and (equal (seventh aa) '(1 2 3 4 5 6 (1 2 3 4 5 6 (1 2 3 4 5 6 7 8 9 10 11 12) 7 8 9 10 11 12) 7 8 9 10 11 12)) (equal (seventh (seventh aa)) '(1 2 3 4 5 6 (1 2 3 4 5 6 7 8 9 10 11 12) 7 8 9 10 11 12)) (equal (seventh (seventh (seventh aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (seventh (seventh (seventh (seventh aa)))) 7) ) ) ) (do-test "test seventh3" (let ((aa (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm))) (setf (seventh aa) (make-list 15)) (setf (seventh (seventh aa)) (make-list 15 :initial-element 'rah)) (setf (seventh(seventh (seventh aa))) "magic kingdom") (equal aa '(a b c d e f (nil nil nil nil nil nil (rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah rah rah rah) nil nil nil nil nil nil nil nil) h i j k l m)) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-SIXTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-SIXTH.TEST new file mode 100644 index 00000000..fc9a6f47 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-SIXTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SIXTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 3,1986 ;; July 3, 1986 Sye/ create test cases ;; ;; Last Update: July 3,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-SIXTH.TEST ;; ;; ;; Syntax: (SIXTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (SIXTH X) = (NTH 6 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test sixth0" (and (eq (sixth ()) ()) (eq (sixth '(1)) ()) (eq (sixth '(1 2)) ()) (eq (sixth '(1 2 3)) ()) (eq (sixth '(1 2 3 4)) ()) (eq (sixth '(1 2 3 4 5)) ()) (eq (sixth '(1 2 3 4 5 6)) 6) (eq (sixth '(a b c d e f g)) 'f) (equal (sixth '(nil nil nil t t (nil . t) non-nil)) '(nil . t)) )) (do-test "test sixth1" (and (eq (sixth '(Do a deer a female deer !!)) 'deer) (equal (sixth '("Re" "a" "drop" "of" "golden" "sun---nn" ! ! !)) "sun---nn") (equal (sixth '((Mi) (a) (name) (i . call) (myself) (Fa a (long logn .way) to . run) nil)) '(Fa a (long logn .way) to . run)) (eq (sixth '(|So| #\a |needle| "...." Oh! #\I |forgot|)) #\I) (equal (sixth '( A needle pulling thread "yes !" ((((((a) needle) pulling) "thread") "--") . "--ead"))) '((((((a) needle) pulling) "thread") "--") . "--ead") ) (equal (sixth '((so . how) (do . you) (like . my) (do . re) (mi . fa) (so la ti ( and . do) ?? ) ) ) '(so la ti ( and . do) ??) ) ) ) (do-test "test sixth2" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (sixth ,list) ,elm)) ((or cons string) (equal (sixth ,list) ,elm)) (t (eq (sixth ,list) ,elm)) ) ) (and (mac '(New Mail for Sye dot pasa xsis xerox) 'pasa) (mac (make-list 5) nil) (mac (sixth '(1 2 3 4 5 (10 20 30 40 50 60 70 80) 7 8 9)) 60) (mac (sixth (sixth (sixth (sixth '(a b c d e (1 2 3 4 5 (11 22 33 44 55 ( 111 222 333 444 555 (aa bb cc dd ee (ff . gg) hh ii) 777) 77) 7) gg) )))) '(ff . gg)) (mac '(blackberries "monroe" (county) (tennessee . olympus) om-2 ((with 90mm . macro) (lenx . kodachrome) . peter) 'arnold 'inc) '((with 90mm . macro) (lenx . kodachrome) . peter)) )) ) (do-test "test sixth - using setf and rplacd with sixth" (progn (setq list (list #'+ #'- #'* #'= #'<= #'max #'equalp)) (setq aa (mapcar #'(lambda (x) (funcall x 10 20)) list)) (eq (sixth aa) 20) (setf (sixth list) #'cons) (setq aa (mapcar #'(lambda (x) (funcall x 10 20)) list)) (equal (sixth aa) '(10 . 20)) (rplacd (sixth aa) "end of testing") (equal (sixth aa) '(10 . "end of testing")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-TENTH.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-TENTH.TEST new file mode 100644 index 00000000..eb5e02b1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-TENTH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TENTH ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 5, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-2-TENTH.TEST ;; ;; ;; Syntax: (TENTH LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (do-test "test tenth0" (prog2 (defmacro mac (list elm) `(typecase ,elm (number (= (tenth ,list) ,elm)) ((or cons string) (equal (tenth ,list) ,elm)) (t (eq (tenth ,list) ,elm)) ) ) (and (mac () ()) (mac '(1) ()) (mac '(1 2) ()) (mac '(1 2 3) ()) (mac '(1 2 3 4) ()) (mac '(1 2 3 4 5) ()) (mac '(1 2 3 4 5 6) ()) (mac '(1 2 3 4 5 6 7) ()) (mac '(1 2 3 4 5 6 7 8) ()) (mac '(9 9 9 9 9 9 9 9 9.99955) ()) (mac '(1 2.0 3.3 4 5.5 6 7.00 8.005 9.999 10.001) 10.001) (mac '(nil nil nil t t (nil . t) non-nil (t . t) (t nil . t) ((t))) '((t))) (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) 'm ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)))) (u v) ((w)) (x . y) ((y)) ((z))) '(x . y) ) (mac '(foo foo1 foo2 ((foo3)) (foo4 . foo5) 'foo #\F #\o "o1" "foo2") "foo2") (mac '((foo bar) (foo1 . bar1) ((foo2 bar2)) ((foo3) bar3) (foo4 (bar4)) (((foo5 bar5))) (foo6 bar6 gack6) "foo7-bar7" ("foo8" "bar8") (((('foo9))) (((('bar9)))) bar10) nil t) '(((('foo9))) (((('bar9)))) bar10) ) (mac (append '(plus + (minus -) times *) '("excitint" "vacations" "to" |HAWAII| |Mexico| (the Pacific Northwest) ((and)) (the . Orient))) '|Mexico| ) ) )) (do-test "test tenth1" (progn (setq a (list #'= #'- #'* #'endp #'list #'max #'min #'evenp #'oddp #'(lambda (x) (* 100 x)))) (equal (mapcar (tenth a) '(3 5 100)) '(300 500 10000)) ) ) (do-test "test tenth2" (let ((aa '(1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11 12) 10 11 12) 10 11 12) 10 11 12))) (and (equal (tenth aa) '(1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11 12) 10 11 12) 10 11 12)) (equal (tenth (tenth aa)) '(1 2 3 4 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11 12) 10 11 12)) (equal (tenth (tenth (tenth aa))) '(1 2 3 4 5 6 7 8 9 10 11 12)) (eq (tenth (tenth (tenth (tenth aa)))) 10) ) ) ) (do-test "test tenth3" (let ((aa (copy-list '(a b c d e f g h i j k l m)))) (setf (tenth aa) (make-list 15)) (setf (tenth (tenth aa)) (make-list 15 :initial-element 'rah)) (setf (tenth(tenth (tenth aa))) "magic kingdom") (equal aa '(a b c d e f g h i (nil nil nil nil nil nil nil nil nil (rah rah rah rah rah rah rah rah rah "magic kingdom" rah rah rah rah rah) nil nil nil nil nil) k l m)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-2-THIRD.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-2-THIRD.TEST new file mode 100644 index 00000000..35544af1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-THIRD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: THIRD ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.2 Lists ;; Page: 266 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-2-THIRD.TEST ;; ;; ;; Syntax: (THIRD LIST) ;; ;; Function Description: ;; These functions are sometimes convenient for accessing particular ;; elements of a list. FIRST is the same as function CAR, ;; SECOND is the same as CADR, THIRD is the ;; same as CADDR, and so on. ;; Note that the ordinal numbering used here is one-origin, ;; as opposed to the zero-origin numbering used by function NTH: ;; ;; (FIFTH X) = (NTH 4 X) ;; ;; ;; macro SETF may be used with each of these functions to store ;; into the indicated position of a list. ;; ;; Argument(s): LIST - a list ;; ;; Returns: anything ;; (DO-TEST "TEST THIRD0" ;; ;; the test cases were incorporated in the test file "15-1-caddr-and-third.test" ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACA.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACA.TEST new file mode 100644 index 00000000..498662db --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACA.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RPLACA ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.3 Alteration of List Structure ;; Page: 272 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 1, 1986 Sye/ create test cases ;; ;; Filed As: {ERIS}CML>TEST>15-3-RPLACA.TEST ;; ;; ;; Syntax: (RPLACA X Y) ;; ;; Function Description: ;; (RPLACA X Y) changes the CAR of X to Y and returns ;; (the modified) X. X must be a cons, but Y may be any ;; Lisp object. ;; For example: ;; ;; (SETQ G '(A B C)) ;; (RPLACA (CDR G) 'D) => (D C) ;; Now G => (A D C) ;; ;; ;; Argument(s): X - a list ;; Y - anything ;; ;; Returns: a list ;; (do-test "test rplaca - test case copied from page 272 of CLtL" (let () (setq g '(a b c)) (and (equal (rplaca (cdr g) 'd) '(d c)) (equal g '(a d c))))) (do-test "test rplaca0" (and (equal (rplaca '(a b c d) 'e) '(e b c d)) (equal (rplaca '(a b c d) #\k) '(#\k b c d)) (equal (rplaca '((a) b c d) 'e) '(e b c d)) (equal (rplaca '((((((1))))) . 2) '(3 . 6)) '((3 . 6) . 2)) (equal (rplaca '(1 2 3 . 4) ()) '( () 2 3 . 4)) )) (do-test "test rplaca1" (let () (setq a '(1 2 3 4 5)) (and (prog2 (rplaca a (nthcdr 2 a)) (equal a '((3 4 5) 2 3 4 5))) (prog2 (rplaca (cdar a) '(4 . 4)) (equal a '((3 (4 . 4) 5) 2 3 (4 . 4) 5))) (prog2 (rplaca (cddar a) "hi") (equal a '((3 (4 . 4) "hi") 2 3 (4 . 4) "hi"))) ))) (do-test "test rplaca2" (let () (setq ab '(5 4 3 2 1)) (rplaca (nthcdr 2 ab) (nthcdr 3 ab)) (rplaca ab (nthcdr 2 ab)) (tree-equal ab '(((2 1) 2 1) 4 (2 1) 2 1)) )) (do-test "test rplaca3" (prog2 (rplaca (rplaca (rplaca (rplaca (setq a '(1 2 . 3)) 'foo1) 'foo2) 'foo3) 'foo4) (equal a '(foo4 2 . 3)) )) (do-test "test rplaca4" (progn (setq aa '(a b (c d (e f)) g h) aaa (append aa nil) ) (rplaca aa "bar1") (rplaca (cdaddr aa) "bar2") (rplaca (cdadr (cdaddr aa)) "bar3") (and (equal aa '("bar1" b (c "bar2" (e "bar3")) g h)) (equal aaa '(a b (c "bar2" (e "bar3")) g h)) ))) (do-test "test rplaca5" (progn (setq a (make-list 5) b '(v w x y z)) (mapcar #'(lambda(x y) (rplaca (nthcdr x a) (nthcdr y b))) '(0 1 2 3 4) '(0 1 2 3 4)) (equal a '((v w x y z) (w x y z) (x y z) (y z) (z))) )) (do-test "test rplaca6" (progn (setq a '(1)) (rplaca a a) (= (list-length a ) 1))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACD.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACD.TEST new file mode 100644 index 00000000..108c1aec --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RPLACD ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.3 Alteration of List Structure ;; Page: 272 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; July 3, 1986 Sye/ create the test cases ;; ;; Filed As: {ERIS}CML>TEST>15-3-RPLACD.TEST ;; ;; ;; Syntax: (RPLACD X Y) ;; ;; Function Description: ;; (RPLACD X Y) changes the CDR of X to Y and returns ;; (the modified) X. X must be a cons, but Y may be ;; any Lisp object. ;; For example: ;; ;; (SETQ X '(A B C)) ;; (RPLACD X 'D) => (A . D) ;; Now X => (A . D) ;; ;; ;; Argument(s): X - a list ;; Y - anything ;; ;; Returns: a list ;; (do-test "test rplacd - test case copied from page 273 of CLtL" (and (SETQ X '(A B C)) (EQUAL (RPLACD X 'D) '(A . D)) (EQUAL X '(A . D)) ) ) (do-test "test rplacd1" (and (equal (rplacd '(1) 2) '(1 . 2)) (equal (rplacd '(1 . 3) 2) '(1 . 2)) (equal (rplacd '(2 4 . 6) ()) '(2)) (equal (rplacd '(a (c d (e f))) '(g . h)) '(a g . h) ) ) ) (do-test "test rplacd - use rplacd to construct circular lists" (let (( a (copy-list '(1 2 3 4))) (b (copy-list '(11 22 (33 44) 55 66)))) (rplacd (nthcdr 1 a) a) (rplacd (nthcdr 2 b) b) (not (and (list-length a) (list-length b))) ) ) (do-test "test rplacd2" (and (prog2 (setq a '(To further (the wise use of) (land and water)) b '(To work (for (the (stablilization))) of world (population)) c '(To (protect "all" life . from) pollution #\, "radiation" (and toxic) substance) d '(Goal 1) e '(Goal 2) f '(Goad 3)) (and (equal (rplacd (last f) c) (cons '3 c)) (equal (rplacd (last b) f) (append '((population)) f)) (equal (rplacd (last e) b) (cons '2 b)) (equal (rplacd (last a) e) (cons '(land and water) e)) (equal (rplacd (cdr d) a) (cons '1 a)) (equal d '(Goal 1 To further (the wise use of) (land and water) Goal 2 To work (for (the (stablilization))) of world (population) Goad 3 To (protect "all" life . from) pollution #\, "radiation" (and toxic) substance)) ) ) ;; (progn (setq a '(((1 2) 4 5) (6 7) 8 9)) (rplacd (last a) 10) (rplacd (cdr (second a)) 7.7) (rplacd (cddar a) 5.5) (rplacd (cdaar a) 2.22) (equal a '(((1 2 . 2.22) 4 5 . 5.5) (6 7 . 7.7) 8 9 . 10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBLIS.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBLIS.TEST new file mode 100644 index 00000000..6f10300b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBLIS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSUBLIS ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 15, 1986 ;; ;; Last Update: Aug. 15, 1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-NSUBLIS.TEST ;; ;; ;; Syntax: (NSUBLIS ALIST TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; NSUBLIS makes substitutions for objects in a tree (a structure of conses). The first argument to NSUBLIS is an ;; association list. The second argument is the tree in which substitutions are to be made, as for SUBST. ;; NSUBLIS looks at all subtrees and leaves of the tree; if a subtree or leaf appears as a key in the association ;; list (that is, the key and the subtree or leaf satisfy the test), it is replaced by the object it is associated ;; with. This operation is non-destructive. In effct, NSUBLIS can perform several SUBST operations simultaneously. ;; NNSUBLIS is like NSUBLIS but destructively modifieds the relevant parts of the tree. ;; ;; Argument(s): LIST - an association list ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test nsublis - test cases copied from page 274 of CLtL" (and (equal (nsublis '( (x . 100) (z . zprime) ) '(plus x (minus g z x p) 4 . x)) '(plus 100 (minus g zprime 100 p) 4 . 100) ) (equal (nsublis '(((+ x y) . (- x y)) ((- x y) . (+ x y))) '(* (/ (+ x y) (+ x p)) (- x y)) :test #'equal) '(* (/ (- x y) (+ x p)) (+ x y)) ))) (do-test "test nsublis 1" (and (prog2 (setq a '(>= (* x y) (+ x y) (- x y) (/ x y) )) (equal (nsublis '( (x . xx) (y . yy) ) a) '(>= (* xx yy) (+ xx yy) (- xx yy) (/ xx yy)) )) (prog2 (setq a '(1 2 (2 3 4) ((3) 4) 5 6 ( 6 4 2 1))) (equal (nsublis '( (2 . 3) (3 . 6) (6 . 1)) a) '(1 3 (3 6 4) ((6) 4) 5 1 (1 4 3 1)) )) (prog2 (setq a '( (#\a #\b) #\c ((#\d)) #\e)) (equal (nsublis '((nil . 7)) a) '( (#\a #\b . 7) #\c ((#\d . 7) . 7) #\e . 7))) (prog2 (setq a '()) (equal (nsublis '(( nil . "empty list")) a) "empty list")))) (do-test "test nsublis - with :TEST keyword" (and (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (equal (nsublis '((1 . 3.0) (3.0 . 5.0) (5.0 . 7.0) (7 . 9.0) (9 . 1.0)) a :test #'equalp) '(3.0 2.0 5.0 (4.0) (7.0 6.0 (9.0)) (8 ((1.0)) 10)))) (prog2 (setq a '( "I" "buy" ("coke") (("lime")) "plus" ("lemon" . "banana"))) (equal (nsublis '((#\i . "apricot") (#\e . "opium") (#\a . "coffee")) a :test #'(lambda (n m) (and (stringp n) (find m n)))) '("I" "buy" ("opium") (("apricot")) "plus" ("opium" . "coffee")))) (prog2 (setq a '( ((( park . place) (small . talk) (small . 80))) (park . play) ( (small . 72) ) (park . small))) (equal (nsublis '(((park . play) . (pool . swim)) ( (small . talk) . (public . speech))) a :test #'equal) '(((( park . place) (public . speech) (small . 80))) (pool . swim) ( (small . 72) ) (park . small)) )) (prog2 (setq a '(2 5 7 13 27)) (equal (nsublis '( (dummy . "star")) a :test #'(lambda (y x) (and (listp y) (evenp (first y))))) "star")))) (do-test "test nsublis - with :TEST-NOT keyword" (and (prog2 (setq a '(78 65 (45 ((66) 23) 121) 8 100)) (equal (nsublis '(( 30 . "<= 30") (50 . "<= 50") (80 . "<= 80")) a :test-not #'(lambda (y x) (or (listp y) (> y x)))) '("<= 80" "<= 80" ("<= 50" (("<= 80") "<= 30") 121) "<= 30" 100))) (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (equal (nsublis '(((4.0) . foo) ((9.0) . bar)) a :test-not #'(lambda (y x) (not (equalp x y)))) '(1 2.0 3 foo (5 6.0 (7.0)) (8 (bar) 10)))) (prog2 (setq a '((John 250) (Susan 78) (Henry 140) (Kelly 115) (Mark 350))) (equal (nsublis '( ((Edward 200) . (Tom 214))) a :test-not #'equal) '(Tom 214))))) (do-test "test nsublis - with :KEY keyword" (and (prog2 (setq a '( (a b c) (1 2 3) (#\q #\w #\e) ("a" "b" "c"))) (equal (nsublis '((b . bb) (#\w . #\p) ("b" . "bb")) a :test #'equal :key #'(lambda (k) (if (listp k) (second k) ))) '(bb (1 2 3) #\p "bb"))) (prog2 (setq a '( (1 2 3 4) (2 3) (8 9 0 12) (1))) (equal (nsublis '( ( (4) . four) ( (12) . twelve)) a :test #'equal :key #'(lambda (x) (if (listp x) (last x) '(3)))) '(four (2 3) twelve (1)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF-NOT.TEST new file mode 100644 index 00000000..ba503349 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSUBST-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: AUG. 14,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-NSUBST-IF-NOT.TEST ;; ;; ;; Syntax: (NSUBST-IF-NOT NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; NSUBST is a destructive version of SUBST. The list structure of ;; TREE is altered by destructively replacing with NEW ;; each leaf of the TREE such that OLD and the leaf ;; satisfy the test. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test nsubst-if-not 1" (and (prog2 (setq a '(1 2 3 (3 2 1) ((2)) (3 (1)))) (equal (nsubst-if-not 88 #'(lambda (x) (or (not (numberp x)) (not (eq x 2)))) a) '(1 88 3 (3 88 1) ((88)) (3 (1)) ))) (prog2 (setq a '("one" ("two" . "three") ("four") "five" "six" . "seven")) (equal (nsubst-if-not 'gotchu #'(lambda (x) (or (not (stringp x)) (not (find #\r x)))) a) '("one" ("two" . gotchu) (gotchu) "five" "six" . "seven"))) (prog2 (setq a '(10 13 12 (17 18) ((30 5) 31 4) 40 -5)) (equal (nsubst-if-not "***" #'(lambda (x) (or (not (listp x) ) (some #'(lambda (x) (not (numberp x))) x) (/= (apply #'+ x) 35) )) a) '(10 13 12 "***" ("***" . "***") . "***"))) (prog2 (setq a '()) (equal (nsubst-if-not "April fool" #'consp a) "April fool")))) (do-test "test nsubst-if-not -- with :KEY keyword" (and (prog2 (setq a `("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (equal (nsubst-if-not #\y #'stringp a :key #'(lambda (x) (if (and (listp x) (= (list-length x) 3)) (first x) "dummy" ))) '("sleepy" #\y "grouchy" . #\y))) (prog2 (setq a '("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (equal (nsubst-if-not '(foo) #'(lambda (x) (find #\s x :test #'char-equal)) a :key #'(lambda (z) (typecase z (string z) (null "s") (symbol (string z)) (t "s")))) '("sleepy" (sneezy ((foo) bashful (foo)) (foo)) (foo) (foo) snow (foo)))) (prog2 (setq a '(a b c (10 3 5 2 5 8) d (3 4 5))) (eq (nsubst-if-not 'end-of-testing #'(lambda (x) (/= (apply #'- x) -13.0)) a :key #'cadddr) 'end-of-testing)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF.TEST new file mode 100644 index 00000000..a9e158bc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSUBST-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Kelly Roach ; Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 14,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-NSUBST-IF.TEST ;; ;; ;; Syntax: (NSUBST-IF NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; NSUBST is a destructive version of SUBST. The list structure of ;; TREE is altered by destructively replacing with NEW ;; each leaf of the TREE such that OLD and the leaf ;; satisfy the test. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test nsubst-if 1" (and (prog2 (setq a '(10 20 (10.0) (10 . 10.0) 100 30 (10) . 10) aa (copy-tree a)) (and (equal (nsubst-if 99.99 #'(lambda (x) (equalp x 10)) a) '(99.99 20 (99.99) (99.99 . 99.99) 100 30 (99.99) . 99.99)) (equal (nsubst-if 99.99 #'(lambda (x) (eql x 10)) aa) '(99.99 20 (10.0) (99.99 . 10.0) 100 30 (99.99) . 99.99)) ) ) (prog2 (setq a '( (apple . orange) (banana) ((papaya) (tomato) mongo) watermelon . cantolope) aa (copy-tree a) ) (and (equal (nsubst-if 'yummy #'null a) '( (apple . orange) (banana . yummy) ((papaya . yummy) (tomato . yummy) mongo . yummy) watermelon . cantolope) ) (equal (nsubst-if t #'atom aa) '(( t . t) (t . t) ((t . t) (t . t) t . t) t . t) ) ) ) (prog2 (setq a '("string1" ("sTring" "string2") ((((( "string")))) "STRING") "string3" ("string" "string4") ) aa (copy-tree a) ) (and (equal (nsubst-if "bow" #'(lambda (x) (and (stringp x) (string= x "string"))) a) '("string1" ("sTring" "string2") ((((( "bow")))) "STRING") "string3" ("bow" "string4")) ) (equal (nsubst-if "bow" #'(lambda (x) (and (stringp x) (string-equal x "string"))) aa) '("string1" ("bow" "string2") ((((( "bow")))) "bow") "string3" ("bow" "string4")) ) ) ) (prog2 (setq a '( (string . guitar) ((keyboard . organ) string . guitar) (string guitar (percussion . drum)) )) (equal (nsubst-if '(string . harp) #'(lambda (x) (equal x '(string . guitar))) a) '( (string . harp) ((keyboard . organ) string . harp) (string guitar (percussion . drum)) )) ) (prog2 (setq a '( (1 2 3) (a b c) ( (w) (q) (i)) )) (equal (nsubst-if "poco ret." #'(lambda (x) (= (list-length x) 3)) a) "poco ret.") ) ) ) (do-test "test nsubst-if - with :KEY keyword" (and ;;(prog2 (setq a '( ("1" 2) (11 12) ("111" 212) (1111 2121) (111111 . 32112)) ) ;; (equal (nsubst-if "k" #'(lambda (x) (and (numberp x) (<= x 11110))) a :key #'car) ;; '( ("1" . "k") "k" ("111" . "k") "k" (111111 . 32112)) ) ;;) (prog2 (setq a '( "To" ("all" ("those")) "who" ("strive" "for") (("excellent")))) (equal (nsubst-if (second '(last least)) #'(lambda (x) (and (stringp x) (find #\t x))) a :key #'identity) '("To" ("all" (least)) "who" (least "for") ((least))) ) ) (prog2 (setq a '( ("a" "c" (ace)) "spade" club ("c" "l" (u b) ("d" "i" (amod)) ((king) "queen") Jack)) ) (equal (nsubst-if "*" #'(lambda (x) (and (listp x) (= (list-length x) 1))) a :key #'(lambda (x) (if (listp x) (third x) t))) '( "*" "spade" club ("c" "l" (u b) "*" ((king) "queen") Jack)) ) ) (prog2 (setq a '(10 23 34 23 100 2000 9)) (eq (nsubst-if 'end-of-nsubst-if-test #'(lambda (x) (= (apply #'+ x) 2166)) a :key #'(lambda (x) (nthcdr 2 x))) 'end-of-nsubst-if-test) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST.TEST new file mode 100644 index 00000000..49f804c8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSUBST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 13,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-NSUBST.TEST ;; ;; ;; Syntax: (NSUBST NEW OLD TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; NSUBST is a destructive version of SUBST. The list structure of ;; TREE is altered by destructively replacing with NEW ;; each leaf of the TREE such that OLD and the leaf ;; satisfy the test. ;; ;; Argument(s): NEW - anything ;; OLD - anything ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (DO-TEST "TEST NSUBST - test cases copied from page 273 of CLtL" (and (equal (NSUBST 'TEMPEST 'HURRICANE '(SHAKESPEARE WROTE (THE HURRICANE))) '(SHAKESPEARE WROTE (THE TEMPEST))) (equal (NSUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) '(SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO)) (equal (NSUBST '(A . CONS) '(OLD . PAIR) '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) :TEST #'EQUAL) '((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS))) ) ) (do-test "test nsubst 1" (and (prog2 (setq aa '(allen (apple) apply ((apple) apple1) apple2)) (equal (nsubst 'orange 'apple aa) '(allen (orange) apply ((orange) apple1) apple2)) ) (prog2 (setq aa '(twinkle (nil t) (twinkle) () little (star) "!")) (equal (nsubst 999 nil aa) '(twinkle (999 t . 999) (twinkle . 999) 999 little (star . 999) "!" . 999)) ) (prog2 (setq aa '(#\A #\a '(#\G (#\o)) ((#\b) #\a) (#\N (#\a)) ((#\n) #\a))) (equal (nsubst 'apple #\a aa) '(#\A apple '(#\G (#\o)) ((#\b) apple) (#\N (apple)) ((#\n) apple))) ) ) ) (do-test "test nsubst - with :TEST keyword" (and (prog2 (setq aa '("silent" "night" ("holy" ("night")) (("last" . "night")) ("lonely") "night")) (equal (nsubst "afternoon" "night" aa :test #'equal) '("silent" "afternoon" ("holy" ("afternoon")) (("last" . "afternoon")) ("lonely") "afternoon")) ) (prog2 (setq aa '((1 3 5.0) ((1.0 3) (1.0 3.0 5.0)) 1 3 5)) (equal (nsubst '(11.1 22.2) '(1 3.0 5.0) aa :test #'(lambda (x y) (and (listp y) (= (list-length x) (list-length y)) (every #'(lambda (m n) (and (numberp n) (= m n))) x y)))) '((11.1 22.2) ((1.0 3) (11.1 22.2)) 11.1 22.2)) ) (prog2 (setq aa '(20 77 45 (60) 5 0.2 ((30)) (39) 10 8 35)) (equal (nsubst 44 30 aa :test #'(lambda (x y) (and (numberp y) (>= x y)) )) '(44 77 45 (60) 44 44 ((44)) (39) 44 44 35)) ) ) ) (do-test "test nsubst - with :TEST-NOT keyword" (and (prog2 (setq aa '((1 2) (2 3 4) (4 ((5))) (7 8 (9)) )) (equal (nsubst '(foo) 'dumy aa :test-not #' (lambda (x y) (and (listp y) (= (list-length y) 4)) )) '((foo) foo) ) ) (prog2 (setq aa '((a z) (y x) (m n) (b c))) (equal (nsubst "foo" '(a b) aa :test-not #'intersection) "foo") ) (prog2 (setq aa '(no (sense) ((no)) feelings)) (equal (nsubst 'foo 'dumy aa :test-not #'(lambda (x y) (not (atom y)))) '(foo (foo . foo) ((foo . foo) . foo) foo . foo)) ) ) ) (do-test "test nsubst - with :KEY keyword" (and (prog2 (setq aa '((end2 end1) ((end) end))) (equal (nsubst 'zero '(end) aa :test #'equal :key #'(lambda (x) (if (listp x) (last x)))) '((end2 end1) zero)) ) (prog2 (setq aa '(13.0 ((2) 13.0 40) (26 (13.0) 39) ((2 4) 13 28))) (equal (nsubst 33 13 aa :test #'equalp :key #'(lambda (x) (if (consp x) (second x)))) '(13.0 33 (26 (13.0) 39) 33)) ) (progn (setq aa '((a b) a (a c) b c (d a))) (setq bb '((a b) d (a c) b c (d a))) (and (equal (nsubst 'w 'a aa :key #'(lambda (x) (if (consp x) (first x)))) '(w . w)) (equal (nsubst 'w 'a bb :key #'(lambda (x) (if (consp x) (first x)))) '(w d w b c (d . w))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBLIS.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBLIS.TEST new file mode 100644 index 00000000..7822dba4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBLIS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBLIS ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 274 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Aug. 15, 1986 ;; ;; Last Update: Aug. 15, 1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-SUBLIS.TEST ;; ;; ;; Syntax: (SUBLIS ALIST TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SUBLIS makes substitutions for objects in a tree (a structure of conses). The first argument to SUBLIS is an ;; association list. The second argument is the tree in which substitutions are to be made, as for SUBST. ;; SUBLIS looks at all subtrees and leaves of the tree; if a subtree or leaf appears as a key in the association ;; list (that is, the key and the subtree or leaf satisfy the test), it is replaced by the object it is associated ;; with. This operation is non-destructive. In effct, SUBLIS can perform several SUBST operations simultaneously. ;; NSUBLIS is like SUBLIS but destructively modifieds the relevant parts of the tree. ;; ;; Argument(s): LIST - an association list ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test sublis - test cases copied from page 274 of CLtL" (and (equal (sublis '( (x . 100) (z . zprime) ) '(plus x (minus g z x p) 4 . x)) '(plus 100 (minus g zprime 100 p) 4 . 100) ) (equal (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y))) '(* (/ (+ x y) (+ x p)) (- x y)) :test #'equal) '(* (/ (- x y) (+ x p)) (+ x y)) ) ) ) (do-test "test sublis 1" (and (prog2 (setq a '(>= (* x y) (+ x y) (- x y) (/ x y) )) (and (equal (sublis '( (x . xx) (y . yy) ) a) '(>= (* xx yy) (+ xx yy) (- xx yy) (/ xx yy)) ) (equal a '(>= (* x y) (+ x y) (- x y) (/ x y) )) ) ) (prog2 (setq a '(1 2 (2 3 4) ((3) 4) 5 6 ( 6 4 2 1))) (and (equal (sublis '( (2 . 3) (3 . 6) (6 . 1)) a) '(1 3 (3 6 4) ((6) 4) 5 1 (1 4 3 1)) ) (equal a '(1 2 (2 3 4) ((3) 4) 5 6 ( 6 4 2 1))) ) ) (prog2 (setq a '( (#\a #\b) #\c ((#\d)) #\e)) (and (equal (sublis '((nil . 7)) a) '( (#\a #\b . 7) #\c ((#\d . 7) . 7) #\e . 7)) (equal a '( (#\a #\b) #\c ((#\d)) #\e)) ) ) (prog2 (setq a '()) (and (equal (sublis '(( nil . "empty list")) a) "empty list") (eq a ()) ) ) ) ) (do-test "test sublis - with :TEST keyword" (and (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (and (equal (sublis '((1 . 3.0) (3.0 . 5.0) (5.0 . 7.0) (7 . 9.0) (9 . 1.0)) a :test #'equalp) '(3.0 2.0 5.0 (4.0) (7.0 6.0 (9.0)) (8 ((1.0)) 10))) (equal a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) )) (prog2 (setq a '( "I" "buy" ("coke") (("lime")) "plus" ("lemon" . "banana"))) (and (equal (sublis '((#\i . "apricot") (#\e . "opium") (#\a . "coffee")) a :test #'(lambda (n m) (and (stringp n) (find m n)))) '("I" "buy" ("opium") (("apricot")) "plus" ("opium" . "coffee"))) (equal a '("I" "buy" ("coke") (("lime")) "plus" ("lemon" . "banana"))))) (prog2 (setq a '((((park . place) (small . talk) (small . 80))) (park . play) ((small . 72)) (park . small))) (and (equal (sublis '(((park . play) . (pool . swim)) ((small . talk) . (public . speech))) a :test #'equal) '((((park . place) (public . speech) (small . 80))) (pool . swim) ((small . 72)) (park . small))) (equal a '((((park . place) (small . talk) (small . 80))) (park . play) ((small . 72)) (park . small))))) (prog2 (setq a '(2 5 7 13 27)) (and (equal (sublis '((dummy . "star")) a :test #'(lambda (y x) (and (listp y) (evenp (first y))))) "star") (equal a '(2 5 7 13 27)))))) (do-test "test sublis - with :TEST-NOT keyword" (and (prog2 (setq a '(78 65 (45 ((66) 23) 121) 8 100)) (and (equal (sublis '((30 . "<= 30") (50 . "<= 50") (80 . "<= 80")) a :test-not #'(lambda (y x) (or (not (numberp y)) (> y x)))) '("<= 80" "<= 80" ("<= 50" (("<= 80") "<= 30") 121) "<= 30" 100)) (equal a '(78 65 (45 ((66) 23) 121) 8 100)))) (prog2 (setq a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))) (and (equal (sublis '(((4.0) . foo) ((9.0) . bar)) a :test-not #'(lambda (x y) (not (equalp x y)))) '(1 2.0 3 foo (5 6.0 (7.0)) (8 (bar) 10))) (equal a '(1 2.0 3 (4.0) (5 6.0 (7.0)) (8 ((9.0)) 10))))) (prog2 (setq a '((John 250) (Susan 78) (Henry 140) (Kelly 115) (Mark 350))) (and (equal (sublis '(((Edward 200) . (Tom 214))) a :test-not #'equal) '(Tom 214)) (equal a '((John 250) (Susan 78) (Henry 140) (Kelly 115) (Mark 350))))))) (do-test "test sublis - with :KEY keyword" (and (prog2 (setq a '( (a b c) (1 2 3) (#\q #\w #\e) ("a" "b" "c"))) (and (equal (sublis '((b . bb) (#\w . #\p) ("b" . "bb")) a :test #'equal :key #'(lambda (k) (if (listp k) (second k) ))) '(bb (1 2 3) #\p "bb")) ) ) (prog2 (setq a '( (1 2 3 4) (2 3) (8 9 0 12) (1))) (and (equal (sublis '( ( (4) . four) ( (12) . twelve)) a :test #'equal :key #'(lambda (x) (if (listp x) (last x) '(3)))) '(four (2 3) twelve (1))) (equal a '( (1 2 3 4) (2 3) (8 9 0 12) (1) ) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF-NOT.TEST new file mode 100644 index 00000000..ec080eb9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBST-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 273 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 14,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-SUBST-IF-NOT.TEST ;; ;; ;; Syntax: (SUBST-IF-NOT NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; (SUBST NEW OLD TREE) makes a copy of TREE, ;; substituting NEW for every subtree or leaf of TREE ;; (whether the subtree or leaf is a CAR or a CDR of its parent) ;; such that OLD and the subtree or leaf satisfy the test. It ;; returns the modified copy of TREE. The original TREE is ;; unchanged, but the result tree may share with parts of the argument ;; TREE. ;; Compatibility note: In Maclisp, SUBST is guaranteed NOT to share with ;; the TREE argument, and the idiom (SUBST NIL NIL X) was ;; used to copy a tree X. In Common Lisp, the function function COPY-TREE should ;; be used to copy a tree, as the SUBST idiom will not work. ;; For example: ;; ;; (SUBST 'TEMPEST 'HURRICANE ;; ;; '(SHAKESPEARE WROTE (THE HURRICANE))) ;; => (SHAKESPEARE WROTE (THE TEMPEST)) ;; (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) ;; => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) ;; (SUBST '(A . CONS) '(OLD . PAIR) ;; '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) ;; :TEST #'EQUAL) ;; => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) ;; ;; This function is not destructive; that is, it does not change ;; the CAR or CDR of any already existing list structure. ;; One possible definition of SUBST: ;; ;; (DEFUN SUBST (OLD NEW TREE X TEST TEST-NOT KEY) ;; (COND ((SATISFIES-THE-TEST OLD TREE :TEST TEST ;; ;; :TEST-NOT TEST-NOT :KEY KEY) ;; NEW) ;; ((ATOM TREE) TREE) ;; (T (LET ((A (APPLY #'SUBST OLD NEW (CAR TREE) X)) ;; (D (APPLY #'SUBST OLD NEW (CDR TREE) X))) ;; (IF (AND (EQL A (CAR TREE)) ;; (EQL D (CDR TREE))) ;; TREE ;; (CONS A D)))))) ;; ;; See also function SUBSTITUTE, which substitutes for top-level elements ;; of a sequence. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test subst-if-not 1" (and (prog2 (setq a '(1 2 3 (3 2 1) ((2)) (3 (1)))) (and (equal (subst-if-not 88 #'(lambda (x) (or (not (numberp x)) (not (eq x 2)))) a) '(1 88 3 (3 88 1) ((88)) (3 (1)) )) (equal a '(1 2 3 (3 2 1) ((2)) (3 (1)))) ) ) (prog2 (setq a '("one" ("two" . "three") ("four") "five" "six" . "seven")) (and (equal (subst-if-not 'gotchu #'(lambda (x) (or (not (stringp x)) (not (find #\r x)))) a) '("one" ("two" . gotchu) (gotchu) "five" "six" . "seven")) (equal a '("one" ("two" . "three") ("four") "five" "six" . "seven")) ) ) (prog2 (setq a '(10 13 12 (17 18) ((30 5) 31 4) 40 -5)) (and (equal (subst-if-not "***" #'(lambda (x) (or (not (listp x) ) (some #'(lambda (x) (not (numberp x))) x) (/= (apply #'+ x) 35) )) a) '(10 13 12 "***" ("***" . "***") . "***")) ) ) (prog2 (setq a '()) (and (equal (subst-if-not "April fool" #'consp a) "April fool") (equal a ()) ) ) ) ) (do-test "test subst-if-not -- with :KEY keyword" (and (prog2 (setq a `("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (and (equal (subst-if-not #\y #'stringp a :key #'(lambda (x) (if (and (listp x) (= (list-length x) 3)) (first x) "dummy" ))) '("sleepy" #\y "grouchy" . #\y)) (equal a `("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) ) ) (prog2 (setq a '("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) (and (equal (subst-if-not '(foo) #'(lambda (x) (find #\s x :test #'char-equal)) a :key #'(lambda (z) (typecase z (string z) (null "s") (symbol (string z)) (t "s")))) '( "sleepy" (sneezy ( (foo) bashful (foo) ) (foo)) (foo) (foo) snow (foo)) ) (equal a '("sleepy" (sneezy (doc bashful rabbit) jumpy) "grouchy" dopy snow white)) ) ) (prog2 (setq a '(a b c (10 3 5 2 5 8) d (3 4 5))) (and (eq (subst-if-not 'end-of-testing #'(lambda (x) (/= (apply #'- x) -13.0)) a :key #'cadddr) 'end-of-testing) (equal a '(a b c (10 3 5 2 5 8) d (3 4 5))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF.TEST new file mode 100644 index 00000000..bae6a2c8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBST-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 273 ;; ;; Created By: Kelly Roach ; Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 14,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-SUBST-IF.TEST ;; ;; ;; Syntax: (SUBST-IF NEW TEST TREE &KEY KEY) ;; ;; Function Description: ;; (SUBST NEW OLD TREE) makes a copy of TREE, ;; substituting NEW for every subtree or leaf of TREE ;; (whether the subtree or leaf is a CAR or a CDR of its parent) ;; such that OLD and the subtree or leaf satisfy the test. It ;; returns the modified copy of TREE. The original TREE is ;; unchanged, but the result tree may share with parts of the argument ;; TREE. ;; Compatibility note: In Maclisp, SUBST is guaranteed NOT to share with ;; the TREE argument, and the idiom (SUBST NIL NIL X) was ;; used to copy a tree X. In Common Lisp, the function function COPY-TREE should ;; be used to copy a tree, as the SUBST idiom will not work. ;; For example: ;; ;; (SUBST 'TEMPEST 'HURRICANE ;; ;; '(SHAKESPEARE WROTE (THE HURRICANE))) ;; => (SHAKESPEARE WROTE (THE TEMPEST)) ;; (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) ;; => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) ;; (SUBST '(A . CONS) '(OLD . PAIR) ;; '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) ;; :TEST #'EQUAL) ;; => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) ;; ;; This function is not destructive; that is, it does not change ;; the CAR or CDR of any already existing list structure. ;; One possible definition of SUBST: ;; ;; (DEFUN SUBST (OLD NEW TREE X TEST TEST-NOT KEY) ;; (COND ((SATISFIES-THE-TEST OLD TREE :TEST TEST ;; ;; :TEST-NOT TEST-NOT :KEY KEY) ;; NEW) ;; ((ATOM TREE) TREE) ;; (T (LET ((A (APPLY #'SUBST OLD NEW (CAR TREE) X)) ;; (D (APPLY #'SUBST OLD NEW (CDR TREE) X))) ;; (IF (AND (EQL A (CAR TREE)) ;; (EQL D (CDR TREE))) ;; TREE ;; (CONS A D)))))) ;; ;; See also function SUBSTITUTE, which substitutes for top-level elements ;; of a sequence. ;; ;; Argument(s): NEW - anything ;; TEST - a function ;; TREE - a tree ;; KEY - a function ;; ;; Returns: a tree ;; (do-test "test subst-if 1" (and (prog2 (setq a '(10 20 (10.0) (10 . 10.0) 100 30 (10) . 10)) (and (equal (subst-if 99.99 #'(lambda (x) (equalp x 10)) a) '(99.99 20 (99.99) (99.99 . 99.99) 100 30 (99.99) . 99.99)) (equal (subst-if 99.99 #'(lambda (x) (eql x 10)) a) '(99.99 20 (10.0) (99.99 . 10.0) 100 30 (99.99) . 99.99)) (equal a '(10 20 (10.0) (10 . 10.0) 100 30 (10) . 10)) ) ) (prog2 (setq a '( (apple . orange) (banana) ((papaya) (tomato) mongo) watermelon . cantolope) ) (and (equal (subst-if 'yummy #'null a) '( (apple . orange) (banana . yummy) ((papaya . yummy) (tomato . yummy) mongo . yummy) watermelon . cantolope) ) (equal (subst-if t #'atom a) '(( t . t) (t . t) ((t . t) (t . t) t . t) t . t) ) (equal a '( (apple . orange) (banana) ((papaya) (tomato) mongo) watermelon . cantolope) ) ) ) (prog2 (setq a '("string1" ("sTring" "string2") ((((( "string")))) "STRING") "string3" ("string" "string4") )) (and (equal (subst-if "bow" #'(lambda (x) (and (stringp x) (string= x "string"))) a) '("string1" ("sTring" "string2") ((((( "bow")))) "STRING") "string3" ("bow" "string4")) ) (equal (subst-if "bow" #'(lambda (x) (and (stringp x) (string-equal x "string"))) a) '("string1" ("bow" "string2") ((((( "bow")))) "bow") "string3" ("bow" "string4")) ) (equal a '("string1" ("sTring" "string2") ((((( "string")))) "STRING") "string3" ("string" "string4"))) ) ) (prog2 (setq a '( (string . guitar) ((keyboard . organ) string . guitar) (string guitar (percussion . drum)) )) (and (equal (subst-if '(string . harp) #'(lambda (x) (equal x '(string . guitar))) a) '( (string . harp) ((keyboard . organ) string . harp) (string guitar (percussion . drum)) )) (equal a '( (string . guitar) ((keyboard . organ) string . guitar) (string guitar (percussion . drum)) )) ) ) (prog2 (setq a '( (1 2 3) (a b c) ( (w) (q) (i)) )) (and (equal (subst-if "poco ret." #'(lambda (x) (= (list-length x) 3)) a) "poco ret.") (equal a '( (1 2 3) (a b c) ( (w) (q) (i)) )) ) ) ) ) (do-test "test subst-if - with :KEY keyword" (and ;;(prog2 (setq a '( ("1" 2) (11 12) ("111" 212) (1111 2121) (111111 . 32112)) ) ;; (and (equal (subst-if "k" #'(lambda (x) (and (numberp x) (<= x 11110))) a :key #'car) ;; '( ("1" . "k") "k" ("111" . "k") "k" (111111 . 32112)) ) ;; (equal a '( ("1" 2) (11 12) ("111" 212) (1111 2121) (111111 . 32112)) ) ;; ) ;;) (prog2 (setq a '( "To" ("all" ("those")) "who" ("strive" "for") (("excellent")))) (and (equal (subst-if (second '(last least)) #'(lambda (x) (and (stringp x) (find #\t x))) a :key #'identity) '("To" ("all" (least)) "who" (least "for") ((least))) ) (equal a '( "To" ("all" ("those")) "who" ("strive" "for") (("excellent")))) ) ) (prog2 (setq a '( ("a" "c" (ace)) "spade" club ("c" "l" (u b) ("d" "i" (amod)) ((king) "queen") Jack)) ) (and (equal (subst-if "*" #'(lambda (x) (and (listp x) (= (list-length x) 1))) a :key #'(lambda (x) (if (listp x) (third x) t))) '( "*" "spade" club ("c" "l" (u b) "*" ((king) "queen") Jack)) ) (equal a '( ("a" "c" (ace)) "spade" club ("c" "l" (u b) ("d" "i" (amod)) ((king) "queen") Jack)) ) ) ) (prog2 (setq a '(10 23 34 23 100 2000 9)) (and (eq (subst-if 'end-of-subst-if-test #'(lambda (x) (= (apply #'+ x) 2166)) a :key #'(lambda (x) (nthcdr 2 x))) 'end-of-subst-if-test) (equal a '(10 23 34 23 100 2000 9)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST.TEST new file mode 100644 index 00000000..a89e7d9b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBST ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.4 Substitution of Expressions ;; Page: 273 ;; ;; Created By: Kelly Roach ; Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Aug. 13,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-4-SUBST.TEST ;; ;; ;; Syntax: (SUBST NEW OLD TREE &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; (SUBST NEW OLD TREE) makes a copy of TREE, ;; substituting NEW for every subtree or leaf of TREE ;; (whether the subtree or leaf is a CAR or a CDR of its parent) ;; such that OLD and the subtree or leaf satisfy the test. It ;; returns the modified copy of TREE. The original TREE is ;; unchanged, but the result tree may share with parts of the argument ;; TREE. ;; Compatibility note: In Maclisp, SUBST is guaranteed NOT to share with ;; the TREE argument, and the idiom (SUBST NIL NIL X) was ;; used to copy a tree X. In Common Lisp, the function function COPY-TREE should ;; be used to copy a tree, as the SUBST idiom will not work. ;; For example: ;; ;; (SUBST 'TEMPEST 'HURRICANE ;; ;; '(SHAKESPEARE WROTE (THE HURRICANE))) ;; => (SHAKESPEARE WROTE (THE TEMPEST)) ;; (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) ;; => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) ;; (SUBST '(A . CONS) '(OLD . PAIR) ;; '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) ;; :TEST #'EQUAL) ;; => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) ;; ;; This function is not destructive; that is, it does not change ;; the CAR or CDR of any already existing list structure. ;; One possible definition of SUBST: ;; ;; (DEFUN SUBST (OLD NEW TREE X TEST TEST-NOT KEY) ;; (COND ((SATISFIES-THE-TEST OLD TREE :TEST TEST ;; ;; :TEST-NOT TEST-NOT :KEY KEY) ;; NEW) ;; ((ATOM TREE) TREE) ;; (T (LET ((A (APPLY #'SUBST OLD NEW (CAR TREE) X)) ;; (D (APPLY #'SUBST OLD NEW (CDR TREE) X))) ;; (IF (AND (EQL A (CAR TREE)) ;; (EQL D (CDR TREE))) ;; TREE ;; (CONS A D)))))) ;; ;; See also function SUBSTITUTE, which substitutes for top-level elements ;; of a sequence. ;; ;; Argument(s): NEW - anything ;; OLD - anything ;; TREE - a tree ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a tree ;; (DO-TEST "TEST SUBST - test cases copied from page 273 of CLtL" (and (equal (SUBST 'TEMPEST 'HURRICANE '(SHAKESPEARE WROTE (THE HURRICANE))) '(SHAKESPEARE WROTE (THE TEMPEST))) (equal (SUBST 'FOO 'NIL '(SHAKESPEARE WROTE (TWELFTH NIGHT))) '(SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO)) (equal (SUBST '(A . CONS) '(OLD . PAIR) '((OLD . SPICE) ((OLD . SHOES) OLD . PAIR) (OLD . PAIR)) :TEST #'EQUAL) '((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS))))) (do-test "test subst 1" (and (prog2 (setq aa '(allen (apple) apply ((apple) apple1) apple2)) (and (equal (subst 'orange 'apple aa) '(allen (orange) apply ((orange) apple1) apple2)) (equal aa '(allen (apple) apply ((apple) apple1) apple2)))) (prog2 (setq aa '(twinkle (nil t) (twinkle) () little (star) "!")) (and (equal (subst 999 nil aa) '(twinkle (999 t . 999) (twinkle . 999) 999 little (star . 999) "!" . 999)) (equal aa '(twinkle (nil t) (twinkle) () little (star) "!")))) (prog2 (setq aa '(#\A #\a '(#\G (#\o)) ((#\b) #\a) (#\N (#\a)) ((#\n) #\a))) (and (equal (subst 'apple #\a aa) '(#\A apple '(#\G (#\o)) ((#\b) apple) (#\N (apple)) ((#\n) apple))) (equal aa '(#\A #\a '(#\G (#\o)) ((#\b) #\a) (#\N (#\a)) ((#\n) #\a))))))) (do-test "test subst - with :TEST keyword" (and (prog2 (setq aa '("silent" "night" ("holy" ("night")) (("last" . "night")) ("lonely") "night")) (and (equal (subst "afternoon" "night" aa :test #'equal) '("silent" "afternoon" ("holy" ("afternoon")) (("last" . "afternoon")) ("lonely") "afternoon")) (equal aa '("silent" "night" ("holy" ("night")) (("last" . "night")) ("lonely") "night")))) (prog2 (setq aa '((1 3 5.0) ((1.0 3) (1.0 3.0 5.0)) 1 3 5)) (and (equal (subst '(11.1 22.2) '(1 3.0 5.0) aa :test #'(lambda (x y) (and (listp y) (= (list-length x) (list-length y)) (every #'(lambda (m n) (and (numberp n) (= m n))) x y)))) '((11.1 22.2) ((1.0 3) (11.1 22.2)) 11.1 22.2)) (equal aa '((1 3 5.0) ((1.0 3) (1.0 3.0 5.0)) 1 3 5)))) (prog2 (setq aa '(20 77 45 (60) 5 0.2 ((30)) (39) 10 8 35)) (and (equal (subst 44 30 aa :test #'(lambda (x y) (and (numberp y) (>= x y)) )) '(44 77 45 (60) 44 44 ((44)) (39) 44 44 35)) (equal aa '(20 77 45 (60) 5 0.2 ((30)) (39) 10 8 35)))))) (do-test "test subst - with :TEST-NOT keyword" (and (prog2 (setq aa '((1 2) (2 3 4) (4 ((5))) (7 8 (9)) )) (and (equal (subst '(foo) 'dumy aa :test-not #'(lambda (x y) (and (listp y) (= (list-length y) 4)) )) '((foo) foo)) (equal aa '((1 2) (2 3 4) (4 ((5))) (7 8 (9)) )))) (prog2 (setq aa '((a z) (y x) (m n) (b c))) (and (equal (subst "foo" '(a b) aa :test-not #'intersection) "foo") (equal aa '((a z) (y x) (m n) (b c))))) (prog2 (setq aa '(no (sense) ((no)) feelings)) (and (equal (subst 'foo 'dumy aa :test-not #'(lambda (x y) (not (atom y)))) '(foo (foo . foo) ((foo . foo) . foo) foo . foo)) (equal aa '(no (sense) ((no)) feelings)))))) (do-test "test subst - with :KEY keyword" (and (prog2 (setq aa '((end2 end1) ((end) end))) (and (equal (subst 'zero '(end) aa :test #'equal :key #'(lambda (x) (if (listp x) (last x)))) '((end2 end1) zero)) (equal aa '((end2 end1) ((end) end))))) (prog2 (setq aa '(13.0 ((2) 13.0 40) (26 (13.0) 39) ((2 4) 13 28))) (and (equal (subst 33 13 aa :test #'equalp :key #'(lambda (x) (if (consp x) (second x)))) '(13.0 33 (26 (13.0) 39) 33)) (equal aa '(13.0 ((2) 13.0 40) (26 (13.0) 39) ((2 4) 13 28))))) (progn (setq aa '((a b) a (a c) b c (d a))) (setq bb '((a b) d (a c) b c (d a))) (and (equal (subst 'w 'a aa :key #'(lambda (x) (if (consp x) (first x)))) '(w . w)) (equal aa '((a b) a (a c) b c (d a))) (equal (subst 'w 'a bb :key #'(lambda (x) (if (consp x) (first x)))) '(w d w b c (d . w))) (equal bb '((a b) d (a c) b c (d a))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-ADJOIN.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-ADJOIN.TEST new file mode 100644 index 00000000..1ffecac0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-ADJOIN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ADJOIN ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 276 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-ADJOIN.TEST ;; ;; ;; Syntax: (ADJOIN ITEM LIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; ADJOIN is used to add an element to a set, provided that ;; it is not already a member. The equality test defaults to EQL. ;; ;; (ADJOIN ITEM LIST) = (IF (MEMBER ITEM LIST) LIST (CONS ITEM LIST)) ;; ;; In general, the test may be any predicate; the ITEM is added to the ;; list only if there is no element of the list that ``satisfies the ;; test.'' ;; ;; ADJOIN deviates from the usual rules described in chapter ;; for the treatment of arguments named ITEM and :KEY. ;; If a :KEY function is specified, it is applied to ITEM ;; as well as to each element of the list. The rationale is that ;; if the ITEM is not yet in the list, it soon will be, and so ;; the test is more properly viewed as being between two elements ;; rather than between a separate ITEM and an element. ;; ;; (ADJOIN ITEM LIST :KEY FN) ;; = (IF (MEMBER (FN ITEM) LIST :KEY FN) LIST (CONS ITEM LIST)) ;; ;; See macro PUSHNEW. ;; ;; Argument(s): ITEM - anything ;; LIST - a list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (DO-TEST "ADJOIN TEST 1" (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((1 2) (3 4))) :TEST (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((3 4))) :TEST (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((1 2) (3 4))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((3 4))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((3 4) (1 2) (2 1) (3 4))) :TEST (QUOTE EQUAL)) (QUOTE ((3 4) (1 2) (2 1) (3 4)))) (EQUAL (ADJOIN (QUOTE (1 2)) NIL :TEST-NOT (QUOTE EQUAL)) (QUOTE ((1 2)))) (EQUAL (ADJOIN (QUOTE (1 2)) NIL :TEST (QUOTE EQUAL)) (QUOTE ((1 2)))) (EQUAL (ADJOIN (QUOTE (1 2)) NIL :TEST (QUOTE EQL)) (QUOTE ((1 2)))) (EQUAL (ADJOIN (QUOTE (1 2)) (QUOTE ((1 2))) :TEST (QUOTE EQL)) (QUOTE ((1 2) (1 2))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-INTERSECTION.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-INTERSECTION.TEST new file mode 100644 index 00000000..a38e06aa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-INTERSECTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: INTERSECTION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 277 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-INTERSECTION.TEST ;; ;; ;; Syntax: (INTERSECTION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; INTERSECTION takes two lists and returns a new list containing ;; everything that is an element of both argument lists. ;; If either list has duplicate entries, the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (INTERSECTION '(A B C) '(F A D)) => (A) ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the intersection operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' For every matching pair, ;; exactly one of the two elements of the pair will be put in the result. ;; No element from either list appears in the result that does not match ;; an element from the other list. ;; All this is very general, but probably ;; not particularly useful unless the test is an equivalence relation. ;; ;; NINTERSECTION is the destructive version of INTERSECTION. ;; It performs the same operation, but may destroy LIST1 ;; using its cells to construct the result. (The argument LIST2 ;; is NOT destroyed.) ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (DO-TEST "TEST INTERSECTION - test case copied from page 277 of CLtL" (prog2 (setq aa '(a b c) bb '(f a d) cc (intersection aa bb)) (and (equal cc '(a)) (equal aa '(a b c)) (equal bb '(f a d))))) (do-test "test intersection 1" (and (prog2 (setq aa '(1 2 3 4 5) bb '(4 5 1 8 9) cc (intersection aa bb)) (and (every #'equal (list aa bb) '((1 2 3 4 5) (4 5 1 8 9))) (= (list-length cc) 3) (every #'(lambda (x) (member x cc :test #'eq)) '(1 5 4)))) (prog2 (setq aa '(a b c d) bb '(x y (z)) cc (intersection bb aa)) (and (equal aa '(a b c d)) (equal bb '(x y (z))) (eq cc nil))) (let* ((aa '(#\a #\b)) (bb '(#\B #\a)) (cc (intersection aa bb :test #'equalp))) (and (equal aa '(#\a #\b)) (equal bb '(#\B #\a)) (member #\a cc) (member #\b cc :test #'equalp) (= (list-length cc ) 2))))) (do-test "test intersection 2" (progn (setq aa '((Kathy 100) (Karen 50) (Susan 80)) bb '((ken 85) (Henry 70) (kathy 96)) cc (intersection aa bb :test #'eq :key #'car )) (and (equal aa '((Kathy 100) (Karen 50) (Susan 80))) (equal bb '((ken 85) (Henry 70) (kathy 96))) (or (equal cc '((Kathy 100))) (equal cc '((Kathy 96))))))) (do-test "test intersection 3" (progn (setq aa '((10 20 120) (30 60 360.0) (40 50 450)) bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0)) cc (intersection aa bb :test #'= :key #'third)) (and (equal aa '((10 20 120) (30 60 360.0) (40 50 450))) (equal bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0))) (and (= (list-length cc ) 2) (every #'(lambda (x) (member x cc :test #'= :key #'third)) '(360 450)))))) (do-test "test intersection 4" (and (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (intersection aa bb :test-not #'(lambda (x y) (not (equal x y))) )) (and (equal aa '(1 "h" #\T (2 . 3) (list) "st")) (equal bb '((2 . 3) #\4 aatom 300 #\t "St")) (equal cc '((2 . 3))))) (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (intersection aa bb :test-not #'(lambda (x y) (not (equalp x y))) )) (and (every #'(lambda (x) (member x cc :test #'equalp)) '((2 . 3) #\t "St")) (= (list-length cc) 3))) (progn (setq aa '((1 3 5) (2 6 7) (10 20)) bb '((10 2 3) ( 20 5 1) ( 2 4 1)) cc (intersection aa bb :test-not #'(lambda ( x y) (/= (apply #'+ x) (apply #'+ y))))) (or (equal cc '((2 6 7))) (equal cc '((10 2 3))))) (progn (setq aa '("banana" "papaya" "tomamo") bb '("orange" "pineapple" "watermelon") cc (intersection aa bb :test #'(lambda (x y) (car (mapcar #'find '(#\m #\a ) (list x y)))))) (and (equal aa '("banana" "papaya" "tomamo")) (equal bb '("orange" "pineapple" "watermelon")) (some #'(lambda (x) (equal cc x)) '(("orange") ("tomamo") ("pineapple") ("watermelon"))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF-NOT.TEST new file mode 100644 index 00000000..a3643836 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MEMBER-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 17,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-MEMBER-IF-NOT.TEST ;; ;; ;; Syntax: (MEMBER-IF-NOT TEST LIST &KEY KEY) ;; ;; Function Description: ;;The LIST is searched for an element that satisfies the test. ;; If none is found, NIL is returned; ;; otherwise, the tail of LIST beginning ;; with the first element that satisfied the test is returned. ;; The LIST is searched on the top level only. ;; These functions are suitable for use as predicates. ;; For example: ;; ;; (MEMBER 'SNERD '(A B C D)) => NIL ;; (MEMBER-IF #'NUMBERP '(A #\SPACE 5/3 FOO)) => (5/3 FOO) ;; (MEMBER 'A '(G (A Y) C A D E A F)) => (A D E A F) ;; ;; Note, in the last example, ;; that the value returned by MEMBER is EQ to the portion of the list ;; beginning with A. ;; Thus RPLACA on the result of MEMBER may be used ;; to alter the found list element, ;; if a check is first made that MEMBER did not return NIL. ;; ;; See also function FIND and function POSITION. ;; Compatibility note: In Maclisp, the MEMBER function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for MEMBER in Common Lisp. Where in Maclisp one would write ;; (MEMBER X Y), in Common Lisp one must write (MEMBER X Y :TEST #'EQUAL) ;; to get a completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (MEMQ X Y) ;; by writing in Common Lisp (MEMBER X Y :TEST #'EQ). ;; ;; Argument(s): TEST - a function ;; LIST - a pure list ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test member-if-not 0" (and (equal (member-if-not #'floatp '(1.0 3.4 5.6 8 9.0 10)) '(8 9.0 10)) (equal (member-if-not #'integerp '(1 2 3.4 5.6 8 9.0 10)) '(3.4 5.6 8 9.0 10)) (equal (member-if-not #'consp '((a b . c) (#\d) ((#\e)) #\f g "h")) '(#\f g "h")) (equal (member-if-not #'symbolp '(a b c (#\d) ((#\e)) #\f g "h")) '((#\d) ((#\e)) #\f g "h")) (equal (member-if-not #'null '( () 1 2 t nil)) '( 1 2 t nil)) (equal (member-if-not #'symbolp '(() 1 2 t nil)) '(1 2 t nil)) (equal (member-if-not #'atom '((nil) 1 2 t nil)) '((nil) 1 2 t nil)) (equal (member-if-not #'consp '(() t nil (weight 100))) '(() t nil (weight 100))) (equal (member-if-not #'listp '( (weight 100) t nil ())) '(t nil ())) (equal (member-if-not #'numberp '(8 (1 2) ((3 4) 5) '6 "7")) '((1 2) ((3 4) 5) '6 "7") ) ) ) (do-test "test member-if-not 1" (and (equal (member-if-not #'floatp '((1.0 3.4) (5.6 8) (10 . 12)) :key #'car) '((10 . 12))) (equal (member-if-not #'null '((a b d e) (1 2 3) (10 20 (30 40) 50)) :key #'fourth) '((a b d e)(1 2 3) (10 20 (30 40) 50))) (equal (member-if-not #'atom '("a" t #(1 2 3 4) 'star (8 9 10)) :key #'identity) '('star (8 9 10))) (equal (member-if-not #'numberp '( ((1 2 3) "a" "b") ((1 3 "a") "b" 2 "c") (("c" "a" "b") 1 2 3)) :key #'cadar) '((("c" "a" "b") 1 2 3)) ) ) ) (do-test "test member-if-not 2" (and (equal (member-if-not #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197)) '(99 98 2 4 200 100 197)) (equal (member-if-not #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197) :key #'(lambda (x) (1+ x))) '( 98 2 4 200 100 197)) (equal (member-if-not #'(lambda (x) (cond ((symbolp x) (eq x 'june)) ((numberp x) t) ( (listp x) (string= (first x) "July")) )) '(("July" may june) (("July" may june) 5 6 7) ( 7 6 ("july" may june)) (6 8 ("July" may june) 5 7)) :key #'caddr) '((7 6 ("july" may june)) (6 8 ("July" may june) 5 7))) (equal (member-if-not #'(lambda (x) (string-equal x "end-of-testing")) '("end-OF-" "END-OF-" "end-OF-" "end-" "endd-of-" "endd-off-") :key #'(lambda (x) (concatenate 'string x "TESTING"))) '("end-" "endd-of-" "endd-off-")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF.TEST new file mode 100644 index 00000000..ff8f8f08 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MEMBER-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 23, 1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-MEMBER-IF.TEST ;; ;; ;; Syntax: (MEMBER-IF TEST LIST &KEY KEY) ;; ;; Function Description: ;; The LIST is searched for an element that satisfies the test. ;; If none is found, NIL is returned; ;; otherwise, the tail of LIST beginning ;; with the first element that satisfied the test is returned. ;; The LIST is searched on the top level only. ;; These functions are suitable for use as predicates. ;; For example: ;; ;; (MEMBER 'SNERD '(A B C D)) => NIL ;; (MEMBER-IF #'NUMBERP '(A #\SPACE 5/3 FOO)) => (5/3 FOO) ;; (MEMBER 'A '(G (A Y) C A D E A F)) => (A D E A F) ;; ;; Note, in the last example, ;; that the value returned by MEMBER is EQ to the portion of the list ;; beginning with A. ;; Thus RPLACA on the result of MEMBER may be used ;; to alter the found list element, ;; if a check is first made that MEMBER did not return NIL. ;; ;; See also function FIND and function POSITION. ;; Compatibility note: In Maclisp, the MEMBER function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for MEMBER in Common Lisp. Where in Maclisp one would write ;; (MEMBER X Y), in Common Lisp one must write (MEMBER X Y :TEST #'EQUAL) ;; to get a completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (MEMQ X Y) ;; by writing in Common Lisp (MEMBER X Y :TEST #'EQ). ;; ;; Argument(s): TEST - a function ;; LIST - a pure list ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test member-if - test case copied from page 275 of CLtL" (equal (MEMBER-IF #'NUMBERP '(A #\SPACE #.(/ 5 3) FOO)) '(#.(/ 5 3) FOO)) ) (do-test "test member-if 0" (and (equal (member-if #'integerp '(1.0 3.4 5.6 8 9.0 10)) '(8 9.0 10)) (equal (member-if #'floatp '(1 2 3.4 5.6 8 9.0 10)) '(3.4 5.6 8 9.0 10)) (equal (member-if #'characterp '(a b c (#\d) ((#\e)) #\f g "h")) '(#\f g "h")) (equal (member-if #'stringp '(a b c (#\d) ((#\e)) #\f g "h")) '("h")) (equal (member-if #'null '( () 1 2 t nil)) '( () 1 2 t nil)) (equal (member-if #'symbolp '(() 1 2 t nil)) '(() 1 2 t nil)) (equal (member-if #'atom '((nil) 1 2 t nil)) '(1 2 t nil)) (equal (member-if #'consp '(t nil () (weight 100))) '((weight 100))) (equal (member-if #'listp '(t nil () (weight 100))) '(nil () (weight 100))) (equal (member-if #'numberp '((1 2) ((3 4) 5) '6 "7")) nil) ) ) (do-test "test member-if 1" (and (equal (member-if #'integerp '((1.0 3.4) (5.6 8) (10 . 12)) :key #'car) '((10 . 12))) (equal (member-if #'null '((a b d e) (1 2 3) (10 20 (30 40) 50)) :key #'fourth) '((1 2 3) (10 20 (30 40) 50))) (equal (member-if #'listp '("a" t #(1 2 3 4) 'star (8 9 10)) :key #'identity) '('star (8 9 10))) (equal (member-if #'stringp '( ((1 2 3) "a" "b") ((1 3 "a") "b" 2 "c") (("c" "a" "b") 1 2 3)) :jey #'cadar) '((("c" "a" "b") 1 2 3)) ) ) ) (do-test "test member-if 2" (and (equal (member-if #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197)) '(ň00 100 197)) (equal (member-if #'(lambda (x) (and (evenp x) (>= x 99))) '(99 98 2 4 200 100 197) :key #'(lambda (x) (1+ x))) '(99 98 2 4 200 100 197)) (equal (member-if #'(lambda (x) (and (listp x) (= (list-length x) 3) (string= (first x) "July"))) '() (mac '(a b c (d e) (f g) "h" ((i) (((ip)))) (j k) (l . l) m n o) 'm ) (mac '((a b) ((c d) e f) (g (h) i) (j (k)) ((l m)n) ((o p) (q r) s) ((((t)) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER.TEST new file mode 100644 index 00000000..e9d578a4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MEMBER ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach / Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 16,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-MEMBER.TEST ;; ;; ;; Syntax: (MEMBER ITEM LIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; The LIST is searched for an element that satisfies the test. ;; If none is found, NIL is returned; ;; otherwise, the tail of LIST beginning ;; with the first element that satisfied the test is returned. ;; The LIST is searched on the top level only. ;; These functions are suitable for use as predicates. ;; For example: ;; ;; (MEMBER 'SNERD '(A B C D)) => NIL ;; (MEMBER-IF #'NUMBERP '(A #\SPACE 5/3 FOO)) => (5/3 FOO) ;; (MEMBER 'A '(G (A Y) C A D E A F)) => (A D E A F) ;; ;; Note, in the last example, ;; that the value returned by MEMBER is EQ to the portion of the list ;; beginning with A. ;; Thus RPLACA on the result of MEMBER may be used ;; to alter the found list element, ;; if a check is first made that MEMBER did not return NIL. ;; ;; See also function FIND and function POSITION. ;; Compatibility note: In Maclisp, the MEMBER function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for MEMBER in Common Lisp. Where in Maclisp one would write ;; (MEMBER X Y), in Common Lisp one must write (MEMBER X Y :TEST #'EQUAL) ;; to get a completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (MEMQ X Y) ;; by writing in Common Lisp (MEMBER X Y :TEST #'EQ). ;; ;; Argument(s): ITEM - anything ;; LIST - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test member - test cases copied from page 275 of CLtL" (and (equal (MEMBER 'SNERD '(A B C D)) NIL) (equal (MEMBER 'A '(G (A Y) C A D E A F)) '(A D E A F)) ) ) (do-test "test member - if the ITEM is not found in LIST , nil is returned" (notany #'member '(a b c d e f g) '((c d e) (e f g) (a b) (a b c) (b c d) (c d e) (a b c d e f))) ) (do-test "test member- the LIST is searched on the top level only" (and (equal (member 2 '(1 3 (2 4) 2 4 6)) '(2 4 6)) (eq (member a '(b c ((a)) (a) d e)) nil) (equal (member 100.05 '((100.05 100.05) 100.005 (100.05) 100.05 . end )) '(100.05 . end)) (equal (member '(1 2 (3)) '(1 2 (3) (1 2 (3)) 3 2 1 ) :test #'equal) '((1 2 (3)) 3 2 1 )) (eq (member #\a '((#\a) ((#\a)) #\A)) nil) (equal (member 'dummy '(a (d ()) "234" () 56) :test-not #'(lambda (x y) (not (null y)))) '(() 56)) ) ) (do-test "test member - the value returned is eq to the portion of LIST beginning with ITEM" (prog2 (defmacro fun1 (item list nth fn) `(eq (member ,item ,list :test ,fn) (nthcdr ,nth ,list))) (and (fun1 4 '(1 2 3 4) 3 #'=) (fun1 #\q '(#\q #\u #\a #\c #\k) 0 #'char=) (fun1 'pretty '(prety preeery prity pretty prreety) 3 #'eq) (fun1 "ab" '("aa" "bb" "ba" "ab") 3 #'equal) (fun1 20.0 '(20 (20.0) -20.0 0.0 20.0 20.0 20.0) 4 #'eql) (fun1 #\q '(#\Q #\u #\a #\c #\k) 0 #'equalp) ) ) ) (do-test "teste member - include :TEST-NOT keyword and REPLACA in the following test cases" (and (equal (rplaca (member 11.0 '(11 22.0 33 44) :test-not #'eq) 99) '(99 22.0 33 44)) (equal (rplaca (member 10 '(1 3 20 4 5 (2 4 6) 24) :test-not #'>=) #\y) '(#\y 4 5 (2 4 6) 24)) (equal (rplaca (member '(a b c) '((c d e) (1 2 3) (a b c d e) (2 . 4)) :test-not #'(lambda (x y) (= (list-length x) (list-length y)))) '(88 99)) '((88 99)(2 . 4))) (equal (rplaca (member "A" '("a" "b" "d" "234" () 56) :test-not #'string-equal) t) '(t "d" "234" () 56)) ) ) (do-test "test member - incluse :KEY keyword in the following test cases" (and (equal (member 'a '((a b c) (b c a) (c a b)) :test #'eq :key #'caddr) '((b c a) (c a b))) (equal (member 10 '((10 20 30) (20 30 10) (30 10 20)) :test #'= :key #'cadr) '((30 10 20))) (equal (member '(1 . 4) '( ((2 . 8) "a" (1 . 4) 1 . 4) ((3 . 6) (1 . 4) (5 . 10)) ((5 . 6) "g" (1 . 4)) ) :test-not #'equal :key #'third) '(((3 . 6) (1 . 4) (5 . 10)) ((5 . 6) "g" (1 . 4)) )) (equal (member 100 '((10 200 300) (1 2 3 4) (1000 2000 3000)) :test-not #'< :key #'second) '((1 2 3 4) (1000 2000 3000)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-NINTERSECTION.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-NINTERSECTION.TEST new file mode 100644 index 00000000..8296be08 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-NINTERSECTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NINTERSECTION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 277 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 24,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-NINTERSECTION.TEST ;; ;; ;; Syntax: (NINTERSECTION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; INTERSECTION takes two lists and returns a new list containing ;; everything that is an element of both argument lists. ;; If either list has duplicate entries, the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (INTERSECTION '(A B C) '(F A D)) => (A) ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the intersection operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' For every matching pair, ;; exactly one of the two elements of the pair will be put in the result. ;; No element from either list appears in the result that does not match ;; an element from the other list. ;; All this is very general, but probably ;; not particularly useful unless the test is an equivalence relation. ;; ;; NINTERSECTION is the destructive version of INTERSECTION. ;; It performs the same operation, but may destroy LIST1 ;; using its cells to construct the result. (The argument LIST2 ;; is NOT destroyed.) ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (DO-TEST "TEST INTERSECTION 0" (prog2 (setq aa '(a b c) bb '(f a d) cc (nintersection aa bb)) (and (equal cc '(a)) (equal bb '(f a d))))) (do-test "test nintersection 1" (and (prog2 (setq aa '(1 2 3 4 5) bb '(4 5 1 8 9) cc (nintersection aa bb)) (and (every #'equal (list bb) '( (4 5 1 8 9))) (= (list-length cc) 3) (every #'(lambda (x) (member x cc :test #'eq)) '(1 5 4)))) (prog2 (setq aa '(a b c d) bb '(x y (z)) cc (nintersection bb aa)) (and (equal bb '(x y (z))) (eq cc nil))) (let* ((aa '(#\a #\b)) (bb '(#\B #\a)) (cc (nintersection aa bb :test #'equalp))) (and (equal bb '(#\B #\a)) (member #\a cc) (member #\b cc :test #'equalp) (= (list-length cc) 2))))) (do-test "test nintersection 2" (progn (setq aa '((Kathy 100) (Karen 50) (Susan 80)) bb '((ken 85) (Henry 70) (kathy 96)) cc (nintersection aa bb :test #'eq :key #'car )) (and (equal bb '((ken 85) (Henry 70) (kathy 96))) (or (equal cc '((Kathy 100))) (equal cc '((Kathy 96))))))) (do-test "test nintersection 3" (progn (setq aa '((10 20 120) (30 60 360.0) (40 50 450)) bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0)) cc (intersection aa bb :test #'= :key #'third)) (and (equal bb '((90.0 100 360) (30.0 20 40.0) (50 40 450.0))) (and (= (list-length cc ) 2) (every #'(lambda (x) (member x cc :test #'= :key #'third)) '(360 450)))))) (do-test "test nintersection 4" (and (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (nintersection aa bb :test-not #'(lambda (x y) (not (equal x y))) )) (and (equal bb '((2 . 3) #\4 aatom 300 #\t "St")) (equal cc '((2 . 3))))) (progn (setq aa '(1 "h" #\T (2 . 3) (list) "st") bb '((2 . 3) #\4 aatom 300 #\t "St") cc (nintersection aa bb :test-not #'(lambda (x y) (not (equalp x y))) )) (and (every #'(lambda (x) (member x cc :test #'equalp)) '((2 . 3) #\t "St")) (= (list-length cc) 3))) (progn (setq aa '((1 3 5) (2 6 7) (10 20)) bb '((10 2 3) ( 20 5 1) ( 2 4 1)) cc (nintersection aa bb :test-not #'(lambda ( x y) (/= (apply #'+ x) (apply #'+ y))))) (or (equal cc '((2 6 7))) (equal cc '((10 2 3))))) (progn (setq aa '("banana" "papaya" "tomamo") bb '("orange" "pineapple" "watermelon") cc (nintersection aa bb :test #'(lambda (x y) (car (mapcar #'find '(#\m #\a ) (list x y)))))) (and (equal bb '("orange" "pineapple" "watermelon")) (some #'(lambda (x) (equal cc x)) '(("orange") ("tomamo") ("pineapple") ("watermelon"))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-DIFFERENCE.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-DIFFERENCE.TEST new file mode 100644 index 00000000..f2e3cd0d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-DIFFERENCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSET-DIFFERENCE ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 278 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-NSET-DIFFERENCE.TEST ;; ;; ;; Syntax: (NSET-DIFFERENCE LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-DIFFERENCE returns a list of elements of LIST1 ;; that do not appear in LIST2. This operation is ;; not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set difference operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' An element of LIST1 ;; appears in the result if and only if it does not match any element ;; of LIST2. This is very general and permits interesting applications. ;; For example, one can remove from a list of strings all those strings ;; containing one of a given list characters: ;; ;; ;; REMOVE ALL FLAVOR NAMES THAT CONTAIN "C" OR "W". ;; (SET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" ;; "LEMON" "PISTACHIO" "RHUBARB") ;; '(#\C #\W) ;; :TEST ;; #'(LAMBDA (S C) (FIND C S))) ;; ;; => ("BANANA" "RHUBARB" "LEMON") ;One possible ordering. ;; ;; ;; NSET-DIFFERENCE is the destructive version of SET-DIFFERENCE. ;; This operation may destroy LIST1. ;; ;; Compatibility note: An approximately equivalent Interlisp function ;; is LDIFFERENCE. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group (group-test :before (defun EQUALLY (x y) (and (= (list-length x) (list-length y)) (every #'(lambda (w) (member w x :test #'equal)) y) ))) (DO-TEST "NSET-DIFFERENCE TEST 1" (and (EQUALLY (NSET-DIFFERENCE '(A B C X C D) '(C C B A)) '(D X)) (EQUALLY (NSET-DIFFERENCE '(D X D Z D F G F) '(C C B A)) '(F G F D Z D X D)) (EQUALLY (NSET-DIFFERENCE '(Z A E D B E F) '(C C B A)) '(F E D E Z)) (EQUALLY (NSET-DIFFERENCE '(F C Z E) '(D X F D D F G)) '(E Z C)) (EQUALLY (NSET-DIFFERENCE '(D Z E E) '(C F A E G C)) '(Z D)) (EQUALLY (NSET-DIFFERENCE '(Z A E D B E F) '(Y F B Z Y F X E)) '(D A)))) (DO-TEST "NSET-DIFFERENCE TEST 2" (and (EQUALLY (NSET-DIFFERENCE '(Y F B Z Y F X E) '(D Z E E)) '(X F Y B F Y)) (EQUALLY (NSET-DIFFERENCE '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (EQUALLY (NSET-DIFFERENCE '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(A F X G X F)) (EQUALLY (NSET-DIFFERENCE '(C B Z B B D Y B E) '(D X D Z D F G F)) '(E B Y B B B C)) (EQUALLY (NSET-DIFFERENCE '(C C B A) '(A B C X C D)) NIL) (EQUALLY (NSET-DIFFERENCE '(C F A E G C) '(Z C Y B E Z D B D)) '(G A F)))) (DO-TEST "NSET-DIFFERENCE TEST 3" (and (EQUALLY (NSET-DIFFERENCE '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK)) (EQUALLY (NSET-DIFFERENCE '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(CATOR)) (EQUALLY (NSET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK PERTY MORY FOO)) (EQUALLY (NSET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (EQUALLY (NSET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (EQUALLY (NSET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(BAZ QIX ZORK PERTY QIX)))) (DO-TEST "NSET-DIFFERENCE TEST 4" (and (EQUALLY (NSET-DIFFERENCE '(MEEF) '(QIX FOO)) '(MEEF)) (EQUALLY (NSET-DIFFERENCE '(MEEF) '(PERTY QIX CATOR)) '(MEEF)) (EQUALLY (NSET-DIFFERENCE '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(CATOR CATOR BAR BAR MORY)) (EQUALLY (NSET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(BAR)) (EQUALLY (NSET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(MEEF MEEF MEEF)) (EQUALLY (NSET-DIFFERENCE '(BAR PERTY BAR) '(QIX FOO)) '(BAR PERTY BAR)))) (DO-TEST "NSET-DIFFERENCE TEST 5" (and (EQUALLY (NSET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(2 6 2 9 2 8)) (EQUALLY (NSET-DIFFERENCE '(3 4) '(6 4 8 4 7 3 2 9)) NIL) (EQUALLY (NSET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(1 5)) (EQUALLY (NSET-DIFFERENCE '(2 7 2) '(4)) '(2 7 2)) (EQUALLY (NSET-DIFFERENCE '(7 3 4 10 8) '(2 9 4)) '(8 10 3 7)) (EQUALLY (NSET-DIFFERENCE '(8 2) '(4 5 1 10 5 7 7 10)) '(2 8)))) (DO-TEST "NSET-DIFFERENCE TEST 6" (and (EQUALLY (NSET-DIFFERENCE '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(10 7 7 10 4)) (EQUALLY (NSET-DIFFERENCE '(4 6 2 8 8) '(2 7 2)) '(8 8 6 4)) (EQUALLY (NSET-DIFFERENCE '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(9 4 4)) (EQUALLY (NSET-DIFFERENCE '(4) '(3 4)) NIL) (EQUALLY (NSET-DIFFERENCE '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(4)) (EQUALLY (NSET-DIFFERENCE '(2 9 4) '(2 7 2)) '(4 9)))) (do-test "test nset-difference - test case copied from page 278 of CLtL" (equally (NSET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" "LEMON" "PISTACHIO" "RHUBARB") '(#\C #\W) :TEST #'(LAMBDA (S C) (FIND C S))) '( "RHUBARB" "LEMON" "BANANA") ) ) (do-test "test nset-difference 8" (and (prog2 (setq aa '("STRAWBERRY" "CHOCOLATE" "BANANA" ) bb '("123456" "chocochoco" "strawstrawst") cc (nset-difference aa bb :test-not #'(lambda (x y) (/= (length x) (length y))))) (and (equally cc '("CHOCOLATE")) ) ) (prog2 (setq aa '((1 2) "hello" long-atom) aaa aa bb '(2 3 4 5 6 7) bbb bb cc (nset-difference aa bb :test #'(lambda (x y) (numberp y))) dd (nset-difference aaa bbb :test-not #'(lambda (x y) (not (numberp x))))) (and (eq cc nil) (equally dd '(long-atom "hello" (1 2))) ) ) ) ) (do-test "test nset-difference 9" (and (progn (setq aa '( (1 () (2 3 4 (5))) (a b c d (e f g)) (a z x (8 9) d (l o n e y))) bb '( (() () () () (w x y z)) ((10 20 30)) (n i l (n i l))) cc (nset-difference aa bb :test #'(lambda (x y) (= (length x) (length y))) :key #'(lambda(x) (car (last x))) )) (equally cc '((a z x (8 9) d (l o n e y)))) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-EXCLUSIVE-OR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-EXCLUSIVE-OR.TEST new file mode 100644 index 00000000..d82c3e71 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-NSET-EXCLUSIVE-OR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NSET-EXCLUSIVE-OR ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 278 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: October 23,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-NSET-EXCLUSIVE-OR.TEST ;; ;; Modification: Changed calls to COPY (not a CML fn) to COPY-TREE. With ;; packages, COPY in LISP does not exist. ;; ;; Syntax: (NSET-EXCLUSIVE-OR LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-EXCLUSIVE-OR returns a list of elements that appear ;; in exactly one of LIST1 and LIST2. ;; This operation is not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set-exclusive-or operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' The result contains precisely ;; those elements of LIST1 and LIST2 that appear in no matching pair. ;; ;; NSET-EXCLUSIVE-OR is the destructive version of SET-EXCLUSIVE-OR. ;; Both lists may be destroyed in producing the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group ( test-nset-exclusive-or-group :before (progn (defmacro mac (x y) `(every #'(lambda (z) (member z ,y :test #'equal)) ,x)))) (DO-TEST "TEST NSET-EXCLUSIVE-OR0" (AND (MAC (NSET-EXCLUSIVE-OR '(A B C X C D) '(C C B A)) '(D X)) (MAC (NSET-EXCLUSIVE-OR '(D X D Z D F G F) '(C C B A)) '(A B C C F G F D Z D X D)) (MAC (NSET-EXCLUSIVE-OR '(Z A E D B E F) '(C C B A)) '(C C F E D E Z)) (MAC (NSET-EXCLUSIVE-OR '(F C Z E) '(D X F D D F G)) '(G D D X D E Z C)) (MAC (NSET-EXCLUSIVE-OR '(D Z E E) '(C F A E G C)) '(C G A F C Z D)) (MAC (NSET-EXCLUSIVE-OR '(Z A E D B E F) '(Y F B Z Y F X E)) '(X Y Y D A)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 2" (AND (MAC (NSET-EXCLUSIVE-OR '(Y F B Z Y F X E) '(D Z E E)) '(D X F Y B F Y)) (MAC (NSET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (MAC (NSET-EXCLUSIVE-OR '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(D B D B Y A F X G X F)) (MAC (NSET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(D X D Z D F G F)) '(F G F X E B Y B B B C)) (MAC (NSET-EXCLUSIVE-OR '(C C B A) '(A B C X C D)) '(D X)) (MAC (NSET-EXCLUSIVE-OR '(C F A E G C) '(Z C Y B E Z D B D)) '(D B D Z B Y Z G A F)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 3" (AND (MAC (NSET-EXCLUSIVE-OR '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(QIX QIX MEEF MEEF MEEF BAZ BAZ QIX BAR ZORK)) (MAC (NSET-EXCLUSIVE-OR '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(BAR CATOR)) (MAC (NSET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(MEEF MEEF MEEF ZORK PERTY MORY FOO)) (MAC (NSET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (MAC (NSET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (MAC (NSET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(CATOR CATOR BAZ QIX ZORK PERTY QIX)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 4" (AND (MAC (NSET-EXCLUSIVE-OR '(MEEF) '(PERTY QIX CATOR)) '(CATOR QIX PERTY MEEF)) (MAC (NSET-EXCLUSIVE-OR '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(QIX CATOR CATOR BAR BAR MORY)) (MAC (NSET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(MORY ZORK MORY PERTY BAR)) (MAC (NSET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(ZORK PERTY MORY FOO MEEF MEEF MEEF)) (MAC (NSET-EXCLUSIVE-OR '(BAR PERTY BAR) '(QIX FOO)) '(FOO QIX BAR PERTY BAR)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 5" (AND (MAC (NSET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 10 4 2 6 2 9 2 8)) (MAC (NSET-EXCLUSIVE-OR '(3 4) '(6 4 8 4 7 3 2 9)) '(9 2 7 8 6)) (MAC (NSET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(3 7 4 4 1 5)) (MAC (NSET-EXCLUSIVE-OR '(2 7 2) '(4)) '(4 2 7 2)) (MAC (NSET-EXCLUSIVE-OR '(7 3 4 10 8) '(2 9 4)) '(9 2 8 10 3 7)) (MAC (NSET-EXCLUSIVE-OR '(8 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 5 10 1 5 4 2 8)))) (DO-TEST "NSET-EXCLUSIVE-OR TEST 6" (AND (MAC (NSET-EXCLUSIVE-OR '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(2 6 2 9 2 8 10 7 7 10 4)) (MAC (NSET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 7 2)) '(7 8 8 6 4)) (MAC (NSET-EXCLUSIVE-OR '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(5 9 4 4)) (MAC (NSET-EXCLUSIVE-OR '(4) '(3 4)) '(3)) (MAC (NSET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(3 7 7 5 4)) (MAC (NSET-EXCLUSIVE-OR '(2 9 4) '(2 7 2)) '(7 4 9)))) (do-test "test nset-exclusive-or - with :TEST keyword" (and (progn (setq aa '(2 4 #\a #\z 8 10) aaa (copy-tree aa) bb '(#\Z 10.0 4 2) bbb (copy-tree bb) cc (nset-exclusive-or aa bb) dd (nset-exclusive-or aaa bbb :test #'equalp)) (and (mac cc '( 10.0 #\Z 10 8 #\z #\a)) (mac dd '(8 #\a)))) (progn (setq aa '("a" "b" "c" "d" "e" "F" "G" "I" "J") aaaa (copy-tree aa) aaa (copy-tree aa) bb '("A" "B" "c" "D" "E" "f" "G") bbbb (copy-tree bb) bbb (copy-tree bb) cc (nset-exclusive-or aa bb) dd (nset-exclusive-or aaa bbb :test #'string=) ee (nset-exclusive-or aaaa bbbb :test #'string-equal)) (and (mac cc '("G" "f" "E" "D" "c" "B" "A" "J" "I" "G" "F" "e" "d" "c" "b" "a")) (mac dd '("f" "E" "D" "B" "A" "J" "I" "F" "e" "d" "b" "a")) (mac ee '("J" "I")))))) (do-test "test nset-exclusive-or - with :TEST-NOT keyword" (and (progn (setq aa '((1 2 3) (a b) (x y z (g))) bb '(nil (nil nil nil) ((t t) (t)) (t nil (t . nil) t)) cc (nset-exclusive-or aa bb :test-not #'(lambda (x y) (/= (list-length x) (list-length y))))) (equal cc '(nil))) (progn (setq aa '("set" "difference" "exclusive" "not") bb '("south" "xoy") cc (nset-exclusive-or bb aa :test-not #'(lambda (a b) (/= (length a) (length b))))) (mac cc '("exclusive" "difference" "south"))))) (do-test "test nset-exclusive-or - with :KEY keyword" (progn (setq aa '((a 10) (b 20) (s 80) (t 100)) bb '((S 160) (x 100) (a 30) (y 45)) aaa (copy-tree aa) bbb (copy-tree bb) cc (nset-exclusive-or bb aa :key #'car) dd (nset-exclusive-or bbb aaa :key #'cadr)) (and (mac cc '((t 100) (b 20) (y 45) (x 100))) (mac dd '((s 80) (b 20) (a 10) (y 45) (a 30) (S 160)))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-NUNION.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-NUNION.TEST new file mode 100644 index 00000000..f61c1bf5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-NUNION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NUNION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 276 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 23,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-NUNION.TEST ;; ;; ;; Syntax: (NUNION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; UNION takes two lists and returns a new list containing ;; everything that is an element of either of the LISTS. ;; If there is a duplication between two lists, ;; only one of the duplicate instances will be in the result. ;; If either of the arguments has duplicate entries within it, ;; the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (UNION '(A B C) '(F A D)) ;; => (A B C F D) or (B C F A D) or (D F A B C) or ... ;; ;; (UNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) ;; => ((X 5) (Y 6) (Z 2)) or ((X 4) (Y 6) (Z 2)) or ... ;; ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the union operation may be ;; described as follows. For all possible ordered pairs consisting of one ;; element from LIST1 and one element from LIST2, the test is used ;; ;; to determine whether they ``match.'' For every matching pair, at least ;; one of the two elements of the pair will be in the result. Moreover, any ;; element from either list that matches no element of the other will appear ;; in the result. All this is very general, but probably not particularly ;; useful unless the test is an equivalence relation. ;; ;; The :TEST-NOT argument can be useful when the test function ;; is the logical negation of an equivalence test. A good example ;; of this is the function function MISMATCH, which is logically inverted ;; so that possibly useful information can be returned if the arguments do not ;; match. This additional ``useful information'' is discarded in the following ;; example; MISMATCH is used purely as a predicate. ;; ;; (UNION '(#(A B) #(5 0 6) #(F 3)) ;; '(#(5 0 6) (A B) #(G H)) ;; :TEST-NOT ;; #'MISMATCH) ;; => (#(A B) #(5 0 6) #(F 3) #(G H)) ;One possible result ;; => ((A B) #(F 3) #(5 0 6) #(G H)) ;Another possible result ;; ;; ;; Using :TEST-NOT #'MISMATCH differs from using ;; :TEST #'EQUALP, for example, because MISMATCH ;; will determine that #(A B) and (A B) are the same, ;; while function EQUALP would regard them as not the same. ;; ;; NUNION is the destructive version of UNION. ;; It performs the same operation but may destroy the argument lists, ;; using their cells to construct the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test nunion - test cases copied from page 276 and page 277 of CLtL" (and (let (( a (NUNION '(A B C) '(F A D)) )) (every #'(lambda (x) (member x a :test #'eq)) '(A B C F D)) ) (let (( a (NUNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) )) (and (member 'X a :test #'eq :key #'car) (every #'(lambda (x) (member x a :test #'equal)) '((Y 6) (Z 2))) ) ) ) ) (do-test "test nunion 1" (and (progn (setq a '(1 2 3 4) b '(5 6 7 8 9) ab (nunion a b)) (every #'(lambda (x) (member x ab)) '(1 2 3 4 5 6 7 8 9)) ) (progn (setq a '( (1 2) "one" "two" ( 1 . 2)) b '( "three" ( 3 4) "four" (3 . 4)) ab (nunion a b)) (every #'(lambda (x) (member x ab :test #'equal)) '("three" ( 3 4) "four" (3 . 4) (1 2) "one" "two" ( 1 . 2))) ) (prog2 (setq a '(1 2) b '(1 2) c (nunion a b)) (every #'(lambda (x) (member x c :test #'eq)) '(2 1)) ) (prog2 (setq aa '("a" "b" "c" "d" "e" "f") bb '("d" "e" "f" "g" "h" "i") cc (nunion aa bb)) (every #'(lambda (x) (member x cc :test #'equal)) '("d" "e" "f" "g" "h" "i" "a" "b" "c")) ) (prog2 (setq aa '((1 2 3 (4 5) (6 7)) 8 9 10 11) bb '(#\a "string" (1 2 3 (4 5) (6 7)) 10 #\v) cc (nunion aa bb)) (every #'(lambda (x) (member x cc :test #'equal)) '((1 2 3 (4 5) (6 7)) 8 9 10 11 #\a #\v "string")) ) ) ) (do-test "test nunion 2" (and (progn (setq a '((a b) (x y) (o p)) b '((1 2) (4 y) (7 p)) cc (nunion a b :test #'eq :key #'cadr)) (and (member 'p cc :key #'cadr) (member 'y cc :key #'cadr) (every #'(lambda (x) (member x cc :test #'equal)) '((a b) (1 2))) ) ) (progn (setq a '((poco a poco rit end) (sound little)) b '((rit little by little ) (by degrees) (end)) cc (nunion a b :test #'equal :key #'last)) (and (member '(little) cc :test #'equal :key #'last) (member '(end) cc :test #'equal :key #'last) (every #'(lambda (x) (member x cc :test #'equal)) '((by degrees))) ) ) ) ) (do-test "test nunion 3" (and (progn (setq aa '((1 #\3 4) (5 #\7) (9 #\1)) bb '((2 #\7 9) (8 #\9 20) (99 #\8)) cc (nunion aa bb :test-not #'char/= :key #'second)) (and (member-if #'(lambda (x) (char= x #\7)) cc :key #'second) (every #'(lambda (x) (member x cc :test #'equal)) '((1 #\3 4) (9 #\1) (8 #\9 20) (99 #\8))) ) ) (progn (setq aa '(("blue" ("green")) ("yellow" ("red")) ("purple" ("blue"))) bb '(("blue" ("Green")) ("yellow" ("blue")) ("yellow" ("Red"))) cc (nunion aa bb :test-not #'(lambda (x y) (not (string= x y))) :key #'caadr)) (and (member-if-not #'(lambda (x) (not (string= x "blue"))) cc :key #'caadr) (every #'(lambda (x) (member x cc :test #'equal)) '( ("blue" ("green")) ("yellow" ("red")) ("blue" ("Green")) ("yellow" ("Red"))) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-SET-DIFFERENCE.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-SET-DIFFERENCE.TEST new file mode 100644 index 00000000..c5a83454 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-SET-DIFFERENCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SET-DIFFERENCE ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 278 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-SET-DIFFERENCE.TEST ;; ;; ;; Syntax: (SET-DIFFERENCE LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-DIFFERENCE returns a list of elements of LIST1 ;; that do not appear in LIST2. This operation is ;; not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set difference operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' An element of LIST1 ;; appears in the result if and only if it does not match any element ;; of LIST2. This is very general and permits interesting applications. ;; For example, one can remove from a list of strings all those strings ;; containing one of a given list characters: ;; ;; ;; REMOVE ALL FLAVOR NAMES THAT CONTAIN "C" OR "W". ;; (SET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" ;; "LEMON" "PISTACHIO" "RHUBARB") ;; '(#\C #\W) ;; :TEST ;; #'(LAMBDA (S C) (FIND C S))) ;; ;; => ("BANANA" "RHUBARB" "LEMON") ;One possible ordering. ;; ;; ;; NSET-DIFFERENCE is the destructive version of SET-DIFFERENCE. ;; This operation may destroy LIST1. ;; ;; Compatibility note: An approximately equivalent Interlisp function ;; is LDIFFERENCE. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group ( test-set-exclusive-or-group :before (progn (defmacro mac (x y) `(every #'(lambda (z) (member z ,y :test #'equal)) ,x)))) (DO-TEST "SET-DIFFERENCE TEST 1" (and (mac (SET-DIFFERENCE '(A B C X C D) '(C C B A)) '(D X)) (mac (SET-DIFFERENCE '(D X D Z D F G F) '(C C B A)) '(F G F D Z D X D)) (mac (SET-DIFFERENCE '(Z A E D B E F) '(C C B A)) '(F E D E Z)) (mac (SET-DIFFERENCE '(F C Z E) '(D X F D D F G)) '(E Z C)) (mac (SET-DIFFERENCE '(D Z E E) '(C F A E G C)) '(Z D)) (mac (SET-DIFFERENCE '(Z A E D B E F) '(Y F B Z Y F X E)) '(D A)))) (DO-TEST "SET-DIFFERENCE TEST 2" (and (mac (SET-DIFFERENCE '(Y F B Z Y F X E) '(D Z E E)) '(X F Y B F Y)) (mac (SET-DIFFERENCE '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (mac (SET-DIFFERENCE '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(A F X G X F)) (mac (SET-DIFFERENCE '(C B Z B B D Y B E) '(D X D Z D F G F)) '(E B Y B B B C)) (mac (SET-DIFFERENCE '(C C B A) '(A B C X C D)) NIL) (mac (SET-DIFFERENCE '(C F A E G C) '(Z C Y B E Z D B D)) '(G A F)))) (DO-TEST "SET-DIFFERENCE TEST 3" (and (mac (SET-DIFFERENCE '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK)) (mac (SET-DIFFERENCE '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(CATOR)) (mac (SET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(ZORK PERTY MORY FOO)) (mac (SET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (mac (SET-DIFFERENCE '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) NIL) (mac (SET-DIFFERENCE '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(BAZ QIX ZORK PERTY QIX)))) (DO-TEST "SET-DIFFERENCE TEST 4" (and (mac (SET-DIFFERENCE '(MEEF) '(QIX FOO)) '(MEEF)) (mac (SET-DIFFERENCE '(MEEF) '(PERTY QIX CATOR)) '(MEEF)) (mac (SET-DIFFERENCE '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(CATOR CATOR BAR BAR MORY)) (mac (SET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(BAR)) (mac (SET-DIFFERENCE '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(MEEF MEEF MEEF)) (mac (SET-DIFFERENCE '(BAR PERTY BAR) '(QIX FOO)) '(BAR PERTY BAR)))) (DO-TEST "SET-DIFFERENCE TEST 5" (and (mac (SET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(2 6 2 9 2 8)) (mac (SET-DIFFERENCE '(3 4) '(6 4 8 4 7 3 2 9)) NIL) (mac (SET-DIFFERENCE '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(1 5)) (mac (SET-DIFFERENCE '(2 7 2) '(4)) '(2 7 2)) (mac (SET-DIFFERENCE '(7 3 4 10 8) '(2 9 4)) '(8 10 3 7)) (mac (SET-DIFFERENCE '(8 2) '(4 5 1 10 5 7 7 10)) '(2 8)))) (DO-TEST "SET-DIFFERENCE TEST 6" (and (mac (SET-DIFFERENCE '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(10 7 7 10 4)) (mac (SET-DIFFERENCE '(4 6 2 8 8) '(2 7 2)) '(8 8 6 4)) (mac (SET-DIFFERENCE '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(9 4 4)) (mac (SET-DIFFERENCE '(4) '(3 4)) NIL) (mac (SET-DIFFERENCE '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(4)) (mac (SET-DIFFERENCE '(2 9 4) '(2 7 2)) '(4 9)))) (do-test "test set-difference - test case copied from page 278 of CLtL" (mac (SET-DIFFERENCE '("STRAWBERRY" "CHOCOLATE" "BANANA" "LEMON" "PISTACHIO" "RHUBARB") '(#\C #\W) :TEST #'(LAMBDA (S C) (FIND C S))) '( "RHUBARB" "LEMON" "BANANA") ) ) (do-test "test set-difference 8" (and (prog2 (setq aa '("STRAWBERRY" "CHOCOLATE" "BANANA" ) bb '("123456" "chocochoco" "strawstrawst") cc (set-difference aa bb :test-not #'(lambda (x y) (/= (length x) (length y))))) (and (mac cc '("CHOCOLATE")) (equal aa '("STRAWBERRY" "CHOCOLATE" "BANANA" )) (equal bb '("123456" "chocochoco" "strawstrawst")) ) ) (prog2 (setq aa '((1 2) "hello" long-atom) bb '(2 3 4 5 6 7) cc (set-difference aa bb :test #'(lambda (x y) (numberp y))) dd (set-difference aa bb :test-not #'(lambda (x y) (not (numberp x))))) (and (eq cc nil) (mac dd '(long-atom "hello" (1 2))) (equal aa '((1 2) "hello" long-atom)) (equal bb '(2 3 4 5 6 7)) ) ) ) ) (do-test "test set-difference 9" (and (progn (setq aa '( (1 () (2 3 4 (5))) (a b c d (e f g)) (a z x (8 9) d (l o n e y))) bb '( (() () () () (w x y z)) ((10 20 30)) (n i l (n i l))) cc (set-difference aa bb :test #'(lambda (x y) (= (length x) (length y))) :key #'(lambda(x) (car (last x))) )) (and (mac cc '((a z x (8 9) d (l o n e y)))) (equal aa '( (1 () (2 3 4 (5))) (a b c d (e f g)) (a z x (8 9) d (l o n e y)))) (equal bb '( (() () () () (w x y z)) ((10 20 30)) (n i l (n i l)))) ) ) ) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-SET-EXCLUSIVE-OR.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-SET-EXCLUSIVE-OR.TEST new file mode 100644 index 00000000..25d653dc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-SET-EXCLUSIVE-OR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SET-EXCLUSIVE-OR ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 278 ;; ;; Created By: Kelly Roach , KARIN SYE ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 25,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-SET-EXCLUSIVE-OR.TEST ;; ;; ;; Syntax: (SET-EXCLUSIVE-OR LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SET-EXCLUSIVE-OR returns a list of elements that appear ;; in exactly one of LIST1 and LIST2. ;; This operation is not destructive. ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the set-exclusive-or operation ;; may be described as follows. For all possible ordered pairs consisting of ;; one element from LIST1 and one element from LIST2, the test is ;; used to determine whether they ``match.'' The result contains precisely ;; those elements of LIST1 and LIST2 that appear in no matching pair. ;; ;; NSET-EXCLUSIVE-OR is the destructive version of SET-EXCLUSIVE-OR. ;; Both lists may be destroyed in producing the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test-group ( test-set-exclusive-or-group :before (progn (defmacro mac (x y) `(every #'(lambda (z) (member z ,y :test #'equal)) ,x)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 1" (AND (mac (SET-EXCLUSIVE-OR '(A B C X C D) '(C C B A)) '(D X)) (mac (SET-EXCLUSIVE-OR '(D X D Z D F G F) '(C C B A)) '(A B C C F G F D Z D X D)) (mac (SET-EXCLUSIVE-OR '(Z A E D B E F) '(C C B A)) '(C C F E D E Z)) (mac (SET-EXCLUSIVE-OR '(F C Z E) '(D X F D D F G)) '(G D D X D E Z C)) (mac (SET-EXCLUSIVE-OR '(D Z E E) '(C F A E G C)) '(C G A F C Z D)) (mac (SET-EXCLUSIVE-OR '(Z A E D B E F) '(Y F B Z Y F X E)) '(X Y Y D A)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 2" (AND (mac (SET-EXCLUSIVE-OR '(Y F B Z Y F X E) '(D Z E E)) '(D X F Y B F Y)) (mac (SET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(Z C Y B E Z D B D)) NIL) (mac (SET-EXCLUSIVE-OR '(F X G Z E X F A C Z) '(Z C Y B E Z D B D)) '(D B D B Y A F X G X F)) (mac (SET-EXCLUSIVE-OR '(C B Z B B D Y B E) '(D X D Z D F G F)) '(F G F X E B Y B B B C)) (mac (SET-EXCLUSIVE-OR '(C C B A) '(A B C X C D)) '(D X)) (mac (SET-EXCLUSIVE-OR '(C F A E G C) '(Z C Y B E Z D B D)) '(D B D Z B Y Z G A F)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 3" (AND (mac (SET-EXCLUSIVE-OR '(ZORK) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(QIX QIX MEEF MEEF MEEF BAZ BAZ QIX BAR ZORK)) (mac (SET-EXCLUSIVE-OR '(MEEF MEEF QIX BAZ CATOR) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(BAR CATOR)) (mac (SET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX)) '(MEEF MEEF MEEF ZORK PERTY MORY FOO)) (mac (SET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (mac (SET-EXCLUSIVE-OR '(ZORK) '(PERTY BAZ ZORK MEEF BAR PERTY ZORK)) '(PERTY BAR MEEF BAZ PERTY)) (mac (SET-EXCLUSIVE-OR '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ) '(MORY BAR BAR FOO CATOR CATOR)) '(CATOR CATOR BAZ QIX ZORK PERTY QIX)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 4" (AND (mac (SET-EXCLUSIVE-OR '(MEEF) '(PERTY QIX CATOR)) '(CATOR QIX PERTY MEEF)) (mac (SET-EXCLUSIVE-OR '(MORY BAR BAR FOO CATOR CATOR) '(QIX FOO)) '(QIX CATOR CATOR BAR BAR MORY)) (mac (SET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(PERTY MORY ZORK QIX MEEF MEEF MEEF MORY BAZ)) '(MORY ZORK MORY PERTY BAR)) (mac (SET-EXCLUSIVE-OR '(BAR QIX BAZ BAZ MEEF MEEF MEEF QIX QIX) '(FOO QIX MORY PERTY ZORK QIX BAR BAR BAZ)) '(ZORK PERTY MORY FOO MEEF MEEF MEEF)) (mac (SET-EXCLUSIVE-OR '(BAR PERTY BAR) '(QIX FOO)) '(FOO QIX BAR PERTY BAR)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 5" (AND (mac (SET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 10 4 2 6 2 9 2 8)) (mac (SET-EXCLUSIVE-OR '(3 4) '(6 4 8 4 7 3 2 9)) '(9 2 7 8 6)) (mac (SET-EXCLUSIVE-OR '(8 5 2 9 2 6 1 2) '(6 4 8 4 7 3 2 9)) '(3 7 4 4 1 5)) (mac (SET-EXCLUSIVE-OR '(2 7 2) '(4)) '(4 2 7 2)) (mac (SET-EXCLUSIVE-OR '(7 3 4 10 8) '(2 9 4)) '(9 2 8 10 3 7)) (mac (SET-EXCLUSIVE-OR '(8 2) '(4 5 1 10 5 7 7 10)) '(10 7 7 5 10 1 5 4 2 8)))) (DO-TEST "SET-EXCLUSIVE-OR TEST 6" (AND (mac (SET-EXCLUSIVE-OR '(4 5 1 10 5 7 7 10) '(8 5 2 9 2 6 1 2)) '(2 6 2 9 2 8 10 7 7 10 4)) (mac (SET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 7 2)) '(7 8 8 6 4)) (mac (SET-EXCLUSIVE-OR '(6 4 8 4 7 3 2 9) '(2 5 8 2 7 2 7 6 3)) '(5 9 4 4)) (mac (SET-EXCLUSIVE-OR '(4) '(3 4)) '(3)) (mac (SET-EXCLUSIVE-OR '(4 6 2 8 8) '(2 5 8 2 7 2 7 6 3)) '(3 7 7 5 4)) (mac (SET-EXCLUSIVE-OR '(2 9 4) '(2 7 2)) '(7 4 9)))) (do-test "test set-exclusive-or - with :TEST keyword" (and (progn (setq aa '(2 4 #\a #\z 8 10) aaa aa bb '(#\Z 10.0 4 2) bbb bb cc (set-exclusive-or aa bb) dd (set-exclusive-or aaa bbb :test #'equalp)) (and (equal aa aaa) (equal bb bbb) (mac cc '( 10.0 #\Z 10 8 #\z #\a)) (mac dd '(8 #\a)))) (progn (setq aa '("a" "b" "c" "d" "e" "F" "G" "I" "J") aaa aa bb '("A" "B" "c" "D" "E" "f" "G") bbb bb cc (set-exclusive-or aa bb) dd (set-exclusive-or aaa bbb :test #'string=) ee (set-exclusive-or aaa bbb :test #'string-equal)) (and (equal aaa aa) (equal bbb bb) (mac cc '("G" "f" "E" "D" "c" "B" "A" "J" "I" "G" "F" "e" "d" "c" "b" "a")) (mac dd '("f" "E" "D" "B" "A" "J" "I" "F" "e" "d" "b" "a")) (mac ee '("J" "I")))))) (do-test "test set-exclusive-or - with :TEST-NOT keyword" (and (progn (setq aa '( (1 2 3) (a b) (x y z (g)) ) aaa aa bb '( () ( () () () ) ((t t) (t)) (t nil (t . nil) t) ) bbb bb cc (set-exclusive-or aa bb :test-not #'(lambda (x y) (/= (list-length x) (list-length y))) )) (and (equal aaa aa) (equal bbb bb) (mac cc '( () ) ))) (progn (setq aa '("set" "difference" "exclusive" "not") aaa aa bb '("south" "xoy" ) bbb bb cc (set-exclusive-or bb aa :test-not #'(lambda (a b) (/= (length a) (length b))))) (and (equal aaa aa) (equal bbb bb) (mac cc '("exclusive" "difference" "south")))))) (do-test "test set-exclusive-or - with :KEY keyword" (progn (setq aa '((a 10) (b 20) (s 80) (t 100)) bb '((S 160) (x 100) (a 30) (y 45)) cc (set-exclusive-or bb aa :key #'car) dd (set-exclusive-or bb aa :key #'cadr)) (and (mac cc '((t 100) (b 20) (y 45) (x 100))) (mac dd '((s 80) (b 20) (a 10) (y 45) (a 30) (S 160)))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-SUBSETP.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-SUBSETP.TEST new file mode 100644 index 00000000..e5dc5abc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-SUBSETP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SUBSETP ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 279 ;; ;; Created By: Kelly Roach , KARIN SYE ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 28,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-SUBSETP.TEST ;; ;; ;; Syntax: (SUBSETP LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; SUBSETP is a predicate that is true if every element of LIST1 ;; appears in (``matches'' some element of) LIST2, and false otherwise. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: T or NIL ;; (do-test "test subsetp 0" (and (subsetp '(1 2) '(1 2 3 4)) (subsetp () '( () ()) ) (subsetp '(a) '(z x y b a)) (subsetp (list 'name1) '(name9 (name8) name4 name1 name3)) (subsetp (list (1+ 99)) '(100.0 88 99 1 100)) (subsetp '(#\q #\h #\a) '(#\h #\a #\p #\q #\y)))) (do-test "test subsetp - with :TEST keyword" (and (subsetp '("str1" "str2" ) '(str5 "str6" "str3" "str4" "str7" "str1" "str9" "str2") :test #'string=) (subsetp `((1 . 2) (())) '(a b (1 . 2) t (()) c d e ()) :test #'equal) (subsetp '(1.0 2.0 3.0 4.0) '(2.0 10 20 1.0 3 4 5 3.0 6 4.0) :test #'=) (subsetp '(#3r10 #5r10 ) '(3.0 #c(1 -1) 5 10 12 #c(1 2) #c(-1 -1)) :test #'=) (subsetp '(#c(1 -1) #c(-1 -1)) '(#c(1 -1) 5 10 12 #c(1 2) #c(-1 -1)) :test #'equal) (subsetp '(a b c d) '(((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) :test #'rassoc))) (do-test "test subsetp - with :TEST-NOT keyword" (and (subsetp '(2 4 6) '(a b c d) :test-not #'(lambda (x y) (oddp x))) (subsetp '("k" "i" "t" "e") '(sound of music) :test-not #'(lambda (x y) (listp y))) (subsetp '(#\m #\x #\y) '("retardanto" "poco a poco" "adagio") :test-not #'(lambda (x y) (find x y))) (subsetp '(#c(1 9) #c(-1 2) #c(0 3)) '(2 ) :test-not #'(lambda (x y) (eq (type-of x) (type-of y)) )) (subsetp '(a b c d) '(((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) :test-not #'assoc))) (do-test "test subsetp - with :KEY keyword" (and (subsetp '((8 2) (2 4) (4 6)) '((2 3) (4 5) (6 7) (8 9)) :key #'first) (subsetp '( (a ((#\A) 1) 1) (b ((#\B) 2) 2) (c (( #\C) 3) 3)) '(( 1 ((#\A) 1) 1) (b ((#\B) 2) 2) (c (( #\C) 3) 3)) :test #'equalp :key #'caaadr) (subsetp '( (a b c (d)) (1 2 3 (4 5)) (w x y ((z))) ) '( (c b a (d) s z b c) (3 2 1 9 (4 5) 2 3) (y x w s p ((z)) x y)) :test #'(lambda (x y) (member (car x) y :test #'equal)) :key #'(lambda (x) (nthcdr 3 x)) ))) (do-test "test subsetp 2" (not (or (subsetp '(2 3) '(1 3 5)) (subsetp '(1 3 5) '(1.0 2.0 5.0 4.0 3.0)) (subsetp '(#\z #\r #\o #\w) '("zebra" "kangaroo" "ostrich") :test #'(lambda (x y) (find x y))) (subsetp '(-1 -3 -5 -6) '(t) :test-not #'(lambda (x y) (plusp (expt x 2))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-TAILP.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-TAILP.TEST new file mode 100644 index 00000000..2e0cd1c1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-TAILP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TAILP ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 275 ;; ;; Created By: Kelly Roach , Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: July 15,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-TAILP.TEST ;; ;; ;; Syntax: (TAILP X Y) ;; ;; Function Description: ;; This predicate is true if SUBLIST is a sublist of LIST (i.e., ;; one of the conses that makes up LIST); otherwise it is false. ;; Another way to look at this is that TAILP is true if ;; (NTHCDR N LIST) is SUBLIST, for some value of N. ;; See function LDIFF. ;; ;; Argument(s): X - a list ;; Y - a list ;; ;; Returns: T or NIL ;; (do-test "test tailp - SUBLIST is not a sublist of LIST " (not (or (tailp '(1) '(1 2)) (tailp '(a b) '( d c a b)) (tailp '() '(1 2 () 3 4)) (tailp '( 4 . 5) '((2 . 3) (4 . 5))) (let* ((a '(1 (2 3))) (b (copy-list a))) (tailp a b)) (progn (setq a '(1 2 3 4) b (append a nil)) (tailp a b)) ) ) ) (do-test "test tailp 1 " (and (progn (setq a '(1 2 3 4 5 6) b (nthcdr 3 a) c (nthcdr 5 a) d (nthcdr 1 b)) (and (tailp b a) (tailp c a) (tailp d a)) ) (let () (defun fun (list n) (tailp (nthcdr n list) list)) (and (fun '(10 9 8 7 6 5 4 3 2 1) 5) (fun '(( a b c d) e f g h (i j k) l m n) 1) (fun (make-list 200 :initial-element 'quack) 190) (fun (make-list 150 :initial-element '(1 . 2)) 100) (fun (make-list 125 :initial-element #\w) 75) t ) ) ) ) (do-test "test tailp 2" (progn (setq a '(1 2 3 4 5 (6 7) (8 9 10) 11 12)) (and (tailp (cdr a) a) (tailp (cdr (cddddr a)) a) (tailp (cdddr a) a) (tailp (cdddr (cdddr a)) a) (tailp (last a) a) t ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-5-UNION.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-5-UNION.TEST new file mode 100644 index 00000000..172f1a64 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-UNION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: UNION ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.5 Using Lists as Sets ;; Page: 276 ;; ;; Created By: Kelly Roach , Karin M. Sye ;; ;; Creation Date: July 22,1986 ;; ;; Last Update: July 23,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-5-UNION.TEST ;; ;; ;; Syntax: (UNION LIST1 LIST2 &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; UNION takes two lists and returns a new list containing ;; everything that is an element of either of the LISTS. ;; If there is a duplication between two lists, ;; only one of the duplicate instances will be in the result. ;; If either of the arguments has duplicate entries within it, ;; the redundant entries ;; may or may not appear in the result. ;; For example: ;; ;; (UNION '(A B C) '(F A D)) ;; => (A B C F D) or (B C F A D) or (D F A B C) or ... ;; ;; (UNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) ;; => ((X 5) (Y 6) (Z 2)) or ((X 4) (Y 6) (Z 2)) or ... ;; ;; ;; There is no guarantee that the order of elements in the result will ;; reflect the ordering of the arguments in any particular way. ;; The implementation is therefore free to use any of a variety of strategies. ;; The result list may share cells with, or be EQ to, either of the arguments ;; if appropriate. ;; ;; In general, the test may be any predicate, and the union operation may be ;; described as follows. For all possible ordered pairs consisting of one ;; element from LIST1 and one element from LIST2, the test is used ;; to determine whether they ``match.'' For every matching pair, at least ;; one of the two elements of the pair will be in the result. Moreover, any ;; element from either list that matches no element of the other will appear ;; in the result. All this is very general, but probably not particularly ;; useful unless the test is an equivalence relation. ;; ;; The :TEST-NOT argument can be useful when the test function ;; is the logical negation of an equivalence test. A good example ;; of this is the function function MISMATCH, which is logically inverted ;; so that possibly useful information can be returned if the arguments do not ;; match. This additional ``useful information'' is discarded in the following ;; example; MISMATCH is used purely as a predicate. ;; ;; (UNION '(#(A B) #(5 0 6) #(F 3)) ;; '(#(5 0 6) (A B) #(G H)) ;; :TEST-NOT ;; #'MISMATCH) ;; => (#(A B) #(5 0 6) #(F 3) #(G H)) ;One possible result ;; => ((A B) #(F 3) #(5 0 6) #(G H)) ;Another possible result ;; ;; ;; Using :TEST-NOT #'MISMATCH differs from using ;; :TEST #'EQUALP, for example, because MISMATCH ;; will determine that #(A B) and (A B) are the same, ;; while function EQUALP would regard them as not the same. ;; ;; NUNION is the destructive version of UNION. ;; It performs the same operation but may destroy the argument lists, ;; using their cells to construct the result. ;; ;; Argument(s): LIST1 - a pure list ;; LIST2 - a pure list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a pure list ;; (do-test "test union - test cases copied from page 276 and page 277 of CLtL" (and (let (( a (UNION '(A B C) '(F A D)) )) (every #'(lambda (x) (member x a :test #'eq)) '(A B C F D))) (let (( a (UNION '((X 5) (Y 6)) '((Z 2) (X 4)) :KEY #'CAR) )) (and (member 'X a :test #'eq :key #'car) (every #'(lambda (x) (member x a :test #'equal)) '((Y 6) (Z 2))))) )) (do-test "test union 1" (and (progn (setq a '(1 2 3 4) b '(5 6 7 8 9) ab (union a b)) (and (every #'(lambda (x) (member x ab)) '(1 2 3 4 5 6 7 8 9)) (equal a '(1 2 3 4)) (equal b '(5 6 7 8 9)))) (progn (setq a '( (1 2) "one" "two" ( 1 . 2)) b '( "three" ( 3 4) "four" (3 . 4)) ab (union a b)) (and (every #'(lambda (x) (member x ab :test #'equal)) '("three" ( 3 4) "four" (3 . 4) (1 2) "one" "two" ( 1 . 2))) (equal a '( (1 2) "one" "two" ( 1 . 2))) (equal b '( "three" ( 3 4) "four" (3 . 4))))) (prog2 (setq a '(1 2) b '(1 2) c (union a b)) (and (every #'(lambda (x) (member x c :test #'eq)) '(2 1)) (equal a '(1 2)) (equal b '(1 2)))) (prog2 (setq aa '("a" "b" "c" "d" "e" "f") bb '("d" "e" "f" "g" "h" "i") cc (union aa bb)) (and (every #'(lambda (x) (member x cc :test #'equal)) '("d" "e" "f" "g" "h" "i" "a" "b" "c")) (equal aa '("a" "b" "c" "d" "e" "f")) (equal bb '("d" "e" "f" "g" "h" "i")))) (prog2 (setq aa '((1 2 3 (4 5) (6 7)) 8 9 10 11) bb '(#\a "string" (1 2 3 (4 5) (6 7)) 10 #\v) cc (union aa bb)) (and (every #'(lambda (x) (member x cc :test #'equal)) '((1 2 3 (4 5) (6 7)) 8 9 10 11 #\a #\v "string")) (equal aa '((1 2 3 (4 5) (6 7)) 8 9 10 11)) (equal bb '(#\a "string" (1 2 3 (4 5) (6 7)) 10 #\v)))) )) (do-test "test union 2" (and (progn (setq a '((a b) (x y) (o p)) b '((1 2) (4 y) (7 p)) cc (union a b :test #'eq :key #'cadr)) (and (member 'p cc :key #'cadr) (member 'y cc :key #'cadr) (every #'(lambda (x) (member x cc :test #'equal)) '((a b) (1 2))))) (progn (setq a '((poco a poco rit end) (sound little)) b '((rit little by little ) (by degrees) (end)) cc (union a b :test #'equal :key #'last)) (and (member '(little) cc :test #'equal :key #'last) (member '(end) cc :test #'equal :key #'last) (every #'(lambda (x) (member x cc :test #'equal)) '((by degrees))))) )) (do-test "test union 3" (and (progn (setq aa '((1 3.0 4) (5 7.0) (9 12)) bb '((2 7 9) (8 9 20) (99 88)) cc (union aa bb :test-not #'/= :key #'cadr)) (and (member-if #'(lambda (x) (= x 7)) cc :key #'cadr) (every #'(lambda (x) (member x cc :test #'equal)) '((1 3.0 4) (9 12) (8 9 20) (99 88))))) (progn (setq aa '(("blue" ("green")) ("yellow" ("red")) ("purple" ("blue"))) bb '(("blue" ("Green")) ("yellow" ("blue")) ("yellow" ("Red"))) cc (union aa bb :test-not #'(lambda (x y) (not (string= x y))) :key #'caadr)) (and (member-if-not #'(lambda (x) (not (string= x "blue"))) cc :key #'caadr) (every #'(lambda (x) (member x cc :test #'equal)) '( ("blue" ("green")) ("yellow" ("red")) ("blue" ("Green")) ("yellow" ("Red"))) ))) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-ACONS.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-ACONS.TEST new file mode 100644 index 00000000..5808af45 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-ACONS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ACONS ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 279 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ACONS.TEST ;; ;; ;; Syntax: (ACONS KEY DATUM ALIST) ;; ;; Function Description: ;; ACONS constructs a new association list by adding the pair ;; (KEY . DATUM) to the old A-LIST. ;; ;; (ACONS X Y A) = (CONS (CONS X Y) A) ;; ;; ;; Argument(s): KEY - a function ;; DATUM - anything ;; ALIST - an association list ;; ;; Returns: an association list ;; (DO-TEST "ACONS TEST 1" (EQUAL (ACONS 'G 5 '((B . 7) (E . 5) (E . 2))) '((G . 5) (B . 7) (E . 5) (E . 2))) (EQUAL (ACONS 'C 5 '((G . 3))) '((C . 5) (G . 3))) (EQUAL (ACONS 'G 9 '((G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) '((G . 9) (G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) (EQUAL (ACONS 'F 3 '((F . 4) (Y . 2))) '((F . 3) (F . 4) (Y . 2))) (EQUAL (ACONS 'D 3 '((D . 5) (Z . 3) (Y . 3) (Z . 6))) '((D . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) (EQUAL (ACONS 'Z 1 '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) '((Z . 1) (E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8)))) (DO-TEST "ACONS TEST 2" (EQUAL (ACONS 'X '(X E G C G) '((D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) '((X X E G C G) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) (EQUAL (ACONS 'E '(A G C) '((E F F))) '((E A G C) (E F F))) (EQUAL (ACONS 'D '(G F X Y E A Z F E Z) '((C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) '((D G F X Y E A Z F E Z) (C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) (EQUAL (ACONS 'B '(C C Z) '((D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) '((B C C Z) (D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) (EQUAL (ACONS 'C '(F X G D B G F X) '((C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) '((C F X G D B G F X) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) (EQUAL (ACONS 'X '(C F A F D A Y C X F) '((X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X))) '((X C F A F D A Y C X F) (X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X)))) (DO-TEST "ACONS TEST 3" (EQUAL (ACONS 'CATOR 'B '((FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) '((CATOR . B) (FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) (EQUAL (ACONS 'FOO 'E '((MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) '((FOO . E) (MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) (EQUAL (ACONS 'ZORK 'X '((BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) '((ZORK . X) (BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) (EQUAL (ACONS 'CATOR 'C '((PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) '((CATOR . C) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) (EQUAL (ACONS 'PERTY 'E '((FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) '((PERTY . E) (FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) (EQUAL (ACONS 'MORY 'A '((CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y))) '((MORY . A) (CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y)))) (DO-TEST "ACONS TEST 4" (EQUAL (ACONS 'MEEF '(G C E C C) '((MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) '((MEEF G C E C C) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) (EQUAL (ACONS 'BAZ '(G X A) '((QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) '((BAZ G X A) (QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) (EQUAL (ACONS 'FOO '(B D E Y B D C B) '((BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) '((FOO B D E Y B D C B) (BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) (EQUAL (ACONS 'CATOR '(E D F G Z) '((BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) '((CATOR E D F G Z) (BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) (EQUAL (ACONS 'QIX '(A Z F C Y G) '((BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) '((QIX A Z F C Y G) (BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) (EQUAL (ACONS 'BAZ '(E C G F A G D B) '((MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F))) '((BAZ E C G F A G D B) (MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F)))) (DO-TEST "ACONS TEST 5" (EQUAL (ACONS 1 'E '((1 . B) (4 . G))) '((1 . E) (1 . B) (4 . G))) (EQUAL (ACONS 1 'Z '((4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) '((1 . Z) (4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) (EQUAL (ACONS 2 'F '((3 . Z) (2 . G))) '((2 . F) (3 . Z) (2 . G))) (EQUAL (ACONS 9 'Z '((4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) '((9 . Z) (4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) (EQUAL (ACONS 4 'Y '((8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) '((4 . Y) (8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) (EQUAL (ACONS 3 'Y '((1 . Y) (4 . E) (8 . A) (3 . F) (6 . F))) '((3 . Y) (1 . Y) (4 . E) (8 . A) (3 . F) (6 . F)))) (DO-TEST "ACONS TEST 6" (EQUAL (ACONS 5 '(X G E) '((8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) '((5 X G E) (8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) (EQUAL (ACONS 5 '(Z A D A Z Y) '((7 C F Y E G B))) '((5 Z A D A Z Y) (7 C F Y E G B))) (EQUAL (ACONS 6 '(G) '((4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) '((6 G) (4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) (EQUAL (ACONS 10 '(Z F B) '((7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) '((10 Z F B) (7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) (EQUAL (ACONS 6 '(Z D F Z) '((4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) '((6 Z D F Z) (4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) (EQUAL (ACONS 8 '(A B D Z E D Y D) '((8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) '((8 A B D Z E D Y D) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF-NOT.TEST new file mode 100644 index 00000000..ca024c6e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASSOC-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 280 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ASSOC-IF-NOT.TEST ;; ;; ;; Syntax: (ASSOC-IF-NOT PREDICATE ALIST) ;; ;; Function Description: ;; Each of these searches the association list ;; A-LIST. The value is the first pair in the a-list such that ;; the CAR of the pair satisfies the test, or NIL if there is ;; no such pair in the a-list. ;; For example: ;; ;; (ASSOC 'R '((A . B) (C . D) (R . X) (S . Y) (R . Z))) ;; => (R . X) ;; (ASSOC 'GOO '((FOO . BAR) (ZOO . GOO))) => NIL ;; (ASSOC '2 '((1 A B C) (2 B C D) (-7 X Y Z))) => (2 B C D) ;; ;; It is possible to RPLACD the result of ASSOC PROVIDED ;; that it is not NIL, ;; in order to ``update'' the ``table'' that was ASSOC's second argument. ;; (However, it is often better to update an a-list by adding new pairs ;; to the front, rather than altering old pairs.) ;; For example: ;; ;; (SETQ VALUES '((X . 100) (Y . 200) (Z . 50))) ;; (ASSOC 'Y VALUES) => (Y . 200) ;; ;; (RPLACD (ASSOC 'Y VALUES) 201) ;; (ASSOC 'Y VALUES) => (Y . 201) now ;; ;; A typical trick is to say ;; (CDR (ASSOC X Y)). ;; Because the CDR of NIL is guaranteed to be NIL, ;; this yields NIL if no pair is found OR if a pair is ;; found whose CDR is NIL. This is useful if NIL serves ;; its usual role as a ``default value.'' ;; ;; The two expressions ;; ;; (ASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CAR) ;; ;; are equivalent in meaning with one important exception: ;; ;; if NIL appears in the a-list in place of a pair, ;; and the ITEM being searched for is NIL, ;; FIND will blithely compute the CAR of the NIL in the a-list, ;; find that it is equal to the ITEM, and return NIL, ;; whereas ASSOC will ignore the NIL in the a-list and continue ;; to search for an actual pair (cons) whose CAR is NIL. ;; See function FIND and function POSITION. ;; ;; Compatibility note: In Maclisp, the ASSOC function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for ASSOC in ;; Common Lisp. Where in Maclisp one would write ;; (ASSOC X Y), in Common Lisp one must write (ASSOC X Y :TEST #'EQUAL) ;; to get the completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (ASSQ X Y) ;; by writing in Common Lisp (ASSOC X Y :TEST #'EQ). ;; ;; In Interlisp, ASSOC uses an EQ test, and SASSOC ;; uses an Interlisp EQUAL test. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "ASSOC-IF-NOT TEST 1" (EQUAL (ASSOC-IF-NOT (QUOTE NUMBERP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (A 2))) (EQUAL (ASSOC-IF-NOT (QUOTE SYMBOLP) (QUOTE ((A 2) (1 1) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (1 1))) (EQUAL (ASSOC-IF-NOT (QUOTE STRINGP) (QUOTE (("FOO" 3) (A 2) (1 1) ((1 2) 4) (NIL T)))) (QUOTE (A 2))) (EQUAL (ASSOC-IF-NOT (QUOTE LISTP) (QUOTE (((1 2) 4) ("FOO" 3) (A 2) (1 1) (NIL T)))) (QUOTE ("FOO" 3))) (EQUAL (ASSOC-IF-NOT (QUOTE NULL) (QUOTE ((NIL T) ((1 2) 4) ("FOO" 3) (A 2) (1 1)))) (QUOTE ((1 2) 4)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF.TEST new file mode 100644 index 00000000..4e5c903a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASSOC-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 280 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ASSOC-IF.TEST ;; ;; ;; Syntax: (ASSOC-IF PREDICATE ALIST) ;; ;; Function Description: ;; Each of these searches the association list ;; A-LIST. The value is the first pair in the a-list such that ;; the CAR of the pair satisfies the test, or NIL if there is ;; no such pair in the a-list. ;; For example: ;; ;; (ASSOC 'R '((A . B) (C . D) (R . X) (S . Y) (R . Z))) ;; => (R . X) ;; (ASSOC 'GOO '((FOO . BAR) (ZOO . GOO))) => NIL ;; (ASSOC '2 '((1 A B C) (2 B C D) (-7 X Y Z))) => (2 B C D) ;; ;; It is possible to RPLACD the result of ASSOC PROVIDED ;; that it is not NIL, ;; in order to ``update'' the ``table'' that was ASSOC's second argument. ;; (However, it is often better to update an a-list by adding new pairs ;; to the front, rather than altering old pairs.) ;; For example: ;; ;; (SETQ VALUES '((X . 100) (Y . 200) (Z . 50))) ;; (ASSOC 'Y VALUES) => (Y . 200) ;; ;; (RPLACD (ASSOC 'Y VALUES) 201) ;; (ASSOC 'Y VALUES) => (Y . 201) now ;; ;; A typical trick is to say ;; (CDR (ASSOC X Y)). ;; Because the CDR of NIL is guaranteed to be NIL, ;; this yields NIL if no pair is found OR if a pair is ;; found whose CDR is NIL. This is useful if NIL serves ;; its usual role as a ``default value.'' ;; ;; The two expressions ;; ;; (ASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CAR) ;; ;; are equivalent in meaning with one important exception: ;; ;; if NIL appears in the a-list in place of a pair, ;; and the ITEM being searched for is NIL, ;; FIND will blithely compute the CAR of the NIL in the a-list, ;; find that it is equal to the ITEM, and return NIL, ;; whereas ASSOC will ignore the NIL in the a-list and continue ;; to search for an actual pair (cons) whose CAR is NIL. ;; See function FIND and function POSITION. ;; ;; Compatibility note: In Maclisp, the ASSOC function uses ;; an EQUAL comparison rather than EQL, which is the default ;; test for ASSOC in ;; Common Lisp. Where in Maclisp one would write ;; (ASSOC X Y), in Common Lisp one must write (ASSOC X Y :TEST #'EQUAL) ;; to get the completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (ASSQ X Y) ;; by writing in Common Lisp (ASSOC X Y :TEST #'EQ). ;; ;; In Interlisp, ASSOC uses an EQ test, and SASSOC ;; uses an Interlisp EQUAL test. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "ASSOC-IF TEST 1" (EQUAL (ASSOC-IF (QUOTE NUMBERP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (1 1))) (EQUAL (ASSOC-IF (QUOTE SYMBOLP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (A 2))) (EQUAL (ASSOC-IF (QUOTE STRINGP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE ("FOO" 3))) (EQUAL (ASSOC-IF (QUOTE LISTP) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE ((1 2) 4))) (EQUAL (ASSOC-IF (QUOTE NULL) (QUOTE ((1 1) (A 2) ("FOO" 3) ((1 2) 4) (NIL T)))) (QUOTE (NIL T)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC.TEST new file mode 100644 index 00000000..a4c544e6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ASSOC ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 280 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-ASSOC.TEST ;; ;; ;; Syntax: (ASSOC ITEM ALIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; Each of these searches the association list ;; A-LIST. The value is the first pair in the a-list such that ;; the CAR of the pair satisfies the test, or NIL if there is ;; no such pair in the a-list. ;; For example: ;; ;; (ASSOC 'R '((A . B) (C . D) (R . X) (S . Y) (R . Z))) ;; => (R . X) ;; (ASSOC 'GOO '((FOO . BAR) (ZOO . GOO))) => NIL ;; (ASSOC '2 '((1 A B C) (2 B C D) (-7 X Y Z))) => (2 B C D) ;; ;; It is possible to RPLACD the result of ASSOC PROVIDED ;; that it is not NIL, ;; in order to ``update'' the ``table'' that was ASSOC's second argument. ;; (However, it is often better to update an a-list by adding new pairs ;; to the front, rather than altering old pairs.) ;; For example: ;; ;; (SETQ VALUES '((X . 100) (Y . 200) (Z . 50))) ;; ;; (ASSOC 'Y VALUES) => (Y . 200) ;; (RPLACD (ASSOC 'Y VALUES) 201) ;; (ASSOC 'Y VALUES) => (Y . 201) now ;; ;; A typical trick is to say ;; (CDR (ASSOC X Y)). ;; Because the CDR of NIL is guaranteed to be NIL, ;; this yields NIL if no pair is found OR if a pair is ;; found whose CDR is NIL. This is useful if NIL serves ;; its usual role as a ``default value.'' ;; ;; The two expressions ;; ;; (ASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CAR) ;; ;; ;; are equivalent in meaning with one important exception: ;; if NIL appears in the a-list in place of a pair, ;; and the ITEM being searched for is NIL, ;; FIND will blithely compute the CAR of the NIL in the a-list, ;; find that it is equal to the ITEM, and return NIL, ;; whereas ASSOC will ignore the NIL in the a-list and continue ;; to search for an actual pair (cons) whose CAR is NIL. ;; See function FIND and function POSITION. ;; ;; Compatibility note: In Maclisp, the ASSOC function uses ;; an EQUAL comparison rather than EQL, which is the default ;; ;; test for ASSOC in Common Lisp. Where in Maclisp one would write ;; (ASSOC X Y), in Common Lisp one must write (ASSOC X Y :TEST #'EQUAL) ;; to get the completely identical effect. Similarly, one can get the ;; precise effect, and no more, of the Maclisp (ASSQ X Y) ;; by writing in Common Lisp (ASSOC X Y :TEST #'EQ). ;; ;; In Interlisp, ASSOC uses an EQ test, and SASSOC ;; uses an Interlisp EQUAL test. ;; ;; Argument(s): ITEM - anything ;; ALIST - an association list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: anything ;; (DO-TEST "ASSOC TEST 1" (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)))) :TEST (QUOTE EQUAL)) (QUOTE ((1 2) (3 4)))) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)))) :TEST-NOT (QUOTE EQUAL)) NIL) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)) ((2 1) (3 4)))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((2 1) (3 4)))) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((2 1) (3 4)) ((1 2) (3 4)))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((2 1) (3 4)))) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((1 2) (3 4)))) :TEST (QUOTE EQL)) NIL) (EQUAL (CL:ASSOC 1 '(((2 3) 4) ((4 5) 6) ((1 2) 3) ((7 8) 9)) :KEY 'CAR) '((1 2) 3)) (EQUAL (CL:ASSOC T '(("A" S)(1 2)) :KEY 'CL:STRINGP) '("A" S)) (EQUAL (CL:ASSOC NIL '(("A" S)(1 2)) :KEY 'CL:STRINGP) '(1 2)) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((QUOTE (1 2)) (3 4)))) :TEST-NOT (QUOTE EQUAL) :KEY 'EVAL) NIL) (EQUAL (CL:ASSOC (QUOTE (1 2)) (QUOTE (((QUOTE (1 2)) (3 4)))) :TEST (QUOTE EQL) :KEY 'EVAL) NIL)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-PAIRLIS.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-PAIRLIS.TEST new file mode 100644 index 00000000..f7354cc2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-PAIRLIS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: PAIRLIS ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 280 ;; ;; Created By: Kelly Roach ; Karin Sye ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-PAIRLIS.TEST ;; ;; ;; Syntax: (PAIRLIS KEYS DATA &OPTIONAL ALIST) ;; ;; Function Description: ;; PAIRLIS takes two lists and makes an association list that associates ;; elements of the first list to corresponding elements of the second ;; list. It is an error if the two lists KEYS and DATA are not of ;; the same length. If the optional argument A-LIST is provided, then the ;; new pairs are added to the front of it. ;; ;; The new pairs may appear in the resulting a-list in any order; ;; in particular, either forward or backward order is permitted. ;; Therefore the result of the call ;; ;; (PAIRLIS '(ONE TWO) '(1 2) '((THREE . 3) (FOUR . 19))) ;; ;; might be ;; ;; ((ONE . 1) (TWO . 2) (THREE . 3) (FOUR . 19)) ;; ;; but could equally well be ;; ;; ((TWO . 2) (ONE . 1) (THREE . 3) (FOUR . 19)) ;; ;; ;; Argument(s): KEYS - a pure list ;; DATA - a pure list ;; ALIST - an association list ;; ;; Returns: an association list ;; (do-test-group (group-test :before (defun equally (x y) (and (= (list-length x) (list-length y)) (every #'(lambda (w) (member w y :test #'equal)) x) ) )) (DO-TEST "PAIRLIS TEST 1" (and (EQUALLY (PAIRLIS '(F) '(10) '((B . 7) (E . 5) (E . 2))) '((F . 10) (B . 7) (E . 5) (E . 2))) (EQUALLY (PAIRLIS '(Z Z C F C B D D) '(2 10 1 9 8 6 4 4) '((G . 3))) '((Z . 2) (Z . 10) (C . 1) (F . 9) (C . 8) (B . 6) (D . 4) (D . 4) (G . 3))) (EQUALLY (PAIRLIS '(B) '(6) '((G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) '((B . 6) (G . 4) (B . 5) (E . 7) (X . 4) (B . 10) (X . 6))) (EQUALLY (PAIRLIS '(G Z Z Z E D Y A G Z) '(8 3 7 6 9 6 1 6 5 4) '((F . 4) (Y . 2))) '((G . 8) (Z . 3) (Z . 7) (Z . 6) (E . 9) (D . 6) (Y . 1) (A . 6) (G . 5) (Z . 4) (F . 4) (Y . 2))) (EQUALLY (PAIRLIS '(F D F G) '(10 8 7 3) '((D . 5) (Z . 3) (Y . 3) (Z . 6))) '((F . 10) (D . 8) (F . 7) (G . 3) (D . 5) (Z . 3) (Y . 3) (Z . 6))) (EQUALLY (PAIRLIS '(F Y B D E C) '(8 3 1 1 7 4) '((E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))) '((F . 8) (Y . 3) (B . 1) (D . 1) (E . 7) (C . 4) (E . 4) (F . 2) (G . 3) (C . 10) (C . 4) (G . 9) (F . 3) (D . 8))))) (DO-TEST "PAIRLIS TEST 2" (and (EQUALLY (PAIRLIS '(D C X Z A A X A Z) '((D E B B E C) (B B Y G F X F) (C G E X B E G Z G) (Y C E C Y) (F E D D D Z B) (E E E C C X F C Y) (C Y F G) (X D F X) (B Z X G Z)) '((D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) '((D D E B B E C) (C B B Y G F X F) (X C G E X B E G Z G) (Z Y C E C Y) (A F E D D D Z B) (A E E E C C X F C Y) (X C Y F G) (A X D F X) (Z B Z X G Z) (D A Z C Z A E E) (Z G X E Y X C Y F) (G A G Z A G G B Y) (F D G E B B A Y) (Z B E B))) (EQUALLY (PAIRLIS '(Y B F D B) '((A C E F) (B D Z) (B D D Y D X E E) (Z F E C F) (B A G E)) '((E F F))) '((Y A C E F) (B B D Z) (F B D D Y D X E E) (D Z F E C F) (B B A G E) (E F F))) (EQUALLY (PAIRLIS '(D B F A B D Y Z F) '((G) (D A C A Z A A B) (B F F Z) (Z D A E F Z A) (X) (G A) (B D B A E) (Y D X A A) (B D)) '((C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) '((D G) (B D A C A Z A A B) (F B F F Z) (A Z D A E F Z A) (B X) (D G A) (Y B D B A E) (Z Y D X A A) (F B D) (C X Y Z F X Z A B) (X G G F X C Y G E E) (C Z X A G) (Z A F Z D X D E Y X) (G A F Y Y B Y) (Z Y Z) (A C X) (E E E X G B F C E) (C Z Y Y E))) (EQUALLY (PAIRLIS '(E) '((C F A E Y)) '((D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) '((E C F A E Y) (D Y B A B B C Z D) (C X E A E X D) (X F F Y B B Y X A) (G Y G C A D) (Z G A D A) (D F A G D G) (B X B E) (Y F B C B X Y) (E F A C) (C F A E A))) (EQUALLY (PAIRLIS '(Z X F) '((C D G E) (G D A) (C G)) '((C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) '((Z C D G E) (X G D A) (F C G) (C Y E A Z C D) (G F D G C A F D D B) (Z D C D D Z F) (Y C C G E B G D Y Z F) (C E F Z) (Z D) (A G C F G B B A F A Z) (E E A B G Z Z X))) (EQUALLY (PAIRLIS '(B F Y) '((Y A G D) (B Z Y Y) (X)) '((X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X))) '((B Y A G D) (F B Z Y Y) (Y X) (X G D C D Z Y) (C Y Z G E G Y C C A) (A A) (Z Y F X))))) (DO-TEST "PAIRLIS TEST 3" (and (EQUALLY (PAIRLIS '(BAR MORY ZORK MEEF QIX PERTY BAZ QIX MORY) '(F B Z E B A E B F) '((FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) '((BAR . F) (MORY . B) (ZORK . Z) (MEEF . E) (QIX . B) (PERTY . A) (BAZ . E) (QIX . B) (MORY . F) (FOO . F) (BAZ . A) (PERTY . G) (MORY . D))) (EQUALLY (PAIRLIS '(MEEF) '(G) '((MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) '((MEEF . G) (MEEF . F) (ZORK . Z) (CATOR . G) (MORY . F) (FOO . Y) (ZORK . G) (CATOR . D) (BAZ . Y))) (EQUALLY (PAIRLIS '(QIX) '(C) '((BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) '((QIX . C) (BAR . A) (MEEF . D) (BAR . B) (BAR . G) (QIX . C))) (EQUALLY (PAIRLIS '(QIX CATOR BAZ PERTY FOO MORY BAZ BAZ MEEF FOO) '(A Z C X B B X Y Y D) '((PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) '((QIX . A) (CATOR . Z) (BAZ . C) (PERTY . X) (FOO . B) (MORY . B) (BAZ . X) (BAZ . Y) (MEEF . Y) (FOO . D) (PERTY . E) (ZORK . X) (PERTY . C) (CATOR . Z) (MEEF . Y) (CATOR . Z) (MORY . E) (ZORK . X))) (EQUALLY (PAIRLIS '(CATOR MORY MEEF MEEF PERTY FOO BAR) '(B G G B G Z Z) '((FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) '((CATOR . B) (MORY . G) (MEEF . G) (MEEF . B) (PERTY . G) (FOO . Z) (BAR . Z) (FOO . E) (CATOR . C) (CATOR . E) (ZORK . X) (MORY . D) (QIX . Y) (QIX . X) (FOO . X))) (EQUALLY (PAIRLIS '(CATOR QIX QIX MORY) '(G C G D) '((CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y))) '((CATOR . G) (QIX . C) (QIX . G) (MORY . D) (CATOR . Z) (ZORK . B) (BAZ . E) (BAR . D) (MEEF . A) (FOO . Y))))) (DO-TEST "PAIRLIS TEST 4" (and (EQUALLY (PAIRLIS '(BAZ CATOR ZORK QIX) '((A Y Z X) (C B X D D A D E G X) (X) (E E D F E X G)) '((MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) '((BAZ A Y Z X) (CATOR C B X D D A D E G X) (ZORK X) (QIX E E D F E X G) (MORY G X F E) (ZORK D F C F D E D G Z) (CATOR F Y Z) (ZORK B F G X E X F B B) (PERTY A D F B D E D E A X))) (EQUALLY (PAIRLIS '(MEEF BAZ FOO CATOR MEEF QIX CATOR) '((Z G Y Y Z) (D G F A G D D Y C) (Y X Y Z G C B D) (A C D Z A B D D F G) (D A E Y X F Y G) (A A A F F X Y A D) (Y Z B Z D)) '((QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) '((MEEF Z G Y Y Z) (BAZ D G F A G D D Y C) (FOO Y X Y Z G C B D) (CATOR A C D Z A B D D F G) (MEEF D A E Y X F Y G) (QIX A A A F F X Y A D) (CATOR Y Z B Z D) (QIX C E D C E D X D C B) (ZORK E E Z) (MORY E Y Z))) (EQUALLY (PAIRLIS '(PERTY ZORK PERTY BAZ BAZ BAR PERTY MEEF) '((D E D Z A) (E X A F Y D) (G X E) (B E E Y) (F C E E X B) (Y F G Z) (A F B E D X) (C A B Z F)) '((BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) '((PERTY D E D Z A) (ZORK E X A F Y D) (PERTY G X E) (BAZ B E E Y) (BAZ F C E E X B) (BAR Y F G Z) (PERTY A F B E D X) (MEEF C A B Z F) (BAZ Y B A X B) (BAZ B E Y E) (FOO B B X C G X) (CATOR G D X G F Z) (MORY X A C X G F E))) (EQUALLY (PAIRLIS '(ZORK MEEF ZORK ZORK BAZ QIX) '((C Y E E E G G Z Z X) (E B C B Y F Y E F) (X E F Z Y C D) (F Y F X G Y C X) (C) (Z F A C C Z Y X Y)) '((BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) '((ZORK C Y E E E G G Z Z X) (MEEF E B C B Y F Y E F) (ZORK X E F Z Y C D) (ZORK F Y F X G Y C X) (BAZ C) (QIX Z F A C C Z Y X Y) (BAR C B Z) (QIX Y F D Z F E) (BAZ E G D E F Z B) (MORY B D C G D D G G D C) (BAZ Y E C G F B D B) (BAZ F B B B A E F B) (BAR C F Z A Y D A Z D) (BAZ B) (BAR X X C))) (EQUALLY (PAIRLIS '(MEEF CATOR MORY CATOR BAR CATOR BAR) '((E G E F) (X F Z Z X G) (F D B C Z G) (A C Z E Z G Z Z E) (Y F Z Z Y D C) (A C Z A D D A X G D) (G E A)) '((BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) '((MEEF E G E F) (CATOR X F Z Z X G) (MORY F D B C Z G) (CATOR A C Z E Z G Z Z E) (BAR Y F Z Z Y D C) (CATOR A C Z A D D A X G D) (BAR G E A) (BAR D B Y G F G) (PERTY D Y Z D Z) (QIX Y D E A Y A X Y) (MEEF Y G D B F E E X C))) (EQUALLY (PAIRLIS '(PERTY ZORK) '((F D B X Y F) (F D E)) '((MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F))) '((PERTY F D B X Y F) (ZORK F D E) (MEEF G Y B) (MEEF B D C G) (PERTY G Z F C G Z A) (PERTY X A F Z) (MEEF B X A G E) (BAZ Y Z Y A Z F) (MORY D E Z D C B G B F))))) (DO-TEST "PAIRLIS TEST 5" (and (EQUALLY (PAIRLIS '(3 9 10 5 3 3 5) '(C C C E E G B) '((1 . B) (4 . G))) '((3 . C) (9 . C) (10 . C) (5 . E) (3 . E) (3 . G) (5 . B) (1 . B) (4 . G))) (EQUALLY (PAIRLIS '(3 10 10 1 1) '(X E B Z C) '((4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) '((3 . X) (10 . E) (10 . B) (1 . Z) (1 . C) (4 . X) (10 . E) (4 . D) (9 . A) (7 . E) (6 . Y) (2 . A) (4 . X) (2 . G) (10 . X))) (EQUALLY (PAIRLIS '(3 10 6 5 8 10 9 2) '(E F Y G D G Z X) '((3 . Z) (2 . G))) '((3 . E) (10 . F) (6 . Y) (5 . G) (8 . D) (10 . G) (9 . Z) (2 . X) (3 . Z) (2 . G))) (EQUALLY (PAIRLIS '(2 6 7 8 3) '(Z Z F D E) '((4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) '((2 . Z) (6 . Z) (7 . F) (8 . D) (3 . E) (4 . A) (2 . Z) (3 . Y) (2 . E) (6 . A) (1 . D) (3 . C) (7 . D))) (EQUALLY (PAIRLIS '(9 6 10 2 4 9) '(D C C Z C F) '((8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) '((9 . D) (6 . C) (10 . C) (2 . Z) (4 . C) (9 . F) (8 . Y) (10 . E) (5 . A) (6 . Z) (5 . Z) (6 . A) (8 . Z))) (EQUALLY (PAIRLIS '(3 7 6 3) '(C D X X) '((1 . Y) (4 . E) (8 . A) (3 . F) (6 . F))) '((3 . C) (7 . D) (6 . X) (3 . X) (1 . Y) (4 . E) (8 . A) (3 . F) (6 . F))))) (DO-TEST "PAIRLIS TEST 6" (and (EQUALLY (PAIRLIS '(2 8 1) '((C Z Y C G) (D) (Y Y A)) '((8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) '((2 C Z Y C G) (8 D) (1 Y Y A) (8 D G Y F G X E D Z Z) (2 Y D B C Z E Y A E Y) (9 C G Z G) (3 Z Y) (2 C) (4 A X E Z C A F) (5 F A Y E F G) (4 Y A) (5 F E E Y D Y B C) (4 Y X X E E))) (EQUALLY (PAIRLIS '(5 4 8 4 6 8) '((Y E C B Z) (Z A G D C B) (F B G) (X Y G B) (E B C) (Y G Y Y)) '((7 C F Y E G B))) '((5 Y E C B Z) (4 Z A G D C B) (8 F B G) (4 X Y G B) (6 E B C) (8 Y G Y Y) (7 C F Y E G B))) (EQUALLY (PAIRLIS '(10 8 2 8 9 8 4 10 8) '((D G E Y D Y X) (X A F Z Z C G B B A) (X C D D C G E G X) (D F A F F X D F C A) (D B Y G) (X E) (B C Z X Y Y D Y C) (D C B C D X) (Y Y X C F E X C)) '((4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) '((10 D G E Y D Y X) (8 X A F Z Z C G B B A) (2 X C D D C G E G X) (8 D F A F F X D F C A) (9 D B Y G) (8 X E) (4 B C Z X Y Y D Y C) (10 D C B C D X) (8 Y Y X C F E X C) (4 F A Y Y X B Z G) (10 Y Y G B E G Z F) (7 F B E E B B E) (10 D Z F X Z A A F) (5 Z B B F) (1 A X X A D F D))) (EQUALLY (PAIRLIS '(2 10 7 2 5 10 7 1) '((G X E) (C E A B D) (E Y) (A C Z G E Y) (X Z D D) (Y C E Y D F Y) (F C D F D Y F) (Z A Z Z)) '((7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) '((2 G X E) (10 C E A B D) (7 E Y) (2 A C Z G E Y) (5 X Z D D) (10 Y C E Y D F Y) (7 F C D F D Y F) (1 Z A Z Z) (7 G) (2 Z D X E Y C Y X) (4 X E G C E G D A) (5 Y X F Z Y) (5 C) (2 D C Z C D C) (2 Z B))) (EQUALLY (PAIRLIS '(3 3 10 6 3 4 3) '((F X F) (Z G B F Y) (G B Z F X D) (A Y F Y) (C B X X X X) (F D A D E A C) (C Y X)) '((4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) '((3 F X F) (3 Z G B F Y) (10 G B Z F X D) (6 A Y F Y) (3 C B X X X X) (4 F D A D E A C) (3 C Y X) (4 D Z C C A E Y) (9 A A C G X E Y) (2 X G A G D B G) (6 A B) (1 G))) (EQUALLY (PAIRLIS '(1 6 9 5 8 2 1 2 9) '((B G C X C) (C G Z A Z Z A Y) (X E D D C) (A X D A A C Z A F) (B) (G Z B A E Y Y) (Y B) (G) (B B B X X E C Y Z)) '((8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))) '((1 B G C X C) (6 C G Z A Z Z A Y) (9 X E D D C) (5 A X D A A C Z A F) (8 B) (2 G Z B A E Y Y) (1 Y B) (2 G) (9 B B B X X E C Y Z) (8 Z C) (9 E Z A D F D Y X Z G) (6 G) (5 G D D G B F B C A) (4 B Y Z C X A E) (8 X A G F D A C Y) (5 B F E C E F E))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF-NOT.TEST new file mode 100644 index 00000000..af7006da --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RASSOC-IF-NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 281 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-RASSOC-IF-NOT.TEST ;; ;; ;; Syntax: (RASSOC-IF-NOT PREDICATE ALIST) ;; ;; Function Description: ;; RASSOC is the reverse form of ASSOC; it searches for ;; a pair whose CDR satisfies the test, rather than the CAR. ;; If the A-LIST is considered to be a mapping, then RASSOC ;; treats the A-LIST as representing the inverse mapping. ;; For example: ;; ;; (RASSOC 'A '((A . B) (B . C) (C . A) (Z . A))) => (C . A) ;; ;; ;; The expressions ;; ;; (RASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CDR) ;; ;; are equivalent in meaning, except when the ITEM is NIL ;; and NIL appears in place of a pair in the a-list. See the discussion ;; of the function function ASSOC. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "RASSOC-IF-NOT TEST 1" (EQUAL (RASSOC-IF-NOT (QUOTE NUMBERP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (2 . A))) (EQUAL (RASSOC-IF-NOT (QUOTE SYMBOLP) (QUOTE ((2 . A) (1 . 1) (3 . "FOO") (4 1 2) (T)))) (QUOTE (1 . 1))) (EQUAL (RASSOC-IF-NOT (QUOTE STRINGP) (QUOTE ((3 . "FOO") (2 . A) (1 . 1) (4 1 2) (T)))) (QUOTE (2 . A))) (EQUAL (RASSOC-IF-NOT (QUOTE LISTP) (QUOTE ((4 1 2) (3 . "FOO") (2 . A) (1 . 1) (T)))) (QUOTE (3 . "FOO"))) (EQUAL (RASSOC-IF-NOT (QUOTE NULL) (QUOTE ((T) (4 1 2) (3 . "FOO") (2 . A) (1 . 1)))) (QUOTE (4 1 2)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF.TEST new file mode 100644 index 00000000..f937f1e9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RASSOC-IF ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 281 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-RASSOC-IF.TEST ;; ;; ;; Syntax: (RASSOC-IF PREDICATE ALIST) ;; ;; Function Description: ;; RASSOC is the reverse form of ASSOC; it searches for ;; a pair whose CDR satisfies the test, rather than the CAR. ;; If the A-LIST is considered to be a mapping, then RASSOC ;; treats the A-LIST as representing the inverse mapping. ;; For example: ;; ;; (RASSOC 'A '((A . B) (B . C) (C . A) (Z . A))) => (C . A) ;; ;; ;; The expressions ;; ;; (RASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CDR) ;; ;; are equivalent in meaning, except when the ITEM is NIL ;; and NIL appears in place of a pair in the a-list. See the discussion ;; of the function function ASSOC. ;; ;; Argument(s): PREDICATE - a function ;; ALIST - an association list ;; ;; Returns: a list ;; (DO-TEST "RASSOC-IF TEST 1" (EQUAL (RASSOC-IF (QUOTE NUMBERP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (1 . 1))) (EQUAL (RASSOC-IF (QUOTE SYMBOLP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (2 . A))) (EQUAL (RASSOC-IF (QUOTE STRINGP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (3 . "FOO"))) (EQUAL (RASSOC-IF (QUOTE LISTP) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (4 1 2))) (EQUAL (RASSOC-IF (QUOTE NULL) (QUOTE ((1 . 1) (2 . A) (3 . "FOO") (4 1 2) (T)))) (QUOTE (T)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC.TEST b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC.TEST new file mode 100644 index 00000000..a943d7fd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: RASSOC ;; ;; Source: Guy L Steele's CLTL ;; Section: 15.6 Association Lists ;; Page: 281 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>15-6-RASSOC.TEST ;; ;; ;; Syntax: (RASSOC ITEM ALIST &KEY TEST TEST-NOT KEY) ;; ;; Function Description: ;; RASSOC is the reverse form of ASSOC; it searches for ;; a pair whose CDR satisfies the test, rather than the CAR. ;; If the A-LIST is considered to be a mapping, then RASSOC ;; treats the A-LIST as representing the inverse mapping. ;; For example: ;; ;; (RASSOC 'A '((A . B) (B . C) (C . A) (Z . A))) => (C . A) ;; ;; ;; The expressions ;; ;; (RASSOC ITEM LIST :TEST FN) ;; ;; and ;; ;; (FIND ITEM LIST :TEST FN :KEY #'CDR) ;; ;; are equivalent in meaning, except when the ITEM is NIL ;; and NIL appears in place of a pair in the a-list. See the discussion ;; of the function function ASSOC. ;; ;; ;; Argument(s): ITEM - anything ;; ALIST - an association list ;; TEST - a function ;; TEST-NOT - a function ;; KEY - a function ;; ;; Returns: a list ;; (DO-TEST "RASSOC TEST 1" (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2))) :TEST (QUOTE EQUAL)) (QUOTE ((3 4) 1 2))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2))) :TEST-NOT (QUOTE EQUAL)) NIL) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2) ((3 4) 2 1))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((3 4) 2 1))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 2 1) ((3 4) 1 2))) :TEST-NOT (QUOTE EQUAL)) (QUOTE ((3 4) 2 1))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) 1 2))) :TEST (QUOTE EQL)) NIL) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)))) :TEST (QUOTE EQUAL) :KEY (QUOTE EVAL)) (QUOTE ((3 4) QUOTE (1 2)))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)))) :TEST-NOT (QUOTE EQUAL) :KEY (QUOTE EVAL)) NIL) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)) ((3 4) QUOTE (2 1)))) :TEST-NOT (QUOTE EQUAL) :KEY (QUOTE EVAL)) (QUOTE ((3 4) QUOTE ( 2 1)))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (2 1)) ((3 4) QUOTE (1 2)))) :TEST-NOT (QUOTE EQUAL) :KEY (QUOTE EVAL)) (QUOTE ((3 4) QUOTE ( 2 1)))) (EQUAL (RASSOC (QUOTE (1 2)) (QUOTE (((3 4) QUOTE (1 2)))) :TEST (QUOTE EQL) :KEY (QUOTE EVAL)) NIL)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-CLRHASH.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-CLRHASH.TEST new file mode 100644 index 00000000..0bd3de14 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-CLRHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: clrhash ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-1-clrhash.test ;; ;; ;; Syntax: clrhash hash-table ;; ;; Function Description: clrhash removes all the entries from hash-table and returns the hash table itself. ;; ;; Argument(s): hash-table ;; ;; Returns: hash table ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table3 (make-hash-table :size 5 :rehash-size 5)) (setf (gethash 'car hash-table3) 'vw) (setf (gethash 'year hash-table3) 1970) (setf (gethash 'mileage hash-table3) 99999) (setf (gethash 'option hash-table3) 'sunroof) (setf (gethash 'owner hash-table3) 'smith))) (do-test clrhash-test (and (eq (gethash 'car hash-table3) 'vw) (eq (gethash 'year hash-table3) 1970) (eql (gethash 'mileage hash-table3) 99999) (eq (gethash 'option hash-table3) 'sunroof) (eq (gethash 'owner hash-table3) 'smith) (typep (clrhash hash-table3) 'hash-table) (eq (gethash 'car hash-table3) nil) (eq (gethash 'year hash-table3) nil) (eq (gethash 'mileage hash-table3) nil) (eq (gethash 'option hash-table3) nil) (eq (gethash 'owner hash-table3) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-GETHASH.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-GETHASH.TEST new file mode 100644 index 00000000..bccc0f21 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-GETHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: gethash ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 284 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-1-gethash.test ;; ;; ;; Syntax: gethash key hash-table &optional default ;; ;; Function Description: gethash finds the key in hash-table and returns the associated value. If none, returns default or nil if not specified ;; ;; Argument(s): key, hash-table, and default(&optional) ;; ;; Returns: value of the specified key or NIL ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table1 (make-hash-table :size 7)) (setf (gethash 'name hash-table1) 'joshua) (setf (gethash 'age hash-table1) 24) (setf (gethash 'number hash-table1) 1234) (setf (gethash 'weight hash-table1) 150) (setf (gethash 'job hash-table1) 'writer))) (do-test gethash-test (and (eq (gethash 'name hash-table1) 'joshua) (eq (gethash 'age hash-table1) 24) (eq (gethash 'number hash-table1) 1234) (eq (gethash 'weight hash-table1) 150) (eq (gethash 'job hash-table1) 'writer) (eq (gethash 'address hash-table1 'unknown) 'unknown) (eq (gethash 'salary hash-table1) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-COUNT.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-COUNT.TEST new file mode 100644 index 00000000..ec36ed7f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-COUNT.TEST @@ -0,0 +1 @@ + ;; Function To Be Tested: hash-table-count ;; ;; Source: CommonLisp by Steele Section: 16.2: Hash Table ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 19, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-2-hash-table-count.test ;; ;; ;; Syntax: hash-table-count hash-table ;; ;; Function Description: hash-table-count returns the number of entries in the hash-table. When a hash table is first creatd or has been cleared, the number of entries is zero ;; ;; Argument(s): hash-table ;; ;; Returns: number of entries in the hash-table ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table3 (make-hash-table :size 5 :rehash-size 5)) (setf (gethash 'car hash-table3) 'vw) (setf (gethash 'year hash-table3) 1970) (setf (gethash 'mileage hash-table3) 99999) (setf (gethash 'option hash-table3) 'sunroof) (setf (gethash 'owner hash-table3) 'smith))) (do-test hash-table1-test (eq (hash-table-count hash-table3) 5)) (do-test hash-table2-test (and (clrhash hash-table3) (eq (hash-table-count hash-table3) 0))) (do-test do-hash-table3-test (and (setf hash-table4 (make-hash-table :size 10)) (eq (hash-table-count hash-table4) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-P.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-P.TEST new file mode 100644 index 00000000..309a7c4b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-HASH-TABLE-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: hash-table-p ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 284 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-1-hash-table-p.test ;; ;; ;; Syntax: hash-table-p object ;; ;; Function Description: hash-table-p is true if its argument is a hash table, and otherwise false ;; ;; Argument(s): hash table ;; ;; Returns: hash table ;; ;; Constraints/Limitations: None (do-test hash-table-p-test (and (hash-table-p (make-hash-table)) (hash-table-p (make-hash-table :size 10)) (hash-table-p (make-hash-table :size 8 :rehash-size 4)) (not (hash-table-p 'x)) (not (hash-table-p 100)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-MAKE-HASH-TABLE.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-MAKE-HASH-TABLE.TEST new file mode 100644 index 00000000..af990a4e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-MAKE-HASH-TABLE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-hash-table ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 283 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: Oct 9, 1986 ;; ;; Filed As: {eris}cml>test>16-1-make-hash-table.test ;; ;; ;; Syntax: make-hash-table &key test size rehash-size rehash-threshold ;; ;; Function Description: This function creates and returns a new hash table ;; ;; Argument(s): test: determines how keys are compared ;; [#'eq, #'eql, or #'equal] Default; eql ;; size: initial size of the hash table ;; rehash-size: specifies how much to increase the size of the hash ;; table when it becomes full. Must be integer greater than 0 or ;; floating-point number greater than 1 ;; rehash-threshold: specifies how full the hash table can get before ;; it can grow. ;; ;; Returns: hash table ;; ;; Constraints/Limitations: None (do-test make-hash-table-test (and (eq (type-of (make-hash-table)) 'hash-table) (eq (type-of (make-hash-table :size 10)) 'hash-table) (eq (type-of (make-hash-table :size 8 :rehash-size 4)) 'hash-table) (eq (type-of (make-hash-table :size 20 :rehash-size 1.5)) 'hash-table) (eq (type-of (make-hash-table :size 10 :rehash-size 20 :rehash-threshold 12)) 'hash-table) (eq (type-of (make-hash-table :size 50 :rehash-size 1.4 :rehash-threshold 0.5)) 'hash-table) (eq (type-of (make-hash-table :test #'equal :size 30 :rehash-size 40 :rehash-threshold 0.5)) 'hash-table))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-MAPHASH.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-MAPHASH.TEST new file mode 100644 index 00000000..ef3f10b9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-MAPHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: maphash ;; ;; Source: CommonLisp by Steele Section: 16.2: Primitive Hash ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 19, 1986 ;; ;; Last Update: Oct 9, 1986 ;; ;; Filed As: {eris}cml>test>16-2-maphash.test ;; ;; ;; Syntax: maphash function hash-table ;; ;; Function Description: Maphash calls function on two arguments the key of the entry and the value of entry for each entry in hash-table. ;; ;; Argument(s): function to be mapped and hash-table ;; ;; Returns: hash-table or nil ;; ;; Constraints/Limitations: None ;; Alter every entry in hash-table7, replacing the value with its ;; square root. Entries with negative values are removed. (do-test-group (set-hash-table :before (progn (setf hash-table7 (make-hash-table :size 7)) (setf (gethash 'entry1 hash-table7) 1) (setf (gethash 'entry2 hash-table7) -2) (setf (gethash 'entry3 hash-table7) 9) (setf (gethash 'entry4 hash-table7) -4) (setf (gethash 'entry5 hash-table7) 25) (setf (gethash 'entry6 hash-table7) -6) (setf (gethash 'entry7 hash-table7) 49) ) ) (do-test maphash-test (and (eq (maphash #'(lambda (key val) (if (minusp val) (remhash key hash-table7) (setf (gethash key hash-table7) (sqrt val)))) hash-table7) nil) (eql (gethash 'entry1 hash-table7) 1.0) (eql (gethash 'entry2 hash-table7) nil) (eql (gethash 'entry3 hash-table7) 3.0) (eql (gethash 'entry4 hash-table7) nil) (eql (gethash 'entry5 hash-table7) 5.0) (eql (gethash 'entry6 hash-table7) nil) (eql (gethash 'entry7 hash-table7) 7.0)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-1-REMHASH.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-1-REMHASH.TEST new file mode 100644 index 00000000..f88d638a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-REMHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: remhash ;; ;; Source: CommonLisp by Steele Section: 16.1: Hash Table ;; Functions Page: 284 ;; ;; Created By: John Park ;; ;; Creation Date: May 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>16-1-remhash.test ;; ;; ;; Syntax: remhash key hash-table ;; ;; Function Description: remhash removes any entry for key in hash-table. This is true if there was an entry or false if there was not. ;; ;; Argument(s): key and hashtable ;; ;; Returns: T or NIL ;; ;; Constraints/Limitations: None (do-test-group (set-hash-table :before (progn (setf hash-table2 (make-hash-table :size 7)) (setf (gethash 'name hash-table2) 'joshua) (setf (gethash 'age hash-table2) 24) (setf (gethash 'number hash-table2) 1234) (setf (gethash 'weight hash-table2) 150) (setf (gethash 'job hash-table2) 'writer))) (do-test gethash-test (and (eq (remhash 'name hash-table2) T) (eq (remhash 'name hash-table2) NIL) (eq (remhash 'age hash-table2) T) (eq (remhash 'age hash-table2) NIL ) (eq (remhash 'number hash-table2) T) (eq (remhash 'number hash-table2) NIL) (eq (remhash 'weight hash-table2) T) (eq (remhash 'weight hash-table2) NIL) (eq (remhash 'job hash-table2) T) (eq (remhash 'job hash-table2) NIL) (eq (remhash 'address hash-table2) NIL)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/16/16-2-SXHASH.TEST b/internal/test/LANGUAGE/from-sun/language/16/16-2-SXHASH.TEST new file mode 100644 index 00000000..73003850 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/16/16-2-SXHASH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: sxhash ;; ;; Source: CommonLisp by Steele Section: 16.2: Hash Table ;; Functions Page: 285 ;; ;; Created By: John Park ;; ;; Creation Date: May 19, 1986 ;; ;; Last Update: Aug 8, 1986 ;; ;; Filed As: {eris}cml>test>16-2-sxhash.test ;; ;; ;; Syntax: sxhash object ;; ;; Function Description: sxhash computes a hash code for an object and ;; returns the hash code as a non-negative fixnum. ;; ;; Argument(s): simple-string,string,symbol,list,array,floating point number, integer, ratio, :: and complex number ;; ;; Returns: hash-code (non-negative fixnum) ;; ;; Constraints/Limitations: None (do-test sxhash-test (and (and (<= (sxhash "hello") most-positive-fixnum) (>= (sxhash "hello") 0)) (and (<= (sxhash "1298!@#$)(#)") most-positive-fixnum) (>= (sxhash "1298!@#$)(#)") 0)) (and (<= (sxhash lambda-list-keywords) most-positive-fixnum) (>= (sxhash lambda-list-keywords) 0)) (and (<= (sxhash '(a b c)) most-positive-fixnum) (>= (sxhash '(a b c)) 0)) (and (<= (sxhash (make-array 5)) most-positive-fixnum) (>= (sxhash (make-array 5)) 0)) (and (<= (sxhash 3.78) most-positive-fixnum) (>= (sxhash 3.78) 0)) (and (<= (sxhash 999) most-positive-fixnum) (>= (sxhash 999) 0)) (and (<= (sxhash 3/4) most-positive-fixnum) (>= (sxhash 3/4))) (and (<= (sxhash -7) most-positive-fixnum) (>= (sxhash -7) 0)) (and (<= (sxhash #C(5 -3)) most-positive-fixnum) (>= (sxhash #C(5 -3)) 0)) (zerop (sxhash 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-1-MAKE-ARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-1-MAKE-ARRAY.TEST new file mode 100644 index 00000000..d6063c27 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-1-MAKE-ARRAY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-array ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.1: Array Creation Page: 286 ;; ;; Created By: John Park ;; ;; Creation Date: May 29, 86 ;; ;; Last Update: Oct 16, 86 ;; ;; Filed as: {eris}cml>test>17-1-make-array.test;; ;; ;; Syntax: make-array dimensions &key :element-type :initial-element ;; :initial-contents :adjustable ;; :fill-pointer :displaced-to ;; :displaced-index-offset ;; ;; Function Description: Make-array constructs an array according to ;; the given dimension and key specifications. ;; ;; Argument(s): dimensions: non-negative integers ;; keys element-type: type of the elements of the array ;; (default: t (general array)) ;; initial-element: initialize each element of the array ;; (may not be used with :inital-contents or :display-to option ;; initial-contents: initalialize the contents of the array ;; adjustable: used to alter the array size dynamically after ;; it is created (default: nil) ;; fill-pointer: indicates that the array should have a fill ;; pointer. If specified, an array must be one-dimensional ;; ;; Returns: array or NIL ;; ;; Constraints/limitations: None (do-test-group (array-creation-test :before (progn (setq array1 (make-array 0)) (setq array2 (make-array 5)) (setq array3 (make-array '(2 2) :initial-contents '(((a b) (10 20)) ((c d) (30 40))))) (setq array4 (make-array '(2 2 2) :element-type 'single-float)) (setq array5 (make-array '(2 2) :element-type 'fixnum :initial-element 7)) (setq array6 (make-array '(4 3) :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq array6.1 (make-array 8 :displaced-to array6 :displaced-index-offset 2)) (setq array7 (make-array 10 :fill-pointer T)) (setq array7.1 (make-array 10 :fill-pointer 3)) (setq array8 (make-array '(3 2 2) :adjustable T)) (setq array9 (make-array '(4 2 3) :initial-contents '(((a b c) (1 2 3)) ((d e f) (3 1 2)) ((g h i) (2 3 1)) ((j k l) (0 0 0))))) (setq all-created-arrays (list array1 array2 array3 array4 array5 array6 array6.1 array7 array7.1 array8 array9 )))) (do-test array-dimension-limit-exist? (and (boundp 'array-dimension-limit) (integerp array-dimension-limit) (> array-dimension-limit 1024))) (do-test array-total-size-limit-exist? (and (boundp 'array-total-size-limit) (integerp array-total-size-limit) (> array-total-size-limit 1024))) (do-test array-rank-limit-exist? (and (boundp 'array-rank-limit) (integerp array-rank-limit) (> array-rank-limit 7))) (do-test make-array-test (every #'arrayp all-created-arrays))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-1-VECTOR.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-1-VECTOR.TEST new file mode 100644 index 00000000..0e1f5758 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-1-VECTOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vector ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.1: Array Creation Page: 290 ;; ;; Created By: John Park ;; ;; Creation Date: June 5, 86 ;; ;; Last Update: July 29, 1986, MASINTER, TYPE-OF IS NOT GUARANTEED TO RETURN 'ARRAY ;; ;; Filed as: {eris}cml>test>17-1-vector.test;; ;; ;; Syntax: vector &rest objects ;; ;; Function Description: Vector provides convenient means for creating ;; a simple general vector with specified initial contents ;; ;; Argument(s): any number of lisp objects ;; ;; Returns: array ;; ;; Constraints/limitations: None (do-test vector-test (and (TYPEP (setq v1 (vector 1 2 3)) 'array) (TYPEP (setq a1 (make-array (list 3) :element-type T :initial-contents (list 1 2 3))) 'array) (and (eq (aref v1 0)(aref a1 0)) (eq (aref v1 1)(aref a1 1)) (eq (aref v1 2)(aref a1 2))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-2-AREF.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-2-AREF.TEST new file mode 100644 index 00000000..ffa81763 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-2-AREF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: aref ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.2: Array Access Page: 290 ;; ;; Created By: John Park ;; ;; Creation Date: June 5, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-2-aref.test ;; ;; Syntax: aref array &rest subscripts ;; ;; Function Description: This function accesses and returns the element of ;; array specified by the subscripts. The number of subscripts must equal the ;; rank of the array, and each subscript must be a non-negative integer less ;; than the corresponding array dimension. ;; ;; Argument(s): array and element-position ;; ;; Returns: element specified by the subscripts ;; ;; Constraints/limitations: None (do-test-group (array-creation-test :before (progn (setq array1 (make-array 5 :initial-contents '(a b c d e))) (setq array2 (make-array '(2 2) :initial-contents '(((a b) (10 20)) ((c d) (30 40))))) (setq array3 (make-array '(2 2 2) :element-type 'single-float :initial-element 7.0)) (setq array4 (make-array '(4 3) :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq array5 (make-array 5 :displaced-to array4 :displaced-index-offset 2)) (setq array6 (make-array '(4 2 3) :initial-contents '(((a b c) (1 2 3)) ((d e f) (3 1 2)) ((g h i) (2 3 1)) ((j k l) (0 0 0))))))) (do-test aref-test1 (and (eq (aref array1 0) 'a) (eq (aref array1 1) 'b) (eq (aref array1 2) 'c) (eq (aref array1 3) 'd) (eq (aref array1 4) 'e))) (do-test aref-test2 (and (equal (aref array2 0 0) '(A B)) (equal (aref array2 0 1) '(10 20)) (equal (aref array2 1 0) '(C D)) (equal (aref array2 1 1) '(30 40)))) (do-test aref-test3 (and (eql (aref array3 0 0 0) 7.0) (eql (aref array3 0 1 0) 7.0) (eql (aref array3 1 1 1) 7.0))) (do-test aref-test4 (and (eq (aref array5 0) (aref array4 0 2)) (eq (aref array5 1) (aref array4 1 0)) (eq (aref array5 2) (aref array4 1 1)) (eq (aref array5 3) (aref array4 1 2)) (eq (aref array5 4) (aref array4 2 0)))) (do-test aref-test5 (and (eq (aref array6 0 0 0) 'a) (eq (aref array6 0 1 1) 2) (eq (aref array6 1 1 2) 2) (eq (aref array6 2 1 2) 1) (eq (aref array6 3 0 1) 'k) (eq (aref array6 3 1 2) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-2-SVREF.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-2-SVREF.TEST new file mode 100644 index 00000000..83186fc2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-2-SVREF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: svref ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.2: Array Access Page: 291 ;; ;; Created By: John Park ;; ;; Creation Date: June 9, 86 ;; ;; Last Update: Aug 8, 86 ;; ;; Filed as: {eris}cml>test>17-2-svref.test ;; ;; Syntax: svref simple-vector index ;; ;; Function Description: This function accesses and returns the element of ;; a simple vector specified by the index. The index must be non-negative and ;; less than the length of the vector. ;; ;; Argument(s): vector and index ;; ;; Returns: element specified by the index ;; ;; Constraints/limitations: None (do-test-group vector-access-test :before (progn (setq vector1 (vector 'a 'b 'c 'd 'e 'f)) (setq vector2 (vector 'A 2 10 4.3 "hello" -1.7))) (do-test svref-test1 (and (eq (svref vector1 0) 'a) (eq (svref vector1 1) 'b) (eq (svref vector1 2) 'c) (eq (svref vector1 3) 'd) (eq (svref vector1 4) 'e) (eq (svref vector1 5) 'f))) (do-test svref-test2 (and (equal (svref vector2 0 ) 'A) (equal (svref vector2 1 ) 2) (equal (svref vector2 2 ) 10) (equalp (svref vector2 3 ) 4.3) (equal (svref vector2 4) "hello") (equalp (svref vector2 5) -1.7)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ADJUSTABLE-ARRAY-P.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ADJUSTABLE-ARRAY-P.TEST new file mode 100644 index 00000000..9847736a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ADJUSTABLE-ARRAY-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: adjustable-array-p ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 293 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-adjustable-array-p.test ;; ;; Syntax: adjustable-array-p array ;; ;; Function Description: This predicate is true if the array is adjustable ;; otherwise false. ;; Argument(s): array ;; Returns: T if array is adjustable, NIL otherwise. ;; ;; Constraints/limitations: None (do-test-group adjustable-array-p-tests :before (progn (setq array1 (make-array 10)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(3 3 3) :adjustable T)) (setq array4 (make-array '(3 4 5 2)))) (do-test adjustable-array-p-test (and (not (adjustable-array-p array1)) (not (adjustable-array-p array2)) (adjustable-array-p array3) (not (adjustable-array-p array4))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSION.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSION.TEST new file mode 100644 index 00000000..79ec7a45 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-dimension ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-dimension.test ;; ;; Syntax: array-dimension array axis-number ;; ;; Function Description: This function returns the length of dimension ;; specified by axis-number of a given array. ;; ;; Argument(s): array and axis-number ;; Returns: length of a given array dimension ;; ;; Constraints/limitations: None (do-test-group "array-dimension-test-setup" :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7)))) (do-test "array-dimension-test" (and (eq (array-dimension array1 0) 30) (eq (array-dimension array2 0) 3) (eq (array-dimension array2 1) 5) (eq (array-dimension array3 0) 2) (eq (array-dimension array3 1) 4) (eq (array-dimension array3 2) 3) (eq (array-dimension array4 0) 3) (eq (array-dimension array4 1) 4) (eq (array-dimension array4 2) 5) (eq (array-dimension array4 3) 3) (eq (array-dimension array4 4) 2) (eq (array-dimension array4 5) 2) (eq (array-dimension array4 6) 7)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSIONS.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSIONS.TEST new file mode 100644 index 00000000..c129f905 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-DIMENSIONS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-dimensions ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-dimensions.test ;; ;; Syntax: array-dimensions array ;; ;; Function Description: This function returns the dimensions ;; of a given array. ;; ;; Argument(s): array ;; Returns: dimensions of a given array ;; ;; Constraints/limitations: None (do-test-group array-dimensions-test :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7)))) (do-test array-dimensions-test (and (equal (array-dimensions array1) '(30)) (equal (array-dimensions array2) '(3 5)) (equal (array-dimensions array3) '(2 4 3)) (equal (array-dimensions array4) '(3 4 5 3 2 2 7))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ELEMENT-TYPE.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ELEMENT-TYPE.TEST new file mode 100644 index 00000000..c7d6edc2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ELEMENT-TYPE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-element-type ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 291 ;; ;; Created By: John Park ;; ;; Creation Date: June 9, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-element-type.test ;; ;; Syntax: array-element-type array ;; ;; Function Description: This function returns a type specifier for the set ;; of objects that can be stored in the array. ;; ;; Argument(s): array ;; ;; Returns: element specified by the index ;; ;; Constraints/limitations: None (do-test-group (array-element-type-test :before (progn (setq array1 (make-array 5 :initial-contents '(a b c d e))) (setq array2 (make-array '(2 2) :element-type 'single-float :initial-contents '((1.2 9.1019) (-5.39 0.1)))) (setq array3 (make-array 7 :element-type '(mod 6))) (setq array4 (make-array '(4 3) :element-type 'fixnum :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq array5 (make-array 5 :element-type 'fixnum :displaced-to array4 :displaced-index-offset 2)))) (do-test a1-element-type-test (eq (array-element-type array1) T)) (do-test a2-element-type-test (eq (array-element-type array2) 'single-float)) (do-test a3-element-type-test (or (equal (array-element-type array3) '(UNSIGNED-BYTE 8)) (subtypep (array-element-type array3) T))) (do-test a4-element-type-test (or(eq (array-element-type array4) 'fixnum) (subtypep (array-element-type array4) T))) (do-test a5-element-type-test (or(eq (array-element-type array5) 'fixnum) (subtypep (array-element-type array5) T)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-IN-BOUNDS-P.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-IN-BOUNDS-P.TEST new file mode 100644 index 00000000..21f5c6d4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-IN-BOUNDS-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-in-bounds-p ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-in-bounds-p.test ;; ;; Syntax: array-in-bounds-p array &rest subscripts ;; ;; Function Description: This predicate checks whether the subscripts are all ;; legal subscripts for array. The number of subscripts must be equal to the ;; rank of the array. ;; ;; Argument(s): array and subscripts ;; Returns: T for legal subscripts; NIL otherwise. ;; ;; Constraints/limitations: None (do-test-group array-in-bounds-p-tests :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7)))) (do-test array-in-bounds-p-test (and (array-in-bounds-p array1 0) (array-in-bounds-p array1 2) (array-in-bounds-p array1 4) (array-in-bounds-p array1 10) (array-in-bounds-p array1 26) (array-in-bounds-p array1 29) (eq (array-in-bounds-p array1 30) NIL) (array-in-bounds-p array2 0 0) (array-in-bounds-p array2 1 1) (array-in-bounds-p array2 1 2) (array-in-bounds-p array2 2 2) (array-in-bounds-p array2 2 4) (eq (array-in-bounds-p array2 3 5) NIL) (array-in-bounds-p array3 0 0 0) (array-in-bounds-p array3 1 1 1) (array-in-bounds-p array3 1 3 2) (eq (array-in-bounds-p array3 2 4 3) NIL) (array-in-bounds-p array4 0 0 0 0 0 0 0) (array-in-bounds-p array4 1 1 1 1 1 1 1) (array-in-bounds-p array4 1 2 0 2 1 0 6) (eq (array-in-bounds-p array4 3 1 2 2 0 1 0) NIL)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-RANK.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-RANK.TEST new file mode 100644 index 00000000..d60245ae --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-RANK.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-rank ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 9, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-rank.test ;; ;; Syntax: array-rank array ;; ;; Function Description: This function returns the number of dimensions of ;; array. ;; ;; Argument(s): array ;; Returns: number of dimensions (non-negative integer) ;; ;; Constraints/limitations: None (do-test array-rank-test (and (eq (array-rank (make-array 1)) 1) (eq (array-rank (make-array '(2 2))) 2) (eq (array-rank (make-array '(3 3 4))) 3) (eq (array-rank (make-array '(4 3 5 2 1 3))) 6) (eq (array-rank (make-array '(2 2 2 2 2 2 2))) 7))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ROW-MAJOR-INDEX.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ROW-MAJOR-INDEX.TEST new file mode 100644 index 00000000..f4826b1f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-ROW-MAJOR-INDEX.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-row-major-index ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 293 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-row-major-index.test ;; ;; Syntax: array-row-major-index array &rest subscripts ;; ;; Function Description: This function takes an array and valid subscripts ;; for the array and returns a single non-negative integer less than the ;; total size of the array that identifies the accessed element in the major ;; ordering of the elements. For a one-dimensional array, the result ;; of array-row-major-index always equals the supplied subscript. ;; ;; Argument(s): array and subscripts ;; Returns: non-negative integer ;; ;; Constraints/limitations: None (do-test-group array-row-major-index-tests :before (progn (setq array1 (make-array 10)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(3 3 3))) (setq array4 (make-array '(3 4 5 2)))) (do-test array-row-major-index-test (and (eq (array-row-major-index array1 0) 0) (eq (array-row-major-index array1 9) 9) (eq (array-row-major-index array2 0 0) 0) (eq (array-row-major-index array2 1 2) 7) (eq (array-row-major-index array2 2 4) 14) (eq (array-row-major-index array3 0 0 0) 0) (eq (array-row-major-index array3 0 2 1) 7) (eq (array-row-major-index array3 1 1 1) 13) (eq (array-row-major-index array3 2 1 2) 23) (eq (array-row-major-index array3 2 2 2) 26) (eq (array-row-major-index array4 0 0 0 1) 1) (eq (array-row-major-index array4 1 0 0 1) 41) (eq (array-row-major-index array4 1 1 1 1) 53) (or (< (array-row-major-index array4 2 3 2 1) (array-total-size array4)) (>= (array-row-major-index array4 2 3 2 1) 0)) (or (< (array-row-major-index array4 2 1 4 0) (array-total-size array4)) (>= (array-row-major-index array4 2 1 4 0) 0))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-TOTAL-SIZE.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-TOTAL-SIZE.TEST new file mode 100644 index 00000000..1658f86f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-3-ARRAY-TOTAL-SIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-total-size ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.3: Array Information Page: 292 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-3-array-total-size.test ;; ;; Syntax: array-total-size array ;; ;; Function Description: This function returns the total number of elements ;; or the product of all the dimensions ;; ;; Argument(s): array ;; Returns: product of a given array ;; ;; Constraints/limitations: None (do-test-group (array-total-size-setup :before (progn (setq array1 (make-array 30)) (setq array2 (make-array '(3 5))) (setq array3 (make-array '(2 4 3))) (setq array4 (make-array '(3 4 5 3 2 2 7))) (setq array5 (make-array 0)))) (do-test array-total-size-test (and (eq (array-total-size array1) 30) (eq (array-total-size array2) 15) (eq (array-total-size array3) 24) (eq (array-total-size array4) 5040) (eq (array-total-size array5) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-AND.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-AND.TEST new file mode 100644 index 00000000..bed57802 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-AND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-and ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-and.test ;; ;; Syntax: bit-and bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical AND ;; operation and creates a new array unless the third argument is t (stores ;; the result in bit-array1) or in result-bit-array. ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise AND operation ;; ;; Constraints/limitations: None (do-test-group bit-and-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-and-test1 (and (bit-and bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 1))) (do-test bit-and-test2 (and (setq new-bit-array (bit-and bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 1))) (do-test bit-and-test3 (and (bit-and bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC1.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC1.TEST new file mode 100644 index 00000000..b7df0b8c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-andc1 ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-andc1.test ;; ;; Syntax: bit-andc1 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical AND ;; operation on complement of argument1 with argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise AND operation on complement of ;; argument1 with argument2. ;; ;; Constraints/limitations: None (do-test-group bit-andc1-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-andc1-test1 (and (bit-andc1 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 0))) (do-test bit-andc1-test2 (and (setq new-bit-array (bit-andc1 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 0))) (do-test bit-andc1-test3 (and (bit-andc1 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC2.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC2.TEST new file mode 100644 index 00000000..5db40ae8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ANDC2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-andc2 ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-andc2.test ;; ;; Syntax: bit-andc2 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical AND ;; operation on argument1 with compliment of argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise AND operation on argument1 with ;; compliment of argument2. ;; ;; Constraints/limitations: None (do-test-group bit-andc2-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-andc2-test1 (and (bit-andc2 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 0))) (do-test bit-andc2-test2 (and (setq new-bit-array (bit-andc2 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 0))) (do-test bit-andc2-test3 (and (bit-andc2 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-EQV.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-EQV.TEST new file mode 100644 index 00000000..53e3384f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-EQV.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-eqv ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-eqv.test ;; ;; Syntax: bit-eqv bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical equivalence ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise equivalence (exclusive nor) ;; operation ;; ;; Constraints/limitations: None (do-test-group bit-eqv-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-eqv-test1 (and (bit-eqv bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 1))) (do-test bit-eqv-test2 (and (setq new-bit-array (bit-eqv bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 1))) (do-test bit-eqv-test3 (and (bit-eqv bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-IOR.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-IOR.TEST new file mode 100644 index 00000000..63f97d35 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-IOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-ior ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-ior.test ;; ;; Syntax: bit-ior bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Inclusive OR ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Inclusive OR operation ;; ;; Constraints/limitations: None (do-test-group bit-ior-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-ior-test1 (and (bit-ior bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 1))) (do-test bit-ior-test2 (and (setq new-bit-array (bit-ior bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 1))) (do-test bit-ior-test3 (and (bit-ior bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NAND.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NAND.TEST new file mode 100644 index 00000000..c110bcfb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NAND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-nand ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-nand.test ;; ;; Syntax: bit-nand bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Not-AND ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Not-AND operation. ;; ;; Constraints/limitations: None (do-test-group bit-nand-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-nand-test1 (and (bit-nand bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 0))) (do-test bit-nand-test2 (and (setq new-bit-array (bit-nand bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 0))) (do-test bit-nand-test3 (and (bit-nand bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOR.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOR.TEST new file mode 100644 index 00000000..8af6e987 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-nor ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-nor.test ;; ;; Syntax: bit-nor bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Not-OR ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Not-OR operation. ;; ;; Constraints/limitations: None (do-test-group bit-nor-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-nor-test1 (and (bit-nor bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 0))) (do-test bit-nor-test2 (and (setq new-bit-array (bit-nor bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 0))) (do-test bit-nor-test3 (and (bit-nor bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOT.TEST new file mode 100644 index 00000000..a7888845 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-not ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 12, 86 ;; ;; Last Update: July 18, 1986 by Masinter, bit-array1 -> bit-array ;; ;; Filed as: {eris}cml>test>17-4-bit-not.test ;; ;; Syntax: bit-not bit-array &optional result-bit-array ;; ;; Function Description: This function returns an array with all the bits ;; inverted. If an array is specified, that array is used to store the ;; result. If t is specified, the result is destructively stored in the ;; the original array or bit-array. ;; ;; Argument(s): bit-array result-bit-array ;; Returns: array with all the bits inverted. ;; ;; Constraints/limitations: None (do-test-group bit-not-tests :before (progn (setq bit-array (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-not-test1 (and (bit-not bit-array result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 0))) (do-test bit-not-test2 (and (setq new-bit-array (bit-not bit-array)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 0))) (do-test bit-not-test3 (and (bit-not bit-array t) (eq (bit bit-array 0) 1) (eq (bit bit-array 1) 1) (eq (bit bit-array 2) 0) (eq (bit bit-array 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC1.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC1.TEST new file mode 100644 index 00000000..8b3efc6c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-orc1 ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-orc1.test ;; ;; Syntax: bit-orc1 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical OR ;; operation on complement of argument1 with argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise OR operation on complement of ;; argument1 with argument2. ;; ;; Constraints/limitations: None (do-test-group bit-orc1-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-orc1-test1 (and (bit-orc1 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 0) (eq (bit result-bit-array 3) 1))) (do-test bit-orc1-test2 (and (setq new-bit-array (bit-orc1 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 0) (eq (bit new-bit-array 3) 1))) (do-test bit-orc1-test3 (and (bit-orc1 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC2.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC2.TEST new file mode 100644 index 00000000..22c576a6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-ORC2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-orc2 ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-orc2.test ;; ;; Syntax: bit-orc2 bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical OR ;; operation on argument1 with compliment of argument2, and stores the result ;; in a newly created array. If an array is specified, that array is used to ;; store the result. If t is specified, the result is destructively ;; stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise OR operation on argument1 with ;; compliment of argument2. ;; ;; Constraints/limitations: None (do-test-group bit-orc2-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-orc2-test1 (and (bit-orc2 bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 1) (eq (bit result-bit-array 1) 0) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 1))) (do-test bit-orc2-test2 (and (setq new-bit-array (bit-orc2 bit-array1 bit-array2)) (eq (bit new-bit-array 0) 1) (eq (bit new-bit-array 1) 0) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 1))) (do-test bit-orc2-test3 (and (bit-orc2 bit-array1 bit-array2 t) (eq (bit bit-array1 0) 1) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 1)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-XOR.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-XOR.TEST new file mode 100644 index 00000000..a5beaa48 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT-XOR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-xor ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 294 ;; ;; Created By: John Park ;; ;; Creation Date: June 11, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-4-bit-xor.test ;; ;; Syntax: bit-xor bit-array1 bit-array2 &optional result-bit-array ;; ;; Function Description: This function performs bit-wise logical Exclusive OR ;; operation and stores the result in a newly created array. If an array is ;; specified, that array is used to store the result. If t is specified, the ;; result is destructively stored in bit-array1. ;; ;; Argument(s): bit-array1 bit-array2 t or result-bit-array ;; Returns: array with result of bit-wise Exclusive OR operation ;; ;; Constraints/limitations: None (do-test-group bit-xor-tests :before (progn (setq bit-array1 (make-array 4 :element-type 'bit :initial-contents '(0 0 1 1))) (setq bit-array2 (make-array 4 :element-type 'bit :initial-contents '(0 1 0 1))) (setq result-bit-array (make-array 4 :element-type 'bit))) (do-test bit-xor-test1 (and (bit-xor bit-array1 bit-array2 result-bit-array) (eq (bit result-bit-array 0) 0) (eq (bit result-bit-array 1) 1) (eq (bit result-bit-array 2) 1) (eq (bit result-bit-array 3) 0))) (do-test bit-xor-test2 (and (setq new-bit-array (bit-xor bit-array1 bit-array2)) (eq (bit new-bit-array 0) 0) (eq (bit new-bit-array 1) 1) (eq (bit new-bit-array 2) 1) (eq (bit new-bit-array 3) 0))) (do-test bit-xor-test3 (and (bit-xor bit-array1 bit-array2 t) (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 1) (eq (bit bit-array1 2) 1) (eq (bit bit-array1 3) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT.TEST new file mode 100644 index 00000000..fb0bf382 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 293 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: July 18, 1986 by masinter, "intial" -> "initial" ;; ;; Filed as: {eris}cml>test>17-4-bit.test ;; ;; Syntax: bit bit-array &rest subscripts ;; ;; Function Description: This function returns an element of a bit-array ;; specified by subscripts. Analogous to aref. ;; Argument(s): array ;; Returns: 0 or 1 ;; ;; Constraints/limitations: None (do-test-group bit-tests :before (progn (setq bit-array1 (make-array 5 :element-type 'bit)) (setq bit-array2 (make-array '(2 2) :element-type 'bit :initial-element 1)) (setq bit-array3 (make-array '(2 2 2) :element-type 'bit :initial-contents '(((1 0) (0 1)) ((1 1) (0 0)))))) (do-test bit-test (and (eq (bit bit-array1 0) 0) (eq (bit bit-array1 1) 0) (eq (bit bit-array1 2) 0) (eq (bit bit-array1 3) 0) (eq (bit bit-array1 4) 0) (eq (bit bit-array2 0 0) 1) (eq (bit bit-array2 0 1) 1) (eq (bit bit-array2 1 0) 1) (eq (bit bit-array2 1 1) 1) (eq (bit bit-array3 0 0 0) 1) (eq (bit bit-array3 0 0 1) 0) (eq (bit bit-array3 0 1 0) 0) (eq (bit bit-array3 0 1 1) 1) (eq (bit bit-array3 1 0 0) 1) (eq (bit bit-array3 1 0 1) 1) (eq (bit bit-array3 1 1 0) 0) (eq (bit bit-array3 1 1 1) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-4-SBIT.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-4-SBIT.TEST new file mode 100644 index 00000000..be82d0ed --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-SBIT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: sbit ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.4: Functions on Arrays of Bits Page: 293 ;; ;; Created By: John Park ;; ;; Creation Date: June 10, 86 ;; ;; Last Update: July 18, 1986 by masinter, SBIT is not required to fail on ;; non-simple-bit-arrays ;; ;; Filed as: {eris}cml>test>17-4-sbit.test ;; ;; Syntax: sbit simple-bit-array &rest subscripts ;; ;; Function Description: This function returns an element of a sbit-array ;; specified by subscripts. ;; Argument(s): simple-bit-array ;; Returns: 0 or 1 ;; ;; Constraints/limitations: None (do-test-group sbit-tests :before (progn (setq sbit-array1 (make-array 5 :element-type 'bit)) (setq sbit-array2 (make-array '(2 2) :element-type 'bit :initial-element 1)) (setq sbit-array3 (make-array '(2 2 2) :element-type 'bit :initial-contents '(((1 0) (0 1)) ((1 1) (0 0))))) (setq sbit-array4 (make-array '(4 3) :initial-contents '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))) (setq sbit-array4.1 (make-array 8 :adjustable t :fill-pointer t :displaced-to array6 :displaced-index-offset 2))) (do-test sbit-test (and (eq (sbit sbit-array1 0) 0) (eq (sbit sbit-array1 1) 0) (eq (sbit sbit-array1 2) 0) (eq (sbit sbit-array1 3) 0) (eq (sbit sbit-array1 4) 0) (eq (sbit sbit-array2 0 0) 1) (eq (sbit sbit-array2 0 1) 1) (eq (sbit sbit-array2 1 0) 1) (eq (sbit sbit-array2 1 1) 1) (eq (sbit sbit-array3 0 0 0) 1) (eq (sbit sbit-array3 0 0 1) 0) (eq (sbit sbit-array3 0 1 0) 0) (eq (sbit sbit-array3 0 1 1) 1) (eq (sbit sbit-array3 1 0 0) 1) (eq (sbit sbit-array3 1 0 1) 1) (eq (sbit sbit-array3 1 1 0) 0) (eq (sbit sbit-array3 1 1 1) 0) ; (eq (sbit sbit-array4.1 0) 3) ;; tests to see if sbit fails ;; on non-simple-array ;; ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-5-ARRAY-HAS-FILL-POINTER-P.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-5-ARRAY-HAS-FILL-POINTER-P.TEST new file mode 100644 index 00000000..cf7d974f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-5-ARRAY-HAS-FILL-POINTER-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: array-has-fill-pointer-p ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointers Page: 295 ;; ;; Created By: John Park ;; ;; Creation Date: June 12, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-5-array-has-fill-pointer-p.test ;; ;; Syntax: array-has-fill-pointer-p array ;; ;; Function Description: This function returns t if an array has a fill ;; pointe, and otherwise returns nil. Returns nil if array is not ;; one-dimensional. ;; ;; Argument(s): array ;; ;; Returns: t or nil ;; ;; Constraints/limitations: None (do-test-group array-has-fill-pointer-p-tests :before (progn (setq fill-pointer-array1 (make-array 4 )) (setq fill-pointer-array2 (make-array 5 :fill-pointer 2)) (setq fill-pointer-array3 (make-array 5 :fill-pointer t)) (setq fill-pointer-array4 (make-array '(2 3)))) (do-test array-has-fill-pointer-p-test1 (and (eq (array-has-fill-pointer-p fill-pointer-array1) nil) (array-has-fill-pointer-p fill-pointer-array2) (array-has-fill-pointer-p fill-pointer-array3) (eq (array-has-fill-pointer-p fill-pointer-array4) nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-5-FILL-POINTER.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-5-FILL-POINTER.TEST new file mode 100644 index 00000000..6cecc824 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-5-FILL-POINTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fill-pointer ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointer Page: 296 ;; ;; Created By: John Park ;; ;; Creation Date: June 13, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-5-fill-pointer.test ;; ;; Syntax: fill-pointer vector ;; ;; Function Description: This functions returns the fill-pointer of a vector ;; ;; Argument(s): vector (one-dimensional array with fill-pointer) ;; ;; Returns: fill-pointer ;; ;; Constraints/limitations: None (do-test fill-pointer-test (and (setq v1 (make-array 7 :fill-pointer 2)) (setq v2 (make-array 7 :fill-pointer t)) (eq (fill-pointer v1) 2) (eq (fill-pointer v2) 7) (setf (fill-pointer v1) 3) (eq (fill-pointer v1) 3))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-POP.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-POP.TEST new file mode 100644 index 00000000..3260d089 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-POP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vector-pop ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointers Page: 296 ;; ;; Created By: John Park ;; ;; Creation Date: June 13, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-5-vector-pop.test ;; ;; Syntax: vector-pop vector ;; ;; Function Description: Vector-pop decrements the fill pointer of a vector by ;; 1 and returns the value designated by the new fill pointer. rwards. If the ;; fill-pointer is 0, vector-pop signals an error. ;; ;; Argument(s): vector-pop vector ;; ;; Returns: value designated by the new fill pointer ;; ;; Constraints/limitations: None (do-test-group vector-pop-tests :before (progn (setq vector-pop1 (make-array 7 :initial-contents '(1 2 3 4 5 6 7) :fill-pointer 6)) (setq vector-pop2 (make-array 4 :initial-contents '(a b c d) :fill-pointer t)) (setq vector-pop3 (make-array 4 :initial-contents '(10 20 30 40) :fill-pointer 2))) (do-test vector-pop-test1 (and (eq (vector-pop vector-pop1) 6) (eq (vector-pop vector-pop1) 5) (eq (vector-pop vector-pop1) 4) (eq (vector-pop vector-pop1) 3) (eq (vector-pop vector-pop1) 2) (eq (vector-pop vector-pop1) 1))) (do-test vector-pop-test2 (and (eq (vector-pop vector-pop2) 'd) (eq (vector-pop vector-pop2) 'c) (eq (vector-pop vector-pop2) 'b) (eq (vector-pop vector-pop2) 'a))) (do-test vector-pop-test3 (and (eq (vector-pop vector-pop3) 20) (eq (vector-pop vector-pop3) 10)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH-EXTEND.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH-EXTEND.TEST new file mode 100644 index 00000000..d1604cb6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH-EXTEND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vector-push-extend ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointer Page: 296 ;; ;; Created By: John Park ;; ;; Creation Date: June 15, 86 ;; ;; Last Update: January 7, 87 ;; ;; Filed as: {eris}cml>test>17-5-vector-push-extend.test ;; ;; Syntax: vector-push-extend new-element vector &optional extension ;; ;; Function Description: Vector-push is just like vector-push except that if the ;; fill pointer gets too large, the vector is extended (using adjust-array) so ;; that it can contain more elements. The option, extension must be a positive ;; integer, is the minimum number of elements to be added to the vector if it ;; must be extended. The default (*DEFAULT-PUSH-EXTENSION-SIZE*) is 20. ;; ;; Argument(s): new-element vector extension (optional) ;; ;; Returns: vector-push-extend ;; ;; Constraints/limitations: The variable such as *DEFAULT-PUSH-EXTENSION-SIZE* (xcl) ;; is implementation-dependent. (do-test vector-push-extend-test1 (let ((vpe1 (make-array 7 :adjustable t :fill-pointer 5))) (and (eq (array-dimension vpe1 0) 7) (eq (vector-push-extend 'fifth vpe1) 5) (eq (vector-push-extend 'sixth vpe1) 6) (eq (vector-push-extend 'seventh vpe1) 7) (eq (vector-push-extend 'eighth vpe1) 8) (> (array-dimension vpe1 0) 7) ;; vpe1 should now have been extended to contain more than 7 ;; elements (this is implementation-dependent) ) ) ) (do-test vector-push-extend-test2 (let ((vpe2 (make-array 7 :adjustable t :fill-pointer 6))) ;; In the following cases, the array size should increase by 5 ;; so that its total dimension is equal to 12 (and (eq (vector-push-extend 'a vpe2 5) 6) (eq (vector-push-extend 'b vpe2 5) 7) (eq (vector-push-extend 'c vpe2 5) 8) (eq (vector-push-extend 'd vpe2 5) 9) (eq (vector-push-extend 'e vpe2 5) 10) (eq (vector-push-extend 'f vpe2 5) 11) (eq (array-dimension vpe2 0) 12) ) ) ) (do-test vector-push-extend-test3 (if (string-equal (lisp-implementation-type) "xerox") (let ((vpe3 (make-array 7 :adjustable t :fill-pointer t))) (and (eq (vector-push-extend 'a vpe3) 7) ;; fill-pointer is already 7. The total-dimension of the array ;; should increase to 27 since the *DEFAULT-PUSH-EXTENSION-SIZE* ;; is 20 (eq (vector-push-extend 'b vpe3) 8) (eq (vector-push-extend 'c vpe3) 9) (eq (vector-push-extend 'd vpe3) 10) (eq (vector-push-extend 'e vpe3) 11) (setf (fill-pointer vpe3) 24) ; resets fill-pointer to 24 (eq (vector-push 'x vpe3) 24) (eq (vector-push 'y vpe3) 25) (eq (vector-push 'z vpe3) 26) (not (vector-push 'end vpe3)) ) ) T ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH.TEST new file mode 100644 index 00000000..7cc60c4c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-5-VECTOR-PUSH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vector-push ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.5: Fill Pointer Page: 296 ;; ;; Created By: John Park ;; ;; Creation Date: June 13, 86 ;; ;; Last Update: Jan 7, 87 ;; ;; Filed as: {eris}cml>test>17-5-vector-push.test ;; ;; Syntax: vector-push new-element vector ;; ;; Function Description: Vector-push stores new-element in the vector specified ;; by the fill-pointer, which is incremented by 1 afterwards. If the ;; fill-pointer is t (i.e. size of a vector) or is incremented to the size of a ;; vector, nil will be returned. ;; ;; Argument(s): new-element vector ;; ;; Returns: vector-push ;; ;; Constraints/limitations: None (do-test vector-push-test (and (setq vp-array1 (make-array 7 :fill-pointer 2)) (setq vp-array2 (make-array 7 :fill-pointer 6)) (setq vp-array3 (make-array 7 :fill-pointer t)) (eq (vector-push 'new vp-array1) 2) (eq (fill-pointer vp-array1) 3) (eq (aref vp-array1 2) 'new) (eq (vector-push 'new2 vp-array1) 3) (eq (aref vp-array1 3) 'new2) (eq (vector-push 'last vp-array2) 6) (eq (fill-pointer vp-array2) 7) (eq (aref vp-array2 6) 'last) (not (vector-push 'last2 vp-array2)) (eq (fill-pointer vp-array3) 7) (not (vector-push 'seventh vp-array3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/17/17-6-ADJUST-ARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/17/17-6-ADJUST-ARRAY.TEST new file mode 100644 index 00000000..7d98cd49 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/17/17-6-ADJUST-ARRAY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: adjust-array ;; ;; Source: Common Lisp by Guy Steele ;; Section 17.6: Changing the Dimensions of an Array Page: 297 ;; ;; Created By: John Park ;; ;; Creation Date: June 16, 86 ;; ;; Last Update: ;; ;; Filed as: {eris}cml>test>17-6-adjust-array.test ;; ;; Syntax: adjust-array array dimensions &key :element-type :initial-element ;; :initial-contents ;; :fill-pointer :displaced-to ;; :displaced-index-offset ;; ;; Function Description: Adjust-array resizes or reshapes an array according to ;; the given options, which are similar to those of make-array . ;; ;; Argument(s): ;; array: array being adjusted ;; new-dimensions: same rank as that of original array ;; element-type: same as that of original array ;; initial-contents: The elements of the new array that are not in the ;; bounds of array are intialized to this value ;; displaced-to: same as for make-array ;; displaced-index-offset: same as for make-array ;; fill-pointer: reset for adjusted array as specified for one-dimensional ;; array. Original array must also have a fill-pointer ;; Returns: adjusted-array of the same rank and type ;; ;; Constraints/limitations: None (do-test-group create-and-adjust-array-test :before (progn (setq original-array (make-array '(4 4) :initial-contents '((alpha beta gamma delta) (epsilon zeta eta theta) (iota kappa lambda mu) (nu xi omicron pi)) :adjustable t))) (do-test adjust-array-test (and (setq adjusted-array (adjust-array original-array '(3 5) :initial-element `baz)) (eq (array-rank adjusted-array) 2) (equal (array-dimensions adjusted-array) '(3 5)) (array-element-type adjusted-array) (eq (aref adjusted-array 0 0) 'alpha) (eq (aref adjusted-array 0 3) 'delta) (eq (aref adjusted-array 0 4) 'baz) (eq (aref adjusted-array 1 0) 'epsilon) (eq (aref adjusted-array 1 3) 'theta) (eq (aref adjusted-array 1 4) 'baz) (eq (aref adjusted-array 2 0) 'iota) (eq (aref adjusted-array 2 3) 'mu) (eq (aref adjusted-array 2 4) 'baz)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-1-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-1-CHAR.TEST new file mode 100644 index 00000000..1e3948a1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-1-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: char ;; ;; Source: CLtL p. 300 ;; Chapter 18: Strings Section 1: String Access ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 24 July 86 ;; ;; Last Update: 19 December 86 ;; ;; Filed As: {eris}cml>test>18-1-char.test ;; ;; ;; Syntax: char string index ;; ;; Function Description: Returns the character index positions (counting from 0) into string. ;; ;; Argument(s): : any character string ;; : a non-negative integer less then the number of characters in the string. ;; ;; Returns: the character at index ;; (do-test-group char-group :before (progn (test-setq simple (copy-seq "This is a simple string.") arraystring (make-array '(13) :element-type 'string-char :initial-contents '(#\S #\h #\o #\r #\t #\Space #\Linefeed #\s #\t #\r #\i #\n #\g)) twine (copy-seq "twine") displacedarray (make-array (length simple) :element-type 'string-char :displaced-to simple) fillpt '(#\H #\a #\s #\Newline #\a #\Newline #\f #\i #\l #\l #\Newline #\p #\o #\i #\n #\t #\e #\r) fillptarray (make-array (length fillpt) :element-type 'string-char :initial-contents fillpt :fill-pointer t) adjarray (make-array 10 :element-type 'string-char :initial-contents '(#\a #\d #\j #\u #\s #\t #\a #\b #\l #\e) :adjustable t) all3array (make-array (length simple) :element-type 'string-char :adjustable t :fill-pointer t :displaced-to simple) ) ; test-setq (test-defun stringchartest (string index character) (let ((stringchar (char string index))) (and (char= character stringchar) (string-char-p stringchar) ) ; and ) ; let ) ; test-defun ) ;progn ;; ;; Test with simple strings. (do-test char-simple-test (AND ;; The simplest case (stringchartest simple 0 #\T) ;; See that it goes past a line-feed (stringchartest simple 8 #\a) ;; See that is distinguishes upper from lower case (not (char= #\t (char simple 0))) (char-equal #\t (char simple 0)) ;; See if it treats 1-dimensional character array as a string. (stringchartest arraystring 12 #\g) ;; See if the setf/char combination alters a string destructively. (setf (char twine 0) #\s) (eq (string= twine twine) (string= twine (make-array '(5) :element-type 'string-char :initial-contents '( #\s #\w #\i #\n #\e)))) ) ;and ) ;do-test ;; ;; Test with non-simple strings. (do-test char-nonsimple-test (and (stringchartest displacedarray 4 #\Newline) (stringchartest fillptarray 4 #\a) (stringchartest adjarray 9 #\e) (stringchartest all3array 5 #\i) ) ;and ) ;do-test ) ;do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-1-SCHAR.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-1-SCHAR.TEST new file mode 100644 index 00000000..dc9e57ca --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-1-SCHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: schar ;; ;; Source: CLtL p. 300 ;; Chapter 18: Strings Section 1: String Access ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 24 July 86 ;; ;; Last Update: 24 July 86 ;; ;; Filed As: {eris}cml>test>18-1-schar.test ;; NOTE: The contents of this file are a subset of {eris}cml>test>18-1-char.test with schar replacing char and tests on non-simple strings removed. ;; ;; Syntax: schar string index ;; ;; Function Description: Returns the character index positions (counting from 0) into string. ;; ;; Argument(s): string : any simple character string - i.e. any vector of type string-char with no displacement, no fill-pointer and no adjustability. ;; index : a non-negative integer less then the number of characters in the string. ;; ;; Returns: the character at index ;; (do-test-group (schar-group :before (progn (setq simple "This is a simple string." arraystring (make-array '(13) :element-type 'string-char :initial-contents '(#\S #\h #\o #\r #\t #\Space #\Linefeed #\s #\t #\r #\i #\n #\g)) twine (copy-seq "twine") ) ;setq (defun stringschar (string index character) (setq stringchar (schar string index)) (and (char= character stringchar) (string-char-p stringchar ) ) ) ;defun ) ;progn ) ;schar-group ;; (do-test schar-test (AND ;; The simplest case (stringschar simple 0 #\T) ;; See that it goes past a line-feed (stringschar simple 8 #\a) ;; See that is distinguishes upper from lower case (not (char= #\t (schar simple 0))) ;; See if the setf/char combination alters a string destructively. (setf (schar twine 0) #\s) (string= twine "swine") ;; See if it treats 1-dimensional character array as a string. (stringschar arraystring 12 #\g) ) ;and ) ;do-test ) ;do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQ.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQ.TEST new file mode 100644 index 00000000..a876b91f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string= ;; ;; Source: CLtL p. 300 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 27 July 86 ;; ;; Last Update: 11 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-eq.test ;; ;; ;; Syntax: string= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: Compares the 2 strings; returns the length of the common portion iff the corresponding characters of the substrings designated by the keywords are identical (i.e. are char=), nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string "characters" and the end-position 7, comparison stops with the letter "t". ;; ;; Returns: a length or nil, depending on the results of the comparison. ;; (do-test-group (string=-group :before (progn (test-setq simple1 ";; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string characters and the end-position 7, comparison stops with the letter t. ;; " ;;END SIMPLE1 DEFINITION ;; ;; Simple1 and Simple2 are the same length, but simple2 starts and ends 1 character later. ;; simple2 "; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string characters and the end-position 7, comparison stops with the letter t. ;; " ;; END SIMPLE2 DEFINITION length (length simple1) ) ; test-setq ) ;progn ) ; string=group ;; (do-test "check setups for string=-test" ;; Make sure the setup was right (AND (eq length (length simple2)) ;; The common portion of the strings is all but the end characters. (string= simple1 simple2 :start1 1 :end2 (- length 1)) (not (string= simple1 simple2)) ) ; AND ) ; do-test "check setups for string=-test" ;; (do-test "string= keywords test" ;; Use all 4 keywords, out of order. (string= simple2 simple1 :end2 (- length 1) :start1 1 :start2 2 :end1 (- length 2)) ) ; do-test "string= keywords test" ;; (do-test "string= with symbol-names" ;; Remember that the reader sees everything as upper-case. (and (string= (symbol-name '18-2-string-eq.test) "18-2-STRING-EQ.TEST") (not (string= (symbol-name '18-2-string-eq.test) "18-2-string-eq.test")) ) ; and ) ; do-test "string= with symbol-names" ;; (do-test "string= coerces symbols to strings" (and (every 'string= (list 'atom "atom" 'two\ lin\es (make-array 4 :initial-element #\q :element-type 'string-char)) (list "ATOM" '|atom| "TWO LINeS" '\q\q\q\q) ) (not (string= `|MIXED cASE| "MIXED CASE")) ) ; and ) ; do-test "string= coerces symbols to strings" ;; (do-test "string= with a simple array" (string= " " (make-array 10 :element-type 'string-char :initial-element #\newline)) ) ; do-test "string= with a simple array" ;; (do-test "string= with a non-simple array" ;; Not working 27 7; see AR 6190 (string= ";; ;" (make-array 4 :element-type 'string-char :adjustable t :fill-pointer t :displaced-to simple1)) ) ;do-test "string= with a non-simple array" ) ;do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQUAL.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQUAL.TEST new file mode 100644 index 00000000..e2a31638 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-equal ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 27 July 86 ;; ;; Last Update: 9 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-equal.test ;; ;; ;; Syntax: string-equal string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: Compares the 2 strings ignoring case differences; returns the length of the common portion of the keyword-delimited substrings iff their corresponding characters are identical (i.e. char-equal) but for case, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string "characters" and the end-position 7, comparison stops with the letter "t". ;; ;; Returns: a length or nil, depending on the results of the comparison. ;; END PREAMBLE START WORKING CODE ;; (do-test-group (string-equal-group :before (test-setq simple1 ";; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string \"characters\" and the end-position 7, comparison stops with the letter \"t\". ;; " ; END SIMPLE1 DEFINITION ;; ;; Simple1 and Simple2 are the same length, but simple2 starts and ends 1 character later. ;; simple2 "; ;; Function Description: Compares the 2 strings; returns t iff their corresponding characters are identical, nil otherwise. ;; ;; Argument(s): :start1, :start2: the start-comparison positions (counting from 0) in the respective strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string \"characters\" and the end-position 7, comparison stops with the letter \"t\". ;; " ; END SIMPLE2 DEFINITION ;; ;; Simple3 is simple2 with some letters capitalized. simple3 "; ;; FuNcTiOn DESCRIPTION: Compares the 2 STRINGS; returns T IFF their corresponding characters are identical, nil otherwise. ;; ;; Argument(S): :start1, :start2: the start-comparison positions (counting from 0) in the reSPECTive strings ;; :end1, :end2: the end-comparison positions + 1 (counting from 0) - i.e. comparison stops with the previous character; for the string \"characters\" and the end-position 7, comparISON Stops with the letter \"t\". ;; " ; END SIMPLE3 DEFINITION length (length simple1) arbitrary "llQ8uqk&Y1SlQ8upp" ) ; test-setq ) ; string-equal-group ;; (do-test "check string-equal setups" (AND ;; Don't bother unless I set things up right. (every #'(lambda (string) (= length (length string))) (list simple1 simple2)) (string-equal simple2 simple3) (string/= simple2 simple3) ;; The common portion of the strings is all but the end characters. What are string= are a fortiori string-equal. (string-equal simple1 simple2 :start1 1 :end2 (- length 1)) (string-not-equal simple1 simple3) ) ; and ) ; do-test "check string-equal setups" ;; (do-test "string-equal with a simple array" (string-equal " q " (make-array 11 :element-type 'string-char :initial-contents '( #\Newline #\Newline #\Newline #\Newline #\Newline #\q #\Newline #\Newline #\Newline #\Newline #\Newline))) ) ; do-test "string-equal with a simple array" ;; (do-test "string-equal with a non-simple array" ;; NOTE: Not working 27 7. See AR 6190 - can't displace to a string ;; The quoted portion starts on the 3rd character of simple1 - i.e. 2 if counting from 0. (string-equal " ;; f" (make-array 5 :element-type 'string-char :adjustable t :fill-pointer t :displaced-to simple1 :displaced-index-offset 2) ) ; string-equal ) ; do-test "string-equal with a non-simple array" ;; (do-test "string-equal ignores case differences, but string= doesn't" ;; With every corresponding letter of different case (and (string-equal arbitrary (make-array 15 :element-type 'string-char :initial-contents '( #\L #\L #\q #\8 #\U #\Q #\K #\& #\y #\1 #\s #\L #\q #\8 #\U)) :start1 0 :start2 0 :end2 13 :end1 13 ) ; string-equal ;; The same comparison for string= should fail. (not (string= arbitrary (make-array 15 :element-type 'string-char :initial-contents '( #\L #\L #\q #\8 #\U #\Q #\K #\& #\y #\1 #\s #\L #\q #\8 #\U)) :start1 0 :start2 0 :end2 13 :end1 13 ) ) ) ; and ) ; do-test "string-equal ignores case differences, but string= doesn't" ;; (do-test "string-equal coerces symbols to strings" (and (every 'string-equal (list 'atom 'Atom '|Mixed Case|) (list "ATOM" "ATOM" "mIXED cASE") ) (not (string-equal "Mixed Case" '|Mixed Case |)) ) ; and ) ; do-test "string-equal coerces symbols to strings" ;; (do-test "string-equal with a symbol-name" (string-equal (symbol-name 'simple3) "simple3") ) ;do-test "string-equal with a symbol-name" ;; (do-test "char-equal portability test" ;; The function should be portable - not contingent on keyboard layout. Upper- and lower-case numbers and punctuation should fail. (notany `string-equal '("\\" "1" "2" "3" "4" "5" "6" "7" "8" "9" "0" "-" "=" "[" "]" ";" "'" "`" "," "." "/" ) '("|" "!" "@" "#" "$" "%" "^" "&" "*" "(" ")" "_" "+" "{" "}" ":" "\"" "~" "<" ">" "?")) ) ;do-test "char-equal portability test" ) ;do-test group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GE.TEST new file mode 100644 index 00000000..8da811e9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string>= ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-ge.test ;; ;; ;; Syntax: string>= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>=). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string>=-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly>= (dotpair) "T iff the every character of the car of a dotted pair of strings is string>= every character of the cdr, nil otherwise." (= 0 (string>= (car dotpair) (cdr dotpair))) ) ) ;; (do-test "B-Z string>= A-Y, upper and lower case" (every 'strictly>= (list (cons (string-trim '(#\a) lowcase) (string-trim '(#\z) lowcase)) (cons (string-trim '(#\A) upcase) (string-trim '(#\Z) upcase)) ) ; list ) ) ; do-test "B-Z string>= A-Y, upper and lower case" ;; (do-test "string>= strings-strictly-outside-characters inequalities" (and (or (string>= "A" "9") (char<= #\0 #\Z)) (or (string>= "A" "9") (char<= #\0 #\z)) ) ) ; do-test ;; (do-test "string>= on the digits, using make-array" (strictly>= (cons (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) ) ) ) ;; (do-test "a string string>= itself" (every 'string>= (list upcase lowcase digits " ") (list upcase lowcase digits (make-array 2 :element-type 'string-char :initial-element #\newline)) ) ) ;; (do-test "string>= keywords" (and (string>= "123464" "12345" :end1 5) (string>= "12345" "55512345" :start2 3) (string>= "fghi" "abcdr" :end2 4) (string>= "55512345" "12345" :start1 3) (string>= "000000000" "000000001" :end1 8 :end2 8) (not (string>= "000000000" "000000001")) ) ) ;; (do-test "string>= is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string>= (make-array (1- longlength) :element-type 'string-char :initial-element letter) (make-array longlength :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GREATERP.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GREATERP.TEST new file mode 100644 index 00000000..3d4ee62e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-greaterp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-greaterp.test ;; ;; ;; Syntax: string-greaterp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string-greaterp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-greater (string1 string2) (eq 0 (string-greaterp string1 string2)) ) ) ; progn ;; (do-test "B...Z is string-greaterp A...Y; comparison is case-insensitive" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-greater (string-trim '(#\a) lowcase) (string-trim '(#\Z) upcase) ) (strictly-greater (string-trim '(#\A) upcase) (string-trim '(#\z) lowcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string-greaterp as for the character inequalities" (or (strictly-greater "9" "A" ) (strictly-greater "Z" "0" )) ) ;; (do-test "string-greaterp with digit strings created with make-array" (strictly-greater (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) ) ) ;; (do-test "a string is not string-greaterp itself" (every 'null (list (string-greaterp (make-array 2 :element-type 'string-char :initial-element #\Linefeed) " ") (string-greaterp upcase upcase) (string-greaterp upcase lowcase) ) ) ) ;; (do-test "string-greaterp coerces to symbol" (and (= 4 (string-greaterp 'b66643yz 'abc6660999xx :start1 1 :end1 5 :start2 3 :end2 7)) ) ) ; do-test "string-greaterp coerces to symbol" ;; (do-test "string-greaterp stops as soon as it finds a nil comparison" (and (= (1- diglength) (string-greaterp digits "0123456788")) (= 3 (string-greaterp "0124456789" digits)) ) ) ;; (do-test "string-greaterp keywords" (and (string-greaterp "vwxyz" "ZSTUVW" :start2 1) (string-greaterp "XYZbcd" "ABC" :start1 3) (string-greaterp "012012" "0123456" :end2 3) (string-greaterp "lmnABC" "abc" :end1 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GT.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GT.TEST new file mode 100644 index 00000000..ce920762 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-GT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string> ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 10 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-gt.test ;; ;; ;; Syntax: string> string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string>-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-greater (string1 string2) (eq 0 (string> string1 string2)) ) ) ; progn ;; (do-test "B...Z is string> A...Y in upper and lower case" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-greater (string-trim '(#\A) upcase) (string-trim '(#\Z) upcase) ) (strictly-greater (string-trim '(#\a) lowcase) (string-trim '(#\z) lowcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string> as for the character inequalities" (and (or (strictly-greater "9" "A" ) (strictly-greater "Z" "0" )) (or (strictly-greater "9" "a" ) (strictly-greater "z" "0" )) ) ) ;; (do-test "string> with digit strings created with make-array" (strictly-greater (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) ) ) ;; (do-test "a string is not string> itself" (every 'null (list (string> (make-array 2 :element-type 'string-char :initial-element #\Linefeed) " ") (string> upcase upcase) ) ) ) ;; (do-test "string> coerces to symbol" (and (= 4 (string> 'b66643yz 'abc6660999xx :start1 1 :end1 5 :start2 3 :end2 7)) ) ) ; do-test "string> coerces to symbol" ;; (do-test "string> stops as soon as it finds a nil comparison" (and (= (1- diglength) (string> digits "0123456788")) (= 3 (string> "0124456789" digits)) ) ) ;; (do-test "string> keywords" (and (string> "vwxyz" "zstuvw" :start2 1) (string> "XYZBCD" "ABC" :start1 3) (string> "012012" "0123456" :end2 3) (string> "lmnABC" "abc" :end1 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LE.TEST new file mode 100644 index 00000000..4297f1e2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string<= ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-le.test ;; ;; ;; Syntax: string<= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char<=). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char<=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string<=-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly<= (dotpair) "T iff the every character of the car of a dotted pair of strings is string <= every character of the cdr, nil otherwise." (= 0 (string<= (car dotpair) (cdr dotpair))) ) ) ;; (do-test "A-Y string<= B-Z, upper and lower case" ;; In upper or lower case, the characters a-y should all <= b-z. (every 'strictly<= (list (cons (string-trim '(#\z) lowcase) (string-trim '(#\a) lowcase)) (cons (string-trim '(#\Z) upcase) (string-trim '(#\A) upcase)) ) ; list ) ) ; do-test "A-Y string<= B-Z, upper and lower case" ;; (do-test "string<= strings-strictly-outside-characters inequalities" (and (or (string<= "9" "A" ) (char<= #\Z #\0 )) (or (string<= "9" "A" ) (char<= #\z #\0 )) ) ) ; do-test ;; (do-test "string<= on the digits, using make-array" (strictly<= (cons (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ) ) ;; (do-test "a string string<= itself" (every 'string<= (list upcase lowcase digits " ") (list upcase lowcase digits (make-array 2 :element-type 'string-char :initial-element #\newline)) ) ) ;; (do-test "string<= keywords" (and (string<= "12345" "123464" :end2 5) (string<= "55512345" "12345" :start1 3) (string<= "abcdr" "fghi" :end1 4) (string<= "12345" "55512345" :start2 3) (string<= "000000001" "000000000" :end1 8 :end2 8) (not (string<= "000000001" "000000000")) ) ) ;; (do-test "string<= is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string<= (make-array longlength :element-type 'string-char :initial-element letter) (make-array (1- longlength) :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LESSP.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LESSP.TEST new file mode 100644 index 00000000..c5b91b3f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-lessp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-lessp.test ;; ;; ;; Syntax: string-lessp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string-lessp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-less (string1 string2) (eq 0 (string-lessp string1 string2)) ) ) ; progn ;; (do-test "A...Y is string-lessp B...Z;comparison is case-insensitive" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-less (string-trim '(#\Z) upcase) (string-trim '(#\a) lowcase) ) (strictly-less (string-trim '(#\z) lowcase) (string-trim '(#\A) upcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string-lessp as for the character inequalities" (or (strictly-less "9" "A" ) (strictly-less "Z" "0" )) ) ;; (do-test "string-lessp with digit strings created with make-array" (strictly-less (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) ) ) ;; (do-test "a string is not string-lessp itself" (every 'null (list (string-lessp (make-array 2 :element-type 'string-char :initial-element #\newline) " ") (string-lessp upcase upcase) (string-lessp upcase lowcase) ) ) ) ;; (do-test "string-lessp stops as soon as it finds a nil comparison" (and (= (1- diglength) (string-lessp "0123456788" digits)) (= 3 (string-lessp digits "0124456789")) ) ) ;; (do-test "string-lessp keywords" (and (string-lessp "zSTuvw" "vwxyZ" :start1 1) (string-lessp "ABC" "XYzbcD" :start2 3) (string-lessp "0123456" "012012" :end1 3) (string-lessp "abc" "lMnABC" :end2 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LT.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LT.TEST new file mode 100644 index 00000000..2b525511 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-LT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string< ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 10 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-lt.test ;; ;; ;; Syntax: string< string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string<-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) ) (test-defun strictly-less (string1 string2) (eq 0 (string< string1 string2)) ) ) ; progn ;; (do-test "A...Y is string< B...Z in upper and lower case" (AND (= (length lowcase) alphalength) ; make sure I set things up right (strictly-less (string-trim '(#\Z) upcase) (string-trim '(#\A) upcase) ) (strictly-less (string-trim '(#\z) lowcase) (string-trim '(#\a) lowcase) ) ) ) ;; (do-test "digits and alpha characters are strictly outside each other for string< as for the character inequalities" (and (or (strictly-less "9" "A" ) (strictly-less "Z" "0" )) (or (strictly-less "9" "a" ) (strictly-less "z" "0" )) ) ) ;; (do-test "string< with digit strings created with make-array" (strictly-less (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim `(#\9) digits)) (make-array (1- diglength) :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :element-type 'string-char) ) ) ;; (do-test "a string is not string< itself" (every 'null (list (string< (make-array 2 :element-type 'string-char :initial-element #\newline) " ") (string< upcase upcase) ) ) ) ;; (do-test "string< stops as soon as it finds a nil comparison" (and (= (1- diglength) (string< "0123456788" digits)) (= 3 (string< digits "0124456789")) ) ) ;; (do-test "string< keywords" (and (string< "zstuvw" "vwxyz" :start1 1) (string< "ABC" "XYZBCD" :start2 3) (string< "0123456" "012012" :end1 3) (string< "abc" "lmnABC" :end2 3) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NEQ.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NEQ.TEST new file mode 100644 index 00000000..a0072a97 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NEQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string/= ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 24 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-neq.test ;; ;; ;; Syntax: string/= string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char/=). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char/=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string/=-group :before (progn (test-setq longstring "paring string with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char/=: the index (counting from 0) of the first non-identical chara" ;; END LONGSTRING DEFINITION ) ) (do-test string/=-test (AND ;; Change just one character from upper to lower case; the predicate should hold. (let ((string2 (copy-seq longstring))) (replace string2 "P" :end 0) (string/= longstring string2) ) ;; A string shouldn't be unequal to itself (not (string/= longstring longstring)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-EQUAL.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-EQUAL.TEST new file mode 100644 index 00000000..fdf82187 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-not-equal ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-2-string-not-equal.test ;; ;; ;; Syntax: string-not-equal string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char-not-equal). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char/=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that satisfies the predicate. ;; If not: nil ;; (do-test-group string-not-equal-group :before (progn (test-setq longstring "paring string with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char-not-equal: the index (counting from 0) of the first non-identical chara" ;; END LONGSTRING DEFINITION ) ) (do-test string-not-equal-test (AND ;; Change just one character; the predicate should hold. (let ((string2 (copy-seq longstring))) (replace string2 "?" :end 0) (string-not-equal longstring string2) ) ;; A string shouldn't be unequal to itself (not (string-not-equal (string-upcase longstring) (string-downcase longstring))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-GREATERP.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-GREATERP.TEST new file mode 100644 index 00000000..2b8d445a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-GREATERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-not-greaterp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-le.test ;; ;; ;; Syntax: string-not-greaterp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char-not-greaterp). ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char<=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string-not-greaterp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly-not-greaterp (dotpair) "T iff the every character of the car of a dotted pair of strings is string <= every character of the cdr, nil otherwise." (= 0 (string-not-greaterp (car dotpair) (cdr dotpair))) ) ) ;; (do-test "A-Y string-not-greaterp B-Z, upper and lower case; comparison is case-insensitive" (every 'strictly-not-greaterp (list (cons (string-trim '(#\Z) upcase) (string-trim '(#\a) lowcase)) (cons (string-trim '(#\z) lowcase) (string-trim '(#\A) upcase)) ) ; list ) ) ; do-test "A-Y string-not-greaterp B-Z, upper and lower case" ;; (do-test "string-not-greaterp strings-strictly-outside-characters inequalities" (or (string-not-greaterp "9" "A" ) (char<= #\Z #\0 )) ) ; do-test ;; (do-test "string-not-greaterp on the digits, using make-array" (strictly-not-greaterp (cons (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ) ) ;; (do-test "a string is string-not-greaterp itself" (every 'string-not-greaterp (list lowcase upcase digits " " '|this is a test|) (list upcase lowcase digits (make-array 2 :element-type 'string-char :initial-element #\newline '|THIS IS A TEST|)) ) ) ;; (do-test "string-not-greaterp keywords" (and (string-not-greaterp "12345" "123464" :end2 5) (string-not-greaterp "55512345" "12345" :start1 3) (string-not-greaterp "aBCDR" "fghi" :end1 4) (string-not-greaterp "12345" "55512345" :start2 3) (string-not-greaterp "000000001" "000000000" :end1 8 :end2 8) (not (string-not-greaterp "000000001" "000000000")) ) ) ;; (do-test "string-not-greaterp is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string-not-greaterp (make-array longlength :element-type 'string-char :initial-element letter) (make-array (1- longlength) :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-LESSP.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-LESSP.TEST new file mode 100644 index 00000000..ef6d5eed --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-2-STRING-NOT-LESSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-not-lessp ;; ;; Source: CLtL p. 301 ;; Chapter 18: Strings Section 2: String Comparison ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}<=lispcore>cml>test>18-2-string-not-lessp.test ;; ;; ;; Syntax: string-not-lessp string1 string2 &key :start1 :end1 :start2 :end2 ;; ;; Function Description: The function compares the respective strings (with the keywords for the respective strings counting from 0 and the :end keywords designating the character after the last compared) lexicographically (i.e. it compares the corresponding characters by the function char>=). Comparison is case-insensitive. ;; ;; Argument(s): string1, string2: character strings ;; :start1, start2: the start-comparison position in the respective strings (counting from 0) ;; :end1, end2: the last character + 1 (counting from 0) to compare - i.e. if comparing "string" with a :end keyword of 4, the last character compared will be the letter i. ;; ;; Returns: If all characters satisfy char>=: the index (counting from 0) of the first non-identical character - i.e. the length of the portion of the strings that is string=. ;; If not: nil ;; (do-test-group string-not-lessp-group :before (progn (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase "abcdefghijklmnopqrstuvwxyz" alphalength (length upcase) digits "0123456789" diglength (length digits) longstring (concatenate 'string upcase lowcase digits) longlength (length longstring) longindex (1+ (random (1- longlength))) ) (test-defun strictly-not-lessp (dotpair) "T iff the every character of the car of a dotted pair of strings is string-not-lessp every character of the cdr, nil otherwise." (= 0 (string-not-lessp (car dotpair) (cdr dotpair))) ) ) ;; (do-test "B-Z string-not-lessp A-Y; comparison is case-insensitive." (every 'strictly-not-lessp (list (cons (string-trim '(#\a) lowcase) (string-trim '(#\Z) upcase)) (cons (string-trim '(#\A) upcase) (string-trim '(#\z) lowcase)) ) ; list ) ) ; do-test "B-Z string-not-lessp A-Y; comparison is case-insensitive." ;; (do-test "string-not-lessp strings-strictly-outside-characters inequalities" (and (or (string-not-lessp "a" "9") (char<= #\0 #\Z)) (or (string-not-lessp "A" "9") (char<= #\0 #\z)) ) ) ; do-test ;; (do-test "string-not-lessp on the digits, using make-array" (strictly-not-lessp (cons (make-array (1- diglength) :element-type 'string-char :initial-contents '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (make-array (1- diglength) :element-type 'string-char :fill-pointer t :adjustable t :displaced-to (string-trim '(#\9) digits)) ) ) ) ;; (do-test "a string string-not-lessp itself" (every 'string-not-lessp (list upcase lowcase digits " ") (list lowcase upcase digits (make-array 2 :element-type 'string-char :initial-element #\newline)) ) ) ;; (do-test "string-not-lessp keywords" (and (string-not-lessp '|123464| '\1\2\3\4\5 :end1 5) (string-not-lessp "12345" "55512345" :start2 3) (string-not-lessp "fghi" "ABCDR" :end2 4) (string-not-lessp "55512345" "12345" :start1 3) (string-not-lessp "000000000" "000000001" :end1 8 :end2 8) (not (string-not-lessp "000000000" "000000001")) ) ) ;; (do-test "string-not-lessp is nil for string of unequal length" (let ((letter (elt longstring longindex))) (not (string-not-lessp (make-array (1- longlength) :element-type 'string-char :initial-element letter) (make-array longlength :element-type 'string-char :initial-element letter) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-MAKE-STRING.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-MAKE-STRING.TEST new file mode 100644 index 00000000..ed283579 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-MAKE-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-string ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-make-string.test ;; ;; ;; Syntax: make-string size &key :initial-element ;; ;; Function Description: Create a simple string of length size with each position initialized to :initial-element ;; ;; Argument(s): size - a positive integer ;; :initial-element - a character (default: #\null) ;; ;; Returns: a simple string. ;; (do-test-group make-string-group :before (test-setq charQ #\Q q100 (make-string 100 :initial-element charQ)) (do-test make-string-test (AND (stringp q100) (eq 5 (length(make-string 5))) (eq 100 (length q100)) (char= #\Q (char q100 99)) (char= #\Null (char (make-string 35) 34)) (string= (make-string 20 :initial-element #\6) '\12345666666666666666666666654332 :start2 5 :end2 25) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-CAPITALIZE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-CAPITALIZE.TEST new file mode 100644 index 00000000..b99edf24 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-CAPITALIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nstring-capitalize ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-nstring-capitalize.test ;; ;; ;; Syntax: string &key :start :end ;; ;; Function Description: convert the first letter of each word in string from :start :to :end to upper case. Counting for :start and :end starts from 0. A word is a consecutive subsequence of characters having at each end either a non-alphanumeric character or an end of the string. ;; ;; Argument(s): string - a valid character string ;; :start, :end - the first and last+1 characters to be modified. ;; ;; Returns: string, modified as described. ;; (do-test-group nstring-capitalize-group :before (test-setq testcase "word word\\word|word!word@word#word$word%word^word^word*word(word)word-word_word= word+word[word{word]word}word;word:word'word\"word`word~word,wordword/word?" testcase2 testcase stablecase (copy-seq testcase) digits "9 8 7 6 5 4 3 2 1 0" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test nstring-capitalize-test (AND (string= testcase stablecase) ; for future comparison ;; The result is one and the same string (eq testcase (nstring-capitalize testcase)) ;; ... yet with different contents. (not (string= testcase stablecase)) (string-equal testcase stablecase) ;; A pointer to the changed string points to the new contents. (string= testcase2 "Word Word\\Word|Word!Word@Word#Word$Word%Word^Word^Word*Word(Word)Word-Word_Word= Word+Word[Word{Word]Word}Word;Word:Word'Word\"Word`Word~Word,WordWord/Word?") ;; Results should be the same length regardless of keywords. (= (length testcase) (length (nstring-capitalize testcase :start (random 10) :end (+ 10 (random 20)) ) ) ) ;; Within the :start-:end portion, skip over the non-alphanumeric characters. (string= (nstring-capitalize "ab cdefg\"hijklmnop" :end 9 :start 2) "ab Cdefg\"hijklmnop") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-DOWNCASE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-DOWNCASE.TEST new file mode 100644 index 00000000..d8339999 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-DOWNCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nstring-downcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-nstring-downcase.test ;; ;; ;; Syntax: nstring-downcase string &key :start :end ;; ;; Function Description: converts all upper case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to lower case, destructively modifying string. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: a string of the same length with the specified conversions. ;; (do-test-group nstring-downcase-group :before (test-setq testcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" testcase2 testcase stablecase (copy-seq testcase) alphalength (length testcase) digits "0123456789" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./" ) ;; (do-test nstring-downcase-test (AND ;; The result is one and the same string (eq testcase (nstring-downcase testcase)) ;; ... yet with different contents. (not (string= testcase stablecase)) (string-equal testcase stablecase) ;; A pointer to the changed string points to the new contents. (string= testcase2 "abcdefghijklmnopqrstuvwxyz") ;; Numeric characters, punctuation marks and non-string characters have no lower case. (string= digits (nstring-downcase digits)) (string= punc (nstring-downcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (nstring-downcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6 ) ) ;; Results should be the same length regardless of keywords. (= alphalength (length (nstring-downcase stablecase :end 20 :start 10))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-UPCASE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-UPCASE.TEST new file mode 100644 index 00000000..fe140aa0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-NSTRING-UPCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: nstring-upcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-nstring-upcase.test ;; ;; ;; Syntax: nstring-upcase string &key :start :end ;; ;; Function Description: converts all lower case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to upper case, destructively modifying string. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: string with the specified conversions. ;; (do-test-group nstring-upcase-group :before (test-setq testcase "abcdefghijklmnopqrstuvwxyz" testcase2 testcase stablecase (copy-seq testcase) alphalength (length testcase) digits "0123456789" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test nstring-upcase-test (AND ;; The result is one and the same string (eq testcase (nstring-upcase testcase)) ;; ... yet with different contents. (not (string= testcase stablecase)) (string-equal testcase stablecase) ;; A pointer to the changed string points to the new contents. (string= testcase2 "ABCDEFGHIJKLMNOPQRSTUVWXYZ") ;; Numeric characters, punctuation marks and non-string characters have no upper case. (string= digits (nstring-upcase digits)) (string= punc (nstring-upcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (nstring-upcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6) ) ;; Results should be the same length regardless of keywords. (= alphalength (length (nstring-upcase stablecase :end 20 :start 10))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-CAPITALIZE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-CAPITALIZE.TEST new file mode 100644 index 00000000..054552f4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-CAPITALIZE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-capitalize ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-capitalize.test ;; ;; ;; Syntax: string &key :start :end ;; ;; Function Description: convert the first letter of each word in string from :start :to :end to upper case. Counting for :start and :end starts from 0. A word is a consecutive subsequence of characters having at each end either a non-alphanumeric character or an end of the string. ;; ;; Argument(s): string - a valid character string ;; :start, :end - the first and last+1 characters to be modified. ;; ;; Returns: the modified string ;; (do-test-group string-capitalize-group :before (test-setq testcase "word word\\word|word!word@word#word$word%word^word^word*word(word)word-word_word= word+word[word{word]word}word;word:word'word\"word`word~word,wordword/word?" digits '9\ 8\ 7\ 6\ 5\ 4\ 3\ 2\ 1\ 0 punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test string-capitalize-test (AND (string-equal testcase (string-capitalize testcase)) (= (length testcase)(length (string-capitalize testcase))) ;; Within the :start-:end portion, skip over the non-alphanumeric characters. (string= (string-capitalize '|ab cdefg"hijklmnop| :end 9 :start 2) "ab Cdefg\"hijklmnop") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-DOWNCASE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-DOWNCASE.TEST new file mode 100644 index 00000000..b58d570e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-DOWNCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-downcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-downcase.test ;; ;; ;; Syntax: string-downcase string &key :start :end ;; ;; Function Description: converts all upper case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to lower case. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: a string of the same length with the specified conversions. ;; (do-test-group string-downcase-group :before (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase '|abcdefghijklmnopqrstuvwxyz| alphalength (length upcase) digits "0123456789" punc "|\\!@#$%^&*()_+-={}[]:\"~<>?,./ ") ;; (do-test string-downcase-test (AND (string= lowcase (string-downcase upcase)) (string= lowcase (string-downcase lowcase)) ;; Numeric characters, punctuation marks and non-string characters have no lower case. (string= digits (string-downcase digits)) (string= punc (string-downcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (string-downcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6 ) ) ;; Results should be the same length regardless of keywords. (string-equal lowcase (string-downcase upcase :end 20 :start 10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-LEFT-TRIM.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-LEFT-TRIM.TEST new file mode 100644 index 00000000..7452492e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-LEFT-TRIM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-left-trim ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-left-trim.test ;; ;; ;; Syntax: string-left-trim character-bag string ;; ;; Function Description: starting from the left end of string and moving rightward, the function removes all occurrences of any characters found in character-bag until it encounters a character not in character-bag. ;; ;; Argument(s): character-bag - a list of characters of type string-char ;; string - any valid character string ;; ;; Returns: the substring of string consisting of string with the elements of character-bag removed as described; if the function trimmed no characters, the result is string= to string (but not eq in the Xerox implementation). ;; (do-test-group string-left-trim-group :before (test-setq upcase '|ABCDEFGHIJKLMNOPQRSTUVWXYZ| lowcase '|abcdefghijklmnopqrstuvwxyz| digits '\0\1\2\3\4\5\6\7\8\9) ;; (do-test "string-left-trim stops when it encounters something not in character-bag" ;; In this case, D should not get trimmed. (string= (string-left-trim '(#\A #\B #\W #\Z #\Y #\D) upcase) "CDEFGHIJKLMNOPQRSTUVWXYZ") ) ; do-test ;; (do-test "string-left-trim can trim off the entire string and to accept redundant characters" (and (string= (string-left-trim '(#\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\2 #\1 #\0) digits) "") (string= (string-left-trim '(#\5) (make-string 5 :initial-element #\5)) "") ) ) ;; (do-test "string-left-trim is case-sensitive" (and (string= lowcase (string-left-trim '(#\A #\B #\C) lowcase)) (string= upcase (string-left-trim '(#\a #\b #\c) upcase)) ) ) ;; (do-test "string-left-trim accepts non-standard characters" (string= (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed) 'string) (string-left-trim '(#\G #\Page #\Tab #\Backspace) (coerce '(#\Backspace #\G #\Linefeed #\linefeed #\Return #\Linefeed) 'string) ) ) ) ;; (do-test "string-left-trim character-bag need not be all characters" (and (string= digits (string-left-trim '(50 '('(5 10) '(15 20)) "Alexis is a bitch") digits)) (string= "23456789" (string-left-trim '(50 #\1'('(5 10) '(15 20)) "Alexis is a bitch" #\0) digits)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-RIGHT-TRIM.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-RIGHT-TRIM.TEST new file mode 100644 index 00000000..2b83dfce --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-RIGHT-TRIM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-right-trim ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-right-trim.test ;; ;; ;; Syntax: string-right-trim character-bag string ;; ;; Function Description: starting from the right end of string and moving leftward, the function removes all occurrences of any characters found in character-bag until it encounters a character not in character-bag. ;; ;; Argument(s): character-bag - a list of characters of type string-char ;; string - any valid character string ;; ;; Returns: the substring of string consisting of string with the elements of character-bag removed as described; if the function trimmed no characters, the result is string= to string (but not eq in the Xerox implementation). ;; (do-test-group string-right-trim-group :before (test-setq upcase '|ABCDEFGHIJKLMNOPQRSTUVWXYZ| lowcase '|abcdefghijklmnopqrstuvwxyz| digits "0123456789") ;; (do-test "string-right-trim stops when it encounters something not in character-bag" ;; In this case, W should not get trimmed. (string= (string-right-trim '(#\A #\B #\W #\Z #\Y #\D) upcase) "ABCDEFGHIJKLMNOPQRSTUVWX") ) ;; (do-test "string-right-trim can trim off the entire string and accept redundant characters" (and (string= (string-right-trim '(#\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\2 #\1 #\0) digits) "") (string= (string-right-trim '(#\5) (make-string 5 :initial-element #\5)) "") ) ) ;; (do-test "string-right-trim is case-sensitive" (and (not (string= lowcase (string-right-trim '(#\x #\y #\z) lowcase))) (string= upcase (string-right-trim '(#\x #\y #\z) upcase)) ) ) ;; (do-test "string-right-trim accepts semi-standard characters" (string= (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed) 'string) (string-right-trim '(#\G #\Page #\Tab) (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed #\Tab #\Page) 'string) ) ) ) ;; (do-test "string-right-trim character-bag need not be all characters" (and (string= digits (string-right-trim '(50 '('(5 10) '(15 20)) |Alexis is a bitch|) digits)) (string= "0123456789" (string-right-trim '(50 #\1'('(5 10) '(15 20)) '|Alexis is a bitch| #\0) digits)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-TRIM.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-TRIM.TEST new file mode 100644 index 00000000..8c606cf4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-TRIM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-trim ;; ;; Source: CLtL p. 302 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-trim.test ;; ;; ;; Syntax: string-trim character-bag string ;; ;; Function Description: starting from both ends of string and moving inward, the function removes all occurrences of any characters found in character-bag until it encounters a character not in character-bag. ;; ;; Argument(s): character-bag - a list of characters of type string-char ;; string - any valid character string ;; ;; Returns: the substring of string consisting of string with the elements of character-bag removed as described; if the function trimmed no characters, the result is string= to string (but not eq in the Xerox implementation). ;; (do-test-group string-trim-group :before (test-setq upcase '|ABCDEFGHIJKLMNOPQRSTUVWXYZ| lowcase '|abcdefghijklmnopqrstuvwxyz| digits '\0\1\2\3\4\5\6\7\8\9) ;; (do-test "string-trim stops when it encounters a character not in character-bag" ;;In this case, W and D should not get trimmed. (string= (string-trim '(#\A #\B #\W #\Z #\Y #\D) upcase) "CDEFGHIJKLMNOPQRSTUVWX") ) ;do-test ;; (do-test "string-trim can trim off the entire string and accept redundant characters" (and (string= (string-trim '(#\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\2 #\1 #\0) digits) "") (string= (string-trim '(#\5) (make-string 5 :initial-element #\5)) "") ) ; and ) ; do-test ;; (do-test "string-trim is case-sensitive" (and (string= lowcase (string-trim '(#\A #\B #\C) lowcase)) (string= upcase (string-trim '(#\x #\y #\z) upcase)) ) ; and ) ; do-test ;; (do-test "string-trim accepts semi-standard characters" (string= (coerce '(#\Linefeed #\linefeed #\Return #\Linefeed) 'string) (string-trim '(#\G #\Page #\Tab #\Backspace) (coerce '(#\Backspace #\G #\Linefeed #\linefeed #\Return #\Linefeed #\Tab #\Page #\Backspace) 'string) ) ; string-trim ) ; string= ) ; do-test ;; (do-test "string-trim character-bag need not be all characters" (and (string= digits (string-trim '(50 '('(5 10) '(15 20)) "Alexis is a bitch") digits)) (string= (symbol-name '|23456789|) (string-trim '(50 #\1'('(5 10) '(15 20)) "Alexis is a bitch" #\0) digits)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-UPCASE.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-UPCASE.TEST new file mode 100644 index 00000000..16797e06 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING-UPCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string-upcase ;; ;; Source: CLtL p. 303 ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string-upcase.test ;; ;; ;; Syntax: string-upcase string &key :start :end ;; ;; Function Description: converts all lower case characters in string from :start to :end (counting from 0, with :end the character after the last to be converted) to upper case. ;; ;; Argument(s): string - any valid character string ;; :start, :end - the first and last+1 characters (counting from 0) in string to be converted. ;; ;; Returns: a string of the same length with the specified conversions. ;; (do-test-group string-upcase-group :before (test-setq upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" lowcase '|abcdefghijklmnopqrstuvwxyz| alphalength (length upcase) digits "0123456789" punc "|\\!@#$%^ &*()_+-={}[]:\"~<>?,./") ;; (do-test string-upcase-test (AND (string= upcase (string-upcase lowcase)) (string= upcase (string-upcase upcase)) ;; Numeric characters, punctuation marks and non-string characters have no upper case. (string= digits (string-upcase digits)) (string= punc (string-upcase punc)) (string= (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) (string-upcase (coerce '(#\linefeed #\page #\tab #\return #\rubout #\backspace #\page) 'string) :start 0 :end 6) ) ; string= ;; Results should be the same length regardless of keywords. (string-equal upcase (string-upcase lowcase :end 20 :start 10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING.TEST b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING.TEST new file mode 100644 index 00000000..98281d43 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: string ;; ;; Source: CLtL p. ;; Chapter 18: Strings Section 3: String Construction and Manipulation ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 23 July 86 ;; ;; Last Update: 14 December 86 ;; ;; Filed As: {eris}cml>test>18-3-string.test ;; ;; ;; Syntax: string x ;; ;; Function Description: makes a string of x if x is an appropriate object; signals an error otherwise. ;; ;; Argument(s): x - a string, a symbol or a character ;; ;; Returns: - if x is a string: x ;; - if x is a symbol: the printname of x ;; - if x is a character: a 1-character string consisting of the character ;; (do-test-group string-group :before (test-setq longstring "23 July 86 ;; ;; Filed As: {eris}cml>test>18-3-string.test ;; ;; ;; Syntax: string x ;; ;; Function Description: makes a string of x if x is an appropriate object; signals an error otherwise. ;; " ; END LONGSTRING DEFINITION oddstring (coerce '(#\3 #\- #\page) 'string) ) ; test-setq ;; (do-test "string returns itself if its argument is a string" (every #'(lambda (string) (and (string= string (string string)) (eq string (string string)) ) ) ;; NOTE: not working 14 12; eq doesn't hold. See AR 7066. (list longstring oddstring (make-array 5 :element-type 'string-char :initial-element #\1) (make-string 30) ) ) ) ;; (do-test "string returns the symbol-name of a symbol" (every #'(lambda (string) (string= (symbol-name string) (string string) ) ) '(sym \1 |This is a symbol.| nil) ) ) ;; (do-test "string returns a string if x is a character" (and (string= "1" (string #\1 #\2)) (string= (string #\page) (make-string 1 :initial-element #\page)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST b/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST new file mode 100644 index 00000000..81539c3a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: defstruct ;; ;; Source: Common Lisp the Language by Guy Steele ;; Section 19: Structures, page 305 ;; ;; Created By: John Park Reviewed by Peter Reidy (as a brief test of main features ;; already implemented 7 aug.) ;; ;; Creation Date: Aug 5, 86 ;; ;; Last Update: April 9, 86 (CSW) ;; ;; History: Added regression tests thru lyric patch 4 (CW) ;; ;; Filed as: {eris}cml>test>19-defstruct.test ;; ;; Syntax: (defstruct name-and-options [doc-string] {slot-description}+) ;; ;; Function Description: This function defines a record-structure data type. ;; A general call to defstruct looks like the following: ;; (defstruct (name option-1 option-2 ...) ;; doc-string ;; slot-description-1 ;; slot-description-2 ;; ....) ;; ;; Argument(s): ;; Name: must be a symbol; it becomes the name of a new data type ;; consisting of all instances of the structure. The name is ;; returned as the value of the defstruct form. ;; Doc-String: This is attached to the name as a documentation ;; string of type structure. ;; Slot-description-j: Each slot-description-j is of the form ;; (slot-name default-init ;; slot-option-name-1 slot-option-value-1 ;; slot-option-name-2 slot-option-value-2 ;; ......) ;; Returns: The value of the defstruct form. ;; ;; Constraints/limitations: Defstruct options "initial-offset", and "type" ;; (vector), are not implemented as of Aug 7, 86. ;; Comments: ;; ;; Test Case I (simple-defstruct-test): This test checks for data-type of a created ;; structure, make and copy functions, and resetting of the structure components. ;; ;; Test Case II (slot-option-test): This test determines if defstruct slot options ;; can be specified ;; Test Case III: This test determines if each of the options can be given to ;; defstruct. Options include conc-name, constructor, copier, predicate, include, ;; print-function, type, named, and initial-offset. (do-test-group ("defstruct-test-setup" :before (progn (setq ship-test-case-1 (defstruct ship x-position y-position x-velocity y-velocity mass)) (setq ship-1 (make-ship)) (setq ship-2 (make-ship :x-position 10 :y-position 0 :x-velocity 54 :y-velocity 99)) (setq ship-3 (copy-ship ship-2)) (setq ship-4 (make-ship :x-position 100 :y-position 1)) (setq *default-ship-mass* 777.0) (setq test-case-2 (defstruct new-ship (x-position 0.0 :type short-float) (y-position 0.0 :type short-float) (x-velocity 0 :type fixnum) (y-velocity 0 :type fixnum) (mass *default-ship-mass* :type short-float :read-only t))) (setq new-ship-1 (make-new-ship :x-position 10.9 :y-position 222.99 :x-velocity 50 :y-velocity 100 :mass *default-ship-mass*)))) (do-test "simple-defstruct-test" (and (typep ship-1 'ship) (ship-p ship-1) (eq ship-test-case-1 'ship) (eq (ship-x-position ship-2) 10) (eq (ship-y-position ship-2) 0) (eq (ship-x-velocity ship-2) 54) (eq (ship-y-velocity ship-2) 99) (eq (ship-mass ship-2) nil) (eq (ship-x-position ship-3) 10) (eq (ship-y-position ship-3) 0) (eq (ship-x-velocity ship-3) 54) (eq (ship-y-velocity ship-3) 99) (eq (ship-mass ship-3) nil) (eq (ship-x-position ship-4) 100) (eq (ship-y-position ship-4) 1) (eq (ship-x-velocity ship-4) nil) (eq (ship-y-velocity ship-4) nil) (eq (ship-mass ship-4) nil) (setf (ship-x-position ship-3) 0) (eq (ship-x-position ship-3) 0))) (do-test "slot-option-test" (and (new-ship-p new-ship-1) (typep (new-ship-x-position new-ship-1) 'short-float) (typep (new-ship-y-position new-ship-1) 'short-float) (typep (new-ship-x-velocity new-ship-1) 'fixnum) (typep (new-ship-y-velocity new-ship-1) 'fixnum) (typep (new-ship-mass new-ship-1) 'single-float) (setf (new-ship-x-position new-ship-1) 100.0) (eql (new-ship-mass new-ship-1) *default-ship-mass*) (typep (new-ship-y-position new-ship-1) 'short-float))) (do-test "conc-name-option-test" (and (defstruct (employer (:conc-name manager-)) name age sex) (setq new-employer (make-employer :name 'smith :age 40 :sex 'm)) (eq (manager-name new-employer) 'smith) (eq (manager-age new-employer) 40) (eq (manager-sex new-employer) 'm))) (do-test "constructor-option-test" (and (defstruct auto engine body) (fboundp 'make-auto) (defstruct (auto (:constructor build-auto)) engine body) (fboundp 'build-auto) (setq new-auto (build-auto :engine '8cyl :body 'convert)) (eq (auto-engine new-auto) '8cyl) (defstruct (auto (:constructor design-auto)) engine body) (fboundp 'design-auto) )) (do-test "copier-option-test" (and (defstruct (truck (:copier duplicate-truck)) engine body) (setq prototype (make-truck :engine '16cyl :body 'wide)) (setq new-truck (duplicate-truck prototype)) (eq (truck-engine new-truck) '16cyl) (eq (truck-body new-truck) 'wide) (defstruct (sports-car (:copier nil)) engine body) (not (fboundp 'copy-sports-car)) )) (do-test "predicate-option-test" (and (defstruct (tools (:predicate is-tool?)) name size direction) (setq tool1 (make-tools)) (is-tool? tool1))) (do-test "include-option-test" (and (defstruct person name age sex) (defstruct (astronaut (:include person) (:conc-name astro-)) helmet-size (favorite-beverage 'tang)) (setq astro-1 (make-astronaut :name 'buzz :age 47 :sex 'm :helmet-size 17.5)) (eq (person-name astro-1) 'buzz) (eq (astro-name astro-1) 'buzz) (eq (astro-age astro-1) 47) (eq (astro-sex astro-1) 'm) (equalp (astro-helmet-size astro-1) 17.5) (eq (astro-favorite-beverage astro-1) 'tang))) (do-test "print-function-option-test" (and (defstruct (numbers (:print-function default-structure-printer)) x y z) (setq number1 (make-numbers :x 100 :y 200 :z 300)) (eq (numbers-x number1) 100) (eq (numbers-y number1) 200) (eq (numbers-z number1) 300) (numbers-p number1))) (do-test "type-option-test" (and (defstruct (binop (:type list)) (operator '? :type symbol) operand-1 operand-2) (setq binop-1 (make-binop :operator '+ :operand-1 'x :operand-2 5)) (equal binop-1 '(+ x 5)) (setq binop-2 (make-binop :operand-2 4 :operator '*)) (equal binop-2 '(* nil 4)) (defstruct (trinop (:type vector)) element1 element2) (vectorp (make-trinop :element1 0 :element2 1)))) (do-test "named-option-test" (and (defstruct (named-binop (:type list) :named) (operator '? :type symbol) operand-1 operand-2) (equal (make-named-binop :operator '+ :operand-1 'x :operand-2 5) '(named-binop + x 5)) (equal (make-named-binop :operand-2 4 :operator '*) '(named-binop * nil 4)))) (do-test "initial-offset-option-test" (and (defstruct (offset-binop (:type list) (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) (setq offset-binop-1 (make-offset-binop :operator '+ :operand-1 'x :operand-2 5)) (equal offset-binop-1 '(NIL NIL + X 5)) (defstruct (offset-binop2 (:type list) :named (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) (setq offset-binop-3 (make-offset-binop2 :operator '+ :operand-1 'x :operand-2 5)) (equal offset-binop-3 '(NIL NIL OFFSET-BINOP2 + X 5)))) ;; ;; Regression tests (do-test "AR 7650 Regression test" (and (defstruct (foo (:type (vector fixnum))) s1 (s2 2) s3)) (setq s (make-foo :s1 1)) (eq (foo-s1 s) 1))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/20/20-1-APPLYHOOK.TEST b/internal/test/LANGUAGE/from-sun/language/20/20-1-APPLYHOOK.TEST new file mode 100644 index 00000000..fea98395 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/20/20-1-APPLYHOOK.TEST @@ -0,0 +1 @@ +;; Function To Be Tested:applyhook ;; ;; Source: Guy L Steele's CLTL ;; Section: 20.1 THE EVALUATOR (Run-Time Evaluation of Forms) ;; Page: 323 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 13, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>20-1-applyhook.test ;; ;; ;; Syntax: (applyhook function args evalhookfn applyhookfn &optional env) ;; ;; Function Description: The function applyhook is provided to make it easier to ;; exploit the hook feature. In the case of applyhook, the function is applied ;; to the list of arguments args. In either case, for the duration of the ;; operation the variable *evalhook* is bound to evalhookfn, and *applyhook* to ;; applyhookfn. Furthermore, the env argument is used as the lexical environment ;; for the operation; env defaults to the null environment. The check for a hook ;; function is bypassed for the evaluation of the form itself (for evalhook), but ;; not for subsidiary evaluations and applications, such as evaluations of ;; subforms. ;; ;; Argument(s): function ;; args ;; evalhookfn: *evalhook* ;; applyhookfn: *applyhook* ;; env (optional): lexical environment for the operation ;; ;; Returns: ;; ;; Constraints/Limitations: (do-test-group ("evalhook-test-setup" :before (progn (defvar *hooklevel* 0) (defun apply-hook-function (fn args &optional env) (let ((*applyhook* 'apply-hook-function))) (let ((*hooklevel* (+ *hooklevel* 1))) (format *trace-output* "~%~V@TFunction: ~S" (* *hooklevel* 3) fn) (let ((values (multiple-value-list (applyhook fn args nil #'apply-hook-function env)))) (format *trace-output* "~%~V@TArguments: ~{~S~}" (* *hooklevel* 3) (list args)) (format *trace-output* "~%~V@TValue: ~{~S~}" (* *hooklevel* 3) values) (values-list values)))) ) ) (do-test "*applyhook*-exist?" (boundp '*applyhook*) ) (do-test "applyhook-test" (and (= (apply-hook-function '+ '(1 2 3 4)) 10) (eq (apply-hook-function '> '(1 2)) NIL) (equal (apply-hook-function 'list '(3 4 'a (car '(b . c)) (+ 3 4))) '(3 4 'a (car '(b . c)) (+ 3 4))) (equal (apply-hook-function 'substitute '(7 2 (2 2 2 2))) '(7 7 7 7)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/20/20-1-CONSTANTP.TEST b/internal/test/LANGUAGE/from-sun/language/20/20-1-CONSTANTP.TEST new file mode 100644 index 00000000..00325f1c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/20/20-1-CONSTANTP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: constantp ;; ;; Source: Guy L Steele's CLTL ;; Section: 20.1 THE EVALUATOR (Run-Time Evaluation of Forms) ;; Page: 324 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 11, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>20-1-constantp.test ;; ;; ;; Syntax: (constantp object) ;; ;; Function Description: If the predicate constantp is true of an object, then ;; that object, when considered as a form to be evaluated, always evaluates to ;; the same thing; it is a constant. This includes self-evaluating objects ;; such as numbers, characters, strings, bit-vectors, and keywords, as well as ;; all constant symbols declared by defconstant, such as nil t and pi. ;; In addition, a list whose car is quote, such as (quote foo), is considered ;; to be constant. ;; ;; Argument(s): object ;; ;; Returns: T or NIL ;; ;; Constraints/Limitations: (do-test "constantp-test1" (and (constantp NIL) (constantp T) (constantp pi) (constantp *evalhook*) (constantp most-positive-double-float) (constantp "STRING") (constantp #\a) (constantp #*) (constantp 132984) (constantp #C(1.0 2.0)) (constantp :INTERNAL) (constantp (car '((quote foo) (quote bar)))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/20/20-1-EVAL.TEST b/internal/test/LANGUAGE/from-sun/language/20/20-1-EVAL.TEST new file mode 100644 index 00000000..9b2f8068 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/20/20-1-EVAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: eval ;; ;; Source: Guy L Steele's CLTL ;; Section: 20.1 THE EVALUATOR (Run-Time Evaluation of Forms) ;; Page: 321 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 11, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>20-1-eval.test ;; ;; ;; Syntax: (eval form) ;; ;; Function Description: The form is evaluated in the current dynamic environment ;; and a null lexical environment. Whatever results from the evaluation is ;; returned from the call to eval. When a call to eval is made, two levels of ;; of evaluation occur on the argument. First the argument form is evaluated, ;; as for arguments to any function, by the usual argument evaluation mechamism ;; (which involves an implicit use of eval). Then the argument is passed to ;; the eval function, where another evaluation occurs. ;; ;; Argument(s): form ;; ;; Returns: result of evaluation of form ;; ;; Constraints/Limitations: (do-test "eval-test1" (and (eq (eval (list 'cdr (car '((quote (a . b)) c)))) 'b) (equal (eval '(append '(a b) '(c d))) (append '(a b) '(c d))) (= (eval '(* (cos 1.0) (sin 1.0))) (* (cos 1.0) (sin 1.0))) ) ) (do-test "eval-test2" (and (setq foo '(1- 10)) (= (eval foo) 9) (equal (eval 'foo) '(1- 10)) (eq (eval (quote (quote foo))) (quote foo)) (setq x 10 y 20 z 'last-element) (equal (mapcar #'eval (list 'x 'y 'z)) (list x y z)) ) ) (do-test "eval-top-level-variables" (and (boundp '+) (boundp '++) (boundp '+++) (boundp '*) (boundp '**) (boundp '***) (boundp '/) (boundp '//) (boundp '///) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-COPY-READTABLE.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-COPY-READTABLE.TEST new file mode 100644 index 00000000..513115bf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-COPY-READTABLE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: copy-readtable ;; ;; Source: CLtL p. 361 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 October 86 ;; ;; Last Update: 17 January 87 ;; ;; Filed As: {eris}cml>test>22-1-5-copy-readtable.test ;; ;; Syntax: copy-readtable &optional from-readtable to-readtable ;; ;; Function Description: Make a copy of from-readtable (default: *readtable*, the current readtable). If NIL is explicitly supplied as the value of from-readtable, the function makes a copy of the standard readtable. ;; If to-readtable is nil or unsupplied, the function makes a new copy; if to-readtable is supplied, it must be a read-table; the function then copies from-readtable into it. ;; ;; Arguments: from-readtable, to-readtable: nil or readtables. ;; ;; Returns: the readtable to which the copy was made ;; ;; (do-test-group copy-readtable-group :before (progn ;; Create 3 new readtables, but don't put them into effect yet. Substitute 1 and 2, 3 and 4 and 5 and 6, respectively, for left and right parentheses. (test-setq oddtable-one-two (copy-readtable nil)) (set-syntax-from-char #\1 #\( oddtable-one-two) (set-syntax-from-char #\2 #\) oddtable-one-two) ;; (test-setq oddtable-three-four (copy-readtable nil)) (set-syntax-from-char #\3 #\( oddtable-three-four) (set-syntax-from-char #\4 #\) oddtable-three-four) ;; (test-setq oddtable-five-six (copy-readtable nil)) (set-syntax-from-char #\5 #\( oddtable-five-six) (set-syntax-from-char #\6 #\) oddtable-five-six) ;; (test-setq *readtable* (copy-readtable nil)) ;; (test-defun rttest (readtable testfun) "Copy readtable to *readtable*, making it the effective table for read operations. Evaluate testfun, restore the standard table and return the value of testfun." (copy-readtable readtable *readtable*) (let ((*standard-input* (make-string-input-stream "12 34 56"))) (prog1 (funcall testfun) (copy-readtable (copy-readtable nil) *readtable*) ) ; prog1 ) ; let ) ; test-defun ) ; prog ;; ;; For each of the new readtables, the changed digits and no other digits will be NIL, the empty list - '() - and an integer otherwise. ;; (do-test standard-readtable-test ;; With the standard readtable in effect, all are integers. (every 'integerp (list '12 '34 '56)) ) ; do-test standard-readtable-test ;; (do-test oddtable-one-two-test (rttest oddtable-one-two #'(lambda nil (and (null (read)) (= 34 (read)) (= 56 (read)) ) ) ) ) ; do-test oddtable-one-two-test ;; (do-test oddtable-three-four-test (rttest oddtable-three-four #'(lambda nil (and (= 12 (read)) (null (read)) (= 56 (read)) ) ; and ) ) ) ; do-test oddtable-three-four-test ;; (do-test oddtable-five-six-test (rttest oddtable-five-six #'(lambda nil (and (= 12 (read)) (= 34 (read)) (null (read)) ) ; and ) ) ) ; do-test oddtable-five-six-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..c99ae066 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-DISPATCH-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-dispatch-macro-character ;; ;; Source: CLtL p. 364 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 4 November 86 ;; ;; Last Update: 4 November 86 ;; ;; Filed As: {eris}cml>test>22-1-5-get-dispatch-macro-character.test ;; ;; Syntax: get-dispatch-macro-character disp-char sub-char &optional readtable ;; ;; Function Description: returns the function called by the sequence DISP-CHAR/SUB-CHAR under READTABLE. Returns NIL if the seqence isn't a dispatching-macro sequence in READTABLE - alway if SUB-CHAR is one of the decimal integers. ;; ;; Argument(s): disp-char, sub-char - characters ;; readtable - a readtable ; defaults to NIL (the readtable currently in effect). ;; ;; Returns: a function or NIL. ;; (do-test-group (get-dispatch-macro-character-group :before (progn (test-defun has-dispf-p (disp-char sub-char &optional readtable) "Return T iff get-dispatch-macro-character returns a function for the same arguments. If the value is a symbol, it must satisfy fboundp; otherwise, it must be non-nil and satisfy functionp." (let ((func (get-dispatch-macro-character disp-char sub-char readtable))) (cond ((symbolp func) (fboundp func)) ; if it's a symbol (func (functionp func)) ; if it's anything else but NIL (t nil) ; if it's NIL fail ) ; cond ) ; let ) ; test-defun (test-defun std-has-dispf-p (sub-char) "Call has-dispf-p with #\# as the disp-character and the standard readtable." (let ((std-table (copy-readtable nil))) (declare (special std-table)) (has-dispf-p #\# sub-char std-table) ) ; let ) ; test-defun ) ; progn ) ; get-dispatch-macro-character-group ;; ;; (do-test get-dispatch-macro-character-with-standard-readtable-test (let ((*readtable* (copy-readtable nil))) (and ;; For every defined #-macro character in table 22-4 (CLtL p. 352), see if it returns a function ;; NOTE: #\# and #\= lack standard definitions. See AR 6795. (every 'std-has-dispf-p (list #\# #\' #\( #\* #\, #\: #\= #\\ #\| #\+ #\- #\. #\A #\B #\C #\O #\R #\S #\X)) ;; Decimal digits must never be dispatch macro characters. (notany 'std-has-dispf-p (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) ) ; and ) ; let ) ; do-test get-dispatch-macro-character-with-current-readtable-test ;; ;; ;; Try the function under an alternate readtable. Note that the alternate readtable never actually becomes *readtable*, the ruling table. (do-test get-dispatch-macro-character-with-alternate-readtable-test (let ((altreadtable (copy-readtable nil) ) ) (declare (special altreadtable)) (make-dispatch-macro-character #\$ nil altreadtable) (set-dispatch-macro-character #\$ #\% '(lambda (x y z) "This is a test.") altreadtable) (and ;; Is the function is in effect for the character pair? (has-dispf-p #\$ #\% altreadtable) ;; This should not have affected other pairs in the same readtable. (not (has-dispf-p #\$ #\+ altreadtable)) (not (has-dispf-p #\+ #\% altreadtable)) ;; Should not have affected the standard readtable. (not (std-has-dispf-p #\%)) ) ; and ) ; let ) ; do-test get-dispatch-macro-character-with-alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..7d55ddf2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-GET-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-macro-character ;; ;; Source: CLtL p. 362 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 November 86 ;; ;; Last Update: 2 November 86 ;; ;; Filed As: {eris}cml>test>22-1-5-get-macro-character.test ;; ;; Syntax: get-macro-character char &optional readtable ;; ;; Function Description: returns the function associated with char and the value of the character's non-terminating-p flag. Returns NIL if char is not a macro character. ;; ;; Argument(s): char - a character ;; readtable - the readtable in which char's syntax is to be examined; defaults to *readatable* (the readtable currently in effect) ;; ;; (do-test-group (get-macro-character-part-1-group :after (setq *readtable* (copy-readtable nil))) (do-test get-macro-character-test-with-ordinary-cases ;; Try with characters in the standard readtable (and (functionp (car (multiple-value-list (get-macro-character #\#)))) ;; This is a non-terminating macro. (cadr (multiple-value-list (get-macro-character #\#))) ;; (functionp (car (multiple-value-list (get-macro-character #\')))) ;; This is a terminating macro. ;; Return on nil non-terminating-p not working in 29 October sysout. See AR 6759. (null (cadr (multiple-value-list (get-macro-character #\')))) ;; Some non-macros (null (get-macro-character #\|)) (null (get-macro-character #\1)) ) ; and ) ; do-test get-macro-character-test-with-ordinary-cases ;; (do-test get-macro-character-test-with-a-different-table ;; The same characters in another readtable (let ((oddtable (copy-readtable nil))) (and (functionp (car (multiple-value-list (get-macro-character #\#)))) ;; This is a non-terminating macro. (cadr (multiple-value-list (get-macro-character #\# oddtable))) ;; (functionp (car (multiple-value-list (get-macro-character #\' oddtable)))) ;; This is a terminating macro. (null (cadr (multiple-value-list (get-macro-character #\' oddtable)))) ;; Some non-macros (null (get-macro-character #\| oddtable)) (null (get-macro-character #\1 oddtable)) ) ; and ) ; let ) ; do-test get-macro-character-test-with-a-different-table (do-test get-macro-character-test-with-non-standard-settings-in-the-current-table ;; The same characters in another readtable (let ((oddtable2 (copy-readtable nil))) (set-macro-character #\8 '(lambda (stream char) "this is a test") t oddtable2) (set-macro-character #\page '(lambda (stream char) "this is a test") nil oddtable2) (and (functionp (car (multiple-value-list (get-macro-character #\8)))) ;; This is a non-terminating macro. (cadr (multiple-value-list (get-macro-character #\8 oddtable2))) ;; (functionp (car (multiple-value-list (get-macro-character #\page oddtable2)))) ;; This is a terminating macro. (null (cadr (multiple-value-list (get-macro-character #\page)))) ;; Some non-macros (null (get-macro-character #\| oddtable2)) (null (get-macro-character #\1 oddtable2)) ) ; and ) ; let ) ; do-test get-macro-character-test-with-non-standard-settings-in-the-current-table ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..8b810733 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: make-dispatch-macro-character ;; ;; NOTE: the code for 22-1-5-make-dispatch-macro-character.test and 22-1-5-set-dispatch-macro-character.test are the same, because the two functions work so closely together. Only the comments and the test names are different. ;; ;; Source: CLtL p. 363 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 4 November 86 ;; ;; Last Update: 2/2/87 Jim Blum - rewrote test ;; ;; Filed As: {eris}cml>test>22-1-5-make-dispatch-macro-character.test ;; ;; Syntax: make-dispatch-macro-character char &optional non-terminating-p readtable ;; ;; Function Description: Makes char a dispatching macro character in readtable. If non-terminating-p is non-nil, this will be a non-terminating macro character. ;; ;; Argument(s): char - a character ;; readtable - a readtable ; defaults to NIL (the readtable currently in effect). ;; ;; Returns: T ;; (do-test-group (make-dispatch-macro-character-group :before (progn (setq 3nov862036 0 3nov862040 0 4nov861358readtable (copy-readtable nil)) ; These have to be setq'd anyway. (DEFUN setmarker (x y z) (incf 3nov862036)) (make-dispatch-macro-character #\{ T 4nov861358readtable) (set-dispatch-macro-character #\{ #\E '(lambda (stream char arg) (incf 3nov862040) ) 4nov861358readtable) (set-dispatch-macro-character #\{ #\K '(lambda (x y z) T) 4nov861358readtable) ) ) ; make-dispatch-macro-character-group ;; ;; (do-test make-dispatch-macro-character-with-standard-readtable-test (let ((*readtable* (copy-readtable nil))) (and ;; Test whether the functions return T. (eq t (make-dispatch-macro-character #\$)) (eq t (set-dispatch-macro-character #\$ #\q 'setmarker)) ;; The read under the standard table should stop at the to . ;; Since non-terminating-p defaults to nil, the read should terminate at the macro char and not increment the counter. (with-open-stream (s (make-string-input-stream "tok$qen ") ) (and (eq 'tok (read s)) (= 3nov862036 0) (eql 1 (read s)) (= 3nov862036 1) (eq 'en (read s)) ) ) (equal 'Qq (with-open-stream (s (make-string-input-stream "Qq")) (read s) ) ) ; this should have no effect (= 3nov862036 1) ) ; AND ) ; let ) ; do-test make-dispatch-macro-character-with-current-readtable-test ;; ;; ;; Try the function under an alternate readtable and non-terminating = T. (do-test make-dispatch-macro-character-with-alternate-readtable-test-and-non-terminating-p (let ((*readtable* (copy-readtable 4nov861358readtable))) (and ;; {E read in under the alternate table ought to increment the counter. {k ought to do nothing. ;; Since non-terminating-p all occurrences should invoke the new syntax. (with-open-stream (s (make-string-input-stream "tok{Een ") ) (eq 'tok{een (read s)) ) (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "{k{K{K{k"))(read s)) ; this should have no effect (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "kKkKkK"))(read s)) ; nor should this (= 3nov862040 0) ;; What we do in 4nov861358readtable should have no effect on the other readtable. (with-open-stream (s (make-string-input-stream "$q$Qxx"))(read s)) (= 3nov862036 1) ) ; and ) ; let ) ; do-test make-dispatch-macro-character-with-alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-READTABLEP.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-READTABLEP.TEST new file mode 100644 index 00000000..8999ca0e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-READTABLEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: readtablep ;; ;; Source: CLtL p. 361 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 October 86 ;; ;; Last Update: 24 March 8y - Reidy - changed the copy-readtable example. ;; ;; Filed As: {eris}cml>test>22-1-5-readtablep.test ;; ;; Syntax: readtablep object ;; ;; Function Description: Returns non-nil iff object is a readtable, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group readtablep-group :before (progn ;; See if readtablep is true or not true of object, and whether its value is equivalent to (typep object 'readtable). ;; JRB - AR 6654 is declined; it is sufficient that the Lisp truth value of whatever readtablep returns is correct, not its exact EQ value. (test-defun readtabletest (object expected-value) (let ((value (readtablep object))) (cond (expected-value value) (t (null value)) ) ) ; let ) ; test-defun (test-setq oddtable1 (copy-readtable nil)) ) ; progn ;; (do-test readtablep-test (every 'readtabletest (list *readtable* (let ((crt (copy-readtable))) crt) oddtable1 (let ((*readtable* oddtable1)) oddtable1) '*readtable* '(copy-readtable) 'oddtable1 "*readtable*" ) ; list '(t t t t nil nil nil nil) ) ; every ) ; do-test readtablep-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..7d82235d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set-dispatch-macro-character ;; ;; NOTE: the code for 22-1-5-make-dispatch-macro-character.test and 22-1-5-set-dispatch-macro-character.test are the same, because the two functions work so closely together. Only the comments and the test names are different. ;; ;; Source: CLtL p. 364 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 4 November 86 ;; ;; Last Update: 2/2/87 Jim Blum - rewrote test ;; ;; Filed As: {eris}cml>test>22-1-5-set-dispatch-macro-character.test ;; ;; Syntax: set-dispatch-macro-character disp-char sub-char function &optional readtable ;; ;; Function Description: causes the reader to call function when it encounters the sequence disp-char/sub-char under the control of readtable. ;; ;; Argument(s): disp-char, sub-char - characters ;; function - a function ;; readtable - a readtable ; defaults to NIL (the readtable currently in effect). ;; ;; Returns: T ;; (do-test-group (set-dispatch-macro-character-group :before (progn (setq 3nov862036 0 3nov862040 0 4nov861358readtable (copy-readtable nil)) ; These have to be setq'd anyway. (DEFUN setmarker (x y z) (incf 3nov862036)) (make-dispatch-macro-character #\{ T 4nov861358readtable) (set-dispatch-macro-character #\{ #\E '(lambda (stream char arg) (incf 3nov862040) ) 4nov861358readtable) (set-dispatch-macro-character #\{ #\K '(lambda (x y z) T) 4nov861358readtable) ) ) ; set-dispatch-macro-character-group ;; ;; (do-test set-dispatch-macro-character-with-standard-readtable-test (let ((*readtable* (copy-readtable nil))) (and ;; Test whether the functions return T. (eq t (make-dispatch-macro-character #\$)) (eq t (set-dispatch-macro-character #\$ #\q 'setmarker)) ;; The read under the standard table should stop at the to . ;; Since non-terminating-p defaults to nil, the read should terminate at the macro char and not increment the counter. (with-open-stream (s (make-string-input-stream "tok$qen ") ) (and (eq 'tok (read s)) (= 3nov862036 0) (eql 1 (read s)) (= 3nov862036 1) (eq 'en (read s)) ) ) (equal 'Qq (with-open-stream (s (make-string-input-stream "Qq")) (read s) ) ) ; this should have no effect (= 3nov862036 1) ) ; AND ) ; let ) ; do-test set-dispatch-macro-character-with-current-readtable-test ;; ;; ;; Try the function under an alternate readtable and non-terminating = T. (do-test set-dispatch-macro-character-with-alternate-readtable-test-and-non-terminating-p (let ((*readtable* (copy-readtable 4nov861358readtable))) (and ;; {E read in under the alternate table ought to increment the counter. {k ought to do nothing. ;; Since non-terminating-p all occurrences should invoke the new syntax. (with-open-stream (s (make-string-input-stream "tok{Een ") ) (eq 'tok{een (read s)) ) (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "{k{K{K{k"))(read s)) ; this should have no effect (= 3nov862040 0) (with-open-stream (s (make-string-input-stream "kKkKkK"))(read s)) ; nor should this (= 3nov862040 0) ;; What we do in 4nov861358readtable should have no effect on the other readtable. (with-open-stream (s (make-string-input-stream "$q$Qxx"))(read s)) (= 3nov862036 1) ) ; and ) ; let ) ; do-test set-dispatch-macro-character-with-alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..54ab5232 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-MACRO-CHARACTER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set-macro-character ;; ;; Source: CLtL p. 362 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 November 86 ;; ;; Last Update: 17 January 87 ;; ;; Filed As: {eris}cml>test>22-1-5-set-macro-character.test ;; ;; Syntax: set-macro-character char function &optional non-terminating-p readtable ;; ;; Function Description: Makes char a macro character which causes function to be called when the reader encounters it. ;; ;; Argument(s): char - a character ;; non-terminating-p - if true, makes char a non-terminating macro ;; readtable - the readtable in which char's syntax is to be set; defaults to *readatable* (the readtable currently in effect) ;; (do-test-group set-macro-character-group :before (progn (test-setq percentable (copy-readtable nil) *readtable* (copy-readtable nil) 2nov862039 0 2nov862110 0 ) ; test-setq (test-defun dmactest (val var string) "See if var=val after reading string. String will contain characters whose macro-function may or may not increment var; val (which was initialized to 0) is the expected value after reading occurrences of the character." (= val (write (progn (read (make-string-input-stream string) nil) var ) ) ) ) ; test-defun ) ; progn ;; (do-test set-macro-character-returns-t-test ;; Change #\&'s syntax in the current readtable and #\%'s in a non-standard one. Note that these test-setq's are real setq's that persist after the file is run; thus the odd names, which are unlikely to step on anything. (and (eq t (set-macro-character #\& '(lambda (x y) (test-setq 2nov862039 (1+ 2nov862039)) (values)) ) ) (eq t (set-macro-character #\% '(lambda (x y) (test-setq 2nov862110 (1+ 2nov862110))(values)) T percentable ) ) ) ; and ) ; do-test set-macro-character-returns-t-test ;; (do-test second-value-is-non-terminating-p-flag ;; NOTE: Always T in 29 October sysout. See AR 6759. (and (null (cadr (multiple-value-list (get-macro-character #\&)))) (cadr (multiple-value-list (get-macro-character #\% percentable))) ) ; and ) ; do-test second-value-is-non-terminating-p-flag ;; (do-test current-readtable-test (and ;; In the current readtable, #\&'s read function bumps a marker; 5 occurrences should bump it 5 times. (= 5 (progn (read (make-string-input-stream "&&&&&") nil) 2nov862039 ) ) ;; Macro-char settings in another readtable should not be invoked in this one. (= 0 (progn (read (make-string-input-stream "%%%%%%%%") nil) 2nov862110 ) ) ) ; and ) ; do-test current-readtable-test ;; (do-test alternate-readtable-test (let ((*readtable* percentable)) (and ;; In percentable, #\%'s read function bumps a marker; 8 occurrences should bump it 8 times. (= 8 (progn (read (make-string-input-stream "%%%%%%%%") nil) 2nov862110 ) ) ;; Macro-char settings in another readtable (i.e. the default one, as altered earlier in this file) should not be invoked in this one. (= 5 (progn (read (make-string-input-stream "&&&&&") nil) 2nov862039 ) ) ;; Macro-char settings in another readtable should not be invoked in this one. ) ; and ) ; let ) ; do-test alternate-readtable-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-SYNTAX-FROM-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-SYNTAX-FROM-CHAR.TEST new file mode 100644 index 00000000..661079fa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-1-5-SET-SYNTAX-FROM-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set-syntax-from-char ;; ;; Source: CLtL p. 361 ;; ;; Chapter 22: Input/Output Section 1.5: The Readtable ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 November 86 ;; ;; Last Update: 2/2/87 Jim Blum - removed (EVAL from (read estream) to run on the SUN ;; ;; Filed As: {eris}cml>test>22-1-5-set-syntax-from-char-part-01.test ;; ;; Syntax: set-syntax-from-char to-char from-char &optional to-readtable from-readtable ;; ;; Function Description: Makes the syntax of to-char in to-readtable the same as that of from-char in from-readtable. ;; ;; Argument(s): to-char, from-char - characters ;; to-readtable, from-readtable - readtables. To-readtable defaults to *readtable* (the readtable currently in effect), from-readtable to NIL (the standard readtable). ;; (do-test-group set-syntax-from-char-group :before (progn (test-setq tabstream (make-string-input-stream " 5 5 b B ") abc 0 3abc 1 \abc 2 |31oct861301| 0 |31OCT861301| 1 E31oct861301E 2 savetable *readtable* ; in case it wasn't the standard *readtable* (copy-readtable nil) tab-is-double-quote-table (copy-readtable nil) pound-is-newline-table (copy-readtable nil) 3-is-backslash-from-table (copy-readtable nil) 3-is-backslash-to-table (copy-readtable nil) \|-is-constituent-table (copy-readtable nil) pound-sign-is-double-quote-table (copy-readtable nil) ) ; test-setq (cond ((boundp '4abc) ; save this value in case it was bound (test-setq save4abc 4abc) (makunbound '4abc)) (t t) ) ) ; progn :after (progn (setq *readtable* savetable) (cond ((boundp 'save4abc) (setq 4abc save4abc)) (t t) ) ) ;; (do-test term-macro-from-whitespace-test ;; Make the tab a double quote; this will enable #\tab to create strings. (set-syntax-from-char #\tab #\" tab-is-double-quote-table) (let ((*readtable* tab-is-double-quote-table)) (and (stringp (read tabstream)) (not (integerp (read tabstream))) (string-equal (read tabstream)(read tabstream)) ) ) ) ; do-test term-macro-from-whitespace-test ;; (do-test whitespace-from-non-term-macro ;; Make # into a whitespace character. (set-syntax-from-char #\# #\newline pound-is-newline-table) (let ((*readtable* pound-is-newline-table) (*standard-input* (make-string-input-stream "# # ##5# ##"))) (and (integerp (read)) (= 50 (read *standard-input* nil 50)) ;; (= 9 (+ (* 3 2) 3)), with line feeds (standard and newly-defined) and tabs randomly interspersed. (eval (read (make-string-input-stream "( #= ##9 (#+# (#*##3#2) ## ##3##))") )) ) ; and ) ; let ) ; do-test whitespace-from-non-term-macro ;; ;; Test the to-readtable and from-readtable arguments (do-test single-escape-from-constituent-before ;; ;; Set #\4 to a #\\'s syntax in the from table. (set-syntax-from-char #\4 #\\ 3-is-backslash-from-table) ;; ;; Then copy it to #\3's in the to-table. The result should be that #\3 functions as a backslash in to-table. ;; (set-syntax-from-char #\3 #\4 3-is-backslash-to-table 3-is-backslash-from-table) ;; (and (let ((*standard-input* (make-string-input-stream "3abc 3ABC"))) (= (eval (read)) (eval (read))) ) ;; Before putting the to-table into effect, show that the symbols above all have different values. (notany #'= (list abc abc 3abc) (list 3abc \abc \abc)) ) ; and ) ; do-test single-escape-from-constituent-before ;; (do-test single-escape-from-constituent-after ;; Under the standard readtable, abc=0, 3abc=1 and \abc=2. Under 3-is-backslash-to-table, '3abc should read as '\abc. (let ((*readtable* 3-is-backslash-to-table) (*standard-input* (make-string-input-stream "3abc 4abc")) ) (and (= 2 (eval (read))) ;; See if the from- and to-tables are distinct. #\4 was a single-escape in the from-table, but not in the to-table, which is currently in effect; it should not have the #\\ syntax now. (not (boundp (read))) ) ; and ) ; let ) ; do-test single-escape-from-constituent-after ;; (do-test constituent-from-multiple-escape (set-syntax-from-char #\| #\E \|-is-constituent-table) (and ;; Verify that, under the standard readtable, all 3 have distinct values. (notany #'= (list |31oct861301| |31oct861301| |31OCT861301|) (list |31OCT861301| E31oct861301E E31oct861301E)) (let ((*readtable* \|-is-constituent-table)) (with-input-from-string (estream "|31oct861301| |31OCT861301| 36E3 36|3") (and ;; #\| no longer serves to distinguish upper- from lower-case characters in symbols. (eq (read estream) (read estream)) ;; #\| does not copy #\E's exponent-marker property. (floatp (read estream)) (not (floatp (read estream))) ) ; and ) ; with-input-from-string estream ) ; let ) ; and ) ; do-test constituent-from-multiple-escape ;; (do-test non-terminating-macro-from-terminating-macro (set-syntax-from-char #\# #\" pound-sign-is-double-quote-table) (let ((*readtable* pound-sign-is-double-quote-table)) (and (every #'(lambda (string) (stringp (read-from-string string))) '("\#\# \#" "\# \#")) (eq 100 (parse-integer (read-from-string "\#100\#"))) ) ; and ) ; let ) ; do-test non-terminating-macro-from-terminating-macro ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-LISTEN.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-LISTEN.TEST new file mode 100644 index 00000000..4197f6fa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-LISTEN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: listen ;; ;; Source: CLtL p. 380 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 14 November 86 ;; ;; Last Update: 12 January 87 ;; ;; Filed As: {eris}cml>test>22-2-1-listen.test ;; ;; Syntax: listen &optional input-stream ;; ;; Function Description: true iff a character is immediately available from input-stream. ;; ;; Argument(s): input-stream - a stream; defaults to the value of *standard-input* ;; ;; Returns: t or nil ;; (do-test-group listen-group :before (test-setq gulf (make-string-input-stream "g ")) :after (close gulf) ;; THE FOLLOWING TEST IS BOGUS because it depends on the state of the ;; terminal at the time that the test suite runs. ;; (do-test "top-level default listen gets an eof" ;; (null (listen)) ;; ) ; do-test "top-level default listen gets an eof" ;; ;; Try it with read, read-char, and read-line. (do-test "non-interactive streams listen is true except at read eof" (let ((*standard-input* (make-string-input-stream "g "))) (and (listen) ;; JRB This has to be READ-PRESERVING-WHITESPACE, not READ. (read-preserving-whitespace) (listen) ;; Listen says that a character is available, not neccessarily a lisp object. (string= "eof" (read nil nil "eof")) ;; NOTE: returns nil in 30 December sysout; see AR 7202. (null (listen)) ) ) ; let ) ; do-test "non-interactive streams listen is true except at read eof" ;; (do-test "non-interactive streams listen is true except at read-char eof" (let ((*standard-input* gulf)) (and (listen gulf) (read-char) (listen) (read-char) (null (listen)) (string= "eof" (read-char nil nil "eof")) (null (listen)) ) ) ; let ) ; do-test "non-interactive streams listen is true except at read-char eof" ;; (do-test "non-interactive streams listen is true except at read-line eof" (let ((*standard-input* (make-string-input-stream (make-array 3 :element-type 'string-char :initial-contents '(#\g #\newline #\h))))) (and (listen) (car (multiple-value-list (read-line))) (listen) (car (multiple-value-list (read-line))) (null (listen))(print *standard-input*) (string= "eof" (read-line *standard-input* nil "eof")) (null (listen)) ) ) ; let ) ; do-test "non-interactive streams listen is true except at read-line eof" ;; ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-PARSE-INTEGER.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-PARSE-INTEGER.TEST new file mode 100644 index 00000000..04ca4bd0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-PARSE-INTEGER.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: parse-integer ;; ;; Source: CLtL p. 381 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 16 November 86 ;; ;; Last Update: 12 January 87 ;; ;; Filed As: {eris}cml>test>22-2-1-parse-integer.test ;; ;; Syntax: parse-integer string &key :start :end :radix :junk-allowed ;; ;; Function Description: scans the substring delimited by :start (defaults to the beginning of string) and :end (defaults to the end) and attempts to parse an integer. Returns the integer if successful, otherwise nil. ;; ;; Arguments: ;; string: a string ;; :start, :end: substring delimiters within string (counting from 0) ;; :radix: the base in which the input integer is to be read (defaults to 10) ;; :junk-allowed: if true, the function's first value is nil in cases where it could not parse an integer; if nil (the default), it signals an error in these cases. ;; ;; Returns: the integer (or nil; see :junk-allowed) and the index into the string of the delimiter that terminated the parse. ;; (do-test-group parse-integer-group :before (test-setq length (+ 20 (random 100)) start (random 5) end (+ start 1 (random 10))) ;; (do-test "parse-integer standard cases" (every #'(lambda (value) (= 123 value)) (list (parse-integer "123") (* -1 (parse-integer "-0123")) (parse-integer "00123") (parse-integer "0012300" :end 5) ;; NOTE: 12 Nov parse-integer works incorrectly on symbol-names. See AR 6869 (parse-integer (symbol-name '\123) :start 0) (parse-integer (symbol-name '\1\2\3) :end 3) (parse-integer "xx123" :start 2) (parse-integer "123xx" :end 3) (parse-integer (symbol-name '!!!123***) :start 3 :end 6) (parse-integer (make-array 3 :initial-contents '(#\1 #\2 #\3) :element-type 'string-char)) (- (parse-integer (make-string 3 :initial-element #\2)) 99) (* -1 (parse-integer (make-array 4 :initial-contents '(#\- #\1 #\2 #\3) :element-type 'string-char))) (parse-integer (make-array 7 :initial-contents '(#\newline #\space #\1 #\2 #\3 #\newline #\space) :element-type 'string-char) :start 2 :end 5) ) ) ; every ) ; do-test "parse-integer standard cases" ;; (do-test "parse-integer with different radices" (and (= 123 (parse-integer "1111011" :radix 2)) (= 123 (parse-integer "211110112" :radix 2 :start 1 :end 8)) ;; NOTE: parse-integer doesn't accept letters. See AR 6904 (= 123 (parse-integer "3f" :radix 36)) (= 117 (parse-integer "39" :radix 36)) ) ; and ) ; do-test "parse-integer with different radices" (do-test "parse-integer skips whitespace" (= 123 (parse-integer " 123 ")) ) ; do-test "parse-integer skips whitespace" (do-test "parse-integer :junk-allowed" (and ;; redundant here (= 123 (parse-integer "123" :junk-allowed 0)) ; any non-nil value will do (null (parse-integer "#123#" :junk-allowed t)) (null (parse-integer "2002" :junk-allowed "nil" :radix 2)) (null (parse-integer "20x02" :junk-allowed *readtable* :start 2 :end 3)) ) ; and ) ; do-test "parse-integer :junk-allowed" (do-test "parse-integer index value" (and (let ((parse1 (multiple-value-list (parse-integer "123"))) (parse2 (multiple-value-list (parse-integer " 123 "))) ) ;; Different lengths but same value (= 3 (cadr parse1)) (= 8 (cadr parse2)) (= (car parse1) (car parse2)) ) ;; Index is the stopping point, no matter where parsing started. (= end (cadr (multiple-value-list (parse-integer (make-string length :initial-element #\9) :start start :end end ) ) ) ) (= 0 (cadr (multiple-value-list (parse-integer "xxx" :junk-allowed t)))) (= 0 (cadr (multiple-value-list (parse-integer "xxx" :junk-allowed t)))) (= (1- (length "123!")) (cadr (multiple-value-list (parse-integer "123!" :junk-allowed t)))) ) ; and ) ; do-test "parse-integer index value" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-PEEK-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-PEEK-CHAR.TEST new file mode 100644 index 00000000..ba018aea --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-PEEK-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: peek-char ;; ;; Source: CLtL p. 379 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 12 November 86 ;; ;; Last Update: 1 Jan 87 Jim Blum - fixed MACRO char tests ;; ;; Filed As: {eris}cml>test>22-2-1-peek-char.test ;; ;; Syntax: peek-char &optional peek-type input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads and returns the next character from input-stream, but leaves the stream's pointer unchanged - i.e. pointing to the character just read, so that another peek-char or read-char will read the same character. ;; ;; Argument(s): peek-type - if t, skip whitespace characters; if nil, don't. ;; input-stream - a stream ;; eof-error-p - if true, signal an error if eof is encountered before the end of the line ;; eof-value - if eof-error-p is nil, return this value if eof is encountered before the end of the line ;; recursive-p - if true, this is an embedded call, not top-level ;; ;; Returns: the character read ;; (do-test-group (peek-char-group :before (test-setq test(make-string-input-stream "@5") test2(make-string-input-stream "#@4") river (make-string-input-stream "12345") brook (make-string-input-stream " 1;this is a comment") ; #\space and #\newline are the only standard whitespace characters. canal (make-string-input-stream "100") savetable *readtable* ) ; test-setq ;; :after (progn (setq *readtable* savetable) (mapcar 'close (list river brook canal test test2)) ) ; progn ) ; peek-char-group (do-test "peek-char doesn't move the pointer" (and (eq #\1 (peek-char nil river)) (eq #\1 (peek-char nil river)) (eq #\1 (read-char river)) (progn (unread-char #\1 river) (peek-char nil river) (peek-char nil river) (peek-char nil river) (peek-char nil river) (peek-char nil river) (= 12345 (read river)) ) ; progn ) ; and ) ; do-test "peek-char doesn't move the pointer" ;; (do-test "peek-char accepts alternative input-stream" (let ((*standard-input* (make-string-input-stream "a B c D"))) (and (eq #\a (peek-char)) (read-char) (eq #\space (peek-char)) (= 6 (length (read-line))) (or (close *standard-input*) t) ; for portability ) ; and ) ; let ) ;do-test "peek-char accepts alternative default stream" ;; (do-test "peek-char peek-type" (and (eq #\1 (peek-char t brook)) ; skip whitespace (read brook) ; get past the 1 (eq #\; (peek-char nil brook)) ; don't skip comments ) ) ;do-test "peek-char peek-type" ;; (do-test "peek-char eof arguments test" (let ((*standard-input* canal)) (read) (= 50 (peek-char nil nil nil 50)) ) ; let ) ;do-test "peek-char eof arguments test" ;; (do-test peek-char-recursive-p-test ;; a real test of this (set-macro-character #\@ #'(lambda (stream char) (peek-char nil stream t nil t))) (set-dispatch-macro-character #\# #\@ #'(lambda (stream mac disp) (peek-char nil stream t nil t))) (and (eql #\5 (read test)) (eql #\4 (read test2)) ) ; and ) ;do-test peek-char-recursive-p-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR-NO-HANG.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR-NO-HANG.TEST new file mode 100644 index 00000000..8056d490 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR-NO-HANG.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read-char-no-hang ;; ;; Source: CLtL p. 380 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 15 November 86 ;; ;; Last Update: 18 February 87 - Reidy. Commented out the first test pending a fix of AR 7216. ;; ;; Filed As: {eris}cml>test>22-2-1-read-char-no-hang.test ;; ;; Syntax: read-char-no-hang & optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads a character and returns it if one is available, returns nil if one isn't. ;; ;; Argument(s): input-stream - a stream ;; eof-error-p - iff true, the function will signal an error at eof; otherwise, it returns the value of eof-value ;; eof-value - see eof-error-p ;; recursive-p - if true, this is a recursive call, not top-level ;; ;; Returns: the character read or eof-value if specified ;; (do-test-group read-char-no-hang-group :before (progn (test-setq cold (make-string-input-stream "1 2 ") *readtable* (copy-readtable nil) ; start with the standard ) ;; (test-defun atsign-top (stream char) (read-char-no-hang stream nil nil nil) "top") ;; (test-defun atsign-recursive (stream mac disp) (read-char-no-hang stream nil nil 1) "recursive") ;; (set-dispatch-macro-character #\# #\@ 'atsign-recursive) (set-macro-character #\@ 'atsign-top) ) ; progn ;; :after (close cold) ;; ;; (do-test "read-char-no-hang returns nil standard-input" (null (read-char-no-hang)) ) ; do-test "read-char-no-hang returns nil on standard-input" ;; (do-test "read-char-no-hang on string stream" (let ((*standard-input* cold)) ;; MAPCAR and EVERY constructs didn't work on this. Maybe it was timing. (and (char= #\1 (read-char-no-hang)) ; try default and explicitly-specified input streams. (char= #\space (read-char-no-hang cold)) (char= #\newline (read-char-no-hang)) (char= #\2 (read-char-no-hang cold)) (char= #\space (read-char-no-hang)) ;; Try eof-value. (= 0 (read-char-no-hang cold nil 0)) (expect-errors (error) (read-char-no-hang)) ) ; and ) ; let ) ; do-test "read-char-no-hang on string stream" ;; (do-test "read-char-no-hang recursive-p test" (and (string= "top" (read-from-string "@@1")) (string= "recursive" (read-from-string "#@1")) ) ; and ) ; do-test "read-char-no-hang recursive-p test" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR.TEST new file mode 100644 index 00000000..06cf6d8d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read-char ;; ;; Source: CLtL p. 379 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 12 November 86 ;; ;; Last Update: 1-6-87 Jim Blum - fixed macro char tests ;; 2-3-87 Jim Blum - changed (read test t nil t) to (read test) ;; and for test2 in last test ;; changed (read-char nil nil 50) to ;; (read-char *standard-input* nil 50) ;; Filed As: {eris}cml>test>22-2-1-read-char.test ;; ;; Syntax: read-char &optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads and returns the next character from input-stream. ;; ;; Argument(s): input-stream - a stream ;; eof-error-p - if true, signal an error if eof is encountered before the end of the line ;; eof-value - if eof-error-p is nil, return this value if eof is encountered before the end of the line ;; recursive-p - if true, this is an embedded call, not top-level ;; ;; Returns: the character read ;; (do-test-group (read-char-group :before (test-setq test(make-string-input-stream "@5") test2(make-string-input-stream "#@4") blood (make-string-input-stream "12345") jet (make-string-input-stream "100") savetable *readtable* *readtable* (copy-readtable nil) ) ; test-setq ;; :after (progn (mapcar 'close (list blood jet test test2)) (setq *readtable* savetable) ) ; progn ) ; read-char-group ;; (do-test "read-char moves the pointer" (and (eq #\1 (read-char blood)) (eq #\2 (read-char blood)) (eq #\3 (read-char blood)) (= 45 (read blood)) ) ; and ) ; do-test "read-char doesn't move the pointer" ;; (do-test "read-char accepts alternative input-stream" (let ((*standard-input* (make-string-input-stream "a B c D"))) (and (eq #\a (read-char)) (eq #\space (read-char)) (= 5 (length (read-line))) (or (close *standard-input*) t) ; for portability ) ; and ) ; let ) ;do-test "read-char accepts alternative default stream" ;; (do-test "read-char eof arguments test" (let ((*standard-input* jet)) (read) (= 50 (read-char *standard-input* nil 50)) ) ; let ) ;do-test "read-char eof arguments test" ;; (do-test read-char-recursive-p-test (set-macro-character #\@ #'(lambda (stream char) (read-char stream t nil nil))) (set-dispatch-macro-character #\# #\@ #'(lambda (stream mac disp) (read-char stream t nil t))) (and (equal #\5 (read test)) (equal #\4 (read test2)) ) ; and ) ;do-test read-char-recursive-p-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-DELIMITED-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-DELIMITED-LIST.TEST new file mode 100644 index 00000000..ce9528ca --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-DELIMITED-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read-delimited-list ;; ;; Source: CLtL p. 377 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 10 November 86 ;; ;; Last Update: 19 January 87 ;; ;; Filed As: {eris}cml>test>22-2-1-read-delimited-list.test ;; ;; Syntax: read-delimited-list char &optional input-stream recursive-p ;; ;; Function Description: reads objects from input-stream until the next character after an object's representation (ignoring whitespace characters and comments) is char. ;; ;; Argument(s): char - a character ;; input-stream - a stream ;; recursive-p - if non-nil, indicates that this is an imbedded rather than top-level call ;; ;; Returns: a list of objects read ;; ;; ;; Steele's example, CLtL p 377-378 ;; (do-test-group read-delimited-list-group :before (progn (test-setq *readtable* (copy-readtable nil) test (make-string-input-stream "((p q) (p z) (p a) (q z) (q a) (z a))") test2 (make-string-input-stream "#{p q z a}") ) (test-defun |#{-reader| (stream char arg) (declare (ignore char arg)) (mapcon #'(lambda (x) (mapcar #'(lambda (y) (list (car x) y) ) ; lambda (cdr x) ) ; mapcar ) ; lambda (read-delimited-list #\} stream t) ) ; mapcon ) ; test-defun ) ; progn :after (progn (setq *readtable* (copy-readtable nil))(close test)) (do-test read-delimited-list-test (set-dispatch-macro-character #\# #\{ #'|#{-reader|) (set-macro-character #\} (get-macro-character #\) nil)) (equal (read test2) (read test)) ) ; do-test-read-delimited-list-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-FROM-STRING.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-FROM-STRING.TEST new file mode 100644 index 00000000..4a3c4de2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-FROM-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read-from-string ;; ;; Source: CLtL p. 380 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 16 November 86 ;; ;; Last Update: 22 January 87 ;; ;; Filed As: {eris}cml>test>22-2-1-read-from-string.test ;; ;; Syntax: read-from-string string &optional eof-effor-p eof-value ;; &key :start :end :preserve-whitespace ;; ;; Function Description: reads the part of string delimited by :start and :end and returns the lisp object built by the reader from it. ;; ;; Arguments ;; string: a string ;; eof-error-p, eof-value: if true, return an error at eof; otherwise, return the value of eof-value ;; :start, :end: (counting from 0) delimiters of the portion of the string to read ;; :preserve-whitespace: if true, reads whitespace characters as syntactically significant. ;; ;; Returns: the object created by the reader, and the length of the string ;; (do-test-group read-from-string-group :before (progn (test-setq symbol5 '|5| symbol55 '\5\5 list5 (list 5 4 3 2 1) \5 6 |55| 66 ) ) ; progn (do-test "read-from-string produces symbols" (and (every 'equal (list (read-from-string "|5|") (read-from-string "|55|")) (list symbol5 symbol55) ) (every '= (list (eval (read-from-string "|5|")) (eval (read-from-string "|55|"))) '(6 66) ) ) ; and ) ; do-test "read-from-string produces symbols" ;; (do-test "read-from-string produces strings" (string-equal "Alexis is a bitch." (read-from-string "\"Alexis is a BITCH.\"")) ) ; do-test "read-from-string produces strings" ;; (do-test "read-from-string produces lists" (and (listp (eval (read-from-string "list5"))) (listp (read-from-string "(5 4 3 2 1)")) (= 1 (car (last (eval (read-from-string "list5"))))) ) ; and ) ; do-test "read-from-string produces lists" ;; (do-test "read-from-string length value" ;; the object read is the same, but the strings' lengths are different. (let ((version1 "(+ 3 3)") (version2 "( + 3 3 )")) (and (equal (car (multiple-value-list (read-from-string version1))) (car (multiple-value-list (read-from-string version2))) ) ; equal (not (equal (cadr (multiple-value-list (read-from-string version1))) (cadr (multiple-value-list (read-from-string version2))) )) ; not equal ) ; and ) ; let ) ; do-test "read-from-string length value" ;; (do-test "read-from-string start and end keywords" (every #'(lambda (arg) (= (read-from-string "123") arg)) (list (read-from-string "0123" nil nil :start 1 :end 4) (read-from-string "1234" nil nil :end 3) (read-from-string "01234" nil nil :start 1 :end 4) (read-from-string "01234" nil nil :end 4 :start 1) ) ) ; every ) ; do-test "read-from-string start and end keywords" ;; (do-test "read-from-string returns evaluable expressions" (and (= 6 (eval (read-from-string "(+ 3 3)"))) (= 6 (eval (read-from-string "xxx(+ 3 3)!!!" nil nil :start 3 :end 10))) (= (eval (read-from-string "(+ 3 3)")) (eval (read-from-string "xxx(+ 3 3)!!!" nil nil :start 3 :end 10))) ) ; and ) ; do-test "read-from-string returns evaluable expressions" ;; (do-test "read-from-string eof arguments" (and (= 0 (read-from-string " " nil 0)) (expect-errors (error) (read-from-string "(car (list 1 2 3)" t 0)) ) ; and ) ; do-test "read-from-string eof arguments" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-PRESERVING-WHITESPACE.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-PRESERVING-WHITESPACE.TEST new file mode 100644 index 00000000..84631a1d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ-PRESERVING-WHITESPACE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read-preserving-whitespace ;; ;; Source: CLtL p. 376 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 7 November 86 ;; ;; Last Update: 23-Mar-87 by van Melle ;; ;; Filed As: {eris}cml>test>22-2-1-read-preserving-whitespace.test ;; ;; Syntax: read-preserving-whitespace &optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads the printed representation of an object from input-stream, builds an object and returns it, preserving the character that ended the extended token. ;; ;; Argument(s): input-stream: a stream ;; eof-error-p: if true, signal an error at end-of-file. ;; eof-value: if eof-error-p is false, return this value at end-of-file. ;; recursive-p: if true, this is an embedded call, not top-level. ;; ;; Returns: the lisp object or eof-value. ;; (do-test basic-read-test (and (with-input-from-string (s "foo bar") (read s) ; read should throw the whitespace away (eq (read-char s) #\b)) (with-input-from-string (s "foo bar") (read-preserving-whitespace s) (eq (read-char s) #\Space)) (with-input-from-string (s "foo(bar)") (read s) ; read better not throw ALL terminators away (eq (read-char s) #\()) )) (do-test-group (read-group :before ;; Steele's example, CLtL p. 376 (test-defun atsign-reader (stream char) (declare (ignore char)) (do ((path (list (read-preserving-whitespace stream)) (cons (progn (read-char stream nil nil t) (read-preserving-whitespace stream) ) ; progn path ) ; cons ) ) ((not (char= (peek-char nil stream nil nil t) #\@)) (cons 'path (nreverse path)) ) ) ; do ) ; test-defun ) ; read-group (do-test read-test (let ((*readtable* (copy-readtable)) val) (set-macro-character #\@ 'atsign-reader) (setq val (read-from-string "(zyedh @usr@games@zork @usr@games@boggle)")) (and (= 3 (length val)) (listp (cadr val)) (listp (caddr val)) ) ; and ) ; let ) ; do-test-read-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ.TEST new file mode 100644 index 00000000..df83a9ce --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-READ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: read ;; ;; Source: CLtL p. 375 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 7 November 86 ;; ;; Last Update: 2-3-87 Jim Blum - Changed (read test t nil t) to (read test) ;; to run on the SUN ;; ;; Filed As: {eris}cml>test>22-2-1-read.test ;; ;; Syntax: read &optional input-stream eof-error-p eof-value recursive-p ;; ;; Function Description: reads the printed representation of an object from input-stream, builds an object and returns it. ;; ;; Argument(s): input-stream: a stream ;; eof-error-p: if true, signal an error at end-of-file. ;; eof-value: if eof-error-p is false, return this value at end-of-file. ;; recursive-p: if true, this is an embedded call, not top-level. ;; ;; Returns: the lisp object or eof-value. ;; (do-test-group (read-char-group :before (test-setq test (make-string-input-stream "#@50") test2 (make-string-input-stream "") test3 (make-string-input-stream "@(a b c)")) :after (progn (mapcar 'close (list test test2 test3)) (setq *readtable* (copy-readtable nil)) ) ; progn ) ;read-char-group (do-test basic-read-test (set-macro-character #\@ '(lambda (stream char) (declare (ignore char)) (read stream) ) ; lambda ) ; set-macro-character (set-dispatch-macro-character #\# #\@ '(lambda (stream subchar integer) (declare (ignore subchar) (ignore integer)) (read stream) ) ; lambda ) ; set-dispatch-macro-character (= 50 (read test t nil t)) ) ; do-test basic-read-test (do-test read-with-eof-error-p-test (null (read test2 nil)) ) ; do-test read-with-eof-error-p-test ;; (do-test read-with-eof-value-test (equal "EOF" (read test2 nil "EOF")) ) ; do-test read-with-eof-value-test ;; (do-test read-with-recursive-p-test ;; From CLtL p. 374 (equal '(a b c) (read test3)) ) ; do-test read-with-recursive-p-test ) ; do-test group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-2-1-UNREAD-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-UNREAD-CHAR.TEST new file mode 100644 index 00000000..baaf68b6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-2-1-UNREAD-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unread-char ;; ;; Source: CLtL p. 379 ;; ;; Chapter 22: Input/Output Section 2.1: Input from Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 11 November 86 ;; ;; Last Update: 1-6-87 Jim Blum removed system dependent test and reorganized ;; ;; Filed As: {eris}cml>test>22-2-1-unread-char.test ;; ;; Syntax: unread-char character &optional input-stream ;; ;; Function Description: puts character at the front of input-stream, thus setting the stream's pointer back one position. ;; ;; Argument(s): character - a character ;; input-stream - a stream (default: *standard-io*) ;; ;; Returns: nil ;; (do-test-group (unread-char-group :before (test-setq |1 2 3 string| "1 2 3" numbers (make-string-input-stream "1234567890") river (make-string-input-stream |1 2 3 string|) ) ;; :after (mapcar 'close (list numbers river)) ) ; unread-char-group ;; (do-test unread-char-returns-nil-test (every 'null (list (progn (read-char numbers) (unread-char #\1 numbers) ) ) ; list ) ; every ) ; do-test unread-char-restores-correct-char ;; (do-test unread-char-unreads-just-one-character-test ;; This also tests the default for stream. (let ((*standard-input* river)) (read-char) (read-char) (read-char) (unread-char #\2) ; this is the "right" character (and ;; Should point to the third character (eq #\2 (read-char)) ;; Now it should point to the fourth (= (length (car (multiple-value-list (read-line))) ) (- (length |1 2 3 string|) 3) ) ) ; and ) ; let ) ; do-test unread-char-unreads-just-one-character-test ;; ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-FINISH-OUTPUT.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-FINISH-OUTPUT.TEST new file mode 100644 index 00000000..1de5d522 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-FINISH-OUTPUT.TEST @@ -0,0 +1 @@ +;; Definition To Be Tested: finish-output, force-output, and clear-output ;; ;; Source: Xerox LIsp Manual ;; Chapter 22-3-1: Input/Output Output to Character Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>22-3-1-finish-output.test ;; ;; ;; Syntax: finish-output &optional output-stream ;; ;; Function Description: The function finish-output attempts to ensure that all output sent to output-stream has reached its destination, and only then returns nil. force-output initiates the emptying of any internal buffers but returns nil without waiting for completion or acknowledgment. The function clear-output, on the other hand, attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the desitnation. ;; ;; Argument(s): output-stream ;; ;; Returns: nil ;; ;; These tests just test that the functions dont break for a variety of devices. It could be improved by putting out a huge string or simulating a slow channel by advising \bufferedbout (whatever its called) and do some elapsed time tests after each type of output. Then do an input-test to see if all the characters made it (or not in the case of clear-output). ;; (DO-TEST LOAD-CH-21-FUNCTIONS (OR (BOUNDP '21-FUNCTIONS-HAVE-BEEN-LOADED) (LOAD "21-functions.def"))) (DO-TEST ("finish-output" :AFTER (DOLIST (STREAM-NAME STREAM-IO-NAMES) (DELETE-FILE STREAM-NAME))) (DOLIST (STREAM-NAME STREAM-IO-NAMES T) (WITH-OPEN-FILE (ASTREAM STREAM-NAME :DIRECTION :OUTPUT) (OUTPUT-TEST ASTREAM :KEEP-OPEN) (FINISH-OUTPUT ASTREAM) (CLOSE ASTREAM) (WITH-OPEN-FILE (ASTREAM STREAM-NAME) (UNLESS (INPUT-TEST ASTREAM) (PRINT-STREAM-ERROR "finish-output" STREAM-NAME)))))) (DO-TEST ("force-output" :AFTER (DOLIST (STREAM-NAME STREAM-IO-NAMES) (DELETE-FILE STREAM-NAME))) (DOLIST (STREAM-NAME STREAM-IO-NAMES T) (WITH-OPEN-FILE (ASTREAM STREAM-NAME :DIRECTION :OUTPUT) (OUTPUT-TEST ASTREAM :KEEP-OPEN) (FORCE-OUTPUT ASTREAM) (CLOSE ASTREAM) (WITH-OPEN-FILE (ASTREAM STREAM-NAME) (UNLESS (INPUT-TEST ASTREAM) (PRINT-STREAM-ERROR "finish-output" STREAM-NAME)))))) (DO-TEST ("clear-output" :AFTER (DOLIST (STREAM-NAME STREAM-IO-NAMES) (DELETE-FILE STREAM-NAME))) (DOLIST (STREAM-NAME STREAM-IO-NAMES T) (WITH-OPEN-FILE (ASTREAM STREAM-NAME :DIRECTION :OUTPUT) (OUTPUT-TEST ASTREAM :KEEP-OPEN) (CLEAR-OUTPUT ASTREAM) (CLOSE ASTREAM)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-FRESH-LINE.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-FRESH-LINE.TEST new file mode 100644 index 00000000..2ab4ad5a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-FRESH-LINE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fresh-line ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-fresh-line.test ;; ;; Syntax: fresh-line &optional output-stream ;; ;; Function Description: puts a newline out to stream iff stream is not at the beginning of a line. ;; ;; Argument(s): stream - a stream (defaults to *standard-output*) ;; ;; Returns: t if a newline was output, else nil ;; (do-test-group (fresh-line-group :before (progn (test-setq yes-examples ;; These do not write a newline themselves, so fresh-line will be required. (list #'(lambda () (print 1 charstream)) #'(lambda () (prin1 1 charstream)) #'(lambda () (write-string "1" charstream)) #'(lambda () (princ 'simple charstream)) #'(lambda () (princ '\c\ om\ \plicated charstream)) #'(lambda () (terpri charstream) (fresh-line charstream) (princ '\c\ om\ \plicated charstream)) #'(lambda () (write-char #\1 charstream)) ) ; list ;; no-examples ;; These write a newline themselves, so fresh-line won't be required. (list #'(lambda () (terpri charstream)) #'(lambda () (fresh-line charstream)) #'(lambda () (write-line "1" charstream)) ) ; list ) ; test-setq ;; (test-defun fresh-line-test (function) "Execute function (which puts something out to charstream) then (fresh-line charstream). Return the value of fresh-line." (funcall function) (fresh-line charstream) ) ; test-defun ) ; progn ) ; fresh-line group ;; (do-test "fresh-line returns t if not at the beginning of a line" (let ((charstream (make-string-output-stream))) (declare (special charstream)) (prog1 (notany 'null (mapcar 'fresh-line-test yes-examples) ) ; notany (close charstream) ) ; prog1 ) ; let ) ; do-test "fresh-line returns t if not at the beginning of a line" ;; (do-test "fresh-line returns nil if already at the beginning of a line" (let ((charstream (make-string-output-stream))) (declare (special charstream)) (prog1 (every 'null (mapcar 'fresh-line-test no-examples) ) ; every (close charstream) ) ; prog1 ) ; let ) ; do-test "fresh-line returns nil if already at the beginning of a line" (do-test "fresh-line writes a #\newline" ;; If fresh-line is true - i.e. if an output command has left the stream-pointer where fresh-line will actually put out a newline - the last character of the output (the first of its reverse) will be #\newline. (every #'(lambda (newline-position) (= 0 newline-position)) (mapcar #'(lambda (item) (position #\newline (reverse (with-output-to-string (charstream) (declare (special charstream)) (progn (funcall item)(fresh-line charstream)) ) ; with-output-to-string ) ) ; position ) ; lambda yes-examples ) ; mapcar ) ; every ) ; do-test "fresh-line writes a #\newline" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PPRINT.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PPRINT.TEST new file mode 100644 index 00000000..6398d30c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PPRINT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: pprint ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-pprint.test ;; ;; Syntax: pprint object &optional output-stream ;; ;; Function Description: outputs object to output-stream (default: *standard-output*) as if *print-pretty* were true. Returns no values. ;; ;; Argument(s): object - a cml object ;; output-stream - a stream ;; (do-test-group (pprint-group :before (test-setq deep '(A(B(C(D(E(F(G(H(I(J(K(L(M(N(O(P(Q(R(S(T(U(V(W(X(Y(Z))))))))))))))))))))))))))) ) ; pprint-group (do-test pprint-test (and (null (pprint deep)) (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (prog1 (null (pprint deep stream)) (close stream)) ) ; let (let ((stream (open 'file :direction :input :element-type 'unsigned-byte))) (prog1 (read stream) (close stream) (delete-file 'file)) ) ; let ) ; and ) ; do-test pprint-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1-TO-STRING.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1-TO-STRING.TEST new file mode 100644 index 00000000..c9ffe3a3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1-TO-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prin1-to-string ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 7 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-prin1-to-string.test ;; ;; Syntax: prin1-to-string object ;; ;; Function Description: outputs object as a string with escape characters. ;; ;; Argument(s): object - a cml object ;; ;; Returns: a string containing the representation of object ;; (do-test-group (prin1-to-string-group :before (progn (test-setq examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list ) ; test-setq (test-defun find-escape (object) "Look for a escape-characters in a string: at least one #\\ or two #\|'s, at the start and end, or else #\"'s at the start and end." (or (position #\\ object) (and (eq 0 (position #\| object)) (eq 0 (position #\| (reverse object))) ) ; and (and (eq 0 (position #\" object)) (eq 0 (position #\" (reverse object))) ) ; and ) ; or ) ; test-defun find-escape (test-defun compare (object) "Compare prin1-to-string with princ-to-string for a given object (symbol or string). See that the first representation contains escape characters and the second doesn't." (and (find-escape (prin1-to-string object)) (not (find-escape (princ-to-string object))) ) ) ) ; progn ) ; prin1-to-string-group (do-test "prin1-to-string all types" ;; Prin1-to-string an example of each of the standard types (every #'(lambda (object) (stringp (prin1-to-string object))) examples) ) ; do-test "prin1-to-string all types" ;; (do-test "compare prin1-to-string with princ-to-string" (every 'compare (list '|A String with Upper and Lower Case and Linefeeds| '\123 "this is a string" (make-array (1+ (random 20)) :element-type 'string-char :initial-element #\t) 'ab\c '\a\ \b\ \c) ) ) ; do-test "compare prin1-to-string with princ-to-string" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1.TEST new file mode 100644 index 00000000..5fbcfb26 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRIN1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prin1 ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 December 86 ;; ;; Last Update: 2 December 86 ;; ;; Filed As: {eris}cml>test>22-3-1-prin1.test ;; ;; Syntax: prin1 object &optional output-stream ;; ;; Function Description: outputs object to output-stream (default: *standard-output*) with escape characters. ;; ;; Argument(s): object - a cml object ;; output-stream - a stream ;; ;; Returns: object ;; (do-test-group (prin1-group :before (progn (test-setq stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte) examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list ) ; test-setq (test-defun prin1test (object) "PRIN1 an object to a file and to *standard-output*, seeing in each case that PRIN1's value is eq to the object. Verify that the result doesn't start with a newline, as PRINT's does." (and (eq object (prin1 object)) (eq object (prin1 object stream)) (not (eq 0 (position #\newline (with-output-to-string (charstream) (prin1 object charstream))))) ) ; and ) ; test-defun ) ; progn :after (progn (close stream) (delete-file 'file)) ) ; prin1-group (do-test prin1-test ;; Prin1 an example of each of the standard types (every 'prin1test examples) ) ; do-test prin1-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC-TO-STRING.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC-TO-STRING.TEST new file mode 100644 index 00000000..2bf8b3e8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC-TO-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: princ-to-string ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 7 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-princ-to-string.test ;; ;; Syntax: princ-to-string object ;; ;; Function Description: outputs object as a string without escape characters or quotation marks. ;; ;; Argument(s): object - a cml object ;; ;; Returns: a string containing the representation of object ;; (do-test-group (princ-to-string-group :before (progn (test-setq examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list ) ; test-setq (test-defun find-escape (object) "Look for a escape-characters in a string: at least one #\\ or two #\|'s, at the start and end, or else #\"'s at the start and end." (or (position #\\ object) (and (eq 0 (position #\| object)) (eq 0 (position #\| (reverse object))) ) ; and (and (eq 0 (position #\" object)) (eq 0 (position #\" (reverse object))) ) ; and ) ; or ) ; test-defun find-escape (test-defun compare (object) "Compare prin1-to-string with princ-to-string for a given object (symbol or string). See that the first representation contains escape characters and the second doesn't." (and (find-escape (prin1-to-string object)) (not (find-escape (princ-to-string object))) ) ) (test-defun princtest (object) "See that the output of princ-to-string for a given object is a string and, unless the object is a character, that is contains no escape characters." (let ((obstring (princ-to-string object))) (and (stringp obstring) (cond ((not (typep object 'character)) (not (find-escape obstring)) ) ;; Characters get this for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ) ; progn ) ; princ-to-string-group (do-test "prin1-to-string all types" ;; Princ-to-string an example of each of the standard types; see that it contains no escape characters. (every 'princtest examples) ) ; do-test "princ-to-string all types" ;; (do-test "compare prin1-to-string with princ-to-string" (every 'compare (list '|A String with Upper and Lower Case and Linefeeds| '\123 "this is a string" (make-array (1+ (random 20)) :element-type 'string-char :initial-element #\t) 'ab\c '\a\ \b\ \c) ) ) ; do-test "compare princ-to-string with princ-to-string" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC.TEST new file mode 100644 index 00000000..7f8567cc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: princ ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 2 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-princ.test ;; ;; Syntax: princ object &optional output-stream ;; ;; Function Description: PRINC is like PRIN1 in that it prints its object without a leading newline or trailing blank; it prints only the characters of its print name, omitting escape characters from atoms and flanking double quotes from strings. ;; ;; Argument(s): object - a CML object ;; output-stream - a stream (default: *standard-output*) ;; ;; Returns: object ;; (do-test-group (princ-group :before (progn (test-defun find-escape (object writefunc) "Look for a double quotation mark in a string's representation, #\| or #\\ in a symbol's. Return a position or NIL." (let ((obstring (with-output-to-string (obstream) (funcall writefunc object obstream)))) (cond ((stringp object) (position #\" obstring) ) ; stringp object (t (or (position #\| obstring) (position #\\ obstring) ) ; or ) ; t ) ; cond ) ; let ) ; test-defun find-escape (test-defun princtest (object) "Verify that an object's PRIN1 representation contains escape characters, but its PRINC representation doesn't." (and (find-escape object 'prin1) (not (find-escape object 'princ)) ) ; and ) ; test-defun ) ; progn ) ; princ-group ;; (do-test princ-on-strings-test (every 'princtest (list "string" "string with newlines" (make-array (random 50) :element-type 'string-char :initial-element #\space))) ) ; do-test princ-on-strings-test ;; (do-test princ-on-symbols-test (every 'princtest (list '|||||| 'abcd\e '|1 2 3| (make-symbol "This is a string.") (make-symbol (print "This is a string."))) ) ; every ) ; do-test princ-on-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINT.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINT.TEST new file mode 100644 index 00000000..bfb6eb2f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-PRINT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: print ;; ;; Source: CLtL p. 383 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 1 December 86 ;; ;; Last Update: 2 December 86 ;; ;; Filed As: {eris}cml>test>22-3-1-print.test ;; ;; Syntax: print object &optional output-stream ;; ;; Function Description: outputs object to output-stream (default: *standard-output*) with escape characters, preceded by a (terpri) and followed by a space. ;; ;; Argument(s): object - a cml object ;; output-stream - a stream ;; ;; Returns: object ;; (do-test-group (print-group :before (progn (test-setq stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte) examples (list (make-array '(3 5) :adjustable t) ; array '100.88 ; atom (1+ most-positive-fixnum) ; bignum 1 ; bit (make-array 3 :element-type 'bit :fill-pointer 2) ; bit-vector #\newline ; character (car (list-all-packages)) ; common #'cons ; compiled-function #c(3 3) ; complex '(1 . 2) ; cons 1.00 ; double-float #'(lambda nil 100) ; function (make-hash-table) ; hash-table 100000 ; integer :skate ; keyword (cons nil nil) ; list 2.25 ; long-float ;; nothing for type NIL nil ; null .4761 ; number *package* ; package *default-pathname-defaults* (make-random-state) 3/4 ; ratio, rational (copy-readtable) "sequence" 3.33 ; short-float "simple array" (make-array 10) ; simple-vector .5 ; single-float #\5 ; standard-char *standard-input* ; stream (make-array 5 :element-type 'string-char :adjustable t) ; string #\ ; string-char '\A\ bcd\E ; symbol nil ; t "vector" ) ; list newline " " blank " " ) ; test-setq (test-defun printtest (object) "PRINT an object to a file and to *standard-output*, seeing in each case that PRINT's value is eq to the object. Verify that it starts with a newline and ends with a space." (let ((stringstream (with-output-to-string (charstream) (print object charstream)))) (and (eq object (print object)) (eq object (print object stream)) ;; Acknowledgements to Bob Bane. (= 0 (search newline stringstream)) (= 0 (search blank (reverse stringstream))) ) ; and ) ; let ) ; test-defun ) ; progn :after (progn (close stream) (delete-file 'file)) ) ; print-group (do-test print-test ;; Print an example of each of the standard types (every 'printtest examples) ) ; do-test print-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-TERPRI.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-TERPRI.TEST new file mode 100644 index 00000000..0bc433d5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-TERPRI.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: terpri ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-terpri.test ;; ;; Syntax: terpri &optional output-stream ;; ;; Function Description: puts a newline out unconditionally to stream ;; ;; Argument(s): stream - a stream (defaults to *standard-output*) ;; ;; Returns: nil ;; (do-test-group (do-test "terpri returns nil" (every 'null (list (terpri) (terpri *standard-output*) (let ((outstream (make-string-output-stream))) (write 4761 :stream outstream) (terpri outstream) ) ) ) ; every ) ; do-test "terpri returns nil" ;; (do-test "terpri outputs #\newline unconditionally" (every #'(lambda (writefunc) (position #\newline (with-output-to-string (charstream) (declare (special charstream)) (funcall writefunc) ) ; with-output-to-string ) ; position ) ; lambda (list #'(lambda () (terpri charstream)) #'(lambda () (progn (write-line "This is a test" charstream) (terpri charstream))) #'(lambda () (progn (write-string "This is a test" charstream) (terpri charstream))) #'(lambda () (progn (terpri charstream) (write-string "This is a test" charstream))) #'(lambda () (progn (write 5 :stream charstream) (terpri charstream) (write-char #\? charstream))) ) ; list ) ; every ) ; do-test "terpri outputs #\newline unconditionally" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-CHAR.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-CHAR.TEST new file mode 100644 index 00000000..7c51263a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-CHAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: write-char ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-write-char.test ;; ;; Syntax: write-char character &optional output-stream ;; ;; Function Description: writes character to output-stream (default: *standard-output*) ;; ;; Argument(s): character - a character ;; output-stream - a stream ;; ;; Returns: character ;; (do-test-group (write-char-group :before (progn (test-setq charlist ;; 94 standard characters (CLtL p. 21) plus space and newline (2 notations each) '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\< #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\space #\ #\newline #\ )) (test-defun readback (character) "Write-char a character to a file and read-char it back; return the character read." (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (write-char character stream) (close stream) ) (let ((stream (open 'file :element-type 'unsigned-byte :direction :input))) (prog1 (read-char stream) (close stream) (delete-file 'file)) ) ) ; test-defun readback ;; (test-defun write-char-test (char) "See if a character read back is the same one written out." (char= char (readback char)) ) ) ; progn ) ; write-char-group (do-test "write-char to default stream" (every #'(lambda (char) (char= (write-char char) char)) charlist) ) ; do-test "write-char to default stream" ;; (do-test "write-char and read back" (every 'write-char-test charlist) ) ; do-test "write-char and read back" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-LINE.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-LINE.TEST new file mode 100644 index 00000000..88fc2811 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-LINE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: write-line ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>22-3-1-write-line.test ;; ;; Syntax: write-line string &optional output-stream &key :start :end ;; ;; Function Description: writes string (delimited by :start and :end) to output-stream ;; ;; Argument(s) ;; string: a string ;; output-stream: a stream (default: *standard-output*) ;; :start, :end: delimiters within string. ;; ;; Returns: string (entire, regardless of :start and :end) ;; ;;NOTE: the test files for write-line and write-line contain virtually identical code, and changes to one file should be made to the other. ;; (do-test-group (write-line-group :before (progn (test-setq simcase "simple case" sclen (length simcase) newline " " rand1 (random 10) rand2 (* rand1 (1+ (random 3)))) ; test-setq (test-defun readback (write-line-call) "Write-string an expression to a file (with variable write call) and read-line it back; return the object read." (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (declare (special stream)) (funcall write-line-call) (close stream) ) (let ((stream (open 'file :element-type 'unsigned-byte :direction :input))) (prog1 (read-line stream) (close stream) (delete-file 'file)) ) ) ; test-defun readback ;; (test-defun compare ( writestringcall writelinecall) "See that a string written with write-string does not end with #\newline while a string written with write-line does." (and (not (eq 0 (search newline (revstring writestringcall)))) (= 0 (search newline (revstring writelinecall))) ) ; and ) ;; (test-defun revstring (writecall) "Reverse string, capturing the end-character that write-line may have added." (reverse (with-output-to-string (charstream) (declare (special charstream)) (funcall writecall) ) ) ; reverse ) ; test-defun revstring ) ; progn ) ; write-line-group ;; NOTE: not working in 18 Nov. sysout; write-line returns the substring, not the full string (AR 7023). (do-test "write-line returns the full input string" (every #'(lambda (string start end) (string= string (write-line string nil :start start :end end))) (list simcase "string with linefeeds and spaces." (make-array 25 :initial-element #\newline :element-type 'string-char)) (list 0 (random 5) 2) (list sclen (+ 5 (random 20)) 19) ) ) ; do-test "write-line returns the full input string" ;; (do-test "write-line writes just the substring" (every #'(lambda (string start end) (string= (subseq string start end) (readback #'(lambda () (write-line string stream :start start :end end))) ) ; string= ) ; lambda (list simcase (make-array 50 :element-type 'string-char :initial-element #\" :adjustable t) (symbol-name '|This is a symbol.|)) (list 0 (random 20) 4) (list sclen (+ 20 (random 32)) 10) ) ) ; do-test "write-string writes just the substring" ;; (do-test "write-string doesn't add a linefeed, while write-line does" (every 'compare (list #'(lambda nil (write-string simcase charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) (list #'(lambda nil (write-line simcase charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) ) ; every ) ; do-test "write-string doesn't add a linefeed, while write-line does" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-STRING.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-STRING.TEST new file mode 100644 index 00000000..95543859 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-1-WRITE-STRING.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: write-string ;; ;; Source: CLtL p. 384 ;; ;; Chapter 22: Input/Output Section 3.1: Output to Character Streams ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 8 December 86 ;; ;; Last Update: JRB - 9 March 87 - Fixed bug in rand{12} selection ;; ;; Filed As: {eris}cml>test>22-3-1-write-string.test ;; ;; Syntax: write-string string &optional output-stream &key :start :end ;; ;; Function Description: writes string (delimited by :start and :end) to output-stream ;; ;; Argument(s) ;; string: a string ;; output-stream: a stream (default: *standard-output*) ;; :start, :end: delimiters within string. ;; ;; Returns: string (entire, regardless of :start and :end) ;; ;;NOTE: the test files for write-string and write-line contain virtually identical code, and changes to one file should be made to the other. ;; (do-test-group (write-string-group :before (progn (test-setq simcase "simple case" sclen (length simcase) newline " " rand1 (random 10) rand2 (+ (random 3) 10)) ; test-setq (test-defun readback (write-string-call) "Write-string an expression to a file (with variable write call) and read-line it back; return the object read." (let ((stream (open 'file :direction :output :if-exists :new-version :if-does-not-exist :create :element-type 'unsigned-byte))) (declare (special stream)) (funcall write-string-call) (close stream) ) (let ((stream (open 'file :element-type 'unsigned-byte :direction :input))) (prog1 (read-line stream) (close stream) (delete-file 'file)) ) ) ; test-defun readback ;; (test-defun compare ( writestringcall writelinecall) "See that a string written with write-string does not end with #\newline while a string written with write-line does." (and (not (eq 0 (search newline (revstring writestringcall)))) (= 0 (search newline (revstring writelinecall))) ) ; and ) ;; (test-defun revstring (writecall) "Reverse string, capturing the end-character that write-line may have added." (reverse (with-output-to-string (charstream) (declare (special charstream)) (funcall writecall) ) ) ; reverse ) ; test-defun revstring ) ; progn ) ; write-string-group ;; NOTE: not working in 18 Nov. sysout; write-line returns the substring, not the full string (AR 7023). (do-test "write-string returns the full input string" (every #'(lambda (string start end) (string= string (write-string string nil :start start :end end))) (list simcase "string with linefeeds and spaces." (make-array 25 :initial-element #\newline :element-type 'string-char)) (list 0 (random 5) 2) (list sclen (+ 5 (random 20)) 19) ) ) ; do-test "write-string returns the full input string" ;; (do-test "write-string writes just the substring" (every #'(lambda (string start end) (string= (subseq string start end) (readback #'(lambda () (write-string string stream :start start :end end))) ) ; string= ) ; lambda (list simcase (make-array 50 :element-type 'string-char :initial-element #\" :adjustable t) (symbol-name '|This is a symbol.|)) (list 0 (random 20) 4) (list sclen (+ 20 (random 32)) 10) ) ) ; do-test "write-string writes just the substring" ;; (do-test "write-string doesn't add a linefeed, while write-line does" (every 'compare (list #'(lambda nil (write-string simcase charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-string (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) (list #'(lambda nil (write-line simcase charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream)) #'(lambda nil (write-line (symbol-name '|This expression has to be at least thirty characters long|) charstream :start rand1 :end rand2)) ) ) ; mapcar ) ; do-test "write-string doesn't add a linefeed, while write-line does" ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/22/22-3-3-FORMAT.TEST b/internal/test/LANGUAGE/from-sun/language/22/22-3-3-FORMAT.TEST new file mode 100644 index 00000000..6c480bde --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/22/22-3-3-FORMAT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested:format ;; ;; Source: Guy L Steele's CLTL ;; Section: 22 Input/Output (Section 22.3.3 - Formatted Output to Character Streams) ;; Page: 385 ;; ;; Created By: John Park ;; ;; Creation Date: Dec 3, 1986 ;; ;; Last Update: Feb 3, 1987 - Jim Blum - small changes to make it run on the SUN ;; Feb 6, 1987 - Bob Bane ;; Feb 9, 1987 - Jim Blum - Added missing paren to TAB test. ;; Feb 16, 1987 - Bob Bane - Fixes for format-new-line-character ;; and format-justification tests. ;; Feb 26, 1987 - Bob Bane - Added an error-check case to format-radix. ;; ;; Filed As: {ERIS}CML>TEST>22-3-3-format.test ;; ;; ;; Syntax: (format destination control-string &rest arguments) ;; ;; Function Description: This function is used to produce formatted output. ;; Format outputs the characters of control-string, except that a tilde (~) introduces ;; a directive. The character after the tilde, possibly preceded by prefic parameters ;; and modifiers, specifies what kind of formatting is desired. Most directives use ;; one or more elements of arguments to create their output; the typical directive ;; puts the next element of arguments into the output, formatted in some special way. ;; It is an error if no argument remains for a directive requiring an argument, but ;; it is not an error if one or more arguments remain unprocessed by a directive. ;; ;; Argument(s): destination - where output is sent (NIL or stream) ;; control-string - string containing directive for formatting output ;; arguments - Parameter(s) to the directive ;; ;; Returns: Formatted output (string or NIL) ;; ;; Constraints/Limitations: (do-test "format-ascii" (let ((w '(a b c)) (x 'lion) (y "elephant") (z 292)) (and (string-equal (format nil "foo") "foo") (string-equal (format nil "Look at the ~A!" y) "Look at the elephant!") (string-equal (format nil "Look at the ~A!" x) "Look at the lion!") (string-equal (format nil "Look at the number ~A!" z) "Look at the number 292!") (string-equal (format nil "Look at ~A!" w) "Look at (a b c)!") (string-equal (format nil "Look at the ~10A!" y) "Look at the elephant !") (string-equal (format nil "Look at the ~10@A!" y) "Look at the elephant!") (string-equal (format nil "Look at the (~:A)!" y) "Look at the (elephant)!") ) ) ) (do-test "format-S-expression" (let ((x 'lion) (y "elephant") (z 292)) (and (string-equal (format nil "Look at the ~S!" y) "Look at the \"elephant\"!") (string-equal (format nil "Look at the ~S!" x) "Look at the lion!") (string-equal (format nil "Look at the number ~S!" z) "Look at the number 292!") ) ) ) (do-test "format-decimal" (let ((n 3) (n1 -3) (n2 12982298)) (and (string-equal (format nil "The answer is ~D." n) "The answer is 3.") (string-equal (format nil "The answer is ~3D." n) "The answer is 3.") (string-equal (format nil "The answer is ~3D." n1) "The answer is -3.") (string-equal (format nil "The answer is ~3@D." n) "The answer is +3.") (string-equal (format nil "The answer is ~7D." n2) "The answer is 12982298.") (string-equal (format nil "The answer is ~:D." n2) "The answer is 12,982,298.") (string-equal (format nil "The answer is ~:D." (expt 1000 n)) "The answer is 1,000,000,000.") (string-equal (format nil "The answer is ~15,'0,:D." n2) "The answer is 0000012,982,298.") ) ) ) (do-test "format-binary" (let ((n 3) (n1 -3) (n2 123)) (and (string-equal (format nil "The answer is ~B." n) "The answer is 11.") (string-equal (format nil "The answer is ~4B." n) "The answer is 11.") (string-equal (format nil "The answer is ~4@B." n) "The answer is +11.") (string-equal (format nil "The answer is ~4B." n1) "The answer is -11.") (string-equal (format nil "The answer is ~10B." n2) "The answer is 1111011.") (string-equal (format nil "The answer is ~:B." n2) "The answer is 1,111,011.") (string-equal (format nil "The answer is ~:B." (expt 2 10)) "The answer is 10,000,000,000.") (string-equal (format nil "The answer is ~15,'0,:B." n2) "The answer is 0000001,111,011.") ) ) ) (do-test "format-octal" (let ((n 8) (n1 -8) (n2 1000)) (and (string-equal (format nil "The answer is ~O." n) "The answer is 10.") (string-equal (format nil "The answer is ~4O." n) "The answer is 10.") (string-equal (format nil "The answer is ~4@O." n) "The answer is +10.") (string-equal (format nil "The answer is ~4O." n1) "The answer is -10.") (string-equal (format nil "The answer is ~10O." n2) "The answer is 1750.") (string-equal (format nil "The answer is ~:O." n2) "The answer is 1,750.") (string-equal (format nil "The answer is ~15,'0,:O." n2) "The answer is 00000000001,750.") ) ) ) (do-test "format-hexadecimal" (let ((n 10) (n1 -10) (n2 10191)) (and (string-equal (format nil "The answer is ~X." n) "The answer is A.") (string-equal (format nil "The answer is ~4X." n) "The answer is A.") (string-equal (format nil "The answer is ~4@X." n) "The answer is +A.") (string-equal (format nil "The answer is ~4X." n1) "The answer is -A.") (string-equal (format nil "The answer is ~10X." n2) "The answer is 27CF.") (string-equal (format nil "The answer is ~:X." n2) "The answer is 2,7CF.") (string-equal (format nil "The answer is ~15,'0,:X." n2) "The answer is 00000000002,7CF.") ) ) ) (do-test "format-radix" (let ((n 3) (n1 -3) (n2 12982298) (r 12)) (and (string-equal (format nil "The answer is ~10R." n) "The answer is 3.") (string-equal (format nil "The answer is ~10,3R." n) "The answer is 3.") (string-equal (format nil "The answer is ~10,3R." n1) "The answer is -3.") (string-equal (format nil "The answer is ~10,3@R." n) "The answer is +3.") (string-equal (format nil "The answer is ~10,7R." n2) "The answer is 12982298.") (string-equal (format nil "The answer is ~10,:R." n2) "The answer is 12,982,298.") (string-equal (format nil "The answer is ~10,:R." (expt 1000 n)) "The answer is 1,000,000,000.") (string-equal (format nil "The answer is ~10,15,'0,:R." n2) "The answer is 0000012,982,298.") ;full radix form (expect-errors (il:format-error) (format nil "~:R" 1/2)) ;; The following tests various radix cases. (string-equal (format nil "~D in radix ~D is ~2R." r 2 r) "12 in radix 2 is 1100.") (string-equal (format nil "~D in radix ~D is ~3R." r 3 r) "12 in radix 3 is 110.") (string-equal (format nil "~D in radix ~D is ~4R." r 4 r) "12 in radix 4 is 30.") (string-equal (format nil "~D in radix ~D is ~5R." r 5 r) "12 in radix 5 is 22.") (string-equal (format nil "~D in radix ~D is ~6R." r 6 r) "12 in radix 6 is 20.") (string-equal (format nil "~D in radix ~D is ~7R." r 7 r) "12 in radix 7 is 15.") (string-equal (format nil "~D in radix ~D is ~8R." r 8 r) "12 in radix 8 is 14.") (string-equal (format nil "~D in radix ~D is ~9R." r 9 r) "12 in radix 9 is 13.") (string-equal (format nil "~D in radix ~D is ~10R." r 10 r) "12 in radix 10 is 12.") (string-equal (format nil "~D in radix ~D is ~11R." r 11 r) "12 in radix 11 is 11.") (string-equal (format nil "~D in radix ~D is ~12R." r 12 r) "12 in radix 12 is 10.") (string-equal (format nil "~D in radix ~D is ~13R." r 13 r) "12 in radix 13 is C.") (string-equal (format nil "~D in radix ~D is ~14R." r 14 r) "12 in radix 14 is C.") (string-equal (format nil "~D in radix ~D is ~15R." r 15 r) "12 in radix 15 is C.") (string-equal (format nil "~D in radix ~D is ~16R." r 16 r) "12 in radix 16 is C.") ;; The following tests various directive cases for formatting a numer (string-equal (format nil "~R is a cardinal number." 4) "four is a cardinal number.") (or (string-equal (format nil "~R is a cardinal number." -4) "negative four is a cardinal number.") (string-equal (format nil "~R is a cardinal number." -4) "minus four is a cardinal number.")) (string-equal (format nil "~:R is an ordinal number." 4) "fourth is an ordinal number.") (string-equal (format nil "~@R is a roman number ~D." 4 4) "IV is a roman number 4.") (string-equal (format nil "~:@R is an old roman number ~D." 4 4) "IIII is an old roman number 4.") ) ) ) (do-test "format-plural" (let ((zero 0) (singular 1) (plural 7) (float-pt 9.99)) (and (string-equal (format nil "~D tr~:@p/~D win~:P." plural singular) "7 tries/1 win.") (string-equal (format nil "~D tr~:@p/~D win~:P." singular zero) "1 try/0 wins.") (string-equal (format nil "~D tr~:@p/~D win~:P." float-pt plural) "9.99 tries/7 wins.") ) ) ) (do-test "format-character" ;; Implementation or I/O dependent characters (i.e. control-C) are not included (let ((a #\a) (Z #\Z) (n #\1) (s #\*) (ch 'character) (Space #\ ) (Tab #\ ) (Newline #\ )) (and (string-equal (format nil "This is character ~C" a) "This is character a") (string-equal (format nil "This is character ~C" Z) "This is character Z") (string-equal (format nil "This is character ~C" n) "This is character 1") (string-equal (format nil "This is special character ~C" s) "This is special character *") (string-equal (format nil "This is character ~@C" a) "This is character #\\a") (string-equal (format nil "This is character ~@C" Z) "This is character #\\Z") (string-equal (format nil "This is character ~@C" n) "This is character #\\1") (string-equal (format nil "This is special character ~@C" s) "This is special character #\\*") (string-equal (format nil "This is non-printing ~A ~:C" ch Space) "This is non-printing character Space") (string-equal (format nil "This is non-printing ~A ~:C" ch Tab) "This is non-printing character Tab") (string-equal (format nil "This is non-printing ~A ~:C" ch newline) "This is non-printing character newline") (string-equal (format nil "This is non-printing ~A ~:@C" ch Space) "This is non-printing character Space") (string-equal (format nil "This is non-printing ~A ~:@C" ch Tab) "This is non-printing character Tab") (string-equal (format nil "This is non-printing ~A ~:@C" ch newline) "This is non-printing character newline") ) ) ) (do-test "format-fixed-floating-point" (and (defun format-float (x) (format nil "~6,2F:~6,2,1,'*F:~6,2,,'?F:~6F:~,2F:~F" x x x x x x)) (string-equal (format-float 3.14159) " 3.14: 31.42: 3.14:3.1416:3.14:3.14159") (string-equal (format-float -3.14159) " -3.14:-31.42: -3.14:-3.142:-3.14:-3.14159") (string-equal (format-float 100.0) "100.00:******:100.00: 100.0:100.00:100.0") (string-equal (format-float 1234.0) "1234.00:******:??????:1234.0:1234.00:1234.0") (string-equal (format-float 0.006) " 0.01: 0.06: 0.01: 0.006:0.01:0.006") (string-equal (format-float -0.006) " -0.01: -0.06: -0.01:-0.006:-0.01:-0.006") (string-equal (format-float 2/3) " 0.67: 6.67: 0.67:.66667:0.67:0.6666667") (string-equal (format-float 4/2) " 2.00: 20.00: 2.00: 2.0:2.00:2.0") (string-equal (format-float 4/2) " 2.00: 20.00: 2.00: 2.0:2.00:2.0") (string-equal (format-float 1234) "1234.00:******:??????:1234.0:1234.00:1234.0") ) ) (do-test "format-exponential-floating-point" (and (defun format-exponent (x) (format nil "~9,2,1,,'*E:~10,3,2,2,'?,,'$E:~9,3,2,-2,'%@e:~9,2E" x x x x)) (string-equal (format-exponent 3.14159) " 3.14E+0: 31.42$-01:+.003E+03: 3.14E+0") (string-equal (format-exponent -3.14159) " -3.14E+0:-31.42$-01:-.003E+03: -3.14E+0") (string-equal (format-exponent 1100.0) " 1.10E+3: 11.00$+02:+.001E+06: 1.10E+3") (or (string-equal (format-exponent 1100.0L0) " 1.10L+3: 11.00$+02:+.001L+06: 1.10L+3") (string-equal (format-exponent 1100.0L0) " 1.10E+3: 11.00$+02:+.001E+06: 1.10E+3")) (string-equal (format-exponent 1.1E13) "*********: 11.00$+12:+.001E+16: 1.10E+13") (or (string-equal (format-exponent 1.1L36) "*********: 11.00$+35:+.001L+39: 1.10L+36") (string-equal (format-exponent 1.1L36) "*********: 11.00$+35:+.001E+39: 1.10E+36")) ) ) ; AR 7427 (do-test "format-general-floating-point" (and (defun format-general-float (x) (format nil "~9,2,1,,'*G:~9,3,2,3,'?,,'$G:~9,3,2,0,'%G:~9,2G" x x x x)) (string-equal (format-general-float 0.0314159) " 3.14E-2:314.2$-04:0.314E-01: 3.14E-2") (string-equal (format-general-float 0.314159) " 0.31 :0.314 :0.314 : 0.31 ") (string-equal (format-general-float 3.14159) " 3.1 : 3.14 : 3.14 : 3.1 ") (string-equal (format-general-float 31.4159) " 31. : 31.4 : 31.4 : 31. ") (string-equal (format-general-float 314.159) " 3.14E+2: 314. : 314. : 3.14E+2") (string-equal (format-general-float 3141.59) " 3.14E+3:314.2$+01:0.314E+04: 3.14E+3") (or (string-equal (format-general-float 3141.59L0) " 3.14L+3:314.2$+01:0.314L+04: 3.14L+3") (string-equal (format-general-float 3141.59L0) " 3.14E+3:314.2$+01:0.314E+04: 3.14E+3")) (string-equal (format-general-float 3.14E12) "*********:314.0$+10:0.314E+13: 3.14E+12") (or (string-equal (format-general-float 3.14L36) "*********:314.0$+34:0.314L+37: 3.14L+36") (string-equal (format-general-float 3.14L36) "*********:314.0$+34:0.314E+37: 3.14E+36")) ) ) ; bug AR 7427 (do-test "format-dollars-floating-point" (and (defun format-dollars-float (x) (format nil "~$:~3,3,7,'*$:~,,10,'*$:~0,,10,'*$" x x x x )) (string-equal (format-dollars-float 0.99) "0.99:000.990:******0.99:********1.") (string-equal (format-dollars-float 10.99) "10.99:010.990:*****10.99:*******11.") (string-equal (format-dollars-float 119.99) "119.99:119.990:****119.99:******120.") (string-equal (format-dollars-float 12345.78) "12345.78:12345.780:**12345.78:****12346.") (string-equal (format-dollars-float 12762877.49) "12762877.00:12762877.000:12762877.00:*12762877.") ) ) (do-test "format-new-line-character" (and (string-equal (format nil "Hello~%~20TToday is Monday.") "Hello Today is Monday.") (string-equal (format nil "Hello~2%~20TToday is Monday.") "Hello Today is Monday.") ) ) (do-test "format-fresh-line" (and (string-equal (format nil "Hello~&") "Hello ") (string-equal (format nil "Hello~2&") "Hello ") (string-equal (format nil "Hello~2&") "Hello ") ) ) (do-test "format-page-separator-character" (and (string-equal (format nil "Hello~|") "Hello ") (string-equal (format nil "Hello~2|") "Hello ") ) ) (do-test "format-tilde" (and (string-equal (format nil "outputs ~D ~~~:P" 1) "outputs 1 ~") (string-equal (format nil "outputs ~D ~2~~:P" 2) "outputs 2 ~~s") (string-equal (format nil "outputs ~D ~3~~:P" 3) "outputs 3 ~~~s") ) ) (do-test "format-tilde-newline" (and (defun type-clash-error (fn nargs argnum right-type wrong-type) (format nil "~&~S requires its ~:[~:R~;~*~] ~ argument to be of type ~S, ~%but it was called ~ with an argument of type ~S." fn (eql nargs 1) argnum right-type wrong-type)) (string-equal (type-clash-error 'aref nil 2 'integer 'vector) "AREF requires its second argument to be of type INTEGER, but it was called with an argument of type VECTOR.") (string-equal (type-clash-error 'car 1 1 'list 'short-float) "CAR requires its argument to be of type LIST, but it was called with an argument of type SHORT-FLOAT.") ) ) (do-test "format-tab" (and (string-equal (format nil "a~3Tb~5Tc~7Td~9Te~11Tf~13Tg~15Th") "a b c d e f g h") (string-equal (format nil "a~3@Tb~5@Tc~7@Td") "a b c d") (or (string-equal (format nil "a~3,8@Tb") "a b") (string-equal (format nil "a~3,8@Tb") "a b") ) ) ) (do-test "format-indirection" (and (string-equal (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) " 7") (string-equal (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) " 7") (string-equal (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) " 7") (string-equal (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) " 14") ) ) (do-test "format-case-conversion" (and (defun f (n) (format nil "~@(~R~) error~:P detected." n)) (equal (format nil "~:(~A~)" "this capitalizes all words") "This Capitalizes All Words") (equal (format nil "~@(~A~)" "this capitalizes just the first word") "This capitalizes just the first word") (equal (format nil "~:@(~A~)" "This converts every Lowercase character to upper case character") "THIS CONVERTS EVERY LOWERCASE CHARACTER TO UPPER CASE CHARACTER") (equal (format nil "~@R ~(~@R~)" 14 14) "XIV xiv") (equal (f 0) "Zero errors detected.") (equal (f 1) "One error detected.") (equal (f 23) "Twenty-three errors detected.") ) ) (do-test "format-conditional-expression" (string-equal (format nil "~[Siamese~;Manx~;Persian~] cat" 0) "Siamese cat") (string-equal (format nil "~[Siamese~;Manx~;Persian~] cat" 1) "Manx cat") (string-equal (format nil "~[Siamese~;Manx~;Persian~] cat" 2) "Persian cat") (string-equal (format nil "~[false~;true~]" 0) "false") (let ((*print-level* nil) (*print-length* 5)) (string-equal (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) " print length = 5") ) (let ((foo "Items:~#[ none~; ~S~; ~S and ~S~ ~:;~@{~#[~; and ~] ~S~^,~}~].")) (and (string-equal (format nil foo) "Items: none.") (string-equal (format nil foo 'foo) "Items: FOO.") (string-equal (format nil foo 'foo 'bar) "Items: FOO and BAR.") (string-equal (format nil foo 'foo 'bar 'baz) "Items: FOO, BAR, and BAZ.") (string-equal (format nil foo 'foo 'bar 'baz 'quux) "Items: FOO, BAR, BAZ, and QUUX.") ) ) ) (do-test "format-iteration" (and (string-equal (format nil "The winners are:~{ ~S~}." '(fred harry jill)) "The winners are: Fred harry jill.") (string-equal (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) "Pairs: .") (string-equal (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) "Pairs: .") (string-equal (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) "Pairs: .") (string-equal (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) "Pairs: .") ) ) (do-test "format-justification" (and (string-equal (format nil "~10") "FOO BAR") (string-equal (format nil "~10:") " FOO BAR") (string-equal (format nil "~10:@") " FOO BAR ") (string-equal (format nil "~10") " FOOBAR") (string-equal (format nil "~10:") " FOOBAR") (string-equal (format nil "~10@") "FOOBAR ") (string-equal (format nil "~10:@") " FOOBAR ") ) ) (do-test "format-escape-construct" (and (let ((donestr "Done. ~^ ~D Warning~:P.~^ ~D error~:P.")) (and (string-equal (format nil donestr) "Done. ") (string-equal (format nil donestr 3) "Done. 3 warnings.") (string-equal (format nil donestr 1 5) "Done. 1 warning. 5 errors.") ) ) (let ((tellstr "~@(~@[~R~]~^ ~A.~)")) (and (equal (format nil tellstr 23) "Twenty-three") (equal (format nil tellstr nil "losers") " Losers.") (equal (format nil tellstr 23 "losers") "Twenty-three losers.") ) ) (let ((up-out-str "~15<~S~;~^~S~;~^~S~>")) (and (string-equal (format nil up-out-str 'foo) " FOO") (string-equal (format nil up-out-str 'foo 'bar) "FOO BAR") (string-equal (format nil up-out-str 'foo 'bar 'baz) "FOO BAR BAZ") ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/.DFASL b/internal/test/LANGUAGE/from-sun/language/23/.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e838a8886a7aa7d19046b8256c1be0b8526010ed GIT binary patch literal 165 zcmbQpz#8G~qu`vMTacNPTBML)T2fG2qL7wfq)?n+T9llskOmZ2sCEtV46e0ta`bbx z)3Y|@3PzGkE=o--Nlj7k&Cg3otkh93v`}y?D9X%HFtoI=&`~flwlXxfGBwiUa&rv! hffxtV5>lF44AEnWqQ}s{%Fx`(#6XYh|15_8{{bv@Gy(ts literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-MAKE-PATHNAME.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-MAKE-PATHNAME.X new file mode 100644 index 00000000..96439b8e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-MAKE-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: MAKE-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 416 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 12,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-MAKE-PATHNAME.TEST ;; ;; ;; Syntax: (MAKE-PATHNAME &key :host :device :directory ;; :name :type :version :defaults) ;; ;; ;; ;; Function Description: ;; creates a pathname ;; ;; ;; ;; Argument(s): host - the name of the host ;; device - the name of the device ;; directory - the name of the directory ;; name - the name of the file ;; type - the type of file it is ;; version - the version of the file ;; defaults - the default values ;; ;; Returns: a pathname ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.dfasl")) T) ; get here and functions were defined (do-test "test a simple case" (let ((temp-pathname (make-pathname :host "core" :name "hello"))) (and (pathnamep temp-pathname) (string-equal "{CORE}HELLO" (namestring temp-pathname)) ))) (do-test "check defaulting works." (let ((temp-namestring (namestring *default-pathname-defaults*)) (t-host-namestring (host-namestring *default-pathname-defaults*))) (and (equal temp-namestring (namestring (make-pathname :defaults *default-pathname-defaults*))) (equal (concatenate 'string "{" t-host-namestring "}") (namestring (make-pathname))) ))) ;;; test do same type of test on several different HOSTS (do-test "test a couple simple variations, core" (and (23DRIVE-MAKE-LIST "{CORE}TEMPDEVICE:HELLO.TYPE;2" "core" "tempdevice" "tempdir" "hello" "type" 2) (23DRIVE-MAKE-LIST "{CORE}HELLO.TYPE;2" "core" nil "tempdir" "hello" "type" 2) (23DRIVE-MAKE-LIST "{CORE}TEMPDEVICE:HELLO.TYPE;2" "core" "tempdevice" nil "hello" "type" 2) (23DRIVE-MAKE-LIST "{CORE}HELLO.TYPE;2" "core" nil nil "hello" "type" 2) )) (do-test "test a couple simple variations, dsk" (23DRIVE-MAKE-LIST "{DSK}TEMPDIR>HELLO.TYPE;2" "dsk" NIL "lispfiles>tempdir" "hello" "type" 2)) (do-test "test a couple simple variations, erinyes" (23DRIVE-MAKE-LIST "{ERINYES}HELLO.TYPE;2" "erinyes" nil "CMLTEST" "hello" "type" 2)) (do-test "test a couple simple variations, pollux" (23DRIVE-MAKE-LIST "{POLLUX:AISNORTH:XEROX}HELLO.TYPE;2" "pollux:aisnorth:xerox" nil "CMLTEST" "hello" "type" 2)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-MERGE-PATHNAME.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-MERGE-PATHNAME.X new file mode 100644 index 00000000..2b549251 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-MERGE-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: MERGE-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 415 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 11,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-MERGE-PATHNAME.TEST ;; ;; ;; Syntax: (MERGE-PATHNAME pathname &optional defaults default-version) ;; ;; ;; ;; Function Description: ;; returns the name of the file as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; defaults - the default values ;; default-version - the default version ;; ;; Returns: the name of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.dfasl")) T) ; get here and functions were defined (do-test "test a simple case" (23check-merge "{CORE}TEMPDEVICE:HELLO.TYPE" "hello" "{CORE}TEMPDEVICE:NAME.TYPE")) ;;; test do same type of test on several different HOSTS (do-test "test lots of variations in {CORE}" (let ((temp-name (string (gensym)))) (23DRIVE-MERGE-LIST-STREAM (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1") "CORE" NIL NIL temp-name NIL "CORE" "TEMPDEVICE" "TEMPDIR" temp-name "TYPE" 1) )) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (MERGE-PATHNAMES value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ; get ride of some stuff, what's the better way? ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-NAMESTRING.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-NAMESTRING.X new file mode 100644 index 00000000..89590449 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-NAMESTRING.X @@ -0,0 +1 @@ +;; Function To Be Tested: NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 7,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-NAMESTRING.TEST ;; ;; ;; Syntax: (NAMESTRING pathname) ;; ;; ;; ;; Function Description: ;; returns the full name of the file ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the full name of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq temp-name (string (gensym))) (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdev" "tempdir" temp-name "type"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-list simple-list 'name (concatenate 'string "{CORE}TEMPDEV:" temp-name ".TYPE"))) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23DRIVE-NAMESTRING-LIST (host device dir name type expectvalue) "build the list and check get what want" (let* ((delete-list (23BUILD-LIST-OF-STREAM host 1 device dir name type)) (big-list (23Multiply-stream delete-list)) (result (23TEST-NAMESTRING-VALUE-list big-list 'name expectvalue))) (23Delete-file-list delete-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (let ((temp-name (string (gensym)))) (and (23DRIVE-NAMESTRING-LIST "core" nil "tdir" temp-name nil (concatenate 'string "{CORE}" temp-name ".;1")) (23DRIVE-NAMESTRING-LIST "core" "tdev12-23" "cmlfiletest>sub" temp-name "type" (concatenate 'string "{CORE}TDEV12-23:SUB>" temp-name ".TYPE;1")) ))) (do-test "test lots of variations in {dsk}" (let ((temp-name (string (gensym)))) (23DRIVE-NAMESTRING-LIST "dsk" nil "lispfiles>cmltest>sub" temp-name "type" (concatenate 'string "{DSK}CMLTEST>SUB>" temp-name ".TYPE;1")) )) (do-test "test lots of variations in {ERINYES}" (let ((temp-name (string (gensym)))) (23DRIVE-NAMESTRING-LIST "erinyes" nil "cmltest>sub" temp-name "type" (concatenate 'string "{ERINYES}SUB>" temp-name ".TYPE;1")) )) (do-test "test lots of variations in {POLLUX:AISNORTH:XEROX}" (let ((temp-name (string (gensym)))) (23DRIVE-NAMESTRING-LIST "pollux:aisnorth:xerox" nil "cmltest>sub" temp-name "type" (concatenate 'string "{POLLUX:AISNORTH:XEROX}SUB>" temp-name ".TYPE;1")) )) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (namestring value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PARSE-NAMESTRING.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PARSE-NAMESTRING.X new file mode 100644 index 00000000..ca07f46a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PARSE-NAMESTRING.X @@ -0,0 +1 @@ +;; Function To Be Tested: PARSE-NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 414 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PARSE-NAMESTRING.TEST ;; ;; ;; Syntax: (PARSE-NAMESTRING thing &optional host defaults ;; &key :start :end :junk-allowed) ;; ;; ;; ;; Function Description: ;; Turns thing into a pathname ;; ;; ;; ;; Argument(s): thing - a string, or symbol, or pathname, or stream ;; host - where ought to be ;; defaults - the default values ;; start - where start in the string ;; end - where end in the string ;; junk-allowed - could there be junk in the string? ;; ;; Returns: a pathname ;; ;; comment: For most tests don't need to worry about host ;; and default for the file system doesn't need ;; the information. See page 414. (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-name "{core}any-name.type") (temp-pathname (parse-namestring temp-name))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Parse-Basic (host) (let* ((temp-name (concatenate 'string "{" host "}any-name.type")) (temp-pathname (parse-namestring temp-name))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23Parse-Variable-Type (host) (let* ((temp-pathname (23BUILD-PATHNAME host)) (temp-stream (open temp-pathname :direction :io)) (toss-away (close temp-stream)) (expect (namestring temp-stream)) (temp-list (23Multiply-stream (list temp-stream))) (result (23check-parse-list expect temp-list))) (delete-file temp-stream) result)) (test-defun 23Parse-Junk (host) (let* ((temp-name (concatenate 'string " uh {" host "}any-name.type")) (temp-pathname (parse-namestring temp-name :junk-allowed T))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23Parse-Start (host) (let* ((temp-name (concatenate 'string " uh {" host "}any-name.type")) (temp-pathname (parse-namestring temp-name :start 5))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23Parse-End (host) (let* ((temp-name (concatenate 'string "{" host "}any-name.type uh")) (string-length (length temp-name)) (temp-pathname (parse-namestring temp-name :end (- string-length 3)))) (and (pathnamep temp-pathname) (string-equal temp-name (namestring temp-pathname)) ))) (test-defun 23DRIVE-parse (host) "run a set of tests across several hosts" (and (23Parse-Basic host) (23Parse-Variable-Type host) (23Parse-Junk host) (23Parse-Start host) (23Parse-End host) )) ) ; End of defining functions for this test group. (do-test "test with lots of variations in {core}" (23DRIVE-parse "core")) ; problem with dsk vs pseudo-dsk ;(do-test "test with lots of variations in {dsk}" ; (23DRIVE-parse "dsk")) (do-test "test with lots of variations in {erinyes}" (23DRIVE-parse "erinyes")) ) ; End of defining functions for this test group. (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (parse-PATHNAMES value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ; get ride of some stuff, what's the better way? ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DEVICE.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DEVICE.X new file mode 100644 index 00000000..7fc34957 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DEVICE.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-DEVICE ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-DEVICE.TEST ;; ;; ;; Syntax: (PATHNAME-DEVICE pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the device as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the device name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 3 "tempdevice"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'DEVICE "TEMPDEVICE")) ;;; test do same type of test on several different HOSTS (do-test "test lots of variations in {CORE}" (and (23DRIVE-DEVICE-LIST "core" "tempdevice" "TEMPDEVICE") (23DRIVE-DEVICE-LIST "core" "tempdevice12-32" "TEMPDEVICE12-32") )) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-DEVICE value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-DEVICE "DF")) (not (PATHNAME-DEVICE "OCT-6-65")) (not (PATHNAME-DEVICE 'hello)) (not (PATHNAME-DEVICE 'bye)) (not (PATHNAME-DEVICE (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DIRECTORY.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DIRECTORY.X new file mode 100644 index 00000000..5a8a3b2a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-DIRECTORY.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-DIRECTORY & DIRECTORY-NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-DIRECTORY.TEST ;; ;; ;; Syntax: (PATHNAME-DIRECTORY pathname) ;; (DIRECTORY-NAMESTRING pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the directory as a string or symbol ;; returns the name of the directory as a string ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the directory name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test, PATHNAME-DIRECTORY, a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 3 nil "tempdir"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'directory "TEMPDIR")) (do-test "test, DIRECTORY-NAMESTRING, a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 3 nil "tempdir"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-list simple-list 'directory "TEMPDIR")) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-DIRECTORY-LIST (host directory result-type) "build a list to test pathname-directory" (append ; general cases, for many file serves (23file-generator result-type host 2 nil directory) (23file-generator result-type host 2 nil directory nil "temptype") (23file-generator result-type host 2 nil directory nil "temptype12") )) ;Do each type (test-defun 23BUILD-DIRECTORY-LIST-ALL (host directory) "build the master list for the checker" (append (23BUILD-DIRECTORY-LIST host directory 'PATHNAME) (23BUILD-DIRECTORY-LIST host directory 'STREAM) (23BUILD-DIRECTORY-LIST host directory 'STRING) (23BUILD-DIRECTORY-LIST host directory 'SYMBOL) )) (test-defun 23DRIVE-DIRECTORY-LIST-PATHNAME (host directory-create directory-match) "push the same test across many hosts" (let* ((big-list (23BUILD-DIRECTORY-LIST-ALL host directory-create)) (result (23TEST-PATHNAME-VALUE-list big-list 'directory directory-match))) (23Delete-file-list big-list) result)) (test-defun 23DRIVE-DIRECTORY-LIST-NAMESTRING (host directory-create directory-match) "push the same test across many hosts" (let* ((big-list (23BUILD-DIRECTORY-LIST-ALL host directory-create)) (result (23TEST-NAMESTRING-VALUE-list big-list 'directory directory-match))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "testing PATHNAME-DIRECTORY, lots of variations in {CORE}" (23DRIVE-DIRECTORY-LIST-PATHNAME "core" "cmltest>sub>sub12" "CMLTEST>SUB>SUB12")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {DSK}" (23DRIVE-DIRECTORY-LIST-PATHNAME "DSK" "lispfiles>cmltest>sub" "LISPFILES>CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {ERINYES}" (23DRIVE-DIRECTORY-LIST-PATHNAME "erinyes" "cmltest>sub" "CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {pollux}" (23DRIVE-DIRECTORY-LIST-PATHNAME "pollux:aisnorth:xerox" "cmltest" "CMLTEST")) (do-test "testing DIRECTORY-NAMESTRING, lots of variations in {CORE}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "CORE" "cmltest>sub>sub12" "CMLTEST>SUB>SUB12")) (do-test "testing DIRECTORY-NAMESTRING, lots of variations in {DSK}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "DSK" "lispfiles>cmltest>sub" "LISPFILES>CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {ERINYES}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "erinyes" "cmltest>sub" "CMLTEST>SUB")) (do-test "testing PATHNAME-DIRECTORY, lots of variations in {pollux}" (23DRIVE-DIRECTORY-LIST-NAMESTRING "pollux:aisnorth:xerox" "cmltest" "CMLTEST")) ) ; end of do-test-group (do-test "testing PATHNAME-DIRECTORY for error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-DIRECTORY value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-DIRECTORY "DF")) (not (PATHNAME-DIRECTORY "OCT-6-65")) (not (PATHNAME-DIRECTORY 'hello)) (not (PATHNAME-DIRECTORY 'bye)) (not (PATHNAME-DIRECTORY (make-broadcast-stream *terminal-io*))) ))) (do-test "testing DIRECTORY-NAMESTRING for error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (DIRECTORY-NAMESTRING value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (DIRECTORY-NAMESTRING "DF")) (not (DIRECTORY-NAMESTRING "OCT-6-65")) (not (DIRECTORY-NAMESTRING 'hello)) (not (DIRECTORY-NAMESTRING 'bye)) (not (DIRECTORY-NAMESTRING (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-HOST.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-HOST.X new file mode 100644 index 00000000..dea52dd5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-HOST.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-HOST & HOST-NAMESTRING ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 4,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-HOST.TEST ;; ;; ;; Syntax: (PATHNAME-HOST pathname) ;; (HOST-NAMESTRING pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the host as a string or symbol ;; returns the name of the host as a string ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the host name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test, PATHNAME-HOST, a simple case, dsk" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 3 nil "lispfiles"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'HOST "DSK")) (do-test "test, HOST-NAMESTRING, a simple case, dsk" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 3 nil "lispfiles"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-LIST simple-list 'HOST "DSK")) (do-test "test, PATHNAME-HOST, a simple case, pollux" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "pollux:aisnorth:xerox" 3 nil "cmltest"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'HOST "POLLUX:AISNORTH:XEROX")) (do-test "test, HOST-NAMESTRING, a simple case, pollux" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "pollux:aisnorth:xerox" 3 nil "cmltest"))) :after (progn (23Delete-file-list simple-list)) (23TEST-NAMESTRING-VALUE-LIST simple-list 'HOST "POLLUX:AISNORTH:XEROX")) (do-test-group "test do same type of test on several hosts" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-HOST-LIST (host usedevice InOneDir result-type) "build a list with which to test pathname-host" (append ; if don't need to stay in one directory, wander (if (not InOneDir) (append (23file-generator result-type host 2) (23file-generator result-type host 2 nil "aisbu.modem12") (23file-generator result-type host 2 nil "aisbu.modem32" nil "temptype") )) ; if able to support devices on this host, test (if usedevice (append (23file-generator result-type host 2 "tempdevice") (23file-generator result-type host 2 "tempdevice" "cmltest") (23file-generator result-type host 2 "tempdevice" "cmlfiletest" nil "temptype") )) ; general cases, for many file serves (23file-generator result-type host 2 nil "cmltest") (23file-generator result-type host 2 nil "cmltest>sub") (23file-generator result-type host 2 nil "cmltest>sub" nil "temptype") )) ;Do each type (test-defun 23BUILD-HOST-LIST-ALL (host usedevice InOneDir) "build the big master list" (append (23BUILD-HOST-LIST host usedevice InOneDir 'PATHNAME) (23BUILD-HOST-LIST host usedevice InOneDir 'STREAM) (23BUILD-HOST-LIST host usedevice InOneDir 'STRING) (23BUILD-HOST-LIST host usedevice InOneDir 'SYMBOL) )) (test-defun 23DRIVE-HOST-LIST-PATHNAME (host-create host-match usedevice InOneDir) "push the same test across many hosts" (let* ((big-list (23BUILD-HOST-LIST-ALL host-create usedevice InOneDir)) (result (23TEST-PATHNAME-VALUE-list big-list 'HOST host-match))) (23Delete-file-list big-list) result)) (test-defun 23DRIVE-HOST-LIST-NAMESTRING (host-create host-match usedevice InOneDir) "push the same test across many hosts" (let* ((big-list (23BUILD-HOST-LIST-ALL host-create usedevice InOneDir)) (result (23TEST-NAMESTRING-VALUE-list big-list 'HOST host-match))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test (PATHNAME-HOST) lots of variations in {CORE}" (23DRIVE-HOST-LIST-PATHNAME "core" "CORE" T nil)) ;Ought to test around the problem with psuedo-dsk ;(do-test "test (PATHNAME-HOST) lots of variations in {DSK}" ; (23DRIVE-HOST-LIST-PATHNAME "dsk" "DSK" T nil)) (do-test "test (PATHNAME-HOST) lots of variations in {ERINYES}" (23DRIVE-HOST-LIST-PATHNAME "erinyes" "ERINYES" nil T)) (do-test "test (HOST-NAMESTRING) lots of variations in {CORE}" (23DRIVE-HOST-LIST-NAMESTRING "core" "CORE" T nil)) ;Ought to test around the problem with psuedo-dsk ;(do-test "test (HOST-NAMESTRING) lots of variations in {DSK}" ; (23DRIVE-HOST-LIST-NAMESTRING "dsk" "DSK" T nil)) (do-test "test (HOST-NAMESTRING) lots of variations in {ERINYES}" (23DRIVE-HOST-LIST-NAMESTRING "erinyes" "ERINYES" nil T)) ) ; end of do-test-group (do-test "test error conditions for PATHNAME-HOST" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-HOST value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-HOST "DF")) (not (PATHNAME-HOST "OCT-6-65")) (not (PATHNAME-HOST 'hello)) (not (PATHNAME-HOST 'bye)) (not (PATHNAME-HOST (make-broadcast-stream *terminal-io*))) ))) (do-test "test error conditions for HOST-NAMESTRING" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (HOST-NAMESTRING value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (HOST-NAMESTRING "DF")) (not (HOST-NAMESTRING "OCT-6-65")) (not (HOST-NAMESTRING 'hello)) (not (HOST-NAMESTRING 'bye)) (not (HOST-NAMESTRING (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-NAME.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-NAME.X new file mode 100644 index 00000000..483648a7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-NAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-NAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-NAME.TEST ;; ;; ;; Syntax: (PATHNAME-NAME pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the file as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the name of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" ; test on dsk, lispfiles, so atleast the basics work. :before (progn (setq temp-name (string (gensym))) (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 1 nil "lispfiles>cmltest" temp-name))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'name temp-name)) (do-test "test a simple case" ; test on pollux, lispfiles, so atleast the basics work. :before (progn (setq temp-name (string (gensym))) (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "pollux:aisnorth:xerox" 1 nil "cmltest" temp-name))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'name temp-name)) ;(do-test "make sure can have a file like HELLO.GOOD.BYE & be consistent" ; :before (progn ; (setq expect-name (concatenate 'string (string (gensym)) ".bye")) ; (setq temp-name (concatenate 'string expect-name ".solong")) ; (setq delete-list (23BUILD-LIST-OF-FILENAME-PATHNAMES ; "core" 1 nil "tempdir" temp-name)) ; (setq simple-list (23Multiply-stream delete-list))) ; :after (progn (23Delete-file-list delete-list)) ; (23TEST-PATHNAME-VALUE-list simple-list 'name expect-name)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-NAME-LIST (host name result-type usedevice InOneDir) "create a list of files of one type" (append (if (not InOneDir) (append (23file-generator result-type host 1 nil nil name) (23file-generator result-type host 1 nil "TEMPDIR12-23" name))) (if usedevice (append (23file-generator result-type host 1 "TEMPDEVICE" nil name))) (23file-generator result-type host 1 nil "cmltest" name) (23file-generator result-type host 1 nil "cmltest" name "temptype12") )) (test-defun 23DRIVE-NAME-LIST (host name-create name-match usedevice InOneDir) "push the list through the checker, valid function?" (let* ((delete-list (23BUILD-NAME-LIST host name-create 'STREAM usedevice InOneDir)) (big-list (23Multiply-stream delete-list)) (result (23TEST-PATHNAME-VALUE-list big-list 'name name-match))) (23Delete-file-list delete-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (let ((temp-name (concatenate 'string "MM" (string (gensym))))) (23DRIVE-NAME-LIST "core" (string-downcase temp-name) temp-name T nil))) (do-test "test lots of variations in {DSK}" (let* ((name-create (concatenate 'string "LL" (string (gensym)))) (delete-list (23file-generator 'STREAM "dsk" 1 nil "lispfiles>sub" name-create "temptype12")) (big-list (23Multiply-stream delete-list)) (result (23TEST-PATHNAME-VALUE-list big-list 'name (string-downcase name-create)))) (23Delete-file-list delete-list) result)) (do-test "test lots of variations in {ERINYES}" (let ((temp-name (concatenate 'string "HC" (string (gensym))))) (23DRIVE-NAME-LIST "erinyes" (string-downcase temp-name) temp-name nil T))) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-NAME value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-NAME (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-TYPE.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-TYPE.X new file mode 100644 index 00000000..cf47c8e2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-TYPE.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-TYPE ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 5,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-TYPE.TEST ;; ;; ;; Syntax: (PATHNAME-TYPE pathname) ;; ;; ;; ;; Function Description: ;; returns the type of the fil as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the type of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 3 nil "lispfiles>tempdir" nil "hello"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'type "HELLO")) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-TYPE-LIST (host type result-type) (append (23file-generator result-type host 2 nil "cmltest" nil type) (23file-generator result-type host 2 nil "cmltest>sub" nil type) )) ;Do each type (test-defun 23BUILD-TYPE-LIST-ALL (host type) (append (23BUILD-TYPE-LIST host type 'PATHNAME) (23BUILD-TYPE-LIST host type 'STREAM) (23BUILD-TYPE-LIST host type 'STRING) (23BUILD-TYPE-LIST host type 'SYMBOL) )) (test-defun 23DRIVE-TYPE-LIST (host type-create type-match) (let* ((big-list (23BUILD-TYPE-LIST-ALL host type-create)) (result (23TEST-PATHNAME-VALUE-list big-list 'type type-match))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (23DRIVE-TYPE-LIST "core" "hello" "HELLO")) (do-test "test lots of variations in {erinyes}" (23DRIVE-TYPE-LIST "erinyes" "Nalpha-123" "NALPHA-123")) ) ; end of do-test-group (do-test "test a few variations in {dsk}" (let* ((big-list (23file-generator 'STREAM "dsk" 2 nil "lispfiles>sub" nil "temptype12")) (result (23TEST-PATHNAME-VALUE-list big-list 'type "temptype12"))) (23Delete-file-list big-list) result)) (do-test "test a few variations in {polux}" (let* ((big-list (23file-generator 'STREAM "pollux:aisnorth:xerox" 2 nil "cmltest" nil "temptype12")) (result (23TEST-PATHNAME-VALUE-list big-list 'type "temptype12"))) (23Delete-file-list big-list) result)) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-TYPE value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (not (PATHNAME-TYPE "DF")) (not (PATHNAME-TYPE "OCT-6-65")) (not (PATHNAME-TYPE 'hello)) (not (PATHNAME-TYPE 'bye)) (not (PATHNAME-TYPE (make-broadcast-stream *terminal-io*))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-VERSION.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-VERSION.X new file mode 100644 index 00000000..b95e6135 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME-VERSION.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAME-VERSION ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 417 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 18,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAME-VERSION.TEST ;; ;; ;; Syntax: (PATHNAME-VERSION pathname) ;; ;; ;; ;; Function Description: ;; returns the type of the fil as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the version of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" :before (progn (setq simple-list (23BUILD-LIST-OF-STREAM "dsk" 3 nil "lispfiles>tempdir" nil "hello"))) :after (progn (23Delete-file-list simple-list)) (23TEST-PATHNAME-VALUE-list simple-list 'version 1)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN ; this function is just for this test case. (test-defun 23BUILD-VERSION-LIST (host result-type) (append (23file-generator result-type host 2 nil "cmltest") (23file-generator result-type host 2 nil "cmltest>sub") )) ;Do each type (test-defun 23BUILD-VERSION-LIST-ALL (host) (append (23BUILD-VERSION-LIST host 'STREAM) ; (23BUILD-VERSION-LIST host 'STRING) ; (23BUILD-VERSION-LIST host 'SYMBOL) )) (test-defun 23DRIVE-VERSION-LIST (host) (let* ((big-list (23BUILD-VERSION-LIST-ALL host)) (result (23TEST-PATHNAME-VALUE-list big-list 'version 1))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (23DRIVE-VERSION-LIST "core")) (do-test "test lots of variations in {dsk}" (let* ((big-list (23file-generator 'STREAM "dsk" 2 nil "lispfiles>sub" nil nil)) (result (23TEST-PATHNAME-VALUE-list big-list 'version 1))) (23Delete-file-list big-list) result)) (do-test "test lots of variations in {erinyes}" (23DRIVE-VERSION-LIST "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (PATHNAME-VERSION value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME.X new file mode 100644 index 00000000..595ace2a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: pathname ;; ;; Source: CLtL p. 413 ;; Chapter 23: File System Interface Section 23-1-2: Pathname Functions ;; ;; Created By: Herb Jellinek ;; ;; Creation Date: 8 August 86 ;; ;; Last Update: October 9, 1986 ;; ;; Filed As: {eris}cml>test>23-1-2-pathname.test ;; ;; ;; Syntax: pathname pathname ;; ;; Function Description: converts pathname to a pathname. ;; ;; Argument(s): pathname - a pathname, string, symbol or stream ;; ;; Returns: a pathname ;; ;; ;;;; Watch out for implementation-dependent filenames below ;; (do-test-group ("pathname-test" :before (progn (test-setq termstream (make-broadcast-stream *terminal-io*)) (test-setq closed-stream (let ((s (open "{core}directory>empty" :direction :output))) (close s) s)) (test-setq bstream (open "{core}directory>empty" :if-does-not-exist :create)) (test-setq cstream (make-broadcast-stream bstream)) (test-setq dstream (open "{core}junk" :direction :output)) (test-setq open-streams (list termstream bstream cstream dstream)) (test-setq all-streams (list termstream closed-stream bstream cstream dstream)) (test-setq some-symbol 'five) (test-defun pathtest (object) (cl:pathnamep (cl:pathname object))) )) :after (progn (cl:mapcar #'cl:close open-streams) (cl:mapcar #'cl:delete-file all-streams)) (do-test pathname-test ;; Will the function accept all these files and streams? (and (cl:every #'(lambda (item) (streamp item)) all-streams) ;; Will it accept t and nil? (cl:every #'(lambda (x) x) (cl:mapcar #'pathtest '(t nil))) ;; Symbols? (pathtest (cl:gensym)) (pathtest (cl:gentemp)) (pathtest some-symbol) ;; Pathnames? (cl:every #'(lambda(x) x) (cl:mapcar #'pathtest (cl:mapcar #'pathname all-streams))) ;; Strings? (pathtest "abc") (pathtest (cl:pathname (cl:make-array 10 :element-type 'cl:string-char :initial-element #\newline))) (pathtest (cl:pathname (cl:make-array 4 :element-type 'cl:string-char :initial-contents "path" :adjustable t :fill-pointer t)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAMEP.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAMEP.X new file mode 100644 index 00000000..c2aae103 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-PATHNAMEP.X @@ -0,0 +1 @@ +;; Function To Be Tested: PATHNAMEP ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 416 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: October 31,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-PATHNAMEP.TEST ;; ;; ;; Syntax: (PATHNAMEP object) ;; ;; (PATHNAMEP object) is exactly equal to: ;; (typep object 'pathname) ;; ;; ;; Function Description: ;; This predicate is true if object is a pathname, nil otherwise ;; ;; ;; ;; Argument(s): object - can be anything ;; ;; Returns: T if the object is a pathname, nil otherwise ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "try a simple test" :before (progn (setq simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 1 nil "lispfiles>tempdir"))) :after (progn (23Delete-file-list simple-list)) (eq T (PATHNAMEP (car simple-list)))) (do-test-group "test same type on different hosts" :before (progn ; this function is just for this test case. (test-defun 23BUILD-PathNameP-Host-List (host usedevice InOneDir) "build the master list to drive past the checker" (append ; if don't need to stay in one directory, wander, not use directory (if (null InOneDir) (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1) (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "aisbu.modem12") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 3 nil nil nil "temptype") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "aisbu.modem" nil "temptype") )) ; if able to support devices on this host, test (if usedevice (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 3 "tempdevice") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 "tempdevice" "cmltest") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 "tempdevice" "cmltest" nil "temptype") )) ; general cases, for many file serves (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "cmltest") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 3 nil "cmltest>sub") (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2 nil "cmltest>sub" nil "temptype") )) (test-defun 23DRIVE-PATHNAMEP-HOST-LIST (host usedevice InOneDir) "push the same test across many hosts" (let* ((big-list (23BUILD-PathNameP-Host-List host usedevice InOneDir)) (result (cl:every #'(lambda (item) (eq T (pathnamep item))) big-list))) (23Delete-file-list big-list) result)) ) ; end of local functions (do-test "test lots of variations in {core}" (23DRIVE-PATHNAMEP-HOST-LIST "core" T nil)) (do-test "test lots of variations in {core}" (let* ((big-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 2 nil "lispfiles>sub")) (result (cl:every #'(lambda (item) (eq T (pathnamep item))) big-list))) (23Delete-file-list big-list) result)) (do-test "test lots of variations in {erinyes}" (23DRIVE-PATHNAMEP-HOST-LIST "erinyes" nil T)) ) ; end of do-test-group (do-test "test other types return nil" (and (NOT (PATHNAMEP T)) (NOT (PATHNAMEP 54)) (NOT (PATHNAMEP #\h)) (NOT (PATHNAMEP "A string")) (NOT (PATHNAMEP 'symbol)) (NOT (PATHNAMEP (list 'hi 'bye))) (NOT (PATHNAMEP (make-array '(2 3 4)))) (NOT (PATHNAMEP (make-hash-table))) (NOT (PATHNAMEP (copy-readtable))) (NOT (PATHNAMEP (find-package 'Lisp))) (NOT (PATHNAMEP (make-broadcast-stream *terminal-io*))) ; (NOT (PATHNAMEP (make-random-state))) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-TRUENAME.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-TRUENAME.X new file mode 100644 index 00000000..356d4e7d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-TRUENAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: truename ;; ;; Source: CLtL p. 413 ;; Chapter 23: File System Interface Section 23-1-2: Pathname Functions ;; ;; Created By: Herb Jellinek ;; ;; Creation Date: 8 August 86 ;; ;; Last Update: October 7, 1986 ;; ;; Filed As: {eris}cml>test>23-1-2-truename.test ;; ;; ;; Syntax: truename pathname ;; ;; Function Description: if pathname is an open stream, returns the pathname of ;; file. Otherwise looks to see if pathname names an extant file; is so, ;; returns its pathname, if not, signals an error. ;; ;; Argument(s): pathname - a pathname, string, symbol or stream ;; ;; Returns: a pathname ;; ;; ;;;; Watch out for implementation-dependent filenames below ;; (do-test-group (truename-group :before (progn (test-setq astream (make-broadcast-stream *terminal-io*)) (test-setq bstream (open "{core}imaginary" :direction :output)) (test-setq cstream (make-broadcast-stream)) (close (test-setq dstream (open "{dsk}emptyfile.;1" :direction :output :if-does-not-exist :create))) (delete-file "{dsk}emptyfile.;1") (test-setq estream (open "{core}JUNK" :direction :output)) (test-setq file-streams (list bstream estream)) (test-setq extant-streams (list astream bstream cstream estream)) (test-setq all-streams (cons dstream extant-streams)) (test-setq symbol 'five)) :after (progn (mapcar #'close file-streams) (mapcar #'delete-file file-streams)) (do-test truename-test (and (every #'(lambda (x) x) (mapcar #'truename file-streams)) (expect-errors (simple-error) (truename "{core}non-existent.;1")) (expect-errors (simple-error) (truename dstream)) (expect-errors (simple-error) (truename astream)) (every #'(lambda (x) x) (mapcar #'truename (mapcar #'pathname extant-streams))) ) ) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-1-2-USER-HOMEDIR-PATHNAME.X b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-USER-HOMEDIR-PATHNAME.X new file mode 100644 index 00000000..97e8a32a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-1-2-USER-HOMEDIR-PATHNAME.X @@ -0,0 +1 @@ +;; Function To Be Tested: USER-HOMEDIR-PATHNAME ;; ;; Source: Steele's book ;; Section 23.1.2 PATHNAME Functions ;; Page: 418 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 10,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-1-2-USER-HOMEDIR-PATHNAME.TEST ;; ;; ;; Syntax: (USER-HOMEDIR-PATHNAME &optional host) ;; ;; ;; ;; Function Description: ;; returns a pathname for the user's "home directory" ;; ;; ;; ;; Argument(s): host - the name of a host ;; ;; Returns: a pathname for the user's "home directory" ;; (do-test "test a simple case" (pathnamep (USER-HOMEDIR-PATHNAME))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-2-OPEN.X b/internal/test/LANGUAGE/from-sun/language/23/23-2-OPEN.X new file mode 100644 index 00000000..0c48fea4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-2-OPEN.X @@ -0,0 +1 @@ +;; Function To Be Tested: OPEN ;; ;; Source: Steele's book ;; Section 23.2 ;; Page: 418 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-2-OPEN.TEST ;; ;; ;; Syntax: (OPEN filename &key :direction :element-type ;; :if-exists :if-does-not-exist) ;; ;; ;; ;; Function Description: ;; renames a file ;; ;; ;; ;; Argument(s): filename - pointer to a file ;; direction - the direction of data ;; element-type - the type of data stored in the file ;; if-exists - what to do if it exists ;; if-does-not-exist - what to do if it doesn't exist ;; ;; Returns: if it succeed a stream to the file ;; (do-test "need to load the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) (do-test "if able to build a file, then part of open works." (let* ((temp-name (string (gensym))) (simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name)) (probe-result (probe-file (car simple-list))) (expect (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1")) (result (and (pathnamep probe-result) (string-equal (namestring probe-result) expect)))) (23Delete-file-list simple-list) result)) (do-test "check can open and reopen." (let* ((temp-name (string (gensym))) (temp-pathname (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name))) (temp-stream (cl:open temp-pathname :direction :output :if-exists :new-version)) (probe-result (probe-file temp-stream)) (expect (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;2")) (result (and (pathnamep probe-result) (string-equal (namestring probe-result) expect)))) (cl:close temp-stream) (Delete-file temp-pathname) result)) (do-test "Try for files which do not exist" T) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:open value)) )) (and (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-2-WITH-OPEN-FILE.X b/internal/test/LANGUAGE/from-sun/language/23/23-2-WITH-OPEN-FILE.X new file mode 100644 index 00000000..fbded6be --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-2-WITH-OPEN-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: WITH-OPEN-FILE ;; ;; Source: Steele's book ;; Section 23.2 ;; Page: 422 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-2-WITH-OPEN-FILE.TEST ;; ;; ;; Syntax: (WITH-OPEN-FILE (stream filename {options}*) ;; {declaration}* {form}*) ;; ;; ;; ;; Function Description: ;; opens a file while within the control of the body ;; ;; ;; ;; Argument(s): stream - to a file ;; filename - pointer to a file ;; ;; Returns: not clear, the last form inside? ;; (do-test "need to load the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) (do-test "try a simple case" (let* ((temp-pathname (23BUILD-PATHNAME "DSK" nil "lispfiles")) (result (with-open-file (temp-stream temp-pathname :direction :io) (probe-file temp-stream)))) (delete-file temp-pathname) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23With-Open-Basic (host) (let* ((temp-pathname (23BUILD-PATHNAME host)) (result (with-open-file (temp-stream temp-pathname :direction :io) (probe-file temp-stream)))) (delete-file temp-pathname) (pathnamep result))) (test-defun 23With-Open-More-Test (host) (let* ((probe-result nil) (temp-stream nil) (length-result nil) (with-open-result nil) (temp-name (string (gensym))) (temp-pathname (23BUILD-PATHNAME host nil "CMLTEST" temp-name)) (expect (concatenate 'string "{" host "}" temp-name ".;1"))) (setq with-open-result (with-open-file (temp-stream temp-pathname :direction :io) (setq probe-result (probe-file temp-stream)) (setq length-result (file-length temp-stream)) "HI")) (and (string-equal expect (namestring probe-result)) (eq nil temp-stream) (eq 0 length-result) (equal "HI" with-open-result) (delete-file temp-pathname) ))) (test-defun 23DRIVE-With-Open (host) "run a set of tests across several hosts" (and (23With-Open-Basic host) (23With-Open-More-Test host) )) ) ; End of defining functions for this test group. (do-test "test with lots of variations in {core}" (23DRIVE-With-Open "core")) (do-test "test with lots of variations in {erinyes}" (23DRIVE-With-Open "erinyes")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-DELETE-FILE.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-DELETE-FILE.X new file mode 100644 index 00000000..83445c26 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-DELETE-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: DELETE-FILE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 424 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-DELETE-FILE.TEST ;; ;; ;; Syntax: (DELETE-FILE pathname) ;; ;; ;; ;; Function Description: ;; deletes the file ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: T if succeeds ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-name (string (gensym))) (temp-pathname (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "dsk" 1 nil "lispfiles>temp" temp-name)))) (and (Delete-file temp-pathname) (not (probe-file temp-pathname)) ))) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23TEST-DELETE-FILE (temp-pathname) "check return T and file really gone" (and (eq T (Delete-file temp-pathname)) (not (probe-file temp-pathname)) )) (test-defun 23TEST-DELETE-FILE-LIST (delete-list) "check that each item in the list exists, and give the right pathname" (cl:every #'(lambda (item) (23TEST-DELETE-FILE item)) delete-list)) (defun 23DRIVE-DELETE-FILE-LIST (host device directory name) "build the list and check able to delete the files" (let* ((delete-list (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 device directory name "typea") (23BUILD-LIST-OF-STREAM host 1 device directory name "typeB") ; (23BUILD-LIST-OF-FILENAME-STRING ; host 1 device directory name "typeC") (23BUILD-LIST-OF-FILENAME-SYMBOL host 1 device directory name "typeD")))) (23TEST-DELETE-FILE-LIST delete-list) )) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (and (23DRIVE-DELETE-FILE-LIST "CORE" NIL NIL NIL) (23DRIVE-DELETE-FILE-LIST "CORE" "tempdevice-12" NIL NIL) (23DRIVE-DELETE-FILE-LIST "CORE" NIL "cmltest>sub12" NIL) (23DRIVE-DELETE-FILE-LIST "CORE" "tempdevice-12" "cmltest>sub12" "hi-23") )) (do-test "test lots of variations in {DSK}" (23DRIVE-DELETE-FILE-LIST "DSK" NIL "lispfiles>cmltest>sub12" NIL)) (do-test "test lots of variations in {ERINYES}" (23DRIVE-DELETE-FILE-LIST "ERINYES" NIL "cmltest" NIL)) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:DELETE-FILE value)) )) (and (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (handle-expect-errors "DF") (handle-expect-errors "OCT-6-65") (handle-expect-errors 'hello) (handle-expect-errors 'bye) (handle-expect-errors (make-broadcast-stream *terminal-io*)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-AUTHOR.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-AUTHOR.X new file mode 100644 index 00000000..e5eddf73 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-AUTHOR.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-AUTHOR ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 424 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-WRITE-DATEAUTHOR.TEST ;; ;; ;; Syntax: (FILE-WRITE-DATEAUTHOR file) ;; ;; ;; ;; Function Description: ;; returns the author of a file ;; ;; ;; ;; Argument(s): file - an existing file ;; ;; Returns: the author of a file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "erinyes" 1))) (author-create (file-author simple-file))) (Delete-file simple-file) author-create)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Test-AUTHOR (temp-pathname expectvalue) "check the author is who we expect" (string-equal expectvalue (file-author temp-pathname))) (test-defun 23Test-AUTHOR-list (big-list expectvalue) "check the author is correct for bunch of files" (cl:every #'(lambda (item) (23Test-AUTHOR item expectvalue)) big-list)) (test-defun 23Build-AUTHOR (host) (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2) ; (23BUILD-LIST-OF-STREAM host 2) ; (23BUILD-LIST-OF-FILENAME-STRING host 2) (23BUILD-LIST-OF-FILENAME-SYMBOL host 2) )) (test-defun 23DRIVE-AUTHOR (host expectvalue) "build a set of files and check author works" (let* ((big-list (23BUILD-author host)) (result (23Test-author-list big-list expectvalue))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test the date with lots of variations in {core}" (23DRIVE-author "core" nil)) (do-test "test the date with lots of variations in {erinyes}" (let ((expectvalue (concatenate 'string (IL:username) ".pa"))) (23DRIVE-author "erinyes" expectvalue))) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-LENGTH.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-LENGTH.X new file mode 100644 index 00000000..e1112d42 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-LENGTH.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-LENGTH ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 425 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 20,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-LENGTH.TEST ;; ;; ;; Syntax: (FILE-LENGTH file-stream) ;; ;; ;; ;; Function Description: ;; returns the length of a file ;; ;; ;; ;; Argument(s): file - a stream which is open ;; ;; Returns: the length of the file ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-stream (cl:open (23BUILD-PATHNAME "DSK" NIL "LISPFILES") :direction :output :element-type 'string-char)) (result (eq 0 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Length-Empty (host) (let* ((temp-stream (23File-SetUP host)) (result (eq 0 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Length-String-Char (host) (let* ((temp-stream (23File-SetUP host)) (toss-away (prin1 'hello temp-stream)) (result (eq 5 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Length-Unsigned-byte (host) (let* ((temp-stream (23File-SetUP host 'unsigned-byte)) (toss-away (write-byte 8 temp-stream)) (result (eq 1 (file-length temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23DRIVE-Length (host) "run a set of tests across several hosts" (and (23Length-Empty host) (23Length-String-Char host) (23Length-Unsigned-byte host) )) ) ; End of defining functions for this test group. (do-test "test the length with lots of variations in {core}" (23DRIVE-Length "core")) (do-test "test the length with lots of variations in {erinyes}" (23DRIVE-Length "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (and (not (file-length 54)) (not (file-length #\h)) (not (file-length (list 'hi 'bye))) (not (file-length (make-array '(2 3 4)))) (not (file-length (make-hash-table))) (not (file-length (copy-readtable))) (not (file-length (find-package 'Lisp))) ; (not (file-length (make-random-state))) (not (file-length "DF")) (not (file-length "OCT-6-65")) (not (file-length 'hello)) (not (file-length 'bye)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-POSITION.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-POSITION.X new file mode 100644 index 00000000..1741b057 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-POSITION.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-POSITION ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 425 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 20,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-POSITION.TEST ;; ;; ;; Syntax: (FILE-POSITION file-stream &optional position) ;; ;; ;; ;; Function Description: ;; either returns the current postion, or sets current position ;; ;; ;; ;; Argument(s): file-stream - a stream which is open ;; position - where want to go to ;; ;; Returns: the current position ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-stream (cl:open (23BUILD-PATHNAME "DSK" NIL "LISPFILES") :direction :output :element-type 'string-char)) (result (eq 0 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Position-Empty (host) (let* ((temp-stream (23Length-SetUP host)) (result (eq 0 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Position-String-Char (host) (let* ((temp-stream (23Length-SetUP host)) (toss-away (prin1 'hello temp-stream)) (result (eq 5 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Position-Unsigned-byte (host) (let* ((temp-stream (23Length-SetUP host 'unsigned-byte)) (toss-away (write-byte 8 temp-stream)) (result (eq 1 (file-position temp-stream)))) (23File-CleanUP temp-stream) result)) (test-defun 23Position-String-Char-Complex (host) (let* ((temp-stream (23Length-SetUP host)) (toss-away (prin1 'hello temp-stream)) (first-position (file-position temp-stream)) (toss-away-2 (prin1 'hello temp-stream)) (second-position (file-position temp-stream)) (result-set-position (file-position temp-stream 0)) (result-read-char (read-char temp-stream))) (23File-CleanUP temp-stream) (and (eq first-position 5) (eq second-position 10) (eq result-set-position T) (eq result-read-char #\H) ))) (test-defun 23DRIVE-Position (host) "run a set of tests across several hosts" (and (23Position-Empty host) (23Position-String-Char host) (23Position-Unsigned-byte host) (23Position-String-Char-Complex host) )) ) ; End of defining functions for this test group. (do-test "test the length with lots of variations in {core}" (23DRIVE-Position "core")) (do-test "test the length with lots of variations in {erinyes}" (23DRIVE-Position "erinyes")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-WRITE-DATE.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-WRITE-DATE.X new file mode 100644 index 00000000..e406446e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-FILE-WRITE-DATE.X @@ -0,0 +1 @@ +;; Function To Be Tested: FILE-WRITE-DATE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 424 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-FILE-WRITE-DATE.TEST ;; ;; ;; Syntax: (FILE-WRITE-DATE file) ;; ;; ;; ;; Function Description: ;; returns the date the file was created, or last written to ;; ;; ;; ;; Argument(s): file - an existing file ;; ;; Returns: the time in universal time format ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((before-time (get-universal-time)) (temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "DSK" 1 nil "lispfiles"))) (after-time (get-universal-time)) (time-create (file-write-date simple-file)) (result (<= before-time time-create after-time))) (Delete-file simple-file) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Test-Date (temp-pathname before-time after-time) "check the date of a file is nicely bound" (let ((time-create (cl:file-write-date temp-pathname))) (<= before-time time-create after-time) )) (test-defun 23Test-Date-list (big-list before-time after-time) "check the date of a set of files are nicely bound" (cl:every #'(lambda (item) (23Test-Date item before-time after-time)) big-list)) (test-defun 23Build-Date (host) (append (23BUILD-LIST-OF-FILENAME-PATHNAMES host 2) (23BUILD-LIST-OF-STREAM host 2) ; (23BUILD-LIST-OF-FILENAME-STRING host 2) (23BUILD-LIST-OF-FILENAME-SYMBOL host 2) )) (test-defun 23DRIVE-Date (host) "build a set of files and check date works" (let* ((before-time (get-universal-time)) (big-list (23BUILD-date host)) (toss-away (sleep 5)) (after-time (get-universal-time)) (result (23Test-Date-list big-list before-time after-time))) (23Delete-file-list big-list) result)) ) ; End of defining functions for this test group. (do-test "test the date with lots of variations in {core}" (23DRIVE-Date "core")) ;(do-test "test the date with lots of variations in {dsk}" ; (23DRIVE-Date "dsk")) ;(do-test "test the date with lots of variations in {erinyes}" ; (23DRIVE-Date "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (and (not (file-write-date 54)) (not (file-write-date #\h)) (not (file-write-date (list 'hi 'bye))) (not (file-write-date (make-array '(2 3 4)))) (not (file-write-date (make-hash-table))) (not (file-write-date (copy-readtable))) (not (file-write-date (find-package 'Lisp))) ; (not (file-write-date (make-random-state))) (not (file-write-date "DF")) (not (file-write-date "OCT-6-65")) (not (file-write-date 'hello)) (not (file-write-date 'bye)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-PROBE-FILE.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-PROBE-FILE.X new file mode 100644 index 00000000..0c4c9141 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-PROBE-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: PROBE-FILE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 4124 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-PROBE-FILE.TEST ;; ;; ;; Syntax: (PROBE-FILE pathname) ;; ;; ;; ;; Function Description: ;; returns the name of the device as a string or symbol ;; ;; ;; ;; Argument(s): pathname - pointing to a file ;; ;; Returns: the device name ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test a simple case" (let* ((temp-name (string (gensym))) (simple-list (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name)) (probe-result (probe-file (car simple-list))) (expect (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1")) (result (and (pathnamep probe-result) (string-equal (namestring probe-result) expect)))) (23Delete-file-list simple-list) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23TEST-PROBE-FILE (temp-pathname expectvalue) "check one pathname at a time" (let ((probe-result (probe-file temp-pathname))) (and (pathnamep probe-result) (string-equal expectvalue (namestring probe-result)) ))) (test-defun 23TEST-PROBE-FILE-LIST (big-list expectvalue) "check that each item in the list exists, and give the right pathname" (cl:every #'(lambda (item) (23TEST-PROBE-FILE item expectvalue)) big-list)) (test-defun 23DRIVE-PROBE-FILE-LIST (host device directory name type expectvalue) "build the list and check get what want" (let* ((delete-list (23BUILD-LIST-OF-STREAM host 1 device directory name type)) (big-list (23Multiply-stream delete-list)) (result (23TEST-PROBE-FILE-LIST big-list expectvalue))) (23Delete-file-list delete-list) result)) ) ; End of defining functions for this test group. (do-test "test lots of variations in {CORE}" (let ((temp-name (string (gensym)))) (and (23DRIVE-PROBE-FILE-LIST "CORE" NIL "TDIR" temp-name NIL (concatenate 'string "{CORE}" temp-name ".;1")) (23DRIVE-PROBE-FILE-LIST "CORE" "TEMPDEVICE" "TDIR" temp-name NIL (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".;1")) (23DRIVE-PROBE-FILE-LIST "CORE" NIL "CMLTEST>SUB" temp-name "TYPE" (concatenate 'string "{CORE}SUB>" temp-name ".TYPE;1")) (23DRIVE-PROBE-FILE-LIST "CORE" "TEMPDEVICE" "TDIR" temp-name "TYPE" (concatenate 'string "{CORE}TEMPDEVICE:" temp-name ".TYPE;1")) ))) ;For now don't worry about, problem with DSK vs PSEUDO-DSK ;(do-test "test lots of variations in {DSK}" ; (let ((temp-name (string (gensym)))) ; (and ; (23DRIVE-PROBE-FILE-LIST "DSK" NIL "TDIR" temp-name NIL ; (concatenate 'string "{DSK}" temp-name ".;1")) ; (23DRIVE-PROBE-FILE-LIST "DSK" "TEMPDEVICE:" "TDIR" temp-name NIL ; (concatenate 'string "{DSK}TEMPDEVICE:" temp-name ".;1")) ; (23DRIVE-PROBE-FILE-LIST "DSK" NIL "CMLTEST>SUB" temp-name "TYPE" ; (concatenate 'string "{DSK}SUB>" temp-name ".TYPE;1")) ; (23DRIVE-PROBE-FILE-LIST "DSK" "TEMPDEVICE:" "TDIR" temp-name "TYPE" ; (concatenate 'string "{DSK}TEMPDEVICE:" temp-name ".TYPE;1")) ; ))) (do-test "test lots of variations in {ERINYES}" (let ((temp-name (string (gensym)))) (and (23DRIVE-PROBE-FILE-LIST "ERINYES" NIL "CMLTEST" temp-name NIL (concatenate 'string "{ERINYES}" temp-name ".;1")) (23DRIVE-PROBE-FILE-LIST "ERINYES" NIL "CMLTEST>SUB" temp-name "TYPE" (concatenate 'string "{ERINYES}SUB>" temp-name ".TYPE;1")) ))) ) ; end of do-test-group (do-test "test for files not there" (and (not (probe-file "{core}fdadzzzzzzzzzzxxxxx.")) (not (probe-file "{core}fdadzzzzzzzzzzxxxxx.dfwqe")) (not (probe-file "{zzzzzz}aaaaaa.aaaadfzzz")) (not (probe-file "{zzzzzz}dfdad:aaaaaa.aaaadfzzz")) (not (probe-file "{zzzzzz}dfdad:aaaaaa.aaaadfzzz")) )) (do-test "test error conditions" (and (not (probe-file 54)) (not (probe-file #\h)) (not (probe-file (list 'hi 'bye))) (not (probe-file (make-array '(2 3 4)))) (not (probe-file (make-hash-table))) (not (probe-file (copy-readtable))) (not (probe-file (find-package 'Lisp))) ; (not (probe-file (make-random-state))) (not (probe-file "DF")) (not (probe-file "OCT-6-65")) (not (probe-file 'hello)) (not (probe-file 'bye)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-3-RENAME-FILE.X b/internal/test/LANGUAGE/from-sun/language/23/23-3-RENAME-FILE.X new file mode 100644 index 00000000..b1842f4f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-3-RENAME-FILE.X @@ -0,0 +1 @@ +;; Function To Be Tested: RENAME-FILE ;; ;; Source: Steele's book ;; Section 23.3 ;; Page: 423 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-3-RENAME-FILE.TEST ;; ;; ;; Syntax: (RENAME-FILE file new-name) ;; ;; ;; ;; Function Description: ;; renames a file ;; ;; ;; ;; Argument(s): file - an existing file ;; new-name - the new name ;; ;; Returns: three values ;; a) the new name filled in ;; b) the truename of file before renamed ;; c) truename after renamed ;; (do-test "load functions for chapter 23 tests" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) ; get here and functions were defined (do-test "test another simple case" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 "tempdevice" nil temp-name))) (new-name (concatenate 'string "{CORE}" temp-name ".ren;1")) (new-pathname (make-pathname :host "core" :directory "tdir" :name temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (do-test-group "test do same type of test on several different HOSTS" :before (PROGN (test-defun 23Check-rename-simple (host) "complete test for just adding a type" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 nil "cmltest" temp-name))) (new-name (concatenate 'string "{" host "}" temp-name ".ren;1")) (new-pathname (make-pathname :host host :directory "cmltest" :name temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (test-defun 23Check-rename-name-type (host) "complete test for renaming the name and adding type" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 nil "cmltest" temp-name))) (new-temp-name (concatenate 'string temp-name "ab")) (new-name (concatenate 'string "{" host "}" new-temp-name ".ren;1")) (new-pathname (make-pathname :host host :directory "cmltest" :name new-temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (test-defun 23Check-rename-directory (host) "complete test for changing dirctories" (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES host 1 nil "cmltest" temp-name))) (new-temp-name (concatenate 'string temp-name "cd")) (new-name (concatenate 'string "{" host "}sub>" new-temp-name ".ren;1")) (new-pathname (make-pathname :host host :directory "cmltest>sub" :name new-temp-name :type "ren")) (result (23check-RENAME new-name simple-file new-pathname))) (Delete-file new-pathname) result)) (test-defun 23Drive-rename-test (host) "make sure the tests work" (and (23Check-rename-simple host) (23Check-rename-name-type host) (23Check-rename-directory host) )) ) ; End of defining functions for this test group. (do-test "test variations in {core}" (23Drive-rename-test "core")) ;DSK vs Pseudo-dsk problem, need to redesign test to handle ;(do-test "test variations in {dsk}" ; (23Drive-rename-test "dsk")) (do-test "test variations in {erinyes}" (23Drive-rename-test "erinyes")) ) ; end of do-test-group (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:rename-file value value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) (handle-expect-errors "DF") (handle-expect-errors "OCT-6-65") (handle-expect-errors 'hello) (handle-expect-errors 'bye) T )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-4-LOAD.X b/internal/test/LANGUAGE/from-sun/language/23/23-4-LOAD.X new file mode 100644 index 00000000..efae9ef0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-4-LOAD.X @@ -0,0 +1 @@ +;; Function To Be Tested: LOAD ;; ;; Source: Steele's book ;; Section 23.4 ;; Page: 426 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-4-load.TEST ;; ;; ;; Syntax: (LOAD filename &key :verbose :print :if-does-not-exist) ;; ;; ;; ;; Function Description: ;; renames a file ;; ;; ;; ;; Argument(s): file - an existing file ;; new-name - the new name ;; ;; Returns: three values ;; a) the new name filled in ;; b) the truename of file before renamed ;; c) truename after renamed ;; (do-test "simple case, try loading the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.DFASL")) t) (do-test "building a file in core, make sure can load" ; open a file, write to it, use evaluate to load file T) (do-test "test for files which do not exist" T) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:load value)) )) (and (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-5-DIRECTORY.X b/internal/test/LANGUAGE/from-sun/language/23/23-5-DIRECTORY.X new file mode 100644 index 00000000..3095dd91 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-5-DIRECTORY.X @@ -0,0 +1 @@ +;; Function To Be Tested: DIRECTORY ;; ;; Source: Steele's book ;; Section 23.5 ;; Page: 427 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 13,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-5-DIRECTORY.TEST ;; ;; ;; Syntax: (DIRECTORY pathname &key) ;; ;; ;; ;; Function Description: ;; returns a list of pathnames to files ;; ;; ;; ;; Argument(s): pathname - a pathname ;; ;; ;; Returns: three values ;; a) the new name filled in ;; b) the truename of file before renamed ;; c) truename after renamed ;; (do-test "make sure have the functions for chapter 23" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.DFASL")) t) (do-test "make sure able to do a simple directory." (let* ((temp-name (string (gensym))) (simple-file (car (23BUILD-LIST-OF-FILENAME-PATHNAMES "core" 1 nil "TDIR" temp-name))) (expect (concatenate 'string "{CORE}" temp-name ".;1")) (dir-pathname (directory simple-file)) (result (and (pathnamep (car dir-pathname)) (string-equal expect (namestring (first dir-pathname)))))) (delete-file simple-file) result)) (do-test "test error conditions" (flet ((handle-expect-errors (value) (xcl-test:expect-errors (cl:error) (cl:directory value)) )) (and (handle-expect-errors 54) (handle-expect-errors #\h) (handle-expect-errors (list 'hi 'bye)) (handle-expect-errors (make-array '(2 3 4))) (handle-expect-errors (make-hash-table)) (handle-expect-errors (copy-readtable)) (handle-expect-errors (find-package 'Lisp)) ; (handle-expect-errors (make-random-state)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS new file mode 100644 index 00000000..02f9806e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "13-May-87 17:24:00" {ERIS}CML>TEST>23-FUNCTIONS.\;8 83482 |changes| |to:| (FUNCTIONS XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::23DRIVE-DIRECTORY-LIST-NAMESTRING XCL-TEST::23DRIVE-DIRECTORY-LIST-PATHNAME XCL-TEST::23DRIVE-RENAME-TEST XCL-TEST::23CHECK-RENAME-DIRECTORY XCL-TEST::23CHECK-RENAME-NAME-TYPE XCL-TEST::23CHECK-RENAME-SIMPLE XCL-TEST::23DRIVE-PROBE-FILE-LIST XCL-TEST::23TEST-PROBE-FILE-LIST XCL-TEST::23TEST-PROBE-FILE XCL-TEST::23DRIVE-DATE XCL-TEST::23BUILD-DATE XCL-TEST::23TEST-DATE-LIST XCL-TEST::23TEST-DATE XCL-TEST::23DRIVE-POSITION XCL-TEST::23POSITION-STRING-CHAR-COMPLEX XCL-TEST::23POSITION-UNSIGNED-BYTE XCL-TEST::23POSITION-STRING-CHAR XCL-TEST::23POSITION-EMPTY XCL-TEST::23DRIVE-LENGTH XCL-TEST::23LENGTH-UNSIGNED-BYTE XCL-TEST::23LENGTH-STRING-CHAR XCL-TEST::23LENGTH-EMPTY XCL-TEST::23DRIVE-AUTHOR XCL-TEST::23BUILD-AUTHOR XCL-TEST::23TEST-AUTHOR-LIST XCL-TEST::23TEST-AUTHOR XCL-TEST::23DRIVE-DELETE-FILE-LIST XCL-TEST::23TEST-DELETE-FILE-LIST XCL-TEST::23TEST-DELETE-FILE XCL-TEST::23DRIVE-WITH-OPEN XCL-TEST::23WITH-OPEN-MORE-TEST XCL-TEST::23WITH-OPEN-BASIC XCL-TEST::23DRIVE-HOST-LIST-NAMESTRING XCL-TEST::23DRIVE-HOST-LIST-PATHNAME XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::23BUILD-HOST-LIST XCL-TEST::23DRIVE-TYPE-LIST XCL-TEST::23BUILD-TYPE-LIST-ALL XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::23DRIVE-NAME-LIST XCL-TEST::23BUILD-NAME-LIST XCL-TEST::23DRIVE-PATHNAMEP-HOST-LIST XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST XCL-TEST::23DRIVE-VERSION-LIST XCL-TEST::23BUILD-VERSION-LIST-ALL XCL-TEST::23BUILD-VERSION-LIST XCL-TEST::23DRIVE-MERGE-LIST-NO-STREAM XCL-TEST::23DRIVE-MERGE-LIST-STREAM XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::23CHECK-MERGE-LIST XCL-TEST::23DRIVE-MAKE-LIST XCL-TEST::23DRIVE-NAMESTRING-LIST XCL-TEST::23DRIVE-PARSE XCL-TEST::23PARSE-END XCL-TEST::23PARSE-START XCL-TEST::23PARSE-JUNK XCL-TEST::23PARSE-VARIABLE-TYPE XCL-TEST::23PARSE-BASIC XCL-TEST::23DRIVE-DEVICE-LIST XCL-TEST::23BUILD-DEVICE-LIST-ALL XCL-TEST::23BUILD-DEVICE-LIST XCL-USER::23DRIVE-ENOUGH-LIST XCL-USER::23DRIVE-FILE-BOTH XCL-USER::23DRIVE-FILE-LIST XCL-USER::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::23DRIVE-FILE-BOTH XCL-TEST::23DRIVE-ENOUGH-LIST XCL-TEST::23CHECK-PARSE-LIST XCL-TEST::23CHECK-PARSE XCL-TEST::23CHECK-RENAME XCL-TEST::23CHECK-MERGE XCL-TEST::23MUL-NO-PATHNAME XCL-TEST::23THREE-TYPES XCL-TEST::23MULTIPLY-STREAM XCL-TEST::23FILE-GENERATOR XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::23TEST-NAMESTRING-VALUE XCL-TEST::23TEST-PATHNAME-VALUE XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::23DELETE-FILE-LIST XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME XCL-TEST::23FILE-CLEANUP XCL-TEST::23LENGTH-SETUP XCL-TEST::23FILE-SETUP XCL-TEST::23BUILD-FILE XCL-TEST::23BUILD-PATHNAME) (VARS 23-FUNCTIONSCOMS) |previous| |date:| " 8-May-87 13:40:30" {ERIS}CML>TEST>23-FUNCTIONS.\;4) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT 23-FUNCTIONSCOMS) (RPAQQ 23-FUNCTIONSCOMS ((FUNCTIONS XCL-TEST::23BUILD-AUTHOR XCL-TEST::23BUILD-DATE XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::23BUILD-DEVICE-LIST-ALL XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::23BUILD-FILE XCL-TEST::23BUILD-HOST-LIST XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::23BUILD-NAME-LIST XCL-TEST::23BUILD-PATHNAME XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::23BUILD-TYPE-LIST-ALL XCL-TEST::23BUILD-VERSION-LIST XCL-TEST::23BUILD-VERSION-LIST-ALL XCL-TEST::23CHECK-MERGE XCL-TEST::23CHECK-MERGE-LIST XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::23CHECK-PARSE XCL-TEST::23CHECK-PARSE-LIST XCL-TEST::23CHECK-RENAME XCL-TEST::23CHECK-RENAME-DIRECTORY XCL-TEST::23CHECK-RENAME-NAME-TYPE XCL-TEST::23CHECK-RENAME-SIMPLE XCL-TEST::23DELETE-FILE-LIST XCL-TEST::23DRIVE-AUTHOR XCL-TEST::23DRIVE-DATE XCL-TEST::23DRIVE-DELETE-FILE-LIST XCL-TEST::23DRIVE-DEVICE-LIST XCL-TEST::23DRIVE-DIRECTORY-LIST-NAMESTRING XCL-TEST::23DRIVE-DIRECTORY-LIST-PATHNAME XCL-TEST::23DRIVE-ENOUGH-LIST XCL-TEST::23DRIVE-FILE-BOTH XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::23DRIVE-HOST-LIST-NAMESTRING XCL-TEST::23DRIVE-HOST-LIST-PATHNAME XCL-TEST::23DRIVE-LENGTH XCL-TEST::23DRIVE-MAKE-LIST XCL-TEST::23DRIVE-MERGE-LIST-NO-STREAM XCL-TEST::23DRIVE-MERGE-LIST-STREAM XCL-TEST::23DRIVE-NAME-LIST XCL-TEST::23DRIVE-NAMESTRING-LIST XCL-TEST::23DRIVE-PARSE XCL-TEST::23DRIVE-PATHNAMEP-HOST-LIST XCL-TEST::23DRIVE-POSITION XCL-TEST::23DRIVE-PROBE-FILE-LIST XCL-TEST::23DRIVE-RENAME-TEST XCL-TEST::23DRIVE-TYPE-LIST XCL-TEST::23DRIVE-VERSION-LIST XCL-TEST::23DRIVE-WITH-OPEN XCL-TEST::23FILE-CLEANUP XCL-TEST::23FILE-GENERATOR XCL-TEST::23FILE-SETUP XCL-TEST::23LENGTH-EMPTY XCL-TEST::23LENGTH-SETUP XCL-TEST::23LENGTH-STRING-CHAR XCL-TEST::23LENGTH-UNSIGNED-BYTE XCL-TEST::23MUL-NO-PATHNAME XCL-TEST::23MULTIPLY-STREAM XCL-TEST::23PARSE-BASIC XCL-TEST::23PARSE-END XCL-TEST::23PARSE-JUNK XCL-TEST::23PARSE-START XCL-TEST::23PARSE-VARIABLE-TYPE XCL-TEST::23POSITION-EMPTY XCL-TEST::23POSITION-STRING-CHAR XCL-TEST::23POSITION-STRING-CHAR-COMPLEX XCL-TEST::23POSITION-UNSIGNED-BYTE XCL-TEST::23TEST-AUTHOR XCL-TEST::23TEST-AUTHOR-LIST XCL-TEST::23TEST-DATE XCL-TEST::23TEST-DATE-LIST XCL-TEST::23TEST-DELETE-FILE XCL-TEST::23TEST-DELETE-FILE-LIST XCL-TEST::23TEST-NAMESTRING-VALUE XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::23TEST-PATHNAME-VALUE XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::23TEST-PROBE-FILE XCL-TEST::23TEST-PROBE-FILE-LIST XCL-TEST::23THREE-TYPES XCL-TEST::23WITH-OPEN-BASIC XCL-TEST::23WITH-OPEN-MORE-TEST))) (CL:DEFUN XCL-TEST::23BUILD-AUTHOR (XCL-TEST::HOST) (CL:APPEND ( XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2) (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST 2))) (CL:DEFUN XCL-TEST::23BUILD-DATE (XCL-TEST::HOST) (CL:APPEND ( XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2) (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 2) (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST 2))) (CL:DEFUN XCL-TEST::23BUILD-DEVICE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::RESULT-TYPE) "build a list for the checker" (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE "cmltest") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE "cmltest>sub") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE "cmltest>sub" NIL "temptype"))) (CL:DEFUN XCL-TEST::23BUILD-DEVICE-LIST-ALL (XCL-TEST::HOST XCL-TEST::DEVICE) "build the big master list" (CL:APPEND (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'PATHNAME) (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'STREAM) (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'STRING) (XCL-TEST::23BUILD-DEVICE-LIST XCL-TEST::HOST XCL-TEST::DEVICE 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-DIRECTORY-LIST (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::RESULT-TYPE) "build a list to test pathname-directory" (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE CL:DIRECTORY) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE CL:DIRECTORY NIL "temptype") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 XCL-TEST::DEVICE CL:DIRECTORY NIL "temptype12"))) (CL:DEFUN XCL-TEST::23BUILD-DIRECTORY-LIST-ALL (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY) "build the master list for the checker" (CL:APPEND (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'PATHNAME) (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'STREAM) (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'STRING) (XCL-TEST::23BUILD-DIRECTORY-LIST XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-FILE (PATHNAME) "build a file" (LET ((XCL-TEST::STR (OPEN PATHNAME :DIRECTION :OUTPUT))) (CL:CLOSE XCL-TEST::STR) XCL-TEST::STR)) (CL:DEFUN XCL-TEST::23BUILD-HOST-LIST (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR XCL-TEST::RESULT-TYPE) "build a list with which to test pathname-host" (CL:APPEND (CL:IF (NOT XCL-TEST::INONEDIR) (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "aisbu.modem12") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "aisbu.modem32" NIL "temptype"))) (CL:IF XCL-TEST::USEDEVICE (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 "tempdevice") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::OST 2 "tempdevice" "cmltest") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 "tempdevice" "cmlfiletest" NIL "temptype"))) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub") (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub" NIL "temptype"))) (CL:DEFUN XCL-TEST::23BUILD-HOST-LIST-ALL (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "build the big master list" (CL:APPEND (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'PATHNAME) (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'STREAM) (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'STRING) (XCL-TEST::23BUILD-HOST-LIST XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of pathnames for created files on {host}" (LET ((XCL-TEST::RESULTS NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:PUSH (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE) XCL-TEST::RESULTS) (XCL-TEST::23BUILD-FILE (CAR XCL-TEST::RESULTS))))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of strings for created files on {host}" (LET ((XCL-TEST::RESULTS NIL) (XCL-TEST::TEMP-PATHNAME NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:SETQ XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:PUSH (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME) XCL-TEST::RESULTS) (XCL-TEST::23BUILD-FILE XCL-TEST::TEMP-PATHNAME)))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of symbols for created files on {host}" (LET ((XCL-TEST::RESULTS NIL) (XCL-TEST::TEMP-PATHNAME NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:SETQ XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:PUSH (XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME XCL-TEST::TEMP-PATHNAME) XCL-TEST::RESULTS) (XCL-TEST::23BUILD-FILE XCL-TEST::TEMP-PATHNAME)))) (CL:DEFUN XCL-TEST::23BUILD-LIST-OF-STREAM (XCL-TEST::HOST &OPTIONAL (CL:NUMBER 5) XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "return list of stream for created files on {host}" (LET ((XCL-TEST::RESULTS NIL)) (CL:DOTIMES (XCL-TEST::I CL:NUMBER XCL-TEST::RESULTS) (CL:PUSH (XCL-TEST::23BUILD-FILE (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) XCL-TEST::RESULTS)))) (CL:DEFUN XCL-TEST::23BUILD-NAME-LIST (XCL-TEST::HOST XCL-TEST::NAME XCL-TEST::RESULT-TYPE XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "create a list of files of one type" (CL:APPEND (CL:IF (NOT XCL-TEST::INONEDIR) (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL NIL XCL-TEST::NAME) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL "TEMPDIR12-23" XCL-TEST::NAME))) (CL:IF XCL-TEST::USEDEVICE (CL:APPEND (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 "TEMPDEVICE" NIL XCL-TEST::NAME))) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME) (XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME "temptype12"))) (CL:DEFUN XCL-TEST::23BUILD-PATHNAME (XCL-TEST::HOST &OPTIONAL XCL-TEST::DEVICE (XCL-TEST::DIR "CMLTEST") XCL-TEST::NAME TYPE) "build a path name with default directory, and if need generated name" (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DEVICE XCL-TEST::DEVICE :DIRECTORY XCL-TEST::DIR :NAME (CL:IF XCL-TEST::NAME XCL-TEST::NAME (STRING (CL:GENSYM))) :TYPE TYPE)) (CL:DEFUN XCL-TEST::23BUILD-PATHNAMEP-HOST-LIST (XCL-TEST::HOST XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "build the master list to drive past the checker" (CL:APPEND (CL:IF (NULL XCL-TEST::INONEDIR) (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1) (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "aisbu.modem12") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 3 NIL NIL NIL "temptype") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "aisbu.modem" NIL "temptype"))) (CL:IF XCL-TEST::USEDEVICE (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 3 "tempdevice") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 "tempdevice" "cmltest") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 "tempdevice" "cmltest" NIL "temptype"))) (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "cmltest") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 3 NIL "cmltest>sub") (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 2 NIL "cmltest>sub" NIL "temptype"))) (CL:DEFUN XCL-TEST::23BUILD-SYMBOL-FROM-PATHNAME (XCL-TEST::TEMP-PATHNAME) "get the name of a stream into SYMBOL form" (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))) (CL:DEFUN XCL-TEST::23BUILD-TYPE-LIST (XCL-TEST::HOST TYPE XCL-TEST::RESULT-TYPE) (CL:APPEND ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest" NIL TYPE) ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub" NIL TYPE))) (CL:DEFUN XCL-TEST::23BUILD-TYPE-LIST-ALL (XCL-TEST::HOST TYPE) (CL:APPEND ( XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'PATHNAME) (XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'STREAM) (XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'STRING) (XCL-TEST::23BUILD-TYPE-LIST XCL-TEST::HOST TYPE 'CL:SYMBOL))) (CL:DEFUN XCL-TEST::23BUILD-VERSION-LIST (XCL-TEST::HOST XCL-TEST::RESULT-TYPE) (CL:APPEND ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest") ( XCL-TEST::23FILE-GENERATOR XCL-TEST::RESULT-TYPE XCL-TEST::HOST 2 NIL "cmltest>sub"))) (CL:DEFUN XCL-TEST::23BUILD-VERSION-LIST-ALL (XCL-TEST::HOST) (CL:APPEND ( XCL-TEST::23BUILD-VERSION-LIST XCL-TEST::HOST 'STREAM))) (CL:DEFUN XCL-TEST::23CHECK-MERGE (XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME &OPTIONAL XCL-TEST::DEFAULTS XCL-TEST::DEFAULT-VERSION) "check both a pathname, and value is as expected." (LET ((XCL-TEST::RESULT (CL:MERGE-PATHNAMES XCL-TEST::TEMP-PATHNAME XCL-TEST::DEFAULTS XCL-TEST::DEFAULT-VERSION))) (AND (CL:PATHNAMEP XCL-TEST::RESULT) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::RESULT))))) (CL:DEFUN XCL-TEST::23CHECK-MERGE-LIST (XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION) "make sure each type can be merge with all the other types" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (EQ T (XCL-TEST::23CHECK-MERGE XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME XCL-TEST::ITEM XCL-TEST::DEFAULT-VERSION))) XCL-TEST::DEFAULT-LIST )) (CL:DEFUN XCL-TEST::23CHECK-MERGE-LISTS (XCL-TEST::EXPECT XCL-TEST::BIG-LIST XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION) "make sure each type can be merge with all the other types" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (EQ T (XCL-TEST::23CHECK-MERGE-LIST XCL-TEST::EXPECT XCL-TEST::ITEM XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION))) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23CHECK-PARSE (XCL-TEST::EXPECT XCL-TEST::TEMP-PATHNAME) "check get what want" (LET ((PATHNAME (CL:PARSE-NAMESTRING XCL-TEST::TEMP-PATHNAME))) (AND (CL:PATHNAMEP PATHNAME) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING PATHNAME))))) (CL:DEFUN XCL-TEST::23CHECK-PARSE-LIST (XCL-TEST::EXPECT XCL-TEST::PATHNAME-LIST) "check a list, make sure get good results" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23CHECK-PARSE XCL-TEST::EXPECT XCL-TEST::ITEM)) XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23CHECK-RENAME (XCL-TEST::EXPECT XCL-TEST::OLD-PATHNAME XCL-TEST::NEW-PATHNAME) "check both a pathname, and value is as expected." (LET* ((XCL-TEST::RESULT (CL:MULTIPLE-VALUE-LIST (CL:RENAME-FILE XCL-TEST::OLD-PATHNAME XCL-TEST::NEW-PATHNAME))) (XCL-TEST::RESULT-1 (CL:FIRST XCL-TEST::RESULT)) (XCL-TEST::RESULT-2 (CL:SECOND XCL-TEST::RESULT)) (XCL-TEST::RESULT-3 (CL:THIRD XCL-TEST::RESULT))) (AND (CL:PATHNAMEP XCL-TEST::RESULT-1) (CL:PATHNAMEP XCL-TEST::RESULT-2) (CL:PATHNAMEP XCL-TEST::RESULT-3) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING (CL:PROBE-FILE XCL-TEST::RESULT-3))) (CL:PROBE-FILE XCL-TEST::NEW-PATHNAME) (NOT (CL:PROBE-FILE XCL-TEST::RESULT-2))))) (CL:DEFUN XCL-TEST::23CHECK-RENAME-DIRECTORY (XCL-TEST::HOST) "complete test for changing dirctories" (LET* ((XCL-TEST::TEMP-NAME (STRING (CL:GENSYM))) (XCL-TEST::SIMPLE-FILE (CAR (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::TEMP-NAME))) (XCL-TEST::NEW-TEMP-NAME (CL:CONCATENATE 'STRING XCL-TEST::TEMP-NAME "cd")) (XCL-TEST::NEW-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}sub>" XCL-TEST::NEW-TEMP-NAME ".ren;1")) (XCL-TEST::NEW-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DIRECTORY "cmltest>sub" :NAME XCL-TEST::NEW-TEMP-NAME :TYPE "ren")) (XCL-TEST::RESULT (XCL-TEST::23CHECK-RENAME XCL-TEST::NEW-NAME XCL-TEST::SIMPLE-FILE XCL-TEST::NEW-PATHNAME))) (CL:DELETE-FILE XCL-TEST::NEW-PATHNAME) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23CHECK-RENAME-NAME-TYPE (XCL-TEST::HOST) "complete test for renaming the name and adding type" (LET* ((XCL-TEST::TEMP-NAME (STRING (CL:GENSYM))) (XCL-TEST::SIMPLE-FILE (CAR (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::TEMP-NAME))) (XCL-TEST::NEW-TEMP-NAME (CL:CONCATENATE 'STRING XCL-TEST::TEMP-NAME "ab")) (XCL-TEST::NEW-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}" XCL-TEST::NEW-TEMP-NAME ".ren;1")) (XCL-TEST::NEW-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DIRECTORY "cmltest" :NAME XCL-TEST::NEW-TEMP-NAME :TYPE "ren")) (XCL-TEST::RESULT (XCL-TEST::23CHECK-RENAME XCL-TEST::NEW-NAME XCL-TEST::SIMPLE-FILE XCL-TEST::NEW-PATHNAME))) (CL:DELETE-FILE XCL-TEST::NEW-PATHNAME) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23CHECK-RENAME-SIMPLE (XCL-TEST::HOST) "complete test for just adding a type" (LET* ((XCL-TEST::TEMP-NAME (STRING (CL:GENSYM))) (XCL-TEST::SIMPLE-FILE (CAR (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::TEMP-NAME))) (XCL-TEST::NEW-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}" XCL-TEST::TEMP-NAME ".ren;1")) (XCL-TEST::NEW-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DIRECTORY "cmltest" :NAME XCL-TEST::TEMP-NAME :TYPE "ren")) (XCL-TEST::RESULT (XCL-TEST::23CHECK-RENAME XCL-TEST::NEW-NAME XCL-TEST::SIMPLE-FILE XCL-TEST::NEW-PATHNAME))) (CL:DELETE-FILE XCL-TEST::NEW-PATHNAME) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DELETE-FILE-LIST (XCL-TEST::PATHNAME-LIST) " delete every file in the list" (CL:MAPCAR #'CL:DELETE-FILE XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23DRIVE-AUTHOR (XCL-TEST::HOST XCL-TEST::EXPECTVALUE) "build a set of files and check author works" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-AUTHOR XCL-TEST::HOST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-AUTHOR-LIST XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DATE (XCL-TEST::HOST) "build a set of files and check date works" (LET* ((XCL-TEST::BEFORE-TIME (CL:GET-UNIVERSAL-TIME)) (XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DATE XCL-TEST::HOST)) (XCL-TEST::TOSS-AWAY (CL:SLEEP 5)) (XCL-TEST::AFTER-TIME (CL:GET-UNIVERSAL-TIME)) (XCL-TEST::RESULT (XCL-TEST::23TEST-DATE-LIST XCL-TEST::BIG-LIST XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DELETE-FILE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME) "build the list and check able to delete the files" (LET* ((XCL-TEST::DELETE-LIST (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME "typea") (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME "typeB") (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME "typeD")) )) (XCL-TEST::23TEST-DELETE-FILE-LIST XCL-TEST::DELETE-LIST))) (CL:DEFUN XCL-TEST::23DRIVE-DEVICE-LIST (XCL-TEST::HOST XCL-TEST::DEVICE-CREATE XCL-TEST::DEVICE-MATCH) "check each file in the list checks" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DEVICE-LIST-ALL XCL-TEST::HOST XCL-TEST::DEVICE-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::DEVICE XCL-TEST::DEVICE-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DIRECTORY-LIST-NAMESTRING (XCL-TEST::HOST XCL-TEST::DIRECTORY-CREATE XCL-TEST::DIRECTORY-MATCH &OPTIONAL XCL-TEST::DEVICE) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIRECTORY-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST 'CL:DIRECTORY XCL-TEST::DIRECTORY-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-DIRECTORY-LIST-PATHNAME (XCL-TEST::HOST XCL-TEST::DIRECTORY-CREATE XCL-TEST::DIRECTORY-MATCH &OPTIONAL XCL-TEST::DEVICE) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-DIRECTORY-LIST-ALL XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIRECTORY-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'CL:DIRECTORY XCL-TEST::DIRECTORY-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-ENOUGH-LIST (XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE XCL-TEST::EXPECTVALUE) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::NAME XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-FILE-BOTH (XCL-TEST::HOST XCL-TEST::NAME-CREATE TYPE) "pathname doesn't give version unless you give it first" (LET ((XCL-TEST::NAME-MATCH-1-V (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".;1")) (XCL-TEST::NAME-MATCH-2-V (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".type;1")) (XCL-TEST::NAME-MATCH-1 (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".")) (XCL-TEST::NAME-MATCH-2 (CL:CONCATENATE 'STRING XCL-TEST::NAME-CREATE ".type"))) (AND (XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::HOST XCL-TEST::NAME-CREATE NIL XCL-TEST::NAME-MATCH-1-V) (XCL-TEST::23DRIVE-FILE-LIST XCL-TEST::HOST XCL-TEST::NAME-CREATE "type" XCL-TEST::NAME-MATCH-2-V) (XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::HOST XCL-TEST::NAME-CREATE NIL XCL-TEST::NAME-MATCH-1) (XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION XCL-TEST::HOST XCL-TEST::NAME-CREATE "type" XCL-TEST::NAME-MATCH-2)))) (CL:DEFUN XCL-TEST::23DRIVE-FILE-LIST (XCL-TEST::HOST XCL-TEST::NAME-CREATE TYPE XCL-TEST::NAME-MATCH ) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME-CREATE TYPE) (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 NIL "cmltest>sub" XCL-TEST::NAME-CREATE TYPE))) (XCL-TEST::BIG-LIST (XCL-TEST::23MUL-NO-PATHNAME XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::FILE XCL-TEST::NAME-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-FILE-LIST-NO-VERSION (XCL-TEST::HOST XCL-TEST::NAME-CREATE TYPE XCL-TEST::NAME-MATCH) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (CL:APPEND (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest" XCL-TEST::NAME-CREATE TYPE) (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST 1 NIL "cmltest>sub" XCL-TEST::NAME-CREATE TYPE))) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::DELETE-LIST 'XCL-TEST::FILE XCL-TEST::NAME-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-HOST-LIST-NAMESTRING (XCL-TEST::HOST-CREATE XCL-TEST::HOST-MATCH XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::HOST-CREATE XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::HOST XCL-TEST::HOST-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-HOST-LIST-PATHNAME (XCL-TEST::HOST-CREATE XCL-TEST::HOST-MATCH XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the same test across many hosts" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-HOST-LIST-ALL XCL-TEST::HOST-CREATE XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'XCL-TEST::HOST XCL-TEST::HOST-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-LENGTH (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23LENGTH-EMPTY XCL-TEST::HOST) (XCL-TEST::23LENGTH-STRING-CHAR XCL-TEST::HOST) (XCL-TEST::23LENGTH-UNSIGNED-BYTE XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-MAKE-LIST (XCL-TEST::EXPECT XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::VERSION &OPTIONAL XCL-TEST::DEFAULTS) "create the path name and check what want" (LET ((XCL-TEST::TEMP-PATHNAME (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DEVICE XCL-TEST::DEVICE :DIRECTORY CL:DIRECTORY :NAME XCL-TEST::NAME :TYPE TYPE :VERSION XCL-TEST::VERSION :DEFAULTS XCL-TEST::DEFAULTS))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))))) (CL:DEFUN XCL-TEST::23DRIVE-MERGE-LIST-NO-STREAM (XCL-TEST::EXPECT XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::D-HOST XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE XCL-TEST::DEFAULT-VERSION) "check the pathname and defaults can be of any type" (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23THREE-TYPES XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::VERSION)) (XCL-TEST::DEFAULT-LIST (XCL-TEST::23THREE-TYPES XCL-TEST::D-HOST XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE)) (XCL-TEST::RESULT (XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::EXPECT XCL-TEST::BIG-LIST XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION))) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-MERGE-LIST-STREAM (XCL-TEST::EXPECT XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::D-HOST XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE XCL-TEST::DEFAULT-VERSION) "check the pathname and defaults can be of any type" (LET* ((XCL-TEST::BIG-LIST-DEL (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::BIG-LIST-DEL)) (XCL-TEST::DEFAULT-LIST-DEL (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::D-HOST 1 XCL-TEST::D-DEVICE XCL-TEST::D-DIRECTORY XCL-TEST::D-NAME XCL-TEST::D-TYPE)) (XCL-TEST::DEFAULT-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DEFAULT-LIST-DEL)) (XCL-TEST::RESULT (XCL-TEST::23CHECK-MERGE-LISTS XCL-TEST::EXPECT XCL-TEST::BIG-LIST XCL-TEST::DEFAULT-LIST XCL-TEST::DEFAULT-VERSION))) (XCL-TEST::23DELETE-FILE-LIST (CL:APPEND XCL-TEST::DEFAULT-LIST-DEL XCL-TEST::BIG-LIST-DEL)) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-NAME-LIST (XCL-TEST::HOST XCL-TEST::NAME-CREATE XCL-TEST::NAME-MATCH XCL-TEST::USEDEVICE XCL-TEST::INONEDIR) "push the list through the checker, valid function?" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-NAME-LIST XCL-TEST::HOST XCL-TEST::NAME-CREATE 'STREAM XCL-TEST::USEDEVICE XCL-TEST::INONEDIR)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'XCL-TEST::NAME XCL-TEST::NAME-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-NAMESTRING-LIST (XCL-TEST::HOST XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE XCL-TEST::EXPECTVALUE) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-NAMESTRING-VALUE-LIST XCL-TEST::BIG-LIST ' XCL-TEST::NAME XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-NIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-PARSE (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23PARSE-BASIC XCL-TEST::HOST) (XCL-TEST::23PARSE-VARIABLE-TYPE XCL-TEST::HOST) (XCL-TEST::23PARSE-JUNK XCL-TEST::HOST) (XCL-TEST::23PARSE-START XCL-TEST::HOST) (XCL-TEST::23PARSE-END XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-PATHNAMEP-HOST-LIST (XCL-TEST:&HOST XCL-TEST::USEDEVICE ;; Function To Be Tested: WITH-OPEN-FILE ;; ;; Source: Steele's book ;; Section 23.2 ;; Page: 422 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>23-2-WITH-OPEN-FILE.TEST ;; ;; ;; Syntax: (WITH-OPEN-FILE (stream filename {options}*) ;; {declaration}* {form}*) ;; ;; ;; ;; Function Description: ;; opens a file while within the control of the body ;; ;; ;; ;; Argument(s): stream - to a file ;; filename - pointer to a file ;; ;; Returns: not clear, the last form inside? ;; (do-test "need to load the functions file" (unless (fboundp '23check-parse-list) (load "{eris}cml>test>23-functions.def")) T) (do-test "try a simple case" (let* ((temp-pathname (23BUILD-PATHNAME "DSK" nil "lispfiles")) (result (with-open-file (temp-stream temp-pathname :direction :io) (probe-file temp-stream)))) (delete-file temp-pathname)  (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::EXPECTVALUE) "build the list and check get what want" (LET* ((XCL-TEST::DELETE-LIST (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST 1 XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE)) (XCL-TEST::BIG-LIST (XCL-TEST::23MULTIPLY-STREAM XCL-TEST::DELETE-LIST)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PROBE-FILE-LIST XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::DELETE-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-RENAME-TEST (XCL-TEST::HOST) "make sure the tests work" (AND (XCL-TEST::23CHECK-RENAME-SIMPLE XCL-TEST::HOST) (XCL-TEST::23CHECK-RENAME-NAME-TYPE XCL-TEST::HOST) (XCL-TEST::23CHECK-RENAME-DIRECTORY XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23DRIVE-TYPE-LIST (XCL-TEST::HOST XCL-TEST::TYPE-CREATE XCL-TEST::TYPE-MATCH) (LET* ((XCL-TEST::BIG-LIST (XCL-TEST::23BUILD-TYPE-LIST-ALL XCL-TEST::HOST XCL-TEST::TYPE-CREATE)) (XCL-TEST::RESULT (XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'TYPE XCL-TEST::TYPE-MATCH))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-VERSION-LIST (XCL-TEST::HOST) (LET* ((XCL-TEST::BIG-LIST ( XCL-TEST::23BUILD-VERSION-LIST-ALL XCL-TEST::HOST) ) (XCL-TEST::RESULT ( XCL-TEST::23TEST-PATHNAME-VALUE-LIST XCL-TEST::BIG-LIST 'XCL-TEST::VERSION 1))) (XCL-TEST::23DELETE-FILE-LIST XCL-TEST::BIG-LIST) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23DRIVE-WITH-OPEN (XCL-TEST::HOST) "run a set of tests across several hosts" (AND (XCL-TEST::23WITH-OPEN-BASIC XCL-TEST::HOST) (XCL-TEST::23WITH-OPEN-MORE-TEST XCL-TEST::HOST))) (CL:DEFUN XCL-TEST::23FILE-CLEANUP (XCL-TEST::TEMP-STREAM) "close the stream and delete the file" (CL:CLOSE XCL-TEST::TEMP-STREAM) (CL:DELETE-FILE XCL-TEST::TEMP-STREAM)) (CL:DEFUN XCL-TEST::23FILE-GENERATOR (XCL-TEST::RESULT-TYPE XCL-TEST::HOST &OPTIONAL CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE) "allow standard interface, so can just wory about type" (CASE XCL-TEST::RESULT-TYPE (STREAM (XCL-TEST::23BUILD-LIST-OF-STREAM XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (STRING (XCL-TEST::23BUILD-LIST-OF-FILENAME-STRING XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:SYMBOL (XCL-TEST::23BUILD-LIST-OF-FILENAME-SYMBOL XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)) (CL:OTHERWISE (XCL-TEST::23BUILD-LIST-OF-FILENAME-PATHNAMES XCL-TEST::HOST CL:NUMBER XCL-TEST::DEVICE XCL-TEST::DIR XCL-TEST::NAME TYPE)))) (CL:DEFUN XCL-TEST::23FILE-SETUP (XCL-TEST::HOST &OPTIONAL (TYPE 'CL:STRING-CHAR)) "create a file of a certain element-type" (OPEN (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST) :DIRECTION :OUTPUT :ELEMENT-TYPE TYPE)) (CL:DEFUN XCL-TEST::23LENGTH-EMPTY (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM ( XCL-TEST::23FILE-SETUP XCL-TEST::HOST)) (XCL-TEST::RESULT (EQ 0 (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23LENGTH-SETUP (XCL-TEST::HOST &OPTIONAL (TYPE 'CL:STRING-CHAR)) "create a file of a certain element-type" (OPEN (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST) :DIRECTION :IO :ELEMENT-TYPE TYPE)) (CL:DEFUN XCL-TEST::23LENGTH-STRING-CHAR (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM ( XCL-TEST::23FILE-SETUP XCL-TEST::HOST )) (XCL-TEST::TOSS-AWAY (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT (EQ 5 (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM) ))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23LENGTH-UNSIGNED-BYTE (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23FILE-SETUP XCL-TEST::HOST 'CL:UNSIGNED-BYTE)) (XCL-TEST::TOSS-AWAY ( CL:WRITE-BYTE 8 XCL-TEST::TEMP-STREAM )) (XCL-TEST::RESULT (EQ 1 (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23MUL-NO-PATHNAME (XCL-TEST::STREAM-LIST) "take a stream and push it, string and symbol into a list" (LET ((XCL-TEST::RESULT NIL)) (CL:DOLIST (XCL-TEST::ITEM XCL-TEST::STREAM-LIST XCL-TEST::RESULT) (CL:PUSH XCL-TEST::ITEM XCL-TEST::RESULT) (CL:PUSH (CL:NAMESTRING XCL-TEST::ITEM) XCL-TEST::RESULT) (CL:PUSH (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::ITEM)) XCL-TEST::RESULT)))) (CL:DEFUN XCL-TEST::23MULTIPLY-STREAM (XCL-TEST::STREAM-LIST) "take a stream and create four types pointing to the same file" (LET ((XCL-TEST::RESULT NIL)) (CL:DOLIST (XCL-TEST::ITEM XCL-TEST::STREAM-LIST XCL-TEST::RESULT) (CL:PUSH XCL-TEST::ITEM XCL-TEST::RESULT) (CL:PUSH (CL:NAMESTRING XCL-TEST::ITEM) XCL-TEST::RESULT) (CL:PUSH (PATHNAME XCL-TEST::ITEM) XCL-TEST::RESULT) (CL:PUSH (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::ITEM)) XCL-TEST::RESULT)))) (CL:DEFUN XCL-TEST::23PARSE-BASIC (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}any-name.type" )) (XCL-TEST::TEMP-PATHNAME ( CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME ))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME)) ))) (CL:DEFUN XCL-TEST::23PARSE-END (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}any-name.type uh" )) (XCL-TEST::STRING-LENGTH (CL:LENGTH XCL-TEST::TEMP-NAME )) (XCL-TEST::TEMP-PATHNAME (CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME :END (- XCL-TEST::STRING-LENGTH 3)))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))))) (CL:DEFUN XCL-TEST::23PARSE-JUNK (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING " uh {" XCL-TEST::HOST "}any-name.type" )) (XCL-TEST::TEMP-PATHNAME ( CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME :JUNK-ALLOWED T))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME))) )) (CL:DEFUN XCL-TEST::23PARSE-START (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-NAME (CL:CONCATENATE 'STRING " uh {" XCL-TEST::HOST "}any-name.type" )) (XCL-TEST::TEMP-PATHNAME ( CL:PARSE-NAMESTRING XCL-TEST::TEMP-NAME :START 5))) (AND (CL:PATHNAMEP XCL-TEST::TEMP-PATHNAME) (STRING-EQUAL XCL-TEST::TEMP-NAME (CL:NAMESTRING XCL-TEST::TEMP-PATHNAME)) ))) (CL:DEFUN XCL-TEST::23PARSE-VARIABLE-TYPE (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST)) (XCL-TEST::TEMP-STREAM (OPEN XCL-TEST::TEMP-PATHNAME :DIRECTION :IO)) (XCL-TEST::TOSS-AWAY (CL:CLOSE XCL-TEST::TEMP-STREAM )) (XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::TEMP-STREAM )) (XCL-TEST::TEMP-LIST (XCL-TEST::23MULTIPLY-STREAM (LIST XCL-TEST::TEMP-STREAM))) (XCL-TEST::RESULT ( XCL-TEST::23CHECK-PARSE-LIST XCL-TEST::EXPECT XCL-TEST::TEMP-LIST ))) (CL:DELETE-FILE XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23POSITION-EMPTY (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM ( XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST)) (XCL-TEST::RESULT (EQ 0 ( CL:FILE-POSITION XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23POSITION-STRING-CHAR (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST)) (XCL-TEST::TOSS-AWAY (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT (EQ 5 (CL:FILE-POSITION XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23POSITION-STRING-CHAR-COMPLEX (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST)) (XCL-TEST::TOSS-AWAY (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::FIRST-POSITION (CL:FILE-POSITION XCL-TEST::TEMP-STREAM)) (XCL-TEST::TOSS-AWAY-2 (CL:PRIN1 'XCL-TEST::HELLO XCL-TEST::TEMP-STREAM)) (XCL-TEST::SECOND-POSITION (CL:FILE-POSITION XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT-SET-POSITION (CL:FILE-POSITION XCL-TEST::TEMP-STREAM 0)) (XCL-TEST::RESULT-READ-CHAR (CL:READ-CHAR XCL-TEST::TEMP-STREAM))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) (AND (EQ XCL-TEST::FIRST-POSITION 5) (EQ XCL-TEST::SECOND-POSITION 10) (EQ XCL-TEST::RESULT-SET-POSITION T) (EQ XCL-TEST::RESULT-READ-CHAR #\H)))) (CL:DEFUN XCL-TEST::23POSITION-UNSIGNED-BYTE (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-STREAM (XCL-TEST::23LENGTH-SETUP XCL-TEST::HOST 'CL:UNSIGNED-BYTE)) (XCL-TEST::TOSS-AWAY (CL:WRITE-BYTE 8 XCL-TEST::TEMP-STREAM)) (XCL-TEST::RESULT (EQ 1 (CL:FILE-POSITION XCL-TEST::TEMP-STREAM )))) (XCL-TEST::23FILE-CLEANUP XCL-TEST::TEMP-STREAM) XCL-TEST::RESULT)) (CL:DEFUN XCL-TEST::23TEST-AUTHOR (XCL-TEST::TEMP-PATHNAME XCL-TEST::EXPECTVALUE) "check the author is who we expect" (STRING-EQUAL XCL-TEST::EXPECTVALUE (CL:FILE-AUTHOR XCL-TEST::TEMP-PATHNAME))) (CL:DEFUN XCL-TEST::23TEST-AUTHOR-LIST (XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE) "check the author is correct for bunch of files" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-AUTHOR XCL-TEST::ITEM XCL-TEST::EXPECTVALUE)) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23TEST-DATE (XCL-TEST::TEMP-PATHNAME XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME) "check the date of a file is nicely bound" (LET ((XCL-TEST::TIME-CREATE (CL:FILE-WRITE-DATE XCL-TEST::TEMP-PATHNAME))) (<= XCL-TEST::BEFORE-TIME XCL-TEST::TIME-CREATE XCL-TEST::AFTER-TIME))) (CL:DEFUN XCL-TEST::23TEST-DATE-LIST (XCL-TEST::BIG-LIST XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME) "check the date of a set of files are nicely bound" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-DATE XCL-TEST::ITEM XCL-TEST::BEFORE-TIME XCL-TEST::AFTER-TIME)) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23TEST-DELETE-FILE (XCL-TEST::TEMP-PATHNAME) "check return T and file really gone" (AND (EQ T (CL:DELETE-FILE XCL-TEST::TEMP-PATHNAME)) (NOT (CL:PROBE-FILE XCL-TEST::TEMP-PATHNAME)))) (CL:DEFUN XCL-TEST::23TEST-DELETE-FILE-LIST (XCL-TEST::DELETE-LIST) "check that each item in the list exists, and give the right pathname" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-DELETE-FILE XCL-TEST::ITEM)) XCL-TEST::DELETE-LIST)) (CL:DEFUN XCL-TEST::23TEST-NAMESTRING-VALUE (PATHNAME XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test for correct string" (LET ((XCL-TEST::RESULT (CASE XCL-TEST::TEST-TYPE (XCL-TEST::NAME (CL:NAMESTRING PATHNAME)) (XCL-TEST::FILE (CL:FILE-NAMESTRING PATHNAME)) (CL:DIRECTORY (CL:DIRECTORY-NAMESTRING PATHNAME)) (XCL-TEST::HOST (CL:HOST-NAMESTRING PATHNAME)) (XCL-TEST::ENOUGH (CL:ENOUGH-NAMESTRING PATHNAME))))) (STRING-EQUAL XCL-TEST::RESULT XCL-TEST::VALUE))) (CL:DEFUN XCL-TEST::23TEST-NAMESTRING-VALUE-LIST (XCL-TEST::PATHNAME-LIST XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test list for correct string" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-NAMESTRING-VALUE XCL-TEST::ITEM XCL-TEST::TEST-TYPE XCL-TEST::VALUE)) XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23TEST-PATHNAME-VALUE (PATHNAME XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test for correct string or symbol" (LET ((XCL-TEST::RESULT (CASE XCL-TEST::TEST-TYPE (XCL-TEST::HOST (CL:PATHNAME-HOST PATHNAME)) (XCL-TEST::DEVICE (CL:PATHNAME-DEVICE PATHNAME)) (CL:DIRECTORY (CL:PATHNAME-DIRECTORY PATHNAME)) (XCL-TEST::NAME (CL:PATHNAME-NAME PATHNAME)) (TYPE (CL:PATHNAME-TYPE PATHNAME)) (XCL-TEST::VERSION (CL:PATHNAME-VERSION PATHNAME))))) (CL:IF (CL:EQUAL XCL-TEST::TEST-TYPE 'XCL-TEST::VERSION) (CL:EQUAL XCL-TEST::RESULT XCL-TEST::VALUE) (OR (STRING-EQUAL XCL-TEST::RESULT XCL-TEST::VALUE) (AND (TYPEP XCL-TEST::RESULT 'CL:SYMBOL) (STRING-EQUAL XCL-TEST::VALUE (STRING XCL-TEST::RESULT))))))) (CL:DEFUN XCL-TEST::23TEST-PATHNAME-VALUE-LIST (XCL-TEST::PATHNAME-LIST XCL-TEST::TEST-TYPE XCL-TEST::VALUE) "common pattern of code, test list for correct string or symbol" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-PATHNAME-VALUE XCL-TEST::ITEM XCL-TEST::TEST-TYPE XCL-TEST::VALUE)) XCL-TEST::PATHNAME-LIST)) (CL:DEFUN XCL-TEST::23TEST-PROBE-FILE (XCL-TEST::TEMP-PATHNAME XCL-TEST::EXPECTVALUE) "check one pathname at a time" (LET ((XCL-TEST::PROBE-RESULT (CL:PROBE-FILE XCL-TEST::TEMP-PATHNAME))) (AND (CL:PATHNAMEP XCL-TEST::PROBE-RESULT) (STRING-EQUAL XCL-TEST::EXPECTVALUE (CL:NAMESTRING XCL-TEST::PROBE-RESULT))))) (CL:DEFUN XCL-TEST::23TEST-PROBE-FILE-LIST (XCL-TEST::BIG-LIST XCL-TEST::EXPECTVALUE) "check that each item in the list exists, and give the right pathname" (CL:EVERY #'(CL:LAMBDA (XCL-TEST::ITEM) (XCL-TEST::23TEST-PROBE-FILE XCL-TEST::ITEM XCL-TEST::EXPECTVALUE)) XCL-TEST::BIG-LIST)) (CL:DEFUN XCL-TEST::23THREE-TYPES (XCL-TEST::HOST XCL-TEST::DEVICE CL:DIRECTORY XCL-TEST::NAME TYPE XCL-TEST::VERSION) "want in three types, no file, so no stream" (LET ((XCL-TEST::RESULT (CL:MAKE-PATHNAME :HOST XCL-TEST::HOST :DEVICE XCL-TEST::DEVICE :DIRECTORY CL:DIRECTORY :NAME XCL-TEST::NAME :TYPE TYPE :VERSION XCL-TEST::VERSION))) (LIST XCL-TEST::RESULT (CL:NAMESTRING XCL-TEST::RESULT) (CL:MAKE-SYMBOL (CL:NAMESTRING XCL-TEST::RESULT))))) (CL:DEFUN XCL-TEST::23WITH-OPEN-BASIC (XCL-TEST::HOST) (LET* ((XCL-TEST::TEMP-PATHNAME ( XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST )) (XCL-TEST::RESULT (CL:WITH-OPEN-FILE ( XCL-TEST::TEMP-STREAM XCL-TEST::TEMP-PATHNAME :DIRECTION :IO) (CL:PROBE-FILE XCL-TEST::TEMP-STREAM )))) (CL:DELETE-FILE XCL-TEST::TEMP-PATHNAME) (CL:PATHNAMEP XCL-TEST::RESULT))) (CL:DEFUN XCL-TEST::23WITH-OPEN-MORE-TEST (XCL-TEST::HOST) (LET* ((XCL-TEST::PROBE-RESULT NIL) (XCL-TEST::TEMP-STREAM NIL) (XCL-TEST::LENGTH-RESULT NIL) (XCL-TEST::WITH-OPEN-RESULT NIL) (XCL-TEST::TEMP-NAME (STRING ( CL:GENSYM ))) (XCL-TEST::TEMP-PATHNAME (XCL-TEST::23BUILD-PATHNAME XCL-TEST::HOST NIL "CMLTEST" XCL-TEST::TEMP-NAME)) (XCL-TEST::EXPECT (CL:CONCATENATE 'STRING "{" XCL-TEST::HOST "}" XCL-TEST::TEMP-NAME ".;1")) ) (CL:SETQ XCL-TEST::WITH-OPEN-RESULT (CL:WITH-OPEN-FILE (XCL-TEST::TEMP-STREAM XCL-TEST::TEMP-PATHNAME :DIRECTION :IO) (CL:SETQ XCL-TEST::PROBE-RESULT (CL:PROBE-FILE XCL-TEST::TEMP-STREAM )) (CL:SETQ XCL-TEST::LENGTH-RESULT (CL:FILE-LENGTH XCL-TEST::TEMP-STREAM )) "HI")) (AND (STRING-EQUAL XCL-TEST::EXPECT (CL:NAMESTRING XCL-TEST::PROBE-RESULT )) (EQ NIL XCL-TEST::TEMP-STREAM) (EQ 0 XCL-TEST::LENGTH-RESULT) (CL:EQUAL "HI" XCL-TEST::WITH-OPEN-RESULT ) (CL:DELETE-FILE XCL-TEST::TEMP-PATHNAME) ))) (PUTPROPS 23-FUNCTIONS COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF new file mode 100644 index 00000000..03633f89 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF @@ -0,0 +1 @@ +;; These functions are defined once for the ;; test for chapter 23. ;; Not using "test-defun", for there is no reasonable way to undo it. ; Since DO-TEST reads in package XCL-TEST, all these functions must live there as well... (in-package 'xcl-test) ; do so the tests will work on the 1108, give it a directory it can use (if (not (il:lispdirectoryp 'il:lispfiles)) (il:createdskdirectory 'il:lispfiles)) (defun 23BUILD-PATHNAME (host &optional device (dir "CMLTEST") name type) "build a path name with default directory, and if need generated name" (make-pathname :host host :device device :directory dir :name (if name name (string (gensym))) :type type)) (defun 23BUILD-FILE (pathname) "build a file" (let ((str (open pathname :direction :output))) (close str) str)) (defun 23File-SetUP (host &optional (type 'string-char)) "create a file of a certain element-type" (cl:open (23BUILD-PATHNAME host) :direction :output :element-type type)) (defun 23Length-SetUP (host &optional (type 'string-char)) "create a file of a certain element-type" (cl:open (23BUILD-PATHNAME host) :direction :io :element-type type)) (defun 23File-CleanUP (temp-stream) "close the stream and delete the file" (cl:close temp-stream) (cl:delete-file temp-stream)) (defun 23BUILD-SYMBOL-FROM-PATHNAME (temp-pathname) "get the name of a stream into SYMBOL form" (make-symbol (namestring temp-pathname))) (defun 23Delete-file-list (pathname-list) " delete every file in the list" (cl:mapcar #'cl:delete-file pathname-list)) (defun 23BUILD-LIST-OF-FILENAME-PATHNAMES (host &optional (number 5) device (dir "CMLTEST") name type) "return list of pathnames for created files on {host}" (let ((results nil)) (dotimes (i number results) (push (23BUILD-PATHNAME host device dir name type) results) (23BUILD-FILE (CAR results)) ))) (defun 23BUILD-LIST-OF-STREAM (host &optional (number 5) device (dir "CMLTEST") name type) "return list of stream for created files on {host}" (let ((results nil)) (dotimes (i number results) (push (23BUILD-FILE (23BUILD-PATHNAME host device dir name type)) results) ))) (defun 23BUILD-LIST-OF-FILENAME-STRING (host &optional (number 5) device (dir "CMLTEST") name type) "return list of strings for created files on {host}" (let ((results nil) (temp-pathname nil)) (dotimes (i number results) (setq temp-pathname (23BUILD-PATHNAME host device dir name type)) (push (namestring temp-pathname) results) (23BUILD-FILE temp-pathname) ))) (defun 23BUILD-LIST-OF-FILENAME-SYMBOL (host &optional (number 5) device (dir "CMLTEST") name type) "return list of symbols for created files on {host}" (let ((results nil) (temp-pathname nil)) (dotimes (i number results) (setq temp-pathname (23BUILD-PATHNAME host device dir name type)) (push (23BUILD-SYMBOL-FROM-PATHNAME temp-pathname) results) (23BUILD-FILE temp-pathname) ))) (defun 23TEST-PATHNAME-VALUE (pathname test-type value) "common pattern of code, test for correct string or symbol" (let ((result (case test-type (HOST (pathname-host pathname)) (DEVICE (pathname-device pathname)) (DIRECTORY (pathname-directory pathname)) (NAME (pathname-name pathname)) (TYPE (pathname-type pathname)) (VERSION (pathname-version pathname)) ))) (if (equal test-type 'VERSION) (equal result value) (or (string-equal result value) (and (typep result 'symbol) (string-equal value (string result)))) ))) (defun 23TEST-NAMESTRING-VALUE (pathname test-type value) "common pattern of code, test for correct string" (let ((result (case test-type (NAME (namestring pathname)) (FILE (file-namestring pathname)) (DIRECTORY (directory-namestring pathname)) (HOST (host-namestring pathname)) (ENOUGH (enough-namestring pathname)) ))) (string-equal result value) )) (defun 23TEST-PATHNAME-VALUE-LIST (pathname-list test-type value) "common pattern of code, test list for correct string or symbol" (cl:every #'(lambda (item) (23TEST-PATHNAME-VALUE item test-type value)) pathname-list)) (defun 23TEST-NAMESTRING-VALUE-LIST (pathname-list test-type value) "common pattern of code, test list for correct string" (cl:every #'(lambda (item) (23TEST-NAMESTRING-VALUE item test-type value)) pathname-list)) (defun 23file-generator (result-type host &optional number device dir name type) "allow standard interface, so can just wory about type" (case result-type (STREAM (23BUILD-LIST-OF-STREAM host number device dir name type)) (STRING (23BUILD-LIST-OF-FILENAME-STRING host number device dir name type)) (SYMBOL (23BUILD-LIST-OF-FILENAME-SYMBOL host number device dir name type)) (otherwise (23BUILD-LIST-OF-FILENAME-PATHNAMES host number device dir name type)) )) (defun 23Multiply-stream (stream-list) "take a stream and create four types pointing to the same file" (let ((result nil)) (dolist (item stream-list result) (push item result) (push (namestring item) result) (push (pathname item) result) (push (make-symbol (namestring item)) result) ))) (defun 23THREE-TYPES (host device directory name type version) "want in three types, no file, so no stream" (let ((result (make-pathname :host host :device device :directory directory :name name :type type :version version))) (list result (namestring result) (make-symbol (namestring result)) ))) (defun 23Mul-No-Pathname (stream-list) "take a stream and push it, string and symbol into a list" (let ((result nil)) (dolist (item stream-list result) (push item result) (push (namestring item) result) (push (make-symbol (namestring item)) result) ))) (defun 23check-merge (expect temp-pathname &optional defaults default-version) "check both a pathname, and value is as expected." (let ((result (merge-pathnames temp-pathname defaults default-version))) (and (pathnamep result) (string-equal expect (namestring result)) ; (equal expect (namestring result)) ))) (defun 23check-RENAME (expect old-pathname new-pathname) "check both a pathname, and value is as expected." (let* ((result (multiple-value-list (RENAME-file old-pathname new-pathname))) (result-1 (first result)) (result-2 (second result)) (result-3 (third result))) (and (pathnamep result-1) (pathnamep result-2) (pathnamep result-3) (string-equal expect (namestring (probe-file result-3))) (probe-file new-pathname) (not (probe-file result-2)) ))) (defun 23check-parse (expect temp-pathname) "check get what want" (let ((pathname (parse-namestring temp-pathname))) (and (pathnamep pathname) (string-equal expect (namestring pathname)) ))) (defun 23check-parse-list (expect pathname-list) "check a list, make sure get good results" (cl:every #'(lambda (item) (23check-parse expect item)) pathname-list)) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-1-BREAK.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-1-BREAK.TEST new file mode 100644 index 00000000..ecedf8b4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-BREAK.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: break ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.1 ERRORS (General Error-Signalling Functions) ;; Page: 432 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 5, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>24-1-break.test ;; ;; ;; Syntax: (break &optional format-string &rest args) ;; ;; Function Description: This function prints the message and goes directly into the ;; debugger, without allowing any possibility of interception by programmed error ;; handling facilities. When continued, break returns nil. It is permissible to call ;; break with no arguments; a suitable default message will be provided. Break is ;; presumed to be used as a way of signalling errors; it is expected that continuing ;; from a break will not trigger any unusual recovery action. ;; ;; Argument(s): format-string: Error message . ;; ;; Args: ;; ;; Returns: Error message or NIL ;; ;; Constraints/Limitations: Due to the nature of break function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. Tests requiring user interface are commented out. (do-test-group ("break-test-setup" :before (progn (defun command-dispatch (cmd) "**Error message is printed if a symbol has no property named command**" (let ((fn (get cmd 'command))) (if (not (null fn)) (funcall fn) (break "The command ~S is unrecognized." cmd)))) (defun turn-off-val1 () "ABANDON!") (setf (symbol-plist 'emergency-shutdown) '(command turn-off-val1 switch emergency reactor-status 7)) ) ) (do-test "break-test-0" (fboundp 'break) ; Is the function break defined? ) ;; The following are tested manually: ;; (do-test "break-test-1" ;; (break)) ; Should break and return NIL upon exit from break. ;; ;; ;;(do-test "break-test-2" ;; (and (command-dispatch 'emergency-shutdown) ;; (let ((cmd 'switch)) ;; (if (member cmd (symbol-plist 'emergency-shutdown)) T ;; (break "change the emergency-list to include ~S!" cmd) ;; ) ;; ) ;; (if (member 'switch (symbol-plist 'emergency-shutdown)) ;; (print "Switch function is now activated!!") ;; (print "Switch function is still not included. ;; Critical Time: 10 minutes before meltdown!!") ;; ) ;; ;; (let ((cmd 'shutdown-reactor)) ;; (if (member cmd (symbol-plist 'emergency-shutdown)) T ;; (break "change the emergency-list to include ~S!" cmd) ;; ) ;; ) ;; (if (member 'shutdown-reactor (symbol-plist 'emergency-shutdown)) ;; (print "shutdown-reactor function is now activated!!") ;; (print "shutdown-reactor function is still not included. ;; Critical Time: 10 minutes before meltdown!!") ;; ) ;; ) ;;) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-1-CERROR.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-1-CERROR.TEST new file mode 100644 index 00000000..685963ab --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-CERROR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cerror ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.1 ERRORS (General Error-Signalling Functions) ;; Page: 431 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 3, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>24-1-cerror.test ;; ;; ;; Syntax: (cerror format-string &rest args) ;; ;; Function Description: This function is used to signal continuable errors. Like error, ;; it signals an error and enters the debugger. However, cerror allows the program to ;; be continued from the debugger after resolving the error. If the program is continued ;; after encountering the error, cerror returns nil. The code that follows the call to ;; error will then be executed. This code should correct the problem, perhaps by ;; accepting a new value from the user if a variable was invalid. ;; ;; Argument(s): format-string: Error message (same way that error uses it). ;; continue-format-string: This is given as a control string to format ;; along with the args to construct a message string. ;; Args: ;; ;; Returns: T ;; ;; Constraints/Limitations: Due to the nature of cerror function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. (do-test-group ("cerror-test-setup" :before (progn (defun cerror-example (vals) "**This is an example of where the caller of cerror, if continued, fixes the problem without any further user interaction**" (let ((nvals (list-length vals))) (unless (= nvals 3) (cond ((< nvals 3) (cerror "Assume missing values are zero." "Too few values in ~S;~%~ three are required, ~ but ~R ~:[were~;was~] supplied." nvals (= nvals 1)) (setq vals (append vals (subseq '(0 0 0) nvals)))) (T (cerror "Ignore all values after the first three." "Too many values in ~S;~%~ three are required, ~ but ~R were supplied." nvals) (setq vals (subseq vals 0 3)))))) ) (defun known-wordp (word) "**This is called by the second cerror-example and returns T if it is a member of the known-wordp-list**" (if (member word '(this is a known wordp list)) T) ) (defun cerror-example-2 (word) " In this example a loop is used to ensure that a test is satisfied" (do () ((known-wordp word) word) (cerror "You will be prompted for a replacement word." "~S is an unknown word (possible misspelled)." word) (format *query-io* "~&New word: ") (setq word (read *query-io*))) ) ) ) (do-test "cerror-exist?" (fboundp 'cerror) ) (do-test "cerror-test-1" (eq (cerror-example '(1 2 3)) NIL) ) (do-test "cerror-test-2" (and (eq (cerror-example-2 'WORDP) 'WORDP) (eq (cerror-example-2 'THIS) 'THIS) ) ) ;; The following tests should be performed manually ;; ;; Does the following test return the delineated error message in a similar format ;; if not totally identical? Is the value returned after continuation equal to ;; '(-47 0 0). This is for the first condition where nvals < 3. ;; ;; (do-test "cerror-test-2" ;; (cerror-example '(-47)) ;; ) ;; Should return: "Error: Too few values in (-47); ;; three are required, but one was supplied. ;; Error signalled by function example-cerror. ;; If continued: Assume missing values are zero.") ;; ;; Does the following test return the delineated error message in a similar format ;; if not totally identical? Is the value returned after continuation equal to ;; '(4 5 6). This is for the second condition where nvals > 3. ;; ;; (do-test "cerror-test-2" ;; (cerror-example '(4 5 6 7)) ;; ) ;; Should return: "Error: Too many values in (4 5 6 7); ;; three are required, but four were supplied. ;; Error signalled by function example-cerror. ;; If continued: Ignore all values after the first three.") ;; ;; Does the following test prompt you for a new word if the given word is not part ;; of KNOWN-WORDP-LIST (THIS IS A KNOWN WORDP LIST). ;; (do-test "cerror-test-3" ;; (cerror-example-2 'NOWN) ;; ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-1-CHECK-TYPE.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-1-CHECK-TYPE.TEST new file mode 100644 index 00000000..d69b96ba --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-CHECK-TYPE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: check-type ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.1 ERRORS (General Error-Signalling Functions) ;; Page: 433 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 5, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-1-check-type.test ;; ;; ;; Syntax: (check-type place typespec &optional string ) ;; ;; Function Description: Check-type signals an error if the contents of place are not ;; of the desired type. If the user continues from this error, he will be asked for a ;; new value; check-type will store the new value in place and start over, checking ;; the type of the new value and signalling another error if it is still not of the ;; desired type. Subforms of place may be evaluated multiple times because of the ;; implicit loop generated. The error message will mention place, its contents, and ;; the desired type. ;; ;; Argument(s): Place: Generalized variable reference acceptable to setf. ;; Typespec: a type specifier; it is not evaluated. ;; String (optional): English description of the type, starting with an ;; indefinite article ("a" or "an"); it is evaluated. If string is not ;; supplied, it is computed automatically from typespec. ;; ;; Returns: NIL ;; ;; Constraints/Limitations: Due to the nature of check-type function, which enters the ;; debugger (check-type), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. Tests requiring user interface are commented out. (do-test "check-type-test-0" (macro-function 'check-type) ; Does check-type have a macro definition? ) (do-test "check-type-test-1" (let ((array-type (make-array 10 :initial-element 7)) (atom-type 'adam) (bignum-type (+ 1 most-positive-fixnum)) (bit-type 0) (character-type #\A) (common-type 'abc) (compiled-type #'cos) (complex-type #C(1 2)) (cons-type '(a b c)) (double-float-type most-positive-double-float) (fixnum-type most-positive-fixnum) (hash-table-type (make-hash-table 10)) (function-type 'xyz) (integer-type 10000) (keyword-type ':element-type) (null-type nil) (number-type 820) (package-type (find-package 'user)) (pathname-type (make-pathname)) (random-type (make-random-state)) (ratio-type 3/4) (read-table-type *readtable*) (string-type "hello") (stream-type *standard-input*)) (and (null (check-type array-type (array))) (null (check-type atom-type (atom symbol))) (null (check-type bignum-type (bignum))) (null (check-type bit-type (bit))) (null (check-type character-type (character))) (null (check-type common-type (common))) (null (check-type cons-type (cons))) (null (check-type compiled-type (compiled-function))) (null (check-type complex-type (complex))) (null (check-type double-float-type (float))) (null (check-type fixnum-type (fixnum integer))) (null (check-type hash-table-type (hash-table))) (null (check-type function-type (function))) (null (check-type integer-type (fixnum integer))) (null (check-type keyword-type (keyword))) (null (check-type null-type (null))) (null (check-type number-type (number integer))) (null (check-type package-type (package))) (null (check-type pathname-type (pathname))) (null (check-type ratio-type (ratio rational))) (null (check-type read-table-type (readtable))) (null (check-type null-type (null))) (null (check-type string-type (string)))) ) ) (do-test "check-type-test-2" (and(setq aardvarks '(sam harry fred)) (null(check-type aardvarks (list)) (setq narrds 1) (null (check-type narrds (integer 0 *))) ) ) ; Should not break ;; The following should break, print the appropriate error message, prompt for ;; a correct value, and return. ;;(do-test "check-type-test-3" ;; (and(setq aardvarks '(sam harry fred)) ;; (setq new-aardvarks '(1 2 3)) ;; (null (check-type aardvarks (list integer))) ;Enter new-aardvarks ;; ) ;;) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-1-ERROR.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-1-ERROR.TEST new file mode 100644 index 00000000..2b3299b9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-ERROR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: error ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.1 ERRORS (General Error-Signalling Functions) ;; Page: 429 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 31, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>24-1-error.test ;; ;; ;; Syntax: (error format-string &rest args) ;; ;; Function Description: This function signals a fatal error. It is impossible ;; to continue from this kind of error; thur error will never return to its ;; caller ;; ;; Argument(s): format-string: Error message ;; Args: ;; ;; Returns: T ;; ;; Constraints/Limitations: none (do-test-group ("error-test-setup" :before (progn (defun command-dispatch (cmd) "**Error message is printed if a symbol has no property named command**" (let ((fn (get cmd 'command))) (if (not (null fn)) (funcall fn) (error "The command ~S is unrecognized." cmd)))) (defun turn-off-val1 () "ABANDON!") (setf (symbol-plist 'emergency-shutdown) '(command turn-off-val1 switch emergency reactor-status 7)) ) ) (do-test "error-test" (and (string-equal (command-dispatch 'emergency-shutdown) "ABANDON!") ;;(if (string-equal (lisp-implementation-type) "Xerox") ;; (eq (il:nlsetq (command-dispatch 'emergency-shotdown)) nil) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-1-WARN.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-1-WARN.TEST new file mode 100644 index 00000000..92d82df0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-WARN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: warn ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.1 ERRORS (General Error-Signalling Functions) ;; Page: 432 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 4, 1986 ;; ;; Last Update: Dec 19, 1986 ;; ;; Filed As: {ERIS}CML>TEST>24-1-warn.test ;; ;; ;; Syntax: (warn format-string &rest args) ;; ;; Function Description: This function prints an error message, but normally doesn't go ;; into the debugger. (However, this may be controlled by the variable ;; *break-on-warnings*). Warn returns nil. This function would be just the same as ;; format with the output directed to the stream in *error-output*, except warn may ;; perform various implementation-dependent formatting and other actions. For example, ;; an implementation of warn should take care of advancing to a fresh line before and ;; after the error message and perhaps supplying the name of the function that called ;; warn. ;; ;; Argument(s): format-string: Error message . ;; ;; Args: ;; ;; Returns: Error message or NIL ;; ;; Constraints/Limitations: Due to the nature of warn function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. It's unrealistic to execute this kind of test automatically ;; though it is not impossible. (do-test-group ("warn-test-setup" :before (progn (defun command-dispatch (cmd) "**Error message is printed if a symbol has no property named command**" (let ((fn (get cmd 'command))) (if (not (null fn)) (funcall fn) (warn "The command ~S is unrecognized." cmd)))) (defun turn-off-val1 () "ABANDON!") (setf (symbol-plist 'emergency-shutdown) '(command turn-off-val1 switch emergency reactor-status 7)) ) ) (do-test "warn-test-variable" (boundp '*break-on-warnings*) ; Does this variable exist? ) (do-test "warn-test1" (and (string-equal (command-dispatch 'emergency-shutdown) "ABANDON!") (let ((*break-on-warnings* NIL)) (or (eq (command-dispatch 'emergency-shotdown) NIL) ; This should not break (ignore-errors (command-dispatch 'emergency-shotdown)) ; should not invoke the debugger ) ) ) ) ;; The following is tested manually, in which case the function warn should break ;; or go into the debugger since *break-on-warnings* is set to NIL. ;; (do-test "warn-test2" ;; (let ((*break-on-warnings* T)) ;; (command-dispatch 'emergency-shotdown)) ;; ) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-2-ASSERT.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-2-ASSERT.TEST new file mode 100644 index 00000000..951a7605 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-2-ASSERT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: assert ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.2 ERRORS (Specialized Error-Signalling Forms and Macros) ;; Page: 434 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 6, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-2-assert.test ;; ;; ;; Syntax: (assert test-from [({place}*) [string {arg}*]]) ;; ;; Function Description: Assert signals an error if the value of test-form is nil ;; Continuing from this error will allow the user to alter the values of some ;; variables, and assert will then start over, evaluating test-form again. ;; ;; Argument(s): Test-form: any form ;; Place: each place (none or more than one) must be a generalized ;; variable reference acceptable to setf. These should be ;; variables on which test-from depends, whose values may ;; sensibly be changed by the user in attempting to correct the ;; error. ;; String: Error message string ;; Arg: additional arguments; they are evaluated only if an error ;; is signalled, and may be re-evluated if the error is re-signalled. ;; ;; Returns: NIL ;; ;; Constraints/Limitations: Due to the nature of assert function, which enters the ;; debugger (break), this test should be conducted manually to see if correct error ;; messages are returned. Tests requiring user interface are commented out. (do-test "assert-test-0" (macro-function 'assert) ; Does assert have a macro definition? ) (do-test "assert-test1" (and (setq status '(switch-1 switch-2 switch-3)) (defun valve-closed-p (x) (if (member x status) T)) (eq (assert (valve-closed-p 'switch-3)) NIL) ; Should not break ) ) ;; The following should break and print the error message as indicated. ;; (assert (valve-closed-p 'switch-9) () "Live stream is escaping!")) ;; (assert (valve-closed-p 'switch-4) (status) "Live stream is escaping!")) (do-test "assert-test2" (and (setq minbase 10 base 20 maxbase 30) (eq (assert (<= minbase base maxbase) (base) "Base ~D is not in the range [~D, ~D]" base minbase maxbase) NIL) ) ) ;; The following should break and print the error message as indicated. ;; Note here that the user is invited to change BASE, but not the bounds ;; MINBASE and MAXBASE. ;; ;; (setq base 40) ;; (assert (<= minbase base maxbase) ;; (base) ;; "Base ~D is not in the range [~D, ~D]" ;; base minbase maxbase) (do-test "assert-test3" (and (setq a (make-array '(2 3))) (setq b (make-array '(3 2))) (eq (assert (= (array-dimension a 1) (array-dimension b 0)) (a b) "cannot multiply a ~D-by-~D matrix ~ and a ~D-by-~D matrix." (array-dimension a 0) (array-dimension a 1) (array-dimension b 0) (array-dimension b 1)) NIL) ) ) ;; The following should break and print the error message as indicated. It should ;; exit the debeugger and return NIL after an appropriate change is made. ;; Note here that it is probably not desirable to include the entire contents ;; of the two matrices in the error message. It is reasonable to assume that the ;; debugger will give the user access to the values of the places a and b. ;; ;;(setq b (make-array '(2 2))) ;;(assert (= (array-dimension a 1) ;; (array-dimension b 0)) ;; (a b) ;; "cannot multiply a ~D-by-~D matrix ~ ;; and a ~D-by-~D matrix." ;; (array-dimension a 0) ;; (array-dimension a 1) ;; (array-dimension b 0) ;; (array-dimension b 1)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-3-CCASE.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-3-CCASE.TEST new file mode 100644 index 00000000..32af5748 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-CCASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ccase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-ccase.test ;; ;; ;; Syntax: (ccase keyform {({({key}*)|key} {form}*)}* ;; ;; Function Description: This control construct is similar to case, but no explicit ;; otherwise or T clause is permitted. If no clause is satisfied, ccase signals ;; an error with a message constructed from the clauses. Continuing from this ;; error causes ccase to accept a new value from the user, store it into keyplace ;; , and start over, making the clause tests again. Subforms of keyplace may be ;; evaluated multiple times. The name of this function stands from "continuable ;; exhaustive case." ;; ;; Argument(s): Keyplace: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of ccase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "ccase-test0" (macro-function 'ccase) ; Does ccase have a macro definition? ) (do-test "ccase-test1" (and (setq x 'alpha) (defun foo () 'foo-for-alpha) (defun bar () 'bar-for-omega) (defun baz () 'baz-for-zeta) (setq alpha 1 omega 2 zeta 3 phi 4) (equal (mapcar #'(lambda (x) (ccase x (alpha (foo)) (omega (bar)) ((zeta phi) (baz)))) '(alpha omega zeta phi)) (list (foo) (bar) (baz) (baz))) ) ) ; This should not break since each of the three clauses is satisfied. ;; The following (ccase-test2) should break with the appropriate error message, ;; prompt for a new value, and return when the new value satisfies one of the ;; three clauses ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; ;; (progn (setq x 1/3) ;; (ccase x ;; (alpha (foo)) ;; (omega (bar)) ;; ((zeta phi) (baz))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-3-CTYPECASE.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-3-CTYPECASE.TEST new file mode 100644 index 00000000..149819cf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-CTYPECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ctypecase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-ctypecase.test ;; ;; ;; Syntax: (ctypecase keyplace {(type {form}*)}*) ;; ;; Function Description: This macro resembles typecase. Its control construct ;; is similar to typecase, but no explicit otherwise or T clause is permitted. ;; The keyplace must be a generalized variable reference acceptable to setf. ;; If no clause is satisfied, etypecae signals an error with a message constructed ;; from the clauses. Continuing from this error causes ctypecase to accept a new ;; value from the user, store it into keyplace, and start over, making the type ;; tests again. Subforms of keyplace may be evaluated multiple times. The name ;; of this function stands from "continuable exhaustive type case." ;; ;; Argument(s): Keyplace: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of ctypecase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "ctypecase-test0?" (macro-function 'ctypecase) ; Does ctypecase have a macro definition? ) (do-test "ctypecase-test1" (and (setq x 1/3) (= (ctypecase x (integer x) (rational x) (symbol (symbol-value x))) 1/3) ) ) ; This should not break since the clause (rational x) is satisfied. ;; The following should break with the appropriate error message, promt for ;; a new value, and return when the new value satisfies any of the type cases ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; ;; (progn (setq x "HELLO") ;; (ctypecase x ;; (integer x) ;; (complex x) ;; (list x) ;; (symbol (symbol-value x))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-3-ECASE.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-3-ECASE.TEST new file mode 100644 index 00000000..8b8024ed --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-ECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ecase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-ecase.test ;; ;; ;; Syntax: (ecase keyform {({({key}*)|key} {form}*)}* ;; ;; Function Description: This control construct is similar to case, but no explicit ;; otherwise or T clause is permitted. If no clause is satisfied, ecase signals ;; an error with a message constructed from the clauses. It is not permissible to ;; continue from this error. The name of this function stands for "exhaustive ;; case" or "error-checking case." ;; ;; Argument(s): Keyplace: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of ecase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "ecase-test0" (macro-function 'ecase) ; Does ecase have a macro definition? ) (do-test "ecase-test1" (and (setq x 'alpha) (defun foo () 'foo-for-alpha) (defun bar () 'bar-for-omega) (defun baz () 'baz-for-zeta) (setq alpha 1 omega 2 zeta 3 phi 4) (equal (mapcar #'(lambda (x) (ecase x (alpha (foo)) (omega (bar)) ((zeta phi) (baz)))) '(alpha omega zeta phi)) (list (foo) (bar) (baz) (baz))) ) ) ; This should not break since each of the three clauses is satisfied. ;; The following (ecase-test2) should break with the appropriate error message ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; ;; (progn (setq x 1/3) ;; (ecase x ;; (alpha (foo)) ;; (omega (bar)) ;; ((zeta phi) (baz))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-3-ETYPECASE.TEST b/internal/test/LANGUAGE/from-sun/language/24/24-3-ETYPECASE.TEST new file mode 100644 index 00000000..f46afc84 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-ETYPECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: etypecase ;; ;; Source: Guy L Steele's CLTL ;; Section: 24.3 ERRORS (Special Forms for Exhaustive Case Analysis) ;; Page: 436 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 7, 1986 ;; ;; Last Update: Jan 15, 1987 ;; ;; Filed As: {ERIS}CML>TEST>24-3-etypecase.test ;; ;; ;; Syntax: (etypecase keyform {(type {form}*)}*) ;; ;; Function Description: This function resembles casetype. This control construct ;; is similar to typecase, but no explicit otherwise or T clause is permitted. ;; If no clause is satisfied, etypecae signals an error with a message constructed ;; from the clauses. It is not permissible to continue from this error. ;; The name of this function stands for "exhaustive type case" or "error-checking ;; type case." ;; ;; Argument(s): Keyform: Key (variable) ;; (type {form}): type case for error checking ;; ;; Returns: ;; ;; Constraints/Limitations: Due to the nature of etypecase function, which enters ;; the debugger (break), this test should be conducted manually to see if correct ;; error messages are returned. Tests requiring user interface are commented out. (do-test "etypecase-test-0" (macro-function 'etypecase) ; Does etypecase have a macro definition? ) (do-test "etypecase-test1" (and (setq x 1/3) (= (etypecase x (integer x) (rational x) (symbol (symbol-value x))) 1/3) ) ) ; This should not break since the clause (rational x) is satisfied. ;; The following should break with the appropriate error message. ;; "Error: The value of X, 1/3, is neither an integer nor a symbol" ;; (progn (setq x 1/3) ;; (etypecase x ;; (integer x) ;; (symbol (symbol-value x))) ;; ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X b/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X new file mode 100644 index 00000000..a977bfb3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X @@ -0,0 +1 @@ +;; This is a collection of tests from the ErrorSystem.NoteFile. It tests Xerox extensions to the CommonLisp ErrorSystem mostly dealing with proceed cases. The individual test files for each of the functions have been appended together in this big file to gain diagnostic information by testing the functions in a particular order. Nested proceed-cases use find-proceed-case and so find should come first. ;; ;; The source for the text file listing is the NoteCards database at {eris}cml>test>ErrorSystem.NoteFile. Changes are made only to the NoteFile. The listing is ;; Filed As: {eris}cml>test>24-ErrorSystem.x ;; ;; (do-test "define our-little-condition" (define-condition our-little-condition condition)) ;; Definition To Be Tested: ignore-errors ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Handling Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-ignore-errors.x ;; ;; ;; Syntax: ignore-errors &body forms [Macro] ;; ;; Function Description: Executes its body in a context which handles errors of type error by returning control to this form. If no error is signalled, all values returned by the last form are returned by ignore-errors. Otherwise, the form returns nil and the condition that was signalled. Synonym for (condition-case (progn . forms) (error () nil)). ;; ;; Argument(s): forms ;; ;; Returns: nil if error followed by the signalled condition, else value(s) of last form ;; (do-test-group "ignore-errors" (do-test "ignore-errors with simple error" (not (ignore-errors (error)))) (do-test "ignore-errors no error" (and (string-equal "success" (ignore-errors "success")) (ignore-errors (signal 'simple-condition)))) (do-test "ignore-errors cerror" (not (ignore-errors (cerror)))) (do-test "ignore-errors second return no error" (second (multiple-value-list (ignore-errors (values-list (list nil t)))))) (do-test "ignore-errors second return error" (second (multiple-value-list (ignore-errors (error)))))) ;; Definition To Be Tested: find-proceed-case ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-find-proceed-case.x ;; ;; ;; Syntax: find-proceed-case name ;; ;; Function Description: Searches for a proceed case by the given name which is applicable to the given condition in the current dynamic contour. If name is a proceed function name, then the innermost (ie, most recently established) proceed case with that function name that matches the given condition is returned. nil is returned if no such proceed case is found. If name is a proceed case object, then it is simply returned unless it is not currently valid for use. In that case, nil is returned. ;; ;; Argument(s): name -- a proceed function name or ;; a proceed case object ;; ;; Returns: proceed-case, proceed case object, or nil ;; ;; The simple tests for this fall out of compute-proceed-cases. ;; ;; (do-test-group "find-proceed-case" (do-test "find-proceed-case nil 1" (not (find-proceed-case `none))) (do-test "find-proceed-case nil 2" (not (or (find-proceed-case `none) (proceed-case (find-proceed-case `none) (use-food))))) (do-test "find-proceed-case nil 3" (not (proceed-case (find-proceed-case `proceed) (use-food)))) (do-test "find-proceed-case nil switched" (not (proceed-case (find-proceed-case `use-food) (proceed)))) (do-test "find-proceed-case positive" (proceed-case (find-proceed-case `use-food) (use-food))) (do-test "proceed-case signal positive " (proceed-case (condition-case (signal (make-condition `our-little-condition)) (our-little-condition nil (find-proceed-case 'use-food))) (use-food))) (do-test "find-proceed-case nil :condition" (not (proceed-case (find-proceed-case `use-food) (use-food nil :condition our-little-condition nil)))) (do-test "find-proceed-case nested inner" (define-proceed-function use-food :report "Select this food.") (proceed-case (proceed-case (and (test-setq our-proceed-case (find-proceed-case 'use-food)) (typep our-proceed-case 'proceed-case) (string-equal "The inner case." (princ-to-string our-proceed-case))) (use-food nil :report "The inner case." t)) (use-food))) (do-test "find-proceed-case nested outer" (proceed-case (progn (and (test-setq our-proceed-case (find-proceed-case 'use-food)) (typep our-proceed-case 'proceed-case) (string-equal "Select this food." (princ-to-string our-proceed-case))) (proceed-case (find-proceed-case 'use-food) (use-food nil :report "The inner case." t)) (and (test-setq our-proceed-case (find-proceed-case 'use-food)) (typep our-proceed-case 'proceed-case) (string-equal "Select this food." (princ-to-string our-proceed-case)))) (use-food)))) ;; Definition To Be Tested: proceed-case ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-proceed-case.ux ;; ;; ;; Syntax: proceed-case form &rest clauses [Macro] ;; ;; Function Description: The form is evaluated in a dynamic context where the clauses have special meanings as points to which control may be transferred in the event that a condition is is signalled. If form runs to completion and eturns any values, all values returned by theform are simply returned by the proceed-case from. If a condition is signalled while form is running, a handler may transfer control to one of the clauses. If a transfer to a clause occurs, the forms in the body of that clause will be evaluated and any values returned by the last such form will be returned by the proceed-case form. See the documentation for further information. ;; ;; Argument(s): form ;; clauses -- (proceed-function-name arglist [keyword value]* [body-form]*) ;; valid keyword/value pairs are: ;; :filter-function expression ;; :filter form ;; :condition type ;; :report-function exp ;; :report form ;; ;; Returns: value of last form or handled form ;; (do-test-group "proceed-case :filter-function" (do-test "proceed-case :filter-function simple positive" (proceed-case (find-proceed-case 'use-food) (use-food nil :filter-function (lambda () t)))) (do-test "proceed-case :filter-function simple negative" (proceed-case (not (find-proceed-case 'use-food)) (use-food nil :filter-function (lambda () nil)))) (do-test "proceed-case :filter-function simple negative 2" (proceed-case (not (find-proceed-case 'use-food)) (use-food nil :filter-function (lambda () (typep *current-condition* 'our-little-condition))))) (do-test "proceed-case *cur-cond* :filter-function positive" (proceed-case (let ((*current-condition* (make-condition 'our-little-condition))) (find-proceed-case 'use-food)) (use-food nil :filter-function (lambda () (typep *current-condition* 'our-little-condition))))) (do-test "proceed-case :filter simple positive" (proceed-case (find-proceed-case 'use-food) (use-food nil :filter t))) (do-test "proceed-case :filter simple negative" (proceed-case (not (find-proceed-case 'use-food)) (use-food nil :filter nil))) (do-test "proceed-case :condition negative" (proceed-case (not (let ((*current-condition* (make-condition 'our-little-condition))) (find-proceed-case 'use-food))) (use-food nil :condition error))) (do-test "proceed-case :condition positive" (proceed-case (let ((*current-condition* (make-condition 'our-little-condition))) (find-proceed-case 'use-food)) (use-food nil :condition our-little-condition))) (do-test "proceed-case :filter and :condition error" (expect-errors (simple-error) (proceed-case (find-proceed-case 'use-food) (use-food nil :condition our-little-condition :filter t)))) (do-test "proceed-case :filter and :filter-function error" (expect-errors (simple-error) (proceed-case (find-proceed-case 'use-food) (use-food nil :filter t :filter-function (lambda () (typep *current-condition* 'our-little-condition))))))) (do-test-group "proceed-case :report-function" (do-test "proceed-case :report-function" (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'use-food))) (use-food nil :report-function (lambda (proceed-case *standard-output*) (write-string "Select this." *standard-output*))))) (do-test "proceed-case :report-function 2" (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'use-food))) (use-food nil :report-function (lambda (ignore stream) (write-string "Select this." stream))))) (do-test "proceed-case :report" (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'use-food))) (use-food nil :report "Select this."))) (do-test "proceed-case :report" (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'use-food))) (use-food nil :report (write-string "Select this." *standard-output*)))) (do-test "proceed-case :report and :report-function error" (expect-errors (simple-error) (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'use-food))) (use-food nil :report (write-string "Select this." *standard-output*) :report-function (lambda (ignore stream) (write-string "Select this." stream))))))) (do-test-group "nested proceed-case inner catch and throw" (do-test "nested proceed-case catch and throw" (proceed-case (catch 'test-throw (proceed-case (block test-throw (throw 'test-throw (string-equal "Select this." (princ-to-string (find-proceed-case 'proceed)))) nil) (proceed nil :report "Select this." nil))) (proceed nil :report "Don't Select this." nil))) (do-test "throw proceed-case" (catch 'test-throw (throw 'test-throw (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'proceed))) (proceed nil :report "Select this."))))) (do-test "throw nested proceed-case" (catch 'test-throw (throw 'test-throw (proceed-case (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'proceed))) (proceed nil :report "Select this." nil)) (proceed nil :report "Don't Select this." nil))))) (do-test "nested proceed-case outer catch and inner throw" (catch 'test-throw (proceed-case (proceed-case (progn (throw 'test-throw (string-equal "Select this." (princ-to-string (find-proceed-case 'proceed (make-condition 'simple-condition))))) nil) (proceed nil :report "Select this." nil)) (proceed nil :report "Don't Select this." nil)) nil)) (do-test "internested proceed-case nested catch and throw" (not (catch 'test-throw (proceed-case (catch 'test-throw (proceed-case (progn (throw 'test-throw (string-equal "Select this." (princ-to-string (find-proceed-case 'proceed (make-condition 'simple-condition))))) nil) (proceed nil :report "Select this." nil))) (proceed nil :report "Don't Select this." nil)) nil)))) (do-test "proceed-case: dynamic environment" (let ((x t)) (declare (special x)) (proceed-case (let ((x nil)) (declare (special x)) (invoke-proceed-case (find-proceed-case 'use-food))) (use-food nil :report "Select this." x)))) ;; Definition To Be Tested: define-proceed-function ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-define-proceed-function.test ;; ;; ;; Syntax: define-proceed-function name [keyword value]* &rest variables [Macro] ;; ;; Function Description: Defines a function called name which will proceed an error in a typed way. The only thing that a proceed function really does is collect values to be passed on to a proceed-case clause. Valid keyword/value pairs are the same as those which are defined for the proceed-case special form. That is, :test, :condition, :report-funciton, and :report. The test and report functions specified in a define-proceed-function form will be used for proceed-case clauses with the same name that do not specify their own test or report functions, respectively. See the documentation for further information. ;; ;; Argument(s): name (of function to be defined) ;; keyword/value pairs: ;; :test function ;; :condition type ;; :report-function exp ;; :report form ;; &optional variables ;; each variable has the form ;; variable-name or ;; (variable-name initial-value) ;; ;; Returns: value of function or handled proceed clause ;; (do-test "define-proceed-function" (fmakunbound 'test-fn) (and (define-proceed-function test-fn :report "our little report") (fboundp 'test-fn) (proceed-case (string-equal "our little report" (default-proceed-report 'test-fn)) (test-fn nil t)))) (do-test-group "define-proceed-function default parameter collection" (do-test "define-proceed-function test-fn" (fmakunbound 'test-fn) (define-proceed-function test-fn :report "Select this food." (y t))) (do-test "define-proceed-function find test" (proceed-case (find-proceed-case 'test-fn) (test-fn))) (do-test "define-proceed-function default parameter collection" (proceed-case (invoke-proceed-case (find-proceed-case 'test-fn)) (test-fn (y) y)))) ;; Definition To Be Tested: compute-proceed-cases ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-compute-proceed-cases.x ;; ;; ;; Syntax: compute-proceed-cases condition [Function] ;; ;; Function Description: Uses the dynamic state of the program to compute a list of proceed cases which may be used with the given condition. See the documentation for more information. ;; ;; Argument(s): condition ;; ;; Returns: list of proceed cases ;; (do-test-group "compute-proceed-cases" (do-test "compute-proceed-cases single" (proceed-case (member-if #'(lambda (case) (eq (proceed-case-name case) 'proctest)) (compute-proceed-cases)) (proctest)))) (do-test "compute-proceed-cases multiple" (fmakunbound 'test-fn) (define-proceed-function test-fn :report "Select this food." (y t)) (proceed-case (proceed-case (and (member-if #'(lambda (case) (equal (proceed-case-name case) 'test-fn)) (compute-proceed-cases)) (member-if #'(lambda (case) (equal (proceed-case-name case) 'proceed)) (compute-proceed-cases))) (test-fn nil t)) (proceed))) ;; Definition To Be Tested: proceed-case-name ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-proceed-case-name.test ;; ;; ;; Syntax: proceed-case-name proceed-case ;; ;; Function Description: Returns the name of the given proceed-case, or nil if it is not named. ;; ;; Argument(s): proceed-case ;; ;; Returns: name or nil ;; (do-test "proceed-case-name named" (proceed-case (equalp (proceed-case-name (find-proceed-case 'proceed)) 'proceed) (proceed))) ;; Definition To Be Tested: default-proceed-test ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-default-proceed-test.x ;; ;; ;; Syntax: default-proceed-test proceed-case-name ;; ;; Function Description: Returns the default test function for proceed cases with the given name. May be used with setf to change it. [This is a Xerox Lisp extension.] ;; ;; Argument(s): proceed-case-name ;; ;; Returns: function ;; (do-test-group "default-proceed-test" (do-test "default-proceed-test simple" (functionp (default-proceed-test 'proceed))) (do-test "default-proceed-test override" (fmakunbound 'test-fn) (define-proceed-function test-fn :report "our little report" :filter t) (setq testfn (default-proceed-test 'test-fn)) ;; begin test (proceed-case (equalp (default-proceed-test 'test-fn) testfn) (test-fn nil :filter-function #'nil)))) ;; Definition To Be Tested: default-proceed-test ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-default-proceed-test.x ;; ;; ;; Syntax: default-proceed-test proceed-case-name ;; ;; Function Description: Returns the default report function for proceed cases with the given name. May be used with setf to change it. [A Xerox Lisp extension.] ;; ;; Argument(s): proceed-case-name ;; ;; Returns: function ;; (do-test-group ("default-proceed-report" :before (fmakunbound 'test-fn (define-proceed-function test-fn :condition simple-condition :report "Select this food."))) (do-test "default-proceed-report simple" (string-equal (default-proceed-report 'test-fn) "Select this food.")) (do-test "default-proceed-report override" (proceed-case (string-equal (default-proceed-report 'test-fn) "Select this food.") (test-fn nil :report "A different report.")))) ;; Definition To Be Tested: invoke-proceed-case ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Handling Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-invoke-proceed-case.x ;; ;; ;; Syntax: invoke-proceed-case proceed-case &rest values [Function] ;; ;; Function Description: Transfers control to the given proceed-case, passing it the given values. The proceed-case must be a proceed case object or the name of a proceed function which is valid in the current dynamic context. If the argument is not valid, the error bad-proceed-case will be signalled. If the argument is a named proceed case that has a corresponding proceed function, invoke-proceed-case will do the optional argument resolution specified by that function before transferring control to the proceed case. [The CL error proposal does not specify a required second argument.] ;; ;; Argument(s): proceed-case -- object or name ;; condition ;; optional values -- for the proceed-case ;; ;; Returns: can abort, does not return ;; (do-test "invoke-proceed-case single" (proceed-case (invoke-proceed-case 'test-proccase) (test-proccase nil t))) (do-test "invoke-proceed-case multiple" (fmakunbound 'test-fn) (define-proceed-function test-fn :report "Select this food.") (and (proceed-case (invoke-proceed-case 'test-fn) (proceed nil nil) (test-fn nil t)) (proceed-case (invoke-proceed-case 'proceed) (proceed nil t) (test-fn nil nil)))) ;; Definition To Be Tested: catch-abort ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-catch-abort.x ;; ;; ;; Syntax: catch-abort print-form &body forms ;; ;; Function Description: Sets up a proceed-case context for the proceed function abort. If no abort is done while execinting forms and they return normally all values returned by the last form in forms are returned. If an abort transfers control to this catch-abort, two values are returned: nil and the condition which was given to abort (or nil if none was given). ;; ;; Argument(s): print-form -- e.g. string / format ;; forms ;; ;; Returns: values of last form or nil and a condition. ;; (do-test "simple catch-abort" (not (catch-abort "it worked" (abort)))) (do-test "catch-abort nested" (catch-abort "level 1" (not (catch-abort "level 2" (abort))))) ;; Definition To Be Tested: abort ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-abort.x ;; ;; ;; Syntax: abort &optional condition ;; ;; Function Description: Transfers control to the innermost (dynamic) catch-abort form, causing it to return nil immediately. ;; ;; Argument(s): optional condition ;; ;; Returns: never ;;simple abort is tested in catch-abort (do-test-group "abort with condition" (do-test "abort with condition" (multiple-value-bind (result acondition) (catch-abort "test" (abort (make-condition 'simple-condition))) (and (not result) (typep acondition 'simple-condition)))) (do-test "abort with condition 2" ;; the proceed case below should be ignored, so we return ;; t if this proceed case is seen. Normal return from ;; catch-abort is nil. (multiple-value-bind (result acondition) (catch-abort "test" (proceed-case (progn (abort (make-condition 'simple-condition)) t) (abort (condition) :filter-function (lambda () nil) t))) (and (not result) (typep acondition 'simple-condition))))) ;; Definition To Be Tested: proceed ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-proceed.x ;; ;; ;; Syntax: proceed &optional condition ;; ;; Function Description: This is a predefined proceed function. It is used by such functions as break, cerror, etc. ;; ;; Argument(s): optional condition ;; ;; Returns: nil ;; (do-test-group "proceed" (do-test "proceed simple" (proceed-case (find-proceed-case 'proceed) (proceed))) (do-test "proceed body" (and (not (proceed-case (invoke-proceed-case (find-proceed-case 'proceed)) (proceed nil nil))) (proceed-case (invoke-proceed-case (find-proceed-case 'proceed)) (proceed nil t)))) (do-test "proceed filter" (proceed-case (not (find-proceed-case 'proceed)) (proceed nil :filter nil))) (do-test "proceed report" (proceed-case (string-equal "Select this." (princ-to-string (find-proceed-case 'proceed))) (proceed nil :report "Select this.")))) (do-test-group "proceed nested" (do-test "proceed nested inner" (proceed-case (proceed-case (invoke-proceed-case (find-proceed-case 'proceed)) (proceed nil t)) (proceed nil nil))) (do-test "proceed nested outer" (proceed-case (progn (proceed-case (proceed-case nil (proceed nil nil))) (invoke-proceed-case (find-proceed-case 'proceed)) (proceed-case (proceed-case nil (proceed nil nil)))) (proceed nil t))) (do-test "proceed nested both" (proceed-case (progn (proceed-case (invoke-proceed-case (find-proceed-case 'proceed)) (proceed nil nil)) (invoke-proceed-case (find-proceed-case 'proceed))) (proceed nil t)))) (do-test-group "proceed bindings" (do-test "proceed closure" (eq 'x (let ((val 'x)) (proceed-case (invoke-proceed-case (find-proceed-case 'proceed)) (proceed nil val)))))) ;; Definition To Be Tested: use-value ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-use-value.ux ;; ;; ;; Syntax: use-value &optional new-value ;; ;; Function Description: This is a predefined proceed function. It is intended to be used for supplying an alternate value to be used in a compuatation. If new-value is not provided, use-value will prompt the user for one. ;; ;; Argument(s): optional value ;; ;; Returns: n/a ;; (do-test "use-value" (and (not (proceed-case (invoke-proceed-case 'use-value) (use-value 'simple-condition nil))) (proceed-case (invoke-proceed-case 'use-value) (use-value 'simple-condition t)))) ;; Definition To Be Tested: store-value ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Proceeding from Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-use-value.x ;; ;; ;; Syntax: store-value &optional new-value ;; ;; Function Description: This is a predefined proceed function. It is intended to be used for supplying an alternate value to be stored in some location as a way of proceeding from an error. store-value does not actually store the new vlaue anywhere: it is up to proceed case to take care of that. If new-value is not provided, store-value will prompt the user for one. store-value is used by such forms as check-type and cerror. ;; ;; Argument(s): optional value ;; ;; Returns: n/a ;; (do-test-group "store-value" (do-test "store-value" (and (not (proceed-case (invoke-proceed-case 'store-value) (store-value 'simple-condition nil))) (proceed-case (invoke-proceed-case 'store-value) (store-value 'simple-condition t))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE-FILE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE-FILE.TEST new file mode 100644 index 00000000..f361e8e2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE-FILE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compile-file ;; ;; Source: Guy L Steele's CLTL Chapter 25, Miscellaneous Features ;; Section: 25.1 The Compiler ;; Page: 439 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 25,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-1-compile-file.test ;; ;; ;; Syntax: (compile-file input-pathname &key :output-file) ;; ;; Function Description: The input-pathname must be a valid file specifier, such as a ;; pathname. The defaults for input-filename are taken from the variable ;; *default-pathname-defaults*. The file should be a lisp source file; its contents ;; are compiled and written as a binary object file. The :output-file argument may ;; be used to specify an output pathname; it defaults in a manner appropriate to the ;; implementation's file system conventions. ;; ;; Argument(s): Input-pathname: pathname ;; :output-file(key): ;; ;; Constraints/Limitations: none ;; JRB commenting this test out until a better file can be found to test #| (do-test-group (" compile-file-test-setup" :before (progn (defun file-exist? (file) (if (not (eq (probe-file file) nil)) t nil)) (defun compile-source-file () (cond ((and(file-exist? '{erinyes}tools>do-test) (not (file-exist? '{erinyes}tools>do-test.dcom))) (compile-file '{erinyes}tools>do-test)) ((and (file-exist? '{eris}tools>do-test) (not (file-exist? '{eris}tools>do-test))) (compile-file '{eris}tools>do-test)) (t nil))) (defun compile-source-file-default () (cond ((and(file-exist? '{erinyes}tools>do-test) (not (file-exist? '{erinyes}tools>do-test.dcom))) (progn (rename-file '{erinyes}tools>do-test '{dsk}do-test) (compile-file 'do-test))) ((and (file-exist? '{eris}tools>do-test) (not (file-exist? '{eris}tools>do-test.dcom))) (progn (rename-file '{eris}tools>do-test '{dsk}do-test) (compile-file 'do-test))) (t nil))) (defun compile-source-output-file () (cond ((file-exist? '{erinyes}tools>do-test) (compile-file '{erinyes}tools>do-test :output-file '{erinyes}tools>do-test-output-file.dcom)) ((file-exist? '{eris}tools>do-test) (compile-file '{eris}tools>do-test :output-file '{eris}cml>do-test-output-file.dcom)) (t nil))) (defun delete-compiled-file (file) (cond ((file-exist? file) (delete-file file)) (t t))) (defun move-file (from-file to-file) (cond ((and (file-exist? from-file)(not (file-exist? to-file))) (rename-file from-file to-file)) (t t))))) (do-test "compile-file-test" (and (compile-source-file) (or(file-exist? '{erinyes}tools>do-test.dcom) (file-exist? '{eris}tools>do-test.dcom)) (delete-compiled-file '{erinyes}tools>do-test.dcom) (delete-compiled-file '{eris}tools>do-test.dcom))) (do-test "compile-file-test(*default-pathname-defaults*)" (and (compile-source-file-default) (file-exist? '{dsk}do-test.dcom) (move-file 'do-test '{erinyes}tools>do-test) (move-file 'do-test '{eris}cml>do-test))) (do-test "compile-file-test(:output-file)" (and (compile-source-output-file) (or (file-exist? '{erinyes}tools>do-test-output-file.dcom) (file-exist? '{eris}cml>do-test-output-file.dcom)) (delete-compiled-file '{erinyes}tools>do-test-output-file.dcom) (delete-compiled-file '{eris}cml>do-test-output-file.dcom)))) |# (do-test "compile-file-no-test-yet" t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE.TEST new file mode 100644 index 00000000..6a57fb98 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compile ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.1 The Compiler ;; Page: 439 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 25,1986 ;; ;; Last Update: ;; Changed by Pavel on January 29, 1987 to change the uses of DEFUN into ;; (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA ...)) so as to avoid having ;; the interpreter create spurious interpreted closures. The compiler ;; cannot yet break one of these down. ;; ;; Filed As: {ERIS}CML>TEST>25-1-compile.test ;; ;; ;; Syntax: (compile name &optional definition) ;; ;; Function Description: If definition is supplied, it should be a lambda-expression, ;; the interpreted function to be compiled. If it is not supplied, then should be ;; a symbol with a definition that is a lambda-expression; that definition is ;; compiled and the resulting compiled code is put back into the symbol as its ;; function definition. The definition is compiled and a compiled-function object ;; is produced. If name is a non-nil symbol, then the compiled-function object is ;; installed as the global function definition of the symbol and the symbol is ;; returned. If the name is nil, then the compiled-function object is returned. ;; ;; Argument(s): name: symbol with a definition or nil ;; definition (option): lambda-expression ;; ;; Returns: compiled-function object ;; ;; Constraints/Limitations: none (do-test "compile-test-general" (and (setf (symbol-function 'palindromep) '(lambda (string &optional (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil))))) (eq 'palindromep (compile 'palindromep)) (compiled-function-p #'palindromep) (eq (compile 'abs1 '(lambda (x) (if (minusp x) (- x) x))) 'abs1) (compiled-function-p #'abs1) (compiled-function-p (compile nil '(lambda (a b c) (- (* b b) (* 4 a c))))) (fmakunbound 'palindromep) ) ) ;; Test to determine if the compiled version runs faster than the interpreted one. (do-test "compile-test-time" (and (setf (symbol-function 'comp-palindromep) '(lambda (string &optional (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil))))) (setf (symbol-function 'inter-palindromep) (symbol-function 'comp-palindromep)) (compile 'comp-palindromep) (setq i-time1 (get-internal-run-time)) (dotimes (k 50 t) (inter-palindromep "Able was I ere I saw Elba")) (setq i-time2 (get-internal-run-time)) (setq c-time1 (get-internal-run-time)) (dotimes (k 50 t) (comp-palindromep "Able was I ere I saw Elba")) (setq c-time2 (get-internal-run-time)) (< (abs(- c-time2 c-time1)) (abs (- i-time2 i-time1))) (fmakunbound 'inter-palindromep) (fmakunbound 'comp-palindromep) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-1-DISASSEMBLE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-1-DISASSEMBLE.TEST new file mode 100644 index 00000000..d949c136 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-1-DISASSEMBLE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: disassemble ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.1 The Compiler ;; Page: 439 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 28,1986 ;; ;; Last Update: Oct 8, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-1-disassemble.test ;; ;; ;; Syntax: (disassemble name-or-compiled-function) ;; ;; Function Description: The argument should be either a function object, ;; a lambda-expression, or a symbol with a function definition. If the relevant ;; function is not a compiled function, it is first compiled. In any case, ;; the compiled code is then "reverse-assembled" and printed out in a symbolic ;; format. ;; ;; Argument(s): function object, a lambda-expression, or ;; a symbol with a function definition. ;; ;; Returns: disassembled-function object ;; ;; Constraints/Limitations: none (do-test-group ("disassemble-test-setup" :before (setf (symbol-function 'xyz) '(lambda () 123456)) ) (do-test "disassemble-test" (and (typep (disassemble 'xyz) 'symbol) (typep (disassemble '(lambda (a b c) (- (* b b) (* 4 a c)))) 'symbol) (typep (disassemble '+) 'symbol)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-2-DOCUMENTATION.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-2-DOCUMENTATION.TEST new file mode 100644 index 00000000..eab61a6f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-2-DOCUMENTATION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: documentation ;; ;; Source: Guy L Steele's CLTL ;; Section: 25.2 Miscellaneous Features (Documentation) ;; Page: 440 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 18, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-2-documentation.test ;; ;; ;; Syntax: (documentation symbol doc-type) ;; ;; Function Description: This function returns the documentation string of type ;; doc-type for the symbol, or nil if none exists. Some kinds of documentation ;; are provided automatically by certain Common Lisp constructs if the user ;; writes an optional documentation string within them: ;; ;; ;; Argument(s): symbol: symbol ;; doc-type: symbol ;; Variable (defvar, defparameter, and defconstant) ;; Function (defun and defmacro) ;; Structure (defstruct) ;; Type (deftype) ;; Setf (defsetf) ;; ;; Returns: string of type doc-type for the symbol or nil ;; ;; Constraints/limitations: (do-test-group (documentation-test-setup :before (progn (defun discriminant (a b c) (declare (number a b c)) "computes the discriminant for a quadratic equation" (- (* b b) (* 4 a c))) (defvar *visible-windows* 1 "number of visible windows") (defsetf accessfn updatefn "expands into a call on updatefn") (defsetf foo (x) (y) "Doc for FOO's SETF" nil) (define-setf-method baz (x) "Doc for BAZ's SETF" (values 1 2 3 4 5)) (deftype square-matrix (&optional type size) "square-matrix includes all square two-dimensional arrays" `(array ,type (,size ,size))) (defmacro arithmetic-if (test neg-form zero-form pos-form) "if analogous to the FORTRAN arithmetic IF" (let ((var (gensym))) `(let ((,var ,test)) (cond ((< ,var 0) ,neg-form) ((= ,var 0) ,zero-form) (t ,pos-form))))) (defstruct line "line has points x and y" x y))) (do-test "documentation-test" (and (string-equal (documentation 'discriminant 'function) "computes the discriminant for a quadratic equation") (string-equal (documentation '*visible-windows* 'variable) "number of visible windows") (string-equal (documentation 'line 'structure) "line has points x and y") (string-equal (documentation 'square-matrix 'type) "square-matrix includes all square two-dimensional arrays") (string-equal (documentation 'arithmetic-if 'function) "if analogous to the FORTRAN arithmetic IF") (string-equal (documentation 'accessfn 'setf) "expands into a call on updatefn") (string-equal (documentation 'foo 'setf) "Doc for FOO's SETF") (string-equal (documentation 'baz 'setf) "Doc for BAZ's SETF") ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS-LIST.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS-LIST.TEST new file mode 100644 index 00000000..5c894ca2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS-LIST.TEST @@ -0,0 +1 @@ +;; Function To Be Testapropos-list: apropos-list ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 443 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 30, 1986 ;; ;; Last Update: Jan 20, 1987 ;; ;; Filapropos-list As: {ERIS}CML>TEST>25-3-apropos-list.test ;; ;; ;; Syntax: (apropos-list string &optional packages) ;; ;; Function Description: (apropos-list string) tries to find all available symbols ;; whose print names contain string as a substring. (A symbol may be supplied ;; for the string, in which case the print name of the symbol is used.) ;; Apropos-list performs the same search that apropos does, but prints nothing. ;; ;; Argument(s): string or symbol ;; package (optional) ;; ;; Returns: list of the symbols whose print names contain string as a substring. ;; ;; Constraints/Limitations: none (do-test-group ("apropos-list-test-setup" :before (progn (setq testt-number1 1) (setq testt-number2 2) (setq testt-number3 3) (setq testt-number4 4) (setq a-testt-number1 nil) (setq b-testt-number2 nil) (setq c-testt-number3 nil) (defun dummmy-function1-x nil 'x) (defun dummmy-function1-y nil 'y) (defun dummmy-function1-z nil 'z) ) ) (do-test "apropos-list-test" (and (eq (set-difference (apropos-list "testt-") '(testt-number1 testt-number2 testt-number3 testt-number4 a-testt-number1 b-testt-number2 c-testt-number3)) nil) (eq (set-difference (apropos-list "dummmy") '(dummmy-function1-x dummmy-function1-y dummmy-function1-z)) nil) (member 'lisp-implementation-type (apropos-list "implementation")) (member 'apropos (apropos-list "apro")) (member 'ffloor (apropos-list "floor")) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS.TEST new file mode 100644 index 00000000..f5e077bb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS.TEST @@ -0,0 +1 @@ +;; Function To Be Testapropos: apropos ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 442 ;; ;; Creatapropos By: John Park ;; ;; Creation Date: Sep 30, 1986 ;; ;; Last Update: ;; ;; Filapropos As: {ERIS}CML>TEST>25-3-apropos.test ;; ;; ;; Syntax: (apropos string &optional packages) ;; ;; Function Description: (apropos string) tries to find all available symbols whose ;; print names contain string as a substring. (A symbol may be supplied for the ;; string, in which case the print name of the symbol is used.) Whenever apropos ;; finds a symbol, it prints out the symbol's name; in addition, information about ;; the function definition and dynamic value of the symbol, if any, is printed. ;; If package is specified and not nil, then only symbols available in that ;; package are examined; otherwise "all" packages are searched, as if ;; by do-all-symbols ;; ;; Argument(s): string or symbol ;; package (optional) ;; ;; Returns: nil ;; ;; Constraints/Limitations: none (do-test-group ("apropos-test-setup" :before (progn (setq testt-number1 1) (setq testt-number2 2) (setq testt-number3 3) (setq testt-number4 4) (setq dummy-testt-number1 nil) (setq dummy-testt-number2 nil) (setq dummy-testt-number3 nil) (defun dummy-function1-x nil 'x) (defun dummy-function1-y nil 'y) (defun dummy-function1-z nil 'z))) (do-test "apropos-test" (and(eq (apropos "testt") nil) (eq (apropos "dummy") nil) (eq (apropos 'function1) nil) (eq (apropos "apro") nil)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-DESCRIBE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-DESCRIBE.TEST new file mode 100644 index 00000000..0f9e585a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-DESCRIBE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: describe ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 441 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 9, 1986 ;; ;; Last Update: Dec 23, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-3-describe.test ;; ;; ;; Syntax: (describe object) ;; ;; Function Description: Describe prints, to the stream in the variable ;; *standard-output*, information about the object. Sometimes, it will describe ;; something that it finds inside something else; such recursive descriptions are ;; indented appropriately. For instance, describe of a symbol will exhibit the ;; symbol's value, its definition, and each of its properties. Describe of a ;; floating-point number will exhibit its internal representation in a way that ;; is useful for tracking down round-off errors and the like. ;; ;; Argument(s): object ;; ;; Returns: no values or what the expression (values) returns. ;; ;; Constraints/Limitations: Visual inspection of results is required to see if ;; the function describe prints sufficient information about the object. This is ;; dependent upon each implementation but it should return (values). ;; The following is an example of what describe might print: ;; (setq array-1 (make-array '(3 4) :initial-element 0)) ;; (describe array-1) => It is a simple-array (brief description) ;; Dimensions: (3 4) Element Type: t Adjustable: no Displaced: no, etc. (do-test "describe-test-function" (flet ((factorial (n) (lambda (n)(cond ((zerop n) 1) (t (* n (factorial (1- n)))))))) (eq (describe 'factorial) (values)) ) ) (do-test "describe-test-string" (let ((xyz "string")) (eq (describe xyz) (values)) ) ) (do-test "describe-test-number" (let ((number-1 10000.88)) (eq (describe number-1) (values)) ) ) (do-test "describe-test-hashtable" (let ((hashtable (make-hash-table :size 9))) (eq (describe hashtable) (values)) ) ) (do-test "describe-test-array" (let ((array-1 (make-array '(3 4) :initial-element 0))) (eq (describe array-1) (values)) ) ) (do-test "describe-test-structure" (let ((structure (defstruct line a b c))) (eq (describe structure) (values)) ) ) (do-test "describe-test-package" (let ((package-1 (make-package "abc-package" :nicknames '("NICKNAME-10")))) (and (eq (describe package-1) (values)) (if (and (fboundp 'delete-package) (member (find-package "abc-package") (list-all-packages)) ) (progn (delete-package (find-package "abc-package")) (identity T) ) T) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-ED.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-ED.TEST new file mode 100644 index 00000000..40467198 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-ED.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ed ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 442 ;; ;; Created By: John Park ;; ;; Creation Date: Oct 2, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-3-ed.test ;; ;; ;; Syntax: (ed &optional x) ;; ;; Function Description: If the implementation provides a resident editor, this function ;; should invoke it. (ed) or (ed nil) simply enters the editor, leaving one in the same ;; state as the last time he was in the editor. (ed pathname) edits the contents of the ;; file specified by pathname. The pathname may be an actual pathname or a string. ;; (ed symbol) tries to let you edit the text for the function named symbol. ;; ;; Argument(s): nil, pathname, or symbol ;; ;; Returns: ;; ;; Constraints/Limitations: This function requires user-interface so it's not realistic ;; to run this test automatically. This test merely tests to see if there is a global ;; function definition for ed, which does not necessarily mean it has met the require- ;; ments prescribed in CLtL. This will require manual testing. (do-test "ed-test" (fboundp 'ed)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-INSPECT.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-INSPECT.TEST new file mode 100644 index 00000000..ae01316a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-INSPECT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: inspect ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 442 ;; ;; Creatinspect By: John Park ;; ;; Creation Date: Oct 2, 1986 ;; ;; Last Update: ;; ;; Filinspect As: {ERIS}CML>TEST>25-3-inspect.test ;; ;; ;; Syntax: (inspect object) ;; ;; Function Description: Inspect is an interactive version of describe. The nature ;; of the interaction is implementation-dependent, but the purpose of inspect is to ;; make it easy to wander through a data structure, examining and modifying parts ;; of it. Implementations are encouraged to respond to the typing of the character ? ;; by providing help, including a list of commands. ;; ;; Argument(s): object ;; ;; Returns: process (i.e #) ;; ;; Constraints/Limitations: This function requires user-interface so it's not ;; realistic to run this test automatically. This test merely tests to see if ;; there is a global function definition for inspect, which does not necessarily ;; mean it has met the requirements prescribed in CLtL. This will require ;; manual testing. (do-test "inspect-test" (fboundp 'inspect)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-ROOM.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-ROOM.TEST new file mode 100644 index 00000000..ae0f49f1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-ROOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: room ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 441 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 9, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-3-room.test ;; ;; ;; Syntax: (room &optional x) ;; ;; Function Description: Room prints, to the stream in the variable ;; *standard-output*, information about the sate of internal storage and its ;; management. This might include descriptions of the amount of memory in use ;; and the degree of memory compaction, possibly broken down by internal data ;; type if that is appropriate. (room nil) prints out a minimal amount of ;; information. (room t) prints out a maximal amount of information. ;; Simply (room) prints out an intermediate amount of information that is likely ;; to be useful. ;; Example: ;; Type Assigned Free items In use ;; Total alloc ;; pages [items] ;; FIXP 10 1280 670 610 ;; 68329 ;; FLOATP 14 1792 1176 616 ;; 75731 ;; LISTP ~ 1126 130616 963 129653 ;; 1052227 ;; ARRAYP 4 256 163 93 ;; 9512 ;; STRINGP 146 9344 1367 7977 ;; 26366 ;; STACKP 2 256 256 0 ;; 737 ;; VMEMPAGEP 136 136 30 106 ;; 489 ;; STREAM 36 162 8 154 ;; 1226 ;; BITMAP 12 510 45 465 ;; 1560 ;; COMPILED-CLOSURE ;; 30 1920 1607 313 ;; 22852 ;; ONED-ARRAY 2 85 64 21 ;; 693 ;; TWOD-ARRAY 2 85 80 5 ;; 14 ;; GENERAL-ARRAY 2 64 53 11 ;; 327 ;; ;; TOTAL 5356 ;; ;; Data Spaces Summary ;; Allocated Remaining ;; Pages Pages ;; Datatypes (incl. LISTP etc.) 2020 \ ;; ArrayBlocks (variable) 3822 -- 51492 ;; ArrayBlocks (chunked) 3336 / ;; Litatoms 1036 1012 ;; ;; variable-datum free list: ;; le 4 19 items; 76 cells. ;; le 16 89 items; 939 cells. ;; le 64 48 items; 1261 cells. ;; le 256 5 items; 385 cells. ;; le 1024 1 items; 428 cells. ;; le 4096 1 items; 1456 cells. ;; le 16384 1 items; 7992 cells. ;; others 1 items; 30998 cells. ;; ;; Total cells free: 43535 total pages: 341 ;; ;; Argument(s): nil or t ;; ;; Returns: No value or (values) ;; ;; Constraints/Limitations: none (do-test "room-test" (and (eq (room) (values)) (eq (room t) (values)) (eq (room nil) (values)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-3-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-3-TIME.TEST new file mode 100644 index 00000000..9dea99cd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: time ;; ;; Source: Guy L Steele's CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 441 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 29,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-3-time.test ;; ;; ;; Syntax: (time form) ;; ;; Function Description: This evaluates form and returns what form returns. ;; However, as a side effect, various timing data and other information are printed ;; to the stream that is the value of *trace-output*. ;; ;; Argument(s): form ;; ;; Returns: value of (form) ;; ;; Constraints/Limitations: none (do-test "time-test" (and (equal (time (identity '(a b c))) '(a b c)) (eql (time (cos 0)) 1.0) (equal (time ((lambda (x y) (append x y)) '(a b) '(c d))) '(a b c d)) (eq (time (setq x 10000)) 10000) (equal (time (string 'strings)) "STRINGS"))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-DECODE-UNIVERSAL-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-DECODE-UNIVERSAL-TIME.TEST new file mode 100644 index 00000000..75e3fbd1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-DECODE-UNIVERSAL-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: decode-universal-time ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 446 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 19,1986 ;; ;; Last Update: Oct 2, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-4-decode-universal-time.test ;; ;; ;; Syntax: (decode-universal-time universal-time &optiona time-zone) ;; ;; Function Description: This function returns the time specified by universal-time ;; in Universal Time format, converted to Decoded Time format. ;; ;; Argument(s): Universal-time: time in Universal Time format (integer) ;; time-zone (&optional): integer (between -12 and 12) ;; ;; Returns: Nine values (second, minute, hour, date, month, year, day-of-week, ;; daylight-saving-time-p, and time-zone) ;; ;; Constraints/Limitations: none (do-test-group ("decode-universal-time-setup" :before (progn (setq universal-time (get-universal-time)) (setq decoded-time (multiple-value-list (decode-universal-time universal-time))) (setq decoded-time-zone0 (multiple-value-list (decode-universal-time universal-time 0))) (setq decoded-time-zone9 (multiple-value-list (decode-universal-time universal-time 9))) (setq Oct-1-86 (encode-universal-time 54 25 13 1 10 1986)) (defun decode-universal-timep (time-list) (if (and (eq (list-length time-list) 9) (every #'integerp (remove (eighth time-list) time-list)) (and (>= (first time-list) 0) (<= (first time-list) 59)) (and (>= (second time-list) 0) (<= (second time-list) 59)) (and (>= (third time-list) 0) (<= (third time-list) 23)) (and (>= (fourth time-list) 1) (<= (fourth time-list) 31)) (and (>= (fifth time-list) 1) (<= (fifth time-list) 12)) (>= (sixth time-list) 1986) (and (>= (seventh time-list) 0) (<= (seventh time-list) 6)) (or (eq (eighth time-list) T)(eq (eighth time-list) NIL)) (and (>= (ninth time-list) -12)(<= (ninth time-list) 12))) t nil)))) (do-test "decode-universal-time-test" (and (decode-universal-timep decoded-time) (decode-universal-timep decoded-time-zone0) (decode-universal-timep decoded-time-zone9) (eq (ninth decoded-time-zone0) 0) (eq (ninth decoded-time-zone9) 9) (> universal-time Oct-1-86) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-ENCODE-UNIVERSAL-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-ENCODE-UNIVERSAL-TIME.TEST new file mode 100644 index 00000000..9a881b11 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-ENCODE-UNIVERSAL-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: encode-universal-time ;; ;; Source: Guy L Steele's CLTL Chapter 24: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 443 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 20,1986 ;; ;; Last Update: Oct 6, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-4-encode-universal-time.test ;; ;; ;; Syntax: (encode-universal-time second minute hour date month year ;; &optional time-zone) ;; ;; Function Description: This function returns the encoded time (in Universal Time ;; format), which was specified by the given components of decoded time. ;; ;; Argument(s): Second (integer between 0 and 59, inclusive) ;; Minute (integer between 0 and 59, inclusive) ;; Hour (integer between 0 and 23, inclusive) ;; Date (integer between 1 and 31, inclusive) ;; Month (integer between 1 and 12) ;; Year (integer indicating the year A.D. eg: 1986) ;; Time-zone (optional) (integer specified as the number of hours ;; west of GMT (Greenwich Mean Time). eg: California- 8 ;; ;; Returns: Encoded time (integer) ;; ;; Constraints/Limitations: none (do-test-group ("encode-universal-time-setup" :before (progn (setq decoded-time-yr2000 '(23 30 7 28 8 2000)) (setq decoded-time-LA '(10 20 12 20 8 1986 8)) (setq decoded-time-LA-nosaving '(10 20 12 20 8 1986)) (setq decoded-time-Denver '(10 20 12 20 8 1986 7)) (setq decoded-time-Chicago '(10 20 12 20 8 1986 6)) (setq decoded-time-NewYork '(10 20 12 20 8 1986 5)) (setq decoded-time-GreenWich '(10 20 12 20 8 1986 0)) (setq decoded-time-Greenland '(10 20 12 20 8 1986 -2)) (setq decoded-time-HongKong '(10 20 12 20 8 1986 -8)) (setq decoded-time-yr1940 '(59 0 23 30 3 1940)) (setq decoded-time-list (list decoded-time-yr2000 decoded-time-LA decoded-time-Denver decoded-time-Chicago decoded-time-NewYork decoded-time-GreenWich decoded-time-Greenland decoded-time-HongKong decoded-time-yr1940)))) (do-test "encode-universal-time-test" (and (setq encoded-time-list (mapcar #'eval (mapcar #'(lambda (x) (append '(encode-universal-time) x)) decoded-time-list))) (every #'integerp encoded-time-list) (apply #'> encoded-time-list) (setq LA-time-saving-yes (eval (append '(encode-universal-time) decoded-time-LA))) (setq LA-time-saving-no (eval (append '(encode-universal-time) decoded-time-LA-nosaving))) (= (abs(- LA-time-saving-yes LA-time-saving-no)) 3600)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-DECODED-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-DECODED-TIME.TEST new file mode 100644 index 00000000..95523211 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-DECODED-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-decoded-time ;; ;; Source: Guy L Steele's CLTL Chapter 24: Miscellaneous Features ;; Section: 24.4.1 Time Functions ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-4-get-decoded-time.test ;; ;; ;; Syntax: (get-decoded-time) ;; ;; Function Description: This function returns the current time in Decoded Time ;; format. Nine values are returned; second, minute, hour, date, month, year, ;; day-of-week, daylight-saving-time-p, and time-zone. ;; ;; Argument(s): none ;; ;; Returns: second, minute, hour, date, month, year, ;; day-of-week, daylight-saving-time-p, and time-zone ;; ;; Constraints/Limitations: none (do-test-group "get-decoded-time-setup" :before (progn (defun get-decoded-timep (time-list) (if (and (eq (list-length time-list) 9) (every #'integerp (remove (eighth time-list) time-list)) (and (>= (first time-list) 0) (<= (first time-list) 59)) (and (>= (second time-list) 0) (<= (second time-list) 59)) (and (>= (third time-list) 0) (<= (third time-list) 23)) (and (>= (fourth time-list) 1) (<= (fourth time-list) 31)) (and (>= (fifth time-list) 1) (<= (fifth time-list) 12)) (>= (sixth time-list) 1986) (and (>= (seventh time-list) 0) (<= (seventh time-list) 6)) (or (eq (eighth time-list) T)(eq (eighth time-list) NIL)) (and (>= (ninth time-list) -12)(<= (ninth time-list) 12))) t nil)) (setq today (multiple-value-list (get-decoded-time)))) (do-test "get-decoded-time-test" (get-decoded-timep today))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-REAL-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-REAL-TIME.TEST new file mode 100644 index 00000000..33546de1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-REAL-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-internal-real-time ;; ;; Source: Guy L Steele's CLTL Chapter 24: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 446 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 20,1986 ;; ;; Last Update: Oct 7, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-4-get-internal-real-time.test ;; ;; ;; Syntax: (get-internal-real-time) ;; ;; Function Description: This function returns the current real time in Internal ;; Time Format. This time is relative to an arbitrary time base, but the difference ;; between the values of two calls to this function will be the amount of elapsed ;; real time between the two calls measured in the units defined by ;; internal-time-units-per-second. ;; ;; Argument(s): none ;; ;; Returns: Integer ;; ;; Constraints/Limitations: none (do-test-group ("get-internal-real-time-setup" :before (progn (setq before-internal-time (get-internal-real-time)) (defstruct science physics chemistry math) (setq after-internal-time (get-internal-real-time)))) (do-test "internal-time-units-per-second-exist?" (and (integerp internal-time-units-per-second) (boundp 'internal-time-units-per-second))) (do-test "get-internal-real-time" (and(integerp (get-internal-real-time)) (> (- after-internal-time before-internal-time) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-RUN-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-RUN-TIME.TEST new file mode 100644 index 00000000..d0bd3f6d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-INTERNAL-RUN-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-internal-run-time ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 446 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 20,1986 ;; ;; Last Update: Oct 2, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-4-get-internal-run-time.test ;; ;; ;; Syntax: (get-internal-run-time) ;; ;; Function Description: This function returns the current run time. The intent is ;; that the difference between the two calls during which computational effort was ;; expended on behalf of the executing program. ;; ;; Argument(s): none ;; ;; Returns: Integer ;; ;; Constraints/Limitations: none (do-test-group ("get-internal-run-time-setup" :before (progn (setq before-internal-time (get-internal-run-time)) (defstruct science physics chemistry math) (setq after-internal-time (get-internal-run-time)))) (do-test "internal-time-units-per-second-exist?" (and (integerp internal-time-units-per-second) (boundp 'internal-time-units-per-second))) (do-test "get-internal-run-time" (and(integerp (get-internal-run-time)) (> (- after-internal-time before-internal-time) 0)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-UNIVERSAL-TIME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-UNIVERSAL-TIME.TEST new file mode 100644 index 00000000..9b31f148 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-GET-UNIVERSAL-TIME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-universal-time ;; ;; Source: Guy L Steele's CLTL Chapter 24: Miscellaneous Features ;; Section: 24.4.1 Time Functions ;; Page: 184 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 19,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-4-get-universal-time.test ;; ;; ;; Syntax: (get-universal-time) ;; ;; Function Description: This function returns the current time of day as a single ;; integer in Universal Time format. ;; ;; Argument(s): none ;; ;; Returns: integer in Universal Time format. ;; ;; Constraints/Limitations: none (do-test-group "get-universal-time-setup" :before (progn (setq decoded-time (multiple-value-list (get-decoded-time))) (setq encoded-time (encode-universal-time (first decoded-time) (second decoded-time) (third decoded-time) (fourth decoded-time) (fifth decoded-time) (sixth decoded-time))) (setq universal-time (get-universal-time)) (setq Aug-19-1986 (encode-universal-time 0 0 0 19 8 1986))) (do-test "get-universal-time-test" (and (integerp universal-time) (>= universal-time encoded-time) (> universal-time Aug-19-1986)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-LISP-IMPLEMENTATION-VERSION.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-LISP-IMPLEMENTATION-VERSION.TEST new file mode 100644 index 00000000..3210deb3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-LISP-IMPLEMENTATION-VERSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: lisp-implementation-version ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-4-lisp-implementation-version.test ;; ;; ;; Syntax: (lisp-implementation-version) ;; ;; Function Description: A string is returned that identifies the version of ;; the particular common lisp implementation. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "lisp-implementation-version-test" (stringp (lisp-implementation-version))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-LONG-SITE-NAME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-LONG-SITE-NAME.TEST new file mode 100644 index 00000000..a95f68df --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-LONG-SITE-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: long-site-name ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-long-site-name.test ;; ;; ;; Syntax: (long-site-name) ;; ;; Function Description: A string is returned that identifies the physical ;; location of the computer hardware. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "long-site-name-test" (stringp (long-site-name))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-INSTANCE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-INSTANCE.TEST new file mode 100644 index 00000000..36b29e22 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-INSTANCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: machine-instance ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-machine-instance.test ;; ;; ;; Syntax: (machine-instance) ;; ;; Function Description: A string is returned that identifies the particular ;; instance of the computer hardware on which Common Lisp is running; this ;; might be a local nickname. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "machine-instance-test" (stringp (machine-instance))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-TYPE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-TYPE.TEST new file mode 100644 index 00000000..5859eafb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-TYPE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: machine-type ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: Dec 19, 86 ;; ;; Filed As: {ERIS}CML>TEST>25-5-machine-type.test ;; ;; ;; Syntax: (machine-type) ;; ;; Function Description: A string is returned that identifies the generic name ;; of the computer hardware on which Common Lisp is running. ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "machine-type-test" (if (string-equal (lisp-implementation-type) "Xerox") (or (string-equal (machine-type) "XEROX 1186") (string-equal (machine-type) "XEROX 1132") (string-equal (machine-type) "XEROX 1109") (string-equal (machine-type) "XEROX 1108")) (stringp (machine-type))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-VERSION.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-VERSION.TEST new file mode 100644 index 00000000..b614cc65 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-MACHINE-VERSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: machine-version ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-machine-version.test ;; ;; ;; Syntax: (machine-version) ;; ;; Function Description: A string is returned that identifies the version name ;; of the computer hardware on which Common Lisp is running. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "machine-version-test" (stringp (machine-version))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-SHORT-SITE-NAME.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-SHORT-SITE-NAME.TEST new file mode 100644 index 00000000..1289c09e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-SHORT-SITE-NAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: short-site-name ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-short-site-name.test ;; ;; ;; Syntax: (short-site-name) ;; ;; Function Description: A string is returned that identifies the physical ;; location of the computer hardware. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "short-site-name-test" (stringp (short-site-name))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-SLEEP.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-SLEEP.TEST new file mode 100644 index 00000000..9b8c2bf7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-SLEEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: sleep ;; ;; Source: Guy L Steele's CLTL Chapter 24: Miscellaneous Features ;; Section: 25.4.1 Time Functions ;; Page: 447 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 20,1986 ;; ;; Last Update: April 24, 1987 ;; ;; Filed As: {ERIS}CML>TEST>25-4-sleep.test ;; ;; ;; Syntax: (sleep n) ;; ;; Function Description: (sleep n) causes execution to cease and become dormant for ;; approximately n seconds of real time, whenupon execution is resumed. The argument ;; may be any non-negative non-complex number. ;; ;; Argument(s): none ;; ;; Returns: nil ;; ;; Constraints/Limitations: none (do-test-group ("sleep-test-setup" :before (progn (setq before-internal-time (get-internal-real-time)) (sleep 7) (setq after-internal-time (get-internal-real-time)) ;; For AR #8543 (setq before-internal-time2 (get-internal-real-time)) (sleep 0.10) (setq after-internal-time2 (get-internal-real-time)) ) ) (do-test "sleep-test" (and(eq (sleep 1) nil) (>= (abs(- after-internal-time before-internal-time)) 7000) ) ) (do-test "AR8543-test" (and(eq (sleep 0.10) nil) (>= (abs(- after-internal-time2 before-internal-time2)) 100) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-TYPE.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-TYPE.TEST new file mode 100644 index 00000000..796b84db --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-TYPE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: software-type ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-software-type.test ;; ;; ;; Syntax: (software-type) ;; ;; Function Description: A string is returned that identifies the generic name ;; of any relevant supporting software. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "software-type-test" (or (string-equal (software-type) "Xerox Lisp") (stringp (software-type)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-VERSION.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-VERSION.TEST new file mode 100644 index 00000000..9f7df2bd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-SOFTWARE-VERSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: software-version ;; ;; Source: Guy L Steele's CLTL Chapter 25: Miscellaneous Features ;; Section: 25.4.2 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>25-5-software-version.test ;; ;; ;; Syntax: (software-version) ;; ;; Function Description: A string is returned that identifies the version ;; of any relevant supporting software. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test "software-version-test" (stringp (software-version))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/25/25-5-IDENTITY.TEST b/internal/test/LANGUAGE/from-sun/language/25/25-5-IDENTITY.TEST new file mode 100644 index 00000000..7ce2612d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/25/25-5-IDENTITY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: identity ;; ;; Source: Guy L Steele's CLTL Chapter 25:Identity Function ;; Section: 25.5 Other Environment Inquiries ;; Page: 448 ;; ;; Created By: John Park ;; ;; Creation Date: Aug 21,1986 ;; ;; Last Update: Oct 7, 1986 ;; ;; Filed As: {ERIS}CML>TEST>25-5-identity.test ;; ;; ;; Syntax: (identity object) ;; ;; Function Description: This function is occasionally useful as an argument to ;; other functions that require functions as arguments. ;; ;; Argument(s): none ;; ;; Returns: string ;; ;; Constraints/Limitations: none (do-test-group ("identity-test-setup" :before (progn (setq array-object (make-array 10)) (setq hash-table-object (make-hash-table)) (setq random-state-object *random-state*) (setq read-table-object *readtable*) (setq stream-object *standard-output*) (setq structure-object (defstruct ship x y z)) (setq objects '(19 3/4 #C(1 -1) #\a 'abc "abc" '(a b c) t nil array-object hash-table-object *default-pathname-defaults* random-state-object read-table-object stream-object structure-object)) (defun identityp (pair) (if (equal (car pair) (cdr pair)) t nil)) )) (do-test "identity-test" (and (setq original-returned (pairlis objects (mapcar #'identity objects))) (notany #'null (mapcar #'identityp original-returned))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/4/4-7-DEFTYPE.TEST b/internal/test/LANGUAGE/from-sun/language/4/4-7-DEFTYPE.TEST new file mode 100644 index 00000000..f7dff256 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/4/4-7-DEFTYPE.TEST @@ -0,0 +1 @@ +;; Macro To Be Tested: deftype (and the cml type specifiers) ;; ;; Source: CLtL p. 50 ;; ;; Chapter 4: Type Specifiers Section 7: Defining New Type Specifiers ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 27 August 86 ;; ;; Last Update: 27 August 86 ;; ;; Filed As: {eris}cml>test>4-7-deftype-and-type-specifiers.test ;; ;; Syntax: deftype name lambda-list {declaration|doc-string}* {form}* ;; ;; Function Description: Define a new type specifier. ;; ;; Argument(s): name: the type name ;; lambda-list: arguments to the type specifier ;; {declaration|doc-string}*: just one of these, or neither, may appear ;; {form}*: zero or more or these as the body of the type specifier ;; ;; Returns: name ;; (do-test-group deftype-group :before (progn (test-setq string "deftype defines a new type specifier." pname (make-pathname) rtable *readtable* simvec '#(1 2 3 #\a #\B #\c *package*) vcvec (make-array (random 6) :element-type '(complex integer) :displaced-to (make-array 10 :element-type '(complex integer))) svcvec (make-array (random 6) :element-type '(complex integer)) sname (symbol-name (gentemp)) ) ;; Rem0 has to be global, because anything SATISFIES uses has to be global. (test-defun rem0 (arg) (= 0 (rem arg 2))) ) ; progn ;; (do-test member-true-test ;; The EQUAL checks to see if deftype returns the type name. (and (eq (deftype oddlot () `(member 0 ,pname ,rtable ,*package* ,string)) 'oddlot) (every #'(lambda (arg) (typep arg 'oddlot)) (list 0 *package* pname rtable string ) ) ) ) ; do-test 4-4-member-true-test ;; (do-test 4-4-member-false-test (notany #'(lambda (arg) (typep arg 'oddlot)) (list ;; String= isn't sufficient. "deftype defines a new type specifier." ;; Objects of different type are never eql. 0.0 ) ) ) ; do-test 4-4-member-false-test ;; (do-test 4-4-satisfies-test (and (eq (deftype even () '(and (satisfies integerp) (satisfies rem0))) `even) (typep 100 'even) (not (typep 100.00 'even)) (rem 100.0 2) (eq 'oddorstring (deftype oddorstring () '(or oddlot string))) (typep string 'oddorstring) (typep "deftype defines a new type specifier." 'oddorstring) (not (typep 0.00 'oddorstring)) ) ; and ) ; do-test 4-4-satisfies-test ;; (do-test 4-5-array-test (and ;; v2da is a type containing vectors of any length whose elements are 2-dimensional integer arrays. Width and height of the element integers may be specified. (eq 'v2da (deftype v2da (&optional width height) `(array (array integer ,width ,height) (*)))) (typep (make-array (random 20) :initial-element (make-array '(2 2) :initial-contents (list (list 1 2) (list 3 4)))) 'v2da) (typep (make-array 10 :element-type '(array integer (5 4)) :fill-pointer t) '(v2da (5 4))) ) ; and ) ; do-test 4-5-array-test ;; (do-test 4-5-simple-array-test ;; Must be simple-arrays with only string-chars. This includes all simple strings, but also multi-dimensional arrays. (and (eq 'simple-and-string (deftype simple-and-string () '(and simple-array (array string-char)))) (typep (make-array '(5 4 3 2 1) :initial-element #\newline :element-type 'string-char) 'simple-and-string) ;; Not limited to string-char (not (typep (make-array '(5 4 3 2 1) :initial-element #\newline) 'simple-and-string)) ;; Not simple. (not (typep (make-array '(5) :initial-element #\newline :element-type 'string-char :fill-pointer t) 'simple-and-string)) (not (typep (make-array 20 :element-type 'string-char :displaced-to "This is a string of more than twenty characters.") 'simple-and-string)) (not (typep (make-array '(3 3 3) :element-type 'string-char :adjustable t) 'simple-and-string)) ) ; and ) ; do-test 4-5-simple-array-test ;; ;; NOTE: not working in 30 Dec. sysout; see AR 7184. (do-test 4-5-symbol-names-test (and (typep (symbol-name 'atom) 'string) (typep (symbol-name 'atom) 'array) (typep (symbol-name 'atom) '(array string-char)) (typep (symbol-name 'atom) '(array string-char (*)))) ) ; do-test 4-5-symbol-names-test ;; (do-test 4-5-vectors-and-complex-test (and (eq 'vc (deftype vc () '(vector (complex integer) *))) (eq 'svc (deftype svc () '(simple-vector *))) (typep svcvec 'vc) (typep svcvec 'svc) (notany #'(lambda (arg type) (typep arg type)) '(simvec vc) '(vc svc) ) ; notany ) ; and ) ; do-test 4-5-vectors-and-complex-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/4/4-8-COERCE.TEST b/internal/test/LANGUAGE/from-sun/language/4/4-8-COERCE.TEST new file mode 100644 index 00000000..1a67285e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/4/4-8-COERCE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: coerce ;; ;; Source: CLtL p. 51 ;; ;; Chapter 4: Strings Section 8: Type Conversion Function ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 6 October 86 ;; ;; Last Update: Feb 3, 87 Jim Blum ;; ;; Filed As: {eris}cml>test>4-8-coerce.test ;; ;; Syntax:coerce object result-type ;; ;; Function Description: Turns object into a like object of type result-type. ;; ;; Argument(s): object - any cml object that may be converted to an object of type result-type ;; result-type - any defined cml type specifier ;; ;; Returns: the converted object ;; (do-test-group coerce-group :before (progn (test-setq bound 0 type-examples (list (1+ most-positive-fixnum) ; bignum; common 0 ; bit; t 27/60 ; rational; ratio 5.00 ; float; double-float; single-float; long-float; short-float 3.1415926535897932384d0 #c( 6/7 3.00) ; complex #\* ; standard-char; character #\backspace ; semi-standard bound ; bound symbol (gentemp) ; unbound symbol '( a b c . d) ; cons; sequence (list) ; list (vector 5 4 3 2 1) ; vector " string " ; string; simple-string; simple-array #*1001 ; bit-vector; simple-bit-vector #'+ ; compiled-function #'(lambda nil nil) ; function (random 1000) ; integer; atom; fixnum (make-hash-table) ; hash-table :key ; keyword (copy-readtable) ; readtable nil ; null (car(list-all-packages)) ; package (pathname nil) ; pathname (make-synonym-stream nil) ; stream *random-state* ; random-state ) ; list ) ; test-setq (test-defun charcoercetest (object expected-result) "See if an object coerced to a character is char= the expected result; if it's an integer, see if it's char= (int-char object)." (let ((result (coerce object 'character))) (and (char= result expected-result) (cond ((integerp object) (char= result (int-char object)) ) ;; Non-integers get this one for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ) ; progn ;; (do-test coerce-converts-sequence-types-test (and ;; A sequence of one type can be converted to a sequence of another type. (listp (coerce '((1 2 3)(4 5 6)) 'list)) (let ((hexarray (make-array 5 :initial-contents '(#\E 8 3 0 #\B) ) ; make-array ) ; hexarray ) ; values (outer let) (let ((hexlist (coerce hexarray 'list))) ;; Corresponding elements must be eql. (and (eql (car hexlist) (aref hexarray 0)) (eql (aref hexarray (1- (length hexlist))) (car (reverse hexlist))) ) ; and ) ; inner let ) ; outer let ) ; and ) ; do-test coerce-converts-sequence-types-test ;; (do-test coerce-to-character-test ;; Digits, one-character strings and one-character symbols are coercible to characters. (every 'charcoercetest (list "a" "*" #\newline (char-int #\A) 1000 '? (make-symbol "?")) (list #\a #\* #\newline #\A (int-char 1000) #\? #\?) ) ) ; do-test coerce-to-character-test ;; (do-test coerce-to-float-test ;; Non-complex numbers are coercible to floating-point. (AND (typep (coerce (random 1000) 'float) 'float) (typep (coerce 100/1000 'long-float) 'long-float) (typep (coerce (* 3/4 50) 'double-float) 'double-float) (typep (coerce (* 35e2) 'single-float) 'single-float) ) ; and ) ; do-test coerce-to-float-test (do-test coerce-to-complex-test ;; Any number is coercible to complex (AND (eql (coerce #c(3 5) (type-of #c(3 5))) #c(3 5)) (typep (coerce 3/4 'complex) 'ratio) (typep (coerce (coerce 3/4 'double-float)'complex) 'complex) (typep (coerce (random 1000) 'complex) 'integer) ) ; AND ) ; do-test coerce-to-complex-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/4/4-9-TYPE-OF.TEST b/internal/test/LANGUAGE/from-sun/language/4/4-9-TYPE-OF.TEST new file mode 100644 index 00000000..c02a3ecf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/4/4-9-TYPE-OF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: type-of ;; ;; Source: CLtL p. 52 ;; ;; Chapter 4: Type Specifiers Section 9: Determining the Type of an Object ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 16 September 86 ;; ;; Last Update: 1 January 87 ;; ;; Filed As: {eris}cml>test>4-9-type-of.test ;; ;; Syntax: type-of object ;; ;; Function Description: find a standard type of which object is a member (object's canonical type). ;; ;; Argument(s): object - any commonlisp object ;; ;; Returns: a type name ;; (do-test type-of-test (let ((bound 0)) ;; Steele's requirement is simply that the function return some defined type. (every 'type-of (list (1+ most-positive-fixnum) ; bignum; common 0 ; bit; t 27/60 ; rational; ratio 5.00 ; float; double-float; single-float; long-float; short-float 3.1415926535897932384d0 #c( 6/7 3.00) ; complex #\* ; standard-char; character #\backspace ; semi-standard bound ; bound symbol (gentemp) ; unbound symbol '( a b c . d) ; cons; sequence (list) ; list (vector 5 4 3 2 1) ; vector " string " ; string; simple-string; simple-array #*1001 ; bit-vector; simple-bit-vector #'+ ; compiled-function #'(lambda nil nil) ; function (random 1000) ; integer; atom; fixnum (make-hash-table) ; hash-table :key ; keyword (copy-readtable) ; readtable nil ; null (car(list-all-packages)) ; package (pathname) ; pathname (make-synonym-stream) ; stream *random-state* ; random-state ) ; list ) ; every ) ; let ) ; do-test STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-EXPRESSIONS.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-EXPRESSIONS.TEST new file mode 100644 index 00000000..4230aceb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-EXPRESSIONS.TEST @@ -0,0 +1 @@ +;; ;; ;; 5.2.2. Lambda-expressions ;; ;; test cases copied from page 63 - 65 of CLtL ;; ;; test file created by Karin M. Sye on Nov. 9, 1986 ;; (do-test "test Lambda-expressions - examples of &optional and &rest parameters 0" (and (= ((lambda (a b) (+ a (* b 3))) 4 5) 19) (= ((lambda (a &optional (b 2)) (+ a (* b 3))) 4 5) 19) (= ((lambda (a &optional (b 2)) (+ a (* b 3))) 4) 10) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x))) '(2 nil 3 nil nil)) ) ) (do-test "test Lambda-expressions - examples of &optional and &rest parameters 1" (and (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6) '(6 t 3 nil nil)) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3) '(6 t 3 t nil)) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8) '(6 t 3 t (8))) (equal ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8 9 10 11) '(6 t 3 t (8 9 10 11))) ) ) (do-test "test Lambda-expressions - examples of &key parameters 0" (and (equal ((lambda (a b &key c d) (list a b c d)) 1 2) '(1 2 nil nil)) (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6) '(1 2 6 nil)) (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8) '(1 2 nil 8)) (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6 :d 8) '(1 2 6 8)) ) ) (do-test "test Lambda-expressions - examples of &key parameters 1" (and (equal ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8 :c 6) '(1 2 6 8)) (equal ((lambda (a b &key c d) (list a b c d)) :a 1 :d 8 :c 6) '(:a 1 6 8)) (equal ((lambda (a b &key c d) (list a b c d)) :a :b :c :d) '(:a :b :d nil)) ) ) (do-test "test Lambda-expressions - examples of mixtures 0" (and (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1) '(1 3 nil 1 nil)) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 2) '(1 2 nil 1 nil)) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) :c 7) '(:c 7 nil :c nil)) ) ) (do-test "test Lambda-expressions - examples of mixtures 1" (and (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :c 7) '(1 6 7 1 (:c 7))) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8) '(1 6 nil 8 (:d 8))) (equal ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8 :c 9 :d 10) '(1 6 9 8 (:d 8 :c 9 :d 10))) ) ) (do-test "test Lambda-expressions - examples of &aux " (and (equal ((lambda (x y &aux (a (car x)) (b 2) c) (list x y a b c)) '(6 8 10) '(3 4 5)) '( (6 8 10) (3 4 5) 6 2 nil)) (equal ((lambda (&optional (a 2) (b 4) &rest x &aux (c (+ a b)) d (e b)) (list a b c d e x)) 22) '(22 4 26 nil 4 nil)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-LIST-KEYWORDS.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-LIST-KEYWORDS.TEST new file mode 100644 index 00000000..9b933fec --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-LIST-KEYWORDS.TEST @@ -0,0 +1 @@ +;; ;; LAMBDA-LIST-KEYWORDS {Constant] ;; ;; The value of LAMBDA-LIST-KEYWORDS is a list of all the lambda-list-keywords, which must contain at least ;; the symbols &optional, &rest, &key, &allow-other-kwys, &aux, &body, &whole, and &environment ;; ;; Oct. 7, 1986 ;; Karin Sye ;; ;; page 65 of CLtL ;; (do-test "test lambda-list-keywords" (every #'(lambda (x) (find x lambda-list-keywords)) '(&optional &rest &key &allow-other-keys &aux &body &whole &environment)) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST new file mode 100644 index 00000000..782fc1ea --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST @@ -0,0 +1 @@ +;; ;; LAMBDA-PARAMETERS-LIMIT [Constant] ;; ;; The value of LAMBDA-PARAMETERS-LIMIT is a positive integer that is the upper exclusive bound on the number of distinct ;; parameter names that may appear in a single lambda-list. This bound will not be smaller than 50. ;; (do-test "test lambda-parameters-limit" (and (integerp lambda-parameters-limit) (>= lambda-parameters-limit 50)) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-3-1-DEFUN.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-3-1-DEFUN.TEST new file mode 100644 index 00000000..83a158d8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-3-1-DEFUN.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defun ;; ;; Source: CLtL p. 67 ;; Chapter 5: Program Structure Section 3.1: Defining Named Functions ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 9, 86 ;; ;; Last Update: Feb 3, 1987 Jim Blum - changed DOCUMENTATION defun ;; and fixed (declare (type (array * (10))) ) ;; in &allow-other-keys test ;; ;; Filed As: {eris}cml>test> 5-3-1-defun.test ;; ;; ;; Syntax: defun NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}* ;; ;; Function Description: The defun special form is the usual means of defining named functions. For detailed description, please ;; read page 66-67 of CLtL ;; ;; Argument(s): NAME - a symbol which is the global name for the defined function ;; LAMBDA-LIST - (see page 60-61 of CLtL) ;; DECLARATION - a declaration form ;; DOC-STRING - a string ;; FORM - a lisp form ;; ;; Returns: NAME ;; (do-test "test defun - examples of &optional and &rest parameters 0" (progn (defun foo (a b) (+ a (* b 3))) (defun foo2 (a &optional (b 2)) (+ a (* b 3))) (and (= (foo 4 5) 19) (= (foo2 4 5) 19) (= (foo2 4) 10) ) ) ) (do-test "test defun - examples of &optional and &rest parameters 1" (progn (defun foo (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) (and (equal (foo ) '(2 nil 3 nil nil)) (equal (foo 6) '(6 t 3 nil nil)) (equal (foo 6 3) '(6 t 3 t nil)) (equal (foo 6 3 8) '(6 t 3 t (8))) (equal (foo 6 3 8 9 10 11) '(6 t 3 t (8 9 10 11))) ) ) ) (do-test "test defun - examples of &key parameters" (progn (defun foo (a b &key c d) (list a b c d)) (and (equal (foo 1 2) '(1 2 nil nil)) (equal (foo 1 2 :c 6) '(1 2 6 nil)) (equal (foo 1 2 :d 8) '(1 2 nil 8)) (equal (foo 1 2 :c 6 :d 8) '(1 2 6 8)) (equal (foo 1 2 :d 8 :c 6) '(1 2 6 8)) (equal (foo :a 1 :d 8 :c 6) '(:a 1 6 8)) (equal (foo :a :b :c :d) '(:a :b :d nil)) ) ) ) (do-test "test defun - examples of mixtures" (progn (defun foo (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) (and (equal (foo 1) '(1 3 nil 1 nil)) (equal (foo 1 2) '(1 2 nil 1 nil)) (equal (foo :c 7) '(:c 7 nil :c nil)) (equal (foo 1 6 :c 7) '(1 6 7 1 (:c 7))) (equal (foo 1 6 :d 8) '(1 6 nil 8 (:d 8))) (equal (foo 1 6 :d 8 :c 9 :d 10) '(1 6 9 8 (:d 8 :c 9 :d 10))) ) ) ) (do-test "test defun - examples of &aux" (progn (defun foo (x y &aux (a (car x)) (b 2) c) (list x y a b c)) (defun foo2 (&optional (a 2) (b 4) &rest x &aux (c (+ a b)) d (e b)) (list a b c d e x)) (and (equal (foo '(6 8 10) '(3 4 5)) '( (6 8 10) (3 4 5) 6 2 nil)) (equal (foo2 22) '(22 4 26 nil 4 nil)) ) ) ) (do-test "test defun - with &allow-other-keys" (let (aray1) (declare (type (array * (10))) ) (defun foo (str dims &rest keyword-pairs &key (start 0) end &allow-other-keys) (apply #'make-array dims :initial-element (subseq str start end) :allow-other-keys t keyword-pairs)) (and (setq aray1 (foo "string" 5 :element-type 'string :start 1 :end 5)) (equal (array-dimensions aray1) '(5)) (equal (mapcar #'(lambda (x) (aref aray1 x)) '(0 1 2 3 4)) (make-list 5 :initial-element "trin")) ) ) ) (do-test "test defun - the forms constitute the body are executed as an implicit progn" (progn (defun foo ()) (defun foo2 () (values 1 2 3 4 5 6)) (and (not (foo)) (equal (multiple-value-list (foo2)) '(1 2 3 4 5 6)) ) ) ) (do-test "test defun - the body is implicitly enclosed in a block construct" (progn (defun foo () 1 3 5 (return-from foo 4321) 7 8 9) (= (foo) 4321) ) ) (do-test "test defun - with doc-string" (progn (defun foo () "a b c") (setf (documentation 'foo 'function) "foo") (defun foo2 () "a b c" "a b c") (and (equal (foo) "a b c") (equal (foo2) "a b c") (equal (documentation 'foo 'function) "foo") (equal (documentation 'foo2 'function) "a b c") ) ) ) (do-test "test defun - name is returned as the value of the defun form" (and (eq (defun foo () "foo fun" (+ 2 3)) 'foo) (eq (defun foo2 (x y) (declare (number x y)) "foo fun again" (list x y)) 'foo2) ) ) (do-test "test defun - use defun to redefine a function/macro as a function" (progn (defun foo () 78) (defmacro mac () 90) (defun foo () (+ 78 78)) (defun mac () (- 90 78)) (and (equal (list (foo) (mac)) '(156 12)) (eq (macro-function 'mac) nil) ) ) ) (do-test "test defun - test case copied from page 67 of CLtL" (progn (defun foo (a b c) (declare (number a b c)) "Compute the foo for a quadratic equation.Given a, b, and c, the value ...." (- (* b b) (* 4 a c))) (and (equal (foo 1 2/3 -2) 76/9) (equal (documentation 'foo 'function) "Compute the foo for a quadratic equation.Given a, b, and c, the value ....") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFCONSTANT.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFCONSTANT.TEST new file mode 100644 index 00000000..0273d57e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFCONSTANT.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defconstant ;; ;; Source: CLtL p. 68 ;; Chapter 5: program structure Section 3.2: Declaring global variables and named constants ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 8, 86 ;; ;; Last Update: Nov. 8, 86 ;; ;; Filed As: {eris}cml>test>5-3-2-defconstant.test ;; ;; ;; Syntax: defconstant NAME INITIAL-VALUE [DOCUMENTATION] ;; ;; Function Description: defconstant is like defparameter but does assert that the value of the variable name is fixed ;; and does license the compiler to build assumptions about the value into ptograms being compiled. ;; ;; Argument(s): name - a variable ;; initial-value - a lisp form ;; documentation - a string ;; ;; Returns: NAME ;; (do-test "test defconstant - test case copied from page 68 of CLtL" (prog2 (defconstant *visible-windows-defc1* 0 "Number of windows at least partially visible on the screen") (and (zerop *visible-windows-defc1*) (equal (documentation '*visible-windows-defc1* 'variable) "Number of windows at least partially visible on the screen") ) ) ) (do-test "test defconstant 0" (= (catch 'cat (defconstant *defcons2* (gcd 10 12)) (let () (throw 'cat (1+ *defcons2*)))) 3) ) (do-test-group ( "test defconstant 1" :before (progn (defconstant *defcons30* 789) (defun foo2 () (let () (defun fun () (let ((a *defcons30* )) (+ (fun1) a) )) (defun fun1 () *defcons30* ) (fun) )) )) (do-test "test defconstant 1" (and (= (foo2) (* 2 789)) (= *defcons30* 789) ) ) ) (do-test "test defconstant - The initial-value form is evaluated and the result assigned to the variable" (let ((j 0) (k 0)) (and (progn (defconstant *reshaped-window-defc4* (incf j)) (= *reshaped-window-defc4* j 1)) ;;(progn (proclaim '(special *reshaped-window-defc5*)) ;; (setq *reshaped-window-defc5* 7) ;; (defconstant *reshaped-window-defc5* (incf k)) ;; (equal (list *reshaped-window-defc5* k) '(1 1)) ) ) ) ) (do-test "test defconstant - with documentation" (progn (defconstant *shrinked-window-defc10* (cos 0) "number of shrinked window-defc10") (equal (list (documentation '*shrinked-window-defc10* 'variable) (1+ *shrinked-window-defc10*) (documentation '*shrinked-window-defc10* 'variable) ) '("number of shrinked window-defc10" 2.0 "number of shrinked window-defc10") ) ) ) (do-test "test defconstant - the value returned is the name declared" (and (equal (defconstant *defc12* 1) '*defc12*) (equal (defconstant *defc14* 2 "str2") '*defc14*) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFPARAMETER.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFPARAMETER.TEST new file mode 100644 index 00000000..2aa62a74 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFPARAMETER.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defparameter ;; ;; Source: CLtL p. 68 ;; Chapter 5: program structure Section 3.2: Declaring global variables and named constants ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 8, 86 ;; ;; Last Update: Nov. 8, 86 ;; ;; Filed As: {eris}cml>test>5-3-2-defparameter.test ;; ;; ;; Syntax: defparameter NAME INITIAL-VALUE [DOCUMENTATION] ;; ;; Function Description: defparameter is similar to defvar, but defparameter requires an initial-value form, always evaluates ;; the form, and assigns the result to the variable. defparameter is intended to declare a variable ;; that is normally constant but can be changed. defparameter therefore does not indicate that the ;; quantity never changes; in particular, it does not license the compiler to build assumptions about ;; the value into programs being compiled. ;; ;; ;; Argument(s): name - a variable ;; initial-value - a lisp form ;; documentation - a string ;; ;; Returns: NAME ;; (do-test "test defparameter - test case copied from page 68 of CLtL" (prog2 (defparameter *visible-window-defp1* 0 "Number of window-defp1 at least partially visible on the screen") (and (zerop *visible-window-defp1*) (equal (documentation '*visible-window-defp1* 'variable) "Number of window-defp1 at least partially visible on the screen") ) ) ) (do-test "test defparameter - defparameter proclaims variable to be a special 0" (= (catch 'cat (defparameter *defp2* (gcd 10 12)) (let ( (*defp2* (lcm 10 12)) ) (throw 'cat (locally (declare (special *defp2*)) (1+ *defp2*))) )) 61)) (do-test-group ( "test defparameter 1" :before (progn (defparameter *defp88* 789) (defun foo2 () (let () (defun fun () (let () (fun1) )) (defun fun1 () (locally (declare (special *defp88*)) *defp88*) ) (fun) )) )) (do-test "test defparameter - defparameter proclaims variable to be a special 1" (and (= (foo2) 789) (= *defp88* 789) ) ) ) (do-test "test defparameter - The initial-value form is evaluated and the result assigned to the variable" (let ((i 0) (j 0) (k 0)) (and (progn (defparameter *reshaped-window-defp4* (incf i)) (= i 1) ) (progn (defparameter *reshaped-window-defp5* (incf j)) (= *reshaped-window-defp5* j 1) ) ;;(progn (proclaim '(special *reshaped-window-defp6*)) ;; (setq *reshaped-window-defp6* 7) ;; (defparameter *reshaped-window-defp6* (incf k)) ;; (equal (list *reshaped-window-defp6* k) '(1 1)) ) ) ) ) (do-test "test defparameter - with documentation" (progn (defparameter *shrinked-window-defp10* (cos 0) "number of shrinked window-defp10") (equal (list (documentation '*shrinked-window-defp10* 'variable) (1+ *shrinked-window-defp10*) (documentation '*shrinked-window-defp10* 'variable) ) '("number of shrinked window-defp10" 2.0 "number of shrinked window-defp10") ) ) ) (do-test "test defparameter - the value returned is the name declared" (and (equal (defparameter *defp15* 1) '*defp15*) (equal (defparameter *defp18* 2 "str2") '*defp18*) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFVAR.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFVAR.TEST new file mode 100644 index 00000000..ba7716d6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-3-2-DEFVAR.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: defvar ;; ;; Source: CLtL p. 68 ;; Chapter 5: program structure Section 3.2: Declaring global variables and named constants ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 7, 86 ;; ;; Last Update: Nov. 7, 86 ;; ;; Filed As: {eris}cml>test>5-3-2-defvar.test ;; ;; ;; Syntax: defvar NAME [INITIAL-VALUE [DOCUMENTATION]] ;; ;; Function Description: defvar is the recommended way to declare the use of a special variable in a program ;; (defvar variable) proclaims variable to be special, and my perform other system-dependent ;; bookkeeping actions. If a second "argument" is supplied, (defvar variable initial-value) ;; then variable is initialized to the result of evaluating the form initial-value unless it ;; already has a value. The initial-value form is not evaluated unless it is used. defvar also ;; provides a good place to put a comment describing the meaning of the variable. The value ;; returned is the name declared. ;; ;; ;; Argument(s): name - a variable ;; initial-value - a lisp form ;; documentation - a string ;; ;; Returns: NAME ;; (do-test "test defvar - test case copied from page 68 of CLtL" (makunbound '*visible-window-defv1*) (defvar *visible-window-defv1* 0 "Number of window-defv1 at least partially visible on the screen") (and (zerop *visible-window-defv1*) (equal (documentation '*visible-window-defv1* 'variable) "Number of window-defv1 at least partially visible on the screen") (setq *visible-window-defv1* 1) (defvar *visible-window-defv1* 0) (= *visible-window-defv1* 1) ; initial value should not take effect since var is already defined ) ) (do-test "test defvar - defvar proclaims variable to be a special 0" (= (catch 'cat (defvar *defv2* (gcd 10 12)) (let ( (*defv2* (lcm 10 12)) ) (throw 'cat (locally (declare (special *defv2*)) (1+ *defv2*))) )) 61)) (do-test-group ( "test defvar - defvar proclaims variable to be a special 1" :before (progn (defvar *defv3* 789) (defun foo () (let ( (y 100)) (defun fun () (let ((y 20)) (fun1) )) (defun fun1 () y) (fun) )) (defun foo2 () (let () (defun fun () (let ((*defv3* 20)) (fun1) )) (defun fun1 () (locally (declare (special *defv3*)) *defv3*) ) (fun) )) )) (do-test "test defvar - defvar proclaims variable to be a special 1" (and (= (foo) 100) (= (foo2) 20) (= *defv3* 789) ) ) ) (do-test "test defvar - The initial-value form is not evaluated unless the variable is used." (let ((k 0)) (progn (proclaim '(special *reshaped-window-defv8*)) (setq *reshaped-window-defv8* 7) (defvar *reshaped-window-defv8* (incf k)) (equal (list *reshaped-window-defv8* k) '(7 0)) ) ) ) (do-test "test defvar - with documentation" (progn (defvar *shrinked-window-defv12* (cos 0) "number of shrinked window-defv12") (equal (list (documentation '*shrinked-window-defv12* 'variable) (1+ *shrinked-window-defv12*) (documentation '*shrinked-window-defv12* 'variable) ) '("number of shrinked window-defv12" 2.0 "number of shrinked window-defv12") ) ) ) (do-test "test defvar - the value returned by defvar is the name declared" (and (eq (defvar var1 1) 'var1) (eq (defvar var3 3 "str3") 'var3) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/5/5-3-3-EVAL-WHEN.TEST b/internal/test/LANGUAGE/from-sun/language/5/5-3-3-EVAL-WHEN.TEST new file mode 100644 index 00000000..45ba62db --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/5/5-3-3-EVAL-WHEN.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: eval-when ;; ;; Source: CLtL p. 69 ;; Chapter 5: Program Structure Section 3.3: Control of Time of Evaluation ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 9, 86 ;; ;; Last Update: Nov. 9, 86 ;; ;; Filed As: {eris}cml>test> 5-3-3-eval-when.test ;; ;; ;; Syntax: eval-when ({situation}*) {form}* ;; ;; Function Description: The body of an eval-when form is processed as as implicit progn, but only in the situations listed. ;; Each situation must be a sumbol, either compile, load, or eval. Eval specifies that the ;; interpreter should process the body. Compile specifies that the compiler should evaluate the body ;; at compile time in the compilation context. Load specifies that the compiler should arange to ;; evaluate the forms in the body when the compiled file containing the eval-when form is loaded. ;; ;; Argument(s): situation - compile, load, or eval ;; ;; Returns: anything ;; ;;This test is incredibly bogus. -- Pavel (do-test "test eval-when 0" (and ; (equal (multiple-value-list (eval-when (eval) (values 2 3 4))) '(2 3 4)) ; (equal (eval-when (eval) (list 'a 'b 'c 'd 'e)) '(a b c d e)) T) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-1-SUBTYPEP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-1-SUBTYPEP.TEST new file mode 100644 index 00000000..572c22a6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-1-SUBTYPEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: subtypep ;; Subtypep not implemented 19 September ;; ;; Source: CLtL p. 72 ;; ;; Chapter 6: Predicates Section 2-1: General Type Predicates ;; ;; Created By: Greg Nuyens and Peter Reidy ;; ;; Creation Date: 17 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-1-subtypep.test ;; ;; Syntax: sybtypep type1 type2 ;; ;; Function Description: Tells if type1 is a subtype of type2. ;; ;; Argument(s): type1, type2 - any valid cml types ;; ;; Returns: two values, the result of the test and the degree of certainty. T T indicates that type1 is definitely a subtype of type2. NIL T indicates that it definitely isn't. NIL NIL indicates that the function could not determine the relation between the types. ;; (do-test-group subtypep-group :before (progn (test-defun subtest (type1 type2 expected-result expected-certainty) (let ((vals-list (multiple-value-list (subtypep type1 type2)))) (and (eq expected-result (car vals-list)) (eq expected-certainty (cadr vals-list)) (= 2 (length vals-list)) ) ; and ) ; let ) ; test-defun (deftype arbitrary () '(or simple-vector compiled-function)) ) ; progn ;; (do-test "every type is subtypep itself" (every #'(lambda (type) (subtest type type t t)) '(arbitrary atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float null number package pathname ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; every ) ; do-test ;; (do-test "subtypep: proper subtypes are subtypes" (and ;; Try some standard types. (every #'(lambda (type) (subtest type type t t)) '(integer fixnum number atom t) ) (every #'(lambda (type) (subtest type type t t)) '(bit-vector vector array sequence t) ) ;; It doesn't work in reverse. (notany #'(lambda (type) (subtest type type nil t)) '(atom number fixnum integer) ) ) ) ;; (do-test "subtypep with a user-defined OR types" (and (subtest 'simple-vector 'arbitrary t t) (subtest 'arbitrary 'simple-vector nil t) ;; Not sure what's supposed to happen here. (subtest 'arbitrary '(or vector function) t t) ) ; AND ) ; do-test proper-subtypep-test ;; (do-test "subtypep with AND types" (and (subtest 'float '(and symbol float) nil t) (subtest '(and symbol float) 'float t t) ) ) ;; (do-test "subtypep with defstruct" (defstruct t-super a) (defstruct (t-root (:include t-super)) b) (deftype deft-root () 't-root) (deftype deft-super () 't-super) (and (subtest 't-root 't-super t t) (subtest 't-super 't-root nil t) (subtest 'nil 't-super t t) (subtest 't-root 'nil nil t) (subtest 'deft-root 't-super t t) (subtest 't-root 'deft-super t t ) (subtest 'deft-root 'deft-super t t) ) ) ;; (do-test "subtypep with null intersection" ;; and-t-float-t-super has a null intersection, so nothing should ever be a subtype of it. (deftype and-t-float-t-super () '(and float t-super)) (deftype and-t-float-t-root () '(and float t-root)) (and (subtest 't-super 'and-t-float-t-super nil t) (subtest 'float 'and-t-float-t-super nil t) (subtest 't-root 'and-t-float-t-super nil t) (subtest 'deft-root 'and-t-float-t-super nil t) (subtest 'deft-super 'and-t-float-t-super nil t) ;; on the other hand, it can be detected as the subtype of many things (subtest 'and-t-float-t-super 't-super t t) (subtest 'and-t-float-t-super 'float t t) (subtest 'and-t-float-t-super 't-root nil nil) (subtest 'and-t-float-t-super 'deft-root nil nil) (subtest 'and-t-float-t-super 'deft-super t t) (subtest 'and-t-float-t-root 't-super t t) (subtest 'and-t-float-t-root 't-root t t) (subtest 'and-t-float-t-root 'deft-super t t) ) ; and ) ;; (do-test "subtypep with unknown disjunct" (deftype t-unknown () '(satisfies god-knows-what-partial-recursive-function)) (and (subtest '(or (satisfies gkwprf) float) 'float nil nil) (subtest '(or t-unknown float) 'float nil nil ) (subtest '(or float t-unknown) 'float nil nil) (subtest '(or t-unknown float) 't-unknown nil nil) (subtest '(or float t-unknown) 't-unknown nil nil) ) ) ;; (do-test "subtypep with non-subtypep disjunct" (and ;; if we know that some disjunct is not a subtype, then the union isn't either. (subtest '(or t-root float) 'float nil t) ;; however, if both disjuncts are known to be sub-types, then it is known to be true (subtest '(or float float) 'float t t) ;; if none is known, we still aren't sure since the union may be a partition of the first type. (subtest 'float '(or t-unknown (satisfies gkwprf)) nil nil) (subtest 'float '(or float t-unknown) t t) (subtest 'float '(or t-unknown float) t t) ) ) ;; (do-test "subtypep with arrays" (and (subtest '(simple-array t ) '(array t ) t t) (subtest '(simple-array t ) '(simple-array t ) t t) (subtest '(simple-string 10) 'array t t ) (subtest 'array '(simple-string *) nil t) (every #'(lambda (type) (subtest type 'array t t)) '(simple-string simple-bit-vector simple-vector string bit-vector (vector t) vector simple-array)) ) ) ;; (do-test "subtypep with assorted types" (and (subtest '(integer 0 5) '(integer -1 5) t t ) (subtest '(float 0.0 3.0) '(number -132412341234 13212341234) t t) (subtest '(number -132412341234 13212341234) '(float 0.0 3.0) nil t) (subtest 'fixnum 'integer t t ) (subtest 'fixnum '(number 0 3) nil t) (subtest 'fixnum 'number t t) (subtest 'fixnum '(number 0 3) nil t) (subtest 'fixnum '(number 0 *) nil t) (subtest 'bignum 'number t t) (subtest '(float 3.0 4.0) '(float 2.9 4.1) t t ) (subtest '(float 3.0 4.0) 'number t t) (subtest 'complex '(number * *) t t ) (subtest 'ratio 'rational t t ) (subtest 'string-char 'character t t) (subtest 'character 'string-char nil t) (subtest 'standard-char 'character t t) (subtest 'hash-table 'readtable nil t) (subtest 'random-state 'common t t) (subtest 'common 'random-state nil t) (and (deftype unknown () '(satisfies something-or-other)) (subtest 'unknown 'stream nil nil) (subtest 'stream 'unknown nil nil)) (subtest 'function 'compiled-function nil t) ) ) ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-1-TYPEP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-1-TYPEP.TEST new file mode 100644 index 00000000..455bfd53 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-1-TYPEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: typep ;; ;; Source: CLtL p. 72 ;; ;; Chapter 6: Predicates Section 2-1: General Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-1-typep.test ;; ;; Syntax: typep object type ;; ;; Function Description: returns non-nil or NIL, depending on whether object is of type type. ;; ;; Argument(s): object - any cml object ;; type - a type ;; ;; Returns: non-nil iff object is of type type, else NIL ;; (do-test-group typep-test-group (do-test try-types-test ;; Run through the standard types (Steele p. 43) (and (every 'typep (list (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(list) ; list 37e5 ; long-float (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list '(array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; every ;; Type NIL is always nil. (not (typep (eq 1 2) 'nil)) ) ; and ) ; do-test-try-types ;; An object may be of more than one type. (do-test multi-types-test (every 'typep '(5 5 5 5 5) '(integer fixnum number (or integer simple-string) (member 5))) ) ; do-test multi-types-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-ARRAYP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-ARRAYP.TEST new file mode 100644 index 00000000..8448fdc9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-ARRAYP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: arrayp ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 26 September 86 ;; ;; Last Update: Feb 4, 1987 Jim Blum - fixed to run on the SUN ;; ;; Filed As: {eris}cml>test>6-2-2-arrayp.test ;; ;; Syntax: arrayp object ;; ;; Function Description: Returns non-nil iff object is an array, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group arrayp-group :before (progn (test-defun arrayptest (object &optional (expected-value nil)) "See if the predicate is true or false of object, depending on expected-value; see if (arrayp object) <=> (typep object 'array) for any object; see that an array's dimensions are non-nil." (let ((val (arrayp object))) (and (cond (expected-value val) (t (null nil)) ) ; cond ;; Equivalent to typep...array (eq val (typep object 'array)) ;; If it's an array, functions on arrays won't break. (cond (expected-value ;;Each dimension of object (as counted by (array-rank object) should return a non-nil value to (array-dimension object dimension). Acknowledgements to Karin Sye. (and (mapcar #'(lambda (rank) (array-dimension object rank)) (do ((rank 0 (1+ rank)) (y nil (append y (list rank)))) ((= rank (array-rank object)) y))) ;; More thanks to Karin. (mapcar #'(lambda (func) (funcall func object)) (list #'array-rank #'array-dimensions #'array-total-size)) ) ; and ) ; expected-value ;; Non-arrays get this one for free. (t t) ) ; cond ) ; and ) ; let ) ; test-defun (test-setq type-examples (list (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(list) ; list 37e5 ; long-float t ; nil (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname nil) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence 6.25 ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list types '(array atom bignum bit bit-vector character common compiled-function complex cons float fixnum float function hash-table integer keyword list float t null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; test-setq ) ; progn ;; (do-test arrayp-with-arrays-of-all-types-test ;; See that an array of any element type is an array (every #'(lambda (object) (arrayptest object t)) (mapcar #'(lambda (type element) (make-array (list (1+ (random 5)) (1+ (random 5)) (1+ (random 5))) :element-type type :initial-element element) ) ; lambda types type-examples ) ; mapcar ) ; every ) ; do-test arrayp-with-arrays-of-all-types-test ;; (do-test arrayp-with-strings-test ;; Every string is an array (every #'(lambda (object) (arrayptest object t)) (list "array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum hash-table integer keyword list long-float null number pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector" (symbol-name '|array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum hash-table integer keyword list |) (make-string (random 100) :initial-element #\backspace) ) ; list ) ; every ) ; do-test arrayp-with-strings-test ;; (do-test arrayp-with-symbols-test ;; No symbol is an array. (every 'arrayptest (list (make-symbol "(make-array 20)") (make-symbol (make-string 20 :initial-element #\Newline)) (aref (make-array '(2 2 2) :element-type 'symbol :initial-contents '(((a b)(c d))((e f)(g h)))) (random 2)(random 2)(random 2)) ) ; list ) ; every ) ; do-test arrayp-with-symbols-test ;; (do-test arrayp-with-lists-test ;; No list is an array. (every 'arrayptest (list (list (list 1 2 3) (list 4 5 6) (list 7 8 9)) (aref (make-array '(2 2 2) :initial-contents '((((list 1 2) (list 3 4))((list 5 6) (list 7 8)))(((list 9 10) (list 11 12))((list 13 14) (list 15 16))))) (random 2)(random 2)(random 2)) '(make-array 20) ) ; list ) ; every ) ; do-test arrayp-with-lists-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-ATOM.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-ATOM.TEST new file mode 100644 index 00000000..2a0045a8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-ATOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: atom ;; ;; Source: CLtL p. 73 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 September 86 ;; ;; Last Update: Feb 4, 1987 - Jim Blum added nil args to (pathname) & ;; (make-synonym-stream) ;; Filed As: {eris}cml>test>6-2-2-atom.test ;; ;; Syntax: atom object ;; ;; Function Description: Returns non-nil iff object is an atom (i.e. not a cons), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group atom-group :before (test-defun atomtest (object &optional (expected-value nil)) (and ;; Must be non-nil for the true cases, NIL for the others. (cond (expected-value (atom object)) (t (eq (atom object) nil)) ) ;; Test the equivalencies in Steele's function description. (eq (typep object 'atom) (atom object)) (eq (atom object) (not (typep object 'cons))) ) ; and ) ; test-defun ;; (do-test atom-with-atoms-test (every #'(lambda (object) (atomtest object t)) (list (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)) ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float (symbol-function 'atom) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword 37e5 ; long-float (list) ; nil () ; nil '() ; nil (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname nil) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable 6.25 ; short-float (make-array '(2 2)) ; simple-array #*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list ) ; every ) ; do-test atom-with-atoms-test ;; (do-test atom-with-non-atoms-test (every 'atomtest (list '(nil) '(a b c) '(a b c . d) (cons 1 2) (list 1 2) (append '(1) '(2)) (nconc '(1) '(2)) ) ; list ) ; every ) ; do-test atom-with-non-atoms-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-BIT-VECTOR-P.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-BIT-VECTOR-P.TEST new file mode 100644 index 00000000..265b4530 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-BIT-VECTOR-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: bit-vector-p ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-bit-vector-p.test ;; ;; Syntax: bit-vector-p object ;; ;; Function Description: Returns non-nil iff object is a bit-vector (a one-dimensional array of element-type 'bit), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group bit-vector-p-group :before (test-defun bit-vector-ptest (object &optional (expected-value nil)) "See if (bit-vector-p object) <=> (typep object 'bit-vector); see if the predicate is true or false of the object, depending on expected-value; see if bit vectors are of the proper type." (let ((val (bit-vector-p object))) (and ;; Test equivalence of bit-vector-p to typep...'bit-vector. (eq val (typep object 'bit-vector)) (cond (expected-value val) (t (null val)) ) ; cond ;; Vectors are one-dimensional arrays. (cond (expected-value ;; The caller had better not pass anything but an array when expected-value is non-nil. (and (= 1 (array-rank object)) (typep object '(array bit)) ) ; and ) ;; Non-arrays are moot. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test bit-vector-p-with-bit-vectors-test (every #'(lambda (object) (bit-vector-ptest object t)) (list #*1000010101101111111 (make-array 500 :element-type 'bit) (bit-andc2 (make-array 12 :element-type 'bit) #*000100101110) (make-array 10 :element-type 'bit :displaced-to (make-array 11 :initial-element 0 :element-type 'bit) :fill-pointer 5) ) ; list ) ; every ) ; do-test bit-vector-p-with-non-bit-vectors-test ;; (do-test bit-vector-p-with-non-bit-vectors-test (every 'bit-vector-ptest (list ;; Vectors containing only bits are not neccessarily bit-vectors. '#(1 0 0 1 1) (make-array 50 :initial-element 1) '#() '#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6)) (vector) (vector 1 2 3 4 5 6 7) (make-array (list 7)) (make-array (+ 10 (random 100)) :displaced-to (make-array (+ 100 (random 100)) :displaced-to (make-array 300 :element-type '(or readtable string-char) :initial-element (copy-readtable) ) ) :adjustable t :displaced-index-offset (random 10) :fill-pointer (random 5) ) ; make-array ) ; list ) ; every ) ; do-test bit-vector-p-with-non-bit-vectors-test ;; No string is a bit-vector (do-test bit-vector-p-with-strings-test (every 'bit-vector-ptest (list "1 0 0 1" "1001" "#*1001" (make-array 4 :element-type 'string-char :initial-contents '(#\1 #\0 #\0 #\1)) (make-string (random 10) :initial-element #\0) ) ; list ) ; every ) ; do-test bit-vector-p-with-strings-test ;; ;; Multi-dimensional arrays don't qualify. (do-test bit-vector-p-with-multi-dimensional-arrays-test (every 'bit-vector-ptest (list (make-array '(1 4) :element-type 'bit) (make-array '(1 4) :element-type 'bit :initial-contents '((1 0 0 1))) ) ; list ) ; every ) ; do-test bit-vector-p-with-multi-dimensional-arrays-test ;; ;; Symbols aren't vectors. (do-test bit-vector-p-with-symbols-test (every 'bit-vector-ptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20))) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test bit-vector-p-with-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-CHARACTERP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-CHARACTERP.TEST new file mode 100644 index 00000000..4252d040 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-CHARACTERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: characterp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 21 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-characterp.test ;; ;; Syntax: characterp object ;; ;; Function Description: Returns non-nil iff object is NIL, the empty list, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group characterp-group :before (test-defun characterptest (object &optional (expected-value nil)) (and ;; Non-nil for characters, NIL for non-characters (cond (expected-value (characterp object) ) (t (null (characterp object))) ) ; cond ;; (characterp object) is equivalent to (typep object 'character). (eq (characterp object) (typep object 'character)) ) ; and ) ; test-defun ;; (do-test characterp-with-standard-chars-test (every #'(lambda (object) (characterptest object t)) (list #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ #\| #\} #\~) ) ; every ) ; do-test characterp-with-standard-chars-test ;; (do-test characterp-with-semi-standard-chars-test ;; NOTE: this test is not strictly portable; see Steele p. 21. (every #'(lambda (object) (characterptest object t)) (list #\backspace #\linefeed #\page #\return #\rubout) ) ; every ) ; do-test characterp-with-non-chars-test ;; (do-test characterp-with-non-chars-test (every 'characterptest (list 5 '\#\5 "#\5")) ) ; do-test characterp-with-non-chars-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMMONP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMMONP.TEST new file mode 100644 index 00000000..35c3d5d1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMMONP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: commonp ;; NOTE: COMMONP NOT IMPLEMENTED 15 12; SEE AR 7072 ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 28 September 86 ;; ;; Last Update: 28 September 86 ;; ;; Filed As: {eris}cml>test>6-2-2-commonp.test ;; ;; Syntax: commonp object ;; ;; Function Description: Returns non-nil iff object is a standard CML data type, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group commonp-group :before (progn (test-defun commonptest (object &optional (expected-value nil)) "See if (commonp object) <=> (typep object 'common) for any object, and see if the predicate is true or is false of object, depending on expected-value." (let ((val (commonp object))) (and (cond (expected-value val) (t (null val)) ) ; cond (eq val (typep object 'common)) ) ; and ) ; let ) ; test-defun ) ; progn (do-test commonp-test (every #'(lambda (type) (commonptest type t)) '(array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string string-char symbol t vector) ) ; every ) ; do-test-commonp-test ;; (do-test not-commonp-test (deftype zeroorone () '(member 0 1)) (notany 'commonptest (list ;; The name of a type isn't a type. "array" ;; A list with a type isn't a type. (list 'bignum) '(bit) ) ; list ) ; notany ) ; do-test-not-commonp-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPILED-FUNCTION-P.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPILED-FUNCTION-P.TEST new file mode 100644 index 00000000..6deee8a7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPILED-FUNCTION-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compiled-function-p ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 28 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-compiled-function-p.test ;; ;; Syntax: compiled-function-p object ;; ;; Function Description: Returns non-nil iff object is any compiled code object, NIL otherwise ;; ;; Argument(s): object - any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group compiled-function-p-group :before (progn (setf (symbol-function 'zero) '(lambda () 0)) (setf (symbol-function 'one) '(lambda () 1)) (compile 'one) ) ; progn ;; (do-test compiled-function-p-test (and (compiled-function-p #'one) (typep #'one 'compiled-function) (not (compiled-function-p #'zero)) (not (typep #'zero 'compiled-function)) ) ; and ) ; do-test compiled-function-p-test ;; (do-test compiled-function-p-before-and-after-test (and (not (compiled-function-p '(lambda () 3))) (not (typep '(lambda () 3) 'compiled-function)) (compiled-function-p (compile nil '(lambda () 3))) (typep (compile nil '(lambda () 3)) 'compiled-function) (compile 'zero) (compiled-function-p #'zero) (typep #'zero 'compiled-function) ) ; and ) ; do-test compiled-function-p-before-and-after-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPLEXP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPLEXP.TEST new file mode 100644 index 00000000..316f9ded --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-COMPLEXP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: complexp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 20 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-complexp.test ;; ;; Syntax: complexp object ;; ;; Function Description: True iff object is a complex number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group complexp-group :before (test-defun complexptest (object &optional (expected-value nil)) "See if complexp is true or not of an object, depending on the expected value; see if (typep object 'complex) <=> (complexp object); see if #c(a b) eql (complex a b)." (and (cond (expected-value (complexp object)) (t (null (complexp object))) ) ; cond (eq (complexp object) (typep object 'complex)) ;; #C(a b) is equivalent to (complex a b), for all numbers except floating-point, whose imagpart is 0.00 (see Steele p. 220). (cond ;; So test this for non-floating numbers ((and (numberp object) (not (floatp object))) (eql object (complex (realpart object)(imagpart object)))) ;; ... but give floats and non-numbers this one for free. (t t) ) ; cond ) ; and ) ; test-defun ;; (do-test complexp-with-complex-test (every #'(lambda (object) (complexptest object t)) (list #c(3 5) ; the simplest cases #C(3. 5.) #c(2/3 3/4) #c(12/3 77/11) #C(0 #5r12) ; zero real part is ok #C(0.00 #5r12) #C(3/4 3.77) ; mixed types get converted #C(27 44.99e12) #C(33e5 27/12) #c(#O-17/32 12) #c(#5r12 #4r22/31) #c(7.7777 3/2) #C(0 0.0) ; imaginary part can be zero if it's floating zero #C(3/22 0.00) #C(37e12 .00) (+ #C(3/4 22.4e4) pi) ; computed numbers (+ pi #C(3/4 22.4e4)) (- #C(50/2 35)) (* 3 #C(50/2 35)) (/ 27 #C(3 3)) (cadr (list 25 (* 3 #C(50/2 35)) 40 30 " ")) '#C(3. 5.) ; complex numbers evaluate to themselves '#C(33e5 27/12) (eval '#C(0 0.0)) (eval (cadr (list 25 (* 3 '#C(50/2 35)) 40 30 " "))) ) ; list ) ; every ) ; do-test complexp-with-complex-test ;; (do-test complexp-with-non-complex-test (every 'complexptest (list 0 (random most-positive-fixnum) ; integers -16/2 (realpart (complex 3 3.2)) (imagpart #c(3/2 3)) (- (random most-positive-fixnum)) '5 7.99 ; float (realpart #C(7.00 3.3)) (imagpart (complex 7.00 3.3)) 3/2 ; ratios #o-17/32 #c(37/22 0) ; fixed zero imaginary part yields just the real part #c(0 0) #c(3/4 0) "#c(3/4 0)" (make-symbol "#c(3/4 0)") ) ; list ) ; every ) ; do-test complexp-with-non-complex-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-CONSP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-CONSP.TEST new file mode 100644 index 00000000..1c6aae22 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-CONSP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: consp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Jim Blum (make-synonym-stream) must have an arg ;; to run on the SUN ;; ;; Filed As: {eris}cml>test>6-2-2-consp.test ;; ;; Syntax: consp object ;; ;; Function Description: Returns non-nil iff object is a cons (i.e. not an atom), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group consp-group :before (test-defun consptest (object &optional (expected-value nil)) "See if an consp is or isn't true of an object, depending on expected-value; see if object consp is true of object iff object isn't an atom; see if (consp object) <=> (typep object cons)." (and ;; Non-nil for true cases, NIL for others. (cond (expected-value (consp object)) (t (eq (consp object) nil)) ) ; cond ;; Test the equivalences in Steele's function description. (eq (typep object 'cons) (not (typep object 'atom))) (eq (consp object) (typep object 'cons)) ) ; and ) ; test-defun ;; (do-test consp-with-conses-test (every #'(lambda (object) (consptest object t)) (list '(nil) '(a b c) '(a b c . d) (cons 1 2) (list 1 2) (append '(1) '(2)) (nconc '(1) '(2)) ) ; list ) ; every ) ; do-test consp-with-conses-test ;; (do-test consp-with-non-conses-test (every 'consptest (list (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)) ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex 5.00 ; double-float (random most-positive-fixnum) ; fixnum (symbol-function 'atom) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword 37e5 ; long-float (list) ; nil () ; nil '() ; nil (eq 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable 6.25 ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list ) ; every ) ; do-test-consp-with-non-conses-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-FLOATP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-FLOATP.TEST new file mode 100644 index 00000000..f2f9ac82 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-FLOATP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: floatp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Jim Blum - removed :5 keyword from last test ;; ;; Filed As: {eris}cml>test>6-2-2-floatp.test ;; ;; Syntax: floatp object ;; ;; Function Description: True iff object is a floating point number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group (floatp-group :before (test-defun floatptest (object &optional (expected-value nil)) "See if an object is floatp or not, depending on expected-value; see if (floatp object) and (typep object 'float) return the same value." (and (cond (expected-value (floatp object)) (t (null (floatp object))) ) ; cond (eq (floatp object) (typep object 'float)) ) ; and ) ; test-defun ) ; floatp-group ;; (do-test floatp-with-floats-test (let ((five 5.00)) (declare (special five)) (every #'(lambda (object) (floatptest object t)) (list pi five (sqrt 5) (sqrt (truncate five)) 17.02020e12 .6060e-12 (caddr (list "5.00" '(.005) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; let ) ; do-test floatp-with-floats-test ;; (do-test floatp-with-non-floats-test (let ((five 5)) (declare (special expected-value five)) (every 'floatptest (list '(5.00) "5.34e7" (list 5.14159) #\5 'five (random most-positive-fixnum) ; integers (- (random most-positive-fixnum)) five '5 (eval 'five) (truncate (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable)))) ;; 3/2 ; ratios -16/2 #o-17/32 #x11/eff #7r33/66 ) ; list ) ; every ) ; let ) ; do-test floatp-with-non-floats-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-FUNCTIONP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-FUNCTIONP.TEST new file mode 100644 index 00000000..95268732 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-FUNCTIONP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: functionp ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 26 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-functionp.test ;; ;; Syntax: functionp object ;; ;; Function Description: Returns non-nil iff object is suitable for applying to arguments, NIL otherwise. Always true of ;; - symbols ;; - lists whose car is 'lambda ;; - values returned by the FUNCTION special form ;; - values returned by COMPILE when the first argument to it is nil. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group functionp-group :before (progn (test-defun zero () 0) ) ; progn ;; (do-test functionp-with-symbols-test (every 'functionp (list (gensym) (gentemp) 'lambda 'mu (make-symbol (symbol-name (gensym)))) ) ) ; do-test functionp-with-symbols-test ;; (do-test functionp-with-lambda-lists-test (functionp '(lambda "lambda" 'lambda)) ) ; do-test functionp-with-lambda-lists-test ;; (do-test functionp-with-lambda-lists-test-1 (functionp '(lambda)) ) ;; (do-test functionp-with-lambda-lists-test-2 (functionp '(lambda 3 4 5)) ) ;; (do-test functionp-with-predefined-functions-test (every 'functionp '(zero cons)) ) ; do-test functionp-with-predefined-functions-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-INTEGERP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-INTEGERP.TEST new file mode 100644 index 00000000..0d97222e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-INTEGERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: integerp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Removed :5 keyword from last test;; ;; Filed As: {eris}cml>test>6-2-2-integerp.test ;; ;; Syntax: integerp object ;; ;; Function Description: True iff object is an integer, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group integerp-group :before (progn (test-setq five 5) (test-defun integerptest (object &optional (expected-value nil)) "See if (integerp object) <=> (typep object integer); see if (integerp object is true or false, depending on the expected value." (and (eq (integerp object) (typep object 'integer)) (cond (expected-value (integerp object)) (t (null (integerp object))) ) ; cond ) ; and ) ; test-defun ) ; progn ;; (do-test integerp-with-integers-test (every #'(lambda (object) (integerptest object t)) (list (random most-positive-fixnum) (- (random most-positive-fixnum)) five '5 (eval 'five) -15/3 (truncate 26/5) (truncate 5.0) ) ; list ) ; every ) ; do-test integerp-with-integers-test ;; (do-test integerp-with-non-integers-test (every 'integerptest (list ;; expressions that contain the numeral 5 but aren't equal to the integer 5. (float 5) '(5) "5" (list 5) #\5 'five 3/2 ; ratios -16/3 #o-17/32 #x11/eff #7r33/66 pi ; float 17.02020e12 #c(3.33 3/2) ; complex #c(5 5) (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; do-test integerp-with-non-integers-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-LISTP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-LISTP.TEST new file mode 100644 index 00000000..3d40c65f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-LISTP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: listp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Jim BLum - added NIL args to (pathname) & ;; (make-synonym-stream) ;; ;; Filed As: {eris}cml>test>6-2-2-listp.test ;; ;; Syntax: listp object ;; ;; Function Description: Returns non-nil iff object is a cons (i.e. a cons or NIL), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group listp-group :before (test-defun listptest (object &optional (expected-value nil)) "See that listp is or is not true of object, depending on the expected value. See that (listp object) <=> (typep object 'list). See that listp is true of an object iff it is cons or null." (and ;; Non-nil for true cases, NIL for others. (cond (expected-value (listp object)) (t (eq (listp object) nil)) ) ; cond ;; Test the equivalences in Steele's function description. (eq (typep object 'list) (listp object)) (eq (listp object) (typep object '(or cons null))) ) ; and ) ; test-defun ;; (do-test listp-with-lists-test (every #'(lambda (object) (listptest object t)) (list '(nil) '(a b c) '(a b c . d) (cons 1 2) (list 1 2) (append '(1) '(2)) (nconc '(1) '(2)) (list) () '() (eq 1 2) ) ; list ) ; every ) ; do-test listp-with-lists-test ;; (do-test listp-with-non-lists-test (every 'listptest (list (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)) ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex 5.00 ; double-float (random most-positive-fixnum) ; fixnum (symbol-function 'atom) ; function (make-hash-table) ; hash-table 4761 ; integer :mot-de-clef ; keyword 37e5 ; long-float 3.1415926535897932384d0 ; number (car (list-all-packages)) ; package (pathname nil) ; pathname *random-state* ; random state 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable 6.25 ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream nil) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector ) ; list ) ; every ) ; do-test listp-with-non-lists-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-NULL.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-NULL.TEST new file mode 100644 index 00000000..5cfb068b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-NULL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: null ;; ;; Source: CLtL p. 73 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-null.test ;; ;; Syntax: null object ;; ;; Function Description: Returns non-nil iff object is NIL (the empty list), and NIL otherwise. Equivalent to the predicate not. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group null-group :before (test-defun nulltest (object) "True cases of NULL return non-nil, others NIL." (cond ((not (null expected-value)) (not (null (consp object)))) (t (eq nil (consp object))) ) ; cond ;; For null or non-null object, test the equivalencies in Steele's function description. (and (eq (null object) (typep object 'null)) (eq (null object) (eq object '())) (eq (null object) (not object)) (eq (typep object 'null) (eq object '())) ;; See that (null object) has the expected truth value. (eq (null object) expected-value) ) ; AND ) ; test-defun ;; (do-test null-test-with-null-objects (let ((expected-value t)) (declare (special expected-value)) (every 'nulltest (list nil '() (not t) nil) ) ; every ) ; let ) ; do-test (do-test null-test-with-non-null-objects (let ((expected-value nil)) (declare (special expected-value)) (every 'nulltest (list t '(nil) (not nil) (sqrt pi) "nil") ) ; every ) ; let ) ; do-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-NUMBERP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-NUMBERP.TEST new file mode 100644 index 00000000..f5b85dc7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-NUMBERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: numberp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 18 September 86 ;; ;; Last Update: Feb 4, 1987 - Jim Blum - removed :5 keyword from last test ;; ;; Filed As: {eris}cml>test>6-2-2-numberp.test ;; ;; Syntax: numberp object ;; ;; Function Description: True iff object is any type of number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group numberp-group :before (progn (test-setq five 5) (test-defun numberptest (object &optional (expected-value nil)) (and (eq (numberp object) (typep object 'number)) ;; Non-nil for true cases, NIL for others. (cond (expected-value (numberp object)) (t (null (numberp object))) ) ; cond ) ; and ) ; test-defun ) ; progn ;; ;; Returns NIL for true cases 18 September. See AR 6493. (do-test numberp-with-numbers-test (every #'(lambda (object) (numberptest object t)) (list (random most-positive-fixnum) ; integers (- (random most-positive-fixnum)) five '5 (eval '|FIVE|) 3/2 ; ratios -16/2 #o-17/32 #x11/eff #7r33/66 (eval 'pi) ; float 17.02020e12 #c(47 3/2) ; complex (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; do-test numberp-with-numbers-test ;; (do-test numberp-with-non-numbers-test (every 'numberptest (list '(5) "5" (list 5) #\5 'five ) ; list ) ; every ) ; do-test numberp-with-non-numbers-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-PACKAGEP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-PACKAGEP.TEST new file mode 100644 index 00000000..3300d250 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-PACKAGEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: packagep ;; PACKAGEP NOT IMPLEMENTED 26 SEPTEMBER ;; ;; Source: CLtL p. 76 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 26 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-packagep.test ;; ;; Syntax: packagep object ;; ;; Function Description: Returns non-nil iff object is a package, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group packagep-group :before (test-defun packageptest (object &optional (expected-value nil)) "See if (packagep object) <=> (typep object 'package); see if the predicate is true or false, depending on the value of expected-value." (let ((val (packagep object))) (and ;; Packagep is equivalent to typep...'package (eq (packagep object) (typep object 'package)) (cond (expected-value val) (t (null val)) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test packagep-with-list-all-packages-test (every #'(lambda (object) (packageptest object t)) (list-all-packages) ) ) ; do-test packagep-with-list-all-packages-test ;; The current package (do-test packagep-with-current-package-test (packageptest *package* t) ) ; do-test packagep-with-current-package-test ;; An invented package (do-test packagep-with-invented-packages-test (and (packageptest (make-package (gensym) :nicknames (list (gensym) (symbol-name (gensym)))) t) (packageptest (make-package (symbol-name (gensym))) t) ) ; and ) ; do-test packagep-with-invented-packages-test ;; ;; A list of packages is not a package (do-test packagep-with-list-of-packages-test (packageptest (list-all-packages)) ) ; do-test packagep-with-list-of-packages-test ) ; do-test group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-RATIONALP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-RATIONALP.TEST new file mode 100644 index 00000000..eecb783b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-RATIONALP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: rationalp ;; ;; Source: CLtL p. 74 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 19 September 86 ;; ;; Last Update: Feb 4, 1987 Jim Blum - removed :5 keyword from last test ;; ;; Filed As: {eris}cml>test>6-2-2-rationalp.test ;; ;; Syntax: rationalp object ;; ;; Function Description: True iff object is any type of number, NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group rationalp-group :before (progn (test-setq five 5) (test-defun rationalptest (object &optional (expected-value nil)) "See that (rationalp object) <=> (typep object 'rational); see that, if the expected value is true, the object is either an integer or a ratio; see that the predicate is true or false, depending on the expected value." (and (eq (rationalp object) (typep object 'rational)) (cond (expected-value (and (rationalp object) (or (typep object 'ratio) (integerp object)) ) ) (t (null (rationalp object))) ) ; cond ) ; and ) ; test-defun ) ; progn ;; (do-test rationalp-with-rationals-test (every #'(lambda (object) (rationalptest object t)) (list (random most-positive-fixnum) ; integers (- (random most-positive-fixnum)) five '5 (eval 'five) #7r55 3/2 ; ratios -16/2 #o-17/32 #x11/eff #7r33/66 ) ; list ) ; every ) ; do-test rationalp-with-rationals-test ;; (do-test rationalp-with-non-rationals-test (every 'rationalptest (list '(5) "5" (list 5) #\5 'five pi ; float 17.02020e12 #c(5 5) ; complex (caddr (list "5" '(5) (apply '+ (list pi 3 #7r12/24)) (copy-readtable))) ) ; list ) ; every ) ; do-test rationalp-with-non-rationals-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SIMPLE-BIT-VECTOR-P.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SIMPLE-BIT-VECTOR-P.TEST new file mode 100644 index 0000000000000000000000000000000000000000..bc3936150ba9c02e8b3375f65cb8a60cfba9d7c8 GIT binary patch literal 4557 zcmb_fU2oG!6x~-p8T{9{Ze@b*|ahLHJ0n zJ^%w4Hqe=GbGxJ96<0|q3WL)ErRu8873DIIbCHo)ue}QrikN4J_6$+TNaj3F#g^v^ zK3GPqELlx*O+4fHua33BdW=O6;aF3OGBcI{09g`CKU7MyRmL9@%TxLy^hQ=1vDPBX z;zEiX97OKn+c#Gv^@f*UgyIul{`2y-GGRg$Edp0BJkl;4PX`$363ikfKGz#lIlMx$_Musc8DeFsw^t z0c#ss=&_y@6;rWhRuS)2`_lt{gScnaa zzyM~3d0@IfE?NGuQ7I}yI&U#j>@!!wR!ZHt)1(~`ouciHqtRZ1{*i-a-)p8@gQi`F zNR7=r=?_q4`x}Xe{4+0WIvs}@+pbd9G-))bG26zzi?tUThBorT=k&pBiqFjam|y#W z03l*&_7t=gz_+I3L0kJM+_I0{0YzuiDJ^1y*YBHyGsM(wr zA{Sb)EcOvW=0I>dePD~URnDe18Ap%9!CqTXJz0L1-k+S~s5Q#$jl4s8`|TWK({{Xt zI|4g+0QucM6=O1V9u6ZjfL4#v8T=mNY<5PF)$D^!Gjt-}xvafQlA|N|KP&H0OG{;U zr{2loDJ?qpKSLtlBKdfk>`yKC*GFprW4>wz4((ouEemelNHe1~=SjkqVx@3T{6W^w z=J9DbqbYu7G#hH;zBarW7CL+DVNQ?8$`*diwegDYD8kiaI-_&HhlFk$^^x3-Ut-PZ zNk0ka_etZS#eeu4K>{Hrdn&iMoFZPQN37U8;{$mJq_>6FrNJ^R)L0RJMv=rvOqc-PXW8&WsaD+VK_~*PIocX@5`?1Tzs6M>K z>utTYIy2XJ|4EyRdGA!`mf4AR$F!Ma+D3uRq#ZCsP5>^>*_P8T Zub;u1bL=OH6+q{uc(lCv^LjM;cml>test>6-2-2-stringp.test ;; ;; Syntax: stringp object ;; ;; Function Description: Returns non-nil iff object is a string (a one-dimensional array of type string-char, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group stringp-group :before (test-defun stringptest (object &optional (expected-value nil)) "See if (typep object 'string) <=> (stringp object), and if the string and its elements are of the proper type." (let ((val (stringp object))) (and ;; Test equivalence of stringp to typep...'string. (eq val (typep object 'string)) ;; non-nil for true cases, NIL for others. (cond (expected-value val) (t (null val)) ) ; cond ;; Strings are one-dimensional arrays of type string-char. (eq val (typep object '(array string-char (*)))) ;; Strings are vectors of type string-char. (eq val (typep object '(vector string-char))) ;; If the object is an array, see if it's the right kind of array. (cond (expected-value (and (= 1 (array-rank object)) ;; The type must at least be consistent with 'string-char. (subtypep 'string-char (array-element-type object)) ) ; and ) ;; If it's not an array, it can't be the right kind; the test is moot (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test stringp-with-strings-test (every #'(lambda (object) (stringptest object t)) (list "string" (symbol-name 'string) (symbol-name (gensym)) (symbol-name (gentemp)) (symbol-name (make-symbol "string")) (make-string (random 1000)) (make-string (random 1000) :initial-element #\$) (make-array 1 :element-type 'string-char) (make-array 1 :adjustable t :element-type 'string-char) (make-array 20 :initial-element #\} :element-type 'string-char) (make-array 20 :element-type 'string-char :initial-contents '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\A #\B #\C #\D #\E)) (make-array 20 :element-type 'string-char :fill-pointer (random 20) :adjustable t :displaced-to (make-array (list (+ 20 (random 20)) (+ 20 (random 10))) :element-type 'string-char :initial-element #\})) ) ; list ) ; every ) ; do-test stringp-with-strings-test ;; ;; Symbols aren't strings (do-test stringp-with-symbols-test (every 'stringptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20) :adjustable t :displaced-to (make-array (list (+ 20 (random 20)) (+ 20 (random 10))) :element-type 'string-char :initial-element #\A ))) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test stringp-with-symbols-test ;; ;; Only one-dimensional string-char arrays are strings. (do-test stringp-with-non-string-arrays-test (every 'stringptest (list (make-array 6 :initial-contents '(#\s #\t #\r #\i #\n #\g)) ) ; list ) ; every ) ; do-test stringp-with-non-string-arrays-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SYMBOLP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SYMBOLP.TEST new file mode 100644 index 00000000..e7c33dfd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SYMBOLP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: symbolp ;; ;; Source: CLtL p. 73 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 17 September 86 ;; ;; Last Update: 19 September 86 ;; ;; Filed As: {eris}cml>test>6-2-2-symbolp.test ;; ;; Syntax: symbolp object ;; ;; Function Description: Returns non-nil iff object is a symbol, and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group symbolp-group :before (test-defun symbolptest (object) (and ;; Non-nil for true cases, NIL for others. (cond ((not (null expected-value)) (not (null (symbolp object)))) (t (eq (symbolp object) nil)) ) ; cond ;; Test the equivalence in Steele's function description. (eq (symbolp object) (typep object 'symbol)) ) ; and ) ; test-defun ;; (do-test symbolp-test-with-symbols (let ((expected-value t) (five 5) (symbol 'cymbal)) (declare (special expected-value five symbol)) (every 'symbolptest (list 'cymbal symbol (gensym) (gentemp) (make-symbol (make-array 5 :element-type 'string-char :initial-element #\g)) (car '(one two three)) t nil ) ; list ) ; every ) ; let ) ; do-test-symbolp-test-with-symbols ;; (do-test symbolp-test-with-non-symbols (let ((expected-value nil) (cymbalname 'cymbal)) (declare (special expected-value cymbalname)) (every 'symbolptest (list (symbol-name 'cymbal) (symbol-name cymbalname) (symbol-name (gensym)) (symbol-name (gentemp)) (make-array 5 :element-type 'string-char :initial-element #\g) (car '(1 2 3)) ) ; list ) ; every ) ; let ) ; do-test-symbolp-test-with-non-symbols ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-VECTORP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-VECTORP.TEST new file mode 100644 index 00000000..6ac4b4e7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-VECTORP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: vectorp ;; ;; Source: CLtL p. 75 ;; ;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates ;; ;; Created By: Peter Reidy ;; ;; Creation Date: 22 September 86 ;; ;; Last Update: 15 December 86 ;; ;; Filed As: {eris}cml>test>6-2-2-vectorp.test ;; ;; Syntax: vectorp object ;; ;; Function Description: Returns non-nil iff object is a vector (a one-dimensional array), and NIL otherwise. ;; ;; Argument(s): object any cml object ;; ;; Returns: non-nil or NIL ;; (do-test-group vectorp-group :before (test-defun vectorptest (object &optional (expected-value nil)) "See if (vectorp object) <=> (typep object 'vector); see if the predicate is true or false of the object, depending on the expected value; see if a vector is a one-dimensional array." (let ((val (vectorp object))) (and ;; Test equivalence of vectorp to typep...'vector. (eq val (typep object 'vector)) ;; non-nil for true cases, NIL for others. (cond (expected-value val) (t (null val)) ) ; cond ;; Vectors are one-dimensional arrays. (cond (expected-value ;; The caller had better not pass anything but an array when expected-value is non-nil. (eq 1 (array-rank object)) ) ;; Non-arrays are moot. (t t) ) ; cond ) ; and ) ; let ) ; test-defun ;; (do-test vectorp-with-vectors-test (every #'(lambda (object) (vectorptest object t)) (list '#() '#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6)) '#(1 0 0 1 1) (vector) (vector 1 2 3 4 5 6 7) (make-array (list 7)) (make-array (+ 10 (random 100)) :displaced-to (make-array (+ 100 (random 100)) :displaced-to (make-array 300 :element-type '(or readtable string-char) :initial-element (copy-readtable) ) ) :adjustable t :displaced-index-offset (random 10) :fill-pointer (random 5) ) ; make-array ) ; list ) ; every ) ; do-test vectorp-with-vectors-test ;; All strings are vectors (do-test vectorp-with-strings-test (every #'(lambda (object) (vectorptest object t)) (list "string" (symbol-name 'string) (symbol-name (gensym)) (symbol-name (gentemp)) (symbol-name (make-symbol "string")) (make-string (random 1000)) (make-string (random 1000) :initial-element #\$) (make-array 1 :element-type 'string-char) (make-array 1 :adjustable t :element-type 'string-char) (make-array 20 :initial-element #\} :element-type 'string-char) (make-array 20 :element-type 'string-char :initial-contents '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\A #\B #\C #\D #\E)) ) ; list ) ; every ) ; do-test vectorp-with-strings-test ;; All bit-vectors are vectors (do-test vectorp-with-bit-vectors-test (every #'(lambda (object) (vectorptest object t)) (list #*1000010101101111111 (make-array 500 :element-type 'bit) (bit-andc2 (make-array 12 :element-type 'bit) #*000100101110) ) ; list ) ; every ) ; do-test vectorp-with-bit-vectors-test ;; ;; Multi-dimensional arrays don't qualify. (do-test vectorp-with-multi-dimensional-arrays-test (every 'vectorptest (list (make-array '(6 1)) (make-array (list (random (- array-dimension-limit 1)) 1) :element-type 'bit) (make-array (list 1 (random (1- array-dimension-limit 1))) :element-type 'bit) (make-array '(2 2) :adjustable t) ) ; list ) ; every ) ; do-test vectorp-with-multi-dimensional-arrays-test ;; ;; Symbols aren't strings, so a fortiori they aren't vectors. (do-test vectorp-with-symbols-test (every 'vectorptest (list 'string (gensym) (gentemp) (make-symbol "string") (make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20) :initial-element #\a)) (make-symbol (symbol-name (gentemp))) ) ; list ) ; every ) ; do-test vectorp-with-symbols-test ) ; do-test-group STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQ.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQ.TEST new file mode 100644 index 00000000..a81ee2e6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQ ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 77 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: 16 12 86 Peter Reidy - added do-test-group ;; ;; Filed As: {ERIS}CML>TEST>6-3-eq.TEST ;; ;; ;; Syntax: (eq x y) ;; ;; Function Description: ;; (do-test-group eq-group (do-test "EQ on symbols" (and (not (eq 'a 'b)) (eq 'a 'a))) (do-test EQ-on-CONSes (not (eq (cons 'a 'b) (cons 'a 'b)))) (do-test EQ-on-the-same-CONS (let ((x (cons 3 4.5))) (eq x x))) (do-test EQ-on-smallps (and (eq 0 0) (eq 65534 65534) (eq -32700 -32700))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQL.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQL.TEST new file mode 100644 index 00000000..c1f9bb66 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQL ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 78 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: 16 12 86 Peter Reidy - added do-test-group ;; ;; Filed As: {ERIS}CML>TEST>6-3-eql.TEST ;; ;; ;; Syntax: (eq x y) ;; ;; Function Description: ;; (do-test-group eql-test (do-test "EQL on symbols" (and (not (eql 'a 'b)) (eql 'a 'a))) (do-test EQL-on-CONSes (not (eql (cons 'a 'b) (cons 'a 'b)))) (do-test EQL-on-the-same-CONS (let ((x (cons 3 4.5))) (eql x x))) (do-test EQL-on-smallps (and (eql 0 0) (eql 65534 65534) (eql -32700 -32700) (not (eql 0 1)) ) ) (do-test EQL-on-complex (and (eql #c(3 4) #c(3 4)) (eql #c(3 4.1) #c(3 4.1)) (not (eql #c(3 4) #c(3.0 4.0))) ) ) (do-test EQL-on-strings (and (not (eql "Foo" "foo")) (let ((x "foo")) (eql x x) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUAL.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUAL.TEST new file mode 100644 index 00000000..251e098c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUAL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQUALP ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 80 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: 16 12 86 Peter Reidy - added do-test-group ;; ;; Filed As: {ERIS}CML>TEST>6-3-equal.TEST ;; ;; ;; Syntax: (equal x y) ;; ;; Function Description: ;; (do-test-group equal-group (do-test "EQUAL on symbols" (and (not (equal 'a 'b)) (equal 'a 'a))) (do-test EQUAL-on-CONSes (equal (cons 'a 'b) (cons 'a 'b)) ) (do-test EQUAL-on-the-same-CONS (let ((x (cons 3 4.5))) (equal x x))) (do-test EQUAL-on-smallps (and (equal 0 0) (equal 65534 65534) (equal -32700 -32700) (not (equal 0 1)) ) ) (do-test EQUAL-on-complex (and (equal #c(3 4) #c(3 4)) (equal #c(3 4.1) #c(3 4.1)) (not (equal #c(3 4) #c(3.0 4.0))) ) ) (do-test EQUAL-on-strings (and (equal "Foo" "Foo") (not (equal "Foo" "foo")) (let ((x "foo")) (equal x x) ) ) ) (do-test EQUAL-on-chars (and (equal #\A #\A) (not (equal #\A #\a)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUALP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUALP.TEST new file mode 100644 index 00000000..e5243f4e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUALP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EQUALP ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.3 Equality Predicates ;; Page: 80 ;; ;; Created By: John Sybalsky ;; ;; Creation Date: July 30,1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>6-3-equalp.TEST ;; ;; ;; Syntax: (equalpp x y) ;; ;; Function Description: ;; (do-test-group equalp-group (do-test "EQUALP on symbols" (and (not (equalp 'a 'b)) (equalp 'a 'a) (equalp 'a 'A))) (do-test EQUALP-on-CONSes (equalp (cons 'a 'b) (cons 'a 'b)) ) (do-test EQUALP-on-the-same-CONS (let ((x (cons 3 4.5))) (equalp x x))) (do-test EQUALP-on-smallps (and (equalp 0 0) (equalp 65534 65534) (equalp -32700 -32700) (not (equalp 0 1)) ) ) (do-test EQUALP-on-complex (and (equalp #c(3 4) #c(3 4)) (equalp #c(3 4.1) #c(3 4.1)) (equalp #c(3 4) #c(3.0 4.0)) ) ) (do-test EQUALP-on-strings (and (equalp "Foo" "Foo") (equalp "Foo" "foo") (let ((x "foo")) (equalp x x) ) ) ) (do-test EQUALP-on-chars (and (equalp #\A #\A) (equalp #\A #\a) ) ) (do-test EQUALP-on-strings (and (every 'equalp (list "string" "RRRRRR") (list "STRING" (string-capitalize (make-array 6 :element-type 'string-char :initial-element #\r))) ) (not (equalp "string" "strings")) ) ) (do-test "EQUALP on arrays" (and (every 'equalp (list #*100101 (make-array '(3 3)) (make-array '(2 2 1) :element-type 'number) ) (list (make-array 6 :element-type 'bit :initial-contents '(1 0 0 1 0 1)) (make-array '(3 3) :displaced-to (make-array '(4 4)) (make-array '(2 2 1) :element-type 'integer) ) ) ) (notany 'equalp (list (make-array '(3 4 5)) (make-array '(3 3 3) :element-type 'character)) (list (make-array '(3 4 4)) (make-array '(3 3 3) :element-type 'integer)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-4-AND.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-4-AND.TEST new file mode 100644 index 00000000..e1346b77 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-4-AND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: AND ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.4 Logical Operators ;; Page: 82 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: 25-Jul-86 ;; ;; Last Update: 25-Jul-86 ;; ;; Filed As: {ERIS}CML>TEST>6-4-AND.TEST ;; ;; ;; Syntax: (AND &REST FORMS) ;; ;; Function Description: ;; ;; (AND FORM1 FORM2 ... ) evaluates each FORM, one at a time, ;; from left to right. If any FORM evaluates to NIL, the value NIL ;; is immediately returned without evaluating the remaining ;; FORMS. If every FORM but the last evaluates to a non-NIL value, ;; AND returns whatever the last FORM returns. ;; Therefore in general AND can be used both for logical operations, ;; where NIL stands for FALSE and non-NIL values stand for TRUE, ;; and as a conditional expression. ;; For example: ;; ;; (IF (AND (>= N 0) ;; (< N (LENGTH A-SIMPLE-VECTOR)) ;; (EQ (ELT A-SIMPLE-VECTOR N) 'FOO)) ;; (PRINC "FOO!")) ;; ;; The above expression prints FOO! if element N of A-SIMPLE-VECTOR ;; is the symbol FOO, provided also that N is indeed a valid index ;; for A-SIMPLE-VECTOR. Because AND guarantees left-to-right testing ;; of its parts, ELT is not called if N is out of range. ;; ;; To put it another way, ;; the AND special form does SHORT-CIRCUIT Boolean evaluation, ;; like the and then operator in Ada ;; and what in some Pascal-like languages is called cand (for ``conditional ;; and''); the Lisp AND special form is ;; unlike the Pascal or Ada and operator, ;; which always evaluates both arguments. ;; ;; In the previous example writing ;; ;; (AND (>= N 0) ;; (< N (LENGTH A-SIMPLE-VECTOR)) ;; (EQ (ELT A-SIMPLE-VECTOR N) 'FOO) ;; (PRINC "FOO!")) ;; ;; would accomplish the same thing. The difference is purely stylistic. ;; Some programmers never use expressions containing side effects ;; within AND, preferring to use IF or WHEN for that purpose. ;; ;; From the general definition, one can deduce that ;; (AND X) = X. Also, ;; (AND) evaluates to T, which is an identity for this operation. ;; ;; One can define AND in terms of macro COND in this way: ;; ;; (AND X Y Z ... W) = (COND ((NOT X) NIL) ;; ((NOT Y) NIL) ;; ;; ((NOT Z) NIL) ;; ... ;; (T W)) ;; ;; ;; See IF and macro WHEN, which are sometimes stylistically ;; more appropriate than AND for conditional purposes. ;; If it is necessary to test whether a predicate is true ;; of all elements of a list or vector (element 0 AND element 1 AND ;; element 2 AND...), then the function function EVERY may be useful. ;; ;; Argument(s): Any number of Lisp objects. ;; ;; Returns: A Lisp object. ;; (DO-TEST "TEST AND 1" (AND (EQ (AND) T) (EQ (AND T) T) (EQ (AND NIL) NIL) (EQ (AND 123) 123) (EQ (AND 'ATOM) 'ATOM) (EQ (AND T T) T) (EQ (AND T NIL) NIL) (EQ (AND T 23 100) 100) (EQ (AND 100 T 23) 23) (EQ (AND T 1 T 2 T 3) 3) (EQ (AND T T 10 20 T) T))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-4-NOT.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-4-NOT.TEST new file mode 100644 index 00000000..592eae64 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-4-NOT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NOT ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.4 Logical Operators ;; Page: 82 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: 25-Jul-86 ;; ;; Last Update: 25-Jul-86 ;; ;; Filed As: {ERIS}CML>TEST>6-4-NOT.TEST ;; ;; ;; Syntax: (NOT X) ;; ;; Function Description: ;; NOT returns T if X is NIL, and otherwise returns NIL. ;; It therefore inverts its argument considered as a Boolean value. ;; ;; function NULL is the same as NOT; both functions are included for the sake ;; of clarity. As a matter of style, ;; it is customary to use NULL to check whether something is the empty list ;; and to use NOT to invert the sense of a logical value. ;; ;; Argument(s): See CLTL manual. ;; ;; Returns: See CLTL manual. ;; (DO-TEST "TEST NOT 1" (AND (NOT NIL) (EQ (NOT NIL) T) (EQ (NOT T) NIL) (EQ (NOT 100) NIL) (EQ (NOT "STRING") NIL) (EQ (NOT 'ATOM) NIL) (EQ (NOT (NOT T)) T) (EQ (NOT (NOT NIL)) NIL) (EQ (NOT (NOT 1000)) T) (EQ (NOT (NOT (NOT NIL))) T))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-4-OR.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-4-OR.TEST new file mode 100644 index 00000000..e2b93290 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/6-4-OR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: OR ;; ;; Source: Guy L Steele's CLTL ;; Section: 6.4 Logical Operators ;; Page: 83 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: 25-Jul-86 ;; ;; Last Update: 25-Jul-86 ;; ;; Filed As: {ERIS}CML>TEST>6-4-OR.TEST ;; ;; ;; Syntax: (OR &REST FORMS) ;; ;; Function Description: ;; ;; (OR FORM1 FORM2 ... ) evaluates each FORM, one at a time, ;; from left to right. If any FORM other than the last ;; evaluates to something other than NIL, ;; OR ;; immediately returns that non-NIL value without evaluating the remaining ;; FORMS. If every FORM but the last evaluates to NIL, ;; OR returns whatever evaluation of the last of the FORMS returns. ;; Therefore in general OR can be used both for logical operations, ;; where NIL stands for FALSE and non-NIL values stand for TRUE, ;; and as a conditional expression. ;; ;; To put it another way, ;; the OR special form does SHORT-CIRCUIT Boolean evaluation, ;; like the or else operator in Ada ;; and what in some Pascal-like languages is called cor (for ``conditional ;; or''); the Lisp OR special form is ;; unlike the Pascal or Ada or operator, ;; which always evaluates both arguments. ;; ;; From the general definition, one can deduce that ;; (OR X) = X. Also, ;; (OR) evaluates to NIL, which is the identity for this operation. ;; ;; One can define OR in terms of macro COND in this way: ;; ;; (OR X Y Z ... W) = (COND (X) (Y) (Z) ... (T W)) ;; ;; ;; See IF and macro UNLESS, which are sometimes ;; stylistically more appropriate than OR for conditional purposes. ;; If it is necessary to test whether a predicate is true ;; one or more elements of a list or vector (element 0 OR element 1 OR ;; element 2 OR...), then the function function SOME may be useful. ;; ;; Argument(s): Any number of Lisp objects. ;; ;; Returns: A Lisp object. ;; (DO-TEST "TEST OR 1" (AND (EQ (OR) NIL) (EQ (OR NIL) NIL) (EQ (OR T) T) (EQ (OR 123) 123) (EQ (OR 'ATOM) 'ATOM) (EQ (OR NIL NIL) NIL) (EQ (OR NIL T) T) (EQ (OR NIL T 100) T) (EQ (OR 100 NIL T) 100) (EQ (OR NIL 1 NIL 2 NIL 3) 1) (EQ (OR NIL NIL 10 20 NIL) 10))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-BOUNDP.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-BOUNDP.TEST new file mode 100644 index 00000000..0be1f22d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-BOUNDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: boundp ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 90 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 3, 1986 ;; ;; Last Update: June 3, 1986 ;; ;; Filed As: {eris}cml>test>boundp.test ;; ;; ;; Syntax: BOUNDP symbol ;; ;; Function Description: BOUNDP returns true if the special variable named by symbol has a value ; otherwise, ;; it returns nil. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: true or nil ;; (do-test test-boundp0 (and ;;(every #'boundp '(nil t :start :end :initial-contents :key :from-end :circle multiple-values-limit ;; call-arguments-limit pi)) (setq a "ham" b 90 c '(9 8 7) d (1- 9)) (every #'boundp '(a b c d)))) (do-test test-boundp1 ;; ;; test for dynamically bound variables ;; (progn (defun fun1 () (let ((*a* 1) (*c* 2)) (declare (special *a* *c*)) (fun2))) (defun fun2 () (and (boundp '*a*) (boundp '*c*))) (fun1))) (do-test test-boundp2 ;; ;; test for lexically bound variables ;; (progn (makunbound 'a) (makunbound 'b) ; make suere a & b are unbound (not (or (boundp 'a) (boundp 'b))) (defun fun1 () (let ((a 1) (b 3)) (fun2))) (defun fun2 () (or (boundp 'a) (boundp 'b))) (eq nil (fun1)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-FBOUNDP.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-FBOUNDP.TEST new file mode 100644 index 00000000..acffe6a7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-FBOUNDP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fboundp ;; ;; Source: STEELE's book Section 7.1.1: Reference Page: 90 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 2, 1986 ;; ;; Last Update: June 2, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-fboundp.test ;; ;; ;; Syntax: FBOUNDP symbol ;; ;; Function Description: FBOUNDP returns true if the symbol names a global function, a special form or a macro. ;; It returns nil otherwise. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: true or nil ;; ;; (do-test test-fboundp0 ;; ;; tests for system provided functions, special forms, and macros ;; (and (every #'fboundp '(block catch compiler-let declare eval-when flet function go if labels let let* macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq tagbody the throw unwind-protect)) (every #'fboundp '(car cdr caaadr cddddr cdadr endp list-length nthcdr last rest nth copy-list append make-array aref svref adjust-array make-hash-table clrhash hash-table-count every notany some notevery)) (every #'fboundp '(pop push pushnew defmacro multiple-value-list multiple-value-bind multiple-value-setq)))) (do-test test-fboundp1 ;; ;; tests for user defined global functions and macros ;; (and (defun fun1 () 'fun1) (defun fun2 () 'fun2) (defmacro mac1 () ''mac1) (defmacro mac2 () '(car '(hi there !))) (every #'fboundp '(fun1 fun2 mac1 mac2)))) (do-test test-fboundp2 ;; ;; tests for symbols not associated with function definitions ;; (and (setq a 0 b #\q c "1" d '(4) e 'e) (notany #'fboundp '(a b c d e no-such-fun1 no-such-fun2)))) (do-test test-fboundp-local-functions ;; ;; tests for user defined local functions ;; (and (flet ((locfun1 () 'locfun1) (locfun2 () 'foo2)) (notany #'fboundp '(locfun1 locfun2))) (notany #'fboundp '(locfun1 locfun2)))) (do-test test-fboundp-local-macros ;; ;; tests for user defined local macros ;; (and (macrolet ((locmac1 () ''locmac1) (locmac2 () ''bar2)) (notany #'fboundp '(locmac1 locmac2))) (notany #'fboundp '(locmac1 locmac2)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-FUNCTION.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-FUNCTION.TEST new file mode 100644 index 00000000..bb86457c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-FUNCTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: function ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 87 ;; ;; Created By: Karin ;; ;; Creation Date: June 5, 1986 ;; ;; Last Update: June 5, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-function.test ;; ;; ;; Syntax: FUNCTION fn ;; ;; Function Description: FUNCTION returns the functional interpretation of fn. If fn is a symbol, the ;; function definition associated with that symbol is returned. If fn is a ;; lambda-expression, then a lexical closure is returned. ;; ;; Argument(s): fn - a symbol associated with a function definition or a lambda-expression ;; ;; Returns: functional interpretation of fn ;; (do-test test-function0 ;; ;; the following two test cases were copied from page 87 of CLtL ;; (and (progn (defun adder (x) (function (lambda (y) (+ x y)))) (setq add3 (adder 3)) (= (funcall add3 5) 8)) ;; (progn (defun two-funs (x) (list (function (lambda () x)) (function (lambda (y) (setq x y))))) (setq funs (two-funs 6)) (and (= (funcall (car funs)) 6) (= (funcall (cadr funs) 43) 43) (= (funcall (car funs)) 43))))) (do-test test-function1 (let ((funlist '())) (push (function (lambda () 'fun4)) funlist) (push (function (lambda () 'fun3)) funlist) ;; ;; (function f) is same as #'f ;; (push #'(lambda () 'fun2) funlist) (push #'(lambda () 'fun1) funlist) (and (eq (funcall (car funlist)) 'fun1) (eq (funcall (cadr funlist)) 'fun2) (eq (funcall (caddr funlist)) 'fun3) (eq (funcall (cadddr funlist)) 'fun4)))) (do-test-group (test-function2 :before (test-defun fun (x) (if (evenp x) (function +) (function -)))) (do-test "test function2" (and (let ( (fun1 (fun 2)) ) (= (funcall fun1 2 3 4 5) 14)) (let ( (fun2 (fun 3)) ) (= (funcall fun2 2 3 4 5) -10)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-QUOTE.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-QUOTE.TEST new file mode 100644 index 00000000..13dc4bc5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-QUOTE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: quote ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 86 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 29, 1986 ;; ;; Last Update: May 29, 1986 ;; ;; Filed As: {eris}cml>test>quote.test ;; ;; ;; Syntax: QUOTE object ;; ;; Function Description: QUOTE does not evaluate object. It simply returns object. ;; ;; Argument(s): object - any lisp object ;; ;; Returns: object ;; (do-test test-quote0 (and (eq (quote a) 'a) (equal (quote (1 2 3)) '(1 2 3)) (equal (quote (cons 10 20)) '(cons 10 20)) (equal (list (quote a) (quote b)) '(a b)) (equal (quote (setq a (quote c))) '(setq a 'c)) (equal (quote (quote (quote (quote "string")))) ''''"string"))) (do-test test-quote1 ;; ;; (quote f) is equivalent to 'f ;; (and (eq '1 #6r1) (equal `(1 2 ,(* 3 4) ,(list 'a 'b) 5 6 ,(cons 'c 'd)) '(1 2 12 (a b) 5 6 (c . d))) (equal 'urthelorj9037958u3270-ikorldflgkdjmihret02-38 'urthelorj9037958u3270-ikorldflgkdjmihret02-38) (equal (multiple-value-bind (a b c d) (values (list '(x y) '(w z)) (eq (cadr '(m n o p)) 'n) ''quack) `(,a ,b ,c ,d)) '(((x y) (w z)) t 'quack nil)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SPECIAL-FORM-P.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SPECIAL-FORM-P.TEST new file mode 100644 index 00000000..6f1cdbc3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SPECIAL-FORM-P.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: special-form-p ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 91 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 3, 1986 ;; ;; Last Update: June 3, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-special-form-p.test ;; ;; ;; Syntax: SPECIAL-FORM-P symbol ;; ;; Function Description: SPECIAL-FORM-P returns a non-nil value if the symbol names a special form. It returns ;; nil otherwise. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: non-nil & nil ;; (do-test-group (special-form-p-group ;; ;; the values assigned to special-forms1 & special-forms2 are copied from table 5-1 ;; of CTtL p 57 ;; :before (progn (setf special-forms1 '(catch compiler-let declare eval-when flet function go if labels let let* macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq tagbody the throw unwind-protect)) (setf special-forms2 '(block)) (setf non-special-forms1 '(null listp floatp stringp atom + * abs max min <= expt rplaca rlpacd union char= char-code char-name)) (setf non-special-forms2 '(no-such-form1 no-such-form2 no-such-form3)))) ;; ;; -- An implementation is free to implement as a macro any construct described herein (Table 5-1) ;; as a special form.-- (page 57 of CLtL) ;; (do-test test-special-forms1 (every #'(lambda (x) (or (special-form-p x) (macro-function x))) special-forms1)) (do-test test-special-forms2 (every #'(lambda (x) (or (special-form-p x) (macro-function x))) special-forms2)) (do-test test-non-special-forms1 (notany #'special-form-p non-special-forms1)) (do-test test-non-special-forms2 (notany #'special-form-p non-special-forms2))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-FUNCTION.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-FUNCTION.TEST new file mode 100644 index 00000000..a07a9e5d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-FUNCTION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: symbol-function ;; ;; Source: Steele's book Section 7.1.1: Reference Page: 90 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: June 4, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-symbol-function.test ;; ;; ;; Syntax: SYMBOL-FUNCTION symbol ;; ;; Function Description: SYMBOL-FUNCTION returns the current global function definition named by symbol ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: the current glocal function definition ;; an error signal - if the symbol has no function definition ;; (do-test "test symbol-function0 - the function returns current global function definition named by symbol" ;; ;; when the definitions are objects representing special forms ;; (every #'(lambda (x) (and (special-form-p x) (symbol-function x))) '(go block declare catch throw unwind-protect)) ) (do-test "test symbol-function1 - the function returns current global function definition named by symbol" ;; ;; when the definitions are objects representing macros ;; (every #'(lambda (x) (and (macro-function x) (symbol-function x))) '(prog prog* defmacro locally and or)) ) (do-test "test symbol-function2 - the function returns current global function definition named by symbol" ;; ;; when the definitions are functions ;; (and (every #'(lambda (x) (and (functionp x) (not (macro-function x)) (not (special-form-p x)) (symbol-function x) )) '(symbol-value symbol-function boundp fboundp special-form-p first second third)) (= (funcall (symbol-function '+) 10 20 30 40 50) 150) (equal (funcall (symbol-function 'caar) '((2.8 4) 6 8)) 2.8) ) ) ;; (do-test "test symbol-function3 - symbol-function cannot access the local function value" ;; (and ;; (flet ((locfun1 () 'loc1) (locfun2 () 'loc2) (locfun3 () 'loc3)) ;; (notany #'(lambda (x) (nlsetq (symbol-function x))) '(locfun1 locfun2 locfun3))) ;; (labels ((labfun1 () 1) (labfun2 () 2)) ;; (notany #'(lambda (x) (nlsetq (symbol-function x))) '(labfun1 labfun2))))) (do-test-group ( use-SETF-and-SYMBOL-FUNCTION :before (progn (mapcar #'fmakunbound '(mac fun)) (test-defmacro mac () ''mac) (test-defun fun () 'fun) )) (do-test "test symbol-function4 - use SETF and SYMBOL-FUNCTION to alter the global function definition" ;; ;; when previous definition is a macro (try to redefine a macro as a function) ;; (let (buf) (push (mac) buf) (setf (symbol-function 'mac) #'(lambda (x y) (block mac (append `(sum of ,x and ,y is ) (list (+ x y)))) )) (push (funcall (symbol-function 'mac) 12 1) buf) (push (mac 3 -2) buf) (equal buf '( (sum of 3 and -2 is 1) (sum of 12 and 1 is 13) mac)) ) ) (do-test "test symbol-function5 - use SETF and SYMBOL-FUNCTION to alter the global function definition" ;; ;; when previous definition is a function ;; (let (buf) (push (fun) buf) (setf (symbol-function 'fun) #'(lambda (x y) (block fun (cons x y)))) (push (funcall (symbol-function 'fun) 20 40) buf) (push (fun 'a 'b) buf) (equal buf '(( a . b) (20 . 40) fun)) ) ) ) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-VALUE.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-VALUE.TEST new file mode 100644 index 00000000..1923620b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-1-SYMBOL-VALUE.TEST @@ -0,0 +1 @@ +;; ;; Source: Steele's book Section 7.1.1: Reference Page: 90 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 3, 1986 ;; ;; Last Update: June 3, 1986 ;; ;; Filed As: {eris}cml>test>7-1-1-symbol-value.test ;; ;; ;; Syntax: SYMBOL-VALUE symbol ;; ;; Function Description: SYMBOL-VALUE returns the current value of the special variable named by symbol. ;; ;; Argument(s): symbol - a lisp object ;; ;; Returns: a value - if the symbol has a value ;; an error - if the symbol has no value ;; (do-test " test symbol-value : a keyword should return that keyword" (every #'(lambda (x) (eq (symbol-value x) x)) '( :start :end :initial-contents :key :from-end :circle :test ))) (do-test " test symbol-value : a named constant should return its current value" (every #'symbol-value '( t multiple-values-limit call-arguments-limit pi most-positive-fixnum array-dimension-limit array-total-size-limit array-rank-limit))) (do-test " test symbol-value : when used with setf" (progn (setq a 1 b 2 c 3 d 4) (every #'(lambda (x) (let (val) (setq val (symbol-value x)) (setf (symbol-value x) (* val 2)))) '(a b c d)) (every #'(lambda (x y) (= (symbol-value x) y)) '(a b c d) '(2 4 6 8)) ) ) (do-test " test symbol-value : tests for global variables" (and (setq a 10 b "b" c (cons 'c1 'c2) d (char-code #\y) e (prog1 #3r10)) (every #'(lambda (x y) (equal x (symbol-value y))) (list a b c d e) '(a b c d e)) ;; ;; now unbound those variables. The follow-up symbol-value of those variables should signal errors ;; (every #'makunbound '(a b c d e)) (notany #'boundp '(a b c d e)))) (do-test " test symbol-value for lexical variables" ;; ;; tests for lexical variables ;; ( "symbol-value cannot access the value of a lexical variable" page 90 of CLtL) ;; (and (progn (setq a 9) (let ((a 2)) (eq 9 (symbol-value 'a)))) (progn (setq a 9) (let ((a 2)) (declare (special a)) (eq 2 (symbol-value 'a)))) (progn (setq b 'foo) (prog ((b 'bar)) (setq b (cons b nil)) (return (eq 'foo (symbol-value 'b))))))) (do-test "test symbol-value for dynamic variables" ;; ;; tests for dynamic variables ;; (progn (defun fun () (let ((*c* 88)) (declare (special *c*)) (fun1))) (defun fun1 () (eq 88 (symbol-value '*c*))) (fun))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-2-FMAKUNBOUND.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-FMAKUNBOUND.TEST new file mode 100644 index 00000000..316761e6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-FMAKUNBOUND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: fmakunbound ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 92 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 2, 1986 ;; ;; Last Update: June 2, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-fmakunbound.test ;; ;; ;; Syntax: FMAKUNBOUND symbol ;; ;; Function Description: FMAKUNBOUND causes the global function definition named by symbol to become unbound. ;; ;; Argument(s): symbol - a lisp object ;; ;; Returns: symbol - (same as the argument) ;; (do-test test-fmakunbound ;; ;; define some functions ;; (progn (defun fun1 () 'fun1) (defun fun2 (x) (expt x 2)) (defun fun3 (x y) (cons x y)) (defun fun4 (x y z) (progn (and (constantp x) (listp y) (special-form-p z)))) (defun fun5 (w x y z) (let () (- (* w (- x y) z)))) ;; ;; make those functions become unbound ;; (dolist (x '(fun1 fun2 fun3 fun4 fun5)) (fmakunbound x)) ;; ;; make sure no function definitions are bound to those symbols ;; (every #'(lambda (x) (eq nil (fboundp x))) '(fun1 fun2 fun3 fun4 fun5)))) (do-test "test fmakunbound - fmakunbound should return SYMBOL as the result value (p 93)" (prog2 (defun fun () 0) (eq (fmakunbound 'fun) 'fun))) ;;(do-test test-fmakunbound1 ;; ;; tests for some illegal inputs ;; ;;(every #'(lambda (x) (eq nil (nlsetq (fmakunbound x)))) '(3232 #\a (1 2 3) "string"))) (do-test test-fmakunbound2 ;; ;; this test case was copied from page 93 of CLtL ;; (and (defun foo (x) (+ x 1)) (= (foo 4) 5) (prog1 t (fmakunbound 'foo)) (not (fboundp 'foo)) )) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-2-MAKUNBOUND.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-MAKUNBOUND.TEST new file mode 100644 index 00000000..fe6a9f5d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-MAKUNBOUND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: makunbound ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 92 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: Feb 4, 1987 removed test on lexically bound vars ;; ;; Filed As: {eris}cml>test>7-1-2-makunbound.test ;; ;; ;; Syntax: MAKUNBOUND symbol ;; ;; Function Description: MAKUNBOUND causes the dynamic (special) variable named by symbol to become unbound and ;; returns symbol as the result value ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: symbol ;; (do-test "test makunbound - should return symbol as the result value (page 93 of CLtL)" (prog2 (setq a 1) (eq (makunbound 'a) 'a) )) (do-test "test makunbound 0" (and (setq a 1 b 2 c 3 d 4 e 5) (every #'makunbound '(a b c d e)) (notany #'boundp '(a b c d e)))) ;;(do-test " test makunbound - constant symbols are really variables that cannot be changed (p 90 of CLtL)" ;; ;; tests for constants ;; ;;(and (progn (setq a pi) (makunbound 'pi) (= a pi)) ;; (progn (setq b multiple-values-limit) (makunbound 'multiple-values-limit) ( = b multiple-values-limit)))) (do-test " test makunbound - for dynamically bound variables" (progn (defun fun1 () (let* ((w 'w) (x 'x) (y 'y)) (declare (special w x y)) (fun2) )) (defun fun2 () (declare (special w)) (makunbound 'w) (fun3)) (defun fun3 () (declare (special x)) (makunbound 'x) (fun4)) (defun fun4 () (declare (special x y)) (makunbound 'y) (setq x 'xx) (fun5)) (defun fun5 () (declare (special w x y)) (and (not (boundp 'w)) (not (boundp 'y)) (eq (symbol-value 'x) 'xx))) (fun1))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-2-PSETQ.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-PSETQ.TEST new file mode 100644 index 00000000..d17ebc8a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-PSETQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: psetq ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 92 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: June 4, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-psetq.test ;; ;; ;; Syntax: PSETQ {var form}* ;; ;; Function Description: SETQ evaluates the forms and assigns the values to the corresponding variables. ;; The assignment of variables are performed in parallel. The variables may be lexical ;; or special variables. SETQ returns nil. ;; ;; Argument(s): {var form}* ;; ;; Returns: nil ;; (do-test "test psetq - return nil if no argument was specified" (eq nil (psetq))) (do-test "test psetq - return nil" (and (eq nil (psetq a 1 b 2 c 3 d 4)) (equal (list a b c d) '(1 2 3 4)) (eq nil (psetq a (1+ #3r111) b (gcd 3 7) c (string-upcase "dr.livingston"))) (equal (list a b c) '(14 1 "DR.LIVINGSTON")) (eq nil (psetq a (progn 1 2) b (prog1 #\b 3.99) c (prog2 a b (* 2 a)))) (equal (list a b c) '(2 #\b 1)))) (do-test "test psetq - forms are parallelly evaluated" (and (progn (psetq x 17) (psetq x (+ 1 2 3) y (cons x nil)) (equal (list x y) '(6 (17)))) (progn (setq a 1 b 2) (psetq a b b a) (equal (list a b) '(2 1))) (progn (setq a 10 b 20 c 30 d 40) (psetq a (+ a b d) b (- d a b) c (* a b) d (incf c b)) (equal (list a b c d) '( 70 10 200 50))))) (do-test "test psetq - assignment performed for both lexical & special variables" (let ((a 1) (b 1) (c 1)) (declare (special b)) (defun funb () (declare (special b)) (psetq b (if (= 1 b) 1000 -1000))) (psetq a (incf c 99) c (decf b 99)) (funb) (equal (multiple-value-list (values a b c)) '(100 -1000 -98)))) ;; (do-test "test psetq - there must be an even number of argument forms " ;; (not (or (nlsetq (psetq a)) (nlsetq (psetq a 1 b)) (nlsetq (psetq a 4 (+ 3 4)))))) ;; ;; (do-test "test psetq - illegal arguments" ;; (not (or (nlsetq (psetq 43)) (nlsetq (psetq (3 . 4))) (nlsetq (psetq t nil)) (nlsetq (psetq (1+)))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-2-SET.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-SET.TEST new file mode 100644 index 00000000..c0391b6e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-SET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: set ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 92 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: June 4, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-set.test ;; ;; ;; Syntax: SET symbol value ;; ;; Function Description: SET causes the dynamic variable named by symbol to take on value as its value. ;; It cannot alter the value of a lexically bound variable. SET returns value as ;; its result. ;; ;; Argument(s): symbol - a lisp symbol object ;; ;; Returns: value ;; (do-test test-set0 ;; ;; tests for global variables ;; (and (= (+ (set 'a 1) (set 'b 2) (set 'c 30) (set 'd 100)) (+ a b c d)) (progn (setq a 2 b 3) (= (set (if (eq a b) 'c 'd) 100) d)) (eq (set 'ab&cd (+ (set 'ab 9) (set 'cd 20))) (incf ab cd)) (progn (set 'foo (list 'a 'b 'c 'd)) (and (= (list-length foo) (length (list 'a 'b 'c 'd))) (eq (caddr foo) (third '(a b c d))))))) (do-test test-set1 ;; ;; tests for dynamically bound variables ;; (prog ((m '(1 2)) (n '(3 4)) (o '(8 9)) p) (declare (special m n o p)) (defun funlist () (declare (special m n o p)) (set 'p (cons (list m n o) p))) (defun funappend () (declare (special m n o p)) (set 'p (cons (append m n o) p))) (defun funbutlast () (declare (special o p)) (set 'p (cons (butlast o) p)) p) (funlist) (funappend) (return (equal (funbutlast) '((8) (1 2 3 4 8 9) ((1 2) (3 4) (8 9))))))) (do-test test-set2 ;; ;; tests for lexically bound variables ;; set cannot alter the values of lexically bound variables ;; (let ((m 1) (n 2) (o 3)) (set 'm 10) (set 'n 20) (set 'o 30) (and (= m 1) (= n 2) (= o 3)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-1-2-SETQ.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-SETQ.TEST new file mode 100644 index 00000000..6bea2f53 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-1-2-SETQ.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: setq ;; ;; Source: Steele's book Section 7.1.2: Assignment Page: 91 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 4, 1986 ;; ;; Last Update: June 4, 1986 ;; ;; Filed As: {eris}cml>test>7-1-2-setq.test ;; ;; ;; Syntax: SETQ {var form}* ;; ;; Function Description: SETQ evaluates the forms and assigns the values to the corresponding variables. ;; The assignment of variables are performed sequentially. The variables may be lexical ;; or special variables. SETQ returns the result of the evaluation of the last form. ;; ;; Argument(s): {var form}* ;; ;; Returns: the result of the evaluation of the last form ;; nil - if no arguments are specified ;; (do-test "test setq - return nil if no argument was specified" (eq nil (setq))) (do-test "test setq - return value of the last form" (and (= (setq a 1 b 2 c 3 d 4) 4) (equal (setq a (1+ #3r111) b (gcd 3 7) c (string-upcase "dr.livingston")) "DR.LIVINGSTON") (char= (setq a (progn 1 2) b (prog1 #\b 3.99) c (prog2 a b (* 2 a))) #\b))) (do-test "test setq - forms are sequentially evaluated" (and (equal (setq x (+ 1 2 3) y (cons x nil)) '(6)) (progn (setq a 1 b (1+ a) c (1- b) d (incf c)) (>= d c b a)) (progn (setq a (defun funa () 3) b (defun funb () (+ (funa) 2)) c (defun func () (+ (funb) 4))) (= (func) 9)))) (do-test "test setq - assignment performed for both lexical & special variables" (let ((a 1) (b 1) (c 1)) (declare (special b)) (defun funb () (declare (special b)) (setq b (if (= 1 b) 1000 -1000))) (setq a (incf c 99) c (decf b 99)) (funb) (equal (multiple-value-list (values a b c)) '(100 -1000 -98)))) ;; (do-test "test setq - there must be an even number of argument forms " ;; (not (or (nlsetq (setq a)) (nlsetq (setq a 1 b)) (nlsetq (setq a 4 (+ 3 4)))))) ;; ;; (do-test "test setq - illegal arguments" ;; (not (or (nlsetq (setq 43)) (nlsetq (setq (3 . 4))) (nlsetq (setq t nil)) (nlsetq (setq (1+)))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-10-CATCH.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-10-CATCH.TEST new file mode 100644 index 00000000..e37d61aa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-10-CATCH.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: catch & throw ;; ;; Source: CLtL Section 7.10. Dynamic Non-local Exits Page: 139 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 28 ,1986 ;; ;; Last Update: Oct. 28 ,1986 ;; ;; Filed As: {eris}cml>test>7-10-catch.test ;; ;; ;; Syntax: catch TAG {FORM}* ;; ;; Function Description: The catch special from serves as a target for transfer of control by throw. The form TAG is evaluated first ;; to produce an object that names the catch. A catch is then established with the object as the TAG. ;; The FORMs are evaluated as an implicit PROGN, and the results of the last form are returned, except that ;; if during the evaluation of the FORMS a throw should be executed such that the tag of the throw matches the ;; tag of the catch and the catcher is the most recent outstanding catcher with that tag, then the evaluation of ;; the FORMs is aborted and the results specified by the throw are immediately returned from the catch expression. ;; ;; Argument(s): TAG - a lisp form ;; FORM - ;; ;; Returns: anything ;; (do-test "test catch - the body of catch is an implicit progn" (and (eq (catch 'cat ) nil) (= (catch 'cat 1 2 3 4) 4) (equal (multiple-value-list (catch 'foo (block blk (tagbody 1 2 3 (go exit) 4 5 6 exit (return-from blk (values 10 20 30)) (return-from blk 200) )))) '(10 20 30)) ) ) (do-test-group ( "dynamic extent of tags" :before (progn ;; ;; test cases copied from page 39 of CLtL ;; (test-defun bar1 (x) (catch 'trap (+ 3 (bar2 x)))) (test-defun bar2 (y) (catch 'trap (* 5 (bar3 y)))) (test-defun bar3 (z) (throw 'trap z)) ;; ;; (test-defun far1 (x) (catch 'trap (+ 3 (far2 x)))) (test-defun far2 (y) (catch 'trap9 (* 5 (far3 y)))) (test-defun far3 (z) (throw 'trap z)) )) (do-test "test catch & throw - the tag of the throw matches the tag of the most recent outstanding catcher with that tag" (and (= (bar1 7) 10) (= (far1 7) 7) (let (var) ;; ;; this example also demonstrates that throw returns multiple values ;; (equal (multiple-value-list (catch 'cat (catch 'dog (catch 'cat (catch 'cat (push 'a var) (throw 'cat (values var var))) (push 'b var) (throw 'cat (values var var))) (push 'c var) (throw 'cat (values var var))) (push 'd var) (throw 'cat (values var var)))) '((c b a) (c b a) ) ) ) ) ) ) (do-test "test catch & throw - the tags of both catch & throw are evaluated" (let ((b 10)) (= (catch (prog1 'cat (incf b 2) (decf b 10)) (setq b (* b b)) (throw (prog2 (incf b) 'cat (decf b 3)) b)) 2) ) ) (do-test "test catch & throw - the result form is evaluated before the unwinding process commences" (let ( (a '("path" )) (b '("path")) ) (declare (special a b)) (and (equal (catch 'foo (unwind-protect (progn (nconc a '(unwfoo1)) (throw 'foo (nconc a '(throwfoo1))) (nconc a '(wrongfoo1))) (nconc a '(cleanupfoo1)) (nconc a '(cleanupfoo2)) ) (nconc a '(wrongfoo2))) '("path" unwfoo1 throwfoo1 cleanupfoo1 cleanupfoo2)) (equal (catch 'bar (block blk (unwind-protect (progn (nconc b '(unwbar1)) (return-from blk (nconc b '(returnbar1))) (nconc b '(wrongbar1))) ;; ;; the cleanup forms of an unwind-protect are not protected by that unwind-protect ;; (nconc b '(cleanupbar1)) (throw 'bar (nconc b '(cleanupbar2))) (nconc b '(cleanupbar3)) ) (nconc b '(wrongbar2)) (nconc b '(wrongbar3)) )) '("path" unwbar1 returnbar1 cleanupbar1 cleanupbar2)) ;; ;; Page 142 of CLtL (In the process, dynamic variable bindings are undone back to the point of the catch) ;; ;; ;; (equal (list a b) '("path" "path")) ) ) ) (do-test-group ("test catch & throw - when catcher is a function argument" :before (progn (test-defun getnum () (declare (special numlist)) (* 2 (getnum1)) ) (test-defun getnum1() (declare (special numlist)) (throw 'catcher (pop numlist)) numlist ) (test-defun fool (m) (let ( (numlist m) (newvar '()) ) (declare (special numlist)) (dotimes (x (length numlist) newvar) ;; ;; feed whatever returned from catcher to expt ;; (push (expt (catch 'catcher (getnum)) 2) newvar) ) )) )) (do-test "test catch & throw - when catcher is a function argument" (and (equal (fool '(2 3 4)) '(16 9 4)) (equal (fool '(10 20 30 40)) '(1600 900 400 100)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-10-THROW.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-10-THROW.TEST new file mode 100644 index 00000000..8a3e8520 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-10-THROW.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: throw ;; ;; Source: CLtL Section 7.10: Dynamic Non-local Exits Page: 139 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 29 ,1986 ;; ;; Last Update: Oct. 29 ,1986 ;; ;; Filed As: {eris}cml>test>7-10-throw.test ;; ;; ;; Syntax: throw TAG RESULT ;; ;; Function Description: The throw special form transfers control to a matching catch construct. The TAG is evaluated first to ;; produce an object called the throw tag ; then the RESULT form is evaluated, and its results are saved. ;; The most recent outstanding catch whose tag matches the throw tag is exited ; the saved results are ;; returned as the value(s) of the catch. ;; ;; Argument(s): TAG - a lisp form (which returns a symbol) ;; RESULT - a lisp form ;; Returns: anything ;; ;; ;; The tests for throw are included in {eris}cml>test>7-10-catch.test ;; (do-test notest t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-10-UNWIND-PROTECT.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-10-UNWIND-PROTECT.TEST new file mode 100644 index 00000000..e062d429 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-10-UNWIND-PROTECT.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unwind-protect ;; ;; Source: CLtL Section 7.10: Dynamic Non-local exits Page: 139 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 29 ,1986 ;; ;; Last Update: Oct. 29 ,1986 ;; ;; Filed As: {eris}cml>test>7-10-unwind-protect.test ;; ;; ;; Syntax: unwind-protect PROTECTED-FORM {CLEANUP-FORM}* ;; ;; Function Description: unwind-protect guarantees to execute the cleanup-forms before exiting, whether it terminates normally ;; or attemps to exit from the protected form. The function returns whatever results from evaluation of the ;; protected-form and discards all the results from the cleanup-forms. ;; ;; Argument(s): PROTECTED-FORM , CLEANUP-FORM - a lisp form ;; ;; Returns: anything ;; (do-test "test unwind-protect returns multiple-vlaues 0" (equal (multiple-value-list (unwind-protect (values 1 2 3 4))) '(1 2 3 4)) ) (do-test "test unwind-protect returns multiple-vlaues 1" (equal (multiple-value-list (unwind-protect (values-list '(a b c d e)) "this is a cleanup form")) '(a b c d e)) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting 0" (let (a b c d) (and (= (unwind-protect (setq a 10) (setq b 20) (setq c 30) (setq d 40)) 10) (equal (list b c d) '(20 30 40)) ) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting 1" (let (a b c d) (and (= (unwind-protect (prog2 (setq a 10) (setq b 20) (setq b 22)) (setq c 30) (setq d 40)) 20) (equal (list a b c d) '(10 22 30 40)) ) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting from catch" (let (a b c d) (equal (list a b c d (catch 'cat (unwind-protect (progn (setq d 9) (throw 'cat (setq c 99)) (setq d 89)) (setq a "cleanup 1") (setq b "cleanup 2") )) a b c d) '(nil nil nil nil 99 "cleanup 1" "cleanup 2" 99 9)) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting from block" (let (a b c d) (equal (list a b c d (block blk (unwind-protect (progn (setq d 9) (return-from blk (setq c 99)) (setq d 89)) (setq a "cleanup 1") (setq b "cleanup 2") )) a b c d) '(nil nil nil nil 99 "cleanup 1" "cleanup 2" 99 9)) ) ) (do-test "test unwind-protect guarantees to execute the cleanup-forms before exiting from tagbody" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (progn (setq d 9) (go exit) (setq d 89)) (setq a "cleanup 1") (setq b "cleanup 2") ) exit (setq c 67)) a b c d) '(nil nil nil nil nil "cleanup 1" "cleanup 2" 67 9)) ) ) (do-test "test unwind-protect - the cleanup-forms are not protected by that unwind-protect 0" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (progn (setq d 9) (setq d 89)) (setq a "cleanup 1") (go exit) (setq b "cleanup 2") ) exit (setq c 67)) a b c d) '(nil nil nil nil nil "cleanup 1" nil 67 89)) ) ) (do-test "test unwind-protect - an unwind-protect occurred within the protected form of another unwind-protect 0" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (tagbody (setq d 9) (unwind-protect (setq c 7) (go exit) (decf c 3) (setq d 90)) done (incf c 2) ) (setq a "cleanup 1") (setq c (expt c 2)) (setq b "cleanup 2") ) exit (incf c 4)) a b c d) '(nil nil nil nil nil "cleanup 1" "cleanup 2" 53 9)) ) ) (do-test "test unwind-protect - an unwind-protect occurred within the protected form of another unwind-protect 1" (let (a b c d) (equal (list a b c d (tagbody (unwind-protect (tagbody (setq d 9) (unwind-protect (go exit) (setq c 7) (decf c 3) (setq d 90)) (incf c 2) ) (setq a "cleanup 1") (setq c (expt c 2)) (setq b "cleanup 2") ) exit (incf c 4)) a b c d) '(nil nil nil nil nil "cleanup 1" "cleanup 2" 20 90)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-MODIFY-MACRO.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-MODIFY-MACRO.TEST new file mode 100644 index 00000000..f7e6d693 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-MODIFY-MACRO.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: define-modify-macro ;; ;; Source: Steele's book Section 8.2: Macro definition ;; Page: 101 - 105 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: November 26, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>8-1-define-modify-macro.test ;; ;; ;; Syntax: (define-modify-macro name lambda-list function [doc-string]) ;; ;; Function Description: defines a read-modify-write macro named name. ;; modifies the value in a given location ;; ;; Argument(s): name - the name of the macro ;; lambda-list - describes the arguments for the function ;; function - is literally the function to apply ;; doc-string - documentation for the macro ;; ;; Returns: the name of the macro ;; ;; ;; ;; comment: May want to try the functions nargs and argtype when ;; the work. ;; a macro agaisnt each type of variable? (do-test "try a simple case with lists, cdr" (let ((temp1 '(a b c d e f)) (temp2 '(1 2 3 4))) (and (eq 'MY-RESTF (define-modify-macro my-restf (list) cdr)) (equal (my-restf temp1) '(b c d e f)) (equal (my-restf temp2) '(2 3 4)) (equal temp1 '(b c d e f)) (equal temp2 '(2 3 4)) ))) (do-test "try with lists within lists, car" (let ((temp1 '((a b c) d e)) (temp2 '((1 2 3) 4 5))) (and (eq 'MY-FIRSTF (define-modify-macro my-firstf (list) car "doc")) (equal (my-firstf temp1) '(a b c)) (equal (my-firstf temp2) '(1 2 3)) (equal temp1 '(a b c)) (equal temp2 '(1 2 3)) ))) (do-test "test creating a modify macro with same name as a just defined macro" (let ((temp1 5)) (defmacro my-double (number) `(+ ,number ,number)) (and (eq 'MY-DOUBLEF (define-modify-macro my-doublef (number) my-double)) (eq 10 (my-doublef temp1)) (eq 10 temp1) ))) ; currently when run this by its self it works, but when run from ; do-test-file it fails. ;(do-test "test creating a modify macro with same name as a just defined ;function" ; (let ((temp1 #\M)) ; (defun MY-LIST*F (temp-var) "dummy-function" (list temp-var)) ; (and ; (eq 'MY-LIST*F (define-modify-macro my-list*f (first &rest list) ;list*)) ; (equal (my-list*f temp1 #\B #\C) '(#\M #\B . #\C)) ; (equal temp1 '(#\M #\B . #\C)) ; ))) (do-test "test &rest" (let ((temp1 '(a))) (and (eq 'MY-APPENDF (define-modify-macro my-appendf (first &rest rest) append)) (equal (my-appendf temp1 '(b) '(c)) '(a b c)) (equal temp1 '(a b c)) (equal '1 (setq temp1 1)) (eq 'MY-LISTF (define-modify-macro my-listf (first &rest rest) list)) (equal (my-listf temp1 '2 '3 '4 '5) '(1 2 3 4 5)) (equal temp1 '(1 2 3 4 5)) ))) (do-test "test &optional" (let ((temp1 5)) (defmacro my-length (position string) `(+ ,position (length ,string))) (and (eq 'MY-LENGTHF (define-modify-macro my-lengthf (position &optional string) my-length)) (eq 5 (my-lengthf temp1)) (eq 5 temp1) (eq 8 (my-lengthf temp1 "bye")) (eq 8 temp1) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-SETF-METHOD.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-SETF-METHOD.TEST new file mode 100644 index 00000000..1ece12cf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFINE-SETF-METHOD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: define-setf-method ;; ;; Source: Guy L Steele's CLTL, Chapter 7 Control Structure ;; Section: 7.2 Generalized Variables ;; Page: 105 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 25, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-2-define-setf-method.test ;; ;; ;; Syntax: (define-setf-method access-fn lambda-list ;; {declaration | doc-string}* {form}*) ;; ;; Function Description: This defines how to setf a generalized-variable reference ;; that is of the form (access-fn..). Note that define-setf-method differs from ;; the complex form of defsetf in that while the body is being executed the variables ;; in lambda-list are bound to parts of the generalized-variable reference, not to ;; to temporary variables that will be bound to the values of such parts. ;; In addition, define-setf-method does not have defsetf's restriction that access-fn ;; must be a function or a function-like macrto; an arbitrary defmacro destructring ;; pattern is permitted in lambda-list. ;; ;; Argument(s): access-fn - name of a function of a macro. ;; lambda-list - subforms of the generalized-variable reference, as ;; with defmacro. ;; form - evaluating the form should generate five values representing ;; setf method. ;; ;; ;; Returns: Name of access-fn ;; ;; Constraints/Limitations: none ;; setf method for the form (ldb bytespec int). ;; Recall that the int form must itself be suitable for setf. (do-test-group ("define-setf-method-setup" :before (progn (defun test-ldb (bytespec int) (ldb bytespec int)) (setq byte-spec8-0 (byte 8 0)) (setq byte-spec8-1 (byte 8 1)) (setq byte-spec8-2 (byte 8 2)) (setq byte-spec8-3 (byte 8 3)) (setq byte-spec8-4 (byte 8 4)) ) ) (do-test "define-setf-method-test" (and (eq (define-setf-method test-ldb (bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method int) ;Get SETF method for int. (let ((btemp (gensym)) ;Temp var for byte specifier. (store (gensym)) ;Temp var for byte to store. (stemp (first stores))) ;Temp var for int to store. ;; Return the SETF method for LDB as five values. (values (cons btemp temps) (cons bytespec vals) (list store) `(let ((,stemp (dpb ,store ,btemp ,access-form))) ,store-form ,store) ;storing form. `(ldb ,btemp ,access-form) ;accessing form. )))) 'test-ldb) (eq (test-ldb byte-spec8-0 15) 15) (eq (test-ldb byte-spec8-1 15) 7) (eq (test-ldb byte-spec8-2 15) 3) (eq (test-ldb byte-spec8-3 15) 1) (eq (test-ldb byte-spec8-4 15) 0) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFSETF.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFSETF.TEST new file mode 100644 index 00000000..ec1689a9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFSETF.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: defsetf ;; ;; Source: Steele's book Section 8.2: Macro definition ;; Page: 102 - 105 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: December 2, 1986 ;; ;; Last Update: ;; ;; Filed As: {eris}cml>test>8-1-defsetf.test ;; ;; ;; Syntax: (defsetf access-fn {update-fn [doc-string] | ;; lambda-list (store-variable) ;; {declaration | doc-string}* {form}*) ;; ;; Function Description: defines how to setf a generalized-variable reference ;; of the form (access-fn ...). ;; ;; Argument(s): access-fn - the function or macro to get the data ;; update-fn - a function or macro, one more argument ;; than access-fn, how put the data ;; doc-string - for documentation ;; lambda-list - subforms of the generalized-variable ;; reference, as with defmacro. ;; store-variable - the value to be stored into ;; declaration - ;; doc-string - for documentation ;; form - ;; ;; Returns: ;; ;; ;; ;; Comments: Cann't use FLET in defsetf. (do-test "try the example from the book, modify so don't mess up others" :before (defun my-subseq (sequence start &optional end) (subseq sequence start end)) (let ((temp1 "this is a string")) (and (eq 'MY-SUBSEQ (defsetf my-subseq (sequence start &optional end) (new-sequence) `(progn (replace ,sequence ,new-sequence :start1 ,start :end1 ,end) ,new-sequence))) (equal " " (setf (my-subseq temp1 5 7) " ")) (equal temp1 "this a string") (equal "is fun " (setf (my-subseq temp1 5) "is fun ")) (equal temp1 "this is fun ring") ))) (do-test "try with both functions defined" :before (progn (defun my-nth (n list) "own nth function" (nth n list)) (defun my-nthf (n list value) (setf (nth n list) value) value)) (let ((temp1 '(have a nice day))) (and (eq 'MY-NTH (defsetf my-nth my-nthf "try two functions")) (eq 'good (setf (my-nth 2 temp1) 'good)) (equal temp1 '(have a good day)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST new file mode 100644 index 00000000..87ab1d32 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-setf-method-multiple-value ;; ;; Source: Guy L Steele's CLTL, Chapter 7 Control Structure ;; Section: 7.2 Generalized Variables ;; Page: 107 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 26, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-2-get-setf-method-multiple-value.test ;; ;; ;; Syntax: (get-setf-method-multiple-value form) ;; ;; Function Description: This returns five values constituting the setf method for form. ;; The form must be a generalized-variable reference. This is the same as get-setf-method ;; except that it does not check the number of store-variable; use this in cases that ;; allow storing multiple values into a generalized variable. ;; ;; Argument(s): form ;; ;; Returns: Five values constituting the setf method for form. ;; ;; Constraints/Limitations: none (do-test "get-setf-method-multiple-value-test" (and (defmacro test-setf-macro (reference value) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value reference) (declare (ignore access-form)) `(let* ,(mapcar #'list (append vars stores) (append vals (list value))) ,store-form))) (setf x 100 y 200 z 300) (eq x 100) (eq y 200) (eq z 300) (test-setf-macro x 1000 y 2000 z 3000) (eq x 1000) (not (eq y 2000)) (not (eq z 3000)) (eq (get-setf-method-multiple-value 'test-setf-macro)) (let ((setf-values (multiple-value-list (get-setf-method-multiple-value 'test-setf-macro)))) (and (eq (first setf-values) NIL) (eq (second setf-values) NIL) (symbolp (car (third setf-values))) (equal (fourth setf-values) (list 'setq 'test-setf-macro (car (third setf-values)))) (eq (fifth setf-values) 'test-setf-macro) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD.TEST new file mode 100644 index 00000000..9eea1d27 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-GET-SETF-METHOD.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: get-setf-method ;; ;; Source: Guy L Steele's CLTL, Chapter 7 Control Structure ;; Section: 7.2 Generalized Variables ;; Page: 106 ;; ;; Created By: John Park ;; ;; Creation Date: Nov 26, 1986 ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-2-get-setf-method.test ;; ;; ;; Syntax: (get-setf-method form) ;; ;; Function Description: get-setf-method returns five values constituting the setf ;; method for form. The form must be a generalized-variable reference. It takes care ;; of error-checking and macro expansion and guarantees to return exactly one-store ;; variable. ;; ;; Argument(s): form ;; ;; Returns: Five values constituting the setf method for form. ;; ;; Constraints/Limitations: none (do-test "get-setf-method-test" (and (defmacro test-setf-macro (reference value) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method reference) (declare (ignore access-form)) `(let* ,(mapcar #'list (append vars stores) (append vals (list value))) ,store-form))) (setf x 100 y 200 z 300) (eq x 100) (eq y 200) (eq z 300) (test-setf-macro x 1000 y 2000 z 3000) (eq x 1000) (not (eq y 2000)) (not (eq z 3000)) (eq (get-setf-method 'test-setf-macro)) (let ((setf-values (multiple-value-list (get-setf-method 'test-setf-macro)))) (and (eq (first setf-values) NIL) (eq (second setf-values) NIL) (symbolp (car (third setf-values))) (equal (fourth setf-values) (list 'setq 'test-setf-macro (car (third setf-values)))) (eq (fifth setf-values) 'test-setf-macro) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-PSETF.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-PSETF.TEST new file mode 100644 index 00000000..cdcc2bae --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-PSETF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: psetf ;; ;; Source: Guy L Steele's CLTL, Chapter 7, Control Structure ;; Section: 7-2 Generalized Variables ;; Page: 97 ;; ;; Created By: Jim Blum ;; ;; Creation Date: Oct 24, 1986 ;; ;; Last Update: Nov 24, 1986 by John Park, The test file was reformatted due to ;; its unreadability and changes were made to the following do-test cases, ;; which failed the first time the test was run: ;; (PSETF-CAAAR, PSETF-GETHASH, PSETF-BIT, and PSETF-SBIT) ;; ;; Filed As: {ERIS}CML>TEST>7-2-psetf.test ;; ;; ;; Syntax: (psetf {place newvalue)*) ;; ;; Function Description: The psetf {place newvalue} is evaluated and then checked ;; for correctness. This function is like setf except it evaluates {place ;; newvalue}* in parallel instead of sequentially. ;; ;; Argument(s): Place - when evaluated accesses a data object in some location and ;; inverts it to produce a corresponding form to update the location. ;; Newvalue - when evaluated gets stored according to above update form created ;; ;; Returns: value(s) of the last evaluated form of the selected clause ;; ;; Constraints/Limitations: (DO-TEST PSETF-OF-A-SYMBOL (AND (SETQ FOO 1) (SETQ BAR 2) (NOT (PSETF BAR FOO FOO BAR)) (EQ FOO 2) (EQ BAR 1))) (DO-TEST PSETF-CAR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (NOT (PSETF (CAR FOO) (CAR BAR) (CAR BAR) (CAR FOO))) (EQUAL FOO '(B . A)))) (DO-TEST PSETF-CDR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (NOT (PSETF (CDR FOO) (CDR BAR) (CDR BAR) (CDR FOO))) (EQUAL FOO '(A . B)))) (DO-TEST PSETF-CAAR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (NOT (PSETF (CAAR FOO) (CAAR BAR) (CAAR BAR) (CAAR FOO))) (EQ (CAAR FOO) 'E))) (DO-TEST PSETF-CADR (AND (SETQ FOO '((A . B) G . D)) (SETQ BAR '((E . F) C . H)) (NOT (PSETF (CADR FOO) (CADR BAR) (CADR BAR) (CADR FOO))) (EQ (CADR FOO) 'C) (EQ (CADR BAR) 'G))) (DO-TEST PSETF-CDAR (AND (SETQ FOO '((A . F) C . D)) (SETQ BAR '((E . B) G . H)) (NOT (PSETF (CDAR FOO) (CDAR BAR) (CDAR BAR) (CDAR FOO))) (EQ (CDAR FOO) 'B) (EQ (CDAR BAR) 'F))) (DO-TEST PSETF-CDDR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (NOT (PSETF (CDDR FOO) (CDDR BAR) (CDDR BAR) (CDDR FOO))) (EQ (CDDR FOO) 'H) (EQ (CDDR BAR) 'D))) (DO-TEST PSETF-CAAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CAAAR FOO) (CAAAR BAR) (CAAAR BAR) (CAAAR FOO))) (EQ (CAAAR FOO) 'I) (EQ (CAAAR BAR) 'A))) (DO-TEST PSETF-CAADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CAADR FOO) (CAADR BAR) (CAADR BAR) (CAADR FOO))) (EQ (CAADR FOO) 'M) (EQ (CAADR BAR) 'E))) (DO-TEST PSETF-CADAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CADAR FOO) (CADAR BAR) (CADAR BAR) (CADAR FOO))) (EQ (CADAR FOO) 'K) (EQ (CADAR BAR) 'C))) (DO-TEST PSETF-CADDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CADDR FOO) (CADDR BAR) (CADDR BAR) (CADDR FOO))) (EQ (CADDR FOO) 'O) (EQ (CADDR BAR) 'G))) (DO-TEST PSETF-CDAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDAAR FOO) (CDAAR BAR) (CDAAR BAR) (CDAAR FOO))) (EQ (CDAAR FOO) 'J) (EQ (CDAAR BAR) 'B))) (DO-TEST PSETF-CDADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDADR FOO) (CDADR BAR) (CDADR BAR) (CDADR FOO))) (EQ (CDADR FOO) 'N) (EQ (CDADR BAR) 'F))) (DO-TEST PSETF-CDDAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDDAR FOO) (CDDAR BAR) (CDDAR BAR) (CDDAR FOO))) (EQ (CDDAR FOO) 'L) (EQ (CDDAR BAR) 'D))) (DO-TEST PSETF-CDDDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (NOT (PSETF (CDDDR FOO) (CDDDR BAR) (CDDDR BAR) (CDDDR FOO))) (EQ (CDDDR FOO) 'P) (EQ (CDDDR BAR) 'H))) (DO-TEST PSETF-CAAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAAAAR FOO) (CAAAAR BAR) (CAAAAR BAR) (CAAAAR FOO))) (EQ (CAAAAR FOO) 'AA) (EQ (CAAAAR BAR) 'A))) (DO-TEST PSETF-CAAADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAAADR FOO) (CAAADR BAR) (CAAADR BAR) (CAAADR FOO))) (EQ (CAAADR FOO) 'II) (EQ (CAAADR BAR) 'I))) (DO-TEST PSETF-CAADAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAADAR FOO) (CAADAR BAR) (CAADAR BAR) (CAADAR FOO))) (EQ (CAADAR FOO) 'EE) (EQ (CAADAR BAR) 'E))) (DO-TEST PSETF-CAADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CAADDR FOO) (CAADDR BAR) (CAADDR BAR) (CAADDR FOO))) (EQ (CAADDR FOO) 'MM) (EQ (CAADDR BAR) 'M))) (DO-TEST PSETF-CADAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADAAR FOO) (CADAAR BAR) (CADAAR BAR) (CADAAR FOO))) (EQ (CADAAR FOO) 'CC) (EQ (CADAAR BAR) 'C))) (DO-TEST PSETF-CADADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADADR FOO) (CADADR BAR) (CADADR BAR) (CADADR FOO))) (EQ (CADADR FOO) 'KK) (EQ (CADADR BAR) 'K))) (DO-TEST PSETF-CADDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADDAR FOO) (CADDAR BAR) (CADDAR BAR) (CADDAR FOO))) (EQ (CADDAR FOO) 'GG) (EQ (CADDAR BAR) 'G))) (DO-TEST PSETF-CADDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CADDDR FOO) (CADDDR BAR) (CADDDR BAR) (CADDDR FOO))) (EQ (CADDDR FOO) 'OO) (EQ (CADDDR BAR) 'O))) (DO-TEST PSETF-CDAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDAAAR FOO) (CDAAAR BAR) (CDAAAR BAR) (CDAAAR FOO))) (EQ (CDAAAR FOO) 'BB) (EQ (CDAAAR BAR) 'B))) (DO-TEST PSETF-CDADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDADDR FOO) (CDADDR BAR) (CDADDR BAR) (CDADDR FOO))) (EQ (CDADDR FOO) 'NN) (EQ (CDADDR BAR) 'N))) (DO-TEST PSETF-CDDAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDAAR FOO) (CDDAAR BAR) (CDDAAR BAR) (CDDAAR FOO))) (EQ (CDDAAR FOO) 'DD) (EQ (CDDAAR BAR) 'D))) (DO-TEST PSETF-CDDADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDADR FOO) (CDDADR BAR) (CDDADR BAR) (CDDADR FOO))) (EQ (CDDADR FOO) 'LL) (EQ (CDDADR BAR) 'L))) (DO-TEST PSETF-CDDDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDDAR FOO) (CDDDAR BAR) (CDDDAR BAR) (CDDDAR FOO))) (EQ (CDDDAR FOO) 'HH) (EQ (CDDDAR BAR) 'H))) (DO-TEST PSETF-CDDDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (NOT (PSETF (CDDDDR FOO) (CDDDDR BAR) (CDDDDR BAR) (CDDDDR FOO))) (EQ (CDDDDR FOO) 'PP) (EQ (CDDDDR BAR) 'P))) (DO-TEST PSETF-FIRST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FIRST FOO) (FIRST BAR) (FIRST BAR) (FIRST FOO))) (EQ (FIRST FOO) 'A) (EQ (FIRST BAR) '1))) (DO-TEST PSETF-SECOND (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SECOND FOO) (SECOND BAR) (SECOND BAR) (SECOND FOO))) (EQ (SECOND FOO) 'B) (EQ (SECOND BAR) '2))) (DO-TEST PSETF-THIRD (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (THIRD FOO) (THIRD BAR) (THIRD BAR) (THIRD FOO))) (EQ (THIRD FOO) 'C) (EQ (THIRD BAR) '3))) (DO-TEST PSETF-FOURTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FOURTH FOO) (FOURTH BAR) (FOURTH BAR) (FOURTH FOO))) (EQ (FOURTH FOO) 'D) (EQ (FOURTH BAR) '4))) (DO-TEST PSETF-FIFTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FIFTH FOO) (FIFTH BAR) (FIFTH BAR) (FIFTH FOO))) (EQ (FIFTH FOO) 'E) (EQ (FIFTH BAR) '5))) (DO-TEST PSETF-FIFTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (FIFTH FOO) (FIFTH BAR) (FIFTH BAR) (FIFTH FOO))) (EQ (FIFTH FOO) 'E) (EQ (FIFTH BAR) '5))) (DO-TEST PSETF-SIXTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SIXTH FOO) (SIXTH BAR) (SIXTH BAR) (SIXTH FOO))) (EQ (SIXTH FOO) 'F) (EQ (SIXTH BAR) '6))) (DO-TEST PSETF-SEVENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SEVENTH FOO) (SEVENTH BAR) (SEVENTH BAR) (SEVENTH FOO))) (EQ (SEVENTH FOO) 'G) (EQ (SEVENTH BAR) '7))) (DO-TEST PSETF-EIGHTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (EIGHTH FOO) (EIGHTH BAR) (EIGHTH BAR) (EIGHTH FOO))) (EQ (EIGHTH FOO) 'H) (EQ (EIGHTH BAR) '8))) (DO-TEST PSETF-NINTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (NINTH FOO) (NINTH BAR) (NINTH BAR) (NINTH FOO))) (EQ (NINTH FOO) 'I) (EQ (NINTH BAR) '9))) (DO-TEST PSETF-TENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (TENTH FOO) (TENTH BAR) (TENTH BAR) (TENTH FOO))) (EQ (TENTH FOO) 'J) (EQ (TENTH BAR) '10))) (DO-TEST PSETF-REST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (REST FOO) (REST BAR) (REST BAR) (REST FOO))) (EQUAL FOO '(1 B C D E F G H I J)) (EQUAL BAR '(A 2 3 4 5 6 7 8 9 10)))) (DO-TEST PSETF-NTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (NTH 6 FOO) (NTH 6 BAR) (NTH 6 BAR) (NTH 6 FOO))) (EQUAL FOO '(1 2 3 4 5 6 G 8 9 10)) (EQUAL BAR '(A B C D E F 7 H I J)))) (DO-TEST PSETF-NTHCDR (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (NTHCDR 6 FOO) (NTHCDR 6 BAR) (NTHCDR 6 BAR) (NTHCDR 6 FOO))) (EQUAL FOO '(1 2 3 4 5 6 G H I J)) (EQUAL BAR '(A B C D E F 7 8 9 10)))) (DO-TEST PSETF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (NOT (PSETF (AREF FOO 6) (AREF BAR 6) (AREF BAR 6) (AREF FOO 6))) (EQUAL (AREF FOO 6) 'G) (EQUAL (AREF BAR 6) '7))) (DO-TEST PSETF-SVREF (AND (SETQ FOO (VECTOR 1 2 3 4 5 6 7 8 9 10)) (SETQ BAR (VECTOR 'A 'B 'C 'D 'E 'F 'G 'H 'I 'J)) (NOT (PSETF (SVREF FOO 6) (SVREF BAR 6) (SVREF BAR 6) (SVREF FOO 6))) (EQUAL (SVREF FOO 6) 'G) (EQUAL (SVREF BAR 6) '7))) (DO-TEST PSETF-GET (AND (SETF (GET 'FOO 'A) 'B) (SETF (GET 'BAR 'C) 'D) (NOT (PSETF (GET 'FOO 'A) (GET 'BAR 'C) (GET 'BAR 'C) (GET 'FOO 'A))) (EQUAL (GET 'FOO 'A) 'D) (EQUAL (GET 'BAR 'C) 'B))) (DO-TEST PSETF-GETF (AND (SETQ FOO '(B C D E F)) (SETQ BAR '(H I J K L)) (NOT (PSETF (GETF FOO 'D) (GETF BAR 'J) (GETF BAR 'J) (GETF FOO 'D))) (EQUAL FOO '(B C D K F)) (EQUAL BAR '(H I J E L)))) (DO-TEST PSETF-GETHASH (AND (SETQ FOO (MAKE-HASH-TABLE)) (SETF (GETHASH 'A FOO) 'B) (SETF (GETHASH 'C FOO) 'D) (NOT (PSETF (GETHASH 'A FOO) (GETHASH 'C FOO) (GETHASH 'C FOO) (GETHASH 'A FOO))) (EQUAL (GETHASH 'A FOO) 'D) (EQUAL (GETHASH 'C FOO) 'B))) (DO-TEST PSETF-SYMBOL-FUNCTION (AND (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (A) NIL)) (SETF (SYMBOL-FUNCTION 'BAR) '(LAMBDA (B) NIL)) (NOT (PSETF (SYMBOL-FUNCTION 'FOO) (SYMBOL-FUNCTION 'BAR) (SYMBOL-FUNCTION 'BAR) (SYMBOL-FUNCTION 'FOO))) (EQUAL (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)) (EQUAL (SYMBOL-FUNCTION 'BAR) '(LAMBDA (A) NIL)))) (DO-TEST PSETF-SYMBOL-VALUE (AND (SETF (SYMBOL-VALUE 'FOO) 1) (SETF (SYMBOL-VALUE 'BAR) 2) (NOT (PSETF (SYMBOL-VALUE 'FOO) (SYMBOL-VALUE 'BAR) (SYMBOL-VALUE 'BAR) (SYMBOL-VALUE 'FOO))) (EQUAL (SYMBOL-VALUE 'FOO) 2) (EQUAL (SYMBOL-VALUE 'BAR) 1))) (DO-TEST PSETF-SYMBOL-PLIST (AND (SETF (SYMBOL-PLIST 'FOO) '(A B C D)) (SETF (SYMBOL-PLIST 'BAR) '(E F G H)) (NOT (PSETF (SYMBOL-PLIST 'FOO) (SYMBOL-PLIST 'BAR) (SYMBOL-PLIST 'BAR) (SYMBOL-PLIST 'FOO))) (EQUAL (SYMBOL-PLIST 'FOO) '(E F G H)) (EQUAL (SYMBOL-PLIST 'BAR) '(A B C D)))) (DO-TEST PSETF-MACRO-FUNCTION (AND (SETQ FOO (GENTEMP "FOO")) (SETQ BAR (GENTEMP "BAR")) (SETF (MACRO-FUNCTION FOO) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (SETF (MACRO-FUNCTION BAR) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (NOT (PSETF (MACRO-FUNCTION FOO) (MACRO-FUNCTION BAR) (MACRO-FUNCTION BAR) (MACRO-FUNCTION FOO))) (EQUAL (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (EQUAL (MACRO-FUNCTION BAR) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))))) (DO-TEST PSETF-CHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (NOT (PSETF (CHAR FOO 0) (CHAR BAR 0) (CHAR BAR 0) (CHAR FOO 0))) (EQL (CHAR FOO 0) #\B) (EQL (CHAR BAR 0) #\A))) (DO-TEST PSETF-SCHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (NOT (PSETF (SCHAR FOO 0) (SCHAR BAR 0) (SCHAR BAR 0) (SCHAR FOO 0))) (EQL (SCHAR FOO 0) #\B) (EQL (SCHAR BAR 0) #\A))) (DO-TEST PSETF-BIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (NOT (PSETF (BIT FOO 1) (BIT BAR 1) (BIT BAR 1) (BIT FOO 1))) (EQL (BIT FOO 1) 0) (EQL (BIT BAR 1) 1))) (DO-TEST PSETF-SBIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (NOT (PSETF (SBIT FOO 1) (SBIT BAR 1) (SBIT BAR 1) (SBIT FOO 1))) (EQL (SBIT FOO 1) 0) (EQL (SBIT BAR 1) 1))) (DO-TEST PSETF-SUBSEQ (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (SETQ BAR '(A B C D E F G H I J)) (NOT (PSETF (SUBSEQ FOO 2 4) (SUBSEQ BAR 2 4) (SUBSEQ BAR 2 4) (SUBSEQ FOO 2 4))) (EQUAL (SUBSEQ FOO 2 4) '(C D)) (EQUAL (SUBSEQ BAR 2 4) '(3 4)))) (DO-TEST PSETF-LDB (AND (SETQ FOO 100000) (SETQ BAR 200000) (NOT (PSETF (LDB (BYTE 8 0) FOO) (LDB (BYTE 8 0) BAR) (LDB (BYTE 8 0) BAR) (LDB (BYTE 8 0) FOO))) (EQL (LDB (BYTE 8 0) FOO) 64) (EQL (LDB (BYTE 8 0) BAR) 160))) (DO-TEST PSETF-MASK-FIELD (AND (SETQ FOO 100000) (SETQ BAR 200000) (NOT (PSETF (MASK-FIELD (BYTE 8 0) FOO) (MASK-FIELD (BYTE 8 0) BAR) (MASK-FIELD (BYTE 8 0) BAR) (MASK-FIELD (BYTE 8 0) FOO))) (EQL (MASK-FIELD (BYTE 8 0) FOO) 64) (EQL (MASK-FIELD (BYTE 8 0) BAR) 160))) (DO-TEST PSETF-APPLY-OF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (NOT (PSETF (APPLY #'AREF FOO '(1)) (APPLY #'AREF BAR '(1)) (APPLY #'AREF BAR '(1)) (APPLY #'AREF FOO '(1)))) (EQL (AREF FOO 1) 'B) (EQL (AREF BAR 1) '2))) (DO-TEST PSETF-EVAL-ONCE (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (SETQ A 4) (SETQ B 4) (NOT (PSETF (AREF FOO (INCF A)) (AREF BAR B) (AREF BAR (INCF B)) (AREF FOO A))) (EQL (AREF FOO 5) 'E) (EQL (AREF BAR 5) '6))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-ROTATEF.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-ROTATEF.TEST new file mode 100644 index 00000000..9b3b2897 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-ROTATEF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ROTATEF ;; ;; Source: Steele's book ;; Section 7.2: Generalized Varibles Page: 93 ;; ;; Created By: Jim Blum ;; ;; ;; Creation Date: Nov 4, 1986 ;; ;; Last Update: Nov 25, 1986, Changes were made to ROTATEF-PUTHSH and ;; ROTATEF-CHAR by John Park ;; ;; ;; Filed As: {ERIS}CML>TEST>7-2-ROTATEF.TEST ;; ;; ;; Syntax: (rotatef {place}*) ;; ;; ;; Function Description: ;; ;; Each place form may be any form acceptable as a generalized variable ;; to setf. In the form (rotatef place1 place2 ... placen), the values ;; in place1 through placen are accessed and saved. Values 2 through n ;; and value 1 are then store into place1 through placen. It is as if all ;; the places form an end-around shift register that is rotated one place ;; to the left, with value of place1 being shifted around the end to ;; placen. Note that (rotatef place1 place2) exchanges the contents of ;; place1 and place2. ;; ;; ;; Argument(s): PLACE - when evaluated accesses a data object in ;; some location and "inverts" it to produce ;; corresponding form to update the location ;; ;; ;; Returns: NIL ;; ;; (DO-TEST ROTATEF-OF-A-SYMBOL (AND (SETQ FOO 1) (SETQ BAR 2) (SETQ BAZ 3) (SETQ BLETCH 4) (NOT (ROTATEF BAR FOO BAZ BLETCH)) (EQ FOO 3) (EQ BAR 1) (EQ BAZ 4) (EQ BLETCH 2))) (DO-TEST ROTATEF-CAR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (SETQ BAZ '(C . C)) (SETQ BLETCH '(D . D)) (NOT (ROTATEF (CAR FOO) (CAR BAR) (CAR BAZ) (CAR BLETCH))) (EQUAL FOO '(B . A)) (EQUAL BAR '(C . B)) (EQUAL BAZ '(D . C)) (EQUAL BLETCH '(A . D)))) (DO-TEST ROTATEF-CDR (AND (SETQ FOO '(A . A)) (SETQ BAR '(B . B)) (SETQ BAZ '(C . C)) (SETQ BLETCH '(D . D)) (NOT (ROTATEF (CDR FOO) (CDR BAR) (CDR BAZ) (CDR BLETCH))) (EQUAL FOO '(A . B)) (EQUAL BAR '(B . C)) (EQUAL BAZ '(C . D)) (EQUAL BLETCH '(D . A)))) (DO-TEST ROTATEF-CAAR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CAAR FOO) (CAAR BAR) (CAAR BAZ) (CAAR BLETCH))) (EQUAL FOO '((E . B) C . D)) (EQUAL BAR '((I . F) G . H)) (EQUAL BAZ '((M . J) K . L)) (EQUAL BLETCH '((A . N) O . P)))) (DO-TEST ROTATEF-CADR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CADR FOO) (CADR BAR) (CADR BAZ) (CADR BLETCH))) (EQUAL FOO '((A . B) G . D)) (EQUAL BAR '((E . F) K . H)) (EQUAL BAZ '((I . J) O . L)) (EQUAL BLETCH '((M . N) C . P)))) (DO-TEST ROTATEF-CDAR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CDAR FOO) (CDAR BAR) (CDAR BAZ) (CDAR BLETCH))) (EQUAL FOO '((A . F) C . D)) (EQUAL BAR '((E . J) G . H)) (EQUAL BAZ '((I . N) K . L)) (EQUAL BLETCH '((M . B) O . P)))) (DO-TEST ROTATEF-CDDR (AND (SETQ FOO '((A . B) C . D)) (SETQ BAR '((E . F) G . H)) (SETQ BAZ '((I . J) K . L)) (SETQ BLETCH '((M . N) O . P)) (NOT (ROTATEF (CDDR FOO) (CDDR BAR) (CDDR BAZ) (CDDR BLETCH))) (EQUAL FOO '((A . B) C . H)) (EQUAL BAR '((E . F) G . L)) (EQUAL BAZ '((I . J) K . P)) (EQUAL BLETCH '((M . N) O . D)))) (DO-TEST ROTATEF-CAAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CAAAR FOO) (CAAAR BAR) (CAAAR BAZ) (CAAAR BLETCH))) (EQUAL FOO '(((I . B) C . D) (E . F) G . H)) (EQUAL BAR '(((Q . J) K . L) (M . N) O . P)) (EQUAL BAZ '(((1 . R) S . T) (U . V) W . X)) (EQUAL BLETCH '(((A . 2) 3 . 4) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CAADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CAADR FOO) (CAADR BAR) (CAADR BAZ) (CAADR BLETCH))) (EQUAL FOO '(((A . B) C . D) (M . F) G . H)) (EQUAL BAR '(((I . J) K . L) (U . N) O . P)) (EQUAL BAZ '(((Q . R) S . T) (5 . V) W . X)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (E . 6) 7 . 8)))) (DO-TEST ROTATEF-CADAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CADAR FOO) (CADAR BAR) (CADAR BAZ) (CADAR BLETCH))) (EQUAL FOO '(((A . B) K . D) (E . F) G . H)) (EQUAL BAR '(((I . J) S . L) (M . N) O . P)) (EQUAL BAZ '(((Q . R) 3 . T) (U . V) W . X)) (EQUAL BLETCH '(((1 . 2) C . 4) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CADDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CADDR FOO) (CADDR BAR) (CADDR BAZ) (CADDR BLETCH))) (EQUAL FOO '(((A . B) C . D) (E . F) O . H)) (EQUAL BAR '(((I . J) K . L) (M . N) W . P)) (EQUAL BAZ '(((Q . R) S . T) (U . V) 7 . X)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (5 . 6) G . 8)))) (DO-TEST ROTATEF-CDAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDAAR FOO) (CDAAR BAR) (CDAAR BAZ) (CDAAR BLETCH))) (EQUAL FOO '(((A . J) C . D) (E . F) G . H)) (EQUAL BAR '(((I . R) K . L) (M . N) O . P)) (EQUAL BAZ '(((Q . 2) S . T) (U . V) W . X)) (EQUAL BLETCH '(((1 . B) 3 . 4) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CDADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDADR FOO) (CDADR BAR) (CDADR BAZ) (CDADR BLETCH))) (EQUAL FOO '(((A . B) C . D) (E . N) G . H)) (EQUAL BAR '(((I . J) K . L) (M . V) O . P)) (EQUAL BAZ '(((Q . R) S . T) (U . 6) W . X)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (5 . F) 7 . 8)))) (DO-TEST ROTATEF-CDDAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDDAR FOO) (CDDAR BAR) (CDDAR BAZ) (CDDAR BLETCH))) (EQUAL FOO '(((A . B) C . L) (E . F) G . H)) (EQUAL BAR '(((I . J) K . T) (M . N) O . P)) (EQUAL BAZ '(((Q . R) S . 4) (U . V) W . X)) (EQUAL BLETCH '(((1 . 2) 3 . D) (5 . 6) 7 . 8)))) (DO-TEST ROTATEF-CDDDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (SETQ BAR '(((I . J) K . L) (M . N) O . P)) (SETQ BAZ '(((Q . R) S . T) (U . V) W . X)) (SETQ BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . 8)) (NOT (ROTATEF (CDDDR FOO) (CDDDR BAR) (CDDDR BAZ) (CDDDR BLETCH))) (EQUAL FOO '(((A . B) C . D) (E . F) G . P)) (EQUAL BAR '(((I . J) K . L) (M . N) O . X)) (EQUAL BAZ '(((Q . R) S . T) (U . V) W . 8)) (EQUAL BLETCH '(((1 . 2) 3 . 4) (5 . 6) 7 . H)))) (DO-TEST ROTATEF-CAAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAAAAR FOO) (CAAAAR BAR) (CAAAAR BAZ) (CAAAAR BLETCH))) (EQUAL FOO '((((AA . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AAA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((A . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CAAADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAAADR FOO) (CAAADR BAR) (CAAADR BAZ) (CAAADR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((II . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((III . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((IIII . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((I . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CAADAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAADAR FOO) (CAADAR BAR) (CAADAR BAZ) (CAADAR BLETCH))) (EQUAL FOO '((((A . B) C . D) (EE . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EEE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (E . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CAADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CAADDR FOO) (CAADDR BAR) (CAADDR BAZ) (CAADDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (MM . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MMM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (M . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADAAR FOO) (CADAAR BAR) (CADAAR BAZ) (CADAAR BLETCH))) (EQUAL FOO '((((A . B) CC . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CCC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) C . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADADR FOO) (CADADR BAR) (CADADR BAZ) (CADADR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) KK . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KKK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) K . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADDAR FOO) (CADDAR BAR) (CADDAR BAZ) (CADDAR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) GG . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GGG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) G . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CADDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CADDDR FOO) (CADDDR BAR) (CADDDR BAZ) (CADDDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) OO . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OOO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) O . PPPP)))) (DO-TEST ROTATEF-CDAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDAAAR FOO) (CDAAAR BAR) (CDAAAR BAZ) (CDAAAR BLETCH))) (EQUAL FOO '((((A . BB) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BBB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . B) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDADDR FOO) (CDADDR BAR) (CDADDR BAZ) (CDADDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . NN) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NNN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . N) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDAAR FOO) (CDDAAR BAR) (CDDAAR BAZ) (CDDAAR BLETCH))) (EQUAL FOO '((((A . B) C . DD) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DDD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . D) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDADR FOO) (CDDADR BAR) (CDDADR BAZ) (CDDADR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . LL) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LLL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . L) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDDAR FOO) (CDDDAR BAR) (CDDDAR BAZ) (CDDDAR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . HH) ((I . J) K . L) (M . N) O . P)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HHH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . H) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)))) (DO-TEST ROTATEF-CDDDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (SETQ BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PP)) (SETQ BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPP)) (SETQ BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . PPPP)) (NOT (ROTATEF (CDDDDR FOO) (CDDDDR BAR) (CDDDDR BAZ) (CDDDDR BLETCH))) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . PP)) (EQUAL BAR '((((AA . BB) CC . DD) (EE . FF) GG . HH) ((II . JJ) KK . LL) (MM . NN) OO . PPP)) (EQUAL BAZ '((((AAA . BBB) CCC . DDD) (EEE . FFF) GGG . HHH) ((III . JJJ) KKK . LLL) (MMM . NNN) OOO . PPPP)) (EQUAL BLETCH '((((AAAA . BBBB) CCCC . DDDD) (EEEE . FFFF) GGGG . HHHH) ((IIII . JJJJ) KKKK . LLLL) (MMMM . NNNN) OOOO . P)))) (DO-TEST ROTATEF-FIRST (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (FIRST FOO) (FIRST BAR) (FIRST BAZ) (FIRST BLETCH))) (EQUAL FOO '(AA B C D E F G H I J)) (EQUAL BAR '(AAA BB CC DD EE FF GG HH II JJ)) (EQUAL BAZ '(AAAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(A BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-SECOND (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (SECOND FOO) (SECOND BAR) (SECOND BAZ) (SECOND BLETCH))) (EQUAL FOO '(A BB C D E F G H I J)) (EQUAL BAR '(AA BBB CC DD EE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBBB CCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA B CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-THIRD (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (THIRD FOO) (THIRD BAR) (THIRD BAZ) (THIRD BLETCH))) (EQUAL FOO '(A B CC D E F G H I J)) (EQUAL BAR '(AA BB CCC DD EE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB C DDDD EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-FOURTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (FOURTH FOO) (FOURTH BAR) (FOURTH BAZ) (FOURTH BLETCH))) (EQUAL FOO '(A B C DD E F G H I J)) (EQUAL BAR '(AA BB CC DDD EE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDDD EEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC D EEEE FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-FIFTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (FIFTH FOO) (FIFTH BAR) (FIFTH BAZ) (FIFTH BLETCH))) (EQUAL FOO '(A B C D EE F G H I J)) (EQUAL BAR '(AA BB CC DD EEE FF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEEE FFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD E FFFF GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-SIXTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (SIXTH FOO) (SIXTH BAR) (SIXTH BAZ) (SIXTH BLETCH))) (EQUAL FOO '(A B C D E FF G H I J)) (EQUAL BAR '(AA BB CC DD EE FFF GG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFFF GGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE F GGGG HHHH IIII JJJJ)))) (DO-TEST ROTATEF-SEVENTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (SEVENTH FOO) (SEVENTH BAR) (SEVENTH BAZ) (SEVENTH BLETCH))) (EQUAL FOO '(A B C D E F GG H I J)) (EQUAL BAR '(AA BB CC DD EE FF GGG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF G HHHH IIII JJJJ)))) (DO-TEST ROTATEF-EIGHTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (EIGHTH FOO) (EIGHTH BAR) (EIGHTH BAZ) (EIGHTH BLETCH))) (EQUAL FOO '(A B C D E F G HH I J)) (EQUAL BAR '(AA BB CC DD EE FF GG HHH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGG HHHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG H IIII JJJJ)))) (DO-TEST ROTATEF-NINTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (NINTH FOO) (NINTH BAR) (NINTH BAZ) (NINTH BLETCH))) (EQUAL FOO '(A B C D E F G H II J)) (EQUAL BAR '(AA BB CC DD EE FF GG HH III JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH IIII JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH I JJJJ)))) (DO-TEST ROTATEF-TENTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (TENTH FOO) (TENTH BAR) (TENTH BAZ) (TENTH BLETCH))) (EQUAL FOO '(A B C D E F G H I JJ)) (EQUAL BAR '(AA BB CC DD EE FF GG HH II JJJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII J)))) (DO-TEST ROTATEF-REST (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (REST FOO) (REST BAR) (REST BAZ) (REST BLETCH))) (EQUAL FOO '(A BB CC DD EE FF GG HH II JJ)) (EQUAL BAR '(AA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (EQUAL BAZ '(AAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (EQUAL BLETCH '(AAAA B C D E F G H I J)))) (DO-TEST ROTATEF-NTH (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (NTH 6 FOO) (NTH 6 BAR) (NTH 6 BAZ) (NTH 6 BLETCH))) (EQUAL FOO '(A B C D E F GG H I J)) (EQUAL BAR '(AA BB CC DD EE FF GGG HH II JJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGGG HHH III JJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF G HHHH IIII JJJJ)))) (DO-TEST ROTATEF-NTHCDR (AND (SETQ FOO '(A B C D E F G H I J)) (SETQ BAR '(AA BB CC DD EE FF GG HH II JJ)) (SETQ BAZ '(AAA BBB CCC DDD EEE FFF GGG HHH III JJJ)) (SETQ BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ)) (NOT (ROTATEF (NTHCDR 6 FOO) (NTHCDR 6 BAR) (NTHCDR 6 BAZ) (NTHCDR 6 BLETCH))) (EQUAL FOO '(A B C D E F GG HH II JJ)) (EQUAL BAR '(AA BB CC DD EE FF GGG HHH III JJJ)) (EQUAL BAZ '(AAA BBB CCC DDD EEE FFF GGGG HHHH IIII JJJJ)) (EQUAL BLETCH '(AAAA BBBB CCCC DDDD EEEE FFFF G H I J)))) (DO-TEST ROTATEF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AA BB CC DD EE FF GG HH II JJ))) (SETQ BAZ (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAA BBB CCC DDD EEE FFF GGG HHHH IIII JJJJ))) (SETQ BLETCH (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ))) (NOT (ROTATEF (AREF FOO 6) (AREF BAR 6) (AREF BAZ 6) (AREF BLETCH 6))) (EQ (AREF FOO 6) 'GG) (EQ (AREF BAR 6) 'GGG) (EQ (AREF BAZ 6) 'GGGG) (EQ (AREF BLETCH 6) 'G))) (DO-TEST ROTATEF-SVREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(A B C D E F G H I J))) (SETQ BAR (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AA BB CC DD EE FF GG HH II JJ))) (SETQ BAZ (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAA BBB CCC DDD EEE FFF GGG HHHH IIII JJJJ))) (SETQ BLETCH (MAKE-ARRAY 10 :INITIAL-CONTENTS '(AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ))) (NOT (ROTATEF (SVREF FOO 6) (SVREF BAR 6) (SVREF BAZ 6) (SVREF BLETCH 6))) (EQ (SVREF FOO 6) 'GG) (EQ (SVREF BAR 6) 'GGG) (EQ (SVREF BAZ 6) 'GGGG) (EQ (SVREF BLETCH 6) 'G))) (DO-TEST ROTATEF-GET (AND (SETF (GET 'FOO 'A) 'B) (SETF (GET 'BAR 'C) 'D) (SETF (GET 'BAZ 'E) 'F) (SETF (GET 'BLETCH 'G) 'H) (NOT (ROTATEF (GET 'FOO 'A) (GET 'BAR 'C) (GET 'BAZ 'E) (GET 'BLETCH 'G))) (EQ (GET 'FOO 'A) 'D) (EQ (GET 'BAR 'C) 'F) (EQ (GET 'BAZ 'E) 'H) (EQ (GET 'BLETCH 'G) 'B))) (DO-TEST ROTATEF-GETF (AND (SETQ FOO '(B C D E F)) (SETQ BAR '(H I J K L)) (SETQ BAZ '(M N O P Q)) (SETQ BLETCH '(R S T U V)) (NOT (ROTATEF (GETF FOO 'D) (GETF BAR 'J) (GETF BAZ 'O) (GETF BLETCH 'T))) (EQUAL FOO '(B C D K F)) (EQUAL BAR '(H I J P L)) (EQUAL BAZ '(M N O U Q)) (EQUAL BLETCH '(R S T E V)))) (DO-TEST ROTATEF-GETHASH (AND (SETQ FOO (MAKE-HASH-TABLE)) (SETF (GETHASH 'A FOO) 'B) (SETF (GETHASH 'C FOO) 'D) (SETF (GETHASH 'E FOO) 'F) (SETF (GETHASH 'G FOO) 'H) (NOT (ROTATEF (GETHASH 'A FOO) (GETHASH 'C FOO) (GETHASH 'E FOO) (GETHASH 'G FOO))) (EQ (GETHASH 'A FOO) 'D) (EQ (GETHASH 'C FOO) 'F) (EQ (GETHASH 'E FOO) 'H) (EQ (GETHASH 'G FOO) 'B))) (DO-TEST ROTATEF-SYMBOL-FUNCTION (AND (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (A) NIL)) (SETF (SYMBOL-FUNCTION 'BAR) '(LAMBDA (B) NIL)) (SETF (SYMBOL-FUNCTION 'BAZ) '(LAMBDA (C) NIL)) (SETF (SYMBOL-FUNCTION 'BLETCH) '(LAMBDA (D) NIL)) (NOT (ROTATEF (SYMBOL-FUNCTION 'FOO) (SYMBOL-FUNCTION 'BAR) (SYMBOL-FUNCTION 'BAZ) (SYMBOL-FUNCTION 'BLETCH))) (EQUAL (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)) (EQUAL (SYMBOL-FUNCTION 'BAR) '(LAMBDA (C) NIL)) (EQUAL (SYMBOL-FUNCTION 'BAZ) '(LAMBDA (D) NIL)) (EQUAL (SYMBOL-FUNCTION 'BLETCH) '(LAMBDA (A) NIL)))) (DO-TEST ROTATEF-SYMBOL-VALUE (AND (SETF (SYMBOL-VALUE 'FOO) 1) (SETF (SYMBOL-VALUE 'BAR) 2) (SETF (SYMBOL-VALUE 'BAZ) 3) (SETF (SYMBOL-VALUE 'BLETCH) 4) (NOT (ROTATEF (SYMBOL-VALUE 'FOO) (SYMBOL-VALUE 'BAR) (SYMBOL-VALUE 'BAZ) (SYMBOL-VALUE 'BLETCH))) (EQ (SYMBOL-VALUE 'FOO) 2) (EQ (SYMBOL-VALUE 'BAR) 3) (EQ (SYMBOL-VALUE 'BAZ) 4) (EQ (SYMBOL-VALUE 'BLETCH) 1))) (DO-TEST ROTATEF-SYMBOL-PLIST (AND (SETF (SYMBOL-PLIST 'FOO) '(A B C D)) (SETF (SYMBOL-PLIST 'BAR) '(E F G H)) (SETF (SYMBOL-PLIST 'BAZ) '(I J K L)) (SETF (SYMBOL-PLIST 'BLETCH) '(M N O P)) (NOT (ROTATEF (SYMBOL-PLIST 'FOO) (SYMBOL-PLIST 'BAR) (SYMBOL-PLIST 'BAZ) (SYMBOL-PLIST 'BLETCH))) (EQUAL (SYMBOL-PLIST 'FOO) '(E F G H)) (EQUAL (SYMBOL-PLIST 'BAR) '(I J K L)) (EQUAL (SYMBOL-PLIST 'BAZ) '(M N O P)) (EQUAL (SYMBOL-PLIST 'BLETCH) '(A B C D)))) (DO-TEST ROTATEF-MACRO-FUNCTION (AND (SETQ FOO (GENTEMP "FOO")) (SETQ BAR (GENTEMP "BAR")) (SETQ BAZ (GENTEMP "BAZ")) (SETQ BLETCH (GENTEMP "BLETCH")) (SETF (MACRO-FUNCTION FOO) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (SETF (MACRO-FUNCTION BAR) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (SETF (MACRO-FUNCTION BAZ) '(LAMBDA (C) (BQUOTE (CONS (|,| C) (|,| C))))) (SETF (MACRO-FUNCTION BLETCH) '(LAMBDA (D) (BQUOTE (CONS (|,| D) (|,| D))))) (NOT (ROTATEF (MACRO-FUNCTION FOO) (MACRO-FUNCTION BAR) (MACRO-FUNCTION BAZ) (MACRO-FUNCTION BLETCH))) (EQUAL (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) (EQUAL (MACRO-FUNCTION BAR) '(LAMBDA (C) (BQUOTE (CONS (|,| C) (|,| C))))) (EQUAL (MACRO-FUNCTION BAZ) '(LAMBDA (D) (BQUOTE (CONS (|,| D) (|,| D))))) (EQUAL (MACRO-FUNCTION BLETCH) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))))) (DO-TEST ROTATEF-CHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (SETQ BAZ "C-STRING") (SETQ BLETCH "D-STRING") (NOT (ROTATEF (CHAR FOO 0) (CHAR BAR 0) (CHAR BAZ 0) (CHAR BLETCH 0))) (EQL (CHAR FOO 0) #\B) (EQL (CHAR BAR 0) #\C) (EQL (CHAR BAZ 0) #\D) (EQL (CHAR BLETCH 0) #\A))) (DO-TEST ROTATEF-SCHAR (AND (SETQ FOO "A-STRING") (SETQ BAR "B-STRING") (SETQ BAZ "C-STRING") (SETQ BLETCH "D-STRING") (NOT (ROTATEF (SCHAR FOO 0) (SCHAR BAR 0) (SCHAR BAZ 0) (SCHAR BLETCH 0))) (EQL (SCHAR FOO 0) #\B) (EQL (SCHAR BAR 0) #\C) (EQL (SCHAR BAZ 0) #\D) (EQL (SCHAR BLETCH 0) #\A))) (DO-TEST ROTATEF-BIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (SETQ BAZ #*01010101) (SETQ BLETCH #*10101010) (NOT (ROTATEF (BIT FOO 1) (BIT BAR 1) (BIT BAZ 1) (BIT BLETCH 1))) (EQL (BIT FOO 1) 0) (EQL (BIT BAR 1) 1) (EQL (BIT BAZ 1) 0) (EQL (BIT BLETCH 1) 1))) (DO-TEST ROTATEF-SBIT (AND (SETQ FOO #*01010101) (SETQ BAR #*10101010) (SETQ BAZ #*01010101) (SETQ BLETCH #*10101010) (NOT (ROTATEF (SBIT FOO 1) (SBIT BAR 1) (SBIT BAZ 1) (SBIT BLETCH 1))) (EQL (SBIT FOO 1) 0) (EQL (SBIT BAR 1) 1) (EQL (SBIT BAZ 1) 0) (EQL (SBIT BLETCH 1) 1))) (DO-TEST ROTATEF-ELT ; make sure setf-inverse optimizations aware of side-effects (let* ((a '(1 2 3)) (b '(4 5 6)) (c a)) (rotatef (elt a 0) (elt (setq a b) 1)) (and (equal c '(5 2 3)) (equal b '(4 1 6))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-SETF.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-SETF.TEST new file mode 100644 index 00000000..8498c888 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-SETF.TEST @@ -0,0 +1 @@ +(DO-TEST SETF-OF-A-SYMBOL (AND (EQ (SETF FOO (QUOTE BAR))(QUOTE BAR)) (EQ FOO (QUOTE BAR)))) (DO-TEST SETF-CAR (LET ((FOO (QUOTE (A . B)))) (AND (EQ (SETF (CAR FOO) (QUOTE BAR)) (QUOTE BAR)) (EQ (CAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDR (LET ((FOO (QUOTE (A . B)))) (AND (EQ (SETF (CDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAAR (LET ((FOO (QUOTE ((A . B) C . D)))) (AND (EQ (SETF (CAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADR (LET ((FOO (QUOTE ((A . B) C . D)))) (AND (EQ (SETF (CADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDAR (LET ((FOO (QUOTE ((A . B) C . D)))) (AND (EQ (SETF (CDAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDR (LET ((FOO (QUOTE ((A . B) C . D)))) (AND (EQ (SETF (CDDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAAAR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CAAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAADR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CAADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADAR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CADAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADDR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CADDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDAAR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CDAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDADR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CDADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDAR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CDDAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDDR (LET ((FOO (QUOTE (((A . B) C . D) (E . F) G . H)))) (AND (EQ (SETF (CDDDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAAAAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CAAAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAAAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAAADR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CAAADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAAADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAADAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CAADAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAADAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CAADDR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CAADDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CAADDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADAAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CADAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADADR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CADADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADDAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CADDAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADDAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CADDDR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CADDDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CADDDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDAAAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDAAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDAAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDAADR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDAADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDAADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDADAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDADAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDADAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDADDR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDADDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDADDR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDAAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDDAAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDAAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDADR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDDADR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDADR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDDAR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDDDAR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDDAR FOO) (QUOTE BAR))))) (DO-TEST SETF-CDDDDR (LET ((FOO (QUOTE ((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (AND (EQ (SETF (CDDDDR FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (CDDDDR FOO) (QUOTE BAR))))) (DO-TEST SETF-FIRST (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (FIRST FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (FIRST FOO) (QUOTE BAR))))) (DO-TEST SETF-SECOND (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (SECOND FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (SECOND FOO) (QUOTE BAR))))) (DO-TEST SETF-THIRD (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (THIRD FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (THIRD FOO) (QUOTE BAR))))) (DO-TEST SETF-FOURTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (FOURTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (FOURTH FOO) (QUOTE BAR))))) (DO-TEST SETF-FIFTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (FIFTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (FIFTH FOO) (QUOTE BAR))))) (DO-TEST SETF-SIXTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (SIXTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (SIXTH FOO) (QUOTE BAR))))) (DO-TEST SETF-SEVENTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (SEVENTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (SEVENTH FOO) (QUOTE BAR))))) (DO-TEST SETF-EIGHTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (EIGHTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (EIGHTH FOO) (QUOTE BAR))))) (DO-TEST SETF-NINTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (NINTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (NINTH FOO) (QUOTE BAR))))) (DO-TEST SETF-TENTH (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (TENTH FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (TENTH FOO) (QUOTE BAR))))) (DO-TEST SETF-REST (LET (( FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (REST FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (REST FOO) (QUOTE BAR))))) (DO-TEST SETF-NTH (LET ((FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQ (SETF (NTH 6 FOO) (QUOTE BAR))(QUOTE BAR)) (EQ (NTH 6 FOO) (QUOTE BAR))))) (DO-TEST SETF-NTHCDR (LET ((FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQUAL (SETF (NTHCDR 6 FOO) '(A B C)) '(A B C)) (EQUAL (NTHCDR 6 FOO) '(A B C))))) (DO-TEST SETF-AREF (LET ((FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS (QUOTE (1 2 3 4 5 6 7 8 9 10))))) (AND (EQ (SETF (AREF FOO 2) (QUOTE BAR))(QUOTE BAR)) (EQ (AREF FOO 2) (QUOTE BAR))))) (DO-TEST SETF-SVREF (LET ((FOO (VECTOR 10 :INITIAL-CONTENTS (QUOTE (1 2 3 4 5 6 7 8 9 10))))) (AND (EQ (SETF (SVREF FOO 2) (QUOTE BAR))(QUOTE BAR)) (EQ (SVREF FOO 2) (QUOTE BAR))))) (DO-TEST SETF-GET (AND (EQ (SETF (GET (QUOTE FOO) (QUOTE BAR)) (QUOTE BAZ)) (QUOTE BAZ)) (EQ (GET (QUOTE FOO) (QUOTE BAR)) (QUOTE BAZ)))) (DO-TEST SETF-GETF (LET ((FOO (QUOTE (CRUFT1 CRUFT1 BAR BLETCH BAR2 JUNK)))) (AND (EQ (SETF (GETF FOO (QUOTE BAR)) (QUOTE BAZ)) (QUOTE BAZ)) (EQ (GETF FOO (QUOTE BAR)) (QUOTE BAZ))))) (DO-TEST SETF-GETHASH (LET ((FOO (MAKE-HASH-TABLE))) (AND (EQ (SETF (GETHASH (QUOTE BAR) FOO) (QUOTE BAZ)) (QUOTE BAZ)) (EQ (GETHASH (QUOTE BAR) FOO) (QUOTE BAZ))))) (DO-TEST SETF-SYMBOL-FUNCTION (AND (EQUAL (SETF (SYMBOL-FUNCTION (QUOTE FOO)) (QUOTE (LAMBDA (BAR) NIL))) (QUOTE (LAMBDA (BAR) NIL))) (EQUAL (SYMBOL-FUNCTION (QUOTE FOO)) (QUOTE (LAMBDA (BAR) NIL))))) (DO-TEST SETF-SYMBOL-VALUE (AND (EQ (SETF (SYMBOL-VALUE (QUOTE FOO)) (QUOTE BAR)) (QUOTE BAR)) (EQ (SYMBOL-VALUE (QUOTE FOO)) (QUOTE BAR)))) (DO-TEST SETF-SYMBOL-PLIST (AND (EQUAL (SETF (SYMBOL-PLIST (QUOTE FOO)) (QUOTE (CRUFT1 CRUFTPROP1 BAR BLETCH))) (QUOTE (CRUFT1 CRUFTPROP1 BAR BLETCH))) (EQUAL (SYMBOL-PLIST (QUOTE FOO)) (QUOTE (CRUFT1 CRUFTPROP1 BAR BLETCH))))) (DO-TEST SETF-MACRO-FUNCTION (AND (EQUAL (SETF (MACRO-FUNCTION (QUOTE FOO)) (QUOTE (LAMBDA (BAR) (BQUOTE (CONS (\, BAR) (\, BAR)))))) (QUOTE (LAMBDA (BAR) (BQUOTE (CONS (\, BAR) (\, BAR)))))) (EQUAL (MACRO-FUNCTION (QUOTE FOO)) (QUOTE (LAMBDA (BAR) (BQUOTE (CONS (\, BAR) (\, BAR)))))))) (DO-TEST SETF-CHAR (LET ((FOO "A-STRING")) (AND (EQL (SETF (CHAR FOO 1) #\a) #\a) (EQL (CHAR FOO 1) #\a)))) (DO-TEST SETF-SCHAR (LET ((FOO "A-STRING")) (AND (EQL (SETF (SCHAR FOO 1) #\a) #\a) (EQL (SCHAR FOO 1) #\a)))) (DO-TEST SETF-BIT (LET ((FOO '#*00000000)) (AND (EQL (SETF (BIT FOO 1) 1) 1) (EQL (BIT FOO 1) 1)))) (DO-TEST SETF-SBIT (LET ((FOO '#*11111111)) (AND (EQL (SETF (BIT FOO 1) 0) 0) (EQL (BIT FOO 1) 0)))) (DO-TEST SETF-SUBSEQ (LET ((FOO (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (AND (EQUAL (SETF (SUBSEQ FOO 2 4) (QUOTE (BAR BAZ))) (QUOTE (BAR BAZ))) (EQUAL (SUBSEQ FOO 2 4) (QUOTE (BAR BAZ)))))) (DO-TEST SETF-LDB (LET ((FOO 100000)) (AND (EQL (SETF (LDB (BYTE 8 0) FOO) 42) 42) (EQL (LDB (BYTE 8 0) FOO) 42)))) (DO-TEST SETF-MASK-FIELD (LET ((FOO 0)) (AND (EQL (SETF (MASK-FIELD (BYTE 8 0) FOO) 42) 42) (EQL (MASK-FIELD (BYTE 8 0) FOO) 42)))) (DO-TEST SETF-APPLY-OF-AREF (LET ((FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS (QUOTE (1 2 3 4 5 6 7 8 9 10))))) (AND (EQ (SETF (APPLY (FUNCTION AREF) FOO '(4)) (QUOTE BAR)) (QUOTE BAR)) (EQ (AREF FOO 4) (QUOTE BAR))))) (DO-TEST SETF-EVAL-ONCE (LET ((FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS (QUOTE (1 2 3 4 5 6 7 8 9 10)))) (BAR 4)) (AND (EQ (SETF (AREF FOO (INCF BAR)) (QUOTE BAZ)) (QUOTE BAZ)) (EQ (AREF FOO 5) (QUOTE BAZ)) (EQL BAR 5)))) (DO-TEST PSETF (LET ((FOO (QUOTE (A B C))) (B0 -1) (B1 0)) (AND (NULL (PSETF (NTH (INCF B0) FOO) (NTH (INCF B1) FOO) (SECOND FOO) (FIRST FOO))) (EQL B0 0) (EQL B1 1) (EQUAL FOO (QUOTE (B A C)))))) (DO-TEST SHIFTF (LET ((FOO (QUOTE (BAR A B))) (B0 -1) (B1 0) (B2 1)) (AND (EQ (SHIFTF (NTH (INCF B0) FOO) (NTH (INCF B1) FOO) (NTH (INCF B2) FOO) 'C) 'BAR) (EQL B0 0) (EQL B1 1) (EQL B2 2) (EQUAL FOO (QUOTE (A B C)))))) (DO-TEST ROTATEF (LET ((FOO (QUOTE (C A B))) (B0 -1)) (AND (NULL (ROTATEF (NTH (INCF B0) FOO) (SECOND FOO) (CADDR FOO))) (EQL B0 0) (EQUAL FOO (QUOTE (A B C)))))) (DO-TEST SETF-OF-MACROLET-THING ; Test for AR 6273 (LET ((FOO (QUOTE (A B C)))) (AND (EQ (MACROLET ((FOO (X) `(CADR ,X))) (SETF (FOO FOO) 'BAR)) 'BAR) (EQUAL FOO (QUOTE (A BAR C)))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-2-SHIFTF.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-2-SHIFTF.TEST new file mode 100644 index 00000000..297eecb0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-SHIFTF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SHIFTF ;; ;; Source: Steele's book ;; Section 7.2: Generalized Varibles ;; Page: 93 ;; ;; Created By: Jim Blum ;; ;; ;; ;; ;; Last Update: Nov 25, 1986, changes were made to SHIFTF-CAADDR, ;; SHIFTF-GETHASH, SHIFTF-APPLY-OF-AREF and reformatted for readability by John Park ;; ;; ;; Filed As: {ERIS}CML>TEST>7-2-SHIFTF.TEST ;; ;; ;; Syntax: (shiftf {place}+ newvalue) ;; ;; ;; ;; ;; The values in place1 through placen are accesed and saved, and newvalue is ;; evaluated, for a total of n + 1 values in all. Values 2 through n +1 are then stored into ;; place1 through placen, and value 1 (the original value of place1) is returned. It is as if ;; all the places form a shift register; the newvalue is shifted in from the right, all values ;; shift over to the left one place, and the value shifted out of place1 is returned. ;; ;; ;; ;; ;; Argument(s): PLACE - when evaluated accesses a data object in ;; some location and "inverts" it to produce ;; corresponding form to update the location ;; NEWVALUE - when evaluated gets stored according to the ;; above update form created. ;; ;; Returns: the value shifted out of place1 ;; ;; ;; (DO-TEST SHIFTF-OF-A-SYMBOL (AND (SETQ FOO 1) (EQ (SHIFTF FOO 2) 1) (EQ FOO 2))) (DO-TEST SHIFTF-CAR (AND (SETQ FOO '(A . B)) (EQ (SHIFTF (CAR FOO) 'C) 'A) (EQUAL FOO '(C . B)))) (DO-TEST SHIFTF-CDR (AND (SETQ FOO '(A . B)) (EQ (SHIFTF (CDR FOO) 'C) 'B) (EQUAL FOO '(A . C)))) (DO-TEST SHIFTF-CAAR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CAAR FOO) 'E) 'A) (EQUAL FOO '((E . B) C . D)))) (DO-TEST SHIFTF-CADR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CADR FOO) 'E) 'C) (EQUAL FOO '((A . B) E . D)))) (DO-TEST SHIFTF-CDAR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CDAR FOO) 'E) 'B) (EQUAL FOO '((A . E) C . D)))) (DO-TEST SHIFTF-CDDR (AND (SETQ FOO '((A . B) C . D)) (EQ (SHIFTF (CDDR FOO) 'E) 'D) (EQUAL FOO '((A . B) C . E)))) (DO-TEST SHIFTF-CAAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CAAAR FOO) 'I) 'A) (EQUAL FOO '(((I . B) C . D) (E . F) G . H)))) (DO-TEST SHIFTF-CAADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CAADR FOO) 'I) 'E) (EQUAL FOO '(((A . B) C . D) (I . F) G . H)))) (DO-TEST SHIFTF-CADAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CADAR FOO) 'I) 'C) (EQUAL FOO '(((A . B) I . D) (E . F) G . H)))) (DO-TEST SHIFTF-CADDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CADDR FOO) 'I) 'G) (EQUAL FOO '(((A . B) C . D) (E . F) I . H)))) (DO-TEST SHIFTF-CDAAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDAAR FOO) 'I) 'B) (EQUAL FOO '(((A . I) C . D) (E . F) G . H)))) (DO-TEST SHIFTF-CDADR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDADR FOO) 'I) 'F) (EQUAL FOO '(((A . B) C . D) (E . I) G . H)))) (DO-TEST SHIFTF-CDDAR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDDAR FOO) 'I) 'D) (EQUAL FOO '(((A . B) C . I) (E . F) G . H)))) (DO-TEST SHIFTF-CDDDR (AND (SETQ FOO '(((A . B) C . D) (E . F) G . H)) (EQ (SHIFTF (CDDDR FOO) 'I) 'H) (EQUAL FOO '(((A . B) C . D) (E . F) G . I)))) (DO-TEST SHIFTF-CAAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAAAAR FOO) 'Q) 'A) (EQUAL FOO '((((Q . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CAAADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAAADR FOO) 'Q) 'I) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((Q . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CAADAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAADAR FOO) 'Q) 'E) (EQUAL FOO '((((A . B) C . D) (Q . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CAADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CAADDR FOO) 'Q) 'M) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (Q . N) O . P)))) (DO-TEST SHIFTF-CADAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADAAR FOO) 'Q) 'C) (EQUAL FOO '((((A . B) Q . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CADADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADADR FOO) 'Q) 'K) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) Q . L) (M . N) O . P)))) (DO-TEST SHIFTF-CADDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADDAR FOO) 'Q) 'G) (EQUAL FOO '((((A . B) C . D) (E . F) Q . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CADDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CADDDR FOO) 'Q) 'O) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) Q . P)))) (DO-TEST SHIFTF-CDAAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDAAAR FOO) 'Q) 'B) (EQUAL FOO '((((A . Q) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CDADDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDADDR FOO) 'Q) 'N) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . Q) O . P)))) (DO-TEST SHIFTF-CDDAAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDAAR FOO) 'Q) 'D) (EQUAL FOO '((((A . B) C . Q) (E . F) G . H) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CDDADR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDADR FOO) 'Q) 'L) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . Q) (M . N) O . P)))) (DO-TEST PSETF-CDDDAR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDDAR FOO) 'Q) 'H) (EQUAL FOO '((((A . B) C . D) (E . F) G . Q) ((I . J) K . L) (M . N) O . P)))) (DO-TEST SHIFTF-CDDDDR (AND (SETQ FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)) (EQ (SHIFTF (CDDDDR FOO) 'Q) 'P) (EQUAL FOO '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . Q)))) (DO-TEST SHIFTF-FIRST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (FIRST FOO) 'A) 1) (EQUAL FOO '(A 2 3 4 5 6 7 8 9 10)))) (DO-TEST SHIFTF-SECOND (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (SECOND FOO) 'B) 2) (EQUAL FOO '(1 B 3 4 5 6 7 8 9 10)))) (DO-TEST SHIFTF-THIRD (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (THIRD FOO) 'C) 3) (EQUAL FOO '(1 2 C 4 5 6 7 8 9 10)))) (DO-TEST SHIFTF-FOURTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (FOURTH FOO) 'D) 4) (EQUAL FOO '(1 2 3 D 5 6 7 8 9 10)))) (DO-TEST SHIFTF-FIFTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (FIFTH FOO) 'E) 5) (EQUAL FOO '(1 2 3 4 E 6 7 8 9 10)))) (DO-TEST SHIFTF-SIXTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (SIXTH FOO) 'F) 6) (EQUAL FOO '(1 2 3 4 5 F 7 8 9 10)))) (DO-TEST SHIFTF-SEVENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (SEVENTH FOO) 'G) 7) (EQUAL FOO '(1 2 3 4 5 6 G 8 9 10)))) (DO-TEST SHIFTF-EIGHTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (EIGHTH FOO) 'H) 8) (EQUAL FOO '(1 2 3 4 5 6 7 H 9 10)))) (DO-TEST SHIFTF-NINTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (NINTH FOO) 'I) 9) (EQUAL FOO '(1 2 3 4 5 6 7 8 I 10)))) (DO-TEST SHIFTF-TENTH (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (TENTH FOO) 'J) 10) (EQUAL FOO '(1 2 3 4 5 6 7 8 9 J)))) (DO-TEST SHIFTF-REST (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQUAL (SHIFTF (REST FOO) '(A B C D E F G H I J)) '(2 3 4 5 6 7 8 9 10)) (EQUAL FOO '(1 A B C D E F G H I J)))) (DO-TEST SHIFTF-NTH (AND (SETQ FOO '(0 1 2 3 4 5 6 7 8 9 10)) (EQ (SHIFTF (NTH 6 FOO) 'A) 6) (EQUAL FOO '(0 1 2 3 4 5 A 7 8 9 10)))) (DO-TEST SHIFTF-NTHCDR (AND (SETQ FOO '(0 1 2 3 4 5 6 7 8 9 10)) (EQUAL (SHIFTF (NTHCDR 6 FOO) '(A B C D E F G H I J)) '(6 7 8 9 10)) (EQUAL FOO '(0 1 2 3 4 5 A B C D E F G H I J)))) (DO-TEST SHIFTF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (EQ (SHIFTF (AREF FOO 6) 'A) 6) (EQUAL (AREF FOO 6) 'A))) (DO-TEST SHIFTF-SVREF (AND (SETQ FOO (VECTOR 0 1 2 3 4 5 6 7 8 9)) (EQ (SHIFTF (SVREF FOO 6) 'A) 6) (EQUAL (SVREF FOO 6) 'A))) (DO-TEST SHIFTF-GET (AND (SETF (GET 'FOO 'A) 'B) (EQ (SHIFTF (GET 'FOO 'A) 'C) 'B) (EQ (GET 'FOO 'A) 'C))) (DO-TEST SHIFTF-GETF (AND (SETQ FOO '(B C D E F)) (EQ (SHIFTF (GETF FOO 'D) 1) 'E) (EQUAL FOO '(B C D 1 F)))) (DO-TEST SHIFTF-GETHASH (AND (SETQ FOO (MAKE-HASH-TABLE)) (SETF (GETHASH 'A FOO) 'B) (EQ (SHIFTF (GETHASH 'A FOO) 'C) 'B) (EQ (GETHASH 'A FOO) 'C))) (DO-TEST SHIFTF-SYMBOL-FUNCTION (AND (SETF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (A) NIL)) (EQUAL (SHIFTF (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)) '(LAMBDA (A) NIL)) (EQUAL (SYMBOL-FUNCTION 'FOO) '(LAMBDA (B) NIL)))) (DO-TEST SHIFTF-SYMBOL-VALUE (AND (SETF (SYMBOL-VALUE 'FOO) 1) (EQ (SHIFTF (SYMBOL-VALUE 'FOO) 2) 1) (EQ (SYMBOL-VALUE 'FOO) 2))) (DO-TEST SHIFTF-SYMBOL-PLIST (AND (SETF (SYMBOL-PLIST 'FOO) '(A B C D)) (EQUAL (SHIFTF (SYMBOL-PLIST 'FOO) '(E F G H)) '(A B C D)) (EQUAL (SYMBOL-PLIST 'FOO) '(E F G H)))) (DO-TEST SHIFTF-MACRO-FUNCTION (AND (SETQ FOO (GENTEMP "FOO")) (SETF (MACRO-FUNCTION FOO) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (EQUAL (SHIFTF (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))) '(LAMBDA (A) (BQUOTE (CONS (|,| A) (|,| A))))) (EQUAL (MACRO-FUNCTION FOO) '(LAMBDA (B) (BQUOTE (CONS (|,| B) (|,| B))))))) (DO-TEST SHIFTF-CHAR (AND (SETQ FOO "A-STRING") (EQL (SHIFTF (CHAR FOO 0) #\B) #\A) (EQUAL FOO "B-STRING"))) (DO-TEST SHIFTF-SCHAR (AND (SETQ FOO "A-STRING") (EQL (SHIFTF (SCHAR FOO 0) #\B) #\A) (EQUAL FOO "B-STRING"))) (DO-TEST SHIFTF-BIT (AND (SETQ FOO #*01010101) (EQL (SHIFTF (BIT FOO 1) 0) 1) (EQL (BIT FOO 1) 0))) (DO-TEST SHIFTF-SBIT (AND (SETQ FOO #*01010101) (EQL (SHIFTF (SBIT FOO 1) 0) 1) (EQL (SBIT FOO 1) 0))) (DO-TEST SHIFTF-SUBSEQ (AND (SETQ FOO '(1 2 3 4 5 6 7 8 9 10)) (EQUAL (SHIFTF (SUBSEQ FOO 2 4) '(C D)) '(3 4)) (EQUAL FOO '(1 2 C D 5 6 7 8 9 10)))) (DO-TEST SHIFTF-LDB (AND (SETQ FOO 100000) (EQ (SHIFTF (LDB (BYTE 8 0) FOO) 128) 160) (EQ (LDB (BYTE 8 0) FOO) 128))) (DO-TEST PSETF-MASK-FIELD (AND (SETQ FOO 100000) (EQ (SHIFTF (MASK-FIELD (BYTE 8 0) FOO) 128) 160) (EQ (MASK-FIELD (BYTE 8 0) FOO) 128))) (DO-TEST SHIFTF-APPLY-OF-AREF (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(1 2 3 4 5 6 7 8 9 10))) (EQ (SHIFTF (APPLY #'AREF FOO '(1)) FOO) 2) (EQ (AREF FOO 1) FOO))) (DO-TEST PSETF-EVAL-ONCE (AND (SETQ FOO (MAKE-ARRAY 10 :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (SETQ A 4) (EQL (SHIFTF (AREF FOO (INCF A)) 'E) 5) (EQL (AREF FOO 5) 'E)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-3-APPLY.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-3-APPLY.TEST new file mode 100644 index 00000000..c86dcb98 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-3-APPLY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: apply ;; ;; Source: Steele's book Section 7.3: Function Invocation Page: 107 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 5, 1986 ;; ;; Last Update: June 5, 1986 ;; June 16,1986 /sye add test case "test-apply7" to make sure APPLY returns multiple values. ;; Feb 4, 1987 Jim Blum - changed test2 apply cdddr to make it ;; run on the SUN ;; ;; Filed As: {eris}cml>test>7-3-apply.test ;; ;; ;; Syntax: APPLY function arg &rest more-args ;; ;; Function Description: APPLY applies function to a list of arguments. The last argumnet in the argument ;; list has to be a list. ;; ;; Argument(s): function - may be a compiled-code object, a lambda-expression, or a symbol ;; ;; Returns: value returned by applying the function to the arguments ;; (do-test test-apply0 ;; ;; test cases copied from page 107 of CLtL ;; (and (setq f '+) (= (apply f '(1 2)) 3) (setq f #'-) (= (apply f '(1 2)) -1) (= (apply #'max 3 5 '(2 7 3)) 7) (equal (apply 'cons '((+ 2 3) 4)) '((+ 2 3) . 4)) (= (apply #'+ '()) 0))) (do-test test-apply1 ;; ;; test cases copied from page 107 of CLtL ;; (and (equal (apply #'(lambda (&key a b) (list a b)) '(:b 3)) '(nil 3)) ; (defun foo (size &rest keys &key double &allow-other-keys) (let ((v (apply #'make-array size :allow-other-keys t keys))) (if double (concatenate (type-of v) v v) v))) (setq foo-array (foo 4 :initial-contents '(a b c d) :double t)) (= (apply 'array-total-size (list foo-array)) 8) (eq (apply #'aref foo-array '(1)) 'b) (eq (apply 'aref foo-array '(7)) 'd) (eq (apply (function aref) foo-array '(4)) 'a) (eq (apply #'aref foo-array '(6)) 'c))) (do-test test-apply2 (and (= (apply #'cadddr '((0 1 2 3))) 3) (equal (apply 'cons '(foo) '(bar)) '((foo) . bar)) (equal (apply (function list) '(foo) '(bar)) '((foo) bar)) (equal (apply #'append '(foo) '((bar))) '(foo bar)) (equal (apply 'intersection (list 2 4 6 8) (list '(1 3 5 7 8))) '(8)))) (do-test test-apply3 (and (equal (apply #'(lambda (&rest rest &key a b c) (list rest a b c)) '(:b 3 :a 9)) '((:b 3 :a 9) 9 3 nil)) (equal (apply #'(lambda (x) (multiple-value-list (values x (expt x 2) (expt x 3)))) '(2)) '(2 4 8)))) (do-test test-apply4 (equal (apply #'(lambda (x y z) (defun funx (x) (list x x)) (defun funy (y) (list y y y)) (defun funz (z) (list z z z z)) (append (funx x) (funy y) (funz z))) '(2 3 4)) '(2 2 3 3 3 4 4 4 4))) (do-test test-apply5 (progn (defun bar (test bar-sequence &rest keys &key dummy &allow-other-keys) (let ((x (apply #'remove-if test bar-sequence :allow-other-keys t keys))) (list (length x) x))) (and (equal (bar #'oddp '(-2 5 -7 9 10 13 16)) '( 3 (-2 10 16))) (equal (bar #'oddp '(-2 5 -7 9 10 13 16) :start 2) '( 4 (-2 5 10 16))) (equal (bar 'plusp '(-2 5 -7 9 10 13 16) :start 4 :end 6) '( 5 (-2 5 -7 9 16)))))) (do-test test-apply6 ;; ;; --It is illegal for the symbol to be the name of a macro or special form -- ;; (page 107 CLtL) ;; ;; (progn (defmacro mac1 () ''mac1) ;; (defmacro mac2 () '(list 1 2)) ;; (not (or (nlsetq (apply #'mac1 '())) ;; (nlsetq (apply #'mac2 '())) ;; (nlsetq (apply #'quote '(quote))) ;; (nlsetq (apply #'progn '())) ;; ;; setq is defined as a special-form in common lisp ;; ;; (nlsetq (apply 'setq '(foo (1+ 10)))) ;; (nlsetq (apply 'no-such-fun1 '())))))) t) (do-test "test-apply7 make sure APPLY returns multiple values" (and (multiple-value-setq (a b c d) (apply #'values 1.1 2.2 3.3 '(4.4))) (= a 1.1) (= b 2.2) (= c 3.3) (= d 4.4) (multiple-value-bind (a b c d e) (apply #'values-list '((1 2 3 4))) (and (= a 1) (= b 2) (= c 3) (= d 4) (eq e nil))))) ;; ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-3-CALL-ARGUMENTS-LIMIT.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-3-CALL-ARGUMENTS-LIMIT.TEST new file mode 100644 index 00000000..bb4a6369 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-3-CALL-ARGUMENTS-LIMIT.TEST @@ -0,0 +1 @@ +;; Constant To Be Tested: call-arguments-limit ;; ;; Source: Steele's book Section 7.3: Function Invocation Page: 108 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 6,1986 ;; ;; Last Update: June 6,1986 ;; ;; Filed As: {eris}cml>test>7-3-call-arguments-limit.test ;; ;; ;; Syntax: CALL-ARGUMENTS-LIMIT (* note: this is a constant) ;; ;; Function Description: CALL-ARGUMENTS-LIMIT is a positive integer that is the upper exclusive bound on the ;; number of arguments that may be passed to a function. ;; ;; Argument(s): none ;; ;; Returns: a positive integer ;; (do-test "test call-arguments-limit : it is a positive integer and wiil not be smaller than 50" (and (integerp call-arguments-limit) (>= call-arguments-limit 50))) (do-test "test call-arguments-limit : the value of it must be at least as great as that of lambda-parameters-limit" (>= call-arguments-limit lambda-parameters-limit)) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-3-FUNCALL.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-3-FUNCALL.TEST new file mode 100644 index 00000000..8cf341d0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-3-FUNCALL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: funcall ;; ;; Source: Steele's book Section 7.3: Function Invocation Page: 108 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 6,1986 ;; ;; Last Update: June 6,1986 ;; ;; Filed As: {eris}cml>test>7-3-funcall.test ;; ;; ;; Syntax: FUNCALL fn &rest arguments ;; ;; Function Description: FUNCALL applies the fn to the arguments and returns its value. Fn may not be ;; a special form or macro. ;; ;; Argument(s): fn - ;; {argument}* ;; ;; Returns: a value returned by fn ;; (do-test test-funcall0 (setq fc (symbol-function `+)) (= (funcall fc 1 2) 3)) (do-test test-funcall2 (and (equal (funcall 'append '(+ 1 2 3) '(4 5 6)) '(+ 1 2 3 4 5 6)) (equal (funcall #'append `(,(+ 1 2 3)) '(4 5 6)) '(6 4 5 6)))) (do-test test-funcall3 (and (= (multiple-value-setq ( a b c d) (funcall 'values 1 2 3 4)) 1) (= (funcall `+ a b c d) 10) (equal (multiple-value-list (funcall (function values-list) (list #\p #\l #\m))) '(#\p #\l #\m)))) (do-test test-funcall4 (progn (set 'funlist '()) (push (function (lambda (x y) (+ x y))) funlist) (push (function (lambda (x y) (* x y))) funlist) (push (function (lambda (x y) (gcd x y))) funlist) (defun fun (m n o p) (funcall (case n ((1) (car m)) ((2) (cadr m)) ((3) (caddr m))) o p)) (and (= (fun funlist 1 3 9) 3) (= (fun funlist 2 100 100) 10000) (= (fun funlist 3 100 (sqrt 4)) 102) (= (fun funlist 2 (expt #3r10 2) (/ 8 2)) 36)))) (do-test test-funcall5 (and (funcall '> 10000.001 +10000.00009 9999.999 9998.999 -9998.9999) (funcall #'(lambda (x1 x2 x3 x4 x5 x6) (and x1 x2 x3 x4 x5 x6)) 'e 8 30 t 'null 'nill) (every #'(lambda (x) (funcall 'null x)) (list nil '() (intersection '(2 4) '(1 3)) (set-difference '(2 4) '(2 4)))) (funcall #'(lambda (x y z) (every #'(lambda (a b c) (eq c (+ a b))) x y z)) '(1 3 5) '(2 4 6) '(3 7 11)))) (do-test test-funcall6 ;; ;; --It is illegal for the fn to be the name of a macro or special form -- ;; (page 108 CLtL) ;; ;; (progn (defmacro mac1 () ''mac1) ;; (defmacro mac2 () '(list 1 2)) ;; (not (or (nlsetq (funcall #'mac1 nil)) ;; (nlsetq (funcall #'mac2 nil)) ;; (nlsetq (funcall #'quote 'quote)) ;; (nlsetq (funcall #'progn nil)) ;; ;; setq is defined as a special-form in common lisp ;; ;; (nlsetq (funcall 'setq '(foo (1+ 10)))) ;; (nlsetq (funcall 'no-such-fun1 nil)))))) t) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG1.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG1.TEST new file mode 100644 index 00000000..455fb2b3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog1 ;; ;; Source: Steele's book Section 7.4: simple sequencing Page: 109 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 29, 1986 ;; ;; Last Update: May 29, 1986 ;; ;; Filed As: {eris}cml>test>7-4-prog1.test ;; ;; ;; Syntax: PROG1 first {form}* ;; ;; Function Description: PROG1 takes a number of forms and evaluates them sequentially. It discards the results ;; of all forms but the first one and returns the value of the first form. ;; ;; Argument(s): {form}* - a sequence of forms ;; ;; Returns: value of the first form ;; (do-test test-prog10 (and (equal (prog1 (cdr (setq a '(o p q r))) (rplacd a '(8 9))) '(p q r)) (equal (prog1 (setq a '( o p q r s t)) (setq a (union a (cons 'w ())))) '(o p q r s t)) (eq (prog1 (setq a #\s) (characterp a) (makunbound 'a)) #\s) (string-equal (string (prog1 (defun fun () 'fun) (equal (fun) 'fun) (fmakunbound 'fun))) "fun") (eq (prog1 () (cons 1 2)) nil))) (do-test test-prog11 ;; ;; - prog1 always returns a single value, even if the first form tries to return multiple values. - p109 ;; (and (eq (prog1 (values 1 2 3)) 1) (eq (prog1 (values-list (list (setq a (evenp (+ 2 #2r1010))) (setq b (string 'p)))) (equal a b)) t))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG2.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG2.TEST new file mode 100644 index 00000000..fc6e1f1c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG2.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog2 ;; ;; Source: Steele's book Section 7.4: simple sequencing Page: 109 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 29, 1986 ;; ;; Last Update: May 29, 1986 ;; ;; Filed As: {eris}cml>test>7-4-prog2.test ;; ;; ;; Syntax: PROG2 first second {form}* ;; ;; Function Description: PROG2 takes a number of forms and evaluates them sequentially. It discards the results ;; of all forms but the second one and returns the value of the second form. ;; ;; Argument(s): first - first form ;; second - second form ;; {form}* - the rest of forms ;; ;; Returns: value of the second form ;; (do-test test-prog20 (and (eq (prog2 1 2 3 4 5 6) 2) (eq (prog2 (defmacro mac (x) `(gcd ,x 20 30)) (mac 10) (mac 40)) 10) (eq (prog2 (defun fun (x) (nth x '(foo bar gack tank bush moon fish))) (fun 2) (fun 5) (fun 0)) 'gack) (eq (prog2 (rplaca (setq x '((a . b) c d (e. f))) 'foo) (car (rplaca x 'fish)) (car (rplaca x 'ham)) (list x)) `fish))) (do-test test-prog21 ;; ;; - prog2 always returns a single value, even if the second form tries to return multiple values. - p110 ;; (and (eq (prog2 nil (values 2 4 6 8)) 2) (eq (prog2 (defmacro mac (x) `(values-list (list ,x 'p 'q))) (mac 'a) (mac 'w) (mac 'o)) 'a) (eq (prog2 (defun fun () (values (signum 10) (signum -9) (max 2 2.0 1.9999999 2.000009))) (fun) (fmakunbound 'fun)) 1))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-4-PROGN.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROGN.TEST new file mode 100644 index 00000000..96e92f36 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROGN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: progn ;; ;; Source: Steele's book Section 7.4: simple sequencing Page: 109 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 29, 1986 ;; ;; Last Update: May 29, 1986 ;; ;; Filed As: {eris}cml>test>7-4-progn.test ;; ;; ;; Syntax: PROGN {form}* ;; ;; Function Description: PROGN takes a number of forms and evaluates them sequentially. It discards the results ;; of all forms but the last one and returns the value(s) of the last form. ;; ;; Argument(s): {form}* - a sequence of forms ;; ;; Returns: nil - if there are no forms ;; value(s) of the last form - otherwise ;; ;; (do-test test-progn0 ;; ;; if there are no forms in progn, be sure it returns nil ;; (eq nil (progn))) (do-test test-progn1 (and (eq (progn 1 2 3 4 ) 4) (eq (progn 'a 'b 'c 'd 'e 'f 'g 'x 'z 'y) 'y) (equal (progn "simple-string") "simple-string") (equal (progn (setq x (+ 3 3 4)) (setq y (- 10 2 3)) (setq z (1+ (* 5 2 1))) (max x y z)) 11) (equal (progn (setq m 10) (multiple-value-setq (a b c) (values (incf m 100) (decf m 50) (gcd 7 21 28))) (list a b c)) '(110 60 7)))) (do-test test-progn2 ;; ;; check if progn returns multiple values ;; (and (equal (multiple-value-list (progn (values 10 20 30))) '(10 20 30)) (equal (multiple-value-list (progn (setq a :bar) (setq b :foo) (values-list (list a b)))) '(:bar :foo)))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-COMPILER-LET.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-COMPILER-LET.TEST new file mode 100644 index 00000000..0cba7a15 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-COMPILER-LET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: compiler-let ;; ;; Source: CLtL p. 112 ;; Chapter 7: Control Structure Section 5: Establishing new variable bindings ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov 2, 86 ;; ;; Last Update: Nov 2, 86 ;; ;; Filed As: {eris}cml>test> 7-5-compiler-let.test ;; ;; ;; Syntax: compiler-let ( {VAR | (VAR VALUE )}*) {FORM}* ;; ;; Function Description: When executed by the Lisp interpreter, compiler-let behaves exactly like let with all the variable ;; bindings implicitly declared special. When the compiler processes this form, however, no code is compiled ;; for the bindings; instead, the processing of the body by the compiler is done with the special variables ;; bound to the indicated values in the execution context of the compiler. ;; ;; Argument(s): var - a variable ;; value - a lisp form ;; form - a lisp form ;; ;; Returns: anything ;; (do-test "test compiler-let - when executed by the interpreter 0" (eval-when (eval) (equal (compiler-let ((a 1) (b 2) (c 3 ) (d 4)) (list a b c d) ) '(1 2 3 4) ))) (do-test "test compiler-let - when executed by the interpreter 1" (eval-when (eval) (compiler-let ((a 1) (b 2) (c 3 ) (d 4) buf) (let ((a 11) (b 22) (c 33 ) (d 44)) (set 'b -2) (set 'd -4) (push (list (locally (declare (special a)) a) (locally (declare (special b)) b) (locally (declare (special c)) c) (locally (declare (special d)) d) ) buf) (push (list a b c d) buf)) (push (list a b c d) buf) (equal buf '( (1 -2 3 -4) (11 22 33 44) (1 -2 3 -4) ) ) ) ) ) (do-test-group ( "test compiler-let - when executed by the interpreter 2" :before (progn (test-defun foo (x y) (progv '(a b) (list x y) (compiler-let ((a (* 2 b)) (b (+ a 4)) (c (- a b)) ) (foo1 a c) ) )) (test-defun foo1 (a1 c1) (declare (special b)) (if (evenp b) (+ a1 c1) (- a1 c1))) )) (do-test "test compiler-let - when executed by the interpreter 2" (eval-when (eval) (and (= (foo 20 1) 21) (= (foo -7 8) 31) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-FLET.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-FLET.TEST new file mode 100644 index 00000000..bbbdca3d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-FLET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: flet ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 113 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 25 ,1986 ;; ;; Last Update: Oct. 25 ,1986 ;; ;; Filed As: {eris}cml>test>7-5-flet.test ;; ;; ;; Syntax: flet ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}* ;; ;; Function Description: flet may be used to define locally named functions. Within the body of the flet form, function names ;; matching those defined by the flet refer to the locally defined functions rather than to the global ;; function definitions of the same name. Any number of functions may be simultaneously defined. ;; Each definition is similar in format to a defun form. Using flet one can locally redefine a global function ;; name, and the new definition can refer to the global definition. ;; ;; Argument(s): NAME - a function name ;; LAMBDA-LIST - ;; DECLARATION - ;; DOC-STRING - a string ;; FORM - ;; ;; Returns: anything ;; (do-test "test flet - test case copied from page 113 of CLtL" (flet ((safesqrt (x) (sqrt (abs x)) )) ;; ;; The safesqrt function is used in two places ;; (let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) ) (and (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist1))) (sqrt 30)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist2))) (sqrt 118)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist3))) (sqrt 16.5)) ) ) ) ) (do-test "test flet - with empty flet bodies" (and (eq (flet ()) nil) (eq (flet ( (fun1 () "this is an empty function") ) ) nil) (eq (flet ( (fun1 (m n) (declare (integer m)) "m is declared to be an integer" (declare (special n)) "n is a special variable" ) ) ) nil) ) ) (do-test "test flet - with declare statements / parameter list keywords" (and (eq (flet () t) t) (equal (flet ( (let1 () (values 10 20 30 40)) (let2 () (values "a" "b" "c" "d" "e")) (let3 () (values-list '(writing code for flet))) ) (multiple-value-call #'list (let1) (let2) (let3)) ) '(10 20 30 40 "a" "b" "c" "d" "e" writing code for flet) ) (equalp (flet ( (fun1 (m n) (declare (integer m n)) (+ m n)) (fun2 (m n ) (declare (string m n)) (concatenate 'string m n)) (fun3 (m n o p) (declare (type (integer 2 10) m n o p)) (max m n o p)) (fun4 (s) (declare (complex s)) (type-of s)) (fun5 (s r) (declare (number s r)) (vector (gcd s r) (lcm s r))) ) (list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) ) (list 59 "ace" 7 'complex (vector 1 2300)) ) (equal (flet ( (fun1 (m n &key o p) (list m n o p)) (fun2 (m n &optional (o 2 oflag) (p 30 pflag)) (list m n o p oflag pflag)) (fun3 (m n &rest x &key (y 6) (z 7 zflag)) (list m n x y z zflag)) ) (list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) ) '( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) ) ) ) (do-test-group ( "more tests for flet" :before (progn (test-defun fun1 () 1) (test-defun fun2 () 2) (test-defun fun3 () 3) (test-defun fun4 () 4) )) (do-test "test flet - locally defined functions overshadow the global functions of the same names" (equal (list (fun1) (fun2) (fun3) (flet ((fun1 () 10) (fun2 () 20) (fun3 () 30)) (list (fun1) (fun2) (fun3) (fun4)) ) (fun1) (fun2) (fun3) (fun4) ) '(1 2 3 ( 10 20 30 4) 1 2 3 4)) ) (do-test "test flet - one can locally redefine a global function and the new definition can refer to the global definition" (equal (flet ((fun1 () (+ (fun1) (fun2) (fun3))) (fun2 () (* (fun1) (fun3))) (fun3 () (+ (fun2) (fun4))) ) (list (fun1) (fun2) (fun3)) ) '(6 3 6)) ) ) (do-test "test flet - make sure those named functions are defined locally" (progn (dolist (x '(fun1 fun2 fun3)) (fmakunbound x)) (flet ((fun1 () 1) (fun2 () 2) (fun3 () 3)) (list (fun1) (fun2) (fun3)) ) (notany #'fboundp '(fun1 fun2 fun3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-LABELS.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-LABELS.TEST new file mode 100644 index 00000000..0d97e0f9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-LABELS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: labels ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 113 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 26 ,1986 ;; ;; Last Update: Feb 4, 1987 Jim Blum - removed empty body test, and changed (declare (integer 0 *) n) ;; to (declare (type (integer 0 *) n)) ;; ;; Filed As: {eris}cml>test>7-5-labels.test ;; ;; ;; Syntax: labels ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}* ;; ;; Function Description: labels may be used to define locally named functions. Within the body of the labels form, function names ;; matching those defined by the labels refer to the locally defined functions rather than to the global ;; function definitions of the same name. Any number of functions may be simultaneously defined. ;; Each definition is similar in format to a defun form. The scope of the defined function names encompasses ;; both the body and the function definitions. That is, labels can be used to define mutually recursive ;; functions. ;; ;; Argument(s): NAME - a function name ;; LAMBDA-LIST - ;; DECLARATION - ;; DOC-STRING - a string ;; FORM - ;; ;; Returns: anything ;; (do-test "test labels - test case copied from page 113 of CLtL (flet was replaced by labels)" (labels ((safesqrt (x) (sqrt (abs x)) )) ;; ;; The safesqrt function is used in two places ;; (let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) ) (and (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist1))) (sqrt 30)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist2))) (sqrt 118)) (= (safesqrt (apply #'+ (map 'list #'safesqrt longlist3))) (sqrt 16.5)) ) ) ) ) (do-test-group ( "test labels - test case copied from page 113 of CLtL" :before (test-defun integer-power (n k) ; a highly "bummed" integer (declare (integer n)) ; exponentiation routine. (declare (type (integer 0 *) k )) (labels ((expt0 (x k a) (declare (integer x a) (type (integer 0 *) k )) (cond ((zerop k) a) ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a))))) (expt1 (x k a) (declare (integer x a) (type (integer 1 *) k )) (cond ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a)))))) (expt0 n k 1) ) ) ) (do-test "test labels - test case copied from page 113 of CLtL" (equal (mapcar #'integer-power '(100 9 8 7 6 5 4 3 2 -4 -6 -7 -9) '( 0 2 2 3 1 4 5 2 1 3 3 2 1)) '(1 81 64 343 6 625 1024 9 2 -64 -216 49 -9) ) ) ) (do-test "test labels - with declare statements / parameter list keywords" (and (eq (labels () t) t) (equal (labels ( (let1 () (values 10 20 30 40)) (let2 () (values "a" "b" "c" "d" "e")) (let3 () (values-list '(writing code for labels))) ) (multiple-value-call #'list (let1) (let2) (let3)) ) '(10 20 30 40 "a" "b" "c" "d" "e" writing code for labels) ) (equalp (labels ( (fun1 (m n) (declare (integer m n)) (+ m n)) (fun2 (m n ) (declare (string m n)) (concatenate 'string m n)) (fun3 (m n o p) (declare (type (integer 2 10) m n o p)) (max m n o p)) (fun4 (s) (declare (complex s)) (type-of s)) (fun5 (s r) (declare (number s r)) (vector (gcd s r) (lcm s r))) ) (list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) ) (list 59 "ace" 7 'complex (vector 1 2300)) ) (equal (labels ( (fun1 (m n &key o p) (list m n o p)) (fun2 (m n &optional (o 2 oflag) (p 30 pflag)) (list m n o p oflag pflag)) (fun3 (m n &rest x &key (y 6) (z 7 zflag)) (list m n x y z zflag)) ) (list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) ) '( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) ) ) ) (do-test-group ( "more tests for labels" :before (progn (test-defun fun1 () 1) (test-defun fun2 () 2) (test-defun fun3 () 3) (test-defun fun4 () 4) (test-setq buf '(results ) )) ) (do-test "test labels - locally defined functions overshadow the global functions of the same names" (equal (list (fun1) (fun2) (fun3) (labels ((fun1 () 10) (fun2 () 20) (fun3 () 30)) (list (fun1) (fun2) (fun3) (fun4)) ) (fun1) (fun2) (fun3) (fun4) ) '(1 2 3 ( 10 20 30 4) 1 2 3 4)) ) (do-test "test labels - the scope of the defined function names for labels encompasses the function definitions" (and (equal (labels ((fun1 () (+ (fun2) (fun3))) (fun2 () 20) (fun3 () (+ (fun2) (fun4))) ) (list (fun1) (fun2) (fun3)) ) '(44 20 24)) (equal (labels ((fun (n) (declare (type (integer 0 *) n)) (cond ( (zerop n) 1) ( t (* n (fun (1- n)))) ) )) (map 'list #'fun '(10 8 6 4 2 0 1 3 5)) ) '(3628800 40320 720 24 2 1 1 6 120)) (equal (block done (labels (;; ;; buf was initialized in :before section ;; (next-index-type (x y) (declare (list x) (atom y)) (nconc buf (list (search x input :test #'equal ) y)) (typecase (second x) ( null (return-from done buf)) ( list (lst (cdr x)) ) ( string (str (cdr x)) ) ( number (num (cdr x)) ) ( t (other (cdr x)) ) )) (num (x) (declare (list x)) (next-index-type x 'number)) (lst (x) (declare (list x)) (next-index-type x 'list)) (str (x) (declare (list x)) (next-index-type x 'string)) (other (x) (declare (list x)) (next-index-type x 'other))) ( num (setq input '(4 "st" (3) #\a 4/5 (4 . 5) "labels") ) ) )) '(results 0 number 1 string 2 list 3 other 4 number 5 list 6 string)) ) ) ) (do-test "test labels - make sure those named functions are defined locally" (progn (dolist (x '(fun1 fun2 fun3)) (fmakunbound x)) (labels ((fun1 () 1) (fun2 () 2) (fun3 () 3)) (list (fun1) (fun2) (fun3)) ) (notany #'fboundp '(fun1 fun2 fun3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-LET.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-LET.TEST new file mode 100644 index 00000000..9c7249d5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-LET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: let ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 110 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 9 ,1986 ;; ;; Last Update: Oct. 9 ,1986 ;; ;; Filed As: {eris}cml>test>7-5-let.test ;; ;; ;; Syntax: let ( {VAR | (VAR VALUE)}*) {DECLARATION}* {FORM}* ;; ;; Function Description: A let form can be used to execute a series of forms with specified variables bound to specified values. ;; All of the variables VARs are bound to the corresponding values in parallel; each binding will be a ;; lexical binding unless there is a special declaration to the contrary. The expressions FORMs are then ;; evaluated in order; the values of all but the last are discarded. ;; ;; Argument(s): VAR - a variable ;; VALUE - a valid lisp form ;; DECLARATION - ;; FORM - ;; ;; Returns: anythihng ;; (do-test-group (test-let-group :before (progn (test-setq a 2 b 20 c 4 d -12 e 30 buf '()))) (do-test "test let 0" (and (eq (let ()) nil) (= (let () 100) 100) (eq (let (a b c d)) nil) (= (let (a b c d) (realpart #c(1 2))) 1) (equal (multiple-value-list (let () (values 1 2 3 4))) '(1 2 3 4)) ) ) (do-test "test let - variables are bound in parallel" (and (equal (let ( (a 10) (b (1+ a)) (c (1- b))) (list a b c)) '(10 3 19)) (equal (let ( (e (+ a b)) (d (+ e a)) (c (- e d)) (b (+ e d c))) (list e d c b)) '(22 32 42 22)) ) ) (do-test "test let - the expressions (forms) are evaluated in order ; the value(s) of the last form are returned" (and (equal (let () (push a buf) (push b buf) (push c buf) (push d buf)) '( -12 4 20 2)) (equal buf '(-12 4 20 2)) (equal (let ((a 20) (b 30)) (setq a (* 3 a)) (setq b (* -2 b)) (decf a) (incf b) (list b a)) '(-59 59)) (equal (let (x) (setq x (concatenate 'string "abcdefg")) (setq x (concatenate 'string x '(#\q #\w #\e #\r #\t))) (setq x (concatenate 'string x "zxcvbn")) x) "abcdefgqwertzxcvbn") ) ) (do-test "test let - include declaration statement(s)" (and (equal (let ((x 0) (y 0) (u "") (w "a")) (declare (fixnum x y) (simple-string u w)) (setq x (1+ x)) (setq y (lcm (+ 2 y) (+ 11 y))) (setq u (concatenate 'string u w "za")) (setq w (concatenate 'string w u w)) (list w u y x)) '("aazaa" "aza" 22 1)) (equalp (let ((a #*1010111000) (b (vector #\t #\e #\s #\t #\s)) (c nil) (d 20)) (declare (number d) (list c) (sequence b) (simple-bit-vector a)) (setq a (subseq a 4)) (setq b (concatenate 'string (subseq b 1 4))) (setq c (cons "a" (cons "b" (cons "c" c)))) ; (setq d (+ #c(1 2) #c( -2 -1) )) (list a b c )) '( #*111000 "est" ("a" "b" "c") )) ) ) (do-test "test let - the body of a let form is an implicit progn; it returns multiple values" (and (equal (multiple-value-list (let ((a 1) (b 2) (c 3) (d 4) e f) (values a b c d e f))) '(1 2 3 4 nil nil)) (equal (multiple-value-list (let (a b c d e f) (multiple-value-bind (a c e) (values 11 22 33) (values f e d c b a)))) '(nil 33 nil 22 nil 11)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-LETSTAR.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-LETSTAR.TEST new file mode 100644 index 00000000..9a9d42bc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-LETSTAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: let* ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 110 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 10 ,1986 ;; ;; Last Update: Oct. 10 ,1986 ;; ;; Filed As: {eris}cml>test>7-5-let*.test ;; ;; ;; Syntax: let* ( {VAR | (VAR VALUE)}*) {DECLARATION}* {FORM}* ;; ;; Function Description: A let* form can be used to execute a series of forms with specified variables bound to specified values. ;; All of the variables VARs are bound to the corresponding values sequentially ; each binding will be a ;; lexical binding unless there is a special declaration to the contrary. The expressions FORMs are then ;; evaluated in order; the values of all but the last are discarded. ;; ;; Argument(s): VAR - a variable ;; VALUE - a valid lisp form ;; DECLARATION - ;; FORM - ;; ;; Returns: anythihng ;; (do-test-group (test-let*-group :before (progn (test-setq a 2 b 20 c 4 d -12 e 30 buf '()))) (do-test "test let* 0" (and (eq (let* ()) nil) (= (let* () 100) 100) (eq (let* (a b c d)) nil) (= (let* (a b c d) (imagpart #c(1 2))) 2) (equal (multiple-value-list (let* () (values 1 2 3 4))) '(1 2 3 4)) ) ) (do-test "test let* - variables are bound sequentially" (and (equal (let* ( (a 10) (b (1+ a)) (c (- b 2))) (list a b c)) '(10 11 9)) (equal (let* ( (e (+ a b)) (d (+ e a)) (c (- e d)) (b (+ e d c))) (list e d c b)) '(22 24 -2 44)) ) ) (do-test "test let* - the expressions (forms) are evaluated in order ; the value(s) of the last form are returned" (and (equal (let* () (push a buf) (push b buf) (push c buf) (push d buf)) '( -12 4 20 2)) (equal buf '(-12 4 20 2)) (equal (let* ((a 20) (b 30)) (setq a (* 3 a)) (setq b (* -2 b)) (decf a) (incf b) (list b a)) '(-59 59)) (equal (let* (x) (setq x (concatenate 'string "abcdefg")) (setq x (concatenate 'string x '(#\q #\w #\e #\r #\t))) (setq x (concatenate 'string x "zxcvbn")) x) "abcdefgqwertzxcvbn") ) ) (do-test "test let* - include declaration statement(s)" (and (equal (let* ((x 0) (y 0) (u "") (w "a")) (declare (fixnum x y) (simple-string u w)) (setq x (1+ x)) (setq y (lcm (+ 2 y) (+ 11 y))) (setq u (concatenate 'string u w "za")) (setq w (concatenate 'string w u w)) (list w u y x)) '("aazaa" "aza" 22 1)) (equalp (let* ((a #*1010111000) (b (vector #\t #\e #\s #\t #\s)) (c nil) (d 20)) (declare (number d) (list c) (sequence b) (simple-bit-vector a)) (setq a (subseq a 4)) (setq b (concatenate 'string (subseq b 1 4))) (setq c (cons "a" (cons "b" (cons "c" c)))) ;; (setq d (+ #c(1 2) #c( -2 -1) )) (list a b c )) '( #*111000 "est" ("a" "b" "c"))) ) ) (do-test "test let* - the body of a let* form is an implicit progn; it returns multiple values" (and (equal (multiple-value-list (let* ((a 1) (b 2) (c 3) (d 4) e f) (values a b c d e f))) '(1 2 3 4 nil nil)) (equal (multiple-value-list (let* (a b c d e f) (multiple-value-bind (a c e) (values 11 22 33) (values f e d c b a)))) '(nil 33 nil 22 nil 11)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-MACROLET.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-MACROLET.TEST new file mode 100644 index 00000000..b3fb6180 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-MACROLET.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: macrolet ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 113 ;; ;; Created By: Pavel , Karin M. Sye ;; ;; Creation Date: May 30 ,1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - changed (special *foo*) to ;; (declare (special *foo*)) ;; Feb 4, 1987 Jim Blum - Added #+Xerox before first test, since it is Xerox specific ;; ;; Filed As: {eris}cml>test>7-5-macrolet.test ;; ;; ;; Syntax: macrolet ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}* ;; ;; Function Description: macrolet may be used to define locally named macros. Within the body of the macrolet form, macro names ;; matching those defined by the macrolet refer to the locally defined macros rather than to the global ;; macro definitions of the same name. Each definition is similar in format to a defmacro form. ;; Lexically scoped entities are not visible within the expansion functions. However, they are visible within ;; the body of the macrolet form and are visible to the code that is the expansion of a macro call. ;; ;; Argument(s): NAME - a macro name ;; LAMBDA-LIST - ;; DECLARATION - ;; DOC-STRING - a string ;; FORM - ;; ;; Returns: anything ;; ;; ;;; Test cases for macrolet, constantp, and other lexical macro facilities. ;;; ;;; Pavel, May 30, 1986 #+Xerox (do-test lexical-macros-and-constantp (macrolet ((foo (x) `(get ,x 'foo)) (bar (x &environment env) (if (macro-function x env) 7 ; A constant expression '(baz) ; A non-constant expression )) (my-constantp (x &environment env) `(constantp ,x ',env)) ) (my-constantp (bar foo)) ) ) (do-test lexical-macros-for-declarations (macrolet ((special (&rest x) `(declare (special ,@x)))) (macrolet ((test (x) (declare (special *foo*)) `(eql ,x ,x))) (macrolet ((special (&rest y) `(this-is-an-undefined-function ,@y))) (test 7) ) ) ) ) (do-test "test macrolet - test case copied from page 113 of CLtL (flet was replaced by macrolet)" (macrolet ((safesqrt (x) `(sqrt (abs ,x)) )) ;; ;; The safesqrt function is used in two places ;; (let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) ) (and (= (safesqrt (apply #'+ (map 'list #'(lambda (x) (safesqrt x)) longlist1))) (sqrt 30)) (= (safesqrt (apply #'+ (map 'list #'(lambda (x) (safesqrt x)) longlist2))) (sqrt 118)) (= (safesqrt (apply #'+ (map 'list #'(lambda (x) (safesqrt x)) longlist3))) (sqrt 16.5)) ) ) ) ) (do-test-group ( "test macrolet - test case copied from page 114 of CLtL" :before (test-defun foo1 (x flag) (macrolet ((fudge (z) ; The parameters x and flag are not accessible ; at this point. `(if flag (* ,z ,z) ,z) )) ; The parameters x and flag are accessible here (+ x (fudge x) (fudge (+ x 1))) ))) (do-test "test macrolet - test case copied from page 114 of CLtL" (and (= (foo1 2 t) 15) (= (foo1 2 nil) 7) (= (foo1 (1+ 5) t) 91) (= (foo1 (+ 1 5) nil) 19) ) ) ) (do-test "test macrolet - with empty macrolet body" (and (eq (macrolet ()) nil) (eq (macrolet ( (fun1 () "this is an empty function") ) ) nil) (eq (macrolet ( (fun1 (m n) (declare (integer m)) "m is declared to be an integer" (declare (special n)) "n is a special variable" ) ) ) nil) ) ) (do-test "test macrolet - with declare statements/parameter list keywords" (and (eq (macrolet () t) t) (equal (multiple-value-list (macrolet ( (let1 () `(values 10 20 30 40)) (let2 () `(values "a" "b" "c" "d" "e")) (let3 () `(values-list '(writing code for macrolet))) ) (values (let1) (let2) (let3)) )) '(10 "a" writing ) ) (equalp (macrolet ( (fun1 (m n) (declare (integer m n)) `(+ ,m ,n)) (fun2 (m n ) (declare (string m n)) `(concatenate 'string ,m ,n)) (fun3 (m n o p) (declare (type (integer 2 10) m n o p)) `(max ,m ,n ,o ,p)) (fun4 (s) (declare (complex s)) `(type-of ,s)) (fun5 (s r) (declare (number s r)) `(vector (gcd ,s ,r) (lcm ,s ,r))) ) (list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) ) (list 59 "ace" 7 'complex (vector 1 2300)) ) (equal (macrolet ( (fun1 (m n &key o p) `'(,m ,n ,o ,p)) (fun2 (m n &optional (o 2 oflag) (p 30 pflag)) `'(,m ,n ,o ,p ,oflag ,pflag)) (fun3 (m n &rest x &key (y 6) (z 7 zflag)) `'( ,m ,n ,x ,y ,z ,zflag)) ) (list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) ) '( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) ) ) ) (do-test-group ("more tests for macrolet" :before (progn (defmacro fun1 () 1) (defmacro fun2 () 2) (defmacro fun3 () 3) (defmacro fun4 () 4) )) (do-test "test macrolet - locally defined functions overshadow the global functions of the same names" (equal (list (fun1) (fun2) (fun3) (macrolet ( (fun1 () 10) (fun2 () 20) (fun3 () 30)) (list (fun1) (fun2) (fun3) (fun4)) ) (fun1) (fun2) (fun3) (fun4) ) '(1 2 3 ( 10 20 30 4) 1 2 3 4)) ) (do-test "test macrolet - one can locally redefine a global function and the new definition can refer to the global definition" (equal (macrolet ( (fun1 () (+ (fun1) (fun2) (fun3))) (fun2 () (* (fun1) (fun3))) (fun3 () (+ (fun2) (fun4))) ) (list (fun1) (fun2) (fun3)) ) '(6 3 6)) ) ) (do-test "test macrolet - using macro to define special declaration" (let (buf) (macrolet ((special1 (&rest x) `(declare (special ,@x)) )) ;; set only works on special variables (prog ((a 2) (b 4) (c 8)) (set 'a 22) (set 'b 44) (set 'c 88) (push a buf) (push b buf) (push c buf) ) (prog ((a 2) (b 4) (c 8)) (special1 a b c) (set 'a 22) (set 'b 44) (set 'c 88) (push a buf) (push b buf) (push c buf) )) (equal buf '(88 44 22 8 4 2)) ) ) (do-test-group ("test macro - lexically scoped entities are not visible within the expansion functions" :before (progn (test-setq num 100) (test-setq varlist '(10 8 12)) (test-defun lisper (num) (let ((var (pop varlist))) (macrolet ((mac1 (item) ;; the parameter num is not accessible at this point; ;; a reference to num would be to the global variable. (cond ((plusp num) `(list "global num is > 0" (format nil "local num is ~A" num) (* ,item ,item ,item))) ((zerop num) `(list "global num is = 0" (format nil "local num is ~A" num) (- 100 ,item ))) (t `(list "global num is < 0" (format nil "local num is ~A" num) (expt ,item 2)))) )) ;; The parameter num is accessible from here (list var (mac1 var)) ))) )) (do-test "test macro - lexically scoped entities are not visible within the expansion functions" ;; global variable num was defined in :before section (and (equal (lisper -4) '(10 ("global num is > 0" "local num is -4" 1000))) (equal (progn (set 'num 0) (lisper 30)) '(8 ("global num is = 0" "local num is 30" 92))) (equal (progn (set 'num -9) (lisper 0)) '(12 ("global num is < 0" "local num is 0" 144))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-5-PROGV.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-5-PROGV.TEST new file mode 100644 index 00000000..9113ff90 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-PROGV.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: progv ;; ;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 112 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 27 ,1986 ;; ;; Last Update: Oct. 27 ,1986 ;; ;; Filed As: {eris}cml>test>7-5-progv.test ;; ;; ;; Syntax: progv SYMBOLS VALUES {FORM}* ;; ;; Function Description: progv allows binding one or more dynamic variables whose names may be determined at run time. ;; The sequences of forms (an implicit progn) is evaluated with the dynamic variables whose names are ;; in the list SYMBOLS bound to corresponding values from the list VALUES. The results of the progv form ;; are those of the last form. ;; ;; Argument(s): SYMBOLS - a form which returns a list of symbols after being computed ;; VALUES - a form which returns a list of values after being computed ;; FORM - ;; ;; Returns: anything ;; (do-test "test progv - the body of progv is an implicit progn" (and (not (progv '() '())) (progv '(a b) '(#\a #\b) (every #'characterp (list a b))) (equal (multiple-value-list (progv '(aa bb cc) (list 1 -1 2) (values aa bb cc))) '(1 -1 2)) ) ) (do-test "test progv - if too many values are supplied, the excess values are ignored" (and (equal (progv (list 'a 'b 'c 'd) (list 11 22 33 44 55) (list d b c a)) '(44 22 33 11)) (equal (progv '(x y) '(1 2 3 4 5 6) (list x y)) '(1 2)) ) ) (do-test "test progv - if too few values are supplied, the remaining symbols are bound and then made to have no value" (and (progv '(a b c d) '(10 20) (and (equal (list a b) '(10 20)) (notany #'boundp '(c d)) ) ) (progv '(aa bb cc dd ee ff gg) '() (notany #'boundp '(aa bb cc dd ee ff gg)) ) ) ) (do-test-group ("test progv - progv allows bindings for dynamic variables" :before (progn (test-defun pro1 () (declare (special w x y z)) (set 'w (concatenate 'string w "ce")) (cons (pro2) w)) (test-defun pro2 () (declare (special w x y z)) (set 'y (concatenate 'string y "ell")) (list x y z)) )) (do-test "test progv - progv allows bindings for dynamic variables" (and (progv '(m n o p) '(9 8 7 6) (set 'm 99) (set 'o 70) (equal (list m n o p) '(99 8 70 6)) ) (progv '(w x y z) '("a" "b" "c" "d") (equal (pro1) '(("b" "cell" "d") . "ace")) ) (let ((w 10) (x 20) (y 30) (z 40)) (declare (special w x y z)) (and (progv '(w x y z) '("a" "b" "c" "d") (equal (pro1) '(("b" "cell" "d") . "ace")) ) ;; ;; the bindings of the dynamic variables are undone on exit from the progv form ;; (equal (list w x y z) '(10 20 30 40)) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-6-CASE.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-6-CASE.TEST new file mode 100644 index 00000000..143034d0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-CASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: case ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 117 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 13,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ broke into smaller tests. ;; ;; Filed As: {ERIS}CML>TEST>7-6-CASE.TEST ;; ;; ;; Syntax: (case keyform {({({key}*)|key}{form}*)}*) ;; ;; ;; Function Description: ;; The form keyform is evaluated to produce the key object. ;; The key is matched against each clause to see if the key is ;; in the keylist. The forms of that cluase are evaluated, and ;; case returns what was returned from the last consequent (or ;; nil if there are none for that clause. ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; KEY - a list of one or more keys. ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "Do some simple tests" (and ; Does case evaluate and return the appropriate things? (case T (T T)) ; catch everthing (case T (nil nil) (T T)) ; catch everthing (case T (nil nil) (nil nil) (T T)) ; catch everthing (eq (case T (nil T)) nil) (eq (case T (T nil)) nil) ; catch everthing (eq (case T (T)) nil) )) (do-test "Do some work in creating keyform" (and ; do some work inside (case (< 10 13) (T T)) (case (< 10 13) (T (> 13 10))) (case (< 10 3) (T T)) ; catch everthing (eq (case (< 10 13) (nil T)) nil) )) (do-test "Check we can use symbols in the keyform" (and (case 'foo (foo T) (T nil)) (case 'foo (bar nil) (foo T) (T nil)) (eq (case 'foo (bar T)) nil) (eq (case 'foo (bar T) (5 T)) nil) )) (do-test "Check we can use numbers in the keyform" (and (case (* 5 6) (30 T)) (case (* 5 6) ((20 30) T)) (case (* 3 10) (5 nil) ((4 5 6) nil) ((20 30) T)) (case (/ 3 10) (5 nil) ((2/10 4/10) nil) ((3/10) T)) )) (do-test "Can case return multiple values?" (and (let ((casevar 'foo)) (equal (multiple-value-list (case casevar (foo (values 'x 'y)) (t nil))) '(x y))) )) (do-test "Check values set in CASE still good outside" ; Define a function, tee returning T (flet ((tee nil t)) (let ((casevar 'foo)(sideffect nil)) (and ; Check values set withinside of CASE ; are still set outside of CASE (case (tee) (T (setq sideffect T))) (eq sideffect T) (case 'foo (nil nil) (hi nil) (foo (setq sideffect 'foo) T) (T nil)) (eq sideffect 'foo) (eq (case casevar (bar (setq sideffect 'nope)) ((foo baz) (setq sideffect 'winner) 'okay) (otherwise (setq sideffect 'lose) 'so-what)) 'okay) (eq sideffect 'winner) (eq (case (* 5 5) (5 nil) ((10 20 53) nil) ((1 2 3 4 25) (setq sideffect 5)) (T nil)) 5) (eq sideffect 5) )))) (do-test "Check values set in CASE still good outside" ; check the path not taken was in fact not taken (flet ((tee nil t)) (let ((sideffect nil)) (and (eq (case (tee) (nil (setq sideffect T))) nil) (eq sideffect nil) (eq (case 'foo (nil (setq sideffect 'nil)) (hi (setq sideffect 'he)) (bar (setq sideffect 'foo) T) (T 'everythingelse)) 'everythingelse) (eq sideffect nil) (eq (case (* 5 5) (5 (setq sideffect 5)) ((10 20 53) (setq sideffect 104)) ((1 2 3 4 6) (setq sideffect 65)) (T (* 2 3 4))) 24) (eq sideffect nil) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-6-COND.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-6-COND.TEST new file mode 100644 index 00000000..0e49b57b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-COND.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: cond ;; ;; Source: Steele's book Section 7.6: Conditionals Page: 116 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: June 11,1986 ;; ;; Last Update: June 11,1986 ;; June 17, 1986 Sye/ change "set 'm ..." to "setq m ..." in "test cond - test the selected final clause" ;; ;; Filed As: {eris}cml>test>7-6-cond.test ;; ;; ;; Syntax: COND {(test {form}*)}* ;; ;; Function Description: COND processes its clauses from left to right and selects the first clause whose test is ;; non-nil. The forms (consequents) of the selected clause are evaluated in order (as an ;; implicit progn) and the value(s) of the last form evaluated is returned and the remaining ;; clauses are ignored. ;; ;; Argument(s): form - a lisp data object meant to be evaluated to produce one or more values ;; test - a form which returns nil or non-nil ;; ;; Returns: value(s) of the last evaluated form of the selected clause ;; (do-test "test cond - zero clause" (eq nil (cond))) (do-test "test cond - zero form" (and (= (cond (1)) 1) (= (cond (nil) (2)) 2) (eq (cond (nil) ((cdr '(1))) ((and t nil)) ((or nil nil)) ('()) ('non-nil)) 'non-nil))) (do-test "test cond0" (eq (cond ((oddp 20) (1+ 20)) ((evenp 3) (1- 3)) ((= (sqrt #18r10000) #18r100) 18) (t 180)) 18)) (do-test "test cond1" (equal (cond ((equal '(1 2 3) (list 1 2 3 4)) "err1") ((and 'a 'b nil) "err2") ((prog1 2) "2") ((prog1 3) "3")) "2")) (do-test "test cond2" (progn (defun fun (x y) (cond ((evenp x) nil) (t y))) (equal (cond ((fun 2 4) "err1") ((fun 10 9) "err2") ((fun 1000 'a) "err3") (t (fun -1 "gotcha"))) "gotcha"))) (do-test "test cond3 - test nested cond" (let (object) (defun otype (object) (cond ((numberp object) (cond ((plusp object) (cond ((>= object 100) ">= 100") (t "< 100 +"))) ((zerop object) (cond ("= 0"))) ((minusp object) (cond ((>= object -100) ">= -100 -") (t "< -100"))) (t "error1"))) ((listp object) (cond ((eq object nil) "nil") (t "list"))) (t "non-number-non-list"))) (and (equal (otype 101) ">= 100") (equal (otype nil) "nil") (equal (otype 'a) "non-number-non-list") (equal (otype (1- 1)) "= 0") (equal (otype (/ -400 2)) "< -100")))) (do-test "test cond - test for returning multiple values" (let () (defun fun1 (x y) (multiple-value-list (cond ((= x 1) (values-list y)) ((= x 2) (values-list (mapcar #'(lambda (z) (* z 2)) y))) ((= x 3) (values-list (mapcar #'(lambda (z) (* z 3)) y))) (t (values 'sorry 'wrong 'input))))) (and (equal (fun1 1 '(1 2)) '(1 2)) (equal (fun1 3 (list 10 20 30)) '(30 60 90)) (equal (fun1 10 '(9)) '(sorry wrong input)) (equal (fun1 (* 2 1.0) (cons 9 (cons 7 (cons 5 (cons 3 nil))))) '(18 14 10 6))))) (do-test "test cond - a selected singleton clause returns only a single value (p 138 of CLtL)" (let (fail a b) (multiple-value-setq (a b) (cond (fail 1) (fail 2) ((values 999 99 9)) ((not fail) 100))) (and (= a 999) (eq b nil)))) (do-test "test cond - test the selected final clause" (let (fail m) ; ; if the selected final clause is a singleton clause, be sure only a single value was returned ; (and (setq m (multiple-value-list (cond (fail 1) (fail 100) ((values-list (list 66 33 22)))))) (equal m '(66)) ; ; if the selected final clause has a test part (non-nil), any value(s) may be returned ; (equal (multiple-value-list (cond (fail 10) (fail 100) ((or fail 1) (values-list (list 2 4 6 8 10))))) '(2 4 6 8 10) )))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-6-IF.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-6-IF.TEST new file mode 100644 index 00000000..4a3fb4c9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-IF.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: if ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 115 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 9,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ broke into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-6-IF.TEST ;; ;; ;; Syntax: (IF TEST THEN [ELSE]) ;; ;; which is exactly equal to: ;; (cond (test then) (t else)) ;; ;; ;; Function Description: ;; The if special form corresponds to the if-then-else ;; construct common to other languages. First TEST is ;; evaluated. If the result is not nil, THEN is selected; ;; otherwise, ELSE is selected. Whatever is slected is ;; evaluated, and if returns whatever evaluation of the ;; selected form returns. ;; ;; ;; ;; Argument(s): TEST - a form which returns nil or non-nil ;; THEN - a lisp data object meant to be evaluated ;; to produce one or more values ;; ELSE - an optional lisp data object meant to be ;; evaluated to produce one or more values ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test the simple cases" (and ; Does if evaluate and return the appropriate things? ; Check just boolean values (if T T) (if nil nil T) (eq (if nil t) nil) )) (do-test "test when do some work in test" (and (if T (> 3 0)) (if (> 3 0) (> 3 0)) (if (> 3 0) (> 3 0) nil) )) (do-test "test when call a locally defined function" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and (eq (if (tee) 'foo 'bar) 'foo) (eq (if (tee) 'foo) 'foo) (eq (if (nill) 'foo 'bar) 'bar) (eq (if (nill) 'foo) nil) ))) (do-test "test able to return numbers" (flet ((tee nil t) (nill nil nil)) (and (eq (if (tee) (* 3 4) (* 5 6)) 12) (eq (if (tee) (* 2 3)) 6) (eq (if (nill) (* 1 2) (* 5 5)) 25) (eq (if (nill) (* 9 9)) nil) ))) (do-test "test numbers and symbols are true" (and (if 5 T) (if 5 T nil) (if 'hi T) (if 'hi T nil) )) (do-test "test able to return several values" (flet ((tee nil t) (nill nil nil)) (and ; Does if pass multiple values? (equal (multiple-value-list (if (tee) (values 'foo 'bar) (values 'baz 'bletch))) '(foo bar)) (equal (multiple-value-list (if (nill) (values 'foo 'bar) (values 'baz 'bletch))) '(baz bletch)) ))) (do-test "test values set in IF are still set outside" ; Check values set withinside of IF ; are still set outside of IF ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (if (tee) (setq sideffect T) nil) T) (eq sideffect T) (eq (if (tee) (setq sideffect 'foo) 'bar) 'foo) (eq sideffect 'foo) (eq (if (tee) (setq sideffect 5) 23) 5) (eq sideffect 5) )))) (do-test "test path not taken was in fact not taken" ; Check values set withinside of IF ; are still set outside of IF ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (if (nill) (setq sideffect T) nil) nil) (eq sideffect nil) (eq (if (tee) (setq sideffect 'foo) (setq sideffect 'bar)) 'foo) (eq sideffect 'foo) (eq (if (nill) (setq sideffect 5) (setq sideffect 23)) 23) (eq sideffect 23) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-6-TYPECASE.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-6-TYPECASE.TEST new file mode 100644 index 00000000..17978ed5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-TYPECASE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: typecase ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 118 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 14,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ documented, and added ;; ;; Filed As: {ERIS}CML>TEST>7-6-TYPECASE.TEST ;; ;; ;; Syntax: (typecase keyform {(type {form}*)}*) ;; ;; ;; Function Description: ;; The form keyform is evaluated to produce the key object. ;; The type of the key is matched against each clause to see if ;; it is of the correct type. The forms of the clause which ;; match are evaluated, and typecase returns what was returned ;; from the last consequent (or nil if there are none for that ;; clause.) ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; TYPE - a type(s) against which match keyform ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test several types" (and ; Does if evaluate and return the appropriate things? ; Check each type from page 12-13 on Guy Steele's book (TYPECASE T (T T)) (typecase 54 (number T) (T nil)) (typecase #\g (character T) (T nil)) (typecase "A STRING" (string T) (T nil)) (typecase 'symbol (symbol T) (T nil)) (typecase (list 'hi 'bye) (list T) (T nil)) (typecase (make-array '(2 3 4)) (array T) (T nil)) (typecase (make-hash-table) (hash-table T) (T nil)) (typecase (copy-readtable) (readtable T) (T nil)) ; some of the early sysouts don't have a lisp package (typecase (find-package 'Lisp) (package T) (T nil)) ; put in pathnames? (typecase (make-broadcast-stream *terminal-io*) (stream T) (T nil)) (typecase (make-random-state) (random-state T) (T nil)) ; user defined structures? ; some functions? )) (do-test "test doesn't fall into another type" (and ; now make sure doesn't get caught in some other group (eq (typecase 54 (character T) (string T) (symbol T) (list T) (array T) (hash-table T)) nil) (eq (typecase #\g (string T) (symbol T) (list T) (array T) (hash-table T) (readtable T)) nil) (eq (typecase "A STRING" (symbol T) (list T) (hash-table T) (readtable T) (package T)) nil) (eq (typecase 'symbol (list T) (array T) (hash-table T) (readtable T) (package T) (stream T)) nil) (eq (typecase (list 'hi 'bye) (array T) (hash-table T) (readtable T) (package T) (stream T)) nil) (eq (typecase (make-array '(2 3 4)) (hash-table T) (readtable T) (package T) (stream T)) nil) (eq (typecase (make-hash-table) (readtable T) (package T) (stream T) (random-state T) (number T)) nil) (eq (typecase (copy-readtable) (package T) (stream T) (random-state T) (number T) (character T)) nil) (eq (typecase (find-package 'Lisp)(stream T) (random-state T) (number T) (character T)) nil) (eq (typecase (make-broadcast-stream *terminal-io*) (random-state T) (number T) (character T)) nil) (eq (typecase (make-random-state) (number T) (character T) (string T) (symbol T) (list T)) nil) )) (do-test "test able to catch everything" (and (typecase 54 (string nil) (T T)) (typecase #\g (number nil) (array nil) (otherwise T)) (eq (typecase "string" (T nil)) nil) ; the test below generated AR 6640 (eq (typecase 'smile (readtable T) (T)) nil) )) (do-test "test function valid for keyform & return numbers" (and (typecase (* 10 13) (list T) (number T)) (eq (typecase (* 5 6) (integer 5) (float 7) (number 9)) 5) (eq (typecase (/ 5 6) (integer 5) (float 7) (ratio 3) (number 10)) 3) )) (do-test "test can return symbols and strings" (and (eq (typecase 'foo (symbol 'asymbol) (T nil)) 'asymbol) (equal (typecase 'bar (symbol "a string") (T nil)) "a string") )) (do-test "test able to return multiple values" (and (let ((casevar 'foo)) (equal (multiple-value-list (typecase casevar (symbol (values 'x 'y)) (t nil))) '(x y))) )) (do-test "test local functions valid for keyform" (flet ((retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (and (typecase (retnumber) (number T) (T nil)) (typecase (retsymbol) (symbol T) (T nil)) (typecase (retlist) (list T) (T nil)) ))) (do-test "test values stay set outside of typecase" (flet ((retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (let ((casevar 'foo)(sideffect nil)) (and (typecase (retnumber) (T (setq sideffect T))) (eq sideffect T) (typecase (retsymbol) (number nil) (string nil) (symbol (setq sideffect 'foo) T) (T nil)) (eq sideffect 'foo) (eq (typecase casevar (number (setq sideffect 'nope)) (symbol (setq sideffect 'winner) 'okay) (otherwise (setq sideffect 'lose) 'so-what)) 'okay) (eq sideffect 'winner) (eq (typecase (* 5 5) (symbol nil) (list nil) (number (setq sideffect 5)) (T nil)) 5) (eq sideffect 5) )))) (do-test "test path not taken was not taken" (flet ((retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (let ((casevar 'foo)(sideffect nil)) (and (eq (typecase (retnumber) (symbol (setq sideffect T)) (list (setq sideffect 'why))) nil) (eq sideffect nil) (eq (typecase (retsymbol) (number (setq sideffect 'nil)) (list (setq sideffect 'he)) (string (setq sideffect 'foo) T) (T 'everythingelse)) 'everythingelse) (eq sideffect nil) (eq (typecase (retnumber) (number (setq sideffect 5)) (string (setq sideffect 104)) (symbol (setq sideffect 65))) 5) (eq sideffect 5) )))) (do-test "test the first test created" (let ((a-string "foo") (an-atom 'bar)(sideffect nil)) (and ; Does typecase evaluate and return the right things (eq (typecase a-string (symbol (setq sideffect 'lose)) (string 'win) (t (setq sideffect 'wrong))) 'win) (null sideffect) (eq (typecase an-atom (string (setq sideffect 'lose)) ((or number symbol) 'win-again) (otherwise (setq sideffect 'wrong))) 'win-again) (null sideffect) (eq (typecase a-string (symbol (setq sideffect 'nope)) (number (setq sideffect 'wrong)) (otherwise 'right)) 'right) (null sideffect) (equal (multiple-value-list (typecase an-atom (number (setq sideffect 'nope) (values 'ouch 'ouch)) (symbol (values 'right 'again)) (t (setq sideffect 'wrong) (values 'oops 'twice)))) '(right again)) (null sideffect) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-6-UNLESS.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-6-UNLESS.TEST new file mode 100644 index 00000000..0d0ea169 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-UNLESS.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: unless ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 115 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 10,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ broke up into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-6-UNLESS.TEST ;; ;; ;; Syntax: (unless test {form}*) ;; ;; (unless p a b c) is exactly equal to: ;; (cond ((not p) a b c)) ;; (if p nil (progn a b c)) ;; (when (not p) a b c) ;; ;; ;; Function Description: ;; First TEST is evaluated. If the result is not nil (T), ;; then no form is used. Otherwise the forms are evaluated ;; sequentially from left to right. The value of the last one ;; is returned. ;; ;; ;; ;; Argument(s): TEST - a form which returns nil or non-nil ;; {forms}* - a sequence of lisp data objects ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test simple cases" (and ; Does when evaluate and return the appropriate things? ; Check just boolean values (unless nil T) (unless nil nil nil T) (eq (unless T T) nil) (eq (unless T nil nil T) nil) )) (do-test "test work generating test" (and (unless (> 0 95) T) (unless (> 0 95) nil nil T) (eq (unless (> 0 13) T) T) (eq (unless (> 0 13) T nil nil) nil) (eq (unless (> 10 6) T T T) nil) )) (do-test "test local functions for test & returning symbols" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and ; check symbols (eq (unless (nill) 'foo) 'foo) (eq (unless (tee) 'foo) nil) (eq (unless (nill) 'bar 'bar 'foo) 'foo) (eq (unless (tee) 'bar 'bar 'foo) nil) ))) (do-test "test returning numbers" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and (eq (unless (nill) (* 3 5)) 15) (eq (unless (nill) (* 3 5) (* 5 7)) 35) (eq (unless (nill) (* 3 5) (* 5 7) (* 9 4)) 36) (eq (unless (tee) (* 3 5)) nil) (eq (unless (tee) (* 3 5) (* 5 7) (* 9 4)) nil) ))) (do-test "test using numbers and symbols for true" (and (eq (unless 5 T) nil) (eq (unless 5 T T) nil) (eq (unless 'hi T) nil) (eq (unless 'hi T nil T) nil) )) (do-test "test passing back multiple values" (flet ((nill () nil)) (and (equal (multiple-value-list (unless (nill) (values 'foo 'bar))) '(foo bar)) (equal (multiple-value-list (unless (nill) 56 'Hello (values 'bar 'foo))) '(bar foo)) ))) (do-test "test values set in UNLESS, still set outside" (flet ((nill () nil)) (let ((sideffect nil)) (and (eq (unless (nill) (setq sideffect T)) T) (eq sideffect T) (eq (unless (nill) (setq sideffect 'foo) 'bar) 'bar) (eq sideffect 'foo) (eq (unless (nill) (setq sideffect 5) 23) 23) (eq sideffect 5) )))) (do-test "test path not taken was not taken" (flet ((tee nil t)) (let ((sideffect nil)) (and (eq (unless (tee) (setq sideffect T) nil) nil) (eq sideffect nil) (eq (unless (tee) (setq sideffect 23)) nil) (eq sideffect nil) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-6-WHEN.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-6-WHEN.TEST new file mode 100644 index 00000000..f4c37669 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-WHEN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: when ;; ;; Source: Steele's book ;; Section 7.6: Conditionals ;; Page: 115 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 9,1986 HC3/ documented, and added ;; several more test cases ;; October 24,1986 HC3/ broke into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-6-WHEN.TEST ;; ;; ;; Syntax: (when test {form}*) ;; ;; (when p a b c) is exactly equal to: ;; (cond (p a b c)) ;; (and p (progn a b c)) ;; (if p (progn a b c) nil) ;; (unless (not p) a b c) ;; ;; ;; Function Description: ;; First TEST is evaluated. If the result is nil, then no ;; form is used. Otherwise the forms are evaluated sequentially ;; from left to right. The value of the last one is returned. ;; ;; ;; ;; Argument(s): TEST - a form which returns nil or non-nil ;; {forms}* - a sequence of lisp data objects ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; (do-test "test for the simple cases" (and ; Does when evaluate and return the appropriate things? ; Check just boolean values (when T T) (when T nil nil T) (eq (when nil T) nil) (eq (when T T nil nil) nil) )) (do-test "test when build test from a function" (and (when (> 5 0) T) (when (> 5 0) nil nil T) (eq (when (> 5 0) T) T) (eq (when (> 5 0) T nil nil) nil) (eq (when (> 5 10) T T T) nil) )) (do-test "test with a local function, & able to pass symbols" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and ; check symbols (eq (when (tee) 'foo) 'foo) (eq (when (nill) 'foo) nil) (eq (when (tee) 'bar 'bar 'foo) 'foo) (eq (when (nill) 'bar 'bar 'foo) nil) ))) (do-test "test with a local function, & able to pass numbers" ; Define two functions, tee returning T, ; and nill returning nil (flet ((tee nil t) (nill nil nil)) (and ; check numbers (eq (when (tee) (* 3 5)) 15) (eq (when (tee) (* 3 5) (* 5 7)) 35) (eq (when (tee) (* 3 5) (* 5 7) (* 9 4)) 36) (eq (when (nill) (* 3 5)) nil) (eq (when (nill) (* 3 5) (* 5 7) (* 9 4)) nil) ))) (do-test "test non nil acts at true values" (and (when 5 T) (when 5 nil T) (when 'hi T) (when 'hi nil nil T) )) (do-test "test able to pass multiple values" (flet ((tee nil t) (nill nil nil)) (and (equal (multiple-value-list (when (tee) (values 'foo 'bar))) '(foo bar)) (equal (multiple-value-list (when (tee) 56 'Hello (values 'bar 'foo))) '(bar foo)) ))) (do-test "test values set in still set outside of when" (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (when (tee) (setq sideffect T)) T) (eq sideffect T) (eq (when (tee) (setq sideffect 'foo) 'bar) 'bar) (eq sideffect 'foo) (eq (when (tee) (setq sideffect 5) 23) 23) (eq sideffect 5) )))) (do-test "test path not taken, was not taken" (flet ((tee nil t) (nill nil nil)) (let ((sideffect nil)) (and (eq (when (nill) (setq sideffect T) nil) nil) (eq sideffect nil) (eq (when (nill) (setq sideffect 23)) nil) (eq sideffect nil) )))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-7-BLOCK.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-7-BLOCK.TEST new file mode 100644 index 00000000..cfbc9f8f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-7-BLOCK.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: block ;; ;; Source: CLtL Section 7.7: Blocks and Exits Page: 119 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 13 ,1986 ;; ;; Last Update: Oct. 13 ,1986 ;; ;; Filed As: {eris}cml>test>7-7-block.test ;; ;; ;; Syntax: block NAME {FORM}* ;; ;; Function Description: The block donstruct executes each FORM from left to right, returning whatever is returned by the ;; last form. If, however, a return or return-from form that specifies the same name is executed during ;; the execution of some form, then the results specified by the return or return-from are immediately ;; returned as the value of the block construct, and execution proceeds as if the block had terminated ;; normally. ;; ;; Argument(s): NAME - a symbol ;; FORM - a valid lisp form ;; ;; Returns: anything ;; (do-test-group (test-block-group :before (progn (test-defun hairyfun (x) (list x "hairyfun")) (test-defun fun (x) (typecase x ((integer 100 *) (return-from fun "x >= 100") ) ((mod 100) (return-from fun "100 > x >= 0") ) (t (return-from fun "0 > x") ) ) ("wrong!!")) )) (do-test "test block - test case copied from page 120 of CLtL" (and (equal (block loser (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) (hairyfun x) (return-from loser nil))) '(23 24 35 36)))) '( (23 "hairyfun") (24 "hairyfun") (35 "hairyfun") (36 "hairyfun"))) (eq (block loser (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) (hairyfun x) (return-from loser nil))) '(#\q 24 35 36)))) '()) (equal (multiple-value-list (block loser (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) (hairyfun x) (return-from loser (values 'multiple 'values)))) `(t nil t nil))))) '(multiple values)) ) ) (do-test "test block - the body of a defun form is a block construct which has the same name as the function" ;; ;; fun was defined in :before section ;; (and (equal (fun 150) "x >= 100") (equal (fun -9) "0 > x") (equal (fun 87) "100 > x >= 0") ) ) ) (do-test "test block - block construct returns whatever is returned by the last form" (and (eq (block name1) nil) (= (block name2 (1+ 99)) 100) (equal (block name3 (append '(2 3 4) '(0 9 8))) '(2 3 4 0 9 8)) (equal (multiple-value-list (block name (values #\a #\b #\c))) '(#\a #\b #\c)) (equalp (block name1 (concatenate 'bit-vector #*0000 #*1111)) #*00001111) (equal (block name2 ( (lambda (x) (cons x x)) 9)) '(9 . 9)) ) ) (do-test "test block - nested blocks" (flet ((fun (y) (let (temp) (block outblk (setq temp (mapcar #'(lambda (x) (cons x (block blk (typecase x (number (return-from blk '( is a number))) (list (return-from blk '( is a list))) (string (return-from blk '( is a string))) (t (return-from outblk "wrong input !!")) )))) y)) (if (null temp) (return-from outblk "no input")) (setq temp (cons "Results:" temp)) ) ) )) (and (equal (fun nil) "no input") (equal (fun '(1 "fg")) '("Results:" (1 is a number) ("fg" is a string))) (equal (fun '( (2 3) 100 20 "fgh" "as")) '("Results:" ((2 3) is a list) (100 is a number ) (20 is a number) ("fgh" is a string) ("as" is a string))) (equal (fun '(#*0101 3)) "wrong input !!") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN-FROM.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN-FROM.TEST new file mode 100644 index 00000000..5ea67b9d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN-FROM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: return-from ;; ;; Source: CLtL Section 7-7-Blocks and Exits Page: 120 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 13 ,1986 ;; ;; Last Update: Oct. 13 ,1986 ;; ;; Filed As: {eris}cml>test>7-7-return-from.test ;; ;; ;; Syntax: return-from NAME [RESULT] ;; ;; Function Description: return-from is used to return from a block or from such constructs as do and prog that ;; implicitly establish a block. The name is not evaluated and must be a symbol. A block ;; construct with the same name must lexically enclose the occurrence of return-from ; ;; whatever the evaluation of result produces is immediately returned from the block. ;; ;; Argument(s): NAME - a smbol ;; RESULT - a lisp form ;; ;; Returns: anything ;; (do-test "test return-from for BLOCK - the name is not evaluated and must be a symbol" (and (= (block abc (return-from abc 2)) 2) (= (block |m & m| (return-from |m & m| 20)) 20) (eq (block nil (return-from nil t)) t) (eq (block t (return-from t 'hi)) 'hi) (equal (block first\ name (return-from first\ name '(first name))) '(first name)) (equalp (block 3.14159\s0 (return-from 3.14159\s0 #\p)) #\P) ) ) (do-test "test return-from for BLOCK - whatever the evaluation of result produces is immediately returned from the block" (let (a) (and (= (block blk 2 (return-from blk 11) 22 33 44) 11) (eq (block blk 2 (return-from blk ) 22 33 44) nil) (= (block |abc| (setq a 0) (incf a 2) (return-from |abc| a) (incf a 3)) 2) (equal (block \@ (setq a nil) (push 11 a) (push 22 a) (return-from \@ a) (push 33 a)) '(22 11)) ) ) ) (do-test "test return-from for BLOCK - be sure multiple-values are returned properly" (and (equal (multiple-value-list (block blk1 (return-from blk1 (values 1 2 3 4 5)))) '(1 2 3 4 5)) (equal (multiple-value-list (block blk2 (return-from blk2 (values-list '(5 4 3 2 1))))) '(5 4 3 2 1)) ) ) (do-test "test return-from for BLOCK - nested return-forms" (macrolet ((fun (x) `(cons 0 (block blk0 (return-from blk0 (cons 1 (block blk1 (return-from blk1 (cons 2 (block blk2 (return-from blk2 (cons 3 (block blk3 (return-from blk3 (cons 4 (block blk4 (return-from ,x 9))))))))))))))) )) (and (equal (fun blk0) '(0 . 9)) (equal (fun blk1) '(0 1 . 9)) (equal (fun blk2) '(0 1 2 . 9)) (equal (fun blk3) '(0 1 2 3 . 9)) (equal (fun blk4) '(0 1 2 3 4 . 9)) ) ) ) (do-test "test return-from for DO" (and (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return-from nil (values-list b))))) '(0 1 2 3 4)) (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(0 1 2 3 4 5 6 7 8 9)) ) ) (do-test "test return-from for DO*" (and (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return-from nil (values-list b))))) '(1 2 3 4 5)) (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(1 2 3 4 5 6 7 8 9 10)) ) ) (do-test "test return-from for DOLIST" (let (a b) (and (equal (multiple-value-list (dolist (y '(1 2 3 4 5 6)) (push y a) (when (= y 4) (return-from nil (values-list a))))) '(4 3 2 1)) (equal (dolist (y '(0 a b 3 d e 7 g h 8 ) b) (if (numberp y) (setq b (cons y b)))) '(8 7 3 0)) ) ) ) (do-test "test return-from for DOTIMES" (let ((a 0) (b 20)) (and (= (dotimes (x 10) (incf a x) (unless (< a 10) (return-from nil a))) 10) (= (dotimes (x 8 b) (decf b x) ) -8) ) ) ) (do-test "test return-from for PROG" (and (equal (prog ((a 1) (b 2) (c 3) (d 4)) (return-from nil (list a b d c))) '(1 2 4 3)) (equal (prog () (return-from nil (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) (do-test "test return-from for PROG*" (and (equal (prog* ((a 1) (b 2) (c (+ a b)) (d (- a b))) (return-from nil (list a b d c))) '(1 2 -1 3)) (equal (prog* () (return-from nil (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) ;; [Masinter] 4-Sep-86 ;; at AAAI, James Meehan of Cognitive Systems mentioned that this definition of TAGBODY uncovered a serious bug in ;; the Lucid Common Lisp compiler. Can anyone turn this into a test case for return-from? ;; (do-test-group ( "test return-from for macro defined TAGBODY-GO" :before (test-defmacro tagbody1 (&rest rest) (labels ((parse (tail &aux (rest (member-if #'atom (cdr tail)))) (if tail (cons (cons (gensym) (ldiff tail rest)) (parse rest))))) (let ((name (gensym)) (bodies (parse (cons (gensym) rest)))) `(block ,name (macrolet ((go1 (tag) `(return-from ,(car (find tag ',bodies :key 'cadr)) nil))) (labels ,(maplist #'(lambda (tail) `(,(caar tail) () ,@(reduce #'(lambda (body tag) `((block ,(car tag) ,@body) (return-from ,name (,(car tag))))) bodies :initial-value `(,@(cddar tail) ,(if (cdr tail) `(return-from ,(caadr tail) nil) `(return-from ,name nil) ))))) bodies) (,(caar bodies)))))))) ) (do-test "test return-from in tagbody1 0" (let (a) (eq (tagbody1 t1 (setq a (cons "t1" a)) (go1 t33) t2 (setq a (cons "t2" a)) (go1 done) t33 t3 (setq a (cons "t3" a)) t4 (setq a (cons "t4" a)) t5 (setq a (cons "t5" a)) (go1 t77) t6 (setq a (cons "t6" a)) t7 t77 (setq a (cons "t7" a)) t8 (setq a (cons "t8" a)) t9 (setq a (cons "t9" a)) t10 (setq a (cons "t10" a)) (go1 t2) done (setq a (cons "done !!" a)) ) nil) (equal a '("done !!" "t2" "t10" "t9" "t8" "t7" "t5" "t4" "t3" "t1")) ) ) (do-test "test return-from in tagbody1 1" (flet ((fun (items elt) (let (a) (tagbody1 (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) x (progn (push x a) (go1 lose)))) items) ) lose (nconc a '(is not a number)) ) (equal a (append (list elt) '(is not a number))) ) )) (and (fun '(1 2 3 #\q) #\q) (fun '(10 20 "st" "fre") "st") ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN.TEST new file mode 100644 index 00000000..494b6a41 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: return ;; ;; Source: CLtL Section 7-7-Blocks and Exits Page: 120 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 13 ,1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - changed = to eq in first test since = expects a number and was failing on the SUN ;; ;; Filed As: {eris}cml>test>7-7-return.test ;; ;; ;; Syntax: return [RESULT] ;; ;; Function Description: (return form) is identical in meaning to (return-from nil) ; It returns from a block named nil. ;; ;; Argument(s): ;; RESULT - a lisp form ;; ;; Returns: anything ;; (do-test "test return for BLOCK 0" (and (eq (block nil (return t)) t) (eq (block nil (return)) nil) ) ) (do-test "test return for BLOCK - whatever the evaluation of result produces is immediately returned from the block" (let (a) (and (= (block nil 2 (return 11) 22 33 44) 11) (eq (block nil 2 (return ) 22 33 44) nil) (= (block nil (setq a 0) (incf a 2) (return a) (incf a 3)) 2) (equal (block nil (setq a nil) (push 11 a) (push 22 a) (return a) (push 33 a)) '(22 11)) ) ) ) (do-test "test return for BLOCK - be sure multiple-values are returned properly" (and (equal (multiple-value-list (block nil (return (values 1 2 3 4 5)))) '(1 2 3 4 5)) (equal (multiple-value-list (block nil (return (values-list '(5 4 3 2 1))))) '(5 4 3 2 1)) ) ) (do-test "test return for BLOCK - nested returns" (macrolet ((fun (x1 x2 x3 x4 x5) `(cons 0 (block ,x1 (return (cons 1 (block ,x2 (return (cons 2 (block ,x3 (return (cons 3 (block ,x4 (return (cons 4 (block ,x5 (return 9))))))))))))))) )) (and (equal (fun nil a b c d ) '(0 . 9)) (equal (fun nil nil b c d ) '(0 1 . 9)) (equal (fun nil nil nil c d ) '(0 1 2 . 9)) (equal (fun nil nil nil nil d ) '(0 1 2 3 . 9)) (equal (fun nil nil nil nil nil ) '(0 1 2 3 4 . 9)) (equal (fun nil a nil b nil) '(0 2 4 . 9)) (equal (fun nil a b c d) '(0 . 9)) (equal (fun nil a b nil d) '(0 3 . 9)) ) ) ) (do-test "test return for DO" (and (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return (values-list b))))) '(0 1 2 3 4)) (equal (multiple-value-list (do (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(0 1 2 3 4 5 6 7 8 9)) ) ) (do-test "test return for DO*" (and (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) nil) (if (= (length b) 5) (return (values-list b))))) '(1 2 3 4 5)) (equal (multiple-value-list (do* (( a 0 (1+ a)) (b nil (append b (list a)))) ((= a 10) (values-list b)))) '(1 2 3 4 5 6 7 8 9 10)) ) ) (do-test "test return for DOLIST" (let (a b) (and (equal (multiple-value-list (dolist (y '(1 2 3 4 5 6)) (push y a) (when (= y 4) (return (values-list a))))) '(4 3 2 1)) (equal (dolist (y '(0 a b 3 d e 7 g h 8 ) b) (if (numberp y) (setq b (cons y b)))) '(8 7 3 0)) ) ) ) (do-test "test return for DOTIMES" (let ((a 0) (b 20)) (and (= (dotimes (x 10) (incf a x) (unless (< a 10) (return a))) 10) (= (dotimes (x 8 b) (decf b x) ) -8) ) ) ) (do-test "test return for PROG" (and (equal (prog ((a 1) (b 2) (c 3) (d 4)) (return (list a b d c))) '(1 2 4 3)) (equal (prog () (return (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) (do-test "test return for PROG*" (and (equal (prog* ((a 1) (b 2) (c (+ a b)) (d (- a b))) (return (list a b d c))) '(1 2 -1 3)) (equal (prog* () (return (concatenate 'string "asd" "qwe" "zxc"))) "asdqwezxc") ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-1-LOOP.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-1-LOOP.TEST new file mode 100644 index 00000000..2afdbd89 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-1-LOOP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: loop ;; ;; Source: Steele's book ;; Section 7.8: Iteration ;; Page: 121 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 16,1986 HC3/ documented, and added ;; several more test cases ;; October 27,1986 HC3/ broke into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-8-1-loop.TEST ;; ;; ;; Syntax: (loop {form}*) ;; ;; ;; Function Description: ;; Each form is evaluated in turn from left to right. When ;; the last form is evaluated, then the first is evaluated again, ;; and so on until execution is terminated explicitly. ;; ;; ;; ;; Argument(s): FORM - what is evaluated. ;; ;; Returns: depends on what is used to terminate execution. ;; (do-test "test simple function" (and (loop (return T)) (catch 'looptag (loop (throw 'looptag T))) (eq (loop (return)) nil) )) (do-test "test loop can terminate with return." ; first return a symbol, then a number (let ((sideffect nil) (foo '(a b c)) (bar '(1 2 3 4 5 6 7))) (and (eq (loop (if (null foo) (return 'bar) (push (pop foo) sideffect))) 'bar) (equal sideffect '(c b a)) (eq (loop (if (null bar) (return 1013)) (push (pop bar) sideffect)) 1013) (equal sideffect '(7 6 5 4 3 2 1 c b a)) ))) (do-test "test loop can with throw and catch." ; first return a symbol, then a string (let ((sideffect '(c b a)) (foo '(a b c)) (bar '("a" "little " "short" "string"))) (and (eq (catch 'looptag (loop (if (null foo) (throw 'looptag 'bar) (push (pop foo) sideffect)))) 'bar) (equal sideffect '(c b a c b a)) (equal (catch 'looptag (loop (if (null bar) (throw 'looptag "string testing")) (push (pop bar) sideffect))) "string testing") (equal sideffect '("string" "short" "little " "a" c b a c b a)) ))) (do-test "test loop can return with multiple values." ; first return two symbols, then two characters (let ((sideffect '(c b a)) (foo '(a b c)) (bar '(#\a #\b #\c #\d))) (and (equal (multiple-value-list (loop (if (null foo) (return (values 'foo 'bar)) (push (pop foo) sideffect)))) '(foo bar)) (equal sideffect '(c b a c b a)) (equal (multiple-value-list (loop (if (null bar) (return (values #\+ #\-)) (push (pop bar) sideffect)))) '(#\+ #\-)) (equal sideffect '(#\d #\c #\b #\a c b a c b a)) ))) (do-test "test loop can throw multiple values." ; first return two symbols, then two characters (let ((sideffect '(f e d)) (foo '(a b c))) (and (equal (multiple-value-list (catch 'looptag (loop (if (null foo) (throw 'looptag (values 'foo 'bar))) (push (pop foo) sideffect)))) '(foo bar)) (equal sideffect '(c b a f e d)) ))) (do-test "test loop can go" (let ((sideffect '(c b a)) (foo '(a b c))) (and (null (tagbody (loop (if (null foo) (go looptag) (push (pop foo) sideffect))) looptag)) (equal sideffect '(c b a c b a)) ))) (do-test "test loop can return and throw value from a function" ; try returning, and throwing the value from a function ; is the complier smart enough to hardcode in the value ; instead of making a dumb function call? want the call (flet ((tee nil t) (retnumber nil 5) (retsymbol nil 'hello) (retlist nil '(hi bye))) (let ((sideffect '(c b a)) (foo '(a b c))) (and (loop (return (tee))) (eq (catch 'looptag (loop (throw 'looptag (retnumber)))) 5) (eq (loop (return (retsymbol))) 'hello) (equal (catch 'looptag (loop (throw 'looptag (retlist)))) '(hi bye)) )))) (do-test "test loop can nest: when, unless" (let ((sideffect nil) (i 1) (j 1)) (and (eq (loop (when (> i 4) (return i)) (push i sideffect) (setq i (+ i 1))) 5) (equal sideffect '(4 3 2 1)) (eq (loop (unless (> 6 j) (return j)) (push j sideffect) (setq j (+ j 1))) 6) (equal sideffect '(5 4 3 2 1 4 3 2 1)) ))) (do-test "test loop can nest: type, typecase" (let ((sideffect nil) (i 1) (foo '(1 23 abc))) (and (eq (loop (case i ((7 8 9) (return i))) (push i sideffect) (setq i (+ i 1))) 7) (equal sideffect '(6 5 4 3 2 1)) (equal (loop (typecase (car foo) (number (push (pop foo) sideffect)) (T (return foo)))) '(abc)) (equal sideffect '(23 1 6 5 4 3 2 1)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-2-DO.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-2-DO.TEST new file mode 100644 index 00000000..a0f230e1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-2-DO.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do ;; ;; Source: Steele's book ;; Section 7.8: Iteration ;; Page: 122 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 16,1986 HC3/ docuemented, and added ;; several more test cases ;; October 27,1986 HC3/ broke into several tests ;; Feb 5, 1987 Jim Blum - changed (do nil nil (return T)) which is wrong on the SUN ;; to (do nil ((return T))) ;; and (catch 'lloptag (do nil nil (throw 'looptag T))) to ;; (catch 'looptag (do nil ((throw 'looptag T)))) ;; ;; ;; Filed As: {ERIS}CML>TEST>7-8-2-do.TEST ;; ;; ;; Syntax: (do {(var [init [step]])}*) (end-test {result}*) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; The initial variables are each evaluated and then bound. ;; Then the end-test is checked to see if can terminate. ;; If ok, the forms in result are evaluated, and the value of ;; the last one is returned If suppose to go on, loop thru ;; the body, update the variables and start over again. ;; The difference between DO and DO* is here DO first ;; evaluated everything and then binds the variable. ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; TYPE - a type(s) against which match keyform ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; ;; The first section is similar to DO* (do-test "test the simple stuff" (let ((x nil)) (and (do nil ((return T))) (catch 'looptag (do nil ((throw 'looptag T)))) (eq (do nil ((return))) nil) (do nil (T . (T)) nil) (eq (do nil (T)) nil) (do nil (T nil nil T)) (null (do ((x '(a b c d) (cdr x))) ((null x)))) ))) (do-test "test returning for termination" ; first check can return a symbol, then a number (let ((sideffect nil) (x nil) (foo '(1 2 3 4))) (and (eq (do ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (return 'right) (setq sideffect (car x)))) 'right) (eq sideffect 'b) (eq (do nil ((null foo) (return 1013)) (push (pop foo) sideffect)) 1013) (equal sideffect '(4 3 2 1 . b)) ))) (do-test "test returning mutiple-values" (let ((x nil)) (and ; first return two symbols, then three characters (equal (multiple-value-list (do ((x '(a b c d) (cdr x))) ((null (cddr x)) (values (car x) (cadr x))))) '(c d)) (equal (multiple-value-list (do nil (T (values '#\y '#\9 '#\q)) nil)) '(#\y #\9 #\q)) ))) (do-test "test can go out of do" (let ((sideffect nil) (x nil)) (and (null (tagbody (do ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (progn (setq sideffect (cons 'right x)) (go dotag)) (setq sideffect (car x)))) dotag)) (equal sideffect '(right c d)) ))) (do-test "test can throw a value out of do" (let ((x nil)) (and (equal (catch 'looptag (do ((x '("a" "small" "little" "string") (cdr x))) ((null x) 'nope) (if (equal (car x) "little") (throw 'looptag "have a nice day")))) "have a nice day") ))) (do-test "use several different functions to stop" (let ((x nil)) (and (equal (do ((x '(1 2 3 4 5) (cdr x))) ((> (car x) 3) (car x))) 4) (equal (do ((x '(1 b "Hi" '(a b c)) (cdr x))) ((stringp (car x)) (car x))) "Hi") (equal (do ((x '(1 b "Hi" '(a b c)) (cdr x))) ((if (symbolp (car x)) T) (car x))) 'b) ))) ;; Do some parallel testing ;; this will be different in DO* (do-test "test parallel evaluation setting initial values" (let ((x nil)) (and (do ((x '(a b c d)) (y x)) (nil) (return (and (equal x '(a b c d)) (eq y nil)))) (do ((x '(a b c d)) (y x)) (T (and (equal x '(a b c d)) (eq y nil)))) ))) (do-test "test parallel evaluation for incrementing values" (let ((x nil)) (eq (do ((x 1 (+ x 1)) (y 2 (+ x 2))) ((> x 5) y)) 7) )) (do-test "test both parallel setting and incrementing" (let ((sideffect nil) (x nil) (y nil)) (and (eq (do ((x '(a b c) (cdr x)) (y '(foo) (cdr x))) ((or (null x) (null y)) 'done) (push (cons (car x) (car y)) sideffect)) 'done) (equal sideffect '((c . c)(b . b)(a . foo))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-2-DOSTAR.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-2-DOSTAR.TEST new file mode 100644 index 00000000..087657d3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-2-DOSTAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: do* ;; ;; Source: Steele's book ;; Section 7.8: Iteration ;; Page: 122 ;; ;; Created By: Bob Bane ;; Henry Cate III ;; ;; Creation Date: June 26,1986 ;; ;; Last Update: June 26,1986 ;; October 20,1986 HC3/ docuemented ;; October 27,1986 HC3/ broke into several tests ;; Feb 5, 1987 Jim Blum - same changes as in "do.test" ;; ;; Filed As: {ERIS}CML>TEST>7-8-2-dostar.TEST ;; ;; ;; Syntax: (do* {(var [init [step]])}*) (end-test {result}*) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; The initial variables are each evaluated and then bound. ;; Then the end-test is checked to see if can terminate. ;; If ok, the forms in result are evaluated, and the value of ;; the last one is returned If suppose to go on, loop thru ;; the body, update the variables and start over again. ;; The difference between DO and DO* is here DO* does the ;; first evaluation and binds it, and then does the second ;; evaluation and so on. ;; ;; ;; ;; Argument(s): KEYFORM - evaluated to build a key object ;; TYPE - a type(s) against which match keyform ;; FORM - what is evaluated. ;; ;; Returns: value(s) of the last evaluated form of ;; the selected clause ;; ;; The first section is similar to DO (do-test "test the simple stuff" (let ((x nil)) (and ; do* some simple tests... (do* nil ((return T))) (catch 'looptag (do* nil ((throw 'looptag T)))) (eq (do* nil ((return))) nil) (do* nil (T . (T)) nil) (eq (do* nil (T)) nil) (do* nil (T nil nil T)) (null (do* ((x '(a b c d) (cdr x))) ((null x)))) ))) (do-test "test returning for termination" ; first check can return a symbol, then a number (let ((sideffect nil) (x nil) (foo '(1 2 3 4))) (and (eq (do* ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (return 'right) (setq sideffect (car x)))) 'right) (eq sideffect 'b) (eq (do* nil ((null foo) (return 1013)) (push (pop foo) sideffect)) 1013) (equal sideffect '(4 3 2 1 . b)) ))) (do-test "test returning mutiple-values" ; return two symbols, then three characters (let ((x nil)) (and (equal (multiple-value-list (do* ((x '(a b c d) (cdr x))) ((null (cddr x)) (values (car x) (cadr x))))) '(c d)) (equal (multiple-value-list (do* nil (T (values '#\y '#\9 '#\q)) nil)) '(#\y #\9 #\q)) ))) (do-test "test can go out of do*" (let ((sideffect nil) (x nil)) (and (null (tagbody (do* ((x '(a b c d) (cdr x))) ((null x) 'nope) (if (eq (car x) 'c) (progn (setq sideffect (cons 'right x)) (go dotag)) (setq sideffect (car x)))) dotag)) (equal sideffect '(right c d)) ))) (do-test "test can throw a value out of do*" (let ((x nil)) (and (equal (catch 'looptag (do* ((x '("a" "small" "little" "string") (cdr x))) ((null x) 'nope) (if (equal (car x) "little") (throw 'looptag "have a nice day")))) "have a nice day") ))) (do-test "use several different functions to stop" (let ((x nil)) (and (equal (do* ((x '(1 2 3 4 5) (cdr x))) ((> (car x) 3) (car x))) 4) (equal (do* ((x '(1 b "Hi" '(a b c)) (cdr x))) ((stringp (car x)) (car x))) "Hi") (equal (do* ((x '(1 b "Hi" '(a b c)) (cdr x))) ((if (symbolp (car x)) T) (car x))) 'b) ))) ;; Do some serial testing ;; this is different in DO (do-test "test serial evaluation setting initial values" (let ((x nil)) (and (do* ((x '(a b c d)) (y (cdr x))) (nil) (return (and (equal x '(a b c d)) (equal y '(b c d))))) (do* ((x '(a b c d)) (y (cdr x))) (T (and (equal x '(a b c d)) (equal y '(b c d))))) ))) (do-test "test serial evaluation for incrementing values" (let ((x nil)) (eq (do* ((x 1 (+ x 1)) (y 2 (+ x 2))) ((> x 5) y)) 8) )) (do-test "test both parallel setting and incrementing" (let ((sideffect nil) (x nil) (y nil)) (and (eq (do* ((x '(a b c d e f) (cdr y)) (y (cdr x) (cdr x))) ((or (null x) (null y)) 'done) (push (cons (car x) (car y)) sideffect)) 'done) (equal sideffect '((e . f)(c . d) (a . b))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOLIST.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOLIST.TEST new file mode 100644 index 00000000..16112402 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOLIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: dolist ;; ;; Source: Steele's book ;; Section 7.8.3: Simple Iteration Constructs ;; Page: 126 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: October 23, 1986 ;; Creation Date: October 27, 1986 HC3/ broke into several tests ;; ;; Last Update: ;; ;; Filed As: {ERIS}CML>TEST>7-8-3-dostar.TEST ;; ;; ;; Syntax: (dolist (var listform [result]) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; listform is evaluated returning a list. The the body ;; is executed, once for each element in the list, in order, ;; with var bound to the element. Then resultform is ;; evaluated and the result is the value of the dolist form. ;; ;; ;; ;; Argument(s): LISTFORM - evaluated to build a list ;; RESULT - creates the value for dolist ;; DECLARATION - ;; TAG - for go ;; STATEMENT - where do the work ;; ;; Returns: If allowed to finish the list DOLIST will ;; return the value of RESULT. If control is ;; aborted during the iteration, then the ;; value of DOLIST depends on how it was aborted. ;; (do-test "test the simple cases" (and (dolist (aitem '(a) T) nil) (dolist (aitem '(a b c d e) T) nil) (eq (dolist (aitem '(a b c) aitem)) nil) (eq (dolist (aitem nil) nil) nil) (catch 'looptag (dolist (aitem '(a)) (throw 'looptag T))) (dolist (aitem '(a) nil) (return T)) (dolist (aitem '(a b c d e) (null aitem)) nil) )) (do-test "test building lists by function" ; again the question about how smart the compilier is ; do we really need to have a function here? (flet ((listnum nil '(1 2 3 4 5)) (listsym nil '(a b c d e f)) (listchar nil '(#\a #\b #\c))) (let ((sideffect nil) (oldval nil)) (and (eq (dolist (aitem (listnum) oldval) (setq oldval aitem) (push aitem sideffect)) 5) (equal sideffect '(5 4 3 2 1)) (null (setq sideffect nil)) (eq (dolist (aitem (listsym) oldval) (setq oldval aitem) (push aitem sideffect)) 'f) (equal sideffect '(f e d c b a)) (null (setq sideffect nil)) (equal (dolist (aitem (listchar) sideffect) (setq oldval aitem) (push aitem sideffect)) '(#\c #\b #\a)) (eq oldval #\c) (null (setq sideffect nil)) (eq (dolist (aitem (append '(a b) '(c d) '()) oldval) (setq oldval aitem) (push aitem sideffect)) 'd) (equal sideffect '(d c b a)) )))) (do-test "test various variable types in list" ; first pass back a list, then single value ; again the question about how smart the compilier is ; do we really need to have a function here? (let ((sideffect nil) (oldval nil)) (and (equal (dolist (aitem '(2/3 4/5 6/7) sideffect) (setq oldval aitem) (push aitem sideffect)) '(6/7 4/5 2/3)) (equal oldval 6/7) (null (setq sideffect nil)) (eq (dolist (aitem '(#\a #\b #\c #\d) oldval) (setq oldval aitem) (push aitem sideffect)) #\d) (equal sideffect '(#\d #\c #\b #\a)) (null (setq sideffect nil)) (equal (dolist (aitem '("a" "little" "string") oldval) (setq oldval aitem) (push aitem sideffect)) "string") (equal sideffect '("string" "little" "a")) ))) (do-test "test termination, use when" (let ((sideffect nil)) (and (equal (dolist (aitem '(1 2 3 4 5 6 7) sideffect) (push aitem sideffect) (when (> aitem 4) (return "hello"))) "hello") (equal sideffect '(5 4 3 2 1)) (null (setq sideffect nil)) (null (tagbody (dolist (aitem '(a b c d) sideffect) (push aitem sideffect) (when (eq aitem 'c) (go dotag))) dotag)) (equal sideffect '(c b a)) (null (setq sideffect nil)) (eq (catch 'looptag (dolist (aitem '("a" "b" "c" "d" "e") sideffect) (push aitem sideffect) (when (equal aitem "d") (throw 'looptag #\y)))) #\y) (equal sideffect '("d" "c" "b" "a")) ))) (do-test "test with unless, case, typecase" (let ((sideffect nil)) (and (equal (dolist (aitem '(1 2 3 4 5 6 7) sideffect) (push aitem sideffect) (unless (< aitem 4) (return "hello"))) "hello") (equal sideffect '(4 3 2 1)) (null (setq sideffect nil)) (null (tagbody (dolist (aitem '(a b c d) sideffect) (push aitem sideffect) (case aitem ('c (go dotag)))) dotag)) (equal sideffect '(c b a)) (null (setq sideffect nil)) (eq (catch 'looptag (dolist (aitem '(1 a "b" (c) 4/5) sideffect) (push aitem sideffect) (typecase aitem (list (throw 'looptag #\y))))) #\y) (equal sideffect '((c) "b" a 1 )) ))) (do-test "test return mutiple-values" ; first return two symbols, then three characters (and (equal (multiple-value-list (dolist (aitem '(a b c d) (values 'a 'b 'c)) nil)) '(a b c)) (equal (multiple-value-list (dolist (aitem '(#\x #\y #\z) (values 5 6 7)) nil)) '(5 6 7)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOTIMES.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOTIMES.TEST new file mode 100644 index 00000000..9a7db00e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-3-DOTIMES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: dotimes ;; ;; Source: Steele's book ;; Section 7.8.3: Simple Iteration Constructs ;; Page: 126 ;; ;; Created By: Henry Cate III ;; ;; Creation Date: October 23, 1986 ;; ;; Last Update: October 27,1986 HC3/ broke into several tests ;; ;; Filed As: {ERIS}CML>TEST>7-8-3-dotimes.TEST ;; ;; ;; Syntax: (dotimes (var countform [result]) ;; {declaration}* {tag | statement}*) ;; ;; ;; Function Description: ;; countform is evaluated returning an integer. Then the body ;; is executed, once for each integer from 0 to what counform ;; returned, minus one with the var bound to the indexing value. ;; Then resultform is evaluated and the result is the value of ;; the dotimes form. ;; ;; ;; ;; Argument(s): COUNTFORM - evaluated to build a list ;; RESULT - creates the value for dolist ;; DECLARATION - ;; TAG - for go ;; STATEMENT - where do the work ;; ;; Returns: If allowed to finish the list DOTIMES will ;; return the value of RESULT. If control is ;; aborted during the iteration, then the ;; value of DOLIST depends on how it was aborted. ;; (do-test "test the simple cases" (and (dotimes (i 3 T) nil) (dotimes (i 2 T) (return T)) (catch 'looptag (dotimes (i 5) (throw 'looptag t))) (eq (dotimes (i 5 i) nil) 5) (eq (dotimes (i 4) T) nil) (eq (dotimes (i 0 i)) 0) (eq (dotimes (i -5 i)) 0) )) (do-test "test it loops the right number of times" (let ((tmpcnt 0)) (and (dotimes (i 10 (and (eq i 10) (eq tmpcnt 10))) (setq tmpcnt (+ tmpcnt 1))) (eq (setq tmpcnt 0) 0) (dotimes (i 6 (and (eq i 6) (eq tmpcnt 6))) (setq tmpcnt (+ tmpcnt 1))) (eq (setq tmpcnt 0) 0) (dotimes (i 65 (and (eq i 65) (eq tmpcnt 65))) (setq tmpcnt (+ tmpcnt 1))) ))) (do-test "test able to return different types of values" (and (eq (dotimes (i 10 13) nil) 13) (equal (dotimes (i 19 '(6 1)) nil) '(6 1)) (eq (dotimes (i 21 'KY) nil) 'KY) (equal (dotimes (i 11 '(6 C J)) nil) '(6 C J)) (eq (dotimes (i 8 #\L) nil) #\L) (equal (dotimes (i 5 '(#\L #\L)) nil) '(#\L #\L)) (equal (dotimes (i 9 "MB") nil) "MB") (equal (dotimes (i 11 '("a" "b" "c")) nil) '("a" "b" "c")) )) (do-test "test able to build integer by function" ; again the question about how smart the compilier is ; do we really need to have a function here? (flet ((Buildnum1 (x) (+ x x)) (Buildnum2 (x) (* x x)) (Buildnum3 (x) (+ x 5))) (let ((sideffect nil)) (and (eq (dotimes (i (buildnum1 3) i) (push i sideffect)) 6) (equal sideffect '(5 4 3 2 1 0)) (null (setq sideffect nil)) (eq (dotimes (i (buildnum2 2) i) (push i sideffect)) 4) (equal sideffect '(3 2 1 0)) (null (setq sideffect nil)) (eq (dotimes (i (buildnum3 1) i) (push i sideffect)) 6) (equal sideffect '(5 4 3 2 1 0)) (null (setq sideffect nil)) (eq (dotimes (i (- (buildnum3 6) (buildnum1 4)) i) (push i sideffect)) 3) (equal sideffect '(2 1 0)) )))) (do-test "test can do several statements inside" (let ((sideffect nil)) (and (eq (dotimes (i (+ 3 4) i) (push i sideffect) (pop sideffect) (push i sideffect) (pop sideffect) (push i sideffect)) 7) (equal sideffect '(6 5 4 3 2 1 0)) ))) (do-test "test termination, use when" (let ((sideffect nil)) (and (equal (dotimes (i (* 2 10) i) (push i sideffect) (when (> i 4) (return "hello"))) "hello") (equal sideffect '(5 4 3 2 1 0)) (null (setq sideffect nil)) (null (tagbody (dotimes (i (* 5 5) i) (push i sideffect) (when (eq i 4) (go dotag))) dotag)) (equal sideffect '(4 3 2 1 0)) (null (setq sideffect nil)) (eq (catch 'looptag (dotimes (i (+ 20 20) i) (push i sideffect) (when (eq i 3) (throw 'looptag #\y)))) #\y) (equal sideffect '(3 2 1 0)) ))) (do-test "test with unless, case, typecase" (let ((sideffect nil)) (and (equal (dotimes (i 6 i) (push i sideffect) (unless (< i 4) (return "hello"))) "hello") (equal sideffect '(4 3 2 1 0)) (null (setq sideffect nil)) (null (tagbody (dotimes (i 10 i) (push i sideffect) (case i (0 (push (cos 0) sideffect)) (1 (push (* i 5) sideffect)) (2 (go dotag)))) dotag)) (equal sideffect '(2 5 1 1.0 0)) (null (setq sideffect nil)) (eq (catch 'looptag (dotimes (i 10 i) (push i sideffect) (typecase i (number (throw 'looptag #\y))))) #\y) (equal sideffect '(0)) ))) (do-test "test able to return multiple-values" ; first return two symbols, then three characters (and (equal (multiple-value-list (dotimes (i 5 (values 'a 'b 'c)) nil)) '(a b c)) (equal (multiple-value-list (dotimes (i 5 (values 5 6 7)) nil)) '(5 6 7)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPC.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPC.TEST new file mode 100644 index 00000000..1324a254 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPC.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPC ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - removed nil lists from mapc test1 as it is an illegal construct on the SUN ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPC.TEST ;; ;; ;; Syntax: (MAPC FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; ;;(do-test "test mapc0 - syntax checking" ;; (not (or (nlsetq (mapc #'+)) ;; (nlsetq (mapc #'- '(1 2 3) 4 5 6)) ;; (nlsetq (mapc #'* 'a 'b 'c 'd (list 3 6 9))) ;; (nlsetq (mapc #'car (+ 2 3) (char-code #\a) (cons 1 2))) ;; (prog1 nil (makunbound 'fun)) ;; ; non-existing function ;; (nlsetq (mapc #'fun '(1))) ;; (nlsetq (mapc 'm 'n 'o 'p)) ;; ; missing argument(s) ;; (nlsetq (mapc #'(lambda (x) (list x)))) ;; ; non-function type ;; (nlsetq (mapc #'progn '(list 1 2)))))) (do-test "test mapc1 - make sure MAPC always returns the first list argument" (and (equal (mapc #'+ '(1 2 3) '(4 5 6) '(9 8 7)) '(1 2 3)) (equal (mapc #'- '(1) '(2 3) '(-9 -8 -7)) '(1)) (equal (mapc #'* '(100 200) '(3 4)) '(100 200)) (equal (mapc #'list (cdr '(a)) '(9 8)) nil) (equal (mapc #'append '() '((1 2))) '()))) (do-test "test mapc2" (let () (defun fun1 (list1) (let (buffer) (list (equal (mapc #'(lambda (x) (setq buffer (cons x buffer))) list1) list1) buffer))) ; (and (equal (fun1 '(1 2 3 4)) '(t (4 3 2 1))) (equal (fun1 '('a 'b 'c 'd 'e `f `g `h `i)) `(t ,(reverse '('a 'b 'c 'd 'e `f `g `h `i)))) (equal (fun1 '( 0 0 1 1 2 2 3 3 4 4 5 5)) (list t (reverse '( 0 0 1 1 2 2 3 3 4 4 5 5))))))) (do-test "test mapc3" (and (equal (mapc #'(lambda (x y z) (set x (make-list y :initial-element z))) '(n1 n2 n3 n4) '(5 10 15 20) '(a b c d)) '(n1 n2 n3 n4)) (equal n1 (prog1 '(a a a a a))) (equal n2 (prog2 (setq z '(b b b b b)) (append z z))) (equal n3 (progn (setq z '(c c c c c)) (append z z z))) (equal n4 (progn (setq z '(d d d d d)) (append z z z z))) ; (equal (mapc #'makunbound '(n1 n2 n3 n4)) '(n1 n2 n3 n4)) ; (notany #'boundp '(n1 n2 n3 n4)))) (do-test "test mapc4" (progn (setq nlist '((1 2) (1 2 3 4) (1 2 3 4 5) (1 2 3 4 5 6 7 8))) (defun fun (ntimes) (setq n4 (pop nlist) n3 (pop nlist) n2 (pop nlist) n1 (pop nlist)) (push n1 nlist) (push n2 nlist) (push n3 nlist) (push n4 nlist) (mapc #'(lambda (x y) (set x (nthcdr y (symbol-value x)))) '(n1 n2 n3 n4) ntimes)) ; (and (fun '(7 4 3 1)) (equal n1 '(8)) (equal n2 '(5)) (equal n3 '(4)) (equal n4 '(2)) (fun '(7 4)) (equal n1 '(8)) (equal n2 '(5)) (equal n3 '(1 2 3 4)) (equal n4 '(1 2)) (fun '(5 2 1)) (equal n1 '(6 7 8)) (equal n2 '(3 4 5)) (equal n3 '(2 3 4)) (equal n4 '(1 2)) (fun '(8 5 4)) (not (or n1 n2 n3 (not (equal n4 '(1 2)))))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAN.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAN.TEST new file mode 100644 index 00000000..5aaa6a64 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAN.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPCAN ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPCAN.TEST ;; ;; ;; Syntax: (MAPCAN FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (DO-TEST "TEST MAPCAN0" t) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAR.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAR.TEST new file mode 100644 index 00000000..46a4002e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPCAR ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye,Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPCAR.TEST ;; ;; ;; Syntax: (MAPCAR FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; ;; ;;(do-test "test mapcar0 - syntax checking" ;; (not (or (nlsetq (mapcar #'+)) ;; (nlsetq (mapcar #'- '(1 2 3) 4 5 6)) ;; (nlsetq (mapcar #'* 'a 'b 'c 'd (list 3 6 9))) ;; (nlsetq (mapcar #'car (+ 2 3) (char-code #\a) (cons 1 2))) ;; (prog1 nil (makunbound 'fun)) ;; (nlsetq (mapcar #'fun '(1))) ;; (nlsetq (mapcar 'm 'n 'o 'p)) ;; (nlsetq (mapcar #'progn '(1 2)))))) (do-test "test mapcar1 - test cases copied from p128 of CLtL" (and (equal (mapcar #'abs '(3 -4 2 -5 -6)) '(3 4 2 5 6)) (equal (mapcar #'cons '(a b c) '(1 2 3)) '((a . 1) (b . 2) (c . 3))))) (do-test "test mapcar2 - sqrt & gcd" (and (equal (mapcar #'sqrt (list 10000 400 9 144 169 81 121 #31r100 #27r100 #17r10000)) '(100.0 20.0 3.0 12.0 13.0 9.0 11.0 31.0 27.0 289.0)) (equal (mapcar #'gcd '(10 3 9) '(20 9 45) '(30 27 54)) '(10 3 9)))) (do-test "test mapcar3 - max & append" (and (equal (mapcar #'max '(10 20 30 40 50) '(1 200 3 49 5)) '(10 200 30 49 50)) (equal (mapcar #'append '((2 4 6) (1 3 5)) '((12 14 16) (11 13 15))) '((2 4 6 12 14 16)(1 3 5 11 13 15))))) (do-test "test mapcar4 - subst & list & null" (and (equal (mapcar #'subst '(hat ball pink) '(chair pen blue) '((this is my chair) (that is your pen) (blue is a nice color))) '((this is my hat) (that is your ball) (pink is a nice color))) (equal (mapcar #'list '(1) '(2) `(,(+ 1 2)) (list 4) (cons 5 nil) (car '((6))) '(7) '(8) (cdr '(nil 9)) '(10) '(11) (list (- 14 2)) (progn '(13)) `(,#14r10) (union '(15) nil)) '((1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) (equal (mapcar #'null (list t nil 'non-nil '())) '(nil t nil t)))) (do-test "test mapcar5 - lambda list" (equal (mapcar #'(lambda (fn1 fn2 fn3) (let ((x 10) (y 20)) (list (funcall fn1 x y) (funcall fn2 x y) (funcall fn3 x y)))) '(+ - *) '(gcd >= cons) '(list eq min)) '((30 10 (10 20)) (-10 nil nil) (200 (10 . 20) 10)))) (do-test "test mapcar6 - tests with different length of lists" (and (equal (mapcar #'>= '(8 20 93) '(87 -40 900 -2) '(2 81 90)) '(nil nil nil)) (equal (mapcar #'expt '(2 4 6) '(1)) '(2)) (eq (mapcar #'+ '(1 2 3) '()) nil))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCON.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCON.TEST new file mode 100644 index 00000000..fa811802 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPCON.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPCON ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPCON.TEST ;; ;; ;; Syntax: (MAPCON FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (DO-TEST "TEST MAPCON - AR 7987" (and (eq (mapcon 'car '(1)) 1) (equal (mapcon 'car '((1 2) 3)) '(1 2 . 3)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPL.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPL.TEST new file mode 100644 index 00000000..5f4d4455 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPL.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPL ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPL.TEST ;; ;; ;; Syntax: (MAPL FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (do-test "test mapl1" (let (list1 foo-var bar-var) (setq list1 '(foo bar foo bar)) (setq list1 (append list1 list1 list1 list1 list1)) (and (equal (mapl #'(lambda (x) (cond ((evenp (list-length x)) (push (car x) foo-var)) (t (push (car x) bar-var)))) list1) list1) (equal foo-var (make-list 10 :initial-element 'foo)) (equal bar-var (make-list 10 :initial-element 'bar))))) (do-test "test mapl2" (progn (defun fun (l1 l2) (let (result) (and (equal (mapl #'(lambda (x y) (cond ((member (car x) y) (setq result (append result '(1)))) (t (setq result (append result '(0)))))) l1 l2) l1) result))) (and (equal (fun '(1 2) '(2 2)) '(0 1)) (eq (fun '(1 2) nil) nil) (equal (fun '(4 2 6 4 2 2 2 6 8) '(4 6 8)) '(1 0 0)) (equal (fun '(1 3 5 7) '(3 5 1)) '(1 0 0))))) (do-test "test map13" (let (result) (defun fun (v w x y z) (equal (mapl #'(lambda (n1 n2 n3 n4 n5) (push (append n1 n2 n3 n4 n5) result)) z y x w v) z)) (and (fun '(1 2 4) '(3 5 7) '(2 4 6) '(10 20 30) '(99 88 77)) (= 3 (list-length result)) (equal (car result) '(77 30 6 7 4)) (equal (cadr result) '(88 77 20 30 4 6 5 7 2 4)) ; (prog1 1 (setq result nil)) (fun '(1 2 4) '(3 5 7) '(2 4 6) '(10 20 30) '()) (eq result nil) ; (prog1 1 (setq result nil)) (fun '(#\l #\k #\n) '("l" "k" "n") '(l k) '((l) (k)) '(88 99 00)) (= 2 (list-length result)) (equal (car result) '(99 00 (k) k "k" "n" #\k #\n)) (equal (cadr result) '(88 99 00 (l) (k) l k "l" "k" "n" #\l #\k #\n))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPLIST.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPLIST.TEST new file mode 100644 index 00000000..bbe93d9b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPLIST.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: MAPLIST ;; ;; Source: Guy L Steele's CLTL ;; Section: 7.8-4 Mapping ;; Page: 128 ;; ;; Created By: Karin M. Sye, Kelly Roach ;; ;; Creation Date: June 27,1986 ;; ;; Last Update: June 27,1986 ;; ;; Filed As: {ERIS}CML>TEST>7-8-4-MAPLIST.TEST ;; ;; ;; Syntax: (MAPLIST FUNCTION LIST &REST MORE-LISTS) ;; ;; Function Description: ;; For each these mapping functions, ;; the first argument is a function and the rest must be lists. ;; The function must take as many arguments as there are lists. ;; ;; MAPCAR operates on successive elements of the lists. ;; First the function is applied to the CAR of each list, ;; then to the CADR of each list, and so on. ;; (Ideally all the lists are the same length; if not, ;; the iteration terminates when the shortest list runs out, ;; and excess elements in other lists are ignored.) ;; The value returned by MAPCAR is a list of the ;; results of the successive calls to the function. ;; For example: ;; ;; (MAPCAR #'ABS '(3 -4 2 -5 -6)) => (3 4 2 5 6) ;; (MAPCAR #'CONS '(A B C) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) ;; ;; ;; MAPLIST is like MAPCAR except that the function is applied to ;; the list and successive cdr's of that list rather than to successive ;; elements of the list. ;; For example: ;; ;; (MAPLIST #'(LAMBDA (X) (CONS 'FOO X)) ;; '(A B C D)) ;; ;; => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) ;; (MAPLIST #'(LAMBDA (X) (IF (MEMBER (CAR X) (CDR X)) 0 1))) ;; '(A B A C D B C)) ;; => (0 0 1 0 1 1 1) ;; ;An entry is 1 if the corresponding element of the input ;; ; list was the last instance of that element in the input list. ;; ;; ;; MAPL and MAPC are like MAPLIST and MAPCAR ;; respectively, except that they do not accumulate the results ;; of calling the function. ;; Compatibility note: In all Lisp systems since Lisp 1.5, ;; MAPL has been called MAP. In the chapter on sequences ;; ;; it is explained why this was a bad choice. Here the name MAP ;; is used for the far more useful generic sequence mapper, ;; in closer accordance to the computer science literature, ;; especially the growing body of papers on functional programming. ;; These functions are used when the function is being called merely for its ;; side effects, rather than its returned values. ;; The value returned by MAPL or MAPC is the second argument, ;; that is, the first sequence argument. ;; ;; MAPCAN and MAPCON are like MAPCAR and MAPLIST respectively, ;; except that they combine the results of ;; the function using function NCONC instead of LIST. That is, ;; ;; (MAPCON F X1 ... XN) ;; = (APPLY #'NCONC (MAPLIST F X1 ... XN)) ;; ;; and similarly for the relationship between MAPCAN and MAPCAR. ;; Conceptually, these functions allow the mapped function to return ;; a variable number of items to be put into the output list. ;; This is particularly useful for effectively returning zero or one item: ;; ;; (MAPCAN #'(LAMBDA (X) (AND (NUMBERP X) (LIST X))) ;; '(A 1 B C 3 4 D 5)) ;; ;; => (1 3 4 5) ;; ;; In this case the function serves as a filter; this is a standard Lisp ;; idiom using MAPCAN. ;; (The function function REMOVE-IF-NOT might have been useful in this ;; particular context, however.) ;; Remember that NCONC is a destructive operation, and therefore ;; so are MAPCAN and MAPCON; the lists returned by the FUNCTION ;; are altered in order to concatenate them. ;; ;; Sometimes a DO or a straightforward recursion is preferable to a ;; mapping operation; however, the mapping functions should be used wherever they ;; naturally apply because this increases the clarity of the code. ;; ;; The functional argument to a mapping function must be acceptable ;; to APPLY; it cannot be a macro or the name of a special form. ;; Of course, there is nothing wrong with using a function that has ;; and parameters as the functional argument. ;; ;; Argument(s): FUNCTION - a function ;; LIST - a pure list ;; MORE-LISTS - a pure list ;; ;; Returns: a pure list ;; (do-test "test maplist1 - test cases from page 129 of CLtL" (and (equal (maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) '((foo a b c d) (foo b c d) (foo c d) (foo d))) (equal (maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c)) '(0 0 1 0 1 1 1)))) (do-test "test maplist2 - append & first & butlast" (and (equal (maplist #'append (list 1 2 3 4) (cons 5 (cons 6 (cons 7 (cons 8 nil))))) '((1 2 3 4 5 6 7 8) (2 3 4 6 7 8) (3 4 7 8) (4 8))) (equal (maplist #'first '('x 'e 'r 'o 'x )) '('x 'e 'r 'o 'x)) (equal (maplist #'butlast '(1 2 3 4 5 6 7 8)) '((1 2 3 4 5 6 7) (2 3 4 5 6 7) (3 4 5 6 7) (4 5 6 7) (5 6 7) (6 7) (7) nil)))) (do-test "test maplist3 - list-length " (and (setq long-list (maplist #'list-length (make-list 50))) (= (apply #'+ long-list) (/ (* 50 51) 2)))) (do-test "test maplist4 - lambda function" (equal (maplist #'(lambda (x y z) (append (reverse x) (reverse y) (reverse z))) `(a c e) `(b a k) `(l o p)) '((e c a k a b p o l) (e c k a p o) (e k p)))) (do-test "test maplist5 - tests for different length of lists" (and (equal (maplist #'(lambda (x y) (+ (list-length x) (list-length y))) '(1 2) '(2 3 4)) '(5 3)) (eq (maplist #'list `(a b c) nil) nil) (equal (maplist #'cons `(a b c) `(d e)) '(((a b c) d e) ((b c) e))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPPER.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPPER.TEST new file mode 100644 index 00000000..34766631 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-4-MAPPER.TEST @@ -0,0 +1 @@ +(do-test mapcar (let (sideffect) (and ; Simple stuff first (equal (mapcar #'abs '(3 -4 2 -5 -6)) '(3 4 2 5 6)) ; Two lists (equal (mapcar #'cons '(a b c) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Two lists of uneven lengths (equal (mapcar #'cons '(a b c) '(1 2 3 4)) '((a . 1) (b . 2) (c . 3))) ; And the other way, just in case (equal (mapcar #'cons '(a b c d) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Test of (go) out of mapcar (null (tagbody (mapcar #'(lambda (x) (if (eq x 'c) (go mapcartag) (push x sideffect))) '(a b c d)) mapcartag)) (equal sideffect '(b a)) ))) (do-test mapc (let (sideffect) (and ; Simple stuff first (progn (setq sideffect nil) (equal (mapc #'(lambda (x) (push (abs x) sideffect)) '(3 -4 2 -5 -6)) '(3 -4 2 -5 -6)) ) (equal sideffect '(6 5 2 4 3)) ; Two lists (progn (setq sideffect nil) (equal (mapc #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(1 2 3)) '(a b c)) ) (equal sideffect '((c . 3) (b . 2) (a . 1))) ; Two lists of uneven lengths (progn (setq sideffect nil) (equal (mapc #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(1 2 3 4)) '(a b c)) ) ; And the other way, just in case (progn (setq sideffect nil) (equal (mapc #'(lambda (x y) (push (cons x y) sideffect)) '(a b c d) '(1 2 3)) '(a b c d)) ) (equal sideffect '((c . 3) (b . 2) (a . 1))) ; Testing (go) out of mapc (progn (setq sideffect nil) (null (tagbody (mapc #'(lambda (x) (if (eq x 'c) (go mapctag) (push x sideffect))) '(a b c d)) mapctag)) ) ))) (do-test maplist (let (sideffect) (and ; Simple stuff first (equal (maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) '((foo a b c d) (foo b c d) (foo c d) (foo d))) ; Two lists (equal (maplist #'cons '(a b c) '(d e f)) '(((a b c) d e f) ((b c) e f) ((c) f))) ; Two lists of uneven lengths (equal (maplist #'cons '(a b c) '(d e f g)) '(((a b c) d e f g) ((b c) e f g) ((c) f g))) ; Two lists of uneven lengths the other way (equal (maplist #'cons '(a b c foo) '(d e f)) '(((a b c foo) d e f) ((b c foo) e f) ((c foo) f))) ; Testing (go) out of maplist (null (tagbody (maplist #'(lambda (x) (if (eq (car x) 'c) (go maplisttag) (push x sideffect))) '(a b c d)) maplisttag)) (equal sideffect '((b c d) (a b c d))) ))) (do-test mapl (let (sideffect) (and ; Simple stuff first (equal (mapl #'(lambda (x) (push (cons 'foo x) sideffect)) '(a b c d)) '(a b c d)) (equal sideffect '((foo d) (foo c d) (foo b c d) (foo a b c d))) ; Two lists (progn (setq sideffect nil) (equal (mapl #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(d e f)) '(a b c)) ) (equal sideffect '(((c) f) ((b c) e f) ((a b c) d e f))) ; Two lists of uneven lengths (progn (setq sideffect nil) (equal (mapl #'(lambda (x y) (push (cons x y) sideffect)) '(a b c) '(d e f g)) '(a b c)) ) (equal sideffect '(((c) f g) ((b c) e f g) ((a b c) d e f g))) ; Two lists of uneven lengths the other way (progn (setq sideffect nil) (equal (mapl #'(lambda (x y) (push (cons x y) sideffect)) '(a b c foo) '(d e f)) '(a b c foo)) ) (equal sideffect '(((c foo) f) ((b c foo) e f) ((a b c foo) d e f))) ; Testing (go) out of mapl (progn (setq sideffect nil) (null (tagbody (mapl #'(lambda (x) (if (eq (car x) 'c) (go mapltag) (push x sideffect))) '(a b c d)) mapltag)) ) (equal sideffect '((b c d) (a b c d))) ))) (do-test mapcan (let (sideffect) (and ; Simple stuff first (equal (mapcan #'(lambda (x) (list (abs x))) '(3 -4 2 -5 -6)) '(3 4 2 5 6)) ; Two lists (equal (mapcan #'(lambda (x y) (list (cons x y))) '(a b c) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Two lists of uneven lengths (equal (mapcan #'(lambda (x y) (list (cons x y))) '(a b c) '(1 2 3 4)) '((a . 1) (b . 2) (c . 3))) ; And the other way, just in case (equal (mapcan #'(lambda (x y) (list (cons x y))) '(a b c d) '(1 2 3)) '((a . 1) (b . 2) (c . 3))) ; Testing (go) out of mapcan (null (tagbody (mapcan #'(lambda (x) (if (eq x 'c) (go mapcantag) (progn (push x sideffect) (list x)))) '(a b c d)) mapcantag)) (equal sideffect '(b a)) ))) (do-test mapcon (let (sideffect) (and ; Simple stuff first (equal (mapcon #'(lambda (x) (list (cons 'foo x))) '(a b c d)) '((foo a b c d) (foo b c d) (foo c d) (foo d))) ; Two lists (equal (mapcon #'(lambda (x y) (list (cons x y))) '(a b c) '(d e f)) '(((a b c) d e f) ((b c) e f) ((c) f))) ; Two lists of uneven lengths (equal (mapcon #'(lambda (x y) (list (cons x y))) '(a b c) '(d e f g)) '(((a b c) d e f g) ((b c) e f g) ((c) f g))) ; Two lists of uneven lengths the other way (equal (mapcon #'(lambda (x y) (list (cons x y))) '(a b c foo) '(d e f)) '(((a b c foo) d e f) ((b c foo) e f) ((c foo) f))) ; Testing (go) out of mapcon (null (tagbody (mapcon #'(lambda (x) (if (eq (car x) 'c) (go mapcontag) (progn (push (car x) sideffect) (list x)))) '(a b c d)) mapcontag)) (equal sideffect '(b a)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-5-GO.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-GO.TEST new file mode 100644 index 00000000..5fff190c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-GO.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: go ;; ;; Source: CLtL Section 7.8.5: The "Program Feature" Page: 133 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 14 ,1986 ;; ;; Last Update: Oct. 14 ,1986 ;; ;; Filed As: {eris}cml>test>7-8-5-go.test ;; ;; ;; Syntax: go TAG ;; ;; Function Description: The (go tag) special form is used to do a "goto" within a tagbody construct. ;; It transfers control to the point in the body labelled by a tag eql to the one given. ;; ;; Argument(s): TAG - a symbol or an integer ;; ;; Returns: This form does not ever return a value ;; (do-test "test go" ;; ;; the test cases were incorporated in 7-8-5-tagbody.test ;; t ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROG.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROG.TEST new file mode 100644 index 00000000..5f0c3df4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROG.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog ;; ;; Source: CLtL Section 7.8.5: The "Program Feature" Page: 131- 133 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 15 ,1986 ;; ;; Last Update: Oct. 15 ,1986 ;; ;; Filed As: {eris}cml>test>7-8-5-prog.test ;; ;; ;; Syntax: prog ({VAR | (VAR [INIT])}*) {DECLARATION}* {TAG | STATEMENT}* ;; ;; Function Description: The prog construct is a synthesis of LET, BLOCK, and TAGBODY, allowing bound variables (processed ;; in parallel ) and the use of RETURN and GO within a single construct. ;; ;; Argument(s): VAR - a variable ;; INIT - a form ;; DECLARATION - ;; TAG - a symbol or an integer ;; STATEMENT - a list ;; ;; Returns: anything ;; (do-test "test prog - slightly modified test cases copied from page 132 of CLtL" (flet (( king-of-confusion (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (prog (x y z) (setq y (car w) z (cdr w)) loop (cond ((null y) (return x)) ((null z) (go err))) rejoin (setq x (cons (cons (car y) (car z)) x)) (setq y (cdr y) z (cdr z)) (go loop) err ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) (go rejoin) ) ) ( prince-of-clarity (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (do ((y (car w) (cdr y)) (z (cdr w) (cdr z)) (x '() (cons (cons (car y) (car z)) x))) ((null y) x) (when (null z) ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) )) ) ) (and (equal (king-of-confusion '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (king-of-confusion '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (king-of-confusion '( () dummy)) '()) (equal (king-of-confusion '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) (equal (prince-of-clarity '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (prince-of-clarity '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (prince-of-clarity '( () dummy)) '()) (equal (prince-of-clarity '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) ) ) ) (do-test-group ( "test prog - prog allows bound variables and returns nil when the end of the body is reached" :before (progn (test-setq a 2 b 4 c 6 d 8 e 10 buf () ))) (do-test "test Prog 0" (and (null (prog ( (a 10) b (c (+ a 2)) d (e (+ a c)) ) (push (list a b c d e) buf)) ) (equal buf '((10 nil 4 nil 8))) (null (prog ( (a (cons b c)) (b (cons a c)) (c (cons c c)) (d (cons c a)) e) (rplaca buf (list e d c a b) ) )) (equal buf '((nil (6 . 2) (6 . 6) (4 . 6) (2 . 6))) ) (null (prog ( (a (evenp b)) (b (eq t a)) (c (and a b)) (d (list a b c)) ) (rplaca buf (list a b c d)) )) (equal buf '((t nil 4 (2 4 6) )) ) ) ) ) (do-test "test prog - go and return statements are allowed" (macrolet (( mac (m n) `(prog (buf (switch t) ) 0 (and switch (go ,m)) (go ,n) 1 (push 1 buf) (go 99) 2 (push 2 buf) (go 6) 3 (push 3 buf) (go 99) 4 (push 4 buf) (go 10) 5 (push 5 buf) (go 99) 6 (push 6 buf) (go 4) 7 (push 7 buf) (go 99) 8 (push 8 buf) (go 1) 9 (push 9 buf) (go 99) 10 (push 10 buf) (go 9) 99 (if switch (or (setq switch nil) (go 0)) (return buf)) ) )) (and (equal (reverse (mac 3 8)) '(3 8 1)) (equal (reverse (mac 2 4)) '(2 6 4 10 9 4 10 9)) (equal (reverse (mac 99 1)) '(1)) (equal (reverse (mac 7 6)) '( 7 6 4 10 9)) (equal (reverse (mac 9 2)) '(9 2 6 4 10 9)) (equal (reverse (mac 99 99)) ()) ) ) ) (do-test "test prog - with declarations" (equal (multiple-value-list (prog ((a 66) (b 88) (c 22) (d 44) (e 10) (f 20) buf) (declare (special a b c d)) (flet (( fun1 (x) (declare (special a b)) (list x (cons a b))) ( fun2 (x) (declare (special c d)) (list (cons c d) x)) ) (push (fun1 e) buf) ;; buf = '( (10 (66 . 88))) (push (fun2 f) buf) ;; buf = '( ((22 . 44) 20) (10 (66 . 88)) ) (let ((a -1) (c -2) (b -3) (d -4)) (push (fun1 a) buf) ;; buf = '( (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (set 'c 1000) ;; set only updates dynamic binding (push (fun2 c) buf) ;; buf = '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (return (values-list buf)) ) ) ) ) '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROGSTAR.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROGSTAR.TEST new file mode 100644 index 00000000..60baa5ca --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-PROGSTAR.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: prog* ;; ;; Source: CLtL Section 7.8.5: The "Program Feature" Page: 131- 133 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 15 ,1986 ;; ;; Last Update: Oct. 15 ,1986 ;; ;; Filed As: {eris}cml>test>7-8-5-progstar.test ;; ;; ;; Syntax: prog* ({VAR | (VAR [INIT])}*) {DECLARATION}* {TAG | STATEMENT}* ;; ;; Function Description: The prog* construct is a synthesis of LET, BLOCK, and TAGBODY, allowing bound variables (processed ;; in serial ) and the use of RETURN and GO within a single construct. ;; ;; Argument(s): VAR - a variable ;; INIT - a form ;; DECLARATION - ;; TAG - a symbol or an integer ;; STATEMENT - a list ;; ;; Returns: anything ;; (do-test "test prog* - slightly modified test cases copied from page 132 of CLtL" (flet (( king-of-confusion (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (prog* (x y z) (setq y (car w) z (cdr w)) loop (cond ((null y) (return x)) ((null z) (go err))) rejoin (setq x (cons (cons (car y) (car z)) x)) (setq y (cdr y) z (cdr z)) (go loop) err ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) (go rejoin) ) ) ( prince-of-clarity (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (do ((y (car w) (cdr y)) (z (cdr w) (cdr z)) (x '() (cons (cons (car y) (car z)) x))) ((null y) x) (when (null z) ;; instead of entering the debugger, z was assinged a list (setq z '(a b c d e f)) )) ) ) (and (equal (king-of-confusion '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (king-of-confusion '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (king-of-confusion '( () dummy)) '()) (equal (king-of-confusion '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) (equal (prince-of-clarity '((1 2 3 4) 11 22 33 44)) '((4 . 44) (3 . 33) (2 . 22) (1 . 11) )) (equal (prince-of-clarity '((1 2 3 4) 11)) '((4 . c) (3 . b) (2 . a) (1 . 11) )) (equal (prince-of-clarity '( () dummy)) '()) (equal (prince-of-clarity '((1 2 3 4 5 6 7 8 9 10))) '((10 . d) (9 . c) (8 . b) (7 . a) (6 . f) (5 . e) (4 . d) (3 . c) (2 . b) (1 . a))) ) ) ) (do-test-group ( "test prog* - prog* allows bound variables and returns nil when the end of the body is reached" :before (progn (test-setq a 2 b 4 c 6 d 8 e 10 buf () ))) (do-test "test Prog 0" (and (null (prog* ( (a 10) b (c (+ a 2)) d (e (+ a c)) ) (push (list a b c d e) buf)) ) (equal buf '((10 nil 12 nil 22))) (null (prog* ( (a (cons b c)) (b (cons a c)) (c (cons c c)) (d (cons c a)) e) (rplaca buf (list e d c a b) ) )) (equal buf '(( nil ((6 . 6) 4 . 6) (6 . 6) (4 . 6) ((4 . 6) . 6) ) )) (null (prog* ( (a (evenp b)) (b (eq t a)) (c (and a b)) (d (list a b c)) ) (rplaca buf (list a b c d)) )) (equal buf '((t t t (t t t) )) ) ) ) ) (do-test "test prog* - go and return statements are allowed" (macrolet (( mac (m n) `(prog* (buf (switch t) ) 0 (and switch (go ,m)) (go ,n) 1 (push 1 buf) (go 99) 2 (push 2 buf) (go 6) 3 (push 3 buf) (go 99) 4 (push 4 buf) (go 10) 5 (push 5 buf) (go 99) 6 (push 6 buf) (go 4) 7 (push 7 buf) (go 99) 8 (push 8 buf) (go 1) 9 (push 9 buf) (go 99) 10 (push 10 buf) (go 9) 99 (if switch (or (setq switch nil) (go 0)) (return buf)) ) )) (and (equal (reverse (mac 3 8)) '(3 8 1)) (equal (reverse (mac 2 4)) '(2 6 4 10 9 4 10 9)) (equal (reverse (mac 99 1)) '(1)) (equal (reverse (mac 7 6)) '( 7 6 4 10 9)) (equal (reverse (mac 9 2)) '(9 2 6 4 10 9)) (equal (reverse (mac 99 99)) ()) ) ) ) (do-test "test prog* - with declarations" (equal (multiple-value-list (prog* ((a 66) (b 88) (c 22) (d 44) (e 10) (f 20) buf) (declare (special a b c d)) (flet (( fun1 (x) (declare (special a b)) (list x (cons a b))) ( fun2 (x) (declare (special c d)) (list (cons c d) x)) ) (push (fun1 e) buf) ;; buf = '( (10 (66 . 88))) (push (fun2 f) buf) ;; buf = '( ((22 . 44) 20) (10 (66 . 88)) ) (let ((a -1) (c -2) (b -3) (d -4)) (push (fun1 a) buf) ;; buf = '( (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (set 'c 1000) ;; set only updates dynamic binding (push (fun2 c) buf) ;; buf = '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) (return (values-list buf)) ) ) ) ) '( ((1000 . 44) -2) (-1 (66 . 88)) ((22 . 44) 20) (10 (66 . 88)) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-8-5-TAGBODY.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-TAGBODY.TEST new file mode 100644 index 00000000..4cba6a14 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-8-5-TAGBODY.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: tagbody ;; ;; Source: CLtL Section 7.8.5: The "Program Feature" Page: 130 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 14 ,1986 ;; ;; Last Update: Oct. 14 ,1986 ;; ;; Filed As: {eris}cml>test>7-8-5-tagbody.test ;; ;; ;; Syntax: tagbody {TAG | STATEMENT}* ;; ;; Function Description: EACH ELEMENT OF THE BODY IS PROCESSED FROM LEFT TO RIGHT. A TAG IS IGNORED ; A STATEMENT IS EVALUATED, AND ;; ITS RESULTS ARE DISCARDED. IF THE END OF THE BODY IS REACHED, THE TAGBODY RETURNS NIL. IF (GO TAG) IS ;; EVALUATED, CONTROL JUMPS TO THE PART OF THE BODY LABELLED WITH THE TAG. ;; ;; Argument(s): TAG - a symbol or an integer ;; STATEMENT - a list ;; ;; Returns: nil, if the end of the body is reached. ;; (do-test "test tagbody - a tag may be a symbol or an integer , and it is ignored during the processing" (and (eq (tagbody 20) nil) (eq (tagbody |tag name|) nil) (eq (tagbody another/ tag/ name) nil) (eq (tagbody tagbody may have many tags) nil) (eq (tagbody the following numbers will be treated as tags 1 2 3 4 5 6 7) nil) ) ) (do-test "test tagbody - if the end of body reached, tagbody returns nil" (let ((a 10) (b 20) c) (and (eq (tagbody) nil) (eq (tagbody (incf a 3) (setq a (* a 2)) (decf a) a) nil) (= a 25) (eq (tagbody (incf b) (go tag1) tag2 (incf b 2) (* b 2) tag11 (setq b 0) tag1 (decf b 10) b) nil) (= b 11) (eq (tagbody tag (values a b )) nil) (eq (tagbody (block blk (return-from blk (push 23 c)) (push 34 c)) (push 56 c)) nil) (equal c '(56 23)) ) ) ) (do-test "test tagbody - simple go statment 1" (let (a) (eq (tagbody t1 (setq a (cons "t1" a)) (go t33) t2 (setq a (cons "t2" a)) (go done) t33 t3 (setq a (cons "t3" a)) t4 (setq a (cons "t4" a)) t5 (setq a (cons "t5" a)) (go t77) t6 (setq a (cons "t6" a)) t7 t77 (setq a (cons "t7" a)) t8 (setq a (cons "t8" a)) t9 (setq a (cons "t9" a)) t10 (setq a (cons "t10" a)) (go t2) done (setq a (cons "done !!" a)) ) nil) (equal a '("done !!" "t2" "t10" "t9" "t8" "t7" "t5" "t4" "t3" "t1")) ) ) (do-test "test tagbody - simple go statement 2" (let ((c '(results)) i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 i14 i15 i16 i17 i18 i19 i20 ) (setq i1 20 i2 19 i3 18 i4 17 i5 16 i6 15 i7 14 i8 13 i9 12 i10 11 i11 10 i12 9 i13 8 i14 7 i15 6 i16 5 i17 4 i18 3 i19 2 i20 1 ) (equal (block blk (macrolet ((mac (counter num) `(if (> (decf ,counter) 0) (nconc c (list,num)) (go t1)) )) (tagbody t1 (if (> (decf i1) 0) (nconc c (list 1)) (return-from blk c)) (mac i2 2) (mac i3 3) (mac i4 4) (mac i5 5) (mac i6 6) (mac i7 7) (mac i8 8) (mac i9 9) (mac i10 10) (mac i11 11) (mac i12 12) (mac i13 13) (mac i14 14) (mac i15 15) (mac i16 16) (mac i17 17) (mac i18 18) (mac i19 19) (mac i20 20) ) ) ) (append '(results) (mapcon #'(lambda (x) (reverse x)) '(19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1))) ) ) ) (do-test "test tagbody - go can break up catchers if necessary to get to the target (p131)" (flet ((fun (items elt) (let (a) (tagbody (catch 'stuff (mapcar #'(lambda (x) (if (numberp x) x (progn (push x a) (go lose)))) items) ) lose (nconc a '(is not a number)) ) (equal a (append (list elt) '(is not a number))) ) )) (and (fun '(1 2 3 #\q) #\q) (fun '(10 20 "st" "fre") "st") ) ) ) (do-test "test tagbody - use Go to jump to a tagbody that is not the innermost tagbody containing that go" (let (a) (tagbody (push "t1" a) (tagbody (push "t2" a) (tagbody (push "t3" a) ;; ;; the inner tag shadows the outer one ;; (go g23) (push "wrong3" a) g23 (push "t23" a) (go g10) g30 (push "t30" a) ) g20 (push "t20" a) g23 (push "wrong2" a) ) g10 (push "g10" a) ) (equal a '("g10" "t23" "t3" "t2" "t1")) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST new file mode 100644 index 00000000..64700a3e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST @@ -0,0 +1 @@ +;; ;; Functions tested: BLOCK, DOLIST, DOTIMES, DO, PROG ;; (do-test "test BLOCK - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (block foo (values 1 2 3 4 5))) '(1 2 3 4 5)) (equal (multiple-value-list (block nil (defun fun () (ffloor 99.5)) (return-from nil (fun)) t)) '(99.0 .5)) (equal (multiple-value-list (block |exit 1| (defmacro mac () `(fceiling -99.5)) (return-from |exit 1| (mac)) nil)) '(-99.0 -.5)) (equal (multiple-value-list (block |exit 1| (setq a '(mo mo talo son)) (multiple-value-call #'values (make-list 4 :initial-element (first a)) (make-list 4 :initial-element (last a)) ))) '( (mo mo mo mo) ( (son) (son) (son) (son)) )) ) ) (do-test "test BLOCK - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (block foo (values 1 2 3 4 5))) 1) (eql (foo (block nil (defun fun () (ftruncate 99.5)) (return-from nil (fun)) t)) 99.0) (eql (foo (block |exit 1| (defmacro mac () `(fround -99.5)) (return-from |exit 1| (mac)) nil)) -100.0) (equal (foo (block |exit 1| (setq a '(mo mo talo son)) (multiple-value-call #'values (make-list 4 :initial-element (butlast a)) (make-list 4 :initial-element (last a)) ))) '( (mo mo talo) (mo mo talo) (mo mo talo) (mo mo talo) )) ) ) ) (do-test "test BLOCK - when forms are used for side-effects" (and (equal (progn (setq a '(m n o) b '(w x y)) (block t (values (intersection a b) (union a b))) (list a b)) '((m n o) (w x y)) ) (equal (let ((a 10)) (block tag (incf a 20) (return-from tag (values-list (list a (* a a))))) (list a 'end-of-block) ) '(30 END-OF-BLOCK)) ) ) (do-test "test DOLIST - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (dolist (x '(1 2 3 4 5) (values x x x x x x)) )) '(nil nil nil nil nil nil)) (equal (multiple-value-list (dolist (x '() (values 'grouchy 'sneezy 'doc)) (1+ 9))) '(grouchy sneezy doc)) (equal (multiple-value-list (dolist (x '(tree bird dog green grass) 99) (if (find #\G (symbol-name x)) (return-from nil (values x 'foo1 'foo2))) )) '(dog foo1 foo2)) (equal (multiple-value-list (dolist (x '(#c(1 2) #c(4 2) #c(7 4)) 'dummy) (if (evenp (realpart x)) (return (values x (imagpart x) (realpart x)))) )) '(#c(4 2) 2 4) ) ) ) (do-test "test DOLIST - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (dolist (x '(1 2 3 4 5) (or (values 9 8 7 x x x) 23)) )) '(9)) (equal (multiple-value-list (dolist (x '() (cond ((values 'grouchy 'sneezy 'doc)))) (1+ 9))) '(grouchy)) (equal (multiple-value-list (dolist (x '(tree bird dog green grass) 99) (if (find #\G (symbol-name x)) (return-from nil (cons (values x 'foo1 'foo2) nil))) )) '((dog))) (equal (multiple-value-list (dolist (x '(#c(1 2) #c(4 2) #c(7 4)) 'dummy) (if (evenp (realpart x)) (return (list (values x (realpart x) (imagpart x))))) )) '((#c(4 2))) ) ) ) (do-test "test DOTIMES - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (dotimes (k 0 (values k k k )) )) '(0 0 0)) (equal (multiple-value-list (dotimes (p 4 (decode-float (float p)) ) (1+ p) )) '(.5 3 1.0)) (equal (multiple-value-list (dotimes (k 100 t) (when (= (lcm k 3) 21) (return (values k (expt k 2)))) )) '(7 49)) (equal (multiple-value-list (dotimes (w #b1010 'dot) (unless (< w 6.0) (return-from nil (values-list (make-list w :initial-element w)))) )) '(6 6 6 6 6 6)) ) ) (do-test "test DOTIMES - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (dotimes (k 0 (values k k k )) )) 0) (eql (foo (dotimes (p 4 (decode-float (float p)) ) (1+ p) )) .5 ) (= (1+ (foo (dotimes (k 100 t) (when (= (lcm k 3) 21) (return (values k (expt k 2)))) ))) 8) (eq (foo (dotimes (w #b1010 'dot) (unless (< w 6.0) (return-from nil (values-list (make-list w :initial-element w)))) )) 6) ) ) ) (do-test "test DO - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (do ((i 0 (1+ i)) (var nil (cons i var)) ) ((= i 5) (values (list-length var) var)) )) '(5 (4 3 2 1 0)) ) (equal (multiple-value-list (do ((j '("sneezy" "grouchy" "sleepy" "bashful") (cdr j)) (var nil)) ((endp j) (values var (reverse var)) ) (cond ( (find #\s (first j)) (setq var (cons (first j) var)))) )) '(("bashful" "sleepy" "sneezy") ("sneezy" "sleepy" "bashful")) ) (equal (cdr (multiple-value-list (do ((i 3 (+ 2 i))) ((= i 51) t) (if (= (gcd i 22) i) (return (decode-float (float i)))) ))) '(4 1.0) ) (equal (multiple-value-list (do* ((i 0 (1+ i)) (str "Best wishes to you guys") (size (length str)) ) ((= i size) 'fail) (if (char= (char str i) #\y) (return (values i (fceiling i 2) ))))) '(15 8.0)) ) ) (do-test "test DO - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (equal (multiple-value-list (foo ( do ((i 0 (1+ i)) (var nil (cons i var)) ) ((= i 5) (values (list-length var) var)) ))) '(5)) (equal (multiple-value-list (foo (do ((j '("sneezy" "grouchy" "sleepy" "bashful") (cdr j)) (var nil)) ((endp j) (values var (reverse var)) ) (cond ( (find #\s (first j)) (setq var (cons (first j) var)))) ))) '(("bashful" "sleepy" "sneezy")) ) (equal (multiple-value-list (foo (do ((i 3 (+ 2 i))) ((= i 51) t) (if (= (gcd i 22) i) (return (values i (decode-float (float i))))) ))) '(11) ) (equal (multiple-value-list (foo (do* ((i 0 (1+ i)) (str "Best wishes to you guys") (size (length str)) ) ((= i size) 'fail) (if (char= (char str i) #\y) (return (values i (fceiling i 2) )))))) '(15 )) ) ) ) (do-test "test PROG - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (prog (a b c (d 1) (e 3) f g) (return (values a b c d e f g)))) '(nil nil nil 1 3 nil nil)) (equal (multiple-value-list (prog ((a #x10) (b #x-20) (c #x30)) (go exit) (decf a #x2) (decf b #x3) (incf c #x4) exit (return-from nil (values c b a)) )) (list #b110000 #b-100000 #b10000)) (equal (multiple-value-list (prog ((a #o7) (aa #o10) ( aaa #o20)) (setq exit 'exit1 exit1 'exit2) (go exit) tag1 (decf a) (decf aa) (return-from nil (values-list '(another wrong exit))) exit (incf aaa ) (go exit2) exit1 (decf a #o10) (return (values 'wrong 'exit)) exit2 (return (values aaa aa a) ))) (list #o21 #o10 #o7)) (equal (multiple-value-list (prog ((a '(a)) (b '((b))) (c '(c ((b)) a ((a)))) ) (cond ((member a c :test #'equal) (return (values a c))) ((member b c :test #'equal) (return (values b c)) )))) '( ((b)) (c ((b)) a ((a))) )) ) ) (do-test "test PROG - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (prog (a b c (d 1) (e 3) f g) (return (values e b c d e f g)))) 3) (eq (foo (prog ((a #x10) (b #x-20) (c #x30)) (go exit) (decf a #x2) (decf b #x3) (incf c #x4) exit (return-from nil (values c b a)) )) #b110000) (eq (foo (prog ((a #o7) (aa #o10) ( aaa #o20)) (setq exit 'exit1 exit1 'exit2) (go exit) tag1 (decf a) (decf aa) (return-from nil (values-list '(another wrong exit))) exit (incf aaa ) (go exit2) exit1 (decf a #o10) (return (values 'wrong 'exit)) exit2 (return (values aaa aa a) ))) #o21) (equal (foo (prog ((a '(a)) (b '((b))) (c '(c ((b)) a ((a)))) ) (cond ((member a c :test #'equal) (return (values a c))) ((member b c :test #'equal) (return (values b c)) )))) '((b)) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CATCH.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CATCH.TEST new file mode 100644 index 00000000..bae10496 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CATCH.TEST @@ -0,0 +1 @@ +;; ;; funtion to be tested - catch ;; (do-test "test CATCH - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (catch 'moderato (setq a 2 b 4 d 6) (values (+ a b) (* a d)) )) '(6 12)) (equal (multiple-value-list (catch 'adagio (cond ((= #b10 #o3) (throw 'adagio1 (values 1 2 3))) ((= #b10000 #x10) (throw 'adagio (values 11 22 33))) (t (throw 'adagio2 (values 0 -1 -2))) ))) '(11 22 33)) (equal (multiple-value-list (progn (defun fun () (declare (special var)) (rplacd (last var) '(fun-1)) (fun1) (rplacd (last var) '(fun-2)) ) (defun fun1 () (declare (special var)) (rplacd (last var) '(fun1-1)) (throw 'trill (values var (list-length var))) (rplacd (last var) '(fun1-2)) ) (defun fun0 (var) (declare (special var)) (catch 'trill (rplacd (last var) '(hi)) (fun) (rplacd (last var) '(bye)) )) (setq buf `(hello)) (fun0 buf) ) ) '( (hello hi fun-1 fun1-1) 4) ) ) ) (do-test "test CATCH - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (catch 'summer (values 'swim 'hike 'watermelon))) 'swim) (= (foo (catch 'moderato (setq a 2 b 4 d 6) (values (+ a b) (* a d)) )) 6) (equal (cons (catch 'poco (if t (throw 'poco (values-list '((1 . 2) (3 . 4))) ))) nil) '((1 . 2))) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST new file mode 100644 index 00000000..3884c15f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: IF, AND, OR, and COND ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137-138 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 5,1986 ;; ;; Last Update: August 5,1986 ;; ;; Filed As: {eris}cml>test>7-9-2-mvr-conditional-constructs.test ;; ;; ;; Syntax: [not applicable] ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely these circumstances: ;; ;; ;; Conditional constructs ;; ;; . IF passes back multiple values from whichever subform is selected (the THEN form or the ELSE form). ;; . AND and OR pass back multiple values from the last subform but not from subforms other than the last ;; . COND passes back multiple values from the last subform of the implicit PROGN of the selected clause. if, however, ;; the clause selected is a singleton clause, then only a single value (the non-nil predicate value) is returned. This is ;; true even if the singleton clause is the last clause of the COND. It is not permitted to treat a final clause (x) ;; as being the same as (t x) for this reason; the latter passes back multiple values from the form x. ;; (do-test "test IF - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (if nil nil (values 3 -5 7 -9))) '(3 -5 7 -9)) (equal (multiple-value-list (if t (values 2 -6 40 9) (values 9 40 -6 2))) '(2 -6 40 9)) (equal (multiple-value-list (if (evenp (values 3 8)) (floor 3 8) (floor 8 3))) '(2 2)) (equal (multiple-value-list (if (zerop (1- -1)) (if (evenp 33) (values 7 8 9) (values 17 18 19)) (if (oddp 157) (values -9 -8 -7) (values -4 -3 -2)))) '(-9 -8 -7)) ) ) (do-test "test IF - forms *don't* return multiple values when they *shouldn't* " (and (eq (if nil nil t) 't) (eq (if t (values 3) 55) 3) (equal (if 'non-nil '(foo) '(bar)) '(foo)) (equalp (if () 2.1 3.0) 3) ) ) (do-test "test IF - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (if t (values 'a 'b 'c) 99)) 'a) (equal (foo (if nil 10 (values "pot" "cup" "brush"))) "pot") (eq (foo (if t (values-list '(30 300 3000 30000)))) 30) (equal (foo (if t (values-list '( (neck . body) (rosette . sound-hole) (metal . plastic))))) '(neck . body)) ) ) ) (do-test "test IF - use MULTIPLE-VALUE-LIST for receiving multiple vlaues" (and (equal (multiple-value-list (if nil nil (values #\1 #\2 #\3 #\4))) '(#\1 #\2 #\3 #\4)) (equal (multiple-value-list (if t (values 'value0 '(value1) '((value2)) 'value3) (values 9 40 -6 2))) '(value0 (value1) ((value2)) value3)) ) ) (do-test "test IF - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (x y) (if t (values 10 20 30)) (list x y)) '(10 20)) (equal ( multiple-value-bind (x y z) (if t (values 10 20 30)) (list x y z)) '(10 20 30)) (equal ( multiple-value-bind (x y z q) (if t (values 10 20 30)) (list x y z q)) '(10 20 30 nil)) ) ) (do-test "test IF - when forms are used for effect" (and (eq (progn (if t nil (floor 5 3)) 'prognn) 'prognn) (equal (progn (if t (truncate 30 4)) 'end-of-IF) 'end-of-IF) ) ) (do-test "test AND - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (and 1 2 3 (values 11 22 33))) '(11 22 33)) (equal (multiple-value-list (and 11 (values 'a 'b 'c 'd) (values 'e 'f 'g 'h 'i))) '(e f g h i)) (equal (multiple-value-list (and 'foo1 'foo2 'foo3 t (truncate 123 10))) '(12 3)) (equal (multiple-value-list (and (>= 2 1) (= 2.0 2) (< 1 90) (floor 43 3))) '(14 1)) ) ) (do-test "test AND - forms *don't* return multiple values when they *shouldn't* " (and (equal (and 1 2 3 4 5 6) 6) (equal (and (member 'a '(d a n c e)) (= 3 (car '(3 6 9)))) t) (equal (and (evenp 10) (oddp 33) (zerop 0) (cons (floor 4 3) nil)) '(1)) (equal (and 'a 'b 2 3 () 4 5 'c 'd) ()) ) ) (do-test "test AND - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (and (values 11 22 33 44))) 11) (eq (foo (and 1 3 6 7 (truncate 50 3))) 16) (equal (foo (and "star" "moon" "sun" (values "tree" "rock" "grass"))) "tree") (equal (foo (and '(1 (2)) '((3) 4) (values-list '((5 (6)) (7 . 8))))) '(5 (6))) ) ) ) (do-test "test AND - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal (multiple-value-bind (x y z) (and 1 3 4 5 (values 5 4 3 2)) (list x y z)) '(5 4 3)) (equal (multiple-value-bind (x y z p) (and 1 3 4 5 (values 5 4 3 2)) (list x y z p)) '(5 4 3 2)) (equal (multiple-value-bind (x y z p q) (and 1 3 4 5 (values 5 4 3 2)) (list x y z p q)) '(5 4 3 2 nil)) ) ) (do-test "test AND - when forms are used for effect" (and (eq (and (floor 4 2) (ceiling 8 3) (+ 2 3.4) (1- 34)) 33) (equal (and (values-list (list "a" "b" "c")) "end of AND") "end of AND") ) ) (do-test "test OR - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (or (values 'foo1 'foo2 'foo3 'foo4))) '(foo1 foo2 foo3 foo4)) (equal (multiple-value-list (or nil nil (ffloor 10 3))) '(3.0 1)) (equal (multiple-value-list (or () () (fceiling 9.5))) '(10.0 -0.5)) (equal (multiple-value-list (or nil (not t) (values-list '(the house was ransacked)))) '(the house was ransacked)) ) ) (do-test "test OR - forms *don't* return multiple values when they *shouldn't* " (and ;; OR won't pass back multiple values from subforms which is not the last one ;; (equal (multiple-value-list (or () (cdr '(1)) (truncate 234 100) 99)) '(2)) (equal (multiple-value-list (or (null 'a) (listp 'a) (values-list '(atom a)) (endp '(())) )) '(atom)) (equal (multiple-value-list (or (progn (setq a 120 b 8) (floor a b)) (ceiling a b) (* a b))) '(15)) ;; (equal (or 'foo) 'foo) (eq (or (member 'z '(a b c)) (values (floor 34 11))) 3) (equal (or (null '(())) (cons (floor 45 10) nil) (endp ())) '(4)) (eq (or (intersection '(1) '(2)) (cdr '(2)) (eq 2 2.0)) nil) ) ) (do-test "test OR - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (or (values 1 2 3 4 54))) 1) (equal (foo (or (truncate 10000 999) (* 10000 999) (+ 10000 999))) 10) (equal (foo (or (tailp '(a) '(b a c)) (values-list '("Mozart" "Beethoven" "Bach")) (find #\q "quit"))) "Mozart") (equal (list (floor 57 7)) '(8)) ) ) ) (do-test "test OR - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (or (zerop (1- 2)) (values 10 20 30 40 50 )) (list w x y z)) '(10 20 30 40)) (equal ( multiple-value-bind (v w x y z) (or (zerop (1- 2)) (values 10 20 30 40 50 )) (list v w x y z)) '(10 20 30 40 50)) (equal ( multiple-value-bind (u v w x y z) (or (zerop (1- 2)) (values 10 20 30 40 50 )) (list u v w x y z)) '(10 20 30 40 50 nil)) ) ) (do-test "test OR - when forms are used for effect" (and (equal (progn (setq a 10) (or (and (decf a 3) nil) (floor a 2)) (list a)) '(7)) (equal (progn (or (truncate 200 45) (floor 200 35)) "end-of-or") "end-of-or") ) ) (do-test "test COND - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (cond ( (= 1 3) 13) ( (= 2 2.0) (values 2 2.0 22.0 220)) ( t 'true))) '(2 2.0 22.0 220)) (equal (multiple-value-list (cond ( nil 'fail1) ( (and nil t) 'fail2) ( (or nil t) (values "transfer" "repeat" "* #")))) '("transfer" "repeat" "* #")) (equal (multiple-value-list (cond ( (equal #\a #\A) (values 'char 'equal)) ( (equal 2.0 2) (values 'number 'equal)) (t (values 'pick-up 'sta.speed 'hold 'forward)))) '(pick-up sta.speed hold forward)) ) ) (do-test "test COND - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (cond ( (equal #\a #\A) (values 'char 'equal)) ( (equal 2.0 2) (values 'number 'equal)) ( (values 'pick-up 'sta.speed 'hold 'forward)))) '(pick-up )) (equal (multiple-value-list (cond ( () 10) ((floor 100 9)) (t (* 100 9)))) '(11)) (equal (multiple-value-list (cond ( (values 9 8) 77) ('non-nil 'true))) '(77)) (equal (multiple-value-list (cond ( (= 2 3) (values 2 3)) ( (= 4 5) (values 4 5)) ( (> 5 9) (values 5 9)))) '(())) ) ) (do-test "test COND - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (cond ( (= 1 3) 13) ( (= 2 2.0) (values 2 2.0 22.0 220)) ( t 'true))) 2) (equal (foo (cond ( nil 'fail1) ( (and nil t) 'fail2) ( (or nil t) (values "transfer" "repeat" "* #")))) "transfer") (equal (identity (cond (nil) (t (values-list '(time and tide wait for no one))) (last '(2 3)))) 'time) (equal (list (cond (t (values (floor 8 3) (floor 9 4)))) 3 8 ) '(2 3 8)) ) ) ) (do-test "test COND - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal (multiple-value-bind (a b c) (cond (nil 'dummy1) ((= #5r110 30) (values (truncate 99 8) (truncate 88 77) (truncate 77 2) (truncate 44 3)))) (list a b c)) '(12 1 38)) (equal (multiple-value-bind (a b c d) (cond (nil 'dummy1) ((= #5r110 30) (values (truncate 99 8) (truncate 88 77) (truncate 77 2) (truncate 44 3)))) (list a b c d)) '(12 1 38 14)) (equal (multiple-value-bind (a b c d e) (cond (nil 'dummy1) ((= #5r110 30) (values (truncate 99 8) (truncate 88 77) (truncate 77 2) (truncate 44 3)))) (list a b c d e)) '(12 1 38 14 nil)) ) ) (do-test "test COND - when forms are used for effect" (and (equal (progn (setq a 5 b 20) (cond ((= 5.0 (gcd a b)) (values (incf a 3) (incf b 2))) (t nil)) (list a b)) '(8 22)) (equal (progn (setf a "dance" b "music" c nil d nil) (multiple-value-bind (c d) (cond ((find #\s a) (values a b)) ((find #\u b) (values b a)) (t (values "????" " !!!!!"))) (concatenate 'string d c)) ) "dancemusic") ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-1.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-1.TEST new file mode 100644 index 00000000..8cc4483a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-1.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: DEFUN , DEFMACRO, EVAL-WHEN, PROGV, LET , LET* , MULTIPLE-VALUE-BIND ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 7,1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - many changes to make this pass on ;; the SUN ;; Filed As: {eris}cml>test>7-9-2-MVR-IMPLICIT-PROGN-1.test ;; ;; ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely these circumstances: ;; ;; ;; ;; Implicit PROGN contexts ;; ;; . The special form PROGN passes backs multiple values resulting from evaluation of the last subform. Other situations ;; referred to as "implicit progn," where several forms are evaluated and the results of all but the last form are ;; discarded, also pass back multiple values from the last form. These situations include the body of a lambda-expression, ;; in particular those constructed by DEFUN, DEFMACRO, and DEFTYPE. Also included are bodies of the constructs EVAL-WHEN, ;; PROGV, LET, LET*, WHEN, UNLESS, BLOCK, MULTIPLE-VALUE-BIND, and CATCH, as well as clauses in such conditional constructs ;; as CASE,TYPECASE,ECASE,ETYPECASE, CCASE, and CTYPECASE. ;; ;; (do-test "test DEFUN - forms *do* return multiple values when they *should* " (and (defun fun1 () (values 1 2 3 4 5 6 7 8 9 10)) (equal (multiple-value-list (fun1)) '(1 2 3 4 5 6 7 8 9 10)) (defun fun2 (x) (values-list (list 1 2 3 4 5 6 7 8 9 10 11 12 131 14 15 x)) (equal (multiple-value-list (fun2 888)) '( 1 2 3 4 5 6 7 8 9 10 11 12 131 14 15 888))) (defun fun3 (x y &rest z) (values x y z (decode-float 16.0))) (equal (multiple-value-list (fun3 10 20 "mvr")) '(10 20 ("mvr") .5 )) (defun fun4 (x &optional (y 99) &rest z ) (values (floor x y) z (list x y) ) (equal (multiple-value-list (fun4 98 100 'm 39 'n 38)) '(0 (m 39 n 38) (98 100)))) ) ) (do-test "test DEFUN - forms *don't* return multiple values when they *shouldn't* " (and (defun fun1 () (cond (nil (floor 4 2)) ((ffloor 4 2)) )) (equal (multiple-value-list (fun1)) '(2.0)) (defun fun2 (x &optional (y 2) (z 30.0)) (values (list x (expt x y) (decode-float z)))) (equal (multiple-value-list (fun2 8 )) '((8 64 .9375)) ) (defun fun3 (x y z) (or nil () (values (* y z) (+ y z)) (- y z))) (equal (multiple-value-list (fun3 2 4 6)) '(24)) (defun fun4 (&rest z) (values-list (list z))) (equal (multiple-value-list (fun4 'software 'quality 'assurance)) '((software quality assurance))) ) ) (do-test "test DEFUN - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eql (foo (progn (defun fun () (decode-float -8.0)) (fun))) .5) (equalp (foo (progn (defun fun1 (x y z) (and (values x y z))) (fun1 #\a #\b #\c))) #\A) (equal (cons (progn (defun fun2 (w x y z) (or (values-list (list w x y z))) ) (fun2 "a" "b" "c" "d") ) nil) '("a")) (equal (find (progn (defun fun1 (x y z) (and (values x y z))) (fun1 #\z #\b #\c)) "lazy") #\z) ) ) (do-test "test DEFUN - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (defun fun () (values-list '(zebar monkey dragon deer rabit snake bird turtle sqirrel elephant))) (and (equal ( multiple-value-bind (a b c d e f g h i) (fun) (list a b c d e f g h i) ) '(zebar monkey dragon deer rabit snake bird turtle sqirrel)) (equal ( multiple-value-bind (a b c d e f g h i j) (fun) (list a b c d e f g h i j) ) '(zebar monkey dragon deer rabit snake bird turtle sqirrel elephant)) (equal ( multiple-value-bind (a b c d e f g h i j k) (fun) (list a b c d e f g h i j k) ) '(zebar monkey dragon deer rabit snake bird turtle sqirrel elephant nil)) ) ) (do-test "test DEFUN - when forms are used for effect" (and (eq (progn (defun fun (&key a b) (values a b)) (multiple-value-setq (c d) (fun :a 3 :b 6)) (+ c d)) 9) (equal (progn (defun fun1 (a &optional (b 30) &rest rest &key c d) (values a b rest c d)) (multiple-value-bind (s t1 u v w x y z) (fun1 10 11 :d 14 :c 13) (list s t1 u v w x y z))) '(10 11 (:d 14 :c 13) 13 14 nil nil nil )) ) ) (do-test "test DEFMACRO - forms *do* return multiple values when they *should* " (and (defmacro mac () `(ftruncate 7.5)) (equal (multiple-value-list (mac)) '(7.0 .5)) (defmacro mac (w x y z) (list 'values w x y z )) (equal (multiple-value-list (mac 1 2 3 4)) '(1 2 3 4)) (defmacro mac () `(block bar (return-from bar (values #o111 #b1111 #x-11)))) (equal (multiple-value-bind (a b c d e) (mac) (list a b c d e)) '(73 15 -17 nil nil)) (defmacro mac (m n o) `((lambda (a b &rest c) (values-list (list a b c))) ,m ,n ,o)) (equal (multiple-value-list (mac (complex 3 4) (realpart #c(3 4)) (imagpart #c(3 4)) )) '(#c(3 4) 3 (4)) ) ) ) (do-test "test DEFMACRO - exactly one value is used, if forms are passed as an argument to a function call" (defmacro mac1 () `(ftruncate 7.5)) (defmacro mac2 (w x y z) (list 'values w x y z )) (defmacro mac3 () `(block bar (return-from bar (values #o111 #b1111 #x-11)))) (defmacro mac4 (m n o) `((lambda (a b &rest c) (values-list (list a b c))) ,m ,n ,o)) (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (progn (mac1) )) 7.0) (equal (foo (progn (mac2 (find #\a "chiao") ( expt #c(2 -2) 2) #b-1010 '|good earth|))) #\a) (equal (cons (progn (mac3) ) nil) '(73)) (equal (identity (progn (mac4 (complex 3 4) (realpart #c(3 4)) (imagpart #c(3 4)) )) ) #c(3 4)) ) ) (do-test "test EVAL-WHEN - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (eval-when (eval) (values 1 2 3 4))) '(1 2 3 4)) (equal (multiple-value-list (eval-when (eval) (floor -8.0))) '(-8 .0)) (equal (multiple-value-list (eval-when (eval) (values-list '(Morning has broken just like)))) '(Morning has broken just like) ) (equal (multiple-value-list (eval-when (eval) (decode-float 16.0))) '(.5 5 1.0)) ) ) (do-test "test EVAL-WHEN - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (eval-when (eval) (values 1 2 3 4))) 1) (= (foo (eval-when (eval) (floor -8.0))) -8) (eq (foo (eval-when (eval) (values-list '(Morning has broken just like)))) 'Morning) (= (foo (eval-when (eval) (decode-float 16.0))) .5) ) ) (do-test "test PROGV - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (progn (setq aa 'a bb 'b a 0 b 1) (progv (list aa bb) (list 88 99 111) (values a b)) )) '(88 99)) (equal (multiple-value-list (progn (setq foo 'f bar 'b rah 'r f nil b nil r nil) (progv (list foo bar rah) '(to all those who) (values-list (list foo bar rah f b r))) )) '(f b r to all those)) (equal (multiple-value-list (let () (setq foo 'oo bar 'ar rah 'ah) (progv (cons foo (cons bar (cons rah nil))) '(#c(1 -1) #c(2 -2) #c(3 -3)) (values (* oo ah) (+ ah ar) (- ar oo) (list foo bar rah))) )) '( #c(0 -6) #c(5 -5) #c(1 -1) (oo ar ah)) ) (equal (multiple-value-list (progn (defun fun (a b) (progv (list a b) '(prince frog) (values a b (symbol-value a) (symbol-value b) ))) (setq foo 'f bar 'b f nil b nil) (fun foo bar) )) '( f b prince frog)) ) ) (do-test "test PROGV - exactly one value is used, if forms are passed as an argument to a function call" (defun fool (x) (and (equal (list x) (multiple-value-list x)) x)) (and (prog2 (setq aa 'a bb 'b a 0 b 1) (= (fool (progv (list aa bb) (list 88 99 111) (values a b)) ) 88) ) (prog2 (setq foo 'f bar 'b rah 'r f nil b nil r nil) (eq (fool (progv (list foo bar rah) '(to all those who) (values-list (list foo bar rah f b r))) ) 'f) ) (prog2 (setq foo 'oo bar 'ar rah 'ah) (= (fool (progv (cons foo (cons bar (cons rah nil))) '(#c(1 -1) #c(2 -2) #c(3 -3)) (values (* oo ah) (+ ah ar) (- ar oo) (list foo bar rah))) ) #c(0 -6) )) (progn (defun fun (a b) (progv (list a b) '(prince frog) (values a b (symbol-value a) (symbol-value b) ))) (setq foo 'f bar 'b f nil b nil) ( eq (fool (fun foo bar)) 'f ) ) ) ) (do-test "test LET - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (let () (values-list (make-list (1- multiple-values-limit) :initial-element 'rah)))) (append (make-list (- multiple-values-limit 31) :initial-element 'rah) (make-list 30 :initial-element 'rah)) ) (equal (multiple-value-list (let ((size 80)) (values-list (make-list size :initial-element 'rah)))) (append (make-list (- 80 30) :initial-element 'rah) (make-list 30 :initial-element 'rah)) ) (equal (multiple-value-list (let ((a 100.9) (b 3)) (values (fround a) (fround b) (decode-float (float b))))) '(101.0 3.0 .75)) (equal (multiple-value-list (let ((a 100) (b 50) (c -30)) (multiple-value-call #'values (floor a 3) (floor b 30) (floor c 2)))) '(33 1 1 20 -15 0)) ) ) (do-test "test LET - forms *don't* return multiple values when they *shouldn't* " (and (equal (let ((a "a") (b "b") (c "c")) (cond (nil 'atom) ((values-list (list a b c ))))) "a") (equal (let () (setq a '(2) b '(4)) (or nil () (values a b) t 'non-nil)) '(2)) (equal (cons (let () (fceiling 39 7)) nil) '(6.0)) ) ) (do-test "test LET* - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (let* ((size 80)) (values-list (make-list size :initial-element 'rah)))) (append (make-list (- 80 30) :initial-element 'rah) (make-list 30 :initial-element 'rah)) ) (equal (multiple-value-list (let* ((a 100.9) (b 3)) (values (fround a) (fround b) (decode-float (float b))))) '(101.0 3.0 .75)) (equal (multiple-value-list (let* ((a 100) (b 50) (c -30)) (multiple-value-call #'values (floor a 3) (floor b 30) (floor c 2)))) '(33 1 1 20 -15 0)) ) ) (do-test "test LET* - forms *don't* return multiple values when they *shouldn't* " (and (equal (let* ((a "a") (b "b") (c "c")) (cond (nil 'atom) ((values-list (list a b c ))))) "a") (equal (let* () (setq a '(2) b '(4)) (or nil () (values a b) t 'non-nil)) '(2)) (eq (let* (x (y 2) (z 9)) (values (values x y z))) ()) (equal (cons (let* () (fceiling 39 7)) nil) '(6.0)) ) ) (do-test "test MULTIPLE-VALUE-BIND - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (multiple-value-bind () nil (values-list (make-list 20)))) (append (make-list 10) (make-list 10))) (equal (multiple-value-list (multiple-value-bind (a b c d) (decode-float -10.0) (values a b c d))) '(.625 4 -1.0 nil)) (equal (multiple-value-list (multiple-value-bind (a b c d e f) (values-list '(dopey sneezy sleepy bashful grouchy doc witch)) (values a b c d e f) )) '(dopey sneezy sleepy bashful grouchy doc )) (equal (multiple-value-list (multiple-value-bind () (values-list '(sleepy sneezy doc snow white witch)) (values-list '(blue sky red apple squirrel rabbit broom dwarf)))) '(blue sky red apple squirrel rabbit broom dwarf)) ) ) (do-test "test MULTIPLE-VALUE-BIND - forms *don't* return multiple values when they *shouldn't* " (and (eq (multiple-value-bind (a b c) (decode-float 300.0)) ()) (eql (multiple-value-bind (m n o) (decode-float -6.0) (prog1 (values o n m) m n)) -1.0) (eql (multiple-value-bind () t (values (decode-float (float #o-10)))) .5) (eq (multiple-value-bind (a b) (values 'dopey 'jumpy) (cond ((values-list (list b a))))) 'jumpy) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-2.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-2.TEST new file mode 100644 index 00000000..5589f140 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-IMPLICIT-PROGN-2.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: WHEN, UNLESS, CASE, ECASE, CCASE, TYPECASE, ETYPECASE, CTYPECASE ;; ;; Source: CLtL ;; Section 7.9.2: Rules Governing the Passing of Multiple Values ;; Page: 137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: August 6,1986 ;; ;; Last Update: Feb 5, 1987 - Jim Blum - many changes to make this run on the SUN, mostly having to do ;; with floating pt differences. ;; ;; Filed As: {eris}cml>test>7-9-2-MVR-IMPLICIT-PROGN-2.test ;; ;; ;; Syntax: [not applicable] ;; ;; Description: It is often the case that the value of a special form or macro call is defined to be the value of one of ;; its subforms. For example, the value of a COND is the value of the last form in the selected clause. ;; In most such cases, if the subform produces multiple values, then the original form will also produce ;; all of those values. This passing back of multiple values of course has no effect unless eventually one ;; of the special forms for receiving multiple values is reached. ;; To be explicit, multiple values can result from a special form under precisely these circumstances: ;; ;; Argument(s): [not applicable] ;; ;; Returns: [not applicable] ;; ;; ;; ;; Implicit PROGN contexts ;; ;; . The special form PROGN passes backs multiple values resulting from evaluation of the last subform. Other situations ;; referred to as "implicit progn," where several forms are evaluated and the results of all but the last form are ;; discarded, also pass back multiple values from the last form. These situations include the body of a lambda-expression, ;; in particular those constructed by DEFUN, DEFMACRO, and DEFTYPE. Also included are bodies of the constructs EVAL-WHEN, ;; PROGV, LET, LET*, WHEN, UNLESS, BLOCK, MULTIPLE-VALUE-BIND, and CATCH, as well as clauses in such conditional constructs ;; as CASE,TYPECASE,ECASE,ETYPECASE, CCASE, and CTYPECASE. ;; ;; (do-test "test WHEN - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (when (= 2 2.0) (values 1 2 3 4 5))) '(1 2 3 4 5)) (equal (multiple-value-list (when (stringp "l") (round 4.5))) '(4 .5)) (equal (multiple-value-list (when (eq (cdr '(9)) nil) (values-list '(xerox flexible benefit account)))) '(xerox flexible benefit account)) (equal (multiple-value-list (when (characterp #\r) (setq a 100 b 3) (floor a b))) '(33 1)) ) ) (do-test "test WHEN - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (when (and (setq a #c(1 1)) (complexp a)) a)) '(#c(1 1))) (equal (multiple-value-list (when (consp 'atom) (values 1 2))) '(nil)) (equal (multiple-value-list (when (and (atom ()) (listp ())) (values-list '(single-value)))) '(single-value)) ) ) (do-test "test WHEN - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (when t (ffloor 5 3))) 1.0) (= (foo (when t (setq a 80 b 33) (fceiling a b))) 3.0) (= (1+ (when t (when t (values 24 5)))) 25) (equal (multiple-value-list (values (when t (ftruncate 4.7)) (when t (fround 5.6)))) '(4.0 6.0)) ) ) (do-test "test WHEN - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (x) (when t (fceiling 8.5 3)) (list x)) '(3.0)) (equal (multiple-value-bind (x y) (when t (ceiling 8 3)) (list x y)) '(3 -1)) (equal (multiple-value-bind (x y z) (when t (ceiling 8 3)) (list x y z)) '(3 -1 nil)) ) ) (do-test "test WHEN - when forms are used for effect" (and (equal (progn (setq a 2 b 3) (multiple-value-setq (c d) (when (evenp a) (values (* a b) (complex a b)))) (* c d)) #c(12 18)) (eq (progn (when t (values-list '(a b c d))) 'end-of-WHEN) 'end-of-WHEN) ) ) (do-test "test UNLESS - forms *do* return multiple values when they *should* " (defmacro mac5 () `(ceiling 7.0 2)) (defun fun () (floor 7.5 2)) (and (equal (multiple-value-list (unless (= 1 3) (values 2 4 6 8 10))) '(2 4 6 8 10)) (equal (multiple-value-list (unless (consp ()) (round 7.5 2))) '(4 -.5)) (equal (multiple-value-list (unless (member '(a) '(aa bb cc)) (fun))) '(3 1.5)) (equal (multiple-value-list (unless (endp '(a)) (mac5))) '(4 -1.0)) ) ) (do-test "test UNLESS - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (unless (eq #\a #\A) (values '(is that impossible ?)))) '((is that impossible ?))) (equal (multiple-value-list (unless (equal "clock" "CLOCK") (last '(a b c)))) '((c))) (equal (multiple-value-list (unless (and t nil) (values (fround 6.9 4)))) '(2.0)) (equal (multiple-value-list (unless nil (complex 8 7))) '(#c(8 7))) ) ) (do-test "test UNLESS - exactly one value is used, if forms are passed as an argument to a function call" (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (unless nil (setq a 99 b -8) (ffloor b a))) -1.0) (= (foo (unless nil (setq a 99.4 b 8.5) (fceiling b a))) 1.0) (= (* (foo (unless nil (setq a 75 b 7) (fround a b))) 2) 22.0) (equal (complex (foo (unless nil (setq a 75 b 7) (ftruncate a b))) 2.1) #c(10.0 2.1)) ) ) (do-test "test UNLESS - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (x y z) (unless nil (values-list'( 1 2 3 4))) (list x y z)) '(1 2 3)) (equal ( multiple-value-bind (w x y z) (unless nil (values-list'( 1 2 3 4))) (list w x y z)) '(1 2 3 4)) (equal ( multiple-value-bind (v w x y z) (unless nil (values-list'( 1 2 3 4))) (list v w x y z)) '(1 2 3 4 nil)) ) ) (do-test "test UNLESS - when forms are used for effect" (and (eq (progn (setq a 10) (unless nil (values (decf a 2) (decf a ) (decf a))) a) 6) (equal (progn (setq a '(1 2 3 4)) (values (rplaca a 'a) (rplaca (cdr a) 'b) (rplaca (cddr a) 'c) (rplaca (last a) 'd)) a) '(a b c d)) ) ) (do-test "test CASE - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (case 11 ((1 2 3) 'case1) ((11 22 33) (values 'case2 'case3)) (otherwise '(case4)))) '(case2 case3)) (equal (multiple-value-list (case #\m ((#\p #\r #\e #\t #\t #\y) (values-list '(pretty blouse))) ((#\c #\u #\t #\e) (values-list '(cute toy))) ((#\m #\e #\l #\o #\d #\y) (values-list '(soft melody))) (otherwise (values-list '(wrong !!))))) '(soft melody)) (equal (multiple-value-list (case (sqrt 100) (10 (floor 8 3)) ((20 30) (ceiling 8 3)) ((25.0 10.0) (round 13 7)) (otherwise (truncate 999 7)) )) '(2 -1)) ) ) (do-test "test CASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (case (setq a 7) ((1 3) (values 10 30)) ((5 7) (cond ((evenp a) (values (* 2 a) (* 3 a))) ( (values (* 4 a) (* 5 a))))) (otherwise (values 10 100)))) '(28)) (equal (multiple-value-list (case 'foo (foo0 (ffloor -4 -3)) (foo (or (ftruncate -5 -2) 3 2 )) (foo3 (fround 7.9)))) '(2.0)) ) ) (do-test "test CASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (case 'a ('A (values 'blocks 'and 'exits)))) 'blocks) (eq (foo (case #\a ( #\d nil) ( #\a (floor 7 -3)))) -3) (equal (list (foo (case 100 (10 t) (20 nil) (t (values 9 6 3)))) 99 999) '(9 99 999)) (eq (list-length (foo (case 20 (20.0 '(())) (10 '(1 2 3)) (20 (values '(a b c d) '(e f)))))) 4) ) ) ) (do-test "test CASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (a b c d e) (case 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) (t (ceiling 1000 99))) (list a b c d e)) '(-3 1 14 1 4 )) (equal ( multiple-value-bind (a b c d e f) (case 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) (t (ceiling 1000 99))) (list a b c d e f)) '(-3 1 14 1 4 -8)) (equal ( multiple-value-bind (a b c d e f g) (case 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) (t (ceiling 1000 99))) (list a b c d e f g)) '(-3 1 14 1 4 -8 nil)) ) ) (do-test "test CASE - when forms are used for effect" (and (equal (progn (setq a 2) (case a (1 (defun fun () 'fun1)) (2 (defun fun () (values-list '(fun2 fun22)))) (3 (defun fun () (ffloor -999 37)))) (cdr (multiple-value-list (fun)))) '( fun22)) (eq (let ((a 83)) (list-length (multiple-value-list (case (evenp a) ((t) (values 12 34 56)) (t (values 00 99 88 77 6 66)))))) 6) ) ) (do-test "test ECASE - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (ecase 11 ((1 2 3) 'ecase1) ((11 22 33) (values 'ecase2 'ecase3)) )) '(ecase2 ecase3)) (equal (multiple-value-list (ecase #\m ((#\p #\r #\e #\t #\t #\y) (values-list '(pretty blouse))) ((#\c #\u #\t #\e) (values-list '(cute toy))) ((#\m #\e #\l #\o #\d #\y) (values-list '(soft melody))) )) '(soft melody)) (equal (multiple-value-list (ecase (1+ 9) (10.0 (floor 8 3)) ((20 30) (ceiling 8 3)) ((25.0 10) (round 13 7)) )) '(2 -1)) ) ) (do-test "test ECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (ecase (setq a 7) ((1 3) (values 10 30)) ((5 7) (cond ((evenp a) (values (* 2 a) (* 3 a))) ( (values (* 4 a) (* 5 a))))) )) '(28)) (equal (multiple-value-list (ecase 'foo (foo0 (ffloor -4 -3)) (foo (or (ftruncate -5 -2) 3 2 )) (foo3 (fround 7.9)))) '(2.0)) ) ) (do-test "test ECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (ecase 'a ('A (values 'blocks 'and 'exits)))) 'blocks) (eq (foo (ecase #\a ( #\d nil) ( #\a (floor 7 -3)))) -3) (equal (list (foo (ecase 100 (10 t) (20 nil) (100 (values 9 6 3)))) 99 999) '(9 99 999)) (eq (list-length (foo (ecase 20 (20.0 '(())) (10 '(1 2 3)) (20 (values '(a b c d) '(e f)))))) 4) ) ) ) (do-test "test ECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (a b c d e) (ecase 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e)) '(-3 1 14 1 4)) (equal ( multiple-value-bind (a b c d e f) (ecase 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f)) '(-3 1 14 1 4 -8)) (equal ( multiple-value-bind (a b c d e f g) (ecase 'sun ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f g)) '(-3 1 14 1 4 -8 nil)) ) ) (do-test "test ECASE - when forms are used for effect" (and (equal (progn (setq a 2) (ecase a (1 (defun fun () 'fun1)) (2 (defun fun () (values-list '(fun2 fun22)))) (3 (defun fun () (ffloor -999 37)))) (cdr (multiple-value-list (fun)))) '( fun22)) (eq (let ((a 83)) (list-length (multiple-value-list (ecase (evenp a) ((t) (values 12 34 56)) ((nil) (values 00 99 88 77 6 66)))))) 6) ) ) (do-test "test CCASE - forms *do* return multiple values when they *should* " (let (( z '(11 #\m 10))) (and (equal (multiple-value-list (ccase (car z) ((1 2 3) 'ccase1) ((11 22 33) (values 'ccase2 'ccase3)) )) '(ccase2 ccase3)) (equal (multiple-value-list (ccase (cadr z) ((#\p #\r #\e #\t #\t #\y) (values-list '(pretty blouse))) ((#\c #\u #\t #\e) (values-list '(cute toy))) ((#\m #\e #\l #\o #\d #\y) (values-list '(soft melody))) )) '(soft melody)) (equal (multiple-value-list (ccase (caddr z) (10.0 (floor 8 3)) ((20 30) (ceiling 8 3)) ((25.0 10) (round 13 7)) )) '(2 -1)) ) ) ) (do-test "test CCASE - forms *don't* return multiple values when they *shouldn't* " (let ((a 7) (b 'foo)) (and (equal (multiple-value-list (ccase a ((1 3) (values 10 30)) ((5 7) (cond ((evenp a) (values (* 2 a) (* 3 a))) ( (values (* 4 a) (* 5 a))))) )) '(28)) (equal (multiple-value-list (ccase b (foo0 (ffloor -4 -3)) (foo (or (ftruncate -5 -2) 3 2 )) (foo3 (fround 7.9)))) '(2.0)) ) ) ) (do-test "test CCASE - exactly one value is used, if forms are passed as an argument to a function call" (flet (( foo (x) (and (equal (list x) (multiple-value-list x)) x))) (let (( a 'a) (b #\a) (c 100) (d 20)) (and (eq (foo (ccase a ('A (values 'blocks 'and 'exits)))) 'blocks) (eq (foo (ccase b ( #\d nil) ( #\a (floor 7 -3)))) -3) (equal (list (foo (ccase c (10 t) (20 nil) (100 (values 9 6 3)))) 99 999) '(9 99 999)) (eq (list-length (foo (ccase d (20.0 '(())) (10 '(1 2 3)) (20 (values '(a b c d) '(e f)))))) 4) ) ) ) ) (do-test "test CCASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (let (( aa 'sun)) (and (equal ( multiple-value-bind (a b c d e) (ccase aa ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e)) '(-3 1 14 1 4)) (equal ( multiple-value-bind (a b c d e f) (ccase aa ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f)) '(-3 1 14 1 4 -8)) (equal ( multiple-value-bind (a b c d e f g) (ccase aa ('sun1 ()) ('sun2 (floor -5 2)) ('sun (multiple-value-call #'values (floor -5 2) (truncate 99 7) (round 56 16))) ('sun3 (ceiling 1000 99))) (list a b c d e f g)) '(-3 1 14 1 4 -8 nil)) ) ) ) (do-test "test CCASE - when forms are used for effect" (and (equal (let (( a 2) ) (ccase a (1 (defun fun () 'fun1)) (2 (defun fun () (values-list '(fun2 fun22)))) (3 (defun fun () (ffloor -999 37)))) (cdr (multiple-value-list (fun)))) '( fun22)) (eq (let ((a (evenp 83))) (list-length (multiple-value-list (ccase a ((t) (values 12 34 56)) ((nil) (values 00 99 88 77 6 66)))))) 6) ) ) (do-test "test TYPECASE - check if forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (typecase (car '(100)) (string (values 'str1 'str2)) (array (values 'ary1 'ary2)) (number (values 5 10 15 20)))) '(5 10 15 20)) (equal (multiple-value-list (typecase (cdr '(c a b)) (number (values 1 2 3 4)) ((or list character) (values '(1 . 2) '(3 . 4) #\n)) (complex (values #c(1 2) #c(4 5))) (t (values 'something 'is 'wrong)) )) '( (1 . 2) (3 . 4) #\n)) (equal (multiple-value-list (typecase (caddr '(2 4 "August")) ((simple-string 10) (round 3.7)) ((integer -2 100) (round 2.3)) ((simple-string 6) (round 4.5)) )) '(4 .5)) (equal (multiple-value-list (typecase (second '(2 1 9)) ((integer 2 9) (floor 9 2)) ((float -2.0 9.0) (floor 9 2)) (complex (truncate 5 4)) (bit (truncate 13 -7)) (t (values 'something 'else)) )) '(-1 6)) ) ) (do-test "test TYPECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (typecase (second '(1200 9.99 #c(5 6) 87)) ((or rational float) (or (values-list '(to all those who strive for excellence)) 99)) ((float 5 6) (values 100 99 98 97)) ((complex integer) (or (values-list '(twinkle twinkle little star)) 999)) (t (values -10 -20 -30 -40)) )) '(to)) (equal (multiple-value-list (typecase (cdr '(m n o p)) ((or string cons) (values (fround 7.9))) ((vector) (values (ftruncate 7.9))) (bit (values (fceiling 3.4))) (t (values (ffloor -3.4))) )) '(8.0)) ) ) (do-test "test TYPECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (typecase (second '(a #\r t #\i s t)) ( character (values 88 999 10000)) )) 88) (equal (foo (typecase (third '(a #\r t #\i s t)) (list (values 1 2)) (atom (values 11 22 33)) )) 11) (equal (cons (typecase (fourth '(a #\r t #\i s t)) (number ()) (character (fround 3.999)) ) #\%) '(4.0 . #\%)) (equal (list (typecase (first '(1 2 #\3 (4))) (list (values 100 200 300)) (character (values #\a #\b #\c #\d)) ((integer -1 2) (values -1 0 1 2)) )) '(-1)) ) ) ) (do-test "test TYPECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (typecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) (otherwise (values-list '(love story sung by Andy Willium))) ) (list w x y z)) '(the simple truth about)) (equal ( multiple-value-bind (v w x y z) (typecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) (otherwise (values-list '(love story sung by Andy Willium))) ) (list v w x y z)) '(the simple truth about love)) (equal ( multiple-value-bind (u v w x y z) (typecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) (otherwise (values-list '(love story sung by Andy Willium))) ) (list u v w x y z)) '(the simple truth about love nil)) ) ) (do-test "test TYPECASE - when forms are used for effect" (and (eq (progn (setq a 20.0) (typecase a (integer (floor 5 2)) (float (floor 15 2))) 'prog10) 'prog10) (eq (progn (setq a 200 ) (typecase a (integer (values 'a 'b )) (float (values 'c 'd))) 'the-end) 'the-end) ) ) (do-test "test ETYPECASE - check if forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (etypecase (car '(100)) (string (values 'str1 'str2)) (array (values 'ary1 'ary2)) (number (values 5 10 15 20)))) '(5 10 15 20)) (equal (multiple-value-list (etypecase (cdr '(c a b)) (number (values 1 2 3 4)) ((or list character) (values '(1 . 2) '(3 . 4) #\n)) (complex (values #c(1 2) #c(4 5))) )) '( (1 . 2) (3 . 4) #\n)) (equal (multiple-value-list (etypecase (caddr '(2 4 "August")) ((simple-string 10) (round 3.7)) ((integer -2 100) (round 2.3)) ((simple-string 6) (round 4.5)) )) '(4 .5)) (equal (multiple-value-list (etypecase (second '(2 1 9)) ((integer 2 9) (floor 9 2)) ((float -2.0 9.0) (floor 9 2)) (complex (truncate 5 4)) (bit (truncate 13 -7)) )) '(-1 6)) ) ) (do-test "test ETYPECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (etypecase (second '(1200 9.99 #c(5 6) 87)) ((or rational float) (or (values-list '(to all those who strive for excellence)) 99)) ((float 5 6) (values 100 99 98 97)) ((complex integer) (or (values-list '(twinkle twinkle little star)) 999)) (bit (values -10 -20 -30 -40)) )) '(to)) (equal (multiple-value-list (etypecase (cdr '(m n o p)) ((or string cons) (values (fround 7.9))) ((vector) (values (ftruncate 7.9))) (bit (values (fceiling 3.4))) (character (values (ffloor -3.4))) )) '(8.0)) ) ) (do-test "test ETYPECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (etypecase (second '(a #\r t #\i s t)) ( character (values 88 999 10000)) )) 88) (equal (foo (etypecase (third '(a #\r t #\i s t)) (list (values 1 2)) (atom (values 11 22 33)) )) 11) (equal (cons (etypecase (fourth '(a #\r t #\i s t)) (number ()) (character (fround 3.999)) ) #\%) '(4.0 . #\%)) (equal (list (etypecase (first '(1 2 #\3 (4))) (list (values 100 200 300)) (character (values #\a #\b #\c #\d)) ((integer -1 2) (values -1 0 1 2)) )) '(-1)) ) ) ) (do-test "test ETYPECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (etypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list w x y z)) '(the simple truth about)) (equal ( multiple-value-bind (v w x y z) (etypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list v w x y z)) '(the simple truth about love)) (equal ( multiple-value-bind (u v w x y z) (etypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list u v w x y z)) '(the simple truth about love nil)) ) ) (do-test "test ETYPECASE - when forms are used for effect" (and (eq (progn (setq a 20.0) (etypecase a (integer (floor 5 2)) (float (floor 15 2))) 'prog10) 'prog10) (eq (progn (setq a 200 ) (etypecase a (integer (values 'a 'b )) (float (values 'c 'd))) 'the-end) 'the-end) ) ) (do-test "test CTYPECASE - check if forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (ctypecase (car '(100)) (string (values 'str1 'str2)) (array (values 'ary1 'ary2)) (number (values 5 10 15 20)))) '(5 10 15 20)) (equal (multiple-value-list (ctypecase (cdr '(c a b)) (number (values 1 2 3 4)) ((or list character) (values '(1 . 2) '(3 . 4) #\n)) (complex (values #c(1 2) #c(4 5))) )) '( (1 . 2) (3 . 4) #\n)) (equal (multiple-value-list (ctypecase (caddr '(2 4 "August")) ((simple-string 10) (round 3.7)) ((integer -2 100) (round 2.3)) ((simple-string 6) (fround 4.5)) )) '(4.0 .5)) (equal (multiple-value-list (ctypecase (second '(2 1 9)) ((integer 2 9) (floor 9 2)) ((float -2.0 9.0) (ffloor 9 2)) (complex (truncate 5 4)) (bit (truncate 13 -7)) )) '(-1 6)) ) ) (do-test "test CTYPECASE - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (ctypecase (third '(1200 9.99 #c(5 6) 87)) ((or rational float) (values-list '(to all those who strive for excellence))) ((float 5 6) (values 100 99 98 97)) ((complex integer) (or (values-list '(twinkle twinkle little star)) 999)) (bit (values -10 -20 -30 -40)) )) '(twinkle)) (equal (multiple-value-list (ctypecase (cdr '(m n o p)) ((or string cons) (values (round 7.9))) ((vector) (values (truncate 7.9))) (bit (values (ceiling 3.4))) (character (values (floor -3.4))) )) '(8)) ) ) (do-test "test CTYPECASE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (ctypecase (second '(a #\r t #\i s t)) ( character (values 88 999 10000)) )) 88) (equal (foo (ctypecase (third '(a #\r t #\i s t)) (list (values 1 2)) (atom (values 11 22 33)) )) 11) (equal (cons (ctypecase (fourth '(a #\r t #\i s t)) (number ()) (character (fround 3.999)) ) #\%) '(4.0 . #\%)) (equal (list (ctypecase (first '(1 2 #\3 (4))) (list (values 100 200 300)) (character (values #\a #\b #\c #\d)) ((integer -1 2) (values -1 0 1 2)) )) '(-1)) ) ) ) (do-test "test CTYPECASE - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (w x y z) (ctypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list w x y z)) '(the simple truth about)) (equal ( multiple-value-bind (v w x y z) (ctypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list v w x y z)) '(the simple truth about love)) (equal ( multiple-value-bind (u v w x y z) (ctypecase (car '(#(1 2 3) #c(2 4))) ((complex integer) (values-list '(the sweet love story is older than the sea))) ((array float) (values-list '( how do I begin to tell you the story))) ((array t) (values-list '(the simple truth about love))) ) (list u v w x y z)) '(the simple truth about love nil)) ) ) (do-test "test CTYPECASE - when forms are used for effect" (and (eq (progn (setq a 20.0) (ctypecase a (integer (floor 5 2)) (float (floor 15 2))) 'prog10) 'prog10) (eq (progn (setq a 200 ) (ctypecase a (integer (values 'a 'b )) (float (values 'c 'd))) 'the-end) 'the-end) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-MISC-SITUATIONS.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-MISC-SITUATIONS.TEST new file mode 100644 index 00000000..534803e4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-2-MVR-MISC-SITUATIONS.TEST @@ -0,0 +1 @@ +;; ;; Functions tested: SETQ, MULTIPLE-VALUE-SETQ, PROG1, PROG2 (these functions shouldn't pass back multiple values) ;; MULTIPLE-VALUE-PROG1, UNWIND-PROTECT, THE (these functions should pass back multiple values) ;; ;; Last Update: Feb 5, 1987 - Jim Blum - changes in the floating pt area to make it run on the SUN ;; (do-test "test SETQ - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (setq a (values 1 2 3 4 5))) '(1)) (equal (multiple-value-list (setq a 1 b (ffloor 3.7))) '(3.0)) (equal (multiple-value-list (setq z "a" y "b" x (values-list '(sunshine on my shoulder make me happy)))) '(sunshine)) ) ) (do-test "test MULTIPLE-VALUE-SETQ - forms *don't* return multiple values when they *shouldn't* " ;; ;; [MULTIPLE-VALUE-SETQ variables form] P. 137 ;; MULTIPLE-VALUE-SETQ always returns a single value, which is the first value returned by form ;; (and (let (a b) (equal (multiple-value-list (multiple-value-setq (a b) (values 1 2 3 4 5))) '(1)) (eql a 1) (eql b 2)) (let (x y z w) (equal (multiple-value-list (multiple-value-setq (x y z w) (floor 3.5))) '(3)) (eql x 3) (eql y .5) (eq z nil) (eq w nil)) (let (z y x) (equal (multiple-value-list (multiple-value-setq (z y x) (values-list '(sunshine on my shoulder makes me happy)) )) '(sunshine)) (eq z 'sunshine) (eq y 'on) (eq x 'my)) ) ) (do-test "test PROG1 - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (prog1 (values 0 9 8 7 6 5) 4 3 2 1)) '(0)) (equal (multiple-value-list (prog1 (round 7 2) (ceiling 6 2.8))) '(4)) (equal (multiple-value-list (prog1 (values-list '(sunshine in my eyes can make my cry)) 10 20)) '(sunshine)) ) ) (do-test "test PROG2 - forms *don't* return multiple values when they *shouldn't* " (and (equal (multiple-value-list (prog2 99 (values 0 9 8 7 6 5) 4 3 2 1)) '(0)) (equal (multiple-value-list (prog2 999 (round 7 2) (ceiling 6 2.8))) '(4)) (equal (multiple-value-list (prog2 8 (values-list '(sunshine in the water looks so lovely)) 10 20)) '(sunshine)) ) ) (do-test "test MULTIPLE-VALUE-PROG1 - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (multiple-value-prog1 (values 0 9 8 7 6 5) 4 3 2 1)) '(0 9 8 7 6 5)) (equal (multiple-value-list (multiple-value-prog1 (round 7 2) (ceiling 6 2.8))) '(4 -1)) (equal (multiple-value-list (multiple-value-prog1 (values-list '(sunshine in my eyes can make my cry)) 10 20)) '(sunshine in my eyes can make my cry)) ) ) (do-test "test MULTIPLE-VALUE-PROG1 - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (eq (foo (multiple-value-prog1 (values 0 9 8 7 6 5) 4 3 2 1)) 0) (eql (foo (multiple-value-prog1 (round 7 2) (ceiling 6 2.8))) 4) (eq (foo (multiple-value-prog1 (values-list '(sunshine in my eyes can make my cry)) 10 20)) `sunshine) ) ) ) (do-test "test MULTIPLE-VALUE-PROG1 - when exactly 'n' multiple values are expected, test for n-1, n,and n+1 numbers of values wanted" (and (equal ( multiple-value-bind (a b c d e f g) (multiple-value-prog1 (values-list '(foo foo1 foo2 foo3 foo4 foo5 foo6 foo7)) 'foo8 'foo9) (list a b c d e f g) ) '(foo foo1 foo2 foo3 foo4 foo5 foo6)) (equal ( multiple-value-bind (a b c d e f g h) (multiple-value-prog1 (values-list '(foo foo1 foo2 foo3 foo4 foo5 foo6 foo7)) 'foo8 'foo9) (list a b c d e f g h) ) '(foo foo1 foo2 foo3 foo4 foo5 foo6 foo7)) (equal ( multiple-value-bind (a b c d e f g h i) (multiple-value-prog1 (values-list '(foo foo1 foo2 foo3 foo4 foo5 foo6 foo7)) 'foo8 'foo9) (list a b c d e f g h i ) ) '(foo foo1 foo2 foo3 foo4 foo5 foo6 foo7 nil )) ) ) (do-test "test MULTIPLE-VALUE-PROG1 - when forms are used for effect" (and (equal (progn (setq a 4 b 5) (multiple-value-prog1 (values 3 4 (decf a) (incf b))) (list a b)) '(3 6)) (eq (progn (multiple-value-prog1 (truncate 456 123)) 'end-of-mvprog1) 'end-of-mvprog1) ) ) (do-test "test UNWIND-PROTECT - make sure forms *do* return multiple values when they *should* " (and ; ; test cse 1 ; (equal (multiple-value-list (unwind-protect (round -5 2))) '(-2 -1)) ;; ;; test case 2 ;; (let ((m 2) (n 8)) (and (equal (multiple-value-list (unwind-protect (progn (incf m 10) (decf n 3) (values m n) ) (incf m 9) (decf n 2) )) '(12 5)) (equal (list m n) '(21 3)))) ;; ;; test cse 3 ;; (let ((m 2) (n 8)) (and (equal (multiple-value-list (block bar (unwind-protect (progn (incf m 10) (return-from bar (values m n)) (decf n 3) ) (incf m 9) (decf n 2) ) (incf m 10) (decf n 1) ) ) '(12 8)) (equal (list m n) '(21 6)))) ) ) (do-test "test THE - forms *do* return multiple values when they *should* " (and (equal (multiple-value-list (the (values integer integer) (floor 8 3))) '(2 2)) (equal (multiple-value-list (the (values complex character cons ) (values #c(4 3.0) #\f '(9)) )) '(#c(4 3.0) #\f (9) )) (equal (multiple-value-list (the (values (float -.5 .6) (integer 3 5) (member 1.0)) (decode-float 8.0))) '(.5 4 1.0)) (equal (multiple-value-list (the (values (string 4) t list) (values-list (list "test" (rationalp (/ 9 4)) '(THE))) )) '("test" t (the))) ) ) (do-test "test THE - exactly one value is used, if forms are passed as an argument to a function call" (prog2 (defun foo (x) (and (equal (list x) (multiple-value-list x)) x)) (and (= (foo (the (values integer integer) (floor 8 3))) 2) (equal (foo (the (values complex character cons ) (values #c(4 3.0) #\f '(9)) )) #c(4 3.0)) (eql (foo (the (values (float -.5 .6) (integer 3 5) (member 1.0)) (decode-float 8.0))) .5) (string-equal (foo (the (values (string 4) t list) (values-list (list "test" (rationalp (/ 9 4)) '(THE))) )) "test") ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/7/7-9-MULTIPLE-VALUES.TEST b/internal/test/LANGUAGE/from-sun/language/7/7-9-MULTIPLE-VALUES.TEST new file mode 100644 index 00000000..1e4cc6a1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/7/7-9-MULTIPLE-VALUES.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: values, values-list, multiple-value-list, multiple-value-call, ;; multiple-value-prog1, multiple-value-bind, and multiple-value-setq ;; ;; Source: Steele's book Section 7.9: multiple values Page: 133-137 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 21, 1986 ;; ;; Last Update: Feb 5, 1987 Jim Blum - fixed mult val setq2 test ;; ;; Filed As: {eris}cml>test>7-9-multiple-values.test ;; ;; ;; Syntax: VALUES &rest args ;; ;; Function Description: VALUES takes any number of arguments and returns that many values, in order. ;; ;; Argument(s): args ;; ;; Returns: values ;; ;; .................................................................................................... ;; ;; Syntax: VALUES-LIST list ;; ;; Function Description: VALUES-LIST takes all of the elements of list and returns multiple values. ;; ;; Argument(s): list ;; ;; Returns: values ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-LIST form ;; ;; Function Description: MULTIPLE-VALUE-LIST evaluates form and returns a list of multiple values ;; it returned. ;; ;; Argument(s): form ;; ;; Returns: a list of multiple values ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-BIND ({var}*) values-form {declaration}* {form}* ;; ;; Function Description: MULTIPLE-VALUE-BIND evaluates the values-form and binds the values returned to ;; the variables specified in {var}*. The forms, which make up an implicit progn, ;; will then be executed. ;; ;; Argument(s): ({var}*) - a list of variables ;; values-form - a form which might return multiple values ;; {declaration}* - ;; {form}* - a number of list form(s) ;; ;; Returns: value of the last form evaluated ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-CALL function {form}* ;; ;; Function Description: MULTIPLE-VALUE-CALL first evaluates the function to obtain a function and then ;; evaluates the forms. All the values of the forms are given as arguments to ;; the function. The result of MULTIPLE-VALUE-CALL is whatever returned by the ;; function. ;; ;; Argument(s): function - ;; {form}* - ;; ;; Returns: value returned by the function ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-PROG1 form {form}* ;; ;; Function Description: MULTIPLE-VALUE-PROG1 evaluates the first form and saves all the values produced ;; by that form. It then evaluates the remaining forms and discarding their values. ;; MULTIPLE-VALUE-PROG1 returns the values produced by the first form. ;; ;; Argument(s): form - ;; {form}* - ;; ;; Returns: value returned by the first form ;; ;; ;; .................................................................................................... ;; ;; Syntax: MULTIPLE-VALUE-SETQ variables form ;; ;; Function Description: MULTIPLE-VALUE-SETQ evaluates the form and set the variables to the values ;; returned by that form. MULTIPLE-VALUE-SETQ returns the first value produced ;; by the form. ;; ;; Argument(s): variables - a list of variables ;; form - ;; ;; Returns: the first value returned by the form ;; ;; ;; **** check if the constant "multiple-values-limit" was properly defined **** ;; (do-test test-multiple-values-limit (and (boundp 'multiple-values-limit) (integerp multiple-values-limit) (>= multiple-values-limit 20))) ;; ;; ;; **** tests for "values" & "multiple-value-list" functions **** ;; ;; (do-test test-values0 (and (eq (values) nil) (equal (multiple-value-list (values 1 2 3 4 5)) '(1 2 3 4 5)) (equal (multiple-value-list (values "1 + 2 = " (+ 1 2))) '("1 + 2 = " 3)) (equal (multiple-value-list (values 'a #\b 99 (list 'list) (/ 8 2))) '(a #\b 99 (list) 4)) (equal (multiple-value-list (values)) nil))) (do-test test-values1 (and (equal (multiple-value-list (values 'list ''foo ''bar)) '(list 'foo 'bar)) )) ;;;**** (equal (multiple-value-list (values (multiple-value-list (values 'list ''foo ''bar)))) ;;;;**** '((foo bar))))) (do-test test-values2 ;; ;; input 50 arguments to "values" and see if it works ;; (and (equal (multiple-value-list (values 1 2 3 4 5 6 7 8 9 10 11 2 3 4 5 6 7 8 9 10 21 2 3 4 5 6 7 8 9 10 31 2 3 4 5 6 7 8 9 10 41 2 3 4 5 6 7 8 9 50)) '(1 2 3 4 5 6 7 8 9 10 11 2 3 4 5 6 7 8 9 10 21 2 3 4 5 6 7 8 9 10 31 2 3 4 5 6 7 8 9 10 41 2 3 4 5 6 7 8 9 50)))) (do-test test-values3 (and (setq x 1) (setq y 2) (equal (multiple-value-list (values x y)) '(1 2)))) ;; ;; ;; ;; **** tests for "values-list" & "multiple-value-bind" functions **** ;; ;; (do-test test-values-list0 (and (equal (multiple-value-bind (n0 n1 n2) (values-list '(0 1 2)) (list n0 n1 n2)) '(0 1 2)) ;; ;; with more variables than values returned ;; (equal (multiple-value-bind (n0 n1) (values-list ()) (list n0 n1)) '(nil nil)) (equal (multiple-value-bind (n0 n1 n2 n3 n4) (values-list '(0 1 2)) (list n0 n1 n2 n3 n4)) '(0 1 2 nil nil)) ;; ;; with less variables than values returned ;; (equal (multiple-value-bind (n0 n1 n2) (values-list '(0 1 2 3 4 5)) (list n0 n1 n2)) '(0 1 2)) (equal (multiple-value-bind () (values-list '(0 1 2 3 4 5)) (= 1 1)) 't))) (do-test test-values-list1 (and (equal (multiple-value-bind (n0 n1 n2) (values-list (list (cons 'a 'b) (list 'c 'd) (prog1 'efg))) (list n0 n2 n1)) '((a . b) efg (c d))) (equal (multiple-value-bind (n0 n1 n2) (values-list (list (cons 'a 'b) (list 'c 'd) (prog1 'efg)))) nil))) (do-test test-values-list2 (equal (multiple-value-bind (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50) (values-list (list 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)) (declare (special n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50)) (and (every #'boundp '(n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50)) (every #'(lambda (x) (= x 1)) (list n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32 n33 n34 n35 n36 n37 n38 n39 n40 n41 n42 n43 n44 n45 n46 n47 n48 n49 n50)))) 't)) ;; ;; ;; ;; **** tests for "multiple-value-call" function **** ;; ;; (do-test test-multiple-value-call0 (and (equal (multiple-value-call #'/= (values-list '(2 4 6 8.0 10))) 't) (equal (multiple-value-call #'+ 1 (+ 2 3) (* 4 5) (values 6 7) (values-list '(9 10))) 58) (equal (multiple-value-call #'(lambda (x y z) (notany #'oddp (list x y z))) (* 10 2) (/ 10 5) 8) 't) (equal (multiple-value-call #'(lambda (ar1 ar2 &optional (ar3 33 ar3-flag) ar4) (list ar1 ar2 ar3 ar3-flag ar4)) (values 1 2 3) 'last-not-least) '(1 2 3 t last-not-least)))) ;; ;; ;; **** tests for "multiple-value-prog1" function **** ;; ;; (do-test test-multiple-value-prog10 (and (eq (multiple-value-prog1 'a 'b 'c 'd 'e) 'a) (= (multiple-value-prog1 (setq a 10) (setq a 20) (setq a 30)) 10) (eq (multiple-value-prog1 () (values 1 2 3)) nil) (equal (multiple-value-call #'- (multiple-value-prog1 (values-list (list (prog1 1) (prog1 2) (prog1 3))) (evenp 3))) -4) (eq (multiple-value-prog1 (car (setq x '(o p q r))) (rplaca x 'u)) 'o))) ;; ;; ;; **** tests for "multiple-value-setq" function **** ;; ;; ;; (do-test test-multiple-value-setq0 (and (eq (multiple-value-setq (n0 n1) ()) nil) (equal (list n0 n1) '(nil nil)))) (do-test test-multiple-value-setq1 (eq (multiple-value-setq () ()) nil)) (do-test test-multiple-value-setq2 (and (eq (multiple-value-setq (n0) (values 'x 'y 'z)) 'x) (equal (list n0) '(x)) (eq (multiple-value-setq (n0 n1) (values 'x 'y 'z)) 'x) (equal (list n0 n1) '(x y)) (eq (multiple-value-setq (n0 n1 n2) (values 'x 'y 'z)) 'x) (equal (list n0 n1 n2) '(x y z)))) ;; ;; ;; ;; (do-test test-mixed0 (equal (multiple-value-call #'values (multiple-value-bind (a b c) (multiple-value-prog1 (values-list '(1 2 3))) (multiple-value-setq (x y z) (values a b c)) (multiple-value-list (values x y z)))) '(1 2 3))) (do-test "test case from masinter.pa" (PROGN (DEFUN 3MVS () (VALUES 1 2 3)) (AND (EQUAL (MULTIPLE-VALUE-LIST (3MVS)) '(1 2 3)) (EQUAL (MULTIPLE-VALUE-BIND (A B C) (3MVS) (LIST C B A)) '(3 2 1)))) ) ;; ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/8/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST b/internal/test/LANGUAGE/from-sun/language/8/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST new file mode 100644 index 00000000..ad9bed2a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/8/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: macro-function and defmacro ;; ;; Source: Steele's book Section 8.1: Macro definition Page: 144,145 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 12 '86 ;; ;; Last Update: May 19, 1986/ Masinter, fix (optional0) test, ;; comment out some tests that now (correctly) ;; signal errors ;; May 21, 1986/ Sye, add test cases test-redefine0, test-redefine1, ;; test-redefine2, and test-macros4 ;; June 2, 1986/ Masinter, put &allow-other-keys in tests that have ;; extraneous keywords, add more ;; descriptive name to (currently failing) test ;; Dec. 4, 1986/ Sye ;; add test cases for MACRO-FUNCTION ;; comment out nlsetq statements ;; ;; Filed As: {eris}cml>test>8-1-macro-function-and-defmacro.test ;; ;; ;; Syntax: MACRO-FUNCTION symbol ;; ;; Function Description: MACRO-FUNCTION determines if the argument has a macro ;; definition ;; ;; Argument(s): symbol - a lisp symbol object ;; env - optional lexical environment in which to look for ;; definitions ;; ;; Returns: the expansion function - ;; nil - ;; ;; ;; ;; ;; Syntax: DEFMACRO name lambda-list {declaratioh | doc-string}* {form}* ;; ;; Function Description: DEFMACRO globally defines "name" as a macro with the ;; arguments "lambda-list" and the definition form "form". ;; ;; Argument(s): name - the symbol whose macro definition is being created ;; ;; lambda-list - a list that defines how the argument list ;; passed to the macro "name" is interpreted. ;; It may contain the ;; lambda-list "&-keywords", support the imbedded ;; lambda-list, and allow the dotted-list format ;; ;; declaration | doc-string - ;; ;; form - an entity which constitutes the body ;; of the expander function ;; ;; Returns: name - same as the argument "name" ;; ;; ;; (do-test "test macro-function - if a macro has a macro global definition, then MACRO-FUNCTION returns the expansion function." (progn (defmacro mac () '(* 7 9)) (and (functionp (macro-function 'mac)) (equal (funcall (macro-function 'mac) '(mac) nil) '(* 7 9)) (equal (first (multiple-value-list (macroexpand '(mac)) )) '(* 7 9)) ) ) ) (do-test "test macro-function - if a macro does not have a macro global definition, then MACRO-FUNCTION returns nil" (and ;; special forms ;; (notany #'macro-function '(let progv throw catch go)) ;; ;; ordinaly functions ;; (prog2 (defun fun () 99) (flet ((locfun () 'locfun)) (notany #'macro-function '(fun locfun)))) ;; ;; local macros ;; (macrolet ((locmac1 () '(list 23)) (locmac2 (x y) `(cons ,x ,y))) (notany #'macro-function '(locmac1 locmac2))) ) ) (do-test "test macro-function - use setf and MACRO-FUNCTION to erase previous macro's definition" (let (buf) (defmacro mac (x y z) `(list 'glob ,y ,z ,x)) (macrolet ( (mac (m n o) `(list 'loc ,o ,n ,m) )) (push (mac 11 22 33) buf) (setf (macro-function 'mac) #'(lambda (x y) (list 'cons (fourth x) (second x)))) (push (mac 1 2 3) buf)) (push (mac 111 222 333) buf) (and (equal buf '( (333 . 111) (loc 3 2 1) (loc 33 22 11) )) (equal (funcall (macro-function 'mac) '(mac 8 9 10) nil) '(cons 10 8)) ) ) ) (do-test "test macro-function - use setf and MACRO-FUNCTION to erase previous function's definition" (let (buf) (fmakunbound 'fun) (defun fun (x y) (+ x y)) (push (fun 2 5) buf) (setf (macro-function 'fun) #'(lambda (x y) (apply (second x) (nthcdr 2 x)))) (push (fun - 10 2 6) buf) (push (fun * 6 3 -1) buf) (fmakunbound 'fun) (equal buf '(-18 2 7)) ) ) (do-test test-macros1 ;; ;; ** test defmacro, be sure it returns the name of the symbol ;; (and (string-equal (string (defmacro my-first (list) `(car ,list))) "my-first") ;; ;; ** check if the defined expansion function has two arguments ;; ; (= 0 (argtype (macro-function 'my-first))) ; (= 2 (nargs (macro-function 'my-first))) ;; ;; ** try some macro calls ;; (equal (my-first '(1 2 3)) 1) (equal (my-first '((a b c) d e f)) '(a b c)))) (do-test test-macros2 (and (string-equal (string (defmacro my-rest (list) `(cdr ,list))) "my-rest") ;(= 0 (argtype (macro-function 'my-rest))) ;(= 2 (nargs (macro-function 'my-rest))) (equal (my-rest '(1 2 3)) '(2 3)) (equal (my-rest '((a b c) d e f)) '(d e f)))) (do-test test-macros3 (and (string-equal (string (defmacro my-cons (object list) `(cons ,object ,list))) "my-cons") ;(= 0 (argtype (macro-function 'my-cons))) ;(= 2 (nargs (macro-function 'my-cons))) (equal (my-cons 99 '(1 2 3)) '(99 1 2 3)) (equal (my-cons "string" '((a b c) d e f)) '("string" (a b c) d e f)))) (do-test test-macros4 ;; ;; test for a zero-form macro ;; (and (string-equal (string (defmacro empty-macro ())) "empty-macro") ;(= 0 (argtype (macro-function 'empty-macro))) ;(= 2 (nargs (macro-function 'empty-macro))) (eq nil (empty-macro)))) ;; ;; test &rest keyword in the lambda-list ;; (do-test test-rest-keyword0 (and (string-equal (string (defmacro my-when (test &rest form) `(cond (,test ,@form)))) "my-when") ;(= 0 (argtype (macro-function 'my-when))) ;(= 2 (nargs (macro-function 'my-when))) (equal (my-when (zerop 0) (list 'test 'is 'successful)) '(test is successful)) (equal (my-when (oddp 8) (list "error!")) nil))) (do-test test-rest-keyword1 (and (string-equal (string (defmacro rest1 (&rest form) `',form)) "rest1") ;(= 0 (argtype (macro-function 'rest1))) ;(= 2 (nargs (macro-function 'rest1))) (equal (rest1 2 4 6 8 10) '(2 4 6 8 10)) (equal (rest1) nil) (equal (rest1 a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0) '(a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0)) (equal (rest1 "arg1" arg2 (arg3 (arg4 arg5))) '("arg1" arg2 (arg3 (arg4 arg5)))))) ;; ;; test &body keyword in the lambda-list (it should work like &rest keyword) ;; (do-test test-body-keyword0 (and (string-equal (string (defmacro my-when (test &body form) `(cond (,test ,@form)))) "my-when") ;(= 0 (argtype (macro-function 'my-when))) ;(= 2 (nargs (macro-function 'my-when))) (equal (my-when (zerop 0) (list 'test 'is 'successful)) '(test is successful)) (equal (my-when (oddp 8) (list "error!")) nil))) (do-test test-body-keyword1 (and (string-equal (string (defmacro rest1 (&body form) `',form)) "rest1") ;(= 0 (argtype (macro-function 'rest1))) ;(= 2 (nargs (macro-function 'rest1))) (equal (rest1 2 4 6 8 10) '(2 4 6 8 10)) (equal (rest1) nil) (equal (rest1 a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0) '(a b c d e f g h i j k l m n o p q r 10 9 8 7 6 5 4 3 2 1 0)) (equal (rest1 "arg1" arg2 (arg3 (arg4 arg5))) '("arg1" arg2 (arg3 (arg4 arg5)))))) ;; ;; test &optional keyword in the lambda-list ;; (do-test test-optional-keyword0 (and (string-equal (string (defmacro optional0 (&optional n0 n1) `(list ,n0 ,n1))) "optional0") ;(= 0 (argtype (macro-function 'optional0))) ;(= 2 (nargs (macro-function 'optional0))) (equal (optional0 100 200) '(100 200)) (equal (optional0 9) '(9 nil)) (equal (optional0 9 8) '(9 8)) ; used to be (optional0 9 8 7) (equal (optional0) '(nil nil)))) (do-test "missing optional signals error" (and (string-equal (string (defmacro optional1 (n1 n2 n3 &optional (n4 9) n5 (n6 99 n6-flag)) `(list ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n6-flag))) "optional1") ;(= 0 (argtype (macro-function 'optional1))) ;(= 2 (nargs (macro-function 'optional1))) ;; ;; if all three required args are not supplied, be sure an error signal occurs ;; ;;(eq nil (nlsetq (optional1))) ;;(eq nil (nlsetq (optional1 2))) ;;(eq nil (nlsetq (optional1 2 4))) ;; ;; more testing follows ;; (equal (optional1 100 200 300) '(100 200 300 9 nil 99 nil)) (equal (optional1 2 4 6 8 10 12) '(2 4 6 8 10 12 t)) (equal (optional1 'a 'b 'c 'd 'e) '(a b c d e 99 nil)))) ;; ;; test &key keyword in the lambda-list ;; (do-test test-key-keyword0 (and (string-equal (string (defmacro key0 (&key n0 n1) `(list ,n0 ,n1))) "key0") ;(= 0 (argtype (macro-function 'key0))) ;(= 2 (nargs (macro-function 'key0))) (equal (key0) '(nil nil)) ;;; (equal (key0 1 2) '(nil nil)) This now signals an error (equal (key0 :n1 80) '(nil 80)) ;;; (equal (key0 :n0 900 0 1 2) '(900 nil)) This now signals an error (equal (key0 :n0 20 :n1 1000) '(20 1000)))) ;; (do-test test-key-keyword1 (and (string-equal (string (defmacro key1 (n0 n1 &key n2 (n3 (+ 9 90 900)) (n4 (quote (cons 2 4)) n4-flag) n5 &allow-other-keys) `(list ,n0 ,n1 ,n2 ,n3 ,n4 ,n4-flag ,n5))) "key1") ;(= 0 (argtype (macro-function 'key1))) ;(= 2 (nargs (macro-function 'key1))) (equal (key1 () ()) '(nil nil nil 999 (2 . 4) nil nil)) (equal (key1 1 2 :n3 3 :n5 8) '(1 2 nil 3 (2 . 4) nil 8)) (equal (key1 10 20 :n2 :n3 :n4 :n5) '(10 20 :n3 999 :n5 t nil)) (equal (key1 'a 'b :n5 500 :n4 400 :n2 200 :n3 300) '(a b 200 300 400 t 500)) ;; ;; -- it is an error for the first member of any keyword-argument pair to be anything but a keyword-- ;; (page 62 of CLtL) ;; ;; "is an error" isn't the same as "signals an error" ;; (eq nil (nlsetq (key1 10 20 30 :n2 22 :n3 33 :n4 44 :n5 55 nil))) )) ;; ;; ;; test &allow-other-keys keyword in the lambda-list ;; (do-test test-allow-otherkey0 ;; ;; by specifying &allow-other-keys in the lambda-list, unmatched keywords are allowed ;; (and (string-equal (string (defmacro otherkey0 (&key n0 n1 &allow-other-keys) `'(,n0 ,n1))) "otherkey0") ;(= 0 (argtype (macro-function 'otherkey0))) ;(= 2 (nargs (macro-function 'otherkey0))) (equal (otherkey0 :n0 20 :n1 1000) '(20 1000)) (equal (otherkey0 :n0 20 :n3 6 :n8 900) '(20 nil)) (equal (otherkey0 :n10 20 :n3 6 :n8 900) '(nil nil)))) (do-test test-allow-otherkey1 ;; ;; &allow-other-keys is not specified in the lambda-list ; unmatched keywords are not allowed ;; (and (string-equal (string (defmacro otherkey1 (&key n0 n1) `'(,n0 ,n1))) "otherkey1") )) ;(= 0 (argtype (macro-function 'otherkey1))) ;(= 2 (nargs (macro-function 'otherkey1))) ;(eq (nlsetq (otherkey1 :n0 20 :n3 6 :n8 900)) nil) ;(eq (nlsetq (otherkey1 :n10 20 :n3 6 :n8 900)) nil))) (do-test test-allow-otherkey2 (and (string-equal (string (defmacro otherkey2 (&key n0 n1) `'(,n0 ,n1))) "otherkey2") ;(= 0 (argtype (macro-function 'otherkey2))) ;(= 2 (nargs (macro-function 'otherkey2))) ;; ;; ** by setting :allow-other-keys to non-nil, unmatched keywords are allowed ** ;; (equal (otherkey2 :n0 20 :n1 1000 :n2 44 :allow-other-keys t) '(20 1000)) (equal (otherkey2 :n50 20 :n100 1000 :n28 44 :allow-other-keys 'non-nil) '(nil nil)) )) ;; ;; ** by setting :allow-other-keys to nil, unmatched keywords are not allowed ** ;; ;; (eq (nlsetq (otherkey2 :n0 20 :n1 1000 :n2 44 :allow-other-keys nil)) nil) ;; (eq (nlsetq (otherkey2 :n50 20 :n100 1000 :n28 44 :allow-other-keys nil)) nil) ;; ;; test &whole keyword in the lambda-list ;; (do-test test-whole-keyword0 (and (string-equal (string (defmacro whole0 (&whole n0 a1 a2 a3 a4 a5) `'(,n0 ,a1 ,a3 ,a5))) "whole0") ;(= 0 (argtype (macro-function 'whole0))) ;(= 2 (nargs (macro-function 'whole0))) (equal (whole0 1 2 3 4 5) '((whole0 1 2 3 4 5) 1 3 5)) (equal (whole0 a b c d e) '((whole0 a b c d e) a c e)))) ;; ;; test &aux keyword in the lambda-list ;; (do-test test-aux-keyword0 (and (string-equal (string (defmacro aux0 (&aux a (b 20) (c (* 10 9)) (d (- 100 10)) e) `(list ,a ,b ,c ,d ,e))) "aux0") ;(= 0 (argtype (macro-function 'aux0))) ;(= 2 (nargs (macro-function 'aux0))) (equal (aux0) '(nil 20 90 90 nil)))) ;; ;; test {declaration | doc-string}* in defmacro ;; (do-test test-dec-doc0 (and (string-equal (string (defmacro dec-doc0 (n0 n1 n2) (declare (number n0 n1 n2)) "This is a simple macro which returns the sum of three arguments" `(+ ,n0 ,n1 ,n2))) "dec-doc0") ;(= 0 (argtype (macro-function 'dec-doc0))) ;(= 2 (nargs (macro-function 'dec-doc0))) (= (dec-doc0 11 22 33) 66) (/= (dec-doc0 -1 1 -1) 1))) (do-test test-dec-doc1 (and (string-equal (string (defmacro dec-doc1 (n0 n1 n2) "This macro returns a list of 3 character codes for the 3 input characters" (declare (character n0)) "n0 is 1st arg" (declare (character n1)) "n1 is 2nd arg" (declare (character n2)) "n2 is 3rd arg" `(list (char-code ,n0) (char-code ,n1) (char-code ,n2)))) "dec-doc1") ;(= 0 (argtype (macro-function 'dec-doc1))) ;(= 2 (nargs (macro-function 'dec-doc1))) (equal (dec-doc1 #\a #\b #\c) '(97 98 99)) (equal (dec-doc1 #\1 #\2 #\3) '(49 50 51)))) ;; ;; test imbedded lambda-list in defmacro ;; ;; (do-test test-imbedded0 (and (defmacro imbedded0 ((mouth eye1 eye2) ((fin1 length1) (fin2 length2)) tail) "This test case was copied from Steele's book p149" `'(,mouth ,eye1 ,eye2 ,fin1 ,length1 ,fin2 ,length2 ,tail)) ;; ;; the following "equal" should return t ;; (equal (imbedded0 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) my-favorite-tail) '(m (car eyes) (cdr eyes) f1 (count-scales f1) f2 (count-scales f2) my-favorite-tail)) )) ;; ;; now try make some mistakes in the following macro call forms, I'll expect error signals to occur ;; ;; (eq (nlsetq (imbedded0 (m (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) ;; my-favorite-tail)) nil) ;;(eq (nlsetq (imbedded0 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) ;; )) nil) ;;(eq (nlsetq (imbedded0 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) ( (count-scales f2))) ;; my-favorite-tail)) nil))) (do-test test-imbedded1 (and (defmacro imbedded1 ((&whole head mouth eye1 eye2) ((fin1 length1) (fin2 length2)) tail) " ** This test case was copied from Steele's book p150 **" " ** &whole keyword was included in the imbedded lambda list **" `',head) ;; ;; check contents of "head". It should be a list whose components are called "mouth" "eye1" and "eye2" ;; (equal (imbedded1 (m (car eyes) (cdr eyes)) ((f1 (count-scales f1)) (f2 (count-scales f2))) my-favorite-tail) '(m (car eyes) (cdr eyes))))) ;; ;; test lambda-list dotted form ;; (do-test test-dotform0 (and (defmacro dotform0 (n0 . n1) " ** test for top-level lambda-list ** " `'(,n0 ,n1)) (equal (dotform0 1 2 3 4) '(1 (2 3 4))) (equal (dotform0 100) '(100 ())) (equal (dotform0 (a b c) 8) '((a b c) (8))))) (do-test test-dotform1 (and (defmacro dotform1 ((n0 n1 . n2) n3) " ** test for imbedded -level lambda-list ** " `'(,n0 ,n1 ,n2 ,n3)) (equal (dotform1 (1 2 3 4 5) 6) '(1 2 (3 4 5) 6)) (equal (dotform1 (a b "string1" "string2" 3 4) (x y z)) '(a b ("string1" "string2" 3 4) (x y z))))) (do-test test-dotform2 (and (defmacro dotform2 ((n0 n1 . n2) n3 . n4) `'(,n0 ,n1 ,n2 ,n3 ,n4)) (equal (dotform2 (1 2 3 4 5) 6 7 8 9 10) '(1 2 (3 4 5) 6 (7 8 9 10))) (equal (dotform2 (a b "string1" "string2" 3 4) w (x y z)) '(a b ("string1" "string2" 3 4) w ((x y z)))))) ;; ;; ;; more testing on defmacro ;; (with lambda-lists contain & keywords, imbedded lambda lists, and/or dotted forms) ;; (do-test test-arithmetic-if (and (defmacro arithmetic-if (test neg-form zero-form pos-form) "** This test case was copied from p147 of CLtl **" (let ((var (gensym))) `(let ((,var ,test)) (cond ((< ,var 0) ,neg-form) ((= ,var 0) ,zero-form) (t ,pos-form))))) (equal (arithmetic-if (+ 10 100) 'neg 'zero 'pos) 'pos) (equal (let ((x 3)) (arithmetic-if (- x 4.0) (- x) 'zero x)) -3) (equal (let ((x 4)) (arithmetic-if (- x 4.0) (- x) 'zero x)) 'zero) (equal (let ((x 5)) (arithmetic-if (- x 4.0) (- x) 'zero x)) 5))) ;; (do-test test-lamb0 ;; (and (defmacro lamb0 (x &optional (a b &rest c) &rest z) ;; "** This test case was copied from p150 of CLtl **" ;; `(,x ,a ,c ,z)) ;; (eq nil (nlsetq (lamb0 4))) ;; (eq nil (nlsetq (lamb0 4 ( 1 3 5) 7))))) (do-test test-lamb1 (and (defmacro lamb1 (x &optional ((a b &rest c)) &rest z) "** This test case was copied from p150 of CLtl **" `'(,x ,a ,b ,c ,z)) (equal (lamb1 1 (2 3 4 5) 6 7 8) '(1 2 3 (4 5) (6 7 8))) )) ;; (eq nil (nlsetq (lamb1 (car pool)))) ;; (eq nil (nlsetq (lamb1 (car pool) (10)))))) (do-test test-lamb2 (and (defmacro lamb2 (x &optional ((a b &rest c) '(nil nil)) &rest z) "** This test case was copied from p151 of CLtl **" `'(,x ,a ,b ,c ,z)) (equal (lamb2 1 (2 3 4 5) 6 7 8) '(1 2 3 (4 5) (6 7 8))) (equal (lamb2 (car pool)) '((car pool) nil nil nil nil)) (equal (lamb2 (car pool) (88 99) 100 200) '((car pool) 88 99 nil (100 200))) )) ;; ;; if the macro call specifies a explicitly then it must also specify b explicitly ;; ;; (eq nil (nlsetq (lamb2 (car pool) (10)))))) (do-test test-lamb3 (and (defmacro lamb3 (x &optional ((&optional a b &rest c)) &rest z) "** This test case was copied from p151 of CLtl **" `'(,x ,a ,b ,c ,z)) (equal (lamb3 1 (2 3 4 5) 6 7 8) '(1 2 3 (4 5) (6 7 8))) (equal (lamb3 (car pool)) '((car pool) nil nil nil nil)) (equal (lamb3 (car pool) (88 99) 100 200) '((car pool) 88 99 nil (100 200))) ;; ;; if the macro call specifies a explicitly, it doesn't have to specify b explicitly ;; (equal (lamb3 (car pool) (10) 100 200) '((car pool) 10 nil nil (100 200))) (equal (lamb3 (car pool) ((+ x 1))) '((car pool) (+ x 1) nil nil nil)))) ;; ;; ;; - It is permissible to use defmacro to redefine a macro, or to redefine a function as a macro - ;; - It is an error to attempt to redefine the name of a special form - ;; [from 8.1. Macro Definition (p 146) of CLtL] ;; (do-test test-redefine0 (and (defmacro redefine0 () ''fine) (equal (redefine0) 'fine) (defmacro redefine0 () ''fine-fine) (equal (redefine0) 'fine-fine))) (do-test test-redefine1 (and (defun redefine1 () 'fine) (equal (redefine1) 'fine) (defmacro redefine1 () ''fine-fine) (equal (redefine1) 'fine-fine))) ;;(do-test test-redefine2 ;; (and (eq nil (nlsetq (defmacro progn () ''new-macro))) ;; (eq nil (nlsetq (defmacro function () ''new-macro))) ;; (eq nil (nlsetq (defmacro labels () ''new-macro))))) ;; ;; (do-test "defmacro and defun" (equal '(fun macro macro fun) (list (PROGN (defun xx () 'fun) (XX)) (PROGN (defmacro xx () ''macro) (xx) ) (PROGN (defmacro xxx () ''macro) (xxx)) (PROGN (defun xxx () 'fun) (xxx))))) ;; ;; STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/8/8-1-PARSE-BODY.TEST b/internal/test/LANGUAGE/from-sun/language/8/8-1-PARSE-BODY.TEST new file mode 100644 index 00000000..1bd785af --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/8/8-1-PARSE-BODY.TEST @@ -0,0 +1 @@ +(do-test parse-body-test (let ((docstr "Doc-string #1")) (multiple-value-bind (body decls doc) (parse-body (list '(declare (special foo)) docstr '(declare (special bar)) "Doc-string #2" '(body-form 1) "Body string #1" '(body-form 2)) nil) (and (eq doc docstr) (equal (car body) '(body-form 1)) (= 2 (length decls)) (= 3 (length body))) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/8/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST b/internal/test/LANGUAGE/from-sun/language/8/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST new file mode 100644 index 00000000..0df15b23 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/8/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: macroexpand and macroexpand-1 ;; ;; Source: Steele's book Section 8.2: Macro Expansion Page: 151 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: May 15 '86 ;; ;; Last Update: June 2, 1986/masinter, change test-env1: don't use FOO, move MACROLET to the right place ;; ;; ;; Filed As: {eris}cml>test>8-2-macroexpand-and-macroexpand-1.test ;; ;; ;; Syntax: MACROEXPAND-1 form &optional env ;; MACROEXPAND form &optional env ;; ;; Function Description: MACROEXPAND-1 will expand the form (macro call) once and return two values ;; MACROEXPAND will repeatedly expand the form until it is no longer a macro call. ;; It also returns two values. ;; ;; Argument(s): form - a lisp form ;; env - an environment ;; ;; Returns: the expansion function and t - if the argument "form" is a macro call ;; form and nil - if the argument "form" is not a macro call ;; ;; ;; tests for *macroexpand-hook* variable ;; ;;This test commented out by Pavel because we do macro-caching by default in the system and thus don't use 'funcall as the default hook. ;;(do-test test-hook ;; ;; ;; ;; make sure its initial value is 'funcall' ;; ;; ;; (and (boundp '*macroexpand-hook*) ;; (eq *macroexpand-hook* 'funcall))) ;; ;; tests for "macroexpand-1" with null environment ;; (do-test test-macroexpand-10 (and (defmacro expand-10 () `(a b c)) (equal (multiple-value-list (macroexpand-1 '(expand-10))) '((a b c) t)))) (do-test test-macroexpand-11 (and (defmacro expand-11 (n0 n1 n2 n3 n4 n5) `(/= ,n0 ,n1 ,n2 ,n3 ,n4 ,n5)) (equal (multiple-value-list (macroexpand-1 '(expand-11 10 10.1 20.2 30 33 50))) '((/= 10 10.1 20.2 30 33 50) t)) (equal (multiple-value-list (macroexpand-1 '(expand-11 0 0.0 -1 1 (- 0 2) (+ 3 9)))) '((/= 0 0.0 -1 1 (- 0 2) (+ 3 9)) t)))) (do-test test-macroexpand-12 (and (defmacro expand-12 (n0 n1 n2) `(progn (defun () (list ,n0 ,n1 ,n2)))) (equal (multiple-value-list (macroexpand-1 '(expand-12 'good 'better 'best))) '((progn (defun () (list 'good 'better 'best))) t)) (equal (multiple-value-list (macroexpand-1 '(expand-12 (cons 1 2) (= 1 1.0) (evenp 4)))) '((progn (defun () (list (cons 1 2) (= 1 1.0) (evenp 4)))) t)))) (do-test test-macroexpand-13 ;; ;; tests for non-macro forms ;; (and (equal (multiple-value-list (macroexpand-1 '(no-such-macro 1 2 3))) '((no-such-macro 1 2 3) nil)) (equal (multiple-value-list (macroexpand-1 '(again-no-such-macro))) '((again-no-such-macro) nil)))) ;; ;; ;; ;; tests for "macroexpand" with null environment ;; ;; ;; (do-test test-macroexpand0 (and (defmacro expand0a () ''macro-no-fun) (defmacro expand0b () `(expand0a)) (defmacro expand0c () `(expand0b)) (equal (multiple-value-list (macroexpand '(expand0c))) '('macro-no-fun t)))) (do-test test-macroexpand1 (and (defmacro expand1a (a0 a1 a2) `(list ,a0 ,a1 ,a2)) (defmacro expand1b (b0 b1) `(expand1a (progn (defun fun1 () (+ ,b0 ,b1)) (fun1)) (progn (defun fun2 () (- ,b0 ,b1)) (fun2)) (progn (defun fun3 () (/ ,b1 ,b0)) (fun3)))) (defmacro expand1c () `(expand1b 10 20)) (equal (multiple-value-list (macroexpand '(expand1c))) '((list (progn (defun fun1 () (+ 10 20)) (fun1)) (progn (defun fun2 () (- 10 20)) (fun2)) (progn (defun fun3 () (/ 20 10)) (fun3))) t)))) (do-test test-macroexpand2 (and (defmacro expand2a (n0) `',n0) (defmacro expand2b (n0 n1) (let ((var (cons n1 n0))) `(expand2a ,var))) (defmacro expand2c (n0 n1) (let ((var (cons n1 n0))) `(expand2b ,var "d"))) (defmacro expand2d (n0 n1) (let ((var (cons n1 n0))) `(expand2c ,var "c"))) (defmacro expand2e (n0 n1) (let ((var (cons n1 n0))) `(expand2d ,var "b"))) (defmacro expand2f () (let ((var (list "-" ))) `(expand2e ,var "a"))) (equal (multiple-value-list (macroexpand `(expand2f))) '('("d" "c" "b" "a" "-") t)) (equal (multiple-value-list (macroexpand-1 `(expand2f))) '((expand2e ("-") "a") t)))) (do-test test-macroexpand3 ;; ;; tests for non-macro forms ;; (and (equal (multiple-value-list (macroexpand '(no-such-macro 1 2 3))) '((no-such-macro 1 2 3) nil)) (equal (multiple-value-list (macroexpand '(again-no-such-macro))) '((again-no-such-macro) nil)))) ;; ;; ;; tests for macroexpand/macroexpand-1 with &environment argument ;; ;; (do-test test-env0 (and (defmacro foo () ''global-foo) (defmacro env0 (&environment env) (macrolet ((foo () ''local-foo))) (macroexpand-1 '(foo))) (eq (env0) 'global-foo))) (do-test test-env1 (progn (defmacro test-env1-foo () ''global-foo) (defmacro env1 (&environment env) (macroexpand-1 '(test-env1-foo) env)) (macrolet ((test-env1-foo () ''local-foo)) (eq (env1) 'local-foo)))) ;; ;; ;; tests for AR # 5532 regarding "&body and &rest args don't get destructured" ;; ;; (do-test test-5532ar0 (and (defmacro 5532ar0 (&rest (foo bar)) `'(,foo %% ,bar)) ;; (equal (multiple-value-list (macroexpand '(5532ar0 1 2))) '('(1 %% 2) t)) (equal (5532ar0 1 2) '(1 %% 2)) )) (do-test test-5532ar1 (and (defmacro 5532ar1 (&body ((foo (bar (bar1 &optional (bar2 88)))))) `'(,foo %% ,bar %% ,bar1 %% ,bar2)) ;; (equal (multiple-value-list (macroexpand '(5532ar1 1 (2 (3 4))))) '('(1 %% 2 %% 3 %% 4) t)) (equal (5532ar1 1 (2 (3 4))) '(1 %% 2 %% 3 %% 4)) (equal (multiple-value-list (macroexpand '(5532ar1 1 (2 (3))))) '('(1 %% 2 %% 3 %% 88) t)) (equal (5532ar1 1 (2 (3))) '(1 %% 2 %% 3 %% 88)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/8/8-MACRO-ARG-EVAL-ORDER.PRETEST b/internal/test/LANGUAGE/from-sun/language/8/8-MACRO-ARG-EVAL-ORDER.PRETEST new file mode 100644 index 00000000..a6d244af --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/8/8-MACRO-ARG-EVAL-ORDER.PRETEST @@ -0,0 +1 @@ +;; ;; Created By: Karin M. Sye ;; ;; Creation Date: 21, Dec., 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test> 8-macro-arg-eval-order.test ;; (do-test "test order of evaluation of arguments to system provided macros" (let (counter macro-name) (macrolet ((foo (counter-value foo-value) "define the test parameter production" `(progn (unless (= ,counter-value (incf counter)) (print (concatenate 'string "arguments to macro '" macro-name "' evaluated out of order") *error-output*)) ,foo-value)) (test (name) "reset the variables COUNTER and MACRONAME" `(setq counter 0 macro-name ,name)) ) ;; ;; now let's do the tests ;; ;; AND ;; (test "and") (and (foo 1 1) (foo 2 (values 6 60 600)) (foo 3 (values nil t)) (foo 99 #\a)) (and (foo 4 'a) (foo 5 'b) (foo 6 'c) (foo 7 'd)) ;; ;; CASE ;; (test "case") (case 'bar ( bar1 (foo 99 'bar1)) ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju)) ( bar4 (foo 99 'bar4)) ( otherwise (foo 99 'other))) ; (case 'quack ((3 quack3) (foo 99 '3)) (('quack) (foo 99 '0)) (t (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit))) ; (case nil ( non-nil (foo 99 'non-nil)) ( nill (foo 99 'nill))) ; (case t ( t (foo 9 t))) ;; ;; CCASE ;; (test "ccase") (let ( (bar '(bar bar2 t)) ) (ccase (pop bar) ( bar1 (foo 99 'bar1)) ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju)) ( bar4 (foo 99 'bar4))) ; (ccase (pop bar) (bar2 (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit))) ; (ccase (pop bar) ((t) (foo 9 t)))) ;; ;; CHECK-TYPE ;; (test "check-type") (let ((var '(12 #\w "str" (1 2 3)) )) (check-type (caddr (foo 1 var)) string (foo 2 (concatenate 'string "a " "string")) )) ;; ;; COND ;; (test "cond") (cond ((foo 1 (oddp 20)) (foo 99 (1+ 20))) ((foo 2 (evenp 3)) (foo 99 (1- 3))) ((foo 3 (= (sqrt #18r10000) #18r100)) (foo 4 'gochu)) ((foo 99 t) 180)) ;; (cond ((foo 5 nil) (foo 99 10)) ((foo 6 nil) (foo 99 20)) ((foo 7 t) (foo 8 30) (foo 9 40) (foo 10 (values 30 40 50))) ((foo 99 t) "buggy")) ;; ;; CTYPECASE ;; (test "ctypecase") (let ((var '(100 #\q t) )) (ctypecase (foo 1 (pop var)) ((or float string) (foo 99 'fool1)) ((integer 105 200) (foo 99 'fool2)) ( fixnum (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy)) ( package (foo 99 'fool3))) ; (ctypecase (foo 6 (pop var)) ((or vector stream) (foo 99 'fool4)) ((or string character) (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9))) ( ratio (foo 99 'fool5))) ; (ctypecase (foo 10 (pop var)) (atom (foo 11 'hwow!)))) ;; ;; DECF ;; (test "decf") (let ((a 0)) (declare (special a)) (decf (symbol-value (foo 1 'a)) (foo 2 -5)) (decf (symbol-value (foo 3 'a)) (foo 4 50))) ;; ;; DEFCONSTANT ;; (test "defconstant") (defconstant mac-arg-3 (foo 1 246)) (defconstant mac-arg-4 (foo 2 135) (foo 3 "a constant")) ;; ;; DEFINE-MODIFY-MACRO name lambda-list function [doc-string] ;; ;; ** Test case was not generated since none of the arguments need to be evaluated ** ;; ;; DEFMACRO ;; (test "defmacro") (defmacro mac ( x y) (foo 1 (declare (integer x y))) (foo 2 "a dummy macro") (foo 3 'nonsense1) (foo 4 'nonsense2) (foo 5 `(progn (values (+ ,x ,y) (- ,x ,y) (* ,x ,y))))) (fmakunbound 'mac) ;; ;; DEFPARAMETER ;; (test "defparameter") (defparameter mac-arg-2 (foo 1 100)) (defparameter mac-arg-2 (foo 2 300) (foo 3 "a global var")) ;; ;; DEFSTRUCT ;; (test "defstruct") (let () (defstruct new-blocks (length (foo 1 10) :type fixnum) (wide (foo 2 5 ) :type fixnum) (height (foo 3 20) :type fixnum) (volume (foo 4 (* 5 10 20)) :type fixnum) (number-of-block (foo 5 8) :type fixnum :read-only t) (total-volume (foo 6 (* 5 10 20 8)) :type fixnum) ) (make-new-blocks)) ;; ;; DEFTYPE ;; (test "deftype") (deftype square-matrix (&optional type size) "SQUARE-MATRIX includes all aquare two-dimentional arrays." (foo 1 (setq a1 'array)) (foo 2 (setq a2 `,type)) (foo 3 (setq a3 `(,size ,size))) (foo 4 (list a1 a2 a3) )) ;; ;; DEFUN ;; (test "defun") (defun fun (x y buf) (foo 1 (declare (integer x y) (list buf))) (foo 2 "a fun function") (foo 3 (push 'form1 buf)) (foo 4 (push 'form2 buf)) (foo 5 (push 'form3 buf)) (foo 6 (if (evenp x) (push 'form4 buf))) (foo 7 (if (oddp y) (return buf))) (foo 8 (return (progn (push 'form8 buf) buf)))) (fmakunbound 'fun) ;; ;; DEFVAR ;; (test "defvar") (every #'makunbound '(mac-arg-1 mac-arg-11)) (defvar mac-arg-1 (foo 3 11)) (defvar mac-arg-11 (foo 2 22) (foo 1 "a special var")) (evenp (+ mac-arg-11 mac-arg-1)) ;; ;; DO ;; (test "do") (do ((z '(1 2 3 4 5) (rest z))) ((foo 1 (null z)) "something is wrong") (foo 2 (and (= (car z) 1) (return 'gochu)))) ; (do ((w 0 (+ w 1)) (buf '(9))) ((foo 3 (zerop w)) (foo 4 (nconc buf (list w (+ 1 w)))) (foo 5 (reverse buf))) (foo 6 "wrong")) ; (do ((m 0 (incf m)) (n 2 (incf n 2)) (o 3 (incf o 3))) ((foo 6 (< 10 (+ m n o))) "sum > 10") (foo 7 (declare (fixnum m))) (foo 8 (declare (fixnum n))) (foo 9 (declare (integer o))) (foo 10 (if (plusp (lcm m n o)) (return "+"))) (foo 11 (if (minusp (gcd m n o)) (return "-"))) (foo 12 (return 'hooray))) ;; ;; DO* ;; (test "do*") (do* ((z '(1 2 3 4 5) (rest z))) ((foo 1 (null z)) "something is wrong") (foo 2 (and (= (car z) 1) (return 'gochu)))) ; (do* ((w 0 (+ w 1)) (buf '(9))) ((foo 3 (zerop w)) (foo 4 (nconc buf (list w (+ 1 w)))) (foo 5 (reverse buf))) (foo 6 "wrong")) ; (do* ((m 0 (incf m)) (n 2 (incf n 2)) (o 3 (incf o 3))) ((foo 6 (< 10 (+ m n o))) "sum > 10") (foo 7 (declare (fixnum m))) (foo 8 (declare (fixnum n))) (foo 9 (declare (integer o))) (foo 10 (if (plusp (lcm m n o)) (return "+"))) (foo 11 (if (minusp (gcd m n o)) (return "-"))) (foo 12 (return 'hooray))) ;; ;; DO-ALL-SYMBOLS ;; (test "do-all-symbols") (progn (do-all-symbols (x) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 (if (find-symbol (string x) (car (list-all-packages))) (return 'first))))) ;; ;; DO-EXTERNAL-SYMBOLS ;; (test "do-external-symbols") (progn (import '(lisp:vector) 'user) (export '(user::vector) 'user) (do-external-symbols (x (find-package 'user)) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 (if (find-symbol (string x) 'user) (return 99))))) ;; ;; DO-SYMBOLS ;; (test "do-symbols") (let ((pac (or (find-package "macro-arg-pac") (make-package "macro-arg-pac" :use NIL) )) result) (progn (set (intern "joke" pac) 789) (do-symbols (x pac (foo 5 result)) (foo 1 (push (numberp x) result)) (foo 2 (push (arrayp x) result)) (foo 3 (push (rationalp x) result)) (foo 4 (push (symbolp x) result)) ))) ;; ;; DOLIST ;; (test "dolist") (dolist (x (foo 1 '()) (foo 2 "bye")) (foo 3 nil)) ; (dolist (x (foo 3 '(#\q)) (foo 5 "end-of-list")) (foo 4 (characterp x))) ; (dolist (x (foo 6 '(2)) (foo 99 'jumpy)) (foo 7 (setq x (sqrt x))) (foo 8 (return x))) ;; ;; DOTIME ;; (test "dotimes") (dotimes (x (foo 1 0) (foo 2 "bye")) (foo 3 nil)) ; (dotimes (x (foo 3 1) (foo 5 "end-of-list")) (foo 4 (characterp x))) ; (dotimes (x (foo 6 1) (foo 99 'jumpy)) (foo 7 (setq x (sqrt x))) (foo 8 (go tag)) done (foo 10 (return x)) tag (foo 9 (go done))) ;; ;; ECASE ;; (test "ecase") (let ( (bar '(bar bar2 t)) ) (ecase (pop bar) ( bar1 (foo 99 'bar1)) ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju)) ( bar4 (foo 99 'bar4))) ; (ecase (pop bar) (bar2 (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit))) ; (ecase (pop bar) ((t) (foo 9 t)))) ;; ;; ETYPECASE ;; (test "etypecase") (etypecase (foo 1 100) ((or float string) (foo 99 'fool1)) ((integer 105 200) (foo 99 'fool2)) ( fixnum (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy)) ( package (foo 99 'fool3))) ; (etypecase (foo 6 #\q) ((or vector stream) (foo 99 'fool4)) ((or string character) (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9))) ( ratio (foo 99 'fool5))) ;; ;; INCF ;; (test "incf") (let ((a 0)) (declare (special a)) (incf (symbol-value (foo 1 'a)) (foo 2 -5)) (incf (symbol-value (foo 3 'a)) (foo 4 50))) ;; ;; LOCALLY ;; (test "locally") (locally (foo 1 (floor 3 8)) (foo 2 (ceiling 3 8)) (foo 3 (truncate 3 8)) (foo 4 (round 3 8))) ; (locally (foo 5 (declare (inline floor round car))) (foo 6 (declare (notinline truncate ceiling cdr))) (foo 7 (declare (optimize space))) (foo 8 (floor 3 8)) (foo 9 (ceiling 3 8)) (foo 10 (truncate 3 8)) (foo 11 (round 3 8))) ;; ;; LOOP ;; (test "loop") (loop (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 8) (foo 9 9) (foo 10 10) (foo 11 (return t))) ;; ;; MULTIPLE-VALUE-BIND ;; (test "multiple-value-bind") (multiple-value-bind (n0 n1 n2) (foo 1 (values-list '(0 1 2))) (foo 2 (setq n1 (+ n0 n2 100))) (foo 3 (setq n2 (* n1 23))) (foo 4 (setq n0 (lcm n1 n2))) (foo 5 (list n0 n1 n2)) ) ;; ;; MULTIPLE-VALUE-LIST ;; (test "multiple-value-list") (multiple-value-list (foo 1 (values 'a 'b 'c 'd 'e 'f 'g))) (multiple-value-list (foo 2 '(1 2 3 4 5 6 7))) ;; ;; MULTIPLE-VALUE-SETQ ;; (test "multiple-value-setq") (multiple-value-setq (n0 n1 n2) (foo 1 (values 10 20 30 40 50))) (multiple-value-setq (n0 n1) (foo 2 (values-list '(11 22)))) ;; ;; OR ;; (test "or") (or (foo 1 (values nil 1 11)) (foo 2 'nil) (foo 3 3) (foo 4 'atom4) (foo 5 55)) (or (or (foo 4 nil) (foo 5 'nil)) (or (foo 6 nil) (foo 7 99)) (foo 8 nil) (foo 9 t)) ;; ;; POP ;; (test "pop") (let ((a '(10 20 30 40 50 (60 77 88)) )) (declare (special a)) (pop (symbol-value (foo 1 'a))) (pop (fifth (foo 2 a))) ) ;; ;; PROG ;; (test "prog") (prog ((a 1) (b 2) (c 3) (d 4)) (foo 1 (setq c (* (+ a d) (- c b)))) (foo 2 (setq d (gcd (expt c 3) (* 99 d)))) (foo 3 (setq a (lcm c d))) (foo 4 (setq b (complex c a))) (foo 5 (return (list a b c d))) ) ;; ;; PROG* ;; (test "prog*") (prog* ((a 10) (b (* a 2)) (c (+ a b))) (foo 1 (declare (fixnum a b c))) (foo 2 "a simple prog* form") (foo 3 (if (evenp (+ a b)) (go tag1))) tag2 (foo 5 (go exit)) tag1 (foo 4 (go tag2)) exit (foo 6 (return (mapcar #'list (list a b c))))) ;; ;; PROG1 ;; (test "prog1") (prog1 (foo 1 "1") (foo 2 "2") (foo 3 "3") (foo 4 "4") (foo 5 "5")) (prog1 (foo 6 "66") (foo 7 "77") (foo 8 "done")) ;; ;; PROG2 ;; (test "prog2") (prog2 (foo 1 'a) (foo 2 (prog2 (foo 3 'c) (foo 4 'd) (foo 5 'e)(foo 6 'f) )) (foo 7 'g)) (prog2 (foo 8 (defun fun () 'fun-fun)) (foo 9 (fun)) (foo 10 (fmakunbound 'fun))) ;; ;; PSETF ;; (test "psetf") (let ((a 22) (b '(1 2 3 4 5)) (c '(11 22 33 44)) (d 44)) (declare (special a d)) (psetf (symbol-value (foo 1 'a)) (foo 2 b) (second (foo 3 b)) (foo 4 a) (rest (foo 5 c)) (foo 6 d) (symbol-value (foo 7 'd)) (foo 8 (incf a d)) )) ;; ;; PSETQ ;; (test "psetq") (let (a b c d) (psetq a (foo 1 'a) b (foo 2 `b) c (foo 3 'c) d (foo 4 'd)) (psetq a (foo 5 b) b (foo 6 a))) ;; ;; PUSH ;; (test "push") (let ((a '(1 2 3 4 5 6 7 8 9 10) )) (push (foo 1 100) (third (foo 2 a))) (push (foo 3 200) (rest (foo 4 a))) ) ;; ;; PUSHNEW ;; (test "pushnew") (let ( (a 0) (aa '( 5 4 3)) ) (pushnew (foo 1 (incf a)) (first (foo 2 (list (list a) a)))) (pushnew (foo 3 (first aa)) (second (foo 4 (setq aa (reverse aa)))) :test (foo 5 #'=) ) ) ;; ;; REMF ;; (test "remf") (let ((a 1)) (setf (symbol-plist 'a) '(color blue height 6.6 near-to bar weight 230)) (remf (symbol-plist (foo 1 'a)) (foo 2 'height)) (remf (symbol-plist (foo 3 'a)) (foo 4 'weight)) ) ;; ;; RETURN ;; (test "return") (do () () (return (foo 1 100))) (prog () (return (foo 2 30))) (dolist (x '(1)) (return (foo 3 x))) (dotimes (x 1) (return (foo 4 x))) ;; ;; ROTATEF ;; (test "rotatef") (let ((a '(a b c d e f g h) )) (rotatef (car (foo 1 a)) (cadr (foo 2 a)) (caddr (foo 3 a)) (cadddr (foo 4 a)) (fifth (foo 5 a)) (sixth (foo 6 a)) (seventh (foo 7 a)) (eighth (foo 8 a))) ) ;; ;; SETF ;; (test "setf") (let ((a '(1 2 3 4 5 6 7 8 9 10)) ) (setf (subseq (foo 1 a) 1 3) (foo 2 '(11 22)) (cadddr (foo 3 a)) (foo 4 44) (ninth (foo 5 a)) (foo 6 99))) ;; ;; SHIFTF ;; (test "shiftf") (let ((a '(a b c d e f) )) (shiftf (car (foo 1 a)) (cadr (foo 2 a)) (caddr (foo 3 a)) (cadddr (foo 4 a)) (fifth (foo 5 a)) (sixth (foo 6 a)) (foo 7 'z)) ) ;; ;; STEP form ;; ;; ** single form doesn't need test cases ** ;; ;; TIME form ;; ;; ** single form doesn't need test cases ** ;; ;; TRACE {function-name}* ;; ;; ** no arguments need to be evaluated ** ;; ;; UNTRACE {function-name}* ;; ;; ** no arguments need to be evaluated ** ;; ;; TYPECASE ;; (test "typecase") (typecase (foo 1 100) ((or float string) (foo 99 'fool1)) ((integer 105 200) (foo 99 'fool2)) ( fixnum (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy)) ( otherwise (foo 99 'fool3))) ; (typecase (foo 6 #\q) ((or vector stream) (foo 99 'fool4)) (otherwise (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9))) (t (foo 99 'fool5))) ;; ;; UNLESS ;; (test "unless") (unless (foo 1 nil) (foo 2 3) (foo 3 4) (foo 4 5) (foo 5 (values 6 66 666))) (unless (foo 6 t) (foo 99 "ouch")) ;; ;; WHEN ;; (test "when") (when (foo 1 nil) (foo 2 "ouch")) (when (foo 2 'star) (foo 3 3) (foo 4 4) (foo 5 5) (foo 6 (values 6 66 666))) ;; ;; WITH-INPUT-FROM-STRING ;; (test "with-input-from-string") (let (a str buf) (with-input-from-string (s1 (foo 1 "abc")) (foo 2 (read s1))) (with-input-from-string (s1 (foo 3 "abcde") :index (symbol-value (foo 11 'a)) :start (foo 4 1) :end (foo 5 4)) (foo 6 (setq str (string (read s1)))) (foo 7 (push (map 'string #'char-upcase str) buf)) (foo 8 (push (map 'list #'char-code str) buf)) (foo 9 (push (map 'vector #'standard-char-p str) buf)) (foo 10 buf))) ;; ;; WITH-OPEN-FILE ;; ;; (more coming) ;; ;; WITH-OPEN-STREAM ;; (test "with-open-stream") (let (buf) (with-open-stream (strim (foo 1 (make-string-input-stream "abcdefg"))) (foo 2 (setq buf (string (read strim)))) (foo 3 (setq buf (concatenate 'string buf " has length of " (prin1-to-string (length buf))))) (foo 4 buf))) ;; ;; WITH-OUTPUT-TO-STRING ;; (test "with-output-to-string") (let ((str (make-array 10 :element-type 'character :fill-pointer 0)) buf) (with-output-to-string (s1 str) (foo 1 (write-char #\a s1)) (foo 2 (write-char #\b s1)) (foo 3 (push str buf)) (foo 4 (write-char #\c s1)) (foo 5 (write-char #\d s1)) (foo 6 (push str buf)) (foo 7 buf))) ) ; end of macrolet ) ; end of let ); end of do-test STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/9/9-1-DECLARE.TEST b/internal/test/LANGUAGE/from-sun/language/9/9-1-DECLARE.TEST new file mode 100644 index 00000000..5b3b1319 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/9/9-1-DECLARE.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: declare ;; ;; Source: CLtL p. 153 ;; Chapter 9: Declarations Section 1: Declaration Syntax ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov 3, 1986 ;; ;; Last Update: Jan 28, 1987 Jim Blum - removed null :before forms in do-test-groups ;; Feb 5, 1987 Jim Blum - more fixes ;; Filed As: {eris}cml>test> 9-1-declare.test ;; ;; ;; Syntax: declare {decl-spec}* ;; ;; Function Description: The declare construct is used for embedding declarations within executable code. Declarations may occur in ;; lambda-expressions and in the forms listed below. ;; ;; defmacro defsetf deftype defun do* do-all-symbols do-external-symbols do-symbols ;; do dolist dotimes flet labels let let* locally ;; macrolet multiple-value-bind prog prog* ;; ;; ;; ;; Argument(s): decl-spec - anyone of the following declaration specifiers: ;; ;; special, type , ftype , function , inline , notinline , ignore , optimize , declaration ;; ;; Returns: It is an error to evaluate a declaration. Those special forms that permit declaratins to appear perform ;; explicit checks for their presence. ;; ;; ;; (do-test declare-is-not-a-macro (let ((decl (declare (special foo)))) (multiple-value-bind (new-form anything-changed) (macroexpand decl nil) (and (eq decl new-form) (null anything-changed)) ) ) ) (do-test-group ("test declare - with test case from page 155 of CLtL" :before (progn (test-defun fool (x y &optional (z "tail")) (list x y z)) ;; ;; test case copied from page 155 of CLtL ;; (test-defun nonsense (k x z) (fool z x) ;; first call to fool (let ((j (fool k x)) ;; second call to fool (x (* k k))) (declare (inline fool) (special x z)) (fool x j z))) ;; third call to fool )) ;; I now believe that this test is correct with respect to CLtL. ;; If you disagree, please talk to me before changing it. --Pavel (do-test "test declare - with test case from page 155 of CLtL" (and (equal (progv '(x z) '("special x" "special z") (nonsense 33 "loc x" "loc z")) '(1089 (33 "special x" "tail") "special z") ) (equal (progv '(x z k) '(10 20 30) (nonsense 3 1 2)) '(9 (3 10 "tail") 20)) ) ) ) (do-test-group ("test declare - with test case from page 157 of CLtL" :before (progn ;; ;; test case copied from page 157 of CLtL ;; (test-defun hack (thing *mod*) (declare (special *mod*)) (hack1 (car thing))) (test-defun hack1 (arg) (declare (special *mod*)) (if (atom arg) *mod* (cons (hack1 (car arg)) (hack1 (cdr arg))))) )) (do-test "test declare - with test case from page 157 of CLtL" (let ((modvar "mo")) (and (equal (hack '(atom) modvar) "mo") (equal (hack '(((atom0 atom1) atom2) atom3) modvar) '(("mo" "mo" . "mo") "mo" . "mo")) ) ) ) ) (do-test-group ("test declare - with test case from page 158 of CLtL" :before (progn ;; ;; test case copied from page 158 of CLtL ;; (test-defun example (x y) (declare (special y)) (let ((y 3) (x (* x 2))) (list (+ y (locally (declare (special y)) y)) (let ((y (incf y 4))) (declare (special y)) (list (fo y) (fo x))) ))) (test-defun fo (x) x) )) (do-test "test declare - with test case from page 158 of CLtL" (prog2 (proclaim '(special x)) (and (equal (example 15 10) '(13 (14 30))) (equal (example 5 0) '( 3 ( 4 10))) ) ) ) ) (do-test-group ("test declare - with test case from page 160 of CLtL" :before (progn ;; ;; test case copied from page 160 of CLtL ;; (test-defun often-used-subroutine (x y) (declare (optimize (safety 2))) ; (error-check x y) ; (hairy-setup x) (prog (buf) (dotimes (xx y) (setq buf (append buf x))) (setq x buf)) (do ((i 0 (+ i 1)) (z x (cdr z))) ((null z) i) ;; This inner loop really needs to burn. (declare (optimize speed)) (declare (fixnum i)) )) )) (do-test "test declare - with test case from page 160 of CLtL" (and (= (often-used-subroutine '(3 4) 5) 10) (= (often-used-subroutine '(1 3 4 5 ( a b)) 10) 50) ) ) ) (do-test-group ("test declare - with test case from page 161 of CLtL" :before (test-defun strange (x) (declare (author "Harry Tweeker")) (member x '(strange weird odd peculiar))) ) (do-test "test declare - with test case from page 161 of CLtL" (progn (proclaim '(declaration author target-language target-machine)) (proclaim '(target-language ada)) (proclaim '(target-machine IBM-650)) (and (equal (strange 'weird) '(weird odd peculiar)) (equal (strange 'strange) '(strange weird odd peculiar)) (not (strange 'n0way)) ) ) ) ) (do-test-group "test declare in let construct" (do-test " test declare in let construct - type function and ftype" (equal (let ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in let construct - inline notinline and ignore" (equal (let ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third ))) '(2 1 4 3))) (do-test "test declare in let construct - optimize and declaration" (equal (let ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) )) 50)) ) (do-test-group "test declare in let* construct" (do-test " test declare in let* construct - type function and ftype" (equal (let* ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in let* construct - inline notinline and ignore" (equal (let* ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third ))) '(2 1 4 3))) (do-test "test declare in let* construct - optimize and declaration" (equal (let* ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) )) 50)) ) (do-test-group "test declare in prog construct" (do-test " test declare in prog construct - type function and ftype" (equal (prog ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (return (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2)))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in prog construct - inline notinline and ignore" (equal (prog ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (return (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third )))) '(2 1 4 3))) (do-test "test declare in prog construct - optimize and declaration" (equal (prog ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (return (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) ))) 50)) ) (do-test-group "test declare in prog* construct" (do-test " test declare in prog* construct - type function and ftype" (equal (prog* ((a 0) (b 4.00) c (d '(3 4 5 6))) (declare (type integer a)) (declare (float b)) (declare (string c)) (declare (ftype (function (integer list) t) nth) (ftype (function (number) float) sin cos)) (declare (function length (sequence) (integer 0 *)) (function floor (number number) (values integer integer))) (return (list (nth 2 d) (sin a) (cos a) (length (setq c "12345")) (multiple-value-list (floor b 2)))) ) '( 5 0.0 1.0 5 (2 0.0)) )) (do-test " test declare in prog* construct - inline notinline and ignore" (equal (prog* ((a '(1 2 3 4))) (declare (list a)) (declare (inline first second) (notinline third fourth) (ignore ghostvar1 ghostvar2)) (return (mapcar #'(lambda (x) (funcall x a)) (list #'second #'first #'fourth #'third )))) '(2 1 4 3))) (do-test "test declare in prog* construct - optimize and declaration" (equal (prog* ( (z (make-list 50 :initial-element '(2))) ) (declare (optimize (space 2) (safety 3) (compilation-speed 1))) (return (do ((i 0 (1+ i)) (a z (cdr a))) ((null a) i) (declare (optimize speed)) (declare (fixnum i) (list a)) ))) 50)) ) (do-test-group "test declare in do construct" (do-test " test declare in do construct - type function and ftype" (equalp (do ( (a 0 (+ 2 a)) (s '(2 3 5 6 8 12 9 8 3 4 56) (cdr s)) (b #*10 (concatenate 'vector b b))) ((or (>= (length b) (length s)) (>= a 8)) (list a s b)) (declare (fixnum a) (list s) (type (simple-bit-vector 12) b)) (declare (ftype (function (list) t) cdr)) (declare (function concatenate ((or list vector) sequence sequence) sequence)) ) '(6 (6 8 12 9 8 3 4 56) #*1010101010101010))) (do-test " test declare in do construct -linline , notinline , ignore and optimize" (equal (do ((i 0 (1+ i)) (buf nil (append buf (list (expt i 2))) )) ( (> (apply #'+ buf) 500) buf) (declare (inline 1+ oddp expt list) (notinline apply) ) (declare (ignore *no-such-var* *no-such-symbol*)) (declare (optimize speed (space 2) (compilation-speed 0) )) ) '(0 1 4 9 16 25 36 49 64 81 100 121))) (do-test " test declare in do construct - declaration" (= (do ((s "abcdefghijklmn" (subseq s 0 (1- (length s))) )) ((equal (elt (reverse s) 0) #\f) (length s) ) (proclaim '(declaration ugly-dec1 ugly-dec2 ugly-dec3)) (proclaim '(ugly-dec1 nonsense1)) (proclaim '(ugly-dec2 nonsense2)) (proclaim '(ugly-dec3 nonsense3)) ) 6) ) ) (do-test-group "test declare in do* construct" (do-test " test declare in do* construct - type function and ftype" (equalp (do* ( (a 0 (+ 2 a)) (s '(2 3 5 6 8 12 9 8 3 4 56) (cdr s)) (b #*10 (concatenate 'vector b b))) ((or (>= (length b) (length s)) (>= a 8)) (list a s b)) (declare (fixnum a) (list s) (type (simple-bit-vector 12) b)) (declare (ftype (function (list) t) cdr)) (declare (function concatenate ((or list vector) sequence sequence) sequence)) ) '(6 (6 8 12 9 8 3 4 56) #*1010101010101010))) (do-test " test declare in do* construct -linline , notinline , ignore and optimize" (equal (do* ((i 0 (1+ i)) (buf nil (append buf (list (expt i 2))) )) ( (> (apply #'+ buf) 500) buf) (declare (inline 1+ oddp expt list) (notinline apply) ) (declare (ignore *no-such-var* *no-such-symbol*)) (declare (optimize speed (space 2) (compilation-speed 0) )) ) '(1 4 9 16 25 36 49 64 81 100 121))) (do-test " test declare in do* construct - declaration" (= (do* ((s "abcdefghijklmn" (subseq s 0 (1- (length s))) )) ((equal (elt (reverse s) 0) #\f) (length s) ) (proclaim '(declaration ugly-dec1 ugly-dec2 ugly-dec3)) (proclaim '(ugly-dec1 nonsense1)) (proclaim '(ugly-dec2 nonsense2)) (proclaim '(ugly-dec3 nonsense3)) ) 6) ) ) (do-test-group "test declare in lambda-expression construct" (do-test " test declare in lambda-expression construct - type , function and ftype" (equal ((lambda ( a b &optional (c #'floor) (d #'-)) (declare (integer a) (type (float 2.0 10.0) b)) (declare (ftype (function (integer integer) (values fixnum float)) c)) (declare (function d (number number) number)) (list (multiple-value-list (funcall c b 2.0)) (apply d (list a 9))) ) 20 8 ) '((4 0.0) 11) )) (do-test " test declare in lambda-expression construct - inline, notinline, ignore" (equal (mapcar #'(lambda (x y z) (declare (inline car) (notinline last) (ignore *no-such-var1* *no-such-var2*)) (declare (list x y) (function z (integer integer) integer)) (funcall z (car x) (car (last y))) ) '((2 3) (5 1) (3 9)) '((10 2 -1) (2 4 -8)) (list #'* #'+)) '(-2 -3))) (do-test " test declare in lambda-expression construct - optimize and declaration" (equal ((lambda ( lst0 &key (lst1 '(3 9 8 39 1)) (lst2 '(10 45 -3 -17))) (declare (list lst0 lst1 lst2)) (declare (optimize (speed 3) (safety 2))) (proclaim '(declaration proc1 proc2)) (proclaim '(proc1 foo1)) (proclaim '(proc2 foo2)) (sort (append lst0 lst2 lst1) #'<)) '(40 52 32 66 -1 -20) :lst2 '(-17 -47 -27 37)) '(-47 -27 -20 -17 -1 1 3 8 9 32 37 39 40 52 66)) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/9/9-1-LOCALLY.TEST b/internal/test/LANGUAGE/from-sun/language/9/9-1-LOCALLY.TEST new file mode 100644 index 00000000..3b8c2abe --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/9/9-1-LOCALLY.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: locally ;; ;; Source: CLtL p. 156 ;; Chapter 9: Declarations Section 1: Declaration Syntax ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 4, 86 ;; ;; Last Update: Feb 5, 1987 Jim Blum - fixed typo in specifier 1 test ;; ;; Filed As: {eris}cml>test> 9-1-locally.test ;; ;; ;; Syntax: locally {declaration}* {form}* ;; ;; Function Description: Locally may be used to make local pervasive declarations where desired. ;; ;; Argument(s): declaration - a declare statement ;; ;; Returns: anything ;; (do-test "test locally - test case from page 156 of CLtL" (equal (multiple-value-list (locally (declare (inline floor) (notinline car cdr)) (declare (optimize space)) (floor (car '(2 3)) (cdr '(8 . 1))) )) '(2 0) )) (do-test "test locally with 'special' declaration specifier 0" (equal (let ((a 6) ( b 8)) (declare (fixnum a b) (special a b)) (let ((a 1) (b 9)) (list a b (* 10 (locally (declare (special a)) a) ) (- 99 (locally (declare (special b)) b) ) (+ a b) ))) '(1 9 60 91 10))) (do-test "test locally with 'special' declaration specifier 1" (= (catch 'exit (let ((x 10) (y 20)) (declare (special y)) (prog (( x 90) (y 40)) (declare (special x)) (let ((x 99) (y 88)) (throw 'exit (+ (locally (declare (special y)) y) (locally (declare (special x)) x) )))))) 119)) (do-test-group ( "test locally with 'inline' 'notinline' and 'optimize' declaration specifiers" :before (test-defun get-list (num inc) (declare (type (mod 26) num) (type (mod 20) inc)) " get-list function returns a list of numbers less than 100. The first arg indicates the starting number and the second arg indicates the incrementation." (do (( x num (+ x inc)) (buf nil (locally (declare (inline append) (notinline list)) (append buf (list x)))) ) ((>= x 100) buf) (declare (fixnum x)) (declare (optimize (safety 2) speed (space 2))) ) )) (do-test "test locally with 'inline' 'notinline' and 'optimize' declaration specifiers" (equal (let ( (aray (make-array 4 :element-type 'list)) (index -1)) (declare (type (simple-array 'list 4) aray) (index fixnum)) (declare (inline sort)) (sort (mapcan #'(lambda (x y) (setf (aref aray (incf index)) (locally (declare (inline get-list)) (get-list x y)) )) '(25 20 15 10) '(20 20 15 15)) #'>) ) '(90 85 85 80 75 70 65 60 60 55 45 45 40 40 30 25 25 20 15 10) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/9/9-1-PROCLAIM.TEST b/internal/test/LANGUAGE/from-sun/language/9/9-1-PROCLAIM.TEST new file mode 100644 index 00000000..259ec9ce --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/9/9-1-PROCLAIM.TEST @@ -0,0 +1 @@ +;; ;; Function To Be Tested: proclaim ;; ;; Source: CLtL p. 156 ;; Chapter 9: Declarations Section 1: Declaration Syntax ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Nov. 5, 86 ;; ;; Last Update: Nov. 5, 86 ;; ;; Filed As: {eris}cml>test> 9-1-proclaim.test ;; ;; ;; Syntax: proclaim decl-spec ;; ;; Function Description: The function proclaim takes a decl-spec as its argument and puts it into effect globally. Because proclaim ;; is a function, its argument is always evaluated. Any variable names mentioned are assumed to refer to the ;; dynamic values of the variable. Similarly, any function names mentioned are assumed to reger to the ;; global function definition. ;; ;; Argument(s): del-spec - one of the following declaration specifiers: ;; special type ftype function ;; inline notinline ignore optimize declaration ;; ;; ;; Returns: ;; (do-test "test proclaim with type and special decl-spec" (progn (proclaim '(special x)) (proclaim '(fixnum x)) ;; x was just proclaimed to be always special and its value be a fixnum (defun foo (x) (let ((x (* x 2))) (list x (locally (declare (special x)) x)) )) (progv '(x) '(99) (let ((x 88)) (equal (foo x) '(176 176)) ) ) ) ) (do-test "test proclaim with type, ftype , and function decl-spec" (equal (progv '(x y) '(0.0 (a b c d)) (proclaim '(type float x)) (proclaim '(list y)) (proclaim '(ftype (function (integer list) t) nth)) (proclaim '(function sin (number) float)) `(,(nth 2 y) ,(sin x)) ) '(c 0.0) ) ) (do-test "test proclaim with inline and notinline decl-spec 0" (equal (let (buf) ;; ;; advise that floor should be open-coded in-line by the compiler ;; (proclaim (list 'inline 'floor )) (push (list (floor 8 2) (floor 100.0 10) (floor 30 5.0)) buf) (defun foo (x y) ;; ;; now advise floor to be compiled out-of-line in the body of foo by the compiler ;; (declare (notinline floor)) (floor x y) ) (push (list (foo 8 3) (foo 10 2) (foo 20 4)) buf) (push (list (floor 999 9) (floor 7777 11)) buf) buf) '( (111 707) (2 5 5) (4 10 6)) )) (do-test "test proclaim with inline and notinline decl-spec 1" (equal (progn (proclaim '(inline expt)) (proclaim '(notinline sqrt)) (list (expt 3 3) (sqrt 10000) (flet ((expt (x) (declare (fixnum x) ) (* x x x)) (sqrt (x) (declare (float x) ) (* .5 x)) ) (let () ;; ;; advise local functions sqrt & expt to be compiled in-line and ;; out-of-line respectively by the compiler ;; (declare (inline sqrt) (notinline expt)) (+ (expt 4) (sqrt 6)))) (- (expt 3 0) (sqrt 81)) )) '(27 100.0 67.0 -8.0) )) (do-test "test proclaim with ignore decl-spec 0" (= (progn ;; Specify that the bindings of the specified variables are never used. (proclaim '(ignore broken-var1 broken-var2)) (defun foo (x &optional broken-var1 broken-var2) (values x x)) (foo 234 567 890)) 234 )) (do-test "test proclaim with ignore decl-spec 1" (progn (proclaim '(ignore broken-var1 broken-var2)) (let ((x 100) (y 234) (broken-var1 "error1") (broken-var2 "error2")) (> y x) ))) (do-test "test proclaim with optimize & declaration decl-specs" (progn (proclaim '(optimize (speed 2) space (safety 3) (compilation-speed 0) )) (proclaim '(declaration funny1 funny2 funny3)) (defun foo (x) ;; the following declaration should be ingored (declare (funny1 fun1) (funny2 fun2) (funny3 fun3)) (do ((i 0 (+ i 1)) (z x (cdr z)) ) ((null z) i) )) (= (foo '(2 3 4 5 6)) 5) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/9/9-3-THE.TEST b/internal/test/LANGUAGE/from-sun/language/9/9-3-THE.TEST new file mode 100644 index 00000000..9f478c52 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/9/9-3-THE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ;; ;; Source: CLtL Section 9.3: Type declaration for forms Page: 161 ;; ;; Created By: Karin M. Sye ;; ;; Creation Date: Oct. 8,1986 ;; ;; Last Update: Oct. 8,1986 ;; ;; Filed As: {eris}cml>test>9-3-the.test ;; ;; ;; Syntax: the VALUE-TYPE FORM ;; ;; Function Description: The function is used to declare the type of the value of an unnamed form. It returns the ;; evaluated value of FORM. It is an error if what is produced by the form does not conform to ;; the data type specified by VALUE-TYPE. ;; ;; Argument(s): VALUE-TYPE - a lisp type specifier ;; FORM - ;; ;; Returns: any lisp object ;; (do-test "test the 0" (and (= (the integer 30) 30) (= (the float 23.9) 23.9) (= (the (integer 2 10) 2) 2) (= (the (mod 100) (1- 1)) 0) (= (the (mod 1000) (1+ 998)) 999) (= (the (unsigned-byte 3) 7) 7) (= (the (unsigned-byte 4) 13) 13) (= (the (float -99.2 99.2) -99.01) -99.01) (= (the complex #c(1 -2)) #c(1 -2)) (= (the (complex float) #c(1.1 -9.3)) #c(1.1 -9.3)) (= (the (complex integer) #c(2 10)) #c(2 10)) (= (the (complex ratio) #c(2/3 5/9)) #c(2/3 5/9)) (= (the rational 20) 20) (= (the (rational 2/13 2/5) 2/7) 2/7) ) ) (do-test "test the 1" (and (equal (the string "jkfldjskl") "jkfldjskl") (equal (the (string 20) (make-string 20 :initial-element #\a)) "aaaaaaaaaaaaaaaaaaaa") (equalp (the simple-vector (vector 1 0 1 0 0 0 1 1)) #*10100011) (equalp (the (bit-vector 10) #*0000011111) (vector 0 0 0 0 0 1 1 1 1 1)) (equalp (the array (make-array '(2 2) :initial-contents '((a b) (c d)) )) (make-array '(2 2) :initial-contents '((a b) (c d)) )) (equalp (the (vector * 5) (vector 1 2 3 4 5)) (vector 1 2 3 4 5)) ) ) (do-test "test the 2" (and (= (the (satisfies evenp) 10) 10) (char= (the (satisfies characterp) #\q) #\q) (= (the (member 2 4 6 8 10) 6) 6) (eq (the (member abc def ghi) 'def) 'def) (equal (the (not list) "abc") "abc") (eq (the (and symbol list) nil) nil) (eq (the (or t nil) (find #\a "bcd")) nil) ) ) (do-test "test the 3" (and (equal (multiple-value-list (the (values integer integer float) (values 2 3 1.2))) '(2 3 1.2)) (equal (multiple-value-list (the (values list string character) (values '(1 2) "12" #\1))) '((1 2) "12" #\1)) (equal (multiple-value-list (the (values bit ratio complex) (values 1 2/9 #C(1 1)))) '(1 2/9 #c(1 1))) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/DO-TEST.DFASL b/internal/test/LANGUAGE/from-sun/language/DO-TEST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a209fd14045fbceb1da1da2b49b92efc99b31dad GIT binary patch literal 12169 zcmb7KYj9M@mA?1RjGky1A%UflfH4LPV@5_IUh}XCqtO*Jn#Uc_13}^hE7IT*2ubK^ zVo(V`Vi%q)2*G&Tu`6-NmbbFrl#DA04`Zb^TdATp+1lEz+Ei-uE2(|_*i=zP9{XpP z{m$t-FG-Gp5_7vxcc1P)=k$4X&ndRUzL3i|a&mNVC^hC9nVcA%oNyf*8FP(~Opf)Z zT*m-+y{yLq@w3l_0`aKNi0S(Sk%S(LctiU`fzFsWc4U8-;YsN6MBBcO-8J!&f&F8t zzKPU;E0LZY8z1O9y~EYf?(&X~4Gy{5_w3%i!_~fXFaA27Zma3`#zS(p2O8AAcjunA zn)~l%wdN5;QC{S~T1Ba^SE*jDC=Nwab5}CWgP9UiIGvyP--eQMEgIf0ZZ;;rm8y`@g)LABsZ_lYHNYe(WQ3>BD#n0 zVtBVv3yfAHszi`%dy;WIM*Xn5 zu7tNU1h@rofUKR~xL&8`G8HdJCWnU3D(_{LN8~1Hd)VkAeIKE1<}&piOBO$lHbq!y z&1x;yT!|G$V@A}{fJ&{&EuRsNTT!p3opgadaiUkH*{ZG1&0BNxRn*~-Hx{7f#dDW3 ztK8nm5sw~=8L_xKH&?ooOPNMDiGjx#(!G&n)YEOm!g04~!Z5qpVuYiZO~Ps=ENpa{ z0CRY!H{tVpVtPCoN|?hNWLKtn)SDpjlQK)LU&_>hU3scwwe^Sf zm~q&Hy@!p6ha}qE0WCZ?ZvpKsU`sAzm2J$A`PBed1j11xmLL+CBw`WZ-4Vna3h^O` zGbB$&uGHiQ9E=&sD1&OjequZANcPbWMacAU5Xa9n4o#bmPJ!+OY1`;bi0>uaQ?S7iy2j^k@;tSRaWcBSa!%RadbM z14M^t7rTI~xi^sTL)1NzS;WJ_(#1}(16}HU$yiK}B;-jU=3xAj;)zlUg2)L>3A$g& zSV=;2%)G|1H;7Y)1Exm~1!6`d3_R#kMX#v%?Gl*e`doZpe|*BpvP70tO!1Gs=w;3^eOB zbVY3_R$(W;kT(!kt3|V_(w;74D&yd9z#9_HpEsW~mubn*$NVinPo?vU9-9ba7AMal zLc;lZ$XjxmwdKgoBe@dVmOR=PLhD?CMj)3-rB<+_3^AYUWmvUFoFyAeO|@vv<8LMW zEi2$BkU7EnrDQ4B6U$}-S=M8=%$Ao^V}s*opBWk)AMGC*OYQGJIkbNwH9o;Vp0U*U z#~Dq$h^KXFztU;U&2D&r&2G$P9$CIwR<$ebbR$u`a&q{@@W}MAIn72) zqg0#BC405Z*p`?po7k+7R9MROve>#*B@4HBLhK;b2BoqSYNZQ@X z;Q^1SennGO8$O_2_p3Mj+RgN>^d|w!+~90F8&Gcrv`@|jZXJR+-@P543%|ytcY5u# z>L8h0X?*2xk2CFb$|AL+6a;{ZPW&^!fIxdxh*nD_PQTsFCetIm1GgBh&=id=G--#- zs?D2Osk6z1y2)2d)SvnkDH$@U-b8f*W!rN}BcX@IsU9)aDfWF4AZsKU3Oz%GUcVmM zgMuYuB(~$k)yTtgNRM?IaeX5owd}=t;h!ARt^K4;r50vm(tPgA3{k~1FpwJ)I4!PC zGu}bfTpKW}1fu`Il0NDHCiTX!^6R5(P||u`&U&>jf}W3~37<8uRJN$;8%NhI8tYKK zJ8w7^8jN*6Rg}5(o5nf}Q86RtbwZ?O)94cJ-9#M=Yn0V@dN z;qfC93F$FUX8@4M!MIynB_Pqtn_8XuttMy6?K8dNL^2lfM1AagSHzFRp#l)-EbEal z+&uie#UasH>Y<9(h*Mm9!(n+y^|Ojj*>|B)D!fs|I$czKk8#aW@q*}~&$%Mxi&#@* zahpB_G}1%lF6Yr({ddw-A#XfEm7j?z`t0WBODHP;$q?nHgnU)>_{jx)Ue4d~7`kW~ zOtKEdBv%#0EAdqk9#DrD#Wa0h5U1$#6~?F;VjtB);wAb7#A*8M!eVT!q^Y)zJpKqN z+YnWoc@1wHDQ>#aKYW0xZo}Z^yb)H)7 zGN}OhCV-|g?A#h4N~m~1zgJ20s`f7 zvG`3czSECU)%qcC$U~;$%M83iX2k*z`)RJ`w#lxIz^e%gCaEwlO$9f-OJ%sWW~?9` zT`OTFV*=)a|8a7xrctrMD?S(zPD1h~0cpAKqazo-%iXwmRrZ;Z6A>EICeg@YhQcmU zr9YSP>}6hX%s$SU3v%tGvC3PinYd}U+Gr5MJoOw3>b=~zXvLQ@8)SX}Ay58Lvb2T* zV6rz9=S7__u8$eDSafp;*UemJQ)FZ~Z`*h|WF;{*|ITb7t4KXZXvb$oGcV!AlHI7! z=Q3@3C6^z3J8Ib6j`H8U9bW9m<%?B*v)n)ruiX21o*y3y=j<_{W_;i7<#lR+EjR4z zmKt_xnZewA3Zjycd;``T1W?{kMH?)-*qyDQ>Ydc_dw+Ez4fRL{bA$H7N_=jf>$@py zw)CxYeYXbdRcmlA`04>DR@irVXy?)n_0tGh1UsifU?|e0{~ctG-#^-jlGf{lIj%MA zCwlB?0zR1I2C@WAi$)WwFvn|Pj+;z#+=L-yj>+aYu03iv(8X|I3Vb80I4-1BGHCI9 zZ!0PI2>FI#?e<6ahZU`s_m@}PZ<+hOqDdlVEH$#-Vuu#qU88BQ+{ZuD2}E>&>=0)* zNaD8!^&>d+Rp!Z}G|?&~tzrpiISQKVh;)lmL4J$@wOu;St;|YM)8CS+^cm436q^v> z`{-0hZhJft0}cXx08kA@+8#{or#6CqhoE_Yhk|W_Uf`u)dRFXdL%W&TGGa$6aeVCF z*uf-4=%xCdyfWn~Z2{uprA!V1z6F3akMmW=nSF^rZx70k)U^M&2D7X(H_r(KN!wp& zgawCft#4#NUb<%bX14fN7HSCFo~*K+_ytyihu8g7CSfA>9qOZd)Q?$$?v516}Fsq_$AdOLNsF@i-%jR6B z=4A>%&!+qOPqgi8ugPTw_U%J*ba32-zdjfCi>#E3GEXiVzQfh!4Tl4XM{Bl?rzTFh z@;Sr3dzWUtpl7z%Y#SW*i~@Dviz(M8>PsQtrtLM@LHWd>$KI^EiS~azeFLcuI!reL zsMf0*eHI)1+VzG1QZ!9$6niaY#K=pjr3rhth7504J(J_NQlbAV2urb7-dm?Nc=8$o z5tu>@{Dq9dz>LCQK)RAE*GkKG34effEZiHrkJO>a{r znvDCY@`mg%%d=+(#B?88?d9>)R{>fbKN9XVLY{mgyO#&t)5UbBnBFHVUyvV<{7A>~ z_bxHLo&kSw0*w~vc8KX3lq$Prrc1h~f0D}mYBjCthh#9wz$-s64aPKEB03Z1$|BVI zo`eEdOb=7qkASb{GLJ`xQhnno*T4v!?6K59>e%3L$~EI9BiiR;%TCGpuk$=#l2&ed zf6?0g;pt-ek2~|TkpIyA=L}bwkYXt-8?N7}qC*OIy%~z;$5DdzfhC)S2U3JTDQ`t7 zEfL_nT$YLCGRY)iM2{8WEU4u&`&nJfdo7V{wOV^<$!;col4RQ;*-2*k2U1*3>6Veh zJ?i!j%h>PFi0RW@`r{aX?vX@`=`YEO^ug{$WnakdelBHqifIp~v75P7PM>(9kBMm) zxBp>1Nv;uda_vtfz+C#Da@nndnnaW z5I|FW7+5AE`EDdiCE_H}6osy|TZt$IoHu$j?dHNa&_96xe&B$iMOKV>ptiuQJe8ax#lCWXVaYXER@qbPEBG}MFp{FcTzYo!X3t#D>oSQ;6bLwH z11x|ftfrW?KfIVVuq@13IQ&%|=H|)MU6oJPP<%+2pLK~M|hz?ckBEv=W-%$qdUP>;kM*;Zd zpZ`w9JW8+NKjrf3HI3FpENN8yjoOK_ntjoKrwR!%O`Jjk>q4f*4MCzvp%9Lc-^ihZ z+hP$LELO4JVngV(!(u55oovjnpChz@JHeO66n2=wR2=16q{-;6k^&D@E2vjk=TPE; zs5pVSsW(SJ?8dxBV;2=!fB(#m|b$uZyZMb64NP zpDwmJs;`1;ofg9JL6$$)L8fc#4iQW!qbIAmdxVK2z2#DB;7Ev}DWHN=p9C)lL(PllLN`M!0GC4m;=<#`!mlxN z5{98UN&V)*j#(0dszqMY!hhuFyK(%0eK7#NVuNt6b<<5Zg(q>`V28bd2*OEZ+i=x! z%2Fv>(8b|SMtTF0E)QJ01TM9uLwVk2QB;tvl47W2OsBJgzl`DwG_{S-PFit{rkC$eH-$X z9;2J%q4;(qmucOHxGOd}Jd7I)_9~G%8XGwYM{}kFL1bnvwbPBpxNB^3*oC|fTDI)X zWi}KW`o>bOucZiq8G#PWY9RpYqTqN>#=53U-L@WTl;5Ha8Z$ zvIo_NL?WrsC$mymScM`XbvZR;xtBdLWTDfRI`ON4<99!99Mbx3ocPu8yWbzONWFSK zd4moyjtr6rp#RODYtPdGVwH+Ic6-QKuUUIg?#Fcznyma=!QBDn(?)u=Zm~=^F4vS+ zN3Vk>J3!|=4Yg?{kHp=LhfO$3xHX`BYqi^a>f&aNTI(*nEOO)QQbs5oighJALpZEN z{4@^iMoSfR>XSBWnNCGIO1>?jgHD*Y8d18g!21OncpSI0I8+HEs7IJ`-xE{An7~e% zkA!|Wfh?2m4W9t0A{_K4jPPL^r~FF@xK`o)6m)}p3Prb-bSx6;T$vQJ5T%{sgg?2vR1)choWdyXf$MJ3n z4{2oD?^)>+UwRxZRuT?tfDvU6@aOGz`5`B!vez3U)h-^xl@%q*xv4a>Y|W|-Q6eeJ zB@(2IFiCv0p@W=5eJ8&*&_{v$Qfq({Uy@v_P55<>ITvO^Ix(E=?#7Dq^V7zjt`$>x zqWl>5&2*d=61t6ybD`O0h>gLh&xMJ*I+)SSIr=~VP?Lt}OCW;EZu)J|Tf=N*i_PfD-2c1JV*oYK)NRJ#$_}!3nWR454Lwd-q z*_o{uG!8%2i-qfiYJ%hJ%QOF0K{wDd$BM4*NO$O9K`+$930s4UUKzu@X=xNKmbIc; zJX>#5EXAvaI?gWe`%IqnByJz1f{#P~N&3hkQ!mR)%USsu;&r@F4gC`0m!CFn;5*xY z!nPU;4nscY=-~w4KNP#Y&&6*~%g=gjMBZT55b{k7&z}_f zDL*RoQ$8pbvvhz$-f(A^m)EX}lsMB(?dsWQMB9_X!@Io5BYsTa45^ka+Y)0VlV2;< zF5d0(@=m6xxa(vtvwhi(Umu*lkx`d?Mhw+Qu3G-$@A=|1hjW=P$Vb&r#i(eB-XfZ3bD5{ix7!2oLI?0%TRzXB2iz+n1S)em%5PUz z>StC4hqLOI7#$RtHVtTEST>CMLSTREAMS>AR6247.TEST ;; Verify that WITH-OUTPUT-TO-STRING and WITH-INPUT-FROM-STRING can handle 16-bit characters. (do-test-group AR6427 :before (test-setq fatstring (il:mkstring (il:packc '(9865 9866 9988)))) (do-test AR6247 (with-input-from-string (s fatstring :index j)(read s)) (with-input-from-string (s fatstring :index k :start 1)(read s)) (mapcar #'(lambda (stringlen) (= 3 stringlen)) (list j k (LENGTH (WITH-OUTPUT-TO-STRING (STREAM (MAKE-ARRAY 10 :ELEMENT-TYPE 'STRING-CHAR :FILL-POINTER 0)) (PRINT FATSTRING STREAM) ) ) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR6273.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR6273.TEST new file mode 100644 index 00000000..882979f4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6273.TEST @@ -0,0 +1 @@ +;;; Test case for AR 6273 (do-test "SETF in MACROLET" (let ((x '(1 2 3))) (macrolet ((foo () '(second x))) (and (setf (foo) t) (equal x '(1 t 3)) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST new file mode 100644 index 00000000..758ab0ab --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 6781: etypecase produces incorrect error message (do-test "AR 6781" (not (search "the value of" (xcl:condition-case (progn (etypecase "foo" (symbol 1) (integer 2)) "the value of") (xcl:type-mismatch (c) (princ-to-string c))) :test 'char-equal)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST new file mode 100644 index 00000000..8130e774 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST @@ -0,0 +1 @@ +;; AR 7412 test ;; Filed as {ERIS}TEST>CMLEXEC>AR7412.TEST ;; Verify that the interlisp function DIR is defined (do-test AR7412 (eq (type-of (il:getd 'il:dir)) 'il:compiled-closure)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7475.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7475.TEST new file mode 100644 index 00000000..d7bc15f0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7475.TEST @@ -0,0 +1 @@ +;; AR7475.TEST ;; Filed as {ERIS}TEST>CML-IO>AR7475.TEST ;; By Peter Reidy ;; Read an expression with nested #+. The expression only has to be readable, not executable. (do-test-group AR7475 :before (test-setq string "#+(or symbolics ti lmi) (progn (foo) #+(or symbolics ti) (bar) (baz)) )" ) (do-test AR7475-test (or (read-from-string string) t) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7525.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7525.TEST new file mode 100644 index 00000000..008c6856 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7525.TEST @@ -0,0 +1 @@ +;; AR7525 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR7525.TEST ;; by Peter Reidy ;; Verify that CL:OPEN's :element-type argument determines a file's IL TYPE attribute for element-types string-char (type text) and unsigned-byte (type binary). (do-test-group AR7525 :before ;; Open (with variable element-type), write to the conn'd directory, test file-type and delete. Return the value of the file-type test. (test-defun writefun (eltype expected-type) (let ((dynasty (open 'collins :direction :io :element-type eltype :if-does-not-exist :create))) (write "Alexis is a bitch." :stream dynasty) (close dynasty) (prog1 (equal (il:getfileinfo 'collins 'type) expected-type) (delete-file 'collins) ) ) ) (do-test AR7525 (and (writefun 'string-char 'il:text) (writefun 'unsigned-byte 'il:binary) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7587-DOC.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7587-DOC.TEST new file mode 100644 index 00000000..e5d7b645 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7587-DOC.TEST @@ -0,0 +1 @@ +;; AR7587-DOC.TEST ;; Filed as {ERIS}TEST>CMLDOC>AR7587-DOC.TEST ;; By Peter Reidy ;; Verify that (macroexpand '(setf (documentation...) does not use gensyms or gentemps. (do-test-group AR7587 :before (test-defun gentrim (charpart symbol) "Extract the integer part of a gensym or gentemp." (parse-integer (string-trim charpart (symbol-name symbol))) ) (do-test AR7587-test ;; See that the integer parts of generated symbols advance exactly once before and after execution of the SETF - i.e. that the SETF itself did not advance the counter. (let ((beforesym (gentrim "#:G" (gensym)))(beforetemp (gentrim "T" (gentemp)))) (macroexpand '(setf (documentation 'foo 'function) "Alexis is a bitch.")) (and (= (1+ beforesym (gentrim "#:G" (gensym)))) (= (1+ beforetemp (gentrim "T" (gentemp)))) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7647.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7647.TEST new file mode 100644 index 00000000..13c23096 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7647.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7647: CASE macro loses on () clause - Lucid L211 (do-test "AR 7647" (let ((foo nil)) (case foo (() nil) ((nil) t))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST new file mode 100644 index 00000000..cce5c8f8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7742: ADVISE doesn't work on Common Lisp functions (do-test "AR 7742" (defun foo (a b) (list a b)) (il:advise 'foo 'il:before '(if (eql (first xcl:arglist) 10) (setf (first xcl:arglist) 12))) (equal (foo 10 4) '(12 4)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST new file mode 100644 index 00000000..da5f25ed --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST @@ -0,0 +1 @@ +;; AR 8135 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR8135.TEST ;; by Peter Reidy ;; This code is adapted from {ERIS}CML>TEST>21-STREAMS.TEST. AR8135-test is the full test file's make-concatenated-stream-test. (do-test-group AR8135-group :before (progn (test-defun input-test (astream &key keep-open dont-test-for-eof) (and (streamp astream) (input-stream-p astream) (or (subtypep (stream-element-type astream) 'integer) (subtypep (stream-element-type astream) 'character) ) (equal (read astream) 'hello) (or dont-test-for-eof (read astream nil t)) (or keep-open (close astream)) ) ) (test-setq test-string "hello") ) (do-test AR8135-test (let* ((original-stream (make-string-input-stream test-string)) (astream (make-concatenated-stream original-stream))) (input-test astream) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST new file mode 100644 index 00000000..0c92ea5e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST @@ -0,0 +1 @@ +;; AR 8136 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR8136.TEST ;; By Peter Reidy ;; Verify that a concatenated stream is readable even when the first ends with whitespace. (do-test-group AR8136 :before (test-setq stream1 (make-string-input-stream "(= 6 (+ 3 3) ") stream2 (make-string-input-stream ")") ) (do-test AR8136 (eval (read (make-concatenated-stream stream1 stream2))) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8190.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8190.TEST new file mode 100644 index 00000000..49e7e2a6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8190.TEST @@ -0,0 +1 @@ +;; AR 8190 test ;; Filed as {ERIS}TEST>CMLSTREAMS>AR8190.TEST ;; Verify that (expect-errors (file-not-found) (open xxx)) fails if the file isn't found. (do-test AR8190 (expect-errors (file-not-found) (open '23april871509)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8207.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8207.TEST new file mode 100644 index 00000000..b4a962a0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8207.TEST @@ -0,0 +1 @@ +;; AR8207.TEST ;; Filed as {ERIS}TEST>CML-IO>AR8207.TEST ;; By Peter Reidy ;; (LOADCOMP 'TEDITMENU) without error. (do-test-group AR8207 (do-test AR8207-test (il:loadcomp '{erinyes}library>teditmenu) t ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8297.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8297.TEST new file mode 100644 index 00000000..2acff213 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8297.TEST @@ -0,0 +1 @@ +;; AR8297.TEST ;; Filed as {ERIS}TEST>CML-IO>AR8297.TEST ;; By Peter Reidy ;; Verify no udf break for READ-LINE nil nil nil. (do-test-group AR8297 (do-test AR8297-test (read-line nil nil nil) t ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8301.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8301.TEST new file mode 100644 index 00000000..cc2a99c7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8301.TEST @@ -0,0 +1 @@ +;; AR8301.TEST ;; Filed as {ERIS}TEST>CML-IO>AR8301.TEST ;; By Peter Reidy ;; Verify no udf break for unread-char, peek-char. (do-test-group AR8301 (do-test AR8301-test (CL:UNREAD-CHAR #\Space) (CL:PEEK-CHAR NIL (make-string-input-stream "nothing")) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8319.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8319.TEST new file mode 100644 index 00000000..3fa36acb --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8319.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8319: FMEMB not on UNSAFE.TO.MODIFY.FNS (do-test "AR 8319" (member 'il:fmemb il:unsafe.to.modify.fns) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST new file mode 100644 index 00000000..075d4266 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8458: *TRACE-OUTPUT* is supposed to be a window by default (do-test "AR 8458" (typep *trace-output* 'il:window) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST new file mode 100644 index 00000000..320e97f4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8465: (SHIFTF (CAR L) 0) COMPLAINS: "Attempt to bind a non-symbol: 0" (do-test "AR 8465" (let ((il:*exec-make-undoable-p* t) (l (list 1 2 3))) (and (eql (shiftf (car l) 0) 1) (equal l '(0 2 3))) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST new file mode 100644 index 00000000..85990a2a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8466: Errors in SETF's call undefined function (do-test "AR 8466" (search "not a known location specifier for setf" (xcl:condition-case (progn (setf (frob) 8) "") (xcl:simple-error (c) (princ-to-string c))) :test 'char-equal) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST new file mode 100644 index 00000000..104bab21 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8470: VIRGINFN calls u.d.f. PACK-IN- (do-test "AR 8470" (not (member 'il:pack-in- (first (il:calls 'il:virginfn)))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST new file mode 100644 index 00000000..ae14d4b8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8491: Arg not a NUMBER error when format ~:R given RATIO (do-test "AR 8491" (labels ((find-il-lambda (form) (if (atom form) (eq form 'il:lambda) (or (find-il-lambda (car form)) (find-il-lambda (cdr form)))))) (not (find-il-lambda (macroexpand '(prog1 a b c))))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST new file mode 100644 index 00000000..86290397 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST @@ -0,0 +1 @@ +;; AR 8575 test ;; Filed as {ERIS}TEST>MATMULT>AR8575.TEST ;; By Peter Reidy ;; Verify that MATMULT-N33 will execute without error or crash. (do-test AR8575-test (il:matmult-n33 (il:make-homogeneous-n-by-3 4) (il:make-homogeneous-3-by-3)) (il:matmult-n33 (il:make-homogeneous-n-by-3 (random 100)) (il:make-homogeneous-3-by-3)) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST new file mode 100644 index 00000000..2b2e951f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "expt simple function" (equal (CL:EXPT -1.0 2) 1.0)) (do-test "expt complex number" (equal (CL:EXPT 0.0 (complex 1.0 -5.0)) 0.0)) (do-test "expt zero" (equal (CL:EXPT 0.0 0) 1.0)) (do-test "expt fraction raised to the zero" (eq (CL:EXPT (/ 1 2) 0) 1)) (do-test "expt negative raised to a fraction" (equal (CL:EXPT -8 (/ 1 4)) #C(1.1892071 1.1892071))) (do-test "expt very large number" (equal (CL:EXPT -1.539016e+9 2) 2.3685701e+18)) (do-test "sqrt with complex number" (equal (sqrt #C(0.0 0.0)) 0.0)) (do-test "asin with complex number" (equal (asin #C(1.0 0.0)) #C(1.5707964 0.0))) (do-test "phase with complex number" (equal (phase #C(1.0 0.0)) 0.0)) (do-test "acosh with complex number" (equal (acosh #C(-2.9732 -3.328)) #C(2.1905336 -2.2875323) )) (do-test "rational" (il:leq (rational -1e20) 0)) (do-test "decode-float and scale-float are inverses" (and (setq x 3.8246e-41) (multiple-value-setq (a b c) (decode-float x)) (equal x (scale-float a b)))) (do-test "Floor and bignums" (multiple-value-bind (f r) (floor -2165/60893 31072) (= -2165/60893 (+ r (* f 31072)))) ) (do-test "type expander for Complex" (and (not (typep #C(5 6) '(complex float))) (typep #C(5 6) '(complex integer))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST new file mode 100644 index 00000000..1f762e7f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: All of chapter 5 of the IRM ;; ;; Source: IRM, p 5.1 ;; ;; Chapter 5: Array ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Array.test ;; ;; (do-test "test array" (and (il:arrayp (il:array 5)) (il:arrayp (il:array 10 'il:floatp)) (il:arrayp (il:array 10 'il:floatp 3.141592)) (il:arrayp (il:array 10 'il:floatp 3.141592 0)) T )) (do-test "test elt" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (equal 3.141592 (il:elt tempx 3)) (equal 3.141592 (il:elt tempx 8)) (equal 'a-litatom (il:elt tempy 2)) (equal 'a-litatom (il:elt tempy 72)) ))) (do-test "test seta" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (equal 2.71828 (il:seta tempx 3 2.71828)) (equal 2.71828 (il:elt tempx 3)) (equal 'Janet (il:seta tempy 62 'Janet)) (equal 'Janet (il:elt tempy 62)) ))) (do-test "test arraytyp" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (equal 'il:floatp (il:arraytyp tempx)) (equal 'il:pointer (il:arraytyp tempy)) ))) (do-test "test arraysize" (let* ((tempx (il:array 10 'il:floatp 3.141592)) (tempy (il:array 100 nil 'a-litatom))) (and (eq 10 (il:arraysize tempx)) (eq 100 (il:arraysize tempy)) ))) (do-test "test arrayorig" (let* ((tempx (il:array 10 'il:floatp 3.141592 0)) (tempy (il:array 100 nil 'a-litatom 1))) (and (eq 0 (il:arrayorig tempx)) (eq 1 (il:arrayorig tempy)) ))) (do-test "test copyarray" (let* ((tempx (il:array 10 'il:floatp 3.141592 0)) (tempy (il:array 100 nil 'a-litatom 1))) (and (il:arrayp (il:copyarray tempx)) (il:arrayp (il:copyarray tempy)) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST new file mode 100644 index 00000000..61a074d6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ArrayP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>ArrayP.test ;; ;; (do-test "test simple cases" (let* ((temp-array1 (il:array 5)) (temp-array2 (il:array 10 'il:FLOATP 3.141592 0))) (and (equal temp-array1 (il:arrayp temp-array1)) (equal temp-array2 (il:arrayp temp-array2)) (eq nil (il:arrayp -5)) (eq nil (il:arrayp 1000000)) (eq nil (il:arrayp 'a-floatp)) (eq nil (il:arrayp 12.34)) ))) (do-test "Test lists of various things" (let* ((temp-array1 (il:array 10 'IL:POINTER NIL 1)) (temp-array2 (il:array 20 'IL:FIXP 2 0)) (temp-array3 (il:array 1 'IL:WORD))) (and (equal temp-array1 (il:arrayp temp-array1)) (equal temp-array2 (il:arrayp temp-array2)) (equal temp-array3 (il:arrayp temp-array3)) ))) (do-test "Test go on own function" (flet ((temp-small nil (il:array 10 'IL:POINTER NIL 1))) (test-defun temp-fun nil (il:array 1 'IL:BYTE)) (and (il:arrayp (temp-small)) (il:arrayp (temp-fun)) ))) (do-test "Try various types of Litatoms" (and (eq nil (il:arrayp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:arrayp 'A-couple-dashs)) (eq nil (il:arrayp 'Numbers-1234567890)) (eq nil (il:arrayp 'il:other-packags)) (eq nil (il:arrayp 'il:other-packagsNumbers-1234567890)) (eq nil (il:arrayp 'il:other-packagsA-couple-dashs)) (eq nil (il:arrayp T)) (eq nil (il:arrayp nil)) (eq nil (il:arrayp ())) (eq nil (il:arrayp '())) (eq nil (il:arrayp (list))) (eq nil (il:arrayp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:arrayp (tee))) (eq nil (il:arrayp (nill))) (eq nil (il:arrayp (temp-litatom))) (eq nil (il:arrayp (temp-string))) (eq nil (il:arrayp (temp-fun))) (eq nil (il:arrayp temp-litatom)) ))) (do-test "Stop on arrayps from system functions" (and (eq nil (il:arrayp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:arrayp (second '(#\. #\k)))) )) (do-test "Test other datatypes aren't lists" (and (eq nil (il:arrayp #\backspace)) ; character (eq nil (il:arrayp #\*)) ; character (eq nil (il:arrayp #\.)) ; character (eq nil (il:arrayp (make-hash-table))) ; hash table (eq nil (il:arrayp (car (list-all-packages)))) ; packages (eq nil (il:arrayp (pathname nil))) ; pathname (eq nil (il:arrayp *random-state*)) ; ramdom state (eq nil (il:arrayp #'cons)) ; compiled function (eq nil (il:arrayp (copy-readtable))) ; readtable (eq nil (il:arrayp #*1001)) ; simple-bit-vector (eq nil (il:arrayp "twine")) ; simple-string (eq nil (il:arrayp (make-synonym-stream nil))) ; stream (eq nil (il:arrayp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST new file mode 100644 index 00000000..4b56fd6f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST @@ -0,0 +1 @@ +;; AR 6466 test ;; Filed as {ERIS}TEST>LLARRAYELT>AR6466.TEST ;; By Peter Reidy ;; Verify that the value of (cl:make-hash-table) prints as # instead of #. (do-test AR6466 (let ((hashstring (write-to-string (make-hash-table)))) (and (search "#test>binding>stkscan.test ;; ;; (do-test "simple stuff for stkscan, check doesn't die " (let* ((sp (il:stknth 1))) (and (equal nil (il:stkscan 'should-not-find sp)) (equal nil (il:stkscan 'should-not-find sp 'please-ignore)) (il:relstk sp) T ))) (do-test "simple stuff for framescan, check doesn't die " (let* ((sp (il:stknth 1))) (and (equal nil (il:framescan 'should-not-find sp)) (il:relstk sp) T ))) (do-test "simple stuff for stkargname, check doesn't die " (let* ((sp (il:stknth 1))) (and (equal nil (il:stkargname 2 sp)) (il:relstk sp) T ))) (do-test "simple stuff for stknargs, check doesn't die " (let* ((sp (il:stknth 1))) (and (il:stknargs sp) (il:relstk sp) T ))) (do-test "simple stuff for variables, check doesn't die " (let* ((sp (il:stknth 1))) (and (il:variables sp) (il:relstk sp) T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST new file mode 100644 index 00000000..901085b9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST @@ -0,0 +1 @@ +;; ByteCompiler regression tests (do-test "AR 7120: Bytecompiler should rebind *print-level*, *print-length*" (progn (with-open-file (s "{Core}AR7120." :direction :output :if-exists :new-version) (format s "(DEFINE-FILE-INFO ~CREADTABLE \"OLD-INTERLISP-FILE\" ~:*~CPACKAGE \"INTERLISP\") (FILECREATED 1 2 3) (DECLARE: EVAL@COMPILE DONTCOPY (COND ((AND (NULL *PRINT-LEVEL*) (NULL *PRINT-LENGTH*)) (SETQ *FOO* (PLUS *FOO* 1))))) STOP " (int-char #o247))) (let ((*print-level* 3) (*print-length* 3) (il:*foo* 0)) (declare (special il:*foo*)) (and (progn (il:lispxunread '(il:f)) (il:tcompl "{Core}AR7120.")) (progn (il:lispxunread '(il:f)) (il:bcompl "{Core}AR7120.")) (progn (il:lispxunread '(il:f)) (il:recompile "{Core}AR7120.")) (progn (il:lispxunread '(il:f)) (il:brecompile "{Core}AR7120.")) (il:fake-compile-file "{Core}AR7120.") (eq il:*foo* 5))))) (do-test "AR 7261: ByteCompiler should not remove terminal NIL arguments" (progn (setf (symbol-function 'one) '(lambda () (two 1 2 3 nil nil))) (setf (symbol-function 'two) ; First trick compiler into '(il:lambda (x) x)) ; believing TWO is ARGTYPE 0. (progn (il:lispxunread '(il:st il:n)) (il:compile 'one)) (setf (symbol-function 'two) ; Now here's the real '(lambda (&rest args) args)) ; definition of TWO. (equal (one) '(1 2 3 nil nil)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST new file mode 100644 index 00000000..89f8d692 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for Character Printing (AR 7403) and IL:U-CASE/L-CASE (AR 7600) (do-test char-print-escaped ;; When *print-escape* is true, print chars as #\x. ;; This works ok already in Lyric Jan 21. (let ((*readtable* (il:find-readtable "LISP"))) (and (string= (prin1-to-string #\A) "#\\A") (string= (prin1-to-string #\a) "#\\a") (string-equal (prin1-to-string #\Space) "#\\Space"))) ) (do-test char-print-unescaped ;; When *print-escape* is false, print chars as themselves. ;; This fails in Lyric Jan 21. (let ((*readtable* (il:find-readtable "LISP"))) (and (string= (princ-to-string #\A) "A") (string= (princ-to-string #\a) "a") (string= (princ-to-string #\Space) " ") (eql (char (princ-to-string #\GREEK-A) 0) #\GREEK-A))) ) (do-test char-print-mkstring ;; Interlisp integration: passing character as string arg should act ;; like string of single character. ;; This fails in Lyric Jan 21. (let ((*readtable* (il:find-readtable "LISP"))) (and (string= (il:mkstring #\A) "A") (string= (il:mkstring #\a) "a") (string= (il:mkstring #\Space) " ") (= (il:nchars #\Space) 1) (string= (il:concat "Cat" #\s) "Cats"))) ) (do-test ucase-in-il ;; Assure that Interlisp fns really do intern in IL (and (eq (il:u-case :foo) 'il:foo) (eq (il:u-case :|foo|) 'il:foo) (eq (il:l-case :|foo|) 'il:|foo|) (eq (il:l-case :foo) 'il:|foo|) (eq (il:u-case 'car) 'car)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST b/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST new file mode 100644 index 00000000..c740a52c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST @@ -0,0 +1 @@ +(do-test "CHARSET accepts 255 OK" (let ((strm (IL:OPENSTREAM '{NODIRCORE} 'IL:BOTH))) (NOT (NULL (IL:NLSETQ (IL:CHARSET strm 255)))))) (DO-TEST "CHARSET 255 == CHARSET T" (let ((strm (IL:OPENSTREAM '{NODIRCORE} 'il:BOTH))) (il:for ch il:in '(255 255 0 0 1 2 0 3 3) il:do (il:bout strm ch)) (il:setfileptr strm 0) (il:charset strm 255) (equal (list 1 512 771) (list (il:readccode strm) (il:readccode strm) (il:readccode strm))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CL-INTERPRETER-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CL-INTERPRETER-REGRESSION.TEST new file mode 100644 index 00000000..46480d5b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CL-INTERPRETER-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the Common Lisp interpreter (do-test "AR 8189: (THE (VALUES ...) ...) errors in the interpreter." (the (values fixnum fixnum) (floor 5 2))) (do-test "AR 7511: All Common Lisp documented variables/constants should be proclaimed/made constant" (flet ((special? (var) (il:variable-globally-special-p var))) (and (every #'special? '(*applyhook* *break-on-warnings* *debug-io* *default-pathname-defaults* *error-output* *evalhook* *features* *load-verbose* *macroexpand-hook* *package* *print-array* *print-base* *print-case* *print-circle* *print-escape* *print-gensym* *print-length* *print-level* *print-pretty* *print-radix* *query-io* *random-state* *read-base* *read-default-float-format* *read-suppress* *readtable* *standard-input* *standard-output* *terminal-io* *trace-output* * ** *** + ++ +++ - / // /// )) (every #'constantp '(array-dimension-limit array-rank-limit array-total-size-limit boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor call-arguments-limit char-bits-limit char-code-limit char-control-bit char-font-limit char-hyper-bit char-meta-bit char-super-bit double-float-epsilon double-float-negative-epsilon internal-time-units-per-second lambda-list-keywords lambda-parameters-limit least-negative-double-float least-negative-long-float least-negative-short-float least-negative-single-float least-positive-double-float least-positive-long-float least-positive-short-float least-positive-single-float long-float-epsilon long-float-negative-epsilon most-negative-double-float most-negative-fixnum most-negative-long-float most-negative-short-float most-negative-single-float most-positive-double-float most-positive-fixnum most-positive-long-float most-positive-short-float most-positive-single-float multiple-values-limit nil pi short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon t))))) (do-test "AR 7472: DEFCONSTANT, DEFPARAMETER and company don't override each other" (and (defvar #1=#:foo) (il:variable-globally-special-p '#1#) (defconstant #1# 7) (constantp '#1#) (defparameter #1# 17) (il:variable-globally-special-p '#1#) (defglobalvar #1#) (il:variable-global-p '#1#) (defconstant #1# 7) (constantp '#1#) (defglobalparameter #1# 10) (il:variable-global-p '#1#))) (do-test "AR 7349: SETQ doesn't see lexical bindings" (= 17 (let ((foo 78)) (setq foo 17) foo))) (do-test "AR 7127: Bad interaction between MACROLET and FLET in interpreter" (= 17 (macrolet ((foo (x) `(bar ,x))) (flet ((bar (y) (+ 1 y))) (foo 16))))) (do-test "AR 7684: redefining macros as functions doesn't work" (and (defmacro #1=#:foo (x) `(cons ,x ,x)) (defun #1# (x) x) (null (macro-function '#1#)))) (do-test "AR 7405: test progv - if too few values are supplied, the remaining symbols are bound and then made to have no value" (and (progv '(a b c d) '(10 20) (and (equal (list a b) '(10 20)) (notany #'boundp '(c d)) ) ) (progv '(aa bb cc dd ee ff gg) '() (notany #'boundp '(aa bb cc dd ee ff gg)) ) ) ) (do-test "AR 7464: SELECTQ's optimizer should do constant-folding when selector is (SYSTEMTYPE)" (equal (macroexpand-1 '(il:selectq (il:systemtype) (il:interlisp-10 (garbage)) ((il:tenex il:tops-20) (il:more-garbage)) ((il:d il:maxc) (il:wonderfulness) (il:brilliance)) (il:darn))) '(progn (il:wonderfulness) (il:brilliance)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST new file mode 100644 index 00000000..7137c9c4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for open accepting cl:character as element-type. (do-test "open with character element-type" (close (open "{nodircore}" :direction :output :element-type 'character))) ;;; Regression test for open accepting cl:character as element-type. (do-test "charset applied to two-way and broadcast streams" (and (il:charset (make-two-way-stream (il:getstream t 'il:input) (il:getstream t 'il:output)) 0) (il:charset (make-broadcast-stream (il:getstream t 'il:output)) 0))) ;;; Regression test for AR 7525 to have openstream assign the file ;;; types of the file based upon the :element-type. (do-test "open assign filetype unsigned-byte" (setq foo (open "{core}foo" :direction :output :element-type 'unsigned-byte)) (eq (IL:getfileinfo foo 'type) 'il:binary) (close foo) (delete-file "{core}foo")) (do-test "open assign filetype signed-byte" (setq foo (open "{core}foo" :direction :output :element-type 'signed-byte)) (eq (IL:getfileinfo foo 'type) 'il:binary) (close foo) (delete-file "{core}foo")) (do-test "open assign filetype character" (setq foo (open "{core}foo" :direction :output :element-type 'character)) (eq (IL:getfileinfo foo 'type) 'il:text) (close foo) (delete-file "{core}foo")) (do-test "open assign filetype string-char" (setq foo (open "{core}foo" :direction :output :element-type 'string-char)) (eq (IL:getfileinfo foo 'type) 'il:text) (close foo) (delete-file "{core}foo")) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST new file mode 100644 index 00000000..beff200b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST @@ -0,0 +1 @@ +;; (do-test "adjust-array works on displaced arrays" (equalp (adjust-array (make-array '(1 2) :adjustable t :displaced-to (make-array '(2 2) :initial-contents '((2 3)(8 9))) :displaced-index-offset 2) '(2 2)) '#2a((8 9) (nil nil)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST new file mode 100644 index 00000000..0024fd3b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for CMLARRAY AR 8108 (do-test "array printing observes *print-length*" (let ((*print-length* 2) (*print-array* t)) (print #*111001110010011101)) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST new file mode 100644 index 00000000..7409802e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for CMLCHARACTER - 7801 ;;; bill said to use the short form ;; This test is slow, since it applies to all 2^16 characters. ;; Almost as good to replace (1+ char-code-limit) with something smaller, say #x2323 (do-test "name-char and char-name are inverses" (dotimes (i #x2323 t) (let ((char (code-char i))) (or (graphic-char-p char) (char= (name-char (char-name char)) char) (return nil)))) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST new file mode 100644 index 00000000..d934eabf --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST @@ -0,0 +1 @@ +;; FILE MANAGER - tests for Common Lisp FILE COMMANDS "FUNCTIONS", "VARIABLES", and "STRUCTURES". ;; Functions To Be Tested: MAKEFILE, IL:LOAD, CL:LOAD MARKASCHANGED, ;; UNMARKASCHANGED, ;; ADDTOFILE, GETDEF, PUTDEF, HASDEF, ;; COPYDEF, DELDEF ;; RENAME, BCOMPL, BRECOMPILE, COMPILE-FILE ;; Source: KOTO IRM, [NOTE: Can't find any LYRIC documentation on this] ;; ;; Created By: Jim Blum ;; ;; Creation Date: Jan 9, 1987 ;; ;; Last Update: Jan 21, 1987 ;; FEB 16, 1987 - MOVED Into {ERIS}TEST>FILEMANAGER>CMLFILEMANAGER.TEST ;; ;; Filed As: {ERIS}TEST>FILEMANAGER>CMLFILEMANAGER.TEST ;; ;; 3 new FILE MANGAGER TYPES have been added for COMMON LISP - ;; FUNCTIONS, VARIABLES, & STRUCTURES ;; The tests below test the FILE MANAGER to see if these are being handled correctly (do-test "load a test file and make sure it gets noticed" (do nil ((null (il:delfile '{DSK}testfile)))) ; delete any old local versions (do nil ((null (il:delfile '{DSK}testfile.lcom)))) (do nil ((null (il:delfile '{DSK}testfile.dfasl)))) (setq il:dfnflg nil) ; make sure DFNFLG is set to nil (il:smashfilecoms 'testfile) (il:deldef 'test-function 'il:functions) (il:deldef 'test-macro 'il:functions) (makunbound 'test-variable) (defstruct test-structure) ; redefine test-structure to dummy def (il:setproplist 'il:testfile nil) ; remove entire property list (IL:load '{eris}test>filemanager>testfile) (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-TEST")) (member 'il:testfile il:filelst) ) (do-test "define a new function and add to the COMS file" (and (eq 'test-function (defun test-function)) (member 'test-function il:changedfunctionslst) (eq 'il:testfile (il:addtofile 'test-function 'il:functions 'il:testfile)) ) ) (do-test "define a new macro and add to the COMS file" (and (eq 'test-macro (defmacro test-macro nil :test)) (member 'test-macro il:changedfunctionslst) (eq 'il:testfile (il:addtofile 'test-macro 'il:functions 'il:testfile) ) ) ) (do-test "Define a structure and make sure it gets noticed" (and (defstruct test-structure x y) (member 'test-structure il:changedstructureslst) (eq 'il:testfile (il:addtofile 'test-structure 'il:structures 'il:testfile) ) ) ) (do-test "Define and set a variable and add to the COMS file" (and (defvar test-variable (make-test-structure :x 1 :y 2)) (member 'test-variable il:changedvariableslst) (eq 'il:testfile (il:addtofile 'test-variable 'il:variables 'il:testfile) ) ) ) (do-test "MAKEFILE, DELDEF test" (and (il:makefile '{DSK}testfile) (il:deldef 'test-function 'il:functions) (il:deldef 'test-macro 'il:functions) (il:deldef 'test-structure 'il:structures) (null (il:hasdef 'test-function)) (null (il:hasdef 'test-macro)) (makunbound 'test-variable 'il:variables) (null (boundp 'test-variable)) ) ) (do-test "Reload test" (and (makunbound 'test-variable) (null (boundp 'test-variable)) (il:load '{DSK}testfile) (eql (test-structure-x test-variable) 1) (eql (test-structure-y test-variable) 2) (equal (il:getdef 'test-function 'il:functions) '(defun test-function)) (eq (test-macro) :test) ) ) (do-test "edit the function definition and see if marked as changed" (and (il:putdef 'test-function 'il:functions (append (il:getdef 'test-function 'il:functions) '((a b) (+ a b)))) (member 'test-function il:changedfunctionslst) (equal (il:getdef 'test-function 'il:functions) '(defun test-function (a b) (+ a b))) ) ; and ) (do-test "edit the macro definition and see if marked as changed" (and (il:putdef 'test-macro 'il:functions (subst ':new-test ':test (il:getdef 'test-macro 'il:functions) ) ) (member 'test-macro il:changedfunctionslst) ) ) (do-test "edit the structure and see if it gets marked as changed" (defstruct test-structure x y z) (member 'test-structure il:changedstructureslst) ) (do-test "edit the variable def and see if it gets marked as changed" (defvar test-variable (make-test-structure :x 3 :y 4 :z 5)) (member 'test-variable il:changedvariableslst) ) (do-test "makefile, load and execute the new version" (and (il:makefile '{DSK}testfile) (il:deldef 'test-function 'il:functions) (null (il:hasdef 'test-function)) (il:deldef 'test-macro 'il:functions) (null (il:hasdef 'test-macro)) (makunbound 'test-variable) (defstruct test-structure) ; redefine to dummy defstruct (equal (il:getdef 'test-structure 'il:structures) '(defstruct test-structure) ) (il:load '{DSK}testfile) (eql (test-function 3 2) 5) (equal (test-macro) :new-test) (eql (test-structure-z test-variable) 5) ) ) (do-test "rename the function, makefile, reload and execute" (setq il:defaultrenamemethod '(il:editcallers)) (il:rename 'test-function 'new-function 'il:functions '{DSK}testfile) (and (null (il:hasdef 'test-function)) (il:hasdef 'new-function) (eql (new-function 2 3) 5) ) ) (do-test "copydef" (and (il:copydef 'new-function 'newer-function 'il:functions) (il:hasdef 'newer-function) (member 'newer-function il:changedfunctionslst) ) ; and ) (do-test "test dfnflg set to PROP and ALLPROP" (flet ((dfnflg-check (functions-def cell-def) (declare (special il:dfnflg)) (and (equal (il:getdef 'new-function 'il:functions) functions-def ; make sure there is a new functions def ) (member 'new-function il:changedfunctionslst) ; test marked as changed (equal (symbol-function 'new-function) cell-def ; make sure it hasn't taken effect ) ) ; and )) (il:addtofile 'new-function 'il:functions 'il:testfile) (and (let ((il:dfnflg 'il:prop)) (declare (special il:dfnflg)) (defun new-function (a b) (- a b)); redefine the function (dfnflg-check '(defun new-function (a b) (- a b)) '(lambda (a b) (block new-function (+ a b)))) (il:makefile '{DSK}testfile) (true (setq il:dfnflg nil)) (defun new-function) ; redefine the function in both places (defstruct test-structure) ;redefine test-structure (il:load '{DSK}testfile) (dfnflg-check '(defun new-function (a b) (- a b)) '(lambda (a b) (block new-function (- a b)))) (defun new-function) ; redefine the function (il:load '{DSK}testfile 'il:prop) ; load with PROP (dfnflg-check '(defun new-function (a b) (- a b)) '(lambda nil (block new-function))) (equal (il:getdef 'test-structure 'il:structures) '(defstruct test-structure x y z) ) ) ; let (let ((il:dfnflg 'il:allprop)) ; now check dfnflg = ALLPROP (declare (special il:dfnflg)) (defun new-function (a b) (* a b)) ; redefine the function (dfnflg-check '(defun new-function (a b) (* a b)) '(lambda (a b) (block new-function (+ a b)))) (defstruct test-structure a b c) (il:makefile '{DSK}testfile) (true (setq il:dfnflg nil)) (defun new-function) ; redefine the function in both places (defstruct test-structure) (il:load '{DSK}testfile) (dfnflg-check '(defun new-function (a b) (* a b)) '(lambda (a b) (block new-function (* a b)))) (defun new-function) ; redefine the function (il:load '{DSK}testfile 'il:allprop) ; load with PROP (dfnflg-check '(defun new-function (a b) (* a b)) '(lambda nil (block new-function))) (equal (il:getdef 'test-structure 'il:structures) '(defstruct test-structure a b c) ) ) ; let ) ; and ) ; flet ) (do-test "test BCOMPL" (and (defun new-function) (defmacro test-macro) (defvar test-variable 1) (il:delfromfile 'test-structure 'il:structures 'il:testfile) ; get rid of structure as this will cause a problem later (il:defineq (test-fns (a b)(+ a b))) ; define a fns (il:addtofile 'test-fns 'il:fns 'il:testfile) (il:makefile '{DSK}testfile) (il:bcompl '{DSK}testfile nil nil 'il:ST) (true (il:smashfilecoms 'testfile)) (il:deldef 'test-fns 'il:fns) ; delete fns definition (il:deldef 'new-function 'il:functions) (il:deldef 'test-macro 'il:functions) (makunbound 'test-variable) (il:load '{DSK}testfile.lcom) ; reload file (eq (test-fns 3 4) 7) ; make sure fns got loaded (equal (il:getdef 'new-function 'il:functions) '(defun new-function) ) ; make sure functions and macros didn't compile (equal (il:getdef 'test-macro 'il:functions) '(defmacro test-macro) ) ) ) (do-test "test makefile, brecompile, & load in a different package environment" (il:defineq (test-fns (a b)(- a b))) ; redefine fns (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-USER")) (il:makefile '{DSK}testfile) (il:brecompile '{dsk}testfile) (il:smashfilecoms 'testfile) (il:deldef 'new-function 'il:functions) (il:deldef 'test-macro 'il:functions) (il:deldef 'test-fns 'il:fns) ; delete fns definition (makunbound 'test-variable) (and (il:load '{DSK}testfile.lcom) (eq (test-fns 4 3) 1) (equal (il:getdef 'new-function 'il:functions) '(defun new-function) ) (equal (il:getdef 'test-macro 'il:functions) '(defmacro test-macro) ) (eql test-variable 1) ) ) (do-test "test COMPILE-FILE new compiler" (and (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-TEST")) (il:putprop 'il:testfile 'il:filetype 'compile-file) (il:defineq (test-fns (a b)(* a b))) ; redefine the fns (defun new-function (a b)(* a b)) (defmacro test-macro nil :test) (defvar test-variable 1) (eq 'test-macro (defmacro test-macro nil :test)) (il:makefile '{DSK}testfile) (compile-file 'testfile) (true (il:smashfilecoms 'testfile)) (il:deldef 'new-function 'il:functions) (il:deldef 'test-macro 'il:functions) (il:deldef 'test-fns 'il:fns) ; delete fns definition (makunbound 'test-variable) (il:load '{DSK}testfile.dfasl) (eql (test-fns 4 3) 12) (eq (test-macro) :test) (eql (new-function 4 3) 12) (true (il:smashfilecoms 'testfile)) (il:deldef 'new-function 'il:functions) (il:deldef 'test-macro 'il:functions) (il:deldef 'test-fns 'il:fns) ; delete fns definition (makunbound 'test-variable) (cl:load '{DSK}testfile.dfasl) ; test CL LOAD (eql (test-fns 4 3) 12) (eq (test-macro) :test) (eql (new-function 4 3) 12) ) ) (do-test "test makefile, compile-file, & load in a different package environment" (and (il:defineq (test-fns (a b)(- a b))) ; redefine fns (defun new-function (a b)(- a b)) (defmacro test-macro nil :new-test) (defvar test-variable 2) (il:putprop 'il:testfile 'il:makefile-environment '(:readtable "XCL" :package "XCL-USER")) (il:makefile '{DSK}testfile) (compile-file '{DSK}testfile) (il:smashfilecoms 'testfile) (il:deldef 'new-function 'il:functions) (il:deldef 'test-macro 'il:functions) (il:deldef 'test-fns 'il:fns) ; delete fns definition (makunbound 'test-variable) (il:load '{DSK}testfile.dfasl) (eq (test-fns 4 3) 1) (eql (new-function 4 3) 1) (eql test-variable 2) (il:smashfilecoms 'testfile) (il:deldef 'new-function 'il:functions) (il:deldef 'test-macro 'il:functions) (il:deldef 'test-fns 'il:fns) ; delete fns definition (makunbound 'test-variable) (cl:load '{DSK}testfile.dfasl) (eq (test-fns 4 3) 1) (eql (new-function 4 3) 1) (eql test-variable 2) ) ) (do-test "delete test environment items" \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLFILESYS-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLFILESYS-REGRESSION.TEST new file mode 100644 index 00000000..b3f3cfb5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLFILESYS-REGRESSION.TEST @@ -0,0 +1 @@ +;;; test file-author and file-position ;;; Last edited: 8-February-1988 by was -- Don't use CORE device when writing temp files; use NODIRCORE. (do-test "file-author should return NIL when author is unknown" (let ((strm (open "{nodircore}foo" :direction :output))) (prog1 (not (file-author strm)) (close strm)))) (do-test "file-position should return a number when passed just a stream" (let ((strm (open "{nodircore}foo" :direction :output))) (prog1 (file-position strm) (close strm)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST new file mode 100644 index 00000000..acb230df --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST @@ -0,0 +1 @@ +;;; WILKIE 4/28/87 test for CMLFLOAT AR 8598 ;;; tested function (and....) passed ;;; (do-test "test for value of epsilon *" (and (not (= 1.0 (+ 1.0 single-float-epsilon))) (< single-float-epsilon (expt 2 -23)) (> single-float-epsilon (expt 2 -24))) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST new file mode 100644 index 00000000..6f74cee2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for returning the proper length from cl:parse-namestring (do-test "parse-namestring length" (multiple-value-bind (path len) (parse-namestring "{dsk}") (eq len (length "{dsk}")))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLPROGV-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLPROGV-REGRESSION.TEST new file mode 100644 index 00000000..a936b70b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLPROGV-REGRESSION.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: progv ;; Regression tests for CMLPROGV ;;This one is taken from 7-5-PROGV.TEST (do-test "AR 7405: test progv - if too few values are supplied, the remaining symbols are bound and then made to have no value" (and (progv '(a b c d) '(10 20) (and (equal (list a b) '(10 20)) (notany #'boundp '(c d)) ) ) (progv '(aa bb cc dd ee ff gg) '() (notany #'boundp '(aa bb cc dd ee ff gg)) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLRAND.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLRAND.TEST new file mode 100644 index 00000000..2f3737dc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLRAND.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for CMLRAND - 7511 (do-test "random state symbols are globally-special" (and (get '*random-state* 'il:globally-special) (get '*read-default-float-format* 'il:globally-special)) ) ;;; test for CMLRAND - 7263 (do-test "make-random-state's are equalp" (and (equalp (make-random-state) (make-random-state)) (not (equalp (make-random-state t) (make-random-state t)))) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST new file mode 100644 index 00000000..686b4cf2 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the file CMLREADTABLE (do-test "AR 7475: Nested #+ reading fails" (let ((eof-value "foo")) (and (eq eof-value (read-from-string "#+(or symbolics ti lmi) (progn (foo) #+(or symbolics ti) (bar) (baz))" nil eof-value)) (eq eof-value (read-from-string "#-(or symbolics xerox) (progn (foo) #-(or hp lmi ti) (bar) (baz))" nil eof-value)) (eq eof-value (read-from-string "#+(or symbolics ti lmi) (progn (foo) #-(or symbolics lmi) (bar) (baz))" nil eof-value)) (eq eof-value (read-from-string "#-(or symbolics xerox) (progn (foo) #+(or hp lmi ti) (bar) (baz))" nil eof-value))))) (do-test "AR 7802 - *READ-SUPPRESS* and undefined hash macro characters" (equal (read-from-string "(foo #+noway #Pnope bar #+noway \"junk\" baz)") '(foo bar baz))) (do-test "AR 7608 - #0\a loses" (and (char= #\a #0\a) (expect-errors (xcl:simple-error) (read-from-string "#1\\q")))) (do-test "AR 8160: printing forms containing backquoted vectors" (flet ((r-p-r () (read-from-string (prin1-to-string (read-from-string "`#(:a :b :c)"))))) (and (not (expect-errors xcl:unbound-variable (eval (r-p-r)))) (equalp (eval (r-p-r)) '#(:a :b :c))) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST new file mode 100644 index 00000000..84c77a94 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST @@ -0,0 +1 @@ +;; (do-test "delete-duplicates works with :from-end" (equal (delete-duplicates '(0 2 2 2) :start 2 :from-end t) '(0 2 2)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST new file mode 100644 index 00000000..0b2ea8dd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the SETF machinery (do-test "AR 7507: SETF macroexpands too early sometimes" (progn (with-open-file (s "{Core}AR7507.lisp" :direction :output) (princ ";; (defmacro foo (x) `(bar ,x)) (defsetf foo set-foo) (defun baz (y) (setf (foo y) 17)) " s)) (compile-file "{Core}AR7507.lisp"))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST new file mode 100644 index 00000000..8fc82fd7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the file CMLSPECIALFORMS (do-test "AR 7464: SELECTQ's optimizer should do constant-folding when selector is (SYSTEMTYPE)" (equal (macroexpand-1 '(il:selectq (il:systemtype) (il:interlisp-10 (garbage)) ((il:tenex il:tops-20) (il:more-garbage)) ((il:d il:maxc) (il:wonderfulness) (il:brilliance)) (il:darn))) '(progn (il:wonderfulness) (il:brilliance)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST new file mode 100644 index 00000000..d81461aa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST @@ -0,0 +1 @@ +;; (do-test "Subtypep on exclusive ranges" (and (multiple-value-bind (r c) (subtypep 'bit '(unsigned-byte 1)) (and (eq r t) (eq c t))) (multiple-value-bind (r c) (subtypep '(integer 0 2) '(integer (0) 2)) (and (eq r nil) (eq c t)))) ) (do-test "Typep with string-char" (eq (typep 1 'string-char) nil) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST b/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST new file mode 100644 index 00000000..8daa2b3b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for COMMON - 8168 (do-test "#n# reads properly" (consp (cdr #1='("This structure is circular" . #1#))) ) ;;; test for COMMON - 7610 (do-test "Guy Steele Jr. memorial test case" (setq foo '(bar baz)) (setq bar '(barola)) (setq baz '(bazola alozab)) (equal (eval ``(,@,@foo)) '(barola bazola alozab)) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST b/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST new file mode 100644 index 00000000..7aea76ee --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8409: MKATOM should return a single value (do-test "AR 8409" (eql (length (multiple-value-list (il:mkatom "abc"))) 1) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST new file mode 100644 index 00000000..cefdec5b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7875: Report-methods for ILLEGAL-GO and ILLEGAL-RETURN are misspelled. (do-test "AR 7875" (every #'(lambda (x) (not (search "non-existant" (princ-to-string (xcl:make-condition x)) :test 'char-equal))) '(xcl:illegal-go xcl:illegal-return xcl:illegal-throw)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST new file mode 100644 index 00000000..9b961639 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7893: Default handler for STREAM-NOT-OPEN uses TEdit function when TEdit not loaded (do-test "AR 7893" (or (get 'il:tedit 'il:filedates) (null (xcl:condition-handler 'xcl:stream-not-open))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST new file mode 100644 index 00000000..33970300 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7383: ENTER-DEBUGGER-P should say yes for STORAGE-CONDITIONs (do-test "AR 7383" (il:enter-debugger-p 0 nil (xcl:make-condition 'xcl:storage-condition)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST new file mode 100644 index 00000000..ff57da7d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8512: System errors get breakwindows the say "In \LISPERROR..." (do-test "AR 8512" (member 'il:\\lisperror il:*debugger-entry-points*) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST new file mode 100644 index 00000000..b6c0a883 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: XCL:def-define-type, XCL:defdefiner ;; ;; Source: {ERIS}CML>DOC>DEF-DEFINE-TYPE.TEDIT ;; {ERIS}cml>doc>defdefiner.tedit ;; ;; Created By: Jim Blum ;; ;; Creation Date: Jan 9, 1987 ;; ;; ;; Last Update: FEB 2/16/87 Moved into {ERIS}TEST>FILEMANAGER>DEFDEFINE.TEST ;; ;; ;; Filed As: {ERIS}TEST>FILEMANAGER>DEFDEFINE.TEST ;; ;; Function: defdefinetype ;; ;; Syntax: (defdefinetype name &optional description &key undefiner) ;; ;; Function Description: New kinds of file manager objects can be defined with defdefinetype. ;; ;; Aruments: NAME should be the name of the define type in plural, e.g., FUNCTIONS, VARIABLES, STRUCTURES. ;; DESCRIPTION is the documentation of this definition type, and should be a string suitable for the sentence ;; "The following have not been saved on any file: " ;; The only keyword currently defined is a global "undefiner" for this definition type. ;; Each individual defdefiner is allowed to define how to "undefine" a given name, ;; but def-define-type also has a shot at removing a definition for all instances of this type, if there is such. ;; Function: def-definer ;; ;; Syntax: (def-definer name-and-options type arg-list . body) ;; ;; Function Description: DefDefiner creates macro named name that creates definitions of type type. ;; DefDefiner arranges that: ;; -- the body will be evaluated if and only if IL:DFNFLG is not one of IL:PROP or IL:ALLPROP ;; -- the form returned by the body will be evaluated in a context in which the file manager has been disabled ;; (so that subordinate definitions like the accessor defun's of defstruct will not be noticed by the file-manager) ;; -- macro-calls to the new definer will return the name of the thing being defined ;; (as DEFUN, DEFMACRO, and others are defined to do) ;; ;; ;; Arguments: name-and-options is a defstruct-style name. That is, it is either a symbol, name, or ;; a list, ie, (name (option . value) ...). ;; type must be a file-manager type previously defined using def-define-type. ;; The following options are supported: ;; (:name name-fn) ;; name-fn should be a form acceptable as the argument to cl:function. When name-fn is ;; applied to any form representing a ;; macro-call on the new definer, it should return a Lisp value to be used as the name of the thing ;; being defined, for the purposes of ;; saving the definition with the file-manager and returning the name as the value of the ;; macro-call. name-fn should have no ;; side-effects nor should its workings depend upon any data outside of that provided as an ;; argument. The default value for name-fn is cl:second. ;; (:prototype-fn defn-fn) ;; defn-fn should be a form acceptable as the argument to cl:function. When defn-fn is applied to any Lisp value, it should ;; return either NIL or a form that, when evaluated, would create a dummy definition of type type named by that Lisp value. ;; This function can be used by SEdit to provide dummy definitions for names that have no other definition. ;; For example, the defn-fn for DEFUN might be ;; ;; (lambda (name) ;; (and (symbolp name) ;; `(defun ,name ("args") "body"))) ;; The default value for defn-fn is ;; (lambda (name) nil) ;; (:undefiner function) ;; a function which will clear any definition of the name given to it. This is an "incremental" undefiner, in that when DELDEF ;; is given the type, it calls all undefiners for all of the types. The undefiner function should be undoable, if at all possible. ;; ;; Returns: name of definer if successful or, error if not. ;; ;; ------------------------------------------------------------------------------ ;; Use DEF-DEFINE-TYPE to define a new file manager type. ;; Give it a recognisable description string and an undefiner. ;; The undefiner will take a name and remove a certain property ;; (call it PROPERTY-ONE) from that name. (do-test "define new file manager type" (and (def-define-type definer-tests "Definer Tests" :undefiner (lambda (name) (remprop name 'property-one))))) ;; Use DEFDEFINER to define a definer of the new type. ;; Use the :NAME option in some non-trivial way to make a new ;; name. The effect of the definer will be to put T onto the ;; properties PROPERTY-ONE and PROPERTY-TWO of the name. Use ;; the :UNDEFINER option to remove only PROPERTY-TWO from the ;; name. In conjunction with the undefiner on the type, this ;; will clear the whole effect of the definer. (do-test "define a new definer of the new type" (and (defdefiner (def-test-one (:name (lambda (whole) (intern (concatenate 'string "FOO--" (string (second whole)))))) (:undefiner (lambda (name) (remprop name 'property-two)))) definer-tests (proto-name value-one value-two) (let ((name (intern (concatenate 'string "FOO--" (string proto-name))))) `(progn (setf (get ',name 'property-one) ',value-one) (setf (get ',name 'property-two) ',value-two)))))) ;; Also use DEFDEFINER to definer another definer for the new ;; type using neither :NAME nor :UNDEFINER. The effect of this ;; definer would be to only give the name the property PROPERTY-ONE. (do-test "use DEFDEFINER to definer another definer for the newtype using neither :NAME nor :UNDEFINER" (and (defdefiner def-test-two definer-tests (name value-one) `(setf (get ',name 'property-one) ',value-one)))) ;; With DFNFLG bound to NIL, use both definers to make objects ;; of the new type. These definitions should take effect. Use ;; SEdit-style comments to test that they get properly stripped. (do-test "make objects of the new type which take effect" (and (let ((il:dfnflg nil)) (declare (special il:dfnflg)) (def-test-one (il:* il:|;| "An SEdit-style comment") one-1 (il:* il:|;;| "An SEdit-style comment") 1 (il:* il:|;;;| "An SEdit-style comment") 2) (def-test-two (il:* il:|;| "An SEdit-style comment") two-1 (il:* il:|;;| "An SEdit-style comment") (il:* il:|;;;| "An SEdit-style comment") 3)))) ;; With DFNFLG bound to PROP, again use both definers. Neither ;; of these should take effect. (do-test "make objects of the new type with DFNFLG = PROP which should not take effect" (and (let ((il:dfnflg 'il:prop)) (declare (special il:dfnflg)) (def-test-one (il:* il:|;| "An SEdit-style comment") one-2 (il:* il:|;;| "An SEdit-style comment") 1 (il:* il:|;;;| "An SEdit-style comment") 2) (def-test-two (il:* il:|;| "An SEdit-style comment") two-2 (il:* il:|;;| "An SEdit-style comment") (il:* il:|;;;| "An SEdit-style comment") 3)))) ;; With DFNFLG bound to ALLPROP, once again use both definers. ;; Neither of these should take effect either. (do-test "make objects of the new type with DFNFLG bound to ALLPROP which should not take effect" (and (let ((il:dfnflg 'il:allprop)) (declare (special il:dfnflg)) (def-test-one (il:* il:|;| "An SEdit-style comment") one-3 (il:* il:|;;| "An SEdit-style comment") 1 (il:* il:|;;;| "An SEdit-style comment") 2) (def-test-two (il:* il:|;| "An SEdit-style comment") two-3 (il:* il:|;;| "An SEdit-style comment") (il:* il:|;;;| "An SEdit-style comment") 3)))) ;; Check that the define-type, both definers, and all six uses ;; of the definers got marked as changed. (do-test "Check that the define-type, both definers, and all six uses of the definers got marked as changed" (and (flet ((is-changed (name type) (let ((changes-var (first (find type il:prettytypelst :key 'second)))) (member name (symbol-value changes-var))))) (and (is-changed 'definer-tests 'il:define-types) (is-changed 'def-test-one 'il:functions) (is-changed 'def-test-two 'il:functions) (is-changed 'foo--one-1 'definer-tests) (is-changed 'foo--one-2 'definer-tests) (is-changed 'foo--one-3 'definer-tests) (is-changed 'two-1 'definer-tests) (is-changed 'two-2 'definer-tests) (is-changed 'two-3 'definer-tests))))) ;; Check that the define-type got installed with the ;; right description name. (do-test "Check that the define-type got installed with the right description name" (equal "Definer Tests" (third (find 'definer-tests il:prettytypelst :key 'second)))) ;; Check that all six uses of the definers got putdef'd correctly. (do-test "Check that all six uses of the definers got putdef'd correctly" (and (equal (il:getdef 'foo--one-1 'definer-tests) '(def-test-one (il:* il:|;| "An SEdit-style comment") one-1 (il:* il:|;;| "An SEdit-style comment") 1 (il:* il:|;;;| "An SEdit-style comment") 2)) (equal (il:getdef 'two-1 'definer-tests) '(def-test-two (il:* il:|;| "An SEdit-style comment") two-1 (il:* il:|;;| "An SEdit-style comment") (il:* il:|;;;| "An SEdit-style comment") 3)) (equal (il:getdef 'foo--one-2 'definer-tests) '(def-test-one (il:* il:|;| "An SEdit-style comment") one-2 (il:* il:|;;| "An SEdit-style comment") 1 (il:* il:|;;;| "An SEdit-style comment") 2)) (equal (il:getdef 'two-2 'definer-tests) '(def-test-two (il:* il:|;| "An SEdit-style comment") two-2 (il:* il:|;;| "An SEdit-style comment") (il:* il:|;;;| "An SEdit-style comment") 3)) (equal (il:getdef 'foo--one-3 'definer-tests) '(def-test-one (il:* il:|;| "An SEdit-style comment") one-3 (il:* il:|;;| "An SEdit-style comment") 1 (il:* il:|;;;| "An SEdit-style comment") 2)) (equal (il:getdef 'two-3 'definer-tests) '(def-test-two (il:* il:|;| "An SEdit-style comment") two-3 (il:* il:|;;| "An SEdit-style comment") (il:* il:|;;;| "An SEdit-style comment") 3)))) ;; Check that only the first two uses took effect. (do-test "Check that only the first two uses took effect" (and (= 1 (get 'foo--one-1 'property-one)) (= 2 (get 'foo--one-1 'property-two)) (= 3 (get 'two-1 'property-one)) (null (get 'two-1 'property-two)) (null (get 'foo--one-2 'property-one)) (null (get 'foo--one-2 'property-two)) (null (get 'two-2 'property-one)) (null (get 'two-2 'property-two)) (null (get 'foo--one-3 'property-one)) (null (get 'foo--one-3 'property-two)) (null (get 'two-3 'property-one)) (null (get 'two-3 'property-two)))) ;; Use DELDEF on each of the first two uses and check that all of the appropriate REMPROP's ;; happened. Also check that those two uses are no longer marked as changed and that HASDEF returns NIL for both. (do-test "DELDEF test" (and (il:deldef 'foo--one-1 'definer-tests) (il:deldef 'two-1 'definer-tests) (null (get 'foo--one-1 'property-one)) ; (null (get 'foo--one-1 'property-two)) (null (get 'two-1 'property-one)) (null (get 'two-1 'property-two)) ; (null (il:hasdef 'foo--one-1 'definer-tests)) ; (null (il:hasdef 'two-1 'definer-tests)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-ADDITIONAL.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-ADDITIONAL.TEST new file mode 100644 index 00000000..c190bfc6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-ADDITIONAL.TEST @@ -0,0 +1 @@ + ;;; Additional tests for testing the structure facilities. ;;; Greg Nuyens (xcl-test:do-test-group "standard behavior" :before (progn (defstruct tname a b) (defstruct (s2 (:include tname)) c)) (xcl-test:do-test "constructor keywords" (and (setq in (make-tname :a 3 :b '~b~)) (eq (tname-a in) 3) (eq (tname-b in) '~b~))) (xcl-test:do-test "prebuilt predicates" (tname-p in)) (xcl-test:do-test "simple inheritance" (setq sub (make-s2)) (and (tname-p sub)(s2-p sub))) (xcl-test:do-test "#s form for constructors" (equalp '#s(tname a 3 b 2) (make-tname :a 3 :b 2))) (xcl-test:do-test "try named constructors" (and (defstruct (t6 (:constructor my-make-t6)) a) (t6-p (setq in (my-make-t6 :a 3))) (equal (t6-a in) 3))) (xcl-test:do-test "try the copier" (let ((in (make-tname :a 3 :b 2))) (equalp in (copy-tname in)))) (xcl-test:do-test "setfs?" (let ((in (make-tname))) (setf (tname-b in) 'this) (equal (tname-b in) 'this)))) ); end of use of tname (xcl-test:do-test "defstruct lexical inits" (let ((var1 '~init~)) (defstruct t7 (a var1) b) (equal var1 (t7-a (make-t7))) (setq var1 33) (equal 33 (t7-a (make-t7))) (setq var1 40) (equal 40 (t7-a (make-t7))) (equal 99 (t7-a (make-t7 :a 99))))) (xcl-test:do-test-group "t8 and t9 tests" :before (progn (defstruct t8 (a 0.0 :type short-float) (b 'this :type symbol)) (defstruct t9 a (b 'this :read-only t))) (xcl-test:do-test "slot types" (let ((in (make-t8))) (and (setf (t8-a in) 1.2) (setf (t8-b in) 'foo) (equal (t8-a in) 1.2) (equal (t8-b in) 'foo)))) (xcl-test:do-test "read-only slots" (let ((in (make-t9))) (and (setf (t9-a in) 1.2) (xcl-test:expect-errors xcl:condition (setf (t9-b in) 'foo)) ))) ) ; end "t8 and t9 tests" (xcl-test:do-test "lexical init forms" (and (let ((a 'this)) (defstruct that (a a)))) (eq 'this (that-a (make-that)))) (xcl-test:do-test "simple vector structure" (and (defstruct (vfoo :named (:type vector)) (bar 1.0) (loo 2.0) baz) (let ((vfoo (make-vfoo :baz 'Me!))) (and (eq (vfoo-baz vfoo) 'Me!) (vfoo-p vfoo))))) (xcl-test:do-test "included named vector type" (and (defstruct (vfoo2 :named (:type vector) (:include vfoo) (:initial-offset 2)) this) (let ((vfoo2 (make-vfoo2 :bar 'one :loo 'two :baz 'three :this 'four))) (and (vfoo-p vfoo2) (vfoo2-p vfoo2) (eq (vfoo2-this vfoo2) 'four) (eq (vfoo2-baz vfoo2) 'three))))) (xcl-test:do-test "simple list structure" (and (defstruct (lfoo :named (:type list)) (bar 1.0) (loo 2.0) baz) (let ((lfoo (make-lfoo :baz 'Me!))) (and (eq (lfoo-baz lfoo) 'Me!) (lfoo-p lfoo))))) (xcl-test:do-test "included named list type" (and (defstruct (lfoo2 :named (:type list) (:include lfoo) (:initial-offset 2)) this) (let ((lfoo2 (make-lfoo2 :bar 'one :loo 'two :baz 'three :this 'four))) (and (lfoo-p lfoo2) (lfoo2-p lfoo2) (eq (lfoo2-this lfoo2) 'four) (eq (lfoo2-baz lfoo2) 'three))))) (xcl-test:do-test "simple BOA" (and (defstruct (snake (:constructor snake-make (a b))) a b) (snake-p (snake-make 1 2)))) (xcl-test:do-test "not so simple BOA" (and (defstruct (snake2 (:constructor snake-make2 (a &optional b (c 'sea) &rest d &aux e (f 'eff)))) a (b '3) c d e f ) (snake2-p (snake-make2 1 2)))) (xcl-test:do-test "circle-printing" (let ((*print-circle* t)) (defstruct loopy a b) (let ((loopy (make-loopy :a '(this and that)))) (setf (loopy-b loopy) loopy) (eq "#1-#s(loopy a (this and that) b #1#)" (format nil "~S" loopy))))) (xcl-test:do-test "try the inline extension" (and (defstruct (bebop (:inline nil)) rhythm) (let ((what (make-bebop :rhythm 'you-bet!))) (and (eq 'you-bet! (bebop-rhythm what)) (eq 45 (setf (bebop-rhythm what) 45)) (eq 45 (bebop-rhythm what)))))) (xcl-test:do-test "try the inline extension some more" (and (defstruct (bobep (:inline :predicate)) rhythm) (let ((what (make-bobep :rhythm 'you-bet!))) (and (eq 'you-bet! (bobep-rhythm what)) (eq 45 (setf (bobep-rhythm what) 45)) (eq 45 (bobep-rhythm what)))))) (xcl-test:do-test "suppressing copier and predicate" (and (defstruct (goz (:predicate nil) (:copier nil)) a) (not (fboundp 'goz-p)) (not (fboundp 'copy-goz)))) il:stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST new file mode 100644 index 00000000..62702e69 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST @@ -0,0 +1 @@ +;DEFSTRUCT-RUN-TIME - 8185, 7587 ;Test Case: Observe that no gensyms appear on the lcom of a fake-compile-file'd file with a defstruct on it. Or repeatedly macroexpand (defstruct foo a b) and its subexpressions in Sedit. ; 7587 tested 18-Apr Lyric (do-test "AR 8185 - Defstruct uses svref on non-simple vectors" (defstruct (foo (:type (vector float))) bar baz) (let ((x (make-foo :bar 1.2 :baz 3.4))) (and (typep x '(vector float)) (= 1.2 (foo-bar x))(= 3.4 (foo-baz x))))) ;DEFSTRUCT - 8053, 8360 ; for 8053, 8360: in ARs. ; 8053 - tested 18-Apr Lyric (do-test "AR 8360 - Defstruct makes uncompilable constructor function with :named option" (defstruct (foo (:type list) :named) a b) (equal (make-foo) '(foo nil nil))) ; DEFSTRUCT - 7753 (do-test "AR 7753 - DEFSTRUCT's BOA-constructors don't use default values" (defstruct (foo (:constructor make-foo ())) (a 7)) (= 7 (foo-a (make-foo)))) ;STRUCTURE-PRINT - 7437, 7438 (do-test-group ("*print-circle* vs. *print-structure*" :before (defstruct graph nodes)) (do-test "AR 7437 - circle labels always go to *standard-output*" (let* ((foo (make-string-output-stream)) (*standard-output* foo) (*print-structure* t) (bar (make-graph))) (setf (graph-nodes bar) bar) (write bar :circle t) (string= (get-output-stream-string foo) "#1=#S(GRAPH NODES #1#)"))) (do-test "AR 7438 - circular structures sometimes get lost altogether" (let* ((a (make-graph)) (b (make-graph :nodes a)) (*print-structure* t)) (setf (graph-nodes a) b) (string= (write-to-string a :circle t) "#1=#S(GRAPH NODES #S(GRAPH NODES #1#))"))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DELETE-SIDE-EFFECT.TEST b/internal/test/LANGUAGE/from-sun/language/other/DELETE-SIDE-EFFECT.TEST new file mode 100644 index 00000000..18f897b6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DELETE-SIDE-EFFECT.TEST @@ -0,0 +1 @@ +;CMLSEQMODIFY - 7994 ; Test case: (let ((a "abcabc") (b (make-array 6 :element-type 'string-char :fill-pointer t))) (replace b a) (delete #\a a) (delete #\a b) (and (equal a "abcabc") (equal b "bcbc"))) (do-test "AR7994 - DELETE destroys the contents of simple-strings" (let ((foo "abcdef")) (and (typep foo 'simple-string) (string= (delete #\b foo) "acdef") (string= foo "abcdef")))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DESCRIBE.TEST b/internal/test/LANGUAGE/from-sun/language/other/DESCRIBE.TEST new file mode 100644 index 00000000..916427aa --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DESCRIBE.TEST @@ -0,0 +1 @@ +;;; woz 4/27/87 test for DESCRIBE - 8259 (do-test "random state symbols are globally-special" (DESCRIBE MOST-NEGATIVE-FIXNUM) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DOUBLE-OP-ARITH.TEST b/internal/test/LANGUAGE/from-sun/language/other/DOUBLE-OP-ARITH.TEST new file mode 100644 index 00000000..803ff8f9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DOUBLE-OP-ARITH.TEST @@ -0,0 +1,236 @@ +;; double operation arithmetic tests for edge conditions +;; March 29, 1988 by Masinter + +(do-test-group ("Two Arg arithmetic opcodes" + :before (test-defun and-eq-frob (frob test) + (and (eq frob 'frob) test))) +(do-test + "Arithmetic edge condition tests " + (macrolet + ((check (op) + `(or (null (setq val (pop arg))) + (and-eq-frob 'frob (eql (,op arg1 arg2) val)) + (warn "(~A ~S ~S) is ~S and not ~S" ',op arg1 arg2 (,op arg1 arg2) val)))) + (every + #'(lambda (arg) + (let ((arg1 (pop arg)) + (arg2 (pop arg)) + (val nil)) + (and (check +) + (check -) + (check *) + (check /) + (check il:iplus) + (check il:idifference) + (check il:itimes) + (check il:iquotient) + (check il:quotient) + (check logior) + (check logand) + (check logxor) + (check ash) + (check il:igreaterp) + (check >) + (check il:fgreaterp) + (check =) + (check eql)))) + (prog1 + '((0 0 0 0 0 nil 0 0 0 nil nil 0 0 0 0 nil nil nil t t) + (0 1 1 -1 0 0 1 -1 0 0 0 1 0 1 0 nil nil nil nil nil) + (0 -1 -1 1 0 0 -1 1 0 0 0 -1 0 -1 0 t t t nil nil) + (0 1.0 1.0 -1.0 0.0 0.0 1 -1 0 0 0.0 1 0 1 0 nil nil nil nil nil) + (0 65535 65535 -65535 0 0 65535 -65535 0 0 0 65535 0 65535 nil + nil nil nil nil nil) + (0 -65536 -65536 65536 0 0 -65536 65536 0 0 0 -65536 0 -65536 0 t + t t nil nil) + (0 65536 65536 -65536 0 0 65536 -65536 0 0 0 65536 0 65536 nil + nil nil nil nil nil) + (0 -65537 -65537 65537 0 0 -65537 65537 0 0 0 -65537 0 -65537 0 t + t t nil nil) + (0 2147483648 2147483648 -2147483648 0 0 2147483648 -2147483648 0 + 0 0 2147483648 0 2147483648 nil nil nil nil nil nil) + (1 0 1 1 0 nil 1 1 0 nil nil 1 0 1 1 t t t nil nil) + (1 1 2 0 1 1 2 0 1 1 1 1 1 0 2 nil nil nil t t) + (1 -1 0 2 -1 -1 0 2 -1 -1 -1 -1 1 -2 0 t t t nil nil) + (1 1.0 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t nil) + (1 65535 65536 -65534 65535 1/65535 65536 -65534 65535 0 0 65535 + 1 65534 nil nil nil nil nil nil) + (1 -65536 -65535 65537 -65536 -1/65536 -65535 65537 -65536 0 0 + -65535 0 -65535 1 t t t nil nil) + (1 65536 65537 -65535 65536 1/65536 65537 -65535 65536 0 0 65537 + 0 65537 nil nil nil nil nil nil) + (1 -65537 -65536 65538 -65537 -1/65537 -65536 65538 -65537 0 0 + -65537 1 -65538 0 t t t nil nil) + (1 2147483648 2147483649 -2147483647 2147483648 1/2147483648 + 2147483649 -2147483647 2147483648 0 0 2147483649 0 2147483649 + nil nil nil nil nil nil) + (-1 0 -1 -1 0 nil -1 -1 0 nil nil -1 0 -1 -1 nil nil nil nil nil) + (-1 1 0 -2 -1 -1 0 -2 -1 -1 -1 -1 1 -2 -2 nil nil nil nil nil) + (-1 -1 -2 0 1 1 -2 0 1 1 1 -1 -1 0 -1 nil nil nil t t) + (-1 1.0 0.0 -2.0 -1.0 -1.0 0 -2 -1 -1 -1.0 -1 1 -2 -2 nil nil nil + nil nil) + (-1 65535 65534 -65536 -65535 -1/65535 65534 -65536 -65535 0 0 -1 + 65535 -65536 nil nil nil nil nil nil) + (-1 -65536 -65537 65535 65536 1/65536 -65537 65535 65536 0 0 -1 + -65536 65535 -1 t t t nil nil) + (-1 65536 65535 -65537 -65536 -1/65536 65535 -65537 -65536 0 0 -1 + 65536 -65537 nil nil nil nil nil nil) + (-1 -65537 -65538 65536 65537 1/65537 -65538 65536 65537 0 0 -1 + -65537 65536 -1 t t t nil nil) + (-1 2147483648 2147483647 -2147483649 -2147483648 -1/2147483648 + 2147483647 -2147483649 -2147483648 0 0 -1 2147483648 + -2147483649 nil nil nil nil nil nil) + (1.0 0 1.0 1.0 0.0 nil 1 1 0 nil nil 1 0 1 1.0 t t t nil nil) + (1.0 1 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t nil) + (1.0 -1 0.0 2.0 -1.0 -1.0 0 2 -1 -1 -1.0 -1 1 -2 0 t t t nil nil) + (1.0 1.0 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t t) + (1.0 65535 65536.0 -65534.0 65535.0 1.5259022E-5 65536 -65534 + 65535 0 1.5259022E-5 65535 1 65534 nil nil nil nil nil nil) + (1.0 -65536 -65535.0 65537.0 -65536.0 -1.5258789E-5 -65535 65537 + -65536 0 -1.5258789E-5 -65535 0 -65535 0 t t t nil nil) + (1.0 65536 65537.0 -65535.0 65536.0 1.5258789E-5 65537 -65535 + 65536 0 1.5258789E-5 65537 0 65537 nil nil nil nil nil nil) + (1.0 -65537 -65536.0 65538.0 -65537.0 -1.5258556E-5 -65536 65538 + -65537 0 -1.5258556E-5 -65537 1 -65538 0 t t t nil nil) + (1.0 2147483648 2.1474836E+9 -2.1474836E+9 2.1474836E+9 + 4.656613E-10 2147483649 -2147483647 2147483648 0 + 4.656613E-10 2147483649 0 2147483649 nil nil nil nil nil nil + ) + (65535 0 65535 65535 0 nil 65535 65535 0 nil nil 65535 0 65535 + 65535 t t t nil nil) + (65535 1 65536 65534 65535 65535 65536 65534 65535 65535 65535 + 65535 1 65534 131070 t t t nil nil) + (65535 -1 65534 65536 -65535 -65535 65534 65536 -65535 -65535 + -65535 -1 65535 -65536 32767 t t t nil nil) + (65535 1.0 65536.0 65534.0 65535.0 65535.0 65536 65534 65535 + 65535 65535.0 65535 1 65534 131070 t t t nil nil) + (65535 65535 131070 0 4294836225 1 131070 0 4294836225 1 1 65535 + 65535 0 nil nil nil nil t t) + (65535 -65536 -1 131071 -4294901760 -65535/65536 -1 131071 + -4294901760 0 0 -1 0 -1 65535 t t t nil nil) + (65535 65536 131071 -1 4294901760 65535/65536 131071 -1 + 4294901760 0 0 131071 0 131071 nil nil nil nil nil nil) + (65535 -65537 -2 131072 -4294967295 -65535/65537 -2 131072 + -4294967295 0 0 -65537 65535 -131072 0 t t t nil nil) + (65535 2147483648 2147549183 -2147418113 140735340871680 + 65535/2147483648 2147549183 -2147418113 140735340871680 0 + 0 2147549183 0 2147549183 nil nil nil nil nil nil) + (-65536 0 -65536 -65536 0 nil -65536 -65536 0 nil nil -65536 0 + -65536 -65536 nil nil nil nil nil) + (-65536 1 -65535 -65537 -65536 -65536 -65535 -65537 -65536 -65536 + -65536 -65535 0 -65535 -131072 nil nil nil nil nil) + (-65536 -1 -65537 -65535 65536 65536 -65537 -65535 65536 65536 + 65536 -1 -65536 65535 -32768 nil nil nil nil nil) + (-65536 1.0 -65535.0 -65537.0 -65536.0 -65536.0 -65535 -65537 + -65536 -65536 -65536.0 -65535 0 -65535 -131072 nil nil nil + nil nil) + (-65536 65535 -1 -131071 -4294901760 -65536/65535 -1 -131071 + -4294901760 -1 -1 -1 0 -1 nil nil nil nil nil nil) + (-65536 -65536 -131072 0 4294967296 1 -131072 0 4294967296 1 1 + -65536 -65536 0 -1 nil nil nil t t) + (-65536 65536 0 -131072 -4294967296 -1 0 -131072 -4294967296 -1 + -1 -65536 65536 -131072 nil nil nil nil nil nil) + (-65536 -65537 -131073 1 4295032832 65536/65537 -131073 1 + 4295032832 0 0 -1 -131072 131071 -1 t t t nil nil) + (-65536 2147483648 2147418112 -2147549184 -140737488355328 + -1/32768 2147418112 -2147549184 -140737488355328 0 0 + -65536 2147483648 -2147549184 nil nil nil nil nil nil) + (65536 0 65536 65536 0 nil 65536 65536 0 nil nil 65536 0 65536 + 65536 t t t nil nil) + (65536 1 65537 65535 65536 65536 65537 65535 65536 65536 65536 + 65537 0 65537 131072 t t t nil nil) + (65536 -1 65535 65537 -65536 -65536 65535 65537 -65536 -65536 + -65536 -1 65536 -65537 32768 t t t nil nil) + (65536 1.0 65537.0 65535.0 65536.0 65536.0 65537 65535 65536 + 65536 65536.0 65537 0 65537 131072 t t t nil nil) + (65536 65535 131071 1 4294901760 65536/65535 131071 1 4294901760 + 1 1 131071 0 131071 nil t t t nil nil) + (65536 -65536 0 131072 -4294967296 -1 0 131072 -4294967296 -1 -1 + -65536 65536 -131072 0 t t t nil nil) + (65536 65536 131072 0 4294967296 1 131072 0 4294967296 1 1 65536 + 65536 0 nil nil nil nil t t) + (65536 -65537 -1 131073 -4295032832 -65536/65537 -1 131073 + -4295032832 0 0 -1 0 -1 0 t t t nil nil) + (65536 2147483648 2147549184 -2147418112 140737488355328 1/32768 + 2147549184 -2147418112 140737488355328 0 0 2147549184 0 + 2147549184 nil nil nil nil nil nil) + (-65537 0 -65537 -65537 0 nil -65537 -65537 0 nil nil -65537 0 + -65537 -65537 nil nil nil nil nil) + (-65537 1 -65536 -65538 -65537 -65537 -65536 -65538 -65537 -65537 + -65537 -65537 1 -65538 -131074 nil nil nil nil nil) + (-65537 -1 -65538 -65536 65537 65537 -65538 -65536 65537 65537 + 65537 -1 -65537 65536 -32769 nil nil nil nil nil) + (-65537 1.0 -65536.0 -65538.0 -65537.0 -65537.0 -65536 -65538 + -65537 -65537 -65537.0 -65537 1 -65538 -131074 nil nil nil + nil nil) + (-65537 65535 -2 -131072 -4294967295 -65537/65535 -2 -131072 + -4294967295 -1 -1 -65537 65535 -131072 nil nil nil nil nil + nil) + (-65537 -65536 -131073 -1 4295032832 65537/65536 -131073 -1 + 4295032832 1 1 -1 -131072 131071 -1 nil nil nil nil nil) + (-65537 65536 -1 -131073 -4295032832 -65537/65536 -1 -131073 + -4295032832 -1 -1 -1 0 -1 nil nil nil nil nil nil) + (-65537 -65537 -131074 0 4295098369 1 -131074 0 4295098369 1 1 + -65537 -65537 0 -1 nil nil nil t t) + (-65537 2147483648 2147418111 -2147549185 -140739635838976 + -65537/2147483648 2147418111 -2147549185 -140739635838976 + 0 0 -65537 2147483648 -2147549185 nil nil nil nil nil nil) + (2147483648 0 2147483648 2147483648 0 nil 2147483648 2147483648 0 + nil nil 2147483648 0 2147483648 2147483648 t t t nil nil) + (2147483648 1 2147483649 2147483647 2147483648 2147483648 + 2147483649 2147483647 2147483648 2147483648 2147483648 + 2147483649 0 2147483649 4294967296 t t t nil nil) + (2147483648 -1 2147483647 2147483649 -2147483648 -2147483648 + 2147483647 2147483649 -2147483648 -2147483648 -2147483648 + -1 2147483648 -2147483649 1073741824 t t t nil nil) + (2147483648 1.0 2.1474836E+9 2.1474836E+9 2.1474836E+9 + 2.1474836E+9 2147483649 2147483647 2147483648 2147483648 + 2.1474836E+9 2147483649 0 2147483649 4294967296 t t t nil + nil) + (2147483648 65535 2147549183 2147418113 140735340871680 + 2147483648/65535 2147549183 2147418113 140735340871680 + 32768 32768 2147549183 0 2147549183 nil t t t nil nil) + (2147483648 -65536 2147418112 2147549184 -140737488355328 -32768 + 2147418112 2147549184 -140737488355328 -32768 -32768 + -65536 2147483648 -2147549184 0 t t t nil nil) + (2147483648 65536 2147549184 2147418112 140737488355328 32768 + 2147549184 2147418112 140737488355328 32768 32768 + 2147549184 0 2147549184 nil t t t nil nil) + (2147483648 -65537 2147418111 2147549185 -140739635838976 + -2147483648/65537 2147418111 2147549185 -140739635838976 + -32767 -32767 -65537 2147483648 -2147549185 0 t t t nil + nil) + (2147483648 2147483648 4294967296 0 4611686018427387904 1 + 4294967296 0 4611686018427387904 1 1 2147483648 2147483648 + 0 nil nil nil nil t t)) + '(let + ((values '(0 1 -1 1.0 65535 -65536 65536 -65537 2147483648))) + (mapcan + #'(lambda (arg1) + (mapcar #'(lambda (arg2) + (list arg1 arg2 (+ arg1 arg2) + (- arg1 arg2) + (* arg1 arg2) + (unless (= arg2 0) + (/ arg1 arg2)) + (il:iplus arg1 arg2) + (il:idifference arg1 arg2) + (il:itimes arg1 arg2) + (unless (= arg2 0) + (il:iquotient arg1 arg2)) + (unless (= arg2 0) + (il:quotient arg1 arg2)) + (logior arg1 arg2) + (logand arg1 arg2) + (logxor arg1 arg2) + (unless (> arg2 64) + (ash arg1 arg2)) + (il:igreaterp arg1 arg2) + (> arg1 arg2) + (il:fgreaterp arg1 arg2) + (= arg1 arg2) + (eql arg1 arg2))) values)) + values)))))) +) +STOP +GACHA ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) <2ě3Czş \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST b/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST new file mode 100644 index 00000000..c0bfc70e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST @@ -0,0 +1 @@ +DOVEVMEMSIZEPATCH 8038 - interactive test: check the value of il:\\lastvmemfilepage after logging out and rebooting. This should be a reasonable number (withing a page or two of the number that the System tool gives). Do this several times. If the number is 32768, something is wrong. \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/ERROR-RUNTIME-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/ERROR-RUNTIME-REGRESSION.TEST new file mode 100644 index 00000000..66da6b6c --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/ERROR-RUNTIME-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression tests for ERROR-RUNTIME patches ;; Patch 1. (do-test "AR 7563: Default filter function for unnamed proceed cases" (not (expect-errors (error) (proceed-case (compute-proceed-cases) (nil nil :report "This one")) )) ) (do-test-group ("AR 7564" :before (progn (il:remprop 'foo 'il:%proceed-arg-collector) (defun foo () '(1 2 3)))) (do-test "AR 7564: INVOKE-PROCEED-CASE v. defined functions" (not (expect-errors (error) (proceed-case (progn (invoke-proceed-case (find-proceed-case 'foo)) nil) (foo () t)) )) ) ) ;; Patch 2. (do-test "ECASE report" (macrolet ((capture-error-message (form) `(condition-case ,form (error (c) (write-to-string c :case :downcase :escape nil))))) (and (equal (capture-error-message (ecase "foo" (x 1) (y 2))) "\"foo\" is neither x nor y.") (equal (capture-error-message (ecase (+ 1 2) (x 1) (y 2))) "The value of (+ 1 2), 3,is neither x nor y.") ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST new file mode 100644 index 00000000..d4a5498f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Incidental evaluator regression tests (do-test "simple lexical binding" (= 3 (let ((a 3)) a))) (do-test-group "simple special binding" :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (special a)) b)) (defun goo () (declare (special a )) a)) (do-test "special 1" (let ((a 3)) (declare (special a)) (eq (goo) 3))) (do-test "special reference in let value form" (let ((a 'outer)) (declare (special a )) (eq (goo2) 'outer)))) ;; now try with specvars for references. (do-test-group "using il:specvars in declare for bindings." :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (il:specvars a)) b)) (defun goo () (declare (il:specvars a )) a)) (do-test "special 1" (let ((a 3)) (declare (il:specvars a)) (eq (goo) 3))) (do-test "special reference in let value form" (let ((a 'outer)) (declare (il:specvars a )) (eq (goo2) 'outer)))) ;; from AR's (do-test "#' finding lexical functions AR 5995" (equal '(2) (flet ((bar (n) (1+ n))) (mapcar #'bar '(1))))) (do-test "THROW vs. closures AR 6092" (let ((this-one t)) (catch 'foo (let ((closure #'(lambda () (throw 'foo this-one)))) (funcall closure) (values nil) ) ) )) (do-test "Interpreted &ALLOW-OTHER-KEYS AR 6122" (eq ((lambda (&key key &allow-other-keys) 'ok)) 'ok) ) (do-test "Interpreter: invalid keywords ar 6123" (expect-errors (error) ((lambda (&key foo) 'foo) :bar 'bar)) ) (do-test "value of eval-when 6252" (equal 3 (eval-when(eval) 3))) (do-test "simple special in let* ar 6369" (eq t (let* (x) (declare (special x)) t))) (do-test "shadowing flets ar 6734" (eq 4 (flet ((foo () 3)) (flet ((foo () 4)) (foo))))) (do-test "interaction of FLET and MACROLET AR 7127" (= 17 (macrolet ((foo (x) `(bar ,x))) (flet ((bar (y) (+ 1 y))) (foo 16))))) (do-test "setq of lexical variable." (eq 4 (let ((foo 3)) (setq foo 4) foo))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/EVENP.TEST b/internal/test/LANGUAGE/from-sun/language/other/EVENP.TEST new file mode 100644 index 00000000..46401116 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/EVENP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: EVENP ;; ;; Source: Guy L Steele's CLTL ;; Section: 12.2 Predicates on Numbers ;; Page: 196 ;; ;; Created By: Kelly Roach ;; ;; Creation Date: July 12,1986 ;; ;; Last Update: July 12,1986 ;; ;; Filed As: {ERIS}CML>TEST>12-2-EVENP.TEST ;; ;; ;; Syntax: (EVENP NUMBER &OPTIONAL MODULUS) ;; ;; Function Description: ;; This predicate is true if the argument INTEGER is even (divisible ;; by two), and otherwise is false. It is an error if the argument is not ;; an integer. ;; ;; Argument(s): NUMBER - a number ;; MODULUS - an integer ;; ;; Returns: T or NIL ;; (do-test evenp-test (and (evenp 2) (evenp -4) (not (evenp 3)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST new file mode 100644 index 00000000..e22b4d0a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST @@ -0,0 +1 @@ +;;;; Regression tests for Lyric FASDUMP patches ;;; AR 8655: FASL dumps some integers incorrectly (do-test ("AR 8655: Dump integers s.t. (mod (integer-length x) 8) = 0" :before (let ((fasl::check-table-size nil)) (fasl:with-open-handle (fh "{core}test.dfasl") (princ "Test dumping large integers" (fasl:begin-text fh)) (fasl:begin-block fh) (fasl:dump-value fh (expt 2 31)))) :after (ignore-errors (il:delfile "{core}test.dfasl"))) (with-open-file (s "{core}test.dfasl") (let ((once nil) (ok nil)) (fasl:process-file s :item-fn #'(lambda (x) (if once (setf ok nil) (progn (setf once t ok (eql x (expt 2 31))))))) ok) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST new file mode 100644 index 00000000..ca0552c1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression tests for FASLOAD-PATCHES ;; Patch 2. (do-test-group ("Patch 2 tests" :before (progn (fasl:with-open-handle (h "{core}test.dfasl") (princ "This is a test." (fasl:begin-text h))) (with-open-file (s "{core}test.dfasl" :direction :output :if-exists :append) (write-byte 64 s))) :after (ignore-errors (il:delfile "{core}test.dfasl"))) (do-test "Observe end-of-data mark" (with-open-file (s "{core}test.dfasl" :direction :input) (null (expect-errors (error) (fasl:process-file s)))) ) (do-test "Don't print anything when loading :verbose nil" (and (equal (with-output-to-string (*standard-output*) (load "{core}test.dfasl" :verbose nil)) "") (equal (with-output-to-string (*standard-output*) (load "{core}test.dfasl" :verbose t)) "This is a test. ") ) ) ) (do-test-group "Compatible with old FASL versions" :before (with-open-file (s "{core}test.dfasl" :direction :output) (map nil #'(lambda (byte) (write-byte byte s)) (list fasl:signature 0 4 fasl::end-mark fasl::end-mark))) :after (ignore-errors (il:delfile "{core}test.dfasl")) (do-test "Read old FASL file" (null (expect-errors (error) (with-open-file (s "{core}test.dfasl" :direction :input) (fasl:process-file s)))) ) ) (DO-TEST-GROUP "Reader environment hackery" :BEFORE (FASL:WITH-OPEN-HANDLE (H "{core}test.dfasl") (PRINC "This file tests reader environment hacking." (FASL:BEGIN-TEXT H)) (FASL:BEGIN-BLOCK H) (FASL:DUMP-EVAL H '(LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (FASL:DUMP-EVAL H '(PROGN (SETQ *PRINT-BASE* 7) (SETQ *READ-BASE* 12) (SETQ *PACKAGE* (FIND-PACKAGE "FASL")) (SETQ *READTABLE* (IL:FIND-READTABLE "OLD-INTERLISP-T")) (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)))) :AFTER (IGNORE-ERRORS (IL:DELFILE "{core}test.dfasl")) (DO-TEST "Ensure reader environment not affected" (IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT* (LET ((OLD-VALUES (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (FORM-COUNT 0)) (BLOCK READER-ENVIRONMENT-TEST (WITH-OPEN-FILE (S "{core}test.dfasl" :DIRECTION :INPUT) (FASL:PROCESS-FILE S :TEXT-FN #'(LAMBDA (S) (UNLESS (EQUAL S "This file tests reader environment hacking.") (RETURN-FROM READER-ENVIRONMENT-TEST NIL))) :ITEM-FN #'(LAMBDA (X) (CASE (INCF FORM-COUNT) (1 (UNLESS (EVERY #'EQL X OLD-VALUES) (RETURN-FROM READER-ENVIRONMENT-TEST NIL))) (2 (UNLESS (AND (EVERY #'EQL OLD-VALUES (IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT* (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))) (EVERY #'EQL X (LIST (FIND-PACKAGE "FASL") (IL:FIND-READTABLE "OLD-INTERLISP-T") 12 7))) (RETURN-FROM READER-ENVIRONMENT-TEST NIL)))))) ) ) (EVERY #'EQL OLD-VALUES (LIST *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST new file mode 100644 index 00000000..89d58fe1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the File Manager (do-test "AR 7737: (HASDEF & 'FILES) shouldn't create new symbols" (let ((name (il:gensym))) (and (null (il:hasdef name 'il:files)) (null (find-symbol (il:concat name "COMS") "INTERLISP"))))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST b/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST new file mode 100644 index 00000000..b9f8d938 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FIXP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>FixP.test ;; ;; (do-test "test simple cases" (and (eq 5 (il:fixp 5)) (equal 100000 (il:fixp 100000)) (eq nil (il:fixp 10.13)) (eq nil (il:fixp 'a-fixp)) (eq nil (il:fixp "a string")) )) (do-test "Test fixed numbers" (and (eq 123 (il:fixp 123)) (eq -4567 (il:fixp -4567)) (equal 1237654 (il:fixp 1237654)) (equal -4567321 (il:fixp -4567321)) )) (do-test "Test go on own function" (flet ((temp-small nil 2) (temp-large nil 100000)) (test-defun temp-fun nil -325) (and (eq 2 (il:fixp (temp-small))) (equal 100000 (il:fixp (temp-large))) (equal -325 (il:fixp (temp-fun))) ))) (do-test "Test work against system functions" (and (eq 3 (il:fixp (third '(1 2 3 4 5)))) (equal 3300000 (il:fixp (car '(3300000 2.2 1.1)))) (equal -23123456 (il:fixp (second '(1 -23123456 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:fixp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:fixp 'A-couple-dashs)) (eq nil (il:fixp 'Numbers-1234567890)) (eq nil (il:fixp 'il:other-packags)) (eq nil (il:fixp 'il:other-packagsNumbers-1234567890)) (eq nil (il:fixp 'il:other-packagsA-couple-dashs)) (eq nil (il:fixp T)) (eq nil (il:fixp nil)) (eq nil (il:fixp ())) (eq nil (il:fixp '())) (eq nil (il:fixp (list))) (eq nil (il:fixp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:fixp (tee))) (eq nil (il:fixp (nill))) (eq nil (il:fixp (temp-litatom))) (eq nil (il:fixp (temp-string))) (eq nil (il:fixp (temp-fun))) (eq nil (il:fixp temp-litatom)) ))) (do-test "Stop on fixps from system functions" (and (eq nil (il:fixp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:fixp (second '(#\. #\k)))) )) (do-test "Test arrays aren't fixps" (and (eq nil (il:fixp (make-array '(2 2)))) (eq nil (il:fixp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:fixp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:fixp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:fixp (make-array 50 :initial-element 0))) (eq nil (il:fixp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't fixps" (and (eq nil (il:fixp #\backspace)) ; character (eq nil (il:fixp #\*)) ; character (eq nil (il:fixp #\.)) ; character (eq nil (il:fixp (make-hash-table))) ; hash table (eq nil (il:fixp (car (list-all-packages)))) ; packages (eq nil (il:fixp (pathname nil))) ; pathname (eq nil (il:fixp *random-state*)) ; ramdom state (eq nil (il:fixp #'cons)) ; compiled function (eq nil (il:fixp (copy-readtable))) ; readtable (eq nil (il:fixp #*1001)) ; simple-bit-vector (eq nil (il:fixp "twine")) ; simple-string (eq nil (il:fixp (make-synonym-stream nil))) ; stream (eq nil (il:fixp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST b/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST new file mode 100644 index 00000000..cf4d85b1 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: FLOATP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>FloarP.test ;; ;; (do-test "test simple cases" (and (equal 5.9 (il:floatp 5.9)) (equal -10.13 (il:floatp -10.13)) (eq nil (il:floatp -5)) (eq nil (il:floatp 1000000)) (eq nil (il:floatp 'a-floatp)) (eq nil (il:floatp "a string")) )) (do-test "Test floating numbers" (and (equal 123.0 (il:floatp 123.0)) (equal 45.67 (il:floatp 45.67)) (equal 37e5 (il:floatp 37e5)) (equal .001 (il:floatp .001)) )) (do-test "Test go on own function" (flet ((temp-small nil -1.2) (temp-large nil 100000.01) (temp-floating nil 12.2)) (test-defun temp-fun nil 32e5) (and (equal -1.2 (il:floatp (temp-small))) (equal 100000.01 (il:floatp (temp-large))) (equal 12.2 (il:floatp (temp-floating))) (equal 32e5 (il:floatp (temp-fun))) ))) (do-test "Test work against system functions" (and (equal 1.2 (il:floatp (third '(1 2 1.2 4 5)))) (equal -3.3 (il:floatp (car '(-3.3 2.2 1.1)))) (equal 10101012.3 (il:floatp (second '(1 10101012.3 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:floatp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:floatp 'A-couple-dashs)) (eq nil (il:floatp 'Numbers-1234567890)) (eq nil (il:floatp 'il:other-packags)) (eq nil (il:floatp 'il:other-packagsNumbers-1234567890)) (eq nil (il:floatp 'il:other-packagsA-couple-dashs)) (eq nil (il:floatp T)) (eq nil (il:floatp nil)) (eq nil (il:floatp ())) (eq nil (il:floatp '())) (eq nil (il:floatp (list))) (eq nil (il:floatp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:floatp (tee))) (eq nil (il:floatp (nill))) (eq nil (il:floatp (temp-litatom))) (eq nil (il:floatp (temp-string))) (eq nil (il:floatp (temp-fun))) (eq nil (il:floatp temp-litatom)) ))) (do-test "Stop on floatps from system functions" (and (eq nil (il:floatp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:floatp (second '(#\. #\k)))) )) (do-test "Test arrays aren't floatps" (and (eq nil (il:floatp (make-array '(2 2)))) (eq nil (il:floatp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:floatp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:floatp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:floatp (make-array 50 :initial-element 0))) (eq nil (il:floatp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't floatps" (and (eq nil (il:floatp #\backspace)) ; character (eq nil (il:floatp #\*)) ; character (eq nil (il:floatp #\.)) ; character (eq nil (il:floatp (make-hash-table))) ; hash table (eq nil (il:floatp (car (list-all-packages)))) ; packages (eq nil (il:floatp (pathname nil))) ; pathname (eq nil (il:floatp *random-state*)) ; ramdom state (eq nil (il:floatp #'cons)) ; compiled function (eq nil (il:floatp (copy-readtable))) ; readtable (eq nil (il:floatp #*1001)) ; simple-bit-vector (eq nil (il:floatp "twine")) ; simple-string (eq nil (il:floatp (make-synonym-stream nil))) ; stream (eq nil (il:floatp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST new file mode 100644 index 00000000..cb884870 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7912: Arg not a NUMBER error when format ~:R given RATIO (do-test "AR 7912" (expect-errors (il:format-error) (format nil "~:R" 1/2)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST new file mode 100644 index 00000000..4eaf64c0 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "format-T-regression" (string= (format nil "~2Tfoo") " foo")) (do-test "format-E-regression" (string= (FORMAT NIL "~13,6,2,7E" 3.14159) " 3141590.E-06")) (do-test "format-*-regression" (string= (FORMAT NIL "~D ~D ~@*~D" 4 5 6) "4 5 4")) (do-test "format-R-regression" (string= (format nil "~,20,'*R" 4) "****************four")) (do-test "format-:@-@:-regression" (string= (format nil "~:@R" 42)(format nil "~@:R" 42))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/FP-PRINT-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FP-PRINT-REGRESSION.TEST new file mode 100644 index 00000000..456af393 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/FP-PRINT-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for floating-point printing ;;; Basically checks accuracy of normal numbers ;;; and whether extreme numbers print at all ;;; (denormalized numbers can't have read-print consistency) (do-test "fp-accuracy" (and (string= (write-to-string 1.2345678) "1.2345678") (string= (write-to-string -1.2345678) "-1.2345678") (string= (write-to-string 6.02e23) "6.02E+23") (string= (write-to-string 654.32) "654.32") )) (do-test "fp-extremity" (and (ignore-errors (write-to-string il:max.float)) (ignore-errors (write-to-string il:min.float)) (ignore-errors (write-to-string 3e-40)) ; denormalized # (ignore-errors (write-to-string -5e-45)) )) ;;; AR 7427 test: IL:FLTSTR was losing when it had to round a number to zero ;;; decimal places. (do-test "fp-round-to-integer" (and (string= (format nil "~4,0F" 31.4159) " 31.") (string= (format nil "~4,0F" 31.6159) " 32.") )) ;;AR 7616 test: 1e7 was printing as 1.E+7 and should print as 1.0E+7 (do-test "fp-print-at-least-one-decimal-place" (string= (write-to-string (read-from-string "1e7")) "1.0E+7")) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/HARRAYP.TEST b/internal/test/LANGUAGE/from-sun/language/other/HARRAYP.TEST new file mode 100644 index 00000000..35084e83 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/HARRAYP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: HArrayP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>HArrayP.test ;; ;; (do-test "test simple cases" (let* ((temp-harray1 (il:hasharray 5)) (temp-harray2 (il:hasharray 3 1.7))) (and (equal temp-harray1 (il:harrayp temp-harray1)) (equal temp-harray2 (il:harrayp temp-harray2)) (eq nil (il:harrayp -5)) (eq nil (il:harrayp 1000000)) (eq nil (il:harrayp 'a-floatp)) (eq nil (il:harrayp 12.34)) ))) (do-test "Test various combinations" (let* ((temp-harray1 (il:hasharray 3 5)) (temp-harray2 (il:hasharray 10 2.5)) (temp-harray3 (il:hasharray 4 nil))) (and (equal temp-harray1 (il:harrayp temp-harray1)) (equal temp-harray2 (il:harrayp temp-harray2)) (equal temp-harray3 (il:harrayp temp-harray3)) ))) (do-test "Test go on own function" (flet ((temp-small nil (il:hasharray 3))) (test-defun temp-fun nil (make-hash-table)) (and (il:harrayp (temp-small)) (il:harrayp (temp-fun)) ))) (do-test "Try various types of Litatoms" (and (eq nil (il:harrayp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:harrayp 'A-couple-dashs)) (eq nil (il:harrayp 'Numbers-1234567890)) (eq nil (il:harrayp 'il:other-packags)) (eq nil (il:harrayp 'il:other-packagsNumbers-1234567890)) (eq nil (il:harrayp 'il:other-packagsA-couple-dashs)) (eq nil (il:harrayp T)) (eq nil (il:harrayp nil)) (eq nil (il:harrayp ())) (eq nil (il:harrayp '())) (eq nil (il:harrayp (list))) (eq nil (il:harrayp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:harrayp (tee))) (eq nil (il:harrayp (nill))) (eq nil (il:harrayp (temp-litatom))) (eq nil (il:harrayp (temp-string))) (eq nil (il:harrayp (temp-fun))) (eq nil (il:harrayp temp-litatom)) ))) (do-test "Stop on harrayps from system functions" (and (eq nil (il:harrayp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:harrayp (second '(#\. #\k)))) )) (do-test "Test other datatypes aren't lists" (and (eq nil (il:harrayp #\backspace)) ; character (eq nil (il:harrayp #\*)) ; character (eq nil (il:harrayp #\.)) ; character (eq nil (il:harrayp (car (list-all-packages)))) ; packages (eq nil (il:harrayp (pathname nil))) ; pathname (eq nil (il:harrayp *random-state*)) ; ramdom state (eq nil (il:harrayp #'cons)) ; compiled function (eq nil (il:harrayp (copy-readtable))) ; readtable (eq nil (il:harrayp #*1001)) ; simple-bit-vector (eq nil (il:harrayp "twine")) ; simple-string (eq nil (il:harrayp (make-synonym-stream nil))) ; stream (eq nil (il:harrayp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST b/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST new file mode 100644 index 00000000..fab2f6ea --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST @@ -0,0 +1 @@ +;; AR7587-HASH.TEST ;; Filed as {ERIS}TEST>CMLDOC>AR7587-HASH.TEST ;; By Peter Reidy ;; Verify that (macroexpand '(setf (gethash...) does not use gensyms or gentemps. (do-test-group AR7587 :before (test-defun gentrim (charpart symbol) "Extract the integer part of a gensym or gentemp." (parse-integer (string-trim charpart (symbol-name symbol))) ) (do-test AR7587-test ;; See that the integer parts of generated symbols advance exactly once before and after execution of the SETF - i.e. that the SETF itself did not advance the counter. (let ((beforesym (gentrim "#:G" (gensym)))(beforetemp (gentrim "T" (gentemp)))) (macroexpand '(setf (gethash il:*definition-hash-table* x) y)) (and (= (1+ beforesym (gentrim "#:G" (gensym)))) (= (1+ beforetemp (gentrim "T" (gentemp)))) ) ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/HASHARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/other/HASHARRAY.TEST new file mode 100644 index 00000000..f06716e7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/HASHARRAY.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: All of chapter 6 of the IRM ;; ;; Source: IRM, p 6.1 ;; ;; Chapter 6: HashArray ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>HashArray.test ;; ;; (do-test "test hasharray" (and (il:harrayp (il:hasharray 5)) (il:harrayp (il:hasharray 3 1.7)) T )) (do-test "test harray" (and (il:harrayp (il:harray 5)) (il:harrayp (il:harray 10)) T )) (do-test "test harrayprop" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (equal 0 (il:harrayprop tempx 'il:numkeys)) (equal 0 (il:harrayprop tempy 'il:numkeys)) (equal nil (il:harrayprop tempx 'il:overflow)) (equal 1.7 (il:harrayprop tempy 'il:overflow)) (equal 1.7 (il:harrayprop tempy 'il:overflow 1.8)) (equal 1.8 (il:harrayprop tempy 'il:overflow)) ))) (do-test "test harraysize" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (<= 10 (il:harraysize tempx)) (<= 20 (il:harraysize tempy)) ))) (do-test "test clrhash" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (il:puthash 'key "The value" tempy) (il:harrayp (il:clrhash tempx)) (il:harrayp (il:clrhash tempy)) T ))) (do-test "test puthash & gethash" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (equal 3.141592 (il:puthash 'pi 3.141592 tempx)) (equal 3.141592 (il:gethash 'pi tempx)) (equal 1 (il:harrayprop tempx 'il:numkeys)) (equal 2.71828 (il:puthash 'e 2.71828 tempx)) (equal 2.71828 (il:gethash 'e tempx)) (equal 2 (il:harrayprop tempx 'il:numkeys)) (equal "A simple string" (il:puthash 'string "A simple string" tempy)) (equal "A simple string" (il:gethash 'string tempy)) (equal nil (il:gethash 'should-not-find tempx)) ))) (do-test "test rehash" (let* ((tempx (il:hasharray 10)) (tempy (il:hasharray 20 1.7))) (and (equal 3.141592 (il:puthash 'pi 3.141592 tempx)) (il:harrayp (il:rehash tempx tempy)) (equal 3.141592 (il:gethash 'pi tempy)) (equal 1 (il:harrayprop tempy 'il:numkeys)) ))) (do-test "test maphash" (let* ((tempx (il:hasharray 10)) (tempy '(start))) (and (equal 3.141592 (il:puthash 'pi 3.141592 tempx)) (il:harrayp (il:maphash tempx (function (lambda (val key) (push (list val key) tempy))))) (equal '(3.141592 PI) (first tempy)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ARGUMENT-FUNCTIONS.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ARGUMENT-FUNCTIONS.TEST new file mode 100644 index 00000000..89e347b7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ARGUMENT-FUNCTIONS.TEST @@ -0,0 +1 @@ +;; A Bogus test written by Larry to try to figure out whether or not ;; DEFUN was interacting in the ``proper'' way with the Interlisp ;; argument-list functions. Something like this needs to be decided ;; and then tested. (DO-TEST INTERLISP-ARGUMENT-TEST ; (PROGN ; (DEFUN ARGTEST (FN ARGLIST NARGS ARGTYPE FNTYP) ; (ARGTEST1 FN ARGLIST NARGS ARGTYPE FNTYP) ; (ARGTEST1 (SYMBOL-FUNCTION FN) ARGLIST NARGS ARGTYPE FNTYP)) ; ; (DEFUN ARGTEST1 (DEF ARGLIST NARGS ARGTYPE FNTYP) ; (AND (COND ((EQ ARGLIST T) (SYMBOLP (IL:ARGLIST DEF))) ; (T (EQUAL (IL:ARGLIST DEF) ARGLIST))) ; (EQUAL (IL:NARGS DEF) NARGS) ; (EQUAL (IL:ARGTYPE DEF) ARGTYPE) ; (EQUAL (IL:FNTYP DEF) FNTYP))) ; ; (AND (PROGN (DEFUN TESTEXPR (X) (HELP)) ; (ARGTEST 'TESTEXPR '(X) 1 0 'EXPR)) ; ; (PROGN (DEFUN TESTEXPR (X &OPTIONAL (ARG 3)) (HELP)) ; (ARGTEST 'TESTEXPR T 1 2 'IL:EXPR*)) ; ; (PROGN (DEFUN TESTEXPR (X &KEY (ARG 3)) (HELP)) ; (ARGTEST 'TESTEXPR T 1 2 'IL:EXPR*)) ; ) ; ) T ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-AR7398.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-AR7398.TEST new file mode 100644 index 00000000..f0c19e33 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-AR7398.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7398: COMPILED-FUNCTION-P should always be NIL on symbols (do-test "AR 7398" (funcall (compile nil '(lambda () (block foo (do-all-symbols (s t) (when (compiled-function-p s) (return-from foo nil)) ) ) ) )) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-ATOM.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-ATOM.TEST new file mode 100644 index 00000000..5b2741b3 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-ATOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: ATOM ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Atom.test ;; ;; (do-test "test simple cases" (and (eq t (il:atom 'a-atom)) (eq t (il:atom 5)) (eq nil (il:atom "a string")) )) (do-test "Try various types of litatoms" (and (eq t (il:atom 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq t (il:atom 'A-couple-dashs)) (eq t (il:atom 'Numbers-1234567890)) (eq t (il:atom 'il:other-packags)) (eq t (il:atom 'il:other-packagsNumbers-1234567890)) (eq t (il:atom 'il:other-packagsA-couple-dashs)) (eq t (il:atom T)) (eq t (il:atom nil)) (eq t (il:atom ())) (eq t (il:atom '())) (eq t (il:atom (list))) (eq t (il:atom (eq 1 2))) )) (do-test "Test numbers are atoms" (and (eq t (il:atom 123)) (eq t (il:atom 45.67)) (eq t (il:atom 8/9)) (eq t (il:atom #c( 6/7 3.00))) (eq t (il:atom most-positive-fixnum)) (eq t (il:atom 37e5)) (eq t (il:atom .001)) (eq t (il:atom #c( 6/7 3.00))) )) (do-test "Test able to take atoms from own function" (flet ((tee nil t) (nill nil nil) (temp-atom nil 'atom) (temp-number nil 12.2)) (test-defun temp-fun nil 'atom) (test-setq temp-atom 'il:temp-pointed) (and (eq t (il:atom (tee))) (eq t (il:atom (nill))) (eq t (il:atom (temp-atom))) (eq t (il:atom (temp-fun))) (eq t (il:atom temp-atom)) (eq t (il:atom (temp-number))) ))) (do-test "Test able to take atoms from system function" (and (eq t (il:atom (car '(a b)))) (eq t (il:atom (second '(a b)))) (eq t (il:atom (third '(1 2 3 4 5)))) (eq t (il:atom (first (multiple-value-list (gentemp))))) (eq t (il:atom (first (multiple-value-list (gentemp "il"))))) )) (do-test "Stop on atoms from own functions" (flet ((temp-string nil "string")) (test-defun temp-fun nil #\*) (test-setq temp-atom *random-state*) (and (eq nil (il:atom (temp-string))) (eq nil (il:atom (temp-fun))) (eq nil (il:atom temp-atom)) ))) (do-test "Stop on atoms from system functions" (and (eq nil (il:atom (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:atom (second '(#\. #\k)))) )) (do-test "Test arrays aren't atoms" (and (eq nil (il:atom (make-array '(2 2)))) (eq nil (il:atom (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:atom (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:atom (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:atom (make-array 50 :initial-element 0))) (eq nil (il:atom (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't atoms" (and (eq nil (il:atom #\backspace)) ; character (eq nil (il:atom #\*)) ; character (eq nil (il:atom #\.)) ; character (eq nil (il:atom (make-hash-table))) ; hash table (eq nil (il:atom (car (list-all-packages)))) ; packages (eq nil (il:atom (pathname nil))) ; pathname (eq nil (il:atom *random-state*)) ; ramdom state (eq nil (il:atom #'cons)) ; compiled function (eq nil (il:atom (copy-readtable))) ; readtable (eq nil (il:atom #*1001)) ; simple-bit-vector (eq nil (il:atom "twine")) ; simple-string (eq nil (il:atom (make-synonym-stream nil))) ; stream (eq nil (il:atom '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST new file mode 100644 index 00000000..ac9127a5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: DataTypes ;; ;; Source: IRM, p 8.20 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>DataTypes.test ;; ;; (do-test "Test returns a list, and have some stuff in it" (let* ((datatypes (il:datatypes))) (and datatypes (find 'il:fixp datatypes) (find 'il:floatp datatypes) (find 'il:litatom datatypes) (find 'il:listp datatypes) (find 'il:arrayp datatypes) (find 'il:stringp datatypes) (find 'il:stackp datatypes) (find 'stream datatypes) (find 'random-state datatypes) (find 'pathname datatypes) T ))) (do-test "Test returns a list" (let* ((userdatatypes (il:userdatatypes))) (and userdatatypes T ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST new file mode 100644 index 00000000..d8611c0e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: LITATOM ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Litatom.test ;; ;; (do-test "test simple cases" (and ; Does the function work? (eq t (il:litatom 'a-atom)) (eq nil (il:litatom 5)) (eq nil (il:litatom "a string")) )) (do-test "Try various types of litatoms" (and (eq t (il:litatom 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq t (il:litatom 'A-couple-dashs)) (eq t (il:litatom 'Numbers-1234567890)) (eq t (il:litatom 'il:other-packags)) (eq t (il:litatom 'il:other-packagsNumbers-1234567890)) (eq t (il:litatom 'il:other-packagsA-couple-dashs)) (eq t (il:litatom T)) (eq t (il:litatom nil)) (eq t (il:litatom ())) (eq t (il:litatom '())) (eq t (il:litatom (list))) (eq t (il:litatom (eq 1 2))) )) (do-test "Test able to take litatoms from own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom)) (test-defun temp-fun nil 'litatom) (test-setq temp-atom 'il:temp-pointed) (and (eq t (il:litatom (tee))) (eq t (il:litatom (nill))) (eq t (il:litatom (temp-litatom))) (eq t (il:litatom (temp-fun))) (eq t (il:litatom temp-atom)) ))) (do-test "Test able to take litatoms from system function" (and (eq t (il:litatom (car '(a b)))) (eq t (il:litatom (second '(a b)))) (eq t (il:litatom (first (multiple-value-list (gentemp))))) (eq t (il:litatom (first (multiple-value-list (gentemp "il"))))) )) (do-test "Stop on litatoms from own functions" (flet ((temp-number nil 12.2) (temp-string nil "string")) (test-defun temp-fun nil #\*) (test-setq temp-atom *random-state*) (and (eq nil (il:litatom (temp-number))) (eq nil (il:litatom (temp-string))) (eq nil (il:litatom (temp-fun))) (eq nil (il:litatom temp-atom)) ))) (do-test "Stop on litatoms from system functions" (and (eq nil (il:litatom (car '(1 2)))) (eq nil (il:litatom (second '(#\. #\k)))) )) (do-test "Test numbers aren't litatoms" (and (eq nil (il:litatom 123)) (eq nil (il:litatom 45.67)) (eq nil (il:litatom 8/9)) (eq nil (il:litatom #c( 6/7 3.00))) (eq nil (il:litatom most-positive-fixnum)) (eq nil (il:litatom 37e5)) (eq nil (il:litatom .001)) (eq nil (il:litatom #c( 6/7 3.00))) )) (do-test "Test arrays aren't litatoms" (and (eq nil (il:litatom (make-array '(2 2)))) (eq nil (il:litatom (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:litatom (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:litatom (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:litatom (make-array 50 :initial-element 0))) (eq nil (il:litatom (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't litatoms" (and (eq nil (il:litatom #\backspace)) ; character (eq nil (il:litatom #\*)) ; character (eq nil (il:litatom #\.)) ; character (eq nil (il:litatom (make-hash-table))) ; hash table (eq nil (il:litatom (car (list-all-packages)))) ; packages (eq nil (il:litatom (pathname nil))) ; pathname (eq nil (il:litatom *random-state*)) ; ramdom state (eq nil (il:litatom #'cons)) ; compiled function (eq nil (il:litatom (copy-readtable))) ; readtable (eq nil (il:litatom #*1001)) ; simple-bit-vector (eq nil (il:litatom "twine")) ; simple-string (eq nil (il:litatom (make-synonym-stream nil))) ; stream (eq nil (il:litatom '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST new file mode 100644 index 00000000..143b941e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST @@ -0,0 +1 @@ +;; ;; Source: ;; ;; Created By: Bob CHERRY ;; ;; Creation Date: APR-2-87 ;; ;; Last Update: ;; ;; Filed As: {ERIS}TEST>I.S.Oprs>ISOPRS.TEST ;; ;; ;; Syntax: Just run with DO-TEST ;; ;; ;; Function Description: Chapter 9 (IRM) Iterative Statements ;; ;; ;; ;; Argument(s): FORM - what is evaluated. ;; ;; Returns: depends on what is used to terminate execution. ;; Should return T ;; (do-test "test FOR - IN - EQUAL funct" (LET ((FOO1 '(A B C D E)) (FOO2 '((A) (B) (C))) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 3 IL:as Y IL:in FOO1 IL:COLLECT (IL:LIST Y) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test FOR - WHILE - NOT - GREATERP funct" (LET ((FOO1 '(A B C D E)) (FOO2 '((A) (B) (C))) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT (IL:LIST Y) IL:WHILE (IL:NOT (IL:GREATERP X 3)) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test FOR - WHILE - LESSP funct" (LET ((FOO1 '(A B C D E)) (FOO2 '((A) (B) (C))) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT (IL:LIST Y) IL:WHILE (IL:LESSP X 4) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test SMALLEST & LARGEST funct" (LET ( (FOO1 '(7 15 1 3 9)) ) (AND (EQ 1 (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:SMALLEST Y) ) (EQ 15 (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:LARGEST Y) ) ) ) ) ;; ;; Next Test ;; (do-test "test UNTIL funct" (LET ( (FOO1 '(1 4 9 16 25) ) ) (EQUAL FOO1 (IL:for il:old X IL:from 1 IL:until (EQUAL x 6) IL:COLLECT (IL:TIMES X X) ) ) ) ) ;; ;; Next Test ;; (do-test "test FOR - BY funct" (LET ((FOO1 '(A B C D E)) (FOO2 '(A B C)) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 6 IL:by 2 IL:as Y IL:in FOO1 IL:COLLECT Y) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test COLLECT - WHEN funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(1 3 5)) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT Y IL:when (IL:NUMBERP Y) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test UNLESS funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(B D)) ) (IL:EQUAL (IL:for X IL:from 1 IL:to 5 IL:as Y IL:in FOO1 IL:COLLECT Y IL:unless (IL:NUMBERP Y) ) FOO2 ) ) ) ;; ;; Next Test ;; (do-test "test REPEATWHILE - REPEATUNTIL funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(B D)) ) (AND (IL:EQUAL (IL:for X IL:from 1 IL:REPEATWHILE IL:NOT (IL:EQUAL Y (CDR FOO2)) IL:as Y IL:in FOO1 IL:COLLECT Y IL:unless (IL:NUMBERP Y) ) FOO2 ) (IL:EQUAL (IL:for X IL:from 1 IL:REPEATUNTIL (IL:EQUAL Y (CDR FOO2)) IL:as Y IL:in FOO1 IL:COLLECT Y IL:unless (IL:NUMBERP Y) ) FOO2 ) ) ) ) ;; ;; Next Test ;; (do-test "test I.S.OPR funct" (LET ((FOO1 '(1 B 3 D 5)) (FOO2 '(B D)) ) (IL:I.S.OPR 'RATS '(SETQ IL:$$VAL (IL:NCONC1 IL:$$VAL IL:BODY)) ) (AND (IL:EQUAL (IL:for X IL:from 1 IL:REPEATWHILE IL:NOT (IL:EQUAL Y (CDR FOO2) ) IL:as Y IL:in FOO1 IL:RATS Y IL:unless (IL:NUMBERP Y) ) FOO2 ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-RECORDS.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-RECORDS.TEST new file mode 100644 index 00000000..6f2a86e9 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-RECORDS.TEST @@ -0,0 +1 @@ +(do-test-group |records| :BEFORE (PROGN (SETQ S (QUOTE (FIRST SECOND THIRD))) (SETQ ALFA "some string")) :AFTER (PROGN (IL:RECORD RECORD-TEST-NAME) (IL:RECORD RECORD-TEST-NAME1) (IL:RECORD RECORD-TEST-NAME2)) ;; record type record (DO-TEST |setup-record| (IL:RECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) (IL:SYNONYM ALPHA A) (IL:TYPE? (ODDP (LENGTH IL:DATUM))))) (DO-TEST |create-record| (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) (DO-TEST |type?-record| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST SYNONYM-record (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) (DO-TEST |fetch-record| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-record| (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) S) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA))) (DO-TEST |refetch-record| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) (DO-TEST rereplace-record (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH S) S))) (DO-TEST |typeglobalvariable-record| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) (DO-TEST |using-record| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) (DO-TEST |reusing-record| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) (DO-TEST |copying-record| (SETQ RECORD-TEST-RECORD2 (IL:CREATE RECORD-TEST-NAME IL:COPYING RECORD-TEST-RECORD)) (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) (DO-TEST |smashing-record| (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME IL:SMASHING RECORD-TEST-RECORD2)) (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) (EQ RECORD-TEST-RECORD4 RECORD-TEST-RECORD2) )) ; record type typerecord (DO-TEST |setup-typerecord| (IL:TYPERECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) (IL:SYNONYM ALPHA A))) (DO-TEST |create-typerecord| (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) (DO-TEST |type?-typerecord| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST SYNONYM-typerecord (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) (DO-TEST |fetch-typerecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-typerecord| (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) S) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA))) (DO-TEST |refetch-typerecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) (DO-TEST rereplace-typerecord (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH S) S))) (DO-TEST |typeglobalvariable-typerecord| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) (DO-TEST |using-typerecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) (DO-TEST |reusing-typerecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) (DO-TEST |copying-typerecord| (SETQ RECORD-TEST-RECORD2 (IL:CREATE RECORD-TEST-NAME IL:COPYING RECORD-TEST-RECORD)) (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) (DO-TEST |smashing-typerecord| (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME IL:SMASHING RECORD-TEST-RECORD2)) (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) ;record type proprecord (DO-TEST |setup-proprecord| (IL:PROPRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) (IL:SYNONYM ALPHA A) (IL:TYPE? (EVENP (LENGTH IL:DATUM))))) (DO-TEST |create-proprecord| (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) (DO-TEST |type?-proprecord| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST SYNONYM-proprecord (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) (DO-TEST |fetch-proprecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-proprecord| (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) S) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA))) (DO-TEST |refetch-proprecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) (DO-TEST rereplace-proprecord (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH S) S))) (DO-TEST |typeglobalvariable-proprecord| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) (DO-TEST |using-proprecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) (DO-TEST |reusing-proprecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) (DO-TEST |copying-proprecord| (SETQ RECORD-TEST-RECORD2 (IL:CREATE RECORD-TEST-NAME IL:COPYING RECORD-TEST-RECORD)) (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) (DO-TEST |smashing-proprecord| (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME IL:SMASHING RECORD-TEST-RECORD2)) (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) ;record type datatype (DO-TEST |setup-datatype| (IL:DATATYPE RECORD-TEST-NAME (ALPHA BRAVO GAMMA) (IL:SYNONYM ALPHA A))) (DO-TEST |create-datatype| (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) (DO-TEST |type?-datatype| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST SYNONYM-datatype (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) (DO-TEST |fetch-datatype| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-datatype| (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) S) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA))) (DO-TEST |refetch-datatype| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |typeglobalvariable-datatype| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) (DO-TEST fetchfield-datatype (AND (EQ (IL:FETCHFIELD (CAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) S) (EQ (IL:FETCHFIELD (CADR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) ALFA))) (DO-TEST replacefield-datatype (AND (EQ (IL:REPLACEFIELD (CAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD ALFA) ALFA) (EQ (IL:REPLACEFIELD (CADR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD S) S))) (DO-TEST refetchfield-datatype (AND (EQ (IL:FETCHFIELD (CAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCHFIELD (CADR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) S))) (DO-TEST getfieldspecs-datatype (EQ (CAR (IL:GETFIELDSPECS (QUOTE RECORD-TEST-NAME))) (CADDAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))))) (DO-TEST IL:typename-datatype (EQ (IL:TYPENAME RECORD-TEST-RECORD) (QUOTE RECORD-TEST-NAME))) (DO-TEST typenamep-datatype (IL:TYPENAMEP RECORD-TEST-RECORD (QUOTE RECORD-TEST-NAME))) (DO-TEST |using-datatype| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) (DO-TEST |reusing-datatype| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) (DO-TEST |copying-datatype| (SETQ RECORD-TEST-RECORD2 (IL:CREATE RECORD-TEST-NAME IL:COPYING RECORD-TEST-RECORD)) (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) (DO-TEST |smashing-datatype| (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME IL:SMASHING RECORD-TEST-RECORD2)) (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) ;record type arrayrecord (DO-TEST |setup-arrayrecord| (IL:ARRAYRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) (IL:SYNONYM ALPHA A) (IL:TYPE? (COND (IL:DATUM T))))) (DO-TEST |create-arrayrecord| (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) (DO-TEST |type?-arrayrecord| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST SYNONYM-typearary (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) (DO-TEST |fetch-arrayrecord| ` (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-arrayrecord| (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) S) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA))) (DO-TEST |refetch-arrayrecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) (DO-TEST rereplace-arrayrecord (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH S) S))) (DO-TEST |typeglobalvariable-arrayrecord| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) (DO-TEST getfieldspecs-arrayrecord (EQ (CAR (IL:GETFIELDSPECS (QUOTE RECORD-TEST-NAME))) (CADDAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))))) (DO-TEST IL:typename-arrayrecord (EQ (IL:TYPENAME RECORD-TEST-RECORD) (QUOTE il:arrayp))) (DO-TEST typenamep-arrayrecord (IL:TYPENAMEP RECORD-TEST-RECORD (QUOTE il:arrayp))) (DO-TEST |using-arrayrecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) (DO-TEST |reusing-arrayrecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) (DO-TEST |copying-arrayrecord| (SETQ RECORD-TEST-RECORD2 (IL:CREATE RECORD-TEST-NAME IL:COPYING RECORD-TEST-RECORD)) (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) (DO-TEST |smashing-arrayrecord| (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME IL:SMASHING RECORD-TEST-RECORD2)) (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) ;record type assocrecord (DO-TEST |setup-assocrecord| (IL:ASSOCRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) (IL:SYNONYM ALPHA A) (IL:TYPE? (NOT (IL:ATOM (CAR IL:DATUM)))))) (DO-TEST |create-assocrecord| (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) (DO-TEST |type?-assocrecord| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST synonym-assocrecord (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) (DO-TEST |fetch-assocrecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-assocrecord| (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) S) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA))) (DO-TEST |refetch-assocrecord| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) (DO-TEST rereplace-assocrecord (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH ALFA) ALFA) (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH S) S))) (DO-TEST |typeglobalvariable-assocrecord| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) (DO-TEST |using-assocrecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) (DO-TEST |reusing-assocrecord| (SETQ RECORD-TEST-RECORD3 (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) (DO-TEST |copying-assocrecord| (SETQ RECORD-TEST-RECORD2 (IL:CREATE RECORD-TEST-NAME IL:COPYING RECORD-TEST-RECORD)) (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) (DO-TEST |smashing-assocrecord| (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME IL:SMASHING RECORD-TEST-RECORD2)) (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) ;record type accessfns (DO-TEST setup-accessfns (IL:ACCESSFNS RECORD-TEST-NAME ((ALPHA (CAR IL:DATUM) (SETQ IL:DATUM(CONS IL:NEWVALUE (CDR IL:DATUM)))) (BRAVO (CADR IL:DATUM) (SETQ IL:DATUM (CONS (CAR IL:DATUM) (CONS IL:NEWVALUE (CDDR IL:DATUM))))) (GAMMA (CADDR IL:DATUM) (SETQ IL:DATUM (LIST (CAR IL:DATUM) (CADR IL:DATUM) IL:NEWVALUE)))) (IL:CREATE (LIST ALFA S NIL)) (IL:TYPE? (ODDP (LENGTH IL:DATUM))))) (DO-TEST create-accessfns (SETQ RECORD-TEST-RECORD (IL:create RECORD-TEST-NAME))) (DO-TEST |type?| (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) (DO-TEST |fetch-accessfns| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) (DO-TEST |replace-accessfns| (AND (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD IL:WITH S) (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD IL:WITH ALFA))) (DO-TEST |refetch-accessfns| (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) )) (DO-TEST |typeglobalvariable-accessfns| (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) ; blockrecords (DO-TEST setup-blockrecord (IL:DATATYPE RECORD-TEST-NAME1 ((ALPHA IL:POINTER)) ALPHA IL:_ S) (IL:BLOCKRECORD RECORD-TEST-NAME2 ((BRAVO IL:WORD) (GAMMA IL:WORD))) (SETQ RECORD-TEST-RECORD (IL:CREATE RECORD-TEST-NAME1))) (DO-TEST TEST-FETCH-BLOCKRECORD (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD) (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) IL:OF RECORD-TEST-RECORD) (IL:FETCH (RECORD-TEST-NAME2 GAMMA) IL:OF RECORD-TEST-RECORD))) (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD) S))) (DO-TEST TEST-REPLACE-BLOCKRECORD (IL:REPLACE (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD IL:WITH ALFA)) (DO-TEST TEST-reFETCH-BLOCKRECORD (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD) (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) IL:OF RECORD-TEST-RECORD) (IL:FETCH (RECORD-TEST-NAME2 GAMMA) IL:OF RECORD-TEST-RECORD))) (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD) ALFA))) (DO-TEST "TEST THAT REPLACES THROUGH THE BLOCKRECORD STRUCTURE" (IL:REPLACE (RECORD-TEST-NAME2 BRAVO) IL:OF RECORD-TEST-RECORD IL:WITH (IL:\\HILOC S)) (IL:REPLACE (RECORD-TEST-NAME2 GAMMA) IL:OF RECORD-TEST-RECORD IL:WITH (IL:\\LOLOC S))) (DO-TEST "TEST REFETCHING AFTER REPLACING THROUGH THE BLOCKRECORD" (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD) (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) IL:OF RECORD-TEST-RECORD) (IL:FETCH (RECORD-TEST-NAME2 GAMMA) IL:OF RECORD-TEST-RECORD))) (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD) S))) (Do-test "look at floating point" (IL:DATATYPE flnum ((n IL:floating))) (setq num1 (IL:CREATE flnum)) (setq num2 (IL:CREATE flnum)) (IL:BLOCKRECORD fldisect ((sign IL:BITS 1) (exp IL:BITS 8) (mant IL:BITS 23))) (setq anynum (IL:RAND)) (IL:REPLACE n IL:of num1 IL:with anynum) (IL:REPLACE n IL:of num2 IL:with (IL:times anynum 2)) (eq (IL:add1 (IL:fetch exp IL:of num1)) (IL:fetch exp IL:of num2))) (Do-test "test blank fields and playing with integers" (IL:DATATYPE intnum ((int IL:integer))) (setq num (IL:CREATE intnum)) (IL:BLOCKRECORD evenodd ((nil IL:bits 16) (nil IL:BITS 15) (lastbit IL:BITS 1))) (setq anynum (IL:RAND)) (IL:REPLACE int IL:of num IL:with anynum) (if (evenp (IL:fetch int IL:of num)) (progn (IL:replace lastbit IL:of num IL:with 1) (oddp (IL:fetch int IL:of num))) (progn (IL:replace lastbit IL:of num IL:with 0) (evenp (IL:fetch int IL:of num))))) ;Testing WITH (Do-test "simple with using a datatype" (IL:with flnum num1 (IL:setq n 0) (zerop n))) (Do-test "compound with using two datatypes" (IL:with flnum num1 (IL:with intnum num (IL:setq n (il:times n 2)) (IL:setq int 0) (and (equal (float int) n) (zerop int))))) ) ;END OF DO-TEST-GROUP STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST new file mode 100644 index 00000000..7b8262da --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8538: Interlisp interpreter doesn't bind variables to NIL when no initialization is given in LET* (do-test "AR 8538" (makunbound 'b) (il:eval '(let* ((a 7) b) (list a b))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST new file mode 100644 index 00000000..9bf6c5ba --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 8366: the local variable RPTN was unbound in RPT (do-test "AR 8366" (makunbound 'il:rptn) (equal (let ((x ())) (declare (special x)) (il:rpt 2 '(push il:rptn x)) (il:rptq 2 (push il:rptn x)) x) '(1 2 1 2)) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST new file mode 100644 index 00000000..9177390d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for changes to LLINTERP (do-test "AR 7404: MAKUNBOUND and BOUNDP disagree" (let ((*foo* 7)) (declare (special *foo*)) (makunbound '*foo*) (not (boundp '*foo*)))) (do-test "AR 7398: COMPILED-FUNCTION-P should always be NIL on symbols" (and (not (compiled-function-p '+)) (compiled-function-p #'+))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST b/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST new file mode 100644 index 00000000..1301b72b --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST @@ -0,0 +1 @@ +;;; test file for LLREAD 4-30-87 by woz ;;; AR 7741 (do-test "SKREAD understands vertical bar" (with-input-from-string (s "(a |b) c| d) e |") (il:skread s) (eq (read s) 'e)) ) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST new file mode 100644 index 00000000..d932fde8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for changes in LLSYMBOL (do-test ("AR 7385: (setf (symbol-function ...) ...) doesn't remove macro definition" :before (fmakunbound 'zab) :after (fmakunbound 'zab)) (progn (setf (macro-function 'zab) 'expand-zab) (setf (symbol-function 'zab) '(lambda () 9)) (not (macro-function 'zab)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST new file mode 100644 index 00000000..c117fec4 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST @@ -0,0 +1 @@ +;;; regression tests for LOCALFILE-PATCH: ;; Patch 1 (do-test "DLion renamefile bug" (or (not (eq (il:machinetype) 'il:dandelion)) ;This is only a DLion bug (let (foo) (il:closef (il:openstream "{dsk}foo" 'il:output 'il:new)) (setq foo (il:openstream "{dsk}foo" 'il:input 'il:old)) (prog1 (not (il:renamefile "{dsk}foo" "{dsk}bar")) (il:delfile (il:closef foo)))))) ;; Patch 2 (do-test-group "Rename nonexistant file" :before (ignore-errors (il:delfile "{dsk}this-file-does-not-exist;1")) :after (ignore-errors (il:delfile "{dsk}rename-target")) (do-test "Renaming nonexistant file" (expect-errors (error) (rename-file "{dsk}this-file-does-not-exist;1" "{dsk}rename-target") ) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST b/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST new file mode 100644 index 00000000..1b0562a8 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST @@ -0,0 +1 @@ +(do-test-group ("LONGFNCALL tests" :before (progn (test-defun rest-args (&rest x) x) (test-defun and-eq-frob (frob result) (and (eq frob 'frob) result)) )) (do-test "Check APPLY OF FUNCTION with lots and lots of arguments" (and-eq-frob 'frob (LET ((LONG (CL:DO* ((I 0 (CL:1+ I)) (L NIL (CONS I L))) ((> I 510) L)))) (CL:EQUAL LONG (CL:APPLY (CL:FUNCTION REST-ARGS) LONG))))) (do-test "Check APPLY OF SYMBOL with lots and lots of arguments" (and-eq-frob 'frob (LET ((LONG (CL:DO* ((I 0 (CL:1+ I)) (L NIL (CONS I L))) ((> I 510) L)))) (CL:EQUAL LONG (CL:APPLY 'REST-ARGS LONG))))) (do-test "Check function call with lots of arguments" (and-eq-frob 'frob (macrolet ((cra () (cons 'rest-args (do* ((i 0 (1+ i)) (l nil (cons i l))) ((> i 62) l))))) (equal (cra) (do* ((i 0 (1+ i)) (l nil (cons i l))) ((> i 62) l)))))) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST new file mode 100644 index 00000000..7a5fac81 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST @@ -0,0 +1 @@ +;; regression test for NAMESTRING-PATCH: (do-test "enough-namestring bug" (cl:enough-namestring "{eris}sources>foo.bar;7")) (do-test "namestring radix bug" (let ((*print-base* 2)) (eq (length (namestring "foo.bar;8")) 9))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST b/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST new file mode 100644 index 00000000..123b77c6 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NListP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>NListP.test ;; ;; (do-test "test simple cases" (and (equal nil (il:nlistp '(a))) (equal nil (il:nlistp '(1 2 3 (a b) (c (d e))))) (eq T (il:nlistp -5)) (eq T (il:nlistp 1000000)) (eq T (il:nlistp 'a-floatp)) (eq T (il:nlistp "a string")) )) (do-test "Test lists of various things" (and (equal nil nil(il:nlistp '("a" "list" "of" "strings" "23 #$%"))) (equal nil (il:nlistp '(a list of litatoms qw-32))) (equal nil (il:nlistp '(1 3/4 5.5 32e5))) )) (do-test "Test stop on own function" (flet ((temp-small nil '(12 BV "hi")) ) (test-defun temp-fun nil '(34 QW "bye")) (and (equal nil (il:nlistp (temp-small))) (equal nil (il:nlistp (temp-fun))) ))) (do-test "Test stop against system functions" (and (equal nil (il:nlistp (append '(a) '(b)))) (equal nil (il:nlistp (il:append '(a) '(b)))) (equal nil (il:nlistp (il:cons 'a 'b))) )) (do-test "Try various types of Litatoms" (and (eq T (il:nlistp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq T (il:nlistp 'A-couple-dashs)) (eq T (il:nlistp 'Numbers-1234567890)) (eq T (il:nlistp 'il:other-packags)) (eq T (il:nlistp 'il:other-packagsNumbers-1234567890)) (eq T (il:nlistp 'il:other-packagsA-couple-dashs)) (eq T (il:nlistp T)) (eq T (il:nlistp nil)) (eq T (il:nlistp ())) (eq T (il:nlistp '())) (eq T (il:nlistp (list))) (eq T (il:nlistp (eq 1 2))) )) (do-test "Test go on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq T (il:nlistp (tee))) (eq T (il:nlistp (nill))) (eq T (il:nlistp (temp-litatom))) (eq T (il:nlistp (temp-string))) (eq T (il:nlistp (temp-fun))) (eq T (il:nlistp temp-litatom)) ))) (do-test "Stop go from system functions" (and (eq T (il:nlistp (car '(#*1001 '#( 5 4 3 2 1))))) (eq T (il:nlistp (second '(#\. #\k)))) )) (do-test "Test arrays aren't lists" (and (eq T (il:nlistp (make-array '(2 2)))) (eq T (il:nlistp (make-array '(6 6 6) :element-type '(or integer string)))) (eq T (il:nlistp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq T (il:nlistp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq T (il:nlistp (make-array 50 :initial-element 0))) (eq T (il:nlistp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't lists" (and (eq T (il:nlistp #\backspace)) ; character (eq T (il:nlistp #\*)) ; character (eq T (il:nlistp #\.)) ; character (eq T (il:nlistp (make-hash-table))) ; hash table (eq T (il:nlistp (car (list-all-packages)))) ; packages (eq T (il:nlistp (pathname nil))) ; pathname (eq T (il:nlistp *random-state*)) ; ramdom state (eq T (il:nlistp #'cons)) ; compiled function (eq T (il:nlistp (copy-readtable))) ; readtable (eq T (il:nlistp #*1001)) ; simple-bit-vector (eq T (il:nlistp "twine")) ; simple-string (eq T (il:nlistp (make-synonym-stream nil))) ; stream (eq T (il:nlistp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST b/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST new file mode 100644 index 00000000..e242be3e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: NUMBERP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>NumberP.test ;; ;; (do-test "test simple cases" (and (eq 5 (il:numberp 5)) (equal 10.13 (il:numberp 10.13)) (eq nil (il:numberp 'a-numberp)) (eq nil (il:numberp "a string")) )) (do-test "Test numbers are numberps" (and (eq 123 (il:numberp 123)) (equal 45.67 (il:numberp 45.67)) (equal 8/9 (il:numberp 8/9)) (equal most-positive-fixnum (il:numberp most-positive-fixnum)) (equal 37e5 (il:numberp 37e5)) (equal .001 (il:numberp .001)) )) (do-test "Test go on own function" (flet ((temp-small nil 2) (temp-large nil 100000) (temp-floating nil 12.2)) (test-defun temp-fun nil 32e5) (and (eq 2 (il:numberp (temp-small))) (equal 100000 (il:numberp (temp-large))) (equal 12.2 (il:numberp (temp-floating))) (equal 32e5 (il:numberp (temp-fun))) ))) (do-test "Test work against system functions" (and (eq 3 (il:numberp (third '(1 2 3 4 5)))) (equal 3.3 (il:numberp (car '(3.3 2.2 1.1)))) (equal 2.3 (il:numberp (second '(1 2.3 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:numberp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:numberp 'A-couple-dashs)) (eq nil (il:numberp 'Numbers-1234567890)) (eq nil (il:numberp 'il:other-packags)) (eq nil (il:numberp 'il:other-packagsNumbers-1234567890)) (eq nil (il:numberp 'il:other-packagsA-couple-dashs)) (eq nil (il:numberp T)) (eq nil (il:numberp nil)) (eq nil (il:numberp ())) (eq nil (il:numberp '())) (eq nil (il:numberp (list))) (eq nil (il:numberp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:numberp (tee))) (eq nil (il:numberp (nill))) (eq nil (il:numberp (temp-litatom))) (eq nil (il:numberp (temp-string))) (eq nil (il:numberp (temp-fun))) (eq nil (il:numberp temp-litatom)) ))) (do-test "Stop on numberps from system functions" (and (eq nil (il:numberp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:numberp (second '(#\. #\k)))) )) (do-test "Test arrays aren't numberps" (and (eq nil (il:numberp (make-array '(2 2)))) (eq nil (il:numberp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:numberp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:numberp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:numberp (make-array 50 :initial-element 0))) (eq nil (il:numberp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't numberps" (and (eq nil (il:numberp #\backspace)) ; character (eq nil (il:numberp #\*)) ; character (eq nil (il:numberp #\.)) ; character (eq nil (il:numberp (make-hash-table))) ; hash table (eq nil (il:numberp (car (list-all-packages)))) ; packages (eq nil (il:numberp (pathname nil))) ; pathname (eq nil (il:numberp *random-state*)) ; ramdom state (eq nil (il:numberp #'cons)) ; compiled function (eq nil (il:numberp (copy-readtable))) ; readtable (eq nil (il:numberp #*1001)) ; simple-bit-vector (eq nil (il:numberp "twine")) ; simple-string (eq nil (il:numberp (make-synonym-stream nil))) ; stream (eq nil (il:numberp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST new file mode 100644 index 00000000..356ed4ad --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST @@ -0,0 +1 @@ +;; ;; Creation date: Jan 26, 1987 ;; ;; Created by: Karin M. Sye ;; ;; Regression tests for the Lyric Package System Ars ;; ;; AR 6713 ;; (do-test "package-ar6713: (PACKAGE-NICKNAMES package) returns the primary name of a package" (prog2 (make-package "pac" :nicknames '("pac1" "pac2" "pac3" )) (notany #'(lambda (x y) (find x (package-nicknames y) #'string=)) '("LISP" "pac") '(lisp "pac")) (xcl:delete-package "pac") ) ) ;; ;; AR 6632 ;; (do-test "package-ar6632: CTYPECASE should be in the LISP package" (find-symbol "CTYPECASE" 'lisp)) ;; ;; AR 6652 ;; (do-test "package-ar6652: ARG NOT PACKAGE wrong error attempting to read PHYLEX:PARC:XEROX" (and (catch 'bar (handler-bind (( xcl:missing-package #'(lambda (x) (throw 'bar t)) ) ( xcl:condition #'(lambda (x) (throw 'bar nil)) ) ) (progn (read (make-string-input-stream "PHYLEX:PARC")) nil ) ) ) (catch 'bar (handler-bind (( xcl:symbol-colon-error #'(lambda (x) (throw 'bar t)) ) ( xcl:condition #'(lambda (x) (throw 'bar nil)) ) ) (progn (read (make-string-input-stream "PHYLEX:PARC:XEROX")) nil ) ) ) ) ) ;; ;; AR 6700 ;; (do-test "package-ar6700: Symbols in wrong package" (and (every #'(lambda(x) (find-symbol x 'lisp)) '(copy-symbol make-symbol intern gentemp keywordp)) (find-symbol 'make-keyword 'il) ) ) ;; ;; AR 6742 ;; (do-test "package-ar6742: Shadowing-Import does not seem to add imported symbols to the shadowing-symbols list" (unwind-protect (progn (make-package 'abc :use nil) (shadowing-import '(lisp:if lisp:numberp) 'abc) (or (equal (package-shadowing-symbols 'abc) '(if numberp)) (equal (package-shadowing-symbols 'abc) '(numberp if)))) (xcl:delete-package 'abc) ) ) ;; ;; AR 6822 ;; (do-test "package-ar6822: Various package related bugs in cmlarray and friends (adjustable-array-p, *default-PUSH-EXTENSION-SIZE*, and CHAR were in the wrong place)" (and (find-symbol 'adjustable-array-p 'lisp) (find-symbol '*default-PUSH-EXTENSION-SIZE* 'xcl) (find-symbol 'CHAR 'lisp) ) ) ;; ;; AR 6835 ;; (do-test "package-ar6835: DEFPACKAGE fails for shadowing-import or shadow" (prog1 (and (xcl:defpackage "foo" (:shadow bar)) (xcl:defpackage "fooo" (:shadowing-import cl:*))) (xcl:delete-package "foo") (xcl:delete-package "fooo") ) ) ;; ;; AR 6858 ;; (do-test "package-ar6858: The variable *modules* should be in CML package rather than in Interlisp package" (string= (package-name (symbol-package '*modules*)) "LISP")) ;; ;; AR 6888 ;; (do-test "package-ar6888 : XCL:DELETE-PACKAGE should un-USE the dying package" (and (unwind-protect (progn (make-package 'p1) (make-package 'p2) (use-package 'p1 (find-package 'p2)) (xcl:delete-package (find-package 'p2)) (null (package-used-by-list (find-package 'p1))) ) (xcl:delete-package (find-package 'p1)) ) (unwind-protect (progn (make-package "p3" :use nil) (make-package "p2" :use "p3") (make-package "p1" :use "p2") (xcl:delete-package "p2") (null (or (package-used-by-list "p3") (package-use-list "p1"))) ) (xcl:delete-package "p1") (xcl:delete-package "p3") ) ) ) ;; ;; AR 6889 ;; (do-test "package-ar6889: Export interns NIL in package being exported from" (unwind-protect (progn (make-package 'pack :use nil) (intern "PRIVATE" 'pack) (export (intern "PUBLIC" 'pack) 'pack) (null (multiple-value-bind (name where) (find-symbol 'nil 'pack) where)) ) (xcl:delete-package 'pack) ) ) ;; ;; AR 6908 ;; (do-test "package-ar6908: Need do-internal-symbols for consistency" (let ((pac (make-package "PAC" :use nil)) buf) (progn (import '(cl:if cl:do cl:when cl:unless cl:let) pac) (xcl:do-internal-symbols (x pac (xcl:delete-package pac)) (push (symbol-name x) buf)) (every #'(lambda (x) (find x buf :test #'equal)) '("IF" "DO" "WHEN" "UNLESS" "LET")) ) ) ) ;; ;; AR 6909 ;; (do-test "package-ar6909shadowing-use-package removed from system" (not (fboundp 'shadowing-use-package)) ) ;; ;; AR 6941 ;; (do-test "package-ar6941: INTERN FOO NIL should make an uninterned symbol" (null (symbol-package (intern "FOO" NIL))) ) ;; ;; AR 7157 ;; (do-test "package-ar7157: Exec symbols not exported [xcl::*eval-function* xcl::*exec-prompt* xcl::*debugger-prompt*]" (every #'(lambda (x) (eq :external (second (multiple-value-list (find-symbol x 'xcl))))) '(*eval-function* *exec-prompt* *debugger-prompt*)) ) ;; ;; AR 7233 ;; (do-test "package-ar7233: IMPORT function interns NIL in package being imported to" (progn (make-package "pac" :use nil) (import 'cl:if (find-package "pac")) (prog1 (null (multiple-value-bind (name where) (find-symbol 'nil "pac") where)) (xcl:delete-package "pac") ) ) ) ;; ;; AR 7240 ;; (do-test "package-ar7240: UNINTERN fails to remove the symbol from the package's shadowing-symbols list" (progn (make-package 'pac :use nil) (shadowing-import 'lisp:if 'pac) (unintern 'if 'pac) (prog1 (null (package-shadowing-symbols 'pac)) (xcl:delete-package 'pac) ) ) ) ;; ;; AR 7285 ;; (do-test "package-ar7285: symbol-colon-error conditrion should be exported from the XCL package" (eq :external (cadr (multiple-value-list (find-symbol 'symbol-colon-error 'xcl)))) ) ;; ;; AR 7344 (do-test "package-ar7344: import returns nil instead of t in 21-Jan-87 sysout" (prog2 (make-package 'pac :use nil) (import 'il:plus 'pac) (xcl:delete-package 'pac) ) ) ;; ;; AR 8057 ;; (do-test "package-ar8057: Missing symbols from the LISP package" (every #'(lambda (name) (multiple-value-bind (symbol where) (find-symbol name "LISP") (eq where :external) )) '("SPEED" "SPACE" "SAFETY" "COMPILATION-SPEED") ) ) ;; ;; AR 8130 ;; (do-test "defpackage foo (:use nil)) breaks" (prog2 (if (find-package 'foo) (xcl:delete-package 'foo)) (defpackage foo (:use nil)) (xcl:delete-package 'foo) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST new file mode 100644 index 00000000..55c64c33 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST @@ -0,0 +1 @@ +;; ;; Creation date - Jan. 22, 1987 ;; ;; Created by - Karin M. Sye ;; ;; The following test code attemps to test all the PACKAGE conditions implemented by Xerox Common Lisp ;; ;; ** CONDITIONS RAISED WHILE READING SYMBOL NAMES ** ;; (do-test "test xcl:read-conflict condition" (catch 'done (handler-bind ((xcl:read-conflict #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (let ( (il:litatom-package-conversion-enabled t) (xcl:*preferred-reading-symbols* (remove 'il:* xcl:*preferred-reading-symbols*)) (*readtable* il:coderdtbl) ) (read (make-string-input-stream "*")) ; no condition was signaled nil ) ) ) ) ;; ;; (do-test "test xcl:missing-external-symbol condition" (catch 'done (handler-bind ((xcl:missing-external-symbol #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (progn (read (make-string-input-stream "lisp:dopey-sleepy")) ; no condition was signaled nil ) ) ) ) ;; ;; (do-test "test xcl:symbol-colon-error condition" (catch 'done (handler-bind ((xcl:symbol-colon-error #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (progn (read (make-string-input-stream "aa::bb:cc")) ; no condition was signaled nil ) ) ) ) ;; ;; (do-test "test xcl:missing-package condition" (catch 'done (handler-bind ((xcl:missing-package #'(lambda (condition) (throw 'done t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'done nil)) ) ) (progn (read (make-string-input-stream "ugly:duckling")) ; no condition was signaled nil ) ) ) ) ;; ;; ** CONDITION RAISED WHILE IN THE PACKAGE SYSTEM ;; (do-test "test xcl:symbol-conflict condition" (every #'(lambda (subtype) (subtypep subtype 'xcl:symbol-conflict) ) '(xcl:use-conflict xcl:export-conflict xcl:import-conflict xcl:unintern-conflict) ) ) ;; ;; (do-test "test xcl:package-error condition" (subtypep 'xcl:export-missing 'xcl:package-error) ) ;; ;; ** CONDITION RAISED WHILE CALLING USE-PACKAGE ;; (do-test "test xcl:use-conflict condition" (catch 'fool (unwind-protect (handler-bind ((xcl:use-conflict #'(lambda (condition) (throw 'fool t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'fool nil)) ) ) (progn (every #'(lambda (x) (make-package x :use nil)) '("p1" "p2" "p3")) (export (intern "a" "p1") "p1") (export (intern "a" "p2") "p2") (use-package '("p1" "p2") "p3") ; no condition was signaled nil ) ) (mapc #'(lambda (x) (xcl:delete-package x)) '("p1" "p2" "p3")) ) ) ) ;; ;; ** CONDITION RAISED WHILE CALLING EXPORT ;; (do-test "test xcl:export-conflict condition" (catch 'off (unwind-protect (handler-bind ((xcl:export-conflict #'(lambda (condition) (throw 'off t) )) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'off nil) )) ) (progn (make-package "p1" :use nil) (make-package "p2" :use "p1") (export (intern "A" "p2") "p2") (export (intern "A" "p1") "p1") ; no condition was signaled nil ) ) (mapc #'xcl:delete-package '("p1" "p2")) ) ) ) ;; ;; (do-test "test xcl:export-missing condition" (catch 'bye (handler-bind ((xcl:export-missing #'(lambda (condition) (throw 'bye t)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'bye nil) )) ) (progn (export '( sssnow-whiteee sssneezyyyy) 'lisp) ; no condition was signaled nil ) ) ) ) ;; ;; ** CONDITION RAISED WHILE CALLING IMPORT ;; (do-test "test xcl:import-conflict condition" (block exit (handler-bind (( xcl:import-conflict #'(lambda (condition) (return-from exit t) )) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (return-from exit nil) )) ) (progn (import '(lisp:* lisp:length) 'il) ;no condition was signaled nil ) ) ) ) ;; ;; ** CONDITION RAISED WHILE CALLING UNINTERN ;; (do-test "test xcl:unintern-conflict condition" (catch 'fool (unwind-protect (handler-bind ((xcl:unintern-conflict #'(lambda (condition) (throw 'fool t) )) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (throw 'fool nil) )) ) (progn (every #'(lambda (x) (make-package x :use nil)) '("p1" "p2" "p3")) (export (intern "A" "p1") "p1") (export (intern "A" "p2") "p2") (shadow 'a "p3") (use-package '("p1" "p2") "p3") (unintern (find-symbol "A" "p3") "p3") ; no condition was signaled nil ) ) (mapc #'(lambda (x) (xcl:delete-package x)) '("p1" "p2" "p3")) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER-TEST.DATA b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER-TEST.DATA new file mode 100644 index 00000000..fd36dc55 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER-TEST.DATA @@ -0,0 +1 @@ +(CL:SETQ CONVERTER-TEST-CASES (QUOTE ( (*CATCH "INTERLISP" :EXTERNAL "ERROR") (*FEATURES* "LISP" :EXTERNAL ) (*PRINT-ARRAY* "LISP" :EXTERNAL ) (*PRINT-LENGTH* "LISP" :EXTERNAL ) (*PRINT-LEVEL* "LISP" :EXTERNAL ) (*PRINT-STRUCTURE* "INTERLISP" :EXTERNAL ) (*THROW "INTERLISP" :EXTERNAL "ERROR") (*STANDARD-OUTPUT* "LISP" :EXTERNAL ) (ADJUST-ARRAY "LISP" :EXTERNAL "O.K.") (ADJUSTABLE-ARRAY-P "LISP" :EXTERNAL "O.K.") (ALPHA-CHAR-P "LISP" :EXTERNAL "O.K.") (ALPHANUMERICP "LISP" :EXTERNAL "O.K.") (AND "LISP" :EXTERNAL "EQ") (APPLY "INTERLISP" :EXTERNAL "PREFERRED") (AREF "LISP" :EXTERNAL "O.K.") (ARRAY "INTERLISP" :EXTERNAL "PREFERRED") (ARRAY-DIMENSION "LISP" :EXTERNAL "O.K.") (ARRAY-DIMENSION-LIMIT "LISP" :EXTERNAL "O.K.") (ARRAY-DIMENSIONS "LISP" :EXTERNAL "O.K.") (ARRAY-ELEMENT-TYPE "LISP" :EXTERNAL "O.K.") (ARRAY-HAS-FILL-POINTER-P "LISP" :EXTERNAL "O.K.") (ARRAY-IN-BOUNDS-P "LISP" :EXTERNAL "O.K.") (ARRAY-RANK "LISP" :EXTERNAL "O.K.") (ARRAY-RANK-LIMIT "LISP" :EXTERNAL "O.K.") (ARRAY-ROW-MAJOR-INDEX "LISP" :EXTERNAL "O.K.") (ARRAY-TOTAL-SIZE "LISP" :EXTERNAL "O.K.") (ARRAY-TOTAL-SIZE-LIMIT "LISP" :EXTERNAL "O.K.") (ARRAYP "INTERLISP" :EXTERNAL "PREFERRED") (ASET "XEROX-COMMON-LISP" :EXTERNAL "O.K.") (ATOM "INTERLISP" :EXTERNAL "PREFERRED") (BIT "LISP" :EXTERNAL "EQ") (BIT-VECTOR "LISP" :EXTERNAL "O.K.") (BIT-VECTOR-P "LISP" :EXTERNAL "O.K.") (BOTH-CASE-P "LISP" :EXTERNAL "O.K.") (BOUNDP "LISP" :EXTERNAL "EQ") (CASE "LISP" :EXTERNAL "EQ") (CATCH "LISP" :EXTERNAL "O.K.") (CHAR-BITS "LISP" :EXTERNAL "O.K.") (CHAR-CODE "LISP" :EXTERNAL "O.K.") (CHAR-CODE-LIMIT "LISP" :EXTERNAL "O.K.") (CHAR-DOWNCASE "LISP" :EXTERNAL "O.K.") (CHAR-EQUAL "LISP" :EXTERNAL "O.K.") (CHAR-FONT "LISP" :EXTERNAL "O.K.") (CHAR-GREATERP "LISP" :EXTERNAL "O.K.") (CHAR-INT "LISP" :EXTERNAL "O.K.") (CHAR-LESSP "LISP" :EXTERNAL "O.K.") (CHAR-NAME "LISP" :EXTERNAL "O.K.") (CHAR-NOT-EQUAL "LISP" :EXTERNAL "O.K.") (CHAR-NOT-GREATERP "LISP" :EXTERNAL "O.K.") (CHAR-NOT-LESSP "LISP" :EXTERNAL "O.K.") (CHAR-UPCASE "LISP" :EXTERNAL "O.K.") (CHAR/= "LISP" :EXTERNAL "O.K.") (CHAR< "LISP" :EXTERNAL "O.K.") (CHAR<= "LISP" :EXTERNAL "O.K.") (CHAR= "LISP" :EXTERNAL "O.K.") (CHAR> "LISP" :EXTERNAL "O.K.") (CHAR>= "LISP" :EXTERNAL "O.K.") (CHARACTER "INTERLISP" :EXTERNAL "PREFERRED") (CHARACTERP "LISP" :EXTERNAL "O.K.") (CHECK-TYPE "LISP" :EXTERNAL "O.K.") (CMLPATH "INTERLISP" :EXTERNAL "ERROR") (CMLPROMPT "INTERLISP" :EXTERNAL "O.K.") (CMLRDTBL "INTERLISP" :EXTERNAL "O.K.") (CMLREAD "INTERLISP" :EXTERNAL "O.K.") (CMLSHOW "INTERLISP" :EXTERNAL "ERROR") (CMLWINDOW "INTERLISP" :EXTERNAL "ERROR") (CODE-CHAR "LISP" :EXTERNAL "O.K.") (COERCE "LISP" :EXTERNAL "EQ") (COMPILE-FILE "INTERLISP" :EXTERNAL "PREFERRED") (COMPLEX "LISP" :EXTERNAL "EQ") (COMPLEXP "LISP" :EXTERNAL "O.K.") (COND "LISP" :EXTERNAL "EQ") (CONSP "LISP" :EXTERNAL "O.K.") (DECLARE "LISP" :EXTERNAL "EQ") (DEFINE-MODIFY-MACRO "LISP" :EXTERNAL "O.K.") (DEFMACRO "LISP" :EXTERNAL "EQ") (DEFSETF "LISP" :EXTERNAL "O.K.") (DEFSTRUCT "INTERLISP" :EXTERNAL "PREFERRED") (DEFTYPE "LISP" :EXTERNAL "O.K.") (DIGIT-CHAR "LISP" :EXTERNAL "O.K.") (DIGIT-CHAR-P "LISP" :EXTERNAL "O.K.") (DO "INTERLISP" :EXTERNAL "PREFERRED") (DO* "LISP" :EXTERNAL "O.K.") (DOLIST "LISP" :EXTERNAL "O.K.") (DOTIMES "LISP" :EXTERNAL "O.K.") (DOUBLE-FLOAT "LISP" :EXTERNAL "O.K.") (EQ "LISP" :EXTERNAL "EQ") (EQL "LISP" :EXTERNAL "EQ") (EQUAL "INTERLISP" :EXTERNAL "PREFERRED") (EQUALP "LISP" :EXTERNAL "O.K.") (FBOUNDP "LISP" :EXTERNAL "O.K.") (FILL-POINTER "INTERLISP" :EXTERNAL "PREFERRED") (FLOAT "LISP" :EXTERNAL "EQ") (FLOATP "INTERLISP" :EXTERNAL "PREFERRED") (FUNCALL "LISP" :EXTERNAL "O.K.") (FUNCTION "INTERLISP" :EXTERNAL "PREFERRED") (GO "LISP" :EXTERNAL "EQ") (GRAPHIC-CHAR-P "LISP" :EXTERNAL "O.K.") (IF "INTERLISP" :EXTERNAL "PREFERRED") (INT-CHAR "LISP" :EXTERNAL "O.K.") (INTEGER "LISP" :EXTERNAL "EQ") (INTEGERP "LISP" :EXTERNAL "O.K.") (LAMBDA "INTERLISP" :EXTERNAL "PREFERRED") (LET "LISP" :EXTERNAL "EQ") (LET* "LISP" :EXTERNAL "EQ") (LIST* "LISP" :EXTERNAL "EQ") (LISTFILES1 "INTERLISP" :EXTERNAL "O.K.") (LISTP "INTERLISP" :EXTERNAL "PREFERRED") (LONG-FLOAT "LISP" :EXTERNAL "O.K.") (LOWER-CASE-P "LISP" :EXTERNAL "O.K.") (MAKE-ARRAY "LISP" :EXTERNAL "O.K.") (MAKE-CHAR "LISP" :EXTERNAL "O.K.") (MAKECMLINDEX "INTERLISP" :EXTERNAL "ERROR") (MAPCAR "INTERLISP" :EXTERNAL "PREFERRED") (MEMBER "INTERLISP" :EXTERNAL "PREFERRED") (MOD "INTERLISP" :EXTERNAL "PREFERRED") (NAME-CHAR "LISP" :EXTERNAL "O.K.") (NEWPRINTDEF "INTERLISP" :EXTERNAL "O.K.") (NOT "LISP" :EXTERNAL "EQ") (NULL "LISP" :EXTERNAL "EQ") (NUMBERP "INTERLISP" :EXTERNAL "PREFERRED") (OR "LISP" :EXTERNAL "EQ") (PPLISTFILE "INTERLISP" :EXTERNAL "ERROR") (PROG "LISP" :EXTERNAL "EQ") (PROG* "LISP" :EXTERNAL "EQ") (PROG1 "LISP" :EXTERNAL "EQ") (PROG2 "LISP" :EXTERNAL "EQ") (PROGN "LISP" :EXTERNAL "EQ") (PSETQ "LISP" :EXTERNAL "O.K.") (QUOTE "LISP" :EXTERNAL "EQ") (RATIONAL "INTERLISP" :EXTERNAL "PREFERRED") (RATIONALP "LISP" :EXTERNAL "O.K.") (SATISFIES "LISP" :EXTERNAL "EQ") (SBIT "LISP" :EXTERNAL "O.K.") (SET "LISP" :EXTERNAL "EQ") (SETF "LISP" :EXTERNAL "O.K.") (SETQ "INTERLISP" :EXTERNAL "PREFERRED") (SHORT-FLOAT "LISP" :EXTERNAL "O.K.") (SIGNED-BYTE "INTERLISP" :EXTERNAL "PREFERRED") (SIMPLE-ARRAY "LISP" :EXTERNAL "O.K.") (SIMPLE-BIT-VECTOR "LISP" :EXTERNAL "O.K.") (SIMPLE-STRING "INTERLISP" :EXTERNAL "PREFERRED") (SIMPLE-VECTOR "LISP" :EXTERNAL "O.K.") (SINGLE-FLOAT "LISP" :EXTERNAL "O.K.") (SPECIAL-FORM-P "LISP" :EXTERNAL "O.K.") (STANDARD-CHAR-P "LISP" :EXTERNAL "O.K.") (STRING "LISP" :EXTERNAL "EQ") (STRING-CHAR-P "LISP" :EXTERNAL "O.K.") (STRINGP "INTERLISP" :EXTERNAL "PREFERRED") (SVREF "LISP" :EXTERNAL "O.K.") (TAGBODY "LISP" :EXTERNAL "O.K.") (THE "LISP" :EXTERNAL "EQ") (THROW "LISP" :EXTERNAL "O.K.") (TYPE-OF "LISP" :EXTERNAL "O.K.") (TYPECASE "LISP" :EXTERNAL "O.K.") (TYPEP "LISP" :EXTERNAL "EQ") (UNLESS "INTERLISP" :EXTERNAL "PREFERRED") (UNSIGNED-BYTE "LISP" :EXTERNAL "O.K.") (UNWINDPROTECT "INTERLISP" :EXTERNAL "ERROR") (UPPER-CASE-P "LISP" :EXTERNAL "O.K.") (VALUES "INTERLISP" :EXTERNAL "PREFERRED") (VECTOR "INTERLISP" :EXTERNAL "PREFERRED") (VECTOR-POP "LISP" :EXTERNAL "O.K.") (VECTOR-PUSH "LISP" :EXTERNAL "O.K.") (VECTOR-PUSH-EXTEND "LISP" :EXTERNAL "O.K.") (VECTORP "LISP" :EXTERNAL "O.K.") (WHEN "INTERLISP" :EXTERNAL "PREFERRED") (WRITE-STRING "LISP" :EXTERNAL "O.K.") (CL::FOO1 "LISP" :INTERNAL) (CL::FOO2 "LISP" :INTERNAL) (CL::LYRIC "LISP" :INTERNAL) (:FOO "KEYWORD" :EXTERNAL) (:BAR "KEYWORD" :EXTERNAL) (:LYRIC "KEYWORD" :EXTERNAL) (:KEYWORD "KEYWORD" :EXTERNAL) (:WOW "KEYWORD" :EXTERNAL) (MAKEFILE "INTERLISP" :EXTERNAL) (CL:* "LISP" :EXTERNAL) (APPEND "INTERLISP" :EXTERNAL) (PLUS "INTERLISP" :EXTERNAL) (SORT "INTERLISP" :EXTERNAL) (LOGOUT "INTERLISP" :EXTERNAL) (LOGIN "INTERLISP" :EXTERNAL) (abc "INTERLISP" :EXTERNAL) (XYZ "INTERLISP" :EXTERNAL) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST new file mode 100644 index 00000000..830a96d7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST @@ -0,0 +1 @@ +;; ;; Creation date - Jan. 30, 1987 ;; ;; Created by - Ron Fischer , Karin M. Sye ;; ;; Test purpose - make sure Package Converter translates symbols ;; (residing in the "old" CML files writen using Koto CML package) into correct packages. ;; ;; ;; ** NOTE: In order for this test to be run successfully, the test data file, package-converter-test.data, ;; needs to exist on {eris}test>package> ;; ;; (do-test "converter test 1" (flet ((converter-test-function () "Loads a file of symbols with the converter enabled. (The file should set the variable il:converter-test-cases to a list of triplets: symbol, package name, and location keyword) Checks, based on information in the data file, whether the symbol was read correctly." (let ( ;Turn on the converter (il:litatom-package-conversion-enabled t) ) (declare (special il:litatom-package-conversion-enabled)) ;Load the test file (il:load '{eris}test>package>package-converter-test.data) ;Expect every test case to return true (every #'(lambda (test-case) (let (;Pick apart the test cases for easy reference (symbol (first test-case)) (package-name (second test-case)) (where (third test-case))) (if (and ; Check if the symbol has been read into the correct package (string= package-name (package-name (symbol-package symbol))) ; and if it is correctly :internal or :external in that package (eq where (second (multiple-value-list (find-symbol (symbol-name symbol) package-name)))) ) ; OK, just return t t ; Print a warning so we know what fails (warn "Symbol converter failed for ~s, should have been ~s in ~s" symbol where package-name) ) ) ) il:converter-test-cases) ) )) (converter-test-function) ) ) (do-test "converter test 2" ;; ;; removing symbols from il:*preferred-reading-symbols* list should cause READ-CONFLICT condition ;; to be raised when trying to read back those symbols ;; (let ((count 0) (symbol nil) (symbol-count (length il:*preferred-reading-symbols*)) (symbol-list (mapcar #'(lambda (x) (find-symbol (symbol-name x) 'cl)) il:*preferred-reading-symbols*)) (il:litatom-package-conversion-enabled t) (il:*preferred-reading-symbols* nil) (*readtable* il:coderdtbl) ) (dotimes (x symbol-count (= count symbol-count)) (catch 'here (handler-bind ((xcl:read-conflict #'(lambda (condition) (incf count) (throw 'here)) ) (xcl:condition #'(lambda (condition) ; wrong type of condition was signaled (warn "Removing ~s from il:*preferred-reading-symbols* fails to signal READ-CONFLICT condition. It signals ~s instead." symbol condition) (throw 'here)) ) ) (setq symbol (string (nth x symbol-list))) (read (make-string-input-stream symbol)) ; no condition was signaled (format t "Removing ~s from il:*preferred-reading-symbols* fails to signal READ-CONFLICT condition" symbol) (throw 'here) ) ) ) ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PRETTY-CIRCLE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/PRETTY-CIRCLE-REGRESSION.TEST new file mode 100644 index 00000000..98772eae --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PRETTY-CIRCLE-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Testing whether *print-circle* overrides *print-pretty* because ;;; our pretty-printer can't hack circular structures yet... (do-test ":circle overrides :pretty" (ignore-errors (string= (write-to-string '#1=(#1# . #1#) :pretty t :circle t) "#1= (#1# . #1#)")) ) (do-test ":escape overrides :pretty" (string= (write-to-string '(defun foo (bar baz) (drek "junk")) :pretty t :escape nil) "(defun foo (bar baz) (drek junk))") ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PRINTING-MINUS0.TEST b/internal/test/LANGUAGE/from-sun/language/other/PRINTING-MINUS0.TEST new file mode 100644 index 00000000..2d9be223 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PRINTING-MINUS0.TEST @@ -0,0 +1 @@ +(do-test "-0.0 doesn't blow up number printer" (string= (write-to-string (* 0.0 -1.0)) "-0.0")) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PROC-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/PROC-REGRESSION.TEST new file mode 100644 index 00000000..5a8e9fde --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PROC-REGRESSION.TEST @@ -0,0 +1 @@ +;;; Regression test for WITH.MONITOR macro. ;;; AR 7706 ;;; Nested with.monitor's for same lock lose. ;;; Need to make sure that return from inner with.monitor does ;;; not release lock unless it actually acquired it. ;;; This also tests ar 7280--interpreted with.monitor fails. (do-test nested-monitor (let ((lock (il:create.monitorlock "Test")) ) (macrolet ((test-monitor () `(il:process.result (il:add.process `(il:obtain.monitorlock ',lock t)) t))) (and (il:with.monitor lock (and (null (test-monitor)) ; locked now (il:with.monitor lock (null (test-monitor))) ; still locked (null (test-monitor))) ; locked after nested exit ) (not (null (test-monitor)))))) ; but unlocked now ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST b/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST new file mode 100644 index 00000000..7ead376f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: il:getprop ;; ;; Source: IRM, p 2.5 ;; ;; Chapter 2: Litatoms ;; section 3: Property Lists ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>property>getprop.test ;; ;; (do-test "test putprop & getprop" (let* ((tempx (gensym)) (tempy (gensym))) (and (equal 'tennis (il:putprop tempx 'shoes 'tennis)) (equal 'basket (il:putprop tempy 'games 'basket)) (equal 'tennis (il:getprop tempx 'shoes)) (equal 'basket (il:getprop tempy 'games)) (equal nil (il:getprop tempx 'games)) (equal nil (il:getprop tempy 'shoes)) (equal 'foot (il:putprop tempy 'games 'foot)) (equal 'foot (il:getprop tempy 'games)) ))) (do-test "test addprop" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(basket foot) (il:addprop tempx 'games 'foot)) (equal '(base basket foot) (il:addprop tempx 'games 'base T)) (equal '(base basket foot) (il:getprop tempx 'games)) ))) (do-test "test remprop" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(basket foot) (il:addprop tempx 'games 'foot)) (equal 'games (il:remprop tempx 'games)) (equal nil (il:getprop tempx 'games 'base T)) (equal nil (il:remprop tempx 'games)) ))) (do-test "test remproplist" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(basket foot) (il:addprop tempx 'games 'foot)) (equal nil (il:remproplist tempx '(games))) (equal nil (il:getprop tempx 'games)) (equal nil (il:remproplist tempx '(games))) ))) (do-test "test changeprop" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal tempx (il:changeprop tempx 'games 'sports)) (equal '(basket) (il:getprop tempx 'sports)) ))) (do-test "test propnames" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(games) (il:propnames tempx)) ))) (do-test "test deflist" (let* ((tempx (gensym)) (tempy (gensym))) (and (equal nil (il:deflist '((tempx Janet) (tempy Leslie)) 'friends)) (equal 'Janet (il:getprop 'tempx 'friends)) (equal 'Leslie (il:getprop 'tempy 'friends)) ))) (do-test "test getproplist" (let* ((tempx (gensym))) (and (equal '(basket) (il:putprop tempx 'games '(basket))) (equal '(games (basket)) (il:getproplist tempx)) ))) (do-test "test setproplist" (let* ((tempx (gensym))) (and (equal '(work fun) (il:setproplist tempx '(work fun))) (equal '(work fun) (il:getproplist tempx)) ))) (do-test "test getlis" (let* ((tempx (gensym))) (and (equal '(work fun) (il:setproplist tempx '(work fun))) (equal '(work fun) (il:getlis tempx '(work))) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST new file mode 100644 index 00000000..2b2e951f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "expt simple function" (equal (CL:EXPT -1.0 2) 1.0)) (do-test "expt complex number" (equal (CL:EXPT 0.0 (complex 1.0 -5.0)) 0.0)) (do-test "expt zero" (equal (CL:EXPT 0.0 0) 1.0)) (do-test "expt fraction raised to the zero" (eq (CL:EXPT (/ 1 2) 0) 1)) (do-test "expt negative raised to a fraction" (equal (CL:EXPT -8 (/ 1 4)) #C(1.1892071 1.1892071))) (do-test "expt very large number" (equal (CL:EXPT -1.539016e+9 2) 2.3685701e+18)) (do-test "sqrt with complex number" (equal (sqrt #C(0.0 0.0)) 0.0)) (do-test "asin with complex number" (equal (asin #C(1.0 0.0)) #C(1.5707964 0.0))) (do-test "phase with complex number" (equal (phase #C(1.0 0.0)) 0.0)) (do-test "acosh with complex number" (equal (acosh #C(-2.9732 -3.328)) #C(2.1905336 -2.2875323) )) (do-test "rational" (il:leq (rational -1e20) 0)) (do-test "decode-float and scale-float are inverses" (and (setq x 3.8246e-41) (multiple-value-setq (a b c) (decode-float x)) (equal x (scale-float a b)))) (do-test "Floor and bignums" (multiple-value-bind (f r) (floor -2165/60893 31072) (= -2165/60893 (+ r (* f 31072)))) ) (do-test "type expander for Complex" (and (not (typep #C(5 6) '(complex float))) (typep #C(5 6) '(complex integer))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST new file mode 100644 index 00000000..c936428a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "RESETVAR works interpreted" (il:defineq (il:foo (il:lambda nil il:unixftpflg))) (il:advise 'il:foo 'il:around nil '(il:resetvar il:unixftpflg t il:*)) (eq t (il:foo))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/SIMPLE-SUPPLIED-P.TEST b/internal/test/LANGUAGE/from-sun/language/other/SIMPLE-SUPPLIED-P.TEST new file mode 100644 index 00000000..76716b94 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/SIMPLE-SUPPLIED-P.TEST @@ -0,0 +1 @@ +;;;; Simple test of supplied-p parameters (do-test "supplied-p: funcitons" (setf (symbol-function 'supplied-p-test) '(lambda (&key (key 'init key-supplied)) (list key key-supplied))) (and (equal (supplied-p-test) '(init nil)) (equal (supplied-p-test :key 'foo) '(foo t)) (compile 'supplied-p-test) (equal (supplied-p-test) '(init nil)) (equal (supplied-p-test :key 'foo) '(foo t))) ) (do-test "supplied-p: macros" (defmacro supplied-p-test-m (&key (key 'init key-supplied)) `'(,key ,key-supplied)) (setf (symbol-function '|expand-SUPPLIED-P-TEST-M|) (il:closure-function (symbol-function '|expand-SUPPLIED-P-TEST-M|))) (and (equal (supplied-p-test-m) '(init nil)) (equal (supplied-p-test-m :key foo) '(foo t)) (compile '|expand-SUPPLIED-P-TEST-M|) ; This is implementation-dependent (equal (supplied-p-test-m) '(init nil)) (equal (supplied-p-test-m :key foo) '(foo t))) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/SINGLE-OP-ARITH.TEST b/internal/test/LANGUAGE/from-sun/language/other/SINGLE-OP-ARITH.TEST new file mode 100644 index 0000000000000000000000000000000000000000..0b7ff9d0ca35028dd571209aa8c064678c4bf5a6 GIT binary patch literal 1794 zcmbVMO>fgM7!Ct=h{TB_msjObM_M3GlQ>z0Pz4(x?E}$rCr!LIB8@XA8ybh*_*48k zUOVZQjufG$YCar4AMazo8AFv7i=2Zfxs2;f6cEd-UaokZB~bIKuHZsQ;OT-xB8oIq zb1HK@hSOLkOK_tDpivmY{02vmtmYC-(a?zz1Wg=2u4NT}B zhjWgK9EgUe{Nf5d6{*cH?F%X9K=fI?v^Ieq5`q9A{1Wusp*mZ-8q2coy_qnWcB)6n zgWAyQRkYve|??6P^mHtLBAfl91a8)U-9}9uHzg?iI1^dpp7nr zc20i8vVg(u6uIPr!W+1qT2P1@uLBq=B0Y{gEu8RcE^pxFkmT`dp2iyZ7cY_%^pEZ} z{NBR$^pw>iLz!(;nta&knDvkl2ijj> z(S(AF?_ECtr}w>0!FIu=9`nLc;4yr{xinymxzz84&{s(KPtw5mM?TOIb(jMqmjz5S z22r4_^t0Lu6o9Q!ts~zFLkEW%H;pYt(rc^1w{RsIuFD8i{k<41iZyGL*TjILENVqP z=C;oLsFwgM95IiEu7|;`Lks~c37Hd76_ZCJZ{&DAi;ml0Z*SbSSG>ZtbO2X_f(p2a zunnb+MqLH|?Gv3$^lw6Dw!-1>p!SyeZ^LmqU}|5#kpV3R9! zr=@m4cY13F^qsb9GWEH`)z}t;>O#x3%<1g>vuUW~iLqxqH=cf&y!$vYp6MZVdTUVf z{^)q}^<;K@em29EC3*_3jkUfF@oskX<@D3p12>GZV%fw03w86zF!o=o8ywmH JWjy}*`wzu?bHe}t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/other/SINGLE-VALUE.TEST b/internal/test/LANGUAGE/from-sun/language/other/SINGLE-VALUE.TEST new file mode 100644 index 00000000..de104fcd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/SINGLE-VALUE.TEST @@ -0,0 +1 @@ +(DO-TEST "AR 8409 - IL:MKATOM shouldn't return multiple values" (NULL (CDR (MULTIPLE-VALUE-LIST (IL:MKATOM "FOO"))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST b/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST new file mode 100644 index 00000000..b6f0d1bc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: SMALLP ;; ;; Source: IRM, p 9.1 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 11, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>SmallP.test ;; ;; (do-test "test simple cases" (and (eq 5 (il:smallp 5)) (eq -4 (il:smallp -4)) (eq nil (il:smallp 'a-smallp)) (eq nil (il:smallp "a string")) )) (do-test "Test go on own function" (flet ((temp-small nil 2) (temp-large nil -3) ) (test-defun temp-fun nil 32) (and (eq 2 (il:smallp (temp-small))) (equal -3 (il:smallp (temp-large))) (equal 32 (il:smallp (temp-fun))) ))) (do-test "Test large and floating aren't small numbers" (and (eq nil (il:smallp 100000)) (eq nil (il:smallp 32.4)) (eq nil (il:smallp 32e6)) )) (do-test "Test work against system functions" (and (eq 3 (il:smallp (third '(1 2 3 4 5)))) (equal 3 (il:smallp (car '(3 2.2 1.1)))) (equal 2 (il:smallp (second '(1 2 4.5 6)))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:smallp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:smallp 'A-couple-dashs)) (eq nil (il:smallp 'Numbers-1234567890)) (eq nil (il:smallp 'il:other-packags)) (eq nil (il:smallp 'il:other-packagsNumbers-1234567890)) (eq nil (il:smallp 'il:other-packagsA-couple-dashs)) (eq nil (il:smallp T)) (eq nil (il:smallp nil)) (eq nil (il:smallp ())) (eq nil (il:smallp '())) (eq nil (il:smallp (list))) (eq nil (il:smallp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-string nil "string")) (test-defun temp-fun nil 'litatom) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:smallp (tee))) (eq nil (il:smallp (nill))) (eq nil (il:smallp (temp-litatom))) (eq nil (il:smallp (temp-string))) (eq nil (il:smallp (temp-fun))) (eq nil (il:smallp temp-litatom)) ))) (do-test "Stop stop on system functions" (and (eq nil (il:smallp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:smallp (second '(#\. #\k)))) )) (do-test "Test arrays aren't small numbers" (and (eq nil (il:smallp (make-array '(2 2)))) (eq nil (il:smallp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:smallp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:smallp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:smallp (make-array 50 :initial-element 0))) (eq nil (il:smallp (make-array 20 :element-type 'string-char :initial-element #\0))) )) (do-test "Test other datatypes aren't small numbers" (and (eq nil (il:smallp #\backspace)) ; character (eq nil (il:smallp #\*)) ; character (eq nil (il:smallp #\.)) ; character (eq nil (il:smallp (make-hash-table))) ; hash table (eq nil (il:smallp (car (list-all-packages)))) ; packages (eq nil (il:smallp (pathname nil))) ; pathname (eq nil (il:smallp *random-state*)) ; ramdom state (eq nil (il:smallp #'cons)) ; compiled function (eq nil (il:smallp (copy-readtable))) ; readtable (eq nil (il:smallp #*1001)) ; simple-bit-vector (eq nil (il:smallp "twine")) ; simple-string (eq nil (il:smallp (make-synonym-stream nil))) ; stream (eq nil (il:smallp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST b/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST new file mode 100644 index 00000000..5df26ea7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST @@ -0,0 +1 @@ +(xcl-test:do-test "simple lexical binding" (= 3 (let ((a 3)) a))) (xcl-test:do-test-group "simple special binding" :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (special a)) b)) (defun goo () (declare (special a )) a)) (xcl-test:do-test "special 1" (let ((a 3)) (declare (special a)) (eq (goo) 3))) (xcl-test:do-test "special reference in let value form" (let ((a 'outer)) (declare (special a )) (eq (goo2) 'outer)))) ;; now try with specvars for references. (xcl-test:do-test-group "using il:specvars in declare for bindings." :before (progn (defun goo2 () (let ((a 3)(b a)) (declare (il:specvars a)) b)) (defun goo () (declare (il:specvars a )) a)) (xcl-test:do-test "special 1" (let ((a 3)) (declare (il:specvars a)) (eq (goo) 3))) (xcl-test:do-test "special reference in let value form" (let ((a 'outer)) (declare (il:specvars a )) (eq (goo2) 'outer)))) ;; from AR's (xcl-test:do-test "#' finding lexical functions AR 5995" (equal '(2) (flet ((bar (n) (1+ n))) (mapcar #'bar '(1))))) (xcl-test:do-test "THROW vs. closures AR 6092" (let ((this-one t)) (catch 'foo (let ((closure #'(lambda () (throw 'foo this-one)))) (funcall closure) (values nil) ) ) )) (xcl-test:do-test "Interpreted &ALLOW-OTHER-KEYS AR 6122" (eq ((lambda (&key key &allow-other-keys) 'ok)) 'ok) ) (xcl-test:do-test "Interpreter: invalid keywords ar 6123" (xcl-test:expect-errors (error) ((lambda (&key foo) 'foo) :bar 'bar)) ) (xcl-test:do-test "value of eval-when 6252" (equal 3 (eval-when(eval) 3))) (xcl-test:do-test "simple special in let* ar 6369" (eq t (let* (x) (declare (special x)) t))) (xcl-test:do-test "shadowing flets ar 6734" (eq 4 (flet ((foo () 3)) (flet ((foo () 4)) (foo))))) (xcl-test:do-test "interaction of FLET and MACROLET AR 7127" (= 17 (macrolet ((foo (x) `(bar ,x))) (flet ((bar (y) (+ 1 y))) (foo 16))))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/STACK.TEST b/internal/test/LANGUAGE/from-sun/language/other/STACK.TEST new file mode 100644 index 00000000..dc46be39 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/STACK.TEST @@ -0,0 +1 @@ +;; This is a collection of tests from the Stack.NoteFile. It tests Chapter 11 of the IRM. A few functions are tested minimally. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Stack.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Stack>Stack.test (do-test "EQP stack pointers" (defun foo nil (il:eqp (il:stkpos 'foo) (il:stkpos 'foo))) (foo)) (do-test-group ("STKPOS") (do-test "simple STKPOS" (defun foo nil (il:stkpos 'foo)) (eql 'foo (il:stkname (foo)))) (do-test "(STKPOS 'STKPOS) error" (expect-errors (error) (il:stkpos 'il:stkpos)))) (do-test-group ("RETFROM") (do-test "simple RETROM" (defun foo nil (il:retfrom 'foo "hello")) (string-equal "hello" (foo)))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST b/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST new file mode 100644 index 00000000..9a653eff --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: All of chapter 4 of the IRM ;; ;; Source: IRM, p 4.1 ;; ;; Chapter 4: Strings ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>Strings.test ;; ;; (do-test "test strequal" (and (eq T (il:strequal "ABC" "ABC")) (eq nil (il:strequal "ABC" "def")) )) (do-test "test string-equal" (and (eq T (il:string-equal "ABC" "ABC")) (eq nil (il:string-equal "ABC" "def")) (eq T (il:string-equal "ABC" 'abc)) (eq T (il:string-equal "ABC" "AbC")) )) (do-test "test allocstring" (let* ((tempx "old string")) (and (equal "AAAAA" (il:allocstring 5 'a)) (equal "CCCCCCCCCC" (il:allocstring 10 'C)) (equal "****" (il:allocstring 4 '*)) (equal "...." (il:allocstring 4 '.)) (equal "HHH" (il:allocstring 3 'h tempx)) (equal "HHH" tempx) ))) (do-test "test mkstring" (and (equal "ABC" (il:mkstring "ABC")) (equal "(A B C)" (il:mkstring '(a b c))) (equal "NIL" (il:mkstring nil)) )) (do-test "test nchars" (and (equal 3 (il:nchars 'ABC)) (equal 5 (il:nchars "ABC" T)) )) (do-test "test substring" (and (equal "DEF" (il:substring "ABCDEFG" 4 6)) (equal "C" (il:substring "ABCDEFG" 3 3)) (equal "CDEFG" (il:substring "ABCDEFG" 3 nil)) (equal "DEF" (il:substring "ABCDEFG" 4 -2)) (equal NIL (il:substring "ABCDEFG" 6 4)) (equal NIL (il:substring "ABCDEFG" 4 9)) (equal "B C" (il:substring '(a b c) 4 6)) )) (do-test "test gnc" (let* ((tempx "abcdefg")) (and (equal "a" (il:mkstring (il:gnc tempx))) (equal "bcdefg" tempx) (equal "b" (il:mkstring (il:gnc tempx))) (equal "cdefg" tempx) ))) (do-test "test glc" (let* ((tempx "abcdefg")) (and (equal "g" (il:mkstring (il:glc tempx))) (equal "abcdef" tempx) (equal "f" (il:mkstring (il:glc tempx))) (equal "abcde" tempx) ))) (do-test "test concat" (and (equal "abcDEF" (il:concat "abc" "DEF")) (equal "abcDEFGHI" (il:concat "abc" 'DEF "GHI")) (equal "(A B C)ABC" (il:concat '(a b c) "ABC")) )) (do-test "test concatlist" (and (equal "AB(C D)EF" (il:concatlist '(A B (C D) "EF"))) )) (do-test "test rplstring" (and (equal "ABCEND" (il:rplstring "ABCDEF" -3 "END")) (equal "ABC(A B C)K" (il:rplstring "ABCDEFGHIJK" 4 '(A B C))) )) (do-test "test rplcharcode" (and (equal "ABFDEF" (il:rplcharcode "ABCDEF" 3 (il:charcode F))) (equal "ABCDXF" (il:rplcharcode "ABCDEF" -2 (il:charcode X))) )) (do-test "test strpos" (and (eq 4 (il:strpos "ABC" "XYZABCDEF")) (eq NIL (il:strpos "ABC" "XYZABCDEF" 5)) (eq 10 (il:strpos "ABC" "XYZABCDEFABC" 5)) (eq 4 (il:strpos "A&C&" "XYZABCDEF" NIL '&)) (eq NIL (il:strpos "DEF&" "XYZABCDEF" NIL '&)) (eq NIL (il:strpos "ABC" "XYZABCDEF" NIL NIL T)) (eq 4 (il:strpos "ABC" "XYZABCDEF" 4 NIL T)) (eq 7 (il:strpos "ABC" "XYZABCDEFABC" NIL NIL NIL T)) (eq 2 (il:strpos "A" "A" NIL NIL NIL T)) )) (do-test "test strposl" (and (eq 4 (il:strposl '(A B C) "XYZBCD")) (eq 5 (il:strposl '(A B C) "XYZBCD" 5)) (eq 4 (il:strposl '(A B C) "ABCDEF" nil T)) (eq 3 (il:strposl '(A B C D) "XYZBCD" nil T T)) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS b/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS new file mode 100644 index 00000000..3fe235ca --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS @@ -0,0 +1 @@ +(and (string-equal "abc" "ABC") (not (string-equal "abc" "abcd")) (eql 3(string= "abc" "abc")) (not (string= "abc" "ABC")) (not (string= "abc" "abcd")) (not (string= "abcd" "abc")) (eql 0 (string< "abc" "bbc")) (eql 1 (string< "abc" "adc")) (eql 3 (string< "abc" "abcd")) (not (string< "bbc" "abc")) (not (string< "abcd" "abc")) (eql 0 (string/= "abc" "def")) (eql 3 (string/= "abc" "abcd")) (eql 3 (string/= "abcd" "abc")) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRINGP.TEST b/internal/test/LANGUAGE/from-sun/language/other/STRINGP.TEST new file mode 100644 index 00000000..b73de165 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/STRINGP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: StringP ;; ;; Source: IRM, p 9.2 ;; ;; Chapter 9: Conditionals And Iterative Statements ;; Section 1: Data Type Predicates ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>StringP.test ;; ;; (do-test "test simple cases" (and (equal "a string" (il:stringp "a string")) (equal "Try 12321*& ()" (il:stringp "Try 12321*& ()")) (eq nil (il:stringp -5)) (eq nil (il:stringp 1000000)) (eq nil (il:stringp 'a-floatp)) )) (do-test "Test lists of various things" (and (equal "ABCDEFGHIJKLM" (il:stringp "ABCDEFGHIJKLM")) (equal "NOPQRSTUVWXYZ" (il:stringp "NOPQRSTUVWXYZ")) (equal "abcdefghijklm" (il:stringp "abcdefghijklm")) (equal "nopqrstuvwxyz" (il:stringp "nopqrstuvwxyz")) (equal "1234567890" (il:stringp "1234567890")) (equal "!@#$%^&*()" (il:stringp "!@#$%^&*()")) (equal "-=[];'`,./" (il:stringp "-=[];'`,./")) (equal "_+{}:\"~<>?" (il:stringp "_+{}:\"~<>?")) )) (do-test "Test go on own function" (flet ((temp-small nil "abcdefghijklm") ) (test-defun temp-fun nil "-=[];'`,./") (and (equal "abcdefghijklm" (il:stringp (temp-small))) (equal "-=[];'`,./" (il:stringp (temp-fun))) ))) (do-test "Test work against system functions" (and (equal "A rat in the" (il:stringp (concatenate 'string "A rat" " in the"))) (equal "LITATOM" (il:stringp (il:mkstring 'litatom))) )) (do-test "Try various types of Litatoms" (and (eq nil (il:stringp 'ABCDEFGHIJKLMNOPQRSTUVWXYZ)) (eq nil (il:stringp 'A-couple-dashs)) (eq nil (il:stringp 'Numbers-1234567890)) (eq nil (il:stringp 'il:other-packags)) (eq nil (il:stringp 'il:other-packagsNumbers-1234567890)) (eq nil (il:stringp 'il:other-packagsA-couple-dashs)) (eq nil (il:stringp T)) (eq nil (il:stringp nil)) (eq nil (il:stringp ())) (eq nil (il:stringp '())) (eq nil (il:stringp (list))) (eq nil (il:stringp (eq 1 2))) )) (do-test "Test stop on own function" (flet ((tee nil t) (nill nil nil) (temp-litatom nil 'litatom) (temp-number nil 1234)) (test-defun temp-fun nil 45.65) (test-setq temp-litatom 'il:temp-pointed) (and (eq nil (il:stringp (tee))) (eq nil (il:stringp (nill))) (eq nil (il:stringp (temp-litatom))) (eq nil (il:stringp (temp-number))) (eq nil (il:stringp (temp-fun))) (eq nil (il:stringp temp-litatom)) ))) (do-test "Stop on non-strings from system functions" (and (eq nil (il:stringp (car '(#*1001 '#( 5 4 3 2 1))))) (eq nil (il:stringp (second '(#\. #\k)))) )) (do-test "Test arrays aren't strings" (and (eq nil (il:stringp (make-array '(2 2)))) (eq nil (il:stringp (make-array '(6 6 6) :element-type '(or integer string)))) (eq nil (il:stringp (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (eq nil (il:stringp (make-array '(5 5) :displaced-to (make-array '(6 6 6) :element-type '(or integer string))))) (eq nil (il:stringp (make-array 50 :initial-element 0))) )) (do-test "Test other datatypes aren't strings" (and (eq nil (il:stringp #\backspace)) ; character (eq nil (il:stringp #\*)) ; character (eq nil (il:stringp #\.)) ; character (eq nil (il:stringp (make-hash-table))) ; hash table (eq nil (il:stringp (car (list-all-packages)))) ; packages (eq nil (il:stringp (pathname nil))) ; pathname (eq nil (il:stringp *random-state*)) ; ramdom state (eq nil (il:stringp #'cons)) ; compiled function (eq nil (il:stringp (copy-readtable))) ; readtable (eq nil (il:stringp #*1001)) ; simple-bit-vector (eq nil (il:stringp (make-synonym-stream nil))) ; stream (eq nil (il:stringp '#( 5 4 3 2 1))) ; vector )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST b/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST new file mode 100644 index 00000000..26dee76e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST @@ -0,0 +1 @@ +;; AR 7993 test ;; Filed as {ERIS}TEST>CMLSTRING>AR7993.TEST ;; By Peter Reidy ;; Verify that CLtL's string comparison functions work on single characters as well as strings. (do-test AR7993 (and (string= #\a #\a) (string-equal #\a #\A) (string< #\a #\b) (string> #\8 #\5) (string<= #\a #\b) (string<= #\b #\b) (string>= #\8 #\5) (string>= #\linefeed #\linefeed) (string/= #\a #\A) (string-lessp #\a #\B) (string-not-lessp #\B #\a) (string-greaterp #\B #\a) (string-not-greaterp #\a #\B) (string-not-equal #\a #\B) ) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRUCTURE-PRINT-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/STRUCTURE-PRINT-REGRESSION.TEST new file mode 100644 index 00000000..0db29bdc --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/STRUCTURE-PRINT-REGRESSION.TEST @@ -0,0 +1 @@ +;; This tests for both AR 7437 (circle labels go to *standard-output*) ;; and 7438 (some circular structures don't get printed at all). (do-test-group (structure-print :before (defstruct graph nodes)) (do-test "structures circle-print" (let ((xcl:*print-structure* t)) (declare (special xcl:*print-structure*)) (string= (write-to-string (let ((foo (make-graph))) (setf (graph-nodes foo) foo)) :circle t) "#1=#S(GRAPH NODES #1#)")))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST new file mode 100644 index 00000000..94e71cfd --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST @@ -0,0 +1 @@ +(do-test "timeall OK" (AND (EQL (IL:timeall (car '(1 2))) 1) (EQL (IL:timeall (car '(1 2)) 10) 1) )) (DO-TEST "time OK" (AND (EQL (time (car '(1 2))) 1) (EQL (time (car '(1 2)) :repeat 10) 1) (multiple-value-bind (a b) (time (values 1 2)) (and (eql a 1) (eql b 2))) (multiple-value-bind (a b) (time (values 1 2) :repeat 10) (and (eql a 1) (eql b 2))) )) (do-test "AR 7648 - encode-universal-time" (and (= (encode-universal-time 1 0 0 1 1 1900 0) 1) (= (encode-universal-time 1 0 0 1 1 1976 0) 2398291201) (= (encode-universal-time 0 0 0 1 1 3000 0) 34712668800))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/TYPENAME.TEST b/internal/test/LANGUAGE/from-sun/language/other/TYPENAME.TEST new file mode 100644 index 00000000..d027cb78 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/TYPENAME.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TypeName ;; ;; Source: IRM, p 8.20 ;; ;; Chapter 8: Record Package ;; Section 9: Built-In and User DataTypes ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>TypeName.test ;; ;; (do-test "test simple cases" (and (eq 'il:smallp (il:typename 5)) (eq 'il:stringp (il:typename "a string")) (eq 'il:litatom (il:typename 'a-litatom)) (eq 'il:floatp (il:typename 4.5)) )) (do-test "Test go on own function" (flet ((temp-small1 nil 12) (temp-small2 nil 'bv) (temp-small3 nil "hi") ) (test-defun temp-fun1 nil 34) (test-defun temp-fun2 nil 'QW) (test-defun temp-fun3 nil "bye") (and (eq 'il:smallp (il:typename (temp-small1))) (eq 'il:litatom (il:typename (temp-small2))) (eq 'il:stringp (il:typename (temp-small3))) (eq 'il:smallp (il:typename (temp-fun1))) (eq 'il:litatom (il:typename (temp-fun2))) (eq 'il:stringp (il:typename (temp-fun3))) ))) (do-test "Test work against system functions" (and (eq 'il:smallp (il:typename (+ 1 2))) (eq 'il:litatom (il:typename (car '(a b d)))) (eq 'il:stringp (il:typename (concatenate 'string "a" "b"))) (eq 'il:listp (il:typename (append '(a) '(b)))) )) (do-test "Test a bunch of data types..." (and (eq 'il:twod-array (il:typename (make-array '(2 2)))) (eq 'il:character (il:typename #\backspace)) (eq 'il:character (il:typename #\*)) (eq 'il:character (il:typename #\.)) (eq 'il:harrayp (il:typename (make-hash-table))) (eq 'package (il:typename (car (list-all-packages)))) (eq 'pathname (il:typename (pathname nil))) (eq 'random-state (il:typename *random-state*)) (eq 'il:compiled-closure (il:typename #'cons)) (eq 'readtablep (il:typename (copy-readtable))) (eq 'il:oned-array (il:typename #*1001)) (eq 'stream (il:typename (make-synonym-stream nil))) (eq 'il:oned-array (il:typename '#( 5 4 3 2 1))) )) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST b/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST new file mode 100644 index 00000000..4230910d --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: TypeNameP ;; ;; Source: IRM, p 8.20 ;; ;; Chapter 8: Record Package ;; Section 9: Built-In and User DataTypes ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DataTypes>TypeNameP.test ;; ;; (do-test "test simple cases" (and (il:typenamep 5 'il:smallp) (il:typenamep "a string" 'il:stringp) (il:typenamep 'a-litatom 'il:litatom) (il:typenamep 4.5 'il:floatp) )) (do-test "Test go on own function" (flet ((temp-small1 nil 12) (temp-small2 nil 'bv) (temp-small3 nil "hi") ) (test-defun temp-fun1 nil 34) (test-defun temp-fun2 nil 'QW) (test-defun temp-fun3 nil "bye") (and (il:typenamep (temp-small1) 'il:smallp) (il:typenamep (temp-small2) 'il:litatom) (il:typenamep (temp-small3) 'il:stringp) (il:typenamep (temp-fun1) 'il:smallp) (il:typenamep (temp-fun2) 'il:litatom) (il:typenamep (temp-fun3) 'il:stringp) ))) (do-test "Test work against system functions" (and (il:typenamep (+ 1 2) 'il:smallp) (il:typenamep (car '(a b d)) 'il:litatom) (il:typenamep (concatenate 'string "a" "b") 'il:stringp) (il:typenamep (append '(a) '(b)) 'il:listp) )) (do-test "Test a bunch of data types..." (and (il:typenamep (make-array '(2 2)) 'il:twod-array) (il:typenamep #\backspace 'il:character) (il:typenamep #\* 'il:character) (il:typenamep #\. 'il:character) (il:typenamep (make-hash-table) 'il:harrayp) (il:typenamep (car (list-all-packages)) 'package) (il:typenamep (pathname nil) 'pathname) (il:typenamep *random-state* 'random-state) (il:typenamep #'cons 'il:compiled-closure) (il:typenamep (copy-readtable) 'readtablep) (il:typenamep #*1001 'il:oned-array) (il:typenamep (make-synonym-stream nil) 'stream) (il:typenamep '#( 5 4 3 2 1) 'il:oned-array) )) (do-test "Test fails correctly" (flet ((temp-small nil 12)) (test-defun temp-fun nil '(a b c)) (and (eq nil (il:typenamep 54 'stringp)) (eq nil (il:typenamep '(a b d) 'package)) (eq nil (il:typenamep (temp-small) 'stringp)) (eq nil (il:typenamep (temp-fun) 'package)) (eq nil (il:typenamep (car '(a b d)) 'smallp)) (eq nil (il:typenamep (concatenate 'string "a" "b") 'listp)) ))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST b/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST new file mode 100644 index 00000000..ef59059a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST @@ -0,0 +1 @@ +(DO-TEST "USER DEFINED RECORD TYPES -SET UP" (SETQ IL::CLISPRECORDTYPES (CONS 'IL:TESTRECORD IL::CLISPRECORDTYPES)) (IL:MOVD 'IL:RECORD 'IL:TESTRECORD) (IL:DEFINEQ (TESTRECORDMANIP(DECL) `(IL:RECORD ,@(CDR DECL)))) (IL:PUTPROP 'IL:TESTRECORD 'IL:USERRECORDTYPE 'TESTRECORDMANIP)) (DO-TEST "USER DEFINED RECORD TYPES - CREATION" (IL:TESTRECORD FOO (A B C)) (SETQ FOO1 (IL:CREATE FOO B IL:_ 2)) (IL:REPLACE (FOO A) IL:OF FOO1 IL:WITH 1) (AND (EQ (IL:FETCH (FOO B) IL:OF FOO1) 2) (EQ (IL:FETCH (FOO A) IL:OF FOO1) 1))) (DO-TEST "USER DEFINED RECORDS - CLEANUP" (SETQ IL::CLISPRECORDTYPES (CDR IL::CLISPRECORDTYPES))) (DO-TEST "SUBRECORDS" (IL:RECORD FOO ( X Y Z)) (IL:RECORD BAR (L M FOO) (IL:SUBRECORD FOO)) (SETQ BAR1 (IL:CREATE BAR X IL:_ 5)) (IL:REPLACE (BAR M) IL:OF BAR1 IL:WITH 2) (AND (EQ (IL:FETCH (BAR X) IL:OF BAR1) 5) (EQ (IL:FETCH (BAR M) IL:OF BAR1) 2))) (DO-TEST "RECURSIVE RECORDS" (IL:RECORD FOOBAR (FOO BAR)(IL:RECORD FOO (A B C)) (IL:RECORD BAR (D E F))) (SETQ FOOBAR1 (IL:CREATE FOOBAR A IL:_ 1)) (IL:REPLACE (FOOBAR D) IL:OF FOOBAR1 IL:WITH 5) (AND (EQ (IL:FETCH (FOOBAR A) IL:OF FOOBAR1) 1) (EQ (IL:FETCH (FOOBAR D) IL:OF FOOBAR1) 5))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/VECTOR.TEST b/internal/test/LANGUAGE/from-sun/language/other/VECTOR.TEST new file mode 100644 index 00000000..2b5f93ec --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/VECTOR.TEST @@ -0,0 +1 @@ +; AR 7864 (do-test-group ("AR 7864 - `#(,@foo)" :before (test-setq foo (make-list (* call-arguments-limit 2)))) (do-test "Long backquoted vector: splicing" (eval (read-from-string "`#(,@foo)")))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/WRAPPERS-AR7900.TEST b/internal/test/LANGUAGE/from-sun/language/other/WRAPPERS-AR7900.TEST new file mode 100644 index 00000000..03b3dc4e --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/WRAPPERS-AR7900.TEST @@ -0,0 +1 @@ +;;; Regression test for AR 7900: TRACE shouldn't allow you to trace IL:GETSTREAM (do-test "AR 7900" (member 'il:getstream il:unsafe.to.modify.fns) ) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST new file mode 100644 index 00000000..e024eb2a --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST @@ -0,0 +1 @@ +(do-test "WRITEFILE closes its file once" (il:writefile '((plus 2 3)(times 4 5)) '{dsk}foofile)) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/XCL-COMPILER-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/XCL-COMPILER-REGRESSION.TEST new file mode 100644 index 00000000..87367d66 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/XCL-COMPILER-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the XCL Compiler (do-test "AR 8246: Compiling yields TYPE-MISMATCH error" (and (setf (symbol-function '#1=#:foo) '(lambda () (let ((l nil)) (do ((i 0 (1+ i))) ((= i 4) (nreverse l)) (push (let ((j i)) #'(lambda () j)) l))))) (compile '#1#) (equal '(0 1 2 3) (mapcar #'funcall (#1#))))) (do-test "AR 8346: Compiler doesn't make use of DEFMACRO's on the file" (progn (with-open-file (s "{Core}AR8346.lisp;1" :direction :output :if-exists :supersede) (princ ";; (progn (defmacro #1=#:foo (x) `(1+ ,x)) (defun #2=#:bar (y) (#1# y)) (#2# 1))" s)) (compile-file "{Core}AR8346.lisp;1") (load "{Core}AR8346.dfasl") t)) (do-test "AR 7043: (MULTIPLE-VALUE-BIND (A B) (LET ...) ...) loses the extra values when compiled" (let* ((fn '(lambda (x y) (multiple-value-bind (a b) (let ((*foo* t)) (declare (special *foo*)) (floor x y)) (list a b)))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (equal '(2 1) (funcall compiled-fn 5 2))))) (do-test "AR 8352: Peephole optimizer sometimes doesn't eliminate degenerate jumps" (let ((fn '(lambda (x) (tagbody x (let ((a (foo))) (when x (foo #'(lambda () a)))))))) (compiled-function-p (compile nil fn)))) (do-test "AR 7458: COMPILE-FILE should return the DFASL name, not T" (progn (with-open-file (s "{Core}AR7458.lisp;1" :direction :output :if-exists :supersede) (princ ";; (defun foo (x) x)" s)) (let ((result (compile-file "{Core}AR7458.lisp;1"))) (and (pathnamep result) (equalp "{CORE}AR7458.dfasl;" (namestring result)))))) (do-test "AR 8353: Compiler bombs on (CDR (CONS ...))" (let* ((fn '(lambda (x y) (cdr (cons x y)))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (eq 'a (funcall compiled-fn 'b 'a))))) (do-test "AR 7831: Compiler doesn't observe NOTINLINE declarations" (let* ((fn '(lambda (x) (declare (notinline car)) (car x))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (member 'car (first (il:calls compiled-fn)))))) (do-test "AR 8429: Side-effects data for IL:MACHINETYPE are wrong" (equal '(:none . :any) (get 'il:machinetype 'compiler::side-effects-data))) (do-test "AR 8390: Optimizer for EQL does not transform to EQ for EQL tests of Fixnum's" (let* ((fn '(lambda (x) (declare (notinline eq)) (eql 7 x))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (member 'eq (first (il:calls compiled-fn)))))) (do-test "AR 7981: New compiler loses binding specials to NIL in non-return context" (let* ((fn '(lambda () (tagbody loop (let (*foo*) (declare (special *foo*)) (go loop))))) (compiled-fn (compile nil fn))) (compiled-function-p compiled-fn))) (do-test "AR 7798: SPECIAL declarations are scoped incorrectly by the interpreter and compiler" (let* ((fn '(lambda (x) (declare (special x)) (let ((x 2)) (let ((x x)) (declare (special x)) x)))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (= 1 (funcall fn 1)) (= 1 (funcall compiled-fn 1))))) (do-test "AR 7803: SPECIAL scopes improperly - Lucid L226, L227" (let* ((fn1 '(lambda (foo) (declare (special foo)) (let ((foo 3)) (list foo (let ((foo foo)) (declare (special foo)) foo))))) (compiled-fn1 (compile nil fn1)) (fn2 '(lambda () (let ((y 1)) (declare (special y)) (let ((y 7)) ((lambda (y) (let ((y y)) (declare (special y)) (list y))) y))))) (compiled-fn2 (compile nil fn2))) (and (compiled-function-p compiled-fn1) (equal '(3 5) (funcall fn1 5)) (equal '(3 5) (funcall compiled-fn1 5)) (compiled-function-p compiled-fn2) (equal '(1) (funcall fn2)) (equal '(1) (funcall compiled-fn2))))) (do-test "AR 8043: Compiler should keep multiple values from constant-folding in return context" (let* ((fn '(lambda (x) (when x (floor 5 2)))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (equal '(2 1) (multiple-value-list (funcall compiled-fn 1)))))) (do-test "AR 7463: Compiler can't find global defconstants with values that are lists" (progn (defconstant #1=#:foo '(1 2 3)) (zerop (length (with-output-to-string (*error-output*) (let* ((fn '(lambda (x) (+ x (second #1#)))) (compiled-fn (compile nil fn))) (unless (and (compiled-function-p compiled-fn) (= 3 (funcall compiled-fn 1))) (error "ack")))))))) (do-test "AR 7625: Hairy uses of non-local return-froms compile incorrectly" (let* ((fn '(lambda (f) (block one (funcall f nil #'(lambda nil (return-from one 1))) (block two (block three (funcall f t #'(lambda () (return-from three 3)))) (block four (funcall f nil #'(lambda () (return-from four 4)))))))) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (progn (funcall compiled-fn #'(lambda (flag fn) (when flag (funcall fn)))) t)))) (do-test "AR 8584: Compiler breaks on non-local returns to effect-context blocks" (let* ((fn '(lambda (f) (block foo (funcall f #'(lambda () (return-from foo 7)))) t)) (compiled-fn (compile nil fn))) (and (compiled-function-p compiled-fn) (funcall compiled-fn 'funcall)))) (do-test "AR 7974: Compiler doesn't remove FOO.LISP from NOTCOMPILEDFILES" (push 'il:AR7974.lisp il:notcompiledfiles) (with-open-file (s "{core}AR7974.lisp" :direction :output) (princ ";; (defun foo (x) x)" s)) (compile-file "{core}AR7974.lisp") (not (member 'il:AR7974.lisp il:notcompiledfiles))) (do-test "AR 7507: SETF macroexpands too early sometimes" (with-open-file (s "{Core}AR7507.lisp" :direction :output :if-exists :supersede) (princ ";; (defvar *foo* nil) (defmacro foo7507 (x) `(frob ,x 'foo)) (defsetf foo7507 set-foo7507) (defun set-foo7507 (x y) (push (cons x y) *foo*) y) (defun bar (x) (setf (foo7507 x) 7) (macrolet ((bar (x) `(foo7507 ,x)) (baz (x) `(bar ,x)) (foo7507 (x) `(car ,x))) (setf (baz x) 8) (setf (foo7507 x) 9)))" s)) (compile-file "{Core}AR7507.lisp") t) (do-test "AR 8602: Compiler reorders PROCLAIMs with respect to package-creating forms" (with-open-file (s "{Core}AR8602" :direction :output) (format s "(DEFINE-FILE-INFO ~AREADTABLE \"XCL\" ~APACKAGE (DEFPACKAGE \"PKG FOR TESTING AR 8602\")) (proclaim '(special foo)) il:stop~%" (int-char #o36) (int-char #o36))) (compile-file "{Core}AR8602") (delete-package "PKG FOR TESTING AR 8602") (load "{Core}AR8602.dfasl") (let* ((pkg (find-package "PKG FOR TESTING AR 8602")) (symbol (find-symbol "FOO" pkg))) (and pkg symbol (il:variable-globally-special-p symbol)))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/XCLC-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/XCLC-REGRESSION.TEST new file mode 100644 index 00000000..e2a4c7af --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/XCLC-REGRESSION.TEST @@ -0,0 +1 @@ +;; Regression tests for the new compiler ;; This tests not only the break-free compilation of the function, but also that ;; the cleanup forms are evaluated in the correct order wrt the body. (do-test "AR 7335: Compiler errors on WITH-OPEN-FILE in effect context" (let* ((test-fn '(lambda (name) (let (x) (when name (with-open-file (s name :direction :output :if-exists :new-version) (setq x (il:openp s)))) x))) (compiler-result (compile nil test-fn))) (and (compiled-function-p compiler-result) (funcall compiler-result "{Core}Foo")))) (do-test "AR 7338: Eliminated :CONS function without arguments breaks compiler" (let* ((test-fn '(lambda (x) (let ((a (gensym))) (list x)))) (compiler-result (compile nil test-fn))) (and (compiled-function-p compiler-result) (equal '(1) (funcall test-fn 1))))) (do-test "AR 7339: Substitution into final statement of PROGN breaks compiler" (let* ((test-fn '(lambda (x) (let* ((a x) (b a)) (setq x 7) (list b)))) (compiler-result (compile nil test-fn))) (and (compiled-function-p compiler-result) (equal '(1) (funcall test-fn 1))))) (do-test "AR 7519: Compiler breaks on nested CATCHes" (let* ((test-fn '(lambda (f g) (catch 'one (catch 'two (let ((y (funcall f))) (funcall g #'(lambda nil (case y (one (throw 'one (list y))) (two (throw 'two (list (list y)))) (t y))))))))) (compiler-result (compile nil test-fn))) (and (compiled-function-p compiler-result) (equal 'zero (funcall test-fn #'(lambda () 'zero) 'funcall)) (equal '(one) (funcall test-fn #'(lambda () 'one) 'funcall)) (equal '((two)) (funcall test-fn #'(lambda () 'two) 'funcall))))) ;;; This test is pretty hard to do. It wants to see if the :FILE-MANAGER-FORMAT keyword ;;; is recognized by the compiler. The only way to do that is to see if it works. We make ;;; a file that should, in the course of its compilation, push 1, 2 and 3 onto a list, ONLY ;;; if the file is being interpreted as a normal Common Lisp file. We compile it saying ;;; ":file-manager-format nil" so as to override the compiler's normal inclination to treat ;;; files beginning with an open paren as File Manager files. If we get the list we expect ;;; at the end, it must have recognized our use of the new keyword. (do-test "AR 7378: Compiler documentation says :FILE-MANAGER-FORMAT ..." (progn (with-open-file (s "{Core}AR7378.lisp" :direction :output) (princ "(eval-when (compile) (push 1 *foo*)) (defun foo () (eval-when (compile) (push 2 *foo*)) 5) (eval-when (compile) (push 3 *foo*))" s)) (let ((user::*foo* nil)) (declare (special user::*foo*)) (compile-file "{Core}AR7378.lisp" :file-manager-format nil) (equal user::*foo* '(3 2 1))))) ;; There was a bug in the fix to AR 7341 that caused the tagbody below not to notice that ;; any substitutions had taken place within the progn. This led to a break. (do-test "Test for bug in fix to AR 7341: Compiler runs forever by reordering uselessly" (let* ((test-fn '(lambda (y) (let* ((a y) (b a)) (tagbody tag (progn (setq y b) nil)))))) (compiled-function-p (compile nil test-fn)))) (do-test "AR 7621: COMPILE returns non-compiled code sometimes" (let* ((test-fn '(lambda () (foo #'(lambda (&optional a (b (bar a))) (list a b)))))) (compiled-function-p (compile nil test-fn)))) (do-test "AR 7754: In compiled hard-entry functions, closed-over required args are lost" (let* ((test-fn '(lambda (a b &rest c) (catch 1 (catch 2 (list a b c))))) (compiled-fn (compile nil test-fn))) (and (compiled-function-p compiled-fn) (equal '(1 2 (3 4 5 6)) (funcall compiled-fn 1 2 3 4 5 6))))) (do-test "AR 8016: Compiler shouldn't substitute side-effects into IF's" (let* ((test-fn '(lambda (x y) (let* ((a (pop x)) (b (if y x a))) b))) (compiled-fn (compile nil test-fn))) (and (compiled-function-p compiled-fn) (equal '(2 3) (funcall compiled-fn '(1 2 3) t)) (equal 1 (funcall compiled-fn '(1 2 3) nil))))) ;; This qualifies as a hairy test. We want to see if the right set of type-fixups ;; is being generated by the assembler. Thus, we (temporarily) redefine the function ;; D-ASSEM:INTERN-DCODE to squirrel away the type-fixups list for us. (do-test "AR 8167: Assembler allocates too little storage sometimes" (let* ((test-fn '(lambda (a b) (foo #'(lambda () (+ (incf a) (incf b)))) (loop (let (c d) (foo #'(lambda () (+ (incf c) (incf d)))))))) (intern-dcode-fn (symbol-function 'd-assem:intern-dcode)) (type-fixups :foo)) ;; Redefine D-ASSEM:INTERN-DCODE for a moment, just long enough to compile ;; the test function. (unwind-protect (progn (setf (symbol-function 'd-assem:intern-dcode) #'(lambda (dcode) (when (eq :foo type-fixups) (setq type-fixups (d-assem::dcode-type-fixups dcode))) (funcall intern-dcode-fn dcode))) (compile nil test-fn)) ;;Well, that's done, so restore the old definition. (setf (symbol-function 'd-assem:intern-dcode) intern-dcode-fn)) ;; Now we can check that the right set of types are being used. (null (set-exclusive-or '(il:compiled-closure il:\\ptrhunk2 il:\\ptrhunk4) (mapcar #'cadr type-fixups))))) ;; NOTE: This test fails by running forever, so it should probably be the last ;; one in this file. (do-test "AR 7341: Compiler runs forever by reordering uselessly" (let* ((test-fn '(lambda (y) (let* ((a (funcall y)) b c) (setq b #'(lambda (x) (+ x a))) (setq c 10) (funcall b c)))) (compiler-result (compile nil test-fn))) (and (compiled-function-p compiler-result) (= 17 (funcall test-fn #'(lambda () 7)))))) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/ZZZ-25-3-DRIBBLE.TEST b/internal/test/LANGUAGE/from-sun/language/other/ZZZ-25-3-DRIBBLE.TEST new file mode 100644 index 00000000..6729c282 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/other/ZZZ-25-3-DRIBBLE.TEST @@ -0,0 +1 @@ +;; Function To Be Tested: dribble ;; ;; Source: CLTL Chapter 25:Miscellaneous Features ;; Section: 25.3 Debugging Tools ;; Page: 443 ;; ;; Created By: John Park ;; ;; Creation Date: Sep 10, 1986 ;; ;; Last Update: October 9, 1986, Herb Jellinek, Dec 15, 86, John PARK ;; ;; Filed As: {ERIS}CML>TEST>25-3-dribble.test ;; ;; ;; Syntax: (dribble &optional pathname) ;; ;; Function Description: (dribble pathname) rebinds *standard-input* and *standard- ;; output*, and/or takes other appropriate action, so as to send a record of the ;; input/output interaction to a file named by pathname. (dribble) terminates the ;; recording of input and output and closes the dribble file. ;; ;; Argument(s): pathname (optional) ;; ;; Returns: NIL when opened and the name of dribble file when it's closed. ;; ;; Constraints/Limitations: Due to differences in filenaming convention among ;; various operating systems, only xerox implementation is tested. For other ;; systems, use appropriate filenames for the test. ;; ;;;; Watch out for implementation-dependent filenames below ;; (do-test-group ("dribble-test-setup" :before (progn (defun file-exists? (file) "Is the dribble file created?" (cond ((probe-file file) t) (t nil))) (defun delete-if-exists (file) "Delete if dribble file exists" (cond ((probe-file file) (delete-file file)) (t t))) ) :after (progn ; just in case the file is not dribbled during test (dribble) ) ) (do-test "dribble-test" (if (string-equal (lisp-implementation-type) "xerox") (progn (and (not (dribble (pathname "{core}test-dribble"))) (print "some output") (dribble) (file-exists? "{core}test-dribble") (delete-if-exists "{core}test-dribble") ) ) (fboundp 'dribble)) ; Is it defined if not the xerox implementation? ) ) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET-PROPERTIES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET-PROPERTIES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bc20495e3de51adf1145e183d62b64d257080754 GIT binary patch literal 2281 zcma)8U5pb|6uvVp?RNicD-o!GlZD-o;xsHGfdw?Pvv=EJXJ^X%P&OeU%kC^~QfSk5 ziG)B1F=|W`TsGod5RJqK6MX>U3yRq&55{PGFeWCN_+X-M5~7JlU)FQxmZiI5B%S2m z?>j&DyXT%e(>b#0kg7{+<#@GJ_G(gPwo#pJNHdk1RIkj|raWl|cGwao-Cr>>s4epkdYOPd;$*x@h2Zx^BKD1*;rgK!Wb)M}JV|Hdb z7q4Ct;uS*36j{I_Mo655h<~vePdn6hwg< zC%rOm=Xjk6g!r#DJ4RhYbu`oP=Y?}Zw|}A8qZx7@wx(n$5j$F0FuUM4A0ON%56W5U z$a%}mQ_In)O|D*wohL->PQ*nN^>Oj`m~iU^`S6o5v9LOo5F*C{r8n2Zxb%SZVk!ks zYJcjZCeRoP5KyqeqRWJ{;mbzf%(xD}FUf>_We+`D#z{0byeE9h@m z_=RRs1`D^WIMNuduVFgJ3%ES1Zl@%$(LQ)iqsjqH2OYRqo*GJpIZrC0?P`{Q= zaOejypNe0!DHnwYyATC1-#b@q|2=Y9*YL7pwzj%L!u=_z+d?spjq`eQeOfh*5e>Ub z&MC%-PAz#@1IEbOX)(fL;wos}L|RoGH78rtaV=;)HR#=lJz+a^Tol1$HE(WJr;6d` ziO)N|Z3*%+kj7=YbL}7YR(E$j50f?YF#Xa)ln6j@?}{Un%{@&MGuc3MD>W@L%qwd9nx>J6b^5)CvkX{59d%tmKyfN zII?HhdK^x2V~Gzg541R<5V6WpG(C@=`?zh0+hn!@$$n1uaWcu#V*w(62Z;R1(a#+H z#L?FreaX=~Yz-tMZ?UyFTwv>FaGy|pe489%8#5rJ8*~qwx(qdS=?2`(u<05jc?^LQ z2c_VgHBi(Kh=RjH^bNetA_i7JIE*`N6SCK#&|&JR85T!4#}YV%ffa@Wiri)WK#}i| zQaJS)8$jv`9@6rv%UR2G^W5u2)_0n1Dzi;Tz%QmNM%IOQrp@AqS;9u)IyJIRF3%Es z0riY4W3CbGWh+Z;LForv)1mz=(FY)GQ|Ca6C9pukZ}6r)<~8JMty1-BjgnWF8eYAD zrn`RgDF^0K-&v(knwf;p(X>=L!M`NPoyFY<@A~t2b0Rr9Y|#RX!#rx|6+^RgybwOL zFx!HzFM%uDg3bl1WpfU<*N}Y%SSYuqQcijh6vY_$T3~uX4KfQO+`QkP?_dM0pY3A1 z(F##GjPfDNht~Q#F+ccWwv9L+V0&=h<6*D2UN88q5 zd)QvKk39!G`8|jWJv0#QKL%@nd8~G--hgj7B%Ur+tJPB(G=KjeX+Qs;v>*6acqulj z7F8T7uej5?=1@z~Z3g=i*;dwvi@o7DGeg4^-V~I7i-SKHc*6Wt?;qz`yLG^sqy9X$ qY!n&_UI|b_0C2~l*9{hD+t_C9A^M-^OD4jBMy9tEkjoQ`i~j(W1Bn&@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8190a18ddd2ec93b1977daf674496fa39514b5e7 GIT binary patch literal 3451 zcmd5Ec{eI8!x%N5M_JEO6jpbv<%a!7ay1Z69zE)Egmsix)<+YVUQC$RH zeax_I^W-7jm>a(*vCRo+3M<9=T5&;j*NUqP^WVQqO?*SukFS&~usCo4U}Ey_y_5U* zk8hjNofJj;GCunzC-#kRySo0O6j^4B71#!f4#px(VgC7gB<`AytIZ@+rk2suX52sL z*V~~N&2voKuSfT)wdLblrFf!P!FG3c*?M;}qh+Br zeb!`h`(_l3F2Oo6p(V6g(`D-~MjmG@^s{J0#!4=g-kFo$s!AWdJ16I3v8WVY66H09 zKwf)6y`@+TUa`Zmx9dQoD?mX1SLPMDpl(z`g^`U)TVZqqYAX!j|M%olFZ=Hc&{iUy zOlWaE*jndDpzjtewU+tO>ohoxma>V;??AlmkKb^!RC?>-o(-!9;FWW!XRV$O7&}+` zk<~LNOWm-%IG7(oC(ySu)&;ec3p+Pnm;Z_6<_5{nG&iUn%-)kfMC;oc-wA-q;FU%y zfYE!habOEG8ekfI0e}ur&*@V0?@KpuGc|w#0v!a(SB9JAcLWliFJ07Hu+j}PZ0sl( z#u~ll7M&jh`U;lx6_)eIW;xxE2wr7OU8FS*cc^hB2xbESivBvl<`w|F{dzbUfPtlG z;j3&S^nSC6&ip{LoIpa@N+|9TVBm#&fj!O>q#kVm(pN9zp&lSa+M*WZKLmr%i`P{CXtug$FA26pa1`XeMi0 zS;WJ9CkW*;5+7q8Gw10kR4Nzw4ivBQAr$L;7)3;w%AX3I{1>5oGq1ZN4kT zN5}cDVLn;{I^=^@8_a7qgJ=bj*nUK1cw&b$xG`d%9^|(ndoS-rF+!rBL|6#ra~=hq z@-ISvCGiQ7zZaD&mkIrj(0M+F4rfGYLSr0OyrM5o${|l zf$|$9UV-E=J2?0vqx@45Kt9Xwgy8ZSLO&q%D53i(&fOGXj0Aql+MTSKO2JW~P@8EL zeiww2J{Qi?-)QeYAw=_(E{g)C-$INq4M0SYeog%QT*C;L$me;m>VPAx&DxenbCOPq zlBAlbMJkebfD(HYY{`%LKA zr$qjl(1&mgyVLrdml5X|8engVv&7!O1Df+JR~+#Mk*@(6a!faehOZEJf$u>?o4}sp z6Nr9DSx)oB_juoT`JM-Pf1Xdcyg$biN#6fWzUNLJy`4|&=Ft(Ji1Fwkc!kdR_1?AB zqIRrUt(BLn>Qb?$){3h&)II6fZ*gI*j-1j*)Wv!DzP_NAtMpYHxl_B*Y|yWFpD0(C zYFeROeFPZg$`GOcJaG_4jH{2IIC$fZcX9RdmWa|>zdk-WWx{=L(oX~Ndk5pv44cC{Z;o{!kG_MNkwhBBD@<=iHk#No&QT><;Ii z$M>Cc&%Jwgj*!q+-Bk36-FwH2`I0g*Ro**QR>meu%H+gUX(X?Vfn9lAr?&BAM$-p6 zHzaDEMV^sTez=?;RotokN$q(R~nN_ zd19|x%XP=3r}Dzd_{cITmD>{7Oxt zTTQ6_hMOj*PShPFB-qp#m9dn!3g-r-vwNh$w+G~*wpgPS-bKg-xzIvp7B663lFKpJB8j@VDeBWE+OirVo~JE^*v=-1rx6*D)1O>PxKI|Du2II%fwk#i)y-1j zEZ}Ga)JsRqLp1U(Ax8?&(a3--HNbNE)}a-+FYs3rQV(4iA5msrliy$5z;EXpScleP zu;a{nz6f<3Ell6VmtkBgL+!xRQ4GwUX@Ldqn(J~$F?8ub;XvVES9Oc13aJ;Bh3ed) z%Dd-ls^8NQT}TEBG-LLRQcNxwi%GCuf^8!KR`h>X5^S8Wq!y^fckVo}0lfRC_yK?q z9n;H15Zn$pSXf_>X>|ThijG|exQYjh5CH`P(lpJ`D6lkL%K`x%*I`o^vCSXV4YK|N z`?|kjzkw`(zVsh&3s7u|!S8aW5G8W0f4tHb*QvEJi<3poXx2v4u+>x+ELOi0m+M)L zTnA4Wo)C<$#<;GzdPcPk*Rx^#=zM;Koo$Y549YS@w1@$xn}%k2IWcG-H7{vO$q% zSsRLvd7$(W50uXHK&ej{*9+qsZX~m;6#(QHA--d+WuU8fwhgAJslu*3V+8k{qMo%e zcRy>jSZj*4_ORCN01H-uF9g-~Tc8ELMvZqJwa?(+Cv0J_cU7#VK%B({$R&Q0j_+<7^drUJ&A0WOHrL8W7$m z1^h7qe@Fy9D8zOl9JU$>G(@IM_+J#r`vhdY23iPTB+zQ*+$g7b4z)a3&PqRfP=@-@o+|uhjh4c#NmQD&$ zL3mozU1~c5{tQ^E-3;{{7$?H?1nWeC9`H2a4OjbZ>g9xQxnOM(bRjOtWxgr$2k#vD zjdzaxEW}U3_ya!{@{JH*3FDXi5|BeI3HiuDxW^5H+JI;AYySvq-h(%LvqxRyVb)v# zCFmIL<_B1_#}YP6W?5&NB{#4{FYD@JooiXwN|ubVu4Z5h{O(tpOZkzh(&YHQys|4_ z9#hKs$uhcr^((izuvXglYwgO|FuZ$?D&u>^Ya`nBn|{FDAM9Fi+^+t6G?y=ttO zS=X>N(_wWG#@2}wh0)eHnjagUDwdZdm2<2YNn`%8Fi?gJ%gVwDVDo_%61Z@BOa(pc zxSp<4?h6lUwws0PhLDtp% z8PezyZO0PLxR$)zuXOgM3>d+Nc+KVS?$}S!!};dzcjnrO7l<(bSdgt|Ygk;|k7q== X&08Uz9Kz3i5P>qdG$na)%k1o5x3Xp0 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d48beabb7a87971e65e417866442fd40f9a95ae5 GIT binary patch literal 2372 zcmcImQEwDg6uvXlmTkLTw!2H9n~FoRQCDWMP!cQ>GM!G_Wq0Q;GqXY?NrUZ_S#5VW z+g*jAq@oFlP6D-o%$4wf(ZmN$+LEX!x)L7@zrbJMlP|oRfal!VLO~yh#&nx=&$;J* z-#O>rd+scg_7hr8)+!6t(!5iXD~)=!QJ3c`HF>epsLeR?9N6V^8a4IzCRHt)J~Y&2 zZJL>>Ij8E*tZX-&#o1G5_sB!9$ZEA#nuo!`gP;zL9N0H9Je=+tSFK!t_B3nuj~v*a z?s{ zdFO3s9@AM^BmyD+WiK>dG&DOy4Sz*g62kr^uP0+D1xQVu(1{pop&+{8d!0isD?^H@ z=f}zQt34M8k;=VM5kvXGy`2?qmC4;7v*Pg`$zGx3G>>n+ALPRy1nef0@Jk*|e(!-9 zmx2l!PitorYFnvOJS1k`)Wxl1(i3n9zy zMHi9GO>kav^5sVX ztBTn!yC1bUm))h(l8b*&y_egAy~MI^+RRNmDJ^X5WH+$5Wnm85ph zJ1zAe3Z8-5O6v+u2rh2(zb*I8|C|?ucr=N}$Bh!P+rQ%Vr!;DeW$@N2ld3V6(@kYG z0~TY#N{J!XDR#hrJG6z~l&0F+B-~iLXu`GDcwgwSrYu{}iz0X=g2ticbk!&plyPe2 ztrQbP;qR+$nqu8jm~~2B&?X`&-88AG(4t)^+9@dl3&JVYm{PbML8Pr<>#!$HT^)Pa zkFb;YUUcY*eiUvagtcK4+J!5UCWU7to2@Fjunx<}S>Ud1Rxk;Ey zJgSbST6z!<>&EFQAhq-OKoh@1TuWC?Z4%Wlp|o2dmx4(PsDHq=qgY})P*hnTiawSE zA>0VWi(HUzxF@;EJ;~>+?;Ptdv;H?&e;O#l)>M9!<`l@Ls6T_8qqJy@7197C&0s{p zIANf6nBz&q(3m?6Oql0C$Yi9x&#S4LRyM<8X!x1!La`Qz8-Z{*gm^MolMlop7Dvxv zKxiK|;m8C4N?_i?h42R(04L$sK>G=NLr`(u%&0l;E_@rzTnfY@W|Gs52^*^?(7-y* zcB6JA(6)0y{^UmTTcE81au2>C%7jUa1&&QvP|3?YUh+PZ&tSF%-7uys7HhD98jF|M zb8{>{jT0KRZECRCNw#~6#S1L{Dn!$hSF=Tf7xyI=e*r6dtVnHrki`c;X|r_uSdzuJ zLVyySL8ay_%*i#U-l&xq<#MI0l;NE&&B-Nv@f+n?x$Zi0wN|M*wfb3HRPeoLZD+AA z51dyA^w)2DN7WTbebaobA+w$qU`w&5%FTql9$J}xA#jo+aJSp5oMC%VY-0)t;d&qjxgd8q z1Kay(J^9M_(j%ifTr55KB;emU2o~hGk=S{wm1;WUd+qgiN@eFr026O}9F=@}_`!p} E02o53RsaA1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMPROP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMPROP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..99dfb0ce94aa146da3079dda7894e38630127e32 GIT binary patch literal 2151 zcmbtWT}&KR6uvXd&+@Zm=~7#^h$9WOSv#~#Y0{#p8HUTUWp`$oA8=z*+boN-cDswq zqQRzwRAYk~Qz@~|)%3wW>PyRm30fufC(*Z!6zU3#*2yZ1<#qgw9vjZF$_8P zJ3rq&=iGa^tdRPb)Rd%_FU}T<`HEDYug=a_rI~U?nk&y&a(QV6^wK3&H|XUtMIG;d zKHhBZu;eQF^VR&cWXaN$Wwuf%!s6sffbpRd14Dy@{mr9_nc{3u5;Hgy zhnTIKH-vDR5RxMsD4GZflK}CqyWyBcO-mk4rl_nbX&UoZJU0ln$hJuh&ut%&s^wX^ zn13T*#Bwgq5rGiz12;HoYpRvhHE&f|5?Z}$ZYZhA87NIjP$C9vEXXc+ZfpFQ9G4B6 z&KP=z+`JLGLWnrs9u_g1ubjK%!g`7P@%6Yk)e&tM8ea8NTJ){Z1O&IyJD)YjU@59%43Q)lA?w@oCJ-QFk@nnHHi)ITMzTl9#a)d z9fPZC*#_Ka)gOokGizEjEsEgL!6!ydQAM*e@~Cd4%@`9z;qhookFl0Oh&2UTU_RPn z)G%~I)@>_eTd_bZ1hmE!Ei3zaBndQwuEm<7nw5o_oTLw?5$DKr!|_L^F;qtgtHTlO z#ECi!+tkrXC52!DKm(?ySO_)DPqhsL$REx-6VP@VY#k3vC9EKk&5z*|46Hp>CT#jT;Q>wl+D%Xw|!^fQ!d_x zm>|tkRZr=LA0;fX2>QJamd2zuNez>7Lx~%5Xh2=dds%74Tu5FHK8TCoiE>zEWL)6vR=_ea6bqRi&OqrAL}M4^Qs2R4DP+5_OAy zN4IcZut$G-pLnY{)7`2;6^qJ`j6f=BQA0_YtOeZI5q|K$z-zXhTopD$qMzAOY{9QS uAB#WqCf|5&|IjdnF{J$Y^#3QoIG*Hoc8g{$-~JbQbfj)K8Tt71*4BTIWn(`8 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-SYMBOL-PLIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-SYMBOL-PLIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2a4f746c571d9c477848e57387a1ffabc9a8f79a GIT binary patch literal 3305 zcmds3Z){uD6~FgAJBjnhwS#L~lhT(!OKbWv(mAE1leU+am)Onod+vMBO)?3hlDM!hJfT0c&+{B-U)=l;&Wd+)h-l?11CQ_(9Ys-<#aQK>A~s>?Oycx6#psw^+g6_n#3 zS5E1+WBf9$>63$phC1C%nz_Zov07nX@s;j2#FAx_~+`8q-VIEI-W5N)zY#?(qHxK z9gvHfcMZp{NB1kWN>wcveqJbJIwzJ0CB*-2y<0ZXR{585lyZtBYJsC^QL2BBB zL8OkB6|_#l%+Ouxkm}B4M{QHhnHkq3=bzqkhLAu{G$LV0my2&q($^N~l{Y7)sewe4 zw*8F9d8rTR#vcMNCKB*Z98SDm2Qfl{1@3=pdT}n<=zwzX=H8m00)hWekrspR$2 za{ETYsOk(70>;FjmY@bxgA2V()B;Lz-EVGB1K?MrVvJlHl->YY@0s>nXz{h#aKjD* z`}wN*q#b^nkk#U&c6d^vJutkmed=~}3VLwZO-Q3Ox4Ussnn7V}k)*rV7pa4Lx=PL! zFT`OwgtS_G0tQ#4t1w!*aj!QEujpix+f6>@J?lP0544UKk!Oduhl3*f_Fz zYt+tLW5C`F79&a5gG@DNOwCwm)2~N{u4}syI29~_y>>5l%>cjx26zBQ{sx#fOic5T z{SrJx^}OR4)~3eJDC#~2UF=$cb>9ZV3>jF7~Qyr+K&5`?o?Z|0f8gDiPsUV2*{4^8pA#qu` zs7Zn*tlPO6*h<=%r;VB%a0iIDWVJ~H_M)3sH{`d2yobv*$I)iM0{IX`?GQC=JdBfE z2EMy>qk;&drz_cd)Z!-^$)VWJ6Qh#5X((~;MSY4koy2RzNe6T7w+6P z3m2KM`4zSgr59No$)X^4!|DddVcQwFb)(aUV^6EPoz22of~@(vrNq=-oJgOrI{`2K zm0OeE733|p6@?EAGR}U0oG!Q&C-fVRqn~jA6>!=RIv=9w-F(%n6ONtFu?U!<4-4Q! z0$38{J{}Cs3w$4B8p&AD0yGn%hk{xjU!(0%5P39%o1DgBQnz6mS={8_OpaIgDonst zX&o<^M_%PN$;(*FBYE57^DYVDOCSumhIa%fz93}JuoQBS^N7eJY#6y;32ucQc!?yr>9YPqyjQ!$c6t|13;WOdYuM3l)nSWz z29~DPC;2fpGoImK%jtq?Y*;L8^ZFR7i`|sJIPxKMlp)@c{Bevm5P7dBeA;c5U=RYL zJN>nGcyGd+6WbS!`1N4z7o~*)GTr`TaNycow91daY!&{*KRt4N+HHk;0W} zi>0_+nyr`SBxkj>GBIpJgKb~5k+kH%aX z7L9iyHA-t*+>LIGK2;yp`g`hPpX0?M$Cheghtp|b&@3nM z#J}`?AO4d|I8&@pqxE9Qe77Sg)p0OR8 z4~4)()H&7^7pkDT;Iac#LrX!!a1ogiI~V zv=q~I3a%rEyTH9mR*e}Y&}05^C+ONR1xw=0J~8?o?S!y4ocDt`y5B?6Haey12<`%i zAWzjn*g&G1YgyE2xm-*@+YPXZyM5ABn{o;)hUNw2YUlC=xRJJFLF?W?^*pF!Ef)xN zQ|x&ZChI|w<>*b0j&szW-p=k4Cdj95x&Dj6gnQ_eC2G3B@v!vM^FrLV_|4a_zVIf_N3(u3~{edgH6aMOgzuT4}n%Z zuTHo|P~+Q7oW^1%UDKfs6DI+*+0>cLG4UkpJIYe8F!=~e^|GUBmP#PmTQGeq=N8V? zs?y@@LP@HZR_ds~>3fG9SWCTYYOgdu3*VGEsj|pF2dG;MYOVM?>@W!4;z2ubt?jWK z0}D<&TH?E2WUFQUXxE4Q;(zU5!Tb4wW>M9l$`ezp=NxLOy3JzX#$?{PP2bB5k5IT9 nlz%{iuOe2&tJtBxW^WgiS>(~;DK1lO!M1E@J1P0<)YjHN|H%(r literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-COPY-SYMBOL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-COPY-SYMBOL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..72776bb33e88c55eccba76f0a2ed983fe3fd6328 GIT binary patch literal 2398 zcmb_eUu;uV7(e%JE!(=4u2vaku3SLpwYxcer;ya|KB(=OynJ>Cksk~UPEY_vDa#gC87pr+!nghFZTs2JX&3%eG9e-x5 z$7=KBt8T9D&Pw*8Tbs=-Jt2)fEh&}id=VCV_JBGzv3uvl_;|c0p;#%7c0W10C&qTh zdv0AiFNDg3kUVLk=q4mYI*50s5sKNGWy^_VN|SXZt;M_*uh9j2ksV7jy+;2|sa~$g zMfWwgh}&7H5rGizbfYWb=&GGGbnmQiLg@8QHTsgeoPn(=QyLMwS}2Gvc#Y85lkzTE zH8L}@HItq+QsmP4z)3>HH~K>&GWxu5by~Pm682x47PAjU`vw0oMssx#330Wz;V+5x~ z0Sc^K-kgoLsCE(33nl0CgUyeHI2zZx_v?E1x_E(X1V};l>Nx030eM~ghOe=Y=zK6c zaH(ZK3)m+L{O`V*ZQ{(3NE@{_UgGQPyt<)IaXS>vM^<++LfL_})zMaU5Tn@$^262I z1web11qIjs7fOJ-KMEab7D7bq_Rcj1W2&L=P2y`T?^E=>Db188lVH)OteDtEyG1|z z`(RG`W2$1S`(#tI9TVPjl?{sDnz3vxEs78k;gh7MG(~qZa>6jvR*VXw@b7Hfh|xet zA2_-p%$~u)yFGU}F&zQg-O&qvAM?{tM-L2GFs7NNVakSMXB<1$5rlx=n4-_f%#PJ? z((W19J|7{p6Q}fH9Jnd~b!rEd6e=z#eq^fHs2)YCs$-g(-gYHW0evR;B6qr_Dwf8} zQZ~nr0MbT2+Vc9%fN5K47=-XQ-Gt%~hzhjb0%-f54xsp!Zbs3hQ52_n+6g$Lo)PV! zX2QJzhmz9JxdbR15|f6b@6DjTfV;S(=0Ocw$#e#;G|M(2?KzA(g0))=vEgWYiDFNL zr#OXiPGN*mAb-(8@R462t+$m1U2`yx+@wP&z5;p?OS2QLORat9?mtQ(93?<96yXy6p(SZh#Zcm_{Z}hquxp8IVNWrVngWI%-q&Q54U^ zRqWUC1lfV^ppT(-6C9S`I^Za#Mnh=mp)nMG-qtlPK4lQXM=VFU$i=(dSE2ooAQYfx zr|zT>TsXvCW9%)tbCt_err~5*9U;mg`#F}#1o@NYk>3ETFRe^FIy);sBtNk#syhL6*5k%nh! z_%MxSX;`P>XQ})+4R5FM5gHz*JEAlkgjn%qudyXxt}My5rG=yAqQusfYPnLA>Ta!$ zA&0%jkPT~Tcv%^i=5p|TpOxlI{L_rKty}*9+7O)V literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENSYM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENSYM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a1fd9e104c66ccc5121f50e89f226996bce0fd2c GIT binary patch literal 4870 zcmd5AYiv{J^*$WP)8s_}H^3z3J47` zrVW){xeK)Hez2^QCUp|pgE1AsN*7Jrejv44rLA2jZBwW1$EvMTCaUd6r)B4S#}0w8 z7ODJLSi=P_^IVS3J3i$#llZE4iuS5R12(HK*rQ$}Gdak5+K-Jxic`E&*r+qVPSJFwL~(BJQ>^=c76 zS$hU)_n^ZH#b4CW!nJ5UNAXr~FtG%&+C+Z6Ztc&6qvEF*YZ14rt5TvFJ>4H>U zwu070%dG3|QTx;(JrFrCD$HD3c~%gre$~_{VKA?yZjXq!vQpdYBT~G}(IhTA!Xv!i z4shWIA*UP;_&N4CeqsU{RRIO;|4N)!xrbLd*-gMTn`waXlkVAaq+WuD?6X1pg`oW_ zgnkoMVc8%Ev)4Lc0l#vRgnWDnP!v_~Db^7NYL8sXYC$;mn`HlN`ZkzpKD&Iqn7YNo z1axlN|3c9Ib3vF+oeSDWBoVw#Ut1I3T#g%b>%n6>>74zM{5}#ZJA1scv(+F2;Y_E_ zJi3EbGMzq?dW_a*D%R`b-B6o& z52XObh2P`zW9zK=sgJv1OH+p&(0vz!_G@ckd8mCh*nT0{etu#e+{5qfxvz;_LIT-q z?=Fr5^c9Vgw!jL~oxk3m>EWA*$dyd*!um|= z{-S@nAgZ=if@sXR<1TEbN&uVUu6R$}1t?JfmXBrv{#Cc$UFa1yiZX>CvK|VKuBrV_}#o9zK?qMGi!w`luv< zL@UiLk6+gUv5@KwhDRe#CQ9N`?P$=+>f{zyBe%kovOD!~I2cxgv1lk3b;>J2q28$l z4yc@tM&vf2EenNpuW$dtIK)9FuR`GfB&d6d&6?%aC_LyJ@p-kTSc+^LWIIN-pCpkk5?M=_gRn-zY6+7$ zkpIlB$nSA0@>|@Be3?ti-yrZg64_58!z8kS$0@Jlamr8dIOWx3vjxjcMS^&xyIfzI z78l-GT;->8O{&h<8JO4u%j-z$tEu=uver=!uO&pJ{lQkrM$< zD{#DO*+k_Eh|FHFvf?51)j+S}M+>ED0kcO!y2q#a`Jq+Or|=&nk7}N9P+eqG_$QE; zdly0zJ^;LCR2$J%zb}I4L3oXIBDl)B5SXm<6ze+3I{mE6#X8rrt`Q(t{Q}ggLgC;L zW>IwmI+ zH#kouN8-1LcMhu10L6<1ctKI_IkpNx0qe6j7L4+Cm?Yu^5N)v8dr`t5+Ot4gxc4JH zPHp8U@C>l)y!X3s5$h?|hw>ZPlL*$8ZF><}NfHel2p3>@rC{&svc9Rg(NNVP{zX3D$Cqxu0dNan=`Qt$SI&kF`F{+)uH#&8)AJ zwRNz52W#sF<*MtJsSapfcw5s45C4iQ8ik_Laa!w8(pmcYIvr8Q6YxVrmZFyF$mWVEzA58ahf0)_iF^@tLtIz-Xo;@$cgt)~aGfD#VhXy4 zhd?=&wWYt3_RLc4l4Y(OGsY8BnPPe4m1HWBSFp#V^Q5+GshZ0&o2gw2%2XDE&1a1< z)Nyhh@sCS%#5C`KrIL3xmsJy#I@!8SY@;1s5_T;-#D{F~!e5piKj9B0ETQm@b+Mt;Q|c|bOMRvO o($>^@|o0yKxdio3<-2?n~m<@pJ5F+@hh*bzWj8jvZ`g zEvu*sj6sJN7TR_10^LAEAZ-&Zk%rm<$`7=mO>7!cnbsd{u(3~}tx_lL15MdE_tbMHO(&Iq;x{-Es7O-!aUMqbWM6(^^P@<=W(7jjeiq#=(0 zT|Va5BI*MJihsX%r>{1;s3(~>5=CQJ)~AfZaN_ESx>#d`J+g)-*LrXw9ps*Y=ASv(nqI@0a3R zT}`5Wl$$ua7U04UY)-jc@N?~ReYXT;6a^Hp|08xD#C9IUq?bU)T&4k>liWU6&E1yl zsx-Ri%AV;Xc*rrQIiA!Uj}ZC{DuZT&Ak3ZL01fz+ol3~RcR8}6=rzGQ!a!{He>h_L zHLzgiLsjd=)I~l+K(EXMpU@m{2*OP2QO&Vm62Z`!^K0Vn@|3|-^ZV>Aul|ky_+rj6lLr%!7Q<~%aI%pnp&1tSDHP`gSJPZ%NcdpK)PNW|fIhO?d z=Pxa`1!SF-m^sTab5>&ZvF^0KSFy!Glf7}OZJ(;BUJ>shD0-X8CO0pUmaF}s%Iv(48h&WY3wwc*XmyjOxx z$1g!vWQM^AXuw zs2J2t200cC!nD?$*9>xkL5}MTa{LQ}{(~ri{rg+O<1RO0?2Ka-j5{iXAeOhEN>Sm%OE|=CdH>uo}xMIP@KEH4@Px z9xbMaW4hbY3Ig?RC3Mik>8QlA8ff-#MC}V4Sg0nyP1HC ztw&-#+kimgMB4{k&h|c+v%SsbY%jnNj%Z*o4E0@9k3jD11`*pgfLuqo2dFr_?O9Gc zIM}NNc`1lAw6LmNwjq9+-HPB#Y$Jj%vP}pcWt$Ovp87sRX533=43Zfexf!Ip948c! zNu-%=L9CHu)(^P?>+iV&>t(LM`Z8y+zCdEzDRt&J{|>xI!tz6-s_s`%O_*_w3dDu|Y^f1-AfXzXN(&pr_9h zC0ABzaO}jSUa_1m{vGHxz8HZ^{1XpESoH^#AYbO5Fp}Rx@}T06Xr4tn#h(GWs;^gz zh4yl`x7lsT{RVR*c#hqU;4#*Q-~r}AkY!#3BWxRjdqF`xW_{&mfW&)%XosW%V-eL^ zJAxtRL$Dt@`8x3g15sR&;u_RZo*1mzn2N+|)UjZg@CVijRN*q~LhveK-z2QWI*+lg zds%0Yb$MCmI@Wavn5rD0!4{5a{pecz@AxF_zkr*KJ%pP9?hW>zuxI@OKhXdR9 zInnkyVJ{KrCE^ak+#Fbc%!$_T5%vm!Ng|FCc7VVtBGz-v@(%(hIni>0u=@yXBH~Si zk$^-dNo0~lCP_zOX3oU(AUgQ-h9_)a5v39N_i zx;}_!EW~|}9F5dfi|!nXX*z~SvhdW91Rz>5VSy(8g)@pD5_p%uI|P2nwj;}%d|`^O z5je+oAn|L2J5V4Ogbz!n(1VTr9`D{DciW>VEi7+Q`-4q=y# z(}cgWU4RL{Wz7ga;QYe-g#Dc17ApLdupbcT1-1%_-yzOf!p;%ri-bKzoF^GxeuXa( z=fi}ZV7rep=Q!JS4{MFH9-XxgvE2dIx{K|)ovq%=dN#Aw8`y3aTa5{BpEpZek8I24 zvYugMBr%mK%9D9xBz?3^E{vxq<*5R^BowAbfMOJo|0A<>i*6K(@`mHe26-d_ZxO?C zI!n(8NIQ-@xcve1Y4a4812_94s-ml&>(06$p0`Rc%IbiP_3#9;XU)>4BilZi9b;?{ zjAQ$dkHhY|rp5NIS@O{wG}LvO zRHl}zJZP5IR-Q;;u7yb>nI1{Q#3w;ZV$?wC7)iU#k`1XHK(qdNnJVkA&C;rLwrJ$D zqja?v)3FmjF>`N9%mxnSHk zWq?<9%D#5Fm{0QvTeosemUGKAS)MgZu57NDN@qvq#0ZSdEdagXhkOyNuslPu`F6LUQ3R!v%Z8VVX35*rt3q+6(%Tb% zP%ADZawUV0N6R^lM~}3}ECCSy*l%QwJUpt&30Mosq){lOb6GhzA{XwTIGoEAu!%2P z<+Zb|>~3#uO^w`}C_tnNn0T;A^00Esy=`(PJ&^{K`m$3Khw-^@L{5We6Ga%Iz!m5q zSQg=amXD+}89ATGj)KB`ZURynMu1dCczZH8g<0Y8aaq+n>Xo-nB*u-RF)>+yIJaZ0 zHxAuKT1G1q8^Rus3}6SJx$lg)aqPl?GCz}QgzH4_T?3ckLIIa4_>VV>f$>Wh&i@iz z#F`;0nZ(55;RIMIUtcc63!jCT%jPMIS+e#*oeK*j7#Ixbtl5g^u^lQ(EuyzVvyLC{ zbUtGZQU{v`TsPDZe2svw2t(EB^XOW+{uFC~Si7Vo6$FgiCfW|LvX$)D+TvBSv?ZJ| z&|ky3?3NWE{QOt#74ahvj?-LP)uZp6ZzqaU^&ZpaWr>E zRE&xFtEY{OboId6t5{}32uT|^;hqL`m*ZNgLh-)wF9FB-EhSz zUunA8rcSnb8_?}^b8xd;w=i(I@Sp?E42Kfw=jCeUN(3Dkk68*OUV_Bai`oyeBS`9n z$Kk$2CIj2k5m>Bwq`|f$;?^K`nWq}2+oyfg9n+oDUDJ0=cTe9ry?vUO1#Z&S0(`

Sm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-KEYWORDP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-KEYWORDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..10a0b2428607a41ab818395ff09bc2d73e2034dc GIT binary patch literal 1780 zcmb_d&2Jl35P!S*vXj`dDI~3xq)(9|%9gcAo1!*=V6%BiTsyn&eh_k@TAWR6)v+Uc z($K&Vh;B#v<7zyXOP=l%gmVP-c@-EtrYq}`pJc{9KH z&Fs9l`=sX$wLsPS`bMSdHfVj*+t~EzYP~_5_02}frK@14JF0H5w-*#OpM7bv-|Sc^ zHC)GYSE#k=HdmbO=jr4ns%$hWRd~605!A`)3+JY%rn3EWidl%zjuZ3Z^wjxm|H0kc zLaI&(DUlY6I3X$0MS>6glw>i}lIL;-CTq$flY;%gk3lW6Z89V9)90vH-;k^Bb+?M; ztT%~3NO04S&Dol2<#a8$CA=#P1~>dfPLqpJnljIb7&}BkbRqEjCtr}y%XzlEq#LtE za`*PY9wEZF>6D0cekec43-@az_%Sao4Q0|o?^?+5>k*Jg7mzMzGH_)sXTJBrjG>@{ zwlq>2X;mJ8?Ww)K6GHj^)nrRgg8Fd3a6?c2Ovrxu13j4+g#^5Qd1~n-#=?4xkU>IP zl~Shll`z`LXW zNnQOAFeoY7vK-nGq$>%2ap`b2rNB>3J~7k--GuONoa7TYmtTN?H+x+vpzEGrFzK7Q>vM zgWgj#^mz@Fy@y)ZHPm)sllN*^ci4t1A4BU3So<{HT7VCY`kVYTig7-Q;#B06h=d4u zeTRD|L?FZn6-CEtZkyd#m19p_L}BcuiX0s?qCCb<;(U zj|2a-@Gy|UZ3(G90`%~=bnT;ON0Nq>c@_;Zhd$nSxFwxbBAwoRMc z>u=SowCOnwuTop1TNSTN9a^ea>or9AEdsmwIM`0$XQyWv3^R+)^6&@c9o641eAhf| SMfTN*M!NfPAo9ud!NEUb8UR}W literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-MAKE-SYMBOL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-MAKE-SYMBOL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..425dc7d41a4a683df4250f9b5e8d84333b77bf4f GIT binary patch literal 1755 zcmbtVU2ofD6n>qiY0@NBGDWP7%CPz&RaqTqS)r67qZv`ld)Zzl=B<^bx6`A?NB6myMF=UA zK8g?_F)~D)ukBb$r_)v@D?eAj9Tb@M~Bj_ou$gd@cH z$_{1>S<PQo)B_ay{(Mpd|VVBA53hGV;IM)Fo~puH77%$uOZkE<F^@_clmOBbbyO|nCmE_r<$*)NIJ8{@TjFd)lBiLyEDNJ~8To11LJ>}q zrmHZu_YhtJIPCT09x%if5gRxRh(*|W6d^Vag8aiKQ2Y+BWptKarRuhzLB>2q^jEi% zdyGyG9Kufk9?7gJhP+-x{RhwkXX=-30dkv-f6OKdY%&ez$O$nRhCyFt{5go@J^{mU zQB^i%)O6I`>7tf{lOK?AT<-K%*$h_tn@ywm)6@R&#P<;BmyJ9+l3O^}fsTa@RWXVz z)?m{WHe;}vRq&32gCV<&FS7U?7QSLAI-OBS_?iW6yQ=8aq~9XqFo0 z>y6S4Q}6)3ZI)}TwpFfm_xP^a>7xI2$9_$RXMSp5oZ@#&@HMXRwWjwWMQnc--O`Rd z(y6tZmRUzN^}L#JzIE>6dS8%KD(X~tVH@&UovLD9V_|S(bM92QVaLvNs#dRF;de~F z*W9ss&B{FgQLPJLmoM=^wPm(}YrO{i;E%D}YnHn;t2xh?niYtsHM?fJX;zRC$1Z{( z_gp3{eO8AYICgqvjlwQd??dhWeXxJ8=hJ5QwUhSKS;r2Tjh(vLc;Cwt_dlPOe6xCd F{4b#H`c?n{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-SYMBOL-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-SYMBOL-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1ac880d518ff3612b2721321b2fdf1bed7d642ac GIT binary patch literal 1860 zcmb_dO>7%g5PrLHj2$PIO^TbCv}}!vU}3GgEusyT&}Q?TxVCql{lU!%jI*f?P951! zM1%-Yg%k;`R6^BgA63L12?;8J)Y8fa;DUtU$dLmFBrcUWqcF2;r%8%L4oJJ2H#2X( z`DS+B+buG9MJWhMb7{HWuv z-Pz`1O+rYObWwx}iID-~e&WPLlNzR!%@wGm%0()=Tdos=S|rP$y6eQx3Z3S%)Ua3W z29~qbCLAH|$4)3~sfwA?RQD#g!411NoROR=m7p|vh7vy1LqT-Tbw)F1q;rxnU!2kk zdz*H)Bi9Mxeu>9;B=v3WexAE~jqE(g^X0K*oC{v{nBJKHx%U9|S~3Yw@^bQ?17-{b z6|`Pu)kL>`9~@6!e`1uY-F+k4)uNz2+$!AAqTdm+Rom2}d7c}A<(K2-B!+=MM9459 z-FkJR`xSR?KcT<-ghJ&6q~EG-93B6-kB@Ns66{0g-tMD^%L$+X34mDFUwQc+9=VwR zPWE#@*+@B2!#w|2MZouR61aD3F~X0yx10%4(bVZ2PKY!stJ4LlOH(SC>uv{f+bOm0o-sFK0*HgqA|{%MiFHbAjqFy zIQhd1C%<~(hQH4HO^aL1!Q<|ktmlBxZ2hayg zx;CSt_8DqkgHhXt>m;aR$Giq^vJ_e;*(nqmUrYJoDd?DYJK;xUG29Sg&w?O7dE3eN z-ahiRFFwQuAMBtsqia@)#g^Eq1(vc{>Jo4nfl@5hqx&L@KacF@EX|~+Sv&y|lag55G_p*8l(j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-6-IMPORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-6-IMPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28d8969a0cb0b61c0ba4dfced354ef49175b9775 GIT binary patch literal 1851 zcmb_d&u`mw6n}QwEN$8-En{uNw0dPo$kY`ng>B^kuIIL(iA5J zO^B+RkajUDWn%Id7#GBe0|O+)L?KAMfH?C9AaOwAQi%f+m-3#Sbm`zQ2@cWo_xZig z=ktB}e81j>&MS&8DAmeFsa)`c>Sldovo5SvJ)u_J^i~SO8s>#J6w^}QoRyWivFEeh zcH5g3udrM%tP0L%p|-kweN@O^6yy!BRK|x37jT)Ke0F?tVq&a&TDJ8F?O}S(PmVt` z)_r*AHkYmfzzQ@dbOEFx2En_2T69#~k)}0Wl?*wjiotH+CvY#4YpYh^_l*nn>V{M< zyjCdFb}BXC0D^b?#I$QDj%FIcEpD6Z33mKm&5-iAHF-t_KG8%WbT06d*{t-Oq~-Fa z<-ncW$r}LNk9}#L#C%iSo8#`SgZJ$mKYuFI$Hgi83P3T5f=@R}d-&Xc8d47X_zr)Y?1F`U3>z6ar||n@A^bVc9dDkQXSVq-zcH+ z;`V~=s5zd;ij$Eu6O{I%2FF z8+t_9SdhXzfy7dni)%SVHIEEWRt@}g_5s5uI{;V*x%^Rb?LIPesF!7(7GL2aPReA5 zmS2)I#kDNeXggAjqjw+UyOZ}Pq{y}!>0#kvcpWErVlj7F*X$6gj>ySr9G_$_d%LJ_v4+ ztIsHwDm$w5fD?2LMBp0@Mv99 z$^ejuJu!p<6leqgUPFm7-DMwekun6}~H!gq)=+ zNC5ubMktZBG-lYAe_vXYy8Szi9>XFtD2-0*Acu}v1iR!nPQ~NoBAK!YHBI8qWhQOY zg-7eb)n$OQS6g@5_IA?J<}y@w)AFp+AC-b309lq&fAzuMb$~@tDlXp#sXjTfgHZ3S zj)>%KeihlXBe>jens@BTbAYDzgB?lBQV+mAZ{y5tuQ(>Y$k+|ASIqY{J*B9C9P}SF z-i>LtHDw4bBuT9)Q+LRufrvHj#^iQvQZ%MfrX`7^v#f(6wN{sc?wrf?j4Zub!R#3C zY76mjTNoP?iRq4GJH*binJkO7_27Z-7`5g|3wL82JEX*4Yjmg$fCof(0~I6*CTu4| zSy}v;mUSH6I^i0ZzC^t5UmY5C^+R^v^&Xy%ng+Tont$Yw8*mYBZ(SgTb_Oj$Z(ina z4YDe3|4*B~rby^i8=`CAC7ecHM8BWjLzmR_Qr) zA&0S_SBuMsi51xD;OM$^3(ffB(@k&7L)*Pw@0o`tqB~ouySKgVbkkcaK7r>cDG2Z~ z(%kss+nvL?A^_Muv5=o-FwJ<{v?CMEjksk#UHtRsfsFYS;q7#w6xjFEI8DBU{WXtc zOp0DV2179yf7{vk<(RnlBynr;3h{%Ky!GUu@c+nPV8BE;PQ4nRgkxtg9)9DUe6E)F zM04Ko9za43lY1+ zcXsTafOj$OZ(YM|>sKhVGc)4F3;Z#bE7Wo59AP#?M%TEi-{c=G@`11UpusK&G5^Nf%keVn;lwn>!%i2umXXNuJMA1+I{%=i@qc%whhOf;qCz-X< KV?T`^9Q+N9x3Rha literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-EXTERNAL-SYMBOLS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-EXTERNAL-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d46292b061deab74f0ae9be2e7519bfa77f99175 GIT binary patch literal 1547 zcma)6TW=dh6rQ!6OB2W0I3|R&O1A-uWY{2AshR`<8gC|zlieM6c1)e9QWTO6YwE<2 z?G!4YN-BYPFajr{-KFXe;00NEpz1~S0}>MNh`+#V;SYp!oV1Ao4@h3mxqNdjGvApy zY0Dd?W|Y=83Prc9l{Tvzn^kSKRMsk`&GNFVt%6)tiXe=SgPNMWcwusEY_w~dI_5#N|Fh@PeCsM={B`k(y#lqPUuC?IZXJqz6)Blw4oQ>8*UNXS*s9* z5dXVc=XB0CWQN=RuCk>>{cmeM8C%anYxFWBq0Yl77+vvegQ=8$NuT06%S$F~YU<9s zmFA{H?%!#@O^EV2mi5ScJgYohS8hC+4P8Am)Tgwe^&>*OZbF`Vi?LSmXzL+lQEhsQ z@g`SyxVqhVNkKVog9A( z@YrE!4=~>10DOb+4K+Uo-EJr3w>bV0@EmC&!0-V$SHSTEADZ0jZ&eqsdtY+3?rjws zSNI@L{Cxedz4!S52#Cd!BgM$Gy?!3&Dl`f|uty2m^7aN!+Muj$?`xj8{yP-XxOW%( z1N4^n7`DZ4cO(?=;ZqyrXZ5*n>|Y3}dtceJAqBeK@frhHhj9abovjqj!m?KP)PhPv zZT|PQGf9KnQyIKceTLdoCKGx(0~Y(TlMF?GD}70WN@GSBOy&gKwb3F=yEE@dW`&f0 zBP34--QiepD%=bFh$Wd2TYC8{OmJj!iL>N%ow!$o;-N6FjdQ z+_K;x%#4#o@HtE?n8iO}s1AeLd%$4*`5d6V3t<+s(oCS*6TAWo`5R8R_Zl1}%Tvj% zEY2C)e+9Hkg`o4gHwdmZ7!lRf? zfVHi4l&HE90$P<9}9nLcl z!kLjYZMN!ufI$vDi2Nyd9hV=2^QR$P7#@yJj8pJy{VOHi{j}uOlrD6qL zu3tMV-AYv(xkX2`)g^cvSG2Uhn)Bmon!>wv zl^mBW LI7fb%*x&yLNi)M; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-SYMBOLS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..24700b43b38cbe75b56c6dd3c93ded64c90356de GIT binary patch literal 3043 zcmds3U2IfE6rOu`TS{BnZK=yrYPpmOxbZd?N?J=W-fpMumfbt$-dky_*wl96Rtnqn zhe(K|ARrG*aN9`lKuC;Yj2g|hF)E@o24iCMfd`DyL|-&U;|s=^_*T!E>6V7_Ac?$~ zcJ|D7&Ua?coO|XcO>(*-F)fljI6OF%7}1jBW5eTP+P>t7HkuqC=}&0;K(8H*FpIv> zW<++??5NGRmst8o5`ANd0nHgtj1Kf2c|@yyOf!Z@28W>2&;YQuar@TBy1JVD7Q>Fo z(f*B3Lu2i>n*8}o=aoQ`5YkWPP^=^*KzziTOa;OYwH>`B8l$>t#A(<|d#OBFi{5Ed z%S)AP)y9&;`cUF71!44^?EbY?e2IJi`nGT`P>tP_?8!1^cC}XcZx#Q^A_~1sy=`0$`<+tn_$ht%Ci4 z2`p@&R)LTaF@VJcVCE9?Wm#_-*s!Ony+Ifu1g#ue1++?N8ni0OEt;GmC!YhW@C=|6 z0p4w-f(NUBgo76=XIf)AW3x(D{=tDiW(`&W9khk!Sja!*zcss>g;)TV4*#GpBxJ&! z4c@7PU|)1+6w1mE+=Qt!Z!HEOqFxL@uHn7~Kt5j#fCbZ;GE5W;rQK63kai~qXUJs+ zU#4mfqhnRs)X3hlv`n)gCOh+CHaUBjCZ`Ms?5&<-)sw6`#X^u9Rtn#cg>KE(-DB#G zyJxa-zx3LST7`vz4Ti(|D8gDQx`#TDWGsZ!Vx_`&u@a*j(m@UIHfYO>?kP|NcU4^|^dSXRLaj#r6p?@pA>#TX5khFW+Y*!U1n@Kkl z+_NQHM|oo3&JFg5({5leK-3)Xl~hGI!p!C<9+-NYVK&F8r8h-EW4791)ek3eNjPFS zkv83;PNxMYX+#{wxpueh(738BXE-d(3w*2jN?#eAzC~ebSb~2Haw2Mg@JNgm=!l1gg0^0NT+2{bIBFK6|`LkTiNY3 zMGTwDnRo%3FM_$KnZ~F?vzG$iEG1pkVqJQK#p95OSk&%7@)Tc#;wa8;(KvgOB77cT zvAi$z>}7-c{YZ<`coVe{4)C=o+Cf{;0vTPnVo*m>w=e=;Zm6q)k5T+I@MxFeuy{vS zk2hGruq>lncbH?ubUWIE4!+NL2*ouqjqhDvj_7TPCi#Pi4)aPBk4xqbX$wo{W{HXg zQ~gsg)f6tl=;)wkGdQY;grj;uP}LscsP2(yCtrt@23~<;gBV7c7sDv;3qNH>FqKz@ zpK?i}Q<6C-ncF1uQE6K*nH3WG1(W>BE017Uw5x+z&Nz0Xrb8{0@eMVA3ggDE#c#Qu zSJgv2{wrX}5e0^52Hpj^CYDbO;Tyaf1rD{sb}T6Morp((<;Qmcf_l z7TyrBP3$(uXo`ui@HgKK1m9Ib_kASjzBeVhEYXmpV0o-q7z17QN_7|Cf~Y~dY?m(8 z5^WGj{Y@~{p9NF>UZQU#`a+7=rQlMy!d*>BcSoY#0x5q9cjb2}-V-+E9cjBD(X>Rp zlF}o_RCY@glSr4$uw<^4C@2v5Q83AOf=O;j^p!-PN^wz&G~corlJ0{i-8%koK4$uc zms&ND)JKmTd^R~Wikh#z)Osf|I;K?}Gpe+Geehl#&;}35rzYx-i7z$n!M=`KG~#6U zH9DVztsOPns1m$SGd`6tA!2Tf=voY2&h>*4&Mzco)4X6;7tgh(!%JneI5hVi3J$#B5%GG^p&| Ooy?(pBf0Rz{QN%yK2=Wu literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-EXPORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-EXPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fb742032c891776d29486c0d6d3c4f6349f2cceb GIT binary patch literal 1130 zcma)5;Y(9d6u)m%H@6v6N5T?)GXu2`CC?XMw zJ}q)e@^0amzV@Lo2uw++f5`v9&fSXHf`|w2o%6fro^yV`b6y2CPiuy(<(Bf9tW%J4 zrDDERloxXac_mjW%scWT;PNxgw8--@Rh#I$9S_+jPUZ{FT+vyOS;<*hn0tCzj^C2i zd?AwsV{j1M_|WzKp@D(EP(rnhTDJeWGdMJGwJ&tMvn@q)2%&j&C_b$SMUfwQo8_p& zh|O?9HwdO`k|jlVrj8Qi3;xO?vP)h$9FOChm`tZki=mzEmUU?2yXfSryFV`NEu({jao^Ob z?slnJpbrshLuhxdZUb_(+X?SF1SEXY(VDwESjRF)yO-+TKQ67g;@O9Yj`cu9a`(Pb z5nY*hMSmbvabMDLp9DQ@x}Q3ys?v$HL4+a*9cJb`DsD6rMZRY5P5G>%nRG-KTHrC2 zju^zk!#W^z)K+{=Aac8+sZ1Ng7GY@%MAE7%x7af_BT1k1cLXyP9`*-#t3L?Bo>GWq znHDzFER|-8zZEV-6qU~4DsC$r6pqFl1{Lrl#GAx)!b0sYkfOfr7erl z6VvCCIC~Fgr|X*)z$1olL=P(P}bdSvk*7SeiWos zqz`>cX;-Nv7XL$Et))Kn5A`3|$*!Q-mqH+C?#w;+oHNsb#7k9^Rd2Umb?t`iwOjRe zORjhgx#_hVC0nlWy8KSn4f1{!tLwARGXv(0ol?Utw(PRZ+IF*C+FM0k{QT@d4x3t!?SFa}m*y8{2QE*K1<3<|5?n;TegFw#5FGlF!idRGF0T

&;# za3yr=gk%13%~J=?IY*-(`qF}P_KR}-r?dWv{s!ncAL*JX3;`TE-^aJQW+Q?WKpNnp zS{m&*QdI&m5q$Nh6ji6$e54+&Vw%;6ftIxCbc=0ROo{dLhO~m|HtN<*CFGe%nOo8J#Q?&1 zlxJdxlO%JxQNZkVG)%P&gU}oI6bh8r?_B#(u}OOD;ou|QE!_@#Ivh)8`9`8E;RV0K zB#j1WPr`|ZydEpyjr-x<2@c~XVVm(+Tw}&v%~RJ?HR_$ovJi&V9!>A9JLFz9rpmUGu>;dR=5!V%*A;6{p7 zUA0Sw?mgxna0%~`n=I*41+J#7Q^H3kSui^XX=GWt0#)?2cP@KRk`D>tl9@D*l>TVE zEORgJko&L7{MKSN!-XeA>&JY`w+KN+9PY3%ZoUM#@bH5S*LZOwH8xTJ_ea_zBlU)m zQR7=9Rpz-Qh|f-Loxm`#M+iv}GH%whU-JC_gj48h0?rBjq^tBRpR@zYXHI16mHRxMOU$;a)%%c1} zj4dOoimh%)Cbg?3v|aV*7PhWiHr?cT@K_86t7=rys}-qen46Z!IG+1|v~7qi9*Tk? z<}br!h=q5nfZ9-!MMLqUJ~B&(aP}#YnxY?&ib_$QZ;25z}Eq0>GPJYR<=h1yrDbwku=Gf^d`W}E`zG52dI-+~Q?9|{f*%q32f_DIQyJykundgSvo$X=E5BddA|6YIK zw9&=@4IqV7K=l0-$zORtdyjEra;ixcn@UGIsg-PMDw@UO=mwYmtZLYl{Y&e!>B zt66I``9ihMH>$0AHqRHp&%cm09lwlAa&qc!xZgMz$=35L&3ulht$ZW5vUZaX&+}5P zUMj<8ZVt?FiCK+lE?SIb9N2X_{`cL zD#jEQi$qFc!R(qHFZ3d&4Xm4;p&7net%>FQ^L&}LQ)wU$A@gm=8%qe1=gdwp92W0D6%rMVOlm<>(cZ3m1DM!!z7~%X+~F!Z{FZPm z4^9kmE=Ka1&2zy19}^DDlXvhV4(_B~JXkzSf%w7vztczlNa+^arFM~hM}RoI;R$fX z!(+lqbd#Ip2SVNAYm#tqfWB4SA6vG?V-Q}10>HYI9qtx`r66*+%$?2^LDooAVQPqR zi9}Vbiwn@JLKY3d(FZaQ39>}xxTs^A)<<~}Pbr*$2Z zbN6p?EcOv%Bfoo+B?I>=S^fr~_|IKr4eWqzpWVFyf_NUM9;k{zm#op0H72pb3ZYmh z*RAnu*65@)=4WMgAmFk)VAdu~m76erDl=bM6BUSik~p)h>Cq=_=6WEKngM>!hnYug zSo_$ZCct5DevL01yn9yY798^_B#w23;-~!s4Nit^IOd`Ey92UUm%n#-@9{1VWl@+%3D= zxVuq`7(x*GG7@94%vIYL@yQ444`MMIp^v`$&?iAq5JU(F3ckd1=4R8~whs~dFr2yP zp7VX*z4x4ZcS!53s!3|Ov{oqQDpGm9wzgiAR>~ErT3)X#<)jtxOK+-%N#B}Q)R~bN z6YW;R%u*${Sj#O-_Ij?mym)n3N{ma&TBT5gp9>dYm`FZ9nj9M&X-_GZ#?g+GGoDP0 zjQj`gox)lV`uHco+(q zh5chwbaM*KZQy7i5a#LxA<%iBWB*q3a5MiHIq%guJDNz~m_=d#i_?#AK2Cb^g*ts0 z*9)xwdZj!%YBHGj}bBKz3=wNRYRXlW4+1Kiax1PQ=UkJN1w9dVh0O}A^3vu zwZYd4h20rf6$P6sGD|cAGV4*)$`H5Yfd;U)89hJ6Snpm>Db11W|Z6+cx4X z9Eh+`pdAW58mFddn6ly6S;vkCqL2`YEBc)5`w=AY1o+z089+6TItqKib7P4IIx5ma z2y4MM>czH@fT4w6R5To%ftSJ-7Vg1x zbdqY+ru8mGVV$$oG-hSh$Yfw^wX~JR;ICOXnlD)onvWR@6W)MxI5D5O2tg=DsDZX{ z3JyWG<}woo>J=`tr_e000W{}1%ov9m@?pro{v7#(o4bAp`N0n%w|U4lTs6Ne7FhQ@ z>&dX*LGVQ~%FL1aeqa!v1aE8BG^TVMwZj@CJWrl74JXS^qKv;W$Uhn!{Rx*>n~q!R zEB=`cq1R()&}{S3CO5AEUdJKcgko~ED|q>(b(@+xN0?`4G1Xz`(DZVk7)KC%L;mqY z$iA;ubNo#vzjNm=;0&4ymbQ;aKJgLAM?Cc%Zr)~R=h)x`J2TFP;%sODL4$|NDj;l{5Y2`~+h8nkT9zp+Y-j84Y%0g5ENo+;O+QSGN(cu| zYp@V;2Seh?v*CsqIrtCpAK*+2LhxdCHZ${kZ+`QB@4aaQ|4Uira(fyJz% zLJ>(hD7bCc2~jPgX+Yg|deeNfS`#bQYpcTKtTzA$fcw!2WlbbwMMLgBx5Y)>T_>g> zF;AsQ^ALDKmn@8(bDcY>l=xh{;c#>i+@^tiW6}JuPZzn94e<5nqNk7;?B)Dxoe+-| zI(J6|fa9q`yo;Y7k6$_@uc5nLi2Oyi?CbB88vC|`an3&Zh3NXcz4QV72B2;4phXWC z17OeoK2Ydm(Xc-RKoo$pa;d*1sCt#;!Y&DvEa#Kq3t3~?KR`~Kp_mMDcbBuGpxceSTJtFH+!ce@W aQ&lk3CDkAi=0*j)Ff|OxeQ@~b;^GfCZX*Ez literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-INTERN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-INTERN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c10ba974930f83eeb146b9fa3ced2fe1960e09af GIT binary patch literal 1401 zcma)6-)kF35Z*i4mSovRc8mqF8(mEU$&ocxemZWUoX@N1?9-jQw-?)x7sozV0!1>i z98yYy$wTSGl}0fQw+Z+9c3Ip>KskAM*#~C6MRh&YTh)6h8!=*u8INzWHWn z_S&R(*|asYac#3&3z}MEyS2I9(l#1RZL6`}Tnn@fz_qVTm$R=+hPg2HNul3+%d*xC zR$IZkCbomE_0=y=X@!fLvDvKFU^6`puZ5X&r)SQdo$4B}UZLYZhczqA*h^&IPv=szI8 zC%zqTt_lu0TKG`NBL)f(FRqA)K2 z)Fy8lliJ2Ae0SEhYQ6KxKXyJzK z$qc%|p?&VVg2{1=4ZGBJl*a1FxAOQxcjoDC;8ZN*Xg93Hn&b({C{N09a_`*!{{KFW Bl^*~A literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-LIST-ALL-PACKAGES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-LIST-ALL-PACKAGES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5e1555066395da348c14c262b7a32382b8cd84ff GIT binary patch literal 1196 zcma)6&1(};5PzGbZETacDH22d=pt5R^%WwO){5Y|eX(gb@74XF?Zpz(ts9I@NK!#X z5d~3*XcT3i(u;SYdaIQd@#xiqg5b%M7ypAgFKukli!95|{AS+F{NBuL19i;khN73Q zlnX_-qLh|u<)xakP^u`^(o!YwDhq%sH*{u_o8y{3Ie0qNZM9kQ6*pIN=M{U&tNos)7`R}^BBo!DpHOP0GA_DT-J+m#rHUkk{Kxfh+M&9g zVbp&r-IgN$qk1$$@f1+g&Jz>}Z$}Z)CBL3XrSLE|GLT9$jFy{)mY;XtfqH(5qTYFH z6VmD;`tg1uFukWQE_GaLRvJd=z^gat!H)L!dYfEqlP_+Qduz3U(}{(no|qWig-0toI05@3UU7Z%zhZ8dzWX8b#=~xAUw)xZXQmvgECf( zCLdCW(eUokiGT#&PrQ}HbV8IOUMN3;&_*GjY0b|6%5hGVvZ^UIxyw0m^JqfdwoLG7rJy|4c*<(B0N-_8c>CYrO^D|~?7 z6z>m-EMH&=iiK(o=ZZyK&gC!XF1b})bE`FB{p{EKZIG2ix3ojbLJocw^GacHYtIFC wYajy~)v8AFU;0l2kl~P$u3Q@ zOLkK&Vu(R3lr1%BQ|B70DEQp4;6sfxU>^jr4}vHt6#54UzKDw$VrQuPPt=HEaeOG zZ015{7R#9{5`hrsqp~lW)KxoX=*~4^S!i>vmfK^xoPg4lvy^yzRWImW05{>V{Jb1j z#%SH-<_-S}A;RyN&)3*ra#=#*YwS-qnC=4;u_L;KytYBrDy;9RVik4UPaM`AcU z@`$2GG-}FcVj$7aT9T)k`8|#BG{AIrNUCD1BeF^DqzTidy5reoO;|RKdxU>l*oMSf zy?*BRw!=gokf>=IrfekbMADYLt#F`CQuGPgm0J=Myg0djsXDh3OzN|H2j1U62y4JG zAHacq00)|)h8b6Eg!eHCHEEhu-?c_eK;1pibw8|CRV>OQvsP4p4(bCDs!_YX6}WvJ zAN}%zl5VkD}U8*e*3O@#6bM%an)FZCZWyB^uM@@^O{u1DhYHhL} zQ^#<{E!2F#9!FASN01aangR1b%^db0gS$meas3;doCCAA-Mfq~23Qx8Cs{X=E_M(I zdB6@Mx$mAMzi{*uNB21To}+JBFIs+u31d`Q(X?8nm@uhuyDwQkqAxgF=V*r1gNn{`Ln!Cr9L#9QRndKYk`d;ef8Y{9FnNyppN5Z+=zBpYxuKAooA4C-%0 ze3zm2x|_N1K6@I`94Bc`UWbzncxUV>RGQ4483Uqtp`j=m0p9<}UHI8CR0wWt@+T+1 zVG4K`@@tg3&d84-YIa4b2`>4rE}`RGvdz1Ciya4-~UYElI@WX~RH zF`Jr-X0cW@gDZVCY1ou^vVXrq+-#m;p(Ur@#Kjs*$KQ0ru_18Aph*c>L#f&ZNzS~J TE0&5cYb+!@YDPX8+1dFUHQYRb literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NAME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a64c827e63c6e6a00213ec6afb3b61e078704cb8 GIT binary patch literal 1225 zcmah}OHUI~6u#3!X=#Ch5PT6kVsJ5WkRk?z#AFz5VPHB_=aE88Oqw##D$u46qcIY~ z!qpfpD4DAvap}@@hZwscaplUjKf-^2=T0dCF3fZ?=bZ1}bHDSQb6Z8N3zEV~`L#lB z)h=@RO1V%ebIbW6SISq48Jk;%IQLxAbo^pgl;(#fW9`N%BvZ80WqXM;D|Trq{p=yP>Wz0Sa+T75w4ss2&?uJdzF^6RzeIy?i(iM{Z2^Qx3+*>cJNF$D1>%~X5KZbHQo@p@>sUQCPlTaZ z4Y1z7dPt&y8z+(Q20)$DSivT4&Ihfjdjad(f*@&$1PG|eM)E1?FT#m!@hQzxr<0GU zZJ0XfnOp%o(v*Zw@dFZFps_dz-po2rqO*jXB+*+WdV_)qasK4UE96>$68!`~tEU0= zKEj*_R9c}z-M8d=p7dKlxP=lTU6`8mo{%nYmg~T~kj^|#uh_zRdd(KfcBxEv9=J}_ z1e+V!5C^#BH2fDVak=%zHKwtR!G~@ms|sJ5@}BF24NNuj3K(&nj<~GDRi$+foCPnO q0U7s$yW<0DS0x>bAnQ5d71_kPs2C(nmqESvEzQJa0KLC`bo2-LU}!D? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NICKNAMES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NICKNAMES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..33ad1be1a44287c8c205c12d9ea9e987772905a5 GIT binary patch literal 1342 zcmb7ETW=dh6rNqj*Ep$NP*F>1mrCJb#YA-oB25Kiy&1=w?8VHCY5ZuMO>NbVE!$~@ zP^+jys8Y8oPK22S^*wk$%Z9nVe7lfgXDp4rUmyCr8b9y{yY;U>)C#vW zqt|b>;jy*`VqyK`mG#xth{k9yZGe8PL;`<;~s=6k(JXahm zhe}pF4;CyJS70<_lOQ!U%_6faBDhp2;7?Ai*tN`US&X3<7f4K1eYqb5$ z{S%>4^E-D-RUqq8^Os9^B4}im6hc{qUbh+-N6lO-ht#{WTC z%Jo$&w z-M`uHEzo8iV|$kFeF)4hG0!2>xNG6%R0q7`(V#xiD&fiz>{|Gq4ecZi+bk2OHY25^ zQ!&&E;F+GWNC#=YLP^Qmi8%Z&L{7mEucss$-vR@B^~SyWT_5ka8u#|=9e;p_{$MDr zha$Mn;jP_xWZcm9>Ts#MT5ErDWK#EN>9a9<>+>nkCIkbXDe1X zhI7Ma@R)#uR>iS;Mjg4~nfU`TL-Cz4T8M@K-v9sJl?3#*$SkJ{ABqUv!HUPV6@Pfq>@`+0_z literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cd484fc1e56875ae2bc2fc558e74700c64d80c65 GIT binary patch literal 1323 zcmah}-EZ4e6u)+wENwpOMpc0B1G5c~EL<(oD5FS7j_WjTo$GRat*r1+Lh9Dh(k3M7 zPz6k5Ou&N?%O-~J&?LkgZ)Fk>W2i;ql|KO9dECRE_FB$$S~hhL$g=!9=lt&P-t%!i zK=F&ZCF|{tPP658<@Q#;v(=Z^+FiNV-s(0yc@6yX$GT07Pb-?fIQ>>(%y}x(=z8_O zw<^;uueVy?eoZdCDQlf>vjyP71uzSmS+i!;+>`*&{( zQX3)EKzsZ%ijah2D7+a+3N;+6mQBl0u~s#da1aJb$VGJ>gM`6EQSP@pYRkLqwRk!k zJtQC$-UyOq7wgotad=C(Dx|}2f{cmPB}h%1H;|Y-P~qxA7@R5;)He>Js#DSC?3#(^ zRcEM!&2_#|QM&5Y;9j zo0DLF$7$g6Q;=sK9M^}0d)u{qZ8C$Hm(B!OQ5MmS6cIlE!l~@)?X+^`!YUFnm2HlnlM}{U7M~IE^Ns)M) zGa!^G+oY;dZXV+&(_KOg{L~~e0b=Me#3r94u4|4l+=-=l_y?}!Py$8Z=9gf;a4>_< zP8nxh2S&OKWjh?kPa=hAAV1{L#MB^ojh%cCtQ1^=Ln2{`GE2;WS32B*M=jH#1$O*Z zmN?E5e2CFQpv0qUaO)qqD+$bVwYd2gdx?KOgS19U+PhF%n?q1pV&f&?#z1tMojJ?S zi~>=J!QJW98<*!uzdQ8c3NJm!@p)# zZf*{L6Wn*@WlsA&yd{Q#XfKArNW~@9%iMXVQneg5{=f3mqZ>COq&nO8&DO@b( z7wwWzs8)*Aim*^93FShyl(mHgz=dmyZm8E|vNAhyRPve~OtxfaD)zi!RqgV8=E{CS zIwHu$QhpIOQ&V6{(}yC{lamwPsB9+I)c$)WGJW8{^uehK@9N59jxP{Gvg9K!1BCFz zO`L}{UbIxxqS1IlrJ9^nMW^o6Jdg`bnX2K`h9g3yP^63YWqT3RxmYF~AVz`y{CO5 zq@KI2&A2!ahg-L#x8Y^@_YmSIVY;5i;8S1F>0t*%78K}%|7*+XH82@y10KmEL~(icRvu`sIIS9KC<3kY>eB3 zJa(hiH!86q_dquo0Wi?5gq}V&;Kt4mimGAg2Gvv6T*?yNUU2q{vUZj>aZ_Y40=(2U zN&WqVupS(rO*jNUL8vdP8%fzh^9N`QD=EWJwT|&*9CBZQ8{H_GB0~nvo0t#jm!QPA zGiuKo63>C~N1?Fod=Ye55SL{Z!sYIob&G|rgR`%rHU&JKlxNqAHP3?QSUAaoF%~+` z!uwfp9}5Lp*pE72z`M5@6I!3)h3V5Uw*;E+nSjd*q|pQK!5kYx^8uKF_JtIRj^NT? zAQb&70_~QfR~oe4a7+cFH4tp*DBC;5#`myY9u)Zw)h}kU7c%Ey4Ap@VNc_Dvk?dyWrjq%IQvWx9zV;7vxTg^^OngnYj?ya4c#5qqv0YVEa hhALYs?P^;hZmEWxFqseCpk}92x}~z6Nfah*75gtsN_MG22_k8@$X{)GtURJQ2e_F6}RuShb zgGTEb?~(&j}XeBL;h+*D1f}k-Esn= zNez=kV+tjzl%S$pbsZn{LXrm6U8idVm-7XZvz}Qw-pa_7X#Lr2I&iYPI|M0@XAHlUJpk)YQ@%{P<7w_Vng1_e$+sLn;-2!X#YXo*6`@tzi|%fts}b)r$c+) zUeDIA?|^o1wEBhY*8>&g-_`gl^(R8r?4~;H5iTGENiWXTsN_j~2>B5@v@_k+Y`_j6 zPqX{hxh%?>8i{dk$dsf;6snVn7$EATA$ppC^e$1BOnHjv)J*C?np|VO#Yh<@O?ZU! z9;PO;4sR=K^ZJ13PLb-mrV}k`&LmCI+Xe^xqNJus4L3vvj0eJJ2G{CEh&AzPb#uPI zK%kbWrY9tmtDkvNIjQSZJ+%!?;I{W*>-pQ0EE%+(iFG^!Q)h%K)TAfVW#%J5x?;|1+D!`FG`ahjUb^hh6f;{CDyUN+FgQ+#rro70Bxz3k0t>drQ&f1=)EOnQNwu#aN zfu>DWB?JdcTUt^10}W{$kdQcxA|Z_-df>u=J6G;pIB?*ARNk{2XA43ok=}d1_y5o5 z4jEX|4Oy?RH)?BcQ?9pLjdn|3tvBV(db?S1YDqWyN2zo zZxVqJ|GqbzFPXYiV5Yw-YzZmj6`NyrWHz(jVGkT1R=_n3&nk#7Hv z32mY9%YK825r4DC-;fTNw8JDXfFg^x!&JkBoY|>9I{%C`8A|(OAqAg<9#`9{ZB@I! zCx9Q{9ukG>VV^y_7f*EShMXw~S*x7vRHd3kVgvps z-f2Z=X0Cw4RcAFbXHZL>DF9+#vz6E}*jifAHAkO?fjT7%rmhET8?={ghZbYPzbzc5 z@MJu}6Y){ll&Db4VwTEE&O*si;z@8wDVn*g2Dq(oSecaR+k7HU2tS7Feje6F4k6HB zo>@iBLGf=)s+TO-@l)r-1=Rfxx)Z&gbj_w=CZ0s~cc2z?)Symu8+e83C2FxHRcFN_ z48kbb3uyc;q)p{v8r?HO@N0ew$ya;~$wM$1%FnQpnG0O@Ku&|dqiTlHb+gfOH+1-z zkE8Sc~28uuPNhFV8EF&ge>{hI1qqm8#3QfN3H_7l95dS=! z$9+^YBN~;O4b|KIIJiwh4T-4B3I6ga{z_2lU%n?c-Hr0Pt2WA&cgwe2%LFnhia$h;VO;w(Z>b13cO0S1jNWSVW)!b!;*WLByrAOBk{icG~ zs>Ko*lat`;Q`g6*CMHI^lGrv|Z2vtoJ~gIK>H28b;ohz!R}eyZ^h10)5t30D`P-hX za$<8WnKp?=afYaV!}p@li{{vb`Ci|+Qmd?KCHJ9Q678(6BMBk@l^0Dq)Zl50`a9C5 z)a}3YdeT(OLTh-2piuOPMX*c07t?j^hGwVmw3S19yU{Hu;+v@CbK%RZbWldWzRren z{X>0HGQ?P$G=3daBBJUZU4M}ilyYO)^Hy}8~8%3xap&!Nk zV51-xWfY3|uf2<^VbSTdkU>jfI&BiBCDMS<8CwmtfxdmJfw_^=7~u{BeT=5S?e>Dr zNhT!yo53wLh=n^K5J_Oh^pklACBxAsZsM#S^oBcw&TtP1A6E%u7Sk+;XC1DFW02IX zV!EI;aa#>w0Q23Cp3=*@7_BloLi5h1nXu4QALToCZS%m@(M01E`DmlW zI%;Ox=2t~l5;Q(Ob|DyU7gg;*Aku7Dc+X))+o@>Bd>V|*3)xZ*%YbYX5D5d@2w-i% zm<@V6#EJK?vGsDXTyv{s;lJ~}%iLYBDI*(rL|Iva`@5_Z%dM*?u#Kzt{3F)Xu`vcD zN#SoE1-;P^5B~s4 CDn=~; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOWING-IMPORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOWING-IMPORT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b020270da1878e08dfe7921ac5c994906033e781 GIT binary patch literal 2411 zcmb_e-)|IE6uvVHZMVOe!cr+B9s7go!Zd7y3Kb*M*}L6oXJ^)#St*3XtlMpO!*;jX z-9o@X2rtGs2~@C|E5XG051@$;jo?0*7m)u@zyGn>?l?mxR-RP1+NbYXoo*^uk$&GIe@#NmUT|)CL zA@CI12x;&x{Nez;q1&J5s}vVEFrD>Y62eOUPp3eM>S#0o)hw z^qkzcI=h9CcEBp;_BXx|?rtC;C~E}5Xq|W%A&mn3ij9f;L^z9_(HzQj8lWUbgh0-1iGfE zZA~efl}f=18oHAPEa5MPRD@qx1e>4PZfw3|-Pn8zlzLVbU_-4tr&42<;h@JwKJ7f8 zHp{1-fN9cJX+ZDix%VFK-4b|{2fVq$BA3|iGV7+e4s;6Tg0Mx zLu|hcm|`40Y){+PxQU}zA@$yWWvq|yaFO-pSpR7@Fv$kS*x+$C7-NIO zkVOa-{~$Zi&t8_A6cBfh7MstH(7F8#rMR?pY!a^GdOPcD}EJ#^WTXR>g;O%Eg6 z2mUSph6oJyYc^HkOl>)N2CRs!8V+kiH(1KIGL}nuia+{ZU#*axuADEHXXV<3xpyli zxl)$rv$?a`+5AvVE){EajPir;^}6d!c=&Zf$nNqWx?K&(u!9ha9pW)+zIS*%hEklH zuT<;ubR}Oa57p&dcA=J+^VKR`+z>ZcDbJLOxgcVN#Srlrlp`C$UjO6R5n#277$DW2 z3?&6nWO*sncVamS7lZ@1ocKu08-*lZGazX@LCi#uC#=z3o8>8CTPc*75DWWWPcB=} z6>tHzYDh?c!*tzi)(p$Z*c8~~<82#s)p21LtbY?fDB=rjKw<~rCdd2;BuGBnl;BHf z`f!t}|D5j)kB(80A^MajyFJhB4U39qAh{kq~X6vTv_ESfH8a~?b^wVIXUu4 HdS&Gwt7%g5PoYXu@fh$^XIfp(k_V#(w2>I8k95@h|Tu7*~ESucGpQ`*isrB z$3`I3Dyjr0qvBSS9jXe68$DIIm7*4@2M%1gAaUWufeVKsap4qZ)^?M|kt)lYH{bVW z-Z!)JUX``3=t)`6Un%4^-J+Z?mkQ;Qypb=;+xc>F&6PJ0mp|1_i(j47^o8*Y@eca{ zvsQFhOYXYtl-=$1)lXiP3-yHQaM+)nZ%g)WhIY*ka%RI3HM!p6roYKkx2ylWqJSVtnuQP`8wQ@JLX`>cSV|31ijl=VCq}b>Zs%;Bqe|pnsULPR1VR z*82UX)rCs$HH3z0avq@(7`wYnLA2UeJlo)=nz_*igrfT!>t~@2%{$o_tG=1NA3I8R zH5<)ESs>(nRT)-vQ(QFYgQ;_xxR~UYI%^;zF4;<;71{$WI1N3Dt~vUgYH=rR;n&pt zacHwMw!>2asdfjI?551FGN*cDG zDvFsS39MSRGpSiKNqbrl3pWN60roEpkogBMT|h%P+!8*{{v&{|>;r#dXSxMnu2-tAWG+9u*>opK%pWj9=4W_` z%ug86f}L6fncUA{=qe0<2*dBg2!~T~WV`nBfqWK524Solw@Ua-94l|R9~bh)l3H@N zOX>u{!mFHi(33~6X`}MSDn5Yga&D{kb`f^%3~h^ehlSGddpHg?U4I|R|9T{P&%5K@ z3ZT?ey2UkztA}PIX<&!6qzw_;hJAiJZ8{u==)^lsRm2JY8qO?v2TNZdWn<@`!%jcv TNxlkD@C-N$L+qQWy}kbdGjqNG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNINTERN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNINTERN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8f9c0e121a36410600f9819476e0127d9e530bf2 GIT binary patch literal 2311 zcmb_dOKcle6n!(!$MG*tnx@E9kSnWe#gbJODvkPDqb@90szR;Os4iNqa%9^gcJ}b$o@n>T` zqs_BeweodqNiZ8$Z7IJ#CdAGO(pt4xg2vgi(2d2Po`_FQj{6dlk!EZUoHG$WgVV-+ zyEm?J;R+#Sk!+*sAtX#Z#CgvSM@_{r#Y8f#h^mxPqE6GXy^xETGZfvi`zC~XWlbzu zFIy!{XSGH+LY#MPZz8A4W>Qm~tK23RaIVp&f)~@isL2x4MsU zgSaO*!(7P@gx%C?Ye3YYT#(Y(sX(U-1CUJYmM{W2r|XK^cK9iWzDpSSK|y56P?#+Bqx&gv zho+UZVk)iUj(0}iyrOIKqO4^yP{nl8$RfC(4xs6!$H8#BbP&z25Q{$n^%aeU%#?=l zabLSY?kfho&VVlg(A&B+5S3x5IfjZe)G_)f`g}A3hWzb9$X_mm{N_T)m$1m)mogV1 zEKHw#&afW>f5=E?vT*qsrVh*f9D3iUkpdmC=f>{OJ0~O=do2zUz3kvwYp4 zNt2Gw(P4>>Owf_jbo4Rsd*Eq^(9uUgjxWGH-zXQ$b*oy&{*q&haVY_}JbNwNC$MhS z>cYr|G$Its?CIJtgylTEh)d%*DdK$WT*U)3BMVv3vJqS<&5O$sg`y@=4p|ciP%-?X_!n6XxmZ=OMrNlma({a>NB2-Q()G Ln~Qvu+THyRn68XN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNUSE-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNUSE-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f796c55c05a73f9a62b535d78732efeeaf960fed GIT binary patch literal 1058 zcmah|+fUPA6#u#l8@oV3qIiKdBqpZuL$^Q#G|^Hz*y!5XOD4XUWfZzN*s_a>Q3)Z& zr+OJg>?biMKKWz}Z-|ix{~`VZJl}>m@xioBPk-n1ch32p^EHwGo+xu-d8JY;Syisw zs8~!>TRjA7AC-lbleg z7E54EOu%P+YCJJDHZ~ec3cB28`|m%Asq1i0j)smtY%^>bAyhyI^wo_Ji@eC)bXeYy zbOR?-vV;{OBk^w2b%M|fHg!pJoxTKDFIRBMdSsPoJ1aHBAmqMrf=N>mjg+dmTg*BW zabG*pl!CL+nlLLNPw<$9vNNvJACKc3*i?Y@B<90*U;}FTLJRt4@28o)RrL9L+LL21 z^f7*lE+b@zq3E97bgl<#-n75o0SxXaLdC<~1XuvKd_%hv$=knpFTl^A_yH63jq^=Lu-d#!rnb;6sS`=$yh- z@J~S0l~lEiV9?Kxv=-6SG)d{$1Hw?>EAS2cX;lUrln zF#~LFWK9_1mhx~+7rEkU`-D+!?eaOd&Cj?y?v@9#4U3v27!p3EjGQtgO^|gGreRR` PT~jqAGKAjqM@PQ^>)AJ$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-USE-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-USE-PACKAGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3af07b5ce6ca7392a1cb389128187aa07a924e29 GIT binary patch literal 972 zcmah|?@!Y}7{0C>8*Ge%M2+&Jl9*_<=oW}DP0UelQ0Q7{Z$UozVHt%j4!Z1z(Wr!A zVq#K*gGgEp|AXP1V&sGW5dQ(bR}cw)Fl}>hpL_4Q_kEtb7K%JkG*NL@tL2Ja6P;$G z+H8o+PED*k&05hGmjM@FDTYbjOk-ts_+hHUIyY0S*@cF^B+{l`Un;!3E2hRpT&pb zIjd?!)^UzVUdwZ1(2Jb6i0QfAX|dr{<%<2>uCR7i>xe_h`{>59d0nBZp?f>r2AA-* z+)h=O=b$w_MNlYq%EH(=&lOTB`2nLm%h=nEZbBtnteo$qgBkAI8hZa@CbS@2>*gX1 zT|uZ6hmw=~cNUUR@pkF!4Zz^-M5uhUe+eRhgSq}zd85Rh0|0wAqe-sx?WYd$QET>t z{tKa2>770k;$S7vTwds58?Y~iPy(UDaifnBUH~ zgMvwkn5JRMMxM^)sl<0edP2hbq8#9s8vbm-tT|JgaFz(zbg$PKY>lZ>z+Sw9kO^J4Znsn)2!QawNQLk zSh3}XU2nYb+(8PXIJAz3#N`6qs3ozyc5)dQwtn-97jSXj7jGv7!~=>+FeUPZMm3cZ X6Kj?qXK7I4eBPkM??az&A0Ph)0_-4v literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-8-PROVIDE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-8-PROVIDE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c4b403ed16548dfc5cb3703f6ac0ccdb7d38b99 GIT binary patch literal 1342 zcmbtU-HRJl6u&dcW;bcFPD($6yS-McFm@IbD{NN;XJ>DA<4)$r`PjN3XxPkd0@G$Y%5YleY54U`}4SM>X!EN^bnr^HwyjsjSkKJsAe!b^6 zsN46ujrz5Vw0N27ov_u0!{Q>q;?gUnrAwCKGAuQDRfOjwXzilc0?s4Z$Wn{QNB7&*L^yGe+Y z%PTTw^F#Cgx^#DsT>EidzH+LNmr{9UdS{g7a4h(2j*#Q`0UWY^p!Kni{A_(Swe=bt-`4ANhm4(FjP9PB8i)! z;GmO0lw=#a34r_wAcYC&F2X-B1H-dzW<9osLc+V>F!M)EFm#8F!-_0k-$SMLoKpnVbkp-=f!q&Pu{J4R@-Ie z+}TGQLhey#e919XTO)>h!rkZM?xW76X2=yNO(|i-kDs$JcFyh07Ut!`O<5~fbX>-U zt*}gpHbK(HriGq8o_v51mrDvf+u%?27c1QJyXc3PEBsnEo8%(B-DkRMnaxDEzA3<$ zf-l`AiK8!xaQY5Oa8MO<2rfyH^bNotl5{=0nSyAN;34nybv4&*y!aHM)PpN;a`orn zBMC77Jk}qP#LoyF*S{i(6`q@f-_y+6HKq#qI6`rRx{a#XJ#7Z|$K@{e7lSC!U&}z| z)ARov{NJztZ@H_ZliyC;0k|psGI>Cpb ztw~8$Y;{>SvF(^}&}y%*5o^P;ahc~KBJDL^)v;nY6?uu6WlN$Q&;2voCK8Q>;s8uv z+CYD7Si?h6IuS}hyx@0OUR87lTT}>5!Kfr8Y?{QBiDOqBTM7vf8;4>#oiLw^C5?jNG6SlE-L zF$Vtzha8>5tJvI-EjU#jGw-j!KV@x{i$s?%CZG9V(HXY9q&c=cp&7P(N2l5HkY+!m zZ!uCX3F+aANlFH@La+nz(xa5|x@OrQQGs#%!4i9i!mQun;zbNrB`X@erXpK@ftV|X zQ!Zk&!t5WxjueSwEcVQAKy9jI66i8iZP|)pLm%$Z*)|nxR1C9}Gq|F5ZNDvEKUA)Z zJ6rHrZHtY&-aEs5hjT3Kd-th(!lvh%YGTF4jPQIGd&j72aG4d|qA?Z*JO9KXHm0*I z_sH$!7m65qguREP_d2$H(F?Uh>s&vdbx*QDk}eZ?p(@0JpuBtaKu2U;u{6kJqu^asPdw-k wZaCmi^#udoT#($?@2k8$pfW08KyF09Oh9)S9_!sLItMq0-k`JSiFS7OHx2oD+yDRo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-EVENP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-EVENP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6c263796692b52754406f1489473bb469a6ec041 GIT binary patch literal 769 zcmaiy&rcIU6vy9gf6$he6rzb3qZ1M?8>g`ijaV;^+bM0?&cf_0$dQz-ZBp2#KTM2~ z7!RJ-Xd#ka4gZ5z#K^&a$o~Lmi%|jxPc!p7gIZEYuXK~s*Hxmg<{sx$)}=_Z?`#j99VAB1U}yW~eUyKMNUz`N%FXh! zJmyQqLTPC!m#PrUxN!ULn?mV9p;Rp9Qs>7XSSj4yXXE8uLGScQoB(CQ34M>&7E`So_o%{GlJ+d-9&n4x7%vFJ=7Tvy2Al# zbb6@Y8TM)}YDgTt(k)J3uM>S^=}~UlzL2T)-0HxsBQbRQ_3F#JDEAPNZm-pr!Ro5K z<_h=og_V`1=@PNc3EO{b@`dGlg=JZDete{4Isj0Ev+zg)WFP|mftS$)wFNF2CdG_Y zsOFD+FCo2P$EMu(vUxPKA3sRAIkc=dx(OHdh zZgFfmV$%^?Bq~y`h+e4kI;S+HYM9{4jwH0X43+kN4-Bb=Q+C;-7nKUHygM##871zWJO`M4o6IV$ z;~z}!e~nh(v!4K?);m^Hl_`Mz*4OKsV-guo0b~JAz548^mGg3-#)D7(Elsyr*@!B` zD}V!m|(R3p870jt{xGY&8GbijVThKLCxq3rbT9}C?!*nbqF{d@k zxy7;Nh;>J3v9x@U)d<_dW8Kz5$(t)&YFjb}5KctBiq)h^qGItiBC1g`-Qk?F3o{6n z2U5TGk3%OmJ$DZ?6J;4oN1en`Z~u;KJVxmpA6Ky;CzN1O4s$M?Qy&NZ9pUx|Xnv2( zqvp2!iw)%Mo`0iA+gnhAFTsH-y>IKB5<&5$^rj&wC#D@{qH8kGhGPjD-hj{O?Cdw0 CLFEqs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-PLUSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-PLUSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fd3987042bf097da47e3e77ea39a385239894977 GIT binary patch literal 769 zcmaiy%We}f6o$`CF3q({E08EcU{&g7gd-A)C}D${I=4y>N~J4MRdUn@dm|{AgIcMmF@r7|2f||oDieJp`!JWVE<~CGr!jI`NQ|9ftMTGC$~{1&Kj?JjW^GL# zbA@~P!s==^Q6!czbNla`eBsXBLOz#GoF5-4nH~T%;Vf9<02v5@ci?6;K`nuc6@y|% zYE<(ko*R=a*tRJ5+=VH$Ja@VQ&h8Kt0PlkvE80vK6_a^~%4;R%y?4_UhU*fI zlqjgN-!6f>;<@Qu9_Ml0u&p{AA4Q)8MSN|aR+W=I*!)&ix8|=eD3Q+TGl0c6b19{L z@}0^3&&kF+_5)zje#@$=k_I?vf4RCfMUmkcKnmcj(_EaiGo1{m5$~gWL(@&RUI|LW zWy01C%JJihR9MN<)Uae;&~zg7GUim+T-K~lp`+HeC1_1m{=Feg%}<8r{CFrPIp;OX zxyi9`|g{smdS~Pi$h*FSDw>hWm!VrAr zzSOV$<4Y5ufZpDe*O!z C0Ojxi literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ZEROP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ZEROP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..96004e1efa336bb4abf8aaebb374febdecf8c934 GIT binary patch literal 769 zcmaiy&rcIU6vy9gX=!Oo3eiN2(FqBcjnmkQvDS;@cKVBDw#?3ocq3)8O$u%L!^9Yg z@!)BV79!cz@IQD(j2!%j{158vVuawq)69I|%=f*|dozaUQ{6y%cc<6xIDOO|4SS;@ z+V1wzpgZa}9keZV^h!55eO)E`O7>xH#<~z`_MOe4vxUUS8EkF7yp3`X5b5>X9l0qK zg zX}C&Q$)FrRu1SSeEKQw~%yXJfgkHs*3Y*KC^$;7NgsJ(-$h4n`#3kpf zMmaY*Hf_YqXZs&+S%XC{APYLGlb|f!$d}VuhVR~UDO`*JA*!| zx4Wp<9(1cNs!JTbGAvGC=ZUek`Y1JHU+`4B?rz_$Au(`!wcVF@QR*Qgoo=%wjg1ZY zO=a$o7wUEao36Z^Z>V+jvrGoc>_a z{x#fs&wc_78}C?ARptN=8(*()kA+Bg0w4)+-mEST8(LEXHR^xzZs~@_HVa{6I8WH7 zNjZK}kO<4!x;iBlFX#plMjmr294`;4yCNft0JIE=?^S0SKnTQALW9B$l;!iHKZS%y2lT?7|8H<$=Vn z{nKF(n@-q+*{MzGo1+znm^hs6-*t`GD5<04Hdf?@Vk|6TE(J^KW8b?Y++H6oACP5K z-<7vmL(Tok8HL!visFCqk5oy1+u)Q4iZ9hS3xaZD+QDoXChJrjOVHp3d`6?uZ?>G} ACIA2c literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GEQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..af8b81891f8f19edd8108fe7de138a0728994ab4 GIT binary patch literal 765 zcmaiyT~8B16o$`kKcR(ei6&xaD8UP__UwCR-gBOFW(={XhKY>sZm->O`=~n__C`b0 z?Do;1JL)%F)Ra1UX;_@Tst{u>`!F|cU&=K4?)K2#L1N?%cD7&KMY#uv^!n|N3|3d= zZ?3SCFDx%-r%S{(FWmlnCttX?R9IfgPM;qiDOwi*8gLeVrT{dEfPdg=x}dherK(9W zBXz3#W8X_k7VOxR`(7rGhTR_SxX;~Ah_gEY1;GE{B})!7MAc&cq4HWu`|rJ(D#Pm% zjg%><$=@!ayCUOU9xvfC-GJkx_>-`OudUOXaRNlMCDopNq* zY&l}x5qe}wUP$YNZQ+S->w(18a#yC7hyVo9a8!|+G>MliUMHd)7Bd{qDZ8|SK)EmV zYkxTmV$%!vAQdgjTv84ahm-xYtjQ9kact7WqTElMg(b}SU|xOXdv}C87@~!JvVfY~ z@+Iz|_TI%K3bp-3#sBOds?z$l!6^|GU#V_Z1?9xFgH(7-*4c0@L4zCc37wz+0_I%g Ae*gdg literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GREATERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d315d2f4a8f2588a5b5d0625aae9109c2dc6c582 GIT binary patch literal 775 zcmah{T~8B16urBprL=_wy2<0&?Z0m_xqB~u5qc4GDr_!g>to*$Yu6HVQ&s-GAxzDWho=3RP*hr- z(fgc5QfLjN7E#&(h4Ms5UeWoVzE^dQc=Q%#o2t-T{r7BrN=69NTjrh@_~d9 z72?3j2-1qm2K7I1Ek*ReAL1W`b%LNO2TmTpv-{3GGdqIFQ{6y%XTRHOJ3Z7H4!Xku zYIJ(2-x>C54r)jpz0^%kUzLcyx%x02w=QLBJ!fy=)R7oE{rcXEyD0qtk#4Wmmchn` z{7vW9Gr4SbHC`Z=F?IXzolI^mn_F97jgL=HlvD=*YH$&JW&u(V0`JI8X@Xh;7s>|3 zjBHWO8+mR_vS8by+;bN)Xwd26w)5O+2RQqEPyoCSZmeK4U6f7c9V@Sur1##PD>J+; z(MXYk8vE@MxGOSFXYf62&?=msM4tpLd~Kdrl(PeEsmP0RtnUJ_tCwj=_bpUgT`=) zu)IMzeq5FcD_WWwmc$F1PJ~{Kth|ua2;0RI-O_xCn@V4q+Dr(*4+o@ia{~m=A5!iEAW;3 zQor_>LnjuUy8DT6UglzQkT{s^pJh#!D2*eNCRXHrqAVz3Ecr|7BhS4foc;hUAChI% z*pn}@j#>xPM-*s>D~k8oJ65IjZJkphD85qNC=1GoVfl&Rn5fgc5QfLjXPcx-Dv&5bu&UIH#a1K~QNo4A*?iSmr|UJP$0&74q_m0hfrJnh z;=suW(u&Fk^*?YeMfAWQ;va-{f}kn~PF}yW^UgdoJBG+p-9UPGuh;H4ebgNdd!r%R z?e@{2JL)$bv@3P=Qa3q$RVMnz>ci~3bs^I1JB^{UgT%-g>@;57M%f35^!n|NJgl$F z-)#O~F2A<6I$tD~F?0KGPA-3EEuWP+lapg5-35RqoClvdfHZ`_J9N{Upq9YJia{|W zHL7`I&y7nKY+ICjZYGC@-5%~Z&z(+yvo`<*!296Fi#F3m#bn-*@>)rH@7+{|;kra4 zB?@Z%w@cuzcy212!*{VkEvpVE$I&N26JJ|rRpoRaHosNXt%d6uCDJ~72C(=hmQ-4& z-{*{eN3Cs3(3-0JdqbF-p9sbLxlmkkE@+f< zlVj5sbz5kmIhl~u2;0U}-O_vsoX%dFTPy_Nhl62-s?sD{GwdNP<*MrQ4y3A!}1fsHCboVHU;&s!6!7C`~sb| B<=OxM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MAX.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MAX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b0c4dc134051c2520330f36e59ed2e06040506d2 GIT binary patch literal 754 zcmah{T~8B16urAkKY*4Lq9huF6B1rF4zU#@))&WRN?W$GFgu&VBWbsGlfpLrFfm4A zeDG<{0BH&OeFZ=)7&|8?>YC}xg$ty8zwURy{^}Bd&nOSy2Al# z`90M4hrNc2S`tUE42#p(WnyeBKgmzoS6&)DcX!}6kr=xD=I+aTDE}CdZqMt;V0Beq z^TmgS;>ybMREgN;CEI^%3dQ>?#e%H4I5}2wJ^(b}JU%7?a-czY802(8ZGlS_lVV0{ zR1ZgCkd|JsV^bamvjsHpySU@Na67S`y*?-a;m06da+o1177LG*H%cb_5M(P1Z%S)q zor0SF!xFPAGR_z916(89aB`fi$1QwopH-F9ec1Y5RqHdiXO)C^_8egDZ7QR*Pk%5O z{~B$)XFmZ(?RTuIDp`QT_SgCP*hox~2FL)MdyTnKJLlyE)%w9 zQjVWhB*NBhU7e7YXLW-Jql`Hf4wo$(W6w!@#}>4vD*t8(OOK|tR5YojrOg?ga&B>K zIbzchx;7~bGCE;9c#PY6B>m>{*T$C80HTR_R@#OnNtP^LBcdFO84l-^UHOAZc_i^0 ze|;FlrkCup4=l?QW2q(i4M`RgnYW^OZ7mG4@wky3Gs-^=gS*1*576QPSwyW}xqeOL v?O$$Aj2$c~;g|48l~M}^r$kVEP0_3f%86-5({Y+q-Eu5Jqnq$~;o{;qV6fkz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MIN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d6ea5edf58bcd29ea7696c13c056b0a91ff5f156 GIT binary patch literal 765 zcmaiy&rcIU6vy9ge^Lrrh$do;PDr?H96}35tQW`a6t-+Qq|l~6OpK8j z51!U&A(CAU|ASY=$iaWe{{Ux;QGy3g`}X^0zVChBn-L_Q8Wu7-yWLjX>!HqY&>ap? zqtiqE&ahYWP($kIrD1dWYMmGxiw|=d=TfHD^Qr@{j>ORG*Q+n?qTB;Sy1iCg2CJ*` zH&?iqFRZLAW=h1dF5LcmCtp}vDJ(B7X3md~6s-dQH8_ht695{-AUNz2{y#!rASE0uX%g(MD|sLH=5gsq2@u~aw_OH0aWopNq- zY`bF96?$w!UdZZ%?clNQ=%K{ba#yC7iUEZ2XjHMXG)b0hULj&FDrUHxQ+8kj9 z*Zy)C#Gx1N;bgohb7?t998LDmvc^l4#))wg3vxe67L~B(!a4O(;NKBme}Lxq$vkRQ z>J_@*mXMVwAvzS2OdTnfILMoEbypnQkDxyW4AboIdJ~hP}}c zHM@N@=#Khz2Q{URUg;*MuS-PVSbdaESQjGozOyrQ8c2+sL1X9TU6g)^NUz`S$j$n? zJf?GNnOruznkW#Tnh;aex$rz&mhLnxK}zg|b00 zBUP$-W6zCA7HnITd+tI84ZA(uab7r`0B3gq3V`>~jTLOBi?YeQL*yW+X=bOztYjBeK8_$c}`sNq}dw4$8s!RGghx;1}uL5Z|ap93tuok=RK zlOIg(e~mZZv!4Lt);m^Fl{tWe*4OJ>QxX}D0VDy=+V#b8E7eYc8u324w=~^k`EpPh zE)kYDD92CAQej0)Q^OK@LDPxQOPEt(b6K)JWsX|gmY`Ktxq3sGnm-$w@#CSG#GKbC z=O)LdEo!#VLUH*ZsS&n~r@E#2k~fvU)V7%rfFBNe6{<*+Xu;%FB8ovW-R7LK3p4PQ z2U5TGk3%OGJ$LtK!+9Bt2c5)0Z~u;KI!5UnnO3nPClqBt4r9q*QXhNn9pMayXnCJ3 zqvnqMiw)G?JO4(3w!flyU%W$Adf(PLC4%Bh>5a0WoEVlr8(folHf>W-{|0JnQ@#CkC6GKIpj3%j#Hj!ju?lR}&RFfj&V zIOt^!79!cF;oyION5sg%c=YVmgNcbJPhN4Rhyt4E!NcUud*8fo-ka}D8+mTa3NKfe zYvqbn=c}z|t<~h0s&&3mZPkkwzeMBweOc4->ZBx358p`j7$=Zo-6}M#MV_>*#$w^# z6+U&HmumHLg>J^isGG`;rn8yMa8FJ$lq0sk=A^S%GuhG6;hw{tZ7y6z2o=!*Gk%1^ z$c>y$J1h`v5HXimu&7EiSa8~o?W4Vjrh#?Gj->f!wI)`qyHHceb`my>Jp?2w^I_2U*bhjIykFjiu`Va~tbWkqF zJ53$)y*%dY{x5tScg*Me2foeH?zuk{*e-?3VfHFd?S4Vl)bTufI&o4`#}%xLxAHWi zP8fo#8~iR0U0qb0h#*Tuo)mRVOr5^1+!4oXEEojOxVYa>5KVx9+Yf$si0aWRU|rXA zQ8US`Nd$L*CIkgZT@X8QLjWpFWaO;Aem6qU#Z>h(slHGqZ%)%^B*NU!>{i*-b*!G4 z8sHfAfnu>=&B>C1kFJ6Mg8`z%BPSN#6?I9K{5$RFH8LB*cXY_ zX!3(=(jdQ7pr3V-FRvW^GZtGLV#i)M&z&t7r5ccREDu7P9WGE11|V@0`nl5)^z72%;de)WM1ueT literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4--.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4--.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9a86d40c44c73e69003ec021c44e9473d933aa00 GIT binary patch literal 1103 zcmb_b&rcIk5PsXz($ZquQk&KwZb(SX#z))&5$nOM%PTCjyRbik9GkM(CWSWrVPXu# zaL~&dEJU)S;oyION5sg%c=YVmgNcbJPhRo8A_{1t2M?QhGv9pQn|U+aM!wr}j+d*; zwQ|L-^VL?f)@t%g)jHp(w(3QjU!rmTzO3nFbxM+FhHr>H#tEcYw+l^skvCg*W3h1W z3NK#grCPmQp@;Et>WZ1MbY^sPxF;(axg)i|a?+WrV;NB#?m67q<|0*uP!Sz46GSM2 zyvW^jB7#W_6K9ni!K#!eg4=eT0PO`^2GLz7n&z9;8m`!P?FwsWxq&!@+$T;TYpJrS zXsWx#J>bIbhSRI4c$T&%O%mh@{7_-)oa^|-G#HXhW5wA-7)7;()D!iWd z%*QT7IbV7I4nnc@?sHse?~O{&U)wW})wc+>OApm)57$diyNUTYV^cJMP#B?uaxu|q z>R9jPv0nFo(c`#dy}&={ZI*V=|DnKkDN>HGS9$963$mt8DD3I*l%!7Nh>mY5G@?!# zf~OmT9v}U>=xm~bESd5Y)`@B9^ljzNaQw!CVUoOu`#r)Ec9K2c$ft~QFbV=sFs1*(v19EMCP%C z_p}mUr*!7MqdVwVSzS5i?m>!~t^nYFC%PU8}8jGzBv9uTNb9c)_wFYFJNG8E&8qO&u(WRULA(lofp0hNQ dK$3AcpntAIhl>=10Z872e(rPxJ-d8(_#NK*MNj|$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1+.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1+.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..26a3b123e436a15741229cbdc871a5866d38c0c2 GIT binary patch literal 752 zcmaiyPfrs;7{=e-rT?IimMDqF;Dm(B;t;oii1p&QOle`6h1uC4N762~Nuf>um>455 z9z3nlLL{>qzJpi9$iXk_D+bWp3`YxjF- zx79)2R=-mX(5}+aYun}YO_|th^G~c%@5)ZK6YTVY8WR1WTibc{09lU_X?Ge;wOCqG zzgBUvP+VA;A1x8jxpez)O`-U3u~=A|AH6s^)^aTXsKR;t$pGZQ0C^bZOhG+?OBIJ= zM%Jk*2Qo}67VLYJ%P?O+y;d7HgO@=w#@XwF1|UC$>5|WEQE{0((%x!W`7s=?FubAA z$O;8L{nsUS*JPNo3U~oqb8vE;+=@H+UO!vaPWNH+$Ev1}(0uIt*(6T&s4F(VaajI^ShFe&FQ z$F46nd|?_HRgg6a+r~rPGb4qYv#w1oWdKAY@u-Y7Ws)qpe4U7L9A^8RQ+DMFBJGjV zZ~f!2iAOKpRUcTDCx%h8>K2kLHgfJnQ^v9kGx4;MHHWOHGQ2N>ZV$~IkQubQqaI%k wHTEyxO{^WvYVxZ*(pA#5%_$KSUkh|9f^y<`(O7&;g>L$;pwVskGJSFJ2Pn7RjsO4v literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1-.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1-.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d291e91ad3a401975727b77bdd07eb2b7bbe4490 GIT binary patch literal 765 zcmaiy&rcIU6vy9ge?uXKXd=ewgoMk+Y1~=@){Db3r7g=W%+87&N!i*ag*N?RVvNLi z@U%t?k?d;tAG{()4*o;_2X(eJO5osWX1;Ic``+ih89?lrVIrfo-)=PB4r=v#?S2o{ zS{>AF^*dD;)ufJI85XCnOT<{uKGrAfOOa~F-R-%1Nc7$A-tNo$NPmP#yVGdO&GNE5 z>V?HzA)n7q6p3w)-TwO~S9q{kc(|0E7@nRenHB(4;UZj802zpYf8=E}L2ZGHWs_n? zHmK$gd@m_kuwzs1dowxIYqfFHec?7koc%5+0RBfWS#+2o$`gN^Z>;SgDSJdt4+cQe6asC`&_H81q)X#n} zx&Jj-f6smb4C?P#MOCH%j_O};ZjU%*I0=vjxM);o2lY%N18U6wi>;Q!x^RiG zRg-eOQkDu^vo$p;foC*>2&05K6%LmL8zbVly<-cyp(@vJ2ulklBZ(jtNlM6RjdE^r zY&l}n5n3cAAEY(HcJN5IwLsEl^eatEL;!+l*r`ZGn#7A1-ymWwOlCNoQ+8AV$-pEFd1Eyv6Sts=s4``-(ii0D4k=YDi-8?;w;Qz&INPo6W_Zh+-?ueACh@g z+m%0Y4>bOHy9TF3P<$o5Sr(KN(+(!XYckK4V+k7Eg3o9;{0)WE B&a+kf8_O81sZ#rwJB=;T<*x&Y9C^Kh94$U+4CLocfdY6)Df85A?J zMm2xvdkN_U+ZN@%H(Nk`w}acx3#T30+3SG<;D7WIWt-`uW-|Xsd84HL58h0T;dN<^ zR4Ay43zm>w@x4sGfQwi+S>3J>LE+>${xlTwt$9{gPWNHsdtKek+?-Wnt+VF4w}D+cBGNlhZGVrgnr`kvKvBJ?WeRM=eV*2l)<)|MscnyUPJLzr5SicAI5k%aV` z(J1F8$EGdTZJ|Y`<%6_F*cKk+mKI3U+5BI#n~DGg(Qsgqx+IC0O}<7%C2XeKoKtos zh(LKD@oRs4=)|HE_8=8qk+sa_IB_`T%izX=O8VGX%A(9F&ca5GjdV z0a-x1+wxcLpw|B6LxtGEqT+w?k5t*$2mgWLh8Q{c7xaI4^_q&+`3$C zHEXS=yj-ozjcTjzxbiad%g;5##4mD4n;XBA?6uBCoVvTzbc-@=xsBq|vs-d zhsd;!P4!-$dB}{Vh+(GSprRqF+hhu8T?u=vMT_EjQTR858cNU?in4$}{;17$ z3dMqWD9)6W6l|J?sTww2u&ELnV7dJYB8zI*Zz%zjG?BcpnP?aw2=jGx1>R*qJz2w? zN0jTm&53BXX<~A2-GRVkn=Cf`cTNpi__R~d_kg3|`!>=S?gk^tVB|(H66Q5qtR~JE zs&eYVrKc=0(xq2px1)#f#(FWhBJ$){zIUCvjix-dj>hEWCH5AIa(V6a8gt+JO~K#y lcSHtyO*1i~SiQhU&r@t7-3t168tZl6HYg58;q6$b^9u=O4=n%y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-GCD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-GCD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1a7d2aaca9532f24902978a114bd6ccd55b300a9 GIT binary patch literal 765 zcmaiyT~8B16o$`k=?AosmS`fz=!Arujnmi$BGwzn>GX?b7G`HfE=gHzlR}$*m>455 zUU;=e3z6(<_z&J9MlSqA{)0N(8YOt))t-IN%zMsr&I}>?l$waP_dCs&+ePg`zcc8g zy>=J%+JkQ0MSDs|FR3Nis|ulO*@w9q`%gqFt#Z7f z&`6nqp7`w&x@#)V@50gf79u5XP&R5}5W0=Q__=ZB4SGYxvw|LEN^sKtxburXXA zyl66kA6J#a%eJ9UDdLPliKG=Qm~@2dn2wQS_O>nAx~~0uLRvO#sOd>fB-+XxhHI(KDi@d!XL6^<%WQzo&JCDw^7hsCHP1ml-h5NP+6 ze(f&@B{rM52g#|T$|ckwaX8sO%Nj3H8Ar!WEUEp(cv!+*2p055zIR8uy*^qzB#UTo zN4>;d)I69xqEI_r()`cl30uJ6OiXGyV}o)E?WvPX(iJz@*s>3!F%rUs zH`d@FkXGTse_*&nj9mB^^ndsd<~f@m1TRc4dfu<+ectCirv;J6nl5RTaYVuXQ2f)ZEpEo0mw_t>;&t-;omcB(+*A zmgr$-hMI}gbTTzHHPM?^Exn8O-|e8`Cv0C3=({o(*3guvhPM42Fq zDCw+@6s#^H*>Cw?jLxFi7BYQrFex=ERi)%UbxUlVaveAT|E(8G+gKx61N-~jHrMa( zdIMRkEYZ=_IRt#{7Yak?d@r6zDpN`pYiT$>jP6hh9~h5Mg|m6?bQ6v~&+|EPbdZaz zJHkmOCv1FkgpC1!lT`Oy;+b(fCzK*IQi?KbY@M3X?~c$u$_eE*^_Sb!zg_tKojm~< z+KCEW;q(ip=O3+wH~1?+tMCfX^Bm3HD}20~8)8goI0n!Ua9(tVTLrNw0w3`Yylb*% z;Mpu2RLQ7#R!64tFiSmn&XV~sRd7(&RH9`R6A{~_3TPb(d#n|UphcehH-i{*&=-o* z0Ehpm&2$RIf_NxSl@w%Tnue(uHd(TX92%gx{j!Qzl#bt$11hPQxU`vQ7$69UFpZ20e-nrfkLr=af7%Q6n?v|6aOXH&JS@F(j{tDX~h(5LXw69S~lavsk58xjupZ!N;cS1QU}Kd zA=HA3RD@(y+=yrg)B{Iu<-j2ns1QP&svatVI3a|D#0`#|!kZnO#tjl2d>Fmi?|a|3 z^Jd@7wjlhHS=7wx_D*HXt7+9neWy{^Hmfylx7w(!d)g-A+MA~B&@1zXdFjIQ*_eBb zS+99(b#Fss4R3d2?Tx3j>_yGksa3XcGChrt*_r2ZGZPaRVtKeB|s4J&Wr<8Ez&MN@vYrScueDJk}^FLab-nYI5XqB&93#!tG zv)jWfqe6{r1Rw!$x3WGKl-2h8rtR0;6+b1__KS4KZ>{YY?T+7PZNI**_^C?UFWw!$ z<+fkqfB4-j-yZsx58NszD@jlj{)f#`-L$RQf@nT6Z&W~);h*)#3uEu#(?ZXkp z5y8=mBaGt|c6&-U4Q9?0hq97`-D(Ey-s7&ij4rCm$qZ)eJRXYiXs91MykDn|V>`qy zv858zLyw^#p&QmJ32;~E*y^dNM^8*F1i(*;b221aUq`2&yzML+Ogx?!Z#7GfL#<=y zkSl_F9J#@V#hQjo<*RrcY2_!L7U2gzAj0>2P=xm+cwK_8OYouuCnb130O9ulgx>-X zev}}W;JyUk<%0#D&hvpOJ~)c*>RDXT89c`%xHeV_Y@XzZMdw^HTUsJ{!(_H|bcKi< zA&Oze;b4ozQy6cL9!u0;6zlzqXGC~_#$%nvSz&z4mk*1?ulR@vpG(=NGQ1-;s#7hO zB{kbp%7l3VbKaK_>-8x o$0hTYWQ>!{(*Xm2o?zf-$$WB>xxuyNPV@z?DV+#>G<|sZH}-TBXaE2J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-QUOTIENT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-QUOTIENT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1330a09deca872db8f22125a05323c7e2b7263b6 GIT binary patch literal 823 zcmah{&rcIU6n?vDh3ap=FR*0ecyXMh(D$lqK&O)t?su_quXhAJ7}}f zLhVMkRq@fL^rIKl;q2uCp-a>Eb1C<)NTubkcl-?`x_*0O{rPQ_n?`4FIUXsd|P0vJiuCFUT5#xdN9=i(#8A zGb8MUK~i$Tp38U`jOJ0N(ZqHCnO|3Qw%VWpgztl7$+M|29Xs6DcC}3SE*Lg#T$a?x zJOe%XtBdNcg+VHp#|6CNIl^SNfWw1?uW)>+9xrM~+wkP;qP{vZKB~pHen@O8Gz`$I z?N*PU0*t*H%xKl46I)Z<+0bg`C5D@p&A3m%lX?7VxFMyi^vc*H7SlV*B~GisK(Lmg|tm1U{lx?{DC zKMPi$2Qok22U(CiP1p*8bt}3abHd=J@Y@|UxkDz==DNJz4OH7cKRo5znVNWgBKM?) lpTd1zPPsujBZA>e7%fvUPAoS{t28-Hfnm`&e4IQx`w8`E^{@Z{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-TIMES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-TIMES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d0f26f6a075463c771ee2e83b59a35a71067a7d GIT binary patch literal 769 zcmaiy&rcIU6vy9g>F<^lqKO!z6A~^Pr?C|j>&0=ImMz;^n4J|lHtk}Y6x#HMi7^u6 z!P6QoM6#>lfAESJIrtCxAK+{;O7P%mX1;Ic``+ih8AJ4`ZX&(A(`$F!KI)E!z0nYD zcl&729rYV7+Lk(csau@BS|$2g{$U|yUx+mNZhh!Bkr=syX8px&RCs_$uix&-&GNE5 z7D`LS(&A!1RVKE1?)Kj|#nPR7rMpY{)Y;LYlIsFM15U#w36O&b`1@W?6Vw*CY?u@? zQlpwb_PvB;!H!M2@68m^u-n5O_qp2%adrlv0QeugMA>1wFf8UDD6f@_|K7_Q46jQx zQlX$Ge!GP3itl9$MZAcGQKL2-9mbx7MSN|YRF&gh*!WgeH>a=9DAD%GGl1DQ@r=?s z{?6q7=XmWM`vEX+y=7HZ$pY-RzFgg$pvZ6nAOmpPZp@BbxpofJsQ=Nsq3IS|F~ZXD zDq$-o<@m876;`n|bxJbNXgU%4D&|x;T-K~lpkwxyEoeE#VG^Xnv2( zqwTun%~qpC4%Bh`AtJmPE0#Uhu37D4aX8RxCWol+1W3j C$mP}m literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..134ccfa58b0d41fc6f2ff579a725d2cd4e6e5f9e GIT binary patch literal 1002 zcmah|-%ry}6u#{?w!t;7 zTt1UE3S6#S%9l%ADp%l&xpEznB{QUD9+9- zoZ*CvoR}|UvLqN7AV(qG9}4&N^)^REO|Gl`_nlDq?D=q?(A&JbvCaf@0DvUep_>}2q0E90uU3~XMbJ6)3jV)i>(KQ|){tPThbfJXj3Vn+kdy7$nfbp6@B2|(Mj zJHVv3J}V^tQ5{`Tz5q~7-&aOhhR|2jZx2tlQ4Nyz0N?{)CzEWirh}OvU|rT@vx}D! zN+eFphcQu!$Vi1lae^qr8qYdOUt4)e#8M2Z20Eo9GI8e34raSL-NzE zzac_R(S$lCVtRZfsCWnk(pv086j~t!SIsj$-6NN&NuiG91^bwfLeDL;8ym$E z*Rv@0aH$#c>&$YQ`TDJ=*y5=hmB@qk$n{G2Zd*>N3^t`wv5LsPei5k*eEraIp)v@6 z;d8b4MCHmiuiRaWJ1DL*)-!93CBBYJDiSe*2a1&A7^$MH*)5btyiVu|jO;G(^yKdD EZwUe^6#xJL literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXPT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXPT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..97023147c8b50c1fad89f3b90cc9ff2c8864ae7b GIT binary patch literal 1028 zcmah|TTc@~6h6DX(?S;FJqQa4Az9sO8&IeZFf3DOX?M%+Hh>Q%q%5|vP%Op77ziPi zr!`oJWLF_3zL^+fd_xR882^F#J4}3*I#aw( z9xW7ed2;CMBVs7h8;a|Euf3TstyUlO~0LZ{0-FyHXIKbL8 zIYGyoE=FSsEXpW}1*>A2UXqKL*05@s&0)S&SP=8ZJtI%knOg(~zvV~T8T zF{@0#+AteqvX~;Np%DzM_oo$Vov}=RC@l7hArVieblBZ?uaO{L(@5TB_v6goJiL4# zXD6C2G&3%$J)p~-JS#W7jngBYH7SxGCxhyPf9c!mrJZ_VHT!Gq-v($|^8}de-hoWc zUn^sedQHJ%9U1qc8f<}xjnESKYeby-i$RzXta;TX+Z97XbQ z0;}RsjA-N$O<r~c$5Aq^jUvi(kq?-1Nat0vM){%#H`Q1~J7 zEz4}zjl~k*xq>?R*=h0vX87Fvar08$O4qIO00(e$-N%iW5f6|oqxR~NR30GD2i6(( z(pt581l_f@wLGv2aCRFm4x-PbgK3oq$&SeUlxIo(zI^}2fn~a-greaTf!P`<))s4- z%p{pp&NC!nw(AN>%9@;|`Y)+oV)r^jH~Hedm11FKDS2^ntYkU>P=oVunFh!}1pGrUqX}vYTsBOK z8QG+oKk~hVWWkP2x$kB3Xwd26w)@;|hd6tEPyqZ7UZU(UT^JVgkCfL+%75>r4TiTQ z8d;;DCVsnw?uzfFa(P_9Ic(V5T)@e3{7G2G*XCJ8Io*ftZxwZC_GVUzwa%Ua%)OaP zDb3UGOzwYF-99xdqa)cI{mJd=IVY_&&+gc!zGr23Bn~DGg(Xd^SiZqFrExt*_T9{0CIH&B= z7y{+K)UW;J(1}ea?!ip7BxC7uD{4Gz8_uw1b)On#{B9Sb_#O;1jyI F_ysI8=2-v$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-LOG.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-LOG.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..52cb5ad4e4b0260040e77de15d80da06e4810557 GIT binary patch literal 1066 zcmah|-Afcv6hC+N)30e1qcE{S=xb=iT@+2Bb{wy|HqPjLu=>!0tYf>dy0Wf8L?W`( z%UG>TGL!k(TSN#!X6QrpC*8QS_jk_ko;l}t?vx=kDJ#63pIgZ0 z>;j)(DlRM)`PqDdU(7ER(l$R!{QM(X)A8dGNxs|BAFDO0BI$xXU9@L-bID$unSOYa zkKN*>g+ew*Hod(B#`?PBeO+B0wL_Aj9A*3OnRs7kPhV%eqxNuX195o(NW(r|Y5+J0 zfV=K+f{6`N97-x!RHZR2xMkOgl3qm1z`E-+#`$7?LCo0?>>O=pZV?cG`@)G1S*mO% zHPx-46;$s&cN&taI8IuVhA}YF<192ga-D`)T!I0{e?u%Asgmor?J1199YbXo;j zQwNh&3~@wK2NkS~14-ghhYf)V5|tYTSu*7jQOBmG6P09N=CCnkn0Smq|1wNX@ah5) z5#j)T;^95VctW>$;|knq`h#rVwZ#+BvHK z1|LbH@Q|jDNhXCKXd$wt>sYP25+0(lHzd}4+NUfT_~=VsT`$QJAd|i7T?|s{Hlaod z7HPrWIqKRZl#pK-MHO;?!Yci&Lg7>I5=+;2u5;P67mIxRveeGcPLn@ohR@C)U3ThQ zzEUV9RsiOGYnKuUfN9^Rd~5hNSxQvytzl}P^_K_*Zj|njQ>~?h_{+Mm0bD}*ete4( z2fu%E;5uPEVM)q3;WEBFZiR6jG)dkm6r}A*0|uZ-sps0aw}9MD8eezXWF1Q;7SG6{ aBu%VKis98!8fkpO(oF2Nz^m(rhkpR>!!j8F literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-SQRT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-SQRT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d9bef8514e11e5c0b9c68dc33da0496d59c56b0 GIT binary patch literal 769 zcmaiyT~8B16o$`kY3UbaA)1IWIw9d^;}Euifc3_4nSQa%!tAWbC26;|Nuf!S9c-x>5# zz1>B<_Mlt!P+jWirD=2eszl6<#fL`Pxe}>%y}iCyLt^0dYI`s4BjW)goo=%wH*0J1 zXyjLN`Q_!sbb&b5*zLb>a`~mzys@;HzC1lqv^D@#;UZd602;&~IPx`JP)FcG*`k<{ zO{xdOz)wmR>^hVO{!9+_+a28Uo_nnbXTJvuK=8p&7F=eEvdw~H<+YLx-uqK!hPNad zDN<0Azg;4CCGayw4zFMXJKJ2q=}F>ARK?fEc||!pfbDM;b!Ynaj1q62KLeP3GnrKy zXWyCJ{~T_-V?O|fjkm0#DpLSQjW0KMMl3R%1jqthG^?}2hStS1j zE)lkFQH~#%rNWAiu1-kk8QmnpEMZQC%Vp8#h&tiyI)ZMh%D*>+t%sS|WSEL2CFrzH zIk!2sU9sf~J(iLWvN~bAc%(aeD2X-WTH_{T0O3T`tyo2xBnmd)B%&B4GhNOpyE27P zS(W;YzZ@oU=-55XOsvaTD(WPTy8CBfqd`jN_^65nIim!Na#(ZWocbv6?+LHhNArhd z9@Y2cZ>*u_!T2LZ+Tnr{d=8FP>3!Galn9EirMJq0a$-4QCb}l`Y`eCg;Vt-tE-!xp DRGQ_v literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ABS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ABS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a85443eb78b8bda8371571695c83553041b9a2bc GIT binary patch literal 767 zcmaiyTTc@~6vxkQFZ4=UqKO!z6B1rFPGcJyu)a7f(;Ley%+88DlCrf;3T=8ZF-Bs1 z@M(<}BH7jO9ehQMJottD26eU=CHUae%>2*H|D4}BGls}h-9UPGzt`?KebgNdd!r$0 zcKc}19rYUyYDyiw)J;xbRf)cydz4RDS0atRvpaP5kQh0Gz1l}P*i8Nl3|nUvBx z`_AP4=Xm`c`vEX+y=8S(Ndp|UzTDiNqR4OzAO&#IZp@8anRW)$i1*RGqv@Te{Tp=^OK<&KOTxn&RLCe zZgOneV$&8{C@vqQG{Sc9RJSx=0%!8q`Zf~+@WVl~LUm~pEt`CUh)R%5w>hWm$`E{I zS?V|ba_GdOm+pQtye4BY*+?Ap_RqMcW0b~`X%UNZLQxi^Fy{Sv^|9yP6V70W77ob* zYVOLvxQE&Ym)|JR4i^>gvv;gY>$^IqL{NM!yHOLA6T|Y8!8Ms@%Qgk|Z^0)tnfwAl C{N&gG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..af7bfde0d3741de267fa6403307bd8848293eef9 GIT binary patch literal 1995 zcmbtVUrZZy9RJ-F7===})utTF6DRO=>u$KvXQ`7Nz;j)yzDm zv#>-sLY!Nr+96w0tc0#Px4AXW=iDqcBs3`rsma5X@U^>E&^qUo>U*QoSt%;Xif)p- zn~m2Ahy(;4gZV1^V3gawLOy*s%BMo109WHi+U-V~ZmB%N<+lkzyn&E|ud@#TZ@PZ0 zmCJ5V`pdc>$lo^9o4Ws7LN>DNx_^}CKxbpCHFXm8fnQ6A53J0l+sgO2l>;I0Eqfu< zrdq&ScCrb+LHIU<&q4JNXma$R-rNQJ_x0v%Xfg=Wx}OKVt;cEcvwP&H zBN{nc1ReL^Oo^!u$UWV8Ur%)&&03cOg-dmTwY6;J^Pdaf{7;1kYj1?0kmam^!}4+I zWLVL)!30i}G$Lz*DmA2m1R&b58Rl!4m#>C#4TKfhQbr_$TDAe>rnvK3V@{YB9pibB z2v!DKQK_uiNohzo#>_C|c<%4omL6vH9v?6oaV{ly6BOB`=Kc~OMuDz++HbkH4mCU^oU3d?U$#oEJ~06Ts_l#VBX zO9w&xIIx80F&WgfRSWPS;Qk7(LxE&Xp@5#K7#~ZjbR0I&07<7L^d4GVAM}n@;kLTl z$3sF@^s=nNDsq1SQG=zDEhK*jg8{{cXte{UfpN(D8F<0xt-^9u(r5L^{t{a0KdtE& zmc@kTsTAQ4K+C(I5EBra0jI~3a>7s(Cejyxt~IEvVhR9|KS8Mu8jygn=x)^z-^S3< z*n8~771lP#PRZakXi{rPGAG6cbXD3rPOq{qAKHEfD%D9tAJ&lim9^vJM+Dv0A@w~R zwHgg;;FjbY)`RF5=u5Lz^(q9@;AQ}R>?9K=S@&huGt7Eoto>!y=|$;ZoYE;Pvs4f} zR^<+HW(scpv^aaEa;_0uJq==H-TB11jln3-Uot?h` D@RV4S literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOSH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOSH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0babd0979a2718e3d1b1d11a7d125ea983cbeab9 GIT binary patch literal 2078 zcmbtU-A^1<6u&bIbXi~-){Sjfgb@YF)}aEsg<`Zj3>R1#=5A+ZT}Vs_F1s!bbO|4R zL`8y|(1(pJqBysvFDAYiHIy_ljnwrc#+Uj=HSx(m!9-shJZBatsm7X^?9RRC^Zw4c zzkAk6<(Q_+T7GtJdL}b3=a&}emKNn~eqLV4FU_Yjau)RR8yYj|Tf?e0((z2E&pKjB z&u1nVGgGp?lv$XXeEli8^Q^4S%}>w3rneWw&c0|@UnJ7u8&oa5ob7=zU42jY^mU)@ z@a#fC0^XmQld(i zqH4?4b}u2dfMYuSMCm%Ydj!4k%K`eD z{|mBddn(nGYJ`*1ZQCi_-ge<_F#pyNU`VwcX+Un`1k?;o2tX4gw+WyKI4sCcv_U^E zu@lgQAhd%?BE)U&Lf)0!O71@w|L{K*4=|n&LB~ruiHJ4M2gSy)#*BeDGC~)MwQ18Eh3j-OQ>vyQ;%UCdfWn;{0VZU>x9ym{1IGk z@J3ud;g7xvse=}^2Ni34w4dq9!9-w?9NIk!ZKDTmJBCi*n1d+9GEsVH!`#(-+Hw6m`pP?03#b&IZ!3Ni!+XLboz4tG~#62k{!r0lS zF?_@Di;3m+j=OAM?)%vYQ(bV` z2!wRthLFwD1XSoz`>hvY6>-O!R*2+E@vQ{X$?%=t<{e}<{D)c=0!)FyPgLoMD!B6p4a#h>g F`wL||VXOcE literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASIN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c127ce2a01eee25a07fb949c278f9a02b0d46953 GIT binary patch literal 1995 zcmbtVUrZZy9RJ-FSbw_(I&QiLW!hY>RI`_~?Vi#m9-??-dw96E%b!ci+$V|KFBK z^|+#nN`8J}HkVlx^DD~>E6d_ceo6XeXRDOpL#2W}X{5g9caNqS4 ztz33z(p%QOK>k)zZ|dIf2q|SZbnht7flg_=HFXO0f$t{716F3!ZRNY%>Y)($mi-Xi zsTQ!7o%F%uho>1V-@2juwu8EtgX$sRvvt4T+y(p(^yX|}(ht(Qmj}J=M``i%yX2>1 z8aZAB9rxZ!iK!0AJ>7XvPjw#8T9*xlOLc*@^=#$uKNr6Fp9&Aw-V8t?%UJ=3<&)y6 zkfLjYahxb=MAimXYDfcdK(t{q#MiJ|z8c20DWu4jG9nq&N*XY3iZib@=7ed{F`fqr ze`TN*mC9N&Ar0xqm>FUm&;4E7(nGA?MuDoItg=%6$3OmH=!C@jB06>A^!0e13`C>>7# zmkxsXNni=jV=}0jR4u^$fO{*r4h51mg#!9Q#rRl4rQ@)H21wdPA$(+UJc+CKgk3WCRy+@>mFv^QP%zn>#RlTU+m&(E3>pL zcC5)A;>;A>{AqFaO66Q5wsr=@$cFu?y@|uxra-=s+mU*zaSNKOnyenhAjnHe-J&eG zXcv2;0~8uXE4SGBfmuFqxbJDr-1FUYaf^F#F2?PCJQw44g%}s(AH&imo;}6$&sywa zAU8Gt_Vg46d30dl&~whfz|7cCJ?NCl2@sA;9xx$`$QIWb18aCdpO&)1Tq2fu@@_20 z!=Ry;NANs(>^N%uAC9>3sy1|@>casnzIn;8n(+hn!{XU%gsU#}uY=FvMgjg4hiJDq zYb(^nhY!CmyusM*LVs^>Z=wI%!WV@Hh<$@t8L={8fkO0#FJI*}f=N(j*29A2wz9kX E7mhDj!~g&Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASINH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASINH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..56d9b955686e934a33b6fcf50d74f8f121ace6ba GIT binary patch literal 2052 zcmbtU+fO4^7(X-RTA(}B#$_wQh=QaztUy^1quXIPl*%xtJ2SOxVnVRAmK7Gl#Y zYov5k(`9XDdUkRuJtxmBF3c`2$eEcrd46VbE|r!upqJm!m`UFnQnlgsr#rmX2}^1& zJ-(2hknP3v{KWX{Pskll$?ELf

ardqM2z>+b9ehugh_s-+jR-8ZJQ@5$c2j^1|f z{>=?RnjwUwNCB5hLL}lL&U<+&WK+vl24gx^40VKtoHZw30ktRzi<(Zpwo_i1nN_CJ zucW82oauQY5aQg(R}3Z$&5kj{Sr?XtYUg^sCT1vcC{2x0B32w^!R&&QukPqnx|L2v zwPMB)xw+w8Aw>AGRuU1-SJ|Cm;m%d^>)l~7DFHM-}i*9WmlPRSQOyYwXJi>CPV=C3PP#@$7JfU!Yy*|1bX3@L-bYu z7i7csM6w}S4=1Nuwv)Ksb>Xcu-&PbbBwJ22AUjqEHA55p&;-eC0x0|r3$VHt=*Kly z2Tce-JD4Ow+}0lCUCu6N|8wyV{!{S)uMcU=7>FSwlp)m^(5b2P z$3SC5t&mv8E5%ZvTWv^FZEZ*~shu!^E}F}?GV8Ks(-Bbwk3f--nodr`(#k1pT%(NhF090oV;4o-{YG{;8 zPG0IbHAr5d5--8&@!>Fh3rCjF=T#kr+aQ!->8g$5Ey!7`B>=y1VpO?+wvWLUIBq>w zUj)dj(EKV~jj!2YHUfv?i|Q2BHbm7NH;qfEY=l$Gu?{_EflU4cxzu$+=}Z0)F1L9- zE}!s+--Ofwi`s*Vb$O(p>B`}Yz#uuadj#4>58Ha4H&sKNu!A|{CW{&~H~5qo2_1C=8*BMloglL9T2Q=QdgHe9K0@hWr! z)Rz*>rp0qVck=Ch{S>Z^7GFyD`Cm9X^zgJL>)`zM*EWRAm58wa{*{QhFGWOncD88* zXBd7FvAF*1ZeVCZjNkiXyXig-QdWux5fQ?UV(_i!XPta-YJB>|iE*s^G#lYn7hE<1 zAsx6OWV18|6?)Wu>jhZF=JPra$9VT32o+|4hv@o+2eZbmco zPDgVi57+aavpgK&J%Sf3&#N`PO0SkB=Zzh`q`}=W;W-@m7j(^qemkl#^+=jbuyidlrIy4KocS5=?B2H zT&+98Ev&Vk2KlF2Yc4V#25l|q0lSUgCpjAe zjdBoqCHKEmY<*FR;O9aFLY8wZHt}=oL`>Aw0U0~ZCk1stk#xRa21Fe)Vjdr@_te4| zLorb>#U!swW?F|ah|U~+#+YGBBOVWEgxx`liX^D%6hElxBSwre9_FyMsl{lcH$dyX z4IpgBneon+h=L&*)dfMw8-&3JW0J0GI>NtcYY zVp7%{0zByA8k8oeqC{ESVml73UBE{Ot-)Pu!rh5L*c$0wK|!Vg7#|iSn8-GP%aEAX zbxGZ~*pvYo`3Gd-XAQ-I+$1TkB>4>*9z3OLQ1KXVK#LU#;d@}!Bqk+s*jZr8=IOD^ zG;)z1KL-Y3Lox?>V{D{fQ~14G;cWO3NUS!cYeOpLRR><`t1X}`dVY!;PM47T3+|Oq z#X_(y@|Z^Pc!ag8X+@dBG#m#IF`c692yGjn(JmT2OJAu2RmN*uubP>~A{Sj2qFiAIQSucwncsGi`$t`9 z`;K$s9o^YxbGr(amE3bUnBA1~JK*X5@qPO1RoXSJ>?$3w-FboW;kY}P+2OzrjDdF( z-r0UWDqLFIip)&RUYeS~z8~CT56sBfVpwF`s!0j59>5;`fg{GrBJ-HW@z`>Yd+zat zdt9UO_i22b#)oM99F3o$@i2{(der~3RQ|d72~rP%3fx5Mn=1BYX-jscAD8;%(DGcV z7ql+{-TdSN&@V+3&Y!f|Ykrt~39Lz}cMINnV0ypKW=p-_b#^)oN>J=D0G7(xY_@8% u$COt<4Sy&pTfaQ2+LSxNrkB$7NU8hR?_aKQHjdojM%^?aM%QDwa&wEQ4_BP6B8o1B${}^cn~mn(u*e#8ZTb3e&0-iT8Nl5?aueU zKkxUxzwa%R9ixgSD#eqt(=)j_vADP}ySO0ci*w?9adB=kC+0yezO7J0eP>u!M#8-j zuenJxIhUJQ$W4jXVs3tF;;l|G@}elu&P~t2qNfMgNUS>=J8~rK9gf*zc8vkfoZIG?dg-NtaV<$X>R~wGfMxF;&AZH$=sS z;;b~2dm}f4;hdZ&93l3_a_vw?SF9w}?GimGHG2D2UG4<@!ie z>XxFCY{~jCxx5-ULkRy{gTSLVUly*9aMw<8i#JC2?Ea<(uG(=m>bN@Dc4oF3TqwI&p|*a5NsNt!FJG}r@=zgcmS-apND;Gw| zo3;nmQpq-N521ClJJZ*}x4@a2eO%!hz*0Z3zb|VSsQ+t1mJ8>oe}w12@8z|<*>;Qp z^tFW4LnPCa9hEEGhno`Vseh12-*&?ceSC%7-)^Lx0P;mPlx=|kCd0sdmhH^8BGUzo z4WVSi+sY+CIZ0cg{rt=^}!^LjWjIlgPLkc14)qR2{Xi3 zvpRkU%w$7Iku7CdGE^&Lz)UI5P*$5`rlqEM9xQ_H)GC@P>zTAPM2(agVjRyszT2W9 z=JR+#5paf2a^_u;P1Tel4~HFv9{&@KqD=7YVs#z?v2lDiBcQSY6uaPJGgQTL2V9DP zIPka_t)GFL!XHu%gBlXeSm}%v@&v)OJ|yd7k|W1ZJkNqGpvan%(PT><+yuP)i5kS- z0~)UzWm--e5FiK}w+hj6F9>&SsRo;N_8gnmO$le9a1|bGpbI{#J*MA{mHAL@LvQ%obPDMmlT7FaO-1n{ z?ArOLYD_?3l0Ao{owWkt{stdvFjy^VBL4?#L-GxXcQ`wddzZB%8DJukes&N^7i&RM z14jo<)f$q_vD5(7qzCspD9KOYfLEa@sFLbd!100Dtm94g{0JrkJHiXL{4aQ9+Mo#? zxgQ+&`0FTiii*O|;oYd#F=0;rK4qOKJ&rJXMss8}Oad8q6b|;ek%MoUv~w)i#txyf z+1bZ=T|!vv>#U;=k-oRf2dv!ug4l9eZV~en@Z?U3)2H0m5@n~I=hiN{fePN zb4gnYqa`iq2+d?ZG=l(+WvHdPXZP6UaBM(@s;lmE=)Ca@4-b8C+G%s+{4jd#S>^I4 z;@tZCC*u6N5a;1izpBRZE`t9!@6tQY0xln5)A#?p+VT_wp&-P$I1k$%?!iZ$HQVK; znTeCHPEBC!TN@glZ_a6G=xG}YhI1l}LzEtQz;+n79y6@ntT%vbbu?`ekFV6fL`aSE<(x0+ zuvdH~IG&VVV(e0>A6IBpipSwo$>;N>%HhL@OJAY(#;sf5opaS_eXdkNOVl5=3y$ HvcCQg!9fl7 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-CIS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-CIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2e4e2164fa9a901d92903d7684b8d41389dea913 GIT binary patch literal 2111 zcmcH)%}*Rv{LKt3%L3ckWkuN{j3^(ObZD0r3QG(O!vj`^dF#xq3nzlh;*vlie3%#` zA+^yaZfud*%(Ll#;DHho)3jz|jPc^3hkEet(L)mwFUH{SH_Mk;(_TEx{NC^T`@L;a zIc1oNvAndhu$W&}mN(W{HrAE-Ed1Ez~SLT7Pd}uJ6el)Hd6I}y|kaLQYTg}g| z=jRl6BfmB``@sbz(XZ$$s|$;8=<5SCk?iSCUb)g08r2=MZ0)%^-N{S+$wY5g=-}QR zL0%?=k zbe7hLK!|s{7#z)5hMQuRw~lI{!ED%ZR>mu=2ALD;$Wy(}Jo_H)}|;oUJvAlrVb4+Sis484d#FJ!+L zK!|!Q#v0n8EjL*M^dbgbVX_E%yHCLGR$;5~!j)@yR^=d!x8l&YQb8tSt@mZINi~=? zlEPWk#&v7Nq_#Gk0*W=}sA7OuiF`t&K8!(owk}3jfx2naXRV5HP|p(VD+PhVD@3czci}g+ZVOR^FzDi=)qF>71{l zn?}aeT{?0|m3g%kffWj?)V7(ev5cF}xT+Kd=~`8{rZu0A;YjsBt2a(8(5W<-rz2oI z2CR@D5Q8Gn@@iSd17M$iO;v zNpJyq&A^MDlpgahhskSzE$l;U!fh6FF?hE;5Ys%f`{NC=1_N3bEYSUnW-IJNyz*hjT&q+ZPF>kKSQGs z2A)6h9WZBv$1zl~5Ae#g&Bl-`s=Nh3Jre!0BUT4jUckb-V3~wJc_)JVAX8ywOr(*g zkXbcm1|enAern`b-hr&gzBu{548GwlRX`Qny<&@-Ut3pNH}zI!eimMcIc4Em`Ep0v zW*a&Yyu02G4rsGsQy3cUOwG-d3(YniUV~x~^xGNc(z4^_Q;Ey6qqX#{JA#mz?Aqhzzb}j=H+b-fr22+#zSX#GTmG`yrzVp2I z6@K+4WI#zwWSryub-Z7Y`0Iqc=Iw-TKpw=~kw8Ych=$Us0H8d{2c$zN`tVRj6^|H5 z9jxR70X}dfzz3@UKfx;gAuI8LV^h9n*@17T=1^}C%*StB?fCKQ3csEF0yK+jyn}q@ H931=&=f!Tj literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1500e6ca8e9b081cd8d6f5e6f2bb0a6f725a75f0 GIT binary patch literal 2252 zcmbtV+e;i*7(Zvm%ev~i>Q;;~W|SD0F{9PyYMaDyJZ86!Gn=_|4K0XSH(66}^-?Hl zgCs)xur%42$efnEgg)lM1PYa=Y@rnTP$-m^Lg^n-=yS2(H@j=sw9tYqXV0A9_xrBr zJLlv`<)o%d+T#4u>|A855{?1Px9jrYAe5VXrA zspa(aYI;U;*3v68)9;;-2F^+9((>#ae4ITC%YmU&gF`1z_65gOTQ6AqPo2S`m(LBo za;7i1`)G@X7YQLLlEl;-=wk(sf$r-Obj=4J84osh1cL0!1rmoqE~&fkEYz zGN@>#O&)E9ZxbTC*%%fumM=5U$LY=j`RuE4A=%c}NUQunPxyhRq{7sdzfK6^^@QYS zpTnZ*cJ*PJ*_jIE%@8bq&*^u~&^LtSG9Q|uae)Fcw|ywtj!Ga85K@P#sgC?p`b(K# zT3PZN02&k~H@lws-ws;-%|V%U;bzHtO;UnbGgA>5EihUk?t6F4$ad5WQE-bu#4}sW z*5e@m$ZXBDO|<~q3<;pO{nLSzQ^y`ZC6AL`2QzZ~*;~nD$>UJjRP>pdj2_II>_NSg zGFV&B6n+P*I#_$X4GNjhgo#k&J0se(*g%~DOn(EdK&fyX1E4$LvpS*1Ej@1I`eWXXQygFs znD|}iL*z$(1Xkn+-htEC{3uQjG2{``HAWNf@FNSnV~QU=4bCGrbH)_=%EXANE2W#y zzs3@vQJJvJO9to*BfJx*UIhIO##I+wmsJMV!7ocQk0L4nr^0Y`#K`xMNkbwI_oD%~ zF`JCr&P6{V@;UE8!V_PKJSt50L03q`-v+H3%pan26THdcJ>xw38jtq#&U*B5!OI?X z(krV{*DbY6x;71O(2O*@PbtmVHm}O)p;KXc|Y&D?q&OiMi^{7E4&!~Gq}1JM#=vzyBJa5;1=z^F-&*A zh~;8;ZVU^%5AZKMOoxS^hXv>`IM$c{`~#jW$`5(jwz=u~t25J>$cybrDWQHlLPvVA zFVG0K&;cQf>WF<9tJd8Q2}ixn;Ks#uc*r(I0BL_AuL}FJ<%q(@MWAfJARBr3E6At< zTz(#Nya1H^x-a1BeiU_J5Z}Z;5qj$cx9F0e=eei}F zxd<3liL^aLY@wp_8QKdHF9=XqO+phJ;UdJ#cEf%!X-wzbJP`&GMVm@IN@ycEG?G)bMlY=Rq_Dig$PurEwtCVa+^cP)i+1 z1IHY)<6;wU7I(w6wZ(PK(T7!wIynobMfb+7$v$H{G$V?j5pK+*Zcxq4Wz|7uW$ZW? zMB&fY4vX`kF93qQI994R$hu}zdwYhF<&!|81syB6FN7}Qnt4X`_=w2&2=H3Hz*#MA+2Aw`9H{|?LH?SlQ!cwz zx#yuL6o4t>yYSse_zu2-fV=2v%|PNN5KWl1<{)_kT(;>sz;5n%q+CGRM<5G7s5)le zfX9Os(HI!Tt;3y1l@yK7-<`5@;f3z9VEWskKu8XNAdWW zKmHat4%^fjRP8gF0cNOMn}C69D0Bu&MmH;Zn0K^*nQ$9C?#^0l$VBRM-j2srWO@Zf z>OEL0O(tgU72+KpLv9kGm^lM^1gp^~IfTz;J@Dij??hS6(+FL{=}`e zJH`33(s4oSP$tJ=2Tv$d=Ns!2c^5p}Z`}{wWt_f)x&_>+P+-i6K0EL#(#(wmcetA3SR_&ri6{FDR2F4$SDyP&f4)5 zzTT7wzkA*v9xB|k_kUZ9{;fzZ$tfWvg2A>nE_S}ptwyHD&%Hb`j_E!;fUv>^ZvbHi zUFZwWZ_8;&%%=_5Hk@MTVV(D;c=7}g{&Yqg%4(L=$B!oX(JtQG$&(!@fMOXai1NOD zyibsUw+H)g&{4r(Ik^aJIkZATDM;gN>K^>prxB-2{uv!K?g2Vs)F<(zA6)zBXjbGW z!08k2a-aeysXWj5waQ7nVYEsrg}-0mSD&1mtkjPjIa2uwRqouq`{Tui4w_u7)ID|3 f+`N8G2#Hksp8o#RUEVP8IJBA{;+^E$z{bWOS1?jz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-PHASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-PHASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4695723c336a7279a114c6ab1a5576fd239d87ac GIT binary patch literal 2300 zcmbtVO>7%g5PrK(QpZl5wQEXi(qwVlG?;FRLklGw>dj`IxLNNryKCHDh=Su{M@bXq zhaUk|)LLpKj9L?j_E9PU5*Nh5?TLyOS0HZ5t*8gia0MwhBxGjRj%yXfk7{f8y_q*} z=9_unye*UV(~2f43-gPGx!jVtu)4Cix+0!kSQ3{PR+q9l@hs@Yw-sur?@q|d}(~{x|O_g*xsYdLwU2;P%Qrc7vyW}4h zR~8nfx!miyIZS7MnQ(;IS4-}AT34(D)$Mg|jq9?nl)4kTl!Dacah34yh8OhC*`==N zuykA+mQoY4sgmm(o(qKV{eFQ*G~eWJPja`;k)Q8O@)L6CDg>JbXm9}5FVkQ?G!+1A>f>QwWwH=A4?$9qzPFc(^NwmO@KxpHzRxp>*U*k#{P&RTgrrFs8-ql8Y&KtJIphtr6zeE zEP{2SE1D|n>68?wM$(Khj_3Zm+oBQXb$PHm9KK3UizvWcv)LV}a{0i-11)W+idCmJ z6I?yGPmwhxt;v=;*3=8E)8&UY@kLa_poT=#Rw`{pTmi7}ipcsI$#x#+*yCg&(YETdGlC@!1`mxFOLC7}sWm!W3+q45ymn{@K!KYtI z1Ae{b3Sb%+lvVos>aWW6#HWHR0`IRfx@VZvI%1Y1%Ax!uVbrSI4iI8<3L4i&Z^hf9DXXsT9R zGS4JOsV41QOYg7)6hguAB%#de&M_Qi2Yj%P4?3<5I7?D zKgbSt!Wz)D)NkdMSH$pnIV_%?hA+m9SU6X|>`{0A5W3j1ui5KJ=|06!fnw4_r=%q; zpoeBMFPcFPFQuua*28~omxe}0RiJ=czs;Rb)JikxPPFr8BmNLZytqN;V{j4PjKrWd z@uu6pxxYCr=LMWUE0zmuc@PQ$C}y`eP&r!@W@Fo|X$w+qXQ8RQ-kddd6T1|eo1TAl zW*XCfnBWkea|jL`w@ch<_bV)Hv2c=wPqOea7Vc-^-7M^8VGgt3g#^&l)9us6Sfb~r zOz|$fM{$0CkE8KA8uI1_*E<{IYah+T1XLEDw hQt?|2rd3!96`w!+!&hw%_t+6&7L(Xv^6^Bi_9qd6r^EmN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIGNUM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIGNUM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..866665fb6e8a17b2cb8084ce2b9d5d3b155a37e5 GIT binary patch literal 2520 zcmbtV-A@!(6u&bI$mcrX+Tu!a6rps}K>e*Zu`<(!`{1W_!-;E^e@&5wdgUo^$T+ zp7T5B+)0zt)2c42iRqb%so1QTSeTz#m>0(rv*KK0VRkeoj)Pu&N2R9r-hiSGwjFD) zw2CaFv$2u+*qCT9#OB6E-hNqZKPoCSvlCPBa^wgs+q({SbR9U*RvA<*J%{$Mdpf$> z_jh%6v{hzrta3tv5HdtQNvl`mbhx?QmQ6oND)X)>DLHfo<~7+&Pi3a zcSr}N4#^7j8__VivFbfX2;WjG@EFcF@q2^Z-LvG^ZwL7y(O=7zxv{pov5xw4B9M85 z5Y*QYk{R+3do%H20e*Gx^JS>_@_8z(wNft!$)Q4UXdU&nfc*mX#r?x|;7z?e>|0wO zZ72pS!kxGWi@I}Lc5v~#;7Pr({5`E-qTUCDq~pufJIHeoKzeP*&>jp1?B#@1Lr4>& zdo#DWlSTRPhYI;rJ!`y;pWP;FLybcXaQ0{mEIx&UpAi(G?hGO3LpReE>Rszc)RrPz z4!>Y z;sW8ToNK9ufJ%+N5O$n2pcs9+W=g#w&=~zzfG=Yed?~bZZ9r9QbwDyTJ8D8Zs%}4* zS!XO;3-dg9_;L-e>Y8FiBT|r>VJpBmo_l(?O#`gTQ;CLL-%9SRsEVao8)Jehj~9Hr zFx#f4+W8)5f@dr4R25x~>WZ!PJuwKZ!cz+q;|*x0Nll4H?MT!Pc}XqLyHLF59y*|@gL%eWk#p&U__iPoddNcGGK@C|2TSrJ zYe4Y>djZAQtP#aUh{R`Uc2Kg;gnOwj6>csxo@aYc!Ff=;FqA;ssL>&|*S(^4!U3fb zllB|n&0{ZA6^Mtz=YskJecXzH5BD2fj%5Z?h>UW-u$NF=0iO~hs=K;w762W20BD8M zLVVGP3rB9TRF;`j)BTgJqRv$@X# z>K2<3V%_<~S;3}nR80+9P})>3J!C`g=oYI&H%Q`@D7CfR@fj!8*43*)FKD@Y-~E`) zZyZ`UZPCh~--aiCxQe|&zLGn|^u$tpMV@@L6knC0f&({*wrsS(Ct;c(i^Av~J0dB(ATq z!(}KhCNoQf;M)gDc#v85Iqp7(l09G>bl=JQt6W6pA7|`n2?TDB23EJv@FP200>JU{~QdAPciv?H9KCx zx`DLTWtSuOvD;axAsl}$3x7GSEEAHvf0K|RujOP<>fukx?*!D|2Z-c-@bV`Qzxe&F T5_ejd1hc@}SS$H>Ae;RYiw)Z% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0927b084fc946729ed9bc67797c73cc8d9ffd85b GIT binary patch literal 2252 zcmbtV-A^1<6u)O#~X14R;LNpIHT3<<}r8&T*>zZY=55`n&yzAATu(OYo zT1n5WrDr8~J-s?R^WGV$=M_m^UYTEjKj+WGwx_?ZxBu+fuJDNJ7zJzpsngrv^J0JB zOI_jJoqII8LDm) zSxCQ|Uchv&trALze>)o*@l4ItEz{qoo3zHim95oHB>}0aql^flq7}4G{cLSduhOUV zDvoZFoqN$6ga~ieMFouItIX4J`ec!O{`I(!Y-*~b6+xh9frdlZ^Q}hf z=xN}8WF5^kO*ewH6%j!1;m?OsPMx~{h}=)M9nQ$<$8RN1B~L?TQ}M@EGJZH~vJdr6 z%3y6XQ}`XO>R|2lCMaY+6D2~Ge>dAKYnC~zV~;9hsyS>hTN%;;F-IL)2=OYR0#-Q; zL7l9rt~RFF%=K(&Vl9}03TMi3*@Pf~M656-n!!}lODH3jJ>kfl3iO}at|jwoG0dyP z2nL=9CiPXhe(x7JG2|hdFywh>%!^0&FtDG?xu4 zZ>WaHc)eJUzBSd*JVQm?W{zjLz-R!*kv;J}I0kUTKKYUaXuJTd>cIP+bR$6FASeq8 zrx_a-?_N#+*_sg-| z*v+eh!tN*di4M|1;g>-HIt<48(qDhVlSTP4Kijl0bM5l%3?}k?J5ow$(2mfNKAa0Q zf+Ms*$f7#r9LK7)cSFK)e>=Pdlxz*a$KMu#L%R#fl{uGeR}{7eHUkd7fN5Ps0Oetk ztvq}R!c+m}XCnE{fWftcDC)o>t>6~D@e91OqDaLe6^bfBD6+si3k*cfauDa8B>`?$ pmed1o*#TLRckY=AH22x5F6x^_j_)3n9XvYn>E+$szX9~`o^k*H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SINH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SINH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..70a98602ec5a4032fde8129b1fc779e5252bde05 GIT binary patch literal 2006 zcmbtU+fN)-7(X-1Wm#Z4tQ&cjVIKav^!qlA@Gu=&LRj6>U<|<>R8i&@j0ZK&wVHV6TxViGScC|}wSM8WN zNN#Ke)(8=PsFFnl^JQjlNVt8O{CsCfOe*0jp~OSl>>*8s^Dh&Eib_KA$?%wz&y30N z1>ppcj5RLSO!WLDua~ zBqw6nXzi<8HNyqA;{hkKoN9Vh*dYiJg%^67(xif z!DJEQcJ4yn)y!(LtBUBFqYtVUbrKe^Mfd1dVvpJm9Tr9K2o?CK8&oqBakZaW!*+xVqVVTv zhedd~F93!!NGsJNvaZ?GKISm0d=hw6z{Rtu?sx>`vhNH=>6)P@49%f^M{1du`Ko}* zQiNI-vs9LF;t40>3u20hW{#?!9ufH-0$rt7IIhJk8ezV!9xq4p zt8gk(qsbhE4X6eTifRX<%8uv7Wz^L}(NgTfh}j^M-w_e|pzsBM6qj4P7MG9tV{by@ zkWHO_)gB%0Wrlk65->;&gC2&F(Zh+h@`efs6ZRluaol19CQ6_4dR#t0r8iKN-i1e{ z#Kg|MLA=eIP}_x2%!GkDg3~CB9Lgu+9(c0N8_~Am`I9x?w9M<9`4fJO{>07IJL$zG zrC~*DP$tLW4W3Y@E*G9p)U9~2-?|^Vo5;R8-J-w;_0&|2m;=XY*t{Iw0QB<-=Fmdj z&)i%~PcMZdqlNd;d-Ru%iyl>5u@CFFytXC0I2{!Z-kXk!2Xa(|*Jk%Z6t8Yngx@{y z54RNd@%z8+*8Z(Y&d59T8wnlm9Mc&l|fE!2H`ME~k*}%JyFMgPmfrc919pc?W0Cc5z z_y!#zX4p;Fq7AoXqAsIy$mnq0629{U6s0J{Yo|&3o?PdAR+W5E9OIKlS~m TMIHxu1WuTr<&9*!_u$|UmZnh# literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TAN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TAN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5f9aab29c000db7187071d93fd7dfc4fab4d70c3 GIT binary patch literal 2164 zcmbtVT}&KR6uvVHbopBr*ly^GFpxrV)7c7^*wTmHVYtA`Ftg5&3rQ2C%i>a@OZZES zN(hcx<0ggvkhyIdlfL+%F;JhHV)nuKs1L?Q6Vo>zeK0XT_+apy85XfNu?f4G+{F5^q1KL1H&&)^g7rApEodhrII-OWrHf0&vYugy0Lq*95#b-qS+c zU0Q&Hun2@4Evz+lg8Zu1l#5J+L0b#(V7L9lk&H7Z@9mI#>Gq>J>AZh2eKOq%nayd=-{~lLTg!R>qh%euy%K>$7IQ(uS30)}%~4rX2a;Ih;;^I+C{!2wlYpp0 zMwIunO1=WVa%iIZs4SWCu&7hh(xC}tw~H!_al@peJP#TnugzqIN~)C-2Q_`vh%%1n z{%dV&QC97%VwJuCG*uuI$!fsUo9Y|;VoHA%53Yw$H-Y*|udOOX)QsbMK52pU09cc6X%hX8Ioq+ikii{l`w zcB3C?hXJZ`NokNcNtGd_QwVlHah+7b`LQy*LmKc>xCL7-qreasS7A|ssgg`wz7HPj zWlPtodg#Jp9LiQe7W(J7Fb7_OST%}=;5Y*vss?<;p}lD<0Iqp2t-kYr%oARv5@5q};Dr>OcyYJFX7-!qp+4u+|kI z5;CYcC>rCV{hA_{Zc+D2+yLwHl&%e79Dbd(;qWGc?qTEV5?s9%D(1vZk-@qU?FXGQ z)lv|HyBLlyl@uWzaI@2~q+!P0&5=LYDNrE4x<=%&H+&Dad@6~8&%m-0^8pO4lxK6( zv-y~Hy~DcltSyZ3R-HntnO$5G+E=A^VR{nYwkcueiuWubw%UPABF-J>29|$|tW&5l zq_p2q?g=SL6G}rdST(A_Hea=F16g@8;zMzZXn!3I0)nhr)wyPyO{fzJ%mJ8xx=W6HN5A!S9;|O6oQ7Vdk9g{`)TH zTOl=LhN&2Zx%uhY?1EBQD$Xwzm0V##Su89qWU@*Q_{tjwv*}yIx-ru6OlQd1CCMyg zCyUuB#a+rSPEEf4l+t-x(dQSYXW??{6p)?0@vh#Uo{rFIjiZfOuERa?GWUs}3eis#^Lejd?3xIS9F^DTmr#xv@(r7UtF2>?_$> zOlNM92!wc-%fZ2vWw;4ud8@**(BNGv?@L%}5>nHLC=r8OUeLSXmFqjZ)VSKEy1F$? zuC0a66C(W3D2oW@%lxeo;pSQL^X(BatwbAzS|90AA8969d6^Jo>?5R-j!sCG{Dcf& z7`{k_NtfSY^7>IG36K*qWRHbeq#fiJStK8w2!l40M6g@Gn`z$dZ2A^>4xiuKB;;>` zm`OnXx?)~p(szWcf;_S@ zl|GVghRB)rjWk~G`0!Slv_1qF((Stnke@gNIYSY`Pz2d80x-fJi?BoOP>+l35ELN- zbk`VGZR)0Mm=?nyw_0c1ap|Zif<~k|kA_KgE0t6SnLX;nxF8CD zwsu*J*9Sr%*pFkS`h#rf4s~{B7+C=cG#cRH+0=0T0pxOEKUx{OX{1cur32e+nb!px zVU(p9wQXjrEafIsZY&T+7ct!$SA9Mr3LF65K0k0$PuLDPjQ~fgLSc}O*4)npK$acZ1Zl_*cMqUd9-HTb62?uEMJ0e0IB);H>@wma8@%WfO z`X)GzIMf|fo$=9rW~$qpfPrf$^eB{!ZdLR+Z*2fG;TCwTN!o14Lh5tgg2xBQ^b3mA zyRcMhEzI06#M`_bxp9PIrA*`ztVXru5I&Xk!IP`J4P`67J~_|Zmw3xj{&*0rKk>>f zZg#P#w4T#jmE0uk;3;MLY;}Di@0@S@t@oj~iqm(*uqn)g`cPHPgbVF79bS)W0Q&h9 zb7?j1XI{CZx1U1GXmvmOOTV}ibUWHPXDfckYiq)bGn%mZ-i#)0%9;q`j@m?T;iBWwhsoQQ3KXII&XyZMtJdX1cgi4txXyPX${G<>9 z-d=3JNyi8|wnh$Xkid*~&rfORit9%v{|pcs_W+7fKah9W=MD dUlT&2rISy7|LGooBzO!O&X4gna^eawnB9L$)c<*#jhm1#u-VWUR-Sy z*FBmd^Sn z;t;a-TJD9MrkH7>SqI!5&S&km{Ao?fLTYjfBZs?(!q7RZ4a;bJ?Lr>`)6M-EFkHiS5ecn+Sz=E(~+!M=OCg z2>|)$zPd{Szaq3>{)_~c9GoAHN5lCs1_W|9LOz7rmBQur18(|^PwuzAPj@~7Xyug< zd|~*80D13I5;~e70S@ZL7$J*<$xsyJpOc|-WF-vRB;WwMqdyAKZy%t;d^A7u1P;6T z(eu$JnR7sd0H1;Qdtu@s&QF{V^PEBD#V2>l?DyO?8#=FMP{HdFs6o3du$%p|H4;;Z zHlJqKFD=U2yoz<{S{gW7%7{5!)Z-X{-U`MP*;E!K9h*5FdPA|B%Vpd!Oq_8zKqK7k zK1Ic{mdi>DM9&y8$~m~FtxXc6gS?M=crOS&vYyIiux1)3{mMFx4}k1qug$=(kyFhC z75Iz57EVkgl4X$tUwB$Q3G5(rb0CIwo#+zDnc18f<3ph8i^y^#`4@l}?t8P} z(W%Su|HuH}Y6*$|yec15mpa)~^0Sxm0|em2@5w47z5&9;N+X+${2G9RN>0}y`_p$z zIVRh+ot|8cA{)3HE*)gztMnz<(BBMD&StST&&cn=$Zhn}VC4)hW1TEZ3dv;Pe$}** zU8f@-(3jt*qaFtH9oP?Kb&}E;bq~yaXNy1u#%?ktyHt$24HLtqu^jA_sx*2N%)EUw z13Dy2g)ALU(dZ0~+HStGTCbSJ&4xI(Esu$%RT!XaV&ztM_A%b}I6$MnplaajLJ#XB z>z;MMdTUhCv20>Uqu;4^In=a?by+p&AX9@F-^~#d)A54UiqBrdP-onobN29VocQlM z-Zpxn#9y}#c&F1j0UJPF^272fTQ2)ASqFZe=Q)^^JDpDFpVK7*lIC2rRBFzN2sP)1 q>0$Hg)YMe-9SWyk*wSX?F%uj!m19tL+BwnJ0Gv+Jaddd4)A<)TpZSyk literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-COMPLEX.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-COMPLEX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..861ea10f3230110c008213fca84ad40386689db9 GIT binary patch literal 773 zcmah{O-~a+7=CyA2^7*2O~e?TkZ{>JByCW!UL1#MY1z)g?5x1CX}7jXp-n$bjFA`* zp4Mm~l3fk|!7F0q;2-iI;A}x9cTwZ%u-N&C`Gt>;z;ZXL;?+pkw&+(p@kh;)0cw%RN&t7A5Q zFPC3hTAVBp+dN16Z%;0t&E<2d=j`ZEOLqXE2B+aN0g#3W`1@Ykkj$32P%;_jq{0k; zPOa5Yxn#!g|)o}&HwBl=nDQe6^uxxBKz&+n1NZ6Oc2u!rov}x&W2-27TkbO=hoOME_R~A2zU3s&zH~V zd7k%qpHxWW6-5=5{K{HxIa3hx8^yJaqPUbVi0k={LMkIJfn0oB(GB`eLRO}SUx>7s zb(&NmvslceMQbCoo?g6qUW|;3@>(Ic42z2wVH=4)HxeBi8*YosrdmV$PoI%!WF$Iz zVYqF7cZU=5gpd@e;-{4mfp~~>t1N^qYFbh}sZvRkXK2`|IOP_|MY2t5IA#BcSj?|U z%bB+_%b3o}I^hU$ZkAi(wx(D~U30d%EzaxQD0d_^X%y~a7-PPPf zkab>feum55U+`6RA8dcCs5f-qkAzgR@9Vy4o&(p)Ue8=F`hdQL5HEn`Qhn8X+;|-+ z_u!DUWv(00vJ0K?1mNicg*Ta9dgY{qMqc{Zrup?xi3kSIr7|$hXVAVMW&_ zlh_GTLe?f#YDg1FkZ4n8m~UdOd?U1(Kdi`>l8_8)*#@+U;`UjSId58YhUdW|P-{d* zrLtzvN^#woF~f}GxhK6XJz8 z5q6z&zm-`pii4Z-pt!UMGdL~gR%_!EWt*X^&Ru648?a9?sBBT`*a4_XiyE?OvUW6s zpfB6HMcGi=DGx^{D4Z;<%|&vg^5V*C=|#-zcw>SO z=Qbwvrc>sw@ZFF>hdY1Wrf6nkgg;%vP&!Igc#|_bM2aET{0UW3@ zPiwRg$*zX~;1w})@DKS9aJDr{;NWRzpLgEp<9%lYiD!m|jLvSi)%JR*GaPh>1GLlW zp?+uBYj|i!;^>uObNYIf7;8(9@>9-*N~7o12i`UkL$AMGe|Z<>A0pE2wc7HqvLb); z#e0R~^77JDnK;&j?Y}*RVt&$dete{89RO&+S@g*OXb^+oz}Iv^9f8ZHMKL2ast2RM zPs=RWbtn(~TmcO_UEKCwc@|yUY-#&4NSajgk#M_%kNM>oOXtP*Br< zSR!^M@U?sa-^V4&?3&4lusIwbC7(uCzBNy)%E=yVe6OmTvo~`}qILQlVD4=yt29r3 zFnRtpT6@oa0*spPSXEVK01ld8uWyb6$#NPX3vkwI%#E5_O9M3#eDZJUhRsT5WDu_s zRnLMW(L>Q}>Q{i&y+!#ksI$MsQHC4HKL)dya9ZQ9oSX!o?)hXvT z$F?ihU7^P^vLUMzwuQ&Iqle?zm!_AB0fg~rWU;CwNtSJ1Bcc+C87}9PU06k^JdpUc ze>n`|&D0P_!1ndQsTD3DG?N3a$%W*a$-5*baYMXY`C_d;SKnV&d+}XJ$va_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FCEILING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FCEILING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0bd7688237778fe2c4fabf13ec78d1da52ae9feb GIT binary patch literal 1728 zcma)6-%le|6u#3!ZA)9HScz1`kw`--gSPA{R^u`Zx1} zshXtLR@atSD(g~hv%a=jmzHYl(nf7_y^A+`qORI`raSw>wh(f5n&G@I8?ZGcM~TOOih}5Z(+sB4^2>5orFku{=g7Ug zkz0fa-$z9cw(~>v!K`rqCfWUQ)>C>a9u<6UuW`56@<97F*nUZ^Am$>zfiqD zA8D}&sDJEfJ1p`uA$!%^EHdj6!XO^@mxd4s{C+}0gtV5+&$o_*S01S;{Bl;)Uy1`- zb-ov#7(9J|y!$chJ$!*h1R%^u2-FEdRpaw9NMI2Uq#piOPJDSp4oZpA zz(WvrN`n^zj$(ZPg&r?K{Ixvt9W9Mq3^UU1>k^3HOVY#bD*pdBZG9Kf1|+^22O3&c z5x?%I&4HxK^yxf~fIOq<(;7A9sXSQpoR#$Wc)-&Q^A%01imlGbCbf$u%!ld@n9sUy z*|gyCKt!xPfvQFoy=cf;W)`d@7d*nhvu&2-J>C!xc!S^!C}yr$pt@~!W)`Q-8v&nq zHfm7VDr$C$i{8i4-pP@ffvtmGydXXe_9)DBBuPz^nKCQdM$t}sdm%QIRP^hzYsW^t zPk`;oPCfTHofnP$mlG;DO)>S4(-i`Sc^4k3FdmR2XrYU~t!Sux1&R;pQEXJd0OY7z zG)-XO{QPnOeRseYJO4bYV$pWPya(M={AqZR69iNYgX+_$eho=}>-2~srO`QRvN>60 zg#vtIEpHjCeBfRF%sYJ0?d}`M?>0=9(-HJ@NDuyv1}>ugHb%K@p|%BAhfl{%xO=Mc z1eX35=E;}Um|`0@04CCbv0!WrE*g9|#}gAg5kQOsr}?a1*{DlHTgs5Mv;a5jqO^Ro zeJP@CYZyWQ1R9~X{|xMX=QC#?CvH$RsbW*u*xCHL1ZjDjnu=!e9t?w~-zqYj^5L@6 z9Lr2mV4k*bK=)d&cN#dWyk(vCGWMdg?`=$O6LP+cfC*q5Q(c6FT>|-G)d-9EmifGS!w{#cGscxGk0G+;KiE8y^TM?Y0KCq!gnu z60$Z~ADRG5+|0$SiN+_R3HV|*u9n0HU-m&0{}3O2!*i!lh)aTLdhhxCopXP4?%hNE zi;5~L^|kfdYPliSH=FC5O|epMh#U3IMyV`Tz%G8G5CeZYFDnblH&O%U1y89_UT&6G zL~FCWv9kQ}q?meLl-C=zRS>49K}}_Dq%+sACkL{!sdmw>%t>cbQ<+z8BnM6&+~1 zLflVbfoIM9Tz#~_J-m%}e_7y*&&0x<*X=asc3K+gZlm2z?9?9JLMU?QsbQ}Aa4FOw zAyEI`Q+G({H-z@8cS&f0=LSJM94?MAAn^MT3L@00m0s)|aj#vd$^Cv-(^rfET6HM` z|0w*20D1Q_5;=T{ggBtfix9I#91VXL@gpuyTn;nQ?duANzl!4H?JE2IZ`y_~qYX%WCk8Zhssj7A zU$jRO3eo2BYyhNrS({U_AB6Up8`f0c)1on^-n$o)Gv#-9dx0 zrmb2jDtMj-tI*4kh|U@ZyYNJG8mwWM=1>9~1~DXJTe@u}JQ0WtCS>iVpIrvnED+gc}@3XG9tr^*dU9NLJ9@= zvTEMc*XYOx^tt!xsN383kln8vB&RXRuOK;afdDEn>s=P(vc$A4cr3gcJAiwhI*qfk zKfnxmp{i`@w*Vw~3Sz>b=v2_@c#g)WY242c4xIM$R(Yc-j%~?fVr3a#(iO3GyZZ<- z+txUP{09hh$#M_#k@Kaq&n9eCF|cf5IMUg?y2Pk?3mdX((f|vChTpY`h3R<7X(uzY z7#PRh_s)I9o4xX9b+^pZPLeM>`<~X!3_|D21egG}HQR^Kpew-p(-i~|UU2pYTaW-5 zy#)l+a+l6FNbYhx15$5^xmoc_r8Oh6)M0widV6YWs`VBH=~uRNn0m|{$1LO+g8N(^ Q=p=MOB|44{-aI+^7k@ebU;qFB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-DIGITS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-DIGITS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c74fc801d601e8f9096de3b65109210411634ab7 GIT binary patch literal 1622 zcmbtU&2Jk;6rWuuCUG2h9U0PERoS>|0gJKZG*oFoYSx?a2U+i!o!taqh>T-ngHuO| zg9M1kY9hg5MQb9WomP>0;=(0}3ssAZ#J|9m{{e|J3UAg;uu>$DIIL#h?|r}d&Fi7j zcXdP6+Z&tBR&7gd?{qeII%>VWrEa%(wyHI?4!HW6PA&3zUelLTZ>B?RNK@UaRXVkG z)!wOXuU9^KT}|Iowau+&3x4M3K};{aF}pA~mkMPyW(=bJtIzC0`o==~Rw{IIbSNop zgisar#W9YMf&$3<+EtP^VK&Yd41!IqNRnR9bH|_;>@Z?^Zgf`dv^R09_HnHx+S%Af z5<=d6cP#6ex?P~AcOZ48uy@a$ESR_it!X)eoHeLs5vV1&u7r5*YT5FRfk{PM{w{C@fs7SNh+hZ->g1%BN*ctj7Oek?KQ81l_Evki6UY z&sDzkPgO#wx8o43-%yY|;eF#?PU_TLDu|21dCgohh=nr+K+GIV%0WIZj{*y#NnNw` zJhq7KSa6HFPlF&UGn*7;87yK0p6CYAOs9mi)GD$hmt^UAZ<{9hL?Fz^10mr!eCgP9 ziWy?DGm;5<1R_A5NRn6$;l4B2o9vk0QiJ1T({eV+<0EkQL1kLKcLes9&>%sEY=4$Fhhy^bEKpbaSHqzvriGj10=* z6GAQK8@fhTh*ic625Jz21|j|hRxW0!fluEE;OIBN!^6W6;3Ixf97p_;IKJZX8pMn- zVrTKW5c7Q6PijJ#(UL`TCU{7TqWa;W{%E)&bgv0Ze|kbv;mrn3(Y8N@C{GA90REvN z|I%&W7d-%cdI)EOkwallX<)I(XFlbLk9gueel;jUz2&(t+qLbEn%LD6YP|ycZe4BO z8LTRS?Op>j^qu$6I}nVzqFY3>2|hPpqhJ$DGZ>!`X3)Vq4z&rN5x$3>n_9>axI8l0 zMgD^AoFzTYw#%O7PgM@l%;F8T*X%aD#Sj1dqu1!d?~nOjes8fgebQ?x@K8KA-l}Z8 zzg`jLo~IIQJISXKu*q|!ER=!b-a&Bxb{C=jMUeJ?&erSu@PnY-c#*<7El~zfZiV0_ h>SSQE`jb4Y}T7@l1xCb1oN9l5k!Rb^w;0xQOn(@+J2)T}q-#ALl=_9MX;BIB&F!Kow1 zK>|b+wUOYkqBRlGPOC_qxNr&LR8eFk{sLG20}^Kx-dQ&xa*;sdu$q0pp7&#(dHZPm z9oc~w6)pR5Rv@1P%kS`pVS%PAqswd=`2b6tXO8ou;^CLi3R((%hQDL@xo zAq8}rrf-1#3z}}q>(k&(lOn_&|5}#^?<2%vrVtvmo`5iY_qmHg^D&rd62#y8#(kRn z1)+ZPbDCTc1#s*iUs=1#gTOw4P=bfnuMNIO-<~T|sGgP?Uz7h|k;)@T1l_DDkbJNC zpR0WSpQ;3?w`2etG$ka)gRlLos!q+t62B|FteJ}jv2dXT8gt23#VDH;$AJhbRo5JS z8C%40Ex1TMWJ1)g+72m;B6y^SRM8EhnQjFasa3XBCWykb(GFEvJd$9Okr)^+jodpn z-Ex6g_8HYUNg_$0P*Nq9MJ-HSr{X$l>A&ZwYc?6y z#Nyn{=N!9ER*6-`HVoDvTpI=a3wE_!pawpDE}%!has9|pxc(ba;0f-=u8g?UXt8n0M%$%F`DffqS~8xDv`-24i64hP941s-wK> z6)xW1S<=&NyY|!k+1eqRTKM44Kl)9nC85BV+qKR2Hfp@CQ33(J5E2MD6!=0BWF!X% z(f!+d2< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-RADIX.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-RADIX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fbb1a041dbf8e4e35724f880386e95d9a3143b2a GIT binary patch literal 1645 zcmbtUTW=dh6rNott`j@kO)w>Oqq4DRsVpW^Oba1Mw42S?F=owC(!NR;jG50j_;zaGQNSryKJV?@taoU7pfbx!5SL zYVJ;Xd$st*TiWD%n!dSJt-;UK6qu9KH`3GBuTKnSbjR$l{p+6e^yJ&Yo|B_PNv#t? zN~Dd;03j*~5&uC`O}Wf*X(nefYUz2F@>_m00=-brVYc5KPHT<&Cask}FW0c0^=%>% z;@@vZGM;6)Id1s}(w-Fa?=^>V7A-()dX^D6@`44~CBLaors+F0V{+Z4wmzF%B1eZq zcLAi37Mds#Zkx}RQ7-? z-*sVomH%A&g?}m?s6I?Uf_6nEa@7B!IhHcGHJii3qjS17YciY8>lG z_<_~&O!rJ|D3j2j7zim4@=BLZsO9BnnC%EPbRIOOq?m1Un{v-Bcy21BB4bLomT7=v zdK6oaW@G(?h&~jmf|{!UQ6F2-O*B3NBaEf%E}BbNyW!b3v$}4DkkFR{U;OXU8M?zd zX+;#>8jN=E3R__IGId~4+$XK|i-W?lLisdk_8Q#Pke%0vol7rD^DD~>E6dXC{Gzlpzp|K0OS8b2-dCAHKRmCf<9%;LYRvGyi2$m^1_u$Y~L%iti8k)eV9p|fZEYDX1QE2F*8rhh1MW@uob zuXg*+CMV7lLQ9Pg9Hw(+iExBCYlZ4jTUV_Z)13`2$JIMG3k@+{PC#nP7$to54ho`kPN6Za*>*J0FaS*jODuSK>+i3; z|DU7RT;{sx{Q3BgQc@||el+lfU0@E7@3pWXp6+E9pUaGs4efSO` z{%faNxy*g=#snaru4^}$@C_mBnU9$;&T|cLExwfO!MH(QO-MZ;Xujf6@5gbh8&FnM;|l8e3e_n zSHiS5g;m8;&&vk2Yy+lE^~SZzoHQ*O=XuZwl;>I1sG{2md6XG(GwgCa_pG(W!fu^U z073KqV9L53k5a>o?Ck-ZU|-|WTK%r*6G7BMFD0mI(GhRBAw1L8tOy93&@B$U?5&x7 zf#0q1H6Le*umRX8LYNu`Gh}943EK+$TEL(_tmu=n$H&Bc!J|9?fKw17hgO#W1$QfO zUp2w*;kUp;1)WedB%T6Mh1F6lB>zNI)iw;OA6SkqhqB*57TE8Ws+hDKk6VZ0Pux~K zGz3%<3964E*#$iox^!k?^d@vwqrm3=LoIsIRsRSmBClc(+|$72z6YHO-PVxDnE=&t2ue2LV@-H~+?#F> zs+}pDcDko)5cqee@QRgQT9!Iil@4ik8eYm7DSNg2$RTgF3)Lue&h13|8Rtu91Hblm z)u4(+GmDmeGpEou6s6E=T7J*GM|yeB{jT3tb0?BM@JMdw zhjWDBZ7pAd+uP0td`P^<%|AW|FCq{q$e%k%>`KtslZ2d&s6r42w8E=~+Xo@Iuev?ti{b6<{{iM+l2`x$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d79f7f565441eac8247b5a4e67ec8639b9263601 GIT binary patch literal 769 zcmaiy&rcIU6vy9g=?`d2wnP&#Mkgd(HcpdmK(SsNmnm&oW?^<#>%9@;|7vtx-mSqjB_bc?|QYqw~NHU>+RNF+(pI%L^|DOOKw(H z&x}q_6s-*ab-0L@X#fpk5FGiME~q1LsbW#g z$OhGeVc@4E3w9mK13yh|o-oDy%IKLeP1lgucM zv+qpqe-78*u^#}###>fZl`OzftQ;U45wo$$vLZ2 z&TWouS8TdMk4?)58J(~lJk}jOl)##CrEkd?KsXgOD^`^ziIUAXh**n~nJ(v)T^d5D z+?V>bzZ@oU=)^rtPp!&WcHBxFb@$J}#)FjB@o^c8az+UjC9&qidG%4?-w|G~j}{Ke z0@|y|-?)pK2a}H!X@`qS@HseErTJ}>Qz9t7lHaNb%8BKK>FAowv*p@?hBx378jXGd De@*4R literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5580668675957ab45e0ceb16999380123bb911d3 GIT binary patch literal 1640 zcma)6&2Jk;6rWuu#&&FXZLElx5VoPQB9k?;6Hss^n(b!nxLNO*-8D|dA&MNkHgf97 zaS*5?s)8jrtdxX^vXiPvaDxL%5toXBBf+r;4*VfpxPii(-6p9@q;^(2Gw#oSd$UumiFM$Mw-ln|PZnflF?Bf|FrJW9JGGT= zZB;ZkYa6R8A5V$tw?%oq(`>X7nYDTv0+NNf{G0%+ zfjEThUCWm%Yl>MQn!V56=7RQ)6)I>_2~v~u81cTxC=8vmtx!56y(Q&TLUeTRPIwz3 z?x%>rvsiv^JY3`++(f&-Eb^6?;t|g41R8e&t&Y0On7fGm=EEBZMYmrV;TjK?!+jD4 z@~=I0hlGDaXs_`Z2`}Ms1{>HZ4x8H36OtIh8ywa7-*9)4|a!tRukXeM+cQeW%Lnjb}D1% zqfIgAfCvFT1M!dQy^iov9;U6&j_3(@l;@S?6K=l-0z zi=8V0Y}*pjPu-;;RFw{}3lw5E;s1;*?#6{kdux&?29S7Y%z>9lC#1{e*wMh5gm zi3%k;k*A4Sns8ivWm~VBwT-Sgz9o-~^%Zz9SHx`>wsu zdTC72v20>U;G{F1GN=U;>#}OlA*Kda@0N*)=|t7GQrW8*>Wkf1&3UT3r`}K8ZW)gQ zNxfn3dtgk$0#Fx2Fulg6OQDPQeu(FJgtm`ioKF9;ojb)rqc@kR*L!m!LcO^WdeFNv mJw4rfhr;exHuV{K!~{o7e6y~O{{IyS2yZnrM4!n*EZHlWw8Qw@e7rh_{$kZolU)$?y}B!N^9kX zdU;W_H_Gda3!h&R)9;GP>e|vW2$PebrZaDkWhN$4T{*?le6$O5#xm)N%=pz**YW*( zoKQmul~9XqVT1$}K|*Oa1;f;BR7U>B&um;=vw|16FEgo~r+!;Jd8E`a#EC_de)vfux1Tkm;ogC>5Egf_IQ z0{gb#H2Wo$=+gx@0P>8YPixqerwU-v^OnR1X_)VX>556JVyiQLybwJG))-84RKli7Oqn>g;n-3j4v`T_(Qn9}oskS& z0^6l_E$B)}U5rC0-+@0;G^YFjN|3chv6=cE;Ko$P zG~wi@x0Z6ucNct#)6b$R7WT=~Zswk%ufm3o8K7bqSf6Iy15yduc0!X9{ zV!=QdR50jJo(@ma;V?tkcbl)<<@LHaxTy?^l?8Y)7saJp{$s~%n{P76f1y!cQ@q#Y zGxu9}k4@5mYGTF4@^cN)3N|(s&7$2b3lG{vWrZ99C`|q0fSl3U=KdZZG zwV9;ea`ys_Y!;zLcB{RNf(c+7QymEPcmljLz94|`hP&6(&H&yGNJWinEEk0K(qifn zQ~f22P}0j9sZ<(S5$xGMy5G1qK0e-fpMvxoTUty#VvZvgas)*$Ir)aHZdOX`AWThxnw-8oK0P@()|FCiy@_^V%=mP2a{6*|tn2j7 zZ9ys%Lh_`6Q-~0W_=$U~E+rglJ4!08Q^im-G~w>M^&sp;$=cL%>)~;^THaLF3m+BM zaXTAZL?Fc7s|QnALvzy1a1Vs*LXW#!?@b$u30qU=De(m#qaeEA*2Uzw@|u!zEC^B^ zO77eiZxAB<5SDyc&yU52i^79zWbda%U+%eBSO|E<#=K(l1I=l$ImwOE!>fcuZamX3 z6dx>$4JLy6=f1wn#9s*6FWzM0qEF}r@u)vHgh1dA64FCRqm+NSaV)(4L{8z?vz)

zcy8bk2)nt#^8rUOKY&7w7a;zYANiix2diC*Z)f1;wIH)`AAnybcT4 zS8Ru7d_GtaZMLAMQ`N|tN{U$-JHZ8?@b74cC3v^Lhll)K;0&qOd^ST3$8I$(wwqtX zz*et8W;?4pNiO*>fkSEqDa^#$!7iN_Fb<9|w6&O^mc=ZEWgRo?B>WLr+>=m^D~e~w zQvJ_@t*@QYyHf46(f{;94!15PpSof_z%uW^d)14VuKBE-~%7>7e3&FUU~NcpwqP2yn(29Azu6^6I?>aOgFtoZi6xgTDr_g)ftE~#oQt#N0iy3>>J@D6NW(a8yBVYp9+H40Qy`BK?Qd5vXc*#BJ ztw8`pv<47J?Wy4eZLJ~ZMa9?FYBMs1_VdHqI};NVwYND)KjY9q^#mO!xa0&DcX&MT PQK*6|e3%@*b$a?YEkXoR literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-IMAGPART.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-IMAGPART.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e5b3fe5060fa6b8d612d56e63663bd159eed72f9 GIT binary patch literal 775 zcmah{T~8B16urBpACy8`qKO!z6B1rFPGcKTtS^qsv~1bVmf2a6$EICulR}$*m>455 zKKQgo3z6(<_z%7!Mjre_{)0MO{2=(?)7&}t&bjB@J0plb(M_axcDt>%+e4k5ymjdJ%9>GoP}8LY0# zYp$@8FDx%-lSN{i=WPFdlP}~}3U^kr$?@@#lI{RN9nQjI8Xyf3@DIGSCa5iN(J(1y zq(U`+HJMBPo+b`w{AX>GbxQW=M9GreRE&jv%!Ob9 zdbHWBu}sZpCl|9B(OSwbWF{~6h|!axJU5@8hCzQnOrrxQ`UZ|4?`@9Drdnb9&zQb} z=!t=7UvKl~%{5M#C4@|oGQOG!5r~I4UlfIiMNLbJCsitGa*9Trl2i0TFOqFi!zs4) ziHoyy(scHN>@>D>VS#XjI9H3_xUDHxQrDbSZiQ=ct`u97nv{mtFyfCVl$?&fm$Cj4dH57R$O>J{Dp6CtJCr@DWH=ODCnyJK`8#(>>R zNDGkVrw)|wa7Im1?r}A#cXSW1h0ZN|4eVs zg(iaFt^0Y1yZvZN{PGUD3%S5|RD}F6{rY)1!|Rhwv>cq zP|G$zM~W-N26NoBXo}~-BUn+YqEcD2(^6bFQf7p4Jooo#OOG(0rv(fzxa!{0n`Wm5 zsbM}hK^1@F+Zla_T71;p7LHG+?u` zh0_OEf?^v6)oM;H92xXF#d-beF<)C4WHH<}P}M8Z}AD@0G}J zAa`)5TVaNU&a=Jmuzfuc9yF;Hm$sF7kiF!`8h!?f`m~`BYdHH3O6k~%P{Pfw6#o@Q zxSNU**WoT}&~Sa-<^G%NHz*v2Jz*F!Bg6?-qAD2Z=iWF_8on+i518X59&P z_#`{r#X3VwY((mBonohzU04*u%W_yeI|<)~jF_LPTH52Lzm!a>6r!IK|NP zyY|aIKz;Z9;52Ivf*` zeeE2MH^BuiuYYXuJKwobudSEZ-4L6xKlw_iVCz6xf@L&>q@ oEZoCR9c6EHu{RI0FyY(XP4Kx-Qs-)b^}r4@iFK3fgPWUw0hpI}(EtDd literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-MOD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-MOD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ebd1d96204b29627656b882600bcaad0f260a8db GIT binary patch literal 1594 zcma)6-)kdP6uvWQvuWC7lWZt$taWU&rHng~lwIA;qB5P{w6T-9aei#JAe54(CX(Hh zHdRC{wHEau(5+>cxs?Uk2SE_*E`k(Sg7{j|2k}4fUGPWZ{lU0W#>r6s_n_cdnH4`x(tHgP@ax1R76 zR*DO?;-X})6;~G*-n%3vuSx3iO1T1yt5?BHrmjq+E?-Xg)2gMn+0M+FNF}eNCSFeX zoA>Vtp(-JyKpOb!AtXdR#Qm%ul5J|)N;;!c#Za?Uc6Z#m5B8!s7B$^^ctWaGmz7HK zoni&Ib8D3dgt&L=zO-X#c7_@5uCO8Wx!d(X#!zywHFcU2(Rajx>;kNl6Us|UmQ9iS z_xziL2#s(^L?z#s9?uE~x5?%Yvtm9L3k%+s%%PUd!f>Pf_$@*ro970F(!qSN!Gd7^ zxub8h;7^3?ls;j>Sy2eUa(^%{VJi52g!B>8C>KT=4~6U#RfJzURebp&U@Of>;EBT1 z56pKyVv+qz7|w!7iD1NKQPw{OF`u&jQfxj787wG5?*6ZZ_=AV!n|%CqqH!RBHlIQA zTVd=`IX`wf1qF)vfd(7s_Ux25N{=p70&L)SAoUVb34p>6*}xh6-xbF1=Ew8HhZ`mQ z{qJV>pVmxh?dvfp-zbIf1K+I=$r>}JGB^dwjA~5j)Kn%jfEd%3EP8p5*bO5VmNnJZ zW)zd!jtL{8wPws~%~>|hiXucr+e4`7R5hHOl4fSslDQxX|IN0U%zHh4-s1^^(+?A+ zsOGejrG{-Ck1h_K=REiW=r^h5=r#{|LNKI3nVKdu73SDE$Cf=|i0YG7V@_$|Sk@B( zEQpz{qoJu5wIKTfpy!X#W6~(VVUsz=QFzDU)BS>(0CKwM4OK_u zYcRaHan(liD`eFi(}aDU98NBvZx4LYlg6XIws_v6odhQF;)@uWf^XE7&fGM?Ab;=} zzP`XhYA#2Osd@g)n|vtCpABH}x8Uf`nQYoX>q{u&>+F_?5ZcCoR+rHF814YCfr4B5 z-{o;cUxA9=w9ZsJHwO$SU9{li=Xhw6k6z<(na9sz^aHp4oLyY4Nh9m(h_ti-SLC8p zzTLjv5L>?pVT41=ptc9(yzPGO?&8P{YbI4~syx*PJ!4Z-)h*tOVW9U7huM^mI&M9Y znxxQR+P=kFS99&ScBkmNbtEJ4yu0faJe$pC^B??cZoPVV`196lgM2Rr9$@#wmlV<{0DWmHAvvWrju(0d)-#s>7mYW&>arY zZl{O(onf!;pk0Zh*Sg8+n>C`ZXC7zc)}>0l=j;re1`cR6%0V;T=A5!i zLHNo;iQo9=LnjuUvio!4qO2t^#)*R|Uj#P^RMJN#QkG>_Q5G~Z7X3x_iRa!EPJe)w z4#*PP-I2etfm-|14;5es%Zm5aJ5ptXyE>;tP<%y$Q4uml!}8~XYqHO#Z3^n&f-h)1 F{sY+_=uQ9t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..62b206bf95fdf426a1faa45d54f56eaef4b2b9ac GIT binary patch literal 824 zcmah{T~8B16urAkODTmEqEXSvi1B6PkhFk-`ZO+6C@i}$I~yP-CZyfEHH9|)Ffm3# zc;IP`79!b|@E?3dj6C><{0BHwPzgTxG&ASkd+t5wP6uLZhKY>YX1!AN8mQK8)!Qvp zt~F4z)@~F%R2DdTYuJpwn14x4g;eL?TIdwSB7fgyR zvPAW;69x&P1-lMqVK9_Mty&#dz1Ln<%Gqp!0uX)-5_#7$c)_;917$}^g&%@}f`ylb zG%`m)O=tk|8zk)*#hs|g1S05GNi;L`UBwT^6XT0 z{2l-FCBX1*Z%Xk`zFXq{v$Oc#5?LL8&stEG0f2q~%gxoULJ>{?qyWw;#o>;huB1VY zg`a|Zx?x+h1vvnoC)TV<8Gcp}h&AWvYLBpDNH+*K<}st(WkQP4^&;-9JDe`5%D)-h z)}wx{H|o<8LjIsm8M7I-UB2vcUF#DCDV;eK%!lUp& k70vG(j1o@qwfW2fr;M0R)GyOSvlZ9oG`bC+ADo~60&LCo8UO$Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONALIZE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONALIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..863ee24d81d2942a9c2e0401ba5972cdc1abbcd6 GIT binary patch literal 809 zcmah{T~8B16urAkOMyZbqVY4bk{FYXL()nOmZx!<{0BHwj1qkCY3`gm_uPBVoi3!-EZeZ^TaB>hH;sCy-RQK9 z&3e;l)jQ3KZ)^(Ocw;$?yq(9^;^a(j(7lwYH2saXUp08gZ&f#5KQeMp4cuskH4#it zi)*e}$QP%kCI?H{wJ+HITaz#53dKTUa`624NYU#6P=Paf3;^h$LA)R7CMPaOrLs*B z#Y@DDyK$5eT9D@w7DuCbqg`*Hn*YkLNjY0BPyphOQKsZkinPyv4ba!%??@f=Q)oABxW`S~wCY4V!@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REALPART.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REALPART.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..859b2eb7d959929d509452cc87282abb1f8bb6d9 GIT binary patch literal 775 zcmah{T~8B16urCsE`=1Li5R035?(e=<5onhFOJLfi|s7T&Wb#evb9YLZTewijKuih z(;6*Ava8`g_=*^L@DKS9aJDECeDG=RoO|cobMBoH#GV=^GCJGcR@?2N&T!Bj4p5`h zL;cRMS9eiE;^?Jear&xEjFsF&J#Ame)O+scz}-S(==QfZU))Ce14O#LR$B&3OY*80 z?&S*$3%PWW*yb7Af8XQ_`eNbE-CX+g@Ic9S0H6*h;gJH!LInIhFRKY^3tX(26f;tz znm_Wrr1XLvn{wZq&Z9x6i`(vVw;kHq?t=p0fAEq;hZ&+`F@Ilqtz`W7-eiU0RcVcs zD5%NbEFrt%duct77cr;ATqRt<;X(XKsN-w%xT+lOz}mN}x;}M%T8Xuep8?FgNo17f z(RU`}pQDv`><7T8`Ic2xWfEYo`Q_^R*o{ml0Wtt5t@_NUnQdi3jrkwF8=7IU^GQKoAY*6{$*+c+uiDB1&O1!{MB=3wsEZ z`x3wM*M~uDdd411M3-eQ{b!muobmbE#_N>qv9XeQxv4k{`E@`zJE0t=oF4fi=D{Bp@RI5v?wY7SoD3t)0KG2v+Kb%*!g~_W4zx9-* zP%kbuip!F{R$N_PdjF!7n3mL)dZh}&l`EholCMrBFI}4Sr&LStu$>w+l}ubtzA`=O zKfHHG2-OH71=7M#A0Z*)A@1kRkZe=SR#Iu5Du$Y&vb*CpeXthAv8d@b!&6eDwxU#v z?-r}LoExh|AjG}Z^raj_v(wCQcZCgMz};>J(uR_SrKxk2h`uK*$S#1Km{Kk)Ce4t0 zcl?`#2(55P#7e#|KVA^_Z<5U)7Q|dE78bniGKbq`7Dif?$8Qr7**tSzDDUTkEfxgz zuN{4x1%D=Fr~D}kE{H+^#J%%52}8l|BV>S(R;4i7dMIR`$|C&Q&Em@q16w&CfhP*j zATZzhm__z3qB{#BC4v!`McLpu_MjnylTwq)Kq5DfEaU@EP8pL*b5^TmNnJZ z=3)13$Al5l+B4?07A>1*L=ilqogvh8sv1sKNij2H$y^YH|3=$P=KUT&@ACw~=!c0? zRCCVBP{X#4Mi+<9a~A9Yw42m&beo4fAsEu2Oih!S3UlnNW6Pc}cn!#^v8c3hOzVjN z7R1Q*(a=(6dMA5or|Qu*n=_w&UJ4xXn=FnWN)}!Q?%7Ui$F}>_a&{^qQ)p z@---4T)1kZ`W3Qjj%mWWjt?gn&~_JW(c{KreVyWYn|216#0xK@XA<_PCzZZ#f}}H^kO2fE(e^GRWnYVO^4Z(k2!90 zGC4z`!L)OWwXf#JQSNTib?ZqPlP|ivUSabPex3K$>jwwFZ2btY7+8Sa4?8KM!`~?Q jQTnHgbd@djTB#%ey7dzZJ?-kb3;=(LkCD4q4-fwZQ3mpS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-ROUND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-ROUND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28ebef26420618853eb1c7df87af799322f9b91f GIT binary patch literal 1612 zcma)6&2Jk;6rbI7jP2O&+E@`WA#4*9g;m$cPN-5N(QG$k$IWKf><4beA&MNkHgf97 zaS*5?s)8jrtdxX^vXiPvaDxL%5toXBBf+r;4*VfpxB=nKx=pGOskOB;^S*xXW8S=7 zG;mE(1*NsR)@WASLTjV5w$Tx4t+ue<+Gtm*LJj!BEk!r*$MdqXkbWx@GM|!E+STPw zbw#i?s_QGuA6*bKmjrpO-DtvLW(LSi?#*m&dO97-%cj~#d!|h`m${hBPNhRf_wF!! z3n5fNJ-P)E;t_}3&mCU0uxUy8qKYL=Uc{oi>pB6*MY2t7xK1o9bXsdtv-&}`Nz++f zM+`#ljuXh+nqn1o&D~>eGhuhzi4--d1gXgdjM%_q6pGHcP9&3+E=q=OYjfz{o#+-q z%#SgirLp`}f4IOrxQTXtUSP{FC1Z@=3pD8kS{dnYqy0_jH6GqTD8BW=FjIf96z%Cz zAphJ|xAo|+2<_HC)uRh66M^HwaCwXZfjodv7@=OHlIq=Orl0c3{Px6WpqvD>`cfRe z1bjn)yz_}3KbX{`3{;CU;;x?1hbBP&nLbocE+s%)kFsEQ@JD6hoBL?LJW(Eb1c&YN z=-Fr&sB=Js0H1;Qdu8$mT%J4|<~f5Z3y*Hs>HoQFHgs0apn_MEP=j8br}z4WGa@Rw zHdmyVFU`x^oQe(UN)b3(!4z3P39mG&7I1zE^zGVp5Js+A!; zcMh2Rv4NzQXxzZ(Pb+7E8G}BKir6r8L(*-lWLqK^2gR@`Yu6=@PebHh1YW%F$$LL1 z?h5CR>Dx( zHpmhuSE9%!?uSYSsrWK^88-Ac1(ZuAtj$sKJGe++zIe@8B_r>XSKcF|L8|;MXbqGM zy`WL*E+9uv(j+`(cBzV23QFCAS>V@boL<;XlDYv#gMA|t?!H9$5*aU$)C@^^F1~b~ zSFP%LM;P0b$AsE448|3qakD?uC~xyM07id7U8pAy=|lIfyGMIwR57q@Vd+%5YSF@m zteRwys)5xzwr*iEUU8jt?h1xF;{NpVMsnxa`xCdD=Ho!pZ@7CL=kra%22kfCu#D3s z6*=$jML3p)@wasZKf3&Ty!?{{X?J#_R_o3R2z6(N$$t0p)YMe>Z33rX=+dL)Ar%}_ Wl|xYWd3ll7!2uD;INHB-bo3wPNAdXp literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-SCALE-FLOAT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-SCALE-FLOAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3cea44d2479e42f7e514a8acc2d0bf763a3c4267 GIT binary patch literal 2026 zcmbtVUrbw77(e$GxalP+RAKRoCm&mS#9tcfG+QLI zEBTpneonO3@~d+*@0=BfUKHi!mEr;r7cRhcX!QBv(R1hGohjK=8{QsiGdwzUestu8 zc<0`YElwyALS{)Fj}Afv;vvq*RUu|k(~?qYl}ehNp)sfCRDBSOWSi7*s-a=ATw0bE z@^9xCFr39z!V%(JtNK#5rdVlRb2hmO7jUjtyV9DJh0x@Sl<>ZNFX)|fs>0B)bY3zQ z8Jfu6Ux*N3hAP;uiKhE~GIxF4=&)rv! z9OVi-Al8F${k^7M)q~#?QY(C*2Pb$AUaf8S=1w94koyP;0FL6USpSwAY=O=F*@W%? zH;`vh9e{$%M*zM1cv1G>RCE20=OTJN7tQtEsT3-O|D2_sf65Z%?9~XArd|*T?{}_O z`(lc&CDYh9(zvW8Rcc6MY2auV%^2@x9eg`9Whkb|mNG6G)Upj|D#h(euQ_E}G{f_t z5pJ}tqEcD2vrf%Ja^dI(qqi;34q|qmj078J2OTN^I^MVqk1}7hbIV{PtnON zRVMQbVJf@D{EUZj{pXNn5<1nE+27tLcr^3ea@XSMK)b8 z-5@=BNNP~iRxKvrv>X_^z!5@N8%|m$4$aSiqKyJ5yzIioiwTe|yxs%fA;mTfs~C& ze8KwGpw?lNS}Dn#%8co%)Z7;12;o3>-G#t}GwhTL<0tUlo;CD~8aU(bf`M=_S4=?B z4l24i$J;h6C9j5gaMSW7iz1eb7FC+v3ZfVej4q5gQ5Toe+xon-*P^4HnCApDh8D;DjmqWnzpDR zt0wcK8iethty{DKkKmA+;s@axG zPa50_puBFqvb?YX`lMrHqynFW=oXO@T)U@MtQ1&+=SD=NDutUp2`+)#If0uG1n|Er zz&iLJK-#l%+AuwX0HzIE#}YANE{Nkm`CUpf@C1 nCIM5$Z^-fad6)AFD7!@J^Own7n_ETpEU2&;8z7&i_xAn*mw;11 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-TRUNCATE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-TRUNCATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28b199e4197d3b5210169098e263f7642f104990 GIT binary patch literal 1659 zcma)6&2Jk;6rWuu#&&FXZA?T=2;0zDk;w+xNvq&WG~3O@F0x!n}Y^@g}r-)xHwR=QbupQmot^eA%7)rSd!|h?mAI6;2sWL&w>hDX z5GtZJ+q?(~$c5}LEFo@U!;}^?DwZ@ki{tizZFwLUDQ{riwn9mKdur4LIrmd?f& z;t;a;Eze?JQ_Kv}>_hGr=ePH)Kt_{tkeZyvi1$1}Vd$J~`4UO#l4R;&BbylAy&c>| zi2ETV@GP7kE031Bhd0pvPs@DaKoTiIfE*Qk8f4j|G8^6d{)h%g6~A32JMQ#uJ%i7G_DYB zA;a!pT9UN|73QH4{{D zon!pIjYM)Rbl?kT=qG_6f`$&pv91$cB6%~HH{-4_==$Tbc1?2lEKt{rzwfZ{7_*!z}{1Uy^i}3!T^3xRvGa%5N=i;*<|EBKn^K+U55&sK3>W( z*&fIur`My%2JQw-hnV;ZeFZl37Xy@YIjk)(@;fl{8ofkVO+zbKCo7UdvRSxfHDly9 z=;#OZ)%WR`m*IR10E0Q5q%}s}0efH1Tw-;g0^_%smQyZ9-Gss6)>sx!QZ*X84tBx5 zodJ!Kqe6~Oq-ku9#vDgq+16`jX{#xY@5tj~c?|~Xx>&u@oq>$EGXdD>PbeHX^Yp+z zvhUc3tjER_9mCLpOnM#bltj&#SeI3U4ly-|^4&Z!F`X#d)^zGBhFat9z;mW}vmZdu z^N#T(mgzU`Ll^ueVFRf10a#vV%Z0#s`!K-sJVb|fJDtwor%Mzht@&8F+?p2=YR!+( pqt=y~nVHtx6iz?0rOn6_COBa#C!jpw9a5_aN(9z{i=N~ZS{b2wA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-ASH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-ASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..96059e25d609ff9a9353ff98ad625c6807085bf2 GIT binary patch literal 765 zcmaiyT~8B16o$`kKUmsA3eiN2(FqAR8>g`irciGjm+2SFEX>Y|T#~Z2O$yue!^9Yg z@xrS$T8Ly>J_@*m)AF-qXVt3CUknfILMoEbslnPDQs+wHbHZV!3GL3cPn zO|OUg-muqjQB&&Zm0@xEx=M`I+@pNTzLaV7-0gw8gT&D7?`*%kkMhfibbIZN43?JU zZ@%=fP+DBfrOL!MFWmlnr%=ilOAnTFsq^C_CF=n|1J0t)BtRBo5FGefT~J%#a?PZe zku|CZqrlfB3wCVE1AnG~23{9;+!t;q!rASE0uX%kwX(wuQL|WZsJu}!!3Te;#_+mC zBNYm&_Qxf1S7e+o;36h=6^@URPooyTwNC5G$sTNcudAEWw`Y_@`}8@$?AwWq(mMIU zWc+Ki`kws+7`5K9x~fb89JIdP+#G|*v<8p?IBPd%N3Co-3u+?x=h6#&DIe z6_axOq$U+sv2`^riDz_!2&0NQ6%Lmj8)M|8y=4o!rYhG@2ulysv59aprb)_aopNq* zY&l}x5qfM=UdZT#ZQ-$Q>!HNW=C4d`A_fq~qfy1`(j-~7_!<$FsF>k!PT8dugi2BB zH~w)L#HJVSVLHAdbDA6^jwbteS>q*2}FXM zA6XFzpqU^GNTvlX3QXl;OhBcKuPhZ~^aB-4nToOUFjf+yrInb{52?}=IrrS@$82|% zGgbZJ_UXR&_doaEe?O;tCK%V+bT*zI-ZnBg)IS;@-Z?h1b1c4Pcr?Cac;{$ee|!tn z$L~!`dGTAFsdQKK^+|uh(9$>Bzj3U8b6nopzhm>pyRVKXm&H>fqk}`RvUDkICR-P^ zv|e{zv%e!%$kJ?Is%dFWE@@3JZuVb#{1__?GYr$mOp@SZ7=dvx<-;YRNfrxoq9c

1#v<`NFam|;wQYBsmYH)An@Vo z?fYilH{U$Z%=0ShepJa|rMglpm2C%Cn~hqtftRWdu2-8*-o{IS2#AqYdhM5Q-ol@-DfNgsEmtX(p9XB~6}J6W*%l24F8zE~^@z8=b(7 zYE3HJr|dG_&Pp8#2zf8Nftj49m?>TJE(^~IVeg{bo6@8O*qS`6A~A5Ag|Z8tJD5Bq zO-Ra|Y)G1JO0$M4o2s#Z)~@!SN5~hCMntOXgW}D!uwFrp57Xia9E%G6(#>Ur_ME?C zNGPs9(YK-ZLHONj=Az#BF+!`w7xlihDD=YT^`R4SNfGKqq@2B7>{~LsZp*q0eem)%Q#ztt*YbhKJX$(Sp$Wh@X=fb=Sx~ z>Mrr<1@0P<7;SrS>AWdE{Q#ebnG?QZpuic0TO4#b$QgwO2k+yc#G_H>(3cEEpYiAu z?q1^H^Caew*d*C^4~Y$v7~3SYheW<;IZ~zCkd|5Rb86EVx{PxM(*Y~rfHu0)tT*rj z4}xl6m*?&`Z3yG%??Nbm8|1-I#b5XfFgW z#Oe3xZQqYGU1Ss>vY#)fd+ve1UyhB~Pd2Ucu7%Qkp+Fm<@H4dQu_I6~JZ53|=P~v) z9y5iY2 zuAbsl{x&M~(_fteTw1PF9lMV6R^7&h($bRc*p<9ZtBihNT|{FrAs6p6HsDj6A2^_L+2MDxEnn zHPN-XejX-W0DuiPsEY%T1Q8Iv9VAnxVwmD=Hm``Pw4kKIwJ?a0TEv2(=wZ;GM!s7U zE6%D@q2;X90R$j?D~Qb&RN2gGYIqjD412;eL2p(S7fET-oC1W{zZ6P`VQ}Zr3r3(Bna>6mRw;x8!SC;|Ub^4Couyo~_ z#DqQIi^P zCv~++?QJLZdXw7SMyfE@r1rFv`h1hx)lTZyO=_Zz)X4rOweSB@$>;sVUa~efN=YE} zh3A6Nl&q^OAZvuju0AS)!O^po|T zNGZCm>7rIJ7Yk-8vWq;>lakcqBGV}(43d*O_K#!)0Ng=0jZwPz`v|B*IV$C8AdnzR z6Oc?23Y#|E5fIhAJhBaK+cX!IS~TB9m$0quxz9S>9YCf-BcYdl)zZib5w@(3{pe_$f~mPgmP z3%K|yk9_VP;-bi-eawOHnFzk&(O2BP!Nphbu!o1I@t*tf@F*T0p&8u>gE6~gd1BS| z$stj%*D{D472Ziy_MH{9(y06B(MRaWKf>T{(;?y5DQOHXS>!k@qH>j=WK=tK4;}Vd z_-=TXewO=WU6D*h+%d=btf}Zy-oV{-80p-Rf@Uf#LE%yuq_-!7EZcT!ejQcas%TYe zC9B$4alEpP=s3&v9j{K`dJ(f~o@Ot{qXdob;!G_J4*m!8CIa~-%SV>yFs$f2+psDW zo8#D63l{zv2IJeY88mK@R-y4ji2O8+AE4JS5D5I8LExvYkoRu|k#<5(P{?~6@>DBi zAq?)_nMtv{TqaE;v*UV2@;5^(W3vdeoD*%~05ZS#ZReo!a@F;mI;xN9JyUYt(AD$Iao9j_oM$j9k$Co!QRJvJ}Nqwp(^(Y3uHm zi-lStL5!OpYK6=}3BDL&OcXIZaM67*zL@x6AU>M-Vxox#!;>%Ke`Z>!@Sus>-IMS9 z_y2r5|D4W}qTN!6m&OlGBvbJ;KR%hAn9TB{<7qxKKADci`BBvKQoyZ`jaM(k<#CJKNvJ1lrr$ z+5?+fN*-Lgz`4f>Au*C?;3C9L3W)i3&h0m3-4MEiAz4twe%Wu%nmH$)MTqFKX68Hr zK07`kq~eF;DR!Jg8Nv}_p36DABZ_1MRmGg+X1Fr*Y_2@02w^;$*dr5%b3O~p&Y8K= z);1v^NWG#a50Fb2N=_2u_{!sUux4&0ZufCF#<-f#`yA1FuZJr>V0Cz{4)Ng^TTXbr z`1S7e-prwzg`$Yk|Lbni=Cf#v@isK)lee*G<;f+>xx|g3io9BZ;=S3>S+(LzLS_?h zs1NCBkIGBFI$a7dG;wO`j1QAT_{;TUlQ3& z4AtPO#pOk2&z(|ht_D*})C#VckUK+l`IM;E-JeaIQR`BB5NDF-amU|%U9J0;MbwyT zt?F&W1ZPxyV1{Zjom%0*#8*E<#%7cMnlo&5rxzc{e8No}<>vWZonKOwt{@u+p;uJ8 zLb4`w22rE*=zfQbx*Sei#kh)a<~)8$G^AcZlZ}XmGb33;SF8`}hTQLPphuNGl~PC+ zl}K3VR<(ZJPdNwoWVE6BX=%YyG&psmi%ppRaD>_L6}Zu~M3?)6Xr}H04|Nq(;^MzHgoRQ$KD1@@h72$>=jVUMmmp) z3*}v6hzZwFC}ypT1`|KQWF9G^X|l5DeM32ByNtG~M-)n;F57L;QfAI#Ca0nr@-A5$ zLSgdfUBTcwdKEo%`GBru%4yqk%Jw{Hdv@Bk6&8^DmJ7LOxsV?$7m~wd zW%^)$ry3IQJP~<{ou*TbC|%*b)EA@KEwyqAJ(?N`Q#Zzw@2o)bjTJ$@u;C(>FYg!oB8qiJ=JzJ`FgVQ`8;BtL zOgd#NXHZ$F%f`S_>N!Xo_t45HZ8B)(0BsJ^%5Ai99j$JrO%1fVo;G`Fbq&TkJ~DGv zvBYq?gCC0@7|tdS$N6kLlg%*O6*ITWK!LBH7VG)ZVZ1Fz_~e*<(J|e01G;g)o9~)) zY(jjJCX0qFJoeCpf=H(r(rGEW(I%UspUqsYUH3>bo8X@h@Jt$xW#eg9oBNUa8JxCq z({+m?k6>4L^QDhHir|wOOX%Q}*-Sh&$|5s%f=%!mliGk?Z=3+-4Az2+K?67u$RAJC zAU~P8miA5=2Sv6oSnIzAMvTqH0twUlJS{CO(RC34IWPeo#P#FbseOIv5avT@Z!cFbI2K81_R9Mj#HOZ~zjJgqPtU zq~H*Y!8lC7E0Bf^WML8x!x17g9ETGy4Lp8IEE35j`^WH%*;u*V P#_Gbq@<=Z3c<|s){*lbe literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHARNEQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHARNEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b5f19e2bad0cc48ed3e5b4a075093de74032f5c9 GIT binary patch literal 2218 zcmb_d-E$LF6u-OuAZ^l`XstBzv6L2S$_CRGfdb-oyKO@^yXo$RP!utyDT$;>O;SEY zN(Ua8VRjA{MrJP#5575$4~pXh3e#cKaeVLrXZ#O*aC~s^!AA$r-K9{$8Fh3fx4(PN zJ?D2m_MYBF(r`dl1-U#kTPWr#LV2z>J698?%N3zoo~vYY!ZhlIQ?hO-r^h6DJi05^ zY_2%TR&tqIZc4D`a@DEK$t^-`ry$K%3Ps%P*nwhfa9iKtz(BNlL^4&6?Qebh2K)O5 z2ew6hNeuAYgYni3E{Vgf;`LSi~P-T?na6Hd~2LfuMUT}#v^Wu*ViCE_+ifZa2S8# zec{h-R5Mo;QTmtWZX?>4&@0`}r`x%F*pHoAw^X=^swdB`dWy^6INZ9Vx1xA=QN5_Q zeo4q;{=D8g&T}oe{kS6?W+Zs-BP2k`QX#u$=@ahIifXvTay33TP`W+cj+Xy8#4}z9 z#<(KJ$^aiN2WavFtivk)KYD&-nZAVuEv_nN?%cilaJ!JdE;8w_mTT<(X~x_a^9zNA z{C~_0OWYU6E3lLg628TG*IpBmb!|A#ZlE|OX~U{wh(mGIXrpF?Z=y}S4_70u2E68> zh%8z1m}n?g%D`(XyZ5}&oHQ*Z!SiU*<_&_ZDw38;iX*y_Fe8-XxyQXNJwp9;emw9= zs>&|4`Cw|;eXk49rn+XFh}MW=7`h?qDJz+>B6Y3k5{O9Jr0D7yf87(PYg(omqCv+F z#vU0te*+=3p3T|QY;0o4T(9hxR3>zx(8!XNEGBMX*~%%yP_z|8O*wWJ!n3xAO_L>4 z@$#U4Jm!96Ostr#dzg5Eu4Ztab}%?j!wiyW)1d5Ej7cW-dL})d$!gbx{K{xF-NGu- zhJ54Nkgr@D@|kCI0d4%434Rkr!*vMdfH|2M(p3@bN+~KM8PZeQa575Qucg9TN^+Fsq^i+}t(S>~Ix{&uh+e>ug8O)(xjhog{+_WU5@s#FfeUOIIEWL@8ZYdTG zO)xuCu_od)w3}|~rENWQb2n}4q&;EU){fl#TF36n<};P8dxTo%Xs#;Elq)%*md})g z+VQfGsT`S`$(3qVX4~P|>#bb1CUnkAox*empOz`1Q1V^{rkn3(75)Gj26sI8&Vz3~ z_}YWp9(?M-2OeB<-g7RqnOG+q3Vt5(kxQe-Eya*jllsw&Zua_k&apf0=g(ffOtC01 zF_W$3DlBR442>}8cgbn*3fC^j?)F>cNa-ZMYgFY=cXx_Zvvgirt@-#>=1TqYR0wXXAV-SaZFb*mtKm#3;FaZXb zU_lD@LmCdiBpiecybf8If*ef45y(RU-hiV}gc&G78D`;4s6Z8JFbBurIGli!@D@A| zG3bMS7=Uf?0&IsJuoE^wCv1c+=!Q+O8G7J3h(IrF0TH6G6$W7!?1nwK_QFf>GQ0wZ s;8i#bufZvJ8&1PK2+#~ZXn`gO;O~iowb9ylO(nOSkv9t)7#e->#V(e?m0OyCrQ${w85c9k^+({dCwFAQP*@_Z7`8E zwX~ixqu!cV@Z(sttYg|cGvbvG8lMh@@Dn-`db5CGUWydi|8u%nnuu7M@jV0`1kD63 z8#8a=0Gl4aX@@-h##rNq)rj;TYssgr#&;xXZTd;8aafTX@bR@BxiHtmcE2RmOVY;7 zca5075k1TN-1=t7}`?`94rPpN`Xi*&|D0>P~!m?7P-kKgei}sCaWPPKTnv;QQ=sgac**e%^XnTa`K_z)8z8@jH;2jw zDW`0ZI2pWg_Wo3|S6|_!jqH`ZP@wFEIQR0uIl(@UgmC+BOa~;T-g~yt95t-;K!Tr# z+K`?eNSe0RpTI~u?nIS3R--iFw+6p{{8r<)3J>34)X-gHNV82hYvbW*h|{;)8FgGU zr6`!Om5yg4Y3k{0MjN#3loMsLB5$sCtthKgYgvuj$QvCqmCzg)z3BFUX2zW>2RlEK z)h#^7a);1o+}1Ng34`abfEvJ)yfJFpwqgd=xs^wgR_>~(R|v$exm#-Sz+ygrp``fL@FrUEnIn3VlkXy_=Hu60 zPG3REppmt0GhK0eF`2iW#kQ^G^&lgBK&*~8&vT`;g;O)i=@il}&S~777BvGDY-69~ZDH2TA;@+jsPBt9_4gu0eUI2Lh`mGXBC*$4m=}DL z*q4Nu`j`+?7f8&Yf<8*=Ar>XpN^A$QATd8NNk}XI6ij(fNGrb*(#ns7w6Z1&l&2`= zF=D5P%@dm^ADCi`W+Gs9tm=eV6Hw~YmO;u*1p_&((9N&FuQcOmX)vAs{R4j!H09xKIo&}Fx9 z&8f31}%)ZdVKOdl|f1nO1vS2{+mngq;vpgP^x;T1#f5j z_pzo9*456MT3IZ_n#AGu4X?1v%`Yy6TUYef@Z@p)H8T;OIY~c6cxvT*+`~TathdfD&lbZr zb=TCcxeAgA*R=Jd!|E`Nb%|B-?O@$lt6sto`it}DZ+q+8t~(YTN7IkvF>pi!I3^QE zH3*ZurXc!ey=7(f5uvPn=&k#&Rl^G951T5KpHoE-_kwfDv$k)}suEf9vv^%LV2b>} zrW85r6*~L+O}sTt`t2rukS<+W#?tz&IK>t1^Xh&<=ZGFLb~y5QTkk zD`?OO`{8!@G~5Aq!d>tgxCicq`(O<2htu!{cobHE-)eHmTdxK`)IbB&LoIxf$8Pr4 zLmy`+@Y;G_`|);!T;;7d6z9GNdds^Kb)|pNQi)gaU3wPp)j4|Jev&YFCt;KC>S>mq I&t1O!Zvg;o9{>OV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-GRAPHIC-CHAR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-GRAPHIC-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..096727067d73e992eecef15ff0e4100e0b946e36 GIT binary patch literal 1099 zcmah|U3U{z6upzQX_}@b1zE0zh+{E`V{b8O!BQ2SPH&pDlbLYmh7zDiO{XN7HZdP4 zB9-L>PjO4=f;FS7|G`(pB@g}~|3SUe^34NJb3XSyd!I8s(tqACRinP%sMg%3TJN+Q zowmAGZ>p_&r&)H@H5pfL8a8LQvbwQ2@mVV7ypSn3-Icbxs)~-=T3xv@uBJ|_dZSsb zNn?6ix~Z9y>6xjiiC9K=%ssR>_M~Sfr)JWpCSp6=50pfm5K<3Di z%n>w`Ga0q?Jkz|M*NsXpwCFJIbw|@`yWXHR_qtmP=&ZMhLWp;_8_g6gL*#7B+fr^T zaqqY8aL%FyNll+;Bouvu5}+$y_dsfrrs+J_3)!4OjjYaTfowmB)PrgMsytdy9&V6p ze=mfVMh=ZC{Z|PI62pXSOH)q!#JgR2B>nxr48)bn!+$Jk|JPgm)%ur^UgeIp5K?5v zy~>{lmv+g@bd-=dA&;x&{k=+}njoQm?|%2NX4uwTE*PF>b!*OKoX+NC#F}@sP@hy~ zR5Ns8WGQE&$R#UdSC)uVas(Yl}e0gjB}e)yC@1pp@j!!LtN9X z65WkEnlB|uq+U^WAWVqg7sweYOOQy$=6PLQ2_7?woHOf%HTgsYU&-sfC)`$B9oy8$)U_4)AFQg?jlB~NVw=h1-qrx3 z7{oB*h~a0%4tZP4Siv_aV-+sea1|9)aSh+1hIMS9jt0I%6D_pS!F7C(A8-RdLdPr& z%z+_;d1R5p0v2H+4+}O5I13I30!5s|63(N93rHc2Nlf7+PT^Bb<1{|O`xwJfe1Ig5 z;X@q9N6_#w#z8TG6Zjlo;0(URSGb5vSjJ_1jVri`pKuGCP!;bFZ!09VJYsOB3r1hr clbI8Y>!#xm1!Yprvqf7l{~hxCv7Md&0b6WdqyPW_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-LOWER-CASE-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-LOWER-CASE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d44f218cd8c419bf601622dbcb53301f6d605b9e GIT binary patch literal 1484 zcmb_c-EZ4e6u(Z|Ea^vI##hU9h z+-1>Tck9c}2SZ}|qNr4BWe*n<6KJL<$44f|#)jKw6ieGj`_G(_$t zszL}Ul3o5u5RxKM5`5;TB%4~cJd@R^tSdPx1SqGsTCjfjm(RrcKXT#vW2 zS|G?Jgc#rDZzmy--X-MJ?Gq=3(t{hxT_cI+ zpH1zKk^GsEX6X|nITsNytoiNJi`|E5aY8x>*)11Ohb{+P97 z*)$i4U_|%+d{m7pdLb{*7-r6rm=F>EooyQuYmX*aBHD@5NJ`W+4O2D>cD`Us(RNJe zkQ9AM4)-}o;HT2ZrkjWo!dm!9JNa;aMW7bCplICq35^&pK(V>`kXN7?jwf>^6>N{e1xUjPjKUa0_$t`uiaDd2RI#ai zjD9U^Q&Z6_*3QF_s`-LpQ`TDu{6Vks{y+PELd22A=h@ja!FCTQFa;`11BDrwg$!ij z3e159Incp?Jj{a$7T8dL1z3cuumsn7c1Z4WjF8`d@SMzFcw;l(P5f+?o28U@;=rRE zc&>$>&oiF*$5!U?k*w5yR;rvLf#2gftM4p3ob}@(#vhariWqeq_$_KiF-dd+HI(2> dMMWa|*ieKG5z-Q}#?B!pte^FgFE8xv{S6fF&kq0q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STANDARD-CHAR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STANDARD-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2fe40eb43a01c29dc139a7f3a58c578c5442672f GIT binary patch literal 965 zcmah|T~8B16rJ7DQYe&`keF1#^@A8U4oM3}#HV4I($ZzO?uS@kOl`Ncq_j=DB~c?G zy!f&SRw9|z@E?37V*218@*m)x)+oUTH@lgcJNKS@&b@bgDEM4aC8fFBs@0vg)a<&g zt}9iVZK>1jwo8sw0lV~8(GB`8LzLXYljOL0>88|nimp?Ztgh237hgY+l8+_QYS-$p zSzd-?a^+!aWoc<)JWWh>i1y!@)XL)0Am-xqM2IyJLM7Da%NRm26hQ2w7n3b&S~#6m zDb~m)m06E@VbFqYlN!v6rzE%8!gXiQsdG8I9V8&cK6v4@ttnPk*VwUeAWX0$Z!)Xl zJV+z!6p7*AC>&j2-b`{4r?6=eZH*XfSji9r=h5lO=pnERa_ZC!94<^LtL* ziY4MgXd5AZ0Sml9njfkOcqS1#2h;T7=#)@Bdl~KPQ8@nWsYiPB2SUB-dp(*H1#s(q zy|y*Yrtu)gI_l*QV_Ny@@hS(?XhOFq?T9!+~8Q`f>1FvSmqOF^<7=&8I zWrbKu1{>6}4bZ9#iWM>orbRbJ5jz90(!Mq9eKLNW;<@NQ7*R2xKu5+aZ74A z+eNpw=SZ&8abGd-rUk2Xd!O8vDn%2KT{`~$dce_m#ucxPvpdBV;J`@)WSC*~A` f5{u$1GS#d_4WgQUgu4Ozr?zfUKY>2qzqt4XZpR$K literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STRING-CHAR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STRING-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4883752b894684db5f2a703b4d91b8ca82c970da GIT binary patch literal 1053 zcmah{TXWM!7+u*oahw27rc7s2Xhk5s2sYGCQW8_9D9So^B1>kqPB6DNaTM&Hc=#zU|lYx<7_z%2N7OV+VPFrpdj7FpVZb#oaXS*bF!7x>$wpp)K-G*9g zx9aVdx>0MW&04!ra@7r)S8p3OXLmEYu{3ce5p!Ovlp5}8%UxGR+ik9|-a4r!W>vl3 zs8r=)W=4jI)O0d6H8l}S>yEjH_THIfYH}(yotTL2K7OFYYlM&zc^P~L2#J$0@$Plv znqZEg>8#19rRSLDb-hkha-ju>aj!F+R9m$=t-3edYCvbRNfbi7KRVHL!7@bFw!9tX zXJyFyy|X`S(Y&OlFEA2{{)-ZzD_&w zSDr71Rt}5~E0Jrx4TIW#LY~QJACgrk!C0gZ8Pb7~hvz96*lfE*aobgM{vc}Mf5 z2=T;QTK0zt@%IG+MwTT=U)tt5T{ywdi~{G(dd(PLF=YOOS3C^eVSDKQ;8DpjHqMqA zFH%R6GTEraJLnX1bGAwUb1IUT2qSNpKm&jNw>$`D!jkEIo2Ip`ImvIGG@h!f? zZQQ|KY(te#3^B!f4MR>d@!?uaou$M!Jthlc)nl@=8uwx$9H%C0ZZFa A@&Et; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-UPPER-CASE-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-UPPER-CASE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c7e6f071f56a4d55f496119767034ef67cb788ae GIT binary patch literal 1484 zcmb_c-EZ4e6u(Z|Ea^vteOlthJiraCE&fRmk|I$OeCDSln_9L!m({4OD~nVL+JPU(UgW$*&A{)Q5S!JS?77!mkGHeZ zAOa!5r+$1cud8;}(1Q(OUFZq!_`O+O&S7iHJSCC%E(%8%5GFk-PssUPj+(NnSX9oD zyPNUbSjxk`RD_pwzw}^1xK|;SpB5q)j|}t)F}};+UP2yRCFIEMLx+XZz01ihBZ=l; zZS9Vc{DqKq>0=|g5D_q}{oUgi`}fk~g!B-yRW2M2Ti(O}eGfm5Ajrf2a{^+$I)G?f zr4;Y|3x7yb4gFk}6C`I8{hWr4pUvWqK5t2p7)wMtk^MeNRctjQo7B#m$etR~AG4M$ zn=VEo7}38oA627@p3lj1hPh}-Oo#}NX4{6ux}yn}i1y+%k`gsd!<3D@oy*%&v>Ow8 zBt>76!+j1C_^I@P=_aCtuns=bUOt@P5U7J*P&97*j7E$XpxE5J&nr;#rb+dE`e6e1 zeakEVmw<5M;jyfnyFWsLk|Vld^KvYtM5Aj6e%M-CJZot3p0X~n{w4NUmK`0&_^uIp zftq{ap>%%5oX(tS%d=5DwBQTGJoTZ&3LclXT97mrMyGC z9%t9H8hSp@c;cVynTPwbQaf3xa*720fak1SDLS0>gCfQsln{y-bsYE|YDO_hbOtq) f;7dhCB8J#lgpCo>5wgZkASY~?4U(@;Zg2ksw7}9G literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-BITS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-BITS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..08ec313d9b2692ef79f5c45d6578f2f1c09c8397 GIT binary patch literal 859 zcmah{O-~a+7@pnIPf9IBV}f5Rk<023TOfgY8ipw?YH7VN=8DT{4VXwwf9V+}^}5`{nwgj%d#1 zW^%LH+|0~WB9EAH#`fQtY;Jls_i%11ae8>5q?-VMDmam!H~?u70{)(x);VDu=8Fb_ zCMpr#@B3~{c!4$})OSa-TDRGP4d=Pjkao5^Kmox2;KuT{iFwg7{e9)NlJwuZBSjOg z3TtSI05$fTMY1cto61bXX^0Dm!i6Gd;P4=_A%%Rc9WN_KJK*WJWpzC@KB|PD4b;in z2mr_8Huff(RBA`xO>zF&UwLQ#0H9xcYc8vb=-8`$xwbyACdx4Yk^r34t7H9Ix}FAV z*#GF>)UjnQ7Nt~JK<1)Bqy~YQOH5aX#12Mvj5sbpO1Mph2Rv9pgq0a5B~|&igIjtq z9Et|4Z{?Ld)i>HrGROF_6@eS%w3g>48{4I&*1{(GUQ^kX&APO^`(L7A+yp zUSO5CJh>H`WWccnK?sU4^#4ei9wkqOPZ))|Ovj-`$ z-N{@2e$=aY$lLH1Jl(tRWflLkzpn}bw=pG%6L`sqQRIXog9XE~P3U-RTbu;r;M2X+ F(_d@m|Lp(( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-CODE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-CODE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cd743c45fb160a15818f05b0459557455fdcc549 GIT binary patch literal 777 zcmah{T~8B16urCshSIb|6EQ|7B)n{#CgmeyeQ}&lY0GvNW@kknNm*=@LYsb=7$Y%0 z__Rg~k?d;t556Ks9{fZ81Dq|2L?3*bnR92(J?GpRLF@@N5$)`DTWz<8I>SMCI6ym{ z9_n|7y@rc+6pmg{OR$#}LRa$-3KRB~N~7m)4cu)chi-p+>-k+&xQ|G;*J`WH^0GP> zic9mw#l`$Ynb_t9+kfB87Z;X_g{Az&`SFpK?EpXn&cY=Hkc9~N2VT~Y%$B%ZH5ull z&J2I#dr9R5J2n%(mzzg}P8YY`XKp*Rv)cy^z<=*0%MPcqYH|Nid!?oQcivQ$<27ZC ztT51%zgR+c&G#~e1-yW1g$PWo5`*KT_~TH>m*#0rJK2NvuQh!mb2F#KTBlC|re7!0 zTJz)^SNk8M)wldRz^M6#*K}DYMO-n1pF>)O9Jq-6w?kwlP+B$d~U z!Gy2`wj88y*twF576vB znMFHW>Q`=~*51X33bFk;&Hv;d>Z-wQDj1PWP3(7;V-03iGC@o`m<+F}KI@JpS#SeB HqVw~g272e9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-FONT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-FONT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c5db677192b8b6558ef5b77db78e056e32db629 GIT binary patch literal 857 zcmah{&rcIU6n?v{{x&YiUbdyX5RPS`{w)Jn?3}e5JMx4?PjfRx3osL)9iM% ztwu|0H@dBgt!+tMdr3@AUu7{_oqm{%S{E{vmR;`Ho0{m_?alIw`&x2A!_8K$E-&-* zGEAoDQt8>*>1YO9#u?jxds69{xpeBmboBJ_KuI(JpaLiU5dla*0Ngz%p$lpWl*t(s zF`TEm+jpI?^n!{O<*qZ9(mIVMs@u=)x^HK@4GMt!!3k%IjEJ1c+5_8`>qdA5O z(i&c-poV|5`0R@7#FH~<29Yf0C}T1KhXY z0vyX|{LOGosUCf2^8T~G`i}ho=vUve6;+WHd(|)3)(6&PIt&m4IH^^}`_)7(0cz0w z=-kwa$(C}yRFuVR$)Fr9<|M+FEnOXwGZ@ne79@)}6-6#Rkiif_R>=}HuPXmm2vhe) z0>fS;5SG54TYmCyjUbWaW-k-Rj=;Q)X)opG-c2U$#=ynvw8>pOscn_zuin&ZJ7*u# z$9AV~x%;7Bxrcijy~W<6-lXDwcK22J{B6Q178G6bVdMnm*s#12zf7ulTr>ssCg9V( G)6-vT$NxeA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CODE-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CODE-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e2b1f7f301089dbb4f642b962c2d2e669f33f0c5 GIT binary patch literal 860 zcmah{T~8B16rJ7D?@|lFn4scHBrzMONed)UeHn%+Eo^sjb{4FO549||NufZ6Cf-RGA*BQ$y-DV3n?B{mFm$TDB5<>2KCz7{xDvE~g9!jsJg!|4JE$Vn3 zq>&Yd8fK@qR5;Pa!$z zesFH6)Xf{QX*&pb0#bf8t7mNA+u}>R+6QEJA|Qn z@j%#%1|pz4sWQ$Djtxt!TS5&)VIZLry^IHWQ}tj0smxz{3TAiEtiaK5g zX=H^VIra-BK$koxmC52PE|E2cX@PKbava$Thet@rtFi_ebx8#>6z+V7!b?5T&t6z`JIaOG}1^f4dZ32ZYqn z037%-v^oeDVJJKxoB?+udO$~;_HW&Ue0(?;(mdy$usdC4>VQlsI~BO}Ip;?vFUBkid1E+Tg^- zaSACSih6*{>Xi_Pc0f6Cw8)3vkr0Rj5)wx)NR{#jgg5Inq%Bf=;jo%{Z|42@ zzVFTMlFlVfSG3w%y;3bTl-g#qzS&e(YYkxyib+uZ$ zQK||!Ya2u&#Q)6ensp7$$(n}0C+$c*{%x-}Yp6MdM&}rjyNaqc$T4``x#&m&3leEPA?EzCSPBT_;;V&dd4!WS;WOW6Sx|zp%LWn>X`$Tu4Sg4mrLfzt;o69|RjmJYh=s#;<(^Su8 zXgeC+Q5=C-idmLvsiy1XTqhNZ;nkiLHI~)DFWU0Gc>0NviiDBr4lzf)Vj%v;L>+9A z>caRFjj(`39bx`~3HvnHvY2sdXt^ZLe!{c9?x=RiVvsxaKOQDzW0h#+Gr~0w&^)#wSYg56{WJ?e)qz+ zeO^>K*e9=6&rBhIzkFY%nM0iaO!X=*JC!doRpr;6%+FH~VWB zrGR}D!1tsjB6T2B5rL3u4zmammG=IhO8i1Q{U^^(PoD#bd<;YuK=4~eFrq}=|JvUZ zZ{=mpV${KrKY4k^T*mhzu=GFJQ3!RBHQ+{ zMk5#ey-rY|2PWVWM2G#oBv6{s6idxhX!mw6E@)nd;lN97ToLzaPm<^!N<5l JzPfaD^beVx4-NnT literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-INT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-INT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..30fed284bf844e1a44c730ea0f31e83468a50740 GIT binary patch literal 2875 zcmcImU2GIp6uvVH%kH*awx#}1N|~q#4$lQ0dpBwP@x-OI(AgrTHJX=<;IMBjZD z$}YIYKs2VbDOy~$l!W1+8}oG+5fX3KhD4gq7unl=!mUa4!IypFU}HnA;AOdnS*|0S z`LvZ!Eqsy}a<`8mRCjUBdLeu3mEeLIB+EbNl9$ckHwevT-!g-JqEJH~Z>}F~qI|^f zL#P^|h1`g=@QJv6NoZkBIkb;j2g79JBlAD`F#e_Fqh)eGBj3ED~l_VFN z%H&myTwYP~GiCB>M&7cb3KN&tUykx8wZs-mnu8=?O|^9di3Q4C@%OJSUvyRx;80r3Q-LlEDp2Db_ZSn>N zc;}$@Cy3o^I&p?_i=pTP%_B$zh*!~$v4QIULz4I^eLzjp#SOCX(t=foF0T=)S}ko^ zy0N4^VS)NC5nug(hro(qW#TI8j$_8I<3_sbz#HkbmYiH*i$0)RLyAp~Dyb8z@CSnm zzcZ-tGlL4B;wI_??z_Z&Z*X6l`=ZiEf~*sldt?V@E%E||vDzr?6luI(gT5p7%Cb02t=$!y+xg}l zxS9IH9JY>4!fzGmHij1NFtqS3hkeGUw=2*wjy}QBJOyEhqjyxGTRFO(qpKJU{llj_ z73e5Kqt6){eavC+;qW9uu3PqclwQkBr*PdMZZ>du9}YiFD=oRjO-^Q}AcfDVVQFlb zd~-*o+$8^8Qro#L6qa(YyCo{OCe6}ShbUoD(CjWH6OL}FNgG#D7&(ALY17eJQsQ2` zol^Mc(Np`q2>lq7=5iOZSK0INyCKpf++xG{@Wj#4VH){C1(1)6z!X44;1-3$NDPvT z>8GczY9y+NV+fG|!d;dlmPrPfpQG?A3oU%Ka-nf-G2VP-yf=9~^RdM1tcFU-=Z`1iN6#FkMEZ)=d1wCiqzp{}Ix6}yD5Qb-9 zGi-saunk&ZJIJsDc7g&C*acm%2cCx)U@z>0{qPbTftTS7oP}+>+>#G`;D_^20}=$F z8UihDsRo{fD6~Qh+Mpde;5pb0oy~5k0aWM)4Gw?~J#=3>07%PQod84Nk-B OtCqhQbnVE!d;bDZUq+q) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-NAME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..673ff4325dffad6e9d236ea6f151e336040016c5 GIT binary patch literal 1503 zcma)6OK%%h6uvW#UB5eSq9~XOCPtOeh_U1}pw?`9J-JRy#xw3b;#weqaU5*PsV&Dr zDu_^Z0h`g3Bx-bTt4jO>x}>7Wi!NCpA$7@yRhRsOaPBy9LqGz_*39|N`+R54J__H` zbXn_f54yefQ10)J2D>A9t3Q-?`n$tcTiya({!%k7^3@vF*7NTd;`SL$YuIj%+MBYo z+uqr1-g!qZT$k}+*zLi~wQC?2itjEJmzVSLGPd9Lsx@y~tz zzL|cG(0=DzGrcYfDR_OdP|xxRppPPyL}=V?T^>K_pUw61G*^_P^||^&0-;CX0mG@! zLzKIn|DA6B-_k*-53&$!+>!V^9(b1(%`{djd}!(#Hdb_Esig`a#;UD|5f&4}z(_{X zu%oT17I9n)CaMLLMC^v`kg6zx#oUB5O()oJYiilFsP2#s-*2$Q0f$m1LtXlSe9w2rt8#PM+v35oq~;q z8sNMv>PdxjI~0o`#Af*7r1%#60fA=72G+Uo0)z-}2|HZ;4FYB~*RqIlW=omCbz7wty1Wa{ea4s+ZGJWMu-)!1UMwOH0+ zuLsrr&heUMt{U9xSIC(TKAGtjArXUj5j6EZ%W?DoY+_TtPk8x% z52dbJrdwlDg)QD-xdO{Yx!W()d(&y}jO5%N&dFO%xFnl$_x9unaBS}iH~Z!Y#c#mA z!4JdwN{D*dUUU1?%_cWK&jC1y0SEL@q@HjK{*6!!3Y@ho)f!xb6Sm1s7wcibBNISm zZ-MK8KH`1{-W!@lutU^yH0TwFSXj4Nf}6nrZ@Q*K*y2aj%NI)o_$8BT5}e4>OW9Tnt);Aj zk&u1Rm&sWXC37`A?V~RnpIlwjhkZ9OMjuQ}eDuX+6aD}^cgiB7$?l5}lY7rO_k8?* z=bYIi?Mu3$>eaPcxl*jF)y+n2v!Sk5>*_{zvtB5wtEg8$&@G#Nn5O#t@M|M+=ZvLL zFXkJ?71iA=Zmi_DURFn5RcWnWuHa>20>zQZE2ER+KLtPPxKj`9D8MQ^vZDj z`0zkds)UdNX^JC8h(aPH_|#WYE^}OMHe)c&qzfz+>;--YV$nQ@*@53Psy3=Mtx~*I ztOz)38$==`_{8s+^-SH(SZ1&U)Z zS)DqJ93FJu#!8NQ6j@aCUFpHRbbp;}eLpYf`jS0TG%UA2EVt0xItH5M2R8}ny?x=Q+&`XiCDMiZXG|=b8rd{$ zd80ax1CU5D+qP`Y^4zTFrXmS^+LfZ_vKHz^Sz;2-4OA?OOt*J|g>CkAR`i_{Rp z?35vSKvvPKOYnNKZHJOTXUw6e#Hz*xGiVqm@C5cFbp8T3+Y>2kEkiC4ncgy zhu%Wh{`0QdoNakou4K46#fL`tP>BDRz<<##ZZy=3JM^Nun#bS9idtT8ZM@L!ToO4B z56DZE3scD5Pv2DX=_8!|bY&Zl-STJYiu&_z`p2n93JLsVCBJrKB`-ppXC4<>3Ykap z17BJqQX8@q6X>Y!GMf;QY5)Jp#4oqPfAr+=^eKSICqQHY1ixhjBU03YFN1xtCokwW zqb`p7>DGlKVq_2~H5}e4o?*MMdzQ<%`bOXnPfjzOJ=Xf|h5z!#X=5IDWXCz_(eUM9 zza3QQf(f_^@u6Tp2^6M5hZ$fn3v-Z$3|xbGFkk^pupkT9!3GCh@L&;gumsESdQ$l1 z;RY071&Xi=H=zV&cpKh<3ar68RG|j%LLD}s0h@3O-h=mH3%1)roO~2f@G-8EFRmUR F{{?EI4iEqU literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHARACTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bfa3a3f385aec611c8d01587bdf85649acd735f0 GIT binary patch literal 2526 zcmb`I&u<$=6vt=RNowbZ>x8H+RvWfeB7xNnq%Bn&gw*wB9Xnp{I{PDzDiHcS^ATAs^aN-Z(*c-?4W?!170jV4+>#NVcc{6X` z{CML{(z~eYl3HJFRBPp?RPVGKowl@GZ%VCtr&%mZ%g`=;q?(rYNm5bMlkZLS+xtAl zX1UNVmn5fCZj}lfr=_WjlG12aYw&U50+>_N@1B`HcW$yjq1ZY`d+C@n(`V05pS?KQ z|MdR05UCSFie!f)L`Z}Li1$@D5_2@$krOFhlMN-K#k@_g8-%sUuB};KcleCdt~cab zdA(fY%UNv^fe`P@ZZP2*s*^GeZ%eo>40?CFLn%Yf!qSvkjflbBC_K90b;DC<<#V!{ zR4hexG>hEdK75A|;ho`#$n*KR@+d7lTqEB-PK&uC(P5#_PjUYiXFNADXJ~zW@Q5b^H2e0Q&@#x?W5;920PPI6` z^8>lJFA?F=vqXZtHFqpGGC;_W7knd{8|B7Zz9FFz^^GyV8}q-9!(6v3`1{|f9r>@+ zAkn!foY+n!!uR#-?(vvv8Z#-r`EpV*W^~Px<0)t{X6=~R$3kK+oa}H+RU9=bTbkoq za5AcYw0(BocC?HrLXS~AdsWvI!_CSG)5_Q}CWyknM>}SW4Fp2`!suoW=2I10^Uu@X zyD!Q0P0`$j$Ygu!#ja5Hhu;vEkk43W>o zO`Urp2Se<6hT(38W13}|mTbCC)^%cm5$HV_Q;fXqxASFt-N@8|yB>lwWIgmM%M^#3Q3yD!x|XFG`>Kfv+&2Ke(dS3zZ=F9a8vr-?6OOchLR-+R zyllgU=o)YR9pd-;jokW`o#gll@jc=WJMk$SYp^#$;1eeJfUITC8r(VxbB6uW-YYs5 z;SS=*<(t6+{tcDfXYf_%QTXTW#so zE#;K7T!8njBvse&Y2t0SCV0p{wn^v`++L`{2=ThnT48mmRNx&C?lyE5{N08P_qxKO zAVR94z4V1%*r(?vAw2qT+a$=ND^Fe?T-*&V^5CGnAhOdCgU5ONisC$YMRC4;MRC6H z?s;3h*2h#!QyeJSy_dtkhI$HKV+9ImfOmrnH1C>@#>Q`W-O1^=2KQUTSKt3DYwsQR zvva;>@1FeRjJL&WKu{R3L?Mn)5iWBv78ls74 zA=-!zVjXcEaRae|xXB{ty{#c4h=HEozC*##+k73c^`JON1s6yjZr888c2|7!YG)3oVn(8z|4QkRX zou?MHsY6}5Ky!4F=IP}qA6KADv`9;|Oqb~jt)xzRX3ruC>!f~4O^IsZ!qUQGz9<$}SC&>+#B+tBxLjB*&gR8)U>84Bbwj&6rl{kQ zlhMY^u9n$ier6>nk^PfG#G)H0?#noMbOTA9!!d)+PxFcvwR(G0s3 zjEO6SC3!LbL4Fa3b77fqgxEJq!e}KUmi&&lBTSVDF(T-(Y8hiKNSq{n9%q055~Fs7s-We{P|#~`-3@ZdZlEo%*jxcU3<`Zsky(5LIE>$?9TA?x#>=>Bn@ z^TF%AgSi8k0JIB)G!e47FdN$ZhWmV1uH4N^t^!(f?YRywA>Sq)BIY`g3^^p6>q64w zknWs>q}?ICxd@Qk&U;@j2JctrE5Co8Yun3mMak_+<&Rbp^}u*w>9GxO%;WW1Q)`V0 zQ`)<9u2s_U)pYd#Isv)2LomM0`2gX4_N`L8r0VIBBvz?BrldzwnjsG-!IDm7B;G?k zya2Zw?t0h?K}l6ibxbxiGiyL8tIl3nHV!=Lm5d<$7NS0GRhxtD>>B#y5uM{Z+n>v8~28 zj=rx{`8vh}V0+Wp9W|sods*}gtObD&R!@|=n{1glKLtpjUSlFx zgu$;29x?dJQ6XPADx^%q`yqm#K$%HHPo$BZg5d_7GyeJM8>cPU)a~?#g^BDi9O^J| zm_lbp1GERM+%xd;JwFE3Gq6~m^7R6_WU#eU7;7VSmj8iN9Z@t251nMgkq>0#0B z4v@RxzrSi2a>CHFlTHx1Mx~Ev&l2syW#LcSrNd@^c}48JqI8PqX5ia9CoWuMpG~w~ z!G(g4RN3Wg?Z8*4E7#f4pw0Dh)@C~?;=H-zEhc^)a~HH43Kb@Q$|q$Rs71mFt6h5Q=wV9UM`);JeBgwIQM z+3oZB1VKQyip<+2cv_K7I|9L~}*aM}X93^27lz!YG!fE*a z{I~h$cjo(E&6<+ib}2G6ticJVv43ICU(1!960g+umCSavN6y1qT76dZJwPmzvdfyX zrmc4jcstU0bR3&?YjOnez`?idasZvJm=(ABt>e~!^`jqoJ?}%OYRkx#V2<#Of!Bh9*c*$qQt*yTStEV9O literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-INT-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-INT-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2c13d0e52214a776525444927787d607cbf1256a GIT binary patch literal 1096 zcmah|OHUI~7`@X{`heCJtEA;MfsmNd!L&fY>Vk2&rG<7{XQl$Os%^1N2HNytG)5$t z=w^%-BAJVU#KfH&mLf(L{sR3E?)eAxyG77g6Bd)1`5xzeEP&ZVolEUVUXm2CR)H8yaA z6-woT1|O4?@EZt?2Sa0HBaX13#7@x8?FoiPCqjYo5l3Tpn{gKrLK$>KUv`At$c&6l z-OZ_3QTcE*hIvVdW6r1>x(&4ODFw@h?g_HhVu{ys4|5uovr<6}LdF~27EVc`8cj&X z7PHQD8n1O{RN|8$O_;&RWc!Um(HTQ`1V;HWJ}Rla7!hQ&yKUV78vB&X=ltO;bFhk* zzRa5D-F^>ap;7uc5juQ;P}hdl#pDmZO7MMLpL->JL#UpAAp6{a7khLMy ziO^9Y<87)uMgDk-Y%QFRx0&C+^dG=_-d%7blht^u_i|!FnvPQKd_<6@V_4>IMhHbQU4_aN#H98&e=-C$0Fs*qB zOe{_6&tQ4lCCVvQA^vzvZ;*6P5Z`s;A0qyC+PY)t18S~PWe3-UL3TL}7b(jYR!{B# zjjatY8SjiO6F~KgG8R&+xKUhkTn*|?UFz&H-J!zie{k=iA*B+|VE%V*lMf0fU94aj*Gu68D?eW{rnucaMK#Lo1^xQ zN)OumJI$L{)ckv@F&K7xaJY62#C+kM)xz4^%G{d(I_TV-z-~Lw~Z>+*b(z%kc;jS>@q*Is*d^tz1RM{-4p5T?IQ^x z_N^b=^lX!s9h;pPP!sXDL6h{s%M1cui3_7>6PD38k#=txF0 z4QiHj7gNuLikd-7qNG76uF5iKEKGZ5TG+6?n!f3{Ribf8mi}o?9gQbKaUKt)M6*Th z3B=x>Hk-_vE!q@HfJ%~37x)CNB3ub20h=dI73-c|v7Nd-yP1QQr#0-lj;lK!t$9=n zrG*F0up4@S3s%fm@-K`~Jc>E|OX@G;;Kyp7$) zE`PPfvy{IUu=`!$HP_j)h1M?+GabAb@mPXc=8CxZAut!k5YqSXK%%zDB1q~xo)hRX z=)`Asp9uPYccpK+j#uMKnJ=&NT%PA*!t7_}zd_skBQWdM}nAbmgG@>_le1bRB*TN#<_?K4A9+c*qzUBeJjhvYf`mABYQ7#xIY zxr!lPxLz_SSKt(?mm0w#Wji+33APF5$}&5NFkdbb=7*?Jg#Qg}F+W0J;b7*6Yp`^( epfiq*Npt=QsHj{QGSIlqkHRTXMX~)?5o-U literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-CHAR-BIT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-CHAR-BIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5281db2d8ae26d06b4d50858b9e2698b4a655ec1 GIT binary patch literal 774 zcmah{O-~a+7=Cw4KY&6C(L{{V2?>{tL(&2P>&0<8r7hc8n4J|lHtk}Y6x#H|#2AV3 z;AxE(BH7jOAG{()4*ntk0nWAt2^>7l%ro;oAMZN@h(4z#qOHAlqv>`~tKVz)duX@S zLETorQ+3gbb zUCCsZmlr4U#5PB4|EVG7gY}2>6Fy%8<;KIA1gw=A_IF zf8cuwl?6LC6TUZ-LA_QRH{F+RGmNv>1r5Oe$IPda98EJ?ek)1(S|Yw&^f;%-*pjE9=_L7t%6<$w)jHk0eyoX@d!2 z32ZrX(~(AGTooh@!gufxw~at$PNlE4E*=30#=?F@N{S?ww?vu9^-zpDLNI=14uQ6+ z@LT_KP-3$YdoVec3-zSfx$NlW)P~bk`B?VPyy8V}JCULhN8c^S}B>x}v{N1tXH-YYxn!WP+G>Fd05mI$MqC!CsaKUClnojX9Sp)sDB_^J+-;y>4y$`CXK|k4U@IXsXT9k~-!J z3;DwQe0Hoz9P5JZzi;w|xy8c#z3kZe@sVb<0H6wI(J~5PKn#Kd-!LU}BrcXMhB;Yd zW-ti+l*)o#hl#+?B_2m!zSK`E+Q}Yle68r4lQ%P3ym9&zVCr=; zt<_Jyakc+3SbfXC0}SeKctzJH01oP(uWt?$sd5S+4RF?|P7Uft!vH-VeDH6X)aJ|O z$RREfzHG5bRv~=FG4&A@J!4WLX$cD^U7@VgVfKWxY}T7@l3npK*c{RShISM?n>m#acKd(1uE6vKhyltaqK=aT50ca_miQb>lU* z14M`j^-wr0(8MCz1?7OmiBpf1B6{G$&*?u1@9eatDo9wipP6Ugcjo;*LGfKx$EtVG z>$pxIdxyi`;Sle8eLV0E`%MS$1CKvfO^bd}ChBJ4{bI&`?xfjw8bhar*`YINHIClG z#p{^#`W+V**RH{~xV*Hmytr7%l!&d1+x}N)Vfmf+mKT=_nTzu?Dd!=Cn&=USG(tHP zL&2$^%QI>-rKIUpF-V2xgOk8dfiFtUrdHrjE#RToQ(Wg0$K~!E43LCSaL-SbYKF=* z(+Eb=mr^$P&Y#c>r3$W*b&BNFlUw-hQs8Hbi%L;Z&1zk-=@vRaOWXl7?sHpyYd_qO z9(2(!zi-Gple1G&oUG<_$T zmD&&fFkt=oWb+&2PlQg|ca05M0*TZ1{mVO1sJLnhA$ampr#XGn&UJD~jtAfSujW-P2Nb=bJ3>PIzrd1(~ zZ-3&Csx`}^#&g*YC4P1f&My7qlS*tVUJA#%;BV$C-KG{K4jk0!M?BLNvPl(US)^VL zFBgHyL=2?1Mh%r_`K@<>jzR87rb)UttiNi!gzL|3Rz zD_~+3l#{Aisp@pM!WEwI3aeMC8qVGb=dOcDS}hZcsBp=<;cH4bH_jhEhjJS_gCTBu zy(4Ade9Xx(@UJjV&L5L`yx)LsY~fBmVeX zR=5OGDHF0*(#@SnGDevi7On)o>2>k&>5y>_daifmI0O7?$8~Yn8{$0&H}+su4L#gz z^lxJ>-gdClfY=Q>EeCu1?%rX?ZFRc0aPjTpT=4ZJcugYFGt#O6c#D(5If+{jyOIEI zE$qqyGyxj|HU;PcDgq1vrhuw|EdiDQ5iF@57G}=S^a{+kU&||xp=npj(9}5;_%WDQ zFuA0tMR+Ft1OyLCO`hcGgUTg(m1i>bY)XN2@FP#}ssFlaQNk!pu&13Lb&0M)=@H!y U$3+#yw`wM%;mhcU4=*nM2DvuhU;qFB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-ELT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-ELT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e965aa7ceb445a1f30281f762d1cfbd15eed4955 GIT binary patch literal 2381 zcmb_dT}%{L6uvXd!tS!*0^3EA!k}Hj)j@Z`s92kh%K!_*49v_TG)?RZLl--+6c(+i zwP^Zd(rp!qX0EM$ZPEur?2|v0G=1%(X?$w>)}(!?X_G#*G4!0dyNacWFFwqC=bU@a zch9-!%$+6T9Zf1iGB-UtWm|JXZXrLrkQXL%bHaRXVQ$9(0(W$ zFxIV%&smwgH6fS_*8D`~^ll-3P>^Qlrfd)n8~`=mwJ*`t+1VcGkqm{gJu@cJ)v>>8 z-@f+1+V!hkC`SkxC#wj4LPEqtoXdq!%#;mN>`5uIs7ix!%vo{@KBz@Z8?x>cY7#;| zH!IrKNz2A^rsoMqh;ymn>q)CgGo`7{GPlSDor{I4lqwEEX;QCDcwdnP**TEoonl;+ z6_Z@Q>OW5iFJcNrTQekgx1T?{xuJ&hqP6r?5_0EFLTb-f)NrEh#g)IHVq03T8T+}!n+ z&D$Qk%=X$|^#oX|?M-Vp>r|V6;$*+GwwPVaKA$ANEG6l~6d=oc?zUL;%{JBE0^7QB zgKF0o+_A{27Sh}a-n5$#5u4}rerOlzV8S_*_Krkk$W1?#}Vicyjrt`laN6p(k>k$q!h%<;XXa&skslabfV9iB?rv->IS&dKJA-fW zB))eYqCy94X{9aLCBDHar1RE%Ua;)E&>@Jzyp^96rZcC7;((SBTk{&MDlHCrES7w27Xx+!qg1= z+o0{NTiq|tg#^!g%Dlk}pT8;+3{-CtYHI7ku}J;qEuC8%Uu=3sXxX;CFS?_(O^@x` zExx{IZ#;qL^0l*^;4rcrBP%g7gpn^`WCKPvW8_O1xf3JXOOY3y&z)r+j7}?=%u6>v=ZH5EQZsXDYN!1I)$poXXfT{hVH?1wmQoV)a}m^8l|n+sBRiX zkQwwa=w;ByAjP1c!2kn=!5{;bfyQ8n!7u}zfkC6^=nmX#gc*)97-cX93GKujy>8(& z0cFt+Ha>r?uO|*pEy_@@wK&o0nXv30{{R3 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-LENGTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-LENGTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bdc81e2fb6140628cf7a78c07bb091f2cd43a0d6 GIT binary patch literal 2047 zcmb7EU2GIp6uvXF{o5_LEw%i}&xjC`l|fnxlwzXO;kI46ohdW3Lh%8X-D!8)VRzk~ z7STWm55$lWZL2U>Lt>1HiBCwv17g}3U*y^Nq$WO?@MJXM!Niw(&YfMTfrPlTyXW5T zJ3sfFd*;lOrW0C5*2-rquIE(c@~mH(_2tQORj!q1t9eJB1YCYsGfaA6MAb(39PWu* ztC)P%$@xw}wr8DMA$NYa+;d1)D^=HnMSnkRdj|IR4)pcyi4Un(Ci3=7o8Eza{R4Xs z?TN44ye=fmgpfR0M$tw{l1L<62$CtATDCHj&QL{H$7m{?4}(_7Maf#!41w2QSo^9rVgPA(Ix!zc6g$`_VcgFXI^275QGwd z7V7AGGt<*E(QgJm)9{&r2Qhr&TS0d#>fV0SJGsjKB*!Sad)hDF40g?2XB&?TrtmF^ zSK;4{w=_<0sn~e#0nvH6B`Fl|F6prTYku^7{d+>@i&ylcqOb;5x7Huu&%|ba@hAtuwl&fx7_$_l+DI^4YmA6mNAuE!p{E z(oGVvCHy$poYD;aNE(|*8Bz5k8EPtnX+ZR0D^Y?=zbMO!EW4AkUv%U-C-1}DE#_)+ z4hN+tSITb5cdENNy(^dZ-8lzF8XE4BL9JGC@@~O}@q6Yx*I8{PyEVD$__NiLQ^3f- zguyl&BX7T`ZkH!>FxLyRTZ%?9Vi$L!+F-Z{Z6rZc2pBT7>1oHSS`CG9aA12!^^0Ua5~fCqCt#D?pn^>rBb>PnJ?LAy3Wwb8~DCPd_o z9xjSuAX)TS7znx`Vhh#hG$H6i3_nGcgT_jo1^jjU!YmOwRVu47rl zrqOLb41@UUTiOc_$)D^+6bq2LAjWWc4c@otdl0u*p>((xBTV8tSJ3;Sz;RT%9DXE9 zv5SBTVmS<&Ykt)&O}%pM+~zRY(bK!HZ~uXV{fGAE&g2Wu%9XdOHGg*Q f+}r2hS^xiQ!v-L*!0W*dLuB?U+ekh+v9j_n;hOfSsOEX)h1re}q@>4n+xyl@I|;hd}+^n6m1Q~Qtf zG@2Wj@!5QCK0hH?3;DT;+#CCZp2LDPGg~adqPG{+p1$W2eTNS1Zyb_L)${hBdlG#I zd;1ax_BXCyU*V$DgphHvh9XQzl=z6VY)9i3H7#*SQK_g&X&QIRj@l6}w?5tI3w4Yfgn*J;03*Nj=j0( zkk})pr4$uSdMrydnUd=(p-Y7Dty6?_zvzbbb>Vi3yE#Sff0N=*#J06^!B+_>wct;< znGlTp?v2mMRRjX?gTO<)dJeUczYdT56(egScQDzLku^P1(IcxJpqC4a#goxBJ-Vz% z-va$xLaMtwyOMvs+K%y{uNWDL@wjLqWU;VVsJ1`uTx1ptw}IMxDHP=jH{G*9{k5!K z)+6A&TzFfLq<9Y8lvmqNY(ba!-{1znRvhoxm^>eRn0y$Gz#E=A0Y9ihwxtPNlze(5 z0=2k;Y-R(Ssj<~F?lK1CY1|h(?QW`$y6|4y=tq2S$?p*_Ae7kPD^d5=4e%7VuTFwe zW4#*uk2)+DR<}H^5amL&7$tnzxn@5ZmvwDW!44CXk~XMPLmW^5(T2@9A7o)Z0PWiv zmnBP1iUzf^2DG2-_HWP}GcB6txkoK5J2Yd| zi6)d!rAWSmL90|7wvstmhK^I&(v8e<)^?P&?O|;lV8s0lOu#J#YCpoY4{DgFit6`l z8;Z{W-K1#nq$E|ODosP$h<}2)m`XYWlf|?QI2h3@tP{n%K>Ah1bS+=^u$(6bJ#mz6 zN5iK)Z3ox~YhK7tY%7rD2R8!pohMdZQ}U_1kz9nV19(D4XPv#Q^C0Wm$vU^Q?QYQb z9XmFkpPLsZbEos-T>i{LehP+k4<7l4V|QD~?YtoE6i($}a8C%uDR1T?c40S~-CAq0_Wug2$VYX!#Yj0v5 zTo>!+o?RiK{^T8U7rnQYa+9x2D664=*a~ z=?uJ<2E_+99Dw1MGnSFeYN-U4!S8&CBJ#!3Sri{T6+iJF4!O2MB9JQ96X&6ua%Vl|M_!+p zI6GL&SL1Mc_@IV_YjCde98U~aC=fE+b8*1213CO0S<1zoN=vx*3AxF$!)VvXw(=NQ OnLW?3-Ve0(^}hiFC0)V* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-NREVERSE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-NREVERSE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3ffc5f5e1b84120cad887d94d69a7f666c343b70 GIT binary patch literal 2637 zcmb7GU2GIp6uvXtZMWU-GAspQ5xO8mvSE<6i2XtBFum<=JDpi(W`PtIvE7;P zoO92dzkAM|nI`^&suol8hsTF=*+MKoIWayt5gW=EV#WMqVK5sT0(tBe)iCMtgrfHB zXltmkmaPmHvi%d;Ow69l7Bl_Fw#OP;V#;`7I0r;?Gq4SobxrwI|;#t5l@!HejIbF)XdJ|=AVyhl8+Cc09nT#OUp*85k< zbq9hjJ6Fk-fEPc?LxjM}`^o%jmGD?KsA?H zrvC^ULiY4mFRG%qMH@@S_+KTt;LNW1x0*~l(y&Ctko#uo@wjT}9Z76MIicts8a3s; zNs#DWR$Q!P)uJDId}Ul!Y&9X9)J~hwqpH{Bl~$i+(_T?{Si?5rEa(feY9ID>I8IH| zFl8fcr_y%ZR|5~!#udF!_T*NaL4!X$CqW+}tOBQFJ@)!jV5zdxFnbjn+3o06O`9gw zmrWlNaBV%T)jdc|RV>O~u^=o9cfnE+mLVys!-cYM*=mGuaH&`6p|WM0Pz03Cvo#2x za(D;BP*N$XccAnVu+`oJTGGP6gmY{y!WjPYY!yO))d7(2;UOQ@P@Q}SbYN+& zQScE6{5a-)$dy<$&(>KingVgibEKH2($@}bCEb@+v{Va=?nZ7uRc*uE!J?a3bOk&s zN}eSwJ#tlW=2YrfKMh#nPZmS?fo(+i5*Ak^b!Y@dlc`2~p{gjq#x@~*%;7_H^Pn&@ zTspGjw|Y$i>4FW%dDsJqd*0PMDN> zWJRZuHW#VnelGJ_$%93y5QBst1U@6e&&xIhnFMQV+%jZS5nds!jI6>Y7BshHW}K0s(acEE866pN zGDW-(92pxNIQ;UliR{s1N5}KS`SG^?+*oGd$Yf#HGtEuA8=IP2CWrIcqs~ad$>!T~ z{l#2n)EUBSDC1SL-JO!4I)dV*D(vN;a_Hc|izIY%u8Tv0Ly|)`haL{Rz(OzQ_+AUV z!a|B~a?3^1-VSe|Yk0ekx6cyYa9^0)mbfu;Q|r0+`&=}s!ONyQF?vV41H`TKryNNe zy?yi4ur&L#BN2FOd*1`lm3}CacYa|}OFoP4tCZQgEo@x`#|ZYW%TCm?Xcce))kyWp zpdqpW*cUAC6YeG4j|-)Zs!8FHlK*j@X-S)!ie|AOs=<-5FKyV=8$O}#p~2dTCMAZ0 zLq33ggjT?llDvm>bpJTbrwEKc*#K9SR{)lQ^jMbF lJ+yUVtUFuEr7(q>If z+RZ7-HidN%=elg;zUmMrhzLSg{KNf_3L+>B1W^?HLs4-54#Yoaeeb@htD8e?^UdeI z_kG{@>)!ib=81Q|qDGa{q3J>~Uyhb$XQpRoqT{7EO9tIb4U>|K7n)8GBKA!YvguhjplkN^lyGHA*!XEm+_yf`CN$Q=M7VM3GP!C) z%r*NmSy;6ZAOyB976Z={f?~g$*@58F#DUO~eIUG~hl+vanjT)*pa=C3sO#Z~E1vuo zG!}kwtuKz$O%B~|CrcO;^6g}(T|@#G7+#D|fMM5Yu(;hdx)zLbdqJ=lTw1sZF&4ex zrs!QhX7m5+5L@^}Q%JC{pyx2Kx8~J1_3-C}%-bjRa7q;5#Qeeo`!=k&YbK@dj^1sS*)?QfuZ*`fsLxm6#1J3#CLor3y`jgm-QbN}HRcc7jBtfDL znlZ7F`9v@Dd0R}8EhPahXk`uPQ^jrcMsvipXj&BR)v)v!^LzZv=fU0%#;9TFhNNe$ zOxB8dTHruyOx8vuS8m1_H2J-=;`b238gN1)*znz8sc}Fz(z1nY9K9-8!=T!#31kB9 zMPaY~PGX8|QtpcRVOzKfmi({{Nl^_J%D!gn5N_aBT24{Pvf}d;@e-eYTPR5O^<+ z`UrAwu*fv)uvlam!~xfjY#8#03~VDE&dO@0mqj{R&utyL+;_v|;x>J<%TzZPbD=v^f z*+w`){&3xp-`J)hFdbSk4HbuaTPDUJN=`L6ldsG~%WyfCEBR;~rH?w*O%_TwzbbEz zj*r5%pNkfz_>GOSSGQtFzdCd4;Sme+-}f!vlqh+IZ9`Bv^mCvb1~?3INN`AU7~+uP zpmIoa&^YKEG8~3E7#vKt?Kt|)a&|AeM_QoGCAE9CK4+MTrgpZqT05b8nwm3D&rXjc{)D~Wgvn8aRs*$rN#wT+V6?<}G+|E_-`{3cJ zv4e+RJUWv_BfMRCwqcD$>OYw?O@$(C)>rI!U%dV5V;RtW}o2KmA=F+ zxNnmQpqCf7C$COiOAX!reKFFPf)`gJIr&}cJ0NbHIc|qiliyxDUI;DxY=;Q^0&ss@ zK<_kwP4^zeDpWlt9rkvzj;*X?Esi72-U>;my8z9M~) zh`fxkKUf?+bTBuHqkGR!Ab89oTnkN#s+(DZx{p?Ls=|I)BZ8N8@GQtFXD)z!!rKDf zoN#IZ@^`zZ|G_=&%#mHNwm4PtFsvrG2CM)XvI({k+nbz+7hXuw(;4`^)-Tol3n278 Sm$8gQR!eogg?g_oFaHI0)(@)y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-SUBSEQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-SUBSEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3673a2249075998dec6491321b2876e1bb05d35 GIT binary patch literal 2601 zcmb_dO>7%Q6rNrGhAd zDyUUdDC)rl+=ONaR8>NpIG~UdZBc{Z+9OCHA#vn{RH+gdgu;8Xaa#%!7yL8dyl>vT znR)ZxnCqr4yB^RI4mjr(Nj;@Y36=VbZf%Ma>_0G1F;1 zFfv_rOLccfvKQUjOzF(CQs$7PEL6)rbVf!%%p4vbI6O3TpmSWYw9wjr&KWp7c2eW{rc6*Gwr^QM>q5}z$_&XF z*>a9p^eDM{rTsi1;wjw84e#cpaDAR!|9Vnp>v;q}<|n#Z%nO_m z{pdYrKWCz?IoD8}+mZm5yzqPTBq2TL+meEJ{gw{>JI(wh{X0UM-h29_D1c^j?a`NZ z;cWc36S9qvjq-FqciGlPh2L8nZ9}D7v&WMg-tnFdBk9j|PZ(l!a^cX#UFUWo`CuWhD z^QT}Yv^a6yfwhzOr;KsYFM!6ZU*HbBhWKRQo*v*o-5 zIK#&Ve&FR>x*vlLflrL2i2K>Kp(EU0HF((GUh@9?_AYyCJOAzanqIP;Bw`}?sF6ym zhCY_Vu$8llKBiGqK9U1QpRm$m8|x5b@Q*@X>`1GMt!8DD+Kvfvt@6Z(TT_-z3!?B( z4ckbwu1FW_h+r;kPgB!0OxbYkqGP8coiJfrTG6Lu&Rb~)NwH(_;oRzq5W=FEQT>=9 zC9o79H_U=!qxc%Gsye1g^#?MR2{=}OvEKWKQx%JbOR+8-?nX;t`k~kkVrN0gQyKEn zp}IY*dREDnbYw$_1 zEP^BVs3uixDnArQS`J*GXcp^2HMoT{(pT?}!dv>)==ISXqfKwAd^6w7zcUJt z%6hNTk}oKcW_ih5>z@SG6$P409+bTt7B~-|g7rQmvqyf|TvbNF{*le32VVkDD1V#{ zokodxeiJ^tIKW*8jVNSpCTO&UNe#WYWrKS%7`IOvMJ#cO25M9v%d}O1ja%S8HOq5O zqxyuMJq{JITg_56&*NDhS8`erG~13*)i%sxo>7UZ-Ee2y6?4MD9BS1R(E*lkfu#n) zObm0XC`>_6fdSDl*)4)9m_d| z@a`>0dyS>0f{PItifOPRxNTNsM=dCq!HT%=tx5FDiYSQCM555d;?Q*Mgl6AcY8c_s zal;r0;|6+zEHx4=$H8C(q6`sfLdi{1>$4Okr9uhUEn`|2Iu46kDBAeaW=Xlng*-da$WVY*B&w9r@ z&g^bdlQv32i&`|KI4;rLLVf`1pGpWf2t*#W1*j60+8;;}NC*W9{vZ&dQjqw8N;v0^ z9o#e!RbYGWd41>HbMKrx=X#m(ejz3aF>_(DVrZ6NHXDo0hEO&wp>8&rG?qR1RD$dS>|kx1lVTOz7T zZnTH`gpPzKj)cMo+wNYu%=VZJ!<3kHB&`h7!|;rA$?gf{MKvExq$M#ZM<>OAv+US@ zSWB>=ii%@z3keN#F=%L~H3OHkP-j?%alT>u69qYzPv>N3g+0%9IIr2AX*oCrON%B& zhVySk!RV}G_l!h>p-vohd#%QN?`DQO(Lb<__0BO2 z8vfJM=67xHUmds)*|A|buipSm?}e5gR=>6;1OMT2_UrP`8D?4ks+{52PT*E|oY=WJ z1w;hj^-5`g?$Aa`?8;_JEeKrOGMmB6UEh71`Pvp0LJW`Gb=3l;@rw;h`+wmP97Avj zhAJYFnMV!Z=Kc5v7(M{^fl0@C=wNu|uJgM4`+r$4_uA%q{V);E1N*c_*X7?yH%8V6 z22g(g0c(d1q*!^=34!>4kLz?bZ+MMPqub~+b{Ru$K5#I2!)LS_9iSXEwzst~%uMe( zOfKhoVLxX2)&bv|>w}Q+2jV>w1_l+b{^4uCq_6fr=w&bKJ(V6T*KgW`0jSS-8f!Y3 zipp_GRD#FSpplbmfNLSGoEIJs9GYzbDC1ZvsEGN30!1IAr^csFt9fyfV?T+==K`di zZzruh9+a+ts3OjxvOVC(z$;$l%%bf+TiX#PA#5}ztWr70B0L2Tc0R8e;T zA#qU>^CF6mlO0HQlYS)I(0E*o<#P&%>_5p)B)_5<_5+GxzvGhUNiW)#$RkK9qz}m; z_;*f5vtlr+DA8$DwUJ#wn18tBuK;MJ04c5FYMDQPrk!fkyaF!>bvBL7yhkj4(ti) z$7WqJLWWV<53xJoQz`|ga%nj)((UL4Wp`SJx{69c*uhD7K?rUopF!fGuFT)4#Qf1E zzjev4X*$f$T*wc|kVyvT$nKM5ca#k8AVY^B0B1S&7aLl=A(YHo33^Bk9w8_+bWO0d zdedkKv!+%TYGy;I>qScwinS%7-msdbMiZnnm4;4LW|{gFt-0ocRs*nhs;SjVS{)~; zIreZKC)sl@x<@D%p_$DJm73d!PzQCEa&(7C5PH@)7dfvsTwDH4Uo;Yw`?~rzIGsS*^p>2pG6nKs|1vipGKoWmYuK z6qoAoZmSx+KtZp}=@@vgv(gQ@`_+Q1rqZ%_@3Ml|3@~sxnS2iE!jH2+?WqggyTiX1cH>*1I z*mYgo%l%~jntnZXL%*55lwFu?Y_t=~)b~4CH?ex^3ziy z*780D%fxO~q1lOYOjNP`F_*!_ixTZCuLAFrL^+vHq3J8+3Bp6G$TT=rJ!p=;-0+pLvn&Rh^X}7G*LMr&a5VtEo&fL3xjqjk_i9 z7b8k8RS-|Om`ps8%4S_Yn@Po07th6A%1YG4Cz5VVF5_bPO(36&kCqK7YhPm?!drBq{C=C-mxFn;Z4Mo;}dT7Fn!R? zQH{nE6XTTkCKIV}$Yrw`sW3`ee=3p8W-_S}Dz(F!z&VwPgk7^In;DI4`XrKWeBUuS zHhCPPO3q3rX_C|A40(<$kuQ_8 zStO^3Me3vh-^x8@(>w(KRGA|h7$CD}pE)x;upciZ<_+BNi+At-3vJV7I{*Lx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-EVERY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-EVERY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2bb6ef004ad88c8894bf742493a12f1ed75a831a GIT binary patch literal 8899 zcmeI2dvIGa z9L@zssXg%KNGcuOzbzc;x#l{%I-~RqPv(ZEb0dN5-rUs4(7sIpyE72pGg&ASbaYVF z-rO46+|qJQ_117EA*206o6zRwPPRFF=%8LVp=sK%b{s{OrqyYtR=%%P*O-lFvcawK zL^PNT_eLAbGv!hx%_Z2MiKfe?`cPncVo$J`dt5NTjx~7%iTdLgJpNwSVsbqOp zzf-R%zo)b?o(%TU)WWf-W>mVPV067)T4=WfL&4}x(e$8p=wS6-npW}daZOvZlfyZh zf3inEGOqiM^%y$>E9!OsZ5$&)#V22*X@xUS?3>@}^9z$P9c=*yC zYrSY_P#WQQVR-$#DW3MGSed`^wI~P=p)L z>&{bue#P8B9LoHig^L-Tb*~p)&D@1fe(uX39-h}g0dALu-9@u#6)TGM#dY+#syI~a zE#5r#muk8{h~b96r}wg}S2%Mqr{Q1aO#|D_rxhjLHEAM^uV|vFEPX}O#a>qbF)tq6 zUETYK=TmO~%@^#TaF<`OAcz#e|d9}@BMYZUo$mxex-F+gp zdRl7vw=Mo(yFdXgz0mV%CSO;m(~L#s1ErOXkyNrfj>md%TR7RBh^B*GacW7%GL1&9 zQ)N`sr-nWY=u<_XO8WTeV^J8uTDjiJqXZ!lIjpkx9sA&u*2ZP+6X>=%&sPA}XK2m3Dn&U$jvK48? zT{Mz^YbxCv&Z7EOc#ZU@)6t}oig!8TB{UD#C@sm z?mn{i{n`nj_#w5`BvL!*F!MFeeP44fN8j6d5Z`{b_KiysA%n_zHw7Ng;!5|ech*v2 zzR1ev3#?^6%Z2_tDO*W8MiElc53!1Vzx3VBh4yuB)Q(E+aVg$M>r_MU9f@FHDxQ?Z z(`I>fwEv_r_24K;Um~8#Hly0O3UVVk(SAXq;?3n!&2(;RIzX=`llua#XuG3aT9ZZF z+P8$)21bYIoogge7?;;2w7umDsM+O`FP9s-4IC`b`h2Etfv+r={8RMOHO@V2No#bd zSVYfi>bavZKAoFHZ3Xo9j*Ure=|OGDmM}fZyG|YGicooHex|D~U#FEzmlcP`ZXFpy z2mJ1N0fB&rV|j&DF{d_C@4y7LOpcClvcI>BUMFcPUGc1QC1&T{M*YuG zuv3N6aZK-7(l^~Hot!tN6UvmHnm46m^QLs<)t=HLkNl$eUSz(&zibH4_*`3A=PxhpPB~hhq39ic;4&bb6+RmivTpv>dvGy zDNd;H8U6|fhsye_TKV)r&Ds)P`A?i7!#zWWcYf%~!%49o{o4`Jot+~@9DgUGht!DP z|F1_h<3@zVp*1sQ&9G#>6cDx0(s%(~V1e#c!@1{Q4`=H94Ii1m;UTQ!8+gNg&zDQf zrs)>AyO?u}Vqto^NH^OdY@hF2<9EaA z7H{4oyc>MC@PB~cCR_mT7tVwC3FA>=?iC&d-!7a3j|q=}3&O+TobavSA>kqLEy8aA z(+vT!?E=&N0Q`C|-3-9DfO~~s2aXHh42}x#1c!z395-(e9sqX=?*O+7-vqXW`@unB zKtMS{MnHStZ;9wuEm4W3u!UCpKOd z-Uj}&a18uMVY~nszZXU-Yy3_axufx0VPq-BZ-l$R|0Ns-pBCN%eqQ*s;2#OU2K;?t zWNF4T!qP%s zCHQt>BwEIp@Op4TcpW$=jHJ>S62|?(xJ5Vs9u!6zZ1f8wb2hdMBbhdOg^`IHabcv@ zMpSqOI4q2}7~=+Eyh$0I!gxzFT7~iAX4t}bmotLG4dAPVF9Ba6ycm4Ba6NdHa24*9Ds=u{7+d~g|e>Bk>YPFr) zJ#JCBS>cevw!%$wYVsxZ3-)XZN;yx__YlWyG1-edwu1}!r z66ksax(cevw!%$wYVsxZ3-)X z?G~k7@oOu7ZN;zc`o&aSw?Nk`&~*xQeF9yVK-VMCbqI9*0pSkkZi+HMoK}5?<;Ph* z?H#+;7SWpUwC>~nPq6&Dr`6(W?WSauduCZa&hmt()l6FFxK+lz&9k_lbwA1S8=h83 zu?V>ql+{+S)&Z8EV);$a!d5J7vN+e?rf|FX-sSl|$YXq(<+nVGCS{~1*Z0ldD!h+% z53@Y!TG*XrfrZ@Rja%ma&#?Tqr`0hxuHE5|oAJhVSoaB*-|;Nk-EmXixDRmuXIY-| zwAz$$+uU(`Jc|ce_j4?t@hq^n=h(G~d6B%IbwAJYyPlS}&k;}S5chw9<@Y=->@(Kk zwVu`oxc`eRpY^n`x6r!Ii}8cp|0R~+_q3G#w6UMCX!k50V%;Mwf8bdt`(}Il*6c;{ zFzbGq$J!?B|Y0Ssr8gV^_)D z9Js^Yc&&6%V*GX9gg(qhUt#$ZSIONan6|nLKrh*HWIw{1$65Z=)%W)3GEeEF-2GLS z&$~+A7G3HoJ;vQnvHY2<9%FF}5Lg zWo&(HZ7dL59a|Y&5nC2p8f%Cxj@89#w??}oUEwY2@6_ggy9T1KyGFL*7uo;lRh|B7 zU^#u`R}o31GW}^u(3Y1=#sGa8XAFcOnju;sS|QpX+95h1I?E+%rTtLjch_9tNnztCGFmFNqZATlN+6!Cfq|fJd!I? zF?8!NCA&tIMrp25Sw#u1QBg^$EqygYNv&b|X|)WWMTx9o`Y44p47|JUDkD^tS$FPv`-P(MX>?`&Xw!zwiJ6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-MAP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-MAP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..61fe26029fd9a5444b3aaf1b28d9668c2177fd0a GIT binary patch literal 4261 zcmd59ZERat_1@>$ah%w7GB>DS>7#6bOkapU5+|+L`s}LX3GV_$VnW*we$Y<*V5LxLXh@(=Xo5=oLhu8SK!OP*B*waO&V5en z(n@qtBrM;1?mg$8k9*EN=iawLtg{hSjFcBD#Zs;+mY3?4rMj3eSH)U+shY`&dBBU$ zM&b$O`AIo4J$TUPNVZWj)m*xs%Zl1ku9i)&>=%7wqFkvKOE4H6g{kkru>U|XIOv#= zld380-|_&%&;h@1&~fYHCUutyAsKQFK^GxzVj;$P-R;$sq$W*FsfrYnql(wqFmyZY zMM@==grWEP#d^6Sm2%JIO1Pbc8li+3=XCo-Di+bE;xVI18??tbt2?J+(hO`(eo`TV zy(I;uQyBY#l3$9-GvwlC&ly52Z!Z$E_ZT}0mxPI!@Q-~VI`yhx=uXRcP-vma^C#wYyC)yyFd@x z(0B3|Kspn5tzP=g^@nKRyIb}-TgI3+{%3t*=k4E?TM#;IEq6aWyM@nh+1*_{eA7d& zfx#GkROcawJ;Gi3!MQkph<+3PyrsVfG@IVKpGt_{!`rkayQS0t8r#)vjsFLpw)}2O zsjG1ReV#8|^0bj4w>Aom;sb6QnEUUSL>mQn(M<%G@nwCtHxiGHPhnkS)ma1dLyzHnUoTWmP$Y&iSSBfOU@-VB`VN+S7>oB z>$YrTT^2VKAD352B;pAvp3-Jgn%B|`3_V^sHYag>(#xO<^@jenm~FEV!aA^o4PjM! z6C~Lt;)$rN;q(pE8c8J*O02C!GK#dzK=a($Y(!2frYhEr7a zu1Z@~6Y+Jn9YL1$BM7rT1W&L>5PXt(5LoyU;Vn)Re#&XW6;2bHXsmK1C99}K(9NaK zacRP=$&oTS6q92IUqXM$Y4irC(Kk7bGLv?iv(r;1sG6W;g1iZyHo-9yXeNl6VA2Gl zsbP<)!NE0<8)&aQGo!@D!CrEeDs~?p@9REOsSfbgd?RYUbgcitbaec>J<=V<-x|;MYy7DF^r^&({;8R!E>;NN;pcx zs6(Af@;E=rb|G$;xu}N&;g4(pkivI3O?bsbe#HbUz-{}qtfrJCu6c$}m53Hk;PimW z;xpIoe{VYsu$y7M09Kq>Pm8*Jb>+cn2_A7;CQC^o4j zAWkCNvxg0gz(UIp4Sk}XtJTGYbVZcJVqUBla$+l{xJz+4T@!1ST&9>W!h5J*7LVt| z#bRkc=cwlDOV!01B2d~DL*J{Rw0)=LePTWhZ>+3XTr{6Yh&%llE<0m1JE&mkz;PKK zBlFpOEt}8QaDLLzt=U|DejX?DFi9WJWOFz8|Ze=~IV$zpEdMCN#HW%+ZXfw9~&;{O7xGx-z6 z<)xMC$2W;AVO7?58(CFCEoe|P3o8-~SpYWSFJBbe@xKQEx zJ_PSi8Cn?H14Ij+c1+`+`{Or*VR zKMxxH^*wH*Z@0V65BAcxxZCL0jb;}dWAlgj3xH^V-i|eA=c=I#iz~(jp?h|{)>y}c zqUV5)sREXr*9AFz`%?oy5&%WVS=ne>ogO#{YhCsi<-Py-y#-F3rM9%l2COJThd`T2 zNo80JJYmj51qa^Z)-`(O7W`h6Mfgb3t@)+J#g*>$8m4unQpy>+tz1nn&ga&;oG4D- zBrZ8z5)Qc{*Efpp!he$ya9;7`(U0Hj!X51{^x>lI+=b+4uw97Ky3fXz5&ApXDTDz# zZY_dav#bZZSQX*06OjtzsqtN->1WIA6a#7GORUP_x&MC*n)_|A-3E#3{6HOYzG~=x zo;x3?L(Z4(j>-xMx?P_okq?%-wyBvKQ6VBpJHMD%#4w(iBLBRVQ5V0mgSSQSvJRY7?Qh=Ns7(K?PgjDz*}J->U}le8iZF#coO z{hiM_=l46m-+A17e|M7!&Ds=-`9i~kJ97EVh;Mj&Y{&SRZ(w-DH#$5%(wFfKP`mH_ zp+qvgdtETpx$=CwJf-yXjbwVqGX1{vcxJS}ch?G^-R=wS7|G=c+S;gUuWAmgYHC_p zzBZVO@o4|ih71~3H8rj*KfZ6TUOlX7TAy|ZMVY2mYo=DbsZd>?4yV%owb5AE9}jkg z>x&b`LMhF~-;)X_i-nqiZ)|vnKcBfWlgD%hM>Sp3iZ>QY*Y?Ci>1ZNeoYb$;D~q2f zoDq%tyJ>2{NLVvU-BB>QUMy7DP5yvCo=6Ado3(v=%Rj7XCASP|+Syw~JO{H6bm|9& zbkBpG#zx=V8r{211c_Mj$yRDw?%3VCrnbu7)0Nrs3SqM5^d{w&=slNvOW8}_q-vHv zc?12z=QUaUdw?2eez;_oo;|R&>QJJJs>dc`pGZ_aq-hh`>l0O-hJFU&{w!_=22bX?FeVwb~&p0!(VP^|gkyeJ9KExfIp+_l*{!v7ZRB?ypG?&5KPyq2sLIZzt3tGH ze}WYDzdYr@k#?=Tl4{*6srF4@NuDR=fveyHm(AvlTrO|r@@3_8@sVc=Zno^p($8G{ zPVe|h=(1@|w6b;6nmD4jZ(+TU$#`(Pb#Exr zCqECGPuoGU%{y(!+Z|!a{W8KCGA^~G7}cu#$l0d0Nmf+z9*Uj*)4IcgCetLf)bih3 z{8zK2;b)!hku{O6&Q)v1jN+cc{Q6KLz9x!Cy?JrspWtrlvU_WF~8oY3!kqylWH5 zu3#F~o8UFnlT3!=O6KF}=)0EsYEMo$6ikKLl~aN4G)Cey2Gwq)Jzc@hus@hg1~;SW zLTFqR4y6-GR2MmQC>A=iP*gZ)QQUS`?$C|5X&#RX3 z9Q`TU@R(iPxPtALvE3YDXCB2G2fMq&@ii2M`5iGE{dr-b9~2h)*M)_CtFX|o z7Ao3HqECBK^l3j9ecETaZ=cvA?PJ2dcD*xuw^K)vZFTBeoY^a!Iv+{$R&pgdx5Vi~ zZIDu7IuLZUVyIr`%tz5hI%T1C!DKL$4vTZJp7dr!<8&DXWBza~+(l;(n)93mC}ukg zsqo(D%tLX#7{z-v7njgr#swFmBjlWoqFxl%ABDDcRH#``ad8wz*S??@H zQN_xZ&@%rf3jJ9G5U1-ZL@N3|p`w41`>qp(_ONKw4sz{wEF@JX=8t1jt zCdFcDAE7aIKf>_DqN#Kvs`U#Xmy;9i*Ca|lUM!T4Wk$z*L&IaeL%V#bWX6G?p1b%@4it!9lJq+pE>B4$_mmU83j-*=o{&?i9Va@v&E>O$y({n-QjMN$PCBQqz>0JMd$+}z$&t|bPl~_ zO6cav(7ngi(7pdqL-+puoe14&H=R`+uJ`wt9B!;VT^;n&NmJ>Frk(RJJ9%IA{)U1b z%?%9E^t>;VzUdKD@;9HwOI`U3W>HgxUi<1UDOcsWc;b1!KpY}|N zMd>gHV=1QsYBbReJ&AN!Tms%NO*^zrnDgfyoNDhC#YxNBvb5GjWuQ1&vUSVy+Qp@K zIC(FpYX6oC0!wuR)eTTB+cHO}c0qMxN~%Vus7BG z6g%$uZLzRmjP8Ql>H98O=5u3XR2?1b9r2w*x}K-sjMBkV9D8n`=Gewyx3c4=Q`MIg z3qJMs@AqAm8_W9aK!a~IvvWK%)R)1T@|+_^Fb~tJA`3Jh)>(l9n53k+n6z~`2}V?4$NDacY^mZ?*Kc@!{9y4xXGCl%!A+?nDLM?Kgzrvd>!)@ z;A@$4;N8qw@GfRN3(Rrm0q{=d40w>aADm?;8*O(*VzcS;c z#P~Bal568tW@NL*E6hlgjHApQ;9oKa!7nhc20zREUhtF5?*Tu~jJ(nKA@c>`!_4P{ zA7Nev{x)+v_(A42@B!vl@O{iJ;JcWSQ5knI<3VNI#@q=00yAz8#x2aaVvT*w4Pb}) z-QYdUE5Q@Ye((*;rFRMq+OCFe8^YHZUW-H@cYdZeT>2k?0#?=DFY?Gv2F=3z_k9 zXS6fp#nEVH#=E3pGuMIr%(dWU%x8j^FwX>^!(0Piz+4TU!#o3A$6N)jVa8YWhI{@i z!DZZzjDz0r#hE_?tTUGp>#sAHf?s1U0socR3;r`RQfmEGW)JukW@Ih;QD&qw`il-p z?H=Gmr`+lFdy9oC^-k}@+0yrm`?~(2;$$af8QyTLE6{8^Ba)jGZd5p+u&r>zNw(V+ zZd15b;TDAzzqaDnR{YwEUt95OyM8T--*pRgy#igQK-VYGbqRDm0$qnd*B?-E7ibPB zOQdk4!U2VCg&R(?-L7z(!mSFoD6IIko0N9NudVpC6~DIY7gKTF0$r~_*D28T33Oco zU5`N5A<*>)RNMuc8{Mt=QyW-bY{Mw3N+x3g7 zxNd>2SD@<@==ub@E`hE`pz9Fm`UAopt~(^`xLoxw3VBG#XXItq+{9YLQtL~i|64*n zE47+jt?iTzi=JDB{I-xklUj|Wb%L9D+-=h0Hlh0+A)k|40mUNVT2NYDBDB6NL} zFD-1v!X}Fo?JWwovhS_Z_gBOi4-5H%v}jO9YH)pDELY)nq5FuCKX)zccCx@iZj|HR zA^N{7%hwj(exj{hpA&kQS}(xCuG#S4ID$LjF=}wJ77ZxZ`$8i~U0P zu#hiF3+(L)b}b?@lDmZN_l0~}YRP>LNv*p@{||)xmDIvMV;$(tkx$k=qW_4HN2M0_ z7Fy@a81EJRKNRxUQcKxS8~X{1R%vmc(EX8+zmXQozS(l$8f7H+3*8?J`CGEUg&?=> z-SoaDI=&|4V?w?Hhs&k;*G1doLjKM*m%DRbandU~4hZ=ZA%E{Gxtjxb*c;hOhZ5s2 zmJ|AhF#4&Ge{hxDU4m(|y8vg)cn%89Cxm>})t7rTPbxhix}OyCkFJv3qO+vZgQEK> zA^+qm$sIaVDt%LQKP}`jR|y-0Ih?UqORYPsMH(V2BP$~Hk)@G$Mb3>ZiufW6Bl9D3 zBeNs3BDIm3k?Kg*+VGlCM{qU&ickEWZx`H~RC2IrOb#Nhp>`^&~k% zn^P?fUpe++d#7(b?A5a`0_&g-6@%n_FS>hsAfWbUv$7Xmd*GwL;b$t z0blQlS6^Rl)JK1I(wEKjuRtoRJuT8D?S^7OyPCqu42+Bs?jY>z&*Z7-y}XaoU878+ zMAs-SqZHRDDW&9=zMP@7*08*^T!zP@RMs#(l*AeaUf&Gepo47crbUO+G(6stsZopc o&P%^`s17B%y6G=b*7)7U*Qv4WlJ0bJT~E9-a5KedY&(AZUr@I6dH?_b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTEVERY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTEVERY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2345bddc9b669ff25014d3b6d27acf17a2786eb2 GIT binary patch literal 8827 zcmeI2dvH|s702&mck?797>FQ`%S$n`n7et9pjI}UWwT_n8+SKCP)cL6VYlRg$wo^Z zEOF}i=vs}b>AhH5ZMACE7T;1IXsx#RXlvCXT5YwXqklM~(_uPHrSyD%=U%uWSeX(2 zE5kj%&+qp;=XcKUaqm5MVN`Oj4MeoSK;Py}Z)#8*7|w1U&T2gagWAx*@L*R;>!Eh- zia;zL+}i99v@APEFHAUkx&~97*;Kcd98L{&cWzm#=?$8H^I)czpuV1}`iffLikg~b zg{%CD2#@xqHe{f$@afA65A7J2O9v!L>XLS&D3GL5NtKM7bETEZU?S;V6^;bGQGaW& z(ik;z`7{@Adm&S zaMasIQ}c&{l9F$Yg3)CoSE$!`ecos+8N4tU?~rzk7hWYvdHMa4G;f`V=!x``E%L5@ zS$e8PS)%BKPVc;IVyoSItTJ6#BuoOwHYs$A-o@OT&t7^}s;24c zRnSj9N7LIfPg29QtMX>Z>0KL2cE?Jn`srxo##qU7=)Wdb(xS*y2zOSjSzt#(1CsUb zOxL0b)7xiHFF(EdV7as#3jmXHX?3|`+n&s_a27?idXHGsmrvZpTnp@p70~L?@xmO^ zvrgtr{y#Ra@`+xDLK=|nv}G7~6P@?;hH^Udy#t5FV&yw4V&$=t^ej5ANL*N`hk6rijEv4++6A0gu3(Sel?G7-S${K!9(WL2kR#^(4w3^ zp@B3oQ|q*gAh%_x( zZF}SgblovKDA?J@?7-voL`Il5$BuBS9hbAjL!DxYINQLzE{cx-Zi0^Wa#;99dbIvL z)N#j7do$x$Z->!zX{J*Gc(WWrosorLPv?&sddmF>l5)CCPl@hZ+DWt2I zt|Gb$=*p+dLzkOgCwq_nH-` zy~4Gpxwb=$=iV;Hb6?NnZD5rM7Y$rYWzAxt>H1t~x?Z7;EnRF+#G9baj0DMx>jg2q z>q+xe)E?p5yx`}tXOJJ*USnp^?2SPMYlLtsJ%|vq$i3)6G8QPb2f@cNv9yt z?2r2c$soq_JVbg^!%@0H{1I<35^SYYh4xWuFQx=G;%$qCqn7gb%{l1%o;erAeDgFE zr}EGRqHupg9+a=0M;-3hO%25pTzp4pyDww4jiPXUCK_EIacv(L&(RRBSW{CQS-T!I z=cBlt+KMBwHFWoiLoNDlG8dpP$%C}8^|@RuBZK^K6U`=^#JP6OH5XE$zAuzjcBQ^3 zl;t-_*&U_(CO|5(DOBW}xNk%h(leq_dW>s#bMZrS9vMhuVm+kq(kQaGhombKP9&>Q zt(*gS7PR(~@a#8oQ?sd|tkyq}rR;xji&l%~&y3u>B$^jo>0hArbkb){x0dPWFA}s} zxfp8q8#z}h)wvOTk1^(Qsj?eCky4n%$2*P!7xLc1q+$|>~T(dznS6CtTVM26+McZ2&>C245 zZwx2R(=nsNPs9vOV<^+pk13@{U$v&udEC=jf3l|$GHx}-6ngm24a9@~WYBxmJ0KFK zJJ=sdm_<;d$z9M+Uyb5Od+H}0$r{YG#;l~m{cmH;?OwN}Tt($y##r8lb!U|?%*X4* z{ZFcPuRGVbL{?CJAF2iGW(w7Jp}HnvtG+c+b&pV8!m7^;)wAYWqdq%P^-eK0^CAk| zyjVo+9-kC(HT>Vq5tF9d7*l11UZ5&Y9o1xyhnm)wbz!^5@ZOgFhrh}3HI2qG*&H^9 z*$)*i#gk_aW8gK;N@84cuk_D8jyp!N?ij_sTjrL&&Tzb6J)DZkdrm)n9QEMzVJTf=&s}?rYl~&o zomaN7?2OLVi>^9!=+Hsxc0E41{Xb~G%gCLYrKjYk-jr4JX0q8{dIEP2qMuIK9IHdK zOV-e!qKS9XwU=zZyPB<&m!a6DRvXL6r46Mn9ZvOkrG{uYb-!?=?x4LwKB$iJrs2`0-oV@kzK*#Ud^PhX zFg>Ml>b?oy%A5gjVNQdsgMinGdMUT}fay^R+Y~s%+zn1KcY!;ZF9EM-?gV!*e*@gk zya9Xx^Vh+x%8vBpHDEfp;0wWC=63Lz%*ce) z#moutd}d@$>Kx_^z%!YVm8jF1W8gC8D7cWh6S5~fLUJAaN89ACV!i+bcvX%Kv@D}DJ;9=%7z?U+g4(?+{ zqNZe+7lBjE3&EYtNL!Wl%y^V29n2cIof(;>ase~aZKaiY4miw=oL&hsBNtcv%(KAf zG0y}yFypI8sb$7jnW8h}Q%~_SPY0jLTn=8$d0G0_cP~#KV$ZQKVe2fEPu@G0)N1atVDi~ z8R?4rwn8O9nJe!!a-|cWxf)KFe4lv2%2ya;EtExgf{|8Vt!`#*u5oa+gMALx z9b9#U^#%vmJ9xQ+>m2Oxt2_Ma4!^p?ukP@xTYlXXzvUKac?DWdftF98P( zmOr4wov+sCSRw~kJJ{!7-N98ySZ{D}y@QuKxX!^2zj}?M-Qibv_|+YLb;~cNVz~uc zUV)ZVpyd;2xdd7sftEv{NfY-?4M)?u#YaVZIAi(7^6!$Q7dYxx`& zKFeYQeZ>f^9|`%0kbkf(bccmb7KhvG9K4);<9kL}?-24)A^&JwR5?bfvV7xvMQHt4 z$j5~IlVzbdkOdYpVUPP0(f_!Rui9GmN5<9bt#M=axVH)2T|)lZwpebB+hUJ$FblfB4Z-jgs4$rX7e<9kQ6Y{T?xxG6JjWLhtxL3&E z3i*zuWNi-IVQ=hKI+PfHo;{)agwgXtzH2F2y9Co(YXMHPADr}`+ zitgVD`FBgn-l9`%rC*8e-wXMkrDX5WR9k7M=-wmb`<4RP=@NU|X&Ba&oA zlFUew9Z51INtPtZl%%lr30t4A^$A;_u=NRBU#%QAXY!8|(ub3BA!)CXYnqq~d9`ql zmQAO$RDZWN(4%!8{tVSJLmK_Bi>`F4d#Tn>|ID!pA7=B);9Wo8BJbmH)LuoxVSADZ*Gsa__kAw JO2?r?{{=YL#!LVJ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-REDUCE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-REDUCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..296f84e8eb4ebd943809543aff85d51155a301bf GIT binary patch literal 5112 zcmb_feQaA-6@OoL94Bd#tshC&b+26m!NpmVrXOopQP+7%oH~A~pPe*iWw?nOyM3|K z#3|j%wo-NTn7ouUS^I8Tnb=?&gFi}&5bH*}iHc2#p@BM>I<%p|#88J;fdmLx%{lkj zv6ECQe^l}Fxxe4}zW2U+oe9CV!|PYQ$)Vx6868oRW2xb>l)5K5qK+oVM*5@b9^lnO zUOlKi*x~VRYuwc2G>SC+Bhg4II-rKeqN4+m`#-NX-K~0tN8%<7Hf#Xcv~g|o#+H^w zXPd|HQ?wiUfCIR#YjkE$pAf5(f*|w@7f_T6LX{v3*6~c0E2J4Acbm_zxdWaq&1Fqk z83**@4jWp~%2YS2spPQRj2?)Z*v`Uj zJnfnwIdV}jx@cv}np)h=?x5Bh_G-fE6V4-oVEYeNaxV5#r}$z*y!Yi!sdrgjwP+jU z<)N-Z5X_3~Gd~nA&*Fyuh1|sg2cvkoAPikY{srP=;Jg>HRj|W&GIB>|aR9DPo3kj) z{>$l}0tX{ZLHs?lcmOjRb(SU$2tH1G&hc<;?%zwGzU4^CLNWH@`2dWsPHcN3@H0V} zh&>wUltd_a;>?m>71QG5;HfUe`&aN)%*~xto}arC2mworrr=7&b`fVPpuh=GveO$1 zW-!_Zk11i1Ft|EhJ4Qkp`OT^K<$S#k$`u1)%8&?FXF69ea@fGk)UGMm&f;_R z&auzl#CqlR`FcxpHNZUX%}y^Xpnch=3ScjvteY}bN<}_(1vcHk^a7>nT{^SAxO}j* zy-PvP-EhbC`xZZ<%aek}# z;*LX6`DU@7c>dkWP7fEUOc?-1E~xdnYSWJXdAnSr+3EW0+VNPqIm>OW!?ByP!uG2C zbd>KsAG@#aLckozPU>}MZq@4ou{x*=xqX+;pZTz8N}x!y3BNWKI>a|1KR0F@D!0Se z(7D1|w-#G00+5i8!gsu2p<<(aE1AupFfj_mfh$xLRyz3&bJ8ZE>Or?24t0k^F1Z?P%Uzy8pPTcBi@`Nky?*X(xIhsErr;g;MZD8KhDi1{ zJ=o<5A^Zp{@rHvzEl_mFG7)v}fNo)70=ynWqg1R6)h}Qqx-bzw&T3GM0b6PGb#2xC z?)(Lee2mlvt3}jCXdR)I7|GM!tp!>^sr-#CLh&(MjN(1E1jQNdp)l^DWC-miG(adw zNF%hKPy?Ym3Dsey9?culgAi2yBhMuNfoGE6*3mggOarCbWT2 z6$NwhVA3Z%nDiDmk$%lhq}K^uBy^6@j|n}=-KFE?euUh^WJ38Q$|p6GLp|y02vriY zb0mJigNg6+VB&9hF!4EVBAz0XaY7Fg8X=Tqx52!Kdx_jdWDlXW6tkIPuHZ3+zi<=b zcicqy1)-l3q9qf)OUNSK1ffS*%|onqKdXUMUt%>oS#1}q*~)6yvYJL#yPVZPTX87G z_9m>Djc;&7ufgv+djNN@AK_2f?I^wjtkV~O_tfKe_jvqa4cVuGm1#@aPQln_ggimM z=^p{)Xbb9H?wtBzwhTQUV0WMxfs_jDdjr94Qtcwu4yGd6jTU~N!J};<)h1G{0hQ8supbPs8hN>-E7Y#VXP0DIQxs$z#jMc_?|D2bLdY zE70U1y1O zdnA6v>LIc8D(^!&3ysO`UOXkFgJeETb^{~=JigQpb|pqA2Qg8FKI_!uz}^;axs!!X=(bc#W-w5`~MTJ4fUX z$mAJ9<0Kwqs}HgILFiN5+{@~HZ21@1%2jOT5?1ep5VjAkj58G-O{pW%fid_;uo=le zS(!URNUnIuvqIeyfqxDM)OdpauS4!3To~Kb3Bj?&9Qdv0Qk7t3ZZji8y9Xj@H}4*T zS|xrDS(B2L5qH4T2b_RWp0K7C3!)?|HhYPqw4$usxuCMD`j%T4f>J(;7W>faQ$I(t z+3dNt_6}d?Hh)(@$JMm?fV{R1M#{gfZ=(D0%rb9K^Mo|_oO{g=TQunL8>|e?U`K2Z z>#%A08+>KX{4`;}KeII`&ZbLCP<}t{aG*Sv#yUR1uYV#==lH?21G#@7cVD`6M&FTc z!13G2uSy?mK)EO_A$JYO)f5l!W5t;kB$TC`%c4ydv8{l)kC+zGPQJo>W*T(F+ITDS z@8`6FTS$JJw<14hP1#|BO4@^Z*xS*^Dsd0C>Rvu5+3GPm+QNPgY^{2?Mh12xplLf{ z%sz{u9=4{WnGb7#)1oun)s1SMb+hegvdfxsKxDh&*EH0?c(xG>GJ|~%O}EU1ni;S@ zwv%F^85%WOlO^-nn)$t#TA5JsHg~IEiA57?Di&2ohok-RJ#pCKqhq^Aqx;9A33w0U zqiS?$ICZ}oNerloq`EPlh^OKa(|sUfj&b#1{6I8;McDWhN~h;#mBy{i_8VutZpujF zQ&LKgQ_3BM4fkKDMA|+FZ?Pt25nmlyLG|6UVS|;ioAFf2jG}URF%theuNm=OE3@nW zZ>B$)NJZj_Q8k%}s!=mK6iuXVJeT5S-k5kADuum)Cv6k#pSxHilqensmW}1nm&YSW z_Q6@g2b<@Y+-PN5W|hoAe`GW|s`e*`an1LPB!|@D$RM12Yn#;M9@Xnl;m-@v#VZj$ zg4q+{;j;)*p_BKrHL2j41(w1aK+k;G>OB2Qk;z%m&qU!)&lhR=>BM8?eW!}FUxT0T dZ1oU)%kVbytW7z2drpe8TNh4YStqmE{{ceZlZF5Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-SOME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-SOME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..77aa73b1992aa76d54047f9011457eaa48c59ee1 GIT binary patch literal 8387 zcmeI1Yiu0V702hb>$hVkPD~7#sq6Z^cQ>D$ty6wcU`APRzhe=fhXHx@{R<1u|!oDqxl`*J1W zn70R^`9ncL%C}mf)chFmnjy6BbldfonLC#o-fT57O}~u^P3d9xK^ECJ1Qfefg#)-&dg+A zKz8wgyb3Y%?5@(|@ls?@9gf@=FMW~f?}?XoOJWJ|>B{Y@-HCj*KAs(_aYiQo$&M^P zv*n8l;W))kCKbY#3dy#;oM~Z|AROQFG7sm8OBa~@dpod#`D1xGWBGsE=C-()aVSg+ z!uXQs&Rn`FS2oyFUNSf3v<))%&C8FH*Kdy^PJ$R&^oUmd+OMla|C(49Jl2y=bqY&WI-?#I;%I)>H8#Fa(BiPQGbfEPmtF@Zz2(lIqm|6NOcdQu3|3W zfIk^DT^U7Gy%#Mhbg)xqh^_%qe|OO9PbB>PROC07QnJxlMoBg2Tz@wfBj@_iSVGBP zj0#GgGV2~i8;g?t(e`-6Yu_=b`T?{0+eRhj?l5zsX0F?8ugh$&#cZ#HRg{04$-8Fq zE7nwg!J5hsSyS1MNiAMQL3opx#0bTrjC0ex7eB zC%nXU!oy~r&ciL-V^n_ASei8|cNt5YjLLP!Qq`!u4)M6}#VEUY#Zc}pTNEHW+t0~EviPzL#X{s&dL@~Hfx!=s)WhS?viTpr3+7k)(^`Hf1fP>f; zjBzfETybwt4|XFjQZ8&URA|co;r8TDxgq&|GkJsB3wI!faEjKd{G#y{O71b0?=-b0 zI1&E)XL+rz^AHM;q2!Xm%{XM}R z86*cIDX5dPjzfc#XpUZcsn?3x>uWE%*Q+i^uZsz0pHN_dc02NFSlD(F4uc^(O4gZm>%qlnZH z+}7TBD#%OP_5QrY*?@_2{nc1Q$&>o5%QdiexlEbI_1U~#1J_lo$fsk$^?hWA2R8WD ziV|h-C)I)hQ#D7b+mp8H!TGAUv#QnV6sw+Xbz;71lEX6k&}pOJ>}|)q-qw@v&1P>4 z%@Gj&XWww?-PAN4BRw}9>$9>*r=$!}kP}fT_eFx@`q9ZQ@Y$aF>po@fD3WyVw0Ad7qG>B0G?0b>!P10#VH^JwC zEd-wd!UUfHx(Gf7ga|$YbP{|3pc|+39-xEZ9YBEKEkHZLNr0c=b--qV*8n#VyaJ#* zz4Q`*?pM-p0UHQ@16WV+9H5Qhmw;A+V}KTdp8=W)ehg?LcmhCo5a}@hJ@2JQ0rV)9 z9s;w*jstm;|gP7zfbl zBHavFO)vtW%Z{`Mu##XWUV0SX8{0pt^W49Fw+2;e6806@1r@jZY- z@D4yGcnd)1uXqw55~pZ@;JP{1S{>Zt;ARImIoRP>bNJO9el>?*&EZ$G{JPM8%PpbhmC$lZX!#_xToPIy z2`z_&mOny=J71&EF+>iocd*aFnuF`+SZj4~i-VgT+~i<~U#-DW?(nNQ{Av!rn&p>5 zvD^|`UI{IygqBZ2%O#=Zk_xbrpEJBG-?^$zwqSaWdQ9BZu(ZgFt4gPR=e z@T)aA${l_+hhNR%SF`+5D3)77%PXPfl+f}?Xt^Y`JQ7+C2`ztw>uU&31R%7He2{Gs}Kk z%jdB0Sr!Ahkh9iWmVTB4wuR=f&|q=4yvf1MrtfXG?`ye@c9u8V7Ilu6>MY-Q)SF}F zVch`Bn=A{h6&5s*I0wv8xQ^>PSnja3TISl-TC8?)V3_T$W8EOjowh}@)o!QVu9xdO zS?;p6njGymS?#vl7PYJ!V!7M4pt(KEmc=H!C)cxX7t29g%bw>pTdR)i!z}mMS~Slz z4o$X}#`RlR4%u2Xx1@z*&m1iu*LSlVwzVAdsnL9r1O!@lbs=wt$I%G)9P5l1`H!eSV6)J5_XUIa3dqOa+Z z$!Qer0}c(R@fA)U+%wdVH}L|Y7c#$KE4|9+M9VziyWjhKywCG{-h1BnE-Vt~5r0VbXUB8tj5#T1XQp#A)ACq$Ql84rOpcoJ z80h6k{kox@8BqO$d%HVakrK=3q?wpDlX7&%oJuBUKPPv5K~{5<=?o0+y%)re16`d5 z_U+s2>Qf^j9__!*feD=ly7upNtzBFZ+*v}%D7lVMO^BOF#9GR`eNinERr-PNia5{qbtm2c>jr?WXFV?JVLu$=KJA`oIdnXl@Lh5gZ>9=4W+b3(0kAzv2^ zE5lHl+OH9@%8r831uMV3W1n)563{|gR8s=6;ZV@8f{9#QsXI@I;|7xYS?cN`;iU=k z>dS}3!>v0T1gA|E;pUYG5l#@2t|5eLg0=>fP!Qbtz~wABv~TTzL0px#)43G>y9&C- z^OYVU_0qL4jNe@xd?Ne{LKahB4<8bRIv8E{9+oj4UR8wD5^_B~+QydCW-k1sz`Qbb zEp^O&J$0-RE>B^}ui;c+3YNmCu{bJvq3Pz82arWZD%LunyHQbBRCMW$s1Wg1yIyjO z?pasEsJze(r2;kP4%J@JJ*?b$-E-UZiW7x;Yp_bJwoq5G8e0cU;1_By^6zAs%aqNm zD6WKix>#4)GlHnhlM!#Ui8tOp@qZPF*A@tK>W~u^MUp#M7F3n7De0Gw$;I)j0v8wN z`KZeUZ3o%-T0?h1kF~%$U`N4&Wa#F2jZ0_+;_$oG{Pu*e1z0 z{>J?P3x;u7TeaA2)xz6qDRp`KRtLah%AIx-(PcfAZ}Iu{a3F|>qB5X{10l^&dV`<| z_eXqUEv*)7;Hren36}#--v%EXgZ=@<(4sK|PES8Oek&sJNK_jVh0PvO-A8MrdRi^H z;l$nM(+op56g?IljzxV^15Bv(so}W7^bsG0qqm`}`~2j0b;|Z zR{&a6u+&H5L%n)PDZExtuh35;_~>>7FZCkS(fW; z+b(h2Du+exvcO#?xXVdyOK^w)t17=f99JUR2&NpOI}kJu_i?zBMG*f=8^I?2g?0(OEGD_kVv<$rnWEl@Xwz}p6sF!ov`M8+ z3iUQq@BL7t<0)7rCu=v9^6+I)5yoB$p?HQiBZNRJY2g5l2Vm@sL{)<|TY!B@82XT6 zn-Aim2Zz-DVcVk{=MHLdoVyRk4*a4(p^>&C)Y3Z;s;P`1(p>=38%!zvo++i*xbnMP z`5aeXghax9==?M{pTNw92EEHOOG)ndW!i>bUt(V3t8^zw;?G%O;uQ|hGAiOTSPc7| z3hPKw{099j!a+W#i#xY-@bEd?*z)0)LC+eNMEHR221)oQm;MYcb^Za>P}tT&%bVQt z7z-?Xl|>ZBIUHtz1%tMr=Meo2LN}K_&!yd5@-T_4uqb4KO(*AR^8{^8K~9HX4Hzbs zkJ0v{bXPyUGeG5ow7r||+Cy6-5Y_R#m2a9hr>5nknK7qLB{`GJq(|X9c1pen?U$_l z9Z|HmomJc9u>^bqC*|}6|9VB;S*+8Mp07W@20u79=jU$p5Hi>E2SQLz%u7{>56;i^ ztb+djb6g(>nfcjrY+fwJ*uO$*df<(x!nNimR=zot7(bp&VCqeWA%SIQhoQABT6y6J zTye1i%9qsMh)C}OJLYdMAI9;AiJ=Wg)wrFS;c zlm5o(Nx%DKDg3g8!i_QtFPBmH>3jvgGo%-7Dwj8|l=RJ#SdW#(`dV46Gj^<5JJt;N zuda84^zizsOKl}_@#&N<)6TNE+wHiGcHC`caqB?t!EUsdxnez!_^$N~w#-t#)eolz z{I{m;y%-8cHA4+WXbrl-AvqG$qZ&U7-n{k3>4Y^CU#EKzeqb#-tz}6NB?#ewp&(kz zj_N7|rzlE-1HHbpLh6g{&Ob-~&z7$UY2p6pfJg@k>w0mC5wJ4~z=CJB*+>H0auSkw z{F5O;2iKF&SiAQ;p(P>$d9aiJA1Q?CZ7GY$ld62T?vtgwpwd$ay&U`;0vt4Y3KCVaDc@rE$Jsq!GJb-M`F)`kf-;$VZ}wa8 S{!j6Qjmu1)#>!UK*8T&VECv_= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3cbc8a1e3cad4c804ec28ced1dbb69027104bad1 GIT binary patch literal 5839 zcmcgweQXrR72ln`JKvo-V-tT-Y*;=*(1`_XJ{pLk`Z%xc!{QM1kaJxD*@*XD5g>N~$6yY8srXf{>buG)kpfRjN>>RimcqmlTCmX%T-^l)CTD ztiNp_&{p!^n|brzZ+`F1o7q|S3D#z>U-qVw>9`*4l2bjIbWcX^NOj5Gsh+O3sN4a1 z`3Y|zsD87-<855^K$SBzVWh1q+M0>B%i*4AcYAB^O1WyI>`8aUb!gmwKXj`$t*_p+ zZrv(pohRhyXt(qMhqark*Q|1moE{JhQ-UD02^Uc~1ffun1moFUp*yUG!b+XbuPU0S zNp%~2M$QhgD3OpFG;&4Nawe5l^yuEGj^QM`1yK-;6FGZbMDvDy0nO+a4~lb)<2jd4 zQ?^2Ao_bXvb`u5BMI$$_YMruHsa5@ISXF#=iWUe9rw3ez1i@N~gx-o>*dm_q6yAAz z3)x=rl_Jp^8;b2L7$rNT0b}UyX4KKaB?zV%+{m>W2;DkoT)&9x0|jgVe&SBs*yzF7 z!Po`R%{!D=EXK|QHnaPpukm=G;2lBei)8}^TZjnr^u1BGeIZVUk6jR8ii`0!nQ=3D zi+e|T+mUr_2u(TVKmkbBM;%frHaQLtR-=mZTQR0wfJz<=T33&f9-cyZ2yKAxGa94& zly=)}$%aw3j>%abXN@gb{KT*!!4Ld_i_?r3W0>v1n4vgc zJ}X>76SiPucpT}D5e-fwPzo{ukM6*q3H;3JpN$*pO@4zu6RUg@mIZozzq| z8OSg!$uX{H1ZT2^;rQqx4-Y{eaKB*)Il8Z*x|9lV}WD6$nEun zy$woG4M&1-EPL6xZVR=9!fF!{r(1*rZkjI@P=_=Zj`9Mx8Vm-4N+1&68VS3lLU5Sl z_Gm2%(}&y?&h(=7Q(p}Qk|0nEz7TwPvKIl8tu7F3@`SNlfU|ld!Jw*5c;QeH#w<5r ztav;~uP3DPsc1e9zYj>xNpBC-{v5P(LoH341Ab-nZG`$C(NYv=XbFl_y!R9rykqc~$ zoa1B9@v#$pEWwzPHZFE>(FmMeO`b+o@dSgO7MPSQW1*16EEH12LJ>b z8HSkUVkh$xA7y@`pZhK5mU&DF|KQ>i<{?KkR)5cMzL~#pTED$Fu^)FFgGrTZ?62>EK?i+-nE-ihzNw&L8lE*~DJ% z_8?t`9-FwwdhSuhJ?^9T!kF|fU4Y_k7QgfZE_wmY9#o+Wc~sI~h9Eu0U?rUaNihZ_ zeI2K6@@bI}D_VsvM?g3CxR-m#+@pef6tfV?$2g0x7Phl5%nIov=0iSYKIAg&={yaN zEY0U1yH(;=Q*RuJ|Tbp5|gRci+VQR&lX_O)ZwPsYSwi z!so0f^fL$HXh`j0nZY-qZK|D+U0mBzvrXw04}!W1Eb$=JV&G>HS_5U(6AmF z85y|_4U{8CehP0#=s1pe3R$Cg4)n^7Y__gli^g-|hX9Q5d&GKmHZ0eXntPbT%%HR3 z?Kk@KV1nt~ZWnKyntuw^?IKKxP%-))cf#nVXPyfBudAW2}D#PbDeK+SlFKKAa`^ttEv_oPdebXyVjQ!SPP;{aRLZpzi}& z3FoZh$MMLg9FJTY5DIGG-iOa+ec{zY z!N@JpTa&xmTX8o`yKq1)i|oPycMc;bHWM2=lA1jAc<>Rr91L*YH#tx8LzCxgCeJfd zc)nut{O$yvrzY@x-sJh%UGtn*+P-caHryHBmNTL@LFF3 z_xCRe*UaE7b#N6HMDaTbTx;ZOP7bI+1`l9glybw`Xs%GqroBD1SU4 z%)v6;qf2)XCtSvRaiix2;YAP(sb;LN-&L&i07jW+QJyjSrP-pKzGN@meJ~VqD}39G zgW>@_OZm*2$|Qikd#BwZ9UOWuZkE& z1Huwk>0g{{=xZpff&WH*a9(fqU4>6QpZ+)s_~N_yiAMlu;)y4S_<`u~Hh6*_FT7-+ zKx9@RaNF2`hvw`=!^pI0MykTU{x?)v`d=I6C|pC1Je&2=pu9ci^EN}TY16)i4YlrGwfrfRZV10Tzcgu`=k)nyZPcRT#4oj1 zC$?N?Q$d?X2q2_KyVP5Fx6`Nq3BHXoi4SG0(*$S;x=FAv69R;W$_Ef)q8}=dAe?ir zouqYOL^RfW=iPJ9`JLZ6_ulhfmWltQo>KJET)9wmDoSagT3)Csv!#l1zO+!8agY{WUEe2u@{{4x$K2Ul>SdDTDejv!o#6MFzi2kaNzLJ z(1GxXmPrY;5A^|u!NWrzKM-Dhd4;x@2q81%4HO|l+KEiO%WiwzHZrz4GL|w_QyVwp z-m>QgAs2NrV_2TMZ9u7(%4*Sh$|+(xbLR;q#CzTij!c@mJ(f1T8hwsNyi0C$%v2{J zHSLH&q+lHd(W&RQ^$)3oYSKs!h!nqt26l<`7>>e+-}r!1kJir1M1a-LT7>~Mk5V` zUZG95aW&l5(VxqU-)o@lSZwK_`RjnpEk9U3b}8NVV?vhmUrDzel_*46zSec32N~cM zBm_ddQJC4q$<=eEuQYNEBJKPJ!gcCggU?83_ZrI~R0)ocuPN))c|xsdpI9pl65l}k z2HF7UubG_km(Bl~u{7LZ9NL5-pu(0~Bh-f`7)t2jE|v?5fipMn7pK=7oT3Pe7lbNG zcx!=Mp)talaD&}_DTh4R2#p1Y-0un=X#|(Uja~QQQ7`AO#WveF%lY;~JCRzw7u{WP zJ#8k(@YJcJnwd-)mO4BJ8uLgdE=5^L3c(eG%MX_ij`y~>uG#viY8m#V1;q$IGs`(9SQZ{VI3&G%^pBeW1T39Y&(kmVs5XP+rj7PU-=yU1B-zPeMgLb zAx76BNKj8tOsN^;I8J|^BhVK(0$maaQ^Mz{@cEP&?G>Vnb)jFF3v!FQllQqh`4x93 z-{6+y5_czyZ2JWk1HulAon~D&>q@ZgkFwZw$kIOVJ1=WE-2*s^E+sou{DdE{sh3I`lx1Ux@}k!X#7>S z1H~5v@`4aKL^x(l;mjGIsZZA^%CRxmAqOD z1dVp?2G_;a)zyD>)gSK6fL?|cRP$4jq3^**Vi3WHW`FmGA_#MKg|sA~z0!8#xjT#5 zx#?UM%h=R%puyXKAYD0q=y^Nm5i>D4-@?34TfITUP(?&&@u`{iyl_!6J-%b^yb zjD0LO&>e#=8>V2=(01p&+O7=%ooMXy17cJ-oaF4TP6(lUwE&fTfB%}cXjpOcC1O2 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f04311fbd71e0e03e7ecee775ff314f2f736f334 GIT binary patch literal 5469 zcmb_fdvH|M89(>jyN|qJ6VgZk!xDt*nhVVfc~&mV4S8&K!#+j@H^?h8a6LwEn@=(x%^czI~a6 zVjUp&e&_pruitmhx%b?iVvb$@fY(2=e{|SNjCn^6PK+L$@D7ZOdB;Z%j`bzH1Au!U z@rT0Z;daB{wPsUeX{5l?HKJ4gNgC}_`?m}#tmL$bZppy!TR-}Hg0Tf+St;v zrnJq71Ss1LV=!Rj7w%e9I(K4P@r*FW`q&v1C5(BP%IxDwk1uLQqIz3Lz|@0Ax9PK| z?4%od(PI%aY$q$5yb~j%x|KMTu&|x|<4j@9elqE9iv|7Bj!@7}D~~GW_OWC|M^Nv9 z){Gq{J93%&5suOqU;J%<&>J`N`0!PUV#Y?AJf-IC}wB6NFQWuUwIa5&0~NMmpZeCC6dK2>+h~uoA8$eY64NExRY6IZafIXP=TntD}#`D3P zBej0h+UF;;?U&!EeY67|_$ye6nVkq@-x;%|<*3dyBPJ(cUeID`z-hoiw&R<)s_L(@ zZIuq49)gt|f;Al4lUuz{vBsHx_5n#^pX=+Hm)TLYV%L_l*gg}N?a{)ck1Ov3n-Gn& zGn*_f_W_s+r?cL2%56Y!J}&!6WS75S??YEI1h)UNP_^9uUkg=#>IXmzWv6O^<;XNm zn-i*A?i>Zww47GDAk)ZAB=Wl~k%iX!3=y1tIei%&RG6*O%rgh#=9PDx&6f9A=cvyz z#$a-B>x8N^1gxgaZbf2EcoPV+L@St6!B_{VH1h<3lgiTGK;=f4d$wqp>iY6n=TsI3vB0 zsM*bxVvlIZC(6`HQKDAC>9W9QhQpz-9*RYKVo{&E2m;D|MzB|xc*G~*n5n#L{%KXI zGA1-Uqe6J*JPVneZJ}_t5k>VRR`tiiVKZ281_}jj$G}#dZ`N-_Oe!VH&^&~h%$+eK z(1U6M55R7t%hZi<*yu%QFM1d~J!Wt_s(U~!ksg7Lh^!tFi_x%yL?gP>35n<}plWa| z2T&;!OF(G!Jq17ep0`=fxrvLR6y|6Q4t|Pt>9qgj@?Fz1`bF0X=(cBd$}Z zk3yHoQ1wF@qrNYef{Xe#iSJ5J^=av;PLbzs^6Vv-9uk`g+(6nY(pHeBNR9tnYWzLY z-XZN(;OO>;dV2MUxf3e$Q(_s4mq|QN;$g{yACf%yfaJk9P@;Mg%PC)p)RYfMP&dk( zGK(@x;w*`0WKQKfGN*D(=2X5+aXUz~lDL&bg%s=xiNDD#>^%~1k@zi%S4li8E3lKY z0((+a_lepE#L`Yt+bC)wX$%^5Ou_^>5o6BMBh(wLBv{Z?e=-?3b zD45i=kEEu3NZMaXJCB^(0wMV{X|s@}Ji|(l_V$<%uBF7SC?1myXopDjL!2{W;?sr3 zI8x~{@u|`7gRxtFlLkY`MvGCYom6-srE|(W>J<`~Af4(r!r-o66rV@&E_UP(#pL{` ze*_2Ri-^A|R-pL3OsdYxr0O}W*%l6U>ogzgk$=)SNu!2owrH#6_=7R`4bE&)VsVYkH&0RTZ2mPDTA+@WGMhDkS5)q&U|LMMTvT^N2QMO+iE-u+wsGBvF}F z)f`Bj7KacTyGt10V8!seDXuU=bGpFpbYVW18>p#d{Y2dD)M{aNs&~EUYt)9lhxCvJ z%mU6FITa=%q?k-`I{pDMg>?L)okrf|^#At8&)ew?HOdJ0&q(PvL;@-OT)>^Zh{GS{ zhd;;8VWI4@V$#9F7}5H>#3V+Z{3CBqw1GSezMSr^~i z*Pj@?-W{D6r3O%x!|M{=2BdTGJuxr{Zpz#=^K6A5h8GOHS^SL~z72s>(ffgM7yJ$= z!E?m$!;6f|sr!XwuUtv>VWrE!9?1_3Uhj@xf3cG*Wp~6FysxRD>)WZlC|;Mf&f@S~ ze)zNe@Owpzr#v-p@ftDun{x4#xSg(seF_^4p0x^xrgBBz(53T#*x@6`$F?@3YV6<7kncI#VYk*0t-_ZqkNSqFt{y{@UBU?Cv$Og%lj$+2{D| zbNmrfDxx$sg-C8>G9r- zudy3MQB~c|y!U?dzUIx>u9NUd!(v8lesQ*1UShS?mBrN+HeFj{%eB>|sWO`eoIPbY zuKA^5-5BeAv@hZ97@1lsPp*_p%wH`pmnNUQpY?r)>5EIVRbY-B0kQAs;r^qC4)rFE z>7FIMeW(o@9DV3;Z=!K+lcsBgkSTHlNt}>0QAu#6p3eEE=WEACEK{@fyqOEugL(|+ zq7^;U4eIUvY^AoSRmFVdFaa=mrL)(S8+eaIwA zY}*TZr$Ig5cSw5(qgdqHX8aN%%DW4M?41zV{H*fg7=2-ZeCOw5%85^Pw9^RYI3xaZ zK&omYLS*7NfGtVL^?SCpTJIdYSa}ibGMAzmT6y7A>V}g7@#ea9*-8D1koC$}oz$2@ z!Ek-+?h_qNr!hiWz}M{5o}Fn?znNAH6`^$Cu*qcvhZ1Jtq>zJ9XV8z6*_NCP7$Jf( zHYep|DjgjnFwErR%T;--nQLpc2ZD~?%90zSFJVd`L0@f!Ja$M3WwE-qu`FU;yRk0J z9v2L=&yvxsat4Y}IhBDaS9=;8PG;+FC*!0l9Z&{=&bG@4UQF3@LiRWdg)DJKQutv9dVC(94{g&-&RLnyHgoYdSaVm~1R1{a^+ z`mK`zBT#@pc&e6wV#a5xAy^*xgSqT?F4h0Y|4L=+uK%{L)+_1RG*Obl)%u>C;n;&C zc!IQH-5#_|R~r}s#2)f;N-K{mF=!EJVK}DkIYal2Va+xDq6^2&5a%@FjeEYCSLmG@ zzLVogwS~vk1RTv&&U9VJ)tsVVDEc`y1qLlS-5%Ej?&Ua~(e^_hJnAhfAv}Z!{C+&L zZ-A%BF~`m8K8mknRHNv+roH0=;S|SSg|Y1I2^zX*%1}Is!#_k%=JBF#6;Ry5+as@! znVRmp`Zz-02Pmu;3YL(*2U1)pSRmD8Cc4!YzT)ui-k6 z*to8uOh4iK5WNOy+lUQ2RJSzKGV`#^h+pMU50DwzNvlSKv^Tc>FSoplc)y! z^mx(nOn15{gg)9V*B>VWy*EP52{FaehQ@vqyK8`a#rsM3x$^PIc|UwZ1jnH014|J~PQqvnf_$@IA<8 zScT29Gi;7k**sfdHMYpkGWcL*D{PgWV_#tB*^}&x>?7DPXJY_n(T`zxF zA;3ZrcRlWlsfhH6$67#N-+=cw64mut+Q4w9aB@S`&5}aX;r&_I&G?^t!kx4N~daSQg+V0 zHkbr8%LJ0&`98mM?>+at$24*F1;a{k^ysmSmC7okpj!(bXx`gW5ihe0WK+ppYEUu9Q)7e4`Dz; z=+xq2k?p!M7_g^pXLH5EGqcn`N(dPs7m#=f@e`TYXY&4lsmD#VGZfZULyPDEd)m%> zU@dAQuE*?r^$sOBdQ7!aUrAZGoTFoe5@MgudpZ+F&u;=OciLo3x&N)TJSrQeqrm?iuFs1VjL!&pGZ%n=RmRMq}xx^FTHF4 ze{uT2qsFU*Os5|*_Dd8JPQS3OcRl*!&qD~HUdRm8^DQjaOdlxK>@GP%Ajc^5l{DqZ zg?%OMqF+-Lj=g-fwg;htqchJ&mb?tI~%6+DUs&lm3cG-KnZ7+3Lx z9FfvueAc?s29~HLTMo-vDfYdjEYW+d&B)%Hu3!H5vM3yz{RsT5o8XbDfW}7e`NG$h z%$93$E51~wb%J&g8M?Bdl^K1&W1`a0&KGzUh-RTJQ?i!;|M#PZn_aikO`J~qGkzlZ z?8oyBfne0=2;oFhyEUUDtjE-Lm^UG#D;|)%%qw}|=Z2pXehwIY)q$X92D{amZYE+d zx`KT6x#InCQ;$gWS`RZCV3l$u^U65xZVKqJSTv?a6J}4s49FD_P!-UOewFLv0S0rg zy6x)mSt%3395^)Z#`(7kGPydVv501(*ovsZL@cHoWkZ=!v~2-f&C()+T3i=UtP;%f zhmfhVY{H`M4OWZfRWN-f-XCd?hSk#8M*SRu>jx8BxCh1aC?3*-W;BN4Pekx@tPUk6 zq|-wBmXPif(&yQFbn&n?NStgf5b58n2FdTar}P`{DV-POheG+hke(7`N+=%@(g{KC z6UvN`?h#}!2afT#eXlfpK{lhFa5jK)Q>TSY*l zaH-}J`B;#51^KfeKjPu!91kZ?vYJs=JILz3z-r^HF2rivS=}yH+r;WNv)X!AcNgr5 zV*_lolXnS9)$lfT8Q2106rHRdi2OciP81D-a%uLpJy9U^*c~G zj` zEIS;Eo9H6F$2K5&hnFk8CCIP9MGk7%KhgzWnDin>^@I~~9`${;1#M@A%?6t*5;BU$ zhk0}dkA6^i9LH$=kZ$m3i`de4Nk^c^LhGuZI4G zuZF%Nq&Xq|6p~bhqrEUS_{G9x^sKPiY%5Bq1PO5js)^KXf^39vPcRzk3G014w1PvD ze+Y7#$B>6v{Wn*`x17*!QHGN6l{u(nM#Kjq>Q3AWZt_QV-Z7TT z?nM5BS<SDhs1Wl`Y`v?_Kf85BKJ@kVqY15@RW8@_(m3eL&ClT<8=EGm;G&* zJ>!6zS*3^d2+nk~zefjm*r1Ap5f614dWYKHZ|W4Bd|Jo;1YF_vus-oTrqJxXJUlRn zY^(j4B+1A@FDxEq)2V%z=l_V>+b10-7Zw(-An&)ILWnc@#$Zg>OkKU|r4bI9dQ1z) zS*57Nc`y+*b>5;foathx4VF3$+eW&=wjp^93PGfIadV_Od&UC_*#QqHsy{}?2M<>j zJQNuo!W)=clq#_wr5^()JCJ*p9Y!(@3XuS%Zwh4&l&&gN92SZoUm5Fxy4gW-(_2?6 z7!N?&&I_iOrb@7Z~+H=W6)a&SkK!4&+HHa;?l|EeXAD7kDZr6hAo?yDIqGn~#f zD@H1rRf6N$Y;vSYiDU-Snc?I}GbZ}yEUCt>JKsIs?dSb`@p|0`|1mAQGZfFi3f{Wi zni}lZVk+E{$|(gKkN$0nqrAa}QTo#?aUt0C5U#$JRAQFsWcmlO{-2A4=cW|Q`>c?r zr+QKPj*v#K*BGbRWYVpbxJIGiPkdYvhRc&E zEXb2Gwh^s?2&7&%j>I`j*5In~_omf&Nqpwr*j$oau*aTIMC0#NLOiv7_9&eS~@0Zo1xvUM$?%g1^@9EsRr=z2- zsz)`WJlg;C0f){#?f11+m0nm7YR3s7L*xUjmtSQK?FjaX9~Waq#m*&aow30riB{kn}t9`R}!!^ zwO1peuN(!V3r?Y?y+hdrS@f_H=^-yH1dbEp>cmohlDV)?I6p>y@zZ@`|AwYI!9B|A zLtTIn+g&P}O9*h;8bJM};@%|`>`rCQZC?%Cy#$o~FzA)(%yi}g0PBx?YlY1Di#qUE z=k|X?f1QxI%-8gNq5uKs&NcSmjrREX2!X7ZvO`U5`^q&7$0{{@D~906auf$D$nwm^ zt_r$n*IGeV*wupsXM{Q|B{QAHqSvf&(Wn&eTagI!T`lI8FyQPUteh+QS1Q_3dw-Ru zqP}n0QtVGHdTm|~KL9@2MVB>QlypyJQT`Qma$$MiE5(OzVNovlO7X$lDVuMjT*DJ` zJycmtz;3K;V1?R}?Xum~eBUczg&wk7kUf-XTKVrHFB~uXVR-Cy@XA)f#kN~YMSDqU zdlomsx&;c?vA72lU?4jHFBI@Zp#$X=ifly*Nl?KW@8h%{MA~qx-kZzRW^0KUaGon{ z3Wnl(ID+#>=~MM^R5O%rm@W~$*9?k&>KA?Rc;Ruw3b9G& zF$Yaci;2R`7FIk+tEFn{mvFeP3u=ZDHqf(b(`m|*f?_i~43Zc@i2@*yYhaq9t+Ve zQ|cCZBn7_|hvn=T|B;8-6z-1nzEf~b!!PWv_qtwp0Pp}PeT9R006jGb zJi>txTNO2-W@_=d(6PE$><@7VD^|EZ+X|8Zoul?=viWo#dP^Qo!yjmqW5f7oTI#Tz z&!y9HDlg~1n6_cVi&O*O=sr~m^{IxEAVT%5j2$ApGs`mlksdHNh(qkf>DhK~Zd5xIhFFe893&fABv3+;E z7&yjC;5W;=ih+O217BW~z^~qP>g0Q?PkjewJwufod^Y@}&b$|zeqM003k>+_S%ORTUm8##@UPnSyn1%CR;Qvd(} literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8f806d47fe445d9938bddd92cbda96117d7b1fd7 GIT binary patch literal 5531 zcmb_geQZ5BV-Z}T$ zd5IlX)J5QT?)jb1d(M6L-j`A0+!+Y_0zF*^lV(S+uVuiwyOhSJy^)|80a zqWP^+E9Hi{DDjx4Td8@qzW$zrirI0f!^G)y^%02>>#3BxF&+sR&C!UJmIkGA>r|?u zIihTXsi{pGq3)a)^e$N`Pt7`IEkua~$=R`rV}v+^n8z!f7q&<*cavMMZlOCW7tfQN zCPlo05R*sD=|WX-WXdp!bmuv8-i9bZrYj5cf3|Bfujk6? zowOl0KwXpB%s|)eyp|JP-ct%whk|{}#vN05*X?YkL6jLWE-1|ztSP{`Ba>#&nq?RO zX9+bF6`8A={5@Y2H-^Z~12VJQJCW(Rvq-Q7b z!_G*)5EbY?m!4R76%ZKyL$C9R!Wu&jAW)vG(+m!PhUuBEpUm6j8Y^smJg|At#KP!{Vm`BEq{vN-k>rq{a#*J-p!!MVDLAhUzv??5r`5El^ z^VSz09Az>g%z?*6BOU-7z*9+MRBurYWY=TVKwQ_g$h6~#Nhn(hvW4~}18PhYp;#G+ z9sfa3+V;2_-iGYIfpy?fgUp}U=aF1tl}KI^+&RH9!JQV|_XYP|!Nmj@7TjiV`MFqY zOG7lQlvV};}Ttz-ERC)y0F1V=RngmxPxN5;w z3T^@C=*OI+w*>bt4@BSLf#?Muh^B-}pCG#g*&z%b65J-itrXn-oRe;HXVP`CT{Du}V zqWX7O<-@EB+%~W(g;jz_zCIR%hLf)^D5rBi+(1eqxOl?ImaxS@93SGngx_Z(Q8aQ~ zg@xk`##>rir>-?9M$u({htZ=giY8XdI{-LihN^S%MYaUBUSms<{Dv(<@^b+`E5KpF z9T!}mP%#C#51h$4$9tF$je`hn)mm{}FO=)V^7$%A9QnLz+5MMyOdwkX{$yIi4VWk!MEF3i1P9Cu;I6 zsDa)BAyxnSW;EO`gd5Qtq8$8+P+iK_pvn@?N$+#t(q-;cx+utVygt%1ygt&9;EoIK zpx_P&Zl~a4f~yytBFG{EIyoU1c_8vCk3hx+5gP~@V=LNVANF9XYQWI+U6?rEkan;Y z53vU}u@&Ehq@6WZs;s}G555bM-R-`02q{)-nSs#qqv~?s-UNIlwEL3X;)0LZQLMV- zx;5;uhG6q_z*;HS!deS%lSb<{%}P^Hb~IL zzs88`fC@*GmsqJKW}<6PdjcaB?bC4jQoc{4>y)$;eyx(sDgj47f3wnM*09qWazZw& znmx#B25(KJmjj43?6!v7w#Kgtfw(m+TSKy~@j;zw*^cvtK|VnAmk?zC9CYD15#&tagl}PxkvR%-LIgQnRCf&0 zGe%a`?}zoI;vWernnh}sK*cQsnHUNFt3G2*G;Z&LWU`?ORbh?HCSaDkC_N=`_lBo=RoY1?xN z_(cM%3ln$~LoJ!LP75%B1E&0$5@6t$oDjj~k9ctTW?}F_P?G;*J&o_{>D1DIuBnEm z6x^4>&9E`4;TS6uJBD+6JZfm-?6^E*Us{XqE-?kkn3a}~WwY7a`1k}LS%goH5of)6 z<1PwX)LWPfK^Ko&Y1kfQNrr7irj8PLu6Dw^Ej!=>DuPa8ypQqmQ4X1w1|Suc%iy^> zgnv(vdy9<_-v9q+x{EjAMf9fI@iyD&Iz*i=R9I=F_vR9smNRO2rZnj7DLZ=2M&IL& z_9KJv>o5w~tIW(dn z2m8fB6+ZNy=DG1KZ+JUD%Mz0C#4Cr}en?gD%vHA0a^{D8MY5f|WUpb&_7VKlpbwAq zBWbY(%_9j!8b<1n)Y^h-fqZeK8wFLiU;#&@$vbvOx;CRbHDE9OlXpiNx6)qO;d0|r zzU|>;(orHgoRm0F&EjExi^D;CxX&I&?cpYSxW*nXw1?8vko@D0$&x?LNcKSpP2S_l zlIIJz(Qy=>niU-`L?=-9L?MbVJb9uJ9gkTlSE9Q=`N%*=bmWl`EOv=*u+k;a-!$w2 qz{zmq0Rk@=JlDXEAyJ33#O3zD%jJ?`NF|3f`y|OvFzAQb?0*6GUkcy= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6e5737c135c3995dfb4b0f0b9f6ef384297ae0d5 GIT binary patch literal 5706 zcmcIn3v5%@89w)3KNA8W1QH%27uH~~YT7)YG-K3`b3+1-9qemL&=50@jh#5YA-2m> zHX4yvn9!td3R^o(>a>TpO4FuIn!2u=x<|Y0|IhIw zFS4ZD2=@Ox-}%4)oO|x^2r(XTdt|rP*B?(r24pRh?$4yKaPO`+nes+v9)CK;+Rmb5kkV`CJHMdN;q|HH;#le9gcwa&)wS65J;K!_dFJ&! z;=}9LEEkLk>rqxLMoS4nF)=Pr^+LQCKJgNBE<6;w4tB-k=1L)U^@bPpKaK1?7j2*7b?|>UP zH}C>)UgNRZ^^6}X)`=}ml$99s%i%1Bd=(h0FUB@biB)238Gdb^vRE^iLUle&gf%YFT+HKsb(nCb;L#;_&dm=bJ9Yzpbz+A|MS zkz-$|uUPX=%)}2X1eIcJeLjXnIZ7cogUQE#CXJT z9I=V<{rLp8C;WPsd(eHP_iQ5-X3F z6LG2jOm>~!?en&@-P4j%9BfL$!1RPOFc-~`XmR^GyBq;!ANrfv`A0)#Y4 zD^dJ}jgj7jG0Os79nC(EBmWx1@M}E$92d{hDs+C4i^mwOl;NU-p-X!>dJ{)Cv2o%D zY=HPXZvB#5cer(fTd#2IE8H68R+d{sYzFajTqL>Z=Aw~JE7q}T#SLs);axUd_!S#2 z{E%C>xi!wM%iMaFTj#lTieU!+1 zn)?;E>hq(?TTI@ftI>Lm54p?$$P2XUB&|3>SM<`#X1cPTR(+DLTt};#A=U76z%jDT zhSrbaied8NPV%66o32Ii3V5ZxN*C%cqpo;cP=670V?cHJ*|vLQIAF!#U zZ*cKtq@cF7`>`l#ggc)Ar={JiD!UawHcYyYqi*7GRa^*cV(~*(hKMaT_*z;pUwjXq z6yaduUWPX+bicz>e@5>?>uqX7@dk&v&12Vj>^nSmnLD57&Wqgn6t_-uYZWUE&KT^r z@GmZY&zd3phBZp~1(db~mcGs9aJRYq4lGf4gQwi0o6-6@&wPnnXSmqRpaq#@Rx&|8 z0x+{T*wM^eL%s>N@u1@Ov7L1Ztxiuc&>5m@y6D;ty7tqw=0PgohXG~3;_X~b@7W7e z8s68ltJ9HGT27`iM^fo{I+Kn#;!#IZOUsRz@UEV%Q88iTN!La>8iLz+w;WIMi!}O9 z)?(UKeblOFO{rug^5`HciAba$6k|`O52g9&fR+izKr01;B9RUNuy{7bKrZB}M!?Yp^Od@_FdwJ^wR!1&X^dE%JqZbJ?29b3OE3aq z6aGw4_T@Mq8zW`-5_T@We+L8;z!_TM}gjOzsnP#rI-c};J%+D6!eCw-SqgSgj_LT=7N@i}{;C6Agc zKz0aucqZ-)yOvDc5$B*Vj>iU25EedbFL8vv4dy+51U|t9X(axaDqZ9YJ7@J&bj;J!It1OqdMf-`&+bY^BHgh_s9V;ea#-u@(~`BROfs6#jzB-4X(IF#UTd~F~Z56Q`Rua*Qb;iqTu)h@g>1*}$!!l-$`Y8hB9TpwnDz0SeD zH3bYRTNGGrp|Te^7`%`RG#6W05o~k{O0ijTp;t`nq zhb4#woO91P_n!Nm@0@q(;NSU*Fic zs<2fFcv!Umxds+At#5!elPAad(m2O)-P{C<0*))?L{2}RDz$5BKy$RZJ*va2w5xXg zn4ZdqTpYoG>eo|c_406h&=Cti9*$u;{RxieIQ?iUzcuJ}X>OlaALB>)V*UA4iQDVw zfYg*tDktQpqhNGiPc5ixbTl};fnak$b8A6Ob+}u(ljBAEInHtp5nYJ9wV8i&fIIQC z&BC^2i^_OQtl&`!6um_phvLe4d8!rseej7E=B3@Ek+(oE-=9~(N8Y^Xh4DX*Z8_|{ z%yGve2fUjFz63_+?%5_|F#P0mTrtN@M7vi|TGAkR%>a=X6Cnt&H4Vge+!c(E<@hPA zplJJY{GbZ}oUg`Uw}u^!+$H!zlL0?Jaxt>Ad?K>5!l?R1+#8^S)fh1!YWT@8z0I&7 zjj@tKOPb^J8w`i996j|}Pli@s1$yS=FWZ#jm@))ZbRyK~d0z!B(zCvbSyxH)8EF<_ zf;3S`x5|{*v}7~sS4{vo_-`)l6B#qhAupTVj;xC&o(Foi_0Dg|xG7_R!?@m0Yv zW|_7SNih>sH9==mVye=_RLz5b20aNg7KBDN_reNN1nHm&KedGD5~>S>H0F z0WeV(CF3+@a_7&W37=RW>0MxO3_!Y$gYUnB~ zWb$_Vpf9`Em6u=Req>B%#l`c2hNdS6D1f3c{ZJV*XOdF_pAQ<7*i(i*LxCb=#P0HWTikd9INB6%i%0c4n%!XW zZVK3iLQ)_U!6zR+dGN8oM}q67%GzWTW4rKJ1G+9 zlLE06u9$gt)$jND9loH}5!CEr87wHaE8Z>#wFm43?wYbD^OZGUKH z?ae-q!?-Qcevr9$f;->k>*#U>)U9amB=?{YNI3{`k}N>+cT$1k=X8yDiBzKYJ*FLE z;#p>Vf{8edB8HjR$bzkB!R$1c@GrVf_%mG~{EBH;nf5l*e#o?!m^Q|=reis*=>TH5k5PSCb!k37s@K`vYor>rpRgronejBK+(*jykOh6DqM0nLCzW3! z3zv{e1*Te_fjAc0Q>g8Q_Z_Pj8^(ibKUs`o6#L7Btj?!Q%1- zy|l$-oXR}XZ?Wv|7HBrNhHItw$r2R5Aj?o(BQ+@A#q|MA@#A{wDK=#&*8G^POcrof(fZ<6&mp&9ujvW~JEpn-moPHzs~fDdB%fDd8_L?G)2wwxEj5ET)3{ z4B(fz+7!Ry(o{cfq1Q2^?W*5LwUgf9zBB&p-=m#wjf;>R#Nc|}0VcD7qoVK1tYrEOH8m(?U#bZxdRCA~*v?^xn=V;w% zELvxFpF?-uI9K9?yRZ-5fJ-?&wKx{)f21db6x?!L!=uX6;~GwEh}tDsA#+jnXvjdG zAG*ySP+=0rT{O;FoR3Y;F=QvKrpqf0)D|-nluO(mnUHRp-AJGGh1rVqNuL>uJ~ak^ zHB*9&Ngtc7h)DX#Y(@H{%i~-j(igK%vO9QA40iI!oYkXxH)(Awb7{f=_o_Jw%v?Ha zhS7o6GsdD*#^BrLdC%cI-E6Hw>o?6-O2bjJmC}$hTPY36aW3B(6XxDSoxDW6>CB_p zGJSX2GE&$`-IDW&(Ct&~#PY^9Wz z=r7{Yay+%nVs3id@wnk&R6GGv#7-c~)}T*Q*~M@}Pc6)K~^q2NC=d4zDr)P;8t%K4~cMx4+$CI=&>NaMz_G2KS22D{W8GQ z`fTBjS@R*$QOv<}ffi^Z58?ewkDh^^*+V#BSc#5*wKJQmfA@*6q!pB6Ai+4&1% z?a2Z$dKaJVND4)w_KUb#Eo-ya{SO^gim#^Sre zL$&>(q3A$ucYI`Ec(>dgibdg%k^|9@JP_@R4?rOP8r~8375U2C+n*PX$aq%r?;XL{ zG5+!tG_~n0U}~aD>gH0dCUYH^j6evcZ(#XJ#GzK<+1b zm!A4Ez4W_7iEsj{GZ=-hGQC6bet9tTXjraa(}cxzd4@d+vI@Spq0`>&>%`*oR=o8HPb3CXi6L)vDls`UaMucN(;BZnJ~3hebIUC-Y-(H8+}6^v z(%q>?f&%T5KH$*Wb`$u_9-WaqV~nvlJB7r>n1?AWdpPa!MU6<*-`O2B{2{%^@MWj7 zX(#03k421dHeJ)~O^uEFt;Ftxh3Sk=GKsP5p|rCz779eW%}_QY?USmq2h-KvA%8EV zrmr`c?98Dcx|B_Onp*rf`$LgfdnDQ&jYSQ1bf)qi#vBh|INwY@w?TS#7yI7x8{|!k z=G91=<+4=NR5FI-^ofWq+0NKbw`Pmmip8KBaaY)?g`iT<8N~2`l=E);lKA%=NNew@ zsFRYmMU448x1t22v9x@+Cpu7QdQj>rNLN@xR<&6R z(w(TO&ZqvU^&_j!tg|siwio0J@tJkt1Suah>nP{XnRS<)wETpfbS0)LQZ6KzPaaBP zCoQx%!UyA(3z=-SNp|0GFG}&Rtm8Bb*RSgRU%Ypxrhg)5bbpuX|IXV)8OL_n7#e}h|!1YC-~J!?&h^f_VTNc?BaDu)(Y1);o2m~ zJRxilBR3KC9TKYN#por%RDUYS;{>f9BWU$7L908kGDcra5B9=L>UJD{+z3R?Fb-D; zI5)orN7ejVAj(T5R9>Vxl;=sOJS%ilLiY(F+#-Yvh0sM|C=wC*T|xdxCh|iRoBSZf zChw=%lM^cbN?2MI;mDjb4>Gz+pokP0G9#KPVt z6!y9xzZK*u!embpCVQCIjq>^t-q6SESM&PCynZ*7#1V(GY1EK7+6vb|M+mzuh(nXl zN74pT6|a3bXhDa7-qC?&b~J%X*=Y15zXEtIV8%jZ_c7EMp$^o{;R}#B`9dTbUxbA5 z#Xz+8xEIMgVD9V;n>~KvqrHOjM7z4fh@hP%AMK3r`8nZfF9_Ek;JlHj9>#gK@9-r^ zo`aV`>xlLA^yja?xeT;8pNAG(C^>DTAgvUe)*|Lv36o2=q1AFR)%5_Ubebk_MB!DS zc0>$(*Kp_&PSxnN76lc;3AYFZUMq4^&tXE;uVA9SMJDPS<(s4n5xVNCOI4d};1 z$i!Nz4G^*#?52fR6}}Q=%6q&S$-fY#olumw_>Cxfli!5o_q++otHSOqzZpj_^A;pO z6K~f~D0$_$K>UKR{5)?(lfwe+pa8p9fPGe&>=9s}6kwwQCCP6wn~6C z3$Wz^Y?&~*PJnp@SUrKsuM&#R<&}ce3!#Tb(mw^+Pwvtl@{=q^?sK z(|rCg_r>{wAYTGAHSxu9Fn4?^o32eICR5&BlT(9}sgcxFD&fVYaO}>e7e`UEbg#bD zJ3IhCW{12ZyTtEMlE1QETq75Ju!6bz&g?(Hxt4mT~`4!$TY8)D7>D@5&WoCZSF{!|DN>sbgc zqd2Havn3&-)&H)g_RATj={wGQ*cBI1J6Q;H5(rPW8vZ6SCDs1H-6)lJ#7w#yosOrb1NJTPHq zJSRGMBa%(LQOv!u*l2z6VBrj_(AU8ayUVCm$*v$N*d)>ZUZXcxuG%7Ol5+D0W@nrFo&7DML9iYq>t(|FdSSh=1bZ;v;UjAwqE#OtC&vLCNwZ+>yC9OhHJV9( zD~C3apIiDXp-FEFv{$JGPov|R0(-i^K3P&M>5+29!Yh~b5EVa#U)Eh zwR@3*N_YuTI&`6Q6-b?6>vR^|F18U+>I4KQB2*XK=B04bmd?ihK`ER8H};nT`&xnh zb%A}RBuDneY`U%FzT)?iC_XTmnDoZS#z)|$GCVOh>Kz~0p71uWTJ0Sh_6C9}{LR9S z@ipVHNxEFBOHs9Lz{1up0UNbhm)2pksZQCxjr7mrLK`LDsFMAm0dt-L? EzqiVpy#N3J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..13ed8013c283203d7c10517925b88af740b28b9a GIT binary patch literal 4736 zcmb^!3v3)$@$K$??X$6+_(GjH+19ivm#h^hcI%`qczs^m7vJq3dwX$=0`zL1bLVVq z=X?gLs!a(w3CY|+k_yWp&bmQ0 zljPQ}s{;!6?%L7QS?8Xp3QaSFka2PfL70#xA`$0!r731<8A};VBsE1>Q(DYfbSfdp zMagC~)2TFXm&-G=ik<&*-o|te&JlqS=NpyKU{;S?2}5_5gd;-4d9u=w(3Lc#rVeRD z3@uwh>w;5R+tsb?P|`*wfhtO3P|*#GoTxS&CB*j}hV*jbmEFQi)8vC!cZ;K+Y-<+$ z`&pdGYaqmy-0%OC99yBmt{4G&(5)RxC~hp3?1) z+$E#&nH#2$&b573i$sD5L%7~TZF<(AY(KFdUkQ-Nu%)%LKX`P zM&oW#0R6?2>qgtqK0YBrAkWN5htq1mSv&aDKxmD%gfRCyq8D4z0Ny5589ILv;A)hJGRa`rOHxzbjdsY+uNc6k4&#oroF{3|r z<6uTcgt@ShRrJ{CMY?$9|6|`m*F>+@xQm6RViOVToo`h(#NviNzz5l|st+VJQ|V6t zMIXw<#0DA`!|;UQ@x$YTA=?~_t5$qiF*Pe|!jO!!DI3U)Wh^Zv3Rg;4MvT@=5gL~2 zV6ZmEG}AOp#mHLetQC_QK_L=T^)ZFfGcgJiwz=o>K^>6@p*|eXah$Rzz*1n)FjK09 z=+o#mo;6KPUp4-zfV{_mw{|7TxSG+pD_W22QLyxh%Vs&!duc0zyO5n3OZ6K`#d}F0 zeLZJ4(fub_CN&)%h(R3WtgRfZ z`_$SBy%(1sQ_A>J${G9m_e#ra?^IT*ab63-8O&q%Xb)D z`&mgLHV-fPfR6Q&M0Ap_M_>R|8qvmZKf*o(Oe3Z6V10wgT;6Y^8&GBoko*}-HCfSh zfCrzRO)`s7x(Ov3ffngcSPH*zC5=RZ@uUxd7vyv#OJ`_1g1^y?2>!x_-o~(#iHyZW zva}6(Nfxg300%J;k>V<=rp+ucsU5Y_$!vycHPKI@RvqU_zzd`jI%kR>Fzo@<7SAyW z@jcYm_Gmh4i+^NciEq-)i2aU>{0c;T#=roR_&SS9JjTKi=Q((g#V?xZEn}H5KTuue z#_nf1ikrDiGshwv6G0=AG)7_Yu--%$!oL|$_y^sB*dI9fHuEbiF^2+oFC1bXgalX# z#f?-tsqJMJ9^mvg2FNd&DtV2mlIJ-%LE8_~_Hj&2wTu*o9@Mj`e$7m)XfB~!+7KW; zw0#S`dmX*|GZ2ig>Qq|F`8oI=E>7o_;-oS?Q_7wc(p!-i!GfyQmFRX5`5&akJ={URMy+MgAYyQQ1^;K2(Jf$4MLcO zPDR)&t$|P_EolV-29laSWDVny2KgnViLma8?F9YyRY|B1UoWR`)Caf}myPVGlH0Bx zeBnl|N^9snL3*!9dm$zWPn15<|K+p!APfngBu#>cH+SG;e=WJMt`=__0%w_K#2C z_B+luMNz`tGu+1x+&^`!@BHas<8Eoechq&=3%Gy8c?Mk^uWXE)8q7}RvUf`|VQHqC z%+PusiT`t1!_s&o+fF6QYG-z4u2?S4Onddi{1qrmy~9}wK|GQV7C*ZE4{jP@2}EF# zC0LOBUKlp5h}C0VNnyGVfcP&Ce#5~FELsXbY(#4CzWu?qg200nzsrIU$DE2fS}2zD zWhi5LA`d?U=cgy|$6)S&TrTDFa;_|wzf!b|`wQhxSQ z6YXVb4uM`J5mtO>`NzkN6*()wQ7jU%m)q;El4h*K7l#*zo4DcY)gS!SyQFgjHhI)! zdRSHB!>Xx3uhc&wGcO(7%cd#`pqJ~JzPu>~kxucVhEFHVUwEH`cR2XP6}KY1aIIUx znh<`%Zbg`KmKqk=<$t^o3NJKZ8GO7DRK49sPGBo87dYem0wS)oAYmT~lXMQjLmYgO zgU?q<9UDlYb2oEC>@Y*n5Xm&W9(nG9!A7-xQn}Pi3|GZis2|X-17gP&c#Rr+@N@?43aZf)DrpAwQ6Y_+&g)Tc0F7r^?mll zg`2tqFhPniqa=6(h4GWz9}eL*xYt<+b(A*EOu}8OTkc>w68{lOCu*w JV{|86_rL2L9i9LH literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c87410c153d4904228129df5c62f9e3e11b4b3b GIT binary patch literal 4707 zcmb^!e{37o`Q4rE*s-0ZKaxWF>)HYZ(@UE+Z9}_>T%1ed*1mJk=eFq(n@OD5$u-Fw zXK0(&Ruw3kYUt7o>mCRYpiOKNQ?aHo2BVXZn5Ka=jlq!ECQZ{S5SkXL6Mu}B+xNYf zBWW9L%SfVo-|t`Veeb*T4Dlb2C*}C~$%&$!FUjLm<%y}XJTzXCC&#Bs19^D}`0}^n zhN*qKPmLdLJ=j*CStJ=K<#XlyplnU$CkJ!i*de#wBdZgoq76t#2as(C_U=B=-ric@ zqh^xa+kdqIgN_5ccD2^KPgaG-aYD!dxr87@NF$MmbD`20v$Tw*^dyp+qN^z_=FB*i zAk?B{Gn(mCR_&I{;}eRV|9alWa!yVXfe`1rm0(X+k6Q^tcV>k%Lc}>=i6(R<4W+5Q z8WDr@UeLSXR2tjbl|4$@$RyB2N%W8>tI@NB_@2UaeqMOxknr*tnS1q+c82Th+8WxlG*`0A-Ir7Zel|7A3*=ii;bI%6rMM< zI6LkINzs#Hh~V<}2)s2fb!TS^jm1VHhMmVM8)9)o@8*-MPu07VnyGXpfTQM7AV5+W)#Z@cbrpI!2%$cl$6YvDFMy{&k71@%3(4~sHJ&w1 zO?_!-irango&k( zX){pLN1S?(Q_o?3N42m-!O@$*B)G z^+!&OOJIKqo8j_?eNBaCyE0@kjk)0*B5A%qm?_He_4oVt^PTR8ABK>o~}lJ}WY z@*C!qJi%q>>8;>?kT##7O&QvppiN!0c|UF1L7TVGCfK}tA(n3vLi<@CAvFT8@_>#_ zl0@>$bUlI|;7W(Je#E=j%ic6n3QyMeB^1u%chU{0vkh4OjHQ~a(;De!WCkHnq$^=5 z{EU?}Fr`nJOu7QHI?iY8%XA}3|3Wt*_!C!p2b6*d-O_qBlW7^W1;srqNohX^w}F-v zS6L5jVd+TgfE7q3^lXNiMd>y)t7Ag(8VLRAB$tVE%(@$`#lLffzXHo=ba$hz_%2IK z{4Ko$skgYs>*zu|s_9H+nq?)PV(EzE9GqY!h)K{4WGoX#1==6v-uAIF#VuSX%&7pQ zgsWf?$wFtC3cH3FLih)l{f)+u`W**V7FT$L1r&IAVU$G>;&dx&?&s862FNd&0eOiT zkmu=oP|jf~(D0db8dL2_8mg7P7tmnbNTrk7@$??L@h-Z39o^2l=bTe%DCZ~P)3!L4 zSBgV&JH+u#JC)5Aa<`sRx5`5~_|_eii(~vV6?vy_N3}$iv~Q0_iEoZKmm2`$iI47PPVQdOylH!o?iK02`3yI%K!(yUoQiLw{Yx(UMvU-w0NJS_5_1!TPM8N%ZPkx6;*bX#yxk z)$T)CxZYh!?acG&;s;Je8Xg!#lsexNMG3LTc#J)W&pgz5_06{sdt};o)^*)$h)+3B zV2BHqO>t9$>8jlD%1I_H%~X>a8s?e!k7Nx?rO9g+65Q<`4t7>a1A52j zU3=5ALx=%5t6(Cf_F@Q;esey`ZQQ;5x!u##3r-uk)5z!9kO=tstcUJ& cW}l8iH!o`vzyJUM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..adaca5a2ec628bfb0a53b5ab406ca515e06eb9fc GIT binary patch literal 5399 zcmcIoeQZV`JTiHck7`+D%%e{(;mNa1{;~VH7Os0BMKp|=nToup`OG@&n}NS+B3W>@#vR5P3t}S;7~FJgLUhGZECrD zbxU*eDtEgc4GM3cX#)o9T2`-J<<1|Umg)uwAv?)ABrZbgh)k?wnL4j&L`|)|BWP$L zz02@gQ&z?abJ1c^BVuLhS9?YV2DMbrzMd3Lr+=78gjh#2&h}WyXLf``R#qC5YOEuf z+K!Oc4O7!M8H73uUeLQ_W!z28+8V7p9PL08a(ue>AR+2j%;ojoH#SSJr6u>9o9WiZ zh4qq}qKMZLl2Y?8zDiyY{6mB!YXGZ7Y&<0wbdL3&*^fi~feQS=5rxUqJByQdq#URUj#4ttq6%kw&IT!h6v0#dmy4S92s#m* zvOyR6sN-{*o6n8*Uny#ExjSq@Jz6xNV5&Eh zT8aU1zP)3~Vs((-m+BA3Uh(@g>Jj^xrb&IEY9bGvkGWF*EBe6G|i za9@NSrIz22=_vDx({Yu0Yfpyv_jLay3=XI*;P1mXQ!6S2Fq!>jFj$Ed?a1f0@43nX zM9A}wLaVW;E{?!^#r~gZn)kLu>wU}QaXR-cjAs_gIb{Dh94Z?wo{_Ppc zeIQNY(l6;Ii~87I{yLqQp>I1cL`%Ab-`v9mJDa3vv0`x>oS9_O4fWcS&#kKzQ-HV_ z-qT#;)pAIzue7|b?Tvvqw{f;jWvaI>Sx0EC^-N}w*B1`?`F^Vf^pHPjM6|XJKth|M zUg}~l>V%&Iek%MFI1B2%KHc;Mw1{EGBCwbH_+d~LjYmzRi%OLmX4uQBVvVuWU#QcObGJs_KBPtvDH4H1e}qu2qSoW&yt0Og;o0m<8fZcYkzK$RAmKL> zev=7>aos2%!`e{&v97Lo=|Y2I6#awWULxTx%?SAsxB!3}HT4J=pJxjZe3#vZ%u9gAXYiRr;^ zMB|{L6tgvjaknsD%f5gbcd?~NG`0-M7lq0)t|Fgj^8u9q!V4q+R*)Rl(5L(TSata{ z_aYzX(dB9GMLr5D3aD_6!$RW`AsS-K(QH6~_Y1SF=(4>d!iy@KLe|Pwpymd_-GTFp z8u*GLdb>d9prIM)h;Xo)gY-8%Yx*;uF8z@pCwTqnIM0F(qc>kbk8Iok-sqqZ-iO{0 z<=|GKsxvRDY~-Bu3HL2sZv+|z=4Sa3svdq8k;!TAMu zr{ETHLf+-^$RBwi@=HNp;VmOC^OVR0uOT^v$@9iTy5t~RmSQWDY+018>}Ja}wzv~u z)o*3yj`R$Vcm@ZClOxH2w5J*2Rx7i_M0n`|eW_=60=_SHd6H@IX@J-PY?>-h6Gxv8 zXIdSxGPkA@{X2FgP_1Ggh6E_zhpjBNGSW8q#U&XMRNCRx!1Q3LU9z&()`V(}t5#Nl zWm;ndjV|1p&3LzghDS2)SSZ@DDP;Jywzz3Xpj4~-H^<=pY6}`;|F$L+YaF(Fg*CIa z?4B`VO*pM_rwx3s9Ee#HvNbN-8s|$H*gmdy3K|Y;++mwMQ0@c57G_cKQQ@=|=llNW zs~%fZsM~vtzwf^QcYChC86|f=7Vb{nAa~yu?ha3r<*j>Qsp$B~;}!30U@B18+J_iE z0K@ym|6WM&eOR%Oltr*IWFu(a!qQHbmRY(`n6Hb_k607b8mD%{c=eOh#MQbdMdADF zvx0&ZjP~^%$xzC0|!4wyzLki3o9Pd5AF# zp<2)48*(hO*cUN$)6mMUF2N4di0Hv6s}?Vkx+NAi4Y8YlRIvxF0hjW>n1 zEXnXz%2cU>=L)#~WMu_zZCUwXKA*pgk5BONaRIr4%q4u}0jX_V0?!oz{4ST-G;A;W z#cQZ}MWdk*1YL|Xc#$AOe+r#zt&|?oBr6K)*SDf=tKu!7Jpg3sGR}^$L zFk;0BL5T9ce)Fh}?tdY0$Nv%Of?dp$jq zaNDkd%SS-hFj1|W*6>=L6tyg5dx&E%VG2)7wj)W|Nbh6=l=wmz65Xp{NL5rbOW)2L&VPEDwAdhcDQ}r|e(lpt36z44;xEEa^+LgCm&R#e;0%&f9L6wm&%X6GblV!j(&*fbLA+$RKzMr&m4e= ziS$Tv?`V%!`0bzE+f#`qCie!dY!$RR3tIw}s0?Q?kN|&fu(B?RDr%Jj_7O>TeaXt! f$cp-8D+H~glFO-3Wx*_%G`MTN=;8GBgsi6ot&PG#*`6= zE1&iT4DEEE>OIi%NUJMYghVG}k*V0Q5}J;sha)o&D6RVxH8mMez+mrQa9cat+dB5_ zX>s+aLBC-8k2O%Rx1+ti#kG8SQL0W7LZaj)G)_XQiA>CeOtm|t1w)=5pI`In>VW1p z=go`**5U~VHN(u*v?)``lqV585li55#?wS1#C$sA=n3oIkT0N{S?P>aX8 z+`Tr621pZfUb>MBRpmpE=0X%xD+{Y=S_uGJP(L3R`ZsJ1v?aF&hczwC2P?_T>{vT| z--As;2I(}M1n1ylTd}Tz1!u2M&bP=HW7ZsAa`@u ztHthwp1bYZt9F%HmE={dw6;SKtW^hX%qJpWTa^w)`9>=iDoU=U)+~Uc zC*VqyyR3UsT$vkNBCqY%bCLBdZXoD;FHOEMwzOrfCv|?TI$lj^m3c9<&Fu~7-99|M zJbkL(?bi%Xmk%O(Z_rJh%t;+^mBVF+%Ld0}jT_D@Zy%gsp|AnRoR^=IWx=6fNE@Ki z>Womp%_`&y=9KYh+~n2_BVc#};m}|>;cz*N=~Fb32Rx<_zUZ`d$2z32dE5@J5UY72|>szFUm#VQcqj!fFYu<9Q~w*lQl znl}_Mz?J{V?nU!9+k)m50BcsA+=$!;WOHz6pex|_ko%3ad@Cx+hruF;=g$x_(x#vU(4z+sf+pgJj!&*kn8J67(L1H*cAaE#OCY zH){YR{}`gOrg!7`4vg)=kZNF$$lvF0Y9lbbH z+aWVkKNU+)DU-4Bkq0J=b}LkaM@-2YuJ0aKP}?BzDO!M;oC!nYq^@3nXQS)__5&# zE^*aaNuVG2S!rgenUM~|HAKr`n`N~tNLdTuupapvCAyxqbbYl%$K@g&pZouHu$F>^ z6GhuJ3Dd$(=5B{PQ6lfSC2weBCG-?Y=qi!$Sc!xV(Gl`TEGcazJ5^c4xp9;H9Un%g?msj%AyDNF=4=vvBS-iJOcyEH=iCqqR4P8LLRW#34 z^Gnz=3z;2WIGsY8r{uNi_k}b=^#@r6romx+FdPVJ;+V>=|A4mPJQvt5G)K*>-OS1o zm4U(rLy4MMo6~{DPN^)}FzetV*_>~8@wM_lwtSgi(|bdGl=Ty_-hMOdTqS_Y@M&SG zkU*JGVkwj*{#eT>%**BfH<=&Zm?g0Og7kLAkNQS_m)Jg#$2!F3SFgYMtth*aZ@%=J znW;-p#7@m9!NlOu=wxy_IyRg-K7K4R0$I{+Gjl({0*}Q8hZK=AqYNigu^Hv~^muAU zITlHejZ7!7;3n`*oC+dUbT}D1UIIVIVwm-;nW>#PwRXxyk@D24B}u9Em-HaACd88V zm|2%3+vPHc(?$vO4`Msa?B+sHwprmikqfDm&W-EXX z3W>!A?!+u>6jV5jDq^Y{_K)r05) zE&%q_oci!u6$m_t9lnr}RCW?gmoQ#ox`ol$NtmFVq0rCs-!JgrFBXk6d@O#?!ws=> ZUu3V&I}i8fJ@82@x0hT(B^Q^M{|!S<`~Uy| literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..35a1777e6f54c1a2e8fee3817c1ae205e53c9c8e GIT binary patch literal 5446 zcmcgweQaA-6~FI2+p(Q`b-Scl)34X8gUa12ZQ5@Am{?w%=fl+r9AoJk9Ub} zOX?R1?n4YE$^wK`$Y}Ev7e=;w!IbEpYeX>3_&t;Iq0I3#{=EwP#V4wQLi*BW9mZFO zcAwN=CuAu7w7yFeAlA^uy0*J8AU<9~AjXwUM?G7&3QS?&1k9=lMQ~-;RN#z_?wHPA zJIQXC&c+Pw#tDdHw-uo1n*ivY77~Y(SfbYm08IuFiGIi#Wn-gjW~{<&0Lz~p@Yl&Yg63YhbXyG=Fc+BUI50Ui;9z=+}YPU3(8Y+(h=7%a)D>uQ5S zW?~t~Mi0!;=j%ShJqDbnuUuDu63zem2A)b^Tr$@yIFt@%fvRc{AJAGP7x-+LlczcJD4%t3VshqgKHI`c4PA`pi|Cz51X=?`{0*k0 z?M@q5f(e4fj`!DS9-9_Qo;mp#H|InIo5=7XHMgEN;xz(8Ex zttqNusQV$B@K***_=o`${=k3<7nzkX#7UkLm1};UYp!RSWSq&!`<(oelW#Ija*k<| zleDIT);&yXVMW5U?g3i6fi77~>sHg+db%VDAY5+1>ZFvyERNm`ZbOc_qD|6N4W{)P*tilcEx6dyOCa(_ zj6__i=zgCrL;iQ^awOlTE0CP0E0LU~tB^cPWh7swtC1Yz28Y3`6mBt))yu8&+^U;f zeF+pikyt`CSzw);wbBN((6~htw|IbCG}604CjOl+Me-5LU;HB{n1t8Rpk#Pf;!l_d z@fGG)e3>~CUu2HN7cg`@s;82yz|PP$=c!H%Uc4L%i3%pxV6IWF{ z#BC08n*;EIRq4<_^k{7I(u3C(RDGB&kJ!fj8r<(z`WcjM;chl?H}`VQ&vMNMuDKXC zCK%PBKdCVVUSbnKV37##vgHtd#nwUiDJK`0C*gVKSNIB_4KTmLan9t>g*DuKIkyWk zLjJ)*lfSXh$uLGEgYdu*qi$@42H@}9g0)T9rbVXt#q zl=_>N(z7sdpBNt>{}&99j`zO?rxi?m{c4a6Y8Jq(uD{v6X%i|hgbxwikl&-PH=JP~ zFlPG-^f%qf3~s{drTG9}$LV|^M`#mbea0ECx*4pKZl}`j;vUuvTQF4_7fVj@4bf>Q|I2nC8%rkB~c>;7Wv)gkAJKM3|XPxa(tpYpS;dpn- z!amW%8ctl@iET}!Yd`^$Y`#GpD{dJFO;1Iyb%t+xe}sRs;-O!F(x6}Dz30z!w~9u{ zRQMAs3E^dD*actzGTClBn=2Gy*qzUHW{bJJQ?4%9*-q=x-fU-Qhg0?!i@97rZ`;{y z(axcZ?~IT@lP%hAxc%SY2J9Db13bx8b5h&O*Iqb}@6tR_0__Joa`|F0n+06H$BrEB zJDkfG4gto}(RA0LM|-=o+4S`hKL?2MF5U!}?i)nBk0EwN;NnUI;j39J7vZ!s?7m^h zvlsHI5wZX)x!aa*VkzPJdw)Pk<=>7d5i)=(vL8Y+)~=i&oh{GktO|zGc3)Q z^z7WaZ#_2#;B+Oej;XW`+}5k0F6CWS`t6 zMaXMMg8^8W?y3$rSb(77vd1L8YFl>^S;LP2tgZjV&s@p@dM z%cDDkHB&6Nr^+P(x61t>sJcWCs!gyqu>`NIf!jevf(}-2t}qh}Ig25GK0f|mMI|^4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..84483dd34ee183ca0382108ecf52fe919bdf2ddd GIT binary patch literal 3741 zcmb_fYit}>6~1?7-}VMO*qho(opG8#*>tS<5z&Mab}}BvPS&$#cDAWYMYOiZ-fh;q z%i3-URYQraN)v#m8ZX)A#MAwVJ&sZ!dA78Rr-x#9;Pej)LP#~-9XKtNGz&bimK zcD;crYP^~~_nzl>&b{Z%dW8fZ($k7wnXeX0PEDySEmoHnmDx&7S*R@4rX6J#_{tM{ z#xkB9)$~(+pX!fgw@9XIPJYpuQS2pWVJ3g>KBfPNqE&0f5-je&AGZBR4-Xt28tRLU zXxX&z_JKBFaOCLFC;MXSFRs$I3L#{gypAMFNE?xfcgbx_+D6t^N5;~IYHH&~(p&M| z2;`#XvWDfk?E}hUrK*;k$D9(TGrvG6A>OlYWF%+m_E^UB>hvkv>V4gfkD2NOq^6xP zh!olIg5Ig;?&u#<2UW`$&pc?TVGHweZ?WdaX?Uc>SbwI?>%ugL51q z%Ho6|S$lb5lLxD_@DyVqUubU%8wSTVd9W(QTYcqwwh3Un>1w6;RKfqe29li@!fmv0 z?I$LzZ>*g9n)xOnD}|@clM;nUD_3`&z6GQ z!1=UqkL(8;?ESEXQ}Xp&P?~CF?8Cex5T!jn#K;ybB7OtUCz?c{AdUeNN8y?Pb!Q-5 z@gYUG#4Sl!g)n>-ae+IO#(aRB zv=!Tk6!)HY_aya!Z+D zcFuz4(|PxXvXfcc7?)_XhMh^W7P*B*Wo+0TNyD--mYT`g6FEC6$H1U9shN{1=Vy}) zI=B7s_5si$6T$-6_WPlSrT>7Z&`8D_*KFMW3!~~e%QDO@V}((a{Rw0pn@Q?g))1js z3yR+WPtnGVK+d;;^O5Z2`0-3y_2&)pm)TAvUtu3b@&(p`WQ27h2@09SW%O@cMt{y_ z^cqWm3jK!Iy(D%uZa^!-;EXUhBvg8YN;}_?cLez*Hy~@=fL!MW#yzzyn|oXLy%3Lmsq zW?VJQVHE!e81lyY2dJ90HH)i$6P(BOQO(kH+ps23d5-Nuaz=R03UUlRoH8a+a)fmu zIn26|9AdkX9AtZd&_8oy`g?9ge=W!xT$5hscJvhp8PK(13-y1@dXQXUdy#lzmlICL zg|#L~lEjIeAHtW!C*=*0sb-`k-M> z%(AXWSnnw7J;J&Vv#x`zcNfCT3=dDJ;8Oa#=e8|63yVt4nXf$NsKr@j2>CZWcdw27 zedo1(%4{B9(=$r3EZ(rlJAVMx-t_7%k&Ah+E>Y>?)N*Q)U0(j_-R!dGhVoN0@Xq$? z0Z9%7y}Arx=|M>bWj8dHFT)2NeAlb*xRry8&UP0UD;P&+_cr-(y(<6!ny5#&49zyw zZM~EpgQM5dS=NGTaM?ba%h-mv1y45TKZv-_G2X>vUOfy!;~hOfqi+@f7 zUxsN?4^oj~p!dE6LN*zS#cQfE5ZSLEUh3$)#H3_Z9v!!WsbcIC~h04g?s2 zH;kJ=92|7?+&l1qFqbq9*?0w{S zJ@>%l@YB3D@02QK#s8bmmlyM;O4U&cm9leg#(5lVdOg?LqAa=}-kZl#tl&pFDiJ$HC+<_>t?ggoOQ;0S|n@>N_0@HpWo^{+~` z+dfVL=lQ%FZM=T?1tITxu9^1>w^0iy#fPf|`D+6*`OAlc%pI)=tiNr#804+yi*X36 z^)r4ki0jpNQaK<6Lvl0{j_>U{EeGYUC%pQeE!+-d2ZEp$Pkd}_8A-2nAnD- zMR5~~plPlL=2~YbO`5c*Dr%dGxQg147NXFK1|hWyiPA=*N~Km+BGJ+`O@D%L-UQk4PAj9bB`marL& z7;R?28Ff;As3q7DH)Bp}Mx8!9uqS9I_a$vCr+57`_WZcnbV@x``xQiqFhN#u*aMN3rud#?Nn+mlUB>kQfZT?VLW zu2woNTgxq(0`2h}hcdenIo#+fg<%99I6-o7Ck_5lNNOPF~c$}uaqe@)ewF?PE5 z^VMe}*~E5TcKVP|9p1Wgvn3V0jTKtP0Ds0_gqw=pDtqCE!LTw29Idt=Ml;4jGbFUD z3fcvB=z`zmVr2w?!-jPvS}k|1!_jKmvX1qhoO8WBYqYnruafa{=bNc{flxHEp#?YV zV6zd~5H@4M^(|nDY>WqZnJD2EaFxL2hsy_-2QCdxhZ%v8VTGDuLMBv0${rYVWWDY9%<72aHH(P}<`G0Y}4(&rCgG zrm2hx4bPPgcus7ENZzJstj(}cwJ>X_BNj6w1?QGfurCCCv-8DYF^!${`l z4kO%-Y84(@ZAPmZG-5HM6HRjvVYIiK5t(`xs3j5+Zi&n6K5+-&v=2%A8R2xQq4ff& z8XTozR9+Ue))SIRB)=*l{2wGPk?}3k zeo5NPqC5W6ynwJEZMs`_h>@C>Vd=c2aBQ0U~{XDzG z*qa1BB<7EZnn6)>zqtEzVu2}^7$Oi9fo%}n)9$27hm%9Y`e3quU|&+d2aRDTb*F{K zg(Jp7y(a-5DBXJBZu+)B+sG#oHvQoGX2!6k9yG4VmiDiM#@~2@F`Y!NV5>mm9p3;Z91~23IGXikL(@n@guXe{j7{wrAYL z88@-*d<(sgrD{Sk)3D6olx;uUVwo``92aE>gE`sU5w%P?58C}xhGPXL?i4sG+TG4q z;pkD7be#$!z0&VNjZ5W$^n>Xnf~v<@**bV7HsHE&vudHRqH4JpDEaX54Mv-|2xp7; zVoEm)2Te=YryC)qdJPmcU5Ce<`d^}i%@5F{HeHvlN9{e-fHJoK3U#Lw>FwBl7agD? zY`-Q4POO1$v6ddevs1>S0dZ&Kc&HgCgRDyA2>9Wx07nDw9u-E0R{%+VU}9q8nubn2 zPNw3zXoOrCJVsH)~c>NI&| zp|-z-fgO5*GJnU(z!I5+B0tURbM0Oq#`gJvW;XV9BE3xv3UgD8V(&=|ek*_n`wEgd zN8?vWxsXh8pzF~1Q9j%WDgYyYr!aD1Op5TaB0rvwe3%9TBab*49F~vIc~bFx`IyN( z+i20;^L10^z7BJ*k#i4EQ_7RTe_&H4#+YZF@qay*Fb%i~DgSm-ixS(rx|2OSZX^); zep)8I?4)WWlpL;eNAM+C>?v&iKHY=jHQ0pFj}jH%fdRsPHO4B}!GCjHH1KBgH*UJe zLM27J4&y%f94Nul$q2#r$R(XusOHmoZl}^+nDi%56Ai*g-4S&>@Ar({ZIs7~CQtd& zl*y|_&wX<86xfMo!{UK83C~xBM^m{XZwOg(gT6&K=(|IbdKE)VcQP{z!(()g+bFx{ zg4jPL$fb~Hz~0G&;Q5{bdtZ)cKG4NH=KM!t&gL;cEE*s7l#^Ooct8hrsdXiWl0$mW z;6T5=C$S@`*R8162YU2Sco<(;nIrCj4Oi1(?6x==A8=Ek*#-FM}U Zx|8uJTv6dm$n{nxlVeX}qCZSb{0~gsT#^6) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3fe3649e5b6073560652edd25d399f2eb150ca78 GIT binary patch literal 5503 zcmcIneQaA-6~FI2JN`)0C2bnotZQCd+3UQ%uFc2RW^A?NyfkhcJGGzJq%bDeacU=y zUmDv)X+>9stlB28B@K(-9V-lm28aPApp8=4IwAf5rD%Le{DA~WlMsI(F}}nQo5DHw z+Hn#mT>>T1%em*{{_gLbd*69C)5P58^~+v;WHgzIkI8y2JDSVNgZh}9(Q{+5xI74U z`J6WxQa{z@@pkWj_@F(!#1k8fN3-z(SCUkg#8@tL+3QLwH|0|KD6JyaCKIw(Fq|j@+Jx!AvHuI#+7`HOH;#|(&_W7O2E^j zx{PTfZ-rcxNLURS`PwEqtB)$F_$T8jOlKrR1VW6@0d|E_P6^&CW@rKpSW>MxSl4@ z|KON-Vp~J4U{2XiGp^{ZBm~9$oV?Tu{$Y5Mc1yv1A#nrr&6AeRLgM-x0T{nK-ThqP zM}$l#E(VT?LN$!8edI&~g5hH&q>7L?ld&DFG6fRC$BQH^DG5NJV9Q9HN?EvdXlQ77 zco_b&pOiIa#euz!5r$F9g1^jJ&~S`?ATqZdLCfJUB<@fe;{C-mtgEjymsoBGE~#p} zxmfG2a&J?~ySLnX7Xs{E+>PlZrgF#9ks6BW;K3-b+n2sgo?hlaHkK0MM7a|zrNc9) zmIatgvz_J6WwT4k-l5%--Y%wFT~=vW8O~&hoQe^}2b?%8c^yR$%EdGm{YBjh6rv=?5e`MD=n2AMDb-!ArIgTw&4y?7**RpTp)aYfwqr*tK8t$ww3 zFrBDL))2AMcs{?wEDtuZEO%A6NoM!!EI!+C&>XR(LG%nBg%&Ypr#8 zJ({;m38`8n1g+7_dTT|vKdh-eqEH^81zogKs-iZ@4()W4OAUpBAte~mdLx=k+5{7- zT%JI`!t7xeg}z$*;L7$~B@seR*p%C_vpxq%6`jFQk4HoGSzOf{35C?alBQ1u^i6=T zu9T?P6IS_Bl=bLifK*%7!Exelx)p@)AE z{$5Cs`~}s=RIe5cq53NpOMXtbq4qkT@>Op9BCS79H=mP zXDHaC6rwg`ls6a&uqZp-fl*d^4+!Z`v=PN0=}r{yFrV}y-HzI4+2YdET#N!wleeP- zvz12JQc{qMCQL!=@`aF;^Z++Hz-aXaH1((&!h(r^V5s768JzeFF22VW7Qe%2h+o4s zf*l*;KpulY~@-L(}aIA zYQmoxC*d6~e#(j={FoI=xB=9vVC%a)inq%XQjntX6&`Yx-iz8ZJn~7do#tXMhn6{J z9TVgO0J8)lJ?*?S9UR>7tR}mW^k!awc~wlTBuG*|?G%RML7@ZbAQ~k#E${zx%vrw>%hyYwUoWO!FHk z+Ri&LtjCzK8TpD#IvzhefrC^$J_-Z#P;LaJ<@A`IizQ%WO6y8yQJ4qx(KuLbnY2DW zo=9fnFlRiOjU^COoh26c5Zsh%h>^cL6&*P>5XHsIx*ohR0_%Fv_>8>JFG!H6r1~{* zAW+M?=}7~64CtPUW)g$B6p*c%h9{015J0b%h{hLPJ>s0I>sY>+5cQ~xlQ z_skNTdnhHr9eRT_`vo%;vI5(_dc06e6YWH%WR|dNiF@PQ(Buvb_VREy_G`W>Sz{pNq7OrJoq6O8PyIoSy$`P;2KTInz4Bo%vk)WpX206F(+t-ZP-=qqPv&M|Ym@$dcl>7H^@q?i- z<-RyLXf?yoHs#*Z+&ty}baOL$rjA@7WXcVjHRWcboACb{m~Xy>7B{rIsU!LMTSi`V zxxfyP05s+P34OtgOC|pgOU+bRfg~g2pT9NbshYnfuCjC-k11T>QsTk}k7=KPg{|4q91v>9Fv?_xDRx@I+sC0X^PpcBd5U*ffE5wnuL0(2A(I6cEZ((pR3 z^<8NK9PvGNvc;Rm%=XIqUHcwt@9B$G*EQbP;?ufLQs?8;>7h>i#o%wP8Wno{n5Vj) z1$+SmsB;%}K17{8)ET4BBG!_qD~$WAh&Z_lB42O$%4bSbqUCE)XXAa;iHw)5qLrq! zuQ`RUwKC6#OH+50m(;#?Ne^O9Hda#Mmqz~4Ogui2h(`xxeNc|+BO`j+k;$b8Q~G#( z%rO!jOQsz$J(tc-$gyaOfA00MbTTTZlf!x%z=XF}MS)vF0Yzpg0DfDP*DvAiK)AL9 z%%Km$+P9(PV3Zti16e`oWmcWn5Rh`*D@$-8)eYe~7E^tygnN$TW|!b@ly3=lq=Xye zxIJZ?Dm=ROrXIjd+xVtd8#9~4$%Tc54{Z4N-=+bkm@FdG-~TZLhF~;4RmpNTH{9kUUsF7MKkdX9Ffr^+!+VQ^bvV9dO9vQwLXaF r((BLqGgMKb9|@vKkW9AL#i7}WLz_*IZ05$2Ram|dc>#I;Y+>O)Yb-j| literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0e383f7ff0782e2f5b9f2c7a20c209d7b82f74a7 GIT binary patch literal 6545 zcmcIoeN0=|6~FJpU>j%&0Y(UEUa}GzFHQsGqajMe!#skCv5EcM;#BG87!x}f%=l=R zb;;6{MTzRPBPi(IZf&=2no@0*l1!`AW@@5VTeXd3+A4KZC#}^gt=rT;T2-66r4c*l zUOx;E(?P_Hp6@+hzxzAqopH_|{li2c#Q1i`-WK+IbZ@|KOb920V&myd ziP!J$g4EQ#8WHVT6hs${Oj-R_ccVKLZVBmLJ*;bPZyR}bvgjlswm~HHYT`INxts!UIV71+e!S~Em ze>{mPEL$2P|R6tEmjUSV>g*E%cElZy2-j|_Noib6V>MDHPZ#3(v*l_ zcKAw~5}KV(-j=58LSqhf3Yy}5(~TkH^UILglMDh>)tTK+Ovi=BxwvOcH->97i6UdP z+y?07M!$*qdE+b^i+#M#B`#Lx+vUa+rO8qv78&O=H7-xU-|EE;+}*DFTYXy4-Qop} ze{aYomQaW2fXfb7AzU`NWH>EWxIC)vX?F)TJsgDH-ouWIf>0!+Yn`Gn-$M_$XpvM* z9g-7Hh&xInyfnt#?gMg_EWfvr53s7DQHd?|`YkNhSeIp-Wos2!peI1GUC&QPSY zCE#8s5~aOd+Q^4muB>8%_z4RaKVsqHdn{ah ziFu0Og$5c$lprR{0e*V2nIUc zn!gnlFN4D7355OF3i2g%&06{Z+U{+Irts=4HbGaTPmHd?;bD3g4iStG>1vS0mvI*- zcX7}fbdi~-G))zdqzqk!!x-ZxeT@%afwg2$YbzE*I>`4FC6NM(p3>!-ASu=)0&-h&As&Q zRbZ0?t*u>;Kt8sEMy6sUK0Klfj~*HxNsf$;#NEkWMcInRh>=;VqjCLlb-mIXg?H{A zB{{%fmr-}T7Ts!$Cku=-1;&I7x4&5PX`Q%t=#ehXm=Iw#XV@R|?)7V}?v{wI3E)(s zwswS}Pg;E1i9aGlmGPv_IAa3{x|wdF^(Qb5TloxdR(k=prB>}0)D~M2PNUXt)#4*% zldalMQA?~^0$TYqtM(#l|6%2TS;&92`eGLHU#z~Eh5To$7PFAwF*3qBoV;y?LgMo8 zty&~5-!OxIZ8bBluTPSaW;m$(;B~o_7@5_nX#b&}DBj32$n+8+yCIr|Uocspw^oAH5`H)FN}RQtS^3UbwXA&K zGJ_sBC&#QMVHG=S)iOq-RxK-^K1rNdzEr_9Kk%1S!EOO7SK!n9d-e8g=3OSa-PR;n z<~yx4y0F^Y%%FO6;$IBb7+A7r6TD7bU>#SN1~TOyBLcjP$Q;>e2`K3Maj9C60xY-nIH-|44tbYPX>F4^{*$sq~grizStQYt>>& zrQcY!SW@Xts}@TtT{6Cd8|1mnU7nz(!moJCtCi0SySwTO(IUQ&+V+P7y2ek;7mQ4K zo_)I!ai61Z9F7bjU`>9F~DinsZAQb>TDh6@wf&oabW2d0!wccyMxd9l@6WC|^lq!4!)VToI5 zgzYV|PYvl=`ny;%?;!sjlcbodzQpt;%Pm;Al$!~C7y09fMRSZ9kDjfqu7mFqU`XzA>Zm6WgDxYet-AE0#yX`M>z z@DH7z&+8RD*rAqGZa{~p(Sg>jqjfuIT_>%J(K-`rme)xnCt!DoLwOMSdUIEf=0f(* zUxU`I-AL<@@vK!^b0G~2hVZqld44GuTD)Lcgy zWfnnU2mrhw!b^C};P3aTr8ll1KBeG&5?*`?-%AD9BWLodP4@!v&&j7YUq0tqX-g1n zd^w1n<-|_SA_j$CG_l&5LLbc$8(j`!U**J(%p$gwisgvKa>Ty89K;^t#I%JQdwc%I z#`9cg;EfIE#vS6x>FMcP4*b3;_b@>&6q)>)gd!f_~x!0 zOBYpBJ9(5~8hoL2qTA?(R<)oamC@0yRAVb!*RG{nt9Dw|mT8+nAXaT`rP(?6_}NZk z24aZ3cg{UO-#O>r^X|Q7glX+AkKNV3Z6Ibu2kresiGiVny}N(V9`7F-3`gzVAh+*u z`TXt&*XgbeOIFtv2l6!G!Dwe98nFk5qVY)QHy7LMR@wD|!I%L|Ljw%!8dof9T)uos zaf=@C5ZVoWmNl-ZYpkzdQapBWRI2D_jD^|DNNkK%FomV}Br6<2cOd9&Y4y0BUcJrj zNROnGR;a}p3b_60WaTn@qJO|?L?4J6SkAUMlNd|yPFh<+URSWy=S`=iho#c=P|(c|j+P8FW?78c{H*8Xdg;V=_UcRP z<;^pzD<#da87gW@7(?>gV*yjLm9f5J%@jB0i$N7DE;3bfL8YKGh~W<^&bmF^ga1x~ zbn0-?RH^60DKGGsMmBuUdz!J4p6__q%TgI|&(GLgjS%=)87pP%2T>m*E*-)9Sr&5m~x48&JySd1l?`2G}$8PbMO+Sl-rbI zINHh`Zol8>cltuXjiI1JDF=sAhwklg3VFc6;f$+XIq|40RT$$c9*|$b!_E#!mKLAC zO%LL5E=F~Q{C>AL?*Qf!>PkU3Emx>Z54b55$756b5Rcp3X^NtEKr|)L(YD6tahgXn z%8&6XB+u~aNOsa_2aW3aR1_}dUqE8#(}1X#g^7AWn5Z8UIZMJbG&)7(My^L*(niK}rY*DIy%CI?~M} zLhkJEV#MAe@~rScJScv zBCkgBE=X0pHR0ebba3g-%{X1!8=z7)xI2(P3%us?g}lP%&jecUz;=I^9_s>T-WLs2t(vEKt3_Ti;(O67&j2q{UYwY+>Ur5 z=vJ*c)YjIKy*-*0Oy{%EqMVA81yTPda#Q~z;;7in(wD(X{gVi#o&z|g#pmM-QTQsT zEde)v3^@EHIh{l&{HoL!$>}-a6!MbOQ&^DbJ2W{!CVR>CF|bqvaMvYMugFksq0}0Q zECd@VLK{>(~;OGaqj^h6A_2GIb--ohQPpfDi<+}tv zOgKCFU1*V@P+y}^y%cIInRHR8`zTb1zBRv?JEeiZ7L(;21XfL8GYG7lz)HwOAuuMu z0&I*VOTv2+WFQ791goXgpz$4|T;8 zvBXd!YR5&lRHc*if~Z*VkiNj)-3h-WBlg&K`Vok-hj3Q4kJBkzIw>`YC#5Lb@YvYc zXPJ?Tga6>`S~{f&4IFzZIG~XK95`7PQs5LxaEST-C@XE!-|oG3g^u8Ka<ka6gd6d6!Pf5Vswk4v;ZKdIhsfDUz(fTi`1g-^?iGW- zm6Yz85CkP8EjS6!-nL12oNvMeAH!(K4CgY%g}d=|kkt(q%@}2x-g~8j-TG>^Q=*&9 zDP5gDfNQ!ZS>y7%^`P51;cnt-4Z8ihC%{Y44EEklAz#ofI$m2`ps#UH)4s$TfT;gS zr;7NZbV}8rI|Re5HtY@TlB-POi})h6dk^fuN|IG;#yDg1Pq^Zx)bUQ~lqSonY5|2J zsWSS%eq(>`F#Wg#U0&euW{)8IW6W}KCa_?}2NWVR)V@(>Yw9x;xc%P5DoB}c2JVnj zyQIPNS@3S>-b9~{x;vLe5~f#HF`u|t5grEtPl$LX9uJ>pE{?a& ze4&6+{+v!~+l^Q}0k+Ef`GY@#hX}r3ybqB5+xaGMma8r3JwL0To8>CA95fFh%KsW= zReF5|{%GU9dfz9P#BSJgD^)^ixF54+Ig@$QWX=@IT0U*64~?>lOj>)J z^lMit{;!PonXnHQjJjb`!^w9SXgIvW$PJ?5WJ@|Zv$HD_?cUlIhIe$UUK?)itX&%o z*LH%L^ywsh7wEe{-zD^ycXgrJg^$p z0{`u(C^lJA%8F|gR5}Yv7mzeE-nLR?^9OW;&MmhBnAMsG#;#@!*hLc;4XhB&3U2Jf zoWVQ!2w8*Q=M0WdDv=#dCs$3pz&Pzf67GygKn$)f-Glwx>;s)!qxNMhR@(c! z?JiFOe*&?mdBXr~vo@P*Q&jCfU}3YDfDM|gO=~t;Ra+%k8ydhonYJ)Fz=G7K&CW@s O@#(Vt81MYp*na^MdWIkX literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fb21e499ccb8b3721552454b93bc1354cfa4a5e7 GIT binary patch literal 4795 zcmcH+TWlOx_0G&by=!L^*G}WSCT*Z)<8iaWp-Cvz5AcJC;3Ja7qsn7A=Uz{2 zCq^M5*qS--*FERnJ3B+X2jfXOK6YfhWECdlv8nR-R9PMxn~*2RrX~gp@(}RlXW~Xi zJKn3t_qKg9R+n8O8Js8#lnZ&;oGMJ_2adJMvE8ydK2fp&*|iJE*q)s`_O!RR)pe`c zB=>e(n;mGgJ=Rv|yjm3^V}y`FauGq0kO+~8JzI%HO)YCG-HD{8=xR!f+B0?~0JSK& ztd_AWt9Qudv2n#Je70a=IY%amK#2WvCD5JI<7UFp?K$D35Vl{c)F*T$4W+3)8W95v zUeLP$Zes09yAn5Yx~U|(72Pn&tJV5bgm`{|`Mg$qy-&C>Dnx$VCmy)JWwqcv%#uV| zJt3CI`Q|zDwM8CarLfCCy~syhuTvXa#u;{MPu|Q(EHVINz9gp>!+67Q77sOC)UB#B zXEdB`G#d0`3;0Fe$h&Wz{fn!gcTN@;|6d38np6HYLh%A<8Vx{Rp4t17(eP73W{T5B zL!T&smzlF`542zud;)|(5f@8?8(34^MY!ZHLcmqzOHi9~X*UIrQ#<7HP)BrXDVKJ2 zpsYs$hmNBJv|u^5x=KqSq~h8{mXvny3KKtY3kxnw$ckWhUtHt?W<{~R0jD;;oE<~i z?m8d5p|E{!{>Xh0EqqRG&r;@NASp3*Ses2K0fws(V$=xOjr?B@Qa~MB|3umB3R`=~eZvq?S=S6Ts1X zvQe>~2E`ye0eHOdc;NV59gVAIyjRI+W-bHAXPlkCzHEQi)Ka2wtA=SrX-Epwpi~D( zZbMYdWQ>erl+sX6;SpaklnXfWL(W^JQNL~xD1}cOHX-Z?x#%%xnPSbI{J2 zF-~peU>#>Rb1KMyc%3oDe{kv&2XC=J;?G$i@jMG8p5mI%Ku#f85NM;O!vi^pc`oYX zU?&F;a$omzD$FRsVU+MMPQB0K2=B5u!p~S7;bpG!0@kjk)0*A|A%s!RJq$^^Gt<&o2~Isd+Gz6@ z+63L`1Vzs)kc5{_7E-hD72wlxY?4TRo~}n=0ax0q^&?(n-w7EbrSP;pgD70Ub-Dp{ z62S6iO*O-2PlX5`J(px2+v#T1Xa!!lGhr&c^-3C zA7a|cMAk$VX_B@e7-s28PjHX`6)CQ=x$0(#NspmbI+@Edt2Vk7t+sL57LfT;34KA> z$gI1Vb%bm9&|2HC>1Zu}$kGz$=|f0eW-8*JLB(Tqbuo?av8=>zuyn*(4o@%!JQR6y~a4O0v87#s{;{cpLY>ToGja(L_+rW$PcMdMFxWZW$P~hQ( z3X34*!Al@+q|!<4AbJoEa(+7lb{CY0csb$hR zbeYgitp|uW{n$>raT|SjEq(ZL@bCG7U0G8uOu~0_X|$k}hLq8=m&X-itI5)}DzGjQdoTggW5P`MtH{ z+Weh{A%X~ZM=;*2X4JT;We9V*uS(XfTuSjy14xbZ6Mp)rNOwVnkgoJ6yW*KFPs9-a z;Iw*~bKkS)#6S>vzvJ>9i2v69g3o@zXU}`!Z;4vSHj)3b>lUF%Xh z`%O&%rFyliF9$oiGpU{YF1q-YU6BqC<`I3v{*ow4h+W_@K92bL(;Zje{taU1rah+| z$GL_$wO_#yvz1Npj0Q(5{CsdPS2oni1T2=C%+e6g#JewNm>S>RFWQwxHc5kHQ=?^f zlvuFmDXY8Fo(n)Sk_TR1jClo-dU*N5@RB8XA^TDgkS3%;IAYR6^eF^k2E@N{@D59r z8juK0^PT*Y6*Isk72jYPh)3;;dZ1V;7s@csa=rjR8>dF|_~UV4L@rMh3i3c%E*~vf zrNhN?o2(ZGCgk|k#Kgd8tDGtg7E6Z*M%&QeBz+ozRVCpL{NlOHKS}Ov*kSg?GY4=y z#Qoe~rb<@h1pcUZrZ>VJ-){2Yr{S_41d|O1k(x~RstV4x0(&NOMrKh|9_3S2;=?Gn zbA9vX6hu10$65R+_q2)u;R*+TxTPh+J1e#Xr$Km|wM2N%o~xf`ZNEMp2u|1I09>E; zt1h;QGuRtn*SO&7G!l+9E#dYNo~303$2mC0!BmyhVVzcB{%+dCRx$wlAen}%k{2!v zbJr#Z=_*-+5%77>T6I@pM7*~GiIm!dVMKatAyO9)(XlMVrn?M5Pb@m#&KolCDq?6`YrgNj z+>$f}*3l)p`+om=@B7|6PZ95tXk3YokDe&lxd~;wR6J2CD#POw%Bk_v#9&St2EOv8 zXwuXl>eHeJTkdJCPA`)TPUN!1+>m0Ga;Ju}r*|r?`xNcOM8O7R?_MBV_jk1IZ*Om@ z?$Oe5;q8Cgw4qJgo|fv$#Tlt~oDecd<`D!4sU*L04K1NZoGGX5 zhg#H3S~s2Y+BT&)enPc#pU>G?&gdy35#oHa?C;4KQ7e`-oN4K-6mlLb*Tf7p1*K`d zI-&kWFX&xz%GIsyYP%XuW(-S>^^l7*HRlNN`~Y+LY5s)+(xox-uNM!{{*8@mCGRnw zAj)b8u|1XVKS#d0!~?7l;{3VMB`#}kv&Y9z2qZgS7~I4cez92TS8lO>R}q7GDsv^5cGCsk{Vor6Xk{+p(yk7a z^eMn$S5X35uoQQ?O3NXn;@Z@HB!$tJ-NFJZ5)!+3eu)Q|9l>pc+{ah4TT!;J+DFJp zW$uuhJ~FqVfv+;Re>wABkQ7iGmu53cfZ-|xIW+=yBOgh<^4HyZYar_41^^}qc#F)S z$jnXTSdOFt(q$}%$L%|iJf3e{ z`3EB+lIMdm0=SJ6Q>ccKz^%$JliEI93TX91H!`6G?m_q5iH(bl6mB>4_?DHDf-8jx z?h2jFf50`mke_Y1+1O6yYYVl62Ayx0H$|dJqdSI&p4z7w-ErMiyJEmGdeaeF!vZt_ zj~^Z{JRUe**G8h6741_^-O8A7I!5{N>Pru#Ej>Y{)f!eZ!h&*$1>|ZtQNt14G?S*9 z%vh<66_LYW5Q=EVfXeyl2!o?_ZO4r#bVw$IdGK70;wgI(Jo$Q(Wo@jGp4D- zS^WOF&m@$c2if|iBBNSb7ok`X#Ye!C-#x^Uv7gl=Py}cI@tX8NqAM9!-P-}hK_Qk{ z15olmIVE2a)U%k}VLfUkO%y)J>JXIJIs`ek9>E@AaksFzOMoW9+$gA^0E9E?HBQk5 z0sbhMZwTs_0{oB%qR;R^^hq9w7KG*lkW&y=0rpNe;DH?IK_O}tpjiMBm5Qj+Ke%V< z&s-*57SueCBfZGuNYC&%(t|?fB-XB_Qo7L%A*92Cn-qrKg4!*BSYau|De@=olw9FX z$?M!H`HqlHvyXk5HJoJi!>r-6tUkjUAoXt6u#eTZu!cKWeIsk=gm9iS5Z%lB2&ocW z={^ISB#z`TYeJ9$u6$4*Ks?SbeKVO*MZTV16fWXzY!m9J!1AUo&E%cd#I_)F9Rvz> z#Vl29vzkJtkIUriAgdC5WXo@{W(0p_n-RPzlrDpkKW12ZuWoX!qpT6dhj@~5mjJs# zOO9&1jZ~hFybV~sM9j#fxmi8ihGum_=m()U6&Eu44!7<`Yx*`Puf#xt(K86@VdY8+jw^#(JHw5?|k1IJmpmbh*$*N>z+So0^@_6=P)9C z!jpE6L=|D11TNUVFjx*MmpAO=-q19fTc^I zRHJnt$iRem#r3mKql@R9vV3fC2+^mUZ&4~E_FWOpX!WE|fP%O&!iy_-)``t-RgiF-teKc$x)8Cf-Atq@|0wKk1a$@WvY)FO3zk^LU_9 zwhKLf!kP9%BC-cwUX1rHA~o>xh2W*g@Iv-q0)W&b6~vB|!|Xl)^r`@_3-A-3CQCsQ z?2wr6r&mSCrKC^s==46Pto7#$#at0OUm425Z^6>o5dI>}jwr>6Tu#XrmEso)cHvmQ z*rFJ@?1U06O-y9Rb}EU&V7_oHJJy2!j zeUI=-SP)+~|9#xx_uh(eldv;FT0GUKsnI^oR8vF>KC19YJ4B>AXGjf3`XKIaoMwqK zTg(Fub8phy0$dT`7pt~JdVbZGVE0Qu;#(q(I@2|ie9Ny-`U8_SxcS#7t27teEExQa zuWLf^-Xszgc~Zu)kqWGYASXapfX~g406)L{S8sKD_$vCL_v0zJE=9qTDcs&Gz}^`W zM(_Ci#$I#FA*c^F${$N;y%>VBFD^#eDctW^;ePXnaL>N7Lsfj@$l$l&MH)NB|ZrFz=wXGA9g>15U5H?oE z79vt@bdvjR##P( z=hf*UA9=f?O(oi_sw~e-A0C&A`WR#F>=Y6gV?|71=D}o9S=b1LwK}iQ(ENInQD%;s zNhgd&i-e4znJlh!C;Ixec=VoV9Ea1hjY*7|2a?XZh~E?T2K?rjG$a+6`;&!Uzt#*x z(>EAQc4oYwcgai^R#a(KnkNwPhuPur!d;BnzJnckzVk$bbi7w;{z-#;XX%1s$rhIp zFJvsProZgBTu`_Wcqtk^dCy>Dhl;8(r1I=!fh!DAwxPqcxGmJ1qo*iN+ z=~P=*nx*-<-cw&dQM?kYumN)Ha%DQTMBp734lVdmui_o)q0Z@lCqQ`JE=Q5ndHkdw z+UG|b_xXRy*l6d2{svhBucH(5@BCD@BTg~8Q?d31Vj?s7lec8^=ZHH{6&%GCOqdw# zGZrXMX7O;(#jIvAf-GVq(up4)8fqL4>}3I%xqky5=8l=w#;gxrc=II1uN32iYWqY zVpi?x)a2Yj;4G|68Spi!05zH&s%vtxa|Zfk&jk!WH3MRm9E>l^#i1Bd_vXN0N9zM* zU+kJ@kr`Na^;FL)74}fRxV}oKYe1r=SHLw%iS1Z6C571AOpmD^3n#OX?K@PV$i^?G z=yroJj_Uw^P%`k2!Gj8UlPkuYqHp=m1dHVfx2gV&S%#2ts%1I~90rW#L6Tqzt)3x` zBD=T8@-%c(^*)OqC`9_*Yboo#0s?JSBFF}cuuIJvOQ6Y$r1ai7=fb$_kT2x{xS zfcQ6r%48RJ$xe72@Yvu{;Xo-a^XOquy%sdWksurh9&w`BL#?5((IiVVHNt^1p0DI{ zmx71LoH8RA3~!NevC5xE|?2HE{sWj_eKk;F zw%SNjQ|sj23dN{fB`#9IK$B+pYZ3T707|C4oG(P^CcYR+33nqY1_fIvtOtdCA*m=r zMg5Q9)PE57hA>cnOW>>gCNNiD;Y*M_i(wj#R&1w8?@7#tu`#0inh`w)8fvDS>JP~H zyJWnFe+D(~=QktS!IvW0PAUmfso)C`Tp==|E+S&XYp3opuf5nXv(cv1cc zDk`X;hH{QHUMA5?{IdwYNZ z1_7K-l zwudk6<64|Ajc_fKRtGby#e(<&)2KD7>x zD3GEzk2#ia?zNf2HgimcVHRYDr-fUa4K&=J%!~L#-VJ`ER$Jd1HY89g)N30eu*%l^ zjG_0^tXLZ7CVOD{nC=ub9OkgYGWklb z4+xtXMaIVrr!_d*^S3MK#@s;R`Ul%>4gCf-l+`g`_To%1{hncs}3i#Pq~-1VRx@ce z6ISystLYIb7yNEWs%U(J&ZVm98Lh;Q-Xbz8zcF`B|wMslOa3c z+V8^CO!vU-QV$*%8Is>IljU`7iMF^qIxqnL+QPkiu(v%C>+5yX1;5%I)h66s5XQy%1jj^hb&mIl-?JiQ`kIbHBVd339D&Z%?GSzuhnd|n)+o2 zAXQEu04`XmTnvD{0R<_^0I=Uowtha+hQJF%j^&<}6DWKv7d?;Ykz5oPAv>Il3J(vM z$+>O4iP+Y`sFrzlj%@9miFS-^g?~uep+d%BD}mlBaBu@@5bt&7m`jpXo81BXkEFO( jm}7Gk)wa6^0^4N?K4w)}l|MZzD$SlU_6YX+Y&!ivTpcFY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-MISMATCH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-MISMATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8b06e578fa4b50f0874a540375bc8042cb05c12c GIT binary patch literal 4390 zcmb_f4{Q_X760zeah!iNp-I{%0S;QqFgP@UYy}4D#knL7{uAsoG(}@_lS^zk$64$Y zHU`a@MAr7YHH6Xo)^**cYEnCm(Nx<+yN*iJ)K1fcv_G0!ty8B;m8xnQQb)(ezI`G7pPffh##l8|m~+yu_8NN3@O1`)x-YDS zbgwh%*dEx6FCNpQj$PBL<}xEb%Y4MNa69QNlNfWJvOS&gu-^zo!p@X5E>$|;u&V-L zUoUJ;>(ZI*x$XtMOO9RMvc7Yf8en&Ize&z|-iXUrAETwY1O+9RDCW*_{#N8Y=< zp++h}Eq<#QJDEKD<+(6zd8|@P8Db1Ra3xzV%Z(bVB-tSTkYDZr;~Zka3tDI~6roZ? zXeii<^^?i*)T^Lae!O&qU{TZ%lr(u(8qt5f)nY`R~6ZJzA`(M$N&32EtjJXA&xR1Kf^;?nMZnMZ(%e2xUl+ ziwLQ?5eC7|-Yv3QF3h6}f4cCeca{%ZwW^SRX6gJ;e)?!JTSlL)@Kclr7U%Z-bZh~y zWg)L6KfQh_yjA(}0dm9LP`aTN2SK%};MC zVjhHm;#Rdv@M<>WawrSlV8uPTbvIxb)ZgfCn@m=xs&V9e({A$mBjJt!&Lv;B7VZe@ zQD1uiG~uq8S1#pcatVB0F!*Y`ejG)^g)#2Jk@*=MfDeEtcV{FD zQxV|~jOvd^qk6b#By$OE8^KmPyE(rW(4XS5$lqirZp+q4r47R~Xf( z|1GaW@fxp3@jRhZgbou*6WUEEM5u$rI#S+ENES%GCXoCdp?3-W2{ZCXdi#7aeK*9C zU*gMAoZ+{l_ztf{VbYoet=U0nE1^0X!;O=9`0yC@IJ1N8Cuj3@UPcx zt!R5^#wOse0D8o8JRA{@Ugs;2_6oKjs%ybs@Pdk;0a4kd_u=)+xTrH43Hcx*D!$EE zqj;LHLNUqLp!hn!8^z=N9uy-)IY71{vh|a#2ZBjEk=4bUP-w*3Nvy4WB`Q@+DG<`S z3Ms81^IhbmRwOQ8;r9YrzAS9=M_fhp4sS&9w(u^W;&&mkMN#E(68o{X{%$S018w_= zxmUQBqheojh@5?zuS3daqHH3Hm!hu~smjZUQbCkbqR4_GT@@7ReL<1l6BOw$WP6Kj ze-QDc3nHHMQ)0eM%rj(rfo#vyy60%!31WVgn2(CE(jY1ONx7fa>7;BYvwYRcD`XdRLr&2 zv2V+n*_@hAWz&gVe^SLG=xTH9RR*fp9MjgQg9&)s9Z*xl^rDKoV{3t?yyZ-}CRo*k zQaW)w4}bXc&j}ZbU!(nx&Q!&OBu~gLVZT}{#5J^EV>eoLg?P$@1Rorf%A2QI#RKqc z)!>`2W{%xxCDIQMBrux=^BA6nvY5xtl-EfNBu|QWi9+G(*P|)pvOzyjLH8{lv<=Nll_<%7Rth1y`7xHE zg&San5-L`*zY^>4zz2=)QT+$6&zF zqgpV=E06}GVRt-Y=rlN9TyTzY%*sFDJ`@4R&JLSHiCpRt6An(!95P3nRn|=z%wlLA@1(`!AZ_*1Xe&5Ad!&CYi7j0s_HP_}`Dkh=IX89m z^9B)~A@TH0c}L*CeDilE9imkak=WzdWi$0c-!NI`D%yy6XOSLfjZ{l|Hwn0J>*u#> zqi7Xy**^q{UAzH_`iZ2s#W~`ga7uU=jY=rNyfJqlGT#u#gV}KSol`DJR^VMu;TyP@ z&Y|Sz>v3dufPkZ4yLuxo`r3`y{BwN&b7kDA4)Ps5m-#(4LUY%~5@^~0$q2A$Z r?=y4>NL5-#PaNJ%+JpM|cP|}%{f-$AJk2wFL@1@XHD%xWQa=A*F24&( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-MERGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-MERGE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f090eb3e5904087dd38cc1dc1be9754f2448ec2b GIT binary patch literal 5916 zcmcgveQZT5dqO??d%L<5DNoPAbnn5mr=ut3>FYU|+MDon zfZp?9NQ)>BH3dW4R&S`YMe{6sQ;9w4MBEcQnCOe|>A%xcx6TvnO?7nxbNAgK)~yfJ zulM^`+cpQIVIJ*7HI+cjAFWHy`bUv8Cl zRxd6WO`U>(2E2fUM9a7^ar#MN_@j)2MU5kU#Z5bko7NRKRTVWIPUe1R0p&bmaf!*N zM^)heIk@c`>T`lHnEa}`RTAyM4Oi~;WXrX(TF1Kf*0MRuv_|?&wl$W0qsiTlF|~Vq z^77FyYmQ-;=1`N1Aq;4{CH4I1@I~M>2f&56G^e4tH1`TH z4ruP=;@vKQs?zB2tE2lePMWiO{PK|I8m~BltVVhA)68l%hFcW>mO<=X0dF zCPwZlVgba&$kKvFRdYZA6WFx8cCj)54;_0{bFh{@qB-W>GqNk&voZ*R{e=uN1Qa}B zlyOlFWFRQdHjdnX1MiV7a{w46yJAOH%n1z&_=f~+=FGCrE|*(Zz5IB#dK+eQGnWlg zhu-IC>v&~$P>B{v>X-W(bU6fRfpJ`~@`f~ZQ!{SgzNVnMDXc_%jm@A@w?w^?jh0Ada9Q9o z!6m~vQSJ=|W1%KrM2WRUV4n}MgTfqbkH(Z1Nt}y_X&20~H=?h#+bI5*9nphH&!jg~z zJc$ylEZEwrsGA^PiEw{``HLSiNAUwr-T|m3qU=y2Q3bH#-xyZBz_G8D7 zEw??#1Mq%}KcI^d*~E#9WhIugtVEGzC7fgK!i&sZ_$il$xnywZICVp@Q0RTMVmEaw zw4#x^SJH~*)O`A+a)Cg}(W))X%7{vy9JCdb6gk zL0W}UH%mkQ93$i{bPOx%mRJ)Q$(ziPyiPqRo#YE?C37T8xrc)h3G*Vs#wg$n1T&{qP8K>;P$z==&oP{g1)=2^ZOC*swgA(ag zCg5!fG%TH|mB3Y(IN>faLoL?gGzKvE^|kN{Ak$lwB967d7$|{=H|$fUJ0H6y$rva! zKgDbMpJoIV=OzQWc~2|!O#VAGdRAA@j=?QS(}F z&d!#=5 zQEtHK19UZ#?S}5Iuk$wq{DC#_^RHbKSi1(edIoASboo#saR`ykhVDr9!(I?ic625? zJ32e!ov2sfD|yY@0Q*Nd2tI4z5BZITE;ZoJA+IxZiysE@*VmyKFm!V&kxHl1DAj>W z2mB%LGjx$LcK{?A??`gUa_~?0r&Imuenizk;6w_!+rc;4nPmJTLnrY#^R58z_)L!F z5R?^UGjsvHN-(i{Ne#i)NDARTNB@*V{72T*wq z0GU3K-xcl?c_F`K@+^krC6m!i$>dCa$>bNaN+u)OlF1X`n<<(6Xr^THz5J5N>Aal3 zlgs(&N6j~Zg_1v)WB`I>=8}8`TZVH<4$qoP^2JPZ$>(`2hrR)fE zLKbs;%NVMho9NW+3=8Li$zc0QA&-*zaIWT1s z`^dq~M;CX&)h?Oo3W=@&6Q=)rHl5EPJI>fqWJjSW)=b_Q*~Dip+ta)W&Gl(!?g})T z&2r%$vdMcQm&NyUS)4M4yq0RY%v@RK^7`smxttbrrQJ>Jrn>6-N*PvUjw9Pz^kI=;2hM+U z!wpy3$Q~B4s;HL;TVuZ0UEn2_FfZW`@W3DF>FaOQ+CeM)8lGMhk^dDu)EPDISHNa1 zKg>ftod5; zi9ebqXroL)fMghHw&>kW6EI*KVuCFL#KyMp@edgrFxHI$LgPc4gqXCV{ehS?g>&w8 zKKhxp3TmBu?z!jw?zz8n@45HBSyDCR4M<*nY&@%}c}Xu7$4f;it>>kJUdks`DGhq* zv))ixx!Wgu`&#d4vqjdmB=c&bsHUW7NiC!jQ#VO%w@dPPKC6Ln+ig&7J9wb|U`I!* zty_)+INFAN+7BM+IC%4|t+wTd=LM%u2uYGfENTdG5)(1bl$|Y6B@%Ua`vZzQDEBKZ z#;j4c!d%?3h!Qr+Tid0gKJM1kld6W(87mNh5aVlQYj-T@jrv1DV@^0N*p2(j4u8-+ z08^8D6e3zHD2Of?<(jq*_W^e#6poUI=WFgI#5|oNWcM)h=BJtG`h;h4V8Sc zZ03uhx;{|=v)Lybj_p{1vJwL5i`iu3dS8VXR(!RhA@Io^f!5-?%0~a>*zVC7^ z_Aa@=SnF6`xDE+G8yD$yi74Q&mXOn#g`*et#rjJNhc8qEWIaIEZwz@lga0;<0Mp48 z0&324YJEt+J12POMDOg&3k?@d7}z?UdE_af`9cV+1M2`_UmRP8q7HEE6`YS>3g>d@ zh);fYd3-C!cL2Wi+VB_dx;(m>qgw#od~N8P9XIpmR^sN!0I#d*0OtU)JC9n30IG2@ zf4MTpE14}Mu51Lui9m#iMAR=Yw1HTG<9i2&(`=VrCRatonaq>hFSUhdGtR7&hz{d{ z@~#$dDA?u44CeO9!LEQ3c6h-z9N;DRRH0Nb` z(h`YBqDsFgTx<~ywa{8qEv+$OYOHHf!r@TZ9g0NU-arsPf^NfNkh-vt=!dXyutNMd-2pZ6 zP1a9*jW%HIx2(JP3vTiRFXp)A=egx1x18XX$GJ&>7yG&89&XvdEw^$@GcytX#Y}|1 zG85r1%tScLi{CIy;R)uv@LlG-K$-Kx37CErBNqG=`ZxOgP62t`-!0N4ZHx{^ng~KS-K)V@Fbf}o#go>$8 ziKF~1ZN_4b7u~c8Ylm5PQ!6XPH&~nadmPZ~lf#F=M4aZzBK_E@qk}aDlt=_y$nV&| zy1NI=OkO$MMVmhXqCFA~!wzw?K0VOMJYtkY|o#Q9rna=01I=g@WjQk`>oww5m zXF7)uPt0`g1nJ0Q-)GzPE%YC9ddi2#iROU0kk?+%G&X(^|7q)*+kyy5s|M(XizUPk zFQQwAlyGRs?G5$!Lz)iwBLfgL@ZR)i7?htHot!mrKnCgEjRuAOB1@^poQPb(FU}HQ zl{_#Ih}Y2uE0xW(L97MdgcgB%_<(1Pxq3ctWTg^BP8Bl82*Q{$S}OE0s*p5BGbb0g zZaTzB#c8~ZsH__&7YRpRDU}9`tvYB!c*vw&_0tsw+uC7)_BV&uR zdeLfq@c+QgeVe-&FQR6jK;xX6FL7!#;~`wWXUa`pmgZoCtXyT-Ngwb->XQQzT8n0o za0g?dsKT@Io#$n*c4RtE_hGTiDBDvhHIvKfdZAdHLfy7`vdgz*_AOaP&*BEREW##( zy>2r9Xz*H2O&R5?f|@I+@YGD?M@nOA4owQB9D=AxJqI9`G(574 z8PMmlpf^osbeNa;{yeFNL}k9(e7k-&VjXR-g-l^ZhS^bDRY|TQq$daFM5JjWl3?;e zB_pxy4R=meq-oBH_-k4~e_w#uBu8=>8hs+4FQM*7^Q6(YWc4jMcx)UP8%?~X$cQeg zt_DJUoDceSPLg#~NTR1!*|~e3SUZ`cSIdoHURf;S829nhK+I$*uj^VilTlR_iHXgV zoxUZzZ>f$GQ-{QiUK=ml*7M@yV;*q;zC;EBSw3t?Dv2hm(D}?`WPo10W zsqi9){~^mmbQrP>{UpDSedoON(gxuWzRA*ykT%MV(^ID=PnL>>{KUAP8`DNlWHTda zHI+P`K*Qt4Tq6<97OTTv=d5>a-_f|MNou~~BR96()Os^!Dj_~kGQOpHJoBIN%jXtu z!pi7bsA|BRgXD zTy9PhYeZ$hQG`?VTXGC00o$3Ti=0>f>2>BBb;Bm^7XkQKj}(dE5M7Jy1oGSHcDi*;+GE*EY6|$pe*R%EwLsotM zTB!r~%#DyRobb*WfDiFq?#h!68cckt{tdL*2+7p?hRCTrw*t5nRDihRn-^98GvPZ)d(==>K& zMU}qn7sTNHV|^`J4JVN|;zc9L>m{R*j4waJ_Z{JdTt1V9&f&u_>^pj}|LDNL{+3}u zlbN~rN#k1lDtcQ_zR-mnmoJoc(x zZh~06QB6|qa#ufJv~u38v1nv5ocRLb2(iCeZW@k;MLnQ|?ep9juFZa?+#U#fBM_P} zA`w?pMGI=@>~d${fcKzR(*+;c(G*oD&#yI~CB)rk60&!SI`xb63EHh z)$~(JN6^KA*y^R;i5*o{O@x5Bz1X!6PFdN6$UK-t++_yEETHB=L zOd9|0pVKa>>U8r>Zq&layno_WK8^tf#yxRc?%vyR?{`SCx*w>x&$HfUt0l zVYi2j_PEyl4^=$8tp`&Nr;HQkx%B(8S*TjkvzQ3($PaBF$}LU>4) zRIe`pl<xYv9%z(CQ|{sl%P$hntvyriNif z4GB67UDwg77*$m%TvJ&b4tehbuV*7bQP3o2%4tRRWzf`GQznr1L!dQ@N+jmhq%kBs z=WN5~jI$k^JR5zMjSe{7NPN`!C^o#)0}b~VD#E=3iaw&nLOw^II!5Fuk^GAi z$)72ayvK;|FydQ`_$DL1&WJBiL*ybgL~N&L0ka^DMFlxxVs~5;b;yacZPe)%oZdsu z1A7sZKLM|vW*0}lg;L%S#?;9;yz1=2=Ep#F2c;PHpK^9%GtHW9&Q2V)Q9159Yu=?i zj%pVDf_fZ8xT}o#n)4uzUSK24Wj%^KhQz1QO<4+$=zbi2oyj~2RF3j})EIY!S@E!D z8?akYg?B`i1YJ@iFqiz>*@Mlyz-*^XS<*Dhd4oDYzCm@76=zq;*);-UZc$K&oZXK> zw@uSk*j`>b=hL9a^-sIpT{H?szEF%$XAN(`$`|_kS|>4#D5ihaI&#rNw}YDIXTkQL$CYp<{P+TbCaLt6XK)Rn=@I9xq&U`4nDy}={S zg_Xgn&n&DAJ^;NFKYFpJXGP#)@`+R`wFfbEy}U+x2jPH7`mxAm+Xwwu$#33D@7&o* z?DDQ`e119^M`t!|SU9se$Z4Y}D_T^QVCUk0nVaNXupyfvemKnmOg#O&CM8vw^omL- z1SLogXb}JwtzQJ|?0g%91CI3s=>6?Z)?vPjmJ9p53ys1rR@V){*9(z|9P4m;o1BAn zPOqyKXq<<04l#q@Ll7w%h*bp*1|Z@|VMA~zSQStyfCwc8pFs{8*mImhjbU6st#lfL z9MgbkS1h3dnjeZiO&l``nF1FuRhZH}G@Zw(8Pxjp|B@Q#6SWy}K2-tyD{ExOR)Al> zN5q|jw?OUX93O-FOAcN4rRuVU!02kFkunfyPbng0Ve zpTED0aT7G3Fhm-*e?XBCR{HL8`|zJ;mez)FMIFoK_TrwLKP9bcvPA zN46>_{Rqv+oqf=7f3?rI+2w{p+A3v}*fA2837z_aVHOM^q~Kkln6}IALdk@unZajq z$%5xn8lKGsW1(c238P?_>#$nE{X3qYDa{)ubQ|MYc)v(4qpA1SNITY$S=hOEv2nS| z#--K5)c}FHC0WM+8&zpsQZf1%-^an8^P5$%EDU@e$(T5xH`wEKy%qCpst@%w<})IJl1$#N!ohE z8{V*FZ$z;v-_@Wiu%W3J*GS{w+`V}1UibPt%Uj7`O-6G&Rw~#LsON&b$E6`} j(QvT;0&vLNH*Wj~TT|)Y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bdc8b34a4a47c763756ffe71dab13e87082b5adc GIT binary patch literal 3500 zcmb^!U2I#``J8)gCr(oACZVnDs=bR^C@zk0NYpk6#Eo-Z-(cUHUSE?&n$}%xC$@0x z%s-_aT9s05L*mXfO;_&WM@(qaG>L~2Aw&x_50f@+LVKBncpDEqOyUKJXViV)xpwR% zL)`=Ry*}Un&pF?B&ha|&o{y)bcy(p9R4&w{YO}H0Y)DJhnpCegYq^571a#@;xNa!F zO3Lx)#-EA}WO_KcTES`*@{-vs)brNm$EDaANnWj$$^e``4QOn7YGQhFa(o~mXHu@U z2kJ~rPfbowof;pw|IRHMtP(EXA99Ii zGm7EZ`zNGEbv0TpTr89^os~MFggDpj{zO)bo2srk8+45hIj`IMR4qCWsmW&*BJ{Vd zpmpllgR!Y-EE<>LV~}@l4ZcE%@OO;lZt;^jdZ$8#Pv?Y%!=e4uyG#f&_7SoLAUp^m z&4$_a{`4h*KZ$OIMT7vPsk9YP|8U>jZVg2bTaM(6R;reZ!r`q!nc>y z3j;e8Lc<8;#)Nb}EfG!1+H6WOqBAN` zw6mFrFv$EuAG}_8Ja9W)0|@IBz^(W-((bX@TyQF!cx<6bFDI$ntiR zVta`XF~1mq27D-@7=~^{^{hFcH6vmWgoh%swixB~OoUN!KhUVm0?^r$yE}WpO9=B| zKOe>Z{0vO`61tI=O+@cvO!2H?C|b{c!6@?n47|~9`f)j4ZrVxFN;mp$S*byAQaj}29!+S3AO&4pq z!#KD0yrRvc!U@2{w5lOI#$ow9!iNF&q|^+q6U9pK=(Dq2!;grTO`&)4Pws*Im76Aa z+0o-L9s3HGR;@}Nb7X-r7Cy)xc?^Vwj~sibQK&bhoCTlSlStci?4u^q#;(X?(vk&7 zT3#wu+|vkYSB|6D%g%=AYzR|n?_}G+bsku`jIsIL-ruBZj4zbdS~!Y zpx9SDc=89XeV|b+NH4+lsR$P@a5iUEnpW*H%DwGuK+rwKX#apPHxw$>rDnZpmCKi< zT)AM?Bxnq&-mFwEJN8drDm98yqp-4Cs9B9>tfdxke2r~@#rek|1o_Ms5nzG3Y->a!-lK^sdD}lpxo>aT5 zT8UQGv4v_3RF|sN2{a1N4cn8@^(Vo^O{_3PCRxA*rd(^kg&SJoQm)h}RT^ma8dvpU zt-;gfIkx|zm9rY9YNZaI8db38OUetfs`3bZ>B6N_t_tvm*v$9Pi&zicU0Vg9p98mL{glgeORQzNO6*j7gncFh znbN%OHVY>UoWe%Ht$>n($j&5Spu&u^;RRs(!M^kQ`uhE+k#tkU1>K-XWh0NbZSgs! zLg*GTpA|k%(mP3k-i2%99K7zM!hLZL?~L%`9ceGMw3mePq0oa`S%j^p-O5llL&uJ_ zPfIxT9DAgLD%$g^p=)VaWYYf()V9Ef^zO8PCgazfb%NnvU2KSmoN+j`ZTtX xPs^rf6k`y;esghN!8-;$hEoa#bOU}puzzMyGGiKW=^}LJUP9hP7lHft{|nl^7u^5= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAADR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b36fb5c1ccb08e51675fc85394ff564f1eb077ef GIT binary patch literal 3479 zcmb^zTWk~A_1+oVv6Dbd5+1TCOjFp0!4x~BqFJ%si8IENwP(V3ydhO3I%_-FTF1`% z!K*3?Ahp$Y)+Ly-bN8WE)k^)V*r-wqv_yTVUuZuor2h0{KUV6`N>!!)(R1$D#3Wns zvx#TU&iF3;iMocAZMw4nV#S6s>rnB52lo02p?N8>kgsJM9)1j+$*!h{gL)D`5keYm2A%eea1+7!Z z9*RvxW6^{x%d-ag=+4k}LWEB-lKZ6xbM#)73V)ar7WRjBQSW&|aA5}_8-T(OG32}j z$ge&jH+uN`1;o0t>*xE4v;BnHPfYg{NBW8VeZ&WS_-bkE{{skW^!mU!E!}&l0sh6> z>+foRA!M!eBW+Hg5a!z5y$c6=HvEJPLki`*#M9_y{EuG717HF+r2kzCg-W4*Mn4XV zp%5D9NPc2tVM3skBIjZ0TyUdwZWNyJ4ejO)J$U!9MsXErJ?QA8`uGd5{1bh=6goEw z!kX~#?qi4;wI6*Yi3vx0i4B#%8iS8}28S`qd}w1K1SuiDkFKi=ycUnvU*%j(w!3nq zw<0}V*<5|EySTZx&yV$1>F%B{+t#&GupA`9u=8_!e8uWHXV98j6`SV0aRI`h3~Ntf^!Kx?RH5BWy?y zn7ES##1WXnoe{+_bR(+g%=w%d5rZH+9FeufDCcJ*jEcK}M`bnw<9%Z5cn^9BVICZ6 z35WF0VA7Y=jf`v}xq&eya)zO3eTN34xb_=Z8{bSnA!ilWC*$M3o9#iVQMMO>!1e*4 zf8|X2C(fjwxXgFZXGWe+$Og(x0XdRg%*^QNXz$QL{x?|&!OJfAh70z&VAKV}9FTu; zFXVIXg*@h7$j1<_n2{4~1gsE;g%SLeg|D*k+bmpQ;RP0+W8qUQ9An{^U~k8=ikXap zhM_-=;{fo-Ie$xlJlBsQaxX7C*cLv7Q`4tmDbq;aWCsDz|FQ!JzHq6}T<~j``3slo zxFF80y`gCHsBjc0F{5gTzrb<%EaDR2p0t|9?V`Jp&}V1426l%>%capf4FExp07gFL zzR2IW6LOy&JPd`|QM|NbRSTFc8<}9?z3j!8L0EX;*u%|YqbcPr%PQ0-k@q{tK4>Cu z;;K9$Em`oPD@f(4`;9{0)x#*Z>U6N@>35;;Is!BpyaBkF2o(R>gUi-=I4a*NSI-w} z%K<;C%zz322nE3`-!b8$vqcu2G>4{$WXsj+ta7= zoz0*!APs7V#w(%8$vN?lQTKpRQOg1JD)9b z9R2KISbzG6n`LJ}i5YH_{P9`o7>eCf*I- z@jGJMYQNcrB7!V!7uv=45-Oj%LwuFOYkv z^vS=sMNK|?HtORj_D>!)`K4p;X_ku8MYs`_;4TH8=B#SVs$WK-51o$Ju?I>;s{k$H zX7zs+cpRZ}LuxfzR;6-T%2$e3U4qV*8m(&evSWY!V!2t8n#JXnV%=)C>cvf2@QY!< z9u6ecq^T-d>|E?&LDc|-`7=`rkm9Vo$Z3zMW)$=ZOK|vOYg}<`PyG0c4b+lN-oRc> zJ)Hs+v$@?)BDjf3LB%h2E1zuF99yWxKzXTFi=#>S-LgGNU7rLax3RO3IKf6-WXiSo zW4Lw|FXhY4a}k8}J8CV#Oz&+af9hlZ_n(4sl&kA#{hB zuL-|T(R(R@-iO=a96at%g=^s)UJc>Fo6vS{c{__=B}31fZxIfn?tDWR4Ietx{TRYG z&9TRNq@ul{8oHK&{U`ocvHRS6|0{qB%9$g)`k%i9lvg>ElheCh#wal8DI6=Gmdng2 t#t@)>b8%k5n*=?C1p))Q0dEhSrdgECng(302z~Z|A@Ab`|L4h*{{cJz5)uFa literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4059ed9f981504c6dfbdf4709e4aa5beda51cd12 GIT binary patch literal 3485 zcmb^zTWlOx_1+n;?X{im#x_Z{-KK+^mUNp5UDs9!>_@h$!sgU3Uf%xGA2_z&y;tTN+&bhN| zZ)_kxwRh&c&pqedbMD+V5;&VkONr{za;aRXN!4a!x!I5wt2L=!ZPs!HX%YC+w-Sb_ zemkWkP9HlNAF#S4xmv+#6!MbYEY$PP%26qPLQnjD{+m^e0&RIIe` z?V&c~Qnib}wk^MAqo)8r5BV-Fu_#uXz zR{{CiFUXY+e)9riZQYyayNR>igw{<=bra8a6VWc>-7b8!xcmPu1U3A6-zY8KzNZ8J zkG0c3(my6-t@u5CR-h2(+UCLeLmeOegbYCnrJTgm=w$qxPR4!U0`|jy7bB5kq?^%= zgD?_7w}|A%w&uqurAXf^o(pdk&ke&fx}{&eVuUvj>mZ{*8ez{EHb$QY>GzG%V&vQ~ z=<33~&EG?yX#DACl8^9YC!fL6XXEhK9fw00WiGNcAEC4?KtYfmB;-+gb7r2`|M50|Tl98Yva_iVkM>$|^T2=G&$VK>6ehxu_m&%tB@BH=!+DTXiawK8 zO?g@aj(*CD34<&s^uZH=rw4{^e=MQciIi-rcGiTUN${!bwH7Q}%?Na_hHb>ypf~^m zK~c6R6lY6(gaySAOy46h)ie!LHnR3y){co`P#%gY`hv{)R*X?`Kk%r+LNL}7yT^JU zKnUx>VU}<@?}E$Tq+w2Fp9GGK{mRRenPQSe@({c{LA1em{Crv za$2*vvmtf>?Skwe0QxWXD1y73NpJbg4}9ijj3T4VB@`2Nz6fNk;gP8uEJ%QlQT#Np}2S4$d8$R^|9~|YYysYYTXz(;pVn)*umpHDR zMLYs{PkR$6_Dqj4Gs7){Na)!#Mn!(bS0JBo*W?b9o`N#%D_mT5DtXMEg~nL)AUpC5 zC<`BY?qH)(Z%8@Eaca*aYtwU|u#q)(Ng0zC9r*C&rBcQJW+Cs=Q>eD$t&85e03FBQ z+X#^G!5CO_&cl)UYN>KQUtJ19V?Im)T6-E=8vsOzV1{q2u)NzDE`IL+EH3U@4LIxs zJITI;rrAy?R16}0YOgC8avrYGWj57ep-pVthK=la9`)WurEBh?gsCdFD(@Pqv}UWO zlD60&szG0!$r`rGcS{I7un*(72xTz<^keRoeHCoj*Zk&raMR+bwdpH=2Lijix{4e> zFWik)9y-)tpn|x)6Ce>=PV1FcjweG~`BtH|h?XyGklu3srQe2$=RQ_;mR`v_xc_^O z9OyO5j~u?^^eoT>?8!g(L`?qlKzh%i)*pGquGCE=jfbU(Kj=*z+7o42aC{-(USf)`0XT2$9UePojTW_Xt zv6QOR9NTzQV5eV~wU26AK38f#rA`SMj+}xz3WE zVnPkuLcqQb(w6g;c7O34TaItRPP8E$8WyBX^M*eqxHyt*1TX>B1d*Lg0-(aQw;n(_ z?^hhPKyP1v@Hn!ri)aNbHgc4!U}{u|Y!Le;;Z};?P6_l5T#aVo@qZdz5@+$E2oK(h z_Hs*mS*Rb0JZx@7I9%Fu3q3P*_;CA!2;Vi&9qEv&{<3BoI)2PZKVAX?{Q7?qFhM=@ zEHC!ojv!w>lU356^BKdypfBR!^y=Bnv}z6l+HWt+sd%rThp{-|z%b$61LvcKnwD+C SMT^h}&kgbp?&rVn-~SJe>=4@k literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0531da855e43938a3b35688af86410e91f8c592a GIT binary patch literal 3592 zcmb^!O>7%k`Mnw2v6HlMerQ*AX@}767N;(C+Ca%JRVU84o~%8Sj>qc;A(g4^)Ydw7 z@K3iD>XH_;0yOJ3N$Jj`T98RKgcSRRBrn&?6+q6O1u`~0H939e%*pPS=k`(-XFM4i10CH@~HH|9DP`&^zodKI}{qG-m8S5U>_k{fWikcuM=j4iaI|`Kf&<64$j^6~`i)l(pHEVnk6f8;-fgsDmU2!?QfL@^BAi0WB$K5ItAASe$;WNjhJ`I!i#;xO>2%!XjP&+MM=elH=+gEKAR zjQ$>6`VzX4mQ5s|U{3L@VJKS9nZYQ^ehsp*o$}*yMsZ^@KJ8=d0BQ}hg9s>l0Ra7w zGwJU*lWw@oA7jk4JRg@0)R_cwD6^2B(NodxnS=ZjEQH`i7f3ER=z?Jv3~)gH&ZCgO z@hIdI9)-LI>56GN&W6AXd547&{Dg&XvhXqs7g#vQ!f6&h&%!YlJ`QU;no-O|6f6vV zJCDP_ALIO83GyP}gUr3W?ciH@0Eebe!&at{yu*$Fp#Ncq5&XlYK6SybT;|VRYRv^- z<=$RXw0Si63Q%HN)e!$O$K^|ie-Us`O3mPM(J>_S*;#I}9|p;)vo3;j`YqUrNKp6%(D?ub_eTGc zbrnv|*UQzbh1ycUkNPv94**g@Fv}NExVBptgIsZgu!;ZSUkv!!X*R{aj>?zZ&=^+? zAS3yi)}9`db2~|U{Ae=SW5Pyvd>?Wipk&QH95)o%RHD1)B&C{)A*V8I0M%gET+HgG z!WTv8f40e!7$?9Y0O%jNTV{X}%eZ^y@w3`7RD0jmwxQp*R#uP$m$vBUerv@|*$aRQ zB1}H^za0UEw$;AU&bylJLc7>rMALKkiLX*P|EC~v>~O_ex>B%kdG{P7u&XFPNccL^ zOF$E_C;!@$Gx_w{oKKeo1WzjnHfL2^R{aL|94a@YR-=5-6eiY8DnN>}@&czlrkYl;3=qL}0m|&AV|yk~z0^P} z+2niNtEm@~fMPxC?F525&bklR>APUuPPA)|E!1LQxmc^g9^|vLW_w_OPlJbhxbu)W z!-iaB%60Y@JkpBS^W|o_+C;CnxhZs~&#E`e&`oC@-*H_P#|~Vx@>a84t2Q8Dvj%Q` zNjWF0D$moGE?zI^Yk;qdPzSUDo`Y&abtg3dXP=qO!DWRCm?Cpy-V@kOaHJb5+$wB{ zFRNR^v%j}mo%F!51{bWRrn;V7f4hEfm7R6i*0B6A9gqzS6}(Q-L|`ugEzZaWP}|*! z@$LW5s=(1KogM d4;d#3NGqedoqW znoO#Mrsn$ld%l0?eBU`;V!`u?l$NN>EtF@ARjpF5E!1n;Or@$VR_fJ!QJVo@do5u* z#?^5>@#2Z+20AjEB>8GFS1T4Yw_aQ<C7!M&Y1UhBb>}y3D>kOZ<$}?UEW)b9i|nZL~8n3 zgDK%PD`cH}jn0AL_&_|N>tkaMd-qP~4aSr|QY7z}9!&82^PGP$p-k%M;LKl0rHcdvm1o3X{=N?6Zw|b%G74|I1#>`m66SYW1ES+n}~Nd;nzxA|2=@M z-WzTGymbGe1^nMjFMi+pkg=uG8`gxv5#`doJyZKyHo}Z`A%k*WlUcM9{-l*~8%$t7 zw*QtQk?l;M15qSG4kQxEA6%U}s3@Eh>tX3a&uZyHFTVa&>+SE_J@*bnwjh2LIYJ*hNw1Bdb#pq(t~re8rrS z#rSyT1<9pk*CfYU5^Y_wA-%gM+}PkJ$9k)DZ}(^I?NX_y+{2VE?+1;&v4m}nnbaHc zaorkA8BToE1jjm?i7B0;U1`G?#1}vV?usRJH!&V}3^(hbffBLQ2$FcB2<}#tg@?ow%KKC$nx$?SXn%Ot+@vlAnnQuI>Vl>!KS? zerjuzcLW&|0c!07)T+OM$xzaE(z;9JhZI#J>o|tBX>Qil&IXE%pQO|B8JC z{^L{s^uf=3=6gPM*9XJW+DnEtNejLTN==&<;ZI9kKTr6Vfd^7%hIWldh_J`T7IQg{j&RF{~XmSY1^XvFt8oP%L}>r0+m8^ z9~99&;_0JUrmT96u3B-irsZ?FLZLcDya!%mze~J>uj>c3nH;Xff>xgQZ!_Y(ewfs5 zddopr=HI~C1egX`R=j0ZQ6&s;5V%u1=5iM?RbMI3Uo2GS+QXzf>MubkM2*SqR9@Sv zOHMAri8wCepJ7^U4~ro&ES@2~Z+XkUL$#gA^!8vezusaYB-wOVts!83fV!`LpMi% z`{=6I2+il_iX)m#=>IqBH4eO5u9dV}ac-el&DHAF;zj_7jY7pXwX=Sv91ZE3X@e4h2p0#GMb&Er22Xxvkyh!hJk~+WJUb4QGFomX3B2Vk z)A0{yCbN!dXW^*%9oT6mn-#C2R0d#VrcxOs)A+;9f%YAOvDt+byRmit(Rp$mIX{8(p;-vgP>6`NC>0p z#0Axf;vg;+7dDB7X(me!E~?xLs$~fEURwg}+rCuveG`4?HPnUrLUYKsP7eCk#9+x9 zVL~}lk>_qc-&gwpno>zo1g%oVFh&7}mm0vKYQy+}0YoY}!BAVc{dr`{mD6Bd_f3)< zbMu@GicbRER;7*_5Pip?M-!NlbFM`0F!zk|%W-~xT;cEIT{?l!|1FK6;34 z=a#p#{HN@bCW(r1w>C-8wq1t~tzE&mNxep2i!`j4Ovkp;I5{l*0@^9$|JUO=po($s znB17Z9|aXOa0F6c@EN^e@UK%RhO8{zf1Nr$=NTx~U_FHDbDLI$%ygk-t za^}oWW=@06gZJ*xaE%aBAlnE+goKGm+}ln#W-2)|o>DVPT$8g(%w2b#AmkFy=M=+r zh9{+FZ8cu8U$iTj&Psz&Lfki;U@EUAO;y+24Z21L-PfIcsuo{>)Z_~a5rQ2r=$*RG zzQmb$BA%4xIfJ}+XW$kg!WS6GXQj{Q>D?-&_vVGg!;xX?ze)%S_7SoTDEtsZ&I^FN z{}H)`ct>Na-b)m^T3d^~>@*UdpRJi*!HHhta1Zfr5588~{r5Te8oAXsMoV|^Yk>cA z{o)_AF9=yLy{gR%6rx<;Jh*tI>mx|WAY@Q3NIZ*f!rycg?gJOF9lh^TB+^Uv;vkAd z&^1R2mz z69!mF=!3@(j}IDdIF^*nWIAprX5N5?N%D>hD@iu?B(Af+2w*+lYV3@Vv73`Ogi6pW(m1CWh9%s(mT6mLz&n>@@8pjJOS2!Q^F9YV0p zne?8={Lo{*f@@~wg`{kt&LogSxuxu^o{4uS4f0R22!f|QAbH@R2ZlW`zybLOUxoag zuR{LJS0Na#n3a=k2)vNDSrozVS@Z^ruCi#6MHg8#%cAF5G{K@1u(_i-#Z1M)!q9i( zI0F1J&fgUvCMht8+|SF7)H;mHfQF^aAo&VA3V{Bb9YOG&M}6yo_dVu29@X~1kGZ$! z6m0S%OWmY1FyYSxXEdmE2|F>(M;d z3C1G z!_Q&>=%2V(b^&Zy+B*=RKBAmJt&ctB*C3ypYir242q@UxT!T>kfKWk%eiqv?d|B=1 z+Xb#b+r_rsUPgO0N)TH z11JF8=G2txHD3sZn3-OLuMR3;e5?U+u^Kqh4HZ5OY>4lq7yF~{o6z}~LZ1fTNKMUj zU33!NrCf%(fIdru1#}HuDN$cw$AK1SWdo?4f+ToBfC&iq)~(be&`>InAO@>Lz&AP^ zEGhWIfE?!U*oX$IQl)QtR{oR8H{{>w5 B7B&C? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..82e127bce39d126c9b6800cbe59993645ec018f4 GIT binary patch literal 3437 zcmb_eU2Gf25#GHcDN&M5>Zf+Vu+CMnQ-?N5os;(L9;FlaI&H0t&bn@?;XB zNP$0zg*LA2phgieOeCewZGKRoK_7~uh@t{TodniH(LN=wDUg=}?L&Y(6-6HlxHEgC zeUVZaC<6ZM%r`$fGrP09o5X)PnURw9)wN31Zb6wa#EFuO&@Y*PLy-K}VcdJBL&)z67bs7Zf54 z_Pn5X>U4sMnRp_elx2gwb9?wEA;L!(#|PyP7wMfEr5`N{g=l1y`mYj#fT~5>S5mU&>Q9bpAW&;*v)|nTE25v z1Nxtv7hlo-M960OmbNHRh;no1XyI7j#~>jikU^y=@htiYf6`BQ09?Roxc}uy#LIeV z5Je*B6p7;GUSX0_Wbc-*g!jr<#^5)xr@i))9^QFeqm%-thaG)PpLha@K7%09_T#T57vWexm*L9SP(5e8{Kz5jrN9gVk3cMH}?@oiv ztpuPa`e=lsef*6c{9q{`9_Lnh=g3#B;$}Hq2@_$&`9&uhOX}K!iaiid%i2OlG2-(o zAlijoOc-WCVE}%9`1zpGMq^3YOs3<8V&)BKlqB!8KyEo_Dp`RZ)G+lJ8y1H^AjtCl zuEc&453`^cf{r^JQw&2l;(Fd(%9}AU49X)hSzC^CJQrhB90iQZECj7Qy}y-*{Dd$c zHn4;(xdSc(Dc#7*CbGZ7n38$JP&Cg0!6?e!2HC`e^pkQbxo5#sFe_hF;u$r^ zoei)fXy;=`VW9tJkKphJ4$|Md;JYsP6O1A&FC}FIbxs2t$}MN-^-R2fJGzvAYX9zW??U8aR!*`In3FeH6o;2t^hFk3W6=_e7FaaPqUTvO z!J;Q&na6XAnTmsjq2CYS7~m5e-xnEXCu~8;e!c?8y$pwCK*OqLkiE`$trLKTR1J2I zoQW$LB@0CcG5vx)hQr^v7X8#6mqSxx=JYEK^F?S?B~%hwN)>R;`3pV4+DCJ<6Uu z31-4?oX(+^-E2uk%W9lO++M4bE0LIGgBk4>X%$=h!Uj zX8EjC3?d_Y4WW&<1=zv&Ri`l92t|HDqbg{{+Ezn?jVLwSwc0xRfg(dPd@udKZk*1yUZ}LnQp;Xlvl~{c-LM}_3DID1u#N*M zHD#(w4z?Ri38%8E0SR4arWIht1$mkCK2yyq7&?gHRsdzzb~?VPr@q}pE7|1x)vu`+ z(m-Mk+ualnuR7ZSu$V{`4OU$@_Zo!+& zzE-TXDzz3myva@RCDupbA@;mgv|5#VtqF6q>fkAmmJ70~@~8q?`&y+~2YOqCs3B>1 z(5Wfa?Xe)7VrIGkHxMddRBRohVQp}t8!DV&EW{Vhjrhy|H`=br|N6gC;pq$PBup#L z%Z4}81kV&eAh?5m38sLD8h`{TJTEB2)L-hMSTE=mgl?gss|$tehtYQgCF}`-`jIPT z<3H?eEjQWm9z4?<;lwap1TJi$T2_#AJRA}ETAb+An>sbdgvjC0s(qy|AM;j&5{%) z8F3GRxtjNW@6G#~c{Ae{@m`ImqOQ$bP4`uo!`D!s&FBT-TQLGhmx1N`#zbDCS)lwOVmtF#P`ut4n{MoaohZ1ro z+#}lj@bVXu0@Wv5e`g)CeWSxnuhiSuJj=y5`)a>vY6<$3CEH(aVsUJg*SJ z-?4($sbe3Qo{3IJh3w)4KF)?K47J*4x^GK*4fr>(JuSt_?pSBM^QmFYy#Q+0w0UwgX@S)&kY7 zP{;~(i2UUC;v}U4MgF06Ex2u68-s6RTf6g?9^9JJC`y6XgN{C?Pdp3aU+NQ9=-L=4 zYr?~=ze6ZE`_VTNv5@UXJd8&3q3y*`H@-*rXI*9o`0fs{10LQDqM+=3w9$~}c5C{ZW z?lmm7n)nPG6a&zV&qNf%(2b~`H7{q)h!_Ork%+722%GhDFzHL^Mp`zJ{R_qv&l-lJ^_?AzqUr(4Hjr6L&+4gY_v`_je8uOIfAYEHuY4|f4}uWW za-0QFWrKxr_yr69goW2wxWK}TEWE(Nudr~8g-^nYjb{`y5rr9s-m`ub@ClCZaXSju zgbyJeFE1u?AHb35)387(WF2-4hvV!h4&QdUAwJNbagf$s&T-uH{w>7%&S=vhX1`89`5<$ z<4Ly2zxUOJe7URFfLDMy_1GCFRS-TvdWbl4_0B)my0RICr58 zP#UNKFNS@vZWW~)@I15NVF#HmaDgtpuzF3sVUg%nBvzMcI@LfN_9)B7gyGb z)m*(%E$##XCeZ_I-hqUgFjXak2JvDLR1L^?Y|%_Az>0J766ZapnpV&!h~RbsWrm?M z$M(ctc&>&sWfL^pwpUZQ4kpyLJ+rbg%>phFb44~!+T9YgnE*v@@PnRGv*Or7 zWf~kTS1K`d4L^{=nREsmxrTu`%MAko=M?&U3#Qd8Z}15|zPki?7#45lOZC!f-LVH> z%jI+RQf0Nq6~Ux0DKE;Zd#3o(#hayk1svQJI~hWe;Eky!R6Ld1_8=U&W^xg3K2*Y} zxZb^P1`G`9h6>jd3p8AX?jG;8UWd57UgA{%mal#V`lIY`pm@umX$2Uy)70&hU1`7$|RXJjVtvKz&5v9LhF2$x;r99yb0w_k#LB&|x98 zNz9AF$4UAiDbP>g#kv5W`%~f7x&R+MUHRK}KU&%kp?)azw3Zj)6z&`!uw_P0oao%m zaK$?Ic$ZbQAE<_|rD1`I|7GY0AOAmwaREp{xpE5EfqG8@=T)v`<aOUL66MIUk zU5UJXrA^_?sncf)vnTf4e&?Ey?l8vcY@0xmu{4udaMe%e9L;v}CB35M4YjJ}g3Z96 zL@xQ7tyzJeDJcEUM!w~};I$~7^&S%#3*PW2OEshD=%x{D30H(v@VdWOH}XqJO+BkI zadPB^ybFOpHFqjMmoKUd>Vn1Ixt4r|F>xY25q& zJ{HKnGLaP;H*Xohzu0{4HRA)uHXA=R7DWN}o7WF5%VQstjHM8Kvwk>CV3e!y!8q3m zxWHEY_g@)*4Oy&FbpL;xs4{J*3jPLI==YJRoDtBvai|5IT$8|h}6iBrMP{lmGUX)Nf} zQ~9!LEL1crKd*yhoV9b}1W$@_yfHLwCRbFQVmWVVPR&Bo6~nGg*ekZ9RYl=`4ady! zDJjL1(jGMG13AsIOe=5JoTZwRlOBLUDyJGN`H*ktxFGEVPf+g+1GO=R;puyaAr)hc z$7lo&qosv^!F!@)T2<8{@*fmQv1VDCv1`P*K(fC=HocQ@QMI*bc|Jwr-|_JOX!~c z0wGCNwa7CtXIHsQ;8iYP=5mM2buORh@*>-=j3eil)eBk(8;C-nssQg>EJ{BY>$yk;yB zbpVu9)eXY;0iUYqIMphean>mlF9}}Es8zysBoHaxa5T%-!XpeC>`&pU?2qAc>|H){ z5!Hw}dd12;VbBOH&;!e@|~zbi}JxY(7P5 zsN%Vr>1a`@etq|{bL8(={0RbsU`rC1Na#0!MoYw0b$*^_K=3Sjcl4m)LncjF?0cGJ zh8n^Z3H>dB7dOmhbtPmDUDytvAJ#*c!f_W3H;;>Zr$xSJMA9%yh6L`C+cn+T^DT8)$3iX zH~Yv!NYQC62#T@OP`RK1JMdI$KHgwT;WZg9P%qpd+CF`G_#8D}3UP@ixI zaq%TMF)ba#$TNLfoE|!MG0b^Gukg&vBUWfMN^Ok4%#Srtg`EUv!vry3K*$aSM%p~X zAKTHH8|wfG{f(wGtM1#@sRTg$)=9q%Vr3ElQmB>X&Ge#DUOXOc145JTWnudq} zXOX@vr&-`X+;Z2SUv+7g?z`nAe65AI9L4RYjvgHy`8c@)fB%@&jPtr>8dbCfoBS3= zA`yM>JquLS&OI6C|A*tC;@Y{IS~(CgvS0|`q(eJl)T;BEH3f9iSy|HPPQ)dL!v_vb c3%@ZOiZ*H5j)l(xCft48u(znhf4+VD-#_tzPXGV_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9183c5f64852375b1a66eea93b4754fade2032ad GIT binary patch literal 3263 zcmb_eO>7&-6`t88DN&R|T2gG6OysQ~|AY-)NtO!RL7S|orMU{ZEAK9?3OyJbYGrOp zkph1b8%7K_Es`8ItYx|Gj@=Xmdg!4SN64YJ3oAe_DNvw54++vkffneYhX5_mV*vNP zSyGmz2I(OZcjvut-n_q=_h#2g`1{#{l&!C>xmBkj)!VJLc1v2RH>760-6%WK3gFU} ztZpc8wP(u9cUVpBnWi3_L{0(}I4*Ea!_NiKC0Ya0{ zDn#h-YC-MP_x4TBWF|9Nc}_OSd$(e55+eKt9l2k5Fi-E*$QQq#7Z#sM?x*34gy6(J zLbiZ}A5w^P(akGJR7HR{Yn%)tX(Jg(Z<{+~g zs{*2(HPb?jMTI_i!tjKksP?C`vX#we4803t8DfnNeWl=2CH1FJyYn1o1;GiNjDZ3tZ+N3wLy;{dv+L*=R7)}Bg2`ei2FK!DNw<_>n?HXd zk5gcV{*yh2!*97(robAO3xt31gfPZL{Xn=1u2CW&@@?)Vq_&r0ASs&-e5cn$sA$Z0 z$HvzyopK=FS?)NU6c9oxJAmNp@byxG?;enuw`*;?aTyctCEdr%%T>p2NO1b3X1i9q z{QsDOP3X(1IZIVcI5l7r`lG4=3H4#+6=20Vd5QCI;){@6ic`>^L72Vjd!ea`V@+Ho zLp8t{*3`3kATfq_{f!7L=;S(e-xKPSAiYwrPoWO@K@H_}{UofqiDv7LKiqK#9WsBZ;gX81fy9TZd-y80+igsQ#bgc**N&3Hst%QFdzW|h=ock8T zGxdk#h%4txa^dL!7y^KP7i%D*m5Q^95d*T{T3S%>W~SqqK~SI@@D4%mGEvgB4ER)m S27|qAy9<%qXyTJckNyilpxC_t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ae5bfd662b78b01cbdca9bf5aaf83868e3b719e1 GIT binary patch literal 3453 zcmb_eO>7&-6`oyE6!l}1`iUKosk0Gm$7Vu7ROG_3(NrsHDXv29%FCq{p+H@lqD7)2 zDN|%@r>NmLg;BID6IqF~lOS!86h(_%92EuPB(;F{QlLHbmZCir=%If=ffhv$1sbT| znkH0sKQYE4(cZ1MZb`u^V=T`$iS#fQWFF?+Yz8B?ma(G=J*7nrHLXRQ zHK*xEF41g8vz+F@xKgjKM3)QC7nUiV@+y-Ub6#os6Iml}>!#tXOV^}+=jG-;-H6U1 zHFZW~vcHW&=#tayi=BwZqH%S4TD90)xB9L#CjXow`JnjWtaPU$c|V$!=N}0TNL@>e zkzyZXn;7Du5lPz8x8Gyecd#2ZVwQcd+9>RlpWVsK>|{<7;{tC)b}GU)pdr@y=ZXhVmnu^COZhOQgPAJQv(7o*TqFylK4hk{P^x#E?h}-V8eCpgDXL z>TjFF#n8Dy7#s54+rLLxyW;8<@KZy)%qwOcC&OF<_0JFhh#iNsA~TBq$FO{&Ip zO0%L?RYY3X?E5^kHkfj`7#R`TT9E*UJKid@IFs3 z6tb$`Ye;G(&wk$H382~bM>NYat*Du`=dyOh6NGVpL^T$oLY|3m$uj_%r1Ai|cw%=K z_jWPHz0|v3pkDkbAbknbN~<=pKc<-CSu*%`8$7@$h)raC$7+Og%@egv^p18EwVWbHjr6JPnoG`=WHSQAs!+!?2`S0uzw0b z_74Hb{vZGuMeRweaUOsJdy|KWv|REc4>x$Y$irXZVS|U`JUqd}$FP(`8O=^a;bock zrac7tu#oSH=OG}<-$kHZqRPa*gtO3RP~}p@UgD2}NPpsohwb zJIzOJl8szdN0bXWe8Lu$QpNrHknHLaGFx)iJ$U#K&7)3X!>vosy0^8|syXX2G#;PR z>@DY(Z~%V2R9RZAmU~(i7)uC&$h257`K!CF2z<5!&X4bf^#g~G@faCScINW;5Igo+ zey!5B{n2eW5|dA8hY!L+CLM6E^CrRHY#xeRnrds&T@8@ZZOu|s8Qw=`*dJ%IrmeZ_ z{mK269mh=4zd03M`k8>`8k~5-wf@ol)|8s`L)W^F@UCxdZGGzb)+AP*G+z`EquNw` zsyaP<3V5!i5O}0(B%p4GVJiowb-tAc5jgmH=VJmpc#928O7Bm~(w(IK>3`OeK|RQv zW_USQKEIfwh2L|G$Z!+K2w^v+=MWaf#Xi}S82iipiH(ujpG9Kq2iPql5!q=Ts22;$ zC0vGzxJF^h*<7WOt6dTJq0*|-SZ(B%m#--K75F5Gp@R^I(ta2KL>{O^=<_zQ%zMAsp!rRk)ll)k~GS)9iUZm(SHp)yk?c1BNfD&a1jEqVlB+mrMC7#@GsF zD7$eL(-XSeVLdpY?BqN?AY>r+$VJ4#%K$Mg9fuDOydV^4WK!>aUIeCW$Iuc-E}~D5 zA(fais+`Z&V#mwQdYAJmmDYo_L_D4;)xuzxA#(HlRbY2&fKv%>URcwJP74X;awVuI zB%BI@4J@h*J5;R`T?Yj9Yr9~yNb7bSygY?(AEytaXLJg^{57$~+6i{rg?a_%Vv_fG zP|yt*pL&13GZoD)&GSIU1(7=b&-P728RhnRPm2sa z7(*c>d}s{ISu8#2YTAYG5i&V+i`kR%`$_bpEPa6M;VfSF(TkzbEM8m<#l>i^w6s@5 z_My;&dfJ1Nu-((>$Ns~I+aE`K>cKR1})=rZ}+D$l(jQYh^qYY z7`QI&Ojb=j%LfrV~np+ARsAwa~mJ>p~1)NE9+=q>+36HYQ(V?+ECWfZ5S}Z zWQinF17mZ(D*+|Zm>3hu5)BB7iT>aRMvVGH6OI1!2S$GIL;pC>xwmh$45B8B-QGR- ze4lgAJ?Fhq;@YK#ylVD9e>#)Qd9y=<{X>J^z1f_1AUl-nO?vkN-TQ(XF|-#u6m>_- zmbS`R5vMno>={fZyyj4HAklNU+1s|stMup68Q5&x2x!~p_3fM2t!t?aD6x>R_K!Mi zH@CKKZeQC{IdyJ=da{I&UUCgV1tA{dAl8|@$7gCWQw{_}nyf2f&1a2Tc{k)D$77md zPjcQ+(!;x?UcF}F07-j^p$;t z%spN{m!>X%s>A;F=#E$Q&j}e#y{vaiv<7w;=XWheZG7B>R1oEEuGkZLl0n zpd9FN0YG6p*=Oq)!%7z+`;n{LR7AF>QlJFKSG=Yc;;*;yT34eaNwnZ04f1D;bca*o zZ+3F}#Lmf$E^Obpx5I!?Y!u;*S@A19XZx*4ok?Ac;<5vm04_?#nQ`8p+=TwP&&lSy z+oc(I#yvIJ04E3kx7jquKA7Rutc2*;Xopw>e$WdPqPW~S+jB9TF1KM*vE1r^EBBkI zTXY5N%w{LAi*{aB=w^0G4n=FYU;m7zJZTS+s;t-Yi+yTD_Xn}no+fuk{s)0e3 z=^2F6!%@j99CKj4%<*Z45i#UQ+>FLepQ9FJt9^>zEpvLz$6(OZZMb({RXYh`PMlJ! zan!s5mdXMVBdnN+p1?@dxM65|(G+A9d53^ke>ZtmiD|+Wt3q}in}=WyYXBhq#pWaU z7IYji8d)u3U$905pP|pN5>*ug(f0tYjdh2&MMAPYMUnnCTZrJi0OLaUga9LGLWxE- z-H$S9L46kLQyaH0PljLQ!yi9WL-cc;`c`pIm=D%)O3#R1*|d_3`gNjwo_Bh2tVsC z9+b3LSgsc)-5k*0p;pcn@Z-gzx7Z4>N)K~UdQiwD1)!Wr{^S_>O@K>mDJYOh=0)&6 zTlPF#o??wMTe6ZhEnrO>f$SKu^3{XM0sIyi$_=L4k#@|=FEx?2{HU_rySE2E4HDjT zpLnYy?dVDrGpw;P2vJfLhId`swoO1)1vuuSlEWHvHZN_s7*L(lt~P5>nfmih^uVR|5&yv&XpxSi@}m z8a8g@Ff!H-qnV?yeTnamfDDBp0=5vq$s@4FC4Q#TA%Rc{wQ>a}@L`&Dic!#4AOa;Q zD0?tQaH|-G(v4gkOu=1xJZ$C5`+Iu#_v}luMnDAf`}#YJ#*WYdxds;neF- z;0s5Y@+g-S_%ga291V_izz0f!e#0a9w>`wlFUs^B*pukNt2SdyN)R|7li<+GJ43;k zY2_VSC`^|?VC6B>fPo*S^)PW<$cz$#xhnk1uy!7%XtMUwo6w44E&L|XKhXHN#5`~c zc$wkcVTacl09-@_c#X&L5>mLxux{rm(>pU%Ss%-?el&ORuGmjjzU)A@4?dy6E&ZVc z`^Fl#Zw>vbXn%f24)m0rLvK$ak;q}!(vu>G-FMrkqz4O4M7tm>Y)Vw=fD%KS@;gEw zn^t74w(zQ%uIHD!#zvwKao6NWFb(Ma8i{=W?^_5=kT1bhp@YZ;ES~5DWStYe!?yCq zVG1@4Q%l>01&aHGoB|QvC*&m9eQ=+U6GeSOMyC6Ona9MQ?HT~@>}kN*Gc($N?cV>t hUVOHX*0U5LMroDQ(h9Y1Wh-f^1bG7w@}sG#zX8sf^2GoE literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDR-AND-THIRD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDR-AND-THIRD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..366ca367f5a2903ae1b15d94ba9c554dd7849a80 GIT binary patch literal 2609 zcmdT_Uu;ul6#u^4bz3(^?pV{oHntn$f>iEU#}J$edV71vI=Xx3y|)4}hLpCWg+gcB zK@5>hTnrDFVHqs<Hw&R>1ZlF6&B0>F4p2iw+XjXP2m6|aB_rlW z`^P<7hx+@6wr%fgTDme%`8**cNp7O>5yBG>vCmn2&{Pal9FE2mQI*D&pk21DMyN%M z8;WjQtph?SKPl$Y$I>}0=SY!ILhQG!#^Jasn^8@*=jb$DWuLWLqN+F!rAfOK!ZlW+ zV03C*{?IltB+61GqKlFm5zUdP9wAreeWwWFE@4U^Wv-9X#iJzg@hG<^(9uf0+3N=h zS#zp^rb~ndi zgr4fAs?2o2A1Yv-&Q$*&PjR=Z#rZPlGS{}_YXDzj&Xe=pTj;IkaC>37O}E)H=;rcR zGU48-X43LMYcq5!@F)_MGklgOT#J3d>I%x58i^v?#Sx%yOwq+~6cBZn5#)T#$2Gv? zg{KZisx>G}raU6*iW%2oBxGl%>WzJdsf=;-VGmOavSv>+^LcQLRtFVb*K|>fo8xga z=xKrttAdicPjql2$Y7pY2Ok{EW)C5(4u`P|XX-3Osvp+$G08;L!c*nAt}ANIurrFb z6JYb-FHn{Y#XX8Oqgey92Znw5V!)9`Lx{Db*aRmv=*o+VZYZex9GL#$il1Hay(_+g zX8H}q92SjzV__{ORxc6QNIzg}P`uCDP+Vnx6dPUe2^aJ`Ao~bcIICVPTVVytk>xyYFW6)>Q!t~4AqxeCkT4Si9pY@4%93c zoOVTv3v!M|eq)^()-JM+Ue>veb@pM9)3()IN*7B)DU&UvLI};+R*#9$hLh3;VIl#) z1SuhV)V;(JJK2kFyJuw-;n@g^ovt=C8%FKvSqX)ACVZ>zGOnmS2VXXa<-8ErOa;Cq zDzSiV(F2Z;YvV#s;SEcFNA;ZLjRFI=vOqUtzg8kt;1CP6)OZcBfFD%W+g$?=vcQwL z^(Xs0haWgoW&wCdoVUUPXuWICc~}n`!;p~U$+kS`^qp;aoetrSZ!i_hJCQ9EOSV;C zOegb4Q&k5vUnY^&U@b zt2384av+t!hCehk9CXqd8Z6SPi$x97wmeE~jCLWb4O52^AE#|VTQ3^N3BfcL?MrS~ zx@BFFOhtTPdScLLU5Xj38C%%xa^}4i#OTL3@3QqMN-(vRk41}!Og@AhnoXi%!WH|W zt#w`mURqvlagt(k&5=U&$YdgwDj*kWmvbcf!C@Eq*5MlY+SR^rxJK?cTq9SjTq74< zra&P*wftfmkXxjT2lgVR$eD`cMr0D(be}+MGxCPa{0$q(v_ly-@F@H7DiMnRh9!sp fJBBccwy`iF`pU-3E1KT_99vIUI*^OUmzMqlmkRu) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADR-AND-SECOND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADR-AND-SECOND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..88ef70b971b0d96d4d5cb558c874739102f5662f GIT binary patch literal 2726 zcmdT_O>7%g5PolMC(e&sCvp=v?$4@KCFFLiI!#4M53t>C5+}|&?5>*z4#>3~)~yo< z+d--dAq`S5ED3ICyRV@V5(0@sMHC5%P-u|2aOklT91wy72P7ma;J^V0GrNhiZ7SMB zg@o+&y!mF{yqWPgZ>z+2N=oojacm-A$d&lwWMyKq!jBe9e7QJT%H;S_!1?o1Qk7rr z6QzNJ$6}3|%aSSO(v@76*C%u3Z2H^*KK2wZPL%QmSR6eHYOMQ6XLncE!Nwj@OE}RU zy615Bp;&ik=fTF+>sM&7NC?T06%-AG1c`@Om&{;Pmo;7Ji6>-15eMa{Rkch%)FPxb zS+&fTPQFr{5DK}Ma|JACtV}2&)?22(C#6VwJgHdobec9>b7ml}2t!bs*eesxzZM0f zQ_Bp+jtDV95>KdtsGJZqSxPD=$n`6M8A7-ZFr`n8oBecooTNYN=Z4!lTBt97^F=~h zXX=C0SiYse`fhdLP322Ms>Vg7pQ8a-Ew&GbaW_7GLYfI#$!9w38rK5S?)8B65CZ*R zpY2fKV6{|P-;PSot(8{GkqNDwxup~WfBm+g42L>ERnFeIbs>LY@#m%RaH!yi zXbY|_(}w%=cnbS^y)eIV$yn^i9~nx-MlBsHWDD8VrOx#fZZGZISk^jrm({?H^d3uc z+~Rt24gaIALkHU)#HXqe%m)eAU|lwMM3K31B)-rGR8GjMa6Ar((yK)|KWpIX;qk%a zh3RUEN}?|H39788RG1FQ934no$wMoPo@-(pq4^G*ZsI00< zRY<1vp_Cr=G=gt)R8&R;8`q)?#;v96{;3Uk31MEG)g3r;*C0||Pf{HebyTlnCQ?dO zWyN(DFp9Q|U<+*&Es2`!9L1W@d=ktaxC_`;)cRQ%#a>6WIikT9^iN0p;)oxinITQq zdjxG{@OUyItluZFpMJr%q4=D&p}4`?QS5a<-T{L)NWQnDkvopK;fQw~G4F_rEPRfI zi)?#8+t$n4o@DJo2*yFZ<)=NT)D!RbD83JHip=oW$xAy+cPEZ;YZW( zj>z))ap!tRY-%66sn$FP-_S1jd7={$xOF`a$f5N59A(WTi!QqXnms+6!F9x%_s*u* zfZ6P94#8H-taEZfZ404 z8*z>M=pWYG9Pr5-hw)%ru?+e5rR2)G=xMf--fJhOx$SN{Qb@+RZ} literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAR-AND-FIRST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAR-AND-FIRST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..392eac1d36dedaa9f0698bd1b003875141539c4d GIT binary patch literal 3433 zcmb_eU2GIp6ux(6x7~L8PbsC=?N}`0$`H4J)`FU0nbIxW-8wr5m035oHko^x-fh1O^^ZTIFo z=ezfwzd3t$rilCgU|0!e$0jmXDyL+Ng^6N88O`RDe72ZNrj$|OmB)ioLw~Yg3vOSx zDNr4|W+$0TB?_q##Vn@sBZ>WMmB3w!Hj&F%AoTQr8tC2F-MeAKy6QeH78ch2_0Ia< z+XKBD?pRknbMj@{kR^m9$wh=JLK=un>=#N6ep8Q`YF{XDdwndIcljfV+wy@vsPm_9#1&yABq9}P&uN?Rj!XU^{-r0H;F zD@~uf5CM65YWva1$AnC!k3etJ{*R z%ggs!k|kR%%Wb)bSJOJHe&%4>`Cpoh-f%MVEKP}|U5>#j%WJh*H(6`bZSdDfYopE7 z@=lkBqRr#3;Z|DKfdFZ`+#79{r15Gua4L!v$;ZO>9o{b zC+XL9(njajmGXaUDyOtdQd5`Wq+bpBmD}fnIte9y2AaB}jau$$^tm+tzIOc8E$F@a zsBgCSd`|EAoZj=z_a2B&@A)uT>^+~;dz|_2z4t=;Ov~TRm8o?mY{qdxM)0=E9lYiNpC6*sbV`8iSgN>T4K7Fm4!n zoHW{1+{8W+peq5fycNv=~3=Y z+QYp`U4rZsWD_Up7$@moPSOVi*)GVHf~?{sxy)9AGx82=LwJ_mfN+GhPp}&YSj#rH z;!f6j8*r|tARIS;5U4!?zn~QntZNw63DyB1UtvCk%R>7=z%D_WLhBdM0@f(nm9Z_{ zJZn}9y7VVohVUD^3E@|vorXiQq4kR+Z!>(h(wh)NeJBDQtA$lPtPjFNMg9cyBG>{R z;_jt5_bY`2cmzqfMz0DO;v^Lj(#@PCGn^!U2<;aEmzV+`$oo7-a+=3T-W1v?p)t0s zz&giR=U%o-Wxg)fv66MHgD4B8b ziiO;PEZl3@d>g@{}x@PL?g0Dn4Wa@?%j6ZD_)gZU-U39 zmEB<}=G4UQ`q*Z7&-6`t88DeA`|Eva@x8p>9+BbNzXQ?>)gMhmZ~rMWV>YcH2o)I$xLT!n0C zQs9qcp{U`yXb_-VIr@pa;~;@iB)t>?3?o2lC$I`6ha6g9Vk8gBAI#DFHS(Vi=cM@qk-gOaA|WW) zL&zqO@F0aq8Hjt=wx|YD9nE{ie#Y)+w0`C}WVoGJKOF62ZX+$cUN7(b`v3%^HwMOO z`Tj!#=zp!A`-$-pA*8MdV@mVtBKBaTMP1P2;s6n&G>L43JU@cr)yoqvrV2Ab!;x zFGntpg0dk!y!#mhhO>YDg~TrvyYUaB(PCtCK7tW&5BFvT(*qJcpa({_gIfYo@GmCJ ze|Ezh=?@d>Cp!^?+a0Xb2l0F!AIe(!?!M1k^3`&<5+>4!_qux^mNbo79lIr-R*l(= zX2oZ8K#a4wm^91=r2%;T@cN)7_r{W{olM6q&CXlUQc2#Ef!spQ*0K`atznxnHY^W; zKvLDM{>9FdpJ0P>2zv90m}Xg~6*u$t`Me#I!=OA8Q;mf<$8#}8<-LGWm4%?`kMC^y zAwMC^hpm19TlX_C8AzE{R<)7+6k|%}ElV@{juJ*u_A$uDd+8_DoF;rSeh6gPKGf3L zejJ`>UxtCc!$JBp4$?INzJxxr>iMK9SO|a-;SiiBHW~bsX!!oyg zO#nX5@f|^ofi>v?MCa$FMeZJ)mjMIIl|lCB>?s_+&L(h}5?quI^i>Yh>w;^EVINrY zW%L{tn+^gK)Mug8y1jsaj8Y??LEGdLKA-%GPbBY&;SET5z<|wX=ouC|1l%6y>QbRr z!kk!Wl12BkgE0)|cb+@aa+)orSSl0>jbn)Y#&e&t5u3cGPAZE9_>h&9N=(ut%KliFsi{a zU&x!bCe~8hUcPCJR%K7)5b`#B{=h&GX!`G7d>j5P^v^wXU6MOYpZvG|@?NPwNAsh8 zO|c^IEB)U&@A9-6e9k3iicR>|_G}Uu`fZ*Kt-*p^2h}2A^54A;Y30%i()1_@`n=O1 zXTUR{@?b}OU80fhza79ARlgNU#sjWFT=&G3|BgE zJXff-3yo#=RW6NGno7IbE>x?_O0nt`8VYoj(rnji%bxp{mn*HZ(sC{@IgLWA-Eexk zUhP|LV}nU(jW6|Ay0f(QlQ9f{$fjMrS7>>Jpn!z z>-A~01rJD5rg;o}3B$k~=Z1keAq?L@J$LX*p;%~D>b2%IJ~bd5!L87_TCB7xwN}3l zcxu(bcp$CLtGYN10$Jy3rC0}7(EB1?s2E%@^^}h1$(lO|N2;BkhwmIJVSHTg?QSl2 zz@TaAa8j~RODO!W-ygh$5|JGg=tW)}(K&o82np1Xd-#+mBfPzbv!K3M6KEX_^!<)4 zK%qEYmwX{anL1OTVBf*w!_NOU*W!DR_fNMUcv8AB!KPU90+4JhD;kBvxLIil&s#}i zpef003U&yU&v@&8V7DG@IXr*{pF?Ov#uZ$LYn$w2W6yR>@ghRbcUh(K~C!NE4DZF?=+KpCrL#Q8#Jg$pnI3+t>EJ2qZJlOf*!gtei$GWU$d`q`X zBMYlag5QLW2#EhGP6H`v7oNctphJg&^J^FKYUWD<7zKcS1Dh*gtf?pq;_&L-AKWz+TPmW zwHN=iSt`Odw1CvX>8?XMm#94QyhK83+L9GQJRl+Q1_*>IAtWSTfJdIfcV@gl`BB3I zyEDG$=R4<~bM8HN?kXF)l*%fp=HgPVUTG=KZfB|6Q5KplrQPhdN)=@Ra^>}uX=&e{ zR#Pt>KbPE<-=QhBD#cEvtk~U3yIfp;UP*pIQI}e^I*1ou0Gm8}dh+b4Q^$8@)O^~&CS$C`HfR`OEW%{wt~rsot>x`RM$c*qL(OS%chz-5$R$z8 zYnJQmnN&K>r9{2*YNbx;EVdbE%zeiRWeP^h)=k6h^A$ek-f(v7Mq(DJsTVXRg$7>8 zJ9nMY5+fKAMr{qR~Bk=oQ9Dv750Cka&n9 zNfpGM*NLi2L^g;VK<`}HLgaUf)5O$E1poXN;<=rOXLc~RchD=&*Z0qD`3o^NhRAEBgI@H5METD*6CH*Nti#UVYBXAn zdSOPR(UP(;r%0SjoFwvRF1Q?ljH@Dy_B#1+dyNe-CIZw{pQ0woz-2IFS~=AwHbpU|3YMiA zJDOH-(oI4)v7LHK&1?RgViaor6S0qm+hRWrZ;Jyol*xTgolU70v0<>`{CsZ8%qBMb zo8%)RN`veT?600D_Oa)Q{m%2mZew;ir=~<0NOnWSXt*w7T@m|+h<#1O@*<{-*cU}C zDPqrJnfB&2JClHgWp2%N5b_C6{!kF)RC*TC4S7{0PQf7*G^jFJVkg8Q4EzmokcMTS zTl5DyokDsVHPh{RQU@Uj7=1u=JwqjCCsQj#4TYi{;iN$M9V1xC zy%`t^4u?SVf4Y6?>zV|AKXQZw_tA|K!OpfBico@5}PzFu(CIPn#e682I^Q{6~aG zp3KMdH_!j?wm)@m!y5HCn6fn0))EhGx2$e!mYU6rQG#K$E*4B%^Oxk^2TPTty!(Pm z!Cygch~^R*^(8LJDFpZ|S?xlXKJTzt7)r1g2E6;UJZwIca*_$4YD?AbrODu@>` zmpJe5mOnq3+zEpH!Ap+4JBY@K*4j$9-7VJZ%Sx$UDYg{sD5c$PG?oe8cl$#<_@orv zo0PBX?CVr3%4@h8RB@+3h%?1Tx7b=kJ!9)yo*dHADCq{s8;)#GYhdNHI`8oTThD1UCsa6F0TxZy2~3{& zY@4i98>lsB$j~oLgQUFP2D;ZI>id-8VM@Aa40pC@Vd}! zPSRX>pv{=(NqF~dz?|}IK%5rgYlLy6PV-yj+Zib}8w=fbt=Vw(m+@ z=wB_CiXEuio)NqUr`0)C*S+Y2xysdAsR_C-BRdoa*BU*eqxHdz;LNe7=Wyl|fPxck z1SOhqVp=*584+HhId5Vo`+&#(zEMFr;BN@&pE=|EqGk7N{B%(j04Q;k1>2ZZf+~5P z#IU1!U=xz)Et0W4B|L~ z-lc`^<8~nj#NOut8}pzP5SOC2n0;P)f12N&miPy_Le1dyA03yd8N9ejc~_}NrL{*z zgpWp_bRNh!wFl<`_So3bql1qZzCo_DcaznOujrO(*V^R|Us4dV|U NNbJY7V*kE>|G%@z$K?P3 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0318cbdcc29255f2302387f7bcfd994c5eb0d52e GIT binary patch literal 3453 zcmb_eU5p!76~1@I_IiI(dpFwz>?oP8HcfEq5^oYH382h+$MJ0Jnaz02W>rLR?OAN$ z*en0E8!Dm@q=H~@vfgbvw^5#ocxt6I2&riy`vAP5@&-aYfOtXTi5DJ_kit3l+Foau zl9$Tkx##bm^PO|=xpOy&|8g>;B>>22fo_s#JAS%ZQWSTpRIQ|9#Zp#7maU5;Ft0$W3R zbpKC)1t4f5jsO52;K4ag57=0r9Y_ugN%}%j*-r=D$9-@UL*S77 ztbj>*83&BC!}A254x(GWf8c+u>P9(S2@`3;d(%A>OPa=lj?EBHtHwe`v*PnQNQ?`) zm^98tr4ji1;qQZvn~Wt@JDHAKnw__xW0Jh(0=bo(tz{*;*TObqY+N1#g`}#3_Qb}L zpJAhN2wLx%m}Xg~6*u$tQr?cqVKAPEsm4m2%X2YCgg*KzWhH@*}c{3C5pEM|!Sp)|1H|~P`g}WfX=Pt-yz#?bW zBnzR*Erz*}n=IO9(QmWpH(4~tqB@IynMD&UdK?yRe@?SgahPG5gCK`NKF#I3qECW1 z>1}}J=QTyH3+G_Kz&d4+eS;mr;aPSVhcUrXKG1b8q-%mJi6H>qg8BlKRkv4Q4kaM) z8TkylBfsTS$gj99d7m9Q3i<7G*4GNP5`t!-85TXrW24L&5tFlj<=tYII;=SQNuW z7Gm7ZIyVP5GCRhOGY+b}BYPg_To7~8e1W8wceI!pT@YGLXqSdzfp)$h=&W}aRbBUR z($Z90i|^Wf8Qs<_HIrlGXa>u5DR0`ESd$Y^RA~;=KgMQZp#So=eEz^l5b3}6fNl8) zqL2GnB^jw9&GtaktKx2hpAQV6I9TRSu)D|eVhdow1YFvA0&W7a{Yb$52Gkk6UB(nQ zB`V1`Q2CsYiZJjFf*vDsu{>G?8~N|T9-3X?fMn!Oq4P?oC?VOmAE`8z zcC%fmR<9|=s#9nvu-%nryH>k~=9}IoK!@BVZ;L139%z*vy8+39vgZFwiN>VKaM^3xz{SKveI&{t~rfDtKD#RK!8h(02^*3rKfCN%b`O&$tB$Y z@|G*xX$@F;L0#dz&(^aV#sn374#1cp^xK~6n>%@|i8ECjEW57X&@ZHcMD>qhMyHO{ z4|tBau<&$Jm}uAa&8t>|g#sVdesAM$}~@bZ!rg$(|isPXISVu zFND;pe}~%#L2(hro*9`=e#gvN7*^J{DKim5yqB8OL&G#5(67aW=C-s_*8GxkLvyd-OA6E(J!EAOXm5( z-AMMa{V()fai3I*+#&XP>4P+Vn3m{=a93P}zj$=GDlWnwE{^=>xK~=)D?avGdV5AGFl2(j#hEaOV=IDQu~zdU4M2rS@HVJ}(Ips;>5>HaK?V zk2Mu#bVCd_9c~ks?p~@1B>o|7s*0wqD>NYf0NOtgAn^kvBz_?T5`S5Fp7-p=Nj8-q zQ_lB3-(TnFEcrt6FB=%8N$Bs^!gV&x*08Bu92|2@nz_0&%wOV8oC!Ml_+M^~y%HWW8vWFrD=p;RtbV+5SXUjT?%lIxX%7*YDi42NX5B1gS|2GU5GgD`=f_ z?7rBUXe=6^m*yp%ym_bZ6+-ymVkGYu9xieZ%H+R4TjZCIg@!oq6+)0PK*$b&@F0Yg z0s!~FiBOw=f1?{QyAiz`iFYG2h%i%=-Q=Sk^4%`#jl%xFhY-*3D?OuJ;lU#n;D2ph z_@4SJLbeL8s*5}a5pLZ(vOLzY;U}aYqA%t|mO(pN?vI^hd%y(jMfbZ93c=G&>4t$7 z3b9aO&5iFYk8?cyA>~owQgEkmX&8Q^JL;`(X~BCFDu-;qwVLg>;k z2&?>~dw+tEQTu~WBr|@plUZN!lQH=Fj=_G6G8fue4z=?=%HLO(SuH-ee~wW*l>pAk z4o7^#+2y{`X6|n8(_`H(+&lbH`?^&K7K4QEcfM~Qi^Mf`UcsJ-CM9(~CF{{S1t{u5 zCc^j80N(>YFZ?{vcter6WW5YMIEfBIYtQU&?Orb-)PoHz zVuL;clfHzerzHc?hZs{ltLw7bH83cLyq^GXbT|FDl#yMZl(qU0J&aO^=n+`B59z0I z`2{0#KX-|5xx`n|XIff{OFGKL03FP%rsuR&v@>v!ev*c8nQ)im?lR&oz3$S(7V>xI zh5U_qA-`i@$PXc0AuYw}AXp(S8ph={8oo}$RT{Qvc!h>9(C|4Lj?wTW?CnTKHWE?L z(6uLVi~)U=(f0+&a{UoR?qy{M+q?r4)2Cu7Q;6F1I4st#QYu6HPz+AV z#jIw?tp5DK-paCoee`qSllwI@OD}*DO}S^}!CvVYioN4XzXlb(0dYgI`R3(j4q2co zxT$!7#kRrb3q=4qUVye|vgbjlX`+fN-OM+w<{GL$e~0)=`SX7W62}gg%=OE86F2z4 z6oJ#ku_=PSY;FZ`0{Y~i2NEEE*_*%=iv5`-Kv)g!&s;6m3u4_`->|A?y-~GlVx!hD zOQmb*x?ZqEsB=$3Nf?Tpal82qr^RxyJ(nx%mst|LV;@G@t8m9E!0ilF7tM0RtX^Xw zhKjpZb0y2Hig4(~TBBUP=KLQK&~@|(V_8w*ltO13Nf}TtUUpU)#bYRGIAk0$;llvp zbkngt(^JpXP){=0>GrD1LJ~kMLept^aU&)`tC?t49GkDiKxM5`nMOnKY}=lMrkw`W z+j!UznW2L&aK^RrZKu`a*nt<#oLMhc%Fs4^y#lhnq_iw43iIkqTbspP1>lwdQ9(7~ z4yPm(x8njZvy9|2d}L4n{nG2;k8XkyO;=#JxSn2SOsKOrS16WEr-k=FYcp4@7t8en zAy7>5CVSsvZW*}6-rFDN=Bn!g5B0}AFPD)6qkT@&>EKu08p64zDIj8jrZ5YvmH-HJ zEXMKnZvA4cexMA1>#eOf4LDc;4no){9Mk1?kAME`JQT93Q$vjPv|^N$x?C=iY}q z=_35xM}b@EBHm2lhqttY)Z#%ByUB*0HcJE;w(VI0hpYd@iS{QLzNC&l(m`eQ1x44? zG#p3bKL=grbN|yg3m`9FJjpiZ-}u$^$``Xz>QgRZ7zo^#uw{K}Ha#cneE|B6)g>A4 iFWd>79biDy;q8GToqd6A< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADDR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ff17dc278bb14061aa11b323453c54b5a0ded9f2 GIT binary patch literal 3681 zcmb_fU2Gd!6}~h6iSyHqn}n3wt8^MQ5V`9rNfWeWmu@G{IGNO*NyphGoSA(jp#^5C|k55QrxP4?OUI%6IO> zNt&=K58KZ8p1=E@bMC$8%*_V#EyfZ`th~BbT*+6I@_KD;y{0UeD@wJzUdiT_WyqDU z#Y{{4#;h7Ucj|@Fj?^Aawvx}(@;Sv`&sTGq>(42pUsTk!N^u3m^Us4Fotzk(93MZ` z5m!?Q7wxHYPEU@Uo}8FC)$#b=T`5>*jAhvt4eg8tnTI*I>%oYvrR->2PiRp?O==Nm z!>I?5OEjI*ET?{WOsSREqAU5A^DC6jYL!WhId9Yh@w5@Mb<=Q~(oLz$`9b}VZbavi znmVH~Ik1gF=#o?K9G!@cMq|_J^t8q9-R-=^nEY#sHVUsAbFzd8H|`%<7-(Sx80$jx#jGMS*iKgZV=LJbmygjC+uoNQ^79nG%x&28oG4nIBC+lBl6|7&wM3c+HK$z9G5>(54FrZKHkVMJ$D zV>+Q((J37gVBrQR=KAEK-urn! zS@rTGGIv-OlvKa^4omxsxnTcqt>yZ2u5798}4ukG+ z)E#==p~D^8#K8V4oUuO(XY4n^8T&D!_9WF9?*Q?G(qeJKZZg2Hy@zk zpDyEU=Z$eMeu1Wo10{S%eOt+Uv z5G1XUPEZ8WAuw$z+rk+YkY4Z|E+0)}6H*$i*e^va>_ZU*`zb#*goQhlzqXbsZbKZ>WRHat0s7oKh^g-!hWj7$UP* zoTd-R(s>+D4D%S8UfvrBK)%?1(YYgg>K&_@D`=`;Etan2%B$^U2mdroi*1yzIs0q~ zIR^xOl0Ww(UQ_n?+xZ9|C6kNL!H19$KevC1XEB>>8J~5U9tw+OWIVoOEc0FpW{P*W zYzLgTfC}M2%+gd_i|(tFgl=n=nn>|ZGQ)8>pEhkxEV+y_-Mg4$zS36>*Tst z$ScUKEw0CHT}!zo{-)FPL+GDL>$Yl96ZBp#uU;0}$WFbVCSApCtbltQFy=C)^-Sfu zh&5E)h0m_!GZh7gU#YH_O4ptLBNUDkNNr!%4Y)NsU}ViLVEp z)H3258~J>d=Bc(gLKL;(Ryb7NaVn}Yf!C@hTF zD%fFn1OkF?fncAur+~tWZRf*Z`m$THh0Jl(Q{IIq552ApM+#(1&BzvVRJ{*ow;tmk zASF6|O_}~6kS+>R%#~%DiBI*&3}*RaI3M5sP{EB{c<@qN@cG*U?UU4$yA|clJ;W7v4zK&@xa!W)br&yP_6|ym z2Sws~9C}&{@}Pxow;+^!*NGF`pL2YboqBJJ)rRV zC@Qx5lh`U+vw1^Q4R=u?sB0)_j{9%)lj z1NR}&9e3uN*_qkdow?OE^DV`aO02TBURo_wmC9yqeY2*lRI18GWwV+qC@a8~@5f9_ z`(Z+jU6^=&vM1dk$yE#4S|P94n}v;h_WIMxre~%w=fT@MQn11p%duS=x)}>H4|86x2P3wYwxe-9sYMMnrA3@=r{0CN zL^Em4a_Wbslv-syx>|Utuu98W+h7u7&TI9qc*cm?x@kB~>4wzj{G#5k8_@+UO+BwM zxvOP`tV>S4fAUOpG8&sx=PdU2PVW|D^6w~+4~ieoOZUp`KOfD@i^oETB;OUrNYKyN zE=W8?5mE$k_Z6aA^1JJuOtzD;I+<7}Gfj*zHQosyZNqPNpf`&9|2{-KgIj@Nsd(?c z0s8ap3qLphz}R;2C&s)iA;RrDM;1rgHo6$=L-eJbB395^tn^8Hu>qLCR&@RrL!nN# zlZGf15^)ld8{J(Tl_gms`0J4V)Eq8` zE)7E0kni956yeh3kH3^v$z$zR^_IRIgMV%t?4u}iq20xhyV|4j-MK}PiI49-N1*%= zA8+GdZQ&0^w_B1&Tl)AYUoYM{{J(Z{yBI75ncV06vVJTQGmSZ&3L%xG1B5G-N#zM8kM7jCX%V}Fn$IH-Az+fq2T;$``|G*K#~Alg z6)RMhzkx}A+_X}vP3(IVQ!Hayn$giExJ0sFK{oto`7t%Exjwll@E(4cwEFoG4AQ^( zS7`W1fYLn|eAflH$Y)Ajh^ZFoOn@CoFQ;bBWVGF72p{Jm8b;mWm^%!)LytQI#K1li zUf4f`7xszp!rno+o|GEn1F*uHJWRvSc=!iAT;<^c4=?fX1s;BZhbMV>9D6&I*6er` zGc5CA93#Mo1->spvDO_#?h|Q;ZMlIq={G2qNn*G7aSYPue1wL7y4>H~;T;#e?Q*ZW z!%1Q7Ma@{C2`9jLQo2F(aY3s~L>~q1P3mddE-476OP|AL>Gm=K{UkLqNs2)7f(fK; z3x|_TvOfv0?DxVQd!HXaffV%@uB~Uwd0ICg80Fz3{Hbv$%fEK&y|uzdP08i6`RZwc z-gWB7ZGuK$R!5bUEIx60rBrsmPK3RDg4C)`lMcUh5eKm8;X_^Em%5!>vZvm&mc4@Z z_}xnhx%!ep~Sw7HKeA0OnssKk~mZsWTbl<5@>b7R7$u#dJHJpKq8PnE8 zc4hybyiJiKnSTR=^haTpBR-j{?g4mzkMbmGz2_?b7;)Y}mCDd=TyEq@lmG_S2i)t_ zU@=C^S}R)-yZIznVYymmqWM;nnQg<$RVl?LcF|0g*&w zfLEt3ErDm4&;E5FZ1(p(VV@$czlyM#$XoquS4*{`QY);j7pmFXX0@=PY;J63S68o- z=UTC#Ah&_I9=CNZ?bhdQr|EO*-piG>%kCQ0bA$ z+-f0PRd9xtjm>iTy7Pay=a(pj=(4(jxTufZQL!H8+;=o7A|n>aa6-Iptt%2}sLm$$;TT&Y$n*ADpSuW(u(&K&#+ z@}~IR`Xc*RVVh3w7dIKFEC(Q`1PV0r%BWOvN36Ie`0UY Kk@@VwgZ}~?3l+-% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b6a8c077885d40106f382307083feab8cf1dbfea GIT binary patch literal 3444 zcmb_eO>7&-6`ooC=s%(*)vjs6-l}#hu%RK!QjsdC>ov8sRwkG7av52N!k{V2WJQqz zMa349rnb{xfMFujRdyN}33@1sq6GvO1?sr4P~_Airv~VuJ@`bEEzFU z4fhamx%1xl-n_q=H#=L*cR7|&W0lplVkuu$D;u@7jheb#sjBOhjcP8hE(2FziKQ(4 z+p}8i;^`Noz3C1~uA0x*@=L0{kzZfRZa%L@zou$y)nW<63on3;PESotPfnihjce(I zYwekH&Pm^DyU5JrK6_v>k~X2|Z$JNj>arIrVPj z63L`>%c&olP-~U7NGbnvzC`J)t~1V<^H#k(o-t##kuseozsdWZH|qn28JS0F+6A2{ z-7PC*ojdiO=u{*ciOpyhySLqUn=$19#qoaO;T(TZW*`4*389-#M5EHJ%@mCO$?%sC-?Vpua7a| zrS4U!AAbdt{&>ntYBsUIpqOGA%hJt`(?M{O3CKqF(vN9r-SsJCXHUUWPg1+6M-oO_ z8uN<7G>?lT82G=%=V|!01o@5&zUP9Q6h%^-k7*X^jDa0YFDB2Y5|Q?KL-?pTMnlLQ z4!c9IJ9No`{au=8f0O3fN76id7m<6CT1*ULI%|p$4L=g0S4F5QLU|FoEJ7DW=&T4u zMQ9AmJe=0;cmy-7)F%NP2RKxgY?3FFU_;x2=x?7HITotmMt$){$g-cgpP=@F(@lP zbLs=N{CZ8zEoG}`2>Gc~KVcIx`kFSXE@$zvTT+W<_d7+{Yo|zU#c6u*h+(`G=dR+Z z_pWBI;ecEzmai>UR(qa`V;>_1#KdRh;we|1eRIja{VDrR#p8D^N=l52C@IZ3O$85R z#GT!nqM%osc(oOyk|U*2siYuo1aMvqwl(^lcgWbC`tg{hYqlQQ*A)rF)-5fO7Ja0K zjd3ZHvUPVsKkh8z1ibM7h%gNgrBN}1DWawO%T8TNg8$sreHDS-L=RI!jjN3uiO$Jj zIbhUU;fjZ{0@KKnhAV6=HS&#R(jMPt{?gL9KL?moKUT`FUR}!4!W}p+ut&H&F5u0n z^UL5F=Cgkuh?YI>jCP!q{wkwovRL&mTrbuNYAwIImak@O8`b=}y0N~IEtNLOajlS7 zQP8fq5w{IJ?RM(hP7_H`I!^sCX_nXesJa*CiWV7%AVE1dS%1y`5U=ntyr!d@GB^#Tk?Hd`jX`9^8MYX*}m=yp7y>~CJBms zUbDpDw`9Gj7#M8#xFqTi#bgn zIcj>T8GZh)?w)Bn{JdW!^sWaq3B>U8QVSQj;5M_*DZicN4`vnqJ}y6V_`8pR+u$7C z2=S*Y(LuC$5Rx~@;ImrXgOje+;^?#flP6o>J$$~L`f!`o&6f--Wzsi`b)Thg2wm%6 z1fl4cz9JXwPxRgP>6bEE;&U!A1b}~?ddhERlIL}+4`jE!IIq*~fuE$}!9dEw+lxaq XO`2)j!gY%APoFUCC$uLXKY8+BXgmXZ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..dc54729efb986863a349dcd939cb08b3ac067930 GIT binary patch literal 3618 zcmb^!TWs6b^VtvNC_N0{frX(-c%JZ;!>L~ydBWH$2hKEmfrsQ14 z)%H-C(<7(Oj3hv2^UXCHt`b5DWCNEFAz>mCXT=W3OeJT=Q))(uYjReJIm?b6gjnMF zoMJe3?~v4}F2?7Jmy7cl&O)6~LY!CZU@EUAO;y*NReFPVJGbq9surJw(ByH22*H*X z)J`3{D{&^Ch$qL!WZ58Zu65lcMEC$bxnFvJg5Imp;0F`J)WJwE_0JK4gnfi;z!rYE zLre?%_HW2bZQ$L@?Z8|+aG@Pg+kugG;6yucunl;lZGWS*`|o{lt?y>X04?2npuzsr z^z!N}zSsy4xF7^SlCOlaG zD|m*|AATtT2oW!UuJV_o@QDi-m*^ zc>M7Apw)U~N!d)MXABM~RQHkk|t~ z_ee}J4Bd$9d2=#v#>6l%cgJLHI?nOA7^7k@;Hb=cpqYnvH*=?-5az=c{wlWQI;ae! zbR#R92>uFvO6Cni(b`4?qe%NP&<3`{Ps%yPwaIvMi)=q~5q1C;`YC%1m%AKEf9)dQ za*%g|$_DZr2e2nMogLLPac{&Revn0QdCXn<_(J~46_S5&h2&$dko*EX6SH!X z^?(5R35(*g>@F{|=oJ?I4vT)9MJHJ_$)dw7dK`|jKc|?fI7k`#mf1sqAK>_1{`7-J zVFeuZ^DHCuBN&MR4KtTP@H#sT3;l#0!sTNZ`p8{gb&@U9>7Q7#8ap zWYGic$O&K;e(u=ajbgna6=r5Et9BZ3?>hEj6LEvrOu%ODY$^k7(W)F=%X!vtv8eu7cWNh{f60k#n4Lf?1A5%s2jrY_r^~cv5k$(sLFmDEatKN$?S3@O)`e_P5$E%|skkTnpPgwQ0%PYM3If33wtDpaCIUQER#Id9E*21M33#(wy;1EEJ4-Qmp(+l7h z`bGY|CouB&oq?S~woiCqnu01;H7L&8wrHjm0L3wRn!`R*%_?XJNHE@knbjTJH+1S)9i?QGm$Y9~$J4OI zxL)Uu^K7r!zLc(?cJXT%3Z9tQOf{=66T9x%LNx&jXRFmA=MGjGiVU+JcXP&-z2&S1 zfU{8rdLS)N$*Rij2C~JgKAy?)Q z>-nB%YO8YHvfO^Zz*!T}erWHlIwr;LJP!FuNGGLBRxR;0Ac%j13_^(r&K*2G5pu>8 zB96)iY`#cixN(OEL*Xo344fBWxcQe|*O3p7#Pi)#0*BKQf!!>60@ZO0 zP{JsDYZ-os#gn5jNtzZm+$C-YJPx>uyq0CWs*Z7kzh_~-{=pS#F~Y=~_Kdd*i%zkg zd`sb~NIhM^#pOQ&l7NZ@k;OBx1Ug{QxJgGhsUZ6NfsSD4TZp|Q_{z*0{u2iTmS$7 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDADR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDADR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c94be82ed049709c8af85d4bfc38a05b7d1ffb12 GIT binary patch literal 3688 zcmb_fU2Ggz6}~gGUax-=uYXABI!y-GNnOWl*^VO>MQu&Mg#Xb0xL7R9;vrtJB4jx>#H)WpnB@`06W> zq@{l=rbS-rJ<(sEs*+?&xlB1XrP@om#i`8Y9<~3AskC4))eZ zwN%_gd#cT`p}ylog9E+wn{Tg4!6IWU%Qk4JV=TxN=H79F-L{^x!%-uyhfOV^ce^XD z6F@BCbV|2er+Gjv7Z<{_xeK{j3TJMSNsPI-oj^2gMr@m#nI6~7- z>r4)8p%A*{It~5D!~NmN=%_YovA5S6t}!MHPd>mAz zjBQ|wAI*rf#l80vcB6{Cf1#R~sV2@=6Gk;LR81VMCJs~)Z&l5&=6C*m2-jM!)wW6b z2MkZ*W3mLVSJwAW9IRjj7;8izg{-*c$J>lMdlu zJ`~D!Y)o{>k}ON4@GyTaxRF2Cf~Rf6y!~1-xPI7_NDMj|bdxQ~wj&U~o@~p9&b2_< zlpn7D9?p^Vqt7G;`PoVg4TaAJ@K+VUM)EQn+L#C-B$_`X-!~>g!uR_p1s92^NRCz{ z>SM_h>G!sTPqy*tzTU~N@B6eJT*(IuK_)l4Z#W0KBS~}Aph5`8G;=hrTj3D{9P@Ol zTW;WWaxI=3JU&!gb9Y3uBeAfh+i45c5)tL*Pfez5Jt0fGHSA3Vk*38MU;HSE|q%?ykX}k&bJh-!->uVU}KC0qp zsVaX8NPjeGB{ZAJb@C~awk+MO>JnTc**lQ6JqbUerF3siF6!IQ_mP&u_hXPg=AWnG zXM!o+_n7xQ<}0*jLK}~07U}eWY)VZgMw0PxrOOci2oKS4z#I07f&EJWvcC&J_6GsT z-h*dKLW}Sw7_jg2b{bZ^;W}@>$lJfh+rPrw$9a2%w-566E^K9MO1Gn7SXs%(%N_*3 zP4IX4(+WiS4LDjOvP{%XbVa{OnTr$oDnEol`YS(3!=F6rx8C4-%-bGy-5Xv2TEG}Z zq78eJY@QSFFYD$wQO|&Ch#P3uaos#^$B5Sop3h9jX+icI0m>c;H1-RA=rFRdCwFNf zGe1RP@um*mzMpsYKw18g>ok^gi)A%CHIZ-+~F42P2lQ*?M@#Nsk-0ZfWrpZy+@sgfr=+t$Q20 zxjnlBSWEg3KSIMt0+yeI5kKW=|9HE0KdHUvXn01vIP=3(jmVOe?*Gd}rv zB^ES-%yrslGjr#sGIRiT^$ZziqG!;uj&v5T3E$9Ql;>0mfc<+{oa}GgFW~p%d{t`^x#8dJ)&AJT6@Dax62ylqp>n zE`eAv;W_I?nnw`yMN-By#U0j-+jmrA)Ox_}{6{#B$4 ztICFn6yI_bJEntFMzu*n`)nhj(?SrT>C-7HxQ=h2@A*Zt(rj_gYfR&G3{#5pP15#$ zcN||dnLOt4*F=mIdriVPtD`coy~|NLsbWLRt|J%wfjwO;4!C#eJd*VwZ}KL`J(!#B zsvnx=BIN#XtQNt_5I&>>LHi54RDTwvvum xxDQ zxQG5-?1Jm~%Z2i64wXiCyWFL0p|UaEkUd@xG2wctK3RBi=Xu z-y&B@h~(J=yy=^?AkF)P=bqW__p3suA2myht}Rl2ocb=Ls$cC@&u2>gFF>ID1026(JV|p&0efrNj=yw zqbhz^0I+3SLd>Sg3mhNnKJo}Y(VV{DO793Y)C?8td5GaF0uUS2x;0Wk^DYtiM?5IT zhn~Tf0y^bnWodEr(B39^QyO;gk#PeVkA0;Ve=`7#HeXPRgt?0UF5OTiILn=7rqv=F~YDlzia;r{= z<P8%C>NIWYYHT$=;*`{@=~b{{iZiVM71_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cc162b251b4f9f52a85caf8fefa2e90b8d6cf2d9 GIT binary patch literal 3510 zcmb_fU2NOd6}}|(Ydf|4)1;H~!x>KF$&q0>&d@k$XIiErx)SM7R2`!j0!5N7ZMI}c za(=KT^Rl970amT-)Z=Z?4QPNCXn`X2!_c%vJfP@Xv8MsU_Am^4*nnXhHf#?Yu);g% zQcPsKSY8^Fy7&Bj_ndR@IlO5S_k~zej8&FbN=t>RSXr&Ftk%VaN>!{?R;#&!xBz_d z2Qf{TuP3C~vmDYN|lM7S`Avv;*gP)K95s0;J2EvA%HX?B)DMwT(C5Nr1 zW%?kNNG2`omf15V)+;NKrNZUH5{9!}BOD>t>!vTBQDcUpsn!O!#&ub*nFka#G7F(e z=VZeBS}2IlS>}Q0=}0sZo1T_*^44bOO+xrBbmZgWCo|l=GUxkrhMzke?BU#tgrML6 zA=@y82WQA>ao_%sywpZ+U2Z29+ldS9gwjq-v=hVa#NjsLcH4ZdxcBc9aIN>Ix1THC zyRX9h@6BglRX-!7S$s*I;W_ZSdH2xVQ3u0ENEZZB%84u(C+^RkxV-=YyJG*MQ9B)k zf5l*KV0&(W<9QCn_lp+;+r^8$@b+)3um4yJ+#OUokOHX%EUj1Te-flGYyHLG#a_@= z`TKW&174x=7hj9>{6WY0&eGQd_^AWfga>DKKa!Bt>7=YjrWD|)=h9)m zllpltyl!}1P+vXam}JBf5nVPiI@Cvu6__VIpEl$a&+XSRv@q=yIzYfn(t~2eG7=u6 zexVx*?Xj?|>zW?XGRADi2nzvF?g~rle1!4SVaf?Tz~dy^4HZ1Tw}Ly|gisgO?GY@* zcL358*YuQRAbAIUie+?NR@?dl0{X1-!m*X`jrp!t+(NVHok<1Sb5d5%842X!{=3vn5*H-DVxZ&;hDLrtj~$0B94K5}$(HjN z7VRFOp+j_V7?k;+S!QRwP^*i%d_G$}g{<3_dCWl8zzu0YT*$&FDleAG_SXe@H;$uP z-r5l0p?!ePOH**DHe8LxM%B6{2p+RzIlBmL?fa$jV!pEM2OSO;#$lRm2LHUZM+Y%y z987w`LE8W{pPvrXlc+FhZSbIjEF{PF={HJ^vZFi%hq(oVY&1C1W&pl`*N(E+x{cWD z=FylgONJcTbD)!oA?s2yO*>Hy_WOKBGh}=J{=F-SW3UkSFZv`7KWC`)X|SQs*vjwj zQjVh59b5SdICpbrXXi`d#YxylluR&xF$%~tMuQKXu+{AFxHSQ*76Z+~GL1`(95aWX zJHJMZ&?f1bg~qYnJ)VE2Vl-tQVG73e{|VwOV+n3owXEpT~9J zU@9t{y4Os>NXS46)6zVnU51j9aUl>vx5oVDEz>nNdZLC_lEKcZTUE{_V2VM#iQ4wF zZo1-{cFN{&+5t7lKiD64IQc zC~Q$rs&KWGtH2zJD-S|1T%VM@*Z%4VniKO;@04*yyh?A>OwN zS97I$sa&^A|K)5hTQ610HMTB&fnH~8&>QrJ{|{>og^(3vjCQ}k6ru2)WbB^&i0MV4 ztT1Pd8isFn3_&KM;)r-DTaA7T1j3&nS8nST?vMbfVQ~vnk`9xv(q^kUc?2iG%mvyw z!*;+y%54tp30B%wG_X04b;nl+0P^1w!fXM(fZaa+U~mRrxKXkj)qZYiKMVDP!ACU{0s3yMnZRM_8XRnWTHy<6 znSBl^tIsLArl#No6W=q~VA=l*&cckB&kwUC{T^=wZuxvhN7&-6`tKCsb5=^tl9}_*jv>8(JZes7o5 zZwg-m?sDGmH}B2Ndpk?a|8hJf$18L5rP)GNt}N8&7wYnKr7G7d3)OrCr1lO}VTx zvAu~x=z?Q+#m+}#(fHWdm}0W`R=e&nCjOct`LOuWxbV0v2)`Q_Ck}^t1^*0Vq}a#U z8b~}uk)#OXm%m|mh;CXutZrxW+Zk&+qY_h=)`9Tw8`~9w+nHy#F%Ho*<6?35?<2(2 zcc-miC_a9ogZ}r@i*M_HU~H-Q1ASZ+;Is7L(8Q4zSUY3g$e@&$-7H!OKWZi11_y^t_!3EZv-8q&*(n^^$(5y zV(3~QjCJwJgTEpk^8WLe61LdU3cIWH;C zAki;pB4QWs5Zmzj@%m6%y^*+L#gkD}wX!BEBkq<~ATyb<)U+tqWD^G4lbKA98mVZjqmaCphiK?>2lfvaiLJXx>=PG> zeSnapv=Zk%uw?gnn1;8#VUdSxJUqk0-{#>o50CJ0jE4uYhX*pMm59R2G&biu0(rkH z-xWw75XCnUq2FCz;%=e!1$0`n6tQ#sC*HMzv9LR(w*R&F-Ab&7hfmw^W{)s?2qe6=I-a%-spma(3Ae z`bZ0%pWr9AAeRZUy@Q|Pr^)I$XIVrHu8jB-U+C2+H!3ZU!#K>FaHJr&;0`yWGl~eC z9>RZ}pVBP%>?3hgRV+2S>r|&SOEr~LhIf$}_Wo+tuvBj^|G9H{hcTJ3&T09CU%9aS z1vv3bp7s5m)-f_$^{iiUBNXmzY;1gv45%dUj<63tA(PXd&f5#hjvjteY8gWzEK1}8 zs*%Hljq8m(+!@=%=wD^MBf_H*QFxrxKL5{BGN=WaV~1yRbJwSGwEKH{gNUi!-ax>% z@G{^S!eO87NsRq{XJTi_>{B-}_C8{A;};$KV7*w7Z{S{2#El43j_1k?x#}$!KUAv8 z3$=yZ?CdQ$KU>IEWgKU@wooqLa_q0(DAkK{y)ZXlsOIVm)xwr7UGD2HORF>|RA|~T=F^Vt8$NTgMqY~L9$vq$T~30eR92y$ zu2kH#?h*KkuaRg}+y$q;?MoQOS>EFrIks4dc@D$Q3Y{xbpW{6qao&Uc5zZ)7fuu5_ zXqr1?AYHgw%2z-yONa;w;qs&t3&sAez#}Z5HE@Er72n5RoYZneJ zK;YG;1Pe_ipf_zBpHqxej6 z`i4qFqv&*=Q_~6^=_M+y8+S+lq*8OeJFs!Zk{DWL)`<8hi6Rz-4{>F%%ldi%X(=McOMZ?G=%IDD<>OAfbac8v%;A``EGO*AgE+$3DeW-6D(P>7;QZ>cuE?cKD zC@E+R57$U3;5|;F#%SUjnTcVtxJ2U{55D?f;)4%9_^>~~WPZQ*wzvTaFW#p2`}_0# ze$V-ya~mXZPEE^d_0oK0uCyRmmumA%HF>tWATL&z7K$Z#7WDEJHEZzqCYX9=_|-(G zxy4dkC>3g@8QEGYEzT6)IVvY!k=gu0We%8Ar$9`MofsWEetfty#muya_S~3bVn#JOpQQh8mqw5;wlX`OaCAKN=LUCBXf>@+7*sD*;))UhLp6G}o+ zlkgbi-rewZLg)%s@-|Cx|R z`9pnDqC0@Q-#68Z(fAJ$(nZL6rP%Mb)&iu-Hee7S&=2BVhZeu`ZW~}L?F>A2UYTwi zAaZ50Tm~Fix2NCb0rx5HTA$h_!9!aaT4Z?(Oug*={+|}t+AW4KMLR$8ds?MHHEj{; zqvz+nRleW*thH^FW0e?g>m7SwXC4iWZ6V90jHxnX1tC7ZW$ zc`NSg0^hDU)29_zZ^i{oTlcXihc@gdMEG%3cjM@N14tdItdU_BieF(RYThuozU3$g zind!|>-n!?m6_a2B_e26gbNrKy(kTcJ|JWRVtjBuL=>ezML&|?F=vM5RA!*~3y4v3 zIy0V4EA69%`gJjYWYr_zdE{FU;xmujK_r&TaXooO^jBd^dQ5Jmlqb+8#qQIh_oV3C z34rtl1O?nRLa7cXxI@PUNTXO2Lr7v`5J||D$Uh$W2?FU6(33Ub{LIQ`Q1~8&Y%-Zc z;l2xgmg~8)=vTzxK{2#P4DCg*&mFs~R$8pd#Tj@OMp3uy*!wKh?Z3+Q%d-Wz8fWCn zW$#u)-PMEWcG+o0VI?KTgiFWAJ*ui6O(sQ@NokK~#3`p4LXSX4 zFofnaPP0QC6oqBkEq`~lweYoH^)fh*RI zbL%R;2F_{vF>{jRfc4kGS&Y=t`%9-8aGE}`k3ur6PD&gJdz@d>)znOjPjWQ{{{A!| ziPyG4I4%UnLmKMyh;v)=2d=p(ph(H%YzRi5XSiZ5H!$?JL?skHXyJeg4)&yXDxh$T zM~x<;Z@ZFPx2JY39cmu-z!K4VeGw~zwwYnDX>`T|tew;I8OILJ7m61P7fPV(G__0) zK4oXQYGn;<*j;%qmpEUqU%X2a>{zT(sh2-_18-}#8DkF^d|p*4_2?m<4qg}lDG`7hruY1#k) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b14962f7a1dac829aa44e2ad3f0a7443007a4806 GIT binary patch literal 2122 zcmb_dO>7%Q6rNezv7I06gfvM*n=UOu$nBI)#cj4a!sDCF3L;Q<;6lto&~*pLCqNa;v`c~j+}_M zn_Db}#ZtajD$3S!X{nfh?|>YCRb~r|l{uIkKMrDi?C9v&ks~ARNoJKE^N99^| zL76MPQ<}qa=9dU1#JOsRk~v+qw2baF=nCz0KDE0vUCBaeY=RRh)Qp1BsbhD=k1BCR zO(YTqxwRU;LJ0jD6ZxThcZ#l`C;59*(sb`&Hw{$oo+YH`N-#>x>p$u+e^@{HiT)EI z_40@MltjB=cDsMN583z&5zMx`*|R@MwiUuy*nLJ0H&p6k$@uhm)swqkqWk@MQA zmI0V+c*8z?7T#Oq=#!xaj zE1R=ozE1G%j4^#iarI_QK!=k_oJ)$3gJOGXl?u3Y-^oJNg_zl-gv#iPt6gNPO zm^10|OiF28AJnglL4@x-_{QUY?!gTV!LnJdCoYJADx5{H$*rXFSePlXV?y*D6aDQF ziCzR!z}*~_mf^a#=~#IR#flh02#MVY#Ffb39^3<>pIMnSn8^1iWDyYNe%`TqqWci=(Kz>ezcMRPDXQ_R6z)c>IcT<-GT9q3+T! zx)q#87wntFn1~>bk9(-9B0?qKffxJS4S&mN_*-*$ZvtTQ2avBijW+R;7#1%hJCX3% zoO_r|x`#m(=cdz;z+*@?IJ3C&*wLmmiyJIuiVk#xojaAwSlrv5p>4IranV7s4}kmy zi2!!ofg$n*8m>aGz2ZmPpH3s>G<-#z|BR*sF!&z85c~y(r*eJ=_GK`VU!humpe=~= zuP`GwDSv{iNl^JyV8$d99J_5`1?2WMu9$P(5El{3R&Gf2h@t)0y2{GKh6C++myVY&2 Rbm$GSk8XD$pIzA8{0Fp%UvmHe literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b79f95dd3f662efb99e0a865c175719502a6be67 GIT binary patch literal 3239 zcmb_eL2Mhx6`kD`DN>R{T2}0oA)KvhH!f`orYyIKjHX#pOKD|tS6(h73n<{wBxMqn zM3o{PyG9JdMbkFe(3a&oJ4pi+JrzBvI@L~V0WFY2koH!f=&6Ss3Ir%xw5I}v`~EB` zGgi=C0&;i$fAjyFKQsT&&ISvdPiNJ1ePyk-TxqEFR&%Y@RF~=vb-mtdlq%{HaP?Z+ zvh~+zwe;DsGpT`mPfw{)DK;x*)oE4M%f+iF)YOZrw$`XELwMl@sHw@*3*XPva$!|=adU0&v(R=r#Xq_=uVms7?8H+N7d3W4s!qM|iGGk=*q^affgty_j zA8nW-r!Bf|5sV8QZA7Va~}C0@>I)v~alVA7X3>LDovD2(&XN=~vx3^@9Qn?!T+CSg+bEqbn98 zQW8p|I}4+-ERp`OdLg<~y)cYtWXHVyeJi^46;qOBXjas-hOLpWqVq@ANHun07^bHD zaO*FKl6*hpih>m z1L)B%8WU(2f4c)e-p9|6^GebRiTZA!Z{+dx(^_8l$K;}b<6sKsw6l6LYvhSc z`h*{(=5PEEHGk&MQ1gxtzU_lQ^ubptikvo|)@-t&c}DV!xhX4~>>ewGhxxPAD57Ei z^_zeD&ENgz4}zY3DCpS(LC@Yq4`|1OW0d3=G#=Xm@j9#8T3F>LICyzXR@ zu(7S(ArAu|5%?3a(0t^}2r?knoU~OOfkBhjF-z)2u2S9oU$kse&+0iWD{$$L z{5fhq5LVIyzj@sUTfSEF8#+h>`YXCQPYyw7O3pAzWI@}IhDVN~-B-D?R$ML9I`GISk00V+I|?WHEzjN8 ztgJWHQn}nXMaYjm_c@1<(d*i%x>Us1tgO~n{SOgg*M+0)-R<`_WqyDLnLuPJgRa{=as+N{3#fFNM zRo7dqt5-eu%dgd%Rkc}JS*tXP%~qrG*cLRziqZQsM#eGpJS8HX)3Ram2roiXrnN<& zs29h`=@^b*fC;+%$a#sEzehfbmHC_=b0opFpxLB;dDa|HHEG~Rt4}^w9HeKrk0R-cAg4!iO1RZlo zHNT1gD2P(@C~$+Y8+uBF4iJLik~wYB55&8(z5I&M-t3MpGyn*I{_J_ijNMxi=A7ywT2q^8{RgjiNzqv>ex>AX2s8bz#c5D*N?b6pf z)zB^xAs|VP-DA$n@~>y5`?Iq202hflJpSLng=&s2Re0zYu@|lFg~&b@i?aV;O$rW_ zPBkIWp(95+Ule>8Joi9X)y-E7+cN2Ez(Oxkw$V-a3=;sPr_Gup& z1|WTtax-Waa#OlJ2r=X=&g=9gmX6TEg21xz?!#G?C(FEJ<7&dBPZuwHhc@%WN00so Dqd2=V literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDR-AND-REST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDR-AND-REST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f1c02095d5c6870d8b9f05f2f194d2195d1fc3ff GIT binary patch literal 3341 zcmcguUu+ab7@wKF>;Lvz3N0TS97WvG5MT9;H1dETn3#wUL=#LT@?avyCu8D^uheg5x~1hnjA^{y^qcw3 z%x`|*H{X7@dE|V_>zBRh>DiQ#$jIrr-0WOVo=j)tYihA)jAUf@(l>TY1YY0bi78Sko=D zrcchLXB8uHJYg_*rn3kmWSuojhN3}l#1{%$i+BN7Snr#azMygdTvLZNL`qgz7&`_U z&o0HIcn5Vw4Gt4ge6l)KjYygGf!XBthJu4WR%DbBs2hGwSN8b; z2@Z$dq=J@`a%h#%N}-iND~9HT=77pp;4n!kvsRkBTxYgi6h2vp2#nL9guu5G} z^!gvJomEbRsDo8Znbp2hpez~+=>avuhDA)1H>&Gea7{&~80MtEU~cn+aCp_QCeEbg zY&s824!;^^Jkk+b$IKM1XJ(vk1w(%0Ai2jua$A7!!8TX;U|?U!uh{jREj9oz4XFDy z#qZ;s8h|IC*s0=vVmVDGIWP`PuLe-OfyaHZh}#(H?Hdw;Uv2 ziP7i6yaR0b8CXnG5K!k>6n?KL`yC>a!0hq`A=^~HqWQG|Tmr*ip)JfDqU^@VCP7-s z+36xrN9h;XAC*+usOJv{`;_$pYmrcz~$(dOr z7N3yWJ4hlo32f4R%WR1-w$@W>t2`NlcajM?H6vap70pM183D7%o<8goz^E{OVFEnX(kIqp39Y5=Y@Juk41!rC4A2BH zL|wFlJ`HTNlXg)zWw$0>fJJuy?G+Z3~5bk!fG%5al4rdX=8sTw=Xf42pJ@^c&1+VyU9a>?TILoHt-HCU|A6z&cVBYQJddSa~ z*|w^uw?I!WGncT{kh@$BIb$tKEE;1Xu=;AG!_@T#oJUTAJhmVt794=c2PnMP5gOw2 zW31awSw51$n*Q!Wd7YLiugZHUTRXd0%sRUmO&gbn?-elMA1rf_GsGt{cD_URzoa|< zUYtS;(ixv!m(KVtp3dN7LB`=@kIS;Pd5M!OEFwqop~vmuc}aJJ|9G&_@m-eLZae;@ zM8h88nR88|pAauN1TK2KZm`aS5Q6U)ng E1JJ6?YybcN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CONS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..88aa7b2a82e0768f87023224bff37efe11ffb07e GIT binary patch literal 3830 zcmds(Z){Ul6u|F$uie^h9UDU+W#VJI|kDTW}n>p zdVlBKcmCY-?mN9>#Jb1lmwoA>Oj3_$<@9hqGn|+E(^)x}9?nMNazE(hL%u*zd92gx z+tIkWsUkFECYp^$^6{9g4aak_$ia1T(aUk+BP(|wX`%=w0lE-?(JV~ zJZ{EA!k_9!lM%rtDU7I!$L z1Wlv1S#*YPTpjfKDyytw$rgY=l%1 zay}Vd$|_OJK)Ab3-yIGrAHKI z-=PIuv{I^|cBvZLRJBV91_MENAgt{SYc6RX7*x5uYM-0wLoO;vHK4Qk18N6$tm%%3 zy-ccwDZxu?p*7xrYiq2q5<)H55Eo&K`w60zwFiPdUJb?Tn3*pe3@Yl3hD!yU`xfRF z+$f088&Y^Wv=XOdbRiBA%KYx4i&0t*?koLW(7pYN+M#u#t`c+>zc+*d#S6?zJkPAe zx0#jL&Xqo{^f0Axg(-#0OetJqO7a_1l3$sUT%n5((S?uDMG3mN1w&neP*zqlls<-^ zgfbP^>PPV`t;eB*F2P|7mpp6`UuR13B$vkcu!bv_ap^8L2p=(}aE?ope8}Jf*h_1{ zu`q<($N3@TJ)8%SdpXCDcXN&)hdJ*<4sqU#9OT@Kyo?O~xrcKn zvY)epyo2*L6LJUVjmYhsJ;(~@^~l>fyODjIUC7%wucCEO8uAUR z9r=tEjeJP!AEZlm)B0{&-%9J&QqOAIvVzt*Y0Dy7*M<-2s%bd#@myYxrc=3%sJUVq z_h_hTIP7hZ`y+6IiOI@Cv-`9dm+h(rX~7a)FdNj}%Df)usaJ`J3AO3>>M(Mr4x_VliBKvP)t zqv0*-># z0X*KChGifdIcOSE`had4<(YUknuy0tLrkXND*|8ENG=mk8A2nv7=e;8c(gQu+DF)} zNZ=4Gkuo>Dp$N_~1Y)8X6d5A%L{Ly?FJjBgMR@S0&3qB_%!zg8#A-p5EY`Aeo83X{ zXbbhwX4*v8)B9*6b<=fpEp^c~bTwT?SJD-9IlcFB+CZ04nchQ}(z{0^qx(mrqp|<1 zpE)TG)Lghe>%j=$na0ZL*3>M!<%kUXN!Jg`dO9^Ar=UkcXTrXP4!&j&O?YdrDvdsm zjK**{G#bU>!03J)a-$I#$e*(kCO@0T>gj}=AmMZ>E~oqDd?GGKvIE0I@l-x1Cv$Qt ziMy0sXDO4@&?X*7`4pZZ5Z*8+#1T9pkQ1O{aP;PI@Dgm84z(UaF+q+-a`7CLB$I^7 z^k>sUawakmmzy`XU>-hy-k+fxx0>UY(pKJVj!S$~HzTnPz7(P(2{(r%FJVGQr>6b_ DQqoV~ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-TREE-EQUAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-TREE-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..034658e0b26540b4142b85ca4d349a20edaa8c06 GIT binary patch literal 4605 zcmb_f3v5&875?w_BX699Ea?oi7dD_6E^By9JcVz}O=57alk4l5K&xRAgH4?{a}ruq zjUkk>YI04DA-jJkwzX`nR&^4fO|&pz8&k!$A~CI#R;klkZQ5IVN}DEa%Fg*u9(H1t zX=`HpobNm5Kj-}C{yz7*z+C$RAtjI*8cC%SStT<*HZne@9L{8w(ad;uAfX%vUU@1I zHuX<;Yk|G%x3||uN-P7}M0_kUs958P(ZTrfbxQkIMH|Vc(x7bF0p1qMGa$(%)#ulxkjI*M=Z577}8Zk>(PC7 z!Om5~UestrH|<>024yTWqNWqa5^3Dd&?u7_v!BaVcSenX6$~48Q93Er+h=kOK|}3@ zt!Z64ldGqrV06jOdD=It?W$$!x~lg@wGg{7S$B#t=T5BVTJriH>Gff0&$sr-u?M_O zlIsX#@M>V}#mnsHM~{;77W(3w;O%mFWp+(5d6`{I%hR5S&L@*(g?-nHpr^=Q%3gUq z?MOSznAl8;GIm#mwQJH1X%Bee0?2Tst=_)~){B>=z2p^Zse>rZw@Oj#Ot_my!8i@;Tk!%WPo`j5v&h;kt{bW)*=k)7sddiM zI$OuICDtq=!Btp^>Z}=hRY;zhPr;YwBDi1@NH4;sJ+YSARU&Bft@L1}GG;ph$qvl# z0B~LNxhtEd8H|Q!e?>X|VmU0mw)elTkg&DV=`SQ3Q;j%f&gYi;0%2o!5J!>Ptr@#R zx~X;qfib!wKDmn5$S!z0Vb(SI0-6=*R!!ZCnlP&ZV%WJO{Siy=k)?$mR@leu95rBY z;pl3gosBrv91Xxbk>?&q-Hgu$0QJ1aQ40fckxw_xu&IWlR&UhuITnFay-zdxRl!Gm z942Ga#`y!b#?2Ua;#l2-BeESLxjVyVk7glU4?&s&QPb3olCjMtv@HW$%Um}CS_H-| zmcVh?I{t)1dTs_I^)C0KxJTmKByND8C(_^35e}&{Qy#ruCG*$#5=1tkJUF`|(T)gK z=lC4ij`5|4vV;!8RceXoR;OAas7YbMt@k3#g zZ;*I}$d}2J>XpwEI!(5HybTJKqx=CBI{z?=#lj{{k@%NbApMrmuL%8^&^&`^j?HliG4|g$2&ce7m55V98ZT4?cp9ICy31Ok0MGF z>L(Q9E07Elxs`te(Z>mS3AGVo0?GdtNPYt{R4JigD5yt77Wpn?ORYT^<0{e!`S>VjZ$ z9rUB>6MDc3o4qpMHXZxTN%o*0Z`2t4X(%{#GRZL+=9#*G-4#={L8`h?5FW2Xy3u8I zFXsN~bSEY{?$D+NC$tgL9-U;%{2LoF^97A$(XUP6{j!j1O#VNeYqE3B-qi5p*u`4V zM@X0d0eWXDn*d(^8|a6p^*`9fYDu<>E(hF(TrM|UjH>FIhPwLNMIO6Yl^@Bc^F#R~ zcF{Q<00hRjiw?YQFj@MdVM~Ye-D*HH z!=a!7XA_px#7C2fW2tmHfqpJv+{feDY~~5>;j7WEbedY1sTr1VcPlZ?(oHa~6y-og zE~ps`P{CX30Lwa5L>Urai+ZP6Ds_?Q<{oil8g0IC&`Qe58;VFJp*oOEpR({a_0tAQ6JQy%_=%709IU*E|Fd@eGV`w<4&U`#S0K^y; zC;b%)ozN8cwOW*0pcfO`U-3u!kAP-q`I9<5nyYuiRNSxR59cX(M^?3de>Msy4^a~|?0d&|>9NySS>DhVs z6x0YWS#qNFL>U^z+(oAZf3QlH9q5v&L=J)*SLxWG)4_Q-3UMX;Hb{N5+IDebIFRfa z2oHxD+$~$&KER1(`!auEDv~%u=Wx~$`e4dx=Y_JY|siMkS5dyf!JCt6Z?aLGAQDYN!2!i#H2|eF%U=~4V825 z^;es&3#fn2dGGzsx#!$-&$;K^4`rEHo(P20KrWL{8~U7@TPWlg3hHcbPMyy!%q4Yo z7TVP>1tQVlR}N}{(LD!xnqm!-$7>oOdMnXY< zSQ`ua%w@A^hgkd*v0&6Jw)U!pT;6Z!&*%n*lbI)!5c69_`_M!<5Fd$z%`#o0&E_|Y zu92{R975BEgG91dte|yj7M(qP{$9T}J{}AYl9yJRPY_}`jh?)gx_F4bnkA<%9g+@r zZEvL(Y{fT)pJqX?e;1h}gt#jFQtBdbZ6|CVntJv1Fwh?^kA5TkCLznIuZ9mv6cm@w zw;xuk*6iHYS~|ItPe5f@TCNUjOVxf&(6^krK)zG$Yq$)L(PivPZHHgAvB^?#Wpxgl zQicmA6)AwK*Q*mp4atxVh4(a^hS%6(bl1!{As?OCWqs9mxbs$jO~{3w<6iDVE+Gm(1-QgG-=A!>ZCa;sWmKy z)vy_M!(q6pa|P4YN?jt~*!H@SGv3S6u`Iomm39lQDeqdu6OMRc;-pEJvL8Uib)%Z+Zqa)&NP;o@O6&>jP0x&TlG}JY_z(RT0ID>M?udkQ_Ef2XhxDKDs_B}8FcYx ze{HvA3$a|NRzwr`)KXmrtBc6P&LkepdQJ2sitw$q3^%kSJJ$^B(Ziimiy>cI-Q6HT za(%VEp#^k75zhJUAxN zjT-TYkG04xtXbZ|9I_iul@?zx8jVE#k%{>DMBFF0LZ@b*7M}F;_Lz^s@zUCN<0;jm z5W*BZn>0LYz7CeGLy_p17Dx7Z962x%jRwOFXCI>|I|edOJ@|kY3yPsw3yMdrJz%K>7A;91<&@_*MPVyLNr90&+#3Tp%`d@Ig$PV=>b8%&+rPPtgyQfN<#Sr2kAN9D1BLQc@8wf8|kp% z4zR8myK9tnJ;J(r(Ci>{>R`$8oLNj4^!b9C$mjL!jOth8DP1)Z*fMuyA){vtY9?`9 zoz~Sv_P82KgCIBkMLk*QR*$99$rMPExs0wBpj#mU*GIIHo8^2mmz^)nEhO=tX+TdL zaLFv*9mfH8KCA6iXQ2lO(^+xB#I|SeL$!y^=M~n>RCYJpfqXx#EE$Oh%u|w7I*Mes zfL$PxkZ)Td_D2mFwm3I2i+37{%=AnGZEsktu&YtNSfQ&~q)$)xs20?(9TA-b; zO`Ca2rc%)gVWhK1Pz09iobr)bmiXYxKh3hTBs>N+<&R)t35l!bDGQZk#e&T5KnWS7 zFPh(m&X9|)Ks2bugZ>+~fY3-h7}Y{C2F~CrwLCTvi3dggUongN^;xT=FPY1y^?8wu z+ASKVUKNR0nA0&idIAy$m@drM(mb!~i%C6S;GKB^I$`9E+2v33Uu*a4qtHXu- z#0`81B6gtQ(VD={6+er8>?rY?Wfz|dtIaNqKy1!>3*VnCU9T=?ey-*fmQMzeCQZ{F2P6Ijh{2{kuzr5dTWho7^|ipH_L6CvM!Ine8A}4 zILISlf)l-)?hez}Fh#gA$emz?6EJ<7b3*zNuQt{PxnK{9{o;&SyzlxV%EG#Y)mW*e z*@bMfkcK6UF|Y6t&0(wQVb)2i0*+R_S|z!2M5BfoMYl z{clBL8xU?JJV3y+1!*@Bc=AcjKr|s?2LiW0EI%H&M1X(?>x;q~> zBt8Vfio{=lfCm>L{QwADf%H#6;GRPN00izJ^c^5D#q{@P*DjPVZn`M2@~mdr@xOE+|EX4_D9xMKC06mfur|fT0538@=3J`%@ccy; zSiW-YEGEB#4OnzwD7=iHU!W0wzd$Elo~~VBOwu&wL>z!y7h(WzVu*uqT>_+!@l{S< z16R4JD`@IxXda1m{(Xyof5X4O#pWM?90x)AY|XL7>lbj^EcP}mUbu(pi-}Ag{)NYn z^ci(_E|*dBi6gq&``~^&y91#@NN4wa&OBASDEVvF;n1*&@YoLS$z^nZNJKHroVXS9 c_IK~ZJ{29_@=klr3ccP(g6AZ8|Jt?x0$27%A^-pY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-BUTLAST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-BUTLAST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..acf03d45aa41181c7a8fb2464633cbccd143a00b GIT binary patch literal 3517 zcmcInYit`;7QT1Jc{-s>p%WTuq)O6a~Nz~U0F>%L@-N`tNCusv{wI-f0E)&~| z9Vk>=m7--qGJ@3F>|Ay$Ez+(82#FF2M9U*cAovpr2@q&^rPYcb`-_#>hqU|v!a4Wa zZA=jlsYn^0`<-*{dERqpvOpS6L=7dHpDkoPXHLn_mkRSGWhOtT6!Y_Q(~dF&eC2dB zY3aWj)uPAt91gdp)<~x3oOH>_DE7Ql%%mUKt%MIMT465h!Q#LHfZ;>KkwZg6ds<^! z$`IDRchBIVeFqN>hxfFuURb0Zc|yoESw_-ANC%OLf4-y14J~Dp3yZ;XgveVll*{g`33@3<&cBwBj`wWpqz%;ok*qB3 zs6!j7Xutde%v1Yy*%|i4@R+g+fG~z`de)t2opyF-0 zg1qi4OUP$ssR#Gr1E^*UYjK^bAr)%jwz!@IKF+%rPocY$utvJF^n_ z(9}`QJYwjUIuZwtc{CN0T3CzJ3{Mk04e$hDqB}!T&5n+$mTpg2Fp*I{(v7L9l&z0R z^jZx&8Dc>>$XaBa;u}J`WhE^&Ibn}a*de(UHnfE_b4um>RESae2H;Wc%1wbY4mZW{ zH*bnyfDjhI`(Zzhdly)5j3uox%|^HmBZ*E}mTs=Oe;5Us^cBduuO=SVQo3-@@Zyj@ z0!smXQZo>|51^@fvmkyCv87MyR!T?wHoFnYGV4XM1T|fs((RZ!rbVr!TD!$i_6*3n zxhyp`Hj*^zgcsOm)TyvOB##PoMxZIS0hyDm2T6==M6wxjkik6bMARePcd{*rS_BDj zCSB!-{$G&)28`hn%#`no~qZ42;JXRb*r$<22l6c z^}1o9d#i(SZgoZ@S1Dw!*iq8E_5Ra?SjF6oWBm&l?(Kt6v_d)^I#Z8!T z%}{kiAA^Aa<8&w6jbuAhk@O1G!x4F%TO}`XbL3gp{|mNllJzH8Kjte3{c>x`DVCJG z=SyC?SQLI*3&=*w;>~5!Q($D&}GYZBD@t@{S0RE=0GYsEeII zE3HC9jwO>^CjbjErL++(|B|IqqXLIa{GmNmg0Ziz;O?ldhPZvQ>Q~y)KAU29vb)fK zO!z-4$fzJNz$inL6p zhSg0Ml^N%L_@AQWrgKn8$8%<#T&cJlb#ltUE-dYwQ<|U4IT1t0-c-s@wy>wku=?=!Rh%CgD%6NIROLQa&vMVzf?2> z7*kYcz2X#+hwJk$`Q`m0%8wNGZzH5#YYMH8f;@%!F0QVA4H}W_H2?qr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-ALIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-ALIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..709bb06f650754b864c617dc27e3c892f6f7cf6b GIT binary patch literal 3745 zcmdT_-D@0G6u+~ZO?I24Nkgn{-EPNf6&E*{)Q=ibm`o-g&2%<9JDV6^WIH?ET}ZMa z*|t<`=?5sv7MpIXbF>u%|A5j5p{-cKf-glx5Ck6tUj-EeAAG65b7%9}+M=i+o6I@) z{LVS|+;h)4cTq%M)J;{d%*>Uiy?M2AusV0JsvfA!s|%Hb^RA~JfLwi5Pus?8Bbq+e z^IY$S>?*{a_wrS*pgIS=g+l(w<7)4-sx~)Yo(8jL50<_CPxbXb`DD+AAuVeL-tK9$ zyTA8|{@%Wx4Yw}7qjXk;5U#k+Bql_s2n+vgtuyHuStm6#Y8oj^+h-*GMZXrsSyH*I zVf(dBeQLEbmzwqtdDDEHnFXN;;h(8RhjNzgjHWHWt{hj|{I_fEqgHAhN7IH45sEgv zuy@6;b@V=!>PzYA@u`$%j%FQk@twAlLWDvb&DGMiy~>qYaqW}6p~)@VHYt%tj7)A` zeqqh3XU!_HdUav-;&>_eT`LOFb+V;PDP8&00{_e6*lFu?Ar?!oTYE!FJGe{tPi|vV z{*MaLCdBo!8<&Y{gr*EFh1RlqkIR28n13XcP<$zrD2L*9U7zf76Zqgx-R=h6EQ6oy z#(D9F1L3>%&t;qMptnvo*)^HCdAWPCn>W4r?&M}kImP!r)!EXe&3DT1VyUy-$)$3> z7EkJFYjBk7DK(;5gQj7p21X&VhO@~~3&lba{5PRsHzjq=(MM9Y;pA)-oGvT2IXjhg zjC~>Hb`2+;q}Ff@KuFV;tDEaG+|I&*0qO|1GNj6Bj|*6&1U`ssh`OO3hzU|iEo6VGdO&UHg1pVX@@#k@)oH~-k=AW z90lGym`)FBg8_UffENO|1h{EH8!!TJe*nH5fFarr7vgsrkobubhiQ9-5-ufnvg@Dy z8pEfm-a=J%D|1Iu`ROv)J~fr{@@`4>ro9<&wyIVRs1m4_@>R9Gpyr`HyTIJMH#ePk zG04laYPIA^FY5jy(3tfO2U>^A)sn;(@-tA#&#U>_g6bCLv5PvFFM4X<(|b6aAN|@6 zheO$UOxvj*$m0c(e&tibvSYhg?W$jI^3R3*nv$oT0kc2I!4wKp0xs`2UMW{2Me4#{L+WUaWN z%!&tcBtNmr?i;qN$D-_!rwRzB6ItXii@O0kL3nb*(LjWW<=0zdM@zXGV*HSuDFiNe!T_4 z33(Y@>S&*KiSSjU51_-HftzeWiCV0IpF<|D7G@|R=y}o`*SG|lAmnC1RfO1xRbA=M z#1~~D-MWlNp~!W>(Kz^(q5S^{bfi(VWm)f>D@>9oa)WbW!4n5Z;uc2%;uv6yT?z{inP2^8iC(d;D~g8RBm+n~QR07o|KSYugNF yc69gOuz5Uq0fRSV-NfH@7c9}hGW^z1fuA7qByWc9zYC_UZ5r_&cgHWcZv6qV-3&Sa literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d91886a7a2902aa6032d5a619b6dd1d3abd84d6c GIT binary patch literal 2104 zcmb_cT}&KR6uvXd{sBuC3T$bSPDp)V=wO$h2C-sihgsNVnV~bY7ECljSY(rJ7h%z; zu_1lX2S+PqZRTidd@`mFP4$h|w28*V2aOLVKK0E9jZZuq6Fg^b7irhTn2^cMch7h3 z{mwae&b?bKIH%<#t$cB{SSqYZ<&DbfMnzgKuSx6WjkU#sw2Zv;mS$S|+f%AGJ@8Dj z(LUf=Tq`V83QLl+QCMGEc;l3md|Fah*NP>ajEY^-0Q0W7aoN#rM@eULx?-p^y6kOvZUk#l^0sbyZtI{_ zDX%J}!fS;Rm2+{O35|A1{ue0KXqsLl>;KLLNez^MzV{KQ$ZNkdV zJp<>vThs3w-!itf@{W-eg&59mCoUYLwKO7(H8XaFp|;cGvrX~zy-TO6%vH~l~DYb&=q|LtdPt;CCQCN_B=x!tm68WS06J!MKYCUUx^ zq%z1DleR3zASy<2L~w+01aUNApSQ}I>S$Anr8{{G`&9EAJ!H?@jy@v_^(!1xhNeI> zL<5c3+byzgS*E3!d1p57$blBz&@8LQyyEk=4A|tYXCA*R%>l-sfo{lAYWH4L3Z+eJ zMs>(MK~c55W$DI&8wdjVC_wu^g=(s;^H4w+NB9kuqWjm0nD3yC;2StX@D;QZyaycw zMebYXzUR5`Dei0JzL@W0fBHW5v+rYH`aX7x`#y#C*P$a1Z5A9!LHlv&pon<7SKXk0 z3KZ%ud>TRqm6#)Q7ZLj8%DftRG>CH{C4clk-m>JM)_8jT1- zFdzg&MEv?V@uT;Nw=Loy>Cr4*b##2lY8~kRm|VuuEj4FD6D`BzIG;BiotJm7KDiMJ zatFEyKJcny*pK?|{_Ish9CV`?Ji%37u2&hR?JseaL9ZId^aAHIbNlZ%odd|oHoRb3 z)6nP7gR{Ej%tIg2LA(&A1%0?JZJN+Wa{Z_SGJgFyPJwdJ*HNEUs6MM9k`eu^*e_l+ zL|LU&3;#Ko^YExShH<>}GwOLE8Q~biL_qM^IMK{F(%v!z70^ z2bIGFCUK6|rl4;fx4~I>7RKQ@I0q_@)QgV>HtK^Wv(VM!ZO2Fi4-rx*K$}%KOVk`v Y<1n7U6_7dTge>vGqx$UQ*}c8L0YBqfLjV8( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-TREE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-TREE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5cfa7e666fd0d8a948f589fa554c538a85289157 GIT binary patch literal 2299 zcmb_cO>7%g5PrLk9ovZ`Cr#p}tr`|Y#IOU9x!pwWIo8X`dDTlZ7X1+Jy z{Or89#r!jRR?*8>R!YmoRi(VKzOu2dES6W5werU5d{J3MyYi-P*~VMrnm*b4Tq2x5 zfXuHJ=hll0inCE%TbO(OX(jQjqOGi!mT@yYjA~+JAUV?C-y2SA`K(}jtWV!a;{3?K zP;Yqe_AMz|W{l0V2P8s_MVXIz+io=O7DjOczYu$yla$Q`(f8y&G;MW2)0wnl@%IIk?Y4?2_lUBnH%^ zs$0{us$&}lyM3$aI%9G#C3AP_-h{Msl`VfWAzwIos#Wsur%2+*doMHAcD=DpTH3j9 z;(m8)@;&oA#llP%}CazoNXof~l9oNj!tYNFE z3|h>wd|Zw|NDko&;%da@$JKyy-Wu06M;}*h!ztJ}r#c_>Kz=sw7*n!Tf5Nfi(Bx}| zkS~n0-4Zu!+p<-w;7k{sxUU5rn&X-|t8#lj4mjkkga5uO%|6DUfo{l28uuP#3ZyN2 zN^?j(OHuWLZ5!r+8we6%6rlZ4p}LkgL@1z(BmIs{q1tsK%lFVm;#)XD;%jIp@h)_b zC<$y)V9yKe8G(fb7U3BCi(~8;jA4Y#2JvL+l*H zx{+2s?YYrfFBE!lltHq`Jol_qTw7Oqu4z5W;vBxf3rgv#cs$8=?Mce&Pp{Gt33(OS ztN8F63`jm-fPmlr3;4I8zZHtYck|;t6}(kNmZl8;60Q^sm0RRKCE*Og45hSLpncB2%6D= zUn(ZIb}$^|j*bKl6sr7iiO$TzWu$~laJfqK!r>~-`U(>h(A7;|IVeCbR@+I3J=sSq Hdwc%?ewU?Z literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-EIGHTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-EIGHTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2105724b4f7d8358b317d2080beaa651bbd727eb GIT binary patch literal 4209 zcmb_fZ){sv6~FgAJF)X;`P2U~tX@gh;`W6mY1%B+SYDjx_@(x9^8DO1d_eOYr}l8- zkT@k%w<@k8CYW26x@7Ne8b~0vFMQ}SKy(|61_B{g4WS_>fhzR_2oOT+N2DQ@bMCd> zm$cf3G{=7Dcg{WM+;i@^_q>}m;yx3M_=EY``D`w|;Lk4==9dconf!u(F~78sO8aL( z?mr)lnc6d9HF&D~WKTofF_KzHCkyFmzqOQJoK8M<#NYFXU!7mb<^T)~0NXRz-#d8h zSa(B6jYovHPqgV91hd|w-3@nMUZ<^jLP&~iBJmQ^N@QYRDYXVHEp90xJ)$Xw8r1^! znqBfhE=nSZnE}PsIy*r*^5ar(fw+G<`H|g~`k7%@+xgix|lpnK#Gi^*K8A)|fQ8v!ji=&k}+I z&4g?MgfF5@2A)57joiec3jVzVzvIBKJMfPj_yq_4RuykNjVR{<_ZxYH_(SG#Co|z> zhMi2Glj(FayBrKcaJrKDxW6|c*Y=C`tu%A}Z3FP_wNsajUlFpF`KB=@QLtaTwr6s8 z)vbq+CRmwlYA-KoWg(^d>O$6o3#jw|`$YGdj@l>Hu{qfxi4U!$f#k+#6YWo{(R!+B z-Po`YI;Xs`@t9Mzb?CtThN>z#&uy{dpGmaxbJb|Qu&STt>sUxw(YK9CT)7q~%-+o^ zOKW1`v+;g|RV7RpOp$zw8eGX-+kL++vzBSiwi3x}f4B6xKrm*E=y;TsuxgA%G*cPY zL1K)?1Cob%rF!_e;pc*W(H01*RxqrXnw2o&ya##1sEbd#+1V4@c^T81IVaa>qFQ|CA9aQ6*n4UG_@ILV5jjE?KC8EdCne<<_ z7s>b7E+j9p-AJBedw|f}TuA@Th4iKn{tSbOs^dY`M4d9QE%B-7a4e!!+a}5{u?{59 z3Q`p0ydX=0@ep?8f*_HO%9ecYscdZosxwBZ?N$qEJWBl5T+( zjdC67CgO;|e@1*t;13Xw3H(RIy1;)xEc{FFAs!X-cM*pK{w-on;9nyi5%`yg#o9`n zh=+yzE!K`<71@3yPw`ZwSx)HtTu9#)+@>JU!&10nBO~LWPruFA<+NsSZWTB=sv9_R zfn)Uy;$<|c>_xhO3{;g{ zwaX2xopm#X9bt!AfPK*}x2%W{Aoh^+&n`90CeLP5{;y@{&Q9lNon!2wiWNJ^9%fyv zlYIgGAKz{RLg^LzCA%y^LJtN_O|>*-+kuYgmS(DvIBP^T*nSg`HC1FDZ*ybQ-3M9>+2t*xC_BQ!NV-1W1*+^5n(a=_y8&!*ymi_K zxFP)yUj_z2NK6&={^!>0dSDv*H=Z56ZkOeil_E+u0Lt!ZgzM|1E;l{&r&eN@e7WT8 z6Vpko@;x0F8VKbb7n-hJqGy07Xg_vu3@5k7fIEzy;4zSY*(Irv2Lbu3UB+u-dO4LX zWakQY$$KuDN*1#Dxkau6#jOh`zmd#lSsUVLdO4fQ11`%@P}vG=AgzZhrykN_GXvv= zu408J;f;Y>6u+PdFE#tB#8TiQX6n#L_|YY|?6MndT;q{M9Ms{|92Psu4QCKV>^Ka& zEj_9s(~lv4071^=^Cy%ik_#tL@IF*uSjnMSj0YhPt0sV}xH(-Q>|t#HKnQ>bRUPQ% z>NtW3b}57_O!{ggi1;=~PsfnqI$%>_Fw3gL{+bygSS8`@cug#jdlYWz2pzegladQk z8vp{y4WK#t7GKz06=#p2=b9WR7ef#c4#9$9rbk&D-)7`@mwBmwW0#xRB0I;Hg)w^? zD}oES!k??$4_mw(x}1mF=X*pjcrwW^M1nNI-P6;eda#vo;j!=VP^D`30S+4wWrx^7 zRCpLMoJ3e&2|EgeNDWK^^23FrqH1&;Wn3^JCc+}ZFx1|ea1q^LSg-KstCcZOoCHN) zbb1CWPN!;y+nKM36t1Bw=yT}p$B>Tbp(unliUd1piDm#|4vW2_$$2zfwq@RcB^{_lK=n! literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-ENDP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-ENDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cb42b166374d4fc690ed2a0d8889262cfc95f6c5 GIT binary patch literal 1279 zcmah|%WoS+7@u9oue@;5w2+0iBUibsx~Y;TY6(bavY8}K*1PULnueQkHnr7_ZTV3I zh^p#=3rmaZQq6!WapGL{))vtNTsd$+;>4+c0RKVwKAS*AK|PG-d;GrNe6Q(|j}MGq>m8Ss3+R@Kjo1xfAYDzZuyKzqUx#t_}1&bRtD{@`*M4W+IjKJfrh^H25r_nT`@Ol_wIR|Z`5F);eGwXqE z`US@pedVSyF7Ct=1=}b=X>5ZNHS-q>vMVCaE-V|12DjHr$%5L3Fzd~?%qxgWUD zNOLfWl(*~oyr?QKBYa1fV~LE+CbH1{Nu9f{;~GxjmjYi;OhCZ6&g@-dVE1$hQ+Rop znFJwn1V=cIL-`GuQtOUeWIn3D;;Uxhy4-$YMWlkhpTIZsPhlqW`0yz?hVE~n@X0yb z@i7GtO0_te1w4=~vTbfy1#j?1AD?8U670suAin197FQk1INGk3Jbq2Su_dQB%!g`0++O$k7je0w5BkpGrpY{=#zrpf!zYKqOkJjqLZ-=%Ua|pWwjk|)v=O9$- zq7R)+C~897Q=vNw`};59F95@;%!_+T(ND`W=tmVU6Rv)eWHV`qzFofkfrym~I^G}p zz2UVZ^CQU=nAZ@GE0es;tbofr&N_A3v4SEfkdAWJ72k+H=5We%IrF*kuR&P_pS#TR pH^Zh0Oe<&vBwU%z{J_$TNPeC+@L literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIFTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIFTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..546dad8613c81210e6823ad076adcf3970155aeb GIT binary patch literal 2115 zcmb^x%}*Rv{LOyBcG;G=i~jpKi}`Y zGV#8lsG?GsozLYn3u2*EoG%r{>B54zSST$_X2faWi|;GCK|dUkm9fj$B4^AalF5Zk zx|o>~tx{%jD*f&yG4iq~&oAWifb{hN8R_qh_V@H$J`Kbpl&>(oT_p+NZE(5q+#U+Z1l=tSn`&$>$3je*W)+*Z1 zs@UFA7T=v2LK>HALPB=?p$7PVdF-zCh>&vjjyCENf`Dzdj5k-UY6+<$WH&e2%A0eT zlkj>qry6j9x?sl@4)LwAssj*g4InYuxI5nHf(MCKz^kflRaJxmLQqG@N5Sy_%=qVO z#8UUyDhBf+E5(lK^l>@A(a}^U>rEw zuo-sMFu%(SzXt}cA*{%jG9nq&N*ORP3ZFQiIbm8f;Sx@3SbCTR+U^U;@g%23gZT1uL>iE1_5b#czQpe?lIkk{UO;vsc(T6b!It1eaI~ z0_=txP7$jIiu{G)$S17% zJ=VhW*Z`Ma-U5&dYj9|N8rG*G`7vup@Bt(d=p2%bF=(8bzNc%hId-6!S%hmYH(ks|(PGoFpS6(HbxZCNr_*rhO^La=%6)~rTNhF7 zwzC>sg2!3)VG|5G#OeX@O;Amp;cb1%=hy!X%e)8rsT+ zpSY^{VAmbnGYt%A4;_qatz*b#_zgp3|1yN{DSha^iL zwRx%H`P+5UBX@_&xuvZ0D!-ZJgOGe*hI@KDUXI@$fg7wU*b5zM?1zYBKa)?--k3_` zT%9`9F1TCyp@xW1Cmul9C8{Qb4%pxt(=y;nN($%TBzaMoBm|qf#wUe^d7gX#$em*Y za0RuNnTVA*wr^&kP?}!^9N2DtwiD`qN@6Re!IjcA*rTP7uJTnl9*%rbJUI9pN-1&) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIRST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIRST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d948ff1aefc33d735f1655d9151191fa2571a5a4 GIT binary patch literal 757 zcmaiyPfrs;7{=e-rKK$`DMU#$1}7w3HV&~BBG!xJc1jD&EX>ZPawP56HYv2}9}{CF z#)GFdT8Ly;!*}qC7&-Wb{02B%OeA>lw6o95`#kUOof$#wnPnrZv)664{T}KJ2i@TS zH99@i?+kl2A2pPYURe&Ougk>RSbCgGxmR{-J%4xL*O3_d{rc|9dnoq^k#4WmR*ThD z^_wfK&!b z8QG+!9LXS|Sg_|(E`ymo8g#n2?Z5Eb5zby8GywTANR&KgiHgJIk@iMQ%MU@O!tjU9ANhCWLj&U z{$OhTYqas6{R9{_-?4RF%K#iUzs^<1D3L`1APsQds?Cm?*;W?xnEVvnF)fD`D^YK_ zOjyyT96zlng{`@!KB1szOp6Gsj5!q^S4~@E>bSe(3c9Il|DF(z8BQ6KVbVw_&}ox$ z?r`jQV#^bzkyHg~ldv5;)?G7H#M#`n!A%+f;Y2hoV?&w5OAg;8q8x=;9_N%@xrI=B zsPr3uIV|GROLx@=R^_pA)S|kGIE#$zTj88hl)+Rqa5NtD{U+CVZa1xcCh*#Nf&R literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FOURTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FOURTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0c9b92dc8ccbd49612719befc1a3a3d0387201c4 GIT binary patch literal 759 zcmaiyPfrs;7{=e-rKLb2g(!)};Dm(B#vyKji1p&QOle`6h1uCuj!nDRCWSWrV`7ZN zc<{7F3z5uf_zqqXBL}~b-vDP@6A2tV?d&u2KF|AmXZnzMZac_s?zifVppBZnZmZWt zd(AfLG<)qzfcBJ*UfV9GZwkcTTzq1UdslWU?V#KZsz~&LPPP2%0kR$=(rVWmYO%Vi zey!X}Hn+UIIG!h-Gj#iJ%~H#euuFpjQPEV4hxQp+#^9}9n0Cs+C=%uN<(^{f_{sLg;-Dp~? zo&98L{ky;Uf&BvL*WR-YU7G|rs(qU+4On7}6hIo_qF$Nl*E01C=n45byl2`jTPw!R z;R0c64(0e+Q7LTQGxZTgJ#E@V*agg~@VV;R9$+WET~E+0UAuWgxMnnAj7DQdN|8>P zlyjG3*B9HqFpV))kTwb1#RJ_lBZZu?u1#*#0EkB7aT%M+B$;>l77>Lw%=S5_?8-Gn z+9Rdk`p01tj}F~cA6S(q22l&@CXy^Ra_&U4#+nS%@x;+^(hr}?@V*E-T{M44=FwhR zy}>G~9}J&QtQ{_B@~b@7RoI-(DG?N3%XEr@a^iT=M0`x;?)a{t(QWuLcX{~-?yBKt literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LAST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LAST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8c9af13234004ba37ba328c87d3e7df1b6026836 GIT binary patch literal 2226 zcmb_cO>7%Q6rNezNu1P;6In@cf7nET8n+wOPD)Eq1)KG{akAMByX(4<;9wl5w(8WD z?Nn5Vs#FLrhSqgyclyJj2M(M{IJJdV1tElp#Dzl-9Jp}l3B&;;5aGQY#|_%vHqFO0B$76PHRAv07TGWOL#Y$i+7m!&KjzmX+DD7o*+Q zCQY`I%hYm!d5u-1Na=B6{0&(B~u+hnVvB`;vvF?OyX*}8!ea0uFvB~lM zW8Lf5F4AC$5RxT#5&VP%iHA7n>%oYvTDFu(YO18mb85tCIQ1^*MM_z!>D2pTVy#q` zin$ZHBDS+!C6o~7T)iui(iJ;t=uVTKrdyn|^*~aW=AkwDkV=HERuqg*ow`4|Pl`#J zY}w@6#lRUtgaFoYD}Q^2-aJmueLf?k2f}^S=N1`S9ZiRzMr77jx3%e~uB1b*tWh|f z=YO}464HOBGf49{@904P(wKc;|B8@C{#|`WpaGz645o+B3x8dNY$4=sAscqjp_QM$ zw~@aSLZBV^xdtuz`lsY}qW@liSQ3K9=pj3(@WgC=C%#f4dQVbppl3 z09e4+!?OZ_Q@S5j5dCVpzjX+}Y&85owk?D<+U|lHAl2so`EWQ4#T+XNMNe^8(d*Vi zw?cJb2p??~SsYt`@(j-BZw&m`5E}VlA&ATJVSRf*(o_;8`XMVK zbTYr-gP#{xwlAW{wlXc5s+}@n*-;B5AN{Rh-#XKDH$nyK4nKd-C(dKBI^s1E4LyHmbq{I(L3Sy5yHH96L!LG)4w57 zN5U}YWE|Bv8m8W7osQwxv`Q-U|Z2`G2fb-%dLgp4Q zou+zNH7ynSRTf6L2I5|8VQ$LMq>U?z@=I(xLW4t@4IsD71`%FkLkJSo;sGDli`;W; z8-mDoAcP=n2Na^}ab&xJ_0P$(s-z{|a>!q<9r=;N_Z+_D@EM0sID7=t4q2+5kRB=X zBpW!v2A9~7#KOZY+=q#NfgAI)!bpa^}sSl9ajg-ZP z5oWpVOB`_U9#fv?t#(4#-lPu8Cu@?bsdF$W@FBmlAi~caF0mc2vSFKzOtTU9On!Ij zfm*Iw6N{N@Erv;cbLvmqC>c2=kBCbdc=H#51qlv^IKW)m(bz#u@SV$JEig$eglZgSpoAn^eB(6zEY5V)Ss*;f zR3uZ}EDe%4G{baeuzBur$GIR-0ex?^sgEI#4@K9VrVnQ1b(zZ-Y1hl}=*eqAP_aIz zzO9&9etj{6!+q>E029G|4PatuOBblX!XU-CZ@cqmyHU4?4Og7{M0-*Z7GzUQfwona*oz?npMe%wd=Q&$ OY3aXnlFP@|*Z%?I~4i^j#oCrymL@!*q}7h^P;|Nr-`8yh6NkhS|?zyJ69 zU(Ww@nv@@Pd8jKjHjy;rX`0GqCvsUjno845DwmGN=_u&wt1h2kKQpMghPwCn)CBIc zMAPv|HXftFTs#wtoZ3Nq_EK#koiu^z>jSZ8-)`r=-rnw-0WIJW(H?nb*S;Pn9P6%G zygDN_qzEBVGLNL1kOra<>vF!q5!3@gb-?Y>RYUXY4r|)VS3xdnD4_eTe4~?QQxmEg ze|`cZz&zFBBYLx`DAn( zuf-As$yVNtjGLCS>y760#~t zZYg~Z-Q?A(CFGMY$P^l0#(y9ePatEKmBg3KZ{R3=z-G>wbIStyYUa#RT(ri_*ouT^ zYMxn9m_z2!iUelNQv5xZF38`Oa;-+}tGd9ej`eRt(?YR5+$IB-O~v&~nk!*Dw>(BX z%GV`4wnkdFlsR;G9$4QdWPF=^8-U^@HbEO+TY}9A&W=D0vtv(y8^WhyJ8)sTP=wLp z=CFNXHVl)5>b3=hU+h~Or*wKHpolY_c)Juu9DQ^jE+?*Sc-Z4GooGll5V;Q4f}}0) z0ephxTGSn6HrZx#n((lU?dRKy|VP6N6_bB^-2w^Ro1aOr5I(&jLqUhq3=VY;%@|R+KHy-IvK|i|g+osuGs0}J)poDlYBjJDSsCuK zZd^_mA$G-p&+pZOD8282vWYuD3Z&} zj^q;CjN}|^L9$D@%iJa{a+~x!w@G&)0R^@>vw^2{2O?H`wIN;gxC0nhDzXkFpRy;B zd@Q7bAg>GMl#p_QB!qHA5Vs)vA?5XebU+P^cn|tKYU%xfK{p6o%>tLgagm=mW+E~r zU$NHH%zlb(PO_F~S*wG!Vt&dPmY4S$r8vBpDhzC!2gMP#6^J~?>X2M#wMcSo3z9Km ziwL6QXoN)t?r{g{7jBV$5ab3#u6G+S^qNQ2J-Qbr0m4Y1u}&njg5(7`2hqxpgy3B$ zBAyoNH0wg&l#qIPUC2NDHu5LGhTLOYUu0XtZ0iu)x&xe*3s!!2HlE2+GnO13r7G>r zLrsJ7}d5T6;#uH(C04D1bWAv|;uU)~{181eb`K8kBcTb}9xgb}q z_hm^&#ieB~W);dxu+Z|t8W~_qYgEHlq53|RNCulU2wjA9c*72hj>2@Z9<+IZ!L=vp z&>CBHRb>SV&shZ<7s|^N8CRXOXNJ@q&cObkVTFaoB6-IE-)$a#qyrS*F3f8Zx;7;_aN8t|K2m-RRR-uCHF(-0ib@-f>?_FsQJY8IfMl$gXjLJk39+%N{YK%@qj>oBU tj}xCSmnZ8v!5mN>91a+VKI}FOPVaqnSC_3DaoU$hOIm$DnN2M&{tw@caZdmM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST-LENGTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST-LENGTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..caa62b355a2a914a062377f9806f2f5e0fdb69d0 GIT binary patch literal 2781 zcmb_eUrbwN6#u?^3lz$qvM?Cz58s%$*z8Uz!%Y@5F6BZC<(BncWcVkhmavoj+f@LTXM0!Yq(kTuP=AS(Yi}mkN0{pUJXZrjU&%*gVMD+kr?_I~!C36NiuY zH5l78@oXZNPs}m1kjTx&-a5qko@44#HkpFMv17pY4G#DRj~qGNFsd41;q8&{^bhvI z=jh>v%`2MZor~U8(P#Zw)$B< zv!tXFZzNI(XE8@8A@+ww_vo}9FhddDF41M$Xn#;_3hBxeKvTywBDu?6&^xt@-o63F zuY^MoDy->aW{_N2^_(X}I*aMtux^gi^)xyA)wndXtE-jPoF+tktgf!ETRP;ccWxkA zv6hoJLAB$2-41H4-_qfHcV*&z{Wj_@=;IP?g45NGnJ)Br6br&FY_1(ZUA%p*bEaLIY43D$co$`G0=s1k{~k|DXDTVV(SJFo z$K(3PitBnn3z-X08-NKx2@b??hKfTa9!pf|VkK%*RgE!V%H<(s?Rm>uK-!NYN9;ki zC$$gj+lK%AAh@!nmVgsQ|378FWL<54&?u}}-lUgEP4?yD9$z4$kA!fRm7uDRgte$L z90G|xX85FfUN5=fse`8m9v3W4t1qCMfuIuA%;_i$eZbk8T4UBQwMmKIZ(&A!+#`EH zK~HTh7_Nrg$m`_>Se|B|7L7)tN@Uucnl^oMGuSrzRDD))<6_BE6!WcxR>uj z!oYp~q&lHFn~aj(yc0>A(APMG{w>IFP}?>`Ge;F;c5*lpRw_3Jyg|R^JCS_N+mT%3 z9Y`+28_m6X#6;W%)IY4DxCmigVbwrPv;a)Y100&d;Ys086%M<>VMDL>f)?H8kNoAB zl0O_%@{?mqZeqc=T~K}pIr)-zLsasqASFTG<6ZN7XPmbiyhDL}Jlo!TlJ7xek^%A> zr+3Irz>Qg}V`IX|p5WLn`m-q17koc*p9>)uB+D5Jj|$z>LU_O-t&RYYhn751FCMtT) zsXc5y2H#k7ESVNxHYhvSi)IRp+tz0pB~NX!;=modX1gRyJvC_1WS88$mp{P|U?L;D z1&Joes32oNO1NA!CTZv0TbET8psfB=`1`iO0}HH(6w51YD&{bzzDs6XMX~bAg_IasHU2l zQnfSTkf}x0u)#fO20cGH9Wgc0wcB@)rC?D5T^0 zWG2mWR;G}eW7$N$kWI4~OD9v9%LYG)@A?~shNhDA{)>U%j{rm{W$)X*r(%vCx zPn@i^P4%;tsSW2b=tE7f)2f?gQA1 znQVeNig+xSVDZdS5~h4Un^|N_vC|3We|CUn=2;+|$4w=_I#9_qKLpMSIbtUKxNkB`%Gk3h9@w=tq!o6h+5RXeYLXxx|Oi6dH zU;Umu9I*_=t00CMJtcWz#9T0)Q*J&7G1LDA{;FL(UJd#g0KJ7b_fWtu@q<;BBp;_X GH~#^CJ|##1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ba1292d1298ec1c0c36c29be4edd2a67b8d1b6fb GIT binary patch literal 3440 zcmdT`eQXnD7=Q1s9o^`(g9fo%@KQlo@rL`tIsCdEH`dW!=iPN6d#(&&; zeSgpMKHu;2KD}Au-KNE4t*~Pvm(NVfh3VqNbWt8HOv+P*>B)3P9tFO>g+PH2k|rfwY6%GtiMY=>frzbJw$dAo>58Go^@uy`IzGrnNm{z; zIt^`du`r?JGY@9+n9hzVA`s#}>-c(;hGs_-hC3(h7X0orPJPr+1|T(ci%vve*$P@0 zT&K3RQ)yFTQOhQ;%s1>IM6xlC_p(R&g~Q|I#rONgp{7uS;LS^U&ln-_$$PRP{6o3p zM}V4TYc|heDz#3hY}HheCjW z35jk`uP)`q^mV1YlwMaA7}(E`q{Byt!rM=z!zCl{xgVq#N{OZ`U31xpFWxoaD6tG9 zC@rrFU7D$c?nf>NVY{;PK^mW>j17uNK-sb&1QdMp53=jLpy&nqQUPD4&7aF2SaGpF zpUnnx0V4X{7o4VumM}I)@op-8sX+(ZLsZp; ziGs60x`Nh9SHiToBBGmS!c-DTdmw2?qyPx}BdRg1Fh0g1H2_agX+Tktt2!;U! z5!^`wFrhjxoKSVp8`OhyX%$YIKJZq9xv4giI%qa%Nz>Ggs<}r6-0Oh7;JNB)s-^RA zs2{e)Kf#h$9TtWaG9fxxI9XmaJd}DxR51?cnbE7gh z!Z*yaaEe(LK4+GNx53tOW-G30W}-R+;dOc~7!h`Hy@$A7mg$k>j7dIbOmdhu-AhAv z(Z)D!+5kFI1RQ(W2_hASABq|SOOGi^E9g301iAti@mD;;9-i6Hh|5`?MjYq-@2HHT zUo)$Ny1|k=MuW(F6`2EOVvB*)PP!JC2bc>n!2r&qxiw3un(Bc>pf zn51xsFK?k_=Anty_=o~^;gb7-DJ@VhQ%qF2o2w6Uy?(yIArA5bD+YOog+unUILJP}I3QkQ!3?m= zz8?oht*Q6Mbj{YwHunHevarQ8x^@#?w}Gx(MVlLG5KAYiu2WykOcmvPZmQUcoLgMy z8XGy`88s}Arr^D1M9z)#R}$pStU^w{lWZhG&S>(opY zCv)RtkL-5mJaj#c(B^IK984S57Qe&A-3AuKQ?M&~YJ7;lSWrUhv%O=ue8LPODlt!p z-gNhYDM)FRX6mY~D;M16Sk%@{HD*yiia`V2kxbY+@119=bL~KDPtjX(xd(EAsAvc6 zf;8wx+DSV=od$PHuHzY<9&a51(nCMR;kAW|Mu&`j`# z#LO@YP%0k{(q?)S?V>kwZ(vzC%~GR%=sC)}?F&{Cxas`mjJec0W0k_(9mRCsK7>t?;BMw6q(xEcJRD>rM zhg@`>@Iphi%ZfY>y#yVE{Ut*w)5Tn2d;Fwsph!+EItcP%b+@;n&yXmc?sPgI(zmn87lHN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LISTSTAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LISTSTAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1e643626b105c6cf9c68f31e6211762611cecdf6 GIT binary patch literal 3678 zcmd50dVRRh_Ue# z@$u2o;~hyoXG&}TbOqqt3 z(bGoMTlL%^#G>VMhUK|^akWuf)SS|DB?rSWr zNBwhzY<(h;2rk;(IJBigxvgHUTrFQM--Nk+D|-&m^82?kfInKj@Ji+vgshfd%A9Ak z8_-)1P9DOI_yh^*BBWU<4v1v52+)7D3GAsVxBm}65cB``&l!eXKp>qmY)HfA#$il= zOl1q9O@y1flt=bPJCDJZ2S;&y!Uf9s03o0NMTi2>DoaVyf^SrJ_z7{a6xuPPa&uQs zT6w0;FoZ^n{msdKAT!y|7^C8wvB`cwpp48H2b&Hn4mBO6c(lb0C^w;qoSC9}Yf_#6 zZBcDv*|nl+0)!7Pa(vI0+x%sccPD_qwFBsuzW&4amitJtU!-v3z+`{>4=06km(Jez zQkz((!^+b1#z|lYnS>-cJ}3n?@AxLwy$he***G}wFh`LTAWz7oP3N-^x>kPcz^C2n z)pBp8m#|Ln2kxP0BAYpr!ak*)(=%sG!_rQtK$AI}i?VJWVj*~f@a%!d504L;VqY|& z+lh0UW!QNOnp#41#XxR4XB%locdoFrQQoO^!35LwtqzL4PwC(xWiNEcy-~xmvX++3 z+Y@;^s`S9(uBe`w)`UJ6u0GEx&V3Q)_HSn>q2~-qhj+rX@@KHrlbcST&YD`g z-J|{%e+Y-0Jc7fI`9U0xNadhZ?h{J(2RMUp&ajhOT2ENnyRER_z}$W@x6=jt0GKJ@ zllOpa_ESE9!<)dzXJpPypztyZrk=wf*^F?`3c@*iN;*FbEByMzggK2%y7(a+{NT0Y zh;h-drnMZDfoXu2ej+C6-*E@NrJ|_(xiCtb!YKWTFiNYiBmhQ%2CkU{F_hLX7~=;4Qr@|=!g6f9JtiKB8LJV`vs8% z<*SI#OZ+tAl*Chr&q9hJ7rD z-^04@(&fcMbp}sWY+%0wrLrY$a!dewn?H=hSz(1eDYuWvVURz7a}V$l97LVB4jXR< zO-r*OJ_OVBpCXeNjSQYV{i7g9emf+cG=!c~FEbBWW55+mKPy z%SblYDlS@pgXu|Sph@VaW|&4AF3KhTNS+@{@na)AKFmin9#(nmFpo$0$b&qL)!|Ed z?pUK#Z>UbC-iV%1HB~((pnCapYNf80zP?;}uHcla4Y;rBW%cRB!dyv>kDa=NyA98M z*v8$1SM))3wgA5lXVgkn{;)&cl_R)pzqhVCQ=~MZvZOFrZ&vS>i;~Isys=yQ2$>3&} ztHnm8R;{C-clZ-HeAinCKAk+wAzeJihxr%yajx-4`R93b7bia50Ww(pw_b2o6Y1bd z2$suYR0ce^b300`K_w!BVSn}3Ly$+HAM@4}841c^#dCcSeQd@@U^)Bsb}Y zmw4_$r?Bv~nF1c;jvfuKHYR#BCfw~B8fx`J=m(w~Zi`0dV#>;9umTCCe2557?_MVX zd^dguAFcNQToU-vE!YYRE8bf0{^Vf{&W^;eOZOxuj;p3+Vl+t1i%-6A^iMnt#i#h7 zC|~?CSzCT}&JENXOO@)}3s=2$A3w>*_{fxB-tT@$-4q(3-kOj30zts^W3RmfrH@{n z!{IN&7@`k_7ev3>!H?d&hhGd=y(jq5?|JKf&)oz6Q>g+M{x}~83C_YS%$N9MxbVuh z0>#GmY80P^s9;oXx4+2Bz3%ItJGxyn!*DZ%R4mj>YO%Ihfjct0R9jG67yYDKn^hBL l!>sWqzT~Y1?mmDqEG=KkGu{{$an7C`4=I}CC~r> literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-MAKE-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-MAKE-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..042ff3bdf4a2bab26dd866ad64a3f635b0492862 GIT binary patch literal 2538 zcmb_eUu;uV7(e%R|3^o+)dAgL*M$i-+=X=m$5ia4+|h2gx8vSh*vuX*{X>g)Yi&D_ z7|BF2(OidRVYx?x4kFEBhf*w-{7=?YuzvELaO z?jIZ;*xT2%a%GY8xNKCaCxH)cBizP^RaUjJGJ`+jBYJ@s2cD%rQyQJ!;yb#2RWFMc224TNkW zWI31Ya8j`9l~b!;>rEaO!I@PTOPP(*(T&n`8>L;2WV#=$rB%P1T+U>UspdT@0ckJ7e&Vab*X3us+wbc(s!KWsXw}deK0X0Z3?2VS0CJ#6uBK)FZl|ucwWCExc=>YKZJc4m{IuEC zNE=;lDDxJ-tZ6Y#jKz)dxZ!s-!xuLBC3RACblp#(-dhJAZJS0HA+!dYWhYkt0a&SS zB&J0r1L=PB8j5S0tgdTD%HdcqjCt3B3rV`nT+wD2=KhA^8f>!%or?rV?!kx)+LU%6 z`;~4%_>pc!xXajW#=c?f24hQ%eahHX#wcU+j9p;tRmKX8orGiX>asB+>XXq!F-5Fi z5$JG=ZbNv6wjm7Cc7&bO3qbyYWHdgw98md%`Vj6ixXIuX28+~}r)?%}pQ7FY>U)y< zwo)I)#&^OxwazIZYlmB^PQ?@}Nb6}A0Qa+#lvs=<Ki=URt?_r0D9y_*|utrNlIMix5M!?JcNn z73!s_S3V|dlcElNs>p2hHsNQ9{jwI`{`ZV z&ziMiXFS9TCsiL(VtQPYp#|~Z;wHE)u%UY0(7^XN1kJl)L!MA9Iu1|6!{X|E4#dW( zaYGBo)v*93Zeo$RgK)V?aFabQEx7Euv^e>IVt*<&jyIL0RFlKiQ6IJg9 zvQR!-NSB0sMo1;f2_b*tR61EMIX_p**)*JQuAEDl!s&zwKSyvwduR^;`3K!C@ErR< zU z!5|^d2aaBHtTRrc=<{r9XV$j%Jsf*K1n(%xLprL3fA a&weOeD&T9Uy-+)cf84{XlMkj=R{jN0tj)*( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NBUTLAST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NBUTLAST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c38b79e7d1eb405871a913e9a2048f484fe7657d GIT binary patch literal 4017 zcmcInYit}>6~1?N{eG=m2XE~poj6WOmW;`+-QosNJYJ9Ewb!%h?l@bkk*dw^IJ?bw z*Lc??X-X6VYJYSKI9ANuwm~frDH2F^R~1T9z>z>ajVgtQL=pU`RFDuz75v~wh0Hnk z&e-0#QuvX|o;mlN^WF2hXU@znlA0&OQ8`?goy%F~yj)l)%`KGVnZmqWEG*2YO?d|7 z^7(Kqu6=1t4NvraHrSZhqDjx2sgjwIjRmuqNu4_=2OpQ!x%r$0i@`x)gNGjt9Ud6y zYaCS*QDN<#d-@Lt2l$@#tIO0^AcUmJDv}05e8fZS%Vl4{&=Q6+8i{I(u1;zJd(ke} zLoUixLW|qw_K;jE%qf=nMbpA`W{ZRpVt=DtKRTs{jYv$lm*_>>Y=6Dn648}okeYf_ zBT~I%1+7!N+!%aR2`T#Ulo3@E2D!T2dWjHk0%N(AeS4hV%#&+B9G8+iyV_|D545M! zm+XN!ky)$A$sV!Tfds^h*%z{$T+Cg};@{h+2zlUAT?ftH{IL$}4;Ck0(tm=$=k;-k zw!mtoGr1eL<5f>cGa;+Fw9E_Q1VO!S5OppPX%iv$#k|z)ny*K*Y5%w1Br8e3n*Wk9!>bvwjO=Dwuh`Hq`H3l!Ta<*MU*)e2z@ zU6mXJ5rQDF=1+;z$E^+?->Ow7Fh>B>=wRIAvDzGrM__gUrdeRFa5HW$F1;@~d1u|6 znzrO5dI_Ab{{KR8KC8T~Bnmme)(7bbqHLJ8d0JV6rwxWi=DC4jnLgRX8uTf-E23K7Os=lIVb%`kiQDyp9J??L4LzMNY}Xs=^FPSUEv<2l-Q7j zj2kA^2~CMc5?D(~6N*O!Y2}2z&rQ(xxCwfPo1iZW-6hDp?t~5{4u`-1JuSp1@rcx8 z$25HerBAbmkr;w#f&>J#juY}{?u5L{oseH~C*(SqsnL#W@#zb!^E~sPW)B@<-Gi)q z59{s)i{1kqfbE6c9(Xy|>ev`~pxzyfV|d#73NBx!*NYDH07?*7>yWOT#Y7J z6Tl!m-jWL+b>^NgutQKI>6go7SN6ux&1Y_nNB;ZoSI5S)UGToVF@E}Yx4t~)TlvR5 z4$T9H;2au!DpQ^M*d91Yw7kM&W$=;hMk2j_cO?A?yec9ApqEM>FNz-DvJQa(Dxvhi z#;V(0(SL69LjPiyd#ZXoBr9@W&K2d1Ig?tjO7MD;gJ6)p%RSR&Xk6xF_zt6C@#uZc z5wQ&7E?^EBxFKQ$-f=)Q0elu!uoq#E;kpBqUU(CV=|B}OV;1UnqtOm#p&|Yx@jDvD z4KR9~70fSZH6Wbqu$NlU3CplkEDJh1DuOsF$e187Hc&S%Hnmi3VrSVo_AEQko`Xop zhxSs_rol}eZlB=W$@|+1Oa5S&t*XKXp|H6bxs)|!D+l8vn<~mP<{9`AS<0sJP;=8V zXU%-6cn~ppdH(@Cg?Y2IFrSAB1LKHqYqkxw;jv$Zmc>XG526-wKMWEM)0lm_5T5cdy$m@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NCONC.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NCONC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5a54bc84f0b981b182f18b95b7485f7a27789c41 GIT binary patch literal 2539 zcmb_eO>7fK6rNqji4(`fb`u8-IEzVAFj+)?Xdx|Cm(3W($e|Ld)ZBZi)I(40i5@sqLQ3D8A&G%XTu^rN zzIi|2ym>Qk)(gaaLe(X;G&NHw=4PeRe0gTREKQbXrMc4lY&IuNf?hhKCQa>wxS}52 z`&w^Ps>YI?&1K5D3CWtz%}r$9?~!^BO3KV^p$Oo>0T}iU?(Z8M7}(o1tfX|#_S~5M z!QTCYz5Dhyt=_mM_)CP4ELld;NQj@fh_hJn$1E*n$-@aJ1Agl6Yb#g{PTF<6>1q7l*am<8Dd zr{e3~FZaoYnlw~$<67`MA>vI;X`8)Rvzz-IVUNn9tWFddSI3fxVuyCv0j-WTb9zvQ4SuSKH zM!PoW!?igZ3NM6E>|Z1F;H=rrd=X(TI+yd=7>7MvbboQ1+_yK|VY}1rwqte=xyPJ&{^S25`HYLjQM27V`drpNKx^YGqptPV7(ukGULIj3He!<--Zk z7$d2e=%I~b1H5i{>!6ncF;%hDxNK@x+Js(ESu@qA##5FyDhkhfSjiamy1ZZzPOSGG zc8seTbqZ~9H6b_*U=wY0wLq6`ifN{qH05O48cSO-mmeIOV~Q~@Gkq#X1y=xrjzLfm zfePRy1j7JY5sU+9Lofs&gg~P$(CY(F_qrGQhSp(+N3dlVVgCBzq&ccsIJ^Xr0X1!! zno)CuPyuac!PdG_JXJ|)JVEM3a|(*v@HV>-`fxl(B@}~PM41pC(e0oV{-rp%@E7es zaR(xsy0qh(IWDJQA9M}1-_ji@K7$0kdIByqT{A|kIO?jL>@pW0f=A=1a#WMi4efJu zCyE>w5$?8?i_KiLaS>#K++%5xyDTm84egks+ux;;w`j+1DzyQZScXa5Y&&pNgxj*- zz^dsue1~?S=%*nR`zX5%Wg38y@CWTg@f&jye&qs7=^9QZX$#uU09#AKfHSG+vZiaJ zP<+(SfS3DN8tz~2H$`7Y^(hQCl{iZmn}$%vPcG7~G1?iYU9ZzFmfFWo#aqtJ zmF4MdX*xRqG~!22rNaW16g{g%rO6C@%qFD5H2)5v?ktNu?p$$uovOJ02%@XbUB9CT zIdtcW$WeUV&H?vApCRz^vcen!6Ai$S26?5roGUKDRfk>?P;(RpB#5Z1bFL%VVkM%Q znqq14Q-@DaSemKmDa!JL{W+FSS{kqS!zUKp4|KvmbPtN}ovM%U^cp;ksJVSj^uj&# z<``Ty5BzXFQNN4OHm9<+n3*~?k-@4w(?{^l6j&cYD^b5t59h;WSaCt1-Gm_P*G|># z^ENka!ogQBVhTC}?7KO;5~pX(&#cYr{GarfD7P_~J0@YD8#Q|aC~Reh2SmBQahnc36xQ@QD~RG5=8 z(lq?yL4xn-p7|#^CY{Q`jrd-OFXtfyRZ=!Hmy@!knF5^3$=TABG?O`^zc+T9}Ww#}O3A;P} zzH{!m=bm%!opZZHJYz~Ms7z1J;Pk@$%))%|*z|00ZhB#MA`?6Y`rtcCLRU{k zWMz2Y!H#O9WMpDClbX+@gXThJE}c5LH`vh|lxJphc_2MKAa?Y1clLF4?W+#UMvQxV zDMJ^QNfU0S7qX+p>ZSwrv<5+EY6m#sj^R1H%KM`Nm_$#FGgFWHtCa*>jT zs@qn5XK;RcM#^X2%H%Pf$vHv^u|KlB;iRUR(S&BN&_!BnpR@c?O&WpJR9x(Jalec0E^g!a2?uw*#q7hsHzDGN zvsD3_y?#pres^j3L+yJ)ma^|@Ljr|lmaaC9He!nScnPV6{BjdpoqZ{k$_8=)BKYj{)-xd`p$$aw<&+|_HV{*FsXq!DZO{k_Ugi_3;PJpy0Ue+|q{yZc zk#yBe>hK0DP7A0s#tl=A3v{D}nFz5O(a(Hh4ZQVFg;ZTn=u#qSjwH>HSPK(sL$Wq5 zIeH_+s8|g;Di=Eo_5|oGUF$oGzk(1}f&HWz8$<-WSB4XMTsBcuF%l)I>#A1LuNcL# zE*RTSaE8t6>;fo(-N!L}e|StG(2YXYF(I7<4pqoh~3 z@)QOWmq!#?N1JgF>x}Vue2cO1|FEWA zu#cMz)eK8T-nD zqjU#s>Y^GP7C9!VF*Od=Mg5n!WpQrvIr13ipCKRS{0j0R&Ob#S<@{shuK$b32f5xx z9_IW!a+ULCeb#_sY3x~qFi)k=0eZnv(q%5a$KfcHq9QRcFaq{; z#Hq_sRdb{vki>XY!;t}p%VWr2!YS?vp*<+58lT?@0u7u2`D2~_l? zk-oZ0D)Z^XKL?0yZOf-7-$<|ksa>d3k0j;T7M5yY-E|;WYRP!Ns^gvG mHOEI(Z1S`XDvPrcI{dAGLusI;Vd`+#5n5g=a$)k`z5f8{2NMPW literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NRECONC.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NRECONC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3382886d0dcd82c7d46e05294127d428558a46d2 GIT binary patch literal 2542 zcmb_dO>7%g5PrM<&##?EZ7?C(29p%i4NcP05)kTovxzsc*JgJuClrJd$Hi71JF=Zh z6j7B3^}?bybtwA^73u}V0V%44)U*K~K;lwPmAJqO32q?70mP}y?AlG5Qo#Ww_WXZu zX5P&68gb2vF-|NkE$0i_GFMuuF0WL%lch3ODXo+h@s(ecBFhg&8EEoP(rYs}dA$TQ=I z#)ez&UcJotON5XNsUz_b;wKJbUNZb)UD9-ZQjSTyBE+Szxn>$(sD)2yl4=@(QLb8A z<_p==*#efcR3Qu@=0(FhnNmbuPAF!LImfh_7mRjU;ge9BFeMSz+dx5d#x&YSj_{+r zqDo>y5y{odfmK3S7p8JEcWav2ERyfGrrC5?Fu+*aTst9Xy?s5JLwZjGkU`?7!xwi6CV|niI}AF5g9bflon<^)W^Eu|Fz!7$|piZO#M+Y(jFrC1#kqB^pcn;Gh3#Pef^6NB2{kV0DEnyBykz<~kk=>q>F!m@UBd#f2G(kI9+^y@4kQ$)u!Apu=Z$Kay)UsZkE4^ENpH zch#*)`XsN-#UqIr-+TqoCq*AaqS8Jj5!#Q00dP-a@j)hk(h!ngZ1MvpBPNn_&1A^8 z^a-?oWMPpHEi7Wt{#R*emWC#2=qL?6MMJ$b)PnHe1AxoAI+X6f!{k=5XE7ANp+iVM z2W_XUz;p>QUW!R^Xd&u9rU#H*u}Q_Q@E9FLa5sQz~XgQTeNB^y{b`I4cZrC+Fe0U*z&d`=v(RS*(k>Vb)mF*stfZ96YH-uDG(a zkS$lZ`Er)atW>iHxkCO_cAPV74%X?$h)=Bu-@;1fR5e#B7hyo)K0Rtwh$|`0zSFDd za|tdnrKjR>&kdi+L`;U)*!H=A%7^}AxGR}ZXXYRp#w96F*{f*rKM7NIhW5s0hKD|0~hmRDxpijuoDT;P#KUr<`OABrA$bwro*CR zu6VW=q^W2^#pEFqEfp7FO|bq|8_S_bC9pVkL5|smvu4dpyJ;8QL-(2M2*Nw=#&Ykx6egPDcT96JmP<9S)ZpS{s1X$U48 zYkI}}z%IK_R3$-|_+85zlXXcIVj6`uL)+|;RCbNs2qI0>Fp{8I^SInlIQX~wyq?xJ zU|P(Yv!m1QgFn!PeqCnG4ZQ-_b?nPJ%dp!)ZWp@vpsg;a1D;aL+VFGXERr7q@gdOU zjs?_Az``P5qwYbNFU*>Y!BIlYPpn?h#qCOoxvSDc=(kS83s9xkgDE@lQW=-q*M0)x zeC;}Xd%Q_FZl_g-bGCh1#^a4xelP6u8wM@I4q4y*@Xa#&ES|YPHF5>>xOVsM-#=p2 Ay8r+H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bf8ffd97d862dbb58e1e5b046075d3dac1f70ebb GIT binary patch literal 2279 zcmb_dL2nyX5PomhPV6QDr!^r>t9YAIMK#%~aoe;_L3FcO$4=L~VRx-I5*%D-U0dDQ z#&!@DP=yM(un1g>un#B)4oF;3$%#_bRssnLq27=<^9y?HEzIoNC2f()p|;oa=6mzz z&3td>ZJUJ8$*LgNR_hhVZV0utR(-7{lxhv3SzBuqZJ`9X@V2ZQ%DWj!K6B{Q^bT{| zOtE1XTK0-yt=Y|$!lfx;`lKM$8x;ozCr*GmJ$o!Qd-Uj`9cjr_18+}Ub7XdUW;T^N zv}5bq294DSAw_Zj;fZ(EjU_F`w8V5)RYXn7DM_#Gxe>@k%$thgxx*=;RjZ4R z{if|;I;%}W3GqI4Bk8;*TUlN6I&_^5dY`yMSxsDm)T9N4aFMPT^iE+seN0S=nw25f zHlkMu;bt(5pUO8E>5VEW{JhAWjgJk}aOLI&LUvy1kJ0jtTN;e-wa={fZaAG*%2oMIQ&3y!ViYv)t>x)p@`e}leSzCQ9_=i4sFDlx)Ez0cgeNm{a8i~mIU^d1l{cV5WxvGx%w^M3avXi!!qSs$fFEK}egLZanWSPEx*_U$ zYbkFf`9WAPn3S|-(Z|gsgYq6e`e>I7@r1At_QoiddlEeLrFA1GS*T9pu5#Wm6m47Y zF^Y2|Fc<$fL0K}DU@JBN)AUd96jCJ<{m@@Qi5xH$3tJ0;@7V~77Tby94YmtKfyGgr z1jjsd?Sl@--o%M1wj0F@7^Aebq-gV~?gKTNlg=ojnhoqm*dCmS`sU>CK-`4`i9-Zw z(Ok~W>8jYf7r>N!=f^?5_2VELEZ)LBG~ELJ7TL}Pw(B^HKL?f^ULawgQPe_k!GIai zrQ(kFSpvmfNPtQV38iP*I0`+OkpnRU2BEaBrvjUUe!{vQXya@GSL^}T&t^5K9!V7y zRms5-AifKY4Ji{C$Jl-V$$i{$$%n{qLB6iPF?pXQ-eL)njUQl%-7JATbNfB_Sj%p< zglelSi2na-;gWFP7S@_@wYO?Qvu+nFrAtCVs5=FCDIjFGO1L=Txd{swPh6HJgi--s z7b`-g8r<}VT|R(e{^fPT;lBO|UZV7l*Ws7|%!PVK^p5u>U=a1VY$%eYh>sMKnza-| zQcX61W}G_+6zC0?kj8(#bK|5eT2jwW~1HFG#h36y5l1OLBDU1iMe)p zz4BwGo%vvnZ&%jKpG&9V7MuGc7RY-s;<DnN9l zDZKQuP@Tg0s&CY=n`@3gQH2*T`v00u)*<~cPa_V}&4}~rS02CQ&Mj%W!`W~vwY_z;V`hBLJ#1n+Zb$Q}|pmXpnQ{Jb= zc$gB|b5q;s@Q1}h({2jITD<}_R%+B%g?izFEu>~wj;`JSqOE6At(uz(9{Yc zby6koC!kS(+o~OQ>0t-NVOra%JyhBbt9ID2=N@<9Flk5jo((OfleWWbe|o>)`+sf{ z|5ZuhrRwT>#VXhM>PBOIqrop%Yka-BQ7e`CW#IE4OLWXLWU+;`fB_^iECP&(i?(Q++ zDj}pq9wP`65+)pRcI^qpQ=v?X_}v?vnCYf>Os>CSHjr- zFYST2lvmSPoDm@-s%b^mgj5zd>Wm&|TWOH>!|}locEu&pkTQZM8wCx9NOGsJMPJkn zIma@uYZ&=B4RJvlgohDEE!u-% z(*u?VW>H6+pO@7%3f~4Ym=ot@LCNZ_|3QjTk-um+fK zEh^STLGl|qh+qiZ`xd|@?ME^ON^fLUXtbyZvLff8V#tr8nk=5E_0bE!CC}&pg5OEQ>87N6y!PLj>m~O%@GVIMXgAYsi|Y=rn|Ckn;zHyditB9ljbs0`2`l zV+ekLadCFJWGaW$zO(BO^u^?3@mtV1%Y*oQ1awh;2jx39 zBhr2ZDGx|)eaW`#6Wn^Ak0$9Py@Gma+P?`_IG?|z?l}f*Wsk&CO>?XAW2Tw8mExL} zE%T1}J}i3bY1o5@VdB_tS;f_lmWo)#*H#05@tnIFUffq9_C+`!vIDdyLVF-$&8;uJ z1l6NMbUU7f#d^8Um#XU(XxDPBy2`H?ua)`Hi6mcL<|U<}yhmfqtER|T I^G8R21EOUUi~s-t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-POP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-POP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..19faf6d23dd572e8edc6974dfbed1afc25eebe94 GIT binary patch literal 2297 zcmb_dOK%fb6ux&R?>HebE(FU;2a`fE3}EwUpll|So5W!<6K2LSRBCB(?AXO%H%?kr zs3=9HY|O)nfVr)ZsxG>wULaAbc+m~2*i`DWKcGvhs$Ep7+;e8))S;-|kjOgk?>z3k zXDX!ijH*d$;bJkDPcKM?rN!dXqLe8tNTtHkLMkm~KrdZZ4U>I5p{S=0yczAXnk=b> z^z34KPO_KMrMcOU_Dj*@l2TmA<$)O<1~Gc#Xzaw1BL}+16if5a{x|0EiRdv1JJ40X zf0yj}7dc@u(<%4Iq{Tu}&Zj>} z=dqoOB|-^tZkId861r-~4c%F#%hc!GD)+>7c^X<%#u*Vh)=?0h0v|mp$K+{an%uwJ zdzBDz1k3m~`*@N*xP(ZE7wXl~W?8IPW6g3)y(%@ymF&$;(sFJ&+xUMe)eE&o^&Kz_Yyb!} z-sl-5I9`;3_}5Q64L@Bo{K7fEH_flUA-{mQrqgqQnl6Az-%&FH7*Pk?4^8d>1e%8z z@z)$w(V>dF5=cvcNHmFMQX zYxpbK<|#L(y`1&Gl!1%M#=yHVA>5H~#mL0f?l6oq%graAKbrs--Ygty>+@#D%k2H9!C?1B;el=m5OmEs>oT4oZw!lAwQ5B1M**PvB;ZHznH`xp`Er#+Fkh`@w>_Ls` z@Yzk}meD?T+1+tRX47_!VxCln2BUnA%YQ*FbXM)_@!w^(PV zMhs1E>`K%dpl?$RW~!K*?s4vA3Ut_oufQF z%)@)R5BnDnI_1vAbZJp47K$-c>~qSm+NcO$QNmJY7Cv%wQtp!XeL~%p*T7A9=&bsB z0)wx|oK^AU)EQ^Bh5L8_D^%g=fs6uK6_8^a+}H*;jvU@ZIsqJzxJM>=H{S(usX0vY zrSpY{F{qkMv6=kb1<>L)GZoF^z32vGJ)JOY=FJX1dK-;J5$p!vgM@)AkMRA-AHJDG z@(Px+Dx%g^&|jT09Rmyf5pkh4uz)IaGskzKdgarRCxjsPE`)lznN5CZGdH{@z(xhJ z1+@p=p7=19aojr|sj1XM=o4~FCD+%(-rpQ@-YLf#M<&UV%cf>a>5`Nx6mxJ|nT5hd qsW>~ImSS&2r9wthwMFe6zUL6;4Dh|%u~|4RzL#!BCZ8wk^}hk&b)~BS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..dc98fbc3acba1f6910b83902c87d7d69e7696efd GIT binary patch literal 3052 zcmb_eUu;`v75~0_ZO2aR*2&T|^|JI*x^^9~H{r2yn4`@%*=1E9p)iP-UZ4yX;${x`wUJwtcLI@-t2XnUJz9_ANT>5S@ zZK%)9E6EEdpG*v9`ZW1kG1n*-By*!!FXT2)NQoyTrCPHcARd1l*u?aisp-?FPY%v0 z8O`(dg*K&k)}cemVT z5bh#pGpgY>ho_`Qr7Anc%S8vTvtB2Z5cem|;9OQunyIwzw&)cac7NQAq;z=^uBMz* zi4g2~LGRRUh7xDwDS0uQnJ2GZA9;Zg@e|DB7o~U4(_3Y7^Y(ecIuaYEex9VXV@ZPJ zhYuPXrzraM4NKzZmD0PH2pM@{V4Rk2y{7|xZ|lN~`Uiw;m42X~7ia{iw+>oI5smL4 zAz?yx?EEo)^G-zJY&YUSDIepS{DgOmd&lICZN*~w7>|1MZFo zO7ahD!YNo2eOhwYn&<$@9ngMgP4upH^KG)Tr)^u~0{oSQ+aA#m+qTBLPJYO>$Z?{F zYOi@b$F;x7nfG*oX9-6yrS{i5zS^g)Nx?Y;AA7pPz(G~}WjCxz?($0M^I!j$&iEqT z&IB=Ner(4Y!=m6HUZ!^&Ncqz$$QtxL>Hh$O*eUekoU@*P&(86K7x*873P4ycw5_pW z8cL7Qk=Qsy@{nQ?z>ic>lp|{9l;S12cznY@3!aG zP~eD|1Kr0XwjaebBI!{m0UbdROuBuqeb5?%4ERF=f{xtlQ~OCw(TU_A!94SE{Ol#- z5f~fHoyhLXkPc7)x#wAbaW^6PvH$jn2|g{AF@+Ed!9w_Hb0VHh>$54` z8uGlN&uXe6&!j-2pUcFB0TvPb@bi*6#j@E#^Y&> zqCS;Xv_)hy!1|TNMQs_m3&8m_CBqY#fwl}jtS+g>vYdfFXxz;h`w}39e*$uUCq#GM zqx>#AipL+k<0J2Q9l)Ul<$@|>&r$DZ6L<*hAvoyY*yI|UD6xkwvPoWwpJP_Mrl1zz zgzuDqj)l>Xy~&Q_af9(Mi|5!OdlBE<3 zvb3JtlxoFQ_`%SqNV)Q+q}lbVR9X3UG2cL=kKE>A6OE2MuN;w9bMPCYAlYT_>mOy$ zKa8-Y@6S{TK`QOGL_v%o`8BuY7kq&rXTIWYi&PL%J_57o148)Abvp13<>Q%;qp(ca z0k`>}lUrXY{~@QW>9DK~O<*@oW32-tOO3;h>M;PIy03PLi0rL>k^P+2s>zIq6GOHG}d zH(3<7L}0$dOrpil+*SZUY<`rbxZoPptB?I2c!W#4EuY&I8NqBakW-im#Vo-MQQ4>N2SWDl++s9w^(8d#~7Xj b(a#=W!)!F(B@cEKf+we+4oF^pc6awbwjE4r literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSHNEW.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSHNEW.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0857a4c9143165f8cb4c033a315fd437a28e73b7 GIT binary patch literal 4003 zcmb_eeQaA-6~FgB+jYL364Er?(zlOx#p_F&kJ2uv(ASrj#f|fv*w46u3FJCXZRXTb z?5uQ*5>-*BO(w&&2=5M68WU^+!Pcc3qV3dZ8bTEc0)ZGHGz}pTlaMBaP{n`coO}I| zCfl+BiTuv}osZu+_n!C8dqv_tVFXnpJ2RWkBccE8&DkgCtlr8BTNd>CNw;K9DZfr0M& zVLcL*Y+J_k5B44!95~orfBVuh^<@bm39^c!ju0PFh;y;v^V?>`)`kN?Q?v9j)9)0W zf*1CpMI&a|DYW*f`RuHgNj{d$;C5zmgc9O>qu?EmT8146Sx$*A&_?H(LQ}xf#$jvv z!zN+gG7GX(r_k7YQ0vpiqmdEIjFC&r4d)4Q4PYtPQrC~utEb6xuN`Nx&dyfq7Ik*4 z#yW0f+_4Tun+W-0^Qy%{%^ehNYb#w~J4MKQ8W&R6!L||M^$QzsebFakWSWXH$*^ z&ztL9D%^KCd~Yj<^EHPGK{dh3$qzCbRbx4@7Pt3(O`G>y+4ujYm99@$T3IK~upPUG zD<~0{@Gv04Ujre~+%J^fP{i87Lps4-l4uwA$p4^>wIk~qwCPqkOQuoKA=;3kri!&Q z_`87$3l_Az0q_@32KFBwm?||dQ=`~eE9%x(^09Wo2E^<4hitWujctgpde(dJC?wO~ z58+g4C(5l`dNFmm{kGdLt!lxwa25jUugk{M!#-NYC<3JbC`jx{ToMV6PzP=;Q;N% zdAJXlJj0>zm~JE7gT)!qaM-lg4QNi$)&{n=+8G#n#FVKxPFCe@WYUL@hXNMDKLTut zOpYB31+~i9M*Xk(E)>^zCyF0S^dl*rk;;NZvl7inq)T+a6st7(B!s=X%B0g%Vsv;fvyw01BK3af}sBvr1UK* zUYFv#QY=c5kU~~Zw+Tf4EX7SJUXtP|k%3&`9gp#yL%j0=-YGiNBx=Q0LrNEe*PzG3 zegy$4xA<-pzXu_6GMorwB@=GwVo+G$i!xyM{@meA5wQ>b)ilK{`%lsZx z{Qy){c)tkVF7!tAQ(Q%HK{|bj-;d~&M1%Z3M0ZQkBm{d0)0z`tV1MO%QT&EKfZ|sY z-2l7WoQR4|u)CvrjgFnw7gcS6!6!^J94dF@N&!tW$�PuCY?{IgQ)BgSM78b zR*xpns_;9Lotw&G;N4DPw~c}Kp40DDr{nPPHl?Od%kM7Ko!bL$%3qukJicsk=;=R^ zR;Q$3Xbdjim*7(G2GbNQ$W3W#eFVVAufV0V2`P^!UT$q@akQ{yKBxnfkqqjneKwYNdJr7@e|0OGR!}O^$ zM)a_5*k+j0rMO75V=0aa>X&Jk-tQ}>7g9eNDUSH`Vrn6MHBb!rbfuW~r9Mnn_I`U| zx1Ex=d{#>3jMy!w)Vz4~D13OADDPhU%mS?7Im_nrnIybfJSWA9@%?ZIfrE=b=oYoI zw?!0G&3-N{xO!E@^02(5Jyttx7!owQ84i z^mt;KwTvGfhffF{zjDZ$JSBzj)-AeDH+G$Rc_(%8y`uMQZmX&valVar>%~Hs5jJ(( z)Hb{}gD`-?dN9Hp&<$qcL^NcZa=48-h5GgL;{a|Y!23{uyBFsb&aYnH!u=J{2Vg(f zcy~oH016yr47#(8`}tXE=8wy{_Ks8XY}EY%k6Msaye`ADgQOK)gjrETv-nJu`9j!f zF*v(1=F7mX@y8)Q-G!_@;@`({FZ5%`(!(VpaGSZ-S;^n-u)cW*f(q9~zJ~eBELR}^ z0+5rUIC%~oVmv1fl$>`8pIm>SFpvdI#B<4a3&%}|cniHVD|r@6ac#F-BrM zcv_={NM<$s2d{{cgMY|>fHTEJf(K9Y&NK5qAMZ>bQqNouxy`*+y%Duhv)66)x@foA zMxAD_U5(JL!qF?&=k#@nxNCEdosrc z?8`W#vfwbFT*edgsM~DeM)V?T=s0^FFaYGoI8zLnE6P5TN5&f?CqKkvWrjCYG_pd$ z%=}@|?1qf9&LW=2Ty5awI9<^mzSYiFjnjSD{Jv^d#&1s;sruP-fXTPRIiq&^gQ@yg zf9*Z{3DB>-W2>ey25?yWI#n4Y(G(eg9Kdv=F!@>6`rc73*7*4A)|uw{>O z{IskPwi4Lpkjgw^yF|DpWk-Zud3Fb()4^6C=(=hAdqenkGHMMcSu3M*j@y)TpJP81 z8=x;7c{vEpQkS_egk|x;5YyP literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REVAPPEND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REVAPPEND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2c6ad1d1c260f46daa0b0d998e87abcba9fdaea0 GIT binary patch literal 2563 zcmb_eT}&KR6uvXd{_(pYp%p7k$(F*(kV4zEqA?wYfgRYL#hFZiUr=3lg-Oc_q zR%25e)5K&OrAynnYHi|!KA8~WgS03nebGo_VxkYe+eh_LpXxa?EKtzsgMr<1?)lFD zJ?CbZh(pO64?5$i@Z5Yi=0=O^We#4AEn3Rz25)d#ikaZOUKYWpZx&KLNs zanZZ@V_t3Tvr|tvSeOUrdbA*msSoWwte^rX(nVN zlR9L#Y%5FVZaqsc21|8pBsx+(wnnORBhi`S9KLHK(Us~0FwqH)Q$c_dUC8wVkmx{e z0MVY!)e(TW&D8;r_ie8BCW7dAbG0+kZ!@a)$LodopcfbcaRw!dES<5A@# zK6l6`l*1Es$aT1^PEFD$d2K#A9*gkxw*hrb`ZN-Q_8^JVULfR847dFppyW3iMDmM6 z?%GD=L)(Z{Y458vI7fq%GzpP|7+G}wsleg!{nyZv~22=9_d!RAEp_%rQC@(oDa zWCi9(i11QGibAhYzDAEC`OG2LoKj}!5fqA!=_#9#tMth0v_D7t`v7CzR<*5cl*(Mu zxR@*yj9hvI#qi4Y>L~8JEc9{blJMTAxlGP^s!?{?_WYeyW3B38-849OQ*&IdvbbOr zOI)&OaH&e!7~-;-3&t2{)m&_Y2Xk4sE&L0W)P=H{FXmtt;Oe|;Scocd&AGl6)VTro z71!fYxY8}1$yh{&=h)Ht7={1%kLK>#m^w2L)-V~f@|0utkyQ(T*_J8mYH)kJK7UJ7 z-Ic4ku@yR!DdiXQ#e$hhK>?*Q<^xyrVmzixz_1fBkkBxAZk>{Nl`-32(c(F2DEI%9An^?w(tpUY?2c-+wz|cAvc`vui64 z&j|3Yh4E`MK&UQ>KJ)A_?Hi;)7;mhnV13|}+#{-z zpiBIo9gWDkqzVy@LW`kg&Oj!us`B{IaXdE(KQ9Khr;vM%yEHh&;bbL?=PQdwt_-3~ ziA&`R86!Q!}N4HH_-Uoz6en93`35Xn(!q}u}xgMcl5pO?W~MxfWKd7!C)En@?h zS%%%w^4Ka}Xxrd|@wd?}JvUA+`O#Lcd$sk+wV=r4UDv=SB*|cL#3&ty#$Dmh%fMb0b%0r$)8`02R2@pJ9M3SRjw1tSzW7aG~T< z%*ZCSWlu(F#exH$av4p`qfVoV>*0&Au5k|9U;xOEQMwQ?N0dA!PmDK4Mt+FKN(^r) zG_pp)O#gAw?uLv;b4z$0`_%E+Dx94rcXSuusu%0V`5|n7UpIHg?@kzr+QoB#$+xMD zQ9b{`)cRL%<30Nc(5t><>!vXVa9sU5wbN(O7HNPCz-6s6*{f!2SuhjwQ*_VPF(us` zE)urtQjVXNl)~10+Z;}hjmf1ffOtrc%i2&T$%4l>i74tYC*Yj2Yu6AP zkCcAvFNZ^XI&fEgU{#*zN6o66NHT5Y-ifEIRT*XU#L-~V51+{Bz6jeLG;>5|(0*CH y!97$v96TSb9nBi@i##z^*tEkb5ftCZbW4JA;`;HZKBjWF15eQSHhiAGy7~>$T;V(b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SEVENTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SEVENTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..cc8cede87ea3651dc0cbc7b69eb9253439cb92a8 GIT binary patch literal 2972 zcmb_eU2GIp6ux(6x83cJ{o$u%k#;OC!omP8t!axtOsCU!x4W}tW|qyPWI6^iNh0-d8(_Qia4NSB8pG-W^|g3q;r z)~TJZYU`BSWm7w%>DC~*x>$Xl5V0LyxtYEdrZ*<&hA+dy$i_e&^`0OEJE{p;1`0o9 zS0-jg5f`H_sxEfBxX;B_7q@c!h=V)dT>4?(Ti|8= z`SMztzHwUzet&-G9sMgp=F@NLVSz#b^Vb_jHe*=$_z0M4?}>1bNt;r3_C z@AGs&5kJM}3x4_`rH}I~$|7X*w$9zk*1)1{S$12rAmj!iv!z|G21W^82#=BX%jxTz z|7)krr)x8{MDW}1=bsL$F}*K@hff|<^uCB@$h{$u=mTa@@G-wo4v!Ze51jD2psHBv zploPX+<+6RI!C71RtPX2`L)H5|8sVigRi3M%@j z?8wa^qhbZfsIpQy@XSNy=qRlm)gD5a2kS)ukN*y^Ue+HoqKbvh?dXXbHw-8dtM!Oc z?5l^qjjKVcimCDGStWD}-+?86R2kCbNXSHE!V=qp5NDeZ47M4emo)&;PaPrs#1Yaf zTsV!+M3rGxF;FK8%^Gtw+8c|=g+hn&0fw$qg~LG(ogDUY*u`Nxhiwj!f1EkVU(TH5 zSJto-)^UTWS^aWUQH|KjB#j{7=*UZEe-`Eyec+bY$vd{N443Jczz8&jKUgEew~#B* zPzG5Yw!Q(Knvf2gMTy8-M2kXpQT_ogS(NL%hdjdhJn|vV-$fqg{B7hR&MzQ$?Z1J1 zfXmM#@8|p+a*gvd$on`yja=pY6!Koqr&&F^)y1|U?B}7hI6yBsLVAI>&Tt4rDm<~i zzG2X(eNJBBa&cNOLQ9N>bnNMJxN;PEI}UMo2;GAXP3PlrE7Bn9NXTSl0c0-#BR@Lx zlOLRk$sN|%3XWH&UY$%#BysszT{8$ohc&S0oXy>2=PPDX(=*aE+?*3L=>uR$+-m2W zEEG1MRhp&a33w$)N|_0Mo1^S(E2s&-*$Wk{p6y|~S&;2wJMD#?(YYhl}2GkXT@|6Do{g)iG5+6w~2(Wn}lVrg>8af^g3 z%}^pHt3)-}hKJ)ZOXJI>mjv662E(iyfkH4;5Ix?qB2vXA y)>#AXGCdyc)eO9beAei&hIOB|K%Q|_%z%Fn>{1goP0N7mkI=RGB3C9JJop!JaTMtQ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SIXTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SIXTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2e78f49c61da8e2e52f3c64e20d78abf456840d5 GIT binary patch literal 2765 zcmb^ze`p(J^t(%%rd`vfKh|d5R*%|^nt9dK4cl&7Z|S8;mfUrB7rXxB$dYu4WNm3u zoxeuiU7BG1Su84Zn6makE}453=~liL~)?hKm2pd_r7avyH4gG3;DkH zzW4jR``){oAr*&$F(Ej9Y$BJ>ObX*u#fhn+FgiXd6vn3}QyF0t=)y}uRg+%{OThzO zdjr+_8cu35lPqS^f-#jTq?0c^EChN5X<{;$2c)M5j)A^C-F>@vcU6ZZJ!V_Gr_N)2 zf!@AAPgnKr^K+bcoDh;CB?MK3c!`5pXHBo)kaa^0MPjn3NO9S3%~+-zauE}{tXXD# zw@@6P5c8SmGI>nrSb=baSZ7RkD4_(6h^kn#+%#8Xy=8hLiZ}$RNrN)s-78kmI%k=l zz#g$%)FX$CFgZV0cajkP76x)DdpXK2j**LBMET*4)_SfYdp0}&IBwmziMVy*_8@L; zc~{=GywH4<5cn@sG=XbrIy;@c45WsWl|C-Jctt_>%z-zQuLzmRo>rnf=K*ZKWq4;< z$4y8LA*EcZla*v85>6^dQn}(}p}(xLw9vhZ?kJVAcFy&RSs!a{$L zPRWiCvApxyY-{Vnjup7ohVR*6&IWck_bDJpOF5t_hyw1@|Jfl#_DlIo!~QGT!%d~^ z;bvIAl5*yh+BDyp_vD-Myu#H2No}&!X4SV7BwkZ}+1A6&Ag}OO=5M6hOT+E;Ty^8H zpU0o=+IK%});6N$I<<`%<{GflTbMVmDy*R`-TSh^b#1=eZJWt@b6&!Gp<|q}h;Hz8 zw2H5VRSm1kdfVLQ530&Q1ba&iOUgh@*2Mi0peTd7pLbIaUkR%MmJ=Gd-XD~VU|7^- zBcVY923ZHY^by^V<2<)f!chIR#!(LpUXuRpcI;C}1NAr>A+B1#tZAwystIE#VfYP|{`F9j!rj94yu8Bk}!eOe~KcpmWP~3xbTQJ0O77?*;Yy3RvC@R}I!F78`xYc005N@k6mVni}cTPCP)E7<41 zh3G3-@$hsN=BG=+s>JYEqT3NfLB?N8F1x2tmO;nd1}5u{35)y(kg{A~;$(_0XL_ zB)6D4`J3sH-)(RKB%K4YtT9FM0qq>6+n%A@HM+eYSX_vD_tA$~_BSn4EM^Ktp^!UX z%nG6~RmhDU6$+W+r~uxD$%%Y2l@^}Q0h5Vi)ERO<)f@T9nn-J4lPIAPhv{! zHM|!vUOu>s_I4tTUA4`$w}H0T!P%uG;`?Q76QFKmWJtztMH14jcYvitk( z8+HTKs7yn25QJ!$@o5z7l5401HCX-Q+~aJsE=87MhB6nGLy1@nVupk1DrVuED{Yy) zD4G?b2sqlhy3rO@=n#c(q5shM`ppO`erW@^k1V+mc&G4j7%Q6rS0Q6FZI@r+=x^s##SjEp9h${!p4w)XioSJF(a9?z(9tBrvucn>uln zI0%X;r3Vnmh^8*l4poIz!4avggw!9@AP~1o+=|2vaY5oh50o1!@9nIeKiYy++q>WU zoA=(lnR(+y;yI~CCABy`n=fSNq~bzpcA+GlD$Yss#f71{P`Xzzp-b-Z)1 ztI=GgNzY|drEEsB7P9l1)LRFot|O8%JC`p2(ccej*FazQKyPnn!+%(?a&5UG~CUf#X>54pJ4#hn~K=itUWmwWQ}4rILfd_$1t zZr#;^ey}+HvHm?Fi@EppF@eHl7O%BVY{x0$<0YgC=9f?JaMq<-jvuS#XaEzVRwTHKyPMy>}zBR=8fh|8eRS!$RNz zUx8+c&jU!M;2&=<(u@le#KJZ>Y5;tOsg=`0Aq9zRkdc;aQVia{-K(}>e z(yC%=JUsJ*TKEAx`C`hrCPyPCIupKNI}k3RLX9UTYl=Cx4HZSU9pM$$3P5i=skAM&y{H8u40?-5}rU$k#=0gSes(((*VffgFXtT(4tEqreIeSv$gaP(9I5 z!mI_kWw2?E=&*g1sH{b`7}Oi(Nwymy#>XfQ(94dHRyg+ohZ7L9Enqr8FpypB+@V85O;BCKQfxm$9DrmLuhjlDH*BfkU9z!`Q3?6esuzqpIG}| zm`fo0=4@&vgLPspdvJ0N)yfVyC6Vm1zm%OXNu}&eDc1vT#9el|-9pixv&tUnR0^)* zjFg|@wHIIn$J}~Kr?Cm*Dg0s zr>630>2!W(DpQ3A}3X?!c3UQ@_!bT`F15w<~a zDu{KS`UbCWE!|X;2mDR^ha)!Gl{FfW(Z5&(0jpjcw9X71pvf=X^5?adPa5S8yw3-I z>r{a$Fh@4TxAgTjlk37LUpbSb@7Wa**@O7{6JGm*NSy((=*b}Y@)D^pWRBer61%*! zkeYrilfvD!q2a*>rcT3yo@bZoN#F^N4{l5c^s6@QVXz{9v(C09VjUB1hUu-aKySl! zGsbTnct_xRAHypi9=uw(Vzo5CQN;feJS}Yz*2_&>u**#y9d1K{zG9cRR9Q_w5i#OA zwh!XP^X+l|-3FGw@>ZT9XM4J2~xu%HpWF Z0q;84pe9GFPO#exsz~&MZguz71C)J?NW0T$s>SN6 z`pxE7a{1-u#qlEXoJ+U=);!GTmh!ok#qo=iV=dDHfC`+)pD}<87$6VBj47xmaM5-s zW@M9^av;N$V!^&gxeTXssMl)aX7Dm-#yERj&;aD8Fje%KC2W_;Bkir0mLJ1Oo8c{m zM%F0kslP6*cAt(^{f&_5xt$-Dp~? zpZ;WO{d=(Sf&Bs))ZeppU7G|rtbdy=4^d)^6hIo_yiu7M)H96?=n45byk}Z2E7);w zxI|dNp&UQ6mBQ9MQy)>#)22m)Rl=MKpR1;=A$8K*@dVw}wVNk|Yeo~sXf$S|6zG&m zId?gBeX->W(->0)X_K%WJk&iiQpB0;wZV-V0MST1En`EOB#SQJB%&0DSw82KUAcuw zd!+PR|2Qn-(MxyL2Ug{YVbp@Uh$M@RoIBC1QIO$8Ja9A|^wLuq-WNf)hvpB+JgV)g z7g$A&{maJ_YX=LO{3?%hl{IH^N(9B%A{|>$P8=_qh>xk*ZQm6%x(#3EE-wB66J+48 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACA.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACA.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4618dd249b3358648375c28f1f451dbaa0135acd GIT binary patch literal 3381 zcmb_eU2GIp6u$S)Y=3A=TYl@(l(9fl7IxEae}MWEhw1c>Wv1*-T@aI|E?c&tW$U&z z{zTFcG(40&-uB*UCZ8VwErjj$MSX>(gTzkc^!{)1f zy0I_tSnH}t!A>j{ADNCH(VUt1)RB>wc51DAG<`BPHV(?}-C(wMbp*TG+XJh5^hiju zJv64RE7;Q2)*4u~v~Zr*Bncrgl0{KYNDWbldoEq$bIge2@97VjeoNnP`rJ7;T?W1Q zhazU!P1gps>Ext;JpMv_9NU?gB9svKY`Uyx$TFOM+j28>mR7oNrmOlb{~)xc_nL&2 zL~& zyLN-EH9_EMTT6I{8-T`Q*KIEY&c)AibG9O9t0wb(tP%CgX~w~Yrj9K=Jjc1j;)Vyk z(sPNLu^PhGxNoKFeTHpy_v3Zs@6)aBkQw&x?FYo_jrdq4FJ~37s$iAFDuY!D%L7Y= zJFwPg=#J6n51Y=()))$hO{?IF=M?w0!QQ%ir)KC8Q`W{S zaGL^CMW`Qs8bYSk>+}Jpe9yfoZu3njZt!{()0on7`i$-{n&TV`QFa1azF*&G`jG>X zN*P=(g4w?!n7xO=`rx2xb%PIkQTVVK=@XYeRT3-}ApJ*x^bQ18IbjoOJ}{(*Aeded zeso^?osxbf5>y08{^s?g+#BPYBD{Vx#HgEq#v`5xT5I8Ft;E99LqfHbZvmlv${SH! zmewU9*dGF9ze?*zDGp08BCTF2y5OAE9@}o`)j-4Wk)YWo&0x+9N;8l%TZKt~7liZ| z!9;(M;$;b@q%|r8`AvZ2XKCG$;(cJFrl2CHd2>H+)cKYUzU5KGyLt8F*k#a7S5C*L zrnS`M_(*J|6S07s-s~XOctUT~Mn~YU%Moqtxct|F*okd;B!9u&;VdaXxfk6G1J(v3 zZ0e5bzi+NW{f-&dLlItqZgAuWhHS?aB`e<)=kGwiulNoW3vR}PU#RwJ7=I8^DGo|; zNQ!4bWK`bHJ9sDGipHKoBM1g>%M;-CI?)jKL%BR4>+}@Y z*^X{h)XBcX_!_xn&I+*2DeO~{^fcV6LJnSxL==x}hT zu31i^6q5wOjV=iidK=q>L&@MzCxvTDNObrZc08)WaD3>y%Sh?jV$xQ0OH0ycC8^@h zGgWodEHTCkbaZqCidtWxuP5i{!JVf>IBFd^9~Jghv9}cv928-!URE4gDlV=CSjc~( zIP#@Cug=ODBR4?L%^SG}>ENrBFm(PzsHj~*JVOh=RJeSIBi+n5;?qROOJIW+j#(ah z2cR>@?%5a497E3xMi#iG?_)Yuuz$R`xnVcmUT_y^eoa`hk*T;AOHPi#Eijr&PH2-O tN8?&>S5QliYDQ=}beQjeS4DxW+qt<7hYuva4zdnfoQ1rNWnNrb`X5uS!bAW7 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c20aeb33961372749cdc478ca6208cae925ad21d GIT binary patch literal 2660 zcmb_dO>7%Q6rSC+6FW{C#|_R;({$@JRb=9{`6&r0LfLHAiIdH)yIyP4N(hYO)D})` z90wIuR8fh_#idQ0wmVb>2{<5-P?ZZRMU6x+93mlcffEuJBo0U*p`I$0_jcXM0aW?U8H{bg*FXRiEEP$aQPd*`BWDR|L2c`X zam13#>E-lYu=*}mH#6xw_Y}Z?txjE5?h~?_zNAdDOdX)xO-3um$IDe?P?ojV**LaGJA_)=c72Q(KU+m6{}-1pA9HbGeK?wX75TbvQ(={sP1VP; zs;^~J0pB&%2fxed)%0>^S1TY?_1WFHqWY|Me4zTCyC3Wik2%!g+DX6FtYo__j@qKj z7Q8J2n??Yb7)M*OoN=^uYeP5MQ4d%RG6HZATN|$$Jlfh@vaHb#G2MnAb>5EQ!P0DW zv4+3pEyLdm$J~XhZ`sYo-;I+MI#yn`u4U8kvkZ$ygbcd_cdV5f&)J=|^lksMuFGoL zoADC1&b(G?3yP{T7QxFNnh=yRS<*tI5wIxZu^{WBZnhdeCwvZ=sD_{@=;B03lk~U- z6Cqk7RTVoO)1_&ac{)N@gVe)$z`+RH(}#1z)lxTC1CzBcC~2Cih19qnjq5>fAH>!M z1?6JA{e9fFy8}D&bJ3njyiCv{WzsJ zVEwAFs!altJJ7;A`Azl_rb}zdt02N2hg}g+fbzFK@>xf;gKWobjgx3u1}z?kMbzm!Q~d!=;;vp z(c-6vL6Co}Lga6&5c!QBOw$7?+7_n=YrxH(gFL6zP}Fkp##Je}ZyD7$Xa@-93=N<- zWox6BAU|71@}sTYryWx?AkvOO+HsgRcVYHbvs7D5Ef)DgKAT9+_Mxq0mJaD?3tSKa z{9FS5A7=T?g8j6k?LsGp&6w*>bKPOCa}2vOvaj*H!?`kY8=l~GuBv)v}n98M5b)h;(W8qIPOoSS1@6=YhE*OS#%xEX7u>Tq1s zCnOCN$h}hHK*2~O5`*gnh=acf3$Q9&Gpr6?83qIt2nPTLry=NAgZ8lWn3b+-Qy9%+ z1-MuiroC|Cz_2f-3!`#Gj+_y2+#qehs-bE!R<&a4qG~iQSNvEJsDqP(^3W&X9o1A_ z5_O0#afxgeL*z&pr~(LU>NGgkO75sC%W->=54+8hyO5a8B#N2b0#Kua5aHC-nFve^ z2FK!~z)TUL2sDj(2%DuZ(Lp+d+Aqkf%uoT9JD4tV2saS+un51hAWjMMxmm8ZsM0Z; z9}REwq7%=cLMJI+LFSfOuA;~2FqS%rKiD(+3LT&$+pAxPqk@>@D0*oh?T7yDrn+q2 zgiP2`yQoQUFrg>LRgS=6337~jFbwA5R2+I~U;4Mr(!j1u%!l};#Z=`+!z02ca|?^b z!cwxxCo_fQQZ`ZGvzf)>B66Rnc$t}2v+VTvq4eSI!BI5$fGERq4#4E0#f>I#Yj4^k z_2=HX>BX==tWx9~7yxR$b>n!j%!G9^WW!u%>B5fwHCFRt51ME*;zs%cR`~*2h9^Tl zg*vRG3gJ!2wTqHF=wCzf6Q}?H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBLIS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBLIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a4f22773fbc7ec92f303a723643fe102dc0f846f GIT binary patch literal 5092 zcmb_feQaA-6~FhrXFH#*JJvL9()Kl5CFbF_>Bm~KkNU-VY24V)uHQ3BDuHlpXEsgZ zEOu5RphQ#HUvDmH-00n*0TUk;8WK~GP)89(LqZ@;Oq#^RKa(mUKK?+cVn|3sP|ms6 zFSQeQEvQQDbMLw5<9F^o=iKWR;u#M|)o^iUt}vaOSBnefxrMSiRh(B##fAAyPMre2 z`lWC@seffe3y&Upy1&h=TglAl(&b!MwH9)vYUYH8U!#-B;(>z|sDJ{*#B=?!2}}{Y64ZhTKHbN{FAx#JOVo1D0-D!Qn_$4;orb z4>&81-2$-$Q>LDD>>Wqda&ay=oqI7ijp59c2qnb%y4^CIGQw6QZaAxSiFP=b?aqi1 zOh9Pb8J$QiH7jVHI(A3@iQw^|VWtM75tF>O*8UP9vVl;3n!jOn4kIt6)Wz1QVDPYC=2_>S7rQvL=o9(l?42+hCsa|6b=S4Lkkeo4qm{$=B=M8U?& zo4dyLxE5Nt?#)7`m+wQ(IUR7F`%o~`#TUoAHV~X?&OX$fy)(bX!crdp9tv2g(*@ho z;C{>Itfx1x7Z=*RZuUO$U~&(V9ar*ib~Vf8mAt>;CsL<#)$R?1sQE3dq|)wj-b!6G6^50}NWijuV?ZOS?h{Q?Q>r zj_qL(EP03H$(Uy0^fV#~r;|ump{@#bKUXJz;3DK*L9Pq(I_rLs?JTjb4BIupx=*s*`&st^ zfG0l=k$Lzgyy8;o(Z<+9P80p&vCZ5pY78?R({&C)pD*>R%c5K zlhcKg8dNV9%6WAF!d5Tj7B3d(vnY4cvG-dj*LO+lQ>W5!M`zW-thip0cj+LCwK%I- zDavp>m1NtURY{Uz>b1u7=x20fP@aWkjr4|A@=Jy5BP%0c3&|^mrF=DncP+L6KXL4y z>GaHGHjOT}WItT1lxIJfb8I?JKLPP8QO&dn-32_E02JwO;N7W8Fjv@PV$i`5r1WP5 zxvEe}27(Azm6lf0Q3EI45-~`Fg9um#vC5odOOunR`};N0y&3sxNTUAy|A=}N0_8Y= z1wIfSGzoCXPQkcx5j+CRrjxGUn;f&u{49i$VHX-GS6%@599pqy8g<~4L99P;zJYsi z#oiZA>YAkoH`RSKV(CdOYO;0|gK{{Rid(wK+gBa?VAH&C)3z=-q&3!u{-%UC*^0;5 zc3_bAk!#^80XUAts}GH7$sw`)YnIxOiaDzuA)=g(j~GJWBf;^QDN_R$JfJWd&xmd$ zCxnDuV~y(3D6mR36EQ70$_41>5W=vt>ZQveK!n*S569zt`#j5`U%(4(6_#!x#q7l{ zE)Qyuyq&0ddX2PeA$%M0i{s<-66{O0yu`DcfX_IUnF@Tg^%R2R3Ar3vg8n^Kn`nNR z6j0)D9Zp0AQh=&COjt)nj`EYZdA8@7XVp_jHYnx;vQ8X9zgQ{t0>_Rl3dXS`Sl`lt zHL_=OUSo0kL)wQAkl9<}hM0NK-FWm>X&-lf>#j}{jfz1-4Gyc`F58N|3>k^axg(oKciDN6Ja(W)k{b-H!Yz}no3n6;pkGCJF zhVKmzcF)tR-$Tqxh zuJYo(|G~pv)*rk95MuDl4X&MGcrs%1^qE!?o{kBT_cSl^zEZdg2>N=i1_e-6()D=K zTf zV{dCH@P2gA&8wOG$+0_gGjrud72YdlSRfzZHdUpi&HVSADug3f(v?YHB?A)hU&;D> zm7EXNep6H9lec*e!?9E*L6mQMC0oH{Avc^=AB77{mc963fJLw3fpbx)BI9$0tc$~j zmqb;Pz3}Db>^D#k#AWf&06kgpctOvrNL=8%xZRg+>A7doz-5~T;P#Qm$DxLSPC!Z4 z_)lV$&@TQBFB~o#Y{ENS&qHMV0l?b{1*>8e_W_;|wSuSkSSM9L!dD*!>wK`2f2;hv z&t>jz#_Vav+*{AQ)Of;0$9}5ebc5mvnn{;(B{c)Z3UAA)`QnT^mwrB{9zA(nEl#Q7 zXgPX;_2E`=+dJLCUU$$GNDVSZoZ$P(l^X(q8|Pjo8{}NEdL~@iLbt*B6Ff~IS;Shs zLLc|vAk8zciIuHL`!Jz-zfPHKdlu6Nu8mm4z$u1!h7<4kL^2YCn7%Q6rS0&o&Us1(>6aP+5QAtmyJl8iZs1=W3OYU_O83TCP|S%Y2wrtP8``z z+XzvjsvsdP0ms4YfXaaj5(iXOLZTF?5ZB(gaX{jN#08Zb5(o3%uAQVwL|bHeXXd>( z@8_Fu-foe&rvp(TkX>9(XOcM~yHZ$QDF_SMoRH71N_-Zx#VmiIWHJ1$^886>WjkAIYC;^r86)Y9fjr4*xBK+k&(g1kfcW)Z%^EFW^8!K z-cz|_HYo)1sKPWJNRJ`!M@)IG&)Vs;&4fHi&mFRTR&%HC)pD=fkw`5dj3{k%*XoGuFv97ScaO=5s!3I0 zTR8sE4a^=rUGf{LJBRkmzL@f+y@ac?J~EH^0;&>>;CYH+NeM<}O&pJaM48ZioSQXp zE+9+0FCZC#u&BvKLW9E&*lh9WGrA$iIJ(!uP<^b4uLlK{wupt4;2T&2-vXp*^~sv1 zYNDDj;t9jYH-T-lPf}(?Tdw;UuxBp`>s^E}7gEoQ9Lj?yPe|2bl7Y)*%p{P|G+Eg} zZAMY|I_NsLiw#J+?1W-Xs6Gpx8Xw~+N{2w&rq9I2)u>qGJ<8iz7YyW2XZVeEB3+MR~o`~`Ui=f~I)92!_34CHrb_!aEybVCCNaTHsu2Zs;s zFyt2NUBqkv6g~bj#Pm$4aLNhR_8hv(SmvohGG7pu@++6~1u?xKE@caXAc&%HEnP?n zV-Q++Be{Alo14cCDa-6PaKo`1(lKFS78>8YkX~|n7Rqi6pxHo~9CX<1hYN;OuQ-IX z%-+oG;^p~S+_bm-z*hU@;qWb!PD7`G+@*LtI^$y9l){RNwCUE5aqx(7daaU&d7&&i z&f0JYz)B(o3$>miLBOJOS%a>+sD-60}@*!2VebtRi zdN`DbqK>lR-H#2^r7P-GRg3PM%cRc_9jNH{`aknSi`m4L-I|>Td8Xz+)+;)uCf zcO{oynMhOexpHvG=3@kvO)Ywt1Q(F0I?Q#1lEw5Y617-2&DEz>=}vbea4c#~h8 z=s)jQI8)gOi!*q^*2-fEcAmY0`@Xk6wMrb6*cZ@b$&kfe-3pFZ)}*M;n$Qf$e=(r~ z684q;$}&6mxvWFz_e*yCx@ERFUlj}4Y$pBK>NRWA)6&>%nY_>Evo<+rVz2B+qD;>1 zMzIE}&0W04_aemzzQ_PvTxO0x)t%;cLCX)alRnnn4`gm0(AAhM>d?BPGJOHcrKf36 znKb&(c<~%-En{H2Wo*x$*gOCgLM}R$PFkfptiQyycOW%OT%Wt&b@FDVQu!wU*nm}b zDd_-HxRzx{k=jQs)3uPkngnG&ecg2D;X7$*tW0|COJ1ei7CN^XPF zcK+C?h&Y~m@A*IHp6`qoN#GG#73AurnNr!B6{>UfnYp?!U7Zzb)w$WcB}@ZdxGL+0 z^7MoxpFMVFpgX;Wlb^M6b*mtlb5^a8yK=uUa9WUNW=mz*oH_-^f#H*b!$U*Iy2quo z>RQ`Y=fv>f;PCN*W8JH7G`VP%5Rxaia0wF&#C6$=7=-461 zMa-lX!?AY_3iaxYShg-(WlZN%jc|lGuh^mSj3%22U2_`T0=L8YogGPNVhU1|;tJtI zo)xstIrh$hlj4x5r8A@8EHO^rXojy7!hMIqd{n$S$$ePi5+6_UQ+p2V;sPwv=&h+J z#F^jCB1Y0ww1*Jfe73R|7e?FNqAe8v@IJYLw0uYP0wM4ZX4dHLDS4zdsw?#kif#Mb z_*^;dDQ=-~=m%K~MfY9%tb6Z?M41OpyfNOWO4r{J&eoq^aw6_ zupUZ`L8%fZV?XB7r@&%BRiu`Mz4Q=@cf0;LdiOji`Xy6O7I33wR5gbx*-SE-rM)o} z{=%_;Ubkv>p;DVWU#p9yX+aQ$`BJ?o3_~!&MeE9Zb+&+_|90#nCW;``u$;SezK}zq%|jAIS${x_I5zhPTn0h)x0(b&35Xm4 za92W?SMSskOjfuJDV0*QetLl8;KbeM8vni1=!*0m?ZbS!{>ldID^9}?{$q|EsLkXG z78J-YtC>;S>okJE$iuhnG=O-6Xp(YX>JUHp}+O zgW$S~@;Ko9<1kQp*mR{$18y=!xZrQ=tQk{Vg$0qJ=FPkKcl_~q~7(5(LC&2<*fzhzu>_72N8$OQ5Cyl}#0~lny zQXn7@xG6la-MRKI!EiwSj#A5*S#j@obXaZv(k8Ye!>Io3Cb?GJ&5luC-I$eY5R1uD@{XQ6x-NyAtP{Ji&ng!NT$G%z z&O5e88blHUhxfF7jO{)>p%a_+hS2j$3rVa&|ijy7AgI@8RzpuEAf`WdlCgD-otP07o|@Esg`60Vg;rY48E8{lZyB zb;MRmN=aFd#t85;0)9#`A+VLywRr0gnSyy{Bo);KURahiQ&;sAI51rAth2vb>llVO zUjNtb>|pzEpmW*gTlV}9d;WI`euH)F#hvBQbEBVr|F1nD{G24f^k3!~fgK8mk&Jxy zc&JH&Bjw2LJ4Zbs!_2~ob^g$B+aDe__>1A3DMt`M+q~K#^>uTG^W$J-fJp)GUgo?H goJZCs8tEh%iE!+NLZ1Rm)2Hbn@*32W>swv@ACUgW4FCWD literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5a66cd13ef664eb036687479f55d13854d1f9293 GIT binary patch literal 5028 zcmb^!ZERat_1^dF#QAE{QME~$CNJ5V7B??l(uQqe1HU*gv749Y?7iov=|JElPHo}F zQR1$uDoVPAA%+)7otbw#RjRZwtH6a8@0|@~F!H-HHt=bfclQYs}bL)QUy+84xvfm%noM1?`bSG-TAPDkFQe{usjy^8YN(m?8XLWKN zFeFXenmRZyT%tm`^d?;e5#VHAF>49MXj*I73g2N0{tylpl=D@HwBmzV4CYuRVes{LMvAwf9E3P_X6A#V2w+XRd(naYqnWS zgteYxEuF08Bm^a=ARjN^aa_&9@UJp)6AfIRV{HgDpvq(V6yndq-cgM;BK{2GlL9}+ zjv%RvwIk?Y9RQ?FPL%$Q8>&Aa)r<+Gegx(`*bBJ$gAn-*4+BMz_-odQ;Addpb6&S1 z+=cWqJB-w;JSZtGzlfcL?>SDTnHbRG@4 z%Z`Hz`4Nz-B9>;30zJbHr&!yUS)0MS!mRTI>uv>hO$d579MnvZI0WlzIB65GXRL7u zEXXgr*^W$nDWl9UU77}SpOVSQB*Dk0wQn$o@xTvKcaPa}sN3Ct0sRo&@wsM0-U~?k^K* z-(94^&3RU|2|_yEoZJdg^Tjc2Mp?>}eIoZGiamp&-^02kmv;x3MF^T#=ogljbWcRXEM{|zvKQD37{y!e8zRc~prvb$uI?DHMi@?=X4tF_ z#bD?>AB{M=IMU3`9xddA2VJ~ zd{=|=r#zc`=MEiEkvs2#IwK7K9Sq$ZbwY(^fXaba3;}}2_$kC8OERMH#qIC{q1p#X z4T#ad@t$BY;InBlA0N0`rM%R|!G)DBt1|sFuQL6fo2%;?SHa-3Jw3t&f@3{B*!uL% zJUO79YQmJ=fcBpc`73A7uK$F3(;PTFARKyEK4-l5E8!Fd20hl`<4&_8`4z2?-CWUr zz;5z-NGqRThA{zniBZBZ*p)mvv9nMc&3I6;TAK`?k^v3=dqCCp%we~>$&d3}^sH`8 zH8b!?zI8wVLXYH0V_~Cm0jQ5FlhFa9fZr zZ`%S)e8J6OUr?FLY~L-JZ(GR%mA$Bv#9^JST7nB}KI3LrFW5|MDZZr4q!*I#u9{m+UsM)i7vf6)Q>T>loDwuL_?#uLF!e0- zKei`ar4a+JQpm-g2nWTs7WR@hAvF}y;TmD>a1X-`Y9p_R>%s^Rl*@ji1Lb}74(O0j5r~|GQ*=Gc%tIf vbP|H)ksjf{{KbVKb?~L~L?s&vDmx*aoj6j-<4Q-FpKdP=xrrv#&CUM;Ztlu& literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBLIS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBLIS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b6585e600d074f98152baf7377a8815a6ad2bb8e GIT binary patch literal 5762 zcmb^!YiwIr`JQ|I$g6ESXqq;CT&h)K-rO}!t3I|;-?%r86Tj+fle!c%$98J3No`_h zT~w{js*Hhjmy$=rJ#5nk;vpo2N+llc3L8vgfI0y}+8;CtiHC%c&?fkS=#TP!-|2P@BN+gJ&va(=LvsM^%q8p`QhxSS{N%A$I9wZVN@*@#zxawbqMh4d4D9P zKi8}I`*%Ij*<@5v(xcf_Ih#@AW7$$BHU5~|c~I4gqxoT295?{m&O`h59NN2gS5uE> z1ckO$Wx5XS0hxoln(n+h&sqzTB&DS{5j09ttE5QQjM?gm>qgw$6A0?wuolui*0g0d zKrG&bp~oz9{T{VkD0+vp&t!)&oRN~mB+2@!+0c^+`{RK~*qUV%ti`%)t_g&_Q3y>t zrb}`|MGIu05xZuZFo?VHy#Ct~rl zMu1z_w%C}{k_7+YdrO5hk$VFW4_$IU#B$ev9)|UY)BP`n-wSv?2c1MDAK6X)ng?=+%J1x0)+}!uJU~K|%Py6!yW?BDp}X;PCU>=Mxe}VrwdPwT zd5v|&+~V;^!bbzx4!pfu_-Ig%dAkFE2_G{&awBh)8{p%Hj}tx)=sW8@el70r^~Usg zA_jfKPmRZAB#pQplG##@c*Mh-m1ZC?ZJ|eDcTrk+qtXQZXRSw%#Ue3pBoU7$;vQu! z@V0ogaMDY7!^5Ewt>0JQ&zc>Q#2whh9>%V89W=RmBC(Jb$L){N6MrHW)5BF=k~5@z z8)%1?VOL`G^pBoCMf^iN<~}zX{3hO!MWC;V4r}~aRfCZF0qY(QzZ2Cb70+?lVR`RpB9T2?mj#(;XA;b{0D2+DeO7=BE4b04v^CS1jcD33=L55EJKH!y?Qv76dYy+ z)vpJGfGSl~gtS;cF|aS7^4|!w5|4z0*!zh631$EUPD)++(E%-XRFHqovuK{Ut_sKa zN!uZQ3jN@ySVHssDYVM*f`zs3TC*-T=>sz8hQ$QDEoT+yr0*?U0OHStXdv@!Qfq~G zAqdN_RmshmN>3z0_q4nqFm!8BB_wIhOU*tFABHr(KE43JFS$|xm?S6QlVl240gql> z#`B=eC(rq_l?}Sd&m+f|tNgr|_%6aphBY_}FPfNT-5bXnuzSeo@Q6+4lZVvVMDQfml%t~q~&ZCJ?2x@B4=wGY7`4jaNDj;Ha zM5*SWJflI)kL_A$F<@o}`8sIpaV-c%31|)xNH?SQ>ITq2222Utg50}67JH2PkJUB_ z4YIZNTv7Zz1|1FthY{6ve{Y>hXdsSgBqCfg1_IC#Rx|qxDhW&m+h)aI+TH?%6+Lqc zJU18OC7ySyyum-_M!-5ULf@I$)W~;Mh2ZYC6(|Gtlzk?r<}lAISnJ z4v&?<4ph}}cBF9DbPcA?!XJA3y`?Igg<^he#Ma?X!LRyspmGQ9o;P zz^*wb!#n{!u&C%mRk#5tCe57erWpg+#z~Y$;oN;X9$V7VnBOv+s#{to>OVsLi#aTF zO?ISM9#`S2yN^EUUua>!&g60Oj4P_)2`lc(Sa zh|3WAkZW$KFGO4ni?+g#I;8NU4k`SoATQLWU%@i>Ri~a;%+_?Olr5=gXh85QWN5T7 zq83x9v+ADxd)2~_>JOHKXZQ}h3v%VSy-3=NW&Nmlj8_)Lks*X@;(&L}N-AskY_@7- z(MHx7e}wW7vT+$}RH`sKJpF>$d0dny^O-CxjvWKFv-`-Q?!$*WY9q1{cfCFJnXc|b zUEQ6>I%*ehm8p;;gp81R6g7khgeUejO9+^XVM>u$T#;0{UkTVH+p30Iq=cd9w$*e< zEaoPqZ0dX}i{*?L2qnb6YE?%PYRHUfsy#<%Xr29uRUcEO0VqxGRR~wTV3!hCiR7fHcS2reGn zNIGRam`UF`w*)!oZao$wFJVyNe+6`BUwTAvdI8TvJ1RTnq)SOg6LQ3fm)IN^Z!|L|7NsC2jQ+Y@SkMY8(n3ZcT$TN)wKEXX z)Nl-$AVp<099MLyCk7U^*9dT4R>OIKW=(;RY=)weu9yiOXcBUG<}-#2Q|agEdW5M3 zn4hnP4Jxlt63N8Zuo}J|=++QWbY0UWEnyBM%mD8PY+XQBha|^t1Q_ye9et}kgfI`1 zRzUiF3!Z!tP4AaYRKLbdLJ3`0)K!;)QQW%;dz&l8hGau=Loq*YkAbJU)eJ}DSui#l zL;XEkTw1;`Xg|ibqwqU|{L5NEBY(0jDE?quQOvV#C_Zu_S6EAqZSP~-_p|MdV5e8X zv)8EJ2(^OJp3kB9g@T0u#ULb;A#GpGK6b` z?L_e++l7L61bGPfD#O&l!2p=acdQk~H%=Jxg)82}jG#ZpfDCbcy&4>Nf;H|zKVR9_ z!D6aV6bn;l3q>h2CQamuq9{s|cp+0vi`@`id@D75A(tOT{Fk=XW+HyiC3%lHHVnga zRLo4ca}RBo+7UKs&-s`D(P$5AL=gfp=d0(voY&z_7;F`{X#ksSq%$!mVt zNymVdb(P7kAWX|rPzZh=geiC(HD@HdKV(C#Ji`glJfBM}jeciJ{i`nUl&)I48=PQ$aL3}ZN zA1y`S5Ar2=L*2mcXZgjM^tGV-et%j&;NATQmuWM!z#osnYdNl{y=IiqHrw)!PK}RG zW7o+)PIR)c!D`4~_Gk7S2h7?P(iPcMq&0&R4q4IVxWW7ggZp$kp#e{wvGTiZHLo8Q zotVyVY%dDSw(8xlqp@5rd+`x1Z(sM-*Vfq<9|#2O>zuoAH0LK%Cdbz{a=EV#iE%jG zjg?~fs)hcdn%(-_v$eMHlWlw%0Yv0_|fNZZ_wErT-qC4-V@8D nb>)EEt0x4r+`|7U1dnLj6Y`+WjbR0d&5Ep*+(e@Pytw!uFpswl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b933b3835476ca6bfd64980147f297d847b22845 GIT binary patch literal 4532 zcmcgvU2Gf25#Brgh?Go=j$KRsiG5X)rlxa7^^-Q08$_qmiK2D9qmRcZf{OyQbP9>k zq9Rguji#w$xB-e>+E7y1Tekrcqv=b6z;S`NZqgV<9|8nM(I5{23Kac$YTw+40!2|k zo!KQRQj{&b2r7x(*_qjIes*T=R3U+p{SF`j`w$_nD$bJi(fIA=;kAjEsc4UK0E)lQg(w<;_PJG>vck%S?q zAT%Ye5iwLlL3F`$JNqA%hval-6l^8N$!pcn1wzC@^yOE%_fH7d=LP436XMi;`*#Te z=4g~TisV$Zix4DkUOkLUEAPisEU=r)x#isDcge>nor&Ifnh^MdIGau%%5P?EI{Z@Y zaJ!Z5EMHCD_UMLm0UC*C1Qv7s(Ub|n#NcH%TJzAj4@rajK>!F~yjc89yDPQ0(nJ6Y>*6{n#mcufNdJx=#N{n|KQ7|&vAYU z00X+F)DimWepElg&D~EAJPQZ?iftypg@lpO^;39cI+ILJ)9wLK7A4Q^D?6pKR9ZS+ zD$DsfNs^^=`EpJg24AFSob%_3i?gVC&~p#lsM+_t(kIPjVT8|0`FTElk@x&VX#MZr zYDc7}uLsX`{637VKU7IzL=>aMa}N}td797JhL9n-7BcD8!n+sPrxHk*NnJ5QM>FnFeD7% zQrj)i!8@jc-B>-@^a-Bi&1tE4s{zjy?IMa@U$y|Z2E`UA=ZYl<80T_a5-gP$^JkF* zk9kxm76|C`ittJAC%mQ)sg|bLn!IWB>Iqx36g^G5Pz^flWX7~L zK7`_)+ub@>`Y{12eGr#U?5|ayAmTTTLLo!PsMs06z;+X+aKosR4JyGK1Hub06laRk zqEkKwXyiXt62`0+eD^#VV9tM&S04G-X4rphc9Np8*SU|3z6>rh;%9Z@=cw{GR9VA} z1o`!>xWRZPVJjAdvc^O!ZV1NfsHs>m4`3vlR$MV?Hv_xYtPbfx$ZL?3CJY=jk(6es znRFT+`v~D5vocARAo6E!zYgY~P^?tlGGktEw^&!I+hckkKopGlbqoGyRT3J(3ck5r z*Mm+=@xoTDV_xGXuxQDr4JH`k?jrkUb0Bq(Fn^40i=w7+HzE9nbx8+y`TW!UY#0Pf zHf}t(#vMQ|?|lC4vY~()wQFst4%Pq|T7x@;AzW`aH|eVpu0Cz2`npNChgtewm#I?wS-MCgEcd7ju+y$u5n0>IebY>#dGB=RV>&R~0l zKmD8{+}RT0>*%9B2R$y;^;^J{!6n4V{B;gEh>GrN`fPW z$gO)HYJ?0hn4>NB5EDGwFu=Up*!JNVEkv+ww|OIjUTYbnf*+qPtW8rOJH#-1?wAUJ XJ@H#6I_YpL^ap=N+>^+$Vw&Z!kMKoz5g@yxH0O^laWck)848va>VeN$&*Ez2}3` zxOyR^1c!Q_>8;frobj1tBA-0%HD;5!(}{E4-rlFZ%JfV+1Bb(h0qs3<=)jS_zMk3v zMUMz;8|oZ9a-i?X{)0WW4_;lOO<6+7IJt$OhL9#A6Z1;3$!Dm#;U5S`RKKPSt3GqV zEPCKB{t;b`o5jrsy!q_3Ka>1sGK1Hd%n?e6`AX3$ zxI`P^^v2fFR@;b&ka|LHrN`TNf~>gcj2%}s3XV7563#}O?clDCHY4YDA+;Q`M5g4s zsdWW*m2Kc@J(X5}F7X~F~%{Xq=ZHbFKJ<9T9yO-;beXoYH^HrhR>8-Y^yd3fM z8|1R3mg&sYI7rty|ldFs_^Aqz=FTg_SGU+N88Z|^nm?uRbwO$!zjq7S(QGf8|tt`*Gd>sAFGq=fFUW$%H+eDCD*eWxfZ6{CZ8IQ zN8|qJh!GnxeDWp`uJ<}^yV%wmUuQe797F7HGFHl@?v^psd~kaiL8D*w?eRhcD;wSymu z%?6+!fK3XrM%Kf65#KMK?;k*ebpY1E8H>o^PyD?lQX7yL(uLHO0BuS&5wo~GlbAep zI)Q%Iv@qm?@)m|JHjDHG-~=Q3g&h%?Z|8Ba-c=!7H^FO%@Otg>c>SKk>;Cnw=QIg;e6rGWH*Bs6OK z__RUw!~O9Onn~6A5AdSEQ!lRzd|c31fJ13usmVu$JWH@s>`5f_Es<@3g;XK^R%jvg zU2%uS0Pe>dRt4--05hpmF}{~jHAV*e=tAXR(cQe3mK6#7&Ia|Ze7)M zXkNr1+82Q98Bo;-zGTH{dedBVv)x$6yE(8C3=? zvz;q_iL@yz<%U@+q^>GZZW-5ujq?W;wgpn4_z@RTwLv2U!K33r?iEjgPZz0= zmmeNFq)ezREbXkQ$NG$49)6T~pD%qQU5Y!<%eaa_!2 zF$(}samGCU*A71+oSILdK5Ss1$Y4=eSCKQgB0q6Ou}t3Q`sCjK=$QQ7ELFq6uQo=* z+7K?P5JBM*IKTp@hYP@~g14n1Soq#|>4p*qxgy0Kh5W@_^axpVQ3is1_Y(ic_Zc_A zG5*EzXKcn%AtubocL5_GLNJ!C$|x*NE2^Wm?+>v4amS9pjK4-#PeZe+q)-kv`AA oVWkk4oaE@#&b4fK__7gF*}ffXd0Z*Se6;e(kZX9$^A8^U2P6Ty`~Uy| literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-ADJOIN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-ADJOIN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0a562c90c591a4d2e12ca09c59a8725f7ba9aea4 GIT binary patch literal 1272 zcmb_b&r1|h9DlR3>Z)t3)@r*(4uXea_x z5j0_|W%CR>bO?f=E*;D$qEpbVYljX&ry%GLu=jmarUrEhX1?$H`FwxO_r1@X5-J;2 z5`vPQnafP4azeIPm@5{9$!t!@XN$RHN|>a)a9PoGe6>$j23or#RmPr3GM5@Jq$UKj zn95I#FPs!2rv-T~mzkzcXD5Y`u8y{@XtcE|CL0O2+dpgCyV{~%?X+fRbDaxh5kg7y z8kS0g0*FV>svQtbY?x9kp1_hS4`R_NIku1PMY0U6J9cfGP{__n)2aE?G;C)kk2r*! z+qN%esfrobRA-G_;{48vT@zQOA-XlW7bB1FXBX(sId*lVL+X&^o_;N^qRsX4Wje%n znB+xzyPw;dMPFa`dqxh0Yq>ID;hkcSAGs6%FDAXe?cd?Pj{y=9V zZ>51->RW_L>Fa90hpRzoHT|r9gq<}M_z;2}WRi8IbRZKzo-*gIeN0p|wI>dTC-uo{ zPXg=Gxj1FiUPJVFsVcRiBAZH|q+`?4>8UDAmU3gvF!7*=`!mDTL{iOHkV@W1l{h3~ zUDtF;v&%gzh6K-(V4MU`kzfl6vdBA{ zU&bbdyf^f+m8&pE0^oDf0Lx>V!{cE_J)#+2xM&c#M~=dBhlF6c!CDPlZtXP^S|H(h zxV`MwtD1R{gr`Vol!PtP7$aeYG)74{LPE_X+(bf$p~ol3u5zarph}1U`O&eP%v8Q0 zG%w1{!sIypyC;OqtovgEx7Y${Pn|UneK^+u^N=1eV*otZ^;UMhCFWgXHtDQUK|DMd z)`Myf@B+ibZY$n9$lw`jnL`cl?Pjj@E9C@(jnp!S8s6K$T+X=41=l ZxQTT+VUTJ_qsk0hnu$q0+Bmzj^8;~iTs8mz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-INTERSECTION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-INTERSECTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7bd597039865eea67feee95df1d4a81deca07b98 GIT binary patch literal 4762 zcmb^!ZA@F&_1^bv^I<~_u|fjWd7&X|+&CL9^n*1L&o7VI;1A-DIJDJP2TaTc*fLJr ztV)$uEY&23&d|_zS4Go0X_GolOWdl;SHsk8zs8TLot7>?rfpKEeXpC;PMZ|5bMCc? z11wZ1LVoAm^L5WT_uO+2MPfdx1r#kanH`@<<&?~ceD*|M8O!99>CB1TNJ<$4y7Igh zj_9X+sy4X)i(U26D$YnQmCUC`mDq{Y^l0+rKBen1Ma|~MCjfc$QCN2M_IP@`yZ6`k ztI>e4wxP~Ly`JvgZqNSuFo*{&ckVOP_gxHBpjJbl{71N_JcfUWNyF+SFcNs;a zPz$lR<54|g6q-CrK9hA%q@GDlU^tW0gc4$WvryX~4{0%fIAqMz)6{0XQfTmp+(QtW zdPpZyZP^N1r(mY5$KB)hhhlmps&h4Re!>0{Atpcib0vLsfL@*=Z(kdb5*@8g)Xbf2 z=gy8e7ZdFXX9IYzEG87>ER`IIc8tH_GF$mJk~ui{m4E_%>x9=$|S+)S%GFIzE7DNFe%@Zf!*&D-E+^~ObVew8I>qP-lA2%@yL9K}LHDW*@4qgpA2N=>v@fV!|f+zcCw zy}|D$+7RYPx>R~N+>Am?r3Vp&9ru-ZlERK^c_ZvV|D90 zJCnBJ#R^hy5ocMBepfmA(zf#HUJn&RXUh0J^HJ`u_-NaNkGm^Amd{yQbI$iDm8R*6 zoAv9ui9|Slyb9&?Im)iRR+TX*y3z*f$i^R3qEV?`D7)u2P+RASO5Tlh%ARg7d%F6H zh=Sa>66ewvwyk%6i)s6~ok;b@xk9^33x^K+u`#)QYUp4lpo9)ZU6PH}NmlqZ zKh0tX{S=o7}|epTFKEdAj~P>tcT7d_D8k%%6uYUqq2Z!hp1w=<)uQC)1sunEhz zAal0PXgH|5qmZe9j>O-9d0TbMM&g^S4Z+L6vj+U|as>3yp_mV8FM^T!PW^};8LqN2 zEfl&rkZ!RS5S9MRwj=m6+kxOcb{~SbSUUnHB+tPPTcX23Z#dwtJT=HJFeic|!cbHg z(zqe|30I~6-xiWz<$KW-W-zD+y?O+U(qlrSN0{;O75O(`k(=B} z@^h|8ehP|a9xCXOcZB2*S=%Yr@-?>oD{RMJ)}{c#LiFyz%|EAke|n7Pc;Y}ZlN5nvttz&1T>6t?D5(|KilDxb$2lhsbn@gAy^I1!i<%hOig5_Q2mnyY98ua!bynPj6&N)a`M<{68Bki^I+(q{N{19 z^e7xUK@cIwhMn|Mp9+J;1#e52;L1AgEM}_<_0b}ebkS`%(a162LpSq&IHn}PhRm!m;BP@3m;HBxqBqgLZose zl2M>X;Wte8!V#JJp-mD>jd^KyayH4sTl&o5{cPj#u4C@z++ z;{i-4eGr+zRKS)+YrlI)kg_!)nXt{8)uExla3gcpvL{WJCTy2-QE;eiMw+Dta?;>H#wldHDoOHe-Y7`XJkn0WY~44sGTgx9yqSuEw`pe` z_-J7+ncXiO%q$RVAEsfmS)ej=l`A!A%v*%#-S8HeRW%k4GAsB`_f^I61W3VsqUqTf z7sf+^(!fp+@lNx2gGj_2VDS2Fvn;pT+T&}jv1eE8d|`pq^{GpnjSb@BHQI4E58CeP zf!TN+P8QPP)FQeX)7`6H$bcXIUr_^5W=Aoor^E4ZOcx#W({;PoLy!XLU(AgF>RrN& zr1A3}Qm!n})~ZTbDH)uHH&Zk6Hny{wIiYM!TUe)!?Xj@WRfNW=$n^456o!4<5`rxBcvM~&jI3md`1H;z#j0dIRCtm_>A`Q8`}F4Pd)?t zWDYXLk$I8Z@VdE0SENCaTR2y^u6T6jK{e(ZX4a>XyG4+>t&146WZ{0GAUug7W{sD% ze0nGXTK$!sFQPuZC8W#xD;vN>#jKw4G8&Jnu;lOEjVk$f&@|V)w94u)s-!NCR;1oV zgIs=*+q&|9^Fe>GZa%uuSm4Mn!6EVy7~rcL{QDvQ z{+fSpBL7#QOwA@l--k!JZ>W7U*8#M#Bak0MXvVymO0o(1x7lQ-wRK2;qj~{1Uq~S5 z>+9$K8KcmPqnJ`X1uJfaPc0+K>69{($&SNlGM39sD%s@ml;U~h5hXLGXn}kn$K2j> rV*8o3D*T(hm0aDCj;>0|Za6Fazg26sRH%1o(e+&?-@>>)U0(hlx4&CY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ac0e97ec20da250bfa9e9bb90f08489e6b9a4666 GIT binary patch literal 3825 zcmb_fZ){Ul6unU|e>C_9 zJDj4iOuE8&cM6F{6B82yi180bjK)M0zG+PSpwSQd!4C%G7yV%HoO|1?Y#q~tKzr`_ zopaAUf9^TA%M-`_YRIQ%hWDq35~IG%#Q6S+abGes>Kn^Uj1DGzNx*$isS!harb|(K zn(l6{j+RLVM-v0%iMY?4NQ}h?4&3Q$zRRcVA59OzV%IKUn_G8mYu&!Rsk%dnhJ>{h z_q4Qb+tJ#*wW<2@$yw^j5JCpY1te93c!-TyGdYjn)S{-`5e#Xvu7owemA7(kh((S? zHN(oS+2$M1?3afUk0*vOoZ&G-39*jm+#NApHG>h|D$p#gwO+~91$DU>LQ^_5BDsrJ z&^onpYnyk-JLIqyZqp1o*dgl?lboD&A0k9LgARS1I^Rt{8liztx~0Cg8`eIgw{@r^U&Vny^^MfA0b=+sj5>~ICFuL7o2!0xDkH7v!lsm1@!gVNeVu2nSk(Wg4B zFXelV=wA?$PraabOB906pI+ZrkCEfYO-L;v7t(`XUch3$BzGxau7xvUB^cPi6LhetLw6{|3 z^C?f-gO~ew?nb{F(c6RA0dkk3w};?jw*>*wJEMNd#i}F+eC*I-Yy7HWs$H_7nK1)e zMCCo^jP^%OEiBQc8fL`LYHU@k%2o$$waTvS%wsEfSJT0|N1_LcE?6`UhJJApM=KL-Hf5M{-8U-eq3oUKiw; z0P}*I666U1jtg$DAP)$zPjKCW+%68fRUG8y2azARCi#x5kgo;zx!~RxoN$7?F1R@% zJ0iFjnD+o{7-il;*6<+nhFL=g^X_B~TbXwwYuLcNw}AiBVMv677YMm$VPHCS%zg;j zF?Jo2hXA$pX#Kd>P+wKr+YRK}*!4(m=Y)RC)&oZ`@?G>ZLEb5DP;di%TWFpF(51(4 z%Jw2W4ZJ(p4n+={cnp16=uHA{SIkHlvB!Xcs}VEIE@Vf93YOWf$3o~ZHG#3I;;7w1 z-pO}`B8tgRsue!kxpU+%LB3%(!ftW_R2`vUlxq^X(XFc200-Dk(D_1|B7#sHuCx-VVM&)!;9?6XRwxMj!%H3?DY|}wy zlP@^{Pj1|o9uco4Vh6XN+Fq+*vvT&tNL+?j3P@beBw<-qTqb4IdSsSV!&nL6{HVeA z(#qX1G%&m;K7b~d^c!eV-fz%yR*v3JtHApjXd`HTO@|Mq063$j0TY5ctegvP1Abgay-7zIZsAT0< zp%0KE%zJudFZUSUeF^gDa*AZ`n;1F(bHf%^`saT^V1R(xyJNb>RIA`{x`lE#D6@8^ zIb0a~y;cF{6jr2!F994**P^p<`?3~WXUX<}eaL?4cmOJR$rEVts z^PRKA5qR|5m5y9|setE3w^#+&;8Lp_XUV#Kfk%J2!~#Qu|NO~cs};jq?u-qU&sbL( zUVROZrhi+n;_aHrHL8XNts^gbjY2_FGn7!2)u0*-m))_5sfh{nTjlxC3|XhYvfGfH z!xk;xIXVcZf0xjRbHNHmuUWjozxxfeURXAoVH^JAC zi)Addf&bRp;ebsiWofBQ&USFGZ$xD5CajW`Im!?ZJHMJk= zP`B>GDH5w`w7%;UQBgMht_aS_hDc$cB8s9Qh=_xM!bA}jlzPs+P1ldO{WF^Myx;Gf zdp_&U852puvx_4fqG~S?S{R7z?JZ#tiuyJE^)5i7d8y2-`iKy^)&Nb^c zHZ^Z-YH3(B_53&u>G<_oj1LPTwG*gg8$Yd~HcnwR+iX~Bq>Vg3?%zv@^d~0sLFQ-&J#sf0_^?CTTDx)yb?@LAqOOJz6rUai zYUy5YfM$*yGvWEy;+DtFj|nMe4wxMh1+(JY^;_%E7Qa41stGxsO|9VNPDh|GmLqr< zMtJER@<~PZ-HPnNitN6H>_n~tcWVVMRDlat;A-b^#mq={Bs2f-ylj`0EpM0aOh|YV z0QQ%k%)}jMQ{Hqo5g$C;{D%~FUo%PP$5+< z-ma_EkHt(N8z7S3dAhJFsK?FL2+oii*38x@jK<~&FlKuqDEXLQ^1{~*Ul$DOlAx~H zdRVm#J88k7>3mW>iLQig#3Z`V!j1=7m0ZL8aup2c;-Fz!aZ8OS?arhfl&fJubxuRnt)Pg~rIX*R-B7*$VNmSN7iLKsEeH=wIMQ=qOT z3=xV|q55_3V*33t_RPh~jJ+icPE*#ZsZWfYl+A zxS)SCVRE%VmkLxbP(UD= zBk~VN(uLPPD=$Jrn33NyxCeWBb``GdaS>5ey={B}3%xc%LPMI*a{S{qK&S#wpxf@1{-;c(S^^Cv6U#ASv?9>n6D86FLqp| z@l}3qNvDAHCTt5jwG)=m(|~=ER_KC=jUMSQ!tO_09E~JwZuKP~Xr82HhtcM9VKWJ= z%S=WwRr($PS?96ngwP)X$`>(hqusE$n?9Zhwl37TnT{roCE-KuLml7-8)W}-5I*; zbx$k_2tCTDJ_%Hq?1na5Mt_tVI*7 z3e8|TZb`;%Lrngbg)Q8OyWP%$D34r-A*MeQ*vW_@edGXo#;h6gC$U; z$_+Z-1^o*%DoJcBHhIF z*=j`E!!}cK2~SGJ}f%c5u%KE}X($#ozDK_&2~a;OE)k z``O@|+290*Ezk`5`^YKz*e|AU?M1d7*lFVlC~vfvr~5{kdu`eQ zXAjR?KiBj*NP-`QIEVdO04^p>;%OK&3a107G+zaSFZ+b$Zl~lqbDXmcQ*#f}b_y-? zE_PMnM5=o*t)%k(S-8=A2l9PNfA@~G($vzd!As%z4!C6~U2coVnR*fI XKHD{_0LRNYPUl7=&teIaQ&ax|2NV*Y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..57dec952168ec253dffcc04ee9b9ed789d6e6aad GIT binary patch literal 4831 zcmb^#ZERE5_1^nz=fg=!LLec9@JgX$7G{JdgN2Uq;=B-pKa%H{LO?=u90z+ic5s{m z;-i#hV^d$}JU5X~B-Ih1tH%RT zLqFN81$J-T)>a)W<0SIQcp*8gniI+K;rOu)YTKt&Z7iS8z+&rGK-)SyHg~qSZ>;Xo zVj*d5QJtqdH+OWlZ`oM=;L-(Jmm`EE$Snj_gwzp**ypS|pQ*=8e@`%^`y*Od_t{gn zRSCKH2V%NmTlJgOLT=2TNj{g%U^=7Ygc4$Z#j5NXhy=`FG-6NF)3nBZ*{Tgj{C$v` zwo@mpvSbCVQ`_>kb@)5{VLjZX8|2c3nlpsBRE*?C>gFzbJxjjy#xAy}xuu@E4-$fm zl~XCpSt5StCSVO`DjI0&`cERT{%~sdOOe}zOr^dU*~MrrtgbZeX+c?hDha6}X zVL4xJCdYE+4UTfgHLJbMA@vKNCSF(TwCfR}W+aznq7R5_fx< zE-p*uC~-xxkzB5wmdr<3FjuFOiWeNs@i*hR+T(Q7*t~=uBC@+ID_}#FA0o6iGrWka z|2IYG>g5kRvQw$LbRA({`xR@YFA$A%2XWH)d$mY+NH_dlL7+r-#(b=nSFtL1D&eVs z#|@7Q##+5EpqYVQzoDB028^YEm}{QcV9eCRj4qTgqdx9cYIv1W4WsNapKcgY!yg?m z`vy#(@)#)8__WBNU(jPdPL(A4J#ccs&|@Qi?Y47Q~hajD93A`X7nim)QFf`;Eljlh~UQ z`?18n4-K?5rkg$fuof_)0T6u~gp}Pn+EZ==i#~&^H}NJGH#m4h!ne?}*&8&3(rf$)BwiNo`Uj-_OZ-VB zP6E*t(7FvoUXX&v(eS5{a1;!?&@du#)CW;1dqB$W1tQb?kw3uKBZ%+@1WS1<021RL+~At@+Oat#k0fM zEV3u*H)T^@;%z81B;ug^L;y4*!B!C?Z3BIG_dqyYa?&Vcs23YVzAiM$C80v5`0D3* zb2o2&hOgelSFhm>O{g7<=teiM-wCc<)wZ?0kQ^_lqsh@B_^kA+>1-l1F`iUAp%v6a z$zw-y`C%Zcg%o^Z<}#Vwk#zQ;Ds&R@@#HvKsj{urCR$l@N?W6j#NkU+=!j2Jq@BWz zQhsYsGke-anF8ZVLCSr2Rs0HG-fM`y0c7~8g*AB#UUb9%6n|aVQ|$9h@xY6^;N`AG z8vs4FMGp!pTIPc41{^;eXc-Pnq*OPoWc z&|rdhah$<4!0UMf2=M*9f$u}@e!!3bDBq6@0P{q)+FwOO=d9L%p=+k@pEs>TK~p!h zP>g#~4BD-KAZqIJczoQp`mjvNd9@ve+Bye%rohmSs-gFVw1Boqv6Xea1EOdDu&3QG zz*Y|1ma_Tjc5(TzKibo{?{RpB=JWml1PwK18?e0ztcD9I??Lo?6S#Wk0`cyEj{*&z z2X(}@9?!%_hlb-A)PkE2x`c_F50kg(UU&wX2e!c*3c{}(Aw9Cw>}C8o4oDEa4b3D9 zfaQP#fItT@tw2XYHnI@>1V1?w*sYoRpn+>3R6OQ#1ChBrc-^tri^mYWYEM^CrEw1H zBDhOTYF7w(Vgt&Y1>9SPe|}QiBm)~2RptpugAdCYbilUy=blSEf6v7;6G=6nEKKCH zc*4fjsjn88J<$^3{`>ST{+R_~l7pZM6bx=L> zY|w~C!tjAbTx+2FJQ1@u&}}T|>+5)PHTQ|_qGuNrnI5&REoDXai#m$pL1o92@q8i$ zRfd{k?ctYXRsNEk%Vx0YXhD>cc0t>S(?_>mAQjqFx-PX?Vo=bs#N@%jDx=kQ*le6a zjGs7NcC_hw=z8djVq8o>fJHpabZs$?U=_9i9wgu@3ZqD?#zP?p^Ep*B1e9ZN+$Ou; zT5<6l+^i8em_Q^S+2`S$NxERdi@l7EiINM%|1Bt}_#uoSIZ$CxQ_KWjc&L&2XK)Nh z7nk=yjzUH-f=ZNk7F3Abw5=Uw6~gOrL{tNh6P~|p4*v!-0n-x(lqlT>H4A@J0hV)2 z(bkD9bK3#C% zP0vkgpKW!_O-NwkCRY==u{1Q?NIo~Jj>Qiq)y-QvaGnH0h0wFS!zVfeLkCyF^*VdH gQo0e5V={Px@rEmtYJuKxf}?Z8As5lkpB_B;FOQK{WdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NINTERSECTION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NINTERSECTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..082dcb7b56db4a3393e56178a5ff1d030abec148 GIT binary patch literal 4448 zcmb^!ZERat_1^bv=fh6wq#<1sFL_GSk2!N7X$oD~L|$HBYA5z{YCq$qXk%{T)`lbw zjti8EDJoGbZ6++q=Dy1`q)qAuY!V?L)UI92)}fUx2qAu;@dIi7fdC0Kgfxl$3Fq8v zr(P1;DypLAbME;*=bn4+%{;Lm)q;wanV3qCC$mcCRBq~2PC1duD$|)$+0mqO0_e&a zEgaFm>sPg*&M$UVN6R>)*<>P@98=6w$?37g>4%lBM-+7`n;r+`;6Ye+^&aT%?dj>P z9#Eq}VePIu`+K`T-`lmnvwHQ#0(EByA*19vf+|AXL?+fk-t9H@sOcLB1a+UGhIFqr zZ{;f?7hf!@N348Zx01_D`NosqOpaqZ6VrqeVm+I$9Ecg383-HJBAuZw>j(LofZ-d4 z)YQW|kt&N;&^op9^<4*i2Yg1rF!e}O=X&JDg8M8X@_#X)H&Ryy>E%iCldFSLysfE@ z+Ih4Jk9O2^J+8z(H4uKw^>_<%RxZRn9L}V!oFt_FY(*nYUA|@j{?Yu<_l+Bb%%{#7 zgAxU;`K2B4c9h1ik`Nam*VChWxb322`kRvD3KSaM#4(tLvc)~ACX{dzvb;0i0+exi z^@Wmga5j^gNxl4Ya(6z5>F_f&Ml>$_S-Qjw0CA>kTb+jg2 zkGz%T4g}$b2bUFrl#5y628=~oMgKFY`uchV_oX({6Q$ZX(eI~gvlhb|Qtc4?B=THt zEN<8}W8OGd#P3&NpOgY~Z6UDY?nxVV@4ghxwyP9d^`@~Q5q1|FS`_NST5X_vUcHMB zvhjnKvPw+|tu%2LwN18S`3rZ`5#g_>kk0MI2`p#E>SmpPI2qO|oVL{lIhv z12F4@x^dX_BkfVJQoURMvK|>JGt0dq{}JF7 z)`qJeaZPDKfKhZ}`U8UnPA44q8+7Z+UeTgg5j|F%Sq-0IyHF%fp z1v&Z_kR<&GqSv@4{RY>hX`%AC0FQx~Lq8HzgTpA=D?}Sv2d=jB75Op9*ttxMwT0L& zmF@Zxu;ss6`G#C_I;TvgCv(Z{baFJ8&P*yj$h&3bTTSG(J*BoOClc`Z8B@}e;@yI@ zr?4pUYt|y34lD1-WD}DolLF6WCK3}Fj#o{kCzFY(sd2%o`4&8qvJ=Vi%p|J6TA=pf zz7>4RFqf5Y9#2dhA4{O04JQ#^EtH=`Zk8T}T_?LJ@TFTc*&^97>eti05x zrka{Ar{Lv~y6VSE{LRpOXf}Y@!r)Sip9b*Jadq&yq2Qh?v%yr;SKjbTmjcq|r9V

FQj6al9i`N;Txe3!3Nj{U?vhutwm{WVlKgBKY!1$&j`umiAnf_bf*$iiPMOP zQez=bV__EM8cD|0gjh+A3S1=$q#5pacwqEFW&%?ITNQKs&M863Hl$?3nQB*uhl3-v zthJIIwXs&o2{hV4*@)PgD8|eKg5L%^1}EA0YzztxmF-A#R6tE?8Zgd-$aqeY0(b6K+668mr3zwnunw8EivYa^;_SmRY_$qhW*x;g^jM1y5qS>` ze!Hrg;Sh5|{Pf|nTs{L*a9C(+&g8dIE5hsd!DrN7tWJ*12h0d^TV|!d| zuY>I?^@o%dZ93ckOG3tY96*>=KO&@IwqJpl+oIgPZ&v$Il(E><_b9Ck+cgc}2BhWD zSq*#uwy%3F)z9+UGFX$Rp$;5*MwCw3ymY85d3fpQzxesbt+5ZOrhkMvpG3>I1eqJV z$aDID2ZDldWf{yF6B}yx>qZ2$21>3ka{XTjX|DfM6y@0K>!e;Ule#!oG&rQfGl@C7 zi_2&%s=|`rT800cDm}k>s$H1O_e82abH{PjF_%El4)*8z1zuT(^TC_oqU7Hg-vUf$ z=0pH#Vp#w?#*Zxd3-EbjZ}H!^fy*=c1Jt}j@Nw-?XCf=aT@{+-Q>_;oA49bYp_`TI`!+)38? tNU;h7%*nI6$$#JPDrI}KrBsGLm-Ba&s6zg?ocA8x+&lRp27GIE^?$F;@`V5Z literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-DIFFERENCE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-DIFFERENCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d676aa62372f3ad00a94262e2d7d6474822dcce0 GIT binary patch literal 7972 zcmdT}32YqI8Gdu^VS9aH0;EaUfOD|%IPn!iD6MDLV|(#>XFa=)<3NSn%{n%6>|i^g z6hT4|h0-n5xVZZ`1nL2*q86G`)D)0~2nrMhN?X*69!N!MD%3_Tm8d|Z|Ns7-c)Yt- zAfO`R%)Iyg@4w$YJHxc?kytP?v3t+xSY|Rfv3GjU-s#}*#AI-4V((-+6C4J5@WzN` zn>TeEk)FoOo63@|mh@z1XgaeqnA)3}+BtMXL$K+xps{CibPOt6wg7C}+Sa_awY9OV z(@4fh+ZknAwl;6x+Hz@Q*{KKTr0NOASenga;b*LxDJ*wSwmOtDlPSG38Z-5{(QAfs zGr6n}V$u7Prk%^yGzX_A_UL1oeVH)~XZIA77|VSl>+9@~M^aHMo|}~pNENxevw>(_ zPe5o!m&s&bUJGiMa@o43HoZ-cC(V@J5$)_WZ8IJ**@JV-4l?FlUQ;cjS5J*R-6I_t zXAeEoBM)4(yhifuVhkGsjLnZe4WRa*ccnCPKs^dUyN|I76iu(4|B>gA%Y?MgG2ugM-bTJSyt@Q#pajh*LEBJ*c5X54z=-qr zfx|kF!a`lHxDe*^CYw%B{$hiNce!XIkf*~b7XhnC`&YQ)_E)N_} z-QhU2z7l+wyJ*7uPb{1hPB`T*mmJqWr9)1A$_c8XL{QhdXd?HYf=Q%(-HE8o<-OBQ z?uZ=PndXs*{1aRjw0E6|DxHY(%POpm`5->NMaXm1u~vn;)9b~4lMc-ftRDz1*iARg z4>UL#?8$QutWP(dW)Gz|m5^y1*yK{u3`%B3?igs!YdSFU@de_II)Tu}St^jcD`g%C z)D_T2bON+qxg2)r`H^ZSSLg1{t_Ve}ct;dBTfN(ecf?Fv4@ZF#?@ET`D(;sn;VFZs z0-kbs0`U0Z@xkMPM}wWdCKNGJk#5~KQ~fsV)Df}Ody<36l-VoGz)?qMfk@0W;{6G| z)3SS$Auh>Mv2@A`@p7ex`;}VQ`71-FZCkc(^`{d3sgQCG2vmfO_@FN6s6?p)nrs-S zj~93_P|ihSILvF6WmtLk_1^-iZxQ-4p+69Mnb0vpKO^*GLXQx7h|mqfkh)J8 zQip{hwT)OBiDfmR<%G%zc?44aE0FRpLT?g!gV3)D9VhgtFr<7}7*f6|3@K@1xtdrk zLfwQeC)7%49ibqha|l%kB%cyUeuvO6g(3MBVMv}AhUB}5<#uBEGNFBhMhRsIZ70-6 zsDscIgf)fLC#eFBk~`-uJm*9A`;=O9i=&#Sy1iz7f)ddxwr zABMV$D*}R@{9-JwBDNS6jdcEE9;m&+E6rk`d^# zEm%y^bzb{E4X=Rpp9=pZrG2ofX#?+M4=W$ zokZ+{V%Ebq@CL4nydsOnH}NLW-NIW@_no=>p$UXmMQqbZnR>yd5{srx+lVE3IkLe_ z>Fc*rrWib)8P~eda3tdL1OiaKDx7o4GjxL5`^qd+^wj$=jj13`TcvLJhLgsU)E6xpw0^`9_q zMCEU}Svc+bfWzxiu;s5XJ5`VD^C5t~gdvEvUpWFl2PJ-0(4H%lozKnsJgQIif*BNg z64nYIP_X{kf**(6CcX_I;PnOs6D$KhpC-c@T+B)JTYyzf3TVK9N^U7ihdQ}bI@(ZR zT%<#7f;eOmQK&%UT4?c!?5sp*0}9SIb=g9ua0BovYCuT)7lM%U2~plZO;i2@$|MaG zDF0ZT3FYsL15^H3(Ed9o(aJAy+It`cXi$M&%AEk^`2szU6(vM@c&UWoQmZ^55~5rK zPQ!wzz|0WKw3aaK6zpRhc-T>7+zuWgM_&{-M5uIHu=!z23S@~-yq{l?=^?FZuW7>S zFX%7P8|6A+xCr!ucpn3$YOiHGR-Z?_!?JtwlE(zsQF@~TVFPw(RMhS$qDEqTMKIDk zZ&XmIPCUm@`cmjPQi=#RIdY1^I4)XV7H^U%)^?v;um=<S$Wdt^t*eKxuX#_@OVnuK#OZWlEu}F zbd?v4R|#$prFYk6FfP3##;f!c&L11jw0%f?0zGQr2{=hxaH4JC8=>5YEsx`fP4GV8 zYytiR(!PVV4Zx9rvv-2{9>V@kz@No8AkQ3*pB6x<5&wkb-LUq9ZXF)9(FYoZ{jZ^Y zlx+~a8_5sUbC7KHfs750;D%Gt65d{)n+Vcmry>c1fw>C9T7l_6RK) zMV~n7OWQC~^uLAU0wCEKQ!BKh_gLyg|7>y3=u7oX6Dqny^bC6o*Qkvmi|ozPy4f3; z-3HMo*i$VcFYLD{33&x&?A79aW5*YJ&W_?3z~08bVb7pW?3+G#i@rhX5tQk}9EzwI zj0X*H3vhrWa(sVr&$I89^z8wRMD#aEV&B6UK!V;ja9yKsAZ9h>idkvW&x!*xi- zkIr?hyG}On#C@i_5&UXebT?Agz&Dk$HRd+c9@LZYIX7n3z$v^u2B&A8F1%&9R7mTX z^qDzU+YUa!*J1b%p1{|8Jm%Lg+{_nhg?Dr?F2M&BZzN_V`)w0e4g3#RX1NmY*1cvg zTy4ssT2=6E2Y$!JFFE+tQ{!tPg!91T>WI~wfFF!I^t?U^i2kb+DY%=&dz#h7X=nFg J1Z}5I{STulirxSK literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-EXCLUSIVE-OR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7744e28ecc8f79a548fb9ab75a47b5c407ccf1e2 GIT binary patch literal 12922 zcmds83vgUj8NTn`JT~3*LEE&#whc(P-O!{DN@zQ|ySaI^$!@y4X-GjNBpZ{VZTd){ z#R?5m1`BH+MmqPBhVmL28AhNm3KWQfq9VfJpbj$NAfk+jq7FJZjP-xqySd3WP-yQs zFwME={OA1V{NMjLk9+R+kf2@?YYN5sHgE0Sl-VBY8|dFU&>!mV+aB7{H?X}k6Y7Tg z&{t!Lr17-|J+`jm;>yC5tEF>$rlUX86-p0ec64>@S{$mpD5P)Q-n$73D^~(pS-rff zdfBpy!a6%x`9c;k1!TN9r1z zj7VH>Hp1p1GwTOkBCRPSX=Y2SLj8SPBbzc;XEvcan|BDJAeaZU{<_w9EZvxhn?vFr zvDiG24K&6hEuflSZwQj#9tB4i&Foo~%OlGp@syE{7%+His&Ru6NhF1l!?SM?1m7P@ zgA(F8-t)vd@v$w!V^6M=+RiI06}7Jj0yYE$VHAq+ho#;ppfL3Y-#oGBu`id5CQ5*O z?@-f$M9DLPaH!{|M9Dfy1ja)T&Tcy&yF-&HPQ;z384A8VZi-Qn-p zW{1Yyu4_9;s(@v?Fwu zkG7Q~xdf`)%3-DJTs+!V(Y6GZPWXcsSUo$dh_`JqG+Q`GTNRY{^xXB3uy@>;%T7M_ zic^!(wybT%II%0o#2%ZKlgkKJ5&~R7&scONAUwPa7aeP=$W;>HG{RxmO=20 z_5=kfXx^Hg8;&L7wT*aih&1T&+9o3zi8ew_ygn6{rdS1138X?u#gK|11t1kb@p34af9!tRa##(yd82b;Rh{qNUnXX`@+^fMYtJYhq1?9&c@l)FqP5sjwwVVt(&* zB5W1OrO+VhdhYmx2N!uNRz{;%P@ZNL$kXAFQxZ0k$wV@eXic}Yro-|K;3y93@%9MS zqYU{h>=lbaubEJibzO(zEG$N8tl8LJTMLzCP*R{B8RlRa7*N_=L>2(067#s8^BwhkSLw)r$k}tqerLopz(uli`d6tN6PeI%CF@MDL zl)-9PMc8~R_^a?-V}p@wkEFmsO$OH9V$H|wdJt2Zcc8~R`JeUP(zxWk>?{SZ?( zG3QRs))O){PRP_XgiI~u?g8qcd_a`)FQ(pN>i0~&#MBE+J;~JLOnrx`Z!^UvP}l?t zn?PB~EX$dtoT+(C1(_-&O8$^2`2(ijX6h}bUS{egrtT$;=-)BuIRbSj6XvMLf>bqfFh)6gylTV(K8bUC-2RrmkYDhp9CrNW7Q? ziHk^(@E>9k{!J{xADMcSsb4bnB2!N>b)2dDn7Ws#!%PiX3%adyI;~LJnzsn1=`?t= zs*5!1v1B4Q=jK8EbgG{)885(z^$N^CwI!LTk0bRkQnZ30bsxOnX>nXaXhj*e!dSZt zc$Ao4n?&MjV3F4u?O5)H205lveW$e;t5jpSk2vK$#3FB_OnQzgr5`eNj56_ksucgi)N7oDxN;^_ek*(h zEV6T1>xr+wk@{q!wZ#fHS_^BeaHSPKA9w?qom)G$bfGh?;JHvCQ>n~a2I>e$;Ng4D z%r5HB?C1||*^%jwWOjCL8rac$btVG04WUTrn%@4NP&N1_bX8{8HGSK=u*sdM+0}tvCT>W;Ez*Vr zdy<(IH%e2`1IX8=q@X|2qWK=EgGu(^^IFtkpIy*i@y#E)-RRV60jcjzBN5f?XuH!5l&+8w!?M zh@S!0Mi85B^F&b#d!#j}=O8&^kvR-y81?K}($LdJWWxU2)R;DsdQ-|OLN>76`qo6+ zprG>2HM18?;&;dG&h&EoewKA10Mp*^#AvdaEyzWnnGJOHc6VpCXSQ@^%&ZD`U;RC3 zIqf%xg()>~5Y!=^IMfsD{rI4g?4Xh$sB}nCNyETuGUD~=2FcnA(SRfW4DDo#GPCl| zzFk=RG-jsgb<3*b^DWFn%{A15z!dC?pISk_&kqB#1|` z3(}R4Ita@=Pq4t5U95-X#?uM(L`=xz#)UjNZ0c{#AsUk%{QIx91ziWTVgE*| zS0q%d5B3vD+267MT7LlP_PiOPLKMu(ds7MFN*P*#UFsI0xMU(t~B>wD)a8>sCRE5O94hx4&dP2a7RQRJvUL^XU!qMruY>f*c&x|+7s!DTA;AP-^)2!Ip((XcRi7-`uw0BX?_Q^PW z!w@mVl-q$;R576Xd>FUNZJq!qk~9$M4}cJck-uRmuwhI#J(eRf-W`<634rl%AuEli`Txo;&i7JpoWe zvxFxM!FV8VE0OP*e6HZ@nS6w{68Unl6`a!K^^NfAfQ7n5f(~r*MhGFSi0VmdQCo~; z8s2j(=q=XZ5F0#EP9*_r=((DO(NpI#>AMydXCiGjz^ODRk`6i@>5YlxIvcHfm>Sjz z&ZnqCoik7k4abaYsl1j3HHa)^S~EC>{`xTymAu`y^H%-u&J!3siVw0S*HO$%=5<9R~9ucnKe)!Pjp2Y&d1P z^ka?qxduF{!gYKC0-9JZ#SUejz-J7M>rxg*PdA@J85Udu&l!MiP4 z^8}~j!p5Q*28EUMUf#MQy)pT^vJ_xSuhF_9jeLX~Tq4l}lI4V-d(ykT?G9wO0Wo-` zTRpK0Pe8ZlcvWBac?Vf1OA(X$`y5o%} z#v1Znv!lbOvOpsoPA9PtTajj`;fbcaZZqslNtcUGOPA&2VzSZ`%mFf%9YT4AbI&X` zA9J#fbf+ZE$zM<5LTIvgnko!aKdqSt!@7iD~d`BzsoJcwpConc(#bR1`Dr#v}*{}Zy!DK|1+pPIh{tI|-nn}cJ&u0zeM=bjM5AKY){cS01|PpW z7;|{8I>I literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NUNION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NUNION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..747671d3a20c4292475deb83574e86e0a19a8d9b GIT binary patch literal 5214 zcmcH-ZA@F&_1^bvWAkAQqX|j~eId<9-8@ntG$~m-9*+k&7(aNn2Xs{{#~92;Y|ogq z+14y-w^dawQt)8!HqBJ!N2h9=mQkr&)NE|)G_6wqY?`J?o3vkB|8zjjgNmNMn3(>E;E-?CevAEHa(Y(CzMH`D__@5 z%Xnr$(+6A6wN-}KapKuTESH#2B6Eq^iP+_nO54MVmdQ@fz~t;%K-;=H+q+JmZmsOo z!a<>J+ch0s?Pt5%I$JC6-dLu-G$ABTRuOmz@e!HWi+P_vVuT}VUm$3xA#KR;+Y5Hy z4Y8=vuwmKxx^^X(&ZskqONki_=i)4(gxD|T-F?xJ9toHsyFjnfYWrHgCJ<7GAvCSu zAduf?S$Zx(Hd>UryQ8TqLC(VKj~dHy?}nO5WHr3-zH=s`Ml{Jlqfi~aBKf)%bIC7H@Z3S*KW0ZvgRRaiJz*uz7W~X|x#)?%N=A zYzIP^ksmw~P%R@8 zwV>(fylc6_}OQ|9AA&C8em3sRts(P^yW5N1v`~F zuz8+?W+?v`l)L&&Yez)k}9Oc1m9$b5gQa(j{w!|AQC;S34rt=JA~j}u1We8nh~0idWWx&-Vop>JA%aT z3v5Y%=eP;!n*zHeKvZZ8hy{Iu_>jOl1lA(fH4E$>4(Q*xYxHm2HTo`hjo#qO=rz88 zJ}s~>3oI-!Ltw1}Qv_DQG4dhD$U9s$`5jkH-sGyui>!H$9r-F#l1z!P!y`<2lr2H0JlNZ z5!AxChom?8a_JWOW{gC+!_tqz0|$D564%)S2y7v^$W9`5jj0H}A$XSsZ&vU!f~TVy zT|_H&3yE`hq{dk-u6>ZTB2WeA1agK2=b+#;3Qj%fk&F?Pt>v2OuX$AT=R6$xItS#3 zoJej8tiX<@V4bXM)>qi^1Z%s%)W^}p7^@Aj_Ca=>r|I8zzA~4X%_*t5)O0$fbbuB4 zUv~c92ohVaXf4WQ44!@y%5+M++K_gIm-A03UqJXXg*j#4cW#h@n4Qni9P2C~r#K zDjk!m*%1#@pz)rRnMw$1es!66yYaq&1|~ZAHaf{hozw+s^@amO!|>z`M=WSjj}W?+ z1#Tk0OscxIo$Hs1K7$fE24kGc%mfe7-79uM-dXC3RRAR$QeR9c6k>~>ZHnc}%w;n( zqOe>!`ZL3eF4OrAti5Nx4fML_A8r67K7SS^l6zLV=rVEh(tY3~yDJ*hP?|r(6N(PQ zAE2HsuKNYA7@Twdj0h2CwNl}+gfXn8R&8=+od>IFe?K`4=+ zA!ty2$d&`;tU!d-GVqx!@!uE49GqW==0OKX3mDuJ7+C?IJdR;gH(_}lXTHLJzb6Dm z^v#S$#3hZ&WSHneBifZdGe0}gUQad-~6R$jFcEJtFp%U74IN`@t;r7&2&Bx|1!5N;- zWv5e9D8IBXo!9)E?4q+5tak=BgR>m>dvL4vD4kvC|5GQwe-VX7+?b5ws-pKo~$4dI%1M_GA zb^qZL&lmZPo$p!yd{GsS#bdLHStXv%OvA%vGMm1rWMWeZrTxr9N-Q<8hMZB-lZqb9 z;S-hok{?R)JQM@|*eMrI;FLecYNad7q`rG#-S-&&9QpJjz*i;;kH`u=XojPf!Mi*> zkl;sd z58LM6bARW4=X{UzecyT99h3B3;b<^CxNoR`AT=BuJTN+RU^Lh_I2;@qJTTmo3id&L z@JnGkZr##ihIdq7SzD0Ed($(V>K;w?29pO;BfZ@>t`F8;5j2N}`v>4*%NBsOTQ}8h z-MF#3pvg=`xwkX6*|4>4%hrvx)di;?nvhEdB}wX$Cb95KQi-HW&i$E^s-%@j8cmU? zWyH)@tI8R3GCt77=tx*`CsSG%9331o22$6j22h=SBa$ph&V3nQQ%5YEjMy<}Ts|ll zI)^iXNX%#h)y!r~QheE7uy@(XEUw*TY%&s7(%2qpYO>;1ENn>+O_bjuN#23d5(R~N zCVgUu{Pce5+t2P$I#*Pb%ARW^310*xX%Zgc51;x^z(d&`-eq$7>CYEU+C>209*Z8f zi=LCDvGgIkXon&L;n>j&J6BLTuWzdh&aock-CY2XoAPSev_`Is6^lm%~_Q z>pJJDGv}#WH&5M?xpfEAx&I$ot);9M_LZj>!mI_Aj+|2dxeWhbl~Sv6N(Ig%rB3IR zT6F#>rTr$SRN?ufls=V}3eF#;JWF#URg|w3Bus>mF(K!Da%ssc=eQMP_dRQAD(b14 z>|EPfHO;eUJ=J%v#|&KFxfW?(`dVidm6$A#Q40Q$=Ck^%p6pzIfBI+;JLs%lsMmw( zPf*h%IZb)eoln!O!UZ0%#F;eyn34gjt14j1pG=oXN{RD8=Ax>w9ortk+1qF_W80%v z+z3UWCf1y&Qi_FNDT1p2u0psL!4-hZ50?)v4_rDd9ZIXhW-{Dj#I0mU9H#y-tsOjx zu0+ymRTQ8o=fy=hYMHT)HlxXowlIvSs7tUi6cT0Xr|>BphNq?Yw0*lMb225hvsN>u zUP%%fE@6goDbfeLHEX9CMbHJngEE^*ggc>|(r`x{)-HMLB_ZRxCU{pqZPT!suvk*D z2ww-l<^`43PAlGJB*4f~3u-+dprSLEL|8p3DzG>qmSORPxCo2=;$kfJh~-%9;Nk+V zEF`4AO6~MlsGa^(YNsC|65U~vYnY^$Ns>&ml1YM0Qp||^)ZQng{fFLZZ!&s=(XSc( ziqRya6O8UBM%rOwq}@i0v>21H@Y+^Jmve*Fj8-x#V^mB?{eY1AKBK=edXv$!#7O-i zF;X8VM(T}Bay^rz7+uY%ol%TYJ)^CRE@iZu(Go^wgp|J$BjwM;NO_eQDUT9~@(7dM z$LJnLH#54CQJPVTQIb(Rqee#cj21Ja5@sY3Bl%?_kzXPb`58vX89m16QAXp8?qhTt zqnjCB%P7rg8!?ivBu4T&VkEssB+|P?BK?KY>x^Du^fIF#F?xp4T9iu}2 z7gfq{F*?abkSmum@`;suA=xY=p)q+_uvhCyM0Q#RKsJyIWLgWPfz%B{ z-TQmd?xL&`DpY!^5Nkn2>6>u#!ai@wXli6MIFcGQdi(qOQp2hJuxGsjU&frwB}sg_ z;#PA-u&*2TvAx0m{k#Rmx?9m?-V2>^)fv|h!arwR12%FeWLzkAanZ%aZYaiOpbeBS z&(g*CO@xam5~yOM*d#V%zopc#Dr2vTim6%$HrTPr4ItSg0_Cv4G!KHnlf@NHTr^|7 zN7RcNVL0Q8&o3IG8?hNFZBYjNOi_*evYmT4A2)iUyKr5LA=`(kxWHnPjvt4j?DIU}=YQ>t9EsEHi z?ez^Br`-69^}-OZLsia&$@{!Zkpmb4g%14?wXJa8aI@T z^&d=+rAzwHVMJjFsi)=%$!}s$C9qOFlgH2Ti(D^P%rI8nY-5R=&^~LhI^(IW+puxd zW+xNqNe}i6(#^>fj*Jd>e=&PQ;!B7)kVwYOP6(-Zmy_{_TkNnMg|UWSLS_v9BW0N@ zW{04j=0}$DO-RL4F?5brhlTXssrb>~I}3y8?|f8)=qD*M#C72JVwfCW|D}`p%zWA2 z2vTiN_ed((GdR=_X})iGa9?n!`AT$29NFr&5TOziT@y1&^ zLS{UK{oLt_KY-`vm`sb1^+I$HeQ>VT_d=SPx!4cl93I3;PT#}kya@hVtz0Y3UQ zd@OfG2SxLfs6J;LwsSsU>-DI}4yIUL^C&(a0?8HLvWBd+f5L#PsG{~Z%oFtR)`V2j znEp6ZZ=taLkTX4^T@{s-*0ev)Qc?T8Gw$uLq!e7U01-VW8c;Kp1R7feuj^ zXw9?ag!y0bkp>N}NUSJ6ve$;GnA2e4qI*>>fI*+o}>MZ-e$#yUpN$dAi_6Uxfv|Cr=NSobPzLpu?fC4NgfUxCT?J zT@h1f26^{~h(VU__&QZ$bt12bgsxGjV7c3u*q zoq+PE1#%D?ML9`1NO|Z(hC9#rXjMhz+&P;C=smkTk3fE4)&Qd7YG(l>%fjNl-0zE$#V zMp0wAq8EEYh_rwc8J?ZbNsCQ0+^W_^X)hybm*wRtKC(~>7f4if7=1oUR5EO>{BXM4 z0LPBo;MlN6G(y>k)_)#TSOXj+)zX8izP~LzGjR5DT0{u+>IvNOB*T4m)VME~?#}#9E!P?u139@Uz zv6V9m4$@bg@c_tbfV4Hx(4gUJ5H;B9%dW_Wqr(h=8A*4;g3^sHXuBadhOig?1c%QQ zc&sV!#UZT*X>stdG`N0`ONK$~V;I4m4AV3xB<0H&2uYmEA>ZM#xdi*V`NWn^;nY?` z;fO&BXZ%S0cUP2Az>f8(gaq5Z*=ay}ZKk26-?}6N1R}}s3)CEAGX!^vO_b~flp+MN z2?LJ!Iaj2>k13EJNsgyxCL-zk^Nz@OU6DfvRZUPHq#;?pHA|L<=g(i#5m%(~fi#dH zK^{z&kTglA!?R?%du}q94!I%^`l}&bH#6Y&IGO6LAq#$tV)2h~>6gWHTu)zRbDv{x zO=LgNR$n|J)if%{`6LzY(_b`O6d6H9MMavg78xJTaDop%`px^`Q@CnX_A@?we}`Z9 z=AaeZ8HwAmR``hwoLh^UQeg+^W1-m^+HQK`aq4Ho8h(bOpTsB?xH+oK?U3FS?FG2v TsFAdpMvxwa*pN@1J}vzZl*ZC^ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SUBSETP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SUBSETP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ec1d5752da2409371c5a9005c1592435b3ea97b7 GIT binary patch literal 4442 zcmb_fYit}>6~6b*KK$CmHh$rx?If)sU9usL?T|P{-SK+-NbFsEX1B2us<5#)*{$uY zvtGwdfOHcg4AOMl&ART~l=6^3Nc=!nDkRdNL@FvOLX`jksz4z40YCUrQc;0a9^ssO zcbvtxnx-Vl?3wdE=iYO_J1G$NSZGKMrDtYS(}|3lp3lzCXVnwwj5?Q|&rBrL6ChVV z7m67A7Y4M@pCMMPBd}3}ges-tYzF*a5GpT8K*|!ha_U^7d-JPAg zs`@l@NJhJ>Pe*sh?(UBET~)VVUZ%BaLdXQUiKLQ{TA~p9vQ_Jk>Si?1H#npR!rHLz zw+psa0lfrbrf%3)-5xcYo()VV&LpO>otZg839+BID*9sKP;@X7wu>}JYwYJN-(WZ} z0WjER!w_Xpeta;dQ3e!LSA0>T_i+#7E5_GdHo>0c8a|6!-MQ_Yik{K zqZA(>Ay@m8&f9@<@y?TkBwHQT*6GPr=A|;TT+;b_9qj8bdh2QO+Kn*0-zpq>HvA(( z3dt{p4>Agw3MrKRgwzmnGd1y`Sglft^f{+QuVViunWgp zZbn*)k(QN)^}0ebm%4kMmy;_^8x46OS(~aQ%xAw~ZS{vD;oda&vTl=0eSylo;L{f982?+O$8 zN6Eb@$u&v7Ey>fuoz4q)nvm}MrEafue^_#=C)bZ%FQ| zA`#&t5%~&lc#=1c^2T1?xR*CR${QczjXR+`WdfRai~U3HDBKpFFmBEevJu{bB#3v2 zxO>78v1yNhz=ZjmYQisLf}r{<{w4!8%cgF$yG_dCdp9| zg__d6Uy=^2!dMNnTU0?Gz}TWT4B9G%UJ%kxqrfEud2V<`p zHQ-F53we#VKEs#4uh65HA`9iKTq8Ar=?hZAaI z;&9qUW?OU&o^k4es$KfnNEEaf@G&^N7w~1DU36W%4S(?G-}v)S{CN*`A73Wkpaw}l zR7wR?_5pg8QmS@Qu`Tzx#PLiVK2N6Nr%uK*>9lQm({tHOY9fg#w?aAjbNNg@onJt{ z+Ag{;J)R@vQV_yi3Vs8B1PeSGcp)lP-0;fYyYu>Y=$$Dj{Db`xuES;P!H}VAQ9ZB* ze1-<2x}go395OMe*gYDHM0GiqKew%IV#`+dETAr=vPrcYj)6LrIJ=O}Ok$EZ`3@vk zmWe0G82bRrMN2yb@Jh#^Gwg*Gmq}faYOD7nTst2i)Vj@PRnUiLSRd}u4FDOqFSfy4 z%M=!FLa_qYgNAq;k{(GkAVs_{Xs;BQk{sb}e3XyaMX$nWC9ILl&7271(qv4M!(bW1 z03*Ods3PT0@T2?)cJ^hF*2N7Oi*gh8nPMP_2e14yXz6&N$F%TJAPfU>UZe1)@X-?6 z!$7KFSwb69#9k+*4>#_`=?O>=_N%op4~!J6sKg>55SCa0Nf=zWP^<^VkBOP$K@f0F zj!M9`+WzNsJCovIZ27o6D#nHWMfB^oml%bTml%WgmKb)m#9XjKOUw8a%f?)RcH&O1#nW5j_y;V;o`(N zTxI%`{|^=T-cpv=aB(ePCXtP2CgZ2FfCSaE>4~%&SCQD3Cq5ZJnMz~M8(^EC$v>Sx zi`@5@Nxg<2T|XEo4Ag2$Ayu2a+Y-Qko7No^C<^cX3cGIt5P(o-8~Glz$U;;;G=&pKi$yxqAm^r;ICWws;xJk`qUB>n4t#cEHKG zPs%5*Y})9IoVK0!GHpB7l+t7uJ&RO~f!kNJNSPc7A;2}Lhoex^uh9@dj!VHHA@Ac( z{sry=!wH-TpMZK_gMfX-*LXy}3)y$iP7a=~4+SCS4%Iwkp(B<+&ymjv%{@+!s@jwPj#erw&9 zkr&o}0_;Zj0^czXw_HA%kLPFer}JlHIP9m9AI96S=M6%}Cg>!nvUC=c*0G(Mbw*}S_5ZKiW9EJZW;5E4lY2*r4_U`T5 F{{@*+4IBUf literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-TAILP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-TAILP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4c81e2e298ebc7fa9b3e211355f3a6727e851999 GIT binary patch literal 2024 zcmb_c&2Jl35P!St&p1vT*KLzHAKL_|WV$I%8YzTB*=#n6ll9u!U1K67B*$^Eg%hWV z!-r6-s0X+#(8Lh-fePXeK#F<`trDpmKwObP;=lzi2nlhigoH$x*_X7YMd}45>)*_8 z=FOX#H}7o|?~95iDz%lhO0~2u);8;Fn{{!ywk~eeHrIa_e6v-h%kdO!wh_hoy5|(OO(o{-QC0$Od31{1}15k^UGgZT}JBG!2 zZB43{UMp3xoRtm25#rpi15-I&u~He`X>eOytMk4cPU%t>N|UEm!Uv9{V06y0!^u%; zRI=ohmL)fLTdxzspTHa=pg^GJ@>Bu724j`XL%02_Ri)zPof40X(i;aQtWp7 zaJ)Tt<79jP{jGSOcXt8=spl{sv^6sE`(n-hF|dOPL4GyioU+vP|lf`jv+-IGu<`eX{HOPZ1O zNli7Ri4-vUw3*=jG{}45^T7CaBox_FW+X$kat4f_;?A$nTre#)&2x`>SeXP32|+M$ z^8HcAAr->NP0)5BM1um(b6Y|+jEo^=a#l8HC4?4mXidoag5>gMf^tF|E>d7oI|`Gu z9d69X!#5`ACxm+Np7i732O+j^Dr2N&3soPi>`-!sq3TWdkaA$-?tv}#pcjg4s%&!_ zLi5)U$?IM!)b4`j(PR^&a(8GP;R^Rd!ZKAt~1`UeF&GkyR7 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-UNION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-UNION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..dfe9f825e899185ecdb7e5b21b9d1379bd59dbb5 GIT binary patch literal 5538 zcmcH-YiwIr`J8+G%sVA&qc+WMl0Jsln=WZfN2}7@+}xyT9NWFNNmETsspHfUZk#4g z!#37cqih;88ELxg9?B5x2M8)q8^%PTkP4)UN|ONX2NIJIAkYLz1HmN3rcu7{JGPso zUemy;Gqh?SuGbhJK)5!@fGnE~m%4#E-32ibnHIYbaBS6<4H^a8| z#394%Yu(>g7G1(gOeBZ0$zd%vm7E+NdUS`@_HoS^pBPO8@X$kmw(Z-~zHj&L*0OFR z8kE*n)!DUgSKGb^_qLYZd}*H7WEf)!wuqCTu^Of_=X|av5VN8&y}LJP=^>-v3OKV) z&Ih^Z@u+1xx!QIun;F;B$=PG+cdIVB4 zdMu{+@>b9~cXE|&d-OeeJOuLWrTLnt7;~K(W9+_T6wZ%Q*ZTO?G4|e%`;-A~V=eb! zkT@zCJN$l~vWT*X*RjKON}jP0DM+1Q4E`ah3KD0FfE~VpG)XQ3Wgf;BHk2}UHgz_2 z4dm86<*nzbtB+JIhN}Sm`)u&}aMjNkn@v3vuIf`b1T=ej!$5PvwU3-GjwZG&%|!WZ zArl`8Ce{-(QNK8_exM#qB(@QukVxIYdIVp8aiE@N4Cdu4>>vM!?klBr?_bsL!Zc|% z$cP&k2O0(%G2)FYG#e<=7Y7;jej5B0;u0AEP$VaTDAbi?N9`8UqFU{ z4{R(FVKXf>-$uHK_HaN^DC^Ix!2yac@lbR{`%=FXcct48vskYALa{0-mt|{TjIjvh zi?t$JsMhir7lI{?A#tsy?mF4?smtq2oz2-)&1el%DxDW{4FNM8>gvVLr5`dvT|vv% zJ9~i=>WKyvzwj$Q7#ZD?;M^+!*1FdDP^6@I%!EF2K!YB?~t zQEa8y1l0Hy+k5*qgIl?}TbcB*h;o8FIoHwnf)-C?`mh#`6$G;7VcZCjxw z*MQ*2I|97ATjes1s3pCNa%69Va+YniK55y5dKBsxw2-^ zS{)ti?+gd^!p(uwZlJsAUO z15U$YGfsP@r3b*0M_NMacB#=Qr!vukM8CusP0HKkLivltelMr%WKDU66qGBH_;rbW zRbpS1de2Jiteg&0Xi5)-rtGEA_&>=Q{}U;{=; zuaRl?Dw$@_iN-0>a!P0^p~Xbg5utrTG;S45yCF|kH&&eX5Ml@5D))qNHv|!F6l=F^#%MzOtTgO08H4XdIVtZ0NcwFcYql=@WIwacq#P%LA z==zkCtH>rNv)a_yXl6{?g|uT%?!Fk(n$H-`+Q<+*D~GkwG5I1y+8J8GW@iqLyyE0s z$J0|uIQ&k|ePSY+93!IV(PTQEnI^J2ksMwr*;885P7Y%TjqsT4h!mSRbbfqHigiwI zQ+nv+@!=ti=e9Nk??z5-h`jQnN`+{FGY749hbnZ&&~o`atLnfT0$P^r*{j%O%WZNG zRJAJF+aH1FY&2#=Q#!zSp$h0i{ntDz?=bG(zLJj_jPRo{2DvIi5Fy(7voojOUFq_x z07jOTUKUjSLkT;pES6_{YGOPs7nY1;Jin$zSNXY)4k#u>=C1(DK7Sp6iK8g-#=TlP z_4+*XbfmpEYuMVB3`$A0{0h}TRlNQcA-^CQw~}(7>-Zgf1;Okvr6-+>xCZBQjizlG zF-u=@VFi0*mTd&1q8!DbgB*#6W0veW4cU5_Pt$Jk8N2| z>H_M{dsfMH==pq3wL)F8;k+XW9>^pXv?T49R23J>*}XAQEg)ugfj++=VF-Q+`W)CG z^gIYEH!!m~eBihuVKWTsHN?C~pYu{sX77%M;}{6hE}-%?QdU5v79g%5?FaX&8cK!| z1vlW!C0gOrD|VvGlw{Gzjx|v3x67K7S>?i}>H1IbSK>%+So~qFogH>%FQP z{|)$GJ&8B&ki^fOIS;hEVHimmBQQ?DNWmDz*sn`I6p9~*k$_Q@MgI4lIsZ}`z(sw4 zi+U(~<(}2yYpY}-R>@)p)|_@Yf4T@g4v>QHV?I64-5rqzy8Y@`X?rVfzkJ(+x)vNf zQiN=5<2iRW1-CE|RX|)L@LQ2{0buldSYGaUv8kCcSROSyodK?l^dN4(4^k&5CDrzq zUW5&6%d5n#&I7CE({jgr*26A!d%QkBrd|c2a2}})a4P)>7ntlOt;c3sk2S`fUk~>7 z5@+nKTh7?8KCqdvpE@~X$umvY2uTc0CMUH-W_%PLXd@GuliK*uiKN!P_hZ`7*l+>a zt7S$sGnmEKH~R^7AodI_68wu+4+7B9j)`jJ%sgAyacIepTJ-F?^WwlSbsS#FUNabu z#%+skG5-y80M=^{g?&{So-xvP;kB ar<0XF4m|(Ek(hlb9_nlVGJ5R4dGo)!it!x) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ACONS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ACONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c449fae44013650eae6dca623ac2faab4bccac93 GIT binary patch literal 2932 zcmcIkU2IcT96$H=W9_<bkDqqy{)pHAT^OZ%dy0W~mvaFq{E^15FmBpEgb_R0orM&H!myR0w@jVCn zTT2^GW)>@_mMf<(`a`Dr0Ph-JvPWSUdAE?`o|*=b9x~FN_vV-7+T3oVV)LLWo5#mrTd2 zbqr|B)dhXNa-lL$;hbAy3S-_|wNRmK<=s)+^6JXVN}Km)EjnuH#}Jxv#AIsd9t*K6 zUM<=`tnby0yls`(`t`^a#?*0gIjcLkT>`*x6llB!+KpW8ZnD zrBj)``MHJlAFJbUSYI)=I{TV6rYcdaZtOfRu%r}Xtc|fdb2EJ+&IbLr4f+;P+$Vp6 z7Ls`55DVx;mY77oG)EuwXkAhD+OnWHn!Q9MjrxHMv4(PvflXzd-Xw$&{uz-74j0 zPK3&jd^=5F^Dde$N#To9_`DSMN@0%_hJ=va5<>Qg5V8+=*A(w8^X(?@>H(3OfS&;o z80}(s27(rOU8HR*?piiN7X+uk-E;gq`9&2l$Rb-kssyJ4pcc1nAX$ zUad_$OB(s4?IqceS9{8>EG=uv%SKW=a|$o_X>IPjd~`{6IZdz@uO9O1;Sld7!b7}= zro+64$7x|=k>oL+^yOpT!^&u5&sv<@|QniM=-z(%9j6t3u?7Ln)@MzSl!co2-ZtxLl|3b6< zAtGCp_6xEx_%6hn7L}p;BzeNC(~IMuFiom^7KMZ;z$Zm!fF!-EwZJjcana2H#8Dk$ zK)(>s6-CdWSL#8bB`c3EXn`?mix|=jCA1IkgGK7JBp4FlKo^mZhUf!7)E{aeHnzm< zL27{q(n0Q|HfOf0IkSTVYZsYizmoH7Dq^ETQm*iL+YWLSmwW#S+Zo3;K`7*3O7WTy zCP~7{hN`b%+YrV;&wh~|!{-DKKf6(%pWmp+UyvGKZt|Ob-0b%N5q~88eucWM9zpri zsA#XabG;}Q-C`801rs$$8Xsy%)x$l;GK-W^nbP>715~JD@)HOgyDw8i{cr7y(#|G- zPBw=&*&J5?1lQ2DVajD(p)uvBF{9F$_0gD)ic!e30+|u=WT=l?{4sTuW`Ee*l-T#~ G-u)N4NP>$1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..dc76d32428a25b5297357b98bf549a20807ab46a GIT binary patch literal 1147 zcmb7D-%ry}6u!6n4Z{p{kPw3n35hnAFn$;u52lnm*y!5P-UfLxWDK@su(=;5Y9t$p zzF4D!NLmg5gRh8@2VebT{15Ql6=%fNsBdjPy~`)=^HQ}| zDnl?o51)zT+;nnwcCs%e8H%g+PtHtoW;!`DHQ9G@a*SgYgis!xvsVP681fvkX4nL$AMN zxbSby>(NNHFYV?78F+`bx9$*xR{2Fx@-uXADkN$WQocvqE4u( z!{&0=x}dRPP?F{F-w3J+PQNeYM0{az>zY7xUDHL)q&brcz6cPaf~0PU-Mk?EA;-@w4>R*#f>1D}=~;=g&jZ#}Hg%n-o+EYeW60n5y^kyz#O>nrXFwt9J(mYg zeAbEIapGf6JiG(dKzE);aO6Riby5sxM25UyH5Fx^0hF{sb0S0`gX&;VZoC_BWEV9h zH^O4o%q|i=7umP1>)vKOyB>VvnQh&og?fV@-J+iFj^ zFmJKP@W4i07{-uuv7SMHP10&(`y&8g@-bN_5+&l5vr^KO=*;+j1_Q^}OpOv}7=2i~ GxcCXQeo|fl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..04d60199fe87b3075bdd7f723aff4b849a4fbb5d GIT binary patch literal 1131 zcmb7DT~E_c7(VS7>&C!A93;eGgW5Ay#PYq~F}YEx;qtPzf9pvZhiXhWslO|133308 z*R4~WhtbqIf<)YGn;Os3b8EH!luLW4pTx=5X2RgF5!0ERsygrkvivmB!p1V z!R?l~c`qPQXU4R0D&wEqyr||_7NKX>83+#{e);!2nrf4iDnVBkGDxR8xf>)Wg5>oe zITR$NH8=^kdwBq>?xehmVFv>m#5<^C7*m{J=r+q^KoOf+U`~FxjhAvWrjZ}um^!%` zV&$WozIW-gkj$@yoOB2O%+5EIsajo`tIgL-Wn~I*<+5Sf?8=~S4EG$)wL0HeO7-$Y zqdcj&^X0k8iA#Hx+#yAutyiZ(ICv1$+(3WtKwn=^YhHJXVYDCm>>JnzKK(tdD|eP@ zszwMYk=J;%5RxJ?2^Rg7>N3aG@`WPPOnro@K{N0Z(2M3d%ntmHUZqi+)uziA%hTA- z`8h%f3I6aCdCxT5f@KCvbb%&=TYh`N)JCB-{TL%sVl@gzr-9#|>(};cy5m>|xw9O* zMhI=kLY`M%4AEyZH1cvtIE04FI5EH=Q2|}>3YH4e; zlB%YN6b=6LGpb>kM+^8#wL#rHT4c6%qyUI{%u%HX%&J2*bk`WvZ0344d}~7tE9Q(l zE*p{P_YBukd7B*PEph_pvqfdLZP}XTxuc$|$}QlKRCRM)6S$*t7*r~^Y2I;}5FWuH zCt+&jGX#p|Eqg?FQT>ET4bQfj`OOk>injm2wr#y9Lw8u1iMOHo4Md8HjX>=oPvfx| z9@lxg!PBRBy1>&1czO>{ccS$@x`<*?dk0$>GqIE+s&DxYJpKVrgdGpDS3r@6**F@W zgF$9vg8LNk2(Bg?9`K!b+~*?4J&|L~3j^H6O&2%Bv;_GUnB$IX!&FAm%MZO4_^vCw z^8%(YbbE$(p5z&icjtM=;N5*ZljGf4p4rX2wxQFKN^&T~6D_5+{Hx`i1{0OWLIS*D zWwGi|U*(K|My20EOvv#1%2{f`dC-k_>u$k^MZPQ{F3of(u RqQl#O#8`vTDM-^#E_kD9a{xztD&ufc9(Xvi$-@tYqqN0Me8(es9QH}6PnQ0s+y+k|9hVA zJLkl9Rw!j^6k8_jXRq9+z;Of;gz3n(x>=Q5~Nc*s*)0Ixsr4x4OB0vOZsuECZ9{)mnXi&DPH2M~)60KJd;1 zhY@FbCJ2L|{*n38j>*yCiQQwP^~La^aCLoQzOs9CV4p-A+F1>vQo0MfhxPf@Tdo_p zUUzrbMs|+}kDp%kNDvfOujz>3=GlXv-xGfBf#7{#*c09U=JjjB!u>(OjY<%lnfknd ziytXo5+3~AUF~Pa+6Dgm$&rPz_Ads($%F47Yu^)vnt1Z*%Wl7tMY>-Kg4Ha&r}NA+ z`NvyGghw+HC9v7MtwHXIXM#sEET7FgpT7SB_`MgvUvmNcWh>(!I+(p)w!m+4f!VJ` zV!%|R(OsFi<&}y4V2K-#X5v=f2;$~$%*1VbBZ!;t&%|B*Mi94fc_!|vA6Rjfs&84Z zT6E@MM-Z*5KQ{m7&BJ4(H}9sb4D1>jy?LZs8`!>En9-f%o1@i9Icn3pqIX&ElHLWq z^QvQOHV+R?4DTAKRVOBEszbw8$O_~8$0w?LqewH>dZim4sSb@!?i<)KR@*ziISHe1 z`Ra+W%}HC_o|NN@RM*-!S8KJg+Q8W4#J0~`0Cmedvp=pQib7<0`QHO4D=vs#= z$y$~dlS}lG`&M!(AAe|5a%XHx?o$qZ(xKB1EjaX`L+^6vK8NmdXvCqaLzf$&+&U*z zGD7iR*_8OpHYGme&}SX`q(dKbXu+WmIP@-ujym+C4&CNZzY&Tz8KL+xBNY9!O^IHx zDbbf5dfuVWI`oV~A9E;i=mQQt?9c-a-S5ziMkv~5grdzxDEzif316});R_CZ&7tQV zdd{I|9D2&3#Gz9Tz0aYaaA?#Bg?o%pc!LwF_>|bD1TPsB{HsG>bLguMJ?GG~4n5`2 zlMa2vp}A!J+mp5XlS^(%F1=cjyLP-fv14F-|K9CmBLi7$xK6H72<3(OeYLTjqqxoA z09o7seMOCAVU$3yxcFjnCC>D3$rXHj-Jw6XkNCe08UKev|L7m>j?5brebYa#GGuhA zLq+=t-(twH*P(UEmA5H!Dm!aqN(IDAvhIhIE3Qwj)P(ge;m2X{rTTn(8bO^*>%1Q9 zi}m@dCJxLT@7(a<(1y2X7Su@og;LT}LRzGPFfslFJ8`qZ6BceFuS_jvW_)u$~sCB2$c(i&~wRu)cth`^xU zn>44FRZ6?8&1>&|y}Go1Q15PWyjaRtbNqup3eK8kHJ3Z`Nh{c6#TAUOsHtw~%{okVF(NJ6|#JL#o;ril5(g<;)2#}sD z+6p~wNTk=es4+T?gdxDX9M0nky`rHxrHZ&<%_hNSffDq)4I*k}y?m(I=1J0;{6p4` zY&}uOYO_W;XFA6P`%K%4r$U~4+OHQrqCEB!H*!H?pdmPBuMJ4^lcv4blEOPBuqbBg z5SBecZ|*;rYvBzRC%2K6F>v6W`$%Nmor@NjmNH&n=GXu3yu>?>PI z#c+VbvA1?qhT|@@l*{-OE~hd62_C1#=6H(s7Yr|QWC@50fctdSr_Cac;0;}fPw_?^ zaGw>SaOCSWFQch;8uG|uUc2J!)N-N+UPZGE9?$m35e;$4J-kkCA6=(&j^l-1&U-&t=TH=paf~V!iCDDt|~mbYMriSxdQazrDD9O zJJncDuB#H5jlrnBWY;Imw5Y-4xiea`a%DttX_eWy<;_4A zuw}^Em09{@%qby>w}wh7s~&#w@294crr`PzVkkYfWty5cd#jA4Cel;Iv6|%f2Anof z<*k@<;6zA8LRJiULdx?(Dx_|xq>?&L%}c@TL-_?uK~ynpJ8u#F9H$meThwm5Ifs!j zrBj{L3~Pw*^1QjvpLZq~~jBI{ahH!Of7G9O_RZK5G&wk_=6s z75|L5e3|r2Q)gcdv4_a^tb=Z(h zWi6XJx0Dv&Gua^ zKgmBaZKI!Kq#Z+YRiuWhoNaqvwDEAwrX6a=RZCKuwZ~dEL3yM(w-K2qnsUi=AoboB zTTVBZf6w-RH-ho-ESk+kq(O>)+@Bp9uX9bhEneQjg3f)JFbhp{sETFSmbBV3;XHLT zRHqW1Eo;eH$~drfkFsNS_iU4`|8>n>93?2GJkzJw=E_5xNKfRvJ)1K*-6_2$xjVWO zyW_f>wq)Y!1uIr`{nCoH6>?jxVuk;y^hE!_DcKrK0OwC(#Hmp&6e)}ro(_-JNq9eG z(Rb3Ma9UO?%yhL(6b;VCY9d7`d=WLhsvZ8tT1NWtl*ODW&=^#ShsZZH1x=cxhN_5d z2trn%?NLXhC!HpNxQjJSB@Ukar0D5GjV=GYr&*!|(&^KPsSzq_BbVKd^K?coG18Ok z{V9*mQ8_KNvpuRvdu4d02cs-taXNW5#ykk7mr84ei}9C4*z1t5ucQ`esFQP(npDJ; zDzU(yqF5fp;mx6ntt`M{3(@Vgfq$bYbbuy!fFhk^1lmsKsP$zQ9VqQ7v*_SOhHn_? zq@uZYD8aOR^TAl)KM&dQNLIx;CKZ`O`N^w|`05F|n z0v<6L%!kDw~9hD^g5<}s^shK?W zv>3^bG?C<%fk@j8^Kdk67$@QmUhzw)fH`budFhKC zEJXRdC~;&ao5?@E@N0XllGhwg?Q(YClJbskTAX2C3K7n3YAkE$M{Sau?SjJbdf4KM zTN^)Kja)XJcF`i=HxUB)kDFrMgI*&NN6k~Qe2aoP=a8Bk>Lmv(Q!c*MP;GIkVzU@N zPp#C?RH?b9N^!JQp-6q$eHv?cZX=)YY$?3$f?ZI!b7>c}g$2Xj1t}2P>Es6OfVe4U zydmV;Z`VHl9iDVsx7TOa!3a#3&Fr=_zu)b$UVPB-{d@-`I7dm>+*i8pzvN1#I1Gz9 zcKH^L_&^UFz`t7*UYrMEjy#?0&lf1}eyTJXg>wcwF?3#_n+Gsma{b8%*Fn7t+*tg8ocAEx+@y=v8!Z3zNb7SB?(-ns9L2_NspO zQ1xFD+Rr18H@-)meS!MH@$@UzgIAmm`W^^^tL_+D8=SdGKNQ*ZJU?AL_vy7@`B}`` zVAtB{CjI=cLq8#@&#ymx_w+mNy_@f1Fa14+ezh3c?=f(M`S1?C_v<0sWAm$es<%~Z z`v=DLBa@Np8htCLO}|l`7#OLJ?wr_V4@~2ygYfdx!NoU;zJ9Z!KXIX77(%kUNwPUw zfq1B|x)+B>#>OXWRZOG5`SA9rUGxfjt9!RsYi$}{wB#G~`W+?Tm*)o_d2Nv6JLnSR sP2#&_cx>-J{cQ8*fpphU$nx9wP1JTxj_%o-TiFP~FUZXCnRDm<2hNa~U;qFB literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..efab7bac3af922af5e7709d7b88d64d169dfbc93 GIT binary patch literal 1171 zcmb7D-%ry}6u!6nJq8(sK|%~RBs|zyVqq8@52lnm=;+$n-UfLxWE8e!u(=;5Y9vac zFV^TlNvq+1@D(xg;H!U({{f!65&0nr@u}yY`pv0nL zR@I28%XuPrZO@IuETU}@({uYL`DV2yR-7kJg^jb>Ko}wKgB#7-x+%TPo$E9wSC2m9e2=%vjX`c^v1;lnNT_Ir+7 z?i=aHp$&xCMK40f{}Hm1Uq?_duoFq((%}ys;@|D1clu9ID!tKj90tnW($}Hojv=fd zickV%%Ef_pDOpY;F64c3ZwQK^&#P=gaZ%RiHDZc$DrEEpOW=ZFUB95nR9O^FLTwX9 zS32H>trd%sJcs{9P($#00uetJh=N^x0x?a)6b+jeY$^m|P>>L0eMRi#Ex`xhlF}vn zBLRf`AoD!R%zF();jCfiWy+2_OjNN=lj!Gm>f^_dA3U2!kuB0y@q2Q>5WldP`+h3z zr*8SFQ9l*kfa_4Fp+~Uvu+F43%O6%CAJlD4n_&P=wP-o!-?GM+x4I9V<+jK3-d-SxxvaMr zg85%{Pu@o^;0CgW0Rgw`V!7RYy^Ix77|(X#tngYWW4*)R*KwXo1AM#-zf$>(rqefL zAL+s|hPx|jPAB;b$KDrjkAvNfDkhOB5ihM!QzT%O AX#fBK literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..77f53c11463bf3a1a21d023ae9b1528b0aefe96b GIT binary patch literal 1157 zcmb7DT~8B16rI`aClpeMg@hQ~knrHfB^HW-@?e%_3N72+Iy)QW$&j+pCWY31n5dB` ziN3f-OO@&C2 zTB|ATRO?cs+Nu{FX$SJsQ_ZC0*_x`Y&nzVetV=t^y0g`Ewk6hb8rxfsZ%N5TNv+k( z6$lmgp*36~nQt9O4%)t4{F^*ReLPhkQ|Dp)Rk%+t_H!d?` zF(s4LiDIaEB71Gmjer)#wg~myky)u(ttl1fkyGJv_8JHyj33ac^vcKy7$}cQpT{=3X7GXt zLNRDlE{?WK@p2pqLGOcmUDixvCCk+*YpSuL6RIp{A!DpsvJe2Q}zeNupbp8VAZfpC^e~K+N@wRS&TwKOjeCerJJ{8A3TdEuUH=z z5%L4v?+7>VB@l%&Ce5piFAsTB&8CzXm*(l?hmgPaSC6Jzq}RnC%mG96Vkme0M9NRx z^b?bQBC-ox!R}!mz_3FGZ=+lOxCZ%vVe9$=2k2Rg6%>fV7Ng)!VX7N%=9f*qFwSGc z&My;Mh#r8Ri%t^16;kqv=iXpWqbW@ts8iC;7QB#csl4C2+&p(Mod>lqGF~U>y%#Ws zk8tE-wcWd+oCQ*%D`rg7>xcm?aQISx@Z0^tr~89X^asb@C$A&G#3nULR7R95gVVE& WP(Fx34uc8YvrR_)G4xS8KmQGMmr{lR literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..21b797641a0608bcd8f03aa496708bcb9a00ea0b GIT binary patch literal 1575 zcmcIk&1)N15Pxr1mSx!qa;TCxmYTIm4qdt?a-24C4q>}_ie<~Y@qRQhEd(RWk%}F; zvQ!B9#D^Th_Cq!aI|(6&9(pL07IMfJNuhy2p@$xN=%G+3^w3l3A5izrdx@>shhAEc zG;e;t-^`oQ%x;TxoVJRZRa;oB&X?<2t=U*?Hnh1~U0bR(>!q?b$8qg~<+$w9m}yN6 z9nB@ZHl|cB&os)jn%^uh&CZ;EQ_CIE%*A?jo*xb$=5B8E(D3NU$WStGdPSM-UtSV+$iiF z)*7`%W4`=Rc^=zYSR#~==(8}94{XaXICiv3uhO3A({NkCHcs-^%oB_#i5FQgJB`Bb z+#%yF!!>ZMDcr8e0qqi_`gSF{$za1 z1^)}ts$8u;;+c0WclOZAgC{mW|Jj=O*#3@?R^^&KuF!3StW>_`X zT9s5aMU;-{Mwrnp$39-bf8H1~?c+t}8t)W1VxRDICB{eEt6QdTjTtWU1DB7)5;Ki^ z)1J>J6}na7J34f$ozSHw_!zhA%yk{ta035i;OlA^59rZNd)g4Vrvsm7Dz|AZI#og- zhP#l&+3w?s;(5oNG<|dj@KP&qU1qoK8c^g?oO^AfC(HDhya~EFP5!`4a&gf85z=Vx zOLJG6Ymi=m^m~vlK>BS+?}zjNW{&gF4pB6Q{LPm(ZevMBbpL`~XnyCK7<*S@zj28= z!KRV;l@ltP653xl9>YyW;s@A`=6mQv^IY69703k7@WBudl~9l`OuLgE`tHsNp8Krw)PLZQl(M= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-CLRHASH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-CLRHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8de3af0b90dc8f4fa7d48aa968eb1447756e1031 GIT binary patch literal 1731 zcma)7O>7%g5Ps{w#Bt&}R@638)NcMNSg{FCLKIx7(#!TacD>#;yX%^S14M~~jnX)B z90aNwg-C!9D}}UB_O%qG+_*KlRW0%XB#vCTazWz8p_Mps2{XHPVhR$-($0MIKlA22 z?~~x`iYhAA8yl6iQcbLG)i<{4;%c=fZdSKy%O!CYc^P zSBO;!A=`xId_B|q1)NBdor4wht}vkBfidN6pSu7c6VY%PRNRCq^X%E z5AKF{2@wu@V?M0rarsGBc(hIqzsvfHeFMEh=xsvQg6^jqYK}L6Eym#!A;ja?JC06x z3~>V5jhcMr2{7^9j$Wbs=*?(Dj{EdKA{KLhyBH~7!35Cgh1v- zW%+#LkUVQEQaET8*$HOFIQU_>gF|AsFx2++=w=I{Z}RA!7DVHt#lN9z#WeW&*LtB1%U$WI#m(u0SIAv)Iw-ueM-SFnAUbvxPZD_ zpzAvwk3vo6rR5P+r(k>?^UT5~5MSm4NG3co;*oP6>4B^r%_{;%k~9{87u9&l0W${h{+!q(=2F)uBSZ3 z?|cLmzwl8cKk+dnKZ2R>deO6J@JlFjKo&Kb)iw}M{{a`@<3klb^cH{N4L)q~7j-@| z$46)Q*aVj(e(56gA2FCaNHep@1^@?;2|--pL&v^ol{V|*@HQP5SC`<~UlA+o-iwX0 zZMUS~c8T!OH(1EG&VA<&_IE)s7`2%E+%~Bhiy2fkc?8YiAYLoz7ULrNe(u=g$vFnA m%Dl(f{l}@Fq;KWjHk*}<&%1d8ZcaV{5&6qpB==^IkN*M}qw3%Q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-GETHASH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-GETHASH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5a3d0137af9029bc897192e934ec096fe4c16109 GIT binary patch literal 1594 zcma)6O>7%Q6rQym$BrFiM^Q)@4vPR2H@(w*W0=>w#$qdg;T@$;lw(QhDtUK7w zon0aj;yrL9Yqq9XMP2ibgaaY&-FGL8np}a_Xr7TkWS9lB3!WR#zA0zrJhKYaERcuC z(R+jlPAVBdHa|2@O2VTZ^39K>Ky`XHC4@g9#2KFix>J2PR;S<-Bg8*DGv~*h(3A7C zb9{ardN)ttFm-P{B{Ux0PW1Hzz|%wZzMgnY$YJACJy8k>P~`C2%hgNB1MCq(;!vo$ zIn)1+Jib6qa7N@J;8vZ2I84{OJwndRX|FN@Kl&Imcjr@ib5fIRKJI6&|L&Zzim zfRRh%pn1@E`upE4T>7^bAnW=p+;zW^#2fkCy&@^Pwpzq%lM7T^Rhc2L6hWiqO(_uO z(ZCq&L`qVqr4(d?S+)UpstlGQY;KqqD+dDLG3{@SqB5%46?siJ%BIAHfbh>~OP6>o z7zINN?_Rd(ipsL*TZa1)oaE793^phsF~iUeS+}iCCsBO^od$D4v0d-QM8!hD}Dz>a9v;V(XRtD zE9MJ6AMynFgf+Xo!VFCK6MDnb;CuJcdtEmRHuV+XgCc|vkPjaKOqk5NFbST#%hPQx z*0^|!Up4tcfxmQvzntZ-Nc`0WF3m#6A+z`%3t^|a=ccXtZdaV&r}N@=4PM_ZvAN?v zoT%GhKvrLSUwTKl(Jv?lqZX5&SpXH=rK-te=mrCR*VZk@(-`Y|ZYHNt33@ZrvXL|b#vU)ZTc*Gnc~ZE5{7~g1Hngq@I{}c58{I$_51E^+SCaO`f%_0{{Fr{ z=R4Bt=fWYuh-TV=HGZs&O9O0mDPF!h=~bcGm~e=CdbD|`(~(B4AB13Cp(!PpFA@$ z+P8b-svtE9Ayv}GB}RxuLd5&Pl@yy= zy;f^rIp^1iK#2Fg8=Y}<&CVOTcUia~^m~`wL|#|RP#T?OM2zmCAiChW4`$A)88t_( zoNCi4h@}~hZj&2V`!@*@ejboSOzVrKI|bqPGP(O@L98544G57}2x)}hXM}?)^FD2VX64;%s;w2;b6(L(o?-|L0C?tTq zb)u3&FwjQ{fynK8b*TNRknKuRIMqoq>SqLgjquLDjxhLl5xU_ocHm=`LD;VCPLNl3 zE-d|jQGV@2NkFZQ1QbzCZ&%X50QuiT0nRfi$iBTK5i#L?=ng5Gp-<;=ZeSYp=^``L zsXR#ZSxXUPJSIlri@+C#;T%vjYHK;wWVU0%aB2Q@Myxr@W+hPsi(|p~YDGqMr>xEx zX30{xAPV<;+lIp9p*Sew2XmO+A9ozoP(P1_`e2lk3NuZ^R1L>2JGK%^f>*yn^*Pm- zV~Eg^!${*?@?0tNm(vmt6T*A&h#bd3{}Hfz*g0B6<~v{_m@&1H{T5T!9Mfca*Lmau z>e`??cF;MES}e$f$5DL+I-AH*)1-4{(@^+3(FCcAHbY^nN2D;aBbki_qxMTnqG0J#2 zxHN^T5?sr0opR|ca6NO3g3seXisvd^QlLvAjhe$ydE8`vx!8adKOMsozwz8*ySCPn zM>gn)yf_aJ(1KiF4&DxwZ9I%-%icBbGM=ThW-@By)!aFu{+t!_HZy6_;&C*Cjd|8F zY!-C!MV>*3s1L!%z<_6iM*Ze%$S3z}u6XX~K|yZa{;ZXt63 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..498bbcb86a3d50a3a7c82d731d0fff7708a1a437 GIT binary patch literal 947 zcmaizZBNrs6vuD7N4BAZxDc6vhDeMJC6=eaOiV82jul2bZ@U1#BU^EcgDrb7F-Ag2 zG`yI>fs$Sg-@*6}G4jGM&C2 zTB|8-SL;%v+Nu{EX&d~~OUBJ2w> z_o&^k8%hpZ!^;GT;olTa7XYKqDXNmeRz|V$BIL@Uv(w-Kl=7a}^R;xbBAoA{qi-wX z`i2qS;(*(958xSwcg~3iKUXCL%;C^V|ku}p;(s_?ixv`Wb zR9V!)V=P;;=m+rzWDVO|Mxn&cQ)piE)C*dhmQB_~;ok_`lv&glVtu|a2zEmzl$umA z^L8$8%f3E15R1JWkIUw9z!>gocK6hDSh$SMNc)*FhlT-Li|6CJpJOe_&tGNI-BWUny zvg>SE2NgpZOex;XVU~OZBw>RMEwH2taZySbG z(%2pzleV|u|0zo4-R{-rzP)k5{p6mAKpoL2!8TE@HJH_HLUGn&Q62_0KF*sqVYku8 H@vEy}BXJoJ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAKE-HASH-TABLE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAKE-HASH-TABLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3ad93928ff0771be703ce733b0464c756c7babd GIT binary patch literal 1329 zcmah}-D@LN6u*;%1A>9GChaf*=T5A7nqUqWCZP2khfM?SrqhxbS4w;haeiC3Z23uE(-+3y%0`_YW~E+Q zZj@HJyH(m;UHlC{@4ZHzSyf@EmFT&EW~&sBMU9>BCZ$ z(pleR3S<7gW+dmCx?8YJe^tkrhR4L5jTQ z!FSJKc zgqFToFa9Y(qqvaUF0)@IJbp}8W6{vbsr`9^Cyve>iC+FS#PG$s;aVM|g&?{i+Kuy0 zx%)gpdgN|6rj#H3X5#)uYvBv?PsUp1&&>INf|=Ye|CGGZ?h4ZA1VcTjtc9>H>~QKtLKF+UC+ky>+Sx9oF&JV#eni( z3)fO%Fc^k`U<6w>q)OYiY+-rsqUWl?0Xz^>HFHU{aYqI0T_SsG1j0eappW`KLhTEq zqfpMWi<(PnJ1pI^ZE5z*6)4EDf6)JEHz!?lWalOrB>E5Z6n2*urLc0OAE18b)X)(A z1L4k6an>@#@fZ^R5RxQ(NZp3yN053ClJ7!FLUI;T0+K4E&O-84NS#9~g^DwJ%DJF% zJ^2DiA%D;Dy8d=SNPC9EA2KOjgVev_Jc+;1Cf*%wf__EAge^N@-j+_@GUkZbM`G}Z za0>58!hS@o?^yZ1ec^SlbHjH;9mnzwq{;jqjFI>pG9-3@Z$r8cW9yJ91AiaV9%L4Q z=OO(zWTt?>0qKjt(~zd`js5F4Gj3_K!7prU7x>yT{+U*J`EVe5TAVWMG#+n@ktQ`MXcw{ZDOf{63G3|ckVg& zoO91T(;{8ZXu6^`>g#K@%7)U|YOZfJmDR?Evf0?$Sgt6mz$>q7rp4aOQLQlcc>0um zOtZXES!z~R6lbflxw7=yBTD))g|2U`)d0-QfSArqjb|n&$4<>rTNmE`(`F(wF_jqy zo5P#?QoKP3StbX#L|*=CmKCdQR!V_mIP zUa8bDo%$w`2=U%=yXVS==HyMoyDsfWJ>FHfH*csVNR7@jB6lBoLGP01_N1rPv|6O4 z9JO=g=6+1h_7!sH^Mbt4KbVk0FA`D<_d>XR2LKoPUXBtXQ2oyi ztVKGo{znJa20F0*dk5Ci2-og{x4zwQLaN?=A$DNKK>VqtUo~T25Yno?WyT7!1jn{+ z4J@3-$UxssNDrDWpE>x1e0eNfX}2A2H?j+TV0f*1tKtU?7|G11<+cc_TpJ73Oj`ui zXd4UF*|ylKx^3udcB=UM-)Wrww=}@vQ-ja}2h}*<(+xM7(oExG9xqePQRAY{EOj;y zj4^MgPb;!QT2H| z!gJ&46MY&962gPnocCd`y#bDb>}jf_&;TKX;ZX<08pfxUEsGh)UILd;_dMwO|1OV4 zZ6=Q8QB;pY`NH$e!6Z;t_#iF`v2^(h`Bf}Gisf6ed<`*#j~)b=kdHaWNj~CdaM|Yr zb=&|6qwC8&xxkY;Pg0(o=E+f>JO|o)inPGs#@h8mOX*cmbd@Y~-au&$Yjt#ridE%t zq%GX!R}ZB;Jm-*s&+ z(06-J?g;eNzI5+P^p_ji61?qrwnX6t!A!w1$`hVDSX-)JURlBePIe*;Oxf>5@4D={ zfdX5Ef9S+Of+u5e5kdQs<%9u*Emp+aB;v%+y!X)JntQ)yG3qe&L>uaPhgnp&c@($7 zg>ikh8rwCk{KA5~^7=%27%Q6rQym$Bq+YTT#hR)vVH{NULsy(*%XUWwM#rPS(3&f9jSVswi==ksDi% zT`2;hs8m9Tl~Ok%+5z;Kqdm5*L&U7cSww-E0~aB#tXBr02S#ic0- zJP=ZKLdY8FqKFfcB4Oe_a8i=ROiNxYs7%&qkx6dHbz;zqY@5t*o%EF0syF0X`A)fp z?cClX0wL~wC$?y7idE1xcVE~Q`rSQeprFYs&>GD#5{jKf!RUhP^k?6Yv$Da8d1~g# z!-M!;LWI3^DumU1S2m-e}HUQ%>zp@26l=c%@!GDDs( z0HfthDHP@LP!Ft4T2iQ`qMCv`+anvO~g5rWNGQNmo zF0OL%x|h}{Sj^xllaJ^5#kcvTET53ju%w%LoAT5IzdQoXMa;sxECNA=rt6GZ<*k-D zzC*{wja7K3*Tw3l|HLA<<5l#P`=z^&i+w>c7`2%E(jKUom#QXD;4zrxJGO2yK8AHW qt}{6|&tS=z|Au=17+R-EgKRtIN&d-*myKV6SX|~~uD$Pc< z*^o9XHK|@{){3UI$>P#;MJM=08Y$VSNAUsUN~TydHyUP1qD`}2+IaRria(T4wPu%@ zv9Q40cw%lkF*`dokV1yq>-OI>Gl`kG#O(akK()11FfuYYNTintLR)goyjj z8O&&Kg;7IG7>L2kF1)+oI^p;{oQB4F8X0MDdJ@=UAdWeb&(`^}aJCH&zATGtLu12& z|8W=IcBk{BZ8<&X=}%_2>`#+rKSR#GUiR&8_cGtMTUN_De*(bBUVlWe&c15Q{@%{M z(Y^uDw)VAUQ5Xc^(E1o#>&n5>K>#8ET-e2twiUIbK=ixE&bX}TS~A1w!8Fp6Dkg9- z!y?*}A&Y%Xw_#a9R7pdEX`V3NN>{jmQ7|aZiNe1XRF}Q5uip##f=sI+855!tsORZQ zp31%uI}nkPR)F2OA$v@;X#AS?{XPJ^J}!8O3;3Ef3Z!(BLzKJw{8A-P2-dC))Dw1C zeDp6L1sS+^ix*zv9ePtq@(Jcp7DGe`DlB-hIq$}OFE-}Iy3=~ax`cbBkPr3Go^Yqk z4*R>vOKdd)8pourd$;bf_^66&*+np5L5AKo3ZoaJ$j3|cJXs8*A2~rI&%*z;t)x1uzHwNC{?R0(tvBeh4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-MAKE-ARRAY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-MAKE-ARRAY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..675f7c6e4b15ea6c0881853bf7ed686dfc177b67 GIT binary patch literal 2801 zcmcIm-)|IE6uvXlF57mu-Ih{H#WHCD*QHZwX)RO)r?Yq4X=i7anOUX<6C~|Is|(xo z2SUUKdCv7vnv~Gg5fUR3@vj$S370yqlF|*Tm};6P{8hgghP^0RhuVIz zxnEu?%q#iagO#Pxw>WgYr+*F;$JI9byLZ}*3?l-#PGTbstbOx zsc%T>Q_|`LRaDznr^xLa+piKLe$pHhF`=(#?@tK#&I>2MnGn79j%FeBGUPZdm-4k} zyMnCG5`wV};MiSufDiHB4H#VcE%mkFjhDUUWu2vb7-+8(W5ggPQOZXF&7n#Uzt2ku zddrIgYJVA(rTR;r>~(p&y}e%C>+}*{kJsz%_xfi$s(;f1rMdec-g0%zE@AfGsm7Ak z2=JFxR9goJog7>^#-o)4M0)mQyaN&~&Bln>;J;to znb0gVspFwn##A$DP+J+%!DEg(2{Fp*#5%abaE0Kih3;xjXsWA?DK>SpHgty;v{%TP za$K4gMTltS{ihjJHM1EdW!Y&b!30s*yxO%AtU-#fI;kGItuaAu+p-la>t?cULTZEs zk%VeaDS;nFq$co%f_{6p($?6JQmjJsu@(*c0oq<+hXS^}!X5;6M+F@M)B&hPH4H_wsp`@s9}*60@r$v(M+Q)&i4azUQ%A-L zatCTrLyxNlg7*M~u!gFOa1~^mwXAJZbHj*Z0&-V@YpuRdO?4=*9BV-OB)sqXJ@h!W zrxXWXutCv#9Q2!1MmZ2)|=8BUaW-W)MCIVuT-q7~wk} zbBjHN+$GLk;M`fx9p+p+=eBV!6maBA(2iEeDQJ+7SscwxZr*0`6&8Pm#ZRz!lEnvD zyqm?JVDY^WBYp_0YcsYrY9e|ED$!KcQt*VZ7Gz$BJ- z)qt0Af^Jq7z6w-@yIk%gZf=5V+v69b_9AHS$)JKODx?6FlGE@aF!ka-!8J6lEVTTnqxD}o*zU>!xxw*w9xobu3 zlFyumubmlr?mYicLEp+A413=Hz+c0;*U38_ce*}NgAO!w*o|s9tO3K|^c~AuF6Ad? zA3FjP!cTz&I|>2p1^#Nj=gb?MnF43JH#3cXv3Gcc!myzHyC(QpTdHiKocoHizMEbw z@)!OZj2_WnlVA^m3Ihtv2sav-HAxVqYCw`Rl$%r#01?%IQO=BUqXz+^Bvb>&IWxhH z5d=UUn9HZ|v>H*u+uLv}iQ?HHJD!46QyT*BmT(>XMjIk8fo6>~4!@!}3@$MHgU4Vt f%w!grXe;-y40GYGGyXLEiek-Qt4D5Ke)#ZDE0Gnr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-VECTOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-VECTOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d1e80647c6cdc387cd8f11cfc6a78ea40a30a9dd GIT binary patch literal 982 zcmah|T~E_c7(Q*;2W*T&(8L9?ni!JCk`z#J+;}W!Y|yo{J!9^YjNt}@E&DK0BOzRP zRilGIT9NnzyfIuXL5y7ZhxQNfJsVM?7p7@@-uF4@InVpN=d_UTnWjrxWwTl;7iv? zRw~0_b{0Z4c7G~1Gc!35$F|;M`|q0R*z|*#3TrNo4>_@d5Xz%-_UlJTL;`a698spk zrb;}i6UD$OBD*cu2|_JO#wM2Q3{OdoN>wQrUKGl#oXtAo5OO~_!Fa~dXwo#?eQt*f zyYHRBq@kptG`v6%AG~B??40X_)Q5_yEEA2I7CJr*?t+LfOv$(6*&=tkh1%a2`Rqt^ znDcFv`LYlKsS!|lk|+zs=yQZh@OF`6G#VZ70W30jA{$w6XT|k)=OmhqY`}1%-8sre z$~+9=)7dHZo-;0 zf4x-{OCsWZ?twEVYo;-uWJN0pY|QJ#Ql2CsV=UM*-v@3E%NnLyLa_+VSm1`%wbO6s zY)Vo*_wNj9%3eqa0KhM+zpZDc2|<>`sy8I`d;P*77#xv_Wto;@W@tJ?Wg!GJ!ZJ2; zN;hxI9yl$ke>E%sW_f+AO9AHkXCU&&O)G^d3qLVUTE?=7ape?v9K#&IM*ozoVVm@J z@^r|=R{y76uA#ux*8z4kL64|qboSYf4kLoB-svwU6Qui!ZO4JJw7 z^2R425|akljCBQer=ZN1AsHq*Nimr;mnJ-;IB=a?v`}wIcee2zX>A3r*s4_8>fH{O u+rG=WNA5lk0>(9qU`iO{WedCY=t)W}tlM6QO#?+wGbSb8P4sc%;^G%CZzW{_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-AREF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-AREF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fe350ac332b087bb65da26736907d21bdfbe4229 GIT binary patch literal 2925 zcmb_eU2GIp6uxt3TXwsiHNI#x!E^52U0Q0QiKN{< z=X~co=bn4+owGAfY7V6gB{gw;a=e(EQYL0+CTC}qV-r)#^u+AcXihl>xbkAkvh`B~ zT57OsZ+D%u!ZSLRJ2I0ys<^Yc>7z%U-==gwu4t1}<3&*R>;bd8cW1JCnftvQCs z_OCHJdUx#VO(whQ?p``C#U=#eOiT`#fmT+~)Rnr+mS50k5Px$kGDF}N} zvyN{2rG}(3Gcl2}+|Kc7A`#-hRSKrFX3EW2roSMamLmSyQZ!?#!>~22UnewJ z&Vtz`zZB};ttM5?*3;zD`3+|Xkw0mOQ7q;9*o{Hy+6nUOXM@yhZElcii#5*?g03*s ztMGbP0G$;8urgd%1H?oHuS7O4@kCxTu!@v(;`eh}md0;@d&8M^P14x4XX=-%dN7yg zjk8w$=Y-6Uy=K)9QYi}Rl_swpQ-eQ9NQ983@zIW@kLXV;HX)s`Ky>}vD;G$ zLfhggMJm*XL6y16Knrl~^qBbj&joGzr-D{gLqnBnLSAP+e+ON+7CS*Nl=Wt>vrxt_ zfLewhbQy0}%7}W2d_E7Y!%BJ=6)+1`^OBb+6bcn5*6_d@A$L?N2z&ATRj)Z;q<5AV z_j>UH7|?;`Mb(SL*?>_1qZJGp4WwNJBLGH`0`GyJk^F6?w20Rtn!|662^Q~0kuEPj z<+T)`7U&IHk9jRcD$K(2VjEa;9{YxI7ts>Fe6`sB+et{gzZoXR(pZeph<~osl1N!* zUj`q3bwD%w4Bb}uWdJezodgZD5RJko1fL*$YT;7@lcph&(%jU5YU^&+hDnj)qo&pw zaa?_fQeZTSS(Gw#&CCv~Y0DmR5=^4f+Gy8Gu&`VQj#|yOwUM6c*usG$*H<08SWI5e zLUOE%bOX{*wRVEF0ftw7Lbq+pR;{c%oOKiOMqoq|nmM9!9P5x9t5HdadZ=pcU@^ZG z>%MPL)p){Wt?F{OX+!w-OYh3a?j;j z2if*Mz}8oC=!QN7IW#z-hy(Kg-YU|DrMXXHVA-jOU6|roo`UTL0^1`zrtmbq^7QwFASYbWq`#`#cWdILTRcuW2dP>+Ax?S&ld5bR z>T{q+8&R7=w1ah_?yb$D^DN}cH6HS@U+U`Jr^AfU#cLOTmz=4#snVZ0r`)lwQ~m-> z8|p8}xFAzOk*Hiowy{U?vZP^BEy#ci7@>ZEKnw_x;RGs6_Xzu0jBP=R!F_PaPC||V zl}Gr3Vi7q|Qw!+2U2{tHSH}84L>mQyT?4JPb1QsP+U76R Sh#fGfILsO*1X}-i)fvj=Y@du#b3_ z>ZQd-X<2gCN~_C@?+iN6F=Nsu=1VmHlnsi$X6-!KRk)b!DYSwWheGw@WUz zb7hqXg!rF$(OkjMoV;oHH-rtL)8F#qc|)0p*3@ZA#OPratS!pe`l=N4b0s5{?0I<&@Sdd&pUmfwQ+6#4#05B(PFnz{(t;nK(D4@rJCg= z5!?OGygpeojj23thccrYQ#!Sj$vjw$X`9-M3AZKpxQ*LTEViYapa^i0e$ztmwG%cO|@z8TE-8_`&fxyD5&~8Mz64^Q4F#k z6#c9hMUtgKkWFqRAF$p!OHX57Fa(A5@uZ)?6rQ)tX#pA4s`*~HTyotiDsOJS@=;)x z{oDQx+{tG(i>eM)j{RBLdZIN8J4{47~a*`7*g5#WA+mltvt+9iHzW}rf@csY* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ADJUSTABLE-ARRAY-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ADJUSTABLE-ARRAY-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7160a5bd7829077207e4ec1d3a605f5de054e42d GIT binary patch literal 1349 zcma)6O>7fK6rSC+9XtMEokU3#jJvT^kXEdPlR&|hkS3dPV!YWk`-91)RpdC>l7myn zMj%8KAyvJsL`_t*(<(jo+FW`-P31%Hy>jQs0fE#bQg~x0CL*BL2haQ7d-J{DoeuKf zRy9d&Y;4x*m8R5aw>H}?X}!^uwi@kbxgxEDUV5k+CV8}k)k6B~%&>LBQf^jOTa`7* zZdbO}Rv%oHGS?)$*{sz;xOx>}CVP1%J2#ge&S6XIv;F6t+3f64aG&CCH80apuj!9i+=s9z?Vj*;#{B}g=EWP$7z?xd(s_*YGKe%4)jyq z+5u=s9uJLj)#u;Fx<(A(n~wIxi2aRFr}~2tEAU(t#Qn)qf&~M65TOV{-C8->-G6W* z0dC?rfnaG25_nqOPn5>{!f0s{1X`Mc|4wzMwp0DzfyX};7}B`GxVlx5_3bA&A*+VI zkY~+Rmax8{5mTAZgGOJpWIjMcydNePmsM=5ONvQs$Ar$Sz0n1%70V{eJP#gY{n@G- z!Mamaa)!BV$&}-{)3Qd6v6|;3>AgQ0L=m#9-uiuF<6F} zOia@-6~nQMjx7skz#}4KeMRZ%SstD%W6^0HA*X1XvB& zX7DW###P5OiGE^zDaULt!8Z1xhbp#6KP(M1^B=%8a(Wk;>34dL9l!ODJ$mjTow`rY z)@b57T#7E^!qMu^(d2oWOweSM`M(3Bzi1kZIzz7^{KRQ~g|(52%;N>~?=^yWveBnwsA^YUxjyPO{(4P zKN(E7{Uvkz-uuPdWm}R|O@eKreAF*3Zxa)177a5uNcW~=*o01h=egCH+$VyugmW=+kB_lYgbHu2kiV;lA_{!>!OrTznhuR&Uq?rv)nbe zdA(o>&#Nf}8C>*DPcgZf9>Tr6*1vA2E?8 zLa2g2?|& z#2{pUX9ZSEvZUt}+3qt3Ovrv{P32@^1GXlvVZ;Vbv(W5}ZN)RUg#|%WRdGvL$rZ7z z!AkV_D0CkorXP*4w5#XU7kTE{E;{}#&l*<~QN~wKLZ_9)Saw^??%3v& zJJ>X0XAvt#%#HAl21}rGr_pbM?x8v)On~ln^)Eb^L`VtpjYdVxaGlqBlXx}ajcqyhybheJMX zOVe?YWg#N&l1wUKQ7&x=tBP9GQiNfdf3Mb+6q)3L;P5$YSse3`GKrfSI~GWUn;fHg zKp_(3CdQTwSi-={a0;ucq6$h$-ze!R?g~VNQlh*iICk2HZACH{SRV8vL_Cz*S1Cik zg+w0wo>-vZ0DzC~LDVU{2MME6Nma3Y?j8|_`WoPi|1(2L)UaEYOj7q-km<^WOF`{C zxkg3Y6#++}zg#hL#hDuaC$dXWlg5&V~U&+QM3g&-Y3&NJ0rMDWe6e{Nfe%SsC!v)gMmY%85z#&BHNeZHJGnYQM(bJoYc pcG_8b$?p3(kC$Uv|4qBku^w&?3UXeL(;vAGfZQNFI?kM&{0$e*y@vn* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSIONS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSIONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3f22f31a9538f5cb2355ea6f312f560519ee694d GIT binary patch literal 1361 zcma)6&u<$=6rSC+9XoN{b#bF&QnRtzs$F$0oCH$LX|kCl#_Qd5cU==MC~`K~l2ZrA z0U<-Ve_{ z34fv+ir(7XYBasJ(%R{4?R1olR$JL_?X+v2vH|DHH@aoBZftAAMPMnd54UMT2Q3Ei*OP5Bw<9qE#Gb2Yzx|>9n@AruU`S#Bw&b zi9ks3gCAY2n7UiE%-}${EyRO6{&>;UR-iPx#E2Mu5e1_QfqyPPr_E^8w&|+2P%Jak z0Z)e<-Hq=NBBYYCh_e2uKP(9kZjr-BC9!%oofIO?3`nh|2BK>dL+kv|N_QI%KPTku z-pE@*{lRC6u9X1z&%SZTN<1NCzy6(-D2c*2n7_SUoy0`IM+u1&(rwf--QUUgC$b9{ z2ic?56l6#0>Afq}iJ_gYo*&qU)%3u;UB}-WE17tm643QA2JF^lY~fG-q^euyLJ|9{ zEmL#BV74}2gcEbgQN;+4iD4LGQq`%eFKae)D>e*4?@ck{tU4|$iz3`e^~bCmjGC1d zZPBvJj>-j5c-7mrR6ZufcuX1xGSZt_ez+AlPibsOOmkU^577*u(IJ`zlz_cRsLZx4 zTeB+eO2t*BGjJoWQgc=7ouiJxm-DCgEH*+258-m1!4<(kA$F4*2m}BTtbw`!$ukI; z)GM~l%oCf;1?2t)F7>j9I(1k-EgwVr5k!(tuO$-q_yzp@(*GRt3t#bchri?T$pW~H zmuZRh*ZDo3xy&<@JQIWaLJY|8ift{K==~ogKX*F1hAreW@_*s&UK0@g3ID2yiB(~d z)D51U=h>dze*^zr*W2zW*^|Ux`C`+=Y`PR2QOt^>r2Y^BhXqZ8Wo}C!1nGlF{Q=R^)>R6EPzAvk5y9ePU;5ySPxYL8lTGRx6fEq_ znRC8#zI*PubI#5ZX+EwSiatFxQ?8U|mFb1~nT2`f^z^JUH@z@BQBqEWT{){;Hhq0W z(??TB(jjLZGBH~kpD&$K+=bHIsqt6$D(Say_ii()ofcEQ>j67)O1yMEKkYROY!rB$UntnGA4F&^46$y;|#ffdsHrN-5Qtt zmFAZSK`0E_@8a2mLHy7hY6ko6TBT*3Th|6|N{zFL;GzPuB8OTazPnbw1zO^K%NA+! z#*5LK6$SOdlJSley+g>-T9di!QyV9#xx%rx!k@=-dgMea$NT=uf|0ydV!nDP=m*}-dn5d zg^S9{X4aNN%i~?{kJaTO#qNgX(DMJ6gY!7L6_{$1F(OC2_o^L9-7<%=*eU9WW)2zD zRtK|SF^8R`9A-he6|Nv$0l55dHA7p*le*^WBdSf^f(>n@^S<;uV~$I6vJ4(=qH%SD zYGxs?W-L4BB$*^jjnS@^WMN;31$|Ly(`b^~wq>hU!Oa)kr0)p`h$J-=8WZhE;){XJ z&%3p+J`b>yeepWb%M!jsUF!#JQ(a4g)>hYgSi-Bu(tn#HA?O~~gu`P84uBsZvnF~> zGf?>k6hH1rb5Z>YsN#CTwsC6ICl!+r`xvmcwF>K+L&ZK=7~u=R6mSZIIBW7~SOi0& zaSkCg%eJGi*;6Pi)`8+VwhhG=)`{Xt;o{>$`ki}9zj06LNA4+o$UUWN!ev>AIpH}Y zJjaFS0fDs(Y?Hv6I7WWq82OT8N+l275oe(Ph%0qiM2$jC&q0((0BV89_ipTV96mv|(*Nhh zr$Z{VIX$jgnT$i-8Gs^dkZVn`oiC$p{ommUFvPMZObg9W;jMPzjdzM{r^`}0OZBpS z``I3qr8?NYO?Vn#c-8H0X>MNWI;V9hr^n$F#QVj_y42PThlSA%-ihZ6mP`5G7%Q6rSDnPwd3T4we&4Vm1~nlIcb`Nog?%X|tImZk*k8cg+%ngd)emKbtxv zPAi0nqHsV+D+M>A+G$h?ao|eRTSY1#5JKXJ5VxMVz%7SLNJuEW*=bDFR4VJk_kHu; zym>S4&A5&H?^>+-$9Fw#1d@y13EYTrXF|6&M#kQ8XQYIx8!4qi^QI z#wkmAy|UD*EQ{u5Wn+2i;|pT$4N+cOuh~E@Uj~`WUmVL%OpJ!7WuwTVJ#)@@e*98? z;^Jud_|7dZ)CIbbfJhPRi4LLx9vJTuotOhVBK}%V`8hh zCfSwi6`O8nbpvq-xnDXx(spEdmcxj(K**i<}OL& zlC10Uq6BV}T1lNUqy=>6R^JXnd^jHCXoDt^1MX$3-{u(|0P15j0yN@L^bgP!qeno88T}n-8t7j2 z0R3hq>h)e44gG8-8VyDt0JV9>zq1lHegR1nU!>GmUL)8#p~aIv1pihp69_M!5UmCVp%OMNYk1=Z)6F_b7yCp zT9)(*Aut5IPR(`i0_|cU(lv~cn9$o*ZYG z>dVUNqU4R!JX|N1d*X(Lf(Q{Gy;dT<8$k%`XWIlob15XcNkl1@<IUguEomkuBde}6nxDi_ZOmR?@9(75UGQY3E#vXpqp!PrLBZ!2cs_W+-4l49 Xkb#hb-{)mO&VeB3$q2fgJ3jswqCe?L literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-RANK.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-RANK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ab3259791b3961b87e75d62281613a3e00a7ecc4 GIT binary patch literal 966 zcmah|TTc@~6rSDfjZ&Zx+ZZsqA(6z5LsBjQ>x;uOh0?N%v$H`SNxRsFLYrQU#z+Vc zzPJWU1KCk|@E;i75F-!%q5cD$X^AxW;O-_f-#K%>Ip=(5o524<&#HQPr&26ARkhrx zR~mJ7t6WuUli?JyvR$_S#!M%t=aRE?li{n=6De8-0OY`>So#2n0tI+SZd9Y# zqA-=tVrZaMta(k(4e?r_ZDHcM!&7R#T!AI$l~WSs?9_k+fcMD_rEEi|Y18mp(!Lb& z4&8yY0oQnGXbA&3bj>2zCC?p7%)x1h2tgZ=AR_}#PXY%#k#8cKABBq*>3kP_{kbBq z4~`B?{%xKh|F+v_3)ks#RFd0gi5{r5&(t0mXrK0=V0*vNeJ@@DFme!#NQLuX2H&@v znUBVA0GfsO#)>Qr0B}_J9$W9Uhr2@nL;$!f=0=)@XfX<8zjy53({$5VOp9{iGBOsk zn81ZJw-`&7Ci{3Fhcz8heHju=ZNmGYcN!V6HY|!)W$E7&)YMqN5@dZ!i1%(#!-SXw znl@dtsiyStfQW{S4cM_;8skljCT?jFQ~+Q;AwXC(^OzF_QYKkNRKO!~scsX3jUIuS zBzyeSBtydSr@jw zhkV$Aa`$=WwE{lHFH1_oYblE28~0k=BY9u=%JaCd6O1T^w~EZBDJCduv3_xkXY<@P MDQ2VK^TgHFAD8YG5C8xG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9e3211ef304362fc0a11bcc01ac82ea64b8967ed GIT binary patch literal 1755 zcma)7&2Jl35P!S=NbJPMF|G+t8m}B$#Ht(B`G8gv7;C2@%!4M(u$U$2Nyb6-7SK{s)K~CoUW~L{vyzsxaeqOem>f_b~gL-K*sFWbcpp|(|D->M6%wGCmjwzW|x3ag+OK2Yp3GqRC$z5S=nSY~W8a~W)o z@7&@dH9|;%G*JWyi4YHQzG_57lNzQplg&{{l^3Y!>^Y5Y*o%}msO~iSMumE9U9yWG z7H!m_@k$y`WlVn|& zmn2=Yqy_nkrb}6MnqDJ!ZuRaG!e8i%@R-|orAPDJ!yDxG_w&4!Nc3@jI|TU_`cE=1 z#5-TH&R4Wqe)K*e(cP|>xzfY;!c8p<@Mtf0Qw#q<$X@9SEj-V2A^5!asx^p#fbS-x zmyl+;Fx0%y9h{2JPn<;Ww)!hzRXO_RK9{lj?EnBffJn6Bl}b;W8nEJ3n+IffAs4dZ zHg9_ohXIp6tyrZ}fmrB={0hkCs{mW8$xl|ST5Z7~(od`yur`nUE2ua`1-__BpysX> z1%K6`kB}*8w`9*0) z(-#bpaXj~LYf}?hk0$_xztzR#ojJh{_k=pc7>js%I%pJ7ZwI9T1zErohG_|lRM%k! zw7j{PH$~4&u&P&-)g`H=$2^=yB>mj<1-b}fUL3h0oS7sz^3r$Z9D*nSKkh*`5u(FB zC9msLJvHBqLk=fD_V*bovO(RjtOscB0eCuh=CC4r7ubl)nwlx+BqMvBBEi^s6ra1I z$}mN4)kUT&s4FI1@tP~5uHagN{O*chT=AnT9=qa!E53Eb0XzQ@OVrswkqu@bsnCKv zPu)xAGD}`$$w8J3Kn{EYNZ+Ea&8mp79*Hw|Ct)pF1k?TlOY}T7@pm=9otFVb#bgT7<=W2BCR?GCn*GTnr{2I9s0!@F)D=*igEXhrqOF|_M2N8 z+i&h|ZGL`5E55Ih-Cnx`!tye}V(IEaX=$ktUm>m;M0=^vVrg-?R9r5^PaZv#)Gk7( zfd=A;A*3P&`QLh~&Zx`qO4+2?BI{K54}C8Rwcwgd9p6hXX#MUk?leDbc0@UM_K<{- z|BV-2saXaq+m?SM-IJ#L2i|nq!c{1ZtWqRLpGOhVCEuGVzK0hvaU8ONnazla-SSO} z9zBfTM@Y&gRawybwe_qbJ>5Z%f2+v#i*rdS(#ZnVM(UJwBR!U8$I{&3wlK;J+Rr{g z=;Hl}8L9R3R$^c$01gk$2X^9jgbrI@+KGxRO@sL4Qavm3fj)}R6heb`LmT{zzCJ@j zdi#__w4Q?ao$TpB2*V@Hkzc18L{AC&TaS8IW!d@3n&OmD!~Kj}379 zP(&WIRME}vyo_$x*7dSzIbI{yb(1>yS{ZJvRaciIJSK->o=M#x%vi$?Wi*JT+jQo+OxlM<^|#VfY6?&@5Ur5C-Kt@BAG#$(DfC?lis6~_xAMypJY6$@Nd zrp9OyP<)J*042ugDxeFnFbSPHj_qK(#;P@@D=Jt_>BQQ=qkF;1_tfIK1&qPSct~tr zQtZwp2o$0p6H@@Oh7nN_VFJb=VA7~L4z(6ewSxD{0#!0)9a){gLN$-X%TQJ(MnUZHf2LicI#P>f!`{y5=jrUUnR?!vqN(S#BTE3!Os#XnNykdlXxN;ouP Qz%K*fZ}B|(Vd3QDUjrzOBme*a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-AND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-AND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..019b065d5cc8a6d19089786a639d80c13fad44a8 GIT binary patch literal 1869 zcmcIl-%s0C6ux%&5%R0fMk7cwa3i&JUL7q!R~BAo+zX^}Y-T&nc$!cMOWKs65GGYq zQCDeNrA2BP9rbP1m;C|L#zUoQMS0jCviChqyiI#z=h%h;t+YLCN}}U)zVDv<-Q#m| zw@B|NswS$<+iUekwIwz;+G`taai!T3*P9!yN>yBexcG%?nDp+vq82jK*^qS%skEv~ z?dq~r??21cUVa+u8ZmJ9x3q^w>=#0|YF`_%0?$R^@yFq^h`9j|5)vV#Td$fprcmg)?;@1AXn)mtFLK1Hha$LpU zp^5=i0pcr3P?7XiBz+Z0Uq$l&QNhm~s)(YBx>t&XFCyWKNcbWW|DgzYL)VkgvE7Js!>HREy%NmS+pd^@!adHZ9`(=Kp23i+svk^EM|{J2Ae$)0Z=fh zRnly);gQ3HKnUU?ot94oV{9OB=0vt}pb9WeF^QU{Vai6yUMSg8AP%gEr09#X8%Kdo zN64O<&Tu~=tOrN(ZJe;nkf?{=P&9N#!Rf=pDK@$(NEla3rb+c<^UpZMQ0w5|MOGDy zdfT!vz}y~W>i35k{iiI6<_SB8<^fBg`GCEHX3)dp9>%*E*>y4Ujf;^7?A#re(jjTI zs1&HIV8uRSBN7`Kh7|l5AiWEwF{h(94BA5e<}y}%f(aPsk>%C~xBV0TqWW|^ES{bF zjiu2%KD`#Ijq$teJes!0s(L1Nnw)jXNPnrty)m7RxFH(0s=(gGlP z9z;c`MvGW-dvSqIK|sjs(8`J?L%nSPtSju|I2%i|OQY;!ij74<8GqL4jM~-pwwT^j z(&EYzTqet6ebu`MFt&LC5AeP7%-P149#KuI*c5a6gW|qJEpJm((JU558r19Kl3`Qt z@Q>KLm?Gt-U=k46dma*X5wi0dLcVl5ncNJ8rlQ{E;NE!cBcX>1H!WXtX4={Afg6Oo QfR=Dv&&j0Z>GZ+DUppclWdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5788b48fefc4b78606058026091feea208d34307 GIT binary patch literal 1881 zcmcJQQBT`e6vwZfkS2tr&PF3hv*1Q*>AV^#KvxDYGwublI5xALW;{(Oge7fCPzaN% zsi>dQXBwDC}>T2UVQLHfRjiMMG_>>N8}Fe+^in-c5zp8vVWzk7VH z?>6cCMAbyKd3(LysJ6uBW_x|JEv`0O;zo0`RjG=r;1|D84U^toP}IWMOs?NLrc_$h z<#u&Nv^T38E6aDTh`A3$WxZ8zz|GVY40F?0$EPPJ$NJ|KOY^h+*% zXc9syq=P0xh(H3w{nimAn_9L!m)EGQD@7`~+pZIawa6ulny!-=7u(Hsxl#SR+Q8-9 z-XI(y?jt8WSJG8GZ|Lq0caIxzA3CwTE-%8;lzB?{a5oEP=UgYAyCzS{vw2%q^y_Ml zJll=mCxjnQ2t4xqQhQn8UaXNH_X~VEol0<_M({I2{67Zt_W^sd^CoYm=Z!+lP^bP9 zroDCl%sH<1;?sD?h{Nz;TYG54UlFoh``U;XcrFIFKMj{f%nf>&kO4wE^-8w$Gxzuy z5qIr~C|pjKGvy(8#@^-f(9P#J5B6Yq>-nvNy}|NOg9pbGumQ05YX0wEgCySsa-3rS zh$4a%0AEP~MXF1Y>Qbb-6siA*f}cI2h#^JYFGaEok?cYwyAa9$5CY!NM=9vpPE8B+uORAw?&tv<^3(!#-HKDn{qt9CsA7K$b3|9!QKIrj;q$;+$Ae+=Knb4!E*W@8< z$+BsY=OJRy-vz2h6}_}5&lzUXk{HKxr)S%S#G-*H2r;jnO;cIQ^)?N*dtd-W!K7A6 zv;CIG7$yYz!QZdb@(E|0MFM9}WE+Q20rpc|qNZt>vQe@ZOSTk9K-7Sw=u5KaM?lvR za(~;O(KCdwAa2UHafe-jL_vB((Qq&VgAguGv2mD&gbB4|np8jb1z;R%$U68}kyXW_ z{$p7bWNsfaMS9yAJx^H*%@cMW%>$N3^FDhA&7iL(e2w=svgc{!8&4w-*!epwtwY*a zQ7KSa!J2)@G7`%SLkfNrl)gpNnAdSM40LCEkC(CP6HGvb$2hM(_~1X_Llx3-!MJ|z zSC&Qd`1EY3IVyMA1vG6xuIiik>F}HvPJZ{o$!}g9dF`98PKR4eSYsC;-3^v40AK*n z7XWR5YP5*Ox0e>_6gY&u4o$6SGF09M!Me&WjkD1#yF9`!rP*i<==gK4Gh$aa+G2J~ z$%?DXaImb1^)>%YK;PCyT*MFV_wEihcSbd-VpGi7-7?AX5>0$nM*%(xdwN^Wv|JQJExEX~XIk8{Q*$F5CYzMKgi zyx8G{CLyFkI%tA~2*gL6Z`*=oQ_GfT@*0(OrAQ@b%V`H-Epo}Crqhn)#8z`vZd5<7 zHgGw2)(J<5^SB+DDe0=6H*{y4yUz_ckJ^#EF3-c#lvzsnKsO6!=bUyldsQBnr}MU~ z=-1U8d9f3HKnS0U2|V(=uDvO6uU5zpdj-CnOvJeUhW|4{ygvqn`hY#&d7C%Y^M)a2 zs8fFf)82V->I_$V^=Y(YL}9qUr9CpDKNGT5``U;WcrF6BKMt2g%nf>gkO4wE^-8+) z6Zhl@5qI^FC{T` z$@{GZ%ce!1hloLM7pNLl^wPXMW0*xtVjRz%oNXHt3;V(#MBH{ZO=Th5+cenjz5x&g zlUgOs_F5ienBWV6Kcv(0F=vzoeW#CQ%R#6B`zb0>(=<%kDB1HRTk^#qYCux-1=;l@ zpwkwzf7_qoQ-m--ZpwFYhh2h1etJ{Ua4-Uceq5Yl<1h&cV`|AXsea@Oz&O;9b?~nu ztBOUv$FeZU+#X~K_O>&6p0Na)r|c}6hb)QaL-rn;K~IZ$8t-ak*VV{3u0|fRvv*li zhqRHRQlPSeHT#IAB$gV66#OVCeee5X4662V z$*`$cfXD28Op$a`FbM+K2c8mf6|!?eAzwP}%;YqM_M+ZF;hui29_S(ArqyN6OgYCTKvarwN6yq)iD5VNx{} zb(N-7TBMfIQQuB|*&i@%JXESyl!yHxd*8#v+q5Tkj%^swO54MxBsxCl`|i2lJw7LQ zoAi9FYNFb_vtDmhTVivwy}sENSDP(yqq*6tRK-<@i=V58N$<@mYH@Tb7qLztl~#4R zU0o6F&FaR=^4%+9?z*U~x9Saen3w=JH+eNbIX*rbnNcjw%l40J#wN$EPv&6F;qzTi zXc9syq>HAH5P<}U^G!#PY--u^OhKcvuFO-(*>*Z%IE!4esOfZ)d9mGGmmAg3str8O zoejbf;ymtzXG*$i7YyCm;qG%W=TRqK(B%adAeZB^yVUY zzMFVJ2%k?1JgWJ*_NvIeTq8g17x{7~o#aA|;HQLmUnE3&KzXYBrs&XdGzy%7Zv7Q3 zd;3A}Ij;8dlSJ1@fP1j5Ju(u%5VBqS%19J>E)I`B4wgmC4S1N47$MzyCENXpdvZb% zckM_~xST2vl?Pytz02i+TQ6=O?16jx#jS(A{_;SBhli(N0|4Bwd7pnRB=sgCCsphp zspvx$Aik0Y6=`2Z+EB zA#2I9={(N^qu-kWRilbtT99W9bKa5|$8)c*whf6z15p6t*vyJ)DoeTJk-=sU!~hgb zYLztGZFrZ%gg^x15uKJ#1rw|<@Ybnpd7ug~O$mvbreVrP$zCYgQXmPen55`SvKvQ% zPDjX{na*f0AuNa^`3_Fl6-X4Mi;9NMFgPJRoMNM!frLr5WSUezG5?H147K+EU1U|U zsJAVP0?h40re1%T(SOF$Xr8k3Xdbc*nh)5!X!<=Y>0!K!kv$h9U%ME2$j;wo86A?w z=anM$s`?=tlGxB7q~J#Y=~*z1SslGW&=&DGm$BkwOu#sgEVnke?Vs=$71Hsrcy{hL zmPPaA>{_Tc#_zEUXxbjD>Y2n@a?T}_KU^~T-DQzqJ@e&Rvc-fob^%f?vTPBg1wir~ zh>B5-&SS~#r3E?x0imEnD=V4|^|k@9uChycHj-tRhuNhJ8;OH5{+!bpwyPU$F}tN? z#nolFOjgADns*OiZ0jN(;CtsgX9rt)NHwWqQ_SfPiu(?=f=x|Dvse^qP_LUM!=~Qh zAG7x`MaE6RBp|T&JtXcTWcM|MeBpFPC#NYi747JR8bO+Y8>yx9>PQK6h43=tULcFHne8;=X+j~4v?)O$Osb}$ zuF|whi_|hY>f5O={R5_rhf39o@~}T-?|YbdoA$)cu?+)SX?xg|M91fR-#z!c$LHj3 zlip8MO;nq=*Xxa1OKfho*EieZO0y+yG&ft-nz#aS@e9>3>D@U+EoG;2Ve14^ZPk|A zwPn%XtZghW-MJ#>CPihvRd2w<#00px!qt3Xd^{VTQ7p~N_K$1E3S*On{A4zK_-vOG znuL%l>7oe{B9H)azU>H-O)XoVDQZ;Km3b;T+fFA4XOYVmHJwf(FSeWOa-;Tnt%1k6 zy+JraoJXDDOj%d$qMuXqe>L zZu~wWd_E!YsOIO@S0(P{8u?+r#8=X(1lQN-`HT?ni-d45C{K3Z6dgW}Mu0Qet-pe0 zZ{P1f$F08nG~PAh;2vyi4~_UQglw;VZNy7F7lX$ihbkiG20Tbel#p({n(6+;JwBm` zyLO}~SV>lfD}%7d-sQ^R%@;Qh_Q1XM;?}|5KxMGO!^0D>0kHR0z0bcEl6;eplPdO) zRD@6kh_9wVMaox^@>QgK6{-J61wVbHB8DpJUMZ5kh@>wf>5EAIha%t&eUyTZ?XC)h zk2&9U(voWE*NfPE@|>by*Qg1t1rdGLlK2n{@j>|Y!LJuOJRzxytHRFUT{7Id4gf5peqOaEgs?8WJYdvT0KN#QZZ3G1NNncac@a zqTaSF0x-7^nfm=wtvE3RG*HA#j|t2 zu?(8WXV*ftF@Bd_K-2bEHP6J)l5;MZ{Na+x?=Fk{>Y1<3k}W2zu?vvu2FsK{S^y-^ zfv70e=scF(URngjHXQLT*d4yd`v(XqRUOYn_^CXP~3N@6>VxNn#CeWgL-{jHf-u0 z{t5J#OacOX-$P<9LUvz6$d^thTbQQMRMfj1+#9cbEc8g>mgQ^CPB}Y0aD#9c Q(Grg9Ih~X|ojN@H3*-$Q{r~^~ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NAND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NAND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..97c5aa7f0a0b7046fb574eeed3a9f44584fa4ee9 GIT binary patch literal 1875 zcmcIl-%s0C6ux#sn%{Fa8bO)`H&RRI)kp!_((p3lULcFHGuvs#(}W<5v?)O$Osb}$ zuF|whi_|hY>f5O={R5_rhf39o@~}T-?|YbdoA$)cu@eSMrR`x;VjbV}eLnX)$LIL& zkb#d?O;j6qHfr^1Q*3OtHnv*gYNIJ`Hny6}RdE&k;^(Si(tGoYS{$3sg{>3FaF#AQcU@FAnzcIIOijTum%lQepPU>E&nlMYMf=BRCh`;4^OIM{!bi{d zIH5rZStcDcAwmS=BhEK%L9(f3%d-WI%DS>ZC1=NJ2O$@^Y*Eu`C&tBAV?(Z2KdaU; zojaR^BgA>!4$hW!)h-yiv&-G*qRyjstf0#!NKKiegb#M3V06xDhjZ8DNqMGV!zTI- z@_aA;fDnE>A@C^Yr?uBb?$tW^{-DTL(y0U&sQW)9#QP&5JOI*@oi}+i$KD8VhB~#^ z@YvfA&Yb1eUVRep7;#u0?r4vU_|JswtbJv~i#!*D+aHE2BE|+hNJx~BPHj2c`H_2a zLJ@bZrzluSRx*_#*kk`vW$4z++lTwGyp49SGF0c`<|$a;%Ug%{*Sz1q7Lt6EkdrD7 zdMZMw0>m$;Kt-ynBGpxq>Z(ZnKPvc{o{AW%sClJGc10w+B9dJZ$^TFUyrBiN6_tvRs<3JT)oZ=ESO~aIpvRx|Mk}mXr2amXTOy7((!)fDDvOV@}7_Fo=uyc9*f{6HGvWN19t5-1iUoN(FRG7qjPn zWmz;&`W}XYBXEzMN7M3XRnNrx*g2O?es|gAHNr&>^ua!$+AUI=L6aE zpesr>x`1`J7fW;s96~{depWOYif#j7U11l;*=Uws8etdHY%~Vi__I!X#IA0(#O$_` z6<3$wNLdkU>)vUAzU>Q`!VBj+XBYcAqncE)DaPzhi~AzAf=x|DvseUaP_mE8hE2Wn zAG7x`MA{9(Bp|T&JtXELWUmh)UpVct{0xQ8qTUhVo_nohp*@A$R#)@bw6p7nbA-Eq PmT;W^bWrka`snCSXEGmF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..348e302167158db3c459fa7879cb8521b9ecc40f GIT binary patch literal 1869 zcmcIl-*4Mg6ux%)Bh4=y=%O|YsTXPMFmtqI9V_Vzu6NspICim}g+8IGO-Z(_snQf_ zLaW9k#3UkZrK9s5+6#XGf<8=|Sd|C<5Z-w}eM3Bzb8NS?-6VJbCD!pd-*=C{dwh=X z7U}<3)kL**d#%x|wZ+y(XKkY+uC&_XdTXP-R1;SqE`F{WCcQhSsHN;wE@T};mfE$& zPHkDVH)`w4i+3)Gx%Wk7t=(wC&EzDwxx&?aVPYa1no%sx%l40Jt`sIN7cS?sp@U~T zoX{eKERi0XAwmQaAkH^kL9(f3%QHod%DPgflC$M>gRmF5Vo}rS#`9vQwI(-fpVgYU zo!je#BgA>s4bD__)h-&kv(4S(BF@8Zw5ZGTur+0t5!R(yVjpVM$6Y_M?mUY7< z&vs(>3E}f`fk!nz*I$;n7pvrly%JwdCF9&cv+q+vygw2`{h&P2dtEer6b%Dsq}O-} z%ig>{c!sOL_$1adV&Lv?X%CIqFNAE>zcOMao{PfmkE2x)a|0eEBtl59v6Sik#63Qy zh`V;EC|FHY)724p#_q-H$j#@s_IJU(_59}k?r?Ra$-~VPumQ05>fY~P3rW0A$Z-{W zhbo3p1&Citf{LWCBI&D0`YMwDj|zVJP(>6~G`vzId=Uv>M8X%5_zy+E8~QK_9owr5 zgpWGkc2kmS=+}$beDa*4U)QJ!tpyQ%){^)kHpB&sK-H+CSLWpz!z^18<9P1X)wUtAa3Bmo6q{KwO=Tf>G&0!ife3(t zNv(=zyAAJhm=Fj-Jfzd=iC~Nk1>QK3Ee})yrYR;-(=<%ksMzxrTMER16_FHuL3ZOP z(CG@fQ_~q9B!uQ(gvmX=t06jJcxfb`Fs#;lIsC}<1$50|mxSD1it9$9W}@UefwCu#t`HD!12 z+;1#{(Z{FPLbWk|mz_h?@mMv_#7>iQE}8t{lF9Ebi~Q=DFHe&#Cakh^km?4@lt5Yl zB+r4U2-RpAOKvaB(@6*jMIBmM(PXH%4S;o(UC6WX47)hSE~MCa6qNC2obH%iTknXO zO(i3)EW%;3EH+lXa{yzT=WzqyJKs6m*wSg$q>4>3r#~p}JJgCcH5JWbVWdI5KB^ct z^)~;Ay@M%IZVDy=fxYV?Q5PXQuOQ?Lr<*NIQ)nvc9S-h^*Ete;sBqKrHD{-s?LIg` SxbtWU$Mu~|N}f&~9Q*~I=N<(B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a72ccd2bf197190529aed1e9d7764455d5ae1965 GIT binary patch literal 1786 zcmcIl&u`mw6#v>uv;4-Hij`)ebt`om7LG{QX~;seMpM`XyYP;p8~Em`tW*jw731a! zPovjd?>9FDYtY=?SbysUp?FD)tB`qBPz&H2*ei>2bl zLj3sN9fs>7gc@i_MGPShg^>H9!-*C)Eor%|Vo8&$Sac6uCknYpbrTz|lUWe@-5sgZ zywU8?bgu6r1|jzYC%RnM6sxRj?jf_!B;DIis;o&hNKIbBh>ZqOXmrMPlEsVCqI9`z zNt$k0g&T!x8s!fztv|0y6o0nGW~$eI8xJ8VA! z!0B73o@H7O-$)PjG^j@h>TNy!H9`liclC6IWm53^`IJ3Pqkun(P!geGyCDp}VBSBm zH#0NZJ8JWG7M9&VXJ@ZH*gCpDZD+TroV2qY_QAEIk3oh&?zjBkzoxEjB_ars zFrBf}bYwUP6vnT~Dpf+DL}(_mMO8Y^8KrI*SUWM$gaIG(Gx#R|tf(TJ*x!~UsQXih zbSjums_&C2DsGY-72D(t6?u{efqwIR=&|QRKY2cMm*fXzsz-7Sa%KsFrK)lT`=t}f zb3CkL6JVaG8TyJwgZ)lR73?U{qMj!lwf{&_UO}k#JzO*qjb=y_X1*n}RJ=XDcEMlU zAOdy2?xQN6K);TIiyj#L;DOP1KI$7X+Z_j*gu6-voy@*WW-kD(5YSx!LP@ORDy^}# zR>N~(;K~{_s;o*-U<(}P44Kc9voT8MvFprO&E38*wii> zts0XMlZdpHj?Q;zFZ=-r`Y>tQsyy(A@XiD38{(;)V<)90li&fASjYE#=YIaq@j1Rb zWZ+{}6V=A;jat3Z6dPNujjfir)@X{GjjiTNMO*{F__=DB^zOW(7RRTvA?pOP(yT1E zDyyQsRoPr!zH>#)zAq{p%~~C9rlw$-&0o#sCnv{4vx=p8Z2!1tB0u?Veqv%gbo6YG z6B>k&71BWyBt#%S;(XHIcEQk{UG5$iaUQm#1zlc*)RZ|&_&}Eh**T{j%3hNv<(Yyl8>X5i z&-P;X3E^{bfk!zntFMaOi*@qDL6I+~l5uXZ?*Eh!?~ehY0g#^Pyw00G_J$#5xKn!t z+upc;<{Vdj@ky*>#9(>2qdhcYKNGT3{mO_Hc`gdKKaP||pF~#E>@xszw#Pv?$LS=7J?Lj_3M!+lIu#zAyk$>}JI@m8I)d)cHX6 zJm`v0jV@r_?WILJ1rDL0Lq98;3`MsAu&%O8IX0GImq*#96dQ|zHvXK`9)I8s){+PZfdpl|ykrtrPIBv#57OxaVH$SZGh-w$;@ea0ssI2 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC2.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3ae1a89ca76fce9ab0a74bb14f48f98974ba4434 GIT binary patch literal 1875 zcmcIlQE%H+6ux%SE=`)?Ko_-HXuU{VhnXXiWvrwxxZZ6W;@H7<7W#y$G$q-xrfO59 z39TBF5R-_sm5$DLXfON#1bvt^u__Pz5Z-w}eM3BzbL^zFWD-1p66^S$@7&MdIX=gC zhYWqBYNFb@z20cnHpJFedwr`duC_MB&DPdNwI;5DU;IopOnP@wQ46WrbkI71R5xnN z?b?cHZ`C$emhW5^)9;DO`bMJ(H#0M^Oy{m@sX5e z&-Nns3E?wQfk!z%)n6947i;AEg92Yk#G~AB)Bgz}-X8;kLm)lYeU*3e*c*bF@owWK zY;w4fc1gBSNDGZT1f0wLQbkU z=&Kk(6(GJE2Nm(2ig-^&yr&}m|ES>S`YOVxqT!Vy))NuyiHP+?#QsAO@P5JVcCnL!fF@(aR-y-Y|=n#5kTC+-(~Y3;99-gt40y(^Qty$1{W7?i&SA zFsW76Y`5dx7$*3F;1BAwa>^NDBfi&8v1K4sfN_dQ)HDrKHp+IXY)if^xwuabcPV-$C-QsC+sp1`RNTs!^IRVhA}zC#$^HsqiWeSsea-Ez&ONE>)2mK zRuzkSk7Xf%xdUJd^rsmePgxwz6Lt>G1C~JZE_)Nrn1@9@jCV1z?_%UD7b6eYxjQVO z18cab6sT9$_t~VxCMSS`p9W;8WEu-Pt|mZSr2ljoYkq|Z2=Ex@RtKN^2YjW5bxaqt z=YC~LG>->1L%|Wa%g&=|dto)tLtu zsh9pE_7+kkTnZ*Z0DId*!Y)Gg1`zVO(@Ev#D0CL}jtKYMYaa{kE8Mnvnp3mRt{=`3 R?gCoEasJb!As+Gy6-#MVZ8b)zjVwbsP-*2Y?`E-pb_{6aNMdUr-q%Y}(z%sPhD*6IuG z`l4uW)Ylgm?pzj&ABxKATB8XMV`JbJ$47_9M@9;OJyxzp) z++HUfA?_n5GF8!4yJYC@Hg}IpxDTCVNtfr~Xv#Dtd?d(%**Vuq6tBu7@?^=DZx|+d zwv)O~2tS+_cvSOp`Bj;Fu|j^_EA!P{HqC{bU7r!+e~}RD2IZN~o1z0p(KvAWI*nJb z?5+DfXSwAUpQbuS3f%oI?V*wSg^;b~uZ>ih=aTUFQ-4*&+<-?2Nf6R$)bgF5xyQ#8 zaaRu&MXH(VK(!C{*u7NkyZQX){w}z;p5NNv?XC7Td3bmNHUz-EW&iW9g=F3&}P>~H(WCIo1Kt=ZdQNd3hsz{=WhF^+IAR-fp$OIxX|DgzYLmy|MV>`55)mUVlykIsmvFTMh2TblmJjL zsa4Tzui-ro6GAbF$8=gf5lpdY=*)?1!$1{ano<%qO~aIpial4crBE7J2}#lCWiO5b zT}LRMn$CC+A*>5W@@<^3%aEvxURN}92EhsA;S?L)93)Ju71N~pvH52lVyLzE?;@*; zMg47A9AIt_GW7(*jQ&%WMe~H6L-T;;(0st&LDTDFX&>V~jO=Pp^e)WBe{VkEZRj>b^;xCKo+2`NJcV-#r%j)i+gTN2KD-+V%XF_ z{3G@*rpS3Im;?m&o{uCwgzUVAkS|@QFg{74si=QBcsE}ANa&%$O)Jn`m~gkd;0EC? Qpd}pFbuuY=I&pCD7g|gnNB{r; literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2025ec2a5adfe0d8bf7650fd6b93d7703d5a8d27 GIT binary patch literal 1609 zcma)6-EZ4e6u)+wEZ<8)RIw~$ZZ)(jnuC%Swgn;NxwmZ=#}2lG=@XPTC0}c*G({SS zYO2JS6lru7oA0J+h*x-EMFJHzVHtqv6ImP0u(FfcYf#No^yPBcZl~5 zSrO#Uwe?23))hLNz4gtWu-fSg8=cMWa!ptTUU*;Dbo#-9B$u);=Yqx&%W}82)T^xs z=4NeUW$F3_A$M7j*1L^1fJ>J^%@tnE7iMO%!8yrL+-(0DGhLX;74o@k@bLa^F4iH0 zERz9>03k8rA@;3)EMro`6z7Tx6;-KBGxm<%_d_pY)u6iFkLQJ6XI*U9-mSH||wSbtRF_SeXR$0go+HWlZ5ZSOmTz!QRMlTNj+4*#v77s&DBBxZ5=#GvsAoD$n7 zp5f~IZ$<}N6x4$q<)#+>iIAQ8$6B<+a}j{woU&3F2X;RpVL}Ft<@Deompf7t_heL( z-%2*WYaV?0ko;yPTQ2&=O160y?gR9=@N0l$E_`5(H=Dn=FzOb-mJ2_$##_klT?c^N z-kOzYHk(ia;I|OB05=czbigg-0nZ{v9(-Q160MQ{6yhPD0zCA;i_lGTqyF!||2?qr ze;OE!?`jHmX;6>h8~?nY&d8cNTg0^x7bJC7p*p;DVAOdd!~0l(_rlJ_GqPmL3!+ZV zst!9NJ4@#?77de@c^*8H?pDeQmDFlQoYVBOkzpLq{XN>$GA!f?fFT0wB}%$3ElxjO zVq8B@JN}GE?0G(sz*LM#-Z&iuqFSTpez~GJ(fA& z%-fL315Ki<#nLEBu6WfI)2=x0iqoz*=?KziryziQ%2MyK(;8%ol%*1N=XH^tnPg|; znDA$?cq_U#ucG!n6y(RT;v88FsV~sMnFVTh;3n{?*qqbrCu{;(@)3juMqvhvb(pZq zCM-5F5ALy|3JW4BA~b5k5R6%tmVggag_dzB=3<5BfjBvG92#C==?m=KS(Z+-b0_fd zZ|(kBv$oL_Cby(XVRZ>^*cG9%=3b7-Z9R|G+_CT3ySP=)$vTxxiU$vO)S0kSG^s8r z1`DAZboW|SGbs}=cH8b}3s)$-KI-0n&XwMKdg$o1En|3o_9`ZE9*%${+)zPD$Sd}) Zhv)ezPb-uJ|T|3wgStX>cYE$xWP1UBL zX`-4oAubW4t(g36nvizjgb=F$Q8AQ5B~F~UaNxiJ35g3T7fwj!Jv;pe2v8iq-}}8k z-}|25XKxViRYet*=8ffQqr4(E*ILVKEpf5ABCa;qR_4p%BJkoZMK|c%ld>{Bd?g(; zk6Gqd%5$yqf@rOkR~P1P4vFcPMR|Fp+5m9*GN|dXmqx}inc-kgHdQyX4fUQL-6dqB z@~$48=D7&KPoFFGVn(q02?-O@sm}Lxo^a`7<@4c#^8KYm?Tgyp<0s_1QljpnZ%T;< z@4_8`f(t(e=yBnPrDU!4YaOFD0oGmkPAOSOcKap(q%G4kMZvD8yP@IQyR%l88A`aeMErnz1D_uv0+Sn{752JM^bh1Pc}F&vK%+I=ZS z*Rpw>A!$<9vMM#C@jNivgqh-fEWmqVK;tPzwvVnNF3#*CR_9MAnd+R{@jBm}?^!daAL!;oi34@Vw{RfwFlrddn~ouo#93bTL^ zgrSe7sA1@aq!+D1(MkzXa1EzqZB}x4EJQecGCTv}F`#_T>K8$agBCn0C^HO;+U;2S zFGnu`-D4g+ZwWj>zr*q#`kJhw@(U~v=FNgCD>N&?tkJ8Ip39lkS_V`2$YkjaB;d8EN(DWy zS=6Wi5s|Y~MbnbURXPi5EU&@%%Blq2w4l@G1WRS1S^>HzV?0&q3_byCwm?UKIDHV% zHC$llhuF{nJKx8K0=T;$?e>6GUTukk>++zuI0qk%1+lv1zVDG+e*w3&Yd^HNaQ6EZ zgUS}g0=g&3d7Nq<3YJxqh0qP!_i9nMsN0TD?Dp{3IE7iE?hD=dO0^CbJy>ns?5;oj zy1fNcCvdy~caPTx_f!4=+#{iI5f<=S&NEPpg`!*3U0g zYvqPmUurHaHO2XQLtLycHA-c19`40Us$r5VlUU8Ajw-#@CZyCT&o;|*qPhywIrD;4n4@qLLXM$)wY%-f?VcUABMP9Ll7XOnNNUyZ+!VC)5!_CDdkH03iW+ zkbBD!B%4^aJf78vtm7#nxh>c6LoRZ`BBtv^M#N@)L9UfAmTN4X^NWZ>$i31F_lDD#)#W^-h9?N({oh#_JLft>%3*m_#-@p9(vbs%7IgcLP z4P8Zu^G5`ph4-TJGRHl?fF8Zd@x}hZ2m0QFwhmM>>S(3sx;WH zz66#2tJ`*PmFH)|Z6gfgryp+TvRXW>Sluq56`1H2a+7?D(LtCO-x?1BjmP&*y;Su>VRrg$DSqTLp& z8o_!YFOM7MlqFG)=l-;|4T%Ol0UGf10l4FrE_Irx{1^|`SWj?ktr04CLR&+J0P5Wu zN&^&zISNa}G!0WW3UW`4dZq;N<0wtkZG)e zfWCm>V|inniJyTmq83b(=$j^=atwP9SoCMzRcw*2TN-5WGhmASZH$@16FS7U$KCBA z9lA^hm+8)PG=2+WfFvWMw ztWy;xy@hA#(^;CGtY6dQ#eWi6R5(M2r)hG6CKa#`ZSMJQy4%Z$Ke)~=yS&&GlPfqW z&d)_32jqd>rWdOH5-UJ&R$I*jfeTwnhN_@|r) literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-FILL-POINTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-FILL-POINTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9bedb1f77bd69948319ea732db1260d50dc63450 GIT binary patch literal 977 zcmah|T~E_c7(Q*;7aOAxFu@O~Bx+JUB*PIAjmfc`!A954wsUg1jN+CQw(P^i7?E&c zyqLj3B&`PTy)(N*j9mDK_7Ctqo8rU^(~F+>>v^B|dCzGf-xEcZl=4QUQ8X<)7b@Vs|A{sg@i# z%+G@vTbP?&h{tCJ6U0<|X#cIby%2}8`I*7f!vjt%BZLa*g#AJYiAX^1UQ?7UYFapv zR4LX-n#yj=Z3bZ$oHeQ8Hb-Wqdbxrf`<*q|T~wUWlbS^hba)Wl0V=fv<$8%9f7y@3sn9$iS{{D^uXLKhJ z<%&n&H8^)#D{r+Q2(^l@wG_`m(O&V(cy5f*fN&6@2tp^N!i82*EQyHsx$m2oWkuH( zlWbbNOteLn8u(!nJlc{e^8+B`h^!DxS;hvnvIfYYbanKbtENTMJoj&grORGe2ta^; z96QsTsU-xv&RK6*2zeo42$YS=)G%}d>sc$4wPYa-84;OitGMeoWe+44W9K#%@FC<4 zu=RwP(0c&nPv}OPSj^mIoRq9#P_1wM9`_3TV}Hg~h)H{0yl@5(BKZEtc&$>2Q*M11hM)rmqknZaavjKO@uQ8fx-kZDu)?Y0r zyeXamy>XjUmR+k$(_3U(TF=AlT9Znfy@$bkTh}=Eqr1;T!%4-U#G?4zRB95gAyG{) T%+jF$qpWUG?+W^G{q*!FqzNGY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-POP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-POP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0511c4e59f786397adad60e2a12d6fda6ee1dae2 GIT binary patch literal 1965 zcmb_dPiP!v6#r)SPd2;R?WCk3-KOazHPVco&`lFeA_|kqmt@_^%sMlh7!OKFHty1G zH*7Wqk%m$!A}q!jtn;<>;6V_)=z1zf_8@o>#DgcnlUEN5;yJ!IUy@DQfP%6tzu))X z``-6^-@G@oLqf0XhOC!wt`|%Bid^2Tu5VW5wQ@z?C~sC)^70zk<#%<dLZss>um*2T6rzT`=y;3Xz86SsbYI1C3a&&Y!I-@xT&-Radu1}7R zOkSH9j_yBxAV_6G$O>s7v=btc0P#MqNs3DySDi^4R5i7Es(3qIEdsTuIfvR_t#d@K zmeaJz0Su0B(KZxEVL>%mtL=^OGVJ{;*xkc*VWyHl~vQr3`+TJDvT>zzUGz8ka z8>L{&SoCc@Cu}9rH_DCT9t57f*LF@QJb5e8uoAFr?ikxv;(J1N3h!Hqj3~r`eszAa z_u!NWAsvJ?iYtAMuZ8!HsS+}Wsv?WsaCN0{vp&IDs99Gz3pVThoCTWobDW9IPknNu zdAD%*``5y{PZM@r)lY}2+82936;@auY|)-0%8nQp@xMtB#||aL7iGMduBOLH94h{A z$3Qu+CLw2|AQ3U{eNyXHbjzGhW6P;?nmKJyTb)XS#hi5%v7NPx5%`DUAA-K_RCLYN z=Tw`zIUD*?_ZvIxEIBTn7e$EZ;+?M>R5No~b;h#i9fb*^@a%5aQdley14pdY!l|Q4 z!5$BEob-+`DG+7tfdmXjLZP+|eQ)L5Y|d2zXCSmg(aa^)x8tb+>E!n7O!8_{>Z#d_ zg$ZFn9JpQ_o=cEBNEb8%7iVD+#v(Kqmv}~}p0jOg9-D3^pbzK1t96;W=1{JL#lS86 zg0tMJ6HPxdJW%+Ook#eBB@r0AfKcGRH#s;Q<~Us88wUA?Zhr&$-S?4SIsDAw2M&82 z>KwNH?WD$%ci06RWzB0Ds%o~aExpVx4zY`UBAK~*;w!_0j*N03-xX%M`bGQNVg2n@ukxy~HfL!N1gM6Cv z0pL%|OL13>=NJ9Nwkmw8&E|DyuJ;1t)@+v+7t{@+Jr&T3>BWT z3mxE$v!N7IF0-Ltrr<-y_wyw;zfqM3wzL6xZ5h5!t8(!c|FEEKYY=Pw#(U)L;Nb zoTAXjlz(mfPiXZ>=%K7%Q6rQ!?*p8FNNz>X*C|MN|$cByN{4{M4g3V?eZ(^_A-E|UIAQTb@8{9hN z2em?!&;yl_`EjeZ9->GUa6sY`EG{Kgi_`-g;DCe#Hx3Ai14t{C0}_Yu-mW)JTc8(Y zS>N~G%)EKun|ZTk;+d7>yj(oBlrLnL`QqB@(%LG&SX|~;ifhaBS$+}x{A+Sjqp!y# zd8+@(NRz&2WPUk2x0+qxjkWB`!ra*>_{ecyT3XH*fE+spW@L1DV037xzbPu|aXZ=r z*9?vh4U7&P?Qh!Iyut;Ggphf13&BrFkhn?ZVksyXR5!$^5~rdnC8$s-S4uw6BBph! zRZ49G{AzJYEM#BJ7EsQq6~YlxdB5a~rd8Qcl4|7=x6USftH8GXeVuxGU*xtYx$CFN_Kiu`OnYY==P7t! zBqR_2f~Uzt$W8U77T{j9ItD%!xyP&yIlR%V_Bb5ogdOfPE477p)^pBp8%EpDd-rj< z>o-;4W_juz^)?~p+*|6Ti-XwZt%EZim=}!t2x%tdR(}4VRli!M+?!6O-g>5uR;IXj z!4rTCA*+*h3-X$*TRyWoTDSaWRj6AnX0@|!1sn~{rlSDy|4`vtaa8y~CJF}eAAUxz z?rO^KN~)FrEGC8=1ib8UNdGy9L-I+72h6IZ7Q!&SI^y`kX0_MhhsckPFXpxm{KLVObHRKNFXrXaLxP-C#}&N2VoXxU<5UyJ6!54My5RCMzsm#v z2565qL6!_TCTi43YjC|~t3Mj`jBe0`i@Se@krY_K?Pq>>3$(;OfodAu_+;8hr47Ly zfCbHhq-I3RuL}%%qiyis7W2CaVGY<=k79E?3y~V5Ni886Xl8I%Ijw0_-P5>?!!ZTM zI_lzNNvHN!EP%tU5Gk;y3(?oW4ghd}+VGnVKSPy*IEt;k%E^;H#DfdNKd4tIF4O_v2a|` zQ=&DV0Hu<3T1F;CaYCN8BP_E02s5k$p$AsATJgnk1=i?rzUV(}=g?{cX92lm!!I`c zV8gd83=7CdR&;XBicZR`;|120VW9*INh~zXLcOf(5f--2W*Q0}zP}zKzI%haZz)<3 z*!47I=&_C-tr2)e8&y146z%F`JObVkH$08(Fk1LVb0;m%{ee7V^IwtA+WdRu)aG9! zx7Ttvkju7z3;CGMKSnOud;@Z5hS&eDL%s^m7HNDktsBx<+$#7ytob*c19qqc>xPUW z5tP9lw;_akMePZGh9x6^u^xoq*<%PlvBwdqFT5k4+<1OmcyBzrpww z#;2jQjZ~S488HQ@SEti(Yhq7f#dT%Yh((Y^m8cOr%!EU%&kH-a;0xDnWLH-CBj=+FpWKKp>w1dzhw4yspH>1{*V0uJViVsmG4Wq1ei4C;pBJuzT@v=w@Bnm z)6&e^rLAgEu4}cO#@0?l+pN{K?b=R#y{v5luYF@WF1wbe=F;@(?4Z}Dtk=tHjq--Z zcgouvYgbQb*;5+bs#gQ}bMhp>?85xa!ra{SV2*lLFWdjd%r4A9%>4A=;e)%9S|fz4 zlP7p22vLbb!dp#M=gi|qu3$04rprtZTVXQ}wHPIjxnXl;Mr+izjG+8=Ilyu*Z4-%* z@W*C6SF%lBaP085v@4~;o6VtuZ4{w2dY%zE{xS<@m%^r+{mhs*R+z~h*C>{}Jb7?8 zu}6qBhL7`CpKy^602P+B4ioaumW^mEG!Y<-dOiU>ebRAYE{&#O5{j*r#Y^hj(x6xoi_5+K4&r4_`Cp&ecsdM0T|(kZc=XM z4VUqf3nMVQGmLtx9%sw4^uB{Tx=1Q95E3gzgSswV&AuKx4or#nYcpb4N%Rx5Kn#h5 zl7ykBb>_M-Q>Vm>C9W$eFs5{BuNqz6(?xgs?<`R)N{AT1%}L`D3`3%5&T*G1M~FE_ z%#!OeyKggv1R8k`+L1RMF{#ITH;E+5k0DdCZ_SWv1DApYw~V4wusL&)d?+$_w8R)5 zKZs0CWPCBUBr<2fKD11iSg$kFVthi34}(j>Ca8VM4eXUbi9Ca#NVj4{PvQND+E|Z; z@LzEZkA3jOJhlQ=;ZF3F2I~!W{a_^IY-1R9bycgboASGRm3p cPD8B%bctG?NTLlY`=aDR literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-6-ADJUST-ARRAY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-6-ADJUST-ARRAY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..78d1b3d153cbb9fe515622490aa8d757ddec4763 GIT binary patch literal 1792 zcma)7OK%%h6uvWl#Ch1*RutMODnmkejF?DvQyRjC>+wx8@p#6}11FUbiX5kL>(-Iu zAn|BaWdRkkC?OEdrK*q+J0wKAizxDbsj8@4qVLUYF=jyU_$;VFA?K;)VR;{QTU=61DXp+keKKU!2b`Ubr|na(eez zNVf>YaD1oWb~HnY5LCNFhbJ4&QZR#FA^Mj%FI(k#JKO^KN&OnxRynHM-1*m)Pv{H3O4Y#5! znO51BxgZMvj&@9$k4A>UkqY?1iUC6&GZ8ryN%G;yD1uB&Th~eF>(q!7u1CKeNftx_nYbaG91^Fp>#C3pc5bO)R^Ck_08HnGW?;@)v&r0?40WjX5i< zZ~h(hAy%<9-82H=ZvpUE1Qwaz2R=ld>Xnr+-(djz49a>&Gk}<|_;89F0G(1TMjdF} z0MZP+E@6MGe46r^JfE3`_+$W}1)ZG(HQi4Kn{!|(b^<%S>UE!U>bo6jdY?{9TO06d zZ%U2p!Gnvo{aNhq2k%IX#8CRwm)hPPIH90(VL?yOLDw8+QQhXF2!nyY<(dxT)9-lQ zxy1qlp0VI{_5U(Dj|=GEyl;oK%suZN0b`?FhRdP_f514hWm+!7$oMPhdl`L~`o4%S z@R!i@B4SIlQUNTK5!Y$CP^5eolfqIBSSp@tntu+NWlgnkV}KPa+9VVojYj=mc^(vg Mo==mnOQ)xQ1Bp5vI{*Lx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9f6a81ea1f2e4f9da7e2b6a49d9d5c4b1605a899 GIT binary patch literal 3863 zcmeHKeQX>@6`$R^bIxbq^&DF!KAChe`O?K}#jz`l^SNHHeHX8HFS~oa8br{=KIbmJ z*yip`D1{J$N*n34tz&BKq>Y4H6$Db-#Og=V79FSpQGvuCsFnH$l`2(KijXkMAAmqL z@6DVqA5?$@f1>+%^M3C)Z|1#uGqbx)0uQOWq%NFUEEIDkX<@0dxKxp57fMojVW~8o zlV$;z9#Kt8`({E>C;ATbhwM8n)1_RtlADp7rCfO?`*5$+|9MGSEES5-7#ae#fB1p@ z!-Io;p)tkQxwn7YXJB}6V7Px@UufgXst{cugiMnfie^Hh#7DeK)o9$&Y)2kT>Y8jQ zlUm$c_NqaMMNZqAS{X=rUtR@tTTv=_qK!`ux78P+SZ{**c5N^ziAOB=R%xsIb z2~DTi{MNcbHoh?7d@Kgv*s<8_Re-T8sG$9y{y)l0y)dRbScx=Jk8mger6X;Y&U9xj z(*Y~epkz82p@$KsW3^1|E^7>kh0qpov7=TDH+rGthGo}1E(>UZAGiiz(|c;rhQ`_$ zmtT(5%*Z7(@+eoIsrw2OQoGs%7<>_e%y0#|{);Rj6}uMR1oqYoTe^h&4K@O(>&yBR zX5=kGmh+F9kqJ=%;_}t5Om}_AAR(>Tb$Wa4ns64udPVzgZdPY62wBmptT?YJ1E&0-V$0&x1Z#Z|>o6SAc_X$wv-l^uUg_LS{tlcETW4t_qWx~3TE zlsslylXjd6qVUhX9Wzc_d|@y&*~!V2t~HKQJOq6$U4 zMid9tBjBw~OJ)T99evCez4!Tzi9S zKjvDM_C7-8FVS9|%6+u=(^NhI4*ZyiK*}=54b%?8y0_zs%Z6#x7q7AS{+)CelDgq( zqshQBV^tTT`vCP_gRW85_1=EI%dDSonG-K?kq0l)qyeV_tN>J^1669Hqa4hrg;xxF zKtb#zkXtofo5WIfrc#&~Uku8i8Anu9N3#GCe-3j9vpI}gW;(@6R(z3-E+IMx`HW7=RDMkjOJl*hyzPn!;oC7z%=QG5|VKUN+p7AKB#F~r3_E_UFA8%Kcb znAkx=5KjO(WhNnDHfPLc7|wvS?I2mWU}m&W$cp`A3=Ll4Jj47a_1$gAG((02R-6cp}1==UwB1@j| zj<>SaO#o7ML+~GRXCbjg_=Ma=cY!6j;^y2E_z_-)=~m9dFsS^ZT<>U+H5PY+ta^cJ(yn9OJN~th^3X>^3&SPVHZi=_rev0!p k?ilhn-e!B^*SyWD{t9nzo9D9Y2$wPc-78Hl&unb`11|g;EdT%j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-SCHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-SCHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..415202abe058baaa03f98be7bc54bac5534a58c8 GIT binary patch literal 1670 zcma)7&2Jk;6rZ(Y<8L;>DyfO+(j*Ant|d1qN<%AkvmGaH*1Ox?HEvFoNu1b~6GvVL zgepQ632|9%n}$X^RK0QGfK+-2Diry^l|O(3M-Ciw;2z%FbxKr_Kwjz1`$7W~VL|5=W2s zIle;(StflHaYA?!Cf);w&s)^A#8O$IqAFEr-rMz@7~~>WO=@_~@CBjQ*%aH2j~Z=E zXWb?oA>Mr_R;sG9Rn}B*kGspIyn9Z%tcp6MCe2e4iVaS|(>c#c7iYwxXvzzcK_2fX zcL?Dw5Az|!@?-P)BKK^Act0(MYNv9;T+|0T;saeHB>2#lh(H3P#|bQF``|)*nvj0$ zIVdALue`=JpWVvzwG60-yUIN+^D`m4%`ddfVu*vl-6yAOIot&P7$GU#x;)nZj(m;A z0T%A^F_u_uT5nlr^bU z63wN`oTiA!19JtAipiS3B%1Wb6e#J6v`9t2N(tD{6~PwK4Q*aUZ5;5VeIz2**oWiK zTg0ywhJ;}rqbeqkwIF}8iO>8baNNXsL#yhHZ?f@QY(i%fG8;Pw@qAeY=17VNm9U^n z<~wlfAa4;jPC`(MDzt(nw3c-GDqeNQbIw=|yCX_ZjOoTTu>@(5Z3wtmMKDQxP7(RN_bK-b}Bm-muoqBju zCzl|shb1X^dkNQcn{LPLx;$cntckL~pc_QaIqgJzJC*Z3m?AH1w{D;`R YZfj$$FyvQ^or8L?^K6`ab@k}zFGIZPga7~l literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b691b9b3ca104e7fcba117363ed9f7b1db50fc6d GIT binary patch literal 4335 zcmeHKU2NOd6~3fw$C7{I-xX1u^hR~kL^0LcO<~7gR?sqSE0!sRqN=*XHYhS3ah4^8 zl#>}n1Fr=(6kyw>K|9{2*@_NW26R7NR$%Me!N3Y^FGJCnq7Qp0us(F?fTH_B_b?3J zIrmDo6BpZnWe)>JkT|^OobR0P-g|gRUM9^C#gjB%S*hA3%b}IkT6MKXmnsf*E2~by zqD!EskHk}k_UNn{pNmZlhcY`X1;@(QtVL?BTJBwb2E*a;`$xu4 zoQQ>{)l5=E`mm!r(?O0z?W&HtaVbYtLhQ z?vRSFeW`OJ)d|CoFDIW)b-qc+<>J>|h|% z27_P@GS_p~)0bpEF3InNAo*=f`prht4oCpAMnaI`M&C_CG27dhHZaym+Xi{y#Iztv zP22Zy7i#A96%N##n8;G0j(#_dsjdJGci2Hl=aVm_VJ zhPRp~w!1*jwq=C%1bQK0OH$Kk%vs;-8os5UcEUr=ny`ruVMqKcI5%kzs!1Gth)86u znmGIbX~(mMq3Jt1Hj~iyF4+3ES2C_O;iwbw!0K9$I%lWJU>Qp^-8 zzk^D6|0b1mDxsU2fy!@#vO}FZoz0l)WKu)b3y`3#{sxWDs@#nsR!eI0SP|wznmgv$ zAo}Yf=L16A3!ZxuIy`4;QmG@*OJT=QL|GJs{Cf_S-{TnhZ6P+Gv^wS!4{1}h0AP4u`7^!TU(;@G2D0z!x$c7Nl z!&LEE%j&$I5dQ@0MS+XZd?uSRar?;QLb;ABlhMpGUtzt=Z1iE)mt$il>pR0vCRpER z+30cBf0T_KX8jR%GR*q#0&L)Y-@DVTId=KnDSFYa6=|N9D`myCSE}&!nRlH08oIp) zZl>kdXylR_p-XxAG+m^2S$tKZ?h-H8E56q>F%gW2{}Q5#`o*@0h9CJmDiIamgQ+&k@Y$!%qv{DzVMXKp z%5D~4^u2uz7JR7%1*M!{v3T-_Me;*_y>5lGVx5oGVCgYxPs6nJUCc`wOwuR25=tNV zUVkIuvbA=x;w-{^MJVZgo=p1cZkXeH2MR^2uuNU6wpw+?KZ&Rjr2#KMGJ9j|8dMg7|`SI>h#>YdReT^3WAUnmXK5mLapEuoTm!4K3&yxc_ww5lO6u=5ss72^xg{3PGq6 zge5cCwDi2|@m0$#?Jq5J1xm-8$6H_(Vf6JQ<1OQ@*k~^`2=;=pX~1~L^v^uyg77(z zq1MF||9#)FHSpNb>8jvXM|Q0gStUx-UhvBQkoA-a0=V5ccdn0=+*LDoWy|hNXd%X% z;a^(vcsJVf>m|?LabJ4#vft7)LGXzp(jE-Kbh+U;9YvM+Bb0eFX5!Y|&Zs>FU9Q4c7lWGjzxhT_g zU1plD$GGMMsBGf5W*;h{i|SEjM3t3TOkv|XKvcE*Vnw}rdKVDs_spjBJ7!b*39~7E zoq3m@KM zzaK*vpJq120&IEDUN&o4gFPNnvGW1$;xu;=<}P;82Iv#sVH4!b3OSGC0O1!PEFXx( z!-G*|Z_rjGU!`qG3bge+Z97d{L$s}vw%$S8PJ!6{Cm2%}jYWpT$i0Rf+sVki0#7uM zd)P&6Q$0^RQ2IqS7xxrxNA5HihB-M#x1-R_`dsfZq3aKv+=Pu*HEKQt&vTwY!Zrxq z0=lkOKUj7Xi{tEX2EW#LSyuoF!(WA(Hk8VTq zZHkp7T<6?3X+Lt$aPA7%{0!Tb!edSn}Nv?QT17nVGZ2 zg?rG^D}3%X*rXaG0^rrJ%(h+DQvRMnOxey@^Sl^M>@00-cF~mZ;icV)_@mD zyJ*mcJCg8z8!a?2yRJ8#HAf8exPAnpncyjPka&`C<)P?xXXVIwbyfQd>%wq7 zgkhe|WGx6Ii3i)HIW=WiMh4>QAZOr>m#g-X$*f^#_Tgr6E%33;WqDgMm*D1n&Z2k0v-~@|-14A(NT=6>KeOyViptix6#wQF zb|h0qa(b;}+sM!5FwNp$m@n~>%VI_J7(7Sb!uNRE;1n9uiJ3E#39Q1~AD`fjU1X0> z@C4=H4S{drqKh`b@qsp{*T-?vDRlM>sPJ5+^0$8WDFe%&mwc(#FKET;??gjTsCDV| zSohrQbjyTa!&WYb9b26Ok{|ctau3agle!tnkU>=o#DY<3><>CnK!c#M{6=W z2lm15l$D(!2ikDOF=orqqG~`l&l#n%1ZS0%m88eWOrirIMf1@5*T&l+ck3O<#O#Fd zSA}E4HyN9-9gePZmT}I^&OuFVf*Flov+b&}#wB`zm!ZTR@JCcBv=t`r$G?4)Jpu)Qw3JScl5yLkc!3C6T> z*|j$~yLQfiiGAp^%eM1v`{&;M1& literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..81e063ecc93b105ddc9ffd7e106cc68df52ae771 GIT binary patch literal 4762 zcmeHLduUtd6~7P3@l%o0#IZ%{-kQYm6kikDc{pB^`dYfS70bG^bQQ&cu&VO4tyq>E zNv`9SgpiW0Wx}l!mfbH~{#e;a8Ei`f>(->hg}}D3F-B<$8+5Qo853jD<-C69eCM3+-22_D6~TGj7gT)Nx%pJu$|>1}!u&!(nabvre0Cw1w3I2( zD=+$th<I&XUYoiGnq$m}-TnJ}`uFYY zsvXjzL5lXVKE2@3-+QR5cJ0~~(VZ0pAt|gPsSyOXAPe@TqT6fgQBxfX1a&o}jp<%{ z#V%GuEov;PN96D~;vMYE%vUpysw_hzb1VU;U zO4EjQL8>lA!RVr0banTsJ!;g91VY0q*sopLc0mxFvyE;E^SM3q&ZziyM*6|`N2T}< zPor2h&6B*j18C(3ScS#ye*30XO@8vI`-=-W($O8P}@ex@5R6lK2%|1=t2b zSiR8(4E#!aNdmb3mwFJ2t`8mSKuWy>@|Fvmo)l-^=IeoYe;;kqLTD>I)rT%(c* zZYwuh;z}ujYC(V!R#VBg)i_HH1M!d?)x;7!T)K%PM4WFoAsHEVfe? z7-(G@D3)`0y_`eMsmB-9(Nm7v5ckgBqaK!OtaU=2>y;@m;Ki$Lhw5r!XFPB{#(Zv- z^QnV{XsmEK=%&X*Vp;+V{m_D0ax3im7B;==Eu)Z$ypgW-I~^dLKV2s-hE7Qy-HgKy0O>#23`H zP%Nwt8IiH5mx+?N(c3hlaLn|| zjR3CqYM}|0>oK~#1$3K&MjRtBxBLXg^9P0lW)!5YAT4VxpN*#?>#uvZjK zWe6Qk0NIWZbb`L<$3f8yiaISA9?{BPcG2Da$hqi(X=DyO3^hF2EJ)v>AJc*;90#Ea z`=OaA#vop!FBXaDp>-!O6VaxFZR^85!m6lPR)=N}M5?Atj~qtDc2G2oX`{NTMIzb+ zs;XEU5XXJ6$a)Z0bo`XHBKa|U3dwDzAUQ+I1yWk1JOW-${g@uXP>usUlzg8fPR+~6SJB!_Q7l)BPs4~Q`|y+)?zDAq}eHAb--NV$nCrN45e z^fQ>(+Fd*sH3|b7)FF&?m$f5#m&jX0zDeXI9!5G(VNO$+5eU;5)lJoJ_+n$wat)^+ zWAuY%D_Dlq=)~Bd5md{sG-zyw5;kwti)*|=IF^7C{{oUL8rFRQ4cuXe)iA0*LiL#D zix}%;iXVb{)6k$13;8+hJ&>y+a2p!fA@N5j(ukq>E{Jt73UJ@)A-GWYCfkeTbs~#^ zs4wLRqZZ?kDU9-PjS<#^9tT-3k`|Jxxg`97OTy1dx=qqINGh_P7g_H~))QpCU99Ix z);kRWoX{vN z!#AQ~ADwl8tuJ9zb0UnDI0be9h~uB^Adg0eyLAB{y#ZIF+kd<}8%#vD|` zMj&MBSb=<%FC%}6FC)JU5O=wD*hAPsGm5Z_1iL`6K}zEgt?%VT`Xg6Lzai;;B41;> zz+E~EH=V0||Et3hBNpa2o-{>HCkY)QqCuxC@9F4%grf8kX~&Hif`>;e#ODPO+sL#9 zw|P8f@Tr4yz>78~C>?mefFS;Z1I0fR`8APW5cw_ut0+r^UIY=JQ4g093#<_>r`Z6K z3`w)4_~WQclI|Gup`^2|NCpZ2EJ@EWKPvZ;w40Dk%!A4&24TYO_IJ%$m=9sCFCot8IhkO<$^9NYdGt9S#wREt7U96>z`8}+q6P%sncCj;G$fYvVM-D5gypn;BK>i`g zbxL+hS;$zY7ZPbDZDpnlGw3sB7oRe%d_ieDr?n|l3HaEYR8krGPDI@~93RIA_LuF; zcviRiB04-$)JIO5U;w6B3r1NTz}NtvDaQ}tE3lH!thKb5%}wSp+8u_I;5g5Nvf*_u zr|n{MLLsLT!CDG=D?NoSbL82*T#M3nyC~HnCqLK_O8&iF?5M1s%_xN#OPNefL#$3^ zArDPb<`T1(n#ko6OBmuK9$J0_PU7W5sQ7|?xn{Y0xo5d|dEfH>PS+aSJ(owUBNg_gUnwBbPvKdBb|r zl3ncTAJpMc(&@vU4^g2qB<1Ni7cI?87Y6d%#YIy|O-=De!&iT9NvV{JvxogpCg2~A zDJ7vyW()YI#e5>g6{UvZ&{mrGpF&LLI{9R0Az*GXmAClv2d)Tprv}6U3EqF#+=5;7 zq!V+`PbP4dAARG3`%L6-T+ju(xXEvrVJ#35tJu?E!CF2=6UiT(rGZ9Xd|(%Mhtn2x z8VbnlE+{!`(wc&uRL*I*P(tBd!hbsu{)Sy_*xTLHyKn!2gMBzsB7?jV&nLlYdM0&h zHa(Zg&Y#ZZ3kxqSo>{`35ibEk8}#}0q2ZCh(b3>o$Ow-|qGs$^{P+a!r}#1@#~*_e r#Pdg-mv|3ggufHdA5%XeoD>6B^Rq*a@yNzct5qJlQuK@|!DqQbjviveS|^XFKWS{4Oc9Us7g^*&H+m2Z0R@?d=~L80hnl zDW=A(eW=c!p@F?aq1}D{rQ5goK!M}96t{?^f#U+4$ay#1K+sZ6OCF18svK3O)S$QE zx%Ds>Ic}zG4Nf^Pbxl8kGBG(=sB_ae3TO6-zZ@-0fQ%u5et<`qqGeQQghFImy4C=O283 zQb=s;Y~^cD(opYg0lNHy*fX7-@asI-`GyNHssan#|Fbx)PB*PiYUg628-|(M#n_(3 zL=UpT#mWH37(LdqsJGnETRzL!m(T<>n>lXrl`d$&uaXNfM4 z*Qp0!?=NW2=`C+@+(PDaddsB1gW$p|n-WsRWj)6=p=zpY@l|mM!AdQK>(yG;Cw7AW z#IB_~A?#1=1QWE;4Gs9+d2E?m?g#jC=5ppE2egp|g!(HYLbe*tzpCLhAc`OOsOIsR z71*QmDY{jk&57XYUsa02D&nt!OfZlESs?gfB#9n~%@0Wf^60|xZK#IR2!3(`^ILI= z@l=wM=uTi|fMBI?xjou2veht}KKg|F(E9p*SGDTLv?h8ggIRhhCoZRS=~2$8no!ka z%c=jdNKk`=olx$@On?(wycgUp!LS}3jo>CLPbkq*O*Q0^2q4jMGbs2;gU|$DBYe&9 zHNaO7UoCt!u(P)Y!-^H2kPX#}8?ZBn>DFFrPMelGB?utV#`gZOrYg~ROdivXDKkiT zfnTd_=|R#ct|JX%0CxJ8plTSpA?tA~7Po?8D=0JtmFTogaWo>X2dp+83oE9&e5BxE zAZ~z;I!#Yt4_Pm^q1JYt!^wFB1xoTf&{tqA}+0BBUS*o0DrJU0+pbtbKY)lPhP z5FNnt1P>#hdRWnb@ht&Ui$hZ^Wd8~FTElU}P@^kOJ;Gz(U!bq;VahQ;HXzc7-QOUa zk$jD8L2`?1MUn&a>sFm>h#w={knCeR15Brz>WKF!D85TU@#hSD84B*-p&nL^Y1xDd zYbxlAU#4b6!pIFqo&}%HQ_7?&D~6#=qufzuGQmuaGm{dGCxEeqEp57b>XP*+zm-Tx zHi4zaO7tK%1(@(Y?Gk=UEeb!O7KPWSMPY$#N0Ez+B$$ZBL`Ip&Cf3(Mx=_;3h(JMp ziE{kk82KYshE)|r`5#kj{12%${=3u~{|scM%~Y*1*_@sl(KWex>p+bR&HY+j2fT*P zM3fo@uEmV0;fMn2FcIV!!g~>(Qo@G*0h=uXJUU9ny2-~;x}6g4&(Paci3H|X z9Bah=2Ef{74el-pBKl3zi^L_t3#9kcB&d)PYV-%+SY?^W7smk^CC2 zRkcx^s&wYQO=Lu$Wt~?T=P?(uXG$1F?%B+fC|5&1fkYs?fe3%6obVpw{t60#YV5EuEr{Jj zv2W8bgs)Qn!V8S-XW(weZKs4^gf-B5cscCCH_lH`gumKvgvvjQ#1w( zEgq%i1<$6Y zr^(P!(w-oL7HL03h9ji?Nix(+I(o?94${#@hC4||2$X#fJohoDRLtg2$|vbVr8p~{ zw&%|kifIS?-}Bs$S+-M>x-KbQ(upLzb<$Ec&z>oWUBU$UUiH4<-Nch;TbMopz?;O8k`6qs3VEbicxz?zX~3jByqQw)4oeoZP9cwO zzeqlbxo?+*134D5Yk-{5{ko@U4%ieTb>2WW)ksTKZrd+zqt{!;}T-gFKeLy|K; zbG(p4-Cfj;_@^}{#NT@E&ZNYQNLfe97fKcGVLG!V$IhJqJK{UcPT6w>zaN2X1Zz@klqNR@K)_$GF; zX&4& zJTw$+%t3<==-Aq@W1joeNMB#yQ7p#l+A7d7J-lKHp-?L6*m5@S*m(zHIBTN^jl~ea z)O`klI&7hH{vX)Fcz8%BUru7{7i;3+?|N?E(1;3$lFHuJY~;%esk(wLnUyuwhlZ}* z;u=nUN`dS6{Q&2=ow?-9@pKZG+v1Xq*TIi@t*-y-Mn%|Vfx{p0k<=GJOxT8 zGucz8b2ItE?3todnmc>${5+);Msm-& zch|T$Y9f_Cm3DN_`R;k$bMBoxcNe&tBSB3H=4WOzS-T+R=Ss74CFw-IAQkg-g`_Q= z09<-Js2l3}2_-n$x3AwDTQ!m_*jC9-N#>kgOj+|grT)E=GF!-Gff*hKv43P}U}SKx z&pWQfH0JFKZFY|g4vh@%>hmsNyTbeO9LFWOB_s_T=i@}qeZlbsOf_c8<6%veBg&K- za2H&s9_Av)W2)ggZ39v%KPzYLGjc``epc&R9?q&WW-{d~$G>0Q{ z6sD$xR8FX`ctP*H>$LO_%L8)EG{TXP95T6USJpqlaW!(APr!U`rf*I1H*)+Z?@S7b zE`J+edy*!(xEbim53)}C{qXZ2^#9ZW7)?P0>Hk@s_N9mRCAniM(F4;=?quS&rNlNA z151?&jx&0!Wl3*&L2r4Ai7%lGV4FE^>CJ9n;8&>)6aIVUP!&xxw?KQ{6Lp*T^bHyT z#M=wnb9&3qIc_2SjNURS@SwQx=Ej6n30co^O=z0zUb-&E5v=r5xK!rl&a}8Ac_yfsMhh>RoG(p zD&g}K?rU0aRMTos1WtcY=^JaBw+4#EKn7%h;Dh-kwn6${s4I~BS0zthHJwI?lNDIp zN=VG7Qny48?IP^G`y2i{)$mPUel31s>pgd>UcFe(#J0*LmS4(>E2Uh%pIxodsu5dG z{g2Io+8^{oo0rl)PH1tz=WGrH^~hKl-@NjK5*gD}LmmwS5(&iuf|oQ1P4G0r(+p1o zJoWI@!czmU`?f$(F@qDbp_*|6Ue`hTzORi<$4qrf5J01y9SA{9RU+}IJgys4u>j!( zeyz2s2S}sXN*Y8Ty#8APs$uActjEo0+zg0qV9*p$BGWR((TTVYu-bSusKnHja|TZc zaXk)gh(^9!;G z$WZIHQ2dmF;-4A#E;QP^RXwa4({cN|B`y+-=*I8pHOf7vrwG&m}-v8vFWK%U6ZR{B508Y z2d$rj>wwqLg@{^XAhpDzYA~#TIjjRYitrG^Q%ca#|HG#YaNYQ*9*>MswI1>{)ZRb| z_ZJv#szik46~|U_zXPy##e%y@0*JmwdXYFJ@HpxHCJAVyw~quKAiWWQYr4UvCTi#* zlsuo2ZAktBpIWsMT&cKlJs%Mn$*XMe8k5S53^K5nNt-DVKct}e0h4~k$gAMAH5`GL z2uxqq)G1i^;8y$rWKdlQ!3o7c>=n>$s_4k(bd;{d7eUbziEEgXc#MTO%zTF!*^Opn z;aF5tg6f!T>Zti3fX&L-!FbG6M%kL~MLqcX)a0lhj=;)9y&dF1BwNWYBz`7!GRX%9 zzH08UFHOij25Q3lG!5a`G`{dQBYPRRi%DB3;g?`Xcq`izHiRCJ((Sy^sSDEG|(uv^H zO!G-5T_pP+Bb}$o$WhXsAj2kUKScJ0N&CZOq?dH;Aj4ZpM>pB$CmlmzT(chDwZ&2) zlRLRzI&IIN%@nVi&M5p7-1r-OG5;bOq_F zNWSOYs)b<@C|Zm(f*Kj7E%ChLIs?_1MYxX?C94P*t9%Y=2JTszTnaEL2lu5U+`+6u zrkKxRxEti_NWSel&Aa*s1_y`sJT$x)kuwb0O%W`#=P1pL>|Ygk(sedg<0kVq+~bOH z%1FiendA8^+Ju;U&l*$lpRUtoNz7Qv6s26gRFU>W#zi}O0_?@VQ+x5c>j+*i0zWP{ zBYA4ALr8d~24^#+w3N!6gsHO#MX7ojq(d{-X(ZYcMc z2g>DopRdmGuJMLJ{!09$<~wkIq@yOetgILK6N+(-mHK9Uk|;@ES1Z zkhuzsh0GOTa3aEYt2&o}If}?UFbXnrRh?sNrxbOazR|wEzN6TfYJU{~rg6c}&CWvF zIM;0cEO1GyXro7s<>kXN(tPTW!-V)xk;C}>ZR9Wk{{1y^`I``TWK@L%M`d?uR*jWS zQ{62WVwL^VhmM}U!Zn;apum^*Z6D`4{;V}~JY`{~_kQxg))wd|5ALw)7fAmKH^6&H z7wDkVdA7>8Apeb3{DkXlk7jL{vXsi_wwI)Wow8wj+0q3CLt0V^)5U)R&~(%4U4$)x ze*zr8bvy}1C)1fzr?WG;{OqHJVrlNo*~jLwYG5xIY{gy>uFJ;u{F+%?8`<``{%gwc+BwjX!(Tg%J;2J}tXVgLXD literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..047a92211d505000a151c86202345becf29787c6 GIT binary patch literal 4763 zcmeHLeP~*`)U%$Q~XT)5y$b8*3Z(jt@v3_mY$+G5LQ)wjup$2 zBgsv?k`Pk5wIJL&Vd33u`KJ^z3T0_v-I{c`5ZD$r#wbl;gAVpl#>NI23>N5^cg{VM zlg4ZHHhOedE*mF@$IwvbO}Kp7YSvwLt~&tP9) zSM7)vGl=aAV|oYs`UkrqX6@=_(VG(lAtkJ$s1XFOAPdgLlGktPF-si@8M+$QCUn2E z;*_dkEowZbN1ak*k5bGns2TeOJA=!aF9@O_IIowgN8;gt6*9xlCGosi@4QxO2!+)M zEKM8L1*y8sg6yJG@^lZVJ!;H~hQgz&p$k_pZ@VA}?zu*eSchhFDw1{N8?gr zhp$nrI>D2?u><7#A7nl2^TD6*u%r_?O?0BWV>Qt+cNes|k5XL-0rkcR$**}#=!C63U z5QNq1ZJ@wkc`wO;(EqX?gktD}z&fzf?}NSN!loz1+4uN-VBT9XUNb$n1z~0Oo2F-6 z5+Q8mdP_nnCr~X2u!Plgs%`Zh=`K3UohTcXPOJtR97ybh*mcFnwbqIY6>LlpUpkBJ zlm!w!lm?oW9NwtpP;>I}vATLHtPKhO++C_6{7;uJzOZ&!NG)u_=MXqj>xPBGz+=qk zW+k6G$bi}kXM$?_d}L;%^(-qn@KMlLJ0=Ub&6{(u<{hVZ$qj%nebp-0u>5O~6) zF~3yLYNR^28sMsds~WBax)qPYgFe7dimKRD%+e<$2@qT9Cdw^D|KrH%42gpVi48RwHkQ!K!#9pvCm{lLyZX*$XF%$FE1DW>hufRwQou zIVErRBj=(Ax{A^$j*ba_{32j_gwP;kE zLYIrRfpFb}5m`5IM%OP`D~g}7r%>Et3W_u2TqLJW&SxOXtsl{&NagD1RPsHJl>f?+ z@+TZAzYCc*U@8I2m^yffc_Bc)K>=4uFd(ZdANl~CK*V#zb)2{+h^v8|o48Z@2X{)p zgnq5v#dA?((4dA6@zNdEj^YCn?~-_%#7mq;I!`pGh-M6E8e_Vp2F*Zx0!pr7_anz3 zjBJIG5j8e7F>D%Y<&_2pn<4kj8~x%MFA%mRpv1p}<%vb~KuCjd*kLt-?oZJ@p#`Gm z!<^zL;NCPcY{tVu4*L-7swmusCYDD0DVo$`Xnp`@9kc@6cX}8u^u5FOqIiSEX+YGM zbA(olbI1&`JeXsQ^XaPN_S|&nD;B3%> zhvP9z8|IxVzk)b;u{P9*83Hm~sQfZfT_CDqO5*^{@8?4L3wKJtC+i~;Z?atwE}ey& z&QrPn)zPRKkMJ8$nxUZMgbtI?pwjE_=@|YDvGkH?$Bh_)hetfj`vno(XlM&=^JLuQ zT?glYAIIF_bm9F1hWJko6#quzcO-sI;s*e%qAU^mGMM;`dN7SxWQ{m-iVdO2k~LT6 zpG04Zd`DOSEuC#eF--Vp$vVh_=G^(?sKH@M~2@Z!XG$N z_$^t#;Yi_QvhEP_hip3{zfZ^;WPOj2*T}j;$X8i2BELb%m&iKLf@fIs919#{O$jz+ zv8G8D46&wzEU<^Qbg-datfh?weXOMug58r&sk2bbr?V#x9#YZ;B?}*c{6mual-!K6 zn6*zWCNoOL&YmdFV$6h7ddjj3MWyYW)~3uP;bU`JNoVOh5q;;deOwhMTWA314^5VWag#8@4`*bwh2*H7Rpa6O+nd+Bs8KV3k!+YCFwb)J*5(T74#Ii=>L zLP2GLYbh4&%nXLiQ)KsYEn3^1l2nVDe18L#{3oZ>u|9h)s}yH#WjcKVxH^@^0u)J^ zPtMtDGM`T_A;qVhT7KKPRI}W@+_T)f+_$`Mxqo^8^1$)|1YCkMnzY%CvrRdr1M9Pq zQczK*ikT%9zUm9fP|mW|Z1Q)<`LsR!j4R*%6F z78c;=f@F4D$>dIhmP!_E;E~oik8~T8#TN?cCThn}yN+5CwQHz-9kt~R^GQoiscUdp zheJuH4|m=~#q}nsbjP_^xnH`FDCm^VSW0?kh8G&X`twW5`f{=Nu>Pqe{K7G#B$er0 z5r4E;NT#`?Trg}}QWenr|lWoO68n}6D1X1Cj7Yr;oo&i4STzLdi(bE?;pS(5*g%`d_Dz1CuY+p=Q8uz z+`_4Rp}6?M=`%~XA>u_qXv2Y^J~BEMIy`Pngw4ogG-kz*B#utuHj1xMa{M_sMLK`R n`APQyM)-_${+#+b>HJA_mGtH;$);yXwzxju2EvuIYis`oM{OEz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LESSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0a0e017b9123a86f6c3da71bbf1477dee463b4ea GIT binary patch literal 4284 zcmdT{eQX>@72l8Z*ZCu7*LH}Tn62x$(Yb44$4(qOK-cHBeewGCvb&dyQ=w{ex5-^{ zzH@KSNlcX}O4OjV%e79_Xs0xQ5Tbkt(FTFqCdi0_1Og!>L?u9~RH+gl5>g~2D5}7` zH*;q@2?8YY57Ol@^yu((yu3atlkvlp`Gn zTzV#=8|t|kB{DlOJ{UANNm50}E;(t*T5{a9z5KW|xL;Bhi`g6uMn{1i92*%L8y+4A zPAR6wy!}U;J!8Xr$A(7+f@?Rf^PvLAaVc&UNdw1)IFa+OdZDnTnwC5j)l@mA%&B32 z#rNuAE^@+D4c}`Wl1ha|Ip>^qayXp@m*Y9kf6=R-O2i^oRFC=B_zQfK|AN;XjmdGC znli0&LVd*xdgsB-;HW$#o0bucP0N~UnsM&N^|p%~7r5OT5-_D(ncK7cn|c0&@68Iy z?Om;W?FpLa&Fw(fe~@^ls|$Wz2fN<#07g?_f%|_}r>*Ixtx5H+Cc9ypsW4;vR+D|m z?pm!(aEj5VT2}Rzt9r|`jC}=Nz_6L)R$uFZ0sJbpVa&g;9IB#e_BLp@U98*2XWpa{ zfW5P#y`ZWqq<2;wQsv zHwRIk>;@Nf&IWB zgg7DSzvOKXNA%ca6wg9=Mu|;osv%EA0f|kUVWEjM2#xSG!_xpyJv_DW)WG4}8jdJd zWJWerD`CLl8KI|dtvPR6>YN~eMmsy6Bbutj5^;G-H|ESR;RXJFYfBH4MzMu7h+9Bd zn}|mgQ(ZsJ@f;RIa7wp?Rm0E?Sx;E;gcTNBLAfcc#O7s+qj#|lusTgoq6ZQZA3}eV z(dnpV0@n^)18|xeo3>^E=m4Nm(c&{o74p5%;61O67TA*{fbWU}c&ndI2tQdwe zk9tR$%OrC-&0I>5cMx-kSlT>&0g@0Z?;sMAdPV}^t+A3R=+1#i_$hTK{Fu5E-k|P; z74itm&M}f?Di%|jWGdU3tdsPhW{?qqg8Ulg_`fjndn`X|9jNj@qTcu)P;dOVsW<*P zC`r4iT2rz)KR2Oka`o+x78!7`+98(kS&=|s>Xbj<-G!5a)G`{c>Bl{V+n{kg&!mq+wZ`-`z^-;q|Z;@&5tNZw=IyA_9r5POGVKOtkty+PWMe23}ZWZbvN zID)S-?q#NVg=|IeGSj@oxC>6Ej4rcg|~DEz$debjQ?lGJlv>5-1xaIr{B**v=w zAa)+B6L`}9oPQ19A>9!}RV-D$=h)Pu&}T(6Nh7F{QQDV)=6n0@3hctyzbn};Tw@A( zq*=JtWb4yUb1u9Qr5v0B7C3bEPU4Ycsw73D=;{UgJl>fI9P%K&HkzT zbB_Dom@+UhFpoXBYcWg!dUSlF<*1OdT}RI5T_^8C{L>D4*I4`zR)&VF!_lWf#QzOP zHjeJ#2(#jUabFJnE#Dg$n^563p|V>ioAvstuP*oVW@Q85w&5>d=Ne8vp}@E5oe<}H zT{(Ney*DxIP-<1Ed>t(CIQ;q4>h(pWHN_@x905IR~aM zr3?ATN>b5DJFqnz>AZp=ZK;Im;++{yAKttJu=H?e_PXq2DKI*b$(}rwTgVp{pDwzk zrPF85F4JPwfQB*=nN+8yXQBsZwYiucKV+Cz;&AfFJeH38kR?RVvY)XrJ*RH4@zy+} S9iL>hGjMmQxtGtZt^E_Prld0f literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5a7c32b446d2d04720288b5e8ce507b2a2c1d8f1 GIT binary patch literal 4304 zcmdT{YiJzT6`sfHwR(7E%W|za>R6Q@tU9V!mSR~_+l*EtX|2)DdS=#ZITSPA9c$NG z?JBz~If}6{2}y96Zlai)xlY^$3Tc}kNvslxYX{NvMIk@ZA89FtKxrX;KyiQ6B($KO zbMLOK+MzAfe+oN$&iU?n-E;1}Gk1lnIUd%eaDILvlXVJGezCN$SdvcX3sNz^SV%h3 zX~3m(Vck&APb%T5-rYb& z*FUb98uRuaZ4M6g9~ugUdj0FyuJD08$8kw+4M_vX1vruOUUCCLOEoQdJff*`RGC(T z-iqhe!(8OJsT!W!+9#Fr3v$+3aUt%x4=F7p@pChrBeITDp) zFg0aD<%If*7xd11ZcAuT?vqW+h(sr3&El?I+4>a6`F_049$jU4~UyHi49 zS4S&fJ4=&X-34^x2U({(I^frFq~ixJz-S60NdM33v@cz>FUh@Yi7uFCGRVa4wL~|H z``0QH9B1@o%bMQulHT$R6JJ3Wz&3N-+FM<~z^_spCj9%#p(>hYZh`jJr|Nd{=^Hcx zh__d?7xb1NaokG!IlW~{;6ZWat(}R^O2~SSYeLhcw02!sN3haM;Zn7i^@+U@KM`DC z4dHmA3tVh4z^{IeN_(p?GVr^YzL@^66WYNNLPwi2La~yLC{@#GKolQ{QLW?io3Pcc zO~Pj>JkYe>tftkR*gy9n>lXZHDi5ZT=!Q)FSVE?O7*q7u&{;gVD*1Y==`=!wtiZy+ zKgPspNFkd<7wsbKJrEvX_*bjpn{cihlV5)&D<--tvDY7D{e5?;5&dWW$9X`Nj&wkm z*3tn^@O$5IcLl?GbS#2rq&%ra$28TDMh!fc$(p9fTtdwT6k*UP;L!| z6)QX`8>$sI;7|?IQ@PfhF)ejk5J01i9ou0|Rig2jJgytlW{~g#f4{Y*2T7yYLK?&^ za7ecVRm0E?S&v(>xD^xwV9*p)qBAnZ(TUg!SZzEOR!nu{ZGh*vxD^M+A`=nIBwNL8 zAk}Gl0`)*_1F-=HH8nb6O#-kTfJQ}&O)6E$a|5A!UMDTEU5O9hAz#K9!Y?32pL$Hu zQ1~$jwKz4!Lh*;-uQePu3^lsxg++KAyAES*cgu|_u?dkz9L|x4kj#-?NFE~(BME`~ zI`&E$LAjfB0ulc~b;VDquJ}i)E4~N)^zTuRsm6?KLIX7wRc|qiw;6c@{54N2Q>v^O zhBAW+=b5i3nXfa2UA=bwwqL1&3N=Ahnn=H5^gE9QrNC z5FS8yS_vEazxb2^t{WfKE+S@7N{sf~2ZiE0QkIGLaFDvB3!@ z4N@Y0L_zUGCjFF=*T8;DBnoE&%v9CXX;{kOLHsrZt2R44sThd83c5`d9od?R(G~YH zDEgvt4a18kS%_oIHw!P0kT2obVR8UTA2Bs{9()~Ya!ikaIZbUFixHqPgb!#M!p~?L!aIx{X5axP?WTlZtFHX$ z#E3j$=dHhOT!;0dyvGj zLbx7L(3qmaNFO6XO1Muz5x47Izud=U8(49_Cxb|S%cPGg4v!-CONRZN459Q6*^cCG zroYOhH_0%9-(k{Krg@3%K=4_n`81O*lHn)FjyW=Pg0v;bphen_lHmwx8zDnIqg(?xc;wLFVI1gW$U%x=p?yA@ z8TrcHxZ>YDx6_tbWGPdWa`{q48iBAyCwm$U#lO-R;&smz{C)(!SEl5d`yDQAn#kEq zDJ`WkvyeZFP?V}yDLOQ7&pEPPDA>#Bv%rE3c$XW>p>kjOV7b3MP=2I*s61H435mPm z?L|4^&V6x(k3Ba-LqU~tDap<*q-`mgwhMN$7B_lvQJ6Kkn+e_4R)Of?T8j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NEQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NEQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6fbcf3e4e93e783c36bc42e168a5fd44d13d55b1 GIT binary patch literal 1578 zcma)6&2Jk;6rZ&d$9589TTy7O08>jvW$C&k4I(&HXtS9lZZ^BleqeG!i@mP5INoTz zCPb)Fh>&_&siYOvPOJU{JwXphEk%~##<~9iR}S1bhBs>`L}Bh9?8-}}AyX6Fcv zek{pYa<_M!w(ViJ=kN4<+;lzMb$edj#!b-UFC|qYx7I{yy|g%+*3Ve#o^APd0~ioyvH4I6XBg;vZ4r8C{0`?D3%#^EYA;%?dL@b}oz<#=bcB@c;Rk&Vw7J!Vr$-<_{bvly@^5t=}#@6^xrzek5> z*l;r^Y?8G+|rfm%QMi{fpgIM-wdYzjREkvUVvQvR+csK+hB&5 zRAsrsIxVb;%Cbx}VW|QdWmV^637U$H!WeVBBpTA1pb^8=U<^_;$ArG68)PFE1COb} zpe31zidhv_RBc1&DHr4Z8EvRM9gnBLFe$5$CYsvmy)vVI&O?ttiMU56e z0JO;saotoRB5%{&C5FFgss_18b43tFbYg54Xl{(59f!dihTZjXabGOrrUh?N13R6; zGs1NH7n$3WFyN}}a5sDy-eb4sbx9+lL4=pOELRMoiLy?|!HvF2FWd@)QhABM+{oaS zh@L+GH04RIeSMg{R0#u?>BWxaIh`B0>qpzJ$*$9G<4^5@kL@#?Q%b>yhhHkaxCjetw%_wQ-EykZ#1_Py zVs&xX@||vTFH&8(R*tZoPQ(5JU#h#kj?YLoJ$D7b-Ylk1+gSzSBz2c=iYB+lZI#>H_c z6{^gvg$V(;Gc79cmmn5R{izU#=D_SlRqlrjA%ruh|1zlX_RiYaz%tQ=_8q>Bk zovcS9;4#{rx+oDrHp=|6qONN>%0;;6qje=m2crovq$CB>gd;p%5;opwiYB6iumHn3 zqN<9@D~4V+^jvfZf`)Q}yv2ulmLc%dg>ws)=tGG1u`Rm5cHu<;>Lc$65);xO#27n4 zXJV4k6Ae`*@|l&T9N5rbU>p6XJEEYGZdy9X%)bCq`uzSe!_Q#2&@(J4n=%Vz`kz3b z?CFj2iS`GYWyYsq98gJF62#E?E0E)&Qr_Y?o6dhyP+sW-VeJL%-4~ zc6vkv87q*km^qPepzHxl~ EH(eg;DgXcg literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-GREATERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..615c8a7be2849f14665cc3586a82b3b47e0d42a4 GIT binary patch literal 4965 zcmeHLeP~b{u7NmV~D{z&4u>Dnjh$yO}uDbiCEhlNg+WlOOl zIg*^j>zam^v>iO$I$`16ZegqxG78<&z}hwKaJRx(#uy_sgNBDPQU=^q*x9NO92<663SL39@cK}ZRUDCz{kEy#j>&T@N9J!YzbU`SWP z+L-RK7i_B*=Ay=9depX>`;>BFM$M&9q;oi(Vco2Kyze zF&I`OFg0yh7o^$>3$ly0)!I9#_Ng&58VnDsVZ&61qq=75(TH&I!p3I>!C7o}OBmU^ znfFG;ckKb-g7$y-eaZ|kmkwSo zsjZ8N4#;_GC#hYFi7r$EqqvWzsg#Y0R5Hs)a@j(4} zA@q{b^noBOWL_|uMkNv47B06Xlu7`#f&f!k%%(aQ-;{oX#!4m1p=u@80u6Q~I>47V zwnC$QxwYJfg$X^MIf_jb1^V9+2CCH&sHuzpDvh) z3l`xn1opU`Fn8#zRa#C01N|z!u9^x07XSW*XM$k*gzG*dNlPsy7Ih@Nmo{HLyCV9fow{s|GG7oE*&_pJw_-)TnO8 zqpyghN91fZ> z&^Cb97&5}cAw4{7j(}w&Sn8mE+0asj&}jvbO$b3J$cugm46R_O*FupIt?Ff4?%sP2 z$|k5r=D^cY!vih{;XCw$S_qXVK&ioeXeO#(1iofpJQ~%*cO1n`#J&*pZMeNgI4hbg ztHHGedjdIzpl1X01k~90nAZrY)h8e9Y=zj@uC$9wJXct( zfD-=!T2m~d`+^#{!@8>xG=GHVG0hh>?&K72f_Y8AYsABT4!aI|O%!fU15+dZ1XU_L zRNn`+9ts5RMm-D{+TLV4QM^jxBp@0pF+u^xIb;%9ZjUj-`p{z!>qpT>S}oUvzi>_X z6>0C1_Bv@6>wAjzA7OnV*5AYW9$@`hAaG6ryE76shB1RqjXjKF5FQ(A!dUhECU}VL zLTf8n*9OC|1wn4~kdC=W`$n8sr7CTnIplN0zXZ`y@nU5qmT1CK2N;e#QQl!mowRt0>7kE zPM6ArZem+tT=_a5LcYei<*OuKhp^q%DZ*00LYXl{U*g>IYn)qt8E5AY#v&ojr~6gY zK!^p#M$NxJ9y2vBuWk87#K9ALNR1dlAj8ziXNl@rqViH0dueD zZ3B1dX_!~rD*FgLs2lMJpQ1EL{zu3$OhSWYT7DNmrY{g-KZ!0}#QR--fgU{lLgvYTQ@j6582k9Qn{GTPpSDrS)JlO8!2^7mHWtrRAe*?ju=Y%-_h()p=!2Hj2DdeDT@S2|B?oyueq-fbt8Y@S|A(RLb( z%5l^Fx_us>1Uh{Dbx*zL918`Zc(qWB)dP%C%{qQ=Tbox4Z8|-7vQV5TA@NVy2#Oat zKMUUBeag1Fk_!3bY*u5+mP_f}BodT~XV<(7wN17qxv(YQT0t!T*|z#uBP-;Uawe@z zWT$|(TbV6EPL*TH>9m?G7L#+x_7NXNe#1UrH{UzoH{U-$Fu!Yl_xzsu!TG%iI1f(= z)XJ$0?F^D@T!S zE2^pEtLDqA9)^j{%)obzWPU=)6;47cl`N$nQIr&X@kkc4B}fBg8;xoOC{l3%_MB(6NNHLK(&{)`r9Eiru_`$@Xaa=O-MGB7Zw&T?1JE@1-?SK*fNo~Fx{*2mu Zzq?57);!6U$4It0?k)r2m1mZg{ta0OUzY#? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-LESSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-LESSP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b7ecdd94b20e4b73bd4342608ba6089dc6b1304d GIT binary patch literal 4860 zcmeHLeP|rl5#NtHSvpDQlVi));V2tn%kEh#tPk6=5)!TUR?=Ck+tcly&oY?ia#~4e zo$lnjlWjHFH4bSLx+sxN-FOTv&%$u3t%$u1v@4dZU=Df#LT~hON^O>w&kn#(q`Gt}+l`lxe{6ZmZ zOH&}1UQms=c5XybM?0VD@|kNi>4Kdq*^`pBU>7G-iyczeVM&=UWU?^m>jSo{|3G(t zZ*Qk>NHKNh?PG0v`g{BOdk%E^R<2#)19^_)(p(uy9mfSYk#jFOfsmz{mOK>EH94w` zX(4ynb!s6OIbmvX*JbT3YA0KhyOQkw(L>1N@eYn;z$9-lp>bdw*Gf)$rfp zxaFD88~#y&2eaiHElH^oKrP2X3gt|?t^B5N4~3OZ6!mH+)`A;UBzJ)=9kjwAxH?+Z zVPk^k6GyR~MS=Ef!a%kf!|T-;>P|j7ub%Fz*T!UM_8zNYB}bnZ@?0y-fC3+yWIJT% zgOv%w^9bX)RgI?}CSq-c(?KhJ*%EC)C5!2u~e6weZxyWSev&i5^Hmd<^}CBf}BP1a2#Ejk*yX*0t!c zH3E`tAgKfWs-U?FVRsZjwj%_Mpf1`m5bOX!y`slPl&Y2M1iIE;kACPz;=wyn!JEy7 z@IBg5MMvfsFf~{Y#X>d#{+iT8Jg!C8T)>1!od&wC57!8@V#$(vR0qLRVEt{1itV6i z98*R$S&7G$2^7_kHXxq+pb<44XZHM*v?BR2c>>98A|W};gbPe)GvPB}<<*XAadhQ5 zNL`8dDN_6sMT#F%r1%y@yahv2Eq&tQ6;A?SDBfg--vV#-m9POhhN{N)1~1oJt@ zd^R%SCMp#EN`=DDpnrY4X-u*S4XbP5Mz~Abk-W>uTa0{@kr$~O;R17Win$p9H%+Ey z$zelHjKLBpxEs(%KWMgsW=J+C#s&>tuD6n})`F-46VYkl$`f_T%=ppl4%DeOJqYvQmi4XhCVBV<|2A^R?{_0Sry549*f zD0`FaNAfx&X8_Sqi4j^aK_OG<<>4G7q#G>`ksc&1jH{&__Xo;xKWE%+#(jfv4(Wb@ z^qe5wI_c>o-H(%=X>j0u4!nC~abp-O=qF^1p^?+@tU}S3|hM9OdauA5;pX3mdzmYy9H|Ug}>vRr}%gAvi z9B14hBc05AA2Z*}%>Cp^@FKoP4aBlj2hV#ahu)xxr6Ao8mqY*fNW5~igL z(iRl2Ar4-obvb54qLzjkh*#+};+N<&;>!RDRC9+lgcY<*guTRI7a44jg>jh8AEHF~ zBNYn2Vch$Se2we|bKx9pzUKAkfjk^H5;3{~g(+ryf>}iwQJ~_hukq;S8Ro5rk#<~= zAvjDDQQ9|%*v3>_aJk152JJq$A3~_}g3yEe1{nSy6v+RXkzX_N3r4;Rz#0}ULSF(F z&#Z^j@FmiOnp0!|Nse)|760QXOEcL~q9Uh}tw;tL{#nL7O~NSbW!xTyY$ibzKE{v% z#`zf1OF8ZVMRLC*_}_&4Ek$y_V%#q&lKX&hcNy|~WIH0i!;m)__icu}&bX@#`3l*A z$j>q4i;TNK!e_~jS)v{%%}Fv~k>+s{j*#Z3iMo%p>?H%cNlP0E2T4l@7<Cz0^j=9bgmR&4KZReFX zX(|Q(NhhUDj{TiP*?DXy&j;?8-OG5Fx2kasju?5}O{7PlyA|Ce^#CISw6{Dzbe)zB zan0I`XYz%~B6__;uroXtsB<#B#`KiyNGXXKSIFAjN<}+6g{E`NL)VfIx$Uka_;4gX z*x*w9z3c4X5KTTOm1b;dGBcei6+5JbA{0@YOU>GHs!&KRqN|VS6yh6jgD)LM!57@i zbxU1K-Ag@7y-Np{4lW&9>SLOjjk8X;j8#rh)Hdz z?|*VNS?HjfA`gxWXEH^W{=q9;{mB7-K!8{4l>p~D!E9>o`N6y&Q+3Z{{KYyxFEG?Wqb9NC|jlTp4 zWl#-kL&GDHBcu9Q)QFA8O)GIUd29mLkbjv4M^DlTHm0X!h>e4Q;r`CX^rZU<8`HDw Y8XND(G1~krqb;6)?*{Jbxs{cF0b#Q~&;S4c literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-MAKE-STRING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-MAKE-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..11c9bff862c5f22253bd1005df07a5e49e659763 GIT binary patch literal 1680 zcmb7F-A~(A6u-__fk2jI5h@WK7G0;#;E3?i(ri;@%q668?8LraMx|*&5Ee9-APD=^ zP{+gilG3qim2W3r_q_73iLF&8^?i@~6ZSf^=Sl1w8)(#3+Lm19+~4`SzjJ(ivq!@3 zsG6uYZmq96wGFYc)m-0diYtu`akH_tu~ZXRKreo#8YcaGUQvsgH?loehh=G_w%DvK zi)^d5xxDzvsF=MbD(f4o4s52U0cLYk*# zLdX(nqv$3iPJ+b!x)qlgwU|6t(5S2{B`UdlZmSDwk!_2bZYwb^HXG}*Q~R*yU^%xo zi9m?^RjX^x)>T$8boah+Tj+J~wfYLWT!zw=JSBmylPs8Ba9i>0v^*h~lp>WaW)}23 z*?-WtLx^xU5f31vpX-l{!r>bE?MX3EO{Eh;WA;e+C~iE(VlkCh&?4_uYSjf6$3&aY`-6< zp2q}W?;@m^koM|Qy8Vd!*inga_q39(Y7%%K+;qZD7&fqu4vNmQr#(8jjxp7wv-HE! zK^FJUMeuNj0g6rvPCy;-gB>g-j<74}#H7Kcu zK3l+NE6*$XtVT_FrT`i}Z%Kg&?+%1va1xTLFm+xwDYH#@@TxaC5o^I>v=j({N6H^9 zRilb-m*qLbELjp40>VF|nIZ9Lup11aN_K4QYzA?9f_=O@7zI;Uomb2Xj|XwsViGk? z!;}r1m2D;kd%&SrQuGDc)8j!nbvF43x2)ULTSd(WGKd_8fKj_Y<;$z;X@a= zh@Qd@Xv1aG$m@ujP(!?fl#IRRaWrARu-8UJ3|{t#j(zdkMER?z&4M;W_1SR*qv&EW z#bh3Q9a4+g@rlW)D=+*^O-@XV`$r8yE{C z(KJtZm(jZ08e+B0rZ~K<42vs^aAhxxt84yki@NPgSnlxd6%?^uf+Db6K{~&>-@5m4 z>|aq$sxT@)Hy>JoQB%<@9tAf(;@5EKwlcXH3R6e@%hmhGXr56xJ$u_aVUziIx3cCZ VNM844BIKRSGbee;!|CJWzX1s4*r5Ob literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-CAPITALIZE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-CAPITALIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..402fe0c0b2c75f112375d1ae2388fa23bba3cdf2 GIT binary patch literal 2597 zcmdUxTTC2f6vt0-Ama`6%h zscoV$nWWOjX1)W70$))TA#>OiY^SOCL2p;Q7x0*3v{@P08kX={^s+zpmD+T)k z?M=D*W1jd-Vr(ukE*SHP+3~SA8-%6b_di;j08)A1TEQ^ZNFZ-=!%XCvNVpNwk z%PeXZ=F-z*D)Cw(g>=r$ay-Xb@0srIs1h_ns$yN{&++-zMYABJh!ILn>XA8@dwmtG z&Rb?#Q>(aFRCGfNDLrCPii8X)96By@*RJHA=Qx*CFbMhjQfLQ)?shcBvyUvu1Y@*TCX&&3ze@WzfRub!`OUWC98(uZG9n%rmX@|wUw0^39CfG7nLZcsY zv+RzotyHWZAe95J3-Ws!UPA$CX8QzQ`Yxj9{;*$wpM8I~%kweYQTR8*;zPMG+;=s|bc=Nr^_p zZdL2o{fu|^9jL_Q9!N&-H zeXze%4U1Hts0`zMoTpQbDqRt%x0w&(V^#xUGT#EL8D_pPs|hgQPF7P-X4ih2lNHg_ z9tB!06|QV+2}Jarc@R;Ac)PjK-1J?|R?ri)i2sAtK|CO97F{3>jpFZ*`?sqyvLBG@&RqSLbfP2V_Akf0Bfv9TO z_4wH_J|JVJE*o~?esXNzG7<4NSuw;HEC8|MXrHo1XxAO>suTGx^TPPH6M4bW&auWf znD;ajkF(Mk3mB|)fHj6#X$KSQSy?R$)UdK@)>zKUw$Wsl&oXxziP<@!dP%AlCdTLo zc3ha8a()|OTSBM!hnDFbdszsMCnio+CnsMyojNm>o`&Z~#}nV``N%SHyz8;_%(wuY z0L}tcz!6|K-~(!akxlq9ss-u*5f}vy3ie|47!Lspz%Z}~v;%Fx9-taH2`m8(KnD;2 z4grn8VI(tYePCV2x2rO!$&w+9PdwOg$dENDtg}1{V*%$P7?v4m>y+s;AUi+q_WxMs zHjBDZ%_V)kzGy5jSZ3wf6IDlc`)Wpn=l!*HqxIs!g~g%aw(6yhLx&pzXgI&aGK&ug zt-_1Keqo=`BJ35Kg(l$zxU$yE`#K$708RjBfhyn#up96JHNeOw{20{&b$|$r0#sgz zdSD1x0EU4@pdDxf_5jtuNniWl!?c;6a}Mm zj$Iq?5ZVOQF!hw06uLA^l|(}(moElR6XJO@6!c(PH}kjpxa$+#wU7HeRx}#o%J#Xr z&ewsw`-bH6(I~v5z0n&s(6|&Jp#PD(+s*0)t2$c;Ur>{5cuCf~EzU-mSh+BI3(8V` zdPOalzrHuHpalTlo>R_hflmmT%fGG#`aGN;)GMnj9>ap&M@SVR3!~YFg{$QI`+DQK zbf-5ytJ;0;?f0&dS3nO#h;#WX#U*uqzg36pfSuoCMXU&p$->@~|C3?A|DZT*wFU;9junVv?qIrSNnM zJ)+vB$hwe70i!03n5T@EdrDz+LNQ4+r5-_-&5RC5Uvg)s%osFGx!>afk1!i9Ns&c0 zlNP!)z2AsY&ci*p+SFpS(pwG&AC3%8$K6Rp!s`c<-!R35BBPN8y_LX}b)}Li(*RTj zs3Z+D33>%B_XYr$-wD+U zw(z}LQ+zuo+-*`5l6WC>R1psy_{v7`tM2ApI!iQTQ>6q{+G@BP6r| z1osRTM9=`cl)>wkXKf_&=R7XP*l*3C{|$ZtnL80zo>xXEMyRQAcLf?Wzud6+!49~ z{R-~GxEGjs9Af$V#lDQ{76Tn3G=!oCGakrjrdzKdBP)O`F=W#%Y^lqU-|1%XCqL0z z6hF`w6yGuQEsZ1klA+I-=QUc58jsSjTlsOvUSsB_i+sZgv4I~Mg8v1>{OAPx zNk{Gkw%+4)&aasD&sNQr&sNNyob}CC0n7dIQ1&awjt;$;9nOvH%a86qFg89>m^?T& zU7R^|_{hUH|fPYoA&7SmX12Q*8Z)y&Huc$BsX{r?cV2_NSiS)QsKX z(vIzKiMO`3Z`t}p$2MfzVH09P>XN&YJ*nP4rC-(31G-^mc3QgzccVv)<%Xw${K<5; g#h)|XZQ^C7M<$r8d78;^iCX}=mB9_T@=Kufz literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-UPCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-UPCASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..870d016aacee864a2c3fd966cdf0404cfef42290 GIT binary patch literal 2477 zcmd^BU2Gdg5Z<$s)N$fq$F6CuG`*%Iv~JIhleDCvrJOGp$I0c+xjWZQp_Je_b=o9O z6Q@6vrhf@OC@+m zK6~c-c6N4lW@mkKqWw`e_Zs(&d@X#P-s6t^=rML0t2w=GXsMwQHzrrPJZlU%iZ*7BuPAq`s-lQMC6mb{>M z&bET_cA-^J4O364NgtU#Pw#t@4}#N7H;)&*T=bQANRVlkw}26*ylt# zUkCE;1ECip5qKg!ksB7!I29nE|B<;<%i4u(ZLSV}ASb!dlB{3U4`^u`*kq4I$(F_>hMAizf^BKL2@#;YaNdeD_4a$8(6~=&J%6%>uScF(>Ns270 znY7TQ>3v3&axU(lvrR2ZtK5|^;K7E$?zr2BNVt74frz`;k})M71%{m(Uae5|+WJI1dJy&@yUg8X)hw`+pB~?TRA+Ny)GbP|zpne?PjkZp85%t4WUZG;Soa!ZL z6xnsamcwz=of@tMRfNt7N zgIU^a(qKQ0r)Y2+-L!#**3srh8fu{N2n{)TAG591W`3%~H_V6){O};W4-D}m=y7hZE2-}Yxe{N4l!_2m4c5IAcb-1)``I_S` zt!PPW8=k%gOgLG=|hK)9DNxrqAWH%4dhRzJ0<>{ d=}r+ZGd(=cWN-(Qp)w}{bPI#)$))7t;@_9kppgIo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-CAPITALIZE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-CAPITALIZE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..57f962a0a50796bd56b5ed26b46e06958a19fc69 GIT binary patch literal 2002 zcmcIlTTB#J7(TNLTkhF~1?!4>K(Mkf%T>h{)L}R*Bg4!xmr_KebXi;~vV==*gA%Gq z8NndO=`_R|E_PvjNXws(d4gLQar7BI@mnM_%KmYwQ|C!k$#c#B3zqXvo(m9aRby+vqtzk(XNu2F0GhfhTma{Xf*;#6> zWmjfrK4_zzXQ;HaJih>k-d^PMu+ueRBg!6=u z3@IQfB_vFO#Qn?($1P@B;*g>;QIkel+}(1W66i&=O=h@Gq>HZRm&Aqad)WnS=lTi} z2ys7kN``DrwiI1+?+cqkg?rDbR5URStw||H0wvF)V06KC>NBop)In5i$!KLNJ-_G>jl?(uY0L9YV#_bv6FUiAYZTe*+*s*!+D z3CFJwj@MxT(3cQWK}caf^LpVMa__~)A3SfoWW0L38X5)99nm{^0FvFELl6RV3lgGx%V zOdbwa0auiU#pPkw33tA-+NB{vcoFV%6qoW7NKwSzlvHFs1SW)4OBS*l5GW$shQYKK zE)N$_mj_++@2O$^enH&Z^+BxMR7TTqbvN7AQ`G99h{@@3}lKjSFNPgyrkT~F1VNQ$==&A@U+H4)O4CuBtn4aQP z$?V;VYi+0iu-{le1TRAF?*qYZry5HpyBp+cXW43NF z`&Q_Mf27sDI-VD>VLmG{=kDq9n zZWa62Z%s}m8#nsSoo`FDqt%zL2}Zg z&h0;!|IF+n@f?s8UdkPx8k@*W^SQa%skvExG&jx9UpU$4` z?L8gc5%2BG7r8)=5RxWEB;|wzh@03i=L2C=HcX)}uE>HaCgiZaXy?nI7Qr%P-Og8S z<7abI!bIjoW&+DOK0`P{>MbjR{dLrAne9lgk&qX9;obt_rv?s~g#y1KhPq?(9bcu2d*g#g!g)QoULa z^zH|8&xS(q3GEAA&x06U0Rs9zn>*797NLZ6bukr$D$~3(t8^_Rb;YrppshZ;Y7LjY zcEn%Q`~ZJjRL*PuPYGGfp40pTF0K;TE9+AA7!UMig!l+4j-@vg-zB&1>#|F|)8(>M zwR0YLUL6O%8qP-kP^vanyUeSpx>VgVzjrw_*xcjbsB!q8DD`@ncO6DWiSt#tEMCao z`TNhc)IO*d2)r)@`4qDOylb!I>%)?!M&o!Pg?>?uDzYy0#zCUSjIgVemb*M~+pEHo zXiEKpE}NDPw^eekd#N#Gm~z790*fHq2T74d)k+F|nw~JilyhARnNTBy14yURv(X6{bF%5SBWEG;4>=zYTjhX#4VCMrJD^|1|hE7XxFL_+AZirnX?-vyWtpG}~ zD$zvP0`aOOOV?%fzJ~ziP`3_r!FyfBI#?#O0@U0u5UIw9Cz9~wSYB*-&~i@UegfU< z72A$JUxD2JH=kW7{*rD)@(Jc9X|gWK2tS~kki1Q?3hqs2^EyMXF|@?c1%}Qs^a4Xi z=tJmth}I)X(Dg`ycm!)5K=LaZ$3O*|`%>pFH)9<4OL2^C}bKfTcPef+*x? zT8-pKtZLBGOs9!IFyVI~EHPwr5G}rDvM(sMjC@F|ki1XZkX&Wx9omlQ4Tdf;%a`a{ z6u!tTpJ!-+wx6VHkI~3MT9cw}CaoEy?QvSOlSW!;u!XiY(_jN_57D3>oL!sj{6;e~ zGs`#3iw*qfFuaXN__0a$B1PGJGnjGL?WI+P%7U*@Uho#4E0h&{D82GP>A3x>y@bz< z4U#U4rYx-36(w%Ux~Lem0?cR|Yq@3TBR#z`Y@p0ur_OJL*}IwDNon3#P7-^?LG~M- zJ+x_WV^i}J4~JW}9BCDHoj&vU;hu*1oxAsJjkGx{60-A^?H$`XyS6{_X!j2E^Vs>2 z*egZlzF2>J-++=(wd9~~nAZN(fuVz7LH=a9ITO6acxNn^8NYUt(V9Js21}fxX%~Z= K$))J++kXN0ly)Ql literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-LEFT-TRIM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-LEFT-TRIM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d3edceb463b237b1179ef527bee2d0a475114b16 GIT binary patch literal 3246 zcmcInU2Gf25#A#uMSqm3zq)2@XQMbpKHhP_#u|@Q$-HJ2T(R?Cx;6MOsg(I#p}y8|8{yr?pLQW7DInwK{FoHtR)~u7aFi zP)$qw;k=?QjC?EAY44gT*4={Vu25&wZLAcY9j2*Cs%+HD6&OrR0GpZ`ADudWe57+$ zv323?-`b2#jUSsD8y)GqdG!q`UL%AQ$qteZLgFM!!q@zG($Q>3o=xkTY$zEm8E%Ds zJLDqgY|RS&-cjn+Hsp$X)~#SV>kT3i629uU&*lu(Nt;HvEnSkj!&m%R+K{u5nlh)6 zNc$}>=v@l^!PJC2CfkmcHs)kqn{{LuX2{hy_FX0mc&yhB0=@k}@TEiop2W$-uYC}sDX_r(-_?slJAhFR zo*lCX*c)5=D`wAc3E3*WX!a~bq!!df25$$v?eMn2+X~H~ zH>oO)IxkzAle6G3tGpYu*-N&gWg-#K7!d73)iuS)W#w7Z%GgOJMWnsfj+ta#(N5M8 z?SbadlhiEBv}7~qWOGh3x(^JxlZvq|>BwxFCx#c;_%w<_0SdmY-75PZ0Ul-&TU==%-8XY@6 ze&X?oNul{J2or_n;)=VvRw{r0naX;#wsEH3@HWq$JOAu+Lg}Zdq)e+b+U(qX`s9M1 zG0g0uWjnd2^QV?h3#B)q0x?+6oWU!NVZ6)+ko*{nx|lN^+*0HPA-n{_7F%-`&$EGN z*wNE$Fwce^Hn_;-G#h+^9X-nWA7jIhvi>0^Cs;q$JUSZslMSz4uCBr5VAYdhxK4|u zLcLJ*+`7D6Sff=JE;QAeN0(h%s8sIEHqgOH=s)DR4UZ08REFqk0q#dDv|JTe8-P6>yLB{3h1(G}3|~#!8f%XB4Ztl$skrCM4GK?zE|qYMG5B-_F_fJPw_8Bc9drck$gd;6Yd+88WXi56=0ksI zPZUt7Vxi&64Y%4Td*!n(I-3!=P}yiu2$q8)2&FHPQ-bM0Med6|{-sYt-`eB9Sg2CI zBWkOw)GN8vt$O9UONAnZw4rBHQ43mkS2m#zRqyUPNFVcfq${CM5PK^aNAeOhb}@SX z*2LLxyDOLsCW6O<6Tx_JJQxc`;gjNfK>FU^kQYOLeox2^xaT(LxsqF@We?&l);6oK zlN)e>Uw6F{Y;?YtVTaze%Q2*k2s9D;U;kGJ6V-ZgL9vwi;B>GQ%z%u1xhFdEr_djn wn%3Y)N)tD3{x`zAeN>ufZg8ze``Sk03-Af41R+rf7^$DCeyY@dsD#7^KnQ^l{lF)xhMD(r ziJcPyi6HNK-pres-^{#uvkkiXa z)6!mAP?L)j&&9j#T|33PTkzav>TI};<-(<-G=7q*>-BO47Sq$f#%HDyGslllbkD1H zT6p`9Hj^_`$7ZJD6Ww=i-jD`rgpeZHLDEIY0Ev+Bb$=k{Xttxw>uF6f)QlDjw?e-Y za#3=&W`+J>f_k-erQ%+2E11q&gGhvg-}5`?b4Jq9O(Wcvu1dY(b-zzHlq{sCrZggV z-t~gsrOFZ|ydxUJ2zH9a`%2FRJ-+4SgigChzCn3Fr?39a#c77u3yYs%>%)1k% z`7toW1(5$5=74}fvt2m5K|XJSba4=RALQ0SlvLUwMqKo8WL$yD)zZTYL9RDL=*u7B zK^y@Dc(zKf<;S=HQ-|jvV*as-*@FO(BDlxZeePjHM!wdB?9Ef26%`P-hMU0oyORI8 zx{%MQC|r!4(g2Zr!#DiVSkg4+biAR;f@;jAHA|V*L1LurnB2p<LeEwOLKA-T<0X82Oaj3?PwWU28|IhFp_CaHF8;H-n24yj7hT8YVDXY))VPw zU6Fnm5B)LCvP?@cb51tr#3K8^pf{!(OA42xlgI$bI_C70?%4O{5KfTDAa3NcN!8Za zP-FMrH<>4h&m$kUasu29r6<(u`eW zkV&}r1=t(8Uq*xz!LlCMmOsa=Y(0~O*(pZb^ChL|dNS%_GZVm(z9TeV5*kaw$r<5fUO0JDs6571$fsO|{Ee%S-*FY< zgXdm*DKl%P6*z*Nb{UhJHFL&X_UnwM*;5mY9%N6A17u_t_S&MXf zr^CR51ouNht^?FQ z-GJMprWGx%WuQ60gY=wGP6(~ToRGgjmmFw0ZzW}!xhxw3Gx8BPBOeI;+k*TU%%X+! z#btM8wN(D*3zfBMZT(yIhPQFy;^w6nh2@V>Nu5p3Y4fQC{nTPQW0={~mhI%u>S&lXX6grf0`ZD z+5RuH*f<;hA{&324Ue&-Q8tWaj!cIBOv9^}tE)=Ayjt=USg+AysZcKzJ-4o$FRaq4 z3m-7mnn%yOv{0$s-)*3WFNOY-j@$6)*cEk*t`y*VXqlF);!_4?SNI|QBiwFJ1o3cN zX5;XyN!$CHt9>J41=m)sxSQn$g{MHzm%U<%4F$&lOa3(U`;NsElgFo?Ju!U}CBF~1 zBZ;PqCf)6nO`+Nc;aji?ML(3ZG}Y0R2X22_cQi{)+pLHC5Dj%Z^b@VMDHMzDy4Ro$ zcde{6yh3%kP+#6#6Zz+C0#UymZg&KI@Y4-%SI~>HO$azh1-(HRa@BCVt*L?hSso|* z>aHmC&_CQ71=OZkXt+wltv1SD`GSkqnt<&_h|St=hddhT?a(I}$Lj%}gmew2w^&`h zyKynx?g>r?)4_@0*y@Cxc@INp?&)rf$q4U9JZi*%tfgXW7!}fng(BZbdkmSwPJ9qvC Db)TA9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-TRIM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-TRIM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..86f0308bf37304abfe8230e4e4e74fb4d34c5a43 GIT binary patch literal 3235 zcmcInZ)hCX5r2Cp$)~@TEGfoU%Xv9$YOdakPnHr{NhzzOq_q4m`vkaj*pH{wW zPIvO%%70tOIJ8M%Sw|5G`(oUFN$97N)CrW-F@p9>@ux!jp%BQ2B!rR>FckVFEzZn) zKKUFM5{Qd-cizmKncvL3_vW6~N&7K1P1V}UYPsUnX>HA2U32Mjtxg-YwR+K^%OIy0 zRKwJMF{h~WiKmiXR?AGW?i5^SiP~#UW2tcN08JjI%4)q_fx*NCu*u2s(aEu~MAwXB zrG>X|wK+67o}5f36J2+%y)O0F2q8tXiKLT|eiA0Zt6qQH)+}3|Nu@PeS29{WSP#4i z!K<%)CKsbD%Q4I&W|yy8V>a=L1#3_aM8E=fJX6|Xm?%UMWGnbk-r za@PxbmjbUpIUygCE!#}#vod@$c!Y5U=;WAFWoGE0Njqt+jdH&_kY^AY4ibm zdp&){==(Dv>!lZszWI>U3&VGI<#%J4FdreLhmg&3anI)OL-Va^pKqoeL1{h)hByH7 zondwg7&L3aX$ARj6Qq-a(0d@)M^I8}hZu3t&5>~gDwj$RFNDykW(d9cy*!A$fB?_0 z^D)k1;tw11(kBTAM8WB1 zsh@;;g4ev=an;bLQ+PP#IYpmNYo)jC%h4OJK$}HPB0Kx6WS#=11H)EqWGBGafSNN+O>gOdOv1VSFgJ9s zj0h)!W!*3xx`SC+sZ18yrs!%vM)7|@+}+aUQ1&k_Tg*%uY2IN`_66IG7za zkp99Aq~CBADG(~JVYnG(zL^)`NG}MDp9_s+!bwgz(S(ydLS-jcA-A~-`I4)UkGKl) zz;ll!3IPj}(=K3AQ$|jo&OXB)OS4#lJvPE(eBD%-YtNd-tPTN$N08%t1-T*k`RUMc z8TqQVvwc{M+puDh(L-b7PdqtsnC(E(n`|$Vt3tsOD^61FlxBAA7{gPmay6I0((5ghM#8gkJ#XTme|JzW9;!Le8Dz67I4ya18&~W62Q*D&p@@WU{rUfvRG3=l9&-v#;D1C*T;!pW1a-TflTKaq79cgu4 zEL169`P%X_bxRI)s&2XNP@zL1Wh$yb>(0^|6rk$fUjXT^JPzq<;1R@J_s5aE1YKQ> zp1(VBI@sv;5Bn4Tll~L_xIg9}@<-t>$roCB_Q6mW0#9oVwE>sg20c@9sos-Q8VRc6)Dk|4@b?nO(;=#yYnS zL1Yp%5|d^y7s>rl;-f|%M50mtXk+w26Jp|vi9TpdG#a0LGA2IYIrl4nh9vrG*7cm< z`Og3IoqM}PJbNXDmvTpDCZ@8pd~QBJGoRi{Bj%~a+GdnQ_Om{cHj-IVsdb+w|-hRFn9s z(bL%;^WMC8o(tv(AsJFcQb|aVxQYErAs97f!xZ`xiY%yNQjXe7cA)}l5iCR2?Lzey zKA)Qrrm{z~Q&`TCIl>WQpDR@KTdHIxG}T__PH{f_Y{8#Ug%p$~#%1EFD0xBeoLvZY zbPJt=Vd@DrE?6l^G-Pt|y!SLAuE(o`F3joL`1L{V$~1TS<3U$C5~=3O4>^fmt_OPi z1DTIUBJhdqj$AE(7)=2J`ai2Xvk4WUgiN@Y4ndU}-kDUUmXW&R#C13gonG}IH-6<{ zpr{1^{=TG~)dHUpvNV213kuNLZ~lBV`0@Hz?uqS~j(y3m^di5fSeu5w!G^1xlMj!L2_ z4G6kyS~}cS$+_(1#;{?^NtX*W!fYEPMHW>nCG=~0(uh*d#r@OT)S|S?T?q%}>^|RK z9K7;wKOC%5v^3sy8gy5oUSA@fFbzOHKxHY|AK<;T(j9>92}EUG*K|R%%#>wD-4B3{ zFDk0Tf+NQ?+(D34iArifRAe=74$z=o2zK1Fpp`ImT83N6<9c<2?=pFhs32$sP>xlJ zCc+l*S1nn(E~|Gv0w{-PYv3$=r>j^8%Y;_JG50HYsxcDD6g)RdYb_61P89BEIPYaBrG8$h2iob1&U0or3>T=FgI^lFycmqK`rHX?bOHX$j{#uK#Z z0BuxgQ;asQg>MkMI>E-1(zUpXs2TbeT2Z`!7lH=y5C`pX=84DykI`}!r-8%a{-7;L zegLV*Fhw0l#C-?IEvtRVe?g;2KBt?Ie1fU6KnUNbtw@F;e9g-6ab2@gPJFJHZbYSR zEK-yayp55Or!u42u|wk%lZU5{Oy_2vo}J6jAARQ7@n;=N@+U;|C&fWab-Dvy$S<@S z$xm3*kfoVU1Ak<~??G5*$mS4ge8Xg4QfwFbh=!1SK--X9X6Rkoj_6H>E-=lP>1q_d z#57-E=oD=~MpqxEv3;~AP1{UbGep}Hv}QYvwbF14ZEL3C2HGB>;Q$!BHrR#rW_B*m zH!O$^{MZP*g-7{`Y4!p|*+Mg@aaZl-Rg3;b-(uyWck%hfibWqvFWpx#K|WP^fWANe|+cW81|5h*ad%k$Cl2nt&cp~y$vNEyATn3 zr9QboK9JZws3cV_HKZG+wI{uIcpqqxzgTY01aC0j8Oue+ubyVKW+$WJGN)+T#o$JA Jq3`C+zX9_-bH)Gw literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1880be5d1649881ae83c760eefe8e92053b6a6dc GIT binary patch literal 2646 zcmb_eO>7%Q6rQz{5dS1~egv(Xq(dMGIbEwx+A27ubi3IkZk*j@cij*q1g^7*P5q~} z4T(xiRRmmCp=m_415`pn;=+aYR%jJa)dL3*7Y-bdK&s#bDiRWxO69#>JB0MWZ?u~? z@0<5O?~QkjG(RmSsaPtMb9uw0rCPOItJ1}iNh_tAnK9@h;Pi~BsM6UYM*5c{IlI-Zh6J)y|d!fsnJ|Fg)QC;g2nV zQ59I={-L;2haRU6pxFjR>D$a*hh^u52fDcIwddM5m3Cn7tR>%6+HVrFmVHBMpYm`Z zy7tkYx!q_0_FD-F60(`ggg38n&u`0wGa8w+B0ASI*OzYw1@}S7-%Lop&rK;D2D^XT z{X?#MG_uYAcIUSm&V7jD`@h=vNDcdK4f}N;;O44R8_4T4@qRx0AM*oiC&FNM zGaDkFHv28BCn75HSOWWxpA_V=q@?o46M)DQTEydHK2IyWE$}u&lXpZ!K^G@^Rnk)` zG^yxxd5bo$>C&{v0}|ct7>G$pkW(}KxS~#L5ypAA`?Yl?!UEm^^Ler9+ar>yDk`s} z^qG_%@%lj_7!l-o-oep`w;iyyqynKi{l7I~I2+zwu<29A#@s#DXlQAY$L3Q&$GruNcO~eZhK>yw7$cd5`Tua*>6R?t-f}$GxDc!aPDZ9WC;yqeZSbTI6*MNmL|N zl%9oUP@A7Vt|WP=Qc6nV-f<-*kIh8c!@aD3ADHnB0@^&IDibnt&B!@N1{`-6F1QvM ztBOVDeqsYiz6EqwLWZsrlDw3ZrlH7)zs4R#^0F&caLIrR_PCtiA>>!~7)X*|z*)ep zA1_V{Dq=r_@nGF3ug}k5fyfOwvS3|sLRC^TtP|l69NXlwYjo8mud?3LU>A#(lAUay zVO?{W)@(}AC7pH60@I{P`fP%A9bu6{*8Mme9AMr3Y=4+_gp%LAS*3+E!#o z%+;(xD=URlr959u7Ytfj#55cL{n;#v#IVv0;uZBhKy1zB`3 z<)qIJY)kHlZN+vZm#bEc{33H)4J?;%> zaVG?K>Ay%I$a-7YUN7r)VygQ{CS(rAuzTD@JOuh{F} z)!|isHMneB5Iy;RXqcX;%ENOvyBkW(xVE z=;5gIq2X36ih!$*7POUOHN6~fwDYoSXzPE&Ppz1#=1N66W>hj}u8iwAEu>Ey+eQKU z2}YqY4@H_Tm(3D;&Z QT-x3A=Q@(NXYbwn9pb|8A^-pY literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-APPLYHOOK.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-APPLYHOOK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..956ad95827408d17c8a9c0d2f656ff802a46a13f GIT binary patch literal 2082 zcmbtV&2Jk;6rbI766eEi97i}c&@7>$(x&S+X)Bdfr5$g_iIerNySq+__>xJSI;|7C zv0bQ2t*Sk6S*cA!s~u3qm1E1TP?Q54I8@?-;LIO@R0)nq;k|Y2gn$GRmh74Ld++_` z&HEUyla4nvUDnDgmE}@lO)l4Km3mEHDzC}aa(!)~ATI$fU)M~F-I%7@Y~s{-kG)H? zuvW;|3X8H+FH{%v*AC0$ugkQuwp@bE$&(?% zAPn5Q2@jBNAU|Upc8(Bg!G~B!qDbp@*5(p zbAM@_8*HBUpV?#o$i9nOxZ0xb-U+`H+WK;0N4!^j^y-d;&d)yIBi}6EEdI}+fN>@c zh2Jdp6S3R7@4lpHrg1KfHB_gmaZYEJnoI*?OxcPU=c{9Mw@+ z1fdhdqYjFBj8Ds17BhAY0T)nr9(02{DblFTnnCeiRKEi1sNc~lhNiaWf%}I>cpQx+ ze<8m&mmhcxK=ONjo`*Art~A zpr>t23;6>C;SJpVin}q~J?6u>eBmsq>wPN$(87`mVa)QT4c+?N?9T@+7 zrBb?9ESE24dRYN(d@K`DR~JuM18 z#t)-$qUFJl>@_A^pcC+9@*JWNM4y8E?0p6}9B@Fh74dd2Y0DHD7AyPpuYe^~#dxCMJ^%nwd3UX8-R7 z^V`g6E13;@JH3hV2Z8hO3`7JHbuRxH5d<3_n{-L~=`22sXK4|%@I)kgI{fvkww@N_ zXwjBuP@3`oMnr)}MZ!lV391lQ9E)nKJ@|R3(u}{-{DeJy%Q_ zo*SUnlnqqfubEkVo2c%&5;NwyGT3V{#yMuI*r?MyHpycOj7rzrnK?ubpRVOxG^fR|>1OYD=}R?UAal kF4UIGtCO(HMmg zqA{*$A>xdN7oUAFCO+U7CMG`l5BwAUgE~_v5;ZZK-M#0|+%xx{d#4QQF6pMC=dTyC zxpYy<&wGV=PnpdZl~R7bm`W?N+^^ixEgRh(gZg;y*;u2qXC+lkC%yEHLgv$@ndI%` zO6-gR3&m`X8>dfm7#lpq8PY>8h308tPG zbk&cl1UW>D8z#~)oIolqQ$NCM(Od`F)Nk)oynI2+rEjKlqMYj`AOS$1`jNPcbz)eU zu1SkhGkxN>7+9O+rNL1I0+AgS!7fq1weN%$({u|v1Y$A?HrB&SJdf`pnfI9w32Ac< zeEXOPOtl_tm+CS+zqdEC;+x$`_wALbsK9OwCu+v|nlVr_j@69rnz8R%wdUtLcro*@ z=L6r=u@r8VGMk?24E|j+F#B@vr!PJ zqtE;dP^Q@|D0nH8gEV1jH6 z%_ia8q<&i}KUeaSb6!F7(j_k@-0!G=h;X3v+=D&JY?5EM86`WneN%+*-jM=b3y9+` zxE4XYj9}cdcE?=|>eUC!=NAE39^!mcOCS)wh3O+e9|F1-;(0V96HN$7$n+%I=4y1Y zV~k=nq76?IB=Joxa3taKDIYe`B3enFqkg?ZY~KF<<%NYxusS d5+rWM&d^i^H4R=cG#%E&x3MmE0KCvDm0v{jOqu`y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-EVAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-EVAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..da2e3e879d82d97f25a17090c121957054011437 GIT binary patch literal 1910 zcmb_d?@JqJ9DnXk>yJd2WLaxdr#I2PICo~T3fe)(c{yuryi4ycP2FIU#<&Dxb%_dP zv`AaFGBRp(v-foC3Vl=Pn>iU2?J$&4)))Q(8w>`6L0|Uu-nj4gp4ho=&^JSq&-cgY z`+Yv&=bqFu%AU&de3X(%fP(lNDzmE`F>UrgmveQBU{1 z6KS>%WHQBUdLcV4+KbuJbo%03Vq{oU=8O3P7(+wgMotX&pBNbEYaUgsIP3P(n&Vj0 z-{04~cYB@l%@IN}q>9i)h>r-wSuOh{TeEC=G#1xnU764%r{a_wVHP=QX{J;5_lpa2 z^Kv1(lr7*mvn9e2;;fV#N0Yj0#|+(B{| zk+ri*oZMdbULk}Jp^oj`!*Oow0=f6YIG<_@`MLTJ3Bg1z6atOlJlpK42}ZzA3n9B- zABgQO=azF1ff~5daG1+&?dVumIsLi*BO#UCC;B+gK}}`jNXlIkOB)IC5>m})+THD_ z$>3J@Wi%iu({cAZQb~1ykV4ZQ*jJ%3IGEerEY&2q8m9{_8L?UjX1c22XSz4f0I+|U zB(#&8@>O$F0r&)~`pQ+qx6!S0&DF^K4=EQxQRO?*9k>fi|bB~`K2G1=7YqzOk*bYVTA{!zDf*=B#x03*!YdFHMh)Zn z<-lVt_#n!iqkh4U#v~X4G~T0rxHrdNyf@wkLTDY{mJpu*R#^Jbs9{bhHo6|D^s7nJ z)bsK%nMGr z)6SL_#IDOqmpGG#ABJf$e}TQzF?P8JXxvB6SI!y_3v{Tarr4VN!U>4SY|T{S7WE(v zw)jlaur)U1d8gdMB)~fT*zE%<1CU3+rC~P6Hml|3@nE;e zB9*mkC!hYbb<$ZAXb)>5sD^dz-DUV?aJ2|lOn2Qu^kI)wxDxW|bS3iVS-!WOSX cgog1eN+D3Q6*>}P&KGWi`==&yE3vot7kWP}4*&oF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-COPY-READTABLE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-COPY-READTABLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..73f41b07b72575326e32a1bbbd5af5f224938480 GIT binary patch literal 3686 zcmb_fU2Gf25#Bq>)DI<^`mwAsvU(c4tnm9W- zIo1(TtQhz9Uooc`=Hyt%ofmh6K#>r#LiUif6A~aE;@&6+!nS7FawHnlWL=4CVRzdt zx4~NEq@|f|xqCu#itBPdb0w3<<*aQGfe`oEa$6*+t9I1T-RFesLZ|yoxhty630Rsk zuMx4W>IJ)inn(|RlW_M&jBAol!b zQCu1bb_?FiEY~*%f!05ed^Q+_Pw-sub{WJ71s1q0=vIc<5>dD`@+544>$;o(==^zd5CmaWA_5iI)ncu`}Tq9+q_#4zJlm?Vb)8CjPKynuaMGNjs6W!yZ2XI>U;-EHgPe@f-wMz?kE+L^gCywwH|h{KCoO z34lp&-NarnH4TzTnzYB$jVaVsk>~|YwxSn7(F5Uq;rfsYyXC<67lvSGDlz?hvY4`Wlk^GS!LGo*+6L-1p7hHFZ>n?De#dULBcLYk_aZJ0Qnai+neLkjv z8{u!vRQL-s6+U97!kb{)ZE3bVXQ;_IEJVR3LGxEY(+8S}Y%RxUjhI|J6;Sy@*olK* zB7Xwp2Ur==>bt=Ct%RmV6@bIO$q5vnM{!(HO=F+WD2Q7lvqn;%V`h(_+5S@n(GP;S zvl<%el4NV^1);YA#WM?Yhty$37v+d)#AS6sF~I@(oE}H=S2~R3Lpp-wT{?>7HrKt% z$xUu@osJagXqF!T7CnBB4v*21BXsmEn0q!M&Vht!%;S!EE<;iK?`k`_QRD;-q1`;3 zv0fe9h;`L8J%Q3LKo8W>jec(6#eXoo_!$F;f8yjdz#XdNs*g$&XorJ-!mYPBNdV}u zWy2^?%(=#?-2{7x!%lMhqnrd_y=_t5*5);n)#y|318v@X^2_t4kxa0z7CvN7gbx^6 zxXsCH=%l%se#Kf@c!`r6p!P-L%3@My1%`}7P7 z-{D+^o_>nFICK-cdSvjP{1;nIQZJd(Vnn{<@vnaHP zs>2M%C2SK;J|CU&&>2vm_W}0>_c@&ALn`QO4Q_F@bApYmSk%@`C1z0{n9)gAPLG#P z16KU~4mr#-yU8=kPh)!jS5kDQttlPxEtU>_xDibJB@cE5f>ooiP1w1oVC{59sI6Um z?CxMO7EJi}T^ixfZh7qNtOi3&<9B8D0^ro^S1a6>RW0QhY>}|*mVuC;tHt%J61)ba zozx|GS8$3_xXy)7NNcGla)rxM&XJsKM#`+NW>%cs6|iI0_@;r@QgJ;~N;$b=VPi~^ zv@5CnCcIZjn8WI3;RM)hIK>hOz{iG@Dx_1TbkzkgpmsJ(1*S!4Mk=n>uq@Y?cSPwC z6K{fe2Z7r|w?H0O{I~Gp&BRf-Oc3azK)60QqB=XlMcV(BZ72#vWM?Y&TDiS`{<`H> z9F8yxT7q=ApAP%L{Qx|oa9-Oc99%LBfQ+WZJ#?4|t?=?OJ|Uf&l%`H&2Mf>hUcrM> zc(Unt+AWVH@|n~|MoJe8BMz)TomtHlGSZfUk4lOyp4AeeQyj|1fwzJOgdkSfGyks& zI~o32nF1mCgxj$(@Fue(yA_-sDYNhpTcu6=f^o1Aw{&ZH(L1@aX zM#Sz7D`;H^{gLr;IU!HVvzjF*(`HVw)RerSsD>`9DaBA!OEbvTE4|MXaBFB#L??gd zzBwQA!u%D3iYr`;rFS6WdloJp% zjNu!di@xD+OM%)Ta4OfuiM^bHY5&g^%Wr}QyPkjGQ-b?Cix9}0tC@>> z{|D=|*?_6%-Ch5726o>q18w1Vkj?P>dHB63boJd>+V=4E-I%{k4wGL$d>gsuUfX*c zW7Yi@(va0v_k8)k_8Rgv7X@SM?jR9+p)vcEjAdv_(o&`~+E!CyJBj__OMWb_>e*x( z8&FOu*hY+tTB7preoWb?k&SBXP|zbVJtjRxWSFJ0ciJ zT*)rVjE_b_e=u>!k#*asCmQCvTcVJ z6;Sp8dcK_%RWUWbEFD1cPe43iT1iNk$?O&d8sC5#wBC4KSl(!0m>__PygbDf(!YGXb2>*amM@F-{g*h~#xET%E zZv%VhsCH5_+PSCbJ`_$eL&7*SB#baa2DouLF1CzXtprtfr{-1B}SbX=+-5=};^=hwN`7n;-J+HZKDEfthJNpG`8g z3v~D^bmTPM{{$VKpbwAI1AFPg17JY>8?KTw^jUON{1cRE>RuO!d@60FWat~s$SRh$ zon9H+hS&N%I*PX5g&V9Zi`$CrvK#afaqI`iNZc$_){DOWO z>uzUMNthMwn}Q`p1o2?N{^VL<*0iP^eQGq4f!S(awh zc$bTQjwyXIuUoi}$QyJ&!cT$OiCX}PSGnRV94>S4Ied+dtXp2iG%Bt`dY zH1Rl%C1`Az#-cQK42+1s5B+_X)AXd_6=hf|+3@%&O64klw;*qYmElJLgR2~9z^dSL zxDcRk;&WVfj#IVpQU^HOl~ER^lL``RzHplMBP?=w3cw$*+;UTbuPu4t#u!@q61Q}Q zTY8$q6XAEmOL*peMul#KO>@Tql1amEQZgnT05y7q7gwg^U{LrdIF9gPfFTQi2p&cF zUGQ0i-v*Ni?*|hIzX^^ayce)}zYY>e{W3U$@WbFV!uJCc;d_CB@N%Fdgn^21IhaOx zF;Ecv0K*Y31Tw-4EL+0);8~=e4W35$a_~6>FPK882Zs;y*aUI!-Ryv)lLo8Q1=bguLEO-;V@)U8|p E1e9yQ5dZ)H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..49061ee0cfc3d153b4a5b317ffa61e926d3f4221 GIT binary patch literal 2494 zcmcguU1%It6uvV_x7qwGNvmylQ_^YLlCosBY}#r}#dYL=X`ad=U{56a?cr_a?im4fR2h zWH|Gkd(U^ibLXCWcb;rGrWuM>JULaE%uOrB+0xW(Ntq~4D>KE}>9L$L0eaLomnr*3ClG;>rb(>th)O3~*d8w^cMs4rq?+i(|Pmw$C56Qz@ zB5hJ&RWXQ`;JJ0Aie>3mUlsAuy;Uqr7xGJ6SMhxQwaVLEVJ?qFmbMQvUW+ zp=B!s@TYm>oE5rD$b9})D>NiaE%3UuWq2C~!*~NB&4er$#v*(nSH(&%tch*NgG3;! zs^F?z#8wE%U>H>Q*J3^+R_o!)+bf>=yjS!7pR1SMHTA(7^_a0>g|J$D#V22dPzL;S z<#t7zsO|Au%x83?M@0P3l`XAR)`FFdZC@_@yKfFV;7A0Rmh-JdZt*XA+oPIg4y3RV z)Fd?r4Bb}yQ{XWNov0jSLAe2*06ZI@+uEWUb+x2w>u%PDZqazV1)LGb)zh*JGaeBA zs2Msnvl%sE*=Z-rBw4yQ+O?vrsji6y>#+MmQQfvJTeY%oChJD)8X=%LO3e|K`;nwB z1oN7rwoV6J+HXLwd#&-mwRclJA*>#I`XOw}8xT>iAEgF@s{jJ1h`Igw9o;(L|tK+4^0Cz^JVpqU$K6!Pr5 ze;%q1q!J08@6;-tbcEAMRPgk0L*4+o?)%eOHuN{OM^xO`4wpte&P85koh8=Ufhre# zPwk@#xZ=dc$$t%$ax*2R^9=1&3a7*^e#TKIM&ZZ7cnpJ5{uO@#4}uO2TEm4^s2nf6 ziHsERQNv+PI1N6+6IsjE#j-r?dpq0;zaXuo!JKFIKnm%%avaSM<;?u(<<528a7-V(yE|J;+k3lvZz%%}nWM1Lv5oyP zXd_X1Ffny7kmVkf#Q17Vbea$nv5CZ(#b{zQ8hs!!G4a8eVB(7pWPabd?FthM52kcq z&pF@U-*>+6J1mh+2h@b5PM?^Wn9R;f(+l%63-i*^=~-!RdSP}fD;DX;1VeL1SA z@s6j$_2z9SW3$=O`RozNTFA~F8GUiL6y7T-GqV$u@T0dEmf^mhuDj`~5xOgP%^ zDHG}IiS$K!JL=aiFAM%@LdX~?BB>+9Ph7-4U+{-4YFhGOEJ0;WNz#zLWEW~77CCKF z!!886r1|L?c{2M#b`rxmF-HVK>~n?M!L+7YFoOQCO*lE~`<+P*jT=W(AQ7L zuO)=5Q{?(*2{E&^B_PxsACrp5$6AZy5XM+b@fab<=Oa#R6PcEV(ofvRZ>Gh2*PV%L zAlvj>%@$$&>S2FT_rvn$Qu3_szfQ=~`0KhqAqt>(>BEOI+fWgl*AjxtCdS%}ABkby zEIBBASaz@u9SaD)2|R_LH{bh+oZ*X-4)E{h%2ere->qPKov3 zCDVF*4d@3I$yzSyt17wj63VU2R;1iq%2QqH87|dZk%9yQ;$l^)JJ9=IFoc}M5wPO8 zpNLp84IzUn1D4XCpdqorzF24tsk$~0!@82AiZ+m-hTI>69c{=Ai9S{*)-j)0178mm zZy==dIx?u0HlX-aUcDZ3#I$HqbOA@uDQ`7F6)l~T2X!N9hL|7<|CYA&5c9g~;b3#O zrtk0F6OQ!suDiG17Oq7#l;>FmyxK(^e{N zgYD8X#2btbvElA#A4{1K~($+>}*OI`jCdJuK=mx zs#fJp%!M7C_yfpe3GdT)hv|!=qvPcsAc* zJ78CM9qjkrhkermLy9r5!8|u4%&>OUb<9zDz#$Ygi^Id5gWP~c9iWm_j5sx%y-TpS zy}IckLr*)wkTb0PCAK5Sc09oz+m7*kX&2h8?A*Mx?XGtK(7ZJ+Z6DpJ^<{{LUCoYZ<6>8S-IK)q+wKArL^SMos8u+MrMh_^;p| zibQ$@Hz4Z9+Xq(wl}|5|MoR~*=JA1XZASy$Mvnd)h)PLXUUE*l z68dq`e%rnvg3_%jq!+4eL-R_+puUuZ$-Kx0X&g?&g>kO^85TknPjLYKWdNJ1hY_v- zD9GG#d<8{Uo9^NG78{D{B-(3O78EWLMCev_8Ze;Sa?w?1x!K6AU8)?HUn3mh=89`B zkp%%|VdI_ZbnRrF&8!o!7A1g1M3@nD7l2*@oZRAm2f3Bz>VA{o9KhR8I)Ia(7cmI( z!yo zi}}9AeAlv2lgfQR#$WU-Xct;0M^8L|WE5M_#;FQ#cNd?kXb7BvFBH6R5F#hOJ7cZ~ zIK&rWhWJ%InS%cw49KNUgasEMjWdK^;EiLmC7?;P@lL!NZVE{D``LjGna1+d_I RHf0&nv=$F{U7A~4`v(L9wJrbv literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-READTABLEP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-READTABLEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e7a29899d1287f4ae50c82c20d86bac7d0c2943a GIT binary patch literal 1902 zcma)7O>7%Q6rObwH$S#(2diqWP&SdGSX(xd(?m)F2sZ0+?0UVs-Jd2ofg5kIB`1y? zrxHbkwo<5&Rtio;v;$N^>K&CH5QU-~5LfOTIUpf%;lz>f-mc?B0RgMkzIkuvee=Da znQfE4Wm)0n#`88@Xk#R9zQzd z;tfK`Dmg+iKuDbQ5O3d&3l=pkF;`His7fU&cx}(^hgd}0q=x4vrubH4Q>;68oH~ZH zzC}1fypP=eoUO`MK~ud0?j9HM_S|Se6?F(rTBIb@-$6li4q>Lmj5s42RLWY?f3{v9zsgrR-YHSXB*_t?~0+NOQ{4Ge%t5yG#AJ>V@FzSUyJPq>SyQ!!zdv~ zPsU&XFPf^URG>hJForjEBlV4YItyAyL01^U!lxsFPw@R0&nnEVCXZ^*Vde0H3omfh zXFe}be{U;$TI_p5+SP|ztQg_|zWwCN(&Y}(enKL!VQn>a^d)(CCSq>)B;tO6SsHga)91LqfMa0u=CLcSMji zHCwP(qL;OU^@WE!%(=ko_JCn=7V8OQ8^~NCr(N zD^yZ#UCe1l$rKnD;{NV!X#$J%L}6k;%Lc8I>9!;`Q_m2K_F%ik1Zo(XA!@dz+m_HX z2tE-(QddOZjvMsE*nsE8Gv``3+D8cM#l9WJ4tyWLdg(1mL8S>w7zs)istsf)+lE2a zGlzt6IQJIJB~KG1OC}ArW)Ym81EfBBiyAAaC6KYK=_{v40Ll@V zPUV86_@xl_aWs`A+0eujj2FRlAs1|fY`D7!pc~qvidr3Fzu4^-UBt?;1kTuO6omp; zL|DZ<`e}WQO`vt0`5C{;22hIt$Y2+w3qgJXd%SDc#YIE2bswGl=%bS#d^qw|AU+3b z(UMfORi7_FlRbYU;v(srwr2Uc`!Fzm0LEU(+sz#|yv5RMpbq6u-EEdO*tI<4X=h#T zRhG`M^cYL0SlTab)pK96oUIl=wj+)4Yh}3FD|~GuxRueiGmi1icnAIW;kgG7>S+&- z7~J!fR{3__5zsUWT^LmR5ARd&01wMm8A7+Hc&@XQf<+BUFsde)inS`2`C7 zN`uSU|Kqf})J{0rgrn4HG}!tk9#5`P0OfUl)?KAvw^P+*G~1e!Eh}c+MXj zxcNi=!9k{OSX;P3Wy^D8bQ#*oqS>HLxez2SdRjl&u@>x@E_URs=T7K#r@ZCxmBz+I ji*Gs=XRWs3@H-N2T;}~4@PE_m=Y?GlJV(hV^!WHMcX=9N literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bf369439e2d634ad53d52247dd0edc3a024f6253 GIT binary patch literal 3400 zcmb_fZ)jUp6u<8!OaCP`=|a`ot&gpnF8XHEw6p8{;Opyc6O+7`zW1`MQ<2(bwoBJ` z{UdH+W4aH5#BSYOd3QPxzsg`%K?=@*L!^j;D2jd<2!bC(nBW&bNImDir0MF+{2*C+ za_>EVe&?Kf&beD8TMnrSNu4@AJwB10k*4P7rswCRqf;}|?9}|sXjVE3`%+%j4SG7N zsPVlA!u95clhK*%$Xxb_WX)%1kBpprObYLplj?Lsa1BBxDi z*o8o+G&eOZPh?-pPM|x-XNf?FeW6f0kk(Wyrfc>k;jG}b&lh|#O-_Mp${;0TZAlAi z7wp2$&Q3WjcgrTVl@RggNkZBV7XyA5Lj8E` zMnYJbBsV`vh?(sz0iovDs8l>Q+FBd~FGgF6FA{=$KH|7Go@r?){lsnjW?H;=-5I|D zvQ4kn+%Jr+Jnt{+epudKOrF>MHwjrBdrkKzL;>_JUVkvN0~Nt}Eg`6Ee6+pzz8J>M z5lh`EJgl^^&LJA7xJ)GA-OyZv~r|V{5F64dU@p zruEnw&}$XRS}y6UD!F_L<(6kEQf@BgsV?;tm+GlVK>{J-VpXX-qW8bV5ONa7fECC5 zM8t||2pLrAx0JpF4T%l*8&b4kneQVUyWkIR>N52nLYNy{%Y)bwZh;~dEc4>=bD-&gq!OpHX&De>Ii>+dTu>#63=gwyK!o2N@{vQX zp;xM&8kX0?gG_I*79_8;hmho1E0Tw}2>I0^KY?UxwH62>)uF zaHHfZH%b;*YnHW{tW9CkKDbUnur(l?!^u89A(#909=6>NqT&x=XG_Y^2Q^%M0g*~o zgC=KUR#a9J(5N-Vq7~m|K0x5I${O5SI8MfZ0i&5>0aX1V8sf>u)q5~IJQ`+?C-ZH# z3wDLq!2JGun>Q`6qZs|0taCfUG;2pyFFG0zIfQ~@acGEhkXx{*11m|zh*QJay8?SV zs#+d2^t9s&Img;hv0XW~>v8tTPW0w;yU=E3XXm6HXOtb%(GeK(N2KvdXFlWJ8FWuP zy+oR$t2hi+#-iAGVk^gX z=?V*Oh^HH`9^@aDPc4x~P!8QCx+=nK0i|$1C$b}x^8B`ye$Zxs+pI0y^i{PP*}uW2i`%T_HhtA?3ctbIB%jO2;gbWa!uLz0 zg$sJY@NJ$U$W1vzckwpTBh;`C0lR38rN{G>YAnG05mq@4FIU%i4;&u=j=8B^o@OT{ z#Btev%f2Ln((Njw7iw%%=Ssw&x|D>;yvPP=97@B5ac=!N7D5#VcmVz705(;31EzCZF1qS0w;H*%E0yE&Q-nvjxdP24 zvLHlR*mS2N`&_$OM>FeySc?*bMZ_>;&|MJpQozYy9CwggX|9f&{Ne<>{e%;6^5X(J zLB3nS#z9sc@*d9u8-N(IK^|PPWEb}K_EDHQ)Tt-_u%BD6`*OjbF-t9A@ALL07i7qj zP?CN93N9`dghMQVWY{5xS>Tmt7UG$Od=k#tGbIUU_+W|S!x)`aj6sm#8F$Atb%1S+ zEl|3U?_J1uE(tZM+_$6rHP3=}p=Dy^_zOoyumx=%sqk)h@sWy#01SMg;Dy8BIq}`; zb3KGZJP8BDujzUa&jzF-i$K5UK zU9-E6QzA^%(js7KaH2+Y3qe&MK zPiza2=mV>nJ#)@I-#O>rbMBct8&czCJx=xF@=7l6m1uFbva(vCOT`i`7gtLek1m0n zUe_(#_}Yx7&kmj+YIF9CWJ+GT;w@5l)hjQipZgRY8l&1uDVK+b(NSQB#?K9ppFKO+ zHl;anVeLO+&WxWsJAMW*TX*k}P*IYkj8sF?DoG(pk^EcLP}DUXSDlK*4b{{VM%3T% zt1U1WHRTw#Ukwk_N^wQadsn?YPG`9+5lQmDS8bU}nYtUZO#e2yK|1`K)j-TtlQ1=H z+K}Xyx)roe{Ay%)SRGQ&sgB{Q2~D>xRiDvpO?M4jx_c+|yd){#4u@on?SA&XS@Ldy z{QBp!@_Zx`CQZ-qfH!-A?p!c~Y$O6#76GS(yNAX+ZHIw;W8GyI zS9ZQ{YqRs&ha~-5ALC4wH?|$O&(kpJ$hYkCwb^wbpc~mE|J%f&9xg^;0c+WiB;$5& zkJ^Sd>1q>kBPzH1uT*=Zx@AtraL=nVnmHLaY;__A5_8&#$^jOTTj6ejy9w?_XfENX zuDSY*Y8!6KhUTF2?$YEeIIfY9Wzgsn?MIIrnwd(fQS&4 z##pCvWRGNM=rl+=S*u?S4ee`zZOxLz8nEx3!p8Lt2&cigq{We01EvY5p}ELbz+_lY z**1i*+hiHRF%QPNc9&Gw976=pI&k>YXckj|%o$)FOK7u(>bN#6xEeEI+Q=AM0u}n% zQ6!Wd10sLKB1k@DpFr|w){EpFt|I?bsQgH9uM2Kn0Imx_UI27Rdh_QJm*O!8CnH~g zAUdZHc5oaUW=|kF#VC?CVJ^VUk$-Y?Z zdMbgr#1cgHIE-|`$du|VBqpr5y8TYV!6>+UF*$Jo|>>y<|J49BdY0Easf)bzE=?ad-fEP`!L#3j{wReWuWj45H{^v zsIusFHt=~CjkAG47Cp)a#z0H?I%qW}ZEG6mseA=0wEVtM|Aipe0CmDKutHTHz8Z5>6E;7@ zk%&PgSckA@TPK$2joWfIc5vu?y-XK`c{RNJRugQZNK8H%`bdQJBY6~r4On@|1cjo)iS(f$e--36pcr__uJjJ;0+jR?8$q%uxS!Mw&Y|qb zLiQ>fMebXy70F9N{{_L_U}M)<>zCQ+71lk^MqJiC$Hro;`!j5Gfb~4dMvk+dJ~kF% zJ-jb0`_(60uUw&h>slXOO2c7vk>(2G9Eq}ZUOuP%YU2s~fkUMij&R58Kj7sp|NH)J zY}&_ks3EAseZ4ClgTm0_4(k9lHX@4QZ)_Z~_x9QP;T}iwOWZJfdJn83VB;@iSn|Nj z7?9k3P*34{7#|Y~|rJGfG2v!R^ zIf8kOJK%`?in}HE!77VkR2SJS*kB3Pjhu;uFiaJBn}`O7~ zhdZa>f7Q3#CcC5fwbMG|t;lgw5=z!j1s~7xX-4Y((tPqkEnMe)VKB@1ghq$y7oe)3>KekY)O=iU|1tp!25KPzZY!^1@&y;|Jb`WNvX@Ie3o literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..861d7759f2f4348b110548ec2f9a9d1ca351fbea GIT binary patch literal 6305 zcmeHLeQX@n5#O&n`_8d*c8rra!CvR$#<{S@_SueOl90Xg+IR7J_p-Z}!zfkiTujg4 z#36A&P!n8eQz1?c2AbXrM2(92L0bfMm5M;afsk53D+~fOO`~ z-C>ecfRsP_2l9F6{pS5<-n_T(&Cc$;;JGfEP@_}(4opmrA5^CfPailut==$oP(3tt z_+VySy#e&noayWKyiI|=gku{PoUp6>phzIOlllgGutlpqKhp@70C2mwJB^7rQgA=hwR zZ7`lNG*cfjLizc8t`g>=r5wY~=W4su>8S(Sc@bg5Je^ZdF&8)~WSqj^S#~sOjq0X@j;kqD5o6Eu1{Q z?k+*7IK5vGny)X^24oEJr`fX!@yvdu@0o;@?r5wPE569%URVvX{DX;P8yn%*INbPj z4%BE05YT7z&sOIDYZDYtUZ%HjW2UcgQ>MQ#DP=YT*a~19f=D4fkg*F{*w&c=5`!dS zB({@CkT6Lk3&p*@?HADy|l@XLbh)Rsi6+`H^E*;CVrq&wkAc zBqXsKnoq1uci~K+zfusE2tr{Z(_Q$H{PyBg`(o+T`cRAi>A@U1y64}J?x zycJgGCuXzr*&Ijw0^`hP>ppQr4VQ{&Q8=ElQaDxRaAG{17-9&eR`SDSD3XPy$u6rg zJJ|({^Cyc0ig-4AIm7ZUDTP&24r@DxRYr;Qc3j|6km6DZ5+b4N`ML#_Zg{#6{`xTs zru);I)0?pcerB_mZ3Vq|mqHDs6QyvZx=E=R$_bM5*;%-im+!_^Y%UGEth^>Bu26B_ zThm+9+xWbpWnr#S4FJX+vt zxDi4wWCMbQK}&2jW-`XffR!NEo&jiG#)*azauA6bDry+t3GGJ(4g&(iO}n z)w6188OS>541^pPtaN)oi<`-m8F!qkSM zx*LsYw&A91C_$pUhVeS1j%$oaGBE0?$cZKl-ApC5LCYR-LQIszi>+NN#QgFK=95=K zU^OAbwk=z;QZ9xiH-f>EkZz7@T#ruVRiN|1#2go9I8rX3u<(&rL!YciqO4xN5}Hbw z+D)h)?_-t)lmCv_VvWq#=tb|so;!)qmu0|p7F+A_{F+A_^F+9(*4bbN~3#JOr z1;LXH>vqp+7Dn+H>p*c2Ssx|qTglpFo!GaLb)nG6E<|?g2(2a5L|z(rC>}2t%5S+( zPS>^A^nNZUiul^2nNz= z?p68*p`(PdgwljI5o#k;&5`(Tj>Iq4!~K?|py_ze3_F2wU6&-Jbt|r?r$B zie|;P=0(X?AB2#(H_soqH_z+bjpr96?gk&NALAopK#HW0Jd@-kL)I>dZgwriqr3*b zn$od2Jlo(!-=JVht47PkBT=5?PLwCPwelzl9ju#ieHSn6B5(M_B=ZoNw~$>O7xLq* zA7YU6yiYzx%2^V(vLN=2vtAS~zo+sJy#4%Xh)R=`!=O}P^lf53$Qn>NPs}+&_Y(7NLbnieoGnM@9%Ak$w2PQ7p&?@S zvK7b-6SISmM$A@1D~MUaRw7d&rpS@_0cVQu68bA=im$OoV2Z!uOz~wxFA?+Sgq|Yi zqihv2zeCJN2%REkp3uF-yq&E<=B>n>CUi3~CkX8#<}j;9W{j8yp$IYi32DS!%~m6G zB{3TaEhA&qXUnJ_Z=K2rv!s)FrSm*ipsZ+ z3%+gi`VkQFxyH${eS7wfp{on)ELa?o*I7_%<#S$o21*{*BQXv7(AgVvxGTJ`&T-ez z@rkja55x98&W4e2%W*-Ey?}2$bUn8aq=rYvZvhL-79)D8oXwue#_$y`e&)t)HHA0? zi(fBOW*XizG^= zZV39}8VUx(!LIe7^!uf~^GV9=xDxVh$^2Wt{H<#kzQ?Eqo~Xb-r8V zU(fk~EOt|9Tsm)XBS!(m7IY(`t7I#ydC%z79^V9}=5l=8rUN2Ldr>94# z-8@ZFg>8$xmgy;gkJ#%<$5Q5S*9p|! Id;a`?0e*^Y7XSbN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-LISTEN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-LISTEN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..356b0dacd7384efdb14340fc0a02c5d58d55e1f6 GIT binary patch literal 2717 zcmb_eU1%It6ux&hNwb^Hb~i@TtZAIaRP4qHP1-^mwL0BQl5J*Zw)2x1C`jCFx(i7* z?rus&Eujbn8CuiYI=9j%pQK1@M4`1c59)&=iVyxlK@ia=K?;2mtmoXD-Bc^KmXgh! zdw%YBzjN+AcV>yyKapJGu7>3o>KJW4Olk$0|)O5>gJ7;QMfIWBjAto?v= zJ|2f(d~f`c2WFfKDrl=YWxH1jm%-6;WL+E0Uwk&QVn#syeMvuVMm{EFDSyJ6=F09(aSyf=*GuJbma5+Y$61J-vH}U zezCBa7k@2xOsGu|LMXtfGD3B=KJ@!4o#yfG7;PHwhLSArLK^+}sIfYcztC|zUW@sA z$V@t2WfqxBVue#DGpLY+9zjQ>YXv9kA) z{k1Cl2rudXI7AQp+aZGN_hKe1`6!Vh{wc2`ku;6L6n2X;q8fv`W+{78U@?a6gcO3_ zi6(3Z9I7>_q>PN~B&0A4N=>X;Y6cku*$A=${_CM>V~M2dBu5lWb6g9WF3G#L!JdHT zN=p(%w2HP)>Y8e}8D+?{(sqJTiQYQfF%v8tSkHoiC=iJxG|MtA#dIB{5s1Nra6&aE z6mCb5KnvLFhFyKAc2{7R`(Cu~A9uz2Izm_-UJzTc-LC?Eoi?WGsC)%V1M*TGRKGxC zN!PM80ld7!=HY|+p*8!Od-=&Zmi zu#FfpT_c4>kzo@0yoHU$v50bzUH{(OTeweLI4O^5w1&M zi}T`SEDc@_V^B3^d?W>150^exi@Yx)&$CUay~@`iM_KzJ7EiNHy#NrlC(?UNU4b*; zY8%1Ou*Y9eLcGGZ%(BE3>v37n69A7p>l!@O9@hFOrm)X79c?pf#WPoD zYtFtnYi&c;pZcCMpbj~jC0@7u8={gcSLCk4YL{G?6Yu`RwmdxvpA=KQIO!$-P5&hJ zeP;3K$MO(EKjK-iZEGCq`Mc(r%}ZdsZv`d;tA9t|!=?GE=p#o?Y3MQg45J0v+{ H-MH}=Z#e`g literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PARSE-INTEGER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PARSE-INTEGER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..26a161b04bc1fb674a741ca5c549d7e0ee1eaac1 GIT binary patch literal 4072 zcmcIndu&@*89(=4=jA-=H0j2?w7p3aR@~lTI}fE9XuEN45+{D7*VlDZZA@P5%x-St zU?**8X%zH+^bHRT4tu@5&eDymf-6S|nI%Pp20~m!BK8%_?&qogZcMATlb)ldHJc9VzdS5KQ=#Tuq9F`qmgd(unmVy`3+1m>x)A3Q3@0xXc#2_$5{Hnolc<*-ppdkzi$8_qQb%d0*x_4CFP+#f0=1Rqv@wE*8-^VO-l`Nb2 z%+S%&{R{8-SS5Vpc44?CN?TgFtSqoAnVSP;S}9hEBX z1yR`RZA3k^QF77-sRa({7LTUuQC*3~jp?}Ik@kT@lShrrC`^t)Bp1kPVuq?4+YbXg z#-&z}OIl=?UVF zp@)%upR@099WO|@gguJQgh!$w_8NhP=eglLho?9sXcy{EayH4?C}%?)yc`~3K<=`7 z$iG-UWPb{$@GY9qKZ*+RAGQIwtoY13ppGNq`YP&A>9qVNp; z1i}~xFPPv)LD4Z7^UZ{;6WG3B1P%l>q-Y^6467XE(p&Tqgd&?ly2;^t)Put7^cccb z7F&7_;WF7j)C|F6N)c!_CpRfRUnG^RSxIad}5x>CoXW| z6CB*!y_Nfk41~Wh2jNf5LAV3WYvfx*2~4OuL>AtIY@5n;D#pw-TX(+$p{vpa*vTASLuOy+JA<&CFp=b+fLHKAZ_~;?LS7_ zkJ5o2+TKM6-LxH>;ds@y9$HG~3uz_0xSW0leraSEQ|VRtT+&=gqrpqIb=XK3mgTO? zYL`5hgkK#gu;D)#P zBX@uW5Ex2-x3Alq_+UB|fCqu0DfgVxp`fAZYA8k@1^T{iJ-oY^;j=4?^Geb* zbLZ13jC+R;AzZPo8ozhdi+4!+0!+J@HF00(;Q?3qc!a51o_amdWT0ec$v`nZ&mgK n9ByfOJ5=_;dLZH))!>p}R}lv~zMz>^LP&Vf5O$NxV4sy7ykk>lhTzadyq@ zI7*y}F{r}$+N7(jUA1ygOR2U$Xh>)!5)x%YMjC%W6YK}t;Kx8{d(d#rE+mzsxH>%7HiT>bzWMiF3uN< z(hSr~PbPIk{ld7CoQRx^`ps=Eh52H>R-Bfs#p1$r{)s**dO}j>=1XNL3=IK|4iCnL zKSTG7hJ*!0{aCo_88Xvs%(h>6&|yU*enHXPuUm zCTC!1%9zRt4eM6WI`2BIv6vi_qjE-7C*yObC1n6tC~kh0zDJH*j1t z$JI-PzWR5?{I-P>zPYhb4Rj51JveSPP*A`IdG0>Pi$ktp#yb)Ow##72g=!ACUBH;N7R@toT?oNnj|AyPJRvE)LN1!iJ{+js_phhK({}(>l-f!o z1wS0StzpxGM#UJBQ(7i#g@tBlX@aMPvtf^Xz*AprCynA> z2rv*<4MR6%J!@fjVh8A(!-{rBruArC+=n(2hOSSLpx6n-gC?N79~-b70}?`#R5T?G z4DJ6|W1meTd zDi%__9D~WMVW`@+>yhx#=J_kMwQsFWQZZFF7SfE(FM%a*GOe2`vQLqN2%jMLAf$eHpCr9$(ib7UA0mAp1Ch50EO;}9KBfWl+=PtVy}63=n4xDgB#144Kpovk$liuG zGoOY@j5+Q38RG&e)F_+|Mcp8SA0Ie}hE85&sq1#($nwRu~+G(X>D|WHmZ@sOup3qR6-5 zI8SGFi_UK=tHdqif!%N#6<%7${e#4SaepNH5PnAn5Pr+puSp!)n~eR0DZfwlVCDCi za)q&%netnVU1rK>$X--_l_|f(*b<3f)}~=*ZPPwFJBNGS)3uCq;t4JfA~as& zn(R|0yX5!cH-hVg%K6G8(|PQ8>uCy8A=1;-y(qelk8N4k5#eZZ9S@#j{4R0?RA|_{ zdu!W?Zalb~w;YInrw+v5(5WKFw3I7-eB+=gYWFH z&%3S@8BVBhOR9ICz5K(F6VZM=iFo*;JRtcczuzxO(UUd1v>?GhFBPg4To06tyN)*+ z8;D~%^7lj6L#Hr7`MB!{r)XuEtt}o4+&@{F?)BGMneOJRth{%YVduvghCKf{DDHA; GZSCJaqDu$> literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR-NO-HANG.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR-NO-HANG.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..baac4a2993357c8b8f9c3e9c069f998a60aa2c3a GIT binary patch literal 3737 zcmcInU2Ggz6~1@IKe4@bc3nF^jvG&%q@kOPTW^z4Oc5TBXYI9jXSOr5byHe}?RuTr z)ZR6_>q-^E3Xv*W7&$m8W^QS!suC4ER7y-=0;F514=7ZX;H57}2wo5sLIhFqLLr=U z@7mrZR+~y7&-%>yx#xcOoO92;vr3wu(36T@T39U1=gUfIsk*pSRpv@%rBYfd=km%N z$dzyEmTi1%Qq!l0zC7ISG-z_=e72gORota~Wj6c#QDyi`indrT%)`qgj{rM7ay&M2 z?ATCyTyv7b+h>k>c;xsA7&g>?^U@j(mk1#_QbW>4NSMeZxZsDQuHm?9Jdre1Q%f1q zU^Vb}z*^LdW7vToi7D06qB@^{E)wcsl%#mXyd9rsoAP&sgs&HK`yOzog+m4ut>SbI|MkKsO&)h1b^yPv3OkFMJT=P+)=koaXhImu3{7z;*n;8u|8)+WtB$q z?1gJEfA_i8-PF6v*9Yv4)zo<_{2n2z-gm5UQlenEdU@}RQXjX2kPr^d4c4wm`%qX< zl=Q$xqT0Y_)jNCl-ggV{=&ZqggKv4)hVRaq{s`@;Ti$r%3V9LVXZj(EH`brukgqQ^ zNKb7_oij82-WdqO&Gk46r~chTY99QTYE#zwuQc+#-du>?rW2`4IrSew)V?IRp@Tu^HExSBB288<3* zf~F0At?+AsUKNSznyXJj6LB*(^ctNvs}|>^;~FVR28$li&Ge+9nVGa2x9pS?WmKYf zj&`jm3&~xeXwt3Z_-5O~h9&Q0ZE_eebwv%^wrthPxQIxOfO#mYnI}~)N8fTc*mXp) zvANn<5*nx<9=@$-b~O{iny^t0W3T%SjA$|**OJJ*2TThB)m&uXMWlMhwhgnPD>I6^ zE1>Jy3ZsD2SVHS0;sF_81vUL<+eha|)HAvp>rT}~pEhHme;HYDIHD1HFM zVcweKww0=DP;oE27fB!64@CNyyOjRUT}prCE~U2wISno%cXW3g^%NUGVha)%(hqg6X_T~6B26B-PM1gdEelmDPt z%-GI*AEWbu9sno&sUGF0>8UKu+RugQKQN_7M8| zDlE1m4iU?kJP;@w5~?E@hsQFOi#vzj$8$pWgRlup1ZBO#u#*$=FG2nx$e-DRU_yS! zaC4Ji3+`7ehTJug-=DLGk-H*vZwm55LC&)WzX4NqZXx?R>wcQWo@CuKbqJ4Htb2?d z8)m&jEOvzTet{iVST7cdd^PaZ5iJh2FK%c2%2~}P`3+oqe9mWuW$tg zsq_iQ&AzyWO8V=zs7ghpQY{w%ACP=@0SAA?9!2uPn!IoH>LeWF4%{mxxO3FJNxTK% zbqEeD2@V@PF7CPYu))TN2Zqer0)KBVTg`d6q}w~aObLbE(TZ(2V;j)&@$s7ux!ME` zu>rb^4Z+?891D$W!EBuOCCe5&di%}%-k8YQs z>QcE_QHt;>QK@E&v)S^jS}4NT3Amx3@SxD2-QkVC7WhLWV+J%f!hp1IKD+SDY<9aCf`!aa%iy9M_${KNK@mVxg-Bvor_F4D zP)Nj9(O^vJm?#Xs-48arM*{zFdOn}6GEZQ8}b){ z*SmYXQXQ| l{7B!16D+J-sWg1K!6%idHwwbGr_!!HnK7qhuas}z{4d6l4R8Pe literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d5edee26f5876e7e255f13da43c9de731529366e GIT binary patch literal 3589 zcmd^CUu+!38Q%p*kcaq)K_}11c|(KuD;4Nz|uGRqKA= zjD0pqB!a{nvRA+Pee?aBnQy+`TNN69uA8!6o?k4M@=J1grLwqEk>|=w@^X1)DVLY$ zKrTO{+m7+b(Sc1Xf!$9LBhY};h z!-Fm3nrm`z-)eJk;$X9O;ZA{fCHAlE|spGsLgtF0yh#6fkd^ANqTp(ZmWlGHK zi$zJ}DVFB7-GKFf$h#1W!GG*%?9V=k(G)1KACUU`3FZbi&N4SxANAEoL$ypIH(V>g zp5+p?;zzJS?dP}cC4~=9gll#f=S(`#?o9RO_kuh`*pMV?Xn_m`4%Y9poXnV~3Yg}Aj+ z!tN@R65ApE_ZjKdMx+*8C_Zp{?C>`@L}WZO0E@nH8O51F9DavG*mbXBKu_yu5L(?x zBb@2W3}pr~gLpe*u*ZcHJ@Clz^g_A4{M^-kJ4|r~HPfLhOVLx^`Fu ztE-=7hQCv}-ZMie-lH*yRVzdUF&w<=?^bl%8cSloQYSTQ%rqQzGzk)G!d1i;+ALxR zizu!KlbSQ8CaqN3Q^f5s(?;9GX22$R8sTYxwi#7)&C@5LpLuBq+Mdq(W}|!D^^9pz z1dR^fSas9TtaM5px1DKMp+qEiTYI)bTcvi|EbV~FhEdbD$Lehu8>rL)$%PfeacoDm z(;lWK?F8LcMYE2pOpeZ_T_6jg1&vCb=nKaQAYDMDqXx>m!Pj;L8?mR2nua39V6NHK zW(>w@6uNc%j;7xZdr3ps=?`Jk{sp)Q88e!R!~)WY%hNohQ{XMCrya+zw!Bs-!MR6a zu4D5cbj>w*^0XDErCZ>sK{svJK=v-(gYY)(LAXr!A}nHL%pFOdK8S$X>~;-L9ZR|? zb}G}F?%3=#qv@XEpwbj5?Leh_%RF7D@aE7&O;kSKvat$-;@(nYQ==(-!~0 zwHK+3Dn&4AG!1LQn?yQS_hBY2T$K1Lx(~tQa1`ddrnM9Nu6C=Co}Y61e3!khr=AO zNLtHKBo%8b6dP0q{xA zvpMoK7oO(uFeKgvCz`g{KB3+&x)WgsF6mg>_SjZNxUdC;A*jk@sL{Y=!oTSdFyU*u z3*jpoNBDxXn>2y!GtU0XH9w&3DEt%GyvEskT=VywUFMoE(oWQTfond`**ThcigrFh zhaRWh85;L!_c5AC((Xs;(2r?XKaKCFUA;6Bqg{Pq92yIJbwnG7YsEhY**9(_zg&@f z&uYDLae;rEo^|E9EPV3Lva@W;a$x_=CIc0VK}ovsceoTy@Jk}{Ws<|D;I5k6cZLg2?r+4+;RSv0$|r@=-@tfvJR zrND3GmoD%nXb^!P!d?O=vJbS-ty?{UU{@bPnBYMQ_Z3834}62ed5E$(&hUS-=v zhqr7(PvGx{p9ZsPu8>`l^W`}?yL4)0KEF^|mT}iHoftg~AbxU}wfKJEE1TBYTrR%| zcG*%TzqF986wl;gW8im+x?BORd317>`+B^}`dO-)Md5hhZ_CP~a!$s+D-PWq=)u5$ zU^CEs`AiR U7dUqRjAK{mn;8q2Pp+-~A9yFx)&Kwi literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-DELIMITED-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-DELIMITED-LIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e9ada3b36b33c814fe9660ed8c985aa82cc094d0 GIT binary patch literal 2699 zcmcImT}&KR6uvVHl;7>HKvT99N3bod9n1o?Eo$sA%(BbQ&TMC9i!`at3QLDb0r@dn zQbIA-G?`FnYcsdDFTUtQW3W%9&~D<-i_!RKOpVdRXnZhf;+u)7=geJ@){WW+lihpn z`TOoU_nvd_ERo_DWmS;JPL28bJQDPd@ALYN$zo*2jqLm(GsWZh6s$0Rw? z`fQ}!+@u+p$Y!RpgMu}kogB=(u~$r}Nq;Srb|H~?&GC~5xN8AfeAZ#h7B}U__B5G1n3A;aeq$tU(o$; zG4?732-7M;a?6b{fnPpm#{6?eXo{}GYheA@{FZ9YUh!4{_TG|uUiW`O$ddiG?oaR> z7%nZ>^=;2DSxQJHx(nBQZ*Xnl`MQJOc0Kq|m|U19?ouH4rEioR_yeDR-S z*j6Zp%>fLp2T+#ZS8stw$gsA#*?23a# z>oLQ8DJ|nm;9m^=5Dd$bCC8vpt+WC4EPD-6V)mPslH_@?s9_x=tBRzhQ({y%l4h84 zJok5ROApfuUllF$Re-Vxdtsx!knv&L_``}}=!U4LtyJ0y`^v$zGAwERq9;depC9Zh z!q_~P)TJt6-&QaxMu;{VaGgNpp(d>=A%qrTXFh?gl>+x7<%pyrBLh={QA-xGhcIk8 zZ5WES=^CIM>LQ@4`D^E7$y8WSv;x(ofK)82x~U*Xfb+|Gs^4pJFHR71KhQcP-_a0~ zujmdW?_)ri4l?i21|(NOR&6Sln3QBg7v-2_NV26EsH3RsDXeoqSC4+(aWmzeT>*e| zV6@fjPj>05xPEaV@G%zMQ5Ic-Mb`)wQv--mv497mjo?Ur2EbzPfROtZIKP=v3f#eBkD;eiG=Mg{ z>61uy!X00tVVQVUxw`iKi4%;7pCXTh(mX-0%sZZJE+4EyL_ zggnIT_cOz0Mt0DrQRmft6t*Uo*c@4WQN}` z@;M_PGjatCs~*HXM{CgQER7&}lW}u-z{9W8npbH1Q5x){5sL;7(~dX|K1bW1qP5L5 zvWwO>(vA?Vtp;EIpzDa8QWR>Jy_nu-z*Kf}N@$#w8inCe_I%Hp!cYdj3I0u7hR3B1}54a4hk(_XP}*{iX|Gx0!dEymxr z@7VBM*~bI9l zbM8I&&XUI0)QqH7j!l%xc2%lOPfbiuNu!mjG+CLh4%^Zw@TK=v-JmB^irU|~zpKTp zlMGkw!jwHCS=099Na6SkQrA97nW&b^@UeFm23R#hd-Y!Z`Won||@ohG?7M zN9;$6t%Mx77YWo#@E@$9KJp{vKtw$H2o<_MR&U|s7XFnjcGg=EZXvE{F;ko=-W(%j z&FQ9yP+S-c)$|aMcV{!_^w9T&%ofk+p?*;a!soShhc=>rkOv4^MZo{CRBHAZsmPNqbCbZU}#ZLeS{BnaHg0K76d-aeg47S(w z_Sxc0X)s#TqjP%nW4*m$wlq_`z8S8e8giSx^M7#r~W~id&b8I=pbEvPVd#de=dE1c ziZz76U{y@f4$GX6p_V(ep$0;j50C14JY*-qlaC%$GDuW_@FPyeLb8ky)VyI(t!^$b z0c8Uqi!4<^RZQx|Wi22U{z6X~swJ%ylD`8P<|jU3=vmpc3@8-}eg?r)Cbi_Oq8hra zrW8X_Eoz|bHpoJ%o;%EE1us9czhG-|`JAo8v$d7S_=Y#^Sr6*O)W(q=r-pO54nfg(LIf6h;EY2HS{B z8YZt_!(Q>$#o0FC3O|8ui(;ASq{gd84Yn2eSAieoK9h!?&w0%A+>>y|Gkwonj(~%#CYdy4=y*{OYQ{`Fl|(!JQkJzv!^p~ zD;Y}0WG$e^p7$zt#dSL4y%aVH^=?9by-z(v`2gN2a}jVSh8mwI-93C1-zfGJi=~!E zZ%p4k{|U^T6iA|B<5MV1mis zoO^!0bIv{Y+_SSxs$Nz#Nu4=4J2_RHlV%ndW)~Nv6Ekzt{LJE9p(vdIxpYc3O#0rC zq7KK8B(_-EiKH<%2UNRic@%;lk-F%#J%9u4CZvzP8+(rBAgNG+$E4V@*#muU=%n9PmR&0*pCv~b|tVKFa78il}XUWV6Nfo}XD z4XaM%lWo^l5 z_>Pd}(mA7HSQP4Ed*$hTJGugW4Iy=etW6d=*RF~$R+iwaatUfsiVL7#v@#zAeyTek zoh(g)kM+lnzWrg*D?*FGa_HK8R|yj?oq7DTJ<|Jh*?T?4ga}CBEVrKA0dAE;1icV3 zXqYGG-FLF=y)GZkcjaT)h;ZMfu?VbISZ#3k7v8@TH5vqnjBLa;T8*|Y(0*jJl_F!U zU~4ppfVy(K1U7~J|Dk&xT4Cs=qY?15RtgcZ&i&MBjj4t{kj7^z4=MV9Mol@H28o`s zVq%chiuJH+Vb#D2z^Z~7&=^w{TOESOY3EFM!>Ts~0@kQy(~KyBMVL znXzI_5QVL1+laBCFT`qnjW81$V$?JZQ#NvTHfP6tO#rBiDf+1F$`0%^_g6gX3TfM~ST@H5ge=DDl9Q3RM%r{5YCAanz&$;itzG4VgY* z0(b<)M)o;y-KgeFlj;?7kO`=Zf-bySQdO}iPn-ooE#Acwsz!Fyn`>S&DE<}1RjOuK z6gkEsNLJZSB?FOCji>DKQ_H@Gco=&*Lb?e|XNx8US`= zlwm4cwh2uor**hiWT=t>kK}9Cj^s;D95Ao5Ml(r6lcD%IdI|)Aq>Ky2vL@8*LOZW}kPE|KQ9#Gb^zOEbML{aA z06OBK^JyC!8}8RiAERNMZ3YsKb90;9QIC*2tP8Rxzj-=xn+t#7+do@P8k69SWhgh_coMB^2k`K7>3<&*j{UdL&@as%|g*E3{+-A)q>_D0|zrf^u ztR>3gdss_5I}l+l*vGzut|Rv;gU~_zbHMw?St!mgNbRSUc4=~&f18}Pq!Z)t$ukiL zkocK<$z8!g(xyUfZ7M(TrnEHpQ#6YO!HmUuftOrox4q$*d)x4j!A|c%-=pq|4?GJB z!{H(%IZ?f45mhfROH{Z`upWR3cU{K^w}jg}o7>;F*b6^$`?Fg$vs?qt{ZPq(reu-> z3T6Wge-e;TwUtZaql2`Toa(f0(-eGHc}CR(RMixdVrc-9PC*}2mcm?z*$|T5%u7%{ z-;a6jJ>P-k8HmRa#0CN8N9V{K<+zaw+%Ar*-jX``%XQ*?NeWYtKK?b58}L!rA03xo sl?rufF(z4?g)~;)6ysCMLerbLQH*3W+>uvUks% zzwi9qd+uE(_0MR!tj(U7o0=}o%d?A>xy6cnY<6B=m|dJNmgHj~mrrV@MPDCLwbArb znI^kNQ=Bgysg#b&&SGid=#kg<$e9DOIyXNx4Ih1dz-IdQW&8K;O*ajxw$9Q1)u*?A zUtfRk{&dsYjjKXzmJm`TRV0ms#7Kzvm%UiZp|+z8<#ehTYM!S2W#4OnS`^o&mhZ*0 za%FZ-nJ&Ftn#OWYED(VZf5~eYat+PNnTCHwI4wl{OI~x%P{yD%b(j*d;ZGDq7kn>~ z%_>rYQ7v-gYV-^t;`Mk;#GF1W-yRii&Ir<-QL(T?iVNZ6L87Zkpc_BP zyevuZlMYF@JP@NRu)zJl=0W#5*SlAgtA$R;rPx)Sx($I7XEtpU$~PyYRWl0gy=DE9 z8U2Egr*bW{|Y;d5nMp&d~`-#|!&km^)%SM^ija&7hJ*Q;*;vw{pEf{+Cn5Xut# zJ#@6z2Suw1CAO@GYAkfcg=Wa9y1vkCJv7Mft+v8H2n1L`-P57FYp2VJ|1O!2)|1&> zkPBU~q0q|mWE(6ARubB}^yW&J8O02cZSzgZOm>3yyqPRZlM>jPQ4zdWzJB-}d0>yA z@rNX=z8oXsX8#>8nbJ&SFo%a-8BvWvom$F34kX5~of4bj=*LpF0}9m|RC30c>!id+ z)+jc>3d5?0Ig6(>)zL;2i#o0abD{-<7PcpBhvr2QEVlAV)O4yE?wB%UT6sIg1W~x( z+c8rt657HVLorZpGTi(Cwd{?_#hDAmA+2bNT9#=krt4r*p#)e*QmQeb1agEAJ%X}~ zoRxd!h06TY%yAYEZ3S7ql{-u=7Wcha<{wwUmM|f#4(Gld2ly&Ps-uTh9hnQjgfVy3 zLG~OV#WmNms8MstFadS1fNtwwoz+yE^1N6C)!l$puj!^uffIgV5|W?Tqe#AGNhGTn zOsB@MGlJ~LYzLALVaql>pFgbUY|KG;AFLXKYe&x+0oZ#R61<4e#s|sfn#&1gOKc|+ zkCXG9lz1L5@;q#w#~z5-)Ip(N6N(L|LJy)m&ageg_P~++7C4e$14r^*;7D#k*tWbn zN)_9&z>%LGWT=`4XR^w6A@RU2Vo&4;OkIISyYwUo!ULvj4353PI&{{VW*ysECmM^( zpsOFV%wYq$v$z8_l_|rP>5j2D>ZZ{$I10!W;Z_eDxOKr!IxGcJ;Ro>FUF*-kZRL;) z?}lm6;4)V=2ZjOz6ZHe4<~JqYMtTg zm>T(+bs_mCFeG0E7UXkIu7P1QwA3|%_MqJb)`H|5Ry*#R4(<*)%Y~;A*QU<+tE}ZE zmVTBc3ar~(8XV5akY2qNKt#yBoPp%EEt^EPhSCu#b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FINISH-OUTPUT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FINISH-OUTPUT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7ae5cdc151248c570dd92f8fdb80f49c8ca53f6c GIT binary patch literal 2935 zcmcImO>7%g5PrLM{+z_Mjq@YwhE-ZWHad`k`B4H)qaT(@w);ck37c$yOp~=E9?}=g)e5sdFkPx(D)*Y zHs!CF{!P>WRyF$DU=Ces>J)N2%mwQ28}Tcq|7$`va+gj2tSGd@<96qKFTMi)WvhBO!H2NaY|B z!oox(-GBsPRFQOZBp~XLbk`#R^?yO~{T>n@M}lD^`|svbp;V+|MmEg|kYNho*rTEc zIJy^q504*2UHm=u@q@Y_|3|e+FbYL*5DvlbHEzL<<&_OC|!A5(*cCX<3?4Gd-w)zE8jxzLx@3u{9nH zZAG^UJ9*87W`H8xp&cmxqMayyqg^Pj&~6k%+}F>267!L7Xm_4=WNGI-?dr#!;-)ew zVQ>>>(wIzy;Z5;6=nV`%YFjX_8Vw9Rj_PF^K@mqQA4I6?ptelvmd1t}ScISHQ4~M2 z<-)gIl<6@vzD;{jbnqo@%t!8U@fBM_Dzqn!iNN?|;CB$FUv*^KG#IBxRT>$lkz=st zSgj9A<{3?%&@@BFSG7qR48d9A=We+zy_{Jr$^3Fb+h=b15ht^{CiPxadZp|l+%Zd1 zzQC^sv|W4@mzB22$ru|{FcT~A1oOWtc5*T75q;;SaeqY*@GBu{%tN`#3CnaK9Z+o| zV1@iNsd3XzS{f7ue#+kIp(jT@9hhwNXnuHVQ{$SlSB^~pu9fFl#yX=x!HapG)wG0+ zB|r$qm);_N9$#$N3xgEGDEn2wT9DUQ_^kt%4xuO5UDHlav0WOJ3Da`;4h`;y?o|;^ z>rtV~9Zfz^esSH=EG2H!R$K=0KAi+?oV`CGv2e4cGxriJ{6TvmFyY1)c>xDZEKC+K zVK5W!%OKdvF5aj*n>p}XJ96~8i36JdCeQfHP0aXAfY9R}IEi7~PwKGuB<=2@r@Anq z&~&O+?e74M3O@R{IL#S_Q#W$&;2>f_>|%5W8KuXOz54w}#16<+C}HW)z16|M+Jy$a z;DDPPuIDOaL}+)*zHGjbU(HoBL`Lr;jGjKo5bYzxqrx~0sODS({$D^B@bVd<;{w=Q zo=-SdENRRRW2!$sAt>KRDUULYUVH){?iyKs_E1JO%7Vh5t8)kPk1ONa4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FRESH-LINE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FRESH-LINE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7e5e6648dd5ffcb8885b7346955582c7baefdbff GIT binary patch literal 4205 zcmb_fU2Ggz6~1@YUOWC7uidptwg%sXIyKvjCEH2cm@0HUp0&5$omtP!)-eS|+x0lR zj?@jS z>0g~!wT1D|PjuNWoP5R2)!Y^4Y`WEz+{?$<#7U-ZREq2H@buHLotQo`Ieq;2cvnKT zQ^MN+)R~$-adLWMYP@UrjXI5#2_bp1gUbOzA|yoo*StvF(QQXbBvZO#sA)a!Z~I;+ z_@ZQO-SWNuNmeUwDC_P^?mD`2zDg(|{xz>Nku@|YX&V0P^b+myuX?>nL&<<^>YPrb z&W07VPSMPyGNnu?2}`%NuLnqo-KAKPghlo0C~dB>Dr zGv#lI?T=6x9(xJdxqbv5;DaR46`Q+zfTF0nuh__l+|{HHCrF7NEW|V|!rR_MU68)&QW5&508sI&lN1z+Yaow^^ zOEI%fChNpQQBdfKtH!bt(9uX}5NXT0t>~xKbS9^oun8kh)xqr*1gd2%OE+5DET_oZ0$y}KZklTA0v(r;y##UX z8r7fIt!2fAK&Eu09tZoK8Pg78jf4pxbXX{62LkP&Hj-8sbnNOWC1WNH2eKgop@;;6 zp7a}j2$#2c43{_gqqtlIW9?eX3`|KId>Dyoz}dIox)sbi??uiSAHk(pnCb{j(SHS| z==+=jkNyGR$fJhoVC?tYpg-k@k^4$ufW8nIpr?g_q%gohv)|SoW!BWPX^5YS<%L=U zz=;AUq1emm88f9cUq-+rAA$>gA4C5Wx)vlKrQU~~Y-e;Wse(GBOUWSlJtU`9%`$JZ z`D-9|BxcO4F`M}^Johy0L(a2$3J77r8|U#)^C!l@Qiub!J!6@3h&WW`M{!w$H)q(u z;s|Qx1+D;9@&l%HRqQT_WgPU|jBE-8>E8nh`a!^=x5RRpk0UP&*@?7dXU;OSnIJv% zlu$b%#dB?)WhW~C9=CSQ2Z>&8l?<8R;l6W`9GoCe;pnWNjKu6ac=qwT? z6tdTWmm_QGaQX4$waraEH6?X{9|z~4RByXwc-i3IcB1q934$;on4voDS%fA#e^Y{Y zJe*A7WKY)C-CRl8+z`VSg<*@I3`VR@&ZqoZR4%6+*%Pd!8wSvoDbk7z`rDEwUD+7-; zk|_OxKZWNH1n2Wai}jH2J^3-#YiPSvuHD@(-3{#0)sNVvi@rBLJ)^_z*G0I4fgQ@L zQAo`S+Oiup72LOB-@B+^bn}}vnCdr6`C74DVq+Hy#e9Lm&|ig#|GZl(1pdKqfLfX5 z3%N?Q1~EAQISc?uw|LXS9B0f5A{T_|rQG_aiy_(<4$hbBv=^&21LccTJeJMf(hhaI zpZ2|rPs99_$T)>U#zbO2CLgps|Izmz&pVG13=`_39Lr)W}Sxb-O;8&sp%W}$^WMhfWlDb z87m1G5XZHL;T#T7gwiX*HLp$|LDzyr;>3U7feZBkPI$*84XuNpl6anC@9N4kGtD+q zNtmtlSq|Ai2VSiQlm305LECweQobgveDi^<0JyN7#7V1(>e2&+wMW#9=&}&lplV*J z(~fiZ?`EhO$_WV8#Rs$j?U|IsO^SX&tb=X0_n#0XC3G0(n22VkGw}0!R%yIhkTJl& a28;Ah;2-!>#x*Pb90j3=H}kp`_eRmjFP4%+AXC` z1(B6*2>TM4-EiD9**~yP+Yn@PBf>z~2S57<_)!oA!4H0@&vS2fELBkmJip&_p7-7y7XBt^o+yWUG>9cnvLN!6&N%T=27_PpK@^dh-7wY*+>TI_Z< z&2?<&!WIz-@jmYjm0VqMR73Y}2)jbkyVe^~b;*R*;3B#8xDu)z$)ttY2Y!wBPk`hI8yKLYL8mFLnz>%sZazA*~)mp$#8G5Um%z1CG@v=S0V0Ny=TJBmJVK14{8 zkbb+7>E9zy4^$&Go>enc8;9K2TX#PK`+xhz!31*F#*IZaEpBjNc3mFX6O5sg>(L0e<485r0bxHHGUeu^16;#mZWjh;+ zvEfh@b|IZrWJj5oEb6!x+@<0#L(Hz*4y}elU@;zSi=t6kcTK5eSXDdAgplxeZ^y{8 zM0f-aB1K9~zE-#p;RG8F%#&GJuS>ojV|%?+{?H1JLi3uczb;%CWDi)@=mPPdgOU?v5dk4=51@+$E06Shb`r%Mb_&H+_5zB} z*wJlvEC-fJyIw6AngpG=^d!0#3|B9jXe}%QkD8WI#`wYll%5CzOE^%LLhTIN_=7{1 zg^x6*<0SmS9A{IgeI7g`__g~kRMb)DI8-SXh*l83`*-I$CV=tq4f<-7Wqag6NK+|eTDjL+5biYmOr!{GbS~jdHIzPl5VC@^(sQDVh1GCQE(DCRf;$ z#irhdK1Zr@#nt_pzQ)q8;II~5!=a~HdICtqrp{u9rDG6MD0#gXo#s|ooY;{k#I+T8 zyjR8c#o*mV-HzYvb?-~>27VZ)f*z$q>!hg;wPej^2{2=MHhIbG<>m?$7L*3Bss9(z z<(ZzP*s%vmb83)4kXdSg3LGgM6*+>79oUsPDswc?k;>5mM-`4Vj;b8#92p$Jj0f2k vIkGsieRO$X;d1>FM>UR?IjSSV7e#oFrQQW+7+gByPnyjJbducK*x&yX=w>-q literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1-TO-STRING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1-TO-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..873928126e37e701b4a47cf5d5cb4434bdb1d4f2 GIT binary patch literal 4001 zcmc&%Z)_Y_5r4bq^Pls-bK*4ZHFY0OQzu8(!gd0Q8xrrW*S@pwZZErgbu22P_1!vm z_4&@+trINL$V8?s;^g3_we}GLNJvPLS~Wy`NFc>P1QJ3;MeqSpp$Z`+q)HG8AwGtg zeP`!l0x9AH*81kn%$s>Lzc+98?Hci)QsPu8%`fB&cA1tIorOh*&X&rwQd%r$Y&r{a z`UOSP)t92OGTHy!K)|TeWXiVX*jZ{W+Lf%ebdU}lrSd{KUx2}pBft&}A08Y&bf`Zt zCL3|??U6P^!-tO!A3D+>xOa732$l#T8M1+-g^(ce5%;xfFl?%ZDUHSAs+5!yYS>+K ztId#$lr~h|t#%Dkr?emy?6Y!XPYSn+V&a`i zajHAiB{ZJ#g1xZ^=+*<#=RzTPLKC6yS3!)XzygOO5ae6A5ZSqcZ_BbE2K-#pOo#wt zaD{W~|3OpplFNl~l*6B?JySh3O^s~Y6x!>YOwodWYqk95Vj%IHV91aB%Y-&~U^m7% zJ>9XPb-bo^e2KGPuSM5R$j0?vkip}H847XcKfqI)il+As0jvMRiuv0R!H$bfyM){= zFGFDOuEj5D9d`&>%e|s?Oo{>ox_14EsmE$51M+PUY(De&#&^kwDBLWVw>Ar=8KqMp zF#O2=cXR(}Shql(ci*Qry|-}G;1|_}Zh(63HxI~g%ekPo+5dYa;BF!WD{bV0L~L>2 zsO||XT5>dohfj*i$??z+V zFx7-8!i;Wy{*|~YC(|iuOw$uam8z!VH>!VUEiHo|`;J~)_)ZRo0Yrvk=hmEBd%o^0^TyjUx!#rI(s0{hhGRef4A0QR_w(qDl8_JlmCO0urY z(_x1;8T>-AcNU2Ip26MngN};%l;)JZ| z+5DtQ)5thbB?@ff_rQf+Sekc$8Cf*1b+Z@0!ImI+pk_yOxj@++to zzeQ(ghV4N9m%#hvNR7J#Hl48~oJoLEjjOm-IO|8SKr4UONlH}KQT7hZZL7_Z%;}U@ zJ8z@Afx#i}{7v9KAqNbnoG+fC=kiXDrWY3AUSSopfq3bhT@EN##YUFK^F@2swzCy( zdJRmQ6fKdGb(Krzd0JVXN1BsoVA`&2Z)0g(*U~9&6yQb;-fZFToctNG*?R9oD#D-G zCz1S)lXo%MG1#JX(!&^4x4G&T0(~;Ad0Q#G&5Pwt5H?^5nzrFMCAA`JyttIhY=Ah;p#vLPgwVS?Y7gz7wtc|fx;Y}{G6N_|#a@=68FpUlKB3W^(PizmoUVF z7AMz9%Lu&4;0Y498Y)=xGg%9R+}_0jUcu|)(8%3tqZXM^6%*cQ(1G}2N{KM;+*ZF} zh07fFa$wQA2&r4`AC9Qd<5Yf$^={_Q7F?S+T`+3M;gJ_UbgMwfHN4e-)UEIwTl7r+ ztX-s~nHTMhL-$vf=4VO;iXQ{sCLZXg)Ua*pC*)@i*OSU#ehZpURdXJjgF=&qBAN7i8RY zi+US?9~Fr95=VPEUMkJiP~?eAb%}ds9K>M?;GuhmmcZxU7Z6|SoGa12=ld!LQR_kE zSY^ip%r0gR;vBmG5$)~m0~jAN#RG9}oka15Hv+e}o6)ss@WoB;?o~d78V23n<=m~< zTI}DdABnp7utIN=0rKXQW_VY;<5=}N-Zcz$h}pf&ewxj8GrN)5#D8?Pw|})aw0gdC z^}Mk90@lCqS-uBeR~)GuOYAh3^B>_rorSV2m63aY72o3Ir>lpN{CMRA{Nm`QTWzc4 z=NI6k)hd^*C6s+{WhC8m6GzwK>#kydZqY7gY~-)K>}x>!jg{knyJO*qt&9Y@r%M-! z@bb4%_UbxmC}ba9hqVhFSa_kVtejZpqh!fL^_K`R__k7-S&OPVc>lM~@RLx52{K9vtqy`P!-wnP-fZSernIu?Pz=_xV;NZflk;r!rYh)|H$VcURn2 z4`PuEmS(!G=&013Uy!TLDW^)|oNO?GG55JvPpY7+cE-@%7lbE;e)mFaAfwB9gr-bt zOzi1cA?t$M>K`4I_sb)4-puGD?6uYKS;oZoq7jk2`FZ)ulyJEw?)}A-I2{{|3f+(S zE?(LSxc-69<-tLG1`iGXtOYWu0tNQ*#n-LgvFODvr9nSO;8gnfF0|8$YG7TqD)x49 zP7h-O$j~C0jep<}3TC-HNUJjao8CSxbvPZcrc)i*U}Soz+O@u0WoKWADnLzCDmJs$W^;?1^7K@H+@nl zU-tI{dSfMf!3bYvY^8k82v3Ou)K)HjYI;k@0py{dR7>}^f5LuA#I<^OcC8+IU}kzN z^ggorEq61&(e^*qY=@=?5osq^A0vRf?f^dz`R2+ICWhRXT3h3)p(iucCvsZRlUdD_ z6B$tSNh>b)cpl#PO&FWB)wKNR}oiasOzbTSg?g5$ze!y40*;X@r%%`v^GRRsu)7Z3OPeLH6#_ zj%enLY~kdxzG#SxcKf2j`@X2~8;C|N&6bmfTFAjeg^nIZgtx(ofs>N0nOwri%4_qJ zn6JZ$&3Bk*ni1@YUF27d`i+*5`KW}eUPKRf{EiZax#w5rqJ1Y;B59eX~jy* z>l)X+&k*}6DP}XcR+MaZ?MkqSbA@mCT@GG^T+qmC`d6{&?}U#-FKAg1y1DDa-tac> z{t0M{zXP=^ZyJ-7Q1Km{b)SEq$djf~$a|k4>W{pg1iptGs#~X;@k{6>ZN4)(#%ZbeF{ zNgkrG6L}a=l7|X7JASOfr)hI^Itp1<(~3zpw?nKSeL)o~+cSCpl>Z81mo?Qna|$Vl z*7DEsO_E02`tehP^|B128eE_z=g@VfU9f#<;KE$CKeQrD7lVun}Iceu>A zVXIq3<#FmcpwUbU4WwDJZrHMR6qQ6)mci-MwP_iRXz{LM-vTWJXzj-%Zm+phX%cvgpI|w z-IhF|q!1>50r}6mrqgIjLrcn#RH^aj*pem974gcO9VVp(_Z9aA8r$1>Z1NprDVu>k zC2M(o5c9@))ji_2cG&BNxwUoswAs=wvK{knd)Zr>!cDg|Jdw~a6||4;q;TDBQD)!t zOIs?|r1@jVol+CSSt|0NinUq7;*BO&#rmwwU$*hRQp0g7wa3Uir&uaWrDDU8n&o0s z@{R3oNT-U`MMtVMBQ7nJ`dy44D%MqZI)!O8t! z7!$+T<=#o$P`pn%dlSGw*o2K4n^(D8uq8- z%7*ol+uEJSmME&(c`AvzGwaNu45TH6&Y&py4M^We$jlh>ehQU4UngwudFoqX%X#1I zJH^VTMv4MmHJ+&G0S;rq+vfp$`Si`3{{y@)3Jd@M literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC-TO-STRING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC-TO-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..733874a1d06906664645de11b8d3f98104fe9d0b GIT binary patch literal 4494 zcmd^DYit}>6}~g$=lZoyoTl9-?$l|TW}C5MJE4u!)SexWy&LcDY-VQb7y{8`J15#E(jq011HrA%w)^2SF7`2t+t% z?%LTpfkfgb(R$83&wKB8&OLJ{OQiOw5*L-?shM2fE{VlicV^ZVCyOP~DbAKMwm1oL z@kK?`)t92OGTMExCty@*G9}w`?FrGGwVerTevjC5K$K@nxjYP>eHPfB{{6lE`}TDQ zhGiqpqTSbLU;o~{{eAnp1GlfNaKR!WBtuq_G!had0`V@DgJDxOOlde4SEZz!P{ZDm zS8jm4NNGdWy>ff6=oV+Bygg^F)kIj{UsZ?DuR^++i_mQ*BDlME9^Bjn0T;5;D$Z4dIeuJ2}Vj&e5&{Oa4I z{8&e*ovSy|`*}|?3 zGkUyrRcpPZwSJnhuUA&rLdfdXE|9^`UuG!8nEwJ##S~rdI09Dx7c=H=!k#ysuiwID zZ}^x3duu6vQEPpdkfrRaTI(p!0W?cj9~pb70y5;f8Q{rf9$x(x`6CJ|B`S2Tm1qNm z84H2m1Bc(r!eg|m_|?I`widjRr3s#>&UZj=r+@Mx8P*sRRI2NLUkQXe9Da{J%Q1)$09k{2R8FMgsZJK!RvK+OFM#R*x_ zwd$DM-#}bH9MRIrA>ZuJR7C6F(8rOi(k>)#(j7=H(*X-w13Beb&{bj=mqplH(Sb`aFDJx3v?un2r@O4mj( z2SV0gyl@=ezjaBhE5FQA)GxgVlu)fDo)9y16B-WyFUXM!w-0>UVo5l}fV~=5F}G-i znQLNiV@Zk1I?B4iwz*;>nd2$H*hCE1)7!^_ZwGF#95CEcu5eO3opZBddS(W0K2~8O z5HFs#O991lY-GiFu3%5v_JqS+L*QDkXo-}ptGsehP0)VKJKXMW~!$V z{3B`2PcQ$tUqE~(2y5^hpy3u~*y0oJAB=p!$nWU^FyVejKZ4}vjJ!wtk-N#b8}uM@ z-(;ovb^07~Utv0rkuy#fUP*!jd0DHMGb>htp8#l{4@@?S+}hd$bS9G8ohvqi_o5 z5F6-XhK&^jmrAI2EtWJ@{RC))NX$G=`x10ut#MT#f0}N7iXPlaH+NOAJrbguB?v9N z?3MRq;8JasY!Pn5g&xT*N={YLp)hkth(0fR<;P6hamB8)a+f%1!Nq$*%oW(38D(d& zNeIs@x=40FPj|C9M}(gxvd}26@h*GI_`>Q`;P{)Ww4pi2W3VeZZqOz$qX${x{naZ! zvT>PKJ}}MB`&iq+S);NgJoEg= zy)qE8Y}mHwW-S*U_S(lsangsZ3LQVBC7#U9*#)t9V#?0A)!W9yx<{NX?= z%mv|k;gv&q>(q$}3lp^Q)e0XPod0Ttx2spK(;|me#S}KvL-kN5^{i*5co?^BXbJE+ z@>;nOyP2#&mIy(pA`EQ*=s!_4ZuiQ&Qh6Jj)kLwd%N0xZggpr@OFS#%sw~k@0)G2I z817FD@wf0(??J2bUbsKy%%3_@%!~Mi=-2b^Zc+SD8YgolDB_YmQ?eZ!kaly$!X3=- z0^D!4n108G#7w|uYzMZ3dEkDzLbhTa;CHz~A1DJ*T6brlCO{9h(4)2V&^q=#RiAV| z+T8mLVZZfVs~W#SkKuym8H(rP#o}}Y9kwCqP6aXW894nS)HWu`6^oFW9mfzi(LG%h zcbwVf>_M%+b=NAnJ`gsRGT7L8$m@=-U2wSXVd8@`y+WdRyB>s_^Y!RbG&r@!-MYet z02}CToy*>cEyez$`o8td-wVxp849=|r5XP9`gyEu9q)OD+DE6l=+t9$x`R&D(J4}U zV6m%vu`9HArfu;Iw|ESzn)?L9)^GfSRb$D=nfw;c%^V!_VhN1NFBb6zMSifjAIbL@ z2H=UK>t4Cp$(@>k|Dmu-C2JmK-(DC@cV5TQRrr*5>`%_xg^Z2-TNi{Hq+eQi{)2Zd z9MOfrAd7VIJmD^U8D*bYAvO7l`3 dxe)o$I~TEQ3bg}lvzu9;UT>x3i}SZ{{~IR$-L3!t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b01ccf24b0c04be8b0a253e0a1a0fb69d4c4db89 GIT binary patch literal 3197 zcmcf@TWlj&_0Ht6v6FZm!is7DiRXX*yo;e?s?vG&$&CK@3Nv%#arKS8%~RQoBqb8PuIK_ZF`%onnTxsPM=W> zQ~hp1Ru(57&Bm=moLbAN`pzn~H=Xus_4;|5eT2#zEw=%S3l{**&g3R%rl%+3dD+sq zw$GHAo_Xk@ncRhm_}y1`g``IasgVwX7$Hg0L&E2SWX4u4Tgn$TRnp~>nhAHpU;tu~ zDwb-7!N?@_y$z}1JmoYnob@&l2nl~04CE`iViyfPd_nlWFcjVhhKssXhS21Bm52jf zEvQ`xgQ3YuX-djUWwWR&NaxKlSipy*dOFP!hz{29r5Dn-f={`CbrBThdr@$ZV<7hb zwCLUj4?g$Yu@RxZ7exr@M?2aLBk?;zcIrPi5{se$j_$nq`K1%xkOv4E0%zUY$<9sk z2@>~n_x6772D%|4voQ%V@i@EGcwdy8H0b@W&7b&p<`3Bx<$c?+16y5lU>-LDfDaEO z{l8lV)eC7**QqCo7zw{t+$tbd| z6eLr%D<%}H5>&gV=okGt)O@bm@DmTjpfi3(Mk`zCyUQ*3v$%3qCDpEfL{evZW zQI)La(yW0tg}(r;5AP_N6y9Se5&W8^5Zq+4BTP5urZjaaHJ%^6Ci1QE%2da#{*2%Hpf@?Ec_{WgQlKY;4v+}k7c zo9K3wXWaEmz!FwjRf@6}ouE`k^2L+VYE^0K zl3+k7@sU z#jw#bxy4Q+_ze(yu}lzogKzu=2QP9EaPR|`-9j((&=4fmQslDA&bC=@jZIcq&SX;s zc3NfAUt_r}%Z;&In&q&}#RtP+)OOlF9ov$}=voz~_bPRpeDES|D>|+BVM5w|s>uZBqn~ zhe3*)ia+i8^?1{Hy5TmRHu9Fkpr7*)yBHZ`j~r5UE(|7SW>sh`Dxc@kBgH=mbw9=} zs~a_jL;e;9%}Y+pUAs>Gdex`ZCiPaHaBBW|n_>ZEY0KGYIc=xuSAExO(wYY=x7nsn zyH?$BXsuptRcpS}YM-Yo@G^3JE~wlqxav9W=C~hO{a}~ee-ZjUOsiMAaHpPhlhFCY zAl<00udG(_Q0{H3;II(2Rp_jc4`X&gRctZNa(yf(4r4tre@A5QZX_L1O ztzQp=@p8kdwjH|afp6gQspdf`ulXsq;d6vS<@ywO(w(ILFUSqsHL8QT7Gy(cav zIz{jqAGj5L2`@i%ZX3z~hPDXh0bT8wq8V1jRIx~~PI~93zM2z8z^Rk-Fq)2-Mh~E~ zLW)LrNdk;PRTl2_!^;s9lTe^Kn$qS5zftf&CTt0(x)2o`+EImGFbR#_Fl|D5z6{|e v6{A#!clVssb>s`|+XB#ISIV|osOXE+E-%8|Vi#UuTJO;tO@4Ou?%jU^wPuVI literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a01fe2232f8f9740b921dbbc1be6093400b1b074 GIT binary patch literal 4040 zcmd59ZHyaN@$Ih9_wCq?)!w=J*hcx1n?3Gw`6v!FS+Cb;$Ln2Zcb&UKp_OZIVkeI8 zYWq^6LWshV2xKKBg_B=O1phz?L5YNDXu+ZtKY}U{QUyY)gaiU1kgD(@Q2|w$dC%uu z)2gNaNbYXle7>1^GxOeFC4F<6A!`e#7b{h-E-x%K7nhpy@rAnFSXinTJ^47$ z7A5cKcDohYEjJeym8y5ft715(8$=+a{iW7GGH+^b+A`bE3Fn28_LbIX+Ej87nmVHs zaiD7jtqbke$nM?Bv@)gS?6m2U8!N#Jgh=U7P(*KDD!-f&Zq>wZ{wO2Ph9e=te}cJq za|6KM5BOY;MBpcKIP$|5kWm#-!2aLFdp_T{7=jpz5q1K=sSNWNFpg7IsV7?%hx#~Y zfDi%5poKDPe}RK2Fw5l#uFCjlcGIlf<#fTSPIYvRk=ZTPzTR$?)y>crvjiFbz<UjjJ{jm(fooRa^Bnyu+J)sPA)Obtzyf}{TXE$5&lW{d^`0VRu2Xp# z@CPpRKO~fIvHbwObJe(F1zsiOYWb2C$cO@{U43DE_Q9?Lkd+ZsEsk}*M}C6DZtY3^ ztF<=(W@a~l-v4a=!S^!1)^=sp_TX#;BJJktLj>@iJAj{unYnV1h=c8~v^GRF%S@!P zCzX_HCJfzH;%T6mGfq?-po5|xe*2*5Ls3n2wUlD(Zr+Bb)mYd2oq5OAv!VzRVLlc# zLs!jwPDxsJ)`?O<6yB}vT2VSIjnYAB7=}O~s@t|@D^}jk<=v<>0tzEh)tpxt9gRps zAm?{nTUWDE0Qdv?oSMxUy3?CII5nhoAT}87PL!w=1oYu(LQkrB!-YZPrf^;}7n*z0s7f?v{22wtI^5j+ovJhV+es@wC51E*>*(IqZg=b}X}8UxXg zqq|DN((+mGP{p!9BfEeT22N6O=Cg6jP*&$SGDpFQb?>GNe?{lm0fLn9N5BG3PS?^Z zs6#@O9Fl*H@mwFM!;ij9Ym#!Ne{BKAKfCx}w^)I**#CX%xXRG@x0zc_>UZ z;i_>KppXZ0h$+}`v{qJuBX%)#;Q(;fF-}T#Qc6!_C*6kZM^Mp7!}X>b#_HANASc2% zBn*(hft=6E>6jn#5+Ebp6u`mfaU=3AAo_bDkQSYMmQH<=P8xJ-f=+IvQ%R7L9tWwu zoNdjZA!!n7V3^%^%8YI0b96mY$0;kUAl#sS6Kjc;mO%FaQ+x|le0UWzS@Gw9j&cjw z5S;h}W&}p!I74~UNza&iLW$3_;K*ON%%8xPUxSL|)IR_k zN++SQbVo5QSJCI7!qCd^fHMq}Mu7%(c(;+?0&NhanGm{0-avDFIwJZT6iB3PoxP=y z@+-O*!ENvf+vMI6kQZqPIp3!-1UEVMU5p!Ye*|gY;I!*BgV+~n7{Ns@|2dAGr^csf z_!P~2f{xA7m`lfwP$NypK1MT-((#=%wvCQ&p+hw&^vR z@|JVz7P(U6PtkLZe7pcJ+|mRniEp%@Z$F3E$R?gQ<-Sp9q`{tQICL1qXpC3r&)Tic zZqG2c*0YbBox`RU&okQ;o}E3-Q|;D7EUv>O(m#Zg``Rtc&bL|H$c37`@YG4K*n|r~ zF7TiVwGv{{MiW+rdP(80`sgmX;dzzX3G~h@6w7k4(D3ADxzLoEu^kQhOrg5u$(4re zJ&h)sWv^>~LY9wu^~&+HT)xtj!Fs*fke{hE%dm0Hd!|~cdEie;_G+aby|Gv*dMvp+ zSELg)LN?DG3X={zXi{&7#ZCqO`Z`F)hew#C!s4lSV1Zky+XQ~#{c-2!cD}aZvb%Hh zp_5J;7I&|obko4aWw6Zt6G@~YNupztkB+xnk!s=eQ>6k%egCy7Nb4JFp0E#GQ&q1}Q<@6$arxxnJ-y`B ziXP%~7bPFU?DFG(f3<+C)bgPqxAgc0B3%4B()OrheFii%84y+pk;!7I_PjCiUU!HJ&~;FK_U5xW?hwK@P`# N@0=v$`nkJz{|iKQPj~dhtz!qj zY;ZS+6vYiNf*>{I{E{=mr2mD0Dg(3Ke*-+Og+p7T8CIp+Y9*Hv9q zJA3=hme&V0oVbOv5; zr+(+WSiT@C``u;>7b`2cEw6sMu)4G~pIujMJ&yL)ca~N^DX%VGn9m+P8j?Z>0JdSo z|1tmtNI>w5UyvMXJMy}wQ`t~zR0<9PKaE^u*QPA+rxwJ1XJ2l4UwJJ~XRikYAo$r& zue*loXr>W7BtMYJ;DMjh4B0|z$_51?eH?{HCxM?`SdbUxvg}Z1F%2FK$M0bpKTZ_{ zp3dXOlPWoEL;ugJuvsWgkrY3D)2~tDpB%uGn*h`I#!r#P;f?&r%;Wa&1O0)S{|n%t z@spXa3Iwkm{PF(g^s_)|fJuN+bGtag>sLys!l+RIAr<`Ue<-P@v8HiCaz!!Lbjsw* z8lD&%wj?A`sVPZS9JL}d>bMM zQaF)FhnYkMmCH+%F_X!r>sYQMC35(}q@);Ia&*pv1b(4>q7vx@Ksd(bPkxU<#^^Og z@8TlGffc92QB{{QYP?k6klf&zz96eAHjQDzi4_zgdzN0KY)iJ0xlYHv!GKANnHz?~ zS5ZDyEPu-2Ao^!vDRVpUKkj>7H0!bLd*WQ%`?}R^d*YzI-D&SM`^`?f-fG>s8Td1f z*XxV3ca>Rjw~jrrBR1Qyo%z|_v-3l8x|PKGSQA(ti`R(P&%$CJTQ;Xw6lOb&Dz)ck z3kL6~Z|nsld-Wjb=~8Z(Z!8Fz^xLJmVX&=cL~OC!9-#=YXJJ zPDY;n|B+t^r)vg%Bg&Z}NpYRtDQ&{l04NQ~#Wujq^-IOL=-9B$%0ES6G(`x1z=bJ7 zr6}BfWtX3h%ps7s=p+D;$OG6jfuD)W!Kaw8jKtEGX-Dm!$0nGmDOJjcqApveW}rKc zdsB`r0g3ZNQo2=n3i%O3wug-J*c=EGG0v+kuilmi`|*4x z-07=)EJX2=9ElPEL6gd5lQ{sn``N@fWLZ$nnuUXZO+L=16siQzGhbK^tGGsWVJ!GP pc*sZF85P@&H_Y=P8O;qHn}{j89Zv9T*gRKVBpRNE->w`T{R=g_0Ga>* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-CHAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3c021f9cbdcf69624abc39230ca99372a3f1363b GIT binary patch literal 3099 zcmcf@ZEPG@@$LES+=uPlK}eHp>~3B1b-8tIHwlRo)U5a3*%#mKUUv85m;&YETj#E^ zedg|*QbH}Lgg|07#ffU|E3Np&4hyLPA1B>OUkDW_Hi^ zB^4AQglRP+wj~7#-fxh zZhCHVLT)!!l_lqfvqa%6x0uA3_gy!VE9;t_H+1i|^mVDq-ejQ>Qr#MLJf< zx44vy;GR1rnY4{!fgM=KY=X9u^8!CS`QHv{xF62j#GV_SDdaDiXP zLV)}m`yEkI-BpYS7^=PXf84SD9(wSJm-Zy3+Fd_FMDJ}BUN#1Q!PrLaTgKpQNJ2+9 z?i`#u&p@4Z9uLL%ONenUAaGY4BydZl2wV?%wSYGt@W#+g(&Dy~HMDXO-B9T?NPGl2`;e1U ztoh=UQBbzW1~D1NvG=2N_GhH``pH2l_ItzztrFMrDyn1DN{Pt7A#zdGOrzT-`vA#% za#KcG&-!BTi$_WNj-WI$5JPKX_&M>|GeWk+=aIT-%a*Iks;1&;y8it1lYGldR+|N z6epS@b4_Hfh)hXj&f{hSyS|+e$zvjYSR_X}PFzZf=3 z1Hx~B0$xI<%&#MtSq$gL9&xZx!#i7HAik$mL0jV;>Z+p z+gYI}i*I0VlpjDmic&t)+C%EWO&1oXBuajHv+oBL;17&%bk-{(m-lX81r?@1 zgDh~!!8FW39xlQx6rcz?7*K*sV1flUl;JYW!4;T?&p`#Q!U9ymfkn6mHK@aLa2=Ll z8CIYHtMFxLLJQik1~=e&_zJuLUxhIkhY5HJPQocT4WEHCa26hi5qJVV4Ts?f9ED?W z9MW(CGN8aHJPDI<4$i}8@&7bjfM?+I@CEoHJPTifoA5Pw5!OM*UkqYT2O%ZH4|Xwo JwQ~RdKLH|Yhfn|j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-LINE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-LINE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a49afc60c0920771d0ee3ae22893a14946ce84eb GIT binary patch literal 6030 zcmds5eQX>@72n-Ef1T~iU2?V)Hy_(HA;~3c#dexFPD--3xAt9p-aYT`)d{qv=etes zob%bbJ2!~}rXNsRY1<|ZxH~C92nit-3MGh-q^%AKB!~nOf~pcot%_8Hs8rNS{86cb z@ZQXx?W8n8lz%`v`^|gv=Ixs|zj<$F&T&mgm6WK=&de1{c14_>ug%TZ#N)FSu{t|n z$=Tv@kc(#&-B3T5kd?8%1N{MWMNh6`XKQv|wC3$jvT6f3D~?s@(pzQcXm z=}c-;8m1Ipts7aHJ5B{6S|LfB30J8!7St$&VQo_{fo7m`lA7;)G83E6)0;qHFOaW-}=v zYw?t7NU$#`Nh6KynR6Rm0E?NzYj6 zj1~0-LAxU=YsVxiNAtc_AZs$=s~QRULdX~}nSNlxXj@Y!G4TSsy3sd4Lar0)zaho9 z1A>Sj^ZI_w(5K+@e)VoSh0F2fv9^(Z`X!NH!rk57Kt?*mz7&(aMFg zCqdRZE{~~_Y#1^%oMDCyW;n(S-^L7wnI(Y|;eB#D*brW!1B5GdfbeZPKzIaD5;j#! zit9>d940FxSWvwNJrU>`kvv}-brCxa@MqP(knab16J0pe>H{ulrd1^=rzlvYG>SK& zcwANtU0P|g2gEHSF+HQjsal9^Ms0!I0fc{(Y(er1vK7h88M51hveI&Yp?8JrgS7A(3+R#Tatp0K8k3SA4jb;tuM$vaCk+2iN z-=gT_Y1sfcgT(h+s_wf=`+Zj!ISXoQtU|FW!Y?ZZ#Omppso7E=8}c}q?v&$4GNvWR zQs}ntVGylKYLEzEA=H$L3ytyxaIM|649EwPl8_CQodMkrPe-zjrKy2^%#A+w{Y{hz zeAFH_vf$a+R1jI@zE zQKgym0pUMj2|X=dMGeWQ#FF|wNy?tPdXriA5KaDOIYFwDJ0O>uu@ z+#6mHCa~)@Cc8=wAomjzLGnYUe~EG5BL`9VEyi77nop2!6h6i@A7$J_mWI>lk{vSLt9DDW^%BX^z4Gc{=Dl9pR5#Xwp6WEisc8y{H$Fq zZ>x#fd>&9-Dwgfzww>Q4o-E*%f~lgEDx!t^U1yVJS8L+t1$nc0JPT@hu~=r829zyq zMYSD^zAh+*PzcjNCg9HqG%sBYIuYmqE>#|fiougEpFnzCr?-@ynaXF;+>K=eE)-tb z5W*PrWpw+A2<7dp<5RVGE6^s`at2%ro^kfm?P;HytJu|Qakd;NWUEk(#3?(Ft%)T& z3$v&dij~@FF;~b|vbmaFsfwl9@&hEqaX5>ui+qPS3pk(Qt%e-Bxtnl*Vbu+)dJJ6S zd7?5~w=W7U>4}D!FwFWEri6wm-bZ4v@aWLGj}9w2^q&N>g9VapbQ(&cw37Ie*Igeg z0;%gF5dJt3NU;d`-glpK&*M30qXO`O``!(QfE3&T4LN0!c2FZjENA}3b+)X)GHq7H z>3IqOTddAcvF!jM_Wg-`63G{y!pi5XE^@oe9JlG{;Rq*3gjmF1Ph8~^SB1n?KO7dZ z3(t-bE)fv`>~wi=iVy&Zk0Qi9?{l4I7I@b~txHkt+XV;@!f7oH_hzPW*A6ng4y4Uy zCT6M=94{{N-QWmrEO3VY_j?_&Be1@cZ-tJ&5WVaOZRFL6WWQ= zMB3ZLBYFvREsKq8MnTC@8w+JP5?d#te7?sZ;@oG%4>AbJ;nF6Xs_OlwHnCO9=`jki1rebS8UR zEMyWg zGI@FWaIl_)Tq{6=#5bgjHVM}y2~Ka8s#tKN5qNOnen2Vy9RKLxz9GI9zP@%8&d}@* z<9);1J+Q>RkjK2u0^1g>(|HCJr~+kaevYjd?gMK0A!@G)fv)lb78N8)8^Yn-W8wfKGZ4Ur~(^zV-f?}bq*m?Un7Ssh9>s(f(_`t_6L{*3DR88Av zi=6fFKv%nFmqoe<*wQnk(5ft!XKRQN)_q6WK1mBUtKc`Yu~gUTiR&MW{JQD%VV1<+ zJy!@#r)9=mqlK^grfCfx?gS4Og6piJuwbbR!QnaqD#0rv^8N_TQL1bxi7?sQLSXLP zlYX)n2sHWkSOlqGzgyA%DOG$7RW7(rd2;1RCR-MlOFfqPEIX5Ir%`(_TPbFz8b=z~ zV5QOynnB=cG%wLe6l>yCHh1CxED=W{;b$`EWY%qQ^I&QYY@-&INTVZAmVfD zC=JxZF%ZK!UXD}MyMXiSX;s_KdN)w=?5Z)?W_}z+Li-WxNex~B_Cl*Io-|;~!DSRT zcOavg$x#goKM?k0m09q+EA+o1O_$JqBuNG(K sV8L^+_Yhtmup#tx{wvm|C+~}_-Cbt1>ky+o{_7JwcL9yOaP8VZ0TJ43(f|Me literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-STRING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-STRING.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..026dd6325d34419513d0f8817aef0377d0e20dde GIT binary patch literal 6038 zcmdrQZERat^}T01A5P-ft(&x_ACInGJGU=1N!O3GV|jjliQU-G&U??z0%OCmUuLJS zli5zYvaOUMI>8>@(rMw{eIO)$07JkwF|lp~OCUfM2!S*q(9k44q#=gb#E%ICsGM`J zoj4t95#tX?&p!8@d+xdCo_p>&=iVjGbDNS7mHCqk#gbJK=ND@Wi#2g}z9LrV7b`hS zoCUgguaeT$`(v^)F>qwiYqa#_Dps~;h5=R3*dI2sR_u6&?+AryiybS(6u4P+b&C}97~>~wQB)~7bY`f^+8CgsF> zsRz;R^^yx1-XDq%9YhL$2dp}>eL~RP_TT6+DQ@-zU+*0Aely5@d!8A+HY?=x+jNHL- z-C&+#Zgc%v{_99=c(7}+>A@XHo!W^1rA;8RF%nu{5B1v6T*-r5E1*M9Z7q39K|o(A ztw$WB|J!QyGqrGn7QGN{DCPDymFh(5)W*^fsKLI5T19U=r7$M})lip`yP;aJBvRFS z{`;yu)Kskp^g(5sKb)%BMu<4LeuXePyEEt*hu zDG~>YHg1H4PSPoKz^@H{9tfF%up*mEOwv^|qeIA3Xv}OgrVUd~3IcEhSx{9Hs;p(w z(pXAQ8ezf<{5waRsW9nsb&*b2H*~fe@uVUf>PisC@aghGaP@^%T~Fy!Dr2TIX4vHe z?(VRxO-q!H;$6K!^B6FzM*J>6iqq7oL|jt=4Pc)RYa0Y)T@x81e#iC?UKQfIz=Mbz z zVX-ng3$jdjazqX;q2K3F<6T8p&IboRk$k zCAG@j0Oa_G5+vJ=6Js3@sq zTGqk0f#UipWq19M_PbtS-~u?{db3chituGcuUI{Ea%R3Xz=oU$(LHkXSjI5rNCMS% zeH=)=aSZ|iY=oLnaifubAE?&FiWW(U$vV=`0B?7LM>40=RKU$ljlFFCEfffUCPOel zc#{kx_&pg!@I2_YuC*GH#`RPtO;r;!eej{G8)|lq$OF`F*NgJCS{_+!YJK+;T9me(TS0^pE2IVK!|~L478J*k;P30 z0Pufh;E&`WVy`mn7vvCPKVg3LBZ4u6|1RtM76V^q;0p{qMrHCBVL2VTDn}zwL(L1EPv-0LI&g1O&OQQWT?_FBUT zli2lhM!QUoAoc4nT*VE`e0O6NP@&HQ@%s@*Cv!2&l&M zL}jwJEeq}G$)=b9tok~lgr+FoMIx~As8IjAo0Z)9pBS>cHBeAf5~YJgSF~RLo-B}9 zV}aiHVu1v+fa`7N3FlF)gtjW+K5*l^sticLEl`&e2I&Gea)?FE*B$%DHEvIlsyMeu zUBD8ni!lY>Ge=&r{ubFs@p?6MmQM(o1+ zG04S&0=PTf;A{E_xQL7Ti1Vn+vD;XTbsB!_P(OCDyd6)b;qJ^BZn=q!Yy!`3GcplF zo#c3NnePKd@MwWD^xxe$Vm#%e$IG#ItRAY>*44+0XE*P5C6O{Rx=JtJ>qtWAB8rDZ zAuMl(TEvfe5pMHQslmnrvGew{smC(f#C|l^hw1K+$rjru96P+m_7$tPSSiCvEWp#n zVyOhj9UnAS?H{A|7v8ww1(CvU9D5h*^PVo&3Zf`_n_&u4Z#fSHvAU4WSyfCN!mpOO z;OJ-p>>bxFQYAd&OLK0qle^8VzNY^U_L?0ty7Mmf(Ccdqyl| zPgxkotvnT3Ugi%r-L?)@cQN*lpimF+{2GTnu?F+40|$nS%k@H&0GYGl!SDdnNkfPt zClbOiI9@x{4XSRac>CE#3ubr$N=WHcT!WL@xMiSIL-6N>-OGGv4&2yR*J18U1*&EI z(%h)89*1}MHNmnI2nI8#+jxYr0gsPIwnQ~YfA`0&BQdo(xDdp$#&Lmz3)1O2eF|iPvb4Cs_6tt}6?~4$^PsD%ynu;Cj-+%GJY@%&=_501 zoS&9qS?2Y$Oj26f`@nRB0cT~?(2flpxQRXvVfH7tv5a<<_Q zbhm3(S)^xR&3VEUE|%wO=p(HAhO%{a(ma*-fo>DqAULXPRXV9I#U9CK^HD zfiy2sOB8G3Og4Ao2y77sDSGtgXXdONZd#U}EdDdgya}P@-99fEEWmT^e?O^@#|O zp_-SY655^?iy1^c7ifdw+K2mkEw(AICfXHcya-@JO`%_ n9qeyx2(8h7%-Xd6eu}j>lo{;1mBD`Z+7Qn@jzYe6<;p(+C01>G literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-3-FORMAT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-3-FORMAT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e0b92d1b16ff0245b30caaab2c8bcc90343476bb GIT binary patch literal 23983 zcmdUX33yx8mA@9twq#k}?IaNLvXBJFaxB@76D1HUwwyRPRw^qb?4#I9Y@*mkc1S{q z3e;?^8rG%~YX{oWPRjsd28IF+dx2r=Fr7k63oW$JDKjub%al@v|L>ghp0+0k_&2k6Ry zE`PvxaD%t&ZEelA z9`8V(So>6+Hcv~d$JO3!`{bs>#>z2+!7ykzLWR{}s5F=jiEHAOjX~c)(Am@5=X3UZ zH~AV9S1017Xp3{pfG?1USGkqRv2kZ4d|o(0&DlL+Fd7VrtKy|STl%|#z5f2hwZ;pL z_QaL(^4@;uW;D&a-e)kCs#eIlF%h@9-Og70*W(Xt@&*kz9ab(j7-o4#4TgEAu}2RK zKX|h7{!!z;hfX$a?VeL*EFLCD%MAv#xb<$sUo(ktSvL7{ChyFqrp{&BsBuw7GIe?Z z^;CBuqO%aOz5wyU;q3n&gb&phmn=07-+#8_h~EMD-qn3q`W=rM3|9|d=69TIGNM6O z-_@|Shgw0OQiH*6FdP{f+>jjxlU)l#X@Oc(%b1wk;yR|~w3vLGIiJi`nom})Dq_yW z7M*ibA>yS>-2HJzGBvJ~`@hsNMK&!6<+^qt2-oR|shFNL!laz21V!pVR-o4ENsUYz zEy~LORIN@dJ0)i_0g67*+FmAgmS(&~+b_})Q@iw}Q<${-PZ`yemr0}Mx3g%H;kh(5 z!?WeGn>uruZh1{>s9hRRp7AWx&@7_X&}@?0&<`@IT0@t-kVR7)nnP0?noawkX{a@< zHPj{z%^A|>;|dW=n3$csx87}fuYjcK6(;6S*QSRHlW#9fK2(^zhs^jgElT9YF^1z)%EY13V`G7FDf;delm=VAEW#MUGBh$&*XS+W)tQ>Df+ z=W&dG&^Sf;oR>9@C7<)4#wpI{d_&`uI7m( z6mnx=_>-n%%jdkRaUA&^>0Q{W$me`h)2Yno$O0ZI${H3?7T*1r42iq*TEFA28XYUO zPE2PTkR?1)6e+^;N=bo*HziAWE-`y#eV*%?n{KRs)<&U2+EKDA%V%lGu5+?TvsjE8 z6)DM($@!Ucs_bsfsfu)Mna;TNZsVrH`!UkR;l`nyg!0VG&@Csz|LPC4WQht zqkK7+lG>Yx!+Cfh4}0_Q@`x!@V`^SDx@olNpEA5c!I`+a zVUrNfVDKK*f>)CpywtYbu%!65E-O>o^7spKao+gLbp6cvUb#~9UDo-`4fQQNOJ(p( zt{#<-Xtl~-Hd9M#QC_urH)hh2st(N&S^G1N=sO6I^GjCDOy{Id%*&FL z-1=rDwAoYc4>I%__V5MG!#V5_4PW|1O0t7>_EC6pbDP$)K(jc#1gGZbYFZ)=@JrHs znGj|!5o+(ynsW@gmYhQ1Xm^l0KkbN`m(QlcdeUY+X*HAJw?o}xJ)2s5jyeNAo0`2# zySzTqpj}FyBlo&dCh1BTUE|hC;|5g+j^JiCC(t^yS zLPSY%xJ&Z|PbLww4dTPlZb(KaW z{nW`UhhEOglXi^;a;CbJ3_;N3|Ns9Uzh?NZ`a;L$R}WW?R2oe46JLuT+t}sr@9qua zVT5yox4*m37jUlY1*L!eK%+@XT21rtIS!8~Y>k@(z5PLFpYIf3U!!R*NRBkAe|>O6 zqv=?P9)r&ud}iY_3!esj>hY<=rxu?Ye5&!O!lx3S3Va;+*zmFAQ-)7DK3056@hQf~ zf`=_tja}Yg*9K?67u*uS!;&t3+EP4l>Oj!9$z;?^1pSRkn|VRfYF@~$`T_xe!0F!- z+`J{&XkG*bd!x7iR43C18k2a^QtfWfe`2%1Y%nB?=s67@x)}eKp1icfT(LZiA?T*6 zyS4-ZJ_INIEGTIt-hA+CGXd`M4)~{m=zc-BNpVPu^Q9OTk&vLEpiP3jf;@s6q^M2SQ4K}OdKC3PW|8`5 zm{1-S$*5u^yJ7gWKh>K!S5$HuB&VPjQ) z%OX{`BPNx>Q#bpZU47nx4eFqojRsX67Ktm9#}e9~Jcf#(*!qIl@`^2~u1c-W%zBl7 zVadw(1pQ9X6H+|N>Xj*0uas`Bly0ruFA7nS^h?nv3Ts56N<_+qXJl0IXGRrLUxn0H z@uUzRWA%!ASiR!QqVOf*oiAuY&}Jz%iNcAZU>6aZ9cyJia(4Us`n-VwXHTEs8%$EX z9MZdv50Y~U{Tu5zek~G=JmdQU%-pp z%hc==smA1SRP%g6a|B7O9OaB`e`cQTeL?>!=nX+X6ZDdxrvyDB=w3m03i_s?n*?1W z=qrLQ;MUl-avW_zZjG&*TVoSnY~^T8g&IfSw$1*2Oz0d!ySQh6KRFK#v5R~5Hw1}$ z_Ll_7aIrrqNG1*Y_XXX?4%u%MbhV%_3p&8=*-v5j>;vqcy^Gzmmx?4Uady?cOpwdO zx3c$>^j1LGJ1krF8$rJm^ix643;L0u9}2opkPN%B+XdY$ysrz23%W$m`GO_{4YA*4 zYuWFzHSBj;6Z>8MdzLJJlX>MY33^u01A_iekVK~ZMnPW@-jtwo1hyK??*`3o2t|{fLqE4}#tl^b0|f_Es5_R!J%Aox;0Zic7d*);-)X>qb%U5?-sI zCP9jz*^Elxm*PEEFMXZWOD|%P(({EUi({!Qj-}GRQfXglw@98SlG46XX?%a*M3x7Fo+JGAu2!idiJtEwYGOBm@=-fn~QCJBNGBavJxTMOHD3tYVfLsn*Vt zMV~M#`ja5Z`69{rB5|TfoG5xiB!4K9vY9H9%~X*jd(lN)ZPB@0ZP7`h&>;$qf))yr z?k|$=FETOD{1Nla5(%?J!u+c6ej>ad33^!24N@eyTJz;xt$9F1`h+KA%q(Nf+$6l? zg*RJJwIJyZlXQpaedd|oVV>!AL9Yn=KAD_? z7K`32K~;jxjEu6%8)els%BpMpx$yp(C5=xCIwI(LDZb857%yWdjAw|*7U9XFXY>k^ z#577`8jFQ!W_82+tZtAg)^H#54BusAhFb+)C+MrmS`0c2xO0*XgUQ-ck`35dAmj)) zhC7D(`Iyyb)#Eh&PCl%V9eOXrs`g#>veMdEM0r$ zx{np>xC7m&#`OfD~(4q-KTimT*x$&cy1Sg0^u{^*j@+o)C1e6t^MjWdj@h0o>Nn zrUu?teFL5?45SI#?%|*p`m{@U(psS>C3-JU&bGUFkB>TFQ6z8#s zW4G|m;=*>JY?k&&v5G}(EyA16h5d`NVVRU-C5zaX3s2#qY*_XNXG$@jMapIg&&oyl zFAxuF*9LFE+ZE&pl|PYeL2SzJkm74n9F$^^3+p*-$r@r4)&Li!KVf3&vw|MtqIeW{ zMA}|S8#l$5{f~7}L2Ny*eyN7?~{o4Qd$M_tU~$P@MLlY6%T?dboqvHBBzA=ZP*R&4UbOlcTNsR z!(k;dHW7|aG?U0JiFmO?DB`;h_i+S|P-Fi5n8vn$Y3Lbp?FhAZ}aJr)qrY z)7OhM_x24WZ6t=-{0m$BK_6#CLnXqf_We0~CMHLAj0}b*N5)3Uygk{5qW-x=yj)Qb zeePGHJei0)Vy+fX=Nh5Ls5k2$f}AF$&<#QTy?B2Za=BvPXLFiC68n~jd2+1XpcA_e z9RX`OQs}XAa!qoMjD0B)uT1+ETMeJZyZvmBL`jw;qsT9kB!gLk!w_V#v|vb@nzhNOZ!ZtnoIvPEyvaYjWeetEu%Q z>i)VvkgdgLx_pl=mze1C9lBgfM|yQ{C*pNtA?E2kpkPon#Rg7_9c1laewz8G(ATQA zPWgwQrhH%GTC+GJp3%3sdQZlzC*P;K2VSImDs0bh4=Hm)p~>;tFrWzojozCPIm zT#<;+%C{FgpkR)YfJSvaTsN4A&sBREbL7wn4V6&D8QwP@4NpwSxT!l^x_eO~uJlfZ zccZ(JPfe6|^mSU35*i&+6xxiiw-|!mA{SeDx-yFSB(|EIpf481watouiW2jzj&&Y@ z7?@-vb|wj))f77zJCkh{C*pH-b#is6m?Ucdm^_b)-y_T!K{f{eSmKu=@z05PSw@06 z&j{yX3`CVf-ZJZcVcm%z9w_+r!|0?E36Jia99B+L+Nr*8CgM)az-b=+D&a&-h?tPG zsHz5$N$GGRZrKrvOoRy>qTzZv!`NypPGOO`1a59dHjIQu6--?uc|jt6TRH+F}{>0MouFs^k9o4CpHAPJEpP{-gT{6|SCF1p3GKD61)jf|| z!n1E}3ujTye<0(smmhU;QHH{k;X(ZHgrZ;bTlA)XG%UPa*3U6zoEDCb71Vn%5ii-+ zdy2Aegp#7>2{bO&8Bk(aECakm)?iX!8{E)4pkPfo#TN(;D0l)BI92KMZ}kOeby3nA zDJAGvwrt+)3n;mCvW%5rZE$#GLcyp(8z(0e{4NDUwr^~2I68>ND}xxrAv7q8hak$H z@o`+_(#cE;eTJEDY0N9${Y@giNX&-DM_k1a|-qt+9HJ+EQ&0WjH?Mq#?8h8xMs)Ln9_cd;-VcuO<4kWaARY1S%PM)iFq+{ zY0a-OV?Pq>Tnh+P{b3?*)igVZ@Na3w>fhxkR{thP5lNb>_+y&Exl)UR3}FwFRc-at zm>6POtw-{e{~l|Ts!Y0f=jz^(t$SD(pX$rdd^J9kq3vYgOB|Q#J|tgAwxUe-5stMs zt?Udk#&EW(e1!?lJb{H6r6jPOjSPw@g_5)SSnM2N3zlN-ox#CaM`w`f)kG(aL1jom zMk_m&VUkCWD3B*{k`4~VRt3W`mn*m<=4uV@#D+Uaa#erOwXX`1*LHl9Baxx7b2Pj+ zGBQeYY}K#0rBxVKJ8^5NM8oIqL4r&uBN(t)Zg=k4jSV*q(CuMmY=<(re>|+v4QZ2N z+m2t&jbOBeFvgMiSd{mUVEV_boYvDcvTkc>_Nuxj5s%RAX>NTJVOn7`+PSr=x3{0K zV!1`;I`! z8}ryeGffCpXXq0GPTRGFr-UG}UP%O`pF@5TIia*Fu~>|zvMMVUd5wx&npkTL6Au`b zpI{@eG29R*>B zjE`ZbI)Ey>r8=8t!A6hTE3qrns#^?P@o^5j0ujn#BQW9(DOX^;it91feO~8H1t!4R zsy7(R>`P7%Djs03DlSdLmvJj?Hg)dFDS~78{i=dBdK1Q7Xg>{;iZ5beQUi5-%-s?! zBy(OO-Y8~s%&DM|#u)CK#p<+1x9OYNo7sC0jYT4%=!A1eWDGZ1qdT4BW7u+%!#-(h zX(GPdTtAbAN7Irr2NK+?S5-M0|0YIM;dnxlRyxZ;U#(G|x15=HZdU3D*7 z*5c9>TiQHnE{PXU`MOU%7gsh+0jeUr$ye-KmR1Cp#NSOTV(0%kYP7wUR{WPNMK{`m zu+oUlzET@PZM3~G)pb)X9q8E}XGJKGJc&2AX^PsF%A_+O+e1^{j|Lv2D{S83Dj5|; z^qH!dzEYX2_`Rvl-ijAV@f)m2!6!xT1Xj#kDJqi{lT#;s;}u$ZY`A6Ag5z|nQFS7g ztmt#1W7O_&avLw3I?-^)A4zfF%ng#|u~kj(CRY;%#(EE~TY*}emaGL~QJR2Zb36n0 zdKxjdvvniJwi$;X>LicT2HbX!PL32BHMTw;H8!N;(#)vApCQ0Bh+)(2S%wQ2hRrIE z;%aua;EJ-}Ry=iJ;AeCSZbvR2MH3mQYO3SL{%%?m$yh+s<<{zStEO9?_&;Q8hI- zXM$cOQ$E#~It;)ib5{)lIA}&%CH)$wXFsV=xmmcQei)3*! z`k7^ah7F5?DPsjz4rPTDjG9;AUk9cK`69G}?qkbdy3|CcvSrV3$HNuO98MI-Eh^CQ z?XsSpwnZuVPeb3ZtRqt;;f7ouD>b|~{I;`w^ zxa-2!AQN&GDO`F~#0AM;JGJg918ZJRA>s^I(_2kwAWYV7DdgMLzKV1&(sI1)ymXGs z>VVaSQ`$qSm;$JfYtbCja=h%X4jZcEri?Zxo%AmH=ii;!)ZNMA*or21kB7c7{Vr)# zFOlYSg%5LkxVh_fnO(LrbC#cdLs8bo>0JI6`jd}@uwTX@sFTk;u@lWY$I9GSm%o09 zw({lJkKIl>rOSXrxf~9pVBvjYpAE%p>}u_4GoR#gNf3&xk04|@m!=A|L8~o$ADvzAtgGt8&{)yc5lb=ejC+S8pSyd zS`(N~D%Qy zq&?9KbmG)?_sHm;3H(8=JyEG_Fr=63z=Oq@>P#U%#^}P)@J<|EoQE^rqnbh|9n}=N zYtGRvSdVU@1cyz6p@m55p`r)nn%|YO3bx_pA?q7k+0gGQN^e% zsM;>77?`=Wwq;Zwm`1ftRPW4JZOy3u^)#xjqWU$=TRCk-yC<+2;>KdtDd@3VbPwd~ zx>%RbS4yzD6x4NzZYW>3g>~IrFH*ChZj0!y&ui`~R&8Zf%m?)a`e&7B;`}2g#w%Hq zhh53M!kQ~ZvnEfogEiZ^PD^3U4%RIGFi(?{Nlv?p@yxl9w~|c7ujOfSF1g)QXYr2< zYf3H^Kar=&snp7yT8y1fp*kg%iociFFPup($%o>b3ad&g6=NGypPfpQNwk$Fhrd)< zS5m2X;IMg7=lvV-=ZpsM2lI0NmdcUg4fJP`@Z-B`{7BA(-=EQ|_cgh{KkEtjH_`9Q z%t;LHWAHqC5VKmL=Z0pZ!H5?&OS<~}16u+Tg24_liG(3R$sjO`e)cV*_~udlR?!K zp8Czstu5Cv%SW1H7Hm?mgDGssf<$e|WxCKbx7s|*n`tZ9oD{GkL&1Uxj!_hcsszxia@fy&j5&2V^MXb3yu-MqW8Z0F5@1t=R?&S+$5Irhmz*v7 zrM|*8Q9{pS-vt1Epg=xCY&yk{CXs$CEU2Jf4-6mSt+T@L9 z?lr}wRa>eH7={t+n*UqJQk*iaoByb?%c$0kJA_o7)>sPEyqOY_{Wi#qyVbg>HL zccW9wl$i`J_;7W$rdgr=9Kt?Ea*E>=}=E1KW;QqAqU zzBeUs^QKO?naS349e2J7JIX?nZSG=d!VfrPl{VpIVwyDIn=jKzpT0z!I%S>(xA$7NlJ|ZdxO?M_rsvIA~K_g}qUJXLqn4#!qw{b!9f<$T=@}@KTN_;Z8Tt z937Bilo;R8abm5a^HUv%jzUT2c^ya7c~m!}i^l!>?2t-s)n$kAS~Nq=j)B~lQ;k=0 ziWs*cihW~ayOfZ;E2rL*yH~mAlY9Nxp%h@p2AGQ{vQ^pK2wos#29}G8Y=$b2^&zLS z1>s0|d^j{Zxq!8h7Nr`6D#xa=kQIlnod$HIwsM6g21iDqZTN^AXuw38Q|D5xh7+hx z!#%lm8tz1YWP83e=JAT;xAF`rie`xo-JFCuQwiC;KFby{7MSQxa1%x{+_;Ak>m1-)s;+k_aj~p!f z>o;bVZ4;6to#%h$lC*K7OvmdasY+7h>?<>sUBQsw7x8;z{?1U?r%2i7W~%l_W8VHw zZ=}-`>>n76?a$6swWw1Q7d`33*XLx?q3IA0c? zoH$rV1MS50qXfr#E3xDf{3QFblAYPq(&hnCJog_lD029fnSHCJxb%AV#hJ?1wvNGI zsMF&ej0M7x>l{k|aK{QzdEJFld=aO{17`2Ex&pqYPlWy#qkA zvjR75Fm4K1VxDjpqu%fB^LwHX^>u_pTCEdT?Oyh(0dFiomq)c)JdK740K_l}60LSt z+G-t{*k_nEwZQnC)mnX(wv&do#ki3%v}g>}?Zb$)2K`yp#wDHpp`g$2p)2W;4|L!; z-u05iTOw?kYq^6Ye_bL;xE!E0;bMmlnnMQ-+#(*3ohgs_ql2NCC-%^Q-*vB6-->}& zwYD*@cKiGN5pOIU(P~w#xms&>Yt53=12Rn|#x71>zL?mD8w`)7rxKZ|lbPwW+wF&y z*_jgk+dE^+jZuHh(;4;+_WAo`UQ!oe(C2a@CTmUL$eA5yr&H+>HLj*p8KH%yk_mM< znHU~TOfn6(7Qofx4S^eGrKWZ-Iv*b{)xEClmbrhUSQGiA=A7JM!=iOTU9<6z+ z)?5k}Qg&r$Dhw8CY29RDs3L&y5)gZBtS~j95^Jg#<5S7;_*lX-lA25mPfbi-W?1S> zu3)umz+y1Q-R<5Ea0bY~!j52$zLkY62aBsotKY48w`txg&0C^*oekR2E!wd%?YL7r zQ4AaO(d?UYY+zvlw#!Q;!qjRc=_Cf#?ZRq+&T|1+!^HrU$B=B(xF*9Yq;*}sP&n!@ z)!d3pD^ax4Vun9N!(VR@kGuz_&_;tor0PwceFkV}J6=q_(M&vw0n?!nRX~W!=(4X`M2C*QY*)aS?T6`{ zK7QEp!$ENsflku$1zk8t5|5{b6L2#O9qzS#ai8s|(Q?0r>`Ylal{q_oaBN~EG1f)` zZavY`T7;B8N{r$$7=;!7rPNeXy_8H1C*hGT5%}bUt^#ZFIOz_=d>Rnv+tPxh6@vcg zHto?W?a>nL(KQqFX#!v+eXljlO2iA#CN6yPaw6^iWOg*|h6A;j7`-`i;nu&mrj_`d z*xjFY#OKBCuCz10Aa=K>UGW>EH*slo+8uxUpVO|nEr3!|6(Iq?`Q&k3SL- z-XsigH0JM<mi(tJ5LjKfbVrqJFT(}w&=SD^znQFNW{l(M_rj-7{}2@OnSN#9@vhK_R(b0Tjr){ zbd>!eK7hUPU9ZL|vK!)i;P!OVc9D6&ewZ1tlIXsLKbLMZT!zh<(anK1W<|_V$g?Vq zYV`wJ^C_+QuvYKUn(MXtI<2`3ev_-$7JPK&{F?`IyL)gAEXRQG*fzs8<)dJvrPb5g zR)h`Vxe--%3sYePt*|7z%{T|Mkx(hPmR=W3F)LjVJnkY>?y{KjJvmcepEKoKg(<&q z>tD%`erpIW9xN3lMU1sn|X)fIp2+$Se z{mZA;#EA3shyb024@tqHO3|Upj^s$HwQe0!-~$e%@kPM)#Yx-I(!`Y| zM%iI`%!W0LRv293wnK#@bHpnnlc~oOa3hhXu*K*sh~J%+*0n=E@lO}c?*dIr4z!H) zk|}M93$j+u0x0ac!gtByH@BY_HWExUhwsuH?mnLoV`O20#)_+OrpT70#xW7`L{5d< zV|Q}i&Di}e%3umc^p=%~9H!+kr-MGlWAk~EwFbDwlC^X+X!SdUZb!P^mXCzqG8lu0 zWCnrekc=R3l}SLt;xG8iPXzM7L>iDT`g98;|7oSzxW&e~T{~K>9V^$4J1E;j+2zfK z@)+_*qKJk}pc=deP$a0f0}~|KQE)6abhc~twOVsIrQNDmMyIyWPz-?9li|RFO-__? zVC6(s(n_gT@1nWN4q4HTiz$}1w)p~nU$3XnAL-^?Q?0kd2URr}_z@C0?UZezDJ2Dq z%auqv897GSez*U@0Te|bl{Q`{TU3h5iWk}IXm)0UzU$F(bZmksR7Zn-11P#6<%;a9 z$Nz;vZ)gLPB1?JX4Ll%IdZO~W;&N~_?@E%C!<>6o&rZOy#LW;<7?Q{1>FI=;%Bb;- znt0+O(vgXggUkw>Y&e;WuzOsR8Xj!lEO|F8zRk`>IwYOGSqf}cI&!>FXMqi=*=1mZ zD`OxzEyZ$l`q^kKvgG?el=B|);%&1iv$My zd+#YqdC7G|k_X1(qX{)LJ(*Aw@nK|&;9#l4@p1KRLLEy?p4Y8^Je_7W49X#aP8VgE zHYm(kc$jH}3el`&5~rg8alAR=99V`pr5(X;zS}D3!jSFC5d)M^EX1f^i5O9$2H)VW zLWHPeLh$!{#bx`7!~DP+U~cM-0dFMAdSiVKUSDFv`^i))3i#|7r8EDZ5XcbOXVXNBV|{@>B_g#pc+WiZPB|+KKJjiJIb>aDcGAGg|~-z>2ZQ49y7b zxCk2O^ngD=4vIVv{~$ni35IY_2!SAr zeYzj;2!3O6b=kovrD(Fe(;xE31j<7U=s=j^eeWLn))(&gp;X_Gzn%PTe52Oj)Q+)Y zlYZ*%=4*fEs5B!=8`NYooQ#j3M;4QUR4QktbSt%# zYRpsQ>;4U?mM%y&LRUVsgjjqsUObHqAKylwiX44R+QiSU9c|J?o3?z~fIs46L>r3c zI8vhYL40I{&v9A@Za*Rsn|ujJmB=)>oN$=}#ZpEBMPf#7xh_zY)?r!09d7gldm&J7 z_mV(`bb)%3llm3&yMis{lmQZ`2pVi0z%_P zv`s?OmSg|BOo7>nNIXZ7Z6qvfM~Wwj6pi_$xG;^NT1P&vr__Kwtgl6Zn0|IsJIY*? zB?~Oz;E-Q$q#`b=ZpZNF0^~Z(b2UGx^T5{>o0}wx zaWmy2#v1a52K^59jpS>k0xBw+={MG)Qn(STxVe3e=GJVa;4(1tW(JhRMfV4$r;^Zi zmnJ4hh2=-nf|#h$ilu_p=V+?)X%}&NFn|+efXK2h_ULo|I;{CpzIWFVg zkbtJwk;s`slamj%k0QWkRRArq`~iRhOgc#4#ypIu`!hOwIAiN-26E`D63FF^VxLyu zr0uNL8q1Lbbg0=G7X?$DNI~#U2U0V<6E9LozD?k@@lGeV@?TEu@LVUYb0G>xTXik|v~Um&sH1cBourM4F|x z-RA`;%b>FWbPO)a)orRw_t6AsL+%t~WGO8;HVL?>s*n04!<8F@#|oHJL&pJRGFLh% z7O@3FtnuP>1}OqCONQzK+(Q;0o}9>J5Sxr&R;j2jFheC@XCXUg26;alu^+D`Vhr4y zj0*4muvj>Le0y*pO(Nj%_lF0&1Exl5U?tQ^P761eL9+aLlJ!22aO>`gQE`F;v3$J= z-nqqYIkyS6+02`FiF;7E>_d7mI1oZAOK-L<)f(k0e8)hL1F(v^K zx7c=sV*%ok$AE~JG&YHrWuKxd<2<>0#{P|VZ!&;1+;t?b>1RROhu%u|VCPkFt{1y{ zTr1p`-@Li8*HrAXD&A2!mfTCH#xKk^Egmt3jU-pf?@*u$In zF0rW*n{{I2Y|@TxquxhEX2;wEs4IIeH+hJiRpC+guW9^440l8=tHK&?0q9&0I5 zGyaz7cAwE0s*X$~GUI!ZY@lKcJgrO$%{$ZM=;Fz!mnWvh`4pOqQR%$hB z-W|l+wga{xFs~pQ<+|-gR;+rGGD-p1s@8&!qfGyP-Koh#4BQooBj@({@%&yaTT>=5%iIBg<_cSt}+zm z#?uxD%QTl<)iyHaZN&cgqyBs!{yOpJ$6puzx+}{-rovSMWe>94rMi!?&Qc`P<6zU- z$T^fSN2GzVp+p+Are0vQ)gK+g&eiNEE|Ibgym_y*Q9H2>B`~v0Swr1p*(($9w}sS+(x_qe4d-cAZbD?) z>5sA}*VSFwUDds*dov|~=i39p?k#XR77%tj9AF<~rW%(cl=~dAv|fjP{T)H??&QWA zs{48judp1uhU-nvBI`@u5#-9N3o~ux16wda6qsUxh~LkPpHR*#Wf|`R1&ibI`v~_| z5p@}`o0&kpzbIoAAE}Q5Aq9Cl9F%S=Kmike=>hL3;cq(9^IfAR5nx9bsKRlhJ=n{X zc)KS6F9c_d44~2jLjB*i$l!|s=% zcT`>@=IbPeHv*Zw6oK*xtWSRPqTRc*xOK}|W2cd!BCeF*ePJ9QYA`mgF){SJRuh;Wu4Sg=L-c))N7CckH zg1c&=smfd1M4=X|T(#P2p}WKxEKH8TJFCPwq({ZM9yCoro#7Pf4C2&~Hxi^}#H{Ot zdB;e_cOBkn(6R zuI(--8|Yt4a_Ov8nrcUNnEP3ptSuDF4r~dLsGkM>PE@WfQWBpc{8sNFBWJ4(#VuolA(&$&p>ns0KP??nT4a^Xlk2r)jbNa$MJ6NIo1=)MN+JUYzyE}!5 z>Q2AOXj@23Ifp))7sX%4Nb=%1Va~3Vi^mBlE6}O*45HE_;$h~bPX}WG54~T4CS68P zGD1b60cdf>(g!FM3&L8MzxDLtl^y&p24O95_uO}DWij5mZRtf!%8657$nWhR9H1GN z(+n5sLpP&~_W6}_->C4R6~T*V6z$=n`EZfd^>BJ31OB60foO)N&}vD!2?@jIS?Ltj z>TkWu0aO=x@Kv9E!g8^M7G6mz(Ico*r1LCI&f z=xF55WbWC$b9b_t5V;pUloOYL27ri9V&%j*-bHXOKAbp!m&0(>!*zMc>SZ;47O#%U z#XfLgn7DZDgCK32SoosQ!WViQ2(4kgaO*p??B!X2$)#Ux#Xs&t(plgG*}j6sc=H8C z?JS>;Lzl0+n19Re2JJ4SFF0IK7D*qKGo~Vw!-_-s0F0!+ zfyK!E6pi?YcY-)i?pJ#Oyb=r()_elXQSO`vNg;lC2N3U?mDok6>I=D=i)mK@talZ_ z+PRfSy~rV%^1BK^?ixVDd5aFV?1pM}1^l55At@io)Y@8R^U(B1%YT}cnv-+w=yeIc5PUYd5U7$D zdIEKGlsnKjVlSx7(;99dD*wseLP7F?SJ$vPbEtHM^v8PMWW~aVqL-Y=e9n$p#a6VR*NQifL^7=>!mB|3jynU(f{y(ng3fq}V1)~H61AlxR+<8{e^~`T7ICH3k=jLN=`Mx&I)M+O_;ZpC~lYCYJJ=-9m<0q2&g;Lk!f#sfN!cx^09{ z&PpC~%`i&*!>II^%iz>}AX$gaLa+y%c!M}$u~#?WPud&o*taQRa?59UjIvKq{U(=` zrEHbEq%!{is z94{7lhRtv|>bbjK`MrLBnb(Xde=r{N{HzorAWi#3fN|3`&|9Q~g}?;^$hR5IVA^%- z`j(z_#jV$SQ@3VAqzrCZI|7vFk;hyb36ye`Sy|i*d0I!WpYu=_fKhi~p&gKQ)C-IE zdtOVmbl^%g!}14x{Brx(0y>%G5`ul*ev#h;qha z&Kvjy>pTJ-^qJDR;5g=F$sXo$L5IJKBVe?Bq6@>@g;ySN!y%CnN2W=dq; zl~2|jG)!Il9i6`tbcMB zvwTTeR|^>1EpD&X?qRc7De8zn6a~ajnO<_Sbuq^y!* z4p>$y>FQbpYdW*OyGph7u3c@}msu17SzbYD?aAZr9D0_X;^hpTP+&yyHC15m5{&n( z2qPC{dDYhvEJ11{Y?;%H&L}YvV(|$JE1$6J-!8k)iQfj8?fG*aS%WHGx!*xvCW(Vy zzjR!M=eAmbs7MKcIHw&uE%v?uzIO2%eINF)ELW5Sjh0hdUYTP7k}Z;&+!-P#$;>A6 zhoYhCp@qsC*(7MN^jiep-Nb*%;KO@i~}if}F? zSXN9SVyJrv5i{#^Bwl*`hH@$1rBd)Jrn<`TV(D^p76iNtwdl3Kj#p{^JA^f*7fP9( z&M>T43zwpI7co=U_X}rN5V0@i-z-$ z(m%o4ai=Ew?DdzMxVl^JJ<=v~dx<=RAvVoQmAEY?lnb9Ked$De+%tWV-<6aB=|#qw z?((!;p*<|qoBv(jj&LLfdwPgRzE`x!8DW!<-39Rq#8(7-G;V28j6OM!)E6eR(9T`< zv?_#_-<#=Rb5Z`=y;i)PjJMk!NG`#9J|u90;lEyY0n@tmO}cFm$1l@zV_Sl0p+JIZ z9Vj7vRnUWWzf8N1XCLP?HR6?%*-p*<0H288MH}f_t#(Z0`hM#0(i!FBlUnIstktJ) zzl4SNf#3+Tws;{5#=uCJyUHRBkm>4PH0eq=anO3TLNvTb;oO$;JA;(+R(^yu!~}IR zLERh=^L^eaL`DAQKP2fMv0??w(=BVD@d^R?3YJA1FQ#>zq08mH5wQ`2qPMWDqrnrd z2+{KXqZ9bb`0qHl;JuXU{~d=YBD?HM4y~Hr)Zq&cJQN9b2V&Wm@Z$Q74<;rjp1^;* aWAfqzUSx+(K0LPMN7AbV$1nf-*Z&0wzs*bl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-BREAK.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-BREAK.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..19d14e50c6539ee60be4936844fbfbda5c721704 GIT binary patch literal 1632 zcma)6&u<%55PoYXj_oAIj?w~2T5pR=(ZVxvNKr9T)%E&0Hd*hQ{XvKjLXN$O4Yt?v z4^XHGRW4jsDkc!^E9wP_1GgSqQDjA&kT`PSfW(mt2jCwF^VW8V0#b=&W#_$l-+VLQ z%=FRZo07~+cB56RTW#L%bz8kIziqeqj@@gQEq)u$`CF2zk&kksw4Qi18P-qTl-pLR zYgKroXLTy2-52=eE4S`jK6?J)t_SiS8spV^_<&{ME_}(EG zwGl#PG+_Ti2t|<}xt}>v!63SUvw4|dMJy1(?YmA8a>1rfG}no(@Ljuw>(={Lou$+0 zAPyn-Qzw`;70Jk}ihID_=4RYG&TL-6MMzCtBghvVp)hpLb!JyqaT2FBBCex*hrxZ| z@K-GAV_d$iK3eAQ_HeBkMj6(E9hE-k4_q>=#661|VzY^Mm_uvx6~@KgT?R z00V{k-{4RFCpdt-wg51LYLr#w3uj4?R3(#VrNcQ<$;d>*={%e$Yr5bI(2#EubcqR) zXh=D%5yRA=u97EAK;P62QtKSV?RSOBXBSzeONdH`JIGP9}x*_)Fju_M}p?Sqyba z()e=#buuPbz#%HBg#t*9GkLwpP(8XJz z@~My=tJ`aR;5vy^nt+yMIPKmFW0Zy@#?klm5ub$Q9t0rv)F?F?re#|kaio^ZNutxN;?)`>+rBXn{21nw)qm@*==mub-r5a@J%}$^8Q+FyJfYzyL_|M z0Kc-`Xq1{2LAY>;F5W!y{lIq5)d#tL?RNFx-CV@mpf_QWJccMNNX{D-m=@RZON9)# wKre6sin()4(yBEM#X}u|Xs_9}%JxpP_Muftpb1Y;`YfnLuhK$_l>5plNj#SH}LQ-?wAGEYgMQkNe zC8;=BTQvxZ1qcXaYEXkWMSwnbPiu=ltXMX0*oHmsr7s({_dOO^9|{zOdk!hbuDc}} zCWtsZ=bn4+Ip6)xz3h_y)7c`;+KrY~HyvuXy;j?!RokJi-F7M_t%9AtkyTXbt-P3B z%AA-U()Ns09Mka3b*i^bcilKYMW=s4#g=2$;pNFEL7kp^d}eNTHZ!y+YQ-qpZRgC+ z{pj(z>6y&X_VrCJWfMXwWD7-tkQ9lN;9Wn(>yoAmi-n>j$l|iZ2i?FQgj$5MCaHlx zHbXtTCDhHcW*y6ExP&7l_=P{XSeCPTL6L*2+y!npxZ;l#WT6D5i6qLS;IBNqwb{yvt9VKTp|-B{v2Ym#66b}6=UAU(znoFN1UMhMx0*PfP) zwEuCyx&hPgzIfLdSNrVc(Jf^Z)GxZlE6V5}3F+1@DWgj<4i@TulwLWAvGExsWEfVn zD(S6{IUX&&9J!&L90wr|pm@j8@BNR__l9olgifFpVs~p7?mYY3$N$?-{E;Yi1mfE6 z>xJ6?Sqp@EE)8jK)lwuj61?Xh=Cg{NDY9^(;Jvqedi%Ozn^QI|EIaWU@uvvq}M$#{|_ z;z-OI*?SEiRX!4`*)nAa)OW zy~z%tc!7)T-MUs2RtDKejD z$I$#VJBng9nmQQ@^3TvnK996NN8)$5M-eV>v!iDjJ;UhpV7qy6t*}Eyc1UCoJ_Ac7 zmt^?o1tLlx6;Y)9}+*Ar&Ycq8zS>Y&kM9q|~g8gRm| zQ>z&r&S>jQqFW_+Ke&nnzCWur`3MrKnDQ-@4Nnu*4oh zaVWSN=VEbujfYFH;}C#79D(uW?o9KX<$BM8ANeAjNk06(`z9Rqdkb_;uie5a?*@Km zZb1UFOVRlsUTO$JRQ6829j%8z=B2>T(?XMaHOr;uIit~no6n$i+ip>?v|T{Sv#Hs1 z+l~odh6ke>QDe0Y7~$vBS}K?&dRekj4<8rk~jA9$U? z9mJn1OX{jnQ24-4*Nw*7x`A7=zq#QO#cY^OFN~5QxxjDmypGVpzhYn*x^^C5GO24; z?B+V{ZPQI;!Q{YhIZd|*piZqSwY)G(+Atey_(4()Lxc$nSPR_gzzUv!Vv`KdBbtZ1 zRtk>pTf+ui+Xow1V!_n`HUR{WVGo1k#8C8yJ;e^PV~A|Apy}k1z(-R3e78ivaikIbhJgv4Jz|HAR z1L8Tr1*eEzj<{0<1=$phQqzea8n zF^@!?f3+S53FccP2Omv)k%N0g8^{4H16p}OlTJOw9uQCyOC?Fp@$3`@0)iols0l?$ zKB?zP|BnNIRkv;0z~astb@*09a(A>7oyktG%0z+!9*zku2S_^R>ut+Hr1p-l0X`j- zZXnifyVa^gr)3@s{Nsf)O&e^$x}ESw74QlHu38TCd>A@22}chAbTIH=!F;OFAOAI- z#I3VQ^pfe!y@2_2PHY%%=cV1W#^I0^UANtc8p~>)*;xwf`7%Q6rQyc$959qgtW*8oNc92v@ixIDJn*)x>=87ll88|3iXyAx0%wjKI3RIENL=6)-mIN83P{D$%JXL4y!XBD zd-Dcp@=ZzRCA-yWG%bg>`@K%T$8XsV-?jTr)#A5cpT8xk8u_3gO6%#@GEx21N!76` zJ*&nWeXCom?7YZlUggD((`drt>Qyi^*(*!gm6dcfFY59r+GFpmWM96LU0zN{kM16D zaT_62MML%%K`4%b$os^N3kJ~*oG;1*D`JTV-oSIiPzyG7qIvGz65q2sxM{s>HCZ{W zF5(dKK6b--Q<03Ks(Aa{ZEnW9|nvj`1gIku)p)~SPs{`CbkY&-y;`Ms$p zxcdFKV?#9t<{tz3jvD(Op+Ws4HMSn$All$Cv9Z7curG|z41{b{&kql4Y~vWmU&lDY z5C(`EXZ+tep8C%m5bO0ML>t!QjGWKhX9P)Aaz(}SS4`TB(PP2C`+Kma@zMgmGQ5f!tH^Qu+QZJUu(3QHO0VkN;Fh^OwgsX8$ zEtP;YoGa>OM$k#uvVLO`_UOWg^qfu4XMyVlofvtnZm;2RNrnW(hEg zOp6Qj=_tGZJ0O@WYwDW9tRI-=)5WYIw0}rpb^2u=(nYp=4{*(s64BO(B5h*5U>Z4f zL!pTpO}#}IWx9Bc^2^{9^`%tvc?`T|XySPYe)5_w(PWY)eG-0wXJa{z?cko(?XeU; zd+wqEYyRS{c#+?#z(}d_jrM37u)W<&%!MO%{OBJQZiHxlot(Cr-`Xo4p4|a!#MKXWV6z`S*x(J z&-NyGjC&Iy4x0Cb1oVRE%7Q=`nS9IYb}QQ!-{|r%U)yZxHn#W*-`#25w3~dr(&gKB zG~)j{j@_}G-VWccw7{=ww_25UO%R?vK&k5w13$9iboraYpmDpt|4t$1kJ#%lX&wU< zCMf4WB6vrh8lelgjr{aM}0NQUmR@L5aH{Q2uX*A*MNuL9?=w+Hh JpI3e3d#$$GHwZ(B_kr7)vQ*j3XsWlytT0{PH8+}3#XOWIO(}%!+(JQg#&g4?V`4&_ zlXR8bT#sHMg!#Tg$dQ*@y<7+r`k{C$%WPK2jUTh@TrAehbetmuC!&P3;Bm{^A6UC4 zZnJ0%kXGpy#PnV1=x2(XXSkNef%(^J?wZE^M96CKJ&nt<44|!U#O4m+8vJz<(gl#E z!r|7}%n|f#C-V1pB4NM*y8biz;6u@OK{K1%(9r-I=OD3fUhC!d2cFg9O3ANbP2)Bc zoS*&&N-V-Z+nT;ZnAed!^be5f0k-?hP)i%adaqC4VK)Y}A;09S+7QJ0Mfa@~|7QV! zJ`)2TT1Aeq`(d~Hg-KnJW<*W(w>6_q83G&iK5`EUvZf|8C=D?!smZLOi<24f_z__m zWjo;44%+J#WXY7%qOO>h4%(4@@wFTChNXfsJq*{3~rRh0CpbX1AxZ2bN z+7*h>Xs8>q>lPGU*K|>{%)Dg^p&nS!B}nSL==%}GbGgJGZAU_c&^8owA4>FF0BTcS zl(J}i4n{jBAem@>h8f6~t}E)U?x76MUB}GtkswQk611Bs$CYXvEF&=`b}Kj;A*ey0a<_{B#jUt+qGnx!W5 z=zTwkd6ynsrh^l(O9O^trbJ^tH>qXC?N&Ys6TL7YCN$^l`;?rbPbsQAFB)mhOlor~9mbfp zy_43xN%FIgLs~u#*$9R&X!tzkZ91aUkt98K8UP}`jbh6Ll_{kL(Xc3r7Ivr z{JL$&O=*hhp)q!lj&#wZgkUa$_p!Ie!n+R3(1@lY?onJeV=B6oHE0)x!Dh``nyCak z0$FrQlOQ}z#f>6=`dBm$k@Ts6?B6`MZ-*oCf?Y4!XO|od{*|7+?|5#{y)_M| zxm>&Cx$*Hy1sX>Qt`GlCMBW3cw>iFSY_T5Ccx!k#bZoT-9j1?i*>22bpg$;fO?XE{ zzS#}s%O*6t0eZCzI^6NxI%&t#kt3cPTe8b%7wm`84G~-I4s-&~JCu-w=Vk>#sn_BD zE<25eea_)a4Ib{}3SQEsMc(Ec7t3d>OMKC8@Re#L?0;(YYR#!PFY*<;3~_~OxolS! z1mV~^IXrQjy@U7IiSN>@rIq5^`E<8`B~QTF|A<84#%26-$(KV&&Lx=`>}VU_r%XG2 zo;iT>EjrsT%0>=)FvjRjZ+rIWpJ-xYg5Ni@uplOS*e28O@B6*q z_r3ScG)VJ;n4n_0xRNjADzv;>TUo8q<#L5q%d3@ajxK|r-V#%a^v<*(&W>Il^Qp%o z*-B2Y<(8^7#aw0N0K0fM;32MSY`_DDwlNTl?Cte)& z9o*mM{AEH&mh7YO65=OrV%;Zkw+EtYqqT=K9)2N%{&QpYJ^4#Q8pdsT z#>I7jw$q#GK?r<2gtQZ~pU*yL*LR5e$02GfCS?bAp9d&ZVf{X+yS?xS%>Yyb#Qx5& z4Wpi~8+GHE?9bH?_xBV!vUI=Doel06LfL`c7cw*x{H)AEBJeJ|&w!f~Sis$h$`mMmP+F658FRr5*ru@X#OwmI zMb!i?t+D{j)A&E1r6dIn%|BszKujx&Bp;hn#$oIyh;={h znh5(l{8<}@_n@n7&dBjGA)Y|rXMo-*D2lMiN8?FJR-xVK|CEJLeBy|Y9I@?)yN9^Q96pPGeKF|8lim`qaee5g<^1U4+-`X+q$c~XsCw2$;pP3gD^Aay6 zQmPc?=UCuvVBM`sT8vj0lT)b#fB2qBv0#GrU19w}Jiw$NDygHGA9s8V{$~69(E0)1 zQ7tm|(JuTOHi+IU>^zEb#~QW;*|nYIW5;^nhH;Mp%Fi aWlqwWwoKo#W8*JG*)Vr9g?u0#9Q+L!El7%Q6rNotO>pdBJ8l}>U{(%9XvK!+2UHR+o6R_OV(*0AwbJxrnT>-@ojQu0 zNEJ#|il{0uv`!$}DarvPuE?BFDa2B_a^}v30}@ijjZ=7UHwmGsRHwSsTULa^c!*(&$@~y0%`ffO7F7n4^<#j7?5VjQEqPneot`nlmwZ;myg>@e%*Q z-mVa;5<+a!M)4dWA>t#>b|WNP)U=djIzts*%~IKEI*o4VMah}ea2nw;sa{=ED#guW z1>0Gz5rGirZlgPy(={v2bZ1AnAq1Q|jbK_=7N9kCmJ+f15Czc%rx6^RP{tKaQ%y?t zcKtUA5%#c?EYx~m7s5gh>j#)eUqEH8sT2C^ zo}M3Qvw>|k@bQVIXc;nCKcYf2`Tln6=LmqZki#M@It+W=ddAK-SW)&HakHcO#$h=@Hv4&l-<8}J;(F6Ya}psX={CXFYrq*Q$-Lk(p* z4IX{gl*LXS5IZ0Pw32H)SsPLcGTp27jlTSxBio=!>AivUC=WJ}^2iQw#Md=)Q$i zng^f6XFtr4cOZ)+NXsT{e}`Ap*SBphnu>W zfD8PI)9A77LanIOi?#YF;0d>!#!D6$QsTOrkX8zCX)a6UtKNNwzU!}G*nqRs!TWfW zpY>{c_?W%7OYkBI5vOs!QdoU=xqu+2uQKSsJ9;7@Cj)R=3Y@*-5r+_L@zZC+@=vRV zi*?9ILasd{5b(nVI^;Pai_TZhjtKR}HG`@aRUYGDCT&qe&6vCw!(im^DEwEmX7gPLgECQ57FTF!DMQ*pZOr zKqv_&hvc#)l}*h~Oa6lvL{3c;B4}?t_7CW>=UjUT&YN|<+7xowoq50a<~Q&6-rMb> z_*Kg`tj2D$zT>xy#$Knn*D@8jO|e5t)C{{}kOVEb>`^xiM&^u8qltI?TmFuev)e`r zLg9BoGGBHqUSv*qsO&4*@L@1ibnrSzBP$fC$=58BT?vEXxdl9rExxf%E#gu1=qPy) zp_80`tvy{;p4>#+&sNpSClez|{6>`FQ&>jtB}SFnljjcXUv$^Lb$&;vTf6V9s>%@T zdgGM|sYgCZgt7?r>(yK&@inV5@rE@K>DM1$tLV=w`gN^e(dUhBeZO{C(R)jPi~<7m z*T?#7?0}6uV59H+Q%nQbQALN!^-k9z8%NUB(s8J%-tYY^t>gXL$8$cY_4NNsx?9ug z8d4MC_d(9In6q4z#l;2UEZfw@OGQAO70*=TBBc&M=SED6aI1h_%F8ZP-ilf`=xunM zmQ>}#2+mBAiDkf{Tz%VR*`HWeq+)64;IK(um${gg`Ffd~v0;eKn#9?_5$>4+TKVBb zWCjot19A>hvZ({WG?-^@iEwE~nOJ4lrOtbECKT|Y7jVJYJF#*!POcIe>HZChamp%C zYYofE!Ff`&CH@$0$a)*4C1&HViCv~loVJC2S&UCe6(wT148NJrA$j6&z~hk!Y5fKB zJLt#^Bf39DPNKgEO)fvdr3t&p31=l~cjZx+KsV;Zq$zS|L~b0Q)Z1Z}qS4DRI92W3 zZu-^DwvRi0yE7}{f5PBX4u&yxmrNPkoA49ZGU_)^zF&#m{al9qabJna^;vi*tEVy- z-ie~a=?Z*=4})ZMze8-;Lx-jCT{uz+e+&;*sNosQrG!)bpHhMf>Jr-%85ssLu9O+4 fVzLkh+P{;X`D$5wrbKk&ECh=$#3cG*=J@y(R^M@& literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ECASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ECASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4733e3fc745e220ad452c045800a5ce342e3ab3a GIT binary patch literal 1733 zcmbVM-A~(A6u)-(T1aRTQec5)R@l&H&8Vd5)X_?lF%Ah$e3|Wt(ifBkGovL9g1}Tw ztyuRVqHTdLccU$qWaxvQhBSUYL^^J@@WtCOsTH z*xlhGbwWsmG*P@lNQ4B4yX8bgQ#DK}n=h!6CKpxF-E^G}=tU|Ss_r_`w9u$8N>yvs zs$x5}Wx^5SZa5v;lBSq>s=3?T8W(c!I^nz~O+jn&gi831Lli{kTqm5)NarP0kqwpX z?gVcW!rj9{ezG4=a*wW))hCnubRrSuT0iotdki9WySdV-SA)vlH<7 zb9YwedWjxs;Q&@q(&LV|nms z6NbpQvJl?_nNd-ZO(iGks#(&35Q@jBHe<#x)gsTGjxednx&lEK3UmR9xoy zIaM;nz!^vgiLy2$d45A=Tp+?a15xm|%7v+%%))^f8nmcRpwSIR%Qe+RJq~(cDwk*B z=P@}5Gh{8u-xw0|4s73+rFu~|(Oiezs8Z5(RXcG%7>8@0z*_vjX&|lr`dAk(tGMl$ ze2sorHM5d2 zQyilO>F5&T;$0@(WCCTc7Fgmk>rdb`i?X8A%RDmC0ALp#=6riC9=UJ8|?Kq#W{Jv zU${=ERVgo9Qo~wqi~t_D<~pyNUT4xaSQ_Hkd6pvgFC85G3+k8hWdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ETYPECASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ETYPECASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c623a3bf41d8fd799c9a26fe15a137d005b9b2cd GIT binary patch literal 1235 zcmah|&2JM&6rWwk@n^y&avhXdbc=+FR!o$H&_ducY{s#Z^-j7wX2}Uf&ZcWA!Ite* zLKP_D0GCDJM4%lI|3MECmx`t$s@h}!fF671RH=s^Dm8tx;j>iYusidd(%hB ztEQ!!t<83G!|&*=tzLVpr?0m4JPhZeUyVKl&%lY#lPS2g2nVX%R%$A939ie?RW_E7si@9@OPG%3EK2o$6 zLa2cbqSE6uuW)`2tl&>sPleiQ;eU!e9 zkTN8T`61X}RGwc)>pw24-tqAfCHZw+;XWLrw^O4^@ce}h_dohe_w1h$>IZl1MO7Js z+uoQrE+OQXMktTaL9lODdfo2pm z0DrA;zzRF8aF>m~wU?L%riWe;I(ILCVr+>PWRpj^54VGlSGyDJ75}f?exNlqq^6>W zVaYI=Jzte=#T8=DThzgqtDvzLTtiKYj5+`_8!=46%?frXuRG9lGalNYyW(TUKJ$9f#WQY?x4_?IqX>Z^_D~I7%gQ()<%Ncm1(B$zQBu!aWPB^Pcxi3Q<0@Iig6NV_A5T!9tW!|iDO!}`VJm&XqwEf0v z*T+4-+nbibe@5Y_90dL3Epk#{UxnwtrZ=x2yd5CPPze&uj-6bF;R&^ a?fqi$)V%miiQ&ZO;4Dsy3G{gC@bF(3m2h+b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE-FILE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE-FILE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..21330442a559239fed478f3b336a2a2b9903add5 GIT binary patch literal 777 zcmah{K~EDw6n?u)OMyZPQKH7+hJ?$;A(TMCdT|`4w6L9p+1VgRQWo2!uuZ!)Ax2_6 zcv_={NOm>+2d{{cgMY|>fHSQ|A_q_N=9_un_rCXD7gEoNZIWQWS#S6)Gw6iPPH650 zEwdeTT2rL0L0y50Wt$>~ zE7Xd+ag>o>kmph!N8|Hm7&KACf8jTjo&7dw0P%+?Q}h@SWrxKl+G{NvzmG=C3~fkj zc$I>l`OTu(HASq-Q?uZo7h3bnWI3;aJItF_;V)8R>V- zqMSP%IiA??gk=oLgsg?xHtON7l}O{c{6GC0GyswT)ih&WlBA0cuV7J9V#MQ|vTMUg zv?Yn(`s;&Wm-g9Z9Z069dQvlT9%-hC?7PXNu@Xmjs{KtwYVFWLfI`0=qC-D?5=Re& zjLqpIJZwoQ!J<)+n+x6^zE{s9NTU(qQ1!*Ha$ns LEn?H$s{u4>l<sWxIQf@R3MQ;o#=%Ius_vOls* zRL<#n#xdr6S#3;Ns$`}$)mh;dxmM?k>Xx)BWU(}HL}tFmx)<`!In~zqfDjWTEtADS z?CNUE1;)4sE+wKjJb4Ud#;Uq(7%zf zR>szf)9r5C>bY`Hat)!2dc5mDvG0(=2P2~&q?bJcv5V+vdRy(&5ALX?_@jqklMSk^ zsUP0EbG~@~#{Js+q_LxRj6g>%^J2wAq|sUH&2{EFen%g<9l31;A3eP0h1;a+|5N{R z;l{Sj8n9Fd7sJdKa=xl|MkP&6rs?p7QBh4QvMwaj$Wcd(s4oajz5q^EBr1ufG%Dz_ zY3Vo_k~>-r#-w4&86Wq&hN(rN#oq``{wAEJtx;LmHC@mwGi#Yq{}wc8jf(1|;PQwZ)Qt}j$+`2)cbh9CE3^4`)8tvUQsXt&s4Jl2} zh$fNWqJ2cNbX``TS{>j>wv4j&js8fYA$u8vJM&ZMsU?*W$1OFXS!$9@4A@0r3`Kr1 zVGy2xP69`e_1cJR3Tf4pbyZXZ-BR5$NZN~`!n9Mkb_(`i*D`VzA|z^u*9kPcfc;DP zx-Op6WcNLlzcEs%zMp8x{={=`H)Jy<7?YWVrU;MMorHg&@++J0e}%my{vLJ^xDGoB zEJMc(?0OGPUak92K5-^wr-08wcLusd;0K^P4qXR;-wk`)(UiM{MnU(uiCV;4r$MDd zP>8I+egZjgPbdp}kYazi6uakv-#q4BkGcf=NM#ZBqiG&n((+8(#*h=h_QxQSgx+E3 z?T4No=;?-@?aKegWeUGID}L-rgCb@UNzqve5Mh`) zZXRMyJzAEQQdFE3A664IOi?!>!aUM1t4W-86p;s69Wh5i@EnGc8ZD7Q)N+*@Cp8Kb zOevbCdpIXR4ElZNJ*vS{71?kN@aC6BMO~05EQ(Ba0b)FM&bCKpaZ;t8`_id; z`kAz98CjS@66>0RsgAlq00ihGZa=jjV)Tl;ErBDX;x=TEFlvX_S8$`fO-#2{et7pq Wt%KAe=e7&R$+H6c*yV-w_5T10C8Ht$ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-DISASSEMBLE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-DISASSEMBLE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2652bbce0d521efe92dcd2d51dd64002812e80c7 GIT binary patch literal 1326 zcma)6&2Jl35P!RNTsux&rwWPc1iBOgV&S=UnwHia;Cb_$xLNOp-F4ekLMSAg+LBXS z{y+lM$O;EItQ1^}XdhJ%{09-Yh*mzpkpl-Lj!1|LJ@r2bGwY;8X(c$U=FPmB-~8rd zUzZHs(sV_uZPqJQx1rS9t$MqqY}6V`v(|2`xylCEl`k~Y;`bJrwv>J^Gi)EbS!=kf zEq7gU+HP}w^|N=B%r%A88?u3iN-lf68fotsM!=b5b!(Ec-KE_?Ca?4?Y4_~7BL zl&ld#)<_>kjF2P=5&yoIR2^D-15D#S*2C0)2jQaTg7rV zn?xeS|Hg~vONQnYOvCR<9cjeh@kR>Lv%E;))@}nhb|1POLUXpK~NsUR7JA~lHC?WmIBT&w4pE@m-_dibb%><}V zyZVlq_=%8i`71NABun7f-8*}89E0$S5;B6ZYZLvw&yT10`zS>eV4xF#@xxhk7@Wm3 zYp2{P|L@F`FU$;B*HeJoFDJ1l-+I%kW*YMaY#d!=#=Oognk#_CSg=(&B4Y9oOl3^f zn4>LHi#sI?x~c_ZiP$T)!;7*E9^-?#X*y>{X_@9tt7xl2lBMUP9a9zYP)x)^qcEj} z$}P*Zs9AEBOO6_fL%@j2j1?N#5d_ASIWhHEh!7FRQO9v=e*sXK-(Wf_zk?D%0?a}6 zH)NodEQ=e*_DV>2_cJp8w*eZn`5>(bV0Qs2er!oF#1oS!I%4u8F@9UTbX`om3Vj^6 zxs#{%N-<~Z^k@}_(en=g8Ctf?1p~Ex)Pl-T+k?f87)Ui>{=Jw&s{p)Hdck3iSwy`D zG1A+3+7Z(zz7*5p4om^gwoH`K{3rrRQpZqS?$OQyp`>W1%4 zoTN^hZmV5~S0J6uahNb4ya2(ohNTV4IjUpJKCCSLGEft*b+(E0=Lg|{k4Qr{aY3ZW Jch?RM{sGG|jO_pb literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-2-DOCUMENTATION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-2-DOCUMENTATION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..05156ceb48295e0682d3e7e6bea420bf9979eea2 GIT binary patch literal 4962 zcmbstdu$tL{kyZ{Jewv>wl;3kT_0(O+e@1^S-Z4lxm?ciC63R%JGV`FY_5H&O&vSf zP9K_9LJFdP9BR9C(S555VrbGNH0VH}q%A}U1e!n~gjNXz(j<^7A;e37Kthz??>;AX zlCki}!{7a$-|zW-zw=E}by^M!a&BTWow4#lZmKvrRTRc^d7+S-$|o#g9Pq-6vZgC9 zg(P{T>u7hKQ9()Mt$5K&3g(nmNX9Sk6S|)jq{)0b0}n@z0NCBvd$6ykr>ia~8DXYv zU74P~1Bd&1y1VKg-TX=(f8hejTS(ZMJp7o6o1dX z(yQ1J%y>azUDdKNW%U&b!Shl8DwYa*#be1{G%@`EfK4;i&0K2X`Nl=95x_s(3}4q8 zzeC8))MvED5uO7>Z{BS?)ru;BUPDL&iYA_1e2e@Qk)>SmZ!YDk2H4;a1WVh#_7<^M zChXp+gv_l%rKQvo(GOr)_rnV zks`6E7}WGpBS1NxTPtm90b1{=rL~?7&})qWMb|Z5)M92dW(GX|YrTX}FE(`#cIO+gnO8X}g%P+7fDet7OavX= zK#u7;v~>9dp&Zh#0j;$hBv~>PW*V(WvH_Y}40SXLmKmlFaTApjF}6z>Xmu-&3Y3tj zAD2G56_@=CdYVBU40@75^$ha55chW%;{L>-M+|zGK|f{C4;l12-3+R^*XR~pW@#HP zAA@W+8;ZH|>_W?ah3+csu2>A+Yq5%L@jEn zqv{z&H<0Z)j7FJFl4Zp(G)6nJk`~pKK^4kMLAh?W%Wklw8psGQw_aasW9xqyjKoG*_8IaDvXdcq0J4T$LDvN56F><&iW&yNw|3oGO3LmlqO{J@+T_*1Lz*JkA5bn3Y=?$w9 zg)#gRw>t^yp|V^}Kc_9I@NIekm+t|0!=P%&I#gLiikM95^MKy6qO(Nz_J;_>qKxGl z4WNQgxbfj8*^;1m7H}`nUR+|JrB>FWV`AB!VZ@C}BT5BMX6(n<(#w_rF#1qVEN!?G zJb41+QL2a)b;t>jwz>+cTQ6J()Aa<1HZ4a<)CPtX84o6|#-)>gu;q_#OvvwOH_*r< zFrd}CG#Sq(#kJ`nzh+!Nqt7ApkLW>Men1c5@?8*ZD_)+o#FG5l%#m-?k!fT@!TR zEZz4!-G3T*YGP67as{h0M)wcXXNG9YQQGn}J$pgob9N?HX0)iaV%yqFV{X>hmz z?#45qCLh0CfDO67IQHgDI%^53ctM!VfoTQd66~K8E+hF@j@_1>nmCIy{kU);T}YpW zIsRfgo6KEw<$vth2NN*%PeBY_OOxqBBA=c}XX9D+0uUF#yks6Coe(T|#E7HnyUuNA z7N>x1vaUeV#8ua2STz-03LCT@+2Alc5z|bC_2+HJ?&=#*ASw!*%H3RG8d>U=a(2Zi zWw8r)9DjdbPtTF={`r0!1n;({Vdx3Le+uW&vt;q^qZbHyYChEeHfbe`u<)(?VyKBY zwm%b}IGc=Pova=v;8lThhY6S`9Cm(jt#GGoltYR`d9l}uW_29vP$enc4 zM%r6Xd%d)m5Hx*sjywa_Y~#LOotjTAT#e7C7nb0Asry&s_tN*#zz6EBa0m<>xfLD; z1HEgbu>d4SGewD zhZEuWC5JX*QfEB?y0^EcMj+cRf~OXGj9I4^dnV58W-yJ98nl=8v8v(Vu7IdX&*fb#I`{tD8<5X0WaP0ViaaB*pNOuO{QH-eDwVEC#UH+sAT6e zs-N}I3}VkMV_~;xYSOeT1aE;$vkJtjc6m0Lo(2cVpa08NCcl^?BmMk*h+k0odoX_A zhXjv=xRl?Y^1~xSIGFqWD&orEFoNk}o^kq--S1x~Juv0+rKIzY-LPv{X~2OA!LeJG zKqYcg)wKw|vvN3g`-YSVOnctF@XQ@=$IoMJ@ae_YZG;C;STXti5P2ft2bM1R$^Umk zk#EeAU2a%rLp(PFZe!txUJkj>s_KSkU4Qu%<=D`nBQO!qW^+a1tmR%gaHU;@O9Tn={JBDxo1|+MUY0Me$vJWiLZ4bl!5I^}F{9qy zjCHBr8Xnnw?^7cw|CxmlKY#bpd_NcRF97LYsGlEB`BSPJhW9@lSC(Ks>m>Ib5DKz< z*Jm$yj<`rBify)~O*=K& z7?JE{4^DzWB=g*G+dp9ak(kxh9*hSQ58g~Xcrx+eWfKn`@%wFIEd`_5!{ois=lj0j z_x<^1mvpWvs;HET<$NJq5lc0@T(iZEQbnwmYL!e@+yGvDPtgtb{)()uPQD!Rn=O(| zC7ZUh>!MZ5R@c+FUKAr&MY&wb7hp3#4=}PYJGC$~GwF}YrrNajpE@%OSLPS4%uV`_ z4iAK2i4c+@bzFJ~2@)@H_ne?)G1H>an98Uo$C>2rx=uI5LX##lTqiUo+NClrWZ%se zFq~qQ2!yyFIo;8urdTmubN7X9q0ilM`ePbRKxpzZBcASKD`;InGqZG>$_YbH=q6QT zrbP}925u7~#6m$2y7YDK;i~XplYH^bs^>;{BqaE5W`^qpPiCZE@McEqg^tX{dM+cv zHwNE${T)J3ub+^A+2$X@k?`%VAtCqRtw3E50DQEo?&yK<2-(fu(F3a<0n~TzkK7nU zQ}}fg(gzmvnG5w#$-NfGgtZgLx{-wp;sWY>x%=17Fw(JiaBTFm(H3yGWxt)<&i!v6 zhtBm8ti3h@m(+7X%=yR8sHEuHQVa`2S7dETWd>c00i!LOlE=q;Je^SWkfg|#vO*1J zB@L*W(kQ#nOqmvodpvMru-O-i%498>pi$k3n-Uj1!dY!gmw2zYhxd5#p3Vo8SrD%gkBi=sX{MZ>5)spc=W<(x$9kO13yL^g=y@7Ue8pwfmat6pC zkOMM3bpg;Jq!&-oXg7?sa*77at`m&3b$$;Nn|ENlhp=%K2)2V=msJFF0DPDv*+MuC zHbY9%FqqadTU}qCi@5ySTzbimOH-KHo0U-Vv@Gwk#g2v(rmBk?? za-%)1RD#)j{3f4xlTYZ7mGDwB9*?IUdljK?@bJ>Pf)o#5Jy)>C!$EZQC3thvxae&+@vM-)z39$Za)(`qOnfHwvXv1w;7Vbvn=( z?tgKeK)zTmWQ*BNJ8kDno5=p??tA%VF7X!-eeXKH^;)r5yoKm1cfX52#RvJ*`~n~1 z!~7X!KZi5ulT8sFx_8}uoV$yP!DNfkwgypS7BghkY%c;l~xS2t5|68n~UoQ+B2fONvc5+trOQb-ryUQc6!+Q$J* rACChO@Kq3?ScEJ;nJ(0mkZVt-3neF{qme*93+dr=e4Ko;a&+`JQkyj% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3c468513f164382bd780ac72183463bca54538e0 GIT binary patch literal 1742 zcmbVM&2Jk;6rc51ZO3tKW3|W%>E;6=tr&yT6eWfOo6R^ews+0$x~&lsGPZ-Q+O_2m zqzVzLTq?mz!KsLLK=~hvKtdG-OK?Ks#DOFK0TL&!;XT`FgE0d2Fq(P4H}5y^a|XnH zQ^|@-tJ$tMsvWV_@3s3qaj(@8yRCkwTov~K7e7!moqf0~E1CGK3BPepQ|?qty=p}? z`_*oxbmv7eu_?;!PQ3w#jSUbJ$!lxL_4T+vB^%i>+ke`uCtu!3CN|^#)01N%)FOnG z$q+XmAtB-<_K_8mOlFugmCiD%$~h+41KaXKEVN)S-L}GOVz1Svjq3Z=28Pq@5`hr= zQ_GtwsEV1^RQtYgR|wdL)_hu}c?eD3VZ`B`upql&TY$B-Nz?sK@IoMB0kO=Xwr%q-|o4rNqNk5M#CmUB4ZMs!?o zCCg;Bkf$k4&lwUI9Kt`XO-|d;3#R0p1A~Aht3^7(k;EAQ z%#S5EsanWwF+K6Poe*{Ur}b+*;tWoMR{^{@4Xy(i0`QsbLM~UNe|rQ};n^zWkIYuV zE4CF%OtrTUx`Ml~r-Rs{OAxq=U6->cL_zRi!ekRgd@`&Qbe*Z^28au&!)!*M6ikr~ zHck_t12y>-m@Z7F0p*{$h}#e2?VIs-#Gga(kS~73uUv-~h#JgHQKOjK(z5hy{4#v$ zb-skG!UC|mVZ?S+wEGjKQE5>69Y)rpqVE_A`HipQ_7k}2J7Y@lNRO}F;;V1-RSjbs zXZo?4zQrTkv+yF1Y|g@O@<;$)5&SU!rFN&)Zgpv|+U+6cv#l#8oW$k@r8)EygTf@U(lg0`R7R^+^Mv|H`<+o-u`Tk+%;gMzd1&o}zc@zJr%A-hKOy&8l~pDl@f+D-C{sJX|Zvi2#{AocAm}_a!<%>PiG7DA;dMx9gjn1_)C0+ Jd@i4!{srrj{4xLl literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-DESCRIBE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-DESCRIBE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..30effa98b5b70d407816826bb4db22a401ee8154 GIT binary patch literal 3588 zcmb_eVQgDh6~6b`aqKv0lEz!0=`y#d2{?V-(so_RVCwVBb^YS!_q_L>X*@v8aopOF zCc&{06;PRW>xATKWGUg@m4T*e0!^BzDh)MVyCA`jBKQLme<#6@O&}o^?Z=Qn3g_IH zmnImgf0E?p+*}X1vSZCMng*#d>)*?lj6vv&9RC-Y31wu%PtRsmK(nkWseXZ4(aG34LDNSdxp=4RY zU3Obxh(*rZ%yL`(N8|N{MR~6Lt@0d(bAE|XLfjv=!l}HWI+|&?E3`?w-B(*Znjz;P zH03lSQh3t}TBmNS>*!PRF?o{Ns--0vd1JNv5+Q*B^yPNty(zjjPriL;N;mFLmyvm9_T`nBQN{ykh)@kmbr1V@jeuFuO5$WDszY*%p) zu)hv-oZ^@Z!J@0fW5N{vwjm%`1Vg~>1hqHi+orphn}F>5-i`Lb4J3YgZjN|KcSk&q=wf^PAkTw&MY~p z0mnFPC!{EkNIftjFv2i8VRXOoA?2_6k} z@kn3~+~GY5W?7~sn|UXfcM^eKQ0Pu5MnM*QJHg>H_dor=J)tW=2oGW>knvu3f~8Q( zw6cnWOW~KAw=8CC>olB#O!^o$h&>2aRcz*M#iJ0w=5pBzG(z2Ozw5;|#vxJWa05Zc%#7@C^F$4{jEYkUL+XFOQOBS}bHP}dB$^*rLkhPbCe5>d@u0m{%|Jb}E!$Pr+2phvm^7($Gk^E5la^GEO`WHz0{a@d}GNdjlPwn>=XOJaPcQK^saG z5adIFARh=3`IARp@t801(F=U^I3GF8N8@~S5VMj}RL8Vn8=g1_`tS|XdSte|RH{{H z%5uHDRF@ZvrEe6^l|d-|$8A0C055*QTelT0&Xl%m z{;HkzCbTEu`e!YVKZ&}pw*y~vuemD{I6JIb4DJ)O8NU~c_M~eLvlQLtQG`LIJ(o8f zCPJ1PZfkI7I7{_fqf~FyL_puhp{5v-_K8iOX#tEQQnkwxvK z6ipBAhxnqw0M;HdKf@Efd@Rbxf_#h+^zn&Rk_E4Z>ARhkTa~rT#aq=ie+{2jmy5Tn z_|yscoyy(I#XHrz==l5ERU-|KXRaDk;CS|`p@ZYb!yNA<(xnaf*>pY#c@2(aSOIE{ zD)=vn|5Oqj=cf;Fy`N_&pYlBIT_qvR<-@jsYTcHbkas}{l{O=$|8!RZ@CQrLHBHTc za~2GV+kyr;b_n_pT-f-FtG~J{gW#={v-ud8K?Iql3Qr(OdPD_+kIH73Z8qIjhq(1{ zN?hhgK=|oNmQwP%^WehEIZJrJ4>w5@&8~#_^Ud!!xdWEHrh&Tv_shu5Z*g%`;C=wic6Jxab^y01V=GOd`Z8>%u&|x2v$G;lR}$*m>455 zKKQgo3z6(<_z%7!Mjre_{)0N(nn>`$r+eqj+;h*lcZLvqs+&k}A9k88w~N|?erM1} z2kkEEwFljriw-1?Ug;L6ueXT4lYN+*vaj9Ly6%48ts^mTd-eU7_fT#fkxsYSlF8bd zJm!jpd~tO(J5?sOIbr*6&1&)fdNEhXPL0mbluR1{YH$^X6hHp83V{F7OO_p`3&Udmsq#ii`yad+gW;;Q zMm8y^$v-S1yW)F^d;veev;^m8@n@leZ;i`s<>CmQeBV}gXP4%b*z>WhOBv?hCeljd z;s=xYui?&n_7h;(c*nL?Wd`7+@pWN$Y$oJM0;B=1nzi|1Bh$=)8uLGSw>8~jB_mXa zw+Jhll;aIUB5c#v)Tp#Qr|CrKTbNVfa4B0K`;OatwxAVN`S*pev|u`t2vU)xv^uL% z&Ml5DM^qi5MN+aLtr50|$GEKp(sL$vV|0lKKoAY*6|G8=c-i6=A}V1s-Qk?FYkLTk zM-spF*N0AQI$;l{mt=LKykR-4RE_54AvSKS$+g5;NNO$zi;EIhX(?jJ>AQ8@cYA&6 zdv}D4Xyur!po4w+CF`hpH2F;-c6?Xyzxb!BY`v^=N(99>6qtsfoS1en9X^wtA3K(y K!2*0nqtS00zUAEj literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-INSPECT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-INSPECT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..55d58378ad253903be4b07adac3380718cc495ec GIT binary patch literal 789 zcmah{&rcIU6n?w?2^3O@frJ>Gka*cR#1=@PdKrc(ENo}%?5s%Qg_OlMDYR*~CdNpN z2TyCX5Xr8F|G_I_AF^*S{V?I|3+rnX>j)(PF5dsG;9ZoJew-j46>BH8o0yF0HQpu#dD?M|bq4ogew zS|}|ROA8Bg!)4-FS8V^SStvbRE*0nJhA&S~w0sKyYH$&UA%Hw2AUq24hGdS!Wz%Aq zlL|A!ei&qx7wkGrgu!?b`K>l?dM~|ZY-hg<8bJ6d$d+ABrD^l@`cwu7yFaxQOSm$(<^r5>8Lj&tn*pKV*#SKLv7v8`O^<7-7XxkQDonh~ zSr^QGlcRx5=%6qnIZPkOR1A)F%4%d?OEfD*PPWHK@&3 z%~&E{Cw$dn0akeSyd$IvMnk^R^n#V6@u{_ z%ZRkc3cvH$2PF=>Vvk0qRduGkV!M2`nk=eIYS7kDyGiqy)S8K=rsAaQu_sKmhsHs- z?bUqjdtIM}!9A%Wnmr`5Xm3aT&|TCxxcXc%c6eV4zlO)U5-~#sBa-1;S}apCK`bX4 SiPMyZC$247GznkO<>em*hU+o_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ROOM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ROOM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..231176227741dc5c5312d79b41d642c2671c1db7 GIT binary patch literal 791 zcmah{&rcIU6n?u)OACb*B9IsZ8xk%X2W=?{l+(COp|G9B*;x?}CQaG0Oo(iR#WPryj{^v_S$0KKY4)O?6&0X>cqZN~z$ZKT@P< zOGv|O1mwhDln7l4{A6|!Eg)u^B{)5aH=-GSxaS+v**@(3+>p0N?~h5b1b}<_ttN(Z zFHhWlICKx)^F4s^cY`U(J^MvPe%agnKz{@D-1l@tmPP=M-0zdyeSHzIfJp&d)GFgW zH(g7E91A}C4>aARtHo$ww2tYjK^S^c6cxH=Y4U(@VocL9*Vhpv+-5?F-nSxd?O2?Y zWa-}*+|oc#2WyNWP zYdi|4low(dEzfJ9j??Zu3;Y=_qB?tkXVq$1{Lx*twtxM-qT0cn6nqViWkEcxGlDrm ccleDWCkz`_I2=6_q)%;=lW-Eg%v@dl0g$-vEdT%j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..da40ef37b239d96b56c797197480526700da6ff9 GIT binary patch literal 1493 zcmbVLTW=dh6h33ew_GZxB571gvx?MKTD(!5CTeRQ&}2PnoUC`#-8F40@nD<{Hge+N z*a(EEq6+nC5jYXnPEp@@MS@6`C`Ii9Jm$yrAB1yuLuebRAY`p)&Sk#uoHO6_AaO@G z6uq^%-DrAkrPb|hcRR{PtF7#`y6u{$Y@lEHQnzgJ)e_fNrr*mCIxj_PZLiw#))lww z?W|Y7$SL_73g2!wnz*@s9nE}Uezq_-H$Aw>9V0^f*E4g4nHz<<{Pf__qdv>F0H6lX zX~_U&Ar8TwpH*GqxY}aL5Sq!$LJfL>pT=IaiX-g6ADvY?t!=I8edaZ(oy{F!0Ks>D zda+{aZpku(eYVSngKzzjlBum?Yy75wSo#=+&{^PTX6Lo5np-Lhc+^kc#}fXeI)1A^ zU1m?V;MwoXvD;_PkFo@LKL(&>C|V8=?w)oQ4)oK`!-L$b&aEri7YF07`p7!mtw+D7 zNOkspYM9lZJTr0sqPOym`3FF+{=i(0u@Qj1`p@IH!_m>fG{7*x^G5A#ubypWA(jZf z_b;frWfn^`3vG#;MMK!yLJ2+QO-GFl;E+dEoxA#yW(&7s6nwiz1volu6PgN`uS?^4u1BM(B7^qf+k52_YwD{6y#YeQRG`1rBlkeW8&jUZ@xHe7u(_lYFZANBfByLqKS71kfC!GkK zr1?o7(s=LTdkFmV&Fbby>s2CneVSOy@if_hyug@L06q-%<48B)2=^8eusd=RYrc~G zpwCh$y;}IjPzt4I=96KqDA#IT8p5OVpzkAO)H&xPd zSy3gWyu4a+>@}&pQCZ!nNLR{h(t3Ggtzb)6KrdZabc200Eh{qv<3p|HK1*TEUZ~iM zlC@#4FD`s}P8zx($*XH62ZZzI0S=9g4v&qD475(krW$1X&zO<1!3$%fg9ELvpKJ=T zG9jcuYPduQiIFDaJ#b?wikAtAb#t}F`@YU(`ZeP0^F^t_x0$ngj9=n^yrKzfMazl zk?+MI{KAIq7+a8P+vM>+Qo^MMsc=34Ty{Rlcj5A0z8jZRzDunC2}`>>@8rARKqs>M zC?C)Fyu4X#{Qqxe#}8!&2f2hCYQ-2{_anC_rRdsZ25Um6Wo=Sr2ECX8jg~f3Vu(k? z7ASaUN|7yPni|Z?8Bj3AuXxCuH!YSGMeyhfT0&8otmS6ulx}3r6c69`hj>u@Nx$awV_jo|Jl529sO17!+Igg@6|C+1<3Jw;U07EvIz-RE z5BMl_UNprFLpP|Nvu1NvswswXDOsDRz8=|oZfxj4Cr6;nycyd!j{P?ZiJIA*tRgrA zAcQBEErdx(*s0_UgK7I_g$rmq2DYxfn^$C$1>5pAFq0aXyAN&rSsp`&XS^4e?O?gb zPawL>d#>}722{1nWY!cl=d%}el{RMXLogiqBs-^OOlusd9y@e{AubK@{v?-9@%{vO z#na3>FnnRyOc(@P%dDZNHAEeV{Ch(rz^I2bya>D(@&`|@^3zv&@-k1(@LoT>AI5vp zE|eE-y0KEaX0NR;IJ8n)wrRy)uV9jsp4(@EESn4Ejx zdk?V#dliGp7NZAlRn1t;kX4hnp&PLLD5qPDpT^ibo_peO66?5}k@e2I4YMdL|LNy@Yfn?( zvhjrNt<_Qt-XZ7&XJPrX#RaVH!Fhw<4Z)u`7&*_4;M-5Jft&lFn_H6%eiP=Y39psP zdZ4-?gJtzOhVy;&K>K6y+c1=>OiNqS{?AW1qggD?j9Ee^Z?}*i&b1iLenasy&@TKe LKTRHwzkdBUqEbGr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-ENCODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-ENCODE-UNIVERSAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c81b06309e7f9c997d74ff2655e9c6ce6f6b0668 GIT binary patch literal 2204 zcma)7L2MgU5dCX6j+3UY?Yc>Dqp%HW6fOBCPLqga7TWl$b zL*i6IKq*B64wjM-sCEmzaqJ;fNT_O&rNW&aKpZ$AapVFVkje!!vzxSW5~wdSkV0&lEaYYX#l4e`l~ytuMjUWCo~IIziyv5|?<(M0={sLP(Wr`n88B!?%G z=M(LXTQ|6Hg%DCCbtG+sgo&TnpVY#F!E}R8Wn@MbafS)@mR$=%E;O$*&8|g8_-bW^ zE?QTtMNDUDjc|n6o3-FnUXhH9s@U7yHLkZgnby>z0&_|rgjd1&c|wJDLxki3pL~e+nt9;I~W9GxX7m% z|5%LQ$w4llX~yBKJK}!E&BW{mIpD<$cX$lSWhr*3(rM>_EE>+i& zrGfxniG$O6DU6NsS*=HqR3(+cZlcqol9HK5Co>>X(z@UaIBmWbXw`@yiH0;yHD=^B zXf?_0)qq~m4L0NRfkw=0W=UqElF!j8Rh!WThx2iVtqoOhj{7?RIGJMDl_|FwsVqMJ z0I+ra?P%)t?Vd(PH=M9P_<#mq?4fSx`Ym7&~#b^?03$#z;* z(pgvlb^&-W&E&;VOtTxHNRyrHmFF242qA%KnyOJXZ{+fZ;E#iHhaf5i>dNtI{AWNG zh0@?8pk8%of$8A72VEaP6sUn+3nvfEq>cz7&M_QBQJf@yz}d&xtSBS%8!!Rv1kphD zSM)07HH|6zrk=wg_5)zCC!HvXI`blRjw5^%Jo&{*9rqi~b4Y6FT+HQ|l0x=9Px_8C zh}@e1wg4y>kXr=qq+XbrRAst1I#Ip={oj6$!POV24!t2Wl+HN6jha%Z@70LTf;uNa=0t4JyE>;#Sy1rb#Vy&*tFVbpx$)Z(jt%@2y+qGv6*zJUn&_e0kY>r%-kkW9B}DJAxxmANdfV!WB?(&clxU^?3Kd{@mWi&%0OBm}oG1 z;ELpo!8B3Uo#Utm>A#v+4dx}XW7p0c9r>D7U0=b2ZrioQ#3X|jVcrAhzS@|Wm&{%k zSM}Yz5(RrZaEWyF`oX;QQ_bFPJrV1O1(ADjz0qhq${rH^n`#n~mzvm?3r%d`g(kLj l5YBsY!r3M;7zePcx3$MT{^2pVR?dr131{4)H784~QMI}Ap&3a;+tar`sI3c1^73@uH*u+-i zpdv&R^+JIa#jS{TsCucmlePz_T4br*IKTz|2Ck9HwS+gjHi=v$Sg*D3^Y`Aok7=Nu zcT`PQt82B2V{gdSt$J;%F0WKKAAyGa=lt3j{TwSh~unn zB8-stl^dQb=qk$^x_1Nb-~sQNJDAl;9*(A@DU!l16oHOC_t~j)WSXQYBPpsHDVicI zo1^H~ZsZE2^ZRgA5@|gsKb*(+*U{x4=cUEtv0)rqMMx+H5o(70w2LFn%0rMIztTI5 z%l9u0HH{%)_Z!+ZW9TP@8s$%op?L{|M`Q2Q;tAm`{@^_TAeG|D=HA7lv3_gE3NMa8 zS^hWn=)Yn^DsROArdf`P8hq`ZPN;^S%8EjfjH0JBYLeM3Nc6OokU~5n^*|Sf6RN`0 z3^6Gym{3L4Z$rphvKY-t5?G7`eNr{5=!HC)Gt8Wo;8?;>dov@!`@14M(lrRm9%iJJ zrGL6A`q9-7-5N?z(=<$C6j;8%5?upeJCIQHCF08kxaUSEJGvj~Mu>NdmiLRs{R%+c zbV1Ps^9Y!bNK9dZZHmm)f@xCy$b4}ubl-t)+uWi0+W=2 z2Pa{L;JtkZ{guS;KY83JUrl1?0(^HWAp9dK1=7!eI28W^{(<~+K{=ys`+EWye;{za z@JT1$R_zMDrE>$?8Ss^NFZ-;7*Lxp5d3?RRw;J%R5MQ=AClr{cTLKAJ_J7DUG69+Z z7g^tZsjZgq+Mhn&Gl!B^$enWMuThD@HhXT&Szdduv@Dw0xfXCGVt*}QGdwpU?lvN3 zvpWuR*f&NOsJTQe*m;efhK7brnll#YF(8k1%%|vgzi=fQ)zd8F->l)R&S;vNd4#(C S+2Jq1WbhYx9DVcp!NK3l=<@{t literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-REAL-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-REAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3fe1009c9c3ea79dff1120623d2c11d15a376508 GIT binary patch literal 2682 zcmbtW%WoS+7@u7`j`Ma>_vNImDYR;rPH56pN`ruI*5i0%dw09LZfb-?-Ndb3IS&#W zQ9&!yg5Y4O4QazptKPU%4v3^lu>=wl2X62eAc4dQi4&*ree2jsN~I!^*qNDczQ^x- zP8Lbi1tk$yW~b-!h3tHIwp5%e6~mWj=fexLrTNKh_%hJL?<=~=uE%60-v8=AtF`TB zaz2|WW~ah-DZ4P0xppEva3(Cz&F2fS86Jk?z{u&rk)fgf)~IYHYTBMFGc+=Aa%5<@ zzjfo`vJjXhgiMkuE-i!vh=(|zRRWUDESpBv1f!aqWRkP!RQ%uzObf_9Nz%_Y{5z)V?1+@!KrFZZ&9in5* zrmAK$Q-&cf#?{ z#l&sB^Ls)TbD!v)aZv!t#YdruJ#`!)+74Foll!V)kspw{>4-2`cf?#wI%{w;0m5^wW#@D@)SR9UCQOj9?hp0bUUEqU5Opk0!+GQZCht?0q;r(Z7Yn5Y_S?}?)JdzplQ#u+XSV<|c_?pO;$x%H)>rGtZ2d;vegAf*ZG@)8Cid+_jEK}Wp z(5Y`S)0za9U0W=&qA<(SP3x_lbi-s36$*f*_Ox<`5eD6JC*=9l$dRt8OJs%=pNYQbWd9~AncCi|c!RN+Ujfd}o1ZltND zs7zBB@0meTQjW7N(iI>zHyAE*Da|DfXf2yGYVe*hK(HH~rtE@&QEs>z0XJH=-7r(; z(ivb6G+3xUI?fdP1ed~G>OwC+bSitUWQ#OEQ_RlKWC|3XlL9T~r?Yr_-KiY1vkS%W z;T!Vd@Z}6VMN{GYOzjmx+6|16aLjq&EMapVRA4yUj6PMT2^CsJPFTDR*&y`iQo7CD z7zz8G%8`a~v`b4f`Qied%g)njjc4nBFrPP?n(k|?h-rVjQ zi9#08=))#Z3v~{JH{ZnvV@r#hXky}nZ~7OQXyTKJPd?S}o4vF}5=?A&bI$qBclmwS zvrDAmyrM;v`Pqf+Oga~tFXR^r`N*aDTx4;+kefontH&Y(rz7%0E;|F8Q>WlKFnn@wcxb4_hK51xILK^1 zToFR^gpesx#-)jn5b+WBvrj*fWkd{CwV-yvErkb9(jhv^9IEOL zvvgUbR#K;qnqcJNO3O_`ga@4=5wWdjHpYduIr8(9adDzM+$jWtfID2iOh^{*TL{5D zZt*)4fJ1Xbg$P^tY~yIF(7|7n*}0%}^}e=6OMT_+2Jm*>Y}_Se*4}9^8|`rXb4j~x zw0}>?Qsxt*eOweka_Lcc;)NOx5N!o3*{MC{ugDKbtvVtM)*J~|ApB?TyPv6jyXyNj z)lFdjL}V#j%zQr4Hxd5j%3sCI|Fi>O$HEw~Oo)h0?!8iwsfc$ZrW4Lnu$ZBSv{kF~xVi}fBr@w0QXhKEn#5I`4X2ag}44@%Oq zn7*yCxPW&Bgtiq%MYdT5IQM$s4bar{%q~IU2;YOtKE4;1W*&xx{D#IyjHDhl@%Wv` zL&_cx`Le?E5%0yjA|$cfW=@RSlZg>SqqP<;@O@W6&3=fAJff*~oFbP^A<5J*A#&C?M!TrztycVwCHyM!}8dZ8yx4xpW%X zLv{mt z7Zy=Q)(t$J6F1M=~^`WPTj+|@Neu0IEPBN1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-UNIVERSAL-TIME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..390df6d30d69b4c8c9e8eba3cba2ee27ff4532f1 GIT binary patch literal 1378 zcma)6-*4Mg6ux%aG{2f9SzslUVWk2jiyJMaLtT0DoZHmIu{-;^VF(FTsk>N8n<#N6 zA+)L*AcSPJg^A%iG#>a1roBxJ<$<^T2fXr*G%@kO!&J^qT2{JAAlbh6oO91P-#Op$ z9ir(ER9#X#J6*5s_N30h?+$!vyVH~Uok6eZO5329K2=SNTw7DrTIs!V!ainc_S{Y1 z-ID0Q?Qd;<^0rjIASvCR*M`mVGKl4s^NTA>OQpoBV(XJ=|LL=|0&a`vN{NHJw}ngx zA=E@8zQhsApa=@T2{JMzHpQ!&POzcWi5w2YAO^Ky$0k-7WEUmB)5UG~s@vw}?DUa< zP@W(CE`-6E#q)RxR|&-L;oX%!M4(zAa!A5RiWw{wg`1BU_l+z7_~3k zl+;BLPUI&%t2$8(XC1GaR^67FAPUcWQ&VQiNE{5Q3Q^4psf?-mXD~RWky$XO|IH=K zM3O8XNpVMFJaYtn0(42msp9elc$VJi6nB*s<1!xWIlwT; zlut}xdv?sh;eMjnZRwogDwB8xvFB5 zNm|CkqMNM1m#^8Y*Vudw!seczUIOZuCZ(R3>(_v~nUCrlx@OY?oXT+L*K+$ch&9nH{00v zc3kYceV?2E41?Dx?4{zKQk1qg;r7{*yxqyg!F79Y@MCwv@55VsKF+EZQ7FMD8lr2I zSc-15BtHiDE;%M8tjK-83WK>9An3dPpv&!Fgh6TLA^|qY^4e!p9H@gCIiOU>f!)jHKS7akVI>_7h0yKXITcd_WZz1`Z2`?&A`(@xiGLbALJ zpM{mB;!3HsFjl6vamn^yOlbvRi;D|m7bnM3-bV=4(RmU^5y~S4MTcQt70ec-tQ(A& zw8GSA5QSOLLL8g%D4Z(d!0(WzyYDs=IjtU&5Q;v8*|KA5LbuH5NO~>hqW9s1ZjvfU zqiYPw+21S)yA*}ExI{|C(CsSGD^-J4m?>z2CR>c#5YfqT`dPBt*T&g~blOH+-!|m! z$=N9>l^yPT_8g(rgS*Y*iisKc-ZT3T>TmCL9iWw4otsd&d^6 zB1?aF2uqE}l}tRUWWj?;m2qxyVmYGf2vr#cKu)FR4jI;MH3l>Cg=?N>6olfD#K=?? zNYZ7CSE#5Y!!(C;@apP7vGfS)H?DMO)Ml6L@%SvDGq&KMr#b`q?SD9~6rmwCTuX&} zrp;uiF&E!bbhua3>vf3N>NMS!+YV}h=eNne+wCPWaC-rZ!n*<@o_O=jcd=W#=@`s9@yU&W0`+r-mJmCvC9H6UP!Po3yxL@(?T;kpBUG+nR`Y@H8`T=6m0J@0%e?Jk?FCd+lzs<@T^Q@Vf&a z*S#L@dxKuh#dW~(OWor1)uyIz=N{yz>`OPbo?G?ZJuC)pf3N!DF3#V_TDRA1!De+8 zj`_8f!dkJIn<{CxIcEEBO>qs%iuZC;7bnM3)$yLMZ$Yq)QIdg<-MqNO~=0!uP?9!AJ$H zX&V&D>EA3dyA%f33M-^YOp9$0+YsYc=;S#0ELQWiakeF$cF>b=Tk_8A;+&L7k0hS$ zBQ*aem5~~!-x=(G4!7U29|#Q_Z`qbC%^-Bx_;O=sWGv=^stiKs&D#91k!@y?oCrS# zw^ZF?>qe}UY-()Xq?|l50AU-pDo;QJbE>WheUor191a%rQ3gqS*A}!aOaHzQmKsef zsc2G3gY8+Ba&B>AIilhSRhfi>jH&0{_|kl^9bBLeWH=U7`Xc$&$s(nkdK3 zbcb`wF3lv89s+*-j}Kk5>6ks5UWDqDEjak8EW~pD4p}JxmKZ5fVQNVh_c52En~DKb zX?dM}(r@}M=~UY;@!h^p!{D}n6)zuX%eY>JZ@Y(^o$-&0v4cBO_&Ge1LDG`WsRq-$ bqRfN|bIr7)>G&D6f9zO-MhoZ@zPR`W54rIA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-INSTANCE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-INSTANCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..424df4b37b1f700a5430a290a6c55b22330b616e GIT binary patch literal 816 zcmah{O-~a+7@pmwA3z}sQ8C2egv86nA!$<#qL*=)(uM78ot+g)yfkHNH|bZ}t%)%b zIG@ z(e1-Qci69cupx2yirAdKE@QI2@*qFuTso=uy;|VyK{50Od$pH$Vg5eEy}sX)#oC(O z=GRvX>&4>AR0%uQ1>1jnitDnicyDFu{P;-Gy8wVXI7^mE0Cb>%=pfV$K^=igrbQ9M z6>3DID9lPP$aN@>!npzrx;@nLUU;p5+2!=1K`ZB&ySkAuLCs| zeF|?G#AX|2q7{`f+ps7{k4%ZMO~+6tWC(Kx!Ge?#r^4mZ1R1B0c6J>>E2{GE4PhJc zw3dk{wX8HgYf#Q@j%-&{U14aGvLR<+wu{ENW5hB6J%1(0j0QkFk))TZN|JQR<`pa| z$z#OjoU%((iIs;EzxLM$!4AD(kEa)9cg7K1`l&9+TE7~zR*-0Fti_O%OS9x9Ybm~| znQ}7iTD|FaJmhxvqRmxf- foMJ)I6?K*=D94r)Pbb%;fXA*aXuJSE!}Igs-P!Xi literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-TYPE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-TYPE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a0734874e7e5b2377a16f32b673ca4cc4bdf2ea0 GIT binary patch literal 1052 zcmah|%}*0S6rXJ=w0zVBNvp)b2BRh$hgiM>cv_bM7PhlxcN)ONn5HbYNuf*uO!A5tyInz zKo}bXH8C+VI59jt&^o0#=0&yt<_u4WG{`wWI*{ZdLMV%B;xB@bjDpDD^JJ9~hv6y1 zB$#SRqWV?e3j-FMc8KkJor6lHSi%MOxmyr$R@ae)kpIC8Po=5O42$~v(vH;bzxO%} zic?u0;>ubgL4K7=~JZ0HQjS2NoG}Y6# zO=!cexg>mV!Pk9>N!J{5(TTU^ph}CwY`~UsL2hqcUMV+D2#QH|AR<%;xd{i>OvU(Sf%k-k z^AjA=Y9^b@uerFgRf3PZUJ;Ic-|J%_EB)JAzp|2ncebqL*Djujux;OY;(Hy7#I_dU z89f-AZPdm`8?>RpyA9gdXpirO7Tt1jQ}Pe}{QwZvtJ_3l1YhCHG#Ifp)8TC*3{cFc NEk^iF^!eWT`5*iRF6RIM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-VERSION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-VERSION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..402dccbecbc505612fb1bcf82da5e39175e50ba1 GIT binary patch literal 813 zcmah{T~8B16urAkKY)UT5HZBygv6JPLu^wLtiFuPlrC&%>+BRH@uew?-K2DzevlX= zF+TXTMhlVbYWNSnB1RtkL;eGtEhZX#@M-RzoqO&%=gtrkPYnwh{(i@6xn1NB`kg@^ z?fG5Q^9S9Ai}oarUK%#1ugb*OTz;6FaQ^z!=(_d3yNkrY?d{fI+(Wqsh;+JMOBSoE z@-tUl$rlTS<%tq;tSh$v_7sY_eDQvMdE)Z)M9KO9(145h7zfCL2H{bV)dh6~E}0g^ zj8v!|4#OZVz2KTdc^J&(QQz<2mV4l~VmtdiPyoUYLAq39hA?dw9xJbvO!z*SG8wK) zYh;~*n*PlavnydRmtVmJTp>o;WE5{v?#NC!JxM-`<$P_PZzyMN*!s4iZci`FD2en) zB~l(qeD04AgE;hxJ(^sQ-6=8Cm`>l@cn*76cejHKvtZ%GypvKFIT znko0PUvD(Mwu=wkZqM`ExbOD*Gz{(td7`C5vV`{P^5yO#uYL9CV(jp)5`GSkRVixG g;FJi8uW7SPK{>IUXfnPg=Rc|0f=2W330+?P0!6R#bN~PV literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SHORT-SITE-NAME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SHORT-SITE-NAME.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7ff05ef318653decc822b0e695261990249b23bb GIT binary patch literal 813 zcmah{-%ry}82#F^AHcvth!|qm?IJ$#`n!#n_mFlUk#4Wu5yje? z_|(d)#d4`sn5q!R9JBqmr&QL8WlbwgU7nsuc^?3paFHC70C`X#ItueDrw+#z!=%_E zHL6C#D9j2k*mWq2!nq;}{4VZzFT74-XTJ{;K=d)pR$NQxhHXX1(i=Nned>GLP$G14yQF)`u7I6)p%OT z#FI)^_?}fMV>ZLK%j+&zl}XW%Q;D^MN4TTLB7nShEys)k5KkoGrRsttU9nk>@LDoV zcNwGBm8HbeLxC^+^`R4oj@jesCDEO6I1_&Ai=w`9EoG%Bz|=^JD)yGPl0oKjd`mIJ zUivM+7vO$7@bE!n-@}2|4`>wL;o?LqhhzoqHN?x^MeT#}qf4;EyHfNeI+lf~Wt~wX d_IXX4DR#_=>BQ5?H8KCOYjYYe!e?}O`5Pq9@;m?l literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SLEEP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SLEEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a9a7c5085dbaea6b945ae55b9c65a6f48ce42e24 GIT binary patch literal 1546 zcmb_cO>7%g5PrK(9RI||ZqtAq<7_P2!>Vh^u7gq|4x8 z93k!}PM}!T6sx3b?j7zXH|-uck&-4=pfq`f5E>crF6s{X}gRiSPrsX+UjkJvaP<{B(+*3yq{vX=NBQagjx#un%n;i9kk<>1i%gJ zF~SGkPo1Qw=-Raso|&{NYu8k2NXsSI(N;{653nHbhi?*wA}%VjrL0N@wWFQH(pu2Acw7Y03U+lwr9nay8f^J$h!u=xmta&I6>#n4wY)G&C`I{?(OaJ~H+mgQBM zW@#k*mM!4&^+Py`e?A0>WSEnCjQr3k^x#^VJ&Xy`WPHU^Qdtc4WtF+Oq)iIcx z!)sXu>!DtdqxS}y3OhHUr7Hz3T2N5u=QNBrfc}ok>jdbRcsfj2+Fc3PK zc#K2hIa3sIt% zk4~wT629&&wYJlLm|<@3&V=ucY&cE#g=*AV4aNWBA4HJ(q%Ihhj9e06?R|$Zvqt#YBS#PxI^Ryf^Q?nE_;;=qA$ry>7eX1<3D*-F}Fg zet>#@KWKQUDRA^sw;6r4PV~)%2gNbxuRo2ztB2k$;(f2TTYqsM6_*j|2JMa*mX^e4 zab>ZzQZ6ryRfuC=sr{EzUMULB^1|5V>4~KJ0MLMobQuLuL4o)vQZ-H;jw^;qu|=v> ziwAL(7g@0DP!>m1B^3Hy-0=>)P8w&g2NFR1A<9==OXr4d#mCZXsSv-9CJYPLL^QHS zLC*hHN!6t|x>;JpW$f4$zD*d#Ta-D13a2O8r>UQ>t@91(Y#+A1ZOGe`vr|$gKQwv% z3}E_At{}C}zFT7cIoNz>{QwxW-dY>7Gy!nb`f_V~7%kNitOCGAyD>dzscjYHO#Csr zqv^J_YNTHAI5e=xtYenW1fMg_XFH;jD*^14ogjdtU zbeAz|{dFse^ibe8{^Zb!L$B16@maynIh=_+wHYz1*K1Zv0?iD)XyWFwR(g^-m)uqi zaWg%?89uKE9zO7bUfbWtq1Ov(9Npz&Me~Pb9yROY@$RDb{?)rnvBP^({5d|Bg{?WA fQNk&{=FT)YWyExn@pPLo@YuCEO=jQ|y1e`a!M5}S literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-5-IDENTITY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-5-IDENTITY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9f5bf9052b8c4052b78173f920daa39b49b8417b GIT binary patch literal 2984 zcma)8U2Gd!6}~feoFAu-lelR%n|8ffT2Uw-*b#uL3iC+O8|F&jY z{5xq?%S^s9)n^}CDX&*bjmk>g*{p1=l-_(fKJ|sTy0%`cV=yy=>C|j;diLD8$-V{E z&idAl+;eVrYI-&~Guij}y&WmK$`~uNHi=%wqAbANcUsYe!)-@d(6d}I)ErN^TW+fd zxhMsjTW)J`I^I}aQ|gs(RO*z@)eR;w=H6-bEEEjQ(M`kMmYPz(d%JZ^Hyq2*n@%c8MNe_V(VZfDZ)f->W70ndqcVl_p!zT)-M=QCe3X%w#>NJvQ2iJ} zEKjt1@c%RIr8DKT?WIKd<@VBK`Lpde7^~5?Fk>{PA${s0O!~Tf5JUVO(m3YhFiU%$ z6tsJ9{m`&H?bWJ0+HpcEwTIX}bhG=URK0&G(l#TQ{%0$D+l>5@v90P`W+Wp^P~6%b zTN>{~hAjGNZ~0XFr|c6#_cE4)os4^yMwdomuzG0-pBO$PFn;HjIkbD)j7T&aa?O}I zat4cUni?bQiBC-vfh>+u zk*iVS!Vg;G3C%Q8IuS-mt41ozEoEK@VqCBja!B;bU0~y2LQ@?rtytVCSYVUp(J^Ef zZHMP%85%L4uUeL?Mj@{(m{!hC2uYTn-R+nO5f1cYq1&8ak^XRMng<;Q|h4jswVmqqC6M-0%hYv#s>c^oTPFP$`d3F+k5i(5krwyNg=3oLA zjg)Go_A?oUexL1NNAAGta{!|N3mR&C5S-hJPCeD?{Sn4Qkox-sb?e{YB*?#{W@++A zOhQzB)uHJhC^D^JS!nQs%S1@D*2Y@w;Pf@s=6+>Gn3i|Ij>u`lMDRt$1|PDV;0^5R z?OYgn5hcul(*e7fn>Vvc=lUUh5qNiA)vc^QR(H6iW^EBB zH5Bu;g6VL-NdItK!%z5CHY$zHH7eEL-PYvnJV&Q+|M~R36Hsh^Je@$U+k2r+(ykA8 zSa?pFlYh5Wi{b`#TVwUo)ypd-iu>sBWdNiMf{*v#C$IeH9tV>LVjX?&{mDqm*p-A}&8*bDd4bH8CR)`pN{GKpX; z*iIjjCcbqXPLmiU#n4d$TAFJa#iPoCs%L}a$RHdHkOF}(iRgexhD9h8MwaX_@|cql+v!C6-?lUl|l%mc;8Q*$xX)6_2oviXW;< z$bV^=BvY=7E)I1&fT4Hsn7RQ5dw?ufJQ)-#3p7}v-&fpidPd~DEt29qU}D0u&xE2c zE<)UH^>i+&X47qTd94iUiSuFxi_djvvfs%{-ts()&o^0<%x;Io*P9^L!A(G3fYu4U z0=NGCKu&>PCG?Gb6frcLq6SMcs@K!GcrotXzigY$px4dfiypbfH2V>8^Ty-H{{wfi BkM#fm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/4-8-COERCE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/4-8-COERCE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..28ae008bc05407395011db004897d4e31b35147a GIT binary patch literal 4036 zcmb^!TWlOxbsoFx_xc^$#YqRZX_8IG)JYl=C#gLLX6pVmM5u`kdP(S*EgpexnfmI}sK-8Rb@A#1> zP>^DI_T2M++%xCindSV4)VQRMofyyN?7TEKQ5>HrN+V-=sW3K?AF`zppi7@sb%UIY zDr$e*-u6m!4QD8Cr;GNmWKGzG;q+&=N$q+}^QsXIo{DV#b-Z z_te?h(Y~W&#}jRpOII)Rbz>aI4RH$yDmbo=6FKKXsV;00(~^5)aUyF3QJKgCx&=Swv)O-@2;N-yDr za?c7{=bci`PIcmh9clC1cG{^b2*4GIb%dN~S{rt^Q{ue*$7Y0J1dOmQJ1~}gW zaOEE&&V)knALk3>2P$R*dyO{0%*};04{o;M2hcJ$OM6o?+e5b^ma@5-12Ufd!nF8tH5oXt*U<~wqJ@P?8Q z$+C0QKtWy)9=qN#-=qii21xAq@2^wHcT8obGXHbX>+ToynutYdIpP{G6lCI)Q(z-K z8Y?W_wq^GH;PT!=HV-bqYs&#vvBnB;9PG^eBNzZKn!LqVJc#9afCcjHUG`s%4xk{g zLAdIe|IjJ{19|*zw3&s=6n03s;SVA-u-6xY{aDDNR9HBs8K!#-BoWAOYYXyR08UyV3VQN$AHrWoE|SOdHK{s=05OJ z%i_I@{wUD>w45k~+Y&UBM2#tN+F)`L$rVUWD5{~~rON}ktcNxYig9lO-slxZ)3rft z7=tJYp-ZF$KX6y;_>CP*hJ2+fD=^p zJ3+-K0o9*0^j<8g4|{zbYcJW-;aY(Gen`f5!)*Wo@t^MF2;PQkMnJ=c#(oh0=st-_J89;^Gq4V- zpvmm4Y90i}qn>eiaiRY$Q#Q$g6wxpn7#!vrKb_3aF6Lkp1^hcu8XtBCWWfIgYFii6 zV46Z#fE^;#wFvZ`-d@qW;Ai}TDA3)mtJ<9x5r_|OFA#g$w_9a0-kBTcb zUoQ5f>6O0?4P~6tq-onyc0@{#N@GWk*+WHXXv~Ihs$n=BrL;7ZN$1l;MfmE<7AUe` zDrRiS{`5GAf>7QrOyr7t(L%Pkseop(qec6uo!=%Em}N>wJNu>0z>{(5`PxFGIDDDg z(FK>08&PF(esdSQ<;<^-cHQiHJr`VjA(mVEQ*LQ-HuL#hS?sq{nZ>$n9o$=-QYe=` zab!4+o%HUrT!3AmXE~Oy6wo7mFk+ojEja{-g+;nyRGX=|#S7596*v>AGuEp?3XwsJ@E}y9boZs;ssrcF)bnU! z4!#eiLNT8mJt`sog7ak`yfeH4*B$^722{5JkZwAAxJxtTC^<{pnETSX>CO+I_`!5n u7mMk+>8@Dqn<#K*y6YOFojP05^z3Q;U>#*8YV2gN*>`t)a$kLRY3bkM5?4C_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/4-9-TYPE-OF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/4-9-TYPE-OF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1ede3032b1b65ac0e0cbc2b7fd9cb51e09001c9 GIT binary patch literal 1353 zcmah}-EZ4e6u*v>CQUzO=GnNi2duS3*dqlj!7-B*Q35hpec;Fx4k^i8alXPqw>rE_Y zqeCP@qI+Sc@9z6{YXeJxMNik5?Jg7 zU%k9?9HR`Jj}r2>5NpX*6G>oxLe-ei z%GBY)bAUOmPyLYVyMmhu>7N$DR^t&l9S_SHV0&D3z^!dkS1`d?8L5)vn|jah8VFW_jXWIHAkDE^FzXrAM6>xD6iCDeTb zy2Nbv}&_koA(X?}@2K6RmRgWm+-FPUtaQ`fg_%g5{;&dd(rnJN=y9KjX{ z6NU~`$qeJ!M7cKr9oOut4}`IzUdIYy%$U>qF6d%N|2Y|@S z-1opvI`aw!IP}+N_J=4uA?ls3a`F~CsjS!Fi?F6NHV2m(v0JCF>=QZ2ktm#M);6xL z)lhx3Ul8lCU%0y%eUywog!UyN_$W8HiH*Xr(ftHuko7EAU$S_S7JR`aFdAdUiU(5z z4BozH!aY?w-F9R1nsOof6bDmc@iZ=l!J@^}AQa>2b9Xau-Br(gu=~!HjjwkX7YTV| zcTqp~`>EZ-kdCvrlXOV63NZxv$j=Ga`UD9d`X$k6_jFbzA$Mi(|{{4M-qm9YD|k9 z?tQ$!IoaTuELiE1HKmyIR&gqQ@-d}HvIV+W3JHP1TQ174^CR@tb zawd}r;U9*4dE+=C?Temvnz{Z-9Q2=-4xfwPB4jCZHhxH=0nn~>9_hwde7uCT5OOm+ zxs4ZI%Ru+kGk9!wc2$Pz1jn+CS*ybWv%Q&61DWb0b=daV0o%`A4gPWlKN~~&cAc_! z2D&21@s3oV0Kj%PBD*jIxz@W@?cgzu&<1jop09KBtw~c=;gDu*cVp^mCt%{gf%S&9 zO1fL86PSUsoe??2^{J}Znw3x&P_aE3csE9F7#;bYIvqdu!80S$g;rdoF>t|&p$m_# z;SN=I<0@axhXFo(1w=?=f;h!8(}8G%r7@HpS%f%*ru><7zsm7q|Aww z8I~V{1ubDMeoW)mlIC5Gk~EQsPc#_LQ8D=LHv zp>zb@yHJauwu5z|@Ngmh$hyFiuJYB=6~0WmD8wtmcS?wE5z--iUM}b_d>48TcRv6d z(YvT=sC~;qD9-U^^i>gmk_+-P2gw~_eaC`NvMoa_7-qrUutxsXsq8LU#gYLD!L)T1Q zU3EobQByaxSd#fM3=Zt+RKnDGp>olw^sTR;+3Z4T9*R}^F=vi-qj(Bt&vNOyHc=kifYfTua2`R7Tg?iCn$} zS3hkl>A5MT2QEixbz`W^d6C=De)k#q45aq@0ywV7`+q?cDUwSy8+nnl!YG#~R}wTg Zid^3W>)r`Tq_SKt)0Iicr6Ug>{0UAyO>h7J literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..807f1de52b79466d2f852bc7a246fcd3b7a27d78 GIT binary patch literal 1009 zcmah{-%ry}6u#|#u#G`BLLj1%2IC$Y@62#SoG)IwJ2vQAylokaFV3yF#le>S&=4ar zKKN9lgGgEp|AViHkq7@F{{uXCGm)T)X_}sX_uTKC?>lFJ0$YkIDXpD$qiJ`fR=?No z_oVGsN9wlvovJNu11`N(bVgt0iL#!&pNbe4PO2Td(z9!l*|)p3%HAz0bx$JgPNNCI z@-qCUGE0k@bUGQy5knoZ{r65flS*gOcao9w<0B!~LI_pS8UKV4iXk6z51g26Qp3c# zf=aPQid1$7t`h<+*fJ<{o%o{EYqfFHer`9poSiNb5OO~_p`4{DWBM^ z1r2Y2G_p#O82Zh^*#*~`Tf&R*sHC`(C0H#$$#q&T=`3rY z#M0zkTnKQKzY_?ZK1FEi%~({ZpM2LK{yA8Gr~N=^P=Bkfi2`IC)W6J>h9dcu5JFLe z&KlLJK|R)pAu-^7bgs#Yu4N0nYn&%qR;3KD6adjy4O#Sq9dTJ9rjo~unic~&%FvIX zQ8r9k6otPtOkMWIePdqO7Xk|=Wy+Y&ux^lU1QmOAQ5C(?D zZ^O`n8mCroc(Vb`b*}X6Zcl1fcAnHKxY_9T@H2bwMXOWmuDQ;<$qyIy$%3?9f!(c1 zjos1OacuwQRrio94kz>t?k7=sp#+0*L*P%qbm1FM5LMMnSU2-vHDJc@kXT#8>=ixB zvx13IURNnZ(FD~t3ryFFAbR!)g&#Z~PCtfVg+`6?HZB_o^A?5%f`_gnYzYBgCI^!h vM2M#Uxpqi!Kf8w_xOrV+l$aD>GF2^@lo8eN#(5g3duZt<^=8ngt)(Z$oOSJ`;k!=YHf1(&`%UN7Be}RHD4brFgKiJC-Is1VvD4{;01$l&GgaGAnPwW%vG7*NM<2sU%|P4S z8r~ovX8y7y>_QYiSV7Bt>A1dL!90rcQjAaw=~`W5aC(y7O>}*4oo@+Gk&&%cLTAB;w0&+ zN$Z%^l47b&DKV}MCKeuZ{LVigDz?ZKJJ*4DdTLZ^kr#v5Kyp;dD*;>4V&Gty8+^lJ~l7xl9%0(Y!FJ- zfYmyl{ndd|K3!fsNB z*d~*gbI-Zwf6l${zMBz7+~M)bo0>3lL+z{rkLRw>sYF|HmrrhN{iR0DSowGtF=a~ zlpA7EIzw8}N|mgUlZk%CH1-)LhSN95unc28nR2&u`aNN9z;BJR!)&2-G*#sFD;*G; zx>;j5cSZ|pXRTDhI^`CnL21@Nig_+wa+qOUr_qy%==nBwJkE??XydlmRg|#eZic~$ zB8HjF8k&MB0?90$8Y{m#woCy+F^i^#qr=hjz`pRXtCEe5U-ZNH%E*?-{ckeNNc0hZ z8^?n5$eAVE>rpvAZiXoY8?ngEBqbR~Si^C|m1P}xQRLECt0{p&I^JkXCJ$OER*RVF zE^zR2iko?6ky(&0Wyt8~y!p!A?fB}>^0n9G9H&lxhdBx;OqvqJN*(=DhT@*4^f)}o z=$`g<%;#_t1y|{70PiKdGbWY*KK<*ccS4@Gu=y2E*m++m0@} zrqPyOQz8_{yRkJH%GGpKITU0>6J}Aq(*Re4nU`+kPdlL$fgLB5tRa#zWCWLvn~R+| z=c(a^2OSp*q8DdaHgPf1Us7)o^KkFjJ$}cBu@3ZVXZd7wX9YZ!@Kj9(%Ab5FP;q93 zKTyto7x4-!P#LJIf$2vBRndx_mB1V*=RoYtd&C4PfrWEv-daTXn-f%VR!CVxh+`yr z1pYda%u6}N9gf+OTwC$t-%QPm1*ycburSL43^N#HF?-j{op73XtbTg5lyW%h<3uh> zyM2BfKjk=HnsF5uZLWV5yE0aNEsl9=eb*Mpr?Om&nH86DFXLzy(HUma7zK`KMFmnX z9S2R&QzOyg*nD~UuH)sRTrV>imb@2j_x;;>`OGTgwM%#`dS>x|dpC|mi(|zMx5)Zh zstSx7x0ViJbnorHWt)s!C)Y$1UkbV zo#9%(90Uq$RezU4=%HF0P8|yyW}RLZ^9*APcxEy13~~ZgNiBh3yBbFH88qwZ3d`loOeX7Fq5Ke4{gqDP~ zurfM++zUL@pB+fJi|BVX z+RG5zM6oplNPoAN0#W*ih)Tbu;4&^pXmQeL(i`@2WT8owPQhG}vA*DissXB?}J3~uK=Cb{LMH%4P!ABR)b{bMW~?^3I}07 z!pY}hvM?j4gu6O$i{eL#MSdHx$oq*YzKMeCiBtRn!os~nShydPIc}1I7eFVArnzt6 z$b+M2?K%WUDA;c+i1kq5p}O2u7ekb=f2H7;M1XytaI%+CUlWM3@8C$q(VKMYB4wPg zS0nK>C7z+vpjJ%Zf~ph(2h@kwkwCE)jYL5`A*NzT1%3-zq11WREXN*3qby`g|BA zmp-5_m3wr!lIWIWaeAA8v3rUMKk!A$5a4rTjhpbFKrB_k#+5bWCI11i5 z7eOu)B4?!vmo3YjW8f8HrAi%C^KbJ81Ag449LJ8Le*awb&xmLr=@5G(6vw`u6kghG zrM{3;__*F@$gx4Fd2(nV4r>icj0=h`4p^9o(9XcCH7sw0*8CacERJt_@h2og@i{9c>hdl*g0v^B6c0Y(@PTZ4G8>6yBX^}42|s#1ljAJ3 zKQ)SrT<5$T1! zJPt`4iX_q1#UyFMuhWbOcL|>BCoNCd%9|Eo)R{Fi=D;!dIn;gA-Otn(lW#on|~n@5e8g9NrU5MvZFz9PHgy{OjVL@k9D} zW*nV3q)*U2T?NqSZG*3Q7{prhU3176&v1vQ;3u;Q!u2~3rz~(4K1xEko!10m7l&PC zi`KP05Nw8x z>+BXcyc-v&!Oi4z*ZB?>H^A$nc&3hv)wupQ-kuRki?3E?<$0SEdHF(&6rNu(UurQ3o)ld(3qf720_>1kw5%NlkA;&U0jl;?` z(_nP(xpKCwS3lSL{+=r@o18w5^_lpp$(=KW@#sXWx7GV@)Y}G|F8*Az=Vp{agt+r+ z0v&iAp!#4JCI<~0tTQRVc4QipFG(}kHL8s)^a!LJ69#7K4nQuob(Gb&>H?T%BDf+X`t^PMMw6Dl4_}Q?ptF z`vx4s2jC2lGzLg=D@bzL53NzbUTxRgb(jc#L0LFW~)i+n2(@;q(l56h}xZ3gconj&!Q|55cn6K64~DTL=G-Ox=8+-LO2()WD*8$}qW))AT=K zlVoW&44<(b;Qvd(} literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFCONSTANT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFCONSTANT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..39ad15ba0cdf8cc4e2877ce2301662757842a43e GIT binary patch literal 3601 zcmbssU1%KV@!Q>#bdpZ;>CdtyS>DK!8!ui(k`-663(o4aC!Kw_r|j!wBQl~N+5k`p%CapA6)vm*mUEzi!2X4S6bt?MVn@fSp8wd@q(V`>V}(`P0p&zyRGv?Z<> zNv7?|WG2T(TQ=Wb=b|M-NRHe?&`d~_2*iKA7L`oZFy(k6smhv?QYC-QuZ1BNIb*20 zU+b6Z6I70j%*23|O7BdrR&A-jvG-XcVpLVtc$`0zY;*Cp@&`aGW<=c;mD>%pEUzm^xsB&^*U}VcY*IGB<1S*!1vArm4KE3XaXc(2$)nBixZ+3;AUa*gcPznqX zKf%j;&X%>qkBj8+zLDJd)^1~;)s3}5ux_KYx#n!A>9NZ9PZPM9j`pFmUAwICsk)Wc zD<5gg8<%oJ+d*ZAw9PlNL(7}nX1`o@_|NOMBIrTx__ihRZ7YL#KNtqN%pPCf*hUI{ zeSIi)|LLo_D{f)2?n}#Z?%78idGNtVkfq2gjJ_$ICrqhp3xOV6m8p63Y zj1%f4gw%+6QcOfofP#)#M%Pts*W9EWo*ja-?wyLn6hmb((+C{%e}{^77^*4Hq+^*B z$SYVlJoz)&2+!;3SW-!(knnpth~Pcihu~e>kKi>rfFKXdEqhdC=}|mP(IW`XG5Lc` zzKh8VfjswVaK`-t)P&RpB?o>qvd z8)Ayf#>LchIw{xR1(YCxC9)9+l1~Cb@*6tvZQ56*{Wcx=8a*o0BS-1r31Ao6!J~%Y zjv&?uuS}zcc}EZV|4^(3|4-VB-~j_)VBQuKJ)ywmK>A-9{bPC%vHJ{sj~+wp6{g{3 z1}r*)#7ndXfyuC!7#3$(EWo&b2jbj60y*vr27ZRVLd9mWe%vj_@*Q^OGBCo3M;O+@ zK!`pA0_0zi+ScG&!h3iMZz@uM8Ay=#16J}=2G)U9fQF=<-=N0~Iy_5qD za*TFkXu^nJJLB0EPt4m(xsqG)EY}ld(JR>ERjXLF#j@>H%PuS!P9>na)`|_xxuR9J z^Qhq&zjo9_4MR7SA#urqbp@DRwrL>kMv$(*`L$5RD^Gw3|0n-8559%#PdbgT5gQ=RCOh3&QU6V0E<72PB2-$uDK2(`_ zLcX&s?BF_0zIyH^At*f~)EXQ>`$12LKXt-}-!E8i>_0V$j zLHWvdrCRhvt5R_;V^zJbkS5CXzD?d0fr{=hnEfXxdvj_hdM`Ff0Q zv=Uk;&A3YmJsVG>g5&4~R09!{|FWWd1;78YC&A>8`z3e`ng0+Jg}k}WA9?XEY#E{5 zTZX>80Sg+W5S9acq`Mw|#^ZWAh0iqhY+HTw;G5{z`f`?+E9{$Jo+DiF7{Yr9y+2|q zv%+D}(38-hb2TL?n{zrm-SCcNRA}Ra@E$aMGqsRR7-obHa#8v$7iQru1hLH^Vy?96zztt2msZ48>#{ALp2EJ4CB5VdmCnK7)3%$P^>{_JJh5n7 tpkdW2V?PzIi&veB1Dzq3+@Mn`@XwR&p7>JI{Vc3*?%{~Yn}yBI{{f1K7-s+g literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFPARAMETER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFPARAMETER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c4ed27456230923571ea515c4a33d9f09e193d6b GIT binary patch literal 3811 zcmb^!TTC3+_09~B1%ti3%my%?IDqX<2C>8-Oq@F7Wq`Gp88SQTt=lNpungXTWtZ;5 zZdwIdk(E@{R0(!V=caX4DN=s&5jP)=oJ3i*l`6GLK3dWK_OBo5NBvV(?GHWYUY3WU z5o#*!=-hkmd7pF7J-bF~zaEXt(fsm?n{^6uzFb-`H-d`7jc|u5u zbwqhq8CE8=$ywC|HI`kR}l2rcbeWY^fKztLp1P#1ax7%|5^Rzsqh322e;<{P(Kj8xRXgsN|%M^cnOI z5nyD+-BNbq%N%*)Kt~?T?bh{0RaZ0k3TigjQ)duthw4i;92_dJ(+GB<-EF&6iK|sr zM;1R_ydJ7nSVdpjcsczHfXxqB;E~Y?Ep1#6rTZ$WJ|ndG!&KiAShQ^urVj)dA)diE zjSx%W8%F5RIh2l7t!b3&}s*mGiG^(EX}GN2>-c zr3bgHdGtYl6`2*&LkHUU=+NQ0n|W~jpwd{&1l=GJkNQ9IdcsjdpNQebRi;&aBCeUr zr5IrJsYF<8qz&Q`_?qEsfG+?YqMdh$Xk1hEQ~p0sBxmF>S{5D|_WehVcCOf7N>qk2|-;MMiKR+S#LcXrQByH_&5HbhHNBW1+>rtfOYRKT-oIBVa@UsO$KJVLYyk2@j1EeXw1CX8ru2KZG> zGoI9dj=-#GMB{2~1`y)ksf^%r+JoTt^aO&BXfJ~A199WyBE(nelXzI9ClS2N`7dz( z^PK-I;}^bQXTqO3_ytI-(XOg-U=!Y9^uo^>z3>*Nx52BLNy8YXtw^JCny+!1K~B>Q zuC;?}lS<;+%q1hPR9_$9Apc^T$OdC1e_)K{SG4!rw5Lo@IJEZyeNv$(yQzEz$ff7O zqFPp1xH|`LS)GpIM+>EXI)I>;K7pW{1FX@&Rn?5CP*I3)WO(u4Gz2^GpB%hTF`weQ zOoI4h4&I=r5qXCmNAMlKyTx}|zH|Amm$P?pzB&ek_s~{I+!Ur!c%6|5tNg6MK_5r< z@LiAti9Q7k7-y$=|rr0+df za*8E+-dR|&3-+>8f~iK4OBqMLX=lrhTyRR|LJlStx5%(LpaJT1)-E{nDB?xmJ87Ya zQ>*GJdBKMH2Z(cgbV1xIEB`j%t0|TW!^lGXdm=bopP1F6F*VME{5L>Sg@^c0{!ftP zuGbqiHPzCT$1X!W27`qfPtYbVsrJRBVQDr&!LG zWV={&Z(veO`K?qJTzf9-pcN4o5#g`gm^MHOf8^^o;PVZu*+Pdmu4JvFsb$V1Jz z%SEUwt_+pWIkGJmSDZ8$FGoefj&Oa%Ba<4Cq^38PdH^4y)Zm*?hftmb{)9hkPdJ9`@>XjHVdjrIj- zpV-7YT~d$GR)NOFW9x!6i*q>b@V)*WnLDff(qZ`KZwKnBStqqyCLNM}+c-g>GbjT5 zCI8@Q?7;P3_QjWc{(nm25X%1@OCx!ET{`u`!(F3KT_t;=MGzs@mzOqRP=vt4#DZ77 zo;}vX@R+heqHXV}F=-kzI7&z~<$GOeyOhoxm=;MO0t+0xyU=m^Ep}XcO9qBk0)+y;-%way9tSD)r{9;d*k)YGCONG5Q^5bej z?l%4tm~?O9w~PKbYZL9_j0 zeHTsKxo5!pqm`-Gjb9P6lDJ}=lqevs-0Yk^fKd1}5aNMDla9hotJqD)s&>}{#3F8N zNxiuC(XrcF8xW)l|LZDzBT6A}RhPb&mOGq2T{~zIkdSTt{96C zUjgy#AtTY%g*zX7^r){hKsKrdc&f*PrC{dOE66*CG0>H;V-*Sx5-@vs@!^LInDqa& z>919rnl{;VY0>dlOn7u#-L!Z)B|FbSz!o#ze#~d03;g3!Y|p8sTYxhT{_rClJy#BN|r6O=~*hXH=?( z^;&ppU{9MrpxJ>*)za;#1x+QuyHZ``RK(V&CAxKoZTgur36guB5m~77S_B8mo17h!z+hJp;-_j$KT38=j zzw?-%waZ>uuJ>bK8%EX#>>ht)(h3?=8+Q*5;d%$G*FXy#g!kQ*_hHr!efH?)KHCB% z$7-;GypgT998!Fwze=jC6^^NXr~X$_khfv1M3n=@X)bywsQmfY*>QAv= zB*(cibckC)n*>ZVhan$u7;=jX$y-ABUABLob$^~IA$ITucA%ei_b{aktZ$yyrlJOq z@DL!&*FjdxixRol;99LSFvaMh{8e@s$*XJ+lA<6BpwR#Y6x5(@QGQ0qKO;zpb)qmR z$cvmvAFz*sQ2IN^ll~&e?^r(y-($OxyeqhO1b0_(KNH*!1(_EpuLyNZkWVrnsM9s{ z11e<#%ZUDg@1(!wTj)E2WQ8yxxYL4|>={%TV~3C&WgS4sBfgWo&$p023i2CFC3FRz zO7e!-QW9&+>~My89p(+P{&D6#!up4pw~u){nHL?Ge^f5LRB-bJCGO6jjpY!t`9wdX)JX40LfNnHIAc z$}V8F$V=r?O}>yD#&@fHU4qcmN5Xm_sD(t1j)0IoCoC5Gkwb3OTGL=jx3&~hY6&b@JRDm3&GX=#(5uclj>6DuniGvg;V{G(#gDutBIWuQEgOL-`!%9(|XGUqBW zC7*R2uvr-deEK(jIQ`aE=qpbOeX(2`7#Y>!V$j8S&c8XhwY*HL^?4yusaT8#wN}aA z$_TS*a)kM=71F;q6H{G&618-^{Xs(70H9fmKxF|~qELD+aYY+I92 zV+wC1Iv{=u*of(#t@T>>1oetz43+p#fxNdW`%m22GOkKa-Tl-HZB&9>oLqbe6A&Z; z@{S!+Oj$TZ@d?noaYh`s%xRnfW#*JiT~4gvB(^PHnG(ta1EGaR-D_(THGP2I5j3FF z8d^xTCoLESVakZ=&~~4J2-TmSo(Tmbb_?sSXNt6+eS8;ls4ODoU|o?rTS7(P)*0T| zH8|(Q@~+}!vPo#X^SR8Dl8v2lm7~Y7BL_kSy!pwSO#Q4t_nL5b86URn^_^OY6_k`4 tgZn5O%VB>^omb8#^GWP{nKZw`^6(b|H+}5MAr4fmp&Q*K-#)jt_HS^K<$nMG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-3-EVAL-WHEN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-3-EVAL-WHEN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b451ee233ee0c6e137ed234ff3267e4be7456124 GIT binary patch literal 767 zcma))O-~a+7{{O8rEgHMB}$?(I3eM(aY!pKB3>MqDJ?9sFgt7I*tA>Qq_j<6FvduX z2TyCX5Xr8F@8A_Na_|fJ4RE%YK=5Mbu(SV}=l_3xGc$n5bHhYNYqwo*xE<8$_uBm) zsJ>;(Iq1@w^=L88LA&PZ=B^MT=o4-)pDq%1INpf2^y;i92Z}Qa^nGF!?T) zRB9(bnVkO~Y4riw$J&>{|y1URdgCkM4uJq2pS|Lon>4U4T7 z!Ul1kuvL?C{Innywr1<IS-61SJ7}H`wLW@h< z37v9oacnta%MrSkkOfJdupKNhVr3}Vv@ci9J)<&k03th|jV3ysX%!IZWtV|#A5hupnV1HY`fO_X`!d-p`B z&FqsIR4vK3SV8sX#WM=E{aMBT>L02yaN6LM2#T-engu~QG3{V1+$OWP9ZS&Q7JQjL GKmP;%V&td* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-SUBTYPEP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-SUBTYPEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..50d7da4ab61833923bf7ee4a8a2926243f3d0c7a GIT binary patch literal 11684 zcmb_C3v^WFnfKng^U6B`LBeZ5f;Do%03zUn+)QpVLnd>_J2Qk>TnR9kupvqFz@n9g zr;nX#F&O6;S-SSDwMUNvyKVusY)j9!>*;YlZr#)Ewsq}lYxQh((fU}ovftz0$;<== zY9KS;{oddI|KI=r-~Zp)FS*wSBY|M=*1oRpRDYm%Xs~Z+FtE9|KQPcc)W0zm*bMZ* z9YNDF?hNU{mW9{W6~%Kn8~alogQ-n{#87HrQ^)oNfw~m|y|2Hk8y=P~2XxuWrAt>X zxq4wylOB(-wF}W%wzBT3g+*r%jmj0hk|b@EP9gA1QibG_G7qFHY7<60p*4jgh8ERZ zjoQrqOxg!+(UNh)%A_k72L^llwC>clR5vzf>wqLnQs$d!UsEy~OoYv7W<(yAOEUMT zOT$qu22InO4N39YR?xbfNtZ3t7Hf4{JlT+Fj~OxP&}h{zNh+c4i*=b4I-+7l=)}qK@ zcmI)TZS(C2eUemysvEy_>ZpHVZd12AP4yuaKcITS9;UJfRLgOZYyShszCXwQu^BnY z!JOye&f(69bFK_J&P%yhySktkj?HAG6Ol*Y8T}Jyg1x`)crUh{ut#(U1l!}pwN^dl z_$xv4=q4wN5baigQRL>-f=Bqvk+4${auzc(AE5U5R6VB;bz*(wc>b)2voiw(E>avc zI42TpoJQ!F(V3+$ho?@aUdbXXKO+Y@nDdM&WM!2tT%|+JQVx2e>!@0=HT(OJpY^T!^PF%-(y-vrML39_> zlPC)+oz%`7@-SL|v%FckJZDECHK$1v*qrY;%_(=h(u(NB$K$ooZYsw<%f^WJNG>w* z@%chdd{iZ1j2sdLIEHF=^vuNd90`=Cg}ceb=0j>CQ$3kq<%#Bi)-w^y4WeSq#k$H8B>^&R|Wz;oC?$VZPb>P-E^ z`P}<*xW{(n@Q(H7a@GTaQP?{Nv&Qc@x$F0_8MXnOH}=AsoeU0+IqM|f`QR6vJP^(5 zYTOGuDLZP1K1hOy$*LVC0@Vpv*37%0)^c&$<){7N}|%HUH3pAz^K!>1HJ ze)#y{bZG|NaNEht%oRP%b`?eT=sswf~anTz6J#L%P3nAT)kt?^nR zEAn{lgjp+!T~)&Gngk_qS*>ANrlpz5L@b%8bxj6^l3G35t`QxLxGn*?s#+?8p&{{* zme3m_PIzEjDpit%iuEf3-u!2D?gXs)P2>AZQ;13Lb&EQ1_&og+6 z!Cy1DkHOa&^fFk_z+`X(gDK(?h{ZQaOhMohQvrB?1_2k<7;6lxU5i6%MGU0=gfzS- z89d405Q8ByRk25&PfV;`Pld(Ytw=%eiK`R69E%zeE z0t_k{xG5I(WAd*4fnrf#W9;9U_X1<5n0Jh^Z%~}-y%eWp#eY>qW*+Gw*whJ;}Voj2&Qb4}%?$&$A%YVG@R6GGZpjHCSIX zGnNRqhHo;gIP|dVHV~UMCZ-32Mm%mZuP>h$vy8?tEHRimt}gcS7aYNjFwdsf#1mFB z2y2g_H5$Q)j!;kNxFXPObX^Dba7w{x+KL;ET2>wnUd0A$7*vbdNSq`B2uj2p1a9If z|4TlV{}ywBsQg@9hTs@=z4A15y>ghkUfD(+s&p}EV3AcUvWP`g;>jN}c#FZ0NK*a* zNyyi2lQX9g}z(DkG5p4>uwb2K~Dx}`Svilg@ z#$XHD4@VP5GaI~>$li}AS-kI1c6k4j!6}e+>z1XrgE{XrLPyZXl2H~}#h?}?n<6G{ z?B1E80VT^BxCwYZWbi#w_dG>pH#Vx@TkmqPcO6sr4GiqZWNgQvk#X`|7UfV;t%VbO$e zKMBMtT!W#G!A<~ZnP!5S-v*{9m+&pojOIsy?#(kZ!i;-F6Y}=~e^S2D9G71MuAkx< z^R!*8M#Wx%g^s(Mu?^H^?pqj3iZJpl#zG7XcDRDEWugT|Y8ktnjZJ6lQZ`n?n4gVd z1v;l-H1gxlhN%9Dny8);xEQH#gXXNpAaUh_flr4n<*vKHU(2Y0|AgRKlUfT)kBk`|-c<@z$LJeTBb4f(~#S`H)0>aEb zv4a{Lch@W=+fn6^r?QC(20Q_jPeB%zFA}rkQa%)I&`-+y6oB$SB(MA)g009_N1EBN z+6dy2MfoN3Ut(~8(o6X($}8n-48B5BPg&1k9*az8UI_vD6O2Q*8o~)nx7w+H9kC9<8w`FUZbs}evMC>8WA`z*f{6jfDhWux21jMiyAiF~GLt+S z(vL}6`aX+2&EPSRE=;ccD5bxlK%`M|3j`wF4+?q7RUnvo9s1EP8}w6VAe z1}hn*iYO_nEg-pXOqvNJBx(#mR4kOQ6V-L1dakIh7S)~LskAtgo-r`Afo53Xwywd> zK*zv9Z$G}+LfQbzcr)qQiPXSgVD1imZeViwp837+N5hytDAk3;_mXuUMo2cwfql_@M8cX~tC`5Gw6?2NTksd*Wsw zW9bY-3{RzF93B`CPtlzM%u08IM2T%8TZR2}R4T5A%O<*=yQo}HF%e|1sFoF>Q-^zh zi0wpIduXt{N3(b-w(Btmy>};~kLIHfA*vH+B%gC9^|SaoQn?qsJ(=`n`MucF+oNSE zo4N+J4E1arL^oTwQ#BYk=m5pEM3B}zZvcl9qkUL3P@(3n8lwc!Suc#Or@5sqW;N03 z=Y@P9Q^BIt^WGRGL}op|8W*kS#Y}ouHa1!ohI;<8r}ws=Ku(~Z7bsBAy<-+REYF=| z6b{|fJ4Uf(I>sorOgu}Wrcg@{afquXU~Rdg*=*GC5Es|lLQtZ@Sv`SAOv`{PxOjMt zkv#=EOOEIAiCS_*FSX_f&T>!Lxc+vZg(Wt>zk7zdyJ7hpO!W_>HV$_6_JF4Q6Y6mF zkE2p~{qcHuiG3ghUlnlU`ngLky#GJvk}JVYYezkue9cT0Y zBa^$Jts(ey;>-69@MDqRt(TWn;u!muLj9Ahw|}v zl?2|F3B1KorT(0;^l+&qL3-JZYlfv3m)(#Az2l9UcrjuTf%io$KU}o6z=L##A|M)+ z8B=k0ip51pB+<$P5Vx3ypaB5f@i=#+!y=r)gFYUDVN;VuQmg^~G&nKo$p{=9vbU=- zC=0;9NDNEE6qtt`el)yum>%8(>(229eT^{xV~78K4j+OTW~~p%7W@FpxdVpY^=I#V zhljC=3r3~d3r)iF3~YY(ITsxAWNN{0DdWm8Qvh$l%Q<|IOY+i5{(|Ymfh+%oMLncbSR!YbDaxxj?W0r#f%5#~zdc31+GwGWA z4WlD4G?41oVBhHKfs>SJjk&#s+{&Li#vi8E-z_xs@zZg}<>xc$`Hu0GfxiCUKKLo4 zO&ADt^rx~28aTn$cV$LYXpX8U%vN!|SOupAVD1=|{Pp$p8v8ui1q(sWuEkZgTT}xX z?QF}8xGCzp?AUc&3*yF&Nh2CGuv(V;$m4=LRaxRd>vkuQmL9GAEOy1)fT9lKwy5lh7a zfiI0zIDo|gmNc44c&E&lr_i7Vp^0Up9yngu6533w5ryG>R{~&Z#Dw!Pm260jCL<9# zx_a&3asts8(-R^5b*Q*jtQ1#M73a_y&fvg>Z&B?~mWxHi z+b32al;`dw^lp51PfSls?~Lnd=@*&w!j%mM9NG>34J-XHcQAVi;oLs#h}-uO_~u0t zSYW~p#PQJnP{jpYMdYv4V^BsQgvCz)&-3H|{odHe8%Zm&3~> zxDkW*UzQPvoj8-O%2I-cmC#`~Zg*V@jrK&0XmcXu!6IQ@>l#c%ELeQb6&Q2?Oh!EH zR=3!2c_w{%tUJ{)kP2+-?YVp~(4XQJFR(+$d!dd14JZCWS0!*S{`1yR)~uL+4|ekCu%ZQrj&pY(LT# zi4sVK4M?K{Nm)(Fv(s}^<*iJsKr?3`3C zy?a71?K1~Q3>I60$BP8PM&Y+=g1UuLo z3Zyf&+7=Cj%(U}*7Bo-d3$z0KM|Pr67VCLY!2g!;au0-_fu$QZa4mO$&i|pdS@f-7 znL>Fo`LqvuL+X{OrO8K-ul;gULYRDbD!y*SLHuh)y+S0EY1z=T3N~NLQ$4FP zQ_3iy(Q{Th5a!W<2*^sLWopZL$z--;0y1O|T4Aeb*-Q%rz@x**o~$yeI|XUbFf}X9 zg@EwiXxm8hSTM??!B#+8Jk3ngFeSsW3yz%*#vq_2P4%MW=`l$V5gAXLusuVQESuT@ z?P^>16KIZx2;m`w@UsZX`w$dj!&F7#9tdIF6tz*ji@TB?(`5RV`@#jZE#ql6iy~8t z`CH*JG@ph{A{%CA5v61N86-#f4kQP;x3a)@f<%4;&!!x#z_bF&zk=MV(IF;L)1(+q zz5~^EPh}N#Loed#Ohz@deZ`YVZu{gac*bR;P=p@PtW7g2y8x<4f!cYz>*qm8s0v(v zs;Z5vYmI_-o0mUNt-R!g4TCQ1*D{M{tEgoRRcefYF8YrjgT8 zx&x(Y(;U@SyxVU{I1x663<~IV1!KJCq4Xilm#~hN_Zo4Qzl7R%(8rq~C>?>kaoa3z z$;vy?u!rwMveOTWdW1ZJjN23)FiTa5sZ4_sgBN)SIb%>ifUYFxsfoJp!MCOE<7G$X zmppwM^fAq_r7V*Gvx5|3L(p{V7%*Yk&@@BegRxn~DyURuS;;n%eE)9T&YD}@ZI>1n zQ+qGby{U;&_!^9-re^#>j=D=PqT86eDnhm<1rU&f`HKitPU?<^9FPp?R)Zh}43qZ& zZMGDx0JGaagS#3)M~$JQhzUG>-l zCZJjc_~c|aAOy-LRI2PG?*gGEYdC;cX;3w&%@2b{^jKgvzdW$YCPuw-G!3!hh+!f~ zLx^mkt*QadZ3KsOM^$+*=$q=_D!vPZmaT&VWYMHB-hhdCj80YHqZ`)<4Hi4$FkNQA z$E>_z!cf4yg4j~;Nux%Iy1ZEt-Un`t)@>9C;`ChO%$|b{&u6b++R*3`KHo;rF|B;FWjoQcz$Z8go5jS z5^}G@ObqdZJ`9>2-Gc5yw=zYW2>|g{nmz8oP=yXH-Nc|3@C*cy`?NCfGa<-bN2K1W z3Y2$(mA{F62KcHVqj~9Sv}2(%plthdrgD7rkEJs(g}MIj8VSO8#;qpHqtow=kK!G9 za%e+veP|QQ6d3{)4Z zl}5y(ClhA8TIt%Rl?!uv&N<@bD4f}nBui5D@k--RG8(kQRJ^u~6>oEa{!Cs?q`7lx3N!Y|(jX*HJyu6A6k$g7;SB)i`p%KV( z25kHK2+Mh0%{8V~3Ub>Zd>F=Sb0n7Q5wW^@o4sNhTC&7Oi}(TmO$GSTn%c6Iy$WsJ zCmU{(Gne_^0eyQha@uNtMUoaX4_obHii|B-ym;fjjbsJ$FxZN1$WCoudS1CeME6vv zH`Y!?BT@HlfyRA-gWXG+gFSfG;8}~~v6wlLJ?LMu{AVoxgH|`8XRV%#2ds9P$ldb6 zbxS!f0-m|{Za@*jzQupmQT(K@r)sUS)^3FQN369O|G_mdX0!N!rVAEsT;mYUs8*GTO|xCVi`&S2hUp(V;G#905q z&VA^vy}<0H676U6sFuO6Hk^&|MD zOsAxDRlinQ7YJI>P?##AK4L^e5i_n2hCzuACjv?*Yf?J!G~)5$@uK8*1%ieh9MR*Z zos6So26@f(B_ z#u1k_t|x56#syL7-1?q7q1z`(%tIG}L3RByggoY6BSOfxf%qr_!zT1O3L%(`$Ia-f zTZhRs_ax?eR#r1;B;X^(!&+#%gw<}o&D?9oC-elCH)0YsL&l7_IYfv<#)P+o-pf8l z;D7*oG1)e5jG5vZqM0UkBLN@t1E_yvHxYP)tt0RnyP3eNTv&ZsfU5$$z}C~;v(VVW zH6|v;2Q7+MeR_pv$KfT>&N7Wao?BCAgtdEwwL65hKK5~9xmD<2PfCPNek)^2`74)J z{>-J7H@UR(5|>uaaetH(Tv|CMKv94WA=k>~V7nLf;Pa9blrVnna2xP`kdchR)F1hrNJV$wg@Ed>6~-H`qw!0TXcb(wMQl4M%? z0f@dqD;W(@h|)7GK;Sg{1c66zn7R_Ct%s~&avTd`PzHY<)E-cW^!Hfa&wB5MIxjzt z+c9cS#LQsWi16gpW494$+z7@kz2@xAATP}?TduBcK$ zT)Wzqh;EfN^(}5q{WVvwUK8NE><;Kuc?t^=LZ5@}Rx@JKs_9fHh*$-&qvnu1N%RWq zCy=?$1D+hKJ=h~W7!js-3b2XoBJp()2b3O26^p53TB=-_)h4rt^791B^yo*NsWQ6l zsZ6Svnku6O*QP`>p4O-5^Hb$)A^S4^4T4$E3V0 zz$qS@@+jMh$do2%Y;`pb$E{?H8QG=F@k1Dw=E+6 z5*Ium z#yTsDG_`SBOKXj(xt$X_I!W&s#)_iQu&eqMv7D)VEQpe6V@K+J1Hb7aVcU!wkpyc2 z8#6^VEVEI_s+Vd8NnSQsH-SL_u22pNLP!t<%@nkuI@7QqjPQe{exvS~`qZgrvT?dv z>DWA*nsIcIWZQ1vvkDeaX3R-pS*Qy_6{w%dWywc6JWM zLd57ItE!GmDV2-a{2|T7+=^5Jsa|JbJD*M!(>m2D4g5}OmH-#yz@0fZJ6XtSWlbod zb?!MYH4J3Yz;;U2ia(c{olK|bP`|esLo&&{8ACr-t@y0LQ8Q@ED(lAt^eFFKx1q{g zd_$GnKO_tO>n(VzmA+krCi*~Ad_~}&M#}XZttIF2gqyB(_sKu4o(&)wy}T|`RvNZ7 z4(J;U4@Z+UQU}8}KpTL*7jar~U`0rWw~px|;p zh_HvY762 z@pr96vr81W1h{I1`dUE^b<%aU&1mwYAtN5*R|+J2q62hCU}kr-9Tcoj=%9Uiy84LM z>roZz;^ik!@x42J>UP4uc#66%`RKx~uXGn^G*hj3%lBvV4k3rCU-eWUMSbueyHXBRC80JMom^La*!CU zhnlFk%f`Y$xZ@Wz+PyHEx^{v_cOp9&byRZTJld20oKx-#4h{xok-Tx?M<>K+-NL{# zVzjn;&cjk{lBF4suIJ%}yARC1urM$n<{Nmyl+{&1^Rx3U{`(w{PI~9$@;l4RFd_XB z;doRU{SG6QkA5XWV$AQ<1zv=uD+vdE%d}R`INDs%NoS|1)MZOrxj64=Xpg2- zxe^A`T4C}q8m28;+L?3mX(~VHkDQ}(AUbLNNGdn)?AA&`+h$(&=3JRx?XFLKTH9Pc zHs{nx+9uA?%ab~lKjv}@1?3F-t5ja&ESu1GWoMmy3GG-3BuC2^@_Ig->pOCu)>V3X z058|yHx@@uWS@OrS{xztZHyi?E`9m%<;;~Z5tbK69~%v4=xzQ=c;?#Wi@(2;xtzfV zqtVAthA;XDM(OL))$qBo$i^2JA{qaI%cIJbi*H`qjkkA*ul}Wv0(IdB!kq&%qjLLo zqQA*>W;-+Z|Nf;HUq%$S^s4pJi$mSC(TdUQ1rof{ZtlmMgN*~uUsM`rS??j%n_|6G zZ8~_R(?enO)(QHeKzU}wVrDe70YlN)>nI~*^m^nI{i4E;&#UTTkUE6|+p_UqkO+Uq zOs^2@S`(k+5Nl(WX$#(Z8cw*%Zq;DV&jXA-}1NYccIiBU!cM2HiC&jhAft R4(xe%k(ZvN-Ftm``Cm`&s_Os% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ATOM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ATOM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8a1a73cfa241bfe3fc0a817541b25ac76660b263 GIT binary patch literal 3038 zcmbsrTZ|jk_0IUQ-iIA;x+JMf>Bu4tbuxxsQncNmX0ONBYwwO{hM6%Nw*|Chy|t;c zj`oqNR86haG-*4{vPoIZg+^4W_~HYIgb4EB z*qbFF5ee_ip7*)uo^$S*yGbG^G+ohJr%pGTwH2kczIJ+jO<8KKD66gYm6J7P3HZuS zHPdE4D^hJPdu)8j*(Eu-Qd?N7Eh_GMZFOB$4zuSx&e6}!B@AA1bBJ@s8+ zm=Jit9(hkSBd}QTAUzb>F##rok4$`*yWJiY@WFn0F9#fjb@(9!rc?*D`4m#kNN*7& zcDZU!fZ0<4+e<8gRH>w^J12 z`=h3uf)^^==fJwVP%JtAzH~IO?raM3vt3UTdC-5(yE~(qM!tmIt`@10*O{&6O29E@ zoQxdfgK`w!2pp%;j7D9psM^e}*l-*)ah{@1)p1!_mO*1IIB=TIs8O-hf@znX43}i- zv(~Pe;lrUg9}Eq{@k(TvZJV}gR$Qy%WaZXb zK8)fjByQ*+dz9H#)qzau47mny2Yz6HnKps6hU-zwVn!axFux0d#PBd= z;GjA%1A(xzg*1j5FVi`uQro6gWc?giUlA;)YM4e9lVCGiM%gOA8^MzSm

-W?EG! z70tUeC&H6-V8<-#7I7A$`V25e^%9Ios_Xsn=AdK(BzweKMd}pQ9T)c_->H^!rmps9 zB0aS!0Q zR_9A@QH5lR;q9n6(09HONTBvQ7cQFcU5FakJffE#<0=Z%;3|f$P@5kHmh=g>&MohV z1)c-(yTYAxUD!*155TX%`JR#irx3QqbXJB=Kwsw}?qMi1w3wefwE7dK@%mOoa5k&h#}x5PRg8gJTG_&U9(d zzY#munO*n??o7I`^VfEubx&vd4*`}s-#PyMQ*U&prvrNEVhmLy{$=>YOA`7dAD-)e z((NMl9;6InlT9q>KnZ$j25wx?Zb37n%6~y68jT|QFNiM^LF}JfWMH}hU%4dly;O7I z)RT(~SlHXgJg7=y%tJAJFKXsyndV9%o&^E=`Ln1EFWt&KdD-`}Q#l4hg9Vp8af4mk z>7su7oOOB)l|8dXj?%5^&}O~ecm_bDUB8+R$l(8t7kiYrSG5~Al6Cm|!pP-b;#NB7fK3Wt_ma4AsCJkoYWTFUxGbl=X!9`_YPUj+QMp0S!^vI gT2oePi?tyAV`IT<>|FWYz2><{9 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-BIT-VECTOR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-BIT-VECTOR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..68e20a7fa31fe50d9af5acb1e16606a6ba749921 GIT binary patch literal 4249 zcmb_fZ){sv6~FKKPZGyT)3kKM>#|3n>*n^QiPvo<-MYTmFNqt+&$FM~hA$|MUmCBk zv1L2e%2?^9mbIH{mqnC!#|jc3kdQ#yije5&)S+n-A1as-LV!R_XackktYQ?Tp{e}N zy|!Z(K$B?V_s%`%o26A*i|B3jP)@e^IoX;MQt-@>*L9ksi%!;GwLmS z^-koX=W}M(tFMn~wNhDkonwwm=^U*xg)#5>dgpjP9k-KK+FMahDq-(@y(gL0Gf2&t zFqzuf@Iu}duipQF9>f1w($@Ezaofu38FukP_-V#`H`e#5gy}~MSEiK9i|miDO{oVW zk@ZUOumE~#T++|?UbT8(uzF8R_9e1Gvxl*(FAt)DABh$s5y>D&wDF7Vi@aK2?FH9h z$W-c*VK=zq74ZE}cWh7=E{k|zuP>+0TfJ{Ew!H9+)jOpsFk624lLt080CX}ICeyir ztFQR(B4HyF<$N=fPLk5IsQgU^L@+npYEl=xx;;{Yx7&@^W0DO8L~?E*)FD!eM4ylyn}qET(8BJ%S?Ab-RXxF#gx0aOCI zm1ummCK{Sp3L^nDMtKb&Ah?y`{efoqM$utX@FN@;e|KXmzPpj;1S0|h1-$WV%+LP~ z2vPP?(Og~VV`|v@YJGDwZlx1R+C}t9Bb`W@S!@xIq$hGwwVQXTJ$SnCbm9r(31G`w zAB`J!d{WPvc0P+OCocA^U~VR7o71Wajg4|si>FK@ozLjwR(3iU<%+7TwYIG&@Aidw zm#-IFSZ~zKX0bV0c{`K0qrP=82uF?dj4tHl#H;s>d}K=u`55DV+6VX0hV~vD`OW=C zikLru2@(LqCieG)AfC@=&2-zQ%N6Q-i;%AlNZiPoGA!?=?(bm0LR-xJW_Cu;VT4j9 zNxupI-P6XDspn><$1D-^C6Y;2?CGS(A?uhxRC78*`~`kHkrjx0gt?K;8Z#t14^c3S z*|4UG{gPCCoJWXTqE5JhcVZvq8;PX(Cx|@4Hxap=-$taL-vOe2D9O)-rus9XslF~W zRW3Bu=i#)GgPlcYWcFpgnaESpIw7qMX&sZ+-NIVADO8ky3IpYRN&X~-?@01C0`$hM z%nWMANZ7`h7(3;f)cvs}uS(tTQ-<=40s!S(TqE)|+35-#N>SiYJ|}P}_emVvq{^Tq z9dOe{#~lVT9wQe_bg&zeydgZX*M%qcitxnFV2ao0Oj}P_@%%I<%b=z41xPnSI^LLK zy?OE;M2vNfd2Y%cfh-`3bthWAxr`Z48Y!^^^vo6#O&js7)$(yCL>=Q}Rz97`BmvX+ zE;-0#t%)>ozeP?h-$AuF(?(ut^{;_?dS*s-$q?i z=-ScVC4o=pQ+85MB;hrOp~c9Ex|f+q%bgPbHi>t$Bt1aWmrP@;f(h2B4OBUbL-XuI z9BTXdFo^mAzn{oIBzK+D?5o%Q%Rq{x+rq0q5aHGDin!`UNzNktx@P#sppe(&d?%4( zd!+=GaBuN{Fj_S#ixd*rP$@_-DvP7vkqdel!;%96U@MR$*p*q6_>7T53igVgg&fk}A_3gK0I+oHZV`EDXBQuA2>TbT#!!Bv2I zMo!$Sqz$rS3CPO0#QLBlTO{NGF%8Nc62NUTNWToZPWFXGANx>n>;uXDRdVl1?lr*a zUkwg86Im;t5v9VuEy6Q7N$i{m&z?d>v@XXdc&y4}^HksC*kv;jvF)Y<$1+>UY^rwWbZ8Fb1{xS$sqkwBn+?|C8*5SZhys z^Q98RT0bWiz!%}*+{n3M{Ev|7QK0*DbYyr~a7C}~ zZ?+w;-Z7#L<6m^8)_NWlo|RvFD?SX8YSFlLwRUk)_sTcCGXX{Qc`E@L$5awu9N^CQ zsqoR0 z{cpnu`?L4l2Jh?!p~(vnpDqdcI~Q2T-Xbndeax#z+}Wdt3bQnIAH6-mg(7YbH1hSJ zHMS2QNQ#fg&_Vuxx&|Y=?A3=x$4p!+O!-YFJ~V5sI%yWjiCm*(XbrPdUY*G0oa1Q4 zdF`G<#hQN1nX8p5dRZ$SdJN5bwTB+wquoYphHPVnyw`&Eb>?{^gomy#8a~>}vl2g!+&ALlY%Oj#_5=~W` zt+ZT}E2T2NrwP%}u?y_sy|_RAaFX8FFYPdvCr?c-FPto18Z<85d4!}lFKr;g=|$Ju zYkdp&FN*j7o(B|#+L#AlYaXcD?zS>?3>zu0-fJGjfoh`$aJ|c$fhhX>#R;OfA60bD z28B2?fM$=>z@2KU6KuGBJ5l+QOwnm6%_*!XmsD)3L3eretr^#u#fTP4i(6|NM%bJg^B~-x%b?A&z^Jc?1I>^U(YJ~)ZyvUM6s+)&CO2F%_?J4Wo2e+t~^py z#<*X3P`7O3SihzZw%ycT=d9C=l#9c&#ZkqbE6$7#KX9GWzDv=j%cTi!ba%7Z)zjJ8 zbHj~ob!pAXhSt8#obH~^uC}@hrx&Hzln`P>ECIDb#6(1Rrz)|eYdEf&&SVYM)N)4B zTktA1d=|Cf7`9hw>QH8Ui7b9hEbLU@l=YSIN$cQcmhJuV%W8oZO0#*C@v z`Dj|7A>^86E3htkl~|YB!M}RHW^1}@*m-e!vGIfuk@uToGIsRG@w0={E0f~wKMl(J zn&VAU^`T&!XVM`LM3=1SDJ%MLC_aNZ+-wwL>G>9J@E^LyLuiH%Lt_$$E*EPlF>J!wVX5Mp8cQ7bwqOFVGl`78EazPx0O5Dl0*5?^{D z(zI^x@)s+6uR-tk&;Q2<_{{%@KO7C;I%t~zUC^wHm`HggVrsuBTEf$Or;EP7vS=em z`^1LjbihLY^)hU0AkL|`G#(RjqxWRx%A{_Yy&2RAwO=!PvxcpvGTdYKIZ3(Jua#@~ zspe+`7o(=6uDN=@Y8!6B=3=4;)u`GTa$F-P%RFLpSg!P}p_zrenzrnmlk_E7x^%W{ zCH?wHylsW&L`nf5DEb+ivVN>><@* z&twhs9`H8#!{{I5VK|2@#jF9bUAQlJxO0-gAc-+YwKZ*~kf ztvW-wl$BLiD))Xq!DScq-NJnv0+)1hE9&G8J)`jyKBt=Bj;@@h+t#X$E!?#+ow5pM zZ+;6l`VI`_ZL80O^g5q>>sr-U_hsCE)#PA6pQGY-SiNu{V9xLSIPfdJWU5X0H*oiY z--6x~Y*5~Iqpv_X#zJ(>It+x0Ay({MQ-sSpMlPc|E=Qqe_paMOI3*RXx+`2J89@Fg z+u3%Boo_H9|1~fnzZuSbDS-F`n~1G5(PvwQe6XbOg7M;HIPkdNGUF%4*nRcsoHkf6 z1E&`Jgbk10TCiNB-@n3Op$Z@7&3>ZYPqg@nxSuG)8E3u9Rc>)+R%w~nT9mP2e%}~X zN|WKM0{Z5+W7xwU{D;;d?`iLGB-K{kHZ<2zFN)A?hA(O@>-hCN%)ch|Pr<(ybFZX_ zfXk^4*h~#TjDjn@fodStEQ*bLN?cN6!mGq5h7TVc9makx&N03!r69*R&Advrl^QT~ zSBm%vRb(wB5M@Hv%$&uAPtPltd{ zXbd<t%fZx+z;8`jFza?aq^lNf}Uy=1H5BHvzk; z2k4<)Ko@lb9rRI7Qo24E|70C8#un(0TtCb}MoQX9}nDo{<=0Wu+= z#g~)>KBsGd&uAxbo^}AAP%ChbkU-*NN&p|xHsC`-SrQ-6)xdk-P0WkeFNt~aoL6b< zNf}&-jqp7@_;NA3n(!-`KJP5&e%p~nu|<1g55LJiihm2^$4fpMcs`Bs4gH_eQeIBW z$ZA@0@u_XK^0>~mtXGK|`}uxwjb4@S#DXEJn)#}!T`hK-{B*6KuJY4Dl)~&y3@)?V utL(^66o+Su%IMVOj#;H#94(HOCX33vh9WVn1Si86j;gQwLOhkbaN#R8A8Y*p literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMMONP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMMONP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..36f6dd3ccee98f4aee3650dfd3358c8cadd895ee GIT binary patch literal 3094 zcmbtW-H#hr6~AM9z5ZI)4oL`xHltOS#3r+9LRxJ@fsDu3YiGwZ&U|FEAc36qxNF$8 zEw49XL99yE0z#vfZNzp4$O{j=A+<~p?(DOf+lneG{jEWF(;15WozY-tBzF2kal5}WTzA9{|0Zr!{igqP62}w_CfH#LF*=@?hBA1hKRP_JwO#uU`A|^NXpfY^ovJ zC$V|)+H*^bsmJ#Zgj}C7w$2V|NivpWQRcnn=1LYfEvZ^pxunSrUh?)mH-T6r+vJAl z=C6pO{y^Gv?mC+k&ek>)81sJaCaSikSan_V?g_658ShPZuC7TH-<;X#l6?Sqxb>ghsWh`${8`1@+Oemi@p zXW!DZuZQff$p+*cV~6j|gTRkO8-+s1AUx3c6>b#XbB}hxjTtfxb;&RduKN)DsaI$7 z!p4K(Jg|@U)i?F*hm7rS{6x>LL|Z1tMx z{$cuwPdNMEPB;$#(F8vEv3MY$aGsQ}QeuvY!EF=>kaF~Ydj_-{1?2p2BgZ01?-%YD zN{X&k>Qo(4P1Y(ZH>7eM5^dQmMG}586371x$}eA1WJ{?@2DfYj<)Z}k7dO{Ti#H+> zXq*lUR8hIC*-fdc8x6DM3lZVt)|OuK)6qFU8BL=cvn6gAx*_Sd)wHcrGy{W7N!He+ zKu#dh6!cD&thFX@!cns(S#nuL54gF@C(3><#+V=*KPt*2~k-Y4Jrd#BuiFB!)#627^iy+8F;_pE1 zw8^ciWUe*Jx++b2kv3PcNy<$_ZxVmQFVM2!pP^;mKTFGJd$X;D&Xa$CCICdRtP%GBS<4|SlldXhRGAJcVo2*Z{&`w_45zq8 zw-H><&-@D{-34I0Twm7g2C+jRrpMEW?EM9jeizbnquqfskes`%%^gf+=^Nb8bwk&9 zsM3K-@`UW0eu=CtY@H!%$@$)()oY(Ly$Q!sRBIBy-9%S#gRC_FOSCBdC0fn{BQy3Z zh%!7i5roDb2eGh6;qn1=Qxn}~L${lOGW%_)d_UBBBV2xj_@^U#&o6HK#STR2YC~SJ zwIK7hUo+7w7$A!7t{?%RhMTdCS=ziSv8%yx3{sX={t! zUid1JY%fUX9@+&M(Q-YwpB>MgX$^<1U4r=50ZUw`3G{T1d2V5|wRNZ6B8-!b2NfY` zJOXo*3(r2Qmv3;zf;i&ci{LdPxat9m6WXT&%K$9652{Om2;RLY{Eatwqs)ylvgG{= z#~{_uC7ldqv8qY#8zyWmC5FhJVq2 z9`qctBHcnDIwd`+)MP_e00kxksqbQN#>ASb=r#tIR8@7^ z0w1r|Z==#d%>*L zA~R$?e&|6anzB`+PY2K$19h!8Boott_!)zy1StiCCKE~$d8`D3mNra&)8?8&+G(?< z8yK16ATnm1;*=)Y%a8dd5|faAIZI6x4}s}=|9-$`uXpi$eyXaAQOOBWzX$|E`D;*MzH(GP?1ASlUMq8y zB@e&3f)B~jwBshNwr7r;Z;^mr^ITfqHXTRocEpS8{jIHjZy@&Xe8*WI6~&jn`Ze)l zFx|!?@j|Fl4B%V6-Ld?Vi0LJ6hcKfJM;r{Dc6S}qQ0#7tqv4Jt;=2}Pr?t5ax-+$F zI|HZJ?)F|5`#lj;5a&8=iAJfjc=v#b*YTC`M|r>YT5W&hmG1o-@%VZ`3jh5mhp&hK zISKIH85vK4sOQGRF@PIMeo=4ITZH0rvly-DDKre;W}8RPVLxHo<=}}w1!gvAc)c1S zdOSRZGyV!=-S7g6E8}&^b1yVEofaZ&_j?ycB9h>Ax;;nSlW9=3#Na~cn>hC56|!H_ KJ-q(-@qYk6&XKzS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPILED-FUNCTION-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPILED-FUNCTION-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a950f0ee78339fe73b4bf3b06c6b30dfa7d44a22 GIT binary patch literal 1776 zcmbtV;cHt}6u&QNv!rQiqFI-AYx~+-S)Y4hZRcz|5MEwyn%I~3viDw`6+udxnqbzH zHdTgL>jXu3P_we~?zVzo1i>$E2r``H!~O%m`rVHrg5bA$&bv*P&3+h2Th9HRbIl>A7X;Z9i*EhE7;#zG}+^TJF7E9t9_{EP^!=#^N6m=> zba)^{YlM&@X`%@c5+#1(-g2UnO)XnaXEiG8N{&iy!*znti(Ig%={m7#v0mGdtECT1 zRcz<_77++>zjlJ@g09+GLwEOuU7^?Ab0S$?&O>X;A|<}yF$=N_t}}31o`xUQ$mOBZ zg4{}$^W^X#bdwO_UM%WEX+M`AEeQ|T$!EVT`L4wWV?yA4LNE{^r1|s`x@cA&f$zne zr(#0+;d^~eqYvPp4Qb8A z5Viq5{63g`vOL#bHp))NdbhG$-Yq}3lKzvFbjrBbk`XE&caB1)I>8t({~*zp!P+Yn z^Zx|_-J64W#N{aQh1}cDIY~A2g)H8=oKf@zjhb>Q3m$#Zl6*lH@&(|p8-^+-sfw*; zWRuzj6NW50br@&u0EoKiTZ)F@D*yo$px6k% zKm}^SG^yV4Sug=(AEELmhoCAJ4Xu-7=_pi)^aXoXzk%g{~PQKnky`U zW(IbhI%YupDvzFL1Biw>I_n|w4~v77{LN0I`JMHn`N`Wte)QTQ`VeLL2%;^cX*MHu3ibUjT-?!10<^e;%!?4$qy literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPLEXP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPLEXP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c5a98ea599f8b9875d869093bbf7beec375d7b8f GIT binary patch literal 2916 zcmcH*ZEO=|_`PfQ(S4LoCqe`G2BeJ24aSB6MCt8z+sfKry}JVQ4=LM?b}4P$IwBh9 zBz4D+MjR-)7bGSm_)7`!OZ>=4_~#G(rO_CpQ4=+qfYHSLAgRxDcPn#ZG%>clKJW9q z&-e4Z&%JY`?w}N-QsHPZn=>Y8VX9P|D$%jR1f48QO^g_H4CwSZNm1qJ2SsV9^Rccb zZOP8agpn>8qg0Fa z;>nnNFi9?)^_?JuH`)R``tx4q{UPppo_zYj5PzUO*v8c#v7Nlu@4!R;dBuNP@xSDt zucHhsTM3!JvK|)jLsBLfbP$LS*6<7N3%*;qy9=0$ps2%(g3W+s-v|7@6Af)#=DKYU z(A#sdQ;Pp4A#)j1@elDFh|OJDePE^QKqDb7C_1ug{wjA0iEbp^JByJtBK7}%AYL@# zgbh*O>jSR;>j+ogE5aq=@y23!KFHE|zFGy-M;DMI=W)?ba&>eiYhlLm++U@2CCr*Vt<2|Xh9lw+%c`oV zf|AmcDLw3I0fCmVm>3ppIx4X$fv#mouGK>b^Wr&Mg@@)4DDukt#TX(gAob{gs3WSN z2U1E^<;0Rh%{bhPpyzj!Ac>mnm}Skly&96#v{BwKtHXi@S&7L=^@9H9xHu#W+HkyA zL7Uv?Xj6q8Dse#h0Qc0VeylHcj3l7`M4tNowt4-}`7Mf(CF(5VfLwQpPI}Iro!iK7QGNtJ9AX_5? z;>GmuVWBP-TF*j37TSst4qBCmbYrqa*H4S<=~x=xZlg4tcV0|Lo5qlNVpV(_MmoB; z_RwvcG1xoH2@A6xFK+xgyV35LTeBys)#@);5ALT~50CKsazyLy#?`mw$k&A6>Z@|3 zdfD!{kIRvWLwnmgZ=Jydx=vDMQJ0}si$~t>_E=PxRWYWqW?*BFI4M2P1k^WV4rLMc znPr$_#QsA(VwU$s$7jlsfMa8i>8V5dPM5#Oob~ax&%fKgZgc5dOpN1u{QDC5JIr$A z_=+#egHPSC{eO5FPR;WE`g6BxcGsBYCz>z*Si@H>^Q#@?7ryzay!VFVSHNtTZEZqJ zEvB2o7Q`Bt`R_H$;%5-w{ta*S;65?Sdm(-0$kPLt0Vj7{J8quIf=L>X{+sEw;cau4 z_c%2pKRdY~Ke+I_v!o%Ch1nf|x(9RVqlZV+*c8hL8mQy!fd(_ps?;mJ`(#PyJS+qo zXzL@pj%?fADv|3}rE_<$43kcFt|9i_s#NR1#nzkF+-B@VMP;jk;F4w-G&@E|;Chxb zo+;AoBrQ!$85FK(`9g^n#%MZE3x~&zk7K`*pdB?+j@HdJDL4&jdU!K6p3c>{C{j9)oh1X}s}Z9TUBanjg_^AvQ%4D>b14i1y5N5 zu6#|mY~%c_rq7Q&I@;|Vm|0l$iVbg3ao4>1V)40QWi+X1E34%S2B%JeePm*MeB!eY zk91FKPA0JS5p*6tIdO7)qzyH~SN=;kfE_I%BA&mNgRo zw%_bTENb2{Y`-}$rZj3RYQ;O}RVbY0I+GalFEu--^QP{mEz`duZAd--E6v`tspb%x zHe)ckvt@;>OMWx^ia!zPR4pjb>ZIKH>5ui z*os6dwIk^y^x*f)6*-PCoNJ>ndSFOi(;v`}?9tHw@`!A<+>x)h-RWw@|3QNI@j*1C zbG8z}Z15qzI}+dlg4DL1t?uoC1B_qjRu6NGX|jYrq5vg)Pm4$^k(Pa$IbfwS2CcJL zzHPRI$;x1`TFYSD1z0GH1%ecP`0xLnL^v=PheNxiekOPM-)bI7pn_9rDtmQSGgBGE zR;SWH%o!&kck(Vdif;txY9OI&u0E^UhMTu>E_89QqE5kajjSv~VlX&)ddASqd`_LV z?5vaEk}UnVwreGLEY!=pLNT1PzJy`hmaSTOHn!(%8RKC(z{lu7{t!xG<0&me%xhqx(-K-p%`3+_ciM3`mXI9-e@hifeLUzi^sO^qN^1lEc4f0FukGVqR^}wAiejjl! z2i(Pg*`2)~!e08-TP1rs^c$B2)TbuE`O%oJGmj!9v2;5J)L%ERcw)H@P?yO*WbTLh#~p&`~e~j zTpm%A3QN?P$43bLG|)q76Gsak85x5DBK&?V8N;@tZd83%vkChIWP4gNs$0m3dW!Og zFem*EbFr+2tQabe)-++igpIJ~T2wgF4PwY^Vy=UU>Q**uQAE;rq1@kg0x~X~5OP-` z7n(|wN0QG+iM$Yy=gF5;+R0@!-AJjfMRRpzrb}doV&}tzS-^%4WQ&HaOa%g`M0%u$ zL_Q=%5cW2-Vu99-ZRK-9l)WxQ*|k7sDNlVYbY`OQzcUcI3lUDu8(OGP|h7L{@}cy|!CE;`1z ze=!mXhh)(PhPT8{erD?=;*|%s5=6Q;C%%5TMkD4oBaN?=s~%2{+Fi_p3-pma)d3t{iK5O&*tH4N*L#)pYa1w`k=U{XP4 z{0)Bb0{=XJ8Yb9#(4-1t(va%?Mh z3Z)_{RcH}dg`^_fLM!zF^{rBighXjekjf+C0SSbJct8Sy!~^9434~NLb7!X|AgDxQ zdv<1bzWru)X73hAOmlVll13n5h5Slcs5V5(2g6M)(aqnk6 z@E?wnm)gz}B8Gil5!u|z+#VHf=E;|LM#ZBW{63-SxJ~iBup^)KEUTVH)$_8W zUP2!jwiB{^y$c5LK~u)>cNB;Y#_;hU_J3G;Fbi5uL04xjI<|q9y$yQD*)@*|nVa^0 zpx#@EzOH)i60(pvuX;vB0o)d@Z#?R+5ojjFjjofMmv0C~G}a;!PS+!8MypR~L4jYj z!}$e@@TpsCta2_iAaB?RNB}+rjynEckNcK#DdM6WRv!*z!3xkjJRR%1{nl&Oc9 zuU3KQ2}gXPcIFykC0PEIG0ac@R)?yGy(X1@u8@qvB3yf;=_7CY~gKUGk1$k@NEPTUqF@&d4y?-k<_4= zWxE@i^aQB-$f$BbFASX3V zi9giNT)?@iZ;P?$V^m0>sR2^q8l2txn$U>^^Gf< zI?iM@7K3y~BYFbYeU8z|YGMM?CJhZ=;B07PKKH!}wt|4a)&Owc#dX-ZY z8NMEc$v2=F;~P-~xgQ1PTT%G=HW1`K_&4ZBG>n-1!7(Z1uI)`ew!O&>+nc-sA^CL0 zU_+{$j6q5yEP)rmx(=*irccBM)hMgqVdH?ic9rdE48T5|J{WoQgd#^IaDj}o#C9~r zBw15eFt&hcO?XgE#)lHfSv-UQ2~8c2qsAbeo1FWP9gP?xEDkxeb)8|k@^)O+$+x3u zg$uSRj%SNUE!^jOP}~AQ!5+QO@d6dDIN~*cZg-$pkc4AkT>tQXtM?K{?Y)FS2fWu2 zEqpH^lRMz;u6Yk@YBFKdBUfz~a@k%>E;!;PptbTenB%O(*%X-C!ZB$y8MhOXRK(7We<#L=QvY3dL5 z_L&Dzy8ul#AG$&aDn;uZ>ms)MRvBvAP@v@Nmx$dv(TJgFQdH+2SjKytJU+ww(6^(u zvwLOd#`!&g#UF4^m`^@;Z6A!tuk)d`o9^J~=lVMG(-K(|%EH~~C050sOHCh3r!e%@ zmjXBm_N4%nAqI8uup%3Ri!+!&#P8~Hkk9Nm_<;v3$xW*g92iufiWTQ^Zoi|HS2A8t z^_*Tyeh?w&tqO|sx@pqv6iwx6;n)dtvP`ojI+ZJ=%0&uqI{89*FHM_8GoQ}pkJCb) zn$H(um6>KIQ@L655G^_WyXrnR$Zo(((_Q6LMH65g+@1D{-E_t*&(7p&Ib+gNYTBeW zPVnRs*&)3ZYIH4R&tzV$$%V|B?4{Z`1P|?dUU)YAS0cq)B3&zqgvxB$p(gOUkfK(_ zql`o28_E!aYd5J7VH?~bO-^SJl65l6Mr-n*RoR)ynW>UV(}n!bGVo8EQ`x*p=OjGJ T6ty#r?@60t4#&{~NgKKdZ|3qnB<1Ydj*6kp;w_wH_DA~ayh4(Fcl z-1D7t?wNZs%Vft%-B9$>%-qy;Ft3yr%X5omWui2%ER+`K#{*>oaOGv)a_FnWnm*F? zM0c~h!7@G{6v{zS@fL%HV&TO@O84W6Ha9;t4U3~kK|Rvn*Vo^BxT`s#5nCK~+=B({!{Pg^f^)>bum5!uB4e zT$)p-gHypYmNTR!$=qf62msU^A)w&qOLhSIblO60~03$ja5*mgwi zfxoJcO|Go8oFzoQ(w>wtp-(4ojYv0U$q%26$fK!LyA*q#XL&s<&exEq6hPz~C&{bKG&`gfJI_3n|%R+Th<7fC;=lD5D(9KP!6ux1V#)KLd=fS5yWT8^_OxfPx!cpBk}!LtMIReM_3JbhSosOLLy zFLZvfV(ysh(Y!3fj-BG>=?2wI-&V7hlXufhlBKQQo|R_tx@Oi?mwD;kHdjAAD}0wGp4$5LIy?j5Zj635q2Mn6x#(t`ksT* zHyo6{6yR9_z9zsq0jdH_3vf3F$sg=~U?IOj>hZibLREJxKVV@w!9?1T(b! zz@VlYIoA_G)E>4UH@6Ay7$=kd6yob`F?4eV=_Y58t_j!ogm?uQlsn}h`~%_tjBv~g z(Fy*$H~EVeiS&hQQn)s7AM%$FKZC2B_xTQT8%`%Ciic{+cMO|DK87uA>+D00<=bL^ z#2Lv2L3M^5T!5|hPgBQY`zL@ao`o0GH+iFdmT|Dl$9>DA!)z}Fr5<0fCt0SOWja_U z#WL-9$Y-MPK`&S+D;-N(hcZ!s?}wr?H7ox0Berw^x83JQ;pUpMvt&X~Myt*!k72+_w- literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-INTEGERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-INTEGERP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fa0a90555ba3e8f1b20eb41dc8dc7100c1f406b8 GIT binary patch literal 2647 zcmbtWU2NM_6ux$vu7AnWwHjU6k15(;GFR=kj;$N4uIsc}lQ^}Vc72+%#$7U{NtC36 zim^>o>4ao4x{2aDs00rP32A7XK-!?F6Y#(T4+Na^32Ma7_5?A# z-F>|fQ(0PMe0f61Bw0bxNQjTPh4sRB#r4{ROIq(j*RRfe^nMb2FIY66T9@^+?hI#M?Bt?-GUQTH7gcfkMKtM}Ch)wVoj!9fi zfYpV4o(E}*GXeS1eK$p)FUrJL-hy}6BCLe#U2`L z%Ak!0Tl;EnL_w8oHnbVd_0YSf?b4W}OzaEbTyXnr=cNQe?~Y(2Xc|AWsF3Lyn@ljcx%!{~jeE3X=t#IOKi&@Vnd zflyQs6}gsY6rgpX0XY#HjCaAh#mNWFPDon-sJCs;LP2&2baz~lhmae42)etiddKnO zVQrX?!4v2pDvxJNH=t)HeFnuQxJc_`cyiW3dgyLInI9o36U5a`+J@p9I$5|amz!CT8Pq{xZ5#gF`C1(EM8Z}NpLJ^@~}Yae)# zTNGK64{UJ_%*~;wFp`K_9YWJEIr|q8v2)wOjrn<=VNu?j z>kqHLhpX=|x!owgy)@UK*m`^J=v_ik|7I@n;`MG^eO>eY%89-^-wFnA1+B~T7b}&@ z1M7jlZLROS5dV1IWmUTVdM~Q)n+9Vo-h*Ma3NFp{ziXG8Gv79^;+?Wpgh|pQe$6CC z!kVNA5tTNB8|}6au1NP|-i}4Gu0I1;rH`0~KbxFBnM&fm*IpFRbjG?UpuB0+%LB(G zQDa;*2nNiDyxsZ0m{aYQvTh`i__Bq%> z+LrE-t#j2{2hU&Q4mpn3j}U~;pvJ2Gn;JL6eB rS<<;wKDV>X74?)pmC5PcIRQ^C$yx2i7pkLnNL$@M4~ASDtyKO71{dw6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-LISTP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-LISTP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..401a7c8cdc1eee844f835bd52d8147d601510baf GIT binary patch literal 3354 zcmbtXU2Ggz6}~h38}F z+1~p?z!h)Z?Mp5H6y9DbMY6CR4ANt%S>R*z0&NS%Im6~HgtDWxFGbouQvPBx|~C3 z%CyGB?v@p@F1XFeqw;b5X400OW7oF&FES=x9~u( z^YGS`Pro^^Z46vB1}^#Ro1}wbKV#cB4q|{0L8WNaXAm65_(W%-zi2*~1=nIo)t4p3 z2)OcH@cS=z4GEo>m?{N{|P9 z5Ebd1t%NY^e~9l5`M8fD#cijnJ3HV2<1cip`#Hw#NdQ6#6LVg;l~Bt#P46;MIS!Sx zSi7x8DwSb>sg||&`mj(YvE4~(C+lPM|IQv3pNYbm?b09DHu82ZZ^r_CQ0R*(dO`MZG7{+Z2p_n@(unFfzR*}BD4I{L>}P}6B$B^y1uR>hw5?S!(?5_SPgkKass0PE2pVx1z};6<=i2HvWjXN zoj5-SsB3D{$m_}65%?kgm<;4hV_GNfHEjCnIypO(`Z}5@h>YGO}IBdF2%0 zU&5U5KIS4>14+?joUAFreg_*t#WtvJgxka*&)%m03`|%xvRQ)y65fXLVA~1E*l@y= zqqqZ;Y4S*Ti;okz?30V+OEPWcGK#7tW!s>+7m%19FEJE5A0=!K*h9OLMMFPP{(QpA zj_{b54&kUr*t<}Q_)62Jk}^k!UGrtueewgi*twHed3>427Xd}4P}6zc+rvDM zn}9-3HdFl51seT&E%BBw^~;yno_zM)&({(OpTD`@O#(l4H*u>8f@g_e+_}HA zLvYjG48SANpk#HWQ3ca@387H@G9-~p5DACFG+c#Op%9H6_YI2WYV-3dnvjk9>s%FH zN6e&c%~UcLk3ft+;qSM_6QtXV9_)qIg8`*e5L*bl-$K|u_eVik7Zg59WYQ-p9|e>2 zE939*ix>Da{8^Y_A3~Ed!Tz?zx)NpFhJ(y)Mk~d0XBLXIoqMkXhzj0y07bVMHYR5@ z)fNIgjtR2!doM!%)C2$79k)3)F{z=2X#Vrid-FCrwbL$|RjXA-R3vQ8Z4$X_IgZpQ z6&q5eyxgcu1tR3~u`I^V1$G`T3bhPn&-Kn>XNk>TF*lv}M1MOvt)wXbXaZxHa$gTNW z)$_2rQmKrc-(t(kt>MH*=|cH-Y9nyf=s z;x-B1NpGarQe@)ZUathTS4lk?JBAjWU@vnX%qrd*=)v%Hdstsy^B?_*@+2KD(P6Laadu zSt8p=`Ur`UF5=yGV=0T8mXyh=RMO-;O?m5{8-!XU+oXo)#xIEN#)?#Pt~fO;XSqcL zLcGu2V8+%IE30eX9pRb~_HMb6tR@wpG?=z`})#-$7JXtt`7&5h7?LWGC$ zSO9bRvGOP>|1GlzQqzd{|3^KdUt zBpwSvm?|3iA2K}P{}2&?=MvD=?MjRULNGE>x=^5sMW?09vTD=)fx%ZDh zl(-&2JU2FaWWvK;gs^TL>k~Mq-vdxLg;G)Y283QrK(194H!<^r zMkumL{je;G<}x&@KS?iBV^K1pGb%-Gn!SMJB{qO$kevcT{$dFvPq>Zz#BJohZ~F{j z;wH7EX@1S2aGLaL*i+u(_t<&V>Hrf&A4KujzX+<+N0BkmQ>bwtHOOJe-#+=1B>|K? z280Mlm@#y_z+uU^+<|QRD{uPbBdBTrh+AXH7E6{v70Tr0oUQTVZI(2!@;7bWqOkZF6XF095IJ71YiRB_(1tqas_fK)utzmY;Tb|ohuhx)V zxN+%^-+xBV#6d)6-22MAgWKV(Vo=$l(vjIxvlcaE)nrjv#!`M4&a)BlCBJZA_VR&+ zY7%Q6rNqjZsNqQ-9#ld{aFR|$8I-m+NLTgg045?#EreX-CZa30U?t(*vN?^ z$0@3SP*rUzq*aSs5q1haa6ljss1z=RLJmD4^}q#z1QG`XQg21#&;ycrZ+G+4fS?k| z+Hc-B^S<{p^Jd*3{!?;BkgHQO-c@aHzjGn39Z)%k~I1 z{e1)d2YZ9f>x*2ZN(dPzODNh1i4Y&LuUL_UNexp>r887iq%2L?4clskT*RC~b=!&_ z6zbI(u~Ix;tYA7*vxFnWe#2@_SOB9bsGwE+ z&bJlO>1Gpxc+nN#jm0W{AO{5JrXJw;@@ExC1T+*CAAVzbz(2$WZlMCGula+iN6ujL zKV^VEyzu$HM#5yH3GZ(3UuvZ@TG@$iYmk}{Z~ zx|mD@q6`@czLmA{0r>dgbVn1iWXi*$PR*PSr&D&0cfiOSCe89Ztmtyjznr0xlGDVL zs%MP^<9P1x)~1?Z?Yfi4=1RutGcM>Of6?7d>vrWk&u+U=-^1=3j)@XN{`Z& zrowixtw`UxrV6zX!dkGCV%QgZfxm^0N*PqPgA%~FBoo!gF)%r&>r`3Owv59$jG=3_ zHnL<;HyYLs)7-C6yWmbbO7*;GK(R6u(T~_;C_Z4_C>YylxXC$ zNi`!bUnyu|0nf&D_$>N$%3Fd_*wCn)mcR^(BWihsvXZQ;D?BFw+K@`BIb~4mg>i?+ z2bImyZ2$z^xgK!H?*iSg>FSVzS~rw(n|ED_V`+0(RN%C^fFa^GvQ4;-V*&{70o;fI z1vd%zjJwD7p!kV(qWA{5+C8onOYS{Dw><2@xgFQAbC+E93ohMhSEL|NZZ8rag%Pi% zaVR*h$S*(|TqYgT)tu&pN$xsC+aM7*5qVP zHR&sC#~DysaJyz$yvX9CEUvKlQvilmZTGUyJ#7C@*4g7NJ{e=3c)s{9+uC6kXX`@G zywoF17T|R_A(W@xHyL8{J28(RF7>1M*0wlja2J}wkH}~C+xAuL*zGc$MU#r_&Uq$n zQeDaztR0rI{chpjWrxsKUEp|>>GQ|a8-K)6^5XslpMyPpKKIhc2M{~#tvav}1vT76 zY~RAUX0!Rb(+s;ji_jw3aJ&rHT7=kEtWubIexiVxtZ!;4Bj+?Vq+nYCHF<){Cg)>u zm;i3_hm#RIvKlY>*|vHIk`xX!bzip5FNpd|*_P`yZ+I2#MWPQEN#gjSNTYnV1`Xw(U|iyl8+ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-PACKAGEP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-PACKAGEP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a8c62651ec87abdeb551123136c15bafc9857551 GIT binary patch literal 2745 zcmb^zTWl0n^v-T+yWO&E5mClcujRdAs)a&oL1j9<+b%mhv(C)Y_QRN^J7rgw?xwpX zAhAKB=*LDZ#AdG27)>;O8Q{ZMg_MNEPyhV&%NUIx;)jWeiFnT3-BMa&OeEdune%?! zbI#m3vTjV%sa85!E)?BqTAHbrXR36vG)*g|ndu3aP6C~t)l7@MKB8*LoLS z^HQ`#2$>*D2ttHJNsxG#YSEa(Y)6SFbfy?;ip9J+uht5=C>fhsUaeyvt(MA4(LLoB zF`bhYA`#-fS8I)D49!WHhId&yC$)PQYwHt+l7`gOVMYS2bt`CH@@kQT%0Bq3v(sc@ zzWqEQfqX|afbo2jzmb#{r^rt?lY!C4XRt|w&a zYB#*V4@r4h76{}A@9>k4%3s&+aRI9%s48SpF$`GY2H+ddw>%={7kz(#-kH-cnvvUt z%;n!UBgudSYI9e&jLP)@S_x@K)rrofYtkho)-#cY8=15s734tkKRej`AO|b0f84Mh z8tp1POv{0;hUN7TGgJWn!%x%`s)WuK1OaG>oy$M8v;wCa&cnjR|FaCyAC)1>rF@hG z!ruF}&X{HzLkVnJWkfZGbY>}o37{Cmb}X=-hXNsZTH$GiXB|vOM@&;4ZA7t{ld+(? zHGe#s?Qz>-sXzcEHi`Msbfy}av=TS1lpW(zKw7Kqm@ys>w)0T14W=a$W0qxFikWfJ z87CHufI@prHO3X6jz)qTKrR%k4^7OgMSE8bV|x=Jya^|8Cyvu`kZ)qgR2`8FAk7$$ z>L6-iKw8GKn6YBqxr96o6S-F#O|_Ybf`^gaiJ>({7YBNIM<9X{TfkR`o`6N7>Uv|! zZQw|M@kbH-$u}eTg+GSi7MBs+0Il|vnq&%e~P2FEeNc$2~8D<8M5xp+d zzu=vSea^Qc_>^}c_(Xs!0?Z2UXNC8o@Xmz#cENi}@HYB9@+-7S+YWY&S>uWgeW5cj zN`B@~Ah_*okXyb6xh6E;0gVouIm(c!Wl~UF75nQopl$+cT&bth*p_3E%7#_67l5|T zKlMI%i`Z$VB~;z-B_+KBNhwvcOr>FCE09{^gJ#AUN_RtGftS!g+A@a?#7sD@ZH?nn zMib76;vbC}Z`9dV@Zk6slNI@3e;;BT&@{3 zNNA^-#)YBka7kigF#0%Ku);Hp1j8WEQg6`~o(k|3d~?N#%E>zH_iDS+MK@bwm(OktsSnfedd^6EVaES>Zx~TEN2NQkJ7)^ZAM-xa$<;yxyYsFaz_CR0X^X66dnxdNTZ3nirHK;1%m?zKk@IEekSs*RuzA@h& z6U>+jDrhP9lyAA56L929o@K>zS@FE#sPAJi3|k0UzS#)__>}V<e{%(ZF@dY?-fIr6wfz=6cZN}&p6LPTJh$_qwC8A>IrGa)Ts^2pK|?ZtgQZn z%IfRUnl6=q(n&}Bbkvt}12|YxJJCD)5PvIQtV!h$rh8&m>mS7mLCci*!3w1Yn7lGu z%AN4xc$I0DnsT9njDQIg1=b52vBL0w^Mh%}d{BtxgqQFQ)>U(pUs58&LF_GIRE!LV zWK|dnf+aGd`T2U*z}Ldp4ej3Mmqc9}6;xS|snD*H-S4&9q^8SZo`;AI=RimyS&YP@ zLO@Z&nxAnz_up(?@v|mZ3u|ySLHm3BvZ^Yopv3fOO!vE*A)(nXMkWQ@jv%f^u+;>D z6LR&G;rXykZ||B@)>1hk z;OkhajU;Na!-h41n|lDYYuqkR$m*n^L9s$ITK~YsNJ?}Psw58U;*ewh9n5Yq8VyZi z(A(@O6mPK&D9*5rD0GHwxn8y&#SY}D!geTORJX9rAjsc#B6(mZl0WT4auXkBB^BTc*F2^e{_s4N9VNP~I_(MdFg zMM+hvI7h%#7Z_4vk>O|$jGN1NQ0$nz84R_KZyQX=_kr$?s>(Rk`q z$Pz=QbX19wv(ERM$_cAe1mrsG<`VjYPoy8J4mr$MQ~eay0MgLO}^?g;BX1jd$? z+-}yslkM5g+B?g^M|`Xu8;jp&nOk%tU!a}yVke!6!?SdnCezMi5N-3@A&mQZf#XsB zaA7dm`WueEyXbbK{PsfZ$7+>Arn7`WIX_#SM$3ZZHW~ zp_f>uFBP9XJ{`vu^{%-Hpq!k25db;MtW}1_WJ%{-tQ#DN&D&hrvnx!*c^?g zVfh8)1in0hMs45~P&+A`Gp3VM@Saq`!qAy`Di5I3M%GAAC(|crCjE%n?KOV1NQ}XK zw3s}bxHVcFJwFH!>A_q0dplSRE{r;^drODKrLMJcOYInkXg)grO@#WJCvyNdSsa%`50VWx;!k{_YiTv2mx;U)E;7E{cNm*jd|FZ-2>#h zv-#bxmu1Q_yP_#0o;T=pCf!w_P&Q*GnKtOWh&>jkb~E7H++ioBz2@I-M6Ri&(my>h B9diHx literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6b0dba36ae36565565d87ad2adf81f403812c85f GIT binary patch literal 4854 zcmb_gdu&_f760zNj`L0v8p`SgxU`f|uQwznEu{t4o15#zjqU5&*KH&1<;FL)+Z#Kx zooWTGlnT0*T7@($+^^7S(-7K2h?YIeV`1tZ+B9v_g!cMpo5ZI5!6v4mX=u{AbG~CI zSrZV_D*O6;=X~e!JKuM{$Mr00*l$Etqc}C4cb$@2oT*IDRMg30Ni7#=N)wJc33Bxz z!%CW;9o3DozMTUtsbxJAB_~sHvZ_7fl(U(mThxJjReidYccHO;JFwe!3=ZzNduv}y zSWiXC+Xt}O8rm^nukHobEq^6IU zOm3=qLGO}RUB68W!6y}oB_PmH#MbtjhHWLa1iLWba)L46i(Q>ELVG3m>X>x7!2bN& zn7pqi&?Wf~3cN3ciGH$U!Rk0?bv#DwvuFd&cE%PiZh!`SQIrb=h=Ek04d1}-z{}O8 zUf^mBnvyOWwgQ)b75E!YG~OuXE{k};zC9a#!s@uf*lg}|R>znuf!XZE_4{tA0cc{Z z4NWK1g-gnBQCQ1FI$6)838nR?AiYCDA>d*gB)OIb#@se&9j1Qd(Fo#U7J&dXJ}|y@ ztKnM)PL9;UHA6JF9e-LWF5p@MAbN<+3xKFe-$U2(AkMWk*1VC9+XVCw3a@_(%5C)& z5EJI+hM;j6@Yly0=H{>~yNc^`8(hEJD9|21^se5P;e! zuK)xHu4kS47V6S0{p_aHb4J2Ac(RXi)JC$$>bLA z^VOc9Va10dxD9HfdVDx)CSh{}Nqi&~l-qc-+zL-SJk9Vl!Q+Rg0ruUlprPBwsFpPC zbQ1PWLu|bM)OgA^W3mhy-Lx|sQB#kn6I$3x#!^8p$PNeOi(g_A_K|MaM2{}6Ps+|MZ?CTv0W88uUj;`#bFUsn=2>9;2tc=y z<%qyYCzED;*~!5r?0X!MFAa*Jr%VdVTd{ir2CZe2xz|jN!(k8~iJB-K2mh@xeazHS zCerbu%)IIZPiCm}O5 z+r@j3>=f4We}uLCZ(%LJC9LHi3Tyc?seDTq$S)B25(&RRqBDf zd92*Hox4qMR*GD~Da zc#%FOyhwY|G*PgbVh%aKSDK7wi;NNLR|VwPDLh z$6&5?TwM=>v>T-1T7_u!+sA$gwWd}kb=gNj)*xzq5Lz9nglR968;g?z+GqCDjJkVEFHBY+HeG7q+q;ZxWrnbyo3YgZz37xPXfL2 zD)r;8DF~;0AMhzq1K9o^??>`Yz7@$O;=abQGL)0=Ke}QhmZK;V zib)E;kB9*%*3?ndMhczZ%?FY6^Sh8}6u3tOmj4BTSG$nXc*J2xU%I9)10erV0FZwp zBFjG^a*_8z1ofbpXT>q&yxb0 z{5UAIE!o=^_C3sZB8idaFrilg{os4fCZb=_xjczxN`eXW(%*^vUL+y?j>xaYY)Nm3 zu+mTY4gewji2ANj-|N)(Z4!QigcnKpJQ;kMgkL1#)5JX`vX#yfcZRr=B2DQLk)QN& z$gh7z3RX3nCIbOXLx#|HXHtV?0#mp-EiZVK}JLak1H?c_;~@hCOM^Hb?pG zCNMtS!fdDiYK;#iJGV9(K`Dc%ZdTo+0BByNDM@?*FNcym5@ z)x%R=c^Nb$AGTgtY&|91b92d9IYGwZvtqe#0|#dZ&i2D+08M)V-NxWRf4|^1dR1S& zeXCb(98mk=Bf9)6Jj?G0&+?o%r@$b|7LHr<;yEamx4hpw)gZ}=H`jpU7>&S-Cvc|} z`t>#V0fcOOrx?-^REF#@J-KgXz#b7$I=rGs8mFF{y)$jz={Crb_rnlC$d)v0og;Br z_e0~hDe)c0Z}e}m+@{>o^N-k4T?=0u1rd>xnkgsS*oQX=Yq)n^E1BalwS-tQ62h=+& zN2i^-NbOyrzFCCM6pq%ccB*B^A>WmpqfVEcY<>d%5>fMIwNjdKRQM}JM9x=w%Ye=; zJ6qJOGwl?zQ15E70KJatd}bODz~VTPac7)mJ~QeH1n4;fhK`oaPdSBhzF5e(YNk}e zzh5$iEQKo;+@m#Hl@cwhpPtFMFcN)7=2`D9cpv!gDE_|v(t3S%^wH7T-0}Q*eg3eJ zb>=&B@Ol54ghG^SGpQ`jBv$wxRswH7dep0SnET-#V?%Ypr95paJ<#7S&S(wpxnoVh zu3crHk~z*GK6zTGp|Kj>?p1peu9GP{YPMMDt*9{K&SbvesK<0Hw~Q+40{`>z{ck0) L^XTvN)vNynU3npF literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-STRING-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-STRING-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f0d741f4a0578ec89de5d44cbd2958c74549be14 GIT binary patch literal 3698 zcmcInZ)_Y#6`$R+&;KuW>X^g{Wb4LtbM^YL^QWm3gxBk}@9ewXWp}TMkx+ZNTgOYz zch|dfL_sm3Dr%8VTU7J5N|E?L)mp05lonSCLPA0n5&{GgpFkqtD11OjAk2F+ zYxm+rs1gw0=FR)f%zMB0=FQCRI%&P2rX{t!Qt^szRVuI6E30*Bsa%z6<<)B5m6iaP zzM&eHb~UM}3u9-;JME^PeAUg>-Gbz-y0t>?nNex{aY?CEy&^QuoB{RphdJ9ft_!_oLP(x$q39r_mqbYLQlmHSXtpEIrqY_MD;X^wtOt#D zh(*rYniVwqCZu|~A{X5&ZV|&-sS$yY;Jc0X*{rTQDMJr7glj@~@M5DUrOPISrp#$X zY!9uVbs=aRI4w`WpPkB>;K+8Yls+e$L330Yr$-iR%T0!&+f>(KeZkU%>j-8eOW zWb18l5y3DL;f0+@+7ZR46uASm;Kv&w5Ab}M^MF>dKSVjw*&0GzMI#7dSnv<1d}_u6 z_hZ~dSA1}XZU^`(ev><1m1 zEJSOlc8DGDw8ImHrxo^kUtCojH7Q$~leJ*4s%*1I?M2(s zGNK40`uS;~rZq*+n)0k+W$ZW=MB(1qjuEF_k#5=%>4d!>i))r;ShA6I%&ZfS#9%^q zT+tV0hNF?7(L289Ea{FALR;_v8OLMbI2dZto>0=L904VY1QZ9=L&!kQT9&3aomN!9 zz8+-$NitN$*0@`Wr;GRpNLJ^t_Jn3F!U3eur8Puqva4^HWF$o_r^TLn0_#qcR z;9`~85vtryp4&Ocq7o+fkfU65b0K0_JXCgE0~zvndIZH^=}{Da=Gtv$nS97Bled{= z@&YjIvo%MaG1P1Z5}{zBejU($KxgGJUptq`1#q@+5B5dCT3Pv=gjUQpH8rKASy9U7 zFhUtcwG4U3#%BR)o1HeY`iwaR{36HDfN2?XI%)$@C6Dg8faLQjCn@W&gTgC`)q*YK zt+jg*q5=lQZTb+3zrp1f)v++y>i>y8is zds8~>TZjdU)`3nNNB;!)J+Ox#x~9jm_jTxfa8EC1&$Grk^ReIIM6YpXPjg{_-+eoN zLsDpX4oSlGpO#G{1#B4e89Iu63YAeLAhsxv4b@SaK+z72M(@jr<+J&wZz3oBg^?5P zFjm5Exxl3KC^Pd}+fk<3{uF-7Cs#f0X~IyIJn8dn_PQ?Yp-D-Gb!6lE2=gl zI|fd8g%1h%kPXIMCl_YW-5yaI_>H(m-j!O?Qqa#%W@RCI)E&PrAtdpmEf3YjtU8O&OAwa`1{;kh~Iq zyF_el7>0?z3^v3lp0wi6gN>+P^Xq=q_xzH739&bWSD+ta`J8HLilbpshu0E2iPI@4 zDkW{xE*M77^4ffregWrNeh$T%pb@Rrt6qs29AF0NRMYSlHe9%RPmge!_sGFUzyEoE z+@J7I_$U2S{%QX)|BU~*pYt#JdB5PhzT!{&sz2l7E)@Fxt02g~{9`EYH2WuiyiVGt zJh-rXNzfQ9=2k8ia+sC9w--zl*zE-u7#J|7=QY(4A~XRVX!WCe*pgd8V{CF-gKJIW zFVpM`p}xBWJGo!8!_~k7BhLj56d&5ID|t&&ec6>NRkz^f;fq1?YLff(s&^$rNRORg_p^EMM9G#tvq%I3gj9JT#2y!c=P*JHWYgNOh9=e2=v z6fsN;pAB3GsM6Cl*2pML%K|-5g}TP%e$sC0J5- b$t$_inu6t)lUQBgH&@Hul|){?w7var<$nXr literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-VECTOR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-VECTOR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..07646e2833b77521fc0ddb361b0dd21ad1911232 GIT binary patch literal 3693 zcmb_fZ){sv6~FH}cAPkIo&KYE9es2wSxukUv|X3BTelbcC2{lYXWn~m8$N)%_@!~@ z*p}^7D~QmQA&TZP(rVFrY}LMvZ)l4&X&tLFX?#FJAU>cWG$as0Fa**jJ|K`l;dkz} zvm~uxADZ~RbI&>Vp7T5Ro_p?nODuRkWhklIe7#(88%k}VRbOZ+v$clOtSvNVTxAw= zMn}OOKY8rf$)k@X z`^Pog5Y|4$m`9GDJUW`}U%R<1#cGVP8MaEKkFgjFFzE=R617Dx}pWP(LQ0b`zE1^nne=lRzz=wcY3BpYo54uQrsCT6V1vNw% zh@w9TY42Q|1`KlbuR2|*8z0lPLkxAN;5&Z+{i$QyeYe=iW+yP&=mypY&|NUptO60{ zaieH(GhYVV#Vg?5Q)EBuA{zu8@&iECwg2D^9>0!vvq&>8|^TaEHb0tS1nl zg*SfpC~mkoL)ox87h`h7d#SxQkur1X4DCyGQp=?c-BQOgkmM%pggof?$$fajctUuB zC;&r=l;)%+RZDjY7B+B-SAdW`Z995ameFIUC=n?`*K&otI&NB7JK;;RbmwTtO!$$& zfZrGBM?r`tbj!j%Hw#X_;3NW33>ZjgxoMTl$%xmEjch3}0|CbT9;zy%R2xpiP>+6A zGl&@h6CwbbLu`@|qzaa$=QfluUn1Q;LjK8Qq%>O>Zha~_@;@Gy*Bwcvg!xStF16Cr$+86;;kvRXAPe&BJBC)& z&g-d+X7HR=^9M+j)l!zZZsUH4ddJ7iLN1+u7{CH2$UxpQCvwDn5lQy>Er*(VF5^sg zu-Gb{f9ppoF*Iza{~(bFj?qw#vY98^zx_jy%D;h!knLDVN@CxKiyd2BkR3lk+7)Pz zY|#n;*@EF@)N}^(WMh^PB+oE`NDO|N!;r5Fzuyw11yF-p`b@#@uAzJphyr67f-YZx zdO$aHnts)p&hu?^&QFr=D8L-ME0`S0QAdG&p<6&BmV6_ey#me-fun~L>977_n3g^u zx45Jrh0F}LokhZ*k}#dI^M;nv)2d^V@HWRH`M`4cu2}vb4(Te#Azc;#E((%|uUICB z$_nf#D-PnPG?oni2$8V=D3Kn{vD@&zYpeGO%Pi#i%(K_H3wD#+X5SO!Sxoc#t!mLv zHvQx*M3HgSheD3$V8KsX5Cy+fFdco;e?SM*L%IK$pB(X%`~76xPu>S0fnl$`&vBbA zW&fhKUzsi9_E}QORdI17+2R3olmFngL(NvBT)jZtyWY#*4J!GcOJNf`ItAJ}OnCh? zGMIVIu>AyKnCpPqcnD>_c;XNPrz8m&#V8Wn9 z82tt0=|m3eI5zF*l7IM00VbrsZv-g)@D790OTwV--3UHQe>7;^yB5SPRU#157%_4H zdYUXMMZ{eTh<8sgM4e81*BH_JHo4orkz;>cX1!0Aaao8luN|)x=btJSX-c;qU?^V_ zKfrK?!GJk-2G?CF;3uJg5B7^Yf?&72cJkzyj+0Fnmu&v!&{|)=?!qnFou#Dx#-8)q zL_V-xS1Hdb4>im4^@^)ra%Wn#hFVu@PhCXwpz_$`rX*CvHr8cXOLYPzVNdrZ-*5b-TO3AIe)e*mGR&v^gmYzc_DXJC$PRc$c(-(n0Y!*G{b90_47Cw z9ONSI9Rq1(9Xjf@hw~M;*mRXr itvcLNFy-!Sx#}v58f8>b;Y&}STRoeTh5ewpw)S60w*h?s literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-STRINGP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-STRINGP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..194281d5694a31a262e3bc7383c66eebde7eebd9 GIT binary patch literal 3473 zcmb_fUuav`89(0a&rY2u7+DE4)w zRhERL6uMB;br~H)yQyoI-P1OMz7z_5NJAf%wZ(-FHW-w`!d~_;*dORa$I4)=P^kBP z=UmxNGDg{EOa9LHJKz8Foj+bDUFX!Cq}EpJ<%-*oY8PAei!EuT){vUDi;X2$S^-?T zq#CC7Oh!=`MjsxFSi5GH8g8-WE=%@Bx4B$=Iwg%wNlLv@uE1b&64;Z|6BE+W#COp@Rc)5yN@A^v;5Cvr2yV?t*xBC@~;}pI|ZG zNOSt_*rpMC(TM$kv#+2I4EqV$ygm#A_#jkDBsc@w zeh2t_p6ebEN;jE5U_V*UT`^+s6S7`<-iR%T0;sKD-+y*r5I_$heW<#W*nCq=BN${N zeA>yR2hl(r!UB!$zlZ_@pK9o%-Gd-Ti0VlmV=yXnF49FvWiSxB1L7=N-j?D}We_~T z5N%Wj8Fve4KcKg^>jrZj)d);r0k?l3^)FnZp?_B)v>cR2e5+HQULGBk1wKJRSZ*Bu zZ=#04d6joE_zFn}H2a>8{s~OqUY{!JnsIuK0wiYd0%ZnmN4D#)+ z<}^ij3Ub;o^H!1yqHwpiZ6s+l6s5f(+}yFGW}1d68;)IY>|`hc3VlgMUz8b+M*Mbs z?2f}C8X|=5!4qN<_xlhS+M_+L<=?|e$krC~2&0Lf%s7y{n^f!1U<&_0ZR!mb_MCesIh~#JV%Sf)!AtWVwFOqM8 zc$A4-i}@J?LlnP(7-!kxh}b#6y5}HBEnh(1q5F}TbRQC(lPM4io3LI+9?>y+5XoUq zzQi^9=m7*-8NeR60ao}63sLwZ3sLwj3sHE3g($qjj0-*|-)Gi@OPs87@=ZQB&&erH zj&gEnCqs4&qq{+_7Ndudi*l}uCXf?Zoa8gckxyB;$ATtr zvY^QiVO0h!&6Z~k)yYG_6zt;f0y+q2S`O;kxkj+Ad+)#=1FVbn*944WRzXv*oFPjKypb?jKy9k*x_(O&`@&+4#8Av9=G8&b7!ViVj&19xbN9!2zJ zK=TbC6ce#CAlnzn$o67^ZHOd- zvstTc6*c!HDaCxvZGna+cRB{%Lf*76RUG`J@FzRMK1<78&9d5Q7lu} zM|Q-8-!pMx!+Qn=&iNaI-Z5{?JMN8p6W$5$q<6}j^rpO`cfniomOa-~yctjRW8GUIyN=G@tZt)}Ew+*P*B2Xrv{)KxNn23`X{&*0xrZk$%uGnX^#rDw}G9txn5fF4k83_XcbTQ9*I0tZ;R zQoIab{`;S+2yc2ZsA6cliqN9H4;TeJww0XUj%nxM0Jh=ifE(P=x~E~j$8u)yd?}m) z<{oy@%Dc~>21^b{Vu?53_N%q{n#N?&o*4DoO!}+f{ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SYMBOLP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SYMBOLP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b0fc45b3cd902b474c4ec5977008e0a69b65e225 GIT binary patch literal 2274 zcmbtVO>7%Q6rNo>KXq)!u1ckv{%oU01-EOQl9n_e(amNYyI$`uyX&+$A(J?@g&RkX zQ;DKRQ4v29tCqA-?G$=~3*tbjghZhzAg&xa6d{4c0VFt3kdU~b^4^S-ray;DBY>r$;n61#W+FMwHH5c^usJw9 zIy91r+`e*2N;C-}(_|IJCPES0l-Bdm$IK>{2K2lLwS` zb6#y!PgNV3&dCKL5fZ%R_vXr`?iDOExF{`4(cruvE10Scsc93G$h{pe=v@l@$RYIr z{JT@7G0U*Yl}qungh+oT6Ef2IqIRPwU7sU2zbwkfcBYb2_X*DNT29F4ULAk|JP6fNDWO1mFoq{}H1)ZE=PPI(1x@QWK-qk@=MkxPoksxm){1f7 ziho1MO6_$kUX&%6xN>#dF{Kl-myjr$P7kbpB0au=yEM1Py|>=z0#C_MAH3nQwt^8n z92F4SMY?#30Mu*9l>b4r%@56L>w{Qrpd?Fcl%fzNnT(6zP#h}-FQBykegL-@JEZK+|eCpDu?*Eki`WjjK{c~%t2xUlxoIZJ(*4$+m1fCMKZ}GC5I&x!j$=8hRrc(% zmkuStAez?9DV5{sB=8eM_iU#A5Fsp#J7@>)hu^_bm_kud`4N*s0-A^F56D0-I}SBB zY*!}Xw{Ma8odW5aOGQ|g#Lpi<0V9KSk~&kW3l%dcq73}UN?MVsn&W6w2)zbSpQs~0 z3=n$-u$~DBN=r8C%WM~lGsq5Ln2qXbfi4PBWGMvm>`@el*>)63#&aYXgNGG?;1l_m z?L_e#Q&9ZMcBA-|J0aJ&6Y@UWej3u);!-cyIY!jA6X-a&?C;QC!=44KiFMsXJ! zuAmuwK~;MYp^~OM*1C@!0QKa?tg<<7?}6~rFX+H_tO*mfn^55$B808-6Z2TX%c~}| zqd;92!+Bq`K@^|C0oiTh+VQ3QknKZs1JIjT2h^CfEmi*B(uM7SmZodvUzl|bw433Nf>oeHZw*Cm+6^0|2NKde zs|44I;F~RW6~1?7y|&knIEkA!OOj4Pg41ort+Pp*SEo$btQ5=%(1@s8_l zCcDO7M@^wo2z?~VYJy{G<`yC$At3|;l2(PLO>v6{!M&Kt)wiK@BK~AE<%QI7Bt}+gC z<#W1e8BYvr`bh7-zKFf3XKc#NSKNZ)%(&Bq{E2N!-yTJqoGNl<@WuY<7Z8yf<>=;ympt6GFzw0+Lojx`<4I3)QZeW7v*5m`oXJMoSy9U^b|> zKrU*|Hmsn!a=TI~PpY1K-1RV>W7C8Z5`3xJGMLNgPSVT-bMzE#56)LRk{LA%scAz7 zky>hA&^ryPkzML`_&aFmj%j7d#rgKrgoGYg*(D*IS0=8G&?_bK?yDoxp=fj^4L`y$ zK0hevr#lzS&I@MeQ-b{(+CZ~|kcCT|paBnxCZbWnKzh)ICwd_Ia`k2}a5V-^g)SPl z0av^V{HoKDW-qNhw5|rAg^+eM9ow*QSbL;5D?)nU~t0K*MW4Idvf0nO_M zq&4I?pMeuI0~#FFGL#G4AHYSjFwsS%_Tbs-x|nWe5=q>G)L|`?NEwzokOWC)$c{;E ztX1lOw-w$Nc*F2E!G5Kg zZO0gu=u&IPjIlO3!dm4{*#A0XhGm(SYUZ45&WXt@z@R;*WkyvlM<+qGtM9h`G$Iqi zLb!>J;Fj12jzY#kErrZxV8RGMbCBJL2=ts~8JR^pHlx_L3X$I|h_2a&2+P`_TYeu3 z7TIDPG^|n8h6<$&l>Q0)x23faL$ycK1183l|9~>V@&f^7zXMtG5JWZ7S>)elcOm%= zh&#BsW?9-OirxTG*n-h8)5yLo6klLb6TR#`Wav+NEekFzyMY<4G-5%w`8 z{etXZ>yT3grwA^}Iq9F=i}VlfMS6#Ok*;zt(u)wVbs*`e07%~sE~M`Xqi+aO5w@Qd zwnv2RK4H5}sH_zv%nALMAb$hDwYoVLR1-YYcQ`8gdv-T+zZKkDY%OxX=4GI72=3>+ z8uX`v`!QRODnAn3vm6navGG*2LGr4#a3@4Lzx)`07%#TTqnNbjxh`SP!D+!2vUu zNo11%EVK zz*LmJ3DOnG4D2KT$VeHOAj*FR@^-iwrPQpMgt>2_@FxJH&E})7>cbkBEudn}P<2ML zd~JOf6vILh?Y<3w+iHLj6}uOuPlGgeOB(51%1Nq;B!IA?#(;>gEs>WnDvM;s1^PpR z3;~7?EpZ@c*GFA`5D>^P`!Ud7)`ujZ9{r3U z!|Xn^?+37J5=lFo(sU!C!U<#?R?WddSQ*&8Um&!O2zeFo zMC!vaWSO}vA9nIhj)7d{!HF-(7hsGVH}R7!KF#9eI70_vTh3+p^2xEd1)`>hbEabq zv&{xDAzZfmS-g+MH?eq>#Xk;_L(!mmx8qJ%luakKP0Dy4zE}!Mu_Qh=PG#fx$9Ym6Z ztu@dJ<9Q~1$o;XzO>OCYt}R^-&b0?;+k?3f>w{j%CX$1-GL(Vh4~#knWjjx;`Xl<7 z56-O)&aUQ~ECb@F%3OY7o;3Ft;il9@f@;*uA3IXWW1hDk%`h00AI)$&L$c<;0r-5O zGK)h8`v3e=jE@S8J;7YJf4|@7Z};Q=4u7Y=%YVS%?eFpP{t|TPTjfx4TlDRw`37t^(iu<9Tly8siFT2#4F0f;;J!3b0<3 za*21ik4-`(SYyZY-i+JunpZ>|beIQSS1lBexuxl1xs>;m{M1zbMDOu=($f#O;g^Q- z_uBJowb|h(hi4~F6`#}Qk8)X8v1L4OB7l~lOtjkEyUT-&cCh9x}(Z&57V_(+ZJ4yrv_&&@+w3guEyMS-%p eCm literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a475379f9fa325a46f2b1b96cf97bd60736c4c1c GIT binary patch literal 1447 zcmbtU&u<$=6n?u-jDN(IT~b3_i*5p3wro&nQndjIrrSwkyxDbj$CPrZLgLgGPHb!k z6cABWMdGqjYa*&0pywVzLPCmY6;)jO5A-kKniJRX-fjYIK_U{;j^50h?|tukGjDbP z!ylTKX13Qm%~rjuwKw~n&AztQ?rOdEW_P8ot)XB0(sW$@)dDjslW$L@yr*_ny7lFL zeN_{i_1^08)*IT?C5?5u%@$5BUc}{v+3D%o^D~pFIp$dr+X-T3re|j^O{Na--BogJ z09b*2GD(0O#31;_&*_4D!k8;t+_2dq*MmXeC$JWy=5aUh^KWVWcE@PdKdZN>ob?_k z0KpwUF;}xqQFiQLSGlQ-1h@T6**2?NIm*C#r%q;+AC!bSE z$FGeC6=iP&Rv%W>tA%1-i8mkI062B)g}l<(yPn;5vba1LSht<*ZvcbF*G{&gDjA&q z^wQOriGoG~U<6>lxl#aE@;rqo561p`8s*L7G|5(s)D%PA zPWIr$rTk}#o#Pal|EU|Rc)y6Zzu(A#nhC!3OSMa{+AHp6y_d)GX{7gZGzqftMZ7H4*?YRozAqNhtmRsI<* z99^bkX_<^s_hfbMx{hl&HBqezJ(j|N5uMrBjL=UcfuEatt{c-a069c0n4-SgMxr79 z0kdfFDK6q9fC*Y|kOH&jy4-%M-=#u(*Gc)`2VpXgM`>l6wo7u9%$Ph)CL;@IU@vsS zFQF6e%YrLM9eMg)SqQ;fn0>hFI`cNge1Zv5e96F5_7<6CRlUF78NCpK2nq;mrBwx= zSllM@VJ+{-5_tCPDqjn}4|b^;UNK$HL@4p7#ln-d%7VMh@?@G|SoKoP5j+&6oRZ^I!;_u&?f}s2 sQAj2y5Gr4dME@wqKYG?%3FvgS_J-EmTK~A+>dnjXp=TlR-PGaXpT(b?m;e9( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..64251c99e92fc0b88e73a8fbe7552d09367e1995 GIT binary patch literal 1816 zcmb_dO>7%g5T0EpuK%&y#1O|SOVUcnu#rNNstt&;-M%Eon_YKzOfdoQ|2nwhYNA5_RLEN~&kubB*hLj)?iAsK&eKX&DGxOfe za~B3L>4u`$*BaGYxvA7Q+Kr92vRZE{t@=iDxvZ?BUU^HmZ1(norWYojos2m9EX&RE zQoFpOxEtlx%F^c3%H$bEYc#7h{5X9Yx2I;Or)Q^TCL(j1V+giG_{_}APEJik_U_%0 zl63%BhFub2fFuOKd$*I!xy*6ZxxB$tQ(I&?uj_R}Sc_V6nC*2^&nWGBL#>rxFW0D? zwH8PK-tA6ku4L+N-ZH%{>ADp2Zgt{$Q!Qd?+B^d})MFub$?F_BrB12rf&usL#BKn{ z6RD(3iF{SrDM;Jv(Ehq0U(94uQn0#n72xQNBgdr5_Lao0mB8(2_f;p3!59Q6J7Fw)t6m~bsX z*<}2@t;Fo1OZm?b@AX5(A7b9W^hu)+k5qoXPa6B5q(t&&?Txw*h2=n%_k z=4I8_6N%SJPX1$nA^`wCKvQ#!CgDjW8elJJ25m-h6Ql$*m$r{l271Z1nYnL7xkR=w zW&Zbp=$gYsSRO^Q^c^1}ai0&9_=2ZNye5?ELU~0fvqCu{lyP4P+rARM^p)^2PuqOR z;=^ZoI*UZ|IOaK6w5@rQcEgxT0*710i*a0=?&Gglgyx?@|3M!9vC!@}d_aOG)k$Sb zKXGD}zS+m4TZ=`5UE(8T_=Jy=_(;IILcF>U?I4j+bOhQJ=z@SfCq$Z#tCyp@z*Gm{ zIu(yk_`sg;1Hb!V_*sb0(I?XLAt>vCKNR3Cfx5}FZz51S$4A~Esqv8(f1<(1rupbo zJe%d&1ST)1yw2lpxz$$2u4!Y+>Jt7PtSHrW@sgA7+DWSMd+)BdMO}GZx0&YpIre(q zzhWcrGFvko9wiu_>4lQzGEwmkA18`UpMsx206!@#SB2%oLCaC!0zce*;Whwz!?y=8 k@F^dE`9W>L^DkVfuPd$1wO8u3);u2{cn||0oY~v^6MZZHYybcN literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..09e0593428e657514816a07853846d27c9937dc1 GIT binary patch literal 2008 zcmb_dO>7%Q6n?u-jQ`@=RpOG=YFBB>VPPYsO-e|GV7nbV#+zMtcTImdpww|1BPX`} z0}6;zRY+Wnl2B3Y06ig29H=TGQIX0L+z?kJ&LHl<5f0(aj2#++L?j}4^gQ4D-uK@8 zyxA=nykeM&QCqE7s^x}KYq#p{ma<%HD9u{CQ7S9Th%0XywnN^Y*Nyz-`KgHen5Wbz zFSg1{iq|eTmloHbQKp_#^m?OG#XqyNI6XHvJw11JW-^k|T~nwXAZBJ}?#%3DWar*p zDNzG}5_Fjf10)~-{s*0e>Jit|GC7lImcBq#f6MQLa4lNVC63=oo>5x0x>hZ}Uaqp` ztTsUc@Hac5OwlsDoNf7cq+3$V-{=hGEUkb`)3XHRP)~)aOMWMOPCKiSOGVv;dv_zZ z0pxd*37M7h^~!c$dbkFyM|t^jdMqggE88~!j^2J^L|S?HYP@U5ar*0)xnak@1=w17 z&yMG1X$b$`KX&;9lVBqR5CiB|N(x_KU-ienY6wN}H`X)XA2>%!ueu&tkY!{Hi_S7kqFcp+ma&}$SEZ6H?T_|sl|}<`8V(%6K8mZvacoDki(aAV zseuFr#8ln7s&Sl&_?^VmKl(Br0H6b`8B?si)=_AHysVpSQpHJ-6`*@;T45C!MaLo5 zW1UYW=DWr!|9evm-6bL|jWYK!I?T*49bsmWvRu+P9F)2ol zOz=Mu#P@}{v4`(saERgTzri+JP8p6fAT2!ozvlGVZOkq zBfC+IOnP)*&^H9{7EQm2ROtd8eS=w@jyCCdot~Pe$DgL@G)*Vird;RH4(orX3isyZn`weXm}Qvind31 zL2`snu+9CBOVHCupihbY_)2)%`#mM$QTBV{+yg(n`{E`5>cXRa9Qd40T-%H0v3>Za ZDYZ4FxxRY6R&8eK#K2w_eDwUz&R?YLGQ9u* literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUALP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUALP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..69e63f8329c51ac60e95202728b70be4ea0eed8e GIT binary patch literal 3172 zcmb_eU2GIp6uvXtF5R}64vop)gEKp1!wQSqfZMW{W zXfcq67>&9DrGRr$5~Cr}7!yPiL%>u+!Xq(0Xz8dbh9_- z-tT=dBD@3N%V~+4k+$;B72~3VuRAORnbN>$rN<9Y=PmXZ7nU^np-!Pc4&?v)E*(G zwRKy|=8dJZ=gvr>G$Ev)%%BMn5+Xk0oy>*8E_GbBBVth1)S@)(O?kNzn2Q>BsO{yd zo>j)uqiQN~Fp<% z+@vj*A6-@}4PD+} zF=JK0@XnNR+^V=n$kfo=Rz;621)+PPc6TF6U@IY{oRFDh|2jUyg6b~?)e;bae_h@{ z_#;>rO?Wul|c(a3qUJ@=7&}cw^dbG*Id0zwW%Ao;kMEF zb>(+@9hXLB85q^#KGO}Vnemv~VcAh9%p_S_80}hNR^|(_fUgQ}uZl3WZOc}zxEqVR zVc&8HC=Y99ugY;0@p7T2hi=1=j}TUbSD=b_+AR<&qPsK$2RC8h#{x7Lhd*Hjdfc|D z`M`b4B=lX!%I6kG*BmO+vNCj^LnYI4p&A^10K;HZ>!GS<+Zu=7Wh>D$DNI(FLEshB zUDW23J^}6%W~VT^FdKwf%Z+@ORfCxP7h8emcUFVuGFye_YtXE6TpRXG)wNi})r`nq zik=H1cvJ)ri{O1CxL$xO1sLFpo=- zh@Jw@vWV%@PRdzRz$&K(jp7!%y)m4(?=X-8dY5Kvx+`dhn1YTJt4H%9TZ?9o0J~A5 zJ>tX+O{eXuYoTvDfT4&9Pljfwa130~chIo~w0&(6etueoz*7ME&3Lp;0CesKVCbQ(rB|KSL}R{hzrOmbupN3ZjotQ{0tUTQ!{J+{zO z#XZuE1s>_D@JuZ93<}S>g`VZyLw7B%+CG`rE^xA literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-AND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-AND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4a994deb272bc1fb140f77686afeff6a2a591e89 GIT binary patch literal 753 zcma))Pfrs;7{=e-rGJ1z7NR5?gA)=i8>dMX5b@%;Oliw@7G`HtIg+y2CWSWrV`7ZN zc<{7F3z5uf_zqqXBL}~b-=NO6CK9}O+SzC3eV+IC&h#Pi%yy97JZRM$K^rxD-Bz!Q z_M2_gY4+OH0PQOsy|P_SUl)kInSGp_@UHAs+re%(*h8WhboO>%-b1-Zh_u@EhFYwy zs^68hrKPn8%h`!M@tl#{f7C3mtmSgqiNV>aW;Ow!3YYO`9KZwv0QoUY=Y3|2qRZro_D0Ld58+gi;Vp$m zHYn)nKQ6JmCd1SUUc!W}!`W%F5_j;ec2UyK4`KUzNv}-bp3xHZi{}8dZ&MkqcK(B@ z^{@Wsd-fBcUwg+&x;6!HT>Cm#8FIuHX@CsCWxYDvubFid^o0Br-mz?#trz3Qa6tt+ zl;fvGrLYap(#I6>jAavH7ci&7=c;3Sh@A9xJVDF4_U{SdTG6DDipGt!qMWuU=Pt*t zFSdMP8RM!TV-dE4hq`A)3fIhCn_9{Mh{obk8Jo%^nRj`ah(a7@`s z<*?U4~Qfw2`7lxhFEbD}qiJEgX>rw7;uf-yW(T ujvh{|9W83|i#*X))V$3p5foobbc%v<;&{vqTP53-N82kpWgWp>K literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-NOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..989c43ebc3040d44d48c29a26bfa2b123856b721 GIT binary patch literal 753 zcma))Pfrs;7{=e-rGF`;5GBzVoRDzYI8Ca6fEUMQN=uhnn4L}KNZPG!QfSjZCdNpN z2TyCX5Xr2D@8A_Na_|fJ4RE%YNZ{gWXP=q(dEVbUGlbZ4%SKjvuhVS#UDO`*JA*!| zx4Wp<9(1cdsw*A6wj5616p2;NJ;|rtD?8P$zuWg~NDTa5ZTHm!lwU!l(`~lYVtHBp zF0C#stUg-Ir3=KhFWvs5W^rjXzmiK|oE&S}HUL!NJo=;nvS5Hb46>%6uE2$oO)(>z z)RaRRBozzxT*_rI^$_*j9o+I?`mG3OuLl}{{1hY$9-z z6!hd@m&jd{L1GCnVCD!oIgVGN4!$?eHnh`y*#5DhS0?XHX|d+n3xMf&iHz1b{mIn& z_ptnd{Q?*^-m?u|n*ca$e4D9^I3kNAKnCEvS)Cp>vdt{$G5I;TXIc(hD@BdrB4KMb z<@i}iDQw*}^)W>}Wm-g7Ma-%2xa!y%A;;YvSI|veyLm!5W;kvn!jzFzl#?dq+~L^q z#Fi&aBc%#5CSf~xq`PLQaI^VqQ%e{C;aD^(qpVEg1&41EQH;VYk8{edTtTQkR{E`f z92RlurMv0_tMb?=YF^z!oJB_Vop8ojlfgtZZKTGG@=s-OU--Q~nmZtKsJ^RSUkx?) uFCR{%9n5R;t31+G)U3rR5foobv`d0=V!PpZbWEjgdyb&tZTK>Kaq$NOw%?xs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-OR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-OR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5d5f9bde7ac674f219fa0acb93255c8b36eb7fef GIT binary patch literal 751 zcma))Pfrs;7{=e-rKN>JTB0NxgA)=i8>dMT3f7C`GNq-ZPa%{?Cn-tpgkBKo7 zCK9}O+SzC3eV+IC&I}>;%(9Wy-tRP9eiyX|{m!6| z_S#+4YY)10AMGg}y|NrmUzdng$v)0axYu^-UBA}%caa$Qz1`Z&2PpRlkxsYSQj679 z^_wp&EfpRvXD5opwXfX%qh>i@SX{|YT%Mk2={5k=;UfAZ0n%WAJPOjLpsv8hvQ04~ zo79v;86*@7_FT$kkXc0ib_cio7k(?k+3$e{AU_6)qQ@*zc9=ZY-e@WLA($#Nyrs~{ zIt4xP$0c&tWDw8eCG2oGJ&9MN2EH}UH?*?@*#5quSEui0v{>`}Il#=@@s!p$`@z)u z*Rb-Q{R9{`-mwi`n*um$e4VY1Fd~ZtKnmcZS)Um;(#e)ov;esZ=$YWh4%~_lhLGg`1yDTUtwi`}H$5iOH=Lj0!hR<`Cm%jlzGT!+B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-BOUNDP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-BOUNDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..50139375407ec60f9a42926c07c4c977429a3b24 GIT binary patch literal 1813 zcmb_cOK%%h6ux&RiJxgaPEzusOcJ$~Mx8)jeS}4sOeVDxdnU|`DM13sI1aXO>L_tQ z6{3o|VC9Os0W*gxV!?uKB{q~GvOp|ZAR)2jFR(#kffUY}u}erR3KFucbMAS6=YDq@ ztn*bpBkR?T&2pu#gmy}BiDS9i7wMR^_V@_V{v8}FwyeR<-=$*6P8Q`joz zYsEF$-6?Lbdr&u94 z8{3RC=H0D_7jvfWrY+OkFa$IkKQn2amEhIh0}h`cGshJ*AT|E zN*^9mG4228!*90xgt0hopL(>!le;!byXB{MzE^tC{{)DQQlgxoJNURhqUe^nkfw`L zQ<}MuF>G}{jTZBoqX;302%Y%vKqg3vuDN}pq6o`ot zh=|>I`==Dcwk=z=a_&mbRm2!3#1+k4Reigo02kwEQQXmYvmHI$D@1={egr%wv=WPQI(?>-%dLy5<a1qxt&G}cJ2|^y1O+=H&S$mdoaxh=OuxgkBz}eg5E#OE+f;>#jsaZ2QMaLOkwGs6PzoiF}o6q!NLeU|xN=lHYi9El(+rkpn+WEpiAwaIOQ+332G8# z2VxY4H}i7Na*bezKfrk^algr=093Put@Jc>nAJuX3($pe1X0lykmz-aiiTP+;awlA za184-Vx9SqSl{(=!UaSDDvTE4{H(Xv0ZHhEKIk9!_QXgy^o&;*OZg4{_gMDnOGih4 E0&#%%p8x;= literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FBOUNDP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FBOUNDP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0990fc2e3340614de81da73379268db3e73ec3a9 GIT binary patch literal 3441 zcmcH+ZD>_x_&w)-@80RXPM1!d$2l{vJL+unV}Wq)x$oV*dhR*b^Rcy{U~Shn+1%Qu zWTA+Gzi!%E*?AMIAA(>%5(&bLgd!*cA)!DJ3W9=led- zdp1o%PwR%FkByEGkCZ2ru_IICN2Zj6V-w2c*pZ2WvT_jk$}75M)8lzf-@o;#_Bv;d zWMHD)KUE%7+#}`5!Tw`yO8Xu~8=n{+0c7`XAa{0kbaXx0xwS5*Ifn4|05+XFyE=Dl zt-E{SoRl0Rgba`y2x5dJNr3ooRFY|zIFLreQsE$!%`fi=9Kfo1^|0a`G%f!2j7JdB>n zduzdC5Cd*hwQY|i*5z8P`u`d0jiDzGRo0|+%gh$=YO8t8%o@~I zGX>z7-A-DLv6vi%Uj%+3_yu8xQfXat^}K3R*Rx>;bUs93r_XU|QI-~KxK^6Q1927$ z;M^=pQ`@#|)$-hu=cWU7V30^_W}nLWPMS%9CBT!kd$WmC6Vo0kPR zBy0v*Bf8zR(6n8cri5vX+mOEn_=TI2pTH&vXCR`GJ3z+EFOByf9>msExwqL9;Gf)N zn-P3nH4)y)=kraf+#3wrPCjB=5PXOx(2J_Si>wW~?^U@~lQ)@)7k^&y+ga)v)&jlH zu?^7b$64!Rtd-x~V}50wTb`U!T25#!%E5kk^#_&V!{Wh4-ieJ6L(cm%GB}OEX+u2_ zX_gSl$X%epwzGEBZuZX${bt>!noHFMLueFSYHNnW;;06<<$!0ol($z-ux;Q%x-%OP z3Z4ykuX^bw2HeBCQ2Qzm$U2bKDURuV;b+{RiLhm?fh}h%SR-VeFfG;bVEf&3JC`Gh zk)DNh6GX>7enrBPB%Q&}5Ji&Osg90}tKlO%p+^+^Bd^Mn1^ z*G20MRAj#1u;5CfwY56QFfo3mp+-`(r(j!V5w;v;A))TsNzDfXd{2fuBpr z%~KnfDeTnsEJYx1^6?|i2D+Z+fi9gR_&xLhRacifRKwZ`w|)D+*s6q_n13iEY#Ut0 z2sWr>l>h`wo|6X{L1@xmK%-fj-iHkv_CT9I zvyz!04Cq-KKv>r_t%_ygAM!$aR^=|T)D)I-^}OcfRaeUx z_}E2s!$t<6$you+tY>2Q5Py3Bfh~?tC163vDxzf+I9$3G8i1-9*bn;=;U5@)By_7- zf^T&j3Pop;EY%Ij5zrWgcB{R4ij52AgnafZ{cJ_2mu%57?WvJl*77&U-0BInj z{1gRm;X%T~WPr-@1?O9`t?qW$3vbdA&+ILjSrweQRENJEaP{5WMC2Wuz6*En{sVB>3^SO&Z^HJ!kGvmO|{0*@bh@ zx%Zs&o$uar?=BMWF*z>Cxv80~m6;WC^ZA+iyfB`d73OmDvtt=y9PGkdvZgC%2PJu^ z^KhibD4Q9Z&5Y(VX~CS&%%w-q>=z<02-3`K)`CG#52(-g9z584pu4jsDj9JW?Gb#s z5A{YOoi(NFMJ|{lgp83@6h1s<4ONHuaN|nu+rrJx~InHliEY!tRF$twfM-;+WyHPMYXBPs8 z#0Y%We8}~p|2!f5dkE&%#OGouPWpdy){Gs3T<6@&MMc)>X@UYPdCE zRhO1~%4aKawrO>8xQPo`m8IofR>!H~CLWZIlFh6grE?Sbxeb2X&sS~dCT^~%FuuDu z^pW~CA&V0i)T2BH$rf+y91dY(n5`zn59zaGEe>HWMs92kW7Wh8u2e%?i%FFWV2fFThV&s?Q+~#)^OKZyydYfEHC`=fFxiA zO3ORTjCdddQ-8s(K1%9FmKsx)Z7CE0l|Z1?i6G(Y?2ijAVOdiLVtAm%K}j8mE4tVp z1B-gZ2=hMbgA;wZ(7?Jyjw_OyN{UfUPZ(j!@l`PIg}(||Qy-QkQyvs`#Z2kY5wg=# zmBxr+DhZz3yu#GN)bFXKK93(JE1*Y=`%Q@L3WOD1*K|=!naPwH_5@(5KP;&u zqGLxCo^9wZ4GbKhL1^3q4>oSCmk?Tk?YawlZvmoKD6dFyRAxY_#BwAP)hR?Nr*vIW z%kBos;oNI5*RW2OEEx*JK%JKEhG`GfK!dngpv@q-d$b9~pA<85zt9kh6`;MrP|T=k zj3oNC`2E`fCyM}R+ZOh-VD~yD>H;(S9wZ z4misWGgLhc)w2#Na@{eKtB#R;NJITlP_;SigfeLGMcVQVSiHcqqSIh2Z4n?P{|4ep z>e>+%HG{UI7=nAUQbkrBl3$|ji0%(?53pO;y+XSjvbdidFYbG`><$xOFa|$^__fi5 zG?Y@E0x-}Lo4SOlUruSJg2oGUH;Q+`Sb^lC@+MoDV?I!3waU68 znTq(pagE1JMVI0R^}{l{j}`j6UFhuXSKt&W?4fgBZwG^uZ7t1$;U?}xYHtOdWN}U}LOa?8?igQBch}L~d;qqM6RYrl2O*f? za|Y3AqYui)r|rVtq?H++%LwV*^xnKMn@MNJv(p)2LBf=y0;3O}Yzz~1D4|_t1xIKE zX2=gkf)8%+;fUSagK!+}bik4Cp2SyVzIUF)cR%y}>PdVVq2$v|OpqlS=_!(Z(}c7g z>uVsZIKUU9febeA8x(jHA4U}XJle3eaBQ24#MhS|{2M}}cl-LmSRZXVA{Ynmk19E? z87W=CgW{Z(5dcO4K)~R)&Za$bG(ru${L$Uh2zPH#))Gnh-8Ue*DeCA52X^1_q^S?4 q)S<3Wku+^h%Hxy30pu!x-1p<-QQ&|stDHxa^i^)-E|RO`rP9A8IzT7@ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-QUOTE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-QUOTE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ae6cbcb6f53b4198be8be6982176e1576948bad2 GIT binary patch literal 1275 zcma)5%}*0i5PxrLKcKBy5Oq@&R*WWYTq5EpBqrMYvTtES_MYeR;4vb(>h*<0tCuH>hx`5Dz;$j{GA zUD>Pl9950EO0k6C$PrWz^&L3S*L$$LdC>5z2HStc96a3D+uPl|`t%W(%Z#yUwnCzb zF_}eJaK9#NzVLi~Fl!0jHb#UN)Pq_AYteI_aD!UQezjVj(@Xiw`4W|Lah`F;f_t^Z zV9qxEtYZgDe37SuyR~%I)<>~4OqH^Eqnv6bSq5|+A_fN%PlAbz1Fl~TA77iK9%OR!C9;^Tmk7|K8y{8YClW zXo@7UWg9i&x{j+mIe#?gYmpQNq%^~x)I+St&taR*8G04RiS6E+)ok??U) zu8}lA@lmczwhxqJkU0eH8nkDiV=Hu~k%3D=t<%rXSJkfTMwdD}h3|bvEnaFoRkB^* zMTtHIOL%h$53mGipg(059jJ~r}v zHs-cSYK!&BMtw?Q%k`zH$+w?Tvd<~n!s5&<3{IYe>G9E{M@Nqw8;KP(*9g!az~90!fNuB?u%ZCILCq(qKxpdh;BH+xU0 zS$JHV>SfJP3zkz+ZE|I;`ywIIzdcDAqq;GDb4D@_-1rrUYa# zAj9i3H_sB1y4c<)O<#XCv2G<`dV9sVWF>A9vNHXll^BzyE*M^WteQq3kVgsWBxHT2 z*1!IZbiUQ+?Mj3@PYC7-VeV8T&iq>cL;Fhk%E7<3El+@gpI8ZK1z5wz6l@S zfFFKncmR4i4Uw)-Cy5;QKWp}9bj!?_v6|G9X66m*sJSw5%%Yo-yLgA(0dExE2)u1j zwmlhLV|qz-DDxaBJ6+Um#GP;%t;jNH^ah2k8&oqrTU4Bz;gT%vwq{m_$3vaGBNT%& zPGqR#SdMCW%=TC&lmLUyjAl-#f{!4fZr~+ai`mU?^$k{hD7j1FFi(YgfSWR5k=so{ zlDe-1Z2V?2yQ2d;+X>-eY`eYKJ$E4HFg>jqIQa`E5$rCF;q*^{?a@8Qp=L{ua|va? zfvopl-gV8T!3udC#b3j|Bo3Mu!2^I1WxQQL4r>WE8h5RB^$xlL++z3=ZWfXp*$;4tMNCYU$lSMl2)S25XWP!IHnQLU zfADMoKFbGDu@=CvfRy+!GKax>j|gqs#&3ib3oOIJgxm?pkM}nToRMq7gj@}DeLi#+ z)O%aORa-4OmS^*n%?FEo=p-LXVkp1+%>%5y)KCU5XoJd`Nw}4!l$mqEg@U{b2T^Us z|H5CzHX6_!sxhkWC={d2sG}J!kE0r-^^|8Z8Z6{p{xm`y77#oG3j9zYQG|s2y+*oU zg8u)mv{FjqAW8gYdUkT|wW&#rWoN;|g(HcAhnn}B(m0$Mut^n7cdV@%l=(26+u)b{ zy2~%Q75M%5q5bmXfuFaw`>6TNk@ph$k%D1qV$|+32U-@HVU1Z8pwc1y zWZ)ChaxRjJHZDln1R}riB7DPi+-5){j%{eV2EHSX0e5;H;s8gUiT6DW^pfVFeg_Vq zHu7|9fXpcn>%>x+uY2zYxcp25mC{M-Pt2W6~@l=bdl;~|pe z3K)y?~^LVb5?!=h9OqMu-jP4v8pggcxJV1=2d`WRA=Gs LRYE>*+`aoBL0$Tw literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-FUNCTION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-FUNCTION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..72ad45d2ff7f2067dbde9a655ca88c27c63ada1c GIT binary patch literal 4302 zcmb^!e{36P_505G;RGjjIyX(-G&zFXY-X3GP1?0VtiGJjja%o=y*sxJnv}VTGe>jm z$Z;mRiBKwjOq0=;q>Jv`RwU4nhL}W&gxDxbgpfdj0Ybo#00|)^1pgpFNT3NVy!UEWq0lNI8 zW?K4Z##HUxz$cEj+I2fq_b6 zO{jKCXuAuU<0nT3PYkqf-B_c+5+P)YY$9kOBuIS3U8x46j&3_jBAL<^Lmk(n?y_6; zLo7qJ|KWq| z2)3XWFHY%4HD}t8x{;sk+{{mQ!4uvzp8ed-h(W;-K+I0p>@vegVDBk2oDWZS0jD8t z-2A<8Z9VS62LOs6D$Iw0H!N^a1V2Fun|s5PdpDm(9@vH4ZrLR_2qAd&XC&sDplnrXz7*b9^~)rhBbOBqc9#W-U}rFPaLwZYQ@ z%_bz8jh50?Ba>DVrZsLy8I}C7-waP9JPp9t5!F;j8&fRZ$ym@-G~Sh(>8gEBltNxh~O)nMS6j= zNL9g-7ke?m*$*Bx@)V&!H(>2{TGx^)bZiJ+Nh6sjcwE&i^L86Yatm-bCq~VT5$9|Y zczqA|dIvB4FSknHVBH`|H@IkiQA=8!+B_SihiK6N(LGn9@Oze2WW`SGXW~k##=7`WzNI&-SUTvzPS^1C#F+ z%t6{R&lre(iM#0gEZlcZ2A)1Ih6NVE%_%rZI?B3m{RpmAvA!VAL>EBfDx^2LjP!Q_ z{)9yUiQxj$Z&^R+kbW${4+L<5r5o;Gg(nd{tL?`xWUmSJPYAt50kYh*be??_^?p)d zBN*BFjOk!9q(O1y3J@F60@5Oa@qhsB0yJ?zx4@mY+^6TW#c8GHIQ<`YmHv}`9K`7# zKv%P+k3;sb1n95C?yCZPhuw$7m&N&hT^#z?SQLrR3ziiDxF7+UuZ=z9qF! zp2@k>P{4g(0?%TwwbTO*AzH5?>v^LCqC46W zL@DvM1$hCTW=vTX|pa0oa`ZXI>2I-sja*i zq@S#j9=LMg7lTK|8#IjnV(PE+VYtygO!jCP%r~j&v~I+GeimzBrzv{~X4qA*i+Pp4 z!Sl*ay`44bx?3F>8P%Z?>S7M&!#yuBe)zRhU$VVA7(hkSaK_;GU3lqTJ%mzrfFG{p z2{k2JgVugK*bugaXfq+$hSW$qOY>mW-1y+-)lau+_-)mb1C z@ftU@J-2#K4b_bcNy{|G;o<|`aAa6k{g^cRXO2MY^?Q=oLg^np7F_@0gL(eVI?+$z zx?l97_>R+|$K2}VJALfOpr-LNzWx1{bCtz%aY3G1ESGb|%6oj@axpsxU-RWFUIW1Z z26$PMw>}>m8X5uu`4=y6iQ^4TekA?UUG+nK1-!Nb14Kq=yyC>|$a>i!*l$cEE!)9D zv~~Pyk>rdetvKrV*&6AN!Hl)O58uoAU>yj;-1WX4gL)kU1|52-p_7I8utR>2aK9wiS46Sh#VmpU1 y#&s>FS~}AB@QVv)%rY;+qCI0=Ou_^J$#Hbe*}og{AAXmw=jYyY?j0x9{ZfpVawEsHW;)O3O2y-)B0rqV^Mza~pGxz?z~`TpR84+vzbN%= z+_TxI&yu9_>0~iI#2ck_VJJD)&Trn$i^ua>69&6>!E{H*wrw3-w{P@yi+apOdx$mL zcXe#tve7qvb&>{igpd@OLQ+deka&oF$qGgcSvQ34XiOFqF)l~!aoh4jEJ8w;HQNep z;fuNBf|)*%HZh!$0-=Q1FI(R3gd!PHRk0`NSsJh}T6IxH=!MY4eKO&^WfVlGw$-px z*bF~?Al|9QghOI1A(N|<%gzzP-9v{y&D=UbZ;p}+pB>=(n!_Plja>Zd2)T8XkcM+h z!ZdU9a|OnC$9rB>z9M8ib6z>XQP3E_wz7|}tnd;NAY>|=TIW@j__dn7x-eOz(3&a8E^6{3E#)-`vx z;ri|wZouSbxGgYpg9=ff8qS1|gv$}aUfykZWZrpJSG-#a7BMw&zR*%-2*>NeX}FZR zwqmgpIi3k-gM?dZU$$09Bvt8(VhIWRMWrhyYeHufILbaf!ug;!Y3EEaVi|D(*8Wg1DRCJ9#pc`_WqYE_*HNxsW^{mzt zgd$!Vku^=#1T|swCX9$D1PcNYQ5g^%z8+!J)4+V5Wh~%nM1Lga_bkUj7YtV5KxTgE z8$0Irje1BNtHN%v7R&w)7^~@4wYX^D^jBCJk`kIGE3>*0qbU0hWR3TeC5gK1dc*2b zd=11N=tj(sv-csjjk;`fSDHIXlyh&l1=d^lKE_M&`cLl{kCnbF;IQ&8F4K?oP?`J{u>T1<@<2!VS*qp*st0X93VGKnk*W!Ft3PWQA5_mn9k}^4UXQyglfp{hL>!s zjbA)RX8Ke%l{Dw(=ouz}NqWaI$+iL@+vaZ0kG8dG5u^@>S8%d^)XWXe1Ek-(fN$6n z)y&5NtdT8eE6~LF0?xSwoY6_*-7CV)@a;qF1Lw3QOo2uF;TxbH*6gN`!V`!NqSc)X z18ZA6MIHRfOnQ_r72uGZ%oa0zAzd6sh*l>e@~1sf#Z}dKfkp1YxDp-C|3JUNZE^a4 z`OQ`QCU@om|1wEJnHvawWAA>G`vESs2U&n4Ma!9i7aZ+}JL#h3f!10zW98<8q>%S) zOI~!hlRQ)wq$HIaEfkZZP0&8A%4drOK2^%+(;#um5!3Mw6HeI^-si#a z@^~UbxFxAr_5C4G=U+Vk{t~ZL(xC+nPUR8&S_K*zk+tW_!~vlz3X62Sf-7((&2C=;6Oi6zjOt93)v3>bK1r3*+fs(|m{3>2?{5u&I^9suI)*3`J*s?|tQ lO^V6Dt-{B`%JM5!?@JCsjFcKmu`yA`X^`V7!2%&qq?N&d@P=jcv+Z|qGrvkdZ89RrAew;ZR_RAg;hSE zy`IfuIm;!&5Mq8>^~O@NsK*uAyu++9E#`W)H7@f>C{4H`5!UOVAUXpu7x^B(myb;e zlPP&rNy%g6LEU?c5auh)=R4!k1oLo(Y=1w&PPd2K7|%O|pre(L?H3v1p2x=9fo-`a zuYJP6KnXyx+cNuj^AB`7ppO9b=&d6`#&~GO!1S-$*hfHcZrM6Cv6EFm3KJ`3^E|ozA;~E$`Xg3V{d9 z&289&nz5E!Gw|179=DCn`HB{0 zz0}8g;O_=$wM9ii7sq*3(o-r(L$tKjq|Iu&G{rK{M(9eE`dzKm=kkM`0#Qj-6_r;~ zdNQR)T`jPoB`V0XytS@HDe9{4usmB`gitq%vIFJy86Y*q6m?3_ae5zF#gwW_@;=d1 z27Mocul;FpqM%7O74@Tg4v>z-EbS(7eii2aeS*fd7(lpUit_IzLiwX(7*4KTlk^y` z%}$Lf34ZVPptFM>MRSZEL*t_DV92i&^Cv&kFq*He5b~uJLN;i72>_eBrMDz?me=6y z6Vg2Gn4sayG~7?a=V&-W!<`6cV#W3ye|q_PX$XC5P=d!gO`P3;Tiqn%Q6+F{&rM`2Rk)NIcLw>3g*R=+!axRHe5BbKbhrSNk z((`sJKBs32<{c01rl;v^w2Pivs*~0ccwX$+;Kk03Vd-(;g0ICsz*wF5uZ;+!J5R(X zI}POQb~@pPPE2Dr;6DrhIjmy1PEKKVTVVm8y>G{B;~xmF8oYmZM`1Z=!0$QDhA*4T zp>XYoXHP%}16ooN;{se=xFUQKo9ct6Yq}uoN#K721to-^#{rS7!@=%xVEWy4;vLDe r@X=`i;eaF=H>Bd0W|BI3V!hDm5BSZs)s&_XzEHXAT(*6Hq=kQ3V28|<=)BY#AS zsv^XpC$}ZgM*B*mNt)Zaib|ut-l&U}N>$VlMQ8FOZ!`XGlsRuc}p|>W^zK*E9y*iWIrF;GV)RL`IqMV@n`J#C! zt>%o`EM1~}UNL5M&6H=d=rPV&X{iG`r8fLWktNBrs@Upz+0^X3iMOl*0U3&mG-55e#+Q1DY2o`#VLIC2z@3`1%VQVBY};5YHfacgz4 z>RfBAEmsoJSSuGbF&)XECf5WMkon_Ch(atM=^RP`DN3JU)V#UD+w!Y;n#5NlWCmTm$kAmi-1oNANp0m1KbZGZW?84Mr?27bbMcu8txuocMEe^+` z_&bPAkuG0`BsGhp>>;@XNtzVC2ua2$li_Wi3KO95$EO*2OV2W#d_@NM0*CyTdg1LT z3`;Q><1ikg_HVQ97HWX^3aqEqAjl|UaSkU#psxQ8bTkCYgg|UNasV?*au$4f@Rfq( zBniePJW*nh`S(O4PZQ<);hjhv#yj97hwupYr+?SKBVl)kR8v!IP2Mxade+uVMYo`f zmf;M%pU>G^$kN~N4cSY$al9Y)E2K$$zu*wz;}o@q|+o^^%LuTEnZ04aaM^;@G-#)fHzZMP)^(dR;%R OLz=&M0{b%i`0?LG-CZ*P literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-PSETQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-PSETQ.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1bfcada5bc2b7ec31fb89e2dd86f210d00fa4c6e GIT binary patch literal 2154 zcmb_d-*4M=5dYfgucb*yLg`8tbymv87UoJT9b3l(@?57&m)f1}%&UZ`Qpasf-6Z5k zVS-I#2qdIz&=n?sf$=v?JRpssS^^1p;03AU2_8Ybfp|dzq;Ti7W8FaTut?6`_wK%* z@7;ax?z=|1&x$!ttgKXR$EtCaW~16{aEp~1SFbc{ro}CSoO@YRRO$RlK|D43^x>d( zm&UAFg@#q+^rlrW7S0{w4o`4GwPriO96JWfr;d-0AAj=5XfPvaxenU@*mGp!_}H=0 zVEg(tCR!ncn8ZV}i;yS@5cg^;n${&v=QG)y#LL2rly=wLRv*N|=QT-nTd^^&QK|Bd zwQ4yS&Ptsygt%|F`Z9T0)U%50t}_>zko#6EoR#@m2u+xh2-~-Xg6NFf>OaaK=EwM1 zP0~-3>(}C!2w^`!Pd+K#nr3d6$*Z4Ev&LhI7}IUvS|TKVsW-utZf?lH|FU-KvivzA zYo#~jX_g5CcVoA)A9v%|M@Wbe&o&SEp=|*&@-|?v(`BYSCtz}(!fFB}#{gH|Uk^{EOVCqD+Y$rOlXxTA*+(?2A@@U4Q*;?t!JysV>7fTN$ z7;?X$AW!Bbl|PXMi9DsH**+R!d*SPb zuM4)t(xRY?CwW!U^C~oq=yzO?HmB**49nbap(|+`4Mb=t@DL3KqO?B{!_y~eI1s0i zz{Ajak+h_$ipnc_eKxPB0|Q_XN(=HF@5{9`Wde`jrn9hV5Scj|hTa~(x3?ou`?L!? zI))wkHemN;6m>?>ad{bb#>Bj;O7dM3gEFXl1#|;{=Rp)SsdG4uqFRSM^*%duCYRNG zsMCmiM#$wQ4b@Yyy9)*ix zjX&qI-_gWDt>RpzroGgsbOasP)JgYz~*t(Gev3>0Thr z4>X13dtb9ZnaRe3k!}_N3_@7)?OXaQWu02w^)GZ zq{!Lj&P#x@3;WQ_aMuIHOYQcbL-5!B5Jd;CG4bWu_If$+(`)|3B3=onKMlF9Jx*a| zp;$nm`-%YveWw^8@?AbALAU)0Xl2kfxtF zc(glYZ?oiQ3S)DHaoL$K%#M$}azO4LkhSTVi4rpX{U|_*out-zhgFO*Ml@(~cWV1U66zoxA1W zQ);(*ShWp@U0&X`$k2i6_@a1Yn6I4S{Wph2uB9c$YhPgOr3S{3lmyZ>V%n?BI5D}l zT>DxszLx7)TmR@9d!r=sZL1|I-@Zzg+e;X+NKxdR>sY@&jsnR+l!-PG2-!Mw2iEeP zx36oy!{%?X1^>`tHMbx8w5dkMv!HGra{GngsJVT%=>Ok9Vdr9f3oovGX_BFG;=Fl_ zu}blrIV?EBRj%&N$#iJ61{jNAf{DE1y^d-dzNxmMp8Tp$Y*!dVNTQ$T^hn7NQ{Y0fS3_v>LDm<@u@*YEUs&gKBQWP zleKU@b#K7y>`~h>Mg+gt!%4>>CWRm

f%VQB|3gUCd2${XW`Wu+}OopmxR4DZ z3;z>S*Co={h~|*^JBG&etYsPIw&ev*wqMZJwAD^svkkvCh>`hgM3Qh3iN6U7k6BW%GRXaD=p@qX6XvC6e|f3duU=}lLT64H=5c2TUD?Mdh6!EW(tQZZ0w}M7 zG6TvfQ2IbQ0Lng4T0wb?;O|hO-VKL!9QF(S32|z@mqi{w;9XW{Qe#sjehW_!`3gcr zK8HpkS6~N`H@Aaz`(SerCsWA}d)_BH>?37AbP!R2N@0I&kM8oK+0R}y`_T(y-}~ei zw37cd*hA!sFMSHlBz*!+MBejlmwa2rx4rG#-h!5SXq$wGU&Ms9+F&P5*mJOF6k5Ar z&*RYA4$TiilXt$~-11(hFgqtJ3z{OI9>Z_cxIA&j|GbcH!Rw;ye&8+%glpF=LvsxE zuIWl89mCR6HpIvcyL&R5b_~BW=im@l%tzfN35Pl0F4b`%)dYf`EV#f33CCOng5;K1 z7E!!ePU0n-@$TRZeWxHIaR|BP*3#JIsqrzY@Sc5PqPj1l0hC&-qJCp!IS0IK3H|7D z4WVaFT4Ba)!uQa3AbO)DAS6i;c|ew$%`6d6>M={5zXMxIx|VBVeiHgz{KqUj1j-h4 m=VqT2uWfXucI3DqF5tZ-=t2c_`-61{4)K3#+502w>wg1UnP4>l literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-CATCH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-CATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..586ddb44758eb0ca036e6caaa7794297f3f50add GIT binary patch literal 8052 zcmeGhYiyg<_1^FEBTv_Pl%{D(Kl%idFKt>vA3PS z=(=j%#$*O{0>>*%)v`GlEbMCQSrwJ)g ze(VQQKA(HfJ@=e*&pqedb8n6?<7S6jb0i0cV(~~yOOB+6M$+2OWJ()Oj-7=z=}5m87>Nw`hxRpVt!p*=P%0LO#+o(Iy>{I-*Q{IB z)>6@F_q&PPMdz$uw_?S**0n7a6Zd7gHOUwYvvCCFj9Hn=az`^(TfpfL=$$=or|z-$ zI&HZlxl9?XMGyL&zFekerIt<(>G8xw|rDok5Qy(Bt*wM)^TrmAf-j z-Q&^wU}^R)CsWGuT#!4@WvW-}tt)hgJ>ckO_hqez7&FgGFt*@ksm`;}lP*4%V8>3m zlue5pYq)6_V*{wDEAfa}-l^wa z)TtY%b?PVC9VJd}s4X~kb=(Y|7O$Q--b^j?#BnXU;p2J*op1mH66e*k4fTozTM%Ex z2)np4(?=L^2A2o9<8`G^IBm&r@+%Glf{2xjB z>`^m!+Ne2}D%lmYUf7iy#KN{9I4u)@q4TALMw1MUsFf)-xqCA6Z4R%eqX*Abz1!~T za65ha`X0b|y8Jf9D$12vaA?=lq3v)x?Vezt-s$!A`fY+M78v8}izhgqy-Ee*?4nAk zg2|QeRl`>fUzw;@OaP5QP-Bxvv+i>Sf<8FK9kL8C`M3B3&R&I2r3iR!!m8Gaa~83o zK7x)37iJG&_rIuuBk1!vJtf78;5ha+jMbkvo5SvRl3amxhUo+h8#=vSx2VGI<6<6y z+eHI{?})hwc8f*?y|4rIerKRl_iyQ4?{({i8V3iLfJU>X!DH!Tl5T#C(O+N$Rr`ROQiaam;9%ElD{n}`J0lGzbYyDlai9>i1H4iJV2DYi84u)T}0VJ zl#7V6o+zt`(kLm}IZ4TWD=FESq-2juO7@Vr;(%z_FXj%2#=T%ovx@G~=ks=Xpl3QK z=a|kw0d4Z2cS~n~UM#`E0UF#vJwJg?^4DvDO=V}V-4*mmcR~7vG_(LEYz%q>PDIX@ z%9&~bX+T#-T)8APenQ|~0&fv`9d^>(^#U}(MU>YQSc)W&rQ35{@I*zr` zSTi9nCtw9GhEBV06|rG*Wy-%q3(QddE?1_!Ay=lnE?1`fiN=0MV2r?%1b&+5wo-Ca zvc&C>SdQGjN!&(=TZ*{FXlxq+FM%!s*NcTXubH?sP;WMIsU$9Ck_(@ZWBfw`e}di&Bk+J&^bOIp zNi69WOIC|!o6s*8`Uc==`Y@MSla36hwQwjMj%rJ_bTpORqv_h7Xe2>MxYNgmwUD-R zBoR)>k_j!8+BGs5Nu+W9d%4Vl0M1`{z`ju18G@^RzZOf-Egf+OWPG2>jT(@=9e&hr z!wz68CD|j;R8-j<&E1XeLzlR!1G!Agy7f*t#GG{Vm(Ll}PI8@v1s?F{myA(h>dC6twntCYaMcBM z(#cy+^}0X);J600CtUCyzk;jxA#)|%YvKyjp&J@c^bVXk^{oxoW3Mr&Mrsrl7HNiD z9f}o+KZOmns^~EEh;fU6sOe{-lsYrihXDkuX4%ktPkS48w z&mq9Z_(qo3!TL7xXErKfWxPAu2up+a6)tX^S$PgmDO3P)EbC_XcwienP&fp-ecnwv zltMu#>?!BMDHS%pOiIec{6tCnUeS$;jAU6^TmcimVr4T+hA=8fR>f7&!RZm=DAROD zNxM~YH+(FeP^_U5EKLmm%w;xD8#w7`1dKL35|?jagBUxJ-J$r1eB;^?0n0@o$RgTE zVoxm5A4}}ghEmCJWO!H$CkG*{po#q75~~pWA~y)%eFw-@T$T&9r{!gP+OOmaNKl7PJnFovwM z_WZk6v~i2P#GX560_*)dm)aONb6- zOu*>~fN8*UIn*#_huiB9`kcrY<4^5cxk{alQ#^2iaeE!$%d|nlS}VdP&jNH=My)^;mo^&u^+>=zZ`d- zVx~3Wk}w%k)iH=QNMx8Wpt$~%m z0P0z30QEsg*HB1+!*GYF5*6TZqpAP`Ca{B)*{pIyJDkp2PkDmx0^-A9_X|oR zSV=w-LL2@dHuDh*09;vtlUp9uGbBv7?3WnLuvVnnglnZpEyqKejyiRz&>Ky3<@lViV+OSo{}j^Sx)lg^$?;T zF9_J?A4%E#?4_H#L>hmdB*+URoTVsDwvUjsfzp*;vZ+^0S}FfJ$&=U1btUa(B%7DY zzGN%6PLj?3P4eUw^$#WOQ&Kj&eR44D$z@iRoC&&2_dAmP`!L_<0}}3=2`x4_6pw{t zX)KU;C5FYScF5mwTf8o-G+@$ReIi~Rua7rX%9L#VocTEKxMG`HFH%;Ks-Tbt-+_bE z)IJtBP@!`140 zKCRJ0B)b~^gRh8@2mg@&0B2hx1Rs2wJLldx_ndoY1d(UDf%ML9x7Bufs52aNhXb_J z>7jmS*lRdwN8;#}ZgTp%LiE+#qe9ZUlxg&wt%0+R#L($)Z@s*W3J($K_F8QjEG^0F zgVN$+Y2kh@Stgb-Vf*i!VkuuJ5AiNCBL+8Z)D2rj-FT;(c;&X}ZaltAR9J zA#B;896zZ_gsoVb8kU~3nofjX!JG=4OU?S&bky3k1YJ{=e=CHk`BR~op9saJ&uNWv zZgOneV%-*6C?OxDG{QFV7`HTE8qO51%qR>%g%tUs$h_S`$d=?~D{KAA&1 zTk4^mNw{82(p>g-n_>kMR>)!POXU#Ci60C%xl`$(5Sn-9t)fx3gqSDE!fKLi~ zW_-@#YB6twwMemuFI>#G4~x0XlB6V`N-DUV%gc;otoXIO@nkIMjZTGv#Wn64XDU9Q zH%|qnSy-B9(#LpX`7QW%u9)vQBn`QxSa5DCI3dl3Ls6eM%B~l7Kg(Ftduhh@ogrMW zre2%oZl&3me?865_4l-M&4~6AHWt8)^3H1)8M8gx;^0!Z&Ra?$3v}OI4Ll#R+-7Vw z^`($yn&-^$^JdrF06u`1kueivrNzYlnrZ%7nZ}5Nc4``KwK7d>O1^79T*7vo+N0DS zE1?Atf}P2B{!&fPqL}Z!+$n40vUXI~j-`5fdT`{OYpI842>wt7p&7Bc3Dq#QqtuRV zjnIDYu^;0`Q?S4Qh%38my4anO5Cu_;BzO`cz4IiyQ+=URk304oa zz0~#r#BN#Zk+oh~>uZ3xack!wzFvW7L5Nm@Wuw+ktpgxhWz8mQc3E>YK-{>sV-TAb zD-d@hL?gj6Q){Bu0uYU|W|lRRtXUc$Zrs{2h|Q)7L@PpM1dFHEKy5QXWU|J~nnBi@ z8z64n`fw0mNZoX77KB$*)D!Kq2bAb`pj!lG5i@?Y0`U(m%I z7+e4+Suby}FoCJL_h>Zt4h`e}tc%BVrC;wIA;Eq|O7=s&_f56SuR1=hcDdEAFlUo_=v54&~*%2ydb~6Lrr#ioJGAa2rgJO8Yf7cGt#M;u#ZobQC zvvt&N$CKgE3~aYzes3;*@j_<)D&lP1O|Y4;ux#-LLXlY5huexVVX(lCDXo5u-L*I0 z7Y$&u02&5(_%~=QAiDMBaZ72+s#m$Sr6-`_fqS(dCc*!_FgbFVF}}CJ+Wi`zW(lYu zE6=L~4P%dREf^w#5VQgzuO}c)hSWBIZz-?=rKJo&$0NL1?kZ>I=~r_JAmuGyBtrr= zsHldTnh_dUGT`WjeP#8AW@e!*pODH1F{`eg0_(@>4@}O;`aIwy`=fRqe(~^j^}xpK zxZSV|4Zc&eQO0*w^A3yNa0q5rKOzjME{E#kVCvR$v(d0W7MvbN-v|}IU0mZ~y?x%W z&lB}Yb#W^&74?NZfe0`R!(h)p7K8epHcQj-|J$Z;Bh;g6FA4y%wbLJLg<*!bKcv%} zbf@yTef#skFu5L+EGduIuiO?rKuX z?rJJk+|^R=P%Y{w;8DI?b=5kg5gZbb>JDk5a~3+Jx&Haxs(Tw({8Ysi)e)rWC**(X zD0r88kle~}y_k>OC)Q#lEeAS@ww4&rCPfIORq^%0RS3B8hDePrWKhY445`gr=$iL5 z4)GT_&o;rb_83RuN%4X;pm-&p`4Y2Ngyr>0~T|O>5HPckj-2c%c%qGFZ`P*5`McGMb*f?xXXnXw`XgU)JAN< zY3P4oYoMIA`Zf%Y#G%>ywxVv7v(gp=_BzYKzI%N;_0$mtJJDRd=6bfCs9{T3Xk=@y zn2$X~wur0?N+xj$jUUmef;>wBIZ*|*rV2?AReXUP*=A!kQUwPI+DiLqQt?D!`u^ob zbpU>(OwWF#M@i_!43uDdKn5Lv3|dT)&?C2ZB-@hm@Q89x- z+$F`1h8Zs1QXC|ww#fEFm<{mxA47qw^uhSik}`o zsJJHB^%Vm9R>h3a4sR7C-IWyqv)zgvhL4wMVMoggJGS}4*qaRtW3LzU(q`Oclev{_ zdRe@@qU08rl%({O5{J+8B9g;?L&(``aScB}a2|CJiW9o<>S96{K6MX1@s$GWz<3TH zvf&>OC-fO!9RM9ipApJOk>Mi(R_$%N3rl#oHmaRXD!$|;#=(h2|NR}(e3#nqQG0{h z?<3Xh^94p<&+$9}-SUSDmq`gJdkaiR)h_||b1hK%X!2FsoQA*aVuFNl oL*KFQ>*6d4?&rFAQ5UeU!CoBfZ9My!D`%gP;cuZCZ{551Ut9QvmH+?% literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-MODIFY-MACRO.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-MODIFY-MACRO.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0e32d81c629a70f495a48e2e8056608f7619d077 GIT binary patch literal 4859 zcmd^DZ){sv6~Fg6ZvHxT94kq^bb0BYbanf(Wi)M9rqNgXId)>d8|;^EL5$$V&TQ($ z!A{1iiYf}ME5nQ>8PU6iNqiVWLPLZA+S;y(U?7ADAb}>tBqR_ZO+ui+2P8f~IprzaE~b)a5379-srqywn}e6*$ALV0;>eK` z@9Xbv2Ig3HEgYc;iynG^r6f{JIp)=e{)*Gzcd zTp0SC`34~inG5EiLc!F+O8cW7sESV=Ax&^jcHAejRQ88HQt_u&dVr$a{DCdxH%dSM zkKX;X;$2^F+HR9T-2yo1SgkP!W z^-3K)weUFMse#sS@dtD(5Z2;`H4=x`4T#>~kr+)_MogjGB`oIWjgCfM@4$9%_8ajy zi)(De8XmFyjs{R@^6TcPCin?IhrVy=zjb^xItbx4I5ZAo<39kFc7#|wrdvpAcxqrI z9yiRYp~NZfb;6$aW{?3rVaTI+BWx>wfo)f8RErwsfE5nim}5ABaQ}C_9hWyDSFH)d z3dsSaRmK?Z{TTMVVlOcoJH?_~Hm~sxl=&9lh0F8YgUe@mD=z1_7Z)8|s6!Vb2`j|g zkflkjy;2L4iazSY!-g4@BJ|Hfg#KQL&{u_F`fXvDzAOyWb7j3C8#xs<%6d~$FD3O( zODZa<1JcSqX~iq7kUxNxdN@54iC6q1zvR2YP4Xj%yagiHf-Eo+gXHT7B;2_w?2>N^ zyW}&%F1f&4pW@zua=3BGF!=Nk?>fXgy7{ht&~td8uug#lq+D=g>@cy+Q6QCn@@`yy zB}?*iu+x%$dOA6k(ry+|=I>`xm&d)0w~U&28u5$J|yuKjTAG>)MLVDB7&#+D<` zu)-{;p!_`Fw;T3qqK4%M3eNn-GHHkGf&XC)BCMddx8pE;5Z;-?M5#w_WslatD?KD# zShl~2K`)l>4a5!IGPGO9eKcYjaXp&gjVJ~K=7S^5GGt#rYnNOSNCf~62J|W3i_4I` zk&yYk=LAH--diqY9PN z;l^Z(-WF=%kE8zrwR61R#gEnkYNz41dItYdkaL8}5(*z|(5_zk-xyUc%uIx7K z#Gvd%Lv$kf0o-`0{5abA`rTH2m|2d19z%o0xx3D;cK?vUfLmxfJ}}FpWl5~W;`e}PPb;8 MT*8z*fBpKu0RE(4p#T5? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-SETF-METHOD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-SETF-METHOD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e39c283772f3934b8b2e19596d81cb93a8e92dcc GIT binary patch literal 1955 zcma)7-EZ4e6u;N$NBWhfQ|PMDbtYvX!W`DGtrR5cI5$li#}2l$tkMw55_ic+lPF2M z!9+Ff0bVSPZldx9DkL6|ctBzm5|nl818@8R`~f`kkUs#aoNLq4g-Iic@A9s;$+_6|=$D)?4-U7Qb3+@XgwKqhRu@pyzK(szyFeh*B!@)>OZK!cu6M z`IcGajdinG%zt>EpL&xQ>y2^+nE81SFD}f^F3ikD`s1Q5yWXCA=F-B2>4mwONdMu^ zHul#LLIrfdNFPFe>(BV>POdE;3{GLoudKfrhJpncC8N-9DIQWKX5;=KQOVcxNAjb0L_g&2t^6(Z=w zhzn_AB-9w%+3vrK5GEsjj>Yw;w4cIzRkZUs#pO-~M{v(|gqUFnp@XUy6#}s0!YHg< zVGLGJAqZ<%Vf>)H4_i;&?R^24_TKj$s6G(eTk<{C_bWnMrB78~io@V$>xW=&g1Kam z7okD$TrThj57AF2BEZH`1YYn1KNbLxqgY&JdpDX3REEJ;8E)^+=0;t_I*Hp#)gM_UU43XxA3&-8W`oJ^LVV&tkSM|5Qg8_W|;>i?!}B>%VuvQ5U%^%1oFB zp@-!w8ccix9F9m?O(V*QIiZ-@&VnuQZ@nc^C+=(M0GQFAVD>umCC8%F&s2ZV2}XW* z$!{)s;*#$HzJN0w`bs*g%EHlzu@m1wRAXQ~IX(ipk^zW`cALIRxF~w|S0v{%#w6w8%kcSGdF7{37>rg2N!eZ!gLHvdle7ar-id9|Mq2 z;DM1>k~o;a%Q&d|NK&%>%FFoaV6~aJJ>US*lgcKpD5_eihgPc8Ll2cIRq6q$Ql<3JQx9~;n}k4+z#ltr zKHki{ncth8CvE2xl`3v^wp_96)SYY2&NXStt<#1(SD&$I3FP#uq8sdkl&nl0cxR;3 z+@zVQ+l8iGq}H6>C>E~lrz0n*JXFWqx&^x)yq zk&y$PPwp%VF_#cBLmnaNAS6aY#J}yu5*9NpX(FvMNt3fI;m`YCJDf$zo6PXNoj_2Il48@lp$=&E_5?Ew-H`OWmCIX+P&aJYmXNh+sUzBFdH{G*Qdja>a4utUQ1d4w5JL^ZQc7!Qm|-$h{0dw8T0(O=JFctJI@nS9 zBj17KA&(>Rc`uUB_-jZ$;(ceqY1CjjRaV$hSnt>fkY!d%PfF}u4*J53{X9O%f z2D`Ra>5vlM+kE-JFUd=Lq?Ej+2~N!|}E`H$~L@-Iju!N~*pU*IZ?siXEWr%3+b z14w=kxZeWub0GX4>^JT*T74U+zvlER-__uQ7x>_5NGQy-v9>;#xucB4u6T$A_EQUQi&k(O)0{6pEbAv7cYLaRI}`3&Rz zkcl9-NLWiNfgqHWr-K6h4amgE%}egnn0WAC7D@M*JdSsHJVtzPXQfa*Uo2p_twWHI zPz%ZaLdf?7&G*7;+O&MH?ToDE88i#3I)t4ENP=(l|AX(v+)FiD+jLlzFE5hlm<*%h z6@rRuLB&l$g%AV_J&p5~|AoIGLJH7lt8TGex&p5?T6AlBo3v^-8gy=!LJ#eF1D)LD z``+_CkmmD-(60L_m&>t8xvCTWl-Hujfoj2o)%Z8#0RSQ5N0R*ri2VURRJE^+gahde?kM3NuX!2b1shJ`d^I#ZVE77HRd_dP?Iq=yrtmklg$*S*#;6}E9 a776YkR96^l`F#4xlm7tfVVHpS6-&hx&0&Uw%K z9M@3WbxGl+;zlX&+GW02t(2-2eyv#MH;dJB*5=oM=f9M6L;fluN{bU8O?H{DM6zW& zQ?YZrRkb&BnJ>oq$q#w4RL;8qrl(>0!OZ2$GgI$Rbj^vT(o*~1cdpD_oSK=Mp6EK= z-@|MXA(TaRI&>n$q7d?TJXWw|(;{<8MJAf4%7S0>y$+~_q)gfHy}nC)rC1`ay=A+! zoQ+L{5%RzHI_6TEWF>XY-^JTF>VN0;BsH=GrHS)0Vmh9wP<8BkBUi{JGA~=il&v|U z%2q<3C2C5sl1s4gvZ$nFw7=JR3n6@wZt$V=XaOG;@XYZ7lOEvuaN9aUG|+=k9Uwf< z(EXp$FK#XytGiFLY`uWTvvHt)O2^z>1HipB>prF6PC5=jioQw53ZcK!Y@z)R;JP1l zMG!jttVuQw*PDD}$2qvs3{qskYH(tJ5-kLi6Ai}390SPU)()Gj z!*Sg2cPZPX8{5v=-y_J5-)d*Eb9ABsZqydP)qX{&=G@j67z}m75`*bMT0Z@EAQXjD z$YdGIuL}Zk(v$|1)<2CZm6O~4e<_W^hqhhkhNEg8eke@ zAvW-`a!EAh)=EJ)gwc<1GVM3iWhH4+DRd8%hyUA#G;J?9R|etU=GAC9R+J1q=zS0L z`d<>{`5hPrexS*lE9zBUc@c=xO-5kVwr2fQ{2#bH5sg--(COa+PlrE)Av!#14Zpz~ zVbHrqx&0Qm8w`yHLu0V7LHqMkrjR4AZEqwPdLtMK!%O&W-+Oo6u8>W;vPL%Sic`#y zjjCJ8mt31{W!$PwD)wfDroQES=Pkhe$W3vCU(3LUD#zywt#1tFZjNz#XzOF~yG z;WAt887VIotWwcwLY0=<%;rI@{3>E+|-q zR1Oj}UyteR1xUZGvktc!J5iWpm3e&dWRa?I9E*I9b2A&C<}!3gXMF?9F-_n2yNvHe zM@LoKCPJ;_d;QO+vbLNwbWH{OgvY40#HA%!o8qNm{ZYDrV44)1a-_Qo1Dv=h5BC)6;(ejSS3~ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a69f35f19abc2561f66fb968030e727403af93d5 GIT binary patch literal 1496 zcmah}TTdHD6rNcdb2DZ!h_)M=Y!O7&ia{Y)N?*EJ25i_1*iiBKyVJ#V(8WXju z8lk9)RB5Z$prGAUNKyLO7s^ve2(Hvh$wMFd-apVst3ROh%sMxbhstZsH{Ut?&73*k zP93$~P*hQ=tgaPHPF1XI)Ydj?;&P=bu2(jyc}H9ZUi?ZiO!{?7R_4b)p6IgPh~%qI zuI3a(d&5~Tj+=Z!2m&dz~ zcXu#fK?vnhgAJVs@hF1)EsvLMYT0Batx}@P8kPLI?{z>eBx6z2_xjF@waOYPIk%h= zD`#~bVTAl2ypEZSuGncq_qXvTj{DzxJ!zdRKxy(UMO?=V6{e1Tum1`;PiCo2ENagX zjoK+=8tv|M-a!bTV>^26KAFP@Wju8_$7KhEKHRo~5DWAm)Bp(23-s_8^lPb*Pc%x; z^L(R>$MQ*_e$FOJg(iRpS-$j~fqU5`1R44^nKB;qTn9w;6<7g?`+#dzV;nogA))fTdkNb=b>E@<; z^7jO?lXu#A>>eEHfSdLC@ATggs=IgfISxaeu*6_?kd@E=9SFtY6pHzG>n>m95!dG5 z^M)kF(5KU^10*Hu(<(K|)if~rtR-<#XlJHs}l zpgYnI0es_?4Ojys9gJHHdLx|-dS}Ev; zF!~8jrv0XNT}@j|3OxYj-V?rK{7!JH3QE19`CFcp71IcMKLmmP*93X#^3%W%guJz= zT{YBKfjHY$43=pN3ufZ~!sijwSve}3{u797_$wGDEy=#oyZE@Sd&{!}u z3i}##zF5nZ3*@cs4F^N-1jA8y3BT`q11nCAtUI-3vg*{_N`cgz^%{%4=X+;tz~b<2 zd01S|!QE33i{;j}!MNL_!VbFi3HK<4!Q1d0q`Aj)9CKzG&oc`i&fye?T>;=z_sCsJ zG~6Y=q1N5a;!?63e5YtU;;(3A%424E`*n-!*twSV|nJ+@Z!j-Fr6A z)C7S?z9*D&tDhBeY)2=Z0n2frGyHAN_u?ZX8tV&T=73w|<&^5z)25+oV36o2GmpHm zK=o-MkU9e)7M#NU?08jbOK=$ek4$UJJFS>hwkbK`9yM)KQ&z2@o25Y?uVoCI24~Ry IiR0t{0A6dp0ssI2 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-PSETF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-PSETF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..659e61ddbf5cdd875be48c049bcaee154b637b75 GIT binary patch literal 23706 zcmd5^33yc1*`7OFX0pvpGTA4S$p%Or6a)m^m?RStNM_>9gn&yCkPyfqn`jlcT9;N4 zLqMI&qCQq_tF_wL#<~>T`qbT4?ayCre_MU5?cds>)cRYi{@-%Wy)&6yYDj#Zs)z5K z?|#dBzVn^so;$L`WLwhQ5olh&Zo``7s!f6QTh8CG<@`YJ`b~k&>$hxLxhl{L{J_@c zXe@kbTc~-_w3DXi#?zjx+_Y->`K!(iB(|*DeD3m#jtxwo8whRKv?d9aIdh;nd)~~M z^G=vGEw?ok?_g{HR_DZd$IqNMea^Jp&-dM|xYwIZrj@1xNSr2<+hj4N2DiDVCc^PV zu(iD-9E^lI!&6f`QrjHRmtc2197}EU%m|#nenT+1>Vj2C?9RH)CdFh*4Qz9?c1M~M z?a@eTr*egopSp2dL3gk&#p?3V(VWyFw~eduN)kz?ipM;aG+;k<=}z79evmL3?$8mcJ&PQ zAG)Fs|9y0|$y9V@PE6^0cz*=yhjuKwA@Y>Tw4?8u$U?JH0JR57du~QA@YG>4<(o_g z)~rlX|E1r5NxwN1oPnVr(ZQkmp27V+1IjWt0O%Q1$`3@M?sCL&P0s*|yf6X+2u9tE z;>M_(U|bt@e^DIft0WF*HV(pI1~ff`<_hoV816c9+tZ#m^=aIQ~_pY&mhM`fq{{mYay>9KB5-CAI2cX^lRu)EX)21q zan@tt4Dx?`fy-%;f%6yz&P;)$Y~#Sm$%%o};ECGA1uo}*B(kDxWH>$L{G^Pd8LCZD z$~c+ajAq?oDEN89L-Y7IG(49n5dL-5}w&$4LRzm>MWDUyxGWTT@wo% zWgG<#GLDxJ3>+^VlyP51;GDw}UP(4Q4xE_+M;XU~lPer$oEEr=UgHWDOJt=2*+Qa& zL-XYtCl@(h<#?IX*0~B==V&F_O$*(ZvCL6t`3*=Ex;r!o8e3jYwcveZR%tT%ZITN+r7lQ~xi=ZeI4e*UG6APb{ zAgi-MicAz6Ft3L^oz3Y%)Ipj>b>cG7wN~QuXXB$x)V5(>6L}-nc4Epz-r;yn{4%x_ zw@ZSo$p$H>Gw&%poyD#q_hZaNu?+)AS)I5by6>0x0@?U@I*TnCX9`Sb4x+XzQxJK# zOdTf)SNc9UC^DNPCcsH_m4r^)RZ&_=+9nWRX_drx%zq}n zCnUb90$&%=!J$^peLaA3bY%!-41F9!4&ojfV~nDG0;5>APNMvZK)G0;?9fq)ai+|J zxk11&5#b*(NBjaQL)|N&0@j=f#9FScX~znzX9=vaG^`p}J*rwH@WH7&qdhp( z+%vGhXE13WM%;tTdf_7wHu~`EOVa+(foNZ}7b%7nHgHg>2bbF#-CHTzIx$D$jf zed6m--xvKlW5{YW^1TnEQZ!*w9bIm6Xs{JW0Uu%)nQmzE`rI;RXx$` z(b- zYyH{l%uz$DJyk+G35-8s#wd9CrvgJ~WpUbw^DG4urzfYw6Xpo0(4%NC)a2-+1Vt4` zUu$HA6^x7{e``ON9XJ_%!AL_6uawonp~bvCW2D=8hsNs3VsXdBz^xM~umOjb6>v=f zOo9*B6tXH)cVd#a?ly`26m$f@^>-xPht>|`4#aCU)L}2_jjW|j$PEO;3?Dky4x{co zc!v|U>;R8z6ROv~{PF8<21wdd0GhU2u7w@N9qj{nk!bH&Kpu4l*Z)=q@iY;{W}<^b zb7?d0PYWW{DTw_XL?H0P4!FJOA6|RtX8484@F=$zsB!dLc!TyDJU<&9MGr7((d*~v z0WOH%7eaT`VQbXZ{g42*QG{(ZoD$4QE3D{{f|!8t`x|N^&H>!0l6c#cwC37r%Fxj< zorQ^6t7)Ot7jD&TQZqY6$8`d2d`qT4ljuuW^yMUg@%cOFIpEL<{ec}7aBzD7+XFO- z;Kw7tOwPv(8m!!&{W1YvAIAxKlD7VHY7PwjXW^TCj*MSR#(8*PXlq7$aA*x20q6(@ z3nH(k5Jp<0aQ{N)07f2}eYhh42M(BSZhTX4 z$~@V-a7J$ihAzx#4-TzLT37BKIvf7nJJbz5g#+{M{?}IShI!DlS6@c<0&nlKZ7>;n zb`LMx4y$ssF9Ivdc3Ang>F)+M?cKmOtX;Zb=06Hy5InzGL(~`%!4u)${Z*sLYWO^7L*xKrb9U%%5hMpK?y=R7RpzkOoeg`lqpaq zLzx7n5lRD;dMI^JYM}(6)Ijk=sfOZ%QU#?FN(Gd1C}mJep_D-JLMet)1jPfz4aEhe z5K1nTd?R_|kYH+-X*_B@)r8 zYM!MH9#~qVQSB#?_~S)OJ93*sG1X;Rs5&i+;FpetQ^T=XG!~3@C%U>5Q!O1Jl0P*R zSsEmMe5$HgI)SHzKq-QiCe@YNRy2G1$RAU-<(N#W6@Nkrzlk(`hChs)0}kx1(O73F zfz4T$si_}Ua4iLA6y1F`0vhg!$x#CMZo1z^-`BP8if28`5{6(!s@;0|#=hjQy z`Wd%|$yejuOfDyvjhB$i#&zVfaWXi`Z3%ZpfeO3d2ph#B~Zn1R0& zGw=>Ge*|a>J44N}XnKSL-&5-VRNz*a+Qs;b*|)7nOs-(&7AAez)di3= z;m$6UJzH%+auNfX!$6K9AT<{gv*to#*7Py+R4|Y)5@2ztqZLeu9{G^yk9y1jpejZ6bkEEYR(tkT;iGLT9Z$fXq)Z6Tw^IxG(1{eNIS#&d#er7IX zGLO38KaslNpF&-z{wElP7$n+4@is6}{hm4n$(tA&n7EStEA<#;zrs(SX7XcZewT>~ zDlVEzs1!_unmRBZ)mzDJ_1DO4^%{0tg>F0A4ui=iyY zb;Y7MOukn2SR?@^MMSFpOqx}HB+aT{lV;U=fMj1BZcapFpi$MX29cDpsFy`;BwBeh zO~J}*m@Ffa%CktMvXey$(OM+Y*4%>DDn3=GA^9nZRy;zY759>8#TpQGG{RT~K^~>f zQIA7X%EHAgY$f6H8;Dtc9Wl$d60_`OVwSx?%(9;{laZG(@-jwVx{4%ASCC|BoFq#g zCT7VnF-yL~%wlG`nW+%d%Tw9QQ`yT?x%gF*EdB*a7C%9f#dDcCo0*e|S#%dMi|!z1 z(N1PE&LYNH#5g@WNYb;NBt4gtr2Bnhy8lW{_nXY@U}ifr=MmHOePX)4M@-jlX67){ zO3cC!iCMUsn1$yuvzwT?PZBft05NkPU}haNYnbUKX8xtb%)gkJ`TfMq`z(M9iF(#I(ObO#6Qm)BY?oc@4Jn8f@n^*meg=+HNCB+W<-0EX*_!)A~L! zt!s#B?PX>UF)hy#)ADm-T7JUJ*~~nFnGM7=?<1ypH!;oEGtl#TW&_t8Hz9BQvpF}TtN^Tmy++sg+v;D4f0Nw z?`VNz7FcX}k^~zbW{G>4%mu-G7UXjQ%hs`M1q&4rsXqvzvW6oq*yZ|HFtYJPD3+k+ z)9NY6J)oY7WF1&75LTPo6J)c#hiukI*;q4?y4Q4|Qn2o)Bv|(&mbi<_Y!J*7CY#&v z;0ccE0xVk2GWkSmZ`QqQlC_tUWbFkkvYJTXeUS9B(ahrnSr5EHI)PVN_~%UU=vgFy z@IkN(cQw}VvqlMv+KJR0Ry}~V<`1eH$w6+t#I2{9JjTp>n539_ewHUXage8)uac*l z#q5HIz2+p=pU(OX+^S?!#!NR8J2CyAQp=C&Qj*apdAKEK{-?;9|50-0zn{rIHnD?E zT*a-6nOw-s4NT5u<`Qnr1ZTPIOq@d43CGS~%GNpOsz0Tqo$ zg_u_VTBVcBi%gzj<^d){YCDSD$ItF!d$;qmEnrIIDL~;lUCoiL?j{`7txN*wbRjz} zRTrT}2O0K##^eJgf1qc+2S8lRKQK&cK9z##8z6(euQR!T@c1?nI$u8p%Gb-bRuD+v znG`l(CyOj(ktTk28b6!EEgpB@u`JohlGSXil9^@9bg|of)^n1Ts&@dioMMaR5?A#y z!LH)$ui_M_`VNL;0rjh@pSoPthpcvHt-^X6*H@?!h*s4yWO0P6&Qec6)>1-NwV04q z#R*bX7eT7>fVdbLZMCiZCqb!vpF&sp7L%9Ae&vm{P*z^fWGSeNWsQ$-gr%~X4V=W9 z#}TP`2xP@rfh-AD+)jcOx3I)FnYeXKF?a_i$#TY2{sD=U|AEQ1ASoh=`w1H@-$+Kw z*RaglOqwWqWzXswk#?z3_8@7L-Akfnw=ua|jY9OwFhZh>;r0b>!b#~Tq*8jAWJ}*= z@{)?%O(~9nn0fK=VhvbnJL`m4covgtifhS(IA65*v}A8C}_M4~0%VzNm+9lVs} z>Kd)>twO{55ovh;Mxx%gnY>7e;9aMl35s6cAiTUmczJ{H21%s&MZLGJ(e9YATKo`M zE#?)e_}gT)csu1)@d-MPL|c1|SB&Cn*5DPo*hv~iA5sby-KINv;((JsG}^_xIeSwtZ6Pedb&xRHkzbr3QVd5@EkyoX3T@4HO)QNrg9 zqJA^)t9f{)*7UXE$n&wjmlYjE3O)r{rISDue1JweMFTCS84-~v*h)qUHnH|fCQE2) z7vP%r0;y06rE2o`3WtA&ihcmop&B58q@vDAUJ2UevlRYOp0kj zIvuDVf=fwQgB;(5hM3PdJ9%cSf3pvlJy`Y%0K3!3EIAsk0F`mwyVjb?Gkcj;|0vN zf)dQOMBM_4R!kQe)sXC?^<7f5a#XB*%CGZaN1tsSh`OdhQ>nH)o- zX|188usjWl;`{*P$iry)0qI#dD3;x%XStC^!*UIcrseo_J>kz%!Fq01P>7iSL4#p_ zk3ws{B~4Fu(EN4MGhf6C92qm8hs;YUKxRw2p75vqh4d6&0hQNCU3s1Yqg((A;)4?-S3i{pE3kgpk4SGPJHmK$C@6$gyO zk}t%jcJ*XW*1sp}o7Z#hyst?;U!AMOZu!ih1MSlSil!N~27#M>7{ z!Y#q3rHQZtLIt6gh23x`0N21*+yk)c{!cSOX78sze@K50UD1saZy7?V`-KLjZpD%8 zkf$?_Btf29j6KcJJ(;$L09Nfkw&S;y+9%=f>u3tb6EXN|i0wz94Uycofeo7_Kr|zQ%eYvT=n9p3~sYG@f>lnfE8v` zoS!JisxFcuE3eXW8TdYkQTt`IQGzK29X0(@vR{#$SM`Tb1)0DlQfBO`8#7c9xuI9> zp#XetioQD{fTd7{50hAJHV)c!GL7p*%|9WR<>G|x_pmJ%DQpjqXmh@PfRFARp}LQ( z9>zyk8v3r;p!xP2uM2*CUGRT9Gcfr5(|=0_uY`E3N8z2B!Sj+_lOZ<$@fx=3Zx~8d zZ`7scrFPnQF^8Dp(WQC@a(JoVLc5{wH@eIglJUK!%Rr<-%eUXqoA3LYx2nU2QdPg# zrD}|&ay6;SLF3i2^2(8`W94c?o0Z+V&H52G#gQUKGGO zGRpQ}{-7~}@_R=jD8I=NLHRc{1Z5u@+bo0Goq60SJ7{RL>}R^oQ;uMBR+dfU3@p<# zu=ILko2B0vX|r^lAHJl}I#>p7}v=J>iIMQax6NWZRc$vc$vSjWNY);RzS!Ha~ zsp0e<;cVi~I-7Wn&n8~|Y*PHOG0x)mN8&7g!w_fjvl`CgWk;~tlVvkxZ1XtHX3_J; zHjADbX|w1)Lz_i=bel)W&!VjSEHci|B0WDnaGWs8CC~jMae7okoSthnoSw4OE?a7s zHMPr<+Qs|(*VXgXuc>RWc`3Yex59O>x>-F}NL&uAg>c2LUZAcy-MeAOhVQP$M6UJzp zG_51CHAb{9L$rmTYG?~@$Z#L_}!u7^z&(_f9{xQSFc+lqlF2mH=(B?j8h&J~pI@-1j7vn-ZKf}}*(M~l+Tdtwa z|8|Cp@u1D$lVNIXX!EZ&M4P`^M+?jB1g*DupJbRC8``{g4AJJjs-eyMYKDvP#5Qkn zhN&^4oo|eGnufMue};?kpe-2AFf}%`1-BcbE!eK3t;ldOF0`HuQ)5Hx{KOEg^G_OD z=S3MV#)H*r0GrFHMbb-1IatV}WClOvq9FSY9#oV|iTnbC!6s z&@Txs3BeL(VUAc%HMVuEX3PAPW~&5W)j`qxsAlVQag%Sp%g~m2r*7*w%@!(>t;w1# zG>=~e%pOBq%IBIb<&HF4j7!;_W{bZtC|4QV+N9fR!gnu-40u;+u+G1QRN!3@`S@ck qMKQEw`kQ9S^ayLChUpgFk_j@5EL}9ZmDOy)z=vr!hUM_*pZ`Azd0H~`(UQ<_DjB+L%jR8M&MO_*y=CWlo3CmpZCPCEx#Y5K!;o0C z2(o7^X>VWBwxBVg%hTV>t%a}rZ&1M_2oj?+Av!&S_w(*-s z)9MDi{R8f5TEW)ssfEy-p( zv2Ex!@|R|%vQtlRE{4bjgw7m04xSyNN8z(`{OlY+djumGT_8}VhKEv-Q7R^skj5^m42~*B)VF2|86cUs6Ba}Q=Hpfoyp zc#82U252NlXxy^`Z)Ui7l>oeuH}GPHLJN2yjjM^G;RQ-7iV{h@@sA3;&T#SC112TN z8+b88@r8K_(umit%}hWEuRW4;Q}R6mZ&tW?l>oeuH}GPH;*0aJHW7=NSWLx{#G9z^ z+OosNYq!f2732-Pm@&pLPsw6V7L#%$XXT`QBEC7{;#C6hLf*iO8DsqN!!N-11_Z=}@0iEC*6wJgA<84Ffmu>|uPtS!R&Dy%QV zkzAM31_kbdaB;)(D&t0mDbfNruxTyU7Gr%i)|cZ*;!fA^@e0Gm4a=;I8yN;}%JGtn z@rE*9ltsM7HUvr{c+Zg0E#h4iE^b(EW!%Uxa8r(#W{kIn8>n`lBya;Kg19qR2;9Zt z;)W$y#*GXEH|2PV#yuF6QM~nCn7$2*=swK3P~a{J7dI@$GHzrTxGBd=HO}Q4ZlGGc z1#aL(Fy2{B0(WV+xM4|_aU;XPO*tOl7;h-!@vY$ohS+vT5_h&s;4TXnH>}e#Ze$p^ zDaYfR*KVHA0WO`^L9upwr9={UPKm%>9xiTJrvf%;z%X!Qv9<;0^;_G7!@P!P22iYR z)9jJlm*(aO+!f*ChUm(;kzwGb9LJmIb8WMx;f7*uI}Y=C~Im2o4(z)d-dH{!+|bZ$0(fG!Bjc>yuiM!x4f!h@>Za^vHMuvf#ay-6y zKG(*#h_}EEauFQgh0hAyHH=$(sx+!SRT`T(pZEtS{$g;%`~c=4BGn%#W#D3!;ddf& z`rs3vl11W~Qqi3PPpuwDe%dmsJ#87AxL8AUUNA&7HgU(HzKtGTa()!Up{r{;)5@pVq690XNzS9G^T(l1qy3cs}IetAy!%M-d^cnqOm?w-moCdbI0 zF}X(ejmbH(cMSJL(m&PvgnwGuKhxd6(XJFGPTY&bbP2@igU?8f1J@yer%jLdLwdaL z(c^uTQW)<8@XiR&^5*U7n8uU$<1ppHQNwTyZd^5iM0n?FI0oN|(o*p5ke15!VIoqV zsL^MHcHI*X=$^Ps_rww16E`6+c&p6h2jGkWM|c6U2Qdpih$c~Bi~=JM^8PeP;5`{6 zGcXBvWsuB6yK8@#SGldjNzMdW0-;4wu767;R7=l>(}G zB);S~QAG_>GMAdeq)KgJYVO~ot9w)UXpw~We|%)T?b+ZGK3WVx;Qyf?L4SBZApcrG z{@H;1!;pVUc@EofJ!wiqcQWTPq?{9T@V`F|rxY!nVM^2N!+d?#>4Ch^1j$nq3j-OI z0gPh-`MK|F?jhmFB{c6~ANviZaQwYSDI9k%QVPf0Q-dR5l}nqHMlnqeG{x6K*3+s)0(!cF%I z=Pd9;}!kpD_~}L@&`oNC{j9G2ugsvpmin zPzklaFi~&L6q+(eO=;N`bMe-6v)+p^INR9^#~?YZaQYCY9h}~a=_p7~Tn?#O<8S6h z;7#`loO+-=dJSGnMx7ex)b@E;>5aoiJUtJ@n`~nO7W+GPLlIy=qaa2`5=Ma1OtP$xS!ytF>=M`9F7{jXzsg8TfXqw z3N!`6MU&3&L>V7zPG;@v-QEYfZ9S6UYMw%3Y^X#9D~Y~zMWd6r0hMB zn~MS0o-MriHPl2d??Kb^ktnPjQjs0 z-q^&|L=R5vq?m6v#T?Rl%ptAE9MTl??HqF?5OX9Db08S=%E6KCk6d_aq5!^O^vL#8 z#|FnRd)wea%*}n6&-kr?+WG%G)P=hR)Kv)eNgqu2KA7lz7sB)d0Ym0DVCUq|xDbK@ zJlqsPiq8l9^bL>~4#D@lLJu#9V^)x_cOBZAwk^%3tQx;{w6Lzz?_1S_-)VEN_V`xy zdi&ffdw}EX?ypli)p%tkTpqZ-2Gmcz9SuBC8wz_kRf#c(ZxYXMyCaJ9kJ3ReqU z&2Tlr)d-gxt_Ha3;i`kH7Oon&TyRyxRRvciTorJY!&L@XDO@FR6~k2oS0P*laOK05 z2Ujj!IdEmel?9g*u1vTx;7W%p4X#wUQs7E}D;BP3xT4^Tfa!Ieo`KHQ?mq9phCcWr zUnhMNFs6TF|A2R$Vz){R`0La}hZhPQU4Fm*wL$#CpQ8)8D?NQ`s-v5eXG3x|Bx6?g zdO;23denHw8u;2^N}ac_&)?_vZx~p=VW7^j7NnBuJid)?;`i67@cqGz1!n|)578TI zv#C+|?L+u7p*>g+-y>mlfpVw#lhNEi7vh7gjG~(Uq>G!fe zH4%%KL4Sy?>h}(Kd#R~*wE)>IpunNAiqt}2EjXp-BKbhgL-POBd?eA#REXLB2{GIA ziP@gR%s67U6%(_qfS7Gb#B41mW@`yCThoZy@(TKDou{+U?-pOZ1XV5nsum&nA(IE0 z+zsYug7sZ)YlZKq#aQ7sCSy!);(FIJ*~R2MCg-q-kBNs#JCiCfDz+Q^>s_}VTg_EV zkR%dm{xg$b5}fAO2u}0A5uB#KC1%sz#B92andd=sN&Oqwt@QW0&+_zc@IqrvXRD=1 z{7hCcS%i@Qgjmw7mLYL5DP~f@a;Z#Wh%}yN@)?OVzR%=MCa*9#PIfhZpX_QpMs_t` z2-;FLyG+h+{DxW%nj6n#vWm$faK4kAAEZXJT7flOOp2KlaK%(6F+|*_nS4ef?vqSj zXYwKw_Mw}7=w=_f{}Q`yw|8K*r++o5a`&s1NW4rIGO5M5!Eh5oC2AE4Ihn*Wi6PmB z|77wGlUJBLOCk;b$mCuow==mBy|vD>)(g{U|7!Pu2gW?K-mslq+pv{f+pv*bTmMHi zx3{Ms2R{ha|4MZs`Bx_2XVOG9>l>(MeG%2H`ySSWTI>7#*!Sv=sx?RsFxkswIg>^v z#Y|F&)V@ot*8ZAWt^FCbT3ZUnCzJ7>zCO=JXt6d$tp!r^C6o7$_0_yUqF+E2`)5n>kYA!gyd#4P+CF$<3nv*0CS7Q8^rf+vWXf0~&2UlKF_17^lD zGm4mbpAs`Km6&-+#LWE@F>`Z>nd@X`G%<5Zh?!GJ%$x*bX1j=)T}jOBEMjIg5i_fS zm{~={bS@;Ovz?gEDq?1?AZF%LVrIIDnbA$mj8(+USU}8lKQYsLiJ88Pm}!H=OdB9( znwOZVn~0hE7sO0mN6eH9h?#O8F;g}WGhqiY6NZVIa4s>Et|eyDUlB9uB4Q>UAZFqy zF%z#QX7Vv&CV!il$@_^J{{S)L|DKrfcMvn~1To`&NX)qVi5dG6F=JmKX6zHhjCqro zF~1~c%!|Z~{)m{-zawV!8_bMnW(+Z-J|kvS1u>&anVC*Z$1-9%mJriXPfUefr?Bf3 zcAb3>N!qU@N&7aEv@uK@!?ZC>`!*O_XIu%}iA3%94cxFnP*ah+83tlB?P4&u5q>ox z#)rF;Ud*mj8-Xl%54Ss_X8+0_uDal-svApRV4)uoX+Le&B1GFyl4$!|Eb}uaP7qDd zo9$eUdogIR?aw6K_Marx_8ya5vkiubIO|iL<{wd==6_`2zh`nt%>;{^zolj%xm?99Uh`Hp4awPDww}wn zxNIqxwQ^YvmlbnaHkT<>*7PBjHT{Chn*N2#n!X#vM%sjsjZLFuW7D_DxTY(aZ07a` zxxHR)&%^Dtb6Gu?m2+7xlPnfVVi5<4G=53U#@`dO@f~Kejg2pH*?nMRPJkc9hJ?&) zyp_ys+)ws3UeDwLZt@&%(nmHlvYCx+W+R)~$YwUOnT>2_Bb(XCX1du-_bF=A{VQtI z{Znew&8~E#D^rD;+FpdrbF&xS>_s_LVGf4yL;~eHNzSUI8NR_F>w~X}poJ zcX9e_nC|5C5=^h+bStJkoUTw8V-vY*2a*JJ84^2@hA-6>kZbsuL>k^Ak%k{L^Pklv zSayQT9#)rP?m-s$p1K@!cXBI7)J2%Pnd@x<-TIgY_-tx}pF-2nO)+WcAX5J>+UX}d z>)%lEhf(TZMAjN+J*}=p)QdW1G$?wS8 zy5AD6y0<8hb-yIAb^lKA>RzU>);&*{>z*Z)bw8pY*ZqJL);&UC>mHz=-w8 z8@Fs;?luGh=;yj-t?&0WOR7jX4@Hn)ab zsp3`&*xX!hEQ=dUWEaG7o6*!}?OWhNW70gU&&z?UeV&|H`!sp4_E9GPhcwsT4t1is z;g9@XdjPTyJ@+lhDWWJ3=Kr)F9~>}vdfjmAIRLj!{Se&RSQU3^HJ>tho5>SURqsO{ zVM@(CWJ=93vZ3ZMlk3Qon#)z(X4h<2yO8{)+6~0Tt-82X*UQwn>jV=Obfk!3%DYfP z;o3`DTzjZ_*A61phe2BJU?5GR)mM{f^=_8gMx^RSv+;d!B0#cLJ4v=`I}2?hQu!Fj z>P|tnTUK`LF0w5-#F^6rD@Lg?E{o z?)T#P2SuiEKS>wfz+zVsDR|D@bXQNG7RG{yNVwoWmg26M|3`DvovYxFcO3a|lXU*; zB%S{f6Fg7SLxa-V{v_{xlFoaZ#PVKc5+5M#(b~@agrsxdC$Zc&nWP6wYi;LzLDD&& zkXX*UO!8!DkFYz(LDJb@kXZIdOv(bJJzCq@i7f3Pv8>OS)JoFOv}Si!CP`-{l9=-} zla@eft!-xkNjo!HES5;-;s9yklgtW|&MaWDR3aIkKxwV*jCzvJs9>=iBI!M{wCkaSubi@AuTZVZqXcBgidbZQ5SH4#bK94M`|owAmsQ#x5} zA(4b_Ag#|1*sHh;CiIhV!djMEK_uy_0Aa1=q#+VcI)|nFL=tb5g@w_HJ4rZkJ4w78NI32&OC2B*`s`1gk$exsbfT9UJDS`T8?>|gkv6OsRxKep9EojZ2~{Do1spAS*=}18O!FeYyuGld#Jv0!BGp%d2nKn zw^(pMkN074?vBL1TN2e;wQnL(`yk7#C1S%cXNuL+-{tnW`NoD?w?VKW&>UpN0ZpH= zYkah1V9U;3rRCRn%1h7R3_l2XUg@@r`M3O#cMYDwozXdd*b&V&Dj*pZ9fRByNZN_J z;1A zem&$nP5Ca!uQcVCLLT~wE?;fY+U6v!t-m0xt^b#_wmw5zTYo@WTfZS|Z5@!cwyu%2 zwth|4+FEDP+L}vRTYe7R438vxJ?mDk^1#Ctbp`jen3dd%QduAh`dmMk*c;STlA=Cv zoHo=g&x07{@5eTlV_3mGwg&|JLBTn06habYT22TVs=7=F2CJ$U9;dy1%R^GtMN?JP z3y;%{K+B+1by^0mk*ex8g<~)Xo7|+^6s)RVs2SWWRmCVx>S4W53r^X%cnpXBc8=qt zy0bAEOG!M5ZvGsS@K_I%zqa(2=ATe+XOL|vgSQkPNans34h1@2wfsi{bO&@pi1 zVP8*EV)NBnaS!lUB7ZH*^>XnJY^_6GsxGEmyJnd3q6pJT`g~9I5PctQilyZ5A=&h~ z5c@z~N!$3Og73aAt@26_bG>= zYDmCR>Pf`=knZH`w`=X%GmvY~yq-uleL8_t4~`8`Ox3Ajdk#v#$PQF%^pN^>hFa)) zD8JC+g!(FSLhVPElG-=8q;ULjG60V9z#n0bS_yxg>V!W|!G;uWw@}Utf1K)qKNt@9 z7(Hq={4uu&{y4P;{>Xi`$*jX6R5*kNhfv@U?K?#C4sN}R{8dk%4fKgSpPD~#i;8Bm zqFJnH_9~jSie{@qmg4h#MYB`UtW-1`YhaKii;*OTGQ|S|jvAl0c(CR%@}LWCA5&PAFL-3D^vHzj%E2RBMUlb59|~Xa$X4ASh)<4e)e%c%t8SpkR;?ADto zD`B6*zMENOE8k%3ysxmvrt(=!WGf%0$X4zVnx}^xm$}NFqVDujEXlrXk*38qW<(TqKy^Liu%*XNcKN5IYx{@g>}KL;03oL z>;=~}Tfw5MBM*DwHP2SO?IPr1FTCd2iq|nhZdq@&=-QXjCae5u;n|r*w)`4V%YaGTnJk-2K8@r40*6E?m(?3k!OvoTwCs}-YpOIvoWC9-7~ zQDn>7gyvAlgYTfq>P7uf$h|bqEy&A7{ZPn*@1V-^0+Gu*sM7mH`=Ri$eSwiJy;IZ= zh0i=E8IdhLBI<|2XP%Rc-dnmq5TCK);A~uag(b43TPU)ndSoU?zI2kCzEU_J=b2_| z)OFfTUtm;A^F{rsQMXTW(^r}h{%>$BU{3e zEtxX19W>4+yPYoy8CgCK5V!Mzku3=sSw0S!>~_9HiY&%;37<=vB3t~h=slD7T&y`6 z#$vr^Ox=4Y!&t2MjH!F?WEhL7XK2TsK@Mw*ueXfZ;vF<*ix&h(zMNt@^+8RsThz6p z=DQ*Jpe8V~#g(GI6*V99@X9_Z>H@6Ks4+T=gCH-`_og$8Y|#l}qZMPY!>B-vMS9P& zVhrans)%~l6#wGipA< z3k!9Vh%DN$NL?NzvW0I89ReT9hJPSS1pk(c!nZdaFgL3j!gKGE!ZopX0J{6Y^mUzqCR_V zy5~y;mx}slOnQD+Fv)6zBR8CRsbGo~C!Beypvtfjbxs>&5!Rm~vay!P=6_0&&3}CS zmgwYlyS_gl`^}!!M zck;s@JeLB%Hhkck|B%I$Amc=s60n4uOwn#RK&eBs#9=bTq1oXOW;nwXL$rGre3-=^Q4D`5>{gLM<`luXbfiz>APMnetW1dtCu zq|c8uyKE;Z3s1B`y#UrJwTeA$Ho-;(_FtI;O`Kl?hl5PncO=&?wpcKm7?Xkzz;7bJ z#P|pp6kW=FY<6ptMg43dOYQ#w{Hw*4@}ENWhign&vso}6Aih^dJ&LXNFiv?jv)$G=pMs=Y@eb`Yoc^uBL z(ItE*8Fp0Nl5R^>O~Ymy5zVoV-e?-Vxz9`L<|fwElf?R9pK6-UwN4&$5olvaKoOXH zp3eP&1^!$_T3#k5o2YY-OUlCwwY&%zi?2RY!^u-4w(1(NRYLMjcHU=b~`jNaS?8ofEMNb0PyUM@C|Ave@CP^P!`=2+(rYn*F@ z1tIs*WWhAn-kg83fValERj3cSdnWba&eA!LNxC`C=ziFC&SdLMT>$S*a?X(&wnh{= zx=-gNs%Kg(utrsP>)c1R+oIkYRq`@=VveJ_Owv6!qc_K88NE4KG9eQ&l`(mkV)YGcI|(I(62%`T$RoAtJ&j$)gR{md>+<1#>=2XZ^$ip5rVXhYR&{J4-+9uk(FL-TcQIPDhP{U#E5MnD02l(yt%- zI)7mSKfiH?B|;nxJ71P`&nC_ov@i9Yvva4^@cc&sE+Tq? zMSU0%?WPVj>xiB!=?;h}yaQ-Bcp4Gywv67)1vGjyzL3<-MXYTfPV0m+!#aP=I@WM@ z7VZgU#(NeA%sSR^a2D1HWyV{Q?r>sl{{t4vYF(M>O2C$c!zL?r?+WU3lwr@V}d(*9R zhdIvtw$S{YPNx6f0^S^F?FB#KfVsWzO+P8=#yF$%;pM&mf{fc2jAaETcDV9gW_!OiA4ou@3l3 zim`#8#T`OPD5DWW>JYj5h+l5SH}r~mS+zH?5! zz%qJMH_+%!Es)gBG}h3$uH$e6Ug-5t4p;@ zx~GaYe)pWh8S*YE@;Fo9NTS!WDOf3C0V*-q8^S6?6XjRLg&rCR%;O{DBQy%{z68PcV)HoOb3HegJ zkW&oQ{5pN>Cn4RaXn_q4(>wS{kLyB)y{IyUFoM9ePy<6Rrc|y{rmspWtgovv-J`hQrRM$Wv0v6=9Dyht< z!yphIooZ{72;>u=*M(%iCqAVYSgjRW?ZK^0d{nAySc@&O1(-NVS@XSp;{8U&pngw0 zV)1+84dnO4wR%+nL|saLPwdo7ra}^fg{IDv2v31b<77$@cBkq0O%q#;iV_IK{GRp$ zsmZVFLc(0`CCM-A1yfl|WzGPTlb@C9PH8e&Vmx_He!{3InJj+KHTfQk-;-}8zbBug zSGB8)#7u+zJ-J^mVI=@9p%#9*bn4L=|Eg3se80!PXjBa9_xMLGeviMK{2squuc`x47o*?fhxC%r zNMiNLGX89-S||{pDEbJtPZMVRnMUORARbzE;=a%YbaQER#(k_8gtitXOhYv8U8!y; zla2l!_l8k1z+8Cx3rgaiwfH^mVe)(29=)nvQI}~eEBZZdr(R-4;t0`s;x3e`2@v*7 za_$rlA>%e16%ho+;={oH9+#*K1^C^r7nrT3bg2Fw`ha|#(rQ_4C?pTS1o>z zeTMuVdy`&O1EO~Dj2XLEFA0t$n%IGpW$ZVlYLkHA6;7HgV=px-nn0lYPwGE_9b2Fa z$$pPb*9(GMOWfe=YHX}jcM_9>tgA79GAf!(HnssV?^^sG^E2{$%u!QSeJ6?iJ?5}p zVke^~*+XKPY0$=u=+!g_gn9T70|QB3km;8p<@r6PUKf)69#f_lXllVM{gmTN%Kkhgb~y$zcm$qpwF9%a9IZ+RGvkmSF fPzE*IU|(}Bs1}=Y`t*MRVAZ!4 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SETF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SETF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..298e4fe2a5360c1a7fb919083f8f626ffa9ffaa2 GIT binary patch literal 302 zcmbQpz#8G~qu`vMTacNPTBML)T2fG2qL7wfq)?n+T9llskOmZ2sCM=ba;^1nboSP> zHslIMl1VN~O)N=GQ3xqbElx?S)KM_BRB$XP%FF>WEG&RrGbT&&_JB?8wpMilPnPESO;$&bDU|?pLF{wvDE5tQ8MAyyJ$5q$Q(brXL z#>5#t96-P5h6cL^&FB#{QYgtU(9KCLOU(g!C%2e^k%3{xgdPsJP(SAoPk+A|lNlQr qd1mzY@Ot{`1^~V0={`w1UkgQAFx|`b8es$gI!od2bwHItycfp3Hm21~Goxk>i_5A})D*y_3T$9DR70oTVD0_ z-V|IPxMA^isTU;ahEuzt?Rg;^)MaIwKh(F?l6_UkhICmIPunWaTSrpJhE>@KG;ew0R&feB_6p&ME(|l5 zR%E$~!p`G`a8wtDxl1*!=Az+zR0zj(VVJ#C<7x_frwZXZU07C^t7@)S-tP$EdR-W1 zF!ym4S1fmf5TBv~?Kvof$LYdQVXko%mrU2!g>aKD3>BstSMw3!`a}pHr3-^D)tE+g zmHN15jSwEM3xh8AaTS}o<{cqCK^1O*cQ5feBo7{_^xKdxEd-BN1;>)0I&)1jyzEt6 z^F^UKQPpf>O(6=Z=8CKOPZX+?RMqjSswNA%mdfisDRd{RxF;aZggP(NgM$gQ!#$27TyWp?$2XJp~ovBy4ZNN>;6URcanSMySsycwxtfB2ZJ< z3r?nHFW7dUy?h_sfT};aFTETZK!L+N+irj=cAyu2MkFz7&0xV)Fc&NZYr$5q7aRqr z3tHmun@*%lq|*YmTw~1R|sZlC( z3LO1Fq9^_xMYZG3lT^`J_-(0RfhABKV=%}I zxKk-uTsEA5=vVO_L!&nJ7pi$oInM#hA&mIFg^hGck5Sk%+;yM`DIWYyVPnObzVYXx z=}-O#sE=7E)Dt8240B<&LCeF$=IIViz`F-Rs3-7y9&97%1#xh9-%!QcWUNhO)jBe( zf~9}!t{J!zY#n^7e=DTaH9Gl3rEp_o)iySxS&_D_dNh2PkCiv9 z@~`$wrq<$(!;Q^t=~R0ceq)VyCQ|L)$xOVp3y{>JY_ln$I87%*SqSAMC?`TW0m=d> z^P$XxG8fA6P>zE#2g+`<&wEbyVawz(~lYwL_>lDT{aJ~X${mug#fSvHsKG0BH|*J`CPMk5qNu=6RBl!!n4haZ0-b1PAITO~=c;3shSq%Hj%ziay-uB{`T=}F}9rw21@%V#plRLN&{MTUEg{|om*dMCFf zvPl+J+<5y={HWfOSe%R}GMU6Ogubps&|IKI(X3QrXl8+*HPPGKO)gX5moK}lr#0Oj z7vJd7Yn)P#CZaT;aVm9S8h%aj8h%Of8h%Xi8g79IuJ&YaI@^UQC%fCx^?J@GyI6-- zF#B9)XPDgxe&+VxR^-&;b$2^n*MCUP^&gOP{afT*k5#m1lD*xDwj?@T1HWzAd}}s& zD*il+Ij1wHn>cm9C$R2A0_%Rl;06Z2#^7=SW1kZk`xAk&4;j3a!HXGO!{CXaTho(h z%cM)&EH(qCVKAG_b;J+7H%S=}DaOVr6VL>(B8#AplRdrgJ9>arqW?uI(O-~Cl-n!H z?G@$ricSTlNA0gAiS9hMLv$>FW)Q~furd*iOPK^FvY!G+en){LKcm2rhpAH|cR{)# zO83zIkKD*U*C~@R%qk8uz+skfm}cNZC32mKY$rN3V5MMUh~GYC3c^-pDwyzRaMwq} z6Ys}!iPmn+J^WJ&9e$fahhL)5;csK;?yfA(GjuwYol@+yke$rv1P;BKG&W-B_sTRh z-zVSDKJpDcO1_~Lpl(}|Y|EuH=+nYJGuY=S@(I38gFN^!-3vZQ_ky?az2(SHpBG`z(RAPZ3yq zKZElaJdVN11p1#Q(7&5N|9uQDU~n#jQwj9#Bha^pK;J(zm}Ib(!4?8*UL&yP6#{FX zWw4LI9D_*$T^|tWdY?eo8w{>za4m!95a{_cfu7F@^!%2=jSPO1!SfijGiV{u{U-w5 zTL^St%iyI9h8YYnXeQ8m8-ZShK<_mSPGGQ!!CC^H4-n|Qk3eUU!I=zBXK);Wj;9E8 zJVBu2UIw}29NcjZ?l}8P4Qy5%8pzSRJZEp~0`#ytbGI$z;iwU&y z3TWjO(8?>IbuD>X3*>1%lRPcFa9Mcavhc!Xxtu&LmyxGsEqi(yv=eCloIvw-0?k_) zyqv*C2J0B~5@@=QK+`=0nr>up7K6t!*hHZGF9gcZ5GX&$U?+n~29G09dYeG$O#-DC zl-P15a<&rfWy%VeKx3Tn;Pds;N|l5)FP=`dB^4jsY5XJ1H7h-Q@z+Q27tL%be3o|O z&tE9B(EJ-dkyZcaloo`F;OOs4!Db1f!4owHD{&TYtj9+z|HZR7JtE`j4tSgA0}lsn1*+O=I2WF zB*bHqWEx%~nTEX-zhM`fv%uf0rUuVQ_UvTOli6i9nfmv^)1`Xy!;zfpUm@rE@3Yr# zHVQO_C7Ei+iq-GH2F&IXnH>FG3W3}rP-|C?!?bdk`OKeArtX81?1X3CYvft?BD*}z z<~;E9h@fqqi3~-pTgtw@?9@&s_Q#S0G}qX>1KnjXncn{QzPaUE}-y%x%RrY<3%_E8*S}J-Qn;mSfV1r#WA{;%UIUM&@l=~{m zeHER=%sMs!Hcm2;-$1xXd3IulMiC=Fq68x^Q)ZE8**wT(h0QiLo7gOeh&5_N^})@N zx;YXzdt@$0ii5Y@#tsveAXGcjgb6eUdRSp zQM7@!l7ym6^fALsCioX(1b@rsby_Ea-vhpw&Ab7jst31Ggy1zyy^KwBNh5(XdxqH4 z!!8n;!0$*T@Nh|X8F<$rMxaQHz*cs>ip@N56-|H(CPxoUVBZFI;tJLN0et0CC|Kj+0`j_;*8oT>ovL8%7$%09;UweVk3`PM{}^10QJzgM z(Ngu_PE7xeOxetaBo~pSe-1E36|-GSRYm_e=0%y{CgY&SwN?Dsy-!`?!)d|3g!t=H(KZTxVB?=Sj^@qSV|^@oR2p za}^Erno~<;vPpb-q?*<&U``7=PiEtzk?(r1M5d!FqYet!%S3VQBVX5JY;LDvCnCmBpA4S&D2C^4B71(w<|(BQ z)&|cmr60{D9_fOcoM4jP& zj;QXTGHOE9+`XQuYnXEun;w)-k+gde^L^!fA?^J$@x7lA(fb=VZ&3$%Uni>frcx>> ztF`uSWa`(MQ($vCN~cNMn`i!*5q!1QUOVxf2Z`wXl+CXdJT7p)OH}7QQ8ewGb6wh8v^K0?oP8rMAPTQF#RW+cc@cLZ4=8^XkQGT+Fs4B{L6H!)}aUGjWsgCl6Ol$?B*sQ^k z2~9wG8uN~3LX3@_GL>c0m3~ypQ}v{$i6`wOg7jTBJ4jF3qI8}CoPfHi#kaLMpJpk( z4rS&^%B)%J|0z^*jI}sCE;n%ghNkhCCB`?cJQx0v)rzLo=kdRfLhLd;J8QhPxZNws zCbPwAvpbxKY%Bt10->>OnPeiD#Fs|(teuWwySsA9OrkrhxX}&XNl(qEb4kj(@jL}0 zNLOQ+>2UN*N4X7z4I^d+F-^-0NW(`YMjqdWaC9+5u^N7=#cH_X3Q68{7y1{B{ZG^V zEyBP4V?+P?cQya|hbS+lQ&~){fSJ|b1L>F{kW{}F6N7tred)*=)UPyF$mt69;RR`S zp-|l~HKDp~nh;@k(4TkFpLcVdOO4~K(c{dAf2GzM&*n1lO$F6wZAqY+vIS49>mqO$ z2A_6UGK?AfSc@6kTOKpEn_|WuqL{H;%45c^GLE@kk9l%&yBP+dtvk`v+Ma+hr*vV9 zZX33>^0@S|g9S!$mhZsigxw!@DpW<nX9coHzX_KRAvR6; z5LF9&II4D2Rc$Dvej(MGB7MDq1friCwp8>(t)-&7Vely}%IV57dT>VX$KOGvOC8$L zyGPvLGUEQXDbzbCXgmv}`YeomYM55!S6W(;on=kXgk~M0DE}jRsBdXJWtmD`ra@{4`rC{{&D2B5f~TCW5`FIpNOZjKWy4UuC$vz$ zt5u%Tq7nNK3Dsj9YJnaK_At03DS7bM>>nAb=551JH7{tPYPJ(k>ExXh_F&BghlD!Y zI8=`wY7Fv}E_G8zp|s``Rd($+4CVTn7Rm*yJWS)#nc#x`O!+R%b%}APReGqo#U0k- z4oh)|xwyk5<{e(D4;A$WEGEiYWhLHNudG%I^k(OZeo69jXh)Z9n4jklT7I5=N0#U} z$`2(xcO04AcSQ1#aef!-`E`5|3CLEoALTdki;znipU6JL{M>)l@^im-7zs+_Z}cxp zxF0$UdGRO)2a#_w&hIKczucFQ=!fw~5-neXjDwfRV~q22Yx#NK86nY+JF8JPf%lma zWZIUEmVA$4e%@_*e#^gXfLeBK)$z_Wtk>?rbH(6^x$A2Fp(Ld_(=lJ(S$fF;; zj^_;Xb3Cl)ci9(~=%?ogHi6^JFHGi#50Q;`a}Iqs=YWUX;h%5){L*x!A!Pp#Bl0K~ zPy6eJ?PuSkwV!=>bQ1j|pTF1y_QBDS4|#YKId7a_o1R~=OroFn<)d7}Y=0~xtDE}K zlHWDV&-RLzpY4_-Y+mq$#rBOOIN&E3+kml7R@a#@GEBat9vB9;P{z9`aIhMmT3Pi| zD=R#54;v=0zTsQ1GjI?`0M?5P>th|z>SLW#8YVyDp@!*3N*zW%xX{7)c*vq34_Wpa zhRM^3h2>5|2R_oUY&NWqz~N78i6KR#@jymkU( z-g#IDb-@4~^R0$D=FPg!GCfTGkV%JO=IaiJPAqgd+E^!`>6m`4E`S`P1&F2>%OE@< zH9cY&%XGUQ>#G{EMLmBq^=gnfk}}OVjx|M#C4XK*Y@uUX8Mb0(oOEh+Austw!&vfT zdaNr|VhcAU5@9nvGFGo~tdsOuHJkzd%@OHSH5p Tmom%XElIisL`^?Bc<}!L;YKcs literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-APPLY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-APPLY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..71469a66226265876f7a4c5a5fd6aac2fdebaef8 GIT binary patch literal 5401 zcmb_gdu&tJ89(QqYdcQt5cBLpa4rPW&2U*r0))pzZtR=H!SM}#kT_dK-C*Xx4axFA zViOfGN~Ot^rdfl}7<+ZC#2?*gs!2S$M%qJrh-#~*Rq8ZNQ?+iLR83UvAFEc)`@VDR zJO~=7!r|WUaen9fzVm(Ob(tiNzFB?3M9;ULT?X8Og(CJ zn}PgfK34`~(UWmAme2VbwejH*-OilI*f^Y_F+vH+KbtFSPey}@uocZu(bLqEznJre zqk0bv&FCTPB_5bXi9t1z=3w8hRyZhu>%vS93J z;dFNX?-n#HKkL$H_QvZ`;O|WCzYzU7A(Pqj(JqAoe)8Jt-YsYZTFZok*};LWB7?=q z=?A6AU5H!g_Xn?#=b>LwH47|g&e&>E2V}6^0i$Y|83ew!AzO{ZEi26Qfe6FxZNRP- z!ug#ULtqwa^n1Zp-$OY+V&opisFk0VMqMWT6$gpMvO$AlF;pbCOBGzA-!tER5gu!3 zE4FGo?Xqk&{IE4!4apGpN+Wt0V_^-YvA9d&K^=sfnH6_y9!~n$#ga?!-3}hch}7ni z`HEsKU_dzkU{ayKx#6|U>qNd`0m*T%EA~Sz&R5%6?p%=ihZ5wuQjng(hhfk0YRO(X z1Y8_xDZ5B>~?jVgy~W~~}Jumj%8A^)u9rvokUR_MU)*(imTdbzh5yA^ab3tyX#{FLJG@_x18PnUspow*}-I9MtJ zW-MmKbSs(YNhShp4Rr7XjA%+1`gnj-_6X?Q?Utn*v6zwKUiKMK&~{*|c_mxR%UKQg zuywowj49)`myZ5cqVqTd{5AwT48 z(MDbsj>t9Ph7M4@YL6kb+R^*K0w27d& zhi?R;{su4=2aQP5jO(Ro&<{GN)FEUC1XLleVPb0R5P_*0ufxViq#2JO?C*=A+hvV^ zFQDw#67!lQS0Nl`MnhnP{SbIZJYmFe7P2cCc26W3??LGq9zb#ql&Td93Ec?ag1U^H zEyiM}&C=;+>9kIITO)|_&SGejfGW2IRQZL(T$f~cF|<)aQxbYWVoXW=5Su3)O_;H` zDejyQoZ`eJLc-(_>Ax`kVuI=0D8RCe1Cag-fk7h_3dK--VX@zB!Y{ob{L-g{LwZt@ zBiw^MdeNE@Guu%(z$=lo@f}F^@(LskQVQ^Ll-5cK@5EJNJJJ(Y!iebcaKDM|czt$; ztYljRMe;F-RpBUXu7H7{6R^)<;N%Y9faG0CUS1q`gNU145^r&Ovi z6~&*OYt7w$1GyXLTH{Sk$o=SCt4HcyIJd9ZYD2dIcn zG!iCet#~+z9XJw(sbWOp+=noj><5xo!W5ZO8#yjr_K`5bg8<+m(Zb%5Ei<5Uw>#-70Kt;+UcPu4yUm; zOU^n*6m(w@=N&lD=TzK!@;MJ28G772kTjz~6O&dS6MA*OnTms~)&qn4NGRFeodSig z-iSo3UfoJ`!fgOiY6Ga95i{D6=-kZx8m}#bB2^l(j$}6;o?@$ngMAau_`5r=gTC&V z*=-#(^>Dk7_Y;Cyx0V*_3$jp9T(_by##Hzr)C;MVla4v3Nh9P2uRq1h?>*R7NSOgo z8$9r7alg!gEmq7L%jakxJSlkkU0eCK%`i?C&hUQjeYD8JC8Vy%_HnPDuV2B}m+|#% z4IlFGSf`Gwd3^=WShKGu;oxALJXH+oJFrmk-?MPXW%xGSZgv{oUjns&o@atQ?MCg?G--y# zN5$f!^NY`q{LM4zn=r`)f9p*8R%f_t|6DEq-x^dGuR$m8g;j{Fji;n<83@J~B+M_Q z3(KX_DG@TmrD@)>}-xYDvLjZIlqzf2a#dJF`E@bL} z!Amyz1WQxN%ehCKw&cBOvL|!&!xxX0_C`gNN0~1V%$ruZHNscl%`g|6V;8RRuKUfW zyY@#XR0hv&Q6k*qphPYFi;nFuzbfF^fe#xq3J>mlu0*QG)UEcq7$Y$p zjE5Rs2&ChWizkm>QKJX{A^!t>vq&&v)I&3G-n{wV`@T1?E!1&W)v@YV>#oNd*l&jQ zW{B7Q1`hmYqr~t!`0*pPXljp_6m@0t##FcU%SoxhoRF0Qygi!o4N-x-kO7le{-j$w6z442v zFK>`lpr$NpD3Sh&BG9Ec8kr+mqAI#h6m!uoXa=>2o-gDndb{7b4Hdl?WqquCT9yuK z==SI3#GTAoztrJ=+CXSvyYsA6Irw6L{k^sF-1vr2tMb%XPDp)VeK>z-K-?Bz8lhf< zzPhEsHqT?gcgKL8{{gsD`7rz^#8xHaW>BIt-it2CYSEa_3;JY9G3Is6B)9V5F%~U3 z(ZRbCXF%J2SyiaIL`;p^CTOF!#Z6iFEUFa}(&-3VlzC4w&AXCapyydxGtHt&iZ)%f zshsSC3%#;p+#_wjC36t=bbr!Gg!mcJm6Q=I4=nO?b9^wh1$Z6p0yg0lqzr+q-{-@G4^8mlQ9j(xx)(=o$bt}; z9M2<8W20GRwJ;!_TXjQ>b2zLpyy@f#yC%_wGCWH}IV1+o( zsjihBQg<3om4&SF6Hn9*ul5oZ3CFjTalG!pw3V@2I~o+>+nO-r*YR!wI9^muO`#h3 zjjEofnyKg(?-60Z^0r;18Xr>Q$o?xADBlgRgX@0ahVCYVydm3wzkpLK;|DIxaLsR% g3#y<7_<>Ii&tAF7N2GR5d=xVBF+PM|jUOKV0E)6uyZ`_I literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-FUNCALL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-FUNCALL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0749e3f22bd574eebfcf2fef3fc5f257d353389e GIT binary patch literal 2962 zcmb_e-A^1<6u)<7m*ty<0w&wFZd>}1g`q9bQt?5CVU{jkW^rbgElFd8yNinqh45k2 zrWI?|L|0l0;#{@rizddHH27fJYBxrGFg9wmsZaVJnDAiq#biC_&TgeklQv4i-E;1_ z=lss^ocl2>68AAB5>O^5rpBz)bYOCBc4}@mFgiIMn3gwp|YCqUo9+HiSgLcoD z&aSrhu8y|W^4z5r>YXHnBuExT86jRG68mDt8#GnJltST%Drxe78nhSfOexeN#SB%q zGqr7j*~ux%Nmd z5Pk)kXvu1HJh$2&-yPo@55`+87t~d4RpnN<709DZ`+PpYgFjx!e0pFD92(h|QL?v%k8h`UF*QwY-A5^&7STGhO@Y^INj~AGfkKOxNT})qYxXV#q zOnb+?L@2l4$oPXwRO=1n<&%!cT5m+vrJgWYv_2y!RI)Om0!Aqe4-7X97u@vPpdy>f z5lL6gm<~5p;a9!H7&c6GK%g5v%xI8Rh}E#*ftwo%8|Lk|0dKWf!^%W2-23XFs_Ri* zipI>rm>CpnA)+!UYr_(^8$m|JIsWDqvZ-#e67! zW?NBw&HO0d2Y9zSr0T;sdkuPCzKc&K1DYIB(fT5mZm6cz8xDn3$gFVlGhnU^Yo@9j zDt{l*H{v7-J4w2nBsD-xgwC=WbRldz2>QDtes#o8khvamgd}5lpeGvPPbls?x_$(i zL|8=q6`p{e;|b^-PeA)2+H-th2)7QM`XHcUNRGr*L(1F8U#tn1$RDs&;w<6x2M$MW za5(Y>ha=1ABM%O$S}*#XWqXb@-!R+S&-^}Eswtv~jTE;-jpfc4#(De?@oL2?2ypY` zfnEZ9Pf9f0%?M0|KUp)1AB$rTI-R=8g1Efuczx)IP_c7|@1pDY`0~s#J8a zBVjmra>QU2=mtH0EEY9Yrw2D!8$!HeFNvaupM4ut!Bv9RWl*W;M)ksq=;`T}Z?1V^ z!Ws!>4RH7B?aWqdWa5eB2-4bcKcOKazn_4^>RAKC;TZvh=YfgfLhaOTZ5A{tqHXH7 z?Wq;w?oLC}dnTg!MDTwFJyu9#^3Je!z+)Xw!9BcS`uDkRhYJ0Eh3xE6EI}S$Tk58l z8)ZuXMWCm?uNOTp^xr8NMp_0Vd?Z1OPY& zW0;Dtablm+n`iwQHb%bnU!V$nKH(5I{}06Z4gIC3o&FBMmM=^#SPK)dq4ZHlJhEWn ztaD)s1o>q{F!_cDlQ-=pSBcAwXOLU~puGB$z2ss0sDSe`j`=z8 H)4AL~p_n(T literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..56335ae1b46d4b76137c7d02456d545c58474551 GIT binary patch literal 1460 zcmah}%}*Og6rWjRurb67rR2+M7DrLjRhD8x8$#2=vaG>i@0#6N5!6dvV`5hZBY#9{ zt3(M>D^=R2b*$2zR5|t7OBAVxd=yl*QZJSAC*)MAM-IJ{_jVznO{8cKv-5tx_nY@M z(!8&5c%5TCLTkMy*vZmZVj%OJ8WFrC*y9W`M+z8~NIJRzi?!dUztZgXO($!KG z(^+c}N{IKJ8%aBc#xkbib?6P+=Y8w;XAC6|sj0I%5hD94s7^gMdO?{`@|HQ9B6qi< zn}pC5#__QHXr4Y;Cr=;G3rmA1258t1QWUnA{BV!&7-;zGemSs%`3fQB6aA2hc!146 z$9^Yd2XM$Pz;^GSgDt|~fXH^_5CdrYP`h%Y9DI*}G`QI#((;3C1O9j03*Q(Z+b(}) z%nKA`+V_T+hR_dCQ0oK1N^#h)>V7u#(m^&oz=2bW$ABVMc3&@kyL|7>SE#qkVnrlE zkN3TskTuho$zb7?In|iS>XtH{0gEwf%R-n(g)ZpofUK!Zn^P>EITmz9^V`~OFWXGd z3G`(KGi4qNMF61c^9jJ-g`zwf>WA(gk#);5EyZ+L-eGbm2HZYbHI^0MZp)m8`p|!x z$6qxzkuV{=3y0+hw*L%BcBf4%r!w3oF(l2gEZsOXjGQ7i2-whztTolvgEM&yVDb+t z+023p;Py{GjLRSVC@#P7W4L?`oHy)DE)P>4P!)aAQL~6`^5fS4j-_+zf@4gZjxlo; zP7J|(^Y}WHe8|>WTCtaN(`HsVnEH>vrT>M;hp-Jh26QD3n)DP1#Qclp&wPse)(DdP zY9R+NQMZ8=@Wc3*Co!78!IS2FKKbpxDr155XFh_&p9205Jo!0K)Oq3xPh93AgLtFb zoNB2W)2&GqTjKFvJny9Eo?@j&Q%YV}lhSGd-lG+%vK~AoXuEy}b)R@YdL02A-_k5y zWxDde%4ahmtY&QJL{W8qd~#_M!r_$H6@)A+Lpa|MePEH;ndd>1HujGyKyKF-hIJnMBr e!Da+Pi$srlovs6z`dM+H2>cyBLhfAJ+j|DHmaX3a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG2.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..36ed2de877db252e4ff017c310f2226162d3b815 GIT binary patch literal 2007 zcmb7EO>7%g5Pom%#C9CVPLrmM6Q!%9fnaqb5)3Uts{NL&aryG|PjqD5Nm%$xb% zy!rXwtFfkeB`YeG)%BHfaYL+ZZ>?`{iOZD@akH|$u~-zB(JsEO=!W`cT2`ipUl?gI zPk0tLiiNG>l4xxgHpT@pv07v=Shl`<+yv3Pv!nP-PvlCqg~qdjuZ<+0H? ze#0$Cx9dDoVT>)ZLlObTBFw|=-D)Iesiq|*Gg(#AF$AJtWCYE zea%>{^o}+ua6Gzpr)#d0A|cYxSSy~fve@PHu#r129p~;t%<0_GNcp*fYI>Mr?}-f< z{1~HM$K)QJ+HUF2*?-BcR*I}dnBcQNtoFtfU7N_zkfgM%O=ML=N@UQYrOcSn1OdT| z3}}xjvZbUYL$&e-PEc_u&}=T4mYNgzX@sT6An5U%;3(eURfPg22OlXU#hM^mh zp0}p+R?HJbY->!`79_`R#sDdCnpu7?W8ft|brC~mFj8|;H*&H?ON}y7@`j;mC-@4S zd{@!e`LI|;HdXg12$H)CBL$N=c`C0Z^t?7fwlHq-AcrALt01_qdR97S zH#*rL1kK5c17*KK4;g=P#ZS1g!`X-cL;u^p?;%Ra&*3bIeW0q?Cva{Sx@Vw!3c6K@ z#-V2zdWN9452A$TQ+Qa=xs%Ry8FBNAV+Bo4^9XYZ?_aYWPdaR>VmO`+ne>xH!?=|P!4xb=Mt0|faDAt$nW+T9P(N6wma zK6@K3yn!%pGGnG8d;?WaTFyau4F<2#BB^5vFA^e!uLOjzLiZpH^h3`%7zj}2DZ6^X zDsFCx{Ws-)ak+pm=90Lw=00|0yE#ZOU!ApHUp=C$7NmE~uJ)7*t1mAV2z&auLYPY` z?k7Uc%GtbXVw>I?XY2_^`F~gE=f?%!&gqupm!{CsXek=Si^L%E-v{7xC^!e$dxBkU zy?C)f1RRfD?Kobl+HA(qwH%U{33Nxi*^FuVh?s6h60La~1;G!eJ(Jfh6}!c!A&e%7 zlRg7sC*`l~j|sM0?Nba@wp8gKSU?x{enT23fSu+Hev$6?Yboarpln0_T)oN}1q3Y*A+)<4#LqtkE#`(ZbQu EUt&-{CjbBd literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROGN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROGN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3b290f273de70a5267aed67a3945f775b49dc5c5 GIT binary patch literal 1465 zcmb_c&u`mw6#sthrD^J>aYm?0))ueLD$Sa!wJWqMAaFgWP3zd5?aVDgnkqLXk-Vm) z>7)smrX3K6Ajm2ve}SF&2d3S|&@8mmq#fCjGe?k+kT{k1oONsi2@Xh!-{<>&e%|x@ zx`a3 zCKVfm5T8USQiO z=h7~rgoIzTdy5rQb4!*P?$c|uKm5F%E}6p1uncPJ&vP9|+!IPu@MC1*6L*7I!pU)$MN7riq3*T=K z`KE$&kPAk;9O4RhjzgP31)oE4c_DIFLU(o9LU0i;u)cj z2luqc#O4e<4o)n)&YiZvy;rI`*LZi#Zam&~yz5XJ zg&HsViK+r=8VIeev{kF7v{IxBi7I`hX_YE!D;iR@Y17hk?%jnA zjzFpMS!-v`^PY3=Ip@y3*N2E}TOgf zLk$PHwd;;qyRK#Rx|J)NN-sS#B~+yeAu%$8poEYrA`$0suF4nD!V!N*S5WioYOm&V z4mmk5%*7uKYau6B-J)dEBYxX@$g*)d!xy_0@t4xzpQO zfbiClEF+|XkRiPiiAyIpTvNL6TGH{vc;XBw)a>!p3W?LxI^Y)$^&HTDK**uQe!W{1 zz|*1Qbz2qmg^!nzazbX3u|}4+e856uAz)APQ!yxRDH!zH6?U!NU@rr=P^Cf~#jw=H zL=Y-+K?#0&;_TN>kmu|>U|xj*kUiT2^iazCAt)v4@z1^k#k2XKaB=`e)A+itX2zCm z83OXKVMDeEw4_(&LzHb9@Dke#=It_DHfkzukL^aPf>RQV5P{9T)}zt0R}}%A7&R~i z>TuAgVTE|qsJV6}s;er{RK6JU)g%* z!EpkH0*f!q#S;RnT%iGeTWElC zSg!oXTNH5CdY9P+1}*}O{%n5rUO$lQeiK}m+pv_o`vm}e;CC+1!C*cOx6pmikFWNS#fU<9ZtoBMG0%};}u4p-mAB99!F4m0*h7g9-1T|!jgM%Bw{k`o* z&|lb8k^dm@%Q|}1o~Yh#MD>lx3jj~nwx~fQR?|5MT4*hTMmiUO{8xxU1~aQJZ{)ZI zqvS7nNei8iD+OQVs@Xt<&^aia1PtqyKfs0iTsc!;R8Sc{p zT`Hsx%H;1u_E(VIs|G?waZaTvV0$`PI+@x*s-X6EZds>`kP6U71gq#x2v*RW5iDk! z;=h@u_r7MpKGPJ>aLq}s`FXCH=9>3&&23zB70ajC% z=BOIP2!$MyTeLvL2qBrJOAsW0TLzs5>qFDwL7oA*^W3c?w*~1SqkFdmyIB2&E*t}` z6V<~00BR=hRQp!{(^L@+!T?n`0W7GPWivzRVS0;NWQvCOLSFb-VOAZZgg(ldi;ZTe+ac*S?m)RWL!$FjTdAx^9SssP|aPUj0kK!jV`=$dtOZ6jT? zfUaE+7F^$PavQQ%1}<2(l~w%8usLKYnXyqz$tKbnOG%l-aF-e!OU1IubSk5mAc^GgF1olu?TZtC-4m zJ3U~+%_~0@#Z1Lvjxa-O2cJmB zqU21<6}1gAU@{8ZW`_g0nlqfn%0i(s>_&}6M{S>zYg*T?!AD=?S5qcsv9p2}D!D71 zuPuH>q`yrOxVcmjCpX_VhX>*&R(#eW0NONv2tW+S{ekBQH#_NvMfeFPx3tf;OlZ4! zI<+)=rFy$mG;OlTS%5h733M-ga`z8&m$)lScNO8A=w@UsLbKv0H(Sk3;Vv&;D8hfm z%!;o}5ozcXTNR(@mhjLZ?k~bK-0Fr|WfuKTZhdjr?MP-5&~h;wmu@Bt{~H;$Qc(X} zl@W6k8Y&B|ZYN>s4p}>Qq(|e}TjFxoTf+O!q#GJbk}EubL2ote9tQ*)ZTD_KO1v0S zYni(YDG%t1w56iLgG!P(?)Hp>G2z%0S#J$p{JJeB@Wz+0Zjw&H!MQ0|! z!fSir{JqzFHF>5@?d`3WMdYqil3y%(8HrEo^79&95 zXHH(yqxI7k+A4VAb5f~>Hbr~!jLA+qv|MbUt<|)J^`dZeif9nqmn>VpcmyulGDc|G z;`#Uk7hbBhCG%AB^w9YSF1%>V7}(>scq(z)Zh$}`#_q1GV{Ex9MpsdcB}flB36(U%*M#r|CnuRP3)2+`5ku~Ga-tbSR>+wwg`_V7i3!gDJTZ8fCQQ+@H3Sz1 zeG{FJN6&zlqM82>!na?PyR;3J95C?|tmOpS>SN`C2f_T(_ciOJzllWUySd)Dwsb|>Fo2Ga4Qg$+h7um&S1XWMwz$+Z;QV0a8a3bFJ^ z5;vpK^f2`9c1vk)ZdKBQN+6iU!woq`Z%~G2N~JhgPHV~x z=#`5h5>-EYBoG?+_4m}r*7c;zTB@pLl=z%h$)wKjReBC9fl@iAL*vjPfPMbnUjP0B zzWR|sEX=Ka?3jc8eTV$rJ-+&t+c(9gq96!qp@!lKL1+?W!MtHKdE#m;?j0EmtKLXp zLiL!}O`{Ih;!VWVsA;(NDb-@ht84R`j?0;?2%;dEFBx?siAX3uMk3~txF9x|*9^y4 z#5)N~3yi9QRJUpct&66y;h^_`H>}2m+c$eJ3xf5kt4TsfUd_HXF1}Kb#(zF8C1+Y) zqU{v(?rs~%2mj!1wzU=hTaUK>%m6hG1qkT>h^|X%y{5OM3pL%6uGVJXPnT-?mUOw6 zO=oJk*B}zjmp42sW?z|d)`%0}yVt|li1T$pxSstIagIx(1Dba>C$ktn=&uum20^Ih z(x+=L%kQpF$D3>EsB;Z9WSehf?`(AqHRYT0D|a{LbxD_X3yg%c;Gnk_vj6quPx8re z*t*%*O)clwrgrI$q@G_+7V`I8atql>+DRvtKr@^3Zg)~o7M7Fcq>f*ud-%1StS-AO zPZ1BAgSI zTbuni>AOGGS0laodjLsaei>08=>^YMmw7k~*@Rr71xOzU#EH=UQIK~*O7QQKON;gV z+M3%=gAb>t{OlZ=8sK6O3J#oi)^v&ZmvuXQp|gJUoD7gbbQcN+=%^S(6+#$>Z9j3c zRPiWjC_d^_ZxsZ+#kFw<8PY9ieu!BM=5-5%0u@2#&DvNp0_mR`sgWTPBqI+>2Z$ez z40-`>vE4Gbx?2Xu!A; zxD5M;g+O$PU1U&#=#T+ucas4LL{FAXljGzCa*}*z%}8@IxAQ+Q0M>i773QyHn*^x` z?g3GKaPZ@iEp?+VL>*EWHUiM_(R#^?AP8VDZIJdL7zW^>c4;?!I%%WS0UhnsDeVIG zPV=iqnw* zCxPPz&L)_l1=<@y*9`qG=x+kq2-pewdf+qwwgYwmegbeEaBT3gf~zi1C=d@F@kZ5n zA__NEh+TEI*ojzNoscA8wD7wy6jlR~#H4qGL?>b%DoWzxqvOOwo8^7bAqNv9)FJPu zO>!?>f=-VbjgqLBB;u2axJNz!lm<^Aa>C2>Xix5=_3}aLln>EH`7pK1e%fFfO+AlX zwEG}E)PlF`KD;qs1mhOChiLyk5)KXE)f7GtKm(K5`EP-EC_rCU)*Q~_c6J42Sgar6_~hRPq&XHa~TZb5Mo z$E(K@f$${4C_p>R4xv{g@If6xN-PnKsmBlo=nfPI*u-imPNE1Ux*df49v6RvPB|Q! zK-FzFt$d43D}RMeE5|r*n2Q5UNZ(~l>D!Dc-DFHC2lQH!nNoa@DaAL~!o**&g^6Eg z6!Aq)ndg+v;6g*}#6*yUy(~UpMXW=ogCr3d#?=acrR^wwLpxBs%F*{YGHCln+VN@H z9;O{W+Wrjf7zC1a0W4T2qhvIK=p-UmD2R^1&n#O6v&@nnq#n>(DBX?XC5}GN#V9%w zi$`HwL8tsLx(CJETzrm=kmngyKE=gR-q+8Cj|u52V@j79MXE3%zRi^4?>PE37nh-| zob0C~{HpVgMoD6lI$%yQ&)L(Q7UQA=+;dC>#uE`1EabUqJ&KLE;$sQIN<)PGjLLdY zT4HJ(>qE3Mo$ycU1tk21I#K+I`cV9VquOD#AN$QJJ`!U)zM(qRCyN9|vsc#o`Z>L?Y)ZGJvt!GRl zTGc95Mc1l|SE*(-WxAL-uM}sL6w~2vXC+rrQUxV9ThepsTvaKRi>C_x3be{vb*@~f zD6?~VHCKX{!hA}HmjGIxHI1!tw7mUNV7oGtf_Fql$rbn$0CkskA#1_8nkyERN)_HLvs$6rSz$H#eTuQLoHdtZ^Qz6fVl$U4P{R#sSe?M5DSl#7 zMMtg~^@&JqY&4<{dxIz9st6=UVEAYv77ql&>ca0$LxvTj8AD9LXBs|fH2uO_<9XDg z<~eAju+hDU;j-*qtfJ`TXy>AaNa4yh^QyzV;sCGcVcJgz7JeXL?S&+70m(2HC22+4!)1nYIrbMcPzoD^J?^P>E`t1dK`3+I5vCu@9THs@gP-?3{a( zlES1-8s8T3IOlinIp>~x&bjZtn=3-qS3+SeRG65|nVF(im?}?Bm9?=#Q7aXuim8k? z26FAy5Q!S+4hBN~zTI8U*rJhCF_SE3(pr2fQ%Wb#bZA|>w7_IBX9BZxC%_(mcej7r zcAs;9AQtA{{-ezf|JI%UZQVZS-1Rp_r634GN~j=NDhP@o3-(n@@y3lETDdT(o0*dt6PGhl5=23;zhTwvPeelTJ`%BK#c8qDzHGVs zBKjaKEpWgPq?&mz=v}le*A9KV9ya2!cpxfVf3y37AXGh46$yiRC;M){cq=dUzt=Af zjWw%c^)VLV&DB7^_=S+O&CT%Je5m=h1!6P>2K@N+eLLsu22s(4hTPE{0BLa8au-E15; zB~vyX;1ddl?(R-!|Ld@p^RUotQCy3HlCLcUrJ8P4tS1}B@2TQ4(rQZgRk49=Ag!bw zdj!H^li%DkWDey)r;&JvOrTA~OFBSzInsN?2ci|o5+B)uhG@x6pJ&{Ts|#_jgm}`; zP^_W+Je{1UMMinl=ZDgqDVYtb*ley<#Z{(Ex*v>mS0)~lo(Cg671BL^A0X)&zlW%Y zbVK|L%ifiR27vOS7pOP~#DmcF?;sz7TH(LvSFftK7uLP{IK*&##Lr$oBYQa63q13{D;B%F>dr^cC%#imJ533l@)CnZ2s3Cd!aaQ5bI#p@G zbgn1+Ob5=hkGTzwn-0hc3W6-G1#8j^?J&|?A^S*>^v-t`>kZI-o>{7<3t8GQu8JE? zNfld7Sryw%hbp$K$|iD%gh_-9l4#ah&2|=c>3oL|tBO}uHmgd9s=%)FnJ%-*Tn8(H z4G5_v9#IuLiARF85y5RSJULch0P&33($tr@>1xJl& zd~vqmsUU4ZS%|u&PGkbW_^3XbIYXgl>tZ7|SE>!gh!+hBjo zTI~&yNN*pWMf$-&q&I9t^Tmg9<$UGo(f~*#>3$PpTQouE!Qw>iQgsOT&fq3Yk9yQ{LC>(|% zcA8elhGTJKK$1YCfgiV_un~wP2KD_UIuP?xQ4*iEjuS7fm$$-z98Bz|Zh0G3$ zcz|!k1Nl>M?l6u7!U%p1pc>-~#1Y=Z07Hpr)QBwlTA(71{Q|}sp41=|h#5Q-T93ms zP@^SZ9XJy1i!oQ1&@;@EFk(3T3Vi{|OH@O$i=!Tf9G}zGAawkdu0iq#x)#Z8v^NeX z0^vb~GXPyMJEY!-z=JY2MJy4F8HW*`qwA53vx$vRoJ0|Br!7cYIcbDJIUE`Qk^CW> zR{nrZE5FC4mET}`@+nTTj7SfergWcaN_Uthv>8S%t>Ho^6N(?Pg^9mq3lqQ2RK(Yr zig=Q%tb`D1W5WYM64qIMz>8ReK?g}9(u=DV9?@1LzoBhN-r?wn99gvWRoeCvZ4J{l zA8lPj+xCJ|)kol=YA{L;L=fFV#2N+B4fv9)j$oBp(Z5T*Aay*Xn~?mHqn~l|8U_-J zM`2sxUxFTz!=5#W-n$_}l}5{zQaj3-y|)6Uj1M^5Fzwy&)=G=meo7 zX2h{U#408e{zi2`!XIfJl254*$?rM(9qmN)fTQ=h=G(Lug+Jk%H#zz-*Ze+5*SO|I z>OsvnxaMmdP1DZP)H6=?qtrD-eR1kKOgsCiYY){o)24Rn+en*QXlFBR>H_1c4{a-6 z&XmfUnJIfUT`OlZ+GrttMk|bINiM`MbS+oXl6fsRF=^&fxw1A{EF8=4)_^N!%2UOB zNt>85%ehIokDN@JaNj`RcWvv1IQnimA866Wl5kr|Yq>nXXrS!;MpUErZ1wcI>85EH zq5vRKk{#32fE!8n6-dr(Ox+zPJ$$gk!WG)Tocu(D7&6>R7y{Ts~z^ zr88POlQNUVWI0#JYo#(=jV3bra(jvO<)0{~!|_vlR<lPJ<~rDaP%OCX;meYXOl3Q z45SHPpNW*WJ#7rR-{}qM;)6&qeb;ZoxQ({F%5QLO4ji6W%Dg;@uKb)_qj~lVLzatnj{9(Pv zsJGAB`67tLpNJVzJMU}Ma+y)TWgasv3}-kih=O3>mM`i^gah$lBy3NL6Jn`-YrZTP z_V+?)dZ!^sMUEEKF53ChUH)c&j~<9dLPlJ;d#d)dAb1}`R~{OA_y+O85#ipi-XPuB zSnCr#mKW(|g7ENRL8v_K)x@C(&xfJ?{Mqggg}){UXNTSwzCjX!ZWwEq^!$F|bfM=jxSp3-QW{iSr@Y!jjUZ%sp?IxrOKi6z+zQ9Ik&dB zjXrExQn>cKrQoXwUy`L*MLzk8Wke#^0%K$|zUtw%DqI-AWmQmh!N_<&*jrS|46^A;c?SOcluSa7dh5}io3xU#Qraa`Ira0`uK-d|TGf3P55Mb&P; zt{lENyKY&SwBZ-SS;*omhlUK81xfTvNE9;GDG!pek67k+dyk1@d0;TnOxZh87 z3_xBBG&!8;VWsjqXnGIm(NHiJXQgnQ+OzODwb~;HOu<9cVLTIk7i=iT0X>AsG$1PG zMUNx;Rdg1l_KHYpjwU@q<5Ir zA?Yx?3PC@|cCs~y?O zk8z^KiD^#k=fq~n+bYW2q7aqqmc^5AeR5pwg6%NTh-4Op39ssHTg9eH^Ujg4JA5B|-65 z6rK1GTMq)_C)frAQ|xL4|HL*TcrUvK!ObKt9wc!w#KqTx-%4zM6oU{k2w88#2*fqe z_UOI6p?<`0d8)pqN2m1$7J*nI6!*tqVG3b3#4@rj{Eck`O!y1ij^Jh1fZ!$8h~T%J z<)@tG0%v)Qv;2Uw{0C?G1o-`qG z*&B^?h7tQDh3~x+KD5*@E&#M1{4;CD&f}~aL5hRboYlwsJOtD~(<(57FNKM1-n9{T6wwejSJk)+sVR%o*?F;L{x3&B6PCv24EHF;;_88MX_7 z#j&)ba6i(LoEBnx5Zg`etIeFhkz?Cf3-)ay%=0@6&GR(Hw#B(aXv4fTk`V` zuY>-E>B##T3PQezyq70ANWeIF1CgHIkkN-s`&a;hAINGf9){$+;plL7u7uyL|#IJDdOEmD}=cw|; z&#>Lt_c7i#$-xIWnBbs|t8U>sw{oxo3(Q%&L@yxXb)ZN19m5h9o?#f5@C}YlbL=jN z@+!zfFaSFct;aFki2UtFAf!iiJhj9qdf^tf;XSPR9jv(tTz|a}*!e`x%;vP=WNIv<`8CUYXF8R%tP@%`l^KPL9&;p@&ZW()mK-y+kxWiI zmd>UR!5z`@bZ#g;qUDB6jjAr2&Wvb-<0GjYG_t7tOLqRMI4a+8Qs1BrCgEmjKm!rF zVnW(UTqeC|>`AHAo|NI#aoEZnN?O{;_^_7FYH!iD+xeAN2K;eJw9egzQllVMw3O67 zlq#PmwPX816gdbYWlM>?b+L#ar=Y*6( z0UO&zqwn4JW+wJJJHNH1&46Ms_+1xW;L$izs@)u)j5%4yy-oe=lyvQW@qztPN}BF^ zpbHP>L-=Zi@AR&&3tboR>kgg@ps{LMWHokvjg=feG?2tmTXZ56MM0z!Ash->wOGy8 z2$FAM>QCx;nw&qbkZu7T`X8PzJk+WGS5*#p7R&p$f<&6sd%DNGJ-=0+awp14>5@LOe4ZYRQ=N1~uKrE@` zh(=Wkb8R-jq~@f`ok$ui=QPJg%;Vf4n2j*ePN{KC$^eW8P{V>|@|bMsou95ctVL&<^6@j|n%yICzWNc3!S7?ulo;Yy%9 zL4GJ-v?q&1Nwz1IvZ^`-S_*a^U+j`;=WB*Du;8FyS*mVYpkSC#BFSz-uxUzAETuwN zzD%K-C8ta!xZvHm(K*_}X~oX3a#16EAQ+8=d*G7=1h71nN>neuS?cA#p?c{}Q~&Ig zARm3xw10omn92Wc=dWK_Mz}{f^TyP&Irz)LFzhGUZKE)chRqyQua$=V;i!4ycxG$> zOGSQ=N=1g5tU{g0N|_g0P%3q&CZK_JbLtc{iec@S;M6I;twb$Bf*06{&|g;OMOImw zP`wkV^5i`1A6;e!eZpPHjZDXYOiGDtqgEu30ht>`Yy>dw3t~qc2eBQo^Kvp}VzbH4 zi`0O9NJ^%Vv=NsmASW4~-ep)=#UwPOnMG-op11RxmrSEMJeoVf7bje;4rK;Tpo-@x zU(&xU)^xj_-?>l|;VE2MVRui%c04$i8P-OVhfS@ap$R8%Ae6&1ymTAayK%AJ%GafL zCCy#&sVQM~t3KJM@wn=O|U%^D- zjPC#Li(pfD9&7^KRB?J{X6C<(2|S4%&%HsmgeT9me$l{4!Z*?U;v_>!DEOMx)&y42ObYBR0oa*&d9&VrMy?_Wg7Z)e$tJ1!6w_ z9RM1gTPmjyOTLET#bw1TM`tL~h9^`Ui6-U=RNF&JA{zl)7GxzNdXG0v!P)Z%~WXYh9d)Vc-lgd zKsTBYOE^V={{*OqogRhmfE&7ooeev%4L5gzcB&Z>&ey0=?1QUwr-xUQxT-*^3EHH% zir&=4S149Wlyc6jw$XJLSZ8GDj=Xem3o+E7hFz|j4MeL$FF{QkSmbK(TbjC7pgtaF zvm575jFWnO^xop4mGeVvaIJ7>{Vqx_V0Nw~@$G2B$x5Tk!$q)*cnQUe zS3VszE&Z8kEqZe7BjcU+x|wXn$<&;jl3H}Cxy;h2GXAKdEmR6FFvpI;@R8$(4SPkmTQh4KXmZ;!NX&nx34#7Pni&sC96m}2b(yuweo`MIu{%l!zoq?CB*wey*-vTqNy3v@K)$$8t|^wgENMj zgwV7pok;D?U2u2m)jN)=N7STcPMspx8=)(N$n)sOck-{Fps$t4jW}V9}b6`iVzEOKfauQ{Tv~ESNz*){;~O_cgWq>>kDn3`;hrzGi(l+L%g7H7V5a~a(*q7 z@9F8iiy5EqsElX2ZrCuTrmOxY1B$U;&FsP~J`5smAbkxr^H(@NM8Mx}O`_rtdhJ|F1yMxt6O zI;~oIDs4fBi1HTGW}mTBdP1UiYoyEw>yvv}NbZHM(jCz)%d}K8ol2%t5xEZ*1R|Po zM&)ue30>;&<}TGE6T*DhoAzS2ISV`a^ix_K2Nn$4&|fWuLla$yrY%c1)-^&#aqeR< z*MA3%sAlWJF6+Z-3DD|zV$vMrtqmm7AK4(1UkUPc7RJ$6*-j)cvH>Jd!J>X!PsLRG zOk%=}tF2ColQZC3=pOQeAm7F#My(MTb=yfjI-|jIh(t}IIE>JHA zjvnPWNRNQfhiO5XDintW*&#?s5G-o6GtTYMzcBQk{+2z2`kt73 zLy%Vmc}0-(0{$$I0gfQXNB+r$-~eQpn7? zP8HWrdG%c>Tt9qC8&>8s@RZ3Zg_3xMpzP8Js`Yy-zF_|l!Xf>uL4t6>@{ZO+y!uWz zQ=H3XaMfLB72;{0RZ7`Ig!;TMO5Td>)#;p9_hlW|1vXcgGg*h=-v0nQAjt>?n#Ea^ z{|)4%#Hx|A#)j^DaKTy~&54H+;j;klk$al5=CoBxf!APRDOP#b|;BW$cI4 z07gQ_1V%?}azW7W^x3sv;`aq5C7sv4B4_02%b+0~ld_splri&*g zuS8z3yx>}ucFAtm-Wa-GY{)wSS@tj$~t9`q_v(9-u9K-cO0HbmTT?1d z&Y3Ti9OaURCm^Hn;P5$(k@y?*{<|ZA(~}f&bZ_B5JjlgWC*Q~RVhHR>$;Zx8){Wju z;?&T;3kP|Z`t>^gEry4OuJFvW(_)5S37_%m=Qp&C!aQ8FWo6#E2>ro@|5TJr#Zjt@ z3kz<+$&D(tyaS;YGldfL6Q#OToGZIRXRf?h$|)K6K&PY>GdTygQu3J#j#4U%-O!6? z*f^3zgM0mC6HljM16E;GR%46o0=vkbM(M{J(m-++%8z%w>l*`r zw-}V<0Vv6_Ez&8q(kX3c3n6elz@C!$c~jYF8{{Y0&z-=E3-+VoV|a=WurUS-I3B(` zm-l(~llRJHF;iN4_hdRxXPs(w{e0nEsSMSORzf^i(3Y zayz&P?|<%J1^lamf3+=qTWdvd2|~TXgEg(&;N}t7Srpu8L+TNg#i8bB<3BE}06fAv zNAy#=wfTqyqtlwDMWM?l3E2nuKc9Ji?m^50)YttDB10W-5d*j@+7aSQH)2b^g!y~< H_U(TI1&`7y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-CASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-CASE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4d50ba832d3c5580eeb0e8b944e215295a345714 GIT binary patch literal 2199 zcmb_eT}T{P6uvX->Z)t1Ms%^pTrDLq?MVEoCN`x`$5B_;nRI40Mks-GcXS5#$L`E3 zQW_+M($Wp>=8w54mbMV+OF?`~Qp`i?TcG4IPkjjVrIZSVKE|FqH%m2+JUTQqI`~Fk!-Qlc7~8+vjEoMR9v$rO zYuMYo#WfcYLTU7Xih6{aQ3(0h%FTkQ7^XN8Pbi`)%_@Rl@yij&MNArs?w4Bzuvb_S zv(~DWrRn5c#3AH=QI1R`RoRSds(+o^;G+KL<)*kQo`=+=Nd@tdXDpPRgZYR!EXtCh zpv_y+D+uvl(=hJY_ounLd9?b&G(Xqb*}{eGrxkm{xxa)^>y^4z&c3^&!hE+fb5;Ej zp^E*nI?Z!UFx%>w>!K8NL=cK1^uS4X2gy}gA68lGj*yi*QDu!BO_*H1N?3nHgg;ja zo1k>?g>u1p(?UHwlEU(ts)I&*$GNmUraHUZXTi~qvwb=^uI*D)W8QbSV*$3A4PVNJ zcWuF!Jx7rVTh$?oo(~S72f3w^r$eKDHr;oWfC8^^HMHkY7Yc@9DwK%(|%&&69#UOm`7p*q(dOFZW3z;kNj1?{F-cA>1Di{%EE1dUCYBx z9@8VkuIFU4c&Sjx&@0GwG8Q%Y)GwbjE!V@nm!)33n1ZV)LrsD^iDH*urP~z$OaD3# z@pj9)BAJT#!t;=bn~E+a4AMxqLHXZJYNirI$`Akls0K(6t>9MRmGlB9d4(0|8^4U@ zR34{Ou7!)1S1RUlu9Wqh6}UrL)^AhOO~&v(H9bkXDWn}_8}rMjSi#mTpv>bEu;xp- z1*_=NDtNYqm#uYrxlx950V#TVfC&9@7?Hc4TPS1?Aws_~qVEq9eFgcA7vP^k&cbVj u;xdgQxXhjW(!Nm8ZPGLMy!Dh{ZmU|lPL9^YgM)R)Ne}n@PIP;0Z|`r%a*f&m literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-COND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-COND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0f38f99ed2f9fecac3c438c82d9d77a81a8d52ed GIT binary patch literal 3664 zcmb^!ZERat^}hF<#Lma$v`LCHCwq!$)Ox(EX}YE+F|yL5RvtUTQbb zcIJ;tg{?##jQx0QO}j?#uA3O3Nt1?Hl>KSfsSz4TXiSq30;K&x0;VAW($GK}5{)_M z-q>^S*!YnsSLfXGea=1iyz3Rx^k^h5NAlUFjBOR;O)5eRXwINpgFJz~ZT-MuC(3+?W+PDe~vPC{zx z35|%}Eh}hU0DM$AtV9g`Ve;bYJ(mgbd;!CFBYk^PxRoQ1y*VkK9_Z~9nliV~5wh!Y zOOKGgbw>yM!2DFTl732`6on4J*7ltKB5LFE64Fk{MrLl1aoL)}vh$G?tsw3~tL@wN@8uVd$i?(P>wkO>SfA2hplqaj1zq2C= zh!0f#bwFXzHdJ^6ym|m$$NkzqyTkU?cD*_2&makV7S7Yz%9av>9g6AgYD{hQFG z%*pzL=^DBZBx;+$`6~K+_DB`Qv)-}umIkY#wbzBVGrc7Juxh(CeJ6b;xRH}SIMcsj z^rw3n5bhZLq5yOq7?o8cxRPGZZ0lp-89|5(?##1BkX@SZ8o~ej)_9a^0Dg3Dk8eT^ z&ji=^8$n+8e(Vdo+4kBUtRs7YUti|Bj{K}puBO*|KJ5mtr2QE`5&iCUCm6z65ySDK zL{8-C0eI5K!0Y-X>4=)txGUO*>|a1p zTD~@YDjrLsDe326x$Tr1pV5*^mG(02M%FUjh2ROg8$p(K0T3&UDE^xf#lLbQ8tqDI z=7f@*ogO#hN_C{8#*ethOI+g$*GNH>O@=vpQmcI?aKNMdDcXx*ii3wZ7~w#ndywbl zCYzW^;h)T;@Gh8?z%dPgh_FHLMerI2Kj45eb)m%6g~zyhimQ7#QD8*!cSa9K zUaZ$I-D^#vr`g+qo1ef%7)Ru3_lA2-gpm3p2~9OM_7dQ?n>BhoW@-sFo}_Ik28Z*= zjA3dlC+VW=BeG+3alRIZyrF?EHPPt%}%7t7}&gbllG6*uhd?96*EqULPJUntl z&M(N3cqzUg!zxqO4lOJ?x)*%YLFQEa*mZ{LoiZFBbKC>im9u5Llv#o|9W!49d*VNs zJ@IF&1a{=f@M6VP`G{P*5Qg{1`UC3C^sO{JQleKb$JPQ-!4`jeJNDe<)ZiQ6o=W$A z^;T58x%U2+N+fJcmGz+p73qJfJOi_z|F>;D@m%L#JC!{X4(S>0y7|{!&sz&3y7ai82SksC?cLT5{X$F zAXowM)yBfU;5vP^!j4osF9(eU?S##UdM>Zyyz4X{la=8E2aq`HI?{2Op}Onr&gFAT zuADt<6%<76OtFMgDoEurHll|?{h{OXmiqoxG8Z24ufP{`eJp(bqwk09`MV#nHw=3i z`_G3f?7g!I7;v*MY~$hw&>zMx?#<{*^gCe*4c!RW=`#uP*#(D}v#?cgxKGW-_@ovw z;i$g;=?P)Vkc{a%9?b6;s91$UzA!xMIzC7ZOCu`>Yh@bXB?{CM?{b}%V^{(Ces&=K z#sh&kI%)@U5b7q}Wz`pc1y;`GOLOTI65rmodkZ3hNJfzJI>(vn%N!p@`t?=Pc0RoL z{)g~cSN)$;7^rSTCjt$F79MX1TFBN1&AerJ(8r;LStMgsf?AH;hy+Q{P+f^d2v!_9v&(^Qd0b#o^dA?Yw F{0CndF9`qu literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-IF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c1f684344547ad1a5091e1e770d68b47ae8244c9 GIT binary patch literal 3020 zcmb_eYitx%6uvXtZOisSI~2C1SjHA&T%9K6S!x0f%Pef!?v&kGUcr=Qcj^pGckAwK zNuy$0pV1-E^2l5PjWH%h|B%(hAfzOkkeH}3CYoqW3_tv#KTM6kj3jvOy}Qs-D29;D zopaAQ_kQO)=bpVYlgPU_7!iZnp<&a~b7Hn&4;O54Fq;$e*+MR*i-TYnpAV`r<;5Lx zaA)UJUB37%Pb#M;Z9Oe&1wEfmjy@@NZ4%|-oN2+NyBpLEJ?qx>tX<#f3(4^aL%Z*u zjXi6-de*J&^xeF0mTSl&gi`1#5sMINKpx~yISm0#iEC0Q98sjG+@}QGN!O`{T%<%? ziMdYW8qv-UOO`&OTO^&KJmL^?Pde41L^P;{)u?-l8{=x-6HZ+?D)mEZ@^%IB)g=^y z&bdzIMrnf-4xtNYeG>>(EFmO5H!k;bmon(NE4}=lw&jhS*S!2JLc&B<6K7nSj>3Fq za_8~rmk3Q7uSI)#t`24w{d+{Rn~Z9NY7x3>rrK#%Wxy}WfK?9%kV};Tt4Y*p@)!`V z9*)+Z0*(_f2-V{Hl3~oC>Z-%4FlWI#Wy6>;X^fd;2Kmj(7$8-FY@OVBLKSG%udBlU zPMb$%mUSh9lq?B4Wz~*bZC33}v6HElV}?~ZQ)~mqQx-pNwOB1P=c%&m9^@YUIQU&< zUNsNrIQZYnfVJj%R(xm-Xz90RDww6i0Z21QS%THSg*LW7=MV=st(OK6l=D_Fq8v-=lPB$CRi0H>nAoyu&<0L5m65+60jwF;gQ44q} z5jnh!h=WXfhG}u8^)oHN&>v&yeu~chM2*~!)W}_9MwuBmGh-(;qI1-UTxvvb;HF+I zY{yGB;-)T$?D-vNd1)<)b{*a#l~Gct2vL8)%|sNTCZ3S0-g*y_HwbZjgjK;5H)qn6H=ld<@-7VYz>pxI&HGr%d~hi4JC5&a@gT(7zM~{Y5d+ zpG^G0jK4DRGZWu2@eNz@6>dF-{Uf;fFm9Hxe>HAy!OgTMk?TBe>v>xoPTGc;$=afw zJfdgBqshEzX2ii{%D!zSmAv6PD>bsA{g~Vie)xDv)0N~ahS-j+Cd5o8W#DBy+=bqxBifzG|B5R6tN3%!5ni7*Eaa==|L38X%sG34+;yK_tPf*Sy zNee!T#Jp}32H}vH%;{p@HZ6;kb|IGm{1H8uv_wXMV1L3wyh=8=u@*>?c`IvxHS@7MT<1}W zohb|*(sOw+nMsTJ(V;_G3+9lDohuOb{7MSVU7rWReeXK0ccWKAgw5QyZ1dp42f__3 zSQ;)oKXy;Kb&eX)FsUR|JtnAnB}LueY?B$!}Ad%>h^LK^DO*ze&>+NK-( zBa?mpeZTkP`+eVi{zfG2rbt|mF&>@i+_N%bxV^7swJsjQl#?nQhg|8CR5?oSlkR-M#2o0 zN6Mut$R*s7G@Wv3!4|!k?+fQLcVu#y&Y^-NOH%n*sj9WZilkz;RX!mP$+hL9rMj3E zZim#2HdFFdRjiEfHoPsI>S{M5M$(j?7_A?cq^d(0$`9NZcFE88$}3;o4_Lc=avgXb zTh_S&gTMz2)k@N2wmU>sucWG!yi}`l+aQAD*|AmLU=a;QvR|&iA@_v)ocwX6Bp|tV zX1J^}9LYXBJ!1J+XN1Bt!~aQj1hV3oHcpS$OpliEXe9fPH(-Z*0fjG33=|UL)Uhl8 zm-EydVelXWR$7mtf%L?uic0^4N_t}JD&ngua539_*lMiDDaQwDCjIQcs(7;J1|*$= z6wZlf#=$J<aac&y!FJ8k{&rI8# zSy%Ua*6VV^yr8njI@}#wW(T1PBW}qKLMPyQn!sJSo%YJ{Hjeu- zB*XJS1p=5F-^e0*?hTXz`=!g7`gCFjqgED`$d(Skk!aa=dGKgK*N@RFE1ooM5pK_ z?@jxsCkDosUhL&N;?`&DCEvpGsnV)Y#I{;ucy0+t4XY(?I^pIRP^`9O$Twe9`-1S) zz*7s)Jb3EhsfMQt9t|E94owR}5hE3eh8;82;lQCMLZ>EwvMZS~6FzyiM9L0{dCDSD ztt^IvQZQsXj_ri)j#PU`Dx@p{h1!r|b%lwZ3<+6T3UW1YHggg&%ZP_#cBouhcy+^t zhp|PfBncIdVB7FSl?E+;tL-F=6r%eul1PW+nASN*JRu`50ldXC#lUkJyBG72y&Q@a zxFxYC9!rv`C1`n%5$`aQ$PS352vo5QK;S{K2*G_~F@mC4f}jyJ0?CvErEN!C7Rv$n z^Caufk*xm~lGT1iJZ+SC+6m%mhnZKy#5y9XXNjo3PX5(b$-nv(iKtJq$PpH~l8GCb zxSWW}86qlUL{z@U#11ApOl&5i?<|Gn`#of_AYtq_!w$5Iod_pWM#_Xld_M%v65=#F zw$TCwOaap|jRbN}0=KpmI?Fo}BXJ)PgAu#E3p&SWNg2&?vUDYo=aZ$Vk&K3?=_=6c zh;BHJ(FGRdH-Y3Q3~MUAN0CeKQsmMb6uDFummu#^vEp8_vQMn)5tr^2Yi<&&k$M__ zsv=-Tqh3SoIylYyEo_=NqF0H_5G;iL&{CbTh&la_0MGKsnhz}1w%e29azy8$WT#_W zZH#08Yet(9vj`9T3vnmb7ELjJ7F#PGgF4z+s=z;huQVGDb3YIpkoac??*UJ>>~@ox z?}&}ad;_S}o$z<#951hl^~icfY(nrd3%(>mh z9hv*72!TBeZeU(LXavnYrqh**LRXt{Pq#)~g-RN_X|-)~-$jx5Z(y*RMV7Ki5Y+vUo@H_k{Q)4T z_HLtM5Vx#A(hhe<4W0tOBsPN!?PGzvhW3%zir_=Cru|JcAof0kcNx6RydQ~1KL^^5bV6d(>QnSlS$6os;#^%_`V9fRd;(?_BC{tgbS zBT>UKBCyGW5#O)HjR;-_^R*Z5HD{Rjl-P+P0z~{XTg?b~SE0As$+_=-mMyUC?ZQBn zZcqtS{+uHoW$sSqZWj?GHi+vHtYPAECN5xNH7;5R7xp1cS^kiOGa z-OCC^mdvsUcZzH=uZ4L{%-c+JAg^ZPQYO|gQKj-pKcy*@CTZ@ZGYlT5s!7Kv329hF z?iS4jas5HjvRiD~D$FgSb)(q0UbL+gH(mp&RNY)Itt@5=MZM_a4NyOh5Ut$Ypvazb zX-x`gYwt1E>Ic$rP1K`jd-;Y3Y4>~v#a5P2_{0Wr1&jl4l}pNjd>)725W5i^Ek6!? zDD>(GbY{v7U+`jw-PUxBcv8$mF=+hHb=WDBQVa~0OP5hled(gB_vRtQ^zE5m{myh@ z216%zix>d^qob0V)9R&isT$5dR!5@Qbl}BOIfmc}rS7DNL>$9TkR!iaE^Q!3ccgQ0 z%cU2J=|R1aDdJ^WA={JD^9S_eU|*&?UC5w`9`dI>Im?oEv|L(GmU8*-G+av!^mZ4s z`QCyKma{!{>vnr)5O1r%j`j%KF)@@@fp1)G$!weca_MrincfcZ;PkT`18_K`vLO*GgfwgX9hW|l$qv}dq8-Rl`E3?AB_&lU7^Zx5v3pY1(ZKue*&gG!Lp}=YAH5cwm zan8}mE;8bi$|n?`q5?&}9|~aTe1=5)E-`?hk3ojP%?x%O!ARtt47M@|5s*HZ6_@lj j9H%L*0%ihDgi&B=q~D5IibGg-67uH*%%E%+C+Wufv67}O-MA+Clh1#%?D%fo_lv`OGzPwZ0?+U z&bjxT@7#0t+*?4^FUJx>EIU47*+x#t=G}?BD;&<|1Sgx%r48XQkqf6{iYmReON{OA z+umQR&C{fFM#?qD1U+v!W2uw9LjN{FoXA-=nQYxk*v$i*HVtfizOQyr)Dq0vL-%YM z*tl_^zrU~c?)58Na~2_#MzcVcBh-un$iL_{M|4Tkql58;6qUshDdHD=FGymECN)X* zy_OAvo1KW-#&N@jaK;_PA>?21f`dsprpFc8zr;;(_5OLUAudPvkkG^-3Gu@}+rmn7ffdZ`>N@M?2TFaMjk$BM5~~*R*oxjTxED zONHGZ$X_E=Fwe-tJl8;G)8SD8cEboFRFBZCmF}jIRSbSrFfAR94^mS z&^45SQIOQ*+jf)PR4NXXnYH%XQt{a`v(8>uDt0iOWL?4ZD)V&}kPBcwenNPyg0Sw% zB!vI9Vz9mv>m}1%^FB)jsS;A-ptw!qlN%qbdP1=U&Q_q*QYa=A1}y~ZK*%Z;cPj9G zfr`!%d_>JqmWn+r>&14eJY!cAogKErrOQglt}a29u;08|dHf_)1uH-s7Xp2k0G%~S z&9*Bc@?A;MykmzCgbL<+3i(VuLej{_RS)`K7R+X=8S#z&Wv?R=Q{!G#y{aV=6ZP1xs4D46mGqhzZC1;)eVQ(f z@Z91Rx)Q;4fhN2>&`kPMV?R0 z!L5YwUr-_c85Qy$GvO(6bTzMy>`lZqaLT_481{;Zq@)3R5U&KXAFl$^%Pc&@EUcy$ zxI0wH{X&J@w@kQ=2{$w0dMZTMs1W&7h|b~GVH_I5E4JX)^~8GM8{)c}o)>Vp$VISB zhQmkzJB{0b#BdnMcE&x&NRS*xU{F!+-7j!6z%san0y{(%uOS@&ABI!r|H17*u2M_< zMQVaS!$_X#a%|-*jEpj26WdTjS91R{GDC&j=ZyP=k#;5wF)ly}Vs6o2)EN4ckvoih z&&X}uK8eG}aobVc7RBKn+_oCGbwMC^e6Pzj99Nh~xu%fGx`LZJW@LmDDQAv@g+Ke= zQ#vf{o)o)`cmn723%2fz6P@DcW{}N9QuQR4f zqAo@6tF%O1msByK;W}7Gvi4F^(IpynV4v^xQmDsMHhFLej^P3Tc0u!XS`*|^ z#4v#EPnnBJ*xNymn@_{Mo#lA=A+9$qcHQH9Pt!p2)Nv+1e#pot!$=@8fs|0Fo&od5+LfMh|tW^h|rBC5uuM3AwnPe-fD{IL^gL!IAUas rT*`&x03q>=F5pge;kFoQt8|NFjYGoIDaUYL#GTy2W$5ajyLbNwFW5$D literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-WHEN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-WHEN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..74efc0cf69f913e0dafccb88036a4553c374d0e9 GIT binary patch literal 2929 zcmb_eU2GIp6uvXl(*Jh56k6J*4h8zKVX9DmN+mJFGNoI#GdMd-1r@U0PMyK&PTiRW zi4htSg~Tzi6mYJHFUBWh0!@q}N{z+`5~J}!BMFHn8ee>{FZx7+=ib|umXe}`?A|%| zoOACv-}#w4w}{H0i6_OlJ3e7MW?pm){zSnS$K1T=xrKbz6vsd=z7p4T<<$W>zPtO$ z4b`c6nrz<8_~xi+6ijb4b9BA9VVfvVD#oauV-_2b-$cSGHVaqv$e0M zr?02CyZX+h3tYrS2xZX>Ayo)PkbuIoK_q4Jq#K* zioQD`Ip$&0A>oXBh(jnm6IAx6)wq$+)NqQM zEz`rt zD#HIp>CexPaFv?x4R0Ge}7Gl5^UUelta7aj}%HmVKBnlprb}Ad*poJ5LL+RbjmhdhiON$k4Chp1@4d%e zgMbh&BZpi&Ik$cVOUwE-eMmM4`wQ_JPwTp(&O1agM|9tTuIX;TaXF_op+fFs#(ls@8xuwuCs2a^qE^r!jQq~X zO-8 z$;zL?;4y=&>^vrSienkL8H|c{j(yaL?ASW8?Dz#FSP>KkWojasgtKg}56O(^?eJna z#Y6f!;<_RmigZt}B@>3C%gGe3AYfQ!(crHdpP63jYITIpCIsj+i@rZ z7Z}eTHAQz!JYtzS;%_hR0K)$Wu;7Ib1Hn*~MX2~MC@Q=feBw@4jw@lXnmWsjz#YhU zAw!-gju#x?o&W)ZKumwgJRB!`+iAY}Q8I61Mc%!%=go^fcZGpSJ?GqXMMqdy62Ub78QSWeIvk94Xk& zD9ig;-W`XmmGT97L1%D>zR*HE3|7(IgXLx<1WQFG~BO4p|usNJ9f9U z>~7w^wKCv~hq<&H^6cE*+_JlI+t$jt^HV}imJrfI3J59)sUZ?E#`84|2{oSZ27+PL z8}&uh2IGv8x5HSx$+#Lb@~fJZTz1H-ryoe`IGlkIA`oJn&f5dYs6P?ZqQ-=9T&OZm z<*S2HZ#N9h*P#;8UX+5;1tY(5r+23}rY4fHs5cPPBINv3?HD0;eUOlipI|z@l)2a? zTo@$ZyVND#+vHv)Sanes=VrF+PTe^-b4P#wJ2RUI#5C;-Em>9zN^m;&sCR1s3>@7YnRkFd|w z$DRRE`U-u;+)Qg`JTu*Nn2FZKt3^0BsB0c3yF(bXj7va%HBc1S?(^-9>b$1T9<^+$Mh8 z0{&V7utoB<3ur`g?9HEFNjC?x0_QVx&;{@S3EpwC=pgg@+b7_u@ z8=Qwx9>K|&&4z(4IIeXs&}EC@KZbGp>0~-~??Ju&NXnnxe~dhH3Rj zG>-`M(^vW21Q@>p{2pK!*OXIGI=HEzZ5r1$eNl5wZxpb_(_C|=|9Iwc&7-;8IKzqv zJru37cmYGB%Zw|oVq9^3;J9MBVvcY%dX4UcVIF20=+)QWo%s+mgR!qN2eUR4y5=N>!?+(Kfs=%sqN5O+<+J#Kd%fX)YJb%1(uMti%Ob!> z7d40D{G!^t^W1p2OLq*01ABx03z-@sx{R~=4Gn%R+8)Hr#oOtNwujZ2w=D>mXh*z3 zTuUp&I(XJVYUJdpkw2{ZqRDP=K#N7<4O9@F&|VAAYIq#*RKl|Yo@#h1;IYGFg~tLi zRyFv234f=V`gHqQer1jCk0;cKD3ntqv<6xwt)mr^8&WDqgBpuzF|U?PbSD!H(t2R1 zYVbw(dl??pG4iV$8?VpN)=7j=88fp0W?6k8N>=ajg|V^^DpnkfFM-u0>fletVrsM` z4Wt6LsnF(JFqhvKS9!;@3Yu+iP$z=d=o$o9XdQxnj_l*edpObyhOdpQiGVla^T#x= znL8rGt37?gqGjZ4?&ydtE|oPIBT;!!rJ7w z8B+ceL&{e((v1inqY8qf9Qgo84j@NZjdmnDv2iz(D(&P_>zP#XuZ&Ur17j55V2t7gj{FWs zev>1gqPKt)G0UWgI+G$EU{Zvq7*cqWA%#;MnPTk1eT-e$%WF~8i4PZ~30pYht(>uz zF_KdZN%C~f=V@IRGN^l#zHoOdaM(W$bxU_l>xg1)H(iII5l$f1C^|9o=}mMqU~S)H zjkXtf?HLZbII@k`nmK3y&t92+Xec$<>rMDN+O+oljq@iTJhPyZ zt=~qs#z0Z~UL)_xrAKnga5^_SJm~Ek&JHO3gGw&-nM2v$qm4=2D~AdR?VIOp~{BQK8Ru(aBkkgJ`nYUHK9;WQ%cC+|l9u}~I7iB)XZro7Y51DON%x_z*+%YvNZz6UN{_@wK@u8HY>?o2+fMV3_GO2 zHhl#)8;Mqm0(F2Y5bb1GNGu>56QYr~1R?szp+yZRgacF&YQRKtN7MEl$K`#XDH<#o zr}Z%RQdCPoRq(NzHJXgHsj=26QrkHzqQ;mLbk54K!_^Rj$=C(wb3CBi{9!GgjH$Q_ zh$}%xO%%4gu;%xLi`x;cva{F}#kki*1T+%8lio$|rXMF;ro>NzRp3Cbzt}m82}9;m z=H;%_4^KCB37BX)c&0qAIr5qVv~hQ$A*bChhbJS^EtgJ2Gwx4a>=Iv^{@IwV8Vm$l z9`2mAI|@u!Q8dki<8FnsH=%9pD&bz*F5t#!i6@eQ0IesamhO;RK+_t(7U_nIigs^t zXq#wA0DQ%P?nJCJ8SUB*Q*C?OIEO|a&wKna6(YI!x(zH0#*g{Jaasjr^mgX9w%^>y zCAXpItCWGS8xz$=-qxEPOe?qC0uGmJg1O8!Zo}d(e6`|hC%(4hs|8=p_(IRNot?tn zRdAt0bvg;Z{>U)j6U)2|y>YSME#-;V(^QvnRh3~JWtf^W%<3|XvkX&LhH;f)++~;z zWf%{xC)oi@2dBSwapr`VMvxg9dF7Cv?Kz@!G&Q$iG$_w~AoVG_5+N(m&hivt>k_

te5b}>H;=%QHy%6ToC4yRU^%VuVi-OQK zn2sJblKd^?(DM9_ zQvPjA@;8(2d4pAzkT;il9yi$C%Xj1{UbotHY0iC4v=We zu~1IKC4u^ok@uG64tUKzkm?!ED!u8x{z1G(=Q*9XLqj?D8TqZd+f+F8sQeC_UCc8v zEV(eVievF&p0O3VHcm0WdlO^pzLIFw=@enBBL&#A*p>%ykLW%Ek->2Rc1&0l@P;3T ziv_@O@D9Q~0LwMl1;IiIt_!gB#SGhOL#M~OrV}AS$Sj0*=r{-@Awd*F;(08Ig1`kl z1~urISJ+J>+`qWpm%1jyku4WbL^AFJFNMSxr=JaiM7)@oe=q`W&{G44dQ(fsQ|qGC zrRu{UE*`WX`8M*kW>t;e6O3um2%I8ibcXL@-WpTelYTr(k>{y$3t~FdD4gHcQN)eo zA(A`|=oKYj1`ubk_6aPWgiNL~7=`mXq%G_iaRlXreQjzu9-+5~V5^W|wrPC_;N<|E zb)vyDJI$0|xdjSPu=iWx;R@rSdHaB7(^F1eX2Dc-nx30kkG?VSqhO2n;+y$bHZ^b9dAs zf%K>IQkS})<6wk-Uwdp1t8va|VdqmhwF6^19Mb`{M*&Sr=>8^oW z5J*3}eX+PI!q!++3N|}A;R}Z4HOyq~!9bvf$sDf$L`6i!q|+M=$kYuRBPiiZz$Y9c zq3XwJ$aY;C)&zK)gKK=YXl`!+k8ieWt~om`{oBabckAiYNLqnZsveI6eEBNJeCUcP zg{@Hh=mf0RUzf0cqbx93&l-96l7Rt_jtwZ_49niE5DY3(Bfa-OnEvcTJ&3;-=Au}{ zoE#but3eUSum~wM93IBz;17pvy|uh|ICiXCws+*IVVzrEzpiu3ujf0r{9?Xy%PaGp zTYkVgm$75ZQ)L}nCSdh0*>Ss;2u9R6vYldm%YQH9mftk;>zCm+uO?pO%+G)tcAJC| zQ9c6sFQIqCq7vF@y@aqGjwb+AT5m%L%Mn2*t;dxm_X4vliJ0}uw;K~yIEl#?E7mH@ zbdugP@~&lc!fBNL%@mS;1WIr@HhV=iHcS{37KXt}Te)CJz}GG#7&$)5n0G0A49_PevEF&spvn3HVHB`gg^p`KS)SJ{R4=|yze=7 z?8Tj!P!b=%=REJ%^PY3=IoC@>`f5C>#BAX2rG-niJ!7R*7Ek3Lqd{T+c=QB2Ro_GR=j}HzE3_f;f zf5&hvon+Der_W(<7#ujbzoT~J8rPj8giMn)6n;Xwi9np?Qg_5q(?)bSkyN8vY)p+f zOHRoLwL~Y&wm>*SoR>s;oX_3qaR>Am0$an{YM2K|qhj(<)O&GyCnruPA8a^~{<QLsFMS?iO5>(Kb$mWdJ6 z#>52Xs@9~urrCkos%3@B`*ax=!Io++?LfcWr^}iZf}MtTr`N0HbymfJIRLDxE`zV5 zvDGUFHC?90fS+CmgYuv2MQji8jRx_q&p;g6wvcZS-`{j?sdB6FU$&FCxZdF1VbKZ4 z;FIAsYqEb$4=?NCi#YiYa5(IT=TGmq#oEjDNxh_pd9W>i#O8gN`u2lw7>t+o{wvU% zRMvE5Sy#TJ%jMl1YQm3oFTnxwvL4pu5G;h=&qMU`2km8{Qf6n%6%Ozd@%%_WV zzEN8b?g%?roum2fz{Z`*{kp7&aUb9|*|_u41zoi<81J&TPw>Vw?b z+P39}Q(V5=@xNqsXSxaB=Ugp?BXM0DO5i;e9gS&2Ni`KcngB!_Nk{lz*U$Gr>wwk; zEdb3A%?Hg3O@b!ECD{{+$Bg)B{Q`@Q$LTHUNk5Y|)G?lGw=ndG+bINHzpw)?#(N@a zDy65Q`h+n)VMGKO9J(Sg?U^XW(-9YL$limGY`tlN0wJ!5_v-*&m}v;*8P-!{F$0I= zm^MCEIFa3qjgMRnFN+eV3~xg zSX^v;T-AoaPq^gDC@#7?QCRNhP@H7o2?lEDkyN!2V-%JBl#Z~A(h)i-9sVQg$iGh= z`S++J{{{npz`)lSc-6fRqVOh-!k?m1_!N!8B`L@yD9Am@z;5c!bx?PX&=J`{POMyr zMn0sDpzkF%y^F`w{#S(;Z^qLsW>X6cjJB(YL7(SQLRp5m*#~qn7-?s0sgfCPo?f z6*d~6f;&J#?(=N4iwg2{3X(D#{m2a;c6S|c!+YKE5v(KWly(%&LQ%<^#fAJC`er&4OH%VF}6pUoq|{886^Wo_|A;jiw~mNeNM?gRhaq4bLO|cIgLQCQxfXk zd!P#nL<7(TGwc#)MdbJkHTV-?Ed9xO#aZFu;pmU2RM_~@Ezd|YVW_ECGVOMv8LZAz z6S|?&%A^mRQt)mSVBGiI-6(EsAt+tjBq%L!5|qBbNl>~-35t~5DN4?L5K_DQSkAOl z+PO97kZvT#)HLSPXq)8;9{FU0Pxiv zk)!UQfO5zkM4`HaUX&wjIO-1iFu(x_CJH$qr{ ziiuRFikaLQB{vIX3P2I5%q&a;!3=z|S#u@>9`<6B>uf%krS7Nf-1KQ+OnyZflk4!* c$equAlF-;)9v`-Tk0jjP+$W96^<1s?UvTr2f&c&j literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-1-LOOP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-1-LOOP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..22a10022059c9cad9e4b9ba2c18b682b60c368ba GIT binary patch literal 4914 zcmcIoeN0=|6@T}>XJZIB#(6;Me7(_xE-ucRgcbtp65~8D!T3?zgk);Pm~mn!#%9Je zs;X8b%|4_)5r|d#?y5}tW16)8EV@m~n#rp+siK;cKlZ6g)wEXaKK_`Hs(ol%m7R01 z4R#zYRkKOHKKGt`?zzA7anHT>iex(z2x)=r>|83H$Z6Sy{M{;i0Cf_{ejU#1BaWURWtEiVmhCg(P9gU`I+hGy0yc{H2+*Km4;4V9}J)9@9F73 z`uL%yA%8R^wB2`2Z~xIJ`j7M+YPxe{mAJB!B*mo?l152#NwQ>JH(lPC9*y~iMnbwT z>>ty;){131z!u*`RF7C@>k%!Vo%5v=&nD7n&g{HIB*|Jf9YYi0Ky1VaTLrR6nyqVQ z%ShNa4yO5sb%{F4T2MQ&%$8nXpYO0QWEkVpjaBCrNwOcyNYcJ9ayV}!Z;g_h8Oi+d zD4qPQrbxrV)7R7+*cYrBzbenSu&h3+*k=+Gn_w_q?P2? z4d*B&Ezm7?OnPxCHislNOHwHn@2=j8L@HZ3lAsC&r`&?5CBwbeVYtauJM<{9jdsK7 z0jZZ@zstq>ae=Y7bRK7%|Q=p=}r1(BeZM<3*MjL9a07*2I zTcMV%P(QI1w54K2GlDtwvFhM9K&PeBX)b~Oi|A_;Ah-f%+ToIDCniW$;w z@O4W#kFB!uw|v2?<%RX;Jy>$dxr%u_M<5zXB^vg7M1x}iUn{&*n;#Ddr(Ld8WF{nd<(;nX3Gtf`pf$@>v7Vh@Sh&`AKZRrZ|RxA`30r^Ed-|n>XQNeH* zcNlKrI>UYOmoQoU1LEwhREO@g-B3STe#uZlvg~9-1xdA3{4j0*zf}f%xB}aqguM`U zIRgNB!v>bN_JYw~Y=fa=W2&oUbX_;PuEMBsqhc06Iu*0thE;2Wm6Hbck)y5^D9ZOf za90fH<>I?MAfM`xT~8L%?YguS~D~UG&?jKTz#$HfIk)p`XYL4A_7-efZu)g=-FsYAETsRB4&8m zHd$qjavNNCPOlz`7!jW_5gVU~dF6Ik(Cqbx&-yq&>Sb{6wH~|s`c!2}VhUcG`|uX@ zfhPNq5gGHxaOlNd0~3*m9ijjvC`ggv7evi-5Zwuy%Aibbm9`r}JYTARN zAwz6L-sTI)n_QBt3Gy;mMxJMT00c>iky}VMauMmDg52aH((7zbh;;pU|vkDZ1 z_XZ-mKc@TcO5e~(Opo|OQML`mAnH#|7%`n2YztVXb}u_FB@>x$Z6T9R%+KQ<$C-x2 zVHFxV#4=3fcUD2E^k3sRSQqTV9^vX0(=vN%)#noVgLQDVSBd+?O}L>h1lOq(-YW3!fU<>N z+fiF|h9bro6cx+##HaJ|BznKDVo=BhI0FrVkP)4T=;(d;n92c2XzB!=Z6jfDW7r?^ z#exxI(kIR$+qR9h5t;3hB*ffRg-NQy#2&xz=B!uj$@-v{4%BGfzAD+V%)2DZY=AX9lz z=z>l1KUO6f?gPt|W4c~H{a#(vso!wKGWXYRC~|9dA)Qan!B0Y-Wb=nmnJz%M0ff+r7={D} z$SfS4qF49w8bI%?(l4BVA5YKxD7bE4DYk)w#Ya4LG4)`Aya8V{__1m)jRw~h z5A>8$@izY$iWZ7Qc4{Y$lr=m$7D z%_i9yu#w)ba}oWCWqNB}R6dE9Qu(BI4@c2k+)?zaR-t8SW+}e(<)vxiu+31=7r;YH zk1qLe&pAQTOON6xwCUb0=|Gh~Rj3jw~ne&!un@?tQc{on#R6Y+0VwvP_>&OkubP9Q1B4His zE3A^wowylXZ(hb9N_Z@j9ufX#0?E;g;cqUT3a&da{Ekxb*HDx0bN=DAQWbX6$_9vo z?IKXI?gD@Zl3cC#E%{0rRm=EY^+6eKf_i{i~#jUpFb?!TU#* zVpQ=F3Ln--8X>CuqG+hy(+-G~06h0x0b^_&{vtZ*D_=r5(a8|-Dtys@ZFb4Et?sPo X5>U|i^mr^1oCuHheiIj2ckcWLqkxoo literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DO.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DO.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f3046468d929cdda08801e35601d68c51a51ced7 GIT binary patch literal 3717 zcmb_eZ){sv6~FgAyGfHYb)B|roiu$*yB2wMOSY9X?FZ&MFO3uDz07`D*#H&KdG34E zv4j1bYD|=@grSbNG)_wNF8lL=KSKL}WO@72KcoVL#)qPUsKkITuu4T5LR6ZNKpHCN z+*_wf4I6^Wx<2=wbMEh)d+s^s-3sx4CYDfQg~=&9XBL%0*_kRkO14l`N`-PUV=7tT zD=)am zs2cVvp4$v(iHxVzq~~sWOmPZRk(@bg=I}U^B|-`D=H2GOaV=)Vbaml(oOfTlin^%UV}75KMQc`*maBiSSTpvFC4QG-TkvetHfmj5)?j|S zGV+S{Q$i}%OWLqRH^8j=(D6NpfTNj^HbSo2nNRR|+;xOb)E#NEmQn3QfQwHAuj;}1 zS%9sE^dLp}Mfm$B%$N0`1mfx+ky$&)P1pA6f%)0I{I}{BJwS1DKmsH^sD+lRw}5|p zNkjB&4X&eB0Ff#q=k)-0{~LPXzxV&cy8j#QdJmSR`B%UTm|zg#;sFr7sovr))Ivz= zqm^rL!Hl&kr2nU1(rn$YRtumIAFr|6rSVvLaAGY4f^!;$f4tk97F?XpQ})^e^y5!; zKia^g$TEJ|2WLY5Zrwx+BJ;q}oczHe+(A9^f6e)>)#CTWa4BoV+@%`NRk7cf^WCmM zs;}01AJYUA=mGlv&${pJHkx~I$i7k?dE+TKQchad13CW(6>ScvbOTnWZUDdf=Umh6 zRaXD^O7?fu4F(!2Ie>lRM9)>dXF>1zx*o*k1&AipHq=RwhM-KbM(TB2y^f(?DcO(r z54zRXf7fa%R=^GrDd2s}?Fz?qZ6J>QGcpv_1`=vAax@Mc?N}--ZDi}Eb{H)%+F-Q8 z*Z`vmh98Cx8uzAfENaAtB1zR4PeS93@y@+2^-Ri8M*Vd!DjDhJtmxdWPYdss~- z^<+dJH^#<|u)G;Iw1uPEGZD^Dg&B11P5t*b|Da3=^I^+Zu#5i%kk$?A$O9MNOX@eL4|O z;lbzKmJCYwlfP4eGrmlQ}@!N@#dDeyG0NaLSuTbygME((H%5RI+_XWua=Cfio zBFIs|2VXk@L;3+%klx@D>AWB_pwN`i^)VxQOsEYAwIf2lPmmT+^C#oSh76(9jJPpA zr&ss}`WDxu-xFlFUF@?$}+Fw83QHX!;meN1JYCfoLTw*4u# zJ;b_uLFT*VxsN(#$x)swIF>S%E~axic$t(;$FcJ#m2`eWvGedSnl$ssz%B22?oI=@ z^qh(IDA_bT#864Rp^$gx5mbB2Ta>*E5>uFhWCz;;1kV;_oeQo!sO$WUz7k|VuLWzXGPE}0PUX%k|vOxW41S%hFK*>XOEj+UTjC?$9_qD#{PXqUI>qYzM68nU@} zt3xJtaXzX`AEhVV^cMY8l6`(qm44CSo3!k?3O{TnomU*ISU9bu#i8&$t`xG$L;<&6 z;!a8DJa?m&o;E=#Z^H{6p4}*&U80XZc@e+CmxjfguWOj{Px5Q<9l(hdf|nG$$}Uy^ z0PP%;p<`_`9!%<^&}=<7lu0`o3zMy(lR_huzNa%bks02R(OP&UT!fDMS1`m!>_}Uz&u~Z6UqaMVn7u9hhR|TK6@6B>3a>x^w*xdgCiGBr(Dcql}?r& zdn#u}Rx+4g=N9N|U}5h0x&FB?A=rW-b94Q;dU+17hkgz7M-kS(aG&+zM(amBxBEWp zSV)dpoV4@2un@FQm?z!^zfYDRQ-Mj|T#HV=18Yn_l)b#x(hK$IITnoqA&qR2Ly$cz{*h@Sfp_&ZVIy=s)2Ph4fw|TJ^6lw6cm4%ehFC)Y literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DOSTAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DOSTAR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..233946602c96775d70aefdd14d9fd42587b162f1 GIT binary patch literal 3727 zcmb_eYit}>6~1?7*LG~j*=!z7){ZlA(gtlahBir^hXmcM$MHJr8E1Fg5FQF!dp0v< zy=!)79hHjU1_Mf&I(`H*7g~Ps5b7VaTFQ^4=|+GM{0M@IAS(D%h*Sg!5mb=)Q54R( z*X#HJr4rU^_S}2Ux!-x*bI-lAB>3TYQi&JF#+{s1R0?HxyzDC3LQyFd%Eb{&$pT+_ zHg2S}&-BOQr@D_n)|_4@87W#B*BVvKvQ-+*Jaa&K?5GkOFFH9G9618hCypIDbnM{a z?&iK&Iw{cp=bD~l2YZekdZN4e{!0rqR3L@i6hx=K*V>~VQ6E=(jkFm{k(UR5fw6_1Jjx%eAoDh*h{+GRuXxz|y6WB`C{+QmI)Kcn+1aS0|>8P}cZIIgF zYlg2Cz83g4!q*625WWEP@XgV9%#8P|Da{;CK@X1eCf<-fn>MvUiLTW!jVNo8!)$}R z1^RYdR7<6dlxhr{L&IiN-U4*!>k~=7GNhQbV7S z8jP7Z{To`152sR^zU+2k6lHIMZ0m!dpJiJLZ0mkd3H%Dy z2YF&~b{lTe1|74O#OZ5nCz9_%f&#sUt}R{0c#WcDj&&e8$aWx!3iWnQUPg07*I;01{e zO$ea9{(OM4UA`yvJKQ(Own!f;b#Ok8q<7Pk?)vjVD#?K$s7gOuNmqPtlbxBcKr8RSdmSF(D4klMk3M-FZ{r&S;`P@t zK>6kTB3uYKup{uMg7?{t%A3&9vDEn055n8!mpR(757oTV;R8~r&4r!NBd^fS{(r$2?@bAn7yAH~`8)3`PCb67l! z)<3bz`oLQ2$9=DJm32Hru2md!^88F8Xpb;Y{An zeQz7L;@WU7oG}Ov>c5=LUSxX@FN5h^pv_NShZ1r`{Xpd~IPLFJA`*C4FACy`x!f literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOLIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOLIST.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d5b0273a451c40988b2f129f1e5a215518123ef2 GIT binary patch literal 4649 zcmcIoeQaA-6~FiSJ-Z*N=Qybw(l&Vw?Ix_c>qpkFAvV`>nh(b>^T$fJj^aA6d)C|} z@<&HDR;69ZwAHvx!n$`U71|JDAc5Tc0qO??!9c4hs-V*TfK3ek;U5G+6+%Lq$~oux zIZo4M6&h--d+#~to_o&ke7w_6GUbb*h#DF>Hk!%mId!C17%djmqa!&rKT^!4b@eFF z)fYorEc{YWFx0>0(QPZ@b)0lgPZjhbHBr>_L#eUN>b5;9HR@H*qxmjx171$lv5$Mt)z3~LQcz)$6#$10KW~}`wGU%#tt)E{W z=DDBtO9why8@UtBJnWt|4tr)b_mt-TI_wU6XEpDX<~^A?!-+0|MCC7UU1EPCaSw>Q zXEo21<^gf{0&%2EaEZi!bhq|$o%U0jr(XS^r;N&1(TtkzlLqi>`u-05L(eky9O`t> z4BoB!q;VRJ&CGNzuyI=RR94p+Iia~Hjd66WruqGG!}@a#)O%04eB8KKvDr-e!Fqrln{0qrp*!dnS>=VT&jR->><+ig zYAsV*%gbQoT8we*FyEBs z1D)QxbYdt`r?;xpC&4q7Tj(0Z^Jg`s?2@IFy}h)d?j;N*`(|{FN?>m0DbNT(iy;|* z#!5)F|Jm9%s;1h(S{yR)(qo6rQw^EtzC$LzV25mlorOyyF&{Drl~41u63kY}2noRV zC-eCJ0JK8T*qfyFV__hCDQK7gRjt*a;mx_3FIo8Bn2Cc%z_)*CGv@>LF=oC|)i)39 zr&kBc6&qBy(f3iaWL1IPZl*PNr3sv%#E0}f-FIE8Y^0Xsfo&_@&^%fB_BYT+C_rjN z@8SXKfC&(?_h*bD5(hv|5FmApgqjo<7rb$@vVlt9J^ujJ`MFoBee0$HDju~p&upF7 zyAhJ>IqapVznS$lOH`3_rY&qE`03&2YOwKp0P(ZFD%FOfx$l7=t2}7q#}GdTHIbD+ zx_$068f_!^Ya6xi_g$ybL^Lmur)(CJw7fKgTWtvKHwZ#Ij9;@lXARMxR}r;dsv^o} z0p=wTwS@lE80dO$3f-0)igzg6&a!cT#bq|qM=CPF=dSU8c4!AKFJnZy}C7*B);B)(W8q4~v1 zN26Ho@WL44_J?CJEf&y{iNR#T?`VPx4gO&CV1Vdxzkqq9ap&D*O{0S`A>%N!24|C- zpvl>-#Rh^2Jl?=pL&;by9IYFc1V`Rg;5E-X8Vbh4)>DF}oN)lcb!gy8oP1FHCDi<6 zFp><%@wiW{#^o{LgT?tD;l<_Oq6wG3ie^}pw~45Hmx#*iM3fC8$~qC{BoQ4=M09wF z=wL*YUd0E4gM;B{7ii;OCK>(=$?yTuydJ2o3J56#5T3pV1D-RA-be6giqGKkd2p16 zY6BvUc1YfX0arxR1{1;kmRMe_L$M(=;EAM` z2*XKvjqWNZ>5`JOmR`}0ybW|g?jsR7NIZEvEz-Y;DE-YkePAuWK%=_oHK`f*-Lwar z(Llb3q`03J_8ZY21gh&@v(#G9^941h7mB%I^;ofx8O`c} zhk7&x1OAYj8MbC~q@CD=V&}|hhvIbM_8@G_Un!53U%*ogPNGe$CwE*e=Co{`#0KO_ z<^^+F0&Cksv2ZXE4&0Stk={f&7L3HjN)Qt&x#GNSmQ*tO`Aor3i^EwxpWm#eQ+a)} zS{NJEaR zwE%KDRY)6%+oF)(OezjRCd+FDgSdJobm^7RjJ}B|E>-~8A_=J zu3TDxr#!j{PZ=KnET#GJR4y}8%&WMjj=(>#G0F3oOxaAn02ay55U_Fw7-p87`9dx; z{48v;nL;6}qaP^LT4TY<@gd2ghc&V4Mdbb-oGK5M)8!*&yz97L9>V1;l2brTTjvuK zRPv5ID1$BJ+l1sm!97Tj97wPv)-LkT(Ey!={5w+2WQV|Fawo4I8B>oIhtrrosA?Jc zCS6CEp($3gSUQcFw~o4qG>&`dF(5AG%4u9OU_i}$>0vyP-N zfDGzYKrM<65a#f1Eu4G;3k-_@ImRNF_(8L@np`Rvx|+`%gH}p?2|FoIk|S&mbj&{j z4E7!tE0!j^d7iJYPksD1_*G~&8LQLWM_$YD5PjfLXD4rgy!MKA4*3jEuonRb>+Q$_ zE7lX+wa_69r1RU*U_2phU=aT6q$^PEQNU0J1RDGr2mbOygNayAGTOiWn@B6&x$|FL CU5oty literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOTIMES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOTIMES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6624bf74bdd4840b8bf4f74d94ff1676045fca0d GIT binary patch literal 4759 zcmb_geQXow8GrB2cXkruI!^eQ3E`jwT8~3O+VZ8T7{`z}jxX~^fsGBBL8w+$-okM56YlCiWu=*O(8NK-XBO)6#D)csLutu$$EJ*AU6wHbTf z_wHhcqyuRPAJ6+fU+?q$-uHR#z04x^L@>e!bD7DsBIWs9QJpNR{Ae!E7jnh?u*8o7 zpMN$e#zN=%0>Ob@hxRnb8zjSdDWysye4;27Mp9Ed`8@~tz+^tHz+nG=m_BjvvBwVf zJie>>XdoUjz1`Dh-@%>(2X}+boh$Q{Cx;LkMpaCj5b_`f>6bN+KM{&2grohDkPrvl7uyHx%}VQZD7C3Mtud~Mc;WHW z-m2(TS{E0tS~!SafWuq;G3M4@1dLiCj#BykN(S^H-Vw`$Th)XkCY)vRglQsJCV^E= z0>mU>nmqV~nUbAwtBEvD*533Pr5SHta}Bon-v1Y?-7L!vPmD@*>cou zs9P{%aJ&fdR^`(hstPk9y4|OJaO66xVyEa^TzDDC1|P`8PB?R&)fus~RQ^ceFp_@} zH`u7Z1Lkw`HFQI9fYLa)5Pf1NHuqWPJ}~!zxeuE=u=z`M^A{}h(!_-5z0UwDG0VPk z46LDmpHw((tvGNJ@7+%rOwEqrtKr7AXP2_qDrN6|mohtN!~Kv96>Dv}b8(@vOLU7~ zA1Q4b|G)ao?0cjUy{$MQTrWXn^qd`V;s)ft`1ta0l(iqnd6j+k5xmAaQx9R1Q3GN5$A+ zAc3a}UNxAE#X`}BTb)5+*|$N~QBOD+h=*gHJ{JN(GfqoqAwV2QHnWCbmClyI} zCZ)hv2UZ=?wap2vy7jrhR(>=E-z+11I%|GzVBT}xSZ%jH$FQ6e51lYHHW{79MwmHo z>Oa%xXo$Eg7z+gwA>ppm7U@rfVu489Xu)c*Ti;BIi4Y0g`G&6XB+RpERpyIXMJg0_ z^24cuw3An-CM7(=Yg{+BU@{FAfbih#g(*xj^VH*quaCbP#+S#+_HZ9`=|0@0!#y7O zN|1jJO$YZ6*$209Pk7?itEF(M{4O*CT&V5KOZjL_9E4KUHQ#Vb9hNZ!E9wx+kb)!T z3`WFwG8Tex@K1Ae!>OQlfX}u4QOGtLhzNV8pj4%NCY?>G z>0EXvUo1%cSy{?r4^sq0?yx?$w8B1uBPYyLdrcf40URF&9BGUrT@5QtZFLZDV-St6 z-xDoEFhMeQQQM3?)JA}z%Y=bzZ^)JXqdvziWzODcNS3WMPNr65&W`I^H_3cBmE}ir zd;z{&^C^WdsPJ{2k+Nz5_Og&3!6%6wB_Oap`kb@Ap5yikuMWU_JMn5)(3xUd!G)np zWAL$mW{MvzW`{A#;MVaLaqBn_m0@n417L1g0M$Wf-fWaG=jRc3SYdB@kghcyN%lv2 zqshS@I2aUZ_~d+1Ct!|G3Uh8Av4;;YSKjkg%3~|CVovCquq-R9FN~x|N2NSqMar(g z=SKOZ4#6Zya`3L2V|0y5!E*+lVH}TpC6E40*XY3`Af-QE8odiA^+MzV?#lGdhH=GY z{mLX4!5e36ggTJE})TIH2oZnD6uvc%`p zW3tL;iCcO>&>!( zyN&_9CT%tv`F?8yztQ0bwb2H((PDH#FIXN114}v6@RIff#la!?gH5ks^&Sv#j~d^j VK-P3>C=u&RMhEu(^!s=2{1+B2^uquE literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPC.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPC.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..bdd731313ff0976ba08e24eaeeeb449e7a546f58 GIT binary patch literal 3433 zcmcInU2Ggz6~1?7*Ixhaj_svJ&ek0{B%q}e)rm{fP^664B{?m6e4d+xbs))nGC9ZATM<;9ixg=}74E)`cwMfv=4UM?(`@|moB z9(eg;#4xp|qiSUO(5J_`lWjAZd^TOo&dF9OTbN5f^`JcVsI0E!=NAARJqp859UC7% zcI4qh-BW5Z;d*;tn@5fvdGy%BM-O#x-?&btWkN`XG*EOAA`y`|>t!iyX-P|&iX}8f zS7)@aQ*p{Z*o%@%YNk`}KP(rQSCob9li3B_&SHU3LY%8*-&9JESTRF)s`N7Lb)GNx z#dKvBwx*uYh~R5_LGRQl_dTKN%;QS8|u<&kZz;fvPc38#4TS9BdfDbtCw!A>r^En$!k$VbkynU}{JL zSk~S|dh5Hdl7Ii7{C>OLuN$ZYi?18fvu>O(pu*ZtT(#fxi0bKFYm@I~RLQkj{Bb>3 z8~Xt2n2yUid^Ro+GO*e?Omnw3b-@3uOh2dpn2<{Dt9o3ZeSm61_9rkR{PPjgOGslr z6Xuz3o{jL)*4gxc3)BO<#)souJlXQyi;i0e?RePj1Y|B+! zt_|9w>-OkcQwuA1w|d)?b~k?ix`r!r-+L8yB`3{GMCf*|l|$i(p-;xJg(*>0pG;_` zG7$qtKamUzy{t>Sq+rC&P@2_W|eC6S1Vl0?@R__cm=m)C2Qis~*PQy991KrVMjNwQ%?ZSocR#rm5*| zp8`g4?kvm&cQX}HlbX9O>w#(U9hes3Q^2sNi*K^~QCxGy=Uj0Lk{wKH)|8SwGc#c% zl-8F6Rl^Je5~RxR@;z z<;C<$W*nJ}Q+~igX7rLeDxXiokCQohe#!k^f!rmG)8lul0u=y>Z#z}d=k*}`>kj!A zkb=m`Ujr09UY!30z>ZEI!XE+j3Rp+t#*S6psd{MB>}4oPZuA`h+@u0}o!sTufZ}UE z4S+NGmiC2~_F3@N=@Iz~=5_Q$RxNtd5;DF6mj$vckn66A;iSsrUm11;bI!>qIWZi6&G&TenUhL8-g|_I?kM%p{eGBQuFU+Me&G+0-kC#w>KVf4Il#dmg(URhmY<~f3L${)lNpl5YZ?pVQ zsfiT)%9@4kvwk+f23c^LMF=K33LMXMGtExbi`n)%RUenlqdDw+3$&nmMk1!BTAH%w zjwfQ4W~zxK>p?Xr@RKRS(%kah-(F8gaM1_YCqW2*Zi@%UzuPnZ*`Dza*-2D;1!9Cq z=p+j;(|wSBu}MdOw%iBlD@}R==u_^4^u;Ev0)5(jkY3rds_T?Zm~+N}dG_M|bWKRj4^H~fdN{+f55BI?3RN!|rChv299 z!UnKA+JX`90pura38y!~2VO|>Jp^zp;_CMH_J8p8F23#*!9oz1*%!~l9Mq)Yiv1wE We4QZ>9&g7GE77|*Oul(>d;7n(b^!?h literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b4e27223d094c6af6b87875f9b718cf89998d33d GIT binary patch literal 760 zcmah{T~8B16urAkODTmEq9huF6B1rF4&kF(tS^qkloqzLFgqLMk(8}%QfSi;6JsRC z2cOnxA(CAU|G`(p$b)~#e^6&z6A3){G0->7=PnMF-m6LMI+v|AyNOryU{@$wxXz4K`%~q|hiq%!M zeU!^&aw`uPl6m4-L$?3+WOJFt+{*GovVV4}r5gZHhRbLf14x4b!Lgq3u=ZCQUV?*DWygQ}EY8Nj6rr(XG zwCed!uIk^t%@6z+K(G3qZ|K?tz;X54%+A0}M3DeU0bJI~)4giCmIgf*eD?2|)aGl& zXgXXVe9dA4KPxJPuREqbqHIr@lt@~@f=O4XvFX5f+}U*`E9u(J8`3tzabq+bGZM<` zq{)P^1-4ze9Wzv((@WQ)8#MsJkti=?Q<22;wkQ!gEJ@b4}UB0hQz^^oS){W z6rpYng$f~8C2@*oS|P1g+J~Z+2;MZfVgsH9PNHm|dEm$oQsE z?zdo(fqui=;bQ@W4Xy62wA7`(FE9*%+QCF4jm48nwAKW=74A4+z zBb#;`>TdqrtNf98 zK_PqhJY%jaH61+r!95l6-qRNisoBx%!QXRLuSBR6qcB!4|( z>5Ywu8)jZ}&hVT0+WgJ@kMm>si!<^sXCx6#*7M}=3#8=T3cE&*+@k>l5yZ?b~WFz*7QGd54*twATRd3V5%9)6A8t+#_-YPF|0eFqJM1+|cAlE7ze36XvFRZ6pkw z66UY`9=-3uOG=x3W+QFeszci7mFLy@kjlwr2Tx<1P2hQiZEzX3Q1`M3;LhapUr5PY z0Z&z91x2#39bVj8qBJinM>c&UM`F|e-?DqEwnPbc+bgu{3 zV?fU;^iy zDoh8D5cC_+zY6^ohFvcNAp=4s2$e5@SMUP{43uD?d>&c^KWM;U2?on2pjGfg1`L&8 zsC*Rsf*&?uxCF!HgRocdF#}>Hh?QT1fZ$aF)DoyzqBg;g8Zf#7qt~FF*j4DLu*$~P z1Q!Q42M>oP4qgr|99lW}Iqc;S;LygQomU+!;)KC;L5Bui(Cx?UU59Q=a~J0FnY|1y ziB4d*L>=vs#72^6Q+XviELx;=ivg`ty43)`l=d62SHfyRKuQM;Xp_=y2DD39rpn`t zxu=G6Sv)|q!ky1K;r6Ipg!`OR|DiBc$iAfWrRK)Q-q}~(wuG^5>2qWrnOomG$LYku z6gfGjDBqZO=OvXpOaM(A!0VtKP(rt|x5RP&;H7+rYCARp4s0o4`X-dX`{b~|$jtBQ zlW#$P$l-sl{GNIVYlAf%F`sboM7;(~^NqMiy0c_N_W)oy#wvp2;3GGn@h?u9$)n&&}F zwn2!GC`n>>&|AZ)cs!z3-8*$ob2glFKMgdjBqHXkbh*YWJMkn3*@j^ARiD5q(70z%IIiB z9Y7taMd(P)LI-n9Z{oi|9rD%6C{7fT*UXIkOyf9koblOP2Z0%)!T%}wo6*E zrOM-O^mt+E99F?ETt+gpl+V-R3&L~TQOscBa^W(HtdBA8T4@`W!(z47*lQc>8|oa} zaK;kF8395F93(k}ppHNg0qsnS9|47EX+}^>;L8Z?1hylnA%OYeR8IM?2&mTbpAk^4 z<&P=G5}jC<M!G;zwdWu$@f>c~+SVBrHMk-bkk4DvF>ndC^ z=hbL9B9JuU03>G(G-JEYJAdTxMpHRvi)rlIy4~ zOE%mF4Gt#)E?evCs20-C#EdM&^17^I%1|3UKvmLvAG1M)VfS};c99^00?IkNFLw%! ze$sI7-YaGUo4l2FX~msY-gZ$}eSMyq>ih)xD(w)yaxA9YC{ykEMTEO|^$?s#=&lVC zoPMf+DQdhLy3g2E59!U) zIt=U0@)?}R9dZ&0R-YE$5Myx+lPFsxt8E7XIsiVEX#5Wi|K|VeD*GX=ytTIWU(ITe AOaK4? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCON.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCON.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6ac055d2003639cb4aff6cf91b7073808e4bdc83 GIT binary patch literal 988 zcmbtT&rcIU6rSCswa}I<4Hh*G^^$0CKQwNSSfA#GT-#f67g zVQdVdO0`&GMl#9V8>x6ab?y2{UmBU&F55r%BvSEMYBVv@ceK4F$YlUP0krwA7XTSZ zz->9QLa|BJbS8^cf^t}Ko30aJTGYIW4c8eMh4pepEm;q&5|^`F0|Ef_Vr!Wp8@FllH412OQMg|iE;6H2H_HLm8+jHVN?z2#qLRs7_oe6&AJ3A-!c z$LA?=cJSPQ;N$3?J>TE9=Vi7cZL;x1@87vX1ZL~asaagJU+WPj ziKP>9Z|Cd%!w;GNCgB7JYxbvm07TYL$%4JRN0@!soPJLB0chIK$do9A0chDf(b*_Z z=PLj}2!M96aHeU?MHz@b_my*AVXDV7{I=9dM8>n&P;X@zLMBW_>|t#fP&7ofN!7qK zZ?J3BI(_h)b0)<(QTRK9>WUYX!d|ZwWLMv>V8hT2RnOCzJXNF++YnL^nNvHssd%gh za_mGa!x8{q5AUCkx8pk_@~3qphbVWy@k6z|VPJA>K0JZP_E~K3k0uS7xOd7LL=DgDq2X-0Y>y*O1_iTLpgdddU?mKU&GY(%|C(6eKcBceF6(R#B#*zu1b>KP| zsa31P;Z-yYmloJ_T7<=w?n~g<>Sdm`?Y@)*QM&7HitJ<75Ys0J?pqGDoC}(P5yk3> b+Orvo4U{##AWvhp-p=b3dr|P_($Uc`{N5;Z literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..aec2214e279d9dbf76385269bd3e340090e1ea9f GIT binary patch literal 2623 zcmb^zTWl0n^v>N!-^+H{wo*!&6biaB)jot$ewa?D>~?2o>g+6S(WI$;xV77deW1ih z3X-6418i5DxsdvbB>rfYMkA#yjhdKX8cj&})IZ~oA0#Gz7`2`=vxTLY;D_1XIq!4s zJ?EZtnAn8ll_DI5b*ieBu$rJ4~kN_?nr%M zG)K}uIoLNnIKUe-gHr>2rw;J-hk0>gayS7codbKY@6NIzLaP(X;6IEXoy^acz$Y6$HiMHW;sA_vTrnaqc?2(hTFo5|7! zetLXDNDQ7FOyF@wrwB)gc`2FS9#bVFq^V|_o8^kli^-CZDs;lp#A7m{`B^XMoimdq zhlFOKNr;G@3R#%XKT8Pxe2kFYC#>x($5+DK(ir(=HB7szDoZ(cyw|f9@Abm+SsFlU zp3PsOix7*^>j!Rc`I=UK=?%@F+5eJO4ksJ=`7YDSIn7%M4&Fq}R|#&katf-MJDO*G zu}1SIN?s%c{)z}$e^2w}lC$yI_zH-8XY>4AdDn_7I; z_C2yVn(G4bIQm&MKo?H0Y^t?xRYTg++?Sx)c#AvkMZ0`I6lQ1Z?>|-)Hc z!(KuQ&3BVk0ZCKaLU{Rwps2PfvM#iSfTJFZ252!Wpl(<$=&sU$BpOms&}Ad0Lw874 zd%2@MQA3VU?qLl>3$P-GhZQ)sK}UH4vaV~opv8>Nm=SPz!Js%Gsy%|mj|LdDR%zqb z4)r()VNUGJ$FR{p0Z;CBO^=8Ml2o=1GfdpA8ZGxkUN$gxoz2zuPr+=4|^?$h+$d44Wrt5R(YJ2 z9l>mfot?7Uwhg%SEudXiI+2=%$>vruR|=9Zvt0nV1v~0hvZvpa7*P>dNnJ(<^Cs2Oy%PFiPi-lPQ+rw(j zB$t3S0&DC-;=;&jy{F7H1%GT0eyng$0tfw~bU!HO z`bQpUI_}5G2dczhjRLr!4(fCx3Y&E}TzP5}e~ z?as5rUx8+ScLX(80kyqyOMu#5xi0|Cdc6i{*6YXfx#H~^kzpYK09o^ zCTY!+X$)JWcTMxAHE(9GVv+a&q%~irEMk%H>iFk0|2Y+@xlpFIBdkPJ98AGmq%w%} zvxD9U(`ALOMChtYZ)UEvt$T@?+?nVbePN&vtM*XW!b9YO8@8$9?K^9mMZE?F(GT=ZvSnjzcQcrxdL zB^uD%7^^{W7?WlDZ?IB`qk*e4(@rj%PONiQg9p^<#s{6NGSdZ4>UL5}ZH5^1C8eCRDgoK8>EOb7fa5PrLB=RdA(AW6gDHjqG;E|5Qd5?X2FY<`HdFW8%g^b(oG!7h%S#tssy zKq(bf4z5b#7VT>Vk$T`jrOI$B1tqBMfddj3s?wHTdf?brs?}r{*uA5>eLk z^JeDFd^7Lu&JyQQpI`PR#wVh&@T8oWN=;0qqjj)dhg(97@mXh1*Rt@(O) zw>6Xm^HxSC!=Y4oR5qu=$IU4J#u|3uV@a>GB>!?T6B|E}e))%TX}8 zV5Lj;s|VC(wNLB!_XJIH@j~fYLYxJd%U6*bhlT5L^6=(iad3OJM{uHcAu{Y*j10Ts z@h%$Y-=nVV_Tz*Y)gV%rMcvd}2dgvG8>t?4gRLPhWPd=Kt{Un4#|M zE`z#YSFoUNi+X8A9h5OcD*ym5Kmh!%d7c1k14JoFH}2Nl3D?)Ycv1!X7A=dyEgyzmE_ zz==J**wYB~)9&k*MY<(Jw`42r#tzGiRGy>qIqJ6i?9CoRe5nh6-0)Kh@n9Id7OkLF zbr5TYRzb@vpaUx{r*07@AUn^2e<6eGbmz+QB@k*m$=o|XLXtv#zZdCD-WoOz_R ztL=ej0nX0a@o&vVvcvzkf_jMl9I?OVxj)YwK@t^DyDDZQ?x>rH9_!=uCdEgMjvl;G z)o#t`@aqA!y$3W#S5OgMtXM38ryL$9JPx?JJ&I2=ecft6HwOZ6_4@eTT@V}!ntGoo zJZWK4g_TNPRxGW9>)NI0fdCDtbinK%FcoP%IFu=xF{E;RP+@|!0d&QFYILc1ZLho< z@KT3YL(Ai@2Cst<=D-)iM!4P`f5R>Xoixy=nJE5+8TkeR0o}-Z;V=Q$9>UuC{{Zl5 zLETP+;fq5086uTp3aVc>y3B6W-Dg!uX4nQK=U4@jDOQQ37I)VA`*ouO#TpO`1Ns|! zAgH6fnN=gH;zYd4BZyz{2;wCkK|BdAPKe+i0!#62kX{N7^|e#KntSh|zL)19HocBs`|@C8p6nVEVNn0wOfBmw}MG+?L$ow&W(O^nlj!02APyK4PRKQ`Bv)+d z5|j5pKcr4dnP(gB_lK2kN`;dtc|0@`izZVovMQsTnOZcvWo1MwBjNvCTF{sWNxMyaHtDd5 z4g_sQR>yWQ1)axHs<-(FgkZI}hASnHNHChBQv$v8Ip{^nf$U{a3L9z&HX4%0rs5;1Xd;eVoMzjR z9Kkv>#Y}+;YO&H@=E0sMzL7a~AsesCq6;&Xo0?4rDL39e`oYe}C>e%BGnp8dCql==azo=mJS{$d z3ePq9mSaRN06>r{5d;B}D8$L&jjYG9hS`C%oUDeccd&YpLBPWRtOP7)L}2PGag84a ORxdo7Ci&#l($c?>#^6!_ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPPER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPPER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e2da19554019c2168e58b4704db9aa8d0b999f89 GIT binary patch literal 6507 zcmc&&du&tZ760ycukAc+*Ku4ogaq7{5a!~b(2zhtT`!Ik0?xgu?TogX7O`OJOh8Z) zx|iA!RwlN30w<8&yA@5^q*bk2)lI8TG;1<#>&6}(Ohek(KUF8eChecL`;TqP&N=tt zN0RbbV2bR|=ljn2o%gx-OO81nkH$mMkwZs@52i;$BS*)N932lG7#R(XjT{{vN{0@> ze(0-FH4%GemmJ;Gvc0t`S#&Zqn%*~_-XBUGO^@y0_vMYD)@>pA$msAv__1{>knNpq zZJiHqX{qX#lW_y>hB6(UZJRsWT3f0X&P@xx5ysdMo5!V+F&`6|HktK>Q?XIKIyCbqS(iZ8H`}<=Fc5b@*IAiX2(Ui9{v%7`!hk4IW zcJsaK>T3i?W)AlUz4MttAAJ1q3CyeB(_dG8`3TB5upZ7&s)0=XpdYwZ zF9*5&Wd!)$4_+6}nMkx0z%qkDV9jNY4G-4Mt96rV-3ir)0>$#RMztvQb7o=ujVyq|c+{{3ezniFwPQQy;&MIpjidKH(}XT3zl73N!V|#7}(4X!@`-(HY7xABHxHPh5qqj zB2H&jpY3A)14!MmVJmAZmpf;Rl{>F(OIfW^$Ad+x7h3P;I)0L}cx&AeQN60~=KB2| zGtEZN`Y+YwbyN*DoY~@+P!Jv|>>~@5U0pd)%?8b`5a^6K;bz)x zKx%aGjuHwz4*9g^;x+2=X~T-rR!3?jMz!aFl|!FxQCYcRySIUT@PNl>Eezmke8jJs ze@+eHa0-Yym_y%D1Na7DJ&5xc%*+TE%_25aY`r;r;=_JBsKbXn=z}L(U>YCys4s~4 zK~rDQeB+>(3$q?xv$XF0e`saz-+iq!8B=Fj)+X{@5X7Pvf-U$$FlW3k-DD2mzB6;f zeaWi1noq1bV}jgH&E3w+*ftt4w_I_rTNS6?M(+Pdo$Sip);Y6(xoUgVoM1V65v3V+ z3z?g{ol2X`c#s|WS6XT#bb%c&R*D2dXi!8(<}Ks z@bSW@3O)|_NO1Y82}k8rbXO!1OARF8@)V`pmoxc9G8OCN!eWk;8rG{tzg{WU!iCEl zjwKRmBBBnY`Ug^BF#rPYu&g{0q5Wi7hnrVTd-(;QlzDnikKi#-iwc zIP>h$YjN432VklE51mz>HI}usRJ>#?+l-|S6o~T9B(S^wLKv<;5r*pmVK{@d>8zzq zr$n3LKWJ0@J8gs#QGx3!c#Grt$p45-~b^^hRKD`hees{Jo^uah*gQ9}}I{BiYuBjE!Ix{NV7T8Tk+6xyg$3XSDC3vdQe4Xd))3Vv(|Dj`yZw2|1qB ztC0;#{;>fy6{BQ(y7UJT!iVtdbWCAoz7)RlC9pv|!}TTszt?g6ZV-_(3MT@mpF7Hg z9$rqU;yvI5AqfB~eu?gpCrG`stju0pQAK}=NRKw<5GC$#g1qZG62})77XHog`(OBV z9S{CW0n+=>Nrn7&T_V3-lNb@O0ZR-*TpU(cri>m$^NK2v$dc+Tt!1+=U0}S0iyiIS zUPeQ66iUN&pZ-N;avSI{&yAV{86!mv2#fVvUf5KpF7n2TsPh^^+tja7aiON2Khr@I zn}9Fpk4YT}lRAU2nuAoA6go=0S^}Lbp~jK2irsmL)I5(upEupWP6rmVu#1Yls0on& zakRKl=}x(fZYSs|WL>i;$4)op*zxD(bL@D&6wvV;m_;^PYQa)t^1yaUt|3;1N#xjA z?6IS%fQlJ+G!W|IgpnqDU@RI!5{!xBgh|*Sb~>du2^GqsBsa8aW0LFE5RyKNyjEVM z0b3Gml;UJeQT$Q&@EIHMK|Z$32;va>C1(?VjFA3_!X1l3$eSpH!be8$<9HUnUm6raGksY! zo`pwjdxefNp_b)@7=*@(7=uw=aGyanF7X`rf}v!{W_=Pp#gV*fDVK#(AK7=oCHCRM G!hZqvlK_YS literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-GO.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-GO.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ee050df1d09f18f38f2a8993df2504edcaa335cd GIT binary patch literal 751 zcmaiyPfrs;7{=e-rGF@ev_wfX1}7w3HVz5U3f7C`c1jD&EX>XZIX3N>$=`3-Qkm`LE@Y2STj-sgFLGc$zP3&TW)x8G^C-7fM5{m!6| z8eSLmyg|3-qK4GbYs2F7O_>-Q3r`nQ_O+E-*RA&5IuZl7SFgT$gchG5(&@I^vRGY} zzmE&KTwyuCkSY<|ymI?*&q^V;T*xmiq%KcSl#B-eHModA;{X}ZAUN_fx}dherHV;0 zBb!tYhJl}yEZDIr5B%&B>U$mBc3-;f2xq?s3PAA5PnH~Jh>FF6W96-q4nF#m6^6GY z8d;;DCjYub?ux8e@G8#ZH49Ep;ycj@-<#*_%Gm*I|5#UdrtW8zSnGTbVESDmtu)Vm zGFkr~ZhTg9xLHITa3;xV>u&x~VF+cL+-lC$vO3t|cYrlukLf zIJO+IUaKe7{sPm?s5(++he1sd3g!UsIS>QhuQ8{-==1`+5-(DTH v4z8X}q#e#H!Pnqel{vEpr$kVEBhIV{%86-*6VWyqx$RhjhIir1?B(SjE}h@B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROG.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROG.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..79b8283d5b2cf4f53fddd93d3f2c8e154f693a00 GIT binary patch literal 4601 zcmeGfTWk~A_0Ej#I1d{;B!L|s8D3d1ah5;`A*C#inGgrZ6a0t+rJHpeC*x)kr?G+3 z2b(}kOXV$uurPO9q^kSVpGpB$DzGc8YFBMPkdRi}s%pQtqUv@Rsa4fgx1{IXYX^q~ z(T{#s_RM+QbIv`l`g?%k+ts;yZ%ftU^{av_LkLNd0)k3HTtp(~<-E%iRU=VvcOa;GL%u%MW6qg* zJH+CRMbxmFckfhknJKT4I+-#soQW(E2r)0^?cK4EKN`?N=DaW?)R-6ZjzGxU525)E zsYJ9Ft)O+m%scjYJG{HS{bB78xqkJfvxL}=qa%0pw|j-#lfqZu=@sM0Ww&5O?p=Hh zIhm{DAtzGzZt4h@sKFw2Szib)8~7rlG-pw(c{#bJM9%5?5{mHNj9&V^Jw{0F*@|{S zzYQ*EP9Pu79loeJ-z8*D|E}ij6$J;N3#;O%zEjd^)?8%XW;Yf}a z^yINZx>&P4&#jsK)SBH8Y-KgGY%kT!VL0LghWJ5zAU^nkd(#T7L0hk_*4ApQWU?GT zCd2G{?Yw@2d?$VkZQQ&0_4sgnP(~FwKFD7Kvb(M>eoWh{HEEkQMcarKm*v%<3jNzt z(%k=*`0)6L57Y61hw*{S@!=UAtbj3;c3W110gu+KwP-t-I%?19=ZnhNz5jIjvhhM1)`Qz6YtBpGU#J_`+T@|O!a}_vaqNO&FS7omIj`wM&P%fk zzdNV3)z0d*V3Z~2CpUyKZe{t$ogc-@Vn=< z_9qP2aKmfC@cD7ALmujY#ar~_ujjOm<>KUzTzsA8gq4i*cgjPZg@s0#pJN{z6-BHb zJYl>GhNH-O?8z_BX`SV!Z@$J2uSdg;5a2#}XderZAuK?SVSvR!2S*kjn}q=PEi>E1 z%{D@KkCx*4`#EiYQEE<~Ntd>;rB-Nv?t*xFE0ov&AEo*$Mwc;YG#Jf>!(HEmBE>EG zuGTva8?F|Vhk^y84)$n{PApD5n)vs`XKsr}3q6*AKAV&tz!qB2`j=$2AoK|QYin7f zlx@OyL!baV@arMA0iO@?{TCKa!_yY?obF1yi0FZ{O*pu8nBg%bZbM!db%R->^n9L9cj zn%g2rBT=|X|d43ek6ZSHzD{n-HhNZPF?2IB&WX2 zslA-q$|(z@$ln-6?z8F1JvKdghpyWV)@(arDl4lRQXaUw*+N(b48yjbHUY4HN~;i@ zq*yBJ1ZTd&fHa5tcykNEm^98rq+vc5VL(hVrg)rFeH^R@Jx8DKa4f{)1Z8MuCxQyJ zcqFDpG4rB@GX-E;pkhaWCw$6y!k_6@q<%|l5WG*fA-K<}d(?x}dz|_?m;5n{L%7Z* z-{jOaE_sntuW`w7T8-*DmrQYLm`fhxR48zQrW)AgZ#juFd88(*`z#Pq6W@n%Z zl4!BvPz~c*XCT=&tc=YDFAKgz92dbO(6KsZEHiebf5387KB4$cGykRX46sgNk!F?Q z%n3-w$;5OzF>ItD2}`NTDwFUDc}h=BDmgu+q+lR3%FyA=$Y~{=g%l=|I!l)LH8bDR z*`>lBt@2Mj_WjBxWi40gwKI`o_qCv}8+cZ5VGAE|oUPVha2)p);Vj45itFPzTT{@h zSYozn{_we&$#2YjcX`Z8)<}=(Ipef4kr_#krlJ4Ya59mFsFRr~; zasu0%$SkXwLl7m4)mCAzbex1>W}vUF2V;GGN2w!&3lRL3s>Q=v6 z6l+GQ4e$~h;3ZVUGPRau8a6Z^`5(C5`=rY+qsuhg@oZ09%RKcw!_!U6Jzaa1G#wCb z9T0EpcX}?(_PPR>zKxf<+dV=+kbC7j0r7T^cx&N90=I_#a3JJYy;`@|AM}L-(W4Ty zOW9Tv2ht6zmpUojh-fv`gcpdcx=LE~TRKc~K)8KCyc2k%7rr>^XM0=$p;wT5P&vnHK7fMc@|ql<8hvHXX&*d5Z|kyOX?$?4Kc=iGDdJ?GAyY2@q+hP7aJWGrK*$F=N4erzJI4Q0o*Ty|nSmDYv; z*S;3SQT-bof#ANzFEmxg7L26E)5&~#P>WBbbA!oO8nmVtw7}SS#ssFd6~vaE&CNTv zZEvh>55&UU+f!|JP@Cqa#>%+s5K5sUB^3zCNJ7^6g6xayvADlI6xRKbK$q^b zrmaFbM3UIJ=^irJyRdMXIF&g1$*Y`FYTGf^e94=BD-;|DgH_kDizs_Yq1LK z5}+%vidW$^bo*4bw?~CYjB5IC#<+ss?(LyI@4R&dUFtpDdkAV<#u}qa?;%F3@dm5` zzEqKGdVBCDTu%YKjyqgoJA(?3+rF-LeyR8H(NFFv!m~But=ISY<8l2ioCk!j{O54liw@eYYr~@s< zGp2(x;Lc@ppPCh=L5~gnZQk*Rr*O+7j@^p9%65GEC~j2;TA|hLIR1JHw=PykzgOhd zTpjwJ&c9O~*jb#dgZVl4saa-o%ODbloiRN&^e~bipTavAy1x3VBCjbqu7d=3sRO%M zf{bAaa*ifw4|+H=`_L^UxNDKydPT0Y(|a(V*FR3-7j3O+V=_}Z@a9XQ<*DuS_)=J~ z|7ESE{nyMkMObV0DZ)ClRuR^l4T`XV_R~g1uBR6E`FOn<>^tJmMzG1c7;$G67)ffsxu0?Z9rNm=4Sa zQYEe@mEt<$7S|H5s9CQUR{4TBvL{5}p8k$NWKUR+`rAT)ME1sfVjWo`u7PJYJgeYY z36BcTGei+rfVbt~trom318+4%7MB864VVI$4A>IDyns~#<_4?^Fb~*Pz*7!k)$mt- zFsuh6iEe*8j&{X-L=c@Y?tpQ{7YxLM9sZ~uPekFB9%Od{SFAr4*SkdF^BQsNBQ?@< zWQo*36v+=)0k2PwMsd`S6Y=gu+$S}Hk=qxD^!pi3r<0y1mC_dCmYRrH+DfXVZA6Ca zM)RZBjptxbiGyA;HqslzdGPL{AqV1AJWHbqCZbV2vfvU!1UhyC#%dlebTAOp`ShfQ z4tK*wlpXBq35R0LRTp@!>IsAsddy$Kb^#{EbUN<*30X-=k*uQRJ+hjTuYy8ZRPWKF zF`deBvKENrGfv*(B*%%$i1br1ap*7+C`#9uQ|W!?RC;xr;*x_&=sRZJDhtREZzR5smff1=l?dkn5 z0%HPxpas4sPqw+-shS>V0j3ax#k;Oy2Lfla_LpBd6ZO9 zbAxN9xpahU9^g_Z*K8p&)!fE4w{XeNH8*l;8P^oZ63|2sm?ru+m;T8#(LF9*VJn4x z$d(8ZQojW(T;H(@Yx3z_UK<ne1qeYQ1I^>f%&u-HE_D zZ72!fC4*XKlz&oC>;!AH1J(?5ooHPU!AQE>aB^;L?g0Rl&H>ui$46@$YJl-Dgu0h5 ziWS}a)!lIEpr07f6~^XI|1u*EIFP@ z9x>Cf9`mb|(?;Q|^th28)$&GKOT$2Rh_OeqgRf|r9IR$CWw3Ph46$uEa(f?OMJ-w9AFRaGtg9HO|vRMmWiN)_z@_XAQQ3^Q?t__qnXm z&#l7VMOkY(Gc#=D%~!OM>|kan1I@t3Q^_2poyv|;WN17)qKzeo(^}KEtu)DUBl~;J6n8Zmaa_62zS64srWNBAY2XqRFnTl)*p=uaZVU*fd9k$gPsMcEe z5o_T`sDhq#mUL>@Hthc&gx&dQ$S={5$wcduBW+p`sqYDqu3sGKs*9+8w{U&8c*D5a zac-(p4xRfZz2e>I5JH05soo5UH#)@Yv!5WiLv%+&k)ZC!?fzgm5DmrqC8(DL=T0w( z3Uo5@5;v(NRj?;~gV6GesL{A?z$Ckc8@t7uq1QX%n`GHkha3_*1+_!H4)b)1H)rp% s`|j+Y>2&+x+Qufsk@iFk?sSit?%74t5n4L$B4KfPqBkh~-rU@O0CG?vWdHyG literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-TAGBODY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-TAGBODY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..241726d3853e5ad7c222ebaa5ec6800e187480b8 GIT binary patch literal 4003 zcmb_fT}&L;6`q;>0Tvc73$bBE>3}i9YZmeEHFhcMW%$c7m+a2gvEqcTVc1zS?9$!E z5=v`1j_X9~rWhmJGj**-RV!7k6p^TE>z{xkSL#C}=b>?wrc#yWsgbIx5ie~YLeII^ zvw&T-uF{7y-#O>IbI!eY?mhR;3g>t>91+8r`Gu6OX2r~6eqk{$&StV=F0+`OR>fKH zi!X*rRQlFvDExH$(N0%v2Q!^j6M1z;R2J3TOk$}`>^vfd7P2WFlwc6dzW$z`{_fs( z*KjBnVbT8UJBRywdi%Tj+Fe^WukoG?$8po#20|Ifc{m$qTq$_`iWE}RDCC;mqeap5u(mh0@`;99G7NY^?I<`3hsX;2x6$ zlQ6WZ2ZDj#fD#%xPKHi$H?Ngn;5cUp`*K^mGtS>ib7$|43nzws zRlGyHqODbHD_Q~MRgjAy=Tmo*9Ou1I(#mVM)@9KDw(|6A@;#1Q(Jsm30`CTGZQqGe z42e?8aTOf5k(wT-BYv2L_gh&?boaVmGv(RPro0=nZhL=S)`bt&<+%szn14jp>$ct+ zB%ZnVp$+lq?g!Wwm_uNcZ@sl2^)KoBh}Q=J^dLj%=_TUD{O_LE&TBjR42_7Fb$gk3 zX}@0~-Y4()rqyvbb{I3TjNjQ-*T%Q?FQTozvHkYL!TkRQ;y7vzq#OsL;jFG}Q?;P^ zKg5nucSB&k3?l2L5Lz#R*t!#f>kf#n+abJegZR1t3FaUH@yV11m~{65;cz{r=@?!$6=!SdQH@2^NLw63-McFX@d@qyoG z`5l)3RZ5j91^tKr8)nd*lXb_`?y zWN?G@Uw)Y!Tk9nKP)E@oxJCxZVBN+=G6>Dcplu~}Ub{{Pksg5N0t8t5Ev%P!ckUxt zQ9-L91RoZJ;1d@F$Iq>O)JVG+q&0ypKN76GY4u$fz}j7jzF1=Cu$8z8w;kpoLErzN zks!YFq*DP^cJIHd>MNQj<>7=T<7%PaA13n97#>D}(U3e8k)na)W8jfTVt%2~EECE> z+#n?&4iGz>d{zE%NC}SyqLLDi!pRk;N1roxGNwoq0{?gmh4{^K+kUgm)(odzrC*9h zNi;y>%4A&e+YZ1B75b^OruBK*LtMp!m$5DqeD3v=$JPWxXmXJ~R# zl82y;{bMlgkx&dfV1EaUlBo1GDH@Z|z7Eq{a!Q7@;V!h#nY9Qig9w9e20jKn1>2t) zyvN`d3~n;G$Y72^l)(`OjSR{t2%j1#KAgP613C`{$mTwcs4lBY8>OJYD=%&Fo?29}6;W^sN2 zF;QgmS|Tr|a$-6IZ)mERN~hKAd}hb{)0uQWkxHl1NoW9#lNn6oHws@?Fiq3BP?I>D zfNSRryv%Nl=sR}+2l;nn)nOED$<7XV=DWI$f{>?=F4Q`)$zK?c>L;ubsvpvpsNF{m zSB2x(#dm&c+%Q%JSg8%+s1#D9z#|JbGNwq;P$XuSV>9?9&%}u$u_?Y`6eb^;pkzjz zPNc=ta5%vQ)| z9%Nsl$tW~G@+ESq`33lafe(_)!;i|mn$C;#+c(hJwg1Rit*-V~dG=JgD$3nur6o>> z-6mk+vcC@14!QwlB^Hk;&^2@}gVP*F?W{S9@H~Sd28S4UDcJtO;9~~AVekfns|>!$ zV4A@=gH8r@40sB{rwo3_;2witQs6&*Y%chZjKco^I2Uv(aKrE)(5c{mY^=JCLdi@f zt%{9}bd%ur!JQ`LkKiMSkHh%r#YYc5=;otg%TB#}RA0u1IDPyQYC+U8s2xU4 zMXeXL=TPfG?HSa%QIk-^FUI$yMl*?z54XxFe0A4wp-jPM!;Ph;XT;2`NNX2tNZ5!o zZN+kxRr8D4G?c59jyYU(D!30}Q3dxUcc*#QD4g1rBEZU?IG}&$@$ z8S37ZvB40+2olGMyRU7a^z){j;e_Yzrs2abv_o%t>Ci$BXnW--&`!(I!*|f(=B_#4 z|NnoIEypcQJEpOA-+TY>|L^_xy|Omlo{n@3Nq?b0-XU z)NkKjzwNrsB~8J2gj@TAI@i~4-%($;eRIj|*$J_tR}h4DVHz8^AXEslV4uoX)F$+J zBG43$=m8@b)oblBJL`g60&Q_UW@o)ywM=hcz)IbjvM`;a1A-_B_Q|ZPsm%x_!lq%5 zi^F1>eIn}#8-Z3xE!eCJk}Gcot&4Wne|=zAU~3?{FBWKsn4!IakZHsdv9?emE}WgX z>K;KT&0t_prk`pN&-IAWr(2}`O@6PabX$@oTMkPpQ7CSdIzM^W?Sg}e{KUhLmATta|d`mV*0pMZgLa@d7i9IMzJZ1Wchp~_Y;7*tHr4!23FP2XC5`M zgBLe+EFT%SwS={;^b~L|S&(a0QLe`=_u;gxNLDen=^)sd~?FU_8O{sUYFvdnX^pwJz@*RI;dY9~Ie1zPOh#d$qHW zeFeC{2q4huA|UQJV4_UlNbX&T<;V=6aBndR$MPtQC7O7IOG2ArJI=F*c!BxZn@E~IdbOC5@0|9;%2|)KKcIKgjE#db9_Ii=# zWJeyhQ(d{`1<=NfJXXIfmfU$MV5cF}oDcox;TkhIJZ}}LEg?vrUlc%E=G9i1wdS?y zZc9$5OH@LF@3R2KGgigX*R8rKue8!IH=CRIVpD0=0kr})WIvYLgr!=pDXRh?^NLlF zNqZ|ErP^cgM0Q^Qs_8S#x`L|La#<>=PTqnEn7=2q;08vGzGa$I0ih~7m{AO17|v!VOdlQ2V5Pq7(^=_j1+-Ry5sU&$%B!uhUTK}#aA~5a&4$X{ zDwB33FabXf(YV=IIg&;jsB!*s3*=Nf=lfkJ(y??!SA`(0gLeS2VeZh6$8~8f(t^w* zX{=1DVWmDmP3CTE0HSU^1@XCS2Xp6z?MTp){ zobiM4gdUZ|#S#g#mX*s_u@ZSbypmi|tH)wyEMT@JTH6w}^3|YFRvR=928bT7Wukly zE0Z^{Qu$ioIrIbJ1oOxnp|49Jj4jj_i|Izu>lG7`mjK@Kc?d(nxXuG&<;dOuY`MuanFmK}&~8+ZHs~=N`e9fe zKNxK=BZ0yz7}6EC8XJkNfyVPDTZPTjy!jGu7);&rxSnVVEY|mASQTpA!LGz6$^6)C z1P%2Q(S4C{9Fy`~gR$%jM%wf^4p);;&z0P#%4(44U>Y>;{~@0H1LC<~AfEd?=bh%G zF+LjPqkcYWqBz_kio?B);&3~;h)j97{tcsu=tgs54|sBM+phDR`3x}S=1?PYzCvoQ zFLKUF;5eF~Op$dD4s@fj6$jm1F3sik1FIA>4$S*#V$~?PmV$FtQ*f>;C^+@Uq^-U} z@vA?C$#ca+dN=}413p*Y1A5Fn0581JC_FA;7hS54v$fcq;ku{5Wm%&hG8^?kQ^ceS zQXgRJP~&R_p>#`L7hT z^9jn;`54%7M}vEH3=F5(Im{Vdz>p)MD3aow6lEK6w2hDagoyGRGOqj=8CTvQc^~pVPS?2b8ZPW5kMb3)4s@jN6Hodc@uYD+I>|>Z%`F#EB15q{1<_Q|x26vYNkQJNL6)QC58;tJ%fsuVdBgS_{+49a8Qxrgd2!NuLTk=Bb`uy^Pp}{~&KF6;`8^VKPVwd&I6sXh z?13n97V<6+8?ey_BLO|4M`15RdJDI(j9e?Pk|E^>WI_23Z*r^wB$cx)giRwUIDSl$ zju%P9@jP!BBG}j#jUFVYj%paI%`vkrw1-pVGo&UzMDp?oZ}u`=$7MgEVVWF%d1ZbG z`!;Z;@4^t$;bkg)2S(1gq3gGB!_u=1pMNPp_NA-IFdSX50wfOzm%#=RFq`-%OR^}Q zCRs5{LgFxQ4pEk3ls9|mp%w#Rz?1r9U$UnoF!!X?vYlXDtYLexQCU4S!u!1b&yi{2 z39>1Cg*W%GP=o-U6-Cq@DdlCN+@JT4QFj7SK|kOtxpNA+5J3 zrQMmd22)zsfHpXg>e!@pb@ETQTCzW-^(6;@s3ixqWDgK-A3U1s$-wzWOKP2iJ?)vU z-X5(zX_1dZcD5#gKGxkGT&Hy=;Tv{`*44v5KO^mK++j*<;UEM*R*HiPdmK-0B7j~X zv$A}z3LgXJ3n?)MY=+;v#YJ-(c3zb=y>r-4Db`_ zB!=d);sF>7Xz_3C&)MS=1X3M>-5{ak7w7zumCjp{Fs!A)NSu|U7_104x0wl@roeO5 z&IXI2rSINaZAWjd)}P7@_V;K<2dzw3AAHd#qzAOS(y1OTlTHn3wFBwiL93${4?&(T zh8w77E4s)-1n98V!eAjV>pp~6&U(?3K#lv?ym_l&2UzacVL%YNhwO26cz9Tphli12 z5EASV1i@~l1l_ys>@AdFqxsQPj{646-0g;-@J#Fa&BH_3ylZDyHef;B)isb#4Pe;~ z^$u#c4-O3=`zMT~UIZm0CBslFlX^rTXsBKhMFllEO$ zc?CM?+}__i*q$cQyiUOk+U^0{3U(Tnrs7;17vb#k+u7aoIRB|-ork#y_#zP11BASK;~#^( zx(!?__PFAZB@v%h=Ld_BbNCv0MMX)&cjqc|7I(UCg` zwtD#@^xR-d{sEX0CE0;1fc)g5cBa}hxZX;;DKW_lC05N^fFi!1 zUsPcGkJ2oNd@@A%mH`pMw21pT{Qz(HK}>wPko_x^(yMg;5n6nqzBFQmpA?(5fcpJaR55P zLUDL5;%5E@s($pjf1-6uTsI*&@w?#VoR_5hc}cRfW$V}HU)kUd$j&Y+40U5)IA$7n z;D<=ydBh`}gqQU~)IvJwX2{#1c zgQZz}h1V9_>4_JJzcVhrJ)igs}mTs;$6qY7&;Y10a#Rp);?Ck#o DFkw_B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CATCH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CATCH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0bad97fd2cd53befede6e5eb3b03ddaefcdd251a GIT binary patch literal 2570 zcmb7FO>7fK6rSC+9Vbp=LxMw`1SU{GHEcveXdqRqY@BuMuwIAVb$+Dw;MyB(v9Z(G zrbQJ9A+;x0ZAk0x6roBz_Jp`4RCOf|Jrt=I)Si0irN^r3t*7+8-4GH$sgUfQd2eRk z``&xsn^_~?g_uHP<>i&4Wv7do_-WdYx0eR6uUI^=5U+7 zYbCd8W~*kN8a1<$&t5-6hc8lTWwmI*-ED%>hOgzX1!w{&uajUQB)|GjqUQ}q!cYlTnL8J+`!YxjHR zyKz7M{e-lGk76$Dq-`50cj+n6mc8Cx%-|0#KR5~B9gXGNdeF6_C`4WX(VfEm@XH{r z6+*=j;alu4>;2JKTAfN_ImCpdPARe`P9{O4PU}(L%UXF4)cQcw$-St_Mn;2L#hhaM z^hMo}Q#|+L4kI090m08&g;rP;CNuFJc3@qF4ybx(RMxb#CZ;pSY{rNR0od6dmDEMi z(d$tL<$sYyeh(qcgWTyv9-IeDzIa+oNd}4|h$WWMG+EunO~&EcAgpyi3pXa|vg?Wk zV43`hNaN`=3!?Od9me4&$Wga08*x!zOiiX0@hN$6@mqEXhi_OIhtF6~9(K39lbTbK zx{(EQ9@u@B1r64lWW8^*-Vp5LdH}K42@$0rbc9bu{0fQ!8$ers;o;eIY#Yq)Ao^43 zDOr<@ZPjnML!VEkT)01j=+iT)l&ramA6@((v;G@w;C(ibVttc%1P~3g;22B=n6lt0 zJSa^`(@8Mg!;W?%iXprHZq=+*sZ(|;QuD)Xu4-MU<&sISWv!Y?ixpa{nE5lbxa4*> z&90hsC0hX{%~oi(1d1!QWwTU;dw^!?QmvG$7Rx1?%UTvXiQ4s}20A%*Q#wYMvT)7i zX|d$qP^i0k0#orXl-mA+=XezUX>i>W8{56(b|`cna2Yw+wU?!FEu8`u+Vw~-Tg?^F z^b1!K4>%k$p_97jgdt4}Aux3)sT#7TN{VPCwDi0Ujqh(^SIA%i;8WMgqXuc4C`91*cx@t72oby9XJwb)%V%Gj zI&i%!b=<;JEZ^C8F&TI2M`D^R8M63X$0|NlZM8&~YgVS3%~*vpKS<(z%Y1LVw)4&Pe5-IF7)P(1Zn0O-0yH& zn3JI6prmd4r%TwCE|wAwL*yPs(v2>5yn|ilkiT9-ODYN&>q9o;wYey>U>ky(CUS!t znB74G_-0W8^1EMrlv!$j2>AZGH>bCk4TV{x3qbf>DuncAxJA=g{{HB zPLvR=n|n9m`*il6e4qA2SR~Abx>zK{7PuDn8X*+u;cM?}cu%3XxlQO)Xi^U}DRgQ_ zQ#YRInP1)fhW5A>1a?mFuu;Lw&hOi4!k%6gju z2SVF4lLqK^6jPHleV5PBf!$$BJ2a@7wke&s-F|3kN`I7HI<(Vvmz`{Pr*)a`LZKx+ z=UhEoi2{T{Z1DB@+8v(3k;VE4xB+A5+&JtLV!JewHRV$+GK(fEN4TH7|wKbc7xfNb3g)V5 zdqY8A*xwiQnzLrk3BLFSqQQunt7+G=6O%q8u|Hv;JL6M=ChY*j(A_IX~RCwsb z+QWiS(TV1LJ^9ow@pM{T{f%AHP`JKER1A6ib;B|Kiid2+F=zAdGowl*t%9)Ruw#>$Jbfk%`26hdqv3B0!ff*H@GePI0Xw;D zs2`PJa|!}XGnX2PPyj6pKWbU%FyuE3d44ukCe4z^((DA|&;qb%4p49mt<8Ipx8P;H z(FnNFIR9WVyNsSn$1QtYI74wO4u3)Y8QLlp^8dMn7Ryqm>>|I_MyIjC0wvyj+QO4%~A5+>{ zVVSqokj{h)Y5d5O!o6Va0-Zl-+%XcHGn^xXb3?JALCC~2;o~s+WJ7_3?MbgYuGb~& z??KMNK9Ap_YoQ0T_(Gb^TmLbdd{tZ`v_QIyd>*=lP1QsXvmSS&L zEcsoRAr1w$chdzGw@K7DSw&aos#9yMfUGc7NVK7tA^(D4(Y{)ib4Go_nyKE9tfVtu zEH1}uEH=X8W2pX33b<@rzI$Ply%MH+W1)uD8t%nXTxRqYf?_7ipPKHkSn;v$L3HX! zSR2xOz6oPu+4Zm?!8ri+QMj{|Ee@VEw~o8V05&w@1B1cYvnntl|e&#uCPBZ+#)A%D0C7SoJ)@Efp%j-0j%r; z1vRjwC)bc#+}rOT8XSrN1nyB}V&f!SQftIDa8Iof*FuWwA$=EA$b!>vU!wOVPu5-P zNiv(PPE`xiT6oWiI~E>r`1F$2ATPjFsoDHYuED$T`11Am!#hI3h;Mr@JjcR2qh9GM z9J(Ebu13TUNE54+G*%_80@w&}C99Acpj`>A9@+|M%b?XkTMDff+7-}hpjAVwf>sHw z0-6fV1ve=*) zIxD@wNJNkL^nqCaK+G$z0|AfMA0GA*Kk8+o>}6H*dR8fKU>@1W+-7b`d)vjY+7^c( zFdM#Q;T0+{e2Q)a_4aN((&vvMxgJdk3`8QqaM632iP%>UeYK0R4fvx$K0m90ZqFY< zlN-9h(_k1H@?L=TaNOKC80w9pde8GX+n_%*5R4-E3~NB}G+T*a4mxe!uu@2z;$2Vj zuFtbZWZniNbrSgAcXQV65909q!w%hkVvI0qlI7)Tob<8uhbWO)t%)w(!1Y z-d9U~uK%Jw*ME`~uAgw~N1Xa9r%rL|QzY)Xhs0gCb8(F`S8`?rF`ZA6obw5ib7nX- z!Kv#wwUtv2=2?RZFq7=Nc-KzWg48xnUCXIfPOTxImDfqL@+xUo&XHz? zubaZxP2uaN1W8WW&gHJ)R5eky|0c?Ij#K|aI&E{L)Al9OX**1jvrTi5;$SZa!xTfOwb- zWVk?(A|ZBiu#tl%4(cg9!vB(-@G{8>zau%}0nRiz^OLOpCf2Zrt?Xe9LDsT`HFU6* zt69S;wsIIUp`sdcMWJ00DJOixvxjka3jyi*D_e))9E`EUCppMaBv-Ol1WS3Ri-3Cx zG2JRr>KhzIH>UaGg2blN{*l&mYksUP5 z^&8;Wdh}3%{1uR{Xw1Jc+8+!Sc)w)p!9v$KDRd>creO|bVmeM-t=HQ>hW;{LIYR zwI=+B)U#&J_I~(>`01Hx1dq;4AvkX4lm(%qK#&^jx!XJ@IqML+r>CyzfAWi>bq%KZZadMrqR@oYA8`%0Wo+z}ti8V9tNbc;4V zZDdoE;Me}R0e^*{kR=hJM|2B$#&&?+j2rB3HFGx?8*JG+ zkuI31rKV`jHfX7_qGgYa^P==( z3Aag+E|ze&G;`t}pm8bHe2K&Aqh@YrvBUJ|7R@_4k#5O)wM-&Aok^Fh66J6L?(%ajC+sJ%u15EDvImEmuwoosb#3cL?%*@GN?J6AcgGKba3*Ff9ts*(3zYeOUBV7>L zBmR>VUg1ULKVgxs$Eg>2_mz0+`h=NlB~SIp!S2RIi!EczSZhujndtZ# zgbgdr@qJj+zKJ{I8Qf_du%<=SW96wb$4rT%j*pwU;G(1NuErc6;XZ8xpCt6+8bI(x z=-3E|4Ur{~=B$cUG7nNtVB?`>e-;q739&PPp{)Ip5?k%Z%-s7gVe31rK>NL9rTrfu z1K?1QV?B5yQ+jmx6E9N%m52OMLR=AlI0}ElE!?i`QLI_8O*lrskJInZ&~H3Y?R~Ia zAMtBYcXKcZIe`++^~mY!f^87{+b^Kjqy7%InYFVv?3GJGpuo|(jzR$6D=w!xm3eYj zDcxTc*k5nESe2FN?@3iEd<#}4pbizAEMZY9o55!!5Emgi00-3eOo{8Zr_9_Lte7Fc7C{Kaft}k`lXXd(#+sOgOZF-3gcn zmtUS-z*1=7Hnx>*Vb`*2un&%D*PA04lX$*V?9MLWaiCT-;(o$RP*3L+_!p&Xl8wkaE`{93Mq0b@o zHH0qnnZ!sUwLg`mWrIo*(ceL$ZhiZ#LEmGUC&`gLc6e zknwF`5cRJ}od#VqZ8PmNn`b(Z{t^dYnAwcfV>9gt9-YDcPCQ!Tn0U}ShsiN3{$;Fr z@lNh@k9izl61H$Ku$!rXY}a=T^GBB-y2zoIE?~F8eQa_9PixV;h}M;7ClLNt5)0uE z)=^Edcy}9t@OyGwc(imHc!Tj%_QGl2VVw(~W;c8gviI=$^XFf|U$5e?zwCxAmLxy@ g?u68kko#JzYYpHu_H_qIh!@%=+z(+E-Z+2$?+E+r761SM literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-EVALUATION-APPLICATION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-EVALUATION-APPLICATION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..02adbd6f836fb2260199fbeffee2ddeefb6e57d1 GIT binary patch literal 3575 zcmb_fe`p)`75{!uk|oFXVyAJOI7zK~NxQ1KEKZ#!ahAd5a<-L7I`wplN*Yg+J-=2?FNOWDYT?NmO`N2k8Y)7u+lC zXW3^b%f_fI@jmbO`@Zk{e(yXZLWlK4R3ASvQFQW?(eY|!qFRZLjZa3)ybKkxG6vYFG2+(UFI@M0<8ewTa21gJ9P#Wbfl@AbkP z2jta~c=gQ#%Fyc0HW@l5#BoP)0)pu6(Cndc+AHFZz;PIbJW7s9%vL zfxp$X1O9K(&oK6OjdqScKHsl#DSdqn$e*-rlp2ePo9YZp7^%j+vg%pOGE%YHYl!@cxt}q)#KMbSfD~rXx0BI%=pb^I$&Z*k%H$M#mN7>Y z-DE~at>=A+Ro~;FN7#Odg*L3EkV)naFt-_2k+2(XBeDusBawggOysAYiTnj~&ok#T z_cXPRlat5eEPWK#5qHE3Du=wFa)5(&vPp+mnp}zgD>K8%eP%+fU*qJecvfQ0vl9P? zP85p2v+y$({)vUZVd1+he4B+Az0Be{FSDq@>Ib3y0ZbL7E8m3n1g!rqwC{oScR~9m zSic#g2g0Zid1Hf|GKUYAh7`?2g4ln+Mj{__x8B4lkov;&iJmN^y-MPJ&_(!F!W!e3 z*y{-t1^Z3YW~t*fNzs`^U<0`cFOU2ulRr?9Bc8c@pYSl__XrJPlPTEn2y86D z#vWMP0qeHmvI4iewQZGrxe`55bt=UPC$F9waq#^@ovb?fakjARU#6V}aS5)U+Vxw8Q@ zl-~|V$n|4(g&uN)d&vcMz

2xV>wDUq>MzN7n&x0za%>olXT=WH?(Ewm>g%VuU~@$T9#j8YBlY2vQ?_kQc#h zk7U1kbq_@R(><;)Kl=UEw{rUY4-(8WgfQU+BSl^m+ON!DnivX8hZl$@UxYjP~&WDk)3kEc@unYBEiNImq)`NLdI!f%3*)7s^Zq(}isl zS?Mu%H! zC+WY;N7#C;kQg{7hNH$L3|vPfK-DBgP2V+?qHH01FfnY``3C-T+_vLZI}NAx9U<{w M@bN48xpH~=H;7g2wEzGB literal 0 HcmV?d00001 diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~1~ b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..cfffe10cd8bb83eb0d94cabd652691095b7a2353 GIT binary patch literal 1500 zcma)+U2oe|7{`y_nzyA(Mk=8JjVUWa(OjBP+HO=Z*FLGeCU$B&TPtysB`ym~?8r?D zsA>h=aARp5Wx+=5JM?mQx!?lzo-Z=)QF%_{iIf|VEX&V%`9IJ3J%68Ph})GayySL! z?T+p7?x5cr^!a_);}6_{*R=V480U|$p_<1Vrlvpq)WW7Uei>N8>I1y=NhxVgt!;XC zqi?tPs_V2G-`wVltGwnO+TBMWU%a!v1|#ctm+#zNURg?(MYA%=@PBueic87M7eo33 z7a{b;_(>s@%~B*zAT)YoGDt$0$RL^up8K<9wSpxBix!qExtWq1_=2x(77K1gCzyT-PK^)wSS^`j)u`iZR$xGxXXVd}m}_Ry8b; zB%oE+Qy|akHLS7kz;uF)%aGc<2~mphi_pbEdPWDKy2Zg~LRMjdq+xhS6#PU7{*B_Q z0QiLUwb$6zpZod$=tnj z9HSRQ^!62eqe%qsG0VVTY}xy5#}I@cQHsVRou^ z^lR{=AK${30DQ&Z+0@h!<-UA*4;=CHJ$|G-`QznxO6L3(3iA{~)VMf;*k_>`Rf=Ti z2(21aPBgDY9UAL~^F#ERgHV2V^jP^Thenb2(g;CFkJ|8NM`Qt+$RQ<1Ke-akW>9zw z@4Ab)XgENNwC?>XcpuSm25e-v_z{}x$a7KrD(u*+}VZth$ zpBtjt38B`w85tD#H#?2)qgI1&JA7f_eARYZLeF#icC%j?W4}$jNU>oaSdD3CA}`89 zbmaFZsz6t{U?a27N*%l52!r0_E|^kEL){$NiNQLjJ|}MKhJ{cv@MA}YS^B7S%q)i+ z3*iR2d=j76EJLYl+bi&YB}luVt)%Kq@n6>sOue=U2OHzj9b+O2`oV+=A|~mzJwx46 hEWiUd)~@ZjU&HLL0QFW?3>skv5oC?Anheh%$haCkxAGp z1nTy(7fYpM&FrcDA9(Cr9yV#>egDYzKCyG0v<=f9HYu`w&%Niz_ucQDJR`9kvBZha ze!J1MUC!xt+T9Mf=eXQ~({*b$w+D9ah#HD{eAl9;wNX+w4Z+ymFwFdNenS>iX#?#B z6{&KcE`FLHH%B~cu3hcebd)C2D0e3brJIkboK!sY;EUV5j^u7Jol@nGh*e?<1O6+D4Xq;a8c?=@OBkBaB*)?veSTKjgZ!_ANIG5?lY_T3

2xV>wDUq>MzN7n&x0za%>olXT=WH?(Ewm>g%VuU~@$T9#j8YBlY2vQ?_kQc#h zk7U1kbq_@R(><;)Kl=UEw{rUY4-(8WgfQU+BSl^m+ON!DnivX8hZl$@UxYjP~&WDk)3kEc@unYBEiNImq)`NLdI!f%3*)7s^Zq(}isl zS?Mu%H! zC+WY;N7#C;kQg{7hNH$L3|vPfK-DBgP2V+?qHH01FfnY``3C-T+_vLZI}NAx9U<{w M@bN48xpH~=H;7g2wEzGB literal 0 HcmV?d00001 diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.~1~ b/internal/test/Library/rs232/hand/TESTRECEIVE.~1~ new file mode 100644 index 00000000..92746bf9 --- /dev/null +++ b/internal/test/Library/rs232/hand/TESTRECEIVE.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "16-Nov-87 18:09:08" il:{eris}test>testreceive.\;2 2795 il:|changes| il:|to:| (il:functions receive-data get-data) (il:vars il:testreceivecoms) (file-environments "TESTRS232" "TESTRECEIVE") il:|previous| il:|date:| "16-Nov-87 16:10:35" il:{eris}test>testreceive.\;1) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testreceivecoms) (il:rpaqq il:testreceivecoms ((file-environments "TESTRECEIVE") (il:functions get-data receive-data))) (define-file-environment "TESTRECEIVE" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (defun get-data (strm) (il:* il:|;;| "get the data and return the number of characters picked up.") (let ((chars-received 0)) (loop (il:* il:|;;|  "now we start getting data. Just count the number of chars picked up and time how long it takes.") (cond ((il:readp strm) (il:bin strm) (incf chars-received)) (t (return chars-received)))))) (defun receive-data nil (il:* il:|;;| "hang around until readp goes high (they are sending the data) and then count the number of chars until the data stops. Print out this number of characters and a TIME of the input to standard-output.") (let (chars-received) (with-open-stream (input-stream (il:openstream "{RS232}" 'il:input)) (loop (loop (il:* il:|;;| "wait till readp goes high.") (when (il:readp input-stream) (return)) (il:block 100)) (time (setq chars-received (get-data input-stream)) :output *standard-output*) (format *standard-output* "~%~s characters received.~%" chars-received))))) (il:putprops il:testreceive il:copyright ("Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ b/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ new file mode 100644 index 00000000..c6a28f1a --- /dev/null +++ b/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "27-Feb-88 13:23:39" il:{eris}library>rs232>hand>testreceive.\;2 2635 il:|previous| il:|date:| "16-Nov-87 18:09:08" il:{eris}library>rs232>hand>testreceive.\;1 ) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testreceivecoms) (il:rpaqq il:testreceivecoms ((file-environments "TESTRECEIVE") (il:functions get-data receive-data))) (define-file-environment "TESTRECEIVE" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (defun get-data (strm) (il:* il:|;;| "get the data and return the number of characters picked up.") (let ((chars-received 0)) (loop (il:* il:|;;|  "now we start getting data. Just count the number of chars picked up and time how long it takes.") (cond ((il:readp strm) (il:bin strm) (incf chars-received)) (t (return chars-received)))))) (defun receive-data nil (il:* il:|;;| "hang around until readp goes high (they are sending the data) and then count the number of chars until the data stops. Print out this number of characters and a TIME of the input to standard-output.") (let (chars-received) (with-open-stream (input-stream (il:openstream "{RS232}" 'il:input)) (loop (loop (il:* il:|;;| "wait till readp goes high.") (when (il:readp input-stream) (return)) (il:block 100)) (time (setq chars-received (get-data input-stream)) :output *standard-output*) (format *standard-output* "~%~s characters received.~%" chars-received))))) (il:putprops il:testreceive il:copyright ("Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Library/rs232/hand/TESTSEND b/internal/test/Library/rs232/hand/TESTSEND new file mode 100644 index 00000000..a8d1f59a --- /dev/null +++ b/internal/test/Library/rs232/hand/TESTSEND @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "27-Feb-88 13:34:15" il:{eris}library>rs232>hand>testsend.\;2 1072 il:|previous| il:|date:| "16-Nov-87 16:20:15" il:{eris}library>rs232>hand>testsend.\;1) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testsendcoms) (il:rpaqq il:testsendcoms ((file-environments "TESTSEND") (il:functions send-data))) (define-file-environment "TESTSEND" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (defun send-data (n) (il:* il:|;;;| "send n characters across an RS232 stream.") (with-open-stream (output-stream (il:openstream "{rs232}" 'il:output)) (time (dotimes (i n) (il:bout output-stream 99)) :output *standard-output*))) (il:putprops il:testsend il:copyright ("Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Library/rs232/hand/TESTSEND.dfasl b/internal/test/Library/rs232/hand/TESTSEND.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..0be391a9bc1aa55f4d15c306e8e9802d77bfe62f GIT binary patch literal 1577 zcma)7O>f&q5Zxsu%d%ocN@b)C?1pe}LTEs;+qh|9m?l>iV~SL{lxqXIC>Gr)kwt-) z(gucsv}Xcs>RKR+`aksATy$tJzUN=`*mK~{=%cZN90Cv|cb4<^&6~H&mn6QU8j|WA zbeb*Km%LuL)9Xt6o-ZAGJ%7)Y_8~4EFp+ zYD-@gXZWSGJ>RW&-G;>L-Jaj5Kffat?@A^2k>9KP&!xhbtE+dU!t%Z4m3xIRmS#!{ zH%7~ScwQ0mF3$SGCmtc>+u@ZWB%7r;P7;zK0u4`tbV)auYBR-QnqjE|34aPQdF}vt z#nxoqtk#@-7-R}k*XzhF_nF&54GsiA34aczOEptgzcoM@1@X#D(!(d?`g8C3jR26kg*@VC}1mqfL zHVuQRBeU0P9h0*@xjCv0tAhFl_`HeLg+aFX4(CIdBaw(yX$q(&fJoK0s^Uj5xHf5( zYE^g)0!geu16?@kG(DLXu7@WAUcUs{VU5h()@{qIFw^1TOIUV?+18E>Fcr&`4V_nk z`y?9^5qhi|2b3iGLxzPE%>KX11kenB6~f>~@vaQckXKhHj`;jE$bY!+P^9^*B8^6H z2gOjS#fH1zY`Zc#T6Wvdn!eXQaNAvJal(7?t#rc2Q8pE2<8#oRYfxns8;wfbK$-Bx z*{!ncQ4U4SRg^981AK8wCK}}^loyMVqc%sWOLddqqlG@X-zMbt&U$XtP+&SsNcl}p z7&PG?8{jN)cPVrstunMJw zqN7#A;x(HgHDo7l77Ah>08`tFQDYn}<17Hb#KX!qzTbkmq@!1utSW{f%teVbz|3Mq zlS`Ie!R;f$M+wcsARoDt>d`zfq9#0G`ZS1b08fa_jOfZEDWdtkc%OV)J|}-ZdG$bl z^Y2;tTxjiq-h&5EU%&d{apsSIz#_L=^@B%^y3}k-`Cj|GX1gJGe6Q>7b@L+bsuif^ z1bZMpTf-0KX_ltXCS1ZfuPiDM?CcrwJ5 z4a;`G24Rpm@(mn(|e9Bn3|jbaY&pVp8y;= upNLTo!BnfdYwMe32W5lp?E2pK@E`Cyo?q`az4niUB>uwN-{d#v;^IF~3(Z~t literal 0 HcmV?d00001 diff --git a/internal/test/Library/rs232/hand/TESTSEND.dfasl.~1~ b/internal/test/Library/rs232/hand/TESTSEND.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..16d58d77d892ecd0e1b1cd20dce3e862fd38a97a GIT binary patch literal 1399 zcma)6QE%H+6u#Gvn>Zy|GExauqqPbT5aFsx*;dvG&9$Azt7B)j)3wrGvczTC5<7B} z0;(zj&z4}6MmD1VfmimD2cG)Af59WqQ#mKew3Y{iWZCzebMJS~`ObI!l5l&nF35hb z-|4!6;137=;XpX>1L4pg1}#@O0KagoTAF=w-!{z0UplJoOkTEXD65<6Y5U5?R^T=V zZd<7NUc342XF}563QQ~3XTYJF`reR)1&KJf`5 zUrnBQLh^ZvHc!a-{izd82;>Muqq8tu(R5X|RLM~l-IN&;{TSwowj&veWGSL%)EiDQ z3iD-Q;P=I@d*pVJfZibkFwsw8s?soIM>CD+lzzv442VfMQMb(c0<3e2TG0$u#3X=K zG3Nn3Vb)b6@ganH^ed3sUIZ(JO1IC#TmLnQd~}*XFlbeAq%B>ILKdbAu4G-3ccg7_q`)CIY}KMsICpFeyWJCV zJ|efS5jUP%@Sd<3g)43MpyRnBia~U}qfX#^J=YruD{mWG0j@~QB1OyxF*hG`+yW$i zPd00HWCm%ti45Sv*{`cNVm<+Op(gDBfv`h0b~Vd1YO3MTn5Ri-CcZK4AkJSYoctF3 z9P&t_2)s(s%PX-Fx$hCOy!W6$#xsp%2&uj)Fyjuq6Jv~Gpg^hx=EXHDn=@*kBP<1ROilq)uj#~Snmx^h4YMeJ+N-nSjKMk%2KP z&2~_8$tSg4TrWb5ceI)+%95@#3vnh3Fd6hHV#Ty-3@C<$O-aQ>ryZR#Pzu%JCHxrh zf$&+F*n&F2lb)6`!khjO{H_2KwRfq)PEJaMG4(IfP`QFnJstme zYQxz19PR**vzv@53Uj4@{R|*9lQ-qyU~2XUu(9S-Hs%pbHtYMAwq13Q$1uO=2L3nj XYYqB-&>VDp?*~GXf0AFd%gcWN`d^qh literal 0 HcmV?d00001 diff --git a/internal/test/Library/rs232/hand/TESTSEND.dfasl.~2~ b/internal/test/Library/rs232/hand/TESTSEND.dfasl.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..0be391a9bc1aa55f4d15c306e8e9802d77bfe62f GIT binary patch literal 1577 zcma)7O>f&q5Zxsu%d%ocN@b)C?1pe}LTEs;+qh|9m?l>iV~SL{lxqXIC>Gr)kwt-) z(gucsv}Xcs>RKR+`aksATy$tJzUN=`*mK~{=%cZN90Cv|cb4<^&6~H&mn6QU8j|WA zbeb*Km%LuL)9Xt6o-ZAGJ%7)Y_8~4EFp+ zYD-@gXZWSGJ>RW&-G;>L-Jaj5Kffat?@A^2k>9KP&!xhbtE+dU!t%Z4m3xIRmS#!{ zH%7~ScwQ0mF3$SGCmtc>+u@ZWB%7r;P7;zK0u4`tbV)auYBR-QnqjE|34aPQdF}vt z#nxoqtk#@-7-R}k*XzhF_nF&54GsiA34aczOEptgzcoM@1@X#D(!(d?`g8C3jR26kg*@VC}1mqfL zHVuQRBeU0P9h0*@xjCv0tAhFl_`HeLg+aFX4(CIdBaw(yX$q(&fJoK0s^Uj5xHf5( zYE^g)0!geu16?@kG(DLXu7@WAUcUs{VU5h()@{qIFw^1TOIUV?+18E>Fcr&`4V_nk z`y?9^5qhi|2b3iGLxzPE%>KX11kenB6~f>~@vaQckXKhHj`;jE$bY!+P^9^*B8^6H z2gOjS#fH1zY`Zc#T6Wvdn!eXQaNAvJal(7?t#rc2Q8pE2<8#oRYfxns8;wfbK$-Bx z*{!ncQ4U4SRg^981AK8wCK}}^loyMVqc%sWOLddqqlG@X-zMbt&U$XtP+&SsNcl}p z7&PG?8{jN)cPVrstunMJw zqN7#A;x(HgHDo7l77Ah>08`tFQDYn}<17Hb#KX!qzTbkmq@!1utSW{f%teVbz|3Mq zlS`Ie!R;f$M+wcsARoDt>d`zfq9#0G`ZS1b08fa_jOfZEDWdtkc%OV)J|}-ZdG$bl z^Y2;tTxjiq-h&5EU%&d{apsSIz#_L=^@B%^y3}k-`Cj|GX1gJGe6Q>7b@L+bsuif^ z1bZMpTf-0KX_ltXCS1ZfuPiDM?CcrwJ5 z4a;`G24Rpm@(mn(|e9Bn3|jbaY&pVp8y;= upNLTo!BnfdYwMe32W5lp?E2pK@E`Cyo?q`az4niUB>uwN-{d#v;^IF~3(Z~t literal 0 HcmV?d00001 diff --git a/internal/test/Library/rs232/hand/TESTSEND.~1~ b/internal/test/Library/rs232/hand/TESTSEND.~1~ new file mode 100644 index 00000000..cdc675f1 --- /dev/null +++ b/internal/test/Library/rs232/hand/TESTSEND.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "16-Nov-87 16:20:15" il:{eris}test>testsend.\;3 1215 il:|changes| il:|to:| (il:functions send-data) (file-environments "TESTSEND" "TESTRS232") (il:vars il:testsendcoms) il:|previous| il:|date:| "16-Nov-87 16:09:59" il:{eris}test>testsend.\;2) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testsendcoms) (il:rpaqq il:testsendcoms ((file-environments "TESTSEND") (il:functions send-data))) (define-file-environment "TESTSEND" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (defun send-data (n) (il:* il:|;;;| "send n characters across an RS232 stream.") (with-open-stream (output-stream (il:openstream "{rs232}" 'il:output)) (time (dotimes (i n) (il:bout output-stream 99)) :output *standard-output*))) (il:putprops il:testsend il:copyright ("Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Library/rs232/hand/TESTSEND.~2~ b/internal/test/Library/rs232/hand/TESTSEND.~2~ new file mode 100644 index 00000000..a8d1f59a --- /dev/null +++ b/internal/test/Library/rs232/hand/TESTSEND.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "27-Feb-88 13:34:15" il:{eris}library>rs232>hand>testsend.\;2 1072 il:|previous| il:|date:| "16-Nov-87 16:20:15" il:{eris}library>rs232>hand>testsend.\;1) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testsendcoms) (il:rpaqq il:testsendcoms ((file-environments "TESTSEND") (il:functions send-data))) (define-file-environment "TESTSEND" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (defun send-data (n) (il:* il:|;;;| "send n characters across an RS232 stream.") (with-open-stream (output-stream (il:openstream "{rs232}" 'il:output)) (time (dotimes (i n) (il:bout output-stream 99)) :output *standard-output*))) (il:putprops il:testsend il:copyright ("Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log b/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log new file mode 100644 index 00000000..c202b6da --- /dev/null +++ b/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log @@ -0,0 +1 @@ +(10019 PASS "DANIELS" "23-Jun-88 20:18:21") (10216 PASS "DANIELS" "23-Jun-88 20:52:14") (10217 PASS "DANIELS" "23-Jun-88 20:56:20") (10219 PASS "DANIELS" "23-Jun-88 20:58:45") (10220 PASS "DANIELS" "23-Jun-88 22:01:47") (10221 FAIL "DANIELS" "23-Jun-88 22:22:53") (10226 PASS "DANIELS" "23-Jun-88 22:26:08") (10230 PASS "DANIELS" "23-Jun-88 22:29:54") (10253 PASS "DANIELS" "23-Jun-88 22:33:29") (10255 PASS "DANIELS" "23-Jun-88 22:37:02") (10275 PASS "DANIELS" "23-Jun-88 22:39:03") (10283 PASS "DANIELS" "24-Jun-88 16:37:03") (10295 PASS "DANIELS" "24-Jun-88 16:37:49") (10321 FAIL "DANIELS" "24-Jun-88 16:46:20") (10333 PASS "DANIELS" "24-Jun-88 16:53:48") (10334 PASS "DANIELS" "24-Jun-88 16:59:19") (10355 PASS "DANIELS" "24-Jun-88 17:00:54") (10358 PASS "DANIELS" "24-Jun-88 17:02:14") (10359 PASS "DANIELS" "24-Jun-88 17:03:17") (10361 FAIL "DANIELS" "24-Jun-88 17:05:38") (10383 PASS "DANIELS" "24-Jun-88 17:14:10") (10387 PASS "DANIELS" "24-Jun-88 17:49:10") (10388 PASS "DANIELS" "24-Jun-88 17:49:29") (10390 PASS "DANIELS" "24-Jun-88 17:55:34") (10397 PASS "DANIELS" "24-Jun-88 17:56:36") (10398 PASS "DANIELS" "24-Jun-88 17:58:17") (10399 PASS "DANIELS" "24-Jun-88 18:00:03") (10400 PASS "DANIELS" "24-Jun-88 18:08:52") (10423 PASS "DANIELS" "24-Jun-88 18:25:45") (10426 PASS "DANIELS" "24-Jun-88 18:28:34") (10450 PASS "DANIELS" "24-Jun-88 18:33:26") (10459 PASS "DANIELS" "24-Jun-88 18:36:20") (10461 PASS "DANIELS" "24-Jun-88 18:39:08") (10466 PASS "DANIELS" "24-Jun-88 18:40:53") (10375 PASS "DANIELS" "24-Jun-88 19:36:02") (10019 PASS "DANIELS" "30-Jun-88 16:41:06") (10216 PASS "DANIELS" "30-Jun-88 16:41:12") (10217 PASS "DANIELS" "30-Jun-88 16:41:15") (10219 PASS "DANIELS" "30-Jun-88 16:41:24") (10220 PASS "DANIELS" "30-Jun-88 16:41:26") (10224 PASS "DANIELS" "30-Jun-88 16:41:28") (10226 PASS "DANIELS" "30-Jun-88 16:41:30") (10230 PASS "DANIELS" "30-Jun-88 16:41:32") (10253 PASS "DANIELS" "30-Jun-88 16:41:34") (10255 PASS "DANIELS" "30-Jun-88 16:41:37") (10275 PASS "DANIELS" "30-Jun-88 16:41:39") (10283 PASS "DANIELS" "30-Jun-88 16:41:41") (10295 PASS "DANIELS" "30-Jun-88 16:41:43") (10305 PASS "DANIELS" "30-Jun-88 16:41:46") (10309 PASS "DANIELS" "30-Jun-88 16:41:48") (10333 PASS "DANIELS" "30-Jun-88 16:41:50") (10334 PASS "DANIELS" "30-Jun-88 16:41:52") (10355 PASS "DANIELS" "30-Jun-88 16:41:54") (10358 PASS "DANIELS" "30-Jun-88 16:41:56") (10359 PASS "DANIELS" "30-Jun-88 16:41:58") (10375 PASS "DANIELS" "30-Jun-88 16:42:01") (10383 PASS "DANIELS" "30-Jun-88 16:42:04") (10387 PASS "DANIELS" "30-Jun-88 16:42:06") (10388 PASS "DANIELS" "30-Jun-88 16:42:10") (10390 PASS "DANIELS" "30-Jun-88 16:42:12") (10397 PASS "DANIELS" "30-Jun-88 16:42:16") (10398 PASS "DANIELS" "30-Jun-88 16:42:20") (10399 PASS "DANIELS" "30-Jun-88 16:42:23") (10400 PASS "DANIELS" "30-Jun-88 16:42:27") (10420 PASS "DANIELS" "30-Jun-88 16:42:30") (10423 PASS "DANIELS" "30-Jun-88 16:42:34") (10426 PASS "DANIELS" "30-Jun-88 16:42:37") (10450 PASS "DANIELS" "30-Jun-88 16:42:40") (10459 PASS "DANIELS" "30-Jun-88 16:42:42") (10461 PASS "DANIELS" "30-Jun-88 16:42:45") (10466 PASS "DANIELS" "30-Jun-88 16:42:48") (10386 FAIL "DANIELS" "30-Jun-88 17:03:29") (10386 PASS "DANIELS" "30-Jun-88 20:05:56") \ No newline at end of file diff --git a/internal/test/Maiko/ARs/ENDLESS-PUSHES b/internal/test/Maiko/ARs/ENDLESS-PUSHES new file mode 100644 index 00000000..057a4424 --- /dev/null +++ b/internal/test/Maiko/ARs/ENDLESS-PUSHES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "30-Jun-88 20:04:14" {eris}maiko>ars>endless-pushes.\;1 655 |changes| |to:| (vars endless-pushescoms) (functions endless-pushes)) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint endless-pushescoms) (rpaqq endless-pushescoms ((functions endless-pushes))) (cl:defun endless-pushes () (while t when (prog nil (return (eq 0 (logand 1 (return))))) do (print "hi"))) (putprops endless-pushes copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil))) stop \ No newline at end of file diff --git a/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL b/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..09f581cd9d01ee5f1d33e94311705808af5d1588 GIT binary patch literal 805 zcma)*Uu)A)7{*W1cKrvg-6+Gmb0?0av}?t#jzUaMx40|`Ij1l$%a*OxZYgOa$`}l9 zygA^cPEJL?gWq6Y_<8&a^-Wf!6E6mV<4({hrywTkD-pwiEGe{ZAK_-?W@L~-BMlJB9?9vN)@L=cL^;&tLEr}<}mQOWA6yF zUKosyy6-k{t%6^KXCAI@H5wauv(l{8nopjVb8VHHx98kPQ*YMl<=pJM_#!{_5ke>N zl}D&pl%jPOp#qX6am^pJ4U=dtQ5n%qTa%Ia$P4R~sg|y~x?)&Phph`hJMf;_x-c?2&I3aua9T5KLOkB8vp5#$VfvEdqMvAESa7Q1xTbxCMaa4?Y4q^>hzJ+sZNmcF zaIKaGZLGt4zFw6-Z0>MEm9NQL`&>!pn-x)~d4fw2+o#2U?cabTkzzR!41~ ztU(@Ly7~#^H`dqjr&!8ADHV%sy28n|Xu>}atd|NKYk)yJUE7# z)3tY+9$vePTg3n5r78`ftW-t8|3aNo3IC%vT@`W?SKi}xc|uXXm%`w=hRoN=5C5|_ zRTiZKR$#+K{#k4n=dEm?-_z;0ZwToQy1&)F&V*~cz)beC{EW$xAce!JfWn#K=OwXy zu2B)FMgOapIo#zH{NV+qelYO>??{V#^SE&*8l4Q%goN?#Vsre$kW*2}SygMhJ!l!` z3EN{G&33|+!#Sta6tY^u5;#9<`wft){Jk(FW&8 zgJ?P!X3J1D7M>f<5v;^CK&aMMq1jWfR+Uw-j|^8=!O|Sp>Oo1|8%kzmMXd89${>k> z^4sV4^@Pso6Ue3ZJGi1pfPL>`qqE8M^#s;u5OQ%0D}Z6)c84_Dwva{(t$zGsb|fl&=Ye+Iq)!V5JC;!GQwgSBGTNk|@Q& z9&Vp6jku2SxecFQ^xPuD<6kryEsrr;2r|?x(jykj! z+NM<&F<;fzR;x8w6N6UvSgp16weLMETCMHBtFLyUq_6Mwz1GtFf9Kq9X1+;=Rc!13 zUnO(*``vrax#ymH?z#7FlhRj~x-6y9^&1+(!DdUet#w0Nt7UDp+0qhiYpx4g)*{~W z3A@+nyZvgv-RHly%I2)}Tx$#XJ=c1wOFd(}5z#Y+}1M$F=+^NN=)m_KJ!xy|Pi-#X)hi6n7W(`)cbUywR^)V7 z2mFQIUAe`U*64z(ze{*-IeKd`|Vzr(^pLy z(Y!Lht;B@{6*xhZsl?{9XUpAPX`gVng~PW?=&CeTbdx%Wt`3kpG2!M)-CcPLhIOL_ zc_dAx*2|;O`gF9d+Uuz{T|iwaB3YPN?j5<^J5*$m3-O~|byas)nLpIfqGL9CQEP2Oq{Y%2Y-vRth^#dfv}~+x zZiu$ESfU&1qV>TROIr)brXj*aModS|4iwKf9Q z&>FS0);0w#b+yew$`TFNTfA*x7rr3SyD8LA7qU=NB-&~LHwcF}Th?^>LA1!&ZWPMqZ_BppXx02^U#}UbT zL>g=l?Qk4X?xDgCjIjLu)~1RaFcOIYwOW!jH%1dd>2Z#EM3p3kMi>3#7^j}<=1^rv zS`B;FT+UAOrD%Nm4enBpyLA4=#5dscUC3$G*}_TlX>+aYty{!S{RFKgUu#jd7Sr5^ zIA+~t!reGoxV|*ql^)q8O%zN*2MK{?l$p3;3Lb~F7;hNM6~{>85tCL0l2CHGy9)em z%^-pZAt^pnY#_>*lMSu{fDl4P#}HCo?cJrMTWtV%E@(@ek_4|O@WIsZn!?|&?2w6r zj4{*(L=z7?PaS*0q%GGwmJYsAWq13z7gMB%xdBh@GBpv%&YVC1=de?xq`)Bsa%;)bu8C7kq+ zX%{%yTepmz`nlvt-=EH*V7^GpgcI=E%iYB*Y_5QvhE%D`jTmLVq|wUB21 zq)ZD%CNT!2cEKp~^a8{b=akv2{f_w}VWKg??q1>adfbGG?yj+=;b==6*oHl_v7tE{ zSs#qF>LW|Km;3Pu|9*jHg1KlyhF%qTvq`&{vQE~fb$5*`Zw>~FXmTMoVhKm1O>G;x zcbK)=D3e)^xr7=u&lo5+1_%W4Yztx^8&mGJ+lx@R$mQ`=1~6l!8@`!m13dMKOw4jr z?n2S!359NtyNCum1P{!(E|1M$R9x7(tQ}Iuj?vxQyK+`Q&MJ3e;^9d|TZFhwsId2)HXNQZY~1vuea1j@W;VT%?+(V3wq3G z{2KM!=JncE6_ErK@8}p~T&%ao$avo-7;+Bpx3NIH^XO{)a|Q^EGer9xnAPJz7;8u= z2h!pR`Gy1|IE)1ha58jRZ&;1j2}vY|++0ze9vSO&Qf$1}6ODO?cRQ&_yx)3jMfHY` zk2hA8+;bf!dJ$vS^)8AOW8agC7(1UG8z`WRQ6HaF`N_!dkbxx6H_j*0v%ZHaNGL+Q)T$235K2m7Ns{1)B z`G;klYsjkmIV<^*l{i;Aw`Z2m+u5G?CJ~}f3Yu1LNwXMaFq2rKLOFS$26Xt+B;VrS1_&7ErP~x^PhxDxH zDFJcOmx<>Bt+6V>MB7%$O!L z;vJ@Hk8734r1O5XW2(QoHqufTjMQWDs13JRii(OXEv?PL7P0uCX&_cXh7UuX_$_xS zqtxRwgzPJ;4I!6jc`O8wT@PH1D)V3shndd`ZeE6noH7pwAy{C2Vb^XTgz5pWSijJM zDjh2a5uyc^+3m7b*&s>9{4PKgeiKD&w`q}dO53S)cjXsfS%fuo(c;CtcAk$V@B>{l z&TM%O@n*(@SV5xW@=qg@Gwsouqv!@D5oQw-Z!NxtPVbijF}zbjII!g zT~+i0(H^zu3{bW62B}&Ea|f*7PT$(}Ryg+u2<21g<)*g|h7N@ehi=Ll2;G!B5JJMZ z0mqSCtmH(PwuwHEtO4g z9}3-+KhRk9`5-BBn02qy)m%D3_;(rGg?_x^{PEIh=`L22sW#qRtztRzNM`r|^F5GIE4yypX(_ zi1{=TsI$sbMsc4Y$}NFzrIJFW2#t1@Im^rKUc0;0jyUN}#AVw{q0uNRw>e$e6xV^c z46zI^@o%INDK8PC>=M5S2{Cp_i3o`W)DnvbjT26ea1^TWdtjH6tX%Tzo}Qkcz54!5 zCte>~v8+{n@5G5u?7s6iJw4w)^v&0Y4mTcGvHYIfrXKq3@e{A#+4J)|@%zkgj;n73 z;Q5NXsx*4Y+WXbdyw7E7jvw#osd@SKcXm4uop|R)`TM;m2A;g;3(uSw`1%v}_r6^9 z=Q|Fa=zZqIQ$vSN+;r%~b%#!TV(5D(;JN0R6Yn4D>3OQB=b00)UDNoNi9a?40)a!% zjr|L%`Oz2Oc;V9QW%jRp`S!2>d9~xWH;%tCaN^FVcb_Od{&V%YA$8$TYLNNF`**(i z-eXVCw9aik@qSHU_ZIF$`}^Pg(;d%j>J0?~Z`@9ux~&b3d*QuB3%}aaGtkpB^!f6|D^$Sq(ucvBe`6c8WGnE9M32L_Jm%n`5tUXyu0N z8VlM{T@8618Da&ON&0};AZF!2wt?|-a>0j?c~EQE>jDos_^h%~MD))RF#}=lA90+c`%t^f2_OC))Uz)a+2i$! z;Fq42{>6cxr$T6xUf~UTL-XWODY{ya=xRZ%s|B&Hq9lV#uL03FV%2(bTwxVZ8~`xx|8&CvYn2N=()H9_`asR4fXBeI@>;$571R~+ zp)n~wbW!3%7sWnwQS3t@{X3z(&&rq#(C)!U8V(pfB8x~3EkK!pXQe^?t5XG@`p2OR zygH(JJ^+aIOg7Q1+$tjlQlQ&oIU-fDB4H=I$|s3fJQlrKRYXDfR;OOg#|)%|zVEN- zUnVNfBb`K?v?xbn1F?)YR-tUrE$tN!fCMKwe0u`0uf|9$A!s)7F#oE#yq2 zoHafQK8s*Fbm27fP*_MvT=u?1SrTz_^jr+7AZK3BIsOloYlI3|v6B>~tVzVuxdR$wgAMzcX?^jeLsTOt`%xmhIf)LsMapNnT7t3EsV$9a zmx!j;Rf)D;t=Z>`z}6KZoVO})3QZHqu)A(i@Ch&E!|L}bEv;7X{!%*d#G5P`&} z#aD~~8JP#o3q?1fGD~eZY^ldst8M1ZoEA~q2O8p1XtiZi12%WC?;CG{g*Jd|H=?-6 z&BKMVV+q|Fg>sgJtY~w?x`s$?I4*5*yUWUx8l(5T-a_IVK2VP>WqspM9}nUSr7;L4 z1B*c&Zy$j;-lpVHMIUVtqmdh@S8j=}X~X~(-yjY^`PM<)Y^7~Uw5fFt;rqhwu8WxU za^q^E%}p&EYO%#dTUTqNZIOD)rTjz}kIDZ%U34b@J%)IwnBzNy_d}Ttjk>*v^}bcr zE<5caql7$|C?Ok4%gu>e<#~xb(!0>D6zcz>yrh@$+4VeT-91~u-IL$ZccDy6*c_U? z`S<=#S`&A=mBW2M@Z=tVG?2d~Jy#CxL#&wcw^iQf$%W{!Ep(43w?dII`EL*PO{keb zq5$%fL!wth-6U+qH9#CNW0X!Q#GHWX6d)*aVC&sw_d@fD8255tA*S!`U3rC=GD;m# z1p5PCcTsg|VfQxd<@#3n{PrsB3VCmuNSyUs*XPzI%;UxCmV{S7TQ7 zo9@)+twT{WXIPCL{4_UJ;_`6jJzV#e#NPEMNKu9HWSMq{ZJK2*Hax|~H=A5g+#S;= zcJIiO71d-;&&V8;n>W>R@nth-$=weTk!=UbvP}c+Dd=$J_PL-__F}JEG?B8RP1glH z(Ap90^^+Yz8gFs!4;`qG_eG@O!3w1&ryx%@6Y37T?{EKfx~X# zcW_(fXWWecyWIx#=Z-*sehmHm;U^W=*vdV+B(_`Me11}8Wg)O8q`;@Kb1)23#{Ky8 zII>hBi}Y4<^?lQ{S*Dd*u}$=H2|Ihl^s~qGF%CZGXXkmqHCv8@RREMzUZ4ddL1{1l z_Csm57&^0=*8a(1r3rmsKeYa@^#frO`2nGv+(h&>rd&x|3;@cy+6AT?=>ZJ?K)G9< z05ZwCVL2$f+>L!M?<(~o5D4bFvD#9x2mdYXaN<*AP%-`yEFpu_p6x}YuBCuSz-@tD zND(UZE?rvcsa`e5&6YRF7~8=m>yA91-CtDZDGktenvF&q#@2laBNka(ET?yO-9(g! zeRk~LV~)e_J#lnVtFD%xV=0NYhAcA;pR%}}u30?UCB^z@(PYzx?f>RrD{U1o^;9yE z-AKKN5m`-~$k073KL`KzWR(*mE72zdC0)np?!AVcz5;Erxk6jIK+u3tJM9tj@}7wt z`7Kq55zm!#@cC1b5DmB0Mo6qQLV{LJe+N+HCxe1$)Bp}I_o`PcUivNoI4ZTPghbsx zo746PEnFNN!r0-t<);V7!~w-nFfv2+p&BD%t0`mewJU>XynAiYDUARnu# zQY%SGKBi>40be$oO&yASy76?AaXhVxk0*+y0rhtP$Jk-u7&fBBY}~tyiK=gkW;MCA z(knRBug_5zb7+rAhzrjN-8W5Drw7Tynge6%QfvQ2eMB{4j^g=B%u!;PHNL1|7&%Td zjK=ZjUzPK;ij$3=3sa1qYEShUj2#D!og2=4>?CS6j2uJch;cKY2gwaavRDx(i?E6z zGW53}BBNq7!7VookZOi?@73(|P1YPHr&ckaL;XUe-E$F#_NXp)pA)j%Y3G@f%(!8d zM#bL&0(nUg7&az`Pr43Mg;tqz(ml)B_BJCKY>bnEE>-~&!$n-mA1Wvy=kLHeCdYsj zaFedF$WvZkRI;k5xX6|u8Pf))gWen1>6;l_brfF&Us}LTR>kH9ty;|7{S|_G#00)) zBJ!mB0;Q#PpD!&e2r9_V^NV$XR~g-Db&h$bn12iS_jEisVuW%i4rPi>0ph>ID&nMY zEiu4VDBXI+Jk&RxprT}6z)m(+4cC=1ochI3-7}9vdrYg@eU7!l^79i<3$KSYU-vF` ziFKQ`Bb>drF;AAAjz8>7Pm}sCbvnc8?_vp!g&wKi2k-wRL9l`}>SLWvNB8x8pH|SM zR4}uN9hf40WKo$1+9-?g?T^2mKx!1xiq(Nf>#HtglY zC-+@!3!C5@CG}0Th0TLI(nrakwuRH+$(2X}K{mXj0F`_U)Ld)R+rqw-Hwn~2Mr zy`=$|3KNL@SO+iWyEN8Dx1)|R0+yu?dub(YaNnlYT&S&379c67+G}6o^aOmc8-$@H z+4y8o6#YqnZ2%`24Cb;#fYalx2>|G)Z;h;Keq?-DTLCdZ#RiOqn#HnEZP$r_A|BRi zuo%G?WYb#Mw>CLm`<4l`=m=-O70$Lcy?fO9v;7r~gWDSKt7sbB)^u+L(6l|Q!UW^! zPmbovsE-8{$VG@Zlxdkb5_2g zXB-8~6L@*kZ-1V}T%jIzZ*zC_eM~-N{n=qR8q)A-chlf5w(gkH9y;i#LW$Q=fByxp z{t2-!#Ed_vs=fl(w!V}p70Uj;M?qeKBvFU1my%a7q2&4;o`9>Y#7>4!0e4w7Q%(AE z4`{>V69hvZ8g^-=HW$=aI+CVqHR-9xUyN8trz}&!bf~tbl77c{`7(Kb!*#}Y zOn$7bq}Zd046LzNmQd^~BJm)KWZzKk#gPqPsg0D1!a7#w3h$<(%91;{hVnXXrIBVrPe`nWb=EfSf8TI%A(|7LK$OegDn}9pq4ez5sQ_6w(?O9wzj2`-|g<2Y&liAZ>28xjBfL$2u{W8OtD#|(B_)-8M3*B zN4b=LFX3O_LpWK94k!^Vo1)G2Et|T#OqMm9EiK($Ijq~QZMFm>(YAG=2y`{A(J0h# z&1%I;nAcp`8yl*niO8T6nq zf|t0F)3ufGref4FLV@s2JzF9vIEf+8VFeP)1anY-E$Y8$1pnOuc17$E#2^3AWUW?C z{h|1bP@t_DtJR@74{K{sZyJpyL-{o)X=tpxtZ21dxUPGbd1hGU&gQB55}rcf77d~F zOj?`*2F$c|TX*GRY{ybJrwK)%a*42gS1yfny*ksWo39G0n0cXApQ8o&RFmq*;LPi^ z-VAkqr**RSIrOX^jl+keM@BHad~h?xSuwb+Zx%JSVg!$>i1R3z-^X~=0r03wokv|G zA2RZz39c_tMa+tzw_{c`-gWw+H z<*IB-X+Je1fHHf$m;#5ff~Hfk0SvX&rOIMVAjKeG93Ree^x=%dd&7qF^u%z+-cC*+ zX*7c}f}nZTN(2wSC$H3k@TD4<^$e-UI*`l@%vFTXm`2kVmw7?tfBV&CT$?H2o{(wv z)l%;gZhYTF&1Wjt)`{KD{>wOW4@FN=+&9K%jRK79rm z$PpV!<4&`aAa)R*)OQe8>-$02NuZ;eEZhnp70u6ptSk;gsx92_HVS8*a8?S(DV(Lkxm-9?gp$oT zRtd)=999@Bx3bPhxm5t{R@N;mx6Tk*rU+-ea7GKqEF5AaQLGNDeS2*}Ke4TE3Jn4> z6CJ$2{cdN|Tj^=?r?BdSQsQSJ_(^49#UhP&e%W-C#6?;rNAICflCs|!P=|6P3I_@b{ayyk~r>FF8T{mu7l-q`&mwgfjFBn$DH z8^3pAV$HG>TOa4poquGr@ms#ZS#Eh|fZQ5i4>m)ww0?$Gw3ln?`gkA=|`P?>&E9M5gfQ5~TIir4vM;6T+A2X!-V_Q(Ko+(2o5^CRG#Y{7 zQCsj*m~2$rum!)=A~Lh33gxKNbI?K!AX4`3QZlTzx5B0$LdcXk>OFmVBOtl=EaALw zmnq+BqluR!A^~AkO|TnX+eXG>K`89%8H5>;;HDL|;kF=yF^iK|)Hb_uxSqi&3V7Hw zikr3%jY$R7_c`^?{QD>V6&8k-9kA(#0;0OD)wzPdMAAtn2dkT-8)Oq@mYyM=LeSWM zlE#ZFL2s1lPu$vc9N85Osu6&$A_~b%F6Jcp;o6is8(-txmb&!bWK8Jx-bo@G0`#RQC{bAhrcA?_j}ysZnA$>Jnm^+!}C))Gg+yX zyH&?7UIezIn^@7HYk)+k;JSi3g?o;OBO_xe5B@lpZ<}umO73;s{~4MCc(^x!UiUgE zIAv!;sG#ox2kJqNdnt;**Y`S#3?Qk|nlpfiTuIdds4`)wW&tJv2<0wW6=0I-R9u&7 z`IQUjXWz!XxmV1R2bwsP#j~XRCQpy@J~1!4F66YW1f)?nINfyKT^M+?wK+J%9NdjU z8zm%WXW=-kFBYNl&Ybcc!8*2b8`XT%I;>&IV$d?&WKh3;M2R*r#6_bnsp#&S$-INF zy1)bk#Z;4ztPSUk;`nG2@sp3Y!J5>LxhhfhQj1i&OELpkSU=E!c>n;6nf?ffJ%|Y0 zj*>~%j~4qa!8(2X9oWS-)W0E+(_fx91Jz(1R&x=o`f4nM28s_c#(=QH?*6OY6a#9< zp*BxGj@&M<1gaVaQAS=Lg5PzUC zjqaHxiC>@Ui{FG5h?XQvdUTz?F`Yz#R)}$6kMTi@Chz|3{3`Mth zjS_9ujban6d>kV=MikfFD6Zyt*PpO+u4UdK_|9y)H_76Hvcs|-wJmiWOtQLxHc27}zw6%B5LP=RZ`^wO3f$Ps6%VaGn((n`V; zY{}_^WLpi}b4+mjMPYA^*5Rrv3k>9&nKkJ}0(Q_`KX3Lv=tTM?oU7u{7evTOWr+nQrbxRJQF|TzR}dG3YTW^? z8Q(EO9=c-&w-?dXMRdoE16A@JGy5I5x@aJNc#AkAoz3F)70z0b`X~!Lhpv9BXU4y9P5|J$5%T=>ER3+4uo{Ko-$)y^1Yqyfq%~5pBMCT>-Ybi!~^=9;ERO}2D zOMELuf)@!HNZ>dd#i_-MIq5aleXGSR45`I}e2RI^s1}Rm@oUV()nbz<$F#5?J48Ii z(jHP%B)Tawhnf?!tJZvWL#!rvEc3ji$7G0fq^3y! zTgkJ-cSPFi1FChp!aDqBNkYQ@ift8i&=X$Gc|?Lw;M;jbxfcOooQ{s??-l;A;>bY_ zbj*?dkgC^bh>RtY8xvV!f-M%`LXJ9w1$Z**73RkB8ak(w1&GpF78bB4QeU3m)Qv>vWtQ-j#MU*1Dt=8SKB>s>plAaFl5j5{kC+ za0G(%;Ry8baAf2ha5Pos)MX4{h0GPuK~O81*;6G21@Q3jl=+jm4+?!zHnj*l?yEVfjS1ITyI9YiKZe2BCxCl$0S2> zU{{6}%+zW_|3S3qH!fj=B?$rWUc>>G6nv1tLO^jsCp(B++K2^`Mrp4jPOn!nlrm{T z=D{uTr)esZ2r`+qd@3ACyiU&8fTby~Eol*!9**Kh6kjVA6X=zSk8$rFr(b0N;WS;% zkj|ZB=ouHBDzhCm$ffJ~w~ljSrM8qj${0a?Z}N#lJ`|G0@i%8u+c12bD`>GSq%XOy zK(o;SSF_iLBpEwcmk^Jkv+?m`NUXsUox)~27WgrB!;8BzoF53LWezA8>|%35Kc4~M zaSf!8>f@w5K)AHRVkOZM)7)<$-4KaXn zsBt7DQNvk6^6R@y>DD@Fpc={*CKHUV+Lma9hhO??Z1%Ud;Wj$LAdbRqV6sywn6{cR zLM>6g4s#E_e1lY%6eF}$YAd(1g@47)tWlNr(k{gg`Uja~8^_Uq3H}?M{xc-ELt|m;(>`1jb91RVGKIS3Ro@`xAt&XC(+=e6ctGooJp1jq`q%CtQm_gby z6wbh%Y<#A8KDV`jNI1>suXOtzJS8iAyl_zZxOYmgi4La5ZvgbRMQD9(E<`PbwA3W-orA)(0EW~WX;~X=)>-e%yGX#0Z_BHueX6>P zc=Z{(#HA@u&hX?$)c5`nTdUsd$psicMto%Zvr>O00_5l99iIHY>nH}RM!~;Fd&a$t z;G_Z1r0t$bogC6U6OKrpar%k-37BU+#IQXRXr8^P0QasS6jnS1IaKksKGMupHUe4r zmnY{`dZtj_o+L z@API|(sS5-$nC;CFjeGf!aY0esj=W*8}{L=<0d4$mV_6}V=B|wh--N8kG@%e%XzA9 z$~o-GK_iZ2D@u6RqyhJSUd|s$+v||S55DcdeKQI~)b;<0juz~z2+`bCcPWz<>HL%$ zpCaZ;oYrT8dRRAH@Cl2lmewZXv0|0VYY#f0&C+J(dJrRya7H7{x6?OygX<7b#}M(5 z2DLdFCg!cuHt1+b5-b)VK6%-y2ts~&46HCid<`N=K zUcOZGuWg&Hy@Y+&@$ax?t09S(I?(9r^Fgs-mDE00?Ha**lz`CE%FBgrPZqm;-;k74 zd{W_^K~=2v#JZreBlBv4ms}-;5x0o;Fb-t*bWZaypk+79@v?^}2ict_(j>)#3y^4i z8auFTf%bKEY-$aC0J z&DvkJky)VXF!3mt4%1cIqutR~NNX$+@GzI25&FMpb;cq4~uNFtm*qm(y*z%o*i&a|K$Kq2KuJE1^E9UtEf~ zQDpS(^#-bO;@alrJ+e|)nbSvCkk3GRcDcvx7rO{qS1`0%>E={<^(?OAo{JGMFSntv z5D30qz?qJSHMBXOl2^B4DM*tB6rH$+AlNKe<;QtMN}uJmmU5?3E-nzH(fux6=-rjK zGT0ow1-ov|8=~UY0;Hu6(9etX^L6@pnSQ=;tAvNG~aD21MhP@DIi@JC6@RPpC z&1JTai-mUzc?CC>t8`kBPEJ!^{6iyk^H(Y$ib-EYN(cV9Yi}kJRJ}gwbI7ai8yX^j ze-!^yU(>nMWMf2fWJ)sdoN4o0_ymK_c%|LlyRw$$%~No;V3$?cv^MSy9Dsaha#iBI z#2Be>s$<2`nw+CGxkqdAkJgMkS~KA&_|DP2uBM|0`+i7ELxJLUA%M`G_P7e(UMvKV zSa7~zPS73OTsl9VtgF5LMP>3-kBZ~z>g(coy84=$NqthkCydL~e-oDtsQ)TDY)&60 zRWpomo$tL^9BHmNc7BMTA8!zGHM&`$IuZc~nzUB_C#VZjqmj_19y=rCan|1nbX}BjI|q-q zvNM>#Nd|CYmZmKxk{OzqKuiV@1LB-EZLvtw)6Wb=i)S%<)j$3}gBiMS`_u#M95I7| zbP~+u3d}Iz@iSz^PHqf4u~cb@v*`JNrRirdkgiNZQ(a&L3p9)qN@Ern0?TVWP#G3O zWs;-vYX_Y>D_k@7ce+9a*YB%rI(ne*=T2g9TpuyGxCa}~)LCM1OV4s>7_K&tZA3w+ z6(-xgE4bF)DuIJ!o+j26sy+}RcoYFGP>*}r8Dtofl`Y>7HUwY0#G?RG;b{GvB^Z?i zaI-W#Bj9{VDmW*xtG_3d&z1qv9q}I;cx9L~|8?lETkZt7V~oZ$+7g2-_KiRqhCF8i z-39ZLXn0L(8pa%8oW;)*314xRBrLAlH-LAwAlra&cvD3^HjP8E8Cm7kl={1gpvNrS zP`(@wO>sT?G@N!l)A8}^*crs_`Q}cHRH^eN%&MKY-Zf)c=O>pvy|>f)%&knqCrt#f zr=}p~7N|tR!6LpOemGD6)JU006_7Rpn-3U>=!RH)x%m@4n5XYZu3`P&fFtW^Gq%kiQ$q$ri*n9rXwJ2 zp(yqEW_AXzz^e4Kmd_5&knmRkoKmRvvuiL?(%>UMrLCb<;O(MRc;gE-i|RtP%?7mb zPICv3k*U_e8@LvF>;&8|{er&|yt@EPrYU5ZHS*dwElbHnrVM0C zM<%m2k!_+f*3{OQ!&pIBL}jjvMn#Y}_p)G$QUaS7GDuk#Q~m^NBW)X&iKQ*xI;da9 z8#iXUVXXxV!V%x53+1w~i*&WN^g6_0TTH;K2w%JE`eE!}P^Z4;ThM6Rux696II zjENpeSfn}TYtGr4a{{vBKGXOuc@&(j@x`X2fSHsAT&&>#C1=8=wUk$WNxP1mM?`3c zaBdNiJ`r*XXO4)>B#b}a}={K8!e>D`rDtVDGn;y?kD8pq?w8@4lY+iOrIUy`qgJNEyGbqy}F zB`q}H{YU-T-Q6`suZ7|JyJH~dol$*&;%B3g= z``#VvRQC0K$I8k5vrrGp#LwkUk`Gns1@EHkCngQhk=vh-g|!CsrS#W7)hZ`K!l#h= z1!|(JCBP5Kj6iN+rXz2_dE7P7X^(RB?Rv;W2D#dJ@$jS4u$EK`7b6Vzg1gfq6tsw7Fx(Q< z#uE$IHfo#o`m|fQp8L8~TtSLLqs5biWQWm0pF;w!X(h{YRD`e4kcDE{=f~BJG)qhO zAOX4b3pI;qfB!bhi#BL?AQa0Fm3urtdp@NhGdGU4#?t3Lx>{p^;h+EgKLP<|*6izk zuJ;8Z&${h+3pe{8u=)WYwq?1;@+({O|v32&ABie@2}r2yBzgP-es~w?Fy&-_@Sw zo~1UY5BFL79ZOf*y`Gh~UyTWGMSUd?nzj)~t^OhDbPW2@C$x9S3oqr|01^!We3S4p0gWtwCz>^*a zANdk^{Ec6d^HGNe_UlVhP>J$uG&zeUCQaQo+VK zNt*d=&Mi)ymf}wT|8%x^zKs^y1SX<3W)!P;;`9T{$6<;3R^ zYPc7wb16FNV5l}xHe1ht z9vEu!Y^cUHc-Yj!o7Z~LSSzcsT@}&e#^{BsqZ?ukH$+hrT2LvL*W3n@HxnN=#wOYu z|4Lg+XhfBW)4LS|Pom&>{Ug`4MO%aQfG$1QO>m2K5cog{@Ho)-L*A2&YwF`3gUbHu zv(R@Y9#+*K3pJ=cZzC~S?qy>jxtA?))MIQeV)E)6k>a%w)5B@JeW@OgQW14<3gl{1 zgnhQ|vo=IKf>e#4ZODVCX4PG9K)%aU38Hsada)*`(9i1lcaT1=*@O;1?ZG{%@whmJk?PdR;Wa% z=wQW8r)$PO+GAO@pZ8eK0AW|13&Qj_Tn+fTRp9I6!U-`dhT%&}+sM(!*R#WjQa)SP zX&t*@0nWHlq^XF1XA|CHNgVS$us7|r*lUfcF$KQ%xdpyv==e(U0x#fp?&w-^Qgr?6 zhlZ|m8eg%Ob^mtwdI|WNeOi1qgqPm3A&L`*!MFliVD6hb=2oN_X|c|nDe6F0x*dga z`U_`}`So5$WBAcm2gF_vB_G7F!mzv4C1Y6eMRlQ~L)f~k!qz2hHLl<1QV#OSdfULA*gH5KqYnlc5=J2?26s`4AW*u%h*EBW;GhdF zi((vfq#*`Z`bVg}@CnoFi+D`h8cW{CRjn{aHohl~-k=q1il_5WJVu%c9jMqoI2kXc zrax4ZL-${-YLq80GvCVZ0qbO|=Jmz*1tvA3KaH{4+?KS;n7SpH1HyOlwGY$8M2%hqFZ zufXySPGT(I%ih6@fmVr+;tiP~shMMbLv;GNV0`f`Mj-4u1jc{502t4-;_6-<&zSx;RC^g21)}RfsA6*cvS9_=PE2oKWFZa|TZ`D$f}_$>`ie z$3G^dE$zUEkxXK71~Q37odcP`ZYPOM%vmuqnUIQ)P&dvmeO&nuNFQgrUK4VnFe^G+ z3dx~2$e2Q~8Sg&}8W9#mUx#|XGjwHWSLf4@-u*JsNve3zN~&nk%be4*6{G1Hc0gXYljx@X)*AA)H;>8cxUT6B@~2zH{~r z=Gt?beQ>vxn-v@h8e&28nFMQjJmLKu&nhWJk{(WCrou-i1yhMBY=}r=eh@~?duGf7 zSII<-+M8s8m=z<4Qk@{i8|RpK|IU>ro=Zs+W#@+`igiik45{MVXHON^oD)^Vv|huA zqAx)S!(|gSB~d(`APOOyus{;S{>h1=`1BlNm_{#|CKknLqD-fWaYmYm_3m6r;y_B0 zU?rbelM2Nh>`uf#T%U*k&RhkNyhw$#3RNL)6A=z9zQ}f zbZ*=wrs?}g5s?q~_jMJWo-Y}6pULF(u^2h6NX3(4FgaU#0*Q{Mv%~|9XRz@n!IGBN zfj{OEBK-(^7WxsmPmW}1At=~L?M4qBY^&(#tCA0}CN*@(wawMhw?sZvS@qUo$4;jk zTNBWpt=d~z_1>`X(WEeRtbMQ03p~%#B_^lSsTG~^%!NbDmnUe+L_O@Je#*W2?gd{w zrXGta&e-a@opPwh#n#2(46qlO7Ca38f+1Vql>xrXAs zbM@kn8zNUdKD=Matx8!BiuCk!E-&n%miP2f4O7vPYq=v+sUyQ6GqPVJ+c2z#ot-be zB|xzggIC`rY_ae?AhXNqHjvr;kg@Qsp_h*7q5_z|wg%S)n`7gb2Fa}>_VtF3j}kFH zD&IPYF%jFYo|cf4B1`9K_}yY)a_M#52Ixh!ZLwF>F;i zSK7)pXTVo}YJB0%B%BE0AHCR*c$o9gY4J5nOpYhT*ZKw+GV=iA z=|>z8%|NwsdIXmoT|bbQ%R6%iF~iV<^q)EGQfkKGX_<7IcPdWc0;CXr(*`Pzm}I_Y zyP^mJ_TY|+BWdjohv3cMlAcFT%j6Dtaw%n7)qS2^TTyN!+J}Uj-kQhJ9H1z#m3CD&yDwW%7W0QcTnGlQU*1CoDe3;Aa;MklzfqK7i)nd}UF2OV z9KJDkkp0h5O}}FA^W^<1-qf6E-G|E-6(5L22{{N=L=CXvXG#Mg>6p*h!crUVIVr;P zdjYSzh@Rl%)rb6)xbRYb5~mvKYFq0$i!261}jN9?!pRk!pAV7-&n&R&1EKL{l;XPZf zIq-!?JKY<9cL)1)UTE(u`IIEtkr!);<#!Iz+&MIqutkCx>38B?+u7y9VP>a$&l8_Z z20SyhWYBZeNZ_A;K4%2~2j+98&XR?(RoERpSY&?_D>dMS&dut0VdNySIlw;o{xZQL ziBDp%;MKWTfg=6^igfk-nW5+dFtdLM1Tix^uLw#j0xugjX!wy0F=%w;ENcf6=_fIM zcn}%TCdLpCq{KMl!2~4fW}2r$Qfj`n>9jK2GWkFx5U6}7i7ipgZ$`v?KPiS-*T8ue z+vXZrm(i?T?yV*1%^aQWXXQGNS@iKJ+?`5^*^gT?~e$Fey3MCv`6F z?EevoXn(z+^X32C`wR8~%vZ-}i|Ya&zZ17)%`T7om}wI1N^e+WD=`#QgP5~JpBle(q%Uv8aLbZYGAiaQ&{QKrAB%!wNbJl+pgb;J!es8=pLg^p;hf4Gu} zOB?ko)XS6Uh&c1ze+wPa2kgWLQ4(<{HE4%;xBo7o`=u%CK0b|$s&7kr@|)r=!<*ujtoYp?>YGq=@;AkWru9i&GX(rV<0=$=yT!Gya*8*_@eZqa zQ=Ap5bLSp9rZmvzZ|N;tG^{d&-^kAw$JBnO zRB2KXquOuMaJm$_-nsKmOOh9+(&;5se(9-_xxxL(D!=(aYWj_YG}<&KRMy0whp)-0 z$$|de@B;i{H!z3i-#_DK75&}r5A^uEzO#LDgvFSd#qB9#oE6QRJ1^Z7(}Sx5F}>Gt z$NDZHb?x-IrV0v5e_SBCdpSFMrV2-`V)wancAl3{4kq4bKV!N2_enA{$<_ZkBIXZC zF&~CpeeDO8t68EJvNZ&@L6WW8+uJ)jI`E7Cl4R%QIJHSPM9(gd`&f2PgwB)foD5qQ zl#_wWQ6r&y{$*z)d_S=4Y+^~c^CepNSCQ;ozWXP<<_Dnv3Gt;%SqeU{5T|{!K!6tV zv~b*NmX{y+*DEQG2z`tI`-cMgz-gD~7s>}JBEbG=@02zDD)uw}w| z&{cbhqyCtI6+hG&_ZUuh&N*XX1>9(9;+9F1Pr!-i7rECq3|t-#ALp5ccbHOwfxvSn zU<9}(>)_&M7yyO~wfR%Ht(lImuQ)AnT?B~n<~z=%8x36uU_UuMb)5ykN^B)Q1ATb~ zz?{Oda;pA?Ju+0eQ%|)euNAR8v(c-kyhX7leWUxiTQ%&}ox9~a#|A&D+ zDGpwzkr6H&2HH{rZMqd?Yog=XAX+r^lu-THX<5M~y2V@ko{Hi8;GNU+gEOCP0wqQZ zsT#osc-YImV%W#IK{_*6^*A$Eb@0?SY$}+7S(vX8Ok>7vFiW$(i1!~2tg{>sip8mS zzG1Er)a#xN5N83zwqx>dB|*R{T8&DX$0n{0kynB}tfH?m)BVSTv~lnDoFJVhW^Jn# z0OdU-U08}445sl$yWq}4cVY*S>>tFAEtx+gLERT9F+e>rVF{>TZ-lxWhkDUR5bDNF zrgMV&$#(usyrm?dP1uO-;}yhtM^(V(HvoA!V_s_nvd)`9+JzrMARATTX9r~3o#1VX zrCal(g1$#=QA(BWMYD)vOhx6)YBeYF%lAik!gtl?XbxzP8 zv9KlJlNi_D(cS@=UJxf?Ruveadd09A@D74%w$7f-Gzo%&ul)ys>DfpaRW_r9aekpH zD3|x)gc<=fpG3L%xBWwPvWDJic{ zqU*KaIsIiwXKs&K?QyM2td`S+Vq90L_ue2Df75CIXu3GrNvGMTu}nDP^$dzNO&-UI zk@Q9`d%TvNLEOfS_W%{<=5Y@l9PG5-4E+V3U(grcRzQM}La?L=2Bdb{EU~DP$6lmS z5);L#?eRgfV1%6bWGNWYXktVq^K~)NL`CogK5>$`B8lWg{hB$G&v`xHwo6vEHK!HL zq1RwV=9|Feh-JFaYj7RV$ftav=gb$Bc$cJz4AT=s#hg;LLC<2S$Q(O!lAf&MfQ;@O z^A6c$u$Th9TIYbKeXi5y)IP_nc0dQ_FgNabt8>|e%~Lv;wcHX0$g|4ZB6!|C8nK}2 zxF+Kt3`C_K-qOY&n7J-{sB$&jtHC4}X5q9Z4WU)kY9`PfJAw(DkGupkJJR zU3caLWM5f596H8To!omh57lEch=7ne2Awpqx;t(YBbiBuAz*u4l8Am@d}8fdCLL?h z|N1-K*M66jK1|h(EW1PfJoyLis3LGaqY^mna;LLbhQqq`qGHKj#J837aJWghswyFF3 zzH{~=As}vM;`|Yi?)iP+J_7JsJ;p+7mt9+k3k0ZHZ2M zSE8qLOW589zWq^mz!Tj4nUFgeTG{0AH0moI%^`iI?sw`gcd(N9pI%xR%t^7OGu+x8 z-f9m;dOEwdw)Wm_ufE@|Z|P2KMk!Uxmo2;7UbT2d^^z6$F0L%Ba|FGjpx-gsvK33J zD+@n*K6O-^olq3zVg4yn6q`*Yx5@1+F`jPHKc)Q)%}!FkYH^s!};P(k&u=i@VM#i zjLB4P-O8CM%7V3SYHFx3HDp3uwHy!a)1OWyU7<*{OKMW0qq{ZQ(Pi%rcXfjYjqZ+w z?K@gKqlum_dt&>R#MW?^y{8LG8tveBUAVQH5k$Z?rf3_jb4;7yK zNuisWEuveEY#DjYzO^2oD_tv_AS?8`x{BJCimD0+s(KZ(HZ^1g-&E(LrcV)RNILES z=n_H0mX7AZ-0QbVM!`7XE9>j=14P-OQS zhqnfO=Er#8ce*b`!jxT(V)THEt5}ORHaP-~=pOWDp5deD&12$ zf%gT(;97#1LWIZV_JuqllqLI9)RgmOkyccvhAcUfw!#9r8r?`>=Hd$_osnCiOV42; zqmprqDoVJ6S6g0z%FWX1w$=<_geI|D5`jsSFd$= zsW4+VMI(8PYk5}x3!U*qS5IeHSe(?*6wxvc)Xn0g@YOiHHQ{d`t+%CUc`ERl3~% zP(AdMIwsu?e&P15@dR{V6LdS3yeTakcgK!sXQE?UxTBlYeGjIief%`|`CLZEvJ6;0 zbSCnKN~3dWl+tVk22?0_&_b6noa6`&2<mht*zDV8Wlk_#uBjILV$&>Wpd4LU?K^XbT$2K7{j^5h#0+S;-? zHq}Dhk;ul9(dfp~QJ-n!v{8N9A${7w@LUy4y@cj&ejeN#L5#gVZDjcG_0lt#^{4Hz zma36c;OeCy#|9e@=%wcrWiaxjUfQ6k#V9l~JY($)DgzNHn1bx0TV@SLN~2f{SB z%ALB;<)P(FMLiZkUU#5^teMBRDp;#3_^g!FRmx7SU@9KL3vI0(s}rfOUjAk!4x7IZiB>MCPJ851_eNf5}Ppeo_H{0F#LM z^TxdoBNq!-Y#%J8reNwPG>M%LQH)6Yp{R z%+!!g)l6oKHNRkLscpV}!5xe4R8yqMsN+1b_N7C`@`(lF=jI!TvA$R8kpIlMka(OQt|eMtnj=_WM{vp77-;Na@USq0ye&*4c^0f%Q&$(tv1TJCbin&~&wMvgzy$ie8X=!q%0G0p3YB@TXf zb~y*#LcILu2V^lwIWF>3NNz)}yjDF!!{j!B~E;Xx&{LoSQF#nb2QNZ!|SAdA^Q=3pWzZ zL%G6Pmn)no^yw3j&b0B;p_OHhgaX{Ek(C^b-ps*IERDvBB@EBr&A~al2xfBduF1#Y z`BfbJe?>xqg2Mdj53ev&(;|_J^J~k4OskBPqcY}3$2?vz7*-aGc|cQdq%<3I zm8K=5G{hyX`2<9C(*zMsP#a-dM?T96FnS9I@0-0w%~FPErI}g4)H$=T|L5zOBy01# ziDiARSk`335;s9@KKjF}O<`IlyhY1V8b7ydF4G# zbCbn@hnV=;T%r7_eSLOzzZc=;uF%9iwxyrF4qa1R5 z25F2;n8hi6WX>E4K7j!>J1r=&{mj|8XBEl3okcXVo`cav>4jC*JRmp#$iZca8jZqe zpKai1=Y;J(HxqHJ!Dgq^9Sr8h`PKO_2N#yfSzI;kt?^9#hbn%~;pdGkQ%A0pBN-_Z zcM=hQ0t=;U%C$B}uA5m7Bf>h5E+k4-d9qVAEQP!-et%XB;B$+aI%j@}!}Du7xG?jE z@;YYdsiUS9HG?&KHYv)OVYe%~OUy^d?X2 z@~PpU&_05;c^2LfvU^o^!A%Md?*a`S%RZI7i};}xZNcqu_hGl;U<;z!$k&;1d=6+8 zFhk~gx7Sab4BI+)KwpP-a#ItwC*&Eu+3;((Qp;46g&Sz7i&Duu#yf!QTcca;9f@vx zXSlnkv%|h6(b*Z^(jD(rjv4;c(E?f-9;_LR^hZzD57s|X)BYjh6FcIjxK?8`nQEXT z@#1(j#v8ofp%lyvpm#wLA#VRKBX5_h+W^ zI@*R2$6c<`{?t_NDrb?K%AMsba8r40xk6i7I2c`S?2br2Hp7qkMw61~U9~z*zM=O* zie&@5yGa_WNhtluW2$tCkyoV7;qg9Z1m_w7?Owbp@dw;%JbH7mf;)RLSoy@FUj?#V z4cEK1Ml=U~&ZT5(vl{u|xHhWE@FU_eBLLsFDN?E!0g&vSHuZCkWdp=GW(38?S~a)X zR3%n_>7p5mTOTieH(p#5d;fCHd#4-P#|GOEG{nXRV^24rn-0ZI1M$4e|9IJ^nmmnT zC+=)V#IeE1ftV+*UAgo&buh^O=yRk1r0AsQ!xd?&(evS9;(mc1^y_K-v5Z)l$A*R7 z?5AyZOM_{|H|QG}eo%e0=DiUgDiZyYFE)0xiIUyYA9G08;r?c^&5b+;};V?OBgIkOc&ob()W+TL! z`&*7+qGbPN_$fF^)x%!e5z?D@hpFB^h4}x1?Ww(|V{@XXW2=2L4z#)=iJth@jyt;T zk=7kyit=76In^Eyw{`Q8K+l1*gip6_vMf*Ge$}$BTVuqH}B4&Q#KD-`s2ON+nCk)U~yC+QS`*o`)kH@Kkgs z62xhvdi8YdU2_7F_s9` zya&B31>g$bYJ>nYW}SKCH3jyET7I9R6{V7DB~GoZ!mv~#{|(50-c<&82=bjPF|46zidF8V?1<|u@TidW;}#^^Jp;Tq<`od6-}pCHDd!O-k3USSrj*MV{Il4 zqe~8Mn2Tt{T0px#$bhZ3q6vdKPt&-W^Mz|fwQE8?3#6QE#zyn?t8Ws$zHqLwsl;ei z>5$D7!sxW^t=Xg~SozF0zKoV_Lgh$hp1;c4O@lepJPl)m!*^2E8?G`^4H+Y4$r`CM zFj9@uNIjswnQM?{c)v;+u`R-pBHNVLq;wWb=~PMS zR2!RMXT}?Ko|M_&t1hL6KFK+;QQ0drsZ($gf?^kvdVh^zva3YBkGFB^GPVXs`3=J% zVZt3CR-nlS=4O_Mm_5lU-9r7Dc1Q;^OJpedAAXCPafJ!F zXP3Zob2TE|fTJ@F-CSpExrdsfoV|mCbHe*`&g5b8d@Tnz+>w4hxB1=F{8I9xwvR;N zclX7&emFQh6DGh1^&cbOd&%fNU+nV8@IUJ%Qa&Z*d?z10qOtS6gk7so>Loe8)oD}= zB2WP10q1+!4ScJ@r}~=osh*TRbof^3k^wu!g^(($^Ro`sE^hP)4+>>;k+H!NH?|5d z=~>}rJtubwpQ4zm$;87*IUl*Pw2m23ti@)b5fgrB(SrqA6ipjHmen$&J+Bn%i1Tu< zvycD|CY{BSQ%fsd;?&Z*mf|>Q@rqoI8ST(!s^Is+Sk&iU=->;QJ!@h6s*`V4o4| zHey?hSip!mjM!o$Hs6Sq08lLkxMtl1`?8S7l*(N8O9;3%8(~8hHfJI4)tp)5>h;U0#&9u>hOB4`)ECK0rVKomkqFo&pzb0=62lbd51w=gZ^q#8Ei?!`*es15?0>=&d)Jz$ei7R~ zxG>&}0F#5G2D>yq3v-aQuAxT*JqoRgQY*GuB<9P$F`gj`7 z!`*^rZ^$GTiG4=Qq$(!46BmmCu~-(0CkDpnxd~+h!n3N*5;C}N8kxxT7*1*lN9Z#< zQ%MV7U0Rt+PQf)L+)rxVN~`zfsbsNqdEh{DNeUO$#FdarJ~{kjn(#A68M21gnen5T z@gMnpXZ&Nv4lJNsY^6$@t;*aU^IZC&I)?7~*38C^95f4b>FNs(#iBTe!N@9cv+@0ezZxT@< zi8qL#J5mUhGej(u#AzZHNa7R`b0u+-h}n|(J`vL;@jW7Jl6aj6T+rpLze_}cBwi!J zB8d}3sFFAiLi?>GhKcx%B>sYkUrXXUM0_BLSBdzgBwiun7n1lk5${XlTSWX^5-$_+ zQ%QW2h%1u#b0U5$iEj{bNfIv+@s1?^jEJ`-@pU3DNa95z-jc)%M7$}9uMu%d5?>|a zbxC}Mh~tuYo`_c^ag2zUCGi{)FG=FdM7$sg(md^XNu-D{B=IZ}MgCw3JqD2x<645M)Cx}=riG4&gNn$S%9!Y$G2)88m5aE!-01*#JqMwN6AU;oE zDZt|dssMHqr~r73z?}e(5?Bb(M_>U!FM+uLWC66<06Pgx2cUI2eFC8N5TG$Z3x2Ht zpo@S7pp$?K@CbnVTY&8Zeglvo@N0k$0v`ZuBk)UrIDuaP@DA&JfOg{i93V>IrvMQG zR{$O+@MC~B0+#^71l|GIO5kmPEd(wAY$os)Kr4Ya0X7jh1+bC8>i`cCI1aFZz^ef3 z3A_yOAc2Z=-Rs*;RGy%8> zcmSLP+yJ!%8~_di4*=88k1Z)6H36TCQAy5EtF98ccH31c%3PAZSz+wWw0l0_2uK_9vd;m~E;Fkb* z6Zi$dT?F0-C@1i9fIA8N6krj7D*$&8_%Xok1TFzAB=8QvrwF_aa2tUO0Jjo&3t$0( zHv#MfP65m(@H)Ue0>=U75_lEh76LB=+)UslfH?$S0GLhSd4O3241k#gjsVOcFbFW6 zzb(vX~M(o!Gq^xwj(MofQzZWt2~XmZ%d;c__{^B-H8uF|7xQr3K}EwYM7-(D%NIO2hrpZQ7gD5azt7lpO{b6YqCu8XF$}Vc$`E$8I7YTDNVdODnf%ofWbop4H7JGLLH_zv^ubl}r7~QRQ^@lZ*6llcP4H!{vGz0sec>qn49cOkvo!y!5*Hu{RR$viw-Lgd5Gv{DpO)_kJDc1yjF-fBEavx*2fmD7-6 zQ>QRwi_fk8HXV~XZaJm)j4O2=tu~%j6a63MiBp1#k-+Q7I-U_Py3XWlR(`g0144|(g zRAVl>fKEBkZrh%sOIM>A*i?B-RTQQ4L&2ANJO_8AmQ;Y(ND zC3x|;@+DiT3fqRCw~F6ZHnCM9a{&fwCEnl(bJLO`V2*xuq8?;6N#@?oRuIbNc7;n-wEJQQD=_S;@7r3#il8occ%@Tq}LLj4MC%VcYa3N28nW*3svUt_t~Wl{iHm`V6Jfo}nvVW_*O_ zx|0Atj&rg5T{|!>0fy>~)3Y{8Pse6Xa%dw5L+d#>yoLhhIh}*UtaI8SF>w#oh$w6c zwL`)R4&5u5;wJW?+eGqPI5;Y%_5CKw@(4^+<^#5>tlOKu=iP~q$sWcP9#|lXn#_$_ zech;E$c?(>no*_t9hl_02^Dw%zt`(iacZMHgJ{RNWd~D7&7T!FJ8*&R63#4YPR#eP z(&9o|sUth-(PT+l=J}ywZ6AAfN?E5x4J*Vx~xcKDag97VU_3M-v^mATfJfjoNZ*BxOCAzF0_&7{u>*Zyzy4ryPQL zpAms{N2B-)0<;3Ianw3t1z^NT)_Jbxrlyu^agUC1mBQZ-;;?239}Ag*?&VG(RLvbg zsEP%6NK+KE6uvmP62j+0HtiMef^YNlTl7Rnm^gwm#I8nVkj;g1FjL_nXi*W>5%)@Q zvlKowks4i$^xC(@qDFf~*dL9{QHGHGLeoKLcb|=QG5A!s?6b! zFA`o%D@S-~rVMh6b3}54MB=P<)O;L~9Qi#ä*Goq0RBBA{flxBiNuGcL`A&E&& z3`M8qDo0i=p1p<)p2eQ0z){O0fKptq)MwH1-?day1FV3Q1)Ib|>PWnr{_upP*fM2S zR<`PE|H%m@Ph8-6PH2BWuX~l}L}LuzcxnACI&3!ZryeHzYWR~ zT#kM1_g#)rj})Y5h3l_r;Uc2@+u{#;1ldt!GG>EUKpz_hJge&Q6+c$&Hhi?L2l3}% YI=3e}Tgl9##@6%7ml0?``skzo132~tzW@LL literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..0db47210b8936018e95e0e832798a3d23c6d604a GIT binary patch literal 46530 zcmeHw33wdUk$?B}XhuFHOSZAW93Bo^wyZJ82N-i$BWYxfG@21}SQ3~+wqT4ddwND= zOR~-N{{mLOs_NI>?^V^SSFheNeTuWb%Ds zCf7>PT{n9}zVN2YBi?Z2${LTaI(Vfg8VOz*tSt+cd&9Gde%ZyN!TC@o0{0wn_J=Yd&@#zPsCg950=@K!~?x~h2e-N zQ0@tpyM2M$XrwUFn^)}W?pW=PHLY!mQQcSB@Rr23-t3BKpe*7G1`<2e&9>9Xb;wU1Ga2D;0Q(|cx4vAQRTjnmmjv}Cw4eMan^dusy&OniQZAZ zK*SsJ`@*%95ydNycuM`ap+OiR*-JfPZ;qPib=(|S6N_z9P*vqZQBA5Ks(P5x$!RGn z&U9u#qBnnjTD7|HjG}8)8*LV9Gm5Ga_6I%X=L5_3l$S?>OFW@5K%A&XZ75i4Ka*-* zND>y64tQ$3g%dy=Bc)#!tO?tJ^UKP?=`eAAtW`I%3KBbPAUcD!^rA3=>Wep&_qYh>PvA%M!iik>-{zsYo5|-Hk2nU9Rq? zu5Qqv&)v;UuCIcdTgYa;@oting@#y{-*i-A$`zi}KjPhA=>VQu33s z4&ah;^KAVbQHCsLq&`JIQ{Z-D3PAl_Dj*lZx z1U!b|WU)pYw`Nlk1+%OA>@>prelfT#-A(AJwIOMG;3$TqCmzoXbCL@yV z3-}_k1p*ysys0c0C9A5CRAlWmeHC(yHgk}2fRMYCL>)z+FuNics=;gZ29U?pl!qe? zwca|&T6`*Ju|HVq@zcljO_YuJky7)d{*Nw;b#$%iY!VhHv16=|O_@I!j)uHu)yGMK zMX4vJku2(yD{oZ<43#mSmlRfQGZQI(GD9(xI!Xe_F*8v1WQI9LhU91FaRaetnkO12xd?MDGNHH{SNOEu9_htD4%oN!_=g zJGz6fI$s|)c`UyH%V)PJ-NcH{rY1KT@y2EFN@5)yZEIFj&C-we=t}bttACY$~7N0qC$2UhHS?qw)f^PflpN7gNdeZh7)~> z-fZ;V?r0dcYkTh~daT$DW6m|}2PsFA8Y13w8mXK~<1ZGw!@k7 zR=ljyoTe)Jrky8IjmM1dt z$NFFjlfVwM2x**}Xt@=s^aWCxHNkSX!V^ioIo@(Joo&_!(|BrOjVy3o$QSXZ@Fq{Z zTHdfSC*@8GcP3k($;6(NM^pGCYa%|E#-P)zuN}-G$v^pMI*TM5#NBirr97I>B-6Qo zrj0J`SPxH4x@}|>$aIiy*`dU1Icl zt&DXvcB4;q@E3@eT4}J}{9INvkcyUiO2g*e>}YAgyBN;CNy&6)f^SAk4L&nsaE}p#CyW?1-QJ5&)p(3g3Dg%j#+TX3o61rf^fx3kN+S=3O^tLm zws$RWYF~k#sWH~&a=YEGuI|pJE-`|jKE`-Sb{IB-Y`%Qa_TKEWU^tE9t*=d^_=AhB z6mn9~8^KkB(?Z@Sjlw{HYh-ms;iJJ#l%8pb91&9fnHa%=o)z$WYCIO$5BY*_C$hd? zZ*|hWowh{pc-I0qhTrZ53wYRFys-GS^rhpt^6T5$7|_2ddQl?aEyT zt88@>r{t?yL_O4eeeU6w>+=o=wCl$o4vya*9N*J_whCe}m&T-g-4<^~j(EU!sQ=f& zyaO1`j^EA8r)0|8>-uT zI)VhGAg=V`U5;i9zwN})JMmHnd7z$1C*CzNS&uS||HWJR`>rccPXrX?DDe`KeJwin zi2XKw?u~d$7MI{Ugbo}5dY?bY&lT}!wj_tJH~6R?m5^m5qq)@c5U5JVd*7 z+T_HJeATAevz*zZ#^vQtb)8!JmM+8&cX+`y;`wC(FDoRUPQKqY+L17=% zS*%2DRt0Jz1F=Ip?9v>4`>CdXtFP$rD$Nhj>G?lTU$R!y~iL!(k1%>&~PhVli87z^}repJiY^uy;Q5k!+z9=Jq?5T`Fv&zb{_t?~- zl;(P?(lnS#LsZh5&wxb}(pZ$HHo~+PEMf(iaTX^5yI(Jv&)_U+X3k}-$S&-^yOL3| zHp64fQY%}Qm~4q@P@92IUu{MkJmHw5MQM1Ps}@|&)thk!lqQF>SXIWSd*=w=h|av| z9KjpS YTS9Qp?bPU@Y(@0M~1D@ok@FY!3(#$Vc^jdqBUXjt>j?mEFVpWc{rgBKf z4BR-B){9gA<|$Js`3xG=83v<7Jk=73PAZapHM6K-DJL^#7>-r(Ie-w+rWu>87QI>+ z?O9cvtw`8zbXN$DhNER=-f-9v<6G_~PG&DKdhuAi#5e9Y#eAK@*P$#^yOqn$CYOnt zfyJMJqjXHZmRk6_jQLO?tn-X%jJ1l+t_`k`pQBysEYX0AF5>$|_Ukxx*Ksm?@{s&` zL=Pr*YYR*IO19jfDEnITRn=Gd(N3pB>A%3|i#gxL2m;P*6*-XG?j{yifpU0)ukFbG z{(qza1jQ}0IKs*Eg=#tG{XpTcrXGabr_yv8{*gyJYC7hxFwF1>3$l?W?>L4=GkHBW zH_VW|((A9K(M5i}Hx#UgpIlReaS3HOQ?Iq1$2E(I!KALvNc0w@&STlDbRddM~xw{mMk-X*?ZG>kYeg5ne+ z&L$H5Dd6o@m`iq+i0VM*{1vk_SK<9bmqyj}T4a1g4`H%aYtB>j5Kx|O)i%o#6X6j( zEJoC-ePzC?v{kyM7^CZ^yjO7 zMP?lBV8g=m#?R!tvZ}O0fxbXb|268fC2t=Jpdc;x1=^18uA#@y+T47wvIbAQjQ8(7 z)4z9;@ddt(!8zV~xPOYjuRr6RD%&&tk3+qLN($wnF}%8j6(uiR8I1bNOT83(iU!JS zS!dsGXE1Nv(ZibKXL=Pe^u5}%qE4tPtdhM=d8(dw9-dr+uD;qmqP3;|PZftHx zq@uf{gD5MhTx;6bah1Ee8<)4a>Jz=^nD%isVslNMYcbu{vD($K62UrTLEDNXcB`k6 zs*1KmP|4fS%RB&Fy!-SBK+~) z_7K`{erTh9t(y5m8~Od4dTdkl>n7;eqd1S~*WtYmYD|{ruRBITjptRHel0(IePVak zjF`ri&DU&bU9xe*T(mShN71McJYcJ>*n~m7%O>IscgxVoJvPCgdrh-76lTFi_$)&sUtl)p*|Irf z9aUO$o|bIRXX9oxr8Pq{8lm%A2`M~ON3GWz0cC2Kf5#ly)Pvg`NNgZ^8jccH~h1zXWq7e{w16PQiI(m4>Nzr|dcF*vBeqJb<~SfOnB<<5oeZdUait4HqnI&6 zzcwqTuMknvS)vatlB0wRI48`U;8yd{+TL!ucbU5a$fP4NAy-`Guo*7{U&&I_})2c8?G=zPdu$Y zLAWhOmRS%UAc7XtOu{Whu*d8sp@j%pu`H9Ygb0q9!z7du!5MR!go}uf9m_TeXA{9v zj4^~;ilO|T2$o_f?-IdM4CR+ZuoOc%Oax0Yly4EiQVc~Wf~6SBokTE-v3Ct&W+C>j zAk-|v-Y}tN0rr*>YJPriF`?$i_qqr*Km90S=6Ca&NA$nKPNfr~#S)~j-l{6LEd%(E z2O*nT)i(8+ZBxi|aEGNnzMe;k5ye5(tMDhcXJSCD{ zBDq6v>(<+r>un*u&7-$nq_<7g+j0R=DSEhMuM;S|0tQ8!Vo<~-7+jIedu?O>@5+TeQUb7ca}&_6Ui8na7aLXiwsE{hKIG`eI60b=<7d=8i5akrK8(6-|1_6 z)#*_0#jp<{jJKNsQ-Grcqcoli^N_VJp-UBAMmrUyR1C8y(&6v~!gbz|2zB@rB5BZg z9)PO>?uH#$EEn}hG~pz^qqk|QqRElCa0Ub~e#garpRfPQ*G)Y#vf3kf@Yr}VkxS8> z)LhQ+j=e0=o5gE!uT1og#kyN8xW&>Tc<+}cdUIsR0~3<-u#`%!M4bJ(>+sE~3|YeC z^!P34@ozfW9{&-2Ega~E{5)l4ezCo^&G*vJ)T0ph=H|WU@aX^QmtIh>X#@QQb=9BW zjpe+y6aj^!xP3ue)l1dTlWSg754ZVWs(#T<$+I;zFJ!Iy^N|;`4!6KUDm?IZiox_8 z9&g)ySZBat8e3_F^nV{_^O(Do!(E|hEw5MC*P^ zv=$=mH2#pq0Ojps_;ScK!yx}9O|s}Oy!Z<*3>_H#0{mFv=qUO+YJ4gFik%waGJX9* zef?a0{X~7eQw%)*DUS{EZ%1?TdJZT5g;+8&iif)HII4-&FV zBD)FclgKVY?w80;Lhg~s4nppb$aX?{B+^I7CW&k#WP?N=AY_e1wi0raMD8bKl|*_8 zX_3f%gfvOyUP2lrat|TbO5|=r8YFTTAyJ9kNyt?axr2}ziNp!6a09r7fSCYpCSV$XjRc$vU;_bX16WVM835K1a2kNM z1mpu)LjbjjZUROD=prBsKqmnzfSUlQ9|KrTz#jl~5b$3B+6nj&z$yYh06-xx^?d+5 z!g?1#D^cD8&_clL0GbJS4Zw{AyaHe)0WSe)BH%>;D+u^0faL@{4`3MqKLXH5z_S2u zAYea$>k0TCfa?f&8o;##d>g=00=@y@8UmgKa5Vv62GBsjqX6m&&;isDunWKv0{Q?% z3Ai5sO(m%J00Vx0^lW}20%FhJ^*C|cmb3W-~r$v;0gdG1Y8PW5drf7 zTuDGNfGY@a1Gt=knE);$U>bmh1e^=tQUcBfuz-Lw09-=AX#g%JARoYd0!V-65iknC zTmrHH%ppJpPz*r%7{EmY`~kp)1pF6(*#vwDz)iph0E!5BAHXaE-UU!dz*_)j67V{J z83eorpn!l^08A&~B>>Y1coDz_1pE}h`2;)<;5-6;1mIi(o(13{U_XGV1bh#`IRrcn z;A{fE4d5&Sz5(D&0-gjgg@7*uID>#k0h~^N4q!3?y8uigpbx-l1l$i`A_4aRm_WcC z0LBy010a7BE_oYp8Mg+P+?#M2y$YAHEx3$n!X>8>mr>W^lHGudGm4AjDqON^aIyPv z;r^KIh>AtgqU--{p#i;qz5%^~?V955o7m|nT?9D%>qYEK`7Xu2;JY7gL-4V=@_e<8 z!(GZFM2p!35wRaZjWbmfRD^&)-Mfluc0ofNh-h_8%MvsMgNWu~nnTbK5hB_wreV5+ zK8>&t(N1GpwxA(61X@~LNRgracl7ng4EiWf=wulcT_?M!?7+wt(}>tV=%co&Y!!F! z&^O$s1GoKrqrUMbeM6f-R_YtC)i>~>2HVd=`bM9=p-kMlQr|dV-@qe8+s|j{8>i|U zIBa73`FMR}j=q6|0=A#y3yRRP5`o^S7(4kfz(@TKRPC&) zp8ia{x_Qdg`~7W44)(v{qv0KWN_`Jyr}TYI1RCDK%T?GdxwwJviGjTs($nM=RT7)} zXgA(u&hUXMB029+c{V0?=g=FMcz(T{Gsv!<_RbIXCdF+0rV{#CUzSKS*RC%2R?9Mq_rw6FO9 z>b}1;Uv&m^sqz&53+Cb#`%!fts_sM84+L}Djv%<*|9Z7^f@;iem+WuLKR3s7{lvpQ z?U|~+sx40|52>_PeWJDv@Ydi&T6`QF-}dTJEIB{3^#&jl)nC4a%ggV)`t~n=MuBn~ zbMufi$gviv5|u8d!~KQ9iS)XO9!%qJ#w>pS83ZS%;Q2P?3{JFBnQZ%m zc_?+>;im_dIdc_SnZhCG2v#wmV?~$-La=2EQQCx~{vI!~P(!AKML_L+NR{OBI}YbS zOL;e?Cc;eb=o`mmjOW;16%X;%P=V3(o`p;z*FxoJmhEK%PbaDX#aMzfi1EZ@l!3<- zoB@;DL?Ej2Q}Z#jD5BD1%45k4Jq&&z!e<{)AU@lBmERj!9I4bO>#sl=y_7a;ZdlzE zp=s`0_=$H!G2arqAC@nmI{i)bu!!wRMQB5f|@1`RE$G=6w2x~WIyP_MF8W!tOhWIpM$ zTk%;+pB%KF;EAV|`||Tt*f;$9QO-}58`!Xr#Q*`N5_fQg#c41RSfu~lTM0Dzh}mqlN#}83*$?g3KCQ-6?WOf~v}eEEEjJAN_)|MBr^NO@w9Lzn zo#o{-3BZo;at^`Uem}kg1hp(i*U}ccdY17cf8=>c+n<&)_VE&a-NPK)S9Y?_+5RXx z??07@EIhw!`{Tuo{b{Zsa=>5Ne!h78EKYWduKmB+j_rbpGIwPcCqv(KNX0trkiHSi zcwm8uWxdv{bB>$!c5Bvo$IL3#?|}?UPUwRV;P1HV%xyr~ifoT?&9)_W+ZTz|9azNn z66P&R_D=P&(qd6so+sJwQGZEV=KGoAY(4rQp-^THL-U5VT11{NGL~BKv;-f)0+H8p zca|-ARx7@1gOH^QBjzjEg%NvvGzaBD>$9J#-6jjnba zwc=VXcky?1cXVPZqN`(7Q+IO<qmKHLq8Cb+0%@?|; zjUQHFc8;7S%o}AFduK`?*H}riWEZidtkhF75|->b36|`}RMVuE<}{YjmjEt zQ<4~4CeyRZpL6VUloZFA#24jZR&Lw-;{+xuqx0a)_CB*t(N&yZl<6o8Dv0Crw5Z8+ z#f)P(j^m0^ScO2&ipW1HX=~h`qqkfunhf#_NG` zDvTHBv`~4T#7f^(yJ+W*UwMl5Y>WzfBatAw8b8lVYxCKBY4e35YIAA4H3}L0-X&iD z9I}-rR%}?;ry#LQFeh8OkNPmSA(g_Ckj0&l@3O^mo{3G|U)uUn0yeGfHEKgK3Tu!L ziC1P(S69rIm_Zm~ZeN!Q4Ocg^;mx9{SYde?6sGqn_?wyZ{BnN7WptIRK{oYdu}7kO zO?V_vO~R)g;1hNa=X1VRF)(aZR0jqbo`{RLKDcBj^0mb7v5WFAvSFXWZs`ZM?u#C1 zqwqsDHd>5R`lnVdIZ~Hz9eWyV|8M{Tn&a)Y!@jfXV@1B!w zys%;_@$`-*)F$W;O3(WWcv%|}(3mM1jpe-iti(#9aAd3Xpg(5+_@iw-{WB{4-+#7h zXLZf=1M!;XDc3yXOT$^iUZx#A3H~C0JQGl)|95_(caCu^&%%Y^5S`waa&(U?d0QUP zBl^Ztqo5u@^|`pO0n!IXooc(^A;;*TU@Ts0H?m zuvKVmIW__LJ!N!aP;e#@ynZj8kL0F9r_KZ+k50DodHl4yK7t!z;Xg&QH(`aY*sMR> zRhazm)@j`c8+5H%zPzbvMbnDew@xb(8!1M>KnQk)#4;*dH!G#K5F*juhOsJS?h z16BgnRH@-#5aa{#aDq?M%HkqdH-am!8Ee|RT5fD_TH#){0SEdN&%`+rV{e^K#|JEQ z-P%~>q6Tm*fzz_ZK?1iBQw5%NY6U(wDbe8x985aC#Mu^v=5rEGmn~BxGdYQ}H=r#s zCCAjdZcge+JPb8tLnc|uc{Dkq3`|Z6CL4l*9-nvK0&z>;AD)O7%oK0G{{I`v(D6o} zvSjjvWSH@|3|OU;XGq7ms|;`!nGaH$HjIXJaf+ChN2#6ApJ^>E?ZmW}6!&jEP#qIZ z<@Czx?;rH-tnwr1?WcHub=#2x{qIoVCc*C`TWA7UoC&peC3z`2s@aHYJf!(H|>2?{MRTNSUOP=9yckY}N9bT4M zhtUUEJN#3m!t+O{!s0YD3wy5^@8#7(=dofM9kw=w(Iu0ik7IG((_)>>akOA1{$up2@r`#(UlhN4(YN-+OTM#_Rrr`U!R)CSRJjWgr&yDl zkLXIb>GuwHuV@=V8nbz8fuPY&0=6Sgi;tz9+Aep*b|rZ(VVZrvlUS-2Y!Zp+I717W z&*4-dIoXBRmdu9hWXIWjwX@iIB;P!PpNbl?Wb9rkK_?lWEljH0z)AglZ1mph+Bz^@ z!QT|fl(5FF%g|CBfC#30%jhoTc1|X_b$3E??&ZymomR2kmbrb9U|NNY_>cqv;yQ)n zJyY0CPHi<)VfgV6+F+ zBI*j|<`O%7bLc}%EnFXB8qgpa%PT*2gXIN5D9FGLoyjgJ{-QnakP z)ts|_+E8L68F8NMET_65w-nxr4kc+G-{K@kmsFhQE~@ zp;9AFv7pv*tMvxfIW!+^eYQppUl&x?eE(4OPJdwf!FZr~%F+YAG`uPeuW38-Z2xoB z@Z5A!TJqtNkRp#RgA+GW_kxaYb(-E=HZkNdNklAx`d$+JCd(<*$Vr&DacE&-Wy7-t zQG|;M#x^jzBnsO*h7WcP2K)`~+5nTIJU6B-xg2+MJmpnU9PEskk1!8W4#jCpgui&N zOFSXm#fWJ3_loI*D9z?82RH+*u2Y_7uzo3zXKl3BShUoJ>@p(pU1!G zJ4;$U|2vA-Fr=Ln3|85oLQWZm#)>nFZ-}2qz*ZuxWboD_j}XO%!A9C1qk!?g*8Rlv zXM8x@WZTwCUzPfk!&qv>hroP5D~f1bHCRGbJAMA?`)PR9@C*;He#@aI{t7is6R-@g z7L33+CnbdNgGEGZh%st`*tl09R5LV*xpmNxh~p;4>zX;KKZ~@V*AEWZNje66A`(gl z5rl;P-UkU~m&7zFBI^;$6kQ@2aVdUueDU0pNj&y6@$~gisPz4!N_|l=CG@+`frKaw zVUf^!s;^qmA(E9``#};Co@<@xU9A$rvjYPbDKQR7%^h)DN)B;_s9yC8QQ0$yimEVN zQEkd3s)>U{HIYU2vPD+!pITWhI+50tIby+%h+4poh+1%CW|48r)9Se8X+mTadUzia zLZF9Y6fCwh8bnt-wCIizn-GHg=NciniBfQr#EIM7uUhIeT>0IaNq&Gp9gOSoFK`Q7;$?)ROK!zh3*_&Njdd%h6Qp`1_$iH7O zv>Zh!8V9%rK9MlCp=}Ca&`=ElhPyiko*i7GAkNd zW`pA_EHe8TDY7ytvW!3OFkGpT-QS$amX;5a++^+xNpzO(@Lx`?HNE^qWM}+lg++9? z2#eY!l2$g6Y3_^aCaT@(U{^=0V^>FXiH4lgWOmVzGF#c$?Z%P%>G3fkx5+r%ki5)t zDL3n{XBbr&uGlhmf71tvjJrShniD^kT=M5=6GbSeFb%AVW)1|yJ{1VDZiEGI*#q|%Ln7B@;eHjriOZ)nS<>elh zh0G8P6Ot>Il3S9Yr5TkOuIR`>inSLsz&7VE2S-5Y_CXA?u@mM3zltyjpH zHJHQ1`VQ<_vK{1c_G^``KR)PR^@sP`-u18gU%vj4uYbaoBjYL26ApTt>po1tvH)bH zZm9gx9qTfXEUM~GVKE83F9~iTPz#BWRdR$*xwi2w4qe^FVEr_-K8l^76+&Zh9;F#d zNg4ie2}CSqp6im~#Zv57Ucxri(^~pR9M_8T6Rp47gD?;ZBw|-$q^@DTSHN56<^xfW z6;z>GJe(bcDuM3KT^OWuqUGma2V+1RiHqqK%o7$fsb~^#syy592l$*M@Fs>B`0JB zEHRcewRkG23%ov5Oqpyywpu)qREq?ILM_r_MywiXG*XW=5>zB5!hQ@DNsBF|+K6UD zK_*HCIo7YlooM&)SVleJaMQ`_$yt>(ZSTSQ4_1yhMy?zu)NB{L(b#%$CnK$gl)n*=vZ{$ev#5zdIsr97+$vQ~)){ItDU%(M zk*gE3BboJsLs_3Q{TS(ZO}G#u)-_TM$z5t_2*r?lg4eVyP<`em(L;t;ybu)`UZ4C$B9RlCv53Wi0pTmjbbYcVh$Co_KrAiQcDq zuz~seksFvRPpJ1X!)r+$Vn_5lNz?MxB=``4T1J;-58q;=@;HOs_ZR^iQW67(Vi@4? zj0f$3v_@}I6=J8M5M@#!GXG@giR#36GwK8f;Z9yBilrwqOs)9Y$hBgmF;{6;hIzDhB%`KS(OZ zx0B#kSo$Ge@nw5CwU^O2$gAz*jnUff0?sOa>+`P}W=rx72J6q?x||FMB8MVdT2v7R z1r%&&+ld@>6}b$^{w-QkV=UU{xI|`^>P}Un@0QB}?sTa{nSM_AM9oTO9pcF27f6Rr z%(@tnzAuy#9l{R{rB3K&Rw7I6GgY1b)=;Mzm}a0RU1El#_J)} z0$v=Zg>tCvss)PpO*5@dwD|f-X#OeY6?^(=&q1`F9(^(XV{G_j2ytyWi`3=v)%v61q6)t9Z_5j4 zSqBbIXzaYPi;iPxx-oU3=f)w0P^umvnWTw99k3?4qFsFZmZ>#O4>C5p0uuUJ+Kn8Xub1PR1{2rNEu+rR)gy$4$outY8? z9~P335ew?}`~e7CvHYirXXynjC6<>Enkg?98ssI15yOzzpsfsFFlq6Rt)Eh9IYeW+ zQ`IuIr}3garOOLHs}qez`C_yxZen~HQeHE~u@m4WaCnW!3Hf=984N4kW+8ttRgv8 zHjXS_{I)?hPDqNyHEbJaN{+=RB*)@|^h!=bdM9D=J{PiMi+4(8=TNm{TD#1WgS9K% z^G&|o?yxjFZhOf#mqBuujaYIgXZwDgV%cE(ewR-8RSMyguziImVf)-$ChmCSO`fQX zM#)`3U!vRYRC(&5&(?vgli1-2#$pFvrM066y>~kR?HfE<(Kn^!- zSz4pvQ<+7hk-}kzoG!`s!;Q!yHqnN-Atl=pHzo*4E`>avkTTn?bwdt@7O4l?qtWW$ zq?je5{M#VPKc-N~bR8agBs8Ky>4g^4WnGx47Bq4s$s7kc#8SjMvFm~crFL*F8dX^o z(DH$osgLX8gJT*!Ry2fz6kjy~S10V8n;BSBff3 zh>cbfJ4JRYmG5k%QW?*r!JI$!cFW59k=ZR`>;h)*G`{i}ln0%x_b-0+O9R4;kp-eo zMTmuElN1dJs}GZsY0h<4Z>hi+Ya=T$K0^?wF zl#fyqY@?>onTP%b z%f={`xl9_&-BWL$to%J``($Tp6aO(eS2bjxD!%z9`&D4{UpT&SAzPYL%5j>@jz-B@ zqR#pDEOqgLf4G=vr0C-W+dmP`M~8HQ&Q=dptJSubK2Qc3iMNJ!aEgW<>Mae{TWrKt zBEZYr>(zoqY5q+O<8^#ghQ|I4X4Akf^r!$Z6TlesR{$%Y$G!d)V5MC|f64n7>b>&$ z{uQttlZ8EYp%AVa(NYdO7rQP>Il!lG(3vvn^A}UWst?qI{$KiEp7JavF>0_i8mqP& z_K`(>gPCP6y*2^M8tmD_W>z$Sk|qy@v4;h_szl;RV^>hHtAZ0|S0*+PdxpbCuX-`HL(g^P2iWmK@)rUKXI-W4_^&S1K!2xYCkc?g6WFzj{ik8)UyoD zs}Ntd@OG}Le1f-rlee1SZFW=^7ccz`**g-Y#hSuTfVb4iAPmJ_P0q4cads~MhlXt& z=n=(-Ev%iF#@ae!t+NDbYnMuk{Kw_$HA9+$^X0swdHP4XJ^0Pg_F(wEO|;ZHPgN(( z05^NJKs0;P8aUawYIST}H9DZD}%#&`Wm6V%Zk9_v0$<11NHwYLV-1u8eA4O);vl=t%rGN09}}e&mX6)@$nPlv_o`P z#CHzX!F02;WK7#ScrwGnaGGNhQE{4LO5u7qT592XvcnQwZ?|$?HM#Eo0&?9N$U7mf zA1k_Q=dhjNHqS0mz!W^5Vw&a}{5ZCS$?1l9qm{|hHbb=wzkp1(h8sr4WQqWBC}`pB z<2!_Y4+;fk#jBs%qlv*7M}9coLy?{ol`i)!v2Z)xR^Msmw%t_e3%`Kewhp;Yh}(k( zw#0mL<2Ltf?g3BFG*y^G1s1N(PwN4<6IXMjdCsCv5E^{t=Y*#t@i1yURuALUa#d(9 z$2vtA0Xm2qZ5@t4O^>O%oNt!P2 zvGUoOqX6P-; z!=F5<4f-3Bqh&|CaQB)-vXl}nG!0vl#!M62foWILc}zCW=`;_!W$G5=fYeq->l!(! zcjGuzjG)xOjA5!c{A=C2^hLBn(r z*Whkq{}K0XmuZunVr?O(qdUo>gMS@A_(>tkT~*ormn%jrj^TzIt^$-vUp&l8Kvg5lw_ z2$@fmMLavT2qWeA;ozCi#1DPxl3P<)gjZWx6dF>CrXbdnNrC=(=yBcf706p(o6a5U zs7@`ooSSNBIw=q`8{Bb-(OsQKv}9Ht=78s`ibDGH!>3lRD=<- zCC@!~a|&1RN()z%QDje`4CFZF6{r1j6mH2w^zk#-I4~DSnAL`YwPF6TYfV3cPfQBd pHiUeOD)D{2!zNPs0EJ literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..d5ad86e5a1a2793724fe10da2ad7f80258577b4d GIT binary patch literal 49158 zcmeHw3w%`7)$ciTCX?_;NB}`lWYmHXnF&cikSb&*nUF~)GjTEl1bGDr<}oCg1O$8~ zIKJ8lgqJyrt+kc5^cCp~P-e=~_WFQIP z>-$y7oVC{3XP>>-T6^ua*M6LCC4EV;&tBZJenUf~uGQYMv3GZBSGv3vf%&d*C@?=zRU9bsR6B|O$vMNTO;4<8t*dRXTWb$( ztZQ3ayJd!buHE0Vsc!vhyd?kHxpQaO^XJT)dF{Me`Oe{`u4IOuVOJSDzBu|?_G(UqNB9dh|g zT)`5D*IyM5<@R)C=iA#`HaH@6o9ZG|_w^R!(zCNGqcrR<4tWFqp51DPUm+g0t!RC~H?xB53mBDX83s*)$FNfks@PttXK(iIhF zIy0cBD`$36wc7BEqH9ze?P}C!7*(U%7jTta2`s}^QW6R*as@{KNk=uRf`KaQB~-&N_!9RuPBDgEL=WwjMJXI27ER}<$)nsp=Xs-E2z5Yq!yluR++N$z+-7gD zYikD$`rKY$XWvxY+R(DG&EB$MP0QN4Hv7glsAxko-)q~_)?T;XDavC78>#{7bbUk@`ga5`kNZDFF4$semY&&Fu}jeIc3JU_!Q_I!e5*g#o|IM^zsq zX%I`5r^MldwsB4<7_!szkXLb_s>TVO)bs*8V4!=uGQ|x?xRh_kpGdC`1%jUVBQYFO zl(+gnlvWj}ia#PTh?&VEdAc5dhb`=1?DdxzrOFYgBT!oEaMw8U9WE5LAJN^jI~{bb z)K66(DV`zjc!I#Q1P+6P=29I3Wn3b~i53t~l60qMH>qnz ziKp1-3VP;IV$UL%uLv@$LVMtQ0e^^?DMgOg1cD`8L^tYK=?YdrJdmbM_fzul;sUmT zfJYDL}>hoo3>6IxJ90g$EB< z`Srsk9^>2al7NYXjIt64`Sjo-eX+hoRL@rFDh>v?cJeV%K4?F2F8(^3sSp`KNCXxv z#)NUp42rY5%I7WiI7@>t74&xFMy!A+kC}!vISV}@BDsPKgPzi2Kih~=iOEoIG9npX zzc(aXAka}pPQ`&RSyhFkB5SAV>ycu3ECneC2wBTW)M4}q&eA}z64~lCAdjdlsSedt zc@{&~;#HXoeF3-2M=#TFr)0#Bgqp|oe|T}ErEOztov=7PyGIJy6#D|z;h-m0^-+>w zQtI(ZB$N7N$y=pA zoVN+4B>Ow?Fd)HcJ1mKMvvt?V9dE@y&z>uQccK{Oe2+x(fEz|j%x2hKXOmFC9^2?E~$zo zA1SgeMK>ObQ;keQL9c(Iqqxi!j6E=1JWv&2FC<3J667VxbotIIv@V$zlDk~LqNnSU z+Sbvd(Z9>ocal3l`9x@)i}t{Nnpq*Gu_M;^Noc1k25`y zia+KD6PN^c#EOu_sj;S8p)#*Oky&F*cS~KN#G9i{H&1hGjkH|ByeZE`I%JgNq97YKe8s`bx91m$ee9|4oUvWN0V73*&yyF^C;obWF`$W z8X+`oxVvRDJT>XIkx?MiLAqsy5?>wDVH+3Sgjaf(cuEXh8gQE@7z_ljPR_-Vl#2=H zTns$v<+(|ZnQ(s0z>^-!OM1+N^J4}M<3?61oy(j@K9B^-%8m2~9DKtuGmovFKtg%w z*%MhbKk0QQoL^_)yE9B&zc}2y+RS(RjcsdcBeku|$#$~^$Ox}q7ip<&N7roQH;_m) zcVJ2Eb!lOLBI0DL7R})Vt`wFP(yR1k>dGh%R3}k9ORAD6zQ95=g?t?-0z5wWKIFvG zU=9R$SZ1FVt{${SI=DgdXGlS&V;~56n&0QDbeUiug{%E;+q*=N5Sh;2K*oir68c|Qw zugp5xurm9kUt2l)WMK5J!0682Nh*keEE?MK@6KpFQbhfh6TLqVWFN(#c=WdPY_z9K8bx=rR)7HLSU~yFR-Cp@KBj_R`$q zfWO2`qkTsi;sZWU5C$0(|HA5AixqmElUwWx6_=qO3x$JzM^$kyb^5mI8Vpw|5pL+0 zA{1aXRIk!9NyzFHjiLovxuTVdP(iLX5)Y2db@^*VQ?52tx9eiW8c0Fx$)m(f%^1a7 ziKF)*QyV$5u23uT8XK=iF~SHUSAPFh*Q1_@OUS|I9Flz%{DYA7PQCCZO(IW#4uQtmXe}OH-rPiKBxt(L``M|sv`x;iYbtP zXUC`fD(MR8$2$#DJw`%3PWXjxJm6>5xW{kOjO>1zG1|}!Avg%A~rWRUnWONo= z4RtoSoT4V};|Pzm`CSR>|nBQohU{h&e0F%voY)P6PDm zL*UNnMD9?;#l#_Y=T#^7W@_FgT*rlJ75cnc3>M7bOQBs{#`C32=%9pU!rx(p;ut1ub%NZ-Q3j05+j8U>SgJa7wGg}tL*b>p8 zHhmww+6*^%!l6r(((rIubzaBS%bNhD$>bzvmGSDH0>K;6nHOFrc%%9FI*VObb-=cC z2HP9aNKZZlp5!F(BuPt>%r94Tt+iY)O=)k3XlQRUE61joa!AJv+&Gcci&Oggi4*Da zAvCB72BSn+))df=E0T2sv&gxOFL~1p$149aKnRS}#7|m-ULlNjK{+QY6t)}P6~=Vc z;o@RXb+s+Rw`SGxW%gX77jKIec}M*spMNLv??9HR+05no7?+8fg2f+#qjW~Tx=nmt z&3teQ>zp@*v71F_*9uq2$3Zi-Ks4aOnS8&{x`MB>7V~BH_yPH~Uk~)`)8-X*7j0Xm zD2E$!RMlJd&YpCe()$UoHyo!*^3 zT>Z2wVgrz^&|uAl?1zJeqtUFhi<(|_0R|U&Dk!%s*J1& z2BunWNiMTo%Pr1jhHJU*T!qH6n0PDkV01*TZ>L^`{>CCX&(UUeo4iB!cQG98*kJ&U}7a5cikh^$)6OX)1g1 zIV%*mERy+3B(tdLwNpjEd$PRoba&&9@}|?>P4|~WOuHglXT)~uH>Yw`&0BH$(DX(m zJl$Qtqsbewy!ztvBw(N&4G)t7kfM{G_c{!$!u!r1qTWS6^yjVksZ2QB#)gHbpP$UJ zr%)#;|j%Ip>@V<<}&$&?;UM;M?q7^ozz`70;9kH9~3o&i5X1%&=u z=gX;hf)^P)KsTQiH;>_w%w;@VR$c7!)1CX{>F*Kg?||XZ5IS3Q!_(OvS@k+7${^iV^0%kwkwT!&Cc4#Pl{ISic&}Jlg78Hb&MqU)64}uiaEf zNq*PUHOd~TTi4E0njCJ$x zPX67&zh`)&6A>5tEiJ8U+ivOUvf5W~vA6YfWs#{{SKDf@Yi`+iQ++cc740o8L|I4W z+Sq&xSGlddc1@FgNl({hG5fdyvAMd|O_;T7*g4>RotBCEiZS|16lcG_0{PmgF`1rUafX5#&#M-FIX}FzXJ6X1h{l!8(JW|P zvT?&)G}NaLqfsAtz*bwa2!p!aV&P)!kfD*C7QvtHnAuxtJ$vyrJ7=(WlD;ZSuT^RB zi55cZ%!wAQQWPy(G(mp|HCu(kk;**M&)SWKIkR}nPj~lDr=pklGg9R-Bb636Qb%E= zDx{IRUOjF$NaK8;rHt4XVW|z($El+Ca!zbiq6{8r6_gf%i4f8kiv&@GN)Cu&+?O=UU?1OM!?0Ul zDFR1d&ZIjXXEy{0?_DHRHOUk-oy`oOsil4jlj$OSmZFi*jWuVdY|dDYmDHT4#GCUZ z+zcnQW@tt&bY3eWg@@{>OY~YmsT$@_m>%-@AfyHI??;bK$hfB7De4DIFDo;bb-$1Q*3oKy#@*B z0^@TQ<}Y>&Se?!wJBG zo#ISMag(P@6gT;`l*UEQD{|SdH$t1yM%C}s!K=gjE>oNE3p4cC6Y67xTOwqc1z`sf zw1^fX+(raz#2OZ5=Q!$i#h+q`s&_=>yg*dd9&{z=;RTCO3 zz#%uGvDY8UCp7l*Lv})AuYQEE*n6|zTe*-7iZ;cdh)XcIHlAR491O=nFmPQ5%1PKbkJ;-Hvr`6HEAxE};6f9C`Yz8wc&kAuI7gD=Oy{}~6L zje{rR;J4!7*W%#km~2I1#2C_KYAZsl}u+$=7Q;<8FyYQ!ZVE+XRkh6oY8 zAsF_C2+qDSRV2AoTrLuq5#quj0rd?sBuy9|R#hK%iD*W5@1@iTycjH<-q~@Fx9OF1 zoBAmX`w+tTT|Hn5a1>#b#&cmVverfPQ%*m_(-p-nhFKKpu(|xzi#hLN=(xCA? z09XCo4coBhF6;|w!byadYO12ik+^UM1WSaRPIKY^H~&UEWn}d}!Gi;%$wV$gb5gT7 z!JF3No~|@r(mTJWYb2KMV%;uQAi;aTwx=sohCDDKISVVYl}@Ga=o?oDBuy%~xTje=Iu!NnF z9}*Il$PWm)K_br*f)(1F?E8dxCGrd*Sj*3Mo+gBrFyX3vkC5vn@)RN0O5`LVvn6tZ z5G-8dXO0u%kjODYXmJ#-%27h5NaRUEE|o2zgB+ z2MPJDM7~VOuO#v%LSB`~7YX^PL=F)0qC_ZCVR=C!Um)apiF}@rXC?9&A>Wh8=Lk72 zkw*zRB9YG$@@q??f2C9;!{EfU#5$VQ25C*)>{JV3~LiF6Ut zAQ6g-TIwY7DMD%`az7!o_ON~VCB_u47dkDEfB6kx~DUm24UWwdAh({vZ2yscI zlaT8r(m}|zK<*@9Hh?<_$Omvc0S*AS5ilLVtprQ~u$6$z0c;^)5`fJFOaO2T0T%(- zL_iLJjRa7eXeVG80E$^*?q|2!N`MOBW&rBD05%Zt4*)F${3n2B0^SC&o`AOiLz z7XeHm-~|AmAmDibR}%0nfGY_29)QaUI1a#0z!3nG3HUaE%LsS^ zz$5~`2H;Wxz6{_J0v-o2k$}$um_WcI04^p#2QZ$1y#U4$&<)@s0v-S`mVo;Kj3MA| z0HX=$1dww(ezLdVXVgagWZjIP;p_1;vH?FM>hP0Ui=Sc3@sm-5pY$+(Y&YO1tr9<0 zFMhZ`W;>!{QMBm#f1hhWf4I_s{)k`VC;#lGOXpKL<#vA*m| zwTZ)B%6_6nEP{yGkDx}GstGDWK%gF4&orx`Ar3^e#Y{^RGz5c)=3<&n&=3(K+SN?M zbO*f}VIiVj#Iy`SLvRSRq_~hGL;G*)o6i{ZQ6AIDGAg=Gc2U`lku9bXu?^8nZByAU z?%u6$xl;#jd3me8^=5rblR(z#TbJuwcu|Ap<)FURt8Xb5cjoI`XX{&dglKtrn!a_i zzJD5;cmo>iKUDnZv!iePwyUKd6Up(%J3&nNkMt$UX*+itxKSypWb;-Wp`yq!_oUNJIv*NxgtGFJ>(}R*G)eh)L1<3aQ#u#{fIk9 zO%G&I6O!1a(+qUDj;LkpZpd-Fa7?N-~ISU6ey=LHxEez z9BY9pQRxC4C>I$ZPLAT7?9B~~rR>JKFpb}VS^VA!1jnb~`8K5tjI~giEJp&_D0TM9 zC;C>WXDPHYg+tCEtYSdNiZBg?V95}ovMo-t2R7p40MmE+N zX}8w3veTmB0Du{I`WCuDrFj=qUyEx6{C}{Pr@cP@vbsne?UuCPg8THshGv|RK$JT2 zPL$IC}_Gew5Z1Lk#Ntd1f^DwH|esdA`S*{-tfRdh0+^xExs zEnOe)x1Qj!CzMa;WUH`m`1ifc=ap4#Sjb|4fKrJ&_=Ux(i6O8^e>+qLH2z5JUjKyS z&^6ZJ?{6}8Od)1AY>9xetU*Qs?@Xxrb_?2@3=a#|Bvw6(>i0RW?G6GTV)k&W7n8~i z-Y2Nsl$8fJLs8>9pJ(ypxw5wo)O0%51IvDB)AvP{t_lyWucNL1B@Vgom}gRz-Pciu zmiK6xmlYe-OQsWmjpHR8g17XIZUI3pj?k~Wfqq@9=@HGck}ujazE~I0MR_>Dmp!a= znuR-WEVUC!cz##2T*H`FD2N>JS9V>=&pmu8U-pTv{avI0t;udVQ zz6r~CV1elEUFM_(XH9ySIq9r3CY9>9BgK*vdf^WIolT}<=0@3$Wc#^hJA3w77l_pz zSj6@s<}Hd2P4=?VVo_SQE8g!>e@R;A{gIO1c=|y?q0AhH<_&FCh&<0UmRj(%1fS#r zkymkdmLYjoCEja+kfrj8`3hD(ji(zl(HX&!VF{`C<J#-6 zwf1J5*kWHJ4+CgxZ)wF;L|e=Hy7u}8$fKdTy~Vx(Ti9n#?diHYwhoEY#h$8*Zz}ZOi)AEfM=I4d^M1t@Uf`)-^OYv^TUgW0Ay!gc7YYl}Pfs+gMyk zmB3mZVd9e(7}C96m_-^_5AL39!09^V1sA#8#jpY}V#I4(Nw~7Ira-KvV>n;o&4ZY* znZ;8>RzQU;1cC}!00iYT19w>z#VVOEd`iLmNpx3ZmDhNEgEo;FkLjV&{NQeO4U}#R zV>?k)p+&o)MI)$;SX+wKrO1SHng|h7j+Y3(M!QtlAC2Fm?8f6mD+L~qFWdtTjc;fm zqnd(6{L+hsE@~47RhT_PX9+vh%3k))ly0uE5@*R?Vo9;vRWuZq>^%>b?88*kxQ6;9 zme809N|VHqvx#LNIFVx3PzcSe9BNE09y|jN9>ln3n9I#9fKr_8tq-E+gMBNh0UgeC z`6}T^?Tr-Bp-d8E%M|mhath9T9Ft;WC08D1<+hw2MO;!I7M0O?@MSs8tW$Iq#~`IT zQG*I%`zS4Hin(IOX&z^B#i+UuNO$bf3*(MGj*jVSI4(`3hqy*82A~m8)vWq|9$6cC zj-vyovlWfk1LJTR4~~1G@;r`}zDYA7-0>?1XwSy5YELK>Kv&}v9mREQzO?IvebVO9 zcxxCE_&kd|z5=q9F)ZJ(9S0z>Ihd1mAErKxZAh80BxG^N48ma zdX?Hxgu)u+Ln6yG>gw{@5;F)x%(RhBu9-Vuj^pP?+8W@HbQGc`@hUreC=* zB-)wA9*Ocr;gK8|hgaLcC+r^1;dD2Pf#J=HYQrGI6|(cz2fH+pU+md8azV~a3-%f8 zlYU_1;qcKW3O`g}qs1ttcXHXHQ;V}sEzUl*c=V~oV^1v}cM6@&slz;y|797fD(GR7C0wI^ra4Ic+3~EzWdJ3 z&faNdzV93_-&0XJ^=P!Re&UT!dXsS0u$O2@PY=HlKz0mJgx27Uxvm1^bf0))$FQj z%Q9}q3SF^T-)YZ{|98ifc7zSuHm+GySGTrqt@Dm4GsH%v;bFf#MaGQ-XjGhaXN3l% z`w@G~wN+{s4&;E9Ks8lr_@4;yxq3JVsBT^U40}6*EB0v{o7)<0YOY)BSiJ@30_9J~ zIT9o9m`cY7%(LH7JHt*5;7kIiWsCg;ZXzZMJng~?yf7}&!3i8pI=jSKnl-#eTU(ke zTfTYYbiOPTF7NV~0w`pnYFHl$)G z?IdO`Dem8Rv?3y!%Ee_B-#O;pQ|?31+eh*Kil$RXdw)-Xn;y=OY+($*@&wX4vW4@8 z*fdOsQDMG7h7;2`NTND9I-)u&S*2?dn}sE@A*A2PiB<&pvXXgB>udj);ACH4hr+D@ zR&<2PbP>bTl;niq^OdRioM5g#OfC=A0MUtF?;CqnEM$JK@4anzg55DgbF1CptfG)= zn9>Y}yM+Y_I=niy4x#71QXjMa)85 zJ|6lw66ZZF#G%2QkF@Kyr9z!=5b8V$S{g+QR-#X%SB-AHd+LJdeG9&NI9l}et*pXl zya{GcPNB+eh&V;+9DGDqvQ7U~fA@;E5hO92w-yK*?Id73l5X;`voe}W9cm8_!DHwShtj5IvJjA zOj@ypFDqwbqxW|E_P(hK{w6}Egw<|ejh12qL@?c3O?M%;%Tmd$y%myktf{YUHH+=e z)a`==(mwwny;$5l*n5a85JKxbd(#)kB<0$9DCuu_>h3 zZk8RDzB9G_guFgr3C{$B zd?dhU7H9SIvS_Q7_{Sqr0UG{Re1uAkG{J(J$F1fYSm#iGtnqlI9KOyitNhN1iakF6 z)MHV9{lsNQy-9d^5?Ui%n74Y12QCjlh;*cVbE`t*{RQG~TfK88iZyCgplOz$b zg6i9G@GC5*np(ar)35i1`Tfu#7`-+H&D9cH6}h!d<*kH2ZFzFx8gPY`$`o6VT#3*7Siuwf(S^4HY1)wOAy24gHlrqvXlPX;Z4!D^Vuqdz=p7;h2Lfbou4NWHE<45yni32QM6S02jV@AdP^Mwv?;9LV7!}yH-RK6g0yE$s~?> zkQ&&hReGz73+>lVKVuX@vQOpf4+;>2PcLe8{c{+tVMsb~7_72Dh03RnG(r?x`WtC$gaXEg8;=mvpY-BvlbzekyyfZ-PhzPN9|H3httg^#ReuSU z@A3Mk9--k?&67O5`Xz^&_$|~lV}NORHFpTcIW8fDA50?JNQ_aPV&k4usAkPL=GHTY zL~J)RzM`HlD=#JO=kpH&zO6 zoH)3f`&CnY1}nciQps;zKlxo$=52btT&1v+VGiH8umU_MbC?(mv27Ktj18XZ6b7%x zi5_d@GA!t!@9oe7$@Xy*OL)b4z9fhee$ciKaMCPFgEn+gngSt0lz;aNQI1Q|2C1Ou zCBthz1Q`xxWFPC&l4CAsmSR>+iu@Ubf#oPdDc?JcI7|IC_4}e7w@K-dyGVWp44KUsSZ4j>EJ9?XrO1k<$WneIVz5#pyWf$@mX`FB z+<5K_Npz;}@Q)YPnqGGF8!LE+z5)C;e z$!z9;GFw;M?!b}y$?-8Ex65$2A$gf4Qf}sta2Qn>tk_a^e^dL3jJrShnq%L$?(dW5 zBCviDx3obtH6=ykvTR=yEgDl;m^2b5xf!=u$XB7oT`{2aVlgoxud8J{n=0j%;)5#Z zC9Xwh6xYAMZ{j+q_GLu8OzrD^me;I7S;!Q@Fd@0QQgVw@v^1kKgB2YaNU`>U2H3Ir z%l;7%x_u0TZ0v;jgil2ngwLw0cO1tYW+mn@vAzR)mMq73oc(H9;Lh3(`&x< z|K#8Q;@|&=Uyh6?L{B*A9b5Mi1567*hU$jOZ}*s&fuvDY_Xvwg;HTr@HUhO85wePp z&?(hUzQv)ddl_6g1+9-_CuoJx7@S8L3#B9s|F{GqmNLseXK=9;t7i_|P*hoW<`0;U*Cl3E;y>jJM26;md=&a4)X#nqyRL7^5& zF(X!uBpRtl5(z4j5Me)qiX_FB5^Y3_p&(?t6@Y4JnBMLop0+aK?l7K$@dBi3;(sp%BGVAyR*N^jvk~TPbyd zgK+1s6Zz5;8KhSHXy{ro)R?O@EAoS^NlMWh*Mwx>B(+j}HLeuGHyNZ-B+O~0c07_I zdWkymWkV-Qq)sG!Gu9N-JEu_e<4I(Dy7_>h^ALEYef)y@?5~U`rI%PClEa9v% z0$;p*x`P|}3Nf#@aw^P&N&}d8@3LjQ{nLUPIw&X{Cd!ZK1B7R~2eVRvRiAhxpSb>B z^eKS!)O#|YUqr*BCRG~BCX#_VJ;^*Qy5c<#PQ^=7ana9t} z8UBp22_nNUaE3uj_`~SaYsDi!G+t|dHaae&?xwm{qy5oV!L9wKQj^<< zTeOdgSB{}g7>n{PrUOP< zqeXO=eiSik1EAcM(}z|_knx`;o}~;(;!BWAufjhh@fV^`V*@q+V4g@0^9CWWep^jG zX40zkF7cFHP-)qO!MaD)WP3H)GstUnYI)(aN8xaof8=Ao;%3f21IlZ<7?z(=Uh5k+ z<4_uEV8X%Tou2Hm-QBDxlb7;tYb-;rpl`HqJzgO`4P&EDr~F+^bl2n8amyrrYz7(jfGJ@L~pz8!(sr(r7MA7nrCr(tZ|9Hv;rhQs)0w=)F2|EFPM z-_PMMm|q?LFpNbm*{kCx^U}C|DZgCGXaO%pRtw#X70wZtG_iDc7Vi>KXXoSOknu%F z%AQv&)%ZY;rM`?RPt~L|82FJX@K|?sjY<4IJbfHa92Rty{0ssveIFE?l`Mf^XL_pJoVox9 zpke{dvZ_$9EbOl+ARF2~pbfoFJsQy}UQMu#Ap9wr@Y4hWS$o+X0xLyST8ili&ribBT;+qn5~eCiQ3jg|~BN_Mf+%vqs&s443?lgBWrB z0B$?vGBPd~7EXeh1MlIuoBk6flI$cJ3%(-uLx_lfAR-xS9h`{H!Cc-WD=WbL)?(!?T8x_gd|rbpG`=q?ba;=`fLl-qs`%P z#V-=f5>fu#kMgqw3Yo5x7uapfGnp>)8e!F0OKz#jZ4;}4SBMQz&N<6wva% zm#CGfJnE%`f-o+k5idhZbZ+#}ugFDv?~>><|8e*a41vwp#d?by!hw(%#~{rpjX`X* z;@AbUTZw#UBbCT_CiUn1g|}N~-Ve=g5o6~vd#CU(hZ{J)zQsbS zST=Fd@S{rfFhs*YxTC%nErxjbM~T`F9#r`UlA3o;k~$Cb^^uSho39HiC+5F;k5$|D zjepyEvE%I0k;0-e(a>Bf>cm-iZETCwS-XRFFgIM z7EIxrg%iX@Tgca0MSL0XTiBG*$2IhsV{lEdER?roAf0~eeb?!UsV$TPh5KN%S{<~v z{C0vTOy2T;^rO6!KzTpB<@x99Ewi62JZ5;vr^#dP=;-L|?8GnrOYn#nVn;X~-aDf- z2C+vR$1adZoXA^te-oL@r2gE!@E)<5zvt}{TiL&jK25{)GWDf%eE_Vs&9@!mOVzLop;>yWqE2+)})XSMh)Rl~{;0{vb5jB=lAqmEC05G@B81z>F>z>8E z-nC$*RZK0TH^kg8srR~Pd)LBtj29ySI|^Z+7IyQTcD{XP!s(5R`yD8lJTE^Pta?j5 z=KG27rHRKeHD8J4D%i4DbC@jZubEk~eRnayv;ogKXl8}|C~5peKx;L-0nT!9aV4=U zAlOyP7iL!~HV}IT!$z=cf@BvL!^AKge$4NXr#>wjP`NGx$9RerM?IO>G7!UlGq83I zfnjc!yV|5*K`N)}^ok36Q6~Ko$8)Xlm>71l1KN_PH%a=$(NC#QF$R_5wI&9|&jaPz z(6moq#S8b|Qs1(?g(L5ASW}n^iuWYVma16&AP;bQ-?^GUcr|qUJqyv*zHf}}K&3@I z=8vMGUTSDwsd%%Aw}mm~6TICQ_4+J*Ci5 za3;%8f@9!hUsGV}YlQZGbp}{G5-fJTrT#?`3ap{j$W++a*g0bAlAbQLhTg_U?S1q( zZJv=mCr;Z$cSU^X=^>bIc9x7aVK$yV7uK29d-3F|n1`iB4GCPY4!ccUk9Syt>xa!; zS7Tgvd&&m@;g4?{Ffu`udsp}(3nhf4m|lV@2=4;LcjY>KBPq}4jk0PV2tM)c!q)I77|pt#JkAE?POd1V>7p{ zF_q5y7;@V@EuV(P8EUN;(n)qnhCKkRr#gbX)G9KmCOu-`35mUrjFtjE83MLze zw8y@5z|{MV)A1V_T~W)Il@6SRj}bIm^B5ow>t2QU1&+#>@rNRCg55~=6k&k0sLO7U z+@F7nT8ZI`Q`uvUq%he}w51ip5RD*1d2bB1Rgo8dA6>lnODMK6d2?Gs@jco<# zi6IX7=-yGkpp_QvrXa2sJ*n#tMO|J#4qxu}Uadc$uwOTWh_Fj}8wl?^vy;(sMYiimlkw+uB}FPtUy`LC?AOJg(;czi;h5vu84p z1hCrstCCsYxAt0Vul0T3`qsC;_1ImKb&=a|b2qJARTryiwl%G8UA4N^wxX%o*3z`P zd0CBZ1>$XMJz-zvx@#kz%E{J8y)zmKT_37&he|w^Qz`zMxkD=rIhHloRJYbF zw^h|FZ>(uqUcF|Dt@vtNu<6d4l}quS;(2rDB4*b7*>mR?&zm~5)LH2luNqj!+4HB* zoh8=hwzW2`vd3!ftcei?R+>;s_oJQJrO}`};tK`4x5#a# z3sGQxiKo;T^w_CfWG@X3Ly6{4g(qmrMg~hL8bOg+0Ed+L!XD0SD(K!~L5#J+=`MFJ z@N{<$@dYEEu-{i%K?za4l8Dpg#{&f{L6q6$tn}o{-JO=T!PT+YItfjc#*1cB1JTqT z3P&Zwe5t#$U}jn~T98Ik6{@{F47InSZWZBBh4~_CN)a(nv?S;Zc#1ASn~?ogo8 z415SRv;^d6&Z0J4+(9buAian;KiI>l#~Z ztu-yJh=Yu^*4EhWtZuGrTHRu6TD7ccc}Nf`XMhn+z%lv|!f$c7dw78Vwx0uySx$f#^sJJ^+v3M#Z&4h|fT~ir{GDBNKRA+70|Z@4yA<7R2f0c z$kdpr=zr00r6-x!?e)0Ji_`EKz;i`T(rF+eBC<<7Zof0^nNNv53!Q!k1PyXSg=Lq7 zf)S#*5D6<@6AG6Q=W|?WUcebH2b&>+7Or=8v}%T6Bj`(TvRXs+M^mX4C}0Rha4o4c zLVP8jV8j=}yEL|ono>0cWS`N!CCfl$EA&%Ixd$1{{Q999o}k;%l8_+^1?8ng6jR2V z)SJ~MqIs5p(;W_R>$Gg5evnfV!{qBMhDv0I!4c@U1QA9q(PO4oR``8x&(zW|bPl~; ze~_pk>SK&Unt}zM2t_%=3&NgKcaXc;@YH0eH+9f#U(grP)CJJtdP(k36k-yVh$~v_ z6!jZOF*K2agaZ+IONiA`j2Kf(L*W2*$XgISEKpJzSzO_%0(1Dod%ccrLbUPO-&7}S5YS+Ei$AO{GxYHHzGuq#1kSx0-345YHIaR<3y8376n5=yE_yl!viC(Kje(qi;FsLXoHopWf-)5 z-a?pJr9KQiRJBUz=FOc$sK{bF1`bAZHFR;rW5h`u8Rr@l+bewwf+!{ttz|3qEvn#T zIieV@gNV^HM#8?}0=wJm40FPvB4I^{Z558n6H$wdaa#Em=v_zyZjDjLc6VM>-P~Ng z#tutxxvjbpe~jMMT-RD-LyMV>uTs06;jnYDoh+b4Lx&sV^wt_96Kxx5NSWSlV}?ZI z(bUB23=}9dL`S?B)e}Ux!0@CLOiMf%VR&F9hcSbJPKG9H6{`ySV2S9=%@@UKk$R(3 zViT<%WlWpi?365tc5Ag2#Ty!ap|PmcmTNT8vKX7LHBmeT0?h zR-R_^k-%u3BtNy2M2bkAq9>-sPcK53F((Ab4C$QA!fD}lX>h=|$WubFrjae4a5xm6 zoSxHe$f?1cli;+M6d96gFefEAE$K8vQVr&$1S2Vrnp~f0WVBcXNa`pj7_u{FpFVAR zda2hNO4VR4mEbMe1`3akHZC>N*miTvvg%lM^DT+qnH^oaBGy#hiXqdIprqmoE#g;X zMT1Gu<#Y*clpS>iJqutxYiV2%E_$=p;q@Y+G1) z5t9!Z2J`~5E78?S-*S_(-JwbY=2=u>!2F>FI!5*bcm*p8_5>M*(B>tGfYoBO6Jb7q zp_98LZ1#G5h^x&ZQmd#K$m!M7!k=8zpJ{B4?rGDm3*tERytA7XO;x_I_Sy7BLop z76DrK`x@`-J@uHcvA6d`!-+QEeoig(uS9vWMM4w6TmdQv$~aG%mZ$6hr_M%-9Fbzk z!FtEfavi;0wQY5W0Nr>vP=B)9zd2@ZkD20g0u7Ahw8t#*qCm{VSYCU~8oxLYQ%*jH zghSe6*`2jC1rE?pjwGSO&@;)4@Ms0`_3S6y4}a(;?rNU(ckC|~tApbR%A-y11J z8KL~H`VHj`Cl1%%Hln9KaO$?go>1ZDP~n4t^3P9EH8zJvw0^dRBl4O%Y@G;TRvPwM> zx0eP0M9TB<#+(XQ1e5!)lRY}{QiMtoOZ1Vc|K%>Jh=je-V0rNjk;g?DThVcD^&Tzk zs_*a~&1pEXAHN4`50=%R+Fc?z<4Z7g_l1Bh?}MLUCD;oDT_$GH1ON{U1)~-pENeJ% zAb#kJ^88wI+ziva1272!W;B7EMVf8Po~PN|hS@XVYf_+)k%A)@I8eDJcZo;H#(tlC zz-N*VI-D*MamX(p_M7A*-lI~$d(?!;o`%@);0aU>!s|Vn2dtd1vbU(Z`m+FINDa}4 zY=!a=0qmFrd8gXug7?1C#bmsoojiibm=ek4k?FKzmPDos92$U-1l}$HnB!M^09z}= zZtXE3@fd)3oU?)&SW@9ygfPn$3i&-zit(4YLI}++7)A@Y<&{njA~Qu$q}oR_H0wh3 zN~?g(>Xo3=4)sdVXtdJ>HGn3fzWW?r`4?W33@l$#uar|di&@l7;flewaEFybyxGDt zoXR1hWDC^})(YvdyKvSB<+$LBr1KTuCls1Pr5pbW?t zhKrAmDTtzKQT$uk4ad1XRGHDoNaJa#-$&kKLx9)b*%Qj+l4_AF2wIFLT7(Lb;I@&s zjYWkxGq+EG+`h5pe(DW@P~P7?x``@Af2aor5^BnE)P7g5OH%T{>bxRhlL^;ukvb_) zhAt$hD*fw}t8$3@KOr%3b4o&gs7|EdVN!IEB62{_pon{r%nYBZpO6@=nCwco#|LlY z0&?;dEb@dyi!f6R1TbMF|1c%H4uxd-D*Vw(!lttjE+=pz31S7NZSG}&as$qCkDV?0 z8#zt=bs`X5qkar!d77i<5%^dVdcnJJ@EKF>Z_gWBwj^p=cPz@xF-uR7fCh9>282>Nh`i{c!6k?NsBAf@5(Y?-_*sw8??#5- z=<%}>q2K8}0lcG-RU4HA!%Tt=XC@d%6a@?-_5?jTk?9dX_<*yXI9-Ad8cv9^lL;_h zv+a1)0`-Bxp~#vtILKAqox>~3eHC!B@Ja$L40YymOq9H0StJgRuz1}JQ2GIb^#ndB zzy=W%i6Ebze8liP0{$hAyF z-p)beG!9lx;GpR;@oc_08t`Q zBFc??B9)$RN}rgk`ewVZZ{Y>$HIV)`wR3T8Tlsf2^&(kj*eUFgZ&97si^-0(2PO^= z4lukRgl=tw0p_lUecsSk|MOh7$-Cl(h=gV5iYX*rwRQ|Fj{VL9E{O36tq45e5 z+yWhhRivOBV^0u&E7ggM_~|lXTrcODu)Lg&=5HafrIKBMVNTSL!@)d$`u#LDx!#F| zMjL+9^d-Iasmy9p+JpvBE@8SdpKjq-h;fJ`u1$}))DZDlHP|}US+5zl`@Hggm~lM0 z^wIcEvrHe2?gW&<1ah#k3i{Y9L(#C?qfl=~6*Y<`=0?2Q%8RlXsAL{5VD@7+f_a*1H)(nYMur)T88R_cL30+TpKI|w{uOHB zDGV#g)#P@05;;b^9)AU=Spj}v>6j&BGsz##T;%JC*WXn``4Et47j0kbnX*uQ_o>tGK-MfyKz5HMNQL-AoOmyny&<`>7AV>&4tJ7p42QqLZCU7%iQt-;cfEvVg)~kXSJSNtW+}pz z5HIKAcU`7VGA~k#ouZZVIM{0!f%#?*UlCr1S3%cYIYCxIP)@K<_ap3QbPr6oxzI*e zId+eUnHtdcmAxy!Sl$ye6ATLFBY?Vk^NM1wYcYry>ZhD`%VXx#cyKzgtw zkMv~WJtF|qxZmF>~tzc_cl&bmcr`lXit+lqR46m{U zef~+j&XW=wnPh9JZCV{$ZfmY-UESPhn;$A?A-lyWWK{_vL-U{-PyYGEDo+>`l@uhS2670~Abvf!ao0s4N4a{s}SF=!covts9 z&(N2Qn`MlhiJNjvQ(Av7s}AZnEt&d_Rzh0GF_vrSIVsV7x(;oZiq&CIxN5d-maWw` z!&W?r`_gG7h~x^L>0kf+ooTo(L0W^(AU+Orx$4R&KIT-pfnLtaGPj%Hr=>BDInYNX zQ-8Y6*q;_B`V+-chx!W0aX}h6(t4B_jpH|PlXhLKI?R66EzHV2+88Bl;Js#HF1#X) zcN(htC&>=gi#~OQWA`YnN7ZAD;_*t1QKFmGzh*)=@}8y}6>`q+j+gq*l7aV~WT}RpV~Fh2Z)R{OSz;86g$c2UDd-}-fBr5qRF?^^xuJsyt358J zLA%DNUb9av6aK6{!ld1M3A1CbBBlbb2;1$9ik14sX-3?bLcQWEpg=(i1=9LN`k?DI zm#O6$2i-xAw)Yyv;Ld~?Xl4~CaU{*erS$N=QScS0jxjosw2gkreUeF$F|T5Ih%XTe zY-vxw8u)n%aTQl>*(j6=KF3t-BWKG`T|+@c|Y4~wMg+Re7>0V zBerZaA=1TGFoec!Y@!3wS`fs%klj4(|Sn&rW$1iop%z%bU@lnoL*2yi_q4Kw# zF$;ivi5wA56h9Qi8G#O)?`SyT1PuCEK_8{aTV$f$;!4qiB6d0`MWy6hpcqe)iFRBl zMI}W{Or^+O#H3V;Tt&h=L%v<%@&V-{7&A=d6`+4iM*~ew6E({6q`p&)5>eVv{BS`_ z-lIv&;PiHX`o zQGWlmkrg$9ggexQFb5PYIjbmHOb?Ydt;Q6wL#-0tBH6s6K$aT3Z@*=RNP1(r@5gc- z4IdqM{Qf{${mHKSN6H#bb~Svn3~bsQQ?OCv`0tJv$cnH0iJ4f+-lDk?tK-xbgJq|9_6{#}Td z5J@3CJ=2PsO;^84=$z8&G ztSjBlAU)wNv@#d?fJncdODJ8YE)v7Xvr%;s3-0IqoYpm^|5Rx=h_sJt2M>}n5(=GxPQ;pGHA@4;JgDf(D<=NQ|W z^1YQg-^VKHNvOwF*lbqQ zd?&VfH?1NM3MWC=T7-Q97m|RBu0)XI_wa|p7c6o0CaQ}7X42QXpuh;Hmd(c)goWp+ zSbeq%y)qT$!#yrv(ntSpfx04f2;on>XslX|Z4a4Vlo%Mss!K0Wm!Ud4)TJobLVd}Q zf9Yu|s^^zYYBgtG*1bLJDzQ+4F+iKjQ`4a>>T0b+Xp#yVu+o-HtWQmsnM{Id!Xaq7 z!X)T3A))n_VR7V4)mMZ(Od6*y&r@so=#vsb=Pc-O+z!`zhhvQTI9j$Gl_QaPvX8PG z0c~dTm7VO0Pom0}_0dsf2_1!X8(l{ogpMlLbkue7VWU18>3@m}VpRnH9jl@X{f|D9 z9$9WW7(bG(g_s&MgvY@&Q=`r-jXJY6>RhcZhniuRUqYwzn5=U4dDPGc2^1=zgJb76 ziff`&7x z0d%#@xv<@coyM6u`P@Wzo~m_cobXHQ&J&W|c^n=_Q+hKbqXsgsI7r~3_vA%t4WLW{ zC#>aX+VPktnv02_`XWnZ!uExb|M_Q`39qK0d(yVmW=(P73g0zKtu&XacZjv&Jy$aC z_p+rc?^VP`i&tD6+wU~B z@gwnn4CQI`$)g1&T6aP+UQo(=Lo6ue8CDcV&})!@0T8TNlEL z0-fjNwI4ww`;2Uu%wo+)Y2il4#cIN?tJLbOm|7d*$US0hVXtQXi$Nww;cg_qQrkbZ zcBm_1ij77i(*BXn1N&?xnwHv^R-<<8Y&Tx94{jEl@#O5>!J zMU=8bZG<#a$A7g3MjhUFiA>8BP(x4elAk8r#7boxZ7gcfw2vnKcBoAh+$n-PM6gH% zJ`v0p!DJC!EP@;kr2i7ZKa1dm2;LIGk3{gS2)2pfezmDpZCa)_h1Djf+B98l8m~6x z0ias6Q_W0w5qM7$0+2J6-<;euRCqTqTld(Jv7qO+uSoWHV*g45qo{NjvtCF$8 z>f`E+Nyc7~1bLCsw1(;{%nt&kf9C`Yo=Sp$OoG2lg1=0HKTm>hCcz^~aBmWPDG7c* z3GPUOo0DK?65PPx+O;D1h6w6KaJvW=iy$Ndb{w15vhT;VRuF70I{-{;*}ycdy;!8Y zPz1w7kR<|ABu$tdR#fhD3O7Yp{9@_^KFpO)KHBzxui<^GMgA6Meeg~Ez7{ZfE*zMo z@d~h$w6%kN%IIgPRgzp{mPIZMi!)eRbEjPrR7bJ7(bU29-N?U8B>9`t{gb zgEQzje2#5_u-@lkKa%G0z%u+S9K_a6!A||!4fu(b7p;b881YwP#9w``BmNHc9vIMz z3-YBE1;yt22H)F1lTY%=iQSj*S2#c;HOw^yq7U>HpuKY>Gn*J9L#s3LtZ0fo`&=gGFwBA5Q0;coaZnhb`3d1$RrIp zNXP^YIY7vz8nT}d9Ejxt_7O5hLw-cag&OiIAq5)p3L!%^WG^8@G-MAUSsJpN5IVAe zP}+qb)8`rzC*(gg_vYn7F4cSJ>!y2-c zkZ)?p7DDdVkj;d&Ye*L%>onw1Le^-=BZREhkWGYqLqi@WWTl355>lrj-zKC+LujL| zsaiw6Nysf4@(>}5HRM4;q8jo5AvbEs{e%QGq=OKjhHNCnqahmzacW3AA=hb08zJ+6 z+(*D{0P6`T2C$9*JAiu$m;`{jxoHA`dkDA`z#0O^0l1rhF#yP_$L&m8 z>JzkK-82M13jtXGnhB5rd;@^|Ie=9J{09J@J^dSiMv6HFU?l+`1BemuCjhi1U;YR{ zJpmsAs3YJv0BQ+10pJb--UG0LfVTnE5O55@asrM5SVq8`0BEna{9^#s1RMr%I|2Iv z+(y7F0B$8<7l2y`cnQD~0-gtOGXXyUa1#OF1F)EYCjl%XKm|}mz%~F23Frbq>ryzJ zv_&T8zWhx9e75L*0AY%02XG?+>i|>`um(VgfYktKJwg5kfB*q20r&~115i#t4S+HN zssZ>2xCMZhfW-h75D*1WO2CZ(JOl&)ln~$p;3mKWz(s%)fRljh05}Mk2jB(*W&^mM zfMNjG5nu;!Edi4NTtmPF0P_jB6u>+J#sQd1z!(5?2)Gcy)dUm(m`wo5&nyCl0GLTY z7JwN9$N-7~NS_0kPQZTvm`1?A0hmg_DFAi?J_ay_fIk74Ou$C~iU{}+z$5~G1K=tG zP5`))fcF4QB;aiT69_m4;0gkc0=S%jHvwEmz>fi3O2A+U1cDRuX#>%XC{YY@l^b^R^sI^M0I)P>dcK6Ra2Jh@(7KU-bLGeo8CDs}yMbsf7+ zl)4e>`doD#I|YrD+eCHf)RD`2p9SYYDSYl$&t{81%&r^C#=1pU%k+@KbZh{)c znIDveCubei2giSM(N=k(vudQP;lzo3-uhEr-ZnbMBX%cj_QtQP8j0gQwFg}V1&L+l z2{ zkgcISYCO6BLU|}+Kbr1C(|u_A!B8Gfmge=ue^YL~K-L$x9s3&!F3ok~+^i2bCv=r< z*d;wK(=m)f*|1SePE`7x!${R31d)BePH*rnDy ziME`u%Q=Eg3>a9kaRN**WeZk{gEOXf-eVz$6C4%}wT&2!z!y^oyK}JC%{O_8vl*s! z>iS_B{W%IRQ5n5D5P_k@-}zJ;uV%^Y%~DnpKAK_$$a4viK+Gq24B$BhC&1!1(wZn% zI-1Ca9!2FmOR-NS6SOnYxK1D z)HJivg0oCRrXcrS^nhyfIhMYvss;SNv6Tlq_7g9wiPg~6TDH6JoL*Shh?_SlriQE& z=_C&28D5M7fGG~K+fp22H{r#4!R!%}@^5F)%E_(uxSf*RI2o?j#9OpQ7D+6{NbR(0 zfpal*@`t5Ff?lAVi(jV|wZvkP-r_TO*w(_sM%3&)cP|?i(}hhy6B66R>h_as)%)3_ zo669cAKg&9|NgRu;|JpZLTXiXwlSJo9m}=o!m3uL^-F$={v@-@SK2JI4wjxIHA=7D zjMq~5gFgETFm!&qAYX=_!@nQr9+hrq1w)zx5vY}Tf?sH!#R&wO>0ftyfhMygp7l*Q z5<}!-{QaxuLnc=}7i!>lcpQ z<8eg(b{afu^PS1@kH$@sGT+Z6YyHW`2!$}SJDS#0vnt?$p001X;N=OvBp58O;9)IW zqgjP`uLb4Y%+i1BB!(o2ne$~?QfbG9Z=G+I>K8gUu0ZJBn9 zWJ_yPGnOP;npW1d*4BX^b&WV)y9)OnPM_G_IXST(iPI%=)gTq#0S;M%w#tkh1B}TNiltcr8#WTc~I);lSz8nh+H?w$&$P8#EGl8HP z%m9LlnSk3te6vP;)@#C!RO0kh`62(l%)c+uFBqYWAV7MIO$2G1kfN=L3gfZ{^DwF- zwwPj*DGCv}!D1@$WnteaKNR{$yhnNr*#}n(WY8$o4GN8_t0SeFfkgb$7lbS-FAk_O z-KN1-Mq$HRQh6~@+Qu!Gk|a@yByN|J?z|Z=Nz`*7$>UgZ8d+DHMiQDkL1@w_awfJs z4odJXS*fdseT5?_7Ehdp22WuAGsNj)5QrkWZ}&`(o-zl%EsYDCFv>Am?wD>rfd{8*OM~t^v-k* z>(|#5)6{L{8B8&1ZkJ|`J#&7{vF9-`O@`spKyrvMX3_zLfQm*r_(5!W>@D^ZoXnRL z-WH5IY&_as!OvsEZ>nB2^T03dq(d1)a99^tm0=SPuTLvK7t`&Z3;m=Vqj}d5B=CC{ zdi*m;S0=DxU3ct+?wEtMS=T-q!&rxSg(e}5dqIKC6w5sjE8Op@|EwE2t>Faqp%}S0 z$c99bJk%AlCT0+dnETheLc&dBS@CAklC03Y3<}k|Q^_pnyhTEJkIG3LLdar^M0!D3 zBs=Luv;}m+y+#F`E|(=01eS5V*bryL#%CLBnu>g(dwb3e1=CG9Zm?am1MBxi4>ph+ zq8ukFhD-7B-i61j@{U*KAFmp5ysGec)yU%*Y>w~a8T~(a(Ok_F!Ob2*cj4nUAdhHz z0u|#>RwNX0`h|iwjTJ5n<(Oh&%KTECTvy%`C)bsC#eOs8xR~T9Z;QFE@(W5Wy^v)+ zqY-18!O30}9rXp|5X0t+kUgb>WQt$f9NoLG=aCqQ3MnL1$33mK4YYpV%R%Y zf5;y*)17GXtGxbK50`B%4@^AR5vUz|^8sHP&eHiV9rx+xHv-5{0Fsb6`PS~v8OhWC zpso+!rbxL<+Hg65c7e1nV$pPu+-9K`wUY$N@w-LPgc~GsX-lNtb7K@Yj?9_O@%21Y zkn7nrlH=y-92=X&LE}ZZv>;!MmT_#O%MTox|fvcr!RuoUM zwZiLSyJ~e~OWhrfHOuWw*Wjk<;z_tTHD~=qI$w%gysD?z&csDJPu_=%hR9SdW}ROy z&KxWkai!Rq*+`60J{b`6IO)j*yBIyy%E6~eo@9e3S<+>+Y9jTHN-`!JjDc`ocG+C< zNP9jo7R{X`%%y+-|AsSkgXEu?Gx>ruOnChC8o86Nb4PzF^>Pv|9k?`M03GS-6gDl3 zQa_=;gbFnDlY|PS1%Z0pc`3TeXm9zehkRSh{P2eRX(6Dz;rPM$AIOu_&E=7TO90rn zK=MZlZvG&g3@^of{?U5|`D$doY z^O7+0~VqMcPzVs#0EE%)g$Fw{lSTcI)b%hmmKt^;bm!fpyBx8_#5T0 z-c(Urvg4AFq}}ERLvFAp27Ob=ny}!q!3(K}s4K?_d?g9KzTIi6X~y7IV^*QRv@c{MDgQ(7)JT5#+3mV!`aB5T@00MI`&>l#^^LnlHDBNH!Ja z74DzOB3`{j`TF!u9!6izgQ&q#N)mY%CJN#M{N~2(Yh1Cl=gVmEw z`(m&~CidN*_UI~GxG12qV^P1sFkkI{RXhh;`!HNC0s{+1C_e|ToNvHK7XyjuDxw&cvJV;hY zz4JeZkpC#{^Hm^~V6gZa0-O)p)v{UG)!?DS{elZ?`f6z0#6@hV-%s>D;KNlXk8bk% z%H*H+VCxaz_VO|9Frw*HU*?o;_4z06r&-nF13atx2X-6rTc|fC0K=?m?jZDWk~#1? z7`U^VXd}n@AfFs(sZ>50Ns;D=&J4>p1T$(m`1E2DeBMvkYbM6%@YygY={pe2S>^+C zvK=u+M+F;?a-5AvIetfGmT}KhPI1pu1k1?d@F#Ex{vC2nFx%4N zz`El8S$7(jgkap-fM8sq#<-E<3vxV^8rm~Z{;ki%zma|TccItU@W(QlyiGa-|LOcP z@T}Bfst?3+kLYEr@Z`8qc%MwgV3o538++)J&XgftKe9QioD$}23M*myY-j@|jjYt; z2G2@^|3k3yp`c*p$P9guDtb;ly!tEP;b128i6JfB)pB|+<|VjD-|rj%AB6|y$NS)3 zslB>(d&i64ec%n^Wu|!W)822_%;aJbyxgYo@@kEjeLr-0PTX{7;%1qQ1GDcY4V3fT zBd9v5;727!LpO{A$x{&xUvU_f-w7yH{w`77_5}2I&T- zY^R6j?^xK>QBE}xDuzUzPiZ`x-Y?HqRJYpk&B%1OnBd#X6+&&6XnZq%@l|iaK-rdY z_?y^=Wjy@BfGPaahQDjhhGDvEEipyU8bDW*GITD}rez(D3uewtn*8+1L3&j}Kvzjgv7~_+@xNv=0Iu#?oZ~OPAQIfip~| zLp;wu;jMrDkbmWW{ITI9|H}X5-~Zy@|BGLCg{L@9*vp;R!;t_Cn>hw+hH4*-Hg4(2 zqNZ*Y8k4|pC&3M@8$V%hm0^ZXsUGD=?6rE3!A~ck_mSHKy$}+E>nRgnl$7Zo*Fd;Y zX4&Qp(2erm9M+-umd}6T_Ey}dC}t6f)}TV{wn~1fXGqXfW#{`*Pv=yjRy>i(Un)E+ z!nHLx?$#cvJ(%>2j`jv#KjPn79>k6vct&qN#GcPT_zyxd5~tgU#r^p~=M7TXYGi>2 zBk2ugEbclvDMN6h7KGWhAGV5{zffuk`?hYitiE)JgK zb0_J3N70x6FcTaf;=pab8p~5YRIYhv&Wh(xX5=}$YtEhLW4(c2ye0MJ`iFlmu9Gt) zjq7TX)sG~>`4#?m}KSYVlpz59??8kXQf9n z%Llu%zGm_<*!h|;A%w4Muo99-pC@ApVZYbFWh9fIi{vCzJY*$PG~{J!|09plFP17R z<8)cMT9XxR_GhHW*=m#B8MO(!%FbO{rjfB3d?%K7@;kv;??Nhi&Sf>5S5o`6WocK5NUql6hfR|8Dh`lUyux) zop#YZeSc9x6vcOkQWx|x3z5P1nJP}V=;E|6lTOlUGFW+nhz_fxL&SVH3mk7}JU1+E z^O1hbdzz%*@Nq)kmiSO#l~#-EpLpvMJ}})?)*cVY2iezFd)VLQZ;#KD50?ktKjPi$ z3u2=Zyl0E|l?VPQ4L_cO!^awb6RZ94UETrs)a(PcXK+vOx|`Wv=sbd=kh&!JED(JZ3QAy{&1Qh z`wypS*`F~)E`BDxU8%LoSPru6+}W|9XeZTt=T0hNJQ{L6H)K3DB#knC+ts%YX(ep! zc>R4rimm9p+A3j-%~#=%R!%A9U;f6ifR@rnkgJ>TXrXI2YVN3M*84A=6TPR;Qfzwv zaEbm={{A8K34QY(pVTh@r@m3gQ=+I-9HLHf=5tfi2HYihUN||qE@Wmo*S1*8ao%OB ze3C1Ai8MrPi#}Dyed5#d4u?aM=JM|Z{vC-fz-MMVUc-})-urrc!K0sTl~)(1e^SkQ}JNRa-YBJxrJ#PLNaB`)y~ar{`v>o|zbKUindrilaKSDzCq ze_`AT_!fCe&MUVpLSa21D_Vaw=rizZL}q^BGfL5Dlz+5rzu|7qKmGD+l9<+?mR~FD z?#AUd)WLZ8p$*L4+i4HDY;BaJ@i+ApprmW}39-`b01i~eFhSdLdp{9+ScETz5Jbj~kEJ<7+@{S9Uzqzxph>vi){T^p9T465@g#(pE>Kt)Jiu|JX0i5T=g#_}g zN)G462XXZ86)y;fq7^nzI2;O3&c$sG;w}-I?c?%Od{Eni#W*0+zj8+2k^dosyZG>g zw*O7uHH;GdU*yQD2!|HX#j&^#6-O>2_DT;9ikDEtFFE5L0*^7cm%t-Qkd1tKZ!0od zBlc2XxH7`u36b|iL?Vv}=8J%Cf0Rx#{0f18V(?W0U&382qa6FaMbC?@!?!2JL?Tom+c6^a98V=g&t9;^mrk&yg6!LT3ofj{wZe3PO*C=WC z8W@R&uT${Sm$rt9Z?%~xM4SsGd4#AWh8omI&GbQQoD%@SOrdZ)CE1uM374_wE)HH{ zi$#8QmfkjVvTc?=ZKEt%8_u#3oVml$23w}eY3CfW9%|3c^jOp#VuWi;mQ+N--e|CV z77d%N{SKSg$_Hag`H7U_5D|Y$k9aR7f(Fdj`yVg|WkcEx!=<3V*sCkY`K)GgxD+4O zRZj72RQZ$!$J6N9;hJqI#zbkO<^SXr9eZ|C$9rrO3Iqe+&X+s>hDr)s5nqPxD>?_=XWvk`<+s1%Z6?tu zO$KO)d$7Z8731N98?HO})OS0AcmB(IhBRI1>2Q5Zk~~O@xx|9|dTH$J?M27YcBa6L zjQ9c`%+o}`%1#5%lb%Z@JS(+S(sNW_;-7y#XC(hQ>p63WYnDC>TfY;N?7zWG4SdN- z@`ag`qUJz*%+(D42^C3t5}gGfqWdXW#6Mt>=AIuIi_SrreJvQo%Iv%{$YO^sOY1az z$G+$^8gp)F0~6^d*?+hb8Q3QJ5O<_xKjO{=CTSbl&%~t6dh4!!ZMGZagN@N>`L9#d z62<(_J~6*ai6Pb1bDqt%X$IA0+*U5ftH~@im~CPs`6+Q`j?6Z46-J{nvjS4y`!4ko zaXA=yMKKj7CkI1P$J~zHzabOti;Ftm_;la@U;r4~2dt7m>TrWS{3CT(cJ7q<2b`LJR-8Hq_4T#j6RWTD%O}xm9xy8#e)zZd zjJBVdJ6b=Y(W4YUQpb-Tn)(?3q%jK|nmq^(v7?q1m|>FhS8vjQyh%LgU)#UusIadS zWLhNMb;O172TKO#IO6p8f%)t;8Wyn!qXAFYi39%>HyFp!kchp+x6oG^3V*4tBd)N) zy)y0$KB8%nbSDw#Hu_hnm8bI&apH&m96q9RY{a=ZiMWwZz&pgN{r3ysFAZ6^wWORJ zzxNz27oQooP;7tx*F)s$+klU_7(X-aeCFe(|N1kyWSv%((EhK4%hl)V+}C z8`)G_Im2hh6Q5>fhw8NH$*+u?wDaCIoOM?gFRn=cb`zs}ZscIEO9XR7kR|S2c%_li zSBrJG-x*z+l-B6>8=Wqf!q+=(dcPt$E|X6$>GHE?ddxM&RjNjp-wZI-dJ8cPSJ0FZ zE2|P;jIYY8qOa!|J_>&%2+rY)@DB&sMgKtXoW2Kdr3y*E75DUJVwkSXY{8J7d1jwJ zZMxO0`@t2#nD}+vuw56CyLQ4fa~T)=zh{c(PUc|mco8T84qqwd;8pqbWa6tZ2W(fL zO0k*AuKu)7%x5VvUxrH2C z*mh20=gD?Xr7auEsl?@|zSKScwzHAG=WIKh*%Iz}ohJSPvYks`_#MyrLFm6yeExj4 zg3l|(Y27RurHMRE95-gk3l9GM)f7j9K3tIfOQC$U-|6`{`Cz$RZhHG;sgIKQu>Z;T zlmTxtaD^5bbcCiq#a&(T8%QS_=H9F-l~W}g&2w+;)2c2(5H8y<>n(^GB)t>Ocj)T8y|q3N48#)DKJ z%ZL2$_}?9S82dH?*vo|Tpo{mBM*S@lD{-hZ0T@nqP8~3@qCwO&dCR1^k_U}Ak1ulE znMSS<!(94Fkb&p*FutyG?9izruA1D8`HLxI)ah(S->1 zyZ)tX5Cn5MU6ls;3JZeyMBw0BCw8z{__{ac6t5a<1nX&ow4};SnmnDvI}{tqsfA8l&9~_N7y`c;I5_3VIe`sQuCi z+lEF9&&@xIj(V{!d8Ojb2HMU{2%n(s`~+h?<-^bTE_&;=P{g%KeUTh%ktTfVkh_qG*#MVs5vmvxde@3d_+^;IQT-))MxKc1( zAN;z1eK7FRCh9Wokg5`DK-}^e7u`Og4XmtOl~b%-l~2#ShfRS}$P(Mvh^G4HHf&3C zye82Vg9gn|g6jpfv1W#0tP#>%F$E;f0g0U-%l}If0<56cD3o=qwrvD=2+E7_x0v3> zS2%wCC~aK3Ju6CE#Hj6XfS|mFq!~;4hCvH2v;P6I8eV1ybF($aGdzKi$fonU|CVwTT=0I^NiXY7RvG5d)Fa6?3hT$eM13 zXczqj64~eq9~_Zsb%K{E=5HL)B;>o#GDTKL`LjC}F&X1k30{k!RfrUkhTGCW?Q~t; zYNWO~A=1PB$wCWgc|`epCY+vt^5LjK_sbJ-$Rt{wBcpJZyqE?MtWGFJqff zzcD`X^$dzNUsT8s8?E)6_f$0ppW5+#1#W7%3vx49!e5Qx?2|Pn;yLNFqB?yKmZD z>AQ)pJ7!OERllY={2J`Y{3STqXPPej8e9fE@)_@v9{7Y3-zBlr#`I)Y$;#;3pwD6` zNUWbZv8K8>V59qn|C;t>u$cnCT1StnKHlN<@rM?)s|0SiWzYK^H;i0!amNiUcgH~T zoYK{e%jh$BW^v-cGM;0LrWH{v)r+u3iC2Pk? z#Nk}jZWX)5zWsG;KX2c@?~@MCd*8dm(|rH6_BmCj zDg{XZTl@R9k~(Ycv(G+zuW7Hn_Ha5R^Ae}m;%r#8x+YT9XlYo}yn0QuWo1L7rKw>} z%0f5!?4FXqP4;joa8sbv87Op>O{eth7mO&=J+Y#(s-n57 z(o$YkSzpyuS+RDSrQkY?zu}&$Rm<_7f(7&EQ_8~G^A^sTIekQtz050KHPi>^6fB&J z2m7Du++`TwAW72Q{BNWr<>tzSXGl_xWRN>|wr3Z4ye?Ruy#c2|>U^v{C%-IY z_ZQlOg;tNhG#twBY|kmMG&iiaMyl?qiVy`>8Bj{+*7o$Gu-_T-1pJ-b1ExSYgd)=bW)ymYE`HdM+qvC@6mzNFSz=%0>TJ*O z_(QIs*HczX8Bx8$klo?M4FxPglF?x=b7je$?WX(vYa)>i5}GPa6wRatqN%-f9UH&q zNS*Duvy+<9ggjDIq1wwMQF}A$RvHYH8ZV)yJ<%@RZW&PO%R)!dcN1RwyC*l)%4Eo29#%9Y!8+JjON8( zNi@YBswmzZ9Z&DZTTKp6$l(o%%4BH#E5qHqGLJ9pMN_P$9&aF|=0g#Vu&QXM2{& zY7H0RX?>CAvQQxCikF$G;#_ESo>o#U8`!Vr7+6+XX`nP-QWj%L<)~ReG`=g!FzcHb z_LqD7h1z>_1!@fx62^6w3X0cWS!NyJxxbsGwf4gi3<-H`Sl}IJVv(>g#ld>3d&AMD4+*#joubr zCYopR*`2`vw@!Ub)DLn>Vi6%^?gw3J1Yd2yQ zM1AyW$dkLs6`~}2a8b}z|yu392BYkHxpG~|Yy z5`(n1@C}!Lu_qYt`yk_;?H6hEan;{b)7VhIs;a)3#GXohgnysn-=|}AR^I{JtT%gk zMU7QeR_a_TmcxUIG&Iz$SxrhpRwSbc{GxZy)FVWe*c~E444JLHY*bOu<+9>ot2YoR z38Tl*o3>ooiXycm)A(zMUM8A6Cf^_MTb%(vIUeY7y#ag3T9Ds%a|^tT?IU6Bvlqk7 zD)OM?p{kX^Hg9Xspdt&b=r|b7QqiR$mmVi^WSnbIU@h}3@}rnoview&XGtk%%M`_M z9Yl)uU?}MEFS0t__8?~*Au^T**jM4CY>~7?pQe^y3hhE3aBF;YLTCFW6^)G*Ypw7E zD=iiE_+#|m#+v3T3tG%gj48ahg!rnOd|7;D=YUC!io>mP_U9!-tC zPDg<}U2@2cUOh&Hi*$F2z_i$n(YhOYa_Aq>(Mi{2wPNK#4?Gc#xjCXZHBoDHLTaql zWA%BHo1O4TtlesDMe(|ZU#u@GvE?dF)JOD9SDPsA=-Zy~h`#YzTF(H<7~yER4_=rWF;DipJYx+L<0+zB1BK(TpzB6r-f#2rS`Oq=o%) z&|!B7Ym^>#_+5+OJ*#;f5H5PNs_#cH)$nwlG{n#ACP zx&f_#^fIVA*;{T>x-(Fw!(2;Bb(lA>NW;i~0I%Rh!Ji<<5Z1g93GiCgPY=lSXw$!v|7y7PSz17q2(5p(yYzKGKII5K9m zM$+4>X$b72pG-+Y>Dj$h?94tY7HCed?PuoAbst7@J_0tHus7>IJY0RG`e^l?*}c_w z=JZzMMqaP`SWdLoeQdP1?&L=&k5U;@Uq?+#btT_LHe~1-6Ud2r>rjRhgYV6BMHzvd zj@nHnbtjKh-#NOs)_3~Oyxu_Gwm{y)zLGCaQ#G~)M(5O04c*q>bPU$r$Bgb{CY1L* zpEpaA0@?i?{!MswiwC75Y{3P{c&`x!83-`pnRNHDtm32$=~{-YULUGa*Sf0z#F1C} zH%QUR$f@w4pJb_BaX8>xjqnD_*(tEn$hEUQ)9s0)=_DCPNH~}I7L(Ub_`&EkblFYn zBF~|ps7U!P$*0E`D5SLeNpKwqt&|Yv1UAxB=qW041zmop3u)4?ke20gBA{U{vU|K) zl-7#0bTJBdgzn)tEVxr#LgL~U7l*i9D=rps$rG1saWPPV??JgF*`N@7Tqs&vkt^hM zQwM-Vc>&&-S?UO3a38dDLi-d6wDIOIOxGLTo!by zw*iUU0L1OgmDIq(QpXZp(;R_-*A=D|Z=oZAtI+|+Xc4!(%+8n4Y;nntTE{Uo=i=x! zW&s(a*MLsDqt}2&(m|W;qgYBYr5s9; z>#+Bjbi@}Kh0G@+Ilrkp`OBmF=e+csYPgDzNw7F1R{-*Q?}Aakb4+hw%$?)#Q+wRd z8yKg@O-VS6$GAIlC`S&ufWYYYj>{VOKC_up^WHn2rl#h-e;fuWr}h_Sr?_kump5^# z`$blcxXh#q)N7fxF`1!+66eqoNsPigH{`P(mc6hzjB!80`z<;B{V+)RnlHAMeKA{}WY04=(BqRgLft+34QYT0Ip9G$ zxm)6X+?;sGEZ|PonVvidV}bjbxSxqD8UD=3D76^X&>)@M9C~xSWHwZ|GrG6>Q1xNx z)x;ydqrTeXrd~e*bx=tLgc&-7XQ7n-Wkt(Y+zcYJ% zct;)^Gb#z5m;|TINHDx6x-f{;lXUB3s#|>HBYyPcnKFD-cT$uc&wvh^oyB7&7!33V z`R0V)KrZiWA5~W3DMeI;rw(W)s6C5Q!W0HeBUxx?*}4s&^g{+~E5$|lFq#^Uq70w# zodpD*jDs&TSVyTG;gTZ+KEbK02z;Eudf_59EE6|`O4d6Wi`YcsjUuN|iH1a#$UsqY z6&kQ+^=eGSMXFXdQ%VK=k4VG4NNKFOyPA{Gdyf>EVo5eUCvs`eO&yRjY2ag{2Ns^4 zTm$KyL{;J@H1TgU>5MEhY!{x!BUI=6#c)R23(uJCKU^zFom1^ZfH`a7f!DRv{vwOL z?vCy}B*I~HL=+OIYAgB<+X4GQ2jq6NT7;pa`-;2BZKM7JT2i9rg{uUgow^LTQ61F} z!Q&&j>6wk!o#cv#E@Od_m4sm&um}eD|3oqqxzIsYDBYldL1X_UY6{QQCqA&{M)W zWj@`?uMk}gCoD)#xLlX8s{(ADZm(6{*Zpq!0305xTPAQhsoO=ra z1Czrn8QVzyXlx=MsFxl-Tx=-Mn~*D~Q7VskYv9)S6?kWX(HNJuc3&pb5H=e=vH0EE zMq}bOzu{>2M}eF}km%8y%sF!P0e0qq_H~pz7RY&1k~*p%4&)TG5529rdrbKldIvJl zg?y-*72}{1HJF4?LyIrXhm01Y1BX-N#>~6d6~x#9DgH%e`357}lba6_cDfM<4uyk$ zYpFAz+#yrhQcU&vFp)nXM<^hio9C4*Cc|?I$CTweluTsK%(wfOibz@+g`3*PVb-1k zJ!+pHpP9{q#EAKEat)-1NJnVW#~x}#IeGDV^Z1qBJAU8uH%9a4p=s=Xg^UkGXWorR z(>TK&V3^5Ig?Iy;c`ui}DL!?5KgFpq6K=V3qy0+D$_lKr;CXLea6xGsCynjgo{RCU zG0mKwF)Al_qUDNfrc9MPpCmV9Tl?k0rKBkZm9AVrFUF5SOjV023Xdf1mT&+;J5q`s zmXtcZlvI(FWXGh$zqRE%ewhStrR9^ zua&XA#@qP1Ps9~o1zoe`7+D2DIm1u1NWp$l3LLfhutrmCJ>w&WI<$RN|Ee!5dm~1I zL80uNc=C-#_zv?SKe};&8FTeC11^t&m}D-)1SSwzp5RjDatMeaP;yapp&-LMtisYL z6pVjFOY}5k*)Df_7lIyPzeSt;U${`WEC3nxi#u}34i*NSVKQ(WA=DvRIaoys#g38|r}mZs{4HIYh7 zV^#B-#(K-bKnV-k?Rp_Aj|mx?2h-U1mlvySO{_$lbdq!nv%5?9P2Cfs^V5o>3ug-% z5MigiVnnfbEGNFBi1E+9B1T_5n+TC%zC%xmC3;HKK#INwQjAU{1<9z69Kto|5+lg& zOF)j2==F01Ii~StuSHxma`+kDw}>xiCCBb4#j6TzJ(on%BF2aU1*+_=0c22Bs<%CM zqvi%Nt}wO-!Ln`sFZsW#Xp%Ts2z9<*1GH zrYV))s3jyRj=o%-<|HH!P#szj6{$g|FlDY~j-}Z$%Th3vb?FQeL~;dX`q#g_GL6zC zNNvzr#K&eVi8@k>k1T4j!MM>mH z(kRgzciqfQ>b^8;GkT*=;a2vjebg0vZ?93f3;TrgPF>aDB-tHxL#M8`^^8?Dsuq0| z_gA8i5^7fax&dnBK7$&Gc>3FNZnXGJ+H+Y7?TIe|JDcvfNq3eFU3cQ8>NH1}I6!Y^ zv63v)i^bxYSVR=4NdI46MMh{c!8O+@i16CGZV=KiKI%4lqQ$cq>k%&PUNIuttB9e% zKHB3 zLLWzbfj2dn!91S## zOru-UQ}UF~_G^UPX)6s8?5VWWH#BSB{ECLg#;O&~k+m2Mg*ta-&~saD6y@0O?r=Y3 ztL2DC&pqVI*>V-d2JT0)A|oT2wp^pR##3D4^`Tw(XRqzsVa}4eZ?e}BAa~ETV_tuU zd8E{RtsQgvfaLBg>=7fN5mNV9dnB!IyLp8CU3sf^UzE>52PMCVVhfbw$~VxO3MIcVpNXmDJM)>8O1>jsL}w_ND?&b? zTnK%JfuaKRkLjqRseuJWex{WN_3hCx5v2vij}o-xRhTrJN%$}l!Em~Emt;3n~JQmi&%ls|ZFWF;Cx#@*4ya0e7jDo0VW z7#=Dusw_~#?r6D)7Rknyxw2H}e)kWX`4Hca{i(ZX5`d}fwI(QV!l`8oB*RF|ElxE3>0jytzpUK{<2VYhR2y}pd_-@L#(1Bmg4h%xe#fThV(-?+k`qe|hq{j@TOnq8frvO5 zW~tPftx{)>N}ajUN|+fA`NeEH_sLOyd_FbwVFHB-XcLmuC{h{(#(`7ALYqkBsFz`Z z7>yS3L=ex_7}zjukFMb0so{EFwAFHULx7<6#X?k*OhMh*%m7p^^;1|-#6ja!NT{N13sxrl5P=w^c_?T?@GK-D9I=#-ixmV(CcFHJrGYJzaUP;$d{3gD-;) zGat}5znPk!L$e39M{6*brNc){-;2;N}p_+P@;J! zWa9~?>^H@PQnqeJVKlu48R#M=l=23dQ4li;yBcc}A1m{Fh|n>_a;h-96W4wqTX z`6x}?=q^?YxqC{qA}tcF4sl|Sm|NJZy8oi98L6-u$@{7Yr`GQ1D!5|f(1@geav^{tvBUB9I@Te>l{G<_HjA0)D#Cfx|HG|x0dqQX=V|n?2gt$no03rtAbO9 z_gya2GzHAi4_}dgNVtK6tRmqtN>Cz7EXR6EFh-2Agc?dno60WO;^zW3QtA_L`CFrUly+;YUYDm45psR-TA|>dmAw?-c zR}JYQO3t)HXsUQFG7^HmrTA$ z|0OQ}A}%MzXdk@@cp01WFUi!7Il%f;d{Qe4u+g$zjp zMu(+k`|To3(b0V=DS-!LrM|5#4|(c7G@In_VAO}$#3$8&DRN=MAdP2$?PRTO^ixbf zBg~TI5Th&#VVLaxvT|2Y#4tR(I6{HM^Y~l#b2n_lR?M(BqzET*eY8Q5#Y%QsB|&u* z>lY21xxRutEQA=2tKrgT1q~LACKI^~>Lh1#=JiHrXL}m&JiiHRYp}~4+sm;C5Z?O& ztVdEK9+-xogRR!;KG*5rxDG!y^P<-9EIs}z^!RJex5wWdT?YqxX>N|RGPl53TjzQA zXL29!jp(_Y2miOe`;L5D9n#;CSAF?uB?NC;LAN(e7V=mm;2bt z8`jE4v@+KiT;(_nH zK?rTW!&UkzAvdbX>x3*&kzPXPs>o47uy2x|IYNk4MGg}(RYeXFGD$@a5^{x#93TW+ zUb%q%gp5~_pAd4fio8Zhu8O=$$OskLM@WW>>?I^kMS2LKT?x2Kui(emKfK30+E3Hhyx{5L{Qs>pMMe4rvfCgfce zp$MhnxQhIUkYg(H3?Xl+$PWqmsfzr7kRvMceL@bX$kT+psv_SblpNg~*;!%;!gt$~>6CrjLX(i-F6=@-40gwj>mN}0&WN3CSWOmMFfNa z6cKO>02cv10EGm205}P70dNpt2Vf`QMgTSf767=JfVlu}BA@`kjRaT$+(5uo0M`>R z3BW=Et^lxrfXe{PCty5)c?4Vx;5q_w0n8*IZvdtfa2kM>fX@I-Bj8T}t|j180Qm%b3}7k&zXdRbfRg~OA>ac5lL>eiz$5~W z1Gt)iV*suq;4J`G67W+1R}gRnfQ5hq045UfDuBxgcm=>^1iS>`QUaa_a0vm=0+>L+ z4*-lO;3)v(2#5k0OTbP5V+iN~a4`Xo0>~ra5daqv@F0NE1hfLk-GHB*wfGse20z)~ z!q13R_{prn&&VqLWL4lN<97U{FU5~Jj33i2_(}8O$LPTi_s48U~>kxdbc3&mauEHO_BJHNMh(RPG_9If;I8_m; z2mv9rXBDRzMH=Ejlvd7ZX(A25AWE}ynn|P~B1CD|avG*P=+y`dQQF0vmM+o|970-B zTu4$w`|G3Y&lvQ6Geq(T(4VZm1K; z%IL=1qZ@d&f>IrfZuCSqIK`ctq8sN%H}D8ish$$uI5E0`!zN1g=;+3*=mri7DAjnw z?&taDcoLmR}a8RRs%zkWvJ6L_dkt>@6+0=Ln{{^y9 z!~rzjgQk1X^h1GcY#z<-?fz|v`65}H+_oL4%e^AYj;*mCoQ=>?yy+F`37NKG5%lnoG{CVIh!WK!1Ha&i4z8>PKE=qEw9VX*%B=|;gE9(ix|+c zV&MdsU`Q9N6dPv@Exg7;4#qglTr_M#Z$zBl%;6l&b@N$WVsD0FeRSi;C+zJ&yCmD=bM#q4yU0oHTY3}v>Form|ZCIZ{g%)(S zUlpucX<1Q^&7vzU+TmgroPQXx;5=#Yn9*Yk_?+wDX6hM8cdJ ztz7&j&8WpDi?kM>CBk+;B5Xv>_VbUjQ867@1T-nOOswVrg;w34Z{1Q1W!}1}`oM$5 zbtevXpCYp=lx>`9R@rJx9hlWhHGj!>p-(c0e5GwN+hFM_GNbg`ZFntRpB=ES0A1&I zb8}?aIsE%+)-mZWHZWv4kbqi=JNSj=SsFuNnf|rM4K)5p?B2kPW6(t|#oxcGF=Prg zvw=$lwB-$IL=bYvDkqx0&2aXnXH)xrz^&a*;1dK2?eB<#-xeUNwDjbC5Z3sicyo9X zUBaX>x+OYO6sv!h0=}5{+^dKD6k63IJ9tJ_di(||P}xeWy^PrYQ#h3XoGVz!p?IZZ zbORD(XM}zoHS}v=&X4Ti`AB8wGRAf-ri=76$M~gAmN{jI=)`y0M3x2Ox$F3{bGAt2 zz`wNXD#E0vFXhVHs^Ygj#nKac;dcBD6zABoMlpdSZ9}fz+^`*;yNoxBMIKnn_AaI`Y&{dPW&SSe zJF9c-@$QehO%gKC&m?ng-{XWrmN^0_1Imz8V4KBoZQ)dZEQIb=Zig66+b+Y&eG-VI9_(LvjRoq`KGn2 zmN($AgBo-g+JTFeRV!=iYnp2s>akX0d_s*@>T0CYdZ)I;kQ%WQe~E!VN)Sxh1?xVh z8r1Er!O6_z4C81TCyW4W7}45P820&=&Jru?7%q_b^efEU%;6a#BcR#L1cGKU0|+W$ z0`4-<4r*GZsUGVk+(@O1iT^VHzQn&T(k~dHj3z*OoIM0-CmT{}N36m)nZY=c>WCGl zSYrwfil@P1Jf^%P+#BU(VSdDWq{s32@M?hvR0?&1LSt)c$fl+s5x;bgkVWN%AyuYx z_#|P!T8i>qptO@)tRqR3NaA$Z=}?;?lO%c`BzXcePGf4SlSo2CCkRavMb5^SCqM~4 z1`EQWn>-vS9C5LD@(eV162qSiyMsvpp*Y)HpG3=t`c@JHI6%@BcL{%LXJi%~=&fRG znPLuB?krkts5_y&iJm6ems=zgujP@RX5m&gjUp;ZPm9Jp#cfwM376|B8HaYKI%oBp z>xrr6w(KmP7&W&;^~Qd5VZ5>D(Jx&Kzom}k5Z8!70~7*E>t+8(k;=$B93<$=krZAP zj8ke{>S4goW4&*pT{LpPFYTc{85!8Ci?hhEhKHx8m46VU?SByVN%=VqyE2f$>ssvc z&LUeG!wNLpu?Mze9;Rj;`>79O8{!t0ge>kwxfVkt>tH1BfTQ;FPS~`%lcYltif)h# zi6XhHD_~2^APh0<*Ly<34ddDHrqPV7u)GWk)4NAWE$1I_3A}JQ)>)^qLn6H(9Fje> zA=(5w;pC!R%5BJCNkxE0#`$3x_K=0QHds^>`9kNe%$sv(8nD}7m+A)A?hhZTqbNiP zHd2g|x+l69pD52hQJ!<6eDsO(yc6YPPN1_nv7ZO@|L8_@)j$L{JA)3p$I(A7(exN9 z`k}N?AY}In18*2FA{NTe6%)7X1F>;kIUzQ#EANTrX3G0wjHCQg40V-XP;TjkG;<0c z1_5olOJ2b&&i0~E)EDrC=r&)3>?x%rQ~c6jid+Na3HiTqT02%-Y?pLc@*v9lysEq} zpRe+gIn5w-Aj3JxxKtep?UiLdh?!_96WbnKOa;&%6oz*u@X9z!fFYm@o#e7#pXjC( z4vy6x_C}0!>RI;`xA(Op#XCxTlMl7|swdob(36C-biPl!eLDG#0CHl0BqUD0qqBWh zeDgo3>%qq-5)O;joeiL#5bX(>RNEuBn5adqEO1@-iAw_xkjSDHkyh6&VH`LzZ!V|T z@<2hZW!FgVGS1}G$W*@6UxG6Wa?)s`q>+-cYO1fYwPDah#IGMJW;>fOwX_m8bk+zc$;G!-uk&9^; zmW#88%SD_Yc6K%rW0X@vVjgGxbBtY#_BHe6bet#Y;7OWvB~6-0{bS>dNe5#foL62s zU))mf4~<3hrwVuJ|NQ@kGjv4cUzjsFf-_8b{PgR&lcRA*yDRl`7BwHZG%1xLtxnRU z>k|01B20=xe=!@VQ?K@zcf&w)szEe32y z%sS6Wxv+iiuW*9LJBJ?AN&_K|B7nPg_CUitHMI7~)-GNSZawjS}4 zr*Ikd8ZQYmUa4}>OonF@B`JMt`Eq(LqFY-mTlyzU_?rNp5>~NgIW)xth+w+6obG~e zm#5-eb0ausT~S@psAC&P{aaJ(2r;Kt@M!`w_Jlz2JAvas6W9e#)SZbi|M-XT<%EH~ zz&{Sw3kZK#+S}QF-7r;2{RBmtLF)-jdN#>jbxg=pWqgUKOjEsF^9(q{GQMdrjjs5R z3Z1SeJEQX^($x{2cPU-%(RpIdQR_HNf;oMw1&^+7vn`E2LADD=^<&VC^ZIu%rH#`m zgV9QOo2~ul$7469>2qDnxo87>dtM6uH79dzb84;$9(`?mn>S3pX(`JVxu~e3`DP7~&1-+RHRk$(t&azD9n< z>B)mJkhsMRB!Ej##XuUhq*B0|$in+pHz0anrB^^6Y`$5ZJ;2kVeOTfjk1++P`CRd_ zCn;%y71fVO^*68xqWW+xP8Jsf)A?@SYe!3Vc>R+PxB06lEIZ^$!i$q|U)_l#-EWq_ zdy9(Nk{=g`B=s~uIC8^vG3cv7=9mYU4(3U{L|wUyz*pno3(Tie6`WGbdpzV?wzP6B zi-24^QsmBD%31#$hW#DM-xUh@y-Tg7e!g8VCd~dUgsFMHNaVnr@@MuHjaOPkBD;!m zgcaX-<;5bArud~p1S@?6zQW*Xd@7AUKY)czEFE%Vx|5RVu4V%?!BI`ZRNN;!zGcOh zN_;&rb4vx5@+=n*$Xix0U^Q&1WS~UBAxh&CO#>YGW9j5e zOJpM7f4f&R*+LXxvLgnPtZM5ynC#B>;i!D1~R93hsQhl0FA1a9^_HgKXTlN-$L3L19YRR`NOcsapoZGpySRO zqK(|e8~NlemP+N+7)msjY0NNvOE9CFFQ+dh!RPga{YGMp2A>Oa;=u#KoaG)cC*2lN zRPN|M@T{;RhXuw4k0~)Jo>T01gR< zwXbdfhrr1GejS$>2d8EaTaDr)TfwS&uV9ri1*@nDLuJ*5RIH-&x%HYvr+X8t=xk_> zSAV*&yt?^Zv?+C+aMnW6e|gSo0L2R1|Ue6F7tb4}~U}ZAochUBTe2 zJ3~l9Fm9bsFfLDJ+!*nVIPOYy?HMZnHm2g=m;wB|*zKwNW3f!pCXIprd|?@QPUbK% z24Y$#w2Td&+$9X&sp;sfGM8at4}G+m9!R#2?9M8E!ktZEC0w6PEuf^Hm0H^HS*eSE z2v$Dq7pxqULI#BFP zz4-ly-Xvb8N(Vo!gQ{k#5R2gD4waYJsk|KcDa-TXrZW{ci)Cz>eLwD?Twsm7@mx%5 z>?@VJJ}{+PCTgL~-+rafciNqpdo~T!N!1y*6aO?AJexK+&jyB91j~M)vdpQnEahiL zhsrgw`z@(#Y2g6Qjpe?OSf}d_|LMY7(;Lo(ciIjl_EM=Zn}sUh^xt&VnlMzhrR@GD4`3O0 ze{f*(zOwG``g38J7Fvr9(bI;YYEla2GHhAVX1i$i?4&_3@lCtMOnwa-cjchmiv`34 zzYeN;Hd*CYif{9t7rPdpkzN1rm9gub^h*nJ>GbO>=GU7;vXCj_UxIUQtDIY$LesRy z43%|cAjLuo8eqq!Ee8fa==Na@vavJfYOjn4i26aGBbd7MVd@f#HL!=taG1y0C*8Gg z9QLmIk3ZIZ>Rt7p{QF=0`+xDvq40#j2}ikOi#TF{ZZ*en-B9(D(E2qUY1Gsm!eSEm z-8i_3ZR079R_R9Qlxr*B;;7Zb44$3@?W3>>v=9=5<0)fNl!W0Q*Fc0(=2+$pF^qCz z9@|iS%jdsvdMnOT)PHFj5g=5E!&dPx^YO;-w<8B0^ik<8Jlg z>O=9!=s36UjicTjC4MZ~L1gr{!yNhigZB_5BeuJZSUgx9bipu`fs6cw{1+s-T& zKa7h-Cxb#Pl43?I8cAs+9!W_Mk%Zv-8AK#0wv=cizSIOHPZf}{`ffqj@^kGTo=zzz z9Bw*)Il0vBtNSCY|3KmR-SCCu+`0&g+Qg-TE&h{nspyD{HwvF{AgX9%x{GK70dn(>e7% zvG7`4hS(8(Ic{2h6bGLmP)X^M?BQGNl6;>*?t8R=4GD<`LohUOXvTv!L+Yb9i2{+Y z34~J>h>P`oOssw9Diixs$^-}D&R-@9R8M4xQt`9lOT}BYcw~3Pr-4R%*v1DWaDs6Z18hC{$%a4aFw5?p#IUP)d>DAfFHkvBn~{ zsz)rL8+r&LagYjcweF9<#HYH&g_he5v=`^#tqwQhBxt8b2;+jmKFLqwg7H!ue1`47 zDPEnYL=t-$MFe@RyhGYJ{Tj+@oX&;q<;U2PJkQ|itG28l1A@q*$d(jUgh4?H_Ob0C%z~L~2|(fe;r~hB)&0S0qE{W?i&M z-(Qsw;SWU?e@usIM!Bu#M|L*?Oq@sDe--H)V;&w$3i7U z&z9~l@%?iWej))!jJ5kM%=UM`;vPaw%{pX%2ImA{8}&ILZ(|7cYU(|7?35B{HOz@oRm7 zzoue>DDX#IV30Dt-S$SMc;s#EwfaYXld_!6rrba5socA-E&LeORv;p0*9_g`T{G0j zf22!X`lIA_CDtlsIe28xp0-8#d#L7n_D~5E(U65-G)DQi`+ho0>6XmEdvVwefi&Bg?tmwMys(uQF9mWeH5m z5X++bYFH;um$cbzk~E)xC-LtXr~q%8ZF?Pe+WH^p?+35;V5bR|Kw>&!l(Eg$f*bTB ziBTT_X>)Erw2&a}KSexC1rW!Vpp1|AQ28t4md~@q zRd_+UWfBJKAz4xNRcFt@uhFUbh0iF3!(skWANwtX#9<;d+Q;Fi_@K56lW{<#f8_^xMgGSOcJt;5b^V*%J(4p0 zUp$dk8VoF=gJW?XDz;pNtYt3j6fdNNU-5%I1RiH_FM&tnAUpZ;-ex>#4q1yl!Lks4 zCq(WEiA*kWStu@a`lHmx@IC_n#New0zJ$YC#@Y_Jk4c6y2#cZG{Y9REj_?>w$6j#0 z=P)+d)_zgG(;jlVt@t8eIOw<1SNX*GOwWrCP{_}9wqLrUqIpF%oui~4Y@jC^zD~hY zU+NqtzSU-&6tXXp zxq>dg(>1L~2ea>@#|L;YIzu}Q4!AS!da^XD~JxeZ>2V=9r#du(V2O~Je zuKbWam>B1neS&k$K5)-=9^5+*f94y(JN9QTDDOB0?621!Cmwz6%&$=mZ`|p0w%S^&y8Vpbu_i&rj zEc(NTH{E#X>F>As?>V)RA=MVT+8p1JBp32xEV1Z;e(F2>`=L1M$`rVfA&<|6ahkZW zu~WedWaknI&qghg^qe%1_!r*J>B)cIcFx%5n4^utHtxY7`|mMQ179-Zd|~D!m^siM zV>R7>!bFmtgtAC-+uL9f|A0kmcz$RsIuB#^jbIQPvkS@~lNGisNon|ueW5feb8c<{ z6X_?eKdeMLwh0|#MT+YYD-)QcE@VF&lTzEQdk6K|Zk7+#hr=bmNia*4@;?Wp{5m0p zOjqv(cH3s?OqYIHx!hGjZmG^~6AQ`v#GW~F+bC2R4$I66NO}MJq$T2XFp7#|C`>^P zhNQOnZ9Tsw7wyYS+TQ$M`~L?+AoC5e-r|;UAmqU@S<{MQ5F4#Hc7g0xBHh_YB@&*K z22%dQ+buoqhiA8lu=AO`llYe-OdL{Txj+7+@AV5aMiz)V6~Pvv5HZ&9qf*;`u!euY zD*4kkC)mS3Qk!Yd9+`i@sfFjnsq-*j-v~aj`MR)t5?b?+QQ6e>-`9<^o}D|Y9#QX6 zgdeHxC*Pj_IR7Lu3mlp|3=VOimJOJ0kn^`_(vYG_Jmz0Fc;qN=U=UY*h4Gh4 zh88&D{QQ9viW-d!S^Z(3D`>}te+a~|0!JAkYoTYcrz{ZsN<&9nVO@CTva`g9W`vT1 zMEtZqzCx`$Q;di+Km3=75uIlv&L>F3jeG*pA)f7jP{e+z%fhK8B^3BwccesoX52)n zgT-GDQ>bqfKH{SP%((ZlKz0msZAo2f$5@5Dj9sTigiGmAf9Wu94Q&X{R7YH@HyFsAE9 zZdmsv6t0~#!&uD4{_okMx!3Y#??iD?e0<$k#Ftm)Gn0wW!W^<+eLBHsCcpZB4M_Ps zA?2&^t8Y4AznVR2;akID>m%Q~rKP2{wH3ekFTr3iP3vynaFwl`?t?<3#2=!M_&m>-1x8^sqcWH0!FQk>?^!eJW7 z)4*|an!M=HKU_y?BkeSsu`qzd zd*xf*m9QOS#aO|DN?4|Z9lYS7z%n!8M9^~HkVzV?Z4XUev@sE+`b<9Teb4*;gd<3-CpDgO{m{_q*oiRYSyL0-Gi52#vrtwoIjb+?vbaDS8ciEH36=1xNdlsHy zN=XJH&rrw+a*bEX#nsRe3@2*ytJKrP77r?1mxE$F`HmyR^b1{xV80(+x`sh8huu-8 zldqs4m`7Y}T&?uhkJKe#R`%{hFp< z!>d9+lRq0nACN z)xKtyuCEc&8<++XXM)7`&*cAC5(2EC)+m&1th#IjX9&tm@VAuS#z#1Q^C+#KyFDjL zn?$c|vw@&Ihom}7+JZq7PqYi`-2VV(0BQY$n6ahh4+&H+3p;dFk9Syt>bL2sF2|^D z{VSxpev;{&sD7rIKO;{m32GBJw0XPFc{mY9fXpXIE?%yqand26rtj({*CZqtt_B|ZYoxQsuk+--3Oe(6mWfSL zeHJ>;OOoZs^>jAJ>Fn_jO6SG_W8xHtj$=JCfBc<>&J>mJC~57!3d3aC?KPx4KB>fT zsQWjAABHsa^_Zmr@6z~a*(3tvT_U93wM-2DCei%SB(d906>W>YXN?V*qU&Y_r{k6nuU`9eCS73Em39o+1p8(q^}4Nseb; zCoR!jajJVvNoEi56aSkNhG--iBF8M%O*GOYcmwY^i64v70 zU30`WIFR`(aB{#fUBorG3`FEpo+Ul>0VTdmVx@)YaaBo68QP%FVkpS0?Kv?ghB)A( zdq(|+)?~1og1A~+Z#4Quo87}7T2PM?xcTbIH#glE0m(Cq*3_?{@7P*U zbS#pAg~#6{5;+59Lnje3pDT%Y<;2YxDYx|oE;-nC^n3F*CXfh4>q!(GREj1b){{zr z{>R|sx}gh@Ye{J`b@Zb;xr@*4S58eP0YYYtIwmo?>$3|@X3=2^*ncERBtNhJc;!kC z_}Hxf9%}R7^jdz~%{|XFv|YdN?}7<*L80G3x_ASNhE5k`J~Lgg6qYFPI;=;V^OHaP znynX+>fyGV3mV6<=C#@0eDnSUs-Q?6Rm4{oAq?a=ykj! z+NM<&F<;fzR;x8w6N6UvSgp16weLMETCMHBtFLyUq_6Mwz1GtFf9Kq9X1+;=Rc!13 zUnO(*``vrax#ymH?z#7FlhRj~x-6y9^&1+(!DdUet#w0Nt7UDp+0qhiYpx4g)*{~W z3A@+nyZvgv-RHly%I2)}Tx$#XJ=c1wOFd(}5z#Y+}1M$F=+^NN=)m_KJ!xy|Pi-#X)hi6n7W(`)cbUywR^)V7 z2mFQIUAe`U*64z(ze{*-IeKd`|Vzr(^pLy z(Y!Lht;B@{6*xhZsl?{9XUpAPX`gVng~PW?=&CeTbdx%Wt`3kpG2!M)-CcPLhIOL_ zc_dAx*2|;O`gF9d+Uuz{T|iwaB3YPN?j5<^J5*$m3-O~|byas)nLpIfqGL9CQEP2Oq{Y%2Y-vRth^#dfv}~+x zZiu$ESfU&1qV>TROIr)brXj*aModS|4iwKf9Q z&>FS0);0w#b+yew$`TFNTfA*x7rr3SyD8LA7qU=NB-&~LHwcF}Th?^>LA1!&ZWPMqZ_BppXx02^U#}UbT zL>g=l?Qk4X?xDgCjIjLu)~1RaFcOIYwOW!jH%1dd>2Z#EM3p3kMi>3#7^j}<=1^rv zS`B;FT+UAOrD%Nm4enBpyLA4=#5dscUC3$G*}_TlX>+aYty{!S{RFKgUu#jd7Sr5^ zIA+~t!reGoxV|*ql^)q8O%zN*2MK{?l$p3;3Lb~F7;hNM6~{>85tCL0l2CHGy9)em z%^-pZAt^pnY#_>*lMSu{fDl4P#}HCo?cJrMTWtV%E@(@ek_4|O@WIsZn!?|&?2w6r zj4{*(L=z7?PaS*0q%GGwmJYsAWq13z7gMB%xdBh@GBpv%&YVC1=de?xq`)Bsa%;)bu8C7kq+ zX%{%yTepmz`nlvt-=EH*V7^GpgcI=E%iYB*Y_5QvhE%D`jTmLVq|wUB21 zq)ZD%CNT!2cEKp~^a8{b=akv2{f_w}VWKg??q1>adfbGG?yj+=;b==6*oHl_v7tE{ zSs#qF>LW|Km;3Pu|9*jHg1KlyhF%qTvq`&{vQE~fb$5*`Zw>~FXmTMoVhKm1O>G;x zcbK)=D3e)^xr7=u&lo5+1_%W4Yztx^8&mGJ+lx@R$mQ`=1~6l!8@`!m13dMKOw4jr z?n2S!359NtyNCum1P{!(E|1M$R9x7(tQ}Iuj?vxQyK+`Q&MJ3e;^9d|TZFhwsId2)HXNQZY~1vuea1j@W;VT%?+(V3wq3G z{2KM!=JncE6_ErK@8}p~T&%ao$avo-7;+Bpx3NIH^XO{)a|Q^EGer9xnAPJz7;8u= z2h!pR`Gy1|IE)1ha58jRZ&;1j2}vY|++0ze9vSO&Qf$1}6ODO?cRQ&_yx)3jMfHY` zk2hA8+;bf!dJ$vS^)8AOW8agC7(1UG8z`WRQ6HaF`N_!dkbxx6H_j*0v%ZHaNGL+Q)T$235K2m7Ns{1)B z`G;klYsjkmIV<^*l{i;Aw`Z2m+u5G?CJ~}f3Yu1LNwXMaFq2rKLOFS$26Xt+B;VrS1_&7ErP~x^PhxDxH zDFJcOmx<>Bt+6V>MB7%$O!L z;vJ@Hk8734r1O5XW2(QoHqufTjMQWDs13JRii(OXEv?PL7P0uCX&_cXh7UuX_$_xS zqtxRwgzPJ;4I!6jc`O8wT@PH1D)V3shndd`ZeE6noH7pwAy{C2Vb^XTgz5pWSijJM zDjh2a5uyc^+3m7b*&s>9{4PKgeiKD&w`q}dO53S)cjXsfS%fuo(c;CtcAk$V@B>{l z&TM%O@n*(@SV5xW@=qg@Gwsouqv!@D5oQw-Z!NxtPVbijF}zbjII!g zT~+i0(H^zu3{bW62B}&Ea|f*7PT$(}Ryg+u2<21g<)*g|h7N@ehi=Ll2;G!B5JJMZ z0mqSCtmH(PwuwHEtO4g z9}3-+KhRk9`5-BBn02qy)m%D3_;(rGg?_x^{PEIh=`L22sW#qRtztRzNM`r|^F5GIE4yypX(_ zi1{=TsI$sbMsc4Y$}NFzrIJFW2#t1@Im^rKUc0;0jyUN}#AVw{q0uNRw>e$e6xV^c z46zI^@o%INDK8PC>=M5S2{Cp_i3o`W)DnvbjT26ea1^TWdtjH6tX%Tzo}Qkcz54!5 zCte>~v8+{n@5G5u?7s6iJw4w)^v&0Y4mTcGvHYIfrXKq3@e{A#+4J)|@%zkgj;n73 z;Q5NXsx*4Y+WXbdyw7E7jvw#osd@SKcXm4uop|R)`TM;m2A;g;3(uSw`1%v}_r6^9 z=Q|Fa=zZqIQ$vSN+;r%~b%#!TV(5D(;JN0R6Yn4D>3OQB=b00)UDNoNi9a?40)a!% zjr|L%`Oz2Oc;V9QW%jRp`S!2>d9~xWH;%tCaN^FVcb_Od{&V%YA$8$TYLNNF`**(i z-eXVCw9aik@qSHU_ZIF$`}^Pg(;d%j>J0?~Z`@9ux~&b3d*QuB3%}aaGtkpB^!f6|D^$Sq(ucvBe`6c8WGnE9M32L_Jm%n`5tUXyu0N z8VlM{T@8618Da&ON&0};AZF!2wt?|-a>0j?c~EQE>jDos_^h%~MD))RF#}=lA90+c`%t^f2_OC))Uz)a+2i$! z;Fq42{>6cxr$T6xUf~UTL-XWODY{ya=xRZ%s|B&Hq9lV#uL03FV%2(bTwxVZ8~`xx|8&CvYn2N=()H9_`asR4fXBeI@>;$571R~+ zp)n~wbW!3%7sWnwQS3t@{X3z(&&rq#(C)!U8V(pfB8x~3EkK!pXQe^?t5XG@`p2OR zygH(JJ^+aIOg7Q1+$tjlQlQ&oIU-fDB4H=I$|s3fJQlrKRYXDfR;OOg#|)%|zVEN- zUnVNfBb`K?v?xbn1F?)YR-tUrE$tN!fCMKwe0u`0uf|9$A!s)7F#oE#yq2 zoHafQK8s*Fbm27fP*_MvT=u?1SrTz_^jr+7AZK3BIsOloYlI3|v6B>~tVzVuxdR$wgAMzcX?^jeLsTOt`%xmhIf)LsMapNnT7t3EsV$9a zmx!j;Rf)D;t=Z>`z}6KZoVO})3QZHqu)A(i@Ch&E!|L}bEv;7X{!%*d#G5P`&} z#aD~~8JP#o3q?1fGD~eZY^ldst8M1ZoEA~q2O8p1XtiZi12%WC?;CG{g*Jd|H=?-6 z&BKMVV+q|Fg>sgJtY~w?x`s$?I4*5*yUWUx8l(5T-a_IVK2VP>WqspM9}nUSr7;L4 z1B*c&Zy$j;-lpVHMIUVtqmdh@S8j=}X~X~(-yjY^`PM<)Y^7~Uw5fFt;rqhwu8WxU za^q^E%}p&EYO%#dTUTqNZIOD)rTjz}kIDZ%U34b@J%)IwnBzNy_d}Ttjk>*v^}bcr zE<5caql7$|C?Ok4%gu>e<#~xb(!0>D6zcz>yrh@$+4VeT-91~u-IL$ZccDy6*c_U? z`S<=#S`&A=mBW2M@Z=tVG?2d~Jy#CxL#&wcw^iQf$%W{!Ep(43w?dII`EL*PO{keb zq5$%fL!wth-6U+qH9#CNW0X!Q#GHWX6d)*aVC&sw_d@fD8255tA*S!`U3rC=GD;m# z1p5PCcTsg|VfQxd<@#3n{PrsB3VCmuNSyUs*XPzI%;UxCmV{S7TQ7 zo9@)+twT{WXIPCL{4_UJ;_`6jJzV#e#NPEMNKu9HWSMq{ZJK2*Hax|~H=A5g+#S;= zcJIiO71d-;&&V8;n>W>R@nth-$=weTk!=UbvP}c+Dd=$J_PL-__F}JEG?B8RP1glH z(Ap90^^+Yz8gFs!4;`qG_eG@O!3w1&ryx%@6Y37T?{EKfx~X# zcW_(fXWWecyWIx#=Z-*sehmHm;U^W=*vdV+B(_`Me11}8Wg)O8q`;@Kb1)23#{Ky8 zII>hBi}Y4<^?lQ{S*Dd*u}$=H2|Ihl^s~qGF%CZGXXkmqHCv8@RREMzUZ4ddL1{1l z_Csm57&^0=*8a(1r3rmsKeYa@^#frO`2nGv+(h&>rd&x|3;@cy+6AT?=>ZJ?K)G9< z05ZwCVL2$f+>L!M?<(~o5D4bFvD#9x2mdYXaN<*AP%-`yEFpu_p6x}YuBCuSz-@tD zND(UZE?rvcsa`e5&6YRF7~8=m>yA91-CtDZDGktenvF&q#@2laBNka(ET?yO-9(g! zeRk~LV~)e_J#lnVtFD%xV=0NYhAcA;pR%}}u30?UCB^z@(PYzx?f>RrD{U1o^;9yE z-AKKN5m`-~$k073KL`KzWR(*mE72zdC0)np?!AVcz5;Erxk6jIK+u3tJM9tj@}7wt z`7Kq55zm!#@cC1b5DmB0Mo6qQLV{LJe+N+HCxe1$)Bp}I_o`PcUivNoI4ZTPghbsx zo746PEnFNN!r0-t<);V7!~w-nFfv2+p&BD%t0`mewJU>XynAiYDUARnu# zQY%SGKBi>40be$oO&yASy76?AaXhVxk0*+y0rhtP$Jk-u7&fBBY}~tyiK=gkW;MCA z(knRBug_5zb7+rAhzrjN-8W5Drw7Tynge6%QfvQ2eMB{4j^g=B%u!;PHNL1|7&%Td zjK=ZjUzPK;ij$3=3sa1qYEShUj2#D!og2=4>?CS6j2uJch;cKY2gwaavRDx(i?E6z zGW53}BBNq7!7VookZOi?@73(|P1YPHr&ckaL;XUe-E$F#_NXp)pA)j%Y3G@f%(!8d zM#bL&0(nUg7&az`Pr43Mg;tqz(ml)B_BJCKY>bnEE>-~&!$n-mA1Wvy=kLHeCdYsj zaFedF$WvZkRI;k5xX6|u8Pf))gWen1>6;l_brfF&Us}LTR>kH9ty;|7{S|_G#00)) zBJ!mB0;Q#PpD!&e2r9_V^NV$XR~g-Db&h$bn12iS_jEisVuW%i4rPi>0ph>ID&nMY zEiu4VDBXI+Jk&RxprT}6z)m(+4cC=1ochI3-7}9vdrYg@eU7!l^79i<3$KSYU-vF` ziFKQ`Bb>drF;AAAjz8>7Pm}sCbvnc8?_vp!g&wKi2k-wRL9l`}>SLWvNB8x8pH|SM zR4}uN9hf40WKo$1+9-?g?T^2mKx!1xiq(Nf>#HtglY zC-+@!3!C5@CG}0Th0TLI(nrakwuRH+$(2X}K{mXj0F`_U)Ld)R+rqw-Hwn~2Mr zy`=$|3KNL@SO+iWyEN8Dx1)|R0+yu?dub(YaNnlYT&S&379c67+G}6o^aOmc8-$@H z+4y8o6#YqnZ2%`24Cb;#fYalx2>|G)Z;h;Keq?-DTLCdZ#RiOqn#HnEZP$r_A|BRi zuo%G?WYb#Mw>CLm`<4l`=m=-O70$Lcy?fO9v;7r~gWDSKt7sbB)^u+L(6l|Q!UW^! zPmbovsE-8{$VG@Zlxdkb5_2g zXB-8~6L@*kZ-1V}T%jIzZ*zC_eM~-N{n=qR8q)A-chlf5w(gkH9y;i#LW$Q=fByxp z{t2-!#Ed_vs=fl(w!V}p70Uj;M?qeKBvFU1my%a7q2&4;o`9>Y#7>4!0e4w7Q%(AE z4`{>V69hvZ8g^-=HW$=aI+CVqHR-9xUyN8trz}&!bf~tbl77c{`7(Kb!*#}Y zOn$7bq}Zd046LzNmQd^~BJm)KWZzKk#gPqPsg0D1!a7#w3h$<(%91;{hVnXXrIBVrPe`nWb=EfSf8TI%A(|7LK$OegDn}9pq4ez5sQ_6w(?O9wzj2`-|g<2Y&liAZ>28xjBfL$2u{W8OtD#|(B_)-8M3*B zN4b=LFX3O_LpWK94k!^Vo1)G2Et|T#OqMm9EiK($Ijq~QZMFm>(YAG=2y`{A(J0h# z&1%I;nAcp`8yl*niO8T6nq zf|t0F)3ufGref4FLV@s2JzF9vIEf+8VFeP)1anY-E$Y8$1pnOuc17$E#2^3AWUW?C z{h|1bP@t_DtJR@74{K{sZyJpyL-{o)X=tpxtZ21dxUPGbd1hGU&gQB55}rcf77d~F zOj?`*2F$c|TX*GRY{ybJrwK)%a*42gS1yfny*ksWo39G0n0cXApQ8o&RFmq*;LPi^ z-VAkqr**RSIrOX^jl+keM@BHad~h?xSuwb+Zx%JSVg!$>i1R3z-^X~=0r03wokv|G zA2RZz39c_tMa+tzw_{c`-gWw+H z<*IB-X+Je1fHHf$m;#5ff~Hfk0SvX&rOIMVAjKeG93Ree^x=%dd&7qF^u%z+-cC*+ zX*7c}f}nZTN(2wSC$H3k@TD4<^$e-UI*`l@%vFTXm`2kVmw7?tfBV&CT$?H2o{(wv z)l%;gZhYTF&1Wjt)`{KD{>wOW4@FN=+&9K%jRK79rm z$PpV!<4&`aAa)R*)OQe8>-$02NuZ;eEZhnp70u6ptSk;gsx92_HVS8*a8?S(DV(Lkxm-9?gp$oT zRtd)=999@Bx3bPhxm5t{R@N;mx6Tk*rU+-ea7GKqEF5AaQLGNDeS2*}Ke4TE3Jn4> z6CJ$2{cdN|Tj^=?r?BdSQsQSJ_(^49#UhP&e%W-C#6?;rNAICflCs|!P=|6P3I_@b{ayyk~r>FF8T{mu7l-q`&mwgfjFBn$DH z8^3pAV$HG>TOa4poquGr@ms#ZS#Eh|fZQ5i4>m)ww0?$Gw3ln?`gkA=|`P?>&E9M5gfQ5~TIir4vM;6T+A2X!-V_Q(Ko+(2o5^CRG#Y{7 zQCsj*m~2$rum!)=A~Lh33gxKNbI?K!AX4`3QZlTzx5B0$LdcXk>OFmVBOtl=EaALw zmnq+BqluR!A^~AkO|TnX+eXG>K`89%8H5>;;HDL|;kF=yF^iK|)Hb_uxSqi&3V7Hw zikr3%jY$R7_c`^?{QD>V6&8k-9kA(#0;0OD)wzPdMAAtn2dkT-8)Oq@mYyM=LeSWM zlE#ZFL2s1lPu$vc9N85Osu6&$A_~b%F6Jcp;o6is8(-txmb&!bWK8Jx-bo@G0`#RQC{bAhrcA?_j}ysZnA$>Jnm^+!}C))Gg+yX zyH&?7UIezIn^@7HYk)+k;JSi3g?o;OBO_xe5B@lpZ<}umO73;s{~4MCc(^x!UiUgE zIAv!;sG#ox2kJqNdnt;**Y`S#3?Qk|nlpfiTuIdds4`)wW&tJv2<0wW6=0I-R9u&7 z`IQUjXWz!XxmV1R2bwsP#j~XRCQpy@J~1!4F66YW1f)?nINfyKT^M+?wK+J%9NdjU z8zm%WXW=-kFBYNl&Ybcc!8*2b8`XT%I;>&IV$d?&WKh3;M2R*r#6_bnsp#&S$-INF zy1)bk#Z;4ztPSUk;`nG2@sp3Y!J5>LxhhfhQj1i&OELpkSU=E!c>n;6nf?ffJ%|Y0 zj*>~%j~4qa!8(2X9oWS-)W0E+(_fx91Jz(1R&x=o`f4nM28s_c#(=QH?*6OY6a#9< zp*BxGj@&M<1gaVaQAS=Lg5PzUC zjqaHxiC>@Ui{FG5h?XQvdUTz?F`Yz#R)}$6kMTi@Chz|3{3`Mth zjS_9ujban6d>kV=MikfFD6Zyt*PpO+u4UdK_|9y)H_76Hvcs|-wJmiWOtQLxHc27}zw6%B5LP=RZ`^wO3f$Ps6%VaGn((n`V; zY{}_^WLpi}b4+mjMPYA^*5Rrv3k>9&nKkJ}0(Q_`KX3Lv=tTM?oU7u{7evTOWr+nQrbxRJQF|TzR}dG3YTW^? z8Q(EO9=c-&w-?dXMRdoE16A@JGy5I5x@aJNc#AkAoz3F)70z0b`X~!Lhpv9BXU4y9P5|J$5%T=>ER3+4uo{Ko-$)y^1Yqyfq%~5pBMCT>-Ybi!~^=9;ERO}2D zOMELuf)@!HNZ>dd#i_-MIq5aleXGSR45`I}e2RI^s1}Rm@oUV()nbz<$F#5?J48Ii z(jHP%B)Tawhnf?!tJZvWL#!rvEc3ji$7G0fq^3y! zTgkJ-cSPFi1FChp!aDqBNkYQ@ift8i&=X$Gc|?Lw;M;jbxfcOooQ{s??-l;A;>bY_ zbj*?dkgC^bh>RtY8xvV!f-M%`LXJ9w1$Z**73RkB8ak(w1&GpF78bB4QeU3m)Qv>vWtQ-j#MU*1Dt=8SKB>s>plAaFl5j5{kC+ za0G(%;Ry8baAf2ha5Pos)MX4{h0GPuK~O81*;6G21@Q3jl=+jm4+?!zHnj*l?yEVfjS1ITyI9YiKZe2BCxCl$0S2> zU{{6}%+zW_|3S3qH!fj=B?$rWUc>>G6nv1tLO^jsCp(B++K2^`Mrp4jPOn!nlrm{T z=D{uTr)esZ2r`+qd@3ACyiU&8fTby~Eol*!9**Kh6kjVA6X=zSk8$rFr(b0N;WS;% zkj|ZB=ouHBDzhCm$ffJ~w~ljSrM8qj${0a?Z}N#lJ`|G0@i%8u+c12bD`>GSq%XOy zK(o;SSF_iLBpEwcmk^Jkv+?m`NUXsUox)~27WgrB!;8BzoF53LWezA8>|%35Kc4~M zaSf!8>f@w5K)AHRVkOZM)7)<$-4KaXn zsBt7DQNvk6^6R@y>DD@Fpc={*CKHUV+Lma9hhO??Z1%Ud;Wj$LAdbRqV6sywn6{cR zLM>6g4s#E_e1lY%6eF}$YAd(1g@47)tWlNr(k{gg`Uja~8^_Uq3H}?M{xc-ELt|m;(>`1jb91RVGKIS3Ro@`xAt&XC(+=e6ctGooJp1jq`q%CtQm_gby z6wbh%Y<#A8KDV`jNI1>suXOtzJS8iAyl_zZxOYmgi4La5ZvgbRMQD9(E<`PbwA3W-orA)(0EW~WX;~X=)>-e%yGX#0Z_BHueX6>P zc=Z{(#HA@u&hX?$)c5`nTdUsd$psicMto%Zvr>O00_5l99iIHY>nH}RM!~;Fd&a$t z;G_Z1r0t$bogC6U6OKrpar%k-37BU+#IQXRXr8^P0QasS6jnS1IaKksKGMupHUe4r zmnY{`dZtj_o+L z@API|(sS5-$nC;CFjeGf!aY0esj=W*8}{L=<0d4$mV_6}V=B|wh--N8kG@%e%XzA9 z$~o-GK_iZ2D@u6RqyhJSUd|s$+v||S55DcdeKQI~)b;<0juz~z2+`bCcPWz<>HL%$ zpCaZ;oYrT8dRRAH@Cl2lmewZXv0|0VYY#f0&C+J(dJrRya7H7{x6?OygX<7b#}M(5 z2DLdFCg!cuHt1+b5-b)VK6%-y2ts~&46HCid<`N=K zUcOZGuWg&Hy@Y+&@$ax?t09S(I?(9r^Fgs-mDE00?Ha**lz`CE%FBgrPZqm;-;k74 zd{W_^K~=2v#JZreBlBv4ms}-;5x0o;Fb-t*bWZaypk+79@v?^}2ict_(j>)#3y^4i z8auFTf%bKEY-$aC0J z&DvkJky)VXF!3mt4%1cIqutR~NNX$+@GzI25&FMpb;cq4~uNFtm*qm(y*z%o*i&a|K$Kq2KuJE1^E9UtEf~ zQDpS(^#-bO;@alrJ+e|)nbSvCkk3GRcDcvx7rO{qS1`0%>E={<^(?OAo{JGMFSntv z5D30qz?qJSHMBXOl2^B4DM*tB6rH$+AlNKe<;QtMN}uJmmU5?3E-nzH(fux6=-rjK zGT0ow1-ov|8=~UY0;Hu6(9etX^L6@pnSQ=;tAvNG~aD21MhP@DIi@JC6@RPpC z&1JTai-mUzc?CC>t8`kBPEJ!^{6iyk^H(Y$ib-EYN(cV9Yi}kJRJ}gwbI7ai8yX^j ze-!^yU(>nMWMf2fWJ)sdoN4o0_ymK_c%|LlyRw$$%~No;V3$?cv^MSy9Dsaha#iBI z#2Be>s$<2`nw+CGxkqdAkJgMkS~KA&_|DP2uBM|0`+i7ELxJLUA%M`G_P7e(UMvKV zSa7~zPS73OTsl9VtgF5LMP>3-kBZ~z>g(coy84=$NqthkCydL~e-oDtsQ)TDY)&60 zRWpomo$tL^9BHmNc7BMTA8!zGHM&`$IuZc~nzUB_C#VZjqmj_19y=rCan|1nbX}BjI|q-q zvNM>#Nd|CYmZmKxk{OzqKuiV@1LB-EZLvtw)6Wb=i)S%<)j$3}gBiMS`_u#M95I7| zbP~+u3d}Iz@iSz^PHqf4u~cb@v*`JNrRirdkgiNZQ(a&L3p9)qN@Ern0?TVWP#G3O zWs;-vYX_Y>D_k@7ce+9a*YB%rI(ne*=T2g9TpuyGxCa}~)LCM1OV4s>7_K&tZA3w+ z6(-xgE4bF)DuIJ!o+j26sy+}RcoYFGP>*}r8Dtofl`Y>7HUwY0#G?RG;b{GvB^Z?i zaI-W#Bj9{VDmW*xtG_3d&z1qv9q}I;cx9L~|8?lETkZt7V~oZ$+7g2-_KiRqhCF8i z-39ZLXn0L(8pa%8oW;)*314xRBrLAlH-LAwAlra&cvD3^HjP8E8Cm7kl={1gpvNrS zP`(@wO>sT?G@N!l)A8}^*crs_`Q}cHRH^eN%&MKY-Zf)c=O>pvy|>f)%&knqCrt#f zr=}p~7N|tR!6LpOemGD6)JU006_7Rpn-3U>=!RH)x%m@4n5XYZu3`P&fFtW^Gq%kiQ$q$ri*n9rXwJ2 zp(yqEW_AXzz^e4Kmd_5&knmRkoKmRvvuiL?(%>UMrLCb<;O(MRc;gE-i|RtP%?7mb zPICv3k*U_e8@LvF>;&8|{er&|yt@EPrYU5ZHS*dwElbHnrVM0C zM<%m2k!_+f*3{OQ!&pIBL}jjvMn#Y}_p)G$QUaS7GDuk#Q~m^NBW)X&iKQ*xI;da9 z8#iXUVXXxV!V%x53+1w~i*&WN^g6_0TTH;K2w%JE`eE!}P^Z4;ThM6Rux696II zjENpeSfn}TYtGr4a{{vBKGXOuc@&(j@x`X2fSHsAT&&>#C1=8=wUk$WNxP1mM?`3c zaBdNiJ`r*XXO4)>B#b}a}={K8!e>D`rDtVDGn;y?kD8pq?w8@4lY+iOrIUy`qgJNEyGbqy}F zB`q}H{YU-T-Q6`suZ7|JyJH~dol$*&;%B3g= z``#VvRQC0K$I8k5vrrGp#LwkUk`Gns1@EHkCngQhk=vh-g|!CsrS#W7)hZ`K!l#h= z1!|(JCBP5Kj6iN+rXz2_dE7P7X^(RB?Rv;W2D#dJ@$jS4u$EK`7b6Vzg1gfq6tsw7Fx(Q< z#uE$IHfo#o`m|fQp8L8~TtSLLqs5biWQWm0pF;w!X(h{YRD`e4kcDE{=f~BJG)qhO zAOX4b3pI;qfB!bhi#BL?AQa0Fm3urtdp@NhGdGU4#?t3Lx>{p^;h+EgKLP<|*6izk zuJ;8Z&${h+3pe{8u=)WYwq?1;@+({O|v32&ABie@2}r2yBzgP-es~w?Fy&-_@Sw zo~1UY5BFL79ZOf*y`Gh~UyTWGMSUd?nzj)~t^OhDbPW2@C$x9S3oqr|01^!We3S4p0gWtwCz>^*a zANdk^{Ec6d^HGNe_UlVhP>J$uG&zeUCQaQo+VK zNt*d=&Mi)ymf}wT|8%x^zKs^y1SX<3W)!P;;`9T{$6<;3R^ zYPc7wb16FNV5l}xHe1ht z9vEu!Y^cUHc-Yj!o7Z~LSSzcsT@}&e#^{BsqZ?ukH$+hrT2LvL*W3n@HxnN=#wOYu z|4Lg+XhfBW)4LS|Pom&>{Ug`4MO%aQfG$1QO>m2K5cog{@Ho)-L*A2&YwF`3gUbHu zv(R@Y9#+*K3pJ=cZzC~S?qy>jxtA?))MIQeV)E)6k>a%w)5B@JeW@OgQW14<3gl{1 zgnhQ|vo=IKf>e#4ZODVCX4PG9K)%aU38Hsada)*`(9i1lcaT1=*@O;1?ZG{%@whmJk?PdR;Wa% z=wQW8r)$PO+GAO@pZ8eK0AW|13&Qj_Tn+fTRp9I6!U-`dhT%&}+sM(!*R#WjQa)SP zX&t*@0nWHlq^XF1XA|CHNgVS$us7|r*lUfcF$KQ%xdpyv==e(U0x#fp?&w-^Qgr?6 zhlZ|m8eg%Ob^mtwdI|WNeOi1qgqPm3A&L`*!MFliVD6hb=2oN_X|c|nDe6F0x*dga z`U_`}`So5$WBAcm2gF_vB_G7F!mzv4C1Y6eMRlQ~L)f~k!qz2hHLl<1QV#OSdfULA*gH5KqYnlc5=J2?26s`4AW*u%h*EBW;GhdF zi((vfq#*`Z`bVg}@CnoFi+D`h8cW{CRjn{aHohl~-k=q1il_5WJVu%c9jMqoI2kXc zrax4ZL-${-YLq80GvCVZ0qbO|=Jmz*1tvA3KaH{4+?KS;n7SpH1HyOlwGY$8M2%hqFZ zufXySPGT(I%ih6@fmVr+;tiP~shMMbLv;GNV0`f`Mj-4u1jc{502t4-;_6-<&zSx;RC^g21)}RfsA6*cvS9_=PE2oKWFZa|TZ`D$f}_$>`ie z$3G^dE$zUEkxXK71~Q37odcP`ZYPOM%vmuqnUIQ)P&dvmeO&nuNFQgrUK4VnFe^G+ z3dx~2$e2Q~8Sg&}8W9#mUx#|XGjwHWSLf4@-u*JsNve3zN~&nk%be4*6{G1Hc0gXYljx@X)*AA)H;>8cxUT6B@~2zH{~r z=Gt?beQ>vxn-v@h8e&28nFMQjJmLKu&nhWJk{(WCrou-i1yhMBY=}r=eh@~?duGf7 zSII<-+M8s8m=z<4Qk@{i8|RpK|IU>ro=Zs+W#@+`igiik45{MVXHON^oD)^Vv|huA zqAx)S!(|gSB~d(`APOOyus{;S{>h1=`1BlNm_{#|CKknLqD-fWaYmYm_3m6r;y_B0 zU?rbelM2Nh>`uf#T%U*k&RhkNyhw$#3RNL)6A=z9zQ}f zbZ*=wrs?}g5s?q~_jMJWo-Y}6pULF(u^2h6NX3(4FgaU#0*Q{Mv%~|9XRz@n!IGBN zfj{OEBK-(^7WxsmPmW}1At=~L?M4qBY^&(#tCA0}CN*@(wawMhw?sZvS@qUo$4;jk zTNBWpt=d~z_1>`X(WEeRtbMQ03p~%#B_^lSsTG~^%!NbDmnUe+L_O@Je#*W2?gd{w zrXGta&e-a@opPwh#n#2(46qlO7Ca38f+1Vql>xrXAs zbM@kn8zNUdKD=Matx8!BiuCk!E-&n%miP2f4O7vPYq=v+sUyQ6GqPVJ+c2z#ot-be zB|xzggIC`rY_ae?AhXNqHjvr;kg@Qsp_h*7q5_z|wg%S)n`7gb2Fa}>_VtF3j}kFH zD&IPYF%jFYo|cf4B1`9K_}yY)a_M#52Ixh!ZLwF>F;i zSK7)pXTVo}YJB0%B%BE0AHCR*c$o9gY4J5nOpYhT*ZKw+GV=iA z=|>z8%|NwsdIXmoT|bbQ%R6%iF~iV<^q)EGQfkKGX_<7IcPdWc0;CXr(*`Pzm}I_Y zyP^mJ_TY|+BWdjohv3cMlAcFT%j6Dtaw%n7)qS2^TTyN!+J}Uj-kQhJ9H1z#m3CD&yDwW%7W0QcTnGlQU*1CoDe3;Aa;MklzfqK7i)nd}UF2OV z9KJDkkp0h5O}}FA^W^<1-qf6E-G|E-6(5L22{{N=L=CXvXG#Mg>6p*h!crUVIVr;P zdjYSzh@Rl%)rb6)xbRYb5~mvKYFq0$i!261}jN9?!pRk!pAV7-&n&R&1EKL{l;XPZf zIq-!?JKY<9cL)1)UTE(u`IIEtkr!);<#!Iz+&MIqutkCx>38B?+u7y9VP>a$&l8_Z z20SyhWYBZeNZ_A;K4%2~2j+98&XR?(RoERpSY&?_D>dMS&dut0VdNySIlw;o{xZQL ziBDp%;MKWTfg=6^igfk-nW5+dFtdLM1Tix^uLw#j0xugjX!wy0F=%w;ENcf6=_fIM zcn}%TCdLpCq{KMl!2~4fW}2r$Qfj`n>9jK2GWkFx5U6}7i7ipgZ$`v?KPiS-*T8ue z+vXZrm(i?T?yV*1%^aQWXXQGNS@iKJ+?`5^*^gT?~e$Fey3MCv`6F z?EevoXn(z+^X32C`wR8~%vZ-}i|Ya&zZ17)%`T7om}wI1N^e+WD=`#QgP5~JpBle(q%Uv8aLbZYGAiaQ&{QKrAB%!wNbJl+pgb;J!es8=pLg^p;hf4Gu} zOB?ko)XS6Uh&c1ze+wPa2kgWLQ4(<{HE4%;xBo7o`=u%CK0b|$s&7kr@|)r=!<*ujtoYp?>YGq=@;AkWru9i&GX(rV<0=$=yT!Gya*8*_@eZqa zQ=Ap5bLSp9rZmvzZ|N;tG^{d&-^kAw$JBnO zRB2KXquOuMaJm$_-nsKmOOh9+(&;5se(9-_xxxL(D!=(aYWj_YG}<&KRMy0whp)-0 z$$|de@B;i{H!z3i-#_DK75&}r5A^uEzO#LDgvFSd#qB9#oE6QRJ1^Z7(}Sx5F}>Gt z$NDZHb?x-IrV0v5e_SBCdpSFMrV2-`V)wancAl3{4kq4bKV!N2_enA{$<_ZkBIXZC zF&~CpeeDO8t68EJvNZ&@L6WW8+uJ)jI`E7Cl4R%QIJHSPM9(gd`&f2PgwB)foD5qQ zl#_wWQ6r&y{$*z)d_S=4Y+^~c^CepNSCQ;ozWXP<<_Dnv3Gt;%SqeU{5T|{!K!6tV zv~b*NmX{y+*DEQG2z`tI`-cMgz-gD~7s>}JBEbG=@02zDD)uw}w| z&{cbhqyCtI6+hG&_ZUuh&N*XX1>9(9;+9F1Pr!-i7rECq3|t-#ALp5ccbHOwfxvSn zU<9}(>)_&M7yyO~wfR%Ht(lImuQ)AnT?B~n<~z=%8x36uU_UuMb)5ykN^B)Q1ATb~ zz?{Oda;pA?Ju+0eQ%|)euNAR8v(c-kyhX7leWUxiTQ%&}ox9~a#|A&D+ zDGpwzkr6H&2HH{rZMqd?Yog=XAX+r^lu-THX<5M~y2V@ko{Hi8;GNU+gEOCP0wqQZ zsT#osc-YImV%W#IK{_*6^*A$Eb@0?SY$}+7S(vX8Ok>7vFiW$(i1!~2tg{>sip8mS zzG1Er)a#xN5N83zwqx>dB|*R{T8&DX$0n{0kynB}tfH?m)BVSTv~lnDoFJVhW^Jn# z0OdU-U08}445sl$yWq}4cVY*S>>tFAEtx+gLERT9F+e>rVF{>TZ-lxWhkDUR5bDNF zrgMV&$#(usyrm?dP1uO-;}yhtM^(V(HvoA!V_s_nvd)`9+JzrMARATTX9r~3o#1VX zrCal(g1$#=QA(BWMYD)vOhx6)YBeYF%lAik!gtl?XbxzP8 zv9KlJlNi_D(cS@=UJxf?Ruveadd09A@D74%w$7f-Gzo%&ul)ys>DfpaRW_r9aekpH zD3|x)gc<=fpG3L%xBWwPvWDJic{ zqU*KaIsIiwXKs&K?QyM2td`S+Vq90L_ue2Df75CIXu3GrNvGMTu}nDP^$dzNO&-UI zk@Q9`d%TvNLEOfS_W%{<=5Y@l9PG5-4E+V3U(grcRzQM}La?L=2Bdb{EU~DP$6lmS z5);L#?eRgfV1%6bWGNWYXktVq^K~)NL`CogK5>$`B8lWg{hB$G&v`xHwo6vEHK!HL zq1RwV=9|Feh-JFaYj7RV$ftav=gb$Bc$cJz4AT=s#hg;LLC<2S$Q(O!lAf&MfQ;@O z^A6c$u$Th9TIYbKeXi5y)IP_nc0dQ_FgNabt8>|e%~Lv;wcHX0$g|4ZB6!|C8nK}2 zxF+Kt3`C_K-qOY&n7J-{sB$&jtHC4}X5q9Z4WU)kY9`PfJAw(DkGupkJJR zU3caLWM5f596H8To!omh57lEch=7ne2Awpqx;t(YBbiBuAz*u4l8Am@d}8fdCLL?h z|N1-K*M6MAIKO>AUTO>OPCODES.TEST\;10 96285 |changes| |to:| (FNS UNWINDTESTER CLOSUREMAINTEST ADDR-IN-RANGE) (FUNCTIONS SLOPED-LINES DIAGONALS SIMULATE-PILOTBITBLT BUMP XCL-USER::COPY.N.TEST XCL-USER::STORE.N.TEST XCL-USER::POP.N.TEST) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER) (TESTS ERROR+ ERROR/T ERROR/0 NO-ERROR-0/0) (VARS OPCODESCOMS) |previous| |date:| "16-Nov-88 16:38:34" {ERIS}MAIKO>AUTO>OPCODES.TEST\;9) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ( (* |;;| "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (COMS (* \; "BITBLT") (FUNCTIONS SIMULATE-PILOTBITBLT BUMP) (FUNCTIONS SLOPED-LINES DIAGONALS) (FNS ADDR-IN-RANGE) (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (FUNCTIONS XCL-USER::COPY.N.TEST) (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (FUNCTIONS XCL-USER::STORE.N.TEST) (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (FUNCTIONS XCL-USER::POP.N.TEST) (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (VARS (*NON-CONSTANT-FLOAT-1* 1.0)) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (VARS (*NON-CONSTANT-T* T) (*NON-CONSTANT-0* 0)) (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (TESTS ERROR+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (TESTS ERROR/T ERROR/0 NO-ERROR-0/0) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (* \; "BITBLT") (CL:DEFUN SIMULATE-PILOTBITBLT (BBT LOW-WORD-ADDR HI-WORD-ADDR) (* |;;| "A translation of the algorithm in the Mesa PrincOps.") (* |;;| " S-L-O-W !!!") (LET ((SRC.WORD (FETCH (PILOTBBT PBTSOURCE) OF BBT)) (SRC.BIT (FETCH (PILOTBBT PBTSOURCEBIT) OF BBT)) (SRC.BPL (FETCH (PILOTBBT PBTSOURCEBPL) OF BBT)) (DST.WORD (FETCH (PILOTBBT PBTDEST) OF BBT)) (DST.BIT (FETCH (PILOTBBT PBTDESTBIT) OF BBT)) (DST.BPL (FETCH (PILOTBBT PBTDESTBPL) OF BBT)) (BBT.WIDTH (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (BBT.HEIGHT (FETCH (PILOTBBT PBTHEIGHT) OF BBT)) (BOOL-OP (LET ((COMPLEMENT? (NOT (CL:ZEROP (FETCH (PILOTBBT PBTSOURCETYPE) OF BBT))) )) (CL:ECASE (FETCH (PILOTBBT PBTOPERATION) OF BBT) ((0) (CL:IF COMPLEMENT? CL:BOOLE-C1 CL:BOOLE-1)) ((1) (CL:IF COMPLEMENT? CL:BOOLE-ANDC1 CL:BOOLE-AND)) ((2) (CL:IF COMPLEMENT? CL:BOOLE-ORC1 CL:BOOLE-IOR)) ((3) (CL:IF COMPLEMENT? CL:BOOLE-EQV CL:BOOLE-XOR))))) (GRAY? (FETCH (PILOTBBT PBTUSEGRAY) OF BBT)) (GRAY.WIDTH (ITIMES (ADD1 (FETCH (PILOTBBT PBTGRAYWIDTHLESSONE) OF BBT)) 16)) (GRAY.HEIGHT (ADD1 (FETCH (PILOTBBT PBTGRAYHEIGHTLESSONE) OF BBT))) LINE GRAY.BUMP LAST-GRAY Y-FORWARD? X-FORWARD?) (CL:LABELS ((MODIFY-BIT (DSTWORD DSTBIT DSTOFFSET SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (SRCWORD SRCBIT) (BUMP SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (DSTWORD DSTBIT) (BUMP DSTWORD DSTBIT DSTOFFSET) (ADDR-IN-RANGE LOW-WORD-ADDR DSTWORD HI-WORD-ADDR) (CL:SETF (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0)) (CL:BOOLE BOOL-OP (LDB (BYTE 1 (IDIFFERENCE 15 SRCBIT )) (GETBASE SRCWORD 0)) (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0))))))) (BITBLT-ITEM NIL (LET ((OFFSET (CL:IF X-FORWARD? 0 (SUB1 BBT.WIDTH)))) (FRPTQ BBT.WIDTH (LET ((POS (CL:IF GRAY? (IDIFFERENCE (IMOD (IPLUS OFFSET SRC.BIT) (ABS GRAY.WIDTH)) SRC.BIT) OFFSET))) (MODIFY-BIT DST.WORD DST.BIT OFFSET SRC.WORD SRC.BIT POS) ) (CL:INCF OFFSET (CL:IF X-FORWARD? 1 -1))))) (SETUP NIL (CL:WHEN GRAY? (SETQ GRAY.BUMP (IMINUS (ITIMES GRAY.WIDTH (SUB1 GRAY.HEIGHT))))) (COMPUTE-DIRECTION) (CL:WHEN GRAY? (SETQ LAST-GRAY (CL:IF Y-FORWARD? (IDIFFERENCE GRAY.HEIGHT 1 (FETCH (PILOTBBT PBTGRAYOFFSET ) OF BBT)) (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)))) (SETQ LINE (CL:IF Y-FORWARD? 0 (SUB1 BBT.HEIGHT)))) (COMPUTE-DIRECTION NIL (SETQ Y-FORWARD? (SETQ X-FORWARD? (NOT (FETCH (PILOTBBT PBTBACKWARD) OF BBT)))))) (SETUP) (WHILE (AND (ILEQ 0 LINE) (ILESSP LINE BBT.HEIGHT)) DO (BITBLT-ITEM) (BLOCK) (* \; "just to be nice.") (CL:MULTIPLE-VALUE-SETQ (SRC.WORD SRC.BIT) (BUMP SRC.WORD SRC.BIT (CL:IF GRAY? (CL:IF (= (IMOD LINE GRAY.HEIGHT) LAST-GRAY) GRAY.BUMP GRAY.WIDTH) SRC.BPL))) (CL:MULTIPLE-VALUE-SETQ (DST.WORD DST.BIT) (BUMP DST.WORD DST.BIT DST.BPL)) (CL:INCF LINE (CL:IF Y-FORWARD? 1 -1)))))) (CL:DEFUN BUMP (WORD BIT INCR) (CL:MULTIPLE-VALUE-BIND (WORD-INCR NEW-BIT) (CL:FLOOR (IPLUS BIT INCR) 16) (CL:VALUES (ADDBASE WORD WORD-INCR) NEW-BIT))) (CL:DEFUN SLOPED-LINES (W) (LET* ((FEEDBACK-INTERVAL (QUOTIENT W 20)) (NEXT-FEEDBACK 0) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (LOW-ADDR (FETCH (ARRAY-HEADER BASE) OF R)) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF A) PBTDESTBIT _ 0 PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 0 PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:DOTIMES (SLOPE W) (CL:WHEN (> SLOPE NEXT-FEEDBACK) (CL:PRINC #\. *ERROR-OUTPUT*) (CL:INCF NEXT-FEEDBACK FEEDBACK-INTERVAL)) (CL:FILL DA 0) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH (IPLUS W SLOPE 1)) (CL:INCF (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (REPLACE (PILOTBBT PBTHEIGHT) OF BBT WITH (CL:CEILING W (ADD1 SLOPE))) (\\PILOTBITBLT BBT NIL) (CL:FILL DR 0) (SIMULATE-PILOTBITBLT (CREATE PILOTBBT USING BBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF R)) LOW-ADDR HI-ADDR) (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:CERROR "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" W SLOPE))))) (CL:DEFUN DIAGONALS (W SKIP-SIMULATION SKIP-UCODE) (* |;;| "Draw both diagonals in a square of size W.") (* |;;|  "if SKIP-SIMULATION is not NIL, don't bother with the simulation or a consistency check.") (* |;;|  "if SKIP-UCODE is not NIL, don't bother with the real microcode version or a consistency check.") (LET* ((FAILURES NIL) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (A-BASE (FETCH (ARRAY-HEADER BASE) OF A)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (R-BASE (FETCH (ARRAY-HEADER BASE) OF R)) (LOW-ADDR R-BASE) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 1 PBTHEIGHT _ W PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:MACROLET ((CLEAR (WHICH) `(CL:FILL ,WHICH 0))) (CL:LABELS ((SET-SOURCE (BBT BASE INCREMENT) (CL:MULTIPLE-VALUE-BIND (WORD BIT) (BUMP BASE 0 INCREMENT) (REPLACE (PILOTBBT PBTDEST) OF BBT WITH WORD) (REPLACE (PILOTBBT PBTDESTBIT) OF BBT WITH BIT)) BBT) (CHECK-RESULT (FROM TO START-OFFSET) (CLEAR DR) (CL:UNLESS SKIP-SIMULATION (* |;;| "Only run this if we need the simulation.") (SIMULATE-PILOTBITBLT (SET-SOURCE (CREATE PILOTBBT USING BBT) R-BASE START-OFFSET) LOW-ADDR HI-ADDR)) (CL:UNLESS (OR SKIP-SIMULATION SKIP-UCODE) (* |;;| "Only check the results if we ran both versions.") (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:PUSH (CL:CONCATENATE 'STRING FROM " to " TO) FAILURES) (CL:CERROR "Try the next one" "Bad BITBLT: ~A to ~A diagonal w: ~D " FROM TO W))) ) (DO-ONE (FROM TO START-OFFSET BPL) (CLEAR DA) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH BPL) (REPLACE (PILOTBBT PBTBACKWARD) OF BBT WITH (ILESSP BPL 0)) (OR SKIP-UCODE (\\PILOTBITBLT (SET-SOURCE BBT A-BASE START-OFFSET) NIL)) (CHECK-RESULT FROM TO START-OFFSET))) (DO-ONE "upper left" "lower right" 0 (ADD1 W)) (DO-ONE "upper right" "lower left" (SUB1 W) (SUB1 W)) (DO-ONE "lower left" "upper right" (ITIMES W (SUB1 W)) (IMINUS (SUB1 W))) (DO-ONE "lower right" "upper left" (SUB1 (ITIMES W W)) (IMINUS (ADD1 W))))) (CL:VALUES (NOT FAILURES) FAILURES))) (DEFINEQ (ADDR-IN-RANGE (LAMBDA (LOW ADDR HI) (* \; "Edited 16-Nov-88 14:32 by jds") (OR (<= (+ (LLSH (HILOC LOW) 16) (LOLOC LOW)) (+ (LLSH (HILOC ADDR) 16) (LOLOC ADDR)) (+ (LLSH (HILOC HI) 16) (LOLOC HI))) (HELP))) ) ) (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN '(1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN '(1 3 4 5 7 8 9 15 16 17) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (CL:DEFUN XCL-USER::COPY.N.TEST (XCL-USER::USE-UFN) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 2 1 :OK -1 -2) (CL:FUNCALL (\\GETUFNENTRY 'COPY.N) 4)) ((OPCODES COPY.N 4) 2 1 :OK -1 -2))) (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (CL:DEFUN XCL-USER::STORE.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (STORE.N.TEST NIL) and (STORE.N.TEST T) should return the list (5 4 t 2 1)" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 5 4 3 2 1) (CL:FUNCALL (\\GETUFNENTRY 'STORE.N) T 4)) ((OPCODES STORE.N 4) 5 4 3 2 1 T)) ((OPCODES APPLYFN) 5 'LIST)) (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (CL:DEFUN XCL-USER::POP.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 4 3 2 1 0) (CL:FUNCALL (\\GETUFNENTRY 'POP.N) 2)) ((OPCODES POP.N 2) 4 3 2 1 0))) (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST 'SUCCESS (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) '(SUCCESS 3.1415927)))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 16-Nov-88 18:00 by jds") (|for| D |from| 0 |to| (OR DEPTH 10) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high|  |half| |is| |one's| |complement|  |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ 'SUCCESS (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) `(DOFINDKEYTEST1 ((OPCODES FINDKEY ,N) ',KEY) ,N ',KEY))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) `(PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS ,N) ((OPCODES RESTLIST ,N) NIL KEYARGS) ,N)))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* \; "Edited 16-Nov-88 18:01 by jds") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (CL:FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CL:FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) ) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) ) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) ) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) ) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (RPAQQ *NON-CONSTANT-FLOAT-1* 1.0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) :INITIAL-CONTENTS '(0 1 0 1))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :INITIAL-CONTENTS '(0 34 56 255 23))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) :INITIAL-CONTENTS '(0 34 255 65535 23))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 16) :INITIAL-CONTENTS '(0 -34 255 -32768 23)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 32) :INITIAL-CONTENTS '(0 -34 258 -65538 2147483647)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS '(0.0 -34.0 3.456756E+35 -5.768E-34 5.4524)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS '(#\Space #\a #\b))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :FATP T :INITIAL-CONTENTS '(#\Space #\Greek-0 #\Greek-32)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) (+ *NON-CONSTANT-FLOAT-1* 3.4) 'XCL-USER::C (CONS 'XCL-USER::D 'XCL-USER::E))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) (+ *NON-CONSTANT-FLOAT-1* 3.4) 'XCL-USER::C (CONS 'XCL-USER::D 'XCL-USER::E))) (* |;;| "The IL:*NON-CONSTANT-FLOAT-1* is there to prevent using a constant float and getting screwed by refcount.") (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'XPOINTER :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS '(#\a #\b #\c #\d)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS '(0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B)))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :READ-ONLY-P T :INITIAL-CONTENTS '(0 1 2 3)))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 4) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 65535) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 255 -32768) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 65536 -2147483648) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(1 0 1 0) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 4) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 65535) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 255 -32768) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD ) XCL-USER::WORD))))) ))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 65536 -2147483648) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1 )))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))) )))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A 'XCL-USER::B) ) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A 'XCL-USER::B) ) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))) )))))))) (* |;;| "Boxed opcodes") (RPAQQ *NON-CONSTANT-T* T) (RPAQQ *NON-CONSTANT-0* 0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1 -3 9834756987354 21845 -54)) (CL:DOLIST (XCL-USER::Y '(1 -3 9834756987354 21845 -54)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 -54.0)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 -3 1/3 9834756987354 21845 -54)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR+ (DO-TEST T-FIRST (EXPECT-ERRORS (T) (+ *NON-CONSTANT-T* 3))) (DO-TEST T-SECOND (EXPECT-ERRORS (T) (+ 3 *NON-CONSTANT-T*)))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 9834756987354 21845 -54)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845.0 -54.0)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 1/3 9834756987354 21845 -54)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 345235424 0 23 21845)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 1/3 345235424 0 23 21845)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 345235424 -45)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 4/3 -1345619432 45)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR/T (DO-TEST T-DIVISOR (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-T*))) (DO-TEST T-NUMERATOR (EXPECT-ERRORS (T) (/ *NON-CONSTANT-T* 34)))) (DEFTEST ERROR/0 (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-0*))) (DEFTEST NO-ERROR-0/0 (/ *NON-CONSTANT-0* *NON-CONSTANT-0*)) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 -45 345235424 22000)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 22000.0)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1/3 -45 5498457654 22000)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 0.0 -45.0 4.6678E+23)) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 3)) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ( (* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845 1/3 -54.0)) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS '(1.0 2.0 3.0 4.0))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR '((1.0 . 3) (1.0 . 1) (3.5 . 3))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 20.5 1/3 -5.2)) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(2.7182817 -2.0 453.78)) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (20412 20637 (ADDR-IN-RANGE 20422 . 20635)) (23316 30084 (UNWINDTESTER 23326 . 23732) ( UNWINDMAINTEST 23734 . 26742) (UNWINDMAINTEST.RECURSE 26744 . 26913) (UNWINDCHECK1 26915 . 27213) ( UNWINDCHECK2 27215 . 29880) (UNWINDCODE 29882 . 30082)) (31160 34419 (UW2.TEST 31170 . 31601) ( UW2.RECURSE 31603 . 31842) (UW2.TEST.MAIN 31844 . 32501) (UW2.CHECK 32503 . 34111) (UW2.IDENTITY 34113 . 34417)) (34608 36213 (FINDKEYTESTER 34618 . 34832) (DOFINDKEYTEST 34834 . 35714) (DOFINDKEYTEST1 35716 . 36211)) (36767 41156 (\\RESTLIST.SPLICE.FRAME 36777 . 38111) (RESTLISTTESTER 38113 . 38687) ( DORESTLISTTEST 38689 . 39058) (GETRESTARGREFCNTS 39060 . 39281) (DORESTLISTTEST1 39283 . 41154)) ( 42086 47428 (CLOSURETESTER 42096 . 42398) (CLOSUREMAINTEST 42400 . 44327) (CLOSUREMAINTEST.RECURSE 44329 . 44485) (CLOSUREFNCHECK 44487 . 45290) (CLOSUREFNCHECK2 45292 . 45586) (CLOSUREFN1 45588 . 46077) (CLOSUREFN1VALUE 46079 . 46226) (CLOSUREFN2 46228 . 46717) (CLOSUREFN2VALUE 46719 . 46866) ( CLOSUREFN4CODE 46868 . 47282) (CLOSUREFN4VALUE 47284 . 47426)) (47708 49342 (FVARTEST0 47718 . 47925) (FVARTEST1 47927 . 48431) (FVARTEST2 48433 . 49119) (FVARTEST3 49121 . 49340))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ new file mode 100644 index 00000000..2c0b47d0 --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "26-Oct-88 19:11:04" {ERIS}MAIKO>AUTO>OPCODES.TEST\;4 30102 |changes| |to:| (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES COPY.N STORE.N POP.N UNWIND UNWIND-2 FINDKEY RESTLIST CLOSURES) (VARS OPCODESCOMS) |previous| |date:| "21-Oct-88 17:34:38" {ERIS}MAIKO>AUTO>OPCODES.TEST\;3) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ( (* |;;|  "This le contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (ADDVARS (DIRECTORIES {ERIS}MAIKO>AUX>)) (FILES OPTESTS BBTESTS) (COMS (* \; "BITBLT") (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This le contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (ADDTOVAR DIRECTORIES {ERIS}MAIKO>AUX>) (FILESLOAD OPTESTS BBTESTS) (* \; "BITBLT") (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN '(1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN '(1 3 4 5 7 8 9 15 16 17) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST 'SUCCESS (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) '(SUCCESS 3.1415927)))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 26-Sep-88 14:11 by bvm") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high|  |half| |is| |one's| |complement|  |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ 'SUCCESS (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST 'KEYA 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 KEYA) (FINDKEYCHECK 2 KEYA) (FINDKEYCHECK 3 KEYA) (FINDKEYCHECK 4 KEYA) (FINDKEYCHECK 5 KEYA) (FINDKEYCHECK 6 KEYA) (FINDKEYCHECK 7 KEYA) (FINDKEYCHECK 8 KEYA) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) `(DOFINDKEYTEST1 ((OPCODES FINDKEY ,N) ',KEY) ,N ',KEY))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST 'KEYA 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(KEYA) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) `(PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS ,N) ((OPCODES RESTLIST ,N) NIL KEYARGS) ,N)))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER ) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5527 12310 (UNWINDTESTER 5537 . 5958) (UNWINDMAINTEST 5960 . 8968) ( UNWINDMAINTEST.RECURSE 8970 . 9139) (UNWINDCHECK1 9141 . 9439) (UNWINDCHECK2 9441 . 12106) (UNWINDCODE 12108 . 12308)) (13386 16645 (UW2.TEST 13396 . 13827) (UW2.RECURSE 13829 . 14068) (UW2.TEST.MAIN 14070 . 14727) (UW2.CHECK 14729 . 16337) (UW2.IDENTITY 16339 . 16643)) (16834 18457 (FINDKEYTESTER 16844 . 17060) (DOFINDKEYTEST 17062 . 17958) (DOFINDKEYTEST1 17960 . 18455)) (18894 23287 ( \\RESTLIST.SPLICE.FRAME 18904 . 20238) (RESTLISTTESTER 20240 . 20818) (DORESTLISTTEST 20820 . 21189) ( GETRESTARGREFCNTS 21191 . 21412) (DORESTLISTTEST1 21414 . 23285)) (24200 29616 (CLOSURETESTER 24210 . 24512) (CLOSUREMAINTEST 24514 . 26515) (CLOSUREMAINTEST.RECURSE 26517 . 26673) (CLOSUREFNCHECK 26675 . 27478) (CLOSUREFNCHECK2 27480 . 27774) (CLOSUREFN1 27776 . 28265) (CLOSUREFN1VALUE 28267 . 28414) ( CLOSUREFN2 28416 . 28905) (CLOSUREFN2VALUE 28907 . 29054) (CLOSUREFN4CODE 29056 . 29470) ( CLOSUREFN4VALUE 29472 . 29614))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ new file mode 100644 index 00000000..272d4d6f --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "27-Oct-88 10:25:24" {ERIS}MAIKO>AUTO>OPCODES.TEST\;5 30734 |changes| |to:| (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1 \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1 UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (VARS OPCODESCOMS) (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES COPY.N STORE.N POP.N UNWIND UNWIND-2 FINDKEY RESTLIST CLOSURES) |previous| |date:| "26-Oct-88 19:11:04" {ERIS}MAIKO>AUTO>OPCODES.TEST\;4) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ( (* |;;|  "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (ADDVARS (DIRECTORIES {ERIS}MAIKO>AUX>)) (FILES OPTESTS BBTESTS) (COMS (* \; "BITBLT") (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (ADDTOVAR DIRECTORIES {ERIS}MAIKO>AUX>) (FILESLOAD OPTESTS BBTESTS) (* \; "BITBLT") (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN '(1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN '(1 3 4 5 7 8 9 15 16 17) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST 'SUCCESS (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) '(SUCCESS 3.1415927)))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 26-Sep-88 14:11 by bvm") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high|  |half| |is| |one's| |complement|  |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ 'SUCCESS (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) `(DOFINDKEYTEST1 ((OPCODES FINDKEY ,N) ',KEY) ,N ',KEY))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) `(PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS ,N) ((OPCODES RESTLIST ,N) NIL KEYARGS) ,N)))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER ) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (6181 12964 (UNWINDTESTER 6191 . 6612) (UNWINDMAINTEST 6614 . 9622) ( UNWINDMAINTEST.RECURSE 9624 . 9793) (UNWINDCHECK1 9795 . 10093) (UNWINDCHECK2 10095 . 12760) ( UNWINDCODE 12762 . 12962)) (14040 17299 (UW2.TEST 14050 . 14481) (UW2.RECURSE 14483 . 14722) ( UW2.TEST.MAIN 14724 . 15381) (UW2.CHECK 15383 . 16991) (UW2.IDENTITY 16993 . 17297)) (17488 19093 ( FINDKEYTESTER 17498 . 17712) (DOFINDKEYTEST 17714 . 18594) (DOFINDKEYTEST1 18596 . 19091)) (19530 23919 (\\RESTLIST.SPLICE.FRAME 19540 . 20874) (RESTLISTTESTER 20876 . 21450) (DORESTLISTTEST 21452 . 21821) (GETRESTARGREFCNTS 21823 . 22044) (DORESTLISTTEST1 22046 . 23917)) (24832 30248 (CLOSURETESTER 24842 . 25144) (CLOSUREMAINTEST 25146 . 27147) (CLOSUREMAINTEST.RECURSE 27149 . 27305) (CLOSUREFNCHECK 27307 . 28110) (CLOSUREFNCHECK2 28112 . 28406) (CLOSUREFN1 28408 . 28897) (CLOSUREFN1VALUE 28899 . 29046) (CLOSUREFN2 29048 . 29537) (CLOSUREFN2VALUE 29539 . 29686) (CLOSUREFN4CODE 29688 . 30102) ( CLOSUREFN4VALUE 30104 . 30246))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ new file mode 100644 index 00000000..ebf2fd09 --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 8-Nov-88 16:31:16" {ERIS}MAIKO>AUTO>OPCODES.TEST\;6 60216 |changes| |to:| (TESTS FREE-VAR-LOOKUP) (VARS OPCODESCOMS) |previous| |date:| "27-Oct-88 10:25:24" {ERIS}MAIKO>AUTO>OPCODES.TEST\;5) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ((* |;;| "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (ADDVARS (DIRECTORIES {ERIS}MAIKO>AUX>)) (FILES OPTESTS BBTESTS) (COMS (* \; "BITBLT") (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST)))) ) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (ADDTOVAR DIRECTORIES {ERIS}MAIKO>AUX>) (FILESLOAD OPTESTS BBTESTS) (* \; "BITBLT") (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN (QUOTE (1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41)) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN (QUOTE (1 3 4 5 7 8 9 15 16 17)) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST (QUOTE SUCCESS) (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) (QUOTE (SUCCESS 3.1415927))))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 26-Sep-88 14:11 by bvm") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high| |half| |is| |one's| |complement| |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535))))) ) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ (QUOTE SUCCESS) (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) (BQUOTE (DOFINDKEYTEST1 ((OPCODES FINDKEY (\\\, N)) (QUOTE (\\\, KEY))) (\\\, N) (QUOTE (\\\, KEY)))))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) (BQUOTE (PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS (\\\, N)) ((OPCODES RESTLIST (\\\, N)) NIL KEYARGS) (\\\, N)))))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER ) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) ) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) ) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) ) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) ) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :INITIAL-CONTENTS (QUOTE (0 1 0 1)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :INITIAL-CONTENTS (QUOTE (0 34 56 255 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 34 255 65535 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 -34 255 -32768 23))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 32)) :INITIAL-CONTENTS (QUOTE (0 -34 258 -65538 2147483647))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (0.0 -34.0 3.456756E+35 -5.768E-34 5.4524))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\Space #\a #\b)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :FATP T :INITIAL-CONTENTS (QUOTE (#\Space #\Greek-0 #\Greek-32))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) 3.4 (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) 3.4 (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE XPOINTER) :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\a #\b #\c #\d))))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS (QUOTE (0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B))))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :READ-ONLY-P T :INITIAL-CONTENTS (QUOTE (0 1 2 3))))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (1 0 1 0)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD) XCL-USER::WORD)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (* |;;| "Boxed opcodes") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 1/3 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 345235424 -45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 4/3 -1345619432 45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 -45 345235424 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 22000.0))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1/3 -45 5498457654 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE ((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156)))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 0.0 -45.0 4.6678E+23))) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 3))) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845 1/3 -54.0))) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (1.0 2.0 3.0 4.0)))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR (QUOTE ((1.0 . 3) (1.0 . 1) (3.5 . 3)))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 20.5 1/3 -5.2))) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (2.7182817 -2.0 453.78))) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5504 12287 (UNWINDTESTER 5514 . 5935) (UNWINDMAINTEST 5937 . 8945) ( UNWINDMAINTEST.RECURSE 8947 . 9116) (UNWINDCHECK1 9118 . 9416) (UNWINDCHECK2 9418 . 12083) (UNWINDCODE 12085 . 12285)) (12688 15947 (UW2.TEST 12698 . 13129) (UW2.RECURSE 13131 . 13370) (UW2.TEST.MAIN 13372 . 14029) (UW2.CHECK 14031 . 15639) (UW2.IDENTITY 15641 . 15945)) (16113 17718 (FINDKEYTESTER 16123 . 16337) (DOFINDKEYTEST 16339 . 17219) (DOFINDKEYTEST1 17221 . 17716)) (18008 22397 ( \\RESTLIST.SPLICE.FRAME 18018 . 19352) (RESTLISTTESTER 19354 . 19928) (DORESTLISTTEST 19930 . 20299) ( GETRESTARGREFCNTS 20301 . 20522) (DORESTLISTTEST1 20524 . 22395)) (22989 28405 (CLOSURETESTER 22999 . 23301) (CLOSUREMAINTEST 23303 . 25304) (CLOSUREMAINTEST.RECURSE 25306 . 25462) (CLOSUREFNCHECK 25464 . 26267) (CLOSUREFNCHECK2 26269 . 26563) (CLOSUREFN1 26565 . 27054) (CLOSUREFN1VALUE 27056 . 27203) ( CLOSUREFN2 27205 . 27694) (CLOSUREFN2VALUE 27696 . 27843) (CLOSUREFN4CODE 27845 . 28259) ( CLOSUREFN4VALUE 28261 . 28403)) (28678 30312 (FVARTEST0 28688 . 28895) (FVARTEST1 28897 . 29401) ( FVARTEST2 29403 . 30089) (FVARTEST3 30091 . 30310))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ new file mode 100644 index 00000000..fbb78460 --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 8-Nov-88 17:10:36" {ERIS}MAIKO>AUTO>OPCODES.TEST\;7 60631 |changes| |to:| (XCL-USER::VERIFIED-TESTS XCL-USER::INT+) (TESTS ERROR+ ERROR/T ERROR/0 NO-ERROR-0/0 ERROR-T/X FREE-VAR-LOOKUP) (VARS OPCODESCOMS) |previous| |date:| "27-Oct-88 10:25:24" {ERIS}MAIKO>AUTO>OPCODES.TEST\;5) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ((* |;;| "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (ADDVARS (DIRECTORIES {ERIS}MAIKO>AUX>)) (FILES OPTESTS BBTESTS) (COMS (* \; "BITBLT") (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (TESTS ERROR+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (TESTS ERROR/T ERROR/0 NO-ERROR-0/0 ERROR-T/X) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST)))) ) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (ADDTOVAR DIRECTORIES {ERIS}MAIKO>AUX>) (FILESLOAD OPTESTS BBTESTS) (* \; "BITBLT") (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN (QUOTE (1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41)) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN (QUOTE (1 3 4 5 7 8 9 15 16 17)) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST (QUOTE SUCCESS) (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) (QUOTE (SUCCESS 3.1415927))))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 26-Sep-88 14:11 by bvm") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high| |half| |is| |one's| |complement| |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535))))) ) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ (QUOTE SUCCESS) (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) (BQUOTE (DOFINDKEYTEST1 ((OPCODES FINDKEY (\\\, N)) (QUOTE (\\\, KEY))) (\\\, N) (QUOTE (\\\, KEY)))))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) (BQUOTE (PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS (\\\, N)) ((OPCODES RESTLIST (\\\, N)) NIL KEYARGS) (\\\, N)))))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER ) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) ) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) ) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) ) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) ) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :INITIAL-CONTENTS (QUOTE (0 1 0 1)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :INITIAL-CONTENTS (QUOTE (0 34 56 255 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 34 255 65535 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 -34 255 -32768 23))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 32)) :INITIAL-CONTENTS (QUOTE (0 -34 258 -65538 2147483647))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (0.0 -34.0 3.456756E+35 -5.768E-34 5.4524))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\Space #\a #\b)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :FATP T :INITIAL-CONTENTS (QUOTE (#\Space #\Greek-0 #\Greek-32))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) 3.4 (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) 3.4 (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE XPOINTER) :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\a #\b #\c #\d))))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS (QUOTE (0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B))))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :READ-ONLY-P T :INITIAL-CONTENTS (QUOTE (0 1 2 3))))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (1 0 1 0)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD) XCL-USER::WORD)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (* |;;| "Boxed opcodes") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1 -3 9834756987354 21845 -54))) (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (DEFTEST ERROR+ (EXPECT-ERRORS (T) (+ T 3))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 1/3 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 345235424 -45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 4/3 -1345619432 45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (DEFTEST ERROR/T (EXPECT-ERRORS (T) (/ 34 T))) (DEFTEST ERROR/0 (EXPECT-ERRORS (T) (/ 34 0))) (DEFTEST NO-ERROR-0/0 (/ 0 0)) (DEFTEST ERROR-T/X (EXPECT-ERRORS (T) (/ T 5))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 -45 345235424 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 22000.0))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1/3 -45 5498457654 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE ((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156)))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 0.0 -45.0 4.6678E+23))) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 3))) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845 1/3 -54.0))) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (1.0 2.0 3.0 4.0)))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR (QUOTE ((1.0 . 3) (1.0 . 1) (3.5 . 3)))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 20.5 1/3 -5.2))) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (2.7182817 -2.0 453.78))) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5655 12438 (UNWINDTESTER 5665 . 6086) (UNWINDMAINTEST 6088 . 9096) ( UNWINDMAINTEST.RECURSE 9098 . 9267) (UNWINDCHECK1 9269 . 9567) (UNWINDCHECK2 9569 . 12234) (UNWINDCODE 12236 . 12436)) (12839 16098 (UW2.TEST 12849 . 13280) (UW2.RECURSE 13282 . 13521) (UW2.TEST.MAIN 13523 . 14180) (UW2.CHECK 14182 . 15790) (UW2.IDENTITY 15792 . 16096)) (16264 17869 (FINDKEYTESTER 16274 . 16488) (DOFINDKEYTEST 16490 . 17370) (DOFINDKEYTEST1 17372 . 17867)) (18159 22548 ( \\RESTLIST.SPLICE.FRAME 18169 . 19503) (RESTLISTTESTER 19505 . 20079) (DORESTLISTTEST 20081 . 20450) ( GETRESTARGREFCNTS 20452 . 20673) (DORESTLISTTEST1 20675 . 22546)) (23140 28556 (CLOSURETESTER 23150 . 23452) (CLOSUREMAINTEST 23454 . 25455) (CLOSUREMAINTEST.RECURSE 25457 . 25613) (CLOSUREFNCHECK 25615 . 26418) (CLOSUREFNCHECK2 26420 . 26714) (CLOSUREFN1 26716 . 27205) (CLOSUREFN1VALUE 27207 . 27354) ( CLOSUREFN2 27356 . 27845) (CLOSUREFN2VALUE 27847 . 27994) (CLOSUREFN4CODE 27996 . 28410) ( CLOSUREFN4VALUE 28412 . 28554)) (28829 30463 (FVARTEST0 28839 . 29046) (FVARTEST1 29048 . 29552) ( FVARTEST2 29554 . 30240) (FVARTEST3 30242 . 30461))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ new file mode 100644 index 00000000..2dd3e331 --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-Nov-88 14:59:09" {ERIS}MAIKO>AUTO>OPCODES.TEST\;8 69120 |changes| |to:| (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER) (TESTS ERROR+ ERROR/T ERROR/0 NO-ERROR-0/0) (FUNCTIONS SIMULATE-PILOTBITBLT BUMP SLOPED-LINES DIAGONALS XCL-USER::COPY.N.TEST XCL-USER::STORE.N.TEST XCL-USER::POP.N.TEST) (VARS OPCODESCOMS) (FNS ADDR-IN-RANGE) |previous| |date:| " 8-Nov-88 17:10:36" {ERIS}MAIKO>AUTO>OPCODES.TEST\;7) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ((* |;;| "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (COMS (* \; "BITBLT") (FUNCTIONS SIMULATE-PILOTBITBLT BUMP) (FUNCTIONS SLOPED-LINES DIAGONALS) (FNS ADDR-IN-RANGE) (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (FUNCTIONS XCL-USER::COPY.N.TEST) (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (FUNCTIONS XCL-USER::STORE.N.TEST) (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (FUNCTIONS XCL-USER::POP.N.TEST) (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (VARS (*NON-CONSTANT-FLOAT-1* 1.0)) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (VARS (*NON-CONSTANT-T* T) (*NON-CONSTANT-0* 0)) (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (TESTS ERROR+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (TESTS ERROR/T ERROR/0 NO-ERROR-0/0) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (* \; "BITBLT") (CL:DEFUN SIMULATE-PILOTBITBLT (BBT LOW-WORD-ADDR HI-WORD-ADDR) (* |;;| "A translation of the algorithm in the Mesa PrincOps.") (* |;;| " S-L-O-W !!!") (LET ((SRC.WORD (FETCH (PILOTBBT PBTSOURCE) OF BBT)) (SRC.BIT (FETCH (PILOTBBT PBTSOURCEBIT) OF BBT)) (SRC.BPL (FETCH (PILOTBBT PBTSOURCEBPL) OF BBT)) (DST.WORD (FETCH (PILOTBBT PBTDEST) OF BBT)) (DST.BIT (FETCH (PILOTBBT PBTDESTBIT) OF BBT)) (DST.BPL (FETCH (PILOTBBT PBTDESTBPL) OF BBT)) (BBT.WIDTH (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (BBT.HEIGHT (FETCH (PILOTBBT PBTHEIGHT) OF BBT)) (BOOL-OP (LET ((COMPLEMENT? (NOT (CL:ZEROP (FETCH (PILOTBBT PBTSOURCETYPE) OF BBT))))) (CL:ECASE (FETCH (PILOTBBT PBTOPERATION) OF BBT) ((0) (CL:IF COMPLEMENT? CL:BOOLE-C1 CL:BOOLE-1)) ((1) (CL:IF COMPLEMENT? CL:BOOLE-ANDC1 CL:BOOLE-AND)) ((2) (CL:IF COMPLEMENT? CL:BOOLE-ORC1 CL:BOOLE-IOR)) ((3) (CL:IF COMPLEMENT? CL:BOOLE-EQV CL:BOOLE-XOR))))) (GRAY? (FETCH (PILOTBBT PBTUSEGRAY) OF BBT)) (GRAY.WIDTH (ITIMES (ADD1 (FETCH (PILOTBBT PBTGRAYWIDTHLESSONE) OF BBT)) 16)) (GRAY.HEIGHT (ADD1 (FETCH (PILOTBBT PBTGRAYHEIGHTLESSONE) OF BBT))) LINE GRAY.BUMP LAST-GRAY Y-FORWARD? X-FORWARD?) (CL:LABELS ((MODIFY-BIT (DSTWORD DSTBIT DSTOFFSET SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (SRCWORD SRCBIT) (BUMP SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (DSTWORD DSTBIT) (BUMP DSTWORD DSTBIT DSTOFFSET) (ADDR-IN-RANGE LOW-WORD-ADDR DSTWORD HI-WORD-ADDR) (CL:SETF (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0)) (CL:BOOLE BOOL-OP (LDB (BYTE 1 (IDIFFERENCE 15 SRCBIT)) (GETBASE SRCWORD 0)) (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0))))))) (BITBLT-ITEM NIL (LET ((OFFSET (CL:IF X-FORWARD? 0 (SUB1 BBT.WIDTH)))) (FRPTQ BBT.WIDTH (LET ((POS (CL:IF GRAY? (IDIFFERENCE (IMOD (IPLUS OFFSET SRC.BIT) (ABS GRAY.WIDTH)) SRC.BIT) OFFSET))) (MODIFY-BIT DST.WORD DST.BIT OFFSET SRC.WORD SRC.BIT POS)) (CL:INCF OFFSET (CL:IF X-FORWARD? 1 -1))))) (SETUP NIL (CL:WHEN GRAY? (SETQ GRAY.BUMP (IMINUS (ITIMES GRAY.WIDTH (SUB1 GRAY.HEIGHT))))) (COMPUTE-DIRECTION) (CL:WHEN GRAY? (SETQ LAST-GRAY (CL:IF Y-FORWARD? (IDIFFERENCE GRAY.HEIGHT 1 (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)) (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)))) (SETQ LINE (CL:IF Y-FORWARD? 0 (SUB1 BBT.HEIGHT)))) (COMPUTE-DIRECTION NIL (SETQ Y-FORWARD? (SETQ X-FORWARD? (NOT (FETCH (PILOTBBT PBTBACKWARD) OF BBT)))))) (SETUP) (WHILE (AND (ILEQ 0 LINE) (ILESSP LINE BBT.HEIGHT)) DO (BITBLT-ITEM) (BLOCK) (* \; "just to be nice.") (CL:MULTIPLE-VALUE-SETQ (SRC.WORD SRC.BIT) (BUMP SRC.WORD SRC.BIT (CL:IF GRAY? (CL:IF (= (IMOD LINE GRAY.HEIGHT) LAST-GRAY) GRAY.BUMP GRAY.WIDTH) SRC.BPL))) (CL:MULTIPLE-VALUE-SETQ (DST.WORD DST.BIT) (BUMP DST.WORD DST.BIT DST.BPL)) (CL:INCF LINE (CL:IF Y-FORWARD? 1 -1)))))) (CL:DEFUN BUMP (WORD BIT INCR) (CL:MULTIPLE-VALUE-BIND (WORD-INCR NEW-BIT) (CL:FLOOR (IPLUS BIT INCR) 16) (CL:VALUES (ADDBASE WORD WORD-INCR) NEW-BIT))) (CL:DEFUN SLOPED-LINES (W) (LET* ((FEEDBACK-INTERVAL (QUOTIENT W 20)) (NEXT-FEEDBACK 0) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (LOW-ADDR (FETCH (ARRAYP BASE) OF A)) (HI-ADDR (\\ADDBASE LOW-ADDR (IQUOTIENT (+ 15 (ITIMES W W)) 16))) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF A) PBTDESTBIT _ 0 PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 0 PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:DOTIMES (SLOPE W) (CL:WHEN (> SLOPE NEXT-FEEDBACK) (CL:PRINC #\. *ERROR-OUTPUT*) (CL:INCF NEXT-FEEDBACK FEEDBACK-INTERVAL)) (CL:FILL DA 0) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH (IPLUS W SLOPE 1)) (CL:INCF (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (REPLACE (PILOTBBT PBTHEIGHT) OF BBT WITH (CL:CEILING W (ADD1 SLOPE))) (\\PILOTBITBLT BBT NIL) (CL:FILL DR 0) (SIMULATE-PILOTBITBLT (CREATE PILOTBBT USING BBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF R)) LOW-ADDR HI-ADDR) (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:CERROR "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" W SLOPE))))) (CL:DEFUN DIAGONALS (W SKIP-SIMULATION SKIP-UCODE) (* |;;| "Draw both diagonals in a square of size W.") (* |;;| "if SKIP-SIMULATION is not NIL, don't bother with the simulation or a consistency check.") (* |;;| "if SKIP-UCODE is not NIL, don't bother with the real microcode version or a consistency check.") (LET* ((FAILURES NIL) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (LOW-ADDR (FETCH (ARRAYP BASE) OF A)) (HI-ADDR (SUB1 (\\ADDBASE LOW-ADDR (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (A-BASE (FETCH (ARRAY-HEADER BASE) OF A)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (R-BASE (FETCH (ARRAY-HEADER BASE) OF R)) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 1 PBTHEIGHT _ W PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:MACROLET ((CLEAR (WHICH) (BQUOTE (CL:FILL (\\\, WHICH) 0)))) (CL:LABELS ((SET-SOURCE (BBT BASE INCREMENT) (CL:MULTIPLE-VALUE-BIND (WORD BIT) (BUMP BASE 0 INCREMENT) (REPLACE (PILOTBBT PBTDEST) OF BBT WITH WORD) (REPLACE (PILOTBBT PBTDESTBIT) OF BBT WITH BIT)) BBT) (CHECK-RESULT (FROM TO START-OFFSET) (CLEAR DR) (CL:UNLESS SKIP-SIMULATION (* |;;| "Only run this if we need the simulation.") (SIMULATE-PILOTBITBLT (SET-SOURCE (CREATE PILOTBBT USING BBT) R-BASE START-OFFSET) LOW-ADDR HI-ADDR)) (CL:UNLESS (OR SKIP-SIMULATION SKIP-UCODE) (* |;;| "Only check the results if we ran both versions.") (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:PUSH (CL:CONCATENATE (QUOTE STRING) FROM " to " TO) FAILURES) (CL:CERROR "Try the next one" "Bad BITBLT: ~A to ~A diagonal w: ~D " FROM TO W)))) (DO-ONE (FROM TO START-OFFSET BPL) (CLEAR DA) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH BPL) (REPLACE (PILOTBBT PBTBACKWARD) OF BBT WITH (ILESSP BPL 0)) (OR SKIP-UCODE (\\PILOTBITBLT (SET-SOURCE BBT A-BASE START-OFFSET) NIL)) (CHECK-RESULT FROM TO START-OFFSET))) (DO-ONE "upper left" "lower right" 0 (ADD1 W)) (DO-ONE "upper right" "lower left" (SUB1 W) (SUB1 W)) (DO-ONE "lower left" "upper right" (ITIMES W (SUB1 W)) (IMINUS (SUB1 W))) (DO-ONE "lower right" "upper left" (SUB1 (ITIMES W W)) (IMINUS (ADD1 W))))) (CL:VALUES (NOT FAILURES) FAILURES))) (DEFINEQ (ADDR-IN-RANGE (LAMBDA (LOW ADDR HI) (* \; "Edited 16-Nov-88 14:32 by jds") (OR (<= (+ (LLSH (HILOC LOW) 16) (LOLOC LOW)) (+ (LLSH (HILOC ADDR) 16) (LOLOC ADDR)) (+ (LLSH (HILOC HI) 16) (LOLOC HI))) (HELP))) ) ) (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN (QUOTE (1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41)) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN (QUOTE (1 3 4 5 7 8 9 15 16 17)) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (CL:DEFUN XCL-USER::COPY.N.TEST (XCL-USER::USE-UFN) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 2 1 :OK -1 -2) (CL:FUNCALL (\\GETUFNENTRY (QUOTE COPY.N)) 4)) ((OPCODES COPY.N 4) 2 1 :OK -1 -2))) (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (CL:DEFUN XCL-USER::STORE.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (STORE.N.TEST NIL) and (STORE.N.TEST T) should return the list (5 4 t 2 1)" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 5 4 3 2 1) (CL:FUNCALL (\\GETUFNENTRY (QUOTE STORE.N)) T 4)) ((OPCODES STORE.N 4) 5 4 3 2 1 T)) ((OPCODES APPLYFN) 5 (QUOTE LIST))) (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (CL:DEFUN XCL-USER::POP.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 4 3 2 1 0) (CL:FUNCALL (\\GETUFNENTRY (QUOTE POP.N)) 2)) ((OPCODES POP.N 2) 4 3 2 1 0))) (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST (QUOTE SUCCESS) (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) (QUOTE (SUCCESS 3.1415927))))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 26-Sep-88 14:11 by bvm") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high| |half| |is| |one's| |complement| |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535))))) ) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ (QUOTE SUCCESS) (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) (BQUOTE (DOFINDKEYTEST1 ((OPCODES FINDKEY (\\\, N)) (QUOTE (\\\, KEY))) (\\\, N) (QUOTE (\\\, KEY)))))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) (BQUOTE (PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS (\\\, N)) ((OPCODES RESTLIST (\\\, N)) NIL KEYARGS) (\\\, N)))))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER ) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) ) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) ) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) ) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) ) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (RPAQQ *NON-CONSTANT-FLOAT-1* 1.0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :INITIAL-CONTENTS (QUOTE (0 1 0 1)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :INITIAL-CONTENTS (QUOTE (0 34 56 255 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 34 255 65535 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 -34 255 -32768 23))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 32)) :INITIAL-CONTENTS (QUOTE (0 -34 258 -65538 2147483647))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (0.0 -34.0 3.456756E+35 -5.768E-34 5.4524))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\Space #\a #\b)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :FATP T :INITIAL-CONTENTS (QUOTE (#\Space #\Greek-0 #\Greek-32))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) (+ *NON-CONSTANT-FLOAT-1* 3.4) (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) (+ *NON-CONSTANT-FLOAT-1* 3.4) (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (* |;;| "The IL:*NON-CONSTANT-FLOAT-1* is there to prevent using a constant float and getting screwed by refcount.") (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE XPOINTER) :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\a #\b #\c #\d))))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS (QUOTE (0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B))))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :READ-ONLY-P T :INITIAL-CONTENTS (QUOTE (0 1 2 3))))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (1 0 1 0)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD) XCL-USER::WORD)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (* |;;| "Boxed opcodes") (RPAQQ *NON-CONSTANT-T* T) (RPAQQ *NON-CONSTANT-0* 0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1 -3 9834756987354 21845 -54))) (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR+ (DO-TEST T-FIRST (EXPECT-ERRORS (T) (+ *NON-CONSTANT-T* 3))) (DO-TEST T-SECOND (EXPECT-ERRORS (T) (+ 3 *NON-CONSTANT-T*)))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 1/3 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 345235424 -45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 4/3 -1345619432 45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR/T (DO-TEST T-DIVISOR (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-T*))) (DO-TEST T-NUMERATOR (EXPECT-ERRORS (T) (/ *NON-CONSTANT-T* 34)))) (DEFTEST ERROR/0 (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-0*))) (DEFTEST NO-ERROR-0/0 (/ *NON-CONSTANT-0* *NON-CONSTANT-0*)) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 -45 345235424 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 22000.0))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1/3 -45 5498457654 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE ((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156)))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 0.0 -45.0 4.6678E+23))) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 3))) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845 1/3 -54.0))) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (1.0 2.0 3.0 4.0)))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR (QUOTE ((1.0 . 3) (1.0 . 1) (3.5 . 3)))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 20.5 1/3 -5.2))) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (2.7182817 -2.0 453.78))) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (11351 11576 (ADDR-IN-RANGE 11361 . 11574)) (13705 20488 (UNWINDTESTER 13715 . 14136) ( UNWINDMAINTEST 14138 . 17146) (UNWINDMAINTEST.RECURSE 17148 . 17317) (UNWINDCHECK1 17319 . 17617) ( UNWINDCHECK2 17619 . 20284) (UNWINDCODE 20286 . 20486)) (20889 24148 (UW2.TEST 20899 . 21330) ( UW2.RECURSE 21332 . 21571) (UW2.TEST.MAIN 21573 . 22230) (UW2.CHECK 22232 . 23840) (UW2.IDENTITY 23842 . 24146)) (24314 25919 (FINDKEYTESTER 24324 . 24538) (DOFINDKEYTEST 24540 . 25420) (DOFINDKEYTEST1 25422 . 25917)) (26209 30598 (\\RESTLIST.SPLICE.FRAME 26219 . 27553) (RESTLISTTESTER 27555 . 28129) ( DORESTLISTTEST 28131 . 28500) (GETRESTARGREFCNTS 28502 . 28723) (DORESTLISTTEST1 28725 . 30596)) ( 31186 36602 (CLOSURETESTER 31196 . 31498) (CLOSUREMAINTEST 31500 . 33501) (CLOSUREMAINTEST.RECURSE 33503 . 33659) (CLOSUREFNCHECK 33661 . 34464) (CLOSUREFNCHECK2 34466 . 34760) (CLOSUREFN1 34762 . 35251) (CLOSUREFN1VALUE 35253 . 35400) (CLOSUREFN2 35402 . 35891) (CLOSUREFN2VALUE 35893 . 36040) ( CLOSUREFN4CODE 36042 . 36456) (CLOSUREFN4VALUE 36458 . 36600)) (36867 38501 (FVARTEST0 36877 . 37084) (FVARTEST1 37086 . 37590) (FVARTEST2 37592 . 38278) (FVARTEST3 38280 . 38499))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ new file mode 100644 index 00000000..f3084829 --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-Nov-88 16:38:34" {ERIS}MAIKO>AUTO>OPCODES.TEST\;9 69113 |changes| |to:| (FUNCTIONS SLOPED-LINES DIAGONALS SIMULATE-PILOTBITBLT BUMP XCL-USER::COPY.N.TEST XCL-USER::STORE.N.TEST XCL-USER::POP.N.TEST) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER) (TESTS ERROR+ ERROR/T ERROR/0 NO-ERROR-0/0) (VARS OPCODESCOMS) (FNS ADDR-IN-RANGE) |previous| |date:| " 8-Nov-88 17:10:36" {ERIS}MAIKO>AUTO>OPCODES.TEST\;7) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ((* |;;| "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (COMS (* \; "BITBLT") (FUNCTIONS SIMULATE-PILOTBITBLT BUMP) (FUNCTIONS SLOPED-LINES DIAGONALS) (FNS ADDR-IN-RANGE) (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (FUNCTIONS XCL-USER::COPY.N.TEST) (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (FUNCTIONS XCL-USER::STORE.N.TEST) (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (FUNCTIONS XCL-USER::POP.N.TEST) (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (VARS (*NON-CONSTANT-FLOAT-1* 1.0)) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (VARS (*NON-CONSTANT-T* T) (*NON-CONSTANT-0* 0)) (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (TESTS ERROR+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (TESTS ERROR/T ERROR/0 NO-ERROR-0/0) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (* \; "BITBLT") (CL:DEFUN SIMULATE-PILOTBITBLT (BBT LOW-WORD-ADDR HI-WORD-ADDR) (* |;;| "A translation of the algorithm in the Mesa PrincOps.") (* |;;| " S-L-O-W !!!") (LET ((SRC.WORD (FETCH (PILOTBBT PBTSOURCE) OF BBT)) (SRC.BIT (FETCH (PILOTBBT PBTSOURCEBIT) OF BBT)) (SRC.BPL (FETCH (PILOTBBT PBTSOURCEBPL) OF BBT)) (DST.WORD (FETCH (PILOTBBT PBTDEST) OF BBT)) (DST.BIT (FETCH (PILOTBBT PBTDESTBIT) OF BBT)) (DST.BPL (FETCH (PILOTBBT PBTDESTBPL) OF BBT)) (BBT.WIDTH (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (BBT.HEIGHT (FETCH (PILOTBBT PBTHEIGHT) OF BBT)) (BOOL-OP (LET ((COMPLEMENT? (NOT (CL:ZEROP (FETCH (PILOTBBT PBTSOURCETYPE) OF BBT))))) (CL:ECASE (FETCH (PILOTBBT PBTOPERATION) OF BBT) ((0) (CL:IF COMPLEMENT? CL:BOOLE-C1 CL:BOOLE-1)) ((1) (CL:IF COMPLEMENT? CL:BOOLE-ANDC1 CL:BOOLE-AND)) ((2) (CL:IF COMPLEMENT? CL:BOOLE-ORC1 CL:BOOLE-IOR)) ((3) (CL:IF COMPLEMENT? CL:BOOLE-EQV CL:BOOLE-XOR))))) (GRAY? (FETCH (PILOTBBT PBTUSEGRAY) OF BBT)) (GRAY.WIDTH (ITIMES (ADD1 (FETCH (PILOTBBT PBTGRAYWIDTHLESSONE) OF BBT)) 16)) (GRAY.HEIGHT (ADD1 (FETCH (PILOTBBT PBTGRAYHEIGHTLESSONE) OF BBT))) LINE GRAY.BUMP LAST-GRAY Y-FORWARD? X-FORWARD?) (CL:LABELS ((MODIFY-BIT (DSTWORD DSTBIT DSTOFFSET SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (SRCWORD SRCBIT) (BUMP SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (DSTWORD DSTBIT) (BUMP DSTWORD DSTBIT DSTOFFSET) (ADDR-IN-RANGE LOW-WORD-ADDR DSTWORD HI-WORD-ADDR) (CL:SETF (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0)) (CL:BOOLE BOOL-OP (LDB (BYTE 1 (IDIFFERENCE 15 SRCBIT)) (GETBASE SRCWORD 0)) (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0))))))) (BITBLT-ITEM NIL (LET ((OFFSET (CL:IF X-FORWARD? 0 (SUB1 BBT.WIDTH)))) (FRPTQ BBT.WIDTH (LET ((POS (CL:IF GRAY? (IDIFFERENCE (IMOD (IPLUS OFFSET SRC.BIT) (ABS GRAY.WIDTH)) SRC.BIT) OFFSET))) (MODIFY-BIT DST.WORD DST.BIT OFFSET SRC.WORD SRC.BIT POS)) (CL:INCF OFFSET (CL:IF X-FORWARD? 1 -1))))) (SETUP NIL (CL:WHEN GRAY? (SETQ GRAY.BUMP (IMINUS (ITIMES GRAY.WIDTH (SUB1 GRAY.HEIGHT))))) (COMPUTE-DIRECTION) (CL:WHEN GRAY? (SETQ LAST-GRAY (CL:IF Y-FORWARD? (IDIFFERENCE GRAY.HEIGHT 1 (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)) (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)))) (SETQ LINE (CL:IF Y-FORWARD? 0 (SUB1 BBT.HEIGHT)))) (COMPUTE-DIRECTION NIL (SETQ Y-FORWARD? (SETQ X-FORWARD? (NOT (FETCH (PILOTBBT PBTBACKWARD) OF BBT)))))) (SETUP) (WHILE (AND (ILEQ 0 LINE) (ILESSP LINE BBT.HEIGHT)) DO (BITBLT-ITEM) (BLOCK) (* \; "just to be nice.") (CL:MULTIPLE-VALUE-SETQ (SRC.WORD SRC.BIT) (BUMP SRC.WORD SRC.BIT (CL:IF GRAY? (CL:IF (= (IMOD LINE GRAY.HEIGHT) LAST-GRAY) GRAY.BUMP GRAY.WIDTH) SRC.BPL))) (CL:MULTIPLE-VALUE-SETQ (DST.WORD DST.BIT) (BUMP DST.WORD DST.BIT DST.BPL)) (CL:INCF LINE (CL:IF Y-FORWARD? 1 -1)))))) (CL:DEFUN BUMP (WORD BIT INCR) (CL:MULTIPLE-VALUE-BIND (WORD-INCR NEW-BIT) (CL:FLOOR (IPLUS BIT INCR) 16) (CL:VALUES (ADDBASE WORD WORD-INCR) NEW-BIT))) (CL:DEFUN SLOPED-LINES (W) (LET* ((FEEDBACK-INTERVAL (QUOTIENT W 20)) (NEXT-FEEDBACK 0) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (LOW-ADDR (FETCH (ARRAY-HEADER BASE) OF R)) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF A) PBTDESTBIT _ 0 PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 0 PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:DOTIMES (SLOPE W) (CL:WHEN (> SLOPE NEXT-FEEDBACK) (CL:PRINC #\. *ERROR-OUTPUT*) (CL:INCF NEXT-FEEDBACK FEEDBACK-INTERVAL)) (CL:FILL DA 0) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH (IPLUS W SLOPE 1)) (CL:INCF (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (REPLACE (PILOTBBT PBTHEIGHT) OF BBT WITH (CL:CEILING W (ADD1 SLOPE))) (\\PILOTBITBLT BBT NIL) (CL:FILL DR 0) (SIMULATE-PILOTBITBLT (CREATE PILOTBBT USING BBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF R)) LOW-ADDR HI-ADDR) (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:CERROR "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" W SLOPE))))) (CL:DEFUN DIAGONALS (W SKIP-SIMULATION SKIP-UCODE) (* |;;| "Draw both diagonals in a square of size W.") (* |;;| "if SKIP-SIMULATION is not NIL, don't bother with the simulation or a consistency check.") (* |;;| "if SKIP-UCODE is not NIL, don't bother with the real microcode version or a consistency check.") (LET* ((FAILURES NIL) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (A-BASE (FETCH (ARRAY-HEADER BASE) OF A)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT 0)) (R-BASE (FETCH (ARRAY-HEADER BASE) OF R)) (LOW-ADDR R-BASE) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE (QUOTE BIT) :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 1 PBTHEIGHT _ W PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:MACROLET ((CLEAR (WHICH) (BQUOTE (CL:FILL (\\\, WHICH) 0)))) (CL:LABELS ((SET-SOURCE (BBT BASE INCREMENT) (CL:MULTIPLE-VALUE-BIND (WORD BIT) (BUMP BASE 0 INCREMENT) (REPLACE (PILOTBBT PBTDEST) OF BBT WITH WORD) (REPLACE (PILOTBBT PBTDESTBIT) OF BBT WITH BIT)) BBT) (CHECK-RESULT (FROM TO START-OFFSET) (CLEAR DR) (CL:UNLESS SKIP-SIMULATION (* |;;| "Only run this if we need the simulation.") (SIMULATE-PILOTBITBLT (SET-SOURCE (CREATE PILOTBBT USING BBT) R-BASE START-OFFSET) LOW-ADDR HI-ADDR)) (CL:UNLESS (OR SKIP-SIMULATION SKIP-UCODE) (* |;;| "Only check the results if we ran both versions.") (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:PUSH (CL:CONCATENATE (QUOTE STRING) FROM " to " TO) FAILURES) (CL:CERROR "Try the next one" "Bad BITBLT: ~A to ~A diagonal w: ~D " FROM TO W)))) (DO-ONE (FROM TO START-OFFSET BPL) (CLEAR DA) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH BPL) (REPLACE (PILOTBBT PBTBACKWARD) OF BBT WITH (ILESSP BPL 0)) (OR SKIP-UCODE (\\PILOTBITBLT (SET-SOURCE BBT A-BASE START-OFFSET) NIL)) (CHECK-RESULT FROM TO START-OFFSET))) (DO-ONE "upper left" "lower right" 0 (ADD1 W)) (DO-ONE "upper right" "lower left" (SUB1 W) (SUB1 W)) (DO-ONE "lower left" "upper right" (ITIMES W (SUB1 W)) (IMINUS (SUB1 W))) (DO-ONE "lower right" "upper left" (SUB1 (ITIMES W W)) (IMINUS (ADD1 W))))) (CL:VALUES (NOT FAILURES) FAILURES))) (DEFINEQ (ADDR-IN-RANGE (LAMBDA (LOW ADDR HI) (* \; "Edited 16-Nov-88 14:32 by jds") (OR (<= (+ (LLSH (HILOC LOW) 16) (LOLOC LOW)) (+ (LLSH (HILOC ADDR) 16) (LOLOC ADDR)) (+ (LLSH (HILOC HI) 16) (LOLOC HI))) (HELP))) ) ) (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN (QUOTE (1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41)) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN (QUOTE (1 3 4 5 7 8 9 15 16 17)) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (CL:DEFUN XCL-USER::COPY.N.TEST (XCL-USER::USE-UFN) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 2 1 :OK -1 -2) (CL:FUNCALL (\\GETUFNENTRY (QUOTE COPY.N)) 4)) ((OPCODES COPY.N 4) 2 1 :OK -1 -2))) (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (CL:DEFUN XCL-USER::STORE.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (STORE.N.TEST NIL) and (STORE.N.TEST T) should return the list (5 4 t 2 1)" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 5 4 3 2 1) (CL:FUNCALL (\\GETUFNENTRY (QUOTE STORE.N)) T 4)) ((OPCODES STORE.N 4) 5 4 3 2 1 T)) ((OPCODES APPLYFN) 5 (QUOTE LIST))) (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL (QUOTE (5 4 T 2 1)) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (CL:DEFUN XCL-USER::POP.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 4 3 2 1 0) (CL:FUNCALL (\\GETUFNENTRY (QUOTE POP.N)) 2)) ((OPCODES POP.N 2) 4 3 2 1 0))) (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST (QUOTE SUCCESS) (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) (QUOTE (SUCCESS 3.1415927))))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 26-Sep-88 14:11 by bvm") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high| |half| |is| |one's| |complement| |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535))))) ) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ (QUOTE SUCCESS) (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) (BQUOTE (DOFINDKEYTEST1 ((OPCODES FINDKEY (\\\, N)) (QUOTE (\\\, KEY))) (\\\, N) (QUOTE (\\\, KEY)))))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) (BQUOTE (PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS (\\\, N)) ((OPCODES RESTLIST (\\\, N)) NIL KEYARGS) (\\\, N)))))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER ) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) ) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) ) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) ) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) ) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (RPAQQ *NON-CONSTANT-FLOAT-1* 1.0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :INITIAL-CONTENTS (QUOTE (0 1 0 1)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 1)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :INITIAL-CONTENTS (QUOTE (0 34 56 255 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 34 255 65535 23)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 16)) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 16)) :INITIAL-CONTENTS (QUOTE (0 -34 255 -32768 23))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE (CL:SIGNED-BYTE 32)) :INITIAL-CONTENTS (QUOTE (0 -34 258 -65538 2147483647))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (0.0 -34.0 3.456756E+35 -5.768E-34 5.4524))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\Space #\a #\b)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :FATP T :INITIAL-CONTENTS (QUOTE (#\Space #\Greek-0 #\Greek-32))))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) (+ *NON-CONSTANT-FLOAT-1* 3.4) (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B)) (+ *NON-CONSTANT-FLOAT-1* 3.4) (QUOTE XCL-USER::C) (CONS (QUOTE XCL-USER::D) (QUOTE XCL-USER::E)))) (* |;;| "The IL:*NON-CONSTANT-FLOAT-1* is there to prevent using a constant float and getting screwed by refcount.") (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE XPOINTER) :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:STRING-CHAR) :INITIAL-CONTENTS (QUOTE (#\a #\b #\c #\d))))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS (QUOTE (0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B))))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE (CL:UNSIGNED-BYTE 8)) :READ-ONLY-P T :INITIAL-CONTENTS (QUOTE (0 1 2 3))))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (2 #\c 2.3 (XCL-USER::A . XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (1 0 1 0)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 4)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 23 255 65535)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 255 -32768)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD) XCL-USER::WORD)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0 -23 65536 -2147483648)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (0.0 -23.0 3.4456E+24 -4.562435E-12)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (QUOTE (#\a #\b #\c #\A)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c (QUOTE XCL-USER::A) (CONS (QUOTE XCL-USER::A) (QUOTE XCL-USER::B))) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))))))))) (* |;;| "Boxed opcodes") (RPAQQ *NON-CONSTANT-T* T) (RPAQQ *NON-CONSTANT-0* 0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1 -3 9834756987354 21845 -54))) (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 -3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR+ (DO-TEST T-FIRST (EXPECT-ERRORS (T) (+ *NON-CONSTANT-T* 3))) (DO-TEST T-SECOND (EXPECT-ERRORS (T) (+ 3 *NON-CONSTANT-T*)))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845.0 -54.0))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1 3 1/3 9834756987354 21845 -54))) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45 1/3 345235424 0 23 21845))) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 345235424 -45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1 4/3 -1345619432 45))) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR/T (DO-TEST T-DIVISOR (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-T*))) (DO-TEST T-NUMERATOR (EXPECT-ERRORS (T) (/ *NON-CONSTANT-T* 34)))) (DEFTEST ERROR/0 (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-0*))) (DEFTEST NO-ERROR-0/0 (/ *NON-CONSTANT-0* *NON-CONSTANT-0*)) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 -45 345235424 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 22000.0))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845 1/3 -45 5498457654 22000))) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE ((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156)))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 0.0 -45.0 4.6678E+23))) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (-1.0 0.0 -45.0 4.6678E+23))) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 -3.0 -3.4028235E+38 21845.0 3))) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (1.0 3.0 3.4028235E+38 21845 1/3 -54.0))) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (45.0 0.0 1.1342745E+38 -21845.0))) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y (QUOTE (21845.0 -45.0 3.4523542E+8 0.001))) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE (QUOTE CL:SINGLE-FLOAT) :INITIAL-CONTENTS (QUOTE (1.0 2.0 3.0 4.0)))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR (QUOTE ((1.0 . 3) (1.0 . 1) (3.5 . 3)))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (0.0 1/3 -1.2 12.6))) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (1.0 20.5 1/3 -5.2))) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X (QUOTE (2.7182817 -2.0 453.78))) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (11344 11569 (ADDR-IN-RANGE 11354 . 11567)) (13698 20481 (UNWINDTESTER 13708 . 14129) ( UNWINDMAINTEST 14131 . 17139) (UNWINDMAINTEST.RECURSE 17141 . 17310) (UNWINDCHECK1 17312 . 17610) ( UNWINDCHECK2 17612 . 20277) (UNWINDCODE 20279 . 20479)) (20882 24141 (UW2.TEST 20892 . 21323) ( UW2.RECURSE 21325 . 21564) (UW2.TEST.MAIN 21566 . 22223) (UW2.CHECK 22225 . 23833) (UW2.IDENTITY 23835 . 24139)) (24307 25912 (FINDKEYTESTER 24317 . 24531) (DOFINDKEYTEST 24533 . 25413) (DOFINDKEYTEST1 25415 . 25910)) (26202 30591 (\\RESTLIST.SPLICE.FRAME 26212 . 27546) (RESTLISTTESTER 27548 . 28122) ( DORESTLISTTEST 28124 . 28493) (GETRESTARGREFCNTS 28495 . 28716) (DORESTLISTTEST1 28718 . 30589)) ( 31179 36595 (CLOSURETESTER 31189 . 31491) (CLOSUREMAINTEST 31493 . 33494) (CLOSUREMAINTEST.RECURSE 33496 . 33652) (CLOSUREFNCHECK 33654 . 34457) (CLOSUREFNCHECK2 34459 . 34753) (CLOSUREFN1 34755 . 35244) (CLOSUREFN1VALUE 35246 . 35393) (CLOSUREFN2 35395 . 35884) (CLOSUREFN2VALUE 35886 . 36033) ( CLOSUREFN4CODE 36035 . 36449) (CLOSUREFN4VALUE 36451 . 36593)) (36860 38494 (FVARTEST0 36870 . 37077) (FVARTEST1 37079 . 37583) (FVARTEST2 37585 . 38271) (FVARTEST3 38273 . 38492))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ new file mode 100644 index 00000000..1913c86b --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-Nov-88 18:02:22" {ERIS}MAIKO>AUTO>OPCODES.TEST\;10 96285 |changes| |to:| (FNS UNWINDTESTER CLOSUREMAINTEST ADDR-IN-RANGE) (FUNCTIONS SLOPED-LINES DIAGONALS SIMULATE-PILOTBITBLT BUMP XCL-USER::COPY.N.TEST XCL-USER::STORE.N.TEST XCL-USER::POP.N.TEST) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER) (TESTS ERROR+ ERROR/T ERROR/0 NO-ERROR-0/0) (VARS OPCODESCOMS) |previous| |date:| "16-Nov-88 16:38:34" {ERIS}MAIKO>AUTO>OPCODES.TEST\;9) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ( (* |;;| "This file contains tests for the various opcodes used in the system.") (VARS (*TEST-FILE-NAME* "OPCODES")) (COMS (* \; "BITBLT") (FUNCTIONS SIMULATE-PILOTBITBLT BUMP) (FUNCTIONS SLOPED-LINES DIAGONALS) (FNS ADDR-IN-RANGE) (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (FUNCTIONS XCL-USER::COPY.N.TEST) (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (FUNCTIONS XCL-USER::STORE.N.TEST) (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (FUNCTIONS XCL-USER::POP.N.TEST) (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (VARS (*NON-CONSTANT-FLOAT-1* 1.0)) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (VARS (*NON-CONSTANT-T* T) (*NON-CONSTANT-0* 0)) (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (TESTS ERROR+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (TESTS ERROR/T ERROR/0 NO-ERROR-0/0) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This file contains tests for the various opcodes used in the system.") (RPAQ *TEST-FILE-NAME* "OPCODES") (* \; "BITBLT") (CL:DEFUN SIMULATE-PILOTBITBLT (BBT LOW-WORD-ADDR HI-WORD-ADDR) (* |;;| "A translation of the algorithm in the Mesa PrincOps.") (* |;;| " S-L-O-W !!!") (LET ((SRC.WORD (FETCH (PILOTBBT PBTSOURCE) OF BBT)) (SRC.BIT (FETCH (PILOTBBT PBTSOURCEBIT) OF BBT)) (SRC.BPL (FETCH (PILOTBBT PBTSOURCEBPL) OF BBT)) (DST.WORD (FETCH (PILOTBBT PBTDEST) OF BBT)) (DST.BIT (FETCH (PILOTBBT PBTDESTBIT) OF BBT)) (DST.BPL (FETCH (PILOTBBT PBTDESTBPL) OF BBT)) (BBT.WIDTH (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (BBT.HEIGHT (FETCH (PILOTBBT PBTHEIGHT) OF BBT)) (BOOL-OP (LET ((COMPLEMENT? (NOT (CL:ZEROP (FETCH (PILOTBBT PBTSOURCETYPE) OF BBT))) )) (CL:ECASE (FETCH (PILOTBBT PBTOPERATION) OF BBT) ((0) (CL:IF COMPLEMENT? CL:BOOLE-C1 CL:BOOLE-1)) ((1) (CL:IF COMPLEMENT? CL:BOOLE-ANDC1 CL:BOOLE-AND)) ((2) (CL:IF COMPLEMENT? CL:BOOLE-ORC1 CL:BOOLE-IOR)) ((3) (CL:IF COMPLEMENT? CL:BOOLE-EQV CL:BOOLE-XOR))))) (GRAY? (FETCH (PILOTBBT PBTUSEGRAY) OF BBT)) (GRAY.WIDTH (ITIMES (ADD1 (FETCH (PILOTBBT PBTGRAYWIDTHLESSONE) OF BBT)) 16)) (GRAY.HEIGHT (ADD1 (FETCH (PILOTBBT PBTGRAYHEIGHTLESSONE) OF BBT))) LINE GRAY.BUMP LAST-GRAY Y-FORWARD? X-FORWARD?) (CL:LABELS ((MODIFY-BIT (DSTWORD DSTBIT DSTOFFSET SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (SRCWORD SRCBIT) (BUMP SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (DSTWORD DSTBIT) (BUMP DSTWORD DSTBIT DSTOFFSET) (ADDR-IN-RANGE LOW-WORD-ADDR DSTWORD HI-WORD-ADDR) (CL:SETF (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0)) (CL:BOOLE BOOL-OP (LDB (BYTE 1 (IDIFFERENCE 15 SRCBIT )) (GETBASE SRCWORD 0)) (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0))))))) (BITBLT-ITEM NIL (LET ((OFFSET (CL:IF X-FORWARD? 0 (SUB1 BBT.WIDTH)))) (FRPTQ BBT.WIDTH (LET ((POS (CL:IF GRAY? (IDIFFERENCE (IMOD (IPLUS OFFSET SRC.BIT) (ABS GRAY.WIDTH)) SRC.BIT) OFFSET))) (MODIFY-BIT DST.WORD DST.BIT OFFSET SRC.WORD SRC.BIT POS) ) (CL:INCF OFFSET (CL:IF X-FORWARD? 1 -1))))) (SETUP NIL (CL:WHEN GRAY? (SETQ GRAY.BUMP (IMINUS (ITIMES GRAY.WIDTH (SUB1 GRAY.HEIGHT))))) (COMPUTE-DIRECTION) (CL:WHEN GRAY? (SETQ LAST-GRAY (CL:IF Y-FORWARD? (IDIFFERENCE GRAY.HEIGHT 1 (FETCH (PILOTBBT PBTGRAYOFFSET ) OF BBT)) (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)))) (SETQ LINE (CL:IF Y-FORWARD? 0 (SUB1 BBT.HEIGHT)))) (COMPUTE-DIRECTION NIL (SETQ Y-FORWARD? (SETQ X-FORWARD? (NOT (FETCH (PILOTBBT PBTBACKWARD) OF BBT)))))) (SETUP) (WHILE (AND (ILEQ 0 LINE) (ILESSP LINE BBT.HEIGHT)) DO (BITBLT-ITEM) (BLOCK) (* \; "just to be nice.") (CL:MULTIPLE-VALUE-SETQ (SRC.WORD SRC.BIT) (BUMP SRC.WORD SRC.BIT (CL:IF GRAY? (CL:IF (= (IMOD LINE GRAY.HEIGHT) LAST-GRAY) GRAY.BUMP GRAY.WIDTH) SRC.BPL))) (CL:MULTIPLE-VALUE-SETQ (DST.WORD DST.BIT) (BUMP DST.WORD DST.BIT DST.BPL)) (CL:INCF LINE (CL:IF Y-FORWARD? 1 -1)))))) (CL:DEFUN BUMP (WORD BIT INCR) (CL:MULTIPLE-VALUE-BIND (WORD-INCR NEW-BIT) (CL:FLOOR (IPLUS BIT INCR) 16) (CL:VALUES (ADDBASE WORD WORD-INCR) NEW-BIT))) (CL:DEFUN SLOPED-LINES (W) (LET* ((FEEDBACK-INTERVAL (QUOTIENT W 20)) (NEXT-FEEDBACK 0) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (LOW-ADDR (FETCH (ARRAY-HEADER BASE) OF R)) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF A) PBTDESTBIT _ 0 PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 0 PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:DOTIMES (SLOPE W) (CL:WHEN (> SLOPE NEXT-FEEDBACK) (CL:PRINC #\. *ERROR-OUTPUT*) (CL:INCF NEXT-FEEDBACK FEEDBACK-INTERVAL)) (CL:FILL DA 0) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH (IPLUS W SLOPE 1)) (CL:INCF (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (REPLACE (PILOTBBT PBTHEIGHT) OF BBT WITH (CL:CEILING W (ADD1 SLOPE))) (\\PILOTBITBLT BBT NIL) (CL:FILL DR 0) (SIMULATE-PILOTBITBLT (CREATE PILOTBBT USING BBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF R)) LOW-ADDR HI-ADDR) (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:CERROR "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" W SLOPE))))) (CL:DEFUN DIAGONALS (W SKIP-SIMULATION SKIP-UCODE) (* |;;| "Draw both diagonals in a square of size W.") (* |;;|  "if SKIP-SIMULATION is not NIL, don't bother with the simulation or a consistency check.") (* |;;|  "if SKIP-UCODE is not NIL, don't bother with the real microcode version or a consistency check.") (LET* ((FAILURES NIL) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (A-BASE (FETCH (ARRAY-HEADER BASE) OF A)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (R-BASE (FETCH (ARRAY-HEADER BASE) OF R)) (LOW-ADDR R-BASE) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 1 PBTHEIGHT _ W PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:MACROLET ((CLEAR (WHICH) `(CL:FILL ,WHICH 0))) (CL:LABELS ((SET-SOURCE (BBT BASE INCREMENT) (CL:MULTIPLE-VALUE-BIND (WORD BIT) (BUMP BASE 0 INCREMENT) (REPLACE (PILOTBBT PBTDEST) OF BBT WITH WORD) (REPLACE (PILOTBBT PBTDESTBIT) OF BBT WITH BIT)) BBT) (CHECK-RESULT (FROM TO START-OFFSET) (CLEAR DR) (CL:UNLESS SKIP-SIMULATION (* |;;| "Only run this if we need the simulation.") (SIMULATE-PILOTBITBLT (SET-SOURCE (CREATE PILOTBBT USING BBT) R-BASE START-OFFSET) LOW-ADDR HI-ADDR)) (CL:UNLESS (OR SKIP-SIMULATION SKIP-UCODE) (* |;;| "Only check the results if we ran both versions.") (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:PUSH (CL:CONCATENATE 'STRING FROM " to " TO) FAILURES) (CL:CERROR "Try the next one" "Bad BITBLT: ~A to ~A diagonal w: ~D " FROM TO W))) ) (DO-ONE (FROM TO START-OFFSET BPL) (CLEAR DA) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH BPL) (REPLACE (PILOTBBT PBTBACKWARD) OF BBT WITH (ILESSP BPL 0)) (OR SKIP-UCODE (\\PILOTBITBLT (SET-SOURCE BBT A-BASE START-OFFSET) NIL)) (CHECK-RESULT FROM TO START-OFFSET))) (DO-ONE "upper left" "lower right" 0 (ADD1 W)) (DO-ONE "upper right" "lower left" (SUB1 W) (SUB1 W)) (DO-ONE "lower left" "upper right" (ITIMES W (SUB1 W)) (IMINUS (SUB1 W))) (DO-ONE "lower right" "upper left" (SUB1 (ITIMES W W)) (IMINUS (ADD1 W))))) (CL:VALUES (NOT FAILURES) FAILURES))) (DEFINEQ (ADDR-IN-RANGE (LAMBDA (LOW ADDR HI) (* \; "Edited 16-Nov-88 14:32 by jds") (OR (<= (+ (LLSH (HILOC LOW) 16) (LOLOC LOW)) (+ (LLSH (HILOC ADDR) 16) (LOLOC ADDR)) (+ (LLSH (HILOC HI) 16) (LOLOC HI))) (HELP))) ) ) (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN '(1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN '(1 3 4 5 7 8 9 15 16 17) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (CL:DEFUN XCL-USER::COPY.N.TEST (XCL-USER::USE-UFN) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 2 1 :OK -1 -2) (CL:FUNCALL (\\GETUFNENTRY 'COPY.N) 4)) ((OPCODES COPY.N 4) 2 1 :OK -1 -2))) (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (CL:DEFUN XCL-USER::STORE.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (STORE.N.TEST NIL) and (STORE.N.TEST T) should return the list (5 4 t 2 1)" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 5 4 3 2 1) (CL:FUNCALL (\\GETUFNENTRY 'STORE.N) T 4)) ((OPCODES STORE.N 4) 5 4 3 2 1 T)) ((OPCODES APPLYFN) 5 'LIST)) (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (CL:DEFUN XCL-USER::POP.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 4 3 2 1 0) (CL:FUNCALL (\\GETUFNENTRY 'POP.N) 2)) ((OPCODES POP.N 2) 4 3 2 1 0))) (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST 'SUCCESS (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) '(SUCCESS 3.1415927)))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 16-Nov-88 18:00 by jds") (|for| D |from| 0 |to| (OR DEPTH 10) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* |;;| "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* 'PREVPREV 'PREVIOUS-VALUE (PROGN (* \;  "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* \; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* \; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* \; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* \; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* \; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* \;  "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* \;  "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) 'PREVIOUS-VALUE)) (* \; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (|for| V |in| '(*B* *C* *D* *E* *F* *G* *H*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V '(*E* *F* *G* *H*))) NIL)) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high|  |half| |is| |one's| |complement|  |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY 'TOS) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\\MYALINK)) (EOS (|fetch| (FX NEXTBLOCK) |of| CALLER)) (GOODEOS (+ (|fetch| (FX FIRSTPVAR) |of| CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (|for| V |in| '(*B* *C* *D* *E*) |bind| SHOULDBEUNBOUNDP |do| (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V '*E*))) (COND ((\\FRAMESCAN CALLER (\\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ 'SUCCESS (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) (FINDKEYCHECK 2 ||) (FINDKEYCHECK 3 ||) (FINDKEYCHECK 4 ||) (FINDKEYCHECK 5 ||) (FINDKEYCHECK 6 ||) (FINDKEYCHECK 7 ||) (FINDKEYCHECK 8 ||) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS |when| (EQ KEY (ARG KEYARGS I)) |do| (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) `(DOFINDKEYTEST1 ((OPCODES FINDKEY ,N) ',KEY) ,N ',KEY))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\\MYALINK)) CALLER2 IVAR BF) (COND ((AND (|fetch| (FX FASTP) |of| CALLER) (EQ (SETQ IVAR (|fetch| (BF IVAR) |of| (SETQ BF (|fetch| (FX DUMMYBF) |of| CALLER)))) (|fetch| (FX NEXTBLOCK) |of| (SETQ CALLER2 (|fetch| (FX ALINK) |of| CALLER))))) (|replace| (BF IVAR) |of| BF |with| (|add| IVAR WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") (AND (DORESTLISTTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC) (DORESTLISTTEST '(||) '(VALA) '(KEYB) 'VALB '(KEYC) '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (|for| R |in| RESULT |as| I |from| N |to| KEYARGS |thereis| (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (|for| I |from| N |to| KEYARGS |collect| (ARG KEYARGS I)))))) (|for| TAIL |on| RESULT |as| CNT |in| REFCNTS |as| I |from| 1 |do| (COND ((AND (NEQ (\\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (|fetch| (MDSTYPEWORD NOREFCNT) |of| (\\ADDBASE |\\MDSTypeTable| (LRSH (|fetch| (POINTER PAGE#) |of| (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\\REFCNT (CAR TAIL))))) ((NEQ (\\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) `(PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS ,N) ((OPCODES RESTLIST ,N) NIL KEYARGS) ,N)))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* \; "Edited 16-Nov-88 18:01 by jds") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD 'CLOSUREFN4 (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN4CODE) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (CL:FUNCALL (GETD 'CLOSUREFN1) 'A 'B 'C)) (CLOSUREFN1VALUE 'A 'B 'C))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CL:FUNCALL (MAKE-COMPILED-CLOSURE (|fetch| (LITATOM DEFPOINTER) |of| 'CLOSUREFN2) CLOSURETEST.ENVIRONMENT) 'A 'B 'C)) (CLOSUREFN2VALUE 'A 'B 'C))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) (COND (CLOSUREP (COND ((NEQ (\\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) ) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) ) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) ) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) ) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (RPAQQ *NON-CONSTANT-FLOAT-1* 1.0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) :INITIAL-CONTENTS '(0 1 0 1))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :INITIAL-CONTENTS '(0 34 56 255 23))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) :INITIAL-CONTENTS '(0 34 255 65535 23))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 16) :INITIAL-CONTENTS '(0 -34 255 -32768 23)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 32) :INITIAL-CONTENTS '(0 -34 258 -65538 2147483647)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS '(0.0 -34.0 3.456756E+35 -5.768E-34 5.4524)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS '(#\Space #\a #\b))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :FATP T :INITIAL-CONTENTS '(#\Space #\Greek-0 #\Greek-32)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) (+ *NON-CONSTANT-FLOAT-1* 3.4) 'XCL-USER::C (CONS 'XCL-USER::D 'XCL-USER::E))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) (+ *NON-CONSTANT-FLOAT-1* 3.4) 'XCL-USER::C (CONS 'XCL-USER::D 'XCL-USER::E))) (* |;;| "The IL:*NON-CONSTANT-FLOAT-1* is there to prevent using a constant float and getting screwed by refcount.") (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'XPOINTER :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS '(#\a #\b #\c #\d)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS '(0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B)))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :READ-ONLY-P T :INITIAL-CONTENTS '(0 1 2 3)))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 4) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 65535) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 255 -32768) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 65536 -2147483648) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(1 0 1 0) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 4) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 65535) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 255 -32768) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD ) XCL-USER::WORD))))) ))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 65536 -2147483648) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1 )))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))) )))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A 'XCL-USER::B) ) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A 'XCL-USER::B) ) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))) )))))))) (* |;;| "Boxed opcodes") (RPAQQ *NON-CONSTANT-T* T) (RPAQQ *NON-CONSTANT-0* 0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1 -3 9834756987354 21845 -54)) (CL:DOLIST (XCL-USER::Y '(1 -3 9834756987354 21845 -54)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 -54.0)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 -3 1/3 9834756987354 21845 -54)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR+ (DO-TEST T-FIRST (EXPECT-ERRORS (T) (+ *NON-CONSTANT-T* 3))) (DO-TEST T-SECOND (EXPECT-ERRORS (T) (+ 3 *NON-CONSTANT-T*)))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 9834756987354 21845 -54)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845.0 -54.0)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 1/3 9834756987354 21845 -54)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 345235424 0 23 21845)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 1/3 345235424 0 23 21845)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 345235424 -45)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 4/3 -1345619432 45)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR/T (DO-TEST T-DIVISOR (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-T*))) (DO-TEST T-NUMERATOR (EXPECT-ERRORS (T) (/ *NON-CONSTANT-T* 34)))) (DEFTEST ERROR/0 (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-0*))) (DEFTEST NO-ERROR-0/0 (/ *NON-CONSTANT-0* *NON-CONSTANT-0*)) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 -45 345235424 22000)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 22000.0)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1/3 -45 5498457654 22000)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 0.0 -45.0 4.6678E+23)) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 3)) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ( (* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845 1/3 -54.0)) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS '(1.0 2.0 3.0 4.0))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR '((1.0 . 3) (1.0 . 1) (3.5 . 3))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 20.5 1/3 -5.2)) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(2.7182817 -2.0 453.78)) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (20412 20637 (ADDR-IN-RANGE 20422 . 20635)) (23316 30084 (UNWINDTESTER 23326 . 23732) ( UNWINDMAINTEST 23734 . 26742) (UNWINDMAINTEST.RECURSE 26744 . 26913) (UNWINDCHECK1 26915 . 27213) ( UNWINDCHECK2 27215 . 29880) (UNWINDCODE 29882 . 30082)) (31160 34419 (UW2.TEST 31170 . 31601) ( UW2.RECURSE 31603 . 31842) (UW2.TEST.MAIN 31844 . 32501) (UW2.CHECK 32503 . 34111) (UW2.IDENTITY 34113 . 34417)) (34608 36213 (FINDKEYTESTER 34618 . 34832) (DOFINDKEYTEST 34834 . 35714) (DOFINDKEYTEST1 35716 . 36211)) (36767 41156 (\\RESTLIST.SPLICE.FRAME 36777 . 38111) (RESTLISTTESTER 38113 . 38687) ( DORESTLISTTEST 38689 . 39058) (GETRESTARGREFCNTS 39060 . 39281) (DORESTLISTTEST1 39283 . 41154)) ( 42086 47428 (CLOSURETESTER 42096 . 42398) (CLOSUREMAINTEST 42400 . 44327) (CLOSUREMAINTEST.RECURSE 44329 . 44485) (CLOSUREFNCHECK 44487 . 45290) (CLOSUREFNCHECK2 45292 . 45586) (CLOSUREFN1 45588 . 46077) (CLOSUREFN1VALUE 46079 . 46226) (CLOSUREFN2 46228 . 46717) (CLOSUREFN2VALUE 46719 . 46866) ( CLOSUREFN4CODE 46868 . 47282) (CLOSUREFN4VALUE 47284 . 47426)) (47708 49342 (FVARTEST0 47718 . 47925) (FVARTEST1 47927 . 48431) (FVARTEST2 48433 . 49119) (FVARTEST3 49121 . 49340))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/Aux/BBTESTS b/internal/test/Maiko/Aux/BBTESTS new file mode 100644 index 00000000..cb5e0f21 --- /dev/null +++ b/internal/test/Maiko/Aux/BBTESTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "24-Jun-88 15:18:43" {eris}malpha>bbtests.\;7 12836 |changes| |to:| (functions diagonals simulate-pilotbitblt bump sloped-lines test-diagonals) (vars bbtestscoms) |previous| |date:| "15-Jun-88 19:04:55" {eris}malpha>bbtests.\;2) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint bbtestscoms) (rpaqq bbtestscoms ((functions simulate-pilotbitblt bump) (functions sloped-lines diagonals) (prop filetype bbtests))) (cl:defun simulate-pilotbitblt (bbt) (* |;;| "A translation of the algorithm in the Mesa PrincOps.") (* |;;| " S-L-O-W !!!") (let ((src.word (fetch (pilotbbt pbtsource) of bbt)) (src.bit (fetch (pilotbbt pbtsourcebit) of bbt)) (src.bpl (fetch (pilotbbt pbtsourcebpl) of bbt)) (dst.word (fetch (pilotbbt pbtdest) of bbt)) (dst.bit (fetch (pilotbbt pbtdestbit) of bbt)) (dst.bpl (fetch (pilotbbt pbtdestbpl) of bbt)) (bbt.width (fetch (pilotbbt pbtwidth) of bbt)) (bbt.height (fetch (pilotbbt pbtheight) of bbt)) (bool-op (let ((complement? (not (cl:zerop (fetch (pilotbbt pbtsourcetype) of bbt))) )) (cl:ecase (fetch (pilotbbt pbtoperation) of bbt) ((0) (cl:if complement? cl:boole-c1 cl:boole-1)) ((1) (cl:if complement? cl:boole-andc1 cl:boole-and)) ((2) (cl:if complement? cl:boole-orc1 cl:boole-ior)) ((3) (cl:if complement? cl:boole-eqv cl:boole-xor))))) (gray? (fetch (pilotbbt pbtusegray) of bbt)) (gray.width (itimes (add1 (fetch (pilotbbt pbtgraywidthlessone) of bbt)) 16)) (gray.height (add1 (fetch (pilotbbt pbtgrayheightlessone) of bbt))) line gray.bump last-gray y-forward? x-forward?) (cl:labels ((modify-bit (dstword dstbit dstoffset srcword srcbit srcoffset) (cl:multiple-value-bind (srcword srcbit) (bump srcword srcbit srcoffset) (cl:multiple-value-bind (dstword dstbit) (bump dstword dstbit dstoffset) (cl:setf (ldb (byte 1 (idifference 15 dstbit)) (getbase dstword 0)) (cl:boole bool-op (ldb (byte 1 (idifference 15 srcbit )) (getbase srcword 0)) (ldb (byte 1 (idifference 15 dstbit)) (getbase dstword 0))))))) (bitblt-item nil (let ((offset (cl:if x-forward? 0 (sub1 bbt.width)))) (frptq bbt.width (let ((pos (cl:if gray? (idifference (imod (iplus offset src.bit) (abs gray.width)) src.bit) offset))) (modify-bit dst.word dst.bit offset src.word src.bit pos) ) (cl:incf offset (cl:if x-forward? 1 -1))))) (setup nil (cl:when gray? (setq gray.bump (iminus (itimes gray.width (sub1 gray.height))))) (compute-direction) (cl:when gray? (setq last-gray (cl:if y-forward? (idifference gray.height 1 (fetch (pilotbbt pbtgrayoffset ) of bbt)) (fetch (pilotbbt pbtgrayoffset) of bbt)))) (setq line (cl:if y-forward? 0 (sub1 bbt.height)))) (compute-direction nil (setq y-forward? (setq x-forward? (not (fetch (pilotbbt pbtbackward) of bbt)))))) (setup) (while (and (ileq 0 line) (ilessp line bbt.height)) do (bitblt-item) (block) (* \; "just to be nice.") (cl:multiple-value-setq (src.word src.bit) (bump src.word src.bit (cl:if gray? (cl:if (= (imod line gray.height) last-gray) gray.bump gray.width) src.bpl))) (cl:multiple-value-setq (dst.word dst.bit) (bump dst.word dst.bit dst.bpl)) (cl:incf line (cl:if y-forward? 1 -1)))))) (cl:defun bump (word bit incr) (cl:multiple-value-bind (word-incr new-bit) (cl:floor (iplus bit incr) 16) (cl:values (addbase word word-incr) new-bit))) (cl:defun sloped-lines (w) (let* ((feedback-interval (quotient w 20)) (next-feedback 0) (black #16*1) (a (cl:make-array (list w w) :element-type 'bit :initial-element 0)) (da (cl:make-array (itimes w w) :element-type 'bit :displaced-to a)) (r (cl:make-array (list w w) :element-type 'bit :initial-element 0)) (dr (cl:make-array (itimes w w) :element-type 'bit :displaced-to r)) (bbt (create pilotbbt pbtdest _ (fetch (array-header base) of a) pbtdestbit _ 0 pbtsource _ (fetch (array-header base) of black) pbtsourcebit _ 0 pbtgrayoffset _ 0 pbtgraywidthlessone _ 0 pbtgrayheightlessone _ 0 pbtwidth _ 0 pbtdisjoint _ t pbtusegray _ t))) (cl:dotimes (slope w) (cl:when (> slope next-feedback) (cl:princ #\. *error-output*) (cl:incf next-feedback feedback-interval)) (cl:fill da 0) (replace (pilotbbt pbtdestbpl) of bbt with (iplus w slope 1)) (cl:incf (fetch (pilotbbt pbtwidth) of bbt)) (replace (pilotbbt pbtheight) of bbt with (cl:ceiling w (add1 slope))) (\\pilotbitblt bbt nil) (cl:fill dr 0) (simulate-pilotbitblt (create pilotbbt using bbt pbtdest _ (fetch (array-header base) of r))) (cl:when (not (cl:equal da dr)) (cl:cerror "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" w slope))))) (cl:defun diagonals (w) (* |;;| "Draw both diagonals in a square of size W.") (let* ((failures nil) (black #16*1) (a (cl:make-array (list w w) :element-type 'bit :initial-element 0)) (a-base (fetch (array-header base) of a)) (da (cl:make-array (itimes w w) :element-type 'bit :displaced-to a)) (r (cl:make-array (list w w) :element-type 'bit :initial-element 0)) (r-base (fetch (array-header base) of r)) (dr (cl:make-array (itimes w w) :element-type 'bit :displaced-to r)) (bbt (create pilotbbt pbtsource _ (fetch (array-header base) of black) pbtsourcebit _ 0 pbtgrayoffset _ 0 pbtgraywidthlessone _ 0 pbtgrayheightlessone _ 0 pbtwidth _ 1 pbtheight _ w pbtdisjoint _ t pbtusegray _ t))) (cl:macrolet ((clear (which) `(cl:fill ,which 0))) (cl:labels ((set-source (bbt base increment) (cl:multiple-value-bind (word bit) (bump base 0 increment) (replace (pilotbbt pbtdest) of bbt with word) (replace (pilotbbt pbtdestbit) of bbt with bit)) bbt) (check-result (from to start-offset) (clear dr) (simulate-pilotbitblt (set-source (create pilotbbt using bbt) r-base start-offset)) (cl:when (not (cl:equal da dr)) (cl:push (cl:concatenate 'string from " to " to) failures) (cl:cerror "Try the next one" "Bad BITBLT: ~A to ~A diagonal w: ~D " from to w))) (do-one (from to start-offset bpl) (clear da) (replace (pilotbbt pbtdestbpl) of bbt with bpl) (replace (pilotbbt pbtbackward) of bbt with (ilessp bpl 0)) (\\pilotbitblt (set-source bbt a-base start-offset) nil) (check-result from to start-offset))) (do-one "upper left" "lower right" 0 (add1 w)) (do-one "upper right" "lower left" (sub1 w) (sub1 w)) (do-one "lower left" "upper right" (itimes w (sub1 w)) (iminus (sub1 w))) (do-one "lower right" "upper left" (sub1 (itimes w w)) (iminus (add1 w))))) (cl:values (not failures) failures))) (putprops bbtests filetype :compile-file) (putprops bbtests copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil))) stop \ No newline at end of file diff --git a/internal/test/Maiko/Aux/BBTESTS.DFASL b/internal/test/Maiko/Aux/BBTESTS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..36a75527ecbf6f294a6c4736283700f34a1080ab GIT binary patch literal 4196 zcmai2TWnk99ska;V>^kRx@{;)sa9(PiALCKL!lQ+=VSZ0KK8kIKF74tD$-osI<|?k zkZ>84rF3XFkCB$k`6l3jhiNa9N;hfbRzEOl1QEfY(wgph(jNBEikC?f^M3zxoVK(u zr1*UQ+xI{J@B3d*=9&LkQjH|*PfShJO4E`0?99~cOyp#JI`U+Fc6zK7ISG2?Ik}*i zrw^qhU6EDuuqLVbjC44Wuw>IRV~_0XGH($cn=Xyal*S|J>51`?XCH_R?u}$;Crgn% z2lnrOAhPG7gM0QL+&dWSN=v5ds{iI42M!KC9P4VmWxp==*BN7{oWE|yHg6UP?_?~@ zM8STo(UVqGIa!b;OHQdqQe^h88{q-dlJt~RNJSMrU$h47MtDzTral#|m7Xfq=(taa z&|<&R2&9X8(oziFJ}=CPcR^t|C8rf#j*?z%PaECP=r!`PE(Wl{XA~`{>;TxAQVO!O zS=?-&_krTiOUaycM7A59if+jTRWb7<2=h{wlu*I&;Qm4KCL~i133kKxoIYEton|;H zyW2e`9S}!t(t0-?)NX7Zyv_V4!DHM*Rtw#*+7FxZ1tag-3Z%R3sidKqUf`W{mK1Kt zq#N_Mx#A}KJQR2wf%Yw!KzdC@E2@x=<`vbj5{i{jEzrG*qLzm|zZ*!1yKU4KKFY_-;_>vPJ2BP}>j zMti)jpa{_Cf}X{!vnSi$lU;PA1CR)~5}iwx_=ll*YrZ@;u?*<@D_Z56t)8oS&(y>V z`?RWq1kcob7Y4MN=wLl(YW@p5w3_GI8xZU~Qwuc8U(QURf@$lrNQsdz$6paI*|XxS3fE@=9j4N3E`3UB5&+*tPkIx$?Nf zg%|`bZZpDMtwKi

>v4=rF?bl^1i>^_BAQmS#n}KHS?hde0fXKh<(yTqiTm8C${? zvM>{E1`v{&RhC&5q3>-?4KZf)wC42}@#;ART9K5F0s-%3P$Uu{Vvjeo>dW3H;N1}L zH8q$~J@Z8C^2)od(~S2)QgA|>0;b_XxCY4Se?mCq!|j_6cYqIf-11rX@uUJqJAChJC`C;;|tf z(|IhxV~2R`J|5f7V?8_;;4zUle`KHcGC}kZ{1?FVwzO;|Gxm9r$AAU%2@6?LkemYZ zT0=C_pwfW^O2p9dyj92)_1vD_BHu?QP9nY^&#b~LKgp~Hs_P4QE|!WOWErB;)Uh^=E7yFCEadDM-@xfyfB^WR#G+0 zVnKF_;6r?15GBteB}{Pnp*V~hPo`wofeVVTsEEQ+TuQivWmQ;FMd4Dlwn<-y9SEz; zY6w`4ul)#4 zEbuCNvf$~(D}0YhYEd>j`7R%skX8+&;3&VxeqA8H|2AIh{o8w$g?PNYeY@KP@T_!o zFt!+vU%f%e5@qQtq?T`$Qb`I`BD+e?pm+cfZk|BRM4B60C`q?e)az4~z|>^yhVYs1Yr?5SMR zjh-()f9GBHdtLebEi&(DA8xa$WG*k{Dg+r}yfUs=5gMq$|5)>YLY5NwgFyANa{#ic zcMV3ig|A@eS|`x*Q%%iLLq$!+(R=CW2KjGz%kVZ>;%ub@wLv1o7|psBnf?q_t8>9 z)&~$3G_4F0p#U*2TBJ&dY@cfc%%rTKsUETC(e;nX1>;y0ZCo>Sv|2MyV$^;+l)PFr z3G3!VvN4=AKbIXNm73ewPFK0LsO`|w9%KjJZ3>h5v^nl^bo8}*Lb^mmAT z*k$i^m;2piv$L>ece&^;zjK$jd91`wj1MRVXjP@qOLSMPw}afjf3Oc@IvgSzanHBbs-vXqU9gny;x7P(>OzfSc<} zcrh|TKfaxg)=ApF zhlVpdHHFWhTIu8rQ652etks_eWqRUN*&%%kBv40QXBhF`oBzJtvj}{f8C*+ z{quGU*gH2Pl$ZGgg`hJlbZ*QF`+WQ~nOby5VfHd+E2r9FD1*0??Scs`S-}ifovVBt zqPZ=I`5{sBkOO;AA>#|uVgi8@a`v8}@gazt$Gnki3sE_QZisv|Uk;-MDYQ3Bqw1=- z9f2a=hzKPMuTyYS5BH^vsG-Z4EWGXh?L}iu7YxmAh?ZgF)4`GoR&=9xdlGroM~?gj zKRSh!>`oeb67^BXZ;1Eh_%VqOb?_n2DKLGeg&KE6<|l$Y<_unQw^fE0Bz!4F@Vu== zJpUC{p$fxDnz>iHm%C;-_q+8Lg#EjXID88?ACoHW@#npauz+#E`9@Hvr_jfOLLG&G zEV^vmnQSnpL`|buNXnisjSMsm!VLNxbiNwV9H>l+?g-++(7A)hw(=MzG3V{yb(VSh zT-;0!Avd*Gde8s+P!zkU{j@(6%??M=t4!>qZ@O(@btaAcP(eA8v8Xtr`;?~Z&)|Or m(^K{7k(r75Bn5#$VfvEdqMvAESa7Q1xTbxCMaa4?Y4q^>hzJ+sZNmcF zaIKaGZLGt4zFw6-Z0>MEm9NQL`&>!pn-x)~d4fw2+o#2U?cabTkzzR!41~ ztU(@Ly7~#^H`dqjr&!8ADHV%sy28n|Xu>}atd|NKYk)yJUE7# z)3tY+9$vePTg3n5r78`ftW-t8|3aNo3IC%vT@`W?SKi}xc|uXXm%`w=hRoN=5C5|_ zRTiZKR$#+K{#k4n=dEm?-_z;0ZwToQy1&)F&V*~cz)beC{EW$xAce!JfWn#K=OwXy zu2B)FMgOapIo#zH{NV+qelYO>??{V#^SE&*8l4Q%goN?#Vsre$kW*2}SygMhJ!l!` z3EN{G&33|+!#Sta6tY^u5;#9<`wft){Jk(FW&8 zgJ?P!X3J1D7M>f<5v;^CK&aMMq1jWfR+Uw-j|^8=!O|Sp>Oo1|8%kzmMXd89${>k> z^4sV4^@Pso6Ue3ZJGi1pfPL>`qqE8M^#s;u5OQ%0D}Z6)c84_Dwva{(t$zGsb|fl&=Ye+Iq)!V5JC;!GQwgSBGTNk|@Q& z9&Vp6jku2SxecFQ^xPuD<6kryEsrr;2r|?x(j= (LENGTH FIRSTWORD) 3) (STRING= (SUBSEQ FIRSTWORD 0 3) "DEF")) (IL:* IL:|;;| "Each definition is of the form (s . f) where s is the name of the symbol being defined and f is the file name. ") (PUSH (CONS (FORMAT NIL "~a" (LET ((NAME (SECOND FORM))) (IF (CONSP NAME) (CAR NAME) NAME))) FN) DEFS))))) (NREVERSE DEFS)))) (DEFUN XREF-OUTPUT (DEFS OUTPUT-STREAM) (DOLIST (DEF DEFS) (FORMAT OUTPUT-STREAM "~a~50t~a~%" (CAR DEF) (CDR DEF)))) (DEFVAR XREF-READTABLE (LET ((RT (COPY-READTABLE NIL))) (SET-SYNTAX-FROM-CHAR #\: #\_ RT))) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS new file mode 100644 index 00000000..d1fb8840 --- /dev/null +++ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 4-Aug-88 18:06:52" {ERIS}MAIKO>HAND>MAIKO-ARRAY-TESTS.\;9 30433 |changes| |to:| (FUNCTIONS USER::POINTER-ARRAY-TESTS) |previous| |date:| "22-Jun-88 13:52:22" {ERIS}MAIKO>HAND>MAIKO-ARRAY-TESTS.\;8) (PRETTYCOMPRINT MAIKO-ARRAY-TESTSCOMS) (RPAQQ MAIKO-ARRAY-TESTSCOMS ( (* |;;| "Tests for AREF & ASET in Maiko") (* |;;| "TO DO: Extendable arrays, Adjustable arrays, extend past 2**15 and make sure contents are still there. Vectors, strings.") (* |;;| "Main test invokation function:") (FNS MAIKO-ARRAY-TESTS) (* |;;| "1-dimensional array tests:") (FUNCTIONS USER::BIT-ARRAY-TESTS USER::BYTE-ARRAY-TESTS USER::CHAR-ARRAY-TESTS USER::FLOAT-ARRAY-TESTS USER::POINTER-ARRAY-TESTS USER::XPOINTER-ARRAY-TESTS) (* |;;| "Simple AREF & ASET of 1-, 2-, 3-d # arrays:") (FNS SIMPLE-AREF-ASET-TESTS NEQP) (* |;;| "Test of past known failures") (FUNCTIONS USER::PAST-ARRAY-FAILURE-CASES) (* |;;| "Assure that we compile with CL:COMPILE-FILE:") (PROPS (MAIKO-ARRAY-TESTS FILETYPE)))) (* |;;| "Tests for AREF & ASET in Maiko") (* |;;| "TO DO: Extendable arrays, Adjustable arrays, extend past 2**15 and make sure contents are still there. Vectors, strings." ) (* |;;| "Main test invokation function:") (DEFINEQ (MAIKO-ARRAY-TESTS (LAMBDA (LIMIT) (* \; "Edited 22-Jun-88 13:51 by jds") (* |;;| "Main entry point to the Maiko array op-code tests.") (|for| I |from| 1 |to| LIMIT |do| (PRINTOUT T T "Starting Maiko array op-code tests, iteration #" I T) (USER::BIT-ARRAY-TESTS 2) (USER::BYTE-ARRAY-TESTS 2) (USER::CHAR-ARRAY-TESTS 2) (USER::FLOAT-ARRAY-TESTS 2) (USER::POINTER-ARRAY-TESTS 2) (USER::XPOINTER-ARRAY-TESTS 2) (PRINTOUT T " Starting #-array aref/set tests for 1-3 dims." ) (SIMPLE-AREF-ASET-TESTS) (USER::PAST-ARRAY-FAILURE-CASES 1)))) ) (* |;;| "1-dimensional array tests:") (CL:DEFUN USER::BIT-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting bit-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 1))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))))) )) (CL:DEFUN USER::BYTE-ARRAY-TESTS (USER::LIMIT) (* |;;| "Tests of byte arrays, for bytes of length 1, 8, 16, and 32 bits.") (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting byte-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::BYTE-LEN IN '(1 8 16 32) AS USER::MAX-VALUE IN '(2 256 65535 65535) DO (CL:FORMAT T " Byte length = ~D~%" USER::BYTE-LEN) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE (LIST 'CL:UNSIGNED-BYTE USER::BYTE-LEN ) :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE (LIST 'CL:UNSIGNED-BYTE USER::BYTE-LEN) :INITIAL-ELEMENT 1))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (CL:REM USER::I USER::MAX-VALUE)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (CL:REM USER::I USER::MAX-VALUE)) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I))))))))) (CL:DEFUN USER::CHAR-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting bit-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'CL:CHARACTER :INITIAL-ELEMENT #\D)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'CL:CHARACTER :INITIAL-ELEMENT (CL:INT-CHAR (CHARCODE "41,133" ))))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (NEQ (CL:AREF USER::ZERO-ARRAY USER::I) #\D) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (NEQ (CL:AREF USER::ONE-ARRAY USER::I) (CL:INT-CHAR (CHARCODE "41,133"))) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))))))) (CL:DEFUN USER::FLOAT-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting FLOAT-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'FLOAT :INITIAL-ELEMENT 0.0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'FLOAT :INITIAL-ELEMENT 1.0))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0.0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1.0) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN) ))) (CL:ERROR "SIN pattern fails at ~D.~%" USER::I)))) (* |;;| "Just create 1000 of floats into the array, and read them out, so we can run STORAGE later to see if they leaked.") (CL:DO ((USER::I 0 (CL:1+ USER::I)) (CL:ELT (RAND 0 (CL:1- USER::LEN)) (RAND 0 (CL:1- USER::LEN)))) ((= USER::I 1000)) (CL:SETF (CL:AREF USER::ZERO-ARRAY CL:ELT) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY CL:ELT) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:ERROR "SIN pattern fails at ~D.~%" USER::I))))))) (CL:DEFUN USER::POINTER-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting pointer-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :INITIAL-ELEMENT 1)) (USER::GC-ITEM (CREATE FMTSPEC)) USER::OLD-REFCNT) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))) (* |;;|  "Make sure that putting a pointer to something into an array adds to the refcount.") (ERSETQ (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (OR (EQ (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (CL:ERROR "Filling array with GC sample item failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) (CL:1+ USER::OLD-REFCNT)) (CL:ERROR "ASET doesn't bump ref-count at ~D.~%" USER::I))) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) NIL) (OR (NOT (CL:AREF USER::ZERO-ARRAY USER::I)) (CL:ERROR "Filling array with NIL failed at ~D.~%" USER::I )) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) (CL:1- USER::OLD-REFCNT)) (CL:ERROR "ASET to NIL doesn't decrement ref-count at ~D.~%" USER::I)))))))) (CL:DEFUN USER::XPOINTER-ARRAY-TESTS (USER::LIMIT) (* |;;| "Tests of arrays of XPOINTERs.") (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting xpointer-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'XPOINTER :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'XPOINTER :INITIAL-ELEMENT 1)) (USER::GC-ITEMS (LIST (CREATE FMTSPEC) 100000 3.55 (CONS 3 4) (COMPLEX 3.4 5) 4/5 #'(CL:LAMBDA (USER::X) (CL:PRINT (USER::DATE USER::X))) (CL:MAKE-ARRAY 5))) USER::GC-ITEM USER::OLD-REFCNT) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))) (* |;;|  "Make sure that putting a pointer to something into an array adds to the refcount.") (FOR USER::GC-ITEM IN USER::GC-ITEMS DO (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (OR (EQ (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (CL:ERROR "Filling array with GC sample item failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) USER::OLD-REFCNT) (CL:ERROR "ASET bumps ref-count at ~D.~%" USER::I))) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) NIL) (OR (NOT (CL:AREF USER::ZERO-ARRAY USER::I)) (CL:ERROR "Filling array with NIL failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) USER::OLD-REFCNT) (CL:ERROR "ASET to NIL decrements ref-count at ~D.~%" USER::I))))))))) (* |;;| "Simple AREF & ASET of 1-, 2-, 3-d # arrays:") (DEFINEQ (SIMPLE-AREF-ASET-TESTS (LAMBDA NIL (* \; "Edited 9-Jun-88 19:02 by jds") (* |;;| "Just run thru AREF and ASET on simple 1- 2- and 3-d arrays of numbers and make sure they look reasonable.") (LET ((|array1d| (CL:MAKE-ARRAY '(10) :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (|array2d| (CL:MAKE-ARRAY '(3 10) :INITIAL-CONTENTS '((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29)))) (|array3d| (CL:MAKE-ARRAY '(2 3 10) :INITIAL-CONTENTS '(((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29)) ((100 101 102 103 104 105 106 107 108 109) (110 111 112 113 114 115 116 117 118 119) (120 121 122 123 124 125 126 127 128 129))))) (|array1d-0| (CL:MAKE-ARRAY '(10) :INITIAL-ELEMENT "ASDF")) (|array2d-0| (CL:MAKE-ARRAY '(3 10) :INITIAL-ELEMENT 3.5)) (|array3d-0| (CL:MAKE-ARRAY '(2 3 10) :INITIAL-ELEMENT '|array3d-0|))) (* |;;| " 1 d array ref") (|for| \i |from| 0 |to| 9 |do| (NEQP \i (CL:AREF |array1d| \i) '(CL:AREF |array1d| \i))) (* |;;| " 2 d array ref") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (+ (TIMES \j 10) \i) (CL:AREF |array2d| \j \i) '(CL:AREF |array2d| \j \i)))) (* |;;| "3 d aref") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (+ (TIMES \k 100) (TIMES \j 10) \i) (CL:AREF |array3d| \k \j \i) '(CL:AREF |array3d| \k \j \i))))) (* |;;| "1 d array set") (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array1d-0| \i) (DIFFERENCE 10 \i))) (* |;;| "1 d array ref") (|for| \i |from| 0 |to| 9 |do| (NEQP (DIFFERENCE 10 \i) (CL:AREF |array1d-0| \i) '(CL:AREF |array1d-0| \i))) (* |;;| "2 d array set") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array2d-0| \j \i) (PLUS \j (TIMES \i 10))))) (* |;;| "2 d aref") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (PLUS \j (TIMES \i 10)) (CL:AREF |array2d-0| \j \i) '(CL:AREF |array2d-0| \j \i)))) (* |;;| " 3 d array set") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array3d-0| \k \j \i) (PLUS \k (TIMES \j 10) (TIMES \i 100)))))) (* |;;| "3 d aref") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (PLUS \k (TIMES \j 10) (TIMES \i 100)) (CL:AREF |array3d-0| \k \j \i) '(CL:AREF |array3d-0| \k \j \i)))))))) (NEQP (LAMBDA (A B ERROR-MSG) (* \; "Edited 12-Jun-88 18:13 by sybalsky") (* |;;| "if the two numbers A and B are not equal then halt with error message ERROR-MSG") (OR (EQP A B) (ERROR ERROR-MSG)))) ) (* |;;| "Test of past known failures") (CL:DEFUN USER::PAST-ARRAY-FAILURE-CASES (USER::LIMIT) (* |;;| "Repository for past known failure cases, gleened from hand tests, ARs, and failed runs of this test suite.") (CL:FORMAT T " Starting test of past failure syndromes.~%") (LET ((CL:ARRAY (CL:MAKE-ARRAY 57296 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :INITIAL-ELEMENT 1))) (CL:FORMAT T " Test of array of 57296 (unsigned-byte 8)s inited to 1s.~%") (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I 57295)) (CL:WHEN (CL:/= (CL:AREF CL:ARRAY USER::I) 1) (CL:ERROR "Array of ones wasn't 1 at element ~D.~%" USER::I))))) (* |;;| "Assure that we compile with CL:COMPILE-FILE:") (PUTPROPS MAIKO-ARRAY-TESTS FILETYPE :COMPILE-FILE) (PUTPROPS MAIKO-ARRAY-TESTS COPYRIGHT (NONE)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2075 3392 (MAIKO-ARRAY-TESTS 2085 . 3390)) (24410 29486 (SIMPLE-AREF-ASET-TESTS 24420 . 29219) (NEQP 29221 . 29484))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e097e6ea26f0c36629ae702d335a7ef9545f2314 GIT binary patch literal 10388 zcmb_iYj9h~b-wq4Pf4Tzl7c9TrmrcQq9B4IDVloPAqavZBoIphpeWIrVQ2voK!AWs zfR-&sHmxX*GsVPu*eY&nJ5D`qnr0@3CXH=LvC*Vhai=8jnp+ z9Sf+(Ay*%9c%0rddwmYC@4i8s^8mYVz~=4~QLD}4u^q8ep0{n!u2tT=ddH>$?cCX_cI@2Ue$VcXuC`VEHm^%G_DL#rwD0cR)wXKx zxzuH4LrjvS6Z~(rB$-SyrOPGBC@FI4nPg?Z)8(*x95$b$&&BMDlzJ*@w0M0OfX&lq zb-IU!eU?I{NZ@3YV%KESu79*cq#SdIF?JN#nN$)Iv(|_ljGrl8lRpDsK;Vas6oTyNW>GN zNJLEp15<%ERXr3qmWWM3Z9Fj*ik^tK<@(ToE=AP@I*k537z>XlLb0fNd^&oJBD+(U z6pYHy@AhiuT%EcOt3Nauh{jQ3JR-WxRm4%g6y?jai^Q9{m|WZI^yN=&>Ov}6H0*VF zkZ0^Y;&bF@YIl>=K49}Kk(&Bl%(g%iFI+vu_|jQYzUFY@ob2px^@b)-V#f17QS7+d zVQp1A@qfG3uWr&m2Zm+P?!>^%UgzKtmO0h2(nl3IM^2I3ad0R%LmO!YsL;kgRyZ0v zg*hD$Mev#8m{M&MMp-*#^Ja(BZ*#haJr1iKI=vWHwvVm0IRCVX;CMnkMW2`xlX@zY z2GZY=)PGblR!vPqoKx9Av<+6xEIUoN^z~wc{P&7>C z_lIY%rN1gEwEAQxnCF>fvCBE=^l4^;B*_G1{3&3X@@6(fd}MQJy+j>39(jD#sMa;C zZ97PHhdfSq$AGrASF`NZwsdPP?b>FG*4%`=67UYP@6`5f(DoU%0ZDPClG{|(n;4%; z04(YzD+eXP>iD*JAR(4Ihj)i{y9y}8+iFlHSAnBkhXpwFSj-;~bz0R>A}}Q&wh8mt zoVr|k7Q=a@=UVW3@Y})H!mqpc-@JH5o(R#DxU-}-R>`M!%$Ny|RpEb4h8YcG<_t4m zWahJ1#LROSgXs=d%bH%Em^=Rk>MLua@6PHV3NI8jg=bMK{rzAa zRGux}AO){h=WDNF&Cq^!k@g)EtSS8S4=;pgCa9fPGNQGduwWZ+#)`WNZB2ZJ^@b)jMv4a$zr$p>;qPh!#C`4TZilxZBQ|4Ze^{;U}u*U@G%rHtkam* zyiOJiSSCp7%est~!CoxqVu#1WJV;3&Xu}k|DT1evSJKZsgEk*Y&mvhdXgi>jXG|M8 zik=pEV8v^-L!?dmFLa_>49l870Bw+Re@{Dd25?#HbUS@co6G8OIR+hW-)ZPIfUr*? zZ;dXq5`Ro+qbIcc{n}B!V7pVvddDG$dk6%Vz>*g12FsIBAMI;<^lob5-Bfb3#loTi z9X_YV5IA3Rd_+D!ER@KO0$0H6A)0 zQ13QoLHfqZKsvJ&q>}_v0lKOj*3AOzwSZt9hasyqj5TCf!$sBrtXpJ=nK@syUIwxN zy?Vkrl@!2cRl&Nt9N^U@a)J6ry#oyb^-Uc0oj|?7Wo*m>)VF3>D{By_S6S;k>RUPL z8zIV}UWi(O`c{GZCZPTff%gEjvpt>5%Nd7!WrThrN#p57E z$ssLB!4{EY7O?$^b_hc0J#B=7>mqnjJ3OWx(s3&HYey*WS0Z>@8>Q4=K=GsEr#Tg zRMJdH?tM5BP$Plp2{<=7C>P0qFHl^h&>$uJ%;kW*H6O^Rd>bUUq%Ieel0A!&Y*`VK zrC%&Tvh?1v=9Y}(Qi~hC>;88ml^|HCCVc(MM4 zC3KVgs%|dV6F3*(WzJLxFEsOjx>H2-^i+$AV-(SwO zOn$NN|Jk~1(XGq>EMAkpT+y18UtF>#q>rr>>S5b}J&ML7jqyQZ&n-r5ALMn5nx9($>SDfo&jOmd^*MmrNd0*!m8?VGmv<%Q zFQ4miuKjx|`?*{Uo3z{1+M6ren2kyQv@!zu+jF0qfwPU?es85z@||<2#j8HG9Gj5d z&+--~dEwhqOKYCJ6Q?0!XS$s0YDrx#MgV9M3A&2-oo5v1T})Eg9A_zujz^cRX7- z_Uc&6yyGcEEr4T-a6Hv{$8%o0nOUIyD~q&ayV)|o-E868O|+I1W+A_z4dSqZZE)vS z37`#D53<5gb0fKsc4TF&9xRq^iq&ULv}l6rv4-$$!G>SSslz_JC#x@*r%vNkwm{X5 zf~v0Pk6{62eRQh;WqtJBe4p72>cW;5KJ$=Lg}5otceWJrolUeF*9zj9!-lo=C=Sx> zZrakyzZT-3aJsojk~f6pPv<4y5R&urlF!UX5AaOsmm-)I!SmXogfUO$Re=NXvvi<;$ z=J_TT2SYgJnZ|ZDZv!mfOeLH9aSBUkNCKz)*p5`tSs?BK@=L#-N;dIUvg#k0o;;}* z*8In*WJdwb`|N6boS$i86FXU`5uB&rcHjQfl~Lr|D<#I%a&&lG`olqX?u_kZEQHhU zsoQw`TXh0FznB0YTM+>&dzKKO(o%o`#lHJv4%iCQAz_vNM+}jox@;l}=A?Ly6e$K5 zU@I^FEzh0Z@SX&BKD3D4=&0^D;LbaRZzi~tviu7Hk z%AEBDZwANOxLu&uH?a1rQRR8wdRK;Z!7f}#?}2@&WnG-GyIy83Sr+Z$_MwHdXqNbd ztP2LBE0g}t1b(>^aA-GiXI6>e&f6+@6U^BL3nNCLDj33*xqBBT(b$y0hk z6AMT*OP=w<9H+FcggtTMn!JOnC)Qj>rTnkIDQ(W&o;KzB715>)qq4H&&i9t1O`7Ic za2Z{rRZA43fp2fU?r7xUuUiO!+vC|W+O6l3$iFH3w1 zj*pAz=2N>H#i@~(o+zT@6Y1-pKi6|a`_j3d7lix|&h;GIzMXQOKP$;kyl`6{&%a!G z=o1jROuD~`C1%v`yKoXOdj71oEp@pG*@iOWO7JfQa6Ny^6cj;;sib(qB$v1&cZRtKmAK#E#@@X68D#O6jevD&l`1*%j~4GV|~BpnB=vrfew*h z$y8TYvs%=t&7|K&9V1h-b?Q-6y>Wo4xoKc33aXj(Kcb+CHD+gGKay3fDLWILE|Xl% z8clKyYck2}SR=A90F!LS@oqCH-16_#YBjER_+`;wvPMK2GwGM0XFY4ns-+38W$jtD zcd<4kpvXm$`3Y`E<#w9jHbmOQ1aDxS`UEGSq>goEC-^9m8(BBki3#o-G|Ba>(o&=EvQ8Aom+Z#W)4GsV*28wP-E1$rk52A*->X?STIkHq!$a;;4Z({w~9`qsE#0IiGXk~rKLvsV7xj{;^f&6bg0KEg5^joYS zk$!5j50So1`UOd$J54#HY@%R7X`~>ms0fN}?d`jEDs+#{qdSy_Y_wasBOAR(sn15c zl#QI>uPSvsyaua9P`nPyMd4K(oKtvBp{r)Db31<$!lRwIS<|H*{2q-<+p$p)bxnF* zqn=)?m)^Ncsmw-qDyy>59m*QL;A%ar&=r*P@VZi_%S&~6iJmToigNCNZ}(f<75=P) zCp#%gPd7wv2PNskxl}LA-^++ZrymbxvN;`oZ5xpyzlEOB9FOyD&A({v7?|?UV9+9Z zA3%u@P^W0fHSDFtX<}3|Qgp#+I_&VU!&VU5Aah&k-3t{7@h<;>qGeni4r@rOT+9RM z7SDeN66vd2`=r)>P#fvfM!L0;7Hy5bWIK0CuR z8@JC}%?r&Ii-7n4=Qx%Z>V*RSd!7GY^56f!3RTviinv>*1#iG(74-dCtqYDrKi>Wu#Q zow*A^HA@a)y}&m^r&!B^%_thhHJ-fI-?)rK3jLmRY_673K!*hW`r zM~imASF-VITRf4$g>YQeFNZr8-1O2-aziS)7gs~s_cR=t^swfh9i6+n)s|^ILOKx* z_^l7n-OMAIKO>HAND>MAIKO-ARRAY-TESTS.\;8 30798 |changes| |to:| (FNS MAIKO-ARRAY-TESTS SIMPLE-AREF-ASET-TESTS) (FUNCTIONS USER::BYTE-ARRAY-TESTS USER::CHAR-ARRAY-TESTS USER::FLOAT-ARRAY-TESTS USER::XPOINTER-ARRAY-TESTS USER::PAST-ARRAY-FAILURE-CASES USER::POINTER-ARRAY-TESTS USER::BIT-ARRAY-TESTS) (VARS MAIKO-ARRAY-TESTSCOMS) |previous| |date:| "12-Jun-88 18:13:25" {ERIS}MAIKO>HAND>MAIKO-ARRAY-TESTS.\;7) (PRETTYCOMPRINT MAIKO-ARRAY-TESTSCOMS) (RPAQQ MAIKO-ARRAY-TESTSCOMS ( (* |;;| "Tests for AREF & ASET in Maiko") (* |;;| "TO DO: Extendable arrays, Adjustable arrays, extend past 2**15 and make sure contents are still there. Vectors, strings.") (* |;;| "Main test invokation function:") (FNS MAIKO-ARRAY-TESTS) (* |;;| "1-dimensional array tests:") (FUNCTIONS USER::BIT-ARRAY-TESTS USER::BYTE-ARRAY-TESTS USER::CHAR-ARRAY-TESTS USER::FLOAT-ARRAY-TESTS USER::POINTER-ARRAY-TESTS USER::XPOINTER-ARRAY-TESTS) (* |;;| "Simple AREF & ASET of 1-, 2-, 3-d # arrays:") (FNS SIMPLE-AREF-ASET-TESTS NEQP) (* |;;| "Test of past known failures") (FUNCTIONS USER::PAST-ARRAY-FAILURE-CASES) (* |;;| "Assure that we compile with CL:COMPILE-FILE:") (PROPS (MAIKO-ARRAY-TESTS FILETYPE)))) (* |;;| "Tests for AREF & ASET in Maiko") (* |;;| "TO DO: Extendable arrays, Adjustable arrays, extend past 2**15 and make sure contents are still there. Vectors, strings." ) (* |;;| "Main test invokation function:") (DEFINEQ (MAIKO-ARRAY-TESTS (LAMBDA (LIMIT) (* \; "Edited 22-Jun-88 13:51 by jds") (* |;;| "Main entry point to the Maiko array op-code tests.") (|for| I |from| 1 |to| LIMIT |do| (PRINTOUT T T "Starting Maiko array op-code tests, iteration #" I T) (USER::BIT-ARRAY-TESTS 2) (USER::BYTE-ARRAY-TESTS 2) (USER::CHAR-ARRAY-TESTS 2) (USER::FLOAT-ARRAY-TESTS 2) (USER::POINTER-ARRAY-TESTS 2) (USER::XPOINTER-ARRAY-TESTS 2) (PRINTOUT T " Starting #-array aref/set tests for 1-3 dims." ) (SIMPLE-AREF-ASET-TESTS) (USER::PAST-ARRAY-FAILURE-CASES 1)))) ) (* |;;| "1-dimensional array tests:") (CL:DEFUN USER::BIT-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting bit-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 1))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))))) )) (CL:DEFUN USER::BYTE-ARRAY-TESTS (USER::LIMIT) (* |;;| "Tests of byte arrays, for bytes of length 1, 8, 16, and 32 bits.") (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting byte-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::BYTE-LEN IN '(1 8 16 32) AS USER::MAX-VALUE IN '(2 256 65535 65535) DO (CL:FORMAT T " Byte length = ~D~%" USER::BYTE-LEN) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE (LIST 'CL:UNSIGNED-BYTE USER::BYTE-LEN ) :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE (LIST 'CL:UNSIGNED-BYTE USER::BYTE-LEN) :INITIAL-ELEMENT 1))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (CL:REM USER::I USER::MAX-VALUE)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (CL:REM USER::I USER::MAX-VALUE)) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I))))))))) (CL:DEFUN USER::CHAR-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting bit-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'CL:CHARACTER :INITIAL-ELEMENT #\D)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'CL:CHARACTER :INITIAL-ELEMENT (CL:INT-CHAR (CHARCODE "41,133" ))))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (NEQ (CL:AREF USER::ZERO-ARRAY USER::I) #\D) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (NEQ (CL:AREF USER::ONE-ARRAY USER::I) (CL:INT-CHAR (CHARCODE "41,133"))) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))))))) (CL:DEFUN USER::FLOAT-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting FLOAT-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'FLOAT :INITIAL-ELEMENT 0.0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'FLOAT :INITIAL-ELEMENT 1.0))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0.0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1.0) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN) ))) (CL:ERROR "SIN pattern fails at ~D.~%" USER::I)))) (* |;;| "Just create 1000 of floats into the array, and read them out, so we can run STORAGE later to see if they leaked.") (CL:DO ((USER::I 0 (CL:1+ USER::I)) (CL:ELT (RAND 0 (CL:1- USER::LEN)) (RAND 0 (CL:1- USER::LEN)))) ((= USER::I 1000)) (CL:SETF (CL:AREF USER::ZERO-ARRAY CL:ELT) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY CL:ELT) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:ERROR "SIN pattern fails at ~D.~%" USER::I))))))) (CL:DEFUN USER::POINTER-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting pointer-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :INITIAL-ELEMENT 1)) (USER::GC-ITEM (CREATE FMTSPEC)) USER::OLD-REFCNT) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))) (* |;;|  "Make sure that putting a pointer to something into an array adds to the refcount.") (ERSETQ (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (OR (EQ (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (CL:ERROR "Filling array with GC sample item failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) (CL:1+ USER::OLD-REFCNT)) (CL:ERROR "ASET doesn't bump ref-count at ~D.~%" USER::I))) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) NIL) (OR (NOT (CL:AREF USER::ZERO-ARRAY USER::I)) (CL:ERROR "Filling array with NIL failed at ~D.~%" USER::I )) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) (CL:1+ USER::OLD-REFCNT)) (CL:ERROR "ASET to NIL doesn't decrement ref-count at ~D.~%" USER::I)))))))) (CL:DEFUN USER::XPOINTER-ARRAY-TESTS (USER::LIMIT) (* |;;| "Tests of arrays of XPOINTERs.") (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting xpointer-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'XPOINTER :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'XPOINTER :INITIAL-ELEMENT 1)) (USER::GC-ITEMS (LIST (CREATE FMTSPEC) 100000 3.55 (CONS 3 4) (COMPLEX 3.4 5) 4/5 #'(CL:LAMBDA (USER::X) (CL:PRINT (USER::DATE USER::X))) (CL:MAKE-ARRAY 5))) USER::GC-ITEM USER::OLD-REFCNT) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))) (* |;;|  "Make sure that putting a pointer to something into an array adds to the refcount.") (FOR USER::GC-ITEM IN USER::GC-ITEMS DO (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (OR (EQ (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (CL:ERROR "Filling array with GC sample item failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) USER::OLD-REFCNT) (CL:ERROR "ASET bumps ref-count at ~D.~%" USER::I))) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) NIL) (OR (NOT (CL:AREF USER::ZERO-ARRAY USER::I)) (CL:ERROR "Filling array with NIL failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) USER::OLD-REFCNT) (CL:ERROR "ASET to NIL decrements ref-count at ~D.~%" USER::I))))))))) (* |;;| "Simple AREF & ASET of 1-, 2-, 3-d # arrays:") (DEFINEQ (SIMPLE-AREF-ASET-TESTS (LAMBDA NIL (* \; "Edited 9-Jun-88 19:02 by jds") (* |;;| "Just run thru AREF and ASET on simple 1- 2- and 3-d arrays of numbers and make sure they look reasonable.") (LET ((|array1d| (CL:MAKE-ARRAY '(10) :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (|array2d| (CL:MAKE-ARRAY '(3 10) :INITIAL-CONTENTS '((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29)))) (|array3d| (CL:MAKE-ARRAY '(2 3 10) :INITIAL-CONTENTS '(((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29)) ((100 101 102 103 104 105 106 107 108 109) (110 111 112 113 114 115 116 117 118 119) (120 121 122 123 124 125 126 127 128 129))))) (|array1d-0| (CL:MAKE-ARRAY '(10) :INITIAL-ELEMENT "ASDF")) (|array2d-0| (CL:MAKE-ARRAY '(3 10) :INITIAL-ELEMENT 3.5)) (|array3d-0| (CL:MAKE-ARRAY '(2 3 10) :INITIAL-ELEMENT '|array3d-0|))) (* |;;| " 1 d array ref") (|for| \i |from| 0 |to| 9 |do| (NEQP \i (CL:AREF |array1d| \i) '(CL:AREF |array1d| \i))) (* |;;| " 2 d array ref") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (+ (TIMES \j 10) \i) (CL:AREF |array2d| \j \i) '(CL:AREF |array2d| \j \i)))) (* |;;| "3 d aref") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (+ (TIMES \k 100) (TIMES \j 10) \i) (CL:AREF |array3d| \k \j \i) '(CL:AREF |array3d| \k \j \i))))) (* |;;| "1 d array set") (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array1d-0| \i) (DIFFERENCE 10 \i))) (* |;;| "1 d array ref") (|for| \i |from| 0 |to| 9 |do| (NEQP (DIFFERENCE 10 \i) (CL:AREF |array1d-0| \i) '(CL:AREF |array1d-0| \i))) (* |;;| "2 d array set") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array2d-0| \j \i) (PLUS \j (TIMES \i 10))))) (* |;;| "2 d aref") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (PLUS \j (TIMES \i 10)) (CL:AREF |array2d-0| \j \i) '(CL:AREF |array2d-0| \j \i)))) (* |;;| " 3 d array set") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array3d-0| \k \j \i) (PLUS \k (TIMES \j 10) (TIMES \i 100)))))) (* |;;| "3 d aref") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (PLUS \k (TIMES \j 10) (TIMES \i 100)) (CL:AREF |array3d-0| \k \j \i) '(CL:AREF |array3d-0| \k \j \i)))))))) (NEQP (LAMBDA (A B ERROR-MSG) (* \; "Edited 12-Jun-88 18:13 by sybalsky") (* |;;| "if the two numbers A and B are not equal then halt with error message ERROR-MSG") (OR (EQP A B) (ERROR ERROR-MSG)))) ) (* |;;| "Test of past known failures") (CL:DEFUN USER::PAST-ARRAY-FAILURE-CASES (USER::LIMIT) (* |;;| "Repository for past known failure cases, gleened from hand tests, ARs, and failed runs of this test suite.") (CL:FORMAT T " Starting test of past failure syndromes.~%") (LET ((CL:ARRAY (CL:MAKE-ARRAY 57296 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :INITIAL-ELEMENT 1))) (CL:FORMAT T " Test of array of 57296 (unsigned-byte 8)s inited to 1s.~%") (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I 57295)) (CL:WHEN (CL:/= (CL:AREF CL:ARRAY USER::I) 1) (CL:ERROR "Array of ones wasn't 1 at element ~D.~%" USER::I))))) (* |;;| "Assure that we compile with CL:COMPILE-FILE:") (PUTPROPS MAIKO-ARRAY-TESTS FILETYPE :COMPILE-FILE) (PUTPROPS MAIKO-ARRAY-TESTS COPYRIGHT (NONE)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2440 3757 (MAIKO-ARRAY-TESTS 2450 . 3755)) (24775 29851 (SIMPLE-AREF-ASET-TESTS 24785 . 29584) (NEQP 29586 . 29849))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ new file mode 100644 index 00000000..d1fb8840 --- /dev/null +++ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 4-Aug-88 18:06:52" {ERIS}MAIKO>HAND>MAIKO-ARRAY-TESTS.\;9 30433 |changes| |to:| (FUNCTIONS USER::POINTER-ARRAY-TESTS) |previous| |date:| "22-Jun-88 13:52:22" {ERIS}MAIKO>HAND>MAIKO-ARRAY-TESTS.\;8) (PRETTYCOMPRINT MAIKO-ARRAY-TESTSCOMS) (RPAQQ MAIKO-ARRAY-TESTSCOMS ( (* |;;| "Tests for AREF & ASET in Maiko") (* |;;| "TO DO: Extendable arrays, Adjustable arrays, extend past 2**15 and make sure contents are still there. Vectors, strings.") (* |;;| "Main test invokation function:") (FNS MAIKO-ARRAY-TESTS) (* |;;| "1-dimensional array tests:") (FUNCTIONS USER::BIT-ARRAY-TESTS USER::BYTE-ARRAY-TESTS USER::CHAR-ARRAY-TESTS USER::FLOAT-ARRAY-TESTS USER::POINTER-ARRAY-TESTS USER::XPOINTER-ARRAY-TESTS) (* |;;| "Simple AREF & ASET of 1-, 2-, 3-d # arrays:") (FNS SIMPLE-AREF-ASET-TESTS NEQP) (* |;;| "Test of past known failures") (FUNCTIONS USER::PAST-ARRAY-FAILURE-CASES) (* |;;| "Assure that we compile with CL:COMPILE-FILE:") (PROPS (MAIKO-ARRAY-TESTS FILETYPE)))) (* |;;| "Tests for AREF & ASET in Maiko") (* |;;| "TO DO: Extendable arrays, Adjustable arrays, extend past 2**15 and make sure contents are still there. Vectors, strings." ) (* |;;| "Main test invokation function:") (DEFINEQ (MAIKO-ARRAY-TESTS (LAMBDA (LIMIT) (* \; "Edited 22-Jun-88 13:51 by jds") (* |;;| "Main entry point to the Maiko array op-code tests.") (|for| I |from| 1 |to| LIMIT |do| (PRINTOUT T T "Starting Maiko array op-code tests, iteration #" I T) (USER::BIT-ARRAY-TESTS 2) (USER::BYTE-ARRAY-TESTS 2) (USER::CHAR-ARRAY-TESTS 2) (USER::FLOAT-ARRAY-TESTS 2) (USER::POINTER-ARRAY-TESTS 2) (USER::XPOINTER-ARRAY-TESTS 2) (PRINTOUT T " Starting #-array aref/set tests for 1-3 dims." ) (SIMPLE-AREF-ASET-TESTS) (USER::PAST-ARRAY-FAILURE-CASES 1)))) ) (* |;;| "1-dimensional array tests:") (CL:DEFUN USER::BIT-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting bit-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 1))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))))) )) (CL:DEFUN USER::BYTE-ARRAY-TESTS (USER::LIMIT) (* |;;| "Tests of byte arrays, for bytes of length 1, 8, 16, and 32 bits.") (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting byte-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::BYTE-LEN IN '(1 8 16 32) AS USER::MAX-VALUE IN '(2 256 65535 65535) DO (CL:FORMAT T " Byte length = ~D~%" USER::BYTE-LEN) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE (LIST 'CL:UNSIGNED-BYTE USER::BYTE-LEN ) :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE (LIST 'CL:UNSIGNED-BYTE USER::BYTE-LEN) :INITIAL-ELEMENT 1))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (CL:REM USER::I USER::MAX-VALUE)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (CL:REM USER::I USER::MAX-VALUE)) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I))))))))) (CL:DEFUN USER::CHAR-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting bit-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'CL:CHARACTER :INITIAL-ELEMENT #\D)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'CL:CHARACTER :INITIAL-ELEMENT (CL:INT-CHAR (CHARCODE "41,133" ))))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (NEQ (CL:AREF USER::ZERO-ARRAY USER::I) #\D) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (NEQ (CL:AREF USER::ONE-ARRAY USER::I) (CL:INT-CHAR (CHARCODE "41,133"))) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))))))) (CL:DEFUN USER::FLOAT-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting FLOAT-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'FLOAT :INITIAL-ELEMENT 0.0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'FLOAT :INITIAL-ELEMENT 1.0))) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0.0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1.0) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN) ))) (CL:ERROR "SIN pattern fails at ~D.~%" USER::I)))) (* |;;| "Just create 1000 of floats into the array, and read them out, so we can run STORAGE later to see if they leaked.") (CL:DO ((USER::I 0 (CL:1+ USER::I)) (CL:ELT (RAND 0 (CL:1- USER::LEN)) (RAND 0 (CL:1- USER::LEN)))) ((= USER::I 1000)) (CL:SETF (CL:AREF USER::ZERO-ARRAY CL:ELT) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY CL:ELT) (CL:SIN (CL:* USER::I (/ 3.1415927 USER::LEN)))) (CL:ERROR "SIN pattern fails at ~D.~%" USER::I))))))) (CL:DEFUN USER::POINTER-ARRAY-TESTS (USER::LIMIT) (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting pointer-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :INITIAL-ELEMENT 1)) (USER::GC-ITEM (CREATE FMTSPEC)) USER::OLD-REFCNT) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))) (* |;;|  "Make sure that putting a pointer to something into an array adds to the refcount.") (ERSETQ (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (OR (EQ (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (CL:ERROR "Filling array with GC sample item failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) (CL:1+ USER::OLD-REFCNT)) (CL:ERROR "ASET doesn't bump ref-count at ~D.~%" USER::I))) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) NIL) (OR (NOT (CL:AREF USER::ZERO-ARRAY USER::I)) (CL:ERROR "Filling array with NIL failed at ~D.~%" USER::I )) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) (CL:1- USER::OLD-REFCNT)) (CL:ERROR "ASET to NIL doesn't decrement ref-count at ~D.~%" USER::I)))))))) (CL:DEFUN USER::XPOINTER-ARRAY-TESTS (USER::LIMIT) (* |;;| "Tests of arrays of XPOINTERs.") (FOR USER::LOOP-NO FROM 1 TO USER::LIMIT COLLECT (CL:FORMAT T " Starting xpointer-array tests, iteration ~D~%" USER::LOOP-NO) (FOR USER::MIN-LENGTH IN '(1 9 17 33 32768) AS USER::MAX-LENGTH IN '(8 16 32 32767 65535) DO (LET* ((USER::LEN (RAND USER::MIN-LENGTH USER::MAX-LENGTH)) (USER::ZERO-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'XPOINTER :INITIAL-ELEMENT 0)) (USER::ONE-ARRAY (CL:MAKE-ARRAY USER::LEN :ELEMENT-TYPE 'XPOINTER :INITIAL-ELEMENT 1)) (USER::GC-ITEMS (LIST (CREATE FMTSPEC) 100000 3.55 (CONS 3 4) (COMPLEX 3.4 5) 4/5 #'(CL:LAMBDA (USER::X) (CL:PRINT (USER::DATE USER::X))) (CL:MAKE-ARRAY 5))) USER::GC-ITEM USER::OLD-REFCNT) (CL:FORMAT T " Array size = ~D~%" USER::LEN) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) 0) (CL:ERROR "**Zero-array wasn't zero at element ~d.~%" USER::I)) (CL:WHEN (CL:/= (CL:AREF USER::ONE-ARRAY USER::I) 1) (CL:ERROR "**One-array wasn't one at element ~d.~%" USER::I)))) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:WHEN (CL:/= (CL:AREF USER::ZERO-ARRAY USER::I) (COND ((EVENP USER::I) 1) (T 0))) (CL:ERROR "EVENP pattern fails at ~D.~%" USER::I)))) (* |;;|  "Make sure that putting a pointer to something into an array adds to the refcount.") (FOR USER::GC-ITEM IN USER::GC-ITEMS DO (CL:SETQ USER::OLD-REFCNT (\\REFCNT USER::GC-ITEM)) (ERSETQ (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (OR (EQ (CL:AREF USER::ZERO-ARRAY USER::I) USER::GC-ITEM) (CL:ERROR "Filling array with GC sample item failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) USER::OLD-REFCNT) (CL:ERROR "ASET bumps ref-count at ~D.~%" USER::I))) (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I USER::LEN)) (CL:SETF (CL:AREF USER::ZERO-ARRAY USER::I) NIL) (OR (NOT (CL:AREF USER::ZERO-ARRAY USER::I)) (CL:ERROR "Filling array with NIL failed at ~D.~%" USER::I)) (CL:WHEN (CL:/= (\\REFCNT USER::GC-ITEM) USER::OLD-REFCNT) (CL:ERROR "ASET to NIL decrements ref-count at ~D.~%" USER::I))))))))) (* |;;| "Simple AREF & ASET of 1-, 2-, 3-d # arrays:") (DEFINEQ (SIMPLE-AREF-ASET-TESTS (LAMBDA NIL (* \; "Edited 9-Jun-88 19:02 by jds") (* |;;| "Just run thru AREF and ASET on simple 1- 2- and 3-d arrays of numbers and make sure they look reasonable.") (LET ((|array1d| (CL:MAKE-ARRAY '(10) :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))) (|array2d| (CL:MAKE-ARRAY '(3 10) :INITIAL-CONTENTS '((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29)))) (|array3d| (CL:MAKE-ARRAY '(2 3 10) :INITIAL-CONTENTS '(((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29)) ((100 101 102 103 104 105 106 107 108 109) (110 111 112 113 114 115 116 117 118 119) (120 121 122 123 124 125 126 127 128 129))))) (|array1d-0| (CL:MAKE-ARRAY '(10) :INITIAL-ELEMENT "ASDF")) (|array2d-0| (CL:MAKE-ARRAY '(3 10) :INITIAL-ELEMENT 3.5)) (|array3d-0| (CL:MAKE-ARRAY '(2 3 10) :INITIAL-ELEMENT '|array3d-0|))) (* |;;| " 1 d array ref") (|for| \i |from| 0 |to| 9 |do| (NEQP \i (CL:AREF |array1d| \i) '(CL:AREF |array1d| \i))) (* |;;| " 2 d array ref") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (+ (TIMES \j 10) \i) (CL:AREF |array2d| \j \i) '(CL:AREF |array2d| \j \i)))) (* |;;| "3 d aref") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (+ (TIMES \k 100) (TIMES \j 10) \i) (CL:AREF |array3d| \k \j \i) '(CL:AREF |array3d| \k \j \i))))) (* |;;| "1 d array set") (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array1d-0| \i) (DIFFERENCE 10 \i))) (* |;;| "1 d array ref") (|for| \i |from| 0 |to| 9 |do| (NEQP (DIFFERENCE 10 \i) (CL:AREF |array1d-0| \i) '(CL:AREF |array1d-0| \i))) (* |;;| "2 d array set") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array2d-0| \j \i) (PLUS \j (TIMES \i 10))))) (* |;;| "2 d aref") (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (PLUS \j (TIMES \i 10)) (CL:AREF |array2d-0| \j \i) '(CL:AREF |array2d-0| \j \i)))) (* |;;| " 3 d array set") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (CL:SETF (CL:AREF |array3d-0| \k \j \i) (PLUS \k (TIMES \j 10) (TIMES \i 100)))))) (* |;;| "3 d aref") (|for| \k |from| 0 |to| 1 |do| (|for| \j |from| 0 |to| 2 |do| (|for| \i |from| 0 |to| 9 |do| (NEQP (PLUS \k (TIMES \j 10) (TIMES \i 100)) (CL:AREF |array3d-0| \k \j \i) '(CL:AREF |array3d-0| \k \j \i)))))))) (NEQP (LAMBDA (A B ERROR-MSG) (* \; "Edited 12-Jun-88 18:13 by sybalsky") (* |;;| "if the two numbers A and B are not equal then halt with error message ERROR-MSG") (OR (EQP A B) (ERROR ERROR-MSG)))) ) (* |;;| "Test of past known failures") (CL:DEFUN USER::PAST-ARRAY-FAILURE-CASES (USER::LIMIT) (* |;;| "Repository for past known failure cases, gleened from hand tests, ARs, and failed runs of this test suite.") (CL:FORMAT T " Starting test of past failure syndromes.~%") (LET ((CL:ARRAY (CL:MAKE-ARRAY 57296 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :INITIAL-ELEMENT 1))) (CL:FORMAT T " Test of array of 57296 (unsigned-byte 8)s inited to 1s.~%") (CL:DO ((USER::I 0 (CL:1+ USER::I))) ((= USER::I 57295)) (CL:WHEN (CL:/= (CL:AREF CL:ARRAY USER::I) 1) (CL:ERROR "Array of ones wasn't 1 at element ~D.~%" USER::I))))) (* |;;| "Assure that we compile with CL:COMPILE-FILE:") (PUTPROPS MAIKO-ARRAY-TESTS FILETYPE :COMPILE-FILE) (PUTPROPS MAIKO-ARRAY-TESTS COPYRIGHT (NONE)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2075 3392 (MAIKO-ARRAY-TESTS 2085 . 3390)) (24410 29486 (SIMPLE-AREF-ASET-TESTS 24420 . 29219) (NEQP 29221 . 29484))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/AREF-TESTER b/internal/test/Maiko/OBSOLETE/AREF-TESTER new file mode 100644 index 00000000..4dc187de --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/AREF-TESTER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "17-Jun-88 17:28:36" il:{qv}lisp>aref-tester.\;4 4689 il:|changes| il:|to:| (verified-tests aref1-punt aref1-signed-word aref1-displaced aref1-bit aref1-byte aref1-word aref1-fixp aref1-floatp aref1-string-char aref1-pointer aref1-xpointer) (il:vars il:aref-testercoms) (file-environments "AREF-TESTER") il:|previous| il:|date:| "17-Jun-88 12:03:57" il:{qv}lisp>aref-tester.\;1) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:aref-testercoms) (il:rpaqq il:aref-testercoms ((il:files il:tester) (il:coms (il:* il:|;;| "AREF1 all types") (verified-tests aref1-bit aref1-byte aref1-word aref1-signed-word aref1-fixp aref1-floatp aref1-string-char aref1-pointer aref1-xpointer aref1-punt)) (file-environments "AREF-TESTER"))) (il:filesload il:tester) (il:* il:|;;| "AREF1 all types") (define-verified-test aref1-bit "Opcode aref1, type (unsigned-byte 1)" (let* ((array-1 (make-array 4 :element-type (quote (unsigned-byte 1)) :initial-contents (quote (0 1 0 1)))) (array-2 (make-array 4 :element-type (quote (unsigned-byte 1)) :displaced-to array-1))) (with-collection (dotimes (i 4) (collect (aref array-1 i)) (collect (aref array-2 i)))))) (define-verified-test aref1-byte "Opcode aref1, type (unsigned-byte 8)" (let* ((array-1 (make-array 5 :element-type (quote (unsigned-byte 8)) :initial-contents (quote (0 34 56 255 23)))) (array-2 (make-array 5 :element-type (quote (unsigned-byte 8)) :displaced-to array-1))) (with-collection (dotimes (i 5) (collect (aref array-1 i)) (collect (aref array-2 i)))))) (define-verified-test aref1-word "Opcode aref1, type (unsigned-byte 16)" (let* ((array-1 (make-array 5 :element-type (quote (unsigned-byte 16)) :initial-contents (quote (0 34 255 65535 23)))) (array-2 (make-array 5 :element-type (quote (unsigned-byte 16)) :displaced-to array-1))) (with-collection (dotimes (i 5) (collect (aref array-1 i)) (collect (aref array-2 i)))))) (define-verified-test aref1-signed-word "Opcode aref1, type (signed-byte 16)" (let ((array (make-array 5 :element-type (quote (signed-byte 16)) :initial-contents (quote (0 -34 255 -32768 23))))) (with-collection (dotimes (i 5) (collect (aref array i)))))) (define-verified-test aref1-fixp "Opcode aref1, type (signed-byte 32)" (let ((array (make-array 5 :element-type (quote (signed-byte 32)) :initial-contents (quote (0 -34 258 -65538 2147483647))))) (with-collection (dotimes (i 5) (collect (aref array i)))))) (define-verified-test aref1-floatp "Opcode aref1, type single-float" (let ((array (make-array 5 :element-type (quote single-float) :initial-contents (quote (0.0 -34.0 3.456756E+35 -5.768E-34 5.4524))))) (with-collection (dotimes (i 5) (collect (aref array i)))))) (define-verified-test aref1-string-char "Opcode aref1, type string-char" (let ((array-1 (make-array 3 :element-type (quote string-char) :initial-contents (quote (#\Space #\a #\b)))) (array-2 (make-array 3 :element-type (quote string-char) :fatp t :initial-contents (quote (#\Space #\Greek-0 #\Greek-32))))) (with-collection (dotimes (i 3) (collect (aref array-1 i)) (collect (aref array-2 i)))))) (define-verified-test aref1-pointer "Opcode aref1, type t" (let* ((lst (list 0 (cons (quote a) (quote b)) 3.4 (quote c) (cons (quote d) (quote e)))) (array (make-array 5 :element-type t :initial-contents lst))) (with-collection (dotimes (i 5) (collect (cons (aref array i) (il:\\refcnt (aref array i)))))))) (define-verified-test aref1-xpointer "Opcode aref1, type il:xpointer" (let* ((lst (list 0 (cons (quote a) (quote b)) 3.4 (quote c) (cons (quote d) (quote e)))) (array (make-array 5 :element-type (quote il:xpointer) :initial-contents lst))) (with-collection (dotimes (i 5) (collect (cons (aref array i) (il:\\refcnt (aref array i)))))))) (define-verified-test aref1-punt "Opcode aref1, punt cases" (let* ((array-1 (make-array 4 :element-type (quote string-char) :displaced-to (make-array 4 :element-type (quote string-char) :initial-contents (quote (#\a #\b #\c #\d))))) (array-2 (make-array 4 :element-type t :adjustable t :initial-contents (quote (0 a b (a . b))))) (array-3 (make-array 4 :element-type (quote (unsigned-byte 8)) :read-only-p t :initial-contents (quote (0 1 2 3))))) (il:* il:|;;| "aref1 should punt on all these cases") (with-collection (dotimes (i 4) (collect (aref array-1 i)) (collect (aref array-2 i)) (collect (aref array-3 i)))))) (define-file-environment "AREF-TESTER" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (il:putprops il:aref-tester il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL b/internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d705603d5e76796b22543697f11dce6a46cbed0f GIT binary patch literal 4836 zcmdT||4$pq72mb-7cdaGd?6)QvOvQfl%*wUE-9P;*t=$Jb8r{+Wb7q4acs-j zxo{CALB6W0EUtHuYTrqf`g^OYt<>}`ke<}*f6)9`^_Tt${kiA9nYCd7ABoziRV~{y z^JaE-=JP)9&3p3+M1T*NT(93!`$c0oTE@wn0+ltYrJ zNkU8tgjCVS7#~+UhN3Y+2?$z%mz797He^&fM!8}x&u8?zdWP)xjtyrqep+z{fh|h#<}g*HPd`0UwV_8f#RX_mxs6v&P^Cne*o6$hL5UUy`z`R?=-6 zmCj3t7QcdH7_iedpTjjblf_0usu1vC%Z2NUXllfM5*sHhniJJ(9a~LgCbP;8VcT}~s$srqluKkXTyZt8uNYe%dHE>smt)Y2&9+)|AtqVd@2FaUwmZ%KsC-?)8TZ7s$Aa>F zgbr&phXoOlm?^107}I3sIxkKM8XeeT4veU>g3P9(c2hKOmDT2t#1*nk1mx37C*_Bv z%*mRnge4_Lx7Il?Y3e+W@Pt)`CzfLzz}H3K-L@H(*G8}KXeGSYTepz69#?u_Xn2G$ z>;@|TqdCG8D`zrI$Ri@C6)g^i`P?d;B9bqbpDyp*+6`rz{`rsJy)hMf@@#s0COoiH z4lj4V_f$UA4&8pf`|#0k{xaQ$#zNnSm5#j%V|Su$v=2#|rfR%t7-(xfDSauO)%m-6 zA-$B=Q+!chDRPN|zBI}&ri)It&Rr+j$s?S?8C12f5W5Gy93cTAA1}?ug%I>!#_qPT zFeCATrU?uEFwq9SrthO=wFVI0kRTFjse?oyg(RX0KDH2%&Y_?~R^*s0gis%-UR2R3 zm~^ihmD5WJbaSZ@ZfO6rexYboT31TRq^_s1Z~ekBQS`@^mbg-*n;%)p_MoLREW@HD z*dV~R8(VIMVR1_=>oh9gQS-@MN;fwpO+i-V~C*7boHf-=Uf zCx*G>lKq(I?cwT@&* z9m#qRQ>ERtF^K4emmuj|dyppMM?8&%f25Cknq~AXw{~VSgo0gDGf#Hq?dj0K({gCJ z``s^QZa?2aKk|2(_z^lE@gsW`#_k}L8#sn?H47q`IrjXA<9+bWfiDc>Cgp4<*<9~| zUjvcivr(;9|7Idltv+NZ+t8>z7Lz7`Ihex(5vTq}I2|zM{{>3N8Rk;@UjE;LhqY}~ zzpj40@c`kX2KhdB02OQh%OG><;vRn%8}nyB=y_H2={<%%OPO4vXocp7;ERJV1mk`5 zK(Tj&(1pBcjbeC!aUYEw&~G{41^+CF-$sU%k?BnNPw4H-AAU4&t^DI_zxup9`RflU zeZH|1!8+f7Ml0#;&5X{|Wm$dKPmUhzb`z-sr~1AuU6;EoXS@B?9RtVOWU+wT;FHUV z!XZEQBk-+(uL$E~Fku4hx(LDu9?4BXjL5!AEpR^+dlM!J{!l{1UBp;7z`qLOWsER4 zxy|YTgTHRn0cj;R7m=AxtdTnDTO_@Rb5A3j_m^0Q`9Who5+HBk55L{DD5}<4?k1lj zEbT!jhhGfQyBqnszaH=F`i>!MK9|lG^}@a(JMV+90KPPgs~Bv%ZeYkPDlso*u8YTr ziN$Dnh?E#5zd=e7de4*6552FGQh?sG^dNSA0RAk9{pHC8_>7o1MxzW3Nw;laLQno5 z*-%c$G-HK!Jgkp;0P8k{`&0wCi*=Cc9F2iCQT;DM-G2mO<49N_(<`4v-l;9 zCtzX!H1o5|ce;3vgzLA*hOf17>QjAKR8GqHZf2W^)kxiNo4VZl*AmZrw~U z=&sBM*v+Il$hMiHm0#FhM&;~5qayp|l8F_4#cl?;%bD1H;iLynI!+@Nt(dh&$fXC#Y+pl1<0ci7OPzo- zlisp>array-tester.\;1 10444 il:|changes| il:|to:| (verified-tests array-read-bit array-read-byte array-read-word array-read-signed-word array-read-fixp array-read-floatp array-read-thin-char array-read-fat-char array-read-pointer array-read-xpointer array-write-bit array-write-byte array-write-word array-write-signed-word array-write-fixp array-write-floatp array-write-thin-char array-write-fat-char array-write-pointer array-write-xpointer) (il:vars il:array-testercoms) (file-environments "ARRAY-TESTER")) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:array-testercoms) (il:rpaqq il:array-testercoms ((il:files il:tester) (il:coms (il:* il:|;;| "array-read and array-write ") (verified-tests array-read-bit array-read-byte array-read-word array-read-signed-word array-read-fixp array-read-floatp array-read-thin-char array-read-fat-char array-read-pointer array-read-xpointer) (verified-tests array-write-bit array-write-byte array-write-word array-write-signed-word array-write-fixp array-write-floatp array-write-thin-char array-write-fat-char array-write-pointer array-write-xpointer)) (file-environments "ARRAY-TESTER"))) (il:filesload il:tester) (il:* il:|;;| "array-read and array-write ") (define-verified-test array-read-bit "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (flet ((array-read-bit (base index) ((il:opcodes il:misc3 9) base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (dotimes (i 4) (collect (array-read-bit base i))))))) (define-verified-test array-read-byte "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (flet ((array-read-byte (base index) ((il:opcodes il:misc3 9) base 3 index))) (let ((base (il:%make-array-storage 4 3))) (do ((i 0 (1+ i)) (x (quote (0 23 255 4)) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-byte base i))))))) (define-verified-test array-read-word "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (flet ((array-read-word (base index) ((il:opcodes il:misc3 9) base 4 index))) (let ((base (il:%make-array-storage 4 4))) (do ((i 0 (1+ i)) (x (quote (0 23 255 65535)) (cdr x))) ((eq i 4)) (il:\\putbase base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-word base i))))))) (define-verified-test array-read-signed-word "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (flet ((array-read-signed-word (base index) ((il:opcodes il:misc3 9) base 20 index))) (let ((base (il:%make-array-storage 4 20))) (do ((i 0 (1+ i)) (x (quote (0 -23 255 -32768)) (cdr x))) ((eq i 4)) (il:\\putbase base i (il:\\loloc (car x)))) (with-collection (dotimes (i 4) (collect (array-read-signed-word base i))))))) (define-verified-test array-read-fixp "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (flet ((array-read-fixp (base index) ((il:opcodes il:misc3 9) base 22 index))) (let ((base (il:%make-array-storage 4 22))) (do ((i 0 (1+ i)) (x (quote (0 -23 65536 -2147483648)) (cdr x))) ((eq i 4)) (il:\\putbasefixp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-fixp base i))))))) (define-verified-test array-read-floatp "Opcode ARRAYREAD (MISC3 9), type single-float" (flet ((array-read-floatp (base index) ((il:opcodes il:misc3 9) base 54 index))) (let ((base (il:%make-array-storage 4 54))) (do ((i 0 (1+ i)) (x (quote (0.0 -23.0 3.4456E+24 -4.562435E-12)) (cdr x))) ((eq i 4)) (il:\\putbasefloatp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-floatp base i))))))) (define-verified-test array-read-thin-char "Opcode ARRAYREAD (MISC3 9), type string-char" (flet ((array-read-thin-char (base index) ((il:opcodes il:misc3 9) base 67 index))) (let ((base (il:%make-array-storage 4 67))) (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-thin-char base i))))))) (define-verified-test array-read-fat-char "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (flet ((array-read-fat-char (base index) ((il:opcodes il:misc3 9) base 68 index))) (let ((base (il:%make-array-storage 4 68))) (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (il:\\putbase base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-fat-char base i))))))) (define-verified-test array-read-pointer "Opcode ARRAYREAD (MISC3 9), type t" (flet ((array-read-pointer (base index) ((il:opcodes il:misc3 9) base 38 index))) (let ((base (il:%make-array-storage 4 38))) (do ((i 0 (1+ i)) (x (quote (2 #\c 2.3 (a . b))) (cdr x))) ((eq i 4)) (il:\\rplptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-pointer base i))))))) (define-verified-test array-read-xpointer "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (flet ((array-read-xpointer (base index) ((il:opcodes il:misc3 9) base 86 index))) (let ((base (il:%make-array-storage 4 86))) (do ((i 0 (1+ i)) (x (quote (2 #\c 2.3 (a . b))) (cdr x))) ((eq i 4)) (il:\\putbaseptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-xpointer base i))))))) (define-verified-test array-write-bit "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (flet ((array-write-bit (new-value base index) ((il:opcodes il:misc4 7) new-value base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (do ((i 0 (1+ i)) (x (quote (1 0 1 0)) (cdr x))) ((eq i 4)) (collect (array-write-bit (car x) base i))) (collect (let ((byte (il:\\getbasebyte base 0))) (list (ldb (byte 1 7) byte) (ldb (byte 1 6) byte) (ldb (byte 1 5) byte) (ldb (byte 1 4) byte)))))))) (define-verified-test array-write-byte "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (flet ((array-write-byte (new-value base index) ((il:opcodes il:misc4 7) new-value base 3 index))) (let ((base (il:%make-array-storage 4 3))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 23 255 4)) (cdr x))) ((eq i 4)) (collect (array-write-byte (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasebyte base i))))))))) (define-verified-test array-write-word "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (flet ((array-write-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 4 index))) (let ((base (il:%make-array-storage 4 4))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 23 255 65535)) (cdr x))) ((eq i 4)) (collect (array-write-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbase base i))))))))) (define-verified-test array-write-signed-word "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (flet ((array-write-signed-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 20 index))) (let ((base (il:%make-array-storage 4 20))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 -23 255 -32768)) (cdr x))) ((eq i 4)) (collect (array-write-signed-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (let ((word (il:\\getbase base i))) (if (> word 32767) (il:\\vag2 15 word) word)))))))))) (define-verified-test array-write-fixp "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (flet ((array-write-fixp (new-value base index) ((il:opcodes il:misc4 7) new-value base 22 index))) (let ((base (il:%make-array-storage 4 22))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 -23 65536 -2147483648)) (cdr x))) ((eq i 4)) (collect (array-write-fixp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefixp base (ash i 1)))))))))) (define-verified-test array-write-floatp "Opcode ARRAYWRITE (MISC4 7), type single-float" (flet ((array-write-floatp (new-value base index) ((il:opcodes il:misc4 7) new-value base 54 index))) (let ((base (il:%make-array-storage 4 54))) (with-collection (do ((i 0 (1+ i)) (x (quote (0.0 -23.0 3.4456E+24 -4.562435E-12)) (cdr x))) ((eq i 4)) (collect (array-write-floatp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefloatp base (ash i 1)))))))))) (define-verified-test array-write-thin-char "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (flet ((array-write-thin-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 67 index))) (let ((base (il:%make-array-storage 4 67))) (with-collection (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (collect (array-write-thin-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbasebyte base i)))))))))) (define-verified-test array-write-fat-char "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (flet ((array-write-fat-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 68 index))) (let ((base (il:%make-array-storage 4 68))) (with-collection (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (collect (array-write-fat-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbase base i)))))))))) (define-verified-test array-write-pointer "Opcode ARRAYWRITE (MISC4 7), type t" (flet ((array-write-pointer (new-value base index) ((il:opcodes il:misc4 7) new-value base 38 index))) (let ((base (il:%make-array-storage 4 38))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c (quote a) (cons (quote a) (quote b))) (cdr x))) ((eq i 4)) (collect (array-write-pointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1)))))))))))) (define-verified-test array-write-xpointer "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (flet ((array-write-xpointer (new-value base index) ((il:opcodes il:misc4 7) new-value base 86 index))) (let ((base (il:%make-array-storage 4 86))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c (quote a) (cons (quote a) (quote b))) (cdr x))) ((eq i 4)) (collect (array-write-xpointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1)))))))))))) (define-file-environment "ARRAY-TESTER" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (il:putprops il:array-tester il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a176ab1769faecce906cac3d348c705a235c2d7a GIT binary patch literal 10007 zcmdU#e{36P8OQHz$4;6qO`2b<9pc*3tPQ!SSwfn%W2$3c>~rk1v7H~?Dot*3shv1> zaGbVT)vlCinkFwaO zG9%E=ocV13*{1@WlM9A8;b|`)3OsEO2JJ`LFc%7Q!PdiVTSB_Shf-oBEey((QXJ({E_>ID8* zNl`U5G}^A9sA|eYOP4cMJ-nB51UY+{b9(&_6D55yQ{5a2+XbgR=wx{z&=+o&GSzKN zIyu3{#gk$j4SC!ISCKAe%6s|*N0|2u(mZ|MR1X)dc5*$uz_IAMaC(ow60T_R2ROl0 z4kuXsePOs{8LU<~`5=c+Hq}V;7Ssa$aE9&OUQWuGL2PKU1?-Mqy9*l1p@HoSaY0(j zSkDMk@%UK^21tE^3=Rzo26z+wHY&e(m{O*uy`b}xa114zai4cWpDR#jLtek#SqWP< z=wBe{514DwaP;sTeqYF<9`6LnLP)}``a{f(a8+ou65QLQdAN-U8p`lJWY~?aU_qBc z`z~kbW>}aGAC@vZBdJtmngxp(W+Dmrk2g=HVrh|)<}0O3nW}y+$oKG^6I)YAn$yXG zc9WhU71?e+EboH0ZThyOVQy99fIsNOjSadZL%d6XyX5xiuhPR02Ji_rx)XXpy)bF6 z(=~_Pyudo#_8>l?R=20e9@chj*X;=Sc>x?{)d_>zj`>P?w>GqaARp#(<5hqujp~5& zT63dnB)28U77jV@l-!t=o|02^gRa+KDu2|99?B{DVJmu&J=*XtW%5qZ58MR9uEDOw z3H^M~FZehijP0OikPG?;S+FagUtm$(k@79mh75DTBxSa@b+8a(*sd-$ymVa7>@FU+ zsHN;j;vbY7d+mk zPI3FxrbYsX6^6XUIFx*oEjPu#bMZYZf_NME=|#tRmwc!pBPFGiwwRR@-}9l zj}JN8nJ4$RFzM+Dk=Zwun2eoBKu3>HgZH-W2i>=xYYIcJ4>9K=Eeu7=!U2e0wj-nV z4=SoDsnB^rHWLm}D12lr-S!Z~z%pKNa)YpousFGzg(YrAFh-YiR}B?%HpXeIV;IE|9hSNZhRGst;Y=5D(yHMTMO<64p{6 z?A&6lo4@U$-=T8a{_UgE_Ea)8tkZT%cEvSqKPU6iJZ(YXY*wc)-Uf}^*KNn0ipV1# zBC^FmWE5UY5&3x|k?U58T!%$|SEus5O;Y(&#VlBH;R3Nw%C2!u?3B#M6tOR4v)Oyt zm|^Wag#|BY1JT=xi=G!cRLN7lMDjXC@--gUr6_;KNco0U%GbO3vAZ4`y;Z5fGC!IR0iFdH&Vv?u2x{BG$0-?dc?oo#}tbXT5seV&2!ykz!BWYv(t8)6|H@?*bW`*k4(%iv9+<|CMw}4kvpm%J$1KyjhnlH>oW{=Mf&DxRr>N+UiQe5$L3N*(z z)dZIn!5xa=hOhahXnxix`Z!l<-iYHq5?vSi|FTK(XJ0YZM3ItNSpUH^J0*7ZpFP8Tbzs18-8~ zHb_c0taksJYX5rk)h=q>r#B=wR`q*psJ&8BV2Q;KsrS}&|B0e|zk!*nxo;`LV~6Z7 zAv;BftU!u-e{OM)mxd(OjFZ$Gkfiz`N%f&5)oWToNzmf&+@o);c*p;FckDgy_y>6T zAzuCqmeC#XmzUc@PK$d0xT|w3l-XJ=VZucol*C%KBo>WlPIjT6mmrB%5+}6zip-;* z8QHTJtR5w$VEyoTpebb&VC22q;|c>wQahM~YbU8VfkKyl=O7L}_R;PSZ74Zak|4uyRZ=xr7nkTt^!n%xA1*XBx_xi` z*t^gxG+mz&qC1{l@r~WN0VRe%d#?l2USQgbnDVz|(gj3ETcgZ2glF#qVw8dh5?Wh6 zp9R9_W!cpzyDL#*i$;2p@Oe@8>;fQaQVX@fGId?oY}*K{uKng5tKYW+tBND`xLJXf zSGiJB-gVP@)sPm>fgh6Aqi)~rUrk8qO$>(*6@Omka7l6!WbF5?&L5CnR3TzP}LPCj92SU_|oH zdPueu^*mi7UI6rK1gM-3^fdzXvI4Xq3CBJ=J&3-au56VLu?ex!bb zIPz8E$Z8Ia@T%*8R9!92VQ~j^3AKiDkBZWvpfvt!w-K7(H>8QH8V^bHfbzsGndh(8 z!}CGqC&iVON=O0D?-HEw{MCEzHwn(yO2wI13^#tj7L-Rcnr$jgr$RIDtEu{Zc_T2d z8N$RB69SWb)+7@TV7Y@Nf~BUE`qTy9r^fEy{w1aSz>I|*Mn1Z(_o)Zv|AeWM|7%F` zv-d{?>9=Ip^YHAo9Sd?j4k1kNnpsqBfjUbwDFZxCesH?8NT7d1_UxG*LaqyS7_u9R zG-L%W>8HSzp#|ohEWiZA;d_b)>a=DAoKs1DniL~2`lh~lHh}9m{|`1$ z+^^L_%-TkPp&eHF6NLXw{C*SQ&-)%=91(O?B+U>8R72=DiUztmQpqo5U|5gk&n?P1 zJbV&ERT1?&3Yz%Eiiwl4R5CFxCeqAqGS7g_0oo1br_MI|m|R;a*Ot}8%%-g{RU?2V zNulW++ri<=(MtGefZHZFpgBTyXvRX}Tn}1qpkXG5MXn%Iq~uE76d*hwssfc!l$lSf zrfq3mq07)Mm8ni4il$*UlH34o6%K#kXpncg!+7RF&7hb{o`z{}sflDNl8z-4;L5h2 MQ?DYAp2%kZ0~P>%%m4rY literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.TEST b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.TEST new file mode 100644 index 00000000..f16a4e28 --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.TEST @@ -0,0 +1 @@ +;;; File converted on 14-Jun-88 15:01:09 from source array-tester ;;; Original source {qv}lisp>array-tester.;1 created 14-Jun-88 14:57:44 ;;; Copyright (c) 1988 by Xerox Corporation ;; array-read and array-write (do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (equal '(1 0 1 0) (flet ((array-read-bit (base index) ((il:opcodes il:misc3 9) base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (dotimes (i 4) (collect (array-read-bit base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (equal '(0 23 255 4) (flet ((array-read-byte (base index) ((il:opcodes il:misc3 9) base 3 index))) (let ((base (il:%make-array-storage 4 3))) (do ((i 0 (1+ i)) (x '(0 23 255 4) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-byte base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (equal '(0 23 255 65535) (flet ((array-read-word (base index) ((il:opcodes il:misc3 9) base 4 index))) (let ((base (il:%make-array-storage 4 4))) (do ((i 0 (1+ i)) (x '(0 23 255 65535) (cdr x))) ((eq i 4)) (il:\\putbase base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-word base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (equal '(0 -23 255 -32768) (flet ((array-read-signed-word (base index) ((il:opcodes il:misc3 9) base 20 index))) (let ((base (il:%make-array-storage 4 20))) (do ((i 0 (1+ i)) (x '(0 -23 255 -32768) (cdr x))) ((eq i 4)) (il:\\putbase base i (il:\\loloc (car x)))) (with-collection (dotimes (i 4) (collect (array-read-signed-word base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (equal '(0 -23 65536 -2147483648) (flet ((array-read-fixp (base index) ((il:opcodes il:misc3 9) base 22 index))) (let ((base (il:%make-array-storage 4 22))) (do ((i 0 (1+ i)) (x '(0 -23 65536 -2147483648) (cdr x))) ((eq i 4)) (il:\\putbasefixp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-fixp base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type single-float" (equal '(0.0 -23.0 3.4456E+24 -4.562435E-12) (flet ((array-read-floatp (base index) ((il:opcodes il:misc3 9) base 54 index))) (let ((base (il:%make-array-storage 4 54))) (do ((i 0 (1+ i)) (x '(0.0 -23.0 3.4456E+24 -4.562435E-12) (cdr x))) ((eq i 4)) (il:\\putbasefloatp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-floatp base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type string-char" (equal '(#\a #\b #\c #\A) (flet ((array-read-thin-char (base index) ((il:opcodes il:misc3 9) base 67 index))) (let ((base (il:%make-array-storage 4 67))) (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-thin-char base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (equal '(#\a #\b #\c #\A) (flet ((array-read-fat-char (base index) ((il:opcodes il:misc3 9) base 68 index))) (let ((base (il:%make-array-storage 4 68))) (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (il:\\putbase base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-fat-char base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type t" (equal '(2 #\c 2.3 (a . b)) (flet ((array-read-pointer (base index) ((il:opcodes il:misc3 9) base 38 index))) (let ((base (il:%make-array-storage 4 38))) (do ((i 0 (1+ i)) (x '(2 #\c 2.3 (a . b)) (cdr x))) ((eq i 4)) (il:\\rplptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-pointer base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (equal '(2 #\c 2.3 (a . b)) (flet ((array-read-xpointer (base index) ((il:opcodes il:misc3 9) base 86 index))) (let ((base (il:%make-array-storage 4 86))) (do ((i 0 (1+ i)) (x '(2 #\c 2.3 (a . b)) (cdr x))) ((eq i 4)) (il:\\putbaseptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-xpointer base i)))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (equal '(1 0 1 0 (1 0 1 0)) (flet ((array-write-bit (new-value base index) ((il:opcodes il:misc4 7) new-value base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (do ((i 0 (1+ i)) (x '(1 0 1 0) (cdr x))) ((eq i 4)) (collect (array-write-bit (car x) base i))) (collect (let ((byte (il:\\getbasebyte base 0))) (list (ldb (byte 1 7) byte) (ldb (byte 1 6) byte) (ldb (byte 1 5) byte) (ldb (byte 1 4) byte))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (equal '(0 23 255 4 (0 23 255 4)) (flet ((array-write-byte (new-value base index) ((il:opcodes il:misc4 7) new-value base 3 index))) (let ((base (il:%make-array-storage 4 3))) (with-collection (do ((i 0 (1+ i)) (x '(0 23 255 4) (cdr x))) ((eq i 4)) (collect (array-write-byte (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasebyte base i)))))) )))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (equal '(0 23 255 65535 (0 23 255 65535)) (flet ((array-write-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 4 index))) (let ((base (il:%make-array-storage 4 4))) (with-collection (do ((i 0 (1+ i)) (x '(0 23 255 65535) (cdr x))) ((eq i 4)) (collect (array-write-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbase base i)))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (equal '(0 -23 255 -32768 (0 -23 255 -32768)) (flet ((array-write-signed-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 20 index))) (let ((base (il:%make-array-storage 4 20))) (with-collection (do ((i 0 (1+ i)) (x '(0 -23 255 -32768) (cdr x))) ((eq i 4)) (collect (array-write-signed-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (let ((word (il:\\getbase base i))) (if (> word 32767) (il:\\vag2 15 word) word))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (equal '(0 -23 65536 -2147483648 (0 -23 65536 -2147483648)) (flet ((array-write-fixp (new-value base index) ((il:opcodes il:misc4 7) new-value base 22 index))) (let ((base (il:%make-array-storage 4 22))) (with-collection (do ((i 0 (1+ i)) (x '(0 -23 65536 -2147483648) (cdr x))) ((eq i 4)) (collect (array-write-fixp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefixp base (ash i 1))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type single-float" (equal '(0.0 -23.0 3.4456E+24 -4.562435E-12 (0.0 -23.0 3.4456E+24 -4.562435E-12)) (flet ((array-write-floatp (new-value base index) ((il:opcodes il:misc4 7) new-value base 54 index))) (let ((base (il:%make-array-storage 4 54))) (with-collection (do ((i 0 (1+ i)) (x '(0.0 -23.0 3.4456E+24 -4.562435E-12) (cdr x))) ((eq i 4)) (collect (array-write-floatp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefloatp base (ash i 1))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (equal '(#\a #\b #\c #\A (#\a #\b #\c #\A)) (flet ((array-write-thin-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 67 index))) (let ((base (il:%make-array-storage 4 67))) (with-collection (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (collect (array-write-thin-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbasebyte base i))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (equal '(#\a #\b #\c #\A (#\a #\b #\c #\A)) (flet ((array-write-fat-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 68 index))) (let ((base (il:%make-array-storage 4 68))) (with-collection (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (collect (array-write-fat-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbase base i))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type t" (equal '(2*#\c a (a . b) ((2 . 1) (#\c . 1) (a . 1) ((a . b) . 3))) (flet ((array-write-pointer (new-value base index) ( ((il:opcodesőil:misc4 7) new-value base 38 index))) (let ((base (il:%make-array-storage 4 38))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c 'a (cons 'a 'b)) (cdr x))) ((eq i 4)) (collect (array-write-pointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1))))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (equal '(2 #\c a (a . b) ((2 . 1) (#\c . 1) (a . 1) ((a . b) . 2))) (flet ((array-write-xpointer (new-value base index) ((il:opcodes il:misc4 7) new-value base 86 index))) (let ((base (il:%make-array-storage 4 86))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c 'a (cons 'a 'b)) (cdr x))) ((eq i 4)) (collect (array-write-xpointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1))))))))))))) \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER new file mode 100644 index 00000000..e5b96d2e --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "14-Jun-88 11:10:38" il:{qv}lisp>float-tester.\;9 9756 il:|changes| il:|to:| (verified-tests cos-test exp-test log-test sin-test poly box unbox ubabs ubnegate ubfix ub+ ub- ub* ub/ ub> ubmax ubmin mixed/ int> float> mixed> int- float- mixed- int+ float+ mixed+ int* float* mixed* int/ float/) (il:vars il:float-testercoms) (il:functions define-verified-test) (il:define-types verified-tests) (file-environments "FLOAT-TESTER") il:|previous| il:|date:| "14-Jun-88 11:05:17" il:{qv}lisp>float-tester.\;8) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:float-testercoms) (il:rpaqq il:float-testercoms ((il:files il:tester) (il:coms (il:* il:|;;| "Boxed opcodes") (verified-tests int+ float+ mixed+) (verified-tests int- float- mixed-) (verified-tests int* float* mixed*) (verified-tests int/ float/ mixed/) (verified-tests int> float> mixed>)) (il:coms (il:* il:|;;| "Unboxed opcodes [scalar]") (il:* il:|;;| "Ubfloat1") (verified-tests box unbox ubabs ubnegate ubfix) (il:* il:|;;| "Ubfloat2") (verified-tests ub+ ub- ub* ub/ ub> ubmax ubmin) (il:* il:|;;| "Ubfloat3") (verified-tests poly)) (il:coms (il:* il:|;;| "Transcendentals --- stress test") (verified-tests sin-test cos-test exp-test log-test)) (file-environments "FLOAT-TESTER"))) (il:filesload il:tester) (il:* il:|;;| "Boxed opcodes") (define-verified-test int+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (let ((x 3)) (with-collection (dolist (y (quote (1 -3 9834756987354 21845 -54))) (collect (il:iplus x y)) (collect (il:fplus x y)) (collect (il:plus x y)))))) (define-verified-test float+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (let ((x 3.0)) (with-collection (dolist (y (quote (1.0 -3.0 -3.4028235E+38 21845.0 -54.0))) (collect (il:iplus x y)) (collect (il:fplus x y)) (collect (il:plus x y)))))) (define-verified-test mixed+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (let ((x 3.0)) (with-collection (dolist (y (quote (1 -3 1/3 9834756987354 21845 -54))) (collect (il:iplus x y)) (collect (il:fplus x y)) (collect (il:plus x y)))))) (define-verified-test int- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (let ((x 3)) (with-collection (dolist (y (quote (1 3 9834756987354 21845 -54))) (collect (il:idifference x y)) (collect (il:fdifference x y)) (collect (il:difference x y)))))) (define-verified-test float- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (let ((x 3.0)) (with-collection (dolist (y (quote (1.0 3.0 3.4028235E+38 21845.0 -54.0))) (collect (il:idifference x y)) (collect (il:fdifference x y)) (collect (il:difference x y)))))) (define-verified-test mixed- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (let ((x 3.0)) (with-collection (dolist (y (quote (1 3 1/3 9834756987354 21845 -54))) (collect (il:idifference x y)) (collect (il:fdifference x y)) (collect (il:difference x y)))))) (define-verified-test int* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (let ((x 3)) (with-collection (dolist (y (quote (45 345235424 0 23 21845))) (collect (il:itimes x y)) (collect (il:ftimes x y)) (collect (il:times x y)))))) (define-verified-test float* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (let ((x 3.0)) (with-collection (dolist (y (quote (45.0 0.0 1.1342745E+38 -21845.0))) (collect (il:itimes x y)) (collect (il:ftimes x y)) (collect (il:times x y)))))) (define-verified-test mixed* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (let ((x 3.0)) (with-collection (dolist (y (quote (45 1/3 345235424 0 23 21845))) (collect (il:itimes x y)) (collect (il:ftimes x y)) (collect (il:times x y)))))) (define-verified-test int/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (let ((x 21845)) (with-collection (dolist (y (quote (21845 1 345235424 -45))) (collect (il:iquotient x y)) (collect (il:fquotient x y)) (collect (il:quotient x y)))))) (define-verified-test float/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (let ((x 21845.0)) (with-collection (dolist (y (quote (21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (collect (il:iquotient x y)) (collect (il:fquotient x y)) (collect (il:quotient x y)))))) (define-verified-test mixed/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (let ((x 21845.0)) (with-collection (dolist (y (quote (21845 1 4/3 -1345619432 45))) (collect (il:iquotient x y)) (collect (il:fquotient x y)) (collect (il:quotient x y)))))) (define-verified-test int> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (let ((x 21845)) (with-collection (dolist (y (quote (21845 -45 345235424 22000))) (collect (il:igreaterp x y)) (collect (il:fgreaterp x y)) (collect (il:greaterp x y)))))) (define-verified-test float> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (let ((x 21845.0)) (with-collection (dolist (y (quote (21845.0 -45.0 3.4523542E+8 22000.0))) (collect (il:igreaterp x y)) (collect (il:fgreaterp x y)) (collect (il:greaterp x y)))))) (define-verified-test mixed> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (let ((x 21845.0)) (with-collection (dolist (y (quote (21845 1/3 -45 5498457654 22000))) (collect (il:igreaterp x y)) (collect (il:fgreaterp x y)) (collect (il:greaterp x y)))))) (il:* il:|;;| "Unboxed opcodes [scalar]") (il:* il:|;;| "Ubfloat1") (define-verified-test box "Opcode BOX (UBFLOAT1 0)" (with-collection (dolist (x (quote ((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156)))) (collect (il:\\floatbox (il:\\vag2 (car x) (cdr x))))))) (define-verified-test unbox "Opcode UNBOX (UBFLOAT1 1)" (with-collection (dolist (x (quote (1.0 0.0 -45.0 4.6678E+23))) (let ((y (il:\\floatunbox x))) (collect (cons (il:\\hiloc y) (il:\\loloc y))))))) (define-verified-test ubabs "Opcode UFABS (UBFLOAT1 2)" (flet ((ubabs (x) (il:\\floatbox ((il:opcodes il:ubfloat1 2) (il:\\floatunbox x))))) (with-collection (dolist (x (quote (-1.0 0.0 -45.0 4.6678E+23))) (collect (ubabs x)))))) (define-verified-test ubnegate "Opcode UFNEGATE (UBFLOAT1 3)" (flet ((ubnegate (x) (il:\\floatbox ((il:opcodes il:ubfloat1 3) (il:\\floatunbox x))))) (with-collection (dolist (x (quote (-1.0 0.0 -45.0 4.6678E+23))) (collect (ubnegate x)))))) (define-verified-test ubfix "Opcode UFIX (UBFLOAT1 4)" (flet ((ubfix (x) ((il:opcodes il:ubfloat1 4) (il:\\floatunbox x)))) (with-collection (dolist (x (quote (-1.0 0.0 -45.0 4.6678E+23))) (collect (ubfix x)))))) (il:* il:|;;| "Ubfloat2") (define-verified-test ub+ "Opcode UFADD (UBFLOAT2 0)" (flet ((ub+ (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 0) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 3.0)) (with-collection (dolist (y (quote (1.0 -3.0 -3.4028235E+38 21845.0 3))) (collect (ub+ x y))))))) (define-verified-test ub- "Opcode UFSUB (UBFLOAT2 1)" (flet ((ub- (x y) (il:\\floatbox ((il:* il:|;;| "ub -") (il:opcodes il:ubfloat2 1) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 3.0)) (with-collection (dolist (y (quote (1.0 3.0 3.4028235E+38 21845 1/3 -54.0))) (collect (ub- x y))))))) (define-verified-test ub* "Opcode UFMULT (UBFLOAT2 3)" (flet ((ub* (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 3) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 3.0)) (with-collection (dolist (y (quote (45.0 0.0 1.1342745E+38 -21845.0))) (collect (ub* x y))))))) (define-verified-test ub/ "Opcode UFDIV (UBFLOAT2 4)" (flet ((ub/ (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 4) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 21845.0)) (with-collection (dolist (y (quote (0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38))) (collect (ub/ x y))))))) (define-verified-test ub> "Opcode UFGREAT (UBFLOAT2 5)" (flet ((ub> (x y) ((il:opcodes il:ubfloat2 5) (il:\\floatunbox x) (il:\\floatunbox y)))) (let ((x 21845.0)) (with-collection (dolist (y (quote (21845.0 -45.0 3.4523542E+8 0.001))) (collect (ub> x y))))))) (define-verified-test ubmax "Opcode UFMAX (UBFLOAT2 6)" (flet ((ubmax (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 6) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 21845.0)) (with-collection (dolist (y (quote (21845.0 -45.0 3.4523542E+8 0.001))) (collect (ubmax x y))))))) (define-verified-test ubmin "Opcode UFMAX (UBFLOAT2 7)" (flet ((ubmin (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 7) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 21845.0)) (with-collection (dolist (y (quote (21845.0 -45.0 3.4523542E+8 0.001))) (collect (ubmin x y))))))) (il:* il:|;;| "Ubfloat3") (define-verified-test poly "Opcode POLY (UBFLOAT3 0)" (flet ((poly (x base size) (il:\\floatbox ((il:opcodes il:ubfloat3 0) (il:\\floatunbox x) base size)))) (let* ((array (make-array 4 :element-type (quote single-float) :initial-contents (quote (1.0 2.0 3.0 4.0)))) (base (il:%array-base array))) (with-collection (dolist (pair (quote ((1.0 . 3) (1.0 . 1) (3.5 . 3)))) (collect (poly (car pair) base (cdr pair)))))))) (il:* il:|;;| "Transcendentals --- stress test") (define-verified-test sin-test "Function SIN" (with-collection (dolist (x (quote (0.0 1/3 -1.2 12.6))) (collect (sin (* pi x)))))) (define-verified-test cos-test "Function COS" (with-collection (dolist (x (quote (0.0 1/3 -1.2 12.6))) (collect (cos (* pi x)))))) (define-verified-test exp-test "Function EXP" (with-collection (dolist (x (quote (1.0 20.5 1/3 -5.2))) (collect (exp x))))) (define-verified-test log-test "Function LOG" (with-collection (dolist (x (quote (2.7182817 -2.0 453.78))) (collect (log x))))) (define-file-environment "FLOAT-TESTER" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (il:putprops il:float-tester il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..784f4e610709338028085ae144a1d0e7322df15c GIT binary patch literal 11641 zcmd^Fdu&^075}bZN%~ILwOt?DrBVw^Y>e4Fp}&(W=`(0)_-*5BAUojEPqf8-KtbfH~)U*Y@Yw zc~aU+SnbWZ-~H}qpWiv>cfWJ)In5e+Twd9gIWjzyif84_=*aNsh@8k|Yo+aH$` zFfQMJ*Wm~53@UCV6juBPylOajz~c=#BKC+9jwqoW`}Zyh3)B0v@z_XwK#q*Ya|5ya zTIIGq@}bdmTyERj-VSGN``UKy+jYl|B_2oE%fDeBx9r}xbLWmF#m5WZFx`}4j3w#c zQpTE_B|L9pY!x#}g-7x$JgQf5g%n3baeD(U6Dxczzp5o1aroViklU{MgV9J!A-}3k z9?1;bQ}Ltm6smm01gjLjo^SL-{jP`_@E69VG1HB(;3~J`QT>V?*M-|Xfu*pbB@k5n zrbf8I7Klb*Nh^p=ZZ)LP&8FtUxCKYxceo=Cr&lTD%>XtGH3S{5ZbugkG{S&A8dgG5 zA#c0iKblHCz(7HEGgl7P0tGMN-*v`cQnQe6-aYNd=U@)g&Gef$!f$TE9~%ZMxtGFO z1N^>VC=fK?fa-|Ga|L{1OKH9vAPXae%fu<>b+9T7+PJw_7RIfGaT5$!={t0|+yG}5 zT&gf`22pB(gK7W%LVk%ea|~P|Gu)pUi02TJhx02ADXOy z6Cl~>R~WKS?NQt)k6ZLD#x%Py&5&st%EGi3VVWV+G?ayDw+hn?nWmvEOgkV6;7r_0e>nsJ;A|Tz@PT%idF-(HQMZq%yIQw!*lLlrlR5J+!aU1S zhcis0jZvpx=>j7ebDSO(rg4Ew!0`crBLD)|5d^Mx3?QSw7dP0{Fb>14#QH)Mllk_s2n^y_&lDU8=N|H`p}8V zJEf_Vx%jj&F?tUb)f!{&;)s2&F2WV9 z_+YUJ=uI%~QV(Ml%n5joJAr?yxyTq8z49^hdvSq^4Y(o7HXuWQ4R*}i2BeZnPhG#D z9~put&B8&qaX)`ZGS_wW)!fym!*13(qtPfGN)AunPlq{Szhw^CNfq+_65{ivo?lfF z3sBD=rVqSUH83mnpo7myHFl9|^hB9r^khsQB>t!m=t`3Y{>@Bf?)dwPmRFv>MSG37 zgP#CJOgyXoaN;Q>i-~9VYR&=1_JY4U%fPu+k4Fh9ewWhf5oF>I@w}Er7VN{-m=a4= zqe?@yxGt7BL}V9497rkJgEhp#0VmYwO&nzdkQKNA$O>SD&i}#)i=>gOXab78g`2=8 znP;Ss`UU_BX_YLxv{73(CoFs!_6wUb+#uS(V57e#)i#WGf z1UKGYMlquL6xe|9Kg1x0cm>F#8b4x+Y6NMh7Q@Aohlt|*$it#J_W*AIf=oL;F);xS zH-Q_DWfgb{<0|d|2w~qLd^qnQ`GD&(N&68XO$R`_Z6Qc6k|C}l&J;`w$Ju5Ff|%yQ zt7|Z(9UvYm-b^knpwB&;+`8h`)cq^lELVlo9GT{Djkh>zg-pUIP#~OkvFPF zkPj}*wu7E=gK?|C2Vc+=gGLT>L{ART2Ezi%N23xU3O-kS6@6BsEwn_JX!}eO)7rJ? z-o?$tzc*?xeth-=k^rqc%V^yd4MbGPCtE#biI|{rb_K|w8a|5rYW!%Z7Qn@lfe2w8 zGQjkrolx3JM@m5`=O8b9<*6r%oEtE#k#IS>1aSpnx|L~X0bx4873p`H3s9y5(`*wH z5*+~WeTxEok(_W9;ii~c1l$Cp^pM4T^4mZ8;(Gh+ARCw?vwGmbwC{g;$D?$ZhB*Lz z+X8^5B%3rSr5p1mgpaC%9SPy%nvuU%jVzuJ4$O-Xhzd9<06+W{Nnvbk?8J!^aD-1) z(05UhI23I4lqCxK%GnhN`f7+M!mBZ&p<0j@8}uSf^9yK>Swp(7`oj`j@}gqFg)kOdb2duEp?lIewo!o-mhnS z6tAya%z_%W5O@JS;W3`X-Fni=pTtmF1+C$s0Rp^3p)>F%E+k%tYm)zfR%snRd#-NyBP6bjDsGxfcQ%!-AXdIq)oVtu)}jICW51N*^O3Pzk}TuLYmgB_MnZhK-DMBjWzZ*& zuYa}zNXq~u$7Siyj5`s$_uCFQnT!B~mn%{a{O^S^9%R=DE3x!8GgdZEzMY-GLR56X zTo4|_rMD$EDt8KyVKJE(+_07`(yu2Rbqcs~`X$_?MiDoujGO&>#7!(n%#7Pi#U2Zl zcsO2&XQ_0vp&Ws}s5c_OBoLIeMuf@WD16a;J;EgBXmw!1?3dEueWzAuxR2GO!B(yN z=?OF6GgH<}xh`h8Rc_^04-0q+oF&O3UY4?3-FiLZC2opm#;YcSK=^P|Fm__>1fa69 z>_(JY3Ao%=;c}@JaanHAlojb5n-i`jDlN>L-6C+|-b1w(o^gTSRe2AzVhAYR zE}+yddXJ5J5AWT$E|D5a3%jO8BSpC>!G)eR3sQFoNV!F%8Y)Ps{#lXA)TA3J3vbAR zBkl^8SgG9%dOrrw;rZ0y`R>!*CnmQ*1|l8wno?%kJG`KtIpo`R4ik~PpYJwJO}?Yf zl8Dr=gAQj>_f_%`D>M=G>4~k-UA1(pBNTG<+MSNDvIROlmirvtik-%w)x*32`pj0T zel?;xywDfpk6^3JI+(W%dT+X*jg6A5H85+L;#IJb#vbVnDh)|J`B{C?j%{3LOvHa> z0UKzv&d)Js-ds-QIzfBtUZ5Qc1iV>u$fY6YlNZHJ9Ci$qU3#~;KaqM}5co?m@SVGi z?TH1a!|G;Ze`4nQ6AS8F$Xmkd-3nZ#ZiMKZn>t7j(IVZiL-$-wo`mTktuVdw2Ghg( z`9N+cO)WPS&$jRkaXTPv286NOrh#XQu)R}Pz75Y53q4(Nk8(lRAJZJF{urfAsD{>Y z&v)L`I@aE|N$bcROM!nc^NgnZM}{(K8I~(2!dG3>{!DHbO`&sZA(~QExdZm*+J(Tz zbJ`D{xZ`-0rm$Q|)8L$%Zh(}(o;g2QxH;p;hNmm()e|l~u?@`$4QbRobx==sh>5@B zDaO#67oScf$dH}(e?&C@f$z0w9nU?P(e{7$rBIc6u+TM8FO^Boq8@bERjUW@rBRWK z=$5YE{PqosYBb%Kw2rpydU9v2^TikMuTl<{F_dGQs=HUq)Ct8Ke5P+RQfzE3w#U;) zhq9UU5oj2cw}?%rTj1+U{jBTt87qQj9_bQzPTr!%^ZWq>g;eP8^bV$GDpKp>@oNweYIHp4^fq_PXGV_ literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.TEST b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.TEST new file mode 100644 index 00000000..37389d90 --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.TEST @@ -0,0 +1 @@ +;;; File converted on 14-Jun-88 11:17:15 from source float-tester ;;; Original source {qv}lisp>float-tester.;9 created 14-Jun-88 11:10:38 ;;; Copyright (c) 1988 by Xerox Corporation ;; Boxed opcodes (do-test "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (equal '(4 4.0 4 0 0.0 0 9834756987357 9.834757E+12 9834756987357 21848 21848.0 21848 -51 -51.0 -51) (let ((x 3)) (with-collection (dolist (y '(1 -3 9834756987354 21845 -54)) (collect (il:iplus x y)) (collect (il:fplus x y)) (collect (il:plus x y))))))) (do-test "Opcodes IPLUS,FPLUS, and PLUS, both args float" (equal '(4 4.0 4.0 0 0.0 0.0 -340282346638528859811704183484516925437 -3.4028235E+38 -3.4028235E+38 21848 21848.0 21848.0 -51 -51.0 -51.0) (let ((x 3.0)) (with-collection (dolist (y '(1.0 -3.0 -3.4028235E+38 21845.0 -54.0)) (collect (il:iplus x y)) (collect (il:fplus x y)) (collect (il:plus x y))))))) (do-test "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (equal '(4 4.0 4.0 0 0.0 0.0 3 3.3333333 3.3333333 9834756987357 9.834757E+12 9.834757E+12 21848 21848.0 21848.0 -51 -51.0 -51.0) (let ((x 3.0)) (with-collection (dolist (y '(1 -3 1/3 9834756987354 21845 -54)) (collect (il:iplus x y)) (collect (il:fplus x y)) (collect (il:plus x y))))))) (do-test "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (equal '(2 2.0 2 0 0.0 0 -9834756987351 -9.834757E+12 -9834756987351 -21842 -21842.0 -21842 57 57.0 57) (let ((x 3)) (with-collection (dolist (y '(1 3 9834756987354 21845 -54)) (collect (il:idifference x y)) (collect (il:fdifference x y)) (collect (il:difference x y))))))) (do-test "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (equal '(2 2.0 2.0 0 0.0 0.0 -340282346638528859811704183484516925437 -3.4028235E+38 -3.4028235E+38 -21842 -21842.0 -21842.0 57 57.0 57.0) (let ((x 3.0)) (with-collection (dolist (y '(1.0 3.0 3.4028235E+38 21845.0 -54.0)) (collect (il:idifference x y)) (collect (il:fdifference x y)) (collect (il:difference x y))))))) (do-test "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (equal '(2 2.0 2.0 0 0.0 0.0 3 2.6666667 2.6666667 -9834756987351 -9.834757E+12 -9.834757E+12 -21842 -21842.0 -21842.0 57 57.0 57.0) (let ((x 3.0)) (with-collection (dolist (y '(1 3 1/3 9834756987354 21845 -54)) (collect (il:idifference x y)) (collect (il:fdifference x y)) (collect (il:difference x y))))))) (do-test "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (equal '(135 135.0 135 1035706272 1.03570624E+9 1035706272 0 0.0 0 69 69.0 69 65535 65535.0 65535) (let ((x 3)) (with-collection (dolist (y '(45 345235424 0 23 21845)) (collect (il:itimes x y)) (collect (il:ftimes x y)) (collect (il:times x y))))))) (do-test "Opcodes ITIMES,FTIMES, and TIMES, both args float" (equal '(135 135.0 135.0 0 0.0 0.0 340282346638528859811704183484516925440 3.4028235E+38 3.4028235E+38 -65535 -65535.0 -65535.0) (let ((x 3.0)) (with-collection (dolist (y '(45.0 0.0 1.1342745E+38 -21845.0)) (collect (il:itimes x y)) (collect (il:ftimes x y)) (collect (il:times x y))))))) (do-test "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (equal '(135 135.0 135.0 0 1.0 1.0 1035706272 1.03570624E+9 1.03570624E+9 0 0.0 0.0 69 69.0 69.0 65535 65535.0 65535.0) (let ((x 3.0)) (with-collection (dolist (y '(45 1/3 345235424 0 23 21845)) (collect (il:itimes x y)) (collect (il:ftimes x y)) (collect (il:times x y))))))) (do-test "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (equal '(1 1.0 1 21845 21845.0 21845 0 6.3275664E-5 0 -485 -485.44446 -485) (let ((x 21845)) (with-collection (dolist (y '(21845 1 345235424 -45)) (collect (il:iquotient x y)) (collect (il:fquotient x y)) (collect (il:quotient x y))))))) (do-test "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (equal '(1 1.0 1.0 21845 21845.0 21845.0 0 -6.3275664E-5 -6.3275664E-5 485 485.44446 485.44446 0 6.419669E-35 6.419669E-35) (let ((x 21845.0)) (with-collection (dolist (y '(21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (collect (il:iquotient x y)) (collect (il:fquotient x y)) (collect (il:quotient x y))))))) (do-test "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (equal '(1 1.0 1.0 21845 21845.0 21845.0 21845 16383.75 16383.75 0 -1.6234158E-5 -1.6234158E-5 485 485.44446 485.44446) (let ((x 21845.0)) (with-collection (dolist (y '(21845 1 4/3 -1345619432 45)) (collect (il:iquotient x y)) (collect (il:fquotient x y)) (collect (il:quotient x y))))))) (do-test "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (equal '(nil nil nil t t t nil nil nil nil nil nil) (let ((x 21845)) (with-collection (dolist (y '(21845 -45 345235424 22000)) (collect (il:igreaterp x y)) (collect (il:fgreaterp x y)) (collect (il:greaterp x y))))))) (do-test "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (equal '(nil nil nil t t t nil nil nil nil nil nil) (let ((x 21845.0)) (with-collection (dolist (y '(21845.0 -45.0 3.4523542E+8 22000.0)) (collect (il:igreaterp x y)) (collect (il:fgreaterp x y)) (collect (il:greaterp x y))))))) (do-test "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (equal '(nil nil nil t t t t t t nil nil nil nil nil nil) (let ((x 21845.0)) (with-collection (dolist (y '(21845 1/3 -45 5498457654 22000)) (collect (il:igreaterp x y)) (collect (il:fgreaterp x y)) (collect (il:greaterp x y))))))) ;; Unboxed opcodes [scalar] ;; Ubfloat1 (do-test "Opcode BOX (UBFLOAT1 0)" (equal '(1.0 0.0 -45.0 4.6678E+23) (with-collection (dolist (x '((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156))) (collect (il:\\floatbox (il:\\vag2 (car x) (cdr x)))))))) (do-test "Opcode UNBOX (UBFLOAT1 1)" (equal '((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156)) (with-collection (dolist (x '(1.0 0.0 -45.0 4.6678E+23)) (let ((y (il:\\floatunbox x))) (collect (cons (il:\\hiloc y) (il:\\loloc y)))))))) (do-test "Opcode UFABS (UBFLOAT1 2)" (equal '(1.0 0.0 45.0 4.6678E+23) (flet ((ubabs (x) (il:\\floatbox ((il:opcodes il:ubfloat1 2) (il:\\floatunbox x))))) (with-collection (dolist (x '(-1.0 0.0 -45.0 4.6678E+23)) (collect (ubabs x))))))) (do-test "Opcode UFNEGATE (UBFLOAT1 3)" (equal '(1.0 0.0 45.0 -4.6678E+23) (flet ((ubnegate (x) (il:\\floatbox ((il:opcodes il:ubfloat1 3) (il:\\floatunbox x))))) (with-collection (dolist (x '(-1.0 0.0 -45.0 4.6678E+23)) (collect (ubnegate x))))))) (do-test "Opcode UFIX (UBFLOAT1 4)" (equal '(-1 0 -45 466780014920848390488064) (flet ((ubfix (x) ((il:opcodes il:ubfloat1 4) (il:\\floatunbox x)))) (with-collection (dolist (x '(-1.0 0.0 -45.0 4.6678E+23)) (collect (ubfix x))))))) ;; Ubfloat2 (do-test "Opcode UFADD (UBFLOAT2 0)" (equal '(4.0 0.0 -3.4028235E+38 21848.0 6.0) (flet ((ub+ (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 0) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 3.0)) (with-collection (dolist (y '(1.0 -3.0 -3.4028235E+38 21845.0 3)) (collect (ub+ x y)))))))) (do-test "Opcode UFSUB (UBFLOAT2 1)" (equal '(2.0 0.0 -3.4028235E+38 -21842.0 2.6666667 57.0) (flet ((ub- (x y) (il:\\floatbox ( ;; ub - (il:opcodes il:ubfloat2 1) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 3.0)) (with-collection (dolist (y '(1.0 3.0 3.4028235E+38 21845 1/3 -54.0)) (collect (ub- x y)))))))) (do-test "Opcode UFMULT (UBFLOAT2 3)" (equal '(135.0 0.0 3.4028235E+38 -65535.0) (flet ((ub* (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 3) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 3.0)) (with-collection (dolist (y '(45.0 0.0 1.1342745E+38 -21845.0)) (collect (ub* x y)))))))) (do-test "Opcode UFDIV (UBFLOAT2 4)" (equal '(2.1844998E+7 21845.0 -6.3275664E-5 485.44446 6.419669E-35) (flet ((ub/ (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 4) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 21845.0)) (with-collection (dolist (y '(0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (collect (ub/ x y)))))))) (do-test "Opcode UFGREAT (UBFLOAT2 5)" (equal '(nil t nil t) (flet ((ub> (x y) ((il:opcodes il:ubfloat2 5) (il:\\floatunbox x) (il:\\floatunbox y)))) (let ((x 21845.0)) (with-collection (dolist (y '(21845.0 -45.0 3.4523542E+8 0.001)) (collect (ub> x y)))))))) (do-test "Opcode UFMAX (UBFLOAT2 6)" (equal '(21845.0 21845.0 3.4523542E+8 21845.0) (flet ((ubmax (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 6) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 21845.0)) (with-collection (dolist (y '(21845.0 -45.0 3.4523542E+8 0.001)) (collect (ubmax x y)))))))) (do-test "Opcode UFMAX (UBFLOAT2 7)" (equal '(21845.0 -45.0 21845.0 0.001) (flet ((ubmin (x y) (il:\\floatbox ((il:opcodes il:ubfloat2 7) (il:\\floatunbox x) (il:\\floatunbox y))))) (let ((x 21845.0)) (with-collection (dolist (y '(21845.0 -45.0 3.4523542E+8 0.001)) (collect (ubmin x y)))))))) ;; Ubfloat3 (do-test "Opcode POLY (UBFLOAT3 0)" (equal '(10.0 3.0 81.875) (flet ((poly (x base size) (il:\\floatbox ((il:opcodes il:ubfloat3 0) (il:\\floatunbox x) base size)))) (let* ((array (make-array 4 :element-type 'single-float :initial-contents '(1.0 2.0 3.0 4.0))) (base (il:%array-base array))) (with-collection (dolist (pair '((1.0 . 3) (1.0 . 1) (3.5 . 3))) (collect (poly (car pair) base (cdr pair))))))))) ;; Transcendentals --- stress test (do-test "Function SIN" (equal '(0.0 0.86602545 0.5877855 0.95105624) (with-collection (dolist (x '(0.0 1/3 -1.2 12.6)) (collect (sin (* pi x))))))) (do-test "Function COS" (equal '(1.0 0.50000006 -0.8090168 -0.30901712) (with-collection (dolist (x '(0.0 1/3 -1.2 12.6)) (collect (cos (* pi x))))))) (do-test "Function EXP" (equal '(2.7182817 7.9990234E+8 1.3956126 0.0055165673) (with-collection (dolist (x '(1.0 20.5 1/3 -5.2)) (collect (exp x)))))) (do-test "Function LOG" (equal '(1.0 #C(0.6931472 3.1415927) 6.1176124) (with-collection (dolist (x '(2.7182817 -2.0 453.78)) (collect (log x)))))) \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS new file mode 100644 index 00000000..0b8a94a6 --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "13-Jun-88 17:45:50" {ERIS}MAIKO>HAND>MAIKO-UNWIND-TESTS.\;2 1473 |changes| |to:| (VARS MAIKO-UNWIND-TESTSCOMS) (FUNCTIONS UNWIND-TEST UNWIND-TEST-2) |previous| |date:| "13-Jun-88 17:41:59" {ERIS}MAIKO>HAND>MAIKO-UNWIND-TESTS.\;1) (PRETTYCOMPRINT MAIKO-UNWIND-TESTSCOMS) (RPAQQ MAIKO-UNWIND-TESTSCOMS ((FUNCTIONS UNWIND-TEST UNWIND-TEST-2) (VAR (UNWIND-SPECIAL-VAR NIL)) (PROPS (MAIKO-UNWIND-TESTS FILETYPE)))) (CL:DEFUN UNWIND-TEST (&OPTIONAL (USER::LIMIT 20)) (* |;;| "This function should compile so that the UNWIND opcode is emitted at TAG. Runs thru the tagbody 'limit' times, defaulting to 20.") (CL:DOTIMES (USER::I USER::LIMIT) (CL:TAGBODY (+ 2 (UNWIND-TEST-2 #'(CL:LAMBDA NIL (GO TAG)))) #'(CL:LAMBDA NIL (GO TAG)) TAG (SETQ UNWIND-SPECIAL-VAR (DATE))))) (CL:DEFUN UNWIND-TEST-2 (CLOSURE) (CL:FUNCALL CLOSURE)) (RPAQQ UNWIND-SPECIAL-VAR NIL) (PUTPROPS MAIKO-UNWIND-TESTS FILETYPE :COMPILE-FILE) (PRETTYCOMPRINT MAIKO-UNWIND-TESTSCOMS) (RPAQQ MAIKO-UNWIND-TESTSCOMS ((FUNCTIONS UNWIND-TEST UNWIND-TEST-2) (VARS (UNWIND-SPECIAL-VAR NIL)) (PROPS (MAIKO-UNWIND-TESTS FILETYPE)))) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ab34422aab10861c04069c8de41b7a9ed0dcce95 GIT binary patch literal 1281 zcmb7@-%k@k5XbknrKJ?GMW85&+>6FE9ue?I1!Fw!w)Eh7ce&fDBqpZ9DMD!pwkC#{ zsPXX<)QY(^`s6=Ad=oJwzWMGSVuG)v&R(mjnrLjAbZ2H~cD^&8K10!KiY_XZ)wMe% zcU`R1s%y2Xc&oB5-mTQu7hLfc_{9xkYtDm7*jQy1j#t**TdWceW+BP)`{K%iclVMY$0S>K-*@gctsWkbQ;)<_&M;%%D;v#ZUN#{D`5U+9W#H&1=7sACaD zlXVFK51Ww=-lPL(#z)-AyP@+IiGmRS1@^tZu?Y#FkusT|z-)P^{s&3)nx%l28}4dj zzwWN=Z!NF%z%bqAuWwh1JC95KJF_2_clEi0{dbu%LL(oWLq9s7Kj=q$+{5SIkMjK( z;M(g%XrX&=>HU*v58D2wuYB2kw3OKX#F=~UCDV#bm7HV~TCfd?nrZ(TtkjuzD9MK+ zY?!4Y0)E_pPp~UKgH11X!n8PPvhI5wx|Y{yC z5=$(VhTJHXXQoYcUYG)2;JF!yjQS};4fj~&Kr822`rWP>aP4Fs@-fvJF_VNMo1 a79hn&B5;!pun~~l-I5agfzhkkM&mnGFNaqE literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/OBSOLETE/TESTER b/internal/test/Maiko/OBSOLETE/TESTER new file mode 100644 index 00000000..c5233a96 --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/TESTER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "17-Jun-88 15:44:57" il:{qv}lisp>tester.\;5 6908 il:|changes| il:|to:| (il:vars il:testercoms) (il:functions test-equal define-verified-test make-test-defun type-number get-forms verified-test-to-do-test comment-p) (il:commands "COPY-TEST" "E-TEST") (file-environments "TESTER") il:|previous| il:|date:| "14-Jun-88 14:56:12" il:{qv}lisp>tester.\;4) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testercoms) (il:rpaqq il:testercoms ((il:declare\: il:dontcopy il:donteval@load il:doeval@compile (il:files il:cmlarray-support)) (il:functions test-equal) (il:coms (il:* il:|;;| "tester definition ") (il:define-types verified-tests) (il:functions define-verified-test make-test-defun)) (il:functions verified-test-to-do-test get-forms comment-p) (il:functions type-number make-test-defun) (il:commands "COPY-TEST" "E-TEST") (file-environments "TESTER"))) (il:declare\: il:dontcopy il:donteval@load il:doeval@compile (il:filesload il:cmlarray-support) ) (defun test-equal (x y) (equal x y)) (il:* il:|;;| "tester definition ") (def-define-type verified-tests "verified regression test") (defdefiner define-verified-test verified-tests (name message &body body) (il:* il:|;;| "Assumes the body is a form that returns a value or a list of values (comparable by equal) that may be computed at definition/compile time. NAME is a symbol and MESSAGE is a string to printed at success/failure") (let ((values (compile-form (il:bquote (progn (il:\\\,@ body)))))) (il:bquote (eval-when (load) (format *error-output* "~&Test: ~a, " (il:\\\, message)) (if (test-equal (quote (il:\\\, values)) (progn (il:\\\,@ body))) (format *error-output* "succeeded.~%") (format *error-output* "failed. ***********~%")))))) (defmacro make-test-defun (test-name) (il:bquote (defun (il:\\\, test-name) nil (il:\\\,@ (nthcdr 3 (il:getdef test-name (quote verified-tests))))))) (defun verified-test-to-do-test (filename pathname &optional (linelength 60)) (let* ((root-name (intern (string filename) (find-package "INTERLISP"))) (makefile-environment (get root-name (quote il:makefile-environment)))) (let ((*package* (find-package (or (second (member :package makefile-environment :test (function eq))) "INTERLISP"))) (*readtable* (il:find-readtable (or (second (member :readtable makefile-environment :test (function eq))) "INTERLISP"))) (*print-base* (or (second (member :base makefile-environment :test (function eq))) 10)) (*print-case* :downcase) (*print-array* t) (*print-level* nil) (*print-length* nil) (*print-structure* t) (il:* il:|;;| "Interlisp gorp that controls pretty printing") (il:*print-semicolon-comments* t) (il:fontchangeflg nil) (il:\#rpars nil) (il:**comment**flg nil)) (declare (global il:filelinelength il:prettyflg)) (declare (special il:fontchangeflg il:\#rpars il:**comment**flg il:*print-semicolon-comments*)) (with-open-file (stream (make-pathname :type "TEST" :version :newest :defaults pathname) :direction :output) (il:resetvars (il:* il:|;;| "Interlisp gorp that controls pretty printing") ((il:filelinelength linelength) (il:prettyflg t)) (il:* il:|;;| "Identifier") (format stream "~&;;; File converted on ~A from source ~A" (il:date) root-name) (let ((dates (get root-name (quote il:filedates)))) (when dates (format stream "~&;;; Original source ~A created ~A" (cdar dates) (caar dates)))) (terpri stream) (terpri stream) (il:* il:|;;| "Copyright notice") (let ((owner (get root-name (quote il:copyright)))) (when (and owner (consp owner)) (format stream ";;; Copyright (c) ") (do ((tail (cdr owner) (cdr tail))) ((null tail)) (format stream "~4d" (car tail)) (if (cdr tail) (princ ", " stream))) (format stream " by ~a~%" (car owner)))) (terpri stream) (dolist (com (symbol-value (il:filecoms root-name))) (dolist (form (get-forms com)) (pprint form stream) (terpri stream) (il:block)))) (namestring stream))))) (defun get-forms (command) (let ((unsupported-types (quote (il:fns il:specvars il:globalvars il:localvars il:initvars il:alists il:defs il:initrecords il:lispxmacros il:macros il:props il:records il:sysrecords il:usermacros il:vars il:constants export il:resources il:initresources il:globalresources il:i.s.oprs il:horriblevars il:uglyvars il:bitmaps il:cursors il:advice il:advise il:courierprograms il:templates il:prop il:files il:declare\:))) (filepkgtype (car command))) (if (member filepkgtype unsupported-types :test (function eq)) (progn (warn "Filepkg type ~s not supported: ~s" filepkgtype command) nil) (case filepkgtype (il:p (cdr command)) (il:coms (il:* il:|;;| "Recurse") (mapcan (function (lambda (x) (get-forms x))) (cdr command))) ((eval-when il:eval-when) (il:bquote ((eval-when (il:\\\, (mapcar (function (lambda (sym) (intern (string sym) (find-package "LISP")))) (second command))) (il:\\\,@ (get-forms (third command))))))) ((il:*) (il:* il:|;;| "Comment ") (list command)) (t (il:* il:|;;| "Should the filepkgtype of a definer") (let ((ignored-definers (quote (file-environments il:define-types optimizers il:sedit-formats advised-functions il:commands il:special-forms profiles xcl::walker-templates))) (definer-type (il:getfilepkgtype filepkgtype (quote il:commands) t))) (if (member definer-type ignored-definers :test (function eq)) (unless (eq definer-type (quote file-environments)) (progn (warn "Ignoring definer coms: ~s" command) nil)) (let* ((get-def-method (and definer-type (get definer-type :defined-by) (get definer-type (quote il:getdef)))) (defs (and get-def-method (mapcar (function (lambda (name) (if (comment-p name) name (funcall get-def-method name definer-type)))) (cdr command))))) (case definer-type (verified-tests (setq defs (mapcar (function (lambda (def) (destructuring-bind (tag name message &body body) def (let ((values (compile-form (remove-comments (il:bquote (progn (il:\\\,@ body))))))) (il:bquote (do-test (il:\\\, message) (equal (quote (il:\\\, values)) (il:\\\,@ (if (eq 1 (length body)) body (il:bquote ((progn (il:\\\,@ body))))))))))))) defs)))) (or defs (progn (warn "Can't parse: ~s" command) nil)))))))))) (defun comment-p (form) (and (consp form) (eq (car form) (quote il:*)) (consp (cdr form)) (member (cadr form) (quote (il:\; il:|;;| il:|;;;|)) :test (function eq)) t)) (defun type-number (type) (il:%cml-type-to-typenumber-expander type)) (defmacro make-test-defun (test-name) (il:bquote (defun (il:\\\, test-name) nil (il:\\\,@ (nthcdr 3 (il:getdef test-name (quote verified-tests))))))) (defcommand "COPY-TEST" (from to) (il:copydef from to (quote verified-tests))) (defcommand "E-TEST" (name) (ed name (quote (:dontwait verified-tests)))) (define-file-environment "TESTER" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (il:putprops il:tester il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/TESTER.DFASL b/internal/test/Maiko/OBSOLETE/TESTER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..43733862345783e3554f8899ccd43d1d067e1a87 GIT binary patch literal 8000 zcmcIpU2q%Mb>3Zo0Kp#+q^Lhyb|C8~BBYf`Te2k5O|S%(#F7gvv`+lQ)?=Ajcmq^)Nazxc8oW?!D)pd;WJ(@}G{G;n>WD*+MZ_3eQ}epS?IAJ~vYe&&^yc zP3FSq01v-*a`g4*(t2FC9X<60({R#X$mmW+w-5IpZF1@mCri1B`P|v?V5x9+;?kjT z@3HXk#pztQ_r&qz7#;09a-{F*iNj5Unq!KsfBTA~eLcqyH+}NQm0QZr8A+1P^S@?E zYHycm9FU}tq{x+<<=~)U>M>i_GJ4#!Vv1DxPB|2DGFmFG*>TlKrL&nxr5x%F&(F-N z#oQ~oB3<=@f?X=t%Z-ECR4ijysmii^S=ovWLvel3Na-r=i{*n>Gj{Y^X+5PhVu8=f zX0T-gx`DW1>wK}&URm}M1a!nR+JLE7${sKoAb(nmjc7vvGySWVt%g%`TK$WjfWl2z`>L;_BSy`-O1TpPq*-I2xmObdo z5&S6q{graZd~R+Y!g)4#t}tDgFU(Ab#l|h}^JK=-IDe@e9Mx@O(9q*5-Oyn`^ROo{ z(di;?n#c4~xh<)U=p0=IPBukrynM}$O~`7-QsWj!?EDCR1Sddq@K#C zY1%*>+Dv4rscdpUw^^7S64z=ZObDb?p+)I2z9ob}5JC4^Dz|fa(^I2{ZKY^ihgj8q zTDPs!Dy_FtDk&kBiKoOf%9R@mSk-$>g~F-Fk5`rL*v;~;&r)CMHroxsYlv#U2uW-= zWJ=*eMU<4~)A%<=f(GIATt)j=j|!+QKrNCq>E#mZYyf;501aIS49)dxdB`&j#wDp$ zk``COqA!-XuSdL}alF-U4L+j2Z4g-rrTSf-Pyl%IeQs$39r>inhIT=#KNtD<>VG!@bOKI;aq`@5w+FTCANXH># z1pg`Prsf9_!tML&w2NCnPy!I^BaA=C2CcM#021iW#M*bTcFU%XuHa~zs9;tta}n>xY^b@j~(NA{Y8wu z)cF$l*uc%wX#$a6Wr+(B&INI!lm5#Qf_XJEFOs$ z47LXdOVCT!C(MbQW_zi(RDOID&$$KJAl)H+g|2uqYh`q7vaGNvmiM!B-0$@M*NXIW zMGTut~Cq-o)t*j$(fE^68gO7o~t(-I% z>VdIN*4@tLgRI*Rw$ST{DVwaT%nm|EaJd8gAa48B+^e$_(`R!fGT7vtH}M?i_m*Tu z73IBzd?%r-4c`Un!(A{v_t4o0AE;;KyYL^t;?Kkoy^$^g(|i~2b-^rtwPBN4Y}vb) zn+WazD&;NJVV%X6J3w^{Y&E$_j>q~M`{)6nxI?LD*i;YOtzxVggJCqmh;G}Kt%`^u z@;E>~axYqD8@d5>9hMYW!gWOkR%BL7vVh>GGn-<7q{~;G1 z37Xd~tY+FaQW;@PSxJIC2yyTpVfH@Ov7HM=YcCr=%qE_|%kSKfSCub?Z%n35ge{M; zgPp_?M~AVBw*$AW4mYJG^&mUwXI~}x*-|&7pH9QoBFbV1m2Nmlb`U{ATI?;P$7X%I zNq?a7w9RGe3|R3oE_IIyQTud3+fw6GRO7-#!a~n-3;*i;=zl|CB#)mR^s;Ula^tVj z#vQNJERKP{#P%g@U5)$v;Pn=m`$5%}M>l{~yn>3F{%mt^@@TYkOWF}tWUk=(1kS-B zilRUR+?%|OXZxSsL=LhSlxEi5fER1PO|q#+Zvi6*jlM83S(*u7n3#eug)ov|y*OQe zJ${R~+}pe@vqR)Do~qnxAs+t?P(SxxZtCM3xuWOe?-rG!2gI-EipsBFe)y+F&qU%s zI;Hh*7N6s76efVA6%DWeQq~g>l&XQdgPR+>6nSlUark##w9f`zDYgQkP$;yY3Zg@6 z(1<^cq8HJHlHe@wdI7(_b)uLsJEcUYGDW?Firgg#PBle@Sep8%ZbpL>WmjWNB*0LWF5?xCC3G6~+rqWxByoG#LYa;phD4;6*&aWXJgLtDU)pk@#8*h%FknL=-$ zGlpz8*-WRt!~E2Ik8x7I3xk2|X;90WB7(XBfG?$=Li|8zix~Rhp&VR=#=l1fhN4Lt zT;YqYQz>HS9L*3H$5|lBniIH6CtZ$v@;cALul{ow=@XE!ad;`Wf&FQhc|z<8*7}yj z124oKe|au_FGqvx81Q5n&I!*%rh{^r2xr6xxO^y*O`ReJ!cAq6(7H2m}xnX z5b_uJD>n>1bK=<^4+W&n@K9OZp}Zt>0JQtRoE)Y8KFqb!n+gVdNn!)SJwQMk`N6-U z)Q>0c8xJk>nGcmN_;cdb$B74&3a=OF2NxsdX@vefP~dnrsj{(37pHkcRt#Ad^TY{S zCz=h#H*Oi8#lq$M<^1Y^yNs-efzaXlm6a!5(6CJ2ZdiGf>+AzBp$sc)D<9QPqWO*O zaSHzK!Id{fVMbe$pOn$ z`J)l=FR%~SMA!zN34EXP{~u`XZQi|1-9N-yL@-7wMx)DOVoEd#u|g9~p8$4=rW4zH zsQ}@nIss37ZDS~r*~dBq9OGBQV|~b_`%RdF@Jp8vn=I_3bG}t6D~G~gLmg$|$l3GA za{K%HQL~!8R4Sa$&xa38c87Z^hSw~0J6E< z{w4MZ;+dhPi3dJNiTkYo#=~Q}9X;!1xs^Ce>ZQvR#WZLGsGo=}{-7fAks?Y4+;CCu zKUP0@x_+S0rauCkLvHvPS6#KGyf^UWbjD6(QzJ)ivmT*a@>*1WFF}&M>yNm6M@g9T zAqoc`E=3j5S?!4`5a>Ll*tmXWIAq8W>3btLM$Db-SIjk&Ytappjd%t`4v4;d{`LSOs;sH;mo(-@S%N{7Y-J$v+~Hr(-A*7gQ`q-ChAS-Z41Q zt6L4CbTJ>IVU+YLA2L>V7*+4iYCY2Pwc*thQ3cn?zn{N9a{a2g(mf)d39ef~oU~*G zzi9=HqB0!3Z{A3z_P>8EmG64t9%<)?m-Bb|NvoGe_~JZPnb)r-SMsK;C}%?JR!Bb6 zfnViJ=epH-W*gNftWL^4@ONehA9esn;2kj7Q`R<2JY2H2eTzWbc)~$}BsNaoOj*JG z_usIB`K}k=HfSC2Slvqy_nFlHZa*OOI-;S6!2qBPv44Lwt(rofP^4Br& z2`5U!N%nPW#v#0Iww|;`^;%fKGkm#`^#VcqB^T#^r|wT6K0)Nv9|0u^y>oEiQ9Cy9Iq*@N~ls19~KBbu>x?RhC09}9q zAf0cnly{Tenw>fy=EbLlx$yMNe0c8S?CcDgF`~1fvK+=Kp1~BE+C~S5jUqfmzf}|) z+))5dLo?k$qmeQ)Zr`Vo-=+m#1UA$*(=5u{mW{F{hD6J0k=J49tMw?iO%sNH1GyEU zQ{9Ma-Zgx0l@w%kRHetEkWnOUR652B!l+tVJH~6vO@f9EK%2NtJx-%>*g0&a`DI%Y zmTeoTzE^LU9Wuw7gh$gR6U@G8FpZ>dvUb0k>iKxUE_&g!1nH66=M`)#L_`1CcM|Zh@9X>6E2n?2*oB74mE-51c3+MhhhN zjI#N96!v;a&)&hET6GF~)j`cLze4&cADa{n4;d5 z&4~+CFQd8N;lI!2MK#S6(`*hneg=S0_;~^L#93Q2q|zLC?PSvP2|E1AiZ*TQe5sq`)f zShpZ~7YP!!%u_Hzefl@<9#JW8L$Ls+`2tFT;U{b4JPDj?(QyZD>sHqT%;6vOIwSgN zJ;ps9oTR9-M;h2s4?fz#htkIv@1SiZ`9~ckW8u3Ey?UB*Gx8@*^%;ceMc-J;yw8#5ccVHlui6-gnTM`TtXlSiYUKC&VNcXGGGmTB>XL$*;3CL zLD43*@EeVBj_~gD8~3MBme;}Dd%wgHUc{~4?^EK+vw{pf4*uv_=!wJ#zgz|?W!HhK z^Z{ATO}|no%}ig&P0xp)6yK~i)6~(-IvTd(vKuv1c*G8HmS-ho1KQYDktF=B%(lw- zYb>jeq=vjBv*#$%vsmY%5(_`e))jzPaT} bGp{1oD8a!_(5FYt`Ttsa6ODZ3lTZE=Q5GHw literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/OBSOLETE/unwindtest b/internal/test/Maiko/OBSOLETE/unwindtest new file mode 100644 index 00000000..2668bb24 --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/unwindtest @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Oct-88 17:18:53" {POOH/N}VANMELLE>LISP>UNWINDTEST;7 1027 changes to%: (VARS UNWINDTESTCOMS) (FNS TEST2 TEST1 TEST.SIMPLE UW2.CHECK UW2.TEST.MAIN UW2.IDENTITY) previous date%: "20-Oct-88 15:17:15" {POOH/N}VANMELLE>LISP>'U'N'W'I'N'D'T'E'S'T;2) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNWINDTESTCOMS) (RPAQQ UNWINDTESTCOMS ((FNS TEST1 TEST2) (PROP FILETYPE UNWINDTEST))) (DEFINEQ (TEST1 (LAMBDA NIL (* ; "Edited 20-Oct-88 16:45 by bvm") (* ;; "Compute defaults") (LET ((F CL:PI)) (for C in (UNPACK F) do (PRIN1 C)) (AND (FLOATP F) (QUOTE SUCCESS)))) ) (TEST2 (LAMBDA NIL (* ; "Edited 20-Oct-88 16:53 by bvm") (* ;; "Compute defaults") (LET ((F CL:PI)) (LIST (QUOTE SUCCESS) (PROGN (for C in (UNPACK F) do (PRIN1 C)) F)))) ) ) (PUTPROPS UNWINDTEST FILETYPE :COMPILE-FILE) (PUTPROPS UNWINDTEST COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (535 899 (TEST1 545 . 720) (TEST2 722 . 897))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/unwindtest.dfasl b/internal/test/Maiko/OBSOLETE/unwindtest.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..1b89b4253c723e5f5ecb69bf150a14b6ab64d948 GIT binary patch literal 1096 zcma)6ZBNrs6u$R%V=thrA{nBIjR9XK!*#|m&=5=8xoT;f-cI2o!Vr>Sm$DfRAp!Mc z6Tk_%HToa?>LDq2s{^tpfQnT$+$cB_AR5;_%mvkSJpQKZQ^R5zKbO^JT--RaaL$T{CT!Ahs1|a@12SO>wonVL4SV z$HI&(HT_1uUVBxma{^WfbYa_JvRt)P&#*1l#v7y`8fG-TY*>1p_l5GZ-3=XMwxe4l z2?bqt)q|FCIHoki)enn_$l5WU0UVmAOqn_hQ-_Gm}G9qhT!W0r5pLb3Q4_Eoq;k-#D2Zh)KsK#prWLLVpOL^9Q$rZGsR_%0eS zL^)&UP9Bh6)+VeiKvpPQ6hfR!Egv6>M|Uya9CAtC$D4KZs6PS2*+;^{3&lbnWY3pM zTyMDqdhdoe&uS_3Im)szQ8Cb;RF{JkU4D#*k&q`cq14)@B zke&b>tbzkRgcpa0hNcw<1aqmEr`0Lo++#byE}f;GJ`I+Dx8*1+bXXHMxKzL8*(6u^ zzK&~HatcmeRg0^Ib8t@3s;cUgV*LK0(fb474glQI4qO0p3UTruh?fQjIoRkL!O<{5 z(e-HH1VwaXlU$8%^+Y+GjBX!~;9d~<0KRx9{?7#@4Oo*M7tnYlBa#B?BJSsuYCE&8 x@u=c)twV997Wl8>n-DboV6M6BzkG{O;yXTk9$f}zdcZagH$PV!eHuSF_yu=;Jj4J1 literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/OBSOLETE/unwindtest.lcom b/internal/test/Maiko/OBSOLETE/unwindtest.lcom new file mode 100644 index 0000000000000000000000000000000000000000..0222bb5dac2346832078d8f10f7a9ff1c18358f8 GIT binary patch literal 1892 zcma)7&2QX96!&HupoU6KbL$~`HK4Uu%Hr|b`&AUhv1hYRytZq5lSbvT$vW93%R1VR zv=!pS0jX!WapVpHdH{hcapH;q3I2;pf4t#C0=B923myF1VNG4-J|h(r2?c> z)6`l~7C;n^;*ZXH{ip-+00j8hbKS;!&L{7)d1Fs^n$))G1_Rk>Is2AlhBOFomn7f? zQd$q9v&5fTQ>!&n5#Vqb%^gM$&W59RYrrf>GAhtRkY?2BM-PEiXXb@ML4Zzsj6tB+ z`8H8&L}pR`9}z`;^}s=?R8%9`O2{D+e^CRiM#?p!y*%_>E9d0) za~6(fF3izfkPB}s5}!s?Gc{iHfPeuW$WWJnduNH`xEP<64A;2IagREgl}yIM)#_6A z@js2_?Dxwj9Cw`)6&XC=atII^S`Mop%yY2_LCY{`5a0_Gp;#a)(W**0g;d}i_Ol5&%S!{2C_N*8wnx; zDJ2T{)M)tuO_)ucB=ShSW7)hY@yzw?P{Qb<_tz5dsY48O>fn;?Lhxxmijb#y6hVQ! z$z}q1gUvGJxAJh&yLbg-?`N4rn=9EROc)}if@OQ%*ROKO=Pi!Ak){mwNb52wwz_WF zP(-;frnLHqcDdwukth(liF%}p@@b%fQczRMsm(NG4T6T-vdt~pa<<%-V|o~`3VR8Q zZPzua8zfB9Sq4MLR^Vg$KVum>Ub(e&+W76)D?c>)*Z%6?_~S=w=jnG6W3ppC`<%_6 zvVlF;&Yx3~{Bpwg3EN${wY-~s%&%e!@OKRb%>2~-xnZOC-|_9s=C^C?n9YVq&9CR{ zH&Yk8OZUF{1tnL?(4aP^Tv5Sr9YYVHT7nPizTTvPp*v7fz^7r|cbia>)3aK6c2uo` zzQxj2Rlv4FJ;YPxc}+q&EvUKP>{bwkV5gi64&%w71Ba6_jJolp-x=h_&~2Yb0uZc2 zA=M4~(eW70+rwV_upglvk*heq#8y^cWXnTI1CbRJD=t=OSacF-MRa&S9(G0osBC@s z5Qied4B{~yw}%i7;>k%D_t5n?j@h073X5@YKOr$1w~tN%8!fA>S^rA!oeiQ4cO{fP zi#lXBuXF4UP4AKDVP?YvY?!Q-gwtAO*-CmSFZ!N-=gxn&L7cbN*=J#P$u8aA+2*3N zE;{ZkMoB_NyjJM>t`}UuL3zCc-`Z}3_=&q44dVx3#KW_A*dF)d0jf}~RM3>s_!qL3 B#AyHk literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/OBSOLETE/xclopcodetests b/internal/test/Maiko/OBSOLETE/xclopcodetests new file mode 100644 index 00000000..09990a86 --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/xclopcodetests @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Oct-88 17:19:09" {POOH/N}VANMELLE>LISP>XCLOPCODETESTS;2 15906 changes to%: (VARS XCLOPCODETESTSCOMS) previous date%: "26-Sep-88 14:11:23" {POOH/N}VANMELLE>LISP>XCLOPCODETESTS;1) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT XCLOPCODETESTSCOMS) (RPAQQ XCLOPCODETESTSCOMS ((COMS (* ; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK))) (COMS (* ; "RESTLIST") (FNS \RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER))) (COMS (* ; "UNWIND") (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY)) (COMS (* ; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT)) (COMS (FNS CHECKSTACKSPACE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* ; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* bvm%: "14-Jul-86 17:54") (* ;;; "Test the opcode FINDKEY") (DOFINDKEYTEST (QUOTE KEYA) (QUOTE VALA) (QUOTE KEYB) (QUOTE VALB) (QUOTE KEYC) (QUOTE VALC))) ) (DOFINDKEYTEST (LAMBDA KEYARGS (* bvm%: "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 KEYA) (FINDKEYCHECK 2 KEYA) (FINDKEYCHECK 3 KEYA) (FINDKEYCHECK 4 KEYA) (FINDKEYCHECK 5 KEYA) (FINDKEYCHECK 6 KEYA) (FINDKEYCHECK 7 KEYA) (FINDKEYCHECK 8 KEYA) (FINDKEYCHECK 1 KEYB) (FINDKEYCHECK 2 KEYB) (FINDKEYCHECK 3 KEYB) (FINDKEYCHECK 4 KEYB) (FINDKEYCHECK 5 KEYB) (FINDKEYCHECK 6 KEYB) (FINDKEYCHECK 7 KEYB) (FINDKEYCHECK 8 KEYB) (FINDKEYCHECK 1 KEYC) (FINDKEYCHECK 2 KEYC) (FINDKEYCHECK 3 KEYC) (FINDKEYCHECK 4 KEYC) (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) (FINDKEYCHECK 8 KEYC))) ) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* bvm%: "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (for I from N by 2 to KEYARGS when (EQ KEY (ARG KEYARGS I)) do (RETURN (ADD1 I))))) (COND ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) (T T)))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) (BQUOTE (DOFINDKEYTEST1 ((OPCODES FINDKEY (\, N)) (QUOTE (\, KEY))) (\, N) (QUOTE (\, KEY)))))) ) ) (* ; "RESTLIST") (DEFINEQ (\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* bvm%: "21-Jul-86 17:13") (* ;;; "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") (UNINTERRUPTABLY (LET ((CALLER (\MYALINK)) CALLER2 IVAR BF) (COND ((AND (fetch (FX FASTP) of CALLER) (EQ (SETQ IVAR (fetch (BF IVAR) of (SETQ BF (fetch (FX DUMMYBF) of CALLER)))) (fetch (FX NEXTBLOCK) of (SETQ CALLER2 (fetch (FX ALINK) of CALLER))))) (replace (BF IVAR) of BF with (add IVAR WORDSPERCELL)) (replace (FX NEXTBLOCK) of CALLER2 with IVAR) (add (fetch (FX PC) of CALLER2) -2) T))))) ) (RESTLISTTESTER (LAMBDA NIL (* bvm%: "21-Jul-86 17:28") (* ;;; "Test the opcode RESTLIST") (AND (DORESTLISTTEST (QUOTE KEYA) (QUOTE VALA) (QUOTE KEYB) (QUOTE VALB) (QUOTE KEYC) (QUOTE VALC)) (DORESTLISTTEST (QUOTE (KEYA)) (QUOTE (VALA)) (QUOTE (KEYB)) (QUOTE VALB) (QUOTE (KEYC)) (QUOTE (VALC))) (DORESTLISTTEST) (\COMPUTED.FORM (CONS (QUOTE DORESTLISTTEST) (for I from 1 to 200 collect (BQUOTE (QUOTE (\, (LIST I))))))))) ) (DORESTLISTTEST (LAMBDA KEYARGS (* bvm%: "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) (RESTLISTCHECK 2) (RESTLISTCHECK 3) (RESTLISTCHECK 4) (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) (RESTLISTCHECK 8))) ) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* bvm%: "18-Jul-86 15:01") (for I from N to KEYARGS collect (\REFCNT (ARG KEYARGS I)))) ) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* bvm%: "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND ((OR (NOT (EQLENGTH RESULT (IMAX (IDIFFERENCE KEYARGS (SUB1 N)) 0))) (for R in RESULT as I from N to KEYARGS thereis (NEQ R (ARG KEYARGS I)))) (HELP (CONCAT "RESTLIST." N " returned " RESULT " instead of " (for I from N to KEYARGS collect (ARG KEYARGS I)))))) (for TAIL on RESULT as CNT in REFCNTS as I from 1 do (COND ((AND (NEQ (\REFCNT (CAR TAIL)) (ADD1 CNT)) (NOT (fetch (MDSTYPEWORD NOREFCNT) of (\ADDBASE \MDSTypeTable (LRSH (fetch (POINTER PAGE#) of (CAR TAIL)) 1))))) (HELP (CONCAT "Ref cnt of " I "th RESTLIST element was not incremented") (CONCAT "Was " CNT ", now is " (\REFCNT (CAR TAIL))))) ((NEQ (\REFCNT TAIL) (COND ((EQ TAIL RESULT) 0) (T 1))) (HELP (COND ((EQ TAIL RESULT) "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\REFCNT TAIL))))) T) ) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) (BQUOTE (PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS (\, N)) ((OPCODES RESTLIST (\, N)) NIL KEYARGS) (\, N)))))) (PUTPROPS \COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (* ; "UNWIND") (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* ; "Edited 26-Sep-88 14:11 by bvm") (for D from 0 to (OR DEPTH CLOSURETEST.DEPTH) do (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE (QUOTE SUCCESS)) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) T) ) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* ; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET ((*B* 3) (*C* 2) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UNWINDCHECK1 DEPTH) (LET ((*E* 10) (*F* 11) (*G* 12) (*H* DEPTH)) (DECLARE (CL:SPECIAL *E* *F* *G* *H*)) (* ;; "There are 8 pvar slots in this frame (for 7 pvars), so empty stack = 8+2 = 10. Right now the stack depth is up to 13, because of two bind marks and the value returned from UNWINDCHECK1.") (UNWINDCHECKFAIL T *B* *C* *D* *E* *F* (QUOTE PREVPREV) (QUOTE PREVIOUS-VALUE) (PROGN (* ; "Unwind stack to depth 10 + {0,1,3,6} preserving tos when code is even") (SELECTQ CODE (0 (* ; "Blow away whole stack") ((OPCODES UNWIND 10 0))) (1 (* ; "Same as 0 but keep tos") ((OPCODES UNWIND 10 1))) (2 (* ; "Blow away second binding only") ((OPCODES UNWIND 11 0))) (3 (* ; "Same as 2 but keep tos") ((OPCODES UNWIND 11 1))) (4 (* ; "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 13 0))) (5 (* ; "Same as 4 but keep tos") ((OPCODES UNWIND 13 1))) (6 (* ; "Don't touch the bindings, just get rid of some dynamic stuff") ((OPCODES UNWIND 16 0))) ((OPCODES UNWIND 16 1)))) (PROGN (* ; "Check that previous opcode left the stack in the right state") (UNWINDCHECK2 CODE))))))) (T (* ; "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) CODE)))) ) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* ; "Edited 26-Sep-88 14:08 by bvm") (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* bvm%: "21-Jul-86 13:15") (* ; "This just prevents compiler from merging specials") NIL) ) (UNWINDCHECK2 (LAMBDA (CODE) (* ; "Edited 26-Sep-88 14:10 by bvm") (* ;;; "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") (LET* ((CALLER (\MYALINK)) (EOS (fetch (FX NEXTBLOCK) of CALLER)) (GOODEOS (+ (fetch (FX FIRSTPVAR) of CALLER) (UNFOLD (+ 10 (LOGAND CODE 1) (SELECTQ (LRSH CODE 1) (0 0) (1 1) (2 3) 6)) WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT (UNWINDCODE CODE) " unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words"))) ((AND (ODDP CODE) (NEQ (\GETBASEPTR (ADDSTACKBASE (IDIFFERENCE EOS WORDSPERCELL)) 0) (QUOTE PREVIOUS-VALUE))) (* ; "Should have preserved tos") (HELP (UNWINDCODE CODE) " did not preserve top of stack"))) (for V in (QUOTE (*B* *C* *D* *E* *F* *G* *H*)) bind SHOULDBEUNBOUNDP do (SETQ SHOULDBEUNBOUNDP (SELECTQ (LRSH CODE 1) (0 T) (1 (FMEMB V (QUOTE (*E* *F* *G* *H*)))) NIL)) (COND ((\FRAMESCAN CALLER (\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT (UNWINDCODE CODE) " left variable " V " unbound but shouldn't have"))))) (PROGN (* ;; "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") (RETFROM (QUOTE UNWINDMAINTEST) (QUOTE SUCCESS))))) ) (UNWINDCODE (LAMBDA (CODE) (* bvm%: "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." (LRSH CODE 1))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* Value stored in high half is one's complement of number of values bound) (LOGXOR (fetch BINDNEGVALUES of DATUM) 65535))))) ) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* ; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (UW2.TEST.MAIN)) (T (* ; "Separate call so the compiler doesn't optimize out the recursion") (UW2.RECURSE (SUB1 DEPTH))))) ) (UW2.RECURSE (LAMBDA (DEPTH) (* ; "Edited 20-Oct-88 14:56 by vanmelle") (* ; "To foil compiler") (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* ; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) (*D* DEPTH)) (DECLARE (CL:SPECIAL *B* *C* *D*)) (LIST (UW2.IDENTITY (QUOTE TOS)) (LET ((*E* 3.5)) (DECLARE (CL:SPECIAL *E*)) (* ;; "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) (UW2.CHECK)))))) ) (UW2.CHECK (LAMBDA NIL (* ; "Edited 20-Oct-88 15:49 by bvm") (* ;;; "Check that the UNWIND opcode executed prior to this did the right thing.") (LET* ((CALLER (\MYALINK)) (EOS (fetch (FX NEXTBLOCK) of CALLER)) (GOODEOS (+ (fetch (FX FIRSTPVAR) of CALLER) (UNFOLD 9 WORDSPERCELL)))) (COND ((NEQ EOS GOODEOS) (HELP (CONCAT "Unwound stack " (COND ((GREATERP GOODEOS EOS) "too far") (T "not far enough")) " by " (ABS (DIFFERENCE EOS GOODEOS)) " words")))) (for V in (QUOTE (*B* *C* *D* *E*)) bind SHOULDBEUNBOUNDP do (SETQ SHOULDBEUNBOUNDP (AND NIL (EQ V (QUOTE *E*)))) (COND ((\FRAMESCAN CALLER (\ATOMVALINDEX V)) (COND (SHOULDBEUNBOUNDP (HELP (CONCAT "UNWIND left variable " V " bound but shouldn't have"))))) ((NOT SHOULDBEUNBOUNDP) (HELP (CONCAT "UNWIND left variable " V " unbound but shouldn't have"))))) (PROGN (* ;; "Escape from test because the UNWIND there has confused its stack") (RETFROM (QUOTE UW2.TEST.MAIN) (QUOTE SUCCESS))))) ) (UW2.IDENTITY (LAMBDA (X) (* ; "Edited 20-Oct-88 15:19 by bvm") (* ; "Identity compiler doesn't know about") X)) ) (* ; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* bvm%: "21-Jul-86 16:40") (for D from 0 to (OR DEPTH CLOSURETEST.DEPTH) always (CLOSUREMAINTEST D))) ) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* bvm%: "21-Jul-86 16:40") (COND ((OR (NULL DEPTH) (LEQ DEPTH 0)) (LET (VALUE) (PUTD (QUOTE CLOSUREFN4) (MAKE-COMPILED-CLOSURE (fetch (LITATOM DEFPOINTER) of (QUOTE CLOSUREFN4CODE)) CLOSURETEST.ENVIRONMENT)) (COND ((NOT (EQUAL (SETQ VALUE (FUNCALL (GETD (QUOTE CLOSUREFN1)) (QUOTE A) (QUOTE B) (QUOTE C))) (CLOSUREFN1VALUE (QUOTE A) (QUOTE B) (QUOTE C)))) (HELP "CLOSUREFN1 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (FUNCALL (MAKE-COMPILED-CLOSURE (fetch (LITATOM DEFPOINTER) of (QUOTE CLOSUREFN2)) CLOSURETEST.ENVIRONMENT) (QUOTE A) (QUOTE B) (QUOTE C))) (CLOSUREFN2VALUE (QUOTE A) (QUOTE B) (QUOTE C)))) (HELP "CLOSUREFN2 returned the wrong value" VALUE)) ((NOT (EQUAL (SETQ VALUE (CLOSUREFN4)) (CLOSUREFN4VALUE))) (HELP "CLOSUREFN4 returned the wrong value" VALUE)) (T T)))) (T (* ; "Separate call so the compiler doesn't optimize out the recursion") (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH))))) ) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* bvm%: "18-Jul-86 14:07") (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* bvm%: "18-Jul-86 14:48") (LET* ((CALLER (\MYALINK)) (PVAR0 (STACKADDBASE (fetch (FX FIRSTPVAR) of CALLER)))) (COND (CLOSUREP (COND ((NEQ (\GETBASEPTR PVAR0 0) CLOSURETEST.ENVIRONMENT) (HELP (COND (FUNCALLP "FUNCALL of a full closure") (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((fetch (PVARSLOT BOUND) of PVAR0) (HELP "FUNCALL of a null closure stored something into pvar0"))))) ) (CLOSUREFNCHECK2 (LAMBDA NIL (* bvm%: "18-Jul-86 14:51") (* ; "Nothing really to check for now") NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* bvm%: "18-Jul-86 15:30") (* ; "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4))) ) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* bvm%: "18-Jul-86 15:30") (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* bvm%: "18-Jul-86 15:37") (* ; "Vanilla closure called via FUNCALL") (CLOSUREFNCHECK T T) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4))) ) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* bvm%: "18-Jul-86 15:37") (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* bvm%: "18-Jul-86 15:53") (* ; "closure called via FNx") (CLOSUREFNCHECK T NIL) (LET ((DUMMY1 T) (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) (CLOSUREFN4VALUE ARG1 ARG2 ARG3))) ) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* bvm%: "18-Jul-86 15:38") (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFINEQ (CHECKSTACKSPACE (LAMBDA (N START) (* bvm%: "18-Jul-86 16:23") (PROG ((SCANPTR (fetch StackBase of \InterfacePage)) (EASP (fetch EndOfStack of \InterfacePage))) SCAN (SELECTC (fetch (STK FLAGS) of SCANPTR) (\STK.FSB (add SCANPTR (fetch (FSB SIZE) of SCANPTR))) (\STK.GUARD (COND ((EQ SCANPTR EASP) (* ; "Guard block not at end of stack, treat as a free block") (RETURN T))) (add SCANPTR (fetch (FSB SIZE) of SCANPTR)) (* ; "reached end")) (\STK.FX (* ; "frame extension") (CHECK (fetch (FX CHECKED) of SCANPTR)) (SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR))) (LET ((ORIG SCANPTR)) (* ; "must be a basic frame") (until (type? BF SCANPTR) do (CHECK (EQ (fetch (STK FLAGS) of SCANPTR) \STK.NOTFLAG)) (add SCANPTR WORDSPERCELL)) (CHECK (COND ((fetch (BF RESIDUAL) of SCANPTR) (EQ SCANPTR ORIG)) (T (AND (fetch (BF CHECKED) of SCANPTR) (EQ ORIG (fetch (BF IVAR) of SCANPTR)))))) (add SCANPTR WORDSPERCELL))) NEXT (CHECK (ILEQ SCANPTR EASP)) (GO SCAN))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS XCLOPCODETESTS COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1589 2741 (FINDKEYTESTER 1599 . 1788) (DOFINDKEYTEST 1790 . 2418) (DOFINDKEYTEST1 2420 . 2739)) (2975 5359 (\RESTLIST.SPLICE.FRAME 2985 . 3614) (RESTLISTTESTER 3616 . 4044) (DORESTLISTTEST 4046 . 4291) (GETRESTARGREFCNTS 4293 . 4447) (DORESTLISTTEST1 4449 . 5357)) (5883 9346 (UNWINDTESTER 5893 . 6159) (UNWINDMAINTEST 6161 . 7581) (UNWINDMAINTEST.RECURSE 7583 . 7699) (UNWINDCHECK1 7701 . 7823) (UNWINDCHECK2 7825 . 9218) (UNWINDCODE 9220 . 9344)) (9717 11599 (UW2.TEST 9727 . 9963) ( UW2.RECURSE 9965 . 10084) (UW2.TEST.MAIN 10086 . 10533) (UW2.CHECK 10535 . 11479) (UW2.IDENTITY 11481 . 11597)) (11630 14526 (CLOSURETESTER 11640 . 11779) (CLOSUREMAINTEST 11781 . 12733) ( CLOSUREMAINTEST.RECURSE 12735 . 12833) (CLOSUREFNCHECK 12835 . 13320) (CLOSUREFNCHECK2 13322 . 13428) (CLOSUREFN1 13430 . 13693) (CLOSUREFN1VALUE 13695 . 13802) (CLOSUREFN2 13804 . 14067) (CLOSUREFN2VALUE 14069 . 14176) (CLOSUREFN4CODE 14178 . 14425) (CLOSUREFN4VALUE 14427 . 14524)) (14705 15673 ( CHECKSTACKSPACE 14715 . 15671))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom b/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom new file mode 100644 index 0000000000000000000000000000000000000000..4f34b32d411e689c9b65d1dd22231166f878f996 GIT binary patch literal 13116 zcmeHOYiwM{b-qhdqO!7FQj%TQErjvr;iXbBdmsCfQ-^mS6qj7?u6LJu#3~d@yEK=( z;;MW|af$$K`om6IAdQnWMNkw7&=>{UqO@e8wv(29{E-b9sA>hUfc|J5xJ7~fVBi8p z|D^rCb02$`OG&kV+m`muJ$Gi#d^6{qIp@qMn#)fYO8FDhg<}3hp)_4q$EtZdSGP08 zyowY`^?bEhs8u5BSjEoH*{Ax56X7V^WznLZzJJ5j#0aUzvcdh(>6K53*QDjK=e zy?mwBX*N`MRYlZqR?6j>&y~LVc|M;$ZI|Zr#bW+xGI{!JwpgxY%ej0#U#r)iGA2|w zq9;z&npdPx>!g)Fsiz|9;#$-1wE5*LYwMprsaCri%dOStR0~Yzn~hHMd8MblrjwJC z5!G1Sz#t+$s&1XsV<*j64Pw zuT7{cYt5^z?&i9T5LF{a5VNkIG|Y$!e~1C-6JacBZZ3b06Pd57leu`fR46L#F%ADc zH}EICU(?34sG+M|InWaGq9@g9yO>qFrO+LoI^Q!Y#n+6A^UYQU-)vN$2={d$jH4A5 zlke4202}&YNE_0c;~@^?Sg4KPgPQj0@Yh}m{XQu}ouL5ft0WC~h6AJ(l14fs0n!ZXucU3Q`%LAS_Ouxb7BAud*q|26YUtG6ck_9CIt{Y2lSoddjV=CuLxu zIB-yiyG(UUKG{k)g((V#j1UD~n4%Dq$}9*|TS4Z*6Hj4jtAtxK;g~`dck4mKrJm{5 zGh}4s;m{pUgO*eGOsApjQtb?Ectz=|fd8c-p1LaGH>Rrj+Cs6erj^4Wjs*Rj7VyLyWILyv1Xs^V$v@Jrn_{KhT(v{u(Qnv2-^ zm+)fo<63iLb8VITu(D9Y-E1bY1)m3yI^2NzWUW#xWb>2LReL_~O@pN})0hHN6|jw> zV5qDOzoBZ#yf|ePW9q#4EY*dIxG)n+EA9iF@iA>_Tpwu{Zod`US=o8@sWv9z?)lrd zLeI7v1w1bQ{Qb_MyI;J0Yh>ruW9{PYIn2?sZ-?5mx98p-!EfW%zRN$q^Y%VW2R2e} zrrhkjA@AB|hdW?-k8PGa-S9J0ZsAGq)5p)=G<`f5AJ2s+1L0fZ zx~9bA2blFm{JCG0mS zC0R0AN}vRjh*F#-X<@M>EliY5X@Mvxh5Z%vbd-#Am_;(dUK`a@WC9c@kqO3(5}Cj- zqeLb#GD(q1Oj?i$c1qB|B$<{LV3LG002-Jiu`#0*n+T)GCP^?!Vy8n1Op@5HQ38`B zCLJX(NfJ9YS(c;)m?Q;zl1v19l1v19l1v1953XdBm{gMOcH`U4kih~ z9tV?zV2^`ILa@idBq7-2V3H8*7JwuYIx$&fBH%4D5%3n72zZN3WZ^9`5$qP32zHB1 z1iM8hg54q$!ETa?U^i31lo0SHnFx53Oa#11CIa3h6TxnRNnEg-U=kPXCYZzpy9p+7 z!ES&_T(BDe5>FawK_-ITAQQo^lZjy0 z$waX0NnnZ#c%4iHyiO(pUMCX)uak*j*U3b%>trI>butm`F)|VCF)*9hq8y^??8O1 z>=tpS**#&W**j6E**P&&(Jexznp;FnEw>1mN^TJ^b=)Fcs<=h8)Nm_CRZ6jIf~A6+ z#F|3aboQfEZ<9cw-6)`I>b6OkRBe+eso4zRqEu{?7^&ALAtuqYNr=$uuri5}T5S>| zmD(gk>abA71FCNWZzO)e-D z83oj)8XJU2Ej9>|O3ctAN*y)`kt%EuA~o0`L@KaBh}2($5TU+dlu(=MYY-!q*C0gd zu0e=YU4sy*xdtIpaScMG-Wr5RwKWKlT5Av@mDV6c>a1bVFhFOOL5$Q`gUd*TH3*UV zY7ipT)gVM_D>e=k(6vs8)Kyr16woz8(z)*kbX^Q z!wwC37}72YZN#A=8ADoGX!{%*GBTt+CA9qx4QUzDo)p@sLql$cv?HK(4mc#_XFwX$ zun{sv5Co*l5}wM}Nkn*7%}-}b^%_<$g(xvwvcsOg#PQQeq*6v5A^hyVkQQ2)8aGB5yel_$$MXMp?q;~S z{P?qP6xs;j-!FdVM_d0rOHoKGM9*AosI?cEI|&B%=%i))$L|!;7Pv0Nj*3MHtnS|Wc;B|J%r?gede)D`|jPw%FlkVy@Eu- zAD?;5&Ws-!E)3s1xqSHgGX3`qeLu59exIJ3oE* zy?=a5(^ht_e~QB^ALcJqPF^0B-=l2$kfv>Yx_p$K9JP18wenl-og2Tz;&)i*cbtm& zih+XTkc?mm!z&+d-??yj`<4Iw4GpH*&8!#+%U?nRqUbHBVI;kji-FXUPllFxnHU&! zkE|m%CW#tm9o_Hg6a|985Ff||=AS9%OQ-5HOx_?Xc78rrt3Q9GSzo-^X(}giMmc0I z#}i3pb_}L=s?8;JX?26?98a3m#$v0ZTI)Q2!2wS*f||(d>{avXVrR4IRsBkHt&6%y z6Gna&ZLg6Y!48bPSmewi%CZSYHkNywnw{q5Cb(b2XL4(;URo1Mvk}3**grm`m*VK8 zKLHi%OF+?q!AQNV6H-tMr877-2_$o%q!J7+-G^*+JDyI4>*eio9Zx}x0$o5)v+RGOw|^$ z*?bN2uW%YxTd2xm*rdZ03t=Wyq`#SJv>GxYPHs(I>aO8@Y@_qMkH}--?RW`weCD_) z`SDYHTI%>TpQbvV=hINfbA0ORc$UwYI-WT$%Fn~OzDam-RMUp0{$Q%H^1+R-Y&ojw?_|YTVH7Jd}s7fXe((qIzyx# z)V4m`83yrSXe$EZ2#H~B>(S1>oo|nZL%(Zx_M-W<3$~PNrJlZc}4NWb*G;$-2xWTB&IP zVwO{?Sg6}|c4j4gi=ZQ8-Y;#C;P@{2M0*J>B5HH>Vs~@3p)PK2sP*OUW~Z_GUV`v?qf# z5HR3a-nCvh1z&HjU2WpH{0euN^^L_#?FbKABI;Uqt+9^n0jE2un{Ukj zC7VbYt|PmkrTKd-IUG9II9Q$;z=3GMl)$ifmL%bN3NR3^#Xw{Zi-GBa5%Ek!GVNQ4 zq$5!Ndds{b8o$3W&>@GeAP<-X2JH7W2{_ihM_Xhi5rpru0EpY6HLgM<-NnwS&)8K5 z^cj9|PoHrn8(A1o=YTLdvRzcsm^wRwW#?8In(Ess0}hpYDMq5Oez)$}5Zmo`>#&4B zSRNA>ZU?If_u6sJJl6^{y|=?Q5#CkP)4>=|8Q@O@Eyedjwzx99RFa7n6yTV}Zv zZe1pTq&<(LomH4F=}vQO!(MZo<|FdXA*rY;3wRX9EBWLn{Z_d_X3c#uoYA? z%VbnWrDJ%-M(uJE)ykJn7pi64Ttn!LT$?`#1Nn8dgSz5o6!v!Hit&nFJA+&;UJ-Bj zb#WQRpOt}5d-8=zl-&v{>NkaXgt=rO&?EH@);E@$>e^ZtSK%b!LTJPw%dctNrzSU0 zzoLHciUTt3%fSP7C%5yS(zxg7KGQyvud50U`(qM-xF`H{sNDswINquw02L_wuMNSk zUK$?{wdt(hetqh?Du~wX+<3(9cSNZh(B`+aQQQUi1Wh&c8yhmNorq+)(oE6tHGTIY zaS?DOCgRB(T$V+(y4mTdOP%ie=2{aTOm_`89oD;-o8H~Tjjp-^hbsnymxR^xd>^Ul zw`;CmZD9c=*u`~5rvai>7|ZM;`bQ`0&tJaS?Wk)l1jt#JU8A|wT5WB#x~uTyu;hIM zTM7&e&PxA;J8{Fk0t~;deM7jRz*?bT$U32b z%(8YAYc#Tq$!=ktU}&c7OxE?W0(#^sGjdWsZ#O^-XuME-H^;B&wiQ9dX5bFW9g;gB zs5FOz@xWYaBOC<6NCc9>yB&UyepL0*VLw9Htp>zy5Vvnsr%SF4L|)Nn?&9|C&vfY? zxZSoN26r}NPu&N%V|ZNmYj5liSZR2OeULHR^m+p;?d=dB1+m-KLwv6#hOi+UnGvM@ z3rrssiE{klZnJ;W$WY~K;gk~{+cgHx$jKnatJJF^(oC(_MW#y-pa$HGA?(bzj`3#{ zc_75gZ)rmfBrU$bJ;UHRbmz6L|3q47=lYTDnMPp;Ng|K@6J#{LCjs_rTW`)FXXG?S z>f_}ZTtIql>t}qNJ+k%ZBAL-7t~af2G}o3EFEuNR&o!ZH{R9{#{6TJ_UO&fuvx>~p zUU!be(Q3th=9xV{sc4k9lHs_ir~La_kqH%@F4a`vZZI6EzDu9|Z_xE9u%VT~0eI;-Zv^+cCg#V&<;IH>ZWhx6v5-jy71^O@dm>u=IdH5s3upr9`J2{H+Y9}L)q z5>^>xP3P_ET&-BHbF>r{FA$Z27vXwDCm8L;g?&LGI_ODYIO1(@8_o5Nbq}^{A6?w; zn+Mdhp5D6;yx*#-fnCu59xzAle&T-`bXomRj=}7`ic5-r!w?WH_oMg{62RjalXwG} z-k@{ogU|O|f(U0gATAz?K%e*Mt|v%bAX)#O`Qyi)h*L*JX^Uk$r*Lq(w+6c^U3K)v z&gGm!sc6sRXmA_ qviqN8Akwa!!v-)@$3I;;i&Kg(t891eN_TD1@vLx}D}}Mras5AU(#WO& literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/STACKHAX b/internal/test/Maiko/STACKHAX new file mode 100644 index 00000000..889043c4 --- /dev/null +++ b/internal/test/Maiko/STACKHAX @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "15-Nov-88 17:16:48" {ERIS}MAIKO>STACKHAX.\;4 4101 |changes| |to:| (FNS CHECKSTACKSPACE) |previous| |date:| "27-Oct-88 14:58:37" {ERIS}MAIKO>STACKHAX.\;1) ; Copyright (c) 1988 by I. All rights reserved. (PRETTYCOMPRINT STACKHAXCOMS) (RPAQQ STACKHAXCOMS ((FNS CHECKSTACKSPACE))) (DEFINEQ (CHECKSTACKSPACE (LAMBDA (START) (* \; "Edited 15-Nov-88 16:55 by jds") (PROG ((SCANPTR (OR START (|fetch| |StackBase| |of| |\\InterfacePage|))) (EASP (|fetch| |EndOfStack| |of| |\\InterfacePage|)) (*PRINT-LEVEL* 2) (*PRINT-LENGTH* 2)) SCAN (SELECTC (|fetch| (STK FLAGS) |of| SCANPTR) (\\STK.FSB (CL:FORMAT T "~6o Free Block~%" SCANPTR) (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "FSB size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR))) (\\STK.GUARD (CL:FORMAT T "~6o Guard Block~%" SCANPTR) (COND ((EQ SCANPTR EASP) (RETURN T))) (* |;;| "Guard block not at end of stack, treat as a free block:") (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "Guard block size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR)) (* \; "reached end") ) (\\STK.FX (* \; "frame extension") (CL:FORMAT T "~6o Frame Extn (use ~D) for ~S~%" SCANPTR (FETCH (FX USECNT) OF SCANPTR) (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX FNHEADER) |of| SCANPTR))) (OR (|fetch| (FX CHECKED) |of| SCANPTR) (CL:FORMAT T " FX not CHECKED at ~O.~%" SCANPTR)) (COND ((EQUAL (|fetch| (FX NEXTBLOCK) |of| SCANPTR) SCANPTR) (CL:FORMAT T " FX's NEXTBLOCK points to itself at ~O.~%" SCANPTR))) (SETQ SCANPTR (|fetch| (FX NEXTBLOCK) |of| SCANPTR))) (LET ((ORIG SCANPTR)) (* \; "must be a basic frame") (|until| (|type?| BF SCANPTR) |do| (OR (EQ (|fetch| (STK FLAGS) |of| SCANPTR) \\STK.NOTFLAG) (CL:FORMAT T " Non-zero flags in a non-BF word at ~O.~%" SCANPTR)) (|add| SCANPTR WORDSPERCELL)) (CL:FORMAT T "~6o Basic Frame~%" SCANPTR) (OR (COND ((|fetch| (BF RESIDUAL) |of| SCANPTR) (EQ SCANPTR ORIG)) (T (AND (|fetch| (BF CHECKED) |of| SCANPTR) (EQ ORIG (|fetch| (BF IVAR) |of| SCANPTR))))) (CL:FORMAT T " Bad basic frame at ~O.~%" SCANPTR)) (|add| SCANPTR WORDSPERCELL))) NEXT (OR (ILEQ SCANPTR EASP) (HELP "SCANPTR got beyond EASP")) (GO SCAN)))) ) (PUTPROPS STACKHAX COPYRIGHT ("I" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (402 4037 (CHECKSTACKSPACE 412 . 4035))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/STACKHAX.LCOM b/internal/test/Maiko/STACKHAX.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..8912c48ec772e70c2f169f7c5def336f12bcd3f6 GIT binary patch literal 1694 zcmah~Pi)&{6nDCI9YLTL4qQ<6WI!a762*?4I0jWXsa>16wikO-Ktaq+oX$xaSBX1d zgq)BNM-UQ!Bo2%V-1KYhs=01ESW}hi z*~S}O8WE)_NkL=^2iaK2*kLBJ% zYxUKou6qABYN6FzijMLpen3%_`Yc7Ap!+n@=tMv1OP9XaG54D|^c;rNIQF1^nAmOg zmZPK6T$-vyU-&CA;5|&xM|TgY?q#s&75#j^%SH8{Z!dW2ht!wq zYT_~}hP4-?} zJJAofJ~vm8=>3(0zx)@zHb_V3B$6ui7gg=y-NQ#W$UDI8JUM(+rBWQvfhy}3aQQq` zbWt&DTap8LPMEjy%$&vI<(?tgVs6f2ip6=06(-~iQ-VfAc~`EP7L@ooNTE1E@WKqh z%`xJYWO6WSG_-!`4cczgv)mnT1pJdegaXGiK%br5ogjp5@1vmKicd8S99zPBKlzp2 z7HqpizX|PuyX%1)!r07?U!$>i4(M?qfN~sGNI3Sh#c8$?^fPz7K>+QZyE6p84=(i4 zS61MIV9=VeC4m)??r~A2{`wFMx$cy8vr>h_cjQ=)rg+4eek6V;hAhfnia?=Dv%HWS5OvZoh=fFextx9sO@o~O=*LH0q(h{MjiCf&baY=#@5SWmd zk&s|vfG!mS>c_&CwPHi+!v9btBbY1BNt?7PQWxv)-Mf2FKixT;6>^dyOyne4n2?m5 z3S+v!Wle5c7Jw9ZnZTIF@p*0rQ%NxeU6u@uL_%S|gGa6@WPz~B3ANmuNTq;@W#Z{f zEJYwp%I^Ax?N}9XYe3+Ipi9QfyQW~6Q*)e@SEmdUCyQKRvUrDy0AW(SA&E>hnPF%W zg4VJ>#Tl=(pk>!uKxDhIQFiMV^y!n6lLT6oQqw}#=`qO+oygG13+$#)>>_&*WztL} z#ESx-@7Ol*RRqXn5qXJ{DEVDOxxnL5@Pz&_o?hz2DBf!YW~ z1(zslf6V`kjFN$>_~SbjtT;p7ZlsOLeqeFU+nOC3_&9r+qCU73MTu7^sx5YE2Zf!$ z&5ASP?cQ#SlK0lW+JPTnOCDSD|8JoVondeHX;;b*XGJIY(@z85n)l96Ui)({d3))q zpP{9tHE-`$H`xzVE9bfB)Z6OW^VtDp^uA!!MuCHG+rK&> zs%(n#HmV*ocIjhl`+?Emurl{&??zSeYir)8M{g8teYkySUwbcO#~B0u)WUU9`u%z5 z=&NrFpQ62Uv`K}d2^vH})*u>9121RpbGia7o9xF7-HRET?UK_`C>C>zg05;1XS!I7 z?O}KeNoW;|Qmtv#S4w3|E3H~BV9#U7glIeoZs$mYl0LQyM)!@T#_emm`|^&yWZ(=~N1diX?~r0cbjF A1poj5 literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/STACKHAX.LCOM.~2~ b/internal/test/Maiko/STACKHAX.LCOM.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..fa2897752d50bae1193314f828e2a94747dc8d43 GIT binary patch literal 1604 zcmah}OK;;;6m~N0Ji(|>0t%vO;&$9*;wtfs zc!aJ-LM#zTz=8$ChR3F9S+MK2up4PM`~x;f9>IFVxejU4j$pEg?mg!_-}jw+eNS#p zQFT)(sJfvPbW^op*_PxDX_q*TVd zr>p_Z2n92|Tc}ikDTzEMvJ4G5x*gu$3wnMB!amUOk>cp?$8UIw>#f!$eZyLHJ=D~s z#!B;bHjjwv90^+y`4XLh(bmA9@{C~AzSZjQ_(O37vZlxz34@E)6&MBm5zt03+-rve zA7*4LD=RdNI<3g>AYc|}%3_fhd4~S~W>}FgKFvJvj8Hx`hc=@S9p+Tih0Hmhc^K^t z{JTMTXNWlB3XwEhE?Dg-IX_+$Dk4{YiX@XiPYmLkkjdFl0Uc~8f#vAyxZvQL?ckLb z48>gcv}+h*XQ8(ggG3lmB-h485nNd^ZO=gx2Jmzp4_8GnL4_*FhNxOjUGnmf`uR$V zN^ers$ujx7)Ju1kURmsF4}PQ4o!(-6$Q=hEMN!%_6m^W@lT>pz{@z%;@QrbWqP|K} z&tXbSat|BhRHM_o6dzXS$}~OxEXXE+cd@vR#r6LveyMjczCWfupJ);r7d|0{=?A|q zJUelK#t?M)rq)aUP5`NRH~xZb?h)YS_(<%M9X7DJ8y~$q*_@=hohPx_P5i^z_7=3i zzdjdfjH!FtQtBcRL+yq5M_e7F#=~C@{yc+CB)`+lgVj^)q42NIlhjiBvX!--|Lf?* zu9YQJyYaWTKDDw)^j`MhkKpQ;Cg~s*|8(=}gqCznbQ&*c`lI{f$6a#Vcyh<%$D34+ z=Zc^yh7Ei%xzd}GV*gb{4{AB6o*@&VJ>l7LTq z@~gEvu+)d2G=EyFHeMTosWiNrVaXe? z7Y6-k2vG<@H1vDhQ?3lKLTRoD`e-P5@HiBwdJJEk=p{;^ydU*pI~>5iOH>(_0ebyT zYk+2ZVY>^%;6oo@99GkS^E7cf$=668YchZrLaT1=43^`jD!va>D4v*OOV_WHr<{yh s*{ZvcOD5C#!IVd^eZ#Zy0^L(Q$d>&!P7=+-d9I_~YNdieQ#UgI04b>4H~;_u literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/STACKHAX.LCOM.~3~ b/internal/test/Maiko/STACKHAX.LCOM.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..11580a06e6ce19e698691ccbe4128efc6ef1e0b2 GIT binary patch literal 1678 zcmah~OKjs*6m>G~bO;}%uwa9#D+3}KDN+2($Dj%)b!t<`_Sgmmlo8`5PRB{ct`g4x zL+A<#vE(BG3l88LFj++J-Fwct=e}oO=QhNq ztcr!EtcV3!ZECQl3ym#dQv_00EzwY9Qzv1~5QPm(s4Ez5Hxvxi1ycm7l+WZMY6J6@ zxB(=^6;%IDp;`s1%yTqPaU|r(u77LS9XUPlJs{yj(U8rLUb95gT5k#RmbPwMSW^<( z#m=it9uc*K2wmmbGMRzt_SiYqnZmSt)An|p2|tB~BsR8U1rx1{Fm=5tkcvCm?fPQ} z7GlL>k%Vc_4xAnW7ICV=msp;q$p3GK;u-dF=7FV3%$Yf~8TjZh*Hlf&T=1EP>F(IM zKhylB6pItsBJW$MRg2XDW{=N#!pJ1HZv#aynE&1|71d)3ErNkmNF|8?o9xdSwYpo2H0QTq1? zkO~Lkm(k|q2zVttT*;J zYcGX|FU*&NBpGWy_<8@2bKKa%_maB5e#SlEPJADyR?}CstoF>`htChSY$QDhzq|RV zmPMg=v-^L#&wiyw9i6inRcSvb$$#COJ-i+rKAz*z?4d#AShfO^sOZ4bWoRgTQ!`qE z1q@3icQl*W(bZ&*E;ET7RVgKRbagIHQ8nmvn(v5)rbCTOK*}fOx#|MICN%I}q)IUD zbYw4Z#(lf%==P2?1@6%pLV;yjAWt9J9Y26==L6sC#g8+IJ<|BX&wq8h2ix|Czcn^}WJfXY50NWbaJC^}q%XWA!Gy=Z|{} zwG7Y|lshTfY`-!ARcu>zMQd!quJ3xm1Ogx2VB(DW3mVW|Ex|(VU_Rh*xGtPh9QG4A zjXi?+e&9jhAH$xBeltMfwUL{*ZS=D}^1DNrxOW|VjZpx{9yO=V^YthnHHo)LHqH7u zC{sSI;y7@M#M3r(;o7xmD8xg%p|woN#WU{Wh|42bf78}Uj~^3 Ms#dKcP?eR;zrB(1+W-In literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/STACKHAX.LCOM.~4~ b/internal/test/Maiko/STACKHAX.LCOM.~4~ new file mode 100644 index 0000000000000000000000000000000000000000..8912c48ec772e70c2f169f7c5def336f12bcd3f6 GIT binary patch literal 1694 zcmah~Pi)&{6nDCI9YLTL4qQ<6WI!a762*?4I0jWXsa>16wikO-Ktaq+oX$xaSBX1d zgq)BNM-UQ!Bo2%V-1KYhs=01ESW}hi z*~S}O8WE)_NkL=^2iaK2*kLBJ% zYxUKou6qABYN6FzijMLpen3%_`Yc7Ap!+n@=tMv1OP9XaG54D|^c;rNIQF1^nAmOg zmZPK6T$-vyU-&CA;5|&xM|TgY?q#s&75#j^%SH8{Z!dW2ht!wq zYT_~}hP4-?} zJJAofJ~vm8=>3(0zx)@zHb_V3B$6ui7gg=y-NQ#W$UDI8JUM(+rBWQvfhy}3aQQq` zbWt&DTap8LPMEjy%$&vI<(?tgVs6f2ip6=06(-~iQ-VfAc~`EP7L@ooNTE1E@WKqh z%`xJYWO6WSG_-!`4cczgv)mnT1pJdegaXGiK%br5ogjp5@1vmKicd8S99zPBKlzp2 z7HqpizX|PuyX%1)!r07?U!$>i4(M?qfN~sGNI3Sh#c8$?^fPz7K>+QZyE6p84=(i4 zS61MIV9=VeC4m)??r~A2{`wFMx$cy8vr>h_cjQ=)rg+4eek6V;hAhfnia?=Dv%MAIKO>STACKHAX.\;1 3191 ) ; Copyright (c) 1988 by I. All rights reserved. (PRETTYCOMPRINT STACKHAXCOMS) (RPAQQ STACKHAXCOMS ((FNS CHECKSTACKSPACE))) (DEFINEQ (CHECKSTACKSPACE (LAMBDA (N START) (* \; "Edited 27-Oct-88 14:51 by jds") (PROG ((SCANPTR (|fetch| |StackBase| |of| |\\InterfacePage|)) (EASP (|fetch| |EndOfStack| |of| |\\InterfacePage|))) SCAN (SELECTC (|fetch| (STK FLAGS) |of| SCANPTR) (\\STK.FSB (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "FSB size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR))) (\\STK.GUARD (COND ((EQ SCANPTR EASP) (* \;  "Guard block not at end of stack, treat as a free block") (RETURN T))) (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "Guard block size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR)) (* \; "reached end") ) (\\STK.FX (* \; "frame extension") (OR (|fetch| (FX CHECKED) |of| SCANPTR) (CL:WARN "FX not CHECKED at ~O." SCANPTR)) (COND ((EQUAL (|fetch| (FX NEXTBLOCK) |of| SCANPTR) SCANPTR) (CL:WARN "FX's NEXTBLOCK points to itself at ~O." SCANPTR))) (SETQ SCANPTR (|fetch| (FX NEXTBLOCK) |of| SCANPTR))) (LET ((ORIG SCANPTR)) (* \; "must be a basic frame") (|until| (|type?| BF SCANPTR) |do| (OR (EQ (|fetch| (STK FLAGS) |of| SCANPTR) \\STK.NOTFLAG) T (CL:WARN "Non-zero flags in a non-BF word at ~O." SCANPTR)) (|add| SCANPTR WORDSPERCELL)) (OR (COND ((|fetch| (BF RESIDUAL) |of| SCANPTR) (EQ SCANPTR ORIG)) (T (AND (|fetch| (BF CHECKED) |of| SCANPTR) (EQ ORIG (|fetch| (BF IVAR) |of| SCANPTR))))) (CL:WARN "Bad basic frame at ~O." SCANPTR)) (|add| SCANPTR WORDSPERCELL))) NEXT (OR (ILEQ SCANPTR EASP) (HELP "SCANPTR got beyond EASP")) (GO SCAN)))) ) (PUTPROPS STACKHAX COPYRIGHT ("I" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (269 3127 (CHECKSTACKSPACE 279 . 3125))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/STACKHAX.~2~ b/internal/test/Maiko/STACKHAX.~2~ new file mode 100644 index 00000000..f02958aa --- /dev/null +++ b/internal/test/Maiko/STACKHAX.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "15-Nov-88 16:42:40" {ERIS}MAIKO>STACKHAX.\;2 4157 |changes| |to:| (FNS CHECKSTACKSPACE) |previous| |date:| "27-Oct-88 14:58:37" {ERIS}MAIKO>STACKHAX.\;1) ; Copyright (c) 1988 by I. All rights reserved. (PRETTYCOMPRINT STACKHAXCOMS) (RPAQQ STACKHAXCOMS ((FNS CHECKSTACKSPACE))) (DEFINEQ (CHECKSTACKSPACE (LAMBDA (N START) (* \; "Edited 15-Nov-88 16:25 by jds") (PROG ((SCANPTR (|fetch| |StackBase| |of| |\\InterfacePage|)) (EASP (|fetch| |EndOfStack| |of| |\\InterfacePage|)) (*PRINT-LEVEL* 2) (*PRINT-LENGTH* 2)) SCAN (SELECTC (|fetch| (STK FLAGS) |of| SCANPTR) (\\STK.FSB (CL:FORMAT T "~6o Free Block~%" SCANPTR) (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "FSB size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR))) (\\STK.GUARD (CL:FORMAT T "~6o Guard Block~%" SCANPTR) (COND ((EQ SCANPTR EASP) (* \;  "Guard block not at end of stack, treat as a free block") (RETURN T))) (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "Guard block size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR)) (* \; "reached end") ) (\\STK.FX (* \; "frame extension") (CL:FORMAT T "~6o Frame Extn for ~S~%" SCANPTR (FETCH (FNHEADER FRAMENAME ) OF (FETCH (FX FNHEADER) OF SCANPTR))) (OR (|fetch| (FX CHECKED) |of| SCANPTR) (CL:FORMAT T " FX not CHECKED at ~O." SCANPTR)) (COND ((EQUAL (|fetch| (FX NEXTBLOCK) |of| SCANPTR) SCANPTR) (CL:FORMAT T " FX's NEXTBLOCK points to itself at ~O." SCANPTR))) (SETQ SCANPTR (|fetch| (FX NEXTBLOCK) |of| SCANPTR))) (LET ((ORIG SCANPTR)) (* \; "must be a basic frame") (|until| (|type?| BF SCANPTR) |do| (OR (EQ (|fetch| (STK FLAGS) |of| SCANPTR) \\STK.NOTFLAG) T (CL:FORMAT T " Non-zero flags in a non-BF word at ~O." SCANPTR)) (|add| SCANPTR WORDSPERCELL)) (CL:FORMAT T "~6o Basic Frame~%" SCANPTR) (OR (COND ((|fetch| (BF RESIDUAL) |of| SCANPTR) (EQ SCANPTR ORIG)) (T (AND (|fetch| (BF CHECKED) |of| SCANPTR) (EQ ORIG (|fetch| (BF IVAR) |of| SCANPTR))))) (CL:WARN CL:FORMAT T " Bad basic frame at ~O." SCANPTR)) (|add| SCANPTR WORDSPERCELL))) NEXT (OR (ILEQ SCANPTR EASP) (HELP "SCANPTR got beyond EASP")) (GO SCAN)))) ) (PUTPROPS STACKHAX COPYRIGHT ("I" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (402 4093 (CHECKSTACKSPACE 412 . 4091))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/STACKHAX.~3~ b/internal/test/Maiko/STACKHAX.~3~ new file mode 100644 index 00000000..8b70cf31 --- /dev/null +++ b/internal/test/Maiko/STACKHAX.~3~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "15-Nov-88 16:51:34" {ERIS}MAIKO>STACKHAX.\;3 4103 |changes| |to:| (FNS CHECKSTACKSPACE) |previous| |date:| "27-Oct-88 14:58:37" {ERIS}MAIKO>STACKHAX.\;1) ; Copyright (c) 1988 by I. All rights reserved. (PRETTYCOMPRINT STACKHAXCOMS) (RPAQQ STACKHAXCOMS ((FNS CHECKSTACKSPACE))) (DEFINEQ (CHECKSTACKSPACE (LAMBDA (START) (* \; "Edited 15-Nov-88 16:51 by jds") (PROG ((SCANPTR (OR START (|fetch| |StackBase| |of| |\\InterfacePage|))) (EASP (|fetch| |EndOfStack| |of| |\\InterfacePage|)) (*PRINT-LEVEL* 2) (*PRINT-LENGTH* 2)) SCAN (SELECTC (|fetch| (STK FLAGS) |of| SCANPTR) (\\STK.FSB (CL:FORMAT T "~6o Free Block~%" SCANPTR) (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "FSB size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR))) (\\STK.GUARD (CL:FORMAT T "~6o Guard Block~%" SCANPTR) (COND ((EQ SCANPTR EASP) (RETURN T))) (* |;;| "Guard block not at end of stack, treat as a free block:") (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "Guard block size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR)) (* \; "reached end") ) (\\STK.FX (* \; "frame extension") (CL:FORMAT T "~6o Frame Extn for ~S~%" SCANPTR (FETCH (FNHEADER FRAMENAME ) OF (FETCH (FX FNHEADER) OF SCANPTR))) (OR (|fetch| (FX CHECKED) |of| SCANPTR) (CL:FORMAT T " FX not CHECKED at ~O.~%" SCANPTR)) (COND ((EQUAL (|fetch| (FX NEXTBLOCK) |of| SCANPTR) SCANPTR) (CL:FORMAT T " FX's NEXTBLOCK points to itself at ~O.~%" SCANPTR))) (SETQ SCANPTR (|fetch| (FX NEXTBLOCK) |of| SCANPTR))) (LET ((ORIG SCANPTR)) (* \; "must be a basic frame") (|until| (|type?| BF SCANPTR) |do| (OR (EQ (|fetch| (STK FLAGS) |of| SCANPTR) \\STK.NOTFLAG) (CL:FORMAT T " Non-zero flags in a non-BF word at ~O.~%" SCANPTR)) (|add| SCANPTR WORDSPERCELL)) (CL:FORMAT T "~6o Basic Frame~%" SCANPTR) (OR (COND ((|fetch| (BF RESIDUAL) |of| SCANPTR) (EQ SCANPTR ORIG)) (T (AND (|fetch| (BF CHECKED) |of| SCANPTR) (EQ ORIG (|fetch| (BF IVAR) |of| SCANPTR))))) (CL:FORMAT T " Bad basic frame at ~O.~%" SCANPTR)) (|add| SCANPTR WORDSPERCELL))) NEXT (OR (ILEQ SCANPTR EASP) (HELP "SCANPTR got beyond EASP")) (GO SCAN)))) ) (PUTPROPS STACKHAX COPYRIGHT ("I" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (402 4039 (CHECKSTACKSPACE 412 . 4037))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/STACKHAX.~4~ b/internal/test/Maiko/STACKHAX.~4~ new file mode 100644 index 00000000..889043c4 --- /dev/null +++ b/internal/test/Maiko/STACKHAX.~4~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "15-Nov-88 17:16:48" {ERIS}MAIKO>STACKHAX.\;4 4101 |changes| |to:| (FNS CHECKSTACKSPACE) |previous| |date:| "27-Oct-88 14:58:37" {ERIS}MAIKO>STACKHAX.\;1) ; Copyright (c) 1988 by I. All rights reserved. (PRETTYCOMPRINT STACKHAXCOMS) (RPAQQ STACKHAXCOMS ((FNS CHECKSTACKSPACE))) (DEFINEQ (CHECKSTACKSPACE (LAMBDA (START) (* \; "Edited 15-Nov-88 16:55 by jds") (PROG ((SCANPTR (OR START (|fetch| |StackBase| |of| |\\InterfacePage|))) (EASP (|fetch| |EndOfStack| |of| |\\InterfacePage|)) (*PRINT-LEVEL* 2) (*PRINT-LENGTH* 2)) SCAN (SELECTC (|fetch| (STK FLAGS) |of| SCANPTR) (\\STK.FSB (CL:FORMAT T "~6o Free Block~%" SCANPTR) (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "FSB size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR))) (\\STK.GUARD (CL:FORMAT T "~6o Guard Block~%" SCANPTR) (COND ((EQ SCANPTR EASP) (RETURN T))) (* |;;| "Guard block not at end of stack, treat as a free block:") (COND ((ZEROP (|fetch| (FSB SIZE) |of| SCANPTR)) (HELP "Guard block size 0 at " SCANPTR))) (|add| SCANPTR (|fetch| (FSB SIZE) |of| SCANPTR)) (* \; "reached end") ) (\\STK.FX (* \; "frame extension") (CL:FORMAT T "~6o Frame Extn (use ~D) for ~S~%" SCANPTR (FETCH (FX USECNT) OF SCANPTR) (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX FNHEADER) |of| SCANPTR))) (OR (|fetch| (FX CHECKED) |of| SCANPTR) (CL:FORMAT T " FX not CHECKED at ~O.~%" SCANPTR)) (COND ((EQUAL (|fetch| (FX NEXTBLOCK) |of| SCANPTR) SCANPTR) (CL:FORMAT T " FX's NEXTBLOCK points to itself at ~O.~%" SCANPTR))) (SETQ SCANPTR (|fetch| (FX NEXTBLOCK) |of| SCANPTR))) (LET ((ORIG SCANPTR)) (* \; "must be a basic frame") (|until| (|type?| BF SCANPTR) |do| (OR (EQ (|fetch| (STK FLAGS) |of| SCANPTR) \\STK.NOTFLAG) (CL:FORMAT T " Non-zero flags in a non-BF word at ~O.~%" SCANPTR)) (|add| SCANPTR WORDSPERCELL)) (CL:FORMAT T "~6o Basic Frame~%" SCANPTR) (OR (COND ((|fetch| (BF RESIDUAL) |of| SCANPTR) (EQ SCANPTR ORIG)) (T (AND (|fetch| (BF CHECKED) |of| SCANPTR) (EQ ORIG (|fetch| (BF IVAR) |of| SCANPTR))))) (CL:FORMAT T " Bad basic frame at ~O.~%" SCANPTR)) (|add| SCANPTR WORDSPERCELL))) NEXT (OR (ILEQ SCANPTR EASP) (HELP "SCANPTR got beyond EASP")) (GO SCAN)))) ) (PUTPROPS STACKHAX COPYRIGHT ("I" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (402 4037 (CHECKSTACKSPACE 412 . 4035))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/STACKTAKESHI b/internal/test/Maiko/STACKTAKESHI new file mode 100644 index 00000000..1884a4d6 --- /dev/null +++ b/internal/test/Maiko/STACKTAKESHI @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "16-Nov-88 11:35:09" |{DSK}/users/shimizu/STACKTAKESHI.;4| 2148 |changes| |to:| (FNS TEST-CLIENT) |previous| |date:| "16-Nov-88 11:15:18" |{DSK}/users/shimizu/STACKTAKESHI.;3|) ; Copyright (c) 1988 by Fuji Xerox Co., Ltd.. All rights reserved. (PRETTYCOMPRINT STACKTAKESHICOMS) (RPAQQ STACKTAKESHICOMS ((FNS STACK-TAKESHI TEST-CLIENT TEST-CLIENT2 FUNC) (INITVARS (AKINA NIL) (WARMUP NIL)))) (DEFINEQ (STACK-TAKESHI (LAMBDA NIL (* \; "Edited 15-Nov-88 19:17 by shimizu") (SETQ AKINA NIL) (ADD.PROCESS '(TEST-CLIENT 0)) (DISMISS 2000) (PROG NIL IDLE (COND ((NEQ WARMUP 'DONE) (BLOCK) (GO IDLE)))) (ADD.PROCESS '(TEST-CLIENT2 0)) (SETQ AKINA 'OK))) (TEST-CLIENT (LAMBDA (VAL) (* \; "Edited 16-Nov-88 11:33 by shimizu") (COND ((IGREATERP VAL 200) (PROG NIL (SETQ WARMUP 'DONE) LP (COND ((EQ AKINA 'OK) (RETURN)) (T (BLOCK) (GO LP))))) (T (TEST-CLIENT (IPLUS VAL 1)))))) (TEST-CLIENT2 (LAMBDA (VAL) (* \; "Edited 15-Nov-88 19:12 by shimizu") (PROG NIL (COND ((IGREATERP VAL 20) (PROG NIL LP (COND ((EQ AKINA 'OK) (DISMISS 1000) (GO WAIST)) (T (BLOCK) (GO LP))))) (T (TEST-CLIENT2 (IPLUS VAL 1)))) WAIST (FUNC)))) (FUNC (LAMBDA NIL (* \; "Edited 16-Nov-88 11:13 by shimizu") (PRINT (FUNC NIL)))) ) (RPAQ? AKINA NIL) (RPAQ? WARMUP NIL) (PUTPROPS STACKTAKESHI COPYRIGHT ("Fuji Xerox Co., Ltd." 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (559 2014 (STACK-TAKESHI 569 . 957) (TEST-CLIENT 959 . 1357) (TEST-CLIENT2 1359 . 1867) (FUNC 1869 . 2012))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/STACKTAKESHI.LCOM b/internal/test/Maiko/STACKTAKESHI.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..0040cc3e46b5ea3b7b28484ffb74e890a7096ab1 GIT binary patch literal 1187 zcma)6zi-n(6u!a$Wa%LIWoWj8&STP>heQyW@sO#o5orl-T? zBe*o=H#<;ioo8%S&XQ1mReI&>3>-(?HjU$8m+e=>-G-@ zNAVabouyg^qV0xIiL5Y^4To87BtbSD#pg*n;TTQ~QDv`aL!+%5RaG;olDj3(>;lbf z;5L8)dWX3>*g)Z>9&GLS5|Ah479ssENeLnM2pQb@g3s+ELVkR@OUU%%*K7hKU9wC> zwGO&zR{g*;tT2RH9o8Ms=m2ei$-*s$vGyVY8$ewH4*_j3J=el9s1(En^)*l=XqG}4 zkroXqBrue)t2-z_nF+|X4LfKrxT^iDosUp}1Xe5bjP5B+77a`E%{>X2M~CE}bj zQlSMkWlpVBwDxb+d8tQaDKB;Z`trfl=Wcx*-2R5nz2}v_A7A0;6hHfgWA=_~fT}=A zbWNRGht3q%aYhu)!nah(7xArgnFD-pFdaVe#-vT~13YD*0*6T)!`Fy@U`5fs;cXSu zi>C&IAtC}_-`<;bl8`{G6ukv}gjZ4V`K%)s#c{eW$3M);GkC$AFNi%02eFw*K%aL#&ojA^^o!XjM%Z-vk> A?*IS* literal 0 HcmV?d00001 diff --git a/internal/test/Maiko/display.cl b/internal/test/Maiko/display.cl new file mode 100644 index 00000000..019fac6c --- /dev/null +++ b/internal/test/Maiko/display.cl @@ -0,0 +1 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package 'xlib :use '(lisp)) (export '( with-display with-event-queue open-display display-force-output close-display display-protocol-version display-vendor display-roots display-motion-buffer-size display-max-request-length display-error-handler display-after-function display-invoke-after-function display-finish-output)) ;; ;; Resource id management ;; (defun initialize-resource-allocator (display) ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask (let ((id-mask (display-resource-id-mask display))) (unless (zerop id-mask) ;; zero mask is an error (do ((first 0 (index1+ first)) (mask id-mask (the mask32 (ash mask -1)))) ((oddp mask) (setf (display-resource-id-byte display) (byte (integer-length mask) first))) (declare (type array-index first) (type mask32 mask)))))) (defun resourcealloc (display) ;; Allocate a resource-id for in DISPLAY (declare (type display display)) (declare-values resource-id) (dpb (incf (display-resource-id-count display)) (display-resource-id-byte display) (display-resource-id-base display))) (defmacro allocate-resource-id (display object type) ;; Allocate a resource-id for OBJECT in DISPLAY (declare (type display display) (type t object)) (declare-values resource-id) (if (member (eval type) *clx-cached-types*) `(let ((id (funcall (display-xid ,display) ,display))) (save-id ,display id ,object) id) `(funcall (display-xid ,display) ,display))) (defmacro deallocate-resource-id (display id type) ;; Deallocate a resource-id for OBJECT in DISPLAY (when (member (eval type) *clx-cached-types*) `(deallocate-resource-id-internal ,display ,id))) (defun deallocate-resource-id-internal (display id) (remhash id (display-resource-id-map display))) (defun lookup-resource-id (display id) ;; Find the object associated with resource ID (gethash id (display-resource-id-map display))) (defun save-id (display id object) ;; Register a resource-id from another display. (declare (type display display) (type integer id) (type t object)) (declare-values object) (setf (gethash id (display-resource-id-map display)) object)) (defun make-xatom (&key display id) (atom-name-internal display id)) ;; Define functions to find the CLX data types given a display and resource-id ;; If the data type is being cached, look there first. (eval-when (eval compile) ;; I'd rather use macrolet, but Symbolics doesn't like it... (defmacro generate-lookup-functions (useless-name &body types) `(within-definition (,useless-name generate-lookup-functions) ,@(mapcar #'(lambda (type) `(defun ,(xintern 'lookup- type) (display id) (declare (type display display) (type resource-id id)) (declare-values ,type) ,(if (member type *clx-cached-types*) `(let ((,type (lookup-resource-id display id))) (cond ((null ,type) ;; Not found, create and save it. (setq ,type (,(xintern 'make- type) :display display :id id)) (save-id display id ,type)) ;; Found. Check the type ,(if (member type '(window pixmap)) `((or (type? ,type ',type) (type? ,type 'drawable)) ,type) `((type? ,type ',type) ,type)) (t (x-error 'lookup-error :id id :display display :type ',type :object ,type)))) ;; Not being cached. Create a new one each time. `(,(xintern 'make- type) :display display :id id)))) types))) ) ;; End eval-when (generate-lookup-functions ignore drawable window pixmap gcontext cursor colormap font xatom) (defun atom-id (atom display) ;; Return the ID for an atom in DISPLAY (declare (type xatom atom) (type display display)) (declare-values (or null resource-id)) (gethash (if (keywordp atom) atom (intern (string atom) 'keyword)) (display-atom-cache display))) (defun set-atom-id (atom display id) ;; Set the ID for an atom in DISPLAY (declare (type xatom atom) (type display display) (type resource-id id)) (declare-values resource-id) (setf (gethash (if (keywordp atom) atom (intern (string atom) 'keyword)) (display-atom-cache display)) id)) (defsetf atom-id set-atom-id) (defun initialize-predefined-atoms (display) (do ((i 1 (1+ i)) (end (length *predefined-atoms*)) (save-p (member 'xatom *clx-cached-types*))) ((>= i end)) (set-atom-id (aref *predefined-atoms* i) display i) (when save-p (save-id display i (aref *predefined-atoms* i))))) ;; ;; Display functions ;; (defmacro with-display ((display) &body body) ;; This macro is for use in a multi-process environment. It provides exclusive ;; access to the local display object for multiple request generation. It need not ;; provide immediate exclusive access for replies; that is, if another process is ;; waiting for a reply (while not in a with-display), then synchronization need not ;; (but can) occur immediately. Except where noted, all routines effectively ;; contain an implicit with-display where needed, so that correct synchronization ;; is always provided at the interface level on a per-call basis. Nested uses of ;; this macro will work correctly. This macro does not prevent concurrent event ;; processing; see with-event-queue. `(with-buffer (,display) ,@body)) (defmacro with-event-queue ((display) &body body) ; exclusive access to event queue (declare (special *within-with-event-queue*)) (if (and (boundp '*within-with-event-queue*) *within-with-event-queue*) `(progn ,display ,@body) ;; Speedup hack for lexically nested with-event-queue's `(compiler-let ((*within-with-event-queue* t)) (holding-lock ((display-event-lock ,display) "Event-Lock") ,@body)))) (defmacro with-event-queue-internal ((display) &body body) ; exclusive access to the internal event queues `(holding-lock ((display-event-queue-lock ,display) "Event-Queue-Lock") ,@body)) (defmacro with-input-lock ((display) &body body) ; exclusive access to the input buffer `(holding-lock ((display-input-lock ,display) "Input-Lock") ,@body)) (defun open-display (host &rest options &key (display 0) protocol authorization-name authorization-data &allow-other-keys) ;; Implementation specific routine to setup the buffer for a specific host and display. ;; This must interface with the local network facilities, and will probably do special ;; things to circumvent the nework when displaying on the local host. ;; ;; A string must be acceptable as a host, but otherwise the possible types ;; for host and protocol are not constrained, and will likely be very ;; system dependent. The default protocol is system specific. Authorization, ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare-values display) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol)) (disp (apply #'make-buffer #x1000 #x1000 'make-display-internal :host host :display display :output-stream stream :input-stream stream :allow-other-keys t options)) (ok-p nil)) (unwind-protect (progn (display-connect disp :authorization-name authorization-name :authorization-data authorization-data) (initialize-resource-allocator disp) (initialize-predefined-atoms disp) (initialize-extensions disp) (setq ok-p t)) (unless ok-p (close-display disp))) ;; Ensure network connection gets closed on connect problems disp)) (defun display-force-output (display) ; Output is normally buffered, this forces any buffered output to the server. (declare (type display display)) (with-display (display) (buffer-force-output display))) (defun close-display (display) ;; Close the host connection in DISPLAY (declare (type display display)) (close-buffer display)) (defun display-connect (display &key authorization-name authorization-data) (unless authorization-name (setq authorization-name "")) (unless authorization-data (setq authorization-data "")) (writing-buffer-send (display :sizes (8 16)) (card8-put 0 #+clx-little-endian #x6c ;; Ascii lowercase l - Least Significant byte first #-clx-little-endian #x42 ;; Ascii uppercase B - Most Significant Byte First ) (card16-put 2 *protocol-major-version*) (card16-put 4 *protocol-minor-version*) (card16-put 6 (length authorization-name)) (card16-put 8 (length authorization-data)) (write-sequence-char display 12 authorization-name) (write-sequence-char display (lround (+ 12 (length authorization-name))) authorization-data)) (buffer-force-output display) (reading-buffer-reply (display :sizes (8 16 32)) (buffer-input display buffer-bbuf 0 8) (let ((success (boolean-get 0)) (reason-length (card8-get 1)) (major-version (card16-get 2)) (minor-version (card16-get 4)) (total-length (card16-get 6)) vendor-length num-roots num-formats) (declare (ignore total-length)) (unless success (x-error 'connection-failure :major-version major-version :minor-version minor-version :host (display-host display) :display (display-display display) :reason (string-get reason-length))) (buffer-input display buffer-bbuf 0 32) (setf (display-protocol-major-version display) major-version) (setf (display-protocol-minor-version display) minor-version) (setf (display-release-number display) (card32-get 0)) (setf (display-resource-id-base display) (card32-get 4)) (setf (display-resource-id-mask display) (card32-get 8)) (setf (display-motion-buffer-size display) (card32-get 12)) (setq vendor-length (card16-get 16)) (setf (display-max-request-length display) (card16-get 18)) (setq num-roots (card8-get 20)) (setq num-formats (card8-get 21)) ;; Get the image-info (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) (let ((format (display-bitmap-format display))) (declare (type bitmap-format format)) (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) (setf (bitmap-format-unit format) (card8-get 24)) (setf (bitmap-format-pad format) (card8-get 25))) (setf (display-min-keycode display) (card8-get 26)) (setf (display-max-keycode display) (card8-get 27)) ;; 4 bytes unused ;; Get the vendor string (setf (display-vendor-name display) (string-get vendor-length)) ;; Initialize the pixmap formats (dotimes (i num-formats) ;; loop gathering pixmap formats (buffer-input display buffer-bbuf 0 8) (push (make-pixmap-format :depth (card8-get 0) :bits-per-pixel (card8-get 1) :scanline-pad (card8-get 2)) ; 5 unused bytes (display-pixmap-formats display))) ;; Initialize the screens (dotimes (i num-roots) (buffer-input display buffer-bbuf 0 40) (let* ((root (make-window :id (card32-get 0) :display display)) (screen (make-screen :root root :default-colormap (make-colormap :id (card32-get 4) :display display) :white-pixel (card32-get 8) :black-pixel (card32-get 12) :event-mask-at-open (card32-get 16) :width (card16-get 20) :height (card16-get 22) :width-in-millimeters (card16-get 24) :height-in-millimeters (card16-get 26) :min-installed-maps (card16-get 28) :max-installed-maps (card16-get 30) :root-visual (card32-get 32) :backing-stores (member8-get 36 :never :when-mapped :always) :save-unders-p (boolean-get 37) :root-depth (card8-get 38))) (num-depths (card8-get 39)) (depths nil)) ;; Save root window for event reporting (save-id display (window-id root) root) ;; Create the depth AList for a screen, (depth . visual-infos) (dotimes (j num-depths) (buffer-input display buffer-bbuf 0 8) (let ((depth (card8-get 0)) (num-visuals (card16-get 2)) (visuals nil)) ;; 4 bytes unused (dotimes (k num-visuals) (buffer-input display buffer-bbuf 0 24) (push (make-visual-info :id (card32-get 0) :class (member8-get 4 :static-gray :gray-scale :static-color :pseudo-color :true-color :direct-color) :bits-per-rgb (card8-get 5) :colormap-entries (card16-get 6) :red-mask (card32-get 8) :green-mask (card32-get 12) :blue-mask (card32-get 16)) ;; 4 bytes unused visuals)) (push (cons depth (nreverse visuals)) depths))) (setf (screen-depths screen) depths) (push screen (display-roots display)))) (setf (display-default-screen display) (first (display-roots display))))) display) (defun display-protocol-version (display) (declare (type display display)) (declare-values major minor) (values (display-protocol-major-version display) (display-protocol-minor-version display))) (defun display-vendor (display) (declare (type display display)) (declare-values name release) (values (display-vendor-name display) (display-release-number display))) #+comment ;; defined by the DISPLAY defstruct (defsetf display-error-handler (display) (handler) ;; All errors (synchronous and asynchronous) are processed by calling an error ;; handler in the display. If handler is a sequence it is expected to contain ;; handler functions specific to each error; the error code is used to index the ;; sequence, fetching the appropriate handler. Any results returned by the handler ;; are ignored; it is assumed the handler either takes care of the error ;; completely, or else signals. For all core errors, the keyword/value argument ;; pairs are: ;; :display display ;; :error-key error-key ;; :major integer ;; :minor integer ;; :sequence integer ;; :current-sequence integer ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and ;; :window errors another pair is: ;; :resource-id integer ;; For :atom errors, another pair is: ;; :atom-id integer ;; For :value errors, another pair is: ;; :value integer ) ;; setf'able ;; If defined, called after every protocol request is generated, even those inside ;; explicit with-display's, but never called from inside the after-function itself. ;; The function is called inside the effective with-display for the associated ;; request. Default value is nil. Can be set, for example, to ;; #'display-force-output or #'display-finish-output. (defun display-invoke-after-function (display) ; Called after every protocal request is generated (declare (type display display) (special *inside-display-after-function*)) (when (and (display-after-function display) (not (and (boundp '*inside-display-after-function*) *inside-display-after-function*))) (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls (declare (special *inside-display-after-function*)) (funcall (display-after-function display) display)))) (defun display-finish-output (display) ; Forces output, then causes a round-trip to ensure that all possible ; errors and events have been received. (declare (type display display)) (with-display (display) (with-buffer-request (display *x-getinputfocus* :no-after)) (wait-for-reply display 16))) (defparameter *request-names* '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes" "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow" "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows" "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree" "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty" "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner" "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer" "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard" "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents" "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents" "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus" "QueryKeymap" "OpenFont" "CloseFont" "QueryFont" "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath" "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC" "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles" "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane" "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle" "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc" "PutImage" "GetImage" "PolyText8" "PolyText16" "ImageText8" "ImageText16" "CreateColormap" "FreeColormap" "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps" "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes" "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors" "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor" "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions" "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl" "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver" "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl" "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver" "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping")) \ No newline at end of file diff --git a/internal/test/TEST-RESULTS b/internal/test/TEST-RESULTS new file mode 100644 index 00000000..3de2fab9 --- /dev/null +++ b/internal/test/TEST-RESULTS @@ -0,0 +1 @@ +;;; Test results for sysout of 15-Feb-88 14:58:06 ;;; Tests run on 15-Feb-88 16:53:11 ;;; Running tests from ({ERIS}LANGUAGE>AUTO>*.TEST; {ERIS}IO>AUTO>*.TEST;) ;;; The following test files hung the tester: {ERIS}LANGUAGE>AUTO>22-2-1-READ-CHAR-NO-HANG.TEST {ERIS}IO>AUTO>MSPF.TEST Test "read-char-no-hang returns nil standard-input" failed in file "{ERIS}LANGUAGE>AUTO>22-2-1-READ-CHAR-NO-HANG.TEST;1" Test "LOAD-CH-21-FUNCTIONS" failed in file "{ERIS}LANGUAGE>AUTO>22-3-1-FINISH-OUTPUT.TEST;1" Test "finish-output" failed in file "{ERIS}LANGUAGE>AUTO>22-3-1-FINISH-OUTPUT.TEST;1" Test "force-output" failed in file "{ERIS}LANGUAGE>AUTO>22-3-1-FINISH-OUTPUT.TEST;1" Test "clear-output" failed in file "{ERIS}LANGUAGE>AUTO>22-3-1-FINISH-OUTPUT.TEST;1" Warning in test ("warn-test-setup" :BEFORE (PROGN (DEFUN COMMAND-DISPATCH (CMD) "**Error message is printed if a symbol has no property named command**" (LET ((FN (GET CMD (QUOTE COMMAND)))) (IF (NOT (NULL FN)) (FUNCALL FN) (WARN "The command ~S is unrecognized." CMD)))) (DEFUN TURN-OFF-VAL1 NIL "ABANDON!") (SETF (SYMBOL-PLIST (QUOTE EMERGENCY-SHUTDOWN)) (QUOTE (COMMAND TURN-OFF-VAL1 SWITCH EMERGENCY REACTOR-STATUS 7))))) in file "{ERIS}LANGUAGE>AUTO>24-1-WARN.TEST;1": The command EMERGENCY-SHOTDOWN is unrecognized. Warning in test "Do some simple tests" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Do some simple tests" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Do some simple tests" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Do some simple tests" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Do some work in creating keyform" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Check values set in CASE still good outside" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Check values set in CASE still good outside" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "Check values set in CASE still good outside" in file "{ERIS}LANGUAGE>AUTO>7-6-CASE.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "AR 7647" in file "{ERIS}LANGUAGE>AUTO>AR7647.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Warning in test "AR 7647" in file "{ERIS}LANGUAGE>AUTO>AR7647.TEST;1": NIL used as a singleton key in CASE. You probably meant to use (NIL). Test "AR 7742" failed in file "{ERIS}LANGUAGE>AUTO>AR7742.TEST;1" Test "AR8207-TEST" failed in file "{ERIS}LANGUAGE>AUTO>AR8207.TEST;1" Test "AR8575-TEST" failed in file "{ERIS}LANGUAGE>AUTO>AR8575.TEST;1" (XCL-TESTONE redefined) Test "name-char and char-name are inverses" failed in file "{ERIS}LANGUAGE>AUTO>CMLCHARACTER.TEST;1" Test "load a test file and make sure it gets noticed" failed in file "{ERIS}LANGUAGE>AUTO>CMLFILEMANAGER.TEST;1" Test "makefile, load and execute the new version" failed in file "{ERIS}LANGUAGE>AUTO>CMLFILEMANAGER.TEST;1" Test "rename the function, makefile, reload and execute" failed in file "{ERIS}LANGUAGE>AUTO>CMLFILEMANAGER.TEST;1" Test "copydef" failed in file "{ERIS}LANGUAGE>AUTO>CMLFILEMANAGER.TEST;1" Test "test dfnflg set to PROP and ALLPROP" failed in file "{ERIS}LANGUAGE>AUTO>CMLFILEMANAGER.TEST;1" (XCL-TEST::TEST-FNS redefined) (XCL-TEST::TEST-FNS redefined) Compiling 1 top-level form Done Compiling 2 top-level forms Done Compiling DEFUN NEW-FUNCTION Done Compiling DEFMACRO TEST-MACRO Done Compiling DEFVAR TEST-VARIABLE Done Compiling IL:LAMBDA TEST-FNS Done Compiling 1 top-level form Done Compiling 1 top-level form Done Compiling 2 top-level forms Done Compiling DEFUN XCL-TEST::NEW-FUNCTION Done Compiling DEFMACRO XCL-TEST::TEST-MACRO Done Compiling DEFVAR XCL-TEST::TEST-VARIABLE Done Compiling IL:LAMBDA XCL-TEST::TEST-FNS Done Compiling 1 top-level form Done Compiling DEFMACRO FOO Done Compiling DEFSETF FOO Done Compiling DEFUN BAZ Done Warning in test "AR 7507: SETF macroexpands too early sometimes" in file "{ERIS}LANGUAGE>AUTO>CMLSETF-REGRESSION.TEST;1": The following functions were called in the code just compiled, but are not known to exist: SET-FOO -- called from BAZ. (Trouble reading {ERIS}LANGUAGE>AUTO>DEFSTRUCT-ADDITIONAL.TEST;1) Test "random state symbols are globally-special" failed in file "{ERIS}LANGUAGE>AUTO>DESCRIBE.TEST;1" Non DO-TEST form at top level in "{ERIS}LANGUAGE>AUTO>DOVEVMEMSIZEPATCH-LLFAULT.TEST;1" DOVEVMEMSIZEPATCH Non DO-TEST form at top level in "{ERIS}LANGUAGE>AUTO>DOVEVMEMSIZEPATCH-LLFAULT.TEST;1" 8038 Non DO-TEST form at top level in "{ERIS}LANGUAGE>AUTO>DOVEVMEMSIZEPATCH-LLFAULT.TEST;1" - Non DO-TEST form at top level in "{ERIS}LANGUAGE>AUTO>DOVEVMEMSIZEPATCH-LLFAULT.TEST;1" INTERACTIVE Test "AR 7563: Default filter function for unnamed proceed cases" failed in file "{ERIS}LANGUAGE>AUTO>ERROR-RUNTIME-REGRESSION.TEST;1" Test "AR 7564: INVOKE-PROCEED-CASE v. defined functions" failed in file "{ERIS}LANGUAGE>AUTO>ERROR-RUNTIME-REGRESSION.TEST;1" Test "AR 8655: Dump integers s.t. (mod (integer-length x) 8) = 0" failed in file "{ERIS}LANGUAGE>AUTO>FASDUMP-REGRESSION.TEST;1" Test "smashing-arrayrecord" failed in file "{ERIS}LANGUAGE>AUTO>INTERLISP-RECORDS.TEST;1" Test "package-ar6652: ARG NOT PACKAGE wrong error attempting to read PHYLEX:PARC:XEROX" failed in file "{ERIS}LANGUAGE>AUTO>PACKAGE-ARS.TEST;1" Test "test xcl:symbol-colon-error condition" failed in file "{ERIS}LANGUAGE>AUTO>PACKAGE-CONDITIONS.TEST;1" Test "converter test 2" failed in file "{ERIS}LANGUAGE>AUTO>PACKAGE-CONVERTER.TEST;1" Test ":escape overrides :pretty" failed in file "{ERIS}LANGUAGE>AUTO>PRETTY-CIRCLE-REGRESSION.TEST;1" (Trouble reading {ERIS}LANGUAGE>AUTO>SPECIALS.TEST;1) Test "(STKPOS 'STKPOS) error" failed in file "{ERIS}LANGUAGE>AUTO>STACK.TEST;1" Compiling DEFMACRO #:FOO Done Compiling DEFUN #:BAR Done Compiling 1 top-level form Done Compiling DEFUN FOO Done Test "AR 7798: SPECIAL declarations are scoped incorrectly by the interpreter and compiler" failed in file "{ERIS}LANGUAGE>AUTO>XCL-COMPILER-REGRESSION.TEST;1" Compiling DEFUN FOO Done Compiling DEFVAR *FOO* Done Compiling DEFMACRO FOO7507 Done Compiling DEFSETF FOO7507 Done Compiling DEFUN SET-FOO7507 Done Compiling DEFUN BAR Done Compiling 1 top-level form Done Compiling 1 top-level form Done Compiling DEFUN FOO Done Test "peek-char " failed in file "{ERIS}IO>AUTO>IO-REGRESSION.TEST;1" Test "il:peekc" failed in file "{ERIS}IO>AUTO>IO-REGRESSION.TEST;1" Test "Verify combinations of open access methods work as they should" failed in file "{ERIS}IO>AUTO>MSPF.TEST;1" Test "TEST MULTIPLE INPUT STREAMS WORK" failed in file "{ERIS}IO>AUTO>MSPF.TEST;1" Test "TEST FILE ATTRIBUTES UNAFFECTED WITH MULTIPLE STREAMS" failed in file "{ERIS}IO>AUTO>MSPF.TEST;1" Test "TEST WHENCLOSE FUNCTION" failed in file "{ERIS}IO>AUTO>MSPF.TEST;1" Test "TEST INFILE & OUTFILE" failed in file "{ERIS}IO>AUTO>MSPF.TEST;1" Non DO-TEST form at top level in "{ERIS}IO>AUTO>PEEKBIN.TEST;1"  (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/Tools/AUTOTEST b/internal/test/Tools/AUTOTEST new file mode 100644 index 00000000..544cb0c4 --- /dev/null +++ b/internal/test/Tools/AUTOTEST @@ -0,0 +1 @@ +(FILECREATED "16-Jul-85 15:52:21" {DANTE}AUTOTEST.;7 67003 changes to: (FNS AT.SHOW.STARTTIME AUTOTESTER AT.MAKETIMEWINDOW AT.SHOW.ENDTIME AT.SHOW.TESTID AT.SHOW.TESTSUITE AT.REPAINT.TIMEW AT.TESTCOMMAND AT.UPDATEAUTOTESTERITEMS AT.SINGLE-TEST SINGLE-TEST AT.ABORTCOMMAND AT.RESUMECOMMAND AT.CLOSEFN AT.PAUSECOMMAND TEST-MESSAGE AT.COMMANDDISPATCH AT.HARDCOPYFN AT.PRINTCOMMAND AT.PRINTHEADINGSON AT.PRINTANDGETREGION GETPRINTFILE AT.GETPRINTDESTINATION) (VARS AUTOTESTCOMS ATICON) previous date: "20-Jun-85 17:12:30" {DANTE}AUTOTEST.;22) (* Copyright (c) 1985 by XEROX Corporation. All rights reserved.) (PRETTYCOMPRINT AUTOTESTCOMS) (RPAQQ AUTOTESTCOMS [(FILES ATTACHEDWINDOW ICONW) [VARS [ATMENUITEMS (QUOTE ((TEST TEST "Tests the selected files; middle button to also redirect output.") (ABORT ABORT "Aborts testing of the selected files.") (PAUSE PAUSE "Temporarily pauses in the testing of selected files.") (RESUME RESUME "Resumes PAUSEd testing.") (DIRECTORY DIRECTORY "Does a directory of files in order to create a new set of tests to select.") (PRINT PRINT "Prints the results of testing of the selected files; middle button to also select printing destination." ) (SUMMARIZE SUMMARIZE "Prints the results of testing of failed tests from the selected files.") (QUIT QUIT "Quits testing."] (ATNOARGITEMS (QUOTE (DIRECTORY QUIT))) (ATBUSYOKITEMS (QUOTE (ABORT PAUSE RESUME QUIT] (INITVARS (ATICONFONT (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE MRR))) (DEFAULTAUTOTESTFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE MRR))) (ATTIMEWINDOWFONT (FONTCREATE (QUOTE GACHA) 8 (QUOTE MRR))) (ATPROMPTFONT (FONTCREATE (QUOTE GACHA) 8 (QUOTE MRR))) (AUTOTESTMENUFONT (FONTCREATE (QUOTE HELVETICA) 10 (QUOTE MRR))) (ATBORDERWIDTH 2) [ATINFOLISTINGWIDTHS (QUOTE (RESULT (Result . 70) NAME (Name . 180) FILE (File . 1800] (ATINFOSHADE 16920) (ATITEMUNSELECTEDSHADE 0) (ATITEMSELECTEDSHADE 43605)) (BITMAPS ATICON ATICONMASK) (CURSORS AT.RIGHTARROWCURSOR) (* * Main autotester fns) (FNS AT AUTOTESTER SINGLE-TEST TEST-MESSAGE) (COMS (* * commands and major subfunctions) (FNS AT.TESTCOMMAND AT.ABORTCOMMAND AT.PAUSECOMMAND AT.RESUMECOMMAND AT.DIRECTORYCOMMAND AT.PRINTCOMMAND AT.QUITCOMMAND) (FNS AT.COMMANDDISPATCH AT.SELECT AT.UPDATEAUTOTESTERITEMS AT.SINGLE-TEST)) (* * lower-level window mungers) (FNS AT.MAKERIGIDWINDOW AT.CLRPROMPTW AT.PRINTHEADINGSON AT.PRINTANDGETREGION AT.MAKEHEADINGWINDOW AT.MAKECOUNTERWINDOW AT.MAKETIMEWINDOW AT.PROMPTWPRINT AT.PROMPTWTERPRI AT.SELECTFILE AT.UNSELECTFILE AT.CHANGECOMPLETEMARK AT.SHOW.NUMCOMPLETED AT.SHOW.NUMFILES AT.SHOW.NUMSELECTED AT.SHOW.NUMSUCCESSFUL AT.SHOW.ENDTIME AT.SHOW.STARTTIME AT.SHOW.TESTID AT.SHOW.TESTSUITE) (* * window functions) (FNS AT.HEADINGWREDISPLAYFN AT.REPAINT.COUNTERW AT.REPAINT.TIMEW AT.ICONFN AT.BUTTONEVENTFN AT.CURSORMOVEDFN AT.CURSOROUTFN AT.REPAINTFN AT.SCROLLFN AT.RIGHTBUTTONFN AT.MENU.WHENSELECTEDFN AT.CLOSEFN AT.HARDCOPYFN) (* * odds and ends) (FNS AT.FETCHFILENAME AT.STARTOFNAME AT.STARTUP AT.CREATEPRINTSPEC AT.FINDTESTBUCKET AT.PROMPTFORINPUT AT.GETALLFILEINFO AT.GETPRINTDESTINATION AT.\ItemWithTag) (DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS (AT.MARKXPOS 16)) (RECORDS ATPRINTSPEC TESTBUCKET)) (ADDVARS (BackgroundMenuCommands ("AutomatedTester" (AT) "Opens an automated tester window; prompts for directory"))) (VARS (BackgroundMenu)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA AT) (NLAML) (LAMA AT.PROMPTWPRINT]) (FILESLOAD ATTACHEDWINDOW ICONW) (RPAQQ ATMENUITEMS ((TEST TEST "Tests the selected files; middle button to also redirect output.") (ABORT ABORT "Aborts testing of the selected files.") (PAUSE PAUSE "Temporarily pauses in the testing of selected files.") (RESUME RESUME "Resumes PAUSEd testing.") (DIRECTORY DIRECTORY "Does a directory of files in order to create a new set of tests to select.") (PRINT PRINT "Prints the results of testing of the selected files; middle button to also select printing destination." ) (SUMMARIZE SUMMARIZE "Prints the results of testing of failed tests from the selected files.") (QUIT QUIT "Quits testing."))) (RPAQQ ATNOARGITEMS (DIRECTORY QUIT)) (RPAQQ ATBUSYOKITEMS (ABORT PAUSE RESUME QUIT)) (RPAQ? ATICONFONT (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE MRR))) (RPAQ? DEFAULTAUTOTESTFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE MRR))) (RPAQ? ATTIMEWINDOWFONT (FONTCREATE (QUOTE GACHA) 8 (QUOTE MRR))) (RPAQ? ATPROMPTFONT (FONTCREATE (QUOTE GACHA) 8 (QUOTE MRR))) (RPAQ? AUTOTESTMENUFONT (FONTCREATE (QUOTE HELVETICA) 10 (QUOTE MRR))) (RPAQ? ATBORDERWIDTH 2) (RPAQ? ATINFOLISTINGWIDTHS (QUOTE (RESULT (Result . 70) NAME (Name . 180) FILE (File . 1800)))) (RPAQ? ATINFOSHADE 16920) (RPAQ? ATITEMUNSELECTEDSHADE 0) (RPAQ? ATITEMSELECTEDSHADE 43605) (RPAQ ATICON (READBITMAP)) (80 80 "OOOOOOOOOOOOOOOOOOOO" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@COA" "H@@@@AOOOOOOON@@@GOI" "H@@@@AOOOOOOON@@@NAM" "H@@@@AOOOOOOON@@@L@M" "H@@@@AOOOOOOON@@@L@M" "H@@@@AOOOOOOON@@@@@M" "H@@@@AOOOOOOON@@@@@M" "H@@@@AOOOOOOON@@@@AM" "HH@HFAOOOOOOONAH@@OI" "HLAHCAOOOOOOON@L@@OA" "HFC@AIOOOOOOON@F@@LA" "HCF@@MOOOOOOON@C@@LA" "HALGOOOOOOOOOOOOH@LA" "HALGOOOOOOOOOOOOH@LA" "HCF@@MOOOOOOON@C@@LA" "HFC@AIOOOOOOON@F@@LA" "HLAHCAOOOOOOON@L@@LA" "HH@HFAOOOOOOONAH@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@LA" "H@@@@AOOOOOOON@@@@LA" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@AOOOOOOON@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@@@@@A" "OOOOOOOOOOOOOOOOOOOO") (RPAQ ATICONMASK (READBITMAP)) (80 80 "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO") (RPAQ AT.RIGHTARROWCURSOR (CURSORCREATE (READBITMAP) 7 9)) (16 16 "@@@@" "@@@@" "@F@@" "@GH@" "@GN@" "@GOH" "OOON" "OOOO" "OOON" "@GOH" "@GN@" "@GH@" "@F@@" "@@@@" "@@@@" "@@@@") (* * Main autotester fns) (DEFINEQ (AT [NLAMBDA DIR (* scv "23-May-85 11:28") (AUTOTESTER (OR (CAR (NLAMBDA.ARGS DIR)) (PROMPTFORWORD "Test directory pattern?" NIL NIL PROMPTWINDOW]) (AUTOTESTER [LAMBDA (FILESPEC) (* scv "15-Jul-85 15:36") (PROG ((PROMPTWHEIGHT 3) AUTOTESTWINDOW COMMANDMENUWINDOW COMMANDMENU DIRSTART HEADINGW COUNTERW TIMEW TTYDS) (COND ((NULL FILESPEC) (RETURN))) (SETQ FILESPEC (DIRECTORY.FILL.PATTERN FILESPEC (QUOTE DCOM) "")) (SETQ COMMANDMENU (create MENU MENUFONT _ AUTOTESTMENUFONT ITEMS _ ATMENUITEMS MENUROWS _ 1 CENTERFLG _ T WHENSELECTEDFN _(FUNCTION AT.MENU.WHENSELECTEDFN))) (SETQ AUTOTESTWINDOW (CREATEW (GETREGION (WIDTHIFWINDOW (fetch IMAGEWIDTH of COMMANDMENU) (fetch MENUOUTLINESIZE of COMMANDMENU)) (HEIGHTIFWINDOW (ITIMES 4 (FONTPROP DEFAULTAUTOTESTFONT (QUOTE HEIGHT)) ) NIL ATBORDERWIDTH)) NIL ATBORDERWIDTH)) (SETQ HEADINGW (AT.MAKEHEADINGWINDOW (GETWINDOWPROP AUTOTESTWINDOW (QUOTE WIDTH)) DEFAULTAUTOTESTFONT ATBORDERWIDTH "Automated Tester Window")) (SETQ COUNTERW (AT.MAKECOUNTERWINDOW (HEIGHTIFWINDOW (FONTPROP DEFAULTAUTOTESTFONT (QUOTE HEIGHT))) (WINDOWPROP HEADINGW (QUOTE WIDTH)) AUTOTESTWINDOW)) (SETQ TIMEW (AT.MAKETIMEWINDOW (HEIGHTIFWINDOW (FONTPROP ATTIMEWINDOWFONT (QUOTE HEIGHT))) (WINDOWPROP HEADINGW (QUOTE WIDTH)) AUTOTESTWINDOW)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE HEADINGWINDOW) HEADINGW) (ATTACHWINDOW HEADINGW AUTOTESTWINDOW (QUOTE TOP)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE COUNTERWINDOW) COUNTERW) (ATTACHWINDOW COUNTERW HEADINGW (QUOTE TOP)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE TIMEWINDOW) TIMEW) (ATTACHWINDOW TIMEW COUNTERW (QUOTE TOP)) (SETQ COMMANDMENUWINDOW (ATTACHMENU COMMANDMENU AUTOTESTWINDOW (QUOTE TOP))) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE SCROLLFN) (FUNCTION AT.SCROLLFN)) (AT.MAKERIGIDWINDOW (GETPROMPTWINDOW AUTOTESTWINDOW PROMPTWHEIGHT ATPROMPTFONT)) (DSPFONT DEFAULTAUTOTESTFONT AUTOTESTWINDOW) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ICONFN) (FUNCTION AT.ICONFN)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ICONTITLE) FILESPEC) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE NUMCOMPLETED) 0) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE NUMSUCCESSFUL) 0) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ORIGX) (DSPXPOSITION NIL AUTOTESTWINDOW)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ORIGY) (DSPYPOSITION NIL AUTOTESTWINDOW)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE DIRWIDTH) (GETWINDOWPROP AUTOTESTWINDOW (QUOTE WIDTH))) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE BUTTONEVENTFN) (FUNCTION AT.BUTTONEVENTFN)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION AT.RIGHTBUTTONFN)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE REPAINTFN) (FUNCTION AT.REPAINTFN)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE CURSORMOVEDFN) (FUNCTION AT.CURSORMOVEDFN)) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE CURSOROUTFN) (FUNCTION AT.CURSOROUTFN)) (WINDOWADDPROP AUTOTESTWINDOW (QUOTE RESHAPEFN) (FUNCTION RESHAPEBYREPAINTFN)) (WINDOWADDPROP AUTOTESTWINDOW (QUOTE SHRINKFN) (FUNCTION AT.CLOSEFN) T) (WINDOWADDPROP AUTOTESTWINDOW (QUOTE CLOSEFN) (FUNCTION AT.CLOSEFN) T) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ITEMSPEC) FILESPEC) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE HARDCOPYFN) (QUOTE AT.HARDCOPYFN)) (WINDOWPROP COMMANDMENUWINDOW (QUOTE HARDCOPYFN) (QUOTE AT.HARDCOPYFN)) (WINDOWPROP HEADINGW (QUOTE HARDCOPYFN) (QUOTE AT.HARDCOPYFN)) (WINDOWPROP COUNTERW (QUOTE HARDCOPYFN) (QUOTE AT.HARDCOPYFN)) (WINDOWPROP TIMEW (QUOTE HARDCOPYFN) (QUOTE AT.HARDCOPYFN)) (WINDOWPROP (GETPROMPTWINDOW AUTOTESTWINDOW) (QUOTE HARDCOPYFN) (QUOTE AT.HARDCOPYFN)) (SETQ TTYDS (WFROMDS (TTYDISPLAYSTREAM))) (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ATDISPLAYSTREAM) TTYDS) (WINDOWPROP TTYDS (QUOTE PAGEFULLFN) (QUOTE NILL)) (WINDOWPROP TTYDS (QUOTE AUTOTESTER) AUTOTESTWINDOW) (ADD.PROCESS (LIST (FUNCTION AT.STARTUP) AUTOTESTWINDOW COMMANDMENU COMMANDMENUWINDOW) (QUOTE NAME) (QUOTE AT-Update)) (RETURN AUTOTESTWINDOW]) (SINGLE-TEST [LAMBDA (IDENTIFIER EXPRESSION PREDICATE TIMEOUT) (* scv "12-Jul-85 16:22") (PROG (MAIN PROC RESULT TESTEND) (SETQ MAIN (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) (QUOTE AUTOTESTER))) (WINDOWPROP MAIN (QUOTE TESTRESULT) NIL) (PUTWINDOWPROP MAIN (QUOTE TESTSTART) NIL) (PUTWINDOWPROP MAIN (QUOTE TESTEND) NIL) [SETQ PROC (ADD.PROCESS (LIST (QUOTE AT.SINGLE-TEST) (KWOTE IDENTIFIER) (KWOTE EXPRESSION) (KWOTE PREDICATE) (KWOTE TIMEOUT) (KWOTE (TTYDISPLAYSTREAM)) (KWOTE (OUTPUT))) (QUOTE NAME) (CONCAT (QUOTE SINGLE-TEST-) IDENTIFIER) (QUOTE WINDOW) (WFROMDS (TTYDISPLAYSTREAM] (WHILE (AND [NULL (SETQ RESULT (WINDOWPROP MAIN (QUOTE TESTRESULT] (OR (NULL TIMEOUT) [NULL (SETQ TESTEND (WINDOWPROP MAIN (QUOTE TESTEND] (LESSP (CLOCK 0) TESTEND)) (PROCESSP PROC)) DO (DISMISS 50)) (PUTWINDOWPROP MAIN (QUOTE TESTID) NIL) (AT.SHOW.TESTID MAIN) (PUTWINDOWPROP MAIN (QUOTE STARTTIME) NIL) (AT.SHOW.STARTTIME MAIN) (PUTWINDOWPROP MAIN (QUOTE ENDTIME) NIL) (AT.SHOW.ENDTIME MAIN) (IF (NULL RESULT) THEN (TEST-MESSAGE IDENTIFIER "timed out, timeout" TIMEOUT) (DEL.PROCESS PROC) (RETURN NIL) ELSE (RETURN (CAR RESULT]) (TEST-MESSAGE [LAMBDA (IDENTIFIER TEXT INFO) (* scv " 3-Jul-85 12:07") (printout NIL "===> Test " IDENTIFIER ": " TEXT ": " INFO T]) ) (* * commands and major subfunctions) (DEFINEQ (AT.TESTCOMMAND [LAMBDA (FILEENTRY KEY WINDOW STDOUT) (* scv "12-Jul-85 14:21") (PROG (FILENAME NUM ITEMMAP RESULT) (BLOCK) (OUTPUT STDOUT) [WINDOWPROP WINDOW (QUOTE TESTSUITE) (fetch (ATPRINTSPEC LABEL) of (CADR (fetch (TESTBUCKET ITEM) of FILEENTRY] (AT.SHOW.TESTSUITE WINDOW) (SETQ FILENAME (fetch (TESTBUCKET FILENAME) of FILEENTRY)) (SETQ NUM (fetch (TESTBUCKET #) of FILEENTRY)) (SETQ ITEMMAP (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) (LISPXEVAL (LIST (QUOTE LOAD) (LIST (QUOTE QUOTE) FILENAME))) [SETQ RESULT (LISPXEVAL (LIST (FILENAMEFIELD FILENAME (QUOTE NAME)) (LIST (QUOTE QUOTE) (PACKFILENAME (QUOTE NAME) "" (QUOTE EXTENSION) "" (QUOTE VERSION) "" (QUOTE BODY) FILENAME] (replace (TESTBUCKET COMPLETED?) of FILEENTRY with T) [WINDOWPROP WINDOW (QUOTE NUMCOMPLETED) (ADD1 (WINDOWPROP WINDOW (QUOTE NUMCOMPLETED] (replace (TESTBUCKET SUCCESSFUL?) of FILEENTRY with RESULT) [if RESULT then (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL) (ADD1 (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL] (AT.SHOW.NUMCOMPLETED WINDOW) (AT.SHOW.NUMSUCCESSFUL WINDOW) [replace (TESTBUCKET ITEM) of FILEENTRY with (CONS [create ATPRINTSPEC LABEL _(if RESULT then (QUOTE pass) else (QUOTE FAIL)) WIDTH _(fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS (QUOTE RESULT] (CDR (fetch (TESTBUCKET ITEM) of FILEENTRY] (SETQ ITEMMAP (for I in ITEMMAP collect (if (EQP NUM (fetch (TESTBUCKET #) of I)) then FILEENTRY else I))) (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP) ITEMMAP) (UNDOLISPX1 (LISPXFIND LISPXHISTORY (LIST (CADR LISPXHISTORY)) (QUOTE ENTRY) NIL)) (UNDOLISPX1 (LISPXFIND LISPXHISTORY (LIST (SUB1 (CADR LISPXHISTORY))) (QUOTE ENTRY) NIL)) (REDISPLAYW WINDOW (fetch (TESTBUCKET ITEMREGION) of FILEENTRY)) (WINDOWPROP WINDOW (QUOTE TESTSUITE) NIL) (AT.SHOW.TESTSUITE WINDOW) (OUTPUT T]) (AT.ABORTCOMMAND [LAMBDA (KEY WINDOW) (* scv "12-Jul-85 16:19") (PROG (PAUSED? PAUSE) (SETQ PAUSED? (GETWINDOWPROP WINDOW (QUOTE PAUSESTART))) (if (NOT PAUSED?) then (SETQ PAUSE (CLOCK 0)) (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) PAUSE)) (if (MOUSECONFIRM "Are you sure? " "Click left button to ABORT tests, right button to RESUME tests." (GETPROMPTWINDOW (MAINWINDOW WINDOW T))) then [PROG (PROC) (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) (if PROC then (DEL.PROCESS PROC) (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) NIL) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests in process.") (if (NOT PAUSED?) then (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) NIL] else (if (NOT PAUSED?) then (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) NIL) (if (GETWINDOWPROP WINDOW (QUOTE TESTEND)) then (PUTWINDOWPROP WINDOW (QUOTE ENDTIME) (PLUS (GETWINDOWPROP WINDOW (QUOTE ENDTIME)) (IQUOTIENT (DIFFERENCE (CLOCK 0) PAUSE) 1000))) (AT.SHOW.ENDTIME (MAINWINDOW WINDOW T)) (PUTWINDOWPROP WINDOW (QUOTE TESTEND) (PLUS (GETWINDOWPROP WINDOW (QUOTE TESTEND)) (DIFFERENCE (CLOCK 0) PAUSE]) (AT.PAUSECOMMAND [LAMBDA (KEY WINDOW) (* scv " 2-Jul-85 15:29") (PROG (PROC) (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) (if PROC then (SUSPEND.PROCESS PROC) (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) (CLOCK 0)) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests in process."]) (AT.RESUMECOMMAND [LAMBDA (KEY WINDOW) (* scv "12-Jul-85 16:19") (PROG (PROC PAUSE) (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) (if PROC then (if (SETQ PAUSE (GETWINDOWPROP WINDOW (QUOTE PAUSESTART))) then (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) NIL) [if (GETWINDOWPROP WINDOW (QUOTE TESTEND)) then (PUTWINDOWPROP WINDOW (QUOTE ENDTIME) (PLUS (GETWINDOWPROP WINDOW (QUOTE ENDTIME)) (IQUOTIENT (DIFFERENCE (CLOCK 0) PAUSE) 1000))) (AT.SHOW.ENDTIME (MAINWINDOW WINDOW T)) (PUTWINDOWPROP WINDOW (QUOTE TESTEND) (PLUS (GETWINDOWPROP WINDOW (QUOTE TESTEND)) (DIFFERENCE (CLOCK 0) PAUSE] (WAKE.PROCESS PROC) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests paused.")) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests in process."]) (AT.DIRECTORYCOMMAND [LAMBDA (KEY WINDOW) (* scv "20-Jun-85 12:58") (PROG (FILESPEC) (AT.CLRPROMPTW WINDOW) (if (NULL (SETQ FILESPEC (AT.PROMPTFORINPUT "New test directory pattern? " (GETWINDOWPROP WINDOW (QUOTE ITEMSPEC)) WINDOW))) then (RETURN)) (PUTWINDOWPROP WINDOW (QUOTE ICONTITLE) FILESPEC) (PUTWINDOWPROP WINDOW (QUOTE ITEMSPEC) (DIRECTORY.FILL.PATTERN FILESPEC (QUOTE DCOM) "")) (RETURN T]) (AT.PRINTCOMMAND [LAMBDA (FILEENTRY KEY WINDOW IMAGESTREAM) (* scv " 2-Jul-85 10:36") (PROG (XPOS FONTWIDTH) (SETQ FONTWIDTH (CHARWIDTH (CHCON1 "M") (DSPFONT NIL IMAGESTREAM))) (SETQ XPOS (DSPLEFTMARGIN NIL IMAGESTREAM)) (for I in (fetch (TESTBUCKET ITEM) of FILEENTRY) do (printout IMAGESTREAM (fetch (ATPRINTSPEC LABEL) of I)) (DSPXPOSITION (SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of I) FONTWIDTH))) IMAGESTREAM)) (TERPRI IMAGESTREAM]) (AT.QUITCOMMAND [LAMBDA (KEY WINDOW) (* scv "31-May-85 12:49") (CLOSEW WINDOW]) ) (DEFINEQ (AT.COMMANDDISPATCH [LAMBDA (ITEM MENU KEY) (* scv " 3-Jul-85 11:53") (PROG (WINDOW ATUPDATE? FILELIST ITEMMAP NUMCOMPLETED NUMSUCCESSFUL FILE XPOS STDOUT) (SETQ WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (COND ((FMEMB (CADR ITEM) ATBUSYOKITEMS)) ((GETWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY)) (AT.PROMPTWPRINT WINDOW "The autotester is busy.") (RETURN))) (COND ((EQUAL (CADR ITEM) (QUOTE "")) (RETURN))) (SETQ ITEMMAP (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) (OR (FMEMB (CADR ITEM) ATNOARGITEMS) [SETQ FILELIST (for INDEX in (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS)) collect (CAR (NTH ITEMMAP INDEX] (PROGN (AT.PROMPTWPRINT WINDOW "No tests are selected") (RETURN))) (RESETLST (RESETSAVE NIL (LIST (QUOTE SHADEITEM) ITEM MENU ATITEMUNSELECTEDSHADE)) [RESETSAVE NIL (LIST (FUNCTION [LAMBDA (W P) (PUTWINDOWPROP W (QUOTE AUTOTESTERBUSY) P]) WINDOW (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY] (PUTWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY) T) (SHADEITEM ITEM MENU ATITEMSELECTEDSHADE) [SELECTQ (CADR ITEM) [TEST (RESETLST (RESETSAVE NIL (LIST (QUOTE PUTWINDOWPROP) WINDOW (QUOTE TESTPROCESS) NIL)) [RESETSAVE NIL (LIST (QUOTE SETTOPVAL) (QUOTE HELPFLAG) (GETTOPVAL (QUOTE HELPFLAG] (RESETSAVE NIL (LIST (QUOTE SET) (QUOTE HELPFLAG) HELPFLAG)) (PUTWINDOWPROP WINDOW (QUOTE TESTPROCESS) (THIS.PROCESS)) (SETTOPVAL (QUOTE HELPFLAG) NIL) (SETQ HELPFLAG NIL) [SETQ STDOUT (if (EQ KEY (QUOTE LEFT)) then T else (OPENFILE (AT.PROMPTFORINPUT "Name of file to direct output to? " "" WINDOW) (QUOTE OUTPUT] (SETQ NUMCOMPLETED (WINDOWPROP WINDOW (QUOTE NUMCOMPLETED))) (SETQ NUMSUCCESSFUL (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL))) [for FILEENTRY in ITEMMAP do (if (AND (FMEMB (fetch (TESTBUCKET #) of FILEENTRY) (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS))) (fetch (TESTBUCKET COMPLETED?) of FILEENTRY)) then (SETQ NUMCOMPLETED (SUB1 NUMCOMPLETED)) (replace (TESTBUCKET COMPLETED?) of FILEENTRY with NIL) (if (fetch (TESTBUCKET SUCCESSFUL?) of FILEENTRY) then (SETQ NUMSUCCESSFUL (SUB1 NUMSUCCESSFUL)) (replace (TESTBUCKET SUCCESSFUL?) of FILEENTRY with NIL] (WINDOWPROP WINDOW (QUOTE NUMCOMPLETED) NUMCOMPLETED) (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL) NUMSUCCESSFUL) (AT.SHOW.NUMCOMPLETED WINDOW) (AT.SHOW.NUMSUCCESSFUL WINDOW) (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP) ITEMMAP) (REDISPLAYW WINDOW) (TTYDISPLAYSTREAM (WINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM))) (CLEARW (WINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM))) (for FILEENTRY in FILELIST do (AT.TESTCOMMAND FILEENTRY KEY WINDOW STDOUT)) (if (NEQ STDOUT T) then (CLOSEF STDOUT] (ABORT (AT.ABORTCOMMAND KEY WINDOW)) (PAUSE (AT.PAUSECOMMAND KEY WINDOW)) (RESUME (AT.RESUMECOMMAND KEY WINDOW)) (DIRECTORY (SETQ ATUPDATE? (AT.DIRECTORYCOMMAND KEY WINDOW))) (PRINT (SETQ FILE (AT.GETPRINTDESTINATION KEY)) (printout FILE "Testing results for " (WINDOWPROP WINDOW (QUOTE ITEMSPEC) ) ":" T T) (SETQ XPOS (DSPLEFTMARGIN NIL FILE)) (for I on ATINFOLISTINGWIDTHS by (CDDR I) do (printout FILE (fetch (ATPRINTSPEC LABEL) of (CADR I))) (DSPXPOSITION [SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of (CADR I)) (CHARWIDTH (CHCON1 "M") (DSPFONT NIL FILE] FILE)) (TERPRI FILE) (for FILEENTRY in FILELIST do (AT.PRINTCOMMAND FILEENTRY KEY WINDOW FILE)) (CLOSEF FILE)) (SUMMARIZE (SETQ FILE (AT.GETPRINTDESTINATION KEY)) (printout FILE "Testing summary for " (WINDOWPROP WINDOW (QUOTE ITEMSPEC)) ":" T T) (SETQ XPOS (DSPLEFTMARGIN NIL FILE)) (for I on ATINFOLISTINGWIDTHS by (CDDR I) do (printout FILE (fetch (ATPRINTSPEC LABEL) of (CADR I))) (DSPXPOSITION [SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of (CADR I)) (CHARWIDTH (CHCON1 "M") (DSPFONT NIL FILE] FILE)) (TERPRI FILE) (for FILEENTRY in FILELIST do (if (NULL (fetch (TESTBUCKET SUCCESSFUL?) of FILEENTRY)) then (AT.PRINTCOMMAND FILEENTRY KEY WINDOW FILE))) (CLOSEF FILE)) (QUIT (AT.QUITCOMMAND KEY WINDOW)) (LET ((FN (CADR ITEM))) (if (EQ (CAR FN) (QUOTE FUNCTION)) then (APPLY* (CADR FN) FILELIST KEY WINDOW) else (SHOULDNT] (COND (ATUPDATE? (AT.UPDATEAUTOTESTERITEMS (WINDOWPROP WINDOW (QUOTE ITEMSPEC)) WINDOW]) (AT.SELECT [LAMBDA (WINDOW) (* scv "22-May-85 15:32") (PROG (AUTOTESTERITEMMAP TEST SETSEL ADDSEL EXTEND CURRENT#S TEST# FIRST# LAST#) (OR (SETQ SETSEL (MOUSESTATE LEFT)) (SETQ ADDSEL (LASTMOUSESTATE MIDDLE)) (SETQ EXTEND (LASTMOUSESTATE RIGHT)) (RETURN)) (SETQ AUTOTESTERITEMMAP (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) (SETQ TEST (AT.FINDTESTBUCKET WINDOW)) (COND ((NULL TEST) (RETURN))) [COND (SETSEL (for TEST# in (GETWINDOWUSERPROP WINDOW (QUOTE CURRENTTESTNUMBERS)) do (AT.UNSELECTFILE (CAR (FNTH AUTOTESTERITEMMAP TEST#)) WINDOW)) (AT.SELECTFILE TEST WINDOW)) (ADDSEL (if (fetch (TESTBUCKET SELECTED?) of TEST) then (AT.UNSELECTFILE TEST WINDOW) else (AT.SELECTFILE TEST WINDOW))) (EXTEND (* have to find all the messages between TEST and the  one selected *) (COND ([SETQ CURRENT#S (SORT (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS] (SETQ TEST# (fetch (TESTBUCKET #) of TEST)) [COND [(ILESSP TEST# (CAR CURRENT#S)) (* before *) (SETQ FIRST# TEST#) (SETQ LAST# (SUB1 (CAR CURRENT#S] (T (SETQ LAST# TEST#) (* after *) (SETQ FIRST# (ADD1 (CAR (LAST CURRENT#S] (for I from FIRST# to LAST# do (AT.SELECTFILE (CAR (NTH AUTOTESTERITEMMAP I)) WINDOW] (AT.SHOW.NUMSELECTED WINDOW]) (AT.UPDATEAUTOTESTERITEMS [LAMBDA (ITEMSPEC WINDOW) (* scv "12-Jul-85 14:07") (PROG ((INFOWANTED (QUOTE (RESULT NAME FILE))) HEADINGWINDOW FILEGENERATOR FILENAME FILEINFO MAXWIDTH AUTOTESTERITEMMAP) [SETQ FILEGENERATOR (\GENERATEFILES ITEMSPEC (QUOTE (NAME)) (QUOTE (SORT RESETLST] (SETQ HEADINGWINDOW (GETWINDOWPROP WINDOW (QUOTE HEADINGWINDOW))) (WINDOWPROP HEADINGWINDOW (QUOTE TITLE) "Auto Tester") (CLEARW (WINDOWPROP WINDOW (QUOTE COUNTERWINDOW))) (PUTWINDOWPROP WINDOW (QUOTE EXTENT) NIL) (* set EXTENT to NIL while updating) (PUTWINDOWPROP WINDOW (QUOTE INFOGOTTEN) INFOWANTED) (PUTWINDOWPROP WINDOW (QUOTE DIRWIDTH) (SETQ MAXWIDTH (AT.PRINTHEADINGSON HEADINGWINDOW INFOWANTED))) (DSPRIGHTMARGIN 32767 WINDOW) (CLEARW WINDOW) [SETQ AUTOTESTERITEMMAP (while (SETQ FILENAME (\GENERATENEXTFILE FILEGENERATOR)) as ITEMCOUNT from 1 bind ITEM bind STARTOFNAME collect (if (LISTP FILENAME) then (SETQ FILENAME (CONCATCODES FILENAME))) (SETQ FILEINFO (AT.GETALLFILEINFO FILENAME FILEGENERATOR INFOWANTED)) (create TESTBUCKET FILENAME _ FILENAME # _ ITEMCOUNT ITEM _[SETQ ITEM (AT.CREATEPRINTSPEC FILEINFO INFOWANTED (OR STARTOFNAME (SETQ STARTOFNAME (AT.STARTOFNAME FILENAME ITEMSPEC] ITEMREGION _(AT.PRINTANDGETREGION ITEM WINDOW AT.MARKXPOS 10) SELECTED? _ NIL COMPLETED? _ NIL SUCCESSFUL? _(QUOTE ?] (PUTWINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP) AUTOTESTERITEMMAP) (PUTWINDOWPROP WINDOW (QUOTE EXTENT) (if AUTOTESTERITEMMAP then [create REGION LEFT _ 0 BOTTOM _[fetch (REGION BOTTOM) of (fetch (TESTBUCKET ITEMREGION) of (CAR (LAST AUTOTESTERITEMMAP] WIDTH _ MAXWIDTH HEIGHT _(IDIFFERENCE (fetch (REGION PTOP) of (fetch (TESTBUCKET ITEMREGION) of (CAR AUTOTESTERITEMMAP))) (fetch (REGION BOTTOM) of (fetch (TESTBUCKET ITEMREGION) of (CAR (LAST AUTOTESTERITEMMAP] else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No files in group " ITEMSPEC) NIL)) (PUTWINDOWPROP HEADINGWINDOW (QUOTE TITLE) (CONCAT (WINDOWPROP WINDOW (QUOTE ITEMSPEC)) " tester")) (PUTWINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS) NIL) (PUTWINDOWPROP WINDOW (QUOTE CURRENTITEM) NIL) (PUTWINDOWPROP WINDOW (QUOTE NUMCOMPLETED) 0) (PUTWINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL) 0) (AT.SHOW.NUMFILES WINDOW) (AT.SHOW.NUMSELECTED WINDOW) (AT.SHOW.NUMCOMPLETED WINDOW) (AT.SHOW.NUMSUCCESSFUL WINDOW) (AT.SHOW.TESTSUITE WINDOW) (AT.SHOW.TESTID WINDOW) (AT.SHOW.STARTTIME WINDOW) (AT.SHOW.ENDTIME WINDOW]) (AT.SINGLE-TEST [LAMBDA (IDENTIFIER EXPRESSION PREDICATE TIMEOUT TTYDS STDOUT) (* scv "12-Jul-85 16:08") (PROG (RESULT MAIN START) (TTYDISPLAYSTREAM TTYDS) (OUTPUT STDOUT) (SETQ MAIN (WINDOWPROP (WFROMDS TTYDS) (QUOTE AUTOTESTER))) (PUTWINDOWPROP MAIN (QUOTE TESTID) IDENTIFIER) (AT.SHOW.TESTID MAIN) (PUTWINDOWPROP MAIN (QUOTE STARTTIME) (IDATE)) (AT.SHOW.STARTTIME MAIN) (IF TIMEOUT THEN (* The following assumes that the date format used by  IDATE and GDATE is in seconds.) (PUTWINDOWPROP MAIN (QUOTE ENDTIME) (PLUS (IDATE) (QUOTIENT TIMEOUT 1000))) (AT.SHOW.ENDTIME MAIN)) (BLOCK) (SETQ START (CLOCK 0)) (PUTWINDOWPROP MAIN (QUOTE TESTSTART) START) (PUTWINDOWPROP MAIN (QUOTE TESTEND) (if TIMEOUT then (PLUS START TIMEOUT) else -1)) (SETQ RESULT (ERRORSET EXPRESSION T)) (PUTWINDOWPROP MAIN (QUOTE TESTSTART) NIL) (PUTWINDOWPROP MAIN (QUOTE TESTEND) NIL) (BLOCK) (if (NULL RESULT) then (TEST-MESSAGE IDENTIFIER "got an error in expression" EXPRESSION) (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) (QUOTE (NIL))) elseif (EQ (CAR RESULT) (QUOTE NOBIND)) then (TEST-MESSAGE IDENTIFIER "returned NOBIND in expression" EXPRESSION) (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) (QUOTE (NIL))) else [SETQ RESULT (ERSETQ (APPLY* PREDICATE (CAR RESULT] (BLOCK) (if (NULL RESULT) then (TEST-MESSAGE IDENTIFIER "got an error in predicate" PREDICATE) (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) (QUOTE (NIL))) elseif (EQ (CAR RESULT) (QUOTE NOBIND)) then (TEST-MESSAGE IDENTIFIER "returned NOBIND in predicate" PREDICATE) (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) (QUOTE (NIL))) else (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) RESULT]) ) (* * lower-level window mungers) (DEFINEQ (AT.MAKERIGIDWINDOW [LAMBDA (WINDOW) (* lmm "14-Sep-84 16:22") (* * make the argument window immutable w/r/to attachedwindow package) (PROG [(HEIGHT (fetch (REGION HEIGHT) of (GETWINDOWPROP WINDOW (QUOTE REGION] (PUTWINDOWPROP WINDOW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (PUTWINDOWPROP WINDOW (QUOTE MAXSIZE) (CONS SCREENWIDTH HEIGHT]) (AT.CLRPROMPTW [LAMBDA (MAINWINDOW) (* Jellinek " 6-May-84 16:48") (CLEARW (CAR (GETWINDOWPROP MAINWINDOW (QUOTE PROMPTWINDOW]) (AT.PRINTHEADINGSON [LAMBDA (WINDOW HEADINGS) (* scv " 1-Jul-85 10:35") (PROG ((totalwidth 0) BOTTOM) (DSPRIGHTMARGIN 32000 WINDOW) (DSPTEXTURE BLACKSHADE WINDOW) (DSPOPERATION (QUOTE INVERT) WINDOW) (DSPFILL NIL BLACKSHADE (QUOTE REPLACE) WINDOW) (for HEADING in ATINFOLISTINGWIDTHS by (CDDR HEADING) bind word width (pos _ AT.MARKXPOS) when (FMEMB HEADING HEADINGS) do (SETQ word (fetch (ATPRINTSPEC LABEL) of (LISTGET ATINFOLISTINGWIDTHS HEADING))) (SETQ width (ITIMES (fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS HEADING)) (CHARWIDTH (CHCON1 "M") DEFAULTAUTOTESTFONT))) (SETQ totalwidth (IPLUS totalwidth width)) (DSPXPOSITION pos WINDOW) (PRIN3 word WINDOW) (add pos width)) (PUTWINDOWPROP WINDOW (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _[SETQ BOTTOM (IPLUS (DSPYPOSITION NIL WINDOW) (FONTPROP WINDOW (QUOTE ASCENT] WIDTH _ totalwidth HEIGHT _(IDIFFERENCE (GETWINDOWPROP WINDOW (QUOTE HEIGHT)) BOTTOM))) (RETURN totalwidth]) (AT.PRINTANDGETREGION [LAMBDA (PRINTSPEC STREAM LFTMARGIN MINSPACE) (* scv " 1-Jul-85 11:29") (* prints PRINTSPEC on WINDOW and returns the box taken by the characters.) (PROG (YSTART YEND HEIGHT) (DSPXPOSITION LFTMARGIN STREAM) (SETQ YSTART (DSPYPOSITION NIL STREAM)) (for SPEC in PRINTSPEC bind OLDX PRETTYWIDTH do (SETQ OLDX (DSPXPOSITION NIL STREAM)) [SETQ PRETTYWIDTH (ITIMES (fetch (ATPRINTSPEC WIDTH) of SPEC) (CHARWIDTH (CHCON1 "M") (DSPFONT NIL STREAM] (COND ((fetch (ATPRINTSPEC LABEL) of SPEC) (PRIN3 (fetch (ATPRINTSPEC LABEL) of SPEC) STREAM) (PRIN3 " " STREAM))) (* If any single item won't fit, skip a line and  continue) (if (IGEQ (IDIFFERENCE (DSPXPOSITION NIL STREAM) OLDX) PRETTYWIDTH) then (TERPRI STREAM)) (DSPXPOSITION (IPLUS OLDX PRETTYWIDTH) STREAM)) (SETQ YEND (DSPYPOSITION NIL STREAM)) (RETURN (PROG1 (create REGION LEFT _ LFTMARGIN BOTTOM _(IDIFFERENCE YEND (FONTPROP STREAM (QUOTE DESCENT))) HEIGHT _(IPLUS (IDIFFERENCE YSTART YEND) (FONTPROP STREAM (QUOTE HEIGHT))) WIDTH _(IDIFFERENCE (DSPXPOSITION NIL STREAM) LFTMARGIN)) (TERPRI STREAM]) (AT.MAKEHEADINGWINDOW [LAMBDA (WIDTH FONT BORDER TITLE) (* scv "23-May-85 11:56") (PROG (PWINDOW) (SETQ PWINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _(HEIGHTIFWINDOW (FONTPROP FONT (QUOTE HEIGHT)) TITLE BORDER)) TITLE BORDER T)) (DSPFONT FONT PWINDOW) (PUTWINDOWPROP PWINDOW (QUOTE PAGEFULLFN) (FUNCTION NILL)) (PUTWINDOWPROP PWINDOW (QUOTE NOSCROLLBARS) T) (PUTWINDOWPROP PWINDOW (QUOTE SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) (PUTWINDOWPROP PWINDOW (QUOTE REPAINTFN) (FUNCTION AT.HEADINGWREDISPLAYFN)) (AT.MAKERIGIDWINDOW PWINDOW) (RETURN PWINDOW]) (AT.MAKECOUNTERWINDOW [LAMBDA (HEIGHT WIDTH AUTOTESTW) (* scv "30-May-85 16:59") (LET ((COUNTERW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _(HEIGHTIFWINDOW (FONTPROP DEFAULTAUTOTESTFONT (QUOTE HEIGHT))) WIDTH _(WINDOWPROP AUTOTESTW (QUOTE WIDTH))) NIL NIL T))) (AT.MAKERIGIDWINDOW COUNTERW) (WINDOWPROP COUNTERW (QUOTE AUTOTESTERWINDOW) AUTOTESTW) (WINDOWPROP COUNTERW (QUOTE REPAINTFN) (FUNCTION AT.REPAINT.COUNTERW)) COUNTERW]) (AT.MAKETIMEWINDOW [LAMBDA (HEIGHT WIDTH AUTOTESTW) (* scv "15-Jul-85 15:36") (LET ((TIMEW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _(HEIGHTIFWINDOW (FONTPROP ATTIMEWINDOWFONT (QUOTE HEIGHT))) WIDTH _(WINDOWPROP AUTOTESTW (QUOTE WIDTH))) NIL NIL T))) (AT.MAKERIGIDWINDOW TIMEW) (WINDOWPROP TIMEW (QUOTE AUTOTESTERWINDOW) AUTOTESTW) (WINDOWPROP TIMEW (QUOTE REPAINTFN) (FUNCTION AT.REPAINT.TIMEW)) (DSPFONT ATTIMEWINDOWFONT TIMEW) TIMEW]) (AT.PROMPTWPRINT [LAMBDA U (* Jellinek " 6-May-84 16:37") (PROG (WINDOW) (COND ((ILESSP U 2) (ERROR "not enough args to PROMPTWPRINT"))) (* CAR is window, CDR is height in lines) [SETQ WINDOW (CAR (GETWINDOWPROP (ARG U 1) (QUOTE PROMPTWINDOW] (for ITEM from 2 to U do (PRIN1 (ARG U ITEM) WINDOW]) (AT.PROMPTWTERPRI [LAMBDA (MAINWINDOW) (* Jellinek " 6-May-84 16:37") (* CAR is prompt window, CDR is height in lines) (TERPRI (CAR (GETWINDOWPROP MAINWINDOW (QUOTE PROMPTWINDOW]) (AT.SELECTFILE [LAMBDA (FOLDER WINDOW) (* scv "23-May-85 12:10") (COND (FOLDER (replace (TESTBUCKET SELECTED?) of FOLDER with T) (WINDOWADDPROP WINDOW (QUOTE CURRENTTESTNUMBERS) (fetch (TESTBUCKET #) of FOLDER)) [WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS) (SORT (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS] (\ITEMW.SELECTITEM (LIST (fetch (TESTBUCKET ITEMREGION) of FOLDER)) WINDOW]) (AT.UNSELECTFILE [LAMBDA (MSG WINDOW) (* scv "28-May-85 12:53") (COND (MSG (replace (TESTBUCKET SELECTED?) of MSG with NIL) [WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS) (REMOVE (fetch (TESTBUCKET #) of MSG) (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS] (\ITEMW.DESELECTITEM (LIST (fetch ITEMREGION of MSG)) WINDOW]) (AT.CHANGECOMPLETEMARK [LAMBDA (TEST WINDOW) (* scv "28-May-85 12:37") (PROG ((TESTREGION (fetch ITEMREGION of TEST))) (BITBLT NIL 0 0 WINDOW (fetch (REGION LEFT) of TESTREGION) (IDIFFERENCE (fetch (REGION PTOP) of TESTREGION) (IQUOTIENT (FONTPROP WINDOW (QUOTE HEIGHT)) 2)) (fetch (REGION WIDTH) of TESTREGION) 1 (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE]) (AT.SHOW.NUMCOMPLETED [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:30") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 2)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 3))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Completed:" COUNTERW) (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE NUMCOMPLETED)) PRINTINGREGION COUNTERW]) (AT.SHOW.NUMFILES [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:28") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 0)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 1))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Files:" COUNTERW) (CENTERPRINTINREGION (LENGTH (WINDOWPROP AUTOTESTERW (QUOTE AUTOTESTERITEMMAP))) PRINTINGREGION COUNTERW]) (AT.SHOW.NUMSELECTED [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:35") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 1)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 2))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Selected:" COUNTERW) (CENTERPRINTINREGION (LENGTH (WINDOWPROP AUTOTESTERW (QUOTE CURRENTTESTNUMBERS))) PRINTINGREGION COUNTERW]) (AT.SHOW.NUMSUCCESSFUL [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:30") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 3)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 4))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Successful:" COUNTERW) (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE NUMSUCCESSFUL)) PRINTINGREGION COUNTERW]) (AT.SHOW.ENDTIME [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 16:01") (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 3)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 4))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "End:" TIMEW) (IF (WINDOWPROP AUTOTESTERW (QUOTE ENDTIME)) THEN (CENTERPRINTINREGION (GDATE (WINDOWPROP AUTOTESTERW (QUOTE ENDTIME))) PRINTINGREGION TIMEW]) (AT.SHOW.STARTTIME [LAMBDA (AUTOTESTERW) (* scv "15-Jul-85 15:43") (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 2)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 3))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "Start:" TIMEW) (IF (WINDOWPROP AUTOTESTERW (QUOTE STARTTIME)) THEN (CENTERPRINTINREGION (GDATE (WINDOWPROP AUTOTESTERW (QUOTE STARTTIME))) PRINTINGREGION TIMEW]) (AT.SHOW.TESTID [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 13:49") (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 1)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 2))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "ID:" TIMEW) (IF (WINDOWPROP AUTOTESTERW (QUOTE TESTID)) THEN (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE TESTID)) PRINTINGREGION TIMEW]) (AT.SHOW.TESTSUITE [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 13:47") (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 0)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) 4) 1))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "Suite:" TIMEW) (IF (WINDOWPROP AUTOTESTERW (QUOTE TESTSUITE)) THEN (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE TESTSUITE)) PRINTINGREGION TIMEW]) ) (* * window functions) (DEFINEQ (AT.HEADINGWREDISPLAYFN [LAMBDA (WINDOW) (* scv "24-May-85 17:06") (AT.PRINTHEADINGSON WINDOW (GETWINDOWPROP (GETWINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE INFOGOTTEN]) (AT.REPAINT.COUNTERW [LAMBDA (COUNTERWINDOW) (* scv "29-May-85 14:12") (LET [(AUTOTESTERW (WINDOWPROP COUNTERWINDOW (QUOTE AUTOTESTERWINDOW] (DSPFILL NIL WHITESHADE (QUOTE REPLACE) COUNTERWINDOW) (AT.SHOW.NUMFILES AUTOTESTERW) (AT.SHOW.NUMSELECTED AUTOTESTERW) (AT.SHOW.NUMCOMPLETED AUTOTESTERW) (AT.SHOW.NUMSUCCESSFUL AUTOTESTERW]) (AT.REPAINT.TIMEW [LAMBDA (TIMEWINDOW) (* scv "12-Jul-85 13:16") (LET [(AUTOTESTERW (WINDOWPROP TIMEWINDOW (QUOTE AUTOTESTERWINDOW] (DSPFILL NIL WHITESHADE (QUOTE REPLACE) TIMEWINDOW) (AT.SHOW.TESTSUITE AUTOTESTERW) (AT.SHOW.TESTID AUTOTESTERW) (AT.SHOW.STARTTIME AUTOTESTERW) (AT.SHOW.ENDTIME AUTOTESTERW]) (AT.ICONFN [LAMBDA (W I) (* scv " 3-Jun-85 14:41") (PROG (OLDICONREGION) [SETQ OLDICONREGION (AND I (GETWINDOWPROP I (QUOTE REGION] (RETURN (TITLEDICONW (create TITLEDICON ICON _ ATICON MASK _ ATICONMASK TITLEREG _(create REGION LEFT _ 5 WIDTH _ 70 BOTTOM _ 45 HEIGHT _ 75)) (GETWINDOWPROP W (QUOTE ITEMSPEC)) ATICONFONT (AND I (create POSITION XCOORD _(fetch (REGION LEFT) of OLDICONREGION) YCOORD _(fetch (REGION BOTTOM) of OLDICONREGION))) NIL (QUOTE TOP]) (AT.BUTTONEVENTFN [LAMBDA (WINDOW) (* scv "30-May-85 09:23") (AT.SELECT WINDOW]) (AT.CURSORMOVEDFN [LAMBDA (WINDOW) (* scv "29-May-85 09:49") (if (IGEQ AT.MARKXPOS (fetch XCOORD of (CURSORPOSITION NIL WINDOW))) then (SETCURSOR AT.RIGHTARROWCURSOR) else (if (NEQ (CURSOR) DEFAULTCURSOR) then (SETCURSOR DEFAULTCURSOR]) (AT.CURSOROUTFN [LAMBDA (WINDOW) (* rao: "30-JUN-82 15:49") (SETCURSOR DEFAULTCURSOR]) (AT.REPAINTFN [LAMBDA (WINDOW R) (* scv "29-May-85 09:45") (PROG ((AUTOTESTERITEMMAP (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) (HEADINGWINDOW (GETWINDOWPROP WINDOW (QUOTE HEADINGWINDOW))) (TOP (fetch (REGION TOP) of R)) [BOTTOM (IDIFFERENCE (fetch (REGION BOTTOM) of R) (FONTPROP WINDOW (QUOTE ASCENT] YPOS ITEMSPEC DIRWIDTH STARTOFNAME ATTRS) (COND ((NULL AUTOTESTERITEMMAP) (RETURN))) (for FILE in AUTOTESTERITEMMAP bind REGION do (if (AND [IGREATERP TOP (SETQ YPOS (fetch (REGION BOTTOM) of (SETQ REGION (fetch (TESTBUCKET ITEMREGION) of FILE] (ILESSP BOTTOM (fetch (REGION TOP) of REGION))) then (DSPYPOSITION (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of REGION) (fetch (REGION HEIGHT) of REGION)) (FONTPROP WINDOW (QUOTE ASCENT))) WINDOW) (OR (EQUAL (AT.PRINTANDGETREGION (fetch (TESTBUCKET ITEM) of FILE) WINDOW AT.MARKXPOS 10) REGION) T (HELP)) (if (fetch (TESTBUCKET SELECTED?) of FILE) then (\ITEMW.SELECTITEM (LIST (fetch ITEMREGION of FILE)) WINDOW)) (if (fetch (TESTBUCKET COMPLETED?) of FILE) then (AT.CHANGECOMPLETEMARK FILE WINDOW))) repeatwhile (ILESSP BOTTOM YPOS]) (AT.SCROLLFN [LAMBDA (WINDOW HORIZ VERT CONTINUOUS?) (* scv "28-May-85 12:45") (* * Scroll AT window up/down and right/left. In right/left case, tell heading window to scroll also) (* * only scroll an integral number of text lines) (if (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY)) then (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "The autotester is busy.") else (COND ((NOT (ZEROP HORIZ)) (SCROLLW (GETWINDOWPROP WINDOW (QUOTE HEADINGWINDOW)) HORIZ VERT CONTINUOUS?))) (SCROLLBYREPAINTFN WINDOW HORIZ VERT CONTINUOUS?]) (AT.RIGHTBUTTONFN [LAMBDA (WINDOW) (* scv "29-May-85 09:45") (COND ((IGREATERP (LASTMOUSEX WINDOW) AT.MARKXPOS) (DOWINDOWCOM WINDOW)) (T (AT.SELECT WINDOW]) (AT.MENU.WHENSELECTEDFN [LAMBDA (Item Menu Key) (* scv "28-May-85 11:03") (ADD.PROCESS (LIST (FUNCTION AT.COMMANDDISPATCH) (KWOTE Item) (KWOTE Menu) (KWOTE Key)) (QUOTE NAME) (PACK (LIST (QUOTE AT-) (CAR Item]) (AT.CLOSEFN [LAMBDA (WINDOW) (* scv " 2-Jul-85 13:55") (* did you really want to close up shop?) (* * do the right thing; if we are really closing, smash pointers which can cause circularities, so everything gets  collected) (PROG (PROC) (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) (RETURN (COND (PROC (SUSPEND.PROCESS PROC) (if (MOUSECONFIRM "Tests in progress: " "Click left button to ABORT tests, right button to RESUME tests." (GETPROMPTWINDOW (MAINWINDOW WINDOW T))) then (DEL.PROCESS PROC) (PUTWINDOWPROP (GETWINDOWPROP WINDOW (QUOTE COUNTERWINDOW)) (QUOTE AUTOTESTERWINDOW) NIL) (PUTWINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM) NIL) else (WAKE.PROCESS PROC) (QUOTE DON'T))) (T (PUTWINDOWPROP (GETWINDOWPROP WINDOW (QUOTE COUNTERWINDOW)) (QUOTE AUTOTESTERWINDOW) NIL) (PUTWINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM) NIL]) (AT.HARDCOPYFN [LAMBDA (WINDOW IMAGESTREAM) (* scv " 1-Jul-85 14:15") (SETQ WINDOW (MAINWINDOW WINDOW T)) (PROG (XPOS FONTWIDTH) (printout IMAGESTREAM "Testing results for " (GETWINDOWPROP WINDOW (QUOTE ITEMSPEC)) ":" T T) (SETQ FONTWIDTH (CHARWIDTH (CHCON1 "M") (DSPFONT NIL IMAGESTREAM))) (SETQ XPOS (DSPLEFTMARGIN NIL IMAGESTREAM)) (for I on ATINFOLISTINGWIDTHS by (CDDR I) do (printout IMAGESTREAM (fetch (ATPRINTSPEC LABEL) of (CADR I))) (DSPXPOSITION (SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of (CADR I)) FONTWIDTH))) IMAGESTREAM)) (TERPRI IMAGESTREAM) (for FILEENTRY in (for INDEX in (GETWINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS)) collect (CAR (NTH (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP)) INDEX))) do (AT.PRINTCOMMAND FILEENTRY (QUOTE RIGHT) WINDOW IMAGESTREAM]) ) (* * odds and ends) (DEFINEQ (AT.FETCHFILENAME [LAMBDA (ENTRY) (* scv "24-May-85 16:45") (fetch (TESTBUCKET FILENAME) of ENTRY]) (AT.STARTOFNAME [LAMBDA (FILENAME SPEC) (* lmm "14-Sep-84 17:59") (* assume that hosts match) [SETQ SPEC (SUBSTRING SPEC (ADD1 (OR (LASTCHPOS (CHARCODE }) SPEC) 0] (bind (DIRSTART _(ADD1 (OR (LASTCHPOS (CHARCODE }) FILENAME) 0))) DIREND first (SETQ FILENAME (SUBSTRING FILENAME DIRSTART)) while (SETQ DIREND (LASTCHPOS (CHARCODE >) SPEC)) do (SETQ SPEC (SUBSTRING SPEC 1 DIREND SPEC)) [if (STRPOS SPEC FILENAME 1 NIL T NIL (UPPERCASEARRAY)) then (RETURN (IPLUS DIRSTART (NCHARS SPEC] (SETQ SPEC (SUBSTRING SPEC 1 -2 SPEC)) finally (RETURN DIRSTART]) (AT.STARTUP [LAMBDA (WINDOW COMMANDMENU COMMANDMENUWINDOW) (* scv "20-Jun-85 11:05") (PROG ((DIR (FASSOC (QUOTE DIRECTORY) ATMENUITEMS))) (RESETLST (RESETSAVE NIL (LIST (QUOTE SHADEITEM) DIR COMMANDMENU WHITESHADE)) (RESETSAVE NIL (LIST (FUNCTION [LAMBDA (W P) (PUTWINDOWPROP W (QUOTE AUTOTESTERBUSY) P]) WINDOW NIL)) (SHADEITEM DIR COMMANDMENU ATITEMSELECTEDSHADE COMMANDMENUWINDOW) (PUTWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY) T) (AT.UPDATEAUTOTESTERITEMS (GETWINDOWPROP WINDOW (QUOTE ITEMSPEC)) WINDOW]) (AT.CREATEPRINTSPEC [LAMBDA (FILEINFO WANTTOSEE NAMESTART) (* scv "13-Jun-85 17:23") (for HEADING in ATINFOLISTINGWIDTHS by (CDDR HEADING) when (FMEMB HEADING WANTTOSEE) collect (create ATPRINTSPEC LABEL _[COND ((EQ HEADING (QUOTE FILE)) (SUBSTRING (CDR (FASSOC HEADING FILEINFO)) NAMESTART)) (T (CDR (FASSOC HEADING FILEINFO] WIDTH _(fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS HEADING]) (AT.FINDTESTBUCKET [LAMBDA (WINDOW) (* scv "22-May-85 15:30") (for TEST in (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP)) bind [YPOS _(IPLUS (LASTMOUSEY WINDOW) (FONTPROP WINDOW (QUOTE DESCENT] thereis (IGREATERP YPOS (fetch BOTTOM of (fetch (TESTBUCKET ITEMREGION) of TEST]) (AT.PROMPTFORINPUT [LAMBDA (PROMPT EXPRS WINDOW) (* hdj " 1-Sep-84 15:58") (PROMPTFORWORD PROMPT EXPRS NIL (CAR (GETWINDOWPROP WINDOW (QUOTE PROMPTWINDOW))) NIL (QUOTE TTY) (CHARCODE (CR ESC]) (AT.GETALLFILEINFO [LAMBDA (FILE GENERATOR ATTRIBUTES) (* scv "13-Jun-85 16:15") (* *) (for ATTR in ATTRIBUTES collect (if (EQ ATTR (QUOTE FILE)) then (CONS ATTR FILE) elseif (EQ ATTR (QUOTE NAME)) then (CONS ATTR (FILENAMEFIELD FILE (QUOTE NAME))) elseif (EQ ATTR (QUOTE RESULT)) then (CONS ATTR (QUOTE ?)) else (CONS ATTR (\GENERATEFILEINFO GENERATOR ATTR]) (AT.GETPRINTDESTINATION [LAMBDA (KEY) (* scv " 2-Jul-85 10:24") (if (EQ KEY (QUOTE LEFT)) then (OPENIMAGESTREAM (QUOTE {LPT})) else (SELECTQ (MENU (create MENU ITEMS _(QUOTE (File Printer)) TITLE _ "Print where?" MENUCOLUMNS _ 1)) [File (PROG (FILE) (SETQ FILE (GetImageFile)) (RETURN (OPENIMAGESTREAM (CAR FILE) (CDR FILE] [Printer (OPENIMAGESTREAM (PACKFILENAME (QUOTE HOST) (QUOTE LPT) (QUOTE NAME) (GetPrinterName] (SHOULDNT "Bad printer destination"]) (AT.\ItemWithTag [LAMBDA (TAG ITEMS) (* hdj "16-Sep-84 16:16") (* * search a menu's items for one with tag TAG) (for ITEM in ITEMS do (if (EQ (CADR ITEM) TAG) then (RETURN ITEM]) ) (DECLARE: EVAL@COMPILE DONTCOPY (DECLARE: EVAL@COMPILE (RPAQQ AT.MARKXPOS 16) (CONSTANTS (AT.MARKXPOS 16)) ) [DECLARE: EVAL@COMPILE (RECORD ATPRINTSPEC (LABEL . WIDTH)) (RECORD TESTBUCKET (FILENAME ITEMREGION # SELECTED? COMPLETED? SUCCESSFUL? ITEM)) ] ) (ADDTOVAR BackgroundMenuCommands ("AutomatedTester" (AT) "Opens an automated tester window; prompts for directory")) (RPAQQ BackgroundMenu NIL) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA AT) (ADDTOVAR NLAML ) (ADDTOVAR LAMA AT.PROMPTWPRINT) ) (PUTPROPS AUTOTEST COPYRIGHT ("XEROX Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (9367 16583 (AT 9377 . 9610) (AUTOTESTER 9612 . 14714) (SINGLE-TEST 14716 . 16399) ( TEST-MESSAGE 16401 . 16581)) (16628 24097 (AT.TESTCOMMAND 16638 . 19449) (AT.ABORTCOMMAND 19451 . 21083) (AT.PAUSECOMMAND 21085 . 21532) (AT.RESUMECOMMAND 21534 . 22689) (AT.DIRECTORYCOMMAND 22691 . 23307) (AT.PRINTCOMMAND 23309 . 23958) (AT.QUITCOMMAND 23960 . 24095)) (24098 38258 ( AT.COMMANDDISPATCH 24108 . 30527) (AT.SELECT 30529 . 32304) (AT.UPDATEAUTOTESTERITEMS 32306 . 35823) ( AT.SINGLE-TEST 35825 . 38256)) (38298 53841 (AT.MAKERIGIDWINDOW 38308 . 38784) (AT.CLRPROMPTW 38786 . 38985) (AT.PRINTHEADINGSON 38987 . 40340) (AT.PRINTANDGETREGION 40342 . 41924) (AT.MAKEHEADINGWINDOW 41926 . 42761) (AT.MAKECOUNTERWINDOW 42763 . 43384) (AT.MAKETIMEWINDOW 43386 . 43996) (AT.PROMPTWPRINT 43998 . 44481) (AT.PROMPTWTERPRI 44483 . 44799) (AT.SELECTFILE 44801 . 45349) (AT.UNSELECTFILE 45351 . 45816) (AT.CHANGECOMPLETEMARK 45818 . 46341) (AT.SHOW.NUMCOMPLETED 46343 . 47252) (AT.SHOW.NUMFILES 47254 . 48173) (AT.SHOW.NUMSELECTED 48175 . 49101) (AT.SHOW.NUMSUCCESSFUL 49103 . 50015) ( AT.SHOW.ENDTIME 50017 . 50974) (AT.SHOW.STARTTIME 50976 . 51941) (AT.SHOW.TESTID 51943 . 52884) ( AT.SHOW.TESTSUITE 52886 . 53839)) (53871 61709 (AT.HEADINGWREDISPLAYFN 53881 . 54138) ( AT.REPAINT.COUNTERW 54140 . 54591) (AT.REPAINT.TIMEW 54593 . 55022) (AT.ICONFN 55024 . 55771) ( AT.BUTTONEVENTFN 55773 . 55913) (AT.CURSORMOVEDFN 55915 . 56280) (AT.CURSOROUTFN 56282 . 56428) ( AT.REPAINTFN 56430 . 58022) (AT.SCROLLFN 58024 . 58704) (AT.RIGHTBUTTONFN 58706 . 58955) ( AT.MENU.WHENSELECTEDFN 58957 . 59301) (AT.CLOSEFN 59303 . 60543) (AT.HARDCOPYFN 60545 . 61707)) (61736 66330 (AT.FETCHFILENAME 61746 . 61910) (AT.STARTOFNAME 61912 . 62808) (AT.STARTUP 62810 . 63502) ( AT.CREATEPRINTSPEC 63504 . 64065) (AT.FINDTESTBUCKET 64067 . 64476) (AT.PROMPTFORINPUT 64478 . 64752) (AT.GETALLFILEINFO 64754 . 65308) (AT.GETPRINTDESTINATION 65310 . 66031) (AT.\ItemWithTag 66033 . 66328))))) STOP \ No newline at end of file diff --git a/internal/test/Tools/AUTOTEST.LCOM b/internal/test/Tools/AUTOTEST.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..a8c200405166c46adcee23ed7f1f4e10f1e5306a GIT binary patch literal 40326 zcmeHweQaFUl^%8$54*4TQx-Tbo!nzXx3(sYYm6!|N_Qj`QZ&By%FqG*9)|8h~;0g58UqTROG z%1F`vmAb!k&b{y5_hu-|iG-xB6=!(gefQmWKhF0#_q_4hLNS-AG?d{iJSZ}ZI zTz?@~e#x!AP%2b2FVu3?+6%R zW7aG5g7$MwYkkuih?QE+cI$O3ady&LbSfEZcCX#Gs;}>C?d@7t@=ST_EA)KAI(znP z%xbReVq7t^-cF#?^U3Mh>4EXU^x~;A^Ly!YI9shbm0GP($_-e0lDP`qEjbH0 zs&5p^S-0V}&y}-O>s`~T6taQKYQ0e729?~RQz+NYayQlhI;GYbw^VY<{78K_9`$ynl&e;q zIUb&RCR?a3I<-um+UK20HsdZXtEVd%z1j03RpfI{7DKAK@&>BHbmnrkN^Y)zN|d-A z?Hcu|ud}pLWv7NVr>*gqoC;>DzzXl6X%{kXdEm5leY^FQ^{u@f28;6m=n3rjChz#v z`M7;P0dPKi$8GyG7QuQlJ3TO7uqLc*p<>PA?_$L*E!Jc=Pg{MT>WlP8(vS7wU*z`3 zx9IO$bMa&Jmn(<*#_g0hK!AiDS6$4ym4;i%T9a0}=#*x%&RM52S3NyYE))mGt$4zU z)ml5dR&#y3wYs~t{knC1Wp}r=z4;ki|s;%@~wQxpE!Xwt20OcMXqkWNf|M1rzOE>@QM*mY+XnT0Co}khzeP5RfGZ{_gwDwK4p=Jkn{pBcqRZUT*Tf z^UuOj>i1udJx+hxM;fDC`|euf1izQ7^~JKhhwB=njT1aPhNCa4=lJ0gkA_vi54V-d^>bAJBY=eg)#%bNSwveN#w zI~aPPz)KsdY@FiS%R@32cZgTQ9SSv56#_DRudp!BfE#L90KuA`0A6LYXMsZ*ka=rr zYRX!yE1HK&(3n&*T$Ai-ld!GEEYJ{CY03us4)y@*z!cr5rqF%#WHiYPV9I+em)A*)zKVsg4`lM~6Vt^p_@<4z{e3@8D4Q!aHc6XC_Ou~mU4 z_OuP*=>6YypuRwVO9;vwrz_ht{9&UzNC8699N`0 zdm`Lf96KNCEPgJ~S$x{-Oml4MERHD!0V0k$iM-wbFXX#Qc!~oo!><7#7-NoOR?L09 zNyRaXnL@4PEDBeSPn@$d`CMkjRO&P3Y&w~VR54l+5x!H0s-WgDF8J@o+1jse!OC~UMxaxoJvw> zBvcli8S2=4Fbc2lEvv;Jn!Y>l|u8 zYwZiXsRZwzSp$k-UdE>^7HCLJN)fH~W$hG}P|Mwu)6?dy$?1eu%|lFH!0Jp+*%l=B zyt9~_SyuW1Ri~zOHC;{eTr%}a)vdVo8dt@wz%{S(S*a?yFXgh-C^4xTc{MiA$#_xx z9A3m~2|WNX$0UII`PxjqR&&c-nXrO2NdP*UNsHV|xiXC?3BnSp0e}buCQ}S;>H-|b zMTg5)66;B&B`b-gEZ0lbdWIMkAje8#Jy8RRcCnZvJvMPJVUa>mE7YJzBxL`o0`E>> z?{!g#K{Zox8T=C9A^rt$r3SW_0JQO6?2<2bTK4oguC_t3L->yg&;$0Q?TO!tG9(ge zk~Y*zg>Y!CN&s{whEwOX3{98$T#@z%bRbi#fF(e}wE&%1Q@VS$kHdfI&l1g&u&0P;LQoD1$Ora@j%#8Y-^hR&EK`)hcl-QWy$Z zz(HZQ08%guCB+l(Pg{|_M`1q3LlKC82@sNO4#ZuFfQb|!-qiaOAbNm1wtZ+@2H{MQ#U_9_x|L@k0bq8?8(=lM z9lZvYkOa^o*qIG_2z~&YQWYr2$|qqxuqy>dRdh28D8+pi36ljO3GM^8J;v$RlGtHL zxi<84Ew9=@7LW+QEO2GQ0w7~3pr@e`CBs8ZgeMj^_`mn&Y5gAHVghu)TR*(jUnLuo zf?5k3gj{2ujYX!i!af_=s)Z6PqJgw$fXGSVz;V#n3w2oDtT+}(l|cDb3A9{F=cZKw zbWv)s?X)k3=?LPR9!f$6D0T!02F9=;@%lWTNKOLWJ+`~PL3YEv-QTvThyv&gJ>{8` zl)1&W3guas$we)=& zM@&5eis`~)2f>SpDcBd&QZl8m07dk)TFYv3sGa6YNGimh>=}Op^jCh?Fa}9u*jHfioNkUCF z38UDAlU<5(0-_ahS(cU?5OWe%9rk9xz~WLIa?Z5H#aRd+K*hGGGM2BQ~3Hbvi22eA_0wAjrqanf#Vre`Ad0Y^XI3>R{ z5B!6YWF^3T)GcTR!CO$peKM(OfDOW=sXHb->lBJ$VJX;ucXmM2!xFDO5f910aSSG~ z4{<0p!3vCI#?3Cn?wYjV>|kk(^gj?=$dDwP#WnMQN+rAiQm*K8nuVa(qU*qd4N*W@ z;Byr{3v9i&JS=kpuwpUTe&r8%6$zPG{D31u(MFOPS)!yJ2H#|Q$ffLy%oRKuI6*WJ z4B@^0zP{+N6>%6F8I6~kH&2Mv^nIxn>sN;f68|{s+>jBEk@_G#JQOv$xOn@M4&UuK z`~WxaBC0 zX-uTT1`iIxs*QD4!VsX#gLn~yMA-}oZSbD4)UH;Pj1j>O;}Er^!}ydTM{$R7Y<=(* z@h+K&KrGZF>`kU{83zOd5YQueR*1RQEC3s-JT<3bVHCkP!30@y0UM;s6)GhQSc3+t z6H&4tbC5!!rUv^*a2!}4HL=h_0bXrLZUn!i?ARb$x*UhBspYjetX^IjRMcxjn?hhK zl2II88JANcC}E&%Tunfn@Y|X#32V-!tXO%=+J%O;Lk`jF+gq!xogMf(p$*3}?e*1b zR=f4;uJy{^?k*g%yIU6HlRWX;*7o|9HS;FX6_{kWKk5V`i?iLbUfX~K9zmbH7IugYKU-$7MylXZ3eA4MD5-y&g&xU7h0GAks`W9qFEP(dMnz4 zLjBo|zHb<7wtTQBSKajE;DOVRPM(R_ek`yTe;Bx8f=4?;R3MC_@su)9DO&^?A=yr3 zpluwCs{t3dr%A@Ul*Bl+CWVJkA_Ch5F61ka9;!{)CR&5*2hkcP9_g;jfIevm71(n4 zLBpILz!4fiHvq+;JN|L+(&hCiTGDSZ45Y!gHH4YL{{Sb zTh~|ic3RD|g14S+HUy%EW40%7mNfn{NCmjWCbH<3vR&hNH%k2ye3PSM-+Of zZV+PX5Mqu%h~d@bomk5-2J+9cx*)xb{zdkmYDR`5(fNop>g4C6g?HaxlB?rTT7D{O z9^o(COG?>=JtN=`0>Kl-7VGwOXAzhYkkiQ`iVDNNJ&ULgn1L5( zi_RRno?;UKDg9dRp0&=g76e5Dp%0O-L>}vl@X}o1-?b)LBk8v?wt9rC_(wQ387sT* zy<}EPH?)I&jOx;>@QKxrHN;b^Y#ltNg?e;ao!Ok_e(=^A{)@aRQAV3G%W4 zR1lq$Fxif0CQOhDg`l2*3oHSK<8dgzDU79t`cJ0A0QAFN%8Z#M{~$owunk~j`VK~? z949uk$WSLxZG$y&`1ra|gAlVD83@L)JBsedf%QNa_)$pf zKNmu5YZ|su=-Qru0eX+uNNb>Y0(>^?M@+D}Ik>R)Iq;k=E!Gyz*+4)WB2EBD<9HDM zvkIsHZ7=T4K%oYc=61%D@kv(H{S}VG)vW9aanMwvyd>~@=*=|S6HcuZ`H&RmLz2Og zz_#F5LGSZd31%Z2jFKlnRs#D*tdIP^#QVr{VU{n_B^kWBjI4Bn#8o22 zbJu$K3AExM?PalmOzY#sBn*QTXW27;} zZ|U5KKGU;ypjU0=f2rC(@q1W(@&hWEz9=A~glR&~?m3^hINk zpX=zqYwE`8Xs2QAf1x=X>0f{?+iO0GtEeGTsT=%)ci&zeRoBO(AmRT)ciI@+{{)fv zBSl(*#-K;!|C?@cBQoO8<}ZHjXY-`YhFEAc@;!4_%qst*p4R^77%=YsBY*4n#~UZ2 zk>TN^rHI`7C#7iQ$Bi*+(e5vQeDL=fc#b!oy!DB|?g{9C6H=H4m`v|D+x!k%aE1N>F;bnO>4SiQsNWp~P$i z49H|`BL=||wg~JX`U&e&=_MxWaS2uF#mGp%NFZzpUaV0U?7`=!^!*^#|C%{1Fn){ zj{q!pWMSb&fUpGrH3jj5y+MNr&6&X;ObpxOOEskRz!?;-0U%&$4_gu&jN4lgk{l+< z^jL!N5b{avJpLx9C02cX^9rnp8yhRzuUoHfZNnv+fU%C6+GNZ?Q=1HqLC8j%VGRV&hrj zq`3H?JWO&*K)z#9#dFWXAEV_15?6eofaDZUy|(tFpsgQK8{Z5{F9hcXJ;BVy1 z|8eto%y1G^H)5x5E(}jRVN~xwOHATp3+_pNdL)9Vc6aplW9|q%p(lRN9eMWhXa`*K zC+>-ni{A^pr}63Gr$2s}NFfHqZXk_A_wW!C_M$_e5I`@;Z#oFbTZI5j3+^coBR%F} zTK>FB&~~CAW+$R6$hHwWlaSWkn~K*UQ4sJ?R?jfD!3Nnw1qcK>(%zDXA6j1sApy9) zmx4uea68|=w*ve8POFVWAgyMM@EKA&VPI{oWvw8Fi){Ib-df**4`AnYWd{@)(?cLg zy}$$U$UVatQFN*`Dv{WXlOR--7!xXiJ&Ho}OchtkD@Z|K*rIF}eWS=anH0&i#5mVW zgJL5M3*@jy9EBJa0VIpC`DHR9w2%Dd)w^qVFW!8LFR$^{%YQESqI`7;hDR~)D6nVw zZ@GEvzs?^dj2rtW349;RyCd8#B7s(IGgB7Dc ze$5vT$^|t3QnM8K`Fr2KJlH8kuDx@4X#e=-p-zcgM6TUIwL9bv4o9DGPq?E$yE&G3 zPncuqxF@c?efh-xUmlmELWB?$kPLX#inrDZm_|}PYY9xGY`_eGI{AKS-@p%mOHBED ziWj74278Eu?xIF3CEP1%exX*vkb|wjTW0CyV9MQ?0l@=ZP*edyz)U@ZvueMwj!lIJ1q>aL&{Bl$ip%LwX>Qp$&T&|p}I0zU(cZfHZ zvvG=_5Nn|)8+1A`3sm+Dikh*|i7TMjPd^SrD3kl)H;+kdA78Nwc+v4WhdONJ-!$$q zOv|-+p`>iu{0n&o?k{q`I0EJHrLd=K!xskUxsR7`m)y~jFUjL_&`6b`{{89IvLFw1 zvq-6opJ;@Cfope+TZo~-zZ-pj(Cq&s>2+R4^1}sp1SnX{yQgkHu^$$&)!J z*Aj{%urdjKM>nJ@6;dRgJC7O}5!Ddybo+o{loX=kJ)+DSRuT?b;{gKoDk{Ua!z8)I zO%pw0x5FO#M3-}q0=R=uQ4qI^)ugD^Zqk#0Yd-V{jE)##KolSwEb0u`rA_=>sg;3~ zsU)*gQ$8updK;g3wB=-gNiuBd6k~D_RgQ&V0zjunWW*U48XxF7OkA3-OMw)`z}m#I zsFxIx0I682DH=|`Z?++mR}xAbN8Bs_O+4%bfu`UqlE(Slu9y#st_{2%d`7*eCv}Ht z6>JZV(4DJXm=A+-l#3`?Wf0aM-t*iaAlkbqdk!ZRJINI+VY zXn%?lev#d!9M=TKNznvdq*`<>q13P@(;m&aFy_)B6p4sJ>@VJ{4%3Qt5x}pG6ifuk zHA!#@AY+XEiLGsDK~T9!o+I-rM{!))-rBoP=hRV8VfY*=N-cpB?rfZK2ehp#hl5XspM+)O8E>O$P>>Mt58`eqRZr| zI>W8VTg4_>dJDW3P~vsyKKZ8Tk#Z4M<_l+Fimzi#eJ7&*(Z2Qca5PehT&sQ@BzE-} z^O>POKFAEy%#&p}x}2hBxyESqKoRy#`kZu4o-G<-(s~|{lgZ_>7#m_~s7_P}a|oz} zBuao65X~W zw@mIOW$r3}`%@w)i08B;jhUz2==*wvr*QY+)M0J*H-?A$Syq2(Y)%1gSN{DBNA&(DfuE$jqJfIJd2^8(2eh$#zH*vRz2 zv70y~APmh9Y8R{_F+1=`9J*z&0$w!fgHF%{DPA1BCsYHLnyXaY3VCYc!1d5=3M~&1 z**FXxu=wE|10B6nFM|9HUc*dQvwD~ugAZbA18CkioBm;rztOUkWtTA=12v-9Ao0qV6mE9Q-R2=t^2pHAS z2IW7+y93Vb-vRf~OO9#y z3kq^hjj&wgTlClo6MhIw;~;#e*{2)ZZtd=EZ{o~@8WczHwVLazICllUz_gtj+wh~t zu59gEE1OnpdmFa1U`rd&Bi$mrbHM7=Z|iR&-^I?(`qn1QY+(G-JdV?ET^$=unSW4< z637kSv0bJ95MT51I*2NA+UlD`q)^0Al1Y<>w_a+l=EoRG<%;Qos$sD;j5FQGWkTUs zSW@uWDkQBOVlOCF1lAr}Rh3Pru$vSRtPCqE83-w9h~_bd6vvYxJ;|`KSbfL)g0n!B z1pYy^hG$O;RNZ4Ct3Ai4iakT=kSqZj(v(`hl=a$rb9W8gXwrIZYrBa8d22c83CaoU z`qmEq#u11OZ?zoxfHh~OEsv3wr#of0r&0zf=A*ao5fQKYujZ7ri<>9NB!M zPxPeC_urQS6KW~0p;9hcYibO(hlcH=^ZmCI$JO4hNkg$<+*!^WKu{1hjrTr36uIP_ zI+$(@7N3j!h<**{oAM^U`{R81&Ra@r>y)J9&O-U^AIwLi7x({=_5mU#JO~N4ctf!D z53p0*zwg~3^i>`Wl5T^95zrqLLqWDFRLiMm;I6ko6VS79dY=6t5Uh%HcoMe|nE<7n z!r?)wa7~Ai>J?bw`K}>r1Mnc3Dtw{nKZ>J=;Xe+*!~y0E4E-cnBGkS{WFiieyAGLR z@CoP_3V^^cAhgw%wFv=-LW)_kXM+}zoJ*3AdLx0+GLbeCeQ;Wu#37P$2tRN{f(~9H zzQ7CYBG~ex(je+%ooix3=(`1mePlS@KO;K*n*3Qx562%Z_TNq&R~5@M1yPaT$rs*{ z(w!fudo%AWu%fMW=%L7u)QumP3`kIQtT?~RX0=-36xC52QIBgFqMpw}G81NA1g2q1Jf$9XVIo8gDczx20!ee6iACzJZJVd$` zl~DA-Bi=a0&l#sg+NHzK1O$?H2gNuK2nBLmfU<&6Y=E>MK@j)VW?GgxBeEFpW@biG zoGdwF{1LYSQw%|SE=u4*?|VjDrnY$^x1x}SIS>{+h{&)C1}nOxtuBojJB&5u{i6V5 zR@M=rtg+Ncdthu7kQ1v5flDu{7gdE27WmZsGw(3LfG^>&xOx7b?6Ud{* zKL5NWr_dM&=|tby*vMK_ws|-b5sgD+Zvg};`};`AV!8xj7zlz}CD!Qh76T*no&W=b zR2p)yOvv9P1TX`Cq!x{R45CiwG!v@H5edyI!(iHO_Z3_@jISWQ= z&xohhv8K+EzGzh zW;_RVc1CIx>tT@kQ1YkdS@$b{8lEEcvVea8CxMY@4eOVNgd0sa4?Yi(ef^}v3x-f~ zIrJ-+^2@8p>ng%L9dZ?B3&;amyF{ioq&#GUFPr7MEUX}MY{xPkteztlwm{ihm3j&5 z4b{7cSr5C=qZTS>cdaI*0q0e(uojbQE#g>jZau>hE>S^#i!e+jyd zwLmVdopIGIXrxJ5Kqc;6#v38x-j!DXta@dPnG?LxVy*wYk-tT_eLMP-cPQxk8bb#EKqnaBB_Q<;<_x3C#*1P)IdPex4lGFB-FAfYt+CRtZ6;rlqSwd zB!~%q^+-^uGZd8ek)O1q?}jS+-yQCc7Ou`0-Z5ezm<>`0;Zb5b73?9bsl7(S`I7)7;KPsyjWEk@A9D zz>C}UGVBILJ_T&+kYKcO0_(PtARuCjQ~`1)1z@IW_(o5BDltP@T3d)oI4@LB?=u_s zeZf$!CqDONS6am3ABZ;5{h2-GfI3 zTO7LEup4^P4-sh!K7oAdZFxd(Impv}Y&k+wX32jM+HRqM@JcJu>A_?5@7@!uuigo6 zI^jJDPs~P0hT3%)1-z{>kQ}CJ-gd-M29ca~KtXcjN!j+WL=4fy>-*kF4rge0 zPz7A1-oESnb7bPUk9~(>vZ|tw!dvhAh#%VKe*j7E50msG4`%o858b^TF?Rb`LDG#g zCchj_ukNkV>GD_i+U8bk8~87`$y%cdGwr{7PxNj-tR24fNrP^LNj!LLPh^K3VUGPQ zaY#TtcK_Fc&65_Rl8X}~(&hVx3}2VktUk9HVDi2rue;OkEJtLU#uYL)r zsP3+8@0xT%`NSR$P<-v4Wa42-0k=jCDq%1MI(yPf8Zh%0_)Ou~LNI`8qBe+fDyZUp z%LO5#0HL6e4ez}Kl0BU5|J#Re|3eb{58HZp?R#&%A))zO|LdR$K$D~GmhGXlBL3BV z>jRl58 z;7>>Zk`T1S@rFFE2Bl01;Y29n659(GIwc>56WWW71fa;A^zH{!FLxvDF-BSzkO`a_ z3K=K^**ZAGv`!Ws>ICZo%~v85pqj!gtkzKSMLV##H>4gk;N;e59fS`oDP9zk#D-As-n2?-mR~>BhkwvH{Smp^87Pg_Ari9g8Xi8 z1*M<@HDxvv2)v-=gdnMgUml_xS-Mrci1OmAt9#mHe6|$a88cu^S>-e;dY)qijR0x9 zx=^ko%N=Dsv?)^~#dTn}krU}+a3@_L$Pr`v4n}3IC8$yutaJ75&6x8@|34Ii|IHId zduJxY%&e2vCEz>G(J2qMkz^i63Z$~pZLfqU;L_~H9DCE$BKz(!Nr7O7*qeMytr&9g z9=>8KZ4YH8y7&1v4$TqTrg1SKi+mERr9c`~=8t8mhSVR(A;NB%&{6IO2r!H>;L|`# z?=aDliTb@#u&bTKaZr52j5e;++T7!PE9|y5KvbF-N56;?;k4puaE3!tm50)dQ>t=y zTX09x8?a}LX(hXFu$3@Bo7t`@u{9rpN5uQF2i@9E-$U%f47(j;{fuE7gL+o1NpLADJ&d-QwWjx1o zlqhDYmGY1@yGgBqRxj@cIfIGM_T2kUlA-(W` z`H_Z5ntMMf2`SfV)-6AWw3l>rCYYFpLLEFqzIq9A%LIf}FccDr)I_l-2tR!Q=^>%( z@M&$Gdh!ZIm{P85795RFS}>f;VN#ulnoh-GMfd&J!KbvtbeN8<{uh#S=(LdLRtot*ND*8_o+fa$TR!@%)MwEc#NI9!L2-L!a{U+L?#Uy#sFope=fmxIKoq(LF6Zp$pSSj(+*cHxSLT& z!X?as^+m+I(t#TY=FTz_S{RQY0)Tj5CQoevR(@yd*sa__jGcc+&g1e8lUwov)ff5X z1^qmX#D3;GM8xNf=CelOTz<4ee1oFD1KImjJ)g+(QucZA6&!KLpN1rHjaj2g8AT-8 zyH<3Y^7(K3!F*)@w{8B&VGO zT^hOaE{M1X`3+3}(6l=tBMLr66bjtKSq3xl2S7n%8ghUbOo`KqaGEv!ktbtY0b4qq zik21BzW6RcdZqXvQ3Ze;Cs!Nfs-havF^XuQJU54Rk&WaDFVk34)kD zVFo5=J_63Kzo(_wCw#C}(HQ^q0L`30nR{m{Lr24FNTNwWzCvpFq^W|p9xT+sw{`mK z!_JXB)VKmd_M3>=|1Fi!>Rag((HVxJ-$SX62>!7j%->yui{JAQJ=4?N2*v zMj&lO3^y!W2vG(Tr;{!$CE^AA)mPJ1h&yD$Bny3Q8A6Y=6q12@I%PDD_V$z<_XNW? zPZKNXAaJV*Qc$4)0va|j@G5v)KgId)7n+fm)xLity?;g(zhg))`;v9; z?jJ8OE&AGmv%tVH_EzEcqlg>6_-6ju??YU9YaTO&(J64ym*Eh`Jk9?2%M6$m^t=}- z|1xla4x0jym^fpu{1;(xCM2?>qe67~g?A60=D+?A zH)EPDgYiXAtQjTDgeh2ZosrFgGGdxiah$$TV}9x)4%$4|+FjgU-$e2k&fiGJi>~Kz zju6cX8!J~@6um>)GnqZXN)~F1Eg?x!79aanT*RS8>`LCHgd^A%^)8BI;;yjK%Bn{_ zs!x+)oZi_hQhov-AhWHnqSrTw>LS%8K{h4HjLobxk=LFlVl_E8)XFX&V}qF{#&5M= zTWcXXJxcG;h)bkQH`aI8YAaWSsX&ZVMo&<~nlnej+$UM+f=s1|$}((P zcfVd>a`NB#u(Fcy#^u-zmp zKI9wK<0j`B7lnF!oU}Gp-K+tnY3(Adk52a^C&oW#ZLBx(6?7xV|4Msj3;DAGc{-8# z#~PP}VDdWJHF^q; zk$WLj#(7iqCssjzuMIrQ-8S{J+;YI-g@3D zt>85CfRU^0)y*9|I9sNNJW7fWK$@u`h%)Na{PY$OUyFNN-9m=J%_b6nYP&X<(j8Sz1{1gO4FNZgJAwhC#@^Xs*w>MsUOvzXYU29Nzr_~2MPXg!e2i@mmEQ%_C@VQ z52(}YXPg{lz|nqoy_D3ouH%)Y3Z|%pV4<(%qC)UYJ6XL7abVI!eBUE3JZBQ!2z-|p z6-2?pUyDVxw&A1b+jiA_x0=AX0YbSJaLn7*tp(u~4tEviBaqJSzv zji-m9QAppB8ir`-ey|IJC^1bsYs!HbVK$d3I+fgci@p|@297Qgp&Wpr9SFO)Of;p8 z(c9OWatB*H+z5xDvseduZ9IygHeM-?$|Yx{L# z?^>J;zLV;``SKKb()@Y0tQ%MWZ~kgUDvF!y*_4Y;$-%VIBNdUIVqDb(5@td4#%Kma z^5ysRlzu&V*|58qV($ZydIwCg_amtnR{H<%q+TD+Owrfl;4Cc@xGL=pXzZupRa%os zya9n%+P?^F_{BtB{roQ{@9JLeN9ye@y!t(8D->X)htU23Pj?BxA4>l92N9Hl{rV4< zg?|xIIM}}_5F2-Tip9bETDFiLL^hTd3O-?09{-TWA)oI0=X}`e zfd|sdA)S2GdDjM|u|pp%%SX!+UV+0A_d!C7qXQV56;c{VjA_`ogY%2?%kTJ)v}nKr|G4!d_J9@^{O2ZNf~0%$!EOkbP?4&q1jB@ zDR|2=n@$&HSu!Y=y!wpP$MQ~b&LqZpZhmNW&rUG%o-d8%yM{<(=`kT9BHfFaHfW1K zQS7wzLR)@6)gQ9+do({}h=)`^AUHR7N0$+8#A2J`vK(vup*XGX$oz{fFfVoa&}!&x zJ^mfq{KK{WsPmp{`_Zy|v@BgKa45=s1T9@_<+{YidsL(TfmDCgd5^{Yzj)1kPTS?n z(T*PN2G54N/<€IĎk],Ĺ4Hí% ˆS3ŸĆŸ1@Í& J$:”-5…30D˜U.9K*Ɉzš \ No newline at end of file diff --git a/internal/test/Tools/DO-TEST b/internal/test/Tools/DO-TEST new file mode 100644 index 0000000000000000000000000000000000000000..7245314f7944efc104884721bae8bdf97ce8a26d GIT binary patch literal 37656 zcmeHQZF3tplHR0J`sTl|g>Wm;SS5PnWOr{P@A*QJl*KhgGUU)NSNsh!VI>ch{i(bHf4a{`B>qmAZFN$v=WSdpnuENtPcJUsm&j z4@wc4XN}>ApG^H`|73LEt#-Lcewxm&Ouh5TDnZTK!*A=Y4zWC=)Fg(IlsJKOy9g+sp#y!diX8K^24=ymdvh_2TCaQZ{m$-uVrWD{MTR0Bj^0S^HF_`W?cuOL z9POz+lDFRMwi~_ipnlXJo@5`ZBIqA3X?10sSpbUt^M%+BE58I=0H%>taOAQ)v z+#dEU9QoF3oV54uyTGKs7`u}}e;BLX$c&tDrNT?2+Z9$A@r6j+zx5}>{&=9ksN_&W zSM3*rb~848bQ`fK`+tQ5m;~dVvX3W?=CH5dM(y}}(??ALLo!R9&G2=Fk0p?Yb2c$O zBI+^``r^%C_Nu0$1I%Pq>vl$in#}B4psr~pIxqwAF~hKlGTtzyq^~#%n}Fv=sqz?9 zgX=KyeUFM{V=z)P?(}u;JrNcb<{l|b^Fj8mhT~qHa~_=B%07<*hy}RSVPj$3 z=biYtKaT5~`^dm%TKJPBG_So$*BlRr?Ov=G3C><`!sWR{5Cfyd9&Own?Cg+Idm^?U zJ%a2#nlIGZ{N3gBA~{#9WVu=%)b2x!xs{^+Anu%W{<96?ZkqHOAV^Sdl&%o&oGG+8 zy1KlaFIMU`T3$|mn$F%>pi4EMt>)@Aa9Kh?$8V=gb)LMQ&XT2Cy-kEwNAmOKk8jlK z`ZC#9@29J`rqE)kFbt%Dn#|7avxq5y1|hGKzhCmV^XVcvTU}f$tbB9Zyso9CoRMx= z7%ow8`crao{h&Y>J88KF=(Rk4Ie?_cJF&ph=Mq9c2R`K~goQm{Z)c}AUUGourmtqG zNF=9Q$=@dxdbO?}*&NcH5^83TLd;ust0v)CoD zz=8}&?6OfN_`2?TfHVEFhR3}ol+ab6;OB8K#2Y>ouX;W1*NsF`PudW3RD=}AnnG`| z85$>Cy*EBNY!9oVl5tYAKX@sG!n)kn556(N+Y{hTbO%U}KyL+U^7LZ82yyh$E6 zu2%EMTnOqAepeT(B_^BOCqY`)VXI&Q)NWM!85}$Mar316m}MXDJ>Z{5 zpz)d_FCNtb{FfJl`n>=Lh%}GeBWZ4wwRd}f9^Sbz&H69OH0gLX`*AjZKNCWwiuBH> z?&^$Uc)hhU?P_U-ZV5(Ux-FFFpjuV{tV?-gZ8UO653{vg)mZptJ5~5jG~Y7K*5YXR z=~p6HC32a`q{nLKGs7cb4@yaLR2{2aoeCEf*)I?Kt(Vj%_!m{tfxNb$msMy=)Q~h- zYE}mDBQ;&A^Eni#UO$%g)>rnjm8Agp^Upuupbv?gQ+Tuqm)8&5lg0=f{HGMbz z?_{wL?PM-BP%~Z1BM41x35)hBGBBOi?6d7Ef5}8^)a>_K?yyDtG8&K;c`9YK2sje` z+Z0n#6OuSor=*g_CTg}y>Uk9-^v!E8*i=>}>Kv&E%X`%JZQBF*8QQ}J%$H|@^`%f+ zi*l@_hy798p_=rcYiJ`@d*W)S!w4CS<2_ZQl!vbU;K2iRGrIYrW~t&-4-g&wIXY>d z94adKVj8iYp;Fc_HhdbDwA?i2MSVVl#?7Tgy{g?bUe%y|i#BgxXY&=hK3(c<5- zzLV;#GBNeYc&0WfTaKORz@Aw4cTGO~s%Y|LJ8vC#keyR8d}$F#kXQ zNl80O1u1(xIs5Sdvj8U1!C@OSs4ZsbK?8>DP@P>&u9gtq;2DbdALi%R^7Fg-PYJ)g zQ}e4;Dr=>YsM{BX6@msU3B=ROlf!-&Dy)%&>lxV!C$Dshz3oNruR*+gcAz|E*mgjL z0%XHnYXkgFzczcfZmpvR(VdR?EJiTY9n3qzz(h>be-SG*D`J zbwiznH+nqmiTU8bJ~cB-YaPB7q08oA?SH2k;;=vNwFYW;PfPTU=M?ju!{qp1C? z(XDH#Y1V?!&}3CGOj@>xx)ne$ho4)M&-+p5Ne}bEI?f^(h)3?ATDB8e<=2i5yZz=< zwPw8l^xG`OPBUAr%5J@qWwOEook7{prQ+5JvL<%@>|=M$;s)9gxDh^+V8BxG{bjq_ zFbL_y1rGWL=)+W@t6*A`P2wFh7CCn6cRtH)X44=y{&@A}(>4tY?XMZCUGpS+$mNWm z&E#klH-<6n0@+EH8rIebnhc&+2Z7aUH@l5tn<$MC5Yj=POKgn{8^oPx6Kw#q4h}LG z1r@bALj;!ehcA`sW1c|751V|jeVdIgozoPY{{BAD8T1NFAicJ|wA*QefSt3XrGnQLXg11)>{wa8bM=`>Xo|r965a3umsR!JPQc(%$ zY&38CWE-lponNgLM3vnZ!Aer%1C4U%V=O&-EL9%}7}iapcHyZI%=aj?V76x|se57vNmMKS-l36OoLrc$3VM z1)?iOn?{)D3fkq_B6*k0R?xAp_tg(qE5FtvSzRq=OLcX5HesX*gK%b(cL_Fo-oKrm zy;bAc^zVq9S+dvGHLOeq#mDzTf?P?;9A(FGM2ProQ!hE)l%pJ)0 zM$0gz@0}J0b?l9{s%7)ZTS8)`H7rbuc zCRFMND3oTUXfPff!}Cp_<1VxqG-IB{7n^}GpMBt7j|~o6{@Km&3nJ)(GdO%d?#Eb8 zw71y7(8tZ`xI1lKc=8-nz(O61WS2_S1{Vp~4m*{UL5oC3eW{xUt)hwEGom&Nxsi@j zp=Tc1hiydf!V#X40*_z{)1P3V3Q!Ls?zP154gr#SR`dpu<}W+Hb%~wNEMJa$zXDTo zBe8URLe%EiSe;B_ZR#LUIYFiP?FT4?fj36$rbaey9`%V*{@;2IcKWvl(&lkzs~+~? zf~Vu2h!2O$O4`^ApAt*#1H@oUOtc*rpS{fb;qey@C9;>6b(x^kauzstdMyf|3^zz> zXv;64W0-`^WIx(fY5%+IXS0K{|D6>s zxzS&@YaQicN6<8FWE)h0{hSIR2pLk~PH*Q>Hq!kK8fTw8F9yB993u&Jd;+Zt#JSj2 znqD>?ws;yHWB(H7R=vpsFJ{e_Hl&aar_%(L|0BJnLq?Y{5eI%o<+S`MtxSQoz8q&I z&uoYplnba7dUhD8<2Miqe~wfPjkVX(1vt4f%@6LsG!{%|u9)oR6i4u6hu=cljr74< z|0A(Ji5Zk+&5xpC86~W2e=mjOKLh}*H0sZn5SHo+uY_BO(%$ z%#NztasdBaz|MLyBO)KsD;Ba*{=tXJ*i`DEb5w7?z*NxuplP!nW(cQs-^@1q9RuyP zpVtxCG~%S82{L&tryH*M zjD0V<6-@kLG=O>bafs*e;p<+AfOpuKEQQyk#HA1h?d!BKcBM%2`|dA zzhK=F>UyU=ACrDZz;(YxLB3Ongc~H>owuSk3KeH;H$VDA`0=py{Qqz{zbxgYa3f_i zG(vn_y?d({RPUM5(P?#4s5O0K)kMsL=2zq?mJqexCdSR z8NOS4>ex)3)R(Bf)S-afY1>N=&&!EN97!3r;zOLmSwDngiuYP^|0$HL+9>W1427st zO5G@mhhy!w6y@X4IN{OV6cIZj_$C@SRPq?7n#@ALg*1hc;^SIqf}@-vhew>U z3LS4Se&8e=D#D8NXN`Q5UGY~3>oh7rV*PY3rV=7w3GNqf>IcpRHMy7{e<{&7c*SnMNMl6gw34>u#TVv|VFu5%t|Ql6<=w=- ziZnIaI|VD1e5uWq2kXR^Yfe;H7}#>!JH4=K%R@GpTpxethzb2w| z>?7Ywa(2aYr!*08T5Xopf4Ig$Q0gN%SPU(M%(PUq`K(SD^^5uZM;4dZ)qNItKVe)7 zjv(u(mE@<%#T7zZhyqLyIpQ&yUB8{b&(s*lP6M4=N4=x&6KAwIP{kO_H#$7_stBb!0us+R*9pUi>e68*;o*Z#0!D+N|y9)MdpC z++7Zg&c6ek?Of7%#-LIYXL~e2f8>yv@7ZH%jvCWSp0u7CmUU4|-+}QN!TNzBt!JBr zBtb42?HW7qSZqPUmW+@qjSaF}{gF}81MVg`wyVLGU|(#K?lm_}q=AN~IKX zgOY@2XStiBk60K7^uf)S%G&ob7t+-yBf!R|lBt{Hp-o_JV_OHbzdV79J2e5k%sELD zDm$zX#yx*$Ekj=0gHR$&hBOf=!f{ms2{JhApDcVzYaB8(UI4!Ai}1+zay>Nsnh)kS z_?N=p#H!L`tu<$)Fp1|7O_hCv#NEvFhNydzXtLgIKWlgQ)HfA72?dGyDN(KWBtB-n zY8CHbh9O>|`|;N}YqgPdv#FktEU-ND@2u-Z6Hdj}@X z5bDXWnWPRwzW$~&10&M`^OJ(qJXTm4K33~HiaOh1Dot495#B}$s=_+0!1aS3f@kC%^X6k_1XL!nyk(af=LvfO_)bpPa;7!tY2=4 ztkqA#3%Ndmr3G}3Gc6a}EhQ$C!4Vp9u~uf}Ql}~nHk2p;q6%Omi7>~D z&hKj;Xvp!ye`p{7c9J5kr~Ct>fjCb!3TvT`Hu^Ui0qI;x~N71NjoujDqxp}NfYAPB02o3e3b z!|pv5Iw!d=u}0En{V7>2ndcGfrfHB%rwMTpQ<*^|G>}&)&>r=6V1r3XXJ81#XCN*2Dml*}WR|qotL!D;zmhY` zNLz|rU?q9P67&VTlB?+%wheWUyu@O9li0~A=42JiF!7$u)H7oz7JrcU+)5nj)al{n zAahGO&)mSUQMAtI!eix(WrdphL+XYVqtWh3<(YD`fp;MDuQu4EFt3t&i)eYfD;URLVnX~|G+obJvz)jA>BXS20gL&l`4+mxHmf$Kh| zr%$#)tYpotG}SRRPk)UBcW$Sg=Q|h%2bxSYI{>#$m*>E9A8$1h4uG;j*=Aq~j+0Yw zWQTL^6&09!wSV1|>Gvd;yeL|A6BQxn*5y(XI^IU`^vbY{|3FQUeHigdFp3t*8^m9W zqD1!{^djchEmG&s6Qc{V8dr#9LDV>zfoh~rm2wcB2o*UQQ;iX-Y7d(8Z1@*Wv_JuH zGsRVFO&G4(xLr-I@_wUKu_>x$;DnR&tG>xtTOB*y&rScM&6LJDC2tKu9qIu<9@VmS zW?M}QWC}rdr8U__yv)=uAfMfB4tvbcvozeJR4FZ~a>2udG#qTCBn;l2%lWOn0U9k4w(E^vPGJL87eUwSdqZ|G*%-^6h*tR!r4%SK39@h+_p zl?6_m>Fa4xPmxOiKn}^3A~IiY*C0t=D5P-541uMJt40)GO?ZaYHsFEMk)vLFsO!BW zFrRCgLS~>5Z;R7&UayaYpLfpG8cQ6;F#!{jLRcI}vRxx#+BWycM9~E&*Rf=g9r9_3 z8`QAlGg(X+!GKHDlD}O|;8l|9?nR}1lh&DA9y47}yl*%_3<-_s_zaxRK7x_~)viVAmf~A(u?g<0+&@a=}wg->DT|sc{)9#!Fu*whD=^TT{xM{D{mY za~o_PiPd`XF%vC*Ba#I&1z_|Q7Bc?3K08yZbi$OpADs(gh(#Kpg@bQ84OSMpgtNvy z`aM0Yc2Qk0fIztCocrrX;(=e}2$&O^e+u;g{Jl*VWRAV@7yxhwo z%}gILA=20b30cU6T6%5S@Pu_`Fd4^99uSbW^4Js>G;!SV_EPm`zTiP6EIDU5i?o`%&9m& z$S3lnr+IAXj?Vip)wZHcc%b_@3p&Nc(>O6|##JFrq4<9>#9K9B@W#d_ZhX?+x?TN7 zTE8M)Y+%0T;c7!;V)<>A5=;v-EW6Pf`%%-gr20J5ULdUZ48AGy0?q4T=gBbxuu70A zGKRSWg8m8vSO*`=%NB45InN&y16gl*e|L$oQ$$OD(J9X227|3>i)f@O_bmrjKoHnA z^sz8ZA~juoOAPXKx%tC6L?7?+xg9u~r6h;c-Vzt~2S#6)QqQ-E<{64r~5 zX<{@U@alQqxh<*SB-ZZ;M}&a_)mD4uuJ87f6x{YFWXaLW7pgRPx=AX-=McKQ+jdd^ zMGe+Qdh!0SCDmxwzYs@=yk<}E*$m{9Exd8|um>+kwm9B!5j+A%amBsBvFKB1#tj%A zyc-;(V9%jYO2UUNdSEKBwx(4IgP%GNMi2S}*d=&A?hl6@q(jpRt51;P8!C*SbYEI* z4?FQmLlXk$mPUOIveA0hX-XUrpOCMw3UQj~Vuy#?`cH-pOgXfKBd3F|C@gp(#rctQ zQhrVS#Fi<=AvAdUMD~@nJ4G)2rg@qmD)C8F-f5r(t3s=a0am)%)HW~ifegoq4~3s1@KGY=JkT=FvLN; z#WJihz;88ZHhOM`jS9zpa`LS-|7WfPxgI#KSagQ2f4OAreu0Bd-7CoUHOfO5Wyo?L zc9EC!U-I6-TYxYia~{Hgb1>g__HJE3;W5t2ncJE?xf&mLhAplwB3%pOS`5NH5Yyu; zfGqF_PINFmIMl3=zl2gXYsCYGZ9eZk1bp$FubxGcxDH{T6LX<`*knvs3YQ4z zlUxkfG7%+^K)WIcTyLt87m|lVFDwjvlR#hjY1BqyPFb595WM*gxXtCCwSdE+2XpF2 zz?lKip!KB}df`_PVp@J}(+09?92`7vbe|&qX(|$}&~p)@A0BRRou1Ts+Z}P@iWbSa zpCTI6^j&f3K`u}{BrZL~Y`{NaJ3UCd#LgS3@=5E<-_D!aT=s@^c5sQ9UTV2(`F|6Q zDSN}sk<<3V)g#(Vy%hj-WQVtrd2=Gn|>~B);$*?alZfv0D7q| zh8t3#>}b65xQb}^)bnaJBz+aT{Gw7VP@5g@y*FJac_^@Xz4 zdqX)iNfr-J-IOAHKrvV&vYCKf8+E1-+YB4qn++rgDBD!`8VJ4sw<@hzyC(=E`xw~- z(*B0F&5>nh+$gZaU4cNnyVHw5Gh5gd@J}%`5e(^mHg;GG*eL%w z*0d{U#VI6XtrOH}w;P=f83XV^?U^uhdn^dSSH`=vx<$d9D#DyJW1vw;&`N6)|?Q16X-UQi+s@T&WaroKRW z7I7FbK!Ez4E{B}g11!$)aq^p`-#Leli>;h9aaX#jAR3`X;kvA zGs)3|o0Hsnc(%vZ4CdlER#EL)GP_D@>fyKFa_gCuQiGjrLChqK3sM@d)B~ZMAec#e LRq=_bHt+opEp`o+ literal 0 HcmV?d00001 diff --git a/internal/test/Tools/DO-TEST-MENU b/internal/test/Tools/DO-TEST-MENU new file mode 100644 index 00000000..3427113a --- /dev/null +++ b/internal/test/Tools/DO-TEST-MENU @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED " 1-Mar-88 15:02:43" {ERINYES}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}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 \ No newline at end of file diff --git a/internal/test/Tools/DO-TEST-MENU.dfasl b/internal/test/Tools/DO-TEST-MENU.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..64794fb495384101a1abab8c7dd3db9b144f39ce GIT binary patch literal 1947 zcmbtVTTkOg6po!VAp}r@(p@gCI@M}biDE1vidFe~v`+w+}Nq|66`_L##W{&5aIp6udbNoCsvMVY`w2#`2 zrqw}q*KK!Q^w91g$L@Bj7J3MFbSxR$C->_1k(F;&I-RHaMzi6x^H}{zGx8EtC%pgW<2RdeC}%(yWWsM@hAu2n;%YdN*b(|MFZrAnt-N164twRx0X$}MJd z%h~ni_4ihnmRAgJ=Wy<7RNQWd`DT}qR(0(Mkau=5y9n-!xs}xm_r=wP@v|TN zZ}~fR2tEfFKMA@@r8s7e(@iqObN)+jq9`j^EaL*flA?)x$p6Yq&KabjN`*qLze+5lzP` zp8$ubW)cV)g=Jil%a}RyQ~qg$S|AUJ6z(h7_rgFDm|}WC+%9Z_Aug)~mlfI2Ip2#O ztKDYvBm`JPZ(qV>@EFz}Ti)&?^}ST~TK*1w5`<~mToTfbK~j2I)5Eh2!w{dMRx+Ys zj8jAs)XAWA8ylvazXfq91bS*v5W|1rrH2m*qJj&msr%1;k1CKU<{yVj*f0QYFa=L0 zueckSn0hdkpjUmv``#qV2p}Y3Z4G5sn1+^KdUua;SyuP3adJx!e_SgW6mpB?XuTNfS-zD^j2`N=>}v??vsZ6mkdXdO87V6Ytvb{2ZvXw~e;sM4xIt0TJwb(n#)zl3Xl z+~8h8IrbQWQJTlkTdX#JMt|Ane%`ec8ir!vi@ zBRy?`Z9hv#&zCH08eQGK0o&gX4_lv~!M8pG9~xvo*;BQN^k`2@Dy5kQy9|h#fo#G9 zV!~I6p}kSkwK6m<@x9nULa$L+0q_)|Q)w9%V|~J8)xc#ke`%1gf(cH8VfMHyHZh^Xr=1*WfguGv7EFcEpj%jxit0XCva!cQD6CgLk=LhN@+OTq*%Z zx{E+N54w#eELx~$3$Eq3!jaYL3XbJ=+n|wI(8%rj2BZ5`eT)77v?T*$z{@O5!l8yq zvG>4cSu=Hk$b={u#vY7WIsggYB?f^RR|K>cfNLZA)^n{V4EI6f5i|=_z;Qd>s@t$z4$Eq6_=R!9YhdVFIwMC0Q`87? tFb~7Q>tKtEn!Z<-H@667+Dq+P9s3EqemiZuQ=vD3PGf(BzS})J`y05kC$|6q literal 0 HcmV?d00001 diff --git a/internal/test/Tools/DO-TEST-MENU.dfasl.~1~ b/internal/test/Tools/DO-TEST-MENU.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..813fdabbf2b99b4174a6b34b32ce90228a2011d2 GIT binary patch literal 1664 zcmbVN-EZ4e6u)-Td^Bs9Y(caW5*HXkn&xP2LCRV*)w6G!OC8(T*R++8AT(Z+lEzVN zZ$s0>;E4xIV=Jp{#Qu+MeB_0fz3=}i=O*bF+QYQSvV6|XIX>t2`<>%QXlhf@u;T6Y zJ6(5xy)fv90lwu8u-LH@zo9miX5wS95fQQA3aSg$Lq0kg%wd8r6x!^FnydC_u)vVG>=; zK|scE7^Iwn$Gl1{G71(;@qU_npbnMEH#HJRDS#VXSyNWla-FZjQGF4HnUBiiIPTq z$vhM-jH>2UM1>8itHy=|05EX|O3f&mVUrEs!wir|S>;QIG6;GrOiDIkl4>XpXq3sE zQ9$S63BN)z4{$_P*6#SY>jpj!eZ1Xun>`%%anSDccKoa0@O&367vJghTHYPp?6qJ% zu-AJH3=Lx2z-%&ifPRLuqgCMlNf31tcx+sdmtH0^)7r^n5 z-h@94zeVW%fAnu=hdSrJoE{ppWApoR=J*+smGK$ty<=;4xA)^AT^mtw;-ESM1%N7+dmQ@n>?fQ&Ssa*1nc%nH?QVzEz794gTWBPDQ5 ze+`F@MaI;g15aU%FfK?wIO!HRN-$2cqcNVePBgWqe+AyWqFJEehRGIqP&&nr*_KH@ z%7dNJh`z?^!b-d^^6PPwwH-wPxRbe`CXSj+HF$F}_uwt`l6)YhlMjXDGM7Y!ozUIw z_yGoid>3}Q@X*68PYPT=koMeODEV#>_D4dvaAqDrdXC9uaIw7##6D}+;r_f%fftyA z6<9T==Abm%q-&Ppm=dFmX+-2b&+-k!$R@KHERjYET-otj+W=l*B;Gx1vidFe~v`+w+}Nq|66`_L##W{&5aIp6udbNoCsvMVY`w2#`2 zrqw}q*KK!Q^w91g$L@Bj7J3MFbSxR$C->_1k(F;&I-RHaMzi6x^H}{zGx8EtC%pgW<2RdeC}%(yWWsM@hAu2n;%YdN*b(|MFZrAnt-N164twRx0X$}MJd z%h~ni_4ihnmRAgJ=Wy<7RNQWd`DT}qR(0(Mkau=5y9n-!xs}xm_r=wP@v|TN zZ}~fR2tEfFKMA@@r8s7e(@iqObN)+jq9`j^EaL*flA?)x$p6Yq&KabjN`*qLze+5lzP` zp8$ubW)cV)g=Jil%a}RyQ~qg$S|AUJ6z(h7_rgFDm|}WC+%9Z_Aug)~mlfI2Ip2#O ztKDYvBm`JPZ(qV>@EFz}Ti)&?^}ST~TK*1w5`<~mToTfbK~j2I)5Eh2!w{dMRx+Ys zj8jAs)XAWA8ylvazXfq91bS*v5W|1rrH2m*qJj&msr%1;k1CKU<{yVj*f0QYFa=L0 zueckSn0hdkpjUmv``#qV2p}Y3Z4G5sn1+^KdUua;SyuP3adJx!e_SgW6mpB?XuTNfS-zD^j2`N=>}v??vsZ6mkdXdO87V6Ytvb{2ZvXw~e;sM4xIt0TJwb(n#)zl3Xl z+~8h8IrbQWQJTlkTdX#JMt|Ane%`ec8ir!vi@ zBRy?`Z9hv#&zCH08eQGK0o&gX4_lv~!M8pG9~xvo*;BQN^k`2@Dy5kQy9|h#fo#G9 zV!~I6p}kSkwK6m<@x9nULa$L+0q_)|Q)w9%V|~J8)xc#ke`%1gf(cH8VfMHyHZh^Xr=1*WfguGv7EFcEpj%jxit0XCva!cQD6CgLk=LhN@+OTq*%Z zx{E+N54w#eELx~$3$Eq3!jaYL3XbJ=+n|wI(8%rj2BZ5`eT)77v?T*$z{@O5!l8yq zvG>4cSu=Hk$b={u#vY7WIsggYB?f^RR|K>cfNLZA)^n{V4EI6f5i|=_z;Qd>s@t$z4$Eq6_=R!9YhdVFIwMC0Q`87? tFb~7Q>tKtEn!Z<-H@667+Dq+P9s3EqemiZuQ=vD3PGf(BzS})J`y05kC$|6q literal 0 HcmV?d00001 diff --git a/internal/test/Tools/DO-TEST.LCOM b/internal/test/Tools/DO-TEST.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..6bbca04ce48d27c8a6ddea2864fe120d8acfa950 GIT binary patch literal 22958 zcmd^HS#ujllAh=O5ff!>SOyVljShQkL$ew;fd+{YfQGsoIyUqIku3=;65!yl%r(v5 zzTcNw)fWI#vNaL2v3d}J?mF_$tjsJlyJ4?C3jJPx5c>U5FEW1~2c4(EQD_=3I|F}` zgmJ_CISzwv8XOMvDIOdKNoXG2Kk%CUL7S617?Orv(|GW$|Bubw|M9+g_@MpZ`}Tte z4byC#EY2@xXW6M)%uU01m~{1PH+lNo-!`k|le5Li^z6ymY4+r7wz@c3EVC!G`8r$9 z`E>SXIbB{p=|+AUCh5J$53deP_25INmkHcg#Nb?CIrQ;w?!+7Lo$+J-~3|j|6r!oE?j-xm=&1aJ+ z4NcQhOk~`6_y(a6VM>gB<^K9daWokl$UOy~E1U4;IP9br8zZs6aPj>c(!*#EB(Cc;kFnY0q36~z)>BiUSBES78Y7Hh4hKhNgx+@uxE^Lk<4!cwp9 z8I!)Bt;}imb~eveX8k@B`XuuD;=?<$zP!lpnvb*fdpl^kG9VX$H`Dp4`z$&ot7WUq zWWQYS-RTULdVO|jVCWZad!1#`S5;hQs|yUA{hXa$-fMV@6*i&IN?(m(Y+w?(Ba9)9 zP#Mq33jPMGD+ZQY#Hs{G_RI7Wz#xgScp-MQ!-}aVwopF{$aOdxLPhZGoOpknot>HG zW)4DU2J}CNv$Ly%SHob`O-uvgX`hMFZ_-`16loP#7{ulV$=B3pH^_mO3c}M20sp4Zk~s6zt@M~ z7arWRU{@IAhKN*?O+?2*XLU|ttP$C+QkicAZP5?Bo{Z{@@hYSJH1e%Jn4=KtNAF`u zXe#5lKA8gLk0!&zFy6gS&LXeTiN>!4BN$qUBF(QQ-Z+lvgETDSk_S${!2_=eutEK* zj~w*}r8k0I&0+2u;k?R@cWQUrVx#IS*W6Fz*K9dk{r0yM#^lKWk;i8GE_)Je){7^! zFFrJIbGBYF3UZ(efK^}Yd~M@b2t@MR-{^umQ5-($3Z||2zh{ZW!|Nal_jl z0FU1}4ii}?xnZHoJ{4jY5KE+B8k_lt`QqbTV!Ion1qja<2^Ks70Q9Rz3pcn)eO2R@ zKCIH-`qNS%REZXZZ~rfY1;Jb??yLayk|N;4()#q83?l9vM%`Dm>X0|q`3pmJ8l!|4qx@Tt+%L{(>)mJV4>%TRZi;dBEAIr~HcZ)A@4;Sm% z`RsqPcPsQ+Sc96o$-;F)G88g(%af08lLt0RtC64TgMm;l4H zYg}od+oRd(#&W{iT9jrG;8j-MxhR3|A$EyPGkj*x3D$7+M+or)#CXqPJ)2(rwJHTn z{b7`Z+>eGmNKH!)9X`Ud@g!}T25lO`8yxb?b#nc+oY4p`r&!_uvfeNp9vZI=>n;%? zNnp_=h!6{Vkl4Koe1SdO`inUt8d^>Bx^W%6ZXmjmXvuw@FV+;1dj!QZ&cV%(Fcgp{{eldMzF`zlMii35CX^cVF>XHB}8rq z2(n{yayH$pV0geBnx;34(@S}MzW6!glXJ7!ti@bJ5|KdHVD+GxuZD-w05J;Hoxzw& zM6QX>45&4<8$%PIg|$}#2e@aN2zrhnh*-?&eQqeYLognP*czYm$2{KD*2C&BDmg%0 zx3nO^!GvyQh-t=QI*CWd6QftvR}~9&nLFYs9jtnxlsSwhqb>-e`tG&VBJ?X~$(9An z8HHx}JQ(<@ht`5%VWGm_odqw^`li=E8iB9w4B14O+AGt^k)KL}f2MgjhⓈ1wbIN zXvLGVQMIALPOJLGj4BzdR<)pL$wyhiZGJkUz(r`_W{Qkj8~k|&PlQPn=fJ?$>~j=e z!>JcM`}s;v#=Fe;H4eXG5Ro+eJo~Mu9+ir!0dx}V_u^<+aIv7NvK`;8q~g;Rz?Agh zArZV{aua_=K}f5s|6cHsb8({dc@S_2DwH)DUzM~rpb;U%BISU^zFL`&i{%H}qfEjY zQDJUO%Blw4z757B4rV;OwG(_#c5ya6$;=d|WZE=45*sti;J^@@rsjj;TMd5N2(=3eZh2)PIyV9OK+7t0?u^t*-zxXch;k7T zdp8e+-68be?QWiM>8iH~z3%j{lX=R!S3T-Fj}IY)-4q$kIVeu#U}wg-MB<;U8~bv` zdM_l_d{%vjFdXox!_mkE`QUoWv1#+v=FZcQeoKQ(#Jb8;`&}}EL@r5#IEAN?tRKFs z6zy?A%GPe!83YIknh8?WeGqfMzv@QnZpZM^h_}m|!7_FGF>>5d{K{CEMWO)#(o9Xb zn_wWRa5(u&7Ii!#;1-dtU;+`Yx-;f^Sc5_ACBb!U^7X9V^q7y)Osw0*g%ZrM$g|oA zI-4YoK`omG1K7uWh#;N`7lb4Bf#e9Q8ypzgpMYfrLkxgIHw3O)1FMb2%YC+^v)G)S z&c9i^bga3aGA@=Sv8n{L5Q`ekn#3n(FAge-GZZ#Lgd|@Yzp?`M+k3=*_a3u&rUJtu za;{OjIk4OkUgPm&P1xe3I+Yw(G&11&*l^XmrW*{0{q!rZxysi6G_IJ?ZkI9&Bw-5% z5Wvso{sjO)DhMY54yM6=jdTg%$%!i@7leQj;LG_Xcv#5rsx!bb&E(%}2o|*3mzH;` zq`Q@~7l(HulU*UD7sh*Zrck@UifJ1Cc>#3o56y`ECbxeyni;}FoRTF%^c z*=3Lf=2Q%nWQXrkwN4Q0<7N1Gk{kmyamp&Mu>Ay~{K(UjN4{e1b#*(uwBFDD0eIqJ zEtph;+5$50z^?Q=m_w!?$L!~qnV?AZxm*Czm=2>a?%HqB)?YHq2 zaF!Ra^1Ln1PC&MavQK=m^0vew8~t=L5^I3>Rp5AzsH@v<&A?QQ)fmdI0ZFrBQdwe$ zl+oDmUtQ4Tq|{V{=B$~7M1Z$H>XJ&>w;Lfqd5Lfa<_>O#sezYR3=btEhR+UdK&X}w zX*5dO9up|}4K9&SEc1gv;e|!g5h$PIm}j|D;~t{j2_lnyley(i#dR2z0r75N+!k2- z7RK`uF@aZ3BWx+@9BJ+$2Y)J$w8;&pWI@31whln_$_ zQlIQ3&DT5nsXUUqlB3rQwv@K3EMc0w41IYZ(B}G;M~uuz-99TESV*J~#a0A{?jfn= zqEsA$i#k_RPb{|g#!6+i4uutMM8oz1>YmgXN;67uTn}8x0WUl z1R*I2T)Ua8+HP?YHi?FT^vUkzM zheg5CG7sD#Xy@vQF2-&UgR_UOSei|SVm)iz^sEPF+y*dCF-s)1Gq$I=k{V#;YP+ZA zsIF{-g$0FLBWM*fw-Q05QoNbZxfv6GNC7Sv=Um_+&ve>xMtv8*)S|BNjFX^GY#8)M zIEexy)o_CZGCuW@l6Ld>{T~sY2q^hsyE~=|-h@t!+WR?Sn!c6Zi%Wh+&WdLeThVHI zVnogF&a$iBg9zKz=|X!91v@+#6>4RZEqPax9PPyA?b%bpu42A$A6r~3 zF7`lBBEc44ny4E1QO~xH2=gZ+&>dO?g>?Ex#n&@tRX|CADmE1lwUyALc@Z8tlU{Sy zC3D5_7nOj*g5rpr_Y9KFazqni-O-Wjg;)jN=IGdib`n_3EEHN)9fOL2*7Z)yvTkSBGOe>_A z30|n#981sM@*DIW1_Yf^2Y1bCfhX7%>oXa=#9lTF%xO!UxYx#JDD>Rz+%LmJp!p(* zsg}?#+bamK5eyHz0Rn{M(6_JmYM!j@r%9h}uxKLShhVO~aRIX~6JlkfK;4SfaU^ zS|s3j|Mo&SkW#P~(HK$koa6z`YSz~I0pTGfrH-nTQCCVcmt0$BohLWChZYw=+%RDYi4MhUeC@0twW)?#8>B5RB zbywgOT{sGZbQ;1d6bHBrjvf@+8o_bO;dG^`u!sqwrv^dT$Ab4a=4S5!4D+d$~a#OmeLVFr|#j zV9JJ6Q?Vj<(FdHJY}lMb!;emddFH>lL<0>C4EmyAR>wwEU%p>_R0okC8oIqvZ*b(!5?fUiAf+QnE|QdV z)`UVq6TNz2iEZQ2t?1?Y>t?!KY~GZ;NN^zCGuti%o7v#9#8E^xgdjUxA$}8JfY+7B z)>~07Dg72u$zT`EX`{e>A_13EDgy6xCibEABre=@)lu7w1MkAkTv=9Iv`H`fy!fcC z(4x@$Y@(NY!F`@tIVR{y^dsS!K72`PNkk)n3#;;D=u6<->&E~TpFEq+;kX?wVsP^i zBMKJVXn0W40xjNQ?=NS~l9YjrR4|2JDnpz-<;D zh+1JIZ7I@*3`YxPjFU4(k;vYhv~q`YTLrD+FA0l!|IckRM5R8TYN*0%b_jVD?TvIz zi#S}L!dz;fAIP?wexTefWF!CCq$r7CD_XfXcZW6xujpKp@Kwf?6QWzOE6fQ!rn_25 zCx~)tn!X|(DKWHn9Fa(w3}5owY5c&q{QGx);9)ii?0c#X5p zS%yn0)!q@b9Bwy_*@6rXbhd^&)IUtn;p=iQd^8ozlg79ZiF6sjR9dY`X)uga(428$AMLb`|KSI)Y8RlSXf!X>S%$|di$a&y$BkpAuE97^8N|ZxW^qz+53_#)3 zx}KfjSgD{@I;^GE1laTD>Y}~cyRE-k&M2SXUQHpcvxt)ELT(pfxhAIVu^0>o;l_(& z+_5IJi0b)o@2{@guup8ShU`EbAQm_ESKG9;9$S$WlfV>5M1X8jC74iSIoB2g{Ae_I zC0XqohvEL747_bQ+)yeF(Jft;$J^~#8vR`Y=o+J)Z?TQupU~MY=bvqRAbipzvjgZ4 zb#}`(doUuu90JzjSMiY8w8$n@s&^pT4s)iY+!eXfPT`-NE|`UPSN6yVhEllbMtHscJDp496f|_Ue%?p;ZukmO!+rb!ZAuDT|_w%ToWy6JE%p!0VKI zhxxtwz@uVS2N8n;VD3{_$gSHW>YVM!+)5BasqySI0Ni%()eBLU`nH6N;7CwPcFQ*> zL3#YnA!RO>J%cWwxp%v5 z04sM?VFnR)&EC$oZJ#xKXr&M>mrJq+{SLgNreFA3Ev!=({mWva+{=~9Nq$RL>nJ#( zAx1PvktY0|53R;qn+eQ|$jWO3D-@t?Mn&$INMI+2E6L8gX1S?h^eQ)+i`0)iTA3!R zchlvRX^=OUCi~}Ril|SfpHDAQ;gdjdL)(u?TH2}Pe(_&y)z9D-9I`?JvuwY*Jb$w| zldCQc2YtR?N{qTN7x-Y;TWwBG;7_BwV~!=5@^#E65z^*>hqYxP7PO zhR^}cYNxz>h6Q#<2wp?O0yH%i|D@_lM<|l4F>~!2HWQ9Wgp)^A;y@hBoj|2g9D3fVz=FmU-k-Z10fa^(7WPT_>BA1;V;)KDXxMn z>jC@rT(1e7S130(U+Lip)pM{{uq`a0?0#7vOf?1@Ww<}*>g#uGv+wHeE<`X4r zvW=B&AT>HE$q^LMIVsGM)p=VFe&vFV{tX(GhG|3f**k-ZVfcax>Qalp)p)l3OXmfL zd9IaSXoZSnnCdTW5IPd!N>VbP%Q01vGWk4o;5+N049kfL4(gNghNtLDXDF~NnP^*g zWJQ{7Dm@foDK`ij=;DyALF=(}tDvW6iMvzRf%+D0<;e{VHdDXH=jfk+iQR35NOc*b zrblXpc8+x#79tB!gkt;*Kh=ejz1`oS!(PsE0!pWgqm3@eh?jRxOUv6rl`aVw>))#! z=`1cTwf2t#_v|E-n_$um21RCKkyv>-&Mv!%MR+$M?jIe?{Udj8nxUng$b$1&zmP9A zOiB1+@8$_iC3Bt9f0_pD8lm%&r7)SF`BY4|tsKeMt#z-zJq5FP_S5l@M^-W1eDU-B zQO7hGFjyMx0FQB%UO$nw6b{+FPEL0_0mcA}+YV(3E7Y8T_jr{Qk|C?OS)_{4Sb`<_ zB^5$5)?}=_tuxZgAAku`>QJ$wJH{)vXykYmt{iN%TQEH15dhn$_)bR2WX#|9;!iih z20)aHD5;080qn!ZaQ728r60VZkCp33?j1U}RPpg5;PG64VJ+;*U%th~s3`8rSGx6= z68*^6;uAu#u{^SaJptiWQku)3(JLmn?J09<0CUb?8RIXO0Sp);>C7oX;2ua|BtPF% z9ds|b7mfAD;f|v??xP*j?JzkSymFrp`{^)HK#_$?@Z)UUFX%q+cS83GovYlX0}%SG zAV)`W0BOJ@v;vF=Vma`I81o@bg}g0ym@p*GCcC*+3+Y>|J#D|~eajq*)% zJeH$9LQHH7!?(RLl$-NyLlo(o8%#&1hm8i*kUaZq9h%#3?OOd{xx}O;<9pbcd*|qsah_o{X z-3Gdal+b@E_ zQ#69-DkHS92Xt*}7D7QP%CcAfY_R}k+@5lOos@<8Sna8-xJ3xj9{8wSFc{*qtvGL= ztjxDNZjnvwyS5lxmFvHoFXW)DH=pG9=vJy~PHaTI$ZS1HQT(x)KSV+?Ldk?~x4Jn- zRG)Z^;1D`>{X=Fuw%!*6!Yd2~i7^ZxAOT#yzU8)>crIb=4y|;&8X}`otqIyIX?rKC4sKsZ-eR}#d|>#sx0RW=(Dfwj$Rs|p=DoI z2lJfw)C_`P$~(6rzIkh+MPKclvpRGFFl@Ae^)v{8!BaPIE8pw#8ZKGoRMW0xifl%{ zHnst%s7E~@z;Y(ntc&5F%66{tJ)c{oXUGWrqeMxLKn{>fT!)Rwa-%cl9X=$dR@p8A z)@6#Qq!15@4}m^KjdcdzvSmwyz%DVE{i>k}U~Ex7b)>i#d5=d{mr+__Euu1u#C`pk zepZen`uFh_7TW0<5!t#-2tBX+A-g8OU?WWb8a-!Xf0!KMWBsi=Tuc}P5roe&^xrzo zV=as+|NdT6emNtJ6iEj96nOj4IfSahfwMxZd^!6QewrG^LZ}z2^4r)FnSxRJBIu{p zER%?rH1VRTf>BZa`OV literal 0 HcmV?d00001 diff --git a/internal/test/Tools/DO-TEST.dfasl b/internal/test/Tools/DO-TEST.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..6c7f65a0d88091623a0741b7e01bbdc54269a503 GIT binary patch literal 26197 zcmeHwd3apamFIh}w9Ar9mf}U0P1#7YExR0V5D5YfNiX<85Avhigbr<3&1^L-uW zcg}gQs3sdq3?Zuf&fU+wXSwH`dpV{R>}m45ng$OJ^(SJ(uEDX$a9evfAh!j`fVj`drbm*hpW`p-rx>+gyR3;oi7w>$TTz#b^DNE%iIL zUAyDjt3R}T`_-FET09ZIbZ=LUj16$jZCAO>-qFGR81S|&+qR(YRrTAqrYrBbYIDhZ zPoyS{D+e|Fb8GrfF{R4NbOsmFhf_23)X8LNi_hIpV` z!p&}9Fw_yPOC_CKU893T?nLa4Sb}hL&_ENZN0J3C9l@rk&kUwc=!cC}Xwcd0ZSe)Y zZfY0RTTCZf%rQgWpiztpd1glxP39q4*z5~?xw5f5b%G%IAx~4gXO}mXq_uH(M7&`t zhtV}hJ&k_A9e@Lr)98tKi}X}7@9yAOB5{v~IcsY&)8%RMoToXtOlF))mTj9gj}gjI z4jR7h#PIVmxKP*(IacDM*jmsgGZ4wccOgxx8K{a7>hi5zV`=I{0sV^tou06dMjA;S zPcEwS1iRhdaM%n->QcwDCv`koQAaz)-Q@Rrf*m1uiy00?>eLEUE46aWKnT4FtXN2WduC|Zs>#qgVsYS{63t_^94d? zIGQ?P;3Ic;hZ*&zPL$F_tcmiP@)!x?@%wqVM;KxwgFi~_3cJE)M~FeiSWj9<8kdyu z?g?S_E&MR3h*5(5(-D*+_IJS36gC-D$e@Tfx?8PKt5lU*t*%h6Y}B5}!HA2{h`pD9 z__96Tu(`*LWek`>x8D~DSv9CNn*1Y42R2(OnIn0;%T6o?*usgbQMGEFTCX;!I<--4 zQtqtIPtd+8vI?X8@P;F5yIPkzQHVM@L=0#{wWwXG@9epwf8bV^wE;$4g9D?3%*sYKyIj$D|A?zEc1!<2Y{WGhkGTl{5zZbuaI0(d z&`@lX>(2hsxK(I)#D#^VLav^HK0D2uid&0~#9XnvhA6MEe>m1VnmFX@rw*;|rIs*d zH&=5F$3})wupfNv&}N$EN#I8~Rf9R4xrQ-?ML9@wyR$!$a1D0?KwBEDIs(p! zZ6v@PFd?iEO>J?V%uV(cxX_7Q(Dvehr`_vr^+a0T!dAghBUt7N;;b|ns{C*kZwEW@ z?(XpTrO~2YezVczr(V=e;Cl*iYdh3v+Q=wm6Qinsw105G11HjIoj7or%HTp2W^XACwJf z8NFENo!HN@;Q@m7?;q}g0%FZz^L5)u>glU9B7K?#AWQc>$6B57Uc;$5bX5r&2VSsV zu55{<>$c!C%82_nnjOLBP#!HjCeh^g_yYPORjKQ;8}cJy*FKM5RbFPdD^tmpcDKAX zGi6#7_(i|2+e}*s(rVQuitIst&Fp;WKuxXQ2sabinQo_Qb~$R_ z&dx%>6$?NB^pIt95x~0ErDpGMO^cU`BQD)P>Uk7<=hejLNF;j<9SI<_TRQ)BpeVinKNbfAJJYf(o zIMrb6(NDJ;H%!IP#?Sd2$NCS)Cw%%@pKQpr+_z!1u${(++#L!>pZwz&x(CBj1>C>za)*9Azi zFNjlv2Pd;mZyt5@SrT6&-dOXlJVMYX7^;neLJD5H!2>~&7Z_b!<>o%-nkec9d$ zq>Qe$m1TOdDRj3Exm>m7u7@ zaV{9_5~`H(KVW}7(N)X+2YJyB$L9{_nXJK-%rls(%NopH=cx#fBlE`;-a%uWm+FIn z^KfV$oREnC%u~b60v6ihdzS-!RY2M^=91^MPXdj5SMy3LbG5Z@hvO&B)$z*7Ys|Sh zk8{f=#5D>mvr)o*nyX843Afbx@(G}~YQ^-uW)-bfmDNKPuPcTC)MG%;y?6HEbhu6PzJqVECQQ{<8j%mGf~U)ILU*zb^>oCYhM$;HR#k`Ro7$&n|(xe zIL`!|{ob&<(FaIySESA;VV3u%QEdGdfdVr_aM&?w6Fj6FIpaSOCKGm9N&}NB@JO`RPBFufIW4#bGb6W=q%% zP}T$wOiyw{G%)=EPBJp?;DPD4GlT}FCpbw1(>pl%3reW-oFy zS)Z>{@|RrbWlH{-rq>8_YCC;>Bi*Jpm2OD;n@sWVI=FPQJ@!j9*Jf)J#SZFn+>NQ3QcdLHX7p{mgceArFgjC@(TI;HSBps+b}^g0dB6L8q?!05JgB!a*ku@V7_QTEfvf`INCH)?2N-!$Z zlxV;@jKsh@kDYfIH0aq{4T@=>oWI7nHA-DqD-Rz+^W4zydU>n{U<=cTmd@6QL>)o@ z*?JN8@jr5w^6&S`)Ot~XzOSqGmr#JX^y}H$kGeiJ!Mfx-vD<$8xdZVmZEdyj|7I;O|hVh;`d&80`>f3ZN1;5Tf%| z$|L9`L2ZDWtXc$plDqp^i)y$U`IbM&40q>)f=i(_cd$8)`8=0=ixge$%QOw_J`Xu9 z2=FWbId+?ma7m&M?US7R<(T}ifYjG7MNf+??#9M$mX`WDJ~w_3HlU`#u|(g%x>4Jv z?HcbHuL;giQ`+OI0cY$F@%r&9^V06&Z`pNno@{89HE-qhmwo5dR0C{iy0u>LM&%G* zb2nmyxlMkYrkK|CO;tRB^UG%7kT6TfjskLxQ9YeJOqP4hu{D(}xtr{N_r!a855S>V zmP+ z;2uKLFaWvMQdzQptldz8SI@b4H^i#&UHSQMygpzil=U_G2z5kS>En4R@GS3S zCeDWhavw^S&O9_z`NIG&j&uhaO~2drjNQRQ5A9dgH>qkC;d;m?uvj` z0bx>73}4G~Rb7r$ev8FM+_9CKv40gxv#rLm{;#f3w1qA4j2*e zdZgLziBzSQKUOx+pat}ODcQVYV zi-g?``%Z-3mMxs#vI!`&(=(JZo0@FW$dt`cMJAQq>cvPhs}H6bi;gn%!;M_L&H2kq z&q8@)_4!2O*(<#U^D9oi^8-0()J4UKP5aj8{0ho06ZG z%>T>~mY^zA?x^|hJC*Y|BLkaJiFPIZ-?_KbY*J;_G=e_pR#gzU6D9|V1Z(5*!;HZGoUgFyYJ4`ybWcwm&O?x+&e_ke=|AcngHutq@EM0U;?}N2Q z!Pi*@jB8Xi!*KQQF86F|NVhz$Qg8gcw++54BxP zH+f78kt5vV7b;Nfk3RCxz}5RKLY*wa)4Hm&cwi}X2=Q^zp-nV7ixqM-1&$20sR^dV zmj^WMiWhjJuGYU?7;XKx3T^tn9{#bR6%n>xAB%h<60by#Aq5O^GElWRpg97~nF-Ak zXx?-`iWJDXjL##juW0=jj(1FMK!Q8U{Aqn9?<9ZS%YVhFUS=3HR9^ZDt+m29z{ytk zbn7bxur`Zr>?|zA4<}brR1KY8-RTpt1&Gu+9O?>3j#}*ynmMa#9gZ2tdWP$@IPyXT z<+wdM4qFHP2-3x{MN_O7;TE5HR4U-*qEV%De1+sio!eYLsv zl`>vB_0ye3@1kj+9FL#Vj$0Y~Xg3M4^_85zu%Ji^tjqbh1(Nf$^-++im9Amftr(}{ zXX0=K`<`x_T<6no;`Ke-{%E^@#q<&X89(oy2|t6Ue8%a?*DI^%96+BE^ zs9>7MJo%ICA)LOgp>)~@-kArY`#>E@RTo1!TW7wcY6$X|-0VA) zJPIu^V?hz?^!XmnKYt@>h!l4!zTESCT++^Olw2{+oyVR+#41^Cuz{#Bukg20$|cop6liiTS| zg6&t40b{wP{mm1KiIEmFw+TV4V2~QDB-H;uY6}+Bu>V$zBwm~0X+lkz?>G|=dA=zm zM|71r!@}HcouvvsaNbQ>w%#V;0{;lhJ`6N!Lu!Kg%>`!ZFylTNOE`X;I*@Qk=dlBC z^xbyh`HFA zlDlydAzPw>>vQccXJwg@E5&-3OpCmrzj;=NT$EV=35ufWtj1^Z`W$Ch1&_8t*iRh1 zKNmc=sICPu@}O$?6?5=iSZBo-*BRn1d6Pv$aa}rCy$&3O%&h@`xH;PBw^+!VU?H^d zKXMc*mxDK2=4{j#W_lKxMa6hvX0sJka zGzmL$yA2azL6>dV8vY_dPow}*rjrPJVezS`@ zy$|HVG5%zEP%C!hGr!9dCU&c~v!mc`P~~_{+L()&;XaG}!A+=%?^-H`C zH+U5xHrf%#pgnM|-Dm?e53+#wLLYCVv%Gr{$529^0V}NNxPNk~S^5&XKp4YOv$Wlc zVqkUgc>CnC)>jM)#CQz9;6A)9566$kCuDAUH7GN(gW^K|<}2j@?> zLt^)1?>kf__PNWD_4qL~XIkfF4yXHcYiY6?YP=09WvnIJ!-S<9|hCE%Gx+SSx-wjv6=c zl(Kk>zrv{Osskg*?b?L=&0Xuc#D!DKB(^Dz2I%0(6QA76^up0xL5ik|!c`eG0;pa% zPjN(RabsXd9LZE6O`kAJ!H+7^{HP*m@gwnqLXtjck7DAsVCi)KWG8ov=HlcGEv25% zqi3^}yDsKJ$eGbuI)CC__1qttvkQrQ?(f}AwX+!Ac@?@DuL zwu<6pP=TnR4^X?>n~tTb%CSsUVqfNJj*L53t~KxxnKvnTM7|v|i1*J22TEr2J<>FQ=V2`ZC8w&{T^~2;bKp7jo*#PPZj1V z@hfz0(YG;_ygqsjCpjo)Svslxh?6fX)@L=NPN;Yt!T8H&_-Jd5We{rA=f3LCLHqY-i<^KC2YX;s)dF= zni&rc7CR)+wTG|5;EXd$H=yiD6zeo&MZ(mN*SK69+DgrEAd=1)z-6_o?08umw)${0 zRpM*W&ioCcDJ!-``_23^{bTckoBtf5XzgyM?c4ZotDAos#7dGD`pjiX=r7HPL@UsS z?$q?>)nOFvVhV;E)9DSjeg$uLY8z0!sUa zrvQ?=9BP=MpB6jbai8wQdEVBbiL4Ct!pp(}A0OHWapBausApfs;yXZe7mQR=>*At{ zst$vxNq=oIZ3Fwfw~fww&cUJ4{)7D=i_M8&f8)~e>q~^QbNsrMe!@C-%#2^Z`FL$y+<`q!phMAJucb{2a^9RIKp<=4p=4)1Kf=iqF$hoP3FrCph_4N*-3#cSr-4 zu_O*%OJdiFe7(&d#kZ4V+2z}92L0Wnkd>x^45EFb?#j2tV*P+?&n*`&(znAsa`D+v`w8~F!tu(WQ3GL`eCW=pt) zi>>H*V?Uzf*+4<352h>zlk73^CW_>STs>7Kl$^QBb!{AK3uscpbNHnVqg&+4m(yo4zoms zfrnNjpMSJ}mY+A}=Nt0#1SB(Ef2WI~v|Ur`<^lAWk6V%iV$ENBP>zmAcaj+QG`E?) zU@h;D0~C*423HuEVG{>_c_=J<4fVPVSvf(U-%lS)@UhsMEPNbMSSrXQt(PcLN_2|; zTvn4cBR0ok3;?O^D53ou8YrR$1W2HFxi0+B$CKqV>S8+SdheiKo&c!MkEG7)bLt>y zE?wt4R7U_*=T)im(wsWk<9m_nWX5({>U>dt{z`rxAzl^s@*P~ddP|KTReR~@UbX+@ zYTw5Q4RU+e4sW-w>(;65V@lkm#$A0XbTj%}+yt-EE^jk0JvPQ}UXw%Ds{K3EzBOup zmD-o5OkIU?TFAq690TM_ytvnmJ`K7G&HT+cq@ZrpitU&5iymAKJjkzC499MT-FAfT z^paS{(Hrj`I8gj}Qs2WqDz#Rjbq4^eW-J1&mF!WT3NDk=8Mqo%?Qj`moUM<>pRtE= z_QisEsqC`299;;-zaWk<5eAZkpbVQcJgVHO$_wjNbc>2^z@pI00Vv+=ZtQlckg&c7 zm#R>)!qr%;nbjIaOXv!Qg2#dUm6_|#ZZQGJhH1Xk7qpY@X=T9YfO2x!Csrp4={o1% zhZWZXSu^yt+ipkWQ{Yhx^Wy4P@^bb&HmG&0)J;n)MyxHJk8g={)3~2TAe=%6E*!EF zpQ71P!~|R*e7yoLLtL=%W@f#3pyy!Beak>*ruyOrLw7uiKe`itoM;!=$)WpCJgi3n z;AqK=m4x9Z`ELoVBP=%brujxIOrCRQ%aKr~yvPe&l5|klWx_03iDw&lgnPOl<|u2% z4pvKy12w!4@~>9=x2kGh4;jNRt0GZw`D>9SeRD*}3J1keU@f2{husxw+MWcBtL{4SW zb%_|%cJUxwrZ3;Z8oHK!!dK=9sAahe&nWM;vCe znJYfYbX;z^{;<`E>)Y%9KEzBmy@eBV2N5&({n>?6an=&gOT}oMsQ4w!o~f9>p2bC# zSrp9h|B_9&Bnb;*cg1?$^b*O0wib~}t*3o3xcc-P_F<-?oQn;R-1I-?Gr9396xE9( zp*ZVqw817PeVAQL#%<6TZxRHoV~N1*QXHRhUSKHq%<|Q~2aE#?y_w=#i*c@{aal}l z4JKggzw8q*61Y=z5>GXG_jsH5^&q^gC9e{Dr|VWr;;$Dm7RH>Uv)cyjsPgi>x3IG4Fl@Xj- z>eMVC9kzI#`Wzh5W5f`!LmU1U1UGwmchmQ1Y~7eo=n@N`4;UqIXjM%ySFF?;2Byeo6JI#Ldt=mRkpu znK;Es13E2r|^urfydZDKn-TE1y@liRPv{y1~ zI>+Rb;jWp_Hr7fr)WxX)fSmAiNHW*6qLZz|#%~v_(dgtH&RqC{OI2+zXs5;0-fdLX zA5jC>(1#vf&#<$60@BV){N-<$k8AHbI>D!{Bd&H{3gQ`#k+I(1818!X;faYkxgW4D zsJiMh|BTnTQEi;h$M8D$Y;vuJwT%03rTwArnT3&ybD{;GXQ&rLRGJGJl_p2T&VhPW zE@zmccD27n?c2h|AKR#gT%?FcycA9{w#V;5?Us5xtyIaR)q^ z!U6Q#7o-x3{ZPWgW)1s&P<6YYYKg9HCsZNKQ394|mw=y+q$bFBrTw0K=P$$#NU)en z80l!Sgn<~b&)YF#_a{D#s2Dpuj2QSPQ)rv;ByXW9(?hGT8_W{O{C#*su3 zm+bHFFS8yHn#JQd+apF|PV*n8W)9?`D6+hZM3KQCEso_imSfpvEP@(Y(gI_rNI~)+ z)7{U!E8##4M~ot*OY7*V1-dX>S4a8u)?%gQzK(bUz9!R;M=q=)2tuRR8OrSZXt<+^ zg419cH1a|3w%^+m4tu)m@EjD*+g4eMIKPekCdF}dFPlJBdET_@9=znQkeCux!}05o&p3~SN1aqh1hh(oah zCdlR({nr$*lqWGvyuWi zfSO{t3BW#>dJH@N#y}?>_OIgd?wm5f3dQz?t;90W@ga&v1pfWr%t~?lj%y5rcJdwD zD)>>wqtY)w7(WvR$9f@{jgKmbh&M9C*nMiLUCM{cz`Aaik(r}#I+0y#f}FLVh~v?s zfL)zwecET7X?tpNy$x*BMTE8)Pw+?pmvU{!naS7fQa-B`z8SYP#0=sQKkhr`J2H8- zeggw3DDYVOk;ygsjp^pnHF>Jj2sfF0lMbohh@YVqYqM^Gyo48c=B~=MHV&rx_u0|~?`{xE-9vG;4QnqwD)VP(0dEt12 z;k1&cb~L1~KRne2OUnD-et5&G+I`G-zuiiJ8-`6j>ng=YyD=UF69!Y(**4s)sGYhO zujG9c2ZGa+-)%4qxk*8~ygjlL4e4}0W3`*xsXA3D>dgg2_%WnG=oMz5Q&qkU-*_x5 zO?=>nQ&%?_{M=vs#rCKDlN;Lgy`?;=<7VmoW~nb>w3WW-e>4!RJ$El23q$vgb|UOa=f#MoP*?_D}=Rv3Gi@2wQQ+gvUO9PR)QYB7Gy zEZeAA1-5>`lu{Rto0UhUh#Y6=@I#NQoeY|#wJ+Xhmc}b@KIb>iP9B|V2XFDunz^P% z7Zcwg*E;J;^gIvQph{_D{~VN^Lt(GY)q!Lp{SIF&xO)uJLn3j{9yM z7#ybPV7bW84_uGf1zyKX*3_8e24yM=X)lR*@rW4Tfc8Y`>Gm>DbEgl$^xFmW0CqQ* zlvi-MES03Ua%n!~)I>y3m&f0ZH^^*Xku|eNz(j~|6sMAFi1*o#U1Pxf$l-`QpdIU@ z5$2>$xX_cM1@AOLGSKyGerowvd==tNDS3IBvdEdjZ#_ek^pO0g3OP7*&@Uoke2D(X zGpcwU8lTkv9&v)z-&3^>*7JO)DjN(2JpqO(Ozl`d0>I^eni|6<&7x%v^ValY)uO`~zz^zQho{l8 zf{=*l<4*KZAlF_XcI6LGVg9rX!Z*gFk7`TbIua(j?Y}SS3xIj84Nkp4ax!AN-Wf;Krd-o{M@xR zJ;1eCFWc6@s+jRTVTo`m&@vjYWw{W*I&$doI*vg!qWEte@JchIHr{|Mfi*X=3v$lq z*y~ixII-Rz$5X*%WDqgTGFS8*$Fl}{vt-ZQ$7i!0EP630+VD2ZEd@C#1*2UaUldrO zyWf}ZXra)7G*V=Q3&98}cWiO8F!3y-j4)w6x6Vqq<10L>WlW?j%CiE+$lY_P|J(-x z#KA)m55x>m%o$S}j_L?%;lNbK^<*?m=61#g#$s5p{I5fJI}kNG4$NdMl3@PYXOQjq I`}f}azchsUa{vGU literal 0 HcmV?d00001 diff --git a/internal/test/Tools/DO-TEST.dfasl.~1~ b/internal/test/Tools/DO-TEST.dfasl.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..dfa9d21ee2281ec5446c98082ad7a6960c371db4 GIT binary patch literal 24775 zcmdsfYjj-ImFB&-N^h%NvV^c@*)EJM+rs4-^R^SCl2o!vDpkoB_SSbF)C&Qt5M`JV=+!Bf;g0V;-yd@lJhy`Lhw=_lliC{dje)Fw2 z7sqod?iuds9_`udYablg+x_S|-_3XVntJy19C!eI-F(-bcOqrOrVSf6-E!yp;^sg+ zth>9qTDNby^_KO;AAdDHX)PHv3}e6iN(`f{%w)XCFuaCkrcb6k&7p9xF%}FYf=%IQ zqh+Lzq`Yh&A~`k&ezpT{`8x**7{k|XS^9WBQVKc( zjctLg!E~w+p!avigE5xF=$aCNhA`4yNJo;pArKFin(0*jo3|&JKTbG}a!k zQ%lf>$Igkicc8aAq?G8C_Gptt?WzrdL}QCT7L0d>6KMZrs$3TnaCZa}L_Q{abCM&0 zb~JI^g=DjX-y^B~PRjrn*70Q|b_8S59e%7(do<$b-m`14Eza<0$_4C6r`$SE(B}9;B-;~Lt5mJ3 zRIAk*wN}-so7B3T&X0RJEC;hOYqc6fSlHef*(z`l*u=4H$5Nh-Sg<3TC~4QnIwKq! z7qTgvhYIMYPOU?=C0(IJ3wDBEFDKX7h8GI0RkbKm*4P<~1tST)k+_7&TBBAWE3-zJ zTmoI{mF22in>VLZ<;@^bdol^JE86DZgg$5L(9f?qT=$>FKt~O#Zj~Ahin|O{k zR8TdiQ%_=JoQfYD8X6q7Xou>~+F|NYYx*NRO}Qks;>o?H%sf zGur>Cua_O#-RoMKp!%hnZ@6b<2nBmVm>ylvX%dGu2}l6}_{~PoakbdscSm>`(6w2dp;;q_8LlIJeLA_V@dS4-NpBJw7bf zfx+P(J@i7NG-z)eqz-7L6WyRMSRqbrVV$0v#w!qj<9XP?3)=&2L4Qji-s0DE5)?9y zWv(Ep`z4fHfBh@qOC#f7ZOz+B`~>#I@kbL>R76TNa2rkwl@T0*ib`E-;qugHAXvj z%BaCpf;u4E%1yQaJ^|PllEAULsw`m22`imibn{()aBcsccM7+@Wz)vnPNvpfi%dY) zWiGav@+?>wc=Ky56D{849?NUEOjU&)4JcrBe7UT}G#w6REg(T}h;~MrI*1L07;7(i*-~%LW04~Ea&FMv0>Lt6dxNGu+Fc+z1xt%SO&X!)J zGbY)+EuRm)xg7hF-2!^c(RHf!@t)z{ktaTx0Nvga?jG2GuzP>cmcYT$!7U`^e$cyv z{i7pXRvXUCuVz>)(y6LBK$s&iTy9h=Fe>oi)CH1mV|#cD@ncKfdVaupmd!`}oFY4r zziNIy1eV5@U|gDsXWOZsUoN+soSCnL;0#dil z7k<=Tm+kWfP&kj~y$(&q>4E$ENWJx1i+QTWI-Q(Jo(Z`oddHKKA#)~VojDYm*^Z5N z{`K~W_QMi-zRSabw^0H|PPlry8Xx?aicedzN_J}%{`2Y_{kOFWIXZZeqD(>!6ah`l zSIb-lAatHO5wrdJNKq%-;dH)bSR&bz?xhyg)QFrZTmgjCi3TIvL$PRt+`+t!2$Knnqo^UYEWLq=PJ6M8CC& z6zkm&uGJ8Y2Uj4aL=K1noO`wh^9kO=4)^=r<@v%!~y2K+J&*C}sbAP2zz58EdaoTNRQM0ABzJkyl6h*tIJavN zLROcrs?02npyX;~;j`$;f~98i)UL|eXeFZOk4L>z<ge-bHSDt;%Q2pu-@AEFPVWom_FjGE-lePQ0D9HGsBC4~bvl9lA=Hjx zGRVQ^B+1}0_OK0*Bqp2ORRwSyeG0RE1OVDqJsYi-C3!AdElV(-JQ=M{R!wcVApLpt z6s@)Zj;V5c((Ei+U7QD)quI(yz^!V@?BQq?!Cz&!TZJ_um^~K8F?E=A>;cINSz|dc zS~wR*%dZwjcW8KUgjWe8fNDIMBv$1>4I@3l@#&S6Joy9N%tD}fbzNgL(iGxWfN&pa z3I}8Uh7eLBTjO=s0@*?5tWx`11nIV{uF=*HBsyaee@CNeAoAlo$*mQx`5ko7JD~8&;hki6Qif4tv@pOJqbR;;McOL_hM`n z+37YyzoSpYQsh0B<`Kpn4#X3Pn13(nXBoUxg6|_}{9`87&^^9?zob0VLh^I39?!;A zZ0+0Vuo3_!tp-3vm>Lm25*ochhgf~mS73T+7JXY3?j$)jTHJB zgTIjA+YG+V=`}!E*v8l^nKq4YW!f}OWP@Ll;Q!o%T1CO_fv}$(^wW~~PYEQtaHzUN zq93f$MJv#*^V6-ML}ume@ih5ex%DB*B!ALn-R0-7bO+Un33^x%D+igOq8G_q7A-~&yGO_BFuU{ zD?Nl34l&?Oe}yAHmRhbAu22#=+gtEG90Do?!f_eYd)e{Hf}P7sqiDb)VL;yyVQG z?wQ^))7>`F_EbHnJtPuH%7>C(^Nk4Elt;AG;9f~GB`*btZ|6avH|2oQ^H0b((#P=FvK^iJOprDz@Xq6>T@3q)?=C?#q33tiRZ zIuXj~?bhqBemr1UB{EHioBYnwp!p|Duf^|O#X8@mfj6VJ6kFDlALBn;*2V!5+Ivwy za|6}31$Tm$II=L+_zPfEh$TR3skJO6hRjNvBwNN0P^qLT2vVRe2Tc1fq}kNV@Tkg! z@1Rhr2#|>w+F{bmNGcZX7dmfY9#g-;R42htl?_vmNO$jlO5MF4`L^{T8rxZb9qEB+ z+9|psq1#gOJ<5~Dw>S-;SAYt4CVT}6Zl}$sq~xC-k~}=(8~gwQVC}f z7@M^gTR9EYN8{kZ{=EaMM;&FYZ>)Q4RpZ6?i1C8D8|TioTsW*L7W1_hhKW^N$NCno zZwq3AQeH#d4F!>DuMR9FZbC87hcV?fhH(~IDucY~IvM#{jx`H0!jXoJLYi$@&&)&2 zHr=>t(y8Ld_dsR&M6!EN-}=or7pGHuH*eO;VCaLpeV8=#@;>U`eXPFD*A!@P4<&9W zUNh1&`jF2t?rhpL-%0`cwYGRo?|^>@O+)eFTgkFK{;ynHj9JX>7(l6q_G~4A@LKW| zv}W8|r$UI9nHE2@KVSHzMLp1Dn>@r<4+-OkMG^m=*I&!Q2 z`1MCbTeHKbYL-dDwkkAZg_^yprWm1uX00<70osfgu#E9h5&!;(Oo)Pm@ruoaYJ|IS zPuL@iF!!rE6>Y_W?bH-A@u_rbbw__sH*6Vu2f4k6du&U?Sb)sATc6Cyu^*Fu?$MmH zW=n>Hn%nNkhGQF?UMQC|Ujs9ogR&Ue<(T13Lh;Rzscy2FAsHSi0YH^k3yWg{8YU#g z6P?Y?vNOu;W4O}|>=k-jynE$sLCgaR;x`|~bFkk*YF)&}=L^u9n2Zt^O&2Vmi}05! zdO;}^bT)?`DRfVQM}5{cZxO*I5uC9_It6#$(s+LsI3*G+QRiiyW^bLZYBXlX^Aha% ztg3lbLa||;$L*qO?$Hqu9L;ElE{lz^g(2fl8&r)Si|DaU0HO=?cigCId{T1TGH#1# ztV&{W?hXkh=5CAvww2u&-*Aw!1Y5qXGa`G5MUDtgAJq6;b6*Y~Z_kFi16RLEu88n7 zkI1eRa};TGX9NSe9JbeKZ0|Ew-8^iUsqdeU>fT&b=jp)4^b^2zFrL$`M-NRss?ijG zTd6?8Pbb)jDTzqQ;;B=NNXma%qJGI@IY=6+I@M}fr>8!L!Xf-?K^u?(93*`T%s*!W1 z8C|Z+ma7`AXLv@VSUhhihXSIN(kw2)_z4<(i;YK`{z@w(yOYM{l$130k9a= zPUFKv%WV{46%HA|S(x$h!uMCov8IW9Z{8s=`K!fO{sR9`g8FS7>pk$6_ zcCHV|q;Xd+M`*E##>CaoL~^|Mbn8Ux)7q>+poOZ&LxSeq5;n#C=CvbpIl*oG(Iq+s zbHs)hW&H(?E{%t7dgzp9&f#(BWN<=NClBK~ANS%q{zrDK0NU5TmUr@xBlINxQCnMPSsW8rwZdqru=*Hk@z1urQwUY3wqwpfJ$WRxl>QAo zYWXwAH#;F-=W?kPF1K3l(nvp}YF(~5XHZEuSK)jHaZDVfcy_Z-rE!Eypa`Yc4MB)# zK1;O+3rh=E^Zok+0D5Bp6VT3AB&8CJ|FHjQyai$cx*;10;P@h4Ql zW2&%S5aje-@;Rm1>TCHD`-zKfd@DUE-`4=A>B{YdMyGkI)7n!y8{%PZ>Y$|U)9AnH zi7*mj#yd524n22*g)Ql1x#L)uabiK?tc+>ueW$-u57v8TLm+2)*dW){(J_qYyEy#6 z+5@2o4&_ju!am1I&bSIxHHvxbIwM^n72r*~WT*{Vx#r8GrfJuUj2-KdjS>Q9CKm@81K zgjxgO0}G32^PP0cvj*yFf3#T+obk2MbgFtY4z{s_0|WGdqM{Efzv00HzOlgAMjX{s z*D;?qv=Q5%hdHY@rBlnZ8QsG@z6W~Pfa8=kw(2GrrCB2WD11pr#Zk(KqcbbR{o+Qa zGQFEDi%FLPJuIdWT#Ffz1y(F z!jWW^FzZGfRtEeBhqMAvjN-^L-y(rCwGjA8Gy-z7WWHfOW8jxfbP{m&+8U20csa_- z(sicj-i}19r8ClY+Y7*m#kMeY5f3+vvj{|^1GFDQG;nC=NZvKBnQ5A)s?l7L<~IDe zTXZOi4MI~U{UNlJaKS(@TSt0a1f!;)O^)KQL6hfqp%sRXK&{cHN8^`5c%c(K(bMnx zaI&x8#ZG(r-rf7)`5#pDTivJn-hJ@=_xfF$8mD%{)lMiONi=mBr(0iq)i~6O(DZ7I zHA^$AwnH1}%Enm)ZF{*%g>EB`3SFM6GAoand!SMjGS0vG(l}COOOtw+&Su-1Lyz6w zu0f#Zx?lkc8Gx1l@KPN1YEY`<39f8njf%Krdi9Q!g6Z3{+3Z>Vh%LK(gW@NJ&v{)z&RPDNc$NNurrXZ=ytd&H}|1Zq2tI( zgV91Nu)r{4jqoQ72RpW)cqyn@gVs@s-NfAB9s?OGi$wjCh(E$BS)YB&F zV~S%lZO7WCt^)(1rCi|)x&d4pPaaE7)q(}R0H%f1T0yKM2qml7NB%7SxMyGe_~At} zM7q-1wi$AZHXxB^2mZ=- ziNkLhe&twc!0}UZ?ls=$;nvNCb4R72KQ+te&)TZ=XWiO|@J^@sMVijFRTP5ely?y6 z1@WOQp9Mn|>cdgZfKc>zA9!GIH+47jc^L@Pyup?vT7rIip<%^^YPlWy5{%hdd`|6U zt!_VSgT^d@tIFcB+O8yT6yRRKUQ+R~_$HzBhN;QTuQ{A49DP8^3$cJL@01E9lNtRI z+Fq@lm_xQrH;^+g&;Va=paSdGyPm6;I{?*Q>~C!1HcL;in}wKS$D z%g~znJ&xeTSIrakGi^tq-!Vj{QwZqg9Z#bCM$95h>cbUQRaYHo zLtfW9WR`SslIN$(>28ulMV`2@)u$5N32!7pDI%aKrUk1~#A-*qqIo4z0#!j+#JdEB zs|q##vaKM9ssi!4Iaeb<% z>w@urq^tygEfn7|s*6xtZxAp1m!(#UM4JMh= z`3oe}tJWlj2M<1wOREEGwYB|Fw&)Y-)Y=P7^xY8l2Zwz6A{7`4MRdnf-%sCrlF<^1 z8}_9vM0v?1k=RMF5v7nKSCZm1SrIg`j=;8U2)G$=67E(sdYZx!_0ZeWsav&&V7EB( z;~+80`x}nyfPG}JT^BZut@8O~cx*-+Rs;g@8obSMG{lK!FYdu<$3(Pq@dnY9Jw@Z! z7w5r)7f+^fZ&i$Y88V0k!=8}1VgUGk<3OV;d9h^vJ4NooJra?!{+8*QYu(K|Ra+Iyh)v7UKOxIfYgv`aYQc2UnLUbs)|;PYCH z&${8h-hQlo%7;?n>Ng_CB2(8%P-H=n>%$WJcW~7$1Q~L~e&CVSTxexT5S%^>YHGS# zqP*CbS5pI@T=_O8c9>dpJL^Rq<15-IqGnSHwAE=Vxi50^VD*t89CulVKaxIY>R?`%e*CzB{in=_IR%iSc6{mdty zw?&Hojxc*I0NCy}#*1125C$}>G=Nk6&~Ohfie9Bt@5T$=ZbV;R zgC*9#pIV}+TTK;V%d&|UE`CdueJJLo95Mm9CFXb+iEK$hX593t@_ca}u$qO{Sj`^F zxS1-l+2q=zP32<+wzIEwKb(E#NG`gsxAb7Rxyd;Bjp-yX>^*Kth-VY>9epF^0Wj;M zhm*M6$;fVz%O(W55!O}kx1X|4|Hk5c-N80acUxwV>$AH!q8IB1?s7N?nX>nyNy$E6YS56uhJoant4K9>{y(Bva1M zwEn!LKWY8>qAKqP|KjacUjFJ;_l40@0d7GtDm2D;<~G64XKx~-3pBMxLlMzPTKjqN zwG6fqP?|>ZeF@Oh^al2J23hV%C`^w<;}jwb?MXr>p1@&S9ASQ}qRjq2*8lodIWrNJ zAjW_swUH&hhXzX7fKFu6w{_hYQMY_fT}&lY@9U_SuM=431zqRl1$E#zl&N!!b#wyj z9MN^2y`WC+_?~8+?AV@E(Z^JDSVi}cOvHk6ua4L0?pODJT6OPGyE-{#eG|{|&ULQd z)v1j!6%7&Q)@ZYeHlXc=jj%Xu4K~U0V(~?^unw+K-K*5D>s5D!+T~UeQ$^i3)B11> zgOLk)xTDEt4*G2WIP0K-O0rg~8_8|EaVzM6Tp}Ot*$-9W2=C{SMdA1e^MnhZ8pfVs&WwHG@i-_g@;-TaD10hn*Q8T+T<{o zICtoL5@%74pp!C9(nKf~MXH#kFgL8MKyKW%TKd|*Sk||oMs?qyc9mh0OL8Wu&q;7l z?+8N|?@`(l$2v-2EX*m#6A2dEs>aPr6$jJl&^4t9ZgXzLJvDgf@^t{`qDbaKQw9sl zGt;aOh|S$LF4Xj$+t)es*Qs5(ctBrciFKwL`fRHpf3TED#VWN?vU`Dgt zcwfbIY5$|rHNV!DlorAxZWH&AjU>ohP@8j~N#6t8vB;s(il+ac1HmjC&hnY+0NBhOyGfYC~AEZoE; zGCsOR)of4){EV15Z!m4fR{T{;?7S%8jgMT7SWPZ4i=5R3aix6Z;GR7_aOvKQE7TX{ zUT0tY^3`Sk8(VcFs*TCP4JN(rbv`^tA{5iy%2hWvX~5tw$@xVh1c^iG=L_N-m!-GZ z2U+g!7LBd7f0Zh~UWD(`n^pIEwM!f^t>>1i!3qkM@gTk2^!legYEWbBKWD_5L2E6g z?ZJz1{Ts*@zy&ClkINv){g0)VX1V{xQRGr`fD4L`+?{b1clRj=47wHEcnO3TuSyR1 z0KGW8@M5wz+CyV5cx(<{vmAgcrS|OQP7FcCpJR9qKPdf!^NUvM!#wSqC5e3s4iNgV;*qtUy$9zK zEAYw=lz7e1e`!ubqZ>77`8UGq5{p}<2z%;yp_tdm>gt%!=e4SAn_oQG9%_t+ah2OH z0%w{+Y?m@8KN0I}q>~LaNETnWaEyh4SS+x!&dTRG&n`>H)jDy_aZ>mm9-MQCx#mA; zuN+*F9$sk7ceKe^p&`IJzK&80*1u9*gvJ#-+AHPi+e=E6+Am1He~1$VmuV6w0TB=H zlbjFkA|(+`dE|DT@(H0W;-n#3VsiscN5+dvJng=&r1|Hh?9I$L0YZ`wM@#G%Mkf$0 z0B>=8F25ipMVEL8S%po}t_Wc;qKbE`l6F-@Z=DL_vuLw&4#P5mpMu2Rjg{XGzG8pC zZ^}$FYZ-SuQp@4s0%XKbJ5JGq1reYFPx%Yr;lwLAU?+ICk0X6gM)sz~gB#*=eOB&p zZ3Y}lwAZjG#@Az<1^2dZ=W$ca2j)6Ak*G*(Qh+mJ<8|G_cLxFNa4@?h(t+z%%LgvY zu0MoLj4JS6{=u+`>~LJc{(;0jXB&m4IW6Xga4XI(FXDgTD!B;3CkzQ;bEwltT7*fY+y z=o$h2(Xz%_5weZ56-+e$+RfMK_+T!gb7(4)h>`;()-HG9_jV3NIYtd{9fB=!z;_d8FN;>MZt zV(3`F3xl*S)=WR6J%a;~aQOr&w8khXj;;37regtv(p;W+LdoENiJ=%0dP@vJ+z(KW zV>@W~US=8Z;h(n8o8qnX6SM(uB{y~*yvBer_7YywTZye$1(5&I(3jx1Lk7tR__&jr++K8PXVtFOK7?Qt%1|$`d{BDZLmvVJ+{i3R(N99&K!o^`{~m}@!vpf zrt3B3UOkHA^>(NiV>~4{BC4ma<3*qI@H=8t_1tqwZ)kdP$l;hO6B6zUT>7-_J!op?<5?^G5hYd!+XD!;xgweP_7qel?z)k)Ea>ZIjA$ z1qvU1vVAHUHZ8gX;jX&eShwi9Q-SAJFs^6?Wqtf`N1f3{_`~mF5Zk_JB{JX{RQU{( zDn-!e82}BppNvF3wQoEf^(3qAe?4rSnVOtw17Qf~&eBjL#oYGLL}+&^z5zk~h6ku( z{t)}pO$R$hKFiIn*%+hx1oJo+ zgl+2{lfR}(ha6R1tC{koY>E#am#S;z#BKcJ9cn~`YFCU@$vn(V<0A$i5^J_Opt>3B z)z5s~lg(eJkHzmZ#gen|ISC$S3vW_jn9t*2vSHqgTwSe)E8IfInfcPz-hc2$|1S7 ztB4Arlj3*~uhhu3!a#y=;FblNwug|IxvR_PMt4X_{R*L!Wl6qO$obIhgsTEwfp8lh zxp8a(NF4(a;Jz<%+r~xzZ_E2Nc3E>hHZIl>5 zh(3wYt+41_1uN$jlxp&%0;|=t zmt*~n7X-FDDYtu*C{xdAvVx%=w&qTcMtwJ+1qTqAzk~9^OLHI;en|Gt7lbUiz94df z>kA?m%N==EW335b$bvY$oME1YKY2g|<7d%SA+Sc+;a{LciS~r{<4h70C6?>UcS|y^ z3u6B@>`Vl`h!=N8;@K4G>}z~d6&<<0ob&ff5>6eU7K?e}@aH;`q#gt>^)v=zlKjP8 zNbvf2Zym|*#z2#uemfS@EcDWhEd?iaajYg=^I%2)1D}DhHn2Cs3XpwEb`qFGby$nV z4U&<6TrXYrte5YfNiX<85Avhigbr<3&1^L-uW zcg}gQs3sdq3?Zuf&fU+wXSwH`dpV{R>}m45ng$OJ^(SJ(uEDX$a9evfAh!j`fVj`drbm*hpW`p-rx>+gyR3;oi7w>$TTz#b^DNE%iIL zUAyDjt3R}T`_-FET09ZIbZ=LUj16$jZCAO>-qFGR81S|&+qR(YRrTAqrYrBbYIDhZ zPoyS{D+e|Fb8GrfF{R4NbOsmFhf_23)X8LNi_hIpV` z!p&}9Fw_yPOC_CKU893T?nLa4Sb}hL&_ENZN0J3C9l@rk&kUwc=!cC}Xwcd0ZSe)Y zZfY0RTTCZf%rQgWpiztpd1glxP39q4*z5~?xw5f5b%G%IAx~4gXO}mXq_uH(M7&`t zhtV}hJ&k_A9e@Lr)98tKi}X}7@9yAOB5{v~IcsY&)8%RMoToXtOlF))mTj9gj}gjI z4jR7h#PIVmxKP*(IacDM*jmsgGZ4wccOgxx8K{a7>hi5zV`=I{0sV^tou06dMjA;S zPcEwS1iRhdaM%n->QcwDCv`koQAaz)-Q@Rrf*m1uiy00?>eLEUE46aWKnT4FtXN2WduC|Zs>#qgVsYS{63t_^94d? zIGQ?P;3Ic;hZ*&zPL$F_tcmiP@)!x?@%wqVM;KxwgFi~_3cJE)M~FeiSWj9<8kdyu z?g?S_E&MR3h*5(5(-D*+_IJS36gC-D$e@Tfx?8PKt5lU*t*%h6Y}B5}!HA2{h`pD9 z__96Tu(`*LWek`>x8D~DSv9CNn*1Y42R2(OnIn0;%T6o?*usgbQMGEFTCX;!I<--4 zQtqtIPtd+8vI?X8@P;F5yIPkzQHVM@L=0#{wWwXG@9epwf8bV^wE;$4g9D?3%*sYKyIj$D|A?zEc1!<2Y{WGhkGTl{5zZbuaI0(d z&`@lX>(2hsxK(I)#D#^VLav^HK0D2uid&0~#9XnvhA6MEe>m1VnmFX@rw*;|rIs*d zH&=5F$3})wupfNv&}N$EN#I8~Rf9R4xrQ-?ML9@wyR$!$a1D0?KwBEDIs(p! zZ6v@PFd?iEO>J?V%uV(cxX_7Q(Dvehr`_vr^+a0T!dAghBUt7N;;b|ns{C*kZwEW@ z?(XpTrO~2YezVczr(V=e;Cl*iYdh3v+Q=wm6Qinsw105G11HjIoj7or%HTp2W^XACwJf z8NFENo!HN@;Q@m7?;q}g0%FZz^L5)u>glU9B7K?#AWQc>$6B57Uc;$5bX5r&2VSsV zu55{<>$c!C%82_nnjOLBP#!HjCeh^g_yYPORjKQ;8}cJy*FKM5RbFPdD^tmpcDKAX zGi6#7_(i|2+e}*s(rVQuitIst&Fp;WKuxXQ2sabinQo_Qb~$R_ z&dx%>6$?NB^pIt95x~0ErDpGMO^cU`BQD)P>Uk7<=hejLNF;j<9SI<_TRQ)BpeVinKNbfAJJYf(o zIMrb6(NDJ;H%!IP#?Sd2$NCS)Cw%%@pKQpr+_z!1u${(++#L!>pZwz&x(CBj1>C>za)*9Azi zFNjlv2Pd;mZyt5@SrT6&-dOXlJVMYX7^;neLJD5H!2>~&7Z_b!<>o%-nkec9d$ zq>Qe$m1TOdDRj3Exm>m7u7@ zaV{9_5~`H(KVW}7(N)X+2YJyB$L9{_nXJK-%rls(%NopH=cx#fBlE`;-a%uWm+FIn z^KfV$oREnC%u~b60v6ihdzS-!RY2M^=91^MPXdj5SMy3LbG5Z@hvO&B)$z*7Ys|Sh zk8{f=#5D>mvr)o*nyX843Afbx@(G}~YQ^-uW)-bfmDNKPuPcTC)MG%;y?6HEbhu6PzJqVECQQ{<8j%mGf~U)ILU*zb^>oCYhM$;HR#k`Ro7$&n|(xe zIL`!|{ob&<(FaIySESA;VV3u%QEdGdfdVr_aM&?w6Fj6FIpaSOCKGm9N&}NB@JO`RPBFufIW4#bGb6W=q%% zP}T$wOiyw{G%)=EPBJp?;DPD4GlT}FCpbw1(>pl%3reW-oFy zS)Z>{@|RrbWlH{-rq>8_YCC;>Bi*Jpm2OD;n@sWVI=FPQJ@!j9*Jf)J#SZFn+>NQ3QcdLHX7p{mgceArFgjC@(TI;HSBps+b}^g0dB6L8q?!05JgB!a*ku@V7_QTEfvf`INCH)?2N-!$Z zlxV;@jKsh@kDYfIH0aq{4T@=>oWI7nHA-DqD-Rz+^W4zydU>n{U<=cTmd@6QL>)o@ z*?JN8@jr5w^6&S`)Ot~XzOSqGmr#JX^y}H$kGeiJ!Mfx-vD<$8xdZVmZEdyj|7I;O|hVh;`d&80`>f3ZN1;5Tf%| z$|L9`L2ZDWtXc$plDqp^i)y$U`IbM&40q>)f=i(_cd$8)`8=0=ixge$%QOw_J`Xu9 z2=FWbId+?ma7m&M?US7R<(T}ifYjG7MNf+??#9M$mX`WDJ~w_3HlU`#u|(g%x>4Jv z?HcbHuL;giQ`+OI0cY$F@%r&9^V06&Z`pNno@{89HE-qhmwo5dR0C{iy0u>LM&%G* zb2nmyxlMkYrkK|CO;tRB^UG%7kT6TfjskLxQ9YeJOqP4hu{D(}xtr{N_r!a855S>V zmP+ z;2uKLFaWvMQdzQptldz8SI@b4H^i#&UHSQMygpzil=U_G2z5kS>En4R@GS3S zCeDWhavw^S&O9_z`NIG&j&uhaO~2drjNQRQ5A9dgH>qkC;d;m?uvj` z0bx>73}4G~Rb7r$ev8FM+_9CKv40gxv#rLm{;#f3w1qA4j2*e zdZgLziBzSQKUOx+pat}ODcQVYV zi-g?``%Z-3mMxs#vI!`&(=(JZo0@FW$dt`cMJAQq>cvPhs}H6bi;gn%!;M_L&H2kq z&q8@)_4!2O*(<#U^D9oi^8-0()J4UKP5aj8{0ho06ZG z%>T>~mY^zA?x^|hJC*Y|BLkaJiFPIZ-?_KbY*J;_G=e_pR#gzU6D9|V1Z(5*!;HZGoUgFyYJ4`ybWcwm&O?x+&e_ke=|AcngHutq@EM0U;?}N2Q z!Pi*@jB8Xi!*KQQF86F|NVhz$Qg8gcw++54BxP zH+f78kt5vV7b;Nfk3RCxz}5RKLY*wa)4Hm&cwi}X2=Q^zp-nV7ixqM-1&$20sR^dV zmj^WMiWhjJuGYU?7;XKx3T^tn9{#bR6%n>xAB%h<60by#Aq5O^GElWRpg97~nF-Ak zXx?-`iWJDXjL##juW0=jj(1FMK!Q8U{Aqn9?<9ZS%YVhFUS=3HR9^ZDt+m29z{ytk zbn7bxur`Zr>?|zA4<}brR1KY8-RTpt1&Gu+9O?>3j#}*ynmMa#9gZ2tdWP$@IPyXT z<+wdM4qFHP2-3x{MN_O7;TE5HR4U-*qEV%De1+sio!eYLsv zl`>vB_0ye3@1kj+9FL#Vj$0Y~Xg3M4^_85zu%Ji^tjqbh1(Nf$^-++im9Amftr(}{ zXX0=K`<`x_T<6no;`Ke-{%E^@#q<&X89(oy2|t6Ue8%a?*DI^%96+BE^ zs9>7MJo%ICA)LOgp>)~@-kArY`#>E@RTo1!TW7wcY6$X|-0VA) zJPIu^V?hz?^!XmnKYt@>h!l4!zTESCT++^Olw2{+oyVR+#41^Cuz{#Bukg20$|cop6liiTS| zg6&t40b{wP{mm1KiIEmFw+TV4V2~QDB-H;uY6}+Bu>V$zBwm~0X+lkz?>G|=dA=zm zM|71r!@}HcouvvsaNbQ>w%#V;0{;lhJ`6N!Lu!Kg%>`!ZFylTNOE`X;I*@Qk=dlBC z^xbyh`HFA zlDlydAzPw>>vQccXJwg@E5&-3OpCmrzj;=NT$EV=35ufWtj1^Z`W$Ch1&_8t*iRh1 zKNmc=sICPu@}O$?6?5=iSZBo-*BRn1d6Pv$aa}rCy$&3O%&h@`xH;PBw^+!VU?H^d zKXMc*mxDK2=4{j#W_lKxMa6hvX0sJka zGzmL$yA2azL6>dV8vY_dPow}*rjrPJVezS`@ zy$|HVG5%zEP%C!hGr!9dCU&c~v!mc`P~~_{+L()&;XaG}!A+=%?^-H`C zH+U5xHrf%#pgnM|-Dm?e53+#wLLYCVv%Gr{$529^0V}NNxPNk~S^5&XKp4YOv$Wlc zVqkUgc>CnC)>jM)#CQz9;6A)9566$kCuDAUH7GN(gW^K|<}2j@?> zLt^)1?>kf__PNWD_4qL~XIkfF4yXHcYiY6?YP=09WvnIJ!-S<9|hCE%Gx+SSx-wjv6=c zl(Kk>zrv{Osskg*?b?L=&0Xuc#D!DKB(^Dz2I%0(6QA76^up0xL5ik|!c`eG0;pa% zPjN(RabsXd9LZE6O`kAJ!H+7^{HP*m@gwnqLXtjck7DAsVCi)KWG8ov=HlcGEv25% zqi3^}yDsKJ$eGbuI)CC__1qttvkQrQ?(f}AwX+!Ac@?@DuL zwu<6pP=TnR4^X?>n~tTb%CSsUVqfNJj*L53t~KxxnKvnTM7|v|i1*J22TEr2J<>FQ=V2`ZC8w&{T^~2;bKp7jo*#PPZj1V z@hfz0(YG;_ygqsjCpjo)Svslxh?6fX)@L=NPN;Yt!T8H&_-Jd5We{rA=f3LCLHqY-i<^KC2YX;s)dF= zni&rc7CR)+wTG|5;EXd$H=yiD6zeo&MZ(mN*SK69+DgrEAd=1)z-6_o?08umw)${0 zRpM*W&ioCcDJ!-``_23^{bTckoBtf5XzgyM?c4ZotDAos#7dGD`pjiX=r7HPL@UsS z?$q?>)nOFvVhV;E)9DSjeg$uLY8z0!sUa zrvQ?=9BP=MpB6jbai8wQdEVBbiL4Ct!pp(}A0OHWapBausApfs;yXZe7mQR=>*At{ zst$vxNq=oIZ3Fwfw~fww&cUJ4{)7D=i_M8&f8)~e>q~^QbNsrMe!@C-%#2^Z`FL$y+<`q!phMAJucb{2a^9RIKp<=4p=4)1Kf=iqF$hoP3FrCph_4N*-3#cSr-4 zu_O*%OJdiFe7(&d#kZ4V+2z}92L0Wnkd>x^45EFb?#j2tV*P+?&n*`&(znAsa`D+v`w8~F!tu(WQ3GL`eCW=pt) zi>>H*V?Uzf*+4<352h>zlk73^CW_>STs>7Kl$^QBb!{AK3uscpbNHnVqg&+4m(yo4zoms zfrnNjpMSJ}mY+A}=Nt0#1SB(Ef2WI~v|Ur`<^lAWk6V%iV$ENBP>zmAcaj+QG`E?) zU@h;D0~C*423HuEVG{>_c_=J<4fVPVSvf(U-%lS)@UhsMEPNbMSSrXQt(PcLN_2|; zTvn4cBR0ok3;?O^D53ou8YrR$1W2HFxi0+B$CKqV>S8+SdheiKo&c!MkEG7)bLt>y zE?wt4R7U_*=T)im(wsWk<9m_nWX5({>U>dt{z`rxAzl^s@*P~ddP|KTReR~@UbX+@ zYTw5Q4RU+e4sW-w>(;65V@lkm#$A0XbTj%}+yt-EE^jk0JvPQ}UXw%Ds{K3EzBOup zmD-o5OkIU?TFAq690TM_ytvnmJ`K7G&HT+cq@ZrpitU&5iymAKJjkzC499MT-FAfT z^paS{(Hrj`I8gj}Qs2WqDz#Rjbq4^eW-J1&mF!WT3NDk=8Mqo%?Qj`moUM<>pRtE= z_QisEsqC`299;;-zaWk<5eAZkpbVQcJgVHO$_wjNbc>2^z@pI00Vv+=ZtQlckg&c7 zm#R>)!qr%;nbjIaOXv!Qg2#dUm6_|#ZZQGJhH1Xk7qpY@X=T9YfO2x!Csrp4={o1% zhZWZXSu^yt+ipkWQ{Yhx^Wy4P@^bb&HmG&0)J;n)MyxHJk8g={)3~2TAe=%6E*!EF zpQ71P!~|R*e7yoLLtL=%W@f#3pyy!Beak>*ruyOrLw7uiKe`itoM;!=$)WpCJgi3n z;AqK=m4x9Z`ELoVBP=%brujxIOrCRQ%aKr~yvPe&l5|klWx_03iDw&lgnPOl<|u2% z4pvKy12w!4@~>9=x2kGh4;jNRt0GZw`D>9SeRD*}3J1keU@f2{husxw+MWcBtL{4SW zb%_|%cJUxwrZ3;Z8oHK!!dK=9sAahe&nWM;vCe znJYfYbX;z^{;<`E>)Y%9KEzBmy@eBV2N5&({n>?6an=&gOT}oMsQ4w!o~f9>p2bC# zSrp9h|B_9&Bnb;*cg1?$^b*O0wib~}t*3o3xcc-P_F<-?oQn;R-1I-?Gr9396xE9( zp*ZVqw817PeVAQL#%<6TZxRHoV~N1*QXHRhUSKHq%<|Q~2aE#?y_w=#i*c@{aal}l z4JKggzw8q*61Y=z5>GXG_jsH5^&q^gC9e{Dr|VWr;;$Dm7RH>Uv)cyjsPgi>x3IG4Fl@Xj- z>eMVC9kzI#`Wzh5W5f`!LmU1U1UGwmchmQ1Y~7eo=n@N`4;UqIXjM%ySFF?;2Byeo6JI#Ldt=mRkpu znK;Es13E2r|^urfydZDKn-TE1y@liRPv{y1~ zI>+Rb;jWp_Hr7fr)WxX)fSmAiNHW*6qLZz|#%~v_(dgtH&RqC{OI2+zXs5;0-fdLX zA5jC>(1#vf&#<$60@BV){N-<$k8AHbI>D!{Bd&H{3gQ`#k+I(1818!X;faYkxgW4D zsJiMh|BTnTQEi;h$M8D$Y;vuJwT%03rTwArnT3&ybD{;GXQ&rLRGJGJl_p2T&VhPW zE@zmccD27n?c2h|AKR#gT%?FcycA9{w#V;5?Us5xtyIaR)q^ z!U6Q#7o-x3{ZPWgW)1s&P<6YYYKg9HCsZNKQ394|mw=y+q$bFBrTw0K=P$$#NU)en z80l!Sgn<~b&)YF#_a{D#s2Dpuj2QSPQ)rv;ByXW9(?hGT8_W{O{C#*su3 zm+bHFFS8yHn#JQd+apF|PV*n8W)9?`D6+hZM3KQCEso_imSfpvEP@(Y(gI_rNI~)+ z)7{U!E8##4M~ot*OY7*V1-dX>S4a8u)?%gQzK(bUz9!R;M=q=)2tuRR8OrSZXt<+^ zg419cH1a|3w%^+m4tu)m@EjD*+g4eMIKPekCdF}dFPlJBdET_@9=znQkeCux!}05o&p3~SN1aqh1hh(oah zCdlR({nr$*lqWGvyuWi zfSO{t3BW#>dJH@N#y}?>_OIgd?wm5f3dQz?t;90W@ga&v1pfWr%t~?lj%y5rcJdwD zD)>>wqtY)w7(WvR$9f@{jgKmbh&M9C*nMiLUCM{cz`Aaik(r}#I+0y#f}FLVh~v?s zfL)zwecET7X?tpNy$x*BMTE8)Pw+?pmvU{!naS7fQa-B`z8SYP#0=sQKkhr`J2H8- zeggw3DDYVOk;ygsjp^pnHF>Jj2sfF0lMbohh@YVqYqM^Gyo48c=B~=MHV&rx_u0|~?`{xE-9vG;4QnqwD)VP(0dEt12 z;k1&cb~L1~KRne2OUnD-et5&G+I`G-zuiiJ8-`6j>ng=YyD=UF69!Y(**4s)sGYhO zujG9c2ZGa+-)%4qxk*8~ygjlL4e4}0W3`*xsXA3D>dgg2_%WnG=oMz5Q&qkU-*_x5 zO?=>nQ&%?_{M=vs#rCKDlN;Lgy`?;=<7VmoW~nb>w3WW-e>4!RJ$El23q$vgb|UOa=f#MoP*?_D}=Rv3Gi@2wQQ+gvUO9PR)QYB7Gy zEZeAA1-5>`lu{Rto0UhUh#Y6=@I#NQoeY|#wJ+Xhmc}b@KIb>iP9B|V2XFDunz^P% z7Zcwg*E;J;^gIvQph{_D{~VN^Lt(GY)q!Lp{SIF&xO)uJLn3j{9yM z7#ybPV7bW84_uGf1zyKX*3_8e24yM=X)lR*@rW4Tfc8Y`>Gm>DbEgl$^xFmW0CqQ* zlvi-MES03Ua%n!~)I>y3m&f0ZH^^*Xku|eNz(j~|6sMAFi1*o#U1Pxf$l-`QpdIU@ z5$2>$xX_cM1@AOLGSKyGerowvd==tNDS3IBvdEdjZ#_ek^pO0g3OP7*&@Uoke2D(X zGpcwU8lTkv9&v)z-&3^>*7JO)DjN(2JpqO(Ozl`d0>I^eni|6<&7x%v^ValY)uO`~zz^zQho{l8 zf{=*l<4*KZAlF_XcI6LGVg9rX!Z*gFk7`TbIua(j?Y}SS3xIj84Nkp4ax!AN-Wf;Krd-o{M@xR zJ;1eCFWc6@s+jRTVTo`m&@vjYWw{W*I&$doI*vg!qWEte@JchIHr{|Mfi*X=3v$lq z*y~ixII-Rz$5X*%WDqgTGFS8*$Fl}{vt-ZQ$7i!0EP630+VD2ZEd@C#1*2UaUldrO zyWf}ZXra)7G*V=Q3&98}cWiO8F!3y-j4)w6x6Vqq<10L>WlW?j%CiE+$lY_P|J(-x z#KA)m55x>m%o$S}j_L?%;lNbK^<*?m=61#g#$s5p{I5fJI}kNG4$NdMl3@PYXOQjq I`}f}azchsUa{vGU literal 0 HcmV?d00001 diff --git a/internal/test/Tools/FDEVTEST b/internal/test/Tools/FDEVTEST new file mode 100644 index 00000000..6427bf61 --- /dev/null +++ b/internal/test/Tools/FDEVTEST @@ -0,0 +1 @@ +(FILECREATED " 6-Sep-85 10:23:52" {DSK}FDEVTEST.;2 9718 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 \ No newline at end of file diff --git a/internal/test/Tools/FDEVTEST.LCOM b/internal/test/Tools/FDEVTEST.LCOM new file mode 100644 index 00000000..c90d6f6d --- /dev/null +++ b/internal/test/Tools/FDEVTEST.LCOM @@ -0,0 +1 @@ +(FILECREATED "24-Oct-2020 21:02:31" ("compiled on " {DSK}larry>ilisp>ENVOS>MISC>TEST>Tools>FDEVTEST.;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 " 6-Sep-85 10:23:52" {DSK}FDEVTEST.;2 9718 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) (PRETTYCOMPRINT FDEVTESTCOMS) (RPAQQ FDEVTESTCOMS ((RECORDS FDEV) (MACROS .APPLY. FDEVOP) (P (MOVD (QUOTE APPLY*) (QUOTE SPREADAPPLY*))))) (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)) (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)) NIL \ No newline at end of file diff --git a/internal/test/Tools/FILEBANGER b/internal/test/Tools/FILEBANGER new file mode 100644 index 00000000..9e1b5a4e --- /dev/null +++ b/internal/test/Tools/FILEBANGER @@ -0,0 +1 @@ +(FILECREATED "13-Sep-85 14:27:55" {ERINYES}TOOLS>FILEBANGER.;2 12693 changes to: (FNS FILEBANGER) previous date: "14-AUG-83 13:56:54" {ERINYES}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 \ No newline at end of file diff --git a/internal/test/Tools/LOCK-FILE b/internal/test/Tools/LOCK-FILE new file mode 100644 index 00000000..db7f2456 --- /dev/null +++ b/internal/test/Tools/LOCK-FILE @@ -0,0 +1 @@ +((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)) \ No newline at end of file diff --git a/internal/test/Tools/NEXTID b/internal/test/Tools/NEXTID new file mode 100644 index 00000000..368f89ce --- /dev/null +++ b/internal/test/Tools/NEXTID @@ -0,0 +1 @@ +28 \ No newline at end of file diff --git a/internal/test/Tools/RANDOM-GENERATOR b/internal/test/Tools/RANDOM-GENERATOR new file mode 100644 index 00000000..c19af9a6 --- /dev/null +++ b/internal/test/Tools/RANDOM-GENERATOR @@ -0,0 +1 @@ +(FILECREATED "24-Jul-85 17:42:37" {DSK}TESTER>SOURCES>RANDOM-GENERATOR.;2 7172 changes to: (FNS TEST.GENERATE-RANDOM) previous date: "19-Jul-85 11:24:20" {DSK}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 \ No newline at end of file diff --git a/internal/test/Tools/RANDOM-GENERATOR.LCOM b/internal/test/Tools/RANDOM-GENERATOR.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..03f792294525dd32d11f2b8ba977d7064bc5e9a5 GIT binary patch literal 5139 zcmb^#U2hy$HETySDXis$wgd}Bhm|P1NMp^N?^%%9_3o@a&hE@+W}J=rXb84d+q>~v zwo?%yo_Rt-Dm;WX{SB5&UdqS*i9V3GRziXYK!Hl|2TctbI(1; z)sElwT9MaGyf#!cLkYJ}6;0Jt&`4di>V{TxNUQm8*F-Hy(}@#{^=dhjrbq0Qafu$9+l~GY`CI zB@Q>E7H*4PXkZgtgYCWhhi~ql!0EUSs3wSk`o1jO^%TxngQMf!xAw;mPne-~s1R3? zHjuhz)HQV)*w0`Dsg-A`gPU!qTAG`Lb$r&wGt)ndo91?x0;C`qH`T^xr4ptUBwR)Z_SGkNK_7ud(Cc_ z?unrCgEW=Kp?AD!OPP}D9N29}YaV4ar0Qg=&j6;7g&MixNMv2WroJhyukU&^wbc-Cj+@o=h5ZrN-P`DMNVnWMqwifN=fS@-z;{x@FIb0z8yPAp zEDNE+ZakYI?1r#Z3VUxdxPCbQ=V!SvJ;BKBPv=DA z3InVs#?v zKeMFFiOx!qb7L|rNd3}5*08@x!!qK|YZI1@47kU#Po~Ggh^N5k)7f~wI=Kd)JNN;G zv2c7pwSJ=)j9zA_9zPnf3;6B}lt~8p-AQBq*Owb}OtA!>+bL^gpufrt^qID-OMm1p z{hzqEC)XBVYP{W;fBNd+=DmfT;q&({LbEtmI{WLzR@$a8&@fyWau;RnvUdI&2}_Sue|BVR6FsuH5x(2x9p zU5|wmtx|{~8qj9}tEO%9I+lAb5Mzppn#Z`VD8NMo;Zj}e1wvg@)ZaX-v>?PpAv7Fd8bYC| z2}@04a&80dVl)Ouo5?ez6Ncn6&>LnJxRwSNO@7d=L68~51-VoSP@ktH zvU$`U4GM>&qfIj-q#G%-rXny~*>Ur%DM~}#DSW{M4YMbgE=3wk&Cul2NyEI)$tc*N zNjq8ZTMUJ!8o*IABSo<633OgNu}q1YmFtA&I&IC1I`J+Fl#HfL#O;#+0}nCW4BFFM zsA0O(u>cQW(x4Qv#QTj;96lEnXf*>o#ROJ8kdH+hM>Pv;U8TL*>upuQbPT8xOGnq} zS7ToTbj`-PO1~ESI)JH(HI9A__O+1GwrvdyvRD{$fhgU;LTF>HkgE%rQ!9gk*Q2UH zrBVZYu&X$NfV7ztb{YD;2J1$!t$C??>y!7tw$8c~_PMt(37#&53wuj%{H{Cv@Ox(;hYPR& z{_LMU>{sv>&wMR01!fn0QxtoAO{wX%a^QE%RS~#C#b+U-A?TuKuVPDDY7869C}u7D zlxW*zLx4p~K8jf3yey|GArx`G=|^EdF5CiWh5fCF^$OL>-QDBykDxU^J{lk2KiwZ6 NR)Dw;o)Ejv{{fj^{n7vc literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS b/internal/test/Tools/TEST-ARITHMETIC-UTILS new file mode 100644 index 00000000..d046c152 --- /dev/null +++ b/internal/test/Tools/TEST-ARITHMETIC-UTILS @@ -0,0 +1 @@ +(FILECREATED "23-Jul-85 12:55:55" {DSK}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}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 \ No newline at end of file diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..d52d98bacb1929db6263f221a4c248b1558e159f GIT binary patch literal 1378 zcma)6Uu)A)6i+t<9R!s5svPoS`jF6@G))$zG)r&0XqsgACPT%SZY^6STT1^7hxiG6 z_KR%n!}u)(@!gZ8t&Xm+67D^J@A;j7l{=nKT}GXlwn5VBN_a9;w3=1}jo1V~Qvz8! z$w)wknZ_cvwVKePdCRfc-I+~7~G&l-*v*&TQ8B-oN<19<31*tg9 ziw}A<_FN^2J)f(uNflq(Q=IVx!_{g)EW1W*U6bHAkCwg~h%mxvz2P7oUV*L}5IM|+ z&OA+lUrn?544|$A*=6ppgQ}_$4Ei$!Dg7_kbbQpVTT)e&@8+s2Z|A9E89+4KFz}P0 zOw9Lql$-JbJ7rBCCd^&1_oSi&X_y9_ob@kGhf@(|nGN!h!#Lz+SaWd0Ua3*{y>5{7 z6dqC6b9@Eqead(hh28a^k`d&(0iQY_DGMVoiaM&4 zv5-aBMni)|Awb`Qj^p_WqbOg%4#FTWC1p5lh0h(JD~t#bFzy22^=@mclJ4xFMEFr+ zSRx@N(8F~U+A1_?`VvrqLdN#Q@dxa4#JnKhJOyaYBIodMvjxb-EIecs$|9{LkJBWs zW^vQRRqr6#UXdEr`_rbdbv7t}&ztZ!TPsOUnEwG*^}gXQ{XH vazsfS;qYzPVQ|Cf1M|8EG5$NgA5O9_;AWF?HtEks*@XmT&oc0p!1KkwIc!v5 literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..de62470c259f6ebced7483e57dd438767307a304 GIT binary patch literal 1378 zcma)6Uu)A)6mK^K9R!s5svPoS`jF6@G))$zG)r&0t7)3un+z3Sy0vVTY$^RS9O5VN z*)OuO597BG#CK1UwmQ1PO1by^z2|rSMQJmidYrluZGo)U)ZWQV)vJ0HbmEYzQ>)9M z$S3Lfc$5qWkY0cc($|)F_wCJDdOmC<{mJC2F-k_$af1d&J<;eg;WZ*EqDGXa$uuWb zm$T@gOC#o~am0L~y(SfWX-{>>6AV|a0!+v zWI|SH5vOW81RJ<$*jirq!pmCopxE%TWlIVJ0xs{wT^d9J7*v5%5&KaEN>;g4+G;*2 z;qT^!`+ZP;RxULUejb;0x3+J8H$VTndER`qef#({vv``@UH>VVl2S9_Q~M+3y%5a2 zjvD2>$3twRsl%cWVC+HLWq!;l$``PMUXYcNavZkY=MK;nMg#~LcLDHvx4BhLc6Lxw z`cYt5A|V#g!*vw;Dm3WE5>Spp!S+Pa2kdjmSrBcW0<`9#dw96n0+f6f9x@6=k=ByO zX_8j6xM|`lcaUtb0tL4eRD#oP*g6vVm7PYxWP4!PwSuXEpS z*-$r41D%R1JJG4QaIGv$C;5vDY9TVSAh`(Fw;<4KNl8GAnoiI+6RyZ5W&IOcD@%m4 y)Z1A(!Z-?X_%`e?c)jogXPtuxzmD&Rlk^LC>13Qv`m<4bAp_a7O?)L_zVsJ9tyEzE literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..d52d98bacb1929db6263f221a4c248b1558e159f GIT binary patch literal 1378 zcma)6Uu)A)6i+t<9R!s5svPoS`jF6@G))$zG)r&0XqsgACPT%SZY^6STT1^7hxiG6 z_KR%n!}u)(@!gZ8t&Xm+67D^J@A;j7l{=nKT}GXlwn5VBN_a9;w3=1}jo1V~Qvz8! z$w)wknZ_cvwVKePdCRfc-I+~7~G&l-*v*&TQ8B-oN<19<31*tg9 ziw}A<_FN^2J)f(uNflq(Q=IVx!_{g)EW1W*U6bHAkCwg~h%mxvz2P7oUV*L}5IM|+ z&OA+lUrn?544|$A*=6ppgQ}_$4Ei$!Dg7_kbbQpVTT)e&@8+s2Z|A9E89+4KFz}P0 zOw9Lql$-JbJ7rBCCd^&1_oSi&X_y9_ob@kGhf@(|nGN!h!#Lz+SaWd0Ua3*{y>5{7 z6dqC6b9@Eqead(hh28a^k`d&(0iQY_DGMVoiaM&4 zv5-aBMni)|Awb`Qj^p_WqbOg%4#FTWC1p5lh0h(JD~t#bFzy22^=@mclJ4xFMEFr+ zSRx@N(8F~U+A1_?`VvrqLdN#Q@dxa4#JnKhJOyaYBIodMvjxb-EIecs$|9{LkJBWs zW^vQRRqr6#UXdEr`_rbdbv7t}&ztZ!TPsOUnEwG*^}gXQ{XH vazsfS;qYzPVQ|Cf1M|8EG5$NgA5O9_;AWF?HtEks*@XmT&oc0p!1KkwIc!v5 literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TEST-DISPLAY-UTILS b/internal/test/Tools/TEST-DISPLAY-UTILS new file mode 100644 index 00000000..e491daab --- /dev/null +++ b/internal/test/Tools/TEST-DISPLAY-UTILS @@ -0,0 +1 @@ +(FILECREATED "11-Jul-85 11:05:36" {DSK}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 \ No newline at end of file diff --git a/internal/test/Tools/TEST-DISPLAY-UTILS.LCOM b/internal/test/Tools/TEST-DISPLAY-UTILS.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..593c716135c0aec12dfe58dab392453c582b9f10 GIT binary patch literal 943 zcmZ`&zi-n(6t+^Rgup0`PzDC{STu-k!X01VJCt6t;P{a&=)Er+eqXtx}M!FX8K?M>p9 zEyL5wzV7*DKZ?R}Vscf(b4<0#ZTN=iT0mI6NcdJj-#CkfW+C+^Eh6Fd_K=Wr!~O}nLl|!#H1xjVRAHk zK`762^_`GYWZ+SwToRWVn5r_d(s-+v6t27fuOE0(;-TGZ4W4$#Fo{aQZmO;abS(U$ zT8&sUeOcs?e;1HNX~es~RykEE^msLLFxX44h?fw**89kw+Av zrW+4xe#{9oJLY*sKpj*Pc(4AZ-l+-o zwz3%S`bMcUochNLQ~!8j=BH+UYH9JRX`LQDsy9xLnvHtDvvlPe$=GLy4U#4|&kn0* z|HreX)OC_2x6Tf4*GTr{m@<<2bg%b@Wc%MAXZL>wnVNa>(XdWF?e)?mjb!=@$slC* zKLlyYHcXmTM3~+ltjKd~d1Y?N#d8bAC$|jJd4wR%xp^qQ3mlHC`+hTSj%(OHT+&0D zbscqm{gP#1*)`is7XNN@4%^Q<8@}Tb?D@ahK_gDnjhl+U+QaTBdI4HA8b+hmB!~tK L@I^(&6tVnY*hv4D literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TEST-FILING-UTILS b/internal/test/Tools/TEST-FILING-UTILS new file mode 100644 index 00000000..09eb1c53 --- /dev/null +++ b/internal/test/Tools/TEST-FILING-UTILS @@ -0,0 +1 @@ +(FILECREATED "11-Jul-85 11:06:01" {DSK}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 \ No newline at end of file diff --git a/internal/test/Tools/TEST-FILING-UTILS.LCOM b/internal/test/Tools/TEST-FILING-UTILS.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..4380140e73ea8530fb619732669c2a8f488148d0 GIT binary patch literal 1072 zcmaKr!EVz)5QdWg2SAouaRi}}FE|HVUfXHY08uS_-E8aF?ygY?6;hP)tDu<&7`)-ab1iPRHGRIG>+)C;4PC>(b~T7TrD*UN@y8?WRSM zFG^F#DlFR3vy_FxcuJa>WlMKwb1Y?=K-wLXbZkq7m$Fj+WCW8bC~AK^%E#wm8!bp& z?m=*t=OE4(#n}?T(WBy({N4t`FjN=~m)M|s)o!_kHbiug>MW&w+*vC-0=}EN=r%#N8@YW73<$V< zN1$N>r=kh9y*ss9V?DXOJ#ZWK!`^WXpK`e`t?*s%u6)0*Ug3v_Wo)h5erEOEpC>=Q zu*Rp0Z&jeCwH(as`e1K?7si4HU|T@r0Q++wPG}^%LAf_A5SiyuA;8&$z-3{Epkxc; z&HZhib-f%n#sa}#Lfmkl@@kZ=|eu$|Jda9*#X5_wNA0DW0n zL4jl9Aj+vrI8D<-dC!<3g`4L?(RkwS@828+O$#DX#{M%wGV$N=KO#191~u$0;c-&s oTA5Pt;^dIConDIn`d~aSUV~T6XT^NDoD@?PudUs}3=s>JUl7~{j{pDw literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TEST-REMOTE-EVAL b/internal/test/Tools/TEST-REMOTE-EVAL new file mode 100644 index 00000000..5d3963f7 --- /dev/null +++ b/internal/test/Tools/TEST-REMOTE-EVAL @@ -0,0 +1 @@ +(FILECREATED "11-Jul-85 11:39:07" {DSK}TESTER>TEST-REMOTE-EVAL.;4 13178 changes to: (VARS TEST-REMOTE-EVALCOMS) previous date: "11-Jul-85 10:20:19" {DSK}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}TESTER>TESTFILES2>FORM-FILE)) (TEST.MASTER-MACHINE (QUOTE 222#6#)) (TEST.RESULT-FILE-NAME (QUOTE {ERIS}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 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}TESTER>TESTFILES2>FORM-FILE)) (TEST.MASTER-MACHINE (QUOTE 222#6#)) (TEST.RESULT-FILE-NAME (QUOTE {ERIS}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 \ No newline at end of file diff --git a/internal/test/Tools/TEST-REMOTE-EVAL.LCOM b/internal/test/Tools/TEST-REMOTE-EVAL.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..15696f7c637b522f13c747d62d5f2be09e1f2a27 GIT binary patch literal 7859 zcmeHM&u<&Y6{aYqO_Q*Y6Qe+kB6(#BgaWbzclkr48VFvIOK~M~cfGrkB`1f_B4JXd zNP(o>xmRAy*IPuE=5Uh&oN+f zIs0bj%{Sls-kVXXYSxXiYv{gFfuxpG?4z-wWwZ=v>V~FmWJ^g%C65Ltr`=w=1%o~$ zA@P32+x_6}&fuiI*=r7m4>!BL?&x&Wu=Z_lvtfGWP2ceRO@A=xjrdVJpYDu_D6ZPI~LAMWyWTV~cwI4z@od-vE%TPV*^}u^L z8k~&*a*8#0K>f3jPN$R5YL3yrWVl_+;-DM3Vsb5!iY!xAm7TMmQp|&j^OiO;>q!u6 zs+*oerXIU(xC^|`ftpp_URON3Vc3?TRBczO8FdFEGmLIxU! z=Rp-T*fO`Pw&kxu?0$SH7Joj5|89PVJ_r2x0)6uD_vq<$z1z8QgJ0qIwfIu4WnN#I zyxelHuTEO`$mBW%58t00xB5T(x`mcg+ZQG;^JuHFl$yz*AJ!gd1*q#)^eycfR)t*C zw+*Bklx?f5`=DmPaqWiVJFaQ@kOTbM-ZJWS5BG3A4;7=T@6~-83m06eT2LrJx$cTi zkX2!2nO^#bj`0R|ft-f)_3n31VcZ^#lVF+kHBj@A^v>=cw~xjf;A4Axh`ThnH*B6j zzuj()pwsT1CVbr4Mss+7@SrZDJbi9`+C0Tcz0Q?%P@{BJfecobrd!d|1t3N{+S zZe+mPYit>=Vpo-NO?UOOZ@9>d*eeL(Qs099@;`4f&i_9C^6y`+#?Z$E{ZAo1A(zRd zGYcofpsk#r3%St1v0n|1-Q}GP&yZ3zu*esLRnD}I*oUXWNF`o16x~;9w&#o0ILISv z1qVrn%L>-yDW-+Y_i%6URR-i^6|%rEZP)FsU_i8_0hNYcu9=pB+{{IcL|+{=%7-Dxr54q9Txhqa^UnWy|=5;ymb`)8S#h`Sx6Wo{iEC1JwF zq6$e!h=lBP-Nq~;GC{@t6Y}Z$O*Tne=Hs94P5BWi(niULR4I27^a$7h3V5ie3BWzcJ_k`k`w}axF zeO}<%bQ5Tqif6d{h#qxE=zbB8$Cj_b($??$|9bE4%A|9&GP$WwK{{aMo<4q+$-^Ja zr6>R3=T&~ah5Y@Jn0*j3sz5Lb6w|zaP`DU-6r^x> zQY1CI4k^QRZTAO|WSx*>za_~iSYcGsNmMEv-~wYYcU4E-siaYlK*hBLwyxp3hieHG zkQ^l4_IUVE>Yth^LDG28?7^r#e1N*w8H~oz>b9Ui7z3x@_P7n5?udV!jho{xCVkAu z<4zk|?NRq$pEK>ad(wUjn*A2E2ABn@_pm)W9rQpjG+&oQf`tb1rje5A1q{3m;bCP~I^q?_k*4 zd%h4+%1h@|6ZOxF$6_m}e+&-8Cd8^UOPTzNe;%}++<2aI$Bl!frQS7e6e9K+TbbNa zTOv@4v=HBR2vl6Kam#^R5f~zi7|c&-0$MI)iFtWD=!Qt4piy1N%gZ7|ZB{%=RnzA6 z=_82?Rzsr*G%!s;b;fdWX2OI-l@Jjg@%`ya zEEd1E8q+`hHWoT}XZHB-LF2@cRt+Fzk0I6P~L1k zex=oY`p4|*r!R^IWbQ0~5RGr}ejV`VpFdi#Q*VR!H&&H4+C0N&_YeswYFL5{QQM^D5DhmDV}Y$S#p+tj2CJjQsH;k@&!^ z3A!?D46PT@g-CT2iuwYU=%$6opkf#jH4Bz;8-pKX4r87`qC`hEkyzP+X!ir4NJfM# zvw%+HTcB}HUL_*uO36P7Nj>`3L~82{#9Hf<>k)=h(L=oS zBPb#@X5oj~JkU0c(A#s;6vP_rKoUVR>=wuk{(I{5Jjb^B{6CVf%r|G z>48BcvsQSNJ&)>95ec33WJJ`_7W_ITp$6J0FRN%O{wBr+!;+ z#YLuh`uJq>=yPGFv&9`@u`{#Sojm%ru-M^uZ1xU6{%&_>_QT1azaHNHF1H`@=SSwM z$q%24uU*nXO!AU>YM~^l7vy0nh-zM*!!Ak#YE~xhpaZ5Z=HMkqooP9L*+ID^#ZQil z_cB)vo0pp;d!RaB)dLF~Hi`N{d<;%jkj(}d;WfoVjmwd0V`Ys;L}DX76)3*B>AV1{ zn9fr?>!M76X`?7#^T~{fC{NpKR3eD3QEdzqGjhb4>ZN&kVx|+ROw0y~U7WJ=S%$N6 zeCP3NJD8PW2eYyu+>`6aJD8Qt4^926KL|2^)LHEbVVsz~)}1f@^5}1|RDPCXsluUx z2aAqr4wdqdau6o}5VHVd!J8326ypoJ<8dARmPi=$FCmqxTAtX%#kXGz_Lt|HZt$Wj zn+OBM2qYEZ&A5_V7oIJ6yoDt!zqu&T#CVH1BV376B50f5u(I>#TW6XrZYtAZ4z0;M zO!jM0s;1)PvRfSC^QA=!&LQ6OZK+`Q{GCKlM`@b&hL(F{4f}|Z=VV%zTkjjL>3#5a zLw9%WebX=3!uPh6o;+=H+LH$3^+j{PoH7A4XMv|=tN8>Fxb`e_hWf72w0IBX`MTxf zC2?w7N7<16hn9(VTG94=cIFG+)hQ0%+js^JRheBhdX9m&5_m~C1!~?jAh@ukOTGYx za?L335?QE3BF_N4~TJst|R^$_|n^hGn=I zcR^3$W)QbzT?h|PepGZ{$D1>}FRLOfRL4lKXKr(N>4+9*KCV`#h7otgs+BFnzir^5 zm3X6YXTF*9XyCk9os3LIX=cwieGKNTgTRl8#BoM2%iE5r69NJxNLcsM3!*O@wYV$} zQEnF+OGeJ$s)o&(m;obaE)gxMmH0SoMLC#f+Ei?3q`cIA0W;_9ui$6II$+M#Bz^X7 z5voSIZ9fxVBVDdwZN&C!>PF0;mB5#Fx`@S*PFHX_5mLHugzg)mld>#@E|J2U0sK>) sBg(jNg@=CtbPio}yXNEH>kit(!B3z(7@iJ>eE*yTwN%WbPEs-XUz|IkWB>pF literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TESTER b/internal/test/Tools/TESTER new file mode 100644 index 00000000..1b8aaf20 --- /dev/null +++ b/internal/test/Tools/TESTER @@ -0,0 +1 @@ +(FILECREATED "21-Aug-85 16:52:08" {DSK}TESTER>SOURCES>TESTER.;35 96837 changes to: (FNS TEST.EXECUTE-TESTS TEST.RELEASE-LOCK-COMMAND TEST.RELEASE-LOCK-ON-SELECTED-TESTS-COMMAND TEST.OBTAIN-LOCK-ON-SELECTED-TESTS-COMMAND TEST.OBTAIN-LOCK-COMMAND TEST.CLEANUP-AFTER-TEST TEST.DOCOMMAND TEST.EVAL-BEFORE-TEST TEST.EVALUATE-OUTCOME TEST.EVALUATE-TESTED-EXPR TEST.PERFORM-TEST TEST.PRINT-ON-TRACE-FILE TEST.PRINT-TRACE-INFO TEST.EXECUTE-SELECTED-TESTS-COMMAND TEST.DETACH-TESTS-MENU TEST.GET-TEST TEST.GET-EXECUTION-SPECS TEST.GET-STRONG-LINK-CLOSURE TEST.UPDATE-EXECUTION-SPEC TEST.SET-TESTS-BUFFER-SIZE TEST.COMPUTE-AVERAGE-TEST-SIZE TEST.OPENFILE-OR-WAIT TEST.TEST-FAULT TEST.TOPOLOGICAL-ORDER) (VARS TESTERCOMS) previous date: "20-Aug-85 13:50:30" {DSK}TESTER>SOURCES>TESTER.;31) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT TESTERCOMS) (RPAQQ TESTERCOMS ((FNS SHOULDNT TEST.ADD-CONCEPT-AND-SUBCONCEPTS-TO-CONCEPT-LIST TEST.ADD-CONCEPT-COMMAND TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES TEST.ADD-ITEM-TO-BACKGROUND-MENU TEST.ADD-LINK-COMMAND TEST.ADD-NEW-FIELD-TO-TEST-RECORD TEST.ADD-TEST TEST.ADD-TEST-COMMAND TEST.ALL-COMBINATIONS TEST.ATTACH-TESTS-MENU TEST.BROWSE-CONCEPT-SPACE-COMMAND TEST.BROWSE-SUBTREE-COMMAND TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME TEST.CHANGE-DEPTH-COMMAND TEST.CLEANUP-AFTER-TEST TEST.COLLECT-ALL-TESTS TEST.COLLECT-SUBCONCEPTS-CLOSURE TEST.COMPUTE-AVERAGE-TEST-SIZE TEST.COPY-SUBTREE-COMMAND TEST.COPYBUTTONEVENTFN TEST.CREATE-CONCEPT-SPACE-GRAPH TEST.CREATE-CONCEPT-WINDOW-MENU TEST.CREATE-GRAPH-NODES TEST.CREATE-ICON-WINDOW TEST.CREATE-INTERRUPT-MENU TEST.CREATE-NEW-CONCEPT-SPACE TEST.CREATE-NEW-TEST TEST.DELETE-CONCEPT TEST.DELETE-CONCEPT-COMMAND TEST.DELETE-LINK-COMMAND TEST.DELETE-TEST-COMMAND TEST.DETACH-TESTS-MENU TEST.DISPLAY-CONCEPT-GRAPH TEST.DISPLAY-CONCEPT-SPACE-BROWSER TEST.DOCOMMAND TEST.EDIT-TEST TEST.EDIT-TEST-COMMAND TEST.ERRORP TEST.EVAL-BEFORE-TEST TEST.EVALUATE-OUTCOME TEST.EVALUATE-TESTED-EXPR TEST.EXECUTE-SELECTED-TESTS-COMMAND TEST.EXECUTE-TESTS TEST.FIND-MENU-ITEM TEST.GENERATE-COMPARE-FUNCTION TEST.GENERATE-INPUT TEST.GET-AND-INCREASE-NEXT-TESTID TEST.GET-CONCEPT TEST.GET-CONCEPT-SPACE TEST.GET-DEFAULT-FILED-VALUE TEST.GET-EXECUTION-SPECS TEST.GET-FIELD-VALUE TEST.GET-LOCKING-USERS TEST.GET-NEXT-AVAILABLE-TESTID TEST.GET-STRONG-LINK-CLOSURE TEST.GET-TEST TEST.GET-TEST-SELECTION TEST.HARDCOPY-ALL-TESTS-COMMAND TEST.HARDCOPY-ONE-TEST TEST.HARDCOPY-SELECTED-TESTS-COMMAND TEST.HARDCOPY-TESTS TEST.HARDCOPY-TRACE-FILE TEST.INIT TEST.INSPECTW.ICONFN TEST.INSPECTW.VALUECOMMANDFN TEST.KILL-PROCESS TEST.LEFT-BUTTON-SELECTION TEST.LOAD-CONCEPT-SPACE TEST.LOAD-CONCEPT-SPACE-COMMAND TEST.LOCAL-EVAL-FORM TEST.MAKE-BOUND TEST.MARK-AS-CHANGED TEST.OBTAIN-DATABASE-WRITE-LOCK TEST.OBTAIN-LOCK-COMMAND TEST.OBTAIN-LOCK-ON-SELECTED-TESTS-COMMAND TEST.OPENFILE-OR-WAIT TEST.PERFORM-TEST TEST.PERFORM-TIMED-EVALUATION TEST.POP-UP-CONCEPT-SPACES-MENU TEST.POP-UP-TESTS-MENU TEST.PRINT-ON-TRACE-FILE TEST.PRINT-TEST-OUTCOME TEST.PRINT-TRACE-INFO TEST.PROMPT-WINDOW TEST.RELEASE-DATABASE-WRITE-LOCK TEST.RELEASE-LOCK-COMMAND TEST.RELEASE-LOCK-ON-SELECTED-TESTS-COMMAND TEST.REMOVE-SUBCONCEPT-LINK TEST.REMOVE-SUPERCONCEPT-LINK TEST.REPLACE-INSEPCTW-VALUECOMMANDFN TEST.SEND-RELEASE-REQUESTS TEST.SET-DEFAULT-FIELD-VALUE TEST.SET-TESTS-BUFFER-SIZE TEST.SETIFY TEST.SHADE-TEST TEST.STORE-CHANGED-TESTS TEST.STORE-CONCEPT-SPACE TEST.STORE-CONCEPT-SPACE-COMMAND TEST.STORE-TEST TEST.SWITCH-DISPLAY-MODE-COMMAND TEST.TEST-FAULT TEST.TEST-NUMBER-TO-FILE-NAME TEST.TEST-SELECTED-ON-TEST-MENU-FN TEST.TEST-SINGLE-TIME TEST.TOPOLOGICAL-ORDER TEST.UNION-LIST TEST.UNMARK-AS-CHANGED TEST.UPDATE-COMMAND TEST.UPDATE-EXECUTION-SPEC TEST.WAIT-FOR-SELECTION) (VARS (TEST.EXECUTION-SPECS-EVENT (CREATE.EVENT "EXECUTION-SELECTION-ENDED-EVENT")) (TEST.GLOBAL-CONCEPT-NODE-SELECTED-EVENT (CREATE.EVENT "CONCEPT-NODE-SELECTED-EVENT"))) (BITMAPS TEST.CONCEPT-WINDOW-ICON TEST.CONCEPT-WINDOW-ICON-MASK TEST.INSPECTW.ICON TEST.INSPECTW.MASK))) (DEFINEQ (SHOULDNT [LAMBDA (MESS) (* sm "10-Jul-85 13:59") (ERRORX (LIST 1000 MESS]) (TEST.ADD-CONCEPT-AND-SUBCONCEPTS-TO-CONCEPT-LIST [LAMBDA (NEW-CONCEPT-NAME SOURCE-CONCEPT-LIST TARGET-CONCEPT-LIST) (* sm "19-Aug-85 14:49") (PROG (LAST-CDR NEW-CONCEPT) (if (NOT (FASSOC NEW-CONCEPT-NAME TARGET-CONCEPT-LIST)) then (SETQ NEW-CONCEPT (COPY (FASSOC NEW-CONCEPT-NAME SOURCE-CONCEPT-LIST))) (SETQ LAST-CDR (LAST TARGET-CONCEPT-LIST)) (RPLACD LAST-CDR (LIST NEW-CONCEPT)) (RETURN (CONS NEW-CONCEPT-NAME (for C in (fetch SUBCONCEPTS of NEW-CONCEPT) join ( TEST.ADD-CONCEPT-AND-SUBCONCEPTS-TO-CONCEPT-LIST C SOURCE-CONCEPT-LIST TARGET-CONCEPT-LIST]) (TEST.ADD-CONCEPT-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 09:46") (PROG (PARENT-NODE NEW-CONCEPT LAST-CDR) (SETQ PARENT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select parent node")) [SETQ NEW-CONCEPT (MKATOM (PROMPTFORWORD "Type name for new concept:" NIL NIL ( TEST.PROMPT-WINDOW WINDOW) NIL (QUOTE TTY] [SETQ LAST-CDR (LAST (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] [RPLACD LAST-CDR (LIST (create CONCEPT CONCEPTNAME _ NEW-CONCEPT SUPERCONCEPTS _(LIST (fetch NODEID of PARENT-NODE] (pushnew [fetch SUBCONCEPTS of (TEST.GET-CONCEPT PARENT-NODE (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] NEW-CONCEPT) (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES [LAMBDA (CONCEPTSPACE) (* sm "16-Aug-85 17:13") (if (NOT (BOUNDP (QUOTE TEST.CONCEPT-SPACES))) then (SETQ TEST.CONCEPT-SPACES NIL)) (SETQ TEST.CONCEPT-SPACES (REMOVE (TEST.GET-CONCEPT-SPACE (fetch CONCEPTSPACENAME of CONCEPTSPACE) ) TEST.CONCEPT-SPACES)) (SETQ TEST.CONCEPT-SPACES (CONS CONCEPTSPACE TEST.CONCEPT-SPACES)) (fetch CONCEPTSPACENAME of CONCEPTSPACE]) (TEST.ADD-ITEM-TO-BACKGROUND-MENU [LAMBDA (LABEL COMMAND MESSAGE SUBITEMLIST) (* edited: " 3-Jun-85 15:59") (SETQ BackgroundMenuCommands (REMOVE (SASSOC LABEL BackgroundMenuCommands) BackgroundMenuCommands)) (NCONC1 BackgroundMenuCommands (LIST LABEL COMMAND MESSAGE SUBITEMLIST)) (SETQ BackgroundMenu NIL]) (TEST.ADD-LINK-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 09:46") (PROG (SUPERCONCEPT-NODE SUBCONCEPT-NODE CONCEPT-LIST) (SETQ CONCEPT-LIST (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ SUPERCONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select super concept")) (SETQ SUBCONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select sub concept")) (pushnew (fetch SUBCONCEPTS of (TEST.GET-CONCEPT SUPERCONCEPT-NODE CONCEPT-LIST)) (fetch NODEID of SUBCONCEPT-NODE)) (pushnew (fetch SUPERCONCEPTS of (TEST.GET-CONCEPT SUBCONCEPT-NODE CONCEPT-LIST)) (fetch NODEID of SUPERCONCEPT-NODE)) (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.ADD-NEW-FIELD-TO-TEST-RECORD [LAMBDA (NEW-FIELD DEFAULT-VALUE) (* sm "23-Jul-85 16:28") (PROG (OLD-DEC) (if (NOT (TEST.OBTAIN-DATABASE-WRITE-LOCK (QUOTE DATABASE))) then (RINGBELLS) (PROMPTPRINT "Can not obtain lock on the data base.") (if (MENU (create MENU ITEMS _(QUOTE (("Send release requests" T) ("Don't send requests" NIL))) MENUFONT _ BIGFONT)) then (TEST.SEND-RELEASE-REQUESTS (QUOTE DATABASE))) else [SETQ OLD-DEC (COPY (RECLOOK (QUOTE TEST] (if (FMEMB NEW-FIELD (CADDR OLD-DEC)) then (PRINTOUT T T NEW-FIELD " IS ALREADY A FIELD IN TEST RECORD. ") (RETURN NIL)) (NCONC1 (CADDR OLD-DEC) NEW-FIELD) (if (AND TEST.LIST-OF-MODIFIED-TESTS (MENU (create MENU ITEMS _(QUOTE (( "Store current changes first" T) ( "Ignore current changes." NIL))) MENUFONT _ BIGFONT))) then (TEST.STORE-CHANGED-TESTS)) (EVAL OLD-DEC) (SETQ TEST.LIST-OF-TESTS NIL) (for TEST from 1 to (SUB1 (TEST.GET-NEXT-AVAILABLE-TESTID)) do (SETQ CURRENT-TEST (TEST.GET-TEST TEST)) (NCONC1 TEST DEFAULT-VALUE) (TEST.STORE-TEST TEST) (PRINTOUT T "..." TEST)) (SET (PACK* (QUOTE TEST.DEFAULT.) NEW-FIELD) DEFAULT-VALUE]) (TEST.ADD-TEST [LAMBDA (TEST-RECORD) (* sm "22-Jul-85 14:52") (replace TESTID of TEST-RECORD with (TEST.GET-AND-INCREASE-NEXT-TESTID)) (push TEST.LIST-OF-TESTS TEST-RECORD) (fetch TESTID of TEST-RECORD]) (TEST.ADD-TEST-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 15:38") (PROG (CONCEPT-NODE CONCEPT-LIST TEST-NUMBER TESTS) (SETQ CONCEPT-LIST (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select the concept to which the test should be added")) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T) [SETQ TESTS (MKLIST (CAR (TTYINEDIT NIL (TEST.PROMPT-WINDOW WINDOW) NIL "Enter a test id or a list of test ids: "] (for TEST in TESTS when (FIXP TEST) do (pushnew (fetch TESTS of (TEST.GET-CONCEPT CONCEPT-NODE CONCEPT-LIST)) TEST)) (if (WINDOWPROP WINDOW (QUOTE TEST.DISPLAY-TEST-MODE)) then (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH CONCEPT-LIST T) WINDOW]) (TEST.ALL-COMBINATIONS [LAMBDA (SET-OF-SETS) (* sm " 9-Jul-85 17:00") (if (NULL SET-OF-SETS) then (LIST NIL) else (for ELEMENT in (CAR SET-OF-SETS) join (for COMBINATION in (TEST.ALL-COMBINATIONS (CDR SET-OF-SETS)) collect (CONS ELEMENT COMBINATION]) (TEST.ATTACH-TESTS-MENU [LAMBDA (WINDOW TEST-LIST) (* sm "24-Jul-85 13:40") (PROG (MENU-WINDOW) (SETQ MENU-WINDOW (ATTACHMENU (create MENU ITEMS _ TEST-LIST WHENSELECTEDFN _(QUOTE TEST.TEST-SELECTED-ON-TEST-MENU-FN) MENUROWS _[ADD1 (IQUOTIENT (FLENGTH TEST-LIST) (MAX 1 (IQUOTIENT (CAR (WINDOWSIZE WINDOW)) 30] MENUFONT _ BIGFONT CENTERFLG _ T) WINDOW (if (GREATERP (IPLUS (fetch BOTTOM of (WINDOWREGION WINDOW)) (IQUOTIENT (CDR (WINDOWSIZE WINDOW)) 2)) (IQUOTIENT SCREENHEIGHT 2)) then (QUOTE BOTTOM) else (QUOTE TOP)) (QUOTE JUSTIFY))) (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW) MENU-WINDOW) (WINDOWPROP MENU-WINDOW (QUOTE TEST.DETACH) T) (RETURN MENU-WINDOW]) (TEST.BROWSE-CONCEPT-SPACE-COMMAND [LAMBDA NIL (* sm "19-Aug-85 10:00") (PROG (CONCEPT-SPACE-NAME CONCEPT-SPACE) (if (NULL TEST.CONCEPT-SPACES) then (RETURN NIL)) (if (GREATERP (LENGTH TEST.CONCEPT-SPACES) 1) then (SETQ CONCEPT-SPACE-NAME (TEST.POP-UP-CONCEPT-SPACES-MENU)) (if CONCEPT-SPACE-NAME then (SETQ CONCEPT-SPACE (TEST.GET-CONCEPT-SPACE CONCEPT-SPACE-NAME))) else (SETQ CONCEPT-SPACE (CAR TEST.CONCEPT-SPACES))) (TEST.DISPLAY-CONCEPT-SPACE-BROWSER CONCEPT-SPACE]) (TEST.BROWSE-SUBTREE-COMMAND [LAMBDA (WINDOW) (* sm "20-Aug-85 13:35") (PROG (SUBSPACE ROOT-NAME CONCEPT-NODE) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept to browse")) (SETQ ROOT-NAME (fetch NODEID of CONCEPT-NODE)) [SETQ SUBSPACE (create CONCEPTSPACE CONCEPTSPACENAME _ ROOT-NAME ROOTCONCEPT _ ROOT-NAME CONCEPTLIST _(TEST.SETIFY (TEST.COLLECT-SUBCONCEPTS-CLOSURE ROOT-NAME (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] (TEST.DISPLAY-CONCEPT-SPACE-BROWSER SUBSPACE]) (TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME [LAMBDA (CONCEPT-SPACE-NAME) (* sm "19-Aug-85 12:11") (PACK* CONCEPT-SPACE-NAME (QUOTE .CONCEPTSPACE]) (TEST.CHANGE-DEPTH-COMMAND [LAMBDA (WINDOW) (* sm "20-Aug-85 13:08") (PROG (NEW-DEPTH) (SETQ NEW-DEPTH (MENU (create MENU ITEMS _(QUOTE ((Quit NIL) Inf 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) MENUROWS _ 5 MENUFONT _ BIGFONT CENTERFLG _ T))) (if (NULL NEW-DEPTH) then (RETURN NIL) else (WINDOWPROP WINDOW (QUOTE TEST.DEPTH) (if (FIXP NEW-DEPTH) then NEW-DEPTH else NIL)) (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.CLEANUP-AFTER-TEST [LAMBDA (TEST RESULT ACTUAL-ARGUMENTS LOCATION) (* sm "21-Aug-85 14:00") (PROG (FORMTOEVAL) (SETQ FORMTOEVAL (TEST.GET-FIELD-VALUE (QUOTE EVALAFTER) TEST)) (if FORMTOEVAL then [if (EQ (CAR FORMTOEVAL) (QUOTE LAMBDA)) then (SETQ FORMTOEVAL (LIST (QUOTE APPLY) (KWOTE FORMTOEVAL) (KWOTE (LIST RESULT ACTUAL-ARGUMENTS] (if (EQ LOCATION (QUOTE Remote)) then (TEST.REMOTE-EVAL-FORM FORMTOEVAL) else (TEST.LOCAL-EVAL-FORM FORMTOEVAL]) (TEST.COLLECT-ALL-TESTS [LAMBDA (CONCEPT-NAME CONCEPT-LIST) (* sm " 2-Jul-85 16:50") (PROG (CONCEPT) (RETURN (UNION (fetch TESTS of (SETQ CONCEPT (FASSOC CONCEPT-NAME CONCEPT-LIST))) (TEST.UNION-LIST (for SUBCONCEPT in (fetch SUBCONCEPTS of CONCEPT) collect (TEST.COLLECT-ALL-TESTS SUBCONCEPT CONCEPT-LIST]) (TEST.COLLECT-SUBCONCEPTS-CLOSURE [LAMBDA (CONCEPT-NAME CONCEPT-LIST) (* sm "20-Aug-85 11:12") (PROG (CONCEPT) (SETQ CONCEPT (FASSOC CONCEPT-NAME CONCEPT-LIST)) (SETQ SUBTREE (for SUBCONCEPT in (fetch SUBCONCEPTS of CONCEPT) join ( TEST.COLLECT-SUBCONCEPTS-CLOSURE SUBCONCEPT CONCEPT-LIST))) (if (FASSOC CONCEPT-NAME SUBTREE) then (RETURN SUBTREE) else (RETURN (CONS CONCEPT SUBTREE]) (TEST.COMPUTE-AVERAGE-TEST-SIZE [LAMBDA NIL (* sm "20-Aug-85 16:02") (PROG (LENGTH-SUM NUMBER-OF-FILES) (SETQ LENGTH-SUM (DIRECTORY (PACK* TEST.TEST-DATA-BASE-DIRECTORY (QUOTE TEST) (QUOTE *.;)) (QUOTE COUNTSIZE))) [SETQ NUMBER-OF-FILES (FLENGTH (DIRECTORY (PACK* TEST.TEST-DATA-BASE-DIRECTORY (QUOTE TEST) (QUOTE *.;] (SETQ TEST.AVERAGE-TEST-SIZE (FQUOTIENT LENGTH-SUM NUMBER-OF-FILES)) (RETURN TEST.AVERAGE-TEST-SIZE]) (TEST.COPY-SUBTREE-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 15:18") (PROG (PARENT-NODE NEW-CONCEPT-NAME NEW-CONCEPTS TARGET-CONCEPT-LIST SOURCE-CONCEPT-LIST SOURCE-ROOT-NODE) (SETQ PARENT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select target parent node ")) (SETQ SOURCE-ROOT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select root of source subtreee." T)) (SETQ SOURCE-WINDOW TEST.WINDOW-OF-LAST-SELECTION) (SETQ SOURCE-CONCEPT-LIST (WINDOWPROP SOURCE-WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ TARGET-CONCEPT-LIST (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ NEW-CONCEPT-NAME (fetch NODEID of SOURCE-ROOT-NODE)) (pushnew (fetch SUBCONCEPTS of (TEST.GET-CONCEPT PARENT-NODE TARGET-CONCEPT-LIST)) NEW-CONCEPT-NAME) (SETQ NEW-CONCEPTS (TEST.ADD-CONCEPT-AND-SUBCONCEPTS-TO-CONCEPT-LIST NEW-CONCEPT-NAME SOURCE-CONCEPT-LIST TARGET-CONCEPT-LIST)) (pushnew (fetch SUPERCONCEPTS of (FASSOC NEW-CONCEPT-NAME TARGET-CONCEPT-LIST)) (fetch NODEID of PARENT-NODE)) (for C in NEW-CONCEPTS bind SUPERCONCEPTS do (SETQ SUPERCONCEPTS (fetch SUPERCONCEPTS of (FASSOC C TARGET-CONCEPT-LIST))) (for S in SUPERCONCEPTS when (NOT (FASSOC S TARGET-CONCEPT-LIST)) do (DREMOVE S SUPERCONCEPTS))) (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.COPYBUTTONEVENTFN [LAMBDA (WINDOW) (* sm "19-Jul-85 16:54") (PROG (CURSOR-POS SELECTED-NODE NODE-REGION RELEASED) (SETQ CURSOR-POS (CURSORPOSITION NIL WINDOW)) [SETQ RELEASED (MOUSESTATE (AND (NOT LEFT) (NOT MIDDLE) (NOT RIGHT] (if (SETQ SELECTED-NODE (for NODE in (fetch GRAPHNODES of (WINDOWPROP WINDOW (QUOTE GRAPH))) thereis (INSIDEP (SETQ NODE-REGION (NODEREGION NODE)) CURSOR-POS))) then (FLIPNODE SELECTED-NODE WINDOW) else (GRAPHERCOPYBUTTONEVENTFN WINDOW)) (if (AND RELEASED SELECTED-NODE) then (BKSYSBUF (TEST.COLLECT-ALL-TESTS (fetch NODEID of SELECTED-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS]) (TEST.CREATE-CONCEPT-SPACE-GRAPH [LAMBDA (CONCEPT-LIST INCLUDE-TESTS ROOT-CONCEPT DEPTH) (* sm "20-Aug-85 12:21") (PROG (GRAPH NODE-LIST TESTS-SET TEST.COLLECTED-GRAPH-NODES) [if (WINDOWP CONCEPT-LIST) then (SETQ INCLUDE-TESTS (WINDOWPROP CONCEPT-LIST (QUOTE TEST.DISPLAY-TEST-MODE))) (SETQ CONCEPT-LIST (WINDOWPROP CONCEPT-LIST (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ ROOT-CONCEPT (WINDOWPROP WINDOW (QUOTE TEST.ROOT-CONCEPT))) (SETQ DEPTH (WINDOWPROP WINDOW (QUOTE TEST.DEPTH] [if INCLUDE-TESTS then [SETQ TESTS-SET (for CONCEPT in CONCEPT-LIST join (COPY (fetch TESTS of CONCEPT] (SETQ TESTS-SET (TEST.SETIFY TESTS-SET)) (SETQ NODE-LIST (for TEST in TESTS-SET collect (create GRAPHNODE NODELABEL _ TEST NODEID _ TEST] [SETQ NODE-LIST (APPEND NODE-LIST (if DEPTH then (TEST.CREATE-GRAPH-NODES ROOT-CONCEPT CONCEPT-LIST INCLUDE-TESTS DEPTH) TEST.COLLECTED-GRAPH-NODES else (for CONCEPT in CONCEPT-LIST collect (create GRAPHNODE NODELABEL _(fetch CONCEPTNAME of CONCEPT) NODEID _(fetch CONCEPTNAME of CONCEPT) TONODES _(APPEND (fetch SUBCONCEPTS of CONCEPT) (if INCLUDE-TESTS then (fetch TESTS of CONCEPT] (SETQ GRAPH (LAYOUTGRAPH NODE-LIST (LIST ROOT-CONCEPT) (QUOTE LATTICE))) (RETURN GRAPH]) (TEST.CREATE-CONCEPT-WINDOW-MENU [LAMBDA (WINDOW) (* sm "19-Aug-85 14:14") (create MENU ITEMS _ TEST.CONCEPT-WINDOW-MENU-ITEMS WHENSELECTEDFN _(QUOTE TEST.DOCOMMAND]) (TEST.CREATE-GRAPH-NODES [LAMBDA (ROOT-NAME CONCEPT-LIST INCLUDE-TESTS DEPTH) (* sm "20-Aug-85 13:48") (PROG (ROOT-CONCEPT NEW-NODE) (if (NOT (FASSOC ROOT-NAME TEST.COLLECTED-GRAPH-NODES)) then (SETQ ROOT-CONCEPT (FASSOC ROOT-NAME CONCEPT-LIST)) (if (EQP DEPTH 1) then (SETQ NEW-NODE (create GRAPHNODE NODELABEL _ ROOT-NAME NODEID _ ROOT-NAME TONODES _(if INCLUDE-TESTS then (TEST.COLLECT-ALL-TESTS ROOT-NAME CONCEPT-LIST)) NODEBORDER _(if (fetch SUBCONCEPTS of ROOT-CONCEPT) then 1))) (SETQ TEST.COLLECTED-GRAPH-NODES (CONS NEW-NODE TEST.COLLECTED-GRAPH-NODES)) else [SETQ NEW-NODE (create GRAPHNODE NODELABEL _ ROOT-NAME NODEID _ ROOT-NAME TONODES _(APPEND (fetch SUBCONCEPTS of ROOT-CONCEPT) (if INCLUDE-TESTS then (fetch TESTS of ROOT-CONCEPT] (SETQ TEST.COLLECTED-GRAPH-NODES (CONS NEW-NODE TEST.COLLECTED-GRAPH-NODES)) (for S in (fetch SUBCONCEPTS of ROOT-CONCEPT) do (TEST.CREATE-GRAPH-NODES S CONCEPT-LIST INCLUDE-TESTS (SUB1 DEPTH]) (TEST.CREATE-ICON-WINDOW [LAMBDA (WINDOW ICON) (* sm "19-Aug-85 10:13") [COND ((NULL ICON) (SETQ ICON (TITLEDICONW (create TITLEDICON ICON _ TEST.CONCEPT-WINDOW-ICON MASK _ TEST.CONCEPT-WINDOW-ICON-MASK TITLEREG _(CREATEREGION 4 6 65 14)) (fetch (CONCEPTSPACE CONCEPTSPACENAME) of (WINDOWPROP WINDOW (QUOTE TEST.CONCEPT-SPACE))) (FONTCREATE (QUOTE GACHA) 8] ICON]) (TEST.CREATE-INTERRUPT-MENU [LAMBDA (WINDOW) (* sm "28-Jun-85 16:24") (create MENU ITEMS _[SUBST WINDOW (QUOTE WINDOW) (QUOTE ((" I n t e r r u p t" (TEST.KILL-PROCESS WINDOW) "Will kill the current process. "] CENTERFLG _ T]) (TEST.CREATE-NEW-CONCEPT-SPACE [LAMBDA (CONCEPT-SPACE-NAME ROOT-CONCEPT-NAME) (* sm "19-Aug-85 13:10") (create CONCEPTSPACE CONCEPTSPACENAME _ CONCEPT-SPACE-NAME ROOTCONCEPT _ ROOT-CONCEPT-NAME CONCEPTLIST _(LIST (create CONCEPT CONCEPTNAME _ ROOT-CONCEPT-NAME]) (TEST.CREATE-NEW-TEST [LAMBDA NIL (* sm " 3-Jul-85 11:59") (PROG (NEW-TEST-RECORD) (SETQ NEW-TEST-RECORD (create TEST)) [for F in (RECORDFIELDNAMES (QUOTE TEST)) do (RECORDACCESS F NEW-TEST-RECORD NIL (QUOTE REPLACE) (COPY ( TEST.GET-DEFAULT-FILED-VALUE F] (TEST.ADD-TEST NEW-TEST-RECORD) (TEST.EDIT-TEST NEW-TEST-RECORD]) (TEST.DELETE-CONCEPT [LAMBDA (CONCEPT-NAME LIST-OF-CONCEPTS) (* sm " 2-Jul-85 11:04") (PROG (CONCEPT) (SETQ CONCEPT (FASSOC CONCEPT-NAME LIST-OF-CONCEPTS)) (if CONCEPT then (for SUBCONCEPT-NAME in (fetch SUBCONCEPTS of CONCEPT) bind SUBCONCEPT do (SETQ SUBCONCEPT (FASSOC SUBCONCEPT-NAME LIST-OF-CONCEPTS)) (if SUBCONCEPT then (TEST.REMOVE-SUPERCONCEPT-LINK SUBCONCEPT CONCEPT-NAME LIST-OF-CONCEPTS))) (for SUPERCONCEPT-NAME in (fetch SUPERCONCEPTS of CONCEPT) bind SUPERCONCEPT do (SETQ SUPERCONCEPT (FASSOC SUPERCONCEPT-NAME LIST-OF-CONCEPTS)) (if SUPERCONCEPT then (TEST.REMOVE-SUBCONCEPT-LINK SUPERCONCEPT CONCEPT-NAME))) (DREMOVE CONCEPT LIST-OF-CONCEPTS]) (TEST.DELETE-CONCEPT-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 09:46") (PROG (DELETED-CONCEPT-NODE DELETED-CONCEPT) (SETQ DELETED-CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept to be deleted .") ) (TEST.DELETE-CONCEPT (fetch NODEID of DELETED-CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.DELETE-LINK-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 09:46") (PROG (SUPERCONCEPT-NODE SUBCONCEPT-NODE CONCEPT-LIST SUPERCONCEPT SUPERCONCEPT) (SETQ CONCEPT-LIST (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ SUPERCONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select super concept")) (SETQ SUBCONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select sub concept")) (SETQ SUPERCONCEPT (TEST.GET-CONCEPT SUPERCONCEPT-NODE CONCEPT-LIST)) (SETQ SUBCONCEPT (TEST.GET-CONCEPT SUBCONCEPT-NODE CONCEPT-LIST)) (TEST.REMOVE-SUBCONCEPT-LINK SUPERCONCEPT (fetch CONCEPTNAME of SUBCONCEPT)) (TEST.REMOVE-SUPERCONCEPT-LINK SUBCONCEPT (fetch CONCEPTNAME of SUPERCONCEPT) CONCEPT-LIST) (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.DELETE-TEST-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 16:05") (PROG (CONCEPT-NODE CONCEPT-LIST CURRENT-TESTS TEST-LIST TEST-SELECTED) (SETQ CONCEPT-LIST (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select the concept from which the test should be deleted")) (SETQ TEST-LIST (TEST.GET-TEST-SELECTION WINDOW CONCEPT-NODE T)) (SETQ CURRENT-TESTS (fetch TESTS of (TEST.GET-CONCEPT CONCEPT-NODE CONCEPT-LIST))) (SETQ CURRENT-TESTS (LDIFFERENCE CURRENT-TESTS TEST-LIST)) (replace TESTS of (TEST.GET-CONCEPT CONCEPT-NODE CONCEPT-LIST) with CURRENT-TESTS) (if (WINDOWPROP WINDOW (QUOTE TEST.DISPLAY-TEST-MODE)) then (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH CONCEPT-LIST T) WINDOW]) (TEST.DETACH-TESTS-MENU [LAMBDA (WINDOW) (* sm "21-Aug-85 13:09") (if (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW)) then (DETACHWINDOW (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW))) (CLOSEW (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW))) (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW) NIL]) (TEST.DISPLAY-CONCEPT-GRAPH [LAMBDA (GRAPH WINDOW) (* sm "19-Jul-85 16:58") (SHOWGRAPH GRAPH WINDOW (QUOTE TEST.LEFT-BUTTON-SELECTION)) (WINDOWPROP WINDOW (QUOTE COPYBUTTONEVENTFN) (QUOTE TEST.COPYBUTTONEVENTFN]) (TEST.DISPLAY-CONCEPT-SPACE-BROWSER [LAMBDA (CONCEPT-SPACE REGION/POSITION DEPTH INCLUDE-TESTS) (* sm "20-Aug-85 13:39") (PROG (GRAPH WINDOW GRAPH-REGION CONCEPT-LIST ROOT-CONCEPT GRAPH-WINDOW-WIDTH GRAPH-WINDOW-HEIGHT) (if (NULL CONCEPT-SPACE) then (SETQ CONCEPT-SPACE (TEST.GET-CONCEPT-SPACE TEST.DEFAULT-CONCEPT-SPACE-NAME))) (SETQ GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH (fetch CONCEPTLIST of CONCEPT-SPACE) INCLUDE-TESTS (fetch ROOTCONCEPT of CONCEPT-SPACE) (OR DEPTH TEST.DEFAULT-DEPTH))) [SETQ GRAPH-WINDOW-WIDTH (MAX 250 (MIN (IDIFFERENCE SCREENWIDTH 200) (fetch WIDTH of (SETQ GRAPH-REGION (GRAPHREGION GRAPH] [SETQ GRAPH-WINDOW-HEIGHT (MAX 120 (MIN (IDIFFERENCE SCREENHEIGHT 200) (IPLUS 15 (fetch HEIGHT of GRAPH-REGION] [SETQ REGION (if (REGIONP REGION/POSITION) then REGION/POSITION elseif (POSITIONP REGION/POSITION) then (CREATEREGION (fetch XCOORD of REGION/POSITION) (fetch YCOORD of REGION/POSITION) GRAPH-WINDOW-WIDTH GRAPH-WINDOW-HEIGHT) else (GETBOXREGION GRAPH-WINDOW-WIDTH GRAPH-WINDOW-HEIGHT NIL NIL NIL (CONCAT "Specify position for " (fetch CONCEPTSPACENAME of CONCEPT-SPACE) " browser."] (SETQ WINDOW (CREATEW REGION (CONCAT (fetch CONCEPTSPACENAME of CONCEPT-SPACE) " Concept Space"))) (WINDOWPROP WINDOW (QUOTE TEST.ROOT-CONCEPT) (fetch ROOTCONCEPT of CONCEPT-SPACE)) (WINDOWPROP WINDOW (QUOTE TEST.CONCEPT-SPACE) CONCEPT-SPACE) (TEST.DISPLAY-CONCEPT-GRAPH GRAPH WINDOW) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS) (fetch CONCEPTLIST of CONCEPT-SPACE)) (WINDOWPROP WINDOW (QUOTE TEST.PROCESS) NIL) (WINDOWPROP WINDOW (QUOTE TEST.TEST-SELECTION-ENDED-EVENT) (CREATE.EVENT)) (WINDOWPROP WINDOW (QUOTE TEST.NODE-SELECTED-EVENT) (CREATE.EVENT "TEST:NODE-SELECTED-EVENT")) (WINDOWPROP WINDOW (QUOTE ICONFN) (QUOTE TEST.CREATE-ICON-WINDOW)) (GETPROMPTWINDOW WINDOW 3) (ATTACHMENU (TEST.CREATE-CONCEPT-WINDOW-MENU WINDOW) WINDOW (QUOTE RIGHT) (QUOTE JUSTIFY)) (ATTACHMENU (TEST.CREATE-INTERRUPT-MENU WINDOW) WINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (RETURN WINDOW]) (TEST.DOCOMMAND [LAMBDA (ITEM MENU KEY) (* sm "21-Aug-85 13:10") (PROG (WINDOW) (SETQ WINDOW (MAINWINDOW (WFROMMENU MENU))) (SETQ PARENT-ITEM (TEST.FIND-MENU-ITEM ITEM (fetch ITEMS of MENU))) (WINDOWPROP WINDOW (QUOTE TEST.PROCESS) (ADD.PROCESS [SUBPAIR (QUOTE (WINDOW MENU ITEM PARENT-ITEM)) (LIST WINDOW MENU ITEM PARENT-ITEM) (QUOTE (PROGN (TTYDISPLAYSTREAM (TEST.PROMPT-WINDOW WINDOW)) (SHADEITEM (QUOTE PARENT-ITEM) MENU GRAYSHADE) (WINDOWPROP WINDOW (QUOTE TEST.UNSHADE-IF-SHADED) (QUOTE (SHADEITEM (QUOTE PARENT-ITEM) MENU WHITESHADE))) (CLEARW (TEST.PROMPT-WINDOW WINDOW)) (APPLY* (CADR (QUOTE ITEM)) WINDOW) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T (CAR (QUOTE PARENT-ITEM)) " Completed. ") (WINDOWPROP WINDOW (QUOTE TEST.UNSHADE-IF-SHADED) NIL) (TEST.DETACH-TESTS-MENU WINDOW) (SHADEITEM (QUOTE PARENT-ITEM) MENU WHITESHADE) (WINDOWPROP WINDOW (QUOTE TEST.PROCESS) NIL] (QUOTE WINDOW) (TEST.PROMPT-WINDOW WINDOW) (QUOTE NAME) (CAR ITEM]) (TEST.EDIT-TEST [LAMBDA (TEST LOCK/NOLOCK) (* sm "26-Jul-85 15:00") (PROG (INSPECTW) (if (FIXP TEST) then (SETQ TEST (TEST.GET-TEST TEST))) (TEST.MARK-AS-CHANGED (fetch TESTID of TEST)) (if (AND TEST.OBTAIN-LOCK-WHEN-EDIT (NEQ LOCK/NOLOCK (QUOTE NOLOCK))) then (if [NOT (TEST.OBTAIN-DATABASE-WRITE-LOCK (LIST (fetch TESTID of TEST] then (PRINTOUT T "Can not obtain lock on test number " (fetch TESTID of TEST)) (RETURN NIL))) [SETQ INSPECTW (INSPECT TEST (QUOTE TEST) (GETBOXREGION 700 (ITIMES 15 (LENGTH (RECORDFIELDNAMES (QUOTE TEST] (WINDOWPROP INSPECTW (QUOTE TITLE) (CONCAT "TEST " (fetch TESTID of TEST))) (WINDOWPROP INSPECTW (QUOTE ICONFN) (QUOTE TEST.INSPECTW.ICONFN)) [WINDOWPROP INSPECTW (QUOTE STOREFN) (LIST (QUOTE LAMBDA) (QUOTE (I F N)) (LIST (QUOTE TEST.MARK-AS-CHANGED) (fetch TESTID of TEST)) (LIST (QUOTE APPLY) (KWOTE (WINDOWPROP INSPECTW (QUOTE STOREFN))) (QUOTE (LIST I F N] (TEST.REPLACE-INSEPCTW-VALUECOMMANDFN INSPECTW) (RETURN (fetch TESTID of TEST]) (TEST.EDIT-TEST-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 15:00") (PROG (TEST-SELECTED TEST-NUMBER CONCEPT-NODE) (if (WINDOWPROP WINDOW (QUOTE TEST.DISPLAY-TEST-MODE)) then (SETQ TEST-SELECTED (TEST.WAIT-FOR-SELECTION WINDOW "Select the test you want to edit")) (SETQ TEST-NUMBER (fetch NODEID of TEST-SELECTED)) else (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select a concept which contains the test you want to edit.")) (SETQ TEST-NUMBER (TEST.POP-UP-TESTS-MENU WINDOW CONCEPT-NODE "Select the test that you want to edit."))) (if (FIXP TEST-NUMBER) then (TEST.EDIT-TEST (TEST.GET-TEST TEST-NUMBER]) (TEST.ERRORP [LAMBDA (EXPR) (* sm "27-Jun-85 10:25") (AND EXPR (LISTP EXPR) (EQ (CAR EXPR) (QUOTE ERROR!]) (TEST.EVAL-BEFORE-TEST [LAMBDA (TEST LOCATION) (* sm "21-Aug-85 13:50") (if (EQ LOCATION (QUOTE Remote)) then (TEST.REMOTE-EVAL-FORM (TEST.GET-FIELD-VALUE (QUOTE EVALBEFORE) TEST)) else (TEST.LOCAL-EVAL-FORM (TEST.GET-FIELD-VALUE (QUOTE EVALBEFORE) TEST]) (TEST.EVALUATE-OUTCOME [LAMBDA (TEST RESULT ACTUAL-ARGUMENTS LOCATION) (* sm "21-Aug-85 13:55") (PROG (FORMTOEVAL) [SETQ FORMTOEVAL (LIST (QUOTE APPLY) (KWOTE (TEST.GET-FIELD-VALUE (QUOTE SUCCESSPREDICATE) TEST)) (KWOTE (LIST RESULT ACTUAL-ARGUMENTS] (RETURN (if (EQ LOCATION (QUOTE Remote)) then (TEST.REMOTE-EVAL-FORM FORMTOEVAL) else (TEST.LOCAL-EVAL-FORM FORMTOEVAL]) (TEST.EVALUATE-TESTED-EXPR [LAMBDA (TEST ACTUAL-ARGUMENTS LOCATION) (* sm "21-Aug-85 13:53") (PROG (RESULT EXPRESSION-TO-EVALUATE TIMEOUT.ms) (SETQ EXPRESSION-TO-EVALUATE (TEST.GET-FIELD-VALUE (QUOTE EVALEXPR) TEST)) [if [OR (GETD EXPRESSION-TO-EVALUATE) (AND (LISTP EXPRESSION-TO-EVALUATE) (EQ (CAR EXPRESSION-TO-EVALUATE) (QUOTE LAMBDA] then (SETQ EXPRESSION-TO-EVALUATE (LIST (QUOTE APPLY) (KWOTE EXPRESSION-TO-EVALUATE) (KWOTE (COPY ACTUAL-ARGUMENTS] (SETQ TIMEOUT.ms (TEST.GET-FIELD-VALUE (QUOTE TIMEOUT) TEST)) (if (AND TIMEOUT.ms (EQ (CAR TIMEOUT.ms) (QUOTE LAMBDA))) then (SETQ TIMEOUT.ms (APPLY TIMEOUT.ms ACTUAL-ARGUMENTS))) (RETURN (if (EQ LOCATION (QUOTE Remote)) then (TEST.REMOTE-EVAL-FORM EXPRESSION-TO-EVALUATE TIMEOUT.ms) else (TEST.PERFORM-TIMED-EVALUATION EXPRESSION-TO-EVALUATE TIMEOUT.ms]) (TEST.EXECUTE-SELECTED-TESTS-COMMAND [LAMBDA (WINDOW) (* sm "21-Aug-85 14:11") (TEST.EXECUTE-TESTS WINDOW T]) (TEST.EXECUTE-TESTS [LAMBDA (WINDOW SELLECTED-TESTS?) (* sm "21-Aug-85 14:45") (PROG (CONCEPT-NODE TEST-LIST TRACE-FILE HARDCOPY-FILE SPECS HARDCOPY-MODE PRETEST-MODE TRACE-MODE LOCATION) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept whoes tests should be executed.")) (if (NOT SELLECTED-TESTS?) then [SETQ TEST-LIST (TEST.COLLECT-ALL-TESTS (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] (TEST.ATTACH-TESTS-MENU WINDOW TEST-LIST) (for TEST in TEST-LIST do (TEST.SHADE-TEST TEST WINDOW BLACKSHADE)) else (SETQ TEST-LIST (TEST.GET-TEST-SELECTION WINDOW CONCEPT-NODE))) (SETQ SPECS (TEST.GET-EXECUTION-SPECS)) (SETQ HARDCOPY-MODE (CAR SPECS)) (SETQ PRETEST-MODE (CADR SPECS)) (SETQ TRACE-MODE (CADDR SPECS)) (SETQ LOCATION (CADDDR SPECS)) (SETQ TRACE-FILE (OPENFILE TEST.TRACE-FILE-NAME (QUOTE OUTPUT) (QUOTE NEW))) (CLOSEF TRACE-FILE) (if (EQ PRETEST-MODE (QUOTE Strong-Links)) then (SETQ TEST-LIST (TEST.GET-STRONG-LINK-CLOSURE TEST-LIST)) (TEST.DETACH-TESTS-MENU WINDOW) (TEST.ATTACH-TESTS-MENU WINDOW TEST-LIST) (for TEST in TEST-LIST do (TEST.SHADE-TEST TEST WINDOW BLACKSHADE))) (if (NEQ PRETEST-MODE (QUOTE No-Pretests)) then (SETQ TEST-LIST (TEST.TOPOLOGICAL-ORDER TEST-LIST))) (for TEST in TEST-LIST do (TEST.SHADE-TEST TEST WINDOW GRAYSHADE) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "Performing test number : " TEST T) (TEST.PERFORM-TEST (TEST.GET-TEST TEST) NIL LOCATION TRACE-FILE TRACE-MODE)) (CLOSEF? TRACE-FILE) (if (NEQ HARDCOPY-MODE (QUOTE No-Hardcopy)) then (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T " Hardcopying outcome of tests.") [SETQ HARDCOPY-FILE (TEST.HARDCOPY-TRACE-FILE TRACE-FILE NIL (EQ HARDCOPY-MODE (QUOTE Failures-Only] (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "Outcomes hardcopy on " HARDCOPY-FILE)) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "Test trace on file " TRACE-FILE]) (TEST.FIND-MENU-ITEM [LAMBDA (ITEM ITEM-LIST) (* sm "19-Jul-85 15:37") (COND ((NULL ITEM-LIST) NIL) ((ATOM ITEM-LIST) NIL) ((FMEMB ITEM ITEM-LIST) ITEM) ([AND (CDDDR (CAR ITEM-LIST)) (EQ (CAR (CADDDR (CAR ITEM-LIST))) (QUOTE SUBITEMS)) (TEST.FIND-MENU-ITEM ITEM (CDR (CADDDR (CAR ITEM-LIST] (CAR ITEM-LIST)) (T (TEST.FIND-MENU-ITEM ITEM (CDR ITEM-LIST]) (TEST.GENERATE-COMPARE-FUNCTION [LAMBDA (VAL) (* sm "15-Jun-85 23:33") (LIST (QUOTE LAMBDA) (QUOTE (RES ARGS)) (LIST (QUOTE EQUAL) (QUOTE RES) VAL]) (TEST.GENERATE-INPUT [LAMBDA (TEST) (* sm "25-Jul-85 17:53") (PROG (CURRENT-INPUT) (SETQ CURRENT-INPUT (TEST.GET-FIELD-VALUE (QUOTE INPUT) TEST)) (if (EQ (CAR CURRENT-INPUT) (QUOTE SYSTEMATIC)) then [RETURN (TEST.ALL-COMBINATIONS (for ARG-SPEC in (CDR CURRENT-INPUT) collect (TEST.LOCAL-EVAL-FORM ARG-SPEC] else (RETURN (LIST (TEST.LOCAL-EVAL-FORM CURRENT-INPUT]) (TEST.GET-AND-INCREASE-NEXT-TESTID [LAMBDA NIL (* sm "17-Jul-85 15:12") (PROG (FNAME NEXTID) (SETQ FNAME (TEST.OPENFILE-OR-WAIT TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID (QUOTE BOTH))) (SETQ NEXTID (READ FNAME)) (if (NOT (FIXP NEXTID)) then (CLOSEF FNAME) (RETURN NIL)) (SETFILEPTR FNAME 0) (PRIN1 (ADD1 NEXTID) FNAME) (CLOSEF FNAME) (RETURN NEXTID]) (TEST.GET-CONCEPT [LAMBDA (GRAPHNODE CONCEPT-LIST) (* sm "28-Jun-85 18:12") (FASSOC (fetch NODEID of GRAPHNODE) CONCEPT-LIST]) (TEST.GET-CONCEPT-SPACE [LAMBDA (NAME) (* sm "16-Aug-85 16:54") (if (NULL NAME) then (SETQ NAME TEST.DEFAULT-CONCEPT-SPACE-NAME)) (if (NOT (BOUNDP (QUOTE TEST.CONCEPT-SPACES))) then NIL else (FASSOC NAME TEST.CONCEPT-SPACES]) (TEST.GET-DEFAULT-FILED-VALUE [LAMBDA (FIELD-NAME) (* sm " 3-Jul-85 09:59") (GETTOPVAL (PACK* (QUOTE TEST.DEFAULT.) FIELD-NAME]) (TEST.GET-EXECUTION-SPECS [LAMBDA NIL (* sm "21-Aug-85 12:48") (PROG (WINDOW WINDOW1) (SETQ TEST.GLOBAL-EXECUTION-SPECS (LIST TEST.DEFAULT-HARDCOPY-MODE TEST.DEFAULT-PRETEST-MODE TEST.DEFAULT-TRACE-MODE TEST.DEFAULT-LOCATION)) (SETQ WINDOW (ADDMENU (create MENU ITEMS _(QUOTE (No-Hardcopy Failures-Only Hardcopy-All)) WHENSELECTEDFN _(QUOTE TEST.UPDATE-EXECUTION-SPEC) TITLE _ "Hardcopy Mode" MENUFONT _ BOLDFONT) NIL (create POSITION XCOORD _ 300 YCOORD _ 300))) (WINDOWPROP WINDOW (QUOTE TEST.SELECTION) TEST.DEFAULT-HARDCOPY-MODE) (SHADEITEM TEST.DEFAULT-HARDCOPY-MODE (CAR (WINDOWPROP WINDOW (QUOTE MENU))) BLACKSHADE WINDOW) (SETQ WINDOW1 (ATTACHMENU (create MENU ITEMS _(QUOTE (No-Pretests Weak-Links Strong-Links)) WHENSELECTEDFN _(QUOTE TEST.UPDATE-EXECUTION-SPEC) TITLE _ "Pretests Mode" MENUFONT _ BOLDFONT) WINDOW (QUOTE RIGHT) (QUOTE JUSTIFY))) (WINDOWPROP WINDOW1 (QUOTE TEST.SELECTION) TEST.DEFAULT-PRETEST-MODE) (SHADEITEM TEST.DEFAULT-PRETEST-MODE (CAR (WINDOWPROP WINDOW1 (QUOTE MENU))) BLACKSHADE WINDOW1) (SETQ WINDOW1 (ATTACHMENU (create MENU ITEMS _(QUOTE (On Off)) WHENSELECTEDFN _(QUOTE TEST.UPDATE-EXECUTION-SPEC) TITLE _ "Trace mode" MENUFONT _ BOLDFONT) WINDOW (QUOTE RIGHT) (QUOTE JUSTIFY))) (WINDOWPROP WINDOW1 (QUOTE TEST.SELECTION) TEST.DEFAULT-TRACE-MODE) (SHADEITEM TEST.DEFAULT-TRACE-MODE (CAR (WINDOWPROP WINDOW1 (QUOTE MENU))) BLACKSHADE WINDOW1) (SETQ WINDOW1 (ATTACHMENU (create MENU ITEMS _(QUOTE (Local Remote)) WHENSELECTEDFN _(QUOTE TEST.UPDATE-EXECUTION-SPEC) TITLE _ "Location" MENUFONT _ BOLDFONT) WINDOW (QUOTE RIGHT) (QUOTE JUSTIFY))) (WINDOWPROP WINDOW1 (QUOTE TEST.SELECTION) TEST.DEFAULT-LOCATION) (SHADEITEM TEST.DEFAULT-LOCATION (CAR (WINDOWPROP WINDOW1 (QUOTE MENU))) BLACKSHADE WINDOW1) (ATTACHMENU [create MENU ITEMS _(QUOTE ((" O K"))) CENTERFLG _ T WHENSELECTEDFN _(QUOTE (LAMBDA (ITEM MENU KEY) (SETQ TEST.GLOBAL-EXECUTION-SPECS (for W in [CONS (MAINWINDOW (WFROMMENU MENU)) (ATTACHEDWINDOWS (MAINWINDOW (WFROMMENU MENU] bind DEFAULT when (SETQ DEFAULT (WINDOWPROP W (QUOTE TEST.SELECTION))) collect DEFAULT)) (CLOSEW (MAINWINDOW (WFROMMENU MENU))) (NOTIFY.EVENT TEST.EXECUTION-SPECS-EVENT T] WINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (AWAIT.EVENT TEST.EXECUTION-SPECS-EVENT 600000) (RETURN TEST.GLOBAL-EXECUTION-SPECS]) (TEST.GET-FIELD-VALUE [LAMBDA (FIELD DATUM DEC) (* sm " 3-Jul-85 09:40") (PROG (F-VALUE) (SETQ F-VALUE (RECORDACCESS FIELD DATUM DEC)) (if (AND F-VALUE (LISTP F-VALUE) (EQ (CAR F-VALUE) (QUOTE &)) (FIXP (CADR F-VALUE))) then (RETURN (TEST.GET-FIELD-VALUE FIELD (TEST.GET-TEST (CADR F-VALUE)) DEC)) else (RETURN F-VALUE]) (TEST.GET-LOCKING-USERS [LAMBDA (TEST-LIST) (* sm "23-Jul-85 13:41") (PROG (LOCK-FILE LOCK-INFO USER-LIST INTERSECT-INFO) (SETQ LOCK-FILE (TEST.OPENFILE-OR-WAIT TEST.NAME-OF-LOCK-FILE (QUOTE INPUT))) (if (NOT (EOFP LOCK-FILE)) then (SETQ LOCK-INFO (READ LOCK-FILE))) (if (EQ TEST-LIST (QUOTE DATABASE)) then (SETQ USER-LIST (for K in LOCK-INFO collect (CAR K))) else (SETQ USER-LIST (for USER-INFO in LOCK-INFO when [CDR (SETQ INTERSECT-INFO (CONS (CAR USER-INFO) (if (EQ (CADR USER-INFO) (QUOTE DATABASE)) then TEST-LIST else (INTERSECTION TEST-LIST (CDR USER-INFO] collect INTERSECT-INFO))) (CLOSEF LOCK-FILE) (RETURN USER-LIST]) (TEST.GET-NEXT-AVAILABLE-TESTID [LAMBDA NIL (* sm "17-Jul-85 14:51") (PROG (FNAME NEXTID) (SETQ FNAME (TEST.OPENFILE-OR-WAIT TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID (QUOTE INPUT) (QUOTE OLD))) (SETQ NEXTID (READ FNAME)) (CLOSEF FNAME) (if (FIXP NEXTID) then (RETURN NEXTID) else (RETURN NIL]) (TEST.GET-STRONG-LINK-CLOSURE [LAMBDA (TEST-SET) (* sm "21-Aug-85 10:07") (PROG (OLD NEW LAST) (SETQ OLD TEST-SET) (SETQ LAST TEST-SET) LOOP(SETQ NEW NIL) [for TEST in LAST do (for STRONG-PRETEST in [CDR (FASSOC (QUOTE STRONG) (TEST.GET-FIELD-VALUE (QUOTE PRETESTS) (TEST.GET-TEST TEST] when (AND (NOT (FMEMB STRONG-PRETEST NEW)) (NOT (FMEMB STRONG-PRETEST OLD))) do (SETQ NEW (CONS STRONG-PRETEST NEW] (if NEW then (SETQ OLD (APPEND OLD NEW)) (SETQ LAST NEW) (GO LOOP) else (RETURN OLD]) (TEST.GET-TEST [LAMBDA (TEST-NUMBER) (* sm "21-Aug-85 09:45") (if (AND TEST-NUMBER (FIXP TEST-NUMBER) (GREATERP TEST-NUMBER 0)) then (PROG (TEST TEMP-LIST-OF-TESTS TEST-POINTER) (TEST.MAKE-BOUND (QUOTE TEST.LIST-OF-TESTS)) (SETQ TEMP-LIST-OF-TESTS TEST.LIST-OF-TESTS) (while (AND TEMP-LIST-OF-TESTS (NOT TEST-POINTER)) do (if (EQ (CAAR TEMP-LIST-OF-TESTS) TEST-NUMBER) then (SETQ TEST-POINTER TEMP-LIST-OF-TESTS) else (pop TEMP-LIST-OF-TESTS))) (if (NULL TEST-POINTER) then (RETURN (TEST.TEST-FAULT TEST-NUMBER)) else (SETQ TEST (CAR TEST-POINTER)) (RPLACA TEST-POINTER (CAR TEST.LIST-OF-TESTS)) (RPLACA TEST.LIST-OF-TESTS TEST) (RETURN TEST]) (TEST.GET-TEST-SELECTION [LAMBDA (WINDOW CONCEPT-NODE NODE-ONLY-FLAG) (* sm "19-Aug-85 15:54") (PROG (MENU TEST-LIST MENU-WINDOW) (SETQ TEST-LIST (SORT [if NODE-ONLY-FLAG then [fetch TESTS of (FASSOC (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] else (TEST.COLLECT-ALL-TESTS (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] (QUOTE ILESSP))) (WINDOWPROP WINDOW (QUOTE TEST.SELECTED-TESTS) NIL) (SETQ MENU-WINDOW (TEST.ATTACH-TESTS-MENU WINDOW (CONS (QUOTE OK) TEST-LIST))) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "Select tests from menu. when done select . ") (AWAIT.EVENT (WINDOWPROP WINDOW (QUOTE TEST.TEST-SELECTION-ENDED-EVENT))) (RETURN (WINDOWPROP WINDOW (QUOTE TEST.SELECTED-TESTS) NIL]) (TEST.HARDCOPY-ALL-TESTS-COMMAND [LAMBDA (WINDOW) (* sm "25-Jul-85 16:30") (PROG (CONCEPT-NODE) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept of which tests will be hardcopied")) (TEST.HARDCOPY-TESTS TEST.DEFAULT-HARDCOPY-DEVICE (TEST.COLLECT-ALL-TESTS (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS))) NIL TEST.NEWPAGE-BEFORE-HARDCOPY-TEST]) (TEST.HARDCOPY-ONE-TEST [LAMBDA (TEST FILE NEW-PAGE) (* sm "18-Jul-85 12:16") (if NEW-PAGE then (PRINTOUT FILE .PAGE)) (PRINTOUT FILE T "============================================================================" T .FONT BIGFONT "Test number " (fetch TESTID of TEST) T) (for F in (RECORDFIELDNAMES (QUOTE TEST)) do (PRINTOUT FILE .FONT BOLDFONT F " :" .FONT SYSTEMFONT .PPF (RECORDACCESS F TEST) T]) (TEST.HARDCOPY-SELECTED-TESTS-COMMAND [LAMBDA (WINDOW) (* sm "25-Jul-85 16:31") (PROG (CONCEPT-NODE TEST-LIST) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept of which tests will be hardcopied")) (SETQ TEST-LIST (TEST.GET-TEST-SELECTION WINDOW CONCEPT-NODE)) (if TEST-LIST then (TEST.HARDCOPY-TESTS TEST.DEFAULT-HARDCOPY-DEVICE TEST-LIST NIL TEST.NEWPAGE-BEFORE-HARDCOPY-TEST]) (TEST.HARDCOPY-TESTS [LAMBDA (FILE-NAME TESTS-LIST-OR-LOW-LIMIT HIGH-LIMIT NEW-PAGE) (* sm "24-Jul-85 14:46") (PROG (F LOW HIGH THERMOMETER) (SETQ F (OPENFILE FILE-NAME (QUOTE OUTPUT) (QUOTE NEW))) (if (AND TESTS-LIST-OR-LOW-LIMIT (LISTP TESTS-LIST-OR-LOW-LIMIT)) then [if (AND TEST.DISPLAY-THERMOMETERS (CDR TESTS-LIST-OR-LOW-LIMIT)) then (SETQ THERMOMETER (CREATE-THERMOMETER (FLENGTH TESTS-LIST-OR-LOW-LIMIT) NIL (CREATEREGION 900 0 100 750] (for TEST-NUMBER in (SORT TESTS-LIST-OR-LOW-LIMIT) as COUNTER from 1 do (UPDATE-THERMOMETER COUNTER THERMOMETER) (TEST.HARDCOPY-ONE-TEST (TEST.GET-TEST TEST-NUMBER) F NEW-PAGE)) else (if (NULL TESTS-LIST-OR-LOW-LIMIT) then (SETQ LOW 1) (SETQ HIGH (SUB1 (TEST.GET-NEXT-AVAILABLE-TESTID))) else (SETQ LOW TESTS-LIST-OR-LOW-LIMIT) (SETQ HIGH HIGH-LIMIT)) [if (AND TEST.DISPLAY-THERMOMETERS (GREATERP HIGH LOW)) then (SETQ THERMOMETER (CREATE-THERMOMETER HIGH LOW (CREATEREGION 900 0 100 750] (for I from LOW to HIGH as COUNTER from 1 do (UPDATE-THERMOMETER COUNTER THERMOMETER) (TEST.HARDCOPY-ONE-TEST (TEST.GET-TEST TEST-NUMBER I) F NEW-PAGE))) (if THERMOMETER then (CLOSEW THERMOMETER)) (CLOSEF F]) (TEST.HARDCOPY-TRACE-FILE [LAMBDA (TRACE-FILE OUTPUT-FILE FAILURES-ONLY) (* sm "24-Jul-85 16:53") (PROG (OUT-FILE IN-FILE TEST-INFO TRACE-THERMOMETER) (SETQ OUT-FILE (OPENFILE (OR OUTPUT-FILE TEST.DEFAULT-HARDCOPY-DEVICE) (QUOTE OUTPUT) (QUOTE NEW))) (SETQ IN-FILE (OPENFILE (OR TRACE-FILE TEST.TRACE-FILE-NAME) (QUOTE INPUT) (QUOTE OLD))) (if TEST.DISPLAY-THERMOMETERS then (SETQ TRACE-THERMOMETER (CREATE-THERMOMETER (GETEOFPTR IN-FILE) 0 (CREATEREGION 900 0 100 750) "Trace hardcopy"))) [while (NOT (EOFP IN-FILE)) do (SETQ TEST-INFO (READ IN-FILE)) (UPDATE-THERMOMETER (GETFILEPTR IN-FILE) TRACE-THERMOMETER) (if (OR (NOT FAILURES-ONLY) (EQ (CAR (CDDDDR TEST-INFO)) (QUOTE FAILURE))) then (PRINTOUT OUT-FILE T "------------------------------------------------------------------------------" T .FONT BIGFONT "OUTCOME OF EXPERIMENT NUMBER : " (CAR TEST-INFO) T .FONT BOLDFONT "Time executed : " .FONT SYSTEMFONT (GDATE (CAR TEST-INFO)) T .FONT BOLDFONT "Test ID :" .FONT SYSTEMFONT (CADR TEST-INFO) T .FONT BOLDFONT "Actual arguments: " .FONT SYSTEMFONT) (for ARG in (CADDR TEST-INFO) do (PRINTOUT OUT-FILE T " " .PPF ARG)) (PRINTOUT OUT-FILE .FONT BOLDFONT T "Result : " .FONT SYSTEMFONT .PPF (CADDDR TEST-INFO) T .FONT BIGFONT "Test was " (CAR (CDDDDR TEST-INFO] (if TRACE-THERMOMETER then (CLOSEW TRACE-THERMOMETER)) (CLOSEF OUT-FILE) (CLOSEF IN-FILE) (RETURN OUT-FILE]) (TEST.INIT [LAMBDA NIL (* sm "19-Aug-85 17:28") (TEST.ADD-ITEM-TO-BACKGROUND-MENU "Tester" NIL "Move cursor to the right to select one of the subitems" TEST.BACKGROUND-MENU-SUBITEMS) (TEST.LOAD-CONCEPT-SPACE (TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME TEST.DEFAULT-CONCEPT-SPACE-NAME]) (TEST.INSPECTW.ICONFN [LAMBDA (WINDOW ICON) (* sm "25-Jul-85 14:57") [COND ((NULL ICON) (SETQ ICON (TITLEDICONW (create TITLEDICON ICON _ TEST.INSPECTW.ICON MASK _ TEST.INSPECTW.MASK TITLEREG _(CREATEREGION 4 6 65 30)) (CONCAT (WINDOWPROP WINDOW (QUOTE TITLE)) " INSPECTOR") (FONTCREATE (QUOTE GACHA) 8] ICON]) (TEST.INSPECTW.VALUECOMMANDFN [LAMBDA (VALUE PROPERTY DATUM WINDOW) (* sm "26-Jul-85 15:09") (if (AND (LISTP VALUE) (EQ (CAR VALUE) (QUOTE &)) (FIXP (CADR VALUE))) then [MENU (create MENU ITEMS _(LIST (LIST (CONCAT "Edit test " (CADR VALUE)) (LIST (QUOTE TEST.EDIT-TEST) (CADR VALUE] else (TEST.MARK-AS-CHANGED (fetch TESTID of DATUM)) (APPLY* (QUOTE DEFAULT.INSPECTW.VALUECOMMANDFN) VALUE PROPERTY DATUM WINDOW]) (TEST.KILL-PROCESS [LAMBDA (WINDOW) (* sm "24-Jul-85 14:25") (COND ((WINDOWPROP WINDOW (QUOTE TEST.PROCESS)) (DEL.PROCESS (WINDOWPROP WINDOW (QUOTE TEST.PROCESS))) (FLASHWINDOW WINDOW 3) (CLEARW (TEST.PROMPT-WINDOW WINDOW)) (printout (TEST.PROMPT-WINDOW WINDOW) "User interupt. TEST process aborted.") (for W in (ATTACHEDWINDOWS WINDOW) when (WINDOWPROP W (QUOTE TEST.DETACH)) do (DETACHWINDOW W) (CLOSEW W)) (WINDOWPROP WINDOW (QUOTE TEST.PROCESS) NIL) (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW) NIL) (EVAL (WINDOWPROP WINDOW (QUOTE TEST.UNSHADE-IF-SHADED]) (TEST.LEFT-BUTTON-SELECTION [LAMBDA (SELECTED-OBJ WINDOW) (* sm "19-Aug-85 14:09") (WINDOWPROP WINDOW (QUOTE TEST.CONCEPT-SELECTED) SELECTED-OBJ) (SETQ TEST.WINDOW-OF-LAST-SELECTION WINDOW) (NOTIFY.EVENT TEST.GLOBAL-CONCEPT-NODE-SELECTED-EVENT]) (TEST.LOAD-CONCEPT-SPACE [LAMBDA (CONCEPT-SPACE-FILE-NAME) (* sm "16-Aug-85 17:15") (PROG (FULL-NAME CONCEPTSPACE) (SETQ FULL-NAME (OPENFILE CONCEPT-SPACE-FILE-NAME (QUOTE INPUT) (QUOTE OLD))) (SETQ CONCEPTSPACE (READ FULL-NAME)) (CLOSEF FULL-NAME) (TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES CONCEPTSPACE) [PUTPROP (fetch CONCEPTSPACENAME of CONCEPTSPACE) (QUOTE CONCEPTFILE) (PACKFILENAME (QUOTE HOST) (FILENAMEFIELD FULL-NAME (QUOTE HOST)) (QUOTE DIRECTORY) (FILENAMEFIELD FULL-NAME (QUOTE DIRECTORY)) (QUOTE NAME) (FILENAMEFIELD FULL-NAME (QUOTE NAME)) (QUOTE EXTENSION) (FILENAMEFIELD FULL-NAME (QUOTE EXTENSION] (RETURN FULL-NAME]) (TEST.LOAD-CONCEPT-SPACE-COMMAND [LAMBDA NIL (* sm "16-Aug-85 17:52") (PROG (FNAME) [SETQ FNAME (MKATOM (PROMPTFORWORD "Enter concept space file name : " NIL NIL PROMPTWINDOW NIL (QUOTE TTY] (TEST.LOAD-CONCEPT-SPACE FNAME]) (TEST.LOCAL-EVAL-FORM [LAMBDA (FORM) (* sm "10-Jul-85 13:44") (PROG (OLD-HELPFLAG RESULT ERR) (SETQ OLD-HELPFLAG (GETTOPVAL (QUOTE HELPFLAG))) (SETTOPVAL (QUOTE HELPFLAG) NIL) (SETQ RESULT (ERRORSET FORM (QUOTE NOBREAK))) (SETTOPVAL (QUOTE HELPFLAG) OLD-HELPFLAG) [if (NULL RESULT) then (SETQ ERR (ERRORN)) (SETQ RESULT (LIST (LIST (QUOTE ERROR!) (CAR ERR) (ERRORSTRING (CAR ERR)) (CADR ERR] (RETURN (CAR RESULT]) (TEST.MAKE-BOUND [LAMBDA (VARNAME INIT-VALUE) (* sm "18-Jul-85 10:15") (if (NOT (BOUNDP VARNAME)) then (SET VARNAME INIT-VALUE]) (TEST.MARK-AS-CHANGED [LAMBDA (TEST-NUMBER) (* sm "19-Jul-85 16:24") (TEST.MAKE-BOUND (QUOTE TEST.LIST-OF-MODIFIED-TESTS)) (pushnew TEST.LIST-OF-MODIFIED-TESTS TEST-NUMBER]) (TEST.OBTAIN-DATABASE-WRITE-LOCK [LAMBDA (TEST-LIST) (* sm "23-Jul-85 12:44") (PROG (LOCK-FILE USER-NAME LOCK-INFO RETURN-INFO CURRENT-USER-INFO) (SETQ USER-NAME (MKATOM (FULLUSERNAME))) (SETQ LOCK-FILE (TEST.OPENFILE-OR-WAIT TEST.NAME-OF-LOCK-FILE (QUOTE BOTH))) (if (NULL TEST-LIST) then (RETURN NIL)) (if (NOT (EOFP LOCK-FILE)) then (SETQ LOCK-INFO (READ LOCK-FILE))) [if (EQ TEST-LIST (QUOTE DATABASE)) then (* This case is for the option of locking the entire  database. The only locking user that is allowed is the  current user) (if (OR (NULL LOCK-INFO) (AND (EQP (LENGTH LOCK-INFO) 1) (EQ (CAAR LOCK-INFO) USER-NAME))) then (* The current user is the only one who lock tests. We can replace the list of tests that he locked with the single  word DATABASE) [SETQ LOCK-INFO (LIST (LIST USER-NAME (QUOTE DATABASE] (SETQ RETURN-INFO (QUOTE DATABASE)) else (SETQ RETURN-INFO NIL)) elseif (AND (EQP (LENGTH LOCK-INFO) 1) (EQ (CADAR LOCK-INFO) (QUOTE DATABASE))) then (* In this case the user wants to lock some tests, but somebody locked the whole data-base; If this is the user, we  can consider all tests as locked; If this is another user we must consider all tests as unlocked;) (if (EQ (CAAR LOCK-INFO) USER-NAME) then (SETQ RETURN-INFO TEST-LIST) else (SETQ RETURN-INFO NIL)) else (SETQ TEST-LIST (TEST.SETIFY TEST-LIST)) [SETQ RETURN-INFO (LDIFFERENCE TEST-LIST (for USER-INFO in LOCK-INFO when (NEQ (CAR USER-INFO) USER-NAME) join (COPY (CDR USER-INFO] (* The return-info will contain all the tests of the  test list which can be considered as locked after the  return of this function.) (if (SETQ CURRENT-USER-INFO (FASSOC USER-NAME LOCK-INFO)) then [RPLACD CURRENT-USER-INFO (TEST.SETIFY (APPEND RETURN-INFO (CDR CURRENT-USER-INFO] else (SETQ LOCK-INFO (CONS (CONS USER-NAME RETURN-INFO) LOCK-INFO] (* At the end of this if clause, the LOCK-INFO variable will contain the current lock information which should  be written on the lockfile) (SETFILEPTR LOCK-FILE 0) (PRIN2 LOCK-INFO LOCK-FILE) (CLOSEF LOCK-FILE) (* There can be garbage left at the end, but this  dosn't disturb us since it will not be read anyway.) (RETURN RETURN-INFO]) (TEST.OBTAIN-LOCK-COMMAND [LAMBDA (WINDOW SELECTED) (* sm "21-Aug-85 16:05") (PROG (CONCEPT-NODE TEST-LIST) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept whoes tests should be locked.")) (if (NOT SELECTED) then [SETQ TEST-LIST (TEST.COLLECT-ALL-TESTS (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] else (SETQ TEST-LIST (TEST.GET-TEST-SELECTION WINDOW CONCEPT-NODE))) (SETQ LOCKED-TESTS (TEST.OBTAIN-DATABASE-WRITE-LOCK TEST-LIST)) (if (ILESSP (FLENGTH LOCKED-TESTS) (FLENGTH TEST-LIST)) then (FLASHWINDOW (TEST.PROMPT-WINDOW WINDOW) 2) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "Tests " LOCKED-TESTS " are now locked by you. The other tests are locked as followed: " T (TEST.GET-LOCKING-USERS (LDIFFERENCE TEST-LIST LOCKED-TESTS))) (if (MENU (create MENU ITEMS _(QUOTE (("Send Automatic release requests" T) ("Ignore " NIL))) MENUFONT _ BIGFONT)) then (TEST.SEND-RELEASE-REQUESTS (LDIFFERENCE TEST-LIST LOCKED-TESTS))) else (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "All requested tests are locked."]) (TEST.OBTAIN-LOCK-ON-SELECTED-TESTS-COMMAND [LAMBDA (WINDOW) (* sm "21-Aug-85 15:48") (TEST.OBTAIN-LOCK-COMMAND WINDOW T]) (TEST.OPENFILE-OR-WAIT [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL MAX-WAITING-TIME.ms) (* sm "20-Aug-85 16:54") (PROG (F) (if (NULL MAX-WAITING-TIME.ms) then (SETQ MAX-WAITING-TIME.ms 5000)) (for II from 0 to MAX-WAITING-TIME.ms by 1000 while [TEST.ERRORP (SETQ F (TEST.LOCAL-EVAL-FORM (LIST (QUOTE OPENFILE) (KWOTE FILE) (KWOTE ACCESS) (KWOTE RECOG) (KWOTE PARAMETERS) (KWOTE OPTIONAL] do (DISMISS 1000)) (if (NOT (TEST.ERRORP F)) then (RETURN F]) (TEST.PERFORM-TEST [LAMBDA (TEST TIMES LOCATION TRACE-FILE TRACE-MODE) (* sm "21-Aug-85 14:01") (PROG (TIMES-THERMOMETER) (if (NULL TIMES) then (SETQ TIMES (TEST.GET-FIELD-VALUE (QUOTE TIMES) TEST))) (if (NULL TIMES) then (SETQ TIMES 1)) (if (NULL LOCATION) then (SETQ LOCATION TEST.DEFAULT-LOCATION)) (if (NULL TRACE-FILE) then (SETQ TRACE-FILE (OPENFILE TEST.TRACE-FILE-NAME (QUOTE OUTPUT) (QUOTE NEW))) (CLOSEF TRACE-FILE)) (if (NULL TRACE-MODE) then (SETQ TRACE-MODE TEST.DEFAULT-TRACE-MODE)) (if (AND (GREATERP TIMES 1) TEST.DISPLAY-THERMOMETERS) then (SETQ TIMES-THERMOMETER (CREATE-THERMOMETER TIMES 0 (CREATEREGION 900 0 100 750) "Iterations"))) [for I1 from 1 to TIMES do (if (AND (GREATERP TIMES 1) TEST.DISPLAY-THERMOMETERS) then (UPDATE-THERMOMETER I1 TIMES-THERMOMETER)) (PROG (LIST-OF-ACTUAL-ARGUMENTS ARGUMENTS-THERMOMETER) (TEST.EVAL-BEFORE-TEST TEST LOCATION) (SETQ LIST-OF-ACTUAL-ARGUMENTS (TEST.GENERATE-INPUT TEST)) (if (AND TEST.DISPLAY-THERMOMETERS (CDR LIST-OF-ACTUAL-ARGUMENTS)) then (SETQ ARGUMENTS-THERMOMETER (CREATE-THERMOMETER (FLENGTH LIST-OF-ACTUAL-ARGUMENTS) 0 (CREATEREGION 800 0 100 750) "input"))) [for ACTUAL-ARGUMENTS in LIST-OF-ACTUAL-ARGUMENTS as INPUT-NUM from 0 do (if (AND TEST.DISPLAY-THERMOMETERS (CDR LIST-OF-ACTUAL-ARGUMENTS)) then (UPDATE-THERMOMETER INPUT-NUM ARGUMENTS-THERMOMETER)) (PROG (RESULT OUTCOME EXPRESSION-TO-EVALUATE) (if (EQ TRACE-MODE (QUOTE On)) then (TEST.PRINT-TRACE-INFO TRACE-FILE (LIST (IDATE) (fetch TESTID of TEST) ACTUAL-ARGUMENTS))) (TEST.PRINT-ON-TRACE-FILE (SETQ RESULT (TEST.EVALUATE-TESTED-EXPR TEST ACTUAL-ARGUMENTS LOCATION)) TRACE-FILE T TRACE-MODE) (TEST.PRINT-ON-TRACE-FILE (SETQ OUTCOME (TEST.EVALUATE-OUTCOME TEST RESULT ACTUAL-ARGUMENTS LOCATION) ) TRACE-FILE T TRACE-MODE) (TEST.CLEANUP-AFTER-TEST TEST RESULT ACTUAL-ARGUMENTS LOCATION) (if (EQ TRACE-MODE (QUOTE Off)) then (if (EQ OUTCOME (QUOTE FAILURE)) then (TEST.PRINT-TRACE-INFO TRACE-FILE (LIST (IDATE) (fetch TESTID of TEST) ACTUAL-ARGUMENTS RESULT OUTCOME] (if ARGUMENTS-THERMOMETER then (CLOSEW ARGUMENTS-THERMOMETER] (if TIMES-THERMOMETER then (CLOSEW TIMES-THERMOMETER)) (RETURN TRACE-FILE]) (TEST.PERFORM-TIMED-EVALUATION [LAMBDA (FORM TIMEOUT.ms) (* sm "22-Jul-85 19:24") (if TIMEOUT.ms then (PROG (PROCESS EVENT TIMER) (SETQ EVENT (CREATE.EVENT)) (SETQ TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION NIL) (SETQ TIMER (SETUPTIMER (IPLUS TIMEOUT.ms 1000))) [SETQ PROCESS (ADD.PROCESS (SUBPAIR (QUOTE (FORM EVENT)) (LIST FORM EVENT) (QUOTE (PROGN (SETQ TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION (TEST.LOCAL-EVAL-FORM (QUOTE FORM))) (NOTIFY.EVENT EVENT] (if (EQUAL (AWAIT.EVENT EVENT TIMER T) "{time interval expired}") then (DEL.PROCESS PROCESS) (RETURN (QUOTE (ERROR! TIMEEXPIRED))) else (RETURN TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION))) else (TEST.LOCAL-EVAL-FORM FORM]) (TEST.POP-UP-CONCEPT-SPACES-MENU [LAMBDA NIL (* sm "19-Aug-85 09:36") (MENU (create MENU ITEMS _(CONS (QUOTE ("Quit" NIL)) (for C in TEST.CONCEPT-SPACES collect (fetch (CONCEPTSPACE CONCEPTSPACENAME) of C))) MENUFONT _ BIGFONT]) (TEST.POP-UP-TESTS-MENU [LAMBDA (WINDOW CONCEPT-NODE MESSAGE LOCAL-TESTS-ONLY) (* sm "19-Aug-85 10:17") (PROG (TEST-LIST MENU) [SETQ TEST-LIST (if LOCAL-TESTS-ONLY then [fetch TESTS of (FASSOC (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] else (TEST.COLLECT-ALL-TESTS (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] (if TEST-LIST then (if MESSAGE then (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T MESSAGE)) [SETQ MENU (create MENU ITEMS _(SORT TEST-LIST) MENUFONT _ BIGFONT CENTERFLG _ T MENUROWS _(FIX (SQRT (FLENGTH TEST-LIST] (RETURN (MENU MENU]) (TEST.PRINT-ON-TRACE-FILE [LAMBDA (SEXPR FULLFILENAME RETREAT? TRACE-MODE) (* sm "21-Aug-85 13:43") (if (EQ TRACE-MODE (QUOTE On)) then (OPENFILE FULLFILENAME (QUOTE BOTH)) (SETFILEPTR FULLFILENAME (if RETREAT? then (SUB1 (GETEOFPTR FULLFILENAME)) else (GETEOFPTR FULLFILENAME))) (PRIN2 SEXPR FULLFILENAME) (PRIN1 " )" FULLFILENAME) (CLOSEF FULLFILENAME]) (TEST.PRINT-TEST-OUTCOME [LAMBDA (TEST-INFO FILE) (* sm " 3-Jul-85 12:35") (PRINTOUT FILE T "------------------------------------------------------------------------------" T .FONT BIGFONT "OUTCOME OF TEST NUMBER : " (CAR TEST-INFO) T .FONT BOLDFONT "Actual arguments: " .FONT SYSTEMFONT) (for ARG in (CADR TEST-INFO) do (PRINTOUT FILE T " " .PPF ARG)) (PRINTOUT FILE .FONT BOLDFONT T "Result : " .FONT SYSTEMFONT .PPF (CADDR TEST-INFO) T .FONT BIGFONT "Test was " (CADDDR TEST-INFO]) (TEST.PRINT-TRACE-INFO [LAMBDA (TRACE-FILE INFO) (* sm "21-Aug-85 13:30") (OPENFILE TRACE-FILE (QUOTE APPEND) (QUOTE OLD)) (PRINTOUT TRACE-FILE T INFO) (CLOSEF TRACE-FILE]) (TEST.PROMPT-WINDOW [LAMBDA (WINDOW) (* edited: "29-Mar-85 16:07") (CAR (WINDOWPROP WINDOW (QUOTE PROMPTWINDOW]) (TEST.RELEASE-DATABASE-WRITE-LOCK [LAMBDA (TEST-LIST) (* sm "23-Jul-85 14:08") (PROG (LOCK-FILE USER-NAME LOCK-INFO RETURN-INFO CURRENT-USER-INFO NEW-USER-INFO) (SETQ USER-NAME (MKATOM (FULLUSERNAME))) (SETQ LOCK-FILE (TEST.OPENFILE-OR-WAIT TEST.NAME-OF-LOCK-FILE (QUOTE BOTH))) (if (NULL TEST-LIST) then (RETURN NIL)) (if (NOT (EOFP LOCK-FILE)) then (SETQ LOCK-INFO (READ LOCK-FILE))) (if (EQ TEST-LIST (QUOTE DATABASE)) then (* This case is for the option of locking the entire  database. The only locking user that is allowed is the  current user) (if (OR (NEQ (LENGTH LOCK-INFO) 1) (NEQ (CAAR LOCK-INFO) USER-NAME) (NEQ (CADAR LOCK-INFO) (QUOTE DATABASE))) then (* The Data-base Is Not Locked By The Current User - So It Can Not Be Released) (SETQ RETURN-INFO NIL) else (SETQ RETURN-INFO (QUOTE DATABASE)) (SETQ LOCK-INFO NIL)) elseif (AND (EQP (LENGTH LOCK-INFO) 1) (EQ (CADAR LOCK-INFO) (QUOTE DATABASE))) then (* The User Wants To Release A Set Of Tests, But The  Whole Database Is Locked, Either By The User Or By  Another User;) (SETQ RETURN-INFO NIL) else (* The Default Case: Return-info Will Contain The List Of Tests That Actually Were Held By The User And Are Now  Released %. Lock-info Will Be Updated And Written To The File) (SETQ TEST-LIST (TEST.SETIFY TEST-LIST)) (SETQ CURRENT-USER-INFO (FASSOC USER-NAME LOCK-INFO)) (if (NULL CURRENT-USER-INFO) then (SETQ RETURN-INFO NIL) else (for TEST in (CDR CURRENT-USER-INFO) do (if (FMEMB TEST TEST-LIST) then (push RETURN-INFO TEST) else (push NEW-USER-INFO TEST))) (RPLACD CURRENT-USER-INFO NEW-USER-INFO))) (* At the end of this if clause, the LOCK-INFO variable will contain the current lock information which should  be written on the lockfile) (SETFILEPTR LOCK-FILE 0) (PRIN2 LOCK-INFO LOCK-FILE) (PRIN1 " " LOCK-FILE) (CLOSEF LOCK-FILE) (* There can be garbage left at the end, but this  dosn't disturb us since it will not be read anyway.) (RETURN RETURN-INFO]) (TEST.RELEASE-LOCK-COMMAND [LAMBDA (WINDOW SELECTED) (* sm "21-Aug-85 16:15") (PROG (CONCEPT-NODE TEST-LIST) (SETQ CONCEPT-NODE (TEST.WAIT-FOR-SELECTION WINDOW "Select concept whoes tests should be released.")) (if (NOT SELECTED) then [SETQ TEST-LIST (TEST.COLLECT-ALL-TESTS (fetch NODEID of CONCEPT-NODE) (WINDOWPROP WINDOW (QUOTE TEST.LIST-OF-CONCEPTS] else (SETQ TEST-LIST (TEST.GET-TEST-SELECTION WINDOW CONCEPT-NODE))) (TEST.RELEASE-DATABASE-WRITE-LOCK TEST-LIST) (PRINTOUT (TEST.PROMPT-WINDOW WINDOW) T "All requested tests are released."]) (TEST.RELEASE-LOCK-ON-SELECTED-TESTS-COMMAND [LAMBDA (WINDOW) (* sm "21-Aug-85 16:10") (TEST.RELEASE-LOCK-COMMAND WINDOW T]) (TEST.REMOVE-SUBCONCEPT-LINK [LAMBDA (CONCEPT SUBCONCEPT-NAME) (* sm " 2-Jul-85 09:55") (replace SUBCONCEPTS of CONCEPT with (REMOVE SUBCONCEPT-NAME (fetch SUBCONCEPTS of CONCEPT]) (TEST.REMOVE-SUPERCONCEPT-LINK [LAMBDA (CONCEPT SUPERCONCEPT-NAME LIST-OF-CONCEPTS) (* sm " 2-Jul-85 10:00") (replace SUPERCONCEPTS of CONCEPT with (REMOVE SUPERCONCEPT-NAME (fetch SUPERCONCEPTS of CONCEPT))) (if (NULL (fetch SUPERCONCEPTS of CONCEPT)) then (TEST.DELETE-CONCEPT (fetch CONCEPTNAME of CONCEPT) LIST-OF-CONCEPTS]) (TEST.REPLACE-INSEPCTW-VALUECOMMANDFN [LAMBDA (W) (for ITEM in (WINDOWPROP W (QUOTE SELECTABLEITEMS)) when (NEQ (CADDDR ITEM) (QUOTE PROPERTY)) do (RPLACA (CDR ITEM) (QUOTE TEST.INSPECTW.VALUECOMMANDFN]) (TEST.SEND-RELEASE-REQUESTS [LAMBDA (TEST-LIST) (* sm "23-Jul-85 15:59") (PROG (USER-LIST) (SETQ USER-LIST (TEST.GET-LOCKING-USERS TEST-LIST)) (for USER-INFO in USER-LIST do (LAFITE.SENDMESSAGE (CONCAT "Subject: Locks on test files are needed To: " (if (LISTP USER-INFO) then (CAR USER-INFO) else USER-INFO) " cc: " (FULLUSERNAME) " You have the locks for tests " (if (LISTP USER-INFO) then (CDR USER-INFO) else " ") " . Please release them as soon as possible and let me know when you are done. Thanks .")) (PRINTOUT T T (CONCAT "Message was sent to " (CAR USER-INFO)) T]) (TEST.SET-DEFAULT-FIELD-VALUE [LAMBDA (FIELD-NAME NEW-DEFAULT-VALUE) (* sm " 3-Jul-85 09:59") (SETTOPVAL (PACK* (QUOTE TEST.DEFAULT.) FIELD-NAME) NEW-DEFAULT-VALUE]) (TEST.SET-TESTS-BUFFER-SIZE [LAMBDA NIL (* sm "20-Aug-85 16:05") (PROG (STORGE-LEFT) (SETQ STORAGE-LEFT (IDIFFERENCE \LASTVMEMFILEPAGE (VMEMSIZE))) (RETURN (SETQ TEST.TESTS-BUFFER-SIZE (MAX TEST.MIN-TESTS-BUFFER-SIZE (MIN TEST.MAX-TESTS-BUFFER-SIZE (FIX (FQUOTIENT STORAGE-LEFT TEST.AVERAGE-TEST-SIZE]) (TEST.SETIFY [LAMBDA (L) (PROG (NEW-SET) (for ONE-ELEMENT in L when (NOT (MEMBER ONE-ELEMENT NEW-SET)) do (SETQ NEW-SET (CONS ONE-ELEMENT NEW-SET))) (RETURN NEW-SET]) (TEST.SHADE-TEST [LAMBDA (TEST-NUMBER WINDOW SHADE) (* sm "24-Jul-85 16:36") (PROG (MENU-WINDOW) (SETQ SHADE (OR SHADE BLACKSHADE)) (if (SETQ MENU-WINDOW (WINDOWPROP WINDOW (QUOTE TEST.TESTS-MENU-WINDOW))) then (SHADEITEM TEST-NUMBER (CAR (WINDOWPROP MENU-WINDOW (QUOTE MENU))) SHADE MENU-WINDOW]) (TEST.STORE-CHANGED-TESTS [LAMBDA NIL (* sm "19-Jul-85 16:33") (for TEST in TEST.LIST-OF-MODIFIED-TESTS do (PRINT (TEST.STORE-TEST TEST]) (TEST.STORE-CONCEPT-SPACE [LAMBDA (CONCEPTSPACENAME) (* sm "19-Aug-85 12:13") (PROG (FULL-NAME FILENAME CONCEPTSPACE CANDIDATE-FILE) (SETQ CONCEPTSPACE (TEST.GET-CONCEPT-SPACE CONCEPTSPACENAME)) (SETQ CONCEPTSPACENAME (fetch CONCEPTSPACENAME of CONCEPTSPACE)) (SETQ CANDIDATE-FILE (OR (GETPROP CONCEPTSPACENAME (QUOTE CONCEPTFILE)) (TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME CONCEPTSPACENAME))) (CLRPROMPT) [SETQ FILENAME (MKATOM (PROMPTFORWORD (CONCAT "Name of file for storing " CONCEPTSPACENAME ": ") (FULLNAME (MKSTRING CANDIDATE-FILE) (QUOTE NEW)) NIL PROMPTWINDOW NIL (QUOTE TTY] (SETQ FULL-NAME (OPENFILE FILENAME (QUOTE OUTPUT) (QUOTE NEW))) (PRIN2 CONCEPTSPACE FULL-NAME) (CLOSEF FULL-NAME) (RETURN FULL-NAME]) (TEST.STORE-CONCEPT-SPACE-COMMAND [LAMBDA NIL (* sm "16-Aug-85 17:55") (PROG (CNAME) (SETQ CNAME (TEST.POP-UP-CONCEPT-SPACES-MENU)) (TEST.STORE-CONCEPT-SPACE CNAME]) (TEST.STORE-TEST [LAMBDA (TEST-NUMBER) (* sm "18-Jul-85 09:33") (PROG (FULL-FILE-NAME TEST) (SETQ TEST (TEST.GET-TEST TEST-NUMBER)) (if TEST then (SETQ FULL-FILE-NAME (OPENFILE (TEST.TEST-NUMBER-TO-FILE-NAME TEST-NUMBER) (QUOTE OUTPUT) (QUOTE NEW))) (PRIN2 TEST FULL-FILE-NAME) (CLOSEF FULL-FILE-NAME) (TEST.UNMARK-AS-CHANGED TEST-NUMBER) (RETURN FULL-FILE-NAME]) (TEST.SWITCH-DISPLAY-MODE-COMMAND [LAMBDA (WINDOW) (* sm "19-Aug-85 09:46") [WINDOWPROP WINDOW (QUOTE TEST.DISPLAY-TEST-MODE) (NOT (WINDOWPROP WINDOW (QUOTE TEST.DISPLAY-TEST-MODE] (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.TEST-FAULT [LAMBDA (TEST-NUMBER) (* sm "20-Aug-85 16:57") (PROG (FILE-NAME FULL-FILE-NAME TEST CURRENT-LENGTH) (SETQ FILE-NAME (TEST.TEST-NUMBER-TO-FILE-NAME TEST-NUMBER)) (SETQ FULL-FILE-NAME (TEST.OPENFILE-OR-WAIT FILE-NAME (QUOTE INPUT) (QUOTE OLD))) (if FULL-FILE-NAME then (SETQ TEST (READ FULL-FILE-NAME)) (CLOSEF FULL-FILE-NAME) (TEST.SET-TESTS-BUFFER-SIZE) (push TEST.LIST-OF-TESTS TEST) (if (GREATERP (SETQ CURRENT-LENGTH (FLENGTH TEST.LIST-OF-TESTS)) TEST.TESTS-BUFFER-SIZE) then (RPLACD (NLEFT TEST.LIST-OF-TESTS (ADD1 (IDIFFERENCE TEST.TESTS-BUFFER-SIZE CURRENT-LENGTH))) NIL)) (RETURN TEST) else (PROMPTPRINT (CONCAT "TESTER: File " FILE-NAME " not found. "]) (TEST.TEST-NUMBER-TO-FILE-NAME [LAMBDA (TEST-NUMBER) (* sm "22-Jul-85 14:24") (PACK (APPEND (LIST TEST.TEST-DATA-BASE-DIRECTORY (QUOTE TEST)) (from 1 to (IDIFFERENCE 5 (NCHARS TEST-NUMBER)) collect 0) (LIST TEST-NUMBER]) (TEST.TEST-SELECTED-ON-TEST-MENU-FN [LAMBDA (ITEM MENU KEY) (* sm "19-Jul-85 14:59") (PROG (WINDOW MAIN-WINDOW) (SETQ WINDOW (WFROMMENU MENU)) (SETQ MAIN-WINDOW (MAINWINDOW WINDOW)) (COND [(EQ ITEM (QUOTE OK)) (NOTIFY.EVENT (WINDOWPROP MAIN-WINDOW (QUOTE TEST.TEST-SELECTION-ENDED-EVENT] (ITEM (COND ((FMEMB ITEM (WINDOWPROP MAIN-WINDOW (QUOTE TEST.SELECTED-TESTS))) (WINDOWDELPROP MAIN-WINDOW (QUOTE TEST.SELECTED-TESTS) ITEM) (SHADEITEM ITEM MENU WHITESHADE WINDOW)) (T (WINDOWADDPROP MAIN-WINDOW (QUOTE TEST.SELECTED-TESTS) ITEM) (SHADEITEM ITEM MENU BLACKSHADE WINDOW]) (TEST.TEST-SINGLE-TIME [LAMBDA (TEST-NUMBER) (* sm "24-Jul-85 15:50") (PROG (TEST-COPY TEST-INPUT LIST-OF-SETS SHORT-INPUT TRACE-FILE TEST-OUTCOME) (SETQ TEST-COPY (COPY (TEST.GET-TEST TEST-NUMBER))) (SETQ TEST-INPUT (TEST.GET-FIELD-VALUE (QUOTE INPUT) TEST-COPY)) [if (EQ (CAR TEST-INPUT) (QUOTE SYSTEMATIC)) then (EVAL (TEST.GET-FIELD-VALUE (QUOTE EVALBEFORE) TEST-COPY)) (SETQ LIST-OF-SETS (for ONE-SET in (CDR TEST-INPUT) collect (EVAL ONE-SET))) (if (for ONE-SET in LIST-OF-SETS thereis (NOT (LISTP ONE-SET))) then (RETURN (QUOTE (FAILURE "SYSTEMATIC TEST WITH NON-LIST ARGUMENT"))) else (SETQ SHORT-INPUT (for ONE-SET in LIST-OF-SETS collect (CAR ONE-SET))) (replace INPUT of TEST-COPY with (KWOTE SHORT-INPUT] (replace TIMES of TEST-COPY with 1) (SETQ TRACE-FILE (OPENFILE TEST.TRACE-FILE-NAME (QUOTE OUTPUT) (QUOTE NEW))) (CLOSEF TRACE-FILE) (SETQ TRACE-FILE (TEST.PERFORM-TEST TEST-COPY 1 T TRACE-FILE)) (OPENFILE TRACE-FILE (QUOTE INPUT) (QUOTE OLD)) (SETQ TEST-OUTCOME (READ TRACE-FILE)) (CLOSEF TRACE-FILE) (if (LESSP (LENGTH TEST-OUTCOME) 5) then [RETURN (LIST (QUOTE FAILURE) (CONCAT "TEST WAS NOT FINISHED. ONLY " (MKSTRING (LENGTH TEST-OUTCOME)) "ITEMS WERE WRITTEN. TRACE FILE FULL NAME IS : " (MKSTRING TRACE-FILE] else (if [NOT (FMEMB (CAR (CDDDDR TEST-OUTCOME)) (QUOTE (SUCCESS FAILUE] then (RETURN (LIST (QUOTE FAILURE) (CONCAT "OUTCOME WAS " (CAR (CDDDDR TEST-OUTCOME)) "INSTEAD OF SUCCESS OR FAILURE. "))) else (RETURN (QUOTE (SUCCESS]) (TEST.TOPOLOGICAL-ORDER [LAMBDA (SET-OF-TESTS) (* sm "20-Aug-85 17:58") (PROG (TEST-LINKS ORDERED-LIST) [SETQ TEST-LINKS (for TEST in SET-OF-TESTS bind PRETESTS collect (CONS TEST (PROGN (SETQ PRETESTS (TEST.GET-FIELD-VALUE (QUOTE PRETESTS) (TEST.GET-TEST TEST))) (TEST.SETIFY (for PRETEST in (APPEND (FASSOC (QUOTE WEAK) PRETESTS) (FASSOC (QUOTE STRONG) PRETESTS)) when (FMEMB PRETEST SET-OF-TESTS) collect PRETEST] (while TEST-LINKS bind TEMP-LIST do (for T1 in TEST-LINKS when (for PRE in (CDR T1) always (FMEMB PRE ORDERED-LIST)) do (SETQ TEMP-LIST (CONS T1 TEMP-LIST)) (SETQ ORDERED-LIST (CONS (CAR T1) ORDERED-LIST))) (SETQ TEST-LINKS (LDIFFERENCE TEST-LINKS TEMP-LIST))) (RETURN (REVERSE ORDERED-LIST]) (TEST.UNION-LIST [LAMBDA (L) (* sm " 2-Jul-85 12:36") (COND ((NULL L) NIL) (T (UNION (CAR L) (TEST.UNION-LIST (CDR L]) (TEST.UNMARK-AS-CHANGED [LAMBDA (TEST-NUMBER) (* sm "18-Jul-85 10:13") (TEST.MAKE-BOUND (QUOTE TEST.LIST-OF-MODIFIED-TESTS)) (SETQ TEST.LIST-OF-MODIFIED-TESTS (REMOVE TEST-NUMBER TEST.LIST-OF-MODIFIED-TESTS]) (TEST.UPDATE-COMMAND [LAMBDA (WINDOW) (* sm "20-Aug-85 11:25") (TEST.DISPLAY-CONCEPT-GRAPH (TEST.CREATE-CONCEPT-SPACE-GRAPH WINDOW) WINDOW]) (TEST.UPDATE-EXECUTION-SPEC [LAMBDA (ITEM MENU KEY) (* sm "21-Aug-85 12:03") (SHADEITEM (WINDOWPROP (WFROMMENU MENU) (QUOTE TEST.SELECTION)) MENU WHITESHADE) (WINDOWPROP (WFROMMENU MENU) (QUOTE TEST.SELECTION) ITEM) (SHADEITEM ITEM MENU BLACKSHADE]) (TEST.WAIT-FOR-SELECTION [LAMBDA (WINDOW MESSAGE ALLOW-GLOBAL-SELECTION) (* sm "19-Aug-85 14:42") (PROG (WAITS) (WINDOWPROP WINDOW (QUOTE TEST.CONCEPT-SELECTED) NIL) (SETQ WAITS 0) (SETQ TEST.WINDOW-OF-LAST-SELECTION NIL) (printout (TEST.PROMPT-WINDOW WINDOW) T MESSAGE) WAIT-AGAIN (SETQ WAITS (ADD1 WAITS)) (AWAIT.EVENT TEST.GLOBAL-CONCEPT-NODE-SELECTED-EVENT 1000) (COND ([OR (NULL TEST.WINDOW-OF-LAST-SELECTION) (AND (NOT ALLOW-GLOBAL-SELECTION) (NEQ TEST.WINDOW-OF-LAST-SELECTION WINDOW)) (NULL (WINDOWPROP TEST.WINDOW-OF-LAST-SELECTION (QUOTE TEST.CONCEPT-SELECTED] [COND ((GREATERP WAITS 50) (RETURN NIL)) ((ZEROP (IMOD WAITS 10)) (FLASHWINDOW (TEST.PROMPT-WINDOW WINDOW)) (PLAYTUNE (LIST (CONS (ITIMES 100 (IQUOTIENT WAITS 10)) 10000) (CONS (ITIMES 100 (ADD1 (IQUOTIENT WAITS 10))) 10000) (CONS (ITIMES 100 (IQUOTIENT WAITS 10)) 10000] (GO WAIT-AGAIN))) (RETURN (WINDOWPROP TEST.WINDOW-OF-LAST-SELECTION (QUOTE TEST.CONCEPT-SELECTED]) ) (RPAQ TEST.EXECUTION-SPECS-EVENT (CREATE.EVENT "EXECUTION-SELECTION-ENDED-EVENT")) (RPAQ TEST.GLOBAL-CONCEPT-NODE-SELECTED-EVENT (CREATE.EVENT "CONCEPT-NODE-SELECTED-EVENT")) (RPAQ TEST.CONCEPT-WINDOW-ICON (READBITMAP)) (75 49 "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@" "N@@@@@@@@@@@@@@@@@N@" "NOOOOOOOOOOOOOOOONN@" "NH@@@@@@@@@@@@A@@BN@" "NH@@@@@@@@@@@@AOONN@" "NH@@@@@@@@@@@@A@@BN@" "NH@@@@@@@@@@@@AOONN@" "NOOOOOOOOOOOOOOOONN@" "NH@@@@@@@@@@@@A@@BN@" "NH@@@@GOOOH@@@AOONN@" "NH@@@@D@@@@GN@AOONN@" "NH@AOOL@@@@D@@A@@BN@" "NH@A@@D@@@@D@@AOONN@" "NH@A@@GOOO@GOHAOONN@" "NH@O@@@@@A@D@@A@@BN@" "NH@H@@@@@A@D@@AOONN@" "NH@HOOO@@AOOOHAOONN@" "NH@IH@@@@@@@@DA@@BN@" "NOOO@@@@@@@@@BAOONN@" "NH@IH@GOOOOOOOAOONN@" "NH@HOOL@@@@@@@A@@BN@" "NH@H@@GL@AOOH@AOONN@" "NH@N@@@GOO@@@@AOONN@" "NH@B@@@@@AOO@@A@@BN@" "NH@B@@@L@@@@@@AOONN@" "NH@B@@CH@@@@@@AOONN@" "NH@COON@@@@@@@A@@BN@" "NH@@@@CL@@COL@AOONN@" "NH@@@@@GOON@@@AOONN@" "NH@@@@@@@@COL@A@@BN@" "NH@@@@@@@@@@@@A@@BN@" "NOOOOOOOOOOOOOOOONN@" "NOOOOOOOOOOOOOOOONN@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@") (RPAQ TEST.CONCEPT-WINDOW-ICON-MASK (READBITMAP)) (75 49 "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@") (RPAQ TEST.INSPECTW.ICON (READBITMAP)) (75 75 "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "NGOOOOOOOOOOOOOOOLN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@B@@@@DN@" "ND@@@@@@@@@@B@@@@DN@" "ND@@@@@@@@@@G@@@@DN@" "ND@@@@@@@@@@OL@@@DN@" "ND@@@@@@@@@CO@@@@DN@" "ND@@@@@@@@CMN@@@@DN@" "ND@@@@@@@@FLL@@@@DN@" "ND@@@@@@@@LFD@@@@DN@" "ND@@@@@@@AHCH@@@@DN@" "ND@@@@@@@CLA@@@@@DN@" "ND@@@@@@@GFC@@@@@DN@" "ND@@@@@@@NCF@@@@@DN@" "ND@@@@@@ALAO@@@@@DN@" "ND@@@@@@CHCGH@@@@DN@" "ND@@@@@@O@GCL@@@@DN@" "ND@@@@@AN@NAN@@@@DN@" "ND@@@@@COAL@N@@@@DN@" "ND@@@@@GAKH@G@@@@DN@" "ND@@@@@N@O@@G@@@@DN@" "ND@@@@@L@N@@N@@@@DN@" "ND@@@@@N@N@AL@@@@DN@" "ND@@@@@GAL@CH@@@@DN@" "ND@@@@@CKH@G@@@@@DN@" "ND@@@@LAO@@N@@@@@DN@" "ND@@@@F@N@AL@@@@@DN@" "ND@@@@C@@@CH@@@@@DN@" "ND@@@@AH@@G@@@@@@DN@" "ND@@@@@L@AN@@@@@@DN@" "ND@@@@@GOOOO@@@@@DN@" "ND@@@@@COOOOH@@@@DN@" "ND@@@@@AOOOOL@@@@DN@" "ND@@@@@CH@@@N@@@@DN@" "ND@@@@@GOOOOO@@@@DN@" "ND@@@@@OOOOOOH@@@DN@" "ND@@@@@OOOOOOL@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "ND@@@@@@@@@@@@@@@DN@" "NGOOOOOOOOOOOOOOOLN@" "N@@@@@@@@@@@@@@@@@N@" "N@@@@@@@@@@@@@@@@@N@" "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOOOOON@") (RPAQ TEST.INSPECTW.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 TESTER COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (4299 90662 (SHOULDNT 4309 . 4450) (TEST.ADD-CONCEPT-AND-SUBCONCEPTS-TO-CONCEPT-LIST 4452 . 5209) (TEST.ADD-CONCEPT-COMMAND 5211 . 6209) (TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES 6211 . 6762) (TEST.ADD-ITEM-TO-BACKGROUND-MENU 6764 . 7138) (TEST.ADD-LINK-COMMAND 7140 . 8025) ( TEST.ADD-NEW-FIELD-TO-TEST-RECORD 8027 . 9559) (TEST.ADD-TEST 9561 . 9851) (TEST.ADD-TEST-COMMAND 9853 . 10876) (TEST.ALL-COMBINATIONS 10878 . 11266) (TEST.ATTACH-TESTS-MENU 11268 . 12328) ( TEST.BROWSE-CONCEPT-SPACE-COMMAND 12330 . 13005) (TEST.BROWSE-SUBTREE-COMMAND 13007 . 13701) ( TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME 13703 . 13897) (TEST.CHANGE-DEPTH-COMMAND 13899 . 14587) ( TEST.CLEANUP-AFTER-TEST 14589 . 15247) (TEST.COLLECT-ALL-TESTS 15249 . 15673) ( TEST.COLLECT-SUBCONCEPTS-CLOSURE 15675 . 16206) (TEST.COMPUTE-AVERAGE-TEST-SIZE 16208 . 16833) ( TEST.COPY-SUBTREE-COMMAND 16835 . 18509) (TEST.COPYBUTTONEVENTFN 18511 . 19429) ( TEST.CREATE-CONCEPT-SPACE-GRAPH 19431 . 21198) (TEST.CREATE-CONCEPT-WINDOW-MENU 21200 . 21440) ( TEST.CREATE-GRAPH-NODES 21442 . 22817) (TEST.CREATE-ICON-WINDOW 22819 . 23358) ( TEST.CREATE-INTERRUPT-MENU 23360 . 23694) (TEST.CREATE-NEW-CONCEPT-SPACE 23696 . 24022) ( TEST.CREATE-NEW-TEST 24024 . 24529) (TEST.DELETE-CONCEPT 24531 . 25424) (TEST.DELETE-CONCEPT-COMMAND 25426 . 25976) (TEST.DELETE-LINK-COMMAND 25978 . 26969) (TEST.DELETE-TEST-COMMAND 26971 . 27981) ( TEST.DETACH-TESTS-MENU 27983 . 28411) (TEST.DISPLAY-CONCEPT-GRAPH 28413 . 28701) ( TEST.DISPLAY-CONCEPT-SPACE-BROWSER 28703 . 31541) (TEST.DOCOMMAND 31543 . 33080) (TEST.EDIT-TEST 33082 . 34554) (TEST.EDIT-TEST-COMMAND 34556 . 35383) (TEST.ERRORP 35385 . 35577) (TEST.EVAL-BEFORE-TEST 35579 . 35952) (TEST.EVALUATE-OUTCOME 35954 . 36471) (TEST.EVALUATE-TESTED-EXPR 36473 . 37609) ( TEST.EXECUTE-SELECTED-TESTS-COMMAND 37611 . 37780) (TEST.EXECUTE-TESTS 37782 . 40300) ( TEST.FIND-MENU-ITEM 40302 . 40825) (TEST.GENERATE-COMPARE-FUNCTION 40827 . 41072) (TEST.GENERATE-INPUT 41074 . 41632) (TEST.GET-AND-INCREASE-NEXT-TESTID 41634 . 42194) (TEST.GET-CONCEPT 42196 . 42379) ( TEST.GET-CONCEPT-SPACE 42381 . 42720) (TEST.GET-DEFAULT-FILED-VALUE 42722 . 42922) ( TEST.GET-EXECUTION-SPECS 42924 . 46251) (TEST.GET-FIELD-VALUE 46253 . 46750) (TEST.GET-LOCKING-USERS 46752 . 47748) (TEST.GET-NEXT-AVAILABLE-TESTID 47750 . 48219) (TEST.GET-STRONG-LINK-CLOSURE 48221 . 49021) (TEST.GET-TEST 49023 . 49958) (TEST.GET-TEST-SELECTION 49960 . 51048) ( TEST.HARDCOPY-ALL-TESTS-COMMAND 51050 . 51590) (TEST.HARDCOPY-ONE-TEST 51592 . 52123) ( TEST.HARDCOPY-SELECTED-TESTS-COMMAND 52125 . 52665) (TEST.HARDCOPY-TESTS 52667 . 54291) ( TEST.HARDCOPY-TRACE-FILE 54293 . 56182) (TEST.INIT 56184 . 56563) (TEST.INSPECTW.ICONFN 56565 . 57018) (TEST.INSPECTW.VALUECOMMANDFN 57020 . 57622) (TEST.KILL-PROCESS 57624 . 58390) ( TEST.LEFT-BUTTON-SELECTION 58392 . 58706) (TEST.LOAD-CONCEPT-SPACE 58708 . 59603) ( TEST.LOAD-CONCEPT-SPACE-COMMAND 59605 . 59933) (TEST.LOCAL-EVAL-FORM 59935 . 60623) (TEST.MAKE-BOUND 60625 . 60818) (TEST.MARK-AS-CHANGED 60820 . 61060) (TEST.OBTAIN-DATABASE-WRITE-LOCK 61062 . 64222) ( TEST.OBTAIN-LOCK-COMMAND 64224 . 65663) (TEST.OBTAIN-LOCK-ON-SELECTED-TESTS-COMMAND 65665 . 65847) ( TEST.OPENFILE-OR-WAIT 65849 . 66609) (TEST.PERFORM-TEST 66611 . 69758) (TEST.PERFORM-TIMED-EVALUATION 69760 . 70778) (TEST.POP-UP-CONCEPT-SPACES-MENU 70780 . 71144) (TEST.POP-UP-TESTS-MENU 71146 . 72052) (TEST.PRINT-ON-TRACE-FILE 72054 . 72534) (TEST.PRINT-TEST-OUTCOME 72536 . 73144) ( TEST.PRINT-TRACE-INFO 73146 . 73396) (TEST.PROMPT-WINDOW 73398 . 73578) ( TEST.RELEASE-DATABASE-WRITE-LOCK 73580 . 76494) (TEST.RELEASE-LOCK-COMMAND 76496 . 77247) ( TEST.RELEASE-LOCK-ON-SELECTED-TESTS-COMMAND 77249 . 77433) (TEST.REMOVE-SUBCONCEPT-LINK 77435 . 77678) (TEST.REMOVE-SUPERCONCEPT-LINK 77680 . 78104) (TEST.REPLACE-INSEPCTW-VALUECOMMANDFN 78106 . 78388) ( TEST.SEND-RELEASE-REQUESTS 78390 . 79210) (TEST.SET-DEFAULT-FIELD-VALUE 79212 . 79439) ( TEST.SET-TESTS-BUFFER-SIZE 79441 . 79893) (TEST.SETIFY 79895 . 80159) (TEST.SHADE-TEST 80161 . 80580) (TEST.STORE-CHANGED-TESTS 80582 . 80800) (TEST.STORE-CONCEPT-SPACE 80802 . 81807) ( TEST.STORE-CONCEPT-SPACE-COMMAND 81809 . 82071) (TEST.STORE-TEST 82073 . 82606) ( TEST.SWITCH-DISPLAY-MODE-COMMAND 82608 . 82960) (TEST.TEST-FAULT 82962 . 83925) ( TEST.TEST-NUMBER-TO-FILE-NAME 83927 . 84246) (TEST.TEST-SELECTED-ON-TEST-MENU-FN 84248 . 85057) ( TEST.TEST-SINGLE-TIME 85059 . 87171) (TEST.TOPOLOGICAL-ORDER 87173 . 88283) (TEST.UNION-LIST 88285 . 88503) (TEST.UNMARK-AS-CHANGED 88505 . 88784) (TEST.UPDATE-COMMAND 88786 . 88994) ( TEST.UPDATE-EXECUTION-SPEC 88996 . 89352) (TEST.WAIT-FOR-SELECTION 89354 . 90660))))) STOP \ No newline at end of file diff --git a/internal/test/Tools/TESTER.LCOM b/internal/test/Tools/TESTER.LCOM new file mode 100644 index 00000000..e69de29b diff --git a/internal/test/Tools/TESTER.TEDIT b/internal/test/Tools/TESTER.TEDIT new file mode 100644 index 00000000..44d6cc29 --- /dev/null +++ b/internal/test/Tools/TESTER.TEDIT @@ -0,0 +1,85 @@ +THE INTERLISP-D TESTING SYSTEM +The Interlisp-D testing system is an integrated system built for creating, managing and using a large set of programmed tests for testing the correctness and the performance of the Interlisp-D programming environment. +The system is consisted of three parts : The test driver, the data base management system, and a graphic control tool. In addition, there are various tools for helping the test builders in the process of creating new tests. +All parts of the system assumes the structure of a TEST which is a data type consists of several fields, of which the most important are the expression which has to be evaluated, and a predicate which takes the results of this evaluation and determines whether the test was a success or a failure (i.e. whether the actual result is the same as the expected result). +The test driver is in principal a function which gets an object of type TEST, performs the test, and return either success or failure plus some additional information. It includes facilities for monitoring the test execution, tracing and recording the testing process to enable reproducing tests, Remote Eval protocols to enable performing tests with two machines and more. +The data base management system works in two levels. In the low level, the "test cluster" level, the system manages and organizes the tests in the file system, enable retrieving tests through a cashing system, and allows concurrent access to test files using a simple locking scheme. +In the high level, the system enables each user to manipulate the database using its own VIEW of the system. This view is implemented through the CONCEPT SPACE which is a directed acyclic graph that will usually reflect the logic structure of the system as seen by the user. +The graphic control tool displays a concept space as a graph and allows the user to perform most of the Test system operations by selecting nodes from the graph. +The tools for building and manipulating tests include test inspector (and editor), a random generator which can generate random specified Lisp objects, Indirect reference to other tests in TEST fields for shrinking the space of the tests themselves and avoiding redundant work when creating tests which share some of their fields, and more . +In the next sections the different parts of the system will be described as well as the interaction between them. + The TEST data type +The TEST is the data type of test objects. Its structure reflects the various properties that tests have. It includes the following fields: +TestID : The tests are identified by an integer. +Input : This field contains an expression that, when evaluated, will generate the list of arguments on which the tested expression will be applied. There are several tools which help in creating this entry. The random generator helps in generating random objects with specified restrictions. The SYSTEMATIC operation helps in generating systematically all the combinations over finite ranges. +Expression: It can contain a function name, a lambda expression or arbitrary sexpression. In the first two cases it will be applied on the input. +Success Predicate: This field contains a lambda expression with two arguments - the ACTUAL input for the test, and the result of the evaluation. It returns one of the two atoms: Success or Failure. When performing tests with random input, some tricks may have to be used as demonstrated in the examples in the end. +Timeout :This is a lambda expression which gets the ACTUAL input as an argument, and produces an upper limit to the estimated time of evaluation. +EvalBefore and EvalAfter: expressions to be evaluated before and after the test execution. usually, before the test we may want to set the appropriate environment for the test (like loading certain files), and after the test we may want to clean up the environment (like deleting files which the test created). +Pretests: Contains a list of links to other tests. These links may influence the order of an execution of a set of tests. Currently there are two types of links. A STRONG link to other test means that whenever the current test is going to be executed, the pretest must be executed first. An example for such pretest may be tests for the tests themselves. If a test generates a few thousands combinations of some arguments, it may be useful to test first if the test itself works correctly by executing a simplified test which works only on one set of arguments, and check that the test outcome is reasonable. A WEAK link to other test means that whenever a SET of tests is being executed, and both the test and pretest are in this set, the pretest will be executed before the test (thus it defines a partial order on any set of tests). This link may be used in cases where there is logical order on the execution of tests - for example, it is reasonable to test opening a file before testing writing to a file. +The Test Driver +The test driver accept a test as its input and returns either success or failure. It will evaluate the input and the tested expression itself on a remote machine if requested, or on the local machine otherwise. All the process of the testing is recorded on a trace file, such that as much information as possible will be available if needed. +The driver evaluates the EVALBEFORE form, evaluates the input expression to generate the input for the tested expression, applies the tested expression on the generated input, applies the success predicate on the result and the generated input, and evaluates the EVALAFTER form. After some of the above stages the appropriate information is written on the trace file. The most important one is the input generated, especially in cases of random input. +All the evaluation done by the driver uses the Interlisp-D ERRORSET command, thus allowing evaluation that will not break under error condition. The error type may be used by the success predicate to determine if the result is a success or a failure. Thus one test for many arithmetic functions can be to supply them with non numeric arguments and to check that the error reported will the right one. +The evaluation of the tested expression is done as a separated process, such that the driver will be able to try to interrupt it in case where the time of execution is larger then the value of TIMEOUT field of the test. This interrupt will work only if the test execution process will release voluntarily the cpu (when waiting on I/O for example) since Interlisp-D uses non preemptive scheme for process scheduling. +Remote evaluation will not benefit us much in this type of problems. If the remote machine is in infinite loop for example, it will not listen to interrupt attempts as well. The advantages of using remote machine are two: If a long sequence of tests are executed, and the machine "freezes", a remote test will freeze the remote machine and the local machine will be able to call for help and resume operation (as soon as the remote machine does not respond for more then some estimated limit of time, the local machine sends messages to a preset distribution list and asking for human help). A second benefit of remote evaluation is when we need to evaluate the tested expression in a different environment than the Testing system resides. We will want the testing system to work in considerably nvironment (software release), while we are testing an experimental different environment. + +The data base management system: the "test cluster" level. +The user can retrieve a test by calling the GetTest function. The low level of the dbms is responsible for performing the appropriate operations to retrieve the requested test. If the test is not already loaded it will be loaded from its file. There is a limit on the number of the tests that are loaded, and if these number is exceeded a replacement will take place and a test will be removed. The replacement policy is LRU (least recently used) and is implemented by moving each test being referenced to the front of the list of the loaded tests. Thus the last test in the list will be the one to be removed. The limit on the number of loaded tests is dynamically modified according to the amount of the available memory. +The Interlisp-D testing system is designed to work with several users uses it concurrently. There are no problems if the users were only retrieving tests from the data base. Problems may occur if two users modify the same part of the data base in the same time. +For such cases a locking scheme was integrated into the system. There is a special designated file which is the "gate" for the data base. Users can obtain write LOCKS on tests. The file contains the list of users with their locked tests. The basic locking function is ObtainDatabaseWriteLock(testnumber) which checks the LOCK file, and registers the tests that are not already locked . The user has the option of automatically generated messages that will be sent to the locking users, inform them that somebody is waiting for their locked test s and request them to release them as soon as they are not needed. +Thus, either automatically or manually, whenever a user edits a test, he will first obtain LOCK on tests. The locking scheme will work only if the users will follow the rules and will not try to access tests not through the testing system. +The basic operation - ObtainDatabaseWriteLock is "atomic" in the sense that the LOCK file is opened for read and write throughout the execution of this procedure, and thus no other user will be able to open it. The time interval in which the file is opened is very short. +Another problem that may arise from concurrent access to the data base is test numbering. As mentioned above, each test has a unique integer as an ID. Thus there is a file which contains the last ID issued, and the procedures for creating new tests will access and update this file. + The "Concept Space" level. +What is the "thing" which is being tested by the test? it may be a specific low level system function, a library package, or a new representation scheme for integers. It is hard to find a common class to which all these entities belong. Thus the testing system assumes that it is some CONCEPT of the Interlisp-D system that is being tested. +While it is true that when a test is CREATED, its creator intent to test a specific concept, the test itself is not necessarily a test only for this concept. A test that was built for testing the READ function, may actually test also the NS communication protocols, the OPENFILE function etc. +For this reason the tested concept is not considered to be a part of the test itself. There is a separated knowledge strpace" which is the way that the user views the test cluster. A concept space is an acyclic directed graph of CONCEPTS. Each node of the graph is of type CONCEPT which has four fields: The concept name, the tests that tests this concept, the subconcepts and the superconcepts. +The main purpose of the concept space is to enable the user to group tests in a logical way and to perform operations on these sets of tests. The semantic of a concept node is : "the tests which tests this concept are the tests of the concept itself plus the tests that tests its subconcepts (recursively)". +Such a definition allows us to build concept spaces which view the tests from different points of view. We may have a concept named "Arithmetic system" with subconcepts "Integer arithmetic", "Flote arithmetic"and "Arithmetic functions". The "Arithmetic functions" will have as subconcepts, the concepts "IPLUS", "FPLUS", "PLUS" etc. "IPLUS" is also a subconcept of "Integer arithmetic", and "FPLUS" of "Float arithmetic". Thus, if a new representation for the integers was introduced to the system, we will test the "Integer Arithmetic" concept, while in other cases we may want to test the "Arithmetic Functions". +From the above example and from the more detailed example at the end, we can conclude that the organization of the test system should be very flexible, since there can be many parallel views into the same part of the system. We can also see why a tree structure would not be sufficient as a representation scheme. The Testing system supports the the co-existence of several concept spaces, and thus each user can build and use his own concept space(s) to reflect his view of the system. +THE CONCEPT SPACE BROWSER +Most of the operations of the Interlisp-D testing system are done through the "Concept Space Browser". The browser is a graphic tool which is applied on a concept space. +It has a few types of operations. Any operation that require a concept as an argument will get it by a selection from the displayed graph. +The first type of operations are operations for modifications of the concept space itself. There are commands to add new concept, to delete a concept, to ad and delete a link and to add and delete a test to a concept. +Second type of operations are data base operations. The user can edit a test selected from specific concept, can hardcopy all (or part of) the tests of a selected concept, and can request to lock all (or part of) the tests of a concept. +A third type are display op can be specified, a browser of a subgraph can be created, and the tests can be dre are commands to execute all (or part of) the tests of a certain concept, with different modes of execution . +The browser also allows to copy subgraphs between two displayed concept spaces, and to get all the tests of a node by a copy selection so that functions that are not available in the browser can use the concept space as well. + .—˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üřŔ*ŞŞŻęŞŞŞŞŞŤęŞŞŞŞŞŤţŞŞŞ>˙˙đ˙˙˙˙˙óă˙˙ř€üř1™€UUU]UUUUUUWuUUUUUU]UUTc˙˙ç?˙˙˙˙˙ăÉ˙˙ř€üř`ŰUUU]UUUUUUWuUUUUUU]UUTc˙˙ç?˙˙˙˙˙ƒœ˙˙ř€üř`Ţ*ŞŞżŞŞŞŞŞŞŽŞŞŞŞŞŞŞşŞŞŞc˙˙ç?˙˙˙˙˙óœ˙˙ř€üř`Ü6*ŞŞşęŞŞŞŞŞŻęŞŞŞŞŞŞşŞŞŞ>˙˙ç?˙˙˙˙˙óœ˙˙ř€üř`ŢfUUU]ŐUUUUUWuUUUUUUuUUTc˙˙đ?˙˙˙˙˙óœ˙˙ř€üř`ŰfUUUUŐUUUUUWuUUUUUUuUUTc˙˙˙?˙˙˙˙˙óœ˙˙ř€üř`ـ*ŞŞşęŞŞŞŞŞŽşŞŞŞŞŞŞęŞŞŞc˙˙ç?˙˙˙˙˙óœ˙˙ř€üř1˜Ŕ*ŞŞşęŞŞŞŞŞŽşŞŞŞŞŞŞęŞŞŞc˙˙ć˙˙˙˙˙óÉ˙˙ř€üř`UUU_ŐUUUUUWőUUUUUUŐUUT>˙˙đ˙˙˙˙˙˙óă˙˙ř€üřUUUUUUUUUUUUUUUUUUUUUT˙˙˙˙˙˙˙˙˙˙˙˙˙řüř*ŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞ˙˙˙˙˙˙˙˙˙˙˙˙˙řüř*ŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞ˙˙˙˙˙˙˙˙˙˙˙˙˙řüř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř€Ăŕ0ř˙˙ƒă˙˙˙˙˙ŕđ˙˙˙˙ř?Ÿ˙˙€đü|˙˙ŕŕ?˙˙üřŔĆ0qŒ˙˙9É˙˙˙˙˙Îg?˙˙˙˙óŸ˙˙€ŔĆ3˙˙Î?˙˙üřŔĆ0ńŒ˙˙9œ˙˙˙˙˙Îg?˙˙˙˙óž˙˙€ŔĆc˙˙Î~˙˙üřŔŔ01Œ˙˙ůœ˙˙˙˙˙ţ?˙˙˙˙˙žŸ˙˙€ř`˙˙ţ|˙˙˙üř€Ŕŕ0ř˙˙óœ˙˙˙˙˙üü˙˙˙˙˙<Ÿ˙˙€1Œ ~˙˙üü˙˙˙üřŔ01Œ˙˙çœ˙˙˙˙˙ů˙?˙˙˙˙ţyŸ˙˙€aŒc˙˙ůů˙˙˙üřŔ01Œ˙˙Ϝ˙˙˙˙˙ó˙?˙˙˙˙üůŸ˙˙€Ŕ 0c˙˙óů˙˙˙üř Ć01Œ˙˙Ÿœ˙˙˙˙˙çç?˙˙˙˙ůř˙˙€Œ`c˙˙çó˙˙˙üřĆ01Œ˙˙?É˙˙˙˙˙Ďç?˙˙˙˙ó˙Ÿ˙˙€ŒŔc˙˙Ďó˙˙˙üřŔĂŕ0ř˙˙ă˙˙˙˙˙Ŕp˙˙˙˙đŸ˙˙€řřţ>˙˙Ŕs˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üđ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<óŔ Ŕ<ň @@<ň#‹XŘâĂ@8đÄM–X@€<ň$Lˆ"d¨#$Ŕ"D@$J™"d@€<óÇČ"@¨"$@>0@$J‘>@<ň"@¨"$@ @$J‘ @<ňH"@¨"$Ŕ "DH$ʙ"@@<ňˆ@¨"#@80#J–@@<đ@!<đ€@."—=g<đ@!1"˜‘¨‘<đ@!!‘Ÿ<đ@!!‘<đ!!1‘˜‘‘<đ.— +<đ <đ 0<đ<đ<đ<đ<đ<đ<đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý˝ ;î8p˙ěp`ß˙˙˙÷ń˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýŢýŰíۡ~íŰ˝ďÎ~ötçœcîǞy˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý­Ţ;î{ˇ>źýáÎ~ý˛ŰmˇóŰmś˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýľŢýŰď¸wgß}ďŐ~ýśß +ˇýۍđ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýšŢýŰíŰ÷~ď{˝ďŐ~őśŰ}ˇîŰmˇ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý˝Ţ +Ř.;đ˙|}ŕŰvçŒsńÇx˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ý˙˙ß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ý˙˙ß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<đ<đ <đ <đ‡‹‡.x<đ##HLH‘1 <đ"!!HH! <đ>!!HH! <đA##HHH‘1 <đA‡ˆG.<đ <đ <đ<đ<đ<đ<đ<đ<đ<đ<đ<đé Ŕń<đ’ (‰<đČb (ń<đňcĆD‰<đţ’|‰<đž|xůŕxŸ"A>|ţ ‚‰<đ˜ˆ@„D„"c €ţ<đ”ˆx€ńŕx„>c<ţ<đ’ˆ@œ"D„"U ><đ‘ˆ@Œ>D„"U ťř<đˆ|tůAD„"I>đ<đ€ŔÄx…<đ +ŕ?€$„Ĺ<đ@ XĀĽ|@<đ@&ň$œ•¨B@<đ€€$Œ¨AG<ŕ8x¸pâç€<đ`Ät„âHA"H‘D„ĉ<đƒA>O‘đ@„„ň<đ@†A H@„„<đ@A€B"H‘D„„‰<đ 0`|G ŕ8x„pâá€<đ <đú‚‡‰ň$çČđP<đ ‚EDHB&2 H<đ@ňEGˆCć3Á H€Ŕ<đ€‚H„2$HB%R $`0<đ€‚O„äHB%R €" <đƒçDHB$“áđ`<đ 8Ŕ<đ@€0<đ€€€Ŕ <đ`@ <đŘ Ŕ<đ & 0ä‚|N<đ ‚ „Ć@Ž<đ@ a€„ĆxN<đ€@@„Ş@<đ€†„ „Ş@Ž<đa‚„’|N<đâ<đ Y<đG<đĄ€`<đ ``p<đ Ŕ0XHÄ€<đA&„$"€<đB€$<đ„ `“Ä—<đČ"##˜’<đ$Î"!!”<đ >!!š<đ@`A##‘<đ€X A€<đ€†Ŕ<đá€<đ$€R`x‚#Ž<đH€LD‚$N<đ°@*D‚#<đŔ@ x‚ Ž<đ€ @@‚$N<đ'ȐOŸ#Ă (° @ůÎ<đ!˜Č$&K0<đ!˜Ď$„Ŕ<đH‘!•H$ <đ‘!•H$#  Ŕ<đQ!’O„#Ŕŕ! <đ Ŕŕ|OŽ<đ€˜Č<đŔ"@˜Ď<đ0F •H<đ™` •H<đ€!€ŕ’OŽ<đ`F€<đˆ€č<đ0O<đ ŕ Ŕđ<đ  <đ@!â|‰ůň<˘ByňO‘đI @<đ‰$řB<BxB!!@ <đˆx A##D‰<đHA8pŔ<đD<đ$<đ <đ@ <đ@â#ÇÎ<đ€$!<đ€’$!<đ’’$!<đR$!<đáĂÁ<đ<đ<đ<đ<đ<đ#ăĂĂώHO<đ $B$$("LP€<ń!|ůâăŔx #Ä$ JP<ń1  D@˙Č ‚â$$IS€<ń)ńâ D@˙ţ$B$$("Hр<ń%#ĆD˙ࣂ#ĂώHN€<ń# Dţ<ń!ůčâxQđ<đl<đbř|@@<đ1€ŔB@@<đ(@<OžAG<ŕó‡<<đ(0ŕP˜Č’A"H‘DH<đ˜Č’A>O‘đGÇ<đČ•OA HD<đ P•HB"H‘DH<đ ŔHď‘|G ŕ3‡ <đ <đ€<đ€<đ@˙˙˙˙˙˙˙˙˙˙Î<đ Ŕ<đ <đŠBđńN>|‚"źN<đŠb‰ H‘@Ć"˜˘BDALPˆN<đRR‰Ş xĆT”˘B*äJPN<đ€ĹRJ‰Ş`‚@Ş˙˙˙˙ńT’˘B*™IPN<đ„`ü"F‰DB@ވ‘˘BHЈN<đ‚ţ"BđđD‚|’ˆź<ˆON<đ‚ Lj‚?<đA’$HDŔ<đ@€ˆ‘„H(ŕ<đ@€HGˆ"đ˙˙˙˙˙˙˙˙˙˙Î<đ @’$>€˙˙˙˙˙˙˙˙˙˙˙ţ<đ @ÄÁ~@<đ ř@<đŕž!|pOž!|pD„óäx„â<đ€!1ˆH!1ˆDĹ„„Ĺ<đ~!)`O!)`DĽ„„¤Â<đČ!%˙˙˙˙˙Č!%D•„„”"<đ!#ˆH!#ˆD„„ <đ!pH!p8„đ„x„â$<đ@@<đ@@/pç€<đ€@~#$‰<đ€˙˙˙˙˙˙˙˙˙˙˙ţ@!$řâ<đ@@!$€<đ@@#$‰<đ „ŕ>HO#pá€<đĹ LP€<đ€¤Ŕ<JP<đ€”# IS€<đ€ Hр<đ@`„ŕ ŸHN€<đ@€<đ <đ <đ `<đ€€<đ@đâ } ž<đ@ ‰@A ˜Ą<đ 0ˆÂ€y ” <đ Ŕ ˆ#FA ’§<đđ‰ A ‘Ł<đ đâA><đ0đ<đ@<đ€x<đ€<đ8<đ ÄO‚DB <đ@ ‚<8!Á<đŸAxA#‹ˆâ <đ@ŔA$LI źđ@8pA#ˆHq@<đ €€A HI‘@ <đ xxB$LI€<đ €|#‹ˆč€<đđ‚<Ń!<ů!8<$'€<đ‚B1B!!1DŔ‘&(€<đđ„B‘)@!!)0<ž% €UUUUUUUUUUUU|đ ˆBd%@!!%˙˙˙˙˙Ď$§ŞŞŞŞŞŞŞŞŞŞŞŞźđˆB#B!!#D<$hŞŞŞŞŞŞŞŞŞŞŞŞźđ<!|qńŔ8ŕ<đ€ř@ˆB pE<đpđx`A€E<đ @@G˙˙˙˙ţ„E<đ€@ˆB E<đ`|pAŔ8ŕ<đ<đ<đŔ<đ8<đ<đ€<…áâ!|đCăǀ<đp"(Ő1@ˆ „$@A@<đ <(Ľ)xđ „'€A@ <đ"D•Š“%@‰„$@AYŃĂĹÄCÎó…<đ"|¨#@‰đ„$@"j2$&$A"DJźđ"‚…áâHŸ!|ŠƒÄ@AB$"C…<đA2B$"@J<đA"B2$&!"DD<đAAŃĂĹÁÎ3ˆ<đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üđ<đ<đ <đ <đ €xX Ŕ<<đ @ €h + <đ@ €@ <đ@ @ <đ@ €@ <đ@@čŔ <đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üőUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU_˙˙˙˙˙˙˙˙ýUU|˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü +Test creation tools and misc tools +There are several tools that were created to help the tests builders in their task. +In each field of a test the user can write (& n) when n is a test number. This tells the system that to retrieve the value for this field it should refer to the same field in test n. This was done since many tests share values for some of their fields. +The test inspector is built on the top of the Interlisp-D inspector. The user can inspect and modify the various fields of a test. In addition he can call the inspector on indirect referenced tests. +There are functions which keep tracks of changes done to tests, and functions which stores modified tests. +The Random Generator is a very important tool for creating a test. It has many entries for different Lisp objects which he can generate randomly. These set of possible entries will grow constantly as test builders will need more types of random objects. +The random generator function gets as an argument an object type and a list of modifiers. The test builder can specify in the input field of a test a call like (GenerateRandom 'LARGE-INTEGER), or (GenerateRandom 'WINDOW) or (GenerateRandom '(LIST-OF-ITEMS WINDOW 50 100)) to get a random list of length between 50 and 100 of windows. +From the experiments done with the Testing system it was clear that random tests are an important part of any testing and can discover bugs that would be hard to find otherwise. +Another tool is the SYSTEMATIC input generator. Many times we want to test a function if it works right with all the possible combinations of values of its arguments, or to find out whether an library package works with all possible settings for its flags. For such cases the test builder can specify in the input field that he wants a systematic test, and supply the expressions that produces the ranges of values to combine. + + + + TEST EXAMPLES: +EXAMPLE 1 +Ř ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙đđóüĂŕđ`€Ć0đ`€Ć0đ`řóŕ˜ßsńóŕĆ0đa™€Řٛ`ĂŕđaÁ€ŘٛĆ0đaüń€ŘٛűĆ0đa€9€ŘٛĆ0đa™€ŘٛĆ0đ`řđŕĎٛńóĂŕđđđđđđóçĎßż<üđGó6l0f1˜Bó6l0p1ŔfBó6o†><0đeBóçĚ00xBól00Âól0f1˜dÂóoĆ?|1đdGđđđđó÷矟8î;÷đŕ€áŔ@ÀđĆ Ć1ą¸î;˜ŔT  @ @€đĆ1ą˝ď{˜ŔÄ8ŇxpŕˆŽ<8ŘăÇ"p @°áŇxŕ@€đÇdž01˝ď{ćŘŔÄT&H™ ‰H‘D¨ˆ‚" @"ČFH€" @€đĆĆ01ˇmŰŘŔsäO řŔŒ|¨ńˆ"x @>ˆđD" đ@€đĆĆ1ąˇmŰxŔH" € …@Šˆˆ @ ‰D" @€đĆ Ć1ąˇmŰxŔÄ$H"$‰EDŠ ˆ‚ˆ @‘"ÉD€" @€đÇď†2l›ö8ŔÂáÄGpŕ‚ 8¨đŔ‡x @°đD đ@€đ€đ 0€đđđ€€ đ€đŇ8°áÇ°áĽˆ›đH€DÉ €‚Č"fH•"đO€0‰ň‡‚ˆ"$H•đH‰ˆ‚ˆ"$H•đ$H€DÉ ˆ‚Č"dI•"đÄG8°áŔ‡‚°!¤F•đ€ đ€Ŕđđ@đ€@>8řƒ‡"DăÇÇ@$N<8 ‚đ€ D A™"l$„@’&É"Dđ,8hŀ D A™"l$„@’&É"DâŔ8đD2D˜F@<0 Á"TÂ'ˆ@R%O<0# Dđ |ˆD@  ! •"Tř#Ä"@ůR%H(" |đ„ @ˆD@ D !“"T„>@2%H$D" @đD‘ D˜D@ D B!“"T„"@2%H"D" Dđƒƒ 8hD@>8 CÇDâÇ"|ÄO"8" 8đ€đ@đđ đçÇđăäHŸ>8p'Çđ„„(ˆ@„Mˆ!"đ„„(ˆ@„Mˆ!"đ‡†(đ@‡Ęž€!đ„>D @„Jň!đ„„|@„Jˆ!"đ„„Dˆ@„Jˆ!"đ‡ÇDˆŕ„HŸ8pÁđđ đđđqâGxqóçĎ"8řđ!H€‚D!2D€đŋ"!H€Xầ8řřŇD!2D€đ&L‚"!F"dƒ$J€ ͘H€D!ăǏ*@đđäH‚"!âA"D‚'ʀ<͘O€D! *@€đ$H‚!H€"D‚$ €l͘HD! &D€đ&L‚!H€"D’$J€l͘$H€D!&D€đĺ‹qă‡Db#Š€>ĚřÄGxqȟ"8řđđ0đđđpđA€đpăe‡ńaŔ DáŔ€đ™&‰Ś@™"A’ ‘"D‚ €đ‘"¤G>AŕD€€đ‘"¤H AD€@€đ‘&‰ŚH"I "L’ €đ‘p⥇1Ŕ4aÁđđđđpŕóöC‡ďßžA„N!ăă€<8p óăĆ3AFÉ!@ "Dˆ ó0ăĆ3 AFÉA@ "Dˆ óă1łgĂ3 AEOAăĂ <@` ó!łf>A%H‘"AB€(\ óáóć3AĺH‘>A"@$Dˆ óĂ63 A%H‘"A@"Dˆ óđĂö6ł Aň$O"!ă€"8p đ@ đpŕđđ óöCĎߟ>~@€óăl1ł`A@ó0ăl1ł`@óă1łϟ1ł|€€ ó!łl1ž`P óáól1ł`‚ ‚óĂl1ł`‚ óđĂ÷ĎŘ3~AĐđ@đ đđóöăż>c~ÄđĆă°cc„đĆ÷°cc„đĆ÷žccP„đĆÝ°ccP„đĆÝ°cc0„đĆÝ°cc0„đĆÉż>>ÇŔđđđđóöăż<@đĆă°fŔđĆ÷°p@đĆ÷ž<@đĆÝ°@đĆÝ°@đĆÝ°f@đĆÉż|đđđđđŕ ńć3ăçç>|ýůŸ?~‚œ<CÇÇxpŕ€ó6666 ŮłfÁąŽ `‚’"(B$€D‰€ó†6663fÁąŽ `‚’"(‚$€D‰@ńć6Ǐ3fů° |‚Šž"(ƒÇ†x€Ŕ@đö6Çž|Á° `‚J‘"D‚„"P¸ @đ6666Á°fÁąŸ `‚ʑ"|‚D€>H‰@ó6666 Ů°fÁąąŒ`‚J‘"D‚$€"D‰@óăăăçďŸ0fýůŸ1Œ~ƒäHž|đƒˆ<|đ„H‘@A"@đó<đH‘@A"@đ›e˜H‘xáAD!ńÀ>8řƒ‡"DăÇÇ@$N<8óyłcB$H„ lP@„@ D A™"l$„@’&É"Dóyłc‚"ˆ„ lP@„@ D A™"l$„@’&É"Dómłc‚†@2%H$Dóg°c‚!„ Tˆ@„@ D B!“"T„"@2%H"Dóc°>AÁ>DˆAÀ>8 CÇDâÇ"|ÄO"8đ@đ đđ@đ>8řƒ‡"DăÇÇ@$N<8 đ D A™"l$„@’&É"D đ D A™"l$„@’&É"Dđ<0 Á"TÂ'ˆ@R%O<0đ  ! •"Tř#Ä"@ůR%H(đ D !“"T„>@2%H$Dđ D B!“"T„"@2%H"Dđ>8 CÇDâÇ"|ÄO"8 đ đ@đđóöCěß>qâGóă Ůł!H€ó0㙳 !H€óă1łĂł !Fó!ł>!âAóáó˜3!H€óĂ Ř3 !H€óđĂ÷ěŘ3 qă‡đđđđó÷矷ŕđĆ Ć60đĆ60ĘđÇdž60ÂđĆĆ60đĆĆ60đĆ Ć60ÂđÇď†7ŕώđđđđńÄ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ +EXAMPLE 2 +Űœ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕřŕůţ€`0ŕř0Ŕ€ŕpŕř0Ŕ€ŕđŕř0|yđĚošřůđ`°ŕř0ĆĚŔ ll͍°a°ŕř0ĆŕŔ ll͍€c0ŕř0ţxŔ ll͍ý€c0ŕř0ŔŔ ll͍€cřŕř0ĆĚŔ ll͍€`0ŕř0|xp gěÍřů€`0ŕřŕřŕřŕřŕřŕř@€ŕůóçďߞ~xŸDAÁŕů›63́HÂ!ŕů›68ŕ1 PB`ŕů›7Ăx1 žpB ŕůóć< "HB ŕůƒ6 >HC ŕůƒ63Ě1"DB ŕůƒ7ăžř0"DńÁŕřŕř@€ŕřŕř€ŕůűóĎϏœwűřp@€@ŕřccŘÜwƒĚ` €*ˆ€ŕřcŘŢ÷˝ƒĚ`b‰aÏpË +lņŽ"aË,8pǀpŕřcăĂŢ÷˝ól`b €*’ D" L“"TFI‘"’$L2DˆB"ŕřcăŰśíƒl`ăÄxȑ"TPDH‘*ă"|`B"xŕřccŘŰśíƒ<`‰DˆH‘"TPDH‘*ˆ‘"@B"ˆŕřccŘŰśíƒ<`b‰$D‘"ˆH“"T DI‘0$H‘2DˆB@ "ˆŕřc÷Ï™6Mű`aqĂĂxȍT DFŽȏ,8pA€xŕř ŕř€ ŕřŕřŕřŔ ŕř ŕřáĂHŽ,8pǀXhă` 8qaŔ||aÉXhŕ‡ŕř$ȑ2Dˆ"d™  ‘&‰’ f̐$J"d™€ŕřĂäHŸ"@ř"D‰ "‰€fĚä "@ˆŔ€ŕř"H"@€""D‰ "‰@6fĚ$ "@ˆ €ŕř$ɑ"Dˆ""D™ &‰#6fĚ’$I "@™H€ŕřáĂFŽ"8pÂDhâ qÁf|a㈊@hŕ‡ŕř@ŕř@ŕřŕřŕř @@ŕř‚@"@AŕřâÀ,8hâÁXqaŔ"XpâC€<ńaŔ,8q`ŕřƒ$@2˜# A"d ’  d‰„@A’ ‘2D‰ŕř‚'Ŕ ˆ"#ÁDyŕ DůAŕ |ůŕř‚$ ˆ"$AD‰"D€€A @ŕř’$@ ˜"$A"D‰’ "D‰D@I ‘ D‰ŕřb#€ h"#ÁDyaŔDpâ#€1Ŕ 8qŕřŕřpŕřŕřŕř@€€Ŕŕ@ŕř€Ŕ€ŕřaǍŽ,8ăŔ°áŁ‹,4ÇÇŔ,4ăŔXqáËŕřB 2D"É`Œ‚2LflŔ2L™"d€DL‘ŕřB "0ń>‰ň ˆ‚"DćlŔ"D‘>@x€DHŒŕřB ‘" ‰ ˆ‚"DflŔ"D‘ @ˆ€DH‚ŕřBJ‘2D ‘"É`ˆ‚"LflŔ"L™"@ˆDH‘ŕř`AŠ,8đŔ°á ˆ‚"4ögŔ"4á@x`CˆŽŕř ŕř Ŕ8ŕřŕřŕřŕ€ŕř €ŕřâÀDp @ŕř$@&D @ŕřňŔ"Dx @ŕř"Dˆ @ŕř@&Lˆ @ŕřň€4x €ŕř€ŕřŕřŕř8@ŕůű !€C÷ďß €B'ńńŔ8 ŕůƒ q€ăŒ€ €ŁdˆŠ‰ "D ŕů˜q€ăŒ€ €ŁdˆŠ ‰ "Dŕůń˜Ůłá™€ €˘§ˆŠ ńဠ0ŕů€ŮłŒ ¤H‘ Ą@”.ŕů€đůóŒ€ ň¤HŸ ‘ ’"Dŕů€aƒŒ€ ¤H‘ ‰ ‘"DŕůřaűŮ€ ů'‰ńŔ‘8 ŕř  ŕř8@ŕřŕř8ŕř8€áÇȀ8!ŕŕřD$€DQˆ‘"ŕřD$ €DQˆ‘"ŕř@‡Š€@Qŕŕř@D €@‰@JŕřD$Dů É"ŕřD$D‰H‘"ŕř8řáÇĹ8‰HŽŕřŕř8ŕřŕřŕůű !ƒçďϟ?ˆâŕůƒ qƒ6 Ů°ČBŕů˜qƒ6 Ů° ČBŕůń˜ŮƒçϘٞ ¨Bŕů€Ůƒ6 ß0¨Bŕů€đůƒ6 Ů°˜Bŕů€aƒ6 Ů° ˜Bŕůřaűç왿 ˆăŕŕřŕřŕřŕřpŕůűqߟ1żA„N CÇŕřcqŘ1ąŒAFÉ ˘$H„ŕřc{Ř1ąŒ AFÉ@˘$H‚ŕřc{ß1ąŒ AEO@ŁÄŕřcnŘ1ąŒA%H‘"A…ÁŕřcnŘ1ąŒAĺH‘>AňDH‚ŕřcnŘ1ąŒ A%H‘"A$H‚ŕřcdߟ Aň$O"!#‡ŕř@ ŕřpŕřŕřpŕř8ŕř"Dŕř &Lŕř*Tŕř*Tŕř2dŕř"DŕřŽ8ŕřŕřpŕřŕřŕůűqߞ ŕřcqŘ3`ŕřc{Ř8  ŕřc{ß ŕřcnŘ ŕřcnŘ ŕřcnŘ3 ŕřcdßž řŕřŕřŕřŕřp€ŕřóńóóǟ>~üςżA„N!ăă€<8p@ŕů›lŮł`ĆŘÇ0AFÉ!@ "Dˆ@ŕůĂł`ĆŘÇ0 AFÉA@ "Dˆ ŕřóăǙł|ĆŘ +†> AEOAăĂ <@` ŕř{ăß>`ĆŘ +†0A%H‘"AB€(\ ŕř`Ř3`ĆŘφ0AĺH‘>A"@$Dˆ ŕů›lŘ3`ĆŘŘĆ0 A%H‘"A@"Dˆ ŕůńńńó÷Ϙ3~üϘĆ? Aň$O"!ă€"8p@ŕř@ @ŕřp€ŕřŕř`ŕřc€|řăŕ"x!ăŕ>D!áŔ ŕ‡xpŕŕř€‘6DQ lQ "!DH€D‰ŕřo€€‘6DQ lQ "ADH€D‰@€ŕřfđŔ€*DQăŔTQ€ADOx€Ŕ@€ŕřf€ €*x‰BȄT‰ŕ@ A$J"P¸ @€ŕřf€‘*@ů"„Tů "AäI>H‰@€ŕřf‘*@‰„T‰ "A$H€"D‰@€ŕřfřŕ"@‰ŕD‰ŔŸ â'ˆ€"Dpŕŕř ŕřŕřŕřŕř qÇπDpăă‡ŕřŒ‰!"D‰H„ŕřď> ‰!"D‰H‚ŕřŒŮł ‰!DĂŕřŒßł ‰!DŕřŒŘ3 ‰!"D‰H‚ŕřŒŮł ‰!"D‰H‚ŕřěĎ3páÁ€8păă‡ŕř ŕřŕřŕř 8ŕř€AÄG>řAÄž>ŕř€B$H„ € „‘ ŕřyžx‚$H„ € „‘ ŕřͲ̂$H„<đ „ž<ŕřý¸ü‚$H„ „” ŕřÁŽŔ‚$H„ đ„’ ŕřͦ̂$H„ „‘ ŕřyźxAÇ>ÇÇ>ŕř@€ŕř `8ŕřŕřpŕů¸ß1żAπ|řăŕ"|đCçŔDđâ "8ůđG<8ˆ@€ŕůźŮąŒA„B€2@ˆ „d‰`"D!B"Dˆ@€ŕůźŮąŒ A„B€2@ˆ „d‰`"D!B"D¨ @ŕůśŮąŒ AƒđŔ€*x𠇀T‰ "D!ŕB"D¨ @ŕůśß1ŒA€‚€ € *@Ą„”"T‰ "D!B"D¨ @ŕůłŘ1ŒA„B€&@‘đ„>L‰ "D!‚"DP @ŕůłŘ1Œ A„B&@‰„"L‰ "D!‚"DP @ŕůąŘ AńÂřŕ"|‰‡Ŕ"Dđâ 8!đ‡<8P@€ŕř@@€ŕřpŕřŕř@ @ŕřpqň!xˆƒ‡>|‰ÁÇȄ< ŕřH Cbˆ‘"Dˆ„H‘ @É  +Š" ŕřH Cbˆ‘"DPH‘ @É  +Š"ŕřx B˘ˆ"DP|‰áÁ‘  ŕř€ ŕř@ @ŕřŕř€ŕř|řăŕ"|đCçŔDđâ "8ůđ|ăŕ>DpÇÇDŕř€2@ˆ „d‰`"D!" lˆ$„"dŕř€2@ˆ „d‰`"D!" lˆ$„"dŕřđŔ€*x𠇀T‰ "D!ŕŔL‰ "D!" TˆD„"Lŕř&@‰„"L‰ "D!" Tˆ$„"Lŕřřŕ"|‰‡Ŕ"Dđâ 8!đŽâ>Dp'ÇDŕřŕř€ŕřŕř8ŕřƒ€ŕř„@"ŕř„Ŕ&ŕř…@*ŕř…@*ŕř†@2ŕř„@"ŕřă€ŕřŕř8ŕřŕř8ŕůű !ƒöoŸ €B'ˆâ'‡8áÏ>Dăă‡"€áÇÂŕůƒ qƒlـ €ŁdˆŠˆC$H‘D$H dB2€B!ŕů˜qƒĚـ €ŁdˆŠ ¨C$H•D$H dB2€B!ŕůń˜ŮƒáŒŮ€ €˘§ˆŠ ¨B¤H•D„Dă‡"řáÁŕř ŕř8ŕřŕř€ŕřPp„J‚ŕř H‰"PBdHŠH„I‚ŕř D‰"PBdHŠD„I‚ŕř Dpŕ<Pâ'‡ DřáȄŕřŕř€ŕřŕř€€ŕř>8â€Dđâ 8qŽ"xqLJŕřD@d‰ "‰„2D‰$H‘ŕřD@d‰ "‰ „2D‰R$H‘ŕřD@T‰  ‰P „*D‰R'ˆ‘ŕřDO•T‰§Ę.‰P „*D‰SĹžŕřD@ L‰@ "‰0&Dˆ˘ˆŕřD@ L‰@"‰0&Dˆ˘Hŕř8ăç€ Dđá@Ÿ8q"xp˘Gŕřŕř€ €ŕřŕřŕřDqȀŕřD!’$H€ŕřT!’$J€ŕřT!R$J€ŕřT!R$J€ŕř(!2$Eŕř(!2$Eŕř(qÅŕřŕřŕřŕřŕřqÇπ<|páÄBŕř‰!"@ˆB&Bŕř ‰!"@ˆB&Aŕř ‰!DÄO"đ@€ŕřB$E D†H‘"ˆ@€ŕř>x‚$E TP†H‘*ˆ @ŕřf́‡ĹxAÄH>(ĄÄOˆ@€ŕř@@€ŕř ŕřŕř€€€ ŕřŔ<|‰ŕ"|đăŕ8q>ŕř  "@ɐ"@‰"‰ŕř<ř ŕ"@ɐ"@‰"‰ŕř fŘŔ0"xŠxđĂŔ ‰P ŕř fŔ€0ž<@Š @ " .‰Säŕř fŔ@0 @™ @‘ "‰0ŕř fŔ 0 @™@‰"‰0ŕř <Ŕ 0 |‰ŕŸ|ˆăŕŸ8qÇŕřŕř€€€ ŕřŕřŕř 8qđˆDqȀ<|páÄBŕř ˆ@HD!’$H€"@ˆB&Bŕř ˆ@HT!’$J€"@ˆB&Aŕř `@HT!R$J€T!R$JŸ(@¸B%Aŕř ˆ@H(!2$E$@ˆB$Áŕř ˆ@H(!2$E"@ˆB$Áŕř>8p@ž(qÅ"|páÄBŕřŕřŕřŕř ŕřAÄB>DÄO"đ@€ŕřB$E D†H‘"ˆ@€ŕř>x‚$E TP†H‘*ˆ @ŕřf́‡ĹxAÄH>(ĄÄOˆ@€ŕř@@€ŕř ŕřŕř€€ŕř>Dń>D!áÏpăÇϑ88ů‡ŕřD‰ lQ$H‘‰$$!ąDAŕřD‰ lQ$HŠ ‰$$!ąDAŕřDńPTQHŠ aǏ<!QDAŕř DĄP„T‰âO „"!R'ŕř D‘0„Tů$H ‰D"!SäŕřD‰0„T‰$H ‰$"!R$ŕřŸ8‰D‰Èpâ'ϑ<8!$ŕřŕř€€ŕřŕřŕůűóĎŰđŕřccŕřceŕřcăĂa ŕřcă ŕřcc€ŕřccaŕřc÷ĂđgÁŕřŕřŕřŕřŕřˆâŕřČBŕřČBŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ +EXAMPLE 3 +Řł˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙đđóüŔđ`€Ŕđ`€Ŕđ`řóŕ˜ßsńóŕŔđa™€Řٛ`ŔđaÁ€Řٛ Ŕđaüń€Řٛű Ŕđa€9€Řٛŕđa™€ŘٛŔđ`řđŕĎٛńóŔđđđđđđ€óçĎßż<üđ>xqŔ8p@ó6l0f1˜D‰’  Dˆ@ó6l0p1ŔbD‰’ D ó6o†><0đb x‰Rp óçĚ00xP‰Rŕ ól00H‰2   ól0f1˜bD‰2 @ˆ óoĆ?|1đaDqŔŸ|p@đ@đ€đđđ"|!Âđ"@Q Bđ*@Q@đ*xQŔđ*@‰ đ@ů đ@‰đ|‰đđđđó÷矟8î;÷đŕŕáÄH‘pŔđĆ Ć1ą¸î;˜ŔT "B&H›"€ " đĆ1ą˝ď{˜ŔÄ8Ňxpŕ&B&H›"qŕ‹xqc` &`đÇdž01˝ď{ćŘŔÄT&H™ ‰*đBH•ˆ€ ‘ ‰’ * đĆĆ01ˇmŰŘŔsäO řŔ*ˆBĺH•ˆ€Ÿ ‰ * đĆĆ1ąˇmŰxŔH" € 2ˆB$ȕ"ˆ€ ‰ 2 đĆ Ć1ąˇmŰxŔÄ$H"$‰"ˆB$ȕ"ˆ€H‘ ‰ " B#đÇď†2l›ö8ŔÂáÄGpŕŔđáÄGp€ˆŽ q Ž AÁđđđđđÇÇ>8đ Dđŋ8p DâŔlđ&L‚Dˆ<0 "TđäH‚|`  >Tđ$H‚@ D  Tđ&L‚Dˆ D ‘"T`đĺ‹8pÁ>8â T đ đ@đđđ€Ŕ pđ € €đ>>qaÉx°ăŔ°áÄA8pǀ,8áō€đ3f‰’$J Č"É$Aˆ"2D‚&J€đ3fä ˆń>ń„A`""|‚$ €đ3f  ‰ DA""@‚$ €đ3f‰$I$‰ ‘"$Á ˆ" "D‚$ €đł>qȎˆđŔ€áĂApÂ"8Ä €đđđđđƒ‡áŔ@€ Ŕ>xp€đ„H€ @‚€€  Dˆ€đ„É€2`ŽDpŕ€đ€đ8đđóöC‡ďßžˆâóăĆ3ČBó0ăĆ3 ČBóă1łgĂ3 ¨Bó!łf>¨Bóáóć3˜BóĂ63 ˜BóđĂö6ł ˆăŕđđđđ óöCĎߟ>~B‚ â#Ÿ|řăŕ|‰çÇDřâ‚óăl1ł`BE"!$B€‰˛D BBó0ăl1ł`‚E"A$B€‰˛D BAóă1łϟ1ł|‚EA$BđŔ€ůSÁD Bó!łl1ž`‚H‘A$B€ ‡Č”‰R>D Bóáól1ł`‚O‘A$B€’‰RD BAóĂl1ł`‚H‘A$B€‘‰RD BAóđĂ÷ĎŘ3~C㈞ áÂřŕ€‘‰á8 ăă‚đ@ @đ 0đđŕ óöăż>c~‚œ<@‡‡đĆă°cc‚’"(ADH‘đĆ÷°cc‚’"(DH‘đĆ÷žcc‚Šž"(Gˆ đĆÝ°cc‚J‘"D‚% ‚đĆÝ°cc‚ʑ"|ƒäˆ‘đĆÝ°cc‚J‘"D‚$H‘đĆÉż>>ƒäHž|ýůŸ?~‚œ<CÇÇxpŕ€ó6666 ŮłfÁąŽ `‚’"(B$€D‰€ó†6663fÁąŽ `‚’"(‚$€D‰@ńć6Ǐ3fů° |‚Šž"(ƒÇ†x€Ŕ@đö6Çž|Á° `‚J‘"D‚„"P¸ @đ6666Á°fÁąŸ `‚ʑ"|‚D€>H‰@ó6666 Ů°fÁąąŒ`‚J‘"D‚$€"D‰@óăăăçďŸ0fýůŸ1Œ~ƒäHžD‘ "D€@@đ@‰ "T&D!I"D‰ "D€@@đ@ˆáŔDâŸ"8!ˆ"8‰óŔŸ8ř@€đ€đđđđ>|pÄH€|äG"đ ˆ$M€"@H„"đ ˆ$M€"@H„"đ <ˆ„J€"xĹH>đ ˆDJŸ"@ůK„"đ ˆ$J€"@Ȅ"đ ˆ$J€"@Ȅ"đ>pȀ@óäG"đ đđđđ8<8!áÀđ` "DQ$@đůçŔ "D|Q$@đc6Ŕ <@fQâđc6(\f‰Bŕ€đc6$Dfů"$@đc6"Df‰$@đać"8f‰Àđđđđ@€đƒˆœ!äG"!'‚"!áŔ€đ„H’!H„"!$E$Q €đěŢđH’(AH„"A$E(Q €đ,٘žAĹH>A¤E8Qâ€đŒŮ˜ˆ‘AK„"A§ˆ$‰Bŕ€đě٘H‘AȄ"Ad‘$ů" €đl٘H‘AȄ"Ad‘"‰ €đÇ٘ƒ‡>!óäG" â$Ž"‰Ŕ€đ€ €đ@€đđ@đ>|p$ODůŕŽ"@ř„Hž8ˆÇÇđ ˆ&HŠ"HH"@ „L‘D$„đ ˆ&HŠ"PH"@ L‘D $‚đ <ˆ%HŠ pń "@ J‘@ŕdžđ ˆ%O Hĺ"@ Jž"@„đ ˆ$Č"Hˆ"@ I>DD‚đ ˆ$Č"DH"@ I"Dˆ$‚đ>pÄHDůŕOŽ| ƒˆ"8ˆ'Çđ €đ@đđ0đ1Ŕđđ7Ŕđ3đ3đ3đ3đ3đđđđ€đ‰ŕŽ< CǂDˆÇŔ>Dqň!đ(É" ˘$F"DŘ$ dˆB!đ(É"@˘$J"DŘ$ dˆB €đ(Š"@˘$BD¨'€DpB!đ đ€đđ @đ!äG"‰Á>xă㈐> đ!H„"‰’"ˆ’ DH đAH„"‰’"ˆ” DHđAĹH>‰R"ˆx㇠đ  đ @đđ€đŽpCŔ‘<qç€>8‰áđˆ˘ ™"(‰"@ D‰đ ˆ˘ ™"(‰B@ D‰€€đ €ŁŔ•"(ĂÄ@<0‰€€đ €•8qđđđ€đđ @đqÇπ đ‰! đ ‰!(đ ‰!đ ‰!đ ‰!đ ‰!đpáÁ€> đ  đ @đđ€đÇ>đ !„đ<ř!„đ fŘ!đ fŔ! „đ fŔ!„đ fŔ!„đ <ŔÇđđ€đđ`€đ`xđ$ODůŕŽ"@ř@đ"Dˆ&HŠ"HH"@ @đo€"Dˆ&HŠ"PH"@ đlŔ Dđ%HŠ pń "@ đlŔ D %O Hĺ"@ đlŔ"D$Č"Hˆ"@ đlŔ"Dˆ$Č"DH"@ đlŔxˆÄHDůŕOŽ| @đ@đ€đđđŔ>8áÇđŔ D„Bđ8ٙĆ3Ŕ D„Bđ ٘f6@Ćađ‡€>8áÇđ€đ đđ ŕđAÄG>p đB$H„ ˆ đ‚$H„ ˜ đ‚$H„<¨ đ‚$H„ ¨ đ‚$H„ Č đ‚$H„ ˆ đAÇ>p đ@€ đ `ŕđđđxůň'ˆ€8ˆăçŔ"8qńÂđĆD€B$L€D‰„"D‰$Bđ÷ǟD€B$L€D‰„"D‰$AđĆlـxđB'Š€D‰‡€ "@áƒđĆoـP€B% €D‰„"@@đĆl€H€B$‰€D‰„"D‰$AđĆlـD€B$I€D‰„"D‰$Ađvg™€DřAÄH€8pŕ‡Ŕ8qńÂđđ đđđŔ!ăçȞ" â#Ÿ| âOđŔ!‘2!$B@PBHđ<Ď<A‘2A$B@PBHđfŮfAăÁž*A$BxPBOđ~Ü~AB”*A$B@ˆBJđ`Ç`A"’&A$B@řBIđfÓfA‘&A$B@ˆBHđ<Ţ<!á" áÂ@ˆă㈟đ @đ0đđ óqžc~CçÇ8ůç‚>đB'‡qÇπ@păŕ8ůň#€óyłc@„„D’E ˆŁ$H›‰!@!€!d@óyłc€„„D’E ˆŁ$H› ‰!@!€!d@ómłc€‡†@ńSDž<đ˘¤H• ‰!@ Ŕ€ž!âŁómžc€„\R„ |Ą¤H• ‰!@ ‡Č>! €óg°c€„„D2„ ‘ňdH• ‰!@!€!¤@óg°c€„„D2H„ ‰dH• ‰!@!€!¤@óc°>@‡Ç8ůäH„>‰'‡páÁ€|pŕ€8!ň#€đ@ đ đđđ8řâ'ŔDůáÇÂppâ$H€đ‘" B$"D$H!$M€đ‘" B$"T$ H!$M€(đ‘ AG€"Tńâ'‚x!¤J€đ ADž"TB$>D!r¤J€đ" AD"("$D!dJ€đ" @„"($D!dJ€đ8 ŕ‡Ŕ(ůÄŽxpâ#ˆ€>đđđđ @€đ @đ" @đ& đ* đ* đ2 đ" đ @đ @đ @€đđóöCěß>qńÄOŽóă Ůł @†Čó0㙳 @†Čóă1łĂł @…O ó!ł> @…Hóáó˜3 @…HóĂ Ř3 @…HóđĂ÷ěŘ3 pAÄOŽđđđđó÷矷ŕđĆ Ć60đĆ60ĹđÇdž60ÉđĆĆ60 đĆĆ60€đĆ Ć60ÁđÇď†7ŕÁđđđđńÄ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ +EXAMPLE 4 +Ůw˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ř€ř€ůţ€`đ€ř0Ŕ€á˜€ř0Ŕ€ă€ř0|yđĚošřůđc€ř0ĆĚŔ ll͍°cđ€ř0ĆŕŔ ll͍€c€ř0ţxŔ ll͍ý€c€ř0ŔŔ ll͍€c€ř0ĆĚŔ ll͍€c€ř0|xp gěÍřů€ađ€ř€ř€ř€ř€ř€ř€ůóçďߞ~x#ˆ€ů›63Ě!€ů›68ŕ3!€ů›7Ăx2Ą€ůóć<Ą€ůƒ6 a€ůƒ63Ě2a€ůƒ7ăžř2#€€ř€ř€ř€ř€€ůűóĎϏœwűřů@ €8p€řccŘÜwƒĚ` €*!@@€€řcŘŢ÷˝ƒĚ`b!aÀ8đŇ<8â#68đáŔˆ€€řcăĂŢ÷˝ól`b €*!D@"D@&HD$D*@" ˆ€€řcăŰśíƒl`!C>0@|Â#*<@"ˆ€€řccŘŰśíƒ<`!@€ @@!@„*D@"…"€řccŘŰśíƒ<`b!D@ "DH$‘DDD‘*DH" …"€řc÷Ï™6Mű`a!C€80Ä 8ŕƒƒ*<0!Ŕ‚€ř€€ř€ €ř€ř€ř >8‰ńǏ„>|€ř@ @ DČB$H @€řáĆË,8đáŇxâĂH›Xđŕ‡ DČB$H @€ř%L‚2@"&H€" $ȕ"dA€D@Ŕ€ D¨B@€ř%H‚"D@"$A" H• D@ € D˜B$ˆ@€ř%L‚"DH"$H€" ɕ"DIH€ D˜B$H@€řáĹK"<0!ÄG ňF•D0ŕ‡ 8ˆAÄO‘|€ř@€ř€€ř€ř€řp€ř€€řâ%‡8°€ř‚&HˆDČ€ř‚$HDˆ€ř‚$HDˆ€ř‚dH‰DˆŔ€ř¤G8ˆ@€ř@€ř€€ř€ř€ř  €€ř  A €€ř‹ +xpăÀ,8ńaŀ,8âŔˆ€X°âŔ€řL“ ‰@2DA’&@2D ˆ€"dÉ €řȑ řÁ"|Aä"| ˆ€>@ €řH‘ €!€"@A"@ … @€řH“$‰$@ "DI$ "D …"@€řȍpŕÀ "81Ä"8⠂@€â€ř€ř €ř€ř €ř(8!Ŕp€ř(@@ €€ř(đŕC€xáÄK +€ř@ D@" ‚$L“€ř@ GŔ" ‚$H‘€ř@ D" ‚$H‘€ř@ D@"$‚$ȓ€ř@ C€ĂH€ř€ř €ř€ř8@€ůű !€C÷ďß €B'ńńŔ8 €ůƒ q€ăŒ€ €ŁdˆŠ‰ "D €ů˜q€ăŒ€ €ŁdˆŠ ‰ "D€ůń˜Ůłá™€ €˘§ˆŠ ńဠ0€ů€ŮłŒ ¤H‘ Ą@”.€ů€đůóŒ€ ň¤HŸ ‘ ’"D€ů€aƒŒ€ ¤H‘ ‰ ‘"D€ůřaűŮ€ ů'‰ńŔ‘8 €ř  €ř8@€ř€řŔ€řLjăŕ>8řç8 CäHŽ"@ă‚€ř€ř€ř€ř €ř CLjqÇπ|ůńÄOž>8qáǏŽ<€ř ˘$H‰!"@!&B D‰„B"€řß|@˘$H ‰!"@!&B D‰„B"€řłf@˘$H ‰!x!â%B<0ŕ„B<€řżfALj ‰!@!%B @‡‚(€ř°fAň ‰!"@!$ D‰ „$€řłfA ‰!"@!$ D‰„"€řٞf!„páÁ€|!ÄB>8qÄ"€ř  €ř €ř€řŔ€řxpŕ@€řD‰@€řD‰@€řx€Ŕ@€ř"P¸ @€ř>H‰@€ř"D‰@€ř"Dpŕ@€ř@€řŔ€ř€ř€ůű !ƒçďϟ?ˆâ€ůƒ qƒ6 Ů°ČB€ů˜qƒ6 Ů° ČB€ůń˜ŮƒçϘٞ ¨B€ů€Ůƒ6 ß0¨B€ů€đůƒ6 Ů°˜B€ů€aƒ6 Ů° ˜B€ůřaűç왿 ˆăŕ€ř€ř€ř€ř€ůűqߟ1żˆâ€řcqŘ1ąŒČB€řc{Ř1ąŒ ČB€řc{ß1ąŒ ¨B€řcnŘ1ąŒ¨B€řcnŘ1ąŒ˜B€řcnŘ1ąŒ ˜B€řcdߟ ˆăŕ€ř€ř€ř€ř€ůűqߞ €řcqŘ3`€řc{Ř8  €řc{ß €řcnŘ €řcnŘ €řcnŘ3 €řcdßž ř€ř€ř€ř€řp€€řóńóóǟ>~üςżA„N!ăă€<8p@€ů›lŮł`ĆŘÇ0AFÉ!@ "Dˆ@€ůĂł`ĆŘÇ0 AFÉA@ "Dˆ €řóăǙł|ĆŘ +†> AEOAăĂ <@` €ř{ăß>`ĆŘ +†0A%H‘"AB€(\ €ř`Ř3`ĆŘφ0AĺH‘>A"@$Dˆ €ů›lŘ3`ĆŘŘĆ0 A%H‘"A@"Dˆ €ůńńńó÷Ϙ3~üϘĆ? Aň$O"!ă€"8p@€ř@ @€řp€€ř€ř`@ @€řc€8đ„GůńÇŔ8đƒ‚<ńńÁ€ř Dˆ„E"‰!€ř DˆE"‰ €€ř8€ƒˆž"‰ńÁ€ř€€ř @€ř€ř€ř‡Â€ř€B€ř€€ř€€ř€ř€ř‚€řâ€ř€ř€ř€ř€ř qÇπDpă㇀řŒ‰!"D‰H„€řď> ‰!"D‰H‚€řŒŮł ‰!DĂ€řŒßł ‰!D€řŒŘ3 ‰!"D‰H‚€řŒŮł ‰!"D‰H‚€řěĎ3páÁ€8pă㇀ř €ř€ř€ř 8€ř€AÄG>řAÄž>€ř€B$H„ € „‘ €řyžx‚$H„ € „‘ €řͲ̂$H„<đ „ž<€řý¸ü‚$H„ „” €řÁŽŔ‚$H„ đ„’ €řͦ̂$H„ „‘ €řyźxAÇ>ÇÇ>€ř@€€ř `8€ř€ř€€ů¸ß1ż â#Ÿ"řáŔ"8ůđD #ˆ€ůźŮąŒ!$B6( B "D!Š"DP!€ůźŮąŒ ADB6( B "D!Š"DP!€ůśŮąŒ @ÁC*( B"D!ŕ |PĄ€ůśß1Œ@ €‚*D B"D! ‘ DˆĄ€ůłŘ1ŒA„B*| B "D!Ÿ"Dřa€ůłŘ1Œ A„B*D B "D!‘"Dˆa€ůąŘ ŕƒ‚"D áŔ8!đDˆ#„€ř €ř€€ř€ř€€ř"8ůđp#ˆ€ř"D! 0ˆ!€ř"D!Pˆ!€ř"D!ीř"D!„ Ą€ř"D!@a€ř"D!€a€ř8!đ|ř#„€ř€ř€€ř€ř€ř>8ř„8‰ÁÄB8ˆŕ€ř D D"DŮ †EDÉ€ř D D"DŮ †EDÉ€ř<0 D DŠŕ…ED¨Ŕ€ř  $ DŠ…H„D¨ €ř D ä"DŠ„Ď„D™€ř D B$"DŠ„Č„D™€ř>8 B'π8‰áÄH„8ˆŕ€ř€ř€ř€ř@€ř8ˆăçŔpqŔŸ<8‰"| €řD‰„H‰ +"‰°" €řD‰„H‰ +"‰°"€řD‰‡€x‰ ž"‰P>€řD‰„D‰ "‰P"€řD‰„D‰ "‰P"€řD‰„D‰ "‰P"€ř8pŕ‡ŔxqóŔŸ<8qÇ" €ř €ř @€ř€ř€řqđ„xřâ$€ř ADD$€ř ADD$€ř ADxń$€ř B$Pr$”€ř CäH$’€ř B$D$‘€řpB'ÇDřáÇȑ€ř€ř€ř€ř€€řńńÄH<pâ'8ůŕȞDńóŔ€€ř‰$H "‰dH"D‘d‰ €€ř ‰$H "‰dH"Dd‰ €€ř ńâH <¤O0ń‚T‰â €€ř ĄäH(§Š"T‰ €€ř ‘$H$‰¤ "D>L‰ €€ř ‰$H"‰¤"D"L‰ €€ř‰ńϑ"pâ$Ÿ8ůŕȐ"DńóŔ€€ř€€ř€€ř€ř€€ř"8ůđ8Ä€ř"D!€"D„€ř"D! €"L„€ř"D!ŕ €"TP„€ř"D! €TP„€ř"D! €d0„€ř"D!€"D0„€ř8!đ8Ç€ř€ř€€ř€ř€ €ř"8ůđx€B >8p#ˆ€ř"D!„"D€˘ ‘ Dˆ!€ř"D!„"D€Ą@‘ Dˆ!€ř"D!ŕ„D€Ą@ž<0`Ą€ř"D!„x€ Ą€ř"D!„"@đ€ Dˆa€ř"D!„"@€ Dˆa€ř8!đ@ů€>8p#„€ř€ř€ €ř€ř€ůű !ƒöoŸ|qă|ř€ůƒ qƒlـ@‰„H€€ů˜qƒĚـ@‰„H€€ůń˜ŮƒáŒŮ€x‰P„đ€ů€ŮƒŸ@‰P„ "€€ů€đůƒĚ€@‰0„I>€€ů€aƒl€@‰0„H"€€ůřaűöl€@qƒˆŸ"ř€ř€ř€ř€ř€ůűóĎŰđ€řcc€€řce€řcăĂa€řc　řcc€€řcca€€řc÷ĂđgÇ€ř€ř€ř€ř€řˆâ€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€' T& ' T'H T&H & MODERN MODERNMODERN Úánw˘Wr2’;“7ůYĹ“Łz;ŘgđX&Ž4h덋ÚďÜâl& BMOBJ.GETFN2#U˙ÇkP´Ź >ž BMOBJ.GETFN2MODERN  `š BMOBJ.GETFN2MODERN  eţ BMOBJ.GETFN2MODERN  Wî BMOBJ.GETFN2MODERN Bzş \ No newline at end of file diff --git a/internal/test/Tools/TESTERLOADER b/internal/test/Tools/TESTERLOADER new file mode 100644 index 00000000..824d8a0c --- /dev/null +++ b/internal/test/Tools/TESTERLOADER @@ -0,0 +1 @@ +(FILECREATED " 2-Oct-86 16:51:12" {ERINYES}TOOLS>TESTERLOADER.;3 1750 previous date: "19-Aug-85 16:19:15" {DSK}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 \ No newline at end of file diff --git a/internal/test/Tools/TESTERLOADER.LCOM b/internal/test/Tools/TESTERLOADER.LCOM new file mode 100644 index 00000000..c137fbce --- /dev/null +++ b/internal/test/Tools/TESTERLOADER.LCOM @@ -0,0 +1 @@ +(FILECREATED "24-Oct-2020 22:17:36" ("compiled on " {DSK}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}TOOLS>TESTERLOADER.;3 1750 previous date: "19-Aug-85 16:19:15" {DSK}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 \ No newline at end of file diff --git a/internal/test/Tools/TESTERVARS b/internal/test/Tools/TESTERVARS new file mode 100644 index 00000000..61a90656 --- /dev/null +++ b/internal/test/Tools/TESTERVARS @@ -0,0 +1 @@ +(FILECREATED "21-Aug-85 16:44:54" {DSK}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}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}TESTS>)) (TEST.TRACE-FILE-NAME (QUOTE {DSK}TESTER-TRACES>TRACE-FILE))) (CONSTANTS (TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID (QUOTE {ERIS}TOOLS>NEXTID)) (TEST.NAME-OF-LOCK-FILE (QUOTE {ERIS}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}TESTS>)) (RPAQ? TEST.TRACE-FILE-NAME (QUOTE {DSK}TESTER-TRACES>TRACE-FILE)) (DECLARE: EVAL@COMPILE (RPAQQ TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID {ERIS}TOOLS>NEXTID) (RPAQQ TEST.NAME-OF-LOCK-FILE {ERIS}TOOLS>LOCK-FILE) (CONSTANTS (TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID (QUOTE {ERIS}TOOLS>NEXTID)) (TEST.NAME-OF-LOCK-FILE (QUOTE {ERIS}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 \ No newline at end of file diff --git a/internal/test/Tools/TESTERVARS.DFASL b/internal/test/Tools/TESTERVARS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7affcd04ebedc4138b921c4769eb512b6d838366 GIT binary patch literal 8083 zcmc&(U2G%O6}FwkvGcPVve|!jnT2HwOD3Cy?80tQs);>LMr+TQneirzgtSgPo0xSx z!9NXKinLVprL_bo1$=3FC=Zn?Rh25WQu{=CK&sk4@Y1Rh4{cxgDX9DisRc^uckZ1T z+lkqwRjcM&TJ`Psa%~cmWtJlSyjJaShE?;O3d1-WzX8KTdMM*YFRp{MB)3dRkKItMzJ4nmT*$>2YcD+|10mnd!4LXV2Vo_sp4z;gn*f zg$+KlRWA$H(~_}LbC+TD^yKv9xHNV8-1M0i^W?9L4SgdNio{k!_~Rd!MuYTu zi4XU;hVdH>+i0&hToXvH?%yA_S>*}x{$ZvYG+vgb@=(NawUy$(=3 zVd$2v=r$*s1>_K&hY3ryWg1xWTrQPTP1({OQ11geYN`ptOir=>6Rdv(fPPQQEQx## zfPGwmu4Gi%NXcmpH7~|q>Q%R`Y6q$@8?q33VhsY3V&B~G@%S!?>C&w({ zB8FdpA*vg5n$ETVlnoQ~$ABIYI^Z%nso07>C14{)nTC#FyTrz5_5cvKbg&_K5^C0# ztt`3L_i7GwH)%R_lT(wjb|iUj*1$ zobW#ZUIdFTnD9ypQAX$=Y-bneSH?bZtH00o64`e_=A9HT@;&1N!e>D-u;}Ek$mwGF zN|l(N;^80qHZXl@cO_pU;5RW7G3VLS3QJ$-HINJ~a8#gUE755QTZj}wUlCKqA$~FBj;}ia%2{jICstfr_ zF~3}LXamCUG`B`@v$0#~!$*@e8iq7B0VPl|sJpW7YD|Yy`C_SFajLRWE?s4(i1Mx$ zWwzqfpry*jK|5sCDsFjI>^Bjfq|aVpdW_4LX*@Fta5$KnG7Io#YDq$RzIPtTk9ME*+4_z<7a$MpGC;r#SbPI{=h6$|$bj7=9foRg7= zQG6c1Mx#B!=pY{v$)7PI+#vmbve9>c&ahQBM4&i*F0la;_jj@4Xj;k4B^6kWCG;xh zJe^c-SLpTTRvf_aN%j!_#ga~SrBYmWFpd<<`1V!T+)53D-p#c<{qL!*5w@4yNB;{h z-=ffKwAbV;qCw_ktIe%Gj3Zi#$Z#K_Hi2Q7^m|!_;A+}Z19(c&(m9hK*H=lBuy;{a z&WmBxvQ0yurPT2TnagA@Voh`h1e0l^`4I```&VVFE6pu(PqQ(Uz+sfC_2pW{ zp_Pbiz^@aW1KU(pnNp&nCpr0`QYc6(Zh6Jop!JIUsU(vi5?5b4@vfv(LSVJgi%TP^ zrja4LvcyP!37H1MMOG!@X-z-hX@)1+qx91_7rTR)%k(y=C6k}!c54ScnI2__%pJsW zwNR`{9;rwYREvlV5lHQAHu{rjuS)r=*P0Ev3U{p3$l1l3vyR$T+HfjVw@L*;B)I_a z3{b^6rg(|@$%uP@%oD~HS0%T6%EgI%rXi7i6V{?;Cl*j-iJFJfZp&#s$Ru+WceCoW zZMN7BQ3A``x4W^fRIgNd1DTh~ZUKzke&i=9Uq%%07O*PirDZO+!bx!+{QZ`y8+mFw z(SdHR6<5|I!U-AZ9J$0|l>;lTTcfjyXk5#eR~@N<@S@!AMdN~^Bm44RdO$Lfah{p;)SzkZYf`@6<3hcU`{l* zQ9zpuL&Ob|%TjW0nQ+{6R-nF)IN&l@EBTEz?i_zZi#2Q{!eCf^#90BI*f|Ikmzlbx zCUTHS`)4&9lO7eE3d_k|6k*tCVRGO*&*BM*jy;|27rD7{+^K?t1Aq3P2}Gb+e52tS zt{&Fj#skc^*24Ks*nY9saz{4pz*sW7Ud1LLzJB?PcOVP!kyP4H zY`KL6Y?Mr$N2A#WMI}us6{Vn%`}Q>m-Uja(Ps^tH zAgb}+6?JNKPMgro;4;?(Pe{6JkXfWQplj2=~;(XyBL02z|0jeN-QGHEu=*O7#sP|`S5{~e% zi26@B`X4*Y2Bc?rfHZOH(EFV3UEiWlnp^#_#51=WNw|lcEHLkNFoz?bhY7t!EHJe% zW#A1DgJG{B6pt>xmHy_2kAj}sfDwK6-|`F&-|A6Dtpz2kE_#x}M}7PWKz0!g z_sy+7_=v~0n;X;?klW?U9^n8HCQKEDhA-@hFKh~s5zx^JhqY5iOB`1!dvu{ULBn?^ zdXHGLX`URaJ( zzfAxj?UG@Z2yVQ2bw`BWfOvZK88Oj%7#Vq9)zO3F?U0mF2BFOzG}R0`J^qx0>9F5~ z@DATMB3R!2tyR3?>(6$98RP&`GbK+=^3Iy_LBOJSVY!Gs*}KPgT-fl%?}nr?9~=sT z|6`CJ*bjKuxZef%p@TcP!qne)frmbVlEd4DWjqtS(r`5G<_maY;EkJPQDH6?DQYQX z##Rd_UN3{|av{r0Y`+uWzao|M>kcp5N)RhbzRoJTT5~I?A5pN>)==aV6Wx=|#vY3> z-7N8%7;JH?HQZ*(YS!JTO7#u&98_WX1y_ga>bTbvbT^nA*3DvWs`!yiSUTplOC8dM z(~j}0*6W)(g3d2Nn~nSzvz0n2zZIcgO0*E0#d5*j^w$?$!5yYd%sugy?>+p=J%|bf zYcH9Emlq8A1*;`7iuo^!6wUmy#b9LnD<&cRtEHa?xR3!GXgxS$77v~mF&QLf6d>Y~ zi}^2}^L%Fz7j7zF zHm1W?E~}b80Pj&zkw*H(&omb2dyapf=HDlpTSvgxOFwe5Gwd{*VRy4>HpwQ~7`uy| zWOuSV*q7J|b~`)HZezEyV@#rlw+N%FBf==ZN7&8R*kOjZs|cfW8({|!Ck(3lAv&h% znoZ&f!C%NOp-jSGu&ot!jzlqISM$SZ0+W9;AWaxRSk^cDEXa53ax+|Ih literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TESTUSERS.TEDIT b/internal/test/Tools/TESTUSERS.TEDIT new file mode 100644 index 00000000..6107b8ac --- /dev/null +++ b/internal/test/Tools/TESTUSERS.TEDIT @@ -0,0 +1,113 @@ +THE INTERLISP-D TESTING SYSTEM - USER GUIDE +This document should be used as a guide for users of the testing system, and it assumes that the reading of "The InterlispD Testing System" document. +LOADING THE TESTING SYSTEM +The testing system resides on the directory {Eris}tools>. To load the testing system, LOAD the file TESTERLOADER. This file contains the correct loading sequence for the testing system files. +FILES: +TESTER.DCOM - Contains the main part of the tester program. +TESTERVARS - Contains most of the tester global variables. +TEST-REMOTE-EVAL.DCOM -Contains the functions for executing remote eval. +RANDOM-GENERATOR.DCOM - Contains functions and variables for random generation. +VARBROWSER.DCOM - A user package for manipulating the programs global variables. +THERMOMETER.DCOM - A user package for displaying the progress of a program in execution. +INTERLISPD-SYSTEM.CONCEPTSPACE - The file contains the global concept space of the system. + +EXECUTING TESTS +Usually execution of tests will be done through the Concept Space Browser. The basic function which is called by the browser is: +(TEST.PERFORM-TEST TEST TIMES LOCATION TRACE-FILE TRACE-MODE) [ function] +Only the first argument is necessary. TEST must be of type TEST. TIMES is the number of times that the test will be performed and is defaulted to the value of the field TIMES of TEST. If this value is NIL it will be executed once. LOCATION can be either the atom "Local" or the atom "Remote" and is defaulted to the value of the global variable TEST.DEFAULT-LOCATION. TRACE-FILE is the name of the file on which the test execution process should be traced. The default name is the value of the global variable TEST.TRACE-FILE-NAME. TRACE-MODE can be the atom "On" or the atom "Off". It is defaulted to the value of the global vcariable TEST.DEFAULT-TRACE-MODE. When TRACE-MODE is "On" every testing step will be recorded on the trace file as soon as possible. The tracing will be done in a "careful" way - as soon as a new information is available (The input was generated, the result from the tested expression evaluation is returned, etc. ) , the trace file will be opened the information will be written and the file will be cvlosed. If the trace mode is Off, the function will check at the end of each iteration of the function to see if the outcome was a failure and only in such a case it will write it down on the trace file. +There are two ways in which the PERFORM-TEST function can iterate. One way is if the TIMES argument is greater then one (or the times field of the test is greater then one). The other way is when the input expression is a list starts with the atom SYSTEMATIC. In such a case each of the elemnets of the CDR of the list will be evaluated. The tester expect them to produce sets (lists) which are the ranges of the arguments. It will then collect all the possible combinations of the elements in these finite ranges and perform the test on each of these combinations. +The function returns the name of the trace file. +(TEST.HARDCOPY-TRACE-FILE TRACE-FILE OUTPUT-FILE FAILURES-ONLY) +The default for TRACE-FILE is the value of TEST.TRACE-FILE-NAME. The default for OUTPUT-FILE is the value of TEST.DEFAULT-HARDCOPY-DEVICE (usually {LPT}). The trace file is written in a way that is hard for reading. This function prints the trace file in a "pretty" way. if FAILURES-ONLY is non-NIL only the trace of tests that failed will be printed out. +Manipulating Concept Spaces +Concept spaces are stored in files, each concept space in its own file. usually the name of the file can be XXX.CONCEPTSPACE where XXX is the name of the concept space. This name can be retrieved by calling +(TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME CONCEPT-SPACE-NAME) +Returns XXX.CONCEPTSPACE where XXX is the value of CONCEPT-SPACE-NAME. +A concept space is of type CONCEPTSPACE which is record with the fields CONCEPTSPACENAME ROOTCONCEPT and CONCEPTLIST. ROOTCONCEPT is the name of the root concept. CONCEPT list is a list of concepts. A concept is an instance of the record CONCEPT which has the fields CONCEPTNAME, TESTS, SUBCONCEPTS and SUPERCONCEPTS. SUBCONCEPTS and SUPERCONCEPT are NAMES of concepts. TESTS is a list of tests ids. Usually the initial concept space will be created by the function +(TEST.CREATE-NEW-CONCEPT-SPACE CONCEPT-SPACE-NAME ROOT-CONCEPT-NAME) +which returns an instance of CONCEPTSPACE with one concept. The rest of the concept space will be most conveniently built using the Concept Space Browser. +The system maintains a global list of the concept spaces that are "known" to the system. It is convenient to work with concept spaces that appear in that list since this will enable the user to perform certain operations on the concept space using the background menu. The global list is stored in the global variable TEST.CONCEPT-SPACES. This variable can be manipulated directly or by calling the function +(TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES CONCEPTSPACE) +If a concept space with the same name is already in the list, it will be removed and the new one will be added. The function +(TEST.GET-CONCEPT-SPACE NAME) +Returns the concept space with name NAME (if there is one in TEST.CONCEPT-SPACES). +Concept spaces that are on the TEST.CONCEPT-SPACES can be stored by calling the function +(TEST.STORE-CONCEPT-SPACE CONCEPTSPACENAME) +The function will prompt for a file name, suggesting the canonical name. If the concept space was loaded before through the TEST.LOAD-CONCEPT-SPACE function then the candidate file name will be the same as the one that it was loaded from (but with higher version). The user can also choose the subitem "Store Concept Space" from the background menu. +(TEST.LOAD-CONCEPT-SPACE CONCEPT-SPACE-FILE-NAME) + Loads the concept space from the specified file, adds it to TEST.CONCEPT-SPACES and keeps the file name in the property CONCEPTFILE of the concept space name. +Building and manipulating tests +(TEST.CREATE-NEW-TEST ) [function] +Creates an instance of the record TEST with the default values which are obtained by calling the function TEST.GET-DEFAULT-FIELD-VALUE. The new instance is then added "officially" to the world by calling TEST.ADD-TEST . Then the test editor is called on the new test to allow the user insert values to its fields. It does NOT store the test in a file, and this should be done later by calling either TEST.STORE-TEST or TEST.STORE-CHANGED-TESTS. The test, after created is not assigned to any concept, and it is recommended to assign it as soon as possible to at list one concept. +(TEST.ADD-TEST TEST-RECORD) [function] +Assigns a new ID to the test record instance by calling TEST.GET-AND-INCREASE-NEXT-TESTID and adds the test to the list of loaded tests. +( TEST.EDIT-TEST TEST) [function] +TEST should be a test or a test number. If the global flag TEST.OBTAIN-LOCk-WHEN-EDIT is non NIL the function will try to obtain write lock on the test. If it fails to obtains such a lock it will exit without editing. The user can get the name of the locking users and automatically send release requests as described in the "accessing the database" section. +The test inspector will be called and the test will be marked as changed. +(TEST.GET-TEST TEST-NUMBER) +This function is the user interface to the database management system. The user calls this function and gets the test with the TESTID TEST-NUMBER. Actually the system will search for the test in the list of the loaded tests. If it will not be found a "test fault" will occur and the system will look for the file for this test and load the test from there. If by adding the test to the list of loaded tests an "overflow" occurs (the number of tests is more then the maximum allowed), the last test on the list (the least recently used will be deleted from the list. +(TEST.GET-FIELD-VALUE FIELD DATUM) +Gets the "Actual value" of a test field. If the field value is indirect reference to other test, the field value will be retrieved from there (using TEST.GET-FIELD-VALUE thus enable chaining), otherwise it will return the field value of DATUM. +( TEST.GET-DEFAULT-FIELD-VALUE FIELD-NAME) +FIELD-NAME is a TEST field name. The function will return the global default value for this field. +The following functions can be useful when building a test for use within the actual test fields: +(TEST.TEST-SINGLE-TIME TEST-NUMBER) +There are tests which have the TIMES field greater then one. Such tests will be executed more then one time. there are also tests which have as their INPUT field a list starts with the atom SYSTEMATIC. Such tests will be applied on all the combinations of the elements of sets in their INPUT field. Such tests can run for hours only to discover that something in the test itself was not correct, and the trace file is full of garbage. To avoid such a cases it is recommended to create for such tests a "Testing test" which will perform the tested test once and will only check that the outcome is meaningful (i.e. The result is either "success" or "failure" etc). Such a test can be built easily by having as its Expression field a call to this function with the tested test as TEST-NUMBER. It may be also useful to add a WEAK or STRONG link in the tested test PRETESTS field. +(TEST.ERRORP EXPR) [function] +If an error occured during the evaluation of the evaluated expression, the returned result will be a list of two elements, the first is the atom ERROR!, and the second is the error number. This is a simple predicate that checks if an expression is of the form described above. It is useful for building the success predicate. For example, a test may have as the EVALEXPR the function ADD1, as its INPUT field some non numeric atom, and as its success predicate, the expression (LAMBDA (RES ARGS) (IF (AND (TEST.ERRORP RES)(EQP (CADR RES) 10)) THEN 'SUCCESS ELSE 'FAILURE] . This test tests whether the function ADD1 breaks with non-numeric arg error. +(TEST.ALL-COMBINATIONS SET-OF-SETS) [function] +Produces the Cartesian product of the sets in the list SET-OF-SETS . (TEST.ALL-COMBINATIONS '((a b)(1 2 3))) will return the list ((a 1)(a 2)(a 3)(b 1)(b 2)(b 3)). This function is used by the tester when it encounter an INPUT field starts with the atom SYSTEMATIC. It is useful in any case that the user wants to build tests that tries all the combinations of possible values of a function arguments, or to have all the possible settings for flags and global variables for some subsystem or library package. +(TEST.LOCAL-EVAL-FORM FORM) [function] +Evaluates the form FORM using ERRORSET, thus the avaluation will not break even if error condition occurs. If error did not occur the function will return the result of the evaluation of form. If error condition was entered, the function will return a list with the first element ERROR!, and the second element the number of the error (as described in Interlisp-D manual. +(TEST.PERFORM-TIMED-EVALUATION FORM TIMEOUT.ms) [function] +Evaluates FORM using TEST.LOCAL-EVAL-FORM (thus it will not break). If the evaluation will take time which is longer then the value of TIMEOUT.ms, the function will return the error expression (ERROR! TIMEEXPIRED). This function is used by the test driver if the TIMEOUT field of a test is non NIL, thus an evaluation that will take more time that the designated time will be considerd as returning with error condition. The function create a seperate process to perform the evaluation, and set a timer for the designated time (plus some time for overhead). The user should note that since the Interlisp-D process schedualing algorithms are non-preemptive, the function is not guarantied to halt. An infinite loop may not release the CPU and then only keyboard interrupt will work. +(TEST.GET-NEXT-AVAILABLE-TESTID ) [function] +The test ids should be unique. That's why the system maintains a file which holds the next available test id. This function access this file and returns the id. +(TEST.GET-AND-INCREASE-NEXT-TESTID ) [function] +This functions returns the next available id as the one above, but also increase this number on the file. this function is called by the function TEST.ADD-TEST which adds a test "officially" to the world. +The Random Generator +The random generator resides on the file RANDOM-GENERATOR.DCOM. The main function is +(TEST.GENERATE-RANDOM OBJECT-SPECIFICATION) [function] +This function is planned to be constantly expanded by the tests builders according to their needs. The OBJECT-SPECIFICATION can be an atom, which should be one of the objects known by the random generator. It can also be a list where the first element is an atom which is one of the known objects, and the rest of the list are modifiers according to the object type. The current list of known objects is : (INTEGER, SPECIAL-INTEGER, BOUND-INTEGER, LARGE-INTEGER, SMALL-INTEGER, BIGNUM, POSITIVE-BIGNUM, SPECIAL-BIGNUM,POSITIVE-POWEROF10-BIGNUM, WINDOW, REGION, SHORT-SIMPLE-LIST, SHORT-SIMPLE-NON-NULL-LIST, SHORT-LIST, LIST-OF-CHARACTERS, CHARACTER, LIST-OF-ITEMS and some more. +Some of the objects have modifiers, like short list which can have a maximum depth as a modifier. A very important object is LIST-OF-ITEMS which can have as its modifier another object specification, thus enable recursive use of the function. Thus you can write (TEST.GENERATE-RANDOOM '(LIST-OF-ITEMS REGION 100 200)) which will produced betwwen 100 and 200 random regions. +Database access +(TEST.GET-LOCKING-USERS TEST-LIST) [function] +TEST-LIST is a list of test numbers or the atom DATABASE. Will return the list of all the users that kas locks to tests in TEST-LIST together with the tests in TEST-LIST that they are locking. If TEST-LIST is the atom DATABASE, the function will return the names of all the users that have locks to any test. +(TEST.OBTAIN-DATABASE-WRITE-LOCK TEST-LIST) [function] +TEST-LIST is as above. The function tries to obtain locks on the list of tests in TEST-LIST. If TEST-LIST is the atom DATABASE, it will try to obtain lock on the whole data base. A lock on a test can be obtained if there is no other user locking the test. A lock to the whole data-base can be obtained if there is no user that locks any test. The function returns the list of all tests that it was able to lock. +(TEST.RELEASE-DATABASE-WRITE-LOCK TEST-LIST) [function] +As above, but releases the locksto the tests in TEST-LIST that are locked by the user. Returns all the tests that it suceeded to release. +(TEST.SEND-RELEASE-REQUESTS TEST-LIST) [function] +TEST-LIST is as above. Sends automatic messages to all the users with locks to the tests in TEST-LIST to release their locks. +(TEST.MARK-AS-CHANGED TEST-NUMBER) [function] +The number of thetests that are being modified using the programs editor are added to the global list TEST.LIST-OF-MODIFIED-TESTS. This can be done by calling this function . +(TEST.UNMARK-AS-CHANGED TEST-NUMBER) [function] +As above, but remove the test from the list. +(TEST.STORE-CHANGED-TESTS) [function] +Stores all the tests in the list of modified tests. +(TEST.STORE-TEST TEST-NUMBER) [function] +Stores the test TEST-NUMBER in the file wit h the name returned by the function TEST.TEST-NUMBER-TO-FILE-NAME, and removes it from the list of changed tests. +(TEST.TEST-NUMBER-TO-FILE-NAME TEST-NUMBER) [function] +Returns a file name on which the test TEST-NUMBER is stored. The directory is the value of the global variable TEST.TEST-DATA-BASE-DIRECTORY. The the root name for test number 45 will be TEST00045. +The Concept Space Browser +To browse a concept space you can either select the submenu "Browse Concept Space", or by calling the function +(TEST.DISPLAY-CONCEPT-SPACE-BROWSER CONCEPT-SPACE REGION/POSITION DEPTH INCLUDE-TESTS) [function] +CONCEPT-SPACE must be of type CONCEPTSPACE. REGION/POSITION can be either a region or a position for the browser window. DEPTH is the depth of the lattice that will be displayed. If INCLUDE-TESTS is non NIL, the tests will be included as part of the displayed graph. Only the first argument is neccessary. +All the operations on concepts are done in PREFIX form - first you select the operation and then the argument (like all Lisp operations). Copy selection from a node will push the list of test numbers belong to this node into the current tty stream. The operations that are available using the concept space browser are: +Copy subtree : Allow you to copy a subtree from one displayed concept space to another one. Will prompt for selection of the new parent node and the root of the subtree. +Add Concept : Prompts for the parent of the new concept and for the name of the new concept. +Delete concept : Deletes the concept selected, and all its children which have the deleted concept as they only parent (and so on recursively). +Add Link : prompts for the superconcept and the subconcept and creates a link between them. +Delete Link : prompts for the superconcept and the subconcept and deletes the linkl between them. +Add test : Adds a test to a concept. Prompts for selection of the concept and for a test number. The test number can be a list of numbers, thus you can copy select tests from any node on any browser window. +Delete test : Will ask you to select a node and will add a menu with all the tests of the node so that you can select those you want to delete. +Edit test : Will ask you for selection of a node and will pop up a menu of all the tests in the selected concept. Will apply the test editor on the selected test. +Display - Display tests on/off : will switch the mode of display. You can either display the graph with the tests as part of it or only with the concepts. +Display - Browse subtree : Will ask you to select a concept and will aply the concept space browser on the subgraph for which the selected node is the root. +Display - Change depth : Will pop up a menu of integers. You can select the depth of the graph being displayed. +Display - Update : Recomputes the graph of the concept space and redisplays it. +Execute tests : Will execute all of the tests or part of the tests of the selected concept. Will pop up a menu to set the execution modes. +Hardcopy tests ; Sends a pretty printed hardcopy of all the tests (or the selecetd tests) of the selected concept. +data base - obtain lock : Tries to obtain lock on all the tests of the selected concept. +data-base - Release lock : Releases all the locks that the user has to tests belongs to the selected concept&H ) && MODERN MODERN MODERNMODERN .–Č<;IPQY[‚fÚ91@eŃ<GŐEœ›9~S[-b2  +I*‰'jJ9#ô,cb$q$—2+u;0˘1ĐW9Ž~289Ł:Œ40ą4-)4, 8Ęoe7A Ą TƒU WÉ † œ}…ZA +€eBUHŻđzş \ No newline at end of file diff --git a/internal/test/Tools/TestExec b/internal/test/Tools/TestExec new file mode 100644 index 00000000..910b82ce --- /dev/null +++ b/internal/test/Tools/TestExec @@ -0,0 +1 @@ +(FILECREATED "23-Sep-85 15:38:40" {DANTE}TESTEXEC.;8 5415 changes to: (FNS ADD-TO-TEST-SUITE END-TEST-BLOCK) previous date: "20-Sep-85 10:12:37" {DANTE}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 \ No newline at end of file diff --git a/internal/test/Tools/TestExec.LCOM b/internal/test/Tools/TestExec.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..febfe6e2a24f657f575fc37cdf3af1bee820d63f GIT binary patch literal 3615 zcmb7HU612t6}BC^U7)FwS%Dye?NNkUXC+6molHJjjpB`+iDw+!YdiB%wxZcMY@%l4 zQ6^Kdsw#oR1%IFd2?2s@kcOorQPFmOM3K1aFW_b`xZslW9y_120y-M`ef@s;Jm;L} zd_-)UmeKMIEiiP*D;3EZ%q69ylt8XDlv<-)%Y&F7L{HAflVJ$a6!MV%K=%(nd}|av z8SYK`v)R+V@nn2{wrAK!j=$G6{nlP!_`zNfMU(TrV0b<^eli>s-;@h@xh`pEGn7z5 z3AIK^Zm3Eg9x(xvH$oUsA)W6I!^!X|sKpAnn%9E%#bg5h)AQ(J4p5ft=zVryg<`Ro zhp<0KT>15NMa7RYxSU$HQ}&M-33$whx-FOMxRX6(zrC1_q=J8<*JoeamSb7T|0)e19BWoD;eR z+O@P4Tx!TlL#_Td!PP?gri{CKEiIZ*0um|NTGxO!zOGvkVsrEjcKEvam<{pjM>PLAJ--?6 z4!C#Ogy#oBGt-RNobF{fQ7+ZM@I1$ZngU(TJJkGEN3-{lYP%J<@APclg^B{c5kOgm zhsKd+9m$}Ums4eTajXiqrFHM?T2b@%ee`Ty2Fvu_laA>Jj&};xD(FVrwDIFr85VLX zbvV*Ib{=G;O#V?ng!7B>d({(^*cA*L;xC=|RoNiaMbstwski1AJJHSJU z0}^-CUf_=U3*5nHZwnmXOkM4eCD)9`lT-c~Tl+mSrM&L)^P4@5%&mZuDko%i;_3|Np_h*N%e=4M| z{?y$eakn^4ZyBJPa9)F=h1vgR;ZJ4kP9=~$|WNVVx^k61aslK6luQ~U|b<$rl5i;c+B9< zp}#^{+(Jfo7Vt3c1H+}D@(jOct-=YDm>L_>)DdPm#dFARp?R9R`r0_dBa?++@iAIP zO`q8I*8}0B&Vj)H>!;)2k20ok`2{C3zq1^{5(~pfFFhN}ot_}yv|N(UlO&)Zoe0+= z6HvTU{zX&|Qy7ZPY?klDs6HXHjS0)O$tROB+4MS_5zH9y+gGnGH`i|@2M=}-d`CFB z{39n;S?cgy&xEQ1IM^~EW#b7F?}jrN+mj2boSZ|Y>B7QMySwP9$IMGp7|v$V3`?kt zYpg{VQ4S%KFI_#L!WDU#E?4HYX?&4tIJl^dUL!!Dj;ciPrI zo=8-s7%rw>;`q_v*5LNwmFweI$3%^|gTMqtZ@pYLE0`27J9jR>n6YWSMcA{4VGw-pq7_vpo=83is)h#1gF^Cuxt@5W#9tqojg~2@L*#RM3GF? z)mon8vpUM^Agh5swwogBxj@|RO<8rr&Ht;3-bim7FL4ps$bNAfej{xy*n={4qh)EH z(SWq>V84$M+q4`_2i>7LQyhN?;j0}`E#h6WrsYJAuxYc!%DJ|?>nR%EYStCHUVisM#p#Q~fC1Xh|2gM~U{w=`lofh3* qfKlQ4OaD=8&{9OLT@SGE9MYFSL)}N1~Db|B}t%C4bW&aN$`cK9H literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TestExec.TEdit b/internal/test/Tools/TestExec.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..902c3b3a219fd45fc571093b830470005829d222 GIT binary patch literal 7726 zcmd5=-Etg96&}k8pe;fHfdZ;1Xj~BQR!J&LauhHwr#99)*+Q0#cAQ`?aJ6Q8wS#7- z*Yl&bLgfK?0WNt8u6PVy1Rj73zVCF;?Ch*S4%{HSq?w-X)2Gk*&Uen~a4-s0|Jk$C z!ErczJm`eeI9K>zOpTgnCW&Wps2t2nayo(+$8R1Z6do`H8sgxE#hLT3M`G&b1WGa{AeyA zqtr=qrQ)DY|1P@S99WV$d)r(>vMq7u(so2zbIsD&+)u{z^t)gLN7pC@r7r|3~~ zs$xux%8UxC9Op9_;dZ|-p?P9-mO=@2cBK}&h^BmAOm(3wECeH99~>Cwfv}HCER?ln zZYCv8l)?rO<;0$uNaF*iL{KI(a|1c%wT=oL=^CL^eQ6*$HBcWGH#_i-Q7wy#WpsW; zQ$YHby0WFyy||iVGpb-zWM?zjhknJLoZ{?4edx@w<-s_UCz1!}+X8;wa{jO>)P&+T ziZorU6DVI~x)M&`+Ui(Z1UYSFVQQSa^0|rP2?Qy5f{^xsCS@84%Fg3UY6W{yu~g4I zU@9fK**2hu1I(_s&3R_aIS$P;!BKeZR+i`yL{>iKTY{a&WQ0KVQRQWf^*CJL$$>w$ zlDUNMG(MlgEQk~!2Y6iWw3x=xRO!snErL|}s8u(g0mMBux0xK%M@oJL4QHZ>TS|}s zw^<2{0_<}lJ|$EpnVmK8heMeigvs$pJ&6-qY#e7MDlEd*q=;HX2i!%t`y%ETs#T~J3di(`}gL1%YobLgT% zumbIEHWpL(D5<U z$>%oBp{t+uWOy_feW)BI<-IL+hOKgoAgH(S$6Lw)@6tNp9PxgFzgt+t zK|~y&=vLso4l>J?UW3OcPoF`F>s4TYLwZ&wJ`l^}l= zlpy7c$q;c+$tfE$WR@915h}Hsn1#^Z+u7vC!15Uo$aq5_j+?2H zAk9Z0q~!7EHIFn6rMhMAvdiwhdkCB&i%ss~yo4={2&I-jVAiP|hJd=%aiY&)AWyul z(>>^n!p%_uC584RBwN_<-u0*g&NCz^ZrKv$jkLnsj^kh;N52#g@|ZE@AuN#TVGd82 zFo>QYcahNtVRarx1_t_vhuh)Fc8KC&d-Qx5E&<_0LXzi(hBO3AiZq0TK~Ml%a!ltR zYFVqLx?(h&fl_46at^FE&+IuC)AWOIa{%-5;5S+iF=P5G1lQ2TYy7}C(tiY+42lUvhsv3TQoX4)nfj&}{EaD__ z>NyEwHq>dCG1yYFrK21#Y*H2_LmYI+g?^38<}tt|(5nmzn1OLw0x>ExGqaM(XW%1! z0jo#`^M`Luh)j~`)KG_-=SaRTr!`Zp%LF`}aP>sWnySng8)AXz!eI$Mc$PIQz)c?~ z8Xm7L=Glm4kwC$WaZFBgGgts9luwQwL|=#PdP+%bFuuARVm*S*7$M?*xLvBaM!cb< zn#KT=)1@Gq)~36nkKs575e&odbOjx!CNGmWh>I0`Ah58=JD@&4%N1+dZ7L>DBc+yKR{Ia%2rnF^(r6#IfH$(Ms) zKkpw^>A9M2&k7x)?a8Q8>F%2wvPRI;`ijp*rY>LtLX?PJ8Nd|LHa4rgQTOY34^G(0F*cpz{(a^lPh z?H?V91;~c1jDbCk6e{%cpSwp#NbCdM26dgMlZC!Q)oQZ~&&mkk`l}41H1dTVVrebE zZT3@jeAIvX(P6*N<~{@KG1?~2Re;Y5WwS&i#}k3CN>ttOWOgo%GCjfQUdtv@d{l59n%Ce-SPwh`=s*aYRLYAobc}{34u$NcGZCChvwEqsn6(EtMwf>woj8TY ztOK2ymoY|?(x?t0{;EpmIT}v!#{}F2|1nb-HWfxa)6s=Kuj?N5Y5#Pjx`6oekB?r+ z3u0=l3$%4bRz`FttcHY9xmZG^j-X6^a&me){OD*@{an8Ni1G{Xph9XofzZpD!9u69n(`H{?k1Kyw0V_crr-wLexidj>6TFtQc?vJH zvX`S5L2rhlqs#u}czD!PmpZ{a*r2hwUyDp$Mj(b9**m#{Bt(YEGI$!HoD%}D&OD=M z#>%240g#l@=oUp4*9%Qh1?Q{QxY-U2BahF>3A^4NYoX?VMyNKd!4i{0Yw-u6t*QT& z;c6Mz+fA-&R@(-aq%+)-AxhZMfi@5vOl1@m5^s$z$bhMF3vvm@m-hJ3rgsYllhS9o zO?b!U%cH6-%8YP3T(>3jq@jlZ(o=Os!1Z^!pZ1TQ4^Ez_?Y-U|A)MvV{sD#%$t;B! zKhUwY&Hm5pa0C!sZ|Pmnx{$XO=(%xLcd1o#mrJj>lAA~k$zb;&E837bbY?W5f{*Z=&$Uiwl|8Yg#I;YqJs$(i&7N%`>N!?RhJ*nUYcGg8 zn1Oq8e^dlg2=KjqcvcE9ox9dq0vf8JF!l9~Db@tzXISM-?_L$ptvdzffK1*zL(b+$E`A~>pSDF&F`>3<} z?hW&(v;V>B%)Qpky?W-(&Q9n4y_YMkUI)EtYwP>F|4ym>Ry%$WZk9s4w6oXYCP@#YCu)g-9HSFLat2y#X~aRBmT-C zos1q;{_S;cnz8fC-4@CI&zR(eyo5$0kpPpszj)bQPwchvdYys0eMC@I>TmB}H@Mdc zI{|;*#=rN19|aHP4Zk*SRZp$Ik1*@E82cK>Z@(1;U*+rTAox=d{3Qtf76ktYZhfP* zsD9n@d(^9MEw`*E`3LI5ADO#>ov!_PuQ|GLyZP37ek<4r-VNUVxc~T*e(+BH@%zC$ z;qd8Tbb9i%e;j@b}ihh8PS}@w0({!R@2=j2Eo|=c>k%;GfMI)MG^kRKNAR<_r$pZ4PjW zX$}xcf~IO0z9`O+QRvCPo9%(GvR&iXPu;4}7~l@PDhAV7F=0 wZd>)AwFlOg2!fh2)(mv7E#s%nfj9I1Pnt`(+jnmq5b!h<`@ySV_W57`1*c*FO8@`> literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TestUtils b/internal/test/Tools/TestUtils new file mode 100644 index 00000000..c21bfe4e --- /dev/null +++ b/internal/test/Tools/TestUtils @@ -0,0 +1 @@ +(FILECREATED "20-Sep-85 09:23:53" {DANTE}TESTUTILS.;2 1077 changes to: (FNS PRINT-TEST-ARS) (VARS TESTUTILSCOMS) previous date: "19-Sep-85 17:02:23" {DANTE}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 \ No newline at end of file diff --git a/internal/test/Tools/TestUtils.LCOM b/internal/test/Tools/TestUtils.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..55ef7cffa70794d6a65a632c5890e3f964e47a51 GIT binary patch literal 923 zcmaJ=Uu&CC98I&QZ3r!U9|vJn9~7^NiP|EQ#I~|Tt@ox)AJaq{HxolNg;L7C#y-Yi z?0H{lA7NM1ly;2ypuc-K=XZX8uF{D=@OrW5GOrI&HpLgS(qiR!!9_@&p-+1b^C)vzo@a%_lA;`yX;!F5 zMCNKsaaU_@p>Ye-)`;EGMO;@7+2IW75`s8PW?6EFmTDk!;~q{nSq6Gn03}$Rm5yk^1{UDxZdJP?Y1e(g7mUKO`*w3F%4*z%~=NT?!NB^%zHSd7hW8ML0$TY z`2(sR=^$FSi|Kr_yh#d_xee(gpon5WU`o}a;>J{lBwX+>Dxg;O!XZaj>*O}gH$`2c z4Ut$obJDdno%{dSoXEmUAH46If)s(kM+6O&xokxFfuL%V2O2K@pdVh!Xnbup8qI_K z#(ezoroo>#)$4mY+dJ6X^P4qvc=r3phh02&YsRm<;yuRh>*}zDc0BiOjeU8fJi%M_ zR`IU+>gTulenTR}nS7}+*tJj7GJ6Ez^9C7K)1~o z>W|TpVHgnY>cT{^$JiBLVLko7mMTbb)PZ5vz)Qb~VroqpR3IJ!Aa0 b8hdd#MlWBl^7W)l^Q8!4nFdz|{y_KxB^c)E literal 0 HcmV?d00001 diff --git a/internal/test/Tools/TestUtils.TEdit b/internal/test/Tools/TestUtils.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..c2a718b349e2be7297afc304ce67ea9188aa7a81 GIT binary patch literal 1695 zcmZ`&O>f&q5Z%ZQ&1au9m0mD?NvAV&jSO3=cTxq!0vumoYGWMEZF0ji5Cg%RV@ zywoDIN;f1zw8ru}=Q{WNu-iTwk1v8XFXrIgxXc9(15(8_!{*v7a?;@NvjIufS|ve(2Xyn#CT6xaD!H$E4kWw0+gdN zD6H465-8Qy-h=Qol~Hl5zdMJO4K&EW3IfSfA*IM+g5rOWI9z#|$+RQ%LLHr7Th$gv zwQaCGEIC+2b66{ZqUzeZcE9KGl|kjOmP^9Bn3MnEb=4I7~;AIyUYgd}rpp$zuV zipq4J(nR2XD%u1PO=eP^Ex9R_llg$wC~XmyHk6cg1_E@9@T*c|9<=QR`YG`NSsF`8 zM>Qy&W5?Q2BMTI4mHrblrD1 zaj8HBfs;;iY>PqTF^dpeT!VPas}0R9UI8Nx!SDu=+NbP_qV&-nGr&2yY+t|2B)Jhh%K+tId3mHwv#81tD`9)1cnaU#Io; zvG$qg3ca{_ks-J`i=LicP2uN%p2aWzeKL>Y%hPB+i+@dK=a&x#$JhyvBc<$Ec z;V?Sd8~zQ}H&J&6J6|sM*&h3W-A|(PS-iYB4;SqI4stVoZx{cK9S6^5r{T+aa(b~y z;247E;nTAaj(@>nYnLauN@mORXc5lgWI7$t63+-_8GFz!+c#D0Gab=CBIx_BUAFK4 fArLUTILITIES>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}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 \ No newline at end of file diff --git a/internal/test/Tools/VARBROWSER.LCOM b/internal/test/Tools/VARBROWSER.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..77a07d3fd5a50cf4b318bb1a96ffc7dd10b404bc GIT binary patch literal 7930 zcmeHM&2JmW6(=btaTLpt9Kvvgz! zQIKS(Mo~1)A5b8d7VW7(doE-ry7Y_J=F(FNsOhEXztCO__xEOYsTF0ZHBg{EcwuvA z-n@BV^S)-4tXQ^LZkf7k8kEp-DY0>o($ZR*G;Kbs&1Ys3luT^&KG@yvZhF+)p#+V6 z&uG`b|IMx52b&As+k1PD7Ph01RceV&+iXpL zBQu5Vg_OR#2OjA(W#;D78L&yv9cIz}x<}hPG?r*=dfm-Ol%38~Q*V{2@}S$L_M`pY zg9D;m%IQ7i{aKoxo=%W=`v8(9!f-9ivghU!Q)9`~3Tmm^gKlarPnqnzHZz~iCrD{y zTkR&JwilLN%eGt#qp;{2Wwdl5M;lwWci!LJr-R-+B`Z#w#!j$kr8KQ11V3mb~CC3n*DN2F{76+Cpi-yE)=`RsB zDUq28YopC;+5c3V%v4zHo5tK&vWe4R5mGC#USMT$0_wp#e?!4SLexl%?UiTN|>ovK0xo`fm`_i4!e&uLZf+vb& z#lx?9(e=rwB(@&!i|a?Piul&#`i+l8{MP#Qer)9Euj0lvMgNM~ZItEk%R8f$Zo^RH zja$XCDS5o-DN2gmRj)gG+_`o9t{r`uCHQB)x82j358` z+xNuypT4CZ6>FX3mgn_&%b47_=9P|Kk#os#)sy0%s8+O{iMOtanmmvUat=AIWr%RuD{*yjtHtsRr*F%GV6=CqyA`1z5Ul@=a!(!t;xwP zDVhAKj=jWu`yx@5tBR6%+l$4X#G(88H6|yNIS=E?Sf7morYwf#gumJsH)HEJA$)B8 zjlQ797wgo2{PbodnVW;_m8O@Q29mDyNy^P?WFqb;H=|KWEIS6=Kc6G^pjt{O%gIo7CdW(CwX=Cdh*&XQLD^iI zn#-=rL(P^zoN3r{3ZfNeNM$uY&NN6ngp$wuC>_#3a?x~4V%0~_6bfXU&Z1jI2AQFf z%D3g663hRRj5Tz`kvd&g?%iza3ANHG5{k!ErlcIqvk4r~;fAprGe(_W*wS#lWO zCeUQvl^#%A&YGm10%y_+jH;2%=0k_1+qR#;v*2W|Hg(6SIFtpWlamY~WpX5%rUMjh zW;UcuDCuKGBc1~(Gp8~S&1N`tQEm=SU>i7Ys+u+q$|~!eeHV2o1K}u_E>IGOI)zb= zk}dWaLUGmdX-cfz-n+Bc`*44Ak3QVq@p>O7pk|H|?cL3d?Yoa?x3|B2u#HN7x3@_Eft$!Rn6p5?TcTc*z)W(hl|Ji39Q!ny<*d#EA@ zwNFDiK;1({QC0ACQs+9uMJ1>@X+oWAs)8a5lttRv5`#Tl6a9K}LD4{AaK<8$k%{Id zX_1NaE5*YtFFFyuEXHHeCk_6UCR5ABD-1ZCLh8RE!MaR!-OI0tur{bzwTw}hEBYnyEJDdpLlCx7kL;+Oi~{rJm$PmhoHz3upwzA6s!>wQ%T;uH+t z=-=~pe(=;|CzSC5bOy+Q4<24?u}ef#g9-2ce_%Z>gSbw)mZ{In>p!jm|21(^qq zqjExF)*m4L+AfmgqB>Mgigg8`Y}VfgchZnlW%AX4;WtG*M`Usi&~md>wp+-ZjiyVP zT#hb{@UpwsG~YssmH{pMAP!s&fTXQAN`_8J?v#j}VkrrSJ z4NOEnQ7pAsOI=#-1iIPX--P7IkQQG_d>z-9jF4JNH<$)h~6Vu)*SE-b;| zh{9U~M<_v(x+KX`kD+(W;9`SY%(JRYkhw@WejCx`OzbzcDnla)>#;~AIx!w8%G4qA z#9@jfJZkxobtxK)u6iS%L|0`l`RsC4z9s7G$PZr>5le9X6Cv1(D4+3rmTb_n;AViz z&u1Vy%ee4yL%|UQ_va1jiU2@ZAGzYIl2wO*vMk-7ldiHjE2hXoEmRnpsksg3-O%wD zmm-naL^@Vfsp8U_sxPaSROG(YgMa@?)Djl_l6RH^_mrG{_$~ z1#~9T_~d%A;ETW_^B}V zv%zBtdzg%)&_$(Y*F$RoxYQ^=3mn4ap~MF9>X0lYMcfCMgI%>#;8L+vH1wiTya;?k z{2VF(LuaEHP^s1HWz2@b^-`^B=;q=nQBH`Lpn%S6zAT`^Dh-3{wVH04LsSOpmvo`? zqeKC5P%#`(IR#JHpi-%xPbIKrAWE^O!;mbBd?Xme>-BmA!kpIVM3z(N5T#sa*Emf@ ziUNIxh=k2z=%Q+r0^?R|6-!b%4ThSHGgQK&sM81}uhnZT9b^f?6Sh^Wot0%kr7WsC zwhX+bZdt6*X)xQoWR@^6)nZ{=$GO;NWgbWzk$~$v+b&6RVqhz3)=Fx3}BdyUky`6Zq5ITppJ|d@>sQ E7qt+;;{X5v literal 0 HcmV?d00001 diff --git a/internal/test/Tools/sloop.lisp b/internal/test/Tools/sloop.lisp new file mode 100644 index 00000000..b0b86f11 --- /dev/null +++ b/internal/test/Tools/sloop.lisp @@ -0,0 +1 @@ +;;; -*- 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: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) \ No newline at end of file diff --git a/internal/test/admin/ManualManual.tedit b/internal/test/admin/ManualManual.tedit new file mode 100644 index 00000000..560426e9 --- /dev/null +++ b/internal/test/admin/ManualManual.tedit @@ -0,0 +1,206 @@ +Lyric Manual Test procedures + +Filed as: {Eris}Admin>ManualManual.tedit + +This document is a part of the procedures describing how to run tests on the Xerox Lisp Environment. The following is a list of the tests that must be run by hand. These are of two types. 1. Those that are run via the do-test software and thus automatically log errors. These are denoted by a .u extention. 2. Those that must be manually logged. + +Running interactive regression tests using do-test + +1. Bring up the LISP.SYSOUT to be tested. + +2. In an XCL executive window, load DO-TEST by typing (LOAD "{ERIS}INTERNAL>LIBRARY>DO-TEST.DFASL") + +3. To run tests using DO-TEST, type (DO-ALL-TESTS :PATTERNS '("filenames") :RESULTS "{Eris}SubSystemName>SubsystemName.log") + +For example, to run all the interactive tests for the debugger and put the results in a file named debugger.log, do the following: + +(DO-ALL-TESTS + :PATTERNS '("{Eris}Env>Debugger>Hand>*.u;") + :RESULTS "{Eris}Env>Debugger>Logs>Debugger.log") + +Note the importance of using the terminating semicolon on test file names. Not supplying the semicolon makes it run all versions of that file name! + +See {eris}internal>library>do-test.tedit for the full list of features. + +Helpful utilities: + +(IL:FILESLOAD WHO-LINE) ;each field is active to help change them. +(IL:FILESLOAD FILEWATCH) ;use background menu to turn on a monitor of what files you have open + + +SUCCESS / FAILURE prompt windows + +Some tests will pop up a prompt window requesting certain actions and to look for certain results. At the top of the window are the words SUCCESS and FAILURE. If the results of the test are as prompted, select SUCCESS otherwise select FAILURE. You may move and shrink this window, but do not close it. + +Before this window is popped up, you will be asked if you want a SHORT, MEDIUM, or LONG test and you will be presented with a menu. A short test will only test high priority items. LONG will test all cases. + +Reporting results + +After running a test for a subsystem, shift-select the log file into a message and address it to: John Sybalsky, the appropriate developer, and the test writer. + +Here is a lafite-form for this purpose: + +Subject: Test results for >>subsystem name<< +To: >>developer<<, >>test writer<<, >>documenter<< +cc: Sybalsky.pa + +>> test log << + +LIST OF MODULES TO BE TESTED: + +EXEC - Tests written by John Park + + Location of Old Detailed Test Procedures: {eris}env>exec>hand>test.proc + Approximate time to run test: < 1 hr. + + Note: + +You cannot use do-all-tests with the Exec test suite. You must instead: + +(DO-TEST-FILE '{Eris}Env>exec>Hand>FOO.u) + +where FOO is the name of each .u file in the directory. + +These are automatic tests, which feed the input into exec via bksysbuf. Test results are automatically logged in {eris}test>exec>test.report, but you must make sure a new version of the file exists before you run the tests. + +Be sure the exec is in the XCL-TEST package. + +While running these tests you must not place the caret outside of the exec or do any other work while the tests are running. + +1108 Regression tests assigned to Norm Schuster, 3/18/87. + +DEBUGGER - Tests written by Kirk Kelley + Relevant developer: Andy Daniels +(DO-ALL-TESTS + :PATTERNS '("{Eris}Env>Debugger>Hand>*.u;") + :RESULTS "{Eris}Env>Debugger>Logs>Debugger.log") + Approximate time to run test: < 1 hr. + + Note: These are a mixture of automatic tests and those that require interaction. Some of them intentially pop up break windows since this tests break windows. If in the process of testing you get a break window that is not obviously part of the test, uparrow out of it (type an ^ or use the one from the title menu) and the next test should appear. + +These tests were generated (and run) on an 1108. + +Regression tests assigned to Masa Tateno, 3/18/87. + +DEDIT - Tests written by Henry Cate + Location of test file: {eris}env>DEdit>hand>*.u + Location of log file: {eris}env>DEdit>logs>DEdit.log + Approximate time to run test: < 1 hr. + +1108 Regression tests assigned to Albert Sahim, 3/18/87. + +DISPLAY - Tests written by Peter Reidy +Location of test procedure: {eris}i/o>display>hand>cursor.proc +Location of test source code (used by both cursor.proc and cursor.test: {eris}i/o>display>hand>cursor.test + Location of log file: {eris}i/o>display>logs>cursor.log + + +HARDCOPY - Tests written by Peter Reidy + Location of test plans: {erinyes}lisp>lyric>plans>fx80driver.plan, 4045xlpstream.plan, press/interpress.plan + Location of test procedure files: {eris}i/o>hardcopy>hand>fx80driver.proc, 4045xlpstream.proc, press/interpress.proc + Location of log files: {eris}i/o>hardcopy>hand>fx80driver.log, 4045xlpstream.log, press/interpress.log + Location of test code: {eris}i/o>hardcopy>hand>streamtests.u + Location of test cases: {eris}test>streams> + +Regression tests assigned to >>NAME<<, >>DATE<<. + +KEYBOARD - Tests written by Henry Cate + Location of test file: {eris}i/o>Keyboard>hand>*.u + (As of march 10th, there are 4 tests.) + Location of log file: {eris}i/o>Keyboard>logs>Keyboard.log + Approximate time to run test: about 15 minutes. + +Regression tests assigned to Albert Sahim, 3/26/87. + +PROGRAM ANALYSIS - Tests written by John Park +(Subsystems: Masterscope, Databasefns, Browser, Spy, and Inspector) + +Masterscope + Location of test files: {eris}env>program-analysis>hand>masterscope.u + Location of log file: {eris}env>program-analysis>logs>masterscope.report + Approximate time to run test: 7 minutes. + +Databasefns + Location of test files: {eris}env>program-analysis>hand>databasefns.u + Location of log file: {eris}env>program-analysis>logs>databasefns.report + Approximate time to run test: 3 minutes. + Note: The data file used by this test is in {eris}env>program-analysis>hand>databasefns.data + +Browser + Location of test files: {eris}env>program-analysis>hand>browser-part1.u + {eris}env>program-analysis>hand>browser-part2.u + Location of log file: {eris}env>program-analysis>logs>browser.report + Approximate time to run test: 8 minutes. + Note: There are two test files for browser testing. Part 2 must be executed after Part 1. + The data file used by this test is in {eris}env>program-analysis>hand>browser. graph + +Spy + Location of test files: {eris}env>program-analysis>hand>spy.u + Location of log file: {eris}env>program-analysis>logs>spy.report + Approximate time to run test: 5 minutes. + +Inspector + Location of test files: {eris}env>program-analysis>hand>inspect.u + Location of log file: {eris}env>program-analysis>logs>inspect.report + Approximate time to run test: 8 minutes. + Note: A fatal bug was discovered - Inspect never returns when *random-state* is inspected +(AR # 8203). + +Regression tests assigned to Norm Schuster, 3/26/87. + +PROGRAM SUPPORT - Tests written by John Park +(Subsystems: DWIM, and PRETTYPRINT) + +DWIM + Location of test files: {eris}env>program-support>hand>dwim.u + Location of log file: {eris}env>program-support>logs>dwim.report + Approximate time to run test: 2 minutes. + Note: The DWIM test is executed by entering (DWIM-TEST). SEE the test file for more info. + +Printing Out Function Definitions (PRETTYPRINT) + This test is covered by PP and other subsystems of Exectutive Test . + (See {eris}env>exec>hand>pp.u and also see.u, see-without-comment, ty.u and type.u + in the same directory) + + +PROCESS CONTROLS (PSW) - Tests written by John Park + + Location of test files: {eris}env>process-controls>hand>psw.u + Location of log file: {erinyes}env>process-controls>logs>psw.report + Approximate time to run test: 2 - 10 minutes. + + + SEDIT - Tests written by Henry Cate + For SEdit test, load TEdit. Then change packages with: (cl:in-package 'xcl-test) + For do-all-tests, it may work better if the semicolon is not used. + Location of test file: {eris}env>code-editor>hand>*.u + (As of march 2nd, there are 21 tests.) + Location of log file: {eris}env>code-editor>logs>SEdit.log + Approximate time to run test: about a day. + +1108 Regression tests assigned to Albert Sahim, 3/18/87. + +INSPECTOR - Tests written by Lois Lew + Location of test files:{eris}env>env>inspector>hand>inspect-allrec.tedit +{eris}env>inspector>hand>inspect-defstruct.tedit +{eris}env>inspector>hand>inspect-macro.tedit +{eris}env>inspector>hand>inspectw.tedit +{eris}env>inspector>hand>inspect-code.tedit +{eris}env>inspector>hand>inspectfieldflg.tedit + + Location of log file:create one at: +{eris}env>inspector>logs>inspect-allrec.log +{eris}env>inspector>logs>inspect-defstruct.log +{eris}env>inspector>logs>inspect-macro.log +{eris}env>inspector>logs>inspectw.log +{eris}env>inspector>logs>inspect-code.log +{eris}env>inspector>logs>inspectfieldflg.log + + Approximate time to run test: ? + + Note: use shift select to copy the material marked to be typed into the appropriate exec window. + +Regression tests assigned to Masa Tateno, 3/26/87. +,,,,,  HELVETICA  HELVETICA  TIMESROMAN  TIMESROMAN  TIMESROMAN ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))  HELVETICA  HELVETICA  HELVETICA . _  3*n?  +ƒ38JKRC E   ! 1Ń Ą(-4 "P '    I  0  8  í  /   9(#  3 8 '  _  1  3$  %    9& E q  +     (u } o E 8  1' "*  +    4/D O Q *  O Q * c Q 9 M * \ ] G I *  K M * [  5 .$G I * Z  0G Z   4F L /  $U F  %*  +  +  9 &R 7 3 . 2 5  ' 2 5 1 , 0 3  #  d  3#ĺÍzş \ No newline at end of file diff --git a/internal/test/admin/Running-AR-Test-Cases.TEdit b/internal/test/admin/Running-AR-Test-Cases.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..c8608897090ad82a16877d3dbba431a536b91815 GIT binary patch literal 1390 zcmbtS&2G~`5Z)vWB36J42LzWPtq_qyL<96f6)8ZFkOHaP0OzeesjWD>(e4_nJOz)! zndjhvm{~g{DNun}OWxV}`@Z=JbEQ&s4x-0e>q*aLZw`?W53wl1m~~Ah9#K^2}`>MTjxR{lHg9>7O#jGyWZ|fvN`m7t)+s#4uDM73K=P zX_xWs2b595>{Fr!nLdX(Mf5;sng&y(E`bZ38}5torNBe0sTx=)T|kj&Fj7J4x)eeK z<4H!jF{r37=@Kt_qw1FZCNhjgZYD)bI9Uc~$S9OULvYw_&5Vo|I|;3mF1I`-h9S<5 z*D2z4^60^!+d470;zeK&nXMA}$UFJMXeckxRT_hmb`NRM41P+n=m%l7r_$#QJ|?KR z_G)T7cs*EUNVtAo7|QPp<=k+LyC8NkNE=@mPrCD?-UMtjrWb+-m;) z?d|l{ID99rmv#c(=x&s{`fqe(+4y8n1H*yjpR$6Ydz^@N1{H5<~+m~a$ZYwz3(Pf1n#yUOIxWyjZWZzdIjkdV^`P&Z| Cl^LJ_ literal 0 HcmV?d00001 diff --git a/internal/test/env/DEdit/high-level.u b/internal/test/env/DEdit/high-level.u new file mode 100644 index 00000000..e2d389a3 --- /dev/null +++ b/internal/test/env/DEdit/high-level.u @@ -0,0 +1 @@ +;; Being tested: DEdit ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 2, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DEdit>high-level.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Just touch various commands" :before (progn (setq window-list (do-test-menu-Setup "Various commands in DEdit"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Test able to bring up SEdit" (let* ((user-result (do-test-menu-Message window-list 'high " Test able to bring up SEdit If there is no free Interlisp exec, bring up a another one. In the Interlisp exec type: (FILESLOAD dedit) (EDITMODE 'DEDIT) (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ED 'tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Now try placing something after" (let* ((user-result (do-test-menu-Message window-list 'high " Now try placing something after Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice on the litatom \"efg\". Type \"h\" and press the carriage return. Select the first option on the DEdit menu, \"After\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try placing something before" (let* ((user-result (do-test-menu-Message window-list 'high " Try placing something before Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice with the left mouse button on the litatom \"bye\". Type \"Good\" and press the carriage return. Select the option on the DEdit menu, \"Before\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|Good| il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try deleting" (let* ((user-result (do-test-menu-Message window-list 'high " Try deleting Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (Good bye) \"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice with the left mouse button on the litatom \"Good\". Select the option on the DEdit menu, \"Delete\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try from XCL-text" (let* ((user-result (do-test-menu-Message window-list 'high " Try from XCL-text Close the old DEdit window. If there is no free Xerox Common Lisp exec, bring up a another one. In the Xerox Common Lisp exec type: (cl:in-package 'xcl-test) (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ED 'tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test replace" (let* ((user-result (do-test-menu-Message window-list 'high " Test replace Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(ED 'tempx)\" Click twice with the left mouse button on the litatom \"efg\". Type \"gfe\" and press the carriage return. Select the option on the DEdit menu, \"Replace\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd gfe "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test switch" (let* ((user-result (do-test-menu-Message window-list 'high " Test switch Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd gfe \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(ED 'tempx)\" First click the litatom \"efg\" with the left mouse button. Then click on the number \"4.5\". Select the option on the DEdit menu, \"Switch\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 gfe 6/7 a cd 4.5 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try with dv." (let* ((user-result (do-test-menu-Message window-list 'high " Try with dv. Close the old DEdit window. In the Xerox Common Lisp exec type: (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "parenthesize" (let* ((user-result (do-test-menu-Message window-list 'high " parenthesize Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(il:dv 'tempx)\" Click twice with the left mouse button on the string \"hello\". Select the option on the DEdit menu, \"()\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Un parenthesize" (let* ((user-result (do-test-menu-Message window-list 'high " Un parenthesize Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg (\"hello\") \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(il:dv 'tempx)\" First click the list \"(b)\" with the left mouse button on the \"(\". Select the option on the DEdit menu, \"() out\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Now try editing a function" (do-test-menu-Message window-list 'high " Now try editing a function Close the old DEdit window. In the Xerox Common Lisp exec type: (defun temp-silly-bottom-fun (a b c) (list a b c)) (defun temp-silly-fun (a b c) (temp-silly-bottom-fun a b c)) (ED 'temp-silly-fun) Were you able to get this far? ")) (do-test "See if find works." (do-test-menu-Message window-list 'high " See if find works. Assuming DEdit is editing the function temp-silly-fun Click twice on the first occurance of the litatom \"b\" Select the option on the DEdit menu, \"Find\" Did DEdit find the second occurance of the litatom \"b\"? ")) (do-test "Test swap" (do-test-menu-Message window-list 'high " Test swap Assuming DEdit is editing the function temp-silly-fun First click with the left mouse button on the first occurance of the litatom \"b\" Then click on the second occurance of the litatom \"c\" Select the option on the DEdit menu, \"Swap\" Did the solid underline and dotted underline switch places? ")) (do-test "Test reprint" (do-test-menu-Message window-list 'high " Test reprint Assuming DEdit is editing the function temp-silly-fun Select the entire function by clicking on the first \"(\" with the left mouse button. Watch carefully, Select the option on the DEdit menu, \"Reprint\" Does the function get reprinted? (Do the underlines get reprinted?) ")) (do-test "Test editing of other functions" (do-test-menu-Message window-list 'high " Test editing of other functions Assuming DEdit is editing the function temp-silly-fun Click with the left mouse button on the function call to \"temp-silly-bottom-fun\" Select the option on the DEdit menu, \"Edit\" Does the second function come up in DEdit? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the DEdit window by selecting Exit from both option window menus as they appear.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/DEdit/high-level.u.~1~ b/internal/test/env/DEdit/high-level.u.~1~ new file mode 100644 index 00000000..a5abaff6 --- /dev/null +++ b/internal/test/env/DEdit/high-level.u.~1~ @@ -0,0 +1 @@ +;; Being tested: DEdit ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 2, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DEdit>high-level.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Just touch various commands" :before (progn (setq window-list (do-test-menu-Setup "Various commands in DEdit"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Test able to bring up SEdit" (let* ((user-result (do-test-menu-Message window-list 'high " Test able to bring up SEdit If there is no free Interlisp exec, bring up a another one. In the Interlisp exec type: (FILESLOAD dedit) (EDITMODE 'DEDIT) (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ED 'tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Now try placing something after" (let* ((user-result (do-test-menu-Message window-list 'high " Now try placing something after Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice on the litatom \"efg\". Type \"h\" and press the carriage return. Select the first option on the DEdit menu, \"After\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try placing something before" (let* ((user-result (do-test-menu-Message window-list 'high " Try placing something before Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice on the litatom \"bye\". Type \"Good\" and press the carriage return. Select the option on the DEdit menu, \"Before\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|Good| il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try deleting" (let* ((user-result (do-test-menu-Message window-list 'high " Try deleting Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (Good bye) \"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice on the litatom \"Good\". Select the option on the DEdit menu, \"Delete\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try from XCL-text" (let* ((user-result (do-test-menu-Message window-list 'high " Try from XCL-text Close the old DEdit window. If there is no free Xerox Common Lisp exec, bring up a another one. In the Xerox Common Lisp exec type: (cl:in-package 'xcl-test) (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ED 'tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test replace" (let* ((user-result (do-test-menu-Message window-list 'high " Test replace Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(ED 'tempx)\" Click twice on the litatom \"efg\". Type \"gfe\" and press the carriage return. Select the option on the DEdit menu, \"Replace\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd gfe "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test switch" (let* ((user-result (do-test-menu-Message window-list 'high " Test switch Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd gfe \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(ED 'tempx)\" First click the litatom \"efg\". Then click on the number \"4.5\". Select the option on the DEdit menu, \"Switch\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 gfe 6/7 a cd 4.5 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try with dv." (let* ((user-result (do-test-menu-Message window-list 'high " Try with dv. Close the old DEdit window. In the Xerox Common Lisp exec type: (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "parenthesize" (let* ((user-result (do-test-menu-Message window-list 'high " parenthesize Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(il:dv 'tempx)\" Click twice on the string \"hello\". Select the option on the DEdit menu, \"()\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Un parenthesize" (let* ((user-result (do-test-menu-Message window-list 'high " Un parenthesize Assumping DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg (\"hello\") \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(il:dv 'tempx)\" First click the list \"(b)\". Select the option on the DEdit menu, \"() out\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Now try editing a function" (do-test-menu-Message window-list 'high " Now try editing a function Close the old DEdit window. In the Xerox Common Lisp exec type: (defun temp-silly-bottom-fun (a b c) (list a b c)) (defun temp-silly-fun (a b c) (temp-silly-bottom-fun a b c)) (ED 'temp-silly-fun) Were you able to get this far? ")) (do-test "See if find works." (do-test-menu-Message window-list 'high " See if find works. Assumping DEdit is editing the function temp-silly-fun Click twice on the first occurance of the litatom \"b\" Select the option on the DEdit menu, \"Find\" Did DEdit find the second occurance of the litatom \"b\"? ")) (do-test "Test swap" (do-test-menu-Message window-list 'high " Test swap Assumping DEdit is editing the function temp-silly-fun First click on the first occurance of the litatom \"b\" Then click on the second occurance of the litatom \"c\" Select the option on the DEdit menu, \"Swap\" Did the solid underline and dotted underline switch places? ")) (do-test "Test reprint" (do-test-menu-Message window-list 'high " Test reprint Assumping DEdit is editing the function temp-silly-fun Watch carefully, Select the option on the DEdit menu, \"Reprint\" Does the function get reprinted? (Do the underlines get reprinted?) ")) (do-test "Test editing of other functions" (do-test-menu-Message window-list 'high " Test editing of other functions Assumping DEdit is editing the function temp-silly-fun Click on the function call to \"temp-silly-bottom-fun\" Select the option on the DEdit menu, \"Edit\" Does the second function come up in DEdit? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the DEdit window by selecting Exit from both option window menus as they appear.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/DEdit/high-level.u.~2~ b/internal/test/env/DEdit/high-level.u.~2~ new file mode 100644 index 00000000..e2d389a3 --- /dev/null +++ b/internal/test/env/DEdit/high-level.u.~2~ @@ -0,0 +1 @@ +;; Being tested: DEdit ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 2, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>DEdit>high-level.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Just touch various commands" :before (progn (setq window-list (do-test-menu-Setup "Various commands in DEdit"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Test able to bring up SEdit" (let* ((user-result (do-test-menu-Message window-list 'high " Test able to bring up SEdit If there is no free Interlisp exec, bring up a another one. In the Interlisp exec type: (FILESLOAD dedit) (EDITMODE 'DEDIT) (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ED 'tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Now try placing something after" (let* ((user-result (do-test-menu-Message window-list 'high " Now try placing something after Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice on the litatom \"efg\". Type \"h\" and press the carriage return. Select the first option on the DEdit menu, \"After\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try placing something before" (let* ((user-result (do-test-menu-Message window-list 'high " Try placing something before Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice with the left mouse button on the litatom \"bye\". Type \"Good\" and press the carriage return. Select the option on the DEdit menu, \"Before\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|Good| il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try deleting" (let* ((user-result (do-test-menu-Message window-list 'high " Try deleting Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (Good bye) \"hi\" (b) cd 4)) In an Interlisp exec type: \"(ED 'tempx)\" Click twice with the left mouse button on the litatom \"Good\". Select the option on the DEdit menu, \"Delete\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try from XCL-text" (let* ((user-result (do-test-menu-Message window-list 'high " Try from XCL-text Close the old DEdit window. If there is no free Xerox Common Lisp exec, bring up a another one. In the Xerox Common Lisp exec type: (cl:in-package 'xcl-test) (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ED 'tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test replace" (let* ((user-result (do-test-menu-Message window-list 'high " Test replace Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(ED 'tempx)\" Click twice with the left mouse button on the litatom \"efg\". Type \"gfe\" and press the carriage return. Select the option on the DEdit menu, \"Replace\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd gfe "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test switch" (let* ((user-result (do-test-menu-Message window-list 'high " Test switch Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd gfe \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(ED 'tempx)\" First click the litatom \"efg\" with the left mouse button. Then click on the number \"4.5\". Select the option on the DEdit menu, \"Switch\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 gfe 6/7 a cd 4.5 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Try with dv." (let* ((user-result (do-test-menu-Message window-list 'high " Try with dv. Close the old DEdit window. In the Xerox Common Lisp exec type: (SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Click on the last option in the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "parenthesize" (let* ((user-result (do-test-menu-Message window-list 'high " parenthesize Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(il:dv 'tempx)\" Click twice with the left mouse button on the string \"hello\". Select the option on the DEdit menu, \"()\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Un parenthesize" (let* ((user-result (do-test-menu-Message window-list 'high " Un parenthesize Assuming DEdit just finished editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg (\"hello\") \"BYE\" (bye) (\"hi\" (b) cd 4)) In the XCL-test exec type: \"(il:dv 'tempx)\" First click the list \"(b)\" with the left mouse button on the \"(\". Select the option on the DEdit menu, \"() out\" Select the last option on the DEdit menu, \"Exit\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Now try editing a function" (do-test-menu-Message window-list 'high " Now try editing a function Close the old DEdit window. In the Xerox Common Lisp exec type: (defun temp-silly-bottom-fun (a b c) (list a b c)) (defun temp-silly-fun (a b c) (temp-silly-bottom-fun a b c)) (ED 'temp-silly-fun) Were you able to get this far? ")) (do-test "See if find works." (do-test-menu-Message window-list 'high " See if find works. Assuming DEdit is editing the function temp-silly-fun Click twice on the first occurance of the litatom \"b\" Select the option on the DEdit menu, \"Find\" Did DEdit find the second occurance of the litatom \"b\"? ")) (do-test "Test swap" (do-test-menu-Message window-list 'high " Test swap Assuming DEdit is editing the function temp-silly-fun First click with the left mouse button on the first occurance of the litatom \"b\" Then click on the second occurance of the litatom \"c\" Select the option on the DEdit menu, \"Swap\" Did the solid underline and dotted underline switch places? ")) (do-test "Test reprint" (do-test-menu-Message window-list 'high " Test reprint Assuming DEdit is editing the function temp-silly-fun Select the entire function by clicking on the first \"(\" with the left mouse button. Watch carefully, Select the option on the DEdit menu, \"Reprint\" Does the function get reprinted? (Do the underlines get reprinted?) ")) (do-test "Test editing of other functions" (do-test-menu-Message window-list 'high " Test editing of other functions Assuming DEdit is editing the function temp-silly-fun Click with the left mouse button on the function call to \"temp-silly-bottom-fun\" Select the option on the DEdit menu, \"Edit\" Does the second function come up in DEdit? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the DEdit window by selecting Exit from both option window menus as they appear.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/DEdit/report.TEdit b/internal/test/env/DEdit/report.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..39beb0a0177124d7abfb5cd4fe31c645b1161e41 GIT binary patch literal 1073 zcmah`O>fgc5M2Tsu;>LLfjEuCC6Sy6_dpG*jNI61gOU^_E?l@6XOgVy?3&$m)9~@f z_;t)WNs}swtmWO=H*db)M)8;%FsKbEETl4ylgzkYUx2KMRFz-DLUChIKq|(7x0sa% z$50kvBy{kbDpR$DW8VeuoqqySfSDnj_Lhog!C9(#rh`tI=dICF%hJFU1*+7hIQE(! zQ_=KKTDCZ@x+(HhtZLtH=Vz?ASfc)Yno!e0kLw~>)%ZjaI*9B*ElNwfMa zGXg67_Z;hfJ4IN`*ga^Va~7<3`R91WdAq>eK(Mqjwe zW-inl_6Hi(g)1?ZE_ApUlYfyG6`kfFmu+{ox8DeF@3UKv8&AgX=5BO@SyY=@N Shk?UmR|QCr+AH?@$Dh9~@X$K| literal 0 HcmV?d00001 diff --git a/internal/test/env/Debugger/24-DEBUG.UX b/internal/test/env/Debugger/24-DEBUG.UX new file mode 100644 index 00000000..a61f6a74 --- /dev/null +++ b/internal/test/env/Debugger/24-DEBUG.UX @@ -0,0 +1 @@ +;; Definition To Be Tested: debug ;; ;; Source: Xerox LIsp Manual ;; Chapter 24: ERROR SYSTEM Handling Conditions ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>24-debug.ux ;; ;; ;; Syntax: debug &optional datum &rest arguments [macro] ;; ;; Function Description: Enters the debugger with a given condition. When the debugger is entered, it will announce the condition by invoking the condition's report function. ;; ;; If datum is a condition, then that condition is used directly. In this case, it is an error for arguments to be non-NIL. ;; ;; If datum is a condition type, then the condition used is the result of doing (apply #'make-condition datum arguments). ;; ;; If datum is a string, then the condition is used is the result of doing (make-condition 'simple-condition :format-string datum :format-arguments arguments). ;; ;; If datum is not specified, it defaults to "Break". ;; ;; Argument(s): datum -- condition | condition type | string | NIL ;; arguments -- for condition ;; ;; Returns: This function will never directly return to its caller. Return can occur only by a special transfer of control, such as to a proceed-case or catch-abort. ;; (do-test "advise debugger" (when nil ;; should check to see if already advised first. Also cant ;; use until advise is fixed to work with nlambda ;; no-spread fns. (il:advise 'debugger 'before 'first '(if (and (typep brkcond 'simple-condition) (equal (simple-condition-format-string brkcond) "Debug test. Please select PROCEED")) (invoke-proceed-case (if (find-proceed-case 'use-food brkcond) 'use-food 'proceed) brkcond))) (il:advise 'enter-debugger-p 'around t)) t) (do-test "debug simple" (proceed-case (debug "Simple debug test. Please select PROCEED") (proceed (condition) :test true :report "Select this." condition))) \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u b/internal/test/env/Debugger/hand/BreakWindow.u new file mode 100644 index 00000000..38241e17 --- /dev/null +++ b/internal/test/env/Debugger/hand/BreakWindow.u @@ -0,0 +1,469 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Eris}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test "bring up exec" +(do-test-menu-message dtmw 'low +(concatenate 'string +"From the background menu, bring up a new exec. + +" +"In the exec +" +"(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) +(do-test-group "STEPPER" +(do-test "call step" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon."))) +(do-test "step space" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Type a space in the exec window after the colon. " +"You should see a long progn form followed by a colon." +" + +Type another space. " +"You should see the rest of the first part of the form."))) +(do-test "step Next" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type N in the exec window after the colon. " +"You should see a long lambda form."))) +(do-test "step Debugger (AR 7709)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type d in the exec window after the colon. " +"You should see a break window."))) +(do-test "step break window OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type ok in the break window and hit return. " +"The break window should go a way and" +" you should see a colon."))) +(do-test "step Finish" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type f in the exec widnow after the colon. " +" You should see the word foo three times " +"followed by a new Exec promp."))) +(do-test "step uparrow" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon." +" Type an uparrow. + +" +"You should see the word abort and then an exec prompt.")))) +(do-test-group ("EVAL UB OK") +(do-test "menued commands" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec, enter + + IL:*DEBUGGER-MENU-ITEMS* + +" +"You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) +(do-test "eval create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Shift select the following into the exec +" +" (progn (unbreak foo) +" " (defun foo nil (print \"hello\")) +" +" (break-function 'foo))(foo) + +" +"You should then see a break window containing Breakpoint at foo"))) +(do-test "pre eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"Not yet evaluated.\""))) +(do-test "type eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the EVAL command. + +" +"You should see \"hello\""))) +(do-test "menu eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Select EVAL from the middle button menu in the break window. + +" +"You should see \"hello\""))) +(do-test "type ub" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the UB command. + +" +"You should see (foo)"))) +(do-test "post eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"hello\""))) +(do-test "menu OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, select the OK command. +" +"The break window should disappear and " +"you should see \"hello\" in the exec.")))) +(do-test-group ("proceed comands") +(do-test "create break window" +(defun foo nil +(restart-case (break) +(use-value (x) +(or x (il:promptforword "Use a different value"))) +(nil nil :report "Just return NIL"))) +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"You should then see a break window containing " +"Break"))) +(do-test "use value PROCEED command from menu" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, " "select the PROCEED command. +" +"You should then see a menu pop up. +" +" Select \"Use a different value\" from the menu. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PROCEED command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PROCEED command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Use a different value. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PR command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PR command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Use a different value. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window.")))) +(do-test-group ("RETURN") +(do-test "RETURN T command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN command. + +" +"The break window should go away and " +"you should see a NIL result in the exec."))) +(do-test "RETURN command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN T command. + +" +"The break window should go away and " +"you should see a T result in the exec.")))) +(do-test-group ("?= uparrow") +(do-test "?= create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type (foo) to the exec +" +"You should then see a break window "))) +(do-test "type ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the ?= command. + +" +"You should see the two parameters: (break) and a Lexical Environment."))) +(do-test "menu ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ?= command. + +" +"You should see the same two parameters."))) +(do-test "BREAKDELIMITER correct default" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +IL:BREAKDELIMITER + +" +"You should see some representation of a " +"carriage return character such as a quoted new line."))) +(do-test "menu ^" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ^ command. + +" +"The break window should disappear " +"and the caret should be back in the exec " +"with no value returned.")))) +(do-test-group "BREAK WINDOW" +(do-test "create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In an exec type control B to cause a break. + +" +"You should see a break window pop up."))) +(do-test "type BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT command. + +" +"You should see a backtrace scroll by. + +" +"(If the window turns black, just hit a space.)"))) +(do-test "type DBT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "menu BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window," +"choose the BT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "type BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT! command. + +" +"You should see a longer backtrace scroll by."))) +(do-test "menu DBT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT! command. + +" +"You should see the detailed backtrace in a " +"window appended to the side of the break window. "))) +(do-test "menu BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window, " +"choose the BT! command. + +" +"You should see a more detailed backtrace window appear " +"appended to the side of the break window. + +"))) +(do-test "scroll BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string +" You should be able to scroll up and down in the backtrace window."))) +(do-test "BTV command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV command. + +" +"You should see an even more detailed " +"backtrace scroll by. + +" +"Terminate scrolling by hitting CTRLe. + +"))) +(do-test "BTV! command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV! command. + +" +"You should see an even more detailed backtrace window appear " +"scroll by. Terminate scrolling by hitting CTRLe. + +")))) +(do-test-group ("@ REVERT STOP") +(do-test "@" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter an at-sign command. + +" "@ + +" +"You should see @ = il:interrupt."))) +(do-test "@ foo" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ foo + + " +"[Note: space between the @ and foo.] + +" +"You should see FOO not found."))) +(do-test "@ exec-read" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read + + " +"You should see @ = il:exec-read."))) +(do-test "@ exec-read / 1 (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read / 1 + + " +"You should see @ = il:exec-read again."))) +(do-test "@ = exec-read (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ = exec-read + +" +"You should see @ = il:exec-read again."))) +(do-test "@ number (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ 3 + +" +"You should see the name of the third stack item."))) +(do-test "frame window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the backtrace window attached to the break window " +"find IL:TTYIN and select it with the left mouse button. + +" +"You should see the frame window for ttyin pop up. "))) +(do-test "menu revert" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button In the break window " +"(not the frame window) , " +"select REVERT from the menu.. + +" +"You should see the break window re-initialize as " +"Breakpoint at IL:TTYIN. "))) +(do-test "STOP" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + + STOP + +" +"The break window should disappear " +"and the carot should be back in the exec.")))) +(do-test-group ("*short-backtrace-filter*") +(do-test "*short-backtrace-filter*" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec enter: + + il:*short-backtrace-filter* + +" +"You should see an appropriate predicate name " +"such as xcl::interesting-frame-p.")))) +(do-test-group ("EDIT") +(do-test "EDIT search for editable fn (AR 8137)" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"Enter EDIT in the resulting break window. + +" +"An editor window for foo should appear. " +"Close the editor window."))) +(do-test "EDIT selected fn (AR 6231)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the DBT command. + +" +"Select the foo frame from the BT menu window with the mouse. " +"Type EDIT in the break window. " +"An editor window should appear."))) +(do-test "EDIT OK (AR 8139)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the editor window, change the (BREAK) to \"hi\"." +" +Close the edit window. +" +"Type OK in the break window. + + " +"\"hi\" should be returned in the exec.")))) +(do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Open a new INTERLISP exec from the background menu. + +" +"In that exec type control B to cause a break. + +" +"See that *PACKAGE* is bound to # +" +"Uparrow out of the break window and close the exec."))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  +,Š,v,A,l,P,<,X,(,,9,,,G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) 5  ˛ g   ) & 1 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # 3& .1  / B5%2'*', + ./;'*', & .*;'*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 ! + 0&   &#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 +H1#°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~1~ b/internal/test/env/Debugger/hand/BreakWindow.u.~1~ new file mode 100644 index 00000000..fc12e882 --- /dev/null +++ b/internal/test/env/Debugger/hand/BreakWindow.u.~1~ @@ -0,0 +1,469 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Erinyes}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test "bring up exec" +(do-test-menu-message dtmw 'low +(concatenate 'string +"From the background menu, bring up a new exec. + +" +"In the exec +" +"(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) +(do-test-group "STEPPER" +(do-test "call step" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon."))) +(do-test "step space" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Type a space in the exec window after the colon. " +"You should see a long progn form followed by a colon." +" + +Type another space. " +"You should see the rest of the first part of the form."))) +(do-test "step Next" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type N in the exec window after the colon. " +"You should see a long lambda form."))) +(do-test "step Debugger (AR 7709)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type d in the exec window after the colon. " +"You should see a break window."))) +(do-test "step break window OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type ok in the break window and hit return. " +"The break window should go a way and" +" you should see a colon."))) +(do-test "step Finish" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type f in the exec widnow after the colon. " +" You should see the word foo three times " +"followed by a new Exec promp."))) +(do-test "step uparrow" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon." +" Type an uparrow. + +" +"You should see the word abort and then an exec prompt.")))) +(do-test-group ("EVAL UB OK") +(do-test "menued commands" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec, enter + + IL:*DEBUGGER-MENU-ITEMS* + +" +"You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) +(do-test "eval create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Shift select the following into the exec +" +" (progn (unbreak foo) +" " (defun foo nil (print \"hello\")) +" +" (break-function 'foo))(foo) + +" +"You should then see a break window containing Breakpoint at foo"))) +(do-test "pre eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"Not yet evaluated.\""))) +(do-test "type eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the EVAL command. + +" +"You should see \"hello\""))) +(do-test "menu eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Select EVAL from the middle button menu in the break window. + +" +"You should see \"hello\""))) +(do-test "type ub" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the UB command. + +" +"You should see (foo)"))) +(do-test "post eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"hello\""))) +(do-test "menu OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, select the OK command. +" +"The break window should disappear and " +"you should see \"hello\" in the exec.")))) +(do-test-group ("proceed comands") +(do-test "create break window" +(defun foo nil +(proceed-case (break) +(use-value (x) :report +"Provide a value to use as the result" x) +(nil nil :report "Just return NIL"))) +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"You should then see a break window containing " +"Break"))) +(do-test "use value PROCEED command from menu" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, " "select the PROCEED command. +" +"You should then see a menu pop up. +" +" Select \"Provide a value to use as the result\" from the menu. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PROCEED command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PROCEED command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Provide a value to use as the result. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PR command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PR command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Provide a value to use as the result. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window.")))) +(do-test-group ("RETURN") +(do-test "RETURN T command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN command. + +" +"The break window should go away and " +"you should see a NIL result in the exec."))) +(do-test "RETURN command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN T command. + +" +"The break window should go away and " +"you should see a T result in the exec.")))) +(do-test-group ("?= uparrow") +(do-test "?= create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type (foo) to the exec +" +"You should then see a break window "))) +(do-test "type ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the ?= command. + +" +"You should see the two parameters: (break) and a Lexical Environment."))) +(do-test "menu ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ?= command. + +" +"You should see the same two parameters."))) +(do-test "BREAKDELIMITER correct default" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +IL:BREAKDELIMITER + +" +"You should see some representation of a " +"carriage return character such as a quoted new line."))) +(do-test "menu ^" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ^ command. + +" +"The break window should disappear " +"and the caret should be back in the exec " +"with no value returned.")))) +(do-test-group "BREAK WINDOW" +(do-test "create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In an exec type control B to cause a break. + +" +"You should see a break window pop up."))) +(do-test "type BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT command. + +" +"You should see a backtrace scroll by. + +" +"(If the window turns black, just hit a space.)"))) +(do-test "type DBT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "menu BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window," +"choose the BT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "type BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT! command. + +" +"You should see a longer backtrace scroll by."))) +(do-test "menu DBT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT! command. + +" +"You should see the detailed backtrace in a " +"window appended to the side of the break window. "))) +(do-test "menu BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window, " +"choose the BT! command. + +" +"You should see a more detailed backtrace window appear " +"appended to the side of the break window. + +"))) +(do-test "scroll BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string +" You should be able to scroll up and down in the backtrace window."))) +(do-test "BTV command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV command. + +" +"You should see an even more detailed " +"backtrace scroll by. + +" +"Terminate scrolling by hitting CTRLe. + +"))) +(do-test "BTV! command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV! command. + +" +"You should see an even more detailed backtrace window appear " +"scroll by. Terminate scrolling by hitting CTRLe. + +")))) +(do-test-group ("@ REVERT STOP") +(do-test "@" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter an at-sign command. + +" "@ + +" +"You should see @ = il:interrupt."))) +(do-test "@ foo" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ foo + + " +"[Note: space between the @ and foo.] + +" +"You should see FOO not found."))) +(do-test "@ exec-read" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read + + " +"You should see @ = il:exec-read."))) +(do-test "@ exec-read / 1 (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read / 1 + + " +"You should see @ = il:exec-read again."))) +(do-test "@ = exec-read (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ = exec-read + +" +"You should see @ = il:exec-read again."))) +(do-test "@ number (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ 3 + +" +"You should see the name of the third stack item."))) +(do-test "frame window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the backtrace window attached to the break window " +"find IL:TTYIN and select it with the left mouse button. + +" +"You should see the frame window for ttyin pop up. "))) +(do-test "menu revert" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button In the break window " +"(not the frame window) , " +"select REVERT from the menu.. + +" +"You should see the break window re-initialize as " +"Breakpoint at IL:TTYIN. "))) +(do-test "STOP" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + + STOP + +" +"The break window should disappear " +"and the carot should be back in the exec.")))) +(do-test-group ("*short-backtrace-filter*") +(do-test "*short-backtrace-filter*" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec enter: + + il:*short-backtrace-filter* + +" +"You should see an appropriate predicate name " +"such as xcl::interesting-frame-p.")))) +(do-test-group ("EDIT") +(do-test "EDIT search for editable fn (AR 8137)" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"Enter EDIT in the resulting break window. + +" +"An editor window for foo should appear. " +"Close the editor window."))) +(do-test "EDIT selected fn (AR 6231)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the DBT command. + +" +"Select the foo frame from the BT menu window with the mouse. " +"Type EDIT in the break window. " +"An editor window should appear."))) +(do-test "EDIT OK (AR 8139)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the editor window, change the (BREAK) to \"hi\"." +" +Close the edit window. +" +"Type OK in the break window. + + " +"\"hi\" should be returned in the exec.")))) +(do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Open a new INTERLISP exec from the background menu. + +" +"In that exec type control B to cause a break. + +" +"See that *PACKAGE* is bound to # +" +"Uparrow out of the break window and close the exec."))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  +((v(A(l(P(<(X((((9(((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA 5  ˛ g   ) & 4 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # *& .1  / B5%A'*', + ./;''*', & .*;''*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 ! + 0&   &#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 +H1Q°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~2~ b/internal/test/env/Debugger/hand/BreakWindow.u.~2~ new file mode 100644 index 00000000..b8dde989 --- /dev/null +++ b/internal/test/env/Debugger/hand/BreakWindow.u.~2~ @@ -0,0 +1,469 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Erinyes}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test "bring up exec" +(do-test-menu-message dtmw 'low +(concatenate 'string +"From the background menu, bring up a new exec. + +" +"In the exec +" +"(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) +(do-test-group "STEPPER" +(do-test "call step" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon."))) +(do-test "step space" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Type a space in the exec window after the colon. " +"You should see a long progn form followed by a colon." +" + +Type another space. " +"You should see the rest of the first part of the form."))) +(do-test "step Next" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type N in the exec window after the colon. " +"You should see a long lambda form."))) +(do-test "step Debugger (AR 7709)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type d in the exec window after the colon. " +"You should see a break window."))) +(do-test "step break window OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type ok in the break window and hit return. " +"The break window should go a way and" +" you should see a colon."))) +(do-test "step Finish" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type f in the exec widnow after the colon. " +" You should see the word foo three times " +"followed by a new Exec promp."))) +(do-test "step uparrow" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon." +" Type an uparrow. + +" +"You should see the word abort and then an exec prompt.")))) +(do-test-group ("EVAL UB OK") +(do-test "menued commands" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec, enter + + IL:*DEBUGGER-MENU-ITEMS* + +" +"You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) +(do-test "eval create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Shift select the following into the exec +" +" (progn (unbreak foo) +" " (defun foo nil (print \"hello\")) +" +" (break-function 'foo))(foo) + +" +"You should then see a break window containing Breakpoint at foo"))) +(do-test "pre eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"Not yet evaluated.\""))) +(do-test "type eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the EVAL command. + +" +"You should see \"hello\""))) +(do-test "menu eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Select EVAL from the middle button menu in the break window. + +" +"You should see \"hello\""))) +(do-test "type ub" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the UB command. + +" +"You should see (foo)"))) +(do-test "post eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"hello\""))) +(do-test "menu OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, select the OK command. +" +"The break window should disappear and " +"you should see \"hello\" in the exec.")))) +(do-test-group ("proceed comands") +(do-test "create break window" +(defun foo nil +(restart-case (break) +(use-value (x) +(or x (il:promptforword "Use a different value"))) +(nil nil :report "Just return NIL"))) +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"You should then see a break window containing " +"Break"))) +(do-test "use value PROCEED command from menu" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, " "select the PROCEED command. +" +"You should then see a menu pop up. +" +" Select \"Use a different value\" from the menu. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PROCEED command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PROCEED command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Use a different value. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PR command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PR command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Use a different value. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window.")))) +(do-test-group ("RETURN") +(do-test "RETURN T command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN command. + +" +"The break window should go away and " +"you should see a NIL result in the exec."))) +(do-test "RETURN command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN T command. + +" +"The break window should go away and " +"you should see a T result in the exec.")))) +(do-test-group ("?= uparrow") +(do-test "?= create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type (foo) to the exec +" +"You should then see a break window "))) +(do-test "type ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the ?= command. + +" +"You should see the two parameters: (break) and a Lexical Environment."))) +(do-test "menu ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ?= command. + +" +"You should see the same two parameters."))) +(do-test "BREAKDELIMITER correct default" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +IL:BREAKDELIMITER + +" +"You should see some representation of a " +"carriage return character such as a quoted new line."))) +(do-test "menu ^" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ^ command. + +" +"The break window should disappear " +"and the caret should be back in the exec " +"with no value returned.")))) +(do-test-group "BREAK WINDOW" +(do-test "create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In an exec type control B to cause a break. + +" +"You should see a break window pop up."))) +(do-test "type BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT command. + +" +"You should see a backtrace scroll by. + +" +"(If the window turns black, just hit a space.)"))) +(do-test "type DBT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "menu BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window," +"choose the BT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "type BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT! command. + +" +"You should see a longer backtrace scroll by."))) +(do-test "menu DBT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT! command. + +" +"You should see the detailed backtrace in a " +"window appended to the side of the break window. "))) +(do-test "menu BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window, " +"choose the BT! command. + +" +"You should see a more detailed backtrace window appear " +"appended to the side of the break window. + +"))) +(do-test "scroll BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string +" You should be able to scroll up and down in the backtrace window."))) +(do-test "BTV command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV command. + +" +"You should see an even more detailed " +"backtrace scroll by. + +" +"Terminate scrolling by hitting CTRLe. + +"))) +(do-test "BTV! command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV! command. + +" +"You should see an even more detailed backtrace window appear " +"scroll by. Terminate scrolling by hitting CTRLe. + +")))) +(do-test-group ("@ REVERT STOP") +(do-test "@" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter an at-sign command. + +" "@ + +" +"You should see @ = il:interrupt."))) +(do-test "@ foo" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ foo + + " +"[Note: space between the @ and foo.] + +" +"You should see FOO not found."))) +(do-test "@ exec-read" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read + + " +"You should see @ = il:exec-read."))) +(do-test "@ exec-read / 1 (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read / 1 + + " +"You should see @ = il:exec-read again."))) +(do-test "@ = exec-read (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ = exec-read + +" +"You should see @ = il:exec-read again."))) +(do-test "@ number (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ 3 + +" +"You should see the name of the third stack item."))) +(do-test "frame window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the backtrace window attached to the break window " +"find IL:TTYIN and select it with the left mouse button. + +" +"You should see the frame window for ttyin pop up. "))) +(do-test "menu revert" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button In the break window " +"(not the frame window) , " +"select REVERT from the menu.. + +" +"You should see the break window re-initialize as " +"Breakpoint at IL:TTYIN. "))) +(do-test "STOP" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + + STOP + +" +"The break window should disappear " +"and the carot should be back in the exec.")))) +(do-test-group ("*short-backtrace-filter*") +(do-test "*short-backtrace-filter*" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec enter: + + il:*short-backtrace-filter* + +" +"You should see an appropriate predicate name " +"such as xcl::interesting-frame-p.")))) +(do-test-group ("EDIT") +(do-test "EDIT search for editable fn (AR 8137)" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"Enter EDIT in the resulting break window. + +" +"An editor window for foo should appear. " +"Close the editor window."))) +(do-test "EDIT selected fn (AR 6231)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the DBT command. + +" +"Select the foo frame from the BT menu window with the mouse. " +"Type EDIT in the break window. " +"An editor window should appear."))) +(do-test "EDIT OK (AR 8139)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the editor window, change the (BREAK) to \"hi\"." +" +Close the edit window. +" +"Type OK in the break window. + + " +"\"hi\" should be returned in the exec.")))) +(do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Open a new INTERLISP exec from the background menu. + +" +"In that exec type control B to cause a break. + +" +"See that *PACKAGE* is bound to # +" +"Uparrow out of the break window and close the exec."))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  +,Š,v,A,l,P,<,X,(,,9,,,G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) 5  ˛ g   ) & 4 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # 3& .1  / B5%2'*', + ./;'*', & .*;'*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 ! + 0&   &#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 +H1&°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~3~ b/internal/test/env/Debugger/hand/BreakWindow.u.~3~ new file mode 100644 index 00000000..38241e17 --- /dev/null +++ b/internal/test/env/Debugger/hand/BreakWindow.u.~3~ @@ -0,0 +1,469 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Eris}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test "bring up exec" +(do-test-menu-message dtmw 'low +(concatenate 'string +"From the background menu, bring up a new exec. + +" +"In the exec +" +"(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) +(do-test-group "STEPPER" +(do-test "call step" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon."))) +(do-test "step space" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Type a space in the exec window after the colon. " +"You should see a long progn form followed by a colon." +" + +Type another space. " +"You should see the rest of the first part of the form."))) +(do-test "step Next" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type N in the exec window after the colon. " +"You should see a long lambda form."))) +(do-test "step Debugger (AR 7709)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type d in the exec window after the colon. " +"You should see a break window."))) +(do-test "step break window OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type ok in the break window and hit return. " +"The break window should go a way and" +" you should see a colon."))) +(do-test "step Finish" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type f in the exec widnow after the colon. " +" You should see the word foo three times " +"followed by a new Exec promp."))) +(do-test "step uparrow" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Shift select the following into the exec window. + +" +"(step (defun foo nil (print \"hello\"))) + +" +"You should be prompted by repeating the form and a colon." +" Type an uparrow. + +" +"You should see the word abort and then an exec prompt.")))) +(do-test-group ("EVAL UB OK") +(do-test "menued commands" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec, enter + + IL:*DEBUGGER-MENU-ITEMS* + +" +"You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) +(do-test "eval create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Shift select the following into the exec +" +" (progn (unbreak foo) +" " (defun foo nil (print \"hello\")) +" +" (break-function 'foo))(foo) + +" +"You should then see a break window containing Breakpoint at foo"))) +(do-test "pre eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"Not yet evaluated.\""))) +(do-test "type eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the EVAL command. + +" +"You should see \"hello\""))) +(do-test "menu eval" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Select EVAL from the middle button menu in the break window. + +" +"You should see \"hello\""))) +(do-test "type ub" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the UB command. + +" +"You should see (foo)"))) +(do-test "post eval value" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the VALUE command. + +" +"You should see \"hello\""))) +(do-test "menu OK" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, select the OK command. +" +"The break window should disappear and " +"you should see \"hello\" in the exec.")))) +(do-test-group ("proceed comands") +(do-test "create break window" +(defun foo nil +(restart-case (break) +(use-value (x) +(or x (il:promptforword "Use a different value"))) +(nil nil :report "Just return NIL"))) +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"You should then see a break window containing " +"Break"))) +(do-test "use value PROCEED command from menu" +(do-test-menu-message dtmw 'low +(concatenate 'string "Press down the middle button of the mouse " +"in the break window, " "select the PROCEED command. +" +"You should then see a menu pop up. +" +" Select \"Use a different value\" from the menu. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PROCEED command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PROCEED command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Use a different value. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window."))) +(do-test "use value typed PR command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, type (foo) +" +"in the break window, type the PR command +" +"You should then see a list. +" +" Type the number by the item from the list and hit RETURN +" +"Use a different value. + +" +"You should see a request for a value. + +" +"Type a T to the request and hit return." +"The break window should go away and " +"you should see a T in the exec window.")))) +(do-test-group ("RETURN") +(do-test "RETURN T command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN command. + +" +"The break window should go away and " +"you should see a NIL result in the exec."))) +(do-test "RETURN command" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"In the resulting break window, type the RETURN T command. + +" +"The break window should go away and " +"you should see a T result in the exec.")))) +(do-test-group ("?= uparrow") +(do-test "?= create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type (foo) to the exec +" +"You should then see a break window "))) +(do-test "type ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the ?= command. + +" +"You should see the two parameters: (break) and a Lexical Environment."))) +(do-test "menu ?=" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ?= command. + +" +"You should see the same two parameters."))) +(do-test "BREAKDELIMITER correct default" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +IL:BREAKDELIMITER + +" +"You should see some representation of a " +"carriage return character such as a quoted new line."))) +(do-test "menu ^" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button in the break window, " +"select the ^ command. + +" +"The break window should disappear " +"and the caret should be back in the exec " +"with no value returned.")))) +(do-test-group "BREAK WINDOW" +(do-test "create break window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In an exec type control B to cause a break. + +" +"You should see a break window pop up."))) +(do-test "type BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT command. + +" +"You should see a backtrace scroll by. + +" +"(If the window turns black, just hit a space.)"))) +(do-test "type DBT" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "menu BT" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window," +"choose the BT command. + +" +"You should see a backtrace window " +"appended to the side of the break window."))) +(do-test "type BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BT! command. + +" +"You should see a longer backtrace scroll by."))) +(do-test "menu DBT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the DBT! command. + +" +"You should see the detailed backtrace in a " +"window appended to the side of the break window. "))) +(do-test "menu BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string "From the middle button in the break window, " +"choose the BT! command. + +" +"You should see a more detailed backtrace window appear " +"appended to the side of the break window. + +"))) +(do-test "scroll BT!" +(do-test-menu-message dtmw 'low +(concatenate 'string +" You should be able to scroll up and down in the backtrace window."))) +(do-test "BTV command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV command. + +" +"You should see an even more detailed " +"backtrace scroll by. + +" +"Terminate scrolling by hitting CTRLe. + +"))) +(do-test "BTV! command" +(do-test-menu-message dtmw 'low +(concatenate 'string "Type the BTV! command. + +" +"You should see an even more detailed backtrace window appear " +"scroll by. Terminate scrolling by hitting CTRLe. + +")))) +(do-test-group ("@ REVERT STOP") +(do-test "@" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter an at-sign command. + +" "@ + +" +"You should see @ = il:interrupt."))) +(do-test "@ foo" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ foo + + " +"[Note: space between the @ and foo.] + +" +"You should see FOO not found."))) +(do-test "@ exec-read" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read + + " +"You should see @ = il:exec-read."))) +(do-test "@ exec-read / 1 (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ exec-read / 1 + + " +"You should see @ = il:exec-read again."))) +(do-test "@ = exec-read (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ = exec-read + +" +"You should see @ = il:exec-read again."))) +(do-test "@ number (AR 8062)" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + +" " @ 3 + +" +"You should see the name of the third stack item."))) +(do-test "frame window" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the backtrace window attached to the break window " +"find IL:TTYIN and select it with the left mouse button. + +" +"You should see the frame window for ttyin pop up. "))) +(do-test "menu revert" +(do-test-menu-message dtmw 'low +(concatenate 'string "With the middle button In the break window " +"(not the frame window) , " +"select REVERT from the menu.. + +" +"You should see the break window re-initialize as " +"Breakpoint at IL:TTYIN. "))) +(do-test "STOP" +(do-test-menu-message dtmw 'low +(concatenate 'string "Enter + + STOP + +" +"The break window should disappear " +"and the carot should be back in the exec.")))) +(do-test-group ("*short-backtrace-filter*") +(do-test "*short-backtrace-filter*" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the exec enter: + + il:*short-backtrace-filter* + +" +"You should see an appropriate predicate name " +"such as xcl::interesting-frame-p.")))) +(do-test-group ("EDIT") +(do-test "EDIT search for editable fn (AR 8137)" +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec type (foo). " +"Enter EDIT in the resulting break window. + +" +"An editor window for foo should appear. " +"Close the editor window."))) +(do-test "EDIT selected fn (AR 6231)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the break window, type the DBT command. + +" +"Select the foo frame from the BT menu window with the mouse. " +"Type EDIT in the break window. " +"An editor window should appear."))) +(do-test "EDIT OK (AR 8139)" +(do-test-menu-message dtmw 'low +(concatenate 'string +"In the editor window, change the (BREAK) to \"hi\"." +" +Close the edit window. +" +"Type OK in the break window. + + " +"\"hi\" should be returned in the exec.")))) +(do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" +(do-test-menu-message dtmw 'low +(concatenate 'string +"Open a new INTERLISP exec from the background menu. + +" +"In that exec type control B to cause a break. + +" +"See that *PACKAGE* is bound to # +" +"Uparrow out of the break window and close the exec."))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  +,Š,v,A,l,P,<,X,(,,9,,,G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) 5  ˛ g   ) & 1 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # 3& .1  / B5%2'*', + ./;'*', & .*;'*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 ! + 0&   &#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 +H1#°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u b/internal/test/env/Debugger/hand/debugger.u new file mode 100644 index 00000000..1e959fb9 --- /dev/null +++ b/internal/test/env/Debugger/hand/debugger.u @@ -0,0 +1,336 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Eris}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test-group +("il:break" :before (progn (unbreak il:ourfn) +(il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) +(do-test "il:break" +(and (il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) +(and (il:break il:ourfn) +(il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break of il:advisedfns updating il:brokenfns" +(and (il:defineq (il:ourfn nil nil)) +(not (il:ourfn)) +(il:advise 'il:ourfn 'il:around nil t) +(il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(car (unbreak il:ourfn)))) +(do-test "AR 7618 BREAK :IN broken" +(il:defineq (foo nil (print "foo")) +(bar nil (foo) (print "bar"))) +(il:break (foo :in bar)) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, enter (foo). + +" +"You should see a break window.")) +(unbreak (foo :in bar))))) +(do-test-group +("xcl:break-function" :before (progn (unbreak il:ourfn) +(il:defineq (il:ourfn nil nil))) :after +(unbreak il:ourfn)) +(do-test "simple il:break-function" (unbreak) +(and (break-function 'il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break-function :trace" +(and (break-function 'floor :trace t) +(floor 20 3) +(and (do-test-menu-message dtmw 'low +(concatenate 'string +"You should see a *Trace-Output* window +" +"with a call to floor passed a 20 and a 3 +" +"and returning a 6 and a 2.")) +(eq 'our-fn (car (untrace 'our-fn)))))) +(do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +" and you should NOT see a break window +")) +(untrace 'floor))) +(do-test "il:break-function :when t" (break-function 'floor :when t) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see a break window " +"for Breakpoint at flo0r. + +" +"Type OK to the break window." +" The break window should go away and " +"the exec should show" +" floor returning a 6 and a 2.")) +(unbreak 'floor))) +(do-test "il:break-function :trace nil" (break-function 'floor :trace nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see a break window " +"for Breakpoint at floor. + +" +"Type OK to the break window." +" The break window should go away and " +"the exec should show" +" floor returning a 6 and a 2.")) +(unbreak 'floor))) +(do-test "il:break-function :trace :when nil" +(and (break-function 'floor :trace t :when nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +"You should not see a new call to floor" +" in the *Trace-Output* window +")) +(untrace 'our-fn)))) +(do-test "il:break-function :when exp (AR 8162)" +(break-function 'floor :when (when nil t)) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +" and you should NOT see a break window +")) +(untrace 'floor)))) +(do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) +(setq il:helpdepth 7))) +(do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) +(setq *test-mode* :interactive)) +(do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) +(proceed-case +(error +"Break test. This is a test, just a test. +Select Proceed from middle button menu.") +(proceed nil :report "Select me!" t))) +(do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) +(prog1 +(not (ignore-errors +(proceed-case +(error +"Break test. This is a test, just a test. +Select Proceed from middle button menu.") +(proceed nil :report "Select me!" nil)))) +(setq il:helpflag t))) +(do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) +(do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) +(and (not (il:gettopval il:helpflag)) +(il:settopval il:helpflag t) +(eq t (il:gettopval il:helpflag))))) +(do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) +(do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) +(do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) +(do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" +;; nlsetq should not trap serious-conditions +(expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) +(do-test-group +("unbreak" :before (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t)) +(do-test "simple unbreak" +(and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) +(not (unbreak)))) +(do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) +(and (il:break (our-fn il:in super-fn)) +(unbreak (our-fn il:in super-fn)))) +(do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) +(and (il:break (our-fn in super-fn)) +(unbreak (our-fn in super-fn)))) +;; the following commented out due to ignore-errors causing +;; do-test-file to abort.: (do-test "unbreak of (sub-fn in +;; superfn)" (unbreak super-fn) (and (il:break (our-fn in +;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test +;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and +;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in +;; super-fn)))) +(do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) +(and (il:break (our-fn il:in super-fn)) +(unbreak '(our-fn il:in super-fn)))) +;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak +;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak +;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in +;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in +;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) +) +(do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t)) +(do-test "simple il:rebreak" +(and (il:break our-fn) +(unbreak our-fn) +(il:rebreak our-fn)))) +(do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) +(do-test "simple untrace" +(and (trace our-fn) (untrace) (not (untrace)) +(not (member 'our-fn il:brokenfns)))) +(do-test "(untrace) with broken fns" +(and (il:break our-fn) +(not (untrace)) +(member 'our-fn il:brokenfns))) +(do-test "(untrace (sub-fn in super-fn))" +(and (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t) +(trace (our-fn il:in super-fn)) +(untrace (our-fn il:in super-fn))))) +(do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) +(do-test "trace il:brokenfns check" (trace our-fn) +(prog1 (member 'our-fn il:brokenfns) +(untrace 'our-fn))) +(do-test "il:broken prop check" (trace our-fn) +(prog1 (get 'our-fn 'il:broken) +(untrace 'our-fn))) +(do-test "simple interpreted trace" (trace our-fn) +(our-fn t) +(and (do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to our-fn passed a t +" +"and returning a t nil?")) +(eq 'our-fn (car (untrace 'our-fn))))) +(do-test "simple compiled trace" (trace floor) +(floor 20 3) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to floor passed a 20 and a 3 +" +"and returning a 6 and a 2?")) +(untrace 'floor))) +(do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) +(and (trace (our-fn il:in super-fn)) (super-fn) +(do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to our-fn passed a nil +" +"and returning a nil and a t?")) +(untrace (our-fn il:in super-fn))))) +(do-test-group ("advise") +(do-test "simple il:advise il:around of defun" (defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (il:unadvise our-fun))) +(do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(prog1 (our-fn) (il:unadvise our-fn))) +(do-test "il:advise redefined broken defun" (defun our-fun nil nil) +(il:break our-fun) +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (unbreak our-fun) +(il:unadvise our-fun))) +(do-test "il:advise redefined advised defun (AR 8172)" +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (il:unadvise our-fun))) +(do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(prog1 (our-fn) (il:unadvise our-fn)))) +(do-test-group ("il:unadvise" :before (defun our-fun nil nil) +(il:unadvise our-fun)) +(do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) +(and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) +(not (our-fun)))) +(do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) +(and (our-fun) (eq 'our-fun (first (il:unadvise t))) +(not (our-fun))))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) +STOP +(do-test "Error List condition correspondence" +(dotimes (i 52) +(ignore-errors (il:seterrorn i))) +(print "Select Inspect from the menu that will be appearing.") +(let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 +il:|collect| (ignore-errors (il:seterrorn i))) nil +(il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) +(result +(do-test-menu-message dtmw 'low +(concatenate 'string +"Does the inspect window have conditions +" +"correctly corresponding to error number + 1 +" +"in the Lyric release notes section 14.10?")))) +(il:closew iw) +result)) +,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&1-.<!O!;%'!$$ 0#8(. !$& +%(*(S  +(E  +!)"K  +!)".0  +)1+  +(>P!9-*'2 +- +**BM&%XFE/*N9%E@($=%!;:86;6 +A(%6:@;4 K %  S  .& %   * +$ %G3%/ 3 %9"'/ + 9*D0 9$!% G " ) J ! ' D   " # 7  "  " ) I !  ! (>  @ ; ; 5H/ "?  ' 4 )-0 (#°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u.~1~ b/internal/test/env/Debugger/hand/debugger.u.~1~ new file mode 100644 index 00000000..fda95a3e --- /dev/null +++ b/internal/test/env/Debugger/hand/debugger.u.~1~ @@ -0,0 +1,336 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Erinyes}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test-group +("il:break" :before (progn (unbreak il:ourfn) +(il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) +(do-test "il:break" +(and (il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) +(and (il:break il:ourfn) +(il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break of il:advisedfns updating il:brokenfns" +(and (il:defineq (il:ourfn nil nil)) +(not (il:ourfn)) +(il:advise 'il:ourfn 'il:around nil t) +(il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(car (unbreak il:ourfn)))) +(do-test "AR 7618 BREAK :IN broken" +(il:defineq (foo nil (print "foo")) +(bar nil (foo) (print "bar"))) +(il:break (foo :in bar)) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, enter (foo). + +" +"You should see a break window.")) +(unbreak (foo :in bar))))) +(do-test-group +("xcl:break-function" :before (progn (unbreak il:ourfn) +(il:defineq (il:ourfn nil nil))) :after +(unbreak il:ourfn)) +(do-test "simple il:break-function" (unbreak) +(and (break-function 'il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break-function :trace" +(and (break-function 'floor :trace t) +(floor 20 3) +(and (do-test-menu-message dtmw 'low +(concatenate 'string +"You should see a *Trace-Output* window +" +"with a call to floor passed a 20 and a 3 +" +"and returning a 6 and a 2.")) +(eq 'our-fn (car (untrace 'our-fn)))))) +(do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +" and you should NOT see a break window +")) +(untrace 'floor))) +(do-test "il:break-function :when t" (break-function 'floor :when t) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see a break window " +"for Breakpoint at flo0r. + +" +"Type OK to the break window." +" The break window should go away and " +"the exec should show" +" floor returning a 6 and a 2.")) +(unbreak 'floor))) +(do-test "il:break-function :trace nil" (break-function 'floor :trace nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see a break window " +"for Breakpoint at floor. + +" +"Type OK to the break window." +" The break window should go away and " +"the exec should show" +" floor returning a 6 and a 2.")) +(unbreak 'floor))) +(do-test "il:break-function :trace :when nil" +(and (break-function 'floor :trace t :when nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +"You should not see a new call to floor" +" in the *Trace-Output* window +")) +(untrace 'our-fn)))) +(do-test "il:break-function :when exp (AR 8162)" +(break-function 'floor :when (when nil t)) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +" and you should NOT see a break window +")) +(untrace 'floor)))) +(do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) +(setq il:helpdepth 7))) +(do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) +(setq *test-mode* :interactive)) +(do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) +(proceed-case +(error +"Break test. This is a test, just a test. +Select Proceed from middle button menu.") +(proceed nil :report "Select me!" t))) +(do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) +(prog1 +(not (ignore-errors +(proceed-case +(error +"Break test. This is a test, just a test. +Select Proceed from middle button menu.") +(proceed nil :report "Select me!" nil)))) +(setq il:helpflag t))) +(do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) +(do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) +(and (not (il:gettopval il:helpflag)) +(il:settopval il:helpflag t) +(eq t (il:gettopval il:helpflag))))) +(do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) +(do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) +(do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) +(do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" +;; nlsetq should not trap serious-conditions +(expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) +(do-test-group +("unbreak" :before (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t)) +(do-test "simple unbreak" +(and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) +(not (unbreak)))) +(do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) +(and (il:break (our-fn il:in super-fn)) +(unbreak (our-fn il:in super-fn)))) +(do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) +(and (il:break (our-fn in super-fn)) +(unbreak (our-fn in super-fn)))) +;; the following commented out due to ignore-errors causing +;; do-test-file to abort.: (do-test "unbreak of (sub-fn in +;; superfn)" (unbreak super-fn) (and (il:break (our-fn in +;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test +;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and +;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in +;; super-fn)))) +(do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) +(and (il:break (our-fn il:in super-fn)) +(unbreak '(our-fn il:in super-fn)))) +;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak +;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak +;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in +;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in +;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) +) +(do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t)) +(do-test "simple il:rebreak" +(and (il:break our-fn) +(unbreak our-fn) +(il:rebreak our-fn)))) +(do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) +(do-test "simple untrace" +(and (trace our-fn) (untrace) (not (untrace)) +(not (member 'our-fn il:brokenfns)))) +(do-test "(untrace) with broken fns" +(and (il:break our-fn) +(not (untrace)) +(member 'our-fn il:brokenfns))) +(do-test "(untrace (sub-fn in super-fn))" +(and (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t) +(trace (our-fn il:in super-fn)) +(untrace (our-fn il:in super-fn))))) +(do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) +(do-test "trace il:brokenfns check" (trace our-fn) +(prog1 (member 'our-fn il:brokenfns) +(untrace 'our-fn))) +(do-test "il:broken prop check" (trace our-fn) +(prog1 (get 'our-fn 'il:broken) +(untrace 'our-fn))) +(do-test "simple interpreted trace" (trace our-fn) +(our-fn t) +(and (do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to our-fn passed a t +" +"and returning a t nil?")) +(eq 'our-fn (car (untrace 'our-fn))))) +(do-test "simple compiled trace" (trace floor) +(floor 20 3) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to floor passed a 20 and a 3 +" +"and returning a 6 and a 2?")) +(untrace 'floor))) +(do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) +(and (trace (our-fn il:in super-fn)) (super-fn) +(do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to our-fn passed a nil +" +"and returning a nil and a t?")) +(untrace (our-fn il:in super-fn))))) +(do-test-group ("advise") +(do-test "simple il:advise il:around of defun" (defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (il:unadvise our-fun))) +(do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(prog1 (our-fn) (il:unadvise our-fn))) +(do-test "il:advise redefined broken defun" (defun our-fun nil nil) +(il:break our-fun) +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (unbreak our-fun) +(il:unadvise our-fun))) +(do-test "il:advise redefined advised defun (AR 8172)" +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (il:unadvise our-fun))) +(do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(prog1 (our-fn) (il:unadvise our-fn)))) +(do-test-group ("il:unadvise" :before (defun our-fun nil nil) +(il:unadvise our-fun)) +(do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) +(and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) +(not (our-fun)))) +(do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) +(and (our-fun) (eq 'our-fun (first (il:unadvise t))) +(not (our-fun))))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) +STOP +(do-test "Error List condition correspondence" +(dotimes (i 52) +(ignore-errors (il:seterrorn i))) +(print "Select Inspect from the menu that will be appearing.") +(let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 +il:|collect| (ignore-errors (il:seterrorn i))) nil +(il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) +(result +(do-test-menu-message dtmw 'low +(concatenate 'string +"Does the inspect window have conditions +" +"correctly corresponding to error number + 1 +" +"in the Lyric release notes section 14.10?")))) +(il:closew iw) +result)) +(~(N(:(&(S(k(K(c(Q(4(7((Œ(™(x(d((’(€(P(<(L(((C(1(n((9((M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&4-.<!O!;%'!$$ 0#8(. !$& +%(*(S  +(E  +!)"K  +!)".0  +)1+  +(>P!9-*'2 +- +**BM&%XFE/*N9%E@($=%!;:86;6 +A(%6:@;4 K %  S  .& %   * +$ %G3%/ 3 %9"'/ + 9*D0 9$!% G " ) J ! ' D   " # 7  "  " ) I !  ! (>  @ ; ; 5H/ "?  ' 4 )-0 (&°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u.~2~ b/internal/test/env/Debugger/hand/debugger.u.~2~ new file mode 100644 index 00000000..1e959fb9 --- /dev/null +++ b/internal/test/env/Debugger/hand/debugger.u.~2~ @@ -0,0 +1,336 @@ +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. +;; +;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are +;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u + + +(do-test "setup user interaction window" +(unless (fboundp 'do-test-menu-setup) +(load "{Eris}tools>do-test-menu.dfasl" t)) +(setq dtmw (do-test-menu-setup "Debugger"))) +(do-test-group +("il:break" :before (progn (unbreak il:ourfn) +(il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) +(do-test "il:break" +(and (il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) +(and (il:break il:ourfn) +(il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break of il:advisedfns updating il:brokenfns" +(and (il:defineq (il:ourfn nil nil)) +(not (il:ourfn)) +(il:advise 'il:ourfn 'il:around nil t) +(il:break il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(car (unbreak il:ourfn)))) +(do-test "AR 7618 BREAK :IN broken" +(il:defineq (foo nil (print "foo")) +(bar nil (foo) (print "bar"))) +(il:break (foo :in bar)) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string "In the exec, enter (foo). + +" +"You should see a break window.")) +(unbreak (foo :in bar))))) +(do-test-group +("xcl:break-function" :before (progn (unbreak il:ourfn) +(il:defineq (il:ourfn nil nil))) :after +(unbreak il:ourfn)) +(do-test "simple il:break-function" (unbreak) +(and (break-function 'il:ourfn) +(il:memb 'il:ourfn il:brokenfns) +(unbreak il:ourfn))) +(do-test "il:break-function :trace" +(and (break-function 'floor :trace t) +(floor 20 3) +(and (do-test-menu-message dtmw 'low +(concatenate 'string +"You should see a *Trace-Output* window +" +"with a call to floor passed a 20 and a 3 +" +"and returning a 6 and a 2.")) +(eq 'our-fn (car (untrace 'our-fn)))))) +(do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +" and you should NOT see a break window +")) +(untrace 'floor))) +(do-test "il:break-function :when t" (break-function 'floor :when t) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see a break window " +"for Breakpoint at flo0r. + +" +"Type OK to the break window." +" The break window should go away and " +"the exec should show" +" floor returning a 6 and a 2.")) +(unbreak 'floor))) +(do-test "il:break-function :trace nil" (break-function 'floor :trace nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see a break window " +"for Breakpoint at floor. + +" +"Type OK to the break window." +" The break window should go away and " +"the exec should show" +" floor returning a 6 and a 2.")) +(unbreak 'floor))) +(do-test "il:break-function :trace :when nil" +(and (break-function 'floor :trace t :when nil) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +"You should not see a new call to floor" +" in the *Trace-Output* window +")) +(untrace 'our-fn)))) +(do-test "il:break-function :when exp (AR 8162)" +(break-function 'floor :when (when nil t)) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string +"Enter + +(floor 20 3) + +to the exec. + +" +"You should see the result + +" "6 +2 + +" +" and you should NOT see a break window +")) +(untrace 'floor)))) +(do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) +(setq il:helpdepth 7))) +(do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) +(setq *test-mode* :interactive)) +(do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) +(proceed-case +(error +"Break test. This is a test, just a test. +Select Proceed from middle button menu.") +(proceed nil :report "Select me!" t))) +(do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) +(prog1 +(not (ignore-errors +(proceed-case +(error +"Break test. This is a test, just a test. +Select Proceed from middle button menu.") +(proceed nil :report "Select me!" nil)))) +(setq il:helpflag t))) +(do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) +(do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) +(and (not (il:gettopval il:helpflag)) +(il:settopval il:helpflag t) +(eq t (il:gettopval il:helpflag))))) +(do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) +(do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) +(do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) +(do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" +;; nlsetq should not trap serious-conditions +(expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) +(do-test-group +("unbreak" :before (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t)) +(do-test "simple unbreak" +(and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) +(not (unbreak)))) +(do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) +(and (il:break (our-fn il:in super-fn)) +(unbreak (our-fn il:in super-fn)))) +(do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) +(and (il:break (our-fn in super-fn)) +(unbreak (our-fn in super-fn)))) +;; the following commented out due to ignore-errors causing +;; do-test-file to abort.: (do-test "unbreak of (sub-fn in +;; superfn)" (unbreak super-fn) (and (il:break (our-fn in +;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test +;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and +;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in +;; super-fn)))) +(do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) +(and (il:break (our-fn il:in super-fn)) +(unbreak '(our-fn il:in super-fn)))) +;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak +;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak +;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in +;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in +;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) +) +(do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t)) +(do-test "simple il:rebreak" +(and (il:break our-fn) +(unbreak our-fn) +(il:rebreak our-fn)))) +(do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) +(do-test "simple untrace" +(and (trace our-fn) (untrace) (not (untrace)) +(not (member 'our-fn il:brokenfns)))) +(do-test "(untrace) with broken fns" +(and (il:break our-fn) +(not (untrace)) +(member 'our-fn il:brokenfns))) +(do-test "(untrace (sub-fn in super-fn))" +(and (defun our-fn (x) (values x (not x))) +(defun super-fn nil (our-fn nil) t) +(trace (our-fn il:in super-fn)) +(untrace (our-fn il:in super-fn))))) +(do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) +(do-test "trace il:brokenfns check" (trace our-fn) +(prog1 (member 'our-fn il:brokenfns) +(untrace 'our-fn))) +(do-test "il:broken prop check" (trace our-fn) +(prog1 (get 'our-fn 'il:broken) +(untrace 'our-fn))) +(do-test "simple interpreted trace" (trace our-fn) +(our-fn t) +(and (do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to our-fn passed a t +" +"and returning a t nil?")) +(eq 'our-fn (car (untrace 'our-fn))))) +(do-test "simple compiled trace" (trace floor) +(floor 20 3) +(prog1 +(do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to floor passed a 20 and a 3 +" +"and returning a 6 and a 2?")) +(untrace 'floor))) +(do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) +(and (trace (our-fn il:in super-fn)) (super-fn) +(do-test-menu-message dtmw 'low +(concatenate 'string "Do you see a *Trace-Output* window +" +"with a call to our-fn passed a nil +" +"and returning a nil and a t?")) +(untrace (our-fn il:in super-fn))))) +(do-test-group ("advise") +(do-test "simple il:advise il:around of defun" (defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (il:unadvise our-fun))) +(do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(prog1 (our-fn) (il:unadvise our-fn))) +(do-test "il:advise redefined broken defun" (defun our-fun nil nil) +(il:break our-fun) +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (unbreak our-fun) +(il:unadvise our-fun))) +(do-test "il:advise redefined advised defun (AR 8172)" +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(defun our-fun nil nil) +(il:advise 'our-fun 'il:around t) +(prog1 (our-fun) (il:unadvise our-fun))) +(do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(il:defineq (our-fn nil nil)) +(il:advise 'our-fn 'il:around t) +(prog1 (our-fn) (il:unadvise our-fn)))) +(do-test-group ("il:unadvise" :before (defun our-fun nil nil) +(il:unadvise our-fun)) +(do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) +(and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) +(not (our-fun)))) +(do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) +(and (our-fun) (eq 'our-fun (first (il:unadvise t))) +(not (our-fun))))) +(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) +STOP +(do-test "Error List condition correspondence" +(dotimes (i 52) +(ignore-errors (il:seterrorn i))) +(print "Select Inspect from the menu that will be appearing.") +(let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 +il:|collect| (ignore-errors (il:seterrorn i))) nil +(il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) +(result +(do-test-menu-message dtmw 'low +(concatenate 'string +"Does the inspect window have conditions +" +"correctly corresponding to error number + 1 +" +"in the Lyric release notes section 14.10?")))) +(il:closew iw) +result)) +,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&1-.<!O!;%'!$$ 0#8(. !$& +%(*(S  +(E  +!)"K  +!)".0  +)1+  +(>P!9-*'2 +- +**BM&%XFE/*N9%E@($=%!;:86;6 +A(%6:@;4 K %  S  .& %   * +$ %G3%/ 3 %9"'/ + 9*D0 9$!% G " ) J ! ' D   " # 7  "  " ) I !  ! (>  @ ; ; 5H/ "?  ' 4 )-0 (#°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log b/internal/test/env/Debugger/logs/DebuggerOnly.log new file mode 100644 index 00000000..266e9657 --- /dev/null +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log @@ -0,0 +1 @@ +;;; Test results for sysout of 3-Mar-88 16:23:58 ;;; Tests run on 7-Apr-87 20:01:15 ;;; Running tests from ({eris}env>debugger>hand>debugger.u;1) Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;1" Test "il:break-function :trace" failed in file "DEBUGGER.U;1" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;1" Test "simple unbreak" failed in file "DEBUGGER.U;1" Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;1" Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" Test "simple il:rebreak" failed in file "DEBUGGER.U;1" Test "simple untrace" failed in file "DEBUGGER.U;1" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;1" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;1" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;1" Test "il:broken prop check" failed in file "DEBUGGER.U;1" Test "simple interpreted trace" failed in file "DEBUGGER.U;1" Test "trace of subfunction" failed in file "DEBUGGER.U;1" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;1" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;1" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;1" Test "simple il:unadvise" failed in file "DEBUGGER.U;1" Test "il:unadvise t" failed in file "DEBUGGER.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ new file mode 100644 index 00000000..49e83fb0 --- /dev/null +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ @@ -0,0 +1 @@ +;;; Test results for sysout of 10-Apr-87 10:19:34 ;;; Tests run on 14-Apr-87 07:07:47 ;;; Running tests from ({Eris}Test>Debugger>debugger.u;) il:ourfn is not broken. il:ourfn is not broken. Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;14" il:ourfn is not broken. il:ourfn is not broken. Test "il:break-function :trace" failed in file "DEBUGGER.U;14" our-fn is not broken. il:ourfn is not broken. Testing... "IL:HELPFLAG BREAK!" Testing... "IL:HELPFLAG NIL" Testing... "restore *test-mode*" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;14" Test "simple unbreak" failed in file "DEBUGGER.U;14" super-fn is not broken. Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" super-fn is not broken. Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;14" super-fn is not broken. Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" Test "simple il:rebreak" failed in file "DEBUGGER.U;14" Test "simple untrace" failed in file "DEBUGGER.U;14" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;14" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;14" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;14" Test "il:broken prop check" failed in file "DEBUGGER.U;14" Test "simple interpreted trace" failed in file "DEBUGGER.U;14" Test "simple compiled trace" failed in file "DEBUGGER.U;14" Test "trace of subfunction" failed in file "DEBUGGER.U;14" Test "trace of recursive subfunction" failed in file "DEBUGGER.U;14" udffn is not a function. our-fn is not broken. Test "trace of undefined subfunction" failed in file "DEBUGGER.U;14" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;14" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;14" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;14" Test "simple il:unadvise" failed in file "DEBUGGER.U;14" Test "il:unadvise t" failed in file "DEBUGGER.U;14" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ new file mode 100644 index 00000000..eb898447 --- /dev/null +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ @@ -0,0 +1 @@ +;;; Test results for sysout of 3-Mar-88 16:23:58 ;;; Tests run on 7-Apr-87 20:01:15 ;;; Running tests from ({eris}env>debugger>hand>debugger.u;1) il:ourfn is not broken. il:ourfn is not broken. Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;1" il:ourfn is not broken. il:ourfn is not broken. Test "il:break-function :trace" failed in file "DEBUGGER.U;1" our-fn is not broken. il:ourfn is not broken. Testing... "IL:HELPFLAG BREAK!" Testing... "IL:HELPFLAG NIL" Testing... "restore *test-mode*" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;1" Test "simple unbreak" failed in file "DEBUGGER.U;1" super-fn is not broken. Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" super-fn is not broken. Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;1" super-fn is not broken. Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" Test "simple il:rebreak" failed in file "DEBUGGER.U;1" Test "simple untrace" failed in file "DEBUGGER.U;1" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;1" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;1" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;1" Test "il:broken prop check" failed in file "DEBUGGER.U;1" Test "simple interpreted trace" failed in file "DEBUGGER.U;1" Test "trace of subfunction" failed in file "DEBUGGER.U;1" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;1" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;1" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;1" Test "simple il:unadvise" failed in file "DEBUGGER.U;1" Test "il:unadvise t" failed in file "DEBUGGER.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ new file mode 100644 index 00000000..266e9657 --- /dev/null +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ @@ -0,0 +1 @@ +;;; Test results for sysout of 3-Mar-88 16:23:58 ;;; Tests run on 7-Apr-87 20:01:15 ;;; Running tests from ({eris}env>debugger>hand>debugger.u;1) Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;1" Test "il:break-function :trace" failed in file "DEBUGGER.U;1" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;1" Test "simple unbreak" failed in file "DEBUGGER.U;1" Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;1" Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" Test "simple il:rebreak" failed in file "DEBUGGER.U;1" Test "simple untrace" failed in file "DEBUGGER.U;1" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;1" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;1" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;1" Test "il:broken prop check" failed in file "DEBUGGER.U;1" Test "simple interpreted trace" failed in file "DEBUGGER.U;1" Test "trace of subfunction" failed in file "DEBUGGER.U;1" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;1" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;1" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;1" Test "simple il:unadvise" failed in file "DEBUGGER.U;1" Test "il:unadvise t" failed in file "DEBUGGER.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/Report.tedit b/internal/test/env/Debugger/logs/Report.tedit new file mode 100644 index 00000000..b121e245 --- /dev/null +++ b/internal/test/env/Debugger/logs/Report.tedit @@ -0,0 +1,313 @@ +Debugger, Error System, and Unwinder test report + +This report is for tests written and executed up to March 24, 1987 on the Basics>Full.Sysout generated 11-Mar-87. + +The following tests are for the integration of the new error system into the Interlisp environment. + +The source for this report is {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile + +The print version of this test report is filed at {Eris}Test>Debugger>Report.IP + +The test plan is filed at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile and IP. + +Groups of tests were written and executed on the 1109 for all the commands in the Debugger document in the Xerox Common Lisp implementation notes. + +These are stored on {eris}Test>Debugger>BreakWindow.u + +Groups of tests were written and executed on the 1109 for most of the functions in IRM chapter 15: Breaking, Tracing, and Advising. + +These are mostly automatic tests but some require user interaction. They are stored in {Eris}Test>Debugger>Debugger.u + +For tests of the Xerox extentions to the CML error system, see {Eris}cml>test>24-*. + {Eris}cml>test>cl-error.x and {Eris}cml>test>errorsystem.notefile which is the source for {Eris}cml>test>24-errorsystem.x. + + +Regression Test for ARS + +ARS tested 21-Jan-87 basics>full.sysout + +7152 passed +7780 new +7797 new +6503 passed + +New ARs generated +Several problems were discovered and reported as ARs. Each of these have tests. The following are only new ARs generated up to February 28. +DEBUGGER.NEWARS +7486 debugger "eval:" undocumented + +7522 missing second param causes random error reporting + +7601 unnamed proceed cases break compute-proceed-cases + +7679 Version .01 Error System documentation edits + +7780 argument names of broken fns unbound in debugger + +7797 breaking/tracing advised fns does not update brokenfns + +7845 exec il:settopval il:helpflag serious-condition attempt-to-change-constant + +7848 (IL:NLSETQ (CL:SIGNAL 'ERROR)) breaks + +7868 bad package fix readtable change screws up fix + +7873: Common functions should be safe to break + +AR 7923 il:brkinfolst no longer exists + +AR 7908 untrace also unbreaks + +AR 7919 TRACE no longer works for undefined subfunctions + +AR 7932: (unbreak (sub-fn in super-fn)) has two problems + + + +Original List of ARs +ERRORSYSTEM.ARSUMMARY +AR Summary generated on 17-Feb-87 10:33:56 +Generated with Query Spec: (AND (Submitter: HAS Kelley)) +Sorted with Sort Spec: (Status:) + +Numbe Date: System: Subsystem: Status: Attn: Subject: Priority: Difficulty Impact: Problem Type: + +6787 4-Nov-86 Common Lisp File System In New Jellinek.pa CL:OPEN says FILE NOT FOUND for BUSY FILE Absolutely +6810 5-Nov-86 Common Lisp Streams and I/ New Jellinek make-synonym-stream core file read fails Absolutely Bug +6847 10-Nov-86 Common Lisp Other New vanMelle, W Making straight common-lisp text files using SEdit Unlikely Hard Feature +6987 2-Dec-86 Common Lisp Streams and I/ New Jellinek make-broadcast-stream should check for list arg Absolutely Bug +7033 9-Dec-86 Programming En Code Editor New Wozencraft SEdit global replace breaks +7067 15-Dec-86 Common Lisp Streams and I/ New Jellinek force-output should flush pages buffered in vmem Serious +7118 29-Dec-86 Programming En Code Editor New woz Sizing to fit SEdit window region length Perhaps Feature +7168 8-Jan-87 Common Lisp Other New Portable DO-TEST needs expect-errors +7268 19-Jan-87 Language Suppo Storage Format New vanmelle SPELLFILE should use FILEDATES prop, but doesn't Hopefully Bug +7308 21-Jan-87 Programming En Break Package New Daniels CL:READ should be in the list of break warning fns Absolutely Design - UI +7436 4-Feb-87 Communications Other New LispCore^.p Constant requests for passwords +7439 4-Feb-87 Common Lisp Error System New Biggs, Dani Error system documentation needs re-writing +7448 4-Feb-87 Programming En Code Editor New Wozencraft, SEdit looses edits of whole lists +7451 4-Feb-87 New Fischer Old-Interlisp-Exec comes up in current pkg&rdtbl +7486 5-Feb-87 Programming En Break Package New Daniels debugger "eval:" undocumented +7522 6-Feb-87 New Daniels CERROR missing second param causes random error reporting Minor +7601 10-Feb-87 Common Lisp Error System New Daniels unnamed proceed cases break compute-proceed-cases +7679 12-Feb-87 Common Lisp Error System New Daniels,Big Version .01 Error System documentation edits +7680 12-Feb-87 Documentation Product Descr/ New Biggs WHO-LINE mention missing from overview +7681 12-Feb-87 Text TEdit New Sybalsky, S TEDIT not calling EDITBM ? +7686 12-Feb-87 Documentation Interlisp Refe New Biggs,Sybal IL => CL function map needed +7687 12-Feb-87 Programming En Code Editor New Wozencraft SEdit should reflect a change in readtable +7696 12-Feb-87 Programming En Code Editor New SeditSuppor SEdit quits refreshing after soft stack overflow +5717 27-May-86 Windows and Gr Window System Open Wozencraft. ATTACHWINDOW JUSTIFY should work for thin windows Hopefully Moderate Bug +6789 4-Nov-86 Common Lisp Streams and I/ Open Jellinek.pa make-concatenated-stream core file problem Absolutely +6919 18-Nov-86 Open Jellinek SETFILEINFO does not take FileName in all cases Unlikely Bug +4847 5-Dec-85 Communications Other Fixed FileCache breaks when running init.firsttime Hopefully Moderate Bug +7098 22-Dec-86 Common Lisp Streams and I/ Fixed make-string-input-stream breaks on printed double Absolutely Bug +4890 10-Dec-85 Operating Syst Virtual Memory Declined Changing CPE and memory boards gives MP9335 Hopefully Moderate Bug +6797 4-Nov-86 Declined KEYACTION does not work for MOVE. +6799 5-Nov-86 Common Lisp Streams and I/ Declined Jellinek make-string-input-stream calls OPENSTRINGSTREAM with unconverted string Absolutely Bug +7529 9-Feb-87 Language Suppo Stack and Inte Incomplete il:|fetch| dwimification problems + +DEBUGGER.ARSUMMARY +AR Summary generated on 16-Feb-87 16:23:08 +Generated with Query Spec: (AND (Subsystem: IS Break Package)) +Sorted with Sort Spec: (Status:) + +Numbe Date: System: Subsystem: Status: Attn: Subject: Priority: Difficulty Impact: Problem Type: + +6851 10-Nov-86 Programming En Break Package New masinter If a u.d.f. has a functions definition, want the d Absolutely Feature + 23:07:31 vironment efinition to be unsaved, ala Interlisp-D environme + nt. +6981 1-Dec-86 Programming En Break Package New Fischer.PA Trace Window Overflow Hopefully Annoying Bug + 08:56:50 vironment +6993 3-Dec-86 Programming En Break Package New daniels Bug in debugger: Buttoning "display edit" from the Hopefully Moderate Annoying Bug + 15:57:33 vironment frame window edits the function cell +7016 6-Dec-86 Programming En Break Package New jellinek, d Want -> = commands for debugger Unlikely Serious Design - Impl + 07:40:10 vironment aniels, big + gs +7079 17-Dec-86 Programming En Break Package New daniels Debugger should skip SI::*UNWIND-PROTECT* frames i Hopefully Easy Annoying Bug + 13:26:10 vironment n reporting errors +7084 17-Dec-86 Programming En Break Package New daniels, va BREAK..OK doesn't work under Interlisp exec/profil Absolutely Bug + 18:07:17 vironment nMelle e--uses wrong evaluator, gets uba BROKEN +7085 17-Dec-86 Programming En Break Package New daniels.pa UNBREAK (foo :in bar) doesn't find uses in subfunc Absolutely Moderate Serious Bug + 20:36:10 vironment tions +7089 19-Dec-86 Programming En Break Package New daniels.pa OPENWP should be on list of unsafe functions to br Absolutely Easy Fatal Bug + 10:23:56 vironment eak +7097 19-Dec-86 Programming En Break Package New Daniels Wrong frame current in broken function in debugger Hopefully Moderate Moderate Bug + 22:36:05 vironment +7122 29-Dec-86 Programming En Break Package New Daniels Break window BT frame window doesn't show arg name Absolutely Bug + 13:47:11 vironment s for broken fn. +7213 13-Jan-87 Programming En Break Package New daniels, pa Trace replacing old fn defn. Hopefully Serious Bug + 02:10:08 vironment vel +7215 13-Jan-87 Programming En Break Package New daniels Arguments displayed during trace are random. Perhaps Moderate Feature + 02:16:43 vironment +7236 14-Jan-87 Programming En Break Package New daniels Information in breakpoint, backtrace, and frame wi Absolutely Moderate Moderate Bug + 16:07:14 vironment ndow is printed with inconsistent package / readta + ble. +7267 16-Jan-87 Programming En Break Package New woz Bad bahavior of backtrace window inspect menu Unlikely Easy Annoying Design - UI + 16:06:54 vironment +7295 20-Jan-87 Programming En Break Package New Daniels, Bi Need to finish documentation for the new DEBUGGER Absolutely Hard Serious Documentation + 17:45:26 vironment ggs +7296 20-Jan-87 Programming En Break Package New Fischer, Bi New Step and trace need documentation Absolutely Moderate Serious Documentation + 17:48:23 vironment ggs +7308 21-Jan-87 Programming En Break Package New Daniels CL:READ should be in the list of break warning fns Absolutely Design - UI + 16:14:01 vironment +7355 26-Jan-87 Programming En Break Package New Pavel, Dani Want better support for debugging interpreted code Design - UI + 23:27:01 vironment els +7371 28-Jan-87 Programming En Break Package New Daniels Stack overflow condition should get normal debugge Absolutely Moderate Design - UI + 12:01:49 vironment r window +7383 29-Jan-87 Programming En Break Package New Daniels ENTER-DEBUGGER-P should say yes for STORAGE-CONDIT Hopefully Easy Moderate Design - Impl + 11:41:06 vironment IONs +7384 29-Jan-87 Programming En Break Package New STACK-OVERFLOW errors should get a new window Hopefully Easy Annoying Design - Impl + 11:43:08 vironment +7402 30-Jan-87 Programming En Break Package New Daniels Closing a debugger window does not always abort Moderate Bug + 12:56:11 vironment +7441 4-Feb-87 Programming En Break Package New Daniels Can't break Interlisp NLAMBDAs Absolutely Serious Bug + 14:57:56 vironment +7445 4-Feb-87 Programming En Break Package New Daniels INSPECTCODE from debugger should always inspect se Hopefully Moderate Bug + 16:51:54 vironment lected frame +7474 4-Feb-87 Programming En Break Package New Daniels The debugger should rebind *READ-SUPPRESS* to NIL Absolutely Easy Serious Bug + 21:28:01 vironment +7486 5-Feb-87 Programming En Break Package New Daniels debugger "eval:" undocumented + 12:00:08 vironment +7510 5-Feb-87 Programming En Break Package New Daniels Debugger gives lexical environment to EVAL too oft Absolutely Moderate Bug + 18:22:32 vironment en +7589 10-Feb-87 Programming En Break Package New daniels Want !EVAL debugger command Feature + 15:10:43 vironment +7592 10-Feb-87 Programming En Break Package New HELPDEPTH no longer controls break depth + 17:47:02 vironment +7742 13-Feb-87 Programming En Break Package New Daniels ADVISE doesn't work on Common Lisp functions Absolutely Serious Bug + 18:53:10 vironment +7748 13-Feb-87 Programming En Break Package New Daniels Want better name for Breakpoint, tracing functions Hopefully Easy Minor Feature + 19:25:46 vironment +118 17-Mar-84 Programming En Break Package Open Pavel Want EDIT command in debugger to work even when co Perhaps Hard Moderate Feature + 0:19:30 vironment de is compiled. +494 4-Apr-84 Programming En Break Package Open Masinter HELPFLAG = BREAK! should cause breaks on every err Absolutely Moderate Feature + 11:24:03 vironment or +1032 8-May-84 Programming En Break Package Open Masinter CML: Want to trace & break macros, like "push, pop Unlikely Moderate Annoying Feature + 17:21:55 vironment " etc +3972 25-Jun-85 Programming En Break Package Open Masinter.pa Want to be able to trace variables at execution ti Perhaps Moderate Feature + 12:46:56 vironment me +4164 1-Aug-85 Programming En Break Package Open Biggs, Masi Want extended documentation of the Break Package Absolutely Hard Annoying Documentation + 16:18:20 vironment nter.pa +5099 29-Jan-86 Programming En Break Package Open Burton want shift selection from the backtrace menu Unlikely Minor Feature + 10:06:54 vironment +6231 27-Jul-86 Programming En Break Package Open Masinter EDIT in break window under Common Lisp won't edit Hopefully Moderate Serious Feature + 10:29:22 vironment the expression +6542 29-Sep-86 Programming En Break Package Open Masinter TRACE window doesn't hold when page is full Hopefully Annoying Feature + 08:56:25 vironment +6959 25-Nov-86 Programming En Break Package Open Masinter Can't advise ARGTYPE = 2 functions Absolutely Fatal Bug + 15:25:50 vironment +6960 25-Nov-86 Programming En Break Package Open daniels.pa Want one-shot breakpoints Unlikely Moderate Feature + 15:46:22 vironment +7364 27-Jan-87 Programming En Break Package Open Daniels (TRACE) gives ("nil not a function") Serious Bug + 19:10:55 vironment +7386 29-Jan-87 Programming En Break Package Open ADVISE AROUND uses u.d.f. IL:\\SAFEAPPLY Absolutely Fatal Bug + 13:01:11 vironment +7391 29-Jan-87 Programming En Break Package Open Want !EVAL in debugger Moderate Design - Impl + 14:32:21 vironment +7618 11-Feb-87 Programming En Break Package Open Daniels BREAK :IN broken Absolutely Serious Design - Impl + 12:36:42 vironment +1034 8-May-84 Programming En Break Package Fixed TRACE of (C)EXPR*'s fails to show arguments Perhaps Easy Serious Design - UI + 17:24:30 vironment +1035 8-May-84 Programming En Break Package Fixed TRACEing shifts (TTYDISPLAYSTREAM) into trace wind Absolutely Moderate Moderate Bug + 17:25:02 vironment ow +1036 8-May-84 Programming En Break Package Fixed Confusing appearance of TRACE's value-return line Hopefully Moderate Annoying Design - UI + 17:25:59 vironment +1122 18-May-84 Programming En Break Package Fixed change STKNARGS, STKARG to see args of Lambda-nosp Perhaps Moderate Design - UI + 12:25:45 vironment read (for break) +1694 24-Jul-84 Programming En Break Package Fixed (BREAK (FOO IN BAR)) replaces recordname FOO with Unlikely Hard Moderate Bug + 10:04:53 vironment FOO-IN-BAR in CREATE +1970 28-Aug-84 Programming En Break Package Fixed ^B while a traced function is being executed confu Absolutely Moderate Design - UI + 09:46:40 vironment ses break package +2478 19-Oct-84 Programming En Break Package Fixed RETFROM inside function doesn't unwind break windo Absolutely Annoying Bug + 16:47:01 vironment ws +2686 14-Nov-84 Programming En Break Package Fixed Repeatable Race break package: causes Break window Absolutely Moderate Bug + 20:39:12 vironment acting like top-level typescript window +5556 24-Apr-86 Programming En Break Package Fixed AUTOBACKTRACEFLG vs. TRACE Absolutely Bug + 11:48:47 vironment +5807 11-Jun-86 Programming En Break Package Fixed AUTOBACKTRACEFLG = ALWAYS breaks TRACE Absolutely Serious Bug + 09:38:52 vironment +5940 28-Jun-86 Programming En Break Package Fixed biggs BT in break windows isn't very useful. Absolutely Moderate Design - Impl + 02:06:18 vironment +6007 8-Jul-86 Programming En Break Package Fixed Break handling under CMLEXEC should be CMLreading Absolutely Annoying Design - Impl + 11:03:28 vironment +6128 19-Jul-86 Programming En Break Package Fixed Want to be able to include 1-cell arglist debuggin Absolutely Design - Impl + 04:17:22 vironment g info in compiled code, have printcode etc know a + bout them +6445 8-Sep-86 Programming En Break Package Fixed Can't revert from the menu any more Absolutely Moderate Bug + 17:57:29 vironment +6712 27-Oct-86 Programming En Break Package Fixed Break package obscures system variables Absolutely Moderate Bug + 09:44:31 vironment +6796 4-Nov-86 Programming En Break Package Fixed EVAL in debugger doesn't print result Absolutely Moderate Design - Impl + 17:59:31 vironment +6817 6-Nov-86 Programming En Break Package Fixed Backtrace windows (and printed backtraces) show to Hopefully Annoying Design - UI + 12:33:52 vironment o many calls +6818 6-Nov-86 Programming En Break Package Fixed Stack frame display for CL EVAL frames should show Hopefully Moderate Annoying Feature + 12:40:05 vironment more +6927 19-Nov-86 Programming En Break Package Fixed debugger windows pop up on top of one another. Absolutely Annoying Design - UI + 11:54:28 vironment +6952 24-Nov-86 Programming En Break Package Fixed PAGEHEIGHT remains debugger window height after de Absolutely Annoying Bug + 12:01:36 vironment bugger exit +7121 29-Dec-86 Programming En Break Package Fixed ?= under breakpoint shows broken fn, rather than a Absolutely Bug + 13:44:59 vironment rgs +7155 7-Jan-87 Programming En Break Package Fixed Fischer Debugger BTV! command :print-junk option broken Absolutely Easy Annoying Bug + 11:23:37 vironment +7329 23-Jan-87 Programming En Break Package Fixed Help info on debugger menu is "NIL" Hopefully Annoying Bug + 18:09:49 vironment +7598 10-Feb-87 Programming En Break Package Fixed ^ out of break under "EVAL" unwinds too far Absolutely Serious Design - Impl + 19:18:26 vironment +7599 10-Feb-87 Programming En Break Package Fixed "PROCEED" shows too much, starts at wrong frame Absolutely Moderate Design - Impl + 19:22:56 vironment +6237 28-Jul-86 Programming En Break Package Closed Change break package uses a special variable to * Easy Annoying Design - Impl + 14:01:45 vironment WINDOW-BREAK* from WBREAK to decide whether to sta + rt a new window or to use the same one instead of + MOVDs when WBREAK(T) or WBREAK(NIL) +2347 8-Oct-84 Programming En Break Package Declined Break of (REPLACE IN FOO) gives erroneous error me Perhaps Annoying Design - UI + 14:23:41 vironment ssage (REPLACE was undefined) +4102 17-Jul-85 Programming En Break Package Declined want ~ to be treated equivalent to ^ in break wind Perhaps Annoying Design - UI + 19:13:39 vironment ow +744 17-Apr-84 Programming En Break Package Superseded (Superseded by AR 1035) ^ out of break can switch Perhaps Moderate Annoying Design - UI + 16:25:26 vironment TTY stream to TRACE window +1740 2-Aug-84 Programming En Break Package Superseded editing under a break (superseded by AR 162) Moderate Bug + 14:00:53 vironment +2809 6-Dec-84 Programming En Break Package Superseded (Superseded by AR 5556) Setting AUTOBACKTRACEFLG = Perhaps Annoying Bug + 09:56:17 vironment ALWAYS causes a break when a traced fn is called: + "TRACE - UNBOUND ATOM" +2863 12-Dec-84 Programming En Break Package Superseded BURTON.PA Harmony: tracing functions (superceded by AR 2863) + 16:10:44 vironment +2967 29-Dec-84 Programming En Break Package Superseded (Superseded by AR 1035) BREAK windows can be left Unlikely Minor Bug + 08:52:57 vironment on screen after REVERT to broken fn. +3487 14-Mar-85 Programming En Break Package Superseded (Superseded by AR 1035) Display stream switched to Perhaps Annoying Design - Impl + 09:13:59 vironment break window when HELPFLAG set to break! +3540 25-Mar-85 Programming En Break Package Superseded (Superseded by AR5556) When AUTOBACKTRACEFLG=ALWAY Hopefully Moderate Bug + 08:39:38 vironment S!, any TRACEd function stops with UNBOUND ATOM TR + ACE +5219 14-Feb-86 Programming En Break Package Superseded superseded by AR494: HELPFLAG = BREAK! doesn't alw Absolutely Moderate Bug + 11:41:33 vironment ays work +6099 16-Jul-86 Programming En Break Package Superseded (Superseded by AR 5556) AUTOBACKTRACEFLG of ALWAYS Perhaps Annoying Bug + 17:46:31 vironment or ALWAYS! breaks TRACE +7011 6-Dec-86 Programming En Break Package Superseded debugger entry frame odd Absolutely Serious Design - UI + 06:53:47 vironment +7083 17-Dec-86 Programming En Break Package Superseded [SUPERSEDED BY 7121] ?= doesn't work for il:broken Absolutely Bug + 18:01:11 vironment fns +7247 15-Jan-87 Programming En Break Package Superseded Superseded by AR7236: Frame inspector window in De Absolutely Moderate Serious Bug + 19:16:18 vironment bugger always uses IL package, readtable +311 27-Mar-84 Programming En Break Package Obsolete HELPFIX is calling EDITE with Type=FNS when there Absolutely Easy Annoying Design - UI + 9:29:34 vironment is no fn +2223 21-Sep-84 Programming En Break Package Obsolete BREAK frame window opens twice Perhaps Annoying Design - Impl + 15:09:15 vironment +2533 30-Oct-84 Programming En Break Package Obsolete Break window becomes Toplevel Moderate Bug + 09:41:33 vironment +2598 7-Nov-84 Programming En Break Package Obsolete Got UNBOUND ATOM "^" and "?=" in break window Perhaps Annoying Bug + 17:07:01 vironment +2614 8-Nov-84 Programming En Break Package Obsolete MaxBkMenuHeight no longer effective Perhaps Minor Bug + 14:55:36 vironment +2928 19-Dec-84 Programming En Break Package Obsolete Break window frame inspect window opened twice whe Perhaps Minor Performance + 08:09:37 vironment n first created +2968 29-Dec-84 Programming En Break Package Obsolete REVERT to Nlambda-nospread with LOCALVAR arg trans Absolutely Moderate Bug + 10:47:57 vironment forms arg to (LIST arg) +6538 26-Sep-86 Programming En Break Package Obsolete TRACE keeps opening new windows, rather than reusi Absolutely Serious Bug + 18:23:55 vironment ng one trace window. +6829 6-Nov-86 Programming En Break Package Obsolete CLOSEW of a breakwindow sends ^ instead of il:^ Minor Bug + 21:34:57 vironment +539 6-Apr-84 Programming En Break Package Incomplete Break middle-button pop-up menu should switch the Perhaps Annoying Design - UI + 10:20:11 vironment TTY to the break window +(($((( TIMESROMAN  HELVETICA  HELVETICA HELVETICA  HELVETICA  HELVETICA HELVETICA1yfPZT“@„^›0    %<948>R-60(:9+9!˛ł˛˛˛˛˛˛˛˛˛˛˛˛˛˛š˛˛˛˛˛˛˛˛˛˛˛˛˛˛Ç˛+?!˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛˛ŤĹrzş \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log b/internal/test/env/Debugger/logs/debugger.log new file mode 100644 index 0000000000000000000000000000000000000000..5789654877deea0a8b5bcacdf85844a6ca44f711 GIT binary patch literal 1579 zcmbVMU60a06fKE9NPPG8W?ux8uG=CX7Hwo@fJTH3blK;AOrfDn$xLTg-T24+Yrc5< z0hmZpDEp?TOwMM(tRzZ%am!Ri@(b5~*5ypR|x6ASn9VXRoX&uON z1;d(v%i}d=Wyyt+;bP8fHIU3pLR<&5zK2#BIwwRk_S-mp-;&HmcH6dLULqm%=ZXvgn2dq^781XFD%k%0L?VveMPjdrj*r46V0~*^}$3u0Rz Wd&=|d@9gX8&-ACFD0rxR`|%4C((&y8 literal 0 HcmV?d00001 diff --git a/internal/test/env/Debugger/logs/debugger.log.~1~ b/internal/test/env/Debugger/logs/debugger.log.~1~ new file mode 100644 index 00000000..2a7ffb68 --- /dev/null +++ b/internal/test/env/Debugger/logs/debugger.log.~1~ @@ -0,0 +1 @@ +;;; Test results for sysout of 11-Mar-87 13:49:38 ;;; Tests run on 24-Mar-87 11:22:16 ;;; Running tests from ({Eris}Test>Debugger>debugger.u;) Non DO-TEST form at top level in "DEBUGGER.U;12" (in-package "XCL-TEST") Test "il:break of il:broken fns update of il:brokenfns" failed in file "DEBUGGER.U;12" Test "il:break of il:advisedfns updating il:brokenfns" failed in file "DEBUGGER.U;12" Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;12" Test "il:break-function :trace" failed in file "DEBUGGER.U;12" Testing... "IL:HELPFLAG BREAK!" Testing... "IL:HELPFLAG NIL" Testing... "restore *test-mode*" Test "IL:HELPFLAG IL:SETTOPVAL" failed in file "DEBUGGER.U;12" Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;12" Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;12" Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;12" Test "simple il:rebreak" failed in file "DEBUGGER.U;12" Test "simple untrace" failed in file "DEBUGGER.U;12" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;12" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;12" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;12" Test "il:broken prop check" failed in file "DEBUGGER.U;12" Test "simple interpreted trace" failed in file "DEBUGGER.U;12" Test "trace of subfunction" failed in file "DEBUGGER.U;12" Test "trace of recursive subfunction" failed in file "DEBUGGER.U;12" Test "trace of undefined subfunction" failed in file "DEBUGGER.U;12" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;12" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;12" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;12" Test "simple il:unadvise" failed in file "DEBUGGER.U;12" Test "il:unadvise t" failed in file "DEBUGGER.U;12" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~2~ b/internal/test/env/Debugger/logs/debugger.log.~2~ new file mode 100644 index 00000000..1a75ba46 --- /dev/null +++ b/internal/test/env/Debugger/logs/debugger.log.~2~ @@ -0,0 +1 @@ +;;; Test results for sysout of 11-Mar-87 13:49:38 ;;; Tests run on 24-Mar-87 11:55:56 ;;; Running tests from ({Eris}Test>Debugger>debugger.u;) Test "il:break of il:broken fns update of il:brokenfns" failed in file "DEBUGGER.U;13" Test "il:break of il:advisedfns updating il:brokenfns" failed in file "DEBUGGER.U;13" Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;13" Test "il:break-function :trace" failed in file "DEBUGGER.U;13" Testing... "IL:HELPFLAG BREAK!" Testing... "IL:HELPFLAG NIL" Testing... "restore *test-mode*" Test "IL:HELPFLAG IL:SETTOPVAL" failed in file "DEBUGGER.U;13" Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;13" Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;13" Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;13" Test "simple il:rebreak" failed in file "DEBUGGER.U;13" Test "simple untrace" failed in file "DEBUGGER.U;13" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;13" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;13" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;13" Test "il:broken prop check" failed in file "DEBUGGER.U;13" Test "simple interpreted trace" failed in file "DEBUGGER.U;13" Test "trace of subfunction" failed in file "DEBUGGER.U;13" Test "trace of recursive subfunction" failed in file "DEBUGGER.U;13" Test "trace of undefined subfunction" failed in file "DEBUGGER.U;13" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;13" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;13" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;13" Test "simple il:unadvise" failed in file "DEBUGGER.U;13" Test "il:unadvise t" failed in file "DEBUGGER.U;13" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~3~ b/internal/test/env/Debugger/logs/debugger.log.~3~ new file mode 100644 index 00000000..2ffceea5 --- /dev/null +++ b/internal/test/env/Debugger/logs/debugger.log.~3~ @@ -0,0 +1 @@ +;;; Test results for sysout of 18-Apr-87 20:24:31 ;;; Tests run on 7-Apr-87 20:01:15 ;;; Running tests from ({eris}test>debugger>*.u;) Test "step Debugger (AR 7709)" failed in file "BREAKWINDOW.U;5" Test "step Finish" failed in file "BREAKWINDOW.U;5" Test "@ foo" failed in file "BREAKWINDOW.U;5" Test "@ = exec-read (AR 8062)" failed in file "BREAKWINDOW.U;5" Test "@ number (AR 8062)" failed in file "BREAKWINDOW.U;5" Test "EDIT search for editable fn (AR 8137)" failed in file "BREAKWINDOW.U;5" Test "EDIT selected fn (AR 6231)" failed in file "BREAKWINDOW.U;5" il:ourfn is not broken. il:ourfn is not broken. Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;14" il:ourfn is not broken. il:ourfn is not broken. Test "il:break-function :trace" failed in file "DEBUGGER.U;14" our-fn is not broken. il:ourfn is not broken. Testing... "IL:HELPFLAG BREAK!" Testing... "IL:HELPFLAG NIL" Testing... "restore *test-mode*" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;14" Test "simple unbreak" failed in file "DEBUGGER.U;14" super-fn is not broken. Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" super-fn is not broken. Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;14" super-fn is not broken. Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" Test "simple il:rebreak" failed in file "DEBUGGER.U;14" Test "simple untrace" failed in file "DEBUGGER.U;14" Test "(untrace) with broken fns" failed in file "DEBUGGER.U;14" Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;14" Test "trace il:brokenfns check" failed in file "DEBUGGER.U;14" Test "il:broken prop check" failed in file "DEBUGGER.U;14" Test "simple interpreted trace" failed in file "DEBUGGER.U;14" Test "trace of subfunction" failed in file "DEBUGGER.U;14" Test "trace of recursive subfunction" failed in file "DEBUGGER.U;14" udffn is not a function. our-fn is not broken. Test "trace of undefined subfunction" failed in file "DEBUGGER.U;14" Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;14" Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;14" Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;14" Test "simple il:unadvise" failed in file "DEBUGGER.U;14" Test "il:unadvise t" failed in file "DEBUGGER.U;14" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~4~ b/internal/test/env/Debugger/logs/debugger.log.~4~ new file mode 100644 index 00000000..f10e8566 --- /dev/null +++ b/internal/test/env/Debugger/logs/debugger.log.~4~ @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 2-Mar-88 13:56:25 ;;; Running tests from ({Eris}Env>Debugger>Hand>*.u;) Test "step space" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "use value PROCEED command from menu" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "use value typed PROCEED command" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "use value typed PR command" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "@ exec-read / 1 (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "@ = exec-read (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "@ number (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "EDIT search for editable fn (AR 8137)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "EDIT selected fn (AR 6231)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" il:ourfn is not broken. il:ourfn is not broken. Test "AR 7618 BREAK :IN broken" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" il:ourfn is not broken. il:ourfn is not broken. Test "il:break-function :trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" our-fn is not broken. il:ourfn is not broken. Testing... "IL:HELPFLAG BREAK!" Testing... "IL:HELPFLAG NIL" Testing... "restore *test-mode*" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple unbreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" super-fn is not broken. Test "unbreak of (sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" super-fn is not broken. Test "unbreak of (sub-fn in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" super-fn is not broken. Test "unbreak of '(sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple il:rebreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple untrace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "(untrace) with broken fns" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "(untrace (sub-fn in super-fn))" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "trace il:brokenfns check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:broken prop check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple interpreted trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "trace of subfunction" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple il:advise il:around of defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:advise redefined broken defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:advise redefined advised defun (AR 8172)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple il:unadvise" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:unadvise t" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~5~ b/internal/test/env/Debugger/logs/debugger.log.~5~ new file mode 100644 index 00000000..cd72fe03 --- /dev/null +++ b/internal/test/env/Debugger/logs/debugger.log.~5~ @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 2-Mar-88 13:56:25 ;;; Running tests from ({Eris}Env>Debugger>Hand>*.u;) Test "@ exec-read / 1 (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "@ = exec-read (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "@ number (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "EDIT search for editable fn (AR 8137)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "EDIT selected fn (AR 6231)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" Test "AR 7618 BREAK :IN broken" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:break-function :trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple unbreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "unbreak of (sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "unbreak of (sub-fn in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "unbreak of '(sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple il:rebreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple untrace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "(untrace) with broken fns" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "(untrace (sub-fn in super-fn))" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "trace il:brokenfns check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:broken prop check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple interpreted trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "trace of subfunction" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple il:advise il:around of defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:advise redefined broken defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:advise redefined advised defun (AR 8172)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "simple il:unadvise" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" Test "il:unadvise t" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~6~ b/internal/test/env/Debugger/logs/debugger.log.~6~ new file mode 100644 index 00000000..833d2fc2 --- /dev/null +++ b/internal/test/env/Debugger/logs/debugger.log.~6~ @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 2-Mar-88 13:56:25 ;;; Running tests from ({Eris}Env>Debugger>Hand>*.u;) The following are in {ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U Test "@ exec-read / 1 (AR 8062)" failed in file Test "@ = exec-read (AR 8062)" failed in file Test "@ number (AR 8062)" failed in file Test "EDIT search for editable fn (AR 8137)" failed in file Test "EDIT selected fn (AR 6231)" failed in file The following are in {ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U Test "AR 7618 BREAK :IN broken" failed in file Test "il:break-function :trace" failed in file Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file Test "simple unbreak" failed in file Test "unbreak of (sub-fn il:in superfn)" failed in file Test "unbreak of (sub-fn in superfn)" failed in file Test "unbreak of '(sub-fn il:in superfn)" failed in file Test "simple il:rebreak" failed in file Test "simple untrace" failed in file Test "(untrace) with broken fns" failed in file Test "(untrace (sub-fn in super-fn))" failed in file Test "trace il:brokenfns check" failed in file Test "il:broken prop check" failed in file Test "simple interpreted trace" failed in file Test "trace of subfunction" failed in file Test "simple il:advise il:around of defun" failed in file Test "il:advise redefined broken defun" failed in file Test "il:advise redefined advised defun (AR 8172)" failed in file Test "simple il:unadvise" failed in file Test "il:unadvise t" failed in file (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~7~ b/internal/test/env/Debugger/logs/debugger.log.~7~ new file mode 100644 index 0000000000000000000000000000000000000000..5789654877deea0a8b5bcacdf85844a6ca44f711 GIT binary patch literal 1579 zcmbVMU60a06fKE9NPPG8W?ux8uG=CX7Hwo@fJTH3blK;AOrfDn$xLTg-T24+Yrc5< z0hmZpDEp?TOwMM(tRzZ%am!Ri@(b5~*5ypR|x6ASn9VXRoX&uON z1;d(v%i}d=Wyyt+;bP8fHIU3pLR<&5zK2#BIwwRk_S-mp-;&HmcH6dLULqm%=ZXvgn2dq^781XFD%k%0L?VveMPjdrj*r46V0~*^}$3u0Rz Wd&=|d@9gX8&-ACFD0rxR`|%4C((&y8 literal 0 HcmV?d00001 diff --git a/internal/test/env/Exec/Hand/CONN.U b/internal/test/env/Exec/Hand/CONN.U new file mode 100644 index 00000000..9d0df3c0 --- /dev/null +++ b/internal/test/env/Exec/Hand/CONN.U @@ -0,0 +1 @@ +;; Function To Be Tested: CONN (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; Section: The Evaluator ;; Page: 9 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 10, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}test>exec>conn.u ;; ;; ;; Syntax: CONN DIRECTORY ;; ;; Function Description: Change default pathname to directory ;; ;; Argument(s): DIRECTORY (directory name) ;; ;; Returns: connected directory ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished using the interlisp comamnd BKSYSBUF in ;; do-test format. Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed". The test result will be automatically logged in the following file: ;; {eris}test>exec>test.report. (DO-TEST 'CONN-TEST-SETUP (PROGN (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~2%COMMAND:CONN ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (SETQ CONN-COMMAND-STRING "(SETQ MESS1 'Connecting-to-new-directory...) (SETQ MESS2 'Connecting-to-default-directory...) (SETQ MESS3 'Reconnecting-to-default-directory...) (PROGN (PRINC MESS2) (SLEEP 2) (VALUES) ) CONN (PROGN (PRINC MESS1) (SLEEP 2) (VALUES)) CONN {CORE} (SETQ CORE-DIRECTORY *DEFAULT-PATHNAME-DEFAULTS*) (PROGN (PRINC MESS3) (SLEEP 2) (VALUES)) CONN (DO-TEST 'MASTERSCOPE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (STRING-EQUAL (PATHNAME-HOST CORE-DIRECTORY) 'CORE) (STRING-EQUAL (PATHNAME-DIRECTORY CORE-DIRECTORY) 'TEST)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF CONN-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/DA.U b/internal/test/env/Exec/Hand/DA.U new file mode 100644 index 00000000..f3f4a1f9 --- /dev/null +++ b/internal/test/env/Exec/Hand/DA.U @@ -0,0 +1 @@ +;; Function To Be Tested: DA (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; ;; Section: The Evaluator ;; Page: 9 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 10, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}integration>exec>da.u ;; ;; ;; Syntax: DA ;; ;; Function Description: Returns current date and time ;; ;; Argument(s): None ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished using the interlisp function BKSYSBUF in ;; do-test form . Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "Test "quote" ;; failed in file "unknown". " at the end of testing. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'DA-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: DA ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ DA-COMMAND-STRING "(SETQ MESS1 'Printing-current-date&time...) (SETQ DATE (IL:DATE)) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) DA (SETQ TODAY IL:IT) ; Now do-test will determine whether DA actually returns today's date (DO-TEST 'DA-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND :IF-DOES-NOT-EXIST :CREATE)) (IF (STRING-EQUAL DATE TODAY :END1 14 :END2 14) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF DA-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/DA.U.~1~ b/internal/test/env/Exec/Hand/DA.U.~1~ new file mode 100644 index 00000000..917555fc --- /dev/null +++ b/internal/test/env/Exec/Hand/DA.U.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: DA (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; ;; Section: The Evaluator ;; Page: 9 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 10, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}integration>exec>da.u ;; ;; ;; Syntax: DA ;; ;; Function Description: Returns current date and time ;; ;; Argument(s): None ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished using the interlisp function BKSYSBUF in ;; do-test form . Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "Test "quote" ;; failed in file "unknown". " at the end of testing. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'DA-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: DA ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ DA-COMMAND-STRING "(SETQ MESS1 'Printing-current-date&time...) (SETQ DATE (IL:DATE)) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) DA (SETQ TODAY IL:IT) ; Now do-test will determine whether DA actually returns today's date (DO-TEST 'DA-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (STRING-EQUAL DATE TODAY :END1 14 :END2 14) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF DA-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/DA.U.~2~ b/internal/test/env/Exec/Hand/DA.U.~2~ new file mode 100644 index 00000000..f3f4a1f9 --- /dev/null +++ b/internal/test/env/Exec/Hand/DA.U.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: DA (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; ;; Section: The Evaluator ;; Page: 9 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 10, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}integration>exec>da.u ;; ;; ;; Syntax: DA ;; ;; Function Description: Returns current date and time ;; ;; Argument(s): None ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished using the interlisp function BKSYSBUF in ;; do-test form . Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "Test "quote" ;; failed in file "unknown". " at the end of testing. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'DA-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: DA ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ DA-COMMAND-STRING "(SETQ MESS1 'Printing-current-date&time...) (SETQ DATE (IL:DATE)) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) DA (SETQ TODAY IL:IT) ; Now do-test will determine whether DA actually returns today's date (DO-TEST 'DA-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND :IF-DOES-NOT-EXIST :CREATE)) (IF (STRING-EQUAL DATE TODAY :END1 14 :END2 14) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF DA-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/DIR.U b/internal/test/env/Exec/Hand/DIR.U new file mode 100644 index 00000000..84816ddf --- /dev/null +++ b/internal/test/env/Exec/Hand/DIR.U @@ -0,0 +1 @@ +;; Function To Be Tested: DIR (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Page: 28 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 10, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}test>exec>dir.u ;; ;; ;; Syntax: DIR &optional PATHNAME &rest KEYWORDS ;; ;; Function Description: Shows a directory listing for PATHNAME or the connected ;; directory. If provided, KEYWORDS indicate information to be displayed for each ;; file. Some keywords are: AUTHOR, AU, CREATIONDATE, DA, etc. ;; ;; Argument(s): Pathname or Connected Directory ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'DIR-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND:DIR ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Connecting to a new directory ({core})...") (SETQ MESS2 "Displaying files in the connected-directory...") (SETQ MESS3 "Displaying files with creationdate, size, and author") (SETQ MESS4 "Now do-test will determine if files exist as indicated by DIR...") (PROGN (PRINC "creating three files for testing......") (SLEEP 2) (VALUES) ) (SETQ TEST-WINDOW (IL:CREATEW '(100 100 300 200) "TEST WINDOW FOR DIR")) (SETQ TEST-STREAM1 (IL:OPENTEXTSTREAM "THIS IS CONTENT OF WINDOW ONE" TEST-WINDOW)) (IL:TEDIT.PUT TEST-WINDOW '{CORE}FILE1) (IL:CLEARW TEST-WINDOW) (SETQ TEST-STREAM2 (IL:OPENTEXTSTREAM "SECOND FILE" TEST-WINDOW)) (IL:TEDIT.PUT TEST-WINDOW '{CORE}FILE2) (IL:CLEARW TEST-WINDOW) (SETQ TEST-STREAM3 (IL:OPENTEXTSTREAM "LAST!" TEST-WINDOW)) (IL:TEDIT.PUT TEST-WINDOW '{CORE}FILE3) (CLOSE TEST-STREAM1) (CLOSE TEST-STREAM2) (CLOSE TEST-STREAM3) (IL:CLOSEW TEST-WINDOW) (SETQ DIR-COMMAND-STRING "(PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) CONN {CORE} (PROGN (PRINC MESS2) (SLEEP 2) (VALUES) ) DIR (PROGN (PRINC MESS3) (SLEEP 2) (VALUES) ) DIR {CORE} CREATIONDATE SIZE AUTHOR CONN (PROGN (PRINC MESS4) (SLEEP 2) (VALUES) ) (DO-TEST 'DIR-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (PROBE-FILE '{CORE}FILE1) (PROBE-FILE '{CORE}FILE2) (PROBE-FILE '{CORE}FILE3)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) (IF (PROBE-FILE '{CORE}FILE1) (DELETE-FILE '{CORE}FILE1)) (IF (PROBE-FILE '{CORE}FILE2) (DELETE-FILE '{CORE}FILE2)) (IF (PROBE-FILE '{CORE}FILE3) (DELETE-FILE '{CORE}FILE3)) ) ) ") (IL:BKSYSBUF DIR-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/FIND-EVENT.U b/internal/test/env/Exec/Hand/FIND-EVENT.U new file mode 100644 index 00000000..b641e6b9 --- /dev/null +++ b/internal/test/env/Exec/Hand/FIND-EVENT.U @@ -0,0 +1 @@ +;; Function To Be Tested: ?? (Find-Event) (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 9, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}test>exec>find-event.u ;; ;; ;; Syntax: ?? EvenSpec ;; ;; Function Description: Redoes the event(s) specified by EvenSpec. ;; For example, REDO 123 repeats the event numbered 123. ;; ;; Argument(s): EvenSpec (number or sequence) ;; ;; Returns: Input and Results of specified event ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "DO-EVENTS-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'FIND-EVENT-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: FIND-EVENT ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Printing input results of first event...") (SETQ MESS2 "Printinginput results of second event...") (SETQ MESS3 "Printinginput results of third event...") (SETQ {CORE}FIRST "{CORE}FIRST") (SETQ {CORE}SECOND "{CORE}SECOND") (SETQ {CORE}THIRD "{CORE}THIRD") (SETQ FIND-EVENT-COMMAND-STRING "(SETQ FIRST-EVENT 1000) (SETQ SECOND-EVENT NIL) (SETQ THIRD-EVENT 'YES) (FORMAT NIL MESS1) (DRIBBLE '{CORE}FIRST) ?? -5 (DRIBBLE) (FORMAT NIL MESS2) (DRIBBLE '{CORE}SECOND) ?? -7 (DRIBBLE) (FORMAT NIL MESS3) (DRIBBLE ' {CORE}THIRD) ?? -9 (DRIBBLE) ; ?? will print all events ; Now the following analyzes to see if the specified events have been found. (LET ((FIRST (OPEN {CORE}FIRST))) (PROGN (DO ((I 0 (1+ I))) ((= I 6) T) (READ FIRST)) (IF (EQUAL (READ FIRST) '(setq first-event 1000)) (SETQ FOUND-FLG1 T) (SETQ FOUND-FLG1 NIL)) (CLOSE FIRST) ) ) (LET ((SECOND (OPEN {CORE}SECOND))) (PROGN (DO ((I 0 (1+ I))) ((= I 6) T) (READ SECOND)) (IF (EQUAL (READ SECOND) '(setq second-event NIL)) (SETQ FOUND-FLG2 T) (SETQ FOUND-FLG2 NIL)) (CLOSE SECOND) ) ) (LET ((THIRD (OPEN {CORE}THIRD))) (PROGN (DO ((I 0 (1+ I))) ((= I 6) T) (READ THIRD)) (IF (EQUAL (READ THIRD) '(setq third-event (quote yes))) (SETQ FOUND-FLG3 T) (SETQ FOUND-FLG3 NIL)) (CLOSE THIRD) ) ) (DO-TEST 'FIND-EVENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (EQ FOUND-FLG1 T) (EQ FOUND-FLG2 T) (EQ FOUND-FLG3 T)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF FIND-EVENT-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/FIX.U b/internal/test/env/Exec/Hand/FIX.U new file mode 100644 index 00000000..a64b6a31 --- /dev/null +++ b/internal/test/env/Exec/Hand/FIX.U @@ -0,0 +1 @@ +;; Function To Be Tested: FIX (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 11, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}test>exec>fix.u ;; ;; Syntax: FIX &rest EventSpec ;; ;; Function Description: Edit the specified event prior to re-executing it ;; ;; Argument(s): EventSpec ;; ;; Returns: Event to be changed ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "FIX-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'FIX-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: FIX ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Fixing the previous events...") (SETQ MESS2 "The new values should now be different from the previous ones...") (SETQ MESS3 "Testing has succeeded; the old events were fixed and their new values are now different from the old ones") (SETQ FORMAT-STRING "POP-ELEMENT-1: ~A POP-ELEMENT-2: ~A ~% TODAY-1: ~D TODAY-2: ~D ~% RUNTIME-1: ~D RUNTIME-2: ~D") (SETQ FIX-STRING "FIX -8 FIX -7 FIX -6 (SETQ POP-ELEMENT-2 CL:*** TODAY-2 CL:** RUNTIME-2 CL:*) DA (PROGN (PRINC MESS2) (SLEEP 2) (VALUES) (FORMAT NIL FORMAT-STRING POP-ELEMENT-1 POP-ELEMENT-2 TODAY-1 TODAY-2 RUNTIME-1 RUNTIME-2) ) (SLEEP 2) (DO-TEST 'FIX-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (NOT (EQ POP-ELEMENT-1 POP-ELEMENT-2)) (NOT (= TODAY-1 TODAY-2)) (NOT (= RUNTIME-1 RUNTIME-2))) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (SETQ FIX-COMMAND-STRING "(SETQ STACK '(A B C)) (POP STACK) (SETQ POP-ELEMENT-1 IL:IT) (SETQ TODAY (GET-UNIVERSAL-TIME)) (SETQ TODAY-1 IL:IT) (SETQ RUNTIME (GET-INTERNAL-RUN-TIME)) (SETQ RUNTIME-1 IL:IT) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) (IL:EVAL.AS.PROCESS '(IL:BKSYSBUF FIX-STRING)) ") (IL:BKSYSBUF FIX-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/HELP.U b/internal/test/env/Exec/Hand/HELP.U new file mode 100644 index 00000000..dbe00e86 --- /dev/null +++ b/internal/test/env/Exec/Hand/HELP.U @@ -0,0 +1 @@ +;; Function To Be Tested: ? (help) (EXEC Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 27 ;; ;; Section: The Evaluator ;; ;; ;; Created By: John Park ;; ;; Creation Date: Feb 9, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}test>exec>help.u ;; ;; ;; Syntax: ? &OPTIONAL NAME ;; ;; Function Description: If NAME is not provided describes all available exec ;; commands by printing the name, argument list and description of each. With ;; NAME, only that command is described ;; ;; Argument(s): NAME (optional) ;; [REDO RETRY USE ? ?? CONN DA DIR DO-EVENTS FIX FORGET NAME NDIR ;; . PL REMEMBER SHH UNDO PP SEE SEE* TIME TY TYPE] ;; ;; Returns: Description of specified NAME ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Displaying the entire ? list will be verified by user manually ;; Comments are incorporated within each command file. ;; The do-test test setup is titled "HELP-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST "HELP-TEST-SETUP" (PROGN (IL:PAGEHEIGHT 0) (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: HELP ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ {CORE}SEE "{CORE}SEE" {CORE}REDO "{CORE}REDO") (SETQ HELP-COMMAND-STRING ";;Entering ? should list and describe all available exec commands as listed above ? ;;Entering ? SEE should only describe the SEE command (DRIBBLE '{CORE}SEE) ? SEE (DRIBBLE) ;;Entering ? REDO should only describe the REDO command (DRIBBLE '{CORE}REDO) ? REDO (DRIBBLE) ; The following determine if {core}see contains the keyword SEE (SETQ SEE-FILE (OPEN {CORE}SEE)) (SETQ SEE-KEYWORD-FLG NIL) (READ-LINE SEE-FILE) (READ-LINE SEE-FILE) (DO ((I 0 (1+ I))) ((EQ (READ SEE-FILE NIL 'EOF) 'EOF) T) (IF (EQ (READ SEE-FILE NIL 'EOF) 'SEE) (PUSH T SEE-KEYWORD-FLG) (PUSH NIL SEE-KEYWORD-FLG))) (CLOSE SEE-FILE) ; The following determine if {core}see contains the keyword REDO (SETQ REDO-FILE (OPEN {CORE}REDO)) (SETQ REDO-KEYWORD-FLG NIL) (READ-LINE REDO-FILE) (READ-LINE REDO-FILE) (DO ((I 0 (1+ I))) ((EQ (READ REDO-FILE NIL 'EOF) 'EOF) T) (IF (EQ (READ REDO-FILE NIL 'EOF) 'REDO) (PUSH T REDO-KEYWORD-FLG) (PUSH NIL REDO-KEYWORD-FLG))) (CLOSE REDO-FILE) (DO-TEST 'FIND-EVENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (NOTEVERY #'NULL SEE-KEYWORD-FLG) (NOTEVERY #'NULL REDO-KEYWORD-FLG)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF HELP-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/MULTIPLE-USE.U b/internal/test/env/Exec/Hand/MULTIPLE-USE.U new file mode 100644 index 00000000..224a4e0d --- /dev/null +++ b/internal/test/env/Exec/Hand/MULTIPLE-USE.U @@ -0,0 +1 @@ +;; Function To Be Tested: USE (multiple) (EXEC Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 4, 1987 ;; ;; Last Update: Feb 27 , 1987 ;; ;; Filed As: {ERINYES}lisp>test>exec>multiple-use.u ;; ;; ;; Syntax: USE NEW1 FOR OLD1 AND ....AND NEWn FOR OLDn [IN EventSpec] ;; ;; Function Description: This command allows multiple substitues. Substitutes NEW1 ;; for OLD1, NEW2 for OLD2, etc in the events specified by EventSpec, and redoes the ;; result. NEW and OLD can include lists or symbols. ;; ;; Argument(s): NEW (new value) OLD (old value) ;; EvenSpec (number or sequence) ;; ;; Returns: Results of substituted variables in the previous event(s) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "MULTIPLE-USE-TEST-SETUP", which executes ;; the command string. The do-test form within the command file will return T or ;; "test "quote" failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST "MULTIPLE-USE-TEST-SETUP" (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: MULTIPLE-USE ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MULTIPLE-USE-COMMAND-STRING "(setq x 10 y 20 x1 11 y1 21) (setq first-val (+ x1 y1)) (setq second-val (+ x y)) (setq a1 -10 b1 -20) ;; The following will use a for x and b for y in the last event USE A1 FOR X AND B1 FOR Y (SETQ SECOND-VAL-1 IL:IT) (= second-val-1 (+ a1 b1)) USE X1 Y1 FOR X Y (SETQ SECOND-VAL-2 IL:IT) (= second-val (+ x1 y1)) ;; The following will perform distributive substitutions (setq w 0) (setq w1 1 w2 2 w3 3 w4 4) (setq z1 (1+ w)) ;; The following should return 2,3,4, and 5 respectively and reset z to 5 USE w1 w2 w3 w4 FOR W (= z1 5) ;; The following will perform the equivalent of ;; USE A FOR D AND X FOR W ;; USE B FOR D AND Y FOR W ;; USE C FOR D AND Z FOR W (setq D '() W '(W)) (setq new-list (append d w)) (setq a '(a) b '(b) c '(c) x '(x) y '(y) z '(z)) (setq new-list (append d w)) USE A B C FOR D AND X Y Z FOR W ;; Now (a x) (b y) and (c z) should be returned respectively and new-list is ;; bound to the last value returned (equal new-list '(c z)) (setq old-val 10 new-val -9) (setq sum (+ old-val new-val)) ;;The following should have the same effect as USE OLD-VAL FOR NEW-VAL ;; AND NEW-VAL FOR OLD-VAL USE OLD-VAL NEW-VAL FOR NEW-VAL OLD-VAL (SETQ FIRST-SUM IL:IT) USE NEW-VAL OLD-VAL FOR OLD-VAL NEW-VAL IN -3 (SETQ SECOND-SUM IL:IT) (DO-TEST 'MULTIPLE-USE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (= SECOND-VAL-1 (+ A1 B1)) (= SECOND-VAL-2 (+ X1 Y1)) (= Z1 5) (EQUAL NEW-LIST '(c z)) (= FIRST-SUM -18) (= SECOND-SUM 20) ) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF MULTIPLE-USE-COMMAND-STRING) ) ) \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/NDIR.U b/internal/test/env/Exec/Hand/NDIR.U new file mode 100644 index 00000000..f45d953f --- /dev/null +++ b/internal/test/env/Exec/Hand/NDIR.U @@ -0,0 +1 @@ +;; Function To Be Tested: NDIR (Programmer's Assistant Command) ;; ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; Created By: John Park ;; ;; Creation Date: Feb 10, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}integration>exec>ndir.u ;; ;; ;; Syntax: NDIR &optional PATHNAME &rest KEYWORDS ;; ;; Function Description: Shows a directory listing for PATHNAME or the connected ;; directory in abbreviated format. If provided, KEYWORDS indicate information ;; to be displayed for each file. Some keywords are: AUTHOR, AU, CREATIONDATE, DA, etc. ;; ;; Argument(s): Pathname or connected directory ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "NDIR-TEST-SETUP", which executes ;; the command string. The do-test form within the command file will return T or ;; "test "quote" failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'NDIR-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: NDIR ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Creating 6 new files in ({core})...") (SETQ MESS2 "Displaying files in the connected-directory...") (SETQ MESS3 "Displaying files with creationdate and size") (SETQ MESS4 "Now do-test will determine if files exist as indicated by NDIR...") (DEFUN MESSAGE (MESS) (PROGN (PRINC MESS) (SLEEP 1) (VALUES) ) ) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) (MAPCAR #'DELETE-FILE (DIRECTORY '{CORE})) (SETQ NDIR-WINDOW (IL:CREATEW '(100 100 300 200) "NDIR WINDOW FOR TESTING")) (IL:FOR X IL:TO 6 (PROGN (SETQ NDIR-STREAM (IL:OPENTEXTSTREAM "THIS IS CONTENT OF NDIR-1" NDIR-WINDOW)) (IL:TEDIT.PUT NDIR-WINDOW (PACK* '{CORE} 'FILE X)) (CLOSE NDIR-STREAM) ) ) (IL:CLOSEW NDIR-WINDOW) (SETQ {CORE}NDIR-TEST "{CORE}NDIR-TEST") (SETQ NDIR-COMMAND-STRING "(MESSAGE MESS2) (DRIBBLE '{CORE}NDIR-TEST) NDIR {CORE} (DRIBBLE) (MESSAGE MESS3) NDIR {CORE} CREATIONDATE SIZE (SETQ FILES-EXIST-FLG NIL) (SETQ X (OPEN {CORE}NDIR-TEST)) (DO ((CNT 1 (1+ CNT))) ((= CNT 7) T) (IL:RATOM X)) (DOLIST (Y '(FILE1. FILE2. FILE3. FILE4. FILE5. FILE6.)) (PROGN (IF (EQ Y (IL:RATOM X)) (PUSH T FILES-EXIST-FLG) (PUSH NIL FILES-EXIST-FLG)) (IL:RATOM X) (IL:RATOM X) ) ) (CLOSE X) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (MESSAGE MESS4) (DO-TEST 'NDIR-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (NOTANY #'NULL FILES-EXIST-FLG) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF NDIR-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/PL.U b/internal/test/env/Exec/Hand/PL.U new file mode 100644 index 00000000..fc9da5b4 --- /dev/null +++ b/internal/test/env/Exec/Hand/PL.U @@ -0,0 +1 @@ +;; Function To Be Tested: PL (Programmer's Assistant Command) ;; ;; Function To Be Tested: USE (multiple) (EXEC Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 12, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}test>exec>pl.u ;; ;; ;; Syntax: PL SYMBOL ;; ;; Function Description: Prints the property list of SYMBOL in an easy to read format. ;; ;; Argument(s): SYMBOL ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "PL-TEST-SETUP", which executes ;; the command string. The do-test form within the command file will return T or ;; "test "quote" failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'PL-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: PL ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS0 "Creating property values for THOMAS...") (SETQ MESS1 "The following will print the property list for THOMAS...") (SETQ MESS2 "Removing all property values for THOMAS...") (SETQ MESS3 "As observed, there is no property value for THOMAS.") (SETQ {CORE}PL-1 "{CORE}PL-1") (SETQ PL-COMMAND-STRING "(PROGN (PRINC MESS0) (SLEEP 1) (VALUES) ) (SETF (GET 'THOMAS 'AGE) 28 (GET 'THOMAS 'BIRTHDATE) 'Jan-8-59 (GET 'THOMAS 'HOBBY) 'SKIING (GET 'THOMAS 'JOB) 'ARTIST (GET 'THOMAS 'HOME) 'LONDON ) (PROGN (PRINC MESS1) (SLEEP 1) (VALUES) ) (DRIBBLE '{CORE}PL-1) PL THOMAS (DRIBBLE) (PROGN (PRINC MESS2) (SLEEP 1) (VALUES) ) (SETF (SYMBOL-PLIST 'THOMAS) NIL) PL THOMAS (IF (EQ * NIL) (SETQ NO-PROP-FLG T) (SETQ NO-PROP-FLG NIL)) (PROGN (PRINC MESS3) (SLEEP 1) (VALUES) ) ; The follow is an analysis of files containing the property list before and after ; the property was assigned and removed from THOMAS: (SETQ PROPERTY-LIST '(|age : 28| |birthdate : jan-8-59| |hobby : skiing| |job : artist| |home : london|)) (SETQ PROP-FLG NIL) (LET ((PL-1 (OPEN {CORE}PL-1))) (DO ((j 0 (1+ j))) ((= j 3) t) (READ-LINE PL-1)) (PROGN (DOLIST (Y PROPERTY-LIST) (IF (STRING-EQUAL Y (READ-LINE PL-1)) (PUSH T PROP-FLG ) (PUSH NIL PROP-FLG)) ) (CLOSE PL-1) ) ) ; Now do-test will determine if the property list for THOMAS has ever existed ; if it has been removed (DO-TEST 'MULTIPLE-USE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (NOTANY #'NULL PROP-FLG) (EQ NO-PROP-FLG T)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF PL-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/PP.U b/internal/test/env/Exec/Hand/PP.U new file mode 100644 index 00000000..b94401ae --- /dev/null +++ b/internal/test/env/Exec/Hand/PP.U @@ -0,0 +1 @@ +;; Function To Be Tested: PP (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The Evaluator ;; Page: 29 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 17, 1987 ;; ;; Last Update: Mar 23, 1987 ;; ;; Filed As: {ERIS}integration>exec>pp.u ;; ;; ;; Syntax: PP &optional NAME &rest TYPES ;; ;; Function Description: Show (prettyprinted) the definitions for NAME specified by ;; TYPES ;; ;; Argument(s): NAME (object) & TYPES (function, macro, vars, etc) ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "TY-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report ;; Messages will be printed before each command in the command files is executed for ;; user monitoring. This test will pp an object to a stream, which is opened for ;; user review. Keyword (object name) should be in bold and pretty printed ;; definitions should be formatted for readability. This test determines whether ;; Keyword(s) are in bold and function/macro definitions are structured. (DO-TEST 'PP-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: PP ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS0 "Defining a function called message .....") (SETQ MESS1 "Pretty printing the function definition for message...") (SETQ MESS2 "Creating a stream to output a pretty printed function defintion...") (SETQ MESS2.5 "The keyword message should be in bold and the function should be printed with indentation...") (SETQ MESS3 "Saving the pretty-printed function definition in a file...") (SETQ MESS4 "Setting message to some value.....") (SETQ MESS5 "Pretty printing the variable definition for message...") (SETQ MESS6 "Creating a stream to output a pretty printed variable defintion...") (SETQ MESS6.5 "The keyword message should be in bold...") (SETQ MESS7 "Saving the pretty-printed varible definition in a file...") (SETQ DO-LIST-CONTENTS-F '("(defun message (mess) (progn (princ mess)" "(sleep 1)" "(values)))")) (SETQ VARIABLE-STRING "(il:rpaqq message this-is-a-variable)") (SETQ PP-COMMAND-STRING ";; Test to see if the function message is pretty-printed (MESSAGE MESS0) (DEFUN MESSAGE (MESS) (PROGN (PRINC MESS)(SLEEP 1)(VALUES))) (MESSAGE MESS1) PP MESSAGE FUNCTION (MESSAGE MESS2) (SETQ PP-WINDOW-F (IL:CREATEW '(100 100 400 200) 'PP-WINDOW-FOR-TESTING)) (SETQ *STANDARD-OUTPUT1* *STANDARD-OUTPUT*) ; Save the original pointer (SETQ PP-STREAM-F (IL:OPENTEXTSTREAM NIL PP-WINDOW-F)) (SETQ *STANDARD-OUTPUT* PP-STREAM-F) PP MESSAGE FUNCTION (SETQ *STANDARD-OUTPUT* *STANDARD-OUTPUT1*) ; Change it back to original pointer (MESSAGE MESS2.5) (SETQ SELECTION-F (IL:TEDIT.SETSEL PP-STREAM-F 8 7)) (SETQ PLIST-F (IL:TEDIT.GET.LOOKS PP-STREAM-F SELECTION-F)) (SETQ KEYWORD-F (CADR (MULTIPLE-VALUE-LIST (GET-PROPERTIES PLIST-F '(IL:WEIGHT))))) ;; Should return IL:BOLD (SETQ SELECTION-F1 (IL:TEDIT.SETSEL PP-STREAM-F 16 27)) (SETQ PLIST-F1 (IL:TEDIT.GET.LOOKS PP-STREAM-F SELECTION-F1)) (SETQ NONKEYWORD-F (CADR (MULTIPLE-VALUE-LIST (GET-PROPERTIES PLIST-F1 '(IL:WEIGHT))))) ;; Should return IL:MEDIUM (MESSAGE MESS3) (IL:TEDIT.PUT PP-WINDOW-F '{CORE}PPF) (CLOSE PP-STREAM-F) (IL:CLOSEW PP-WINDOW-F) ;; Test to see if the variable message is pretty-printed (MESSAGE MESS4) (SETQ MESSAGE 'THIS-IS-A-VARIABLE) (MESSAGE MESS5) PP MESSAGE VARS (MESSAGE MESS6) (SETQ PP-WINDOW-V (IL:CREATEW '(100 100 400 200) 'PP-WINDOW-FOR-TESTING)) (SETQ *STANDARD-OUTPUT1* *STANDARD-OUTPUT*) (SETQ PP-STREAM-V (IL:OPENTEXTSTREAM NIL PP-WINDOW-V)) (SETQ *STANDARD-OUTPUT* PP-STREAM-V) PP MESSAGE VARS (SETQ *STANDARD-OUTPUT* *STANDARD-OUTPUT1*) (SETQ SELECTION-V (IL:TEDIT.SETSEL PP-STREAM-V 12 7)) (SETQ PLIST-V (IL:TEDIT.GET.LOOKS PP-STREAM-V SELECTION-V)) (MESSAGE MESS6.5) (SETQ KEYWORD-V (CADR (MULTIPLE-VALUE-LIST (GET-PROPERTIES PLIST-V '(IL:WEIGHT))))) ;; Should return IL:BOLD (SETQ SELECTION-V1 (IL:TEDIT.SETSEL PP-STREAM-V 20 4)) (SETQ PLIST-V1 (IL:TEDIT.GET.LOOKS PP-STREAM-V SELECTION-V1)) (SETQ NONKEYWORD-V (CADR (MULTIPLE-VALUE-LIST (GET-PROPERTIES PLIST-V1 '(IL:WEIGHT))))) ;; Should return IL:MEDIUM (MESSAGE MESS7) (IL:TEDIT.PUT PP-WINDOW-V '{CORE}PPV) (CLOSE PP-STREAM-V) (IL:CLOSEW PP-WINDOW-V) (SETQ PPF-FLG NIL) (SETQ STREAM-F (OPEN '{CORE}PPF)) (SETQ STREAM-V (OPEN '{CORE}PPV)) (DOLIST (Y DO-LIST-CONTENTS-F) (IF (STRING-EQUAL Y (READ-LINE STREAM-F)) (PUSH T PPF-FLG) (PUSH NIL PPF-FLG) ) ) (READ-LINE STREAM-V) (IF (STRING-EQUAL (READ-LINE STREAM-V) VARIABLE-STRING ) (SETQ PPV-FLG T) (SETQ PPV-FLG NIL) ) (MAPCAR #'CLOSE (IL:OPENP)) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (DO-TEST 'SEE-WITHOUT-COMMENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (NOT (EQ KEYWORD-F NONKEYWORD-F)) (NOT (EQ KEYWORD-V NONKEYWORD-V)) (NOTANY #'NULL PPF-FLG) (EQ PPV-FLG T)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF PP-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/REDO.U b/internal/test/env/Exec/Hand/REDO.U new file mode 100644 index 00000000..2e5e978f --- /dev/null +++ b/internal/test/env/Exec/Hand/REDO.U @@ -0,0 +1 @@ +;; Function To Be Tested: REDO (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 3, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERINYES}lisp>test>exec>redo.tst ;; ;; ;; Syntax: REDO EvenSpec ;; ;; Function Description: Redoes the event(s) specified by EvenSpec. ;; For example, REDO 123 repeats the event numbered 123. ;; ;; Argument(s): EvenSpec (number or sequence) ;; ;; Returns: Results of repeated event ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "REDO-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST "REDO-TEST-SETUP" (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: REDO ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ REDO-COMMAND-STRING "(setq redo-var 'old-variable) (setq redo-var 'new-variable) ;; The following should set redo-var to its original value ;; Event number may be entered in lieu of the sequence number REDO -2 (setq a 1 b 2) (psetq a b b a) ;; The following should reset the variables to their original values REDO (DO-TEST 'REDO-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (= a 1) (= b 2)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF REDO-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U b/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U new file mode 100644 index 00000000..c1b3dc82 --- /dev/null +++ b/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U @@ -0,0 +1 @@ +;; Function To Be Tested: SEE* (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The Evaluator ;; Page: 29 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 16, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}integration>exec>see-without-comment.u ;; ;; ;; Syntax: SEE &rest FILES ;; ;; Function Description: Print the contents of FILES in the exec window, showing ;; comments ;; ;; Argument(s): None ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "SEE-WITHOUT-COMMENT-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'SEE-WITHOUT-COMMENT-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: SEE-WITHOUT-COMMENT ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Creating a file with comments in ({core}SEE)...") (SETQ MESS2 "Displaying the Contents of a file without comments...") (SETQ MESS3 "Now do-test will determine if the file {core}TEST contains no comments as displayed by SEE command") (DEFUN MESSAGE (MESS) (PROGN (PRINC MESS) (SLEEP 1) (VALUES) ) ) (MESSAGE MESS1) (SETQ SEE-WINDOW (IL:CREATEW '(100 100 400 200) "SEE WINDOW FOR TESTING")) (SETQ SEE-STREAM (IL:OPENTEXTSTREAM ";;;; Lisp Init File ;;; Set up the USER package. (require 'calculus) ;I use CALCULUS a lot. Load it. (use-package 'calculus) ;Get easy access to its exported symbols. (require 'newtonian-mechanics) ;Ditto for NEWTONIAN-MECHANICS. (use-package 'newtonia-mechanics)" SEE-WINDOW)) (IL:TEDIT.PUT SEE-WINDOW '{CORE}SEE) (CLOSE SEE-STREAM) (IL:CLOSEW SEE-WINDOW) (SETQ DO-LIST-CONTENTS '("(require 'calculus)" "(use-package 'calculus)" "(require 'newtonian-mechanics)" "(use-package 'newtonia-mechanics)")) (SETQ SEE-COMMAND-STRING "(MESSAGE MESS2) (DRIBBLE '{CORE}SEE-TEST) SEE {CORE}SEE (DRIBBLE) (MESSAGE MESS3) (SETQ NO-COMMENTS-FLG NIL) (SETQ X (OPEN '{CORE}SEE-TEST)) (DO ((CNT 0 (1+ CNT))) ((= CNT 5) T) ; moves the pointer to 6th line (READ-LINE X)) (DOLIST (Y DO-LIST-CONTENTS) (IF (STRING-EQUAL Y (READ-LINE X)) (PUSH T NO-COMMENTS-FLG) (PUSH NIL NO-COMMENTS-FLG) ) ) (MAPCAR #'CLOSE (IL:OPENP)) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (DO-TEST 'SEE-WITHOUT-COMMENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (NOTANY #'NULL NO-COMMENTS-FLG) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF SEE-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/SEE.U b/internal/test/env/Exec/Hand/SEE.U new file mode 100644 index 00000000..2abb5921 --- /dev/null +++ b/internal/test/env/Exec/Hand/SEE.U @@ -0,0 +1 @@ +;; Function To Be Tested: SEE* (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The Evaluator ;; Page: 29 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 16, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}integration>exec>see-without-comment.u ;; ;; ;; Syntax: SEE* &rest FILES ;; ;; Function Description: Print the contents of FILES in the exec window, showing ;; comments ;; ;; Argument(s): None ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "SEE*-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'SEE*-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: SEE ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Creating a file with comments in ({core})...") (SETQ MESS2 "Displaying the Contents of a file with comments...") (SETQ MESS3 "Now do-test will determine if the file {core}TEST contain the contents as displayed by SEE* command") (DEFUN MESSAGE (MESS) (PROGN (PRINC MESS) (SLEEP 1) (VALUES) ) ) (MESSAGE MESS1) (SETQ SEE*-WINDOW (IL:CREATEW '(100 100 400 200) "SEE* WINDOW FOR TESTING")) (SETQ SEE*-STREAM (IL:OPENTEXTSTREAM ";;;; Lisp Init File ;;; Set up the USER package. (require 'calculus) ;I use CALCULUS a lot. Loat it. (use-package 'calculus) ;Get easy access to its exported symbols. (require 'newtonian-mechanics) ;Ditto for NEWTONIAN-MECHANICS. (use-package 'newtonia-mechanics)" SEE*-WINDOW)) (IL:TEDIT.PUT SEE*-WINDOW '{CORE}SEE) (CLOSE SEE*-STREAM) (IL:CLOSEW SEE*-WINDOW) (SETQ DO-LIST-CONTENTS '(";;;; Lisp Init File" ";;; Set up the USER package." "(require 'calculus) ;I use CALCULUS a lot. Loat it." "(use-package 'calculus) ;Get easy access to its exported symbols." "(require 'newtonian-mechanics) ;Ditto for NEWTONIAN-MECHANICS." "(use-package 'newtonia-mechanics)")) (SETQ SEE*-COMMAND-STRING "(MESSAGE MESS2) (DRIBBLE '{CORE}SEE-TEST) SEE* {CORE}SEE (DRIBBLE) (MESSAGE MESS3) (SETQ CONTENTS-EXIST-FLG NIL) (SETQ X (OPEN '{CORE}SEE-TEST)) (DO ((CNT 0 (1+ CNT))) ; moves the pointer to 4th line ((= CNT 3) T) (READ-LINE X)) (DOLIST (Y DO-LIST-CONTENTS) (IF (STRING-EQUAL Y (READ-LINE X)) (PUSH T CONTENTS-EXIST-FLG) (PUSH NIL CONTENTS-EXIST-FLG)) ) (CLOSE X) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (DO-TEST 'FIND-EVENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (NOTANY #'NULL CONTENTS-EXIST-FLG) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF SEE*-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/TEST.REPORT b/internal/test/env/Exec/Hand/TEST.REPORT new file mode 100644 index 00000000..9be14a60 --- /dev/null +++ b/internal/test/env/Exec/Hand/TEST.REPORT @@ -0,0 +1 @@ +TEST REPORT FOR THE LYRIC EXECUTIVE SYSTEM COMMAND: REMEMBER STATUS: success DATE: 23-Feb-87 15:35:33 TESTER: jpark.pasa COMMAND: CONN STATUS: success DATE: 26-Feb-87 13:38:30 TESTER: jpark.pasa COMMAND: MASTERSCOPE STATUS: success DATE: 26-Feb-87 13:51:48 TESTER: jpark.pasa COMMAND: DA STATUS: success DATE: 26-Feb-87 13:57:31 TESTER: jpark.pasa COMMAND: DIR STATUS: success DATE: 26-Feb-87 14:20:09 TESTER: jpark.pasa COMMAND: FORGET STATUS: success DATE: 26-Feb-87 14:22:50 TESTER: jpark.pasa COMMAND: RETRY STATUS: success DATE: 26-Feb-87 14:49:01 TESTER: jpark.pasa COMMAND: DO-EVENTS STATUS: success DATE: 26-Feb-87 14:51:41 TESTER: jpark.pasa COMMAND: TIME STATUS: success DATE: 26-Feb-87 16:06:18 TESTER: jpark.pasa COMMAND: FIX STATUS: success DATE: 26-Feb-87 16:18:44 TESTER: jpark.pasa COMMAND: REDO STATUS: success DATE: 27-Feb-87 11:01:37 TESTER: jpark.pasa COMMAND: PL STATUS: fail DATE: 27-Feb-87 11:11:54 TESTER: jpark.pasa COMMAND: NDIR STATUS: success DATE: 27-Feb-87 12:01:07 TESTER: jpark.pasa COMMAND: MULTIPLE-USE STATUS: success DATE: 27-Feb-87 12:55:58 TESTER: jpark.pasa COMMAND: NAME STATUS: success DATE: 27-Feb-87 12:59:35 TESTER: jpark.pasa COMMAND: UNDO STATUS: success DATE: 27-Feb-87 13:21:12 TESTER: jpark.pasa COMMAND: REDO STATUS: success DATE: 27-Feb-87 13:41:26 TESTER: jpark.pasa COMMAND: SHH STATUS: success DATE: 27-Feb-87 13:51:37 TESTER: jpark.pasa COMMAND: USE STATUS: fail DATE: 27-Feb-87 14:04:58 TESTER: jpark.pasa COMMAND: HELP STATUS: success DATE: 27-Feb-87 14:09:38 TESTER: jpark.pasa COMMAND: SEE STATUS: success DATE: 27-Feb-87 14:11:55 TESTER: jpark.pasa COMMAND: FIND-EVENT STATUS: success DATE: 27-Feb-87 14:42:41 TESTER: jpark.pasa COMMAND: SEE-WITHOUT-COMMENT STATUS: fail DATE: 27-Feb-87 15:25:46 TESTER: jpark.pasa COMMAND: TY STATUS: fail DATE: 27-Feb-87 15:33:07 TESTER: jpark.pasa COMMAND: TYPE STATUS: fail DATE: 27-Feb-87 15:43:59 TESTER: jpark.pasa COMMAND: PP STATUS: success DATE: 27-Feb-87 16:08:06 TESTER: jpark.pasa COMMAND: PL STATUS: success DATE: 27-Feb-87 16:53:09 TESTER: jpark.pasa COMMAND:CONN STATUS: success DATE: 3-Mar-87 17:25:33 TESTER: cate3 COMMAND:CONN STATUS: success DATE: 3-Mar-87 17:27:14 TESTER: cate3 COMMAND:CONN STATUS: success DATE: 3-Mar-87 17:28:02 TESTER: cate3 COMMAND: DA STATUS: success DATE: 13-Mar-87 16:55:32 TESTER: kelley COMMAND: DA STATUS: SUCCESS DATE: 19-Mar-87 09:50:50 TESTER: SCHUSTER COMMAND:CONN STATUS: SUCCESS DATE: 19-Mar-87 10:30:45 TESTER: SCHUSTER COMMAND:DIR STATUS: SUCCESS DATE: 19-Mar-87 11:00:11 TESTER: SCHUSTER COMMAND: DO-EVENTS STATUS: SUCCESS DATE: 19-Mar-87 11:13:17 TESTER: SCHUSTER COMMAND: FIND-EVENT STATUS: SUCCESS DATE: 19-Mar-87 13:03:54 TESTER: SCHUSTER COMMAND: FIX STATUS: SUCCESS DATE: 19-Mar-87 13:14:14 TESTER: SCHUSTER COMMAND: FORGET STATUS: SUCCESS DATE: 19-Mar-87 13:25:29 TESTER: SCHUSTER COMMAND: HELP STATUS: FAIL DATE: 19-Mar-87 13:42:25 TESTER: SCHUSTER COMMAND: MULTIPLE-USE STATUS: SUCCESS DATE: 20-Mar-87 10:44:13 TESTER: SCHUSTER COMMAND: NAME STATUS: FAIL DATE: 20-Mar-87 10:53:46 TESTER: SCHUSTER COMMAND: NDIR STATUS: SUCCESS DATE: 20-Mar-87 11:24:58 TESTER: SCHUSTER COMMAND: NAME STATUS: FAIL DATE: 20-Mar-87 11:30:07 TESTER: SCHUSTER COMMAND: PL STATUS: SUCCESS DATE: 20-Mar-87 13:01:36 TESTER: SCHUSTER COMMAND: PP STATUS: FAIL DATE: 20-Mar-87 14:24:05 TESTER: SCHUSTER COMMAND: PP STATUS: FAIL DATE: 20-Mar-87 14:38:28 TESTER: SCHUSTER COMMAND: REDO STATUS: SUCCESS DATE: 20-Mar-87 14:49:48 TESTER: SCHUSTER COMMAND: REMEMBER STATUS: SUCCESS DATE: 20-Mar-87 15:00:54 TESTER: SCHUSTER COMMAND: RETRY STATUS: SUCCESS DATE: 20-Mar-87 15:06:42 TESTER: SCHUSTER Comment: Tester should enter RETRY Z to see if a break window does appear on error. COMMAND: PP STATUS: FAIL DATE: 23-Mar-87 08:09:25 TESTER: SCHUSTER COMMAND: PP STATUS: SUCCESS DATE: 23-Mar-87 08:32:22 TESTER: SCHUSTER COMMAND: PP STATUS: SUCCESS DATE: 23-Mar-87 08:59:35 TESTER: SCHUSTER.PASA COMMAND: RETRY STATUS: SUCCESS DATE: 23-Mar-87 09:09:07 TESTER: SCHUSTER.PASA Comment: Tester should enter RETRY Z to see if a break window does appear on error. COMMAND: USE STATUS: FAIL DATE: 23-Mar-87 09:17:29 TESTER: SCHUSTER.PASA COMMAND: SHH STATUS: SUCCESS DATE: 23-Mar-87 09:25:21 TESTER: SCHUSTER.PASA COMMAND: UNDO STATUS: SUCCESS DATE: 23-Mar-87 09:32:23 TESTER: SCHUSTER.PASA COMMAND: SEE STATUS: SUCCESS DATE: 23-Mar-87 09:40:37 TESTER: SCHUSTER.PASA COMMAND: SEE-WITHOUT-COMMENT STATUS: FAIL DATE: 23-Mar-87 09:47:19 TESTER: SCHUSTER.PASA COMMAND: TY STATUS: FAIL DATE: 23-Mar-87 10:02:57 TESTER: SCHUSTER.PASA COMMAND: TYPE STATUS: FAIL DATE: 23-Mar-87 10:09:09 TESTER: SCHUSTER.PASA COMMAND: RETRY STATUS: SUCCESS DATE: 24-Mar-87 16:07:16 TESTER: JPARK.PASA Comment: Tester should enter RETRY Z to see if a break window does appear on error. COMMAND: RETRY STATUS: SUCCESS DATE: 24-Mar-87 16:08:37 TESTER: JPARK.PASA Comment: Tester should enter RETRY Z to see if a break window does appear on error. COMMAND: RETRY STATUS: SUCCESS DATE: 24-Mar-87 16:13:20 TESTER: JPARK.PASA Comment: Tester should enter RETRY Z to see if a break window does appear on error. COMMAND: RETRY STATUS: SUCCESS DATE: 25-Mar-87 08:24:44 TESTER: SCHUSTER.PASA Comment: Tester should enter (RETRY-Z) to see if a break window does appear on error. COMMAND: RETRY STATUS: SUCCESS DATE: 25-Mar-87 08:43:01 TESTER: SCHUSTER.PASA Comment: Tester should enter (RETRY-Z) to see if a break window does appear on error. COMMAND: RETRY-BREAK STATUS: SUCCESS DATE: 25-Mar-87 08:44:29 TESTER: SCHUSTER.PASA \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/TY.U b/internal/test/env/Exec/Hand/TY.U new file mode 100644 index 00000000..2715feef --- /dev/null +++ b/internal/test/env/Exec/Hand/TY.U @@ -0,0 +1 @@ +;; Function To Be Tested: TY (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The Evaluator ;; Page: 29 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 16, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}test>exec>ty.u ;; ;; ;; Syntax: TY &rest FILES ;; ;; Function Description: Print the contents of FILES in the exec window, hiding ;; comments ;; ;; Argument(s): FILES ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "TY-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'TY-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: TY ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Creating a file with comments in ({core}TY)...") (SETQ MESS2 "Displaying the Contents of a file without comments...") (SETQ MESS3 "Now do-test will determine if the file {core}TEST contains no comments as displayed by TY command") (DEFUN MESSAGE (MESS) (PROGN (PRINC MESS) (SLEEP 1) (VALUES) ) ) (MESSAGE MESS1) (SETQ TY-WINDOW (IL:CREATEW '(100 100 400 200) "TY WINDOW FOR TESTING")) (SETQ TY-STREAM (IL:OPENTEXTSTREAM ";;;; Lisp Init File ;;; Set up the USER package. (require 'calculus) ;I use CALCULUS a lot. Load it. (use-package 'calculus) ;Get easy access to its exported symbols. (require 'newtonian-mechanics) ;Ditto for NEWTONIAN-MECHANICS. (use-package 'newtonia-mechanics)" TY-WINDOW)) (IL:TEDIT.PUT TY-WINDOW '{CORE}TY) (CLOSE TY-STREAM) (IL:CLOSEW TY-WINDOW) (SETQ DO-LIST-CONTENTS '("(require 'calculus)" "(use-package 'calculus)" "(require 'newtonian-mechanics)" "(use-package 'newtonia-mechanics)")) (SETQ TY-COMMAND-STRING "(MESSAGE MESS2) (DRIBBLE '{CORE}TY-TEST) TY {CORE}TY (DRIBBLE) (MESSAGE MESS3) (SETQ NO-COMMENTS-FLG NIL) (SETQ X (OPEN '{CORE}TY-TEST)) (DO ((CNT 0 (1+ CNT))) ((= CNT 5) T) ; moves the pointer to 6th line (READ-LINE X)) (DOLIST (Y DO-LIST-CONTENTS) (IF (STRING-EQUAL Y (READ-LINE X)) (PUSH T NO-COMMENTS-FLG) (PUSH NIL NO-COMMENTS-FLG) ) ) (MAPCAR #'CLOSE (IL:OPENP)) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (DO-TEST 'SEE-WITHOUT-COMMENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (NOTANY #'NULL NO-COMMENTS-FLG) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF TY-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/TYPE.U b/internal/test/env/Exec/Hand/TYPE.U new file mode 100644 index 00000000..5b586bf5 --- /dev/null +++ b/internal/test/env/Exec/Hand/TYPE.U @@ -0,0 +1 @@ +;; Function To Be Tested: TYPE (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The Evaluator ;; Page: 29 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 16, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}test>exec>type.u ;; ;; ;; Syntax: TYPE &rest FILES ;; ;; Function Description: Print the contents of FILES in the exec window, hiding ;; comments ;; ;; Argument(s): FILES ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "TYPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'TYPE-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: TYPE ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS1 "Creating a file with comments in ({core}TYPE)...") (SETQ MESS2 "Displaying the Contents of a file without comments...") (SETQ MESS3 "Now do-test will determine if the file {core}TEST contains no comments as displayed by TYPE command") (DEFUN MESSAGE (MESS) (PROGN (PRINC MESS) (SLEEP 1) (VALUES) )) (MESSAGE MESS1) (SETQ TYPE-WINDOW (IL:CREATEW '(100 100 400 200) "TYPE WINDOW FOR TESTING")) (SETQ TYPE-STREAM (IL:OPENTEXTSTREAM ";;;; Lisp Init File ;;; Set up the USER package. (require 'calculus) ;I use CALCULUS a lot. Load it. (use-package 'calculus) ;Get easy access to its exported symbols. (require 'newtonian-mechanics) ;Ditto for NEWTONIAN-MECHANICS. (use-package 'newtonia-mechanics)" TYPE-WINDOW)) (IL:TEDIT.PUT TYPE-WINDOW '{CORE}TYPE) (CLOSE TYPE-STREAM) (IL:CLOSEW TYPE-WINDOW) (SETQ DO-LIST-CONTENTS '("(require 'calculus)" "(use-package 'calculus)" "(require 'newtonian-mechanics)" "(use-package 'newtonia-mechanics)")) (SETQ TYPE-COMMAND-STRING "(MESSAGE MESS2) (DRIBBLE '{CORE}TYPE-TEST) TYPE {CORE}TYPE (DRIBBLE) (MESSAGE MESS3) (SETQ NO-COMMENTS-FLG NIL) (SETQ X (OPEN '{CORE}TYPE-TEST)) (DO ((CNT 0 (1+ CNT))) ((= CNT 5) T) ; moves the pointer to 6th line (READ-LINE X)) (DOLIST (Y DO-LIST-CONTENTS) (IF (STRING-EQUAL Y (READ-LINE X)) (PUSH T NO-COMMENTS-FLG) (PUSH NIL NO-COMMENTS-FLG) ) ) (MAPCAR #'CLOSE (IL:OPENP)) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (DO-TEST 'TYPE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (NOTANY #'NULL NO-COMMENTS-FLG) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF TYPE-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/USE.U b/internal/test/env/Exec/Hand/USE.U new file mode 100644 index 00000000..ec957a4e --- /dev/null +++ b/internal/test/env/Exec/Hand/USE.U @@ -0,0 +1 @@ +;; Function To Be Tested: USE (EXEC Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 26 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 4, 1987 ;; ;; Last Update: Feb 27, 1987 ;; ;; Filed As: {ERIS}test>exec>USE-event.u ;; ;; ;; Syntax: USE NEW [FOR OLD] [IN EventSpec] ;; ;; Function Description: Substitutes NEW for OLD in the events specified by ;; EventSpec, and redoes the result. NEW and OLD can include lists or symbols. ;; ;; Argument(s): EvenSpec (number or sequence) ;; ;; Returns: Results of substituted variables in the previous event ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "USE", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST "USE-TEST-SETUP" (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: USE ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ USE-COMMAND-STRING "(setq sin-val (sin 0)) ;; The following will use COS instead of SIN in the previous event USE COS for SIN (= sin-val (cos 0)) ; Should return T (setq val-1 (sin 1.5)) (setq val-2 (sin 2.0)) ;; The following should substitute COS for every occurrence of SIN in the previous ;; two events, and substitute (- X) for every occurence of X, and reexecute them. USE COS (- X) for SIN X IN -2 and -1 (and (= val-1 (cos -1.5)) (= val-2 (cos -2.0)) ) (fboundp 'tan) (boundp 'sin) (boundp 'pi) (setq new-variable 'xyz) ;; The following should return nil USE FBOUNDP FOR BOUNDP (fboundp '*package*) (boundp '*package*) ;; The following has the same effect as USE BOUNDP FOR FBOUNDP and should return T USE BOUNDP FOR FBOUNDP IN F FBOUNDP (setq sin 'trig-function) ;; FBOUNDP(SIN) ;; The following is equivalent to USE BOUNDP FOR FBOUNDP IN -1 USE BOUNDP (makunbound 'sin) (DO-TEST 'USE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (= SIN-VAL (COS 0)) (AND (= VAL-1 (COS -1.5)) (= VAL-2 (COS -2.0)) ) ) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF USE-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/do-events.u b/internal/test/env/Exec/Hand/do-events.u new file mode 100644 index 00000000..6ee3a536 --- /dev/null +++ b/internal/test/env/Exec/Hand/do-events.u @@ -0,0 +1 @@ +;; Function To Be Tested: DO-EVENTS (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 11, 1987 ;; ;; Last Update: Feb 26, 1987 ;; ;; Filed As: {ERIS}integration>exec>do-events.u ;; ;; ;; Syntax: DO-EVENTS &rest INPUTS &Environment ENV ;; ;; Function Description: Executes the multiple events in INPUTS, using ENV for ;; non-EVAL format ;; ;; Argument(s): INPUTS and ENV ;; ;; Returns: Results of the multiple events in INPUTS ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "DO-EVENTS-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'DO-EVENTS-TEST-SETUP (PROGN (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: DO-EVENTS ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ MESS0 "This constitutes partial testing only...") (SETQ MESS1 "The values should now have been assigned to first-event, second-event, and third event are as follows...") (SETQ FORMAT-STRING "FIRST-EVENT: ~D ~% SECOND-EVENT: ~D ~% THIRD-EVENT: ~D") (SETQ DO-EVENTS-STRING "(PROGN (PRINC MESS0) (SLEEP 2) (VALUES) ) DO-EVENTS (SETQ FIRST-EVENT 10) (SETQ SECOND-EVENT 20) (SETQ THIRD-EVENT 30) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) (FORMAT NIL FORMAT-STRING FIRST-EVENT SECOND-EVENT THIRD-EVENT ) ) (DO-TEST 'DO-EVENTS-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (= FIRST-EVENT 10) (= SECOND-EVENT 20) (= THIRD-EVENT 30)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF DO-EVENTS-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/exec.log b/internal/test/env/Exec/Hand/exec.log new file mode 100644 index 00000000..cc0e2880 --- /dev/null +++ b/internal/test/env/Exec/Hand/exec.log @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 10:28:06 ;;; Tests run on 7-Apr-87 20:01:15 ;;; Running tests from (*.u;) (Trouble reading DO-EVENTS.U;2) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/forget.u b/internal/test/env/Exec/Hand/forget.u new file mode 100644 index 00000000..155c2340 --- /dev/null +++ b/internal/test/env/Exec/Hand/forget.u @@ -0,0 +1 @@ +;; Function To Be Tested: FORGET (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}test>exec>forget.u ;; ;; ;; Syntax: FORGET &rest EVENT-SPEC ;; ;; Function Description: Erase UNDO information for the specified events. ;; ;; Argument(s): EVENT-SPEC ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will not be totally automatic. Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT package. ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>exec>test.report. (DO-TEST "FORGET-TEST-SETUP" (PROGN (SETQ MESS1 "Now do-test will determine if side effects of the forgotten event cannot be undone...") (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: FORGET~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ FORGET-COMMAND-STRING "; Unbound all undo variables (MAPCAR #'MAKUNBOUND '(FORGET-VAR-1 FORGET-VAR-2)) ; CASE I Setting and resetting the variable FORGET-VAR-1.. (SETQ FORGET-VAR-1 100) (SETQ FORGET-VAR-1 200) ; The following will UNDO the side effect of (SETQ FORGET-VAR-1 200) UNDO -1 ; SETQ in undone and nothing should have been saved now (IF (= FORGET-VAR-1 100) (SETQ VAR-PROP-1 'UNDONE) (SETQ VAR-PROP-1 'INTACT)) ; CASE II (FORGET) Setting and reseeting the variable FORGET-VAR-2... (SETQ FORGET-VAR-2 700) (SETQ FORGET-VAR-2 800) ; Erasing undo information on (SETQ FORGET-VAR-2 800) FORGET -1 ; The event (SETQ FORGET-VAR-2 800) has been erased from history list ; Setq cannot be undone UNDO -2 (IF (= FORGET-VAR-2 800) (SETQ VAR-PROP-2 'FORGOTTEN) (SETQ VAR-PROP-2 'UNFORGOTTEN)) (FORMAT NIL MESS1) (DO-TEST 'FORGET-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (EQ VAR-PROP-1 'UNDONE) (EQ VAR-PROP-2 'FORGOTTEN)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF FORGET-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/log-form b/internal/test/env/Exec/Hand/log-form new file mode 100644 index 0000000000000000000000000000000000000000..fd7206f504ee45896440039b14056d7790aae6ff GIT binary patch literal 1096 zcma)&T~ER=6o$)}x}zlOjb8Q=OosQwV1N}Nfo<7_k;{b@Tr$|QO#&M4{8j!s+X2b8 z60q6Y)3?ug&uJ~X2>j3vH`t<4jEDXl&-@URHJyIM?ur5=x?;z)xs9nKcQ!2UxgK?J z+ic=561vg%ljlak)DLMZW=<{29FnNv`E!7-zgXByN7C&mdhFS*2Vf9IlO&0)mN8-L z*d!7>ICGbdOjmRnGoh=gssu_Klz{7h-|h9uZLa zaRb*Db`;Yvn)(5)gFa+sMr70>2AKUmj8#PgT?dm8{y%^m{JmyZ&hyiF5ASuR{~V&C#Xp^_((JET)?^2AwQ;IEXa vQqBv4sX(0PQ-sC@;X0op^daR5p{!skc$`i-?U5n)+a~YJrotWSfByaf0W4dj literal 0 HcmV?d00001 diff --git a/internal/test/env/Exec/Hand/masterscope.u b/internal/test/env/Exec/Hand/masterscope.u new file mode 100644 index 00000000..8612f8f8 --- /dev/null +++ b/internal/test/env/Exec/Hand/masterscope.u @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}test>exec>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will not be totally automatic. Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Function ;; | ;; Func-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Func-A1 Func-A2 Func-A3 Func-B1 Func-B2 Func-B3 ;; | ;; -------------- ;; | | ;; Func-C1 Func-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>exec>test.report. (DO-TEST "MASTERSCOPE-TEST-SETUP" (PROGN (SETQ MESS1 "Now do-test will determine if correct results have been returned for the analysis of user functions...") (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~2%COMMAND:MASTERSCOPE~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (DEFUN TOP-FUNCTION NIL (AND (FUNC-A) (FUNC-B))) (DEFUN FUNC-A NIL (OR (FUNC-A1) (FUNC-A2) (FUNC-A3))) (DEFUN FUNC-B NIL (OR (FUNC-B1) (FUNC-B2) (FUNC-B3))) (DEFUN FUNC-A1 NIL T) (DEFUN FUNC-A2 NIL NIL) (DEFUN FUNC-A3 NIL T) (DEFUN FUNC-B1 NIL (AND (FUNC-C1)(FUNC-A1))) (DEFUN FUNC-B2 NIL NIL) (DEFUN FUNC-B3 NIL T) (DEFUN FUNC-C1 NIL NIL) (SETQ {CORE}WHO-CALLS "{CORE}WHO-CALLS") (SETQ {CORE}PATHS "{CORE}PATHS") (SETQ MASTERSCOPE-COMMAND-STRING "; Start analyzing functions in top-function . ANALYZE TOP-FUNCTION . ANALYZE FUNC-A . ANALYZE FUNC-B . ANALYZE FUNC-B1 . WHO CALLS FUNC-A1 (IF (EQUAL * '(FUNC-A FUNC-B1)) (SETQ FUNC-A1-CALL T) (SETQ FUNC-A1-CALL NIL)) . WHO CALLS TOP-FUNCTION (IF (EQUAL * NIL) (SETQ TOP-FUNC-CALL T) (SETQ TOP-FUNC-CALL NIL)) . WHO CALLS FUNC-A (IF (EQUAL * '(TOP-FUNCTION)) (SETQ FUNC-A-CALL T) (SETQ FUNC-A-CALL NIL)) . WHO CALLS FUNC-B2 (IF (EQUAL * '(FUNC-B)) (SETQ FUNC-B-CALL T) (SETQ FUNC-B-CALL NIL)) (DRIBBLE '{CORE}WHO-CALLS) . WHO CALLS WHO (DRIBBLE) (DRIBBLE '{CORE}PATHS) . SHOW PATHS TO FUNC-A1 FROM TOP-FUNCTION (DRIBBLE) ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ CALL-LIST '(|func-b -- (func-b1 func-b2 func-b3)| |func-b1 -- (func-c1 func-a1)| |func-a -- (func-a1 func-a2 func-a3)| |top-function -- (func-a func-b)|)) (SETQ WHO-CALLS-FLG NIL) (SETQ WHO-CALLS (OPEN {CORE}WHO-CALLS)) (READ-LINE WHO-CALLS) (READ-LINE WHO-CALLS) (DOLIST (Y CALL-LIST) (IF (STRING-EQUAL Y (READ-LINE WHO-CALLS)) (PUSH T WHO-CALLS-FLG) (PUSH NIL WHO-CALLS-FLG))) (CLOSE WHO-CALLS) ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN {CORE}PATHS)) (DO (( i 0 (1+ i))) ((= i 5) t) (READ-LINE PATHS)) (IF (AND (STRING-EQUAL (READ-LINE PATHS) '|1.func-a1 func-a top-function|) (STRING-EQUAL (READ-LINE PATHS) '|2. func-b1 func-b top-function|)) (SETQ PATHS-FLG T)(SETQ PATHS-FLG NIL)) (CLOSE PATHS) (DELETE-FILE '{CORE}PATHS) (DELETE-FILE '{CORE}WHO-CALLS) (FORMAT NIL MESS1) (DO-TEST 'MASTERSCOPE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (EQ FUNC-A1-CALL T) (EQ TOP-FUNC-CALL T) (EQ FUNC-A-CALL T) (EQ FUNC-B-CALL T) (EQ PATHS-FLG T) (NOTANY #'NULL WHO-CALLS-FLG)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF MASTERSCOPE-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/name.u b/internal/test/env/Exec/Hand/name.u new file mode 100644 index 00000000..62eb51d8 --- /dev/null +++ b/internal/test/env/Exec/Hand/name.u @@ -0,0 +1 @@ +;; Function To Be Tested: NAME (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 (The Evaluator) ;; Section: The Evaluator ;; Page: 28 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}test>exec>name.u ;; ;; ;; Syntax: NAME COMMAND-NAME &optional ARGUMENTS &rest EVENT-SPEC ;; ;; Function Description: Similar to REDO except sets the debugger parameters ;; so that any errrors that occur while executing EventSpec will cause breaks. ;; ;; Argument(s): Command-Name, Arguments, and Event-Spec ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; Each test setup is titled "NAME-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>exec>test.report. (DO-TEST "NAME-TEST-SETUP" (PROGN (SETQ MESS0 "Setting the variable today-1...") (SETQ MESS1 "Defining a new command DATE using DA...") (SETQ MESS2 "Setting and resetting FOO...") (SETQ MESS3 "Defining a new command called Foo-2, which will return the value assigned when foo was reset for the second time...") (SETQ MESS4 "Now do-test will determine if correct results have been produced...") (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: NAME ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ NAME-COMMAND-STRING "(FORMAT NIL MESS0) DA (SETQ TODAY-1 CL:*) (FORMAT NIL MESS1) NAME DATE DA DATE (SETQ TODAY-2 CL:*) (FORMAT NIL MESS2) (SETQ FOO 'FIRST-FOO) (SETQ FOO 'SECOND-FOO) (SETQ FOO 'THIRD-FOO) NAME FOO-2 FOO -2 FOO-2 (SETQ NEW-FOO CL:*) (FORMAT NIL MESS3) (DO-TEST 'NAME-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (STRING-EQUAL TODAY-1 TODAY-2 :END1 16 :END2 16) (EQ NEW-FOO 'SECOND-FOO)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF NAME-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/remember.u b/internal/test/env/Exec/Hand/remember.u new file mode 100644 index 00000000..15fa9ac2 --- /dev/null +++ b/internal/test/env/Exec/Hand/remember.u @@ -0,0 +1 @@ +;; Function To Be Tested: REMEMBER (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The REMEMBER ;; Page: 28 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}exec>remember.u ;; ;; ;; Syntax: REMEMBER &REST EVENT-SPEC ;; ;; Function Description: Tell History list manager to remember type-in from ;; specified event(s) ;; ;; Argument(s): Event-Spec ;; ;; Returns: See function description ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "REMEMBER-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. This test will determine whether the specified event for ;; REMEMBER is "remembered". Test result is logged on ;; {eris}test>exec>test.report. (DO-TEST "REMEMBER-TEST-SETUP" (PROGN (SETQ MESS0 "remembering the specified event...") (SETQ MESS1 "Do-test will determine if the remembered event can be retrieved and re-executed...") (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: REMEMBER~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ REMEMBER-COMMAND-STRING "(FORMAT NIL MESS0) (SETQ X 100 Y 50) (SETQ EVENT-ONE (+ X Y)) (SETQ EVENT-TWO (- X Y)) (SETQ EVENT-THREE (* X Y)) (FORMAT NIL MESS1) REMEMBER -4 (SETQ REMEMBERED-VAL-ONE CL:*) REMEMBER -5 (SETQ REMEMBERED-VAL-TWO CL:*) REMEMBER -6 (SETQ REMEMBERED-VAL-THREE CL:*) (FORMAT NIL MESS1) (DO-TEST 'REMEMBER-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (EQUAL REMEMBERED-VAL-ONE '(SETQ EVENT-ONE (+ X Y))) (EQUAL REMEMBERED-VAL-TWO '(SETQ EVENT-TWO (- X Y))) (EQUAL REMEMBERED-VAL-THREE '(SETQ EVENT-THREE (* X Y))) ) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF REMEMBER-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/retry.u b/internal/test/env/Exec/Hand/retry.u new file mode 100644 index 00000000..7fb84d27 --- /dev/null +++ b/internal/test/env/Exec/Hand/retry.u @@ -0,0 +1 @@ +;; Function To Be Tested: RETRY (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 (The Evaluator) ;; Section: The RETRY ;; Page: 28 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 23, 1987 ;; ;; Last Update: March 24, 1987 ;; ;; Filed As: {ERIS}test>exec>retry.u ;; ;; ;; Syntax: RETRY EVENT-SPEC ;; ;; Function Description: Similar to REDO except sets the debugger parameters ;; so that any errrors that occur while executing EventSpec will cause breaks. ;; ;; Argument(s): Event-Spec ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will not be totally automatic. Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT package. Since RETRY will break on error, ;; it should be tested manually to see if a break window appear. ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>exec>test.report. (DO-TEST "RETRY-TEST-SETUP" (PROGN (SETQ MESS0 "Setting variables X,Y, and Z to some numbers...") (SETQ MESS1 "Re-executing the previous event...") (SETQ MESS2 "Please enter (RETRY-Z) after do-test is completed determine if RETRYing an event that generates an error will break... The apperance of a break window is the expected result. After entering ^ in the break window, indicate whether test has succeeded or failed by entering (RETRY-TEST T) or (RETRY-TEST NIL) respectively") (DEFUN RETRY-Z NIL (IL:BKSYSBUF "RETRY-Z RETRY ")) (DEFUN RETRY-TEST (FLG) (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (EQ FLG T) (R-FORMAT 'SUCCESS) (R-FORMAT 'FAIL)) (CLOSE *OUTPUT*))) (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: RETRY-BREAK~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (DEFUN R1-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: RETRY~%STATUS: ~A DATE: ~A TESTER: ~A~%Comment: Tester should enter (RETRY-Z) to see if a break window ~%does appear on error.~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ RETRY-COMMAND-STRING "(FORMAT NIL MESS0) (SETQ X 100 Y 50) (SETQ Z (+ X Y)) (FORMAT NIL MESS1) RETRY -2 (SETQ NEW-Z CL:*) (SETQ Y 'NON-NUMBER) (SETQ Z (+ X Y)) NAME RETRY-Z -1 (IL:PROMPTPRINT MESS2) (SLEEP 3) (DO-TEST 'RETRY-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (= Z NEW-Z) (PROGN (R1-FORMAT 'SUCCESS) T) (PROGN (R1-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF RETRY-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/shh.u b/internal/test/env/Exec/Hand/shh.u new file mode 100644 index 00000000..7995aca9 --- /dev/null +++ b/internal/test/env/Exec/Hand/shh.u @@ -0,0 +1 @@ +;; Function To Be Tested: SHH (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 28 ;; ;; Section: The Evaluator ;; ;; Created By: John Park ;; ;; Creation Date: Feb 11, 1987 ;; ;; Last Update: FEB 27, 1987 ;; ;; Filed As: {ERIS}test>exec>shh.u ;; ;; ;; Syntax: SHH &rest LINE ;; ;; Function Description: Execute LINE without history list processing ;; ;; Argument(s): LINE ;; ;; Returns: Results of the specified form (LINE) ;; ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them willbe accomplished by using the interlisp function bksysbuf ;; in do-test form. Comments are incorporated within each command file. ;; The do-test test setup is titled "SHH-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test "quote" ;; failed in file "unknown". " This test file requires TEDIT package. ;; The test result will be logged automatically in the following file: ;; {ERIS}test>exec>test.report (DO-TEST 'SHH-TEST-SETUP (PROGN (SETQ MESS0 "Executing an event with history processing...") (SETQ MESS1 "The previous event was not entered in the history list...") (SETQ MESS2 "Re-executing event containing TODAY(this should have reset the varible today rather than tomorrow)...") (SETQ MESS3 "As indicated by the following, the event containing the variable TOMORROW was not entered in the history list...") (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: SHH ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ SHH-STRING "FIX -6 (PROGN (PRINC MESS3) (SLEEP 2) (VALUES) (FORMAT NIL FORMAT-STRING TODAY TODAY-1 TOMORROW TOMORROW-1) ) (DO-TEST 'FIND-EVENT-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (NOT (EQUAL TODAY TODAY-1)) (EQUAL TOMORROW TOMORROW-1)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (SETQ FORMAT-STRING "TODAY: ~A TODAY-1: ~A ~% TOMORROW: ~A TOMORROW-1: ~A") (SETQ SHH-COMMAND-STRING "(PROGN (PRINC MESS0) (SLEEP 2) (VALUES) ) (SETQ TODAY (IL:DATE)) SHH (SETQ TOMORROW (IL:DATE)) (PROGN (PRINC MESS1) (SLEEP 2) (VALUES) ) (SETQ TOMORROW-1 TOMORROW) (SETQ TODAY-1 TODAY) (PROGN (PRINC MESS2) (SLEEP 2) (VALUES) ) (IL:EVAL.AS.PROCESS '(IL:BKSYSBUF SHH-STRING)) ") (IL:BKSYSBUF SHH-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/test.proc b/internal/test/env/Exec/Hand/test.proc new file mode 100644 index 0000000000000000000000000000000000000000..ce2194c397429e4c24cbcfd8dc8cbda1c26ef0f0 GIT binary patch literal 2498 zcmaJ@O>f&q5LJryP^CGyw+?)XY*0kv_GA<;6q`w0$dVu_MS5J3BXbdwOYAP~C`Awb zTfOvO_1rhRl%sqg21HTI-I+IU-Wz(&&eOu0oQuw~qph)YVd~m6G}W%9>@DY=*SAco zo%37|hfh;_kXDt^A-IWYH;au1SD)7LyrYUg1fE+$3Bn7;Kl-laE-C3Q}Gxmy>TrotE&R5%Y6AF zTPHM|TqE!->`6zpLTc-B(@OZoRMKB(*UvIUSiO7+1T(?3Sm0-dbGV!&w7!xUYoJt3 zf$v3z>VCd=7cG|ai|q2%GFzPuhYD4%gN#J04T&i_uQnCaR?7vxJrrgzO%5X?wi9Rk z$yU3+ei64peS9u-oy)HCM%A2lG>R&fU*ZQ5RJeyD`h1XWh<6MuD}!ylSw74a41keQ z>32-7Wmu=8yi~BRkVJdQfqSVtjb_;}H)L5d!m>t&g{V+&Lw$H4a>TOO459&7n-qG& zE+*SGjXW06kr|m-QX*C{7(Av*sc*_^ha6G`H$@l?@T!~%Q^c|oJK|^5>gRMEAP1f$ zcz^~n=$f5_K+ze1X|2XwE1=1ME$l{4xE;v%oQ30{IikgGXOQ|3POWz6YE_v#D)H%y zk=E?bh$M`R!dB9X0uFhQ0|`||6`%CJ(i^Mn?z}K#*_Bp+M4@!5sLf=8EXAIYd@2JJ_220pG*-92ka&RIMl{B!qwBS}*9n^i& zpE{wJssdg)gt zkK+p(kAqv@LcIZcu0Ezm(nL#P>YKC^Wu zC(0L$u|)^v(EI34EQ-h?K_`>2#mK_2p@IB;J@{(y!{Ct&?$vURm(Sq4u#V-=uZO2k uexec>time.u ;; ;; ;; Syntax: TIME FORM &key REPEAT &environment ENV ;; ;; Function Description: Time the evaluation of FORM in the lexical environment ;; ENV, repeating REPEAT number of times. Information is displayed in the exec ;; window. ;; ;; Argument(s): FORM ;; REPEAT (number) ;; ENV (environment) ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will not be totally automatic. Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT package. ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. This test will determine whether the correct results for ;; TIME are returned "elapsed time","net compute time, etc". Test result is ;; logged on {eris}test>exec>test.report. (DO-TEST "TIME-TEST-SETUP" (PROGN (SETQ MESS0 "Printing time statistics for compilation of the function palindromep...") (SETQ MESS1 "Various time statics have been saved in {core}testfor analysis...") (SETQ MESS2 "Do-test will determine if various statics have been printed.....") (IF (FBOUNDP 'PALINDROMEP) (FMAKUNBOUND 'PALINDROMEP)) ;; palindrome reads the same forwards and backwards (setf (symbol-function 'palindromep) '(lambda (string &optional (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil))))) (SETQ {CORE}TEST "{CORE}TIME") ; this is where the results are stored (SETQ TIME-CATEGORIES '("Elapsed time " "SWAP time " "reclaim time " "net compute time")) (SETQ TEST-RESULT "{ERIS}TEST>EXECUTIVE>TEST.REPORT") (DEFUN T-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: TIME~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ TIME-COMMAND-STRING "(FORMAT NIL MESS0) (DRIBBLE '{CORE}TIME) TIME (COMPILE 'PALINDROMEP) (DRIBBLE) (FORMAT NIL MESS1) (FORMAT NIL MESS2) (FMAKUNBOUND 'PALINDROMEP) (DO-TEST 'TIME-TEST-RESULT (PROGN (SETQ TIME-PRINTOUT-FLG NIL TIME-UNIT-FLG NIL) (SETQ *TIME-STREAM* (OPEN {CORE}TEST :DIRECTION :INPUT)) (DEFUN MOVE-PTR (NO) (DO ((CNT 1 (1+ CNT))) ((= CNT (1+ NO)) T) (READ *TIME-STREAM*))) (MOVE-PTR 4) (READ-LINE *TIME-STREAM*) ;; Checking for various time statistics (DOLIST (Y TIME-CATEGORIES) (IF (STRING-EQUAL Y (READ-LINE *TIME-STREAM*):END2 16) (PUSH T TIME-PRINTOUT-FLG) (PUSH NIL TIME-PRINTOUT-FLG) ) ) (CLOSE *TIME-STREAM*) (SETQ *TIME-STREAM* (OPEN {CORE}TEST :DIRECTION :INPUT)) (MOVE-PTR 8) ;; Checking to see if time is indicated in floating-point number (DO ((CNT 1 (1+ CNT))) ((= CNT 4) T) (IF (FLOATP (PROG1 (READ *TIME-STREAM*)(MOVE-PTR 4))) (PUSH T TIME-UNIT-FLG) (PUSH NIL TIME-UNIT-FLG) ) ) (READ *TIME-STREAM*) (IF (FLOATP (READ *TIME-STREAM*)(MOVE-PTR 4)) (PUSH T TIME-UNIT-FLG) (PUSH NIL TIME-UNIT-FLG) ) (CLOSE *TIME-STREAM*) (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (LET ((*OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND))) (PROGN (IF(AND (NOTANY #'NULL TIME-PRINTOUT-FLG) (NOTANY #'NULL TIME-UNIT-FLG)) (T-FORMAT 'SUCCESS) (T-FORMAT 'FAILED)) (CLOSE *OUTPUT*))) ) ) ") (IL:BKSYSBUF TIME-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Hand/undo.u b/internal/test/env/Exec/Hand/undo.u new file mode 100644 index 00000000..9aa23a8f --- /dev/null +++ b/internal/test/env/Exec/Hand/undo.u @@ -0,0 +1 @@ +;; Function To Be Tested: UNDO (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; Section 20.2 (The Evaluator), Page 27 ;; Section: The Evaluator ;; Page: 28 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {ERIS}test>exec>undo.u ;; ;; ;; Syntax: UNDO &rest EVENT-SPEC ;; ;; Function Description: Undo the side effects of the specified event. The UNDO ;; command is implemented by "watching" the evaluation of forms and requiring ;; undoable operations in that evaluation to save enough information on the history ;; list to reverse their side effects. The Exec simply executes operations, and ;; any undoable changes that occur are automatically saved on the history list by ;; the responsible functions. The UNDO command works on itself the same way: ;; it recovers the saved information and performs the corresponding inverses. ;; thus, UNDO is effective on itself, so that the user can UNDO an UNDO, and UNDO ;; that, etc. ;; ;; Argument(s): EVENT-SPEC ;; ;; Returns: See function description ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will not be totally automatic. Comments are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT package. ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>exec>test.report. (DO-TEST "UNDO-TEST-SETUP" (PROGN (SETQ MESS1 "Now do-test will determine if correct results have been produced when UNDOs were entered...") (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~2%COMMAND: UNDO~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) (SETQ UNDO-COMMAND-STRING "; Unbound all undo variables (MAPCAR #'MAKUNBOUND '(UNDO-VAR UNDO-VAR-1 UNDO-VAR-2)) (SETQ UNDO-VAR 'YES) (SETQ UNDO-VAR-1 'YES-NO) ; this undoes undo-var UNDO -2 (IF (NOT (BOUNDP 'UNDO-VAR)) (SETQ UNDO-VAR 'UNBOUND) (SETQ UNDO-VAR 'BOUND)) (SETQ UNDO-VAR-2 'YES-NO) (SETQ UNDO-VAR-2 'NO) ; This undoes the last event and undo-var-2 is still bound UNDO (IF (EQ UNDO-VAR-2 'YES-NO) (SETQ UNDO-VAR-2F 'STILL-BOUND) (SETQ UNDO-VAR-2F 'GONE)) ; this will restore the value of undo-var-2 to its first value UNDO UNDO (IF (EQ UNDO-VAR-2 'NO) (SETQ UNDO-VAR-2R 'RESTORED) (SETQ UNDO-VAR-2R 'SAME)) (FORMAT NIL MESS1) (DO-TEST 'UNDO-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (EQ UNDO-VAR 'UNBOUND) (EQ UNDO-VAR-2F 'STILL-BOUND) (EQ UNDO-VAR-2R 'RESTORED)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF UNDO-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Debugger.log b/internal/test/env/Exec/Logs/Debugger.log new file mode 100644 index 00000000..afc26090 --- /dev/null +++ b/internal/test/env/Exec/Logs/Debugger.log @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 3-Mar-88 14:39:12 ;;; Running tests from ({Eris}Env>exec>Hand>*.u;) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Exec.log b/internal/test/env/Exec/Logs/Exec.log new file mode 100644 index 00000000..1bc4656a --- /dev/null +++ b/internal/test/env/Exec/Logs/Exec.log @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 29-Feb-88 11:25:26 ;;; Running tests from ({ERIS}Env>Exec>Hand>*.u;) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Exec.log.~1~ b/internal/test/env/Exec/Logs/Exec.log.~1~ new file mode 100644 index 00000000..3849d0f9 --- /dev/null +++ b/internal/test/env/Exec/Logs/Exec.log.~1~ @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 29-Feb-88 10:19:34 ;;; Running tests from ({ERIS}Env>Exec>Hand>do-events.u;1) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Exec.log.~2~ b/internal/test/env/Exec/Logs/Exec.log.~2~ new file mode 100644 index 00000000..1a92b1bc --- /dev/null +++ b/internal/test/env/Exec/Logs/Exec.log.~2~ @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 29-Feb-88 10:54:35 ;;; Running tests from ({ERIS}Env>Exec>Hand>*.u;) (Trouble reading {ERIS}ENV>EXEC>HAND>DO-EVENTS.U;2) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Exec.log.~3~ b/internal/test/env/Exec/Logs/Exec.log.~3~ new file mode 100644 index 00000000..1bc4656a --- /dev/null +++ b/internal/test/env/Exec/Logs/Exec.log.~3~ @@ -0,0 +1 @@ +;;; Test results for sysout of 26-Feb-88 11:29:20 ;;; Tests run on 29-Feb-88 11:25:26 ;;; Running tests from ({ERIS}Env>Exec>Hand>*.u;) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/FilePkg/Hand-Aux/FORMATTINGFNS b/internal/test/env/FilePkg/Hand-Aux/FORMATTINGFNS new file mode 100644 index 00000000..1b4d1ee0 --- /dev/null +++ b/internal/test/env/FilePkg/Hand-Aux/FORMATTINGFNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Mar-88 21:14:40" {DSK}TOP10-87>ADMIN>FORMATTINGFNS.;13 63618 changes to%: (VARS FORMATTINGFNSCOMS) (FNS CALL.OTHERPARA CALL.HEAD CALL.1DIAGRAM CALL.2DIAGRAM CALL.3DIAGRAM CALL.4DIAGRAM CALL.5DIAGRAM CALL.6DIAGRAM TOP10.PAGELAYOUT TOP10.CALLNAME-STYLE TOP10.CALLDEFN-STYLE TOP10.NO-STYLE TOP10.NOTEHEAD-STYLE TOP10.NOTE-STYLE TOP10.DIAGRAM-STYLE TOP10.INIT TOP10-DIAGRAM-CHAR-STYLE TOP10-CALLTITLE-CHAR-STYLE TOP10-MAINPARA-CHAR-STYLE TOP10-NOTETITLE-CHAR-STYLE TOP10-NOTE-CHAR-STYLE TOP10-BIG-STYLES TOP10-PRINT-STYLES XPS.COVER.PARA CRAM-DOC FILE-TO-WP CHC TEDIT.EXTERNAL.FORM TEDIT.EXT.PARALOOKS TEDIT.EXT.CHARLOOKS TEDIT.EXT.OBJECT SPELLING-CORRECT) previous date%: "22-Mar-88 01:44:22" {DSK}TOP10-87>ADMIN>FORMATTINGFNS.;11) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FORMATTINGFNSCOMS) (RPAQQ FORMATTINGFNSCOMS ( (* ;; "Support for TOP-10 '87 edition formatting") (FNS CALL.HEAD CALL.OTHERPARA CALL.1DIAGRAM CALL.2DIAGRAM CALL.3DIAGRAM CALL.4DIAGRAM CALL.5DIAGRAM CALL.6DIAGRAM TOP10.PAGELAYOUT TOP10.CALLNAME-STYLE TOP10.CALLDEFN-STYLE TOP10.NO-STYLE TOP10.NOTEHEAD-STYLE TOP10.NOTE-STYLE TOP10.DIAGRAM-STYLE TOP10.INIT) (COMS (* ;; "Support for character styles used in the Top10 mss.") (FNS TOP10-DIAGRAM-CHAR-STYLE TOP10-CALLTITLE-CHAR-STYLE TOP10-MAINPARA-CHAR-STYLE TOP10-NOTETITLE-CHAR-STYLE TOP10-NOTE-CHAR-STYLE) (FUNCTIONS TOP10-APPLY-CHAR-STYLE) (* ;; "Initial style definitions:") (GLOBALVARS *TOP10-DIAGRAM-CHAR-STYLE-SPEC* *TOP10-CALLTITLE-CHAR-STYLE-SPEC* *TOP10-MAINPARA-CHAR-STYLE-SPEC* *TOP10-NOTE-CHAR-STYLE-SPEC* *TOP10-DIAGRAM-CHAR-STYLE-SPEC* *TOP10-NOTETITLE-CHAR-STYLE-SPEC*) (* ;;  "ALists for converting charlooks to styled looks. Reset these lists to enforce new styles:") (GLOBALVARS *TOP10-DIAGRAM-CHAR-STYLE-ALIST* *TOP10-CALLTITLE-CHAR-STYLE-ALIST* *TOP10-MAINPARA-CHAR-STYLE-ALIST* *TOP10-NOTE-CHAR-STYLE-ALIST* *TOP10-DIAGRAM-CHAR-STYLE-ALIST* *TOP10-NOTETITLE-CHAR-STYLE-ALIST*) (* ;; " Fns for changing to readable sizes:") (FNS TOP10-BIG-STYLES TOP10-PRINT-STYLES) (* ;; "Initialize the styles:") (P (TOP10-BIG-STYLES))) (FNS XPS.COVER.PARA) (* ; "From XPSEDIT formatter.") (FNS CRAM-DOC FILE-TO-WP CHC) (* ;  "For converting from WP format on PC") (FNS TEDIT.EXTERNAL.FORM TEDIT.EXT.PARALOOKS TEDIT.EXT.CHARLOOKS TEDIT.EXT.OBJECT) (* ;  "For writing a WP-able version of TEdit files.") (FNS SPELLING-CORRECT) (* ;  "For fixing common errors in TOP10 documents.") [VARS (*TOP10-FILES* '(Front-Back>Inner-Cover.TEDIT Front-Back>Introduction.TEDIT Front-Back>TOP10-CONTENTS.TEDIT FREQUENCY.TEDIT DICTIONARIES>DICT-PREFACE.TEDIT DICTIONARIES>MSDICT-A-G.TEDIT DICTIONARIES>MSDICT-H-P.TEDIT DICTIONARIES>MSDICT-R-S.TEDIT DICTIONARIES>MSDICT-T-Z.TEDIT DICTIONARIES>PLUSDICT.TEDIT DICTIONARIES>ADV-PREFACE.TEDIT DICTIONARIES>ADVDICT-A-M.TEDIT DICTIONARIES>ADVDICT-N-Z.TEDIT DICTIONARIES>C1-PREFACE.TEDIT DICTIONARIES>C1DEFNS-A-H.TEDIT DICTIONARIES>C1DEFNS-I-R.TEDIT DICTIONARIES>C1DEFNS-S.TEDIT DICTIONARIES>C1DEFNS-T-Z.TEDIT DICTIONARIES>C2DEFNS-A-E.TEDIT DICTIONARIES>C2DEFNS-F-O.TEDIT >DICTIONARIES>C2DEFNS-P-S.TEDIT DICTIONARIES>C2DEFNS-T-Z.TEDIT FRA>FORMATION-DICT.TEDIT FRA>ARRANGEMENTS.TEDIT FRA>FRA.TEDIT FRA>ARRANGE-2FLINES.TEDIT FRA>ARRANGE-8CHAIN.TEDIT FRA>ARRANGE-DIAMOND.TEDIT FRA>ARRANGE-LINES.TEDIT FRA>ARRANGE-QTAG.TEDIT FRA>ARRANGE-WAVES.TEDIT)) (*TOP10-ERIS-FILES* '({ERIS}TOP10-87>TOP10-CONTENTS.TEDIT {ERIS}TOP10-87>FREQUENCY.TEDIT {ERIS}TOP10-87>DICTIONARIES>DICT-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-A-G.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-H-P.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-R-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>PLUSDICT.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADV-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-A-M.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-N-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-A-H.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-I-R.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-A-E.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-F-O.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-P-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-T-Z.TEDIT {ERIS}TOP10-87>FRA>FORMATION-DICT.TEDIT {ERIS}TOP10-87>FRA>ARRANGEMENTS.TEDIT {ERIS}TOP10-87>FRA>FRA.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-2FLINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-8CHAIN.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-DIAMOND.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-LINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-QTAG.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-WAVES.TEDIT)) (*TOP10-ERIS-PART1* '({ERIS}TOP10-87>TOP10-CONTENTS.TEDIT {ERIS}TOP10-87>FREQUENCY.TEDIT {ERIS}TOP10-87>DICTIONARIES>DICT-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-A-G.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-H-P.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-R-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>PLUSDICT.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADV-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-A-M.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-N-Z.TEDIT)) (*TOP10-ERIS-PART2* '({ERIS}TOP10-87>DICTIONARIES>C1-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-A-H.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-I-R.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-A-E.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-F-O.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-P-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-T-Z.TEDIT ERISS}CALENDAR.DATABASEATION-DICT.TEDIT {ERIS}TOP10-87>FRA>ARRANGEMENTS.TEDIT {ERIS}TOP10-87>FRA>FRA.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-2FLINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-8CHAIN.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-DIAMOND.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-LINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-QTAG.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-WAVES.TEDIT] (P (TEDIT.SETFUNCTION (CHARCODE "##^S") (FUNCTION SPELLING-CORRECT))) (* ;;; "Page layout of 3, 3x5 cards per page with heading and 2 columns per card.") [VARS (TOP10-FRAMES (TEDIT.PARSE.PAGEFRAMES '(LIST ((PAGE NIL (PAPERSIZE Letter LANDSCAPE? T FOLIOINFO (ARABIC "˙ď%˙" "˙ď%˙")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 6 FAMILY OPTIMA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE ITALIC WEIGHT BOLD INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "˙ď%˙" "˙ď%˙")) (108 36 288 36) NIL) (TEXT NIL NIL (36 36 210 540) NIL) (TEXT NIL NIL (258 36 210 540) NIL))) (PAGE NIL (PAPERSIZE Letter LANDSCAPE? T FOLIOINFO (ARABIC "˙ď%˙" "˙ď%˙")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 6 FAMILY OPTIMA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE ITALIC WEIGHT BOLD INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "˙ď%˙" "˙ď%˙")) (108 36 288 36) NIL) (TEXT NIL NIL (36 36 210 540) NIL) (TEXT NIL NIL (258 36 210 540) NIL))) (PAGE NIL (PAPERSIZE Letter LANDSCAPE? T FOLIOINFO (ERISIC "˙ď%˙" "˙ď%˙")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 6 FAMILY OPTIMA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE ITALIC WEIGHT BOLD INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "˙ď%˙" "˙ď%˙")) (108 36 288 36) NIL) (TEXT NIL NIL (36 36 210 540) NIL) (TEXT NIL NIL (258 36 210 540) NIL] (P (TOP10.INIT)) (PROP FILETYPE FORMATTINGFNS))) (* ;; "Support for TOP-10 '87 edition formatting") (DEFINEQ (CALL.HEAD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 15-Mar-88 01:38 by Sybalsky") (* ;; "Impose the style for the paragraph that heads a call definition.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (LET* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS (60 (581 . LEFT)) BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 6 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD JUSTIFIED) SEL]) (CALL.OTHERPARA [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 22-Mar-88 18:18 by ") (* ;; "Impose the style for paragrazphs in the body of a call definition.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS NIL BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 2 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD JUSTIFIED]) (CALL.1DIAGRAM [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 14-Oct-87 11:52 by jds") (* ;; "Impose the style for a single-picture diagram paragraph: Centered.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS NIL BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 0 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD CENTERED]) (CALL.2DIAGRAM [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 14-Oct-87 11:54 by jds") (* ;; "Impose the style for a single-picture diagram paragraph: Centered.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS (60 (66 . CENTERED) (144 . CENTERED)) BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 3 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD JUSTIFIED]) (CALL.3DIAGRAM [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 14-Oct-87 11:55 by jds") (* ;; "Impose the style for a 3-picture diagram paragraph: Centered.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS (60 (36 . CENTERED) (108 . CENTERED) (174 . CENTERED)) BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 3 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD JUSTIFIED]) (CALL.4DIAGRAM [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 17-Dec-87 15:33 by jds") (* ;; "Impose the style for a single-picture diagram paragraph: Centered.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(REVISED NIL HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS (60 (18 . CENTERED) (72 . CENTERED) (126 . CENTERED) (174 . CENTERED) (581 . LEFT)) BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 0 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD LEFT]) (CALL.5DIAGRAM [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 5-Jan-88 13:25 by jds") (* ;; "Impose the style for a single-picture diagram paragraph: Centered.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(REVISED NIL HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS (60 (24 . CENTERED) (66 . CENTERED) (108 . CENTERED) (150 . CENTERED) (192 . CENTERED)) BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 1 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD LEFT]) (CALL.6DIAGRAM [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 17-Dec-87 16:20 by jds") (* ;; "Impose the style for a single-picture diagram paragraph: Centered.") (XPS.COVER.PARA TEXTOBJ SEL) (* ;  "Make sure the whole paragraph is selected.") (PROG* ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) (CH# (fetch CH# of SEL)) (CHLIM (fetch CHLIM of SEL))) (TEDIT.PARALOOKS TEXTOBJ '(REVISED NIL HARDCOPY NIL KEEP NIL HEADINGKEEP OFF NEWPAGEAFTER NIL NEWPAGEBEFORE NIL SUBTYPE NIL TYPE NIL SPECIALY 0 SPECIALX 0 USERINFO NIL CHARSTYLES NIL STYLE NIL TABS (60 (18 . CENTERED) (42 . CENTERED) (78 . CENTERED) (120 . CENTERED) (156 . CENTERED) (186 . CENTERED) (581 . LEFT)) BASETOBASE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 1 RIGHTMARGIN 210 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD JUSTIFIED]) (TOP10.PAGELAYOUT [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 14-Oct-87 12:03 by jds") (* ;;; "Impose page layout on a TOP-10 '87 file. 2-column, set up for 7 x 8.5 pages with 1/2%" top and bottom..") (TEDIT.PAGEFORMAT TEXTSTREAM TOP10-FRAMES]) (TOP10.CALLNAME-STYLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 23-Dec-87 11:40 by jds") (* ;; "Impose the CHARACTER style for call titles.") (TEDIT.LOOKS TEXTOBJ '(STYLE TOP10-CALLTITLE-CHAR-STYLE]) (TOP10.CALLDEFN-STYLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 23-Dec-87 11:41 by jds") (* ;; "Impose the CHARACTER style for call titles.") (TEDIT.LOOKS TEXTOBJ '(STYLE TOP10-MAINPARA-CHAR-STYLE]) (TOP10.NO-STYLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 5-Jan-88 12:26 by jds") (* ;; "Remove any character styling.") (TEDIT.LOOKS TEXTOBJ '(STYLE NIL]) (TOP10.NOTEHEAD-STYLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 23-Dec-87 11:41 by jds") (* ;; "Impose the CHARACTER style for call titles.") (TEDIT.LOOKS TEXTOBJ '(STYLE TOP10-NOTETITLE-CHAR-STYLE]) (TOP10.NOTE-STYLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 23-Dec-87 11:41 by jds") (* ;; "Impose the CHARACTER style for call titles.") (TEDIT.LOOKS TEXTOBJ '(STYLE TOP10-NOTE-CHAR-STYLE]) (TOP10.DIAGRAM-STYLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 23-Dec-87 11:41 by jds") (* ;; "Impose the CHARACTER style for call titles.") (TEDIT.LOOKS TEXTOBJ '(STYLE TOP10-DIAGRAM-CHAR-STYLE]) (TOP10.INIT [LAMBDA NIL (* ; "Edited 5-Jan-88 12:26 by jds") (* ;;; "Attach TOP-10 formatting operations to META- command keys") (* ;; "Meta-digits format diagrams of corresponding size:") (TEDIT.SETFUNCTION (CHARCODE %##1) (FUNCTION CALL.1DIAGRAM)) (TEDIT.SETFUNCTION (CHARCODE %##2) (FUNCTION CALL.2DIAGRAM)) (TEDIT.SETFUNCTION (CHARCODE %##3) (FUNCTION CALL.3DIAGRAM)) (TEDIT.SETFUNCTION (CHARCODE %##4) (FUNCTION CALL.4DIAGRAM)) (TEDIT.SETFUNCTION (CHARCODE %##5) (FUNCTION CALL.5DIAGRAM)) (TEDIT.SETFUNCTION (CHARCODE %##6) (FUNCTION CALL.6DIAGRAM)) (* ;; "META-A formats a CALL DEFINITION heading") (TEDIT.SETFUNCTION (CHARCODE %##A) (FUNCTION CALL.HEAD)) (TEDIT.SETFUNCTION (CHARCODE %##a) (FUNCTION CALL.HEAD)) (* ;; "META-S formatsother paragraphs:") (TEDIT.SETFUNCTION (CHARCODE %##S) (FUNCTION CALL.OTHERPARA)) (TEDIT.SETFUNCTION (CHARCODE %##s) (FUNCTION CALL.OTHERPARA)) (* ;; "META-G will set the page layout for a NEW TOP10 FILE:") (TEDIT.SETFUNCTION (CHARCODE %##G) (FUNCTION TOP10.PAGELAYOUT)) (TEDIT.SETFUNCTION (CHARCODE %##g) (FUNCTION TOP10.PAGELAYOUT)) (* ;; "Meta Q W E R T set char styles for") (* ;; "Q - call name") (TEDIT.SETFUNCTION (CHARCODE %##q) (FUNCTION TOP10.CALLNAME-STYLE)) (TEDIT.SETFUNCTION (CHARCODE %##Q) (FUNCTION TOP10.CALLNAME-STYLE)) (* ;; "W - Call defn body") (TEDIT.SETFUNCTION (CHARCODE %##w) (FUNCTION TOP10.CALLDEFN-STYLE)) (TEDIT.SETFUNCTION (CHARCODE %##W) (FUNCTION TOP10.CALLDEFN-STYLE)) (* ;; "E - Note Head") (TEDIT.SETFUNCTION (CHARCODE %##e) (FUNCTION TOP10.NOTEHEAD-STYLE)) (TEDIT.SETFUNCTION (CHARCODE %##E) (FUNCTION TOP10.NOTEHEAD-STYLE)) (* ;; "R - Note body") (TEDIT.SETFUNCTION (CHARCODE %##r) (FUNCTION TOP10.NOTE-STYLE)) (TEDIT.SETFUNCTION (CHARCODE %##R) (FUNCTION TOP10.NOTE-STYLE)) (* ;; "T - diagram captions") (TEDIT.SETFUNCTION (CHARCODE %##t) (FUNCTION TOP10.DIAGRAM-STYLE)) (TEDIT.SETFUNCTION (CHARCODE %##T) (FUNCTION TOP10.DIAGRAM-STYLE)) (* ;; "SPACE - turns off all styling.") (TEDIT.SETFUNCTION (CHARCODE %##SPACE) (FUNCTION TOP10.NO-STYLE]) ) (* ;; "Support for character styles used in the Top10 mss.") (DEFINEQ (TOP10-DIAGRAM-CHAR-STYLE [LAMBDA (LOOKS PC TEXTOBJ) (* ; "Edited 15-Mar-88 00:57 by Sybalsky") (* ;;  "Character Style function for Top10 diagrams -- sets the font always to the proper size & weigth.") (TOP10-APPLY-CHAR-STYLE LOOKS PC TEXTOBJ *TOP10-DIAGRAM-CHAR-STYLE-SPEC* *TOP10-DIAGRAM-CHAR-STYLE-ALIST*]) (TOP10-CALLTITLE-CHAR-STYLE [LAMBDA (LOOKS PC TEXTOBJ) (* ; "Edited 15-Mar-88 00:57 by Sybalsky") (* ;; "Character Style function for Top10 call titles -- sets the font always to the proper size & weigth.") (TOP10-APPLY-CHAR-STYLE LOOKS PC TEXTOBJ *TOP10-CALLTITLE-CHAR-STYLE-SPEC* *TOP10-CALLTITLE-CHAR-STYLE-ALIST*]) (TOP10-MAINPARA-CHAR-STYLE [LAMBDA (LOOKS PC TEXTOBJ) (* ; "Edited 15-Mar-88 00:58 by Sybalsky") (* ;; "Character Style function for Top10 main-definition paragraphs -- sets the font always to the proper size & weigth.") (TOP10-APPLY-CHAR-STYLE LOOKS PC TEXTOBJ *TOP10-MAINPARA-CHAR-STYLE-SPEC* *TOP10-MAINPARA-CHAR-STYLE-ALIST*]) (TOP10-NOTETITLE-CHAR-STYLE [LAMBDA (LOOKS PC TEXTOBJ) (* ; "Edited 15-Mar-88 00:59 by Sybalsky") (* ;; "Character Style function for Top10 note para title run-in heads. -- sets the font always to the proper size & weigth.") (TOP10-APPLY-CHAR-STYLE LOOKS PC TEXTOBJ *TOP10-NOTETITLE-CHAR-STYLE-SPEC* *TOP10-NOTETITLE-CHAR-STYLE-ALIST*]) (TOP10-NOTE-CHAR-STYLE [LAMBDA (LOOKS PC TEXTOBJ) (* ; "Edited 15-Mar-88 00:51 by Sybalsky") (* ;;  "Character Style function for Top10 notes -- sets the font always to the proper size & weigth.") (TOP10-APPLY-CHAR-STYLE LOOKS PC TEXTOBJ *TOP10-NOTE-CHAR-STYLE-SPEC* *TOP10-NOTE-CHAR-STYLE-ALIST*]) ) (DEFMACRO TOP10-APPLY-CHAR-STYLE (LOOKS PIECE TEXTOBJ STYLE-SPEC STYLE-ALIST) (* ;; "For applying character styles in a style function.") `[COND ((CDR (ASSOC ,LOOKS ,STYLE-ALIST)) (* ;  "There's a cached value. Use it.") ) (T (* ;  "No cached value, create one, and cache it.") (CL:PUSH (CONS ,LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST ,STYLE-SPEC ,LOOKS ,TEXTOBJ)) ,STYLE-ALIST) (CDR (ASSOC ,LOOKS ,STYLE-ALIST]) (* ;; "Initial style definitions:") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *TOP10-DIAGRAM-CHAR-STYLE-SPEC* *TOP10-CALLTITLE-CHAR-STYLE-SPEC* *TOP10-MAINPARA-CHAR-STYLE-SPEC* *TOP10-NOTE-CHAR-STYLE-SPEC* *TOP10-DIAGRAM-CHAR-STYLE-SPEC* *TOP10-NOTETITLE-CHAR-STYLE-SPEC*) ) (* ;; "ALists for converting charlooks to styled looks. Reset these lists to enforce new styles:") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *TOP10-DIAGRAM-CHAR-STYLE-ALIST* *TOP10-CALLTITLE-CHAR-STYLE-ALIST* *TOP10-MAINPARA-CHAR-STYLE-ALIST* *TOP10-NOTE-CHAR-STYLE-ALIST* *TOP10-DIAGRAM-CHAR-STYLE-ALIST* *TOP10-NOTETITLE-CHAR-STYLE-ALIST*) ) (* ;; " Fns for changing to readable sizes:") (DEFINEQ (TOP10-BIG-STYLES [LAMBDA NIL (* ; "Edited 15-Mar-88 00:45 by Sybalsky") (* ;; "Set all Top10 styles to be readable size.") (SETQ *TOP10-CALLTITLE-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 10)) (SETQ *TOP10-MAINPARA-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 10)) (SETQ *TOP10-NOTE-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 10)) (SETQ *TOP10-NOTETITLE-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 10)) (SETQ *TOP10-DIAGRAM-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 6 WEIGHT BOLD UNDERLINE OFF)) (SETQ *TOP10-DIAGRAM-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-CALLTITLE-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-MAINPARA-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-NOTE-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-DIAGRAM-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-NOTETITLE-CHAR-STYLE-ALIST* NIL]) (TOP10-PRINT-STYLES [LAMBDA NIL (* ; "Edited 15-Mar-88 00:45 by Sybalsky") (* ;; "Set all top10 styles to their rendering sizes for printing.") (SETQ *TOP10-CALLTITLE-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 9 WEIGHT BOLD UNDERLINE OFF)) (SETQ *TOP10-MAINPARA-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 9)) (SETQ *TOP10-NOTE-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 7)) (SETQ *TOP10-NOTETITLE-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 7 WEIGHT BOLD)) (SETQ *TOP10-DIAGRAM-CHAR-STYLE-SPEC* '(FAMILY OPTIMA SIZE 6 WEIGHT BOLD UNDERLINE OFF)) (SETQ *TOP10-DIAGRAM-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-CALLTITLE-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-MAINPARA-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-NOTE-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-DIAGRAM-CHAR-STYLE-ALIST* NIL) (SETQ *TOP10-NOTETITLE-CHAR-STYLE-ALIST* NIL) (SETQ *DANCER-FONT-SIZE* 10]) ) (* ;; "Initialize the styles:") (TOP10-BIG-STYLES) (DEFINEQ (XPS.COVER.PARA [LAMBDA (TEXTOBJ SEL) (* jds "20-Nov-85 15:20") (* Assure that SEL covers a span of WHOLE paragraphs. Expand it to do so, if need be.) (PROG [[CH1 (CAR (\TEDIT.PARABOUNDS TEXTOBJ (fetch CH# of SEL] (CHLIM (CDR (\TEDIT.PARABOUNDS TEXTOBJ (SUB1 (fetch CHLIM of SEL] (TEDIT.SETSEL TEXTOBJ CH1 (ADD1 (IDIFFERENCE CHLIM CH1]) ) (* ; "From XPSEDIT formatter.") (DEFINEQ (CRAM-DOC [LAMBDA (FILE OUTFILE) (* ; "Edited 28-Dec-87 12:42 by jds") (* ;; "Take one ovf Bill's editor files and make it readable to me") (LET (CH CH2) (CL:WITH-OPEN-FILE (IN FILE) (CL:WITH-OPEN-STREAM (OUT (OPENSTREAM OUTFILE 'OUTPUT 'NEW)) (while (NOT (EOFP IN)) do (SETQ CH (BIN IN)) (SELECTQ CH (12 (* ; "%"New Column%"") (BOUT OUT (CHARCODE CR))) (140 (* ; "Some variant on first-column?") (BOUT OUT (CHARCODE CR))) ((156 175 135 131) (* ; "Not sure what this does.") (* ; "Bold-on?")) ((169 170) (* ; "N dash") (BOUT OUT (CHARCODE -))) (13 (BOUT OUT (CHARCODE SPACE))) (220 (* ;  "Skip to next 12 on input file, insert CR in output file.") (repeatwhile (CL:/= CH 220) do (SETQ CH (BIN IN)))) (225 (* ;  "Skip to next 10 in input, insert CR in output") (BIN IN) (BIN IN) (BOUT OUT (CHARCODE -))) (236 (* ;  "Skip to next 135 in input, insert CR in output.") (SETQ CH2 (BIN IN)) (BIN IN) (BIN IN)) (10 (* ; "LF is para sseparator") (BOUT OUT (CHARCODE CR))) (169 (BOUT OUT (CHARCODE -))) (96 (* ; "open dbl quote") (COND ((= (\PEEKBIN IN) 96) (BIN IN) (BOUT OUT 170)))) (39 (* ; "close dbl quote") (COND ((= (\PEEKBIN IN) 39) (BIN IN) (BOUT OUT 186)))) (124 (* ; "1/2") (BOUT OUT 189)) (123 (* ; "1/4") (BOUT OUT 188)) (125 (* ; "3/4") (BOUT OUT 190)) (BOUT OUT CH]) (FILE-TO-WP [LAMBDA (FILE OFILE) (* ; "Edited 11-Dec-87 16:29 by jds") (LET ((TS (OPENTEXTSTREAM FILE))) (CL:WITH-OPEN-STREAM (OUT (OPEN OFILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)) (TEDIT.EXTERNAL.FORM (TEXTOBJ TS) OUT)) (CLOSEF TS]) (CHC [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 4-Dec-87 11:32 by jds") (LET ((STR (TEDIT.SEL.AS.STRING STREAM SEL))) (PRINTOUT TT (CHCON STR) T T]) ) (* ; "For converting from WP format on PC") (DEFINEQ (TEDIT.EXTERNAL.FORM [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT) (* ; "Edited 11-Dec-87 16:18 by jds") (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks. UNFORMATTED? means write no font or formatting info.") (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch FMTSPEC of TEXTOBJ)) (*READTABLE* *TEDIT-FILE-READTABLE*) (*PRINT-BASE* 10) OLDCH# CURCH# PREVPC FONTFILE (PCCOUNT 0) TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL) (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) (PARALOOKSSEEN NIL) (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ)) (CACHE (TEXTPROP TEXTOBJ 'CACHE)) CH#S PREVFATP PARAHASH LOOKSHASH PREVPREVPC) (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP) (* ;  "Prevent spurious carriage-returns in the piece descriptions.") (SETQ PC (\EDITELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset))) (* ; "First piece in the document") (SETQ OLDLOOKS (create CHARLOOKS)) (* ; "Starting looks") (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC) (* ;  "Run thru the lists of char & para looks and remove any that aren't in use") (COND ([AND (fetch TXTPARALOOKSLIST of TEXTOBJ) (OR (IGREATERP (FLENGTH (fetch TXTPARALOOKSLIST of TEXTOBJ)) 1) (NOT (EQFMTSPEC (CAR (fetch TXTPARALOOKSLIST of TEXTOBJ)) TEDIT.DEFAULT.FMTSPEC] (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.") (SETQ PARAHASH (TEDIT.EXT.PARALOOKS OFILE (fetch TXTPARALOOKSLIST of TEXTOBJ ))) (SETQ PARALOOKSSEEN T))) [COND ((OR PARALOOKSSEEN FORMATTINGLEVEL) (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.") (* ;  "Open a font-info file if one is needed.") (SETQ LOOKSHASH (TEDIT.EXT.CHARLOOKS OFILE (fetch TXTCHARLOOKSLIST of TEXTOBJ] (while PC do [COND ([AND (NOT (ZEROP (fetch PLEN of PC))) (NOT (EQCLOOKS OLDLOOKS (fetch PLOOKS of PC] [OR LOOKSHASH (SETQ LOOKSHASH (TEDIT.EXT.CHARLOOKS OFILE (fetch TXTCHARLOOKSLIST of TEXTOBJ] (CL:FORMAT OFILE "@F(~D)" (GETHASH (fetch PLOOKS of PC) LOOKSHASH)) (SETQ OLDLOOKS (fetch PLOOKS of PC] (COND ([AND (NOT (ZEROP (fetch PLEN of PC))) (OR (NOT PREVPC) (fetch PPARALAST of PREVPC)) (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch PPARALOOKS of PC) (fetch FMTSPEC of TEXTOBJ ] (* ;  "The last piece ended a paragraph, so send out new para looks") (CL:FORMAT OFILE "@P(~D)" (GETHASH (fetch PPARALOOKS of PC) PARAHASH)) (SETQ PARALOOKSSEEN T) (* ;  "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries") )) (COND ((fetch POBJ of PC) (* ;  "It's an object -- go use its PUTFN") (TEDIT.EXT.OBJECT OFILE (fetch (PIECE POBJ) of PC)) (* ; "Send out the object") )) (* ;; "Now dump out the non-object contents of the piece:") (COND ((AND PREVPC PC (EQ (fetch PFATP of PREVPC) (fetch PFATP of PC))) (* ; "Nothing further to do.") ) [(AND PREVPC (fetch PFATP of PREVPC)) (COND ((fetch PFATP of PC)) (T (* ; "Switching from FAT to thin") (BOUT OFILE 255) (BOUT OFILE 0] ((fetch PFATP of PC)(* ; "Switching from thin to fat") (BOUT OFILE 255) (BOUT OFILE 255) (BOUT OFILE 0))) [COND [(SETQ PFILE (fetch PFILE of PC)) (* ; "It's on a file. Copy it.") [OR (OPENP PFILE) (replace PFILE of PC with (SETQ PFILE (\TEDIT.REOPEN.STREAM TEXTOBJ PFILE] (* ; "Make sure the file is open.") (COPYBYTES PFILE OFILE (fetch PFPOS of PC) (IPLUS (fetch PFPOS of PC) (COND ((fetch PFATP of PC) (* ;  "For fat file pieces, copy twice as many bytes as characters.") (UNFOLD (fetch PLEN of PC) 2)) (T (fetch PLEN of PC] ((SETQ PSTR (fetch PSTR of PC)) (* ;  "It's in a string. Just print it.") (COND [(fetch PFATP of PC) (* ;  "The string is fat: Copy twice as many bytes as chars.") (for I from 1 to (fetch PLEN of PC) as CH instring PSTR do (\BOUT OFILE (\CHARSET CH)) (\BOUT OFILE (\CHAR8CODE CH] (T (* ;  "The string is thin. Just copy it to the file.") (for I from 1 to (fetch PLEN of PC) as CH instring PSTR do (\BOUT OFILE CH] (SETQ PREVPC PC) (SETQ PC (fetch NEXTPIECE of PC]) (TEDIT.EXT.PARALOOKS [LAMBDA (FILE LOOKSLIST) (* ; "Edited 10-Dec-87 10:04 by jds") (* ;  "Write the list of FMTSPECs into the font file.") (PROG ((LOOKSHASH (HASHARRAY 50))) (PRIN1 "(PARAGRAPH-LOOKS " FILE) (for I from 1 as LOOKS in LOOKSLIST do (PRIN1 ( \TEDIT.UNPARSE.PARALOOKS.LIST LOOKS) FILE) (* ; "Write out the description") (PUTHASH LOOKS I LOOKSHASH) (* ;  "And save it in the hash table so people can find its index.") ) (PRIN1 ") " FILE) (RETURN LOOKSHASH]) (TEDIT.EXT.CHARLOOKS [LAMBDA (FILE LOOKSLIST) (* ; "Edited 10-Dec-87 09:41 by jds") (* ;; "Write the list of CHARLOOKSs into the font file.") (* ;; "Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' position in the list we wrote on the file. Those position numbers are then written in the individual looks descriptions, and are used to reconstruct the piece looks when the file is read back in.") (PROG ((LOOKSHASH (HASHARRAY 50))) (* ;  "How many CHARLOOKSs there are in the list") (PRIN1 "(FONTS " FILE) (for I from 1 as LOOKS in LOOKSLIST do (* ;  "Write each charlooks, in the order they appear in the list.") (PRIN1 ( \TEDIT.UNPARSE.CHARLOOKS.LIST LOOKS) FILE) (* ; "Write out the description") (PUTHASH LOOKS I LOOKSHASH) (* ;  "And save it in the hash table so people can find its index.") ) (PRIN1 ") " FILE) (RETURN LOOKSHASH]) (TEDIT.EXT.OBJECT [LAMBDA (FILE OBJECT) (* ; "Edited 11-Dec-87 15:22 by jds") (LET (PLIST) (SELECTQ (fetch (IMAGEFNS DISPLAYFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of OBJECT)) (DANCEROBJ.DISPLAYFN (SETQ PLIST (COPY (fetch (IMAGEOBJ IMAGEOBJPLIST) of OBJECT))) [COND ((LISTGET PLIST 'BOUNDBOX) (* ; "Remove the boundbox property") (SETQ PLIST (LDIFFERENCE PLIST (LIST 'BOUNDBOX (LISTGET PLIST 'BOUNDBOX] (PRINTOUT FILE "@PIC" PLIST)) (HELP "UNKNOWN OBJECT TYPE"]) ) (* ; "For writing a WP-able version of TEdit files.") (DEFINEQ (SPELLING-CORRECT [LAMBDA (TEXTOBJ) (* ; "Edited 15-Mar-88 00:09 by Sybalsky") (LET ((TEXTOBJ (TEXTOBJ TEXTOBJ)) CORRECTION-LIST) (CL:WITH-OPEN-FILE (IN "{DSK}TOP10-87>ADMIN>SPELLING-CORRECTION-LIST" :DIRECTION :INPUT) (SETQ CORRECTION-LIST (READ IN))) (for CORRECTION in CORRECTION-LIST do (TEDIT.SETSEL TEXTOBJ 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) NIL NIL) (TEDIT.SUBSTITUTE TEXTOBJ (CAR CORRECTION) (CADR CORRECTION) NIL]) ) (* ; "For fixing common errors in TOP10 documents.") (RPAQQ *TOP10-FILES* (Front-Back>Inner-Cover.TEDIT Front-Back>Introduction.TEDIT Front-Back>TOP10-CONTENTS.TEDIT FREQUENCY.TEDIT DICTIONARIES>DICT-PREFACE.TEDIT DICTIONARIES>MSDICT-A-G.TEDIT DICTIONARIES>MSDICT-H-P.TEDIT DICTIONARIES>MSDICT-R-S.TEDIT DICTIONARIES>MSDICT-T-Z.TEDIT DICTIONARIES>PLUSDICT.TEDIT DICTIONARIES>ADV-PREFACE.TEDIT DICTIONARIES>ADVDICT-A-M.TEDIT DICTIONARIES>ADVDICT-N-Z.TEDIT DICTIONARIES>C1-PREFACE.TEDIT DICTIONARIES>C1DEFNS-A-H.TEDIT DICTIONARIES>C1DEFNS-I-R.TEDIT DICTIONARIES>C1DEFNS-S.TEDIT DICTIONARIES>C1DEFNS-T-Z.TEDIT DICTIONARIES>C2DEFNS-A-E.TEDIT DICTIONARIES>C2DEFNS-F-O.TEDIT >DICTIONARIES>C2DEFNS-P-S.TEDIT DICTIONARIES>C2DEFNS-T-Z.TEDIT FRA>FORMATION-DICT.TEDIT FRA>ARRANGEMENTS.TEDIT FRA>FRA.TEDIT FRA>ARRANGE-2FLINES.TEDIT FRA>ARRANGE-8CHAIN.TEDIT FRA>ARRANGE-DIAMOND.TEDIT FRA>ARRANGE-LINES.TEDIT FRA>ARRANGE-QTAG.TEDIT FRA>ARRANGE-WAVES.TEDIT)) (RPAQQ *TOP10-ERIS-FILES* ({ERIS}TOP10-87>TOP10-CONTENTS.TEDIT {ERIS}TOP10-87>FREQUENCY.TEDIT {ERIS}TOP10-87>DICTIONARIES>DICT-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-A-G.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-H-P.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-R-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>PLUSDICT.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADV-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-A-M.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-N-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-A-H.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-I-R.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-A-E.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-F-O.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-P-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-T-Z.TEDIT {ERIS}TOP10-87>FRA>FORMATION-DICT.TEDIT {ERIS}TOP10-87>FRA>ARRANGEMENTS.TEDIT {ERIS}TOP10-87>FRA>FRA.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-2FLINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-8CHAIN.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-DIAMOND.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-LINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-QTAG.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-WAVES.TEDIT)) (RPAQQ *TOP10-ERIS-PART1* ({ERIS}TOP10-87>TOP10-CONTENTS.TEDIT {ERIS}TOP10-87>FREQUENCY.TEDIT {ERIS}TOP10-87>DICTIONARIES>DICT-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-A-G.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-H-P.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-R-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>MSDICT-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>PLUSDICT.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADV-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-A-M.TEDIT {ERIS}TOP10-87>DICTIONARIES>ADVDICT-N-Z.TEDIT)) (RPAQQ *TOP10-ERIS-PART2* ({ERIS}TOP10-87>DICTIONARIES>C1-PREFACE.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-A-H.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-I-R.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C1DEFNS-T-Z.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-A-E.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-F-O.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-P-S.TEDIT {ERIS}TOP10-87>DICTIONARIES>C2DEFNS-T-Z.TEDIT ERISS}CALENDAR.DATABASEATION-DICT.TEDIT {ERIS}TOP10-87>FRA>ARRANGEMENTS.TEDIT {ERIS}TOP10-87>FRA>FRA.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-2FLINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-8CHAIN.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-DIAMOND.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-LINES.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-QTAG.TEDIT {ERIS}TOP10-87>FRA>ARRANGE-WAVES.TEDIT)) (TEDIT.SETFUNCTION (CHARCODE "##^S") (FUNCTION SPELLING-CORRECT)) (* ;;; "Page layout of 3, 3x5 cards per page with heading and 2 columns per card.") (RPAQ TOP10-FRAMES [TEDIT.PARSE.PAGEFRAMES '(LIST ((PAGE NIL (PAPERSIZE Letter LANDSCAPE? T FOLIOINFO (ARABIC "˙ď%˙" "˙ď%˙")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 6 FAMILY OPTIMA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE ITALIC WEIGHT BOLD INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "˙ď%˙" "˙ď%˙")) (108 36 288 36) NIL) (TEXT NIL NIL (36 36 210 540) NIL) (TEXT NIL NIL (258 36 210 540) NIL))) (PAGE NIL (PAPERSIZE Letter LANDSCAPE? T FOLIOINFO (ARABIC "˙ď%˙" "˙ď%˙")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 6 FAMILY OPTIMA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE ITALIC WEIGHT BOLD INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "˙ď%˙" "˙ď%˙")) (108 36 288 36) NIL) (TEXT NIL NIL (36 36 210 540) NIL) (TEXT NIL NIL (258 36 210 540) NIL))) (PAGE NIL (PAPERSIZE Letter LANDSCAPE? T FOLIOINFO (ERISIC "˙ď%˙" "˙ď%˙")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 6 FAMILY OPTIMA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE ITALIC WEIGHT BOLD INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "˙ď%˙" "˙ď%˙")) (108 36 288 36) NIL) (TEXT NIL NIL (36 36 210 540) NIL) (TEXT NIL NIL (258 36 210 540) NIL]) (TOP10.INIT) (PUTPROPS FORMATTINGFNS FILETYPE CL:COMPILE-FILE) (PUTPROPS FORMATTINGFNS COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (15668 28962 (CALL.HEAD 15678 . 16659) (CALL.OTHERPARA 16661 . 17608) (CALL.1DIAGRAM 17610 . 18559) (CALL.2DIAGRAM 18561 . 19606) (CALL.3DIAGRAM 19608 . 20700) (CALL.4DIAGRAM 20702 . 21945) (CALL.5DIAGRAM 21947 . 23194) (CALL.6DIAGRAM 23196 . 24567) (TOP10.PAGELAYOUT 24569 . 24861) ( TOP10.CALLNAME-STYLE 24863 . 25121) (TOP10.CALLDEFN-STYLE 25123 . 25380) (TOP10.NO-STYLE 25382 . 25597 ) (TOP10.NOTEHEAD-STYLE 25599 . 25857) (TOP10.NOTE-STYLE 25859 . 26108) (TOP10.DIAGRAM-STYLE 26110 . 26365) (TOP10.INIT 26367 . 28960)) (29032 31007 (TOP10-DIAGRAM-CHAR-STYLE 29042 . 29427) ( TOP10-CALLTITLE-CHAR-STYLE 29429 . 29817) (TOP10-MAINPARA-CHAR-STYLE 29819 . 30219) ( TOP10-NOTETITLE-CHAR-STYLE 30221 . 30627) (TOP10-NOTE-CHAR-STYLE 30629 . 31005)) (32434 34235 ( TOP10-BIG-STYLES 32444 . 33294) (TOP10-PRINT-STYLES 33296 . 34233)) (34295 34739 (XPS.COVER.PARA 34305 . 34737)) (34780 38942 (CRAM-DOC 34790 . 38366) (FILE-TO-WP 38368 . 38721) (CHC 38723 . 38940)) ( 38995 52182 (TEDIT.EXTERNAL.FORM 39005 . 48503) (TEDIT.EXT.PARALOOKS 48505 . 49687) ( TEDIT.EXT.CHARLOOKS 49689 . 51434) (TEDIT.EXT.OBJECT 51436 . 52180)) (52245 53240 (SPELLING-CORRECT 52255 . 53238))))) STOP \ No newline at end of file diff --git a/internal/test/env/FilePkg/Hand/AR10062.u b/internal/test/env/FilePkg/Hand/AR10062.u new file mode 100644 index 00000000..06027a6b --- /dev/null +++ b/internal/test/env/FilePkg/Hand/AR10062.u @@ -0,0 +1 @@ +Testing AR 10062: In an Interlisp Exec: LOAD({Eris}Env>FilePkg>Hand-Aux>FORMATTINGFNS) MAKEFILE({CORE}FORMATTINGFNS) ;;shouldn't cause an error. DELFILE({CORE}FORMATTINGFNS) The test is successful if the MAKEFILE runs to completion without causing an error. \ No newline at end of file diff --git a/internal/test/env/FreeMenu/Auto/FREEMENU.TEST b/internal/test/env/FreeMenu/Auto/FREEMENU.TEST new file mode 100644 index 0000000000000000000000000000000000000000..0f93888c3cd1fec785a8cc3fb6723d50265f2eb2 GIT binary patch literal 15472 zcmeHOZ){uFbtfswGG$4XZPj*@EWJ}=TT)Ebl48f92FDcnDAFSNXp*w*ByI3SKAE&A zQsp1pY8};13UmXwHHlk~3{q@EI}8N|)ZG@$u@fs>`^CiyY(PJ(z&>p)3Ty?IEeTqz zYqQ@u_dfDbmYp;)LLAR6i|KrI+1{Be7DNDJydtPgi;05=#Q5V!9#bPCM!6#9Rx;c#qP~PU z)Yc!&@91q_YY^)+mdW zQgOvBRdQxo5HzD)E~az580T}9EC>Mhvd9$CZ_>;b!C}w_c&V&eHtk>}5vvT2q_J2m zEgO~qBu64wU_mjTKmak($OSWNoXZtU#5p4)_9Y62wpcBsnX{(;h>EcU%ItEq$wxvi znU!j(K!eixV%f~_8l2A+GR5=wm@30GKN8Y0`dTNAf*iPRK$5>RaA;%87SK@ zVg=BgF&A?M>S$7VKAVHU(ndZnW!s{96SOw6MJabCTOo;*Op+Azr__W>ltG76Szv8q zN*gTCf-v&sq9~gc0rhETOEHYKESaCK=1MS#h1MDwD=T@WHcH+tf!HY{RDW2odRAaub<-8#l>RYaqs%e-4M3e%Hi@6dSD_NSV z%#nxDBzUrw=l;0!&)(hr?u}coUij9#yWe~FJFmX;?$>|xqxH``(fRxDeD3*I-?<=L zU%l||PoDVNo8P6k-Os=CR~P>J#*N+GJp4a8pBVfh=Fqe&&P&d1^)J`D<8!HaLXUUs z#LJEu-*h6ZMLel+R7)iNdNkRIW_K_g(E>g=U?<-C+XuNmQoqt&ztVvo=P3TUrl#t( zC!z*;Sj76%LWokeP$0gZnlTniIWzxBF>Myo*=3`&B+6BIl`^q>$}ANxh)Axy;;mmH zyq!b~I?!eUV-!|Jp}M?a z^4>z*iZmANt-R4l%SjhYC9}LzEMy2Dm@q^Mn}oCu0;6_rm=Cr*o&#ecC!K+tfd9PwLZj=0@ZEVQ!Z4zO7dc(l~zpiRXwSS|$gLONU! zM`JfJ2igpp7}*BgZOFrvO;VuB|$Tke#3?1PkNH!Dm>yf!=><;5<$+4yAkUr~L zagkt0nhu#q;JlSewndtZ)|VV3`?v3f{Zj=^`S2gkCZ*BtttON(PpV{4RwL z#JF5m>TK5(r4K}jR0$}H1PJfYrbVnP%4x|F9O_|WFbDIaAmlE=Bm%jDG^3K4u9nIi zvcSN~l($`*Nql@0D58@z{<=(4KvsW`8MGNQPyrZ~(Y+-mSGGQ(Gl1CpZ|~ z9_6dhs)$7{kQOq6xkXO-;IT=zWhR2+ zwoM2TBP~*-&fR-7JAym;8DTJRby)l+jevxxnWIY&hjsEHw|*4G9@`f z*_^U8l^5_d0AqNzI8_3*HI%am6fDn9yB-w1nJXw;5-Pk!%#gw=D-<&1MY8%Cgiex> zpnfoHe~P(l}!Ng5%`DGGCU+bDp`ts;#>xKV|TksAUEO3m;&FVni@Dy(uD z)>_EqO}RF0M3fbw#BD;QhaTXRgNQni0C)v9Nf3w}xd0oa055}h5qlJGXrM#MjO7;M zgpK28^MZj~o&|+PpuFBDCi~WXfPorZ6i`wjSj)V#LAB1ol0~F%dl-(e>H6crb=` z4%FtuF%j33BQz3ih&uyfcvw3z=Zj!O#2bu`(Ky;4t@jx%#Z&jkd{Irr!Vv)=BVs>B zM|{&-WJC=W+IX7~bugqBPS zF*H7jP&I>? zk``4v6Z?mUsYgmouAjhrQj2K*lokN4*0RcVYz-%3?ieg79FfaogB?S@{Ir*bQz}EB z0o2YSzSBxOm@G-g(2#wY7LZuN0kQw3T7NvA2*+6EkQOBxJ%dO$E?ug>Q0tu51E(FY zAp6;AURZ(Vl3H@=q>`Ykj-6*54*7e`m%WdE1{{s&91h1{;Lp|Qs9$kXGF9t+_~EF} zpU^$Dx72Gptye8}GMvz3C_1Jb9o>!nosEZ`z}GDiff$G5EA^|6Z4yVH!vXNm0(oTG(nPvcX-<=S5VVr{FHPxdz^T!Z!6zJxuq!`>nCsDe>!5AVB7 zaY2Q0Kq8UZztxyv>h8CwvoTLiivP)aZP4OBs>A!pjCgc20Zf99E4#5oohjceCBpJ4 z!cQG&lTFFylizyUl0t4Ao8kVRRKj->r3KA{Y&OMBTdgL3+k$EYlu|y&=bn5rqRHoA ztGx>~9bbT(JAy$qHV{5J;hB(Q`FUJD!>cCd__-^9O7lt8Y+7-c9Ai>RB$*xe%)Mt@9i&{`Odemp3QecmDkP8 z*|+|3a>)q&e9*DJ^nH4JB=4eEmwJ6T-(kGA^nG+Zkng09&h=}1k~|(u$pcfbWx0J0 zT8)P->*4KA7vZA?9(05TT}$*7@~ofa&)Y86NtdfJ(b3Tu@94y57j(@%8u$5UeKXo< z#}>S9AH@>J0=`7RqoXu5ml|yx>F9Jl_a1(fS@W!YI#&&Rk$SCfT8sHZsPoSzVeo-O zcp4=E4;77|U$MF9w3hJbK@T>ggin@LYCC;#IM9H{KDdJ<_6Hzgi;P1}JoYNuJhX@H zgwFN*5;Jq;H9T4(p(m(#vn6>N2N_Xk3f;Ru8%WMRtExF;ExH;HG4wCgYdhBVuI<&U zl@&S!D2TQ4+TPFAueyNS86xS01|6r@NnqqN=6B&g1dd+_Z#{I|6}rtUxD{{NFs)bi zM)qd*_3Rs=+m2h=XZqJ;FUFqFe$(+2C!Xhb5g@&v=IZ@_y6gq&DP`V zt;aW_FH1mCf^+`>1h2bMk046L7hX2-g|Lm&A0+b>+cW~d=M^!{Ef`&;<(g ze*Bx?)zgK(*>-TV{eU#Mt`Fw>0O?YV_|ylNzK6DJKh}5PVaNKlMx=dG1YEmree=EU zH_jgGUys7?ZDTL=gN|PKzn5wQqjNFrn*k4^lN9#CQSSZsZ7zosn@u-uw{r=NcMNB} z)-iMFa1SlVBoF&BJyLP9JE8d_zHpSZyLNKAx5z zk2D_NkBQw%|9%Vbd!Xw?r9MwV)F5G;4<__zAlZ+Rec_l#>7tvE{A;6|K7I%W`Urb~ zH#lm#!Wdqp$KU10FFng2e^}y=m(%?5mHQgc>;{g$I4mzX7l{O8TQSAysn;G}+pC>3 z@>SHikt!IADCM;3_!RQ48Ebn9{7>t((M`ruqQAQNjDNzG+I<#k+&|!`*Y3+3%L^HU zQjd)*gk4E)=kH)yF5$&N2>-5L+qJeAxiTsNbiTI6RTqn#uh(n$w~>Q`51f10DSoA1 z+Y0;hkqyFEJV2kL^dr`Mwwf>+*7o+b%Ccmgj(>!-22c@>Q!(13l!gk@?x*9aL})HH zJ5j}kyoXdabbAY#?+IzWS$2Hb?+MHg>a~79cF%%G(zaaY-Hy7L*Umv6_Ol-T`0uU! z@pC!%znla7`W`}@Pt%jLuZ@65UuirpeTn1q=L{Dvu}NM$+&*`#PtyQ z1Q5v%<=6F`Xk)pyOXLk1{~? zNA%c?CkaQ+{`joyIfI@7L}4L{5W_LrKK$CJWZzTh`-s&?8$Sxo3E8EitJmtHKsG4b z{RA$l2UGLDgyvCmyt3~x^z}6RXwsPMcmy5y(+RRC9F0flEIY+pjWvHr4*NKU?b&P? zf$HTkZ#mqbt=G1%?F-@z9QD<*cWvTeYAso;*Lv3WB~d<<4Zd`}_OZ2nQ5?e3Ib*m` zMgcW#b|*P1L7~1vPQDUi)aPFNLEE)$s&FOcoa_=c$U_J`1thF5tI1ZPWHM zJUTboFa?JuJJ$Abhiy2*lcV*kvWQz;T%^-UGEojCRrzV9TIO>oO5wQ)=a(u)r%(xg zP*b&pRuO-Js$2_Z<-CbB9pxQW(Xa}#Rw+UjY(4-8S((`Y<$y}>#k77(2#-4j0ymJL z>L?31N;2fxUW+rTlW_f4Q3EK+kS|~{(^g9X0NbedXPIQhNRj8$a~mE6SXAdi&VH`~ zPE%Gw#O!rU)IntR(5=deaGE8yHgbxsPVgC zrVZ3kXhS%I0!xVwPyiA44RVXP#(=XVE*iS2)NdN#)4aez6jeT~qg2%Gii!xFVw(m| zcnVZVsmRj_d*#SpEMlrED^ow+l46+3NpX2qV%1VDLDdcv96WBHJg`y4R$d9K zzQ*d@oRQFG;Eu!EV#8m_4T=J^`{hFlbGSlD@s_n zI5Ff#B?J+^P}QUTRE3D@$cJKL{Gcp0xKY7HD~d{7p5>~NDt_$emT@j41@%}8D!*q~Yn?*)QzFhz1D?6bj!I!3t{0H$g}F-3<< z0P%ZUWO+>zF!8?ACpV`+>>t0^RF)Cd*@p9#aOE<%!eKC6MQ)-0Qeehh|azx1daWn+r3B{LboZG zk(C~2PkWH)?8D~T#kDhMC&J<`-?W}cIUM#l?u>-k7Bn3pRA2ZYksD9$`EcPHA$fii z?1x`zJOSL){SW5ZxBql0OVJuwebDvlmiZmmFB{k8OLz9Q?2YG**K#-1J3_ddmyMh9 zt!wG^%LcMQG~U7=azFY%U`xGX`T#|I$6|Va1W6ep(>L@1y`Qihf0<*#NSKl}e$@M& zxg6(bA-#W=<^c^F`M=AVAHX#0netKVxew2>8pj2>4mXyhe-uRvzt+s=pKv?dV!tg2 zh*buoYG|0$xo=iG-RLHPIetMo4z7Rr)Xj+(YFiRo9I@m_sQ255zc$@x?aecPkHS;Q`L>M?WByi3Y6VUfc;}~Wh&0aqSg$}i8%YV5_>Hl;nKO zS?XdYN{){0bT{T>v_yVAemW7x=7|K41Uki^Uv2F>Ud-qwT*QA?ROm=U%%w&`pz-@ zdF8kd^?y(Q+QmmUnc3_7&Cma932dShziIkklEAP$Xk*vLyRdkW4proBz9BfqA@QK9 zcM2M7JrAkc`q0Qo52pyI#`!T52b?(Ro$&aoXFNxaAd&D+PI|{58xq4qxaYOPH~x`a z@p0tF3;zn_(Uh)7l1J5>I*S^6dg`$roK#PadyZH04El)o(75*yKo8mdbA~}*%oQ$* zAu4&`R+A}Ovv7e+4xn!(WG;#xJH*GmuLMcdgiviA>j(RWj@2wH!o8@~#ub(WlL zC$wk7NinA}1-?#%Z&gqnPL!h#%r~h)KfYpwB%7}K zP||%5u01K;L+Jx0M!#MOv|(zd0K&R|4*wnq`+X@rkyJ7X&{0}Klb1*W&~b{P*>wbT z?W8YqOnFw8dqhV<0VPTbR0pGYhPiU#sY0TzZBJg9r zz;T_f@JI;5BrGt7{m$z>#oWe;lTk6uO?z#4 zd0A7r!eo;N`(H^kNi{+vH<0Y-dszXAlm;jsHkSr3YCFKY5P&7+^Hqy9mcUFzpT-Td zjX0TNd~a}gnu^-EaVEui=P)tME3vVIZljSBsB3I79c&^|5BZWI3zj8RlICbj>K+>7 z;V@;CbdeSgDdJ``d+sq+40H0|0wy+*itr}GPio@OLE%kkJXF2Y(sJ};sTpZ~e0E0e zI2#tsVg#ySAEqFv^mZfHN}!knv4Hz_t)ux-#U0T#h{!TMh)`g(9*hlA+3PLRm|}I)`ryafDzsDo2!{)Bfg~s1^Po z#HjfJ&onOUZBUdA2q6axtEECxD|&<-3aR2n+`?90jq=C~duFNa%HBmxIm8-^+oIzl z8TNWNxriqYw)IfC4JPKC!d*PqG1vCXTSLy*LaryBH;=ns4`(`FpmJn*muthv_Re0^ PKHor}{MC1$B3b+&nrh_V literal 0 HcmV?d00001 diff --git a/internal/test/env/Program-Support/Auto/CLISP.TEST b/internal/test/env/Program-Support/Auto/CLISP.TEST new file mode 100644 index 0000000000000000000000000000000000000000..e033b9509c358b60399b468bb96431fc307cd57d GIT binary patch literal 7660 zcmb_h?QYw~673849mXn9QE{m1!){TzE-HUCFyPv)W1tC8#HGlU&0C68NGg&3_}TB7 z*`-KHD_TiyBosyN&YYP!GqbxoK0c=5EKeq09{O~4b@}!W%2k$U?Y(2Xx_b;W8i$e6 z4=I0CX3*I4!zj!bc$6lyhery+RQWmiUKC}NCv^VTHWHPC=qFij!PqdU>uU z)11d-;bazhIixS9DvWt-GoxvmjJ#2_;2HEur3;#6YCMa0Mmme35up5JG6k-ny|?EC ziOZPX2Oyb})A%Dz9#U_zX;Wj5*8T<~HBM4R4wOE`8?VdJP!fe%PR^W~P8bb5!ezu4 zpDzJl=6qT3Wt=4Z0gohU;C5TB8p%Y?c;fv#i$}>U4rpFGm{n`3EPq7&ebklvUQ0f@ z_uY>Ee&6fV>0K2Cp(3neSKVY{6&_THE+48oGCiA(D)8z}`Rt`JHO|#IjKlbWJQ%N| z%HPJb*w4cxrl+^<1~t_uFLFPJ`J?M24AVMjj-iGduw<3iyB>o;sWtKBsQEN?vpfZq zI$g{UhbN2i!RK%iju*8GD~u9zz&pvW#?95adwG3#amzXA-fdE~oVj}Eq{<82ahgmF zV5)+D4t*gjZ`B5iXi!8Xs}t$ypgw)KC9D(APZJZh%a?2*(nZSk>h;w(u|x|i*Sd+hP&q`Vyd4&9kVwZ3^ZwzC_;6_6E_P{ zt5_Q3vdHJfL10mQj2%?iv&&>=DA!lt%TzIOSBg5El-Xi3O2BX~$MGzRcJM&KsufT8 z+6itLqmYaJ#*E#pkf2mOyCx6OiNoE&F|=$)KdgmxO)(Q>9HwXvg*`82(9ZAxFhj3F zu$B;Zic*V?(VV%lJ*$d`TDkn}%zvc0exl}UolMe4U;irPr)OtNDki+FSRfCSA9>ua zO?DHDNwb}7g`n5JO6EV8!@HC^s04IgJ*DVM6UED?WU5jxPf{$N@UB>vP~$QlhjTj6 zCEZaUkxMJpNv|jR9TXX9>fH|4oAsX5aE5e1r>zEF9%6(=h5G_3T%!Vu2b+plFQDR; zQPJ<%b$tH!XP*y(UWL(qX% z+h@&aCQqeEa(rzueq&Z2|B0$^?o0%*vanF~>Lqks6*`K-zn*h%F1{qtl72oR5gGCF z&z6bT=Y({8a{(L8%~^{xvz)iZ?5_dD^`I2Y{T#KkvKl6o1_pFWR~KM}xv>F)6qKwh z-pHtVo_ao4D?D8H+km|3GzwL~doHfm+i1%hou=c_h4} z_G$Z+U0tzD=m?|*lXxMOr!!gJt~S26;be-l18MlxQQO$$Q5WQq9*Es6-yj?HO+bfB z3nvUKy-ijNU)1pl-u;m8fyq__)pH{dfECX=o+`1RT~wEX@2}jV`Rl zrom)^ZJpx?9V9BoRvcrhS+$*M5ePt#$4G)|R zCBg^s4wuvK!#q;bo9(!0Fi&C{zZf@~`N2ok+ zrQ*!67nmeLI1Uy17~YiS-_)LaTP9WmY`C&f1c&!`Tt8%})>_KG*I7QGFqYz$*_3ek znj2=D8bn7WPnp}VaKMm6fhz}xb0q$DroS8X1W?5#R+i^n>sZgybK+$aVS&V{uzgs; za5S%!1e`?{yJc?Pt|`)KQh8q@sRG7+HUGHOwVB!P25#^E`tpiX8>J8nyxol2HgKuR z5Uu~BwrLx;(c}wx@*g-d=oUV+d%etXOHjEv6a=xn)((>qrEpCy9rFs4&Gc;!;k?lc zl&zUFSzv%Jde+5@X$`EC2LiXusNgQxX6qZjzsJ&MxxCStzPgK&I%hnhu^?^ukUJ;r zjPZYMO|I+W1{`a0>^7=6(J`Y@9n29=Y3mj@U#T&EIB8QFK0N05IYs#@P_eHl8I!dh za;dVfy~;=z?zAqsh6ktjXIw51%Lzr@5mIUCeDncTBU#j$FTBDtcG#MtZ9!P-s0Vd_ zdLW>V$_Z=LQ(Z_fnDp7{P5$-xn-tI!*&E@&KLm6;|L4?7e<0-XU0c*C7{8 z_Jeup{;>L1WP7&{pD(PZg_UHsjv^nt*D!YUO4+bVuEQ2Hf Rd=!8nh-wXt{oUI8=KqPAf^Pr- literal 0 HcmV?d00001 diff --git a/internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ b/internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..e033b9509c358b60399b468bb96431fc307cd57d GIT binary patch literal 7660 zcmb_h?QYw~673849mXn9QE{m1!){TzE-HUCFyPv)W1tC8#HGlU&0C68NGg&3_}TB7 z*`-KHD_TiyBosyN&YYP!GqbxoK0c=5EKeq09{O~4b@}!W%2k$U?Y(2Xx_b;W8i$e6 z4=I0CX3*I4!zj!bc$6lyhery+RQWmiUKC}NCv^VTHWHPC=qFij!PqdU>uU z)11d-;bazhIixS9DvWt-GoxvmjJ#2_;2HEur3;#6YCMa0Mmme35up5JG6k-ny|?EC ziOZPX2Oyb})A%Dz9#U_zX;Wj5*8T<~HBM4R4wOE`8?VdJP!fe%PR^W~P8bb5!ezu4 zpDzJl=6qT3Wt=4Z0gohU;C5TB8p%Y?c;fv#i$}>U4rpFGm{n`3EPq7&ebklvUQ0f@ z_uY>Ee&6fV>0K2Cp(3neSKVY{6&_THE+48oGCiA(D)8z}`Rt`JHO|#IjKlbWJQ%N| z%HPJb*w4cxrl+^<1~t_uFLFPJ`J?M24AVMjj-iGduw<3iyB>o;sWtKBsQEN?vpfZq zI$g{UhbN2i!RK%iju*8GD~u9zz&pvW#?95adwG3#amzXA-fdE~oVj}Eq{<82ahgmF zV5)+D4t*gjZ`B5iXi!8Xs}t$ypgw)KC9D(APZJZh%a?2*(nZSk>h;w(u|x|i*Sd+hP&q`Vyd4&9kVwZ3^ZwzC_;6_6E_P{ zt5_Q3vdHJfL10mQj2%?iv&&>=DA!lt%TzIOSBg5El-Xi3O2BX~$MGzRcJM&KsufT8 z+6itLqmYaJ#*E#pkf2mOyCx6OiNoE&F|=$)KdgmxO)(Q>9HwXvg*`82(9ZAxFhj3F zu$B;Zic*V?(VV%lJ*$d`TDkn}%zvc0exl}UolMe4U;irPr)OtNDki+FSRfCSA9>ua zO?DHDNwb}7g`n5JO6EV8!@HC^s04IgJ*DVM6UED?WU5jxPf{$N@UB>vP~$QlhjTj6 zCEZaUkxMJpNv|jR9TXX9>fH|4oAsX5aE5e1r>zEF9%6(=h5G_3T%!Vu2b+plFQDR; zQPJ<%b$tH!XP*y(UWL(qX% z+h@&aCQqeEa(rzueq&Z2|B0$^?o0%*vanF~>Lqks6*`K-zn*h%F1{qtl72oR5gGCF z&z6bT=Y({8a{(L8%~^{xvz)iZ?5_dD^`I2Y{T#KkvKl6o1_pFWR~KM}xv>F)6qKwh z-pHtVo_ao4D?D8H+km|3GzwL~doHfm+i1%hou=c_h4} z_G$Z+U0tzD=m?|*lXxMOr!!gJt~S26;be-l18MlxQQO$$Q5WQq9*Es6-yj?HO+bfB z3nvUKy-ijNU)1pl-u;m8fyq__)pH{dfECX=o+`1RT~wEX@2}jV`Rl zrom)^ZJpx?9V9BoRvcrhS+$*M5ePt#$4G)|R zCBg^s4wuvK!#q;bo9(!0Fi&C{zZf@~`N2ok+ zrQ*!67nmeLI1Uy17~YiS-_)LaTP9WmY`C&f1c&!`Tt8%})>_KG*I7QGFqYz$*_3ek znj2=D8bn7WPnp}VaKMm6fhz}xb0q$DroS8X1W?5#R+i^n>sZgybK+$aVS&V{uzgs; za5S%!1e`?{yJc?Pt|`)KQh8q@sRG7+HUGHOwVB!P25#^E`tpiX8>J8nyxol2HgKuR z5Uu~BwrLx;(c}wx@*g-d=oUV+d%etXOHjEv6a=xn)((>qrEpCy9rFs4&Gc;!;k?lc zl&zUFSzv%Jde+5@X$`EC2LiXusNgQxX6qZjzsJ&MxxCStzPgK&I%hnhu^?^ukUJ;r zjPZYMO|I+W1{`a0>^7=6(J`Y@9n29=Y3mj@U#T&EIB8QFK0N05IYs#@P_eHl8I!dh za;dVfy~;=z?zAqsh6ktjXIw51%Lzr@5mIUCeDncTBU#j$FTBDtcG#MtZ9!P-s0Vd_ zdLW>V$_Z=LQ(Z_fnDp7{P5$-xn-tI!*&E@&KLm6;|L4?7e<0-XU0c*C7{8 z_Jeup{;>L1WP7&{pD(PZg_UHsjv^nt*D!YUO4+bVuEQ2Hf Rd=!8nh-wXt{oUI8=KqPAf^Pr- literal 0 HcmV?d00001 diff --git a/internal/test/env/Program-Support/hand/DWIM.REPORT b/internal/test/env/Program-Support/hand/DWIM.REPORT new file mode 100644 index 00000000..67d4fc55 --- /dev/null +++ b/internal/test/env/Program-Support/hand/DWIM.REPORT @@ -0,0 +1 @@ +TEST REPORT FOR DWIM COMMAND: DWIMIFIED OPERATOR: +OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:11 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: -OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:12 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: *OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:12 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: /OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:12 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: ^OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:13 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: =OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:13 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: GT-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:14 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: LT-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:14 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: GE-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:15 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: LE-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:15 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: NTH-OPERATOR-1 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:16 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: NTH-OPERATOR-2 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:16 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: RECORD-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:17 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: NTH-TAIL-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:17 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: SETQ-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:19 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: SETQ-OPERATOR-1 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:19 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: SETQ-OPERATOR-2 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:19 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:20 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR-1 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:21 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR-2 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:21 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR-3 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:22 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: QUOTE-OPERATOR-1 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:22 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: QUOTE-OPERATOR-2 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:23 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: NOT-OPERATOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:23 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-1 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:25 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-2 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:25 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-3 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:25 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-4 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:27 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-5 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:27 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-6 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:28 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-7 LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:29 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: DWIM-SPELLING LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: FAIL DATE: 7-Apr-87 07:54:30 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: DWIM-PARENTHESES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:30 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: DWIM-UNBOUND-ATOM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:31 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: DWIM-UNDEFINED-FN LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:31 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: DWIM-FUNCTIONS LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:32 TESTER: JPARK.PASA COMMAND: DWIMIFIED OPERATOR: DWIM-VARIABLES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 7-Apr-87 07:54:32 TESTER: JPARK.PASA TOTAL TEST RUN TIME FOR DWIM: 1.92075 MINUTES COMMAND: DWIMIFIED OPERATOR: +OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:24 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: -OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:26 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: *OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:27 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: /OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:27 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: ^OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:28 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: =OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:28 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: GT-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:29 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: LT-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:30 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: GE-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:30 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: LE-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:30 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: NTH-OPERATOR-1 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:31 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: NTH-OPERATOR-2 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:31 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: RECORD-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: FAIL DATE: 20-Apr-87 10:17:32 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: NTH-TAIL-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:33 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: SETQ-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:34 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: SETQ-OPERATOR-1 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:35 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: SETQ-OPERATOR-2 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:35 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:36 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR-1 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:36 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR-2 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:37 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: LIST-OPERATOR-3 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:37 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: QUOTE-OPERATOR-1 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:38 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: QUOTE-OPERATOR-2 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:38 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: NOT-OPERATOR LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:39 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-1 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:40 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-2 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:41 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-3 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:41 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-4 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:42 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-5 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:42 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-6 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:43 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: PRECEDENCE-7 LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:43 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: DWIM-SPELLING LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: FAIL DATE: 20-Apr-87 10:17:44 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: DWIM-PARENTHESES LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:44 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: DWIM-UNBOUND-ATOM LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:45 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: DWIM-UNDEFINED-FN LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:46 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: DWIM-FUNCTIONS LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:47 TESTER: SCHUSTER COMMAND: DWIMIFIED OPERATOR: DWIM-VARIABLES LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:17:47 TESTER: SCHUSTER TOTAL TEST RUN TIME FOR DWIM: 2.2254834 MINUTES \ No newline at end of file diff --git a/internal/test/env/Program-Support/hand/DWIM.U b/internal/test/env/Program-Support/hand/DWIM.U new file mode 100644 index 00000000..c9d317fb --- /dev/null +++ b/internal/test/env/Program-Support/hand/DWIM.U @@ -0,0 +1 @@ +;; Function To Be Tested: DWIM (Program Support Tools) ;; ;; Source: IRM VOLUME 2 , Section 20 ;; Section 20. DWIM,Lyric Release Notes ;; ;; Section: Program Support ;; ;; Created By: John Park ;; ;; Creation Date: April 6, 1987 ;; ;; Last Update: April 7, 1987 ;; ;; Filed As: {ERIS}test>program-support>clisp.u ;; ;; ;; Syntax: SEE IRM Volume 2, Section 20 ;; ;; Function Description: To correct misspellings, parentheses errors, and other ;; syntactical errors in interlisp programming, the DWIM facility (Do-What-I-Mean) is ;; implemented. DWIM is called automatically whenever an error occurs in the evaluation ;; of an Interlisp expression. DWIM then proceeds to try to correct the mistake using ;; the current context of computation plus information about what the user had ;; previously been doing, (what mistakes he had been making) as guides to the remedy ;; of the error. If DWIM is able to make the correction, the computation continues ;; as though DWIM had not intervened: a break occurs, or an unwind to the last ERRORSET ;; (page 14.21). ;; ;; Argument(s): SEE IRM Volume 2, Section 20 ;; ;; Returns: SEE IRM Volume 2, Section 20 ;; ;; Constraints/Limitations: Testing for DWIM requires the old interlisp executive, which ;; the user will be prompted to create during the couse of testing. ;; Instructions will be given in the prompt window for the user actions to be taken ;; during testing and appropriate messages will be displayed to explain each test ;; process. Test result is logged on {eris}test>program-support>clisp.report. ;; ;; ;; (DO-TEST "DWIM-TEST-SETUP" (PROGN (IL:PAGEHEIGHT 0) (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-SUPPORT>DWIM.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DWIM: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DWIMIFIED OPERATOR: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DWIMIFIED OPERATOR: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ DWIM-MESS1 "Shortly, you will be prompted to create an old interlisp exec window.After specifying a region, click the new exec and enter (DWIM-TEST)") (SETQ DWIM-MESS2 "Please answer y when the test is finished... ") (SETQ DWIM-MESS3 "DWIM test is now finished; please answer Y to continue") ; Defining DWIM-TEST for tesing clisp operators... (IL:DEFINEQ (IL:FOO (X Y) (IL:PLUS X Y))) (IL:DEFINEQ (IL:DWIM-TEST NIL (IL:PROGN (IL:PAGEHEIGHT 0) (IL:SETQ IL:DWIM-MESS " DWIM TEST IS FINISHED PLEASE CLICK THE XCL EXEC WINDOW AND ANSWER YES") (IL:SETQ IL:OPS-LIST '(IL:+OPERATOR IL:-OPERATOR IL:*OPERATOR IL:/OPERATOR IL:^OPERATOR IL:=OPERATOR IL:GT-OPERATOR IL:LT-OPERATOR IL:GE-OPERATOR IL:LE-OPERATOR IL:NTH-OPERATOR-1 IL:NTH-OPERATOR-2 IL:RECORD-OPERATOR IL:NTH-TAIL-OPERATOR IL:SETQ-OPERATOR IL:SETQ-OPERATOR-1 IL:SETQ-OPERATOR-2 IL:LIST-OPERATOR IL:LIST-OPERATOR-1 IL:LIST-OPERATOR-2 IL:LIST-OPERATOR-3 IL:QUOTE-OPERATOR-1 IL:QUOTE-OPERATOR-2 IL:NOT-OPERATOR IL:PRECEDENCE-1 IL:PRECEDENCE-2 IL:PRECEDENCE-3 IL:PRECEDENCE-4 IL:PRECEDENCE-5 IL:PRECEDENCE-6 IL:PRECEDENCE-7)) (IL:SETQ IL:DWIM-TEST-STRING "(DRIBBLE '{CORE}SPELL) (SETQ FOO (PLUSS 1 2)) (DRIBBLE) (DRIBBLE '{CORE}PAREN) 9IPLUS 1 2] (DRIBBLE) (DRIBBLE '{CORE}ATOM) (SETQ BAR 'YES) BARR (DRIBBLE) (DRIBBLE '{CORE}FNS) (FOOS 1 2) (DRIBBLE) (SETQ OPEN-SPELL (OPEN '{CORE}SPELL 'INPUT)) (SETQ SPELL-LST (FOR X TO 10 COLLECT (READ OPEN-SPELL))) (CLOSEF OPEN-SPELL) (IF (AND (MEMBER '=IPLUS SPELL-LST) (MEMBER 3 SPELL-LST)) THEN (SETQ DWIM-SPELL T) ELSE (SETQ DWIM-SPELL NIL)) (SETQ OPEN-PAREN (OPEN '{CORE}PAREN 'INPUT)) (SETQ PAREN-LST (FOR X TO 12 COLLECT (READ OPEN-PAREN))) (CLOSEF OPEN-PAREN) (IF (AND (MEMBER '=IPLUS PAREN-LST) (MEMBER 3 PAREN-LST)) THEN (SETQ DWIM-PAREN T) ELSE (SETQ DWIM-PAREN NIL)) (SETQ OPEN-ATOM (OPEN '{CORE}ATOM 'INPUT)) (SETQ ATOM-LST (FOR X TO 12 COLLECT (READ OPEN-ATOM))) (CLOSEF OPEN-ATOM) (IF (AND (MEMBER '=BAR ATOM-LST) (MEMBER 'YES ATOM-LST)) THEN (SETQ DWIM-ATOM T) ELSE (SETQ DWIM-ATOM NIL)) (SETQ OPEN-FNS (OPEN '{CORE}FNS 'INPUT)) (SETQ FNS-LST (FOR X TO 10 COLLECT (READ OPEN-FNS))) (CLOSEF OPEN-FNS) (IF (AND (MEMBER '=FOO FNS-LST) (MEMBER 3 FNS-LST)) THEN (SETQ DWIM-FNS T) ELSE (SETQ DWIM-FNS NIL)) (PROMPTPRINT DWIM-MESS3) (PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) ") (IL:BKSYSBUF IL:DWIM-TEST-STRING) ) )) ; Test Result Analysis ; The following will compare the actural results of DWIM forms with ; the expected results... (PAUSE) (SETQ DWIM-STRING "; Creating an old interlisp executive (IL:PROMPTPRINT DWIM-MESS1) (PAUSE) (ADD-EXEC :PROFILE 'OLD-INTERLISP-T :EXEC (QUOTE IL:EVALQT)) (IL:ASKUSER 10 'Y DWIM-MESS2) (SETQ OPERATOR-LIST '(+OPERATOR -OPERATOR *OPERATOR /OPERATOR ^OPERATOR =OPERATOR GT-OPERATOR LT-OPERATOR GE-OPERATOR LE-OPERATOR NTH-OPERATOR-1 NTH-OPERATOR-2 RECORD-OPERATOR NTH-TAIL-OPERATOR SETQ-OPERATOR SETQ-OPERATOR-1 SETQ-OPERATOR-2 LIST-OPERATOR LIST-OPERATOR-1 LIST-OPERATOR-2 LIST-OPERATOR-3 QUOTE-OPERATOR-1 QUOTE-OPERATOR-2 NOT-OPERATOR PRECEDENCE-1 PRECEDENCE-2 PRECEDENCE-3 PRECEDENCE-4 PRECEDENCE-5 PRECEDENCE-6 PRECEDENCE-7)) ; Test Result Analysis ; The following will compare the actural results of DWIM forms with (CL:IN-PACKAGE 'INTERLISP) (SETQ EXPECTED-DWIM-FORMS '((PLUS A B) (DIFFERENCE A B) (TIMES A B) (QUOTIENT A B) (EXPT A B) (EQ A A) (GREATERP A B) (LESSP A B) (AND (GEQ A B) (GEQ A C)) (AND (LEQ B A) (LEQ B D)) (CADR FOO) (CAR (LAST (CAR (LAST FOO)))) (|fetch| (B B1) |of| RECORD-1) (CDDDR FOO) (SETQ SETQ-OP 7) (RPLACA (CDR FOO-SETQ) 90) (RPLACD FOO-SETQ 0) (LIST A B (LIST C D)) (CONS A (CONS B C)) (APPEND A B (LIST C)) (NCONC1 A B) (EQ X (QUOTE Y)) (EQ Z (QUOTE DON'T)) (AND (EQ (NOT NIL) T) (NOT (GEQ A B))) (PLUS 1 (TIMES 3 2)) (DIFFERENCE 10 (EXPT 4 2)) (NEQ (PLUS 1 3) 5) (TIMES 2 (EXPT 3 3)) (EQ (TIMES 2 2) 4) (GREATERP (DIFFERENCE 4 1) (PLUS 1 (TIMES 2 3))) (AND (NOT NIL) T))) (SETQ ACTUAL-CLISP '((A + B) (A - B) (A * B) (A / B) (A ^ B) (A = A) (A GT B) (A LT B) (AND (A GE B) (A GE C)) (AND (B LE A) (B LE D)) (|FOO:2|) (|FOO:-1:-1|) (|RECORD-1-1:B.B1|) (|FOO::3|) (SETQ-OP_7) (|FOO-SETQ:2_90|)(|FOO-SETQ::1_0|) (>) () () () (X = (QUOTE Y)) (Z = (QUOTE DON'T)) (AND ~NIL = T ~ (A GE B)) (1 + 3 * 2) (10 - 4 ^ 2) (1 + 3 ~= 5)(2 * 3 ^ 3) (2 * 2 = 4) (4 - 1 GT 1 + 2 * 3) (~NIL AND T))) (SETQ ACTUAL-DWIMIFIED-CLISP (MAPCAR ACTUAL-CLISP 'DWIMIFY)) (CL:IN-PACKAGE 'XCL-TEST) (SETQ PAIRED-DWIM (PAIRLIS IL:EXPECTED-DWIM-FORMS IL:ACTUAL-DWIMIFIED-CLISP)) ; Test to see if the following DWIM functions defineds and variables bound... (SETQ DWIM-FNS-BOUND NIL) (SETQ DWIM-FLIST '(IL:ADDSPELL IL:MISSPELLED? IL:FIXSPELL IL:FNCHECK)) (DOLIST (Y DWIM-FLIST) (IF (FBOUNDP Y) (PUSH T DWIM-FNS-BOUND ) (PROGN (PUSH NIL DWIM-FNS-BOUND) (IL:PROMPTPRINT Y '|: FUNCTION NOT BOUND|)))) (SETQ DWIM-VAR-BOUND NIL) (SETQ DWIM-VLIST '(IL:DWIMWAIT IL:FIXSPELLDEFAULT IL:ADDSPELLFLG IL:NOSPELLFLG IL:RUNONFLG IL:DWIMLOADFNSFLG IL:LPARKEY IL:RPARKEY IL:OKREEVALST IL:DWIMFLG IL:APPROVEFLG IL:LAMBDASPLST IL:SPELLINGS1 IL:SPELLINGS2 IL:SPELLINGS3 IL:USERWORDS IL:\#SPELLINGS1 IL:\#SPELLINGS2 IL:\#SPELLINGS3 IL:\#USERWORDS)) (DOLIST (Y DWIM-VLIST) (IF (BOUNDP Y) (PUSH T DWIM-VAR-BOUND ) (PROGN (PUSH NIL DWIM-VAR-BOUND) (IL:PROMPTPRINT Y '|: VARIABLE NOT BOUND|)))) (IL:CLRPROMPT) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (ABS(- TEST-END TEST-START)) 60000))) ; Wrinting the test results to ; {eris}test>program-support>clisp.u.... (DO-TEST 'DWIM-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (DOLIST (Y PAIRED-DWIM) (IF (EQUAL (CAR Y) (CDR Y)) (PROGN (SETQ OPERATOR (POP IL:OPS-LIST)) (PASS-FAIL OPERATOR T)) (PROGN (SETQ OPERATOR (POP IL:OPS-LIST)) (PASS-FAIL OPERATOR NIL)))) (PASS-FAIL 'DWIM-SPELLING IL:DWIM-SPELL) (PASS-FAIL 'DWIM-PARENTHESES IL:DWIM-PAREN) (PASS-FAIL 'DWIM-UNBOUND-ATOM IL:DWIM-ATOM) (PASS-FAIL 'DWIM-UNDEFINED-FN IL:DWIM-FNS) (PASS-FAIL 'DWIM-FUNCTIONS (NOTANY #'NULL DWIM-FNS-BOUND)) (PASS-FAIL 'DWIM-VARIABLES (NOTANY #'NULL DWIM-VAR-BOUND)) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) ") (IL:BKSYSBUF DWIM-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/Program-Support/hand/dwim.log b/internal/test/env/Program-Support/hand/dwim.log new file mode 100644 index 00000000..df661746 --- /dev/null +++ b/internal/test/env/Program-Support/hand/dwim.log @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 23-Feb-88 12:18:20 ;;; Running tests from ({eris}Env>Program-support>hand>dwim.u;) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-abort.u b/internal/test/env/code-editor/hand/Command-abort.u new file mode 100644 index 00000000..52b491fd --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-abort.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>Command-abort.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Abort" :before (progn (setq window-list (do-test-menu-Setup "Abort"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Abort: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 23 a cd \"hello\" \"there\" (\"hi\" b 4))) (il:dv tempx) Select ABORT from the popup menu. Until told differently always click yes to abort. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: no selection/edit caret In the exec type: \"(il:dv tempx)\" Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type \" 45 67\", then meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: no selection/structure caret In the exec type: \"(il:dv tempx)\" Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select a litatom In the exec type: \"(il:dv tempx)\" Select the litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select a string In the exec type: \"(il:dv tempx)\" Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select a number In the exec type: \"(il:dv tempx)\" Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. Select ABORT from the popup menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select a list" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select a list In the exec type: \"(il:dv tempx)\" Select the list (\"hi\" b 4) as a structure. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select a comment In the exec type: \"(il:dv tempx)\" Place the edit caret after the number 23 and type \"; hello\", then select this as a structure, and type meta-A. Was the parenthesis around the comment?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select part of a litatom In the exec type: \"(il:dv tempx)\" Select the \"d\" in the litatom \"cd\". Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select part of a string In the exec type: \"(il:dv tempx)\" Select the \"h\" in the string \"hello\" and type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: select part of a number In the exec type: \"(il:dv tempx)\" Select the \"2\" in the number \"23\" and type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: try after deleting a litatom In the exec type: \"(il:dv tempx)\" Place the edit caret after the litatom \"b\" with in the list. Type control-W, and meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: try after deleting a string In the exec type: \"(il:dv tempx)\" Place the structure caret after the string \"hi\" with in the list. Type control-W and meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: try after deleting a number In the exec type: \"(il:dv tempx)\" Place the edit caret right after the number \"23\" with no selection. Type control-W, and meta-A Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: try after deleting a list In the exec type: \"(il:dv tempx)\" Pick the list \"(\"hi\" b 4)\" as a structure and press the delete key. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: try after deleting a comment In the exec type: \"(il:dv tempx)\" Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key and type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: try extended selection of litatoms In the exec type: \"(il:dv tempx)\" Place the edit caret after the litatom \"cd\". Type \" ef gh\". Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: extended selection of strings In the exec type: \"(il:dv tempx)\" Select the string \"hello\" as a structure, and extend the selection to include the next string. Type meta-A. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: extended selection of numbers In the exec type: \"(il:dv tempx)\" Place the structure caret after the number \"1\". Type \" 2 3 4\". Now select the number \"2\" as a structure, and extend the selection to include the next two numbers. Type meta-M, and pick ABORT from the SEdit Command Menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: extended selection of lists In the exec type: \"(il:dv tempx)\" Place the structure caret after the list \"(\"hi\" b 4)\". Type \"(2)(3)(4)\". Select the list \"(\"hi\" b 4)\" as a structure, and extend the selection to include the next three lists. Type meta-M, and pick ABORT from the SEdit Command Menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: extended selection of litatoms and numbers In the exec type: \"(il:dv tempx)\" Place the structure caret after the number 23. Type \"fg 56 hij 9876 sdf\". Select the number \"1\" as a structure, and extend the selection to include the next nine items. Type meta-M, and pick ABORT from the SEdit Command Menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: extended selection of strings and lists In the exec type: \"(il:dv tempx)\" Place the structure caret after the number \"1\". Type \" (hi) \"hi\" (bye) \"bye\" (list-string)\" Select the list \"(hi)\" as a structure, and extend the selection to include the next five items. Select Abort from the popup menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: extended selection of several things In the exec type: \"(il:dv tempx)\" Select the number \"1\" as a structure, and extend the selection to include the next six items. Select Abort from the popup menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: selection of entire structure In the exec type: \"(il:dv tempx)\" Select the entire structure. Select Abort from the popup menu. Were you able to get this far?")) (good-value (equal '(1 23 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ;;; Try a couple where don't abort, but save and make sure saved (do-test "Abort: delete, don't abort, ok?" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping tempx equals (1 23 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: delete, thensaying no to abort In the exec type: \"(il:dv tempx)\" Select the number 23 as a structure and press the delete key. Select Abort from the popup menu, say no, and type control-x Were you able to get this far?")) (good-value (equal '(1 a cd "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Abort: add, don't abort, ok?" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is currently editing tempx which equals (1 a cd \"hello\" \"there\" (\"hi\" b 4)) Testing: add, then saying no to abort Place the structure caret after the litatom \"cd\". Type \"(hi)\" Type meta-A, say no, and type control-x Were you able to get this far?")) (good-value (equal '(1 a cd (hi) "hello" "there" ("hi" b 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-arglist.u b/internal/test/env/code-editor/hand/Command-arglist.u new file mode 100644 index 00000000..da774839 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-arglist.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 12, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}command-help.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Arglist" :before (progn (setq window-list (do-test-menu-Setup "Arglist"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Arglist: no selection/no caret" (do-test-menu-Message window-list 'high " Testing Arglist If there is no free Xerox Common Lisp exec, bring up one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq number 3) (defun temp-double (number) (* 2 number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (+ (temp-add-five number) (temp-double number))) (defun temp-garbage (start) (concatenate 'string start 23 5 (4 cd \"hi\") \" more\")) (il:df temp-call-other) Select Arglist from the popup menu. Does SEdit display in its prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Make sure the functions got entered in correctly" (and (eq 3 number) (eq 26 (temp-double 13)) (eq 50 (temp-double 25)) (eq 10 (temp-add-five 5)) (eq 28 (temp-add-five 23)) (eq 11 (temp-call-other 2)) (eq 14 (temp-call-other 3)) )) (do-test "Arglist: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the function temp-call-other Want to place the edit caret right after the litatom \"temp-double\" without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of \"temp-double\". Type meta-H. Does SEdit display in the SEdit prompt window \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Arglist: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the function temp-call-other Want to place the structure caret right between the \"temp-add-five\" and \"number\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-H. Does SEdit display in the SEdit prompt window \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Arglist: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the function temp-call-other Select the last litatom \"number\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for NUMBER\"? ")) ; The response to this may change when AR 7703 is answered/fixed. (do-test "Arglist: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the function temp-call-other Close the SEdit window for temp-call-other In the exec type: \"(il:df temp-garbage)\" Select the string \" more\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-H. Does it display a message of: \"Arguments not available for more\"? ")) (do-test "Arglist: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the function temp-garbage. Select the number \"5\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for 5\"? ")) (do-test "Arglist: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the function temp-garbage. Select the list \"(4 cd \"hi\")\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for (4 cd hi)\"? ")) (do-test "Arglist: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the function temp-garbage. Select the \"d\" in the litatom \"cd\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for CD\"?")) (do-test "Arglist: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the function temp-garbage. Select the \"h\" in the string \"hi\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the function temp-garbage. Select the \"2\" in the number \"23\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for 23\"? ")) (do-test "Arglist: delete a litatom" (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assuming SEdit is editing the function temp-garbage. Close the SEdit window for temp-garbage. In the exec type: \"(il:df temp-call-other)\" Place the structure caret after the second litatom \"number\". Type in the litatom \"ab\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Arglist: delete a string" (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assuming SEdit is editing the function temp-call-other. Place the structure caret after the third litatom \"number\". Type in the string \"hello\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Arglist: delete a number" (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assuming SEdit is editing the function temp-call-other. Place the structure caret before the third litatom \"number\". Type in the number \"34\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Arglist: delete a list" (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assuming SEdit is editing the function temp-call-other. Place the structure caret before the second litatom \"number\". Type in the list \"(have a \"nice\" day)\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Arglist: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the function temp-call-other. Place the edit caret after the second litatom \"number\". Type \" ef gh\". Now select the litatom \"number\" as a structure, and extend the selection to include the next two litatoms. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the function temp-call-other. Place the edit caret after the litatom \"gh\". Type \" 12 3.4 5/6 (hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the function temp-call-other. Select the number \"12\" as a structure, and extend the selection to include the next two numbers. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the function temp-call-other. Select the list \"(hi)\" as a structure, and extend the selection to include the next list. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the function temp-call-other. Select the litatoms \"ef\" as a structure, and extend the selection to include the next four items. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the function temp-call-other. Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the function temp-call-other. Select the litatom \"ef\" as a structure, and extend the selection to include the rest. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? Type meta-H a couple times if neccesary to see.")) (do-test "Arglist: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the function temp-call-other. Select the entire structure. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for (DEFUN TEMP-CALL-OTHER (NUMBER) (+ (TEMP-ADD-FIVE NUMBER EF GH 12 3.4 5/6 (HI) (BYE) \"string\" \"string2\" (list)) (TEMP-DOUBLE NUMBER)))\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-arglist.u.~1~ b/internal/test/env/code-editor/hand/Command-arglist.u.~1~ new file mode 100644 index 00000000..51507530 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-arglist.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 12, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}command-help.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERIS}Integration>do-test-menu.def")) T) (do-test-group "Help" :before (progn (setq window-list (do-test-menu-Setup "Help"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Help: no selection/no caret" (do-test-menu-Message window-list 'high " Testing Help If there is no free Xerox Common Lisp exec, bring up one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq number 3) (defun temp-double (number) (* 2 number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (+ (temp-add-five number) (temp-double number))) (defun temp-garbage (start) (concatenate 'string start 23 5 (4 cd \"hi\") \" more\")) (il:df temp-call-other) Select Help from the popup menu. Does SEdit display in it's prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Make sure the functions got entered in correctly" (and (eq 3 number) (eq 26 (temp-double 13)) (eq 50 (temp-double 25)) (eq 10 (temp-add-five 5)) (eq 28 (temp-add-five 23)) (eq 11 (temp-call-other 2)) (eq 14 (temp-call-other 3)) )) (do-test "Help: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the function temp-call-other Want to place the edit caret right after the function call to \"temp-double\" without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of \"temp-double\". Type meta-H. Does SEdit display in the SEdit prompt window \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Help: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the function temp-call-other Want to place the structure caret right between the \"temp-add-five\" and \"number\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-H. Does SEdit display in the SEdit prompt window \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Help: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the function temp-call-other Select the last litatom \"number\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for NUMBER\"? ")) ; The response to this may change when AR 7703 is answered/fixed. (do-test "Help: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the function temp-call-other Close the SEdit window for temp-call-other In the exec type: \"(il:df temp-garbage)\" Select the string \" more\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-H. Does it display a message of: \"Arguments not available for more\"? ")) (do-test "Help: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the function temp-garbage. Select the number \"5\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for 5\"? ")) (do-test "Help: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the function temp-garbage. Select the list \"(4 cd \"hi\")\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for (4 cd hi)\"? ")) (do-test "Help: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the function temp-garbage. Select the \"d\" in the litatom \"cd\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for CD\"?")) (do-test "Help: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the function temp-garbage. Select the \"h\" in the string \"hi\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the function temp-garbage. Select the \"2\" in the number \"23\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for 23\"? ")) (do-test "Help: delete a litatom" (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assumping SEdit is editing the function temp-garbage. Close the SEdit window for temp-garbage. In the exec type: \"(il:df temp-call-other)\" Place the structure caret after the second litatom \"number\". Type in the litatom \"ab\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Help: delete a string" (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assumping SEdit is editing the function temp-call-other. Place the structure caret after the third litatom \"number\". Type in the string \"hello\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Help: delete a number" (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assumping SEdit is editing the function temp-call-other. Place the structure caret before the third litatom \"number\". Type in the number \"34\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Help: delete a list" (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assumping SEdit is editing the function temp-call-other. Place the structure caret before the second litatom \"number\". Type in the list \"(have a \"nice\" day)\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Help: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the function temp-call-other. Place the edit caret after the second litatom \"number\". Type \" ef gh\". Type meta-H Now select the litatom \"number\" as a structure, and extend the selection to include the next two litatoms. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the function temp-call-other. Place the edit caret after the litatom \"gh\". Type \" 12 3.4 5/6 (hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the function temp-call-other. Select the number \"12\" as a structure, and extend the selection to include the next two numbers. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the function temp-call-other. Select the list \"(hi)\" as a structure, and extend the selection to include the next list. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the function temp-call-other. Select the litatoms \"ef\" as a structure, and extend the selection to include the next four items. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the function temp-call-other. Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Help: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the function temp-call-other. Select the litatom \"ef\" as a structure, and extend the selection to include the rest. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? Type meta-H a couple times if neccesary to see.")) (do-test "Help: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the function temp-call-other. Select the entire structure. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for (DEFUN TEMP-CALL-OTHER (NUMBER) (+ (TEMP-ADD-FIVE NUMBER EF GH 12 3.4 5/6 (HI) (BYE) \"string\" \"string2\" (list)) (TEMP-DOUBLE NUMBER)))\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-arglist.u.~2~ b/internal/test/env/code-editor/hand/Command-arglist.u.~2~ new file mode 100644 index 00000000..da774839 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-arglist.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 12, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}command-help.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Arglist" :before (progn (setq window-list (do-test-menu-Setup "Arglist"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Arglist: no selection/no caret" (do-test-menu-Message window-list 'high " Testing Arglist If there is no free Xerox Common Lisp exec, bring up one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq number 3) (defun temp-double (number) (* 2 number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (+ (temp-add-five number) (temp-double number))) (defun temp-garbage (start) (concatenate 'string start 23 5 (4 cd \"hi\") \" more\")) (il:df temp-call-other) Select Arglist from the popup menu. Does SEdit display in its prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Make sure the functions got entered in correctly" (and (eq 3 number) (eq 26 (temp-double 13)) (eq 50 (temp-double 25)) (eq 10 (temp-add-five 5)) (eq 28 (temp-add-five 23)) (eq 11 (temp-call-other 2)) (eq 14 (temp-call-other 3)) )) (do-test "Arglist: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the function temp-call-other Want to place the edit caret right after the litatom \"temp-double\" without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of \"temp-double\". Type meta-H. Does SEdit display in the SEdit prompt window \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Arglist: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the function temp-call-other Want to place the structure caret right between the \"temp-add-five\" and \"number\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-H. Does SEdit display in the SEdit prompt window \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Arglist: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the function temp-call-other Select the last litatom \"number\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for NUMBER\"? ")) ; The response to this may change when AR 7703 is answered/fixed. (do-test "Arglist: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the function temp-call-other Close the SEdit window for temp-call-other In the exec type: \"(il:df temp-garbage)\" Select the string \" more\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-H. Does it display a message of: \"Arguments not available for more\"? ")) (do-test "Arglist: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the function temp-garbage. Select the number \"5\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for 5\"? ")) (do-test "Arglist: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the function temp-garbage. Select the list \"(4 cd \"hi\")\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for (4 cd hi)\"? ")) (do-test "Arglist: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the function temp-garbage. Select the \"d\" in the litatom \"cd\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for CD\"?")) (do-test "Arglist: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the function temp-garbage. Select the \"h\" in the string \"hi\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the function temp-garbage. Select the \"2\" in the number \"23\". Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for 23\"? ")) (do-test "Arglist: delete a litatom" (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assuming SEdit is editing the function temp-garbage. Close the SEdit window for temp-garbage. In the exec type: \"(il:df temp-call-other)\" Place the structure caret after the second litatom \"number\". Type in the litatom \"ab\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Arglist: delete a string" (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assuming SEdit is editing the function temp-call-other. Place the structure caret after the third litatom \"number\". Type in the string \"hello\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Arglist: delete a number" (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assuming SEdit is editing the function temp-call-other. Place the structure caret before the third litatom \"number\". Type in the number \"34\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-DOUBLE NUMBER)\"? ")) (do-test "Arglist: delete a list" (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assuming SEdit is editing the function temp-call-other. Place the structure caret before the second litatom \"number\". Type in the list \"(have a \"nice\" day)\" Type control-W, meta-H. Does SEdit display in the SEdit prompt window: \"(TEMP-ADD-FIVE NUMBER)\"? ")) (do-test "Arglist: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the function temp-call-other. Place the edit caret after the second litatom \"number\". Type \" ef gh\". Now select the litatom \"number\" as a structure, and extend the selection to include the next two litatoms. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the function temp-call-other. Place the edit caret after the litatom \"gh\". Type \" 12 3.4 5/6 (hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the function temp-call-other. Select the number \"12\" as a structure, and extend the selection to include the next two numbers. Type meta-H Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the function temp-call-other. Select the list \"(hi)\" as a structure, and extend the selection to include the next list. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the function temp-call-other. Select the litatoms \"ef\" as a structure, and extend the selection to include the next four items. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the function temp-call-other. Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? ")) (do-test "Arglist: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the function temp-call-other. Select the litatom \"ef\" as a structure, and extend the selection to include the rest. Type meta-H. Does SEdit display in the SEdit prompt window: \"Select function you want the arguments for.\"? Type meta-H a couple times if neccesary to see.")) (do-test "Arglist: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the function temp-call-other. Select the entire structure. Type meta-H. Does SEdit display in the SEdit prompt window: \"Arguments not available for (DEFUN TEMP-CALL-OTHER (NUMBER) (+ (TEMP-ADD-FIVE NUMBER EF GH 12 3.4 5/6 (HI) (BYE) \"string\" \"string2\" (list)) (TEMP-DOUBLE NUMBER)))\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-base.u b/internal/test/env/code-editor/hand/Command-base.u new file mode 100644 index 00000000..c6cc322f --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-base.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-base.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Base" :before (progn (setq window-list (do-test-menu-Setup "Base"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Base: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Base If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 23 4.5 6/7 a cd \"hello\" (\"hi\" b))) (il:dv tempx) Select BASE from the popup menu. Enter 9 as the base. Do the numbers read: \"#9r1 #9r25 4.5 #9r6/7\"? ")) (good-value (equal '(1 23 4.5 6/7 a cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 9 Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. If a break window pops up in the rests of these tests, just up arrow out of it and try again. Type meta-B, and enter 8 as the base, and then control-x. Do the numbers read: \"#o1 #o27 4.5 #o6/7\"? ")) (do-test "Base: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 8 Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-B, and enter 7 as the base. Do the numbers read: \"#7r1 #7r32 4.5 #7r6/10\"? ")) (do-test "Base: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 7 Select the litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-B, and enter 6 as the base. Do the numbers read: \"#6r1 #6r35 4.5 #6r10/11\"? ")) (do-test "Base: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 6 Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-B, and enter 5 as the base. Do the numbers read: \"#5r1 #5r43 4.5 #5r11/12\"? ")) (do-test "Base: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 5 Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. Select SET PRINT-BASE from the popup menu, and enter 4 as the base. Do the numbers read: \"#4r1 #4r113 4.5 #4r12/13\"? ")) (good-value (equal '(1 23 4.5 6/7 a cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 4 Select the list (\"hi\" b) as a structure. Select SET PRINT-BASE from the popup menu, and enter 3 as the base. Type control-x. Do the numbers read: \"#3r1 #3r212 4.5 #3r20/21\"? ")) (do-test "Base: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 3 Place the edit caret after the number 23 and type \"; hello\", then select this as a structure. Type meta-B, and enter 2 as the base. Do the numbers read: \"#b1 #b10111 4.5 #b110/111\"? ")) (do-test "Base: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 2 Type meta-A, and click yes. Now in the exec type: \"(il:dv tempx)\" Select the \"d\" in the litatom \"cd\". Type meta-B, and enter 11 as the base. Do the numbers read: \"#11r1 #11r21 4.5 #11r6/7\"? ")) (do-test "Base: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 11 Select the \"h\" in the string \"hello\". Type meta-B, and enter 10 as the base. Do the numbers read: \"1 23 4.5 6/7\"? ")) (do-test "Base: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) Select the \"7\" in the number \"6/7\". Type meta-B, and enter 12 as the base. Do the numbers read: \"#12r1 #12r1B 4.5 #12r6/7\"?")) (good-value (equal '(1 23 4.5 6/7 a cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 a cd \"hello\" (\"hi\" b)) with a print base of 12 Place the edit caret after the litatom \"a\". Type control-W, meta-B, and enter 13 as the base. Do the numbers read: \"#13r1 #13r1A 4.5 #13r6/7\"?")) (good-value (equal '(1 23 4.5 6/7 cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 cd \"hello\" (\"hi\" b)) with a print base of 13 Place the structure caret after the string \"hello\". Type control-W, meta-B, and enter 14 as the base Do the numbers read: \"#14r1 #14r19 4.5 #14r6/7\"? ")) (good-value (equal '(1 23 4.5 6/7 cd ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assumping SEdit is editing the variable tempx which currently equals: (1 23 4.5 6/7 cd (\"hi\" b)) with a print base of 14 Place the edit caret right after the number \"23\" with no selection. Type control-W, meta-B, and enter 15 as the base Do the numbers read: \"#15r1 4.5 #15r6/7\"? ")) (good-value (equal '(1 4.5 6/7 cd ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd) with a print base of 15 Pick the list \"(\"hi\" b)\" as a structure and press the delete key. Type meta-B, and enter 16 as the base. Do the numbers read: \"#x1 4.5 #x6/7\"? ")) (good-value (equal '(1 4.5 6/7 cd) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd) with a print base of 16 Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key, type meta-B, and enter 17 as the base. Do the numbers read: \"#17r1 4.5 #17r6/7\"? ")) (good-value (equal '(1 4.5 6/7 cd) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd) with a print base of 17 Place the edit caret after the litatom \"cd\". Type \" ef gh\". Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-m, change the value of Print-Base to 1, and left button the Print-Base item on the menu. Does it log complaint in the SEdit message window of \"Illegal print-base: 1\"? ")) (good-value (equal '(1 4.5 6/7 cd ef gh) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Base: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh) with a print base of 17 Place the edit caret after the litatom \"gh\". Type \"(hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. In the attach menu, change the value of Print-Base to 37, and left button the Print-Base item on the menu. Does it log complaint in the SEdit message window of \"Illegal print-base: 37\"? ")) (do-test "Base: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) with a print base of 17 Select the number \"1\" as a structure, and extend the selection to include the next two numbers. In the attach menu, try to change the value of Print-Base to 1000, then left button the Print-Base item on the menu. Do the numbers read: \"1 4.5 6/7\"? ")) (do-test "Base: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the list \"(\"hi\")\" as a structure, and extend the selection to include the next list. From the popup menu pick SET PRINT-BASE, and enter 10. Do the numbers read: \"1 4.5 6/7\"? ")) (do-test "Base: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the number \"1\" as a structure, and extend the selection to include the next five items. From the popup menu pick SET PRINT-BASE, and enter 10. Do the numbers read: \"1 4.5 6/7\"? ")) (do-test "Base: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. From the popup menu pick SET PRINT-BASE, and enter 2. Do the numbers read: \"#b1 4.5 #b110/111\"? ")) (do-test "Base: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) with a base of 2 Select the number \"1\" as a structure, and extend the selection to include the next 10 items. In the attached menu change the Print-Base to 8, and key on the menu item Print-Base. Do the numbers read: \"#o1 4.5 #o6/7\"? ")) (do-test "Base: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) with a base of 8 Select the entire structure. Type meta-B and enter 16 as the base. Do the numbers read: \"#x1 4.5 #x6/7\"? ")) (good-value (equal '(1 4.5 6/7 cd ef gh (hi) (bye) "string" "string2" (list)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-comment.u b/internal/test/env/code-editor/hand/Command-comment.u new file mode 100644 index 00000000..56dd3397 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-comment.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 19, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-comment.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Comment" :before (progn (setq window-list (do-test-menu-Setup "Comment"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Comment: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Comment If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment))) (il:dv tempx) Select Conv. Comment from the popup menu. Does SEdit display in the SEdit prompt window: \"Select structure to convert comments within.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4) (il:* a comment)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Comment: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-;. Does SEdit display in the SEdit prompt window: \"Select structure to convert comments within.\"? ")) (do-test "Comment: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-;. Does SEdit display in the SEdit prompt window: \"Select structure to convert comments within.\"? ")) (do-test "Comment: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Type control-x. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Type meta-U twice Select the \"d\" in the first litatom \"cd\". Type meta-;. Does SEdit display in the SEdit prompt window: \"Select structure to convert commnts within.\"? ")) (do-test "Comment: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the \"h\" in the string \"hello\". Type meta-;. Does SEdit display in the SEdit prompt window: \"Select structure to convert commnts within.\"? ")) (do-test "Comment: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the \"7\" in the number \"6/7\". Type meta-;. Does SEdit display in the SEdit prompt window: \"Select structure to convert commnts within.\"? ")) (do-test "Comment: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the number \"4.5\" in pending delete mode. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the list \"(bye)\" in pending delete mode. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Type control-x Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Type meta-U twice. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-; Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-; Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-;. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-;. Does SEdit display in the SEdit prompt window: \"No comments converted.\"? ")) (do-test "Comment: extended selection of several things" (do-test-menu-Message window-list 'high " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) (il:* a comment)) Type control-x. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-;. Does SEdit display in the SEdit prompt window: \"1 comment converted.\" And does the comment get converted to a common lisp comment? ")) (do-test "Comment: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) ; a comment) Type meta-U. Select the entire structure. Type meta-;. Does SEdit display in the SEdit prompt window: \"1 comment converted.\" And does the comment get converted to a common lisp comment? ")) (do-test "Comment: pending delete of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) ; a comment) Type meta-U. Select the entire structure in pending delete mode. Type meta-;. Does SEdit display in the SEdit prompt window: \"1 comment converted.\" And does the comment get converted to a common lisp comment? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-eval.u b/internal/test/env/code-editor/hand/Command-eval.u new file mode 100644 index 00000000..57fc4d59 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-eval.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-eval.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Evaluate" :before (progn (setq window-list (do-test-menu-Setup "Evaluate"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Evaluate: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Evaluate If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 4.5 6/7 a cd \"hello\" (\"hi\" b))) (setq a 5) (setq cd \"hi\") (il:dv tempx) Select Eval from the popup menu. Does it display: \"Select a single structure to evaluate\"? ")) (good-value (equal '(1 4.5 6/7 a cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" (\"hi\" b)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. If a break window pops up in the rests of these tests, just up arrow out of it and try again. Type meta-E. Does it display: \"Select a single structure to evaluate\"?")) (do-test "Evaluate: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" (\"hi\" b)) Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-E. Does it display: \"Select a single structure to evaluate\"?")) (do-test "Evaluate: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" (\"hi\" b)) Select the litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-E. Is the result a string \"hi\"? ")) (do-test "Evaluate: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" (\"hi\" b)) Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-E. Is the result a string \"hello\"? ")) (do-test "Evaluate: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" (\"hi\" b)) Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-E. Is the result the number 1? (if a break window pops up, uparrow out of it and indicate to the test prompter failure.)")) (good-value (equal '(1 4.5 6/7 a cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" (\"hi\" b)) Put the edit caret after the number 6/7. Type in \"(+ 4 5)\" Type control-x. Select the whole expression just entered. Type meta-E. Is the result the number 9?")) (do-test "Evaluate: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 (+ 4 5) a cd \"hello\" (\"hi\" b)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-E. Is the result \"il:\\;\"? ")) (do-test "Evaluate: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 (+ 4 5) a cd \"hello\" (\"hi\" b)) Select the comment as a structure and press the delete key. Select the \"d\" in the litatom \"cd\". Type meta-E. Does it display: \"Select a single structure to evaluate\"? ")) (do-test "Evaluate: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 (+ 4 5) a cd \"hello\" (\"hi\" b)) Select the \"h\" in the string \"hello\". Type meta-E. Does it display: \"Select a single structure to evaluate\"? ")) (do-test "Evaluate: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 (+ 4 5) a cd \"hello\" (\"hi\" b)) Select the \"7\" in the number \"6/7\". Type meta-E. Does it display: \"Select a single structure to evaluate\"? (if a break window pops up, uparrow out of it and indicate to the test prompter failure.)")) (good-value (equal '(1 4.5 6/7 (+ 4 5) a cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 (+ 4 5) a cd \"hello\" (\"hi\" b)) Place the edit caret after the litatom \"a\". Type control-W, meta-E. Does it display: \Select a single structure to evaluate\"?")) (good-value (equal '(1 4.5 6/7 (+ 4 5) cd "hello" ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 (+ 4 5) cd \"hello\" (\"hi\" b)) Place the structure caret after the string \"hello\". Type control-W, meta-E. Does it display: \Select a single structure to evaluate\"?")) (good-value (equal '(1 4.5 6/7 (+ 4 5) cd ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 (+ 4 5) cd (\"hi\" b)) Place the edit caret right after the number \"4.5\" with no selection. Type control-W, meta-E. Does it display: \Select a single structure to evaluate\"?")) (good-value (equal '(1 6/7 (+ 4 5) cd ("hi" b)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd (\"hi\" b)) Pick the list \"(\"hi\" b)\" as a structure and press the delete key. Type meta-E. Does it display: \Select a single structure to evaluate\"?")) (good-value (equal '(1 6/7 (+ 4 5) cd) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd) Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key, and type meta-E. Does it display: \Select a single structure to evaluate\"?")) (good-value (equal '(1 6/7 (+ 4 5) cd) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ;;; When AR 7642 gets resolved may have to fix up the next several tests. (do-test "Evaluate: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd) Place the edit caret after the litatom \"cd\". Type \" ef gh\". Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-m, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"? ")) (good-value (equal '(1 6/7 (+ 4 5) cd ef gh) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Evaluate: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd ef gh) Place the edit caret after the litatom \"gh\". Type \"(hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. In the attach menu, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"? ")) (do-test "Evaluate: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the number \"1\" as a structure, and extend the selection to include the next number. In the attach menu, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"? ")) (do-test "Evaluate: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the list \"(hi)\" as a structure, and extend the selection to include the next list. In the attach menu, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"?")) (do-test "Evaluate: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the number \"1\" as a structure, and extend the selection to include the next six items. In the attach menu, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"?")) (do-test "Evaluate: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 6/7 (+ 4 5) cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"?")) (do-test "Evaluate: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the number \"1\" as a structure, and extend the selection to include the rest. In the attach menu, left button the Eval item on the menu. Does it display: \Select a single structure to evaluate\"?")) (do-test "Evaluate: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd ef gh (hi) (bye) \"string\" \"string2\" (list)) Select the number \"1\" as a structure, and extend the selection to include the rest, press the delete key. Type: \"* 45 55\" Select the entire structure. In the attach menu, left button the Eval item on the menu. Is the result shown to be 2475?")) (good-value (equal '(* 45 55) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-expand.u b/internal/test/env/code-editor/hand/Command-expand.u new file mode 100644 index 00000000..ca4d7262 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-expand.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 24, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-expand.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Expand" :before (progn (setq window-list (do-test-menu-Setup "Expand"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Expand: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Expand If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (defmacro temp-double (number) `(+ ,number ,number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (+ (temp-add-five number) (temp-double number))) (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Expand from the pop up menu. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Expand: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-X twice. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-X. Does SEdit display in the SEdit prompt window: \"No expansion found.\"? ")) (do-test "Expand: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"d\" in the first litatom \"cd\". Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-X Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-X Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"? ")) (do-test "Expand: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-X. Does SEdit display in the SEdit prompt window: \"No expansion found.\"? ")) (do-test "Expand: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the entire structure in pending delete mode. Type meta-X. Does SEdit display in the SEdit prompt window: \"Can't expand this selection.\"?")) ;;; Test function works as well as the entry points... (do-test "Expand: Can we expand a function?" (do-test-menu-Message window-list 'high " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Close the window. In the exec type \"(ed 'temp-call-other)\" Select \"(temp-add-five number)\" Type meta-X. Does SEdit replace the function call with a let statement which adds five to the number?")) (do-test "Expand: Can we expand a macro??" (do-test-menu-Message window-list 'high " Testing: selection of entire structure Assumping SEdit is editing the function \"temp-call-other\" Select \"(temp-double number)\" Type meta-X. Does SEdit replace the macro with a statement which adds the number to itself?")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-extract.u b/internal/test/env/code-editor/hand/Command-extract.u new file mode 100644 index 00000000..673c5c70 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-extract.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 19, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-extract.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Extract" :before (progn (setq window-list (do-test-menu-Setup "Extract"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Extract: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Extract If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Extract from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-/. Did the parentheses around ("hi" (B) CD 4) disappear? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) "hi" (b) cd 4) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4) Type meta-U. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-/. Did the parentheses around (bye) disappear? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) Type meta-U. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-/. Did the semicolon disappear and \"hello\" become just another atom in the list? ")) (do-test "Extract: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U three times. Select the \"d\" in the first litatom \"cd\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U twice. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-/ Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-/ Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the entire structure. Type meta-0. Reselect the entire structure. Type meta-/, and control-L Did you get back the original list? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type control-x. Select the entire structure in pending delete mode. Type meta-m. Pick the extract command on the attached menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-extract.u.~1~ b/internal/test/env/code-editor/hand/Command-extract.u.~1~ new file mode 100644 index 00000000..eb9bb4cb --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-extract.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 19, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-extract.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Extract" :before (progn (setq window-list (do-test-menu-Setup "Extract"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Extract: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Extract If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Extract from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-/. Were you able to get this far ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) "hi" (b) cd 4) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4) Type meta-U. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-/. Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) Type meta-U. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-/. Does SEdit display in the SEdit prompt window: \"not implemented for comments.\"? ")) (do-test "Extract: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U twice. Select the \"d\" in the first litatom \"cd\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U twice. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-/ Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-/ Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the entire structure. Type meta-0. Reselect the enterie structure. Type meta-/, and control-L Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type control-x. Select the entire structure in pending delete mode. Type meta-m. Pick the extract command on the attached menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-extract.u.~2~ b/internal/test/env/code-editor/hand/Command-extract.u.~2~ new file mode 100644 index 00000000..673c5c70 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-extract.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 19, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-extract.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Extract" :before (progn (setq window-list (do-test-menu-Setup "Extract"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Extract: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Extract If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Extract from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-/. Did the parentheses around ("hi" (B) CD 4) disappear? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) "hi" (b) cd 4) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4) Type meta-U. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-/. Does SEdit display in the SEdit prompt window: \"Nothing to extract.\"? ")) (do-test "Extract: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-/. Did the parentheses around (bye) disappear? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) Type meta-U. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-/. Did the semicolon disappear and \"hello\" become just another atom in the list? ")) (do-test "Extract: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U three times. Select the \"d\" in the first litatom \"cd\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"4.5\" in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U twice. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-/ Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-/ Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-/. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Extract: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the entire structure. Type meta-0. Reselect the entire structure. Type meta-/, and control-L Did you get back the original list? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Extract: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type control-x. Select the entire structure in pending delete mode. Type meta-m. Pick the extract command on the attached menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-find.u b/internal/test/env/code-editor/hand/Command-find.u new file mode 100644 index 00000000..270123f6 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-find.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-find.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Find" :before (progn (setq window-list (do-test-menu-Setup "Find"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Find: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Find If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4))) (il:dv tempx) Select Find from the popup menu. Type in \"cd\". Does it find the litatom \"cd\" and select it? ")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Type control-x. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-F. Type in \"6/7\". Does it find the number \"6/7\" and select it? ")) (do-test "Find: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and pressing the middle button. Type meta-F. Enter the string \"hello\". Does it find the string \"hello\" and select it? ")) (do-test "Find: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Select the first litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. Press the find key. Does it find the second occurance of the litatom and select it? ")) (do-test "Find: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-F. Does it display a message of \"\"hello\" - Not found.\"? ")) (do-test "Find: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Place the structure caret right after the string \"BYE\". Type \" 4.5 (bye) (bye)\", and then control-x Select the first number \"4.5\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-F. Does it find the second occurance of the number and select it?")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the first list \"(bye)\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. Type meta-F. Does it find the second occurance of the list and select it?")) (do-test "Find: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-F. Does it display a message of \"(il:* il:\\; \" hello\") - Not found.\"? ")) (do-test "Find: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-F. Enter the litatom \"bye\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the first litatom \"bye\" and underline only it?")) (do-test "Find: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-F. Enter the number \"4\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the number \"4\" and underline only it?")) (do-test "Find: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-F. Enter the list \"(\"hi\" b cd 4)\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the list \"(\"hi\" b cd 4)\" and underline only it?")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"a\". Type control-W, meta-F. Enter the number \"4.5\". Does it find the second \"4.5\"? ")) (good-value (equal '(1 4.5 6/7 cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the structure caret after the string \"hello\". Type control-W, meta-F. Enter the litatom \"bye\". Does it find the first litatom \"bye\" (and not the string)? ")) (good-value (equal '(1 4.5 6/7 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret right after the number \"6/7\" with no selection. Type control-W, meta-F. Just press the carriage return. Does it find the first litatom \"bye\" (and not the string)? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Pick the first list of \"(bye)\" as a structure and press the delete key. Type meta-F. And press the carriage return. Does it find the litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key, type meta-F, and press the carriage return. Does it find the litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"cd\". Type \" ef gh\", and control-x. Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-m, in the Find field type in the string \"BYE\", then left button the Find item on the menu. Does it find the string \"BYE\"? ")) (good-value (equal '(1 4.5 cd ef gh "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"gh\". Type \"(hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. In the attach menu, left button the Find item on the menu. Does it find the string \"BYE\"? ")) (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. In the attach menu, left button the Find item on the menu. Does it find the string \"BYE\"? ")) (do-test "Find: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the list \"(hi)\" as a structure, and extend the selection to include the next list. In the attach menu, change the Find field to be \"4.5\", then left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. In the attach menu, left button the Find item on the menu. Does it say \"4.5 - Not found\"? ")) (do-test "Find: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the entire structure. In the attach menu, left button the Find item on the menu. Does it say \"At end; no more structure to search.\"? ")) (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-find.u.~1~ b/internal/test/env/code-editor/hand/Command-find.u.~1~ new file mode 100644 index 00000000..dbb2c5ff --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-find.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-find.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Find" :before (progn (setq window-list (do-test-menu-Setup "Find"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Find: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Find If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4))) (il:dv tempx) Select Find from the popup menu. Type in \"cd\". Does it find the litatom \"cd\" and select it? ")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Type control-x. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-F. Type in \"6/7\". Does it find the number \"6/7\" and select it? ")) (do-test "Find: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-F. Enter the string \"hello\". Does it find the number \"hello\" and select it? ")) (do-test "Find: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Select the first litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. Press the find key. Does it find the second occurance of the litatom and select it? ")) (do-test "Find: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-F. Does it display a message of \"\"hello\" - Not found.\"? ")) (do-test "Find: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Place the structure caret right after the string \"BYE\". Type \" 4.5 (bye) (bye)\", and then control-x Select the first number \"4.5\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-F. Does it find the second occurance of the number and select it?")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the first list \"(bye)\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. Type meta-F. Does it find the second occurance of the list and select it?")) (do-test "Find: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-F. Does it display a message of \"(il:* il:\\; \" hello\") - Not found.\"? ")) (do-test "Find: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-F. Enter the litatom \"bye\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the first litatom \"bye\" and underline only it?")) (do-test "Find: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-F. Enter the number \"4\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the number \"4\" and underline only it?")) (do-test "Find: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-F. Enter the list \"(\"hi\" b cd 4)\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the list \"(\"hi\" b cd 4)\" and underline only it?")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"a\". Type control-W, meta-F. Enter the number \"4.5\". Does it find the second \"4.5\"? ")) (good-value (equal '(1 4.5 6/7 cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the structure caret after the string \"hello\". Type control-W, meta-F. Enter the litatom \"bye\". Does it find the first litatom \"bye\"? ")) (good-value (equal '(1 4.5 6/7 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret right after the number \"6/7\" with no selection. Type control-W, meta-F. Just press the carriage return. Does it find the first litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Pick the first list of \"(bye)\" as a structure and press the delete key. Type meta-F. And press the carriage return. Does it find the litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key, type meta-F, and press the carriage return. Does it find the litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"cd\". Type \" ef gh\", and control-x. Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-m, in the Find field type in the string \"BYE\", then left button the Find item on the menu. Does it find the string \"BYE\"? ")) (good-value (equal '(1 4.5 cd ef gh "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"gh\". Type \"(hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. In the attach menu, left button the Find item on the menu. Does it find the string \"BYE\"? ")) (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. In the attach menu, left button the Find item on the menu. Does it find the litatom \"BYE\"? ")) (do-test "Find: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the list \"(hi)\" as a structure, and extend the selection to include the next list. In the attach menu, change the Find field to be \"4.5\", then left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. In the attach menu, left button the Find item on the menu. Does it say \"4.5 - Not found\"? ")) (do-test "Find: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the entire structure. In the attach menu, left button the Find item on the menu. Does it say \"4.5 - Not found\"? ")) (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-find.u.~2~ b/internal/test/env/code-editor/hand/Command-find.u.~2~ new file mode 100644 index 00000000..270123f6 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-find.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-find.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Find" :before (progn (setq window-list (do-test-menu-Setup "Find"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Find: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Find If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4))) (il:dv tempx) Select Find from the popup menu. Type in \"cd\". Does it find the litatom \"cd\" and select it? ")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Type control-x. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-F. Type in \"6/7\". Does it find the number \"6/7\" and select it? ")) (do-test "Find: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and pressing the middle button. Type meta-F. Enter the string \"hello\". Does it find the string \"hello\" and select it? ")) (do-test "Find: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Select the first litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. Press the find key. Does it find the second occurance of the litatom and select it? ")) (do-test "Find: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-F. Does it display a message of \"\"hello\" - Not found.\"? ")) (do-test "Find: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) Place the structure caret right after the string \"BYE\". Type \" 4.5 (bye) (bye)\", and then control-x Select the first number \"4.5\" as a structure, by pressing the middle button, with the cursor over the number. Type meta-F. Does it find the second occurance of the number and select it?")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the first list \"(bye)\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. Type meta-F. Does it find the second occurance of the list and select it?")) (do-test "Find: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-F. Does it display a message of \"(il:* il:\\; \" hello\") - Not found.\"? ")) (do-test "Find: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-F. Enter the litatom \"bye\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the first litatom \"bye\" and underline only it?")) (do-test "Find: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-F. Enter the number \"4\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the number \"4\" and underline only it?")) (do-test "Find: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-F. Enter the list \"(\"hi\" b cd 4)\" (If it doesn't ask what to find indicate failure to the prompter.) Does it find the list \"(\"hi\" b cd 4)\" and underline only it?")) (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"a\". Type control-W, meta-F. Enter the number \"4.5\". Does it find the second \"4.5\"? ")) (good-value (equal '(1 4.5 6/7 cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the structure caret after the string \"hello\". Type control-W, meta-F. Enter the litatom \"bye\". Does it find the first litatom \"bye\" (and not the string)? ")) (good-value (equal '(1 4.5 6/7 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the edit caret right after the number \"6/7\" with no selection. Type control-W, meta-F. Just press the carriage return. Does it find the first litatom \"bye\" (and not the string)? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Pick the first list of \"(bye)\" as a structure and press the delete key. Type meta-F. And press the carriage return. Does it find the litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key, type meta-F, and press the carriage return. Does it find the litatom \"bye\"? ")) (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"cd\". Type \" ef gh\", and control-x. Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-m, in the Find field type in the string \"BYE\", then left button the Find item on the menu. Does it find the string \"BYE\"? ")) (good-value (equal '(1 4.5 cd ef gh "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Place the edit caret after the litatom \"gh\". Type \"(hi) (bye) \"string\" \"string2\" (list)\". Now select the first string as a structure, and extend the selection to include the second string. In the attach menu, left button the Find item on the menu. Does it find the string \"BYE\"? ")) (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Find: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. In the attach menu, left button the Find item on the menu. Does it find the string \"BYE\"? ")) (do-test "Find: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the list \"(hi)\" as a structure, and extend the selection to include the next list. In the attach menu, change the Find field to be \"4.5\", then left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. In the attach menu, left button the Find item on the menu. Does it find the second number \"4.5\"? ")) (do-test "Find: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. In the attach menu, left button the Find item on the menu. Does it say \"4.5 - Not found\"? ")) (do-test "Find: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) Select the entire structure. In the attach menu, left button the Find item on the menu. Does it say \"At end; no more structure to search.\"? ")) (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-high.u b/internal/test/env/code-editor/hand/Command-high.u new file mode 100644 index 00000000..536c1c17 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-high.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 4, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-high.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "High level, high priority test" :before (progn (setq window-list (do-test-menu-Setup "High-level"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Trouble typing with parentheses" (let* (( user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(5)) (il:dv tempx) Put the edit caret after the five in the SEdit window. Type \"(() 6 7 8)\" Now complete the edit by typing control x. Were you able to get this far?")) (good-value (equal '(5 (nil 6 7 8)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble creating dotted pairs" (let* (( user-result (do-test-menu-Message window-list 'high " Testing dotted pairs. Assuming SEdit is editing tempx which currently equals (5 (nil 6 7 8)) Put the edit caret after the 8. Type \" .9\". Put the edit caret after the smaller list. Type \" .10\". Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(5 (nil 6 7 8 . 9) . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with single quote" (let* (( user-result (do-test-menu-Message window-list 'high " Testing single quotes. Assuming SEdit is editing tempx which currently equals (5 (nil 6 7 8 . 9) . 10) Pick the smaller list as a structure by pressing the middle button down over the open parenthensis. Press the delete key. Type \"'(5 6 7)\". Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(5 (quote (5 6 7)) . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with control-w" (let* (( user-result (do-test-menu-Message window-list 'high " Testing control-w. Assuming SEdit is editing tempx which currently equals (5 '(5 6 7) . 10) Pick the smaller list as a structure by pressing the middle button down over the close parenthensis. Type control W. Now complete the edit by typing control x. Do you now have "(5 . 10)?")) (good-value (equal '(5 . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with meta-(" (do-test-menu-Message window-list 'high " Testing meta-(. Assuming SEdit is editing tempx which currently equals (5 . 10) Select 10 as a structure. Pick meta-( from the pop menu. Check to see if the caret is in front of the ten. Now complete the edit by typing control x. Was the caret in front of the ten? ")) (do-test "Trouble with meta-A" (do-test-menu-Message window-list 'high " Testing meta-A. Assuming SEdit is editing tempx which currently equals (5 10) Place the edit caret after the ten. Type \" 11 12 13\". Pick meta-A from the pop-up menu. Confirm yes it is ok to abort. Were you able to get this far?")) (do-test "Trouble with meta-B" (do-test-menu-Message window-list 'high " Testing meta-B. Assuming tempx is currently equals (5 10) Type: \"(il:dv tempx)\" Pick meta-B from the pop menu and enter 3. Now complete the edit by selecting DONE from the pop-up menu. Do you see (#3r12 #3r101)?")) (do-test "Trouble with meta-J" (let* (( user-result (do-test-menu-Message window-list 'high " Testing meta-J. Assuming SEdit is editing tempx which currently equals (5 10) First restore the base by picking meta-B from the popup menu and entering 10. Delete everything inside the big list. Type \"x x x\". Then select these three elements. Pick meta-J from the pop menu. Now complete the edit by selecting DONE from the pop-up menu. Did the three X's become one atom, XXX?")) (good-value (equal '(xxx) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with meta-M" (do-test-menu-Message window-list 'high " Testing meta-M. Assuming SEdit is editing tempx which currently equals (xxx) Pick meta-M from the pop menu. Now complete the edit by selecting DONE from the pop-up menu. Does the menu come up and stay up?")) (do-test "Trouble with meta-U" (do-test-menu-Message window-list 'high " Testing meta-U. Assuming SEdit is editing tempx which currently equals (xxx) Place the edit structure caret after the symbol xxx. Type \" yyy\". Select Undo from the menu. Were you able to get this far?")) (do-test "Trouble with meta-R" (let* (( user-result (do-test-menu-Message window-list 'high " Testing meta-R. Assuming SEdit is editing tempx which currently equals (xxx) Place the edit structure caret after the symbol xxx. Type \" yyy\". Select Undo, Redo, and Exit from the menu. Were you able to get this far?")) (good-value (equal '(xxx yyy) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-high.u.~1~ b/internal/test/env/code-editor/hand/Command-high.u.~1~ new file mode 100644 index 00000000..d6074be4 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-high.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 4, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-high.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "High level, high priority test" :before (progn (setq window-list (do-test-menu-Setup "High-level"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Trouble typing with parentheses" (let* (( user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(5)) (il:SEdit tempx) Put the edit caret after the five in the SEdit window. Type:\"(()6 7 8\" Now complete the edit by typing control x. Were you able to get this far?")) (good-value (equal '(5 (nil 6 7 8)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble creating dotted pairs" (let* (( user-result (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (5 (nil 6 7 8)) Testing dotted pairs. Put the edit caret after the 8. Type: \" .9\" Put the edit caret after the smaller list. Type: \" .10\" Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(5 (nil 6 7 8 . 9) . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with single quote" (let* (( user-result (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (5 (nil 6 7 8 . 9) . 10) Testing single quotes. Pick the smaller list as a structure by holding both keys down over the open parenthensis. Press the delete key. Type: \"'(5 6 7\" Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(5 (quote (5 6 7)) . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with control x" (let* (( user-result (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (5 (quote (5 6 7)) . 10) Testing control-w. Pick the smaller list as a structure by holding both keys down over the close parenthensis. Type control W. Now complete the edit by typing control x. Were you able to get this far?")) (good-value (equal '(5 . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with control (" (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (5 . 10) Testing meta-(. Select 10 as a structure. Pick meta-( from the pop menu. Check to see if the caret is in front of the ten. Now complete the edit by typing control x. Was the caret in front of the ten?")) (do-test "Trouble with control (" (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (5 10) Testing meta-A. Place the edit caret after the ten. Type: \" 11 12 13\" Pick control-A from the pop-up menu. Confirm yes it is ok to abort. Were you able to get this far?")) (do-test "Trouble with control-B" (do-test-menu-Message window-list 'high "Assumping tempx is currently equals (5 10) Testing meta-B. Type: \"(il:dv tempx)\" Pick control-B from the pop menu and enter 3. Now complete the edit by selecting DONE from the pop-up menu. Do you see (#3r12 #3r101)?")) (do-test "Trouble with control-J" (let* (( user-result (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (5 10) Testing meta-J. First restore the base by picking control-B from the popup menu and entering 10. Delete everything inside the big list. Type: \"x x x\" Then select these three elements. Pick control-J from the pop menu. Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(xxx) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with control-M" (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (xxx) Testing meta-M. Pick control-M from the pop menu. Now complete the edit by selecting DONE from the pop-up menu. Does the menu come up and stay up?")) (do-test "Trouble with control-U" (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (xxx) Testing meta-U. Place the edit structure caret after the symbol xxx. Type: \" yyy\" Select Undo from the menu. Were you able to get this far?")) (do-test "Trouble with control-R" (let* (( user-result (do-test-menu-Message window-list 'high "Assumping SEdit is editing tempx which currently equals (xxx) Testing meta-R. Place the edit structure caret after the symbol xxx. Type: \" yyy\" Select Undo, Redo, and Exit from the menu. Were you able to get this far?")) (good-value (equal '(xxx yyy) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-high.u.~2~ b/internal/test/env/code-editor/hand/Command-high.u.~2~ new file mode 100644 index 00000000..536c1c17 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-high.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 4, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-high.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "High level, high priority test" :before (progn (setq window-list (do-test-menu-Setup "High-level"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Trouble typing with parentheses" (let* (( user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(5)) (il:dv tempx) Put the edit caret after the five in the SEdit window. Type \"(() 6 7 8)\" Now complete the edit by typing control x. Were you able to get this far?")) (good-value (equal '(5 (nil 6 7 8)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble creating dotted pairs" (let* (( user-result (do-test-menu-Message window-list 'high " Testing dotted pairs. Assuming SEdit is editing tempx which currently equals (5 (nil 6 7 8)) Put the edit caret after the 8. Type \" .9\". Put the edit caret after the smaller list. Type \" .10\". Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(5 (nil 6 7 8 . 9) . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with single quote" (let* (( user-result (do-test-menu-Message window-list 'high " Testing single quotes. Assuming SEdit is editing tempx which currently equals (5 (nil 6 7 8 . 9) . 10) Pick the smaller list as a structure by pressing the middle button down over the open parenthensis. Press the delete key. Type \"'(5 6 7)\". Now complete the edit by selecting DONE from the pop-up menu. Were you able to get this far?")) (good-value (equal '(5 (quote (5 6 7)) . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with control-w" (let* (( user-result (do-test-menu-Message window-list 'high " Testing control-w. Assuming SEdit is editing tempx which currently equals (5 '(5 6 7) . 10) Pick the smaller list as a structure by pressing the middle button down over the close parenthensis. Type control W. Now complete the edit by typing control x. Do you now have "(5 . 10)?")) (good-value (equal '(5 . 10) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with meta-(" (do-test-menu-Message window-list 'high " Testing meta-(. Assuming SEdit is editing tempx which currently equals (5 . 10) Select 10 as a structure. Pick meta-( from the pop menu. Check to see if the caret is in front of the ten. Now complete the edit by typing control x. Was the caret in front of the ten? ")) (do-test "Trouble with meta-A" (do-test-menu-Message window-list 'high " Testing meta-A. Assuming SEdit is editing tempx which currently equals (5 10) Place the edit caret after the ten. Type \" 11 12 13\". Pick meta-A from the pop-up menu. Confirm yes it is ok to abort. Were you able to get this far?")) (do-test "Trouble with meta-B" (do-test-menu-Message window-list 'high " Testing meta-B. Assuming tempx is currently equals (5 10) Type: \"(il:dv tempx)\" Pick meta-B from the pop menu and enter 3. Now complete the edit by selecting DONE from the pop-up menu. Do you see (#3r12 #3r101)?")) (do-test "Trouble with meta-J" (let* (( user-result (do-test-menu-Message window-list 'high " Testing meta-J. Assuming SEdit is editing tempx which currently equals (5 10) First restore the base by picking meta-B from the popup menu and entering 10. Delete everything inside the big list. Type \"x x x\". Then select these three elements. Pick meta-J from the pop menu. Now complete the edit by selecting DONE from the pop-up menu. Did the three X's become one atom, XXX?")) (good-value (equal '(xxx) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Trouble with meta-M" (do-test-menu-Message window-list 'high " Testing meta-M. Assuming SEdit is editing tempx which currently equals (xxx) Pick meta-M from the pop menu. Now complete the edit by selecting DONE from the pop-up menu. Does the menu come up and stay up?")) (do-test "Trouble with meta-U" (do-test-menu-Message window-list 'high " Testing meta-U. Assuming SEdit is editing tempx which currently equals (xxx) Place the edit structure caret after the symbol xxx. Type \" yyy\". Select Undo from the menu. Were you able to get this far?")) (do-test "Trouble with meta-R" (let* (( user-result (do-test-menu-Message window-list 'high " Testing meta-R. Assuming SEdit is editing tempx which currently equals (xxx) Place the edit structure caret after the symbol xxx. Type \" yyy\". Select Undo, Redo, and Exit from the menu. Were you able to get this far?")) (good-value (equal '(xxx yyy) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-join.u b/internal/test/env/code-editor/hand/Command-join.u new file mode 100644 index 00000000..709ab632 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-join.u @@ -0,0 +1 @@ +; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-join.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Join" :before (progn (setq window-list (do-test-menu-Setup "Join"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Join: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Join If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (il:dv tempx) Select Join from the popup menu. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structuret, by pressing the left mouse button twice with the cursor over the string. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Delete the comment. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-J Were the litatoms joined together to form \"abcd\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-J Were the strings joined together to form the string \"helloBYE\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-J. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"Can't join numbers.\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-J. Were the lists joined together to form the list \"(bye \"hi\" b cd 4)\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-J. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"Can't join numbers.\"? ")) (do-test "Join: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the string \"helloBYE\" as a structure, and extend the selection to include the next item. Type meta-J. Does SEdit display in the SEdit prompt window: \"Each item to join must be of the same type.\"? ")) (do-test "Join: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-J. Does SEdit display in the SEdit prompt window: \"Each item to join must be of the same type.\"? ")) (do-test "Join: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the entire structure. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-join.u.~1~ b/internal/test/env/code-editor/hand/Command-join.u.~1~ new file mode 100644 index 00000000..61d85c1b --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-join.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-join.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Join" :before (progn (setq window-list (do-test-menu-Setup "Join"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Join: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Join If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (il:dv tempx) Select Join from the popup menu. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Delete the comment. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-J Were the litatoms joined together to form \"abcd\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-J Were the strings joined together to form the string \"helloBYE\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-J. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"Can't join numbers.\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-J. Were the lists joined together to form the list \"(bye \"hi\" b cd 4)\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-J. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"Can't join numbers.\"? ")) (do-test "Join: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the string \"helloBYE\" as a structure, and extend the selection to include the next item. Type meta-J. Does SEdit display in the SEdit prompt window: \"Each item to join must be of the same type.\"? ")) (do-test "Join: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-J. Does SEdit display in the SEdit prompt window: \"Each item to join must be of the same type.\"? ")) (do-test "Join: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the entire structure. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-join.u.~2~ b/internal/test/env/code-editor/hand/Command-join.u.~2~ new file mode 100644 index 00000000..709ab632 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-join.u.~2~ @@ -0,0 +1 @@ +; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-join.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Join" :before (progn (setq window-list (do-test-menu-Setup "Join"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Join: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Join If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (il:dv tempx) Select Join from the popup menu. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structuret, by pressing the left mouse button twice with the cursor over the string. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (do-test "Join: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Delete the comment. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-J Were the litatoms joined together to form \"abcd\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-J Were the strings joined together to form the string \"helloBYE\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-J. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"Can't join numbers.\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-J. Were the lists joined together to form the list \"(bye \"hi\" b cd 4)\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Join: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-J. (If a break window pops up, uparrow out of it and indicate failure.) Does SEdit display in the SEdit prompt window: \"Can't join numbers.\"? ")) (do-test "Join: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the string \"helloBYE\" as a structure, and extend the selection to include the next item. Type meta-J. Does SEdit display in the SEdit prompt window: \"Each item to join must be of the same type.\"? ")) (do-test "Join: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-J. Does SEdit display in the SEdit prompt window: \"Each item to join must be of the same type.\"? ")) (do-test "Join: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) Select the entire structure. Type meta-J. Does SEdit display in the SEdit prompt window: \"Select items to join.\"? ")) (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-menu.u b/internal/test/env/code-editor/hand/Command-menu.u new file mode 100644 index 00000000..fda09bc4 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-menu.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 13, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-menu.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Menu" :before (progn (setq window-list (do-test-menu-Setup "Menu"))) :after (progn (do-test-menu-Cleanup window-list)) ;;; Since each command is tested in its own test suite, ;;; only worry about if can bring up the menu. (do-test "Menu: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Menu If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (il:dv tempx) Select AttachMenu from the popup menu. Does the attached menu come up? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Menu: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the SEdit popup menu. If the attached menu is up, close it. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. If the attached menu is up, close it. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the \"h\" in the string \"hello\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the \"7\" in the number \"6/7\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button with the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"4.5\" in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Delete the comment. If the attached menu is up, close it. Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-m. Does the attached menu come up? ")) (do-test "Menu: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the three items. Type meta-M. Does SEdit display in the SEdit prompt window: \"This SEdit already has a menu\"? ")) (do-test "Menu: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the entire structure. Type meta-M. Does the attached menu come up? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-menu.u.~1~ b/internal/test/env/code-editor/hand/Command-menu.u.~1~ new file mode 100644 index 00000000..bcf26eb1 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-menu.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 13, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-menu.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Menu" :before (progn (setq window-list (do-test-menu-Setup "Menu"))) :after (progn (do-test-menu-Cleanup window-list)) ;;; Since each command is tested in its own test suite, ;;; only worry about if can bring up the menu. (do-test "Menu: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Menu If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (il:dv tempx) Select Menu from the popup menu. Does the attached menu come up? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Menu: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the SEdit popup menu. If the attached menu is up, close it. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. If the attached menu is up, close it. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the \"h\" in the string \"hello\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the \"7\" in the number \"6/7\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button with the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"4.5\" in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Delete the comment. If the attached menu is up, close it. Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-m. Does the attached menu come up? ")) (do-test "Menu: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the three item. Type meta-M. Does SEdit display in the SEdit prompt window: \"This SEdit already has a menu\"? ")) (do-test "Menu: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the entire structure. Type meta-M. Does the attached menu come up? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-menu.u.~2~ b/internal/test/env/code-editor/hand/Command-menu.u.~2~ new file mode 100644 index 00000000..fda09bc4 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-menu.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 13, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-menu.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Menu" :before (progn (setq window-list (do-test-menu-Setup "Menu"))) :after (progn (do-test-menu-Cleanup window-list)) ;;; Since each command is tested in its own test suite, ;;; only worry about if can bring up the menu. (do-test "Menu: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Menu If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (il:dv tempx) Select AttachMenu from the popup menu. Does the attached menu come up? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Menu: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the SEdit popup menu. If the attached menu is up, close it. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. If the attached menu is up, close it. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the \"h\" in the string \"hello\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the \"7\" in the number \"6/7\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button with the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"4.5\" in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Delete the comment. If the attached menu is up, close it. Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-M Does the attached menu come up? ")) (do-test "Menu: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-m. Does the attached menu come up? ")) (do-test "Menu: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the three items. Type meta-M. Does SEdit display in the SEdit prompt window: \"This SEdit already has a menu\"? ")) (do-test "Menu: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-M. Does the attached menu come up? ")) (do-test "Menu: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) If the attached menu is up, close it. Select the entire structure. Type meta-M. Does the attached menu come up? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-meta-o.u b/internal/test/env/code-editor/hand/Command-meta-o.u new file mode 100644 index 00000000..413a48c3 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-meta-o.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 16, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-meta-o.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "See/Change Definition" :before (progn (setq window-list (do-test-menu-Setup "See/Change Definition"))) :after (progn (do-test-menu-Cleanup window-list)) ;;; some different things to look at: ;;; optimizers: defoptimiziers ;;; structures: defstruct ;;; setfs: defsetf define-setf-method ;;; types: deftype ;;; variable: defglobalparameter, def-blobalvar, defconstant, defparameter, defvar ;;; functions: define-modify-macro, defmacro, definline, defun, ;;; define-type: def-define-type ;;; Have AR 7699 on the next three expected responses from meta-o (do-test "See/Change Definition: no selection/no caret" (do-test-menu-Message window-list 'high " Testing See/Change Definition If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq number 3) (setq cd '(a b wer)) (setq efg '(1 2 3 4 5)) (defoptimizer temp-add-five (number) (number) (+ 5 number)) (define-modify-macro my-restf (list) cdr) (defmacro temp-double (number) `(+ ,number ,number)) (define-modify-macro my-doublef (number) my-double) (defstruct temp-silly \"silly\" sing (in 0.0) (long \"ab\") low yeast) (defun temp-double (number) (declare (optimize speed)) (* 2 number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (let ((silly-temp (make-temp-silly))) (+ (temp-add-five number) (temp-double number)))) (defun temp-garbage (x) '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (ed 'temp-call-other) Select Edit from the popup menu. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: Test get right definiton" (do-test-menu-Message window-list 'high " Testing: get the FNS definition Assuming SEdit is editing the function temp-call-other. Select \"make-temp-silly\" Type meta-O. Does the FNS definition for \"make-temp-silly\" popup in an SEdit window? ")) (do-test "See/Change Definition: Test get structures definiton" (do-test-menu-Message window-list 'high " Testing: get the structures definition Assuming SEdit is editing the function temp-call-other & make-temp-silly. Select \"temp-silly\" in the SEdit window for \"make-temp-silly\" about eight lines down the window. Type meta-O. Does the STRUCTURES definition for \"temp-silly\" popup in an SEdit window? ")) (do-test "See/Change Definition: Test get defoptimizer definiton" (do-test-menu-Message window-list 'high " Testing: get the defoptimizer definition Assuming SEdit is editing the function temp-call-other & make-temp-silly, and the structure definition for temp-silly. Close the SEdit window for temp-silly, and make-temp-silly. Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". Type meta-O. SEdit should ask \"Edit which definition of temp-add-five\". Select \"optimizers\". Did it ask and does the SEdit display in another SEdit window: \"(defoptimizer temp-add-five (number) (number) (+ 5 number))\"? ")) (do-test "See/Change Definition: Test get optimizers definiton" (do-test-menu-Message window-list 'high " Testing: get the optimizers definition Assuming SEdit is editing the function temp-call-other, and the optimizers definition for temp-add-five. Close the SEdit window for temp-add-five. Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". Type meta-O. SEdit should ask \"Edit which definition of temp-add-five\". Select \"functions\". Did it ask and does the SEdit display in another SEdit window: \"(defun temp-add-five (number) (+ 5 number))\"? ")) (do-test "See/Change Definition: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the function temp-call-other & temp-add-five. Close both windows. Type \"(ed 'temp-garbage)\" Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the function temp-garbage. Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the function temp-garbage. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-O. (If asked to select a type of dummy definition to install, pick VARS.) Does a second SEdit window pop up editing the var CD with a value of: \"(a b wer)\"? ")) (do-test "See/Change Definition: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the function temp-garbage and the variable CD. Close the SEdit window for the variable CD. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-O. Select VARIABLES, then DEFVAR Does SEdit display in the SEdit prompt window: \"\"hello\" has no VARIABLES definition.\"? ")) (do-test "See/Change Definition: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the function temp-garbage. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-O. Select OPTIMIZERS, DEFOPTIMIZER Does SEdit display in the SEdit prompt window: \"4.5 not editable.\"? ")) (do-test "See/Change Definition: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the function temp-garbage. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-O. Select DEFINE-TYPES, DEF-DEFINE-TYPE Does SEdit display in the SEdit prompt window: \"(BYE) has no DEFINE-TYPES definition.\"? ")) (do-test "See/Change Definition: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the function temp-garbage. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-O. Select FUNCTIONS, DEFUN Does SEdit display in the SEdit prompt window: \"(il:* il:\\; \" hello\") has no FUNCTIONS definition.\"? ")) (do-test "See/Change Definition: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the function temp-garbage. Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the function temp-garbage and the variable cd. Close the SEdit window for the variable \"cd\". Select the \"h\" in the string \"hello\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the function temp-garbage. Select the \"7\" in the number \"6/7\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the function temp-garbage. Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the function temp-garbage. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the function temp-garbage. Select the number \"4.5\" in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the function temp-garbage. Select the list \"(bye)\" in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the function temp-garbage. Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the function temp-garbage. Delete the comment. Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. Type meta-O Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the function temp-garbage. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-O Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the next three numbers. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the function temp-garbage. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the function temp-garbage. Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the function temp-garbage. Select the entire structure. Type meta-O. Select FNS, NLAMBDA. Does SEdit display in the SEdit prompt window: \"(defun temp-garbage (x) (quote (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (BYE) (\"hi\" b cd 4)))) not editable.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ b/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ new file mode 100644 index 00000000..22e7c106 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 16, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-meta-o.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "See/Change Definition" :before (progn (setq window-list (do-test-menu-Setup "See/Change Definition"))) :after (progn (do-test-menu-Cleanup window-list)) ;;; some different things to look at: ;;; optimizers: defoptimiziers ;;; structures: defstruct ;;; setfs: defsetf define-setf-method ;;; types: deftype ;;; variable: defglobalparameter, def-blobalvar, defconstant, defparameter, defvar ;;; functions: define-modify-macro, defmacro, definline, defun, ;;; define-type: def-define-type ;;; Have AR 7699 on the next three expected responses from meta-o (do-test "See/Change Definition: no selection/no caret" (do-test-menu-Message window-list 'high " Testing See/Change Definition If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq number 3) (setq cd '(a b wer)) (setq efg '(1 2 3 4 5)) (defoptimizer temp-add-five (number) (number) (+ 5 number)) (define-modify-macro my-restf (list) cdr) (defmacro temp-double (number) `(+ ,number ,number)) (define-modify-macro my-doublef (number) my-double) (defstruct temp-silly \"silly\" sing (in 0.0) (long \"ab\") low yeast) (defun temp-double (number) (declare (optimize speed)) (* 2 number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (let ((silly-temp (make-temp-silly))) (+ (temp-add-five number) (temp-double number)))) (defun temp-garbage (x) '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (ed 'temp-call-other) Select Edit from the popup menu. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: Test get right definiton" (do-test-menu-Message window-list 'high " Testing: get the FNS definition Assumping SEdit is editing the function temp-call-other. Select \"make-temp-silly\" Type meta-O. Does the FNS definition for \"make-temp-silly\" popup in an SEdit window? ")) (do-test "See/Change Definition: Test get structures definiton" (do-test-menu-Message window-list 'high " Testing: get the structures definition Assumping SEdit is editing the function temp-call-other & make-temp-silly. Select \"temp-silly\" in the SEdit window for \"make-temp-silly\" about eight lines down the window. Type meta-O. Does the STRUCTURES definition for \"temp-silly\" popup in an SEdit window? ")) (do-test "See/Change Definition: Test get defoptimizer definiton" (do-test-menu-Message window-list 'high " Testing: get the defoptimizer definition Assumping SEdit is editing the function temp-call-other & make-temp-silly, and the structure definition for temp-silly. Close the SEdit window for temp-silly, and make-temp-silly. Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". Type meta-O. SEdit should ask \"Edit which definition of temp-add-five\". Select \"optimizes\". Did it ask and does the SEdit display in another SEdit window: \"(defoptimizer temp-add-five (number) (number) (+ 5 number))\"? ")) (do-test "See/Change Definition: Test get optimizers definiton" (do-test-menu-Message window-list 'high " Testing: get the optimizers definition Assumping SEdit is editing the function temp-call-other, and the optimizers definition for temp-add-five. Close the SEdit window for temp-add-five. Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". Type meta-O. SEdit should ask \"Edit which definition of temp-add-five\". Select \"functions\". Did it ask and does the SEdit display in another SEdit window: \"(defun temp-add-five (number) (+ 5 number))\"? ")) (do-test "See/Change Definition: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the function temp-call-other & temp-add-five. Close both windows. Type \"(ed 'temp-garbage)\" Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the function temp-garbage. Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the function temp-garbage. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-O. (If asked to select a type of dummy definition to install, pick VARS.) Does a second SEdit window pop up editing the var CD with a value o: \"(a b wer)\"? ")) (do-test "See/Change Definition: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the function temp-garbage and the veariable CD. Close the SEdit window for the variable CD. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-O. Select VARIABLE, then DEFVAR Does SEdit display in the SEdit prompt window: \"\"hello\" not editable.\"? ")) (do-test "See/Change Definition: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the function temp-garbage. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-O. Select OPTIMIZERS, DEFOPTIMIZER Does SEdit display in the SEdit prompt window: \"4.5 not editable.\"? ")) (do-test "See/Change Definition: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the function temp-garbage. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-O. Select DEFINE-TYPES, DEF-DEFINE-TYPE Does SEdit display in the SEdit prompt window: \"(bye) not editable.\"? ")) (do-test "See/Change Definition: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the function temp-garbage. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-O. Select FUNCTIONS, DEFUN Does SEdit display in the SEdit prompt window: \"(il:* il:\\; \" hello\") not editable.\"? ")) (do-test "See/Change Definition: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the function temp-garbage. Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the function temp-garbage and the variable cd. Close the SEdit window for the variable \"cd\". Select the \"h\" in the string \"hello\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the function temp-garbage. Select the \"7\" in the number \"6/7\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the function temp-garbage. Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the function temp-garbage and the variable efg. Close the SEdit window for efg. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the function temp-garbage. Select the number \"4.5\" in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the function temp-garbage. Select the list \"(bye)\" in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assumping SEdit is editing the function temp-garbage. Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the function temp-garbage. Delete the comment. Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. Type meta-O Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the function temp-garbage. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-O Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the next three numbers. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the function temp-garbage. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the function temp-garbage. Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the function temp-garbage. Select the entire structure. Type meta-O. Select FNS, NLAMBDA. Does SEdit display in the SEdit prompt window: \"(defun temp-garbage (x) (quote (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (BYE) (\"hi\" b cd 4)))) not editable.\"? ")) ;;; After testing the enter points test the command some. (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ b/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ new file mode 100644 index 00000000..413a48c3 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 16, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-meta-o.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "See/Change Definition" :before (progn (setq window-list (do-test-menu-Setup "See/Change Definition"))) :after (progn (do-test-menu-Cleanup window-list)) ;;; some different things to look at: ;;; optimizers: defoptimiziers ;;; structures: defstruct ;;; setfs: defsetf define-setf-method ;;; types: deftype ;;; variable: defglobalparameter, def-blobalvar, defconstant, defparameter, defvar ;;; functions: define-modify-macro, defmacro, definline, defun, ;;; define-type: def-define-type ;;; Have AR 7699 on the next three expected responses from meta-o (do-test "See/Change Definition: no selection/no caret" (do-test-menu-Message window-list 'high " Testing See/Change Definition If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq number 3) (setq cd '(a b wer)) (setq efg '(1 2 3 4 5)) (defoptimizer temp-add-five (number) (number) (+ 5 number)) (define-modify-macro my-restf (list) cdr) (defmacro temp-double (number) `(+ ,number ,number)) (define-modify-macro my-doublef (number) my-double) (defstruct temp-silly \"silly\" sing (in 0.0) (long \"ab\") low yeast) (defun temp-double (number) (declare (optimize speed)) (* 2 number)) (defun temp-add-five (number) (+ 5 number)) (defun temp-call-other (number) (let ((silly-temp (make-temp-silly))) (+ (temp-add-five number) (temp-double number)))) (defun temp-garbage (x) '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (ed 'temp-call-other) Select Edit from the popup menu. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: Test get right definiton" (do-test-menu-Message window-list 'high " Testing: get the FNS definition Assuming SEdit is editing the function temp-call-other. Select \"make-temp-silly\" Type meta-O. Does the FNS definition for \"make-temp-silly\" popup in an SEdit window? ")) (do-test "See/Change Definition: Test get structures definiton" (do-test-menu-Message window-list 'high " Testing: get the structures definition Assuming SEdit is editing the function temp-call-other & make-temp-silly. Select \"temp-silly\" in the SEdit window for \"make-temp-silly\" about eight lines down the window. Type meta-O. Does the STRUCTURES definition for \"temp-silly\" popup in an SEdit window? ")) (do-test "See/Change Definition: Test get defoptimizer definiton" (do-test-menu-Message window-list 'high " Testing: get the defoptimizer definition Assuming SEdit is editing the function temp-call-other & make-temp-silly, and the structure definition for temp-silly. Close the SEdit window for temp-silly, and make-temp-silly. Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". Type meta-O. SEdit should ask \"Edit which definition of temp-add-five\". Select \"optimizers\". Did it ask and does the SEdit display in another SEdit window: \"(defoptimizer temp-add-five (number) (number) (+ 5 number))\"? ")) (do-test "See/Change Definition: Test get optimizers definiton" (do-test-menu-Message window-list 'high " Testing: get the optimizers definition Assuming SEdit is editing the function temp-call-other, and the optimizers definition for temp-add-five. Close the SEdit window for temp-add-five. Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". Type meta-O. SEdit should ask \"Edit which definition of temp-add-five\". Select \"functions\". Did it ask and does the SEdit display in another SEdit window: \"(defun temp-add-five (number) (+ 5 number))\"? ")) (do-test "See/Change Definition: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the function temp-call-other & temp-add-five. Close both windows. Type \"(ed 'temp-garbage)\" Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the function temp-garbage. Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the function temp-garbage. Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-O. (If asked to select a type of dummy definition to install, pick VARS.) Does a second SEdit window pop up editing the var CD with a value of: \"(a b wer)\"? ")) (do-test "See/Change Definition: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the function temp-garbage and the variable CD. Close the SEdit window for the variable CD. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-O. Select VARIABLES, then DEFVAR Does SEdit display in the SEdit prompt window: \"\"hello\" has no VARIABLES definition.\"? ")) (do-test "See/Change Definition: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the function temp-garbage. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-O. Select OPTIMIZERS, DEFOPTIMIZER Does SEdit display in the SEdit prompt window: \"4.5 not editable.\"? ")) (do-test "See/Change Definition: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the function temp-garbage. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-O. Select DEFINE-TYPES, DEF-DEFINE-TYPE Does SEdit display in the SEdit prompt window: \"(BYE) has no DEFINE-TYPES definition.\"? ")) (do-test "See/Change Definition: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the function temp-garbage. Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-O. Select FUNCTIONS, DEFUN Does SEdit display in the SEdit prompt window: \"(il:* il:\\; \" hello\") has no FUNCTIONS definition.\"? ")) (do-test "See/Change Definition: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the function temp-garbage. Select the comment as a structure and press the delete key. Type control-x. Select the \"d\" in the first litatom \"cd\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the function temp-garbage and the variable cd. Close the SEdit window for the variable \"cd\". Select the \"h\" in the string \"hello\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the function temp-garbage. Select the \"7\" in the number \"6/7\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the function temp-garbage. Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the function temp-garbage. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete a number" (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the function temp-garbage. Select the number \"4.5\" in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the function temp-garbage. Select the list \"(bye)\" in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: pending delete of a comment" (do-test-menu-Message window-list 'low " Testing: pending delete of a comment Assuming SEdit is editing the function temp-garbage. Place the structure caret the number \"1\". Type in \"; hello\" Select the comment in pending delete mode. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the function temp-garbage. Delete the comment. Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. Type meta-O Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the function temp-garbage. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-O Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the next three numbers. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the function temp-garbage. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the next seven items. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the function temp-garbage. Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the function temp-garbage. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-O. Does SEdit display in the SEdit prompt window: \"Select name of object to edit.\"? ")) (do-test "See/Change Definition: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the function temp-garbage. Select the entire structure. Type meta-O. Select FNS, NLAMBDA. Does SEdit display in the SEdit prompt window: \"(defun temp-garbage (x) (quote (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (BYE) (\"hi\" b cd 4)))) not editable.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-mutate.u b/internal/test/env/code-editor/hand/Command-mutate.u new file mode 100644 index 00000000..a9c3a877 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-mutate.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-mutate.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Mutate" :before (progn (setq window-list (do-test-menu-Setup "Mutate"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Mutate: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Mutate If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (defun temp-double (number) (* 2 number)) (defun temp-build-string (string) (concatenate 'string string \" more\")) (defun temp-car (list) (car list)) (defun temp-return-value () '(a list)) (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Mutate from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-Z. Enter \"temp-return-value\". Does SEdit display in the SEdit prompt window: \"Error during mutation. No changes made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-Z. Enter \"temp-build-string\". Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello more" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello more\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-Z. Enter \"temp-double\" Were you able to get this far? ")) (good-value (equal '(1 9.0 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-Z. Enter \"temp-car\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) Type meta-U. Select the \"d\" in the first litatom \"cd\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-Z Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-Z Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate\"? ")) (do-test "Mutate: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-Z. Enter \"temp-car\" Were you able to get this far? ")) (good-value (equal 1 tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the entire structure in pending delete mode. Type meta-z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-mutate.u.~1~ b/internal/test/env/code-editor/hand/Command-mutate.u.~1~ new file mode 100644 index 00000000..cd7d7963 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-mutate.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-mutate.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Mutate" :before (progn (setq window-list (do-test-menu-Setup "Mutate"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Mutate: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Mutate If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (defun temp-double (number) (* 2 number)) (defun temp-build-string (string) (concatenate 'string string \" more\")) (defun temp-car (list) (car list)) (defun temp-return-value () '(a list)) (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Mutate from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-Z. Enter \"temp-return-value\". Does SEdit display in the SEdit prompt window: \"Error during mutation. No changes made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-Z. Enter \"temp-build-string\". Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello more" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello more\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-Z. Enter \"temp-double\" Were you able to get this far? ")) (good-value (equal '(1 9.0 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-Z. Enter \"temp-car\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) Type meta-U. Select the \"d\" in the first litatom \"cd\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-Z Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-Z Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate\"? ")) (do-test "Mutate: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-Z. Enter \"temp-car\" Were you able to get this far? ")) (good-value (equal 1 tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the entire structure in pending delete mode. Type meta-z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-mutate.u.~2~ b/internal/test/env/code-editor/hand/Command-mutate.u.~2~ new file mode 100644 index 00000000..a9c3a877 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-mutate.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-mutate.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Mutate" :before (progn (setq window-list (do-test-menu-Setup "Mutate"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Mutate: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Mutate If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (defun temp-double (number) (* 2 number)) (defun temp-build-string (string) (concatenate 'string string \" more\")) (defun temp-car (list) (car list)) (defun temp-return-value () '(a list)) (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Mutate from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-Z. Enter \"temp-return-value\". Does SEdit display in the SEdit prompt window: \"Error during mutation. No changes made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-Z. Enter \"temp-build-string\". Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello more" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello more\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-Z. Enter \"temp-double\" Were you able to get this far? ")) (good-value (equal '(1 9.0 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-Z. Enter \"temp-car\" Were you able to get this far? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) Type meta-U. Select the \"d\" in the first litatom \"cd\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-Z Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-Z Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate\"? ")) (do-test "Mutate: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-Z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Mutate: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-Z. Enter \"temp-car\" Were you able to get this far? ")) (good-value (equal 1 tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Mutate: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the entire structure in pending delete mode. Type meta-z. Does SEdit display in the SEdit prompt window: \"Select whole structure to mutate.\"? ")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-paren.u b/internal/test/env/code-editor/hand/Command-paren.u new file mode 100644 index 00000000..b1839035 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-paren.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 5, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>SEdit-command-low-paren.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Parenthesize current selection" :before (progn (setq window-list (do-test-menu-Setup "Parenthesize"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Parenthesize: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4))) (il:dv tempx) Type meta-(. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-(. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-(. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the litatom \"ab\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-). Is the litatom AB now parenthesized?")) (good-value (equal '(1 23 (ab) cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing tempx which currently equals (1 23 (ab) cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the string \"how\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-). Is the string \"how\" now parenthesized?")) (good-value (equal '(1 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing tempx which currently equals (1 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. Select PARENTHESIZE from the popup menu. Is the number \"1\" now parenthesized?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the list (\"hi\" \"bye\" a 23 4) as a structure. Type meta-9, and then control-x. Is the list now parenthesized?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the edit caret after the number 23 and type \"; hello\", then select this as a structure, and type meta-0. Check to see if it has parenthesis around it, then select Abort from the pop-up menu, clicking the left button to confirm the abort. Was the parenthesis around the comment?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming tempx currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Type: \"(il:dv tempx)\" Select the \"d\" in the litatom \"cd\" and type meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Select the \"h\" in the string \"how\" and type meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Select the \"2\" in the number \"23\" and type meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the edit caret after the litatom \"ab\" with in the list. Type \" ef\", then control-W and meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the structure caret after the string \"hi\" with in the list. Type a double quote, and then the word \"there\", put the structure caret right after this string, and type control-W and meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the edit caret right after the number \"23\" with no selection. Type control-W, and meta-(, control-x. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the structure caret right after the list \"((\"hi\" \"bye\" a 23 4))\" with no selection. Type control-W, and meta-(, control-x. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key and type meta-(, control-x. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") Place the edit caret after the litatom \"cd\". Type \" ef gh\". Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-(. Are the three litatoms now parenthesized?")) (good-value (equal '((1) (ab) (cd ef gh) ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") \"are\" \"you\") Select the string \"are\" as a structure, and extend the selection to include the next string. Type meta-(. Are the two strings now parenthesized?")) (good-value (equal '((1) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) Place the structure caret after the list \"(1)\". Type \" 2 3 4\". Now select the number \"2\" as a structure, and extend the selection to include the next two numbers. Type meta-). Are the three numbers now parenthesized?")) (good-value (equal '((1) (2 3 4) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing tempx which currently equals ((1) (2 3 4) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) Select the list \"(2 3 4)\" as a structure, and extend the selection to include the next two lists. Type meta-). Are the three lists now parenthesized?")) (good-value (equal '((1) ((2 3 4) (ab) (cd ef gh)) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing tempx which currently equals ((1) ((2 3 4) (ab) (cd ef gh)) (\"how\") (\"are\" \"you\")) Select the list \"((2 3 4) (ab) (cd ef gh))\" as a structure and press the delete key. Now type \" ab 23 cd 45\" Select the litatom \"ab\" as a structure, and extend the selection to include the next three items. Type meta-). Is the selection now parenthesized?")) (good-value (equal '((1) (ab 23 cd 45) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing tempx which currently equals ((1) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) Place the structure caret after the list \"(1)\". Type \" (hi) \"hi\" (bye) \"bye\" (list-string)\" Select the list \"(hi)\" as a structure, and extend the selection to include the next four items. Select Parenthesize from the popup menu. Is the selection now parenthesized?")) (good-value (equal '((1) ((hi) "hi" (bye) "bye" (list-string)) (ab 23 cd 45) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing tempx which currently equals ((1) ((hi) \"hi\" (bye) \"bye\" (list-string)) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) Select the second list as a structure, extend the select to include the rest of the items, and press the delete key. Type \"23 a-litatom 45 \"hi\" bye (my small list)\" Select the number \"23\" as a structure, and extend the selection to include the next five items. Select Parenthesize from the popup menu. Is the selection now parenthesized?")) (good-value (equal '((1) (23 a-litatom 45 "hi" bye (my small list))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low "Assuming SEdit is editing tempx which currently equals ((1) (23 a-litatom 45 \"hi\" bye (my small list))) Testing: selection of entire structure Select the entire structure. Select Parenthesize from the popup menu. Is the entire structure inside an extra set of parentheses?")) (good-value (equal '(((1) (23 a-litatom 45 "hi" bye (my small list)))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: clean-up" (let* ((user-result (do-test-menu-Message window-list 'low "Close the SEdit window."))) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-paren.u.~1~ b/internal/test/env/code-editor/hand/Command-paren.u.~1~ new file mode 100644 index 00000000..6f5f873d --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-paren.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 5, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>SEdit-command-low-paren.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Parenthesize current selection" :before (progn (setq window-list (do-test-menu-Setup "Parenthesize"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Parenthesize: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4))) (il:dv tempx) Type meta-(. Were you able to get this far?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Testing: no selection/edit caret Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-(. Were you able to get this far?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Testing: no selection/structure caret Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-(. Were you able to get this far?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Testing: select a litatom Select the litatom \"ab\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-). Were you able to get this far?")) (good-value (equal '(1 23 (ab) cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (1 23 (ab) cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Testing: select a string Select the string \"how\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-). Were you able to get this far?")) (good-value (equal '(1 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (1 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Testing: select a number Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. Select PAREN from the popup menu. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a list" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Testing: select a list Select the list (\"hi\" \"bye\" a 23 4) as a structure. Type meta-9, and then control-x. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: select a comment Place the edit caret after the number 23 and type \"; hello\", then select this as a structure, and type meta-0. Check to see if it has parenthesis around it, then select Abort from the pop-up menu. Was the parenthesis around the comment?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: select part of a litatom Type: \"(il:dv tempx)\" Select the \"d\" in the litatom \"cd\" and type meta-0. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: select part of a string Select the \"h\" in the string \"how\" and type meta-0. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: select part of a number Select the \"2\" in the number \"23\" and type meta-0. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: try after deleting a litatom Place the edit caret after the litatom \"ab\" with in the list. Type \" ef\", then control-W and meta-0. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: try after deleting a string Place the structure caret after the string \"hi\" with in the list. Type a double quote, and then the word \"there\", put the structure caret right after this string, and type control-W and meta-0. Were you able to get this far?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: try after deleting a number Place the edit caret right after the number \"23\" with no selection. Type control-W, and meta-(, control-x. Were you able to get this far?")) (good-value (equal '((1) (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Testing: try after deleting a number Place the structure caret right after the list \"((\"hi\" \"bye\" a 23 4))\" with no selection. Type control-W, and meta-(, control-x. Were you able to get this far?")) (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") Testing: try after deleting a comment Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key and type meta-(, control-x. Were you able to get this far?")) (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") Testing: try extended selection of litatoms Place the edit caret after the litatom \"cd\". Type \" ef gh\". Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-(. Were you able to get this far?")) (good-value (equal '((1) (ab) (cd ef gh) ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") \"are\" \"you\") Testing: extended selection of strings Select the string \"are\" as a structure, and extend the selection to include the next string. Type meta-(. Were you able to get this far?")) (good-value (equal '((1) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) Testing: extended selection of numbers Place the structure caret after the list \"(1)\". Type \" 2 3 4\". Now select the number \"2\" as a structure, and extend the selection to include the next two numbers. Type meta-). Were you able to get this far?")) (good-value (equal '((1) (2 3 4) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (2 3 4) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) Testing: extended selection of lists Select the list \"(2 3 4)\" as a structure, and extend the selection to include the next two lists. Type meta-). Were you able to get this far?")) (good-value (equal '((1) ((2 3 4) (ab) (cd ef gh)) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) ((2 3 4) (ab) (cd ef gh)) (\"how\") (\"are\" \"you\")) Testing: extended selection of litatoms and numbers Select the list \"((2 3 4) (ab) (cd ef gh))\" as a structure and press the delete key. Now type \" ab 23 cd 45\" Select the litatom \"ab\" as a structure, and extend the selection to include the next three items. Type meta-). Were you able to get this far?")) (good-value (equal '((1) (ab 23 cd 45) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) Testing: extended selection of strings and lists Place the structure caret after the list \"(1)\". Type \" (hi) \"hi\" (bye) \"bye\" (list-string)\" Select the list \"(hi)\" as a structure, and extend the selection to include the next four items. Select Paren from the popup menu. Were you able to get this far?")) (good-value (equal '((1) ((hi) "hi" (bye) "bye" (list-string)) (ab 23 cd 45) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) ((hi) \"hi\" (bye) \"bye\" (list-string)) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) Testing: extended selection of several things Select the second list as a structure, extend the select to include the rest of the items, and press the delete key. Type \"23 a-litatom 45 \"hi\" bye (my small list)\" Select the number \"23\" as a structure, and extend the selection to include the next six items. Select Paren from the popup menu. Were you able to get this far?")) (good-value (equal '((1) (23 a-litatom 45 "hi" bye (my small list))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals ((1) (23 a-litatom 45 \"hi\" bye (my small list))) Testing: selection of entire structure Select the entire structure. Select Paren from the popup menu. Were you able to get this far?")) (good-value (equal '(((1) (23 a-litatom 45 "hi" bye (my small list)))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-paren.u.~2~ b/internal/test/env/code-editor/hand/Command-paren.u.~2~ new file mode 100644 index 00000000..b1839035 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-paren.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 5, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>SEdit-command-low-paren.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Parenthesize current selection" :before (progn (setq window-list (do-test-menu-Setup "Parenthesize"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Parenthesize: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4))) (il:dv tempx) Type meta-(. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-(. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-(. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the litatom \"ab\" as a structure, by pressing the middle button with the cursor over the litatom. Type meta-). Is the litatom AB now parenthesized?")) (good-value (equal '(1 23 (ab) cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing tempx which currently equals (1 23 (ab) cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the string \"how\" as a structure, by pressing the middle button, with the cursor over the string. Type meta-). Is the string \"how\" now parenthesized?")) (good-value (equal '(1 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing tempx which currently equals (1 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. Select PARENTHESIZE from the popup menu. Is the number \"1\" now parenthesized?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) Select the list (\"hi\" \"bye\" a 23 4) as a structure. Type meta-9, and then control-x. Is the list now parenthesized?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the edit caret after the number 23 and type \"; hello\", then select this as a structure, and type meta-0. Check to see if it has parenthesis around it, then select Abort from the pop-up menu, clicking the left button to confirm the abort. Was the parenthesis around the comment?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming tempx currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Type: \"(il:dv tempx)\" Select the \"d\" in the litatom \"cd\" and type meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Select the \"h\" in the string \"how\" and type meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Select the \"2\" in the number \"23\" and type meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a litatom Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the edit caret after the litatom \"ab\" with in the list. Type \" ef\", then control-W and meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a string Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the structure caret after the string \"hi\" with in the list. Type a double quote, and then the word \"there\", put the structure caret right after this string, and type control-W and meta-0. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a number Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the edit caret right after the number \"23\" with no selection. Type control-W, and meta-(, control-x. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a list Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) Place the structure caret right after the list \"((\"hi\" \"bye\" a 23 4))\" with no selection. Type control-W, and meta-(, control-x. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: delete a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try after deleting a comment Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. Press the delete key and type meta-(, control-x. Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") Place the edit caret after the litatom \"cd\". Type \" ef gh\". Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. Type meta-(. Are the three litatoms now parenthesized?")) (good-value (equal '((1) (ab) (cd ef gh) ("how") "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") \"are\" \"you\") Select the string \"are\" as a structure, and extend the selection to include the next string. Type meta-(. Are the two strings now parenthesized?")) (good-value (equal '((1) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) Place the structure caret after the list \"(1)\". Type \" 2 3 4\". Now select the number \"2\" as a structure, and extend the selection to include the next two numbers. Type meta-). Are the three numbers now parenthesized?")) (good-value (equal '((1) (2 3 4) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing tempx which currently equals ((1) (2 3 4) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) Select the list \"(2 3 4)\" as a structure, and extend the selection to include the next two lists. Type meta-). Are the three lists now parenthesized?")) (good-value (equal '((1) ((2 3 4) (ab) (cd ef gh)) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing tempx which currently equals ((1) ((2 3 4) (ab) (cd ef gh)) (\"how\") (\"are\" \"you\")) Select the list \"((2 3 4) (ab) (cd ef gh))\" as a structure and press the delete key. Now type \" ab 23 cd 45\" Select the litatom \"ab\" as a structure, and extend the selection to include the next three items. Type meta-). Is the selection now parenthesized?")) (good-value (equal '((1) (ab 23 cd 45) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing tempx which currently equals ((1) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) Place the structure caret after the list \"(1)\". Type \" (hi) \"hi\" (bye) \"bye\" (list-string)\" Select the list \"(hi)\" as a structure, and extend the selection to include the next four items. Select Parenthesize from the popup menu. Is the selection now parenthesized?")) (good-value (equal '((1) ((hi) "hi" (bye) "bye" (list-string)) (ab 23 cd 45) ("how") ("are" "you")) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing tempx which currently equals ((1) ((hi) \"hi\" (bye) \"bye\" (list-string)) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) Select the second list as a structure, extend the select to include the rest of the items, and press the delete key. Type \"23 a-litatom 45 \"hi\" bye (my small list)\" Select the number \"23\" as a structure, and extend the selection to include the next five items. Select Parenthesize from the popup menu. Is the selection now parenthesized?")) (good-value (equal '((1) (23 a-litatom 45 "hi" bye (my small list))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low "Assuming SEdit is editing tempx which currently equals ((1) (23 a-litatom 45 \"hi\" bye (my small list))) Testing: selection of entire structure Select the entire structure. Select Parenthesize from the popup menu. Is the entire structure inside an extra set of parentheses?")) (good-value (equal '(((1) (23 a-litatom 45 "hi" bye (my small list)))) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Parenthesize: clean-up" (let* ((user-result (do-test-menu-Message window-list 'low "Close the SEdit window."))) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-substitute.u b/internal/test/env/code-editor/hand/Command-substitute.u new file mode 100644 index 00000000..feaf3c4f --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-substitute.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 21, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-substitute.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Substitute" :before (progn (setq window-list (do-test-menu-Setup "Substitute"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Substitute: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Substitute If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Substitute from the pop up menu. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-S. Enter the litatom \"cd\" then the litatom \"cde\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cde efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cde efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-S. Enter the string \"hello\" (with quotes) then the string \"HELLO\" (with quotes). Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "HELLO" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"HELLO\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-S. Enter the number \"4.5\" then the number \"5.4\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 5.4 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 5.4 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-S. Enter the list \"(bye)\" then the list \"(bye now)\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye now) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye now) (\"hi\" (b) cd 4)) Type meta-U. Select the \"d\" in the first litatom \"cd\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-S. First enter the litatom \"efg\" then the number \"999\". Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd 999 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd 999 \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-S. First enter the string \"hello\" (with quotes) then the litatom \"we-2\" (without quotes). Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg we-2 "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" in pending delete mode. Type meta-S. Enter the number \"4.5\", then the list \"(a b c d)\". Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 (a b c d) 6/7 a cd efg "hello" "BYE" (bye) ("hi" ;(b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" in pending delete mode. Type meta-S. Enter the list \"(bye)\", then the number \"2\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" 2 ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" 2 (\"hi\" (b) cd 4)) Type meta-U. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-S Enter the litatom \"a\", then the string \"Wedding song\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 "Wedding song" cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 \"Wedding song\" cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-S First enter the string \"hello\", then the number \"12\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg 12 "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg 12 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-S. First enter the number \"6/7\", then the list \"(56 65)\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 (56 65) a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 (56 65) a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-S. First enter the list \"(b)\", then the litatom \"bcd\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" bcd cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" bcd cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-S. First enter the number \"1\", then the litatom \"qw\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(qw 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (qw 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-S. First enter the string \"BYE\", then the number \"7878\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" 7878 (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" 7878 (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-S. First enter the litatom \"cd\", then the litatom \"gh\" Does SEdit display in the SEdit prompt window: \"2 substitutions made.\"? ")) (good-value (equal '(1 4.5 6/7 a gh efg "hello" "BYE" (bye) ("hi" (b) gh 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a gh efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Type meta-U. Select the entire structure. Type meta-S. First enter the string \"Should not change value\", then the litatom \"not-there\" Does SEdit display in the SEdit prompt window: \"No substitutions made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: Pending delete of whole structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the entire structure in pending delete mode. Type meta-m. Enter the number 4 in the FIND field. and the number 5 in the SUBSTITUTE field. Pick the substitute command on the attached menu. Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 5)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting EXIT from the attached menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-substitute.u.~1~ b/internal/test/env/code-editor/hand/Command-substitute.u.~1~ new file mode 100644 index 00000000..00bebe90 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-substitute.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 21, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-substitute.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Substitute" :before (progn (setq window-list (do-test-menu-Setup "Substitute"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Substitute: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Substitute If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Substitute from the pop up menu. Does SEdit display in the SEdit prompt window: \"Select structure to substitue within.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-S. Does SEdit display in the SEdit prompt window: \"Select structure to substitute within.\"? ")) (do-test "Substitute: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-S. Does SEdit display in the SEdit prompt window: \"Select structure to substitute within.\"? ")) (do-test "Substitute: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-S. Enter the litatom \"cd\" then the litatom \"cde\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cde efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cde efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-S. Enter the string \"hello\" then the string \"HELLO\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "HELLO" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"HELLO\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-S. Enter the number \"4.5\" then the number \"5.4\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 5.4 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 5.4 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-S. Enter the list \"(bye)\" then the list \"(bye now)\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye now) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye now) (\"hi\" (b) cd 4)) Type meta-U. Select the \"d\" in the first litatom \"cd\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Select structure to substitue within.\"? ")) (do-test "Substitute: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Select structure to substitue within.\"? ")) (do-test "Substitute: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Select structure to substitue within.\"? ")) (do-test "Substitute: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-S. First enter the litatom \"efg\" then the number \"999\". Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd 999 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd 999 \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-S. First enter the string \"hello\" then the litatom \"we-2\". Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg we-2 "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ;Have an AR on this ;(do-test "Substitute: pending delete a number" ; (let* ((user-result (do-test-menu-Message window-list 'low ;" Testing: pending delete of a number ;Assumping SEdit is editing the variable tempx which currently equals: ; (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) ;Type meta-U. ;Select the number \"4.5\" in pending delete mode. ;Type meta-S. ;Enter the number \"4.5\", then the list \"(a b c d)\". ;Does SEdit display in the SEdit prompt window: ; \"Select structure to extract.\"? ")) ; (good-value (equal '(1 (a b c d) 6/7 a cd efg "hello" "BYE" (bye) ("hi" ;(b) cd 4)) tempx))) ; (and user-result (if (eq t user-result) good-value T)) ; )) (do-test "Substitute: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" in pending delete mode. Type meta-S. Enter the list \"(bye)\", then the number \"2\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" 2 ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" 2 (\"hi\" (b) cd 4)) Type meta-U. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-S Enter the litatom \"a\", then the string \"Wedding song\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 "Wedding song" cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 \"Wedding song\" cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-S First enter the string \"hello\", then the number \"12\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg 12 "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg 12 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-S. First enter the number \"6/7\", then the list \"(56 65)\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 (56 65) a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 (56 65) a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-S. First enter the list \"(b)\", then the litatom \"bcd\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" bcd cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" bcd cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-S. First enter the number \"1\", then the litatom \"qw\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(qw 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (qw 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-S. First enter the string \"BYE\", then the number \"7878\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" 7878 (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" 7878 (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-S. First enter the litatom \"cd\", then the litatom \"gh\" Does SEdit display in the SEdit prompt window: \"2 substitutions made.\"? ")) (good-value (equal '(1 4.5 6/7 a gh efg "hello" "BYE" (bye) ("hi" (b) gh 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a gh efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Type meta-U. Select the entire structure. Type meta-S. First enter the string \"Should not change value\", then the litatom \"not-there\" Does SEdit display in the SEdit prompt window: \"No substitutions made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: Pending delete of whole structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the entire structure in pending delete mode. Type meta-m. Enter the number 4 in the FIND field. and the number 5 in the SUBSTITUE field. Pick the substitute command on the attached menu. Does SEdit display in the SEdit prompt window: \"Select structure to extract.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 5)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-substitute.u.~2~ b/internal/test/env/code-editor/hand/Command-substitute.u.~2~ new file mode 100644 index 00000000..feaf3c4f --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-substitute.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 21, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-substitute.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Substitute" :before (progn (setq window-list (do-test-menu-Setup "Substitute"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Substitute: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Substitute If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (il:dv tempx) Select Substitute from the pop up menu. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-S. Enter the litatom \"cd\" then the litatom \"cde\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cde efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cde efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-S. Enter the string \"hello\" (with quotes) then the string \"HELLO\" (with quotes). Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "HELLO" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"HELLO\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-S. Enter the number \"4.5\" then the number \"5.4\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 5.4 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 5.4 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-S. Enter the list \"(bye)\" then the list \"(bye now)\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye now) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye now) (\"hi\" (b) cd 4)) Type meta-U. Select the \"d\" in the first litatom \"cd\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-S. Does SEdit display in the SEdit prompt window: \"Please select a structure to substitute within.\"? ")) (do-test "Substitute: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-S. First enter the litatom \"efg\" then the number \"999\". Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd 999 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd 999 \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-S. First enter the string \"hello\" (with quotes) then the litatom \"we-2\" (without quotes). Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg we-2 "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"4.5\" in pending delete mode. Type meta-S. Enter the number \"4.5\", then the list \"(a b c d)\". Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 (a b c d) 6/7 a cd efg "hello" "BYE" (bye) ("hi" ;(b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" in pending delete mode. Type meta-S. Enter the list \"(bye)\", then the number \"2\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" 2 ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" 2 (\"hi\" (b) cd 4)) Type meta-U. Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-S Enter the litatom \"a\", then the string \"Wedding song\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 "Wedding song" cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 \"Wedding song\" cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-S First enter the string \"hello\", then the number \"12\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg 12 "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg 12 \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-S. First enter the number \"6/7\", then the list \"(56 65)\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 (56 65) a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 (56 65) a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-S. First enter the list \"(b)\", then the litatom \"bcd\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" bcd cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" bcd cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-S. First enter the number \"1\", then the litatom \"qw\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(qw 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (qw 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-S. First enter the string \"BYE\", then the number \"7878\" Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" 7878 (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" 7878 (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-S. First enter the litatom \"cd\", then the litatom \"gh\" Does SEdit display in the SEdit prompt window: \"2 substitutions made.\"? ")) (good-value (equal '(1 4.5 6/7 a gh efg "hello" "BYE" (bye) ("hi" (b) gh 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a gh efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Type meta-U. Select the entire structure. Type meta-S. First enter the string \"Should not change value\", then the litatom \"not-there\" Does SEdit display in the SEdit prompt window: \"No substitutions made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Substitute: Pending delete of whole structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Type meta-U. Select the entire structure in pending delete mode. Type meta-m. Enter the number 4 in the FIND field. and the number 5 in the SUBSTITUTE field. Pick the substitute command on the attached menu. Does SEdit display in the SEdit prompt window: \"1 substitution made.\"? ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 5)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting EXIT from the attached menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-undo-redo.u b/internal/test/env/code-editor/hand/Command-undo-redo.u new file mode 100644 index 00000000..ab6032e2 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-undo-redo.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-undo-redo.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Undo/Redo" :before (progn (setq window-list (do-test-menu-Setup "Undo/Redo"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Undo: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Undo If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (ed 'tempx) Select Undo from the popup menu. Does it respond with: \"Nothing to Undo\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/no caret" (do-test-menu-Message window-list 'high " Testing Redo Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the popup menu. Select Redo from the popup menu. Does it respond with: \"No Undo to Undo\"? ")) (do-test "Undo: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" and press the delete key. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the structure caret between \"b\" and \"cd\". Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the third litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the fourth litatom \"efg\" as a structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure. Type meta-R. Select the string \"BYE\" and press the delete key. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-U three times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 2 and type \"; bye\", then select this as a structure. Type meta-R. Does SEdit display in the SEdit prompt window: \"No Undo to Undo\"? ")) (do-test "Undo: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 ; bye 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Place the strcuture caret after the litatom \"efg\" Type: \"(Have a nice day please)\" Select the \"d\" in the first litatom \"cd\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"f\" in the litatom \"efg\". Type meta-R twice. Does SEdit display in the SEdit prompt window: \"No Undo to Undo.\"? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-U three times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"B\" in the string \"BYE\". Type meta-R twice. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-U four times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"6\" in the number \"6/7\". Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"cd\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"c\" and then pressing the right button withe the cursor on the \"d\". This should create a box around the litatom \"cd\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"efg\" in pending delete mode. Type meta-R four times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode. Type meta-R twice. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" in pending delete mode. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" in pending delete mode. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(Have a nice day please)\" and press the delete key. Type control-x. Select the litatom \"cd\" as a structure, and extend the selection to include the next litatom, type \"defgh\". Select the litatom \"a\" and extend the selection to include the next two litatoms. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-R Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-U Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-R Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hi\" as a structure, and extend the selection to include the previous list. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the entire structure. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) Select the entire structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ new file mode 100644 index 00000000..580c0116 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-undo-redo.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Undo/Redo" :before (progn (setq window-list (do-test-menu-Setup "Undo/Redo"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Undo: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Undo If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (ed 'tempx) Select Undo from the popup menu. Does it respond with: \"Nothing to Undo\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/no caret" (do-test-menu-Message window-list 'high " Testing Redo Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the popup menu. Select Redo from the popup menu. Does it respond with: \"No Undo to Undo\"? ")) (do-test "Undo: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" and press the delete key. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the structure caret between \"b\" and \"cd\". Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the third litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the fourth litatom \"efg\" as a structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure. Type meta-R. Select the string \"BYE\" and press the delete key. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-U three times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 2 and type \"; bye\", then select this as a structure. Type meta-R. Does SEdit display in the SEdit prompt window: \"No Undo to Undo\"? ")) (do-test "Undo: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 ; bye 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Place the strcuture caret after the litatom \"efg\" Type: \"(Have a nice day please)\" Select the \"d\" in the first litatom \"cd\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"f\" in the litatom \"efg\". Type meta-R twice. Does SEdit display in the SEdit prompt window: \"No Undo to Undo.\"? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-U three times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"B\" in the string \"BYE\". Type meta-R twice. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-U four times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"6\" in the number \"6/7\". Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"cd\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"c\" and then pressing the right button withe the cursor on the \"d\". This should create a box around the litatom \"cd\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"efg\" in pending delete mode. Type meta-R four times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye. Type meta-R twice. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" in pending delete mode. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" in pending delete mode. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(Have a nice day please)\" and press the delete key. Type control-x. Select the litatom \"cd\" as a structure, and extend the selection to include the next litatom, type \"defgh\". Select the litatom \"a\" and extend the selection to include the next two litatoms. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-R Were the litatoms joined together to form \"abcd\"? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-U Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-R Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hi\" as a structure, and extend the selection to include the previous list. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the entire structure. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) Select the entire structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ new file mode 100644 index 00000000..ab6032e2 --- /dev/null +++ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 17, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-undo-redo.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Undo/Redo" :before (progn (setq window-list (do-test-menu-Setup "Undo/Redo"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Undo: no selection/no caret" (let* (( user-result(do-test-menu-Message window-list 'high " Testing Undo If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) (ed 'tempx) Select Undo from the popup menu. Does it respond with: \"Nothing to Undo\"? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/no caret" (do-test-menu-Message window-list 'high " Testing Redo Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select DONE from the popup menu. Select Redo from the popup menu. Does it respond with: \"No Undo to Undo\"? ")) (do-test "Undo: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" and press the delete key. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the structure caret between \"b\" and \"cd\". Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the third litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the fourth litatom \"efg\" as a structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure. Type meta-R. Select the string \"BYE\" and press the delete key. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select a comment" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. Type meta-U three times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select a comment" (do-test-menu-Message window-list 'low " Testing: select a comment Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Place the edit caret after the number 2 and type \"; bye\", then select this as a structure. Type meta-R. Does SEdit display in the SEdit prompt window: \"No Undo to Undo\"? ")) (do-test "Undo: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 ; bye 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the comment as a structure and press the delete key. Type control-x. Place the strcuture caret after the litatom \"efg\" Type: \"(Have a nice day please)\" Select the \"d\" in the first litatom \"cd\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"f\" in the litatom \"efg\". Type meta-R twice. Does SEdit display in the SEdit prompt window: \"No Undo to Undo.\"? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"h\" in the string \"hello\". Type meta-U three times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"B\" in the string \"BYE\". Type meta-R twice. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"7\" in the number \"6/7\". Type meta-U four times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the \"6\" in the number \"6/7\". Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"cd\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"c\" and then pressing the right button withe the cursor on the \"d\". This should create a box around the litatom \"cd\". Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"efg\" in pending delete mode. Type meta-R four times. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" in pending delete mode. Type meta-R twice. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" in pending delete mode. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a number Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"6/7\" in pending delete mode. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: pending delete of a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(Have a nice day please)\" and press the delete key. Type control-x. Select the litatom \"cd\" as a structure, and extend the selection to include the next litatom, type \"defgh\". Select the litatom \"a\" and extend the selection to include the next two litatoms. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of litatoms" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-R Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-U Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of strings" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-R Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next number. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the list \"(bye)\" as a structure, and extend the selection to include the next list. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hi\" as a structure, and extend the selection to include the previous list. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of litatoms and numbers" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of strings and lists" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: extended selection of several things" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Undo: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) Select the entire structure. Type meta-U. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Redo: selection of entire structure" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) Select the entire structure. Type meta-R. Were you able to get this far? ")) (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Control.u b/internal/test/env/code-editor/hand/Control.u new file mode 100644 index 00000000..fb01e283 --- /dev/null +++ b/internal/test/env/code-editor/hand/Control.u @@ -0,0 +1,364 @@ +;; Being tested: SEdit +;; +;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT +;; +;; Created By: Henry Cate III +;; +;; Creation Date: February 6, 1987 +;; +;; Last Update: +;; +;; Filed As: {eris}test>SEdit>command-control.u +;; +;; +;; + + +(do-test "load the functions for the prompter for interactive tests" + (if (not (fboundp 'do-test-menu-setup)) + (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) + T) + + +;;; ----------------------------------------------------- +;;; +;;; The following are the complete tests, a do-test-group per command +;;; From keyboard, popup menu, attached menu. Test for all possible +;;; combinations of selection and caret point: +;;; no selection/no caret +;;; no selection/edit caret +;;; no selection/structure caret +;;; selection of each lisp type: litatom, string, list, comment, gap +;;; selection of part of each type above +;;; pending delete selection of each type above +;;; extended selection ofobjects of the same type +;;; extended selection of objects of mixed type +;;; selection of entire structure +;;; pending delete selection of entire structure +;;; +;;; ----------------------------------------------------- + +(do-test-group "Redisplay, test against standard set" + :before (progn + (setq window-list (do-test-menu-Setup "Redisplay"))) + + :after (progn + (do-test-menu-Cleanup window-list)) + +(do-test "Redisplay:no selection/no caret" + (do-test-menu-Message window-list 'high +"If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" + Testing: no selection/no caret +In the exec type: + +(setq tempx '(1 xy \"hi\" (\"bye\" a 23 4))) +(il:dv tempx) + +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: no selection/edit caret" + (do-test-menu-Message window-list 'low +" Testing: no selection/edit caret +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: no selection/structure caret" + (do-test-menu-Message window-list 'low +" Testing: no selection/structure caret +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Want to place the structure caret right between xy and \"hi\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a litatom" + (do-test-menu-Message window-list 'low +" Testing: select a litatom +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the litatom \"xy\" as a structure, by pressing the middle button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a string" + (do-test-menu-Message window-list 'low +" Testing: select a string +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the string \"hi\" as a structure. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a number" + (do-test-menu-Message window-list 'low +" Testing: select a number +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the number \"1\" as a structure. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a list" + (do-test-menu-Message window-list 'low +" Testing: select a list +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the list (\"bye\" a 23 4) as a structure. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select part of a litatom" + (do-test-menu-Message window-list 'low +" Testing: select part of a litatom +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the \"x\" in the litatom \"xy\" by pressing the left button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select part of a string" + (do-test-menu-Message window-list 'low +" Testing: select part of a string +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the \"h\" in the string \"hi\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select part of a number" + (do-test-menu-Message window-list 'low +" Testing: select part of a number +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the \"2\" in the number \"23\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: delete a litatom" + (do-test-menu-Message window-list 'low +" Testing: delete a litatom +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: delete a string" + (do-test-menu-Message window-list 'low +" Testing: delete a string +Assuming tempx currently equals (1 \"hi\" (\"bye\" a 23 4)) +Delete the string \"hi\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: delete of a number" + (do-test-menu-Message window-list 'low +" Testing: delete a number +Assuming tempx currently equals (1 (\"bye\" a 23 4)) +Delete the number \"1\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: extended selection of objects of same type" + (do-test-menu-Message window-list 'low +" Testing: extended selection of objects of same type +Assuming tempx currently equals ((\"bye\" a 23 4)) +Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: extended selection of objects of different types" + (do-test-menu-Message window-list 'low +" Testing: extended selection of objects of different types +Assuming tempx currently equals ((\"bye\" a 23 4)) +Select all items in the smaller list. +Type control-L. +Was the SEdit window redisplayed?")) + +) ; End of do-test-group + + + + +(do-test-group "Delete previous and done, test against standard set" + :before (progn + (setq window-list (do-test-menu-Setup "Delete previous"))) + + :after (progn + (do-test-menu-Cleanup window-list)) + +(do-test "Delete previous & done:no selection/no caret" + (let* (( user-result (do-test-menu-Message window-list 'high +" Testing parentheses +If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" +Then in the exec type: + +(setq tempx '(1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4))) +(il:dv tempx) + +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(1 2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: no selection/edit caret" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: no selection/edit caret +Assuming SEdit is editing tempx which currently equals (1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: no selection/structure caret" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: no selection/structure caret +Assuming SEdit is editing tempx which currently equals (2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a litatom" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a litatom +Assuming SEdit is editing tempx which currently equals (2 34 cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the litatom \"gh\" as a structure, by pressing the middle button with the cursor over the \"h\". The structure caret should end up to the right of \"gh\". +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 cd ef "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a string" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a string +Assuming SEdit is editing tempx which currently equals (2 34 cd ef \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the string \"hi\" as a structure, with the structure caret to the right of the string. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a number" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a number +Assuming SEdit is editing tempx which currently equals (2 34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the number \"2\" as a structure, with the structure caret to the right of the number. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a list" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a list +Assuming SEdit is editing tempx which currently equals (34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the list (\"bye\" a 23 4) as a structure, with the structure caret to the right of the list. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 cd ef "how" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select part of a litatom" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select part of a litatom +Assuming SEdit is editing tempx which currently equals (34 cd ef \"hi\" \"how\" \"are\" \"you\") +˙˙Place the edit caret in the middle of the litatom \"cd\".˙ +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 d ef "how" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select part of a string" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select part of a string +Assuming SEdit is editing tempx which currently equals (2 3 d ef \"how\" \"are\" \"you\") +˙˙Place the edit caret ˙after the \"h\" in the string \"how\"˙˙.˙ +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 d ef "ow" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select part of a number" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select part of a number +Assuming SEdit is editing tempx which currently equals (34 d ef \"ow\" \"are\" \"you\") +˙˙Place the edit caret in the middle of the ˙number˙˙ \"˙34˙˙\".˙ +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(4 d ef "ow" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: delete a litatom after a delete" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: delete a litatom after a delete +Assuming SEdit is editing tempx which currently equals (4 d ef \"ow\" \"are\" \"you\") +Place the structure caret after the string \"ow\" with no selection. +Type control-W, control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(4 d "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: delete a string after a delete" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: delete a string +Assuming SEdit is editing tempx which currently equals (4 d \"are\" \"you\") +Place the structure caret after the string \"you\" with selection of the string. +Type control-W, control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(4 d) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: delete of a number after a delete" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: delete a number after a delete +Assuming SEdit is editing tempx which currently equals (4 d) +Place the edit caret after the litatom \"d\" with no selection. +Type control-W, control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal nil tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +) ; end of do-test-group + + + +STOP +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) *6uż-'źW  É5˝ +zş \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Control.u.~1~ b/internal/test/env/code-editor/hand/Control.u.~1~ new file mode 100644 index 00000000..e69b46c2 --- /dev/null +++ b/internal/test/env/code-editor/hand/Control.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 6, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-control.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) ;;; ----------------------------------------------------- ;;; ;;; The following are the complete tests, a do-test-group per command ;;; From keyboard, popup menu, attached menu. Test for all possible ;;; combinations of selection and caret point: ;;; no selection/no caret ;;; no selection/edit caret ;;; no selection/structure caret ;;; selection of each lisp type: litatom, string, list, comment, gap ;;; selection of part of each type above ;;; pending delete selection of each type above ;;; extended selection ofobjects of the same type ;;; extended selection of objects of mixed type ;;; selection of entire structure ;;; pending delete selection of entire structure ;;; ;;; ----------------------------------------------------- (do-test-group "Redisplay, test against standard set" :before (progn (setq window-list (do-test-menu-Setup "Redisplay"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Redisplay:no selection/no caret" (do-test-menu-Message window-list 'high "If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Testing: no selection/no caret In the exec type: (setq tempx '(1 xy \"hi\" (\"bye\" a 23 4))) (il:dv tempx) Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: no selection/edit caret" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: no selection/edit caret Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: no selection/structure caret" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: no selection/structure caret Want to place the structure caret right between xy and \"hi\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a litatom" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select a litatom Select the litatom \"xy\" as a structure, by pressing the middle button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a string" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select a string Select the string \"hi\" as a structure. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a number" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select a number Select the number \"1\" as a structure. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a list" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select a list Select the list (\"bye\" a 23 4) as a structure. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select part of a litatom" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select part of a litatom Select the \"x\" in the litatom \"xy\" by pressing the left button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select part of a string" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select part of a string Select the \"h\" in the string \"hi\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select part of a number" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: select part of a number Select the \"2\" in the number \"23\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: delete a litatom" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Testing: delete a litatom Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: delete a string" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 \"hi\" (\"bye\" a 23 4)) Testing: delete a string Delete the string \"hi\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: delete of a number" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (1 (\"bye\" a 23 4)) Testing: delete a number Delete the number \"1\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: extended selection of objects of same type" (do-test-menu-Message window-list 'low "Assumping tempx currently equals ((\"bye\" a 23 4)) Testing: extended selection of objects of same type Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: extended selection of objects of different types" (do-test-menu-Message window-list 'low "Assumping tempx currently equals ((\"bye\" a 23 4)) Testing: extended selection of objects of different types Select all items in the smaller list. Type control-L. Was the SEdit window redisplayed?")) ) ; End of do-test-group (do-test-group "Delete previous and done, test against standard set" :before (progn (setq window-list (do-test-menu-Setup "Delete previous"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Delete previous & done:no selection/no caret" (let* (( user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4))) (il:dv tempx) Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(1 2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Testing: no selection/edit caret Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Testing: no selection/structure caret Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (2 34 cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Testing: select a litatom Select the litatom \"gh\" as a structure, by pressing the middle button with the cursor over the \"h\". The structure caret should end up to the right of \"gh\". Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 cd ef "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (2 34 cd ef \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Testing: select a string Select the string \"hi\" as a structure, with the structure caret to the right of the string. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (2 34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Testing: select a number Select the number \"2\" as a structure, with the structure caret to the right of the number. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a list" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Testing: select a list Select the list (\"bye\" a 23 4) as a structure, with the structure caret to the right of the list. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 cd ef "how" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (34 cd ef \"hi\" \"how\" \"are\" \"you\") Testing: select part of a litatom ˙˙Place the edit caret in the middle of the litatom \"cd\".˙ Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 d ef "how" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (2 3 d ef \"how\" \"are\" \"you\") Testing: select part of a string ˙˙Place the edit caret ˙after the \"h\" in the string \"how\"˙˙.˙ Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 d ef "ow" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (34 d ef \"ow\" \"are\" \"you\") Testing: select part of a number ˙˙Place the edit caret in the middle of the ˙number˙˙ \"˙34˙˙\".˙ Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(4 d ef "ow" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: delete a litatom after a delete" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (4 d ef \"ow\" \"are\" \"you\") Testing: delete a litatom after a delete Place the structure caret after the string \"ow\" with no selection. Type control-W, control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(4 d "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: delete a string after a delete" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (4 d \"are\" \"you\") Testing: delete a string Place the structure caret after the string \"you\" with selection of the string. Type control-W, control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(4 d) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: delete of a number after a delete" (let* ((user-result (do-test-menu-Message window-list 'low "Assumping SEdit is editing tempx which currently equals (4 d) Testing: delete a number after a delete Place the edit caret after the litatom \"d\" with no selection. Type control-W, control-W, and a control-X. Were you able to get this far?")) (good-value (equal nil tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Control.u.~2~ b/internal/test/env/code-editor/hand/Control.u.~2~ new file mode 100644 index 00000000..fb01e283 --- /dev/null +++ b/internal/test/env/code-editor/hand/Control.u.~2~ @@ -0,0 +1,364 @@ +;; Being tested: SEdit +;; +;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT +;; +;; Created By: Henry Cate III +;; +;; Creation Date: February 6, 1987 +;; +;; Last Update: +;; +;; Filed As: {eris}test>SEdit>command-control.u +;; +;; +;; + + +(do-test "load the functions for the prompter for interactive tests" + (if (not (fboundp 'do-test-menu-setup)) + (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) + T) + + +;;; ----------------------------------------------------- +;;; +;;; The following are the complete tests, a do-test-group per command +;;; From keyboard, popup menu, attached menu. Test for all possible +;;; combinations of selection and caret point: +;;; no selection/no caret +;;; no selection/edit caret +;;; no selection/structure caret +;;; selection of each lisp type: litatom, string, list, comment, gap +;;; selection of part of each type above +;;; pending delete selection of each type above +;;; extended selection ofobjects of the same type +;;; extended selection of objects of mixed type +;;; selection of entire structure +;;; pending delete selection of entire structure +;;; +;;; ----------------------------------------------------- + +(do-test-group "Redisplay, test against standard set" + :before (progn + (setq window-list (do-test-menu-Setup "Redisplay"))) + + :after (progn + (do-test-menu-Cleanup window-list)) + +(do-test "Redisplay:no selection/no caret" + (do-test-menu-Message window-list 'high +"If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" + Testing: no selection/no caret +In the exec type: + +(setq tempx '(1 xy \"hi\" (\"bye\" a 23 4))) +(il:dv tempx) + +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: no selection/edit caret" + (do-test-menu-Message window-list 'low +" Testing: no selection/edit caret +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: no selection/structure caret" + (do-test-menu-Message window-list 'low +" Testing: no selection/structure caret +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Want to place the structure caret right between xy and \"hi\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a litatom" + (do-test-menu-Message window-list 'low +" Testing: select a litatom +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the litatom \"xy\" as a structure, by pressing the middle button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a string" + (do-test-menu-Message window-list 'low +" Testing: select a string +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the string \"hi\" as a structure. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a number" + (do-test-menu-Message window-list 'low +" Testing: select a number +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the number \"1\" as a structure. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select a list" + (do-test-menu-Message window-list 'low +" Testing: select a list +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the list (\"bye\" a 23 4) as a structure. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select part of a litatom" + (do-test-menu-Message window-list 'low +" Testing: select part of a litatom +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the \"x\" in the litatom \"xy\" by pressing the left button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select part of a string" + (do-test-menu-Message window-list 'low +" Testing: select part of a string +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the \"h\" in the string \"hi\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: select part of a number" + (do-test-menu-Message window-list 'low +" Testing: select part of a number +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Select the \"2\" in the number \"23\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: delete a litatom" + (do-test-menu-Message window-list 'low +" Testing: delete a litatom +Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) +Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: delete a string" + (do-test-menu-Message window-list 'low +" Testing: delete a string +Assuming tempx currently equals (1 \"hi\" (\"bye\" a 23 4)) +Delete the string \"hi\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: delete of a number" + (do-test-menu-Message window-list 'low +" Testing: delete a number +Assuming tempx currently equals (1 (\"bye\" a 23 4)) +Delete the number \"1\". +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: extended selection of objects of same type" + (do-test-menu-Message window-list 'low +" Testing: extended selection of objects of same type +Assuming tempx currently equals ((\"bye\" a 23 4)) +Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. +Type control-L. +Was the SEdit window redisplayed?")) + + +(do-test "Redisplay: extended selection of objects of different types" + (do-test-menu-Message window-list 'low +" Testing: extended selection of objects of different types +Assuming tempx currently equals ((\"bye\" a 23 4)) +Select all items in the smaller list. +Type control-L. +Was the SEdit window redisplayed?")) + +) ; End of do-test-group + + + + +(do-test-group "Delete previous and done, test against standard set" + :before (progn + (setq window-list (do-test-menu-Setup "Delete previous"))) + + :after (progn + (do-test-menu-Cleanup window-list)) + +(do-test "Delete previous & done:no selection/no caret" + (let* (( user-result (do-test-menu-Message window-list 'high +" Testing parentheses +If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" +Then in the exec type: + +(setq tempx '(1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4))) +(il:dv tempx) + +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(1 2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: no selection/edit caret" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: no selection/edit caret +Assuming SEdit is editing tempx which currently equals (1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: no selection/structure caret" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: no selection/structure caret +Assuming SEdit is editing tempx which currently equals (2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a litatom" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a litatom +Assuming SEdit is editing tempx which currently equals (2 34 cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the litatom \"gh\" as a structure, by pressing the middle button with the cursor over the \"h\". The structure caret should end up to the right of \"gh\". +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 cd ef "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a string" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a string +Assuming SEdit is editing tempx which currently equals (2 34 cd ef \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the string \"hi\" as a structure, with the structure caret to the right of the string. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(2 34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a number" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a number +Assuming SEdit is editing tempx which currently equals (2 34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the number \"2\" as a structure, with the structure caret to the right of the number. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select a list" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select a list +Assuming SEdit is editing tempx which currently equals (34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) +Select the list (\"bye\" a 23 4) as a structure, with the structure caret to the right of the list. +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 cd ef "how" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select part of a litatom" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select part of a litatom +Assuming SEdit is editing tempx which currently equals (34 cd ef \"hi\" \"how\" \"are\" \"you\") +˙˙Place the edit caret in the middle of the litatom \"cd\".˙ +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 d ef "how" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select part of a string" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select part of a string +Assuming SEdit is editing tempx which currently equals (2 3 d ef \"how\" \"are\" \"you\") +˙˙Place the edit caret ˙after the \"h\" in the string \"how\"˙˙.˙ +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(34 d ef "ow" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: select part of a number" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: select part of a number +Assuming SEdit is editing tempx which currently equals (34 d ef \"ow\" \"are\" \"you\") +˙˙Place the edit caret in the middle of the ˙number˙˙ \"˙34˙˙\".˙ +Type control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(4 d ef "ow" "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: delete a litatom after a delete" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: delete a litatom after a delete +Assuming SEdit is editing tempx which currently equals (4 d ef \"ow\" \"are\" \"you\") +Place the structure caret after the string \"ow\" with no selection. +Type control-W, control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(4 d "are" "you") tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: delete a string after a delete" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: delete a string +Assuming SEdit is editing tempx which currently equals (4 d \"are\" \"you\") +Place the structure caret after the string \"you\" with selection of the string. +Type control-W, control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal '(4 d) tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +(do-test "Delete previous & done: delete of a number after a delete" + (let* ((user-result (do-test-menu-Message window-list 'low +" Testing: delete a number after a delete +Assuming SEdit is editing tempx which currently equals (4 d) +Place the edit caret after the litatom \"d\" with no selection. +Type control-W, control-W, and a control-X. +Were you able to get this far?")) + (good-value (equal nil tempx))) + (and user-result (if (eq t user-result) good-value T)) + )) + + +) ; end of do-test-group + + + +STOP +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) *6uż-'źW  É5˝ +zş \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Interrupt.u b/internal/test/env/code-editor/hand/Interrupt.u new file mode 100644 index 00000000..31af3c38 --- /dev/null +++ b/internal/test/env/code-editor/hand/Interrupt.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 5, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>interrupts.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Interrupts" :before (progn (setq window-list (do-test-menu-Setup "Interrupts"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "no selection/no caret" (do-test-menu-Message window-list 'high "If you are not in the XCL-TEST package. Stop this assistant and change packages. Create a second EXEC if needed. Testing no selection/no caret Type: (setq tempx '(xy \"hi\" 5 (a 23 4 \"bye\"))) (il:dv tempx) Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. Type control-B. A break window for SEdit should pop up. Continue on by typing \"ok\". Did both interrupts go correctly?")) (do-test "no selection/edit caret" (do-test-menu-Message window-list 'low " Testing no selection/edit caret Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Want to place the edit caret right after the 5 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 5. Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. Type control-B. A break window for SEdit should pop up. Continue on by typing \"ok\". Did both interrupts go correctly?")) (do-test "no selection/structure caret" (do-test-menu-Message window-list 'low " Testing no selection/structure caret Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Want to place the structure caret right between \"hi\" and the 5 without selecting either \"hi\" or the 5. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a litatom" (do-test-menu-Message window-list 'low " Testing select a litatom Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the litatom \"xy\" as a structure, by pressing the middle button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a string" (do-test-menu-Message window-list 'low " Testing select a string Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the string \"hi\" as a structure. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a number" (do-test-menu-Message window-list 'low " Testing select a number Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the number \"5\" as a structure. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a list" (do-test-menu-Message window-list 'low " Testing select a list Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the list (a 23 4 \"bye\") as a structure. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select part of a litatom" (do-test-menu-Message window-list 'low " Testing select part of a litatom Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the \"x\" in the litatom \"xy\" by pressing the left button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select part of a string" (do-test-menu-Message window-list 'low " Testing select part of a string Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the \"h\" in the string \"hi\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select part of a number" (do-test-menu-Message window-list 'low " Testing select part of a number Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the \"2\" in the number \"23\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "delete a litatom" (do-test-menu-Message window-list 'low " Testing delete a litatom Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "delete a string" (do-test-menu-Message window-list 'low " Testing delete a string Assuming tempx currently equals (\"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Delete the string \"hi\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "delete of a number" (do-test-menu-Message window-list 'low " Testing delete a number Assuming tempx currently equals (5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Delete the number \"5\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "extended selection of objects of same type" (do-test-menu-Message window-list 'low " Testing extended selection of objects of same type Assuming tempx currently equals ((a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "extended selection of objects of different types" (do-test-menu-Message window-list 'low " Testing extended selection of objects of different types Assuming tempx currently equals ((a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select all items in the smaller list. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Interrupt.u.~1~ b/internal/test/env/code-editor/hand/Interrupt.u.~1~ new file mode 100644 index 00000000..a8a6aff8 --- /dev/null +++ b/internal/test/env/code-editor/hand/Interrupt.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 5, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>interrupts.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Interrupts" :before (progn (setq window-list (do-test-menu-Setup "Interrupts"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "no selection/no caret" (do-test-menu-Message window-list 'high "If you are not in the XCL-TEST package. Stop this assistant and change packages. Create a second EXEC if needed. Testing no selection/no caret Type: (setq tempx '(xy \"hi\" 5 (a 23 4 \"bye\"))) (il:SEdit tempx) Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. Type control-B. A break window for SEdit should pop up. Continue on. Did both interrupts go correctly?")) (do-test "no selection/edit caret" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing no selection/edit caret Type: \"(il:dv tempx)\" Want to place the edit caret right after the 5 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 5. Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. Type control-B. A break window for SEdit should pop up. Continue on. Did both interrupts go correctly?")) (do-test "no selection/structure caret" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing no selection/structure caret Type: \"(il:dv tempx)\" Want to place the structure caret right between \"hi\" and the 5 without selecting either \"hi\" or the 5. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-G, control-B. Do both perform as specified before?")) (do-test "select a litatom" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select a litatom Type: \"(il:dv tempx)\" Select the litatom \"xy\" as a structure, by pressing the middle button. Type control-G and control-B Do both perform as specified before?")) (do-test "select a string" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select a string Type: \"(il:dv tempx)\" Select the string \"hi\" as a structure. Type control-G and control-B Do both perform as specified before?")) (do-test "select a number" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select a number Type: \"(il:dv tempx)\" Select the number \"5\" as a structure. Type control-G and control-B Do both perform as specified before?")) (do-test "select a list" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select a list Type: \"(il:dv tempx)\" Select the list (a 23 4 \"bye\") as a structure. Type control-G and control-B Do both perform as specified before?")) (do-test "select part of a litatom" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select part of a litatom Type: \"(il:dv tempx)\" Select the \"x\" in the litatom \"xy\" by pressing the left button. Type control-G and control-B Do both perform as specified before?")) (do-test "select part of a string" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select part of a string Type: \"(il:dv tempx)\" Select the \"h\" in the string \"hi\". Type control-G and control-B Do both perform as specified before?")) (do-test "select part of a number" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing select part of a number Type: \"(il:dv tempx)\" Select the \"2\" in the number \"23\". Type control-G and control-B Do both perform as specified before?")) (do-test "delete a litatom" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) Testing delete a litatom Type: \"(il:dv tempx)\" Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. Type control-G and control-B Do both perform as specified before?")) (do-test "delete a string" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (\"hi\" 5 (a 23 4 \"bye\")) Testing delete a string Type: \"(il:dv tempx)\" Delete the string \"hi\". Type control-G and control-B Do both perform as specified before?")) (do-test "delete of a number" (do-test-menu-Message window-list 'low "Assumping tempx currently equals (5 (a 23 4 \"bye\")) Testing delete a number Type: \"(il:dv tempx)\" Delete the number \"5\". Type control-G and control-B Do both perform as specified before?")) (do-test "extended selection of objects of same type" (do-test-menu-Message window-list 'low "Assumping tempx currently equals ((a 23 4 \"bye\")) Testing extended selection of objects of same type Type: \"(il:dv tempx)\" Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. Type control-G and control-B Do both perform as specified before?")) (do-test "extended selection of objects of different types" (do-test-menu-Message window-list 'low "Assumping tempx currently equals ((a 23 4 \"bye\")) Testing extended selection of objects of different types Type: \"(il:dv tempx)\" Select all items in the smaller list. Type control-G and control-B Do both perform as specified before?")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Interrupt.u.~2~ b/internal/test/env/code-editor/hand/Interrupt.u.~2~ new file mode 100644 index 00000000..31af3c38 --- /dev/null +++ b/internal/test/env/code-editor/hand/Interrupt.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 5, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>interrupts.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Interrupts" :before (progn (setq window-list (do-test-menu-Setup "Interrupts"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "no selection/no caret" (do-test-menu-Message window-list 'high "If you are not in the XCL-TEST package. Stop this assistant and change packages. Create a second EXEC if needed. Testing no selection/no caret Type: (setq tempx '(xy \"hi\" 5 (a 23 4 \"bye\"))) (il:dv tempx) Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. Type control-B. A break window for SEdit should pop up. Continue on by typing \"ok\". Did both interrupts go correctly?")) (do-test "no selection/edit caret" (do-test-menu-Message window-list 'low " Testing no selection/edit caret Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Want to place the edit caret right after the 5 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 5. Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. Type control-B. A break window for SEdit should pop up. Continue on by typing \"ok\". Did both interrupts go correctly?")) (do-test "no selection/structure caret" (do-test-menu-Message window-list 'low " Testing no selection/structure caret Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Want to place the structure caret right between \"hi\" and the 5 without selecting either \"hi\" or the 5. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a litatom" (do-test-menu-Message window-list 'low " Testing select a litatom Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the litatom \"xy\" as a structure, by pressing the middle button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a string" (do-test-menu-Message window-list 'low " Testing select a string Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the string \"hi\" as a structure. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a number" (do-test-menu-Message window-list 'low " Testing select a number Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the number \"5\" as a structure. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select a list" (do-test-menu-Message window-list 'low " Testing select a list Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the list (a 23 4 \"bye\") as a structure. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select part of a litatom" (do-test-menu-Message window-list 'low " Testing select part of a litatom Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the \"x\" in the litatom \"xy\" by pressing the left button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select part of a string" (do-test-menu-Message window-list 'low " Testing select part of a string Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the \"h\" in the string \"hi\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "select part of a number" (do-test-menu-Message window-list 'low " Testing select part of a number Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the \"2\" in the number \"23\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "delete a litatom" (do-test-menu-Message window-list 'low " Testing delete a litatom Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "delete a string" (do-test-menu-Message window-list 'low " Testing delete a string Assuming tempx currently equals (\"hi\" 5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Delete the string \"hi\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "delete of a number" (do-test-menu-Message window-list 'low " Testing delete a number Assuming tempx currently equals (5 (a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Delete the number \"5\". Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "extended selection of objects of same type" (do-test-menu-Message window-list 'low " Testing extended selection of objects of same type Assuming tempx currently equals ((a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) (do-test "extended selection of objects of different types" (do-test-menu-Message window-list 'low " Testing extended selection of objects of different types Assuming tempx currently equals ((a 23 4 \"bye\")) If needed, type: \"(il:dv tempx)\" Select all items in the smaller list. Type control-G, click outside the menu, then type control-B, and \"ok\". Do both perform as specified before?")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log new file mode 100644 index 00000000..72e4559c --- /dev/null +++ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log @@ -0,0 +1 @@ +Command-abort.u failed Command-base.u failed Command-comment.u passed Command-eval.u passed Command-expand.u failed Command-extract.u passed Command-find.u failed Command-help.u failed Command-high.u passed Command-join.u passed Command-menu.u passed Command-meta-o.u slow Command-mutate.u passed command-package.u passed Command-paren.u passed command-skip-next.u failed Command-substitute.u failed Command-undo-redo.u passed Control.u passed Interrupt.u passed \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ new file mode 100644 index 00000000..5225c468 --- /dev/null +++ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ @@ -0,0 +1 @@ +Command-abort.u failed Command-base.u failed Command-comment.u passed Command-eval.u passed Command-expand.u failed Command-extract.u passed Command-find.u failed Command-help.u failed Command-high.u passed Command-join.u passed Command-menu.u passed Command-meta-o.u slow Command-mutate.u passed command-package.u passed Command-paren.u passed command-skip-next.u failed Command-substitute.u failed Command-undo-redo.u passed Control.u passed Interrupt.u report.tedit \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ new file mode 100644 index 00000000..72e4559c --- /dev/null +++ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ @@ -0,0 +1 @@ +Command-abort.u failed Command-base.u failed Command-comment.u passed Command-eval.u passed Command-expand.u failed Command-extract.u passed Command-find.u failed Command-help.u failed Command-high.u passed Command-join.u passed Command-menu.u passed Command-meta-o.u slow Command-mutate.u passed command-package.u passed Command-paren.u passed command-skip-next.u failed Command-substitute.u failed Command-undo-redo.u passed Control.u passed Interrupt.u passed \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/command-package.u b/internal/test/env/code-editor/hand/command-package.u new file mode 100644 index 00000000..bdefab06 --- /dev/null +++ b/internal/test/env/code-editor/hand/command-package.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 25, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-package.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Change Package" :before (progn (setq window-list (do-test-menu-Setup "Change Package"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Change Package: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Change Package If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Change Package from the pop up menu. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Change Package: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Want to place the structure caret right between \"xcl-test::a\" and \"xcl-test::cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-P. Enter: \"xcl-test\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-P. Enter: \"xcl\" Check for three things. First, does the SEdit prompt window say \"Already editing in package XEROX-COMMON-LISP\."? Does the SEdit banner still read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And third, does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does all these, please indicate sucess. ")) (do-test "Change Package: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-P twice. Enter: \"INTERLISP\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the list \"(xcl-test::bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-P. Enter: \"interlisp\" Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the \"d\" in the first litatom \"xcl-test::cd\". Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-P. Enter: \"XEROX-COMMON-LISP\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the \"7\" in the number \"6/7\". Type meta-P. Enter: \"ZZZXXXYYY-SHOULD-NOT-EXIST\" Check for two things. First did SEdit display in the SEdit prompt window: \"No such package: ZZZXXXYYY-SHOULD-NOT-EXIST\"? Second does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the litatom \"xcl-test::efg\" in pending delete mode by first pressing the middle button of the mouse with the cursor on the litatom and then pressing the right button with the cursor. This should create a box around the litatom \"xcl-test::efg\". Type meta-P. Enter: \"IL\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-P. Just press the carriage return. Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit still display tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-P Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-P Enter: \"IL\" Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit still display tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the list \"(xcl-test::bye)\" as a structure, and extend the selection to include the next list. Type meta-P. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit still display tempx like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-P. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the entire structure in pending delete mode. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess.")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/command-package.u.~1~ b/internal/test/env/code-editor/hand/command-package.u.~1~ new file mode 100644 index 00000000..f5484454 --- /dev/null +++ b/internal/test/env/code-editor/hand/command-package.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 25, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-package.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Change Package" :before (progn (setq window-list (do-test-menu-Setup "Change Package"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Change Package: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Change Package If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-packge 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Change Package from the pop up menu. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Change Package: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Want to place the structure caret right between \"xcl-test::a\" and \"xcl-test::cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-P. Enter: \"xcl-test\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-P twice. Enter: \"INTERLISP\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the list \"(xcl-test::bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-P. Enter: \"interlisp\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the \"d\" in the first litatom \"xcl-test::cd\". Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-P. Enter: \"XEROX-COMMON-LISP\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the \"7\" in the number \"6/7\". Type meta-P. Enter: \"ZZZXXXYYY-SHOULD-NOT-EXIST\" Check for two things. First did SEdit display in the SEdit prompt window: \"No such package: ZZZXXXYYY-SHOULD-NOT-EXIST\"? Second does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the litatom \"xcl-test::efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"xcl-test::efg\". Type meta-P. Enter: \"IL\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-P. Just press the carriage return. Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-P Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-P Enter: \"IL\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the list \"(xcl-test::bye)\" as a structure, and extend the selection to include the next list. Type meta-P. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-P. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the entire structure in pending delete mode. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess.")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/command-package.u.~2~ b/internal/test/env/code-editor/hand/command-package.u.~2~ new file mode 100644 index 00000000..bdefab06 --- /dev/null +++ b/internal/test/env/code-editor/hand/command-package.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 25, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-package.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Change Package" :before (progn (setq window-list (do-test-menu-Setup "Change Package"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Change Package: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Change Package If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Change Package from the pop up menu. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Change Package: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Want to place the structure caret right between \"xcl-test::a\" and \"xcl-test::cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-P. Enter: \"xcl-test\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-P. Enter: \"xcl\" Check for three things. First, does the SEdit prompt window say \"Already editing in package XEROX-COMMON-LISP\."? Does the SEdit banner still read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And third, does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does all these, please indicate sucess. ")) (do-test "Change Package: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-P twice. Enter: \"INTERLISP\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the list \"(xcl-test::bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-P. Enter: \"interlisp\" Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the \"d\" in the first litatom \"xcl-test::cd\". Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-P. Enter: \"XEROX-COMMON-LISP\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the \"7\" in the number \"6/7\". Type meta-P. Enter: \"ZZZXXXYYY-SHOULD-NOT-EXIST\" Check for two things. First did SEdit display in the SEdit prompt window: \"No such package: ZZZXXXYYY-SHOULD-NOT-EXIST\"? Second does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the litatom \"xcl-test::efg\" in pending delete mode by first pressing the middle button of the mouse with the cursor on the litatom and then pressing the right button with the cursor. This should create a box around the litatom \"xcl-test::efg\". Type meta-P. Enter: \"IL\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the list \"(bye)\" in pending delete mode. Type meta-P. Just press the carriage return. Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit still display tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-P Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-P Enter: \"IL\" Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit still display tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the list \"(xcl-test::bye)\" as a structure, and extend the selection to include the next list. Type meta-P. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-P. Enter: \"XCL-TEST\" Check for two things. First does the SEdit banner still read: \"Sedit TEMPX Package: XCL-TEST\" And second does SEdit still display tempx like this: \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-P. Enter: \"il\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: INTERLISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess. ")) (do-test "Change Package: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) Select the entire structure in pending delete mode. Type meta-P. Enter: \"xcl\" Check for two things. First does the SEdit banner now read: \"Sedit TEMPX Package: XEROX-COMMON-LISP\" And second does SEdit redisplay tempx to look like this: \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? If it does both please indicate sucess.")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/command-skip-next.u b/internal/test/env/code-editor/hand/command-skip-next.u new file mode 100644 index 00000000..76c3f066 --- /dev/null +++ b/internal/test/env/code-editor/hand/command-skip-next.u @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-mutate.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Skip-Next" :before (progn (setq window-list (do-test-menu-Setup "Skip-Next"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Skip-Next: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Skip-Next If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Skip-Next from the pop up menu. Does SEdit display the message \"Select point from which to start search for blanks.\"?")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Skip-Next: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Skip-Next: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Place the edit caret after the litatom \"bye\" within the list and type: \" .\" Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye . -x-) \"hi\" (b) cd 4)) Place the structure caret after the litatom \"efg\" and type \"'\" Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list (after the \"BYE . \")? ")) (do-test "Skip-Next: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-N twice. Does SEdit first place a box around the \"-x-\" with the quote, and then place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"d\" in the first litatom \"cd\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" in pending delete mode. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Skip-Next: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-N Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-N Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" as a structure, and extend the selection to include the next list. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Skip-Next: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the entire structure in pending delete mode. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/command-skip-next.u.~1~ b/internal/test/env/code-editor/hand/command-skip-next.u.~1~ new file mode 100644 index 00000000..bae26759 --- /dev/null +++ b/internal/test/env/code-editor/hand/command-skip-next.u.~1~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-mutate.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Skip-Next" :before (progn (setq window-list (do-test-menu-Setup "Skip-Next"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Skip-Next: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Skip-Next If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Skip-Next from the pop up menu. Does SEdit either do nothing, or display a message complaing? (AR 7699 is on it doing nothing.) ")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Skip-Next: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-N. Does SEdit either do nothing, or display a message complaing? (AR 7699 is on it doing nothing.) ")) (do-test "Skip-Next: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Place the edit caret after the litatom \"bye\" within the list and type: \" .\" Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye . -x-) \"hi\" (b) cd 4)) Place the structure caret after the litatom \"efg\" and type \"'\" Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-N twice. Does SEdit first place a box around the \"-x-\" with the quote, and then place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assumping SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"d\" in the first litatom \"cd\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" in pending delete mode. Type meta-N. Does SEdit place a box around the \"-x-\" in this list? (AR 7907 was written for case where nothing happens.) ")) (do-test "Skip-Next: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-N Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-N Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" as a structure, and extend the selection to include the next list. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? (AR 7907 was written for case where nothing happens.) ")) (do-test "Skip-Next: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assumping SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the entire structure in pending delete mode. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? (AR 7907 was written for case where nothing happens.)")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/command-skip-next.u.~2~ b/internal/test/env/code-editor/hand/command-skip-next.u.~2~ new file mode 100644 index 00000000..76c3f066 --- /dev/null +++ b/internal/test/env/code-editor/hand/command-skip-next.u.~2~ @@ -0,0 +1 @@ +;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 23, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-mutate.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Skip-Next" :before (progn (setq window-list (do-test-menu-Setup "Skip-Next"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Skip-Next: no selection/no caret" (let* ((user-result (do-test-menu-Message window-list 'high " Testing Skip-Next If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" In the exec type: (setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) (ed 'tempx) Select Skip-Next from the pop up menu. Does SEdit display the message \"Select point from which to start search for blanks.\"?")) (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Skip-Next: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Select DONE from the SEdit popup menu. Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Skip-Next: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) Place the edit caret after the litatom \"bye\" within the list and type: \" .\" Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye . -x-) \"hi\" (b) cd 4)) Place the structure caret after the litatom \"efg\" and type \"'\" Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list (after the \"BYE . \")? ")) (do-test "Skip-Next: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. Type meta-N twice. Does SEdit first place a box around the \"-x-\" with the quote, and then place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing the variable tempx which currently equals: (1 9.0 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"d\" in the first litatom \"cd\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"h\" in the string \"hello\". Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the \"7\" in the number \"6/7\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: pending delete of a litatom" (do-test-menu-Message window-list 'low " Testing: pending delete of litatom Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: pending delete of a string" (do-test-menu-Message window-list 'low " Testing: pending delete of a string Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: pending delete of a list" (do-test-menu-Message window-list 'low " Testing: pending delete of a list Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" in pending delete mode. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Skip-Next: extended selection of litatoms" (do-test-menu-Message window-list 'low " Testing: try extended selection of litatoms Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. Type meta-N Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of strings" (do-test-menu-Message window-list 'low " Testing: extended selection of strings Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Now select the string \"hello\" as a structure, and extend the selection to include the second string. Type meta-N Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: extended selection of numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next two numbers. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of lists" (do-test-menu-Message window-list 'low " Testing: extended selection of lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the list \"(bye . -x-)\" as a structure, and extend the selection to include the next list. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Skip-Next: extended selection of litatoms and numbers" (do-test-menu-Message window-list 'low " Testing: extended selection of litatoms and numbers Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the next five items. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: extended selection of strings and lists" (do-test-menu-Message window-list 'low " Testing: extended selection of strings and lists Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the string \"hello\" as a structure, and extend the selection to include the next three items. Type meta-N. Does SEdit place a box around the \"-x-\" in the first list? ")) (do-test "Skip-Next: extended selection of several things" (do-test-menu-Message window-list 'low " Testing: extended selection of several things Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the number \"1\" as a structure, and extend the selection to include the rest. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: selection of entire structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) gh 4)) Select the entire structure. Type meta-N. Does SEdit place a box around the \"-x-\" with the quote? ")) (do-test "Skip-Next: Pending delete of whole structure" (do-test-menu-Message window-list 'low " Testing: selection of entire structure Assuming SEdit is editing the variable tempx which currently equals: (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) Select the entire structure in pending delete mode. Type meta-N. Does SEdit say \"No more blanks to fill in.\"?")) (do-test "Clean up" (do-test-menu-message window-list 'high "Close the SEdit window by selecting Done&Close from the window popup menu.")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/report.tedit b/internal/test/env/code-editor/hand/report.tedit new file mode 100644 index 0000000000000000000000000000000000000000..3618183762d373ebbf9089c99bbf791b78552ce0 GIT binary patch literal 4865 zcmb_eTW{mW6;`*KraNhXB505z$iqCfb|Gsmd%cpKzzJ>BYdN|>qIR3SjmV+IE^pxs zttf5(Kz~wS^4Id6p{}F@qd;X?8lE|~`ObIFaBO>l=2|MvGnpotX3UufYW2Xe@{`Q$ zE567At!2zb>~Z;{baO2|o~K+V{8mo0Tx3gr(ysI7dAr4vnCrRZUv-yR;9gz{6}am1 zHV?zbc&U~x@bLcb_@yhw$ssCwbLA;de-(NYv z=CTVXm&H+ruuzv{!mZIyw7d;M$=I7L$x~%gf)K(r9X#CG-66Xl zbovZ>6K3CZ9DZYCtK)PA5KbJ+vDwhN{?>X!zax0Nv&Wt9Z8oxR25kIoXL!_yOE#Wd zjh&7&vDu`L4R&L9ZO7)rk^Qzan2hm$L2VqD=n;I%aA`F*?9nvd` z86}8R=Lc#Y_?jyjN)wJBxJkOKa}NTI{U~{mhvbJi>}N^DrEupQgv?xd!I}-qjw=yK zZYs=98rif!(aTi6OtZuXBMupR7sOt&paWBP84Zvc zBA%qge4_9o(DTA6Kq_>=YNaW?%^_a8KnsTobZ)E^e46aInkRYa0c;^sDF|r8dz1f0 z9bI*uL@59$@b8KDIAV?h6iz@n+LVeTcVq@+soOS3B2s(O58}Y2JeAa$633TbgAl{s z5glC-SbnS+;CT?4B6JFmddbm+TCuYRaz%wbWeVU4EsP~nG;@f$JM+b=6vPc0H3)?m zUyi|(1d2&G+Y=Hs-Ln2e)1?_0J(LnS* zW{5RX+o8l*>+J0G1sa@-DcplHDXI`-2C3jDNe`NU!So0NoFa)>>-F)g7Y5Qg?@29= zuDF)~)fhe&N%p=dwkO>H^i`zZDk@MXm=Gi?G%zcXnL8KpO!6rn3U@ggzlXDvO>9eR;&e~OIou?mGG??PS`Y(!6hQMKrkg&ZNI2;0lk;`n5#??3xlmkV zqS49ag9wRtD7xTr9!+Joib`iVZSI=_(n22x2jcXI8)GrYR}zC+1~*LFg52od*6UX% zWfuxb>p4YC^4T2MQ-X}rlpImN$RBYFd0@w;L*S*o@!}>iau1K*ap9xV=$m+kbNrBF zSQl_n;_dc2>NTb+T~`8q2Urj^Ti4VSF#fAvSA%XKcLmz{2DG^h(>f1)s^=X~{z zus8t-xN6!NsEWaZ^7vAEQ{keDt>e>mR;ChnWR8|mX%Z6;W+I3&OV*i^!CBeB5CTA% zNn?PY3q%4@AH%KHZ0$L?M?|^UX1%Ucol~Q7lNEG!gCL77fxN`c>6R_Vn-WViRiYFv zU@{^`#(qvU0rOg0`VhYh@7rTOmNGS6!9qZ3(m*v^r~A0wqe?OVM}m1styxT)qPno! zj`Lz{wOZ|c^FbXWS_cstohAl+5eIO=a5ubI?;vV>({m2hbHEaF@6BjxYfK7o z6~Y)73-CZi7h(zX^9^MS^MVbCi{2q0_*DWk0C!gAg5vSK8+z1%p zktJwijSuSe=J9NI;>&(ZW$_3OnG-TDuRkhrIeqR6WcQZp$f|FMydE1mwi+; z_5|eg3o_X)_MQesyC;p^u!gw1f=cQy$|fetu1O`zf668mjql4EmAX7#%1Y{=mz`F^ zRtQt^Q4w^WbZSg~6?Mv?Nj|7R^i6`7#d0g?l?7jx1?DWfJ}Mg5Ws}>o;J7UKrYxvL znUpmuXR*o}c3IFa3o23W${Jsn1+B86qVcM%QHgS1*7&9@xGW1!%7SiLP>Et%oeE`+ VP20b&az)-AQ~Bt9?dPBV`wNL{`sDxs literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/allrec.test b/internal/test/env/inspector/hand/allrec.test new file mode 100644 index 00000000..0c162c66 --- /dev/null +++ b/internal/test/env/inspector/hand/allrec.test @@ -0,0 +1,665 @@ +(do-test-group |records| :BEFORE (PROGN (SETQ S (QUOTE (FIRST SECOND THIRD))) (SETQ ALFA "some string")) :AFTER (PROGN (IL:RECORD RECORD-TEST-NAME) (IL:RECORD RECORD-TEST-NAME1) (IL:RECORD RECORD-TEST-NAME2)) + +;; record type record + +(DO-TEST |setup-record| + (IL:RECORD RECORD-TEST-NAME + (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (ODDP (LENGTH IL:DATUM))))) + +(DO-TEST |create-record| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME ALPHA IL:_ ALFA BRAVO IL:_ S))) + +(DO-TEST |type?-record| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-record + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-record| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-record| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-record| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-record + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-record| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST |using-record| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) + S))) + +(DO-TEST |reusing-record| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + +(DO-TEST |copying-record| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-record| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD4 RECORD-TEST-RECORD2) )) + +; record type typerecord + +(DO-TEST |setup-typerecord| + (IL:TYPERECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A))) + +(DO-TEST |create-typerecord| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-typerecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-typerecord + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-typerecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-typerecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-typerecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-typerecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-typerecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST |using-typerecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD + GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + +(DO-TEST |reusing-typerecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + +(DO-TEST |copying-typerecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-typerecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + + +;record type proprecord + +(DO-TEST |setup-proprecord| + (IL:PROPRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (EVENP (LENGTH IL:DATUM))))) + +(DO-TEST |create-proprecord| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-proprecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-proprecord + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-proprecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-proprecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-proprecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-proprecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-proprecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + + + +(DO-TEST |using-proprecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME IL:USING RECORD-TEST-RECORD + GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + +(DO-TEST |reusing-proprecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + +(DO-TEST |copying-proprecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-proprecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + + +;record type datatype + +(DO-TEST |setup-datatype| + (IL:DATATYPE RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A))) + +(DO-TEST |create-datatype| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-datatype| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-datatype + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-datatype| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-datatype| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-datatype| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + + +(DO-TEST |typeglobalvariable-datatype| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + + +(DO-TEST fetchfield-datatype + (AND (EQ (IL:FETCHFIELD (CAR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) S) + (EQ (IL:FETCHFIELD (CADR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) RECORD-TEST-RECORD) + ALFA))) + +(DO-TEST replacefield-datatype + (AND (EQ (IL:REPLACEFIELD (CAR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD ALFA) ALFA) + (EQ (IL:REPLACEFIELD (CADR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD S) S))) + +(DO-TEST refetchfield-datatype + (AND (EQ (IL:FETCHFIELD (CAR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCHFIELD (CADR (IL:GETDESCRIPTORS + (QUOTE RECORD-TEST-NAME))) + RECORD-TEST-RECORD) S))) + +(DO-TEST getfieldspecs-datatype + (EQ (CAR (IL:GETFIELDSPECS (QUOTE RECORD-TEST-NAME))) + (CADDAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))))) + +(DO-TEST IL:typename-datatype + (EQ (IL:TYPENAME RECORD-TEST-RECORD) + (QUOTE RECORD-TEST-NAME))) + +(DO-TEST typenamep-datatype + (IL:TYPENAMEP RECORD-TEST-RECORD (QUOTE RECORD-TEST-NAME))) + +(DO-TEST |using-datatype| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + + +(DO-TEST |reusing-datatype| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + + +(DO-TEST |copying-datatype| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-datatype| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + + +;record type arrayrecord + +(DO-TEST |setup-arrayrecord| + (IL:ARRAYRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (COND (IL:DATUM T))))) + +(DO-TEST |create-arrayrecord| + (SETQ RECORD-TEST-RECORD + (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-arrayrecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST SYNONYM-typearary + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-arrayrecord| +` (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-arrayrecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-arrayrecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-arrayrecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-arrayrecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST getfieldspecs-arrayrecord + (EQ (CAR (IL:GETFIELDSPECS (QUOTE RECORD-TEST-NAME))) + (CADDAR (IL:GETDESCRIPTORS (QUOTE RECORD-TEST-NAME))))) + +(DO-TEST IL:typename-arrayrecord + (EQ (IL:TYPENAME RECORD-TEST-RECORD) + (QUOTE il:arrayp))) + +(DO-TEST typenamep-arrayrecord + (IL:TYPENAMEP RECORD-TEST-RECORD (QUOTE il:arrayp))) + + +(DO-TEST |using-arrayrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + + +(DO-TEST |reusing-arrayrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + + +(DO-TEST |copying-arrayrecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + + +(DO-TEST |smashing-arrayrecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + +;record type assocrecord + +(DO-TEST |setup-assocrecord| + (IL:ASSOCRECORD RECORD-TEST-NAME (ALPHA BRAVO GAMMA) + (IL:SYNONYM ALPHA A) + (IL:TYPE? (NOT (IL:ATOM (CAR IL:DATUM)))))) + + +(DO-TEST |create-assocrecord| + (SETQ RECORD-TEST-RECORD (IL:|create| RECORD-TEST-NAME + ALPHA IL:_ ALFA BRAVO IL:_ S))) + + +(DO-TEST |type?-assocrecord| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + +(DO-TEST synonym-assocrecord + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) ALFA)) + +(DO-TEST |fetch-assocrecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-assocrecord| + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) S) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA))) + +(DO-TEST |refetch-assocrecord| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH A IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST rereplace-assocrecord + (AND (EQ (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH ALFA) ALFA) + (EQ (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH S) S))) + +(DO-TEST |typeglobalvariable-assocrecord| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +(DO-TEST |using-assocrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:USING RECORD-TEST-RECORD GAMMA IL:_ S)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH GAMMA IL:OF RECORD-TEST-RECORD3) S))) + + +(DO-TEST |reusing-assocrecord| + (SETQ RECORD-TEST-RECORD3 + (IL:CREATE RECORD-TEST-NAME + IL:REUSING RECORD-TEST-RECORD)) + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) + (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD3)) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD3)))) + + +(DO-TEST |copying-assocrecord| + (SETQ RECORD-TEST-RECORD2 + (IL:CREATE RECORD-TEST-NAME + IL:COPYING RECORD-TEST-RECORD)) + (AND (EQUAL (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2)) + (NOT (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) + (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD2))))) + +(DO-TEST |smashing-assocrecord| + (SETQ RECORD-TEST-RECORD4 (IL:CREATE RECORD-TEST-NAME + IL:SMASHING RECORD-TEST-RECORD2)) + (AND (NULL (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD2)) + (EQ RECORD-TEST-RECORD2 RECORD-TEST-RECORD4))) + +;record type accessfns + +(DO-TEST setup-accessfns + (IL:ACCESSFNS RECORD-TEST-NAME + ((ALPHA (CAR IL:DATUM) + (SETQ IL:DATUM(CONS IL:NEWVALUE + (CDR IL:DATUM)))) + (BRAVO (CADR IL:DATUM) + (SETQ IL:DATUM (CONS (CAR IL:DATUM) + (CONS IL:NEWVALUE + (CDDR IL:DATUM))))) + (GAMMA (CADDR IL:DATUM) + (SETQ IL:DATUM (LIST (CAR IL:DATUM) + (CADR IL:DATUM) + IL:NEWVALUE)))) + (IL:CREATE (LIST ALFA S NIL)) + (IL:TYPE? (ODDP (LENGTH IL:DATUM))))) + +(DO-TEST create-accessfns + (SETQ RECORD-TEST-RECORD + (IL:create RECORD-TEST-NAME))) + +(DO-TEST |type?| + (IL:|type?| RECORD-TEST-NAME RECORD-TEST-RECORD)) + + +(DO-TEST |fetch-accessfns| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) ALFA) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST |replace-accessfns| + (AND (IL:REPLACE ALPHA IL:OF RECORD-TEST-RECORD + IL:WITH S) + (IL:REPLACE BRAVO IL:OF RECORD-TEST-RECORD + IL:WITH ALFA))) + +(DO-TEST |refetch-accessfns| + (AND (EQ (IL:FETCH ALPHA IL:OF RECORD-TEST-RECORD) S) + (EQ (IL:FETCH BRAVO IL:OF RECORD-TEST-RECORD) ALFA) )) + +(DO-TEST |typeglobalvariable-accessfns| + (EQ (SYMBOL-PACKAGE (IL:\\TYPEGLOBALVARIABLE + (QUOTE RECORD-TEST-NAME))) + (FIND-PACKAGE "XCL-TEST"))) + +; blockrecords + +(DO-TEST setup-blockrecord + (IL:DATATYPE RECORD-TEST-NAME1 + ((ALPHA IL:POINTER)) ALPHA IL:_ S) + (IL:BLOCKRECORD RECORD-TEST-NAME2 + ((BRAVO IL:WORD) (GAMMA IL:WORD))) + (SETQ RECORD-TEST-RECORD (IL:CREATE RECORD-TEST-NAME1))) + +(DO-TEST TEST-FETCH-BLOCKRECORD + (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) + (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) + IL:OF RECORD-TEST-RECORD) + (IL:FETCH (RECORD-TEST-NAME2 GAMMA) + IL:OF RECORD-TEST-RECORD))) + (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) S))) + +(DO-TEST TEST-REPLACE-BLOCKRECORD + (IL:REPLACE (RECORD-TEST-NAME1 ALPHA) IL:OF RECORD-TEST-RECORD IL:WITH ALFA)) + +(DO-TEST TEST-reFETCH-BLOCKRECORD + (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) + (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) + IL:OF RECORD-TEST-RECORD) + (IL:FETCH (RECORD-TEST-NAME2 GAMMA) + IL:OF RECORD-TEST-RECORD))) + (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) ALFA))) + +(DO-TEST "TEST THAT REPLACES THROUGH THE BLOCKRECORD STRUCTURE" + (IL:REPLACE (RECORD-TEST-NAME2 BRAVO) IL:OF RECORD-TEST-RECORD + IL:WITH (IL:\\HILOC S)) + (IL:REPLACE (RECORD-TEST-NAME2 GAMMA) IL:OF RECORD-TEST-RECORD + IL:WITH (IL:\\LOLOC S))) + +(DO-TEST "TEST REFETCHING AFTER REPLACING THROUGH THE BLOCKRECORD" + (AND (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) + (IL:\\VAG2 (IL:FETCH (RECORD-TEST-NAME2 BRAVO) + IL:OF RECORD-TEST-RECORD) + (IL:FETCH (RECORD-TEST-NAME2 GAMMA) + IL:OF RECORD-TEST-RECORD))) + (EQ (IL:FETCH (RECORD-TEST-NAME1 ALPHA) + IL:OF RECORD-TEST-RECORD) S))) + +(Do-test "look at floating point" + (IL:DATATYPE flnum ((n IL:floating))) + (setq num1 (IL:CREATE flnum)) + (setq num2 (IL:CREATE flnum)) + (IL:BLOCKRECORD fldisect + ((sign IL:BITS 1) (exp IL:BITS 8) (mant IL:BITS 23))) + (setq anynum (IL:RAND)) + (IL:REPLACE n IL:of num1 IL:with anynum) + (IL:REPLACE n IL:of num2 IL:with (IL:times anynum 2)) + (eq (IL:add1 (IL:fetch exp IL:of num1)) + (IL:fetch exp IL:of num2))) + + +(Do-test "test blank fields and playing with integers" + (IL:DATATYPE intnum ((int IL:integer))) + (setq num (IL:CREATE intnum)) + (IL:BLOCKRECORD evenodd ((nil IL:bits 16) + (nil IL:BITS 15) + (lastbit IL:BITS 1))) + (setq anynum (IL:RAND)) + (IL:REPLACE int IL:of num IL:with anynum) + (if (evenp (IL:fetch int IL:of num)) + (progn (IL:replace lastbit IL:of num IL:with 1) + (oddp (IL:fetch int IL:of num))) + (progn (IL:replace lastbit IL:of num IL:with 0) + (evenp (IL:fetch int IL:of num))))) + +;Testing WITH + +(Do-test "simple with using a datatype" + (IL:with flnum num1 + (IL:setq n 0) + (zerop n))) + +(Do-test "compound with using two datatypes" + (IL:with flnum num1 + (IL:with intnum num + (IL:setq n (il:times n 2)) + (IL:setq int 0) + (and (equal (float int) n) + (zerop int))))) + +) ;END OF DO-TEST-GROUP + +STOP +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) _í_ízş \ No newline at end of file diff --git a/internal/test/env/inspector/hand/inspect-allrec.tedit b/internal/test/env/inspector/hand/inspect-allrec.tedit new file mode 100644 index 0000000000000000000000000000000000000000..45bf3f0783fc6b0664395946d36cdc71e09e6148 GIT binary patch literal 71237 zcmeIb4Rln;l`dM{YD;a5p+yo0Cjt&_?8qK$W8z7)j0Re!F~pbH3I@a6>l+YA{LBco zKmy4lpj%)Y5j*^NuHSQ3p09aBlINH_TbbmJ$m@u1h7dWq69>PUwXSo8)WW>{%w3im z#$IadM(X$NsygS?`RP_eh$nNeYe`*IyLRo`yZ%o7?s{y)_ASk=E!xJ&cCEFcrFBcw zCaraIgSNe4Lu7ls)?ByYFY7inXq9y>EjzYS;D#OBw>LDkHa@9sY0?%)wr-6yY0I~? zG;6C`8n)~BcTT$d8qK6hD@4kzPc}DbcWc5oX%cxKm{hr?@d3%1u-CB32M))mHHbt7A+^UIS2_$lhw8}_*eX~~C*wD18b+ZQC`nuK~ zTknLKRN2zdx=rSSNJOSfBsXktsB6{pNMS)F0fe>M=PJR9w&7064~GR?BH**7bvyDg zh%^kLnp&D0Hnh5=2AmC>BaxN{Ex1J>1(CBYn-vW64fR?>W5ZSySBrKZGKh0DSDUX{IGL+ypVzdeEsc|yhmmP#Uu2$~ z)iBkY$mLijn#qj`V3hnLxlC?c`eCt=3-3o~UTJUr<*c86@`vpw*}%YiC(|80KlnmA zzWoP13)#S>%*ouYww|3+``UVX5dI7Jqdh%4b6MdR_&qz*arhUqk#{(~wzgS)|9j7g zlSnV8r##+{^t_S=hrAf4ReN;!lk+?^L1}6Y=p2k}xs;OFtI=3}_xl8DlrdAke90{+RT0 zs=_~|qOsZ2_w1Cp_t$db<-wI*-r(fD^OuXnCkIzv_U!e0gJB2hhtvll&5(Cj1Zed2_j#m2~v?PeFzwi#Up=+-sW z%ieNx-OdL7IcT9Cc4uAVj)r^mUgCN7F!QW(m=Jr_VPdW@N7PjzwpPs}?oP7A1TgA# zvbiK%JCIAE6CyLlVG+RMfMo@Y|F(f%{LouhIxe06$Li?x6>q)s;R1rSwY{0`9U1(G z{*%K$fAic2{T+zg);E|PyEHiP_M#bsgM(QC`yycDg9H7!VI8K&9YEZ{!E+oh5r3Aa zF>o$A^Q(jJWc!f@cp*lm8APwed4{dS&gXJzcX>}Zs$mFyh20pi7=`d3bUz|4IuDJ( zN5&nthPO6v8Jo+RHHo)|_ZD6jo6ov**om1G=q-x{SAv$s6`tV0ZYwTdS4UsIU{k z>hFGK$Y+Cvzq>-S!q(j30{e_hT$8xu2K*^Koi0bw@@f>r8>3(Tk*EYcjobppKO2Cp znY(6NdD6Ro$``8Gg){qa`3%A4*WWlzWBwy|g+1k^HMicu5H}cV{~L{!mfy9Do$`6g zg96qCn5X=%5SuMwYvzZ#9@OK`@sv~CHFHDlHAz-B<*q6=^b=3{XDBYQq8P6Wtb*by zIKpYbV&vyPJZ=?4!kugxLV_umR3ni+kpAW-R+ce3w^*E>bK}YG=<1J z+SU^@NA!gxR7TszAiJn9DF419AMmZ+(xNrV$qIPi-q5;ZJF-Y*7;&wS?CFclCqzQ{ z^_Z1WW{Tv1w!Wb;(zL1N9!+GXJp<}C)op1qGy1ybz%>jZcm@bbkO4w!6uy+33KBz_ zMw<0dZBg>Us482U?$&3fpWD*Z+OQpwnw=A>9hj0nASaBLN!;h0AvA}au(;iX6{N(d zNxJz&)NSlk(}?x}nfOSmMQ;xzu~tblaAoXur&fmwvTa9Q3k&RnZJAb{YY1eS?_?rVS#doF~Oq{jx3+dhCm(xw}&N`TmM0Nvb@IvptJ?V&! z1AgM)1Wqo}G@KjNamIQR792gTrs34ibfk&X;b|Fkz|X)L&hyB~qC@vaw(TB{Bdue7 zhvudAw2(goaLbuB#)DCwR|!3wZ16*~Ut=hFQ4Apy6sDWv%IkajS0=ChJN880Fg@U` z1t*|`RXcQ+scC7JFzL~LR}{_@u*KstSOg@?iLlP%Ol8 zrp;OYl;7v!R=u#o!1-SJ^j$GllH@q$``=)!+QY4|utEXwQ|=4Jm`~6NgfZt0dsK^X zp7=yC91A@qaOTfh=JSU=+^QEArS-(5imF&>Uy{LSZ=LS)`KuYX)(ERgE08}FiHt3O z-1GVB%S#Zq|62KBvy*lN_^std!xECKII_In$d6-`SAn#Q{BdK138UvvNlXG+3`UN0iso&rS(evD))L?PC?~-S3=ULV?og<@L<+&S02%rro|Q7S!Ij zZB9~0fUUPL-?FKn3^Vrkw?7)2uEm0LLJE#qUgd-nynPw-IdMdJJ+rLbuctK!bdm}k zy}X|8n(D7&?EIOftYUgBc$=D*QC>KRi_)tOlKe{b3EdS5~8TgtA*y`oo%A38!#>c$3Y5{9T~m4tnAfRoV zr^;V9g_(xqn_lpP&q1XGK#pg+@tF~RqALB(7dFJERIk}q_czZp6Y&Gnz7;AD)R#ZM zj?2U9ru|>Z$$?P$G_AB-LwNbLZ!xd*hjjdD2nRm+XU*>%i%ppvDlb23;|K8(Y#2|{ z>ZkleAXo@NY7I`#KRA7g-QXvNONoDrANiy;dv1u$dWtyb_?q8S8oJph{1o2q@#+3< z@^`_%NQ4tT_)9~dl=#T6Ks$Rn_DPW*@q_eY;7X(qzsg@X{ED&3E96nb6G~--bKLH? zw^zI0+FG4HV}XG0-lA)gT}m^yTw5C(b~ZF(WA;zAd$d2jE`3srEppoev2yL?(h6B? z&6AwnujUcWf)mzlj&a)-$Jkoy_QsgLJt4O?vI*O^#@aUPmd0AS6{2rv*tRmp(B~<0 z&%rT1Up4xm^W%2@Pbd`t&Jw$S4S=YYdK)iUg9_$n9yCt^0)M*AUx_+dg`i&zdZN!NA$}0WOdn2_KR5mfU78ZwM){=lK#s*H zg1VomN`KY1?HHKd^#% zq+iqV4JcXl}nW!bVQ%0mKUT@a}4|-H_`7IWdVK=3q79!0Ug4z zmKQ<7CJyL;vaP%*_3A%Jc_CrNAb-}X)f;ZK3kT$S^&3U?l=J0i470v#G}aS?D{-<< zOkyV)>0=;ByJrGynZ#b*$-#fa#{&7zmGe{}js-eq{PQ*QsNm-vM+NWKEN2D(54PNO z2wZEgMDQPVgRQbvKX}i&!HzrejvlAaNG_`%M9k!(xudJH7FZgvv#YYp+b{m}v*!;@ z-#znzO@~GnExmO1c;-)fA`LB>ox@j#fA!6_fz*PLqsKGtUra|jGG#Ny(w~i&rDk=c zkFLseWB~hObodwV_Q#{=QXT2Dfc4;1CgP3__s4nMv&XZ$+ApS`{ov5d-6MYzKQwah z(o08=b6yO_X<~kK73bN2(dWlq-k8#Gxzls>xC?BR6Lxl0Oagf?N0B{ek9QidnCSFD zZ*PowPw&V1KhOEohuGYzx6dD?xFvIz9l;sEy>r5BzVEx`oSwJrjdCq~dEW)!ES!fy z{sGVH^8?2AVuBhBf0y_p*s>$qa`yb3a15~WqpS7}F>lHKDcb$4?({wutbXM@=n+q< z0e>;oPwoQphA5o>!1kP7)tO{0Ml)3nelno9SF^()uf{wjv0GRbeQn5iAa4lY+t95n zY{0m@o|0ra3z@Lvoxt{mR2b-Sm>QSM%l0LahQ?C>hLAT#UX6ZWq`V<=^B>p+4OHS!!!W`B z!a}xgFY7wOVHB6Kt`{^G&|y6Pn27s4>*8^ba(X5EKUKk+*R!s#^SIXX^+2U|t*SIMq`t4Eg84tKdTJdc)U>SnFI`*CF_SQ2O`<`2PXvXLJGFXs*<<;y9 z{XKvCqilTV_|A8K5vN7@S5{?z{Mk%TZ+73o@yyo;_R+$8?W$~V7O-z7Mt?K9bs#~D z^R=&Ld;5EOc-+z90TK7rv6I#9ZD+3Z9a@KEmcdtfcl;fv2vZz2XL2l^mjI>Pi~u@$a3wng)6oIi9kj_R6cL1fH_0 z_R1;)W~{7%9*?W8u9^ISs+TB3Hp!nVMtJCNWd)hc}dqH%W5&nOZ8S= zE1>#Ju-~gb>siIyhtXvij#u3JPPabRtuJ`z&Ny}&_>dLY1RsC}ety_@Xv&Kx zr(fFt)&(3AvEG?IIFQ?X3H)r2?;KsdsI4jW<^T?kSntv99L#NM0zYm0_Kao{&D&Cg zm*U;Kt#@lj2Xm2a;HNDCoFBA}pBwx|yl2dM-%H930iISOK{D!wAIvljwr7iJMUWQ_Z$wn;ea1rUj9ROt!&3lad#Y9UPta)*_8(e{P6O+ zu^^5puhN2P$vkvngb8EhPniU`SSSl?9=hWcUtWAL&5lYkA%?s5x-s}saY6`HarE-K z>6VIcGy6YJfBhhR@OnXl=k(XW z^L;G*kTos$JhbAtmW5h;*HB&>b1|LB9|4|1i`e)xO-wp#l6u{sYoB>=^zth6&Rx^Y zCg>0M&ad}lYocI(xHlMX2c3fbA#l2IDn;oCWw)sGhkNG}PT~G=?_8ucQGci*J0QN( znEAsrgwnsmbRvHoKpTMSvkm0%dW`aN1Q`I}B=UZ1^#F`FbZ1`Md9=hin+!P)t+?Sh z$9i^1apOaMxz_zG^fhiiQ?yB%X5E9hP&PDCoI-H)hYj-*^IC^Er;1$qm**g4gs)a+|+cAhCcA~9uSdW$I7|eps ziT``X$h{|eiSp(6dBj>v3Fi{>pH74%QUpoiKZ<`EswcQ@{x~|D5@zpy0I_viCFsWJ zt4+7}g#m=lMe)1)5&}AvjPaZM283dH>E6DC2s$(A*1iFuQ&2&=vo9f_!y&k_Z$Rk$ z&`i3oFCluj8WVo3w1FS)HX)#+hYDNDe;peO91P^USdN~r&30fhb1BkjhiTpu) zb*){q|7uvf6GV$lMxc*T8z~*0m#ipsg?aTK=YnOlN zv6Y1ue}$3-?ELB~7Ut@D+^~TwRJ}<(3=LaweZHk7vSABUv(?KR_Qsdse`E9A7MfnM z-dN{3bD6ESX8LYm-16b>0{qna3VT$ z#{F#dK>vaT{NzyPC2U5X9Des7*z2j!c69X7siRD9Vn$nH#_-$h^>h6l9bcqVN15Iq z540tQ0i(DbGH&l+=H&43IktM_PnLE(OQ(*~$4=gJ8EKpYFJOaT2hy(ufj?rGA9_vY zgmIVmacfP2uY$eifKAt78U^tmHl01rjMvq;ua$}M`4G|&ybyn!)exm<^2cEs z!T3*Mc?nG#&=X7@l>p3Fi9hZWun^pUz2=yYLSD!Gljzy!n?%n(zXUzUd=m5=^G7Z( zXU6!6QF&NR+11EvjS63dd;5?z%(N~$#$Gsm;22r0TD8&@X78sct{co8b6-zYFK)U& z6n!0@9Zt(k|?b+_knr zXM5{e8bDfxojpIOWC`2Av#n<{TWcG7_VhHXB0T1BDQgG58ZA#5n9~6ydF^_$NM5_%ERxr*H;c;)k&yQ=A^ywDBL*k^%W^9yFQG{T zdKx*sG5Y0nD?v{qw}A1KDnZYo7Y+P5^rC^DLoXW1%g3;aUNq2i=tToPhh8);FEL{n zuUWnZtfFvzHt?u!$U3g*z2o`Eal8g5_;cvJ1Ah*^cO9Npp#O7$IoFwLT|PPP{j>3T`FOAYWqCLICsW17U;Y>c4l*W+iud4_I}%$6nK`3E>cKqX7!W%IS$0;d8X!DF4vpVa}xYe_8|{* z{1kznx4GQugo0y&^SHoIQu(;JIwu!}qn_;);~N_>-(;rZSU!|KiR-ndl^5rf(1}K| zd{R{!x1Np(UnkN!C3FA@9HA`CLqy zs%4Rnj*ioeg2-DINzNGy6vC0^RlfdoY@+fi|7$JeldA3Vl~?(++mb%1+Ad#tl~0=k zI)%%t{CVI^P+sNhZ%a;8UX*{9{1I7VDKEmwm(N#QUOIWJZPcF-!Eca(;Hy?TVHxc! zL@yHk>NOpASbt zA=#6v-_32qQ6B;@(Culdyy{565#@FNwjXSWSso0~QFvMK@>+i5ilZUxBLX^-Szb@B zIF@vOD1g!u{o#QX-wNf&;pMfw5RNRb`wOKd^UzIb$+VF_Y60m2*>P-e)oUvYHOO!m zhvPo}Q9r-<=Bi#-H@@!^n(H?{)HgM*_o)HAv*K(l2s7sZW?VN|)KNo|%ng>X;|(QQVl>CWsRWHy zVP0k|I!fC!7|83eXpBW;3qRb@w}1KC$?d0qcL}dnG$Zct*a!bH-ti|d$9p2bZGvj2 z5f00qN_2FjPE@7S?E`Nw8~`tDPc{YEuj09;$i{*G@d425&vgvMJ31(Cx@n+4u|C8S z{kiyszWuw_{zLnF>23e)L#E5E$Kh;le$l-wHlC0avUESdhYv#fH+b;(INvvd% z!Iw9ruleb5Z7|-isgLj=F7FS0%0oPWRTDj*@)!^3g*i-lkVk>ljHSe2l0(Iz;mFF`-RfJ_fYOE5>{*jJxjOnDZRw zW4v-^k(ZC@l!u5&UXlxW4-@0RBrm~=m6u17KcE*Pr#c1$Jq5;7ss+q3#zNeB`M1T={it!ocYXYlWV7$JVDAHxnQ^qjhMTYX~%H4oD#wdvE z7?S`NwvP))Ui)|gFvl1JaUEj{z)U6#p1U1m29sxr1PgIZj}g}mmY}}EVqE$c^c&Z^ ze=e4u`PIEnTZY$gbxc*z`oHL-1~;=MbYO3dW5;csrJh+TlA9;#2DHE&7*}Rl!gIOg zxL8dy)XTj0+si}eFINwp>WlKFr!ipg54VAl&Sdtab3Yy*izg(;#j=!D^~`5;yHDr- zYAhR1jUDS-dT4rRERnD(qUpbq9T@*Gn~A5#UWzZ+Ih+KBMJ-K#Jl8QcKFTqA`#MU; zl0#Ed79}A~$W8;}LIPK-BWTP320-JOe zifdm22Bhr;r!zyg{K>udTR>7eG>RP4-MY>5G@<*VE*N^4VJ9sG?dA!&0WB~ULmb1f z1T&_o7y&gGB>Qhj0TiTB z5<`~f$#qGi0ER4=XK$&Ppj@8&hL>pt%cbkcOwcG)E?q~0z)%WA7LQpj&k;t!a(T9V zCNy6bDi_KvOMd7%X_O0L6wFgShKn6?fmuNULks~cWf1f!$4o3I2Jvgb;N|k*nf>Jz ztkTrEtkU4^W$_&$PilMkor)D}?NO2oZPttJm*^T0JbB5f27MKMiFk}f69t#H3 z+%QCYIrjB$RvweHr zlgNM`bvU8c!#^OTr%lRQQ!E zuhWwnzQgAAR?eStm34YDhG^!s)#<0;75My$>U82?xsGb%Cua4R7017F6`S*~FDxPH z>B#_7uUJn{4l(sQH4j&=PCNX_5B1tKk8i<8B8su{Pw6Xxa8BqqYNBvB+LyU(%v}?< zU!zlZD%a!vZISBr^fy!-uf!`F^DK{X(gU6AchHlQctt+a)cB;(#( z&sfgD^$xj^feHKNp;Ng%7qdeI6MGJ{WHC0rEA!qEdmW1v2me#w&O;+uq{v=wK7SgI z2x9SJ=Zg5wwgD_lWO92(vS-<9zKePEB5aXj^#0D3V3s^10nS{a9_-v;)YpTpGe1FmvNnE8!B z8XTs6Crn_|(X^g8nYTv8VQ~O``xI@ha^3S2x0`weeEC^;-NkMU4 zU=Fnu#9vHj*5p~_y#hDNazfZ^Vm^FSBGR`K{BfUvh2RG4ahGd3kGovUdChSxhv?a_ z<$#{cwVcOYuH`uDZjAE4YVbYP>#h=Dz%&B#A6}pB*RF`3{n{1cx?H<@+~wL8u1=8} z1zUZ#U%LW5mupwJvc=URDB~WIjaUugUmyGEFpXgRr?9+)CXF+%sGYyA_kV_M^d$y_ z`c89SKzG%$N$d0v*2f3CKR(!P9PIx1CF%)YqMl|wY~dUt35fF!vEKAdJLJ+Z%~0VA zxm=pFr|Hz_V8l)hplB|hNx%2o#LIu?z)8dwUTOW#f*(ekQ`vM1`u%5~%ni?cpt}9^ zl$Ql1@H0G?{o5D%e{gan_1jb;n`s+NMBg3$Rew*@=vo~oIy^T1MO;KaIgr93l58e3 zkcbYCEO`5iBclQ(2Y%R|4|;Gh`Q$(%n}`DE+|1l?y1zf8;NWmcM^EqIdx`bYIN`LV zdUL}fElCIb^yhxO`s6+DN295}#I9`SP%54q9s$qqO)+qy+%=v-{wVt7vND`3y}Uli z;k6-OTGwHEy8JDeqfr%D{+@MdRB;)>jL3G~$Ps*C)IyUkO-WF;H+sd6myx`N~D> z%LE1v_z~q5T>0HVUK~+gpD2I>et3CJDv*|*KW;)xhK&5-byermYG3#A3J`ryNTw2# z+CI3~;77%YAxLNh(Q!n1;hp8KA&=!%4UT{xqrC9W@_~SSDMP-pq2S2!(yG4_u)exs z;27nlg@I#vg+sv+<#nqTo~@_#ym*zvz|qU=7Oh$vVwP7r6dX%k)!}OK8Tq3JN?R?y zYbdXfjU0KE{;-1PgZMLy!O}jXefbLE$o|l`rh90j{?J$dMqr};&=>By=;1wJ{{GMx zJ^(suM<}~Rr9br56Hej&(6^@R;)MNS2ssloaz}BP`NL;hAtgw6{=xb~Jpt85-AEMv z;35>`p9yjP_{N9MF{2$4V*0f5`tQ=&x9Ld#jmtKj3BEqtbWM>~s9|f3Y{iZp-d@r7 z>*Q14eRBf2A~heZSH5QI%DX9Jqm=LRP&T{VvxXwZir3s5gkBS4Tc0PP#P)+gy?um zPL&6%@gWHXe4s-RUk&c`VHnLJJeIHKR)UCF^gtEccj^|319iZ3of5>sVDJ7ZUm&?c%u~9&GZ+RMmVKpM zzGYKCNs!X=yC{DctHA;A{oztGG%X+3pF0P=HVMn^ zNeQxu+cx9avA#%F}f zE@xBG-oeztcq%sou#v63z2E!|hYdCX20V(}E8`BPJ5qZ9i?)60Snruje?@7eKD}#E z6lo;dh&?iUghe_q;}SNWiwdB-Y|Yk62cI!oRYG(aAJg(5!fR&DUbHV>*JB);U;ziL z+i?{H^c+_~5VzWX6$G%b{VE9JIGUY&WSoJ>-Ic#PIb_X*23TBYpL7XAQUq~ zQ=`!1XeelWfh}|2nRklq90JiU{8}Xgh0|R_n%fT1>m#I3gA_(2{+ozeWpAl*VbG;;BFz({At_`*yo-9|bya((T1ew=h< zd~lM(uu-1NLPHwjLMH}~OFA)9@n-h=0O`Qk^;JrPbYP_Vx&RYvy!>7uX9oO@=&(e} z;7>S|-;3;fY7OM>Dp%MO0xv`s|6%i(gz+JUMgf3HdI}8m#G0e>vT7B3LiPye%c`I! z))bYORY6a#51KElf}RdDURDJ?xkhNdtg7$_&NO1r=zxBPnp@?9N)A)X%- zuUf@~1sdX29f2VpACqs82@4qFO&yLQpC04ZPemmAubQWYX$+xI3YUwPA48T)@XY=R%H_5@LNUL57|y+1f^(Jvqfog7=PUz8 zp>ny6FbbAS@Fz=Sh0BF<%aR{@)*9tP7=`mxkK(k|a&d+dL}J9qtv?P1evXn~7$*kj z_oyBY8lqgjU-y%xP~cwm_E5>8TPoIUwqWp=sD5@BImVzIH{c83>Z^azBtbOj9jXJK zce-M1dic8+OMF1;vS9G`a=;q|hA;eGEWJ7~czgMoceYPQCLWfP0=c8@Tx}6ofo9@?u~$+-aV^#sEiD_H zTJ$8f$}cT{pl0#nC67J!&?Ap&E0!#NbVc~?l}jF5dG{kVUtXf&Eil7WR@N-9T~?!2 zF0NUjAzHX*<*F~=X+hC(D<503@+$^T<>E&{8!;YPvik9w<*SycRP`uscID!*k`ne~ zEfFgpTv7A*qr{GiWkHcdt?VEM@naRkEt(rkGO{9!YX-PRQ$ej_u4maZ)nimciWA9 zcI%^V+UK>oO;fL^AV?Sv)oVnLNqB5 zM@q*NZL^L+P0DFJ-8}Ex$IiTeawPpyro&L9{4aabhk7$vLuK;lo{wZAeL^2S+dQgSiX-xjF6Nzgz9{u?K7WWN<(K(1@>1X?FnMbQ*(+ zfm&(zJgdLC77LBd-ej2=rj<4WU-Oq}{=GaQ9$#zsYJM3`^fWx9srxy8mx7m&QOftHI6l`AQA+$P8X-!%;WdqB^?Q;Ie(mybHCv|MhEn1mIjEB? zCDmMtPKMHE$g5~zDD6hLqD{f!C;8QIim&>u{4*>6dFqeO9Bc=ELe@-ajYn;MdwaCD zR;SO7KdFe`=o&VyT6u4z>zaH(e```4^PxSgO?6wh)`^?36YaJCC$`wFUpnf#plXv3 zUbiPFjyg^Oz4~hL^b*!GfN#iU?|#U#frgzhY|di?Z2-$gqW>A=un3+QiUXGAMA0R} zw1Hln4*Og>59O58SG@JkhYJ8(+r|&>3_>~O@Xy~o_d$OL=(W*-pG$)SZ!elLI5?Ok zSfY)N{EQC{^yh{J4D@8&0mK~~JO@0`i_@{6OXmm9MQ46>@SSXb8|YDgD0qQm5Pc=+ z4Zvyindi}8y34ypsmQ|V{-nqW5f~$j|FCsumQ#zpM zcuEKK98c+hp5rMU&~rScL;Mk|VmBcKz8QFiyfHZFU&>KXUP6-w^fYqPNgy(yTM2p^ zxdn`;gy(hEIG)l0e~zbgK+o}%4#{hON(b~DPw9Z3<0&03FEL{nuaMX9lcR!Ng}frB z@{|tGKMob2I&y-Z<0&2R=Xgqo%wsAYor4mr~=UU^I zmR6~@K-UIL9ev2M-z4a7Wlqa-pZrI+S5m&Ibv}jEc!7|v|KJiYH zUBdNs8~#$;(j;{vZ)w%mH#A0?HnrTNiM+E*S+}WfOOvU%A^$-BT0fmeUbje|M0r3^ zAstE*IZk3wS>O%O#z;$pC?gaAzN=03kv5~;|F!gBT1Np=k{vA#+aGv9=$)2sej3>A zwZEFiMlRIOy2c$1EmT6f$Xeyb2%aa^_<5LOwv0YaqX_5dzz$jIGOBRmI9sCw;?jzp zICjcT|4Ln%gQK4?0q-;WnM*TFcYSEZNdX?!!*u&YwmO@j6NKC(Qn0pSb_Tb9f%vbY9D{IHkI)IklMDLeWf$W8{i%*fwC6;6T`Jx$QHY-r zI+2JCtax-x$4NvY792gT{&?E}a9$=lJS~F`_{nUe6N}Xg;)gE$*Zy;BJDPGmC&2SR zEYQ;eKN;eU{>fxhJgIAGz*U>iP;=Y=nNB(F8>2M4m1Yl$5}0}MJ{=E3f|ZjcPF`Z3llz^%w8=oNj|i^ z6FB1TB)4!hiG1b2IW8{+g_j)yj<`F?EvOeKU%&@`C#U)*bZ~$H0o#fUnj9XK1DqZFeqx`evkDgIV{t%9PK3{!#>Ex}p z&W{+4eo_YFwe*mQr6Cd^^N>XUQ>=c=grmHr}wO?(`SOk1_hZzFSIIuv*cuA+j9lHn|lR_)_*dMB)Rs7<1l@Ou!(Jwu+a>)wp1&Adpx{0^e*ffyaBt-ea z<&Q4@cVe%~LHs_;)6U2Z6-`` zABLZ~;zMb3cr7mH>3ah^***3(IQuOg`^ec|OYDcti-@04TNmQn{HxZg;s3-|t<6SL z1WMBq+dlz68%-E~il3ad`#$U~-1|&*-TRfmA05B)+Cc9MzZ~fAd5_|cj*ktcdVAC7 zD%vs>KelLh8vb_&ay?(9_`|v0k%8V`!q0&JwZplAOBYU`y!SWNPXgc0kDXt;f0epm z=0SX$|5YqHk%`eyC(>6J$!d_kxF`_79WUEE z;~PEJ^_tIL(~}h~%?%q`Ew_qA=jL2WxNpL{BewPSxmrWrhRt%-9jYkBZefew$e&=J zw>0vjN(LTP@>)GlP|F(_H8QM%C%DCbhN7nXtgeP9mB^hNH)|RB2U?@$ruOn zjVk6pjN$d!W`0>pxWy$Y&&)Z%>E@TCyyfH;m!f>0g@j*Em!bUSKDfmtsHq3x9#Yd% zc~IRdj&PSvsn|7dNZ>%9d#LtoGk@2H9ns+K=I_~*l~=bP20!$U4LcMJ9|k}4ehupk z`YxY^S_^tV??^BlINQzNs{zfbzz}VANi#$nS<>Xs9~}d-sClls)jFfP)%s(uoVl$? z-lx~}7HpN*W6iNutZaSsOOg{eFjDcVuZsSgU6PzwOt+=iKgJcwYm(%i0;`OL6}7Ri zQIDzAY~c(k^!57zVqE*#A5{c@n~EF(cg@29Y};$k0mm_{XIQA*68p+Jal|4kv&=6-gf3n-=T$>PYv{eADaO`HsdCj z*^h8nNz6WBFNxWgwn{<*B1RwR5m`w{#1atniwtyxdM>`8As}M8Ni1LZ+7BbvYGtv) zA0~)gO5#fs0pDd#hijAJ3lUm40Ek#763Y$?G4+aTume#wQ=&Ej|m}!Y&8Sg+b9Rz;MlTDGPC%4KuXPp4b7aSt> z_03vkV?)y>Xc1Qx!%QlW5}rtC#{(1EUo{{t%V3iDz{xdARA=28er-qF?sJ&MhrtM%>@>6>HL-2T3D~9 z+ZhzI8oTZ8nxsQ6`^IM5O1hjzF+=I>2JT9mfLtyGPgDSKDkL?U%{umhQanPEtxb$) zaj^+L5g|d*M$$4g@xz@TE^zGqq_ay89-67KM9bfO(C^swY0ECyxpNrlw*6hU-?87* zmhCt=Itl6WQ2R~~LPtl(ATJLU`$^^=4?;QRL=PxCc6ZXCOkAxc5ghwE*s#GK4$@5_ z)Ul%jAP-F-FrOKsGb4G;5S<>$YmyU$o}i_C*L7r!%-MgN|tBsm@%Xa z%I>Si6iVs3uNU)l3x*Qqd~uO3=1uuS3+H6v(BCVcaRTI%p}`tU>2PuBYtN83r zqzjM_HNa*6EQEBC&)9~*862N_`ZUITRT|PoPFh1L1H3Un5xNGk0`f?$axyiBTPy*j z3(5igfUS8>mEi^pLg~~`KtFD)yncq;D*>d-L*?OH^9(B!p;W#BO&-NHPqgw-k*;4q zn5(>ahPWEirF`JUYtFzK(*R{8FDyr1d6E0#U4O{$pfSwLzh-CC5+z4FK^&UdjQ2Ymw4i;McHhK`?JUPz`KV#zmhCOAc;%%* zi)_S6mn~Rl!)cv5em;jl!ZjCmOY3$#`@%;YGyu^Rws@AZaN+TUnzQ!Rb#vt4aM{*P z9pNURU@2NtFH{@Uit@gTdIUAxbpH=vX8BzkI1DE*_U1{I5D<4t&P@cMoTF?M^3B zGlmEDT^bl3PWJ+nKQcR*GBCj>$7~_Y;o*VAxPh6)W3v{_*Eyz09h34AVE&TRq(^5J zOz_!{)UzjgxkLkfmwr7wa&Ipr;*ZbPnW=+M^3W(p<`VJ-Iobw)6#u3HpOn*MDf~q7 zPiA~pZk&Ko@)+i7%Kdx!x+EL?FI-e|*ifXm)q&~d9j)5ia#XEVs{YUnLg;z1qTn?& z74vfy-ip9q=$IfPu&tQ%aih}}K43m^3nub)N2gAyX!q3pv=4oKm1kW^r{#>rO;db+ z@Cki{2cBQ&D-UX(!?)v(aKPs|?5mNdAG+rIe>RUz-bhos zU{*u5Ay`$;Tlj$qJ_8ysHC&3-JkxGphSW(3A~2Ox7XtH%08;m^^BoD!AxzK=E2$sQ z{0HVS!UUfINaQ(MGNod=r~KDT@qMa>M0+hKFn}4*^V7&q`6a`r)G++RXXK{=#u5d& z)iN3)fcE>8I}va*oX?ONaoIXldTx~~Ci2r8tbc=N zgv6fD2S;X9=>ng=h2hvmB_QaI2|j&VxKpK>7xM{!5L*-z(*&Q8sF>89<*rb-IQ4d9 z0lIqrVC8O2%~xghOP?E``Eve=a;Pv@sJP#tW(@gx^L(F*>3)-%Fj1P-DkesbN(!b^ zlzXiSpb@CzGo8rKo3(H;nBWtNr!+HaUYerZRZJz4#VPVLX@R+WKB97WPn`Y5Rg75H z8sEFZj`y!(WMvM=CUE^h#&zl_uaNs+d;D3%xL@B!G}m7XZVz39xvo{ya3Y^yEm+?mk@($;HpdciarZ1lIv?TfiixGS-ASMY z-)o+_@j0Aa#{Q$anQ_(GAos58toJQQD?RR9Y}*mR76wkl;i}EH9d(UcHf}*Bfx=O` zzM)TFSs8}S7-RB(=7|(@nS6o{u3&JX&dCwB(g7(1SowP4-rO4c;niWUEpn2}6S-3C zL|0(HUgTt#V}DregjZm%EppN;`7UzeEBP*R@+;KnGOG>HRa=nr+`tdVL(aFD3$owXc&^Koe;AjnFg8js)vpgcAHNR)6CP4cG*Y zg+!pRo~i-g<VCcZ5vY+}FhM#b#P9yS(}Z z6&2a6CpK(j*~Nk_>&gB;dIiET-e;${(w6lk*7c3~>SDrVtX8-fSx-Duk7(6OuvEyQ zK)6%Z6OSKCc$Kg`*s`AN^?#!%Y*9}jWl@|c?NZ?+k5g@zc~BJaM^aCe^x#x(hN}Vj z__lOEMg&<;p89uFf(8uQ@b~Az7X8WI=Q>sF(i(Scy`K1|s@T4K*rGo{JyEM@K5V_7 zbQOm!`;%o;&HfncX8AZV>WPZ2WRJyZ=Jz}c+}-o9P*2<$VV_ycKe9#sT)8^zf&o2s5>0J78!ai`adY;Uy2%tXjVEp+_HC zso}uU(wfCk&34~Be#3>FRdC@l&6mIQNX>G1?lhD}Vq@G$Mk=PE6D+tZuqBd@qSyB%Z#6suVx&lMM0uBFf?5W?}nm0c!?fr3zND!m488RBRj@J-NtbfvD z8Tnw8wNYmp2nQK*!%jOV*P+>RCaL;48Q=q2%68+!_r9G0;*3+Ul$SxuDAWAksR<~| zrf{M+ha8qV@UK#rj1nxSE*&GD)ttHc$9Xf5WHj>aF^Wh&XI(PJFa{@-DLiLhBL~GY zAhUFcQJ3_BD8)mYAHf*Lr~pfd6E!PLVGA@yJp*t2!biewfo#8t_@^v4vfU`GUs4eH z3<$3q1!^mw*>*npq0x`;Hm5fz7$IdMUP#peai1~ZA&FenW zyP76>Q>B}XMptIY$lD9~oGr0HmH2OzR}{;jC*>Rr{Ci2$ zS7Dd#I(#X3&3CUkwKClszGqLD0(eBKjYe+#Tdp}bt|?B&0yXDGJy#r^iT6DUvShNe z=IEvDtU1@Al%37o=pX8dHy~bTOg4(Cz^8T|5ho@e zA_t{HPmo%cGAO{1u8e$CUO{qD#H%VnM{-wJf=2YOQ0kTvysAk(U+pL6H%dAse^XFu zLgiBPbjj!J{PPd#Jw|c{9cL5XCOIj4&W)1-rEHLLcK$|N*eZ$Ngr|$Gg?kd#;3bf(xd76CVX)dgraC8ILb Q5|L8i{uj@ifA#Yx15Z%%Ok`Xs%HfMu zTw?aMK&l0%Xc~}Jg_7!x2@cv0>`*s^I2k*v37Tn#{zTTj9uPdZ!Ztbwr)sNp$St*| zqFM%}HI7RO4BHECpDLu8lx9LSYV=J_O|cg>)nfUwRT@XGRvh#5#h_ZNnOI*o7hQ1pytf zpeZa)E~N*OElJBK!H4WL^_(=Mo2j{t*XhlB0G3Ix1RbSK;9HQ^W7DDEY?tvZyb*%L z$w<#x&`aHoD|%VE7}pOUBGMmd&9zAZ#aOs zt+D{#F7{^p^iU;K0F5xdr{*qpIo3cQsJ67g`Pw8iem1i8>`C_E=wx^A>^OTIY}s12 zYP*+Z@3VeqcW*fOayS~E9FL$6olk?E{Q>k}b<=U1PNTiEql4qYA#8WM2{Hih@c%mf zp7DVYIa6!-z=tKv!(?G=hzf@#pTp#{zn$FvJ52g0t#7aNh))p2Qf?5yMdMSv2M?_y@vVl&Ww|_WU;ho+V~nm)6-E#|M=tljl`cGCyXowmOo zGh}qj^R_lgsJZ33cGvH0gP9ea%}uAvN^P&l7CqZ#J*&B4t=YLu{(f4<-|pE{8NJz= zYIpMi7RxTy&002>VPSWyw`(_U zL#uNc1c9}E=B+zhofdQL9yEc+GNB(m+g~NZWu|Xh8+M+&Ic1Xrau5z;5u^m?6Oa~? zquX-sz~7e7I*zm9u}*u#<{7l=AQI?bV^*(cTdtSMXk!|+UuwV6#@PjJ^1H)hrj;Av#;Fy=+D48JowBxxcAB7-49>}w6yUsn@M-tpFP|RXdAG>&~ z_x7%~OwpVyPGs5mg>36h!g&;w><&@RzcBqTP~JUHlxa?3)4QY(r*NrXWvAZ+MMx3y zne!K?dx1WX3mf5t&*FPjyP*4%u_WPuLIwqma2`uimM>`96CsDDkv`Cw)D9Zq;HOAt zP9q#h$vm(N$Z%TN2q%0N--MH(04GIBOA+O4%opH1EKz_%@lq&c#n&YY^noi>3i(I& z7;qr4Hq=h2iYR863_=3CG!A>XI&^nD~ZU%m;xL~eI+7jK&CuYXE$GIB_7})rcxt) zq@Q>soCF2>@Y$WCJzXzW^9{4!U_0KX<*j3z&bKVzqOE=>!_f4)*|^DSW}#Xua?ZSX zzRGkIRE3&pG)$$tVw6qBMM)ey^|DdFF<+TexCF>#E+<%Zqf%sgWwBJ^u(M{PaDy48 zg&PJTRA>9kMx!v@?5E>oAF-?4?98($ZKx#Um7(Rj*0vxh9_^Xzy-uWy^W;>^E%TDRq_aa7mdbZ znKhuc8m}gbN#9n~3w${sVo^{Cbw`Nrq_mGTWwHNn<8jtt!XOCWW_97kID5#C*ZV0$ zWAV=PP|DcCnTm;lpYkMbxt6;f*oRn?2|6E0BX{*p-(29s*o9P%TTL~hJQ|8_HFKe46wEj{ebJ>Ta`WO3IPRtS#tn>4 ze=#4;Ao6O6KU{lBFoqUS;Q*8}VF;9k#wh|CynK{|e+2aeAx zk^NERTpTh}q5Hxk*T=69FnT;a)VV{`aINF4Se;iaw{5L-)Km>ZNYSe=m1nA@{DM*V zu`y@zv|3)Kb#1OxoiR!;8nt<2rewzICvr%?xmfM9tI(Pga_Y15m0~nP_Ew?9H>a$+ zNUq^L+qOF`dWYf3(_T`xVAQyVb7o_9-YgaC3ud9t2CERKzFshj#aOy%)(f@yg+{eD zOkD9PVoF}^TAPY5CGEgLj^q1^SR&<3Sn`K(8IJpWzv`)e2nSJiGvP~`^Wg{!eOBbq z6DqP)H*9%SG^BUQ0lUzZ*neWbJGO*~mX*bN|0+W4v9u5Hjfw11mdsJAiP)1goV2|R z-2~{hh)@qQ%DQ#j;uDF5;?kJIWe1PROO1isAzmbZ8PZPE{O^yv2O?zq5G@agda@q`c{G_b&NgQ9OE-dw*H)`>1-dr@~ z>U+3Ja_JDH@TlHE(I02OUa2-tJ#|K&I~bZTj8Y_`V~@Oo4G+c8qfclWLiFGcK5{N# z*-38C)90cejBxfgH1Jl7L?vxHb^?DU^o=$_xu!9ahk*1U#$%9YmE9wi5 zJv<%o(`Z!7I0RvL#SeZ2;-O2-qTmRWP;}6dm8Z!F2cM|s9R1vr&_IktyYBUqAA7v* zuG8J#l>Hy%qq4&cJ{gBqw;a--mNW~jl~oH*B~fTj zbLvU!9>Nb_^J2MZ(+(bxqx?{H{F!ICnIlyy{m*UxzcWv45_gcYkB5#O9=B+bNcxq( zKT3L5;tn_OaG2A^Z^TniZ1IjXGe3 zgX+0NIUaaOp3S4BxjfwcmE`}s!a^>}6QiD@D!-5L@ttRc_+eY!a(tWa%Ef(gj!9R= ztlRD|oo;_8pO)!4y7bL&U>D}^l*hF*+BdbcsuPYttHp0A)1y_U;`kbJNPeV)NTUZ#tSr)hd13V%yZ zw*-%e6uOY0%c-&NhLms719TJDb&3?f=u#+nKQ553&;z8t+QaA9X3Eu>A6=ps1r^>w zLvjVe;bL&y`3WUyNY2AA2}puQ;vc+=C=t(>sEa5Oa+>Gc#6#rtpwCd(F+)60JR}|s zn#TD7@hCVE&k*IgfyW@HH5>(*hxNqB{0@e!;6sq&++?Cewm*d*syBGTpg$e)vD4>p zmxd!vBC8`!_=BR`bHuDrqCBVjb&kV5quBTobrD#U)jtU-(O9YEeCT&c9`?L;>*v4! EFK)8%)&Kwi literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ b/internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..bce6cb95d84f6b97ea92673457cc42b3810fceae GIT binary patch literal 9188 zcmcIpU2Ggz6&^b#b(f@dpen6olAC?W8e+G0n$|L*b(%kd@`H*4JXl2I-PzsA&hBh? z#&JRsSyio+w~9AjkX(2`sw~ViD8UsEMM6lCc*RX$;EA;A8xk_+JLk^NnR^$Ky5`E+ zo&DyX@1Aq+ojdo-`EIr6cVkr#dn)##*zYt{&8tUoZ@C&Pw^LJb(^GyY>Uz}}eOCOq znRh5v+$dUZlTmfK*Yi4Ya1))?sj%G+JL-ZTb=8%~>#43=ZMh9^qBOaaR*G+Sy}42) zcdX}CRmD~1rWXVux!Ci{YL2?8^B3m2q2GzU-b7_d9Zyg{m?NwKR8^|#g&eN?H@d)T zYG&$~K!ebwWZ;gcUYHUzb-F_qbu}sA$ZvGK+Dh1~skxr#)+WOaauK6nLoG;NmpGg1 zr5s!G`SVu@Jk1c@NT40Pn3{l<;N;&hRZ=s^}H@T zLB>jH9wRTV6ELkRZMWr3Qa0y2O27n+lVm4z&iyo{i`nng!WHD(ja3katw;ra%i|?d z4>1$C-%xJ1>$$zCRC0zKYHvEfaE9J9THm>1wD|#uVf0?#v5~9W#kS$t$a=BMcHdcl z|Nizi{yuFWy4wj!(Z1soB#Or*3WFl6X&^J zP(Vo|o~KP@@ma??nD%fS@&`VX+esrH{M3t?G2(%h?1Q+#jHIQFc+zYAO*{qy9t*Lp z2-%zWOL+DR1Uxif1%#sbl0e`OQc*-GKQd$Bfz`0ELR?^$$S%f(ls@6irlV0@Kn^&k zGX(yW2pJK`;+M%EX+@Eah(6!}GAa=8z-nw%GB1Mp&}e}t9YueCuK6L`U%7_ch|EIVfLl`e-NuvCW;+M)1Xt<=2KUghtmw-Q5QL+!>;#HR#(N3b*VUB#iyHhTG0nQm{ZZnAMq2H#A6`v$9THI0|bv)+K30cR-Sm~!OkWT9ar`Q z@(xLHNd!Db?C{4xz>|)vzjyw8!M$R}C>zDyZ@_*CtK#mrXd!DrjQtP@{?bNyHjv$o zOOB5D!nnqK8N2a7f8e2<9q6;3~0#D$s|2HT^tE2r|F!2Fo6c!zJZM zs)NHn-ApX%J0C~WcY9$Q;xmyInO<>gs(i}r9D#)KAVMKQQau#~VO-9}_ddh;0raR9 z=u1u3BkKW{;j1 zEeEmNF=v6~9jm*!RL8wFNXM;Os_i=i5L30SS~_mkQaASoAm;P6YUw!e+`V7Wao{m@ z+&xRjfydBs;4yR@cnlo}9z(~0ho5r(xJ93ZxEL7}m$}=lTKmtcwcFfdWWUgH_t*-^ zm`ZdUc<{cEIu1PaLJ>L+Jcf<~5B5x_oa;F7Fp}#y@UT^`D@VX%=s55gI&K%^f*VF$K#aJMRjK3jd`W!@e+(U`*R#}ddcLHN)AJ>D+%CrT z7{U-b4*t+dP2rzzSaqh3gFn>gMB0U)FCbFKB|Q1EBObCU=T-^Nc#iC1Tp1}}(E7mz zIgm8+$Ix-`$Ix-`2hWbQ0*`@!$Ix-$F?1Yw@Dzwf{)lZ2cgP>nK_lj=5%AMxI|py6i0_RoZ@W6 z)L%P2_u4$96Lztcs!gxjqRLDY@(pz%s2dl>nyMRnwM=>}l}hdKx~}E4!{rE9Tv$`F zACpvcdt43dLN7#I@F{4>jOP5pRV|o&5}eQ|q(ZzKC@`h9Bh=_hRE>k!)Mcs_KL{Z4 zqHc(4BTG~l!Xt`RHSEN$-+|{xHBI2PQDRgbx9uH8AQ2TJU8ol=Q;(+ct+;fj8n`{L zrY*IMg$yEZay3~GTu@V1*vo_->4{M4^lDVeq#M!ADE8VMenk^hsmw=iOiWfFxihaO zrl6pEH(4+v#VWZM0Y1pE9a<(+4?Mz)`)0Q-CaZwu% zr^VrX>={l~itE+Y!ham_UO3|Hah`JaUc7wz%xjlYJ%U}^&vvBqj-{2PRD3CXO!K(`3VnC(7ar9K4PgC3__4;kW{)Q8NoL2aHFsZW6? z>+?UH=KvqVYn$FvJ52g0t#7aNh))p2Qf?5yMdMSv2M?_y@vVl&Ww|_WU;ho+V~nm)6-E#|M=tljl`cGCyXowmOo zGh}qj^R_lgsJZ33cGvH0gP9ea%}uAvN^P&l7CqZ#J*&B4t=YLu{(f4<-|pE{8NJz= zYIpMi7RxTy&002>VPSWyw`(_U zL#uNc1c9}E=B+zhofdQL9yEc+GNB(m+g~NZWu|Xh8+M+&Ic1Xrau5z;5u^m?6Oa~? zquX-sz~7e7I*zm9u}*u#<{7l=AQI?bV^*(cTdtSMXk!|+UuwV6#@PjJ^1H)hrj;Av#;Fy=+D48JowBxxcAB7-49>}w6yUsn@M-tpFP|RXdAG>&~ z_x7%~OwpVyPGs5mg>36h!g&;w><&@RzcBqTP~JUHlxa?3)4QY(r*NrXWvAZ+MMx3y zne!K?dx1WX3mf5t&*FPjyP*4%u_WPuLIwqma2`uimM>`96CsDDkv`Cw)D9Zq;HOAt zP9q#h$vm(N$Z%TN2q%0N--MH(04GIBOA+O4%opH1EKz_%@lq&c#n&YY^noi>3i(I& z7;qr4Hq=h2iYR863_=3CG!A>XI&^nD~ZU%m;xL~eI+7jK&CuYXE$GIB_7})rcxt) zq@Q>soCF2>@Y$WCJzXzW^9{4!U_0KX<*j3z&bKVzqOE=>!_f4)*|^DSW}#Xua?ZSX zzRGkIRE3&pG)$$tVw6qBMM)ey^|DdFF<+TexCF>#E+<%Zqf%sgWwBJ^u(M{PaDy48 zg&PJTRA>9kMx!v@?5E>oAF-?4?98($ZKx#Um7(Rj*0vxh9_^Xzy-uWy^W;>^E%TDRq_aa7mdbZ znKhuc8m}gbN#9n~3w${sVo^{Cbw`Nrq_mGTWwHNn<8jtt!XOCWW_97kID5#C*ZV0$ zWAV=PP|DcCnTm;lpYkMbxt6;f*oRn?2|6E0BX{*p-(29s*o9P%TTL~hJQ|8_HFKe46wEj{ebJ>Ta`WO3IPRtS#tn>4 ze=#4;Ao6O6KU{lBFoqUS;Q*8}VF;9k#wh|CynK{|e+2aeAx zk^NERTpTh}q5Hxk*T=69FnT;a)VV{`aINF4Se;iaw{5L-)Km>ZNYSe=m1nA@{DM*V zu`y@zv|3)Kb#1OxoiR!;8nt<2rewzICvr%?xmfM9tI(Pga_Y15m0~nP_Ew?9H>a$+ zNUq^L+qOF`dWYf3(_T`xVAQyVb7o_9-YgaC3ud9t2CERKzFshj#aOy%)(f@yg+{eD zOkD9PVoF}^TAPY5CGEgLj^q1^SR&<3Sn`K(8IJpWzv`)e2nSJiGvP~`^Wg{!eOBbq z6DqP)H*9%SG^BUQ0lUzZ*neWbJGO*~mX*bN|0+W4v9u5Hjfw11mdsJAiP)1goV2|R z-2~{hh)@qQ%DQ#j;uDF5;?kJIWe1PROO1isAzmbZ8PZPE{O^yv2O?zq5G@agda@q`c{G_b&NgQ9OE-dw*H)`>1-dr@~ z>U+3Ja_JDH@TlHE(I02OUa2-tJ#|K&I~bZTj8Y_`V~@Oo4G+c8qfclWLiFGcK5{N# z*-38C)90cejBxfgH1Jl7L?vxHb^?DU^o=$_xu!9ahk*1U#$%9YmE9wi5 zJv<%o(`Z!7I0RvL#SeZ2;-O2-qTmRWP;}6dm8Z!F2cM|s9R1vr&_IktyYBUqAA7v* zuG8J#l>Hy%qq4&cJ{gBqw;a--mNW~jl~oH*B~fTj zbLvU!9>Nb_^J2MZ(+(bxqx?{H{F!ICnIlyy{m*UxzcWv45_gcYkB5#O9=B+bNcxq( zKT3L5;tn_OaG2A^Z^TniZ1IjXGe3 zgX+0NIUaaOp3S4BxjfwcmE`}s!a^>}6QiD@D!-5L@ttRc_+eY!a(tWa%Ef(gj!9R= ztlRD|oo;_8pO)!4y7bL&U>D}^l*hF*+BdbcsuPYttHp0A)1y_U;`kbJNPeV)NTUZ#tSr)hd13V%yZ zw*-%e6uOY0%c-&NhLms719TJDb&3?f=u#+nKQ553&;z8t+QaA9X3Eu>A6=ps1r^>w zLvjVe;bL&y`3WUyNY2AA2}puQ;vc+=C=t(>sEa5Oa+>Gc#6#rtpwCd(F+)60JR}|s zn#TD7@hCVE&k*IgfyW@HH5>(*hxNqB{0@e!;6sq&++?Cewm*d*syBGTpg$e)vD4>p zmxd!vBC8`!_=BR`bHuDrqCBVjb&kV5quBTobrD#U)jtU-(O9YEeCT&c9`?L;>*v4! EFK)8%)&Kwi literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspect-macro.tedit b/internal/test/env/inspector/hand/inspect-macro.tedit new file mode 100644 index 0000000000000000000000000000000000000000..dbbdafb56a06109e8c2c006e98149c5ff37d2e71 GIT binary patch literal 6003 zcmdT|U2Icj7=Bv@s}tC1#l#rJugi327nt#rxJ-iQ^oOn3wP$T-;)ThUF~}6z*{Jf9 zvbCT|YmA6DhC~Q%Bq|qXSD1k7MnT=b&-cF1_kQQ3Z%?>quuqJVUHyY3+Pg2>w|6)3?cFE#_C(3M-93Z-q;GGucW_sC zPj5{)+C3OWESvW9?GuUE-SbZO?%tZ3=s~f!rG|C;TYP~H0`GpEZ}pNoUm)TQ`F&xb zu2G?QyxV;NZwFyL!Pc-qSU%uu=lzX@4TcEo?datFczFZAi;e~)qI*%-&i>tvIBHm- zGa`h7LYRd3fagu(_qK+~7UJbYVX}!tc%PqaByGGeMEt=(EAqqMNJoJy#jjy~fw16p zM@WMd0rhU!aIpV9vcGT79O;qy@Tu9NkHMY;v@|&4h)zR4nhB#bcqauSdR$Q)h1EjCXMopssHmXC&vB zjx#P(R@aF;GVA!Aon|c5b)pa}5(l zto7U);5r<{7PqlZH4D$Nz#>MLwHOPZ#}pi;kR)bSfCCP6+=yF1j-{}uE{GqISk_G3 z0bGjXtYGsvq529nO9OQ!WL;9m7l6B8N2w>s7uYVVk}fI#nP}cSOFTExsR2w zLM&yUtc}||13674GE!z_6|Sm_x?TmdQs@#*F)j1+nByte{Vts{&*qhWO=?$jSUPT()zTEE6# z$APQc=0IH#FU6wg=%{Z)mf*D3`|LDhx1`=uBGKQWg#A+6C)+@PU9_tWj@DZ*fQ4^D0Bek4FGzu&nfGdo%0oTqLs9(XDjSP zD`;vvBT!Qlk^eYI{dl1TZ|B{iV3@G(U?5BySay47z#Z`g14R1A&`4;bAK=@)VbbcA zx_(mV{u_xV0{vf5VOI}PNP$JW|I@mvo!0GKFkt=q3C-E$bZ2G6>FR9yVs=969kcly zq#tHaO)m^9cw&4Yp911@*AL}y&i!`vyS;Y>NLODtcl~gF?$)cn zzH;j>U4QgE#o4P@7bqTjc=-G2NBKFKFX8k>#J4cspKEiV=zU0q8}TqTDi3K~KhD`QnC5F! z`SqBdUrgnvSotZ0Ch30BV}*`>$}bHgruj+(`!VRpRn1BadA+9$rt9_fV|09?!<-7!_3HD{>lstHbYk3( zo-f9Ts`WrVBe+T-j9Aq9MJB1^-_v2OANjKxC4qcDDR2?J`u!O6<6=e$An&(HhXoa; z>(zWc9@F{tnDUpk{vI+ri81AY`aOb+6d|pL4vR6tJ*o1Go}??T!egF$E>44!ns~^c zAu2!JPie^YD~I)bin)Q}BPFlrQlAkyh7n8rRH%?bK7TG1%4qqUh#98qW2$_5J!A61 z!nbihdcGb{D8G$#qWb-m>^VcfpzVXr_{vqDHscImHTArs9jpc07!q5q7doqIGt6l9u*N&I5soNgdZ29Nfs2XkFw~Lly UUfUP{N#4dn-ls2v{m}Wp0hT}Dng9R* literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspect-macro.tedit.~1~ b/internal/test/env/inspector/hand/inspect-macro.tedit.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..05087e2b91ba2746fc4fafa98876924de63ec931 GIT binary patch literal 5950 zcmdT|UrbwN6hH0QsC9$eiit61eqE}x4>PclNN~a1(gIzeEp0LJ!Gwmf1)Xq#>i(pI zcGILaMw~BZiCZ?dMCHNoG?PsV3rqAx7oXHDumZlAjI~2DwjrzMySKf)y_Z{>h$enX zd%xc~zweyicfNabPwVd2SbPj)6w1`j&Q;5cY;TH^!m^VuBSn7aX6b@Zf6IvI6N(WFR|F%u6A3Sl~_DJ zVsUnK+S>5)27c!p)ksA5hOR^XN31yX7H?<3>+^X1#AkCm-Xv|#7C)&YPMgn9_K|?i z)kbPbtIg#jZ60?E^8L<0N0!US*IQg}zt`CmAk};Xt6sl%?}`5R$g$p|N6AnRDhCbV z&{RVkXfh>?aTqUUKxYXfP$H`YS((RB8f%27Jt<0Ff#J$bW-61QELG|XtglkmR8iJr zSbws#|ME=Y=f%t4e_ZniB`e2c7~XyN$MchkpJvZre?QfuWKhcrjHKS0ot#X}El!>p zPW7v?GOGe>eR4{bg}PQJXEEa(pHU?i>Z+WaMfG#2ezYc~mT^R=0xgH?Sb@xw5y3m9 zN-FsryXbAZ$*6;_O&HW&2gwpx4Uml4tEZ7^N!zPqA8ov(0lI#;e2DrivCHOG6&C7} zu$;R#j)l6u8v8Oro$0YF&W%Zcy1q7E;hmR^SL~{+u5-%*>+JF&H5TeRmyH!S7GWjh zM!ph&*VC#QlPVsm8S5p5D)TKr$1+a@;5e65$p=`~uGm;vEBYOAMwNxSN@69wV`Uyb zmTD+^jvdBqMoyK6x;mCi(PhfTDyBYZdS-DnvRNgPs%r9%f9D)^`2@L{Xu^8k*UV7$ zO!WRtWCw&z^V8+f$P6I0EJsIOarl7V?@Ux{W_JPGVI;bU&SH|X@Eo%&qGV}vvG93} z!x;)mbYUA9;dsYx2TyPs4FVy;xoPo?4v!T z40K_tON@oOq%1AQLiK#C0#*_$KtnT+uo7Ab#|_h!5uIZoT~LW6pBY)%tK=fBSJo^R zI!_Z#Tl_qxZ8z-|jZkGs0-s```ql+fKd_L`EIg0q4-EvWOpL&4GU*J2i5ny={&{?9 zJFWVI#N6!-Y%ceE&GVEc&9@H687ew;0=s6nAt;q74v}TuqW(@M` zHF*+!4@C_(TR&+8uR*gI8%6aCrpmL8^#kG!fo#+zStGd(3as+y@r43!4s7u`=E4@a zHbAxmP;UUxgMCg>zu;Ucu@fz&T^%p66D^^s?F@ik9}s>O@cnqU1#h=C`8?sPW=Tpl;!e=%4IZS>u?cBh}TIQg!hWV?SWDTqLS7nIo5LkQxaDct`>S=BDe zcJ5VR`TD7Xvq{U&N{JKYsl<)c6yH0hGHFPxr7p~^j)-`8?U!%v92;5M-EiReOvR^w z`0AaLnY&BB-Tt=kffo|x*RS3=m07y?+OMzPdqCHpxkhp7_U%=Qhu2PhH@BWy68Jn$ z+(3K}qjK&QFVb#{IKVBPoJ8_P!<} z@pEjHVG_2veu~9cA=L2qiyVt|^izI*C^5~K z9~h5zGNOUjAA6P}n4^7&#Lv-=LxLx0Z&84;i;!TB_6t%h&gn#{SH2&Geq2>A#t_y! zieS24UOz_0Co;@RFkLS_AGw|hkxM7a{mA)Tm`GX=X+)pChK(Bm13jMg45d#SOt&w4`1k?3Wz8p`;{BlhBTUvhyS)9h0!a)5Fubt!| zt%nSAVQpEBb}P9?7fd zH;Q*h4xggk;gy%cHmHIf?H-5I=Z5TGCfGhJY+8WVp_cw3YwK(aG<)0uQcEl?wx(7a zsjb1kT!m>p&H_$fyUUG#%GO)0xsZIaI{Lj0KTpvKMiji%vLk01rxR*n=meEK9l-CM s_I8i`;49d|HM{p~{<#vGo6jQVeLH8#<<))hpX9Y>^FBKcl_#(L4e>SCO8@`> literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspect-macro.tedit.~2~ b/internal/test/env/inspector/hand/inspect-macro.tedit.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..dbbdafb56a06109e8c2c006e98149c5ff37d2e71 GIT binary patch literal 6003 zcmdT|U2Icj7=Bv@s}tC1#l#rJugi327nt#rxJ-iQ^oOn3wP$T-;)ThUF~}6z*{Jf9 zvbCT|YmA6DhC~Q%Bq|qXSD1k7MnT=b&-cF1_kQQ3Z%?>quuqJVUHyY3+Pg2>w|6)3?cFE#_C(3M-93Z-q;GGucW_sC zPj5{)+C3OWESvW9?GuUE-SbZO?%tZ3=s~f!rG|C;TYP~H0`GpEZ}pNoUm)TQ`F&xb zu2G?QyxV;NZwFyL!Pc-qSU%uu=lzX@4TcEo?datFczFZAi;e~)qI*%-&i>tvIBHm- zGa`h7LYRd3fagu(_qK+~7UJbYVX}!tc%PqaByGGeMEt=(EAqqMNJoJy#jjy~fw16p zM@WMd0rhU!aIpV9vcGT79O;qy@Tu9NkHMY;v@|&4h)zR4nhB#bcqauSdR$Q)h1EjCXMopssHmXC&vB zjx#P(R@aF;GVA!Aon|c5b)pa}5(l zto7U);5r<{7PqlZH4D$Nz#>MLwHOPZ#}pi;kR)bSfCCP6+=yF1j-{}uE{GqISk_G3 z0bGjXtYGsvq529nO9OQ!WL;9m7l6B8N2w>s7uYVVk}fI#nP}cSOFTExsR2w zLM&yUtc}||13674GE!z_6|Sm_x?TmdQs@#*F)j1+nByte{Vts{&*qhWO=?$jSUPT()zTEE6# z$APQc=0IH#FU6wg=%{Z)mf*D3`|LDhx1`=uBGKQWg#A+6C)+@PU9_tWj@DZ*fQ4^D0Bek4FGzu&nfGdo%0oTqLs9(XDjSP zD`;vvBT!Qlk^eYI{dl1TZ|B{iV3@G(U?5BySay47z#Z`g14R1A&`4;bAK=@)VbbcA zx_(mV{u_xV0{vf5VOI}PNP$JW|I@mvo!0GKFkt=q3C-E$bZ2G6>FR9yVs=969kcly zq#tHaO)m^9cw&4Yp911@*AL}y&i!`vyS;Y>NLODtcl~gF?$)cn zzH;j>U4QgE#o4P@7bqTjc=-G2NBKFKFX8k>#J4cspKEiV=zU0q8}TqTDi3K~KhD`QnC5F! z`SqBdUrgnvSotZ0Ch30BV}*`>$}bHgruj+(`!VRpRn1BadA+9$rt9_fV|09?!<-7!_3HD{>lstHbYk3( zo-f9Ts`WrVBe+T-j9Aq9MJB1^-_v2OANjKxC4qcDDR2?J`u!O6<6=e$An&(HhXoa; z>(zWc9@F{tnDUpk{vI+ri81AY`aOb+6d|pL4vR6tJ*o1Go}??T!egF$E>44!ns~^c zAu2!JPie^YD~I)bin)Q}BPFlrQlAkyh7n8rRH%?bK7TG1%4qqUh#98qW2$_5J!A61 z!nbihdcGb{D8G$#qWb-m>^VcfpzVXr_{vqDHscImHTArs9jpc07!q5q7doqIGt6l9u*N&I5soNgdZ29Nfs2XkFw~Lly UUfUP{N#4dn-ls2v{m}Wp0hT}Dng9R* literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspectfieldflg.tedit b/internal/test/env/inspector/hand/inspectfieldflg.tedit new file mode 100644 index 0000000000000000000000000000000000000000..51f1cee0e983f186255572640d9d439495937975 GIT binary patch literal 3097 zcmchZ(N9`e9LEnx>n)v#$&$S|J)_q zNMDBj0jn;1X?(yvud&*6i@xbUU|ixueOLlZlR=7j_xqj8yy`TF#-~0Ri z&bjygg74mBFgiu=M<%J$?ep?h!Qyh+oxIEDv%4Hx<47#_;LBimj0VGWD&VKi@RWZt z6pTe_bmZRn$e7=x)e2un{asq4)z#&6U-w$9w=E8y8k}x{A9Oi=UPDFVLZJw_j&*5?ir^R^4~c439#4nl;gw;?E6U?g2C+i9Qud%Aek#t2x#G@Ve)cn< z!(x3&e6%hG{@BiEOGn4g#j)^iKKoky_PH3D0LqFpO=9E`%IsB^C=LESyBFs`4Gz78)d7yli{+dKYwt8PX1!TlyLddg6su zR;V?h@6nS*Snsdu4`3E3p-G^w06Go3LyzRpK}=uecE)-Wty_w(TJe=B`AYUpv?#tU zY!-bbLSM{sG2d(HW`n%X^Fa7~f8dZ{pOMN>L5>CHEb?rb;Ep+KS|epS_dX}n%Z)bn z1Z{m9Lx}k*l>7x^0`4E|JrY&OjO%5wIJ^fh6B@{ZU&T3}Z=!Z*8Kjs`!)buNfP50I z0M({3R++6PSx3S5)i&xb;2Q@y8v*%)7jqSoo7C#l3RSw4(!$@_pWRN^MLP6(S~UF+ zJF$=4uIj|AD@0k_kog3!DO<8as(Dz6Z<68sM*83=3oUe$tYv$r_m1+wp#Qx$UwV@- z{kTQR@cu^r^_ybp`)6k4ozkDh()yN}tnF`Xlycvc){7K*cJCPC&p@Bus69B&GtF=o z&GPUAJ)T4ifF6;J6>?X8nySqcoKfN{B*QiL%)oVA1$s_Tp#iGmsFzrcoZ*_fu`!}1 zBgL!rz>1!6rhXao)cl6}Dz9_Zqto@wOz2gcSkILPPXG8PHO2f@oT*l6=C%-RwHNXb)0@e|Ig~-zU!VzK^B&O-k?trsh&E<1Z&G67bFei6nvbhzobDu z)0COro4KUxhB(W4;r-#38#^E8h*ZxaXG@t?X13l6XX>AD=7L#mX8W_qeV&r|F2^*m z53rvS!yZEYm@{RT_Vc38t4e?3{g+=uc>k4d0pCYF z-K0(`MNR%5gTGq6q{C?A?Uo^zVE4EM_)BPXSgidP+R<*3u@eaXGY&Z278mU_ndFo# zaXTJs;CBT9GLowZ7`cpqkq;40L>zKt4gqS@?1J*Wz5!3)ts4$ru)A-n{(Wtb_buOB XawLEN^EHeAi*IAuw=PB+9{&6nU=>!m literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ b/internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..583aaa6e58e39202791363f1737e11dc3628e7bc GIT binary patch literal 3044 zcmchZO-~zF6o#*j6DCfv2dPpw2yO`ywnQUnxGi+a%$=67wn?YFSy)3FKweA(;M^? zD{YnoknAH7T&6>jk?1s?3`QS>M`&>Ps{k{<9}0v=CaLK2w@^Pj_PbrZB3vlvUO~Pd zay!J{7TWC-MPFYF9gd7pkKh!qQ}>jbG#rhN(Qs%?$s7%bqu@Gv(@1m#M<01ebgSxk zI;al63WI)09fvANWy+PZ2LwBfI(R z8|mBUQgj?BE6vnP(MK@5pPz+TWV@JsQIOVgwumMr`0e6B!pm(0HV)&gXgI`9pB4=T7L@gcValp-;O zpaO-!H~E5l!e)aB9k;0HDyW*5v&7-V##z2E7iv2-UrzG{f)#;V0}xg5s=u=hw*BO9)l z#p3WDyi6D%3w{;ne7=e5on??>J_Ba}`U3LFv;tI}##ni_l2jc9-&fnHyMS*T#9QfK#PuiJBx4t<^$P5;AAJU~9L=)|ilL|faS?F6rBTe3nbc}R5pP*ealAH z_BS?4xo=AAMT$JTcMS1opwDhp9~|eIW+;nhdH8`IPZ9<|kI2RfxuZT!-R23-Xz>-2 z;Tk$;;5x1YJ;zgMfVw#9W!58SxcUxkjHt=T@k%|gre~ZnFJqpn-%wxSb*_3$rp}ph zUbl($T&d;w$3N*Q=C9z48RLFpWA!XCj-wu0E5vn#)x%hioH3g?ew_bj^>E*H%%mU- z%Rk@9r-)on4P%0}WsnQ9hH(l$PSjsApq^1}L(7P-4AneT8+1N#8`DKqRL)Q>q+HhDiU`n)RiC*FVcHH7zH z>lW}$Rr23`UuSm`(aLNMq>8*xF8BEyLcf>P$ffAXUt{oBtBbT*9D>t6=nBVfdZfRQ-_sKl@f t@%Os>eBHOMy9Ckcy`lT}l|bHid~d0dAOg%+E&eaQb&79|pO_#1{3nw3O^W~k literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ b/internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..51f1cee0e983f186255572640d9d439495937975 GIT binary patch literal 3097 zcmchZ(N9`e9LEnx>n)v#$&$S|J)_q zNMDBj0jn;1X?(yvud&*6i@xbUU|ixueOLlZlR=7j_xqj8yy`TF#-~0Ri z&bjygg74mBFgiu=M<%J$?ep?h!Qyh+oxIEDv%4Hx<47#_;LBimj0VGWD&VKi@RWZt z6pTe_bmZRn$e7=x)e2un{asq4)z#&6U-w$9w=E8y8k}x{A9Oi=UPDFVLZJw_j&*5?ir^R^4~c439#4nl;gw;?E6U?g2C+i9Qud%Aek#t2x#G@Ve)cn< z!(x3&e6%hG{@BiEOGn4g#j)^iKKoky_PH3D0LqFpO=9E`%IsB^C=LESyBFs`4Gz78)d7yli{+dKYwt8PX1!TlyLddg6su zR;V?h@6nS*Snsdu4`3E3p-G^w06Go3LyzRpK}=uecE)-Wty_w(TJe=B`AYUpv?#tU zY!-bbLSM{sG2d(HW`n%X^Fa7~f8dZ{pOMN>L5>CHEb?rb;Ep+KS|epS_dX}n%Z)bn z1Z{m9Lx}k*l>7x^0`4E|JrY&OjO%5wIJ^fh6B@{ZU&T3}Z=!Z*8Kjs`!)buNfP50I z0M({3R++6PSx3S5)i&xb;2Q@y8v*%)7jqSoo7C#l3RSw4(!$@_pWRN^MLP6(S~UF+ zJF$=4uIj|AD@0k_kog3!DO<8as(Dz6Z<68sM*83=3oUe$tYv$r_m1+wp#Qx$UwV@- z{kTQR@cu^r^_ybp`)6k4ozkDh()yN}tnF`Xlycvc){7K*cJCPC&p@Bus69B&GtF=o z&GPUAJ)T4ifF6;J6>?X8nySqcoKfN{B*QiL%)oVA1$s_Tp#iGmsFzrcoZ*_fu`!}1 zBgL!rz>1!6rhXao)cl6}Dz9_Zqto@wOz2gcSkILPPXG8PHO2f@oT*l6=C%-RwHNXb)0@e|Ig~-zU!VzK^B&O-k?trsh&E<1Z&G67bFei6nvbhzobDu z)0COro4KUxhB(W4;r-#38#^E8h*ZxaXG@t?X13l6XX>AD=7L#mX8W_qeV&r|F2^*m z53rvS!yZEYm@{RT_Vc38t4e?3{g+=uc>k4d0pCYF z-K0(`MNR%5gTGq6q{C?A?Uo^zVE4EM_)BPXSgidP+R<*3u@eaXGY&Z278mU_ndFo# zaXTJs;CBT9GLowZ7`cpqkq;40L>zKt4gqS@?1J*Wz5!3)ts4$ru)A-n{(Wtb_buOB XawLEN^EHeAi*IAuw=PB+9{&6nU=>!m literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspectw.tedit b/internal/test/env/inspector/hand/inspectw.tedit new file mode 100644 index 0000000000000000000000000000000000000000..492201a1b3f826dcf246969f9c5d1afb6c3b2a7b GIT binary patch literal 9947 zcmeHNO>7&-6&^~g#j>eIwK?>l*yDu@QK%#&4NwTNkdP)<78{wQsg)_WE>uQZiG(RG zO|E`YSoO9EQ2FAPet2Uags|9O)d8#x3a9hx4Sbt zv!qldac)`L;+uJI-p@C0X5XW%>2`lJUdjgF`q03@OJ|FD*XIoz4_2&e|E zd=54246JApBLjbDTLi*~NJ~24@w( z*$fUhO8xXTg@@aD#Kh0$ zGTB7tIE}(B0{M-1S7X-GXihz;=0;TUqL2>|+#jfhM)4vMbO{^d9-*enL@{=K_T|(h zT!O>#Q|J|SA`pGoQra+FMc_R0;r8-ypXUjh3b;EQhy8MF<$xas>*_v3O^~} zIjYjkpredxLI8TXuKO0JG@1e^z-}h1=Co4^EWn_Js}5ON*eGX{1a(pS_H(w+Sp#?8 z3BVO!G+og+JxUW4u4+(bGx8~X({KX2GSt^-;K@l8{5Tuw^qqzpntNlJzaSR zzQ9&`deXBLSUblHOrOC;%?s91_bxqWDv(GNi zv2+J}`aGR0lxKBNUbELZa{43%muB>e*+an#aA*d&1=ALB7EBZim1(`+7Y=Js?Yq~h zQL!cT1$}~FaFt0~F`$`%9)f9rcEO~@LY+EFCP9hQGCcBomv*_80NlR}gU<}+K1x$2 ztrv~i@}zsQQwS2?jsQRr`z4IIh*y3^p9JZwQ7@S#7ql5;7T$ZXE!c&bB@=hAP@~3_ zJt4m~dfc6cH;5y@!*Xytq<^3Ujz6gR>Rn zvs%c0``bwa-DkL0#GVJ?+v546UeoD|#w@Ltp;ex=*Vt#68Wp{dj=+v%^6TtK)D2sD z0;++z5}ZH;3O1!=N(odpj5D-cI)h6~bsFV|NVkuzogv-Nu)^UjGDZU4W#glS(!tO1 ziU%KM`NrPR^6Bt~WSn1>K7y?HCiu_-&O<&D32S^2Irk54KM<#ZCcuGb6aJouPvIde zi*L@|`e1YOZ%57x(?D7)f$MYcynFx1U)N;DHrV;_H*0H~n}5IUdoC~6%&L?WT&Qp_SDi?Ld*YY~qVlQ?6*iT{Wk2rYa+CUMAE zBx%Lspe-Bmajr$qId+DYWDeL#at|bJ)>tTc|NS>eq%&Cs-$bv+Ld;J>xXUorO0ESt z$0@DdA;iNOG6A@GYeFMx#-ZZZaY!%fDT6+YV8rn9-dId#Yw&tD;kEj(VX- znS=(WJUdf?Vy?gnu=x^HT+TNy)YQvmtOK!ro5uzP3EldaoI`(poA}H~(mMqX2XwTqRB-B@{@=8?!4?Wl1UI0waRM{6syMTz-V&mm;M)^Nik#pWZ zi{sU+H<0t7efy!0zln8|=Kj184lk?Yl;0aqI27zBQ}kH$J#)oLzj_>({nwql4BT`qntO zt@~zixC?HlrFVrl2&`W51`-umz9N*4mcR=vpALp%)erBqUmWPaA0xpSV+K}F2Op0e ziddnblB6={O333-(!v#j9pKQLR(o*ZNlJycD%c4rF$%BqU^FCiR!@hXb?h8Y0!Prc zdIi=n52)zd@|B=+u6oA`?N|C`-yj|q0UV5Z5r=Li;<>H$j_(+at&~ zj=N02Ih7~)2yo-HOzfK1vM3*YZU^s!ovVPIIbM0;qdrj`VsA(gnuo{9zT=ssnoE-} zJDUV2reO}w{&VCh{I4nT(P3>clh)`{Gd)Up6q61KTz=BgpQ}u@EhCy?rx^i zRy=?|TjAdqk-*#JOGx0%J|uAF2_(dseIKzIn+3kLJ|F?|*wN#equ=g3rfP%frvsnf zH~W@AyMI7)=n0=mHq3BuzlSVbwZ&wjNZ`^UoB0(IDDz7ski|5I8UjHHv~A0OgN>Lx u$>5Brf%G-V9BYv2X^?rfL8ej9*BfMxH0XKSm1zv*)9=XPZ;_rK{QiH2lbsF# literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/inspectw.tedit.~1~ b/internal/test/env/inspector/hand/inspectw.tedit.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..6f6e0f04f2cd94bb31354ebdfa7d3250a6209001 GIT binary patch literal 9894 zcmeHNPjDMo8DH5V7N*2&+5-nSdD#hL8DdXMFP_HJO0m|lz_Ao*9XSxjsMgxjMA9nS z^`9~^S!ic)E}`MZ^kO(LrO6O(WXKSw2c~p}cH9#Kv~Jp7I8fqnaX@j*_wDX```$`6 zZkyh^N#yUn?|a{$-}~O%?~|kHrd6uW604|_THTnf=PQ-GRhlNHs-@Rw^3yu843Zqr zrqy9B*BQ;5=3E6Al&U0&BIS}8Yi=*fwcrjn6lCad-J5hlqN#4{wSo&xFk zSYNY13sqSajWmmr=x{voag}MK$;?i=c2(BGv60k7MjLH*4E;)o${^BC4%Mud%Bab4 z9#b-Y%7>Liv#JIF3F!SltOa2PcWOKfssXEjLrpsaD_X=z!QWXqM9XhNE4?k833$_- zC@sC&Y4^}~NRlk3#NM1?;({Z)IPb*Zt^zn)!Qn;8egNbxvVgHE(E@auSS_qDzxgm* z$hq2?v=HTv;=x59XO**-;WM7Z!|gtN;-@pI^l<6~iNY-c`HdG-bJmk+Mm?owvMPU3 zhzAJn4^%^W$x=p;E!zC+>=KPR(iLs=EqiW^|flmT>PN*a`;wmE=7l2+i^}yn!Mv?#p*iEI? zjCNXq1sF7U)gdbl8|7{ir!MN;e(v_UYv9g13Ao~mrZ*ZV$H*{&s~VI!j9e1mGz`Sy zj2egcOfQvpUO2?Pt{@V)<%xHUNU!)3>*a1=RNvoE@>O^rnl*jeA`7Kz!B`;qT20T_ z%}yyK;WHs=Qs`Coydq7oCoRxSE-4}8^`2l;T@V_{he$*%lYKt8nL%fmeQ6Yl8l@nm>gybnCh%jDXBdZ{O|5xV8* zAMI8O%OT?E_vu`Fm#k>Zq1zynla?LY^#^3emK`6igngRobmeLA5HBTBKSvAxbo}Yk z(4r*a+AE>Ri%J4x2YHUpg}PoGf_Vx3f%&LMqs-x!@{vo5r<1qE`@qw@4D46;(0MoZ zE8)mxMW*rkbgpCh@{oMb*`plDL>(F2-^k^|t>nWU`%%v)!iV7o`e`0w{&V!lJzsl~ z?=>z>xijO8`Z)QxK>N`0x{}j#+a*H#Xh(>tfEtgm-QKoJU3@q zMis^2_N~=*({y;1QlU`RJuc}do(WU82AtX(>vFKCFOd0sc}@rAb!VL`rxysgRMD%} z5dvO-LlxlWEl0#%FkQ@7XLWO+vr~go-n&kXsw1H<>eK9ks}@MrfKCA#1gZgg0gDv# zCUKP%K#AKAJoI~)^m>&5+`klq&kW`PLXs9Si^g2J;9cwlf`qpt08qqc2xBhdm0#5h zAe}bMl2!6Rs~B_e-h*wy7RxGGxO@3JF=m_z@wIWp+i7@%xbiz}cU_;+t?43|(m<)R zaVBbvJ3HWc`kYSc`n+B@!Ka6_nZsoRLdloQ^lb;p<-YIC&u*ucQFUxAg~dfib&AB} z6KXa~a-*qd71HY!a=om$QbzOhxFsWVRpirJ$a(uaNdw(yXFrcU3nH+^3q`%Iljn^& zQY%9rTyWMnXP6jOeSl$=5P^bCDOo}Sl?~%8DVNUT(vnG{ z>=5bBv2`+}?`c{%ydh0WA^)-oP+aK{cDZJ1_6RSzWrZzWz?5@$!3tHTLS#AJ^AEXx#s9P@6r4qG){! z3GQ)md!L)3em^E~q)9np$Ks$ZEeAN)<@2tc(PfbXb`s13L7P1p zN!)w?HA(JC)WA31>&Xc9Q<9j=Fx4(y4>OKiT6;r?hcQF~aP!wlZ5)%~w*Q&IbC13z zbub>-adGP=iHkowB%tHr=5UD3BkJMy$WZKJ1~{BH54Seb#PM)LZQm5NdAPOUc(}Fj zn#YZYN5D4m%8iG7<^DV3lUJQ86tN!7q=<;_6q*or9SY> zivYDt9nwiVC)23tZiPKlH?URF2{uRl(4!Qffho^bs!+`3X#uuSf{M%i=7m^#xr}un z)^7{gpdi7zAYAXXEhURU5thf_ebn^2^*ppJJ2hKgJ#S(!=PH5{A8W}xsX%)MzyBbC zT9s9*3V7(d=Jf(#vQnd880{8vy);|IzDkUl+H9fOanbuC%8Am&1WVWjgP4|HGoc5W zKHCfug~5T^Z3qS2p3}=lbrxDt1HSVLKA=_@rv2psYUNt+RMGLu6s3Yc*N}4|IE&-8Yd4W|ziazJfWLwqr&QfqMZ$kprfz!Zh4{aK{ertEib%vR4o{?9uX0-S3%@BYOwV9mco#x~e_a|h1U&3Eq@)upXB z?*!JYP2K$9j&W}3L4Q!&nu88ne-K#X;sQ5bOYl+_JmELr)OG zy;Z?ZM2Qi2orj|lk+XIt@{DWeZ~{1-wzaFUhI&AF-&U@MmGiaRc4WUYDEbER&cvni8o|{LveFBF)mVy+r9%N@oQP&c({dRhvWMI z@p!m_wx7!}oZW7zkAa4E&ar3RM8@@XiycTc+ zui5h%)#Avq@GwU=+* z$|!L7oum2Yc)+irxJCB&pl_Tu0k?;cZwz;lfO9HNuo2+KXpz`8uSHQd`rHoQ2Rl~* zJ9GTgzKFfB(k2mAV{N=NY!ezwEEFCu}r$(NA8nSDsW%)XD1z?sL9 z08iTQ!{;N%PNa@~Yv8!5jf_7P`t+VScLG}Z16n~(*i52nhWaLb4_UZsi^@ciz@7&-6&^~g#j>eIwK?>l*yDu@QK%#&4NwTNkdP)<78{wQsg)_WE>uQZiG(RG zO|E`YSoO9EQ2FAPet2Uags|9O)d8#x3a9hx4Sbt zv!qldac)`L;+uJI-p@C0X5XW%>2`lJUdjgF`q03@OJ|FD*XIoz4_2&e|E zd=54246JApBLjbDTLi*~NJ~24@w( z*$fUhO8xXTg@@aD#Kh0$ zGTB7tIE}(B0{M-1S7X-GXihz;=0;TUqL2>|+#jfhM)4vMbO{^d9-*enL@{=K_T|(h zT!O>#Q|J|SA`pGoQra+FMc_R0;r8-ypXUjh3b;EQhy8MF<$xas>*_v3O^~} zIjYjkpredxLI8TXuKO0JG@1e^z-}h1=Co4^EWn_Js}5ON*eGX{1a(pS_H(w+Sp#?8 z3BVO!G+og+JxUW4u4+(bGx8~X({KX2GSt^-;K@l8{5Tuw^qqzpntNlJzaSR zzQ9&`deXBLSUblHOrOC;%?s91_bxqWDv(GNi zv2+J}`aGR0lxKBNUbELZa{43%muB>e*+an#aA*d&1=ALB7EBZim1(`+7Y=Js?Yq~h zQL!cT1$}~FaFt0~F`$`%9)f9rcEO~@LY+EFCP9hQGCcBomv*_80NlR}gU<}+K1x$2 ztrv~i@}zsQQwS2?jsQRr`z4IIh*y3^p9JZwQ7@S#7ql5;7T$ZXE!c&bB@=hAP@~3_ zJt4m~dfc6cH;5y@!*Xytq<^3Ujz6gR>Rn zvs%c0``bwa-DkL0#GVJ?+v546UeoD|#w@Ltp;ex=*Vt#68Wp{dj=+v%^6TtK)D2sD z0;++z5}ZH;3O1!=N(odpj5D-cI)h6~bsFV|NVkuzogv-Nu)^UjGDZU4W#glS(!tO1 ziU%KM`NrPR^6Bt~WSn1>K7y?HCiu_-&O<&D32S^2Irk54KM<#ZCcuGb6aJouPvIde zi*L@|`e1YOZ%57x(?D7)f$MYcynFx1U)N;DHrV;_H*0H~n}5IUdoC~6%&L?WT&Qp_SDi?Ld*YY~qVlQ?6*iT{Wk2rYa+CUMAE zBx%Lspe-Bmajr$qId+DYWDeL#at|bJ)>tTc|NS>eq%&Cs-$bv+Ld;J>xXUorO0ESt z$0@DdA;iNOG6A@GYeFMx#-ZZZaY!%fDT6+YV8rn9-dId#Yw&tD;kEj(VX- znS=(WJUdf?Vy?gnu=x^HT+TNy)YQvmtOK!ro5uzP3EldaoI`(poA}H~(mMqX2XwTqRB-B@{@=8?!4?Wl1UI0waRM{6syMTz-V&mm;M)^Nik#pWZ zi{sU+H<0t7efy!0zln8|=Kj184lk?Yl;0aqI27zBQ}kH$J#)oLzj_>({nwql4BT`qntO zt@~zixC?HlrFVrl2&`W51`-umz9N*4mcR=vpALp%)erBqUmWPaA0xpSV+K}F2Op0e ziddnblB6={O333-(!v#j9pKQLR(o*ZNlJycD%c4rF$%BqU^FCiR!@hXb?h8Y0!Prc zdIi=n52)zd@|B=+u6oA`?N|C`-yj|q0UV5Z5r=Li;<>H$j_(+at&~ zj=N02Ih7~)2yo-HOzfK1vM3*YZU^s!ovVPIIbM0;qdrj`VsA(gnuo{9zT=ssnoE-} zJDUV2reO}w{&VCh{I4nT(P3>clh)`{Gd)Up6q61KTz=BgpQ}u@EhCy?rx^i zRy=?|TjAdqk-*#JOGx0%J|uAF2_(dseIKzIn+3kLJ|F?|*wN#equ=g3rfP%frvsnf zH~W@AyMI7)=n0=mHq3BuzlSVbwZ&wjNZ`^UoB0(IDDz7ski|5I8UjHHv~A0OgN>Lx u$>5Brf%G-V9BYv2X^?rfL8ej9*BfMxH0XKSm1zv*)9=XPZ;_rK{QiH2lbsF# literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/hand/report.tedit b/internal/test/env/inspector/hand/report.tedit new file mode 100644 index 0000000000000000000000000000000000000000..c85a7b863c7b18e99d6d5b75c8ce06e303e0dba8 GIT binary patch literal 3594 zcmb_eTW{P%6m|>cVu5(zr3eX*3Q~5f&1#djX&WI>NVgCvmnyrW6!J1_kF!H;kD0MI zED}%rAASJ;hi865`Oetmb+Zb6fU29d&z#FQ=klGMN?WS@oK9t-O&Nw$yvuku4C&>| z;O``$mjT5pNu-f^Nta@2NhcH;DN3dDU8*ds2NdaI=^l)1BsLRv4pHL>ZpvjLzZ$r& zTx7CXJ(4hzN*9?DZAgk}?({g8k&!krm2**2CRASHV_Pqz@;x z9JzZTj^W+n$kL@M=OpsjJ?N@@)%}19qZcZcF$o8gL1u^pgG|JdYz6!Z>CxuG(n3Lt z@4C8rqGTEq-gnIvY9m01D;u>(voINIy>W|^Hk47x)4T*St|Rk z8&vH$s*G#ALPQthTy_ynRHjm4QowIohmjyL(ujzglbffpYcL=1VXAD=R3DJ3r-pLa zz=VC%7OqrWU-r4Gp6z0@Tuu+HPju9_g1dBcLO)j`Rd5m0LK+KPZi0~R{2Z{*F?IJP zvP5w?q>)7`B7av54lq@)TzGWNZNyA30KL;lxxDlj;Jn&h%w?V^leLB544I7UjG=FRRj06{&<}hA+-=zhjM|EZ~o4BwxDz=ltv0PY~8UvIMha z6rl?pefWvQ1=+Grk?R!Hes3~;@obE2pA#DW;CS+Eygyw*tt>i87mUIB)4jvPrw8N1 zCzGd#-wfzz@B7AT|H;hQdXS{fyW1jM2!Ww2INF z=qeHGJY8<)(%QZwY0Ob+2WaZ31nL3p^2~7c8)%oxqKCVw6x=ti`;nodFqqXOr!YK} z30g$c%rAjmpVwwRjP$^Q{xrAsq)pjmnDhxucTW8HtS79X2(ABGj;Yn565*OrZ%qma^Ul#Tm z_OivgezI_RiKlDh&sBhn#GfGAJHL zlq_cvr#{9+^au46@~&lWbEG>Ak9CREG3oKo0!z7uztvir$?{UldcU<}&pz+Ek=Trs ziBfsjMQKFb73K1781TPa!5cv@cq{nAz2VQz8~$nSyVsTc4|?qG&EQ6GJ9vM3a5SEr zo*eBR2k&*G1UG>%2tHt04XhTp=dR$LuEtHg@W+|F&Cjg*wU^xTlHa|g)k(di)w%5@ ztG{*Q;#2UPZoM<>PBrJh%_L8k|l3xazjKJMj{qyLFZM>s7{A zRob+8x1ap029Ly@t_BO*3i<1N+ST9)_pS<#uL{ZlOkm z1AEwfGxPgqW_LurK5#bUjyD9yn@w1ckEgb6bIesDq6Yv++{$bktRXK2unXL5M&6xfJ7*aFaxz-U;ue46(|WlgsJpRYgkB)fG9rRG_{i1 zI|gk%nJqC}tJn~j=D4jum+`&K2pT5&dgc0B4rx7DhKZI`l$ x*|%XL^T=}fnu+uu=zWezoEzBqu8lCB9q++JIl*`)8~PYe)%B*be38cI_Yc=KQxpII literal 0 HcmV?d00001 diff --git a/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ b/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ new file mode 100644 index 00000000..29448604 --- /dev/null +++ b/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ @@ -0,0 +1 @@ +Testing: Inspect-defstruct.tedit Bug: changing the value of an integer typed slot to a floating point number worked. \ No newline at end of file diff --git a/internal/test/env/inspector/logs/inspect-defstruct.log.~2~ b/internal/test/env/inspector/logs/inspect-defstruct.log.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..de5d1fc9317e8081b096ee33b62dcc2ba58da93f GIT binary patch literal 607 zcma)&&rZTX5XRSvi8Ok}L@#rMM2Xyp7qh|wO==;qdarc)C)QokZXx(kK7dc>ZlOkm z1AEwfGxPgqW_LurK5#bUjyD9yn@w1ckEgb6bIesDq6Yv++{$bktRXK2unXL5M&6xfJ7*aFaxz-U;ue46(|WlgsJpRYgkB)fG9rRG_{i1 zI|gk%nJqC}tJn~j=D4jum+`&K2pT5&dgc0B4rx7DhKZI`l$ x*|%XL^T=}fnu+uu=zWezoEzBqu8lCB9q++JIl*`)8~PYe)%B*be38cI_Yc=KQxpII literal 0 HcmV?d00001 diff --git a/internal/test/env/process-controls/LOGS/PSW.LOG b/internal/test/env/process-controls/LOGS/PSW.LOG new file mode 100644 index 00000000..5798f2dd --- /dev/null +++ b/internal/test/env/process-controls/LOGS/PSW.LOG @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 23-Feb-88 19:11:48 ;;; Running tests from ({ERIS}env>process-controls>hand>PSW.U;2) Testing... "PSW-TEST-SETUP" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/process-controls/hand/PSW.REPORT b/internal/test/env/process-controls/hand/PSW.REPORT new file mode 100644 index 00000000..4410b592 --- /dev/null +++ b/internal/test/env/process-controls/hand/PSW.REPORT @@ -0,0 +1 @@ +TEST REPORT FOR PROCESS CONTROLS (PSW) SYSTEM: PSW COMMAND: PSW-INVOKED-PROGRAMMATICALLY LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:53 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: PSW-INVOKED-FROM-BACKGROUND-MENU LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:56 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: BT LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:57 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: BTV LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:57 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: BTV* LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:58 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: BTV! LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:58 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: WHO? LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:45:59 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: KBD_ LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:00 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: INFO LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:00 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: BREAK LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:00 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: KILL LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:01 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: RESTART LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:01 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: WAKE LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:02 TESTER: JPARK.PASA SYSTEM: PSW COMMAND: SUSPEND LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 10-Apr-87 09:46:02 TESTER: JPARK.PASA TOTAL TEST RUN TIME FOR PSW: 1.4854333 MINUTES SYSTEM: PSW COMMAND: PSW-INVOKED-PROGRAMMATICALLY LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: FAIL DATE: 20-Apr-87 10:40:33 TESTER: SCHUSTER SYSTEM: PSW COMMAND: PSW-INVOKED-FROM-BACKGROUND-MENU LISP VERSION: LYRIC of 10-Apr-87 10:19:34 STATUS: SUCCESS DATE: 20-Apr-87 10:40:35 TESTER: SCHUSTER TOTAL TEST RUN TIME FOR PSW: 0.54665 MINUTES SYSTEM: PSW COMMAND: PSW-INVOKED-PROGRAMMATICALLY LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 09:29:27 TESTER: SCHUSTER SYSTEM: PSW COMMAND: PSW-INVOKED-FROM-BACKGROUND-MENU LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 09:29:29 TESTER: SCHUSTER TOTAL TEST RUN TIME FOR PSW: 0.46353334 MINUTES SYSTEM: PSW COMMAND: PSW-INVOKED-PROGRAMMATICALLY LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:39 TESTER: SCHUSTER SYSTEM: PSW COMMAND: PSW-INVOKED-FROM-BACKGROUND-MENU LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:44 TESTER: SCHUSTER SYSTEM: PSW COMMAND: BT LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:46 TESTER: SCHUSTER SYSTEM: PSW COMMAND: BTV LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:46 TESTER: SCHUSTER SYSTEM: PSW COMMAND: BTV* LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:47 TESTER: SCHUSTER SYSTEM: PSW COMMAND: BTV! LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:47 TESTER: SCHUSTER SYSTEM: PSW COMMAND: WHO? LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:48 TESTER: SCHUSTER SYSTEM: PSW COMMAND: KBD_ LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:48 TESTER: SCHUSTER SYSTEM: PSW COMMAND: INFO LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:49 TESTER: SCHUSTER SYSTEM: PSW COMMAND: BREAK LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:49 TESTER: SCHUSTER SYSTEM: PSW COMMAND: KILL LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:50 TESTER: SCHUSTER SYSTEM: PSW COMMAND: RESTART LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:51 TESTER: SCHUSTER SYSTEM: PSW COMMAND: WAKE LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:51 TESTER: SCHUSTER SYSTEM: PSW COMMAND: SUSPEND LISP VERSION: LYRIC of 18-Apr-87 20:24:31 STATUS: SUCCESS DATE: 23-Apr-87 11:00:52 TESTER: SCHUSTER TOTAL TEST RUN TIME FOR PSW: 0.44441667 MINUTES \ No newline at end of file diff --git a/internal/test/env/process-controls/hand/PSW.U b/internal/test/env/process-controls/hand/PSW.U new file mode 100644 index 00000000..0556574d --- /dev/null +++ b/internal/test/env/process-controls/hand/PSW.U @@ -0,0 +1 @@ +;; Function To Be Tested: Process Control Window (Process Controls) ;; ;; Source: IRM VOLUME 2 ;; Section 23.8. PSW,Lyric Release Notes ;; ;; Section: Program Support ;; ;; Created By: John Park ;; ;; Creation Date: April 9, 1987 ;; ;; Last Update: April 23, 1987 ;; ;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; ;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. ;; (SEE IRM Volume 2, Section 23.8) ;; ;; ;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) ;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that ;; allows the user to examine and manipulate all of the existing processes. ;; The window consists of two menus. The top menu lists all the processes at the ;; moment. Commands in the bottom menu operate on the process selected in the ;; top menu. ;; ;; Argument(s): WHERE: position of Process Status Window ;; (SEE IRM Volume 2, Section 23.8) ;; ;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) ;; ;; Constraints/Limitations: The test for PSW is not automated. The user is ;; expected to have tested this system through the operational use of PSW from ;; the background menu. This test will focus on the creation of the PSW only. ;; The user is encourged to either test this system operationally or explicitly ;; by following the functional description of PSW as outlined in IRM Volume 2, ;; section 23.8. Any problems should be reported as ARs and logged in ;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; (DO-TEST "PSW-TEST-SETUP" (IL:PAGEHEIGHT 0) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Wunnerful!") ) ; close DEFUN PASS-FAIL (SETQ PSW-MESS "Shortly a PSW will be created programatically. If it is created, please anwser y or n otherwise...") (SETQ PSW-MESS1 "Please click PSW from the background menu to create the Process Status Window") (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") (DEFUN PSW-TEST NIL (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (SETQ PSW-DESCRIPTION-LIST '("Displays a backtrace of function names starting at LASTPOS" "Displays a backtrace of function names with variables beginning at LASTPOS" "Displays a backtrace of functions names and prints arguments to local variables and eval blips" "Displays a backtrace of functions and prints everything on the stack" "Changes the selection to the tty process (the one currently in control of the keyboard)" "Associates the keyboard with the selected process: (makes the selected process be the tty process)" "If the selected process has an INFOHOOK property, calls it. The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" "Enter a break under the selected process. This has the side effect of waking the process with the value returned from the break" "Deletes the selected process" "Restarts the selected process" "Wakes the selected process. Prompts for a value to wake it with" "Suspends the selected process (causes it to block indefinitely)")) (SETQ COLON ": ") (SETQ MESS "Is the selected process examined or manipulated successfully by the command ~A ? ") (IL:FOR PSW-ITEM IL:IN PSW-ITEM-LIST IL:DO (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) (FORMAT T "~a~a~a~%" PSW-ITEM COLON PSW-DESCRIPTION) (PASS-FAIL PSW-ITEM (Y-OR-N-P (FORMAT T MESS PSW-ITEM))) (IL:CLRPROMPT) ) ; close FOR ) ; close DEFUN PSW-TEST ; Creating the PSW programmatically... (IL:PRIN1 PSW-MESS) (IL:PROCESS.STATUS.WINDOW '(800 . 240)) (PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY (Y-OR-N-P PSW-MESS2)) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) ; Creating the PSW from the background menu... (IL:PRIN1 PSW-MESS1) (PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU (Y-OR-N-P PSW-MESS2)) ; Start PSW Component Test (IL:PRIN1 PSW-MESS3) (IL:IF (Y-OR-N-P PSW-MESS4) IL:THEN (PSW-TEST) ) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) ) STOP \ No newline at end of file diff --git a/internal/test/env/process-controls/hand/PSW.U.~1~ b/internal/test/env/process-controls/hand/PSW.U.~1~ new file mode 100644 index 00000000..8de14025 --- /dev/null +++ b/internal/test/env/process-controls/hand/PSW.U.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: Process Control Window (Process Controls) ;; ;; Source: IRM VOLUME 2 ;; Section 23.8. PSW,Lyric Release Notes ;; ;; Section: Program Support ;; ;; Created By: John Park ;; ;; Creation Date: April 9, 1987 ;; ;; Last Update: April 23, 1987 ;; ;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; ;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. ;; (SEE IRM Volume 2, Section 23.8) ;; ;; ;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) ;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that ;; allows the user to examine and manipulate all of the existing processes. ;; The window consists of two menus. The top menu lists all the processes at the ;; moment. Commands in the bottom menu operate on the process selected in the ;; top menu. ;; ;; Argument(s): WHERE: position of Process Status Window ;; (SEE IRM Volume 2, Section 23.8) ;; ;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) ;; ;; Constraints/Limitations: The test for PSW is not automated. The user is ;; expected to have tested this system through the operational use of PSW from ;; the background menu. This test will focus on the creation of the PSW only. ;; The user is encourged to either test this system operationally or explicitly ;; by following the functional description of PSW as outlined in IRM Volume 2, ;; section 23.8. Any problems should be reported as ARs and logged in ;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; (DO-TEST "PSW-TEST-SETUP" (PROGN (IL:PAGEHEIGHT 0) (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR PSW: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ PSW-MESS "Shortly a PSW will be created programatically. If it is created, please anwser y or n otherwise...") (SETQ PSW-MESS1 "Please click PSW from the background menu to create the Process Status Window") (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") (SETQ PSW-MESS5 "Would you like to see the test result? ") (IL:SHAPEW IL:PROMPTWINDOW '(10 720 550 100)) (DEFUN PSW-TEST NIL (PROGN (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (SETQ PSW-DESCRIPTION-LIST '("Displays a backtrace of function names starting at LASTPOS" "Displays a backtrace of function names with variables beginning at LASTPOS" "Displays a backtrace of functions names and prints arguments to local variables and eval blips" "Displays a backtrace of functions and prints everything on the stack" "Changes the selection to the tty process (the one currently in control of the keyboard)" "Associates the keyboard with the selected process: (makes the selected process be the tty process)" "If the selected process has an INFOHOOK property, calls it. The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" "Enter a break under the selected process. This has the side effect of waking the process with the value returned from the break" "Deletes the selected process" "Restarts the selected process" "Wakes the selected process. Prompts for a value to wake it with" "Suspends the selected process (causes it to block indefinitely)")) (SETQ COLON ": ") (SETQ MESS "Is the selected process examined or manupulated successfully by the command ~A ? ") (IL:FOR ITEM IL:IN PSW-ITEM-LIST IL:DO (PROGN (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) (IL:PROMPTPRINT PSW-ITEM COLON PSW-DESCRIPTION) (PAUSE) (IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:Y (FORMAT T MESS PSW-ITEM))) (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) T) (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) NIL)) (IL:CLEARW) (SLEEP 1))) (IL:CLRPROMPT) ) ) (SETQ PSW-STRING "; Creating the PSW programmatically... (IL:PROMPTPRINT PSW-MESS) (IL:PROCESS.STATUS.WINDOW '(930 . 240)) (IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) (SETQ PSW-CREATED-FLG T) (SETQ PSW-CREATED-FLG NIL)) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) ; Creating the PSW from the background menu... (IL:PROMPTPRINT PSW-MESS1) (PAUSE) (IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) (SETQ PSW-BACKGROUND-FLG T) (SETQ PSW-BACKGROUND-FLG NIL)) ; Start PSW Component Test (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (IL:PROMPTPRINT PSW-MESS3) (IF (EQ (IL:ASKUSER NIL 'IL:N PSW-MESS4) 'IL:Y) (PROGN (PSW-TEST) (SETQ PSW-COMPONENT-TESTED T)) (SETQ PSW-COMPONENT-TESTED NIL)) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (ABS (- TEST-END TEST-START)) 60000))) ; Wrinting the test results to ; {eris}test>program-support>clisp.u.... (DO-TEST 'PSW-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY PSW-CREATED-FLG) (PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU PSW-BACKGROUND-FLG) (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (IF (EQ PSW-COMPONENT-TESTED T) (IL:FOR X IL:IN PSW-ITEM-LIST IL:DO (PROGN (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) (PASS-FAIL X (EVAL (PACK* PSW-ITEM '-EXAMINED-FLG))) ) ) ) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) (IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:N PSW-MESS5)) (PROGN (IL:PAGEHEIGHT 15) (IL:SEE '{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT))) ") (IL:BKSYSBUF PSW-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/process-controls/hand/PSW.U.~2~ b/internal/test/env/process-controls/hand/PSW.U.~2~ new file mode 100644 index 00000000..be76cf56 --- /dev/null +++ b/internal/test/env/process-controls/hand/PSW.U.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: Process Control Window (Process Controls) ;; ;; Source: IRM VOLUME 2 ;; Section 23.8. PSW,Lyric Release Notes ;; ;; Section: Program Support ;; ;; Created By: John Park ;; ;; Creation Date: April 9, 1987 ;; ;; Last Update: April 23, 1987 ;; ;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; ;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. ;; (SEE IRM Volume 2, Section 23.8) ;; ;; ;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) ;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that ;; allows the user to examine and manipulate all of the existing processes. ;; The window consists of two menus. The top menu lists all the processes at the ;; moment. Commands in the bottom menu operate on the process selected in the ;; top menu. ;; ;; Argument(s): WHERE: position of Process Status Window ;; (SEE IRM Volume 2, Section 23.8) ;; ;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) ;; ;; Constraints/Limitations: The test for PSW is not automated. The user is ;; expected to have tested this system through the operational use of PSW from ;; the background menu. This test will focus on the creation of the PSW only. ;; The user is encourged to either test this system operationally or explicitly ;; by following the functional description of PSW as outlined in IRM Volume 2, ;; section 23.8. Any problems should be reported as ARs and logged in ;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; (DO-TEST "PSW-TEST-SETUP" (PROGN (IL:PAGEHEIGHT 0) (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR PSW: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ PSW-MESS "Shortly a PSW will be created programatically. If it is created, please anwser y or n otherwise...") (SETQ PSW-MESS1 "Please click PSW from the background menu to create the Process Status Window") (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") (SETQ PSW-MESS5 "Would you like to see the test result? ") (IL:SHAPEW IL:PROMPTWINDOW '(10 720 550 100)) (DEFUN PSW-TEST NIL (PROGN (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (SETQ PSW-DESCRIPTION-LIST '("Displays a backtrace of function names starting at LASTPOS" "Displays a backtrace of function names with variables beginning at LASTPOS" "Displays a backtrace of functions names and prints arguments to local variables and eval blips" "Displays a backtrace of functions and prints everything on the stack" "Changes the selection to the tty process (the one currently in control of the keyboard)" "Associates the keyboard with the selected process: (makes the selected process be the tty process)" "If the selected process has an INFOHOOK property, calls it. The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" "Enter a break under the selected process. This has the side effect of waking the process with the value returned from the break" "Deletes the selected process" "Restarts the selected process" "Wakes the selected process. Prompts for a value to wake it with" "Suspends the selected process (causes it to block indefinitely)")) (SETQ COLON ": ") (SETQ MESS "Is the selected process examined or manupulated successfully by the command ~A ? ") (IL:FOR ITEM IL:IN PSW-ITEM-LIST IL:DO (PROGN (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) (IL:PROMPTPRINT PSW-ITEM COLON PSW-DESCRIPTION) (PAUSE) (IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:Y (FORMAT T MESS PSW-ITEM))) (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) T) (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) NIL)) (IL:CLEARW) (SLEEP 1))) (IL:CLRPROMPT) ) ) (SETQ PSW-STRING "; Creating the PSW programmatically... (IL:PROMPTPRINT PSW-MESS) (IL:PROCESS.STATUS.WINDOW '(800 . 240)) (IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) (SETQ PSW-CREATED-FLG T) (SETQ PSW-CREATED-FLG NIL)) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) ; Creating the PSW from the background menu... (IL:PROMPTPRINT PSW-MESS1) (PAUSE) (IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) (SETQ PSW-BACKGROUND-FLG T) (SETQ PSW-BACKGROUND-FLG NIL)) ; Start PSW Component Test (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (IL:PROMPTPRINT PSW-MESS3) (IF (EQ (IL:ASKUSER NIL 'IL:N PSW-MESS4) 'IL:Y) (PROGN (PSW-TEST) (SETQ PSW-COMPONENT-TESTED T)) (SETQ PSW-COMPONENT-TESTED NIL)) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (ABS (- TEST-END TEST-START)) 60000))) ; Wrinting the test results to ; {eris}test>program-support>clisp.u.... (DO-TEST 'PSW-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY PSW-CREATED-FLG) (PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU PSW-BACKGROUND-FLG) (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (IF (EQ PSW-COMPONENT-TESTED T) (IL:FOR X IL:IN PSW-ITEM-LIST IL:DO (PROGN (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) (PASS-FAIL X (EVAL (PACK* PSW-ITEM '-EXAMINED-FLG))) ) ) ) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) (IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:N PSW-MESS5)) (PROGN (IL:PAGEHEIGHT 15) (IL:SEE '{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT))) ") (IL:BKSYSBUF PSW-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/process-controls/hand/PSW.U.~3~ b/internal/test/env/process-controls/hand/PSW.U.~3~ new file mode 100644 index 00000000..0556574d --- /dev/null +++ b/internal/test/env/process-controls/hand/PSW.U.~3~ @@ -0,0 +1 @@ +;; Function To Be Tested: Process Control Window (Process Controls) ;; ;; Source: IRM VOLUME 2 ;; Section 23.8. PSW,Lyric Release Notes ;; ;; Section: Program Support ;; ;; Created By: John Park ;; ;; Creation Date: April 9, 1987 ;; ;; Last Update: April 23, 1987 ;; ;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; ;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. ;; (SEE IRM Volume 2, Section 23.8) ;; ;; ;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) ;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that ;; allows the user to examine and manipulate all of the existing processes. ;; The window consists of two menus. The top menu lists all the processes at the ;; moment. Commands in the bottom menu operate on the process selected in the ;; top menu. ;; ;; Argument(s): WHERE: position of Process Status Window ;; (SEE IRM Volume 2, Section 23.8) ;; ;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) ;; ;; Constraints/Limitations: The test for PSW is not automated. The user is ;; expected to have tested this system through the operational use of PSW from ;; the background menu. This test will focus on the creation of the PSW only. ;; The user is encourged to either test this system operationally or explicitly ;; by following the functional description of PSW as outlined in IRM Volume 2, ;; section 23.8. Any problems should be reported as ARs and logged in ;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U ;; ;; ;; (DO-TEST "PSW-TEST-SETUP" (IL:PAGEHEIGHT 0) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Wunnerful!") ) ; close DEFUN PASS-FAIL (SETQ PSW-MESS "Shortly a PSW will be created programatically. If it is created, please anwser y or n otherwise...") (SETQ PSW-MESS1 "Please click PSW from the background menu to create the Process Status Window") (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") (DEFUN PSW-TEST NIL (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL RESTART WAKE SUSPEND)) (SETQ PSW-DESCRIPTION-LIST '("Displays a backtrace of function names starting at LASTPOS" "Displays a backtrace of function names with variables beginning at LASTPOS" "Displays a backtrace of functions names and prints arguments to local variables and eval blips" "Displays a backtrace of functions and prints everything on the stack" "Changes the selection to the tty process (the one currently in control of the keyboard)" "Associates the keyboard with the selected process: (makes the selected process be the tty process)" "If the selected process has an INFOHOOK property, calls it. The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" "Enter a break under the selected process. This has the side effect of waking the process with the value returned from the break" "Deletes the selected process" "Restarts the selected process" "Wakes the selected process. Prompts for a value to wake it with" "Suspends the selected process (causes it to block indefinitely)")) (SETQ COLON ": ") (SETQ MESS "Is the selected process examined or manipulated successfully by the command ~A ? ") (IL:FOR PSW-ITEM IL:IN PSW-ITEM-LIST IL:DO (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) (FORMAT T "~a~a~a~%" PSW-ITEM COLON PSW-DESCRIPTION) (PASS-FAIL PSW-ITEM (Y-OR-N-P (FORMAT T MESS PSW-ITEM))) (IL:CLRPROMPT) ) ; close FOR ) ; close DEFUN PSW-TEST ; Creating the PSW programmatically... (IL:PRIN1 PSW-MESS) (IL:PROCESS.STATUS.WINDOW '(800 . 240)) (PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY (Y-OR-N-P PSW-MESS2)) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) ; Creating the PSW from the background menu... (IL:PRIN1 PSW-MESS1) (PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU (Y-OR-N-P PSW-MESS2)) ; Start PSW Component Test (IL:PRIN1 PSW-MESS3) (IL:IF (Y-OR-N-P PSW-MESS4) IL:THEN (PSW-TEST) ) (IL:FOR X IL:IN (IL:OPENWINDOWS) IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) IL:DO (IL:CLOSEW X)) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U b/internal/test/env/program-analysis/hand/BROWSER-PART2.U new file mode 100644 index 00000000..ff6aff2b --- /dev/null +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER-2 (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 11, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>browser-part2.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test ;; determines if BROWSER modified masterscope in such a way that paths are displayed ;; grahically in a display window. ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "BROWSER2-TEST-SETUP" (IL:FILESLOAD (IL:SYSLOAD) MASTERSCOPE BROWSER GRAPHER) (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Reinitialize and Define functions to be analyzed.... (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) (IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) (IL:MASTERSCOPE '(ANALYZE GFUN-A)) (IL:MASTERSCOPE '(ANALYZE GFUN-B)) (IL:MASTERSCOPE '(ANALYZE GFUN-A1)) (IL:MASTERSCOPE '(ANALYZE GFUN-A2)) (IL:MASTERSCOPE '(ANALYZE GFUN-A3)) (IL:MASTERSCOPE '(ANALYZE GFUN-B1)) (IL:MASTERSCOPE '(ANALYZE GFUN-B2)) (IL:MASTERSCOPE '(ANALYZE GFUN-B3)) (IL:MASTERSCOPE '(ANALYZE GFUN-C1)) ; Browser is now loaded and activated by Part 1 test of browser ; Part 2 of this test is to determine if masterscope is modified by enabling ; the BROWSER or (IL:BROWSER T) (IL:BROWSER T) ; show paths should display the following path graphically in a display window ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion ; show paths should display the above path graphically in a display window ; as being shown on the lower left from ; {eris}test>program-analysis>browser.graph. ; Loading the graph....... ; ; The graph returned from BROWSER should look like the one that is being ; displayed on the lower right. If they are identical, please enter ; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) ; at the end of the test. If it breaks, enter ^ in the break ; window to return to exec. The result will automatically be logged ; in {eris}test>program-analysis>browser.report. (IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) (PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ new file mode 100644 index 00000000..488606b5 --- /dev/null +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER-2 (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 11, 1987 ;; ;; Filed As: {ERIS}test>program-analysis>browser-part2.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test ;; determines if BROWSER modified masterscope in such a way that paths are displayed ;; grahically in a display window. ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "BROWSER2-TEST-SETUP" (PROGN (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>BROWSER.REPORT") (DEFUN BROWSER-FAILED NIL (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'BROWSER-DISPLAY NIL) (CLOSE *OUTPUT*) (IL:CLOSEW BROWSERW) (IL:CLRPROMPT))) (DEFUN BROWSER-SUCCEEDED NIL (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'BROWSER-DISPLAY T) (CLOSE *OUTPUT*) (IL:CLOSEW BROWSERW) (IL:CLRPROMPT))) (SETQ MESSAGE " Please enter (BROWSER-SUCCEEDED) if test has succeeded or (BROWSER-FAILED) if test has failed.") (SETQ BROWSER2-COMMAND-STRING "; Reinitialize and Define functions to be analyzed.... (PAUSE) . ERASE (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) ; Start analyzing functions in gtop-function and others... (PAUSE) . ANALYZE TOP-GFUNTION . ANALYZE GFUN-A . ANALYZE GFUN-B . ANALYZE GFUN-A1 . ANALYZE GFUN-A2 . ANALYZE GFUN-A3 . ANALYZE GFUN-B1 . ANALYZE GFUN-B2 . ANALYZE GFUN-B3 . ANALYZE GFUN-C1 ; Browser is now loaded and activated by Part 1 test of browser ; Part 2 of this test is to determine if masterscope is modified by enabling ; the BROWSER or (IL:BROWSER T) (IL:BROWSER T) (PAUSE) ; show paths should display the following path graphically in a display window ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion ; show paths should display the above path graphically in a display window ; as being shown on the lower left from ; {eris}test>program-analysis>browser.graph. ; Loading the graph....... (PAUSE) (IL:TEDIT '{eris}test>program-analysis>browser.graph BROWSERW) (IL:TTY.PROCESS 'EXEC) ; ; The graph returned from BROWSER should look like the one that is being ; displayed on the lower right. If they are identical, please enter ; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) ; at the end of the test. If it breaks, enter ^ in the break ; window to return to exec. The result will automatically be logged ; in {eris}test>program-analysis>browser.report. (PAUSE) (IL:PROMPTPRINT MESSAGE) . SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION ") (IL:BKSYSBUF BROWSER2-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ new file mode 100644 index 00000000..ea15ddd0 --- /dev/null +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER-2 (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 11, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>browser-part2.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test ;; determines if BROWSER modified masterscope in such a way that paths are displayed ;; grahically in a display window. ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "BROWSER2-TEST-SETUP" (PROGN (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>BROWSER.REPORT") (DEFUN BROWSER-FAILED NIL (PROGN (PASS-FAIL 'BROWSER-DISPLAY NIL) (IL:CLOSEW BROWSERW) (IL:CLRPROMPT))) (DEFUN BROWSER-SUCCEEDED NIL (PROGN (PASS-FAIL 'BROWSER-DISPLAY T) (IL:CLOSEW BROWSERW) (IL:CLRPROMPT))) (SETQ MESSAGE " Please enter (BROWSER-SUCCEEDED) if test has succeeded or (BROWSER-FAILED) if test has failed.") ; Reinitialize and Define functions to be analyzed.... (PAUSE) (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) ; Start analyzing functions in gtop-function and others... (PAUSE) (IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) (IL:MASTERSCOPE '(ANALYZE GFUN-A)) (IL:MASTERSCOPE '(ANALYZE GFUN-B)) (IL:MASTERSCOPE '(ANALYZE GFUN-A1)) (IL:MASTERSCOPE '(ANALYZE GFUN-A2)) (IL:MASTERSCOPE '(ANALYZE GFUN-A3)) (IL:MASTERSCOPE '(ANALYZE GFUN-B1)) (IL:MASTERSCOPE '(ANALYZE GFUN-B2)) (IL:MASTERSCOPE '(ANALYZE GFUN-B3)) (IL:MASTERSCOPE '(ANALYZE GFUN-C1)) ; Browser is now loaded and activated by Part 1 test of browser ; Part 2 of this test is to determine if masterscope is modified by enabling ; the BROWSER or (IL:BROWSER T) (IL:BROWSER T) (PAUSE) ; show paths should display the following path graphically in a display window ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion ; show paths should display the above path graphically in a display window ; as being shown on the lower left from ; {eris}test>program-analysis>browser.graph. ; Loading the graph....... (PAUSE) ; ; The graph returned from BROWSER should look like the one that is being ; displayed on the lower right. If they are identical, please enter ; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) ; at the end of the test. If it breaks, enter ^ in the break ; window to return to exec. The result will automatically be logged ; in {eris}test>program-analysis>browser.report. (PAUSE) (IL:PROMPTPRINT MESSAGE) (IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) (PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ new file mode 100644 index 00000000..34b7df7b --- /dev/null +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER-2 (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 11, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>browser-part2.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test ;; determines if BROWSER modified masterscope in such a way that paths are displayed ;; grahically in a display window. ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "BROWSER2-TEST-SETUP" (IL:FILESLOAD (IL:SYSLOAD) MASTERSCOPE BROWSER GRAPHER) (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Reinitialize and Define functions to be analyzed.... (PAUSE) (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) ; Start analyzing functions in gtop-function and others... (PAUSE) (IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) (IL:MASTERSCOPE '(ANALYZE GFUN-A)) (IL:MASTERSCOPE '(ANALYZE GFUN-B)) (IL:MASTERSCOPE '(ANALYZE GFUN-A1)) (IL:MASTERSCOPE '(ANALYZE GFUN-A2)) (IL:MASTERSCOPE '(ANALYZE GFUN-A3)) (IL:MASTERSCOPE '(ANALYZE GFUN-B1)) (IL:MASTERSCOPE '(ANALYZE GFUN-B2)) (IL:MASTERSCOPE '(ANALYZE GFUN-B3)) (IL:MASTERSCOPE '(ANALYZE GFUN-C1)) ; Browser is now loaded and activated by Part 1 test of browser ; Part 2 of this test is to determine if masterscope is modified by enabling ; the BROWSER or (IL:BROWSER T) (IL:BROWSER T) ; show paths should display the following path graphically in a display window ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion ; show paths should display the above path graphically in a display window ; as being shown on the lower left from ; {eris}test>program-analysis>browser.graph. ; Loading the graph....... ; ; The graph returned from BROWSER should look like the one that is being ; displayed on the lower right. If they are identical, please enter ; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) ; at the end of the test. If it breaks, enter ^ in the break ; window to return to exec. The result will automatically be logged ; in {eris}test>program-analysis>browser.report. (IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) (PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ new file mode 100644 index 00000000..ff6aff2b --- /dev/null +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER-2 (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 11, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>browser-part2.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test ;; determines if BROWSER modified masterscope in such a way that paths are displayed ;; grahically in a display window. ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "BROWSER2-TEST-SETUP" (IL:FILESLOAD (IL:SYSLOAD) MASTERSCOPE BROWSER GRAPHER) (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Reinitialize and Define functions to be analyzed.... (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) (IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) (IL:MASTERSCOPE '(ANALYZE GFUN-A)) (IL:MASTERSCOPE '(ANALYZE GFUN-B)) (IL:MASTERSCOPE '(ANALYZE GFUN-A1)) (IL:MASTERSCOPE '(ANALYZE GFUN-A2)) (IL:MASTERSCOPE '(ANALYZE GFUN-A3)) (IL:MASTERSCOPE '(ANALYZE GFUN-B1)) (IL:MASTERSCOPE '(ANALYZE GFUN-B2)) (IL:MASTERSCOPE '(ANALYZE GFUN-B3)) (IL:MASTERSCOPE '(ANALYZE GFUN-C1)) ; Browser is now loaded and activated by Part 1 test of browser ; Part 2 of this test is to determine if masterscope is modified by enabling ; the BROWSER or (IL:BROWSER T) (IL:BROWSER T) ; show paths should display the following path graphically in a display window ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion ; show paths should display the above path graphically in a display window ; as being shown on the lower left from ; {eris}test>program-analysis>browser.graph. ; Loading the graph....... ; ; The graph returned from BROWSER should look like the one that is being ; displayed on the lower right. If they are identical, please enter ; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) ; at the end of the test. If it breaks, enter ^ in the break ; window to return to exec. The result will automatically be logged ; in {eris}test>program-analysis>browser.report. (IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) (PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/BROWSER.GRAPH b/internal/test/env/program-analysis/hand/BROWSER.GRAPH new file mode 100644 index 0000000000000000000000000000000000000000..dfb6266adfc1e0cb0c951596eb2ebdb51d79818f GIT binary patch literal 3076 zcmeH}?@JUx7{}*Q)59yzeUV64w^<8{l$vi$B=4^L(WNKE6_H@k8-*x^f)it1#rp$H zgx*<1y{j-P&qR06d}S}Pd?VrItWrp?cEw;{EIQ53?rpbv>IDV8xOp-A%sij@&htF; za2&7!JZz;P0Bk6gA*KQ$QQVLVV(z|Wl%2uyNPzwQ^7?ADOXjAduygeA4CJtmD6yN$ zqNFTssvJ9lghv7|-Cb3skibLO&Z|>%I@Ntyont3A6ii8>5RM*ALfCm$omw)fm|Iy!x!eFxC|L=qvVz`2 zQQ}pj5-63CV(n9rLZbHW>5;BLx&rA6{1+9dHGa3EyGBDBUeBLWg+Cfy`r*p?!76gP z>~&xJv$A(X30jQ3gStVSe(KW+Vifs3!^{)vS^{;<-c8ZO>7!(m3NtHI+ixo4#q9mq zagtQ)kTOn;m5U=0D^NB`PnV{QG=#?s^X`E;KX9JPAmE0dzaZ?eiW#Q47TYreKKJelRJ zu{yV}4t<;Yo*&)5Z{4B7&+`WN)WTHG;7)Owf(Hjq~<}n^+d-3Lgh2GpZaV+nS=s0xK~ZeN3Ge*l2KZ( ze&Dq9)|k20p&clIyU=ai2>jG5ducK)jmqDf!o6xxg`nE;z?CdVqM}c`)axHnZmk@6 zhza_C(bUEFnDx6efeqAxisJKi_1?=(!TOd!kglMM8@%Tly>vx+N!+Z$Rtest>program-analysis>databasefns.u ;; ;; ;; Syntax: (DUMPDB FILE) & (LOADDB FILE) ;; ;; Function Description: DATABASEFNS is a very small package whose purpose is to make ;; the construction and maintenance of masterscope data bases an essentially automatic ;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. ;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. ;; The user can dump and restore data bases explicitly via the following functions: ;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, ;; so that data base maintenance for FILE will subsequently be automatic. ;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is ;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be ;; thereafter automatic. ;; ;; Argument(s): (SEE Databasefns documentation) ;; ;; Returns: (SEE Databasefns documentation) ;; ;; Constraints/Limitations: The primary emphasis of this testing is the explicit ;; dumpting and restoration of data bases. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>databasefns.report. This test requires ;; DATABASEFNS, TEDIT, and MASTERSCOPE. ;; ;; ;; (DO-TEST "DATABASEFNS-TEST-SETUP" (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (SETQ TEST-SUCCEEDED T) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Good one!" )) (SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Loading databasefns and other required files from {erinyes}library>.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) ; Copy the necessary source file (data) to {core} (IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA '{CORE}NEW-FUNCTION) (IL:CNDIR '{CORE}) ; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially ; set to ASK (PASS-FAIL "DATABASEFNS VARIABLES" (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK))) ; This part of the test loads the initial data file for masterscope analysis (IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (LOAD '{CORE}NEW-FUNCTION) (IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) (SETQ OLD-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) (IL:CLRPROMPT) ; New-function is redefined; it also utilized times function ... (IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) (SETQ NEW-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) (PASS-FAIL "DATABASE UPDATE" (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES))) (IL:DUMPDB '{CORE}NEW-FUNCTION) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) (PASS-FAIL "DATABASE CREATED" (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (IL:LOADDB '{CORE}NEW-FUNCTION) (PASS-FAIL "DATABASE PROP RESET" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES)) ; Loading the database file will reset the property database with 'YES values ; and make masterscope database maintenance automatic.. (IL:PROMPTPRINT "enter n it the system asks you to save any variables: enter y if the system asks you if you want a masterscope database") (IL:CLEANUP) ; Now new souce and compiles files and corresponding database should have been ; created (PASS-FAIL "DATABASE CREATED BY MAKEFILE" (AND (PROBE-FILE '{CORE}NEW-FUNCTION) (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE))) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) ; Displaying the database that has been created in a tedit window... (IL:PROMPTPRINT "Displaying the database in a tedit window...") (SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) (SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE DATA-WINDOW )) (SLEEP 4) (CLOSE DATA-STREAM) (IL:CLOSEW DATA-WINDOW) ; Erasing masterscope record for NEW-FUNCTION.... (IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) (IL:PROMPTPRINT ". who calls who should now return nil") (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) ; Setting the variable LOADDBFLG to NO will not load the database file... (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (SETQ IL:LOADDBFLG 'IL:NO) (IL:LOAD '{CORE}NEW-FUNCTION) (PASS-FAIL "LOADDBFLG SET TO NO" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) ) ; Setting the variable LOADDBFLG to YES will load the database file... (SETQ IL:LOADDBFLG 'IL:YES) (IL:LOAD '{CORE}NEW-FUNCTION) (PASS-FAIL "LOADDBFLG SET TO YES" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES)) ; Now delete all the files except for the original file for new-function (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (IL:CNDIR '{DSK}) (IL:CLRPROMPT) (SETQ IL:LOADDBFLG 'IL:ASK) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ new file mode 100644 index 00000000..c8bf69f2 --- /dev/null +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: DATABASEFNS (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: March 20, 1987 ;; ;; Filed As: {ERIS}test>program-analysis>databasefns.u ;; ;; ;; Syntax: (DUMPDB FILE) & (LOADDB FILE) ;; ;; Function Description: DATABASEFNS is a very small package whose purpose is to make ;; the construction and maintenance of masterscope data bases an essentially automatic ;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. ;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. ;; The user can dump and restore data bases explicitly via the following functions: ;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, ;; so that data base maintenance for FILE will subsequently be automatic. ;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is ;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be ;; thereafter automatic. ;; ;; Argument(s): (SEE Databasefns documentation) ;; ;; Returns: (SEE Databasefns documentation) ;; ;; Constraints/Limitations: The primary emphasis of this testing is the explicit ;; dumpting and restoration of data bases. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>databasefns.report. This test requires ;; DATABASEFNS, TEDIT, and MASTERSCOPE. ;; ;; ;; (DO-TEST "DATABASEFNS-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DATABASEFNS: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (SETQ DATABASEFNS-COMMAND-STRING "; Loading databasefns and other required files from {erinyes}library>.... (PAUSE) (IL:PAGEHEIGHT 0) (IL:LOAD? '{ERINYES}LIBRARY>TEDIT.LCOM 'IL:SYSLOAD) (IL:LOAD? '{ERINYES}LIBRARY>MASTERSCOPE.LCOM 'IL:SYSLOAD) (IL:LOAD '{ERINYES}LIBRARY>DATABASEFNS.LCOM 'IL:SYSLOAD) ; Copy the necessary source file (data) to {core} (IL:COPYFILE '{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.DATA '{CORE}NEW-FUNCTION) CONN {CORE} (PAUSE) ; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially ; set to ASK (IF (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK)) (SETQ DB-VARIABLES-FLG T) (SETQ DB-VARIABLES-FLG NIL)) ; This part of the test loads the initial data file for masterscope analysis (IL:PROMPTPRINT '(Please enter Y when masterscope asks for loading)) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (LOAD '{CORE}NEW-FUNCTION) . ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION . WHO IS CALLED BY IL:NEW-FUNCTION (SETQ OLD-CALL-LIST *) (IL:CLRPROMPT) ; New-function is redefined; it also utilized times function ... (IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) . WHO IS CALLED BY IL:NEW-FUNCTION (SETQ NEW-CALL-LIST *) (IF (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES)) (SETQ DB-UPDATE-FLG T) (SETQ DB-UPDATE-FLG NIL)) (IL:DUMPDB '{CORE}NEW-FUNCTION) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) (IF (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE) (SETQ DB-CREATED-FLG T) (SETQ DB-CREATED-FLG NIL)) (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (IL:LOADDB '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (SETQ DB-FLG-RESET T) (SETQ DB-FLG-RESET NIL)) ; Loading the database file will reset the property database with 'YES values ; and make masterscope database maintenance automatic.. ; Cleanup will do recompilation and generate the updated database (PAUSE) (IL:PROMPTPRINT '(enter n it the system asks you to save any variables: enter y if the system asks you if you want a masterscope database)) (IL:CLEANUP) ; Now new souce and compiles files and corresponding database should have been ; created (IF (AND (PROBE-FILE '{CORE}NEW-FUNCTION) (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) (SETQ DB-CREATED-MAKEFILE T) (SETQ DB-CREATED-MAKEFILE NIL)) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) ; Displaying the database that has been created in a tedit window... (IL:PROMPTPRINT '(Displaying the database in a tedit window...)) (PAUSE) (SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) (SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE DATA-WINDOW )) (SLEEP 4) (CLOSE DATA-STREAM) (IL:CLOSEW DATA-WINDOW) ; Erasing masterscope record for NEW-FUNCTION.... . ERASE IL:NEW-FUNCTION (IL:PROMPTPRINT '(. who calls who should now return nil)) (PAUSE) . WHO IS CALLED BY IL:NEW-FUNCTION ; Setting the variable LOADDBFLG to NO will not load the database file... (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (SETQ IL:LOADDBFLG 'IL:NO) (IL:LOAD '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) (SETQ DB-NOT-LOADED T) (SETQ DB-NOT-LOADED NIL)) ; Setting the variable LOADDBFLG to YES will load the database file... (SETQ IL:LOADDBFLG 'IL:YES) (IL:LOAD '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (SETQ DB-LOADED T) (SETQ DB-LOADED NIL)) ; Now delete all the files except for the original file for new-function (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) CONN {DSK} (IL:CLRPROMPT) (SETQ IL:LOADDBFLG 'IL:ASK) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) (DO-TEST 'DATABASEFNS-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'DABASEFNS-VARIABLES DB-VARIABLES-FLG) (PASS-FAIL 'DATABASE-UPDATE DB-UPDATE-FLG) (PASS-FAIL 'DATABASE-CREATED DB-CREATED-FLG) (PASS-FAIL 'DATABASE-PROP-RESET DB-FLG-RESET) (PASS-FAIL 'DATABASE-CREATED-BY-MAKEFILE DB-CREATED-MAKEFILE) (PASS-FAIL 'LOADDB-FLG-NO DB-NOT-LOADED) (PASS-FAIL 'LOADDB-FLG-YES DB-LOADED) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) ") (IL:BKSYSBUF DATABASEFNS-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ new file mode 100644 index 00000000..7ce81505 --- /dev/null +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: DATABASEFNS (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: March 20, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>databasefns.u ;; ;; ;; Syntax: (DUMPDB FILE) & (LOADDB FILE) ;; ;; Function Description: DATABASEFNS is a very small package whose purpose is to make ;; the construction and maintenance of masterscope data bases an essentially automatic ;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. ;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. ;; The user can dump and restore data bases explicitly via the following functions: ;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, ;; so that data base maintenance for FILE will subsequently be automatic. ;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is ;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be ;; thereafter automatic. ;; ;; Argument(s): (SEE Databasefns documentation) ;; ;; Returns: (SEE Databasefns documentation) ;; ;; Constraints/Limitations: The primary emphasis of this testing is the explicit ;; dumpting and restoration of data bases. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>databasefns.report. This test requires ;; DATABASEFNS, TEDIT, and MASTERSCOPE. ;; ;; ;; (DO-TEST "DATABASEFNS-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DATABASEFNS: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (NOT TEST-ITEM) (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) )) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Loading databasefns and other required files from {erinyes}library>.... (PAUSE) (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) ; Copy the necessary source file (data) to {core} (IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA '{CORE}NEW-FUNCTION) (IL:CNDIR '{CORE}) (PAUSE) ; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially ; set to ASK (IF (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK)) (SETQ DB-VARIABLES-FLG T) (SETQ DB-VARIABLES-FLG NIL)) ; This part of the test loads the initial data file for masterscope analysis (IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (LOAD '{CORE}NEW-FUNCTION) (IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) (SETQ OLD-CALL-LIST *) (IL:CLRPROMPT) ; New-function is redefined; it also utilized times function ... (IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) (SETQ NEW-CALL-LIST *) (IF (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES)) (SETQ DB-UPDATE-FLG T) (SETQ DB-UPDATE-FLG NIL)) (IL:DUMPDB '{CORE}NEW-FUNCTION) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) (IF (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE) (SETQ DB-CREATED-FLG T) (SETQ DB-CREATED-FLG NIL)) (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (IL:LOADDB '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (SETQ DB-FLG-RESET T) (SETQ DB-FLG-RESET NIL)) ; Loading the database file will reset the property database with 'YES values ; and make masterscope database maintenance automatic.. ; Cleanup will do recompilation and generate the updated database (PAUSE) (IL:PROMPTPRINT "enter n it the system asks you to save any variables: enter y if the system asks you if you want a masterscope database") (IL:CLEANUP) ; Now new souce and compiles files and corresponding database should have been ; created (IF (AND (PROBE-FILE '{CORE}NEW-FUNCTION) (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) (SETQ DB-CREATED-MAKEFILE T) (SETQ DB-CREATED-MAKEFILE NIL)) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) ; Displaying the database that has been created in a tedit window... (IL:PROMPTPRINT "Displaying the database in a tedit window...") (PAUSE) (SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) (SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE DATA-WINDOW )) (SLEEP 4) (CLOSE DATA-STREAM) (IL:CLOSEW DATA-WINDOW) ; Erasing masterscope record for NEW-FUNCTION.... (IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) (IL:PROMPTPRINT ". who calls who should now return nil") (PAUSE) (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) ; Setting the variable LOADDBFLG to NO will not load the database file... (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (SETQ IL:LOADDBFLG 'IL:NO) (IL:LOAD '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) (SETQ DB-NOT-LOADED T) (SETQ DB-NOT-LOADED NIL)) ; Setting the variable LOADDBFLG to YES will load the database file... (SETQ IL:LOADDBFLG 'IL:YES) (IL:LOAD '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (SETQ DB-LOADED T) (SETQ DB-LOADED NIL)) ; Now delete all the files except for the original file for new-function (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (IL:CNDIR '{DSK}) (IL:CLRPROMPT) (SETQ IL:LOADDBFLG 'IL:ASK) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) ) ) (DO-TEST 'DATABASEFNS-TEST-RESULT (PROGN (PASS-FAIL 'DABASEFNS-VARIABLES DB-VARIABLES-FLG) (PASS-FAIL 'DATABASE-UPDATE DB-UPDATE-FLG) (PASS-FAIL 'DATABASE-CREATED DB-CREATED-FLG) (PASS-FAIL 'DATABASE-PROP-RESET DB-FLG-RESET) (PASS-FAIL 'DATABASE-CREATED-BY-MAKEFILE DB-CREATED-MAKEFILE) (PASS-FAIL 'LOADDB-FLG-NO DB-NOT-LOADED) (PASS-FAIL 'LOADDB-FLG-YES DB-LOADED) (T-FORMAT TOTAL-TEST-TIME) (IDENTITY T) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ new file mode 100644 index 00000000..0032b647 --- /dev/null +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ @@ -0,0 +1 @@ +;; Function To Be Tested: DATABASEFNS (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: March 20, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>databasefns.u ;; ;; ;; Syntax: (DUMPDB FILE) & (LOADDB FILE) ;; ;; Function Description: DATABASEFNS is a very small package whose purpose is to make ;; the construction and maintenance of masterscope data bases an essentially automatic ;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. ;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. ;; The user can dump and restore data bases explicitly via the following functions: ;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, ;; so that data base maintenance for FILE will subsequently be automatic. ;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is ;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be ;; thereafter automatic. ;; ;; Argument(s): (SEE Databasefns documentation) ;; ;; Returns: (SEE Databasefns documentation) ;; ;; Constraints/Limitations: The primary emphasis of this testing is the explicit ;; dumpting and restoration of data bases. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>databasefns.report. This test requires ;; DATABASEFNS, TEDIT, and MASTERSCOPE. ;; ;; ;; (DO-TEST "DATABASEFNS-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DATABASEFNS: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (NOT TEST-ITEM) (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) )) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Loading databasefns and other required files from {erinyes}library>.... (PAUSE) (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) ; Copy the necessary source file (data) to {core} (IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA '{CORE}NEW-FUNCTION) (IL:CNDIR '{CORE}) (PAUSE) ; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially ; set to ASK (IF (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK)) (SETQ DB-VARIABLES-FLG T) (SETQ DB-VARIABLES-FLG NIL)) ; This part of the test loads the initial data file for masterscope analysis (IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (LOAD '{CORE}NEW-FUNCTION) (IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) (SETQ OLD-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) (IL:CLRPROMPT) ; New-function is redefined; it also utilized times function ... (IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) (SETQ NEW-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) (IF (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES)) (SETQ DB-UPDATE-FLG T) (SETQ DB-UPDATE-FLG NIL)) (IL:DUMPDB '{CORE}NEW-FUNCTION) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) (IF (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE) (SETQ DB-CREATED-FLG T) (SETQ DB-CREATED-FLG NIL)) (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (IL:LOADDB '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (SETQ DB-FLG-RESET T) (SETQ DB-FLG-RESET NIL)) ; Loading the database file will reset the property database with 'YES values ; and make masterscope database maintenance automatic.. ; Cleanup will do recompilation and generate the updated database (PAUSE) (IL:PROMPTPRINT "enter n it the system asks you to save any variables: enter y if the system asks you if you want a masterscope database") (IL:CLEANUP) ; Now new souce and compiles files and corresponding database should have been ; created (IF (AND (PROBE-FILE '{CORE}NEW-FUNCTION) (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) (SETQ DB-CREATED-MAKEFILE T) (SETQ DB-CREATED-MAKEFILE NIL)) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) ; Displaying the database that has been created in a tedit window... (IL:PROMPTPRINT "Displaying the database in a tedit window...") (PAUSE) (SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) (SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE DATA-WINDOW )) (SLEEP 4) (CLOSE DATA-STREAM) (IL:CLOSEW DATA-WINDOW) ; Erasing masterscope record for NEW-FUNCTION.... (IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) (IL:PROMPTPRINT ". who calls who should now return nil") (PAUSE) (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) ; Setting the variable LOADDBFLG to NO will not load the database file... (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (SETQ IL:LOADDBFLG 'IL:NO) (IL:LOAD '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) (SETQ DB-NOT-LOADED T) (SETQ DB-NOT-LOADED NIL)) ; Setting the variable LOADDBFLG to YES will load the database file... (SETQ IL:LOADDBFLG 'IL:YES) (IL:LOAD '{CORE}NEW-FUNCTION) (IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (SETQ DB-LOADED T) (SETQ DB-LOADED NIL)) ; Now delete all the files except for the original file for new-function (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (IL:CNDIR '{DSK}) (IL:CLRPROMPT) (SETQ IL:LOADDBFLG 'IL:ASK) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) ) ) (DO-TEST 'DATABASEFNS-TEST-RESULT (PROGN (PASS-FAIL 'DABASEFNS-VARIABLES DB-VARIABLES-FLG) (PASS-FAIL 'DATABASE-UPDATE DB-UPDATE-FLG) (PASS-FAIL 'DATABASE-CREATED DB-CREATED-FLG) (PASS-FAIL 'DATABASE-PROP-RESET DB-FLG-RESET) (PASS-FAIL 'DATABASE-CREATED-BY-MAKEFILE DB-CREATED-MAKEFILE) (PASS-FAIL 'LOADDB-FLG-NO DB-NOT-LOADED) (PASS-FAIL 'LOADDB-FLG-YES DB-LOADED) (T-FORMAT TOTAL-TEST-TIME) (IDENTITY T) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ new file mode 100644 index 00000000..2cde5e8d --- /dev/null +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ @@ -0,0 +1 @@ +;; Function To Be Tested: DATABASEFNS (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 18, 1987 ;; ;; Last Update: March 20, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>databasefns.u ;; ;; ;; Syntax: (DUMPDB FILE) & (LOADDB FILE) ;; ;; Function Description: DATABASEFNS is a very small package whose purpose is to make ;; the construction and maintenance of masterscope data bases an essentially automatic ;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. ;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. ;; The user can dump and restore data bases explicitly via the following functions: ;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, ;; so that data base maintenance for FILE will subsequently be automatic. ;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is ;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be ;; thereafter automatic. ;; ;; Argument(s): (SEE Databasefns documentation) ;; ;; Returns: (SEE Databasefns documentation) ;; ;; Constraints/Limitations: The primary emphasis of this testing is the explicit ;; dumpting and restoration of data bases. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>databasefns.report. This test requires ;; DATABASEFNS, TEDIT, and MASTERSCOPE. ;; ;; ;; (DO-TEST "DATABASEFNS-TEST-SETUP" (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (SETQ TEST-SUCCEEDED T) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Good one!" )) (SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) ; Loading databasefns and other required files from {erinyes}library>.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) ; Copy the necessary source file (data) to {core} (IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA '{CORE}NEW-FUNCTION) (IL:CNDIR '{CORE}) ; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially ; set to ASK (PASS-FAIL "DATABASEFNS VARIABLES" (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK))) ; This part of the test loads the initial data file for masterscope analysis (IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) (LOAD '{CORE}NEW-FUNCTION) (IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) (SETQ OLD-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) (IL:CLRPROMPT) ; New-function is redefined; it also utilized times function ... (IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) (SETQ NEW-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) (PASS-FAIL "DATABASE UPDATE" (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES))) (IL:DUMPDB '{CORE}NEW-FUNCTION) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) (PASS-FAIL "DATABASE CREATED" (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (IL:LOADDB '{CORE}NEW-FUNCTION) (PASS-FAIL "DATABASE PROP RESET" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES)) ; Loading the database file will reset the property database with 'YES values ; and make masterscope database maintenance automatic.. (IL:PROMPTPRINT "enter n it the system asks you to save any variables: enter y if the system asks you if you want a masterscope database") (IL:CLEANUP) ; Now new souce and compiles files and corresponding database should have been ; created (PASS-FAIL "DATABASE CREATED BY MAKEFILE" (AND (PROBE-FILE '{CORE}NEW-FUNCTION) (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE))) (SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) ; Displaying the database that has been created in a tedit window... (IL:PROMPTPRINT "Displaying the database in a tedit window...") (SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) (SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE DATA-WINDOW )) (SLEEP 4) (CLOSE DATA-STREAM) (IL:CLOSEW DATA-WINDOW) ; Erasing masterscope record for NEW-FUNCTION.... (IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) (IL:PROMPTPRINT ". who calls who should now return nil") (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) ; Setting the variable LOADDBFLG to NO will not load the database file... (IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) (SETQ IL:LOADDBFLG 'IL:NO) (IL:LOAD '{CORE}NEW-FUNCTION) (PASS-FAIL "LOADDBFLG SET TO NO" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) ) ; Setting the variable LOADDBFLG to YES will load the database file... (SETQ IL:LOADDBFLG 'IL:YES) (IL:LOAD '{CORE}NEW-FUNCTION) (PASS-FAIL "LOADDBFLG SET TO YES" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES)) ; Now delete all the files except for the original file for new-function (MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) (IL:CNDIR '{DSK}) (IL:CLRPROMPT) (SETQ IL:LOADDBFLG 'IL:ASK) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/INSPECT.U b/internal/test/env/program-analysis/hand/INSPECT.U new file mode 100644 index 00000000..bb3aeca3 --- /dev/null +++ b/internal/test/env/program-analysis/hand/INSPECT.U @@ -0,0 +1 @@ +;; Function To Be Tested: INSPECTOR (Program Analysis) ;; ;; Source: IRM VOLUME 3 (Lyric Beta Release 2) ;; Section 26. User Input/Output Packages ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: March 21, 1987 ;; ;; Last Update: March 30, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>inspector.u ;; ;; ;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function ;; ;; Function Description: The inspector provides a display-oriented and window-based ;; facility for looking at and changing arbitrary Interlisp-D data structures. ;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. ;; The inspector displays the field names and values of an arbitrary object in ;; a window that allows setting of the properties and further inpection of the values. ;; This latter feature makes it possible to "walk" around all of the data structures ;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 ;; pages 26.1 through 26.9 ;; ;; Argument(s): The primary function for inspector is INSPECT whose arguments are ;; described here. ;; OBJECT: object to be inspected ;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be ;; used to determine its property names in the inspect window. ;; WHERE: speccifies the location of the inspect window. If NIL, the user will be ;; prompted for location ;; ;; Returns: Inspection Window ;; ;; Constraints/Limitations: The primary emphasis of this testing will be focused ;; on the function INSPECT. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>inspect.report. This test requires ;; TEDIT package. ;; ;; ;; (DO-TEST "INSPECTOR-TEST-SETUP" (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Woo! It worked!" )) (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) (SETQ INSPECTOR "INSPECTOR") (SETQ INSPECTCODE-TITLE "CODE FOR COS") ; Creating various objects to be inspected.... (SETQ INSPECT-ITEM-LIST (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (setq hash (make-hash-table 7)) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(a b c d) ; list 37e5 ; long-float (= 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname ;*random-state* ; random state - inspecting this hangs 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector IL:promptwindow ; window )) (SETF (GETHASH 'COLOR HASH) 'BROWN (GETHASH 'NAME HASH) 'FRED (GETHASH 'AGE HASH) 29 (GETHASH 'PHONE HASH) '777-6551 (GETHASH 'HEIGHT HASH) '6-FEET (GETHASH 'WEIGHT HASH) '170) (SETQ SPACE ": ") (SETQ MESS0 "In this part of test, various lisp objects will be inspected. Numbers except for complex and fraction types, and characters are not inspectable and an appropriate message will be printed. If a inspect menu pops up, select the item INSPECT To create an inspector window, simply click the left mouse button Please respond with y or n after an inspector window is created. ") (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") (SETQ MESS2 "Please indicate a position for inspecting the compiled function COS with left mouse button") (SETQ MESS3 "Is the inspector window displayed for the compiled function COS (Yes or NO?)") (SETQ MESS4 "Is the inspection information displayed in the specified inspector window?") (SETQ MESS5 "The inspector window should have been created for inspecting the compiled function COS") (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) Please run this test after this test is completed by entering (INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. If it still fails the test, please update the log file accordingly: {eris}test>program-analysis>inspect.report.") (SETQ MESS7 "Are you ready to start testing(y or n)? ") (SETQ PROMPT-MESS "Item being inspected: ") (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") ; Load TEDIT if not already loaded.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT) ; Check the intial value of inspector variables... (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES (AND (= IL:MAXINSPECTCDRLEVEL 50) (= IL:MAXINSPECTARRAYLEVEL 300) (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) (EQ IL:INSPECTALLFIELDSFLG T))) ; Create various objects to be inspected... ; Trying to inspect random state object will hang the system (never returns) ; A number or character cannot be inspected and an appropriate message should be ; generated for these objects... (SETQ INSPECT-ITEM-NAMES '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER PACKAGE PATHNAME RATIO RATIONAL READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING STRING-CHAR SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES) (Y-OR-N-P MESS7) (SETQ INSPECT-WINDOWS NIL) (IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) (INSPECT ITEM) (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) (Y-OR-N-P (FORMAT T MESS1 POP-ITEM POP-ITEM))) ) (IL:FOR X IL:IN ITEM-NAMES IL:DO (SETQ PF-ITEM (POP ITEM-NAMES)) (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG)))) ; Inspecting the compiled code of the function... (IL:PROMPTPRINT MESS5) (IL:INSPECTCODE 'COS) (PASS-FAIL 'INSPECTCODE (Y-OR-N-P MESS3)) ; Closing the inspector window... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) ; Testing to see if an object could be displayed in a specified window... (SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) (IL:OPENW INSPECTORW) (INSPECT INSPECT-ARRAY NIL INSPECTORW) (PASS-FAIL 'INSPECT-WHERE (Y-OR-N-P MESS4)) ; Delete all inspect windows that have been created... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 0 :end1 9) (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) ) ) ; Test for AR8203 (IL:PROMPTPRINT MESS6) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~1~ b/internal/test/env/program-analysis/hand/INSPECT.U.~1~ new file mode 100644 index 00000000..0d2e99fa --- /dev/null +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: INSPECTOR (Program Analysis) ;; ;; Source: IRM VOLUME 3 (Lyric Beta Release 2) ;; Section 26. User Input/Output Packages ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: March 21, 1987 ;; ;; Last Update: March 30, 1987 ;; ;; Filed As: {ERIS}test>program-analysis>inspector.u ;; ;; ;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function ;; ;; Function Description: The inspector provides a display-oriented and window-based ;; facility for looking at and changing arbitrary Interlisp-D data structures. ;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. ;; The inspector displays the field names and values of an arbitrary object in ;; a window that allows setting of the properties and further inpection of the values. ;; This latter feature makes it possible to "walk" around all of the data structures ;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 ;; pages 26.1 through 26.9 ;; ;; Argument(s): The primary function for inspector is INSPECT whose arguments are ;; described here. ;; OBJECT: object to be inspected ;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be ;; used to determine its property names in the inspect window. ;; WHERE: speccifies the location of the inspect window. If NIL, the user will be ;; prompted for location ;; ;; Returns: Inspection Window ;; ;; Constraints/Limitations: The primary emphasis of this testing will be focused ;; on the function INSPECT. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>inspect.report. This test requires ;; TEDIT package. ;; ;; ;; (DO-TEST "INSPECTOR-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>INSPECT.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR INSPECTOR: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) (SETQ INSPECTOR "INSPECTOR") (SETQ INSPECTCODE-TITLE "CODE FOR COS") ; Creating various objects to be inspected.... (PAUSE) (SETQ INSPECT-ITEM-LIST (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (setq hash (make-hash-table 7)) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(a b c d) ; list 37e5 ; long-float (= 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname ;*random-state* ; random state - inspecting this hangs 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector IL:promptwindow ; window )) (SETF (GETHASH 'COLOR HASH) 'BROWN (GETHASH 'NAME HASH) 'FRED (GETHASH 'AGE HASH) 29 (GETHASH 'PHONE HASH) '777-6551 (GETHASH 'HEIGHT HASH) '6-FEET (GETHASH 'WEIGHT HASH) '170) (SETQ SPACE ": ") (SETQ MESS0 "In this part of test, various lisp objects will be inspected. Numbers except for complex and fraction types, and characters are not inspectable and an appropriate message will be printed. If a inspect menu pops up, select the item INSPECT To create an inspector window, simply click the left mouse button Please respond with y or n after an inspector window is created. ") (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") (SETQ MESS2 "Please indicate a position for inspecting the compiled function COS with left mouse button") (SETQ MESS3 "Is the inspector window displayed for the compiled function COS (Yes or NO?)") (SETQ MESS4 "Is the inspection information displayed in the specified inspector window?") (SETQ MESS5 "The inspector window should have been created for inspecting the compiled function COS") (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) Please run this test after this test is completed by entering (INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. If it still fails the test, please update the log file accordingly: {eris}test>program-analysis>inspect.report.") (SETQ MESS7 "Are you ready to start testing(y or n)? ") (SETQ PROMPT-MESS "Item being inspected: ") (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") ; Inspector test string... (SETQ INSPECTOR-COMMAND-STRING "; Load TEDIT if not already loaded.... (IL:PAGEHEIGHT 0) (IL:LOAD? '{ERINYES}LIBRARY>TEDIT.LCOM 'IL:SYSLOAD) ; Check the intial value of inspector variables... (IF (AND (= IL:MAXINSPECTCDRLEVEL 50) (= IL:MAXINSPECTARRAYLEVEL 300) (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) (EQ IL:INSPECTALLFIELDSFLG T)) (SETQ VARIABLES-SET-CORRECT T) (SETQ VARIABLES-SET-CORRECT NIL)) ; Create various objects to be inspected... ; Trying to inspect random state object will hang the system (never returns) ; A number or character cannot be inspected and an appropriate message should be ; generated for these objects... (SETQ INSPECT-ITEM-NAMES '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER PACKAGE PATHNAME RATIO RATIONAL READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING STRING-CHAR SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) (IL:PROMPTPRINT MESS0) (PAUSE) (IL:ASKUSER 15 'IL:Y MESS7) (SETQ INSPECT-WINDOWS NIL) (IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO (PROGN (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) (PAUSE) (INSPECT ITEM) (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y (FORMAT T MESS1 POP-ITEM POP-ITEM))) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) T) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) NIL)) (IL:CLEARW) (SLEEP 1))) ; Inspecting the compiled code of the function... (PAUSE) (IL:PROMPTPRINT MESS5) (IL:INSPECTCODE 'COS) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS3)) (SETQ INSPECTCODE-FLG T) (SETQ INSPECTCODE-FLG NIL)) (SLEEP 2) ; Closing the inspector window... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) ; Testing to see if an object could be displayed in a specified window... (PAUSE) (SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) (IL:OPENW INSPECTORW) (INSPECT INSPECT-ARRAY NIL INSPECTORW) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS4)) (SETQ INSPECT-WHERE-FLG T) (SETQ INSPECT-WHERE-FLG NIL)) ; Delete all inspect windows that have been created... (PAUSE) (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 0 :end1 9) (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) ) ) ; Test for AR8203 (IL:PROMPTPRINT MESS6) (PAUSE) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) (DO-TEST 'INSPECTOR-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES VARIABLES-SET-CORRECT) (IL:FOR X IL:IN ITEM-NAMES IL:DO (PROGN (SETQ PF-ITEM (POP ITEM-NAMES)) (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG))))) (PASS-FAIL 'INSPECTCODE INSPECTCODE-FLG) (PASS-FAIL 'INSPECT-WHERE INSPECT-WHERE-FLG) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) ") (IL:BKSYSBUF INSPECTOR-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~2~ b/internal/test/env/program-analysis/hand/INSPECT.U.~2~ new file mode 100644 index 00000000..391a9c52 --- /dev/null +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: INSPECTOR (Program Analysis) ;; ;; Source: IRM VOLUME 3 (Lyric Beta Release 2) ;; Section 26. User Input/Output Packages ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: March 21, 1987 ;; ;; Last Update: March 30, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>inspector.u ;; ;; ;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function ;; ;; Function Description: The inspector provides a display-oriented and window-based ;; facility for looking at and changing arbitrary Interlisp-D data structures. ;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. ;; The inspector displays the field names and values of an arbitrary object in ;; a window that allows setting of the properties and further inpection of the values. ;; This latter feature makes it possible to "walk" around all of the data structures ;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 ;; pages 26.1 through 26.9 ;; ;; Argument(s): The primary function for inspector is INSPECT whose arguments are ;; described here. ;; OBJECT: object to be inspected ;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be ;; used to determine its property names in the inspect window. ;; WHERE: speccifies the location of the inspect window. If NIL, the user will be ;; prompted for location ;; ;; Returns: Inspection Window ;; ;; Constraints/Limitations: The primary emphasis of this testing will be focused ;; on the function INSPECT. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>inspect.report. This test requires ;; TEDIT package. ;; ;; ;; (DO-TEST "INSPECTOR-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>INSPECT.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR INSPECTOR: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) (SETQ INSPECTOR "INSPECTOR") (SETQ INSPECTCODE-TITLE "CODE FOR COS") ; Creating various objects to be inspected.... (PAUSE) (SETQ INSPECT-ITEM-LIST (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (setq hash (make-hash-table 7)) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(a b c d) ; list 37e5 ; long-float (= 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname ;*random-state* ; random state - inspecting this hangs 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector IL:promptwindow ; window )) (SETF (GETHASH 'COLOR HASH) 'BROWN (GETHASH 'NAME HASH) 'FRED (GETHASH 'AGE HASH) 29 (GETHASH 'PHONE HASH) '777-6551 (GETHASH 'HEIGHT HASH) '6-FEET (GETHASH 'WEIGHT HASH) '170) (SETQ SPACE ": ") (SETQ MESS0 "In this part of test, various lisp objects will be inspected. Numbers except for complex and fraction types, and characters are not inspectable and an appropriate message will be printed. If a inspect menu pops up, select the item INSPECT To create an inspector window, simply click the left mouse button Please respond with y or n after an inspector window is created. ") (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") (SETQ MESS2 "Please indicate a position for inspecting the compiled function COS with left mouse button") (SETQ MESS3 "Is the inspector window displayed for the compiled function COS (Yes or NO?)") (SETQ MESS4 "Is the inspection information displayed in the specified inspector window?") (SETQ MESS5 "The inspector window should have been created for inspecting the compiled function COS") (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) Please run this test after this test is completed by entering (INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. If it still fails the test, please update the log file accordingly: {eris}test>program-analysis>inspect.report.") (SETQ MESS7 "Are you ready to start testing(y or n)? ") (SETQ PROMPT-MESS "Item being inspected: ") (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") ; Load TEDIT if not already loaded.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT) ; Check the intial value of inspector variables... (IF (AND (= IL:MAXINSPECTCDRLEVEL 50) (= IL:MAXINSPECTARRAYLEVEL 300) (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) (EQ IL:INSPECTALLFIELDSFLG T)) (SETQ VARIABLES-SET-CORRECT T) (SETQ VARIABLES-SET-CORRECT NIL)) ; Create various objects to be inspected... ; Trying to inspect random state object will hang the system (never returns) ; A number or character cannot be inspected and an appropriate message should be ; generated for these objects... (SETQ INSPECT-ITEM-NAMES '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER PACKAGE PATHNAME RATIO RATIONAL READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING STRING-CHAR SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) (IL:PROMPTPRINT MESS0) (PAUSE) (IL:ASKUSER 15 'IL:Y MESS7) (SETQ INSPECT-WINDOWS NIL) (IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO (PROGN (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) (PAUSE) (INSPECT ITEM) (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y (FORMAT T MESS1 POP-ITEM POP-ITEM))) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) T) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) NIL)) (IL:CLEARW) (SLEEP 1))) ; Inspecting the compiled code of the function... (PAUSE) (IL:PROMPTPRINT MESS5) (IL:INSPECTCODE 'COS) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS3)) (SETQ INSPECTCODE-FLG T) (SETQ INSPECTCODE-FLG NIL)) (SLEEP 2) ; Closing the inspector window... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) ; Testing to see if an object could be displayed in a specified window... (PAUSE) (SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) (IL:OPENW INSPECTORW) (INSPECT INSPECT-ARRAY NIL INSPECTORW) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS4)) (SETQ INSPECT-WHERE-FLG T) (SETQ INSPECT-WHERE-FLG NIL)) ; Delete all inspect windows that have been created... (PAUSE) (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 0 :end1 9) (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) ) ) ; Test for AR8203 (IL:PROMPTPRINT MESS6) (PAUSE) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) ) ) (DO-TEST 'INSPECTOR-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES VARIABLES-SET-CORRECT) (IL:FOR X IL:IN ITEM-NAMES IL:DO (PROGN (SETQ PF-ITEM (POP ITEM-NAMES)) (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG))))) (PASS-FAIL 'INSPECTCODE INSPECTCODE-FLG) (PASS-FAIL 'INSPECT-WHERE INSPECT-WHERE-FLG) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~3~ b/internal/test/env/program-analysis/hand/INSPECT.U.~3~ new file mode 100644 index 00000000..f0f87dbf --- /dev/null +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~3~ @@ -0,0 +1 @@ +;; Function To Be Tested: INSPECTOR (Program Analysis) ;; ;; Source: IRM VOLUME 3 (Lyric Beta Release 2) ;; Section 26. User Input/Output Packages ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: March 21, 1987 ;; ;; Last Update: March 30, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>inspector.u ;; ;; ;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function ;; ;; Function Description: The inspector provides a display-oriented and window-based ;; facility for looking at and changing arbitrary Interlisp-D data structures. ;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. ;; The inspector displays the field names and values of an arbitrary object in ;; a window that allows setting of the properties and further inpection of the values. ;; This latter feature makes it possible to "walk" around all of the data structures ;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 ;; pages 26.1 through 26.9 ;; ;; Argument(s): The primary function for inspector is INSPECT whose arguments are ;; described here. ;; OBJECT: object to be inspected ;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be ;; used to determine its property names in the inspect window. ;; WHERE: speccifies the location of the inspect window. If NIL, the user will be ;; prompted for location ;; ;; Returns: Inspection Window ;; ;; Constraints/Limitations: The primary emphasis of this testing will be focused ;; on the function INSPECT. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>inspect.report. This test requires ;; TEDIT package. ;; ;; ;; (DO-TEST "INSPECTOR-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>INSPECT.REPORT") (DEFUN T-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR INSPECTOR: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (NOT TEST-ITEM) (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) )) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) (SETQ INSPECTOR "INSPECTOR") (SETQ INSPECTCODE-TITLE "CODE FOR COS") ; Creating various objects to be inspected.... (PAUSE) (SETQ INSPECT-ITEM-LIST (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (setq hash (make-hash-table 7)) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(a b c d) ; list 37e5 ; long-float (= 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname ;*random-state* ; random state - inspecting this hangs 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector IL:promptwindow ; window )) (SETF (GETHASH 'COLOR HASH) 'BROWN (GETHASH 'NAME HASH) 'FRED (GETHASH 'AGE HASH) 29 (GETHASH 'PHONE HASH) '777-6551 (GETHASH 'HEIGHT HASH) '6-FEET (GETHASH 'WEIGHT HASH) '170) (SETQ SPACE ": ") (SETQ MESS0 "In this part of test, various lisp objects will be inspected. Numbers except for complex and fraction types, and characters are not inspectable and an appropriate message will be printed. If a inspect menu pops up, select the item INSPECT To create an inspector window, simply click the left mouse button Please respond with y or n after an inspector window is created. ") (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") (SETQ MESS2 "Please indicate a position for inspecting the compiled function COS with left mouse button") (SETQ MESS3 "Is the inspector window displayed for the compiled function COS (Yes or NO?)") (SETQ MESS4 "Is the inspection information displayed in the specified inspector window?") (SETQ MESS5 "The inspector window should have been created for inspecting the compiled function COS") (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) Please run this test after this test is completed by entering (INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. If it still fails the test, please update the log file accordingly: {eris}test>program-analysis>inspect.report.") (SETQ MESS7 "Are you ready to start testing(y or n)? ") (SETQ PROMPT-MESS "Item being inspected: ") (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") ; Load TEDIT if not already loaded.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT) ; Check the intial value of inspector variables... (IF (AND (= IL:MAXINSPECTCDRLEVEL 50) (= IL:MAXINSPECTARRAYLEVEL 300) (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) (EQ IL:INSPECTALLFIELDSFLG T)) (SETQ VARIABLES-SET-CORRECT T) (SETQ VARIABLES-SET-CORRECT NIL)) ; Create various objects to be inspected... ; Trying to inspect random state object will hang the system (never returns) ; A number or character cannot be inspected and an appropriate message should be ; generated for these objects... (SETQ INSPECT-ITEM-NAMES '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER PACKAGE PATHNAME RATIO RATIONAL READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING STRING-CHAR SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) (IL:PROMPTPRINT MESS0) (PAUSE) (IL:ASKUSER 15 'IL:Y MESS7) (SETQ INSPECT-WINDOWS NIL) (IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO (PROGN (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) (PAUSE) (INSPECT ITEM) (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y (FORMAT T MESS1 POP-ITEM POP-ITEM))) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) T) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) NIL)) (IL:CLEARW) (SLEEP 1))) ; Inspecting the compiled code of the function... (PAUSE) (IL:PROMPTPRINT MESS5) (IL:INSPECTCODE 'COS) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS3)) (SETQ INSPECTCODE-FLG T) (SETQ INSPECTCODE-FLG NIL)) (SLEEP 2) ; Closing the inspector window... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) ; Testing to see if an object could be displayed in a specified window... (PAUSE) (SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) (IL:OPENW INSPECTORW) (INSPECT INSPECT-ARRAY NIL INSPECTORW) (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS4)) (SETQ INSPECT-WHERE-FLG T) (SETQ INSPECT-WHERE-FLG NIL)) ; Delete all inspect windows that have been created... (PAUSE) (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 0 :end1 9) (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) ) ) ; Test for AR8203 (IL:PROMPTPRINT MESS6) (PAUSE) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) ) ) (DO-TEST 'INSPECTOR-TEST-RESULT (PROGN (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES VARIABLES-SET-CORRECT) (IL:FOR X IL:IN ITEM-NAMES IL:DO (PROGN (SETQ PF-ITEM (POP ITEM-NAMES)) (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG))))) (PASS-FAIL 'INSPECTCODE INSPECTCODE-FLG) (PASS-FAIL 'INSPECT-WHERE INSPECT-WHERE-FLG) (T-FORMAT TOTAL-TEST-TIME) (IDENTITY T) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~4~ b/internal/test/env/program-analysis/hand/INSPECT.U.~4~ new file mode 100644 index 00000000..dfa09165 --- /dev/null +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~4~ @@ -0,0 +1 @@ +;; Function To Be Tested: INSPECTOR (Program Analysis) ;; ;; Source: IRM VOLUME 3 (Lyric Beta Release 2) ;; Section 26. User Input/Output Packages ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: March 21, 1987 ;; ;; Last Update: March 30, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>inspector.u ;; ;; ;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function ;; ;; Function Description: The inspector provides a display-oriented and window-based ;; facility for looking at and changing arbitrary Interlisp-D data structures. ;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. ;; The inspector displays the field names and values of an arbitrary object in ;; a window that allows setting of the properties and further inpection of the values. ;; This latter feature makes it possible to "walk" around all of the data structures ;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 ;; pages 26.1 through 26.9 ;; ;; Argument(s): The primary function for inspector is INSPECT whose arguments are ;; described here. ;; OBJECT: object to be inspected ;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be ;; used to determine its property names in the inspect window. ;; WHERE: speccifies the location of the inspect window. If NIL, the user will be ;; prompted for location ;; ;; Returns: Inspection Window ;; ;; Constraints/Limitations: The primary emphasis of this testing will be focused ;; on the function INSPECT. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>inspect.report. This test requires ;; TEDIT package. ;; ;; ;; (DO-TEST "INSPECTOR-TEST-SETUP" (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Woo! It worked!" )) (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) (SETQ INSPECTOR "INSPECTOR") (SETQ INSPECTCODE-TITLE "CODE FOR COS") ; Creating various objects to be inspected.... (SETQ INSPECT-ITEM-LIST (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (setq hash (make-hash-table 7)) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(a b c d) ; list 37e5 ; long-float (= 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname ;*random-state* ; random state - inspecting this hangs 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector IL:promptwindow ; window )) (SETF (GETHASH 'COLOR HASH) 'BROWN (GETHASH 'NAME HASH) 'FRED (GETHASH 'AGE HASH) 29 (GETHASH 'PHONE HASH) '777-6551 (GETHASH 'HEIGHT HASH) '6-FEET (GETHASH 'WEIGHT HASH) '170) (SETQ SPACE ": ") (SETQ MESS0 "In this part of test, various lisp objects will be inspected. Numbers except for complex and fraction types, and characters are not inspectable and an appropriate message will be printed. If a inspect menu pops up, select the item INSPECT To create an inspector window, simply click the left mouse button Please respond with y or n after an inspector window is created. ") (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") (SETQ MESS2 "Please indicate a position for inspecting the compiled function COS with left mouse button") (SETQ MESS3 "Is the inspector window displayed for the compiled function COS (Yes or NO?)") (SETQ MESS4 "Is the inspection information displayed in the specified inspector window?") (SETQ MESS5 "The inspector window should have been created for inspecting the compiled function COS") (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) Please run this test after this test is completed by entering (INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. If it still fails the test, please update the log file accordingly: {eris}test>program-analysis>inspect.report.") (SETQ MESS7 "Are you ready to start testing(y or n)? ") (SETQ PROMPT-MESS "Item being inspected: ") (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") ; Load TEDIT if not already loaded.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT) ; Check the intial value of inspector variables... (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES (AND (= IL:MAXINSPECTCDRLEVEL 50) (= IL:MAXINSPECTARRAYLEVEL 300) (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) (EQ IL:INSPECTALLFIELDSFLG T))) ; Create various objects to be inspected... ; Trying to inspect random state object will hang the system (never returns) ; A number or character cannot be inspected and an appropriate message should be ; generated for these objects... (SETQ INSPECT-ITEM-NAMES '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER PACKAGE PATHNAME RATIO RATIONAL READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING STRING-CHAR SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) (Y-OR-N-P MESS7) (SETQ INSPECT-WINDOWS NIL) (IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) (INSPECT ITEM) (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) (Y-OR-N-P (FORMAT T MESS1 POP-ITEM POP-ITEM))) ) (IL:FOR X IL:IN ITEM-NAMES IL:DO (SETQ PF-ITEM (POP ITEM-NAMES)) (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG)))) ; Inspecting the compiled code of the function... (IL:PROMPTPRINT MESS5) (IL:INSPECTCODE 'COS) (PASS-FAIL 'INSPECTCODE (Y-OR-N-P MESS3)) ; Closing the inspector window... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) ; Testing to see if an object could be displayed in a specified window... (SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) (IL:OPENW INSPECTORW) (INSPECT INSPECT-ARRAY NIL INSPECTORW) (PASS-FAIL 'INSPECT-WHERE (Y-OR-N-P MESS4)) ; Delete all inspect windows that have been created... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 0 :end1 9) (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) ) ) ; Test for AR8203 (IL:PROMPTPRINT MESS6) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~5~ b/internal/test/env/program-analysis/hand/INSPECT.U.~5~ new file mode 100644 index 00000000..bb3aeca3 --- /dev/null +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~5~ @@ -0,0 +1 @@ +;; Function To Be Tested: INSPECTOR (Program Analysis) ;; ;; Source: IRM VOLUME 3 (Lyric Beta Release 2) ;; Section 26. User Input/Output Packages ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: March 21, 1987 ;; ;; Last Update: March 30, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>inspector.u ;; ;; ;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function ;; ;; Function Description: The inspector provides a display-oriented and window-based ;; facility for looking at and changing arbitrary Interlisp-D data structures. ;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. ;; The inspector displays the field names and values of an arbitrary object in ;; a window that allows setting of the properties and further inpection of the values. ;; This latter feature makes it possible to "walk" around all of the data structures ;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 ;; pages 26.1 through 26.9 ;; ;; Argument(s): The primary function for inspector is INSPECT whose arguments are ;; described here. ;; OBJECT: object to be inspected ;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be ;; used to determine its property names in the inspect window. ;; WHERE: speccifies the location of the inspect window. If NIL, the user will be ;; prompted for location ;; ;; Returns: Inspection Window ;; ;; Constraints/Limitations: The primary emphasis of this testing will be focused ;; on the function INSPECT. Instructions will be given in the prompt ;; window for the user action to be taken during testing and appropriate messages ;; will be displayed to explain each test process. Test result is logged on ;; {eris}test>program-analysis>inspect.report. This test requires ;; TEDIT package. ;; ;; ;; (DO-TEST "INSPECTOR-TEST-SETUP" (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Woo! It worked!" )) (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) (SETQ INSPECTOR "INSPECTOR") (SETQ INSPECTCODE-TITLE "CODE FOR COS") ; Creating various objects to be inspected.... (SETQ INSPECT-ITEM-LIST (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array (gentemp) ; atom (1- most-negative-fixnum) ; bignum 0 ; bit '#*1001 ; bit-vector #\backspace ; character 'common ; common #'cons ; compiled-function #c( 6/7 3.00) ; complex '( a b c . d) ; cons 5.00 ; double-float (random most-positive-fixnum) ; fixnum (coerce most-negative-fixnum 'float) ; float #'(lambda nil nil) ; function (setq hash (make-hash-table 7)) ; hash-table 4761 ; integer :mot-de-clef ; keyword '(a b c d) ; list 37e5 ; long-float (= 1 2) ; null 3.1415926535897932384d0 ; number (car(list-all-packages)) ; package (pathname) ; pathname ;*random-state* ; random state - inspecting this hangs 27/60 ; ratio 5 ; rational (copy-readtable) ; readtable '(A 'B "C") ; sequence ;; Breaks; see AR 6494 (coerce 6 'short-float) ; short-float (make-array '(2 2)) ; simple-array '#*1001 ; simple-bit-vector "twine" ; simple-string (make-array 50 :initial-element 0) ; simple-vector .001 ; single-float #\* ; standard-char (make-synonym-stream) ; stream (make-array 20 :element-type 'string-char :initial-element #\0) ; string #\. ; string-char (gentemp) ; symbol (not (equal 2 3)) ; t '#( 5 4 3 2 1) ; vector IL:promptwindow ; window )) (SETF (GETHASH 'COLOR HASH) 'BROWN (GETHASH 'NAME HASH) 'FRED (GETHASH 'AGE HASH) 29 (GETHASH 'PHONE HASH) '777-6551 (GETHASH 'HEIGHT HASH) '6-FEET (GETHASH 'WEIGHT HASH) '170) (SETQ SPACE ": ") (SETQ MESS0 "In this part of test, various lisp objects will be inspected. Numbers except for complex and fraction types, and characters are not inspectable and an appropriate message will be printed. If a inspect menu pops up, select the item INSPECT To create an inspector window, simply click the left mouse button Please respond with y or n after an inspector window is created. ") (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") (SETQ MESS2 "Please indicate a position for inspecting the compiled function COS with left mouse button") (SETQ MESS3 "Is the inspector window displayed for the compiled function COS (Yes or NO?)") (SETQ MESS4 "Is the inspection information displayed in the specified inspector window?") (SETQ MESS5 "The inspector window should have been created for inspecting the compiled function COS") (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) Please run this test after this test is completed by entering (INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. If it still fails the test, please update the log file accordingly: {eris}test>program-analysis>inspect.report.") (SETQ MESS7 "Are you ready to start testing(y or n)? ") (SETQ PROMPT-MESS "Item being inspected: ") (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") ; Load TEDIT if not already loaded.... (IL:PAGEHEIGHT 0) (IL:FILESLOAD (IL:SYSLOAD) TEDIT) ; Check the intial value of inspector variables... (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES (AND (= IL:MAXINSPECTCDRLEVEL 50) (= IL:MAXINSPECTARRAYLEVEL 300) (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) (EQ IL:INSPECTALLFIELDSFLG T))) ; Create various objects to be inspected... ; Trying to inspect random state object will hang the system (never returns) ; A number or character cannot be inspected and an appropriate message should be ; generated for these objects... (SETQ INSPECT-ITEM-NAMES '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER PACKAGE PATHNAME RATIO RATIONAL READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING STRING-CHAR SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES) (Y-OR-N-P MESS7) (SETQ INSPECT-WINDOWS NIL) (IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) (INSPECT ITEM) (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) (Y-OR-N-P (FORMAT T MESS1 POP-ITEM POP-ITEM))) ) (IL:FOR X IL:IN ITEM-NAMES IL:DO (SETQ PF-ITEM (POP ITEM-NAMES)) (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG)))) ; Inspecting the compiled code of the function... (IL:PROMPTPRINT MESS5) (IL:INSPECTCODE 'COS) (PASS-FAIL 'INSPECTCODE (Y-OR-N-P MESS3)) ; Closing the inspector window... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) ; Testing to see if an object could be displayed in a specified window... (SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) (IL:OPENW INSPECTORW) (INSPECT INSPECT-ARRAY NIL INSPECTORW) (PASS-FAIL 'INSPECT-WHERE (Y-OR-N-P MESS4)) ; Delete all inspect windows that have been created... (IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) IL:DO (IL:CLOSEW WINDOW) IL:WHEN (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 0 :end1 9) (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTOR :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) ) ) ; Test for AR8203 (IL:PROMPTPRINT MESS6) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT b/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT new file mode 100644 index 00000000..8e421ea2 --- /dev/null +++ b/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT @@ -0,0 +1 @@ +TEST REPORT FOR MASTERSCOPE (PROGRAM ANALYSIS) COMMAND: MASTERSCOPE LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:05 TESTER: jpark.pasa COMMAND: MASTERSCOPE COMMAND LANGUAGE: who-calls LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:08 TESTER: jpark.pasa COMMAND: MASTERSCOPE COMMAND LANGUAGE: show-paths LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:08 TESTER: jpark.pasa COMMAND: MASTERSCOPE COMMAND LANGUAGE: erased LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:08 TESTER: jpark.pasa COMMAND: MASTERSCOPE COMMAND LANGUAGE: who-is-called-by LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:09 TESTER: jpark.pasa COMMAND: MASTERSCOPE COMMAND LANGUAGE: reanalyze LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:09 TESTER: jpark.pasa COMMAND: MASTERSCOPE COMMAND LANGUAGE: describe LISP VERSION: LYRIC of 18-Feb-87 20:00:06 STATUS: success DATE: 6-Mar-87 16:22:10 TESTER: jpark.pasa COMMAND: MASTERSCOPE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: FAIL DATE: 3-Apr-87 08:34:10 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: WHO-CALLS LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: FAIL DATE: 3-Apr-87 08:34:13 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: SHOW-PATHS LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 3-Apr-87 08:34:14 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: ERASED LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 3-Apr-87 08:34:14 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: WHO-IS-CALLED-BY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 3-Apr-87 08:34:15 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: REANALYZE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 3-Apr-87 08:34:15 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: DESCRIBE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 3-Apr-87 08:34:16 TESTER: SCHUSTER COMMAND: MASTERSCOPE LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:06 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: WHO-CALLS LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:09 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: SHOW-PATHS LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:09 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: ERASED LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:11 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: WHO-IS-CALLED-BY LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:11 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: REANALYZE LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:12 TESTER: SCHUSTER COMMAND: MASTERSCOPE COMMAND LANGUAGE: DESCRIBE LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 07:22:13 TESTER: SCHUSTER \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/SPY.REPORT b/internal/test/env/program-analysis/hand/SPY.REPORT new file mode 100644 index 00000000..ba722e9e --- /dev/null +++ b/internal/test/env/program-analysis/hand/SPY.REPORT @@ -0,0 +1 @@ +TEST REPORT FOR SPY (PROGRAM ANALYSIS) COMMAND: SPY TEST-ITEM: FUNCTION-VARIABLE-DEFINITION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:23 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-INITIAL-VALUES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:25 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: FUNCTION-VARIABLE-DEFINITION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:26 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-BUTTON-ON LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:26 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-BUTTON-OFF LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:27 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-START LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:27 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-END LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:28 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-TOGGLE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:28 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: WITH-SPY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:28 TESTER: JPARK.PASA COMMAND: SPY TEST-ITEM: SPY-TREE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 18-Mar-87 10:38:29 TESTER: JPARK.PASA TOTAL TEST RUN TIME FOR SPY: 2.46365 MINUTES COMMAND: SPY TEST-ITEM: FUNCTION-VARIABLE-DEFINITION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:08 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-INITIAL-VALUES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:13 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: FUNCTION-VARIABLE-DEFINITION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:13 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-BUTTON-ON LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:14 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-BUTTON-OFF LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:14 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-START LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:14 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-END LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:15 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-TOGGLE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:16 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: WITH-SPY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:16 TESTER: SCHUSTER COMMAND: SPY TEST-ITEM: SPY-TREE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 31-Mar-87 13:35:17 TESTER: SCHUSTER TOTAL TEST RUN TIME FOR SPY: 2.47435 MINUTES \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/SPY.U b/internal/test/env/program-analysis/hand/SPY.U new file mode 100644 index 00000000..cf710276 --- /dev/null +++ b/internal/test/env/program-analysis/hand/SPY.U @@ -0,0 +1 @@ +;; Function To Be Tested: SPY (Part I) (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 187 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 12, 1987 ;; ;; Last Update: March 18, 1987 ;; ;; Massively munged: Rene P. S. Bane on June 22, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>spy.u ;; ;; ;; Syntax: (See Spy documentation) ;; ;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: ;; a "sampler" that one runs while running his program, which monitors what the program ;; is doing, anda "displayer" that displays the data gathered by the sampler. ;; The "displayer" uses the grapher package to display the data gathered by the sampler. ;; In the graph, the height of each node is adjusted to be proportional to the amount ;; of time. Just as Masterscope and Browser give an interactive picture of the static ;; structure of the program, Spy give an interactive picture of the dynamic structure. ;; ;; Required packages: Grapher, readnumber, imageobj, and tedit ;; ;; Functions: (SPY.BUTTON) - Turns spy on and off. ;; (SPY.START) - Reinitializes the internal Spy data structure and turns on ;; Sampling. ;; (SPY.END) - Turns off sampling, and cleans up the data structure ;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, ;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). ;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls ;; (SPY.END), and another one will turn it off. ;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results ;; of the last "spy" in a grapher window. For argument description, ;; see SPY documentation. ;; (SPY.LEGEND) - This brings up a window that shows what they mean ;; (SPY.BORDER) - This brings up a window that shows the interpretation of ;; SPY.BORDERS ;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. ;; Max: 60 ;; SPY.NOMERGEFNS - Functions on this list are not merged under ;; MergeDefault ;; SPY.TREE - This holds the data from the last sampling. One can save ;; and restore it using UGLYVARS. ;; SPY.BORDERS - This controls the border display on a tree. ;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) ;; SPY.MAXLINES - Maximum height of a node in the graph, measured ;; in multiples of the font height of SPY.FONT. ;; Argument(s): (SEE Spy documentation) ;; ;; Returns: (SEE Spy documentation) ;; ;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the ;; functional tests are written in such a way that many of the top-level functions will be ;; automatically executed and test results will be recorded in the following file ;; {eris}test>program-analysis>browser.report. User interface is necessary for ;; some of the spy functions. Appropriate messages will be printed when user interface is ;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should ;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual ;; vs Cumulative mode). (DO-TEST "SPY-TEST-SETUP" (SETQ SPY-TEST-RESULTS T) ; assume test succeeds, set to nil if something fails (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ SPY-TEST-RESULTS NIL) )) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (IL:PAGEHEIGHT 0) ;Loading spy and other required package ; they are not already loaded... (PAUSE) ; This part of the test will load spy and other required packages... (IL:FILESLOAD (IL:SYSLOAD) SPY GRAPHER READNUMBER IMAGEOBJ) ; This part determines if all spy functions are defined and variables bound .... (PAUSE) (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION (AND (NOTANY #'NULL (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) (NOTANY #'NULL (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) )) ; Test to see if the SPY variables are bound to correct initial values (PASS-FAIL 'IL:SPY-INITIAL-VALUES (AND (EQ IL:SPY.FREQUENCY 10) (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) ) ) ; Test for SPY.BUTTON ; (SPY.BUTTON) will turn spy on/off ; (IL:SPY.BUTTON '(90 . 5)) (IL:CURSORPOSITION '(134 . -145)) (PASS-FAIL "SPY.BUTTON gets you a Spy Eye" (Y-OR-N-P "Did a Spy Eye just appear? ")) ; Clicking the left mouse button will turn it on... (XCL-TEST::PAUSE) (APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) (PASS-FAIL 'IL:SPY-BUTTON-ON (Y-OR-N-P "Did the Spy Eye open? ")) ; Clicking it again will turn off the spy and display the results.... (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) (PASS-FAIL 'IL:SPY-BUTTON-OFF (Y-OR-N-P "Did the Spy Eye close? ")) (IL:SPY.END) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLRPROMPT) ; This part of the test is for (SPY.START) and (SPY.END) ; (SPY.START) will turns on the sampling (XCL-TEST::PAUSE) (IL:SPY.START) ; Now SPY should be turned back on. (PASS-FAIL 'IL:SPY-START (Y-OR-N-P "Did the Spy Eye open? ")) ; (SPY.END) will turn off sampling. (XCL-TEST::PAUSE) (IL:SPY.END) ; Now SPY should be turned off. (PASS-FAIL 'IL:SPY-END (Y-OR-N-P "Did the Spy Eye close? ")) ; The following will test (SPY.TOGGLE) ; If SPY is off, it will turn it on; otherwise, it will turn it off ; with (SPY.END) and show the results. (XCL-TEST::PAUSE) (IL:SPY.TOGGLE) (PASS-FAIL 'IL:SPY-TOGGLE-ON (Y-OR-N-P "Did the Spy Eye open? ")) ; Invoking (SPY.TOGGLE) again will turn spy off and display the results... (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TOGGLE) (PASS-FAIL 'IL:SPY-TOGGLE-OFF (Y-OR-N-P "Did the Spy Eye close? ")) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLRPROMPT) ; The following will test (WITH.SPY form) ; This will evaluate the form with spy on (XCL-TEST::PAUSE) (PASS-FAIL 'IL:WITH-SPY (EQUAL (IL:WITH.SPY (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X))) (PROGN (IL:SPY.START) (PROG1 (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X)) (IL:SPY.END))))) ; This following will test SPY.TREE, which display the results in a grapher window. ; (SPY.TREE 10) will display the last spy with threshold set to 10 (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10) (SETQ IL:SPY-TREE1 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLOSEW IL:SPY.WINDOW) ; (SPY.TREE 10 T) Should display the spy graph in different format (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10 T) (SETQ IL:SPY-TREE2 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLOSEW IL:SPY.WINDOW) ; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10 T 'IL:ALL 2) (SETQ IL:SPY-TREE3 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLRPROMPT) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLOSEW IL:SPY.BUTTON) SPY-TEST-RESULTS ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/SPY.U.~1~ b/internal/test/env/program-analysis/hand/SPY.U.~1~ new file mode 100644 index 00000000..c7d896fc --- /dev/null +++ b/internal/test/env/program-analysis/hand/SPY.U.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: SPY (Part I) (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 187 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 12, 1987 ;; ;; Last Update: March 18, 1987 ;; ;; Filed As: {ERIS}test>program-analysis>spy.u ;; ;; ;; Syntax: (See Spy documentation) ;; ;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: ;; a "sampler" that one runs while running his program, which monitors what the program ;; is doing, anda "displayer" that displays the data gathered by the sampler. ;; The "displayer" uses the grapher package to display the data gathered by the sampler. ;; In the graph, the height of each node is adjusted to be proportional to the amount ;; of time. Just as Masterscope and Browser give an interactive picture of the static ;; structure of the program, Spy give an interactive picture of the dynamic structure. ;; ;; Required packages: Grapher, readnumber, imageobj, and tedit ;; ;; Functions: (SPY.BUTTON) - Turns spy on and off. ;; (SPY.START) - Reinitializes the internal Spy data structure and turns on ;; Sampling. ;; (SPY.END) - Turns off sampling, and cleans up the data structure ;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, ;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). ;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls ;; (SPY.END), and another one will turn it off. ;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results ;; of the last "spy" in a grapher window. For argument description, ;; see SPY documentation. ;; (SPY.LEGEND) - This brings up a window that shows what they mean ;; (SPY.BORDER) - This brings up a window that shows the interpretation of ;; SPY.BORDERS ;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. ;; Max: 60 ;; SPY.NOMERGEFNS - Functions on this list are not merged under ;; MergeDefault ;; SPY.TREE - This holds the data from the last sampling. One can save ;; and restore it using UGLYVARS. ;; SPY.BORDERS - This controls the border display on a tree. ;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) ;; SPY.MAXLINES - Maximum height of a node in the graph, measured ;; in multiples of the font height of SPY.FONT. ;; Argument(s): (SEE Spy documentation) ;; ;; Returns: (SEE Spy documentation) ;; ;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the ;; functional tests are written in such a way that many of the top-level functions will be ;; automatically executed and test results will be recorded in the following file ;; {eris}test>program-analysis>browser.report. User interface is necessary for ;; some of the spy functions. Appropriate messages will be printed when user interface is ;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should ;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual ;; vs Cumulative mode). (DO-TEST "SPY-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>SPY.REPORT") (DEFUN S-FORMAT (TIME) (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR SPY: ~F MINUTES ~%" TIME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: SPY TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: SPY TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (SETQ SPY-COMMAND-STRING "(IL:PAGEHEIGHT 0) ;Loading spy and other required package ; they are not already loaded... (PAUSE) ; This part of the test will load spy and other required packages... (IF (AND (MEMBER 'IL:SPY IL:FILELST) (MEMBER 'IL:GRAPHER IL:FILELST) (MEMBER 'IL:READNUMBER IL:FILELST) (MEMBER 'IL:IMAGEOBJ IL:FILELST)) (PROGN (IL:PROMPTPRINT '(SPY and other necessary files are already loaded)) (SLEEP 2) (IL:CLRPROMPT)) (PROGN (IL:LOAD? '{ERINYES}LIBRARY>SPY.LCOM 'IL:SYSLOAD) (IL:LOAD? '{ERINYES}LIBRARY>GRAPHER.LCOM 'IL:SYSLOAD) (IL:LOAD? '{ERINYES}LIBRARY>READNUMBER.LCOM 'IL:SYSLOAD) (IL:LOAD? '{ERINYES}LIBRARY>IMAGEOBJ.LCOM 'IL:SYSLOAD))) ; This part determines if all spy functions are defined and variables bound .... (PAUSE) (IF (AND (NOTANY #'NULL (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) (NOTANY #'NULL (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) ) (SETQ IL:FUNCTIONS-VARIABLES-FLG T) (SETQ IL:FUNCTIONS-VARIABLES-FLG NIL)) ; Test to see if the SPY variables are bound to correct initial values (IF (AND (EQ IL:SPY.FREQUENCY 10) (PROGN (SETQ NOMERGEFNS-FLG NIL) (DOLIST (Y '(IL:ERRORSET IL:\\\\EVAL IL:\\\\EVALFORM IL:APPLY IL:EVAL)) (IF (MEMBER Y IL:SPY.NOMERGEFNS) (PUSH T NOMERGEFNS-FLG) (PUSH NIL NOMERGEFNS-FLG))) (NOTANY #'NULL NOMERGEFNS-FLG)) (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) ) (SETQ IL:SPY-INITIAL-FLG T) (SETQ IL:SPY-INITIAL-FLG NIL) ) ; Test for SPY.BUTTON ; (SPY.BUTTON) will turn spy on/off ; (CL:IN-PACKAGE 'INTERLISP) (SPY.BUTTON '(90 . 5)) (CURSORPOSITION '(134 . -145)) ; Clicking the left mouse button will turn it on... (XCL-TEST::PAUSE) (APPLY (WINDOWPROP SPY.BUTTON 'BUTTONEVENTFN)) (IF (EQ \\\\PERIODIC.INTERRUPT '\\\\SPY.INTERRUPT) then (SETQ SPY-BUTTON-ON T) else (SETQ SPY-BUTTON-ON NIL)) ; Clicking it again will turn off the spy and display the results.... (XCL-TEST::PAUSE) (PROMPTPRINT '(please indicate the spy.window position with left mouse button)) (APPLY (WINDOWPROP SPY.BUTTON 'BUTTONEVENTFN)) (CLOSEW SPY.BUTTON) (IF (EQ \\\\PERIODIC.INTERRUPT NIL) then (SETQ SPY-BUTTON-OFF T) else (SETQ SPY-BUTTON-OFF NIL)) (SPY.END) (CLOSEW SPY.WINDOW) (CLRPROMPT) ; This part of the test is for (SPY.START) and (SPY.END) ; (SPY.START) will turns on the sampling (XCL-TEST::PAUSE) (SPY.START) ; Now SPY should be turned back on. (If (EQUAL \\\\PERIODIC.INTERRUPT '\\\\SPY.INTERRUPT) then (SETQ SPY-START T) else (SETQ SPY-START NIL)) ; (SPY.END) will turn off sampling. (XCL-TEST::PAUSE) (SPY.END) ; Now SPY should be turned off. (If (EQ \\\\PERIODIC.INTERRUPT NIL) then (SETQ SPY-END T) else (SETQ SPY-END NIL)) ; The following will test (SPY.TOGGLE) ; If SPY is off, it will turn it on; otherwise, it will turn it off ; with (SPY.END) and show the results. (XCL-TEST::PAUSE) (SETQ \\\\PERIODIC.INTERRUPT NIL) (SPY.BUTTON '(100 . 100)) (SPY.TOGGLE) (If (EQ \\\\PERIODIC.INTERRUPT '\\\\SPY.INTERRUPT) then (SETQ SPY-TOGGLE-ON T) else (SETQ SPY-TOGGLE-ON NIL)) ; Invoking (SPY.TOGGLE) again will turn spy off and display the results... (XCL-TEST::PAUSE) (PROMPTPRINT '(please indicate the spy.window position with left mouse button)) (SPY.TOGGLE) (If (EQ \\\\PERIODIC.INTERRUPT NIL) then (SETQ SPY-TOGGLE-OFF T) else (SETQ SPY-TOGGLE-OFF NIL)) (CLOSEW SPY.BUTTON) (CLOSEW SPY.WINDOW) (CLRPROMPT) ; The following will test (WITH.SPY form) ; This will evaluate the form with spy on (XCL-TEST::PAUSE) (WITH.SPY (FOR X FROM 1 TO 10 COLLECT (ADD1 X))) (SETQ WITH-SPY-VAL IT) (IF (EQUAL WITH-SPY-VAL (PROGN (SPY.START) (PROG1 (FOR X FROM 1 TO 10 COLLECT (ADD1 X)) (SPY.END)))) then (SETQ WITH-SPY T) else (SETQ WITH-SPY NIL)) ; This following will test SPY.TREE, which display the results in a grapher window. ; (SPY.TREE 10) will display the last spy with threshold set to 10 (XCL-TEST::PAUSE) (PROMPTPRINT '(please indicate the spy.window position with left mouse button)) (SPY.TREE 10) (IF (EQ (NOT (MEMBER SPY.WINDOW (OPENWINDOWS))) NIL) THEN (SETQ SPY-TREE1 T) ELSE (SETQ SPY-TREE1 NIL)) (CLOSEW SPY.WINDOW) ; (SPY.TREE 10 T) Should display the spy graph in different format (XCL-TEST::PAUSE) (PROMPTPRINT '(please indicate the spy.window position with left mouse button)) (SPY.TREE 10 T) (IF (EQ (NOT (MEMBER SPY.WINDOW (OPENWINDOWS))) NIL) THEN (SETQ SPY-TREE2 T) ELSE (SETQ SPY-TREE2 NIL)) (CLOSEW SPY.WINDOW) ; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 (XCL-TEST::PAUSE) (PROMPTPRINT '(please indicate the spy.window position with left mouse button)) (SPY.TREE 10 T 'ALL 2) (IF (EQ (NOT (MEMBER SPY.WINDOW (OPENWINDOWS))) NIL) THEN (SETQ SPY-TREE3 T) ELSE (SETQ SPY-TREE3 NIL)) (CLRPROMPT) (CLOSEW SPY.WINDOW) (CL:IN-PACKAGE 'XCL-TEST) ; Now do-test will analyze the results of testing (DO-TEST 'SPY-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION IL:FUNCTIONS-VARIABLES-FLG) (PASS-FAIL 'IL:SPY-INITIAL-VALUES IL:SPY-INITIAL-FLG) (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION IL:FUNCTIONS-VARIABLES-FLG) (PASS-FAIL 'IL:SPY-BUTTON-ON IL:SPY-BUTTON-ON) (PASS-FAIL 'IL:SPY-BUTTON-OFF IL:SPY-BUTTON-OFF) (PASS-FAIL 'IL:SPY-START IL:SPY-START) (PASS-FAIL 'IL:SPY-END IL:SPY-END) (PASS-FAIL 'IL:SPY-TOGGLE (AND IL:SPY-TOGGLE-ON IL:SPY-TOGGLE-OFF)) (PASS-FAIL 'IL:WITH-SPY IL:WITH-SPY) (PASS-FAIL 'IL:SPY-TREE (AND IL:SPY-TREE1 IL:SPY-TREE2 IL:SPY-TREE3)) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) (S-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) (IDENTITY T) ) ) ") (IL:BKSYSBUF SPY-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/SPY.U.~2~ b/internal/test/env/program-analysis/hand/SPY.U.~2~ new file mode 100644 index 00000000..e7d05e18 --- /dev/null +++ b/internal/test/env/program-analysis/hand/SPY.U.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: SPY (Part I) (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 187 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 12, 1987 ;; ;; Last Update: March 18, 1987 ;; ;; Massively munged: Rene P. S. Bane on June 22, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>spy.u ;; ;; ;; Syntax: (See Spy documentation) ;; ;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: ;; a "sampler" that one runs while running his program, which monitors what the program ;; is doing, anda "displayer" that displays the data gathered by the sampler. ;; The "displayer" uses the grapher package to display the data gathered by the sampler. ;; In the graph, the height of each node is adjusted to be proportional to the amount ;; of time. Just as Masterscope and Browser give an interactive picture of the static ;; structure of the program, Spy give an interactive picture of the dynamic structure. ;; ;; Required packages: Grapher, readnumber, imageobj, and tedit ;; ;; Functions: (SPY.BUTTON) - Turns spy on and off. ;; (SPY.START) - Reinitializes the internal Spy data structure and turns on ;; Sampling. ;; (SPY.END) - Turns off sampling, and cleans up the data structure ;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, ;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). ;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls ;; (SPY.END), and another one will turn it off. ;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results ;; of the last "spy" in a grapher window. For argument description, ;; see SPY documentation. ;; (SPY.LEGEND) - This brings up a window that shows what they mean ;; (SPY.BORDER) - This brings up a window that shows the interpretation of ;; SPY.BORDERS ;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. ;; Max: 60 ;; SPY.NOMERGEFNS - Functions on this list are not merged under ;; MergeDefault ;; SPY.TREE - This holds the data from the last sampling. One can save ;; and restore it using UGLYVARS. ;; SPY.BORDERS - This controls the border display on a tree. ;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) ;; SPY.MAXLINES - Maximum height of a node in the graph, measured ;; in multiples of the font height of SPY.FONT. ;; Argument(s): (SEE Spy documentation) ;; ;; Returns: (SEE Spy documentation) ;; ;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the ;; functional tests are written in such a way that many of the top-level functions will be ;; automatically executed and test results will be recorded in the following file ;; {eris}test>program-analysis>browser.report. User interface is necessary for ;; some of the spy functions. Appropriate messages will be printed when user interface is ;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should ;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual ;; vs Cumulative mode). (DO-TEST "SPY-TEST-SETUP" (SETQ SPY-TEST-RESULTS T) ; assume test succeeds, set to nil if something fails (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ SPY-TEST-RESULTS NIL) )) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (IL:PAGEHEIGHT 0) ;Loading spy and other required package ; they are not already loaded... (PAUSE) ; This part of the test will load spy and other required packages... (IL:FILESLOAD (IL:SYSLOAD) SPY GRAPHER READNUMBER IMAGEOBJ) ; This part determines if all spy functions are defined and variables bound .... (PAUSE) (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION (AND (NOTANY #'NULL (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) (NOTANY #'NULL (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) )) ; Test to see if the SPY variables are bound to correct initial values (PASS-FAIL 'IL:SPY-INITIAL-VALUES (AND (EQ IL:SPY.FREQUENCY 10) (PROGN (SETQ NOMERGEFNS-FLG NIL) (DOLIST (Y '(IL:ERRORSET IL:\\\\EVAL IL:\\\\EVALFORM IL:APPLY IL:EVAL)) (IF (MEMBER Y IL:SPY.NOMERGEFNS) (PUSH T NOMERGEFNS-FLG) (PUSH NIL NOMERGEFNS-FLG))) (NOTANY #'NULL NOMERGEFNS-FLG)) (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) ) ) ; Test for SPY.BUTTON ; (SPY.BUTTON) will turn spy on/off ; (IL:SPY.BUTTON '(90 . 5)) (IL:CURSORPOSITION '(134 . -145)) (PASS-FAIL "SPY.BUTTON gets you a Spy Eye" (Y-OR-N-P "Did a Spy Eye just appear? ")) ; Clicking the left mouse button will turn it on... (XCL-TEST::PAUSE) (APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) (PASS-FAIL 'IL:SPY-BUTTON-ON (Y-OR-N-P "Did the Spy Eye open? ")) ; Clicking it again will turn off the spy and display the results.... (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) (PASS-FAIL 'IL:SPY-BUTTON-OFF (Y-OR-N-P "Did the Spy Eye close? ")) (IL:SPY.END) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLRPROMPT) ; This part of the test is for (SPY.START) and (SPY.END) ; (SPY.START) will turns on the sampling (XCL-TEST::PAUSE) (IL:SPY.START) ; Now SPY should be turned back on. (PASS-FAIL 'IL:SPY-START (Y-OR-N-P "Did the Spy Eye open? ")) ; (SPY.END) will turn off sampling. (XCL-TEST::PAUSE) (IL:SPY.END) ; Now SPY should be turned off. (PASS-FAIL 'IL:SPY-END (Y-OR-N-P "Did the Spy Eye close? ")) ; The following will test (SPY.TOGGLE) ; If SPY is off, it will turn it on; otherwise, it will turn it off ; with (SPY.END) and show the results. (XCL-TEST::PAUSE) (IL:SPY.TOGGLE) (PASS-FAIL 'IL:SPY-TOGGLE-ON (Y-OR-N-P "Did the Spy Eye open? ")) ; Invoking (SPY.TOGGLE) again will turn spy off and display the results... (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TOGGLE) (PASS-FAIL 'IL:SPY-TOGGLE-OFF (Y-OR-N-P "Did the Spy Eye close? ")) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLRPROMPT) ; The following will test (WITH.SPY form) ; This will evaluate the form with spy on (XCL-TEST::PAUSE) (IL:WITH.SPY (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X))) (SETQ IL:WITH-SPY-VAL IL:IT) (PASS-FAIL 'IL:WITH-SPY (EQUAL IL:WITH-SPY-VAL (PROGN (IL:SPY.START) (PROG1 (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X)) (IL:SPY.END))))) ; This following will test SPY.TREE, which display the results in a grapher window. ; (SPY.TREE 10) will display the last spy with threshold set to 10 (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10) (SETQ IL:SPY-TREE1 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLOSEW IL:SPY.WINDOW) ; (SPY.TREE 10 T) Should display the spy graph in different format (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10 T) (SETQ IL:SPY-TREE2 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLOSEW IL:SPY.WINDOW) ; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10 T 'IL:ALL 2) (SETQ IL:SPY-TREE3 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLRPROMPT) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLOSEW IL:SPY.BUTTON) SPY-TEST-RESULTS ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/SPY.U.~3~ b/internal/test/env/program-analysis/hand/SPY.U.~3~ new file mode 100644 index 00000000..cf710276 --- /dev/null +++ b/internal/test/env/program-analysis/hand/SPY.U.~3~ @@ -0,0 +1 @@ +;; Function To Be Tested: SPY (Part I) (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 187 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 12, 1987 ;; ;; Last Update: March 18, 1987 ;; ;; Massively munged: Rene P. S. Bane on June 22, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>spy.u ;; ;; ;; Syntax: (See Spy documentation) ;; ;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: ;; a "sampler" that one runs while running his program, which monitors what the program ;; is doing, anda "displayer" that displays the data gathered by the sampler. ;; The "displayer" uses the grapher package to display the data gathered by the sampler. ;; In the graph, the height of each node is adjusted to be proportional to the amount ;; of time. Just as Masterscope and Browser give an interactive picture of the static ;; structure of the program, Spy give an interactive picture of the dynamic structure. ;; ;; Required packages: Grapher, readnumber, imageobj, and tedit ;; ;; Functions: (SPY.BUTTON) - Turns spy on and off. ;; (SPY.START) - Reinitializes the internal Spy data structure and turns on ;; Sampling. ;; (SPY.END) - Turns off sampling, and cleans up the data structure ;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, ;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). ;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls ;; (SPY.END), and another one will turn it off. ;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results ;; of the last "spy" in a grapher window. For argument description, ;; see SPY documentation. ;; (SPY.LEGEND) - This brings up a window that shows what they mean ;; (SPY.BORDER) - This brings up a window that shows the interpretation of ;; SPY.BORDERS ;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. ;; Max: 60 ;; SPY.NOMERGEFNS - Functions on this list are not merged under ;; MergeDefault ;; SPY.TREE - This holds the data from the last sampling. One can save ;; and restore it using UGLYVARS. ;; SPY.BORDERS - This controls the border display on a tree. ;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) ;; SPY.MAXLINES - Maximum height of a node in the graph, measured ;; in multiples of the font height of SPY.FONT. ;; Argument(s): (SEE Spy documentation) ;; ;; Returns: (SEE Spy documentation) ;; ;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the ;; functional tests are written in such a way that many of the top-level functions will be ;; automatically executed and test results will be recorded in the following file ;; {eris}test>program-analysis>browser.report. User interface is necessary for ;; some of the spy functions. Appropriate messages will be printed when user interface is ;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should ;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual ;; vs Cumulative mode). (DO-TEST "SPY-TEST-SETUP" (SETQ SPY-TEST-RESULTS T) ; assume test succeeds, set to nil if something fails (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ SPY-TEST-RESULTS NIL) )) (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (IL:PAGEHEIGHT 0) ;Loading spy and other required package ; they are not already loaded... (PAUSE) ; This part of the test will load spy and other required packages... (IL:FILESLOAD (IL:SYSLOAD) SPY GRAPHER READNUMBER IMAGEOBJ) ; This part determines if all spy functions are defined and variables bound .... (PAUSE) (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION (AND (NOTANY #'NULL (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) (NOTANY #'NULL (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) )) ; Test to see if the SPY variables are bound to correct initial values (PASS-FAIL 'IL:SPY-INITIAL-VALUES (AND (EQ IL:SPY.FREQUENCY 10) (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) ) ) ; Test for SPY.BUTTON ; (SPY.BUTTON) will turn spy on/off ; (IL:SPY.BUTTON '(90 . 5)) (IL:CURSORPOSITION '(134 . -145)) (PASS-FAIL "SPY.BUTTON gets you a Spy Eye" (Y-OR-N-P "Did a Spy Eye just appear? ")) ; Clicking the left mouse button will turn it on... (XCL-TEST::PAUSE) (APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) (PASS-FAIL 'IL:SPY-BUTTON-ON (Y-OR-N-P "Did the Spy Eye open? ")) ; Clicking it again will turn off the spy and display the results.... (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) (PASS-FAIL 'IL:SPY-BUTTON-OFF (Y-OR-N-P "Did the Spy Eye close? ")) (IL:SPY.END) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLRPROMPT) ; This part of the test is for (SPY.START) and (SPY.END) ; (SPY.START) will turns on the sampling (XCL-TEST::PAUSE) (IL:SPY.START) ; Now SPY should be turned back on. (PASS-FAIL 'IL:SPY-START (Y-OR-N-P "Did the Spy Eye open? ")) ; (SPY.END) will turn off sampling. (XCL-TEST::PAUSE) (IL:SPY.END) ; Now SPY should be turned off. (PASS-FAIL 'IL:SPY-END (Y-OR-N-P "Did the Spy Eye close? ")) ; The following will test (SPY.TOGGLE) ; If SPY is off, it will turn it on; otherwise, it will turn it off ; with (SPY.END) and show the results. (XCL-TEST::PAUSE) (IL:SPY.TOGGLE) (PASS-FAIL 'IL:SPY-TOGGLE-ON (Y-OR-N-P "Did the Spy Eye open? ")) ; Invoking (SPY.TOGGLE) again will turn spy off and display the results... (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TOGGLE) (PASS-FAIL 'IL:SPY-TOGGLE-OFF (Y-OR-N-P "Did the Spy Eye close? ")) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLRPROMPT) ; The following will test (WITH.SPY form) ; This will evaluate the form with spy on (XCL-TEST::PAUSE) (PASS-FAIL 'IL:WITH-SPY (EQUAL (IL:WITH.SPY (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X))) (PROGN (IL:SPY.START) (PROG1 (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X)) (IL:SPY.END))))) ; This following will test SPY.TREE, which display the results in a grapher window. ; (SPY.TREE 10) will display the last spy with threshold set to 10 (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10) (SETQ IL:SPY-TREE1 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLOSEW IL:SPY.WINDOW) ; (SPY.TREE 10 T) Should display the spy graph in different format (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10 T) (SETQ IL:SPY-TREE2 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLOSEW IL:SPY.WINDOW) ; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 (XCL-TEST::PAUSE) (IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") (IL:SPY.TREE 10 T 'IL:ALL 2) (SETQ IL:SPY-TREE3 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) (IL:CLRPROMPT) (IL:CLOSEW IL:SPY.WINDOW) (IL:CLOSEW IL:SPY.BUTTON) SPY-TEST-RESULTS ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/browser-part1.u b/internal/test/env/program-analysis/hand/browser-part1.u new file mode 100644 index 0000000000000000000000000000000000000000..09efd41e28ea9b976338f2ed9320ba8b659959f9 GIT binary patch literal 5488 zcmb7ITW=ak7Ivh4!O}jiw2w!OR)&$AF=Q_pdz4iJZJQCd(2X)#?MnfLX{G66`Vz*I z$^5YSb^D!D-GH$ZXInOISDnjO=U!Z0(RCirv(Us87;0+@beieKCABA`x4t)_+E^tS z_3C&@%w3|^5`6>LXy=`YVRak0Wh`iFNx?!vx*@n zd0$|YT|QhFM3+F5%vaRBIH%_Kul`lg^i`VCbh8i&Drs5|XneEQ+m*@yext$!2CDp+ z$3Xi}A$!G`2YGx4AZwH8%ZlA@{oQWU>>iw;A2-NvP+P^iP<|ao;Biw1kLRN|>G_|2 z$l!$6I{xr_V{PuJ!sf46Dqg&vS&KOvxTe|2ttf`z-^ZEyrI1xCT^M{f?Db1~?cCkf z={yNH?E1a8*JcqeL-;LQY4UGJZ)xlXw?56ydJWBFmaq>3BuVFHqbW5YgjHBKa};D} zDVaRmx@A zfGXM0w0t-mJBkk}1~9bHFwHuIqXA)kU?`B}v05(exwk7Fi{8>h*p5v`I#x3d2b`G& z)_VQRl7cX&sRhuy$ypn(ujKZqmZcg$6=RZ1c7P5#XNaEKg#NU!WcMHe6(jcRL1_ zPE;6Y>398b9cCf`)K{OgBo6ciE3(XELq224V=J-<@nWkm;h~>w{Lcj?o2xKC%oVI) zSp0~`Iq?V;V!H|vnk*4JX@<;SAhzhEPQvul4-q1NjOv^Ble~=BRA)?#@Nkfie4q?O3R|Ar(&-xjKW`m4Ci6WNM(pp9LX2v zqWlsEOG0Y(8@`;OLpjB!YMG4A4Ces9d^3YKcL3 z7k)rSajjqs(1h9}K=XuU7P1>~B7}0vO4Z1%VG!JoEHV@}kN{=p?d(Xi_vwAQ%$E(8 z+CecyzM#k@wAN{gwuPL7XJAj0Y)m4j--g)=u^`2(ET2nM`!Z?-g7q&8g>!Ov6JXhy zWlt8pGw3Cci=eBPE;AtQgIKf7AYbSg`sdUW&qa@youi#jlFXUylyWz zFB9vW{m)X%0Nbefd$uRmcv&2lpukzD=P+_nvP%=C2oyG(bV!bJb_5Fk(nJyFic2e~ zf(HQ2#<@WQrKds}8z;NB`dwzf9c4Zjx-^qLZFr&*%E;E=JMPpHw-U?@D;<=?V>*LP3V~Jy?nRHc ztgbqrhzFz)!5S*=!P4!zddU;wzJOumK_4g!SObsP{-A8aZr;T8JxDAfEEtVZ%BI7h zHyYY;O8IdV0SF(2-iCMf3qZYTf4WH$6W0ruJ(?rz2j;>;&Pk9woeMH zu_db#e-Dtoe2ThlWmp#of2UdBK|eZN`!k~3Pm1nX(EQtPi-I?7f4+beExV zlq=#xgIblOPkYK8y8UTUnctl|&{J?`3oGBCX<4f9?uNIH)6%fQ7sYrJoxQ^~< zk8T!^79ipX@d8b+07?iSv?yEPq(#mZUt>d|zOz4_r zU=l4FDECWDsg$l@pN+~^xR|U=9xZl)_)vB_;y`DTawIJXBV*oE6u#GJNXb`NrW_J48_nGr4_ae^$`V9@5pilU}>s_vq|n2X~84a!q{7>j&5TV1)UF%UP4I zC!@imd@4k8kJ#s}9FE6T`Cejf@O=m_`{Kw$yUK{qp1_n)+nWlAq<0BCs$pOqQuP3F zm7}oM_X4zR@29}&_l924#^2teRTj;H+j-4~>n=iN^;V%zk)I`1#Yx zi<5t!G`UT=(>^Z6!+@IToNnjV#SFs@Q(j-;4Huk24~3sz)$1pJ7Iyjg%U}7=i<1+) Jy!iEx{{e}(MLGZg literal 0 HcmV?d00001 diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~1~ b/internal/test/env/program-analysis/hand/browser-part1.u.~1~ new file mode 100644 index 00000000..e3a506e0 --- /dev/null +++ b/internal/test/env/program-analysis/hand/browser-part1.u.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER (Part I) (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 12, 1987 ;; ;; Filed As: {ERIS}test>program-analysis>browser-part1.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: ; Part 1 of this test is to determine if masterscope is ;; unaffected when the BROWSER is not enabled or (IL:BROWSER NIL) ;; Part 2 tests masterscope modification by BROWSER. This is test part 2, which ;; is stored in {eris}test>program-analysis>browser-part2.u ;; Part 1 test must be run first before Part 2 test since the former loads functions ;; utilized by the latter. Since Browser calls LAYOUTFOREST module of GRAPHER to ;; display the graph at a user-designated location, user interface is required and ;; testing will not be totally automatic. Instructions will be given for user input ;; during testing. The test will utilize do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within each command file, which will be run ;; by using the function bksysbuf. Each test setup is titled "BROWSER-TEST-SETUP", ;; which executes the command string. The do-test form within the command file will ;; return T or "testfailed" This test file requires MASTERSCOPE, TEDIT, BROWSER, and ;; GRAPHER packages ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>browser.report (DO-TEST "BROWSER-TEST-SETUP" (PROGN (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>BROWSER.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" (LISP-IMPLEMENTATION-VERSION) STATUS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: BROWSER TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: BROWSER TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (SETQ {CORE}PATHS "{CORE}PATHS") (DEFUN PAUSE NIL (PROGN (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) (SLEEP 2))) (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (SETQ BROWSER-COMMAND-STRING ";Loading browser will automatically load grapher package. ; This part of the test determines if grapher is loaded. (PAUSE) (IL:PAGEHEIGHT 0) (DELETE 'IL:GRAPHER IL:SYSFILES) (IL:LOAD? '{ERINYES}LIBRARY>MASTERSCOPE.LCOM 'IL:SYSLOAD) (IL:LOAD '{ERINYES}LIBRARY>BROWSER.LCOM 'IL:SYSLOAD) (IF (OR (MEMBER 'IL:GRAPHER IL:SYSFILES) (MEMBER 'IL:GRAPHER IL:FILELST)) (SETQ GRAPHER-LDFLG T) (PROGN (SETQ GRAPHER-LDFLG NIL) (IL:LOAD '{ERINYES}LIBRARY>GRAPHER.LCOM 'IL:SYSLOAD))) ; This part of test determines if the variables BROWSERFORMAT and BROWSERBOXING ; are bound. (PAUSE) (IF (AND (BOUNDP 'IL:BROWSERFORMAT) (BOUNDP 'IL:BROWSERBOXING)) (SETQ BROWSER-VARIABLES T) (SETQ BROWSER-VARIABLES NIL)) ; Reinitialize and Define functions to be analyzed.... (PAUSE) . ERASE (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) ; Start analyzing functions in gtop-function and others... (PAUSE) . ANALYZE TOP-GFUNTION . ANALYZE GFUN-A . ANALYZE GFUN-B . ANALYZE GFUN-A1 . ANALYZE GFUN-A2 . ANALYZE GFUN-A3 . ANALYZE GFUN-B1 . ANALYZE GFUN-B2 . ANALYZE GFUN-B3 . ANALYZE GFUN-C1 ; Browser is now loaded and activated (PAUSE) ; Part 1 of this test is to determine if masterscope is unaffected when ; the BROWSER is not enabled or (IL:BROWSER NIL) (IL:BROWSER NIL) ; Browser is now deactivated ... (PAUSE) ; This will cause masterscope to diaplay graphs in a teletype mode ; or in the exec. ; show paths should display the following path, which should look like; ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion (PAUSE) (DRIBBLE '{CORE}PATHS) . SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION (DRIBBLE) ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN {CORE}PATHS)) (DO (( i 0 (1+ i))) ((= i 5) t) (READ-LINE PATHS)) (IF (AND (STRING-EQUAL (READ-LINE PATHS) '|1.gfun-a1 gfun-a top-gfuntion|) (STRING-EQUAL (READ-LINE PATHS) '|2. gfun-b1 gfun-b top-gfuntion|)) (SETQ BROWSER-DISABLED-FLG T)(SETQ BROWSER-DISABLED-FLG NIL)) (CLOSE PATHS) (DELETE-FILE '{CORE}PATHS) (DO-TEST 'BROWSER-TEST-RESULT (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (PASS-FAIL 'BROWSER-VARIABLES-BOUND? BROWSER-VARIABLES) (PASS-FAIL 'GRAGPER-LOADED? GRAPHER-LDFLG) (PASS-FAIL 'BROWSER-DISABLED BROWSER-DISABLED-FLG) (CLOSE *OUTPUT*) (IDENTITY T) ) ) ") (IL:BKSYSBUF BROWSER-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~2~ b/internal/test/env/program-analysis/hand/browser-part1.u.~2~ new file mode 100644 index 00000000..dc2a2d40 --- /dev/null +++ b/internal/test/env/program-analysis/hand/browser-part1.u.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: BROWSER (Part I) (Program Analysis) ;; ;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) ;; Browser, Page 11 ;; Section: Program Analysis (Library) ;; ;; Created By: John Park ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: March 12, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; Munged more: June 24, 1988 by Rene P. S. Bane ;; ;; Filed As: {ERIS}env>program-analysis>hand>browser-part1.u ;; ;; ;; Syntax: (BROWSER T/NIL) ;; ;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that ;; the command's output is displayed as an undirected graph. It creates a new window ;; for each SHOW PATHS command, but will reuse a window if that window has an earlier ;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is ;; to determine if masterscope is unaffected when the BROWSER is not enabled or ;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded ;; by browser. ;; ;; Argument(s): T or NIL (SEE Browser documentation) ;; ;; Returns: IL:MSPATHS ;; ;; Constraints/Limitations: ; Part 1 of this test is to determine if masterscope is ;; unaffected when the BROWSER is not enabled or (IL:BROWSER NIL) ;; Part 2 tests masterscope modification by BROWSER. This is test part 2, which ;; is stored in {eris}test>program-analysis>browser-part2.u ;; Part 1 test must be run first before Part 2 test since the former loads functions ;; utilized by the latter. Since Browser calls LAYOUTFOREST module of GRAPHER to ;; display the graph at a user-designated location, user interface is required and ;; testing will not be totally automatic. Instructions will be given for user input ;; during testing. The test will utilize do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within each command file, which will be run ;; by using the function bksysbuf. Each test setup is titled "BROWSER-TEST-SETUP", ;; which executes the command string. The do-test form within the command file will ;; return T or "testfailed" This test file requires MASTERSCOPE, TEDIT, BROWSER, and ;; GRAPHER packages ;; ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-GFuntion ;; | ;; GFun-A------------------------GFun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 ;; | ;; -------------- ;; | | ;; GFun-C1 GFun-A1 ;; ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>browser.report (DO-TEST "BROWSER-TEST-SETUP" (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Pair-fect-o" ) ) (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) (IL:PAGEHEIGHT 0) ; This part of test determines if the variables BROWSERFORMAT and BROWSERBOXING ; are bound. (PASS-FAIL "Browser variables bound" (AND (BOUNDP 'IL:BROWSERFORMAT) (BOUNDP 'IL:BROWSERBOXING))) ; Reinitialize and Define functions to be analyzed.... (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) (DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) (DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) (DEFUN GFUN-A1 NIL T) (DEFUN GFUN-A2 NIL NIL) (DEFUN GFUN-A3 NIL T) (DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) (DEFUN GFUN-B2 NIL NIL) (DEFUN GFUN-B3 NIL T) (DEFUN GFUN-C1 NIL NIL) ; Start analyzing functions in gtop-function and others... (IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) (IL:MASTERSCOPE '(ANALYZE GFUN-A)) (IL:MASTERSCOPE '(ANALYZE GFUN-B)) (IL:MASTERSCOPE '(ANALYZE GFUN-A1)) (IL:MASTERSCOPE '(ANALYZE GFUN-A2)) (IL:MASTERSCOPE '(ANALYZE GFUN-A3)) (IL:MASTERSCOPE '(ANALYZE GFUN-B1)) (IL:MASTERSCOPE '(ANALYZE GFUN-B2)) (IL:MASTERSCOPE '(ANALYZE GFUN-B3)) (IL:MASTERSCOPE '(ANALYZE GFUN-C1)) ; Browser is now loaded and activated ; Part 1 of this test is to determine if masterscope is unaffected when ; the BROWSER is not enabled or (IL:BROWSER NIL) (IL:BROWSER NIL) ; Browser is now deactivated ... ; This will cause masterscope to display graphs in a teletype mode ; or in the exec. ; show paths should display the following path, which should look like; ; 1.gfun-a1 gfun-a top-gfuntion ; 2. gfun-b1 gfun-b top-gfuntion (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) (DRIBBLE) ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-gfuntion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.GFUN-A1GFUN-ATOP-GFUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.GFUN-B1GFUN-BTOP-GFUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE '{CORE}PATHS) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~3~ b/internal/test/env/program-analysis/hand/browser-part1.u.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..09efd41e28ea9b976338f2ed9320ba8b659959f9 GIT binary patch literal 5488 zcmb7ITW=ak7Ivh4!O}jiw2w!OR)&$AF=Q_pdz4iJZJQCd(2X)#?MnfLX{G66`Vz*I z$^5YSb^D!D-GH$ZXInOISDnjO=U!Z0(RCirv(Us87;0+@beieKCABA`x4t)_+E^tS z_3C&@%w3|^5`6>LXy=`YVRak0Wh`iFNx?!vx*@n zd0$|YT|QhFM3+F5%vaRBIH%_Kul`lg^i`VCbh8i&Drs5|XneEQ+m*@yext$!2CDp+ z$3Xi}A$!G`2YGx4AZwH8%ZlA@{oQWU>>iw;A2-NvP+P^iP<|ao;Biw1kLRN|>G_|2 z$l!$6I{xr_V{PuJ!sf46Dqg&vS&KOvxTe|2ttf`z-^ZEyrI1xCT^M{f?Db1~?cCkf z={yNH?E1a8*JcqeL-;LQY4UGJZ)xlXw?56ydJWBFmaq>3BuVFHqbW5YgjHBKa};D} zDVaRmx@A zfGXM0w0t-mJBkk}1~9bHFwHuIqXA)kU?`B}v05(exwk7Fi{8>h*p5v`I#x3d2b`G& z)_VQRl7cX&sRhuy$ypn(ujKZqmZcg$6=RZ1c7P5#XNaEKg#NU!WcMHe6(jcRL1_ zPE;6Y>398b9cCf`)K{OgBo6ciE3(XELq224V=J-<@nWkm;h~>w{Lcj?o2xKC%oVI) zSp0~`Iq?V;V!H|vnk*4JX@<;SAhzhEPQvul4-q1NjOv^Ble~=BRA)?#@Nkfie4q?O3R|Ar(&-xjKW`m4Ci6WNM(pp9LX2v zqWlsEOG0Y(8@`;OLpjB!YMG4A4Ces9d^3YKcL3 z7k)rSajjqs(1h9}K=XuU7P1>~B7}0vO4Z1%VG!JoEHV@}kN{=p?d(Xi_vwAQ%$E(8 z+CecyzM#k@wAN{gwuPL7XJAj0Y)m4j--g)=u^`2(ET2nM`!Z?-g7q&8g>!Ov6JXhy zWlt8pGw3Cci=eBPE;AtQgIKf7AYbSg`sdUW&qa@youi#jlFXUylyWz zFB9vW{m)X%0Nbefd$uRmcv&2lpukzD=P+_nvP%=C2oyG(bV!bJb_5Fk(nJyFic2e~ zf(HQ2#<@WQrKds}8z;NB`dwzf9c4Zjx-^qLZFr&*%E;E=JMPpHw-U?@D;<=?V>*LP3V~Jy?nRHc ztgbqrhzFz)!5S*=!P4!zddU;wzJOumK_4g!SObsP{-A8aZr;T8JxDAfEEtVZ%BI7h zHyYY;O8IdV0SF(2-iCMf3qZYTf4WH$6W0ruJ(?rz2j;>;&Pk9woeMH zu_db#e-Dtoe2ThlWmp#of2UdBK|eZN`!k~3Pm1nX(EQtPi-I?7f4+beExV zlq=#xgIblOPkYK8y8UTUnctl|&{J?`3oGBCX<4f9?uNIH)6%fQ7sYrJoxQ^~< zk8T!^79ipX@d8b+07?iSv?yEPq(#mZUt>d|zOz4_r zU=l4FDECWDsg$l@pN+~^xR|U=9xZl)_)vB_;y`DTawIJXBV*oE6u#GJNXb`NrW_J48_nGr4_ae^$`V9@5pilU}>s_vq|n2X~84a!q{7>j&5TV1)UF%UP4I zC!@imd@4k8kJ#s}9FE6T`Cejf@O=m_`{Kw$yUK{qp1_n)+nWlAq<0BCs$pOqQuP3F zm7}oM_X4zR@29}&_l924#^2teRTj;H+j-4~>n=iN^;V%zk)I`1#Yx zi<5t!G`UT=(>^Z6!+@IToNnjV#SFs@Q(j-;4Huk24~3sz)$1pJ7Iyjg%U}7=i<1+) Jy!iEx{{e}(MLGZg literal 0 HcmV?d00001 diff --git a/internal/test/env/program-analysis/hand/databasefns.data b/internal/test/env/program-analysis/hand/databasefns.data new file mode 100644 index 00000000..fba107f8 --- /dev/null +++ b/internal/test/env/program-analysis/hand/databasefns.data @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "19-Mar-87 10:54:40" {DSK}LIBRARY>NEW-FUNCTION.\;1 629 |changes| |to:| (VARS NEW-FUNCTIONCOMS) (FNS NEW-FUNCTION)) ; Copyright (c) 1987 by XEROX Corporation. All rights reserved. (PRETTYCOMPRINT NEW-FUNCTIONCOMS) (RPAQQ NEW-FUNCTIONCOMS ((FNS NEW-FUNCTION))) (DEFINEQ (NEW-FUNCTION (LAMBDA (X Y) (* \; "Edited 19-Mar-87 10:52 by jpark") (PLUS X Y))) ) (PUTPROPS NEW-FUNCTION COPYRIGHT ("XEROX Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (390 545 (NEW-FUNCTION 400 . 543))))) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/databasefns.data.~1~ b/internal/test/env/program-analysis/hand/databasefns.data.~1~ new file mode 100644 index 00000000..f906e727 --- /dev/null +++ b/internal/test/env/program-analysis/hand/databasefns.data.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP") (FILECREATED "19-Mar-87 10:54:40" {DSK}LIBRARY>NEW-FUNCTION.\;1 629 |changes| |to:| (VARS NEW-FUNCTIONCOMS) (FNS NEW-FUNCTION)) ; Copyright (c) 1987 by XEROX Corporation. All rights reserved. (PRETTYCOMPRINT NEW-FUNCTIONCOMS) (RPAQQ NEW-FUNCTIONCOMS ((FNS NEW-FUNCTION))) (DEFINEQ (NEW-FUNCTION (LAMBDA (X Y) (* \; "Edited 19-Mar-87 10:52 by jpark") (PLUS X Y))) ) (PUTPROPS NEW-FUNCTION COPYRIGHT ("XEROX Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (390 545 (NEW-FUNCTION 400 . 543))))) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/databasefns.data.~2~ b/internal/test/env/program-analysis/hand/databasefns.data.~2~ new file mode 100644 index 00000000..fba107f8 --- /dev/null +++ b/internal/test/env/program-analysis/hand/databasefns.data.~2~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "19-Mar-87 10:54:40" {DSK}LIBRARY>NEW-FUNCTION.\;1 629 |changes| |to:| (VARS NEW-FUNCTIONCOMS) (FNS NEW-FUNCTION)) ; Copyright (c) 1987 by XEROX Corporation. All rights reserved. (PRETTYCOMPRINT NEW-FUNCTIONCOMS) (RPAQQ NEW-FUNCTIONCOMS ((FNS NEW-FUNCTION))) (DEFINEQ (NEW-FUNCTION (LAMBDA (X Y) (* \; "Edited 19-Mar-87 10:52 by jpark") (PLUS X Y))) ) (PUTPROPS NEW-FUNCTION COPYRIGHT ("XEROX Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (390 545 (NEW-FUNCTION 400 . 543))))) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/inspect.report b/internal/test/env/program-analysis/hand/inspect.report new file mode 100644 index 00000000..394109e9 --- /dev/null +++ b/internal/test/env/program-analysis/hand/inspect.report @@ -0,0 +1 @@ +TEST REPORT FOR INSPECTOR COMMAND: INSPECTOR TEST-ITEM: INITIAL-VALUES-OF-VARIABLES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:16 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: ARRAY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:22 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: ATOM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:22 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: BIGNUM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:22 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: BIT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:23 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: BIT-VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:24 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: CHARACTER LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:24 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: COMMON LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:24 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: COMPILED-FUNCTION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:25 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: COMPLEX LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:25 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: CONS LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:25 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: DOUBLE-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:26 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: FIXNUM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:26 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:26 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: FUNCTION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:28 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: HASH-TABLE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:28 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: INTEGER LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:29 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: KEYWORD LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:29 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: LIST LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:29 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: LONG-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:30 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: NULL LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:30 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: NUMBER LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:31 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: PACKAGE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:31 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: PATHNAME LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:32 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: RATIO LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:32 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: RATIONAL LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:33 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: READTABLE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:33 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SEQUENCE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:34 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SHORT-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:34 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SIMPLE-ARRAY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:35 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SIMPLE-BIT-VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:35 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SIMPLE-STRING LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:36 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SIMPLE-VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:36 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SINGLE-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:36 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: STANDARD-CHAR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:37 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: STREAM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:38 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: STRING LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:38 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: STRING-CHAR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:39 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: SYMBOL LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:39 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: T LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:39 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:40 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: WINDOW LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:40 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: INSPECTCODE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:41 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: INSPECT-WHERE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 24-Mar-87 13:40:41 TESTER: JPARK.PASA COMMAND: INSPECTOR TEST-ITEM: RANDOM-STATE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: FAIL DATE: 24-Mar-87 14:36:45 TESTER: JPARK.PASA TOTAL TEST RUN TIME FOR INSPECTOR: 7.845033 MINUTES COMMAND: INSPECTOR TEST-ITEM: INITIAL-VALUES-OF-VARIABLES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:13 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: ARRAY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:31 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: ATOM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:32 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: BIGNUM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:34 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: BIT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:35 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: BIT-VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:36 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: CHARACTER LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:37 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: COMMON LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:39 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: COMPILED-FUNCTION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:39 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: COMPLEX LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:41 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: CONS LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:41 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: DOUBLE-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:42 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: FIXNUM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:43 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:44 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: FUNCTION LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:44 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: HASH-TABLE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:46 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: INTEGER LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:46 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: KEYWORD LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:49 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: LIST LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:50 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: LONG-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:50 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: NULL LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:52 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: NUMBER LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:52 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: PACKAGE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:53 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: PATHNAME LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:53 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: RATIO LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:55 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: RATIONAL LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:56 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: READTABLE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:56 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SEQUENCE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:57 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SHORT-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:58 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SIMPLE-ARRAY LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:58 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SIMPLE-BIT-VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:50:59 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SIMPLE-STRING LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:00 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SIMPLE-VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:01 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SINGLE-FLOAT LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:01 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: STANDARD-CHAR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:02 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: STREAM LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:03 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: STRING LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:03 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: STRING-CHAR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:04 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: SYMBOL LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:05 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: T LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:05 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: VECTOR LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:06 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: WINDOW LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:08 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: INSPECTCODE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:08 TESTER: SCHUSTER COMMAND: INSPECTOR TEST-ITEM: INSPECT-WHERE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 30-Mar-87 09:51:09 TESTER: SCHUSTER TOTAL TEST RUN TIME FOR INSPECTOR: 12.1403 MINUTES \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u b/internal/test/env/program-analysis/hand/masterscope.u new file mode 100644 index 00000000..9ba52eff --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Massively munged by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) (BREAK "Argh!") IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL, so that will count as failure as well. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene ;; JRB - a feature of who calls who is that the order in which the calling information ;; comes out is dependent on the order things got analyzed in. Things get reanalyzed ;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. ;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR ;; between two lists of strings; yuck**2. (LET (ALL-LINES NEXT-LINE) ;; First suck in the lines (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) ;; Then compare them (PASS-FAIL "Who calls...? (analyzing)" (NOT (SET-EXCLUSIVE-OR ALL-LINES '("top-funtion--(fun-afun-b)" "FUN-B1--(FUN-C1FUN-A1)" "FUN-B--(FUN-B1FUN-B2FUN-B3)" "FUN-A--(FUN-A1FUN-A2FUN-A3)") :TEST #'STRING-EQUAL)))) (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~1~ b/internal/test/env/program-analysis/hand/masterscope.u.~1~ new file mode 100644 index 00000000..6cea39b4 --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~1~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" (PROGN (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) (SETQ MESS1 "Now do-test will determine if correct results have been returned for the analysis of user functions...") (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>MASTERSCOPE.REPORT") (DEFUN R-FORMAT (STATUS) (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" (LISP-IMPLEMENTATION-VERSION) STATUS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE COMMAND LANGUAGE: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE COMMAND LANGUAGE: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) (SETQ {CORE}WHO-CALLS "{CORE}WHO-CALLS") (SETQ {CORE}PATHS "{CORE}PATHS") (SETQ {CORE}DESCRIBE "{CORE}DESCRIBE") (SETQ MASTERSCOPE-COMMAND-STRING "; Reinitialize and Define functions to be analyzed . ERASE (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function . ANALYZE TOP-FUNTION . ANALYZE FUN-A . ANALYZE FUN-B . ANALYZE FUN-B1 . WHO CALLS FUN-A1 (IF (EQUAL * '(FUN-A FUN-B1)) (SETQ FUN-A1-CALL T) (SETQ FUN-A1-CALL NIL)) . WHO CALLS TOP-FUNTION (IF (EQUAL * NIL) (SETQ TOP-FUN-CALL T) (SETQ TOP-FUN-CALL NIL)) . WHO CALLS FUN-A (IF (EQUAL * '(TOP-FUNTION)) (SETQ FUN-A-CALL T) (SETQ FUN-A-CALL NIL)) . WHO CALLS FUN-B2 (IF (EQUAL * '(FUN-B)) (SETQ FUN-B-CALL T) (SETQ FUN-B-CALL NIL)) (DRIBBLE '{CORE}WHO-CALLS) . WHO CALLS WHO (DRIBBLE) (DRIBBLE '{CORE}PATHS) . SHOW PATHS TO FUN-A1 FROM TOP-FUNTION (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) . WHO CALLS FUN-A1 . ERASE FUN-A . WHO CALLS FUN-A1 (IF (EQUAL * '(FUN-B1)) (SETQ FUN-A-ERASED T) (SETQ FUN-A-ERASED NIL)) (SETQ ALL-ERASED-FLG NIL) . ERASE . WHO CALLS FUN-A (IF (EQUAL * NIL) (PUSH T ALL-ERASED-FLG) (PUSH NIL ALL-ERASED-FLG)) . WHO CALLS FUN-B2 (IF (EQUAL * NIL) (PUSH T ALL-ERASED-FLG) (PUSH NIL ALL-ERASED-FLG)) . WHO CALLS FUN-B2 (IF (EQUAL * NIL) (PUSH T ALL-ERASED-FLG) (PUSH NIL ALL-ERASED-FLG)) ; REANALYZE (causes masterscope to reanalyze the functions in SET) . ANALYZE TOP-FUNTION . ANALYZE FUN-A . ANALYZE FUN-B . ANALYZE FUN-B1 . ERASE FUN-A . REANALYZE FUN-A . WHO CALLS FUN-A1 (IF (EQUAL * '(FUN-B1 FUN-A)) (SETQ REANALYZED-FLG T) (SETQ REANALYZED-FLG NIL)) . ERASE ;SET ARE SET . WHO IS CALLED BY TOP-FUNTION (IF (EQUAL * '(FUN-A FUN-B)) (SETQ CALLED-BY-FLG T) (SETQ CALLED-BY-FLG NIL)) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (PROGN (SETQ X1 (1+ X)) (SETQ Y1 (1- Y)))) . ANALYZE FUN-DESCRIBE (DRIBBLE '{CORE}DESCRIBE) . DESCRIBE FUN-DESCRIBE (DRIBBLE) . ERASE ; analyzing the file that contains describe results (SETQ DESCRIBE-LIST '(| calls: 1+,1-| | binds: x,y| | uses free: y1,x1|)) (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN {CORE}DESCRIBE)) (DO (( i 0 (1+ i))) ((= i 4) t) (READ-LINE DESCRIBE-FILE)) (DOLIST (Y DESCRIBE-LIST) (IF (STRING-EQUAL Y (READ-LINE DESCRIBE-FILE)) (PUSH T DESCRIBE-FLG) (PUSH NIL DESCRIBE-FLG))) (CLOSE DESCRIBE-FILE) (DELETE-FILE {CORE}DESCRIBE) ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ CALL-LIST '(|fun-b -- (fun-b1 fun-b2 fun-b3)| |fun-a -- (fun-a1 fun-a2 fun-a3)| |top-funtion -- (fun-a fun-b)| |fun-b1 -- (fun-c1 fun-a1)| )) (SETQ WHO-CALLS-FLG NIL) (SETQ WHO-CALLS (OPEN {CORE}WHO-CALLS)) (READ-LINE WHO-CALLS) (READ-LINE WHO-CALLS) (READ-LINE WHO-CALLS) (DOLIST (Y CALL-LIST) (IF (STRING-EQUAL Y (READ-LINE WHO-CALLS)) (PUSH T WHO-CALLS-FLG) (PUSH NIL WHO-CALLS-FLG))) (CLOSE WHO-CALLS) ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN {CORE}PATHS)) (DO (( i 0 (1+ i))) ((= i 5) t) (READ-LINE PATHS)) (IF (AND (STRING-EQUAL (READ-LINE PATHS) '|1.fun-a1 fun-a top-funtion|) (STRING-EQUAL (READ-LINE PATHS) '|2. fun-b1 fun-b top-funtion|)) (SETQ PATHS-FLG T)(SETQ PATHS-FLG NIL)) (CLOSE PATHS) (DELETE-FILE '{CORE}PATHS) (DELETE-FILE '{CORE}WHO-CALLS) (FORMAT NIL MESS1) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) (ITEM-FORMAT-F COMMAND-LANGUAGE))) (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) (DO-TEST 'MASTERSCOPE-TEST-RESULT (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT :IF-EXISTS :APPEND)) (IF (AND (EQ FUN-A1-CALL T) (EQ TOP-FUN-CALL T) (EQ FUN-A-CALL T) (EQ FUN-B-CALL T) (EQ PATHS-FLG T) (EQ FUN-A-ERASED T) (NOTANY #'NULL ALL-ERASED-FLG) (EQ REANALYZED-FLG T) (EQ CALLED-BY-FLG T) (NOTANY #'NULL DESCRIBE-FLG) (NOTANY #'NULL WHO-CALLS-FLG)) (PROGN (R-FORMAT 'SUCCESS) T) (PROGN (R-FORMAT 'FAIL) NIL)) (PASS-FAIL 'WHO-CALLS (NOTANY #'NULL WHO-CALLS-FLG)) (PASS-FAIL 'SHOW-PATHS PATHS-FLG) (PASS-FAIL 'ERASED (AND FUN-A-ERASED (NOTANY #'NULL ALL-ERASED-FLG))) (PASS-FAIL 'WHO-IS-CALLED-BY CALLED-BY-FLG) (PASS-FAIL 'REANALYZE REANALYZED-FLG) (PASS-FAIL 'DESCRIBE (NOTANY #'NULL DESCRIBE-FLG)) (T-FORMAT TOTAL-TEST-TIME) (CLOSE *OUTPUT*) ) ) ") (IL:BKSYSBUF MASTERSCOPE-COMMAND-STRING) ) ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~2~ b/internal/test/env/program-analysis/hand/masterscope.u.~2~ new file mode 100644 index 00000000..d1eb5da9 --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~2~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Somewhat Repaired: June 16, 1988 ;; ;; Munged (as little as possible) by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (PROGN (SETQ X1 (1+ X)) (SETQ Y1 (1- Y)))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL so however John Parks meant to determine ;; if the test failed will still work, supposedly. I mean, true or false results ;; are still pushed onto DESCRIBE-FLG, for whatever reason they're supposed to be ;; pushed. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Who calls...? (analyzing)" (AND (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) )) ) ; close let (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~3~ b/internal/test/env/program-analysis/hand/masterscope.u.~3~ new file mode 100644 index 00000000..d60a3fa9 --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~3~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Massively munged by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL so however John Parks meant to determine ;; if the test failed will still work, supposedly. I mean, true or false results ;; are still pushed onto DESCRIBE-FLG, for whatever reason they're supposed to be ;; pushed. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Who calls...? (analyzing)" (AND (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) )) ) ; close let (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~4~ b/internal/test/env/program-analysis/hand/masterscope.u.~4~ new file mode 100644 index 00000000..5b2b1405 --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~4~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Massively munged by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL, so that will count as failure as well. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Who calls...? (analyzing)" (AND (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) )) ) ; close let (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~5~ b/internal/test/env/program-analysis/hand/masterscope.u.~5~ new file mode 100644 index 00000000..29f2f1cf --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~5~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Massively munged by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL, so that will count as failure as well. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene ;; JRB - a feature of who calls who is that the order in which the calling information ;; comes out is dependent on the order things got analyzed in. Things get reanalyzed ;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. ;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR '' between two lists of strings; yuck**2. (LET (ALL-LINES NEXT-LINE) ;; First suck in the lines (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) ;; Then compare them (PASS-FAIL "Who calls...? (analyzing)" (NOT (SET-EXCLUSIVE-OR ALL-LINES '("top-funtion--(fun-afun-b)" "FUN-B1--(FUN-C1FUN-A1)" "FUN-B--(FUN-B1FUN-B2FUN-B3)" "FUN-A--(FUN-A1FUN-A2FUN-A3)") :TEST #'STRING-EQUAL)))) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Who calls...? (analyzing)" (AND (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) )) ) ; close let (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~6~ b/internal/test/env/program-analysis/hand/masterscope.u.~6~ new file mode 100644 index 00000000..4561713b --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~6~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Massively munged by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL, so that will count as failure as well. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene ;; JRB - a feature of who calls who is that the order in which the calling information ;; comes out is dependent on the order things got analyzed in. Things get reanalyzed ;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. ;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR '' between two lists of strings; yuck**2. (LET (ALL-LINES NEXT-LINE) ;; First suck in the lines (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) ;; Then compare them (PASS-FAIL "Who calls...? (analyzing)" (NOT (SET-EXCLUSIVE-OR ALL-LINES '("top-funtion--(fun-afun-b)" "FUN-B1--(FUN-C1FUN-A1)" "FUN-B--(FUN-B1FUN-B2FUN-B3)" "FUN-A--(FUN-A1FUN-A2FUN-A3)") :TEST #'STRING-EQUAL)))) (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~7~ b/internal/test/env/program-analysis/hand/masterscope.u.~7~ new file mode 100644 index 00000000..9ba52eff --- /dev/null +++ b/internal/test/env/program-analysis/hand/masterscope.u.~7~ @@ -0,0 +1 @@ +;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) ;; ;; Source: Lyric Release Overview (Lyric Beta Release) ;; Section 19 (Masterscope), Page 22 ;; Section: Program Analysis ;; ;; Created By: John Park ;; ;; Creation Date: Feb 25, 1987 ;; ;; Last Update: March 26, 1987 ;; ;; Massively munged by Rene P. S. Bane June 24, 1988 ;; ;; Filed As: {ERIS}test>program-analysis>masterscope.u ;; ;; ;; Syntax: . &rest LINE ;; ;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive ;; program for analyzing and cross referencing user programs. It contains ;; facilities for analyzing user functions to determine what other functions are ;; called, how and where variables are bound, set, or referenced, as well as ;; which functions use particular record declarations. Masterscope is able to ;; analyze definitions directly from a file as well as in-core definitions. ;; This test is almost identical to the masterscope as an exec command, which is ;; located in {eris}test>exec>masterscope.u ;; ;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) ;; ;; Returns: (SEE IRM, Vol 3, Section 19) ;; ;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, ;; testing them will be performed using do-test and the interlisp function bksysfuf. ;; Comments or messages are incorporated within ;; each command file, which will be run by using the function bksysbuf. ;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command ;; string. The do-test form within the command file will return T or "test ;; failed" This test file requires TEDIT and MASTERSCOPE package ;; The tree structure of the functions being analyzed are as follows: ;; ;; Top-Funtion ;; | ;; Fun-A------------------------Fun-B ;; | | ;; --------------------- -------------------- ;; | | | | | | ;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 ;; | ;; -------------- ;; | | ;; Fun-C1 Fun-A1 ;; ;; Messages will be printed before each command in the command files is executed ;; for user monitoring. Test result is logged on ;; {eris}test>program-analysis>masterscope.report (DO-TEST "MASTERSCOPE-TEST-SETUP" ;; If the browser is already loaded, undo what the browser did so this testfile ;; will work properly, then redo it. This is relying on the browser to always ;; affect MSPATHS, because there is no official way of undoing the browser ;; (that I know of) (IL:IF (IL:GETD 'IL:OLDMSPATHS) IL:THEN (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) (SETQ TEST-SUCCEEDED T) (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ TEST-SUCCEEDED NIL) (BREAK "Argh!") IL:ELSE "Hey, no problem!")) ; Reinitialize and Define functions to be analyzed (IL:MASTERSCOPE '(ERASE)) (DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) (DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) (DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) (DEFUN FUN-A1 NIL T) (DEFUN FUN-A2 NIL NIL) (DEFUN FUN-A3 NIL T) (DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) (DEFUN FUN-B2 NIL NIL) (DEFUN FUN-B3 NIL T) (DEFUN FUN-C1 NIL NIL) ; Start analyzing functions in top-function (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) (PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) (DRIBBLE '{CORE}WHO-CALLS) (IL:MASTERSCOPE '(WHO CALLS WHO)) (DRIBBLE) (DRIBBLE '{CORE}PATHS) (IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) (DRIBBLE) ; ERASE (erase all information about the functions in SET from the database) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) ))) ; REANALYZE (causes masterscope to reanalyze the functions in SET) (IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) (IL:MASTERSCOPE '(ANALYZE FUN-A)) (IL:MASTERSCOPE '(ANALYZE FUN-B)) (IL:MASTERSCOPE '(ANALYZE FUN-B1)) (IL:MASTERSCOPE '(ERASE FUN-A)) (IL:MASTERSCOPE '(REANALYZE FUN-A)) (PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) (IL:MASTERSCOPE '(ERASE)) (PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) ; DESCRIBE SET (prints out the bind, use freely and call information) (DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) (IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) (DRIBBLE '{CORE}DESCRIBE) (IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) (DRIBBLE) (IL:MASTERSCOPE '(ERASE)) ; analyzing the file that contains hopefully correct results (SETQ DESCRIBE-FLG NIL) (SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) ;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters ;; expected. At least now it doesn't require the exact number of spaces....Rene ;; p.s. premature EOF will return a NIL, so that will count as failure as well. (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Describe" (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) )) ) ; close let (CLOSE DESCRIBE-FILE) (DELETE-FILE "{CORE}DESCRIBE") ; analyzing the file that contains the previous masterscope interactions ; (who calls?) (SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) ;; Another test which replaces the previous "throw away the first three lines ;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There ;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene ;; JRB - a feature of who calls who is that the order in which the calling information ;; comes out is dependent on the order things got analyzed in. Things get reanalyzed ;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. ;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR ;; between two lists of strings; yuck**2. (LET (ALL-LINES NEXT-LINE) ;; First suck in the lines (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) ;; Then compare them (PASS-FAIL "Who calls...? (analyzing)" (NOT (SET-EXCLUSIVE-OR ALL-LINES '("top-funtion--(fun-afun-b)" "FUN-B1--(FUN-C1FUN-A1)" "FUN-B--(FUN-B1FUN-B2FUN-B3)" "FUN-A--(FUN-A1FUN-A2FUN-A3)") :TEST #'STRING-EQUAL)))) (CLOSE WHO-CALLS) (DELETE-FILE "{CORE}WHO-CALLS") ; analyzing the file that contains the masterscope interaction (show paths) (SETQ PATHS (OPEN "{CORE}PATHS")) (LET (NEXT-LINE) (IL:WHILE (AND (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) (PASS-FAIL "Show paths (would-be graph)" (AND (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) )) ) ; close let (CLOSE PATHS) (DELETE-FILE "{CORE}PATHS") ;; if the browser was loaded, reset MSPATHS so it looks loaded again (IL:IF (IL:GETD 'OLDMSPATHS) IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) TEST-SUCCEEDED ) STOP \ No newline at end of file diff --git a/internal/test/i/o/Display/Auto/CURSORTEST.SOURCE b/internal/test/i/o/Display/Auto/CURSORTEST.SOURCE new file mode 100644 index 00000000..fa4f28de --- /dev/null +++ b/internal/test/i/o/Display/Auto/CURSORTEST.SOURCE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "XCL" §BASE 10) (FILECREATED "30-Mar-87 16:03:39" {ERIS}TEST>DISPLAY>CURSORTEST.SOURCE\;10 5831 |changes| |to:| (VARS CURSORTESTCOMS) |previous| |date:| "30-Mar-87 15:50:23" {ERIS}TEST>DISPLAY>CURSORTEST.SOURCE\;8) ; Copyright (c) 1987 by XEROX Corporation. All rights reserved. (PRETTYCOMPRINT CURSORTESTCOMS) (RPAQQ CURSORTESTCOMS ((VARS CURSORNAMES XCL-TEST::DOLLAR XCL-TEST::WRONGDOLLAR-16-17 XCL-TEST::WRONGDOLLAR-17-16 XCL-TEST::TRIANGLE) (FNS XCL-TEST::CURSORP XCL-TEST::CURSORSETTEST XCL-TEST::CNAMETEST XCL-TEST::MOVECURSORTEST) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA XCL-TEST::MOVECURSORTEST XCL-TEST::CNAMETEST XCL-TEST::CURSORSETTEST XCL-TEST::CURSORP))))) (RPAQQ CURSORNAMES (WAITINGCURSOR MOUSECONFIRMCURSOR SYSOUTCURSOR SAVINGCURSOR CROSSHAIRS BOXCURSOR FORCEPS EXPANDINGBOX |UpperRightCursor| |LowerRightCursor| |UpperLeftCursor| |LowerLeftCursor| |VertThumbCursor| |VertScrollCursor| |ScrollUpCursor| |ScrollDownCursor| |HorizThumbCursor| |HorizScrollCursor| |ScrollLeftCursor| |ScrollRightCursor| DEFAULTCURSOR)) (RPAQQ XCL-TEST::DOLLAR #*(16 16)@EJ@@FF@@LC@ADBHADBHADB@@LB@@FB@@EJ@@DF@@DC@ADBHADBH@LBH@DC@@CL@) (RPAQQ XCL-TEST::WRONGDOLLAR-16-17 #*(16 17)@EJ@@FF@@LC@ADBHADBHADBH@LB@@FB@@EJ@@DF@@DC@ADBHADBHADBH@LC@@FF@@EJ@) (RPAQQ XCL-TEST::WRONGDOLLAR-17-16 #*(17 16)@EM@@@@@@FC@@@@@@DAH@@@@@LAD@@@@ADAD@@@@ADAD@@@@ADA@@@@@@LA@@@@@@FA@@@@@@EM@@@@@ADC@@@@@ADAH@@@@ADAD@@@@@LAD@@@@@FCH@@@@@EM@@@@@ ) (RPAQQ XCL-TEST::TRIANGLE #*(15 16)OOONH@@BD@@DD@@DB@@HB@@HA@A@A@A@@HB@@HB@@DD@@DD@@BH@@BH@@A@@@A@@) (DEFINEQ (XCL-TEST::CURSORP (CL:LAMBDA (XCL-TEST::OBJECT) (* \; "Edited 26-Mar-87 10:56 by REIDY") "OBJECT iff it's a cursor, else NIL" (COND ((TYPEP XCL-TEST::OBJECT 'CURSOR) XCL-TEST::OBJECT) (T NIL)))) (XCL-TEST::CURSORSETTEST (CL:LAMBDA (XCL-TEST::CURSOR) (CL:BLOCK XCL-TEST::CURSORSETTEST (CURSOR XCL-TEST::CURSOR) (CL:EQUAL (CURSOR) XCL-TEST::CURSOR)))) (XCL-TEST::CNAMETEST (CL:LAMBDA NIL (CL:BLOCK XCL-TEST::CNAMETEST (LET ((XCL-TEST::CURSORLIST (CL:MAPCAR 'CL:EVAL CURSORNAMES))) (AND (CL:EVERY 'BOUNDP CURSORNAMES) (CL:EVERY 'CURSORP XCL-TEST::CURSORLIST) (CL:EVERY 'BITMAPP (CL:MAPCAR 'CURSORBITMAP XCL-TEST::CURSORLIST )) (CL:EVERY 'XCL-TEST::CURSORSETTEST XCL-TEST::CURSORLIST)))))) (XCL-TEST::MOVECURSORTEST (CL:LAMBDA NIL (CL:BLOCK XCL-TEST::MOVECURSORTEST (LET ((XCL-TEST::DOLLARCURSOR (CURSORCREATE XCL-TEST::DOLLAR 10 10)) (XCL-TEST::TRIANGLECURSOR (CURSORCREATE XCL-TEST::TRIANGLE 8 8))) (CURSOR XCL-TEST::DOLLARCURSOR) (PRIN1 'XCL-TEST::|Move the dollar-sign cursor through the TEdit, SEdit, Filebrowser and EXEC windows, then enter a carriage return.| ) (CL:READ-CHAR) (SETCURSOR XCL-TEST::TRIANGLECURSOR) (PRIN1 'XCL-TEST::|Move the triangular cursor through the TEdit, SEdit, Filebrowser and EXEC windows, then enter a carriage return.| ) (CL:READ-CHAR) (SETCURSOR BOXCURSOR) (PRIN1 'XCL-TEST::|Move the square cursor through the TEdit, SEdit, Filebrowser and EXEC windows, then enter a carriage return.| ) (CL:READ-CHAR) (CURSOR T) (CL:VALUES))))) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA XCL-TEST::MOVECURSORTEST XCL-TEST::CNAMETEST XCL-TEST::CURSORSETTEST XCL-TEST::CURSORP) ) (PUTPROPS CURSORTEST.SOURCE COPYRIGHT ("XEROX Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2048 5523 (XCL-TEST::CURSORP 2058 . 2350) (XCL-TEST::CURSORSETTEST 2352 . 2560) ( XCL-TEST::CNAMETEST 2562 . 3439) (XCL-TEST::MOVECURSORTEST 3441 . 5521))))) STOP \ No newline at end of file diff --git a/internal/test/i/o/Display/Auto/CURSORTEST.TEST b/internal/test/i/o/Display/Auto/CURSORTEST.TEST new file mode 100644 index 00000000..ebb2453c --- /dev/null +++ b/internal/test/i/o/Display/Auto/CURSORTEST.TEST @@ -0,0 +1 @@ +(do-test-group cursortests ;; Automatic tests of cursor functions ;; Filed as {ERIS}TEST>DISPLAY>CURSOR.TEST ;; ;; 26 March 1987 ;; By Peter Reidy :before (il:load? "{eris}i/o>display>auto>cursortest.source") ;; (do-test cname (cnametest) ) ; do-test cname ;; ;; Tests of AR 8204: see if cursoring rejects oversize bitmaps (i.e. > 16 x 16) rather than proceeding to a crash. ;; WARNING: don't try this in 11 March or earlier sysouts. (do-test cursor-16x17-test (expect-errors (error) (cursor (cursorcreate wrongdollar-16-17)))) (do-test cursor-17x16-test (expect-errors (error) (cursor (cursorcreate wrongdollar-17-16)))) (do-test setcursor-16x17-test (expect-errors (error) (setcursor (cursorcreate wrongdollar-16-17)))) (do-test setcursor-17x16-test (expect-errors (error) (setcursor (cursorcreate wrongdollar-17-16)))) ) ; do-test-group cursortests STOP \ No newline at end of file diff --git a/internal/test/i/o/Display/Hand/CURSOR.PROC b/internal/test/i/o/Display/Hand/CURSOR.PROC new file mode 100644 index 0000000000000000000000000000000000000000..9205cc1d79b5fef90f929a7b6f23f0c81618b0b7 GIT binary patch literal 2174 zcma)6&yU+g6!tDZ4wic1fZ&3jdI6-=u%$%>sz_Gh;$q z^*`atiT{8r{}|sJJG)M@RW>=;^Ze$$?|t7lD-twTWr-To+|(5QDHA}cQjEbEWM!rH zhhI$2A6$&aKaO66bpO}!^Z|Fc|D`|YNlm7jBBh1I;F45TyduSwyD})vag%5%tAHrv zl7xB4Gz%kNHt0bKFrc4lIdKH`P_%@Kfc`L`XN|Qe%o;t@YHd)_5y+huNL*>v z0DdW}W&nVqZoz43n!*Y+?5Z0DaKchtgefH@jW#%H>l`*)NVp3}3JMp6 z&}8ye<-|m&l*YhR8&x~Gu?fewtS!A#4HTvlo?wsI48B@r&b>?3Xg+o~>>HThEnBY- z_`PatqQrzkt6eVUSQ*eTq-SpU|9RZY)TT28UvM88u%kO6)z1Gf)no!(Y$P~ zZ^`!d(XtdcnyP}(t}aMo>uwb5(?fLA8drU0UqwR-N0TAM~RDq4Sw#8 j|I@)5%YzwvT|U~`a`fI#!25eQ@Lw1B@TvFc^}qiEV+1ep literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Display/Logs/CURSOR.LOG b/internal/test/i/o/Display/Logs/CURSOR.LOG new file mode 100644 index 0000000000000000000000000000000000000000..01ed8569187316eb740c40081c46462d6615571d GIT binary patch literal 1473 zcma)4%Wl&^6m=i4u&6+=VTCSI7b$AfBrOO96v-rRV<|5=iAt9fds2^ZJkiXUVh|s~ zf-m3?_&V;jt=0{q!i$mT%(>^D`{>U7>DY&vJDq{=PR9PsJ`*tyfob^W`rh>W`++x| zbjQBiAyTJ@w}Ern>E?m;!T8+%kimo-uE6Ia%xt@xDlHWlt_?(}^O-BL6sTz;4s0P} zVKOih0>zm@BncsiSaQX4LQq5#x|AuNERJE3ir5^91d3Ok2ceu$XjIEUpil@4VODId zq2~ERSl8jCQE$FJpi~PEa#_errFdY#WNTix9bdze>OF*OVIpFnq&Cc?m_t+0NdtyV z1radC+xFX5qXk9n7hZ4H&y5uKzU!U$XOJcfvTcv}^>I%I>53;PCuBmgr%*Ph1I;(^ zk&b|+nrryPvxQ_TJYGq>Lm(5QWK7;eq1k%PnZn6@;UUU2TR5;#7*N<^i3jxDGiN@S z6-LkkhT}UX#pY#&6|Tiq0!J|SY}>i*8C9>_HqCl;>EgKaDbvh5gG=A*c5vFGX~!<- zO}Cu<&&9Z5`r~dJM52vK1G0jh#;sVfBxP6^IzNOpQ$_@7%v6jULHmLYcYL4{OC7RP zr=txFLV1+4$aJp8QX^N`-JpoBT{!;88=bdtkV5B}F7z6wIN?a(7|VV$TtB8GGziUR zIboe?nVNT)1`>%YqB6iHBO_PCHP%?hLDkrFJome98^;xLNH`B^3$t=T>Jw~1WkGIA zfm&fDmMqj|3Sl&~7aUu}LF0l_CX2oY)~;2v_VfSz*xtJR-}tNH{f2ojZ~s4el?3+e5Uz&c<6 literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC b/internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC new file mode 100644 index 0000000000000000000000000000000000000000..1e77289a205a4540dc8cadaac12990a5318965f6 GIT binary patch literal 4892 zcmcgu+iv656;&q5gV>}OBtg>#2sYXRwg8*D*qTw?zYs=5$VK!2|!ba7Gau4 z<;99q^b7hE1^O3#YX7WjACfjD*)ZCo)nLrSefIsbHnq`3uQi;R-x@P=4BMgU%o-TO z^O>P(qaYM>aufQKF*EHye?2zs>A;#9$IN(q+Mf*v*7WlDQG?FHkdt93SClS-gqE@N z#5{`y$;cDr$MTk38oJS3gn^6*hmD*2t5~=n{?7D{w@K}vGTap{`Y*J&Dyr5n3U(Aqj# zOUSu2khizcH4c&`89xXQs-ii{!TyN|v1q%4@sT;%pY{je^xqn^b1@k2pWDW)p&5Ly z0!*^2MEo&>0Ajekg>aG=PgS*|GOx1h-MH66uanl%={(6pthi4yCUbl=w)#U#C56(> zljW;c38L#FqpCl+-ST?HA{1^SBIN3LY@W>ev&-Wn(nc5iWz*{8fpw-0$BuJZ9%pvv zpfkwd>~9QbaGIYFbW-tYyQL>PMPsYBFq_t6PoMTD!(-c-8T~W9wDsYrZ;u-qBnQ@H zQclD(f=nKnW5Yhy4t4Zmsw%761nC``Q%ca)-U2Oz=|UH+A};?@r(TB}R@H7CT*YpD zPiJzTq1kk;`>1M7g^%3c%Pc0eN#KTPe-zPoJ)skgaK~L`EE5^!@tO#faP!!tris z9whEnC~$k2U&87e;9berw{9^W=))Km}O*Xs4JUbk9w&sD&O!UDYDSs|@SPx`P7KWCaD2`pmf7_}wSpQCn#wq3&=|-l0#>S9z)76l2+I*@i@X*$L#iKpv;*?Qni$kp z#|vw6VU0#>E^^Znno(e7VKkZ^*419o2Ffd+_n{}FG?pQcd@LAL1(u-NRvhMBdKoBr z`gO*QA}fe=3Osa(V^?NHl<-1T%cx8UZznW4Yg!0^D^P^bVSwr*Cq=rHB6ITg)Uq9* zg98pfi}F>u3b5B=k!EpTtw^ktxB{NSm$UwK(4Wx`G}^{ws58jvj)lDs2k`|_dV>|4 zy9(?sfL<-kRtp=KSuY&jF@{JoZ>3iId{(@cZRaK_7m>$~o85P_FfEp9tZT2glXLn` zrDmC>l-GYV8_y&`d-I@+BT}ec)OOADqJ>dI9v75tj)wPA34ktrhQGSj(`naII~quw zq(C2hHDClAWjT4N*fwtn+Q~iLHis4W@@C4Fs3nyj*Hc(*8+<7YoNh%SoYsU zfnviQJip;Kp#VmTg`xj&X!}X2gB?;>Ner9bmJZ2mXBB9wt(sYdjs_?$Okm@|PN5_#L-3 zx)&WTo&gZ%0NOzyxDF!K?tnlzQ{&%?YOiWP)N21IDNjE;n?mnB z>Ud7#%i5Ra6`OfcVz1=p=PO9O@cRJ4d{X=HZGUjuuYLT${CVwT$2>FanRV8mlyqo& zk`5`SHrg$acw_<5+qA1xQoGeCk3F0KrDs@bW8#;?)?xQzJO$Ns`uH4aH5!f5R^iDj zxW`fB#|O?cKYz`~_xVpjP#jgl8@{U&wmAN|$?>;M!j{O-svN9bWxKTU3Iyetl7nM> zG1wG2D+xd01Iv6=Quvh#zhFYCgb9kZO8Ds}htg4Uu-!UyR6YCsrbxR=V9qWR`0yzo z*e?HnP{KD^mB8lK3c&=`t)<;3IexjRV=aCb+2Wv0k=;$g7gYkA|814PN-v6iQa>O4jwSw|plhYgJoT7}tubhk~5b;|ux6 zvFBN5kMvuX=QJ(K#k%JOA^i|o`mf71&TGYP`Ks!5vnaDsZ>%@E*|b- zk5vW)2&cMSswS=^HF1p`AAwDkv@SCQW5GdHwn`NxStS>$tTI^x(^c8XKV@}9O)3jo zS8&&mK1j7l4VEM1f7CT%=&-8db($?07K-I%t=<~kI+jZpvO_dWvl?)71g_V4X3*3+ zE7;w~iKJy!-c$HkWec(!q)dtPGf?ivMh7tJw21;z0G!aGlAsLDVk%@qCgBmSAC$Ic znrp0M8FoVH6P;BWD`SOUQ&t~j0;B=T)(}YNzw~FD^tlGc%`iaYO)+$)NXlkUa_DhH z$ed(J@!Aw1iLsCsszhbQFX(n|3NX#j$$4kE{6~7tm}Ahk8FvdK2pEKxp>(ZrYvs0L zm1|iTt+qNPRSftmsvr%-S1C5Nk)%$urJ`Eq7!Gz}NZ9a@)m);4D{qRYd>L!2+$o?iR2(G^8ONO%5Z z8jK_A(d{Id45Le*$R1FKx@|IUqj5Cz-_KySC*yf^PJ+(D;piG8V_yzOS3?qAEN}et zV17dr|8gD(vK zFzW1f7dh}XaQR__1qp2*-}=$Wl(B8mb-_vW2AmQPY+TeO+vz!2_qE+Q;q|FmcfBV8 zo{n~)38M98;OgiBzi_p^=Wv9{>UBAIX1+(S-A4jv>KOHz8geP&*@jS2Zx)=i< zQ^)i)n2bU`bdGM6X`mxmcTYEVucpt=g+2?AS9mP1*0{$(* literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC b/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC new file mode 100644 index 0000000000000000000000000000000000000000..8f19c0cfa3c89648038d6987b60e8fdc493f2ccb GIT binary patch literal 3248 zcmb7GUys{F5KmhwQHz2QLaKN`qw>&1O5NODi`r5mxrwi5)#n)7SM_+?OE%5w9B;bo zBpe8Y#5-St55PNLg73o}W)LT% zfj>M-e8<@rIiCR2@ROee>Cex?AdLs3#P5@0|G-OzgHe3k-}K{>3$&JbF4s`bgocHZ zV?J3b4pSxPzzW#e={*Li==}uulg7d0uVF398O)fPtQp$Sv6j=)Y($|;mREu41s{v4 zz$irlDIb?Y7Vrq<)Px)z`xvzemO}4`$4M~g$DtRcmjsRCE}Tfb*xc@yGp-6=0vnIH z)=)}&$RJj?# zr@^0y66AtPcf_?!6v__m5IP={P=}n*{apMDw>xG{79@b2Qer!v+owmlhsue9GQ%*V%R9 z6;^9{W=lo5vrV+E3xns0mmK%0mRL#3cg7j!J~iuH=n{hP=`cwAK{iSPKXn0uDHO8o z!cub>jH0v)@lkp}*c-m0t}d1(U}eym;_fYH&jpi)(?(DGLFlL9$QuIf(qpskK>E_p z1_vFZVovW?3^7;>9*i!?ao|P6ewrn|cSwh+JKXou@NUOJe;7>!SD2EKiK2hkdFUd> zZQ3iQ1Un%R8TQ3kC#11yQV>_WE+9~mAf;IG{H#m4UI|`OTF(SR@Jud|fh!IhM8Jw> z2BunYEccpWuOv()77)8aAeS{xQa`IgNjr}9s(DE?;B!)={!N8KFKop`PWe>GSJYC& zgz{{`YiytQ*WdS!LhCz-UL1^YY!N&Sk&JtxV8!w!*S7!6?kKuKPLO^IMXW=J^2?;BP@`=VMM zss|$dz6S+caJvW4>L56K3zE>#6^h}f90aC{? zUDPzO?a->GUKP(J1iZXb6C#ZYiYUeU8OWO`G{??b zq!8S3&eLWrivp32b8jLPE~GLrY?6Umj}>R9XoWREmhbgoE{Y`&+557mDm;Cym)Xb{I-ktZwwUuZ!1 z>>8K2*h7y_G|K#^I0}$c7hm_B| z=*94{+}KWgx=lSwP~Z%aO1u$;=?^Or-cF02o2?tI-Bu5O)pO%ot99*STZ`X)@3y|g z-~X}b*4p&Gj(1$~e1LI%*1Gw^8ytA8+vm!6TDP;{&`*=mp%*peS!=&tjh+2bl)(

K6)L-C=D_%BGpc(;gc@Cj$u$e%+mfP0odh*U`ylM zD>eSv)c9jlu;uiVrp9&Ln5xo(A|>@NXld+FKnETPY7Kh-wkf#P6p-mxB&dDR``M;o zuPGp>f0CfSg-kvsLG1$%uKh}aT7ybxG-?68x8k@%CJi60wI%wTU?)n|A_g2tNF~ ImHhbEzfoBJng9R* literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL b/internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..349997fbbe775f3f4325f2c9b1d0ab5288cf4e1a GIT binary patch literal 3994 zcmbVP+fN(m6`vX3x!Q!yvNRVbT(V+gV;e{ajaX0YF`h7<8D_=_v{I{-I13U1)deW|O4K)n9ar0qi=D)l9eS}C_J4{hJlx4!nF50(1Z{~-OHZ*1eFtEwu(Gv}P| z_B+?_%&y>@&uG!i+RgRll~OsnwzavwwHdv!R*r70ZIu^G(HoFQw-rmZcP=`L?M$nq z#&lk`vKhl%0HJ56Nt{zP#h$huOOXr2+wtPJlWlg(9*gDDwawD?sJ*p%{o3ub(bQx# zSNcJD>stACGV^gWIc-x!DRq2B@K@dLS|LuYh ziHO991R*R)V(meti*RND(owRSk&%SjPb=XO+kqNTDW>XX(HW^#!pZ37+InoIbgQ&N z#<(eAm)gBbFjv$wj%w(&J@Jn89ySbTm7J<8G1?c)b4ELM^ctq3OF=B~8$}0O`ap)V zs-^J7Qlz%$B?)k39r==`)G8jh0iu8@XJ+LY2!asAind~jwTgdR-&$GO5gu2C_g&pc zE9iGX@ApZ&S|yTt2lEET1m+>AVmqJ)0K~Km({lt&cZ;hsM#1(%79u6GFpW*7YHOJh zFG}6DJzs54s@<(N7CMT>j)4xrM=l1=`fbITn@n)pH<+1vK ziSdcXv;YX=`I=7J*2Y1$yQ&?7d=JI4F#%eVG3u@+v>{v3v!pg3CS!W9$QF$RD3E}; zzVEE!Wb#ekXW6N-6d&?9&H^Vo5Zg{}elpRV3^@xySJvPxd}0DSpN=V%xS%`gVvB2nfJB7I*{sV^ z0QhuGF31R<2CdchxauTk!)%BRvH^CQonldTlAU1312lJEs#SVYlQHCWY;v-Z(_;@R z=l{9=C|^kG6seJs+> zBEI*Ka}7iA9PWX#LGrY-U@G0Lm(0>zkY|zQNbr`R7g?_eg}p4~CNFDmiDcmsJ6;uz z0AU)nN5&6Gc@<*E0Yc(gNpV*3n-;d72Voa;AiUkEAMJEt%w8y5GPDljGlrf)Uh4RT zh1PB0IAj2LzVu@0<5kTMTMHj1I= zBX*q1UWmh{xb}kcYl=SO~4 zt%JhnC98YL1ip-B*h&E2=t9P+PP}miQLc7Ty>)=cbvG>hh()VXD7`2gq!*>I;1MwE zSR<=qC>e55bMUqu6-Ff;D9ZcYO#7yB78RscWd4So>8w*#ubqB6LE7xoBb=Ul{Z-@Q zNn5X<<#+R6q*wmgBE&432+!bkVAG>cJ46S`8Xl1)JQ5rAc-SW%FI!@#L~j#=L;qM?D{YFecg=9x>|Z4N3hWje5X7cU5pf>bnxQiBhz(YyMEdD)8fyG& ze~z5R$)+#&EiR)+!_`fXu|e@LS|rkfyT^MLsE^V$gc2T~QJlCbTgWEdc=jM0I?0CG z*^m@wqdt}pKXfZEUkEruRiOh=()~;QbfmzBfU-4J$p2!n^#I&zEeD7q`y5NYB;AIq zLZ}Iv4U@w4M!|;-dg-={Q|iSXBVISZfGShDuw5!IZ|q#$ENyH~FORNGFI_8NUtC+i z4Py2B^u}hnw6Vbl56L*1zU56EdZyY&0G>mOtGy9Xh=j#RSc-%_`FmfgJ@|X_L0*Jz zFV+3av%@d$&Mx(T=Q+yIlfR=j)fagqVP7QdkAwr-y)O%V(Q%CyeZT9V@IW`ZhX3#* zqid=EdtYnPt0#ZM!iW?y!VjW zs>c0sU-DtJ?XA)JfENS3^?{sf*-p$ZUgB*7+3~*Q;q&$+iNE(H*TD}Yf%8>QC%ffo z#~vNHV{E(bM|KSL6deuJpstB}C3dFM;|74|4z;CRjC0J-I_RL^vvqp?mVHXE-!zIz zhPYpW^J5e2MeHx#IS)C2pONIpnBY+~=QbBTUI80~&2SqS=mQ^A+UqFjx*g+letv?# ze&MC%zXsIyCe*1YJ4Vv4Anj^ZiU!VMw@wb7kMORAQxxzcRbi9@9$tpipDppLFn{ke z6?b16lK+Uge+X>EdzfHu4pV`W`Z>IxP^Q&edc#@}DQ^N9L&MjFLz(j7f6o-k5$aYp zrm4NL2pZb>MmtZjM{NDo7=2s%ja)OS(S#-6{fKG(Akcv~SpOifBRO_1!+!WNo4Ck! zCKWXHSn^ve(T5e(#rCq%2uQcLZDVmCi+L~C_B^Z?(hxP5mO7Jn zAZdIQ;PbM)zE-}rxxBUt_XYk)k3XGsOLQcWFg2O{Ht)pw)sAgC6Un0Gav`_T?MfyJ z>b#PT+q}iboJcZ>OG~D+4uxIGRHkTMQ4S^D$*~N+QfFF3ZOL(dT63##a>7!spa?f6 ziM72Tck}OXP+KCU8OE&LMAw!W%b|}x6m%rUsgO4(bR;HBe8jcz=QMmIHu=uPdA)V@ Sq*^d8xue2E3h+O_dGl|wmzB-{ literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT b/internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..c46dbeeedb19cf43f6c42cf1087597e8e9c38952 GIT binary patch literal 198815 zcmeFadvKh`ktg^;kb!X3(u@ltNwxCs< z6fq~;bnq-wD@wfIFSDw?`o4YvkmQj)ZjeA%ef3pkWo2bmW@Tk&QmH)$cHepX=>D;t zWBU&5562E1xb4u^@V3t%+_yX2H9EF4JUDvW=*~l$InkK|}};=jO|IPfwt; zhfipp#V7hON}z~6+f;ZYUkNManIgfS&lk`)_B;f}7v{?)U~+nPAzV0;U%=PO^ujc- z8cqZG>?vBBE6y)W7b{v~qKMaLFcL^=r+_{7q7wEN`=Pp2)fHFTlbp(IP^I-vGguyWt z6!30&b_=?_Q?MKBH`>WhSS+2Go1UGL)@Q@sN>Smj6bpPmeC#pcf9%9uF$A(X23sF{ zEIeE+m5;IN&zFye#R&jjJPrzFHGVS{4nhS3fU5B5*!02?3?Q&GBYj@bhLcTJw9S39 z6<{~q?FI$_01^4{j_G2dNU|EWZ4xX%#X%8p4;De5DC4~=gj4gTzQ~Sn=2fP@Sd0yg zKVqzWdLdt$E_eg4guvl0l@;HFi)leaqXEQgn8rF&Cc>i?!5dxzyqr6Q^2`jIOCm-) zX9}^A&tl@R3*l{~vZtTk(#IL$_{K3zzw$9m4Z?F|9s@g5K8l%i_~^m{3E51Q@C!$$ z3wMS2LII>nS`*kgs)UPxkiCQx^LbP_1zg=SJ#`fD4~Lbb0CXN$;|wUGX21S$^60FP zP^B-`+pAnM%zrGLl(+GBzC80WW=xa|N67&VC*6Hu|Jdl~#=@|-_uzp$_wNZaVR{Qv zdq;2k%;?y@-8;jKq<4d{j~)znfq~z)Z~rKYq)tURvfkSd>=`|{AGPD@?W244-FZ6}pIh&|ZRbJzcZ!jx2pUowbwy3t@JE`ndxxb=q+oT4cea0I}E!_2~JS9Y@VeuS(2SUQ~cS` zpd-=n4w~wE$lfZ#=_=7gHf$s1F_{%l<*cxhFr$M%BqSif$Ke|u=+6#u#%KD5(n#2$ zHq0k0EP$kGr)`gAzsS7ZEOh86Z+gC_)DTVPY?$dcnwthjIfExN!`j zk0TimFpHp67G#vk^bZg=S4aJ-iMSQv$6!ncC}r@I9?2Q}WQP;z@j&p=&;YdhAb?{h zu`@K(mmWzE$FXilGmaihKo&5Io~%~~_<|u6qTYMpU|t)7go54pC?gGf9R%JOXYhRh z(^n|iLz>H9F#v33trQ$XLj&kmPQlUqjOwi!BR9ps7<7t(9dHCO5}0CKt$kvNYKjk( zpI@Jf>JU*hJwN~!|1k)+q zl|`no{E7_f%RrPpZ!c3a!`2#7bp_HFHqH>8u`fOWndn&gXo>sgyR?Yxs8Qf>QTEew z^Rm;%yAbzy%63_k+zU8g@^O= zuIUc6+LjI)|3HWpI3OL*Ru-T@5M70KLj@4KV;1!2E&(Dg8(Ua=9@STcI8S6+i}4Xk@Te_!2UhNl?(y*@fwnw6fMgP?3^2HQ=s7E+xMFNqQ9AHyq8MFHdC227Qir6fhjXUI3VbX>_Hd_i;+-0 zG0Scexj7`*BCMcfswdl*UC2v=*^>k>89x|MLcxP>)>F28Xs=X__AGJRh%?67&$=1!_e;E%?jag z!-2PgjX_=}bero#pWb)-&Ra(h?D|v~eyKOL>vnwWyLEKzmi@UchTDFGEDv0_ZIQe; z`8$*x`90Tn!#`dOzMlEWKUxfiKk||HE(U)kzcpt;p87R>nYfVNVT(+7!+!alQ%OYR zgkFv&Fr%a15b%0%|D)ierU!)E|GXcGVf-)Q|KFfX-@@Nb_ z|JiTpJMshmA2bI~6Wa!@H4J1BJAh^lqEoQ~6hnWahwio3d0U}W^L85xL3 z=n6P3kJRc-p`Hv9cN`^SbW6Of@0dj?Gn4qpG65{svgRKy_N{Ir)zt$j^_zK=$%@)T zCJXSW{WtRn+gUru%sj#dCr6b5wmdI>XoG3#*&fTiw#iQmKsP9S5I19pI z8h67~-cMnM&G9$~rz)ld8=J&dSajwnB6ER@w)9+&jiPtA3dEc$axx>6L*6LQmeAmd z@aU|xK~&(~$?5qD<%Pr?(ZdEFyxmHGDt(v@#Iv^62%@NMh&Up>5FZv^66{PKG7%~% z<>z@!I9onCg)_NwGTGM3K?T~A>0LQJpFX)^JeR6rbR?yp|A;@eH5pr zXJ^@U%w2;?BMQV1s|dG{(UE*<(w^!Ft|9^jm}5zL^hp+Df>RDmRKo-luTx$$^Fu{Q z*?}uZHSzhhGB*nvB^U03-uwZb#V zh63uU_WU1*N~kU9k`1~3UMJtZ-^bToy7IN)YwO>8{oY{Py7yk64)(}z&H17{H8tp4 z>!pUyMgHlm%I{_QeMx>V@^?oSzk=)KcQDTH=671Y>+f#)&fh7DKAE(Lwz_?XCJwt- zo^Szmb;N*GVqpWY(0P^Zy(jtm_+j&iYFUp^) z{9cydYwo(pe3W+d6bsUjZr>aBT-3}&l#zU_f|=qj1^q$Q3|JL^M$1v?b%JkPYb+HG z@OPrdoE(eVDltI)u?&*5%GUMTKwWx@!(v7~!C^FQ81;l}VgSRL+ykR2_JFbx^XVs0U)eA>FK51Q*Zqh=fSZA}4=OXWBF1HTe`m5W9 z3G8nciW4X#dJ}GWBH`5E4t~TRdt$GnkYrXw1s3Q1dj3U7YeuY-#nv| z1kZBNsDMG&Z~)O8u}A_>R&k_@m{S--ck5}4Yi;DHBob<^djwxc;acwmK7(^b7%iy| zXi%+#0HUu_MH0OceX;@E(rQLlUpuETV^^`bpsI*a`^X$pwR24BTk8~)!Kh^osR&Ag z@U=rtbFW&$XMHJArrXsDn!to2(A(=JcRa zL-+bfm$pp0&LgGz5m^g-nui)O!%T9{ez8HyWUy+g7Lh2T;Iv0(c56FJCpR6!3k9Q7 zwL)0Mvw#$oh)hJQR%fXQE8U4=r7%Bzm@3G_JU7D-5als5)z!&yM!grQ!IV#hcNHmd zd)*TS!=9t_6kaK5z}Am4pi`t7^(h~79~0?7XlzL!4?{|+%+VsXch{jUY=8olX^sT| z!`;)c<%xKwT9z6+`z>N6N{H^5!%aKs31lxE0aVaZAB_u& znJofexgwelnx_kxQojr`8Y9eoq!EJv0R9zo+GAPG7w5;?JL%`O`m@^qJCUUVQl6?4z?^dPdTy{UZM3^SVvH ztm$h=k9)8Ou!BK*+^9?NWJT$zv*)VoZ@BrzWmCRXnpxcNWNr{z5_uoCF2SbuczXTj z+z^xw=K0KGJIdSkN~KcOe;@UaumA9qIa@!<*^j($6ZpH5bQR@Pm!##9ZaXPi$Yh=54y(P^Z5Iy zKX_%T+IjQj@QUCE`0i7$zojo!<@qvx^LgnElWEB89g-f8r#pZAi}R1(eD6K&FP}fZ zi1J;fGu;;p1@xgb$?{BJh^IGSxG(;^dpw@@%XhwVX8oy~3!B;=JXc`-1jc>Vm`*JQ z!5k|w?=xKu+Uuup`109@9=*Bk^2;w*rF?F(^t~re2TOxFEk8Ut{=Fw2kJ2|xPJQng zFWrgqkEf&O^1k;Rx?vBl8F28=I{mPXy_Yq&+9o>@~+q>G^ zPQKVh_`BD4mzZwvh|=wnzO2vRyZK!EFo)(Jro^O2lp+{roPk!%-Meq5B#qT{Hd;VY|oh+Y7cfULnt6%E!>R)x*cF^L- zcF?A62Q}UO{I^U8P5Q!f20)iK9dv2aL6=UJkEPdNxL`V{#ueO@L|^AxhC7H z_&XS-C3jOIE$~*sJW=?pl)(Gdt~Ao!=lpaKbn6ZW&(A-4PjKP<&CeHD0O7%KiY3ZY;U*CSO>7%B(ebGK@`i!L6M?cLz z`f2vjPXk9cnDq97>7%B()6hPeG;pbXH0hi1oS$Kn))ao*G%9GPg`%XZNPt?|C7Z@q z=_1qExh%IAw!Qx4ljix-V7k39S;)lFbA|Ld|M|8;`huTcS4e-(Pfr%o$4$C|`nPYp z2}Eq*>yQp2;nM2>P}}2C8p$A7wrNSpFTl%g;DbN9A4&(Z)M0(s{gz3C`q62W-@f_g z*Dn7g7|fl2>OvLi%oC>y8*{!ubE_Sy)@nq&yEd6gYrzYL=D=42iRdVT|?TH67r?$GZ zzQ0Y=Qvajh{_v@8rWH`YhY1p;JDGhUN;8Qqv@0)Z!i!B(&^|7^vyS0-dTHFI1Nl@X zedW^6E|JC@EZ6_`G`;f$u2m-45WzH<5XQhB*!>G)C} z+v@y7r*3L5m4c3?O-tjFj@}=?gy&aY`Pt>tRJG&Y<9CmbNAPwK1TW3m)b6GExUHIQ zDSxw^|M3iZ^`>%0RK#I+5SLDIvLWXyi4#Ps+iTBHaDfmSW~f^1&ES+Zxra6yHyo** zD^E`1V$B4+Ccw!76_{4lYW+A=BK3K#w!_`n#OaPbBTm&jO%b!%P)(Dwax59Mz^6u> z+HkpWnjMy}JT3MNYvcMrYoa#x_gwRLXeJNE?>uaJXQ3RwjfQ_VfdM^)i%xtJ5?y^M zzp$#!oGK7QZ+vtZTS|KfFbf2S71Ih`Yk+XPW>!^=*d@-3gAUXZ15WFK7I9`yRnMfy zyts{^e%`?;x;)%nC@&O0sTP9b?t|_nc;QLafY21{IYidEb-7M0Nrhw?r=!!e zz}^X1NM{KGvMc#te+Ht_+f*r^qn1B|<7Y04)vLmc7Ij}Ffu-1`Uc zZC>YG@^FD=W;wW~F7>3N$3ZlVFVAlcRjrTtMj~capd39+2&HBvQ*DHng>o{fS0IFy z*jXdTL~L*dmo|Bg^0CKg^RG>Ql2*}jI$%yD^l*~Jjq@g*d$^5-EH%Tmr!|M+Rs|lC zV1y0pSmGzLVl-XLd+0gAIWocG=G+RE`PVwNJJPV}32n#?*YN8h3lekmyYthfJWP2l z7nO-(5NfdzJ9Xjh5Q_v>pi|jHwGtHN9 ztHX>_#9(-u#B%JD{Dt+qUHohPnopfSb}L9E^{w zYBt=n@6a8$?fm>L2lkKc*>`Ys_t=4h`$iARkdS{bkimh9&>$RB9bG8$P^uT)S)1pb z2;5`@|3l^A<#JOMO;>Q&024^>A4nbGk+bk|grnp6K5Xw$gE^Ar?S|P;@D>56z|gBZ znuVLFX}qbIX5saU?4I`$%u0y`P~c$4CyJAKtPzqyw@WyhHItg;)r5!djt;cr=dGNi ztbSod>p&^^|WyqFaqs@#>mG+S_;^T`>WMvs+hXmp&*) z87?_io{P%vD#NMNOq9M|uU@;tAgf(@OcA=0GMQv~;x@`y4;aU9W_JR2mo93?)r1g82|lHsKW&}7vr za6l3Ylm`>NO^JnR(nQYMLT9aQsPW7N6w-XwGw1YNPtiEe8oI_C>96aWi)L1+Fhg4{ zc0AQ@Wn#@@p4yDAs1dbhZP*igjWi_^J841swwgv7T%pZSgqNNWZPJq-G8CG~nJJ$f z%0@Tk8`Bs(_i#Kj{W`4j8@@iYJrT-b!YM^moR>$wC3h>}Ne6_zN4T92J8YPZVxzHx zH|iJ~11~PQ!V$68G&XrL$c0u@;VK~)3vLdib^X<2Ijs-91HPG4tLETm2E=YYtA6Or z4P?^+a56Bf*x01ZDEOF6jEvtOGvn#9UT2#(!1~e@zFhJ3Sq5 z`z+Z3AAYz;BKNB8fV<)ljR982l|t`Z`x5w6Blarxn+AIIduAy=XVg~BpicsyvK|im z#RxP`L9(2$wF3@*%aVmr_QJOViNn&5PGmzra2h7hnsxwux-JWic$vkAW1(5Y09M69 zn>XTID7r>8hg@S7e7bofZpCqp)aJ+%ghnkVPo^7lc3F^>n{l<`VnOJ8>35OKQDXIQ z1R|>>OGY`vT(zREd)I{I22%Znux=Z6^`MIgX~SKekes@008kq1E683y8qCv-<&_!R zNY5Rm{E28;YOFp^WylQ5rez{&YYa=;Ha&oPZ+sCGpB-RF+ zps8tt$?izeP4*~f<^9lZq#Cx7>__D2a#j7%Zlvllt!S>>@rZI(+YfewzEhHnF~f>v z%WL^bM!X)adOXZ&mtfF%R2Dl(W`0xLUIN zwvC9p+cu({x6lTfNO^78DPpCjfB+rN~zFlo(9B8{wapOK2@Tr;RvyUSo*K$CIy9@}QL+$lygv>8OZlKZjN+gGg^Y*T=1 z091YXz;Rf#Vra@`$>O{AIc}%8n;LW@Crr#u4d&FBK$4rQrhBW10Bs*qF6(XTgySIs zG8nP25V>voHgzJRSKA4flX{yv;h3%MgyXf6A!D<;_0{roJJu12+fKL~*N0kn{Hq%5 zeygjrop6g%d?4V%UZG>{4O&Pt+9aQ~O(gi4DiQ1YmT$>u)xoB!6C2FbI8@m0TW6ud z4zZ3k1bH4sEsxRygTtheb+oRYfkdr6Ykt*yZeciP;% z%0Ln=H;PZdC;*jbC=qp}W|tNP$e}YF+mZSQbwYk7f{ctae4&$wIA9!^hOUOAGaeOq z84O2{iRaXtGm>y0anA)SGyQ6D z{2#gZ_72i3N2YOxjywJ^cyRZRBOmc%fPjPMx}yuqhEasZ3}Zn?MvH9Zcre}Q=>JZ4 zZ68ynP@G_ZrpRSNJ!c7Y?MUldwYoZV^e`<4DqCUDWUOxpfE>LWvzUqlh1QPdlpfy* zu61<}%Nd{ov@FgMU=)JO`LwCBF79B;D6`iO6r}*LHHSJ>FoyK1Y#CUA*qt#LR(J>| zRAeh-bZZ`6-?r_?ZFTg5Ivmdl5H!9LyA)cTARZX}Ht0S1$f>Qd`{Af_cwBAPmnMNX z2txBS`3Y1F4|=p}f#H&|nL3KA@HT{>bQndANrKo>m1kjeGfn$BnghXRMy#mF>V!&Y zA8O6JKr}S7RBJo2>V*GWqQQ2^`iS75!&N3AplOVdx5gNxSttt^@^ksa)1_%xYl7=c z&cle&xU~?w2sMW|;qs!8Zc>&gXWy+Ml>k~fIyYCIhXICoB4sCO4oqtyp)Mc+Z;@VT zh-rXe^aGTH8&AaY^Gd46K%mwd0@E=dV*M3?IJnVZOaqTuim9BTeQk!oNvp^ezvpb_ z@O=3$m^XiIlU7Wi{5y zPFv^O6VhAW{RdEZNi41^bBKM2Nd!~?E2snyF_meZB?fB>AHbml28oBrw~rLXGA9B+ z@PycVtj+kUg)Q*{CcX-cp!JE(lP2h9q(%6n#t z#-Ns0U>XWmB=G5$o`eak!bvo?Dbi)1d$WsVMCC%^C>#Yv(Ol~SeT%6&0V}7A36_@0 z8iPOy_G%o^tHcw)Q}Im0>DH>mY(uGKL9^@kHM6q%3vI*q?@g1yP(^ zbchuqkUM4J&PaqXutl7)ffdCo{4cBWdsvASSZg) zN6CG>&dX9uv~UV}eHU?Ym3nHr7lgE$$>d<1Xga8QjGs4b5usVbBhaz1P`t+yi^CB> zKm6MasFZ2MOpL#X)xJ!u1OQqg`KkvyMA_hYYaZ~WV>Se=nPSKqq}1InS#camgj<~< zU+O(Lx^vI2ePg%pykiUQ8v^mEp1nKv?&$fY{n_&6*Z@hN0l3Fy(C@6(7P&d;I4!vD zs7CHcFxY4WQng&Mo}RJ35=KluP27_K;c&j91>(QhyNF^yO-wT4*DwlyGNyaJ#+%Bf zVt?d4%nEB1Q`aEti(oI#>nIvx`_CQ4N_?^HG{F-@JYJYypfF{&4zgW>Ds8*UyyjAp zESk<=8<)jHdN+nUja}dq{41|g62@b0nS_CwyGk+X%9Go~0iNBrN=32lH1W8X{@Gjz zG`p>$3&g0qY~BQ?Q|F5+_dr-^EC=dULC58d=o8)e^DkvdxN^N?l?e8x;-i$sb+mAb z0aYLp5Fp;t!LR@uNocq+k$t9Zofo4_@fhB*zhO;K{>U{rqXe>>Yt+17u84{XL8Avn z8YOwr=!uA}C^(#L$=rxQHL+o6Bt9gF`W=;OKtq`~oFd#M>(IHdeIQu3L_^_-OXv@$-Ahw2WPN$pIOA%HVx8So9EQX_^Vz&m3QL3n| z1p!;2rGp?XngK(H1m4UY*?7)kl$^iN+D28a5v$0)Z39M7CWS(wT$)DYi&&713U&gZ zGYT^%a6F1?8{BV4U8@&w#8&{AtBMJ)mbH=yDG5Rjq<;v75EksD*64u-19om0hoX@* zq(KI6gld$~%@h}ol%Zp3uB(*RM%DKtBhe&4Y%a7U2;Xo@gR8of;{j`EQ@W=nS5dbq*Z`< z6#8Ou9zkj8=9aC;JLu>iY)>B>{|SOY%Sp`2$eW-hY?DT=h58YA1qfzs1p6`i0?-zl zRgOlmlS-FkW!@Ln#S1q*solf9R;wM52I06BlqMSl0xr`{9#jw@wPcP6PhdfZl5$cy zh|(;H_C7&H4noxB=W(&tEOP&2P*&9)RdCT~SrmCun%|a1S?9Ytf&Y{h=bfddFSt%$ zU*3VgPL5M=-Cs5 zx9nYHx!?Nw%{zjxe4_e+o5zB1&jFJcBJZQY2SVoUmHK|`8$COM|KX!MKG4(4JeE8A zR}XC35gh)*lJSHkgc{Oqf)7+_}J9p4Cc#NOTem7cxd_~1u(xq{=tvtR$prafPO z;mlXOysG-S`5_#Rw(+8Qs`!1WO1Dr_ zUo3B2^Q!C+KWUV^S7E72hUCdNw!u7!q?G129S?rnu!vv3oV?-S<_JCm%W>N`!Xlq^ z^>fHeTbNDWh2Wmx=0x5pi)RlnSApkRT-A<8y>XMK665iAm3OrcU3J<13Q+P3V_v^+ zN%~8p+~!2zn3tr<@jCU5*Ma5l3NQ8B-3I57iMfw{)X8f z7Q!Ljs@Qk#(4)rfaI7>v17||8-Y{Ac3T+rA3N*m+6s?hR{geqXj!uxQ7|&Y?GScHr zqFbd*b=`aQ zoqPceK#5iV1;Z`u>y!qit2lC(`Ql(HLyku#!K8~bqH}*-!Zj)a4i-EIf&3+`N)cnM znn>3}5%*AmQ*Wuft3serEP$q9WP?b*3n8=(qzsbWF;WBSnHS}0V&uer306#iPG<8w z*#hK0ya$*tZ)bqgGWBW@L2W+-S*G{S+t=sC>yarnA=0PRIt{N=5Fo*-Kv+>dF3SsX z3#KwPO&3TAVuQ1CFejix` zX8zd^zVODy*}JcP;lDNQy?!5?cmokrP#)i|GRZWaU+;GsF@lipeBI`0IyeJKk)Cmh zEtaoI|Ljud`A7aDdcLu{z5BUS@$`A`{f$@JH!u0=pdBF^;^qDKH(Y8v{|HVjn9{&U^`MCX&Y?E zrfskto3_DrkiPz0{Qc{XFGaz2MpjRcmfs1>0l#^tKjMozqc<{b$_2dVwdHU@|Ts4imUcMowRF!iBE5@UTZLs ziPiKaVb>s+oF&SqdRfY(T|h?K2_+82>Ketp#j`N)+QP5KVVG{}Wm{?&eCzIUMj=}O8n`M5LnUxe9GXwr!7A1|KCg*yl*D5E*{S9w*hm5yCgmI^nn&43w zzsbquR-BMBBw^FggaTk*tdotQ0<3zqU64@o(`%1Z93hB#G6)66WAV>B;a;-#7FO!E zefvk@rj0z1){HbhQvJO60aCqXnH>_hdp=K{tqtB%Jb)+ z+BoyzE5Gyn>HqX6TK@FKnP-0dU!Fhx!yiieh137d7tX#kbl|Dqd0x_}{m1x^&l@&< zS<}~$<_;$M@I(avI&990(zzF38t;5~^A|2@pbbPU8LW0a_sF-f+m`nS2Zt8dwZ+q& z4?ps)EAIJVwGHLbs3|`Bj4?+;?<%$BQ=huD5P zo^F5j^_R~-x?SVu;d#ek{^ZOPPn?oCcqUy!tQIf*@GIM6>62Y)#6)47y*lOFU(G*w zZgb|F5;u?S`=2$YJE{n|!+Om7Oph~EOTF~^n_pZy|7h^q<;%GiqXOV4}hc9!psp3D2*bCf@Q{#1~^+^zK!F8f(S|GL`Ozwp`{SKF@M zlYgd)_q*D=a;f_tXj@$R!UKf2tMlX_)AxThO1DY+gg(Fi;g{N8yV~~JS53O>+~DuX z^BH}<{+xN=r14zqo6_gqrQC<5Jx#B_P|E!H4YYqxL7v;L$=@~fkMH3KSEO^nKLlIM zN1R?FPwUe(l9E3D+NJfN&)_m*Kk@nZPF6cWk8R)TSd#P$CVi$$(t~Jq>k2xmQh|BDs~S%W#j=2Tp1Qnre$h*JElpmi`swQA1tx9zt}`#i)5-G5bmerc zeyPi=Z`EnrL5m;TL7TQ6)O1(*d!~aXT`Cy>UD|ZerA-H2I$1uJ?tG$^#dLb;CmM5udSh6S`NLVtY+h2Sc>z@frhBRVU=DIJMuw+bkAblYil(1w>cfOk2 zjI@L$lky$8?(Sev!jjqd@m#`^A>IDsOBpN=8kP)c(-;2L^;k2O@n>VAzv~idp`URu z&vA))h&NE*ct^3nEy|lzU)O7hJJeQb<<~i!u zn1^0@iFv5$sik!$=AowXoA3n!fcCeoiu54<`~6`YFF(zsNw+NmJLBx5d4CZh)})V` z#%OkiR*Yu@GILFiR-B8Jhw9v*U?Y2kNUnoXIw`=%|4p+qfdNO`>1K| zG_;Qk+RZ+`f}O|Lz&xZ$-Ip1Xe$X@QRL5bIHT4(XJa zX0c9`vgMiPTS$+Omx7=wkvaV|BXeqbKF4>cLy>O($<)iQTrrV3na&|>`biU+(@RTa zPMf}JB6HgGqKV9D)B64mQh!eB*T|fB&ZhCH;(wQc2VcQ77@0GAjwH6w@wC8O1zsMP z-5CN`;(3%t;7XHT#LK{gq^}-7{@PP7E^FXQJYPEZy@#NvZkNE7On1GYX$G!j`koVS zoF2M_@(5fhA|4Az`&L9_tVFbzIylZ*G}h5;7X*WX@O7Xh)u6Ue%s^Gb1Amm z-BLdNGNfenkrs**8|V_$Ex&Om8B@KAV=zd~L%8yn@gqRglebYy#BFLQjJTcVMM=30 zXykOd&(W)bDx2#~LAW-SSKY-lsFs|rhR50Pyu$mD$HcJ$^>@@eFvnb|F$TrV;Zx`) z`l6d_Mm@4NuU%=;K$sh|X}vOw-|U}JS^G+07u6u6eyoPXf1%N0*w+;8gHo3|w~std zqgrzbm*XHvqdJFQ1f_lH9Iia3nxQmfqIf7udFPLB_B2E(4)i^Yrh4@9znB=*;L!Kq zzfxb;8AYLb$;Dkv>34)E<4;Sq=W=-!6loA_;w|t>Ev}pjWv(1m)RUzoM5WdE9Jph2 z|L!{veg;~!UNZ-v;u5E+$kFhTeui`MgiFIC_z;g0EP$S$Ftl<_H0AvICL9#YAqH@7 z#!nA5VuMKtR{&s!V<{mB1(d-yOBB6hM1XJ%Z2W zSR7_Bd~yX_;1lcpXzRA`&dsKYiy-RY$pR*A-wlgXgbS>+-uc!?Ys z9W07*o8E<$GZEv$fqMDB@8=Ud5r{6wVxEHUaXk$#i16GKc5{@(j(=TuJ$>F=KN! zpYF0xeG5$Q0HXO-IWf%SIbtgpFn`}EgM_f^lPhx==~*l40n#r!=$hZ2lBe*1$i0<+ zm$Nk_@w5eOLYE@MXLak140G6!J&0LyOwSd$72( zPCoEmy>U4>Xy6uA3R^ob5}gMG%gdRPb>PJewfGg2X&l_y{R(c-)^;u)($1?Gw+j6# zOL^E3OO3=0JxN71t8)seyf2K$#A{rkdNi?^HmPI-NAjgf`Umu}!<)cFj@K$J5qITb zgh(TC6NRgB%ZF`AdrAH60>W9Pa|}3hXe(<&?@D?Xeeif;cgbSLP&hh_2UhvE-0=s8 z<#*1d=7+CheQq0S7~_{m_E}jFcTP;mrB$Kcya{tjSZ*)VQe3^|*+a@uZ9nBoDF+@L z+OU624;p+HrsoSKe&MLVdi-wrPG@fP2?$$QPz*Q;Aoy+A0{(XJfgoHA0=ea&6F23Vs+cwb&(u6T1L&3F ztu5vR9jmcJxAK)ey2;Qx8FJB{kD{9nDkpQSWxv81hd{)ZFVGopt)NPQd z$O0Pgn759~oCAkgkuX1H@BG%eZjk_j5bD$eD5xABQAo(v7P_(kzaa(QSaFUhl9W}gsl;Gd!ZM3tJ4;I&7Dh&L{x|0jG;r^2S6BKuQ!0OUMsWk)Ji1bF(!{}M1|vE_TLR(l*ko#vtUShY%j&o zep)T-&HM%lzzr$m{A!czInD9eG}u-d4-8@CrKJdJ>G@&ab8z#}Oh9)z-E>ATc+*{s zq9sBGyv)G)Ufy`cbmSQ0a3Ftp`0(yg*ijb)uez>tO<#-;L+OgLcm+_Pz=izodqdjOw~c7IQfEav{oS2K&Xl-i6-k=FGsuY{MNm@fAP_xASI~S)rdtcV8E@{^sk@~=d8_%zX2by_W~Tln{#J~+ zc*k0dZH@sFso*kE_S_^{0gySPi59`xRSgTzG1#&|nv zUKoIc>5}(rhsG9?GNQ(085^)9Lk`qxu9&GJ@eLdCm>i8bjpxqQ@tB;3fRHFh;Qy`3 zP{9!@OmstNUPJPd*BIp4P#HEv8g<{oWqRzD@Ii2zv17P?==oU0=4%$R6*j!wFjeGu zi*A3+ahEj`KLRh|C3*@kPSl*nv^vqMXI`68^3%}jSzRB*z80e<(f4p5qH|mn<=`+v zHU=lDUYTjKBIl&P5~54vGyt07N9mX0=kZ*IC_Om5s}=*&DeN^Lg>3KC{*APLI0a z4sQpLkR;(59{%!q{Sy~+p%a4w3;yO)bn-2@xV;R8oGLwPZ@ybE{dUI~5Y+ETB+2 zN~wm}rJ7Yek$Kl*@j_DC<&IunAZh7a5lDoC%KiwBmQ4y8wc$hXL13;_J2|Fd^EK~D z2a*!DsAQddjowc}K*In+lK{bY8eR{#C_k> zR*V>t8ln)#9lF=JRAermP(UlsmQLvXa}fSS8R9in( z8%m7H(xT78)%At>qqww9R}uCmzRVv0Y(#DP@|0QR=GEaMv{6)I$z5}1*U=U<&ZU)`|^IfxrT4K6qX*#GmY~|Xi>p*D9v*u=(b^E8d`y)`I2-Hn4ZFD zBjm#gI>WG1zd~$PP+lkr6`lbvG`JuXr<`npqMK~Rb@c=!X;IXnuGVb z3e~BqClZe8l=2ugJ$6eO>agc-k=_z*g9v4uKJq<;Fyul z8UO-$G6;kU9xP-oJCbTT8D)Y+T=^|A|J}Mmk*RyL`Ylx%?@1kw4+0oNrwxG!@3lBD z+x6DyMmNo+yT`kBTwm>2yzc(%7O$&z?6`isE8V?`x>1gPEA^~BZrLxnFjR#x+Swy)6i7Y{(XW69&Sf#Vlyl>-__a}M%)qVVG)MX zKcO)cC`T_g(2U`@JXyyGfZra4?+|{!iE3P~In)^jcmgwG( zXf?1Ltp>}%rQpiTSI@lp=a)Wu;iISiyz5NY%OpK?qt1k((m(E{c^=D(?7IxhCE+Mv z#oR;xQIBf;g%=}4LF8VU9>FcGczYOe5?)Kpz$2?j_+1u)u2qJk)#$j!uUi%&t5o)2 zr#n#$p(hw|$mxh#sxqr+ZA08haFm7XpaP7$YSc06)SlP&qjo+?9}*l!*E6)Op2693 zH_@fRDDct(ykuj4MW$jl3vSi56Klv!teT)FGDUv%;+??$Q;eL9tgJehoXVXk)eor( zi{B|<8~roYv{wI2m0H+aH_XD0TlX`}!p^-r_u|j49Xs~m&z>DSc13^o?%1&tsTKUe zdn{>QHwiZ+^RwZX~Da6uGaz^bFj zgE+u!q7Z0do~inPRA}N$s^(A4dP51o5N4?DgR+k@KTxiBajDPXja(T9UmbuF(02_C z8kIq8h*L%}De4xr^0h%w6IxTNF>RrUREDy?FIn`wKT7j4MN#JP-%@yW3xWt?7H zD?C}!OneTrZH*K$(GK5QYPbl0)`UZ%WSPCTS+7SU7xpj%v@#f+ep6RrqbB0`7JQ$I z2<&+kFwEXk88V5ndeLJ|bV6h@!f7@bSmtD165i0rp~A4PT2>A5EE%=X$^T3DTi34rWXDhbc6Q;-;}389?&8ls50_g{!ME0qpa0&> zt8b2+-uRR1>wgM2TYqu-^;vv_gRS3vc+<n&he@U>sz{DpWfr%#Up$S1P#C8Qg0VPMmb#P zwcpaBXJuaQ%=zyDG59t(St4TaEj`s`zU5v#XTA-Nzhb^k+H&j9Jb7*gh_MiK*>6CM z&ASrp&~d}>D(|i6B>`Pc^sw&&}BhmC;Q7UxG_s3iZy;oAz7%Rph=$6 z;1*-1O!*((v}#ukL`46froi@il@>AE| zyiZf#|Ng}vpZ>od0(arFzd3#JyQlws**yDC5B%|uPs7oNKKsEl$Gp^!&NB6|dB)1G zU9%-M^=RxF@}vcQCaGtyw7H*-;Mv7C_mfPWS!{Pd9dHha8|~&NnK}>CH~Z5O{3y7= z{d@>lB8T12AY{^U_cIw2iI&_qZhEg-|DFx*cRvpVXRdtJ{X7u-sOwGl^J?&&>!Y8g;5*-$a6gm5cg|h!emW3A z7X@e!*++tfj26!rui7_oJ#nldT!iRjsfCO;IMxN_<06)8D5IT(EJp+~Sq;CqwX zCW9AFZm_BD$>7Av*B)X-f@*Nzw)=t)qvWEbIwm{3_n10y@)c93PfJNS{b$X_FY#X2 z4ME5H08p@>)lIoz9qw?O)IEjZX6&O(s%v}_&LX#6J$~;!DA{%IWXJYka_QXC5>th3 z9ht?sr7n}|MrzyAJxg!8XX{Y1Dyd04bMM_e*|9m;wsg1D8FhiMG)b+Ze?i*=L2&m) zR>nHpmasXDrK%U)vzP8^d-dYI@M0n*Us^)RLcyd?H%Wav_AH+I<~^*%)M>iZu63G} zX~Cp!=Cfw~q@SjvH`{cw0kW8h~?j9#i8S zf<_FKK3BORG%-t4^-MHibRxdmxUYlSrN#vsrEqEr)IKsR@ia5s6h~$lJT{{uGA0-E z>Kdd?_0|XLa~4nu+lr#}>X$fhgO6&Sj`@{|Mq6Z7=Zu?=aZZ-lWkR{GLE}TH)fqHe zQ3e=zQ?4Ea-eGJ1@&53TyoB90>(2}xM{HHiGTT_);8HPdUXS-hs9~V zJEZqD?K~ubeK=gyyT`FJeDo^9^zRuHcb$ z#Na9Flwy_VZK~ZD+G1=0rWo@0_@s&fOpxpkn8Y*LYu;vT@1& zAoyc*9Aw3UMZ>G)56*}9iRVcQE2H<()JpQ!^$cH0mis`@`@_GBymgy~YuddYy-LCY zmR^&`&L_*QFs~j?>*TSv=(Al*c)zbEd}Hv@)!>tVgirJuzI6oycjA-C`%Ssu;DxmD zuA_rR5GunJLfR&L);|n$^z)m%-{6Im@b0IBVS>4c|G%MUV#0jh{p0oPB}enZdo z@$wsb`PIZrJ$l~m?XdN0{e8COX086(IEpx@!+HA{#6KhZssK-?6y_L?q9F{aG>A3s z&%>q<^6pl#4Tzi|h;=lzGZJN*ffA{;P>qH?_J8_m)Vf=Z5m;+e=LVkBi95=r6H|=K zM&Z%(JK-I?8Da4sVD)Y5>|74kKfD}#_y^0u@N3mzuCf>`!_(v(eEAJ`E(V+0@H`kt z^rz*Z9sg?$Bi3p|_>Nob*0VqqlU-cTfWpjbC*~AkP0i@!?!IRrkyj1IRv1H3eZ|O; zR>P1FLxbO@ma8BnSE`!7O_*bA&dNYzAd%y(e}ONHf3Q6-;Y*XRcqyF0UHHv6Q{MDoW;XM8ICv)m6Dc z8LG2Sv28HG#jutl2&$`R!vbs^diKY=TWi3x&?#I=+dz58Hw{eHx!tY1ayiazz>Tl|oIcnk5;%qr4*K z!V@jITQ1;a>=k8?xioatkkd>2D+W*w!Hmha-U?nZgl-<^gv*gFfqB#)V_f`pl&IId zHMY;{?s*#=HonN8B3=77*jMM2BZ5({{R@b)X2=p~@EBj}1o!F>)_M<6V>U}N z=%yPVp&?|r5@x`V6dAx+Hik(jLb4kk zzPzO%jxUGflwgIg#HScD#P>50nBkc=i@3McAp^^}<8IkMc;K=hcAD6oOoYRRD9jlj zKkC?eRqQX7Qy)KaiY-n;OC-YSUQ(K9e)ht-%RLPVG)xE_C8T+3u}$oRhd_ z$9QuB1H{>3=7semVSVq|`x4GV6|S=DT_CahbUnRI$QCQTE|RL_&byv*g6>EL#AUqV zUT=$tpKJ8i+z^mr@TH92WoY2)nI?Q*?P+;;n0^&bSlKWEc&{4n^CpawkKhyRM!d#T zZF5DSRUALL7-voRw?6h5WFnlIZ=t~MX%VdC<%#yY#qncOu!n#Lfhv#xy!dz*u3Sq@ zOK# z*&wkYHT6*yvXe*Fv*7{OFCZswSQzp6gTecPHfr6{ID(yPhuvmd7553ve|$gQz8Gw~ zycn#%hDZYl)M4=(dED-{=3 zB=*O4X}VIjl=>-=+Ku=M#s0NO{VBHtqPXP*g=S*EUB)eRO{M5dJGFBM%x>QAjsAXKs6+n2A_%5B_B%R^3q(x;lx9>Tu?E#iOQG6q%tlio~z+&5Xpat_u8Hs2H?fAq3g-0S{z19wFd%XutK0NtVLL{h~}pzpT@b ze(N*Co?W>TPG9AU=(fSHC6yszOU1SxM^LV9p*1OEp~-NAAPgbF*}`5K&R!UckHWWw z^iBho;e9(*ZK0@lS|0&}HVf@$WD9}dZ~gs)8ErY+2ant)AMv_!{R1EtfBCNGp1NO@ zM4@iRSEX0$*V4Kf_qk^4<0FeC88RP29x|Fyj&{1ttmFR~dk-!MP27<8Ym_?mZ|g%? zJL@gx6<>}(#EDD{hjk##!IKFfYT7fRw&ir&KMaPm~LuC8*;;SjC8XGwgYKx z_1m=syKaHVlm$|qL97ADP~-A7-;iU&9upfPAaw<4F>O|Q=vo^AA@_D2x>7CAF31M3 zKh2wkGC1!FwLHSuB=qsP7dGeA{#FaQ4^G~Sv&H#*i9VK%n>Tl}47yn4IFn8YuSQwWRl9{ORlF+XP>$(t}PyGd`3;W`~(%FDevd_6&pzgAqCDXXU+F-F5= z8beiwiwHBtxL(jKBbv_qtOjzTN;>YlD?d3&*RH6N&7+IZ`r{q(UkYzQaP|e|{=_s& z&C_$M+2rxSKn_dr9s@#^aSQ^dL2!A=KsxReAl%JPPc%CQ_=mJY2VlOoHjTCF7XFccF0L9!n$7EryF-^o}C-1m2 zYHowK%s!Ru-=6AQ8Af-4O*eh3IRY@-oSGAW)fth*^-j&#R{sP*Bs8ql*q6#n%>|FO z8vdnXYO)sllcq-iP35B0+ja!dbaYd8Gyj&40Q~K8jbxPEKqZuqEwJbx0W>`UsNF!V z^#~xLFI50l58x|Z{TYi18$W#k;@7TqO}!PXT`LROy?av5(CN`!@wHOLf33jgIFRxr zr}%1Md9~K#lf>!C>W-j9BZ5_3nPhVwV@$*Jd}nn`W;MsOF$p6T=lv}v$eNAUu*%e0 zuO;NkI_rjNTO5c@#YtyD{ub2#Ew%rREjuGMy{G9(l*qTomBdawwVQYv; zcTAwxdaWi*)048Mi;BggC<0cuC`WkoEIV7_kyD1OzlEkKwryCW$O}q#X!Itv?y;!4 zGmRuTcGN8)53uYeCp`#-gqp}KTvN`z(&Z$#UFLk$XOm6N%G_*eerC~hlv^HIq-eaC z*b3^DPITU~od!o1jqMb3A{ZwfUB~w8Yd^XGMfI-GSTQHQlg!bDSp`87=oiU>#)>)O zA_o`7VQzqhGu*PhV_K2sdJbR4@+}cH9yJvO&F>h>9k|Vl+pBZSED>n1+_x1as)zxvDFf4Td+|LSi)JMrJMf`07!p;dV$v{A8kQN<|25lppy zW61zWX0;YidI^U6cHhO29ZT3Ro1B~(=fw7ggO}rRPp+SHEO{3ro3h6TqovaHT!mgO zTWvGs5TP9|?Ki{C-OV^5n8QtiW&Ez1v7zx}`!45H&# zegDCIP3?wjqKGhMGmNLmh22}NS-gz+jI#@|MSCXy`?yz;KaPdk>=`V2dg)2S`p_Jp z4^5mx!6S!k=sXvboG8D{-P-y~+poU%=!<6`d|~~i$R&F8jeyqMu37&GfFHhHc{)d^ z^KgtXF^xcoa5Nbau-UI7z6Up3?v4p=@szRgF<8ZHVyG!(G>RHUyjXO`H+2ZaSaX7y zz`xts=@BB^(Lf`n`DpCjMww;UD}7{kq80!XSP!&;0oOW!s-5nV*38?mJFHB95r?TB znISM2U`p;34M?P%`dh`i2vxC?{li%mZv)lF@ajvwi;s##O_2znBKHKXdJqecyC(>S z4)hpv4m^0ZW$+4YwCAmy1hNzyDcMXj`g95fuCQI-ZB=} z33Y*}L%qhau?aC14>iS$rrh7DJz6FsI}3)D;<764EFgc2*JHa&ia#^k1X<6pwZnTx zkjLx2eHlc`07g{NlM)kqYfq|%{PoPPvs&I)&)DriE<2J-k4VVzp%H9DP0hWda3Xuh zAs7bs>J416^0S&DRsUgBB$l@HOHOi_V@x}79dc-3gdv*D7Bm|UNk33T;g7bUqQ4T= zwsy-mti%DKJt}i*sH|ArurX_DnRSN}ssMGZW?ZXc?Z~6Ra0~!j7}UOz%_>3!6sfE! zC=ya!`^`59inZxXX}ED8IRdy8l5IKPv)giu6M?Q3aC(=PTW4zzW+#ce+F)OQdT3ZO zVT(SH?$22$`uqC_G=HEkGdMV+gd_0jcH7O8fuX*Ek!)59!y2i7WB|j>uH^a#@X`F? zzTsRh1M>3-5N4@P_;o0eBRK#GJ75MQdmC`l1SM*0tlhM&!M3V@INPt8z{y}XD^LKi z!JOt|T0yn#VMP0ABy$RD1DT;gWm1Pad zD+}eA@lrh>^h`uFy?b>3*yzD9wFdU>oFlMJ(hQowSM7tBiVNtU7My$no( z^~7d_Zz@4Su@2s4vJ2i#qjm7!9PO#P%cf33G$~7CeZ0pOKeP5ZF<$T&iSh0lN<)N4 z?9?DU$xX97LK4!-!1OKRrn)CK)JC;bqpbp1=!!UKHchcLw7UW`n1;KK2qC6Khp+54 zMv5FJa^41gaJr$MoZT1cir{a7q-%Y$J+k3lMO`T&Ik|r5Hrj67MQO@x*!}4i%Wh+% z8Q2shHc(hyLa-}`b{LvK&Ol4x1}E?lf!q;UcaqPzVxsoo z7Ll3q5K9>uSwkTZr)pM8c}gQa8+lQhR=vLJ>7^Y|E4BM?*$0P>ol&>Re5oQbu-9&- zxUj&6DR9glojHs{2f#T|oIyUsz#;34Y6Ftm$R^A`M$yT^*=_QwxY+_8y z_MAga3a#ZHnW^QJEfmsfQK)u%-eTL^^74oUS32u~R}VU)Dz9@F3`&jW7LP_#uA49) zz{a@Lop%iRuuh2(SPw$QACNK3<0|5Al^9GxB$9Vm1Ea+uh8*u27-ioho~6tfTZzG~ zP4(%E9khEvLtR2xmckqrX#=?6mqTCcv;m5R&q?%yH6}q^X(NsNMA`ayQ*R6RT0M4w z9jw2=g2#e4g2AnLZ8gdqv$WdXsS*GrI1H@r35ImL;VrEI2h?Z@z@WwoC^Az3qw{Xs zJ*(Cz zG~W&zSVu$zPz zRIDz2Ho+@x(ZXfl5H2FyYJCo!Njlp%k{uRZ3N58sho46yJn%!?Ax=rd$5_%#$r}kj zp%(KsHWwd zWIa(Wr0=;irgsr*NLK93B9+auDMR~CHEHkpJ78oVw}oodl|Tca4KNvphy)(e><*fy zGakW%^~S-bL8A-NN^t|R@kYV2FpZq(kur?J?b!`NYBa9-AdA%Z$=4OY zC!cSwhokekU>pbMRVyaC^BW^)x_m~&LuV<`m~$@CKv)~BvUQ8UQe(Y3XQ79Pwk);i36?eOfhQ(<3@%#U zq@HQq$JBFIHj*d##qmmTr^_(FVi@3D<_Mhou!W}BEL?w`zjJq}JM?(Wd>}fpf$AnJCBZFQ9&@3FW zBb*#@9p9;e-^`>^+j&FUpj*i{3Kexr8Z!Gv-8*`KPx0e_g_&$D<@5lc8 zYtQg&1^LGgRsQhucTT)?BfkI9zn}S^fBfgCFMf&NFP5MB+4mlQ{usXh@Z!uVl|T8zQx~2+^@H~ZkIMJw&!0jW=KtccSuvcz=D02If8XZiZ@YKz5^l5mNNNo z-*9jF?6Q7;GFK=8P{Nu2>TvY^(Ho-gPj3_Ub)Xr3?u4-fGW|#Cf>Ovr4LTb=^CK;X}a8r!^pb;gpVU(?+$n9B?&@(*O^7e~| zc%LQUNWBZc~0XvOi#&%XTCfm0GoOMA*y$N5_keKfu%DR zBmBUpZO6DVaGOOo*GtVh4q3LiHPoIMU8fT?y<`i3~!(P7X z$)F;{irPZVUBNSE=1S9*BeEr9J(0y3&tc5n1O->e=x`Y!w{8JAQfIaEl__bf8o@`_jJNz8 zFz7@M*mNQ%zz1)kcYNP|>gMp_xGf=Xbv|6}eEIClXMq9c^Q~`=cfC@2xx@v>Q!#unfEyI$+)*WV=Hs?&NcJgsxm!Og+?`~9}&ftGk%K(uEV4U6kVlzum-B@y%()ueClIpC7w})En_!+fKdZ^P zd?`_;?MXBnd#mm7WKMg!Cg*j@84k9))^jE&f;l5?9S6_oZu5I_Jh(U5e7~P_!QhZE z^OIk^031r+Eq?AlRg-hI2J_u@a*`t`4FI01d;zK!-?5zguh!5{R}F-|WPmvibu@TIngUhs3yFIEyc)oLOB7V1HcUo+aeIe6_Mub$dotS!gTwO4aZPGCN1 zPvX%+_4Y`fBqS$FI9S!w0RDkqdKI#e)BjTdi5&|MV`sZx&1IZ4L8B|#XIpz5-6ca> zT8((bX5weX<}_AMoy3=Hs7Eqc@re@?kDPX2%9#Vo*ii#drJ&h`M@hM`hZme@9h)Ia zeL0PgoJf}+UGS{q)mIM#<7V$-36BGZM2%=PgF}YF^pKk4@-hNjiDeFm)E7H!!|{XF zahbz5IgyA!MIAi{VZ+0#DiBk7qz0Y7H~_>k`230JnCalYTldzzcv0{CG=5qyXMR9m z@{Aab6F^IELqxP1ym-f;k|~yQwSxmuCu@&9?OC|<3=?IT<3)E=6kSVjHoNZXg0;|f zml=$I=Q?8wcyw~`3xQ)9Ju33;K4Qe=z;*tb1zxpK7l)oiiaij8QMQhAlw(QG!ROph zCvqZyWdeg-gtqDf-N;%Zy5wQ;(sM|Z1^L6JB8kO_<5V9bnd&j}Y9*qZM(3>c$R;*% zwQZ1%FeCrm9S3*zp|M64HI6-8x6jn{(!2i{bZlIn)IIV=4q%(-@bCo2UYE@UV zyjP`*T|Hv`JfMGaO_Kmgk0URt?!8|(BT47qfvlOl#w?Ry=7wjPvvn#YQ6R>57_S1^ z7-Yi+4F`?5sCsv*=aAmq+FyguKyznbHw0W0th2F}Mv@L%>8!P8Y2Z`N#Nvqze$1MN z9YiZDNfS#(nyYh1rLpG&i+sCS$x77FLzY3|8vIr(3UN0~R%IWDX0$o1iP6>#i9@01 zwOW^U@@}r4pdo7_$-=rM)~Bv$ZF3u}7=5uiL4mX&P1k9G^aqnEL%#_C0gZO4MGLxe zayc&0wNcDVq4)6v`b~N;|*q20sDxS%@!9A>Th_}hdcIxI1muOQn>f2TX}ZU z+f>1aR}0%RhYpJ$yR`?#Xl+u9pO(gDu1eXc3P+GpGh5?`C-Av+1>0O}T_zqy*s7mL zuUfP&ld*2JhmrXXltV zTn{#!vQcrjYj+5f?$)76p)ZRcPEfJ>qN#cd@~_hv*ELzP>^;u}e~8h)e^(BCN6<&sOsILZ7Ei%-Jv-z_O3QY!jZs~rLdlr=z5sg#wrkQ!MllH;5 zPjS;UT&n4%eUYs<-}HMUk6eR?Z{Ta|#PX-9BgH~`zu($_&N=tLFt|zMV{>)R-fOSD z_S$RzU2Cr`##fxLr{Mdg4?Z~DTZxtV5r#jWxZ1)~0vc^z+E(Qy4*N#?U<^j9I`ImF zB^lN$Sd|#61Jw=PX$j+CDrLRkQ!A! zM7V2nX-j*w>2P zzE)Ylkys{i2}OZ8Au7ThuDLBP7{uW&GWf&co}sQyoMJ>xz}1Z^jd2{vJpAi&?BcCl zx#ttxn(x^jO@2h1vEeU_2|mJr{oO77l%lADxn~!St3TX~rscI3=K$SmNeB_7|PMouwzK_FH~o={rF*paj7-j<&m^kFQpTU&(B_mhvr}J{O-QEVJUayO8v98 z5^~jKH(ILe*13FU;C}8u>dL6MP`Q=iDb#fimt<#D9N1wsCFrD3AW>HoeCkj{RXycR z`=wb(6VT1Vw;ycJ1(@2hw-cDnU~^uLyOnG_L?vruwU9Yh^6s~gUV0ASlXIu|JhB*5<3xLpIFr3&xEPau!0qF{aW~IV&g~G1B&X`ZXhuFn|e4thcg;J@c7Io&Emno6Mog^gUqae-MT}> zU}gtTu@UQvZZkvPHZ{*FX-Mv#+|b+cV!S7JNOftuHyMDni63QC*(CH8?CE z{SPa7XFNt5T5UIR?3Aa@!x)@{@oJQ<-1aFSD&(JVi)Sj-l$%pqb#}sYs)P#^ z5u^Uz$6FOQ-MOWUs<)&45r~@)*CUWjtRmDr)T0Euu9=tG&6Dv1uBp)VDdnM_4DmqW zI@j_yUgvJ~p=*^*05fXoZDsbl-l13@fRJo_HkSoWF1LCQKxAN8fMW`HGS0QXJu;7% zKEB=m!s!>D>dZLv-&#HLne{pc~38Z+UbL8Up_1g;z8$e)3HxSa&uxnJsI+PR!L!+uZ(2g~!h*9f zqY}7abvhPNZ(+y0Ri8e$NrlaxJv*%7Dt$YB_DhmNtcvtoUD{Apn@bDM2V_)O+==AB z)o#Lh31Vrg8_ue?y0ewNHPzmxQz#~ATJTZqt?3LQ85u2NcnOw)q5m`dw;yW@@l9fr$R^jomeyw%=e-r`mE z&A`=u?GGS~q**%6GXs$U9Bv)3KZ;u_$ z=W^py`e4j^&5#`$pPNQ3&q`5LD!IT(Lj;&8&oIc&d7+{+S& zQ#Q_Ma?<9q!%)rJbl`YBal30sWyO=iI5f~ zgyE~I)YqxYubr-2HhoD!el^~C_U!WI3Hb_5#KU!8eRjFR5_)l(UvKKK&mry)rh}fZ zp%w$VVKQ7BPEM;h{F-M`Wia-lNX&Ga?S;RNUcP#D96$>4SUi>Lv|s7CHmMgZN2g&@ z4?qJMPKAA6Df=}$S#@>HeDQCBKaviAwDG(ykv5#qFJJJI<4iD_qzj>5i+xocf9c?h ztOkJ$UTGVfWHqS#-e?O?lDP^?L)*Y4tHFGYO|lx?FAE7QkH5%jP+0gPPd=R{rVwN@ zZOlfQuGClD**JG_4r7Mo7kApSV>qW~zIw7@`}JODV|E}rujB4;ZUbaSe}#SN!hn3- z;sl5clkJYZ$8!*T$$;@JNB@Tfh zm0A@Lz%C;gBTF_qRo6$!)%uKk(K}n)^olNTf1CJ-iHncUZfv}J78`nrD@$v_9O&*5 z5U3+u6^Hm+6JqHN{vf;q^mWkh9u*BP1-oTIqSmjuTkM7eS+ta+0T~~_xieB)f{a5& z$kd7BZs%7iBU21eW{Q#K$$(#vwi2)NvyM@?qFb zm;!Z}ydjyUfCj~>-qOZnlJ0Ftp2Pfo+9Xb0?47@=SBuM{%X-5q5i7N8fEt&b17z&( zAo%6g2!UDq?l0L8a(7*NVJ3Vin(O+{cU}<;rp8F_Z@81GY zyxi}uI_yRDCwfF-N$D@QOuwS}LgA+QvabSmQrUjfdYLC4>4tRJUWF42@4ma*KGfIW z>9+T_Y^~>1MsBxKd_Phj(LK zXr#ta zBw!e&ojilz1#mwg&<6ef)*Fm|XR^25AotOpYVB&rgjsi8MTqBBlF+Hq)1i042S{C!_nMD%3K^vb`{)A6mWVkz|intmruwOCTt$LklmG zw=g0|J1;#FQ++I z7tk_GNwH}(YA{H`4oU3FM5vXc_2^>EuF(4L(sL5QZ_TE>1<IDc4S_ z9i^LNNqW&M%ArhpyK!kGT}aK#v`Wy$s4}^6%DKe~oSQ8c$fj5I@Q^})F37_mUG=!| zOKF-Fm&pO4OFIhk%-t8Ew2nsaQ|^7thE5--YEjjdzv%Z~f!AGNeY&@=AHCusJ;MT5 z)opofr-GF;e6m#*>nhB%0!7tg^MIz6f`F|gDJHB~-%>v;iv*aiN>|{v28^+`mCnAm=C-xyH8;Akju_+CJk6sSAd)Fl7K4X7`C*jcSz~s%Xf7@__jV&@HJk zRdU5#8V$)c&OoCuB_~l2Xp>rz0NeX|>W$U8M%(=6%$O;$axcX;)0{bN=B!y_D1oU% z?cKNuLGg-zJ@<^`b6@vC+5)%g`#%w{OgEG?(IVJ%F1XhbnbFvz;yVk-TCpfmXERY+ zOc&g)$uqy!<KJ>j>S^xy(Pvf`)N1LA|bc0AC$XH_)E38ENW za5ojEQdC50d)GK^-Nj{lWb8;qg^J3l<7ojBOKUD#S$WaI!_N zTWpcdvG=I&AhWtJK`t{h2DJVX7bB?799^;$)qCtqOW2f@s|D?GT#+QTkXs2LNzP;B zNrpXMZ)sY)SS}gCFx*la@OpJ%tt3qaFWz>qM6|ToLw(im@ep&4%>~k8)QGFi@VHkZ z%I#qgFt7Ny(vv5i)qaCc(PrPN5Xz{nAH+UwaURWkpeJRmZQls(tODx=wlHC|%X-)~($DImQvc zhPCS(^lf3$mCBaX^-Ex?ReCHEYurAVL%rlnPPtLUxUB=WdR5nCIsSRMLIyC%%M^AT z$VZ>Zt9GsL>k+!mvk10hgq-(~b+HT+6)_Q&X*$yCLbpqSh3Lg__a6Z3^#uYfi8k

n{3l~uCQOESHp+qx*- z^@+Q47_AD5>P*Vg73%^p+!BuVYxcY)lc(eRl3}qnd;))b$`ZL z@3W4(q-+n)@z15Hi~O^&@Y=#c^tC--YrHyhX8iA7_-~olevlfO{PCZE=YNb$e*Lw{ z6CJ*zBj<`B2(lY(b4pwAK%e1FcZ3XG967nf9lzW>_li{A`?x&a_U$^HlyATojTnx zkN1lR{{Ubz3`bglw=iED8NmBE@Bp!XDtaFd)s9ZTITH+x9*GWzB5liq;b7=;B05|X zNqOIc44+2$t+ivpX~0h(jt(yyPJNEylL)UJR`7gBxTGD&du*cZZo=UG^qGm4$v4Bn zH!d8hh_2>IR<3NCuGYCPRJGZTPI@aXZeHV6KtgALU~(W9@b z_rYaD(V^}u2%igFshf)qr9ya5JC7&Rc-QdfhoZ+XjHWw>6rQxg&EKLl>-y)POD?$o zjdm~E7L=2VsJeogUK%jTC}0;_#vJH=d5H}A_WW$g zxk+__lVFABCYY09ZlbTo(KmO>EDJ||q|kEk2d7^+l~U&H?zCmKoOqOj;PvAAX#;uV zG4tt;-Y;WP^xkCOBUpN~M}KF&B70fj1~vS5>kS^ymXK^v(#Knh8x?A3-`5)L?@G!n z29OxuC>QP?$QCo2V(`}vz1393dme^KZo*uKRg3W*lB}ud>*(xA(KbP;806Fi4qNc3 zkUqv6jj#31Z{FUMzBmL5SvH4#xstdsXMN4;vB1ffwK?tFUfP*F0JEd6MV~$?xXeHk zMN>A;<)we}I+sT&X}VtIB8{yDJa?y@dwc^kT=A=J6N53Isn?Dy%rCsj*U5#2FJEo% zoVohN&c?YzN58fw@eiNwd}H!ZYUJ9;Wa<=Qvq~hCi3?O3zqPf2()(xwr*^EAHHc;!b}iAT$D=qCjclEO z$j%n$R{ds0srXB1qx!EnL~aZT5I!p_*)A%v`gu2Z8)JAUIaRr>>d++vds|_x2(=f= zVb|D7GNQt6=#a{74Lo4)?|!hm1B$cgE?DhQXKVLJJi7yW=?s}wCK#Tb0Gnf_L5uQ&;nW7KwD>)R#T(TANg2>XMo1x9y$qKSTb z%FjC2QTgwR%+KPqlfAfqms|XRLr|-Y(>#0LdL2TWA#}3ENW%;6Xu;+Ju7tX~uwU6( zxJSDo>&n%j#?D6L+C2&vmU{JAdNx|{TDO1Wtn*Dr=P>Xc(SzUIYx5WJij$77{O#C} zHtu=s^(&$NT`y1m$q(m$(EY|_=hxBNxC_6|(lma8HCOp(DSv`tT=HSxJ@8d79>numn#PZQ zmZr^Hf$*Rlf^q~V$TLp{zxRENN28pjY5WAAmk9MPhoqeR_h0kCc;8pJcz}w}(lmbb zvovkq5KbA;&zzZHnfVoWJFKtD{OOhGsKpCSTz=&uX3ypbTBcGO$TUYfCh7sCb2NiH zyI{Q!jm8Y~H|#3Ii~}7$2Vln1LdG*@*=f_Kuyueb1HU!0+%4-OGc+@pXiE$(;(b#z z>3R))syj{fnE{7ud}b+K4u)Sd=hE<;0nt7UzCR9hzz&rK(7GB%7-%GfQI6K~sB)X4 zviA~(pzm^(b{f4MXNb&99yx`Q)a>~&t5TCX^n)^`(}rUvXN@R7Puae=_%SCXT4ZCL zv=rUESNv1svELTdlZ2B%&w!}dD(V0h#cuTc6pvVijaFm}k$PV> zX(b<%30~&`M^y}@gfRuN%f5zln){5_SZEw!q*#i zcN^AV>C>QGkHH81I$YXdMkvO^{)8%g?tSXqvKx3QfK1Ii4@8yJ$mpA}b1v1Rt6Bz3ZHfCJ6vwDCReO1+0sf1e&6bG> zgW5*u6O(;2U;@8?F==;Xu&aZ0HwHxr2utW!H}t@soT~+QmqxIY+)~PH=queW$WtYY-sRW&I=}5*os2emmtXJm z<@Cpk+vR`Q>nsXWUB@nZ)-v-`8%Z5fD zJDXPT%R{4&!KaIaLkREmzz8ggc|enQCCTGx}yYc42J&CBB=dviCC=E=(UeIkbKzdDJ;G*0ww_ z{6Z|l_lbt(!B|%;^SXKu#k%GF+{F6nFyDVqg@KUz`T{NBP+M!qzYo6tejKz|mQ@y7So+P`#V z#^sXloC9_0$V>~)GwCyI7{c{3Tq`f+fP4q$rE>3_QKjJc6sEYCy`ntaH!#M9hAUuE zH_q&+DXVd54r3RxAM-8x(;LF5JV8Gmc{avUY(sJ-XZ*sL*)~Rzhn0XVfMGX49 zI|;fvJo13#V85Q_AYYk*C&65ET!qsW9GsH5dVwQBvd^t-Dc#dS9#`pVSAv40CQ{s9 z;Fp{a5`$AriEJf`hzRLwpM`ww!^t{KxRe7Fd@88~?<4}k@Uu93G7DcU*Nm;Yc9UE! zYD%u->?)TxPwwg8CzB_`zg(#{tJ(st+zYwCE@&#zh%ErDvc>IneVy`toj-|^!v%VU zUf#*y_nZ#j_Oz!;Hy%pu7u;m!|-a}+?^9Hc-mCB7f-Qp;t2uIk8TVC!A0Wb;Gv^ zf5HjHPzh&3=YxVj+&v}?Wq9zyk5BYN*F5e7aCycuu9=ibqYfzJj?LC3ctEo zJ)y$aPXS)x_k}kgUyVQ2CJc4)d{FRLjkO3v5neTwje{OVKN8{z`}tt`lM`aI{Z#?8cBFXzY|)2dHRy$?B2L()27kG zn>IH6y2ii0;c;Z}v9`PKZW--sX=_*faY79ZQuY-&;b zH}Ja`1U}K$V(>Qz{yRq%p0;*XzmU&3>Dh|#O@~`HH8pAa9rb|E`U#ZgkB0KVgFoN0 z(u$UB@PPhL&NMC5F3dH-87J#eVu=5fv!~~GEi7z0vhaO`q1B{S{eEk9oL)N-{;~}x z{ok4$i>%l%-ngRnj}bn4rTvnUpHI&I^$Ukijc+|fnBuxxzOKrP`fyndAMg8#4QiRZ{T@n?gCr+j{L_7w1++_Yny^Z@@Ev=`Dp zv+<6Ba81*STGBsyC2>j9UziWY`BMnKH2(vaoDAe-iExt+>;g(YgE0x;D%=buK#!GA z3iO>e+{kC}@+c}~w{SDmawTEpCwL~?1NjtgR$XaG82OxbvcU6@a5K~p&lvfPOZdlx zo1uofw2@C0zFW9Sc#S{U=Mev$!c7Q$g7u493QRksXRC0t>hhI@rXT#}yFdTR8aHhilM-@^90pwWPSNBfBt`WH5}Y;syQZW`Uq@J*ZW zEB)I-OG}H>5^fp&7(&|aZo#kcXR@WC#c2q)OmZY>izVNgX9e((p3xZbOZ|>+TCoY?n+}uy(HQ9w`tesiOU#RrpF-ib|18db z&p1W?pf_~tE&-Qs98}?SSPZFjAB>NLXSWBc-3R;+#YZo{5xjaO_Umpi@mIakGV*u` zw;!x>(Xf6)v6fH+q%5}A8%{izB|NdpiwEHifNyB1yOe{U;e8G3>oOno;sO5nbnx}d zS1)C9=m+I^F!K85A%<_Es%%yf?pK4x6X`l@pVq8mgCj9o1Eg9` NZ*5bS28tYtwU4!Mf=u} z6$l+%=DXCOQ8}Ys9~JoQ?e1?^{xHlvGiD33WB-1v-eoeLw+p?&XGs%{7A2GAP`X$y ztdwgHKOH4VP=r=O0WUs!8*hucSvKVLF>c0iXPJ99zO@mrBF$YJ33J^QzS(gvwq&w) z?pwF)*~VL0)_iGvqj z;}53q0D^q{3f^Gnlt9rFbZ$dnKK+rJ)2GulCu>ipRT@Ko6|*gXzjpYgtP>dx3}-aF z#;@QD;EzlIJ{XJ`cujwm&{KeZ!q*%NDL#4V&#XX(MesYLVU$}QLx14vQ}`~7KNA^^ zSb9wT9+?4r0sJ+?qv@Jswc}|)kExfIhZQ{q@hd3z*YID3J{6t_?S z@ZpSv82m0hHEbJ!?OymAz*nagyvA?K8wswM$T-e7z3`-`O2ZrZ7k+~3NH7BUz{4(l zM(D3n0fzsoz7+h$jEkS*8LD|>)Kq|>-#NnkG=4Or?Fyayt1H0ZR}q#T=L;^Rdb>mY zvH0Z^@U^26v<<_5Hx;`xJQjZwzW}cv_sxW;zZSotUq|0MBsb#VYf6^jG2VNFJqwHf zl?=XJtOh;-7zkY=mI8bN@TUD{^5KENA-w!a$gjm8$Xr6eEevJX9=>&GX6E&o+1Z(? zm@_*xi}xx1o1NA818IU<`087)4ZRv$c490!9CMbP7)rzvbti`L?|Cgh8lH_(@c-_K zp-ij}fDyu{37?Jt{)EA==$V?Cd9!+EX6o7w!Y2Vg1NfmCfuA9~#;=ZX-8%g04^LJ< zf8x|rPZR$9i6Nn9C`|aHq{rZQgrBz#XU?C*`SWEbJ_Y!?qbG(sN&nY|QbK>qgJ0@P z!_UnQJv}s&sl(sKIq-jOrZJX?&CE5%W-We^hj-5j{-dW(Y)8S(gZi?MtzQXwcUa&- z{}(KT6Bu^i-TF1~nc3N)nYnAOWKe?KN8{JsoeSl@xv+fG^0O>0!7kJ-f!{$0WXCU_ zMt*P^7M~n=$RmA`|1|xv51c*wr)k1pYLY&B#u=M| zaOR5VjHZA6aNSv0eE=Tj{qX!SKjS<<^eXBJQCg`o(4ZS#mZrMFKwWwi-(=qOr{Ys=@(Cf-vfVjiuj*nhU4V9$x}zS8~9oDi2^^P;HCepJNs1;&|89$7YCi% z;TO~2)bN2*8lLo6{Izu_ML+>R9&#cR;~d{f59mMf)Oq4ZN9xiKhTw@gw*+gmgwJyR z5SSrsBzfcewnd#z z)>97uOD|5K0N+Fz68PtxNf*XH!PCt$YZLfDIs5`I_@@N_U@ltwt>{YtiMs2)xj&TP@+s;dkMKbArDN z{T}%6dD35sKc}rofisx6lRu^SfBMqG+!1lq07(6mlAqI8j?6YK%*}dx<&yZXHerYW zyr389)haOY(m*UT`Vj_Ou9iHi#38uiGQt|`%s&tSYDB7cbLY5!7FVY^v8Nx5B|0I6& z50&AM)SQG$DX`0y{8|bAgZ{{EqsxH5IM>}$2>r{)xIiz_>$uqod_>?Y$FJZ^^qM*N ztH*+*zj&?Y&|ftcB!7z6Y7YLgT=(KnYv{`UEPg-VR%%5rm&AHjeEDiUUtAsUs-tOa zAw3_B$3)i`Z=?>ePTYgJYQ6#vE$+iH{iy355hjXWCll1qxkjY4Sd^>Mp@8d$Z+aRn z!etcBB;hm=tXbXbtonG}9B@^1`HbhJkPrgXN2-$KV)tSc-@$g28K2U_MF9qG z@9ypREl`n6MgLVlt{Q0TQ1?m{Pt;T0bn z1t@r^wf6ury#e{-)*{$Xj{A1ZwM7K*J8OzN4ieyD3WhG$@*sz(E{w zH{JnWIbT$ubC29T=%xW-51`?Sc6KY>=Ku66^4G=|rN~EVZiX^Hhl)b?30-#+5;?=M zbla4~(%#(F@OC#Sp+Tt}x@2gAYZrpB{L)93Zs>&@)0(HB7V4y%@f+?-BZh1$4+ADg z=I(>jhc0kh7bgJpc>xTg<@%j`a(41y2e|dm#qLC3Ur;Tx9rVfCrFEln|uy3tTs*U*x^QqAK1RgYCvEL{jH{$ihEcUH)!|Jm3`hi~fqYYFv zDYQVDMOu?=UNk&+1Dt7EGX&j9b+NbR&5pn~aUr|Jom3Zn)9|-7E)GAS7lmKo7ejw$ zQTPK3Gk~ugfAG=(;Hzvc&X?hj($+6U8ub*-N%Q|UrwV|84^x>{ic^aJVFw$%9{6Kr z>eq!Qb{GVgq2Hya>g0utOnU@U(xabX8U8pumjLO) z7jMZLeuB5w~4JW%;k@IXE!z`N6q?gNOgH z9Dh`K#~y$D!r+zc*bC+4Q}c5yk+?9D&4#n(yRbw?L6@LOl?Z*)FZ4FQ5IN)QE2EfMf zPvIvfe6YMHFSESF&qtK${KMwTe+oaNH2hE%@qZ&bFmP~gU~cYU#2LsA%pIINi0^{~ zb9wkdf5LI@ozFfV31_dw#z0Rt8;isu*)jaP;^GHZ(sO+5e8zEpC!0+~A^?P4S~!~_ zd?pO|tl*Dis?q=_yndDvJ_h&!!Vd^MezRG@kF*&A=D;TaFZ6^2p7a>}NlHf|HWYuPH1 zZ~BZE#`~`EKQ97WHQ)E-#)YZ)lTF`t{sK@Ck%NBmRQPL#FNlBwet2ME`pMxV&4i~s zf<1gO;^~o3L{-iAtU!66d}`s_PMeZPB;kt@Pmg>GeBX@1{~4!k08%-SE1tRdLI3IL zC!cKkp3|0n9QB_oo?iTz@68{KZ)%zXe+Hb5*#u=0^k+Tdsqu#sP6Bj#T4dVJz(@GE%YSJHT|fi?l=TlEh(JWTxGAp8Jj z|Nk_M%KfYQAHb7-VjX*&U0a#)w`#1N{2|q23A~h@e*y&0Qv6f!W$+8Mzz609{~wkf zA3gAc3DRF`d_QSM#NlJiej9d@v*CoNQm}DJ7qP4d)68r~zIN`8^zE?w+ zmQTW0T{wQp*XxwQUzHpJd~vS3%V9O&yAl{ml<0Nb+?oYG+$Qi9S&ZLvBSrw@n5 z)lHeohf;xKq2g==?nqXBH2 z>(U`#n>nCuX2i$wPDm}<&7u45O#PhQFd$b>IXrl79 zNLz4g`afM`)(uMJShp(p2upV2?)s>@CUup_w0P16sooZj%iW=?*S^Ho)~zDb575K* zBTx~NJz$D*_eFaJdltQu7uBSBZh7>H4%8uW z-UA~K2n_D9*MZVXRD&->yWGh}x?MDqLT;N;@&>_c?~WRmXC1xK-sJv{{yufZ2n&Vw zk5ITj!>M`YC`{CK^r)H|Q8RDGJMa2i(WbWNt!j#EyJsixn0 zrdVqFs__YAiD|3BC+ey4_{yp&HNNudNkyMk)9DiBQL6E|>c3*@NQKW;D=N6W1%bxr z!l{h&7a9tmn{N@dqsC{;QB>Wi@Re0FYJBC@iwa*^wW7wSO1TsZN$lq*3N5TOJ^=(= zF*TyWS5|$PL!TlbU%_qgl~osNdGx(HxxrDk;<144;Gx&tPrPO;GpM@);)>HVZ(gFv$ z(ocR*Blwh-qo!~34rqlRx)pJGUB~LB)hwes#dQ%NZb}K@k7cMoLsGxt*YPQ1tbG~}5u)O4})e83q zkxZ^Stq4A?Msww~2tKVoTUv7oC9g>r+P-6bM6}v$sVH?R+(pW()n6{0t60%{Hd+m* z)MQJ+z41)=!dT`T$lv$;jmlT4$Cirnwq`7qp`s&rAr0M$8W)w?#Hhsp2c>N|)t>$~ z;6h0coZwSAM4Y7}E#Xv)C}zR}r*l_o68Rt;rG@xNUpR35!q`OnahmOD^@|G!X@RaJ zbFaV+r8@In1jfjUUw%Bz7CK6YLB z->rqh<52}_AC0fPx<}}%F01Cz_{yty1Ydczj>1=gI!E!jtQtq*)Ag3mwMDCK7J)CV zb1nU6vr{RY75kDeUUiJziV81{)Um)%A(bqJv@yIHLw0N8^?Y5dlg=$TB!(Sh+`xNX zySUt_vzck7p-ji&1;;EV4JseZ7MIGS}97w{NixwS(KUJiOM5 zOQ@mJ;jI(;nq3bmxYsxDOMLx%x%J$K{u#R^f!B8zykwxzwwrU+`C{p9 zxA~HdYRS!v&DiF?E_ZFV)k!lpED#@ayB_uS+a@-F_+n{Sh%2LFX(LWgiL{L}p(>VE z#TLuAQ7{)vdxvwWM7}i}8CxuEa3ND7t#dhDA}ylu6r)+i7R`6ARNC5wG@^^8-Bgu9 z>=D}!|KnbHbp7@SH#P%8JsOLy-%G;D&6xgT3XDfnuhV9vj%@5L{ta4Q zH{dw$@u#&^Wg=HFxqg>Fttye^n?>we_qSRSZ?gt3#nIzKC5ISfQd4nBPQv>*jOq# z)Tz=2(lfIsQ2(0+hCe$Id-Csf+Vl@koB(#jLLmA4=Br4nX%2kvJiLxbEQAfq&08K$ zdGpPQUHWjU-O?Nwa$^U^AlmQQ%(=HI?@Q-Td`;yG+f`sjTfpSp@M<74b4}44$sR=P zdom8X3X>L8ayJF|BJ*^umD7&g*o>sz%#syIn;mOlJ3`59zIf%c8JGvgRHoj$<2|hX-9}fadKm?Xn76{=}OuxFaj58%j$L%I5Dd#$s3!>>UI=3@w}=eDTjFX z-5lAN)$J&7;)JRsQW_%-pt;fJi|UhVu(2p_#M11>vWCV6#!yEQ!)G|%Qk8^KqK4+O zW8m{t#_(!(NL3PI!R2iBAnGV#(yCITk~T{XVd?%Zk{2(@pLXu>0A#_9^{2h^LRLv) z5Silfr^W6C(q^!tmB<{LC6-cLm1eZRyoh94#>&=~pI2GzcTkEk9lDT8fC68>16k6{ z@`kfv2Uwm_j~iEKs-B>r@g$>-sL+qPwtS9Y;W5MGat_F|&qZ{i@yJ0-O;p+H? zpS*O*ktgA)qlFC{#-|b6^pBr0v0j=t1jdgc_SjD@npjUAEo^8K%(MS^@#lZYL^ zgxK!?;Yn+wnbu)ik8Ie;g^5(lkmS4HO`8!8@aN(7(c_ur?H8{8)yHhUh~4N!LWtdr zf9mn2ZIjsI?TC$#GN~V5+6+$VK@yKx0{`BdZ|3m`Y_*Lf?zNAaBfXr6WL+s%>G-SU z87F}dTP&@LH5|%K+m&FxrdDmXy1&|#h=67z5xHsorOZvMV?XAmQg6OCxXw+b-c)%@ zq*YSPaj;NY8(WZOBgKWwD^eV8KR)rT2aOcFl!IoG;?Vh_&wVzxxU3_Q z;?Vh%Zx&7KAno#k`HB<=j}Cp#NU<;92}*JB=<#tQ#cuX*kS5B9rwHPw#4KTk7Acz%N4QM zU(t77SKDhF*VZHSep&^?WC^!=!Uu;n@ZzSBF>Qh&t?{ZOwoPX5?1or4t*%>74-x8O z?6|Ubs^hlbD%o9GB{$u!UlWh7tB*(5Hms?yUthmIssQU6Vrv@X^=nsEui1bblNuW9 ztHGV>>ib~%o4ZK{Cr7a1lN~#2f@-dvJ>*_mYB>PbxYot4QSrWB8XNZaM6Ee-PjbK7 zxzo46KY)EXcRNi|!klmqOj2==>VpSx=`3~++dCd79=%EE^JL{x*N08C=*m=US3CCi zzf0eOrJ9cH&#vv_r?`>@d z-*8*3GF%4R#I=)btqRw4)+pe91!@?j%sKb99(aO$x2$8dpA|k{s#J!R1-R6Vi)LAP z+AUjwQtS|O+e&ysVg%UT6!q{%c7g4duCkGRXtlB|r|2~Ib_kVsDU(*$I~yy{L(~E8 zxT3T)_BI8|DLUIbJ=1{&aK1($onGfBm-NCi*6x<8iiFK^A1u0s)3|t7nOxg~b6Y(R zp-Z%%`C2ky&Zfmk4(T+|!rt9AKS#(E&NTG@D?@hucy&X3WH*>u0NIRh1EWeRJ8S{ zqL0D?K9?YPh=Yr_PM$yjsbq*JM?(sfAGk(33ZrZwg9xbt`pX5kQBSm{Ql5ULCzWg= zDVj{hLVZ`V6?bzVHExFPIkZ|!V`nSvZ9Dopfo+RT{|K_c72qg7%(iI;-`kzi=G#f$ zT-F!GnS$2d)uI$>>F(`<46r)bOyI$b7VW(Dy1NIi29=ItKUy^G{~=)z((T@P$~XxjtLJ07_20n=SV zjMVkrprdtv#{pz7zPwPaDk&Jsvkp7DP$Zn>F!CMM18A!rwhAf9I=WE4eCmY5aM|~$ z#Ca4_Qgs~lci0t9gVW-iPp?u<(H`zui9QMKXn%KWU)M)LT~AMI zvKKWb*p(g%6QSG->?~dTk}Z$6?HCfx-K_ab-IC7SY3Ld1{3c4sy}=NC%Eh0ETr<_S~aU z-5o_$Z%G~KUfp-#5USdPMiG^ZKp5s9479Mz*s-T8*^|StJ!(XfTiKhDwN~;;2WKqS zyQ5Lf{o8Sw4c0Un=Moe&Ggs$E=l^`_!xJAK{`2r?_-Y8tN)V9CTsC%`JoL_)6t{R<47+CoF_7N;6moN?CnH-R7J5h#%GPE0! zOw)26Vbg&In8czx--q*4hu9IcqZxpEszLcG$K=u0(c6cq4tdFpOxOJcy50`yGlV0+ z@x&v^12W2L;s}A0Uzn~LPBFdl%Bq?&8c=Rs+Q#cElH{-0<)uRPkx=7fEVAMz!Y@^$ zT9wgyOJ858Um^!oS-eFQC!u-WB1AkHeXzS{_1+#?H?d#b!Qos6_8vrFVZbJf!hU-9Tj=b3t zi!t5Jk79|jP{s*W&z;CAy05o2sXAgA#ig-vY~qO;*k$t*IVRgZWo)e~)8ZP@KAeFr;LAEoDuyFOu0`>9Iw;NVP7=GSUeMD2ET^(*pB{gCMW z9dMe;)&uaZX2~y1_B1+~gH#~8*>wPOT=cMNpp&-K zhQ`qM2*e4rNk>Ndgr*YR`9E=uO8w`zHgHEqPws}Lnnphm}<{z2z6P} zMJL$k*>h`WO|`dGvUlN1OLay(8ms1no~fzyRB8>MThacGM1&SyrdixkN>$q@x5%#!3KT zOe4t3d$wHJ^R_+Px7@pJ6^A;t48p+O+S1P%4+_MI z7^zXhkW69a;gJOyrPTUTfocxgZU78RQr5t?QbNI{TXT0mobzKoVi#|P7HihdPqPtA zM%9g=S6~hWrdvhk=FNbX0Rac+aZnuTtw^YfR9&^%0u=1qDM;I}{={^nwNomo;NnDh zsaGdqp5wrEI8&LJ|38MQ4i$SrNiC`;8yGG5L{^Nk-T-orABBO!mDo`Nm{t z_9cJJ_kTDt`FV*Mxp>5rX6kbGzyI62TV^L;f3fq6jovg1ugRDE%&S*Zobh(7>@NmD&I-m<(P)zyO+4ljT6^?a&L0qtK~QX67k-fGOkk@ZyumxDS;+mA@{JH=y8 zTCm(S#bS;$OcqNsay>D9MX?o+`B33BZYbZpJh(A2q0!{IbEhwj*492hzbSU{mBDZ% zq4Eh`PM(R4I-_;NsZdMfXdpi(F_8+Ne{M9G4Tm#2%`}c1APr(7=f9T|)6{g#Sx8(Q ziy>yoec`IKPBUrK#Lkb5hT6o2k|hmIzSm$&Ag1by8#8`~iOHOQ)|X~HjF=Fp?o7AD zN5c(nnhW8kGl;2;bk1+88x602Z4@kIK82r~5i^lm|KsVoNcU@3->ikrX_9%Xd|pa5 zgd&MZ3O!8SV6m9w$w(|tYE_z-+uD#OJccxhnw*&St5b>a`1qyK#I2Fo9d4RQPnu=J za^I)MHo5OUU|Tu_Y{}EUm=`Z+5mO~Gr~EOm3?gPUOsdaJc(F~qa{LX%)VvxSt&Lqg zM^h}F58rYhRi4~XeqVP?FnQ+U#qp`bvCQ12819RYWem39V`nBJ$#hHX{2=7IKuq%N z<c+Bp=Cpna3~TuHMn9$EE{e}o-zGfXn81dhs4~m@gQQ(7mdlF z^H$iZrbChUhH8(_4lYk^&(>VYG?^G;iv!yU#Ei{_8!q^;HR+hSOm03Z&9bpEe+;Nj z4o0d^3@&?qFq3L%aj`{a5L5g7>|o>sV}8xX6lCa4;I-saHP$e{5UP3YwJDvgttcAJGhWbL3T71Kz~_12zzmPECniNq(ID+q!|h1rx{r2KA%3) z5SY)yc85yyYx!x4=Tkc7Sn}BqFC3S=J+gpm69lUt)(p+ui z9+`vyqrrxTJrQ)Wb;I{OmR1@0V@4BWSMp+BVH(C9%1PtQ&R;xMIOf+>n!o&?ojGX~ z1*3@z-zyrkqPP`2(^Bsa#HMLwaq+F+z5CykT$n3Cp2Sngb3jOs*|n=ZtIO*Pcz zMi48CQJqMkG^!IR6r(zk5){~ixjfLc6^n_>R8(T!G}4LGT`rKu2I&_!&5el}S$^%> z+$M}AEz>ibV&R(MOzMMYCa=w!r5G&6s=>6{L*6vVPE z!MdT*mY7VtL4}PuIGQ{b$Ex$pB4V~9&2(r!d9EoppE1NNFNkffXiU*Gfx&Fc@@0jn z4h+s6UOqK5dbsIK28F?6%cDL$ztz6-^vtE{Ke6gQN z|IA3~v0jdImsVRZ+k@xWWu=NBYVFL{+!>AD`6(((_EC|GeN$`%%MLcS_^mNk&PME= z)kq||6Gmt|8l;nbbc@>ELpQp2z4c$xFxq=@UiJOk?%lEX{^*Y8EjxGI6WzV-<9l~* z*$vZY?1|D`I~rXtR^RpY+#Q8K1mVF-+*J&d=>{Dock7v`xCG+XJ%DS6k=1$T)QpAk zH+)&IBi{P>df;{MK9;R|7F_8F3i1h-3O)raH37mz*^(CphHO%Ed!AR$8uK8f@X#CG z3cog>g1QpM2hh*BN}sN7Ts;f5v&2Ao)C;u*%y(h7LiIbWF<8-J7Djs%$)A-^tqm!F zC1rQ?vHlKNuoO`nQ`-YuES;8yJ(5uEueUXqugaj>l3IFF4Bus5V$dO;h)X09}f zby4(f)Qv<}s$Y*<1YLg5vEh2bR_0(tdK`mT6W@Td5|RzbWiGzJ_3TOcAYvuF z$9gp{72LmhpYw8Y&5M5=;O!?17a4YKVZN>Ov)_4zx|n0Hotqyk^Ef|(Zl>wniDm!w zRO#m_=N0H`E*|e3xezb?taW|_-Oa^wog>(vEcxswL(|x}MTx#@D)#WNV3MuIRkVGwjRjQbM|ixJtZzgOKiFuo7?0i@_PL6zB2UObP1T zsBbtYpPec}og3BcJT-ODO<3aX8_w{35jSCpw`S)|O}GRmH|iVCbJas7Fu769&hWCQ z+=M0GzTpfln{X4Bcx!e}My5(&a-+WC9G{7nz~n|XJ4dG~m8CB`w^#JvFBFvI_aW2G zBERmBNV5B>-*^)H>p7u?A>YC2XH#J={k-tAkbJ)XneRSxCP!+Gd{TOhOsaPYuwgj! ztR-3b22e6-`~;}hX5`dBDmxQ(nCeRvq?`U7obT`xLZu(_LdmBqk!Kvfv+s1n)HmhxeUj44 zL%yp=#Zf{jb#C8jWb*3<&`Rmo1@ax7o52~EdxlMJ$j>)FzpN$EE0gZnZlv^#^q=Gz zxyk2!`pqBamCvsW9D7amMoD$U_)gCI({GkE{;+p&s`l>kPQCqn@KedBk;wP!d8g?` zZ`VC3t%&o6r<(jCpu z=uq~oN>2UzOG=(7L++cBC&$B2C5x0g({HLb6Yk2VN$bj|dNbi}9htQ6;QTrnE1Wev z`RB+_BcI>3^H9@os-Dz@EBSP#hLXc)vv7$&@6+#!OD^ZgJw9KzkY+`1Am1mL+@H-B z@*SL}z5l%Olk(|GBBjwtB*PhVM*bT4r0BTvPJ2=@s-{Ge# z9egwTBfpF)iDa1jpI1KpIC8&Cub3O2|Gm^bpZ=YVW2saWOjyB*>beHS5yokUzW`Y&^}LpqRlwG6B`u1<584+KA%XE(7o%Mp zzQy900d#yU5>dS= zrE$Z$^{%O%h-H5L#^J?SN?!k(7U92AAS(C%(YSWO!h#G=XuRUR}ywf<d`1tnb>Zs;kg-v92J>&z#z^66-to89=bzH3G z>s0|8r1R4(s9w2RuDnD4$Mz8w@7{1xskpvcajm{ia4QROiSzJBDvS6FwJp=xRM(sC z#)QD{wys%{LpF+`E9?6Dn-}ctSFV)K-6BK?O15tOhPbj}g>bEF*ueI+vOcz^uD-ru zoyxs#&HB2!xHK<139lyy#pHJFddfvTPY!sj+PA=NoE|#0KR&;8wDorcD`@&Zf`^&M zlN~8|N^Es~iS2?lxVT#pv*xWG2gJp15pOssk2q2iw=KP`;`7HijiVFqD7>h{?+-lV zv~;KXJ7Fp<9$mD*IptkR`62?Pbd_kWsNvGGgN~%SqskwR@|8?X2k4b5seGQ&F58rm zaeYbgINk>*u=GEy{4~*n(1Wl;hx4Fr7?StGak)55{V8)MWG&)Zs4e^V8)~gPA=H}i z84lGt;dPK^@U%oHxa%OCeDpYqRObcY%NymE?iJ4U==@MXz+8QdqzyLrtM?sR&A;&O zO3QtzD9I0ArD(>l?dcURR6LKH@KgicO?URE4s^hwBhEoEC;Fee&+F#V>uXupmp;sZ zLK!EK`WOKmW2>Q@2NATtt$sM?hL2n2*NP*#KoCG&Zmp?iZb`~Fh=7AG#qZt#LGzZkv^-&;Elz~QweM0p$1<=qLh|LD$+eZ9%vL(vCultDaU-kIw=-gIel#j-6;-x;ienUOJR!Sm+aQBv-yLNqIPjuz4@7;25RC?o8 zQMm2et%LXMWtR8s-tk~Fu~HcJBd2lK>jd-%aE4~U;5GfUdD z6UPS3Tq*j=Z5%nG<`mEaz-w~eyJy>OVG1W9dzwE5a;3k%Z`bbox6sS8%P#N(Lom(> zpi6E<7pVIB=*sQew%iLQDlX}d=1(E}`*!UjcXuP9csKEt2R8*P%K?LzfE87Q;seQ81UNZc0r*OQQ7Q^o2P4&E;H1Lxm~5aN$G{b? zjC?qSFINom;S|2|aFQ}ltXzC+_=@rpUorONLrX{yxff_N`OvD#l!sRJ%Jk(aS*e9l zpiA=KZHG(p+M!FU!6!mk5}%@y?Qcm1aKhIL;6$2Bz^(DL{v|==UWW5-Us0Zy26w3z z<#NhEKS~Z1=>}ZrmCkpa?-uQ~TsVVO`n3wm_muOL!5T#GT80}Q8Y;k@aWWQnc~1X{ z^CyddMu{zSIl86qKmyf+3TIq~dEQn!f9(9R!MdaroZA*4ydDhx*OfSw@nwsz6dcl3 z0B7n}%2Ag8TS*MC%9GQ_yqilYJwb48wNpU_Yk&P1K)**i{21(%!lqR(TlfbwuzwBY z$d?bpEqW31kVW%2WYv55*Njv#+b15;cMqo+A>GdW@XQS6NC3wG{rLKkS6mg4}rz zLT-mEjpqBe?Eb_WSuNl90J!Xc%U&3O`NG7*Bhh)_bQpx+O)LCFr|p!_)0d8PsmG<2 z_zTdA(6TU<*P1!ynFlZy*sz9`S`Zx`yL2*c;l8)n5#Qo zolqK?^j-*{fnKt0oR3kO)e$|REi0FbV=BV_d6M&1ZW8s zN`)}Fm0Y}XG$W;@ftV=1SxX}3#QDA(g_(Vjc=0k>F(AM6*FkeF`UoG*bm#iN|&xzuNns2ihmMw3%^j1_41o5ac*&nx5XSp zD30@4;v`YONUFEqziaEiQe=xuvE3$?`4aEHGy%NsEEhcR8>M1d<0Z1%VPcup2XGDZ z)6C&5vk^5Ep!7=_Kg1U{T=LY`StH)-8E|tseVSR2(}h^){Edla@hMh6F#$59lIZ`# zglLe!hfP4ix|=nz1g8M8&%4QGe8S{esEmQ-CYBW4gR#|5e0F2x9)l_j4tZNlh$XRYBg*P}^IWB9;?7!WEde5SKp- zie2dv{XWx}eA!!k$pnaoirkmoJTJ)S42V=e$`oibA*Nh1(i`C~SDYfljN6LLcvZeQ z{hE-#YkVQ~q=;Sj$N1_EzyPZPM9f&eUos(i)g;}$ttLaxb(V{{sA@8Z%9bl|lxa*I zpu=-y;f8<@{6$4_wu+^V~-=^gvS4>GTt zTD<|=N?05Yl;pro&a;(S7>===A7KE?Ng}SZ`4#R~L}Hj#!MeP_9KD2ChTm{Pj(D?b zz{hF^+>|mOFj*BE>jLbRZJEKIC40RApz4f3-*WrSDOuVO@|}9PrH0@r#d^ z2x;iSbp`=R{$EgrPZN>1r>e9M7xImKlP6ZbiTW+` z#Pk%T{60hU#zLjGB33Y#ql>Q@O4WrB=o7?pJsS&Jpbm-Lj|g?RbPGcbYbcN>yaAjy zjd%mtvq^D%R23|ZrCEg02T!iEY^5Zz;!=?7(vp~>ASF$RC@!Z`9Hw1SsK&l!(tfy5 z?DtB>aziZEkrgZA|wV3DKYh4Y{Wn z%Dng?{5ZiEmHQHIj4u61KACQpOu&lT*!uw(F{mHpizyKDxb=U{&%-T%B8EwH0Zd8^ z9#SAdWqV1=iG;`=HWUAX4skUO+YOAQCu=OQGy?{siWDORhClLRGG~6i0ElJvBP@q^ z0H{c-1P-W`842;>!Hn`crAjkuG5BMAVU7iRFliKw{V2hhCgk5{WZ3aVjDGoavLw30Gd9WD-(Dt#CEw zx28q*JU3go`VAM>@TI75Sz%vg;H_}UOo)7BV)^-~fw96RJ(1xxcBKC0L)Rr-zXZfq zxTH@+o&i}>8|19WUu6EKK5k4!UUx5X4{0HBH>q=Y>-E=dD9o?FIz};A#ume3bTnbv zuUd5H!1_BxoCeif8VqE>zad?LZLfJ9Yo&d(ZKikSws;ozbEeF;|IN#Y5S$nZyQL>0 zj|yVzBN$=>ly!mkH7~T#cZC+!ybKSQ0Nr(W%s)*-bLrX`Alt~@8&VtJxuMv8KMxzL zguJz5sk9ybyhK>GP8+hvg!ralD-mk@Z=$;kMPHRKA&VTDi0N*i&X<_V5XoHHh~Cpte=@zZdtI92uPPgM%cmW9|$M?8IpVy1M-O*Qe3W?g%UHk@FTzcF4=jr1ev5E z32W5$I(L#d|D3xr7M7Ote}g=(OU?^+PA^<9wt{`wUW3hUSo%bkjF!qIqb0^Lu0oCz zy+0v2E=yX9MIOfqzMVftXg+{m^gH=N<5sN#WD=c`v_e(2fpLbKfM3Qo^49A@MK*kh zs7lM5D=d_^l8f0}h)v61W!wnJs)J?u2$LHAtj6nw{6e{;5U?aE2Gd)b1Bg1%bRy-Z zdeU^gorttR&5d*3(qR=7_@D_uQB`FQnGoUtH$qR{5C(7c5qk=diZ0{0pa2C(p)7FrR1ONE!g z*jM=fX)?QuFA(FvP7`9X7rDM}-kXH%U%qKjNBP3c{>p@y>|OOevxl55dBlL|0OyZP zfK6kWYDiv35R>y;;n~w?(t(okHkQY4h=uaJ z>wmi;r3Ax_2^!}Y>sm+f8hs}Hi{Zy+C4C6RKy z|0}uF>vFoa&GelNB^!?M1-uCSJzp5&lQ~MG%u;SjDef|PlJ%6zXH0;P2ygj*@&2;q zBj+*Uah2vblJmiTZ%8D~wvw-VR5l4&`d*?Ixm4^>hcrxpmkaOxQc*6L*)2(XYx7GF zX@M_zN&6ryAGhZcQ0bnT)T}8J`}(6^)L=uvsJ##_QW1DG2g2Fq4Jh2Pxb2GFL4i@* zZC8e46chH#YKe}#%gIf}n1OZ4pAs|Mmvo4R0jwqI+zhh|=jkp$!$d>I;1O1ugrs~Y zLzzdRqZNVsO{`fX6g<-r;O>s}2!CPVB_G2jEAls^M_Br8lc#i@;8MUU|FtwMNf{6Z zkeau)@o$Pj{z+#@{t-1~Q_KT}p@lX_0z#t!zYBzHcuS4KU}9GwRm1>MnNwO;)$l>h($ literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/fx80driver.log b/internal/test/i/o/Hardcopy/Hand/fx80driver.log new file mode 100644 index 0000000000000000000000000000000000000000..ace39487a2e33c3ce0615eecccf8d98a9d80f188 GIT binary patch literal 967 zcmb_aO;5r=5M91B-KYl->TwPpg{biW+=yT#0WUPjwZZ_KtX;A#D*iP8f&a>xD%|_z1>zyD(`7jt>3n-`alalMltlvOnTigMypk{sJ3BRLLVm@SFED) zTFZEDY!hCU)-VXor}WxEj7@leeqhIQxNFqw5?o0Mq!^(!UnI1#nyRr1G_Z}@G~)tXQgY4|)JKFx>E^5G48y(o%w z@%E`I4muog!Sl+Ap$;e!aKs?nIbTLZGRPqTc1XGKi^qoS;+jklrW|i6C){Kxd}uq$ p-tf$FK6@E%hRe4(0AR`PlWb3dpQ&AB7z||W+>glFe?{Z_=MQZTPYnP7 literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/streamtests.u b/internal/test/i/o/Hardcopy/Hand/streamtests.u new file mode 100644 index 00000000..7a99e603 --- /dev/null +++ b/internal/test/i/o/Hardcopy/Hand/streamtests.u @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "28-Feb-88 14:22:53" il:{eris}i/o>hardcopy>hand>testfiles>streamtests.u\;1 7304 il:|changes| il:|to:| (il:functions sendfiles) (il:vars il:streamtestscoms) (file-environments "STREAMTESTS.U" "STREAMTESTS") (il:fns sendfiles stresstest) il:|previous| il:|date:| "28-Feb-88 13:45:44" il:{eris}i/o>hardcopy>hand>streamtests.u\;4 ) ; Copyright (c) 1987, 1988 by XEROX Corporation. All rights reserved. (il:prettycomprint il:streamtestscoms) (il:rpaqq il:streamtestscoms ((file-environments "STREAMTESTS.U") (il:fns squash lister tedstream setq80 80set defprint pusher 4045set set4045 stresstest setprinters) (il:functions sendfiles) (il:vars tedlist sketchlist rs232 tty fastfx80list fast hq fastfx80 hqfx80 4045xlp) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addvars (il:nlama) (il:nlaml) (il:lama stresstest set4045 4045set pusher defprint 80set setq80 tedstream lister squash))))) (define-file-environment "STREAMTESTS.U" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (il:defineq (squash (lambda (prefix suffix) (block squash (make-symbol (concatenate 'simple-string (symbol-name prefix) (symbol-name suffix)))))) (lister (lambda (names extension) (block lister (mapcar 'squash names (make-list (length names) :initial-element extension))))) (tedstream (lambda (file) (block tedstream (let ((stream (il:opentextstream file))) (il:tedit.hardcopy stream) (close stream))))) (setq80 (lambda (string) (block setq80 (setq il:fastfx80-default-destination string il:hqfx80-default-destination string)))) (80set (lambda (&optional port) (il:* il:\; "Edited 6-Mar-87 15:50 by reidy") (block 80set (cond ((null port) (print 'fastfx80) (prin1 il:fastfx80-default-destination) (print 'hqfx80) (prin1 il:hqfx80-default-destination) (values)) ((stringp port) (setq80 port)) ((equal port tty) (setq80 "{TTY}")) ((or (equal port rs232) (equal port 232)) (setq80 "{RS232}")) (t (setq80 (symbol-name port))))))) (defprint (lambda (&optional printer) (il:* il:\; "Edited 6-Mar-87 15:38 by reidy") (block defprint (cond ((null printer) (car il:defaultprintinghost)) ((equal printer hqfx80) (pusher '(il:hqfx80 il:hqfx80))) ((equal printer fastfx80) (pusher '(il:fastfx80 il:fastfx80))) ((or (equal printer 4045) (equal printer 4045xlp)) (pusher 'il:4045xlp)) (t (pusher printer)))))) (pusher (lambda (arg) (il:* il:\; "Edited 24-Feb-87 21:06 by James.pa") (block pusher (cond ((equal arg (car il:defaultprintinghost)) il:defaultprintinghost) (t (push arg il:defaultprintinghost)))))) (4045set (lambda (&optional (port nil)) (il:* il:\; "Edited 12-Mar-87 16:18 by Reidy") (block 4045set (cond ((null port) (il:4045xlp.get.parameters '(il:port))) ((equal port 'tty) (set4045 tty)) ((or (equal port 'rs232) (equal port '232)) (set4045 rs232)) (t (set4045 port)))))) (set4045 (lambda (port) (il:* il:\; "Edited 26-Feb-87 12:55 by James.pa") (block set4045 (il:4045xlp.set.parameters (list (cons 'il:port port)))))) (stresstest (lambda nil  (il:* il:\; "Edited 28-Feb-88 13:27 by Snow") (block stresstest (il:send.file.to.printer "{eris}i/o>hardcopy>hand>stresstest>stresstest.tedit")))) (setprinters (il:lambda nil (il:* il:\; "Edited 17-Mar-87 14:35 by REIDY") "Set PRESSPRINTER and IPPRINTER to the first Press and Interpress printers on il:defaultprintinghost" (let ((ppos (position 'il:press (mapcar 'il:printertype il:defaultprintinghost))) (ippos (position 'il:interpress (mapcar 'il:printertype il:defaultprintinghost)))) (cond (ppos (setq pressprinter (elt il:defaultprintinghost ppos))) (t (setq pressprinter nil))) (cond (ippos (setq ipprinter (elt il:defaultprintinghost ippos))) (t (setq ipprinter nil)))) (princ '|PRESSPRINTER: |) (prin1 pressprinter) (terpri) (princ '|IPPRINTER: |) (prin1 ipprinter) (values))) ) (defun sendfiles (&optional host) (mapcar '(lambda (file) (il:send.file.to.printer file host)) (il:directory "{eris}i/o>hardcopy>hand>testfiles>" 'il:collect))) (il:rpaqq tedlist (il:01ur.tedit il:02looks.tedit il:03fonts.tedit il:04para.tedit il:05page.tedit il:06line.tedit il:07ns.tedit il:08imob.tedit)) (il:rpaqq sketchlist (il:10mixed.sketch il:11straight.sketch il:12curve.sketch il:13change.sketch il:14text.sketch il:15reverse.sketch)) (il:rpaqq rs232 il:rs232) (il:rpaqq tty il:tty) (il:rpaqq fastfx80list (il:00plaintext.tedit il:01ur.tedit)) (il:rpaqq fast il:fastfx80) (il:rpaqq hq il:hqfx80) (il:rpaqq fastfx80 il:fastfx80) (il:rpaqq hqfx80 il:hqfx80) (il:rpaqq 4045xlp il:4045xlp) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addtovar il:nlama ) (il:addtovar il:nlaml ) (il:addtovar il:lama stresstest set4045 4045set pusher defprint 80set setq80 tedstream lister squash) ) (il:putprops il:streamtests.u il:copyright ("XEROX Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil (1458 5950 (squash 1471 . 1662) (lister 1664 . 1858) (tedstream 1860 . 2066) (setq80 2068 . 2237) (80set 2239 . 3062) (defprint 3064 . 3783) (pusher 3785 . 4118) (4045set 4120 . 4675) ( set4045 4677 . 4878) (stresstest 4880 . 5152) (setprinters 5154 . 5948))))) il:stop \ No newline at end of file diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT new file mode 100644 index 00000000..d6faf8f0 --- /dev/null +++ b/internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT @@ -0,0 +1 @@ +OOPLAINTEXT.TEDIT Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. \ No newline at end of file diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..0d73c162b4aae16e89149ccad93deaa7fafaa66f GIT binary patch literal 7339 zcmeHM&2HN;40eF+Py;*dx&t4eG4^vCiWFVqb;dj-jU8+|Dh^!>uq9Wb+h#+t_uA8q za*F|dg5*FSY|)bVkpl5aq~5;UtdlZbWMv%3xvf+SmF@Q*;rF8W`f!$K#p-jGr^RfY zUX`%ge9E&qcdnO3`f#>Rv&GL@u}bH&QAM&?&f$Bb2$Vyh2EpOYpdEH-$U|)%cy+7I zH7KZci=Yj+DyMvN4v+=GSl6))`SNnPDM6VXY^^1@)7033piFm~*o?=nt4&s(!vbq< zG-+!*%$3KfN8?$(MS#+wq5v3-8TuaGsI#?q+^Tr62V0MwUUdj95``ficG~m2ioox? zt!;e*kS5m&=$ei6s9e>6Cl^##){xQ+&aS9l6Py3zl!Xyw8bIKl9cWv2j^Jict*-Y0 zLqVsgYLahyx8udw4n)=fEWQbYy;1CO@N;wp z>l)d7hWS4=^mWg$7*4^5XHZFeB4Hq5kO&(b2OGrkf%yQ04ulSv4o+lWkmCXJIVc8@ zP>@jIP>`KLc7{L*k~j(-pd^k`Kj2b@B#uWC29h{(ZA;3D2QMc|;&>#4aOgUcB#v^$ vFy3ZJ;&>dT<--#~9EImaG>KkEFE20VUoN6o(K5vg+o2`oYnMHLDPiJ=w-hs06a^)3ycA$k0j0Pe z%TnZ`Fd7n7g621}xB?D|%ml~+rMToeJp%A)QK&LU4ncSt_9NiM5C%#axRoYVV*`;l zlm=-`wl4dAbOddY$U+*a3Joo;#jX~G#`TQ=h)Tf?1tc=#(MXh)&rIE-6r-{Rl~kLW z=K?Ze45?@sN{x200ezPbRHj`3&%JU%CP-2XUdAbCQ4)30Xa-9u(4D2y*Z8cbqYT!5v zt_NVtfh`AE4mRv_!M+{{d=GK}>`|~s0gr-xGT0{r6$INj+HxRl<7npxII6IXTk3qwzk771$z{F)&i2{lBHNx-c~ ok literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..2c71beda9f77504618fe643894f5e09d34bced20 GIT binary patch literal 8396 zcmeHMO;6iE5M2tC#x4D#s2nPFRP_K7q)>W5h=NkbfQ3UKcKUJLI2&Rqv4eL5r7f5K zhTi&1+WxuDY}^n~P>}!2Dvn$HwCNu>_NI1`FP3fi(BukuDnK;_ zq~f?6rJ^ljC83d|Ao)oY9|4C()DjTIh{BZ1<`#fU4{?&VQG-|BDOUsFaUE(&qTn=A z&7`X!aO#ml8NI2)svB%UQ8c1BQc)61u(=dVQp6IUPXs`a3a%(1iRpGaBGo=y$tj`` zjU^-vJt=uxKuah^CKBqA#C4$pdDgBaEtv;!@<(}y8YofnQQsq(gQNM0LI0Xz4vshDYI*bx!D93` z!DiW0mfLl__fFv21$Ix<^ly$$2X4vnE9FvQe}JE5Q?^&|eb*jNPG938oM-f{t6KiUV`ejKa;ISL4i>6UWvd6R?(~X*@%vU;g)y-{l`R}X z4KBP8x5ZZGi_UhT>IL*GGOWP776mKI3;*C6qQI$?-2H+FYYPkPLLFl^$(qHnM}W4% z6akWUpTJ!lZwWlX@r?i({~zt~;fo^TN-$r;r#e m153?tf%Y@5(;+`Uh@r?w1c)*9VQff!-emQ8_MH{J{Qe6eY#Y1) literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT new file mode 100644 index 00000000..5fc43559 --- /dev/null +++ b/internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT @@ -0,0 +1,27 @@ +04PARA.TEDIT + + + Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. + Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. +E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. + +Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button + +On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. + + Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. + Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.ÄHC What are the requirements for saving a file in a crash? In a normal |OGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. + +Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. +Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. + Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.ÄHC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot wit§ÍĂő t÷Ă@ Ş¨@ÂÜČčłú_ý€đĐ˙WœRŁK{sÁŤ4WÖúCŠ/.ÍŽ „JŽ,Œ.Íí „­ ¤ŽL$̍ „ííŽLd,lŽläÍ „­ d.Ź­ „­ŒŽŽL$n„,mŽ.ÍmŒd.ŻMěmΤČĺĚ$Í $ dŽ,Ln +dŽN.Íí dě͍.,Ím$ d, ..Œ +‹$ „ííŽLŽe,lŽ ä. +Äí$Ž.Œ-Í,$l$ ¤-Œn ÍĽ)ŒŒ­ DŹŽŽîÍ +äÉ +$ DŚEŹŽŽîÍ +¤í­nŽŒNŽln.Íí Dě +DŹŽDA (self index) (* dgb%: " 2-DEC-82 22:14") (CAR (FNTH (GetValue self 'indexedVars) index)))) (PutNthValue (LAMBDA (self varIndex newValue propName) (* dgb%: "23-NOV-82 00:11") (* Store away a value for an indexed variable) (COND ((NUMBERP varIndex) (StoreNthValue self varIndex newValue propName)) (T (PutValue self varIndex newValue propName))))) (StoreNthValue (LAMBDA (self index newValue propName) (* dgb%: " 2-DEC-82 18:35") (* * Store value for nth indexed variable. Used by objects having a VarLength mixin.) (PROG ((descr (FetchNthDescr! self index))) (RETURN (ObjSetValue self index newValue descr (ObjGetProp descr propName) propName))))) (StoreNthValueOnly (LAMBDA (self index newValue propName) (* edited%: "22-Dec-84 18:29") (* * Store away value for nth indexed variable. Used by objects having a VarLength mixin. Same as StoreNthValue except ignores activeValues.) (PROG ((descr (CAR (FNTH (@ indexedVars) index)))) (RETURN (COND ((NULL descr) (* Here if no value set yet.) (PROG (varLst numVars) (SETQ varLst (GetValueOnly self 'indexedVars)) (SETQ numVars (LENGTH varLst)) (* First allocate space for any vars of lower index.) (SETQ varLst (APPEND varLst (for i from 1 to (SUB1 (IDIFFERENCE index numVars)) collect (CONS NotSetValue)))) (* Then stick the newValue on the end.) (SETQ varLst (NCONC1 varLst (COND (propName (LIST NotSetValue propName newValue)) (T (CONS newValue))))) (PutValueOnly self 'indexedVars varLst) (RETURN newValue))) (T (* Usual case.) (ObjPutProp descr propName newValue))))))) ) (* ;;; "Class property stuff") (DEFINEQ (GetClass (LAMBDA (classRec propName) (* dgb%: " 5-Dec-84 14:47") (* Maps through a class and its metaClasses in order to find the value of a property on the class itself. Returns if property is set, or NotSetValue if none found.) (_ classRec GetClassProp propName))) (GetClassOnly (LAMBDA (classRec propName) (* smL "24-Sep-85 10:36") (* Maps through a class and its supers and returns property value with no activations. Returns NotSetValue if none found. If firstFoundFlg=T then returns CONS of value and flg indicating whether prop was found past first Class in inheritance chain) (COND ((NULL propName) (*AULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))  +8K + .‹ş    Ď č   /B Ç}őDš Đ #”fK + .‹ş    ¸   /B Ç}őDš Đ #”4ˆ}zş \ No newline at end of file diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..b2193b8cdbf86d7bc9f5b9666376563684c36d42 GIT binary patch literal 9942 zcmeHMOK;mo5MDWPQmaj0c{GO{2FQg1VpWn~N)gzgrIk#W5@nK#lip}~6%mj~hoq9a zh0$AqqSyYHqWJ?owtu7d_THJL9+YFHE)u|QOBqYgemlGK&FpZ=T^80_YMtk8Ue)X@ z{(yeE-*NiT@sEzbfN!eS?#UxvvsyJx=hmjl_iSjjw{@+8jizDolSd}ks!unq7O!l| zf$~+O0{cBD0w)j<^#las`Opo-KzLCIT|a=(dEt7`z=5vY7vOp*bpj{sZ2@Rh@%&(b z9CV{@v~6&_LpbpL2wu8T&mTr$^Fud68gbKJTeG*ID!Q)cMy~ILP;o-B911VQ`U?SI z2f~TSAdwj!9f?4W+4oS9h$2!6;m{4SUnhd_cyQqN!#n`bKg)yL zMUtU#f=&;@D4?M`z85(z8b?>0BR4|&Paa@J8d)YI@D)1H@1t`OJRdrJw|h)B92huJ zrgq%G?TbU>-aO-uWdgC1|KYKE>ETC-+=qMGWqR>^^7tER0r>(uK$6my^y zpaAQ|5^OvyVNH>J#^af)ZWy~3D0^+S3Kib8xyh?JsO+fbsHLVhH2taUU_9ogt~EIr zwHg{SwOvkMB&pVJR+DYI(c)n8dRtdb*ymb($A$*J$F>_es2OHMMT!a5$g5N=!)h5y zt$G9EypT3R61XLbYq{JrqNKF)aNqCWR~eU;(}p& zxDKV&0<3M!3EfI*^);RI$L{Rhil^u@M{>mbEwU?@llS5xTVM(+FqZjF*4aWP{(r_* zNn&r%BekpS4!gy!H4MCYn(W4;=VxqbhwG2ItyNU^!34g`ZrECbTQZFk_-%H*qN|pr zRn7*d1J8~y!mltki;pZKeio6_@O1PU?RkTba17vC>IpN5hhr{uO+QK|Bp+Scuw(X^omiX;Wa0;XRq;+lmkn%U5r zst#pLttmU=w19t%$;JPU7@EtRkU&BElY~XOjHX2P zNdi@BBj9HesE>3Sz0bThKHe>{ip)E5K)OV*)FniQ^(qQfp@B2Mk?_VzCpV>r3R2`10I@7cFs GzxoTzpa@3* literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..fcfdb9085bb6227f65aa2dae626b085dbacc85be GIT binary patch literal 10358 zcmeHMUr*as6u&@ehqvxu+qK)e^`J^qB0-b{8q%qPndBx|IC1JYrQMqePGc#tA$I84 zgoHF{d)!Mu&EBWI?j!7RA7I<_&bf|>1IdQOq*7|6YmR^S+;e{C+~e!q>vT?4syt=z zqGCvrq`FPB15J1L;7jK+q$>4VNl|%yRp*Zls5RDArGTBfR_BM0bgmSit=4P2 zuqsTXidq4-+NKX?&jP<~LC@Oj+dZpmIlc!iw+EiNZ#&PygqGd0z;;k-_Drw62B6T5 zEch~9(n;rKBN=;Puz-@_6&+J;zv3#FYJlL^49M|;0JLqn^9WMpI zQ_oXiw~(Y~nZ0HkJikY#o37)VHaf>p%w5|@`cD_|MmSj{C-4mh(CJ`sKJ4|)j@>#S zA0~87zu8Vz?42D<#&+NLT?as;JY*LKw_UgISqre+vpkQyZM%MZpo$iJaGj7$$Dq14wM@rCY8SQ>GalIG$vm|ONR6)ELT!_U$l3ww00P$)t zc{O-*UJBA&{93pW3&N{j4nP8kOCc@=D+Td}A>J@}SO*aQR*csJE8aMs`}{zPcaC%t z6(1x0AIC`X&JoYH-jw6Si+h?FZyeA4TDTO)%J?fW-Z;jkfFCpBjbr?!i9Tx4#!-?O z{mmrsL!$wSL`^Pps46O;RO5PG`I>_ooWGVdRne4cNrQx}%j-%Z33Wr(4W(M9QTHK} zghU$BkjrFY+NWwY4mvM4R9S~Du9P!e7A{vap=XLvA@As3cM8Z23{OEw1ZYMXu7Ai=2~Drf0|t zrtM)4vdd|BureWaOWEa9I%m(__}U7l=ptuw!22B4l}w6fah6T91WPkE^@F%)(^J9! zG1o*C`xiY@yTaz#Eq1M-%JsTZVAlsje`jkflPL0%+)#~@Ry804iL#6jC1lbVO(5bU zfDedXQL3^Ed1N{qeurH*lnSqldJplLBQ}b^6SzbC2AdT&*#Kfk>^7U*;OY}@CE z{2vY(3=M~>W1z22YaOwh>}o~BC8Zj&N3LTjvGGBndL*%7SR-Ia>7<1LK64Te(>0z5 zs*ms+S|10WGCokpvKps8eUi&SeG-n*pPJGLG~{-y^;S>|=>HfR#(NA61|s{DP;}ss z+_}m)U^I=79%JH_I4_U@Kz|G$9{QUAEKwh6Y?AOXwreEZ!S*f*x3Q&20Bj$S@HVzN z5-5N@66o#=5-2?{NgzAqlKfK>!22Y8gpG`|d)P$RJPN|q=O~DzkOz@gLWIsO6b`Wo zaykh&=`!%}2Zjx@@s{N;Q3nA(>_rS itA&F8B?`Pw_4FqZ7t?lW>gfT6ghhDwd-l_}KmP+l*EaD0 literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..fc74cbd5da00c0c3749f1a7b243bee6506ce03db GIT binary patch literal 11263 zcmeHM>u(!X7C%WT&|z72d9x2VZ7A5#n8ZmFx68J5?QuGE>`BJszIaZYF)?yHsb@mB zbc_0F_aERN04jlasjTQ1kN|1fWwk=Q#COUUBoOH8N`M4>DCb;1;yk=mq6?u+r0bmd zopbK_oipdo>kf?z^=gFA|odS-{3B9XN+xPR6S(QSAb&U)DJ4lh(2-kett1FZNB4BUsS z^#{?#O10);wN6sG;Rdri5e+`5`;9r`U|JJa$w9Y1gVVkr;*n}N>o0`p=rh%jXf#z* zCBxZ?S+7#9SHr4b4>02f-eBO>13G@#Lv$LR8*)Gu}Cr z2)r#g-|&KfqfPtaY|E5p2+^;Xz2@w*E@jMls#Ls6#UuI@rsK-Gxh1hEoQoq%LM5~f zQ5*Db1HEKhlX|+KWz2N3Xk@g%BK`dn@eTU-FT{T%zKQrB#Q!2biuexVDea!&+1NalX0?)QR z;gF2UL3y*Zr3rcX2tI|^K!b1P)AD(FQob+W0s#`ffjiE^FQ@5$PS-xVI8x(v8gS#T zfs>mbz2&x8{Keb5du{N~s?WrT*d|PIpBNK)u}>Tl2ZRI1;5cX^DN^DtalaTBme?=u z76(NM?uL8Yogz+)f|wH-@sRMv5%Gv9i>JhM;(78sEo@N}yOrjsI3}jsnr3&3mqZ{A z3r|c6T}%iAK7kj=>m?D2hL{mkA}exYk8t5RvUiNUUbL+|Eh<_TYo4yUfn1n(9!>j+ z?>!jZdV1e_&hy21?LL5L8=^;$=t4@)9B?iP?v=05#dLBM2J38 zT)5w=E{IQ6Kc~0$=)I9YZ~lM2Sw`=T(LYi|)_Q>AnkGkU?%Z9N;u%$~H}(&W;4 z!#t=QtbMv|8U-D#T#f?S#$KIwzxk+C$ad>Y+I&P?pD3AW8~5wR#2yFpw0mF5$1!Kw z`7}}NVokh~!zmn1VKSA%k+C?3Bhb+gI4ZJAf1Gki;^--_$Ym_ci~o@*C^M{)Zi#T?CuqdboUXXAyqY^4`@0Khp!p9{35k1};H2T)JdBIji8{Fvcd*wCHhoh^o~TX^GJSwDU$GZDNWlvFN^(a|>U0Vs#FL zUj^&coSpPez;&=;k8bYM9V3(O1%FRKz{QE%rmH}^R$85atKs6jMVG8XCo5Q;60DvS zRkEwF?X$K7Y*Si3L%Uqd@zx~kRwuF?UYvbNC3{WY!l`XnGw)x{rDfg=r|egp(k^I` zTgU3sX6sS>4z!qW2U=vm9O`ylB=>{bxXGxWmNvj;e6U#|O@QKk4=~cU*vrBnX zA87oVh2PUiuy8Yt-?DH8jSVcY{xA!Cr@w^-uEk?4@H{}2IKJY*z;77)9gXW*7@*Oi zr$TKaL=}Z2sIoGmY;GXoI1QEI6bn4Z1PfQuAd>w`p!RAa6mJEkh8dV%7c`*%D2Cfurq@h&Tl5i0t+$o9;!&?}+h6a%U;H++EfvK;gwG!zN zRb^r?l^(~Ta`vk@D%O>46(^unoJ~ii=3$!-q8f(za7yaTzR3b3JTZH#T6Fi+)vQAr zU$MZNzq7yv`GSS@{L}5+4P;rzK%E8lQGLg=s55>O1zZtP(Pb00{B9&c)tWO=wv4E= z#iilqq3a^_y~_f7Eg{nlu(`5OWuW%#8)ze{i}|cq+KA%GZLDIi;q}qCohf&BuPRbE jaK74kH%B^u?eis1x1N74nD*Jq$xzST_&J<> zBsj*-o;Zv|Gv;Jqf*aQchbDI7WJt#8q-my+ZBi?qq@ig#wL6`uz?~+}q&+rYV_K)~ z|NnOPZtrgQa1yt5+Wj011A}bW$jCVR`0)7NkwfDw9vK`Shct9icV9HVnT3b; z3?CRCA09a{#kv&{E zHn4w)?Hd{&N0l))I6MY+yT{qsefxKf>>FFdSY*vd*0A9{kmT6V!07J1Y;1fKUGE+_ zFg`F0!C@!^2ZzTY{T;VKhX+}WLD*p!z`lJjxN&yxp@DtFd+x&+18o1m`0l-HI)(=a z0gPRT#>YnvFxG`QG_5we`$rCq4c*2Ljt-5DVYFQ%<9iKN@G#Cs4(uM%z3&}>5#u=d zP=@yG8G`g7OvV&t`*UJJxB=Fj6KYLmMQIs0FM~*5Pgg7w?5y0<9_;OnZmB%NpuE7? zC1}3Q*k3dDB4e|Ry~NmqjD4T6id&R%PXzZxYR`1+>jtOzYPg zv_`E}>(V|<{*}D;CgIX2wXbO3(k^Rr+Ij7w_E*~XwSOkRBG*YJp#;k;{OQ!ZH*?Ay z7xPNYl1Q;^SC`ONf24ArE^%Y2<+V)DbaNtrwQgtF$VtUw!%0Ij=O|H*s}>vX*oYH2 z!+Y)kHe82f;^i5b*-yT1U63R#*wDI%CzUg!pqFB z=Hj-{z38y!xlkr=@?Xo9RJlcE3MDLT+F*X5&=Zt2LqvM%Ai zYinz09Zj8!)sZrKmRjS8WwInEz7mvbYvd`zhPxESvZa!&b#qDLT234(1vWhmQmt1` ztr;f+8V~{O=vqb5F&y!RWjowv;dE<@e-4=ptIWRRcGrb*w}^0Mz`%&HvV9lj^)p1MN z*XMK_bm^|GzD0$Dv|6q^6F8L0+282=X|KOQpi+_zntK%wCeo@;F@M8VS}tyiYlb&n zLQYJqfrFG%k;M~=HIDnN+Pq(n^TAXgfU&s=WF4LMq7B4p&y7Rc9$pe|`1z~HMaWv# zy%}+ITcg$`=<@AeZ%nIxVWPfOIr!?2W}nz(jT1QQS{JVkbT`s7w8`CyxoSUjhR0cy zSQkJZHzA^!@Q7_-192*HBBn?wOpeO|3&}r>olS=5gv1s7b22-$+PE#PYpWb&Cmp!L`>>QV^%M zv9^~7?9GoOHi((!hB*^3-6#>g>cXeHWUrxE|*3oXaI~JgF^%)ui8`m{`>!?|HNmjvT z^Fk^l!3Mpt7I>bW}E=xMIT)k(Bs4)q7jFoH@S;v z9o&2}0oLfvzR)6)X$)agim$i&lRs|2Sd=|+T!mJ;B!@Pu7)K6D%N5|z#*~CDNWu)} zbQ+dhZO=4Bk~b#!6;<8eZ`>K+>#aT^M!1dd37LUSncpAV%-4Y&6!=o4zLX&e??rDI zM^HhPP_HRDl8Gbp@yLydx^AGV>8V~b4n-3}S!$jNtsqYX^{k;|Q{H~u7QXlk+?eR= zZ+udO={^#yudkn7@f?gtVo5F$ClnEgi6Bd*=KC4|x4OWoMue^QRQF<++dT~nF0ptW z0h@(06F3X>^@#_oY6v+TTq-{?<#Tgyi6BbEHx&2Ha0U(1dbuK3GNIH%93et?wODW_?YrSk_ja+!;m14O4yHnBMd0eJ7X^PgZ z4QMO0by`@9lMj$DkZ+Jm?X%ifwHfViwJX}^wXbQHv>%c`Ab&}|Xuc;&8Qo)-OI~WF zZV7=B0wn}W2$T>gAy7h~gg^;_5(2*s0(j?fgCd7+paAzDEJ;MAxSAN0h@`(K=cp)6 z$OP^sixznMop^7Mwg5M+;gC|)PZI9jCX=aRI#g;P)Lqe7Oh*8C1h1#Rn2w0>gncu` zbQW=VqDPDAG;(-Ol^4?);PBi!UoE0E!QpAIE22Vmc+NHz(Q(1MN(j$j5uI`sRtLZ{ zTSSMyg)91=D>fHPxqb8~E8?e>%TARmMOM&0t^@ECar83RnO{c~PS{m+E$2#2a9{0I z1U(iRw7Iu7ZA3j5nH5Y0_+f1sUHQ<5U{YMI9CS!*|2-G>24iCINA~?pP{e~Y&Oqs3=+8L8m!AvT@ zrK-vCgiR{Hb!8a7$qboCWM@0-jC0235tbpH2a!&mdwzO#I&S~6h{q0y++On zXB{EzJ*IfGnhQ3z*}j|w99J+ctehm^PU8JYNzDMGF?oEhL#J0NK_{!Oh-s=7e&eW ztvH0IOgatl2u|A!MOXwk!XpZxZdU}RnD9uB)1jytcqC()6!^k55t||ikL&;|*u1jSD}5FW)r2XYXSAVheaW(-d9^CT4IU~jL!Re-m`9@9vt^h#hodJL z7X7*@Oq^_g^h``jFIR$c8k}7uc ziqeJ~3!#6ksEm+AMV^><)oH%5xBwmn1`m^8P$*??9JH`pAgW66s4Xml;zgWm+C*G~ zaMaoqQN4sX!?z`I4Z=}tQ!3~r`gb$<`V1ir%tnQHTr&C>6oP9|P%vM@UTfgtn)K7dhSp;bOS6G9PZutF-o2sJyH!kHB+G_vF= zAcCHGR;p79xs33ryeFR1nR&HJ&l7-0=T<0rQr@M+6@ry@PL~;(=P3%LJegfvw(x*O zrR5^sb}B&UX5$#d0Jc*B{IyI$F)z$$^P9bjnqh@9R4#EjkzIU{zFnc`h0NlE!^5_? zLZWC21c#ig3OqMc}9mYMNu*tW!X8DqN=Jf9*30Syhf=x z2di?7Egb>y!E-6hzJ8Tsk(s0j_$aahUBPei@>_&QWfQ<&Zoit*K$a;9ijqpVpTn+g zVN4(slADyDQEcVN1bEC5y@Vn$F+lIZZ9%k&L`su2qd;n{2H>!gc(K}D*JpGGObb6FQy z>T()Uv0LQ}U<2@|*yfb^!e@B@blWbSkBcm?EGpw~4!We&B?U#W@xqAQQg1YKuEpVCntC%B#>TYl%PP6)bEkNguBM9`qL+e0qM^=|Fa=^Zo>M zmR#vsGHD#hRu=|czX^zq&tKSBra0 zP_ttZT%pa8MQ68L7HyuIhr#9P4BVKX7AEsVneJ_%b5wy#W`7xYv@bgp_!^c9vRGA< zy#^r{RU$+Q*-F%!K_{In6Qpc{k!L9J&!RiK@{&m26ISSsezE(Eog8_ONu*{{6)w(5 zpLN>0=_;A{-K1vOrUDMJFa4GBSchGS?=TpnPu5!4P zZM)>4GjAfQR)x#wKSs#(!%jNlDVWo$>c1d#*%AjGvEo)zA=j+vAwsytL5Fzu5fAgP zfg^Dek9^zWdl@#<*gfzTk^ECz1z<+M4yWRCPo;>^@UoN6se=n-8ti7U!CZ9Ep|{T6 zLga}j71&_lWnVgGzM(XfwX1|yIUc8D<)g^&%d*VH8c2yxXpC!NlD ze`obqnPNoUEzKljSveh`07b<%099}J(va|P{iQX&1V-<=BLxk5OhI4LO)Jlf-B zAf@Y7CmnKs(}i{gr9+M?WCHc?XNHHFRBB3!l$pTpDC{6YkU9PKDD@xl=|?D<9=Y6y4e>K z#Z!hOB6!D5vErdX>6zPZkPcjG?YNJ{5=DrTMkhnosM| z+DQkwLViNN1;0M|Pwgq~OWFnP2ikW@nrP%d$ot9X^!xPOE_kpPJTxiu@T3N1 z*@fi~-nz=a@+?n>X8zB|1$-AC>wAB3MU@n12ezn1Py?@w<@e>6Rk{&@Nm>D}qir=LlG2`s;s z?n&=Uhq&av^!@2wro^y(Ha(WUH$9Y&r6cKW=_q-Pd>O2sO^>HX(}U^mbU3{=-Ig98 z&wzeB+7apP>FR(7Lc#KU$EV95e)jHsYFcIG|M7FvSn088&W}xdn>S;4s@*&E;dzx6 zrN`%$o}xGekBh8ith5wLO97Tb>A|X{2dj?pEunOY@V|D6Pi@o=v?r8q983R^ga7jn+!87) z`A2&$Km0?MID=>N1-C_5XSAIG6^r!rM(>KScKzOJYgc=;E84lWi}`~+!BBL|O4b_> z_Qa!|+t6wm3#?@RM%KvI2b$Q1jZM(=a~soNPq4kK>-Jve@9qnR*_KFWJkk>huVh== zf<1<0Yp^5QzLOht-4W?&k9I~_*Ve5Ns3&@R1pjjj_WC-*R#`jz;|$gl+1A${>|u9C zqTAZytONe@Okc-JwzaFLBM2#4vWC2x0xfK93u|g=Va@ATVmM&NBRk?eG9Ug17()|V zyS|03U)!RqtOTXEhEIFfosk~?=?&VvlQGH7^ex~5ux(t=n$|Y5bsHR@Yi?Rwp!3$T zvtL{K6upy?H1hr(R@cgv{8%i5@9O*UH^cNH{bP5*?tAIF$gejy)I$Z4EQen!S7kq0 zB=Zex#eomsqPEp%4t$l=l6l5Qu%yaxK1Vi_fIl4B8tiM2Z|&-gvjFpN3&KIq0*!!{ zPQoDu2VhS}v@_VwS^$Zxd2S8{-=*5;0Q_oF#(idnr;_)Qind7m9g%o+OVEjZgMfr( z9h<5)ETvFOB{ihHqYJjI&djKYeM-cBP=KTbSaa5Lm}W}(9!$9M`GymheIohntoIxw zotztdShjZRLVhlWx)UEpUofQ>RyMbcmZUE|h@W9)$D3hgv(IN)4YSGpPRm%&2!2lp z1V82K-)z+x5D$I;#Z?>_&8EifNZbOic}U9%&4-^u?x#8omGB}v;1qlZn2VM>@4lVyWeuF8x2?!BIxcc}A(c(7b)WQqW zB?OUr9}?C9=*sq-Orjim)Zvg}9GD`3oAOxrYbh?m0dNtHCL`j0P$$E|DdPFykOlb&5|t56Pl(Lz!qG9R2JlEre9!&TQ|fsQx=phOLE-z zIw@x9BnO*VOmHOvzykx^64ww&!Y(EY>`4z%oOGx`qHYKz+8|xQSGa*U%jynpD_B?C z&((6Zs&>x@0E6|-atB*8cfZ>2TEhMd5kBrKSUvl&S+6TTzztCy?)o5*t|Lr^wFFWk z1EozsnE`i6AE{NsHmI-V%8wNaQ!Da-G#n);Pyghm)u;G?UfXu*t0*^pESi4M@6mJ0rqL+T zC4{{x{phdt&;o`l!IKL75X+M3f4r%+qe&_?%hDS@?mg-;-7}w))9&a&{|xy*diU%y z8AkK09O5O17hC62Gu;3s;MMjb&7%xx;0VWEWK%@bGRo=xLvZ|ZxClgNIby?TRvx2P c?`f;#>^o|BGP_DAe3X>KoGY9|@Z{UiUj~XG?f?J) literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH new file mode 100644 index 0000000000000000000000000000000000000000..fefc3673cfa298f0194f6b0a20d4065153568488 GIT binary patch literal 1056 zcmah|v2NQi5LKLXG1`B)B>=eyBqhu8sK}HpSe0B$X^m__k`^7(6hX3N$cN?II`kby zIfk2{1}u{A-o1M~l0vjA+vQ8TJf-hHe>~pbV7$M(J!Rnf?&|UO=GO!DoV=+!yX}aC z*fi($oHQwk)gsH68EH4qEjSxG%UWBNwdF96M3D*=X(OpFEB7bix&6RQAClC)vUCXD zuXfXxO-&KAgbKAuiINzKNMY=(+2X4cAY^840Ebs@V9K6lu0s$8I+T=N8Cb$jy>4DL zt(|`>H`sxIK1+t!%oHU!!=wW;F+kp{v#Y`?EKi#GLzO|_@QxsFrYr_-?A1-=0j&lK zhnS*gEW}C5BW9Py{pekCP38<)k!ubk6Xv|(d)K2w?>Zr3e}nnH^}QgOwBKES0x`_K zA^l$KS(#G~l-+qycKLBUgQYRfew>a2{vC^Twy<21FkACQ zyKqZMLXo0G8=B5=Z-sD|-?!r+2vkbx1V02vfp9bb86EGh{+XYE{~Y`lb6aHRRafAV z;bHAPDnCtO0Z;35S!WgTB3AKaTdjeXT~_n^1GxNBY*V$D4y?%9?huv1r&lMVKk)Fe SU6oC^uw7Ay1~Gu6r@NIif&l+!}u`P+;i>HhAT$Gh8`Qve@s-{0R{fB8lOCvWP$*z`n7 zwasO{AWc!gtMe>hWu#@E7tCqtEbEG@tP5;oB(hN$kv0L4QO5zvvR zU<(wTLI{VV5i#3S$j9I%Y=YxYSxF9%88`?0-sb4B?>Z)ef8O~a^@AXpWQcC4fMaJ5 zNI#W&DC5W@WvK^Q$vsKF$p`k&HQkqO))Or3MP+r^x1 zOLJ$KxwYKcCUlAMP83yDt~+GG`W}*If+IGbhfc?%IF8Ly;0}!_7Tu7Z8DB=WZ2scv zzAG+?W1~5jZWg9VY`rge+2$2okuDx`GUngPO+o%q2sm*lC%c<0l0h()dxmaw(mBqh ze0s{aews`t_#LZtc3yx^JX_<5c`M6+R74TQ+R!}Z7fUI5_COT!Z<`WbAcD^)&n8M{ zfUoYP7`*4AJtc7omGT|i`;Betr;!*tj5dB s;Og~qlSF&R8Czyu{}>G>FL$1t{A3?qbQfh4o)`VH4h`=yc=Y|pFSVjC761SM literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH new file mode 100644 index 0000000000000000000000000000000000000000..93f84905cda11d4b3c606597ab741c1a7694f654 GIT binary patch literal 1916 zcmb7F%Wl&^6b%$uMDPz+m5}U><$1)hcX1r2vFh5vaZA)4;w2WP2+<7)K8&y9p6jvW zhKEF?cszH`ocq4^yxn=;W*d6-oZfwSfA{$DYD^5y8IR_%8SzA$6Ll zONFv*>>sFI@CRZ*IISU=apj0v@ijTrA3N!7i(0x2Wq4I34w9@xO}`qpBJ^R&VnvyKJtc zsQPS4alxq}Ss}*+0%cIroGdAt|4Nq8S}V(O<*tY#Yr0}*&a}z+DRm{xh%R(V=}DAca|a~?S2jqjwTBL8%-}xPrk)$ay`=*i>psDGSr*$JqG0+emU4z6 zCYlFUMUEWTW(njLtsok07oHgp1lFwoVd~fv8%L2=97{V3k~lKGEm_fIB}|b%>SE&J zZ=_cde=~qy1>ZZ8nd7qXv!<2_hL*gZx{#3kzOIAA5 z+Jw!TatNmJbb{ZBw@uG-xyx@`4DoB(`s9TaQlvD^6aFT6o_ttb+>Q=AZ9@2X@?hf0 zn|nMw8Sj33f5iA7lTY3%U#FL4yJm+tQKJu*dyUxy{%lUIM( z?UqaJSxb40dy_Z2qOK@_mg9R$$3&4~L_Px9vcBc7idaHAk%4uvk^w3smtlt(n58C3 z;#g2zi_OvqzFOq0tath9>!RTp9JT;ZkHeX>5uDI*F9|hEK4z&8?QBFrzqiukYsAFx zdJZu7XVGC$%<5y8LS z`HuV!kUC4$r9v5Y_Ftea`2#RiIITXAapVG7@eJbRe={D+N`}>@Ta`~%-Cn1;%tU3m*sS>6a!UxMb&3ZiVHyv$?};K2vmTQ=446H{I6sMT5DyPSH2ZdWP+~P88dA%{z_d5 zGT4PJDLp9_DGZie)P*EZio*#w&3uCrQCG%Gj4|gM&N@T*T$_3x1bnx&XJXwaI4{d$ zy8{bBU&T_+a3qN4o>7qn$FVSh+~6vRMbps}azkLt`afJ9yJF%f(u%n>p_jx_(EE}V zO;*Acxknu*mj6KRD)>ht;KYa%av}=27os_JO{K5vt^!yawauFv16*Oz)4n2?5GIGd za_%&^s5mhcfkx*O$>3IOCBw}h91WCZOAR^$e?5)>igmfKfZo(i@tXU6T2hEEkC2AM zkJ#j+U}e+|@I=^lEUn6hO`VZ$fQ4Ccpx@|@zP;bSr8j#z?jL{I-yaV9_jJ6we@~Ar zpApS?>)qkR!hZksEB$oZ)8U&RACAYpH)F7l_7C2Z@x$aO6?h@q9emX$l*fo!m6po_ z3wrdPQz$FnV-u-CG5$??gj zNNJiU{31GzJgYE)|IzTW(oev}uKxorRmP*0-@gI?l3nx@#|`?&Qm}C!gQ24`1wF T7PWVkx9iH&yvM?4zyJLYE+wti literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH new file mode 100644 index 0000000000000000000000000000000000000000..b33f1c41639616c32972ea232171a4e762cc6330 GIT binary patch literal 2434 zcmb7GZI9bT5DqO!D1!emid4z|VtHTeIN#zp&c&*02Paof{eU=VfRir0_DWC-f*;1O zW1d;taZ?VJNb!1SXP*t*#rO z*)I9CJ87waai8bSwx}yIv}uYatu7eQQxvd$?DN7v>4Ye@Y=c1{Thv$3iCIE=CIjnW zCIeIkPQWs;DVEyVEJ*~V!)9p=_APQ&*4upfZP9=PTL5Ul4o=w!V0F?-BF&PAEOpLe zogDx%=yz5+d<~x%UQYoAel5B-tw4pH3YMUvW&pybu$Ab37a{^3oxmn^x?M)X14#rO zD4j*9kJ34J6%&D9N8SbB0g|&sE)~i$*?)m&R6uW2X#^!7PbQ$0aM8tOOM~M=mC9{EeJd#2<+Oi9t-ri@8-PGAwsZrK@XK0j%Agc+GIV zwGaA=9734v`^u@);Gn`}Uj!PRPb599q?Pn1zb9%`8!grA^zrL(1W>HYc?I;kZi*Lt z1EeKI==+jyc-Q#`C3cIqA}WJ!fJ>uo$I_~}1H)}{M%;kSlj4@%(>48YvwuY|_jK6b z|F*xmz1_d1!}ZNux@Y->Xu?acZ;veO){pP#&2dk+-~V!VIP8N7gSoJObi)j_mAm~szClUJDLh><38&ha7`lAeFbVCa^%Q?Bl?*~wy0Nu0_G--W zA1C7xeviFP$`>{m@!JMh`3sr)aI3_l<(N(!&X|YQyeBrQg t{mtqs2?yI*wo13VbE!Z2`o!eR@0i0^+owexT;#h|6=+^#;iKRG{s)w;;q(9i literal 0 HcmV?d00001 diff --git a/internal/test/i/o/Keyboard/Hand/ASKUSER.u b/internal/test/i/o/Keyboard/Hand/ASKUSER.u new file mode 100644 index 00000000..3dd57366 --- /dev/null +++ b/internal/test/i/o/Keyboard/Hand/ASKUSER.u @@ -0,0 +1 @@ +;; Being tested: AskUser ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 6, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>Keyboard>AskUser.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Testing AskUser" :before (progn (setq window-list (do-test-menu-Setup "AskUser"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Test TTYIN in the Interlisp exec" (let* ((user-result1 (do-test-menu-Message window-list 'high " Test TTYIN in the Interlisp exec If there is no free Interlisp exec, bring up a another one. Put the cursor in it. Indicate success when you get this far. ")) (command-string "(SETQ TEMP-KEY-LIST (MAKEKEYLST '(GREETINGS HELLO SALUTATIONS) NIL NIL T)) (SETQ TEMPX (ASKUSER NIL NIL \"Type a H \" TEMP-KEY-LIST))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check basic ASKUSER workds Type an \"H\" and then a carriage return. Were you able to get this far? ")) (good-value (equal 'il:hello il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "TTYIN, test default in the Interlisp Exec" (let* ((user-result1 (do-test-menu-Message window-list 'high " TTYIN, test default in the Interlisp Exec Indicate success when the cursor is in the Interlisp Exec. ")) (command-string "(SETQ TEMP-KEY-LIST (MAKEKEYLST '(GREETINGS HELLO SALUTATIONS) NIL NIL T)) (SETQ TEMPX (ASKUSER 1 'G \"Just CR \" TEMP-KEY-LIST))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check ASKUSER can default Wait for ASKUSER to prompt with \"Just CR ...GREETINGS\" and then press the CR. Were you able to get this far? ")) (good-value (equal 'il:greetings il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test TTYIN in the XCL exec" (let* ((user-result1 (do-test-menu-Message window-list 'high " Test TTYIN in the XCL exec If there is no free XCL exec, bring up a another one. Put the cursor in it. Indicate success when you get this far. ")) (command-string "(cl:in-package 'xcl-test) (setq temp-key-list (il:makekeylst '(GREETINGS HELLO SALUTATIONS) nil nil T)) (setq tempx (il:askuser nil nil \"Type a H \" temp-key-list))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check ASKUSER works in an XCL exec Type an \"H\" and then a carriage return. Were you able to get this far? ")) (good-value (equal 'hello tempx))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "TTYIN, test default in the XCL exec" (let* ((user-result1 (do-test-menu-Message window-list 'high " TTYIN, test default in the XCL exec Indicate success when the cursor is in the XCL Exec. ")) (command-string "(setq temp-key-list (il:makekeylst '(GREETINGS HELLO SALUTATIONS) nil nil T)) (setq tempx (il:askuser 100 'il:G \"Just CR \" temp-key-list))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check ASKUSER can default in an XCL exec Wait until the exec reads: \"Just CR ...GREETINGS\" Then press CR. Were you able to get this far? ")) (good-value (equal 'greetings TEMPX))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "TTYIN, test reaing from a STREAM" (let* ((user-result1 (do-test-menu-Message window-list 'high " TTYIN, test reading from a STREAM Indicate success when the cursor is in the XCL Exec. ")) (command-string "(setq temp-key-list (il:makekeylst '(GREETINGS HELLO SALUTATIONS) nil nil T)) (setq temp-pathname (make-pathname :host \"core\" :directory \"cmltest\" :name (string (gensym)))) (setq temp-stream (cl:open temp-pathname :direction :output)) (write-line \"S\" temp-stream) (write-line \" \" temp-stream) (close temp-stream) (setq temp-stream (open temp-pathname :direction :input)) (setq tempx (il:askuser nil nil \"Just CR \" temp-key-list T T nil temp-stream))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check ASKUSER can read from STREAM Inidcate success when the call to ASKUSER is made. ")) (toss-away2 (and (close temp-stream) (delete-file temp-pathname))) (good-value (equal 'salutations tempx))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/Hand/PromptForWord.u b/internal/test/i/o/Keyboard/Hand/PromptForWord.u new file mode 100644 index 00000000..e7e3d534 --- /dev/null +++ b/internal/test/i/o/Keyboard/Hand/PromptForWord.u @@ -0,0 +1 @@ +;; Being tested: PromptForWord ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>Keyboard>PromptForWord.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Testing PromptForWord" :before (progn (setq window-list (do-test-menu-Setup "PromptForWord"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Check basic ReadNumber works" (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec If there is no free Interlisp exec, bring up a another one. Place the cursor in the Interlisp exec. Indicate success when you get this far. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Type hello\"))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check basic ReadNumber works Enter \"hello\" and a CR. Was the prompt: \"Type hello\"? ")) (good-value (equal "hello" il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Check can do candidate string" (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Type good-bye\" 'good-bye))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check can do candidate string Just press the space-bar. Does the line read: \"Type good-bye good-bye\"? ")) (good-value (equal "good-bye" il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "test returns nil when nothing is entered." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Just press the tab key\"))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " test returns nil when nothing is entered Just press the tab key. Were you able to get this far? ")) (good-value (equal NIL il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test help." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"First question mark, then CR\" NIL \"This is a help message\"))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test help Type in \"?\" Then press CR. Was the following three lines printed out? First question mark, then CR This is a help message First question mark, then CR ")) (good-value (equal NIL il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test DONTECHOTYPEIN.FLG." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Just CR\" \"password\" NIL NIL '*))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test DONTECHOTYPEIN.FLG Press CR. Was the prompt: \"Just CR ********\" ")) (good-value (equal "password" il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test urgency.option, part 1." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Nothing\" \"smile\" NIL NIL NIL 1))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test urgency.option, part 1 Wait, it should continue on it's own after a second or two.. Was the prompt: \"Nothing smile\" And did it go on on its own? ")) (good-value (equal "smile" il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test urgency.option, part 2." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Wait, then CR\" \"smile\" NIL NIL NIL T))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test urgency.option, part 2 Wait for a minute. Then press the CR. Did the exec window flash? ")) (good-value (equal "smile" il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test terminating character list." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec Indicate success when the cursor is in the Interlisp exec. ")) (command-string "(SETQ TEMPX (PROMPTFORWORD \"Type 12345\" NIL NIL NIL NIL NIL (CHARCODE (5 6 7))))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test terminating character list Type: \"12345\" Did it return after the number \"5\"? ")) (good-value (equal "1234" il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Try in XCL." (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to a XCL exec If needed bring up another XCL exec. Indicate success when the cursor is in the XCL exec. ")) (command-string "(cl:in-package 'xcl-test) (SETQ TEMPX (il:PROMPTFORWORD \"Type 12345\" ))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Try in XCL Type: \"12345\" Then a CR Were you able to get this far? ")) (good-value (equal "12345" TEMPX))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/Hand/ReadNumber.u b/internal/test/i/o/Keyboard/Hand/ReadNumber.u new file mode 100644 index 00000000..db8d7d6f --- /dev/null +++ b/internal/test/i/o/Keyboard/Hand/ReadNumber.u @@ -0,0 +1 @@ +;; Being tested: ReadNumber ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 10, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>Keyboard>ReadNumber.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Testing ReadNumber" :before (progn (setq window-list (do-test-menu-Setup "ReadNumber"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Check basic ReadNumber works" (let* ((user-result1 (do-test-menu-Message window-list 'high " Get to the Interlisp exec If there is no free Interlisp exec, bring up a another one. Place the cursor in the Interlisp exec. Indicate success when you get this far. ")) (command-string "(SETQ TEMPX (RNUMBER '(SIMPLE TEST, TYPE 1234)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Check basic ReadNumber works Enter the number \"1234\" by clicking each item on the menu, then on \"ok\" Does \"ReadNumber\" have the message: \"Simple Test, Type 1234\"? ")) (good-value (equal 1234 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Try rest of the numbers and minus sign" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type the number -56789)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test a little more of ReadNumber Enter the number \"-56789\" by clicking the numbers first, and then the minus sign, from the menu, then on \"ok\" Were you able to get this far? ")) (good-value (equal -56789 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test clear" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type the number 123, then clr, then 567)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test a little more of ReadNumber Enter the number \"123\" by clicking each number first then click on the clr item then enter \"567\" by clicking on each number then on \"ok\" Were you able to get this far? ")) (good-value (equal 567 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test back space and position" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type the number 482, bs twice, then 15) '(0 . 0)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test back space and position Enter the number \"482\" by clicking each number first then click on the bs item twice then enter \"15\" by clicking on each number then on \"ok\" Did the menu appear in the bottom left hand corner? ")) (good-value (equal 415 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test abort" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type number 123 then abort) NIL NIL NIL T))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test abort Enter the number \"123\" by clicking each number first then on \"abort\" Were you able to get this far? ")) (good-value (equal nil il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test decimal" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type number 123.456) NIL NIL NIL NIL T))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test decimal Enter the number \"123.456\" by clicking each number first then on \"ok\" Were you able to get this far? ")) (good-value (equal 123.456 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test decimal & abort" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type number 90.87) NIL NIL NIL T T))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test decimal and abort Enter the number \"90.87\" by clicking each number first then on \"ok\" Were both the decimal point and the abort key in the menu? ")) (good-value (equal 90.87 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test message font" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type number 123) NIL '(MODERN 18)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test message font This may take a minute to find the right font Enter the number \"123\" by clicking each number first then on \"ok\" Was the font for the message very big? ")) (good-value (equal 123 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test number font" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in in Interlisp exec Indicate success when the cursor is in the Interlisp exec ")) (command-string "(SETQ TEMPX (RNUMBER '(Type number 123) NIL NIL '(MODERN 18)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test number font This may take a minute to find the right font Enter the number \"123\" by clicking each number first then on \"ok\" Was the font for the numbers very big? ")) (good-value (equal 123 il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test can call from XCL" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in an XCL exec If needed bring up another XCL exec. Indicate success when the cursor is in the XCL exec ")) (command-string "(cl:in-package 'xcl-test) (setq tempx (il:rnumber '(Type number 123)))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test number font This may take a minute to find the right font Enter the number \"123\" by clicking each number first then on \"ok\" Was the font for the numbers very big? ")) (good-value (equal 123 TEMPX))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test create.numberpad.reader" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in an XCL exec Indicate success when the cursor is in the XCL exec ")) (command-string "(setq temp-numberpad (il:create.numberpad.reader '(Continous input))) (setq tempx (il:numberpad.read temp-numberpad))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test create.numberpad.reader Enter the number \"123\" by clicking each number first then on \"ok\" Was the font for the numbers very big? ")) (good-value (equal 123 TEMPX))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Test create.numberpad.reader" (let* ((user-result1 (do-test-menu-Message window-list 'high " Make sure cursor in an XCL exec Indicate success when the cursor is in the XCL exec ")) (command-string "(setq tempx (il:numberpad.read temp-numberpad))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Test create.numberpad.reader Enter the number \"456\" by clicking each number first then on \"ok\" Was the font for the numbers very big? ")) (good-value (equal 456 TEMPX))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/Hand/TTYIN.u b/internal/test/i/o/Keyboard/Hand/TTYIN.u new file mode 100644 index 00000000..49a06d13 --- /dev/null +++ b/internal/test/i/o/Keyboard/Hand/TTYIN.u @@ -0,0 +1 @@ +;; Being tested: TTYIN ;; ;; Source: ;; ;; Created By: Henry Cate III ;; ;; Creation Date: March 4, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>Keyboard>TTYIN.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) (do-test-group "Testing TTYIN" :before (progn (setq window-list (do-test-menu-Setup "TTYIN"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Test TTYIN in the Interlisp exec" (let* ((user-result1 (do-test-menu-Message window-list 'high " Test TTYIN in the Interlisp exec If there is no free Interlisp exec, bring up a another one. Put the cursor in it. Indicate success when you get this far. ")) (command-string "(SETQ TEMPX '(ABCDEFGHIJKLM NOPQRSTUVWXYZ 123 456.789 0 \"!@#$&*()\" \",./<>? ;'`:~\"))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Able to stuff things into a Interlisp exec Was \"tempx\" set in the Interlisp exec? ")) (good-value (equal '(il:abcdefghijklm il:nopqrstuvwxyz 123 456.789 0 "!@#$&*()" ",./<>? ;'`:~") il:|TEMPX|))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Editing, delete, add in, in Interlisp exec" (let* ((user-result (do-test-menu-Message window-list 'high " Editing, delete, add in, in Interlisp exec Assumping just set TEMPX to: (ABCDEFGHIJKLM NOPQRSTUVWXYZ 123 456.789 0 \"!@#$&*()\" \",./<>? ;'`:~\") In the Interlisp exec type: \"fix\" Delete the number \"123\" by clicking with the left button before it, and then the right button after it. Now type in \" 321 \" Type control-x. Were you able to get this far? ")) (good-value (equal '(il:abcdefghijklm il:nopqrstuvwxyz 321 456.789 0 "!@#$&*()" ",./<>? ;'`:~") il:|TEMPX|))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Editing, delete previous word, in Interlisp exec" (let* ((user-result (do-test-menu-Message window-list 'high " Editing, delete previous word, in Interlisp exec Assumping just set TEMPX to: (ABCDEFGHIJKLM NOPQRSTUVWXYZ 321 456.789 0 \"!@#$&*()\" \",./<>? ;'`:~\") In the Interlisp exec type: \"fix\" Place the caret right after the number \"0\". Type control-w. Type control-x. Were you able to get this far? ")) (good-value (equal '(il:abcdefghijklm il:nopqrstuvwxyz 321 456.789 "!@#$&*()" ",./<>? ;'`:~") il:|TEMPX|))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test TTYIN refresh in Interlisp exec" (do-test-menu-Message window-list 'high " Test TTYIN refresh in Interlisp exec Assumping just set TEMPX to: (ABCDEFGHIJKLM NOPQRSTUVWXYZ 321 456.789 \"!@#$&*()\" \",./<>? ;'`:~\") In the Interlisp exec type: \"fix\" Watch carefully Type control-r. Type control-x. Was the screen redisplayed? ")) ;;; start of a new section of testings (do-test "Test TTYIN in the XCL-TEST exec" (let* ((user-result1 (do-test-menu-Message window-list 'high " Test TTYIN in the XCL-TEST exec If there is no free XCL-TEST exec, bring up a another one. Put the cursor in it. Indicate success when you get this far. ")) (command-string "(cl:in-package 'xcl-test) (SETQ TEMPX '(ABCDEFGHIJKLM NOPQRSTUVWXYZ 123 456.789 0 \"!@#$&*()\" \",./<>? ;'`:~\"))") (toss-away (IL:BKSYSBUF command-string)) (user-result2 (do-test-menu-Message window-list 'high " Able to stuff things into a Interlisp exec Was \"tempx\" set in the Interlisp exec? ")) (good-value (equal '(abcdefghijklm nopqrstuvwxyz 123 456.789 0 "!@#$&*()" ",./<>? ;'`:~") tempx))) (and user-result1 user-result2 (if (eq t user-result2) good-value T)) )) (do-test "Try editing a statement in the XCL-TEST exec" (let* ((user-result (do-test-menu-Message window-list 'high " Try editing a statement in the XCL-TEST exec Assumping just set TEMPX to: (ABCDEFGHIJKLM NOPQRSTUVWXYZ 123 456.789 0 \"!@#$&*()\" \",./<>? ;'`:~\") In the XCL-TEST exec type: \"fix\" Delete the number \"123\" by clicking with the left button before it, and then the right button after it. Now type in \" 321 \" Type control-x. Were you able to get this far? ")) (good-value (equal '(abcdefghijklm nopqrstuvwxyz 321 456.789 0 "!@#$&*()" ",./<>? ;'`:~") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Test shift select for TTYIN in XCL-TEST exec" (let* ((user-result (do-test-menu-Message window-list 'high " Test shift select for TTYIN in XCL-TEST exec Assumping tempx set to: (ABCDEFGHIJKLM NOPQRSTUVWXYZ 321 456.789 0 \"!@#$&*()\" \",./<>? ;'`:~\") In the XCL-TEST exec type: \"fix\" Place the caret after the number \"0\". Hold down the shift button. Select the following: \" 54 \" Type control-x. Were you able to get this far? ")) (good-value (equal '(abcdefghijklm nopqrstuvwxyz 321 456.789 0 54 "!@#$&*()" ",./<>? ;'`:~") tempx))) (and user-result (if (eq t user-result) good-value T)) )) ;;; test calling the function "TTYIN" (do-test "Set up for a simple call to function TTYIN" (let* ((user-result (do-test-menu-Message window-list 'high " Set up for a simple call to function TTYIN Place the cursor in an Interlisp Exec. Shift select the following into the Interlisp Exec: \"(SETQ TEMPX (TTYIN \"Please type the number 54. \"))\" Type in the number \"54\". Were you able to get this far?")) (good-value (equal '(54) il:|TEMPX|))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Set up for a simple call to function TTYIN" (let* ((user-result (do-test-menu-Message window-list 'high " Set up for a simple call to function TTYIN Place the cursor in an XCL-test Exec. Shift select the following into the XCL-test Exec: \"(SETQ TEMPX (il:TTYIN \"Please type the atom \\\"hello\\\". \"))\" Type in the number \"hello\". Were you able to get this far?")) (good-value (equal '(il:hello) TEMPX))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Set up for a simple call to function TTYIN" (let* ((user-result (do-test-menu-Message window-list 'high " Set up for a simple call to function TTYIN Place the cursor in an XCL-test Exec. Shift select the following into the XCL-test Exec: \"(SETQ TEMPX (il:TTYIN \"Trying for a string. \" nil nil '(IL:NORAISE IL:STRING)))\" Type: \"Hello\" and a carriage return. Were you able to get this far?")) (good-value (equal "Hello" TEMPX))) (and user-result (if (eq t user-result) good-value T)) )) ;;; test calling the function "TTYINEDIT" (do-test "Set up for a simple call to function TTYINEDIT" (do-test-menu-Message window-list 'high " Set up for a simple call to function TTYINEDIT Place the cursor in an Interlisp Exec. Shift select the following into the Interlisp Exec: \"(SETQ TEMPX (TTYINEDIT '(54 67 89) NIL NIL \"Hello: \"))\" Is a window created with: \"Hello: 54 67 89\"? ")) (do-test "Modify value from a TTYINEDIT" (let* ((user-result (do-test-menu-Message window-list 'high " Modify value from a TTYINEDIT Place the cursor after the numbers in the new TTYINEDIT window. Shift-select in: \" 12 34\" Then type: control-x. Does the caret go back to the Interlisp window?" )) (good-value (equal '(54 67 89 12 34) il:|TEMPX|))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Set up for a simple call to function TTYINEDIT" (do-test-menu-Message window-list 'high " Set up for a simple call to function TTYINEDIT Close the TTYINEdit window from the previous test. Place the cursor in an XCL-test Exec. Shift select the following into the XCL-test Exec: \"(setq IL:TTYINAUTOCLOSEFLG T) (setq tempx (il:TTYINEDIT '(54 67 89) (IL:CREATEW) NIL \"Hello: \"))\" Does the system ask you to: \"Specify region for window\" and then fill the region with a window with the following in it: \"Hello: 54 67 89\"? ")) (do-test "Modify value from a TTYINEDIT" (let* ((user-result (do-test-menu-Message window-list 'high " Modify value from a TTYINEDIT Place the cursor after the numbers in the new TTYINEDIT window. Position the mouse just before the number \"67\" and click the left button. Then position the mouse just after the number \"67\" and click the right button. Type a space. Then type: control-x. Does the caret go back to the XCL-test exec and does the TTYINEdit window get closed?" )) (good-value (equal '(54 89) tempx))) (and user-result (if (eq t user-result) good-value T)) )) ;;; test ?= (do-test "Testing question mark, equals sign" (do-test-menu-Message window-list 'high " Testing question mark, equals sign Place the cursor in an XCL-test Exec. Type/shift-select: \"(il:createw \", a question mark, and a equals sign, then type a carriage return. Does the system respond with: \"(il:createw REGION TITLE BORDERSIZE NOOPENFLG\"? ")) (do-test "Testing question mark, equals sign, part two" (do-test-menu-Message window-list 'high " Testing question mark, equals sign, part two Type: \"nil 'Hello \", a question mark, and a equals sign then a carriage return Does the system respond with: \"(il:createw REGION = nil TITLE = (quote hello) BORDERSIZE NOOPENFLG\"? ")) (do-test "Clean up on question mark, equals sign test" (do-test-menu-Message window-list 'high " Testing question mark, equals sign, part two test Type: \")\" Create any region. Close the window. Were you ableto get this far?")) ) ; end of do-test-group STOP \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/logs/askuser.log b/internal/test/i/o/Keyboard/logs/askuser.log new file mode 100644 index 00000000..4fd42815 --- /dev/null +++ b/internal/test/i/o/Keyboard/logs/askuser.log @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 2-Mar-88 15:48:10 ;;; Running tests from ({ERIS}I/O>Keyboard>Hand>askuser.U) (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/logs/keyboard.log b/internal/test/i/o/Keyboard/logs/keyboard.log new file mode 100644 index 00000000..9acb4b92 --- /dev/null +++ b/internal/test/i/o/Keyboard/logs/keyboard.log @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 2-Mar-88 15:20:41 ;;; Running tests from ({ERIS}I/O>Keyboard>Hand>*.U) Test "TTYIN, test default in the XCL exec" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" Test "Test decimal & abort" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test number font" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test can call from XCL" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test create.numberpad.reader" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test create.numberpad.reader" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test shift select for TTYIN in XCL-TEST exec" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/logs/keyboard.log.~1~ b/internal/test/i/o/Keyboard/logs/keyboard.log.~1~ new file mode 100644 index 00000000..a23498ba --- /dev/null +++ b/internal/test/i/o/Keyboard/logs/keyboard.log.~1~ @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 17-Feb-88 14:16:42 ;;; Running tests from ({eris}i/o>keyboard>hand>*.u;) Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" :BEFORE forms for test "Testing AskUser" in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" failed. Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" :BEFORE forms for test "Testing PromptForWord" in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" failed. Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" :BEFORE forms for test "Testing ReadNumber" in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" failed. Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" :BEFORE forms for test "Testing TTYIN" in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" failed. (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/logs/keyboard.log.~2~ b/internal/test/i/o/Keyboard/logs/keyboard.log.~2~ new file mode 100644 index 00000000..bab1b11e --- /dev/null +++ b/internal/test/i/o/Keyboard/logs/keyboard.log.~2~ @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 17-Feb-88 14:21:48 ;;; Running tests from ({eris}i/o>keyboard>hand>*.u;) Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" :BEFORE forms for test "Testing AskUser" in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" failed. Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" :BEFORE forms for test "Testing PromptForWord" in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" failed. Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" :BEFORE forms for test "Testing ReadNumber" in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" failed. Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" :BEFORE forms for test "Testing TTYIN" in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" failed. (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/i/o/Keyboard/logs/keyboard.log.~3~ b/internal/test/i/o/Keyboard/logs/keyboard.log.~3~ new file mode 100644 index 00000000..9acb4b92 --- /dev/null +++ b/internal/test/i/o/Keyboard/logs/keyboard.log.~3~ @@ -0,0 +1 @@ +;;; Test results for sysout of 12-Feb-88 18:51:29 ;;; Tests run on 2-Mar-88 15:20:41 ;;; Running tests from ({ERIS}I/O>Keyboard>Hand>*.U) Test "TTYIN, test default in the XCL exec" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" Test "Test decimal & abort" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test number font" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test can call from XCL" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test create.numberpad.reader" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test create.numberpad.reader" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" Test "Test shift select for TTYIN in XCL-TEST exec" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" (END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/loops/LOOPS-SETUP.TEDIT b/internal/test/loops/LOOPS-SETUP.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..e4aa3c6ba298aa7249d91a7e3db0ca35d7c81775 GIT binary patch literal 2035 zcmbtV+iu%N5LJT$1qk#X2I_;Qz$D^J8bb|KFcd8lrb(5gVY}$did>3>S6qg>jG{XJ zv3y--msBb@34)?}5LT<4n;3EuEEJkX}Bwp2X6W~Hd7Y}=ISbV)>+is>O_MA8h7 zUzv8@m}jpn!}J@WG9|;LeTv9{jt=bEYaTo({)j!wG``{vD(HWaY9U&30;x zN;YAfWN?tUGcU1N%GYCki~W}p4*nT4#gR^?jPqJdHJYZNvaKy0IK~-@Qh+FU%Q9FZ zHY;dr90xBmp0;aRNy~_fGM6AIqp8A&Fb1rwsDLG9d;0tO8U5dF@&_?V7adQ!xz8APwmJ`7`Fgl17Ya1fdqEFld{3LUiu2aKa zS56c?oP15n3Wl~92Vs<43~~0I2AvD5&u@j%+zz}y z?ZgWM7~Z;3c#Dx50dHh6xup$%|M=Rm6Zd5L0T)Xnk}@vnM)l12if^zA zirl%dgSq?0b}r{pcpc2(^!W6}%MSgt;psg#ZJcwaWTJMYtb}aZRF=FFkn;u4|_z3cUgH3zSg&UjsK57jI<5Ly(P60(*r(H6S@9>)f$GDvy7)yu3l1Oesnkcs=wmGo6_8^)|N zI6>A_lcrGmTJ7V$wnCyS4GNw;_fQxkPoCNpwL9q6RmL}y4xHh`EWZ4*{?Hitp*@2G z?O&*!nC;2gZ|5c-v`3Y=t_agQCnbOJmjFeZxl8 zDw|rcRu{N)n^jqLM~(GogW0#>vGE&Rk$VcF?YipaCG<$>x=4zW50atZP)~T!ex|^0 z%2k1e%yYRR4Lw9ikLOOPS>LOOPS-TESTER-2-1.\;6 17927 |changes| |to:| (FUNCTIONS |LT-2.1-SetName-BASIC| |LT-2.1-GetObjectNames-BASIC| |LT-2.1-UnSetName-MORE-1| |LT-2.1-UnSetName-BASIC| |LT-2.1-Rename-MORE-1| |LT-2.1-Rename-BASIC| |LT-2.1-GetObjectsNames-BASIC| LT-2.1-DOLLAR-EX-BASIC-ERROR LT-2.1-DOLLAR-EX-BASIC LT-2.1-DOLLAR-BASIC-ERROR LT-2.1-DOLLAR-BASIC LOOPS-TESTER-2.1 TEMP4) (VARS LOOPS-TESTER-2-1COMS) |previous| |date:| "17-Feb-88 15:18:28" {ERINYES}LOOPS>LOOPS-TESTER-2-1.\;4) (PRETTYCOMPRINT LOOPS-TESTER-2-1COMS) (RPAQQ LOOPS-TESTER-2-1COMS ((FUNCTIONS LOOPS-TESTER-2.1 LT-2.1-DOLLAR-BASIC LT-2.1-DOLLAR-BASIC-ERROR LT-2.1-DOLLAR-EX-BASIC LT-2.1-DOLLAR-EX-BASIC-ERROR |LT-2.1-GetObjectNames-BASIC| |LT-2.1-Rename-BASIC| |LT-2.1-Rename-MORE-1| |LT-2.1-SetName-BASIC| |LT-2.1-UnSetName-BASIC| |LT-2.1-UnSetName-MORE-1|))) (CL:DEFUN LOOPS-TESTER-2.1 (&OPTIONAL (DETAIL-RESULTS NIL)) "Run each test for section 2.1" (CL:APPLY (CL:IF DETAIL-RESULTS 'LIST 'AND) (LIST (LT-2.1-DOLLAR-BASIC) (LT-2.1-DOLLAR-BASIC-ERROR) (LT-2.1-DOLLAR-EX-BASIC) (LT-2.1-DOLLAR-EX-BASIC-ERROR) (|LT-2.1-SetName-BASIC|) (|LT-2.1-UnSetName-BASIC|) (|LT-2.1-UnSetName-MORE-1|) (|LT-2.1-Rename-BASIC|) (|LT-2.1-Rename-MORE-1|) (|LT-2.1-GetObjectNames-BASIC|)))) (CL:DEFUN LT-2.1-DOLLAR-BASIC NIL (XCL-USER::DO-TEST "$ Basic test, make sure $ gets pointer" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TOSS-AWAY (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (TEMP-INSTANCE-NAME-LIST (LIST TEMP-INSTANCE-NAME)) (RESULTS (AND (CL:APPLY '$ TEMP-INSTANCE-NAME-LIST) (|Instance?| (CL:APPLY '$ TEMP-INSTANCE-NAME-LIST)) ))) (_ ($! TEMP-INSTANCE-NAME) |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN LT-2.1-DOLLAR-BASIC-ERROR NIL (XCL-USER::DO-TEST "$ Check when give bad name, get nil" (AND (EQ NIL ($ A-SYMBOL-WHICH-SHOULD-NOT-EXIST)) (EQ NIL ($ 123456789123456789)) (EQ NIL ($ "Not suppose to be able to use strings" ))))) (CL:DEFUN LT-2.1-DOLLAR-EX-BASIC NIL (XCL-USER::DO-TEST "$! Basic test, make sure $! gets a pointer" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TOSS-AWAY (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (RESULTS (AND ($! TEMP-INSTANCE-NAME) (|Instance?| ($! TEMP-INSTANCE-NAME) )))) (_ ($! TEMP-INSTANCE-NAME) |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN LT-2.1-DOLLAR-EX-BASIC-ERROR NIL (XCL-USER::DO-TEST "$! Check when give bad name, get nil" (LET* ((TEMP-PATHNAME (CL:MAKE-PATHNAME :HOST "CORE" :NAME (CL:GENSYM))) (TEMP-STREAM (OPEN TEMP-PATHNAME :DIRECTION :OUTPUT)) (TEMP-ARRAY (CL:MAKE-ARRAY 2)) (TEMP-LIST (LIST 'A 34 "HI")) (TEMP-HASH (CL:MAKE-HASH-TABLE))) (CL:CLOSE TEMP-STREAM) (AND (EQ NIL ($! 'A-SYMBOL-WHICH-SHOULD-NOT-EXIST)) (EQ NIL ($! 123456789123456789)) (EQ NIL ($! "Not suppose to be able to use strings" )) (EQ NIL ($! TEMP-PATHNAME)) (EQ NIL ($! TEMP-STREAM)) (EQ NIL ($! TEMP-ARRAY)) (EQ NIL ($! TEMP-LIST)) (EQ NIL ($! TEMP-HASH)))))) (CL:DEFUN |LT-2.1-GetObjectsNames-BASIC| NIL (XCL-USER::DO-TEST "GetObjectNames basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME-LIST (LIST (CL:GENSYM))) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New|)) (TOSS-AWAY-1 (CL:DOTIMES (I 10) (CL:PUSH (CL:GENSYM) TEMP-INSTANCE-NAME-LIST ))) (TOSS-AWAY-2 (CL:DOLIST (ITEM TEMP-INSTANCE-NAME-LIST ) (_ TEMP-INSTANCE |SetName| ITEM))) (RESULTS (AND (LISTP (|GetObjectNames| TEMP-INSTANCE)) (EQ 12 (LENGTH (|GetObjectNames| TEMP-INSTANCE))))) ) (CL:DOLIST (ITEM TEMP-INSTANCE-NAME-LIST) (SETQ RESULTS (AND RESULTS (LT-FIND-NAME ITEM (|GetObjectNames| TEMP-INSTANCE))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-Rename-BASIC| NIL (XCL-USER::DO-TEST "Rename basic test, make sure Rename works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME-1 (CL:GENSYM)) (TEMP-INSTANCE-NAME-2 (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME-1)) (TOSS-AWAY (_ TEMP-INSTANCE |Rename| TEMP-INSTANCE-NAME-2 (LIST TEMP-INSTANCE-NAME-1))) (RESULTS (AND (LT-FIND-NAME TEMP-INSTANCE-NAME-2 (|GetObjectNames| TEMP-INSTANCE)) (NOT (LT-FIND-NAME TEMP-INSTANCE-NAME-1 (|GetObjectNames| TEMP-INSTANCE )))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-Rename-MORE-1| NIL (XCL-USER::DO-TEST "Rename more test, make sure Rename works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME-1 (CL:GENSYM)) (TEMP-INSTANCE-NAME-2 (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME-1)) (TOSS-AWAY-1 (CL:DOTIMES (I 10) (_ TEMP-INSTANCE |SetName| ( CL:GENSYM )))) (RESULTS (AND (EQ TEMP-INSTANCE (_ TEMP-INSTANCE |Rename| TEMP-INSTANCE-NAME-2 (LIST TEMP-INSTANCE-NAME-1 ))) (LT-FIND-NAME TEMP-INSTANCE-NAME-2 (|GetObjectNames| TEMP-INSTANCE)) (NOT (LT-FIND-NAME TEMP-INSTANCE-NAME-1 (|GetObjectNames| TEMP-INSTANCE))) (EQ 12 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE)))) )) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-SetName-BASIC| NIL (XCL-USER::DO-TEST "SetName Basic test, make sure SetName works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New|)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (RESULTS (AND (EQ TEMP-INSTANCE (_ TEMP-INSTANCE |SetName| TEMP-INSTANCE-NAME)) (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE))))) (_ ($! TEMP-INSTANCE-NAME) |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-UnSetName-BASIC| NIL (XCL-USER::DO-TEST "UnSetName Basic test, make sure UnSetName works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (TOSS-AWAY (_ TEMP-INSTANCE |UnSetName|)) (RESULTS (AND (EQ 1 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE))) (NOT (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE)))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.2-UnSetName-MORE-1| NIL (XCL-USER::DO-TEST "UnSetName More test, make sure UnSetName works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (TOSS-AWAY-1 (CL:DOTIMES (I 10) (_ TEMP-INSTANCE |SetName| ( CL:GENSYM )))) (TOSS-AWAY-2 (_ TEMP-INSTANCE |UnSetName| TEMP-INSTANCE-NAME)) (RESULTS (AND (EQ 11 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE))) (NOT (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE)))))) (_ TEMP-INSTANCE |UnSetName|) (SETQ RESULTS (AND RESULTS (EQ 1 (CL:LENGTH (|GetObjectNames| TEMP-INSTANCE))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/loops/LOOPS-TESTER-2-1.dfasl b/internal/test/loops/LOOPS-TESTER-2-1.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..6b80a93a49bf06e727d0d843ae292a5aa170ab97 GIT binary patch literal 10026 zcmeHNU2I!NcE0!WM}HPg(y}ZwihbAix*OS)SN^vY+oUMUq)hVCBxT8gx(X#-nT#l2 zf}~=5w*lm=)g-9cME+6k-NY@>q+KKp3ODUT(`+Jaceh)4ffQJ@MIVX+eb^Rxs*6P* z_8~~m&%KmnDcPb}v_P?jcxUF!nKNh3ocU(vjF$w*XecI!wAoU=pq6EAu3DO_%F|j| zu4r@RNmZT(y8NwhDw?7jLo73xBO_tSc zRh^PY)TyFcnabWcEccv}2Y)tMp39bR$USFHp9adw-s4AmPxN#*4+hgQ?(Pd3suPbl zJl6a5likgq-(Qw?Yl0wLrN0(I@OZ?%P;L?gw;+l7y+zkxG!_n}!l3;?ObJPX{_3K; zE1d}@27;*pe>9OC&UERE?jE_SmHY+ud9{E>n3X_^{@P;W;BX?8i7E;GjyNyv1cB~> z@L)6%_M=>AKB%;SM7xpOa)YZ;JV^PG6h7?rgS98c-@YK>+GY1w#D z5X8n^oVYk~a3VOqs^760r-0uP4~9~Ten-;p+MsCDCZ2=DnVqcWwc@>+JzKt7(eHw` zHRpJGuB4VpLMwe+%=%6gc9KXR>C?$}6d3=-E(I$3j)31n*gTh&ciMs&n2LzyP!9UrvQ7x!; zrox%wR03SoILi$rC56Jza|1`HkgZfmAUh6aTP$@hW2OXx8xmSItrn}y$qGQ9HscuO zSxM84xfT|TaR@mMQMna_G$qSgRjb}8smvn0Y4qyLww)fg5D2!yY8YJ(L@;&d00RYR z;m8-K)a!ys{5t{HU^z^p#wm5u=oJM)Lh!&pV0zQ& z)0f2~0dZ9bNFsH6JMv&B1|B;Rq5+e>5?0%7{3@b!|pJ zH3bK-Geow`W=o}f@#-LKMN~Blb5<&ASAz(Z&|nt`u}@u{=+$f6dye{tf(ifWqjJyj z-V-PEJDpq|&z35{)=K>9VRqsqy)2IiH;!ffjIE8wZs;-FcPj@ z#PR`Lq_mFhiQ!m`I2Wvjm*>&*LCJJDbEz&92u|9Fcu|u|u_RT$pxIn!6!iRm)(0BxYg8i&Mn($56J%Gz~!&EFxV{i2Pmsj?>_c`*(n& zg`lZ=Ia`?H9u|RUgM|f&V;Y57YG0=29|KU^j3DK~ZPA3ScnFFGsjb{5g-ZlO_wm*y%nYxoeKf z1K2(`2xv~~M-kO6%~<0ROU0j9s`JA5S7Kv{U_{;tF4IxrJXOJ%9h9k$*}{JlYiyO- z7(&e{e_Ad1PoIDTeeZFAnnufqs5Saplu_Jtv5j*qrodsIB+XhQ{fs+;CB@5&M~*OMM^B>K z0(~vi5LWfOyze{&_oy#Q@GR891`2Ra3NtdmT%evUV;91i{$M(s%%q^Wv+F`Zo5&XY zaq?GxC_9-`yQrgIKm*K3eB=NJ;v$?3P*CF-oEcFN@oZxSpbcl>)Ud`)9NU?XozRkP zLI;eA>5t9)%h*Qbndd2mh0mO@h@560rjP;_c@ePnERDHdf+@4sJl8`5T)Zt~a3L@) z!a7o~zo0Kn5cMa?)_}}$nByfTYi(^}G6zdi(PN04APBX=sUpf-^o0pxh6hx%=2`qp zD#E}K222t2bUHjoHQ@blHQ}y!s(7E_LE;$^*$}x9b*M?2zH~kWf219i_kGa8Np*|J z4Rv%jgo7e0I)Zi5acd56wvb8bAA+kQFBD4M zoTl#?YGF#FJo+DHo;QoNc0586%u@(pKx1d7YSv~q>Y)}YYQ3$M*5 zjfx*cq-VqrhorHOMtrwNI_GomC-ESMzi7_q!{Z=*EFu!}RsqwC7MITlIr#G-H3li> zeeRLY_j@gVl$hHf&Z_eyTu3%@q_ zwXZ1dw-oP#uPJVEyhFsYS6AAU_JdIUveKUOjkf`_;+CMnRJe%>C@vh8 zrONs|(h{H-rWV~wkr-alL;M85I|PDd$EzSfvDJEZeMW z_r>*Y!Paa$WDHqfCf$Tv zBrS`Sc_a5*R2nZb@i}fi%B6mzM0hD>dyVToNE7e-scO8FIXW;AK5fCOX*}oQ#IZS} zi5P~>;^9n08SsaKp-8w3*)EyuT_VVpCTKOEGGW%j5M(^^7^8s1U3{3N-X|DKA;bki zwrCujC4q51h`yj69b@tAjJjcy_R}#6#Q-1@tgk;2TwkM^l@EE4L*@ZWnt=06|C!=rVlB zT4tDjUs|OF`Wt_NrO1;@kp;^5Ai{_t#+nPFoJta`7=0$3lE>kqZUq<*8ate{(@CRr zdyqyw`t6#l&g`dv*^*vsv=(cVafrN7S`dvx5IKO!Xs+XTIt-_*Uqkr+dk80&yh7iX zelB(YS;m^t8U*@S7a8_lQE|^+2SbI>IZ$+xS`WxW#}IGOO(#Q5wRRI*({0%24nk z^0u|FQ1N@r*3nPYk7Dt*j+HpX|1r+cfN|8MR*`Uu>=0$D;L~W$HAXLvso^9&NlF50 zD;5O0kj_#tW9`j=>K2SNC_|@g2(!?A*$mk)P(4L?q`#uPcC+CUbrPJK>Mv-MGj!OZ zv##_b3|B%V3)EVRWZ?zVJy@8l`IL5Ep_;t-o3H^MgeI>&&MM zzA-O=`=Xi3Yo-Aeop7jz)47p>)oeFkG-#^XJQAJOL=J*+K#UEh-E@%l(x3AseU4ue zp6{kUuI)C?^RZD}z)5M$7a_i0oK&UrdTqB%H|ZicHWOudx+f3czx9jAo5nEMV?Vld z;HogAw7FJh6c@M@{5`s#pezh^DL0>=$7?7K-6L*OTwuU)--_b9t@v(H$xu30;g+{5 zJetqlg}n3%UHOy_a7ZuSOIJ{!BAp3F2##-_N*v-ZYz6kQOQs`L5|my(}{At zpq|o6a-d7^jN*gKaa+#keX*fk%zg0D&?+c+GcMlFJ!l`;kH?8)`c^>Xq>_16{8oE zD@GqCvhg$~9x4exHLgKP_*=Tw2^1X`@D3*YkSTv=^c9W16UNhDH_je5&XL%RL3g*a zMgRpJF@l(EGy1XFe-csnHzEpug0J?&#WaMm0cElNb*_KK2<8oVf({HA!JS698Th>T zz7fU$pa55@bhzjEnPUwoctKx0Ru>`Tzy53`KPgw$O7*Zj3pXLTGFMjRHJ)o)d8UF* zZyFIy4!&UwVc-93rt^^Y!LM^!@B|{CwGlYxa=1?L|0KwT?Ciu;7GXA)@gMCz>aUCT zLu4=-qPM;nT~y%zH;5sz*+_~M3>JP5Zbu!)CDBO1-C%LoruK0q754WmZv%Ctp`sw{ zeP$&$WNPq1Q7V53PJ?80g*IWRP4bN#@OeZ#xWz~C`5-b>q)I0|(Luo6te)jX%Za$!G)g!jB$c`1I{ zy}m|3GY|^vL}{D(JCOR|U0x~8TPo;VC(T!vhW9luYGf+7QUG0k*^+i`sV*)>Ye~~m z#3+ur6zfY`Y5UF^W~@Vr?OTf6vrgomy3Tv*7TAmuZbpfHE6Tpx%03GvWRPQ_gp6_s zC1jEVMhBGWsG~&3CX_h12_?Q}qJ$feVLSW~Et=uC6F(EH1?F zZv>S#?A^(r^6v~P|H7d1F@cKsT_ze#oFS~c4~@hOR}69m#k&Qp5Pr@u^D~B_?-}1j z;vX{c_5Tj`oWYosbV^@5T3`HxJ#h`7=9fc{bc~_r9~pAQ*Ua=Rr@}v(>F+}NB~bL0 ZFM%S4k}tucKY{@;7JUat|K8`H{}&-!7XAPL literal 0 HcmV?d00001 diff --git a/internal/test/loops/LOOPS-TESTER-2-2 b/internal/test/loops/LOOPS-TESTER-2-2 new file mode 100644 index 00000000..55752ce2 --- /dev/null +++ b/internal/test/loops/LOOPS-TESTER-2-2 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "17-Feb-88 15:29:01" {ERINYES}LOOPS>LOOPS-TESTER-2-2.\;6 1740 |changes| |to:| (FUNCTIONS LOOPS-TESTER-2.2 |LT-2.2-New-BASIC|) (VARS LOOPS-TESTER-2-2COMS) |previous| |date:| "17-Feb-88 12:12:56" {ERINYES}LOOPS>LOOPS-TESTER-2-2.\;2) (PRETTYCOMPRINT LOOPS-TESTER-2-2COMS) (RPAQQ LOOPS-TESTER-2-2COMS ((FUNCTIONS LOOPS-TESTER-2.2 |LT-2.2-New-BASIC|))) (CL:DEFUN LOOPS-TESTER-2.2 (&OPTIONAL (DETAIL-RESULTS NIL)) "Run each test for section 2.2" (CL:APPLY (CL:IF DETAIL-RESULTS 'LIST 'AND) (LIST (|LT-2.2-New-BASIC|)))) (CL:DEFUN |LT-2.2-New-BASIC| NIL (XCL-USER::DO-TEST "New basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE-NAME (CL:GENSYM)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| TEMP-INSTANCE-NAME)) (RESULTS (AND (|Instance?| TEMP-INSTANCE) (LT-FIND-NAME TEMP-INSTANCE-NAME (|GetObjectNames| TEMP-INSTANCE)) ))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/loops/LOOPS-TESTER-2-2.dfasl b/internal/test/loops/LOOPS-TESTER-2-2.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..26f7cdde3610b78eba9773bb0384cef1b0a99210 GIT binary patch literal 2005 zcmbVNU2oe|7(RB|CTTl2@vA|ZPy!4TWIyV+r6%^(P|5wRmFWIHbDKQ|fC&W` zR2_>H7u*YE0uV=tfpsY#ue4Xp);HG_s75zH6;16w1RyvuIiwjrdkHw z2=o+NTGn780#O0e$g*VNBaH8j-OziD#!d9(08I^UN$&?YO`v~Z4NEA9P_E1baE$^J z!z2bf0+Tpptbh&{)g=)|@=y$!D7g9eS>NMx^CHAbTv!;!=uGZ`cj{kf0($&9{9OJ3 z9lf{@7ubOjL&(h>p;rjfK$r;``}-^i89zx3Dz~Kh9;aYiQZ>=UR#~$xb_&)4(r9V=r54V5XWH!EoCpFVp zrqHDnn^`@cNirj#%rh9@mmqxTsSAZv&lusGP`W*q9JGfT_`(i z4VqgCTF7fVY?2L5MW%xHBMHa~E{jc*nBt)9vymh?OlBp0O$_Z;h!%sQ7RwekgX2?? zmlZlelVcem#tOtNNj9BcpvTE&(}c_$bQoPK;b4xgO~G~2GUS_6gYxWF-ICLFTQ$-y zI*o1EfPRJz?7MH%*Pnv3^x=VJQlm(^B2px3ybDHd#p#muFCbm@%9hh<24~L&ADp3F zRHz^}#-uF(}v_xlbNwdO61-@%Fq23&P zaj5Oqdz8p8k7xq~jjxmdLma3phJuT@*=>h+z5ghXmtf2spyb8ku%g{zH}kzrqq4PL zt59@M?{Dpi0VeblAZx@bo0y&jKaY`_aR~ac@OuDlPqd3BSrtE#v@*7WQ%p3tfDoGo eUJ03$4BEmW9w7uJ8^2=MX0fba&Og*%y!aF3X+=^1 literal 0 HcmV?d00001 diff --git a/internal/test/loops/LOOPS-TESTER-2-4 b/internal/test/loops/LOOPS-TESTER-2-4 new file mode 100644 index 00000000..d089d9a4 --- /dev/null +++ b/internal/test/loops/LOOPS-TESTER-2-4 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "17-Feb-88 16:58:58" {ERINYES}LOOPS>LOOPS-TESTER-2-4.\;4 12236 |changes| |to:| (FUNCTIONS |LT-2.4-DeleteIV-F-MORE-1| |LT-2.4-AddIV-MORE-1| |LT-2.4-AddIV-M-MORE-1| |LT-2.4-AddIV-F-BASIC| LOOPS-TESTER-2.4 |LT-2.4-AddIV-F-MORE-1| |LT-2.4-AddIV-M-BASIC| |LT-2.4-DeleteIV-M-MORE-1| |LT-2.4-Delete-IV-M-BASIC-1| |LT-2.4-Delete-IV-F-MORE-1| |LT-2.4-DeleteIV-F-BASIC| |LT-2.4-DeleteIV-M-BASIC|) (VARS LOOPS-TESTER-2-4COMS) |previous| |date:| "17-Feb-88 16:39:14" {ERINYES}LOOPS>LOOPS-TESTER-2-4.\;1) (PRETTYCOMPRINT LOOPS-TESTER-2-4COMS) (RPAQQ LOOPS-TESTER-2-4COMS ((FUNCTIONS LOOPS-TESTER-2.4 |LT-2.4-AddIV-F-BASIC| |LT-2.4-AddIV-F-MORE-1| |LT-2.4-AddIV-M-BASIC| |LT-2.4-AddIV-M-MORE-1| |LT-2.4-DeleteIV-F-BASIC| |LT-2.4-DeleteIV-F-MORE-1| |LT-2.4-DeleteIV-M-BASIC| |LT-2.4-DeleteIV-M-MORE-1|))) (CL:DEFUN LOOPS-TESTER-2.4 (&OPTIONAL (DETAIL-RESULTS NIL)) "Run each test for section 2.4" (CL:APPLY (CL:IF DETAIL-RESULTS 'LIST 'AND) (LIST (|LT-2.4-AddIV-F-BASIC|) (|LT-2.4-AddIV-F-MORE-1|) (|LT-2.4-AddIV-M-BASIC|) (|LT-2.4-AddIV-M-MORE-1|) (|LT-2.4-DeleteIV-F-BASIC|) (|LT-2.4-DeleteIV-F-MORE-1|) (|LT-2.4-DeleteIV-M-BASIC|) (|LT-2.4-DeleteIV-M-MORE-1|)))) (CL:DEFUN |LT-2.4-AddIV-F-BASIC| NIL (XCL-USER::DO-TEST "AddIV function Basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (|AddIV| TEMP-INSTANCE 'TEMP 1234)) (RESULTS (AND (EQ 1234 (|GetValue| TEMP-INSTANCE 'TEMP))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-AddIV-F-MORE-1| NIL (XCL-USER::DO-TEST "AddIV function MORE test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (|AddIV| TEMP-INSTANCE 'TEMP "A string" 'PROP-TEST)) (RESULTS (AND (EQUAL "A string" (|GetValue| TEMP-INSTANCE 'TEMP 'PROP-TEST))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-AddIV-M-BASIC| NIL (XCL-USER::DO-TEST "AddIV method Basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (_ TEMP-INSTANCE |AddIV| 'TEMP 1234)) (RESULTS (AND (EQ 1234 (_ TEMP-INSTANCE |Get| 'TEMP))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-AddIV-M-MORE-1| NIL (XCL-USER::DO-TEST "AddIV method MORE test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (_ TEMP-INSTANCE |AddIV| 'TEMP "A string" 'PROP-TEST)) (RESULTS (AND (EQUAL "A string" (_ TEMP-INSTANCE |Get| 'TEMP 'PROP-TEST))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-DeleteIV-F-BASIC| NIL (XCL-USER::DO-TEST "DeleteIV function Basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (|AddIV| TEMP-INSTANCE 'TEMP 1234)) (RETURNED-INSTANCE (|DeleteIV| TEMP-INSTANCE 'TEMP)) (RESULTS (AND (EQ TEMP-INSTANCE RETURNED-INSTANCE) (NOT (_ TEMP-INSTANCE |HasAttribute| 'IV 'TEMP))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-DeleteIV-F-MORE-1| NIL (XCL-USER::DO-TEST "DeleteIV method Basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (|AddIV| TEMP-INSTANCE 'TEMP "A string" 'PROP-TEST)) (RETURNED-INSTANCE (|DeleteIV| TEMP-INSTANCE 'TEMP 'PROP-TEST)) (RESULTS (AND (EQ TEMP-INSTANCE RETURNED-INSTANCE) (NOT (_ TEMP-INSTANCE |HasAttribute| 'IV 'TEMP 'PROP-TEST))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-DeleteIV-M-BASIC| NIL (XCL-USER::DO-TEST "DeleteIV method Basic test, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (|AddIV| TEMP-INSTANCE 'TEMP 1234)) (RETURNED-INSTANCE (_ TEMP-INSTANCE |DeleteIV| 'TEMP)) (RESULTS (AND (EQ TEMP-INSTANCE RETURNED-INSTANCE) (NOT (_ TEMP-INSTANCE |HasAttribute| 'IV 'TEMP))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (CL:DEFUN |LT-2.4-DeleteIV-M-MORE-1| NIL (XCL-USER::DO-TEST "DeleteIV method more testing, make sure works" (LET* ((CLASS-NAME (LT-BUILD-CLASS-NAME)) (TEMP-INSTANCE (_ ($! CLASS-NAME) |New| (CL:GENSYM))) (TOSS-AWAY (|AddIV| TEMP-INSTANCE 'TEMP "A string" 'PROP-TEST)) (RETURNED-INSTANCE (_ TEMP-INSTANCE |DeleteIV| 'TEMP 'PROP-TEST)) (RESULTS (AND (EQ TEMP-INSTANCE RETURNED-INSTANCE) (NOT (_ TEMP-INSTANCE |HasAttribute| 'IV 'TEMP 'PROP-TEST))))) (_ TEMP-INSTANCE |Destroy!|) (_ ($! CLASS-NAME) |Destroy|) RESULTS))) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/loops/LOOPS-TESTER-2-4.dfasl b/internal/test/loops/LOOPS-TESTER-2-4.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..72da8b6df754126533031c4669d7d0ca223b801c GIT binary patch literal 8488 zcmd^^e{37&8OQJJwE0>0oTkQvG`)txSm?D)mb6YO(98MKxV8Oywv$qZRNTbHS)I5_ z9I6V63ItKW0-Dh5-crOgF@YwuZlGym1w6#W=q3%uhWKM*nzXS$(56)g2@Pp<&+|U# z#EqRa4Ge9pvish>Kc0KS zgCohY!NidbYTH(|C%J!gJTZDiZR_&+pl8dr&aQ3kof~U<^jMHCcR35UZmhZR)U@Nu zj3h~Sh)=B~x!p3JS4)y2Ib`c(&eanLnnu)w-TQ;ga7fl;Ii)og*Ta52>em9{NMF3w z$|-GXHgiZzC+|$A@gWR5z>4*FuBxXmY{UaBY)#3>9IL^g;x~H&VN*l9u)K%Wg2f6J zF~g23Sg@S+#lhqo_@S#Zq8q#QozPJo2*cwH z24WG}$}PVuJf2P;m7bcGR?^MkZNUvHQkl)dki?z1MY$HXSP2`5L|Md90VmbCQ9s;% z3?GLgUSQFylPh7F^@PL9)wgZc;1y{;pLjLCZJoZ8xvwwU0i@HV<~MdsOPh8~!42F8 z->P{&sYd(X3cNjj1>B4*?#7yOz_YEsmPPOl=s_#z@|$rz5Y(b(tS=akRbLO|%k)Sj zxOXjF-5ZQ+?HfBZe=?oSCIkIiNDHy3skJr1;1#8V-FhrwTv={mkG;@SZefom7OsM^ z)wWT6aIold3XC+&84*irN|qEZw4!8*eHBL~+@ce_)roEf-Vv9U<`nLj8Q1*G=nI+Q zxQ-7L+~cuX2bcL3;0w7m(eV*AnHWf^+2oiV50V4fq0ER1k5)R(*H2g92QO&nh$OAO zHJ{q`uLda(FZZPpdEZ%Ru^U~rLE6>eXx!7(=$0$s#lI2)Bwxh=w_F*1U6S@Gd8SM< z<$gS|nCqMrJ|~?&mU;pX9mm69iMhbt>-W{?!>~T>VD+w7v3sQA9q7+PgJ(7s=V2Nd zUm=Wp^2{^IJht(MS>p`_;|;>Nk`EtbiYt%1gB_8HI;P+T8}qDjk~L0Oym1p&-#`^mz8|2hWuk1P}ok-mqk|$F?^6Y6w)A)sZse|ng z4X7tl$`AypI(YL}wGx(ra1cXF$c*x0ui5HY!8bT6;fpXgwHhq!58&I=dci4z z5P!P^&=cMnYjrrS$(*|t0=3Z#gv9%zVJ%{`S|=c!#P&k04nagLnGt8Le3R3~HRnoj z2Un{Zjk2glQLNRez=FC~J-k;F{V`#!3PP9G7c--Ly~|mMJhkW*H-L%dJuDj1<9O=B z%Nc#qD7YL2%&;CZc?XVF!R>eraJ1wggq`d_DwNEoGJ|ZiH<>;J6Qs9bf@A$UJbaCJ zVe<&|xa}o7li5IjeF#2>{c0^_^xowl_4$yW04+4KTC{KU{W0$A5E%FNPw%nt)s0R`t*@NoP2#G27 z-E$3Y?%gLb$iwr#Ed(|+deWMBlA1Y^9ToRK`6SLXQ=ag z)R{xC!0bmPIXM0hH;(c>$R+pNNOH3*i(5K`wr#g^S{W8GmzW<#AMeGBy>C-=%5EP+ zn)q%Uny_+Jx(e}TXylF~MaK&;wRT>nD6v7PIOe7^Eb%BHa|N^O~}!80rDo`SG@3RweK5n01* zZcryo*t%}#1|aK&!~;~F5)Tsfvblkaa)ahPYo27yh1{U2C^u-D$qkysPT+Eo8#K=3 z2A-1KpapLbzcabPdOJ680eN-st(}KJ1ytJ&1l9wAEy~4G{45dp3=xj6ZR&E24I4rUQl*CJE;%Nb*tlI#7X18ad9f$7%w9Thr zAxik?fo-4&wsi#C*;3ek_g@Sf`X16!fxs1<(Je29I5dOY&dS|a8oG6JpgTj*Jx|cx zP0$$xT_@4@kFwCMMsGh%(A`daMG3mi1l?8C=^~~+<$DmOPYA6K`F=cmm#}-2ro2c~ zmPX%}6}X@0tlae_^ewD{&k%e8f=*s;!}oK$eYr^XaLZ?k&MyJyd{S7b@#mrQ+eLJ$ z)8e)sFQxOj|2UmRr7Ipn&Wx2Ut3Urj0EsK8&j5E|Z&|Fcb3!U@84%m#&c}V9JQ3EeU=gMW7#Tuv1;#P+a zIzhPIOSpZLaPtywD~Pi^HCUcO^+vx7-FZ(LTArkTfS<^zi^@O(azRz7IuHWgf4U3_MFKhbra zP1Of>`yFT(SCo4>w;;%t8Xs}cIwlxIzotjRXjI9um67V5l4QJ{HI|Gc*Td2Rh$$-Jn4 zYM!Z+Oq~#CoHc{~LBS~WuNmt+FX~^jFawwK9%M~W=gp^o>+yl%cc#v})~@qbLVZ`W zK%M7?ISkIm#!%oFFiV3Cw*2 z=8cqfUPql*QKy55yg)>LL`1$%M7~W#{*5hk)}ZOM~;r1ZO`% zDX+5OeA8}^LAx{wT)6tfp!7fyn`?;8cS_m(@JnG6{R^D3@FQd)ue>}yQSh*eDb!x3}M)q+NOIRX1m0`@Ni<$DC|t0bXkiQ69%x16TrxW2d_PPcB}EPgo67w4@- zx;mVJKU&})G2oZavVX@oOYq)q!@I_Y_AR@efcEn%>?JBiBsn)j@+mx>x^Us&DoR63 literal 0 HcmV?d00001 diff --git a/internal/test/loops/LOOPS-TESTER-BASICS b/internal/test/loops/LOOPS-TESTER-BASICS new file mode 100644 index 00000000..d1f19b25 --- /dev/null +++ b/internal/test/loops/LOOPS-TESTER-BASICS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "17-Feb-88 15:35:24" {ERINYES}LOOPS>LOOPS-TESTER-BASICS.\;4 1082 |changes| |to:| (FUNCTIONS LT-BUILD-CLASS-NAME XCL-USER::TEMP-TEMP) (VARS LOOPS-TESTER-BASICSCOMS) |previous| |date:| "17-Feb-88 13:15:00" {ERINYES}LOOPS>LOOPS-TESTER-BASICS.\;1) (PRETTYCOMPRINT LOOPS-TESTER-BASICSCOMS) (RPAQQ LOOPS-TESTER-BASICSCOMS ((FUNCTIONS LT-BUILD-CLASS-NAME LT-FIND-NAME))) (CL:DEFUN LT-BUILD-CLASS-NAME NIL "Really only want to do this once in awhile, messing up (FILES?)" (LET* ((CLASS-NAME (CL:GENSYM))) (|DefineClass| CLASS-NAME) CLASS-NAME)) (CL:DEFUN LT-FIND-NAME (NAME LIST-OF-NAMES) "Walk through a list of names looking for a name" (LET* ((RESULTS NIL)) (CL:DOLIST (ITEM LIST-OF-NAMES) (CL:IF (EQ ITEM NAME) (SETQ RESULTS T))) RESULTS)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/test/loops/LOOPS-TESTER-BASICS.dfasl b/internal/test/loops/LOOPS-TESTER-BASICS.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..6642fe55502ac416294631276b2aa0d1beef5afa GIT binary patch literal 1048 zcmbVLTTj$L6rPr4m)#}0t1-q0%se8YnB@{yG-7F|P%Z7I(+%=i*)H2q+D$JKLP(6y zO^_g@Yve!p2)y`@jQ;@76yhcE1(Igc`Py^lyUaO6!*3-GOTl*E^_&m~N!(9j+zmn; z1xdK!;4a{JkC>{yPU!v%Nwmn!OU*D^^lB9>LM>tnOCnVzI`w?ELjNk<2pv0iI(W_L z_)gTZcPDXU9xKkfFtNj3+<4Y(0y4KSGq*4|JylUes$HFUgTmRyRORyYgntwugf{c1 zicr1Iv3(h#8sfR^IK88&8j(x_0%XmQc$6KawFzp8x-6Qqpz5u*HIb#Y29ATi;5qLd zkNL38LznDRI-<07$x;nHJK{d@51?U9CW@*Pf%S!Q#i&BZg3%&6KLQ0sqisRUVR$Xe zs!8%+GOI*@OmJUGz0F_#z^hR6;psecPsHV~um!-u$J@LGKbb5mBUWsF} zKwu61hb(+TgCRzds{+Lm5NMf3i!Z>Y%!tY$pE5h{=NbN+9#?|O>@%OG_Zss8q$D(( z*Xc~p9;cHxxd!NKeuyP3wN*_PBu%7L(8X19f<{LWI$MEczOU5K;34;$Ghc+7s_b-K z-;q2!ia2nzxJ-1qz6w9x%7Qv2mLMBadzI*x$N~g24*tZ+0fADME}D+*dAm69VcD_$ z7;XXX1UT-w5r8lVu8-}V9!$d|-gctM^*3?S$K%XYy7(lQJE~c58+7?v=UDGdJnvno zhw8`PMao^ge)aRvJyZGfZ$FrDJcJORhm{?HINTERNAL>LIBRARY>DO-TEST.\;15 16187 IL:|changes| IL:|to:| (IL:VARIABLES *TEST-FILE-PATTERN*) IL:|previous| IL:|date:| "25-Mar-87 16:19:44" IL:{ERIS}INTERNAL>LIBRARY>DO-TEST.\;14 ) ; Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DO-TESTCOMS) (IL:RPAQQ IL:DO-TESTCOMS ((IL:VARIABLES *ANY-ERRORS* *TEST-CLEANUP-FORMS* *TEST-COMPILE* *TEST-MODE* *TEST-BATCH-RESULTS* *TEST-FILE-PATTERN* *TEST-FILE-NAME*) (IL:P (DEFPACKAGE "XCL-TEST" (:USE "LISP" "XCL") (:IMPORT DO-TEST-FILE DO-ALL-TESTS DO-TEST DO-TEST-GROUP CL-READFILE EXPECT-ERRORS TEST-DEFUN TEST-DEFMACRO TEST-SETQ *TEST-MODE* *TEST-COMPILE* *TEST-BATCH-RESULTS* *TEST-FILE-PATTERN* *TEST-FILE-NAME*))) (IL:FUNCTIONS DO-TEST DO-TEST-GROUP TEST-DEFMACRO TEST-DEFUN TEST-SETQ WITHOUT-BATCH-MODE-ERRORS EXPECT-ERRORS DO-ALL-TESTS CURRENT-FILE-NAME CL-READFILE DO-TEST-FILE DO-TEST-LIST) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) DO-TEST))) (DEFVAR *ANY-ERRORS* NIL) (DEFVAR *TEST-CLEANUP-FORMS* NIL) (DEFVAR *TEST-COMPILE* NIL) (DEFVAR *TEST-MODE* :BATCH) (DEFVAR *TEST-BATCH-RESULTS* "{eris}cml>test>test-results" ) (DEFVAR *TEST-FILE-PATTERN* '("{ERIS}CML>TEST>*.TEST;" "{ERIS}CML>TEST>*.X;" "{ERIS}PATCHES>TESTS>*.TEST;" "{ERIS}TEST>*.TEST;") ) (DEFVAR *TEST-FILE-NAME* "unknown" ) (DEFPACKAGE "XCL-TEST" (:USE "LISP" "XCL") (:IMPORT DO-TEST-FILE DO-ALL-TESTS DO-TEST DO-TEST-GROUP CL-READFILE EXPECT-ERRORS TEST-DEFUN TEST-DEFMACRO TEST-SETQ *TEST-MODE* *TEST-COMPILE* *TEST-BATCH-RESULTS* *TEST-FILE-PATTERN* *TEST-FILE-NAME*)) (DEFMACRO DO-TEST (IL:NAME-AND-OPTIONS &BODY IL:BODY) (LET ((IL:NAME NIL) (IL:OPTIONS NIL)) (COND ((CONSP IL:NAME-AND-OPTIONS) (SETQ IL:NAME (CAR IL:NAME-AND-OPTIONS)) (SETQ IL:OPTIONS (CDR IL:NAME-AND-OPTIONS))) (T (SETQ IL:NAME IL:NAME-AND-OPTIONS))) (IF (OR (EQ *TEST-MODE* :INTERACTIVE) (EQ *TEST-MODE* :BATCH-VERBOSE)) (FORMAT *ERROR-OUTPUT* "Testing... ~S~%" IL:NAME)) `(NOT (WHEN (NULL (WITHOUT-BATCH-MODE-ERRORS ,@IL:BODY)) (FORMAT *ERROR-OUTPUT* "Test \"~A\" failed in file \"~A\"~%" ',IL:NAME ( CURRENT-FILE-NAME )) (IL:SETQ *ANY-ERRORS* T))))) (DEFMACRO DO-TEST-GROUP (IL:NAME-AND-OPTIONS &BODY IL:BODY) (LET ((IL:NAME NIL) (IL:OPTIONS NIL)) (COND ((CONSP IL:NAME-AND-OPTIONS) (SETQ IL:NAME (CAR IL:NAME-AND-OPTIONS)) (SETQ IL:OPTIONS (CDR IL:NAME-AND-OPTIONS))) (T (SETQ IL:NAME IL:NAME-AND-OPTIONS))) (IL:* IL:|;;| "Hack: find :BEFORE and :AFTER clauses in the body and move them out") (LOOP (IF (AND (SYMBOLP (CAR IL:BODY)) (OR (EQ (CAR IL:BODY) :BEFORE) (EQ (CAR IL:BODY) :AFTER))) (PROGN (IL:SETQ IL:OPTIONS (IL:APPEND IL:OPTIONS (LIST (CAR IL:BODY) (CADR IL:BODY)))) (IL:SETQ IL:BODY (CDDR IL:BODY))) (RETURN NIL))) `(LET ((*TEST-CLEANUP-FORMS* NIL)) (BLOCK ,IL:NAME ,(IF (OR (EQ *TEST-MODE* :INTERACTIVE) (EQ *TEST-MODE* :BATCH-VERBOSE)) (FORMAT *ERROR-OUTPUT* "Testing... ~S~%" IL:NAME)) ,(LET ((IL:BEFORE (IGNORE-ERRORS (GETF IL:OPTIONS :BEFORE)))) (IF IL:BEFORE `(WHEN (NULL (WITHOUT-BATCH-MODE-ERRORS ,IL:BEFORE T)) (FORMAT *ERROR-OUTPUT* ":BEFORE forms for test \"~A\" in file ~S failed." ',IL:NAME (CURRENT-FILE-NAME)) (IL:SETQ *ANY-ERRORS* T) (RETURN-FROM ,IL:NAME)))) ,@(IL:|for| IL:B IL:|in| IL:BODY IL:|join| (IL:|if| (AND (CONSP IL:B) (EQ (CAR IL:B) 'DO-TEST)) IL:|then| (LIST IL:B) IL:|else| (FORMAT *ERROR-OUTPUT* "Non DO-TEST form in ~S in ~S~%~S~%" IL:NAME (CURRENT-FILE-NAME) IL:B))) ,(LET ((IL:AFTER (IGNORE-ERRORS (GETF IL:OPTIONS :AFTER)))) (IF IL:AFTER `(WHEN (NULL (WITHOUT-BATCH-MODE-ERRORS ,IL:AFTER T)) (FORMAT *ERROR-OUTPUT* ":AFTER forms for test \"~A\" in file ~S failed." ',IL:NAME (CURRENT-FILE-NAME)) (SETQ *ANY-ERRORS* T))))) (EVAL (CONS 'PROGN *TEST-CLEANUP-FORMS*)) NIL))) (DEFMACRO TEST-DEFMACRO (IL:NAME &REST IL:STUFF) `(PROGN (IF (FBOUNDP ',IL:NAME) (IF (MACRO-FUNCTION ',IL:NAME) (PUSH (LIST 'SETF (LIST 'SYMBOL-FUNCTION (LIST 'MACRO-FUNCTION '',IL:NAME)) (LIST 'QUOTE (SYMBOL-FUNCTION (MACRO-FUNCTION ',IL:NAME)))) *TEST-CLEANUP-FORMS*) (ERROR "Please don't redefine ~A in a test form" ',IL:NAME)) (PUSH (LIST 'REMPROP '',IL:NAME ''IL:MACRO-FN) *TEST-CLEANUP-FORMS*)) (DEFMACRO (IL:\\\, IL:NAME) ,@IL:STUFF ) )) (DEFMACRO TEST-DEFUN (IL:NAME &REST IL:STUFF) `(PROGN (IF (FBOUNDP ',IL:NAME) (IF (OR (MACRO-FUNCTION ',IL:NAME) (SPECIAL-FORM-P ',IL:NAME)) (ERROR "Please don't redefine ~A in a test form" ',IL:NAME) (PUSH (LIST 'SETF (LIST 'SYMBOL-FUNCTION '',IL:NAME) (LIST 'QUOTE (SYMBOL-FUNCTION ',IL:NAME))) *TEST-CLEANUP-FORMS*)) (PUSH (LIST 'FMAKUNBOUND '',IL:NAME) *TEST-CLEANUP-FORMS*)) (DEFUN (IL:\\\, IL:NAME) ,@IL:STUFF ) )) (DEFMACRO TEST-SETQ (&REST STUFF) (LET (UNBINDLIST) (DO ((X STUFF (CDDR X))) ((NULL X)) (PUSH `(IF (BOUNDP ',(CAR X)) (PUSH (LIST 'SETQ ',(CAR X) (LIST 'QUOTE (SYMBOL-VALUE ',(CAR X)))) *TEST-CLEANUP-FORMS*) (PUSH (LIST 'MAKUNBOUND '',(CAR X)) *TEST-CLEANUP-FORMS*)) UNBINDLIST)) `(PROGN ,@UNBINDLIST (SETQ ,@STUFF)))) (DEFMACRO WITHOUT-BATCH-MODE-ERRORS (&BODY IL:BODY) (COND ((EQ *TEST-MODE* :INTERACTIVE) `(PROGN ,@IL:BODY)) (T `(IGNORE-ERRORS ,@IL:BODY)))) (DEFMACRO EXPECT-ERRORS (IL:ERROR-TYPES &REST IL:FORMS) `(CONDITION-CASE (PROGN ,@IL:FORMS NIL) (,IL:ERROR-TYPES (CONDITION) (VALUES T CONDITION)))) (DEFUN DO-ALL-TESTS (&KEY (RESULTS *TEST-BATCH-RESULTS*) (PATTERNS (IF (CONSP *TEST-FILE-PATTERN*) *TEST-FILE-PATTERN* (LIST *TEST-FILE-PATTERN*))) (SYSOUT-TYPE NIL) (RESUME NIL)) (LET ((IL:NO-PROBLEMS T) (*DEFAULT-PATHNAME-DEFAULTS* (PATHNAME "{ERIS}CML>TEST>")) (*ERROR-OUTPUT* (IF (EQ RESULTS T) *ERROR-OUTPUT* (OPEN RESULTS :DIRECTION :OUTPUT :IF-EXISTS (IF RESUME :APPEND :NEW-VERSION))))) (UNWIND-PROTECT (PROGN (IF (NOT RESUME) (PROGN (FORMAT *ERROR-OUTPUT* ";;; Test results for sysout of ~A~%" IL:MAKESYSDATE ) (IF SYSOUT-TYPE (FORMAT *ERROR-OUTPUT* ";;; Sysout type is ~A~%" SYSOUT-TYPE)) (IF *TEST-COMPILE* (FORMAT *ERROR-OUTPUT* ";;; Tests are being compiled~%") ) (FORMAT *ERROR-OUTPUT* ";;; Tests run on ~A~%" (IL:DATE)) (FORMAT *ERROR-OUTPUT* ";;; Running tests from ~A~2%" PATTERNS) (SETQ *ALL-FILES-REMAINING* (IL:FOR DP IL:IN PATTERNS IL:JOIN (IL:DIRECTORY DP)))) (FORMAT *ERROR-OUTPUT* ";;;Resuming after dying on file ~S~%" (POP *ALL-FILES-REMAINING*))) (IL:|while| *ALL-FILES-REMAINING* IL:|do| (IL:SETQ IL:NO-PROBLEMS (AND (DO-TEST-FILE (CAR *ALL-FILES-REMAINING* )) IL:NO-PROBLEMS)) (IL:|pop| *ALL-FILES-REMAINING*)) (FORMAT *ERROR-OUTPUT* "(END-OF-TESTS)")) (UNLESS (EQ RESULTS T) (CLOSE *ERROR-OUTPUT*))) IL:NO-PROBLEMS)) (DEFUN CURRENT-FILE-NAME NIL *TEST-FILE-NAME*) (DEFUN CL-READFILE (IL:TEST-FILE &OPTIONAL (*READTABLE* IL:CMLRDTBL) (IL:ENDTOKEN "STOP"))  (IL:* IL:|Pavel| "23-Sep-86 12:40") (IL:|if| (PROBE-FILE IL:TEST-FILE) IL:|then| (LET (IL:FORMS-LIST IL:TEM (*PACKAGE* (FIND-PACKAGE 'XCL-TEST)) (*FEATURES* (CONS :NO-STACK-OVERFLOW *FEATURES*))) (WITH-OPEN-STREAM (IL:TEST-FILE (IL:OPENTEXTSTREAM (IL:MKATOM IL:TEST-FILE))) (IL:|until| (OR (NULL (IGNORE-ERRORS (SETQ IL:TEM (READ IL:TEST-FILE)))) (AND (SYMBOLP IL:TEM) (STRING= IL:TEM IL:ENDTOKEN))) IL:|do| (PUSH IL:TEM IL:FORMS-LIST)) (NREVERSE IL:FORMS-LIST))) IL:|else| (PROGN (FORMAT *ERROR-OUTPUT* "~%Couldn't find file ~A~%" IL:TEST-FILE) NIL))) (DEFUN DO-TEST-FILE (IL:FILENAME)  (IL:* IL:|Pavel| "23-Sep-86 12:19") (LET* ((*PACKAGE* (FIND-PACKAGE 'XCL-TEST)) (IL:TEST-FORMS (CL-READFILE IL:FILENAME IL:CMLRDTBL)) (*TEST-FILE-NAME* (LET ((IL:PF (PATHNAME IL:FILENAME))) (FORMAT NIL "~A.~A;~A" (PATHNAME-NAME IL:PF) (PATHNAME-TYPE IL:PF) (PATHNAME-VERSION IL:PF)))) (*ANY-ERRORS* NIL)) (DO-TEST-LIST IL:TEST-FORMS) (IL:|if| *ANY-ERRORS* IL:|then| (TERPRI *ERROR-OUTPUT*)) (NOT *ANY-ERRORS*))) (DEFUN DO-TEST-LIST (TEST-FORMS &OPTIONAL OPTIONS NAME) (LET ((IL:DFNFLG NIL)) (DECLARE (SPECIAL IL:DFNFLG)) (IL:|if| (NULL TEST-FORMS) IL:|then| (FORMAT *ERROR-OUTPUT* "~%(Trouble reading ~A)~%" (CURRENT-FILE-NAME)) (SETQ *ANY-ERRORS* T) IL:|else| (IL:|for| FORM IL:|in| TEST-FORMS IL:|do| (IL:BLOCK 0) (IF (AND (CONSP FORM) (OR (EQ (CAR FORM) 'DO-TEST) (EQ (CAR FORM) 'DO-TEST-GROUP))) (IF *TEST-COMPILE* (BLOCK COMPILER-PUNT (LET ((COMPILED-FORM (IF (EQ *TEST-MODE* :INTERACTIVE) (COMPILE NIL `(LAMBDA NIL ,FORM)) (IGNORE-ERRORS (COMPILE NIL `(LAMBDA NIL ,FORM)))))) (IF (NULL (COMPILED-FUNCTION-P COMPILED-FORM)) (LET ((*PRINT-LEVEL* 3) (*PRINT-LENGTH* 3)) (FORMAT *ERROR-OUTPUT* "Compilation of this form in file ~S failed:~% ~S~%" (CURRENT-FILE-NAME) FORM) (RETURN-FROM COMPILER-PUNT)) (IF (NULL (IF (EQ *TEST-MODE* :INTERACTIVE) (PROGN (FUNCALL COMPILED-FORM) T) (IGNORE-ERRORS (PROGN (FUNCALL COMPILED-FORM) T)))) (LET ((*PRINT-LEVEL* 3) (*PRINT-LENGTH* 3)) (FORMAT *ERROR-OUTPUT* "Compiled code failed for this form in file ~S :~%~S~%" (CURRENT-FILE-NAME) FORM)))))) (EVAL FORM)) (FORMAT *ERROR-OUTPUT* "Non DO-TEST form at top level in ~S~%~S~%" ( CURRENT-FILE-NAME ) FORM)))))) (IL:PUTPROPS DO-TEST IL:MAKEFILE-ENVIRONMENT (:READTABLE "xcl" :PACKAGE "xcl")) (IL:PUTPROPS DO-TEST IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:DO-TEST IL:COPYRIGHT ("Xerox Corporation" 1986 1987)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/internal/test/lyric/DO-TEST.dfasl b/internal/test/lyric/DO-TEST.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..a2c890cb33b91eff37379608242ca5e123c4c8b0 GIT binary patch literal 10386 zcmcIqdu&_RdA|?7^rA^yax5i|>4*H_LP2)y_?37fsVk8Z$xGf#O0u0cRU|r;Ela8% zZQRtF{7Sl(TWl*xK||SKr|7Ej-Q?w8O=`y#%HD{W~Kut#wP<)<1>>( z`M?R#121Vt+&ueqB5tOmx}hD3r?Q%n3MY;v;t?Zk96i#hhq9WPZ9BYsU#(fuacD9> zIGrC3WM}eI!-Hp@2<#7pCniTm1G^6%*#88chxR>nXz#(c+ODvf5OaM-mp$!=+VR`n zR{Qadg_`q{B>ik0j~Yo@{vzoMl7wHKB>DZa-G7}RQV|u)C}H%=7Yaj;ioB~L@3Hfj z&~~W7F1<`64AoZ`z12mZy=tGN$favVZ&y5_MGY;S)jAV;RFO)r7JWf88%}kGjm}U! zmCj{@s#3aItPh4$M?;!n=!O|AT`3hk*vU}N)C^Tcbz_h=Bos|(;Z!ai>e7v*8Dy&J zK%LjB)01h;MpP%Lb%L7IJ2}Z!9wZXZMq?pEGjoY7AH#-5R}}e?T+zflyRWCiPT^kVp-G1opThdM?$;i$7p~qFxipE6o2A^N%zC5c59^ z-nzlNw4tYy$onvQJf(&B^5dy4J&KVWdRj~EL&k$<(L^|&46&wG*0hl|HL<2z*5qVO z^)$gEYoO#$7zf~0=Alv%uj1saqS8g?ev!FGne%JRk;8;FG*c(G)ih`+)`96jAD510 z<+9HpThkdgG|mbyjj>#s2jlp@(q>ZWa#6(=mx>PJK&hx=&r9=bXq0#|ts7Y|uHG7( zzZ*C&DB(ncA5oK2?D=`2*6z@4=(#i})d5NXVJ9tGw9y9ASeb=4PHNx)10QoK(Znt% z!%;)$q#8~#wQPo|%*|ZP!)gTUep)KJXU0yAjem2D-t;d@^Nv#SJ~>9%2C zKGK8@+K+5FlECisZNFS}M8c-laIjQ#y_A|69X-3dG_L@?ZWCJ-4<}f|E)du=tY))F zJF|&q7Nl2=aWiB-|kgs7!4&>PX||73tX?mUU!8! z07CYu_JH2V>E_X7L{F?#IM%bRYXDDg{>6#GvEh&fL#EcVtul+tjs<0`L-}b;UWzHV z3wH|d#nme#bA^Std?&8FcP@UX4~x6^e)3B4BF|m#_tL_9EuoD{@#|?Rw9s4ONA*a0 zL7;34{;U)fpQO5&TXlnl-XIsOA#pT=rDDtI;OXaw2LmHxfz>QDgTXNv-J7rx_95)HZ=q#{n0HQ0dbgLxfdGk!wW< zKa`Gh$2mpDr2c5mFt9oy5=m?`6%uAs7Jv_InGJ6VoEU^IFib4qN&(SkTiZ*;HPmEe z?1i?rw!o}8+baEbFk;;v76Uf65jGmDu@SOFR6W}!v*&>jH_od3cVm*Y>DY3Ia;H~* zuUC1$(DUm?X}R!0g5%|SLgwX!^1-D9&n0EYsN>$P4M`bTxc8iQS@&Mmy_ZCBu5ha{ zm6Vf;3`hX_A0!p!{ke0CKQF_l=dRShzN)JzzR}Oogla%=u0YFhEce`XlnQuYsKtHg zv@|Arp7W6wK&vM7HA+2=N=yHS7QbAR0(}S6jkV|9O>$ugIljDG8tCGubC9>(hiS~Z z3e{*Yh@j(du8^#n5euRfDp;XHD^x00_|~Vcu%Tjwk5sPk;1^gSUsZv)ObfJ5A~c}} zAoQ_dR8MurNiPV+p#CH@BNT~)lIk{tN(~!QNY(HMqn2`#%^9gsI?7ccmwD90fr3VL zUyH0BWO=m?=e(W`skN-LS`u^;1-x3`5&aMNyXiiScXl@7Xw&{)|mfa+Rfzp`GVhG1Z=C>iGkf zq2vbZq2xLvy+|%HgOcB8CM7R3zJxJI2WPkoiW?F8umC3)dQ?ha+_h!?M{&=zw?DO) zsve=YF*MHZE<;ZeP2rPD|H~(p{)bO0{TrWD`X!%K`e#0=^m9z=if9mi8ahgU$)+iJ z>l3GIr>cvrZ-(`srqxBD5ci%yPEBapIGZ}ezDa75{4)}~{N{6LU?B-Oh(@g5q-!lh zU7^o)r!xg(Lc_gW$)+tH2>tw?I=UbF4 z$qb`Q-zDC1PSn*?6};3YkYmFxFt0{7O?Ji&Q7{P zz&ie%ZRIxxEqxsZX9LW^d01Dm9nx<~#kNBNG@pMzr2n+`L%L(_2RGloz<$`Tj;m9~ z+hQv?VfzY5Zt zReEwi$Hm(k%S2e_uqf;mNk}9?p4<$u%toGjrv<|(@h%_B)FS8Z5+-s3uYA|d&T_kz z1R-sJH=X6ifV7zV$^MDNiv{`c%f9>ksi$tPUQo`<6}Ff1C#mT{E3mV zd|)pXk&+bna2=N2bL9RZ$Yj){UPk~B|l0@_E|bUVw0FooALU%AgJ zl-|lR0p9AJjRb1lXyK)I3EMn(s|;(h2Bb2qzi&gT4zjK{m*S^@n!L&pIU~@Q`AP)} z`^x#{@aKp4mju^c1Xo`rT)BnMh~PRik!Z_4ZDd*(`F8i?-`n#>e~uKJPjw zD&!MJXeeWaJd(`$q=l1hWo%#_zm==Rws8&G@PM`953u^{nIQo1F93kN9-E&5=kHzP z?DvT$X>{%fUUstlu$P_c!}@CD-6`nnwhLlS13T+v{n&{wg$3IyRg+a-#(K70y!L+( z?gMyjyehq|LU<(5#kkj=qxduM2hI8+-84RSTESh(J?7Q65L=_H2N-}3u%~9Fj;$dT zcH$fd*?)7dm?XWywk+^V_OHnLrWbfz{&7tf_JOo~X^d6qSQi?t;A&U}23C%+LF$**0!^pQ$q{BVIM zuYpmw)|&(}LtZizM1JDrRb13L?Q0@16uayABVI;^YO^I?0xXw#hPo5oYNJp-cGre3 z#xx+jn++LGo_Vl(jyBk{%x7EtS9_?XlO5jW_);7O8%2GZg5=02x4a1leKH(R!5>0# z7nSv311MLS~PMf9S?hG}cSS#||Gp9580a#^7D#`s7sL#N_yCsF<^RTDz)T z?i3f?eQ5W-NU7LFy~rmy6_}hE3&8qB`&PKgA1_x7PUZv8=V{m>5&ImTZT+26@eyia zocr%FKZD?ko!D$+M@WeENs>5d} zk7aPTscr8{Y(e(&Q+lP~%W(DyliVAHT0It;nGm)vgto-l1>;+ulN)droMb<0V9^Vu zV)N<%!%9GeBl%BxS8iTj6WJ>Ba^D;5_=2pafi8(Pu;UUb3l+`m2Rgqbh+sf9e;*C-42Jaa0*xI`xZ__ud*+g*^Lic8RbLI7`a}j9a|~ZDmu;6fjj6V6(E|((bEv@LbMdV5_knE`cV_K!Y4s4 zwd#T^ag!i|pD=B}Afq!INkCTN-Q-Ph`uDI_N43mCG)e@ocm#}iaGAH>jCdTtpVfP{ z6lcw4mVOSSdMR|6)dsR=7V{-3+~`X7hO@Bvv8H;&8gU*)G?N_n4LF+-5q(^XBkK(t z-H>;1zH<*84lD^pe@YJ_@*C|9=@4^W3B5mwwkzR4rjloYd=JgDt zKm+K1Z-KXYop>5+lx_=$FL=K+CQaNyT4px+p!?v0c0l%FLx!;mc$eqrR0?q)&T;cK`@PZ<)vBe9JdSaV}h$E4PGB(fw zH?GP~C^CBi+c3mg>~>YSn^vUNKCau(3qR<~!Vh`@ob;p&jV=L=E(x!RC@A95*aV2h zXVPq}mrb;z!a*QV9%0jKurc>JHV?GRkAJeyuEKM$TAY!mj-Mzxm-MUl3=y>ULFEva z%$rrGZqL^jBpiJg_z$@cF#GrkmzyzW)mi8KcvN-(49;)_;ay4EgV?W`)zj)reDXI> zi-a#l-uMRFyx@#rT(H+KOC33E#}XZ}+XXr}J;>SrTmg_(zt0f|bvf}`A5S2RM)<}! zurUpaSXjV1D_i(k+3Zw=Bp0vkp(8@-K+OSg+68}d+KBH4Qda`e z%O{EB!drW*QMhaG^j_(`WP5Jkd{_FY|8YG3tDj7|dw*QOvjBH44@@oUBF+UGPV+y! zhqU@M_dkZ??5yg832~s;;y~X)XowCp@#jJ>=y&LGYh28!sz=&5>$cl@)7sCQnqw1*YS8Dn<(4LSNx*q!?h;>y&2zCOjuZoBrs{<&!K|l*q z5_s#*#)60w0Xi$RJ}p6kA!4wuczBvtAXOA6{vDQ-smEs5BKqS+^k)t9rQ-UsGv59V zg78}J5E!r2RvZKbj)VDgKANUYgja$hY7k&A5wTein*`AzN)j(g|1RX$FGT=n0n1;v z;uN;ybs07w6!!jwFw*TvA%sWxzj@~2;HY3srVE`WgE}}W^DSX z5$}%i?~L%hReo~(MSK}JIWa!T_YmB5{|!Ap#AhQa+e)L7=;t;YbQ}wx+&IC_AX+q% h`9Q5g6(2z0V;^<^U$MM6G|HY5sdOD9%QGK;{C^v#WWxXe literal 0 HcmV?d00001 diff --git a/internal/test/lyric/do-test.tedit b/internal/test/lyric/do-test.tedit new file mode 100644 index 0000000000000000000000000000000000000000..870c26235129cde7be86ec0ed29ba2abc4f79d78 GIT binary patch literal 6091 zcmb7HZEqY&5l-L^*o6a~j`!D=PfB*Jojo`tglrUPW3Lkn+w0pMi$hUB`7MCx+;?OlXZ4kCDrYdrHN{7>v64@S>2DXwc@L;Xy*S}zf4U& z?u&su$qJ>5y2`XwNd=3rx-#pv*<{7lUcWy$oJH|;5vwA}`K8M3us@NFm2J{g>!nrM z%B{=bt>~yq*G*Nxq$*4i71WB`B;}F^=2a>g+iApC+waMyh+2X+DIS@JlwDN_R6{<|q zo8(HXPY+Hc#*uPfG!|f-952q{$dX^j>Uf1vh_+fK*&1+HbP`VB!K7(ZS+#8FsnV~K zb(7SYDMnb5Yiqd$;w|wRnWKNZ)A@Whk7gI~`9-{oRCtu5XY<*`xnTXslr&;J=7>}! z)|xbfaqN?*tI9N`GQb{wSs+W5tgv-bq?(&|6;z(ws$|Vf{JF{6R9hy)B3Y%xnyz(H zG^NA~CP0atNQztKy%|`ofiL(mB(jBrcQU6ROk{8y5tB=jT*AnggTuKZ6p6agw;NL} zKO$IKf%0I+1ilHuR8DFjiJp5RB}~&#&!-1*B=9X9{84>dB3+^~>`$4IRwNtIG<}m) z(WRsoAS7wb_gX9cTBnVGN+;cB%(yAEzzZSGAa|`5m+_J6y5l)Nkf5-acMy9}CMnPs4T=(7L;7k~i4(5P+1sK{uuY0ezExmaw)CK`vI<;p*KNnQ$)xJh5RtNc z#NWc}wI${p6vZ}cqT9Bn$%$)_3-t(vs|K!@TeZtbqRXUCucKDBO9u9Oihl-WQgeiP zMM4?1vW}j;wWg`1Y!zn3wh7nOMLO&sAZXjg6maVVlSA0mRyW)M7yRbFt0OCSXPC41ofYCDiB5W3q!W)ZWtNjCi zFuGWp4KmIqizM7ZjHOjm6zK7;Zmv<7m{;ucSm!s8cqJr1Vp@eI>qQ!FhSts{G9IKz zFEu9ztUCpKJDvP?y7>L#a1u}b4lWt{B;R&ku$OJha-HcVXUjT6b7b{pwYoBZ8wmt$ zO+dj7c}{(ZrZ469-^%SfT zGxWC-6mo)N4hlY6Oyf^R=q-3WoE}}A-94X94(2nSh0uR7l5P;$jaE*-RVA8u6wML3 zTB=K)T+n`8fnuy~bvtQRXdFo(stk20JCw3st-w52%sGaw)Nunc0MCIzZ)~RrP1@uY z_$A3?$s#B@EDlvuf`@3JuRJ8ajAg5_x{H?O&63vWK1k&2bEA*-@GbU^Bfuc{RX50P&N!xObRR19ygl$;LWx zU9n>D637&!$%;l}jLd*g<>4-kwHcydD);)mJs~3-?JLki&Zfa9sbr+r7hXH{+M;#s zhz^fj&0|}c_(4C+EFX~btgOtkN#TIH#FV)49fA#xhZ;cIb09_F`K2LUyMA5iLRV7# zX!k6O)MNcR3!E=nr#l=ayK(5+UNm6$1-&E3k{e%(A zkDmlPKHHpq(fK5fr}MLWmIiM(wTo+xt@n4-=c&Bj8MY_@eGsD!+~1sB>jM`Z?G9$A z=kNtSpi|cz*%mhh3=cfD*A!_~vShwyiQQ4?InpL zMjDMZxxU7nORL0kD3g{_%*zUuRgJJO4=r-u&7sk?W^Z6{{EW2->S18P9NM=j9MN znzc7F?9g7tBWa-cwCA|dBL&Sy2!n0i#fp7bM&!Z*yjzFW161> zXz0$k&~nfwGDMh2Kj_?bzTm02y@Jazr85`M5xIn%5K`*|mvk~5H;wKM6t|4_!r?{) zt{r}g3_zMIdJ zkyVt4WxmlB(K+V>CEw%&b>tHz-|~`g@S)?+n;!m?IvvY=5lLA79WM#H|IAB*L4k!! zzsgVaCrE-nU+1SU@P{j9_n`c1F9~}+@)7}xD}L!EZ+iF%KT#)G4u}ch9e@7i?Fa~5 zapWaouQykH+v|i+zw#2nkalt}k+>-NiI)VOfOGKhD_%!X4X)BV*_3uD6~qEFDHTcZ zCrCcvr!QC)kPoW@s-Lr$xZ3eBtO`sBk^abgD86`@2=wb_S{Q64c9j8?O`UJ@mTZ z&(P}xocF!tyL_N!QD$6T=b@yMlCXP-;(L(Fsvq)!I`YtoEA0MruOonSuNPhta1K8I Qm!F{Xe*ECyfBDb<02g@oSpWb4 literal 0 HcmV?d00001

0yV&9bv{)%mlcXE&fGBzW+?@?efIlEjabIe~FZA{9b8j4hR5fN&b6jQSV!s{1TrEdO@hGBn#zmt8%H zxNTTkA_GlihVy%W*0c>CCG7d8TlRdcTAJ^((h0Op@-ug~8McB7Ti_muoq@aITW}ZL z37cUPsb8elouhIhcvTu!TuVR~&h(IJ?x(&gkYII?-rq>oFp!Pg8cv%}*^;)fM(>3U zy6{NS9ZJzJadfb5hzRygBEgW)7rPW#*dS_!*EC60;Ur@zMEa?W0HFaE43a?77iDoC z_ZbRv3<|7(B2{*lBf?S00d27S$wDsTrjQHDGX#%%`vnKRt zo4g4dsmODRzYku|Luo6n<5JKxc$p0RT_OKfH*`-O2Qk6fi%Lb*DTKUT(2;!CeH|A*t}Sl;x=bZ(kjC_ZKK$#jmmkETb6 z{LY;XNhJ^r5p&(oyl_Kfh3nStxMgGWc*jtnbFl5`d~5IkBcd%=u!8}*G*F;y*?E|D zY%Mher;47Ul u!a6eP!K07&4M{I(?ra0!Ej(hq^D&kPW0X_D+UZ7Em@x4St?;$Exvv0Bod}}< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..934b8db0edbfc9f03086bf2af5ff8bc22386958d GIT binary patch literal 15342 zcmdTr3wWGWmH%U2nMWRN`U+{7CZ&b6lafB5Ev3yQnPjG!nLnMGG%28UnoOBA)1>B6 zsIpjUpoqhxjgE6c*yT~c&*f92E-77!imr=Rk&lO>vZBlS?W(MGQ3PF@J&*sNyh_tT z&~G90pL@=|_uO;OIrrRi@BjCRWNxbqy6bxO?(0k?dfhz({rd*`-Mf2w-F-a+z3mD2 zZlJqATBk*Pf9LnsHC0_vZI4ctN0ljSF z+O-?ktgEs&c%wn)He;X5H?G~VarK5O``Eo1xv)o)q;_c(L7pTPN~)ASnl7x2`JypT zLm=q$guNkOW%fumZG*XZTB5#4HeIyZ-QTm%lS=GQq;NWW`y^SCvUjCz4K3liSU?MB zhvb8@Gka&+6$pEpVQSt+pQPAyF34TZrb{mOZ1Al1gtkXKflzZWP#1`Knj>0c*i$Xt zoADl!q=H*euqToyw#vu5<PXY=;in|&Nb;8ORz-#}k9=`K>meKue>O>S zf*76cgQP@VR%MqVt99}?!`J3yy?RPbAf*`7*fgc8GAH)%;>lGaWzstt@-v*3S*S~l zS=c6zYA7Ej4_<@V#^KO}CS5uelr_9&0)2dj7fhgb>Ff}koJH|X!-n{I6Gmg1pA0KI zi$}F$W#{}+ZN9Q|;i$Gy*;z8Gl_)z)N3~LAXW6J$rtEZ&hGnf-*5=FFLRl-3wNhCt zlQlQ|DRQ#J_>V+?;7ig^&X+r|*;)RMW0cEU`NUy#FaPkn8wGgnTza;#mde`FNyG7Y zXp&j+C-d!wLFP^{2ozH)J}j`1z;T`o%k7!bup+l-M_V(k+2>Pvr-mmk7Fa>&V!ksP zu57~mbbp(bsac*erdB+8YJlls3f$wz;|t~_px-%5)6aFKl$4q>u}%#CI`U3EhWpRt z6LOI}&+u+2&u5iXYAeCnb?==shjp$W$gOsLl^P*uRy1h+fuX?#?<5Ke zqAL@c=%w=~jvHZYxE{OfED-E{12|96`S22GZG`2y*h1F?7H2b9*#gG&7bcDI%5$ap zMk#9)W-(6MzHbb@XoBXGuoSz-hRYG|eRFJh0T!VCl)wT`e{2?I$orEaLkW!0ei!cR z?MFxVwBI(`)t(-0y{q*oMB7wbsy)?%VHd}r;E%AF9>N~CP`_L0dB~R{ZN0VhdUoQKj|X1%_)`LMXO1baS5JUZA!@@T;Sfbsh*!2>M6$w7{4O*BCX-HF6#=U z!crsvtMRs@t+yTQMC{}}_?(b}&dOe3f6kC;+4)%D29%{pUJgc(FV@1k@|z7f$q4$) z8dDub@+GO&MRFzBLSBKkh~#V$n`n#e(`}(|o@k9(nRotxG4GW;6%T_d2CKBIPR}tm z>}sT)*(Sqtlc$d)Z^H(&ZJC0{3<)oVooF;w49exdlnWp|z)^AWJdNXX9i((ca%@?MrTj*m`*sL38bJ+womruxZ*5`70V7x)wqouTN zZ69Xuy>@m2WUupIJkH-Z27}N@oXx0RxX;kr#_{n;Emw@sXA{f^B)&2U!W~V1v1z=e zqR5DB9KNg*w2sBoj4$PI#Ib?+ZHCObNZz8|2(AK^6iH`xP8e?fnGUr_l7*dxlClME z1?1Y?H2@yqmCZ==3YT&v7V4m|NjQ`%gj3m={dBstvQ7)v2k!ANyQK+l|d^O>0sKnfw+Ma<;kN*O^I_b1(7qVT zbK#c~Yl*`XUi6;?Y`S%`LG?wH7)!E4|?z9->Dpg{;;AO>NLL;Zp0dSnG{I(I=d0gK(&g zNQ!vtIeVufdW(qQ$2di{GU=){*T2{Xp#R<;z9&p7H$L&iX{m4bCW)9 z(#2Sku@=T6q5@kw7_(8G{SCtGuT!1%NKtdYhYl;dkf%a5c?=&*E6=Au_(>Y*$myC^}af--sb@>WKyRO zhB7q-+KAg(Df~MqnmZs!rW@3nmS2D4H zx;va=Ik0x*k?al&6IGJd^}j@Py+uUV8%+EiW4~qWS;l@q6LNh|R01>C*GX#E2!lsR zc-KQDpi3~ggZq7wgm>M_#Ot}`0AqU?e2`mS%`MxQSWPo>Rnd%GWi+F_{{e?L!J-Tb z7f6x!J3v*q?PTmZP-}727i;iDcZ6!SpvSle#irjBD-n!Bo4jl4wJN;g+>Vr^TydvZ zg;)z?5ymbORY;Ub6x-V*itRNL#rAa)+V(Z!fhM;5sio~MCf-inZ95sehA}r|iwU#7 zNIb325l`z=#M7D)3xJvRb_RnCZeVa7jbM#%KaKlsp?;Ph5z+EI5iQ?h;%87-A#dGU z(vIchI=Y6@1H{#`U#G5S>K<@c@Jw2MmNstEqBp7LCfi63O9Lo!E-4#^h-edaZP~<4 zs>M2(jb%AwrHsvC%u1N~ZNkhyCi%@Tko@Lvll*4ZrTKOkUWGAebn^||ub2B(kxI=g z#APs$xt!}3aveuEvqE*IQ&eaA71f!Zqkg6za^1JN?gZCmNEXu&$zu9A$zm#^I`#L| zPyKJQx%vtdPf!PSggU5?QU|q!TP~oM%2x0!k#9O|HiFYyRq9NoY4I#Jj5G7P6 zjWKwY!FL%PqYlyo)ImBbmh2K$eo?hvRF!dq2SI>>YcN96zKK{2UO-sFxO)W=^@|M% zFmo|)Z3#8+ATt(RBsLVI%ff-+M~s~$$H;pG6t7_Rf>rku0vQS-_aK5< z4^D4$;4HRLFR{bWfV7U|4xF~eo7M9o?-BLYH2%0{cLxW1hxUO8T#3J z#1;gdq6Wcw8psA2Ct@q9gZ0mZS^q!-S&!2Q)-Mrj>oEp*fzZ~F770UMOOjjn(K@iM zx~m!Lr`|?D z@l%~*r#eXeF_Oq{G5Cq_BlazQ1XiW|k4*g(b(BBBu`o>i;haPLH!>*GJM!iz&lMQ0 zWL2lK^`tjN2&mG3iY5dvGx!0GAw9+5R$?w46dU@*hTS4~wFm}9$SXpdL{qhBDi{6* z-0&e_QP7u7Z|_g^^}9nY!C0UfUhGodO-C}fhhO5lD?56+m-kn?dlUTwz1{A;1F8Pb zeei~Qe>??mpxxIc6W#9qWa5CkvM<>)km{hu$h{|F*tgVX!)nJL+ap`8Zb?c^gNN~!zv%#qPKc7drx*q0d1Al zMSR|v&oku^5)8zA5pOUm=3q0}AGWnT$FA2Pg8`x`8rE8w zYpWl$q!$Bln&kmL0F1;HqFwBQ*4A2Y)Zfs;(peiLT1%ZD7>W)Y5{`{lZYes&9?>DL z1*-k+?2u`2i(8URWWa++`x;p=M?=yrWI+)D`-mtR#(rHk-AINB`eK#u*&XeDWDk2C z9Bv0|zE0j{zcN><2C{;JR6xOmg;IkuFPoO*NP#aE)~Vwq63y|s2|9H=Xz0{&udYGIow`mPw;Gh2bj3OL>pFGx>N<6F z8&z%7r4MA&HD{9kJXPxOvD|Z~s?_zu8CB|f%uuOo!!)5>mD%(MNGLkPfl?FK$J_f; z2i!f~dX#i`_PGc85*;huoxAm@8t+ZG_r?2w=#KZfBB05x3Th*8OxmJZ4rHJ7#{RP%2@!zFNEP2!SDqzyaR?WJ@?`B#ZrCv!w?)HtST`` zZ~>}b*sZZ(j`_8yzFoBX_3SsCQLN3|;8J&@fzEDlB{yX?H{~T6$zGEzfxnYSY6_Eu z(oBM*d*PKJ{-xzM5S>(Ko3;{cZ)MZ9lU4$K28J2Lc`i`fAIaTqPl0|!fpC!j+)K~< zz%sUb|6eQv_WH@rKXE3gM%xffQTO`8W^}#3=>7&C+uBVV2}h9b$qLK+$fv15-xJ-ot}m z{n*&p;5RsET6SmC=JsS~yay|Haht0LYhIy{Y6;DbjVEwF9CzzP;I>zS1BYHc*wQ)R zo_zBfViEWp8_vjsHK#zSIPNRcmXZ0{Y}z+<8NJ(xVE#U>6*KH~Dl8KfmI$t1^Ub_w z%-w%|Z>3G+*SexE<9{52Zk%S6s*t3XPw=ie~?UXvS*aq#GcoWbtNGYA5C<< zwCB|4Qc8RznW#{Y52ngSlE)!xl&N1eC!e?}juC{)CvJ+LsPPB3HrdS>>=YF~Dp0`X z&VFDsNwoQm>FGD#Kj7yAdCRnB{Di_A1VSx2$ZxV~69!uhvCEp^{RL{Mnx2;`n?;2c zHrRY`q_G7)s|d&!hzhtr4aj0E5BAhF!>M1%rc=`mXB?@QcQ2oI1BvE@8)mQ~p0KGe*xB9f zsb1;sUI~}v?(P-U?(TuTyAr*9?w;Mbo6C4N^Z*U0UnI+`2eU&CJbYc{qmL_~XbEXy z)F$R9mimadQPXpkdY=zoP+()YqBCyjqG9+pfODDJK!or1Ebu`{EXY)Abldpdo(|Spl2gJ{qzjbb1OZY=ozFZ-V7^`W{2_!J8vG?yD1~( z;a*Iq+!<^P&5Xme8BVh@Y_;!6dfbPU)ziE|sW9$VAf2OSY&gO!-mSn_KzLItzjnt* z5c~?3QY!wD16Y1JBiU-awRFicvqn^XovL_DhTjhOT_r<;!TYTI9G{>uF_gcPk@A6a z9i|J-m$~*=10ob)>EnmDRYt`P!OecBq>8JmY$kt%jZ!gUd>o)4;cX@Dgb`LfFc{nU!4~QVZ0$ ziqYz6b?^ROTJ7~2sWj2``or+A^DxuF{AQ%a>qn*1E$sPuFc}n0i2|`F!v~fXHbcH* z8dF-EksP^y4mjiFfzyBz-et4i>FIB=OHC|bgkrwIy ooGN8bSyI-NEtQvY+0P}#0j|dOH;=-*JlR{MyJ1B6@v*W01KpL~lK=n! literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-MISC-SITUATIONS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-MISC-SITUATIONS.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6479481a5f3a7c010483d90eae6e48e69be9c139 GIT binary patch literal 6683 zcmc&2YiwK9`QCHwYv<9_aYJcBlis9{6gRgtAx%qw64!BRC$?|uN7|HX#!VcY{YaDoZoMJy0GRXh=vKkV!)fkR`Th%G7CpS~gYF*rp*Nrm-Tlmk?y%caH5k zF^>%*Ey}&$hUQhm7bYQ&nP3QDP=m9o*IfPBfwYg zb7?{M{T`>QZ}-iu<)NaHp{aOmCO)i$)A8xy*vS^9^(MtRIW?*SvVT929i8p%oj2~? zUEbpi`M9(%T(hrpZ+mB3$L{jwCl^FpN)Uu0A&a0)5Nv`Z80RuJN7x+-t36(yTMan< zZig{vWUSze8VR|BMy9$=nMqBmdi?IVj_yoM3!)$x-^o~eA^}&}s|AdCaaOD}9?7ip z2Go9V&3VWz5Nl2fN*9ex?LPG;wN3R81XaH`rwj5*D zy_R^rPkc2gN^kU$BZ0bVQ63)(C+g7f3yW=lvsps}c~(91>?r3R%ialY9?y-mgg9q4yH2jyzxT3mCIK_5_mrc27=Zui z=B&0^jMl-ML>sbNgBaZeZxU6qnj%Iw!W$%k&6~NTs=37MsC}`sde4R;A?TAB-GORz z0=J<+G1^oxp$UDquW>LI^1-MXW3K17W2B{3U z1{fyC+Nw9dl2^a!s+%kc#A>m&kf_yST|V=9&XZ_IR_h?q{aLL|Ylrgy$3W{4wf*o< z#6%tcv)fq&;YeLBm0n*Yz2P&Z?YwNy@H1tGV)JF(Lnp^nT`2ba48{* zxn3j*Endrwv8M7i?)IDtbU2iZ=`$ToPk!qW(CjCion zw_wLX6y!N+1!ET4dQxkn57ona(DLQ`CkV9*^X>h`FJWADLO&DChToFO;YPwhDT z21wcv^7{LsMGS?5umP(3aK!1uu^+=ysYlaj1yaw@dIaYgZ_h> zPt7-uIQ4c~i{L1&L*Sv;A=n5jEXVx=K5vNGz5xuV7;yR`?vR?}$^W2RV5+x zsXw95d?Io$aPAVH^E^`}KgU$b-({-g1~$d~9tUr-DdsGjVt$cLF}peQAZNBQrs-L> z!1N3gZMv0Hos5#+W|Z_hPW^-}mtJAZrRUjl>0TBZDak>cgF9#gSS{Vm7wqQ?cCrQJ zUrZ+XJCjM?<*X;s(EN{b}m{~R>^%i_N$N|hs zmOj6r*!x?4h;xGYJ%H3no;SDBCZyW=l-(+L*EMv-dF<^dV0BzR$sBHYU#Uv3oc(!NJ$S1mcGRG)EzJNXey};#dIB2d}w60gi%G)1I{L8BnIEB!^&uqe`+G{0St!a zRU>0UOAucy!e2O3W8>t5a&{H{^#!rKD^Umk7v{Qb z2^$E&BDYzOO`I5xp%JC!4(5og+(E^oxPs{%GM+Hz352o16?8kpZgo{z^LfMWpwkzk zcAN%TcQ~Sj-E1!`VI$L36l3BbP_(}S;(iAdlK=aGLwj( zR2{-p9jH4P$t3V;YbCVycaQ3E@;BlK+6Aybu4nG)3?ns zujId#vfc$&Q54UPfXp%wDgQo?Ts}L3^jk%jQ8MBN~?hoq=I^pv!RSs-2|1;VgD(Qz5cEaxw((zB zR)!E1!!IZz^@23~&zKJF+p}NV3TD~@(Cqj$m(!PPD5zbbTk2^em{GSN)S{PV1uu1y za}(5Ls$6S|d{aP!z%+opU<&m}+u%~Qxio)2{L<5{<{a8cgCg+Dj`xRyo=Bjt z4R>GV}S&us$jD|K-nbUjMJ z9TX}vmrUFxE|j|@XF){&N*`c>`LAHlspaM6Pw=&joOc$4qMt&F^n=%h^1wsfA+4v1 zm2NRpMGztKMUt>|nE$XKNKkrcKSqo86`e45+B0iX?}&B0rM%aM8Y#*_LpioU}Wz5LM{2rpgGxGQle0I z{N71WiFX4Ng;pfh))pn%5=#y%$z82VGCgr3J~geRMhc}ZmV^~(RVO#oY|NL@ddN`| zbbGC|B8RmVup0|ldjZ>9z&Z-pK3Xvga!u!rc`L1_qjZdpQ=LxGBuydz(a+#_dG)dRdy=cvuXZDI`1Abwvc+54 z!;B{%VTiXw9uRMUR?r=o5$-{Ei0!oGasm@serF$aQ*2mr1);Zr?I9nqwG>d{LAry% zQ|$c^d!NqnzJYW90tdvDKk(#_E2zuHyeyPiEix7MY=d)I@H*K% z^WR_WY%;2Nn)^Nmg`4+y#{k2=hx7u1#e%eyT2WtY1y+ZzXhkivLi}^y3h`pj3h`$- zE5z@YSRp=^ztUHgEciA%{FQAI=ebQc;BjPGq2;r}8uDlnU$;BR62goL!IOmeAu}LH z%pPZdKhF%|JuHX$#!;XpUI^bZGKbiXu8G;g8M^Z@3!}@(h$n7=S8OlPtW{Ony9r3q bveFRTaoIzI2y7gXRaa^I<1i?^yuAD$;Q(_4 zKUzs39LF84_UU~0-gC}(?z#8fd*9oBBV$u#*k8H3qq8m9+U4K9r>ApIkAKJRE`Rs# zJzXuW{vBBFf20zkp-0yRE7up^SCk!_(9+V?+SJp!-5=l6+P%GL|5AU^N`J7kt1XFO z#R@Ezm6w*5mn<*Lt`5e+;_Y*7?k!)wyu5ftVfMAB2hH5whGDcAHVL<3=PDi(48b<1=K38=^ zq%vLuk<@^B*vv_Nz0X?{3DjfPf@?#Da*cW+?`EoR#=U`+fx3opyrv$B8iV16P|SFG zaDA^~w!dDhHvYFS&&>FJ4zs`QaN;$D`Mp`aX5!p%1o24!`X?jb zHH`kmkw~pFy@+0#z423WgRL%fX&81}%dfesqmET>+Huy-q)IxH&SXY*22+sT#i1aH zqywE{a-?c0dgIy_1PNc#Inm%G@}Opa;xI-?e^V0Wo^+J1QEuY*jK?$;B#x3aiF+&+ z$;@O{(v@^4y-80xJrn9?-K1{*P3rERR9Bo`JjKyJmyX`Mv*qg09Z7|m`V9`-(Cm#@ z5#pFk7{jR=80YCUtA|DeN$@)yQPvzgV!|B!Dl_5p`FP?y^RjU?kybGy+`wc7j(jG}#jm& z7l$>^oQWfA71&UKcs3L$tI&o*#B-ofS;aOKBlbbDvdU~ILp&GClvQp+IpTRxuB_EI ztVZmI)yk@{p#t#&s8Ck54b_MjLbbALZKy@O2x^rTu_1zZF<@*_8={B{AgZiJ8yXQW zg+^stAIE^?CrvN>P@#ATZycOpbZg_HhU?0= z2*Ltb2#a7bEQMuI3M*h0tbr<62Vtm(IBbHg@E~l51SFvodf;I=2#4Wu_$u_lQ*Z)O z@D2Dg_$K^0oPn3%+wdy94u1pRgYUyd_&az9-h~g~$MBQ?&&_~A9!}(c@lV^xRNVaD zyVEy+7v^nzJ;bQmMuzrd-A>%aGZH?mNX`_2`yQ4s$N2v`3(_f19}7@9sl>p=0$b7L z0l?3N5z~#4af+sd z_vtk69^^%q!);UHHs?&*?Ou#ozB10EU8A0j;7$4L#w&@jo&Utmbtk5Q%!b--%*0T` zXISDH1NRhcq(MhG$(1kd3Uws45>5IHFg2%u>_j>p`;dnQ54rG*$;dMwj?mT*Bcn$l zNfV!J%$BR8=NsGr$2x)Mn>0?J+9Y_fM7R0a*(sYL*`K6ir&WO5QYz&H&m=>4Nr5|a zKstkortbU~-9-7U^}8hUcq08QLMG!6BmIfowp>FUz-KNqIQEc5k4I{M>W};87F0r{ zs)in@0_%d2s&FV8sHnl3$l6$edRTkZKAofX;cZ0*S3qAh9hKNNfcHiEXh!Vp}AT*cJ*Twgm!-&5uw; zh-@As;+o5dsCofv@RH@;s+E*WkWO?icENMp-pQ00k+K?zmqD1v5=7KAT>XMcUsogy2fx# zj9nc;b!SOkV@!Lg`JfJy*stqI>_O$3u~57^5Zhc=0pURUjR!T>>lzYux|YOh&2KVp z!9X*D_4VP+R5?Su<%-CrPRNT7YV=|;XVfp(Ql(RGK;ijcY;zzn;a}(|iOcN7^AEb7 zO0P@l9O`+*Wni>No)a9Gr=R2U^m1IDI`O+!M47lO5HU-9<+Eq+6;| zmX1-WMhqShv0Ox+m``JK*EKeGU1D?B+dR4v9RA8;bm011cIWyY2kiQ`D7~yHude4s z3`*sIl%5iUCz;=ML@NJKDi4d7{ZiQ_qDjoRiOQG7u8c!;l}LySImE0VU~JiUh8jcB z&4Cy$>fsPZk+n!SkeH7HIeqdZbAE^YI)~Y>b0zzAma$*wUF_HK8&+}rnpGSZr1V`W z9b*H>*Vw>uPz)lXvR+h{NNF*b)W=*>BT{-#N|&W{R!Xl(sh?e|W9(Wz#;#RdR5oy? zRD_3JRq?o~FNwh%F>tei`4cuUf5Zmn@3D%xg;mV;qOwp_Zf6zaQ&urPVHM+NtYVyJ z72~f(eqdI&**GF{?=-M@Uy$@5KSpf}^s`}kH1UcWqat1F`R62(* zI5Q)(;_!m-mzrG=NLN23*!j^0f4I&2pHli)DgBT&y_Z57xA35otCy|rIJ?j&kP&)APmOa z#$kJ#I9_jq2-+b((@?VN%@;#2Tez=^_ytGm{;`Oc(2ehAX{(RI+9L7eKFNOE$Hl=B z5wt&KZ$q~4X1^J z__{p;@jy6)hzVT@B3yz@t~erf4-Kb_4jXyguL(=MOaqrs+~x@i7`WLe*V7|51nXlHbrB&ZP(S{Bq-CH3iaj%dNZ9MX5H{Ri6~W~ubg*NeZHR7?jCDL*#MyhXavZhJx`>;D)nUxF#No2E#EOBsE-eH#9&z#M#TK*89kXZ!8|qUyZ|Wuw#7?&Ge(J z?>Wl)o;WJ$YQ0rfI7JFrLQmccc#4!Y>d8sg-bdKlTQ<36A-A|cMNfz65b7SDq~ks# zIvuG2r*6XTn)P^`MX^CdlxMB`*2#uhZ0P!7Y9IrX{s+1h30$uY8uz#E{P;v`()sb9 z;7=${dOB@Qs`s|HkGz<4G`-q(Zs&XLBhMwBP3Mm!Z+|s$E^&TMa9vHUyrcWvp>i0i z_ZoiqT#d}BK1VQG#Q%$N5ZsHPo*q1dVXi9S|E1k$KB%g~ z2}YTE0tdxSD}rky_Cq-{AE$`8V)dkCyOwgYvjT%=#+seiFuva@HghyKoI7Yiv{?&M z110(ay;|R|SLyq7xn8MP=zDdUUam`Zi7wVfdYQgQ7wUjss+Z^jeYak$@6wC(oqD0Z zLod*`Yrmea=jq$@T>T~O)3@q5`W8J~&(bsX44tp@bgrJRr|E2Da|S2%#CZ?*#PI>n z_0$QaJ-S1;(@amw+B-PO!tuCRtW6DM8aUIO8R*%8cbx-E1Q%Y{a2sY58+g8}e;?CQ zKTY2R>f(6ii{nsFB355vVujl_P9r+n zo2`?4nlbTt7Y3)hC^xjdJE{RU__0z&Q0`0<`%CKxx-$Nr{M|ZUew)h1B>%>Luz%xa z%#`*VYi^;%rOQbko<7!0VgP;Muii!eCH`Xn{eD_ejjv3opz>j~<{odko?xBcXI@`p LoFx69Uc2^xHcL1B literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/8-1-PARSE-BODY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/8-1-PARSE-BODY.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..2eb5cc9e7f704cf9cc482f0d0283c2d7898f6692 GIT binary patch literal 1118 zcmah|-%ry}6u#{kFb1;_kOUMOh|yGw83H1jn9|+BpzDR(JAr6I$QW$NV9Pd42$2vT z^rZ#|k+d3Kd@wQb!QhLCfd^mxWB3p7+=4(b#x_mQ&+pvxopZ~`KdBqCo?FOgvZ;cc zTPo$3O7dK;AQy8>g=9*e1G~JU6N+C9Yx-!{!*Gpt!ILbcW=g49nJuM?vop(gN;?HlOn8MxQmRTI@L;{@%$Irj&8`vulI{F;g9b*0dpv#OhNNjxIQMs9z0(lUi6EB#|k!vt79k=lI4C^F6&kBJ3@q zuRlh_iH4SX!OyM#`qC{YPrA-)WALx-j~Egcd`6nNIrZYK$O(y!g-tVkpQ+C6r% zJ`&=>TAIK6^9VJpSA~T1-hm17QF-*W`4gdX`lUG{3IM*D{?atj$N|A!jZiH@hneKn za$3qrNc1~z?Q4oo%t(xrpbl$h#K2S?jDf`*vJ|lb*sWJ|jp@TG#VkRA9o?h1(wedu zj*G(I5sWBq&=+t6zB*tuq+m)3RY`)4C79w1LPD*gnNzA~w-gtsmBN=M6!0PBR`9V@ zagIL&P-T?RxW>5pi5Jxqlw$M3*j<79T<|rX_oQnuF0Yas%ySe2n?r1P-feme-B&$} zKQUq!djv^!=cDEOQ$L9*nN)QWj{`LjG*-dkKSJb{^GKEN#@V`Yg$HdwA-`9YYp-C_ zDouWPW5sO?a?=OLZfB`tN$yzHI^?+-xL31sX7S`oaNFvQr_PoLwE}$ARNlJVDvUdJ zO(d68i={$labE5W--RGo7H`9H4(4W;1&*h@vkrt(wQK7C*rkN^>e-gPS~zbz|*T%2FX6*7xLajCqpR2F87i$bZmv^bp+W&sy2$VrWUG$zRtoo{ye z^*x^H#Z0=KnGuYoOlc8xD-8(nAaFGx)O&+1}5fUaYVqG`GQG@D+I1*Q=s7eVMwJMhBg<8avPBqJH=oZSw z1+kEMKU2VR=1YVl#JXmBM^dV6#FMJE!L4vX>#7-wtKuY-CXG_Ud#fzS&RM2sQ0x(n zF-q>-^j#!`@4#Jrn|(0OZJj6ShvWR&$k7JQoqO;uA&nP3VJ^G%y$br@m5Gnl9YQME zRdt-_LZIC{a<&Px@%0iCB;-+Uy4fzPO33xs2t9=ekYHrM5sx=Z`MLbu++05Ihh+2s z=jJ(707V=gKVS&U2=6C&YGHtoFYpCdp|0Tey9wE6fO{qD{9aB`H)=(BaaYxySF$TF zr)T_YHF_VGg!Irdm=n|xQ=uX1O6MONKlqYSc(+FpIK1%=P+|ZqNkJ z{XfD;Mp?iWVm?;@=J!C9YFbhglPO~|Wkg*;NC-wHbxO2xJ<4E^8+xC;4`aP{^+vf$pJk%!z1qB7$}V`5jlF zr&E$L2{Gh1dqFB2Ne#`PSPP0B){J5soS}p?K}AW^q$z|p*-;dqIRT$I;cJd{iM6~3 z838*(H#9iGan?A>4h^u#LCE6%0k7L`G+KYb7p7jtE-GmL!P-!ySu2Vu$4WSYw?Xo+ zZIM46u?6|zxC)aaDI&Dkfc9h8$XBd=4txh|KB~|J9t~?f!P;6_+c5~@4_IcXoGF!s zayBFMAQH07V+JC}m!;#vY#Ki1GeYjX^BqQP`2_ClS8Kz?t@6Ih93C+DV^#hD5ZXK7 zwl;WEl1q9Aq2j$BT)Mi!g<%FQ;gk0^V28Vs&yNJV0zkRjY*-X|pic8X*jrmS@|IW!3du5E?@Z62`qp|H#VhtQ>{TFPQ75~3 zZ??Vvh@DLy;!5_OfT;Etf**g_B{$6asy-Ps0Aj2U79jTl<$2V;cG6it8vuw01cjv7cuF^@B7U2duRF}UeQgc`+KcM(``e)*KPH> zaMy3cj^At7T(~QBc%WN0IV@p)BfFd%Wq<9|+HSS$)*<(L?M}V=Y7Q>sAa1oAO_+PU zv@{2EOZf-6{KLiUXc05>+U~!a7V`7++0m=BQzhdA0BYbeT1EiKfEW-U{O*JjZ(KYFVDimy zO7YIWQ~Ce1zwwU#0HE)^rR%Da2H@EHa(jD#5?MrF3V_Q-ZL;rW8X2I*#mC^DrdzaN zMBz{g(}GECv}#C&t}#s=lGGELj=5e!HsOvfQ|kll1lwVpY^ut?72MLovDk1p5=%XKa#yufAZ>> zk!u%u9+GA8f#s~6c!EX^=AH1?P)P*&gR-?|<*~t}%uD$Sv8~GClLB+7X|VE2H24)J zk>$l&WrS^mm$H$#yjT#yxbC^N7Z4W;tMWkjR0Q|A+v&oYBRm6ltMawhVPpULokiNw ptRg;(6IF(t)@_10K{qm+1}8Q)SvVGz$=q9x#Ys2?K22X;{Q?-R@2&s< literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/CAR-CDRUFN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/CAR-CDRUFN.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..0d482f7b9bf6c4863f735706e37494fce921b83f GIT binary patch literal 1465 zcma)6&u<$=6rSBpoY-+JrwLWD8h2DB2du1%14zMvDx38<-ej}u?ylS9fRM4**ut@` zwOy%-5~YzSAT25;5bb~}^~$XW4x|Jb2@V{&a6tSM`47UIbrMS8P|4nz_vZclzBkiD z!yB@S<>pqaR<|A8>~>n+4z4sE+-`QAl8q~%$J?@Qke!?)uO$~#A@hZkl4BP;b{SjM zuG20TAI#zT6qZ^}t&US~FD%UA)I$1=dH5wmS;P zG}%&g%{$=sxUl!w9al6l56wv{1o5M1QCM`&bH__XM=X_{Zl!^q9FFZn4S!8Uc~;Ah z)#EkpsDbYPw8r1N5}V)x)zUS;%2I5wT<_P8KSb!t{>UU(J$gUV*CQaF^wh_CT=@i%gKLwPu8UtYa)hKKK zYxjCW*0qenFcNc;mQjfzE-RqXR?Gw+ph12Z2$)F7k|pOvgIEOv0F-?O0_LV^k#(L2 zi>U!cvPvYakQcMMv2G?P$8-Pnw)6xY6M{4-i~}K&1ThTV5cPtUFIWj-3>?Ab&l@%sl< zFhuT3DieMKA;2n^EGB*rv8Mh(N0v-7sEPWc@i`O~nk9FMu_>AWmr88<>Kz&zVZOgZ zsNuY!uV_sAj!AwyOnM4~8PHf7KWmT1vvm4h8c))An4SOXx#{h^zM`ik#RNMmm);7U5^lom(${WaD<%u`z%&hXFZU$ZELd zG+VY)e}J0}+-Nq$dad1QGoNG6ym&LT_oi5TF@4?#w@Zn;k>?7C# zfZCg$n@leg7!)#iZ2UKr9SyKM2W{6pgE2V^VYcC6!OhAA=sR&=S^T$h$gh>&f=cM? LbQ*oLczXIbZ9%$1 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/INIT.LISP b/internal/test/LANGUAGE/from-sun/language/xcompiled/INIT.LISP new file mode 100644 index 00000000..af473480 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/xcompiled/INIT.LISP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (* LOAD "{DSK}BOYER.LCOM") (* LOAD "{DSK}NATIVETRAN.LCOM") (* LOAD "{DSK}COMPILEBANG.LCOM") (KEYACTION 'CTRL '(CTRLDOWN . CTRLUP)) (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE)) (* DEFINEQ (FIXDISPLAY NIL (SETQ SCREENWIDTH 1600) (SETQ SCREENHEIGHT 600) (MOVD 'NILL 'UPDATESCREENDIMENSIONS) (\\STARTDISPLAY))) (* FIXDISPLAY) (* DEFINEQ (TAK (X Y Z) (IF (NOT (ILESSP Y X)) THEN Z ELSE (TAK (TAK (SUB1 X) Y Z) (TAK (SUB1 Y) Z X) (TAK (SUB1 Z) X Y) ) )) ) (* DEFINEQ (BTAK (X Y Z) (IF (NOT (ILESSP Y X)) THEN Z ELSE (BTAK (BTAK (SUB1 X) Y Z) (BTAK (SUB1 Y) Z X) (BTAK (SUB1 Z) X Y) ) )) ) (* DEFINEQ (FUN1 (X Y) (PLUS X Y (FUN2 X Y)))) (* DEFINEQ (FUN2 (X Y) (PLUS X Y))) (* COMPILE! (QUOTE FUN1)) (* COMPILE! (QUOTE FUN2)) (* COMPILE! (QUOTE BTAK)) (* NATIVE (QUOTE BTAK) NIL T) (* TIME (BTAK 18 12 6)) (* DEFINEQ (RESET-SCREEN (addr size) (PRINTOUT T "Before Reset" T) ((OPCODES 125 96 2) addr size) (PRINTOUT T "After Reset of " addr " for " size T) (for i from 1 to 5 do (PRINTOUT T "i=" i T)) ) ) (* cl:COMPILE (QUOTE TAK)) (* TIME (TAK 18 12 6)) (* NATIVE (QUOTE TAK) T T) (* TIME (TAK 18 12 6)) (* COMPILE! (QUOTE RESET-SCREEN)) (* NATIVE (QUOTE BTAK) T T) (* TIME (BTAK 18 12 6)) (* LOAD (QUOTE SET-SCREEN)) (* DEFINEQ (DORS NIL (RESET-SCREEN (fetch (BITMAP BITMAPBASE) of |ScreenBitMap|) 1049056))) (* DORS) (* NATIVE (QUOTE ONE-WAY-UNIFY1-LST) T T) (* SETUP) (DEFINEQ (RUN-TESTS NIL (FOR X IN (CL:DIRECTORY "*.DFASL") DO (IF (NOT (XCL::IGNORE-ERRORS (LOAD X))) THEN (CL:FORMAT *ERROR-OUTPUT* "FAILED TO LOAD: ~A~%" X))))) STOP \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..f0b9c388dd39d924e69f4cb3a876fb2e570a6938 GIT binary patch literal 2732 zcmcImTTC2P7(O%0ePO#?+Oo@SgaUSDuuEx6w-g+fS=h47Y-eUI#D`{urMvR8OJJ#& zrbL^lF`1;LP01YFCMJC_Mw6lsYPALv-;8}TF)_v`qpwZ+WMYc{nPCgkCf39fCjb2R z?|kQ+e`kdhPlRJaI5#(+fz*PKTguNb<%OBtg0PrdT9`@+GiVpig;h;HKPrXCx{n1b z^lhH0g;X-1nih=o(!%0&^7SsECn!ks3mFiCNBjD^gkWFj;K9&=-tLNsq{p0cPnvY3 zyJF+UD(B4+LZ-+%6Xk?>iHlg5O>e-Ebwi9qW3s47<8r`SvCJ}DjhN77%`&TdgnVvZ zgw)v-um#O65{?k-l35l>C}AV2D%KV5O|H_qXjVlPF^-FqMr6X5ZB}8`Im@hysme%1 z2}`jUxv^Sxfe_cpYA?^Qe4V~C#@)_xUEhrHr|SLHT*(<5;Aas>p7yM(p3AD|ZAZP% za`3f^koC1ze8GQaO8fnef@{Nf{P&;me`RiYQQK5lD!yXi)9sPDgI#Jal-6?T+x99@ zy|)s(sCvF5WF`Hs>KWrX1hcZ%aLUitP{uQ-mtycBS{%H46Yy9Y0`@PT+r{v(O10&<^{c4O-zD z5TFH`p$QtH0sP>Dde{qlU^mo3E!03YcwrZKpaLqv4OLJMWl#zwPz*)j0)Dn)aQpti zz~i^)kN;ykaH%K!xWDUZFX7$RRkJY=R+Zr>yP4vsqzuPoO&p4%MH$fpd=)L{%kU|| zrx>q)bs#Jm;ZaeOjf95RH*DYk5`9uP z>h^BrEi{)#hSY>I9Djp0PSA!y+SE&%+i6P^6*@4}6=CJ$nmVE|t%Wu*u?NR`iNg4` z=`N+MXyso*nu-{K4nxg$EWg`vme_*(llm}}yGz@cxMYWL?>fHM9FcZH`t1<%mmNax z+dlG}BYv{EB;O-8cVt`|ODOgluq3(dxISmFPbO4DX2wq(sy;$v5u=mYK5zoBI^rE# zzf9{Fsc(kvOHiLi+ec}GOgs9iFGzi@)aR!@w#BZHWrohh)e$u$MRlaW7!6IxnmTd5 ze^^f_v8Wy&V8>=a$7_VYlxiH$Ow<_dX2xT^tioZ-4209EsaauWDLa+V!%`dWy9?NVoQj2+^by;c^W|H`cFfC-V&W}5@Ew^JBFI(5F zE9@pVhc#I;WO2ulk3|hxlVUn`V;F6Bw&y7AWVwed^N<6|KE8q)5u78p4OTKc{aAc_ zknYDC+!uC#8rZ7NeQa0fKD5juJE|8B{S(yZZaVcl9<9IEsb7opVe7j=$Rk&bIBu6^ zc87*!ya%%LNn(F#F}Fiyfx~5elhtm_B0sMZ_X{{K@2yB)9F~^phveML(@948&MAc9 zygh{&^UmqF%o3axiI_n+p0*LfO5SxiVJC>(+V+0kGCSjtN-m~^>0GumFD#^{Q!|-t zN?4XyyQIAq8~fQ+QkG7&abJ%93nY&47dG(kAuPNJ9c+48CO3ioNyY)-8{3q9bg<~3 L)ROm4Y;61u6IBU> literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/TEST-RESULTS b/internal/test/LANGUAGE/from-sun/language/xcompiled/TEST-RESULTS new file mode 100644 index 00000000..e69de29b diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard b/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard new file mode 100644 index 00000000..8ce1a31f --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard @@ -0,0 +1 @@ +#.(PATHNAME "{DSK}7-1-1-BOUNDP.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-1-FBOUNDP.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-1-FUNCTION.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-1-QUOTE.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-1-SPECIAL-FORM-P.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-1-SYMBOL-FUNCTION.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-1-SYMBOL-VALUE.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-2-FMAKUNBOUND.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-2-MAKUNBOUND.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-2-PSETQ.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-1-2-SET.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-10-CATCH.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-10-THROW.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-10-UNWIND-PROTECT.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-DEFINE-MODIFY-MACRO.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-DEFINE-SETF-METHOD.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-DEFSETF.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-GET-SETF-METHOD.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-PSETF.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-ROTATEF.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-SETF.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-2-SHIFTF.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-3-APPLY.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-3-CALL-ARGUMENTS-LIMIT.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-3-FUNCALL.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-4-PROG1.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-4-PROG2.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-4-PROGN.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-5-FLET.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-5-LET.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-5-LETSTAR.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-5-MACROLET.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-5-PROGV.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-6-CASE.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-6-COND.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-6-IF.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-6-TYPECASE.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-6-UNLESS.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-6-WHEN.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-7-RETURN-FROM.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-7-RETURN.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-1-LOOP.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-2-DO.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-2-DOSTAR.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-3-DOLIST.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-3-DOTIMES.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPC.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPCAN.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPCAR.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPCON.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPL.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPLIST.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-4-MAPPER.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-5-GO.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-5-PROG.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-5-PROGSTAR.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-8-5-TAGBODY.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-2-MVR-CATCH.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-2-MVR-EVALUATION-APPLICATION.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-2-MVR-IMPLICIT-PROGN-1.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-2-MVR-MISC-SITUATIONS.DFASL;0") Failed to load #.(PATHNAME "{DSK}7-9-MULTIPLE-VALUES.DFASL;0") Failed to load \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/sw/do-test b/internal/test/LANGUAGE/from-sun/sw/do-test new file mode 100644 index 00000000..9e6da885 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/sw/do-test @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "10-Mar-88 10:02:26" {eris}sun>test>do-test.\;3 22922 |changes| |to:| (functions xcl-user::do-all-tests) (vars do-testcoms) (variables xcl-user::*test-mode* xcl-user::*test-batch-results* xcl-user::*test-file-pattern*) |previous| |date:| " 2-Mar-88 15:47:17" {eris}sun>test>do-test.\;1) ; Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint do-testcoms) (rpaqq do-testcoms ((variables xcl-user::*any-errors* xcl-user::*test-cleanup-forms* xcl-user::*test-compile* xcl-user::*test-mode* xcl-user::*test-batch-results* xcl-user::*test-file-pattern* xcl-user::*test-file-name*) (p (defpackage "XCL-TEST" (:use "LISP" "XCL") (:import xcl-user::do-test-file xcl-user::do-all-tests xcl-user::do-test xcl-user::do-test-group xcl-user::cl-readfile xcl-user::expect-errors xcl-user::test-defun xcl-user::test-defmacro xcl-user::test-setq xcl-user::*test-mode* xcl-user::*test-compile* xcl-user::*test-batch-results* xcl-user::*test-file-pattern* xcl-user::*test-file-name*))) (functions xcl-user::do-test xcl-user::do-test-group xcl-user::test-defmacro xcl-user::test-defun xcl-user::test-setq xcl-user::without-batch-mode-errors xcl-user::expect-errors xcl-user::do-all-tests xcl-user::current-file-name xcl-user::cl-readfile xcl-user::do-test-file xcl-user::do-test-list) (prop (makefile-environment filetype) do-test))) (cl:defvar xcl-user::*any-errors* nil) (cl:defvar xcl-user::*test-cleanup-forms* nil) (cl:defvar xcl-user::*test-compile* nil) (cl:defvar xcl-user::*test-mode* :interactive) (cl:defvar xcl-user::*test-batch-results* "{dsk}test-results" ) (cl:defvar xcl-user::*test-file-pattern* '("{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" ) ) (cl:defvar xcl-user::*test-file-name* "unknown" ) (defpackage "XCL-TEST" (:use "LISP" "XCL") (:import xcl-user::do-test-file xcl-user::do-all-tests xcl-user::do-test xcl-user::do-test-group xcl-user::cl-readfile xcl-user::expect-errors xcl-user::test-defun xcl-user::test-defmacro xcl-user::test-setq xcl-user::*test-mode* xcl-user::*test-compile* xcl-user::*test-batch-results* xcl-user::*test-file-pattern* xcl-user::*test-file-name*)) (defmacro xcl-user::do-test (name-and-options &body body) (let ((name nil) (options nil)) (cond ((cl:consp name-and-options) (cl:setq name (car name-and-options)) (cl:setq options (cdr name-and-options))) (t (cl:setq name name-and-options))) (cl:if (or (eq xcl-user::*test-mode* :interactive) (eq xcl-user::*test-mode* :batch-verbose)) (cl:format *error-output* "Testing... ~S~%" name)) `(not (cl:when (null (xcl-user::without-batch-mode-errors ,@body)) (cl:format *error-output* "Test \"~A\" failed in file \"~A\"~%" ',name (xcl-user::current-file-name)) (setq xcl-user::*any-errors* t))))) (defmacro xcl-user::do-test-group (name-and-options &body body) (let ((name nil) (options nil)) (cond ((cl:consp name-and-options) (cl:setq name (car name-and-options)) (cl:setq options (cdr name-and-options))) (t (cl:setq name name-and-options))) (* |;;| "Hack: find :BEFORE and :AFTER clauses in the body and move them out") (cl:loop (cl:if (and (cl:symbolp (car body)) (or (eq (car body) :before) (eq (car body) :after))) (progn (setq options (append options (list (car body) (cadr body)))) (setq body (cddr body))) (return nil))) `(let ((xcl-user::*test-cleanup-forms* nil)) (cl:block ,name ,(cl:if (or (eq xcl-user::*test-mode* :interactive) (eq xcl-user::*test-mode* :batch-verbose)) (cl:format *error-output* "Testing... ~S~%" name)) ,(let ((before (ignore-errors (cl:getf options :before)))) (cl:if before `(cl:when (null (xcl-user::without-batch-mode-errors ,before t)) (cl:format *error-output* ":BEFORE forms for test \"~A\" in file ~S failed." ',name (xcl-user::current-file-name)) (setq xcl-user::*any-errors* t) (cl:return-from ,name)))) ,@(|for| b |in| body |join| (|if| (and (cl:consp b) (eq (car b) 'xcl-user::do-test)) |then| (list b) |else| (cl:format *error-output* "Non DO-TEST form in ~S in ~S~%~S~%" name (xcl-user::current-file-name) b))) ,(let ((after (ignore-errors (cl:getf options :after)))) (cl:if after `(cl:when (null (xcl-user::without-batch-mode-errors ,after t)) (cl:format *error-output* ":AFTER forms for test \"~A\" in file ~S failed." ',name (xcl-user::current-file-name)) (cl:setq xcl-user::*any-errors* t))))) (cl:eval (cons 'progn xcl-user::*test-cleanup-forms*)) nil))) (defmacro xcl-user::test-defmacro (name &rest stuff) `(progn (cl:if (cl:fboundp ',name) (cl:if (cl:macro-function ',name) (cl:push (list 'cl:setf (list 'cl:symbol-function (list 'cl:macro-function '',name)) (list 'quote (cl:symbol-function (cl:macro-function ',name)))) xcl-user::*test-cleanup-forms*) (cl:error "Please don't redefine ~A in a test form" ',name)) (cl:push (list 'remprop '',name ''macro-fn) xcl-user::*test-cleanup-forms*)) (defmacro (\\\, name) ,@stuff ) )) (defmacro xcl-user::test-defun (name &rest stuff) `(progn (cl:if (cl:fboundp ',name) (cl:if (or (cl:macro-function ',name) (cl:special-form-p ',name)) (cl:error "Please don't redefine ~A in a test form" ',name) (cl:push (list 'cl:setf (list 'cl:symbol-function '',name) (list 'quote (cl:symbol-function ',name))) xcl-user::*test-cleanup-forms*)) (cl:push (list 'cl:fmakunbound '',name) xcl-user::*test-cleanup-forms*)) (cl:defun (\\\, name) ,@stuff ) )) (defmacro xcl-user::test-setq (&rest xcl-user::stuff) (let (xcl-user::unbindlist) (cl:do ((xcl-user::x xcl-user::stuff (cddr xcl-user::x))) ((null xcl-user::x)) (cl:push `(cl:if (boundp ',(car xcl-user::x)) (cl:push (list 'cl:setq ',(car xcl-user::x) (list 'quote (cl:symbol-value ',(car xcl-user::x)))) xcl-user::*test-cleanup-forms*) (cl:push (list 'cl:makunbound '',(car xcl-user::x)) xcl-user::*test-cleanup-forms*)) xcl-user::unbindlist)) `(progn ,@xcl-user::unbindlist (cl:setq ,@xcl-user::stuff)))) (defmacro xcl-user::without-batch-mode-errors (&body body) (cond ((eq xcl-user::*test-mode* :interactive ) `(progn ,@body)) (t `(ignore-errors ,@body)))) (defmacro xcl-user::expect-errors (error-types &rest forms) `(condition-case (progn ,@forms nil) (,error-types (condition) (cl:values t condition)))) (cl:defun xcl-user::do-all-tests (&key (xcl-user::results xcl-user::*test-batch-results*) (xcl-user::patterns (cl:if (cl:consp xcl-user::*test-file-pattern* ) xcl-user::*test-file-pattern* (list xcl-user::*test-file-pattern* ))) (xcl-user::sysout-type nil) (xcl-user::resume nil)) (let ((no-problems t) (*default-pathname-defaults* (pathname "{dsk}")) (*error-output* (cl:if (eq xcl-user::results t) *error-output* (open xcl-user::results :direction :output :if-exists (cl:if xcl-user::resume :append :new-version))))) (cl:unwind-protect (progn (cl:if (not xcl-user::resume) (progn (cl:format *error-output* ";;; Test results for sysout of ~A~%" makesysdate) (cl:if xcl-user::sysout-type (cl:format *error-output* ";;; Sysout type is ~A~%" xcl-user::sysout-type )) (cl:if xcl-user::*test-compile* (cl:format *error-output* ";;; Tests are being compiled~%" )) (cl:format *error-output* ";;; Tests run on ~A~%" (date)) (cl:format *error-output* ";;; Running tests from ~A~2%" xcl-user::patterns) (cl:setq xcl-user::*all-files-remaining* (for xcl-user::dp in xcl-user::patterns join (directory xcl-user::dp)))) (cl:format *error-output* ";;;Resuming after dying on file ~S~%" (cl:pop xcl-user::*all-files-remaining* ))) (|while| xcl-user::*all-files-remaining* |do| (cl:format *standard-output* "Testing ~s..." (car xcl-user::*all-files-remaining* )) (cl:setq no-problems (and (xcl-user::do-test-file (car xcl-user::*all-files-remaining* )) no-problems)) (cl:format *standard-output* "done~%") (cl:pop xcl-user::*all-files-remaining*)) (cl:format *error-output* "(END-OF-TESTS)")) (cl:unless (eq xcl-user::results t) (cl:close *error-output*))) no-problems)) (cl:defun xcl-user::current-file-name nil xcl-user::*test-file-name*) (cl:defun xcl-user::cl-readfile (test-file &optional (*readtable* cmlrdtbl) (endtoken "STOP")) (let ((xcl-user::true-name (cl:probe-file test-file))) (cl:if xcl-user::true-name (let (tem (*package* (cl:find-package 'xcl-user::xcl-test)) (*features* (cons :no-stack-overflow *features*))) (cl:setq xcl-user::*test-file-name* (cl:namestring xcl-user::true-name)) (cl:with-open-file (test-file test-file :direction :input) (until (or (null (ignore-errors (cl:setq tem (cl:read test-file)))) (and (cl:symbolp tem) (cl:string= tem endtoken))) collect tem))) (progn (cl:format *error-output* "~%Couldn't find file ~A~%" test-file) nil)))) (cl:defun xcl-user::do-test-file (filename) (let* ((*package* (cl:find-package 'xcl-user::xcl-test)) (xcl-user::*test-file-name* nil) (test-forms (xcl-user::cl-readfile filename cmlrdtbl)) (xcl-user::*any-errors* nil)) (xcl-user::do-test-list test-forms) (|if| xcl-user::*any-errors* |then| (cl:terpri *error-output*)) (not xcl-user::*any-errors*))) (cl:defun xcl-user::do-test-list (xcl-user::test-forms &optional xcl-user::options xcl-user::name) (let ((dfnflg nil)) (declare (cl:special dfnflg)) (|if| (null xcl-user::test-forms) |then| (cl:format *error-output* "~%(Trouble reading ~A)~%" (xcl-user::current-file-name)) (cl:setq xcl-user::*any-errors* t) |else| (|for| xcl-user::form |in| xcl-user::test-forms |do| (block 0) (cl:if (and (cl:consp xcl-user::form) (or (eq (car xcl-user::form) 'xcl-user::do-test) (eq (car xcl-user::form) 'xcl-user::do-test-group))) (cl:if xcl-user::*test-compile* (cl:block xcl-user::compiler-punt (let ((xcl-user::compiled-form (cl:if (eq xcl-user::*test-mode* :interactive) (cl:compile nil `(cl:lambda nil ,xcl-user::form)) (ignore-errors (cl:compile nil `(cl:lambda nil ,xcl-user::form))))) ) (cl:if (null (cl:compiled-function-p xcl-user::compiled-form) ) (let ((*print-level* 3) (*print-length* 3)) (cl:format *error-output* "Compilation of this form in file ~S failed:~% ~S~%" (xcl-user::current-file-name) xcl-user::form) (cl:return-from xcl-user::compiler-punt)) (cl:if (null (cl:if (eq xcl-user::*test-mode* :interactive) (progn (cl:funcall xcl-user::compiled-form ) t) (ignore-errors (progn (cl:funcall xcl-user::compiled-form ) t)))) (let ((*print-level* 3) (*print-length* 3)) (cl:format *error-output* "Compiled code failed for this form in file ~S :~%~S~%" (xcl-user::current-file-name) xcl-user::form)))))) (cl:eval xcl-user::form)) (cl:format *error-output* "Non DO-TEST form at top level in ~S~%~S~%" ( xcl-user::current-file-name ) xcl-user::form)))))) (putprops do-test filetype :compile-file) (putprops do-test copyright ("Xerox Corporation" 1986 1987 1988)) (declare\: dontcopy (filemap (nil))) stop \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/sw/do-test.dfasl b/internal/test/LANGUAGE/from-sun/sw/do-test.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..e0e3e2b9eb9382d384df1a5a9ae98103c7963aa7 GIT binary patch literal 11262 zcmcIqeQaCTb${=XBK2)jl4YB=9M-Ypm=0xGw&SnVHAPV(CGtInACjFfO_4}bwk)dp zh~uUaWXEy(!NOK-E4)d(HSM+*#o#I~vQ7Td)^!++uE_oal13GUV2CTrA z{m!|Mq9iMc)MkRDd+)jT-23i5zkBXE=iVu$SX z&5n=srQB)I-LC{#_Kl=^$5Q?7L}q+s zw7>W46Ykwj?nv)QU&g)r;DG~FJk->DsCi#wd7CdDmIJJiY2Sgy@{g`hYa6nPqMYF0 z3Po``RVtS$ibK)V{Iy(lTPPgx#{#}YpfzmxH6?#3=kUZ6KE2f!YxRcoXfol+=N!A; zW7%QvVCtpRAWiwShF~zOrXmWWXoDZu>dn`&ioZCQScqD313S%kk47L*dW=XK7XgL9fY!wo(ROkp?Fly z=WMU&%vA8EcmCu!8#@=K+5VNSLuJaILy#8>&rzfM{ zHX{~^dxXQHp|0AjGa^x}GEps{R!C~ZXl0VM*hz~o;SYLafp{{U;7&?VS1X&doT9!2 z)>fyUY^ZW9sM38A>MozF+5O}a42&vvMG+Pfy@RCiJ+M|m`~{I=PR?V2m~qVOHzE;3 z_mc3a;oE?Ot;I;{tz5i z?N)$3PMg4P?$1i<;P>-aET%9>0#v%3vp_ESoRubELi5TRkZqwz)QBZ8?@F@^#yyrx zQhebsZ~Qn@3d3-ryui>NGm=pzRY3l<1L)gio4~Osc8CcQCRH&iu*gYWHYt=NK7Y($ zQW=xtfyC3oA?ie}SS#w~+WbyFXCEIrHIzLwL^HjVzoKF3?Qske@`YuaujH?+&*yf% z(m#6Y)u(n1pB>9&hnjW`4vY@(8cU6i?dlyL%kCQN9Xc`Idm^=K?-5TUuhNP+_N|)Z z$yIagUp2>pRdXDi=V)5tTJ3IHJTF-uYOD`qLme#Iq>-NjE_EDMEtdXhHj^i(XRipE<$qU=fd*DF9Y)0c%h+r=4v%Kx@w{4+q|s&y#-sW6!bc#$B#!^ zjPQJgwO;I8gQKZB_407{P`Is&!f$I;#C~P@N5Gw=%agcS4q_fyvBt zNWC4>?wkwV?!w1CxEq;@T;SZ>-PQEron&*#FPHy2Tp1V53cpm3q!R?ny6|JBpuiHc zi8_lNhfuYLEg`Qo4`Fe-276Dx*x&0O7;-PQJ#CtzvDpC;$Xm8b% z;qX(G=?(_;gUDEPBe4S(K)K}T3dCBBc;FG?w)PPqU^HCIS@{fho_m%lWYjtR$yf{@ zB&}mIt%L&x#Ulv-&%I^Bx5b_Ag%i#{hRxw+1$j;Ik$h4=w;@I*B2?&P_d z`$e$m-R?!aviNrQ7DA2=uuWz%9sg6O&2`+@-ptJGMdR5a8n ztuCipWmKbLJ6wU9^Y)EuW>)3Ty6FQ|{u&Mm%B8T?m%tXSiG*MLOlBhJC(~1pzxDWY zVXBv3GwNrK8xFN+)10x17w0Ww6EDSN=BlwNc4&Lq}ME*bVG5{`&T__o@$1qMYA?{FWkp9 zfcPel-_Tn_|&cQ3dgh+MfHy`8~bySE|~ZUDv#4{ z5Bp@HOQeVv6PLG)1acarx*ae_*JDKeDY z7Xy_102-vk*9PBENs4)R1sz z=p$PYD(LJ*&JqqJe9ZZJGbdlIMi21xp_$paum-w(VN!=!O-v?Er)HYEfZx`xi<(KA z$bXqC6KzbDNz`9RwaII){!>2ZJ;W=;;fGOP-9UWp&IO(&M|6Z^H$}jS{ z#zRtGD_;WT@69Dp{=i%U?bloap3b`qXU~*xniKsRPgJ?^@JZFrJQ_r8p$T3GxEzQF zP~@T&;SF9?n(TMEzZ>L_mpvCv#DYn^v-z_*<(d|ra!VZMO3|e9$TxA)k+77XNE2vY zPa+eNN`IcTs7x9WHH(uX6CD=xS8O7?G5e4`%OgeV)?!1miL8`d<|rtbm6FF)%QOxR z6bfo`P(t}9SW+7H>Z&X$Wj(FXpI`%*A_l>B7ZH9}YMu9FLVAosC8S4{x2O}@jKRK=Bd<>tIpM&I-S@F{92cf&+#S}G~1b@R(~s=Z!NUG`WYLQy9ozLw8z zj}E4KM^o{waV|DRxQlf4Bjc}LKvA`XZhFm59A`64p!bQSYI_N^T1pAl?#6Kov|VawJ5P`g{A_8$wVy$Y3` znGN3RxO{Hrtb`o?caW2TUr8`Q#>7QHDl}UHx1Ca#)& zT%C%if!X^PQ$Txj#JA4WjVd1XM3Q!#km~)zW zj?z_A^ z5^T4>-dix=L92_igFF>KAJ4cz*XFpIOFD}-C z6z1`ogt*6I5%m_USZgT}Jpv`|{73jPjWF`)tdDgDj+4V--q#^pYTnPqk*|Q)Op&U@ z@n`@=8?}lAG+MSx!gdNBP-`BP&6}?ij~;+$5{Sj&rc=W=h;iQaRVGm^3$=Lz$6&L? zUlsN*iP8v5rt%;s6@1XBRW>e_ksYsmXWB~1hghha^<4zIq&l0_`l{wa6b_tuiD|zj zFJy!Ft?zId8LI7e5aLb=xN&Q1nl1+nLX;qZaYActA1c9y>dnau19$^TvGc(E>AU zYL3XW%RegHX4Blv4j&%PVrX!h`tD7S;blhuS<2%xIE2d4Qd&zftyc41pUOC%1}q?K zRrFw`{4n5$yyL^tt;TVn@Y<8SCeHk>Sre(d~eVqb>!EQv$UOncV+G<=6S2*ra|au^@uW5T9?bISv!#LtDZZGGJdgJ z(8kKD(Kfe8y)998j&6>Y9;N-2f!4EPg{nMlctV2k2%>%z>nZb?j{rQZ5Gy?MFFQQg zVeqW{k#MXv(Gtc509HrcX|aoS*h4+STVh?L60Lao!7dAJN9y@8BTC^$+*cE$7gzNF zdcx=o=r&sCw?rx>Y{%%ENb$xKG3?ziij{blf_*8UlTa+b3VXCgK2)ip1I!m|hbBdE zo_a z$2)9Z%Tj=jDQ1XDZGo91{ihq!Zu$P1X$2a=inYcm1~@x-xnAUGf-)z^Xb`#pzI;4((_hvH)SO<7$Ev zsH6clAe>n5b(;K+CtxcO#v5TT^oSi64O1lTK)-l-h5bMXw{F6!+7LpH#zJcW$N85i zBn0885ne0zvQOm&QV)@4p>B=oYD!}CJ>Pm?J$&?b=jC%5zUR5qsop(F9~NOl>t>z2 zzPYDQ>GL-^-+Ev9&+e`G|8sdi^V=CrG7};92$P!$Wx{5>6?pz<-196#beIsm1&A(P z#DyV&>2<*Lz3_cyDsxU(@97}k9F${BpVX`824?)!H>Myl1A#!BKuYb2phu%HRQWuuD-iZ*l`My-R>A4h8n&5Mia$HHorbMpYi-lp!tJ~T z*TD3U7b0hHAyR9p6;3I|H6@D0gave^d>_QG#kd+*hjytj<3KFog@ulLPm+DR46g5& zr9HCrI58^Up!(0riUwIxCQBt;Qr^RSYUcyFg}Y}jhsAQ-g}fm_GrQT0!yW4J4Vap| zLSSR%N8Ffi9&RnG4-V4zd{?+BnM8NCurJcm>dQ#J7nbGO*Fm-FbFISNES}gdcGBUX z!dO{9vF-81NOt^1yw$|>%YHHyCVV?&^nF)8x8tEWeJ@Ot?66zDeOwZ*-;mGkl`lej z#|B_=z%Cifz=olK-~1)+{H4U9iEVB-U*FQlU=!~%Uz7I3D(c4rQhE7HPfC~V1^nhc zf%4dbRNGC7uiW$ zkM@`7MCx+;?OlXZ4kCDrYdrHN{7>v64@S>2DXwc@L;Xy*S}zf4U& z?u&su$qJ>5y2`XwNd=3rx-#pv*<{7lUcWy$oJH|;5vwA}`K8M3us@NFm2J{g>!nrM z%B{=bt>~yq*G*Nxq$*4i71WB`B;}F^=2a>g+iApC+waMyh+2X+DIS@JlwDN_R6{<|q zo8(HXPY+Hc#*uPfG!|f-952q{$dX^j>Uf1vh_+fK*&1+HbP`VB!K7(ZS+#8FsnV~K zb(7SYDMnb5Yiqd$;w|wRnWKNZ)A@Whk7gI~`9-{oRCtu5XY<*`xnTXslr&;J=7>}! z)|xbfaqN?*tI9N`GQb{wSs+W5tgv-bq?(&|6;z(ws$|Vf{JF{6R9hy)B3Y%xnyz(H zG^NA~CP0atNQztKy%|`ofiL(mB(jBrcQU6ROk{8y5tB=jT*AnggTuKZ6p6agw;NL} zKO$IKf%0I+1ilHuR8DFjiJp5RB}~&#&!-1*B=9X9{84>dB3+^~>`$4IRwNtIG<}m) z(WRsoAS7wb_gX9cTBnVGN+;cB%(yAEzzZSGAa|`5m+_J6y5l)Nkf5-acMy9}CMnPs4T=(7L;7k~i4(5P+1sK{uuY0ezExmaw)CK`vI<;p*KNnQ$)xJh5RtNc z#NWc}wI${p6vZ}cqT9Bn$%$)_3-t(vs|K!@TeZtbqRXUCucKDBO9u9Oihl-WQgeiP zMM4?1vW}j;wWg`1Y!zn3wh7nOMLO&sAZXjg6maVVlSA0mRyW)M7yRbFt0OCSXPC41ofYCDiB5W3q!W)ZWtNjCi zFuGWp4KmIqizM7ZjHOjm6zK7;Zmv<7m{;ucSm!s8cqJr1Vp@eI>qQ!FhSts{G9IKz zFEu9ztUCpKJDvP?y7>L#a1u}b4lWt{B;R&ku$OJha-HcVXUjT6b7b{pwYoBZ8wmt$ zO+dj7c}{(ZrZ469-^%SfT zGxWC-6mo)N4hlY6Oyf^R=q-3WoE}}A-94X94(2nSh0uR7l5P;$jaE*-RVA8u6wML3 zTB=K)T+n`8fnuy~bvtQRXdFo(stk20JCw3st-w52%sGaw)Nunc0MCIzZ)~RrP1@uY z_$A3?$s#B@EDlvuf`@3JuRJ8ajAg5_x{H?O&63vWK1k&2bEA*-@GbU^Bfuc{RX50P&N!xObRR19ygl$;LWx zU9n>D637&!$%;l}jLd*g<>4-kwHcydD);)mJs~3-?JLki&Zfa9sbr+r7hXH{+M;#s zhz^fj&0|}c_(4C+EFX~btgOtkN#TIH#FV)49fA#xhZ;cIb09_F`K2LUyMA5iLRV7# zX!k6O)MNcR3!E=nr#l=ayK(5+UNm6$1-&E3k{e%(A zkDmlPKHHpq(fK5fr}MLWmIiM(wTo+xt@n4-=c&Bj8MY_@eGsD!+~1sB>jM`Z?G9$A z=kNtSpi|cz*%mhh3=cfD*A!_~vShwyiQQ4?InpL zMjDMZxxU7nORL0kD3g{_%*zUuRgJJO4=r-u&7sk?W^Z6{{EW2->S18P9NM=j9MN znzc7F?9g7tBWa-cwCA|dBL&Sy2!n0i#fp7bM&!Z*yjzFW161> zXz0$k&~nfwGDMh2Kj_?bzTm02y@Jazr85`M5xIn%5K`*|mvk~5H;wKM6t|4_!r?{) zt{r}g3_zMIdJ zkyVt4WxmlB(K+V>CEw%&b>tHz-|~`g@S)?+n;!m?IvvY=5lLA79WM#H|IAB*L4k!! zzsgVaCrE-nU+1SU@P{j9_n`c1F9~}+@)7}xD}L!EZ+iF%KT#)G4u}ch9e@7i?Fa~5 zapWaouQykH+v|i+zw#2nkalt}k+>-NiI)VOfOGKhD_%!X4X)BV*_3uD6~qEFDHTcZ zCrCcvr!QC)kPoW@s-Lr$xZ3eBtO`sBk^abgD86`@2=wb_S{Q64c9j8?O`UJ@mTZ z&(P}xocF!tyL_N!QD$6T=b@yMlCXP-;(L(Fsvq)!I`YtoEA0MruOonSuNPhta1K8I Qm!F{Xe*ECyfBDb<02g@oSpWb4 literal 0 HcmV?d00001 diff --git a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC new file mode 100644 index 0000000000000000000000000000000000000000..a835fbceb863255b1fbba6559b1054df92d89f6b GIT binary patch literal 4927 zcmcgv>yF!66;6A4ejLN$qQj2^2(&bSI+0R$F745@93r`i(^_QgV7p~T2!Y4mnV9j| z#+T*{h!;Tc6ubqG!;|o>ZSTZMW?J=d$*796yl#7~Z+&Z5)1DkWd3rXTdA@5Jr{tTS zPczpUnd8^4scDlq5fKF?{n>Oa?=N5S`=RyN8NM>y@yMB-3MxgV6Zu*5j+N$df!wNPHlUlVrd06piO<(244Wbj63VlpBE+fKQ}lBVC66T| zE#e}&!vVj~gMzKLogfu62p5#in|x(mI8I50_+uRxC_;=M*)pY2mTC!^Y)^^Prc|d9 z4z)MJyEwhvLweHDG%jD;9V`c{%HE#vLDTi(JzgcCOteGO&`7XOt-I@{9YcgtS?G{3I=lE zU|f>yq-=Y~Wdnm|2zBj9r#Gn9{H7_@x>yU>cG}$*$TAxoKNm23~;F8=7nud~lTL7lPu9AP7 z(i-&}x+9&-DAAzptFrCAo8+4n!5hHS#}mVw?)5d8qE|M($CQmG*3|Tdd)gBn^WK1> z8KOcG5bz&n={&xy8^B|Vi>ipDOR$I>#16l0=(V8YZc4_xjqP;p>FTs&b20U-!tHfr+k#9Dfm#nS!Tr*HjE@kB+8JNgoc&5Wi3(J ztkm0g18Da4%3z|`IA~U^ZrPSk&%QV~pc8tCbK8z>(xH4jbL=x`GLePD`jk0c1a(Ac zo4^{zf_fZc0StJ{#TB!1M04IJXm3?yNf&vZX^$l?T6ZnOHssrGFPL#XK%fz}U07vU zVr?y2{OF9SeMb@}Hgj2FQG&`*=Ds=_W7qQ-hP#p8bGKQW4%d&mZ;nx-?L4&6T|MSu z{kk1y+y6#?89JWn^ZiLyA#8469q^*nEi39!)MtikoSMGrdc^l8hM&r%+eKJG{67W_ zTFeZ~cM`d$S64NjCT#mbL-}p`4Oi(*>P#Q)rLehel$FTI(2obWRprSI6ZWc)E%k$` z!KUDhnJ94bYhX&`C1HY(C7yYdv7*O!b-Tm5U$^NU7ynW3|F1>ES^=H>n%CcotMY7# zz0KF3cAMdPvbwnI7)ui~xv#LvY_opd=PmW_9%#1Xo6o_gK*joh8@P+S#r$RdtONc7CVKq& zxc5=-sCR(B_VdxbUhm%erxI^|AN78WzYnn(C~f|}j~MUyJm@{>eb)QHr*IjsENWWQa769=30koKiZIy~sB#}hn(IZiFxm=gbJClgZ3 zH*8kz_f@Pmllv$e*9jkfz>(I12OYtW_<2X8D|r4sjeCDp8sFoG`}p@mCE1AE_4==E zjel$lc5?rASA(O-mMN#K{sY#KcF2M?3>GL27JOd`zQGSH`JIyRPZm5;f|be}B~dED zw%}*mf{oPJ>nB|ePVq|?s9gE`xGP|j-?M;|UzL@m8^_u4`W@C#URnJQEKn8T@1J%B ztnphV_<%5v*`^z210?KqC$n#EoBVmD@h3E8xmVb5$b#?sql#Fc(U2_hELz{6yJs t?i}JX7N}JDTTY1*a2UeBRj+Q%Olo&i{kt-eZ@QGTEzsQF-~RN^e*<}Ic&Y#Z literal 0 HcmV?d00001 diff --git a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~1~ b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..83b42df1dd7c89ffda7d4a6dc597725dd7182b7a GIT binary patch literal 4822 zcmcgv>yF#j5tbeIM+l@rfc^+tBpA2}b_K|+)@vtgw-rEBlublSswCI-A_x#Jd9-4d zOR~IJ*%bL*pg@s_=v(x0`Xv44kd&y)x=oryhAnD1XRhCTbF3(jhL0YI3q;bMljrbi?u-+cI^xKcI`MB#KHBUuUr&;oKr!Qkjw;`dJAdqV_sZ za|BRa!?DPz5T#1wrS&^jnnyWeE0^hjZqkYp!RZs{*943+dF02GrFlv4Q?jM-_v}ih zB|R;oJiNsKzt8-fPi-4PD25*_D4o~w%DS+hf^zYfD#}rW2tU$gLV+yR5;EDI0@)^1 zB_Wc!uj5^mT;4}`($F+2GMYvgxu4(AX&P2B3@!7h6jerPBC}gTKtqso23J+2q0Paa$C?2n8dAbCq4hk|t;5W^<6zGDc(kvGY6&5H*D%ly%`J`h$ zU`uw@_*w)om4xUQ$0rixqKpnr>%mOZKhvHYbnr@_J~(p?r>_|NR;E`}7X=^%bvbT0 zT9E9cYc;A@IkmMh zpNUiWyDhFwnwskNDg0|pQrF;!Wdt(vvrPD?QE`O{qU9puUh}9k8-Q8R!<0i+l?NO- zkGxdeAhSW;-HQ|q*P)A+!epmFVttNX(x7BE03^N{)GZ`up93bou9CM;X^ry@U0vk@ zN(3-Inu;B~nb+&Bz;o!TXMJUaV`!1Je;d@w?nrs0VxsHz*JF}PiUGodG?_=2RSjv( zXx8WZho>dEt__56kHdH{(B(9Nr)rYQ-OT$EK_Pjn)d82h4Bm1k>?^1PyLf#?qlJDG@ujD6s-T z(x`5Kl@Y_vbs3|(u6CGUZ0jTZ^=y0Us>7p^` zUoParUER5OX0WygHHSAr*QBB{S2IgAx4ZhtdmnQg$71&bl76@fVai^iq7lj&0SC|+cTbmH-U@we;i`rzs6N;6$Vhi&!L$6 zRa`a~u^b%Dmjfp7mjjyFGv2KT=uZp@um;Gbe!ENWtRb(}d2|^il4ihoKt+!~zv#Wy zQ+q@FX+Ce=>Gkfcf41WFx7zyb+BI zzMpy9kziHh0d#mv)eqf)!X(bzeyH@|bt?|!o!A|V& zb~RAa-k>XB_4m61*3h;E-);-O+ZOoSf{(Wa8*bUl+g%NgfaWO7!!vH!94+lESA z0axUgT>%?)x&pQ(i`W|F@B3X1KJs}h_#WBqph;_uw4v@~x8rxGAjP%~>I(KI)9-3< zG8e7j_GEV4{I)&Av2(rT*|ugZ_;pu<-B4GsH!?o9!YXV0qZPyF!66;6A4ejLN$qQj2^2(&bSI+0R$F745@93r`i(^_QgV7p~T2!Y4mnV9j| z#+T*{h!;Tc6ubqG!;|o>ZSTZMW?J=d$*796yl#7~Z+&Z5)1DkWd3rXTdA@5Jr{tTS zPczpUnd8^4scDlq5fKF?{n>Oa?=N5S`=RyN8NM>y@yMB-3MxgV6Zu*5j+N$df!wNPHlUlVrd06piO<(244Wbj63VlpBE+fKQ}lBVC66T| zE#e}&!vVj~gMzKLogfu62p5#in|x(mI8I50_+uRxC_;=M*)pY2mTC!^Y)^^Prc|d9 z4z)MJyEwhvLweHDG%jD;9V`c{%HE#vLDTi(JzgcCOteGO&`7XOt-I@{9YcgtS?G{3I=lE zU|f>yq-=Y~Wdnm|2zBj9r#Gn9{H7_@x>yU>cG}$*$TAxoKNm23~;F8=7nud~lTL7lPu9AP7 z(i-&}x+9&-DAAzptFrCAo8+4n!5hHS#}mVw?)5d8qE|M($CQmG*3|Tdd)gBn^WK1> z8KOcG5bz&n={&xy8^B|Vi>ipDOR$I>#16l0=(V8YZc4_xjqP;p>FTs&b20U-!tHfr+k#9Dfm#nS!Tr*HjE@kB+8JNgoc&5Wi3(J ztkm0g18Da4%3z|`IA~U^ZrPSk&%QV~pc8tCbK8z>(xH4jbL=x`GLePD`jk0c1a(Ac zo4^{zf_fZc0StJ{#TB!1M04IJXm3?yNf&vZX^$l?T6ZnOHssrGFPL#XK%fz}U07vU zVr?y2{OF9SeMb@}Hgj2FQG&`*=Ds=_W7qQ-hP#p8bGKQW4%d&mZ;nx-?L4&6T|MSu z{kk1y+y6#?89JWn^ZiLyA#8469q^*nEi39!)MtikoSMGrdc^l8hM&r%+eKJG{67W_ zTFeZ~cM`d$S64NjCT#mbL-}p`4Oi(*>P#Q)rLehel$FTI(2obWRprSI6ZWc)E%k$` z!KUDhnJ94bYhX&`C1HY(C7yYdv7*O!b-Tm5U$^NU7ynW3|F1>ES^=H>n%CcotMY7# zz0KF3cAMdPvbwnI7)ui~xv#LvY_opd=PmW_9%#1Xo6o_gK*joh8@P+S#r$RdtONc7CVKq& zxc5=-sCR(B_VdxbUhm%erxI^|AN78WzYnn(C~f|}j~MUyJm@{>eb)QHr*IjsENWWQa769=30koKiZIy~sB#}hn(IZiFxm=gbJClgZ3 zH*8kz_f@Pmllv$e*9jkfz>(I12OYtW_<2X8D|r4sjeCDp8sFoG`}p@mCE1AE_4==E zjel$lc5?rASA(O-mMN#K{sY#KcF2M?3>GL27JOd`zQGSH`JIyRPZm5;f|be}B~dED zw%}*mf{oPJ>nB|ePVq|?s9gE`xGP|j-?M;|UzL@m8^_u4`W@C#URnJQEKn8T@1J%B ztnphV_<%5v*`^z210?KqC$n#EoBVmD@h3E8xmVb5$b#?sql#Fc(U2_hELz{6yJs t?i}JX7N}JDTTY1*a2UeBRj+Q%Olo&i{kt-eZ@QGTEzsQF-~RN^e*<}Ic&Y#Z literal 0 HcmV?d00001 diff --git a/internal/test/Library/4045xlpstream/Hand/4045xlpstream.u b/internal/test/Library/4045xlpstream/Hand/4045xlpstream.u new file mode 100644 index 0000000000000000000000000000000000000000..83b42df1dd7c89ffda7d4a6dc597725dd7182b7a GIT binary patch literal 4822 zcmcgv>yF#j5tbeIM+l@rfc^+tBpA2}b_K|+)@vtgw-rEBlublSswCI-A_x#Jd9-4d zOR~IJ*%bL*pg@s_=v(x0`Xv44kd&y)x=oryhAnD1XRhCTbF3(jhL0YI3q;bMljrbi?u-+cI^xKcI`MB#KHBUuUr&;oKr!Qkjw;`dJAdqV_sZ za|BRa!?DPz5T#1wrS&^jnnyWeE0^hjZqkYp!RZs{*943+dF02GrFlv4Q?jM-_v}ih zB|R;oJiNsKzt8-fPi-4PD25*_D4o~w%DS+hf^zYfD#}rW2tU$gLV+yR5;EDI0@)^1 zB_Wc!uj5^mT;4}`($F+2GMYvgxu4(AX&P2B3@!7h6jerPBC}gTKtqso23J+2q0Paa$C?2n8dAbCq4hk|t;5W^<6zGDc(kvGY6&5H*D%ly%`J`h$ zU`uw@_*w)om4xUQ$0rixqKpnr>%mOZKhvHYbnr@_J~(p?r>_|NR;E`}7X=^%bvbT0 zT9E9cYc;A@IkmMh zpNUiWyDhFwnwskNDg0|pQrF;!Wdt(vvrPD?QE`O{qU9puUh}9k8-Q8R!<0i+l?NO- zkGxdeAhSW;-HQ|q*P)A+!epmFVttNX(x7BE03^N{)GZ`up93bou9CM;X^ry@U0vk@ zN(3-Inu;B~nb+&Bz;o!TXMJUaV`!1Je;d@w?nrs0VxsHz*JF}PiUGodG?_=2RSjv( zXx8WZho>dEt__56kHdH{(B(9Nr)rYQ-OT$EK_Pjn)d82h4Bm1k>?^1PyLf#?qlJDG@ujD6s-T z(x`5Kl@Y_vbs3|(u6CGUZ0jTZ^=y0Us>7p^` zUoParUER5OX0WygHHSAr*QBB{S2IgAx4ZhtdmnQg$71&bl76@fVai^iq7lj&0SC|+cTbmH-U@we;i`rzs6N;6$Vhi&!L$6 zRa`a~u^b%Dmjfp7mjjyFGv2KT=uZp@um;Gbe!ENWtRb(}d2|^il4ihoKt+!~zv#Wy zQ+q@FX+Ce=>Gkfcf41WFx7zyb+BI zzMpy9kziHh0d#mv)eqf)!X(bzeyH@|bt?|!o!A|V& zb~RAa-k>XB_4m61*3h;E-);-O+ZOoSf{(Wa8*bUl+g%NgfaWO7!!vH!94+lESA z0axUgT>%?)x&pQ(i`W|F@B3X1KJs}h_#WBqph;_uw4v@~x8rxGAjP%~>I(KI)9-3< zG8e7j_GEV4{I)&Av2(rT*|ugZ_;pu<-B4GsH!?o9!YXV0qZPTwQ&7cEv4ZS_+8K%s)#QhHstvo^3zmL%G)Kh0lfCM}Y( z)l&z$yuNueZ}u(cuA;M(v-3gcxob7XW9Xr=&{6L^dXyG*CQN>O3w_i^DA|Hep+!Pt zuA=sb9Vy*{XLL$SnbSsYpbe0U2eP zct@EabPHo~Y}|Uf#DI<^q(UMn>e>-Ps-(@eN=1e+iH++{aaadv=XtDA+N|(0i4!m? zwG&6eP@$2B77SYW$V+Pyr8OpQvd($?wFS*)vjK1)7zqPX&E|i_@KykYH_dY6!>co@ zb+*QiJ(@qNmGGa(m0m!d2AHimafKa(R2d(I)ROgKn{dq?wa21|yH5YE_juE0J2OR< zEz8<7T_Hufzo;6w3r9p4xYTZ+-BmA|sVCgPlvhz;#@V>;b@Q_s!F2Y3@A|f&* zmrVktLrAhg9g=VYB?)zYC4U}Ii~N#56@G`8%>w`$p;#88DG}tqpdjMY{r>-o*KJ5?2eL8~id9=`+f8J(tGhKx zp!hMqhEL(%mY+&Ou^26+*6I5^_jJ21K9xqjadbVn92&*h3?i-#4CKVE^fSX%D)jti z58iU6h0HoIxK|=3H+(97Zl+Ro;F6;ygj^)|Zl%Wz?||2aGp6Dxc*pIQ3-)ncK&NZ2 z<^2AHdbmsH+V-$dUU17as62zQk~3f#cwYS&%v8yIGKDVBjFOp%HQ-(XQS__* zu8rGG3zQwh;lbg-K7jq&96FC49W6W~$VnrC_nk$7#s(uKqW}{xif;_L?{Epg~V&9oGFycG| zqXhbmxD9~abBNg}71;#zoEIGB8GFw}iZEXUJZ@7!AF!nqOP(lf4~Gv#Iq0d(QwnLx zl{B&qGKGe*xT8{$)Ky8#oVZJAaqc|XcU?c!FueNdtRF=|&#m4HGX-s!$u(dPa=a4J zE95dx^Mq?4A1o!7vzdlDi*MM3>zeDf8b|eoIy*pWAn72la4WJz-WJ5kd{uwOW*kdR zx&GF&RVWA5aN57dVldp{DqO~~A)H|%<9vp~K^~bYk|dJr>>Kmccvs<$jv7T-bkL$O z@Xs(>;YtyS-DQ?oW@9lS$g3ZmzXL} z10ABPVGs^`{V?c87hyjbu1aklwmNXWX!(|@tmqU4sBkVL;?TPgJzDJNy1@|N*e{o~--UNfULDcX1&gVsxU1uBq>T&qf z$KlT&hZokk`J>}id%>xHHHc0x&Li-k`r7Zl@xiOtmdiG-q98o$pZf!7*J{q%ox<-r z&+u)@eNO)$5U|beZ3O*-)|Ad>qLDm zU_v`9lP8O(KsLye7B+@8TM!TALbPmA^8ldyTNViH{DWY@?Nd{J5?2eL8~id9=`+f8J(tGhKx zp!hMqhEL(%mY+&Ou^26+*6I5^_jJ21K9xqjadbVn92&*h3?i-#4CKVE^fSX%D)jti z58iU6h0HoIxK|=3H+(97Zl+Ro;F6;ygj^)|Zl%Wz?||2aGp6Dxc*pIQ3-)ncK&NZ2 z<^2AHdbmsH+V-$dUU17as62zQk~3f#cwYS&%v8yIGKDVBjFOp%HQ-(XQS__* zu8rGG3zQwh;lbg-K7jq&96FC49W6W~$VnrC_nk$7#s(uKqW}{xif;_L?{Epg~V&9oGFycG| zqXhbmxD9~abBNg}71;#zoEIGB8GFw}iZEXUJZ@7!AF!nqOP(lf4~Gv#Iq0d(QwnLx zl{B&qGKGe*xT8{$)Ky8#oVZJAaqc|XcU?c!FueNdtRF=|&#m4HGX-s!$u(dPa=a4J zE95dx^Mq?4A1o!7vzdlDi*MM3>zeDf8b|eoIy*pWAn72la4WJz-WJ5kd{uwOW*kdR zx&GF&RVWA5aN57dVldp{DqO~~A)H|%<9vp~K^~bYk|dJr>>Kmccvs<$jv7T-bkL$O z@Xs(>;YtyS-DQ?oW@9lS$g3ZmzXL} z10ABPVGs^`{V?c87hyjbu1aklwmNXWX!(|@tmqU4sBkVL;?TPgJzDJNy1@|N*e{o~--UNfULDcX1&gVsxU1uBq>T&qf z$KlT&hZokk`J>}id%>xHHHc0x&Li-k`r7Zl@xiOtmdiG-q98o$pZf!7*J{q%ox<-r z&+u)@eNO)$5U|beZ3O*-)|Ad>qLDm zU_v`9lP8O(KsLye7B+@8TM!TALbPmA^8ldyTNViH{DWY@?Nd{TwQ&7cEv4ZS_+8K%s)#QhHstvo^3zmL%G)Kh0lfCM}Y( z)l&z$yuNueZ}u(cuA;M(v-3gcxob7XW9Xr=&{6L^dXyG*CQN>O3w_i^DA|Hep+!Pt zuA=sb9Vy*{XLL$SnbSsYpbe0U2eP zct@EabPHo~Y}|Uf#DI<^q(UMn>e>-Ps-(@eN=1e+iH++{aaadv=XtDA+N|(0i4!m? zwG&6eP@$2B77SYW$V+Pyr8OpQvd($?wFS*)vjK1)7zqPX&E|i_@KykYH_dY6!>co@ zb+*QiJ(@qNmGGa(m0m!d2AHimafKa(R2d(I)ROgKn{dq?wa21|yH5YE_juE0J2OR< zEz8<7T_Hufzo;6w3r9p4xYTZ+-BmA|sVCgPlvhz;#@V>;b@Q_s!F2Y3@A|f&* zmrVktLrAhg9g=VYB?)zYC4U}Ii~N#56@G`8%>w`$p;#88DG}tqpdjMY{r>-o*K5{S$QLCh1AeNs}l}&z!>*je$BH zZchgx@fb+F0TMS{0fIYjcn=<69)WKy+llL>ot~pX!c`M{W$pF*?X}jnrr|2?Rrc!7 zx&tE&q`43ysX{SuOjl^djvLCrv6WwHil;JAw&xy;?oD7@v=CQOkHWbZ9E*Vjrx;3m za-$Xd!OV2+Pt1_{pUJ>`A@q)+6`N)#k45!JoST6)7l#L0(Fn~jQpchhnA1=zp4pC^ z2or?gwuYVF^Oo_uUyNGD=%m{*1}EL;!%pL5(A9g!Now_I*wW9-M2k&|&GP-gyD}Yh zj7Nd1SftN~UqxIG=LRQY(TG&&Ef5AH@_jD|p|ogt)9~61q-e@3>3IG^y5TFDl$cY5 zra|CMA}i!vk)iA}#~B$3LVIdkw&@5;pX1mw=~_}4H!7411=ec0A}F=75adW3&21$n zo)wXKVj`6l*kh?gIG4gFC``S8{udA$0w1~B@41l<<%x@Ipfm2lXDo-lAwOWP!Z#K@e^jiI> z0^G2iCgLL@+K(i`Blx1@ubu1j5>O^*?-z9H%}=c9G-hto$5xXVQ{feS0O)n z*%_{~@!aTNj3}J6?WUgNc-OSM7IEywH1HN{0=k{kp+0EdZS^#2U}y3EDPgFYt(4RkJGYf4==i{_z5Xv@UH@ujX8I> zwmxh&`h({u2Ae@NqkN$uYaLgZ6Vw0(uqPbPoRE9S<acU(KTY|nmGjQCR0^ zDq6%^erRK&4xNe;;P)6FpBLiQ^x1Jy8+`}I z;T4VVXp4%$K8=iyN8Kce5f_LYZ~Ax_L^2lVOUr)skZNRYZyD;GPx177fov*~MC)O& zZp0@To_G&XZFq_%IVjaL4*SHD%6&iNhIx0m@59M%jf}7EmGo%#xz)vZTY4_4TzV!w z?Tk*lqqMK3$DBCqcfllM_gc^o>Qv7~t<>|bUc&C4ypDC^)0o?HhBi@nPR6-i27D%@ zgM8p)g1`Zf4~q(ImudG9`mZ#$!Qlit@x z8HP6s#lrUr#dfRvv^DB9^upKT9}&(?Wc+xG{Qa2w^&I)F&E!OO;rF+NB;>r1uir1E zQ24M=-D8EjuLDVi0%PY* zCVhT{ACSB+XM}#2?!Sb8QVIMfdWiyjtPJ^|6WCMI@>SBj(U5P@FT_%$n~f~&8nJwZ zSdhFpj9Ke>F%j`fpp=$5Rx#kvt;w>T(Pw+tf5f5iU-LGvwQO`V~& ziU_OluT}mKzJH(M)@@FEX9JJ(@SpqFtlkp?s$jabYthq}ZYwrFmyOyML?_08_ zhLFTIv1SSH=Ly$&!eO3pkSDBp#}zqshSVPAm+a>W@8t=%)DqOcljR@+XDaoD2&^_s z_%%v+p75VMfp=r-%f>qKHZ4ir zUvgv#%a)u*eVO$i(pt^|;zetJoDzOQH`%nWWr{hnYS>C{+_A8?-+S$?PyYU2DwG#p literal 0 HcmV?d00001 diff --git a/internal/test/Library/Auto/AR8230.TEST b/internal/test/Library/Auto/AR8230.TEST new file mode 100644 index 00000000..c5c792ec --- /dev/null +++ b/internal/test/Library/Auto/AR8230.TEST @@ -0,0 +1 @@ +;; AR 8320 test ;; Filed as {ERIS}TEST>MATMULT>AR8320.TEST ;; By Peter Reidy ;; Verify that MATMULT-331 will accept its specified arguments. (do-test AR8320-test (IL:MATMULT-331 (IL:MAKE-HOMOGENEOUS-3-BY-3) (IL:MAKE-HOMOGENEOUS-3-VECTOR)) ) \ No newline at end of file diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST new file mode 100644 index 00000000..fb727988 --- /dev/null +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST @@ -0,0 +1 @@ +;;;; Test code for CASH-FILE ;;; Start with an XCL exec. Copy each non-commented statement ;;; from this file into the executive and observe that it behaves ;;; as described in the comments. ;;; These tests are meant to be done IN ORDER, and ONLY ONCE ;;; as many tests depend upon the sucess of previous tests. ;;; Set up a package for testing in. ;;; MAKE-PACKAGE will report an error if a package named "TEST" exists. ;;; If this happens, use a name besides "TEST". (DO-TEST-GROUP ("Cash-file tests" :AFTER (PROGN ;; now clean up the cash file (hash-file:close-hash-file (cash-file:cash-file-hash-file cash-file)) (delete-file "{dsk}test.hash")) ) ;;; Test MAKE-CASH-FILE & CASH-FILE-P (DO-TEST "Test MAKE-CASH-FILE & CASH-FILE-P" (setq cash-file (cash-file:make-cash-file "{dsk}test.hash" 100 10)) (and (cash-file:cash-file-p cash-file) (typep cash-file 'cash-file:cash-file)) ;; should return T ) ;;; Test GET-CASH-FILE (DO-TEST "Test1 GET-CASH-FILE" (EQUAL (multiple-value-list (cash-file:get-cash-file :foo cash-file)) '(NIL NIL)) ;; should return (nil nil) ) (DO-TEST "Test2 GET-CASH-FILE" (EQUAL (multiple-value-list (cash-file:get-cash-file :foo cash-file :bar)) '(:bar nil)) ;; should return (:bar nil) ) (DO-TEST "Test3 GET-CASH-FILE" (EQUAL (setf (cash-file:get-cash-file :test-key cash-file) :test-value) :test-value) ;; should return :test-value ) (DO-TEST "Test4 GET-CASH-FILE" (EQUAL (multiple-value-list (cash-file:get-cash-file :test-key cash-file)) '(:test-value t)) ;; should return (:test-value t) ) ;;; Test CASH-FILE-HASH-FILE (DO-TEST "Test1 CASH-FILE-HASH-FILE" (hash-file:hash-file-p (cash-file:cash-file-hash-file cash-file)) ;; should return true ) (DO-TEST "Test2 CASH-FILE-HASH-FILE (closing)" (pathnamep (hash-file:close-hash-file (cash-file:cash-file-hash-file cash-file))) ;; should return #.(pathname "{dsk}test.hash") ) (DO-TEST "Test3 CASH-FILE-HASH-FILE" (multiple-value-list (cash-file:get-cash-file :test-key cash-file)) ;; should return (:test-value t) without opening hash file ) ;;; Test OPEN-CASH-FILE (DO-TEST "Test1 OPEN-CASH-FILE" (setq cash-file (cash-file:open-cash-file "{dsk}test.hash" 10)) (cash-file:cash-file-p cash-file) ;; should be true ) (DO-TEST "Test2 OPEN-CASH-FILE" (EXPECT-ERRORS (T) (setf (cash-file:get-cash-file :test-key cash-file) :test-value) ;; should signal an error ) ) (DO-TEST "Test3 OPEN-CASH-FILE (closing)" (pathnamep (hash-file:close-hash-file (cash-file:cash-file-hash-file cash-file))) ;; should return #.(pathname "{dsk}test.hash") ) (DO-TEST "Test4 OPEN-CASH-FILE" (setq cash-file (cash-file:open-cash-file "{dsk}test.hash" 10 :direction :io)) (cash-file:cash-file-p cash-file) ;; should be true ) (DO-TEST "Test4 OPEN-CASH-FILE" (EQUAL (setf (cash-file:get-cash-file :test-key cash-file) :test-value) :test-value) ;; should return :test-value ) ;;; Test REM-CASH-FILE (DO-TEST "Test1 REM-CASH-FILE" (cash-file:rem-cash-file :test-key cash-file) ;; should return T ) (DO-TEST "Test2 REM-CASH-FILE" (EQUAL (multiple-value-list (cash-file:get-cash-file :test-key cash-file)) '(nil nil)) ;; should return (nil nil) ) (DO-TEST "Test3 REM-CASH-FILE" (NOT (cash-file:rem-cash-file :test-key cash-file)) ;; should return NIL ) ) ; close DO-TEST-GROUPS \ No newline at end of file diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS new file mode 100644 index 00000000..90392554 --- /dev/null +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS @@ -0,0 +1 @@ +;;;; Test code for CASH-FILE ;;; Start with an XCL exec. Copy each non-commented statement ;;; from this file into the executive and observe that it behaves ;;; as described in the comments. ;;; These tests are meant to be done IN ORDER, and ONLY ONCE ;;; as many tests depend upon the sucess of previous tests. ;;; Set up a package for testing in. ;;; MAKE-PACKAGE will report an error if a package named "TEST" exists. ;;; If this happens, use a name besides "TEST". (make-package "TEST") (in-package "TEST") (use-package "CASH-FILE") (use-package "HASH-FILE") ;;; Test MAKE-CASH-FILE & CASH-FILE-P (setq cash-file (make-cash-file "{dsk}test.hash" 100 10)) (and (cash-file-p cash-file) (typep cash-file 'cash-file)) ;; should return T ;;; Test GET-CASH-FILE (multiple-value-list (get-cash-file :foo cash-file)) ;; should return (nil nil) (multiple-value-list (get-cash-file :foo cash-file :bar)) ;; should return (:bar nil) (setf (get-cash-file :test-key cash-file) :test-value) ;; should return :test-value (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (:test-value t) ;;; Test CASH-FILE-HASH-FILE (hash-file-p (cash-file-hash-file cash-file)) ;; should return true (close-hash-file (cash-file-hash-file cash-file)) ;; should return #.(pathname "{dsk}test.hash") (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (:test-value t) without opening hash file ;;; Test OPEN-CASH-FILE (setq cash-file (open-cash-file "{dsk}test.hash" 10)) (cash-file-p cash-file) ;; should be true (setf (get-cash-file :test-key cash-file) :test-value) ;; should signal an error (close-hash-file (cash-file-hash-file cash-file)) ;; should return #.(pathname "{dsk}test.hash") (setq cash-file (open-cash-file "{dsk}test.hash" 10 :direction :io)) (cash-file-p cash-file) ;; should be true (setf (get-cash-file :test-key cash-file) :test-value) ;; should return :test-value ;;; Test REM-CASH-FILE (rem-cash-file :test-key cash-file) ;; should return T (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (nil nil) (rem-cash-file :test-key cash-file) ;; should return NIL ;; now clean up the cash file (close-hash-file (cash-file-hash-file cash-file)) (delete-file "{dsk}test.hash") \ No newline at end of file diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~1~ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~1~ new file mode 100644 index 00000000..262e2cb0 --- /dev/null +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~1~ @@ -0,0 +1 @@ +;;;; Test code for CASH-FILE ;;; Start with an XCL exec. Copy each non-commented statement ;;; from this file into the executive and observe that it behaves ;;; as described in the comments. ;;; These tests are meant to be done IN ORDER, and ONLY ONCE ;;; as many tests depend upon the sucess of previous tests. ;;; Set up a package for testing in. ;;; MAKE-PACKAGE will report an error if a package named "TEST" exists. ;;; If this happens, use a name besides "TEST". (make-package "TEST") (in-package "TEST") (use-package "CASH-FILE") (use-package "HASH-FILE") ;;; Test MAKE-CASH-FILE & CASH-FILE-P (setq cash-file (make-cash-file "{dsk}test.hash" 100 10)) (and (cash-file-p cash-file) (typep cash-file 'cash-file)) ;; should return T ;;; Test GET-CASH-FILE (multiple-value-list (get-cash-file :foo cash-file)) ;; should return (nil nil) (multiple-value-list (get-cash-file :foo cash-file :bar)) ;; should return (:bar nil) (setf (get-cash-file :test-key cash-file) :test-value) ;; should return :test-value (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (:test-value t) ;;; Test CASH-FILE-HASH-FILE (hash-file-p (cash-file-hash-file cash-file)) ;; should return true (close-hash-file (cash-file-hash-file cash-file)) ;; should return #.(pathname "{dsk}test.cash") (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (:test-value t) without opening hash file ;;; Test OPEN-CASH-FILE (setq cash-file (open-cash-file "{dsk}test.cash" 10)) (cash-file-p cash-file) ;; should be true (setf (get-cash-file :test-key cash-file) :test-value) ;; should signal an error (close-hash-file (cash-file-hash-file cash-file)) ;; should return #.(pathname "{dsk}test.cash") (setq cash-file (open-cash-file "{dsk}test.cash" 10 :direction :io)) (cash-file-p cash-file) ;; should be true (setf (get-cash-file :test-key cash-file) :test-value) ;; should return :test-value ;;; Test REM-CASH-FILE (rem-cash-file :test-key cash-file) ;; should return T (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (nil nil) (rem-cash-file :test-key cash-file) ;; should return NIL \ No newline at end of file diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ new file mode 100644 index 00000000..90392554 --- /dev/null +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ @@ -0,0 +1 @@ +;;;; Test code for CASH-FILE ;;; Start with an XCL exec. Copy each non-commented statement ;;; from this file into the executive and observe that it behaves ;;; as described in the comments. ;;; These tests are meant to be done IN ORDER, and ONLY ONCE ;;; as many tests depend upon the sucess of previous tests. ;;; Set up a package for testing in. ;;; MAKE-PACKAGE will report an error if a package named "TEST" exists. ;;; If this happens, use a name besides "TEST". (make-package "TEST") (in-package "TEST") (use-package "CASH-FILE") (use-package "HASH-FILE") ;;; Test MAKE-CASH-FILE & CASH-FILE-P (setq cash-file (make-cash-file "{dsk}test.hash" 100 10)) (and (cash-file-p cash-file) (typep cash-file 'cash-file)) ;; should return T ;;; Test GET-CASH-FILE (multiple-value-list (get-cash-file :foo cash-file)) ;; should return (nil nil) (multiple-value-list (get-cash-file :foo cash-file :bar)) ;; should return (:bar nil) (setf (get-cash-file :test-key cash-file) :test-value) ;; should return :test-value (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (:test-value t) ;;; Test CASH-FILE-HASH-FILE (hash-file-p (cash-file-hash-file cash-file)) ;; should return true (close-hash-file (cash-file-hash-file cash-file)) ;; should return #.(pathname "{dsk}test.hash") (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (:test-value t) without opening hash file ;;; Test OPEN-CASH-FILE (setq cash-file (open-cash-file "{dsk}test.hash" 10)) (cash-file-p cash-file) ;; should be true (setf (get-cash-file :test-key cash-file) :test-value) ;; should signal an error (close-hash-file (cash-file-hash-file cash-file)) ;; should return #.(pathname "{dsk}test.hash") (setq cash-file (open-cash-file "{dsk}test.hash" 10 :direction :io)) (cash-file-p cash-file) ;; should be true (setf (get-cash-file :test-key cash-file) :test-value) ;; should return :test-value ;;; Test REM-CASH-FILE (rem-cash-file :test-key cash-file) ;; should return T (multiple-value-list (get-cash-file :test-key cash-file)) ;; should return (nil nil) (rem-cash-file :test-key cash-file) ;; should return NIL ;; now clean up the cash file (close-hash-file (cash-file-hash-file cash-file)) (delete-file "{dsk}test.hash") \ No newline at end of file diff --git a/internal/test/Library/GCHAX/Auto/GCHAX.TEST b/internal/test/Library/GCHAX/Auto/GCHAX.TEST new file mode 100644 index 0000000000000000000000000000000000000000..02e5b10758bcdec7a4dcae941ad0896bca7be3e4 GIT binary patch literal 3188 zcmb7FO>-MX5LG@2I&q;m0gZC-x(bT~C<@|W$|cK=KxLUoAxV`FjCNpy$w})h#YRub zC6bOhkM^InkF}GBDwS=bo|{7!T1wT}2y;QX2w#W^gZ9(ZzmAK{6I+UOSWIQ+WJD?} zSxKIUGIw-3d^C94?(_%4?m_!$@AzQwbV$NTZwL6P%G6Y(=><7WGP4D%5_wT#5{awG zB3PhII~u2YMnw)Me1ulIWmKWa$cYz{tUQxOq)c5PU?w(2M#7TS)6y`GQkXEISQ|1j zhM6oZp}AHF#8@Aw)t{H%%oKta_QitSsVVTSVFKT&SEs88*skL`=<#o;zz;2C4v~n= z&ZHsbtW0BSWx7RDz!N4U5yLd9HWSK`LcLHVt{H@phCR+fN#Ii;k?u&Hsi;7>jH4KJ zM1c{NC*_iZVp*v~oJkr>iFD+-%pz34>4^jgE+K#H?^sPd4+mfqu2ra~Q#4Shqp}(k z0c@niB-7TZ5HDeIDtwoXQAv2BvdNlhJQ3(3g9k+_3~3Wd({AqW;s@nK-E?6>I1A^? zxX;UY(1Il&d}9UoYe$#}eJ7k43k#4wi1uO-|6~#-;(Qw)T9EBbj4pBt zTBoNr(X&a|q6cG%1WF1b8Cz$H5ED`uZ+fS^^MnOVw4kAuH;BC;B`vAge08I(O_ptP zb&dserd(3(9VAsQ2dvc$FtRV{oPsGPb>|XJFv^!H-KQXx*#tyy^8!w+#&YUc&QXVE z3EF&c+pv^3gzrnM zJ`dP@VTSe#F^*+s>iA1*&dJ_rK;-BUtNmoqJ05i(Bg>0sw`!WF5_^m0y?uHbV`t5G zWYr~j!4rmvyjyj|JNee!!uxp$mpZz1Y^CFC&JWvz!!|ce)hjh;Y+J`|cacll!YD~G zZEo@S`liy@ra9%#aDLW0=#nJxf5lGkapy^Y|8Z~hyfVg994g}%q;ePURvEg_mZ{ln z4o8EN27hif?lgkN-~Q~su3uZ8*G@s>uchRTxIeFm`{IhYkFSXP`HHx&uZUa18gGb~ zQ8ybm8b^)qf`jhi{*(UbaBw{074@jw|D`+Xb@u67Z0pzGwo!)a^HJmd1+XS&cC2hs zq%PK&$qn{Ire_lWJB7DZzt!2<%5_isD<5y*_Z1(mHyYRe;{!`7h(Ff_|FEtu@R_U& zeEWb5pVCa9k1XBL990^IzK6@fy1@5`e+R^EXz$h$Ecm7_V2-W2fDu6@*s#A>Y1sZP zTt2G{ZsPLEy5Q4w!2+?tKCYk}niUfE`O6B*jTEST>MATMULT>AR8320.TEST ;; By Peter Reidy ;; Verify that MATMULT-331 will accept its specified arguments. (do-test AR8320-test (IL:MATMULT-331 (IL:MAKE-HOMOGENEOUS-3-BY-3) (IL:MAKE-HOMOGENEOUS-3-VECTOR)) ) \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST b/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST new file mode 100644 index 00000000..e18fa93a --- /dev/null +++ b/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST @@ -0,0 +1 @@ +;; DEGREES-TO-RADIANS ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>DEGREES-TO-RADIANS.TEST ;; Syntax: (DEGREES-TO-RADIANS DEGREES) ;; Function description: converts DEGREES to the equivalent quantity of radians. ;; Arguments: DEGREES - a real number ;; (do-test-group degrees-to-radians-group :before (il:load? '{eris}test>display>matmult>matmult-test.source) ;; (do-test degrees-to-radians-test ;; Compare the results of the function to an independent calculation that should give the same result. (every 'dtrtest (list 0 pi (* 2 pi) (- (+ pi pi)) (* 3/2 pi) (randmost) (randmost) (- (randmost)) (- (randmost))) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST new file mode 100644 index 00000000..cd08828d --- /dev/null +++ b/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST @@ -0,0 +1 @@ +;; IDENTITY-3-BY-3 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>IDENTITY-3-BY-3.TEST ;; Syntax: (IDENTITY-3-BY-3 &optional RESULT) ;; Function description: returns a 3-by-3 identity matrix - i.e. one in which every (N,N) element is 1.0 and every other is 0.0. If RESULT is supplied and is a 3-by-3 matrix of element-type single-float, the result is returned there. ;; Arguments: ;; RESULT - a 3-by-3 matrix of element-type single-float ;; (do-test-group make-homogeneous-n-by-4-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq non-ident (il:make-homogeneous-3-by-3 :a00 22.77 :a10 pi)) ) ;; (do-test identity-3-by-3-simple-case (and (idtest (il:identity-3-by-3)3) (not (idtest (il:identity-4-by-4) 3)) ) ) ;; (do-test n-by-4-with-result (and (not(idtest non-ident 3)) ; before (il:identity-3-by-3 non-ident) (idtest non-ident 3) ; after ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST new file mode 100644 index 00000000..0fc9e2e6 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST @@ -0,0 +1 @@ +;; IDENTITY-4-BY-4 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>IDENTITY-4-BY-4.TEST ;; Syntax: (IDENTITY-4-BY-4 &optional RESULT) ;; Function description: returns a 4-by-4 identity matrix - i.e. one in which every (N,N) element is 1.0 and every other is 0.0. If RESULT is supplied and is a 4-by-4 matrix of element-type single-float, the result is returned there. ;; Arguments: ;; RESULT - a 4-by-4 matrix of element-type single-float ;; (do-test-group make-homogeneous-n-by-4-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq non-ident (il:make-homogeneous-4-by-4 :a00 22.77 :a10 pi)) ) ;; (do-test identity-4-by-4-simple-case (and (idtest (il:identity-4-by-4) 4) (not (idtest (il:identity-3-BY-3) 4)) ) ) ;; (do-test n-by-4-with-result (and (not (idtest non-ident 4)) ; before (il:identity-4-by-4 non-ident) (idtest non-ident 4) ; after ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST new file mode 100644 index 00000000..b456596f --- /dev/null +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST @@ -0,0 +1 @@ +;;MAKE-HOMOGENEOUS-3-BY-3 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>MAKE-HOMOGENEOUS-3-BY-3.TEST ;; Syntax: (MAKE-HOMOGENEOUS-3-BY-3 &key A00 A01 A10 A20 A21) ;; Function description: returns a 3-by-3 matrix of element-type single-float; some elements can be specified in the keywords; the 2, 2 element is always 1.0. Other elements default to 0.0. ;; Arguments: keywords: where x and y are the two digits in the keyword, the corresponding matrix element will be set to the keyword value. ;; (do-test-group make-homogeneous-3-by-3-group :before (il:load? '{eris}test>display>matmult>matmult-test.source) ;; (do-test 3-by-3-simple-case (let ((matrix33a (il:make-homogeneous-3-by-3))) (2dtest matrix33a 3 3 #'(lambda nil (deftest33 matrix33a '(a22)))) ) ) ;; (do-test 3-by-3-with-keys (let ((randnum (- (random most-positive-single-float))) (mat33 (il:make-homogeneous-3-by-3 :a20 most-positive-single-float :a21 Most-negative-single-float :a10 randnum :a01 0 :a00 4761)) ) (2dtest mat33 3 3 #'(lambda nil (deftest33 mat33 '(a00 a01 a10 a20 a21 a22)) ) '(a00 a01 a10 a20 a21) (list 4761 0 randnum most-positive-single-float Most-negative-single-float) ) ; 3by3.test ) ; let ) ;; (do-test 3-by-3-error (expect-errors (error) (il:make-homogeneous-3-by-3 :a00 #c(0 3)))) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST new file mode 100644 index 00000000..2b02e268 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST @@ -0,0 +1 @@ +;;MAKE-HOMOGENEOUS-3-VECTOR ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>MAKE-HOMOGENEOUS-3-VECTOR.TEST ;; Syntax: (MAKE-HOMOGENEOUS-3-VECTOR &optional X Y) ;; Function description: returns a 3-vector of element-type single-float; the elements are X and Y in the first 2 places, and 1.0 in the third. ;; Arguments: X, Y: optional values for the first and second elements of the vector. ;; (do-test-group make-homogeneous-3-vector-tests :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq random (- most-positive-single-float (random most-positive-single-float))) ) ;; (do-test simple-3-vector-test (let ((simple.vector (il:make-homogeneous-3-vector))) (and (vectest simple.vector 3) (= 0.0 (aref simple.vector 0)) (= 0.0 (aref simple.vector 1)) ) ) ) ;; (do-test 3-vector-with-args-test (let ((3x (il:make-homogeneous-3-vector random)) (3y (il:make-homogeneous-3-vector nil most-negative-single-float)) (3xy (il:make-homogeneous-3-vector random most-positive-single-float)) ) (every 'vectest (list 3x 3y 3xy) '(3)) ) ) ;; (do-test 3-vector-complex-test (expect-errors (error) (il:make-homogeneous-3-vector #c(3 5)) ) ) ) ; do-test-group make-homogeneous-3-vector-tests END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-BY-4.TEST new file mode 100644 index 0000000000000000000000000000000000000000..cbe66862c3ed89a8109f83ce540e3820fc7d4bf9 GIT binary patch literal 1944 zcmaJ>U2oeq6m@_NgADX(f8YWI78$4vNfs8=El;RUhnCXw6dZr zsnR{~{HZdTk}&jre)VDX*W;z$2_j@xbw|i?vm{pj4W5 zrAl6psgky?3PXaD;AS5rlnYy_JJK7HnapKj1G_IJ8C7gE8Ei5w?1YTYWp{39Eeg7U zNGaE9qYxBTkiC@z#yef5X5vu%g5vHDDOk*QVs9uKhC`wy5fE^(w+p?Y}f8IrE06JdBEg_J6`LmlBU!}3ZFWETW4vfvdlRn zo%JI(=$puD$z1w=ssk&H4Yrl8OQ`rNgIk^Jtt_Oj4a$Z?*_`&h@r~T*O7=ZpWn;uI z{e#ZG%SxFauQFvy(2-NtHcf#tv7aIZIlS+_&eYK8x>`%lBowvw+nfbPFt!g4NwfGCFl8mg^U$-PJTdct#isX0$OULtokP5(tW+PBHkuibQ6WVc5l)DNT1J`aF69L8Z7cbY~qm8t`nA*Z9{ zlv4Bdo6P9KApgiZ29ZD*1O}0S5`iEIxF+C?0Dlg@z#tOfEx?p{32+e@Mo!^?n8L%l zb7kka{ipUCwvQBGbKv=+EG0(31CCsojl_Ux!b7F0U$;l(HroOZi0`)&7$nWCae~K6 zq2&PGp^px>F8y2)ocJf=*(IwhfHv*-$$skY={h~AJt~K$2)fiG;m%n%!MF=O2iv9x zZbBjLsScJ^r7QB~9Y(wj95R5sJ9w%YY0QQ4eC>zSOo>5%{_$TEST>DISPLAY>MATMULT>MAKE-HOMOGENEOUS-4-VECTOR.TEST ;; Syntax: (MAKE-HOMOGENEOUS-4-VECTOR &optional X Y Z) ;; Function description: returns a 4-vector of element-type single-float; the elements are X, Y and Z in the first 2 places, and 1.0 in the fourth. ;; Arguments: X, Y, Z: optional values for the first three elements of the vector. ;; (do-test-group make-homogeneous-4-vector-tests :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq random (- most-positive-single-float (random most-positive-single-float))) ) ;; (do-test simple-4-vector-test (let ((simple.vector (il:make-homogeneous-4-vector))) (and (vectest simple.vector 4) (= 0.0 (aref simple.vector 0)) (= 0.0 (aref simple.vector 1)) ) ) ) ;; (do-test 4-vector-with-args-test (let ((3x (il:make-homogeneous-4-vector random)) (3y (il:make-homogeneous-4-vector nil most-negative-single-float)) (3z (il:make-homogeneous-4-vector nil nil most-negative-single-float)) (3xz (il:make-homogeneous-4-vector random nil most-positive-single-float)) (3xyz (il:make-homogeneous-4-vector random (random (random most-positive-single-float)) most-positive-single-float)) ) (every 'vectest (list 3x 3y 3z 3xz 3xyz) '(4)) ) ) ;; (do-test 4-vector-complex-test (expect-errors (error) (il:make-homogeneous-4-vector #c(3 5)) ) ) ) ; do-test-group make-homogeneous-4-vector-tests END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST new file mode 100644 index 00000000..9d68d7b4 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST @@ -0,0 +1 @@ +;;MAKE-HOMOGENEOUS-N-BY-3 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>MAKE-HOMOGENEOUS-N-BY-3.TEST ;; Syntax: (MAKE-HOMOGENEOUS-N-BY-3 N &key INITIAL-ELEMENT) ;; Function description: returns a 3-by-3 matrix of element-type single-float; some elements can be specified in the keywords; the 2, 2 element is always 1.0. Other elements default to 0.0. ;; Arguments: keywords: where x and y are the two digits in the keyword, the corresponding matrix element will be set to the keyword value. ;; (do-test-group make-homogeneous-n-by-3-group :before (il:load? '{eris}test>display>matmult>matmult-test.source) ;; (do-test n-by-3-simple-case (let* ((n (random 50)) (matrix (il:make-homogeneous-n-by-3 n)) ) (2dtest matrix n 3 #'(lambda nil (lastcolumn matrix))) ) ) ;; (do-test n-by-3-with-key (let* ((val (- (random most-positive-single-float))) (n (random 50)) (matrix (il:make-homogeneous-n-by-3 n :initial-element val)) ) (2dtest matrix n 3 #'(lambda nil (lastcolumn matrix))) ) ; let ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST new file mode 100644 index 00000000..ddb2142f --- /dev/null +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST @@ -0,0 +1 @@ +;;MAKE-HOMOGENEOUS-N-BY-4 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>MAKE-HOMOGENEOUS-N-BY-4.TEST ;; Syntax: (MAKE-HOMOGENEOUS-N-BY-4 N &key INITIAL-ELEMENT) ;; Function description: returns an N-by-4 matrix of element-type single-float. If INITIAL-ELEMENT is provieded, all items in the first 3 columns are initialized to its value. The elements in the third column are always initialized to 1.0. ;; Arguments: ;; N: an integer ;; INITIAL-ELEMENT a single-float value ;; (do-test-group make-homogeneous-n-by-4-group :before (il:load? '{eris}test>display>matmult>matmult-test.source) ;; (do-test n-by-4-simple-case (let* ((n (random 50)) (matrix (il:make-homogeneous-n-by-4 n)) ) (2dtest matrix n 4 #'(lambda nil (deftestn4 matrix))) ) ) ;; (do-test n-by-4-with-key (let* ((val (- (random most-positive-single-float))) (n (random 50)) (matrix (il:make-homogeneous-n-by-4 n :initial-element val)) ) (2dtest matrix n 4 #'(lambda nil (deftestn4 matrix val))) ) ; let* ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST new file mode 100644 index 00000000..71501f1a --- /dev/null +++ b/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST @@ -0,0 +1 @@ +;; PERSPECTIVE-4-BY-4 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>PERSPECTIVE-4-BY-4.TEST ;; Syntax: (PERSPECTIVE-4-BY-4 PX PY PZ &optional RESULT) ;; Function description: returns a 4-by-4 perspective transformation defined by PX, PY and PZ. If RESULT is supplied and is a 4-by-4 single-float matrix, it is set to the function's result. ;; Arguments: ;; PX PY PZ: real numbers ;; RESULT: a 4-by-4 single-float matrix. ;; (do-test-group perspective-4-by-4-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(4 4) :initial-contents '((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0)) :element-type 'single-float)) ) (do-test perspective-4-by-4-simple-case (matrix-p (il:perspective-4-by-4 (randmost) (- (randmost)) (randmost)) 4) ) ;; (do-test perspective-4-by-4-with-result (let ((fact1 (randmost)) (fact2 (- (randmost))) (fact3 (/ (randmost) 100))) (and (not (equal (2dlist sample) (2dlist (il:perspective-4-by-4 fact1 fact2 fact3)))) ; before (il:perspective-4-by-4 fact1 fact2 fact3 sample) (equal (2dlist sample) (2dlist (il:perspective-4-by-4 fact1 fact2 fact3))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST new file mode 100644 index 00000000..ebe3ead4 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST @@ -0,0 +1 @@ +;; ROTATE-3-BY-3 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>ROTATE-3-BY-3.TEST ;; Syntax: (ROTATE-3-BY-3 &optional RESULT) ;; Function description: returns a 3-by-3 rotation specified by a counter-clockwise rotation oF RADIANS radians. If RESULT is supplied and is a 3-by-3 single-float matrix, it is set to the function's result. ;; Arguments: RESULT: a 3-by-3 single-float matrix. ;; (do-test-group rotate-3-by-3-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(3 3) :initial-contents '((1.0 2.0 3.0)(4.0 5.0 6.0)(7.0 8.0 9.0)) :element-type 'single-float)) ) (do-test rotate-3-by-3-simple-case (matrix-p (il:rotate-3-by-3 (randmost)) 3) ) ;; (do-test rotate-3-by-3-with-result (let ((rads (randmost))) (and (not (equal (2dlist sample) (2dlist (il:rotate-3-by-3 rads)))) ; before (il:rotate-3-by-3 rads sample) (equal (2dlist sample) (2dlist (il:rotate-3-by-3 rads))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-X.TEST b/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-X.TEST new file mode 100644 index 00000000..a0cfe0df --- /dev/null +++ b/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-X.TEST @@ -0,0 +1 @@ +;; ROTATE-4-BY-4-ABOUT-X ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>ROTATE-4-BY-4-ABOUT-X.TEST ;; Syntax: (ROTATE-4-BY-4-ABOUT-X RADIANS &optional RESULT) ;; Function description: returns a 4-by-4 rotation matrix specified by a positive right-hand rotation of RADIANS radians about the X axis. If RESULT is supplied and is a 4-by-4 single-float matrix, it is set to the function's result. ;; Arguments: ;; RADIANS: a real number ;; RESULT: a 4-by-4 single-float matrix. ;; (do-test-group rotate-4-by-4-about-x-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(4 4) :initial-contents '((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0)) :element-type 'single-float)) ) (do-test rotate-4-by-4-simple-case (matrix-p (il:rotate-4-by-4-about-x (randmost)) 4) ) ;; (do-test rotate-4-by-4-about-x-with-result (let ((rads (randmost))) (and (not (equal (2dlist sample) (2dlist (il:rotate-4-by-4-about-x rads)))) ; before (il:rotate-4-by-4-about-x rads sample) (equal (2dlist sample) (2dlist (il:rotate-4-by-4-about-x rads))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Y.TEST b/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Y.TEST new file mode 100644 index 00000000..81c4c88a --- /dev/null +++ b/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Y.TEST @@ -0,0 +1 @@ +;; ROTATE-4-BY-4-ABOUT-Y ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>ROTATE-4-BY-4-ABOUT-Y.TEST ;; Syntax: (ROTATE-4-BY-4-ABOUT-Y RADIANS &optional RESULT) ;; Function description: returns a 4-by-4 rotation matrix specified by a positive right-hand rotation of RADIANS radians about the Y axis. If RESULT is supplied and is a 4-by-4 single-float matrix, it is set to the function's result. ;; Arguments: ;; RADIANS: a real number ;; RESULT: a 4-by-4 single-float matrix. ;; (do-test-group rotate-4-by-4-about-y-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(4 4) :initial-contents '((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0)) :element-type 'single-float)) ) (do-test rotate-4-by-4-simple-case (matrix-p (il:rotate-4-by-4-about-y (randmost)) 4) ) ;; (do-test rotate-4-by-4-about-y-with-result (let ((rads (randmost))) (and (not (equal (2dlist sample) (2dlist (il:rotate-4-by-4-about-y rads)))) ; before (il:rotate-4-by-4-about-y rads sample) (equal (2dlist sample) (2dlist (il:rotate-4-by-4-about-y rads))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Z.TEST b/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Z.TEST new file mode 100644 index 00000000..c3fee637 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/ROTATE-4-BY-4-ABOUT-Z.TEST @@ -0,0 +1 @@ +;; ROTATE-4-BY-4-ABOUT-Z ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>ROTATE-4-BY-4-ABOUT-Z.TEST ;; Syntax: (ROTATE-4-BY-4-ABOUT-Z RADIANS &optional RESULT) ;; Function description: returns a 4-by-4 rotation matrix specified by a positive right-hand rotation of RADIANS radians about the Z axis. If RESULT is supplied and is a 4-by-4 single-float matrix, it is set to the function's result. ;; Arguments: ;; RADIANS: a real number ;; RESULT: a 4-by-4 single-float matrix. ;; (do-test-group rotate-4-by-4-about-z-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(4 4) :initial-contents '((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0)) :element-type 'single-float)) ) (do-test rotate-4-by-4-simple-case (matrix-p (il:rotate-4-by-4-about-z (randmost)) 4) ) ;; (do-test rotate-4-by-4-about-z-with-result (let ((rads (randmost))) (and (not (equal (2dlist sample) (2dlist (il:rotate-4-by-4-about-z rads)))) ; before (il:rotate-4-by-4-about-z rads sample) (equal (2dlist sample) (2dlist (il:rotate-4-by-4-about-z rads))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST new file mode 100644 index 00000000..843f23cf --- /dev/null +++ b/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST @@ -0,0 +1 @@ +;; SCALE-3-BY-3 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>SCALE-3-BY-3.TEST ;; Syntax: (SCALE-3-BY-3 SX SY &optional RESULT) ;; Function description: returns a 3-by-3 homogeneous scaling transformation that scales by a factor of SX along the X axis and SY along the Y axis. If RESULT is supplied and is a 3-by-3 single-float matrix, it is set to the function's result. ;; Arguments: ;; SX SY: real numbers ;; RESULT: a 3-by-3 single-float matrix. ;; (do-test-group scale-3-by-3-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(3 3) :initial-contents '((1.0 2.0 3.0)(4.0 5.0 6.0)(7.0 8.0 9.0)) :element-type 'single-float)) ) (do-test scale-3-by-3-simple-case (matrix-p (il:scale-3-by-3 (randmost) (randmost)) 3) ) ;; (do-test scale-3-by-3-with-result (let ((fact1 (randmost)) (fact2 (- (randmost)))) (and (not (equal (2dlist sample) (2dlist (il:scale-3-by-3 fact1 fact2)))) ; before (il:scale-3-by-3 fact1 fact2 sample) (equal (2dlist sample) (2dlist (il:scale-3-by-3 fact1 fact2))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST new file mode 100644 index 00000000..8b3fa726 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST @@ -0,0 +1 @@ +;; SCALE-4-BY-4 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>SCALE-4-BY-4.TEST ;; Syntax: (SCALE-4-BY-4 SX SY SZ &optional RESULT) ;; Function description: returns a 4-by-4 homogeneous scaling transformation that scales by factors of SX, SY and SZ along the 3 axes. If RESULT is supplied and is a 4-by-4 single-float matrix, it is set to the function's result. ;; Arguments: ;; SX SY SZ: real numbers ;; RESULT: a 4-by-4 single-float matrix. ;; (do-test-group scale-4-by-4-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(4 4) :initial-contents '((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0)) :element-type 'single-float)) ) (do-test scale-4-by-4-simple-case (matrix-p (il:scale-4-by-4 (randmost) (- (random most-positive-fixnum)) 13/30) 4) ) ;; (do-test scale-4-by-4-with-result (let ((fact1 (randmost)) (fact2 (random most-positive-fixnum))) (and (not (equal (2dlist sample) (2dlist (il:scale-4-by-4 fact1 fact2 most-negative-fixnum) ) ) ) ; before (il:scale-4-by-4 fact1 fact2 most-negative-fixnum sample) (equal (2dlist sample) (2dlist (il:scale-4-by-4 fact1 fact2 most-negative-fixnum))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST new file mode 100644 index 00000000..c4a43802 --- /dev/null +++ b/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST @@ -0,0 +1 @@ +;; TRANSLATE-3-BY-3 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>TRANSLATE-3-BY-3.TEST ;; Syntax: (TRANSLATE-3-BY-3 TX TY &optional RESULT) ;; Function description: returns a 3-by-3 homogeneous translation that translates by TX and TY respectively along the X and Y axes. If RESULT is supplied and is a 3-by-3 single-float matrix, it is set to the function's result. ;; Arguments: ;; TX TY: real numbers ;; RESULT: a 3-by-3 single-float matrix. ;; (do-test-group translate-3-by-3-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(3 3) :initial-contents '((1.0 2.0 3.0)(4.0 5.0 6.0)(7.0 8.0 9.0)) :element-type 'single-float)) ) (do-test translate-3-by-3-simple-case (matrix-p (il:translate-3-by-3 (randmost) (randmost)) 3) ) ;; (do-test translate-3-by-3-with-result (let ((fact1 (randmost)) (fact2 (- (random most-positive-fixnum)))) (and (not (equal (2dlist sample) (2dlist (il:translate-3-by-3 fact1 fact2)))) ; before (il:translate-3-by-3 fact1 fact2 sample) (equal (2dlist sample) (2dlist (il:translate-3-by-3 fact1 fact2))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST new file mode 100644 index 00000000..081e4ecf --- /dev/null +++ b/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST @@ -0,0 +1 @@ +;; TRANSLATE-4-BY-4 ;; By Peter Reidy ;; Filed as {ERIS}TEST>DISPLAY>MATMULT>TRANSLATE-4-BY-4.TEST ;; Syntax: (TRANSLATE-4-BY-4 TX TY TZ &optional RESULT) ;; Function description: returns a 4-by-4 homogeneous translation that translates by TX, TY and TZ respectively along the 3 axes. If RESULT is supplied and is a 4-by-4 single-float matrix, it is set to the function's result. ;; Arguments: ;; TX TY TZ: real numbers ;; RESULT: a 4-by-4 single-float matrix. ;; (do-test-group translate-4-by-4-group :before (progn (il:load? '{eris}test>display>matmult>matmult-test.source) (test-setq sample (make-array '(4 4) :initial-contents '((1.0 2.0 3.0 4.0) (5.0 6.0 7.0 8.0) (9.0 10.0 11.0 12.0) (13.0 14.0 15.0 16.0)) :element-type 'single-float)) ) (do-test translate-4-by-4-simple-case (matrix-p (il:translate-4-by-4 (randmost) (- (randmost)) (randmost)) 4) ) ;; (do-test translate-4-by-4-with-result (let ((fact1 (randmost)) (fact2 (- (randmost))) (fact3 (/ (randmost) 100))) (and (not (equal (2dlist sample) (2dlist (il:translate-4-by-4 fact1 fact2 fact3)))) ; before (il:translate-4-by-4 fact1 fact2 fact3 sample) (equal (2dlist sample) (2dlist (il:translate-4-by-4 fact1 fact2 fact3))) ; after ) ) ) ) END \ No newline at end of file diff --git a/internal/test/Library/TEdit/Hand-Aux/.read-me-first b/internal/test/Library/TEdit/Hand-Aux/.read-me-first new file mode 100644 index 0000000000000000000000000000000000000000..398bc2688fa99601f2626e69c6245550e0dcb7ba GIT binary patch literal 5488 zcmeHJTW=dh6yBy6A#)KDmFVL7o?XTCX?@7%`sLRqkTJPqAKB(=z|D;X`e+ zD@Phin?9Lq8gsDJtk+tjkrv19kSAFz>gM?6OUJ3bbXvxSOebW9$Fb4Q4P5d;d8s=<0?2M-i-E$>o8E+ zlu7tRpvvcoC|E9zg$CgnpAgAlT$~m*Mx3PZOiv_iG6n;bjZry)9upu;C{5YR3kd=< zEpm~4HARovUaPt=MDP1 z_v_ug{zLGoDXAO?775fMB0UjtT(9+k)77-j;b5^C=muI?ji&(AZ+3q@qZyNpQ8jmBFpbq0ru(Y1_HHww?9bjBkhS zOS)tVM(8D%E~I49lVv3+7gJW1C+(`9RtQ=ut@_OV8iI#Hu%*#3!>^%mEq;Q#sL|QmC805D%oV4Af)OfQczwgWMztLXe>E_&8b08*D9e3@1m6i-3IeyJ&%L}`I_ z1y9ZRpKA?`b2O(hxY3_>pYU-30to#IXf9&X*lpPB`^nR;lqyn%q2{_)AX4Jca%@)99ARc*z_q3&O}mF`C@)93 z_`byCw~G}_A4W)oSvfX1yeEix)CR^ZH)}O7&DOUs3pRHGrG|Y|W-(qyg$SXm+VwV@ z3v0}jfK5UAaZ#}d{Js96_mwxWd+xB)?OK-MDCz?`$rHBM?GNE?a74?@EcSv)`=|(& zRfo**WgL>~Nbz#Vl_Ae430@JkMP92v}K+hCL%g)RplI<@cV~YIk}E?gP(zBO4@F74zeSG?+L%yx_tVd@%F#IV2(H?6{y?Mm z7rjbm?*?|8CWWS#RsM->P^0>rt`s8$1JA#>^K`N4@Vo*z5FsKNO_8m6-OL_jF*?Zl zH`Xdy@R_`;*P6|gC!*1)x~16+MIJO7Z{+_P511Y1<-RTtulL-c&vpE3I=7r#SAKV{ zlHlq!629X==6vKhTaMEp@%m2_V8ERl1i5iQb$l`U)f(JzK)CZA3BVmbR`3D+N&>() z<|lOJH#)J}EVM>~^Pn5wE<)+cr=?vh}KPG)8<34M?5UQFvh0$mD==sZ6x zV&EpZHVf;L(DQvgSL^G6Hp%%jypjWd(8*$0CeHJqBwL1lMuKypKdnN&wb1QV=v(Wc k&f9OGZy5MrF+h#;K6!Me3rMh3um3p|9@TzvetrJpPi}DE;s5{u literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~1~ b/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~1~ new file mode 100644 index 0000000000000000000000000000000000000000..289059a628a396ef5369970d114d5820bbbc5f0d GIT binary patch literal 3981 zcmeHHO>Y}F5M|_i6zT_h2#_3k$f1W=kX@jMLRi4@Zcqh|6-Wydxdf#|O3Q#+3M99U zTJ#U~CnWzNr~Du14Oem{TPmz11=7N6Ly~9Sym|9xixBu|e{kF$R7 z(UaE6aqlVobe_~v|e3$4lI?JJw!`ggQQOby zj*{ZRD7Pl*N+hdF)=6+K@vIg~(#1VpFlgQepOI!2#@*!=-uP=8iEMC<4`nJI?Ea)<9`!cpI;W}O)>*wVIqvsZW5_X^6 zzwwUkQDE;T1;1j5u?LK`8S7AZ`;!0+IJ-@dy&E4={Sm!uUDSW~-Vf{I`n3_KUyWS) zd=n1cWw)R9(yV_PX9lFfR$^bD*ZhrxkMsanzum$cr;l~R27}@37Ye{TJawQ+A1MHM z<2-|s#tX{SY>mkA-D-dm_b70wmI8;AS=R0d{f26<#`;O1Yh#f|Uu+aWE`CXw)v>d((+uF$b??A7(*d1=*8hY)(|I`6|FYml%Z+?IM9!*2a AuK)l5 literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~2~ b/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~2~ new file mode 100644 index 0000000000000000000000000000000000000000..65255cf5237de05789e50ec5777b4de9ebe3f979 GIT binary patch literal 4677 zcmeHJ-EJF26y7Fng$zYVRHB!2!37tw)gR5w^HSXIXE+A zQ7CQA0Z!9Qagrl4J(uvw7#vVFrsW)VT!L_+G*!=72?7f(jL6}_ zs7x%2S8&beniq+IQGlj`K`<9_x?txe6kT#vakZQ$&?iQmja24qK}p{MshHV%LYPRU zWtLNCa2LP#ppa0?3m2?2xDNK!DYVR~d=*Ka6c=7DK($pYRXk?h&hVr+9vwez3{FO8 z;8RmkIU3foSj=2-M2XBm9#hkEbf#gYfr%>CSVd(9PT=+>cy}&%Y7|@g;c<*c9``3` z{mJt|=jG{W7hc<3L^8!wH6A7 z#Qi`~?I`+Rx*Vtal|MrbWh_`C(2L0QQlx34HUdspYL+^m;}n&xMiewszkgZtmJXZs zsM+XBQ>1)B4y%a^;VgE(SS+b2GVc;x9X1PuRRt7#&84-YyIVWjZOz5@P4|u=xrPyX zBcwMnvL4B%5wweIt16Oi)lWAF+GwrD(*F*ECql4|)v(0xpl~OClcb$6XLd!yF4&Dk zZ^NE-hEMzTZtwWTSB_ zsnaF5vF$t6g;g#g7(p6Lx82bO)j~Cq7Fgn|H2vZ$v?^eD0TND2P1$5h3tU%-)UE%O z)z}3`dm4)y^XcysKC>Wz(650`5u3)}hQm>a?M$}-Xrp@%fs}caU^A8lv6HL3F0OFN zbGICiX}7_k!RDb_CA=s^4m91e61*)JYQaH7t=-OfCR(kk_U(2oOw?++@(B%xsUa%&6w9@Er-j9Ud?Em_CvK@V(Uusr*JK-kOKjNU#mM_w72AbU#}ckd04Ba7&j2M|84u zb4Tchr2A%8{}Jd$T14mew1|Pn6xuSaJ3_a|y4C92fwn35Tf9;Lf6&Q#S}xCRP?Bvz p-y^{`Xz>0!=sO1f2Mo~Qd_;NPngSAROu@enMMRH&4u1XN)t{V}#Do9< literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~3~ b/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~3~ new file mode 100644 index 0000000000000000000000000000000000000000..398bc2688fa99601f2626e69c6245550e0dcb7ba GIT binary patch literal 5488 zcmeHJTW=dh6yBy6A#)KDmFVL7o?XTCX?@7%`sLRqkTJPqAKB(=z|D;X`e+ zD@Phin?9Lq8gsDJtk+tjkrv19kSAFz>gM?6OUJ3bbXvxSOebW9$Fb4Q4P5d;d8s=<0?2M-i-E$>o8E+ zlu7tRpvvcoC|E9zg$CgnpAgAlT$~m*Mx3PZOiv_iG6n;bjZry)9upu;C{5YR3kd=< zEpm~4HARovUaPt=MDP1 z_v_ug{zLGoDXAO?775fMB0UjtT(9+k)77-j;b5^C=muI?ji&(AZ+3q@qZyNpQ8jmBFpbq0ru(Y1_HHww?9bjBkhS zOS)tVM(8D%E~I49lVv3+7gJW1C+(`9RtQ=ut@_OV8iI#Hu%*#3!>^%mEq;Q#sL|QmC805D%oV4Af)OfQczwgWMztLXe>E_&8b08*D9e3@1m6i-3IeyJ&%L}`I_ z1y9ZRpKA?`b2O(hxY3_>pYU-30to#IXf9&X*lpPB`^nR;lqyn%q2{_)AX4Jca%@)99ARc*z_q3&O}mF`C@)93 z_`byCw~G}_A4W)oSvfX1yeEix)CR^ZH)}O7&DOUs3pRHGrG|Y|W-(qyg$SXm+VwV@ z3v0}jfK5UAaZ#}d{Js96_mwxWd+xB)?OK-MDCz?`$rHBM?GNE?a74?@EcSv)`=|(& zRfo**WgL>~Nbz#Vl_Ae430@JkMP92v}K+hCL%g)RplI<@cV~YIk}E?gP(zBO4@F74zeSG?+L%yx_tVd@%F#IV2(H?6{y?Mm z7rjbm?*?|8CWWS#RsM->P^0>rt`s8$1JA#>^K`N4@Vo*z5FsKNO_8m6-OL_jF*?Zl zH`Xdy@R_`;*P6|gC!*1)x~16+MIJO7Z{+_P511Y1<-RTtulL-c&vpE3I=7r#SAKV{ zlHlq!629X==6vKhTaMEp@%m2_V8ERl1i5iQb$l`U)f(JzK)CZA3BVmbR`3D+N&>() z<|lOJH#)J}EVM>~^Pn5wE<)+cr=?vh}KPG)8<34M?5UQFvh0$mD==sZ6x zV&EpZHVf;L(DQvgSL^G6Hp%%jypjWd(8*$0CeHJqBwL1lMuKypKdnN&wb1QV=v(Wc k&f9OGZy5MrF+h#;K6!Me3rMh3um3p|9@TzvetrJpPi}DE;s5{u literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/AR10063.TEdit b/internal/test/Library/TEdit/Hand-Aux/AR10063.TEdit new file mode 100644 index 0000000000000000000000000000000000000000..47a3bed44b3ed0539bf720ccd0470c16e614c3a3 GIT binary patch literal 19832 zcmeHOTW@36bw1K~?2vAf+O^xbX_8&HsYQfRMwc1Op0ofZQ5rV7ndErJHVpKLJQ9!R zkcT~oltw{OppSWKUz(!mTc0|Epa{?afd!AzhXQ?V{W}WyCrrO@?aMj5=;C_N}rQDb$|TYQ;Pyu9N4xxE377NuW;S zp&F)v$kootRhFK#6Az=dItW^EH&BOuH;h6*Q77S`BQw_hC<>CuKTzqw@3sA;tw6Qw z6CTy`yFpr3XwN1j!zf5WFN#kVl)Bdmz(PMx)9@e)%IYLg9UsVmp*HDv)gV@#AnL2G z|G@AV9EQD+^iu`yl0lHj3au#clOQ2cL&T5LScSb-G;D)f+-mtLl@_VsFNf$;al)tY z*pGtVASK_b1#!r6s(f|gpQ`v!R;S*N!xXc^p9mLSEc3WZGH0qA_+Vww@dtv4-x{D< z^?e{j$q$1dQs7KFQy_9%Ja*4q1YJs$$*@0S_P!Vs^98}P;X$U1I~g%DWfnQP)x37^*~)}Qcjl|9ubllLHq`g z6`_&<#Cx&e1#Jnz;5bN5bC%!>6Zq59wAEn}cSYUpxcA0DFeD42?*olh+>1`9ae}os z;|TU+z42%mwu30_S-XO~huub4PDd25r>vYf|(IA39ILlZ5 zaf}7p3&mfF`=(vmJW!h?0^_A^2R%U{XiIE(>UE*fuur=eprJO0E9@Fp)@luDxKNx5 z9{ODjEvt=KHGKX}Xe}@cH8_dkff9t;KEO{>%&Cd3Sk0AHCq5zgWpNz3l9{3LX~$5x zrEIt(Hi1~^3Je26fwbW?PzUgtR>tnz#e#Qj>Hea3eQsAZN}eZQSGAz zVU3duo0?@|psdn<6vCQg;(JmoI9n~y09RBRz!QPen4ExKhYE~3Rerx8o$B~Ri?Y$n zEVLdE1#3FrUJK5t?hywac(5?S2cm&k#H0q(+e!rsM+;@O@27w~7ROkJgTa7C%@=N% z&=Mk8{xJ{(>^+Q*hetXz=KQT42Pw@wg|gH5ZKawJc8oWX3i}Dotfu|(Bt|%WOg}hd zFXCGY4GBl|GU&L2CB;whlxZn7<|oDlZ(=lssqFOv?S@e(u@rWQ|LQ^O6tOci2ACs3 zqfjF;gHArsT(*2fYw=;LsFnsj&pc%1-qMdi3^-CtCJba2EkP4z-HLmM5jP)rpH@_+ z;{;Rvqkz1I-F_1HCCHEX$}qLDfWb+v`|wU*H9CGfKGAHN@Zh%|ke35~wtTR}5NH=C zfC6sNYo}UCur>I`0jx#hiP_8oM%C^Ri*$oPhh}Y0vMqMVXfH*`Kse|T_=+CGV6G5= z;M`PK5*~F1^E%AHxG1)>0j1Ug;m<`3%OvMwry-hflTk_Y2xV3Tsmy*%bqGLQULF{R z@zg`mQU^)=0Ol0-X!OvD+ghdsI=dZcGTIeoyAGE^5Q+3h_0Tb8c4mlp)919!a z!!S^d!70SYY+rk8=4t^_4ZtIuny6rmjT?BrnF&bHm7sX25M%%cg~Z-}LObdM6oX9wZt%#Q=KkgC49%OOs(qLAi+tS%;Xo1chHI8Cfg8+7%=Qu<2#P1DYorcz;sANbaTp`SHg@>CvOT9*{NiB8_N0 zzy>pI{KCf{k7SKxA)hrG0k?u)fZ(U<%;ug=Qv1{!AzB>$wu8+Xc)-o!v2e*KID`{$ zw;DjdCMaeRmqxG?rvq*i5P_jbGBBAh4)j=3l!Lf^D*8>&)TwsmQ}G8eW?v!P9L7WJ z7Xi|&77`_GMl@(f9FsSVuDc!h$2uIzYKU2gY$2j`f|L-JjO7uukF-ZDJ03jva#d1)hOXG4OThc9^yohv|)CwVWHdw<(if|I-)-hz`jx}I> zYPGP_fLp?4Q}7mYEQrjp3|5l1i?{LXI{ix0{@e;W)A!qwZBtYU*ii@)2S7FMb^)Kn z@`a+=t2cBW19LVF#zD)_Ei4PE0O_1i6dhJTtZcV6ngpmGggt%S06bmzIrse&oK|`Z zMUx7Eym@*?bn6nj8*(;+M(G7u0~tz>R;8n-mQ3uf8*77zPk26(-9zsenpFmhOitpC zy~9KxiA}Oon1obNh20~&Weh>0z))=#Gx0I*BOeTr=C+YH%1JfV+Z7YdKK)3aEPyF? zbYs(pQ5-XEWP-&o2UF8K6gM%|#hGhfQUa!kdhup%<&zFVH(bnc;8t)Plo^MxacNn6 z*cy+9%zl|wOk)h{OL#DZpIrv9S=Bg{?6YoRu?LB%kA+_OOdGVQP-N5SDQF477>+^a zCBA?jEFO+%{G5&RxhZfKh&?h-i+2zpQW?h?U&q6s2;cN$R2_8 zM#sRBC1>0t<&2BX8#~qXgiQ7sA;`@}^qZMWn8-0E=<8kIhb-_LY-^`^-RG91DZu5B zU&FeH6B#yf$at)6g&!D~IMQSW->TvoGo z4hx*Za;BckIELpmnWizSi46*jl5*-?A*TnEtd3{{nGLUAuU1DZH; z6<0GM1!Bg^U0vIH``wE-;w78PKZqc*LO* zM@xb(42i)|<7#6PEoQ`=ohj3-B=OA|vrbv{Hje0RgtT^RJh3@MZApAkLb|bXnS=;o zHv$^5b)jiitZRI?MT^FV+UkLvy$|)_5*vb}#$=rpf!@N~Gz$oeH06Ws56fyTeke4y zu*-i?M+3?iIGe}PX-gTVL(+LUxRZTp)Ha=&y)=#vk#8pM>ttF6)x{fVPvU{%3e!5= zQVrAtp+EOsJ8rI#;xxFqXJcsNJ5X#ofZBN!gByx%%SuiY@=fSvO{AuC_>48_bu2qh z)`v+H&dc^Eles2#*f)?e#o&wE3yAq^-b zYXrXZHl*k?j*t01rW<5YD5(frlu(4uwb24Z5H&V0-#94-ajra!0%4~f%NECoG@U*5 zC#w1onKJ9esSME^Fk(8+*8M@NBb}NPE}=z|MjbkJ*Q&H2v<2MJbh3x zMaT~^WueFjxk=z{vT&ScQ4{+_)17UkMuCH+RL_orfs|5cO?n%$E*|!dR{i!zERIPf$(J$-Z&bj?yAQWD{uK{dM~4b z1a#TS1TI+trl3*@wfYol>|9or0uOMQ*GirTjd`o&u`3nuK{jM{(fB#b%4V1%S;htn zCG)~S4mhm;_cf^Y(3eB88@AhkJ6{Kwv^!knNVJ5fW9!pCjwQIW(1vin6vXIo*d$r4 zz>$F|qs(G91fM{5PABBv=~`}^Ax-3TDK3rN2-{!>Al68^n_)6fXrviPHKB{gvh0~< zi(Hu^FE(@(DNXGS_P9E)V^CIP4yg9ku*Upd!K?; zuo!{1FyiE5oFPukgJTlrqH}H&hF08JO!PYQ1tH5pa#ZDVn6F_AcrXA>ZaKh`b5q_OTo~b!7E0=ty415{vB{5DnYs|K% z%nK960&9nf4HQO7Ivg;}Rdop&F>_jlRjWcwF>h_fLT52pZgmQsrC_nu!Pli=giX%mWeK z2+~#(_6K}#p@|5cGG4pN>xL^zro~N|32rM;TMPqSC9Xv#_ zt(M%_s;a7c_-8(+jUBVXFEZ7Qow)j)#?tkA^G>BM7sU->i>%2V^5p1IrV8smZedt4 z#+~VqS09(6=`%gjr(7u7#9A8`z678-FbV1x0rUz}9iZk8U33g^r!7(>Jhhk*K1bAO>L32m^r&DSoZuAr|5n*LGF*03F# zlY?9;@Wp}_??0HL$!i9#%&hN@=vC%*oF%U?2NabcS+M&7_JJ2RYL%V6-3|1kyoP?5 zVF6yVq88QiXg~Te0-DIr$E!Z1EtK`#Wz1Ze(8_2sRB3;NSS^>-&D<3cx9HTzL0;$l zj~?NeDC1~JlCtT-Lkn4lB&PXdfC!J5%;ZXxsRf`;``i+s1`UV_M50(|luAv8ETcr3te8ZJL-7OjB)^r-$4sm*hP1CM%&6gZS3;<|7N_=E5^8O;X|1AD>{p10h zuwqS4S@9@uCW@{G2*+|I%NGptBXubwV}$1yvuxQ};F|EYE=x(_Cr`l~vntwfrHqqj zfMLto1>Vw{+pTSb>x#lBP2x^{YrE2Dcpmp^blG1F(V4{(x?Y@Hla7j7hl6ftunKo9 zPz9VKu9CT;s;1#av@-9g)Z|4exMmVOt9QfXW2X5%)HkN9~dE(I{R>@hc!faT&q`-3ILRQSekwE}c4FVm$Ps#caZ5(@O@DK+o zbF9TzE{rX+jX}XFD|5gui}YrIEPy&PDwN~{@BC>MX};xjXwo6M(>1->!EgL!Hv5hz zERk-3RU0AhaQuX4My$CRg?-`7nSfrYkC+JF>qCIZSCB-BA0Aco^8Df9kdIP6OVW?1NnbDL3Ns7KMdqq}#zSPO0!h zGhV=fJL8St2Lu_12{xg{L=QQ;@U_>mWti3@HJ}t0=1~zDu=F9GbwC`$QA#kcHXF2{ z8SL#Y>WqR-^-mwCFET-I8q%CLogcG@taz`@?Kaf@9sY-h+;a(Ci!KiEtYKrqN(luH zukiUhUM_IFHa9^*Q!9C|N<`s##Zthz1p$O7w)BUBN}*8cDQ883V@_O#LW#>0*jeHD zMl+9MK>3&j4%W+jYgSUyfh);-H0M#W^#B<)g_r=gf_GqxbJcqWucSO^g)nuV zX`OL96LBV&7dB^ex`;XgUPkS z8qSn*o;$LoMI-~BcWrLF)@Z7^x&6u(*Z>fC+OO6dwfC#IY~cT`pf>lmYkRfb%{^RM z)GKSXb@lqw&%giFd)Uwh@EHvf&etoZrhU$jy zC8xL4W@V?g{hr#}Z`O7yYVX}@eY>`6<~QrLA6NJ8>e+X9H*$T|`}>vMMs06b)vH@~ zw<~qk*xuW(s#>$M4MFc!Yg>1kYHe?OgG^QHcGbI$YF!{9WR2!~U=>d#U{&9#G%o{d z@y4oJzNMB{`BBm{=bF{~O+iewfNqXhyrFKc+?YOO>87TVA464qrOK~V3Ge*MD}RH$ zvV{Mw20z!mm%Kldr_bcCcWuV|(RJ_TS?|uQ_t&%Dzs}B9b;o&sH`y`s3*C*`-ptG| z@K=6br03tMRyJz8TV8=Lkm4Qacwl<-A6KWsEbKfg^Ldi9mJ8cB)3i_W$-}4Tedf*b zf^A>;2uV_e+P>U(79I(^y74y@_P&27Z^8Z=l@4 z-^E)i_~gIE8*kw|hUl-$@|8oD5NOR1MAWQTKiyni)Vd=V{K?6c=Ws@I2vy#g_1+h4 z{>!hQ!+#Q%Kl84UadL?NX1!?E``NFFH{nPAY~k1rk35n7tr>t=HC9|jd>h&w(6Cgd8V)PlKXj#YF8c$O7kOhU(b^`e^Fsz5BnO5~CHaTQO<*LP~W z6`qnxg3bj(%;H#Hodg*U4n%*o#m^_tgh$ZVhL~KtQ1E zT^B@z*^3qvTe#v_(7peERl-F)fG&S#CBppy9}D>X0bBU+s%>Ed`1KZSgBv2Dkz+Z8 zZuK2LiYKGtB|QEY8(!ugH2gOHzQRX7uz@3X`DjOw)}n2=ZiaaOIMH&$wr~g)D{GR< zH}LpPt(U#EKVR6YHaBGjH{ka#8?a5eaG#uIK&DB9eCel z1Lxf1L%v6FV9)+|&+oDUJu~l&_i(sS`_J(nJI6b-J(i~#F|ORoGm#xa*~z4Ia>1>! zo@=dq17%TcAP~Rg1FIOa4jyLyd%VT_Q`^FYFndPO)TIw;(C~oV%=hv`In0vv{?_)m z7TIO;OY20!(jA%oS9Z2#VL9JGLB7j|7xBw4W=EP8$plj!fo7%m{Gs2<&z){@;=tCN zrdu4ja7Ia8-(rI(-Dv7>*pSnu_tSg>6(nZG{aYM|-ayGoS^Sh9{ez4A^hyH+Dk}>S zdWN*;FXK+U&Mr=o<(VRH;@A1T6Pf06p~zPnAR<$DE-)Z@?cY!N<*X6$)4-$OqWU!!c_zDQjha3RoF8gSkcvY}dh$*%Rm znSa2SNqh9~FY(_-kLh9f4@t!iVf2;F$%bK= z{H(-fYee*cpL2?BUs0u9Kz|QTxfixIl=LNpwV$m(|6QY&*9h&aLYRo-<&e#QV<;( zC&k(nGGx=O{6l`r<1R^$#ofg{3VdOh=Kvu}5FPcU%a#|@w98|);U){?b*-kKh;16K7ouys zliG75TE%H5{3sIfoiGN*#A`ItEKVLo8Z1`9I!j-QMeIlT@@K>X7eO{VX*9xA+$Uj{ z1?vh&@xBw^Chh;RQC%rX%tAvgweu}R`Z;;&YuNaU{#mUKA}?!q+`57)&)KZ@}JT8NDg zCU;4^;=3e{Gm*u7O`K1Ju-12RvhvA&f}Bg%!hK+tMsb#6g$JDi;p3CtgY;noO`t2i zRvMAQL_&6bEwzAaNu`vH0T2?z&yq*F(XFeqdU}P3R119%Zk_S6L>X@rWc5cYsb1{$a*Sx%l zQ67}QpDhd9#3INtibI&eFQAykn^3w)nJ-zB3ENcc63>7@_J*RC{yI2FPXF6=S{f2E0CWQ7%3XyJ7w&7Sq!a zi7WyUL32lczhVJYDQ#xvh}HFUXgJLM+8s|!Ffm}1QkqjtE-CGl*g(9Fo5vhl_6qq3 zz+8qXMdX)o%{eDI5bKJkN)D})V^MoP46l8)jLJIjG7&=QmYVa@9>^>|HmyW7F`aW3yU&s>~pI zgUpg;_#2sXwq-ii^;qMJ1XT%@IM-a`0*@@;Zcw*G6s|(V5gD6p*T}Nyp$;u9PR=|n z{RlmZEM0^ja6!#$j%+U+5e17}X8sIIq1bjNQ5z#vTo(mg3!Ffu`J6q*E=6rpAtkq? zo+1#xO>m*3CB%GmJq7qr;Zx*zH>MzAHH#gZ;kHsqR*JOI-q0oR;6i_OC zx9FZ|b1+}!izLekCkX}I%ZrcS}v%>Hw$II1NDw( zFVRAv82Yju-l7qK1F6<(HCFxtE>*}wx#8?msZ4cf=5NrrqwohfMTjD=@aAs2meUFR zgd&!1f?3E56;#QlqOIZvUC~b#+kC>wiytGSC=arxtvGu{&uv)FD*#k^Huy_0Lo&)< zCr2Y8SJcteNOvGXrW|9C6u>f=dmB*b;TKr~Eypu$+Zvco*JS9VG0CJgL4-UHWg1CZ zU?302Du&sMV2#Np+9{?dwOaEeAB<8=c+}yt0OMAKo||C6%I7>Trj)ll?cK*oG)HiO zW#m~(Z3{`B%i1g-(r^X_J~@_Ju+)i35eXj1cBe+RBp)0La<&Rch2|Bk=JSu3q1V7l z3}v( zKnQ*N4{Ro{V^AdIe?LsW~pU(e74fZh9mH7}gkHs2Y zQjP|cLs1kW;bs9C>=H;OIrviPxW4Q5l!dZDGrSn4Bp3ak+^?aTZx>61V+-VAM7u)* z5VYj9HV^#yuj?l@O{?`S)9y`#Ruf`k^~_1%9tf{qv+zuB3tcqDrD%&Qp`Qv}7kX3Z zXF_iY{aol5LcioiSE6|;npoQuwZ7|kAQjrRX}>l-t80i0(HW2HqSkT8J#)-_A+7wU zHN|QD)05mGAMcHt<04=jI!))Y_2LB&q|%pK^XgI{BhJq2h=(p5%jS=EChFvF2%=K= z;zif+3W_tLXfj1}pW-a17?}k{>zrkrl8iIS9~cpJp#d&ZPAjJxy3>iNB%PlUoz9Y4 zrKE!BJSUns#!W%gx+0=eCOSVrbdeJcEW_~{UDNTbk=ZNAFWMl#V(Nt zP`ng&44Re;7U#s`T&f`9qd}FcUD5(X?$8{J4M$;#*c1FD`cP&{6E2ll1*M5GvQhL) z!HipWHHy;#LIo#pZ02x)xEA3-5>?SuNKH<^}5%34QiOQnHd|PR%z%;S} z#e%e=rbLrQg%ssfy0@TKu&Q=A#iU69xs*^Ov$akH#*IJeF;W_xFLniPvSrl~YpQsNR^y z$aPdN-g#AN#OQeyu`Gfbr!O4WX;jtAXI|Oln>eof_pJ*)qSkc=;GP4(|5XcXo{44) zDEz2iM$5`h#zpm0FDo4K@x81d!Nvcd>QE=e)^TVIa9AMYtLax~tD~Xw)1!WISW3Q(cM5+vS zQ0TkY1r^u9y{=kNsq#0nx;G8uZJ{D6C8X`O)Phd6)Un&WQL;{{$mNXSu!IJ>+yR9ZqB_R6u6tvYgnJ#9yKE^^p$bPF=IGjW%ti+c z3i>ALEKvd-4hSZEy%-v!g5s1^l^8+P4^Sv%4b7f)V-*cuhdVJs$eM5nUDz0PE8aXM z%kpASnb8W%u!+iN@@o^nnc2Z@+x}I@)$fZi;Xw;I? zn47%M#9kCTQfyCo?kPqnIfn7XxjVQ*?*nsD^T+0*J-z71K{{3BV;BrhbmA4xwvk^s zVdQQ9&Tjy8l0$~7Q?ttN21Rqh03=x#+kAC)Pe)O7YP8(0=p0s_7ij8~lX&0ZSPOFz z*73$({xXN(`TS%hk6!3UKRQ^(QS2td8F9FtAONR#zx2LisObj#($0Dx|n!4`yTF ziVL9N@~VkDjj0vqv0snHX(H#Em)uP(YM)cKpql*D((*2n`R%Xw{0tPUn! zx8D~Nl$x$Lf-)Z8V-WW6!0gGlq%(lmH-?t|P7JXzA3MT*ZH}=`$r+$K+?eiEl20A1 zDBhWGM}{-8FfWhI!PGX!Vq&{EQ&e|vOlxrM2`WC*At`2#m1JzG$Lt`=&58F8>Jr-F zx$)3|cMiIaw{jSdFGRE5#+TeV2+cF!dS#O9Xq}f$(K>62i&k5%se|+<#_LmjKE>x# z{?zMru71yszBp?0mHhM7)6e+gOH?h_b5LAx3|o0$y{yt5J$>>M={{cG%Ut*~e1Db8 ztLjs|Zd7g#uYKYbOB7>%@E;gg*D7Zfj2>N7*D41+TC#Kd`O(jges%P0V4xWwF6v+L z=qvT4T$Mk1dUW*rBVFs6ePe2Sboh-8g2s%{4^Z;tC8{Ti>v(86_}>!RfWQHcUrHhW zJ4fR4^yugK`wP0Hs4+%9r#rm)+2aSaf_pMSVrMCl{0$#a$-j8;bouzf;PHd*;|C|| z!5;UW2MjP;S}0PH`{W;r38_PhaHP}BO8xRwJbpgZL*dt-ym9zdLIF@b`ZK D(ovST literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/DANCER10-C0.DISPLAYFONT b/internal/test/Library/TEdit/Hand-Aux/DANCER10-C0.DISPLAYFONT new file mode 100644 index 0000000000000000000000000000000000000000..f7a00dde5ff63eb06866450e3c1bb61c9c6ae422 GIT binary patch literal 7040 zcmeI0Ux-}Q9mjt&_sls<O(8WjGx~*b7t>7Gi4Ja z;zRD`JNN$noZs(z&iS2lW@cteO4aKZZrb_nA4>jeH%n6bsC2v2&5E4&OnI%mCMB7A z`6;I>^I4ZhL7qmFw-@BWpy(gTCE_)5?PEFQbIHR8F$&i?xiB1ZZahBoc=&p&kJ=k4 zi{TDe1vxnbS=*nfe?FhjUkT~ST#V-opW}RM|Fp-2D;GZ=kF%9E-*|sF^2hOGe(`)v z^3RXI+AF#K#r~VyOSCV}$7cLD%a?DTz^{51{Nj3u>p8ZcuAJZB>$&|}Ct&Gc|R}OoB4RI{nV&^%zraE%x7|W*YOD-fq#&zxBWT1x@WK_NVPm4cb*Pq&7YUGzwUf2_;2h_nB|Mu@5A_n@h{37-v^X`{yb0EJ7T$p zCbZZ3$bX-R>m|g~ZjP?pe&lrLpT{=x^LU&L7)-{^I!;pNE^t)v@#Q^y9_j7xPtqRqk+kS$7eCO|n-a|CqnY z@lE(GRLjX4FZPe+eEUiMdAmRVi~M7LdH*<`>t(JU!hRk4AKOn?4*RvnYjTgt;r!x! zQ6HehYpNo&tXa&w=N` zpTJ*023`Sw18d+-@HXg!_rMA8AMoE{u9Gnrk%T=f*#a&Emw?N_RbT;p58MoX0)7U5 z4(L;I54acH4=i{DJPMu!PlF@iMQ{|n7U#^%*x{V~6Z{*%HK7&^)oP}|1$o~u(>vT+ zfEqPdfF0l(a2>b-d>{M({0Q7Si8uP&RnKz|xC{IO><143YQazo=GTC6HIDd;+yd?Z z`@ntR05}NXSa}c}2GnciH{f@Gxv#*jLTy%F0k4C%Onp`!l2uueCA(^O+C?$bBMthU zShwhAH>T}LOH6%A=4H1{ZD!x)rZt*HdDr&Q?6zOC^I{rpIS_ITBbtVhxmX92MOn2g z7A7vQsSl)h8 zGv#%s&v@@ihQ~T>j%XC}tr2J0>GY{OZ}qx1EoX*SWuVp;H*aOW9 zM~QZ7@qMuLRr_Y@9p)yC{6o?~Gmxd+J)j<9O-E+&o6lO^wA<%SyRGhgW*QwLMQwdF zyOeR;CG4g-?v;y|_Iv$an!0%7OvbCEZW+szUd{3)p(^|}W3(pp_Lr$?%`2-_xsJY? z=^0mzUZXYdve&lRcBZ}QWixi0HI0kWM=k4huc0rinTypddX1vhtK#C(m)^RIS8vK9 zwVvZq--x~w8_XM?*!>{vw6GC z?SN9d{Z7NaMKo4Dt*1z?gPS=;SCK`tkaq-m8zpY_6 zNm$JXko+oA@8hf@@>X#M%(nOOZsntobDUO=|Gy4PgT5Kt8#X?N z!yciljZ;a_Gj_-Ch_1)O@>fPNLvu?0B@1?evunZbVI7!8Le<}C!y0v~!Fg$1jl9R5 wj76{aiKgdlhkIkCy0&nDlU>SItmD);MDD}xK1wzDy^?h+DXX^6>eY4nDca&a&Hw-a literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/DANCEROBJ.LCOM b/internal/test/Library/TEdit/Hand-Aux/DANCEROBJ.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..4e3cda0a9379d078df198dbb6da229b4f0a5dc21 GIT binary patch literal 15068 zcmbtbU2G&*R_GKGvc|E^ z*b~nmDk5n4d_F6-HtqnA_#UO% zLSeRSW*>bNbGB6dF{q1DxiUR16n5gyJ`l{+y{^cdfaavgU9~&i*a=+E4P3jKult>r z9k{-iC$3D2R}Z#d-`#)hHlq%ZSy7x?+PK9uE`q?bmI?Yiim20*3WJv8t>hP)e%Gmc zcA-!(#cZvd$+@B+dc8@JdMcGl8FNphQr|zFHbzsqqPXUI-Ib2hbG@41o6LA_Gm|?B zngrAqGXNyoq9WvqF4|?$oA-mjZ=qche%LMwzu~xxjR5_Y2%Dw|oYer*fbN25*{;_U zj3Ds41=NhW>nTEXY~wUx+Q47@dF8WrFDt~;Y2yQZh7YOHr#W)bH^#=!`XfX4hj&Je z^-*-wL0@YA?`MDIk8bg+(OUlGNv!cl((5CK|D4L11z_P{b$X&|CdnbDD+3+ns_6Qi zK$MHZ4g!0j;nXx8N;859-xI~^z$$BIu%jUAO~+dd8p51D2FWannnS=PXwZ7m31oYv z>vY;3zYS3?SCnWS=Xp_5Rk1W=Cn=!RW6jJ0xU~f0Tf(h%@iaxKK$#?zUh;AoXC^*9;>yv~z`+WuzM5z#J$`Pg_0b=}B^C3SNfo2z_A{lka9Z`CbZN zCBitbHO)wxRfVH4fvwggjBBB#Q--#Jbf73t>)987Q=4a z5BS79W1;ET-b#Cl;CElZ*%dzdZU8&jLPuGG>Ns5|2xnE$`J#i-X@z4K?HNY9E~CahAcgadj3^*dfb9p#ucfdOwxvyFiY&!j2SqUkSy zH|Yz*BPj!{=v{!=?@UbWOsq_7KD7@6&=UbThA!&pWsi(cw~R4!s5fHtM$(%j{mp0l zy-}k#n%*4kZ=UP-CK|@o{{)bad*i+5dgmKy`S$V00qIfi-1mCt2;h&K81$Y6kS(C} z=^yv^wvUWm-QGMhUefKCkBlq2y>(fd$y;3)NpZr?si{gZD0+EME7bob`Ejc9i-H-G2Qj z^(VUh&7;&k-G1XJ^&M`1x4-x1;hWriyZ_4JzV1vPZt3RG;hJs^A9}iZ>Tp3fPan?c z=9xoze1JWBnC0HT8Rtj*uy6PGZhpJJxADP?r(p(j50;kq((cGJ>7n~W-#+@{=^d!0 zSt^T_sRj1*#TmAOfe#6UWV)*zNGJrE8-;1n?zo;Qs?&N_71n{qU?cfy!5($nB(M;F zXhkTWWUH)#P^wcdKuh2=V02ekMX6d6^G(}Z7NwbKfpSZ!6%KQ$$+GG+@47GHM5;8QOwRJ(zPN&c=- z6@Y7kUf9N*fscf476n48iYd@jstRm0NGPlmIoqp=oTjDUtX;L6D~>dX$^cDHo@ni~ zSyyxkx&dM~M&`J+Y6CYx5#VaW?UIK!$xzW#8!u{CgwGsBv#cx>nkBKi?0`;aDmy;! zuhN_JBWP&TM&SXNLnaBWY7_(@jBsmke{Hgr9Gp^25!!R~lZAybrH~?S1>2%1Z5_oF zY)L7KV2erqi@l6C)8xUl+ktJgEb)SLVKD4oFh%gmxWgGm@mq)jBZa|IL?w8lMbH|0y7d9q{KY%rqXX`&H1dIm^P;oq{9;5P=yM6!vP;OS0%*Yh6|2R*X^u zPS&iAj5xB)vgm zA4&R9D6hl4(IzDQRLfYFf_}P{md*FQr5%a~-W|U2NA$e6^t(&TpZq}ed4EWKZ+SoX z)(r$J6BBS))5Kn4Ugijmi_@oB07g?D;|;w#2yehhmBtpQ6tub5K?D+7qU^(HNv`lbx5UW2&XBr z88bLp8#B@kcL~83C_rvDOsBP+Pm61IXCCZ_tyL{#c6QKmy@8aDSlV9sQuxAs$tajm zpKk#oFt>ntI^=jNY=z03k+w-l`nJozOZX)#R6>RY)cuu!h_9PaBEp_}aoz-n;gS;X z$yacOQVY^ps43?%>@SoC4KQwg1zD@-TqS;anuVk@D)AchA2G^P(uHHsr;Sv)bHDg2 zsnpMIQEWXv+^0ZnT*$}y{*A3$zx|^vmfx|o(b#gwpX#6690qgWeS%nw$shydIpV5Q zbCF?|1n-f_!Qeoqy+u@CEF=I<-Ck)1G}dsMHL|Iccv4o_YGawWJ3K^#!CKq-+Fcx& zoN>-n`$abdUZmW@SEC}Gu>t4S4QGzBoaTI11wc(pJM;< zH{v)FA<7^jH*D}B0g3nGKq`o6FELIQIli9amiT+*KEl+ItOP^?VH!OU@+rvxIaLeM zO=##ideJs_Kw_wbBWYEK@Jp8Q?o(15L|T;jk#41iSx!LW zfj?XPA38H5snlj_XEWV_NS#IdG*LR9F1GAtr_K-&HxHnaM75}FDvlIV5Ht(rlVVhq ziJBBChMoCAU4k2r29=OO5~Dt8HRG;E+NC(sOj;Q^#BmNIj}y3)Jc|-*DySg2rjU`# z0HoOA#BSSJAm+sp4hNOjyF3hepG(h;WrtkkPv0@#Z^#CS)Kclt_>m99UW|Q^H_3xtu1-mRMTp25x-~*&=)C zq9!I$N>@7t#8wqP$xKGXViQ;qS!w)4ZFl4P!NyI|+P?J~D#8(0*y<{Isj}_W>C+5Z z2?tIOl`+T=*P-+af>ZV~Zs1V)6SfP+o13w~P4z$u;ce85rA-eKBsNRO!va`H;xZe^e3*r{j4RG^@ zo0K3An~JoIvOv0%Qiq+1dr_5QO_!B-`MQ`!j>$J{U#D6CL|=M3eKkXOL!tSAKp(Rn z5U_9@Y&||6*H^F<#v<}&sD299gL@^ns}w|aP#{dHCwYvJR|6tJD+UDu@=l7zEJj25 zCv5r?ahSy#^hWX_=>V30146A?9x_le9jWXRMIUp2pGw`E`vY!*i&UW=22;DlQP+Od z6lMCU{G7D7u)!2;*~sQmd+l^kjDdzz*&1mPsv>d>x-Q4aBDC^!+B&dD>671yGc491 z9OOXzTWR@VH&htI?^OJWzas)kydzF#$`U_7SU?mIqpW>!UEF-__8sx^wx}O$Z&M`V z-r2sH6_pb1ezTMaKVlN1D@=+xKQ}7rE@fwiZt|}YV%|B>}ZNFm4P=&6j2U2 zSiIKD89UXQoA$hev;svgE?k3dl*JO=W{M)0%h8)4^~HE6P}AMoCHhdH>3YjuB)XJ4 zvl>j|0zO=TE~OlDk8GBPqwzSvY<**M_ttf~hmQkg77oH>{w6@m7Zl=ZsPFUsEg$Cw z!fPn@<3kGA9~k2(?j#UeB>`Tp@6!72sbn#$V=SiRHolmch7D8ZuC4llPVtN6t-v=hcKr}R&+qeU2jUCq|_4{mPU+1$FMUUk8IRour}$@P(-vpp*otB7uj3 zt)(z~B_RfO*-|dOHOQUl}arEBY=#8;^PuzGgXHaG3)4#smpG%KD{}q3H z=>F+vj#B?^tmE4X;Xiu`M_qrezdTlW+JBA+b8*Y~u+cO=YNjXFC;I;R`%n7#Vq^Wn z`uX4I#(6l}q5J>lUpR*iKWO;R86UmpVyW@BFL|HeYkkXm;E$)*#}D6;`@R|Nd+M3P z-+Jh_KeuJ9j~Fg48$Wu~zW=KBlcr)^)k675F4u!B^G=!Rh;{5=(p0D8j7rwgX^=m;{M{3O$0(H|b`-KXVJS0$ z%E4I-W-@1v<|U0~Y}a_K6zh%!z%l5dbVY!rFh%cLNWcgFRx|g49E*P+U|JZBmJpXF zMJCoWU>o8iD!h($g;{$7X1sO)TOT_F(fOorMsqc1p=oy<`a~Ae>EIfFuIbw~ybDkIVRqDq6=LMgbO2*g?n)Z@{l?5 zY9bnpvG*sT*>QwUrW~l^+AW{Hu(43_&*cjFvdD`9Xj8z`%$LzJ!5;!AP8CzZ5^K)2NeOB6#nH7?)r8&ZtmaO zx-H<*EjlNiGCW;IHZ67ZqI%N12?EeNJxkQji*2vp%>R}C%|AvDVPYTdA8i~q}jf-CXn$}#|z z(p~IfuFe1>CHwM>8rhlH5#&T@3P<#X#2=(H?+9K^$WCZkHJcTFnQ3xF<)Uh{G(uop>)iVy%2wz%*l1waZFag=pb35M1yiv$GBkN}hBNOr=^hDz{| zjWl4^DYX$xJ?3l0h3rEW=j+W-rD%2}>q<+pS_|Bu4$*vqM!T^lH8cT|klnIH05m#@16BRVPj=W6?bq&>& zK0Mk5Uoyv?ZG3-Vb9HMshK@z0mUzf??A%Jq=-8T~k|d>&B;*ogUxm%EIaS2}WIKxN z)oC3ORdbBq<3hz!rrA$VJ~p0mL(o=1ObYK^y$?=hZ;IM$o3OFwWwK}wr82%5ixBs%f|72JzrXa8XL*F)2eL+TwT zMfc9e0qslvje?{YUGb)Nk}WwZ{a6>p@4am@rXtw5&X|)qO#+CU5jmnvW^(nQa3x1! zvV((N{8K+{r|={q5OqQ!P!h)GIGmgmS=~J;db?ZO7YQcGQrxX;Dv~4Ei9IV*3J%&cm^w9V7#z zNIi}PTggap>GV>B6&eZXgIL7&g`UPUUQQ>Gad9#k-8G_^AuDNh^>6*^RCS}JC_K>T z8M@Me@&I39^Owu`*Q4?ub1v*3yt;qDMcpj!@=@`@PlbM_=?DMdv|1egeBo9Wi-m>7U<4N*Fm5#qOFYFC zB4QOG#TFt#aV-SVZi^G&Sgj(qP9dVj%0y7M$a?*K=gz%z?@hA!*urAZ$N$d#Ugvw9 z$DK}7r26PXPdxJ2S;>xGL!@+}^p2M;i`3e|)!?d>Wbxo#FDvs5rIF(sNV57IA4OXZ2P%>t(5BXQy_~TiTBj)y?~1u+Q@9pY2CcuY6YjckHwCSMk?~ zNj~bI@AuJsvidUi^^E^<`PFW!=Tg-E+`@ij>kG&)ylMQS_4$5gSB&*4&G`8KWIt!e zzt}I?`@O}D-OkLvkmaKra0}^uuVy(tyy_Ew)pw5gcT#`NU*paDoj;#NeU;s7pz@XH zb?S5^`6q(f=)2_A|0epRUrBz-H(8OCkN$+4fB)23^?CnhYOnfs&i{tzlKJBAUFQ3U zeXhT(RU^}%0N(dQe#7#RuXP%wR4B$^k=_&9ucm_NNUIORA2yBD# zaU~#sP38Q)0p0|cz}w(G@B#Q3Tmheg&%xK=8}L2&0sI7h1;2wEA^|skz}+9*0rufVr}T!LS~AHtRe z9dIYO3lO`!Zo&=Ol6~uk+n;PrHk@f>WOmGYw)_$Kwv41FCR~xzcHsJcOx%He z#mio{6Bi2y?zCMI)9T6gJer?*18JH0x8UNT@sMg>`*gUlln%v| zfaz10m5W}tihNDZP_;2yuac=B$}*Mp$!3)|e8{PerOM!HNd(P?Owh*Bm#{Lmb$J*% zE9d2tSrpaYFHg#=*!Fp97x#R1+9hUGs$QJMk8?9bo{&LLI~X>7Z}eSz6GLi_DSSyKTnY}3&%;j($x%FE7v>qPJLLPLPOp< z^_A;pp^3ID$N8l(hIRxEH5xHGCwmkkEl%6h_Hc0)sddd~ETZ$o&uh+vku8#GSyoBc zRXd@dXWH5~W*}2&Ao0kZ)#OYxi)VF%({oDa3EOtr^#+qwrQu-NwXJE!l^pd+=bqT9 zopKN88El_qJ*zsbx#nQGH#{}%PP?P^=Ah@>Fu5#6RMS<}eg8w2i* T$X9DxLy6>o+oSJCe0%%_RuB3y literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/HEADING-KEEP-EXTRA-LINE-GRAB.TEDIT b/internal/test/Library/TEdit/Hand-Aux/HEADING-KEEP-EXTRA-LINE-GRAB.TEDIT new file mode 100644 index 00000000..c7c4027f --- /dev/null +++ b/internal/test/Library/TEdit/Hand-Aux/HEADING-KEEP-EXTRA-LINE-GRAB.TEDIT @@ -0,0 +1,54 @@ +Introduction + + AGAST is an attempt to produce a program that can write intelligent stories. With an eclectic combination of ideas from the work of both computer scientists and writers, we have produced the flexible core of what could be a very intelligent story teller. + Work being done in cognitive science, natural language processing, and other areas that are closely based on human actions fits neatly into the project. Story-telling is not one isolated behavior, but a combination of many; work from text generation, decision-making, story-planning, character development and other areas is needed. + AGAST uses a formula similar to those developed by various professional writers to teach beginning authors how to write stories*. This formula (described in detail in Part II) divides stories into five sections. AGAST attempts to model this formula by creating stories in the form of five inter-related sections. +-------------------- +* i.e. to capture what is essential in a story as opposed to a random collection of sentences, or some other form of prosaic writing such as a newspaper article or master's thesis + AGAST is flexible because it "writes" stories in two stages. The first stage creates a story tree, where every action that happens is stored. As the tree in generated, the internal representation of the physical world (including locations, objects, and characters) is affected, which in turn affects the progress of the story. + A straight-forward depth-first traversal of the story tree produces a "chronological" account of the story. The second part, the text generator, walks the tree this way and thus tells the story. This part is extremely simple now; it just writes a sentence for each and every action, telling the story in excruciating detail. But since the story structure is unaffected by the telling, a different text generator could easily be used before, after, or instead of the one used now. Sequences of events could be summarized to different levels as needed, events could be told in varying orders, or two stories could be meshed together. + The fact that the story exists as a tree after its generation means also that actions can be undone and the story can take a new direction in the retelling. AGAST uses this feature to handle stories that end in story-telling failure. Like a human writer, AGAST can "change its mind" and rewrite the story to end successfully. This also means that AGAST doesn't need to plan every detail of the plot ahead of time. It can randomly generate complications for the plot, handle them using using any sort of decision making process, and know that if it paints itself into a corner, it can either undo the actions that got it into trouble, or change the situation so that the characters can successfully handle the problem. + Related Work + +A. James Meehan's "TALE-SPIN" + "Tale-Spin" [Meehan 76] seems to be the grandparent of computer story writing--at least, everyone who does work in the field must refer to James Meehan's ground-breaking work. + Like Tale-Spin, AGAST has a physical world, with objects and locations. Both have actions, although AGAST's actions are arranged in a writerly (GIVE, PICK-UP) rather than a formal (PTRANS, MTRANS) fashion. + Tale-Spin's stories are generated by goal stacks--the original goal puts other goals on the stack, the achievement of all of which completes the original goal. AGAST's stories have this feature as well. However, like AGAST actions, AGAST goals are arranged in a writerly fashion, each broken down into story parts. In addition there is the possibility of having multiple goals, all being solved simultaniously. + One example of this is when a character is looking for two different objects. First one object is sought, and when it is found, the other is sought. However, if the second object is run across in the search for the first, it is picked up and the search for it is never initiated. Although it isn't yet implemented in AGAST, characters can have other character's goals as subgoals, thus helping friends achieve their major goals. + Also, in storing actions and their side-effects as they occur, AGAST allows story revision and backpatching, which aren't conceivable in Tale-Spin. + Tale-Spin does have some level of social interaction, which AGAST is at present totally missing. + +B. Natalie Dehn's thesis + + Natalie Dehn [Dehn 81] makes the point that in writing a story, authors have a goal: to write an interesting story. Her project concentrates on author intentionality. AGAST attempts to emulate this goal with the plot formula that drives the story, and with backpatching that "saves" the story when it plots its way into a dead end. + However, there is also the point that characters must have goals. If they start without a specific goal, they are quickly given one, from simply staying alive to saving the universe. Dehn points this out (but not in terms of character goals) when she mentions justifying the situation a character finds him or herself in. A story goes wherever the author intends, but it won't be a very good story if the characters seem to be acting only on the author's whim. They should be following their own goals; their actions should make sense to them, not just to "The Story," of which characters generally aren't aware, anyway. AGAST attempts to combine the internal logic of goal-driven behavior of Tale-Spin with the author-intention-driven stories that Dehn promotes. +C. Michael Dyer's "BORIS" + Michael Dyer's work [Dyer 81] is more on story understanding than on story generation. Dyer's BORIS attempts to understand stories not only by general semantic, grammatical and lexical knowledge but by discerning the context that the story creates. AGAST creates and stores its context, but so far makes only a limited use of it. One example in which AGAST uses the context of an event is when an accident occurs (a character is injured--they trip, or some such accident). If the character is just travelling or exploring, they can cure themselves (but only if they're carrying a medikit). However, if they are fighting or escaping, they can't take the time to do anything about the injury. + While it would surely be interesting to have BORIS read in AGAST stories and answer questions about them, it would be more interesting to have a BORIS-like program enhance the context that AGAST builds. A memory of past events would allow characters to "learn" and would make social interaction easier to simulate. For instance, suppose Frank killed Libby's cat. When Libby next meets Frank, the past event might make her want to get revenge on Frank, and thus would influence what she did during the meeting. As in Tale-Spin, she would know Frank was not to be trusted--but she would conclude it rather than knowing it from the start. From the examples in Dyer's paper, it would seem possible to use such a system to determine characters' attitudes toward other characters and their current emotional states. + +D. Eduard H. Hovy's "PAULINE" + The actual text of AGAST stories is generated very simply--every object in a story tree knows how to print a description of the action it represents. This produces very lengthy, boring text (see sample stories). + Eduard H. Hovy [Hovy 87] discusses a much better text generation model. His program, PAULINE, groups related actions together and summarizes them, specifically mentioning only the "high points" of the event. PAULINE interprets the actions, draws conclusions, and adds them to its knowledge of the event. PAULINE can also "shade" what it tells, adding evocative words that can slant the meaning of the text, although the event is still accurately portrayed. + These abilities would greatly enhance the "story-ness" of AGAST's stories. Instead of: +Libby swung her sword at the giant centipede, injuring its leg. +The giant centipede bit Libby, injuring her arm. +...and so on, each exchanging many blows and ending with: +Libby swung her sword at the giant centipede, injuring its head. Its head was severed and dropped to the floor. The giant centipede was killed. +A program such as PAULINE might be able to produce more writerly text: +Libby drew her sword as the giant centipede attacked. She slashed at the slavering creature as it bit at her. Howling with rage, the giant centipede sank its mandibles into Libby's left arm. Libby raised her sword and with a cry of desperation cut off the centipede's head. + Since AGAST`s actions are already grouped and catalogued (a series of "injure" actions that constitute a "fight" are stored in a slot of a "fight" event), summarizing events and choosing weighted words that fit the situation (desperate, rage) and the characters in it ("slavering", since giant centipedes are defined as non-intelligent animals) should be relatively easy to do. + +E. Michael Lebowitz's "UNIVERSE" + Michael Lebowitz's UNIVERSE program generates plots for soap-opera-like stories. This is different from most other work in the field in that stories in UNIVERSE are deliberately constructed not to end, but to have continuing characters moving from mishap to mishap. Below we examine two versions of UNIVERSE which have appeared in the literature. +[Lebowitz 83] + While AGAST is action-heavy, Lebowitz is primarily concerned with character consistency and development. Past events affect the personality (and thus actions taken) of characters. Like UNIVERSE, AGAST creates important characters--the protagonist, the antagonist, anyone directly involved in the main goal--before the story starts. Unimportant characters--attacking monsters, for instance--are created on the fly. + AGAST reaches for this ideal with the Background section of the story providing the motivation for the story. However, UNIVERSE goes much further, with each character carrying around a changing history. Like Dyer's BORIS, a UNIVERSE-like program could significantly help the character development of AGAST's stories. + UNIVERSE also keeps track of character relationships in a more consistent way than AGAST. AGAST's characters can be related to one another (e.g. Libby is Frank's mother, and Frank is Libby's son), but if Frank is Stella's brother, all Libby knows is that she is somehow related to Stella. Relationships that change with time, such as marriage, exist, but are assumed permanent, with no history of past divorces or whatever. +[Lebowitz 87] + Using goal precedence and mutual-achievement critieria for goal selection, UNIVERSE nicely manages the interweaving of plots that is important for a complex, interesting story. AGAST currently has only one form of subplot implemented, the substory. Here the main goal is temporarily suspended while a subgoal (with a "subprotagonist") is "written" in a "meanwhile, back at the ranch..." type of story. The conclusion of the subgoal, usually with the subprotagonist and the protagonist joined as companions, then allows the completion of the major goal. The nesting of substories, however, can produce quite complex stories (Libby rescues Fred; they both rescue John; all three join with Natasha to continue the search for the Lost Ark of the Covenant...). + The "churning" of plots that UNIVERSE uses as one of its author goals is somewhat emulated by the introduction of obstacles and problems into the path of the protagonist. Plans have particular problems associated with them, and goals (which determine the type of story, such as the "quest") can also have special problems associated with them, especially at the climax of the story (which is a concept UNIVERSE doesn't have, since it writes "slice of life" narratives). + +F. Schank and Abelson's scripts + Schank and Abelson [Schank and Abelson 77] discuss many of the methods used in story writing programs. One important idea is that of scripts--an outline of how to behave in particular situations. They allow both understanding and generation of simple stories involving frequently done events, such as eating in restaurants or taking the bus. + Actions in the AGAST story tree are grouped and stored in PLAN objects. Many plans are similar to scripts in that they generate a restricted series of actions that constitute a type of event. For instance, if the event is a FIGHT between two parties: first, a character (randomly chosen from the first party) injures one (randomly chosen from the second party), then a return injury is done. These actions are repeated until one of the parties has no one left who can continue fighting. +(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -") STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))))) ,, - T, - T8 (FOOTNOTE T), , ,MODERN MODERN MODERNMODERN MODERNMODERN MODERN  TIMESROMAN   O=´J}Ó ąĐŸą•bOš0ÖĚY@1:‘G{!^˘@ŞůŘ Yë0ňrzş \ No newline at end of file diff --git a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL new file mode 100644 index 0000000000000000000000000000000000000000..af591aa19acb25abb1b6878d533ed25629bc0d6e GIT binary patch literal 3653 zcmbtX+fo}z67{Pe>K}3l6I_qE85-T&Iz^K?d}2Hj!BG_nW~~k8}GD}^j5VF0xkTatE&Q69EvBur zH@ABnPH!nuf&BfLAt0Yh5#I-I)t=CtVdsNwbW#U54d~4Jfaoi)*Jns9qU8_7@ zMjluGB@H4H7nGmN#|VQ71y= zwpZQJ>hf2fc(OzLy@R7(w@ZIJ5v%qu%^5?xQ0||-k81?a->sej|eXkF4UM$c>JT8M#sAy_~4D_UPd^y^viqX6E15JJ$O zeQpvJw0-AV#DBlGSzdZo{Q2s?Kl1r@^(X6`Ry5Y>ohmY<+IBPYicYmRI^Gc^__~=* zQ(I{>CppDZubs-2@g(zHAjumy=Y9T*eDIR}@Zi`aS@cM3X|RSuEZ9_CH>qs+lL^>%kNBAzV4h zWDMtGlm<5fwM@YUUly{`d(10p4(zAS@)Q%qL&OF(vt`ksPpzD)=^pKOsjwxeh*O4321~3zgdn zDw?WPBd!1+MG+o2rH2s?mMnNb&jCcL*mrb>7hqwfeG-O*n!zo7jj5le5KTePj!zB| z%7Nc<*sAVy2td7NFr%d{w*aYuS>^=2Xak>f7RLwr!}*~6Yrq2x94*aKy@K{eA3QW1NAp(~8n6wgo}L>*7W#L&IYu@iIiguF7?hXA_3tFx&_Y;%rx zWi0{)ki;+GokBzEJcSD-nAZ5MG)SN+7J+}%m!gb)Sp?#(%plviSf)A-EV@J~FJxL~ z+LT#~28L#c(;ni$B4X7(BvW9PAILTZ6_LD?8ubWkv=QCIh(&}i4$nb5YSbj5dSs$XJ+EfD}&r|3d!n@8PwbH1U z;_MD_3L@bZzts_gGtvY}4n<*f$r>{j1o}AnBY7+aR)hGx)bWBQWdZ3iYhe>hShKQ6Z5p*bCFG;W7#LJ(f6{gUyu zT0-ou+tc>R{=xs=o_6=?Turz=<=*t9*FJu%Jsqxw=vtnvo?Mq1oys)jA~L0G7Tq{6 zQ-;oO!Oc_WIO=}izIA(to!((+-voE2 zLz@_Mrej+asJ@Uc%fg{k0OO7&i?l_Z*h6M0XdAY`V=xom zQcD_XXcH(oO`(GUyf0nAwqRPXztYnBr>6I>6|@Cp}O zm^4=GG!URt*cjxBCtQFIiL$}%0Gtoq(-h1gm2iW%Hn<#00RG!S3UL}az7y_%LqmHX zI{UDlHN4*66HkHnt8|{8m!Ea?+U9tMwHbQveetvtb-GcP_+KlV$U;U7)L!xQSDV;H z87)fsWEYsoWaJW!acNL{D=Y(VU9{-<4Ev-0dm*+5z9!tpaanMa0CbEoFkUC+r>ooR yH9CG7-X3bcB$pw4sF+2Hl9`mr%N-$p{yDfaYGcJU7RRx0Vv83dc@^h#tMzX%TC!^Z literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL-LAFITE-TOC b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL-LAFITE-TOC new file mode 100644 index 0000000000000000000000000000000000000000..d5d5882d808e09fadc509228c0757f609a20f93c GIT binary patch literal 164 zcmdm_#lXqHz~{=q#K1dWVu6C8rGi&tp3r|+yZ?^m{~4?lLaQ~Utk{T?%Y>(IEq2*dN^69~gFI)S^p3$c_sl_rMH4`mT5b3*wR-lN zCimhyIvGQB3=_G6&u0*h;^;gM&tSg1h3+-!6n8zb^s9|bTnzQBo?Q&SC+KFI4<45PCk3fNh60t3AUgLjI>+QR)SNd9Kgyu?kT-y<3>WRI3dVnQ7D^ng*>N`N$wc6&Kzi}h5)zx zS%(u_HGy@Yl-A-}LWLGK-a6=80{N6E$N%>Edvq{8{4ET3qbP`=xn0W8V2~?^qJ2df4|V+Ouj1YE>r}qptT$6xKiuAbT;4s%{e1O)xw>7C$D7K^UDzA>>bhk9 z(n%3~VPlf;sOz@b+9($naxk4lyLa|rOWE6alt;4<(QNCZY>#qpz4KjP8`-$VcCv|X z+k1<&7;V=EUs|8!lku*wvU0Yw=OXLSSgG8us`;kw_wo4EhZqj266YmhSYc|X`mse{ zLo6!WrD(D>u4!!POtM(uLqagd*z@!ASIAMfUXJ6{ql;aVqB1T@Ve1-aC-T{(s*2if!7^_i&lk8%hRU97gzxX#KW4u7;n$I3TXJlRBeIZxbKIXQDa9^Xz^pXFisWhJxe zVt#i$UHu;fWqoYgDyR-ekhg@_M#N{U4Gy@vjMo1bQcaTgAtW|xnT5KxJ91A_6@Qm+ z$s`9ZfB*Hh+@If`Pl!zx8f{@UmH2Ap;t~jPC)&!I*qI?Iw=SBl3q7^r?a`>m6=mT3 z-X(7K&72UUPFbl@H71 z^|zb5@nX7KJ+S#rwz9Nze+GM{CQiDW2pphUQNdLt4~Rtrh~Iv{4zYK2Qz|4H@wEdy*rm z`=`hf*rjMq*GCE<+BU@0Ap#UMA%aG>RA!EEha6oC*aL#PEJP1`sSROQnG@OeT8U!x zWKx*bX1CLzZ*4`m^)*Wh^|>wlz*C~Y{V7^IFkmI(_U$@E1Hpu!HW zYdN2ay0o<`TmaX~PmnZ(*!zM4!bk8maG)93E5Y+wv~rvlQC*{TVH1_vm?wp+orPe&xYTG;O_d!?A$zH@W}s%USE5Rx!=|5hJN2iqlK753%Q^gEo-;)kXV*V zJSk%m){)@?9?XY{7#@*Ta=sH=D;cV|tU`qiO(uhk`rc{Mb)PaAqI#3)XGEk3O5)1S zRRB~Gmz1}?bO&o&wW|?xfF@4)uU)eZY9lnb3z|d%XZ;^!NXdhqsO16jPE9KIC^~t9 zt|oZ;TA}HL)1mR9e-yRBRDCO|5b=?HR3oI*SZ2QM>1$Bb^M;GTpK-68z(>?^W9t)6 zi149uK!q}?%zg-N6DWxg9i?(&REovzU8#6@=EofHv$HB3xTq~jdo6LscXbyEbXqnf zTwBsU1B9%vfBYDY(kPD1Xg_izKk7zLqvPm2e;jWzvaBZdB2P7YGU{0|qb+Ziw=@d; zKJpt!4SO|vDeoB8b*1BW!D`LB8`LtQT#kOaE+U$pVtNPUU z0#9Oo(s<}vMKlt>4R3vx;ZNsFc6-*(_?WCs&#AtEmqQe7j<`m{BisHMDKtS$tqE(i z*tGJQ5T0@#wE&-#B{|hb*FXZ`175Z%^T7!?Tc`b1>t$=UAR9ta@(jbUsr&`j|GMf^ zF5|1vGcxMP_RJ1>?wrVi`Ae5`_rG{|`R;ESJ6D!@hzZ9lVNj}#jSl|7q?a97XKgt_ zXZ<;XoY1_rxMr2g3x*;K{?$;hu5K7+9pwN9Cnh*0y;Fq`?!A--#U-Z44A>pcAtZgh zV~&7OiC&UYLx@FaF|6cqR%}sVQiPY&5q@1hYV~JAhl#Xgh^5XfOoz0XVNz22unk7h z7IdV9)Ns6yn0-V~2iIwy9F}{_EWwWQ50|Jhs8NqWqF(tH63s`4k*33lY5hE3PE>1W zZIkOY8?)7c+R>}?pp2#FCHr)@U1QG9GDqNdoe82dPGe97^IbEn+4;zj8u+WAiTs&R zDEZ>;ZZ&#bZc6D%qZp@)v|ZD?!z?@pF4e-bpvrBY4!)ZRdCzyEwMI8IU>t2|Tt>hI3ytF&JH{rAU{lf$!@2cxaMPe1LvbMR^B zFkD?1I=q>z%Dk?QbrsEnv+G~!s7h}2zEYR-q*QSp)eD_fYFXsBNvum1szOJ}QmbiR zsA{fNl9g4MreT%f!hDJinZ8p|zFf(-O#Mt3`N!%cDVJ)~T(+rt$xsgma()petvzKv zt?t4?_Xm_9RE|$|H&3EDZZCxod6wo;nBuQS7D9E=ViF3e_<&~4e4o` zF9AxNlsDxtI84f@E=z#6A6$M0M~g6;Cz)1tiJNZ2BFXEL0OWNM>2d(2B#W?EsfAwT z_y;&H!=g%}It`0~itB>HCsnD^WU5uPibRT2undJ!JAk4jQkJ3u?D&=@*++F!&LMc1 z#VXd=4WKK0znkj}GDE~{27}AAj&(ecZG_b^T3B@LmOI5wxRN=J30ho~-jVTim z%~g1tCovyfr+QJE8;Uy1$a@Mvp=gp0Z^I-FvBybU&BLmxN74IT2wTOypl+>D?$_t1Mii8n(!|0PNsS=nS%)atg0bdEDC|@j7 z1KjmW%s>>7;W$O$2T8;7z%AIzGxKJP@6zO-Ieun znbTl#BZTpoiS5E=3;j{8vq(I%tl>?fK`|}5HUubQvTP7U5V)?(6?HQ!!o@-tB{WP} zU>>-w;ps7yvl7;!peQVB-~%1tKwXkxo&io{AxSFcqGOB#qCJ8ZelX42)DkBc;~7QY6iENxlTAQ2O3R!w!Q?I7N-wDP0&2niGhL}Nt!Fc+Tx3dMd*KbJS@(cm zG5|m@7%hP#+?KwK!$zN#25Hz1{+sEHtO6$-N;2A@gjAzk2z_VGm79&@4TDL(&{YB{ z7=Iv+4H%R?DnhVzmsI3U8F7Ucj@KE2cus`rP<2*8DGXqg$Y|Ag20$238&9@&wwYtL zpYKv7B`#MvpeZbQ1Rw$x)kT>j04-CE=m~R~Vh2P%f$(s{lif906L3W8vZ|vS^{cw9 z9cLI@J-`qAb&&*kcEVnKniK$O^{ar371ekf(PP-q!Jin z0q_x7%Vd^GV5NPC3MDT7lr|?Bh0-}wfm<_B7#{}mQ`n+jGP>j6Sjhp)q($Xnm}w({ z#IKz21_&L-D=}8Gm_&5Bk;xUpok_S%VIl~@MeNqaBFs=Fz;zlw@oYR}hpvP)oA$x+*N?jhoNg07AH!NEXx&{*vF(F|Q#_$|5F~-}0xr3*tFg?1s zMbV##_0-@PrO2Uj5iFIV8~Fp7OfdJm^QF#Ux~Hg6(tJio`V6jvZtvvm6^eLh{{cd0 z$HxPus=7ePheR2PEKq4%*`bgd7;=dy4lyODvB-j%)M8ad&e9ydmqJ7o%_c%@D-;0| z#fCvJlDZ2;1oH=iJ_|F1_*xnUgpdSF)-w^NbXeH>LwptW01Rk}Lne`kJ}i9dMz3J_ z>Kr==j#kIpTvG`QI%cecTN>r9t!+#7K0!Os=SG}8%%y;y17UTIOd>R)`#Ti=gah#h zp&v0=xJmOIVFzlbFIZ6TG}_wQd$ITQ z1AN)p-Pyvo-Q8zTU+}B#W1jE2PusiC?b>@gPlMN{btoDAexTI$?t9OE3`Qzl2HnXV zSx}8th28>T65fGKiT%i8WmF`~s{EnqU48eozpqZ!_g`KdsGxgrmN6OyhXtWL4Hsx7 zFAleqdEN!zuoh?DQCJ`;&ZJkP3qa?RahGuZ%IN%BdKg+4AV8lWsiy~ueQ1|A4TJZF z4rtPCmM;Mn%|aEwXzCCSa-_6UY{(V>_m2SYNdmirp!eFxW-AAGqJ7ykZvE0%0TD_9 z)`94Ih#Q(AwMa5l{%F~xW?JeTwGk^x7LKiEK=MOUNV|M2N%S^H{|^3h6Tw*Rfk|4h z-BWZo|dN#*CTfT)UT76`8TNl`q&OaE*+m|uDFx0jBsq!Wffmn5@-JwZl za8CIyyXi?`R3Smq_a!zr^#PR;53s(jBf#SoFXB;FwG{LwLsSjt;8>beNUZe7pbMgA z2w?g595NuFPG<(KSRR`y1f(xq?a9Ic;=bNC0fcsB+iw+KGkPOrmI?~+$V!gQm?;4c8J^BdRQ1k@Mu910-H^Lz(Q=-b)uvKqf|<+;@k2-Q0NaV7h{xKS zE*H*BN!4zH*9L+ZFiJ7FL8}Id*cdti?=!GIg9O4^swsU8FQ%K+p{qQ}dehwCo9GHL zwZPEDhMfnjN}RmW2*Ak7l1FnCgz(B{Xc-1ihutgsE#jyR`3=rQc3|AfVz`heT)+>} z;gP>}34;R~7jcysjpHG>jZgoF!C7GyP?1^wM=PPjDz|@puLANWAn;OURW9Cut2s5eLWg6Pv zas|pT*d2CRpqevgevoo>Z;tPy%`?6oCvo;JD)9S>3YD8!7V5k?Cll@@?IKgN+|&S4 zGCYILHIhGURmOOf=)uLN)E8kn;ud40oyh%6K*;-2T$uVo=HRl)cWutH5p;}ICQ@8W zd$iufsB9Es3>g#Pgl-SZ@-&g$5s8J@Ta4Z@gyTHkn+Mn`9udISace6+W_f2V?67f< za}1&5=30WJ=fDPdT9YL}ZfHX7pEzfM3}&rJhIDY>1zR_f=vvl?H?7TeeHU6bUi56( zJsslB)Q70dB_#Q2oEgUZS2=cqY7fKXT8e415K^V}La%#|zNsbGJucf!^q_K7o7ts31Vd%&M-hr-!ty%j)J#d( z7)U;nn=y4VYj7tkgpK3(ZbmHfvv~$BQyvW3^_R4{_sS!X8=Da8$0BR4Fpo%%W@+^7|`w3<6SRxit3LDOE{W^=|YN)1jGWw@34F z^$tH`Z{VDu&x)MIoDYKx_S=>Y*V z!mvb3?lEA?F*)PKYQ>=xJDn)&5N2f=fj(l0bO!rKi^9wEVfPZ^V^W}@XQ^9oZ5-N3 zqAm91edsd9`wALO9%JemRxGvX7KG27w{B$KEEr;_3Q)#jr1Jjzwx?SUwfvw9G%>c2 zb`+OGa=g1>+JPC9I7ew{&qFr+W{k#xp|nVimm8L@e~)2%NqLW<0yS#QlR2a^69(}D zzD>s{3~$ntDPDu{ReF`@DJB7H;lKu7*T|?6?~^zgN=^L-N3`#Zyc@fB0qfUNjafD} zFP4?s+&pT2;t9LSDhZ*`y4Ni?R#YHNpsE0*5cXm(%fg|z*+u0fgN`YeqYB2QSR69;XC*R z#0VPvz!mQO68?UVA4%j3T;Yd5aV!2bpWv~f8{mW7Mk=3jFU6G8{P1(P^5FDW_=KnL zKY4rKopBfa@4ba5|8;Mnv*{KnREMPh+N}sm{PVYN#j{KLU&N|xdB6(YQShN0-{oPy z#c1-02=3Yc3vS^zSs~qDbA`;vN|)d4jebG&%0IH=G{G-^3j>gRlNB=m3$Bo^m*hX) z3fIW=<^6@wEqJ=zN*Vu|Pg+W&a(~;(J8q97GjI!(Tp$(h98|nXB;kT=p|D&P8}*X3 z*rOyD+(PW+i73P}?&-@DGW}=V>n##DZFs0;k7EW@HvW=(olZ!0+FT%Ga)eyI!zW(( zPDwoTuY5ux!j~h@!+ycTLH80=#qzmFEQZT+6Ib{v*vTH!6ZhkCO8_qT8~hmw+t&j&&^oN=Y-grG&J~(*e6^L6H$tjBTrzA~!;zE@4 zA^O7kqj!>~SgqJTxAeF|G9EM`{OIYAxfcLz%=v*^X8b@%QuP! z68jsx)%q155uOEB#3U)4D?FaD_bb!2j?g7vu?f65hpJ@R6(j?tjA<@Bdu= OC%d5jZ=?IkfBXh~fEPpn literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/abbrev-sample.tedit b/internal/test/Library/TEdit/Hand-Aux/abbrev-sample.tedit new file mode 100644 index 0000000000000000000000000000000000000000..515df29119b6ea90fc772b574e7d395a2774575f GIT binary patch literal 485 zcmXv~(Q4a35R{=5W}$EWfF%$jVJo6`A00!$c}r6$e#uLcleCsZtvhjdshkq>U7=ss zl}nGEotxoqkDKedW-B9`vh?z+GqH1)tJZi^Me%`4Ik<7bV;5UC98IZC97XIU^UiUU z5Em@R!PuH(E9|?bjd?rC&W31gCG7SrrfL^Fxr6U){C8Bs^C4bRiIOZV_2_Ab{cg`` zY`ef=FqLFfqoysk6cFeF7xaWD&>7C?4R4??#aAelm&!|8saB|7sb0}iSwR&lstN}M zo#UMH4e|}W;*}oo09xl*=k$n2+FtK&Fg4n2CR(rYe?zyp<#ce*`i-FJ96H-%R4$2 literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/dancer12-c0.wd b/internal/test/Library/TEdit/Hand-Aux/dancer12-c0.wd new file mode 100644 index 0000000000000000000000000000000000000000..87a92132c0ae40cc201dffcbfe2ca6190c077df7 GIT binary patch literal 298 zcmWgOVPIr)arAR`4PrnB4xEe(jFpVbz+z%RvYvsFLFxZd##Y8w2L{H2sIY;7dJx$a m2sXle2B2N!0FW-2DPY$hM)(10UIF7lhKDF}hZ&)efdK%(a5ftN literal 0 HcmV?d00001 diff --git a/internal/test/Library/TEdit/Hand-Aux/new-page-after.tedit b/internal/test/Library/TEdit/Hand-Aux/new-page-after.tedit new file mode 100644 index 0000000000000000000000000000000000000000..daec35479874723d63203d31b3f99d9b81df4ea8 GIT binary patch literal 320 zcmZ<^c5zd1#6@rghPwtS;3ByEy`v(W!xV54dJG`I%D}{+3uZwHCPri)n9Uf1B&37H zX27BtSsKJlibrary>tcp*.;" :new t :hash-file-size 500 :define-types '(il:records))) ;; should return #.(pathname "{dsk}test.hash") ;;; turn on the database & use it (add-where-is-database "{dsk}test.hash") ;; should return #.(pathname "{dsk}test.hash") (il:whereis 'il:ip 'il:records t) ;; should return (il:tcpllip) (il:typesof 'il:ip) ;; should return (il:records) ;;; turn off the database (del-where-is-database (probe-file "{dsk}test.hash")) ;; should return #.(pathname "{dsk}test.hash") (il:whereis 'il:ip 'il:records t) ;; should return NIL (il:typesof 'il:ip) ;; should return NIL (dolist (file (directory "{dsk}test.hash") (values)) (princ (namestring file)) (delete-file file)) \ No newline at end of file diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE b/internal/test/Library/rs232/hand/TESTRECEIVE new file mode 100644 index 00000000..c6a28f1a --- /dev/null +++ b/internal/test/Library/rs232/hand/TESTRECEIVE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "27-Feb-88 13:23:39" il:{eris}library>rs232>hand>testreceive.\;2 2635 il:|previous| il:|date:| "16-Nov-87 18:09:08" il:{eris}library>rs232>hand>testreceive.\;1 ) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:testreceivecoms) (il:rpaqq il:testreceivecoms ((file-environments "TESTRECEIVE") (il:functions get-data receive-data))) (define-file-environment "TESTRECEIVE" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (defun get-data (strm) (il:* il:|;;| "get the data and return the number of characters picked up.") (let ((chars-received 0)) (loop (il:* il:|;;|  "now we start getting data. Just count the number of chars picked up and time how long it takes.") (cond ((il:readp strm) (il:bin strm) (incf chars-received)) (t (return chars-received)))))) (defun receive-data nil (il:* il:|;;| "hang around until readp goes high (they are sending the data) and then count the number of chars until the data stops. Print out this number of characters and a TIME of the input to standard-output.") (let (chars-received) (with-open-stream (input-stream (il:openstream "{RS232}" 'il:input)) (loop (loop (il:* il:|;;| "wait till readp goes high.") (when (il:readp input-stream) (return)) (il:block 100)) (time (setq chars-received (get-data input-stream)) :output *standard-output*) (format *standard-output* "~%~s characters received.~%" chars-received))))) (il:putprops il:testreceive il:copyright ("Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..2186b05ab3a157bc4a76031a5b4b7d84a42843a8 GIT binary patch literal 1685 zcmb7F-%s0C6ux#6l8^#P7u5X#<{`0%sHP>LL0QFW?3>skv5oC?Anheh%$haCkxAGp z1nTy(7fYpM&FrcDA9(Cr9yV#>egDYzKCyG0v<=f9HYu`w&%Niz_ucQDJR`9kvBZha ze!J1MUC!xt+T9Mf=eXQ~({*b$w+D9ah#HD{eAl9;wNX+w4Z+ymFwFdNenS>iX#?#B z6{&KcE`FLHH%B~cu3hcebd)C2D0e3brJIkboK!sY;EUV5j^u7Jol@nGh*e?<1O6+D4Xq;a8c?=@OBkBaB*)?veSTKjgZ!_ANIG5?lY_T3

|%cV$5d~A3mG1Px&{}7qZwjB)1Fy%ufZ$~kgmNQbWe1zT2 z2Fs6>LYZ8m2d0)I~F7}1( z+`L!1xZb6W5!Q_ZT`}3aVgo-put9(lg%X>T_(Km$!kL8<&%y*qg;18FQtV1-KOn^h z8aG6NmUs?yXMWe$hEwfZPD48l9W->(u!@E(4LKTmXvotb)3AnywKUvJ!+IKSqv3WM zHcbw`d;YLmGw4Q-#t)sf77k{Gj!%SuXYyfU2g6E)dYt<03CnH z9(c2F^Qp7UMDJ$nM9q~%1C3vv>NkB`o)LSuSSPCSc<61vuzSEpubdyNUit0tY5=_& zu%2RlUTp=hwpu5u)vFGBy>ib~z2fcgY6!g=vYujnUTp`jwp%Bv)vHc>z4ElHUWM)O zY6QI+v7TamUX6lRqt=OP^=g&9UU^4UuLL{18bhzftfyF?S9gL}cUmW^)vK(%UinU_ zUPbKiY8QI7%X*6Sd36tXb&qwTTD{8I>s9Ct)vKr-UfqXY-Df?;`n(zkug0wt)#_D` zyirs)o$x4*5}n8@M@2BqFTMm+v}A-u6h--!>hgM)n4l<*5}ne@M@oR zqFTL@?e&V!s$NaA!>a@6)dA}%*5}p3;MK#{iE8y~jlEulcd1@Yx5KLvdR4NXVtrm6 z1g{QSC#uz}wf1@?JgIs$!w#SlYrioB_MHPa5Sj-ppb zt*2O@SI5AsW7dgk^=iGnUPZr9y_#i*S7r37Y(2&Lym}10ddxaetzO+`uUD~!s#lG6 zcy$83I$=G<`n-Aqyn4bqQLSFxZm(CkAj@a$pt0q_zE=e zYQvgTwkVR?E1*`u+C(~=he;KRSsCiTs@E4pS+Ad`Wl1FU+WC5Ii(Y#r)P^g$4e$a( zwSis;)s>OJzSFZ@rPpV`8*PM5di`2s{nzw*arGLVzZ&YPG4R6M*g--UR&^UuOCM~o}pt+%{SyL|6l`R&^WxBG`tSMWeX(mkyo|p%GJ+#NF+coVC z2CY@MHyX54`&|xg6{pA^H+Os!02QY+K%gr@JQ(pwE+b(MZf|K*a9 zobvr_&SHj9oaCd~5cvw0gUh{Bgv&75NWq4i+$K^o*(8T;Bwfts#hl>_ox+kfa_Na_ zP9)N)f=F);N&uQ0-cveBc!DHM_4J6jcCuMeNH-1Blne<`Wfchyg?x^So+rk@PP>GWZUX!DEO7yJ+wu84MvA_#DZ= z(?|xkA`+O3A@m-Sp}!y*x`<@x0VG4q5%GOW!#N~<&mieLjij%Lq%Vqy_jMW`Lejer zN$*`qdapv#^FAV;<22lgq~~TNJzYq;|A(aeMMT`gG$fI9HzVnui=^wfNV*Op;!4xt zLej+{>HHK)=l79xZbHO41B2roBpts;((yWyj=Pa`EJlR;h=!+;l}`M!oB_G3CoioeSd83MDo-D9g3}XJiISFigu^E)vNan%YP;bo z)=kgFppu8$hH#ad-n391{jahbfat%Gi~bcuOB(a(65jVy+pB}VDSA+r`7v0 z(!Mg%zDFpw8-w>jp#7D{2E+dK4k7IAqm+!n(`$eYc6(MJ>{&vog&5rA88S#S8xp%? z$hrdvxxT>Qyri>+yv`4hb-qiXH!(Qg0=D9``sjx9bG(eS<5`M5iGllpPODFWNOOmf z=Jr!;7Y6oTpy@-F@xebKuFVwWn^4DYMjd+#6=Z2x4rhb6@`IuWj%>CCD%@>SG1rcp z0mw`5)sR=}5%Vehfkp19@Q?}u<}*yoe1!R!KPmY&P#arPF3pwucZ|ia7*Aah-?9<@ z2eUaoxSjrmh18AD2dv@I@)3@7n3Yz-E+_Z6hAgde;SPYd5Zx2xEGEsDm5&qPaOv`N zUQEd%`IS@o)rYskY(|DbW(!K7l4o^Ml0_V2LqORADWZeWqTE3`i^j?7U{xZsP(^~Y5gOrwqh;0N`Tm(GKu}ypg8zlO&n}j#g&fXngQD2 zG?O;yKy6^7rVY%TqJ=96XhR>Gw4t|A8(O4keIHNJ!u15SzE@0I-&3gd`82Kf{1h#n zuXnRy0S*S9sP>jqWo zp}msB%H=mHou8x9xlU6$g(*tXr{g`7(s2=$j)bP<{;n!3dls%ypyke)wA^Xb!W#|s zJYs)7MGIFf(6SGiwCr7|W#^b%JmpezYnup9!Xo|88UB%OOuLAvSC8>R<$BT#T`+Hz zk2qO|C1*2pfvm#@S$_@IVFV0W{{>lxKd_PY=aHxDXOO4Nk7zw=Pa#k1;c5d~njek@ z$Vv0VDM9+hocqW+H2KI#>|*ShB{ljpZYPLI(G1 zT%O0}i@1Camp{ej4{>=4mnU#}43~#+`7kc`D&xv7WmMVftTvc=jO72|(xv|cO)@pg literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-INTEGER-LENGTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-INTEGER-LENGTH.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d75fa05aaa613c2358fe291c1cd085f82aac248f GIT binary patch literal 787 zcmah{O-~a+7=Cw4KY&77&_s;U2?>{t)7SQq|l}xCdNpN z2TyCX5Xr8F|KJrda_|rN4{){^MLc+#ndhB(KHhgm5PhPXNbl@+TWz<8I>SMCI6#d~ z5A{34Ud=@fiK7>~#p%m3(bqE%vQze@O0DNs2W}mSq1&%lpWj8<`-pUVt+w2(t;u6H zzmm%@FK4ET#5OP3{`)4E&)v)CRx(rP$45%40{}HR3ztcN6hy#3@KTzfw!lThq?nNn zs`(?|OUNwPu_^bxbPf$VUEFq`x$Q8{ZXXl?|Gk$eI!qUa#r#9%m6G(|c{2vXn=%?H zQBV`VSVDHi_vW)XyowDbXo+%cQdSaWI6jI!4&8ido>r8TJ=pqMQMYGrrj=;x^eMpH z>v&RWo_u3+|6{cNmVE~pHQ%s`s>}c!G(TV89%qu}1V9qttW}#EHB+q=s8RoecT3YP zRxm=3xJ+2Vl**3`iLjEbsS`4MTGNTp%a~K)aA{s2r;ph?wxAoT^6w2{X~A?P9!y3O zGVrWMIkz~r9I@#LEix$|BsIcz@EEtXKqgORuQV_o0SG3-u0<-6Bv!Qe1`(xDOm{e^ z?9wy>WmV$W{^Zb!O)uDk>4}1@&Hvp~9QOP72*;z98qu+zB{{Vi3)RepU_pK8dv}D} zAE3p3vWOa0`9JHZwRiEgLTrCY@jv;8s#LkHb4mooSB#j3pq!X?Fdbf#I$MqCQ33}~^X7YRzW06a%@AVG3=(=}3HWCB3w_SgE7v&xz(&>6F8LX_x zYp(DhUszgNoGKC99JBrRO}>!7SGb>FoH{=~QZj7-Xuw%?Bmpv@L2%$_bU|%_OBIu1 zMru?KhJl}uUa(_R9{AZj>bE<%<-TxRk)7QhC;-7nKT&d+Au1LN4wW}bI{4sER~TNG z)<~Ixn)t&Ku`7X}%H{DgHmx#YML0f+KaEs;Yo1n>lRen@UR5_|Zf2F3clsP)_U&X^ zX`cLGGX6DOd(VCX44dy*RaK?|4w_%DZ;rgkbOIm^aOO2;hs}(a0W}tU@^9&e#fp_k z8(x+DOv>?-ibPo1*3}7VI;$H*7^|35;czM17`cwyTehGzRk>OrEImwVlVMUzNTV}4 z<=o=fa>TkLbS)_#q;A!k_!1ndlKr;9DG?N35@1#Y<;1kZR8%JWY&e#n;SKnV&d+}X D84u<( literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..9c2eebf574de8b04e888cdad6f9c50dfc47c9b5e GIT binary patch literal 775 zcmah{T~8B16urCsptOY)qKO!z6B1rFPGc(us4tGg^owN{W@kknNm*=@LYsb=7$Y%0 z__Rg~k?d;t556Ks9{fZ81DtJD2tN2Uch0?Y?m73)0Af$6iD+xL-DtWU)av)z{T|wB zbx^m}@6=qhqj2<+T7tbQ6S|Upm`mE1GPRDo)pNIz?7Q9VtrvGuZV8cgr_ofw;-b3d z3J>yy`T1<27ZC zlo;rV-z*`!=6lIp9xq_iDiOX+b8vhVe-i5WT0gC7Cws8|t*UQK-kj26jniiU({IMo zTK(iZSMkrm$~*o8U{HU{tGYG;a8UnpePifGr4s;YfU`zzdQi_aGN8x&kKQeVT70<@ zs>5Z~(PRQYt|)|;Y(tMK+fxQ5l9sVx(h*8F9r}*jo3>=Dy7q5{w2UAX84JcE31xNC zU_w{|TaH|Fq!Afc57GwVn|O%ZMxZ=ra#uz-76AyN;k+VMMG`MsVwK2J*o-F0Qh#zAHTFi|Da7{YH2<@Is4M>4R4^hLz9PY_NG6DB2dS`3^;vf;$$}g337wz+ E0$&K{ApigX literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC2.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1a2bae27dc86fa54814d8c86cbb92bc32d4ea34d GIT binary patch literal 775 zcmah{TTc@~6h6D97urG!(L{{V2?;M7hu8)K))&WNdSjV|*;$dtrrp{mg*LsI7$Y%0 z__Rg~k?d;t556Ks9{fZ81Dq{h2t4>SXTEdhJKuNCj3D}ynuvCGx~;a`L!IHEI~<@! zr-%BTVXx+*hQiTHY6cFidIduE=>WjN5`v8${uhmw;%8I&X z^Y?T4rKQDWf!O9b+kfBW^0|BYrIp3x+0mhv=>R|tPQzmoAOjKb_q~iEnJsalY%%a?X{Nn-+NPKjyIGw zQe>bfezSz^n(rmEIlPQbt4R1N&B4)O>`AEOYxAU{9q+>Cw~D?seRD>OwoaY_%)W`I zwdV16uHv7gwRijnz^M6_S9EO(V88k0`qtQuN+$r)0H>|m?5LS(Wk8SmAH7=!wfJf| zREJBdqsat*TviA#+J-)%Y|j{!NLs>zNk=HzbnH83Z`+cs>)O={X&FH(5)URL31xNK zU_w{|TaMgtq!F1^57GwV+jxxIMxZ=rvX@2|j{pP{;k+UhMG`AmVx7oh*o-+l_#Nmwpu5G+d#U33iSx}pb@vx6M7tHC8eD98Q`vWw; zN9IwZs{UjhwRX?HQ;6*?X#QvaKv(>?sbEAhd`W^?mP`=S4pL#6>a*!sk_9*56FNKl E1z~UJBLDyZ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGBITP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGBITP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..a6e264ac137bb4313adfa9b1945d9f4a1423e138 GIT binary patch literal 791 zcmah{&rcIU6n?vg@x@b&d!P?UPxKoO$u%L!^9W~ z@nAfx(LyA<8vX~bh>?T;5dQ(r6e0u<9wu+*do$mA-}j~q>F1`6%=%^{tocn;@3b48 zHrl8+QLEl*R(-S~arDM?IDNZ7%%zFPg+cdHrrPw^+WtBc9ly1{_WA)TJVK<=3~O>T zGb4|M(p0fDIXN*{Ca!(P_TM+fQt@GFYHDKe^k84h*8!jk$0`f}@ibV4vY7+9W57siiRzQ zm!&i^PeIR~vnX~gj&g+}p2oH_KWm9)IM~kws*NAP(V}*^1=XL6`pU?yQ7s*YCkH_{ z_#oq+Tsy%|aP$&j>|K9O3l4uVxj*SHePq7@y1{$4sB6OjyTSMCD?NEKodw7N9Ea7h zZjcZ2pr_+6(QU(Y*qo)>#S4VZ*_7j1OCoIEHS|8|!>C~rVJ=`!g~z21vu8xcU3CSm z=-R(GgkvN_ss3ajm6h5@49dB~vEzwlPZ+5I`5 UCPV6)tn<`!1Wj(hS9E&%2gaiDZ2$lO literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGCOUNT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGCOUNT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..8d0954bb8cbc2c7ccd5fc8a615eaea0ee35f9546 GIT binary patch literal 775 zcmah{TTc@~6h6DXP})KY(L{{V2?;M7hu8)K))&X=^u{s^v$GSXTCG%JKuNCj3D-unuvCGx~;a`L!IHEI~<_x zP7n1v!(QD*+X_c7sU_H}GNG%B53@=8LZ;qxYXi4|;pu)y;fTVD=X@n z&EL=EmzEZjMPi%hZ2zsv<#XBmJymmdbf{%I08oe1@R$V1Km`1KFJnk%OI)m&40E!^ z41eT%3FQSlHWR)#lS6|}7q{K#ZacKI(+3T}|KKHx4yUqWasNPjt)>0<-c*I-b!Cl| z80d-LEFrt*d&z7LFJsdxQOn^Hjt=8bLLFb5Csplu7dF0C_08#5@(f`1%|u#j z9)IU5{yAEG$A18fns0ek*QNmWn_sSPj@_tq0w4`=+N#fvnweGx^qBwAyJb*|7b>AT zTqe9=GJzjg6v9ikp+}YN8G{l@%UCe!2ql}2eaG!BTe3A>yZS;}Mv#h31e1}3vN~-r zAuNF{N3J{4h)k-2v_be59^ZuSivq#EX_#BeE1WqmB@aU)V#S zEi3%mKOdCX?3_JFMGGpI{4-4)&iL=z#_Lq literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGEQV.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGEQV.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4337e12f8cdad9e0a0d206a0d06f98f2fa389b7b GIT binary patch literal 771 zcmah{&rcIU6n?v{t)3^-=tQW`aw6ttzVRjbe*tA>Qq|l~6OpK8j z51!U&A(CAU|ASY=$iaWe|DevcMhP4|&71GN`QG=vH$#X%GfZT(_dCs&+ePg`zcc8g zdb^8y?LoKdqPoP!AyzHnQio&6pt0RBfWo_ClbiWc*al{ZS#|KQCP8QzlC zNP&VH|HBfpE54V|Gk6V~R)KEs!0AbBCsgsRab8l+4q*FxN!^{ly`V&!=g$Ea-%cl$ z#@P=h<6pzg_v|OYu*Yr@3?PopaB*cSewSW?0DR>~&jhuZKFrL3cPn zjZP2sJHuYhLk)?eSBA~$>k2W}mmleA=TfHD^L7Vb9f_gWukXIRkMxI#bbGC~4A$1< zRWCfq7gko5(BF&#KDlK5Tujs@t=-=afY2>^Z>v+o`P5 zJpI9B{A;xSp8W(EHQ%wSs>}c!HoxB79($4L6hIc>yj7bYHFK>TsEOc{e@8QHRx~4R zxI$Rbq8vXlCBn*%rpBe|In5x#s9;Wo%cW>z>^kY}ID&4d%Jm9iYhflf6;8)e(&(&4 zIk!2sU9ss3EjBG5WHrKe@ECWrP&&@(R|Yo~0|?{Mv|?3Bk}TPLgNSm}%y2oU?9vuO zWmV!g{`oM7LnrKECSH`e%w(20n(yD0jaMnT6Js4qa!W}Tb+H!01@&>@-xFScfEEwP zB5Lf)|5!(@{mEB~u!AKf_!1nclKrm1DG?N35n!2ua$-4QCMuJCwp?4#@D_YV7Z<+) DS<2>S literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNAND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNAND.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..25334118f118434cb3b467af25f44073a9b79934 GIT binary patch literal 773 zcmah{O-~a+7=CxREd>f`i6&xwC+5b|V(9hj)mINu_7Ni8UaKuPYishD z&8--@<>jTR0&%Phw*S5{az-|1tSn8PA0H{{4gl2PELtW3(x5?b;HPy#9f1oai(*D9 zR1ZdhpOjg!>rfu}83PSEUEKCwdhICAZXXnY;FF&$xXctKn+1o;TO}2I^k+&8Z^~$- zNI^|rvPA4k;HR<%Ud5JOWQ676_$cu#vhlrnT2@Z>VCzR&-JZRhQR1!B7XWkbCQ?fC z=(eO`JRU25htt|bIH@IN(pjBy zZgXtAV$&76HYp#Zbi#J<7b&BRfM{|;?DOi3Oe8(EZdO0Y=Anh)pICxQP!c>Mud*e469 zQI$Wkj#_&cpDDuj7nR^^aHvZ9`zEJEP<+jSRT7jF%L%8WYf@*+wFM3Dz!!9W{s-n1?G}(#)>x<)d`o(q@W@kknNm*=@LYsb=7$Y%0 z__Rg~k?d;t556Ks9{fZ81DtJ*5`6G!X3m{C_ndQQ46&z%iHz=EuibI`s5=_=MnkmQ z?V~|=)Ni_ISK{cUVR8DZN{qGqLp^0*sx(y)Hon!>&AFR7CDuNB1~C67kx^Qw z-U@!(hQ50YN0k< zC9Gspjvv<~!Ya0=My2VTW)NXiF{i@eQnWE~9k;h^K^v;_?+syTK{}EMW+F*xbWWq3 zTO3=CSa*aLnUN1N8ev;_g4he2#QWe?KPlB}htS>iC?KO>urQgX*8I+o;=;xg|BF&Bab^^x!05$<4!77xfG z+TE7_aR;^cr(Y?=4we-Evwx&Y_S*)hL{NN1fLRli6VndT;WgQ3!?6SnZonsWaq$aW CIOc2s literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..e04679d58574c4ff792094a091efdef5f1c1543d GIT binary patch literal 771 zcmah{T~8B16urCsprwTrqKO!z6B1rF4oNEptS^q+Y1y)!h1pq=N762KlR}$*m>455 zKKQgo3z6(<_z%7!Mjre_{)0N(8YTGP)7&}t&bjB@J3~l3)lH7L zUb~BW?LoKhqCJVDm%7F2t97DpEI-Uo+m|x+uDjcJ8%PY?USs#gU6g--NT=(yWU#g- zuleHrLUCnfdAdw&bHeuDH-%y$U%a=rJUu!+QF3hnsKZ5cqycgegW$-|X@c4UmkpC* zMru?GhJl}wUa(_R9{6(w)Ngli%YE*)B0Kv%Pym7teyZ#+T^JS%j+NI+HhAyP7z}Sp zYotO!P5owx*p;SgDRn_g;n{!ISJAVc+|7I$y zG|#>>8UGw^ykkEAhRwIEswy)8N6jzSx5r*&It7pgxbW)p!)DIQftm+{>tE{VgO-0npUhTNs?uY*NCV@&2)!z$}Vjo zR8}Q^?XM4=*mS}kX5uB8%S>j8qxt?>*?5(bJ2BR=B)61gQ5SO|Tu>hc{vF}=`e^Zx zETX+#`5zm|JD7Z>2s>O-g3rORD%o%AoDxCt6#=FpC?}>JW}-6LXUnk!4R63FG#dQ^ Dana^? literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC1.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..49ebbbd37fe7603b194ab1c0cd642bb725e9a888 GIT binary patch literal 773 zcmah{T~8B16urBpA3z}s(L{{V2?;M7hh!TJSYI56X=&Nc!tAWbBWbs`NufR6)JC+u+iAA^E@}_@ok1Vf z+g;Ra54u$!)fJ9jQAe=XYlN;ZKC&j_1hiX@?ZF^*v@VbG=T79kSTba%96vwL+y>04L<}^C5|_gHBw}t zXD(S{b}bCDRt_&?+bKGNT5x=ndK%04);KL|Cws8@y{vCd-=5Ku&C}-qvv1Q`t#R^$ ztNX9v`g{HpVAy!a%epoNaM1XAb8BQqeP;l&0B6nW?66@p4bYR}r{IoB9llzM#o;x= zS8XQnlafMs(KYok<$A`XMA9`ZnDm5FO-HsVEoD$B5hgW zH~#vd#AO%k(d5`_T<@}(IPUPDp^b*A$de->3u;a&9+$D_qB;F>7~GS7uaD;U$vmp> zsEw?l=HA6J#n}FW7Jdm2bwz)d3PvQu*A&<#$po?8Xfh5{bv8Xmvgj6kM(5|h0n_;A Az5oCK literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC2.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC2.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..4c730c3f647d02a967e0cbaef40babf254cf0a63 GIT binary patch literal 773 zcmah{T~8B16urCsriHXb6EQ|7B)n`Kk~SEyzBmrkFP2%DofUZ`?P8l0+VsQ37>V)0 zr!`uLWLLv~@D(xg;2-iI)Y(Fm;Db*ybLQT2&$;)GAoh%!h<5h6t+v}ko#CK69H8A! z5A{34Ufo5z3P-P~CD`iBMepL);T8MqB3hi<>I^YT8*KSZS4Yqiy7Wko&n z#RrAr($eBoiP+`^+kbNk#ez!9FHVh5j)SGvRx=0vdF>xb41h+o7GkK4<{`M=x1&IF(h4`$yUvE#rUirmGxpC~Kt5 zKu=z>gzTE{W%32Qj7_U-30i=YSL9k1!yG{9l=>&>l+8TFk6$N-$T>a(L}wv`1v=6~|;7}Vmc)leL+ z5WZ?MfuB?r!ppXyN0sZGL5ZXlESPkJQcWkesZX1EJoXubBTp|JxM8kGPYKkOYvcx)(<**oagkb#27y@ls z;Wz&Jpu}bu>_IxZ8rHjPCJsCNXK0gQD)QJw$byORG*LPpuN7;vnbbGC~ysWOu zXSVPlS6EqDo-Pu{x?uZnPOgxXY5C>p@yW54?f^gy&ef3wNJ9jILqBZ@>IhscTNE== zrA9Cc{Dky^U5E0(&*adc)5UG?h1XVg_WGa!1RwoG(PgG6+blTJ-e{@dgFjnlcvD&< zB?@}tl0~s=fuG9ea2{KBNxk9ZIQCS@_|`nDXs7$I^}V8R&)v>w(bm~>fcdxal-4}` z!Q}ndXyZNm2{3BDV-;PS1vqSey}3OxBfk>>DS-1^~G^JEiKzwn4J}PY|3Jr6t?Myi7^u6 zgHLO;5Xr8F|KKZPBnED8r~cwD$~{D+(`~h7u(Ber zxx#~dVQFb`vP5ii%=X_m`9eNlxOabX^5W!J(L4ZXz^q?s%}o-oKfPfvu6OaZ<1N1 zdHS8n_~&r#9s2<=Y`$exRha@fY<{`EIr1XYDS#}%d8;uyY-%kH)OhgGzoi=%D^?x;i0E&*%mb#wzAiI9!T0My?a~wk>E)RsO9ImL6te$uJ#DNu$#` z<=o=fa>TkL^jKOx$m)b`;}LG_p>(X}t_&_20|+OgX~n9NBvG<>jfis8%y2lT?9vuO zWm)3a{`xS8O~>qEW}+x_nei-fG~Yif8?91u$45FASE4?bL!*3za!jUAI%?- zd9+)X|8WPk_Qzi-!VVUc;B#=KO7`0Zr$kVEMSximloQhqGf|oBv*B2RhBx37y14iS DbV%la literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-POSITION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-POSITION.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..5ccd58800ea1f4bd592feb9e097d7d9022151182 GIT binary patch literal 1422 zcma)+-EZ4e6u_^YHciqrb3znK6f!I2Ls&R8*?=}kNUnF&hPrm}2c{BYs@!x5cu7eU z1R7LRAK=B(DAOii(DpY#-X=ErVgCwy&wtRJ>ug;cCJjZp@%f#5zV12q9;4YWWrde} z*Y`VatIzj_gZ<%v-|O}HgWj<3wD>*X{0&*t@y{EQyjlLFk}%F_oPKL((AwqAVe4Rb z=g0T?$|^7I_d70ptgL`oseM?jUA|mS)FnficzdNywN|axmRHM(lY4g=u7?nEP(c6U z2yrNa{NFuJFtK5Z^@f5)RocRWf9!iPs7164tovTN$`5+`qTBku<v9UI=P_BvCbl_b51_!@)4&1YtbnN zorl*D${fwT&a@v~O$AyC#PP9mOG`aQ=(zo>mfB>Q1^E2y4ZB2xfj)*%5}}~uycPV7 z{ymccbM!oen4Otr?${akxRHaNt~U9`A7@0WXc<&j!jF4{>tHiM2&63 z#9J&2JF=4rk`*keR#U8N`j#OOhGqV1ZE6CUkHkTd3`fCeVtGYeJ{>taERlsNb%k(| z`6*TfmIRhKbyN9Bq%biJKL(gO2QO8{O8_qbOr4rjxD1pd@kknGIVE6S*K|>{%%)`u zkqqok3X-}lhMX4Ydt7DeZp2~4$PB#@b9Ay@a5RIzkQ6Fh1tCfgM>47S6*x@Gmab#< z%N z4Rfc`DqP^GN|On56UfpKj9)u%Y(UGKg!`J5EV5K5OEc8c^1X{@>tMi_4y6*mw*#-* zF5l@+9wf>R--d1I7ynQHHl2>5tYZmo{Zu(h!^FCz7-XJqgVa8^G!v83cfMDytzkGP jJb7)xCvl5WsiOiDNsCbG9rKEaRRW{-~#}sofSrDj{7i>%_#lGk0f>fK(J+9Bj$4 zgJUC5)u@UPyqr`*)#?^hK10b{MbSO*UEnp3yoK3w>!b#$m94v*-^|X=?9A*jn*LO+ zNosFzzujr}rQUF`KO9KAy}oqN8}^;1vv}^xeWgs#n{=Shgj?(gdF7a zR}>);g^>4?E6Nr%EmEo0DAANnDtpJC8-ZL%!=#4iCd<;Gw@*6FubUm7&fWpS2zfuc zkxD~Tt*Wkh_wijE_wKoKRgKgkHD!$=A@a-%_l`X`Q7V%qva)4SVpcz+=+VRZBZTlE zDGEHE-&;>N@RKh3^^Xm~ma<74?naQ4^1Bi2q~R$z8NVwE&H_AVoUGrKLQW2zc_;6; zpMHr@>S*RQ+4`rPI&S@-CpH8;2cM5$w+nnT&_@u8BjmT8H~rtx zUl$_4-#w2YVyC9@13R_%&)-LO3U?x>CwJ^LN9h2i1JtrJ9AyHO36N6x& zPd>D>9AyKP4bWvf$5AdoIoy#>PttatqkMq!9Nlf5|6V!E%>QKxIe(Oes{1XG*XDtn zlT}??t?~krbwyjPQG={hfoN-{EQDE9n1=31%Bo_i>%^c|!+`3lL3@PFEz_c#f&doj zQU9nls%VWmsp!V0DKjkK|E{)lnazfxpootep-$B$a&_Eryj4PT6Y3HZL$edC3@i>T zHg;2bk8l{9gzp1Pya2D2$u)rU02AZo99{(~vS=s?ot%)VVdw_Y8&oeLU5gNxrVDCOwaQwxl~#mYx-0`2%#ORej$^5+MU1H(8BC3- zgsP&5R%#C`CBy~ow2c&{UjU9#Q~6LS=NzhjgQ(XYd!z5I6G|x(ks@o~%=`D7_ujlW z-X(#XdQR4xtLybfwIw$<+v}Tcd8OHsH=3KRN>yF~x%{QhO#0QFrZ1$fr^D6>O{G;` zYFC$Kd$YQ+ytH*iPG6I?^;W$Bn~4cv(~}=$Ca+#ig=aJ?*F!tkCo`D=pZ8PYqX+wf z)FgydNEeq7ArkQs_r4=3HnnVZCYz(Gp)FFy-F2NH)a9Cr%MNFHZ>;Wk9Qy01p-w!S~=~3guy79S(_->$uyFu8&-sr5LLMEGJ*>p51=Tou z4nc{p6V!Rm7}T8_{$9BuF7_G%(>T!)&>!3gbxt#;bJSF) zvLG>LEk*3(Au#}h5>s@|*5_1{+65CDUH2xX&nj6qT@*#INc2WY&r!`Nge5=zmR2Y87%emwXp^$R~j=bnFho7z|-l zp{B`9l@;uK!B%{6Fd9@eqojIr49NEe$Sxc^s=8)Ti%YH}rBBUzxStU2#{nO}k=+J- zKfR&lkog>#KFm?GkzE7Km|ieVYMgjYxPZD(L6`Wq#&}*Y8t%cS0VzOlP_qQa!cY7y zSjcmJ373a>ik8n)W4g?fpYS&q`A85kx6mnXvRMN;%Y(qgk(-C-sn5XByhyL}(Go-u z>17Ppm*>(Hm#^_rg^xzi;Wj)_x3=06Mo(&fseFFiMUR(v9x+?c?pe9R}s<>y(+pL(RGBI@RdMD5Fz@y2!zA+K=yvj z?za0Qo^ju~teaGWzB*O(T-K(hmb3T(nn3|SE-;&Nx!^jf$teoANqcX+_s50B=oR2) z=G)ebTBJtZPQUxT7$ispAbuYb5s2hRf(kj3M6(W>0TF455 z9z3nlLL|Ey{)1P<$iYA4Kfu{y6!73_W}bKE`FP(ML-eU`BE7rQYj@l}>W+rJ(GWGe zeKhEf`gIpIC5~R|7N@T&L|@B2%+J^tD)qiw8@df7M(&_ddvO=#A0X1}w>xsPvLcW9 z;&P$5w3M4E6Wcsz`|q1Vu}~;3-^@Zyz7V{63*GkHN@68$vZ^&q5 zm4cf1%@VRJzL(7x@Cq)`4a+t{HENdN=rHyqH1oA}QdN$3Ve?y6-I}|ZQKIdWX8_qZ z@s!d!{?6q7=XmWM`vEX+y=7HZnFZKyeYw6hi6qMjfE2)KyPh4l((N>;QU9ZNOVce@ zGD3^ELRiV996vTB!d7ifos!uznofjX!JG<*OYiz5e9Ydq1zlH_e{Tp&3zCs|Fda$A zymK1m+~U}B#D*iZ$h3Tr(g@qe6WrDU89bf8(!Y2FAeai97O6^-SlQz1M68Bly2CkT z7lsii_a%PqZw{T<^qf6NPL*UWd#R;3?Dn4lP6jI_q7yrda%M3Wikb7ly!y!Z?g)1< zL<@Ul0X1v#cQ#Oa_xxjp*xsVzfA$YlDRNuqln9Ei_%IDYIWg@Z8D5h*n~o)Da05P} Gv$J1#GU_t` literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DPB.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DPB.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fed7ff8d878f345d13b8b9f90b62aaadfa0fdf53 GIT binary patch literal 1541 zcma)6&u<$=6rSC+9si26jzTCVBpXXbXvLb^4agV?wAoA&6KB`#t}!`46gdvI?Anpz zAORw(a^YerxK*p2LJxp?L?RXvs%T|Z<-~~tCr(_r?_WT8jhU!x@PAM-MPtK=c3L@Z!)hdML3$eh7lk1RH!-!<8(&JDl5fhboX}n z7$NSbxX9C;{7`$a!QF468xJ@5@?0X$1zJH=nI5)+TxABnd}S8CLgf;CeU-$p{@{It zrjI9{;%fJ|V?!eb)a@5ejM!s@`n6Au*apu{!tmQ?%JZ}UQ~d0JEMpasm6T5t#N0rQmJa0hzRf3D+q2d@M3R3h#m1M+%AGHEj^-@t;HOx&*CLGWGeYI`K zBqD?$5nbN0v0@dmmQ}7iF)+2BFgcb^6H$na#WE0!j>WD*EIbxlf>?}%gefq4Ova{Z zn2J%dizQnYL^@Yi^(|!-r+apKVtVZIgusf#M{mq5y#zmkkPpAD7AW~1NPwPKwJH4$ z1mjxCG_ii+dJ>N2?m=$muYPN)g;`k=q3LZ<65y`Uu}S7BtT1?m!3zu$45A}Ie=u+v z{KnvC29FpF7<|p(7MX98XPad1UGiLr78ycaf6+A7bjnU)lR?;pLjMOM($F0`VbmYW z`tXVbbb8>?`HxAm4ogCGi3R>B644}!d6LYLq>s-3#_28C)q}2-JW`X=-VQvdyHdTy z-a;BXy8MyzxpR}+XkIh13Z58iQXy|+Q!Q8|LZ`uI-YOY3CW}?4m&z?;=ssqT-00=* cJ}Guy<;e2trhKDHOw>pW z7cZM&G2o7di~oRlG-7)2;?@7at2YiFP4G<%l~fbG%*^+_-}Bx~9d+GRR6(gME*HyA zRj91imRD=SLZvFKR936DBP;+fJW+H5Kb?}5>BP-s$UG*otIk}_nHQ{8XJvlw(N!UN zLy(uN#WEa5M*$|&*Hh_{kwj=hHr1B5f7+zdso``gl?WZ|Y%_cXA!MTl-GT`5h(q3{ z%ZnB^Eoma7Vo8%{u;|r2HvqLrITIV68%+td%Cb~;9y(=O&f*GU5b|EQfr*@^SQ%aO zUNX;^u(#p%WHc!YrOA^Rv4KM`)H~z3p=3%LmDKSui4tgMJG71vb2iGeG@Xxyy=msd z659MU&E`+`M;ZT80NJs|Qh>4hU}fzyuyS@ktUi07QQUig(8=`^rQwHa|!MfINUu7@u-t7B1_D@RcSrF^X13wHaPh286= zd|w+}F6Ga(!MRetzXj?Ax0D|^JQtr8{yVL{zoi99-s*?WGzvVuzb$t_RCH}TLoZpH zlC^Oa8`4+?7;VxNSw9J~UC_a(sK}NwB^lVt8PEZx*+RcLYg%}QWkDm>>an6?S<7Xm z3Eh}6MZ&PmpVpQxl5Q?Yf?N*>!(+1+mdq?xMx|@*!Jr-Fx;w;4!gJvcE(KhugBu1e z(!q@Y*9!v_5wT(DhNS1LY|aunp6ZFRHY+uGnzQHf$&P^xLT8DOPGOkN)G2V}!*^tr z0zUvhtyi`v0-~7>P?O;by*384W312f3 Qxd?v9B{GCwCk_sN0lH{^&Hw-a literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..957524c65fc1f57d5c9bb5588bcf1c3f89a940da GIT binary patch literal 1291 zcma)6T~E_c7(Q*s+!v!GNDvXr5{PN+;sz!-uSz+Uz22 z)P!oIzTT({E7h8?QEk+0M_2(|xTEL>zB?x?^QrUcht+(bsGSJ$PAbJMBNa#lAGgOK;g4b2oZ#mecL z_k_8}#Jq=YcTSV?P?|i85gXd`LcKFUr!&%|q)tzvm)nv12r&Z*o~4<5D1Dq~-mjs@ zpXS+O?_h!nu7!}@*IWxRc0Zh~JpdWgOap*Cgis8jX4w{+Z_)OlsLZMTsG(wCr3cI^J*}OIV!uxx zY3+;^2Yi}q?F#chw|NHN(`u~;{htbD-|IiBi?vbHF-ahkK|^68FM48veafbL(6u2e5L3gAn! zN|`QTg0x=QqAYDjLMa#q)($N@VL*m{fUNI#zZKcUepnKv;?LlTgUzM%J2FhK*Z%d& zzn+reDmh*uLs!U&Fo>B5SajtLeO9B&yTFCOUZUNjz;`Nc*G0K+@Gk{5nkda1eI>~< z!{ja?|v0z}`b>eBhUR@F^_C32o%UM`P3_|WRCpb}1WizX( z?k2OwMBJxNS5_7CP?|J}5gR=4LcKGt6HBGVQE^%_au5nD<7j&;{1_poFV3+vp^v4# z9J9NKHa_LpVt0R>2`mPY)zerEGFC5~taTDjpVbei-x_F?_wFFn{rK1krnGxI+R&oF zHrJJ>TJ$qQ>!l}JG{-VsK)&lM4$=T14i&K(1u3%jp%L1ZK8Uh<2A+`f%7#C#8l&3@;n*|+aAh(7XFlG!BPqQp&^mtR2 z6)dTRyf~rh(}qA8mig1#)CAJ$3z3ko3xtue854^}9?PTRrQfSThwAHW6Q>C0i?m^B zz`||VFksO(Yy_|vtWZ?Ix~}P>RxtAgQ}A(APmt6Zv4zu|U587xtz-x$OZ;>XBXp;Z zgCjq_At{sz0283~N+xA};4m&1bRDZlmYy&mL*GHxbJ%ZLGO!nxbW-tWy5ff$OrZ~C zkX~=S>y39kCxcaTszL^Ck<%d%Gf^q!^@=szFZI3z~_^knK9j%ov7dV(%qrJ#Y2j!G1+q XH4fq?{jEskEchYk$Pjv!+~5BR9khX6 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-MAKE-RANDOM-STATE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-MAKE-RANDOM-STATE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..17224dafa9fec77f05632faebea8804d82a564ee GIT binary patch literal 1552 zcmbtU-D@LN6u&cRvq_r9BzA*l({&ngR|an+$*yc8BGc(j8#9^7&WG88q9sjDpxcx* z6+|p$5%*_5cRuDf zcb`mNQ8h{JU)}0$bOus?XSlU9l-BzLX}iBOXm_M_uuJc%hRNPrR@8do#bV4F^Rx$@ z)nR8%vUfV$Ypd@(Cl%)33bCqUX#v{5=9DU>a^+&V5Iekm zOGx$!A#E~35hWx^Ld5&nP0BX2Y+9{pjOt2*$=<%_Mqn1|Sj_a?R7o24x9CRa?al^{ zb9I{tgm@phk*cGscFoYe17S~ydpF$anogTAnzF=*7cZVk^1(NCu{D!T3E>FzoE_o&tpAoqy?bvFlD>B8 zw9vi#Mq*?nK)t`O-7pg06SCjEZY1iWFb&7gpKN6i6#S4MCuG!XKQa1({5)Rix1&lC z2!plUY~=uEult{iWFA#ytb*{`QH3aU0oY$=S~(~LC$E(a4tw4ITM(Lm1;Iw$BoU+D zO*bd2hQ3(C4@8$?;~F#RLJchXk|m1~9u>pzOacQ^vZ~nXGBug)nD7Nvp8{cP#j;sL z6d__J;E1X*MR%ICYM2d6=7K1k%(e}gPlcv=G&BW_NXX1I4U-y<-E?d@6o-VktmrG$ zw2DaEZCyEalh};P!e4OzBIrP}^oDxrmlE;l@p7z{i@fd%nPZ7c=khCdeUKQXc z*sF?$$~-7x98a-PeE|?ts$-f=ANxbNfWGtKoB4ais$#KVC_V*l@&_QLPS71a_xUV} zUjp$X&!YANKZD{co^8qVf1GK;6Wfh407M+Gp|E>?$KRR3%J+h=_;RliRTME9|j=ddCz^y?raaG z{H~Ih)>q*IU6Xp7!QF?p-Dj}gPu{2A0n+rWYBIP}=&`S&)occ{T6_w_U=f!c!)8IR y-|};temXx7PW~*PTk+gNWq|<+Sa99>clhvO8%Onbtp^7fa5PrKGLWmu+4u%Gkrb_@fSXqNjpdm;oo6U3LX1&kdA6%qLQR|Ai zl~C0PL8|s(skl+mJ`fkKy#T!wmC6UMt%TI7Ql(ycX)irgTL0Y;w*-9ZjlItcvs48Y1h=93^Tno;i3@qJ}Y-*Of?6gX=9X#ZFLkx7rb&H znNp9dmS&E!EV*%Y*Cj%v6Jc3IXTB-jn-K1v7goQW5c56Ju+Z8DjvlV!H|2i^e5VUa zHLpyDs-;O8{yX76Qe~klmzjL4kA(z?2?espI$0zJ`cGM;6rJpZ)hr}}-K`%B(Hc-! zHQ)7gpcnuN&w=@=(ECjLgCzjyc&;Zu6pmHjBLt&|#nqX6z;s^Px>qRO1;1Db*gq@A zXDoD|kV@$j7Mc(dwQ_5Bem@$49xkJ9^%JO=X7r$_ms>FT?ATgc|4 z`99dY&<)JVeD}*C#&6yxe}ngMSot`h0{h#u&Y~ZKdZBbacsZx~?@Z=<^Zgj);2rB_ zLrh$+$Cm)Wi>2nj7e3})PdjFSeKQJ)tCnOU2D~rI-Ep0nqZw>MbsSpDpq4t40f{+g z$Hi8@P22(<9**mpqmQc=bzBQNRQFrF)jn-IG%Jd*B2t?HxI6sMNOES0%V&UNC_4loGDHS@IU%P|}&g0ebD zy6((QkagB&{vfP*1Y7QE($r#X*t`Oo$D`jc>H<~6dEY1rNV_)+Qy`3P79IiN9uPLX zY3ym)4rscc(A0D0mF4872^|a*!dq}Gcj1^l3h8N~kV<6wfN8}8)*NIH0Bl%yEsL5> zcK{bqhY5)MUtqds(^@il0Mz2IP=KKWCUY>!Hk6z}QTz*Ru-!hL9btyrxFJyf6$YS> zQ+)#N8YqN%#c&ywSHNg124rMxDZ literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-1-CHARACTERATTRIBUTES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-1-CHARACTERATTRIBUTES.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6c3868e52a990ccd8d63af353244fefd342e812d GIT binary patch literal 1359 zcmcJP%}*0i5WwGVp|*U~R%SSzN9tbEUGfR9Y_20yN~mW%VS7#adKJ#u8dL*60<~zK%bdVZ3@DY-qBftunV-jU7M6%aNbtaq zWIRjfhHV9pq*bXcSohlvOUprNbes`6@{@veDew=cPibjQ&r*l#oH>+p#~Ag%NuEE6 zt`Q;~PsC-+?0sQlLV9 zu}_3l3-|5VgeOywi7fC(2x%i^vp93OR`(A5^A0`oAL!EY9eVU%(SdWm3!1iB zh!Z&)JodX)-L}RIyniiAtud21+Nc2*Yur`kh=|Hz_?n@?300?D&uR|io&yciYaI@| zmtD>#Wf^vK)JH%!8MVBema&~lR~3>h{Ta<|RkViMMKsh34UehJacoDkJ)ZNp8ft@p zHkDeJwVE9vfgexr8KCwMA)*PVrUe_{3!o-;k(#I^K?!35l%skOGtfQ9Vb(7rDkStZ zVdlG+pi`ICj}@)pCSQ>>YJ1jL4%N4!1H~J02*nGLydyfVh>j_7C@YdF(HRG`bOd6W zbB;Z3p%#Y&I&os*V!5lC#-zbDcFAzLd#>?FaJ-TD9YbqXqqYU_BWz(ASQYsuQYgN_ zp8b1(Xn)-}C}TsNza1pHaK|&zjpAXQb5EphHBh@Dyn)f}F}4?TR&)=FRG&z7H9~i{ zg@F!F*gwkiOBJPOh4v_O)9}BVRf;$2zZ$fy^kEVogJ;1b9GfG$!zgFko*tM6zHieN mt+)+t<$`B(RxjYC=)G187stRU`b2k5^fvu&Ax}?kZ~p*jsD@eq literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHA-CHAR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHA-CHAR-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..1c17bc96c8d0c17341307d6e2b102729870222bd GIT binary patch literal 1486 zcmb_c&2Jk;6rWuu#&&FDqkMo9!Zsw3E*%HEE=^nz-EKFr@n+ZTt_e}0Wo2(-OHORr z8zj^=Mdi@T>J<|a?SLxoJyjf#3axTLocRNgIB?+1g)3pkCL#nRE|oQUeqX0PDSaUmF^_qw9mjT^ znqciX-J1Q;86mSINbOFeN&hS^QZBzEVssptD&B^AoxqNOZ9XY(W&m~$2 zp(;9HB8*T11(5%lmk=$*wD59KRj?+lDx%->y%6PsE2d)jUNS4Vtu}5tA39A&XRC`i zg#1sv&~inSt)i~^d)&ud)W7S+iW)9cYSM~=_|RV{44tDenX@>HCAD0Tuw0M~Tt@fy z!?zLQ7Lo~`mGoWxQHguFjoOb({Mu+L$ptt2buwQJp+{7E=Jr!buKw^^{6LRW^|zjS zSC4;>P_KSRkC%9khV>pytc|l2c0ve65jtp8pY4-Ay5Yy88$uN1iNka0Blz$WgQq}m zrRdBK>IuY${m;EAQP#D~Mb>^?khIIHV&F?fYSC6qkq?nDAEalP&NnH_k|h_gp;#4z z&PVPKIB2e$ma@w8G-7nH0kWz{TBVGabz{{O3CDB)&bD-sj09pN92lYVj*E(6=myp+ zR=Hw{fhbLgijuaD`*sH6dx^}6{fPw-B13Fx;%xkJVN8RS?U-r8~TdIvi@LNpD5FQr(Z-+W0f-^ z=vOky#7{IPdVJ}b@hg&IVt){FhfLleQx{39Y8w@4a9-U00adm1cwun?5!*p|L%9Czx$_j$Qh* zzc&k~UVFB`R0bYkU=y?+^!WDQA-iNDj4L*SDa070_ zE(r7&0oD@qga4(!$ChYXHWbNH@QI12MN2Ux)g&V0AC@3|@r{WZ^92;2gXL=V1|+Hu{$mfkKi~B(?S*t?D{k4cv9@?V8=G9cz_I ZrfFIbLJ)=+L@AA1L;plWUo0FR{t44VwzdEO literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHANUMERIC-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHANUMERIC-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..03f20fe74109619176d66e8c50dadf7201d0f6f8 GIT binary patch literal 1124 zcmah|YjYD-7(SbjHcc<4RbU3FE|mx@oI=tR+aROc?Ma(6S#(Cgy@x zq~rL(Pw~-^k=cdeKll}KcF7 z)mF3CYRVhcy4P1)H5PtctW?JmtqN*)VUQEX9eUW0_U2D4QGH3eC&`?)=wGiX6jQx_NsMW3St=#tldJ2^#DRMiWMs^R3BmD6Z}Jbuu(6Lj-?>FJX6 zWQ%P7u@qVvIWj6mZueRYV#9h>iWwKO~i&{Aq~u-<{>3jK2u!lzudpLXxPy zU;6FfN{_n;M+q4cfaT&?rxY*8Nhsp|+CHXerZJxjxKPpFyv{5-mlGai!B#>Cgh-=` zrgCkOT8ulEAgT3K>a$mE&hjDY-x=Ig{K0U)KM;-zVMY{YS*ArzhZh{Kga<^ykfIu^ zwCA@KUnmq$z9Dpfm=OO!pzc6jfb?ZeE3fiuaGB;<7Bluu&6jQn|2waEXsXTj(EY(n zg5yZSFnMsJEm-O7f&hHWUd_*$I(;$6b0RI4U{{#+BI}fY=(vCQh<~WRBGAY7Pp?3O z!M@y;z;Fa+q(>+()}zk|+SOJ6*p%?cUaL*`-g#xySAL(E`y-0P;HVh$SS!H~rQ7LmgemZ2jL111W% z3=1|m99+Q)u3{CRVhy)Y#5!DT;5JGq;|qL=3O2EYDr)!&bu`dK3wQ7}zQH!WmApq@ nHzdS-SF@PP8GU17dX6(o)op(;NE3Qqc1+IvqvYYq-Q9lx2YF;H literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-BOTH-CASE-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-BOTH-CASE-P.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..7460aa146936397bdba0cdadf70bf0e3dd353167 GIT binary patch literal 1170 zcmah|?^7E^7~V@t2uZ-u5uB;TUa{2nWRavqDOKxnY)Ig8NAEVJ_!~oLVgrf!QLVMu zVWy5B;#1Sq&YcebgX6ba$A0i1@;|`c)GE{u&V9IjpWXL)-{*OEJEZT5VX8)Tt5&WQ z>uR;tthJizX0@(1s;zpVsBQ{ey=mAEyOq(6<*5sahAR)gb4u|TYaPLrbyClCy0z10fA5%&Xf49W?&(899 z)*pm)O5a#Z0Yz}$EB!pO+OtG#hY5)h^0-_$+9}1$aT4hBerO-p4BJ}BN{KY1TMH(0 z=zLZn)}pHgjtK9DHACk{hB}Pr9iiRmnHO@`T+VU<<-aGmt@+VlzdsNR3%`am<~X)P z?L1$}b1gU^5@MQetJk2=fkA`LaT~Q}~V9Zp`|DP)*gKL7juUEPtZc)gRt(&X}b6q^74Yj=e-0kT&3fE(nRSK^_nfOh^okfp`F^5)uOOfZ$~k59RyL zNt&=d5RLIflB3`Gedjyh-*fM|S(SX};-(s3ytGs*7b@!Fa&2k3rp_-`)av4LC0|hI zQLbK%Tek7!gdU%aog8dT?^wxK3b|TgPIZLMmPy8)gq3vH zNNOoeO&>QT#lLBVtjlhF@8EsfkQSfNZOxd@=%#ez)!@^T|yVBjJ$TaFIv3eh~4_ABJ5Fhw(3bCj6s1ifJoSWdBF%ypKJ+kNI8!0~?rswkO-0 z9cacTcL}K~AhuC@8<*Rj-gCEHd~>#S!)itPw^j2+tM#Xnv|4=DYMoT%7M$KZknJP$ zxbBxEG__I6M>pQ^tncWNa(=5vesbEC?P`*w^*)-bq_#D(v8@?341Z8kZk`qI^i~`J^4**5#ng(k?KnDcbYhw>J!7@sOqBOnt#X4Ty*C@)DCey3KURy+ zS>f^%h%2R6aHhWhlokFJ?Pzzc4y&^l4LoOc7Q?e0XwGU?(D2RgWBA{ELq0*ida^yc z@ulDKb$;8|uXpWBdWY9{H=aIzR@tuI*#ECGSt)*!ZTCI3)pk0?bo_Rg!pAQWJ_hSc zS5M(vC5uD5%jcu8p{9=*dh<8?)@Gbd<@8 z{L$Tx6=hAHy|~~{JEL?3r0?7@bUS#0xU?s2OeJuc1wA1a@U)?*A(M*hX#*wuNWrwS zo3tJ8n%1ac+m@|a87Gx-qMo}@r8%l6XEZLSSUepl3nVdN-AqmBXlFkP{3*PiC%qYfU2c1^X3R@BS~uNJ51}WoaaK2pSV$TuQQaYGqOnjsW7|e@$Mwl%T04bn?b`*X zxJ6v7iI(@FC7*HDuxF5Yzr_v{9A*az4zfc8&8!Q-bBnKe_H$6aE1-{SDo41cau?T> z|H{|op9#3ZRpjejMSel3*yy$iqr%=ANgU`vK7g|3^vu+VWonpbh70|a>4=p{j;2sY z`U|6CNWWtdg0}?wj$n1xeU(KXX5A)>#8~$s7I_erd|ApcWn1G(VuQqZUx@YL$3sJs z>d4D_fE_`p_gy@s0qTn$cMO{(-^N`n+g}VMy1;q~9$-faWY&Y=`G6bn{8_*^xQger zfG)17yw91kE?7yhF~M566-DOT<-ZGfhp)*$5%4u^XK*_bZQQmpDMsHf@(SNAUl!Yn z0umUx*TmyY8b>LODSa}Ne`4(f ze`Ngxw*>nG8zA-@!G10@f5`Te@CQP3U9j&7&DR9GE;OHKA=3P+(0oR)6*llV3q8W3 z=UH2p^*gL>nhhja+bI_9XPtel{|M`huz@h^yc;+BCfxd=d@)zi3Xd-5%If7(t*Cx( zNF`A&Un^9qq%`W*4?BfwO^saBBkFt(zlP`3(t`MqCD}E8434^Ach~3z(-pT3Jfqr& zo+2}Wr$aZ>tO?avKd-*G)2;XJ2%vOvVX;!Es&l3J`9h_zkjFWC%IB&DjKtf{VhGB; z+!MQJ+m6!h)_d?fw{m4WcC}RHWHYx?ty(D0)AmE$ihK*cf=vEBG!pz4S_s~Q0KqT8 zPw@Ij9LZ~LJvKaI;LF4i-_-mch1#9+Y}Msjdb3g#u{;aS1n1nf2Jk}wTA&#kh5r$E zEe7|(APm8Ma14&aXW+AN0`7-yh`^_y2aZ559ECpkG(@2v20()t+yldK5>CMbI8MWZ z@OgL$9)>T#EPN5J!k6JmxCSczHj3mkfwPc> tb1(zvX>U|?h#nc~pJL9RgI|a_Kj}BbJhULN?Xx(l1# zWp*}N#iA7vWU$84I#&rIQvAS&BEAGGdGJMw_$t1MuObK{BBJqrI5f=)eQ+NRXU_l5 z`Q3Bw?3vjuF!ZESLP~3+U2ixpYIVJK*F)8cow&zrl)pa^m``iO4cNEEOx85KZ3kxL7<&Vte=jUhROR`zwwA<#)<>!v%=X101 zz3nS7-2wnqz%F$$0McLp1aJ9i(NaxIS}K%ONt0JqG1v zL{_)2q%Hs;>}Jvet>%l`^&;G90`JSBaB6Bi10(h8X92kL!X2Zqw)0GCS5J}fm#xx8 zJ@pj;Tea8pR8fG#Lwc`ak3DSzJ9WSYd z^mu_N+OjDMaU2tp#1h1YiN%OTiA9JFk@3rjifkz>lA&5D<}YHNHZ65k5Xc=P zd_a|wDr@C6X-PL$O%X!@_GVkUh!X>caBLt=#xW(ThM^mhUbfcCmN<|h2}x1bPD@Ou zkibvp4vhDq0RZqIo#`wc(H#OBR8Pt!8hlEE2rWRiX!tR$Kq(uBs_lD$U`W?6t^DS} zD6*;YZE=DwpTr~7nRt{s1&>h&m?F>z z&94Ujc%^2$#}@O5yqDc`sO~u%XrtTl(6L2Y-ur=nkL8eX`n)`i)@}0bsiJz5e>SLg z{$6_9)4{vJCHfY{8@JV}uFZpMOt1pa*oST|FVSF=52yAH$A z_TX=f1V8H~eGvE)oRmj1HaQJ6a}<$}@XSN>`gxlC9#4L%H+gk`vV1W43{5WZzTIX7Vi1>pKQu-hSD?tR2(svPG#8(jn5fRaNf4U^w75d;l+&y!? zd(L;hduPtQyAHa~$XO)UR_b=ea!{?|)f*mKsyWE5H5}7IO9V$R%bKpdGAGINV^57o z^Lu7Y$0~YO2^kH`EfrTEMdQ;*sylXtJRChr-0}3(M0#>^EIK3Qvz+aoITPuLsr1zJ zSafIeDooS>04CU`rU!ro2!Y_TpGX->-VkRpSw&Q(1tk@%2Y!UCMJ(hMJ@ES{kXNgV z73;iJq03ou0R$j;+mFl?RN2UAYOn!cg}uQgzb~VTIkGfqRsllf4hv<6fxmzJ32{P{ z=OkU6)fLH5^c>i{8ovmDaJxStP)%QyZ_dN5D)7FX7fz2P`(fC=xeUPmi}ww}^47EQ zZ7ojRU)QsjwD{Kmte4-^;`0LRBahebKaD5_9T5O}0ob<9QMS@1>#Zhhq=T#wHCcN) z$$GxY+Sf_e+fCM32U&&DCTnjeS>I@~M#(F0zS$T6o%j->sZd^hN3c z76SifA@CO#0zc*8#~gfzg9Zmra!_I*_=kbuF9w32Irs?&Kjh#QJf!0R4G%tzhuC7j zq5^WdHmgzr*O(l-h19!DPQkEB*Uq-$b<8ppe1J|KPD7XM-LGpX4BCgCh(CKQa(}$Gva4d5eRu;iQ9;llZ_RIC&5!nX(&!pEk=y=U5t% z)7)7_)G3-Cxvo|ku7{qtkn1_N=~Y%y#d2Nbm5WvKW1*_`l1CTyS>PWsED}0;K^jF% zMRKK;kX_}s5ydVXreQAx*MbfDp^nJxtQYTk>)8xB|D|jm$7mSY;FAT-xU+BP0{=0p zOI&6bqEk=r%5;ekt5iM0q?)y=XD>Hu4VRWYgNLa(9BhQvifhN$9;e=e)H}OotxZ!e z!c^fAQWGEI`}t?!Kh#nT*~`_MW4XvIx)v(gOG}nxRZWZ5fWNaE@J2h&2Z4X2g-0ye z%eLo=5%>fDrHGUVzp*TE ly*=ywz<;1Mt3^22#KUJ>v*z0}b`{Rz;jY$b@UFD8^DhHwtBL>s literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..61e24482c38ceaecefbe7b555ff8e21d460eb485 GIT binary patch literal 2081 zcmb_dL2MgE6#ctSjAJ{-K}o7wNjj>8Dj7BqH$ZDj(XyQ+CeCiUUbjtE30!*n#q!Hpk4zsiW z&7b$*pP4_i4!sw&JkgrVty6|}0Lrk1T^~RaLg2sSCDRrySjto`PZeFAqiKKL_aZzOrC6Y*?+s*#+iWRy zd&RC}I?E170RG!vWU8oZR?g7<4e3=W?qBozbGkCmQ&XoY$dS7&$S(O_eB!v0QM4J= zRHiN1yb-+$Ag>H0WmNM;_4cfEs{!tpv-0_o)PNMO-ChEC;Oc!tQuWqzi7g|+&0p8^ z*Nnth0PEE^jl`@h_4D7Ght7{71-1x49AK+fCP9u})~~y)kppCvNSC$mAX!(sto;Yc z`fZmrc7Uw%BVE=w-<<9q!~hO%>*P1OA)^0RIG6Zril6$eY7*qAf885NYleO%hX+`h zQS~!j$uZvgdF$gX!dsZPUS2T+X-&1X8O5Yl(c~vy3rZ$jSSVO@ zPL{dHpr|P=PgT7*uS^-{Tp`UQS=v9_GSVy-O0d4r{k(z_X=<8=sTf6TzG$UGNj@Q- zR`mrXz>&oFk`wn-WFiE>daw)+VO6y_Q4c+*=Fuo~Ba8x63(eUbb8cQ}R(9*Fq;5M7ajT^U|JbBq zzvN<47kuxCWpme~SJb0qvBV#c3aK^3-H+In2hnZFf8XE0V>hOmRJEvb&mQJ;7B$s; zfyK~`Cx5nRSTqnWhkfrD>N=g>k>_v$cBOGFkXUXu+}cv7*>NzG%tmq1zVkOiYwFtN zwMWtV2Ca*0_S#9bJ`dEeF&>K@5$pI7&m#z;RBB5#*HQT6=+r8 literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LE.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..fffa1b0557ec9a48b4f3cede55dc198408f92126 GIT binary patch literal 2299 zcmb_dUuYaf7@yfB=jHBly+{)2(Ok!bKDfG}iK(_RLDuaiIdj=f_x9SR6m;2adWVv>z5%;t2(P-k^HTnU3H&jr+Co-Lnyj6zWIfwt z?P?|KohEC%g{;y*lQq#w*4LV>F*x$($;J_C-47vs*W4oce}#j@r_<0&>%|n3lHt{0 zpRAe2(JX5VWm+|k=5$MWDhr4)m6xR$?UWKQ;xM{kbi#VHI%d`}; zV9yn7xvd)l60&N{D;#GeVUQZWr`PwiAw=6*gQr=)eg#DB`f)YKoHcMFOn_=L_fw`o zD_E9pY`aY;W^*4frM=9|(LQD#0{Ra9xNgle5Ah}VPrd~I z#FyZY1^A%=-x8oLz+(bbIf(w^Ao_!Y=tlv5B*6Ctc$M~9w8x~qPtrb~>=#VHoMlcK zOu%(6hn0|dm*M`47%X>QidQL*(CJ<_IW9a!m<%fuyZ6Q?U=shp*WhpYB)%<7AV5Kb z>jHdCfPw~RIEcRIAo@mlUkmew0AHbLpQcCY-iK*=A5C*fH^X4RTXg*Ki7^5s;w*c zoM|p=>z10!(>PlOM)q0IASC$p0TrE1wjU~@7xm((5Y`2rN zpP2)|buo5vfPFu>?K{fF&y9Oeh=1^dlztF`l^}vh>30#oh+jnzL_|d6{OOsr2P$|Rb8p{o z-uumO-t3#*03D~43{tAAHK%O5s9N`HbssHPUF22kZox*&1V=9@x}m-}CoA)#PmFb$ zdu9r*o%ih`vg)>1%nV^c`3xlWlpOimJaZ2GbB>4}Nat{K_PaJGNV8J`}XoIX4` z+O@NJ6(*_xfCAX2rW1e!XanJ;AR$_+X-PBbj4EmJf+~g^VGt#Ik#eSLghAgp@~bte zY@fBubUUjafB=MV1kstCrdVlR3opZ$V0U;i=t*l*mTXO)Re=z_!$R3%81#-kDve9Z zoNP!L)ikqU^J@G80K)CQgg^y-TDmz8w<^H@Y+g8-O7_8sb8`iN`!C!#083j>$G7!3 zaevy#T-4)V0I*SdO^?qDu!lTef8Zpd6m&!Z=muchDGal1Hdt>pSfedug{Z;W*-F;4 z4c4Akvfgg6##+cK3^!Q2Tgm!rgSCqsdE;bb0JQFf5Wa0J5&yr!iNs?`(oWl@1Q6ok zm0-W9=-SaV?F?y7){bUWLwYJr5N*~Jg)ZDFbdwPyqlb)6GNNQe$mk&L*e5EorOZi& zYUK>lP73SCh`DH5>VhDUh<@I%N=B8nTvnRVjRjN0P=L+ZmM-F0TQBZxOOW=Ai>hJh zhNS1LY|awf`ba{zC~J!n!zoD^B*yM(_ue)Da69esB<ghHA8_zZ4q6;M&Ow=h;7E9YXqQWj#9%4ER)r#+|)T?!mu6GI#QFAc7+`hiFes0}fpQ8SQ)R)Qc%=%&KN0}^~ zB8%b!ysE#2!N|xID+DhM8p$K_$sRek7o*wm7q$qz(M9vjx5dc%C=8lj(-vaHu2EX-8}Pzqh721M~+!M)P8q9cuU^d`3tM` Bvw;8r literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LT.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..518f8fb7718cb54a0ad82e31dbc985e0190af899 GIT binary patch literal 2124 zcmb_dL2MgE6rEis#<3mapd?kSBpo%XDjBvUX+Vt$Ld$lOm^i!XdfhfrC2;LcY~k3} z?m7?<6%-*Pv`Pt4%MK_)2q6%sid#id4qPfg;=q9`CoUX7;(!Da;s2c&l18Wpau|>Q zn|W{EpP4_qNjfhnIjS^Po7I|S(?-i}wp_a0u&L8%*(HlE15RI7bVGe*R#xUtKQR`~ z?;9!ER?)S})NEN!xw!ra9h;1X;aOc(sVYbN}4>cru|Ldi$E??A+H*~*E3GtMpLR; zYgP@@S#^j&i2t@1nJ#FGnbkFaOL$d?``5khtR^i$YVwRq#K@isstdjsA3GzBOUkTl zNI8>i-;7=(L|p4hisLwJ>)6F%l)x4tBu>aqwM2s)+p1r;RU=2JD$urS*HNmjwN<;1 zQuW)mYU~JA#Yfw!aX6gz8N>)Vx}y`{XfF}{zsAAhGbyfLMK{)`) zUjaz|3_$WT2S4TD#~i%D`VH2rv%aTTe~{PnxYmN9&uHjF4OYh8!e|N}q_Bo*23boi zg?@fv1K9npv(y9| zc$lRISt_u5+4nM~O3|LmP^S})ohPBvnzKhQ$O^*leNYRKqwU*3r@#{ gQ~NKOZ8o%YP+|_~t!DH7^cgnPaga*hdvbU8Z*kpVdH?_b literal 0 HcmV?d00001 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-EQUAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-EQUAL.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..ae1c7bacb7e21cb0dd5899fb44e8f6dccec9b3fa GIT binary patch literal 2610 zcmb_e+i%lW7(aH}lJrIbRadf(nbJZ@aiJ}2P?(tOx@~A`r;bA?8|y;ql8iJdNlLkl z%isZoq7MoJ`D{Yk-q6HD2igMz6iu77hdphKe_&73_OfZ(9>>08(;G}0NJu{V&UgEL zm*exC&E1`y z?Uj#jT<5%5LP&y?81WF|B`#uJDS88j5;4TSU`P>FX-ElJGgi@!wTRJ(qFY5@r%=dF zifQwRnP%lok5_)Ku##cZRFBE){Ensu;%7q<)3)?k6Y=owJH7JG#V9 zQ67+VQPm7l8IDRJa^rgCSwdWmJ}=Lbx|h5^$lcA5Umpzeu_nKdt2k(9db<(n{DY|{ z{eFD>yZv7kQOsPCMeYU7?S2R)^oj|5OyH9KDr`_|DRm!3E6y%k#U<~K)|RwdWPhIt zUD9g5A!H_bUaKACxfKg8ZM;~d8KQNDaOKZ^l>k#0Ah9^1NfN)wZkHE8cF!|eu zULcY*A8Fr0q@SKM(wXGTYm}>Pu2IXM{{{N*)5Y?4`|&+5CB1}SZe1%j24qd`4YJ!N z4oGTmNYTZfAWGE!NPw@Q9^Qk?jjIAzIbLgDK$Z-7K-3i@s^hhk?R#Aj8HpIm5YMAU zopbT!kRqwku-K>RLy-XGcPeCqQjL(REE1 zwWtw}8Ufczbg2$V>WFB|8NRCyWu7^h9_qD<-j1h6jJKQ+TE^zeDmEYL5xGp+BZU~_ zL8gKwD;bQfVA;x1U02jaLyU5$Gr7Q^lDfKfl&ERoD zVa|-Lq^~03F50HtdE1nmwoSP(nwBej6rEXeZH`H+W71%okUwm9@|~?C-`YCzrK7uu z?p2r_o|B^D+K+s7WMrsE3yD~3R0*+EdbFt88*ZnoU!$)#V;q-{MGfm(zsmCajd6Bw z8TT`eWlSD>!&=2Zq)m)mqiYx`I^0QzY{j?A!%k9?4Mk^q`}~#;XcTkb)3uD;q%1m@ zwz0T`4Z;}?2|Bt;M^|PG$zKln#nzFp?W0&S{l$J=i-xHeVaeyVEBVavxk8&xV_jvT zV8l3to0=hMFsj;}*hhUaR`PIEGZcgRhM8SNF@}TGx09}KqjjycwT0F-(G7lD=R<54 zZxuHslJT6F$reQO@KikAEyUAlfyv^Df|<(;6I1zuaKIGCQu#tElPI7Y|BqFC-7rz! zbV_Ox#^d<)9ura-=flfnr&^fVJ?j(eD!WdrWnIBj6rXzELP2b=6pGL)G^4G~QQWeM z>zAe^qz-1XIWsRL;(3RSo#C8z;JTiLYqp9lYIXrgNImT@qzZX6J7%Q6rNot#<88muF^!cl62(20mG(snxZs-(6Zem#?EfKUbmz|pq0IeEjhMX z+byM{Ksg|xRZCj6>`+ArA%4UGRXrd@6h(*&s<